summaryrefslogtreecommitdiff
path: root/src/GF/Command
diff options
context:
space:
mode:
Diffstat (limited to 'src/GF/Command')
-rw-r--r--src/GF/Command/Abstract.hs67
-rw-r--r--src/GF/Command/Commands.hs603
-rw-r--r--src/GF/Command/Importing.hs37
-rw-r--r--src/GF/Command/Interpreter.hs121
-rw-r--r--src/GF/Command/Parse.hs48
5 files changed, 876 insertions, 0 deletions
diff --git a/src/GF/Command/Abstract.hs b/src/GF/Command/Abstract.hs
new file mode 100644
index 000000000..29111b432
--- /dev/null
+++ b/src/GF/Command/Abstract.hs
@@ -0,0 +1,67 @@
+module GF.Command.Abstract where
+
+import PGF.Data
+
+type Ident = String
+
+type CommandLine = [Pipe]
+
+type Pipe = [Command]
+
+data Command
+ = Command Ident [Option] Argument
+ deriving (Eq,Ord,Show)
+
+data Option
+ = OOpt Ident
+ | OFlag Ident Value
+ deriving (Eq,Ord,Show)
+
+data Value
+ = VId Ident
+ | VInt Integer
+ | VStr String
+ deriving (Eq,Ord,Show)
+
+data Argument
+ = ATree Tree
+ | ANoArg
+ | 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
+
+valIntOpts :: String -> Integer -> [Option] -> Int
+valIntOpts flag def opts = fromInteger $ case valOpts flag (VInt def) opts of
+ VInt 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]
+
+isOpt :: String -> [Option] -> Bool
+isOpt o opts = elem o [x | OOpt x <- opts]
+
+isFlag :: String -> [Option] -> Bool
+isFlag o opts = elem o [x | OFlag x _ <- opts]
+
+prOpt :: Option -> String
+prOpt o = case o of
+ OOpt i -> i
+ OFlag f x -> f ++ "=" ++ show x
+
+mkOpt :: String -> Option
+mkOpt = OOpt
+
diff --git a/src/GF/Command/Commands.hs b/src/GF/Command/Commands.hs
new file mode 100644
index 000000000..96e7c57f4
--- /dev/null
+++ b/src/GF/Command/Commands.hs
@@ -0,0 +1,603 @@
+module GF.Command.Commands (
+ allCommands,
+ lookCommand,
+ exec,
+ isOpt,
+ options,
+ flags,
+ CommandInfo,
+ CommandOutput
+ ) where
+
+import PGF
+import PGF.CId
+import PGF.ShowLinearize
+import PGF.Macros
+import PGF.Data ----
+import PGF.Morphology
+import PGF.Quiz
+import PGF.VisualizeTree
+import GF.Compile.Export
+import GF.Infra.Option (noOptions)
+import GF.Infra.UseIO
+import GF.Data.ErrM ----
+import PGF.Expr (readTree)
+import GF.Command.Abstract
+import GF.Text.Lexing
+import GF.Text.Transliterations
+
+import GF.Data.Operations
+
+import Data.Maybe
+import qualified Data.Map as Map
+import System.Cmd
+
+import Debug.Trace
+
+type CommandOutput = ([Tree],String) ---- errors, etc
+
+data CommandInfo = CommandInfo {
+ exec :: [Option] -> [Tree] -> IO CommandOutput,
+ synopsis :: String,
+ syntax :: String,
+ explanation :: String,
+ longname :: String,
+ options :: [(String,String)],
+ flags :: [(String,String)],
+ examples :: [String]
+ }
+
+emptyCommandInfo :: CommandInfo
+emptyCommandInfo = CommandInfo {
+ exec = \_ ts -> return (ts,[]), ----
+ synopsis = "",
+ syntax = "",
+ explanation = "",
+ longname = "",
+ options = [],
+ flags = [],
+ examples = []
+ }
+
+lookCommand :: String -> Map.Map String CommandInfo -> Maybe CommandInfo
+lookCommand = Map.lookup
+
+commandHelpAll :: PGF -> [Option] -> String
+commandHelpAll pgf opts = unlines
+ [commandHelp (isOpt "full" opts) (co,info)
+ | (co,info) <- Map.assocs (allCommands pgf)]
+
+commandHelp :: Bool -> (String,CommandInfo) -> String
+commandHelp full (co,info) = unlines $ [
+ co ++ ", " ++ longname info,
+ synopsis info] ++ if full then [
+ "",
+ "syntax:" ++++ " " ++ syntax info,
+ "",
+ explanation info,
+ "options:" ++++ unlines [" -" ++ o ++ "\t" ++ e | (o,e) <- options info],
+ "flags:" ++++ unlines [" -" ++ o ++ "\t" ++ e | (o,e) <- flags info],
+ "examples:" ++++ unlines [" " ++ s | s <- examples info]
+ ] else []
+
+-- this list must no more be kept sorted by the command name
+allCommands :: PGF -> Map.Map String CommandInfo
+allCommands pgf = Map.fromList [
+ ("cc", emptyCommandInfo {
+ longname = "compute_concrete",
+ syntax = "cc (-all | -table | -unqual)? TERM",
+ synopsis = "computes concrete syntax term using a source grammar",
+ explanation = unlines [
+ "Compute TERM by concrete syntax definitions. Uses the topmost",
+ "module (the last one imported) to resolve constant names.",
+ "N.B.1 You need the flag -retain when importing the grammar, if you want",
+ "the definitions to be retained after compilation.",
+ "N.B.2 The resulting term is not a tree in the sense of abstract syntax",
+ "and hence not a valid input to a Tree-expecting command.",
+ "This command must be a line of its own, and thus cannot be a part",
+ "of a pipe."
+ ],
+ options = [
+ ("all","pick all strings (forms and variants) from records and tables"),
+ ("table","show all strings labelled by parameters"),
+ ("unqual","hide qualifying module names")
+ ]
+ }),
+ ("dc", emptyCommandInfo {
+ longname = "define_command",
+ syntax = "dc IDENT COMMANDLINE",
+ synopsis = "define a command macro",
+ explanation = unlines [
+ "Defines IDENT as macro for COMMANDLINE, until IDENT gets redefined.",
+ "A call of the command has the form %IDENT. The command may take an",
+ "argument, which in COMMANDLINE is marked as ?0. Both strings and",
+ "trees can be arguments. Currently at most one argument is possible.",
+ "This command must be a line of its own, and thus cannot be a part",
+ "of a pipe."
+ ]
+ }),
+ ("dt", emptyCommandInfo {
+ longname = "define_tree",
+ syntax = "dt IDENT (TREE | STRING | \"<\" COMMANDLINE)",
+ synopsis = "define a tree or string macro",
+ explanation = unlines [
+ "Defines IDENT as macro for TREE or STRING, until IDENT gets redefined.",
+ "The defining value can also come from a command, preceded by \"<\".",
+ "If the command gives many values, the first one is selected.",
+ "A use of the macro has the form %IDENT. Currently this use cannot be",
+ "a subtree of another tree. This command must be a line of its own",
+ "and thus cannot be a part of a pipe."
+ ],
+ examples = [
+ ("dt ex \"hello world\" -- define ex as string"),
+ ("dt ex UseN man_N -- define ex as string"),
+ ("dt ex < p -cat=NP \"the man in the car\" -- define ex as parse result"),
+ ("l -lang=LangSwe %ex | ps -to_utf8 -- linearize the tree ex")
+ ]
+ }),
+ ("e", emptyCommandInfo {
+ longname = "empty",
+ synopsis = "empty the environment"
+ }),
+ ("gr", emptyCommandInfo {
+ longname = "generate_random",
+ synopsis = "generate random trees in the current abstract syntax",
+ syntax = "gr [-cat=CAT] [-number=INT]",
+ examples = [
+ "gr -- one tree in the startcat of the current grammar",
+ "gr -cat=NP -number=16 -- 16 trees in the category NP"
+ ],
+ explanation = unlines [
+ "Generates a list of random trees, by default one tree."
+---- "If a tree argument is given, the command completes the Tree with values to",
+---- "the metavariables in the tree."
+ ],
+ flags = [
+ ("cat","generation category"),
+ ("lang","excludes functions that have no linearization in this language"),
+ ("number","number of trees generated")
+ ],
+ exec = \opts _ -> do
+ let pgfr = optRestricted opts
+ ts <- generateRandom pgfr (optCat opts)
+ return $ fromTrees $ take (optNum opts) ts
+ }),
+ ("gt", emptyCommandInfo {
+ longname = "generate_trees",
+ synopsis = "generates a list of trees, by default exhaustive",
+ explanation = unlines [
+ "Generates all trees of a given category, with increasing depth.",
+ "By default, the depth is 4, but this can be changed by a flag."
+ ---- "If a Tree argument is given, the command completes the Tree with values",
+ ---- "to the metavariables in the tree."
+ ],
+ flags = [
+ ("cat","the generation category"),
+ ("depth","the maximum generation depth"),
+ ("lang","excludes functions that have no linearization in this language"),
+ ("number","the number of trees generated")
+ ],
+ exec = \opts _ -> do
+ let pgfr = optRestricted opts
+ let dp = return $ valIntOpts "depth" 4 opts
+ let ts = generateAllDepth pgfr (optCat opts) dp
+ return $ fromTrees $ take (optNumInf opts) ts
+ }),
+ ("h", emptyCommandInfo {
+ longname = "help",
+ syntax = "h (-full)? COMMAND?",
+ synopsis = "get description of a command, or a the full list of commands",
+ explanation = unlines [
+ "Displays information concerning the COMMAND.",
+ "Without argument, shows the synopsis of all commands."
+ ],
+ options = [
+ ("full","give full information of the commands")
+ ],
+ exec = \opts ts -> return ([], case ts of
+ [t] -> let co = showTree t in
+ case lookCommand co (allCommands pgf) of ---- new map ??!!
+ Just info -> commandHelp True (co,info)
+ _ -> "command not found"
+ _ -> commandHelpAll pgf opts)
+ }),
+ ("i", emptyCommandInfo {
+ longname = "import",
+ synopsis = "import a grammar from source code or compiled .pgf file",
+ explanation = unlines [
+ "Reads a grammar from File and compiles it into a GF runtime grammar.",
+ "If a grammar with the same concrete name is already in the state",
+ "it is overwritten - but only if compilation succeeds.",
+ "The grammar parser depends on the file name suffix:",
+ " .gf normal GF source",
+ " .gfo compiled GF source",
+ " .pgf precompiled grammar in Portable Grammar Format"
+ ],
+ options = [
+ -- ["prob", "retain", "gfo", "src", "no-cpu", "cpu", "quiet", "verbose"]
+ ("retain","retain operations (used for cc command)"),
+ ("src", "force compilation from source"),
+ ("v", "be verbose - show intermediate status information")
+ ]
+ }),
+ ("l", emptyCommandInfo {
+ longname = "linearize",
+ synopsis = "convert an abstract syntax expression to string",
+ explanation = unlines [
+ "Shows the linearization of a Tree by the grammars in scope.",
+ "The -lang flag can be used to restrict this to fewer languages.",
+ "A sequence of string operations (see command ps) can be given",
+ "as options, and works then like a pipe to the ps command, except",
+ "that it only affect the strings, not e.g. the table labels.",
+ "These can be given separately to each language with the unlexer flag",
+ "whose results are prepended to the other lexer flags. The value of the",
+ "unlexer flag is a space-separated list of comma-separated string operation",
+ "sequences; see example."
+ ],
+ examples = [
+ "l -langs=LangSwe,LangNor no_Utt -- linearize tree to LangSwe and LangNor",
+ "gr -lang=LangHin -cat=Cl | l -table -to_devanagari -to_utf8 -- hindi table",
+ "l -unlexer=\"LangSwe=to_utf8 LangHin=to_devanagari,to_utf8\" -- different lexers"
+ ],
+ exec = \opts -> return . fromStrings . map (optLin opts),
+ options = [
+ ("all","show all forms and variants"),
+ ("record","show source-code-like record"),
+ ("table","show all forms labelled by parameters"),
+ ("term", "show PGF term"),
+ ("treebank","show the tree and tag linearizations with language names")
+ ] ++ stringOpOptions,
+ flags = [
+ ("lang","the languages of linearization (comma-separated, no spaces)"),
+ ("unlexer","set unlexers separately to each language (space-separated)")
+ ]
+ }),
+ ("ma", emptyCommandInfo {
+ longname = "morpho_analyse",
+ synopsis = "print the morphological analyses of all words in the string",
+ explanation = unlines [
+ "Prints all the analyses of space-separated words in the input string,",
+ "using the morphological analyser of the actual grammar (see command pf)"
+ ],
+ exec = \opts ->
+ return . fromString . unlines .
+ map prMorphoAnalysis . concatMap (morphos opts) .
+ concatMap words . toStrings
+ }),
+
+ ("mq", emptyCommandInfo {
+ longname = "morpho_quiz",
+ synopsis = "start a morphology quiz",
+ exec = \opts _ -> do
+ let lang = optLang opts
+ let cat = optCat opts
+ morphologyQuiz pgf lang cat
+ return void,
+ flags = [
+ ("lang","language of the quiz"),
+ ("cat","category of the quiz"),
+ ("number","maximum number of questions")
+ ]
+ }),
+
+ ("p", emptyCommandInfo {
+ longname = "parse",
+ synopsis = "parse a string to abstract syntax expression",
+ explanation = unlines [
+ "Shows all trees returned by parsing a string in the grammars in scope.",
+ "The -lang flag can be used to restrict this to fewer languages.",
+ "The default start category can be overridden by the -cat flag.",
+ "See also the ps command for lexing and character encoding."
+ ],
+ exec = \opts -> return . fromTrees . concatMap (par opts) . toStrings,
+ flags = [
+ ("cat","target category of parsing"),
+ ("lang","the languages of parsing (comma-separated, no spaces)")
+ ]
+ }),
+ ("pg", emptyCommandInfo { -----
+ longname = "print_grammar",
+ synopsis = "print the actual grammar with the given printer",
+ explanation = unlines [
+ "Prints the actual grammar, with all involved languages.",
+ "In some printers, this can be restricted to a subset of languages",
+ "with the -lang=X,Y flag (comma-separated, no spaces).",
+ "The -printer=P flag sets the format in which the grammar is printed.",
+ "N.B.1 Since grammars are compiled when imported, this command",
+ "generally shows a grammar that looks rather different from the source.",
+ "N.B.2 This command is slightly obsolete: to produce different formats",
+ "the batch compiler gfc is recommended, and has many more options."
+ ],
+ exec = \opts _ -> return $ fromString $ prGrammar opts,
+ flags = [
+ --"cat",
+ ("lang", "select languages for the some options (default all languages)"),
+ ("printer","select the printing format (see gfc --help)")
+ ],
+ options = [
+ ("cats", "show just the names of abstract syntax categories"),
+ ("fullform", "print the fullform lexicon"),
+ ("missing","show just the names of functions that have no linearization")
+ ]
+ }),
+ ("ph", emptyCommandInfo {
+ longname = "print_history",
+ synopsis = "print command history",
+ explanation = unlines [
+ "Prints the commands issued during the GF session.",
+ "The result is readable by the eh command.",
+ "The result can be used as a script when starting GF."
+ ],
+ examples = [
+ "ph | wf -file=foo.gfs -- save the history into a file"
+ ]
+ }),
+ ("ps", emptyCommandInfo {
+ longname = "put_string",
+ syntax = "ps OPT? STRING",
+ synopsis = "return a string, possibly processed with a function",
+ explanation = unlines [
+ "Returns a string obtained from its argument string by applying",
+ "string processing functions in the order given in the command line",
+ "option list. Thus 'ps -f -g s' returns g (f s). Typical string processors",
+ "are lexers and unlexers, but also character encoding conversions are possible.",
+ "The unlexers preserve the division of their input to lines.",
+ "To see transliteration tables, use command ut."
+ ],
+ examples = [
+ "l (EAdd 3 4) | ps -code -- linearize code-like output",
+ "ps -lexer=code | p -cat=Exp -- parse code-like input",
+ "gr -cat=QCl | l | ps -bind -to_utf8 -- linearization output from LangFin",
+ "ps -from_utf8 \"jag ?r h?r\" | p -- parser in LangSwe in UTF8 terminal",
+ "ps -to_devanagari -to_utf8 \"A-p\" -- show Devanagari in UTF8 terminal"
+ ],
+ exec = \opts -> return . fromString . stringOps (map prOpt opts) . toString,
+ options = stringOpOptions
+ }),
+ ("q", emptyCommandInfo {
+ longname = "quit",
+ synopsis = "exit GF interpreter"
+ }),
+ ("rf", emptyCommandInfo {
+ longname = "read_file",
+ synopsis = "read string or tree input from a file",
+ explanation = unlines [
+ "Reads input from file. The filename must be in double quotes.",
+ "The input is interpreted as a string by default, and can hence be",
+ "piped e.g. to the parse command. The option -tree interprets the",
+ "input as a tree, which can be given e.g. to the linearize command.",
+ "The option -lines will result in a list of strings or trees, one by line."
+ ],
+ options = [
+ ("lines","return the list of lines, instead of the singleton of all contents"),
+ ("tree","convert strings into trees")
+ ],
+ exec = \opts arg -> do
+ let file = valIdOpts "file" "_gftmp" opts
+ s <- readFile file
+ return $ case opts of
+ _ | isOpt "lines" opts && isOpt "tree" opts ->
+ fromTrees [t | l <- lines s, Just t <- [readTree l]]
+ _ | isOpt "tree" opts ->
+ fromTrees [t | Just t <- [readTree s]]
+ _ | isOpt "lines" opts -> fromStrings $ lines s
+ _ -> fromString s,
+ flags = [("file","the input file name")]
+ }),
+ ("tq", emptyCommandInfo {
+ 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 pgf from to cat
+ return void,
+ flags = [
+ ("from","translate from this language"),
+ ("to","translate to this language"),
+ ("cat","translate in this category"),
+ ("number","the maximum number of questions")
+ ]
+ }),
+ ("sp", emptyCommandInfo {
+ longname = "system_pipe",
+ synopsis = "send argument to a system command",
+ syntax = "sp -command=\"SYSTEMCOMMAND\" STRING",
+ exec = \opts arg -> do
+ let tmpi = "_tmpi" ---
+ let tmpo = "_tmpo"
+ writeFile tmpi $ toString arg
+ let syst = optComm opts ++ " " ++ tmpi
+ system $ syst ++ " <" ++ tmpi ++ " >" ++ tmpo
+ s <- readFile tmpo
+ return $ fromString s,
+ flags = [
+ ("command","the system command applied to the argument")
+ ],
+ examples = [
+ "ps -command=\"wc\" \"foo\"",
+ "gt | l | sp -command=\"grep \\\"who\\\"\" | sp -command=\"wc\""
+ ]
+ }),
+ ("ut", emptyCommandInfo {
+ longname = "unicode_table",
+ synopsis = "show a transliteration table for a unicode character set",
+ exec = \opts arg -> do
+ let t = concatMap prOpt (take 1 opts)
+ let out = maybe "no such transliteration" characterTable $ transliteration t
+ return $ fromString out,
+ options = [
+ ("devanagari","Devanagari"),
+ ("thai", "Thai")
+ ]
+ }),
+ ("vt", emptyCommandInfo {
+ longname = "visualize_tree",
+ synopsis = "show a set of trees graphically",
+ explanation = unlines [
+ "Prints a set of trees in the .dot format (the graphviz format).",
+ "The graph can be saved in a file by the wf command as usual.",
+ "If the -view flag is defined, the graph is saved in a temporary file",
+ "which is processed by graphviz and displayed by the program indicated",
+ "by the flag. The target format is postscript, unless overridden by the",
+ "flag -format."
+ ],
+ exec = \opts ts -> do
+ let funs = not (isOpt "nofun" opts)
+ let cats = not (isOpt "nocat" opts)
+ let grph = visualizeTrees pgf (funs,cats) ts -- True=digraph
+ if isFlag "view" opts || isFlag "format" opts then do
+ let file s = "_grph." ++ s
+ let view = optViewGraph opts ++ " "
+ let format = optViewFormat opts
+ writeFile (file "dot") grph
+ system $ "dot -T" ++ format ++ " " ++ file "dot" ++ " > " ++ file format ++
+ " ; " ++ view ++ file format
+ return void
+ else return $ fromString grph,
+ examples = [
+ "p \"hello\" | vt -- parse a string and show trees as graph script",
+ "p \"hello\" | vt -view=\"open\" -- parse a string and display trees on a Mac"
+ ],
+ options = [
+ ("nofun","don't show functions but only categories"),
+ ("nocat","don't show categories but only functions")
+ ],
+ flags = [
+ ("format","format of the visualization file (default \"ps\")"),
+ ("view","program to open the resulting file (default \"gv\")")
+ ]
+ }),
+ ("wf", emptyCommandInfo {
+ longname = "write_file",
+ synopsis = "send string or tree to a file",
+ exec = \opts arg -> do
+ let file = valIdOpts "file" "_gftmp" opts
+ if isOpt "append" opts
+ then appendFile file (toString arg)
+ else writeFile file (toString arg)
+ return void,
+ options = [
+ ("append","append to file, instead of overwriting it")
+ ],
+ flags = [("file","the output filename")]
+ })
+ ]
+ where
+ lin opts t = unlines [linearize pgf lang t | lang <- optLangs opts]
+ par opts s = concat [parse pgf lang (optCat opts) s | lang <- optLangs opts]
+
+ void = ([],[])
+
+ optLin opts t = case opts of
+ _ | isOpt "treebank" opts -> treebank opts t
+ _ -> 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)
+ _ -> unl . linearize pgf lang
+
+ treebank opts t = unlines $
+ (abstractName pgf ++ ": " ++ showTree t) :
+ [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
+ Just le -> chunks ',' le
+ _ -> []
+
+-- Proposed logic of coding in unlexing:
+-- - If lang has no coding flag, or -to_utf8 is not in opts, just opts are used.
+-- - If lang has flag coding=utf8, -to_utf8 is ignored.
+-- - If lang has coding=other, and -to_utf8 is in opts, from_other is applied first.
+-- THIS DOES NOT WORK UNFORTUNATELY - can't use the grammar flag properly
+ unlexx opts lang = {- trace (unwords optsC) $ -} stringOps optsC where
+ optsC = case lookFlag pgf lang "coding" of
+ Just "utf8" -> filter (/="to_utf8") $ map prOpt opts
+ Just other | isOpt "to_utf8" opts ->
+ let cod = ("from_" ++ other)
+ in cod : filter (/=cod) (map prOpt opts)
+ _ -> map prOpt opts
+
+ optRestricted opts = restrictPGF (hasLin pgf (mkCId (optLang opts))) pgf
+
+ optLangs opts = case valIdOpts "lang" "" opts of
+ "" -> languages pgf
+ lang -> chunks ',' lang
+ optLang opts = head $ optLangs opts ++ ["#NOLANG"]
+ optCat opts = valIdOpts "cat" (lookStartCat pgf) opts
+ optComm opts = valStrOpts "command" "" opts
+ optViewFormat opts = valStrOpts "format" "ps" opts
+ optViewGraph opts = valStrOpts "view" "gv" opts
+ optNum opts = valIntOpts "number" 1 opts
+ optNumInf opts = valIntOpts "number" 1000000000 opts ---- 10^9
+
+ fromTrees ts = (ts,unlines (map showTree ts))
+ fromStrings ss = (map (Lit . LStr) ss, unlines ss)
+ fromString s = ([Lit (LStr s)], s)
+ toStrings ts = [s | Lit (LStr s) <- ts]
+ toString ts = unwords [s | Lit (LStr s) <- ts]
+
+ prGrammar opts = case opts of
+ _ | isOpt "cats" opts -> unwords $ categories pgf
+ _ | isOpt "fullform" opts -> concatMap
+ (prFullFormLexicon . buildMorpho pgf . mkCId) $ 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
+ v -> concatMap snd $ exportPGF noOptions (read v) pgf
+
+ morphos opts s =
+ [lookupMorpho (buildMorpho pgf (mkCId la)) s | la <- optLangs opts]
+
+ -- ps -f -g s returns g (f s)
+ stringOps opts s = foldr app s (reverse opts) where
+ app f = maybe id id (stringOp f)
+
+stringOpOptions = [
+ ("bind","bind tokens separated by Prelude.BIND, i.e. &+"),
+ ("chars","lexer that makes every non-space character a token"),
+ ("from_cp1251","decode from cp1251 (Cyrillic used in Bulgarian resource)"),
+ ("from_devanagari","from unicode to GF Devanagari transliteration"),
+ ("from_thai","from unicode to GF Thai transliteration"),
+ ("from_utf8","decode from utf8"),
+ ("lextext","text-like lexer"),
+ ("lexcode","code-like lexer"),
+ ("lexmixed","mixture of text and code (code between $...$)"),
+ ("to_cp1251","encode to cp1251 (Cyrillic used in Bulgarian resource)"),
+ ("to_devanagari","from GF Devanagari transliteration to unicode"),
+ ("to_html","wrap in a html file with linebreaks"),
+ ("to_thai","from GF Thai transliteration to unicode"),
+ ("to_utf8","encode to utf8"),
+ ("unlextext","text-like unlexer"),
+ ("unlexcode","code-like unlexer"),
+ ("unlexmixed","mixture of text and code (code between $...$)"),
+ ("unchars","unlexer that puts no spaces between tokens"),
+ ("unwords","unlexer that puts a single space between tokens (default)"),
+ ("words","lexer that assumes tokens separated by spaces (default)")
+ ]
+
+translationQuiz :: PGF -> Language -> Language -> Category -> IO ()
+translationQuiz pgf ig og cat = do
+ tts <- translationList pgf ig og cat infinity
+ mkQuiz "Welcome to GF Translation Quiz." tts
+
+morphologyQuiz :: PGF -> Language -> Category -> IO ()
+morphologyQuiz pgf ig cat = do
+ tts <- morphologyList pgf ig cat infinity
+ mkQuiz "Welcome to GF Morphology Quiz." tts
+
+-- | the maximal number of precompiled quiz problems
+infinity :: Int
+infinity = 256
+
+lookFlag :: PGF -> String -> String -> Maybe String
+lookFlag pgf lang flag = lookConcrFlag pgf (mkCId lang) (mkCId flag)
diff --git a/src/GF/Command/Importing.hs b/src/GF/Command/Importing.hs
new file mode 100644
index 000000000..c3ad9d746
--- /dev/null
+++ b/src/GF/Command/Importing.hs
@@ -0,0 +1,37 @@
+module GF.Command.Importing (importGrammar, importSource) where
+
+import PGF
+import PGF.Data
+
+import GF.Compile
+import GF.Grammar.Grammar (SourceGrammar) -- for cc command
+import GF.Infra.UseIO
+import GF.Infra.Option
+import GF.Data.ErrM
+
+import Data.List (nubBy)
+import System.FilePath
+
+-- import a grammar in an environment where it extends an existing grammar
+importGrammar :: PGF -> Options -> [FilePath] -> IO PGF
+importGrammar pgf0 _ [] = return pgf0
+importGrammar pgf0 opts files =
+ case takeExtensions (last files) of
+ s | elem s [".gf",".gfo"] -> do
+ res <- appIOE $ compileToPGF opts files
+ case res of
+ Ok pgf2 -> do return $ unionPGF pgf0 pgf2
+ Bad msg -> do putStrLn msg
+ return pgf0
+ ".pgf" -> do
+ pgf2 <- mapM readPGF files >>= return . foldl1 unionPGF
+ return $ unionPGF pgf0 pgf2
+
+importSource :: SourceGrammar -> Options -> [FilePath] -> IO SourceGrammar
+importSource src0 opts files = do
+ src <- appIOE $ batchCompile opts files
+ case src of
+ Ok gr -> return gr
+ Bad msg -> do
+ putStrLn msg
+ return src0
diff --git a/src/GF/Command/Interpreter.hs b/src/GF/Command/Interpreter.hs
new file mode 100644
index 000000000..e1a06a205
--- /dev/null
+++ b/src/GF/Command/Interpreter.hs
@@ -0,0 +1,121 @@
+module GF.Command.Interpreter (
+ CommandEnv (..),
+ mkCommandEnv,
+ emptyCommandEnv,
+ interpretCommandLine,
+ interpretPipe,
+ getCommandOp
+ ) where
+
+import GF.Command.Commands
+import GF.Command.Abstract
+import GF.Command.Parse
+import PGF
+import PGF.Data
+import PGF.Macros
+import GF.System.Signal
+import GF.Infra.UseIO
+
+import GF.Data.ErrM ----
+
+import qualified Data.Map as Map
+
+data CommandEnv = CommandEnv {
+ multigrammar :: PGF,
+ commands :: Map.Map String CommandInfo,
+ commandmacros :: Map.Map String CommandLine,
+ expmacros :: Map.Map String Tree
+ }
+
+mkCommandEnv :: PGF -> CommandEnv
+mkCommandEnv pgf = CommandEnv pgf (allCommands pgf) Map.empty Map.empty
+
+emptyCommandEnv :: CommandEnv
+emptyCommandEnv = mkCommandEnv emptyPGF
+
+interpretCommandLine :: CommandEnv -> String -> IO ()
+interpretCommandLine env line =
+ case readCommandLine line of
+ Just [] -> return ()
+ Just pipes -> do res <- runInterruptibly (mapM_ (interpretPipe env) pipes)
+ case res of
+ Left ex -> putStrLnFlush (show ex)
+ Right x -> return x
+ Nothing -> putStrLnFlush "command not parsed"
+
+interpretPipe env cs = do
+ v@(_,s) <- intercs ([],"") cs
+ putStrLnFlush s
+ return v
+ where
+ intercs treess [] = return treess
+ intercs (trees,_) (c:cs) = do
+ treess2 <- interc trees c
+ intercs treess2 cs
+ interc es comm@(Command co _ arg) = case co of
+ '%':f -> case Map.lookup f (commandmacros env) of
+ Just css -> do
+ mapM_ (interpretPipe env) (appLine (getCommandArg env arg es) css)
+ return ([],[]) ---- return ?
+ _ -> do
+ putStrLn $ "command macro " ++ co ++ " not interpreted"
+ return ([],[])
+ _ -> interpret env es comm
+ appLine es = map (map (appCommand es))
+
+-- macro definition applications: replace ?i by (exps !! i)
+appCommand :: [Tree] -> Command -> Command
+appCommand xs c@(Command i os arg) = case arg of
+ ATree e -> Command i os (ATree (app e))
+ _ -> c
+ where
+ app e = case e of
+ Meta i -> xs !! i
+ Fun f as -> Fun f (map app as)
+ Abs x b -> Abs x (app b)
+
+-- return the trees to be sent in pipe, and the output possibly printed
+interpret :: CommandEnv -> [Tree] -> Command -> IO CommandOutput
+interpret env trees0 comm = case lookCommand co comms of
+ Just info -> do
+ checkOpts info
+ tss@(_,s) <- exec info opts trees
+ optTrace s
+ return tss
+ _ -> do
+ putStrLn $ "command " ++ co ++ " not interpreted"
+ return ([],[])
+ where
+ optTrace = if isOpt "tr" opts then putStrLn else const (return ())
+ (co,opts,trees) = getCommand env comm trees0
+ comms = commands env
+ checkOpts info =
+ case
+ [o | OOpt o <- opts, notElem o ("tr" : map fst (options info))] ++
+ [o | OFlag o _ <- opts, notElem o (map fst (flags info))]
+ of
+ [] -> return ()
+ [o] -> putStrLn $ "option not interpreted: " ++ o
+ os -> putStrLn $ "options not interpreted: " ++ unwords os
+
+-- analyse command parse tree to a uniform datastructure, normalizing comm name
+--- the env is needed for macro lookup
+getCommand :: CommandEnv -> Command -> [Tree] -> (String,[Option],[Tree])
+getCommand env co@(Command c opts arg) ts =
+ (getCommandOp c,opts,getCommandArg env arg ts)
+
+getCommandArg :: CommandEnv -> Argument -> [Tree] -> [Tree]
+getCommandArg env a ts = case a of
+ AMacro m -> case Map.lookup m (expmacros env) of
+ Just t -> [t]
+ _ -> []
+ ATree t -> [t] -- ignore piped
+ ANoArg -> ts -- use piped
+
+-- abbreviation convention from gf commands
+getCommandOp s = case break (=='_') s of
+ (a:_,_:b:_) -> [a,b] -- axx_byy --> ab
+ _ -> case s of
+ [a,b] -> s -- ab --> ab
+ a:_ -> [a] -- axx --> a
+
diff --git a/src/GF/Command/Parse.hs b/src/GF/Command/Parse.hs
new file mode 100644
index 000000000..eaf4cba84
--- /dev/null
+++ b/src/GF/Command/Parse.hs
@@ -0,0 +1,48 @@
+module GF.Command.Parse(readCommandLine, pCommand) where
+
+import PGF.Expr
+import PGF.Data(Tree)
+import GF.Command.Abstract
+
+import Data.Char
+import Control.Monad
+import qualified Text.ParserCombinators.ReadP as RP
+
+readCommandLine :: String -> Maybe CommandLine
+readCommandLine s = case [x | (x,cs) <- RP.readP_to_S pCommandLine s, all isSpace cs] of
+ [x] -> Just x
+ _ -> Nothing
+
+test s = RP.readP_to_S pCommandLine s
+
+pCommandLine = RP.sepBy (RP.skipSpaces >> pPipe) (RP.skipSpaces >> RP.char ';')
+
+pPipe = RP.sepBy1 (RP.skipSpaces >> pCommand) (RP.skipSpaces >> RP.char '|')
+
+pCommand = do
+ cmd <- pIdent RP.<++ (RP.char '%' >> pIdent >>= return . ('%':))
+ RP.skipSpaces
+ opts <- RP.sepBy pOption RP.skipSpaces
+ arg <- pArgument
+ return (Command cmd opts arg)
+
+pOption = do
+ RP.char '-'
+ flg <- pIdent
+ RP.option (OOpt flg) (fmap (OFlag flg) (RP.char '=' >> pValue))
+
+pValue = do
+ fmap (VInt . read) (RP.munch1 isDigit)
+ RP.<++
+ fmap VStr pStr
+ RP.<++
+ fmap VId pFilename
+
+pFilename = liftM2 (:) (RP.satisfy isFileFirst) (RP.munch (not . isSpace)) where
+ isFileFirst c = not (isSpace c) && not (isDigit c)
+
+pArgument =
+ RP.option ANoArg
+ (fmap ATree (pTree False)
+ RP.<++
+ (RP.munch isSpace >> RP.char '%' >> fmap AMacro pIdent))
generated by cgit v1.2.3 (git 2.39.1) at 2026-05-20 19:02:20 +0000