GitHub/gf-core
1
0
Fork 1
mirror of https://github.com/GrammaticalFramework/gf-core.git synced 2026-04-21 02:39:31 -06:00
Code Issues Packages Projects Releases Wiki Activity

preparation for dep. types. The -cat option can take any type instead of just a category. The PGF API is generalized as well.

Browse Source
This commit is contained in:
krasimir
2008-10-20 08:42:39 +00:00
parent 96bea5a0bb
commit eb0fefec28
9 changed files with 130 additions and 129 deletions
Download Patch File Download Diff File Expand all files Collapse all files

37
src/GF/Command/Abstract.hs
View File

@@ -1,5 +1,6 @@
module GF.Command.Abstract where
import PGF.CId
import PGF.Data
type Ident = String
@@ -19,7 +20,7 @@ data Option
data Value
= VId Ident
| VInt Integer
| VInt Int
| VStr String
deriving (Eq,Ord,Show)
@@ -29,27 +30,25 @@ data Argument
| AMacro Ident
deriving (Eq,Ord,Show)
valIdOpts :: String -> String -> [Option] -> String
valIdOpts flag def opts = case valOpts flag (VId def) opts of
VId v -> v
_ -> def
valCIdOpts :: String -> CId -> [Option] -> CId
valCIdOpts flag def opts =
case [v | OFlag f (VId v) <- opts, f == flag] of
(v:_) -> mkCId v
_ -> def
valIntOpts :: String -> Integer -> [Option] -> Int
valIntOpts flag def opts = fromInteger $ case valOpts flag (VInt def) opts of
VInt v -> v
_ -> def
valIntOpts :: String -> Int -> [Option] -> Int
valIntOpts flag def opts =
case [v | OFlag f (VInt v) <- opts, f == flag] of
(v:_) -> v
_ -> def
valStrOpts :: String -> String -> [Option] -> String
valStrOpts flag def opts = case valOpts flag (VStr def) opts of
VStr v -> v
_ -> def
valOpts :: String -> Value -> [Option] -> Value
valOpts flag def opts = case lookup flag flags of
Just v -> v
_ -> def
where
flags = [(f,v) | OFlag f v <- opts]
valStrOpts flag def opts =
case [v | OFlag f v <- opts, f == flag] of
(VStr v:_) -> v
(VId v:_) -> v
(VInt v:_) -> show v
_ -> def
isOpt :: String -> [Option] -> Bool
isOpt o opts = elem o [x | OOpt x <- opts]

74
src/GF/Command/Commands.hs
View File

@@ -164,7 +164,7 @@ allCommands cod pgf = Map.fromList [
],
exec = \opts _ -> do
let pgfr = optRestricted opts
ts <- generateRandom pgfr (optCat opts)
ts <- generateRandom pgfr (optType opts)
return $ fromTrees $ take (optNum opts) ts
}),
("gt", emptyCommandInfo {
@@ -185,7 +185,7 @@ allCommands cod pgf = Map.fromList [
exec = \opts _ -> do
let pgfr = optRestricted opts
let dp = return $ valIntOpts "depth" 4 opts
let ts = generateAllDepth pgfr (optCat opts) dp
let ts = generateAllDepth pgfr (optType opts) dp
return $ fromTrees $ take (optNumInf opts) ts
}),
("h", emptyCommandInfo {
@@ -285,8 +285,8 @@ allCommands cod pgf = Map.fromList [
synopsis = "start a morphology quiz",
exec = \opts _ -> do
let lang = optLang opts
let cat = optCat opts
morphologyQuiz cod pgf lang cat
let typ = optType opts
morphologyQuiz cod pgf lang typ
return void,
flags = [
("lang","language of the quiz"),
@@ -405,7 +405,7 @@ allCommands cod pgf = Map.fromList [
("tree","convert strings into trees")
],
exec = \opts arg -> do
let file = valIdOpts "file" "_gftmp" opts
let file = valStrOpts "file" "_gftmp" opts
s <- readFile file
return $ case opts of
_ | isOpt "lines" opts && isOpt "tree" opts ->
@@ -420,10 +420,10 @@ allCommands cod pgf = Map.fromList [
longname = "translation_quiz",
synopsis = "start a translation quiz",
exec = \opts _ -> do
let from = valIdOpts "from" (optLang opts) opts
let to = valIdOpts "to" (optLang opts) opts
let cat = optCat opts
translationQuiz cod pgf from to cat
let from = valCIdOpts "from" (optLang opts) opts
let to = valCIdOpts "to" (optLang opts) opts
let typ = optType opts
translationQuiz cod pgf from to typ
return void,
flags = [
("from","translate from this language"),
@@ -516,7 +516,7 @@ allCommands cod pgf = Map.fromList [
longname = "write_file",
synopsis = "send string or tree to a file",
exec = \opts arg -> do
let file = valIdOpts "file" "_gftmp" opts
let file = valStrOpts "file" "_gftmp" opts
if isOpt "append" opts
then appendFile file (enc (toString arg))
else writeFile file (enc (toString arg))
@@ -530,7 +530,7 @@ allCommands cod pgf = Map.fromList [
where
enc = encodeUnicode cod
lin opts t = unlines [linearize pgf lang t | lang <- optLangs opts]
par opts s = concat [parse pgf lang (optCat opts) s | lang <- optLangs opts, canParse pgf lang]
par opts s = concat [parse pgf lang (optType opts) s | lang <- optLangs opts, canParse pgf lang]
void = ([],[])
@@ -539,21 +539,21 @@ allCommands cod pgf = Map.fromList [
_ -> unlines [linear opts lang t | lang <- optLangs opts]
linear opts lang = let unl = unlex opts lang in case opts of
_ | isOpt "all" opts -> allLinearize unl pgf (mkCId lang)
_ | isOpt "table" opts -> tableLinearize unl pgf (mkCId lang)
_ | isOpt "term" opts -> termLinearize pgf (mkCId lang)
_ | isOpt "record" opts -> recordLinearize pgf (mkCId lang)
_ | isOpt "all" opts -> allLinearize unl pgf lang
_ | isOpt "table" opts -> tableLinearize unl pgf lang
_ | isOpt "term" opts -> termLinearize pgf lang
_ | isOpt "record" opts -> recordLinearize pgf lang
_ -> unl . linearize pgf lang
treebank opts t = unlines $
(abstractName pgf ++ ": " ++ showTree t) :
[lang ++ ": " ++ linear opts lang t | lang <- optLangs opts]
(prCId (abstractName pgf) ++ ": " ++ showTree t) :
[prCId lang ++ ": " ++ linear opts lang t | lang <- optLangs opts]
unlex opts lang = stringOps (getUnlex opts lang ++ map prOpt opts)
getUnlex opts lang = case words (valStrOpts "unlexer" "" opts) of
lexs -> case lookup lang
[(la,tail le) | lex <- lexs, let (la,le) = span (/='=') lex, not (null le)] of
[(mkCId la,tail le) | lex <- lexs, let (la,le) = span (/='=') lex, not (null le)] of
Just le -> chunks ',' le
_ -> []
@@ -571,13 +571,17 @@ allCommands cod pgf = Map.fromList [
_ -> map prOpt opts
optRestricted opts =
restrictPGF (\f -> and [hasLin pgf (mkCId la) f | la <- optLangs opts]) pgf
restrictPGF (\f -> and [hasLin pgf la f | la <- optLangs opts]) pgf
optLangs opts = case valIdOpts "lang" "" opts of
optLangs opts = case valStrOpts "lang" "" opts of
"" -> languages pgf
lang -> chunks ',' lang
optLang opts = head $ optLangs opts ++ ["#NOLANG"]
optCat opts = valIdOpts "cat" (lookStartCat pgf) opts
lang -> map mkCId (chunks ',' lang)
optLang opts = head $ optLangs opts ++ [wildCId]
optType opts =
let str = valStrOpts "cat" (lookStartCat pgf) opts
in case readType str of
Just ty -> ty
Nothing -> error ("Can't parse '"++str++"' as type")
optComm opts = valStrOpts "command" "" opts
optViewFormat opts = valStrOpts "format" "ps" opts
optViewGraph opts = valStrOpts "view" "gv" opts
@@ -591,17 +595,17 @@ allCommands cod pgf = Map.fromList [
toString = unwords . toStrings
prGrammar opts = case opts of
_ | isOpt "cats" opts -> unwords $ categories pgf
_ | isOpt "cats" opts -> unwords $ map prCId $ categories pgf
_ | isOpt "fullform" opts -> concatMap
(prFullFormLexicon . buildMorpho pgf . mkCId) $ optLangs opts
(prFullFormLexicon . buildMorpho pgf) $ optLangs opts
_ | isOpt "missing" opts ->
unlines $ [unwords (la:":": map prCId cs) |
la <- optLangs opts, let cs = missingLins pgf (mkCId la)]
_ -> case valIdOpts "printer" "pgf" opts of
unlines $ [unwords (prCId la:":": map prCId cs) |
la <- optLangs opts, let cs = missingLins pgf la]
_ -> case valStrOpts "printer" "pgf" opts of
v -> concatMap snd $ exportPGF noOptions (read v) pgf
morphos opts s =
[lookupMorpho (buildMorpho pgf (mkCId la)) s | la <- optLangs opts]
[lookupMorpho (buildMorpho pgf la) s | la <- optLangs opts]
-- ps -f -g s returns g (f s)
stringOps opts s = foldr app s (reverse opts) where
@@ -643,14 +647,14 @@ stringOpOptions = [
treeOpOptions pgf = [(op,expl) | (op,(expl,_)) <- allTreeOps pgf]
translationQuiz :: String -> PGF -> Language -> Language -> Category -> IO ()
translationQuiz cod pgf ig og cat = do
tts <- translationList pgf ig og cat infinity
translationQuiz :: String -> PGF -> Language -> Language -> Type -> IO ()
translationQuiz cod pgf ig og typ = do
tts <- translationList pgf ig og typ infinity
mkQuiz cod "Welcome to GF Translation Quiz." tts
morphologyQuiz :: String -> PGF -> Language -> Category -> IO ()
morphologyQuiz cod pgf ig cat = do
tts <- morphologyList pgf ig cat infinity
morphologyQuiz :: String -> PGF -> Language -> Type -> IO ()
morphologyQuiz cod pgf ig typ = do
tts <- morphologyList pgf ig typ infinity
mkQuiz cod "Welcome to GF Morphology Quiz." tts
-- | the maximal number of precompiled quiz problems

16
src/GF/Quiz.hs
View File

@@ -39,19 +39,19 @@ mkQuiz cod msg tts = do
teachDialogue qas msg
translationList ::
PGF -> Language -> Language -> Category -> Int -> IO [(String,[String])]
translationList pgf ig og cat number = do
ts <- generateRandom pgf cat >>= return . take number
PGF -> Language -> Language -> Type -> Int -> IO [(String,[String])]
translationList pgf ig og typ number = do
ts <- generateRandom pgf typ >>= return . take number
return $ map mkOne $ ts
where
mkOne t = (norml (linearize pgf ig t), map (norml . linearize pgf og) (homonyms t))
homonyms = nub . parse pgf ig cat . linearize pgf ig
homonyms = nub . parse pgf ig typ . linearize pgf ig
morphologyList :: PGF -> Language -> Category -> Int -> IO [(String,[String])]
morphologyList pgf ig cat number = do
ts <- generateRandom pgf cat >>= return . take (max 1 number)
morphologyList :: PGF -> Language -> Type -> Int -> IO [(String,[String])]
morphologyList pgf ig typ number = do
ts <- generateRandom pgf typ >>= return . take (max 1 number)
gen <- newStdGen
let ss = map (tabularLinearize pgf (mkCId ig)) ts
let ss = map (tabularLinearize pgf ig) ts
let size = length (head ss)
let forms = take number $ randomRs (0,size-1) gen
return [(head (snd (head pws)) +++ par, ws) |