From 230d9780b7b29273d8f9b6cd6043250356c6c32e Mon Sep 17 00:00:00 2001 From: hallgren Date: Mon, 10 Aug 2015 14:12:51 +0000 Subject: [PATCH] gf -cshell: preliminary support for the C run-time system in the GF shell Some C run-time functionality is now available in the GF shell, by starting GF with 'gf -cshell' or 'gf -crun'. Only limited functionality is available when running the shell in these modes: - You can only import .pgf files, not source files. - The -retain flag can not be used and the commands that require it to work are not available. - Only 18 of the 40 commands available in the usual shell have been implemented. The 'linearize' and 'parse' commands are the only ones that call the C run-time system, and they support only a limited set of options and flags. Use the 'help' commmands for details. - A new command 'generate_all', that calls PGF2.generateAll, has been added. Unfortuntaly, using it causes 'segmentation fault'. This is implemented by adding two new modules: GF.Command.Commands2 and GF.Interactive2. They are copied and modified versions of GF.Command.Commands and GF.Interactive, respectively. Code for unimplemented commands and other code that has not been adapted to the C run-time system has been left in place, but commented out, pending further work. --- gf.cabal | 15 +- src/compiler/GF/Command/Commands2.hs | 1425 ++++++++++++++++++++++++++ src/compiler/GF/Infra/Option.hs | 7 +- src/compiler/GF/Infra/SIO.hs | 11 + src/compiler/GF/Interactive2.hs | 538 ++++++++++ src/compiler/GF/Main.hs | 22 +- src/runtime/haskell-bind/PGF2.hsc | 2 +- 7 files changed, 2007 insertions(+), 13 deletions(-) create mode 100644 src/compiler/GF/Command/Commands2.hs create mode 100644 src/compiler/GF/Interactive2.hs diff --git a/gf.cabal b/gf.cabal index ad2cae07e..0ad07e772 100644 --- a/gf.cabal +++ b/gf.cabal @@ -132,13 +132,14 @@ Library PGF.OldBinary if flag(c-runtime) - exposed-modules: PGF2 - other-modules: PGF2.FFI - hs-source-dirs: src/runtime/haskell-bind - build-tools: hsc2hs - extra-libraries: gu pgf - c-sources: src/runtime/haskell-bind/utils.c - cc-options: -std=c99 + exposed-modules: PGF2 + other-modules: PGF2.FFI + GF.Interactive2 GF.Command.Commands2 + hs-source-dirs: src/runtime/haskell-bind + build-tools: hsc2hs + extra-libraries: gu pgf + c-sources: src/runtime/haskell-bind/utils.c + cc-options: -std=c99 ---- GF compiler as a library: diff --git a/src/compiler/GF/Command/Commands2.hs b/src/compiler/GF/Command/Commands2.hs new file mode 100644 index 000000000..0c9315f1d --- /dev/null +++ b/src/compiler/GF/Command/Commands2.hs @@ -0,0 +1,1425 @@ +{-# LANGUAGE PatternGuards, TypeSynonymInstances, FlexibleInstances #-} +module GF.Command.Commands2 ( + PGFEnv,pgfEnv,emptyPGFEnv,allCommands, + options, flags, + ) where +import Prelude hiding (putStrLn) + +import qualified PGF2 as C +import qualified PGF as H + +--import qualified PGF.Internal as H(lookStartCat,functionsToCat,lookValCat,restrictPGF,hasLin) +--import qualified PGF.Internal as H(abstract,funs,cats,Expr(EFun)) ---- +--import qualified PGF.Internal as H(Literal(LStr),Expr(ELit)) ---- +--import qualified PGF.Internal as H(ppFun,ppCat) + +--import qualified PGF.Internal as H(optimizePGF) + +--import GF.Compile.Export +--import GF.Compile.ToAPI +--import GF.Compile.ExampleBased +--import GF.Infra.Option (noOptions, readOutputFormat, outputFormatsExpl) +import GF.Infra.UseIO(writeUTF8File) +import GF.Infra.SIO +--import GF.Data.ErrM ---- +import GF.Command.Abstract +--import GF.Command.Messages +import GF.Command.CommandInfo +import GF.Command.Help +import GF.Text.Lexing +--import GF.Text.Clitics +import GF.Text.Transliterations +--import GF.Quiz + +--import GF.Command.TreeOperations ---- temporary place for typecheck and compute + +import GF.Data.Operations + +--import PGF.Internal (encodeFile) +--import Data.List(intersperse,nub) +import Data.Maybe +import qualified Data.Map as Map +--import System.Cmd(system) -- use GF.Infra.UseIO.restricedSystem instead! +import GF.System.Process +import GF.Text.Pretty +import Data.List (sort) +import Control.Monad(mplus) +--import Debug.Trace +--import System.Random (newStdGen) ---- + + +type PGFEnv = (Maybe C.PGF, Map.Map C.ConcName C.Concr) + +pgfEnv pgf = (Just pgf,C.languages pgf) :: PGFEnv +emptyPGFEnv = (Nothing,Map.empty) :: PGFEnv + +instance TypeCheckArg PGFEnv where + typeCheckArg env e = Right e -- no type checker available !! + + +-- this list must no more be kept sorted by the command name +allCommands :: Map.Map String (CommandInfo PGFEnv) +allCommands = Map.fromList [ + ("!", emptyCommandInfo { + synopsis = "system command: escape to system shell", + syntax = "! SYSTEMCOMMAND", + examples = [ + ("! ls *.gf", "list all GF files in the working directory") + ], + needsTypeCheck = False + }), + ("?", emptyCommandInfo { + synopsis = "system pipe: send value from previous command to a system command", + syntax = "? SYSTEMCOMMAND", + examples = [ + ("gt | l | ? wc", "generate, linearize, word-count") + ], + needsTypeCheck = False + }), +{- + ("aw", emptyCommandInfo { + longname = "align_words", + synopsis = "show word alignments between languages graphically", + explanation = unlines [ + "Prints a set of strings 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 = \env@(pgf, mos) opts es -> do + let langs = optLangs pgf opts + if isOpt "giza" opts + then do + let giz = map (H.gizaAlignment pgf (head $ langs, head $ tail $ langs)) es + let lsrc = unlines $ map (\(x,_,_) -> x) giz + let ltrg = unlines $ map (\(_,x,_) -> x) giz + let align = unlines $ map (\(_,_,x) -> x) giz + let grph = if null es then [] else lsrc ++ "\n--end_source--\n\n"++ltrg++"\n-end_target--\n\n"++align + return $ fromString grph + else do + let grph = if null es then [] else H.graphvizAlignment pgf langs (head es) + if isFlag "view" opts || isFlag "format" opts + then do + let file s = "_grph." ++ s + let view = optViewGraph opts + let format = optViewFormat opts + restricted $ writeUTF8File (file "dot") grph + restrictedSystem $ "dot -T" ++ format ++ " " ++ file "dot" ++ " > " ++ file format + restrictedSystem $ view ++ " " ++ file format + return void + else return $ fromString grph, + examples = [ + ("gr | aw" , "generate a tree and show word alignment as graph script"), + ("gr | aw -view=\"open\"" , "generate a tree and display alignment on Mac"), + ("gr | aw -view=\"eog\"" , "generate a tree and display alignment on Ubuntu"), + ("gt | aw -giza | wf -file=aligns" , "generate trees, send giza alignments to file") + ], + options = [ + ("giza", "show alignments in the Giza format; the first two languages") + ], + flags = [ + ("format","format of the visualization file (default \"png\")"), + ("lang", "alignments for this list of languages (default: all)"), + ("view", "program to open the resulting file") + ] + }), + + ("ca", emptyCommandInfo { + longname = "clitic_analyse", + synopsis = "print the analyses of all words into stems and clitics", + explanation = unlines [ + "Analyses all words into all possible combinations of stem + clitics.", + "The analysis is returned in the format stem &+ clitic1 &+ clitic2 ...", + "which is hence the inverse of 'pt -bind'. The list of clitics is give", + "by the flag '-clitics'. The list of stems is given as the list of words", + "of the language given by the '-lang' flag." + ], + exec = \env opts -> case opts of + _ | isOpt "raw" opts -> + return . fromString . + unlines . map (unwords . map (concat . intersperse "+")) . + map (getClitics (H.isInMorpho (optMorpho env opts)) (optClitics opts)) . + concatMap words . toStrings + _ -> + return . fromStrings . + getCliticsText (H.isInMorpho (optMorpho env opts)) (optClitics opts) . + concatMap words . toStrings, + flags = [ + ("clitics","the list of possible clitics (comma-separated, no spaces)"), + ("lang", "the language of analysis") + ], + options = [ + ("raw", "analyse each word separately (not suitable input for parser)") + ], + examples = [ + mkEx "ca -lang=Fin -clitics=ko,ni \"nukkuuko minun vaimoni\" | p -- to parse Finnish" + ] + }), + + ("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"), + ("list","all strings, comma-separated on one line"), + ("one","pick the first strings, if there is any, from records and tables"), + ("table","show all strings labelled by parameters"), + ("unqual","hide qualifying module names") + ], + needsTypeCheck = False + }), +-} + ("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." + ], + needsTypeCheck = False + }), +{- + ("dg", emptyCommandInfo { + longname = "dependency_graph", + syntax = "dg (-only=MODULES)?", + synopsis = "print module dependency graph", + explanation = unlines [ + "Prints the dependency graph of source modules.", + "Requires that import has been done with the -retain flag.", + "The graph is written in the file _gfdepgraph.dot", + "which can be further processed by Graphviz (the system command 'dot').", + "By default, all modules are shown, but the -only flag restricts them", + "by a comma-separated list of patterns, where 'name*' matches modules", + "whose name has prefix 'name', and other patterns match modules with", + "exactly the same name. The graphical conventions are:", + " solid box = abstract, solid ellipse = concrete, dashed ellipse = other", + " solid arrow empty head = of, solid arrow = **, dashed arrow = open", + " dotted arrow = other dependency" + ], + flags = [ + ("only","list of modules included (default: all), literally or by prefix*") + ], + examples = [ + mkEx "dg -only=SyntaxEng,Food* -- shows only SyntaxEng, and those with prefix Food" + ], + needsTypeCheck = False + }), +-} + ("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 = [ + mkEx ("dt ex \"hello world\" -- define ex as string"), + mkEx ("dt ex UseN man_N -- define ex as string"), + mkEx ("dt ex < p -cat=NP \"the man in the car\" -- define ex as parse result"), + mkEx ("l -lang=LangSwe %ex | ps -to_utf8 -- linearize the tree ex") + ], + needsTypeCheck = False + }), + ("e", emptyCommandInfo { + longname = "empty", + synopsis = "empty the environment" + }), +{- + ("eb", emptyCommandInfo { + longname = "example_based", + syntax = "eb (-probs=FILE | -lang=LANG)* -file=FILE.gfe", + synopsis = "converts .gfe files to .gf files by parsing examples to trees", + explanation = unlines [ + "Reads FILE.gfe and writes FILE.gf. Each expression of form", + "'%ex CAT QUOTEDSTRING' in FILE.gfe is replaced by a syntax tree.", + "This tree is the first one returned by the parser; a biased ranking", + "can be used to regulate the order. If there are more than one parses", + "the rest are shown in comments, with probabilities if the order is biased.", + "The probabilities flag and configuration file is similar to the commands", + "gr and rt. Notice that the command doesn't change the environment,", + "but the resulting .gf file must be imported separately." + ], + options = [ + ("api","convert trees to overloaded API expressions (using Syntax not Lang)") + ], + flags = [ + ("file","the file to be converted (suffix .gfe must be given)"), + ("lang","the language in which to parse"), + ("probs","file with probabilities to rank the parses") + ], + exec = \env@(pgf, mos) opts _ -> do + let file = optFile opts + pgf <- optProbs opts pgf + let printer = if (isOpt "api" opts) then exprToAPI else (H.showExpr []) + let conf = configureExBased pgf (optMorpho env opts) (optLang pgf opts) printer + (file',ws) <- restricted $ parseExamplesInGrammar conf file + if null ws then return () else putStrLn ("unknown words: " ++ unwords ws) + return (fromString ("wrote " ++ file')), + needsTypeCheck = False + }), +-} +{- + ("gr", emptyCommandInfo { + longname = "generate_random", + synopsis = "generate random trees in the current abstract syntax", + syntax = "gr [-cat=CAT] [-number=INT]", + examples = [ + mkEx "gr -- one tree in the startcat of the current grammar", + mkEx "gr -cat=NP -number=16 -- 16 trees in the category NP", + mkEx "gr -lang=LangHin,LangTha -cat=Cl -- Cl, both in LangHin and LangTha", + mkEx "gr -probs=FILE -- generate with bias", + mkEx "gr (AdjCN ? (UseN ?)) -- generate trees of form (AdjCN ? (UseN ?))" + ], + 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", + "all metavariables in the tree. The generation can be biased by probabilities,", + "given in a file in the -probs flag." + ], + flags = [ + ("cat","generation category"), + ("lang","uses only functions that have linearizations in all these languages"), + ("number","number of trees generated"), + ("depth","the maximum generation depth"), + ("probs", "file with biased probabilities (format 'f 0.4' one by line)") + ], + exec = \env@(pgf, mos) opts xs -> do + pgf <- optProbs opts (optRestricted opts pgf) + gen <- newStdGen + let dp = valIntOpts "depth" 4 opts + let ts = case mexp xs of + Just ex -> H.generateRandomFromDepth gen pgf ex (Just dp) + Nothing -> H.generateRandomDepth gen pgf (optType pgf opts) (Just dp) + returnFromExprs $ take (optNum opts) ts + }), +-} + ("ga", emptyCommandInfo { + longname = "generate_all", + synopsis = "generate a list of all trees", + flags = [("cat","the generation category"), + ("number","the number of trees generated")], + examples = [ + mkEx "ga -- all trees in the startcat", + mkEx "ga -cat=NP -number=16 -- 16 trees in the category NP"], + exec = needPGF $ \ env@(pgf,_) opts _ -> + let ts = map fst (C.generateAll pgf cat) + cat = optCat pgf opts + in returnFromCExprs (takeOptNum opts ts), + needsTypeCheck = False + }), +{- + ("gt", emptyCommandInfo { + longname = "generate_trees", + synopsis = "generates a list of trees, by default exhaustive", + explanation = unlines [ + "Generates all trees of a given category. By default, ", + "the depth is limited to 4, but this can be changed by a flag.", + "If a Tree argument is given, the command completes the Tree with values", + "to all 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") + ], + examples = [ + mkEx "gt -- all trees in the startcat, to depth 4", + mkEx "gt -cat=NP -number=16 -- 16 trees in the category NP", + mkEx "gt -cat=NP -depth=2 -- trees in the category NP to depth 2", + mkEx "gt (AdjCN ? (UseN ?)) -- trees of form (AdjCN ? (UseN ?))" + ], + exec = \env@(pgf, mos) opts xs -> do + let pgfr = optRestricted opts pgf + let dp = valIntOpts "depth" 4 opts + let ts = case mexp xs of + Just ex -> H.generateFromDepth pgfr ex (Just dp) + Nothing -> H.generateAllDepth pgfr (optType pgf opts) (Just dp) + returnFromExprs $ take (optNumInf opts) ts + }), +-} + helpCommand allCommands, + ("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 its abstract is different from current state, old modules are discarded.", + "If its abstract is the same and a concrete with the same name is already in the state", + "it is overwritten - but only if compilation succeeds.", + "The grammar parser depends on the file name suffix:", + " .cf context-free (labelled BNF) source", + " .ebnf extended BNF source", + " .gfm multi-module GF source", + " .gf normal GF source", + " .gfo compiled GF source", + " .pgf precompiled grammar in Portable Grammar Format" + ], + flags = [ + ("probs","file with biased probabilities for generation") + ], + options = [ + -- ["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") + ], + needsTypeCheck = False + }), + ("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."], + flags = [ + ("lang","the languages of linearization (comma-separated, no spaces)") + ], + examples = [ + mkEx "l -lang=LangSwe,LangNor no_Utt -- linearize tree to LangSwe and LangNor"], + exec = needPGF $ \ env opts -> + return . fromStrings . cLins env opts . map cExpr + }), +{- + ("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 = [ + mkEx "l -lang=LangSwe,LangNor no_Utt -- linearize tree to LangSwe and LangNor", + mkEx "gr -lang=LangHin -cat=Cl | l -table -to_devanagari -- hindi table", + mkEx "l -unlexer=\"LangAra=to_arabic LangHin=to_devanagari\" -- different unlexers" + ], + exec = \env@(pgf, mos) opts -> return . fromStrings . optLins pgf opts, + options = [ + ("all", "show all forms and variants, one by line (cf. l -list)"), + ("bracket","show tree structure with brackets and paths to nodes"), + ("groups", "all languages, grouped by lang, remove duplicate strings"), + ("list","show all forms and variants, comma-separated on one line (cf. l -all)"), + ("multi","linearize to all languages (default)"), + ("table","show all forms labelled by parameters"), + ("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)") + ] + }), +-} +{- + ("lc", emptyCommandInfo { + longname = "linearize_chunks", + synopsis = "linearize a tree that has metavariables in maximal chunks without them", + explanation = unlines [ + "A hopefully temporary command, intended to work around the type checker that fails", + "trees where a function node is a metavariable." + ], + examples = [ + mkEx "l -lang=LangSwe,LangNor -chunks ? a b (? c d)" + ], + exec = \env@(pgf, mos) opts -> return . fromStrings . optLins pgf (opts ++ [OOpt "chunks"]), + options = [ + ("treebank","show the tree and tag linearizations with language names") + ] ++ stringOpOptions, + flags = [ + ("lang","the languages of linearization (comma-separated, no spaces)") + ], + needsTypeCheck = False + }), +-} +{- + ("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 pg)" + ], + exec = \env opts -> case opts of + _ | isOpt "missing" opts -> + return . fromString . unwords . + H.morphoMissing (optMorpho env opts) . + concatMap words . toStrings + _ | isOpt "known" opts -> + return . fromString . unwords . + H.morphoKnown (optMorpho env opts) . + concatMap words . toStrings + _ -> return . fromString . unlines . + map prMorphoAnalysis . concatMap (morphos env opts) . + concatMap words . toStrings , + flags = [ + ("lang","the languages of analysis (comma-separated, no spaces)") + ], + options = [ + ("known", "return only the known words, in order of appearance"), + ("missing","show the list of unknown words, in order of appearance") + ] + }), + ("mq", emptyCommandInfo { + longname = "morpho_quiz", + synopsis = "start a morphology quiz", + syntax = "mq (-cat=CAT)? (-probs=FILE)? TREE?", + exec = \env@(pgf, mos) opts xs -> do + let lang = optLang pgf opts + let typ = optType pgf opts + pgf <- optProbs opts pgf + let mt = mexp xs + restricted $ morphologyQuiz mt pgf lang typ + return void, + flags = [ + ("lang","language of the quiz"), + ("cat","category of the quiz"), + ("number","maximum number of questions"), + ("probs","file with biased probabilities for generation") + ] + }), +-} + ("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." + ], + flags = [ + ("cat","target category of parsing"), + ("lang","the languages of parsing (comma-separated, no spaces)"), + ("number","maximum number of trees returned") + ], + examples = [ + mkEx "p \"this fish is fresh\" | l -lang=Swe -- try parsing with all languages and translate the successful parses to Swedish" + ], + exec = needPGF $ \ env opts -> return . cParse env opts . toStrings + }), +{- + ("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.", + "", + "The -openclass flag is experimental and allows some robustness in ", + "the parser. For example if -openclass=\"A,N,V\" is given, the parser", + "will accept unknown adjectives, nouns and verbs with the resource grammar." + ], + exec = \env@(pgf, mos) opts ts -> + return . Piped $ fromParse opts (concat [map ((,) s) (par pgf opts s) | s <- toStrings ts]), + flags = [ + ("cat","target category of parsing"), + ("lang","the languages of parsing (comma-separated, no spaces)"), + ("openclass","list of open-class categories for robust parsing"), + ("depth","maximal depth for proof search if the abstract syntax tree has meta variables") + ], + options = [ + ("bracket","prints the bracketed string from the parser") + ] + }), +-} +{- + ("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 Another way to produce different formats is to use 'gf -make',", + "the batch compiler. The following values are available both for", + "the batch compiler (flag -output-format) and the print_grammar", + "command (flag -printer):", + "" + ] ++ unlines (sort [ + " " ++ opt ++ "\t\t" ++ expl | + ((opt,_),expl) <- outputFormatsExpl, take 1 expl /= "*" + ]), + exec = \env opts _ -> prGrammar env opts, + flags = [ + --"cat", + ("file", "set the file name when printing with -pgf option"), + ("lang", "select languages for the some options (default all languages)"), + ("printer","select the printing format (see flag values above)") + ], + options = [ + ("cats", "show just the names of abstract syntax categories"), + ("fullform", "print the fullform lexicon"), + ("funs", "show just the names and types of abstract syntax functions"), + ("langs", "show just the names of top concrete syntax modules"), + ("lexc", "print the lexicon in Xerox LEXC format"), + ("missing","show just the names of functions that have no linearization"), + ("opt", "optimize the generated pgf"), + ("pgf", "write current pgf image in file"), + ("words", "print the list of words") + ], + examples = [ + mkEx ("pg -funs | ? grep \" S ;\" -- show functions with value cat S") + ] + }), +-} + ("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 = [ + mkEx "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 = [ + mkEx "l (EAdd 3 4) | ps -code -- linearize code-like output", + mkEx "ps -lexer=code | p -cat=Exp -- parse code-like input", + mkEx "gr -cat=QCl | l | ps -bind -- linearization output from LangFin", + mkEx "ps -to_devanagari \"A-p\" -- show Devanagari in UTF8 terminal", + mkEx "rf -file=Hin.gf | ps -env=quotes -to_devanagari -- convert translit to UTF8", + mkEx "rf -file=Ara.gf | ps -from_utf8 -env=quotes -from_arabic -- convert UTF8 to transliteration", + mkEx "ps -to=chinese.trans \"abc\" -- apply transliteration defined in file chinese.trans" + ], + exec = \_ opts x -> do + let (os,fs) = optsAndFlags opts + trans <- optTranslit opts + + if isOpt "lines" opts + then return $ fromStrings $ map (trans . stringOps (envFlag fs) (map prOpt os)) $ toStrings x + else return ((fromString . trans . stringOps (envFlag fs) (map prOpt os) . toString) x), + options = [ + ("lines","apply the operation separately to each input line, returning a list of lines") + ] ++ + stringOpOptions, + flags = [ + ("env","apply in this environment only"), + ("from","backward-apply transliteration defined in this file (format 'unicode translit' per line)"), + ("to", "forward-apply transliteration defined in this file") + ] + }), + ("tt", emptyCommandInfo { + longname = "to_trie", + syntax = "to_trie", + synopsis = "combine a list of trees into a trie", + exec = \ _ _ -> return . fromString . trie + }), +{- + ("pt", emptyCommandInfo { + longname = "put_tree", + syntax = "pt OPT? TREE", + synopsis = "return a tree, possibly processed with a function", + explanation = unlines [ + "Returns a tree obtained from its argument tree by applying", + "tree processing functions in the order given in the command line", + "option list. Thus 'pt -f -g s' returns g (f s). Typical tree processors", + "are type checking and semantic computation." + ], + examples = [ + mkEx "pt -compute (plus one two) -- compute value", + mkEx "p \"4 dogs love 5 cats\" | pt -transfer=digits2numeral | l -- four...five..." + ], + exec = \env@(pgf, mos) opts -> + returnFromExprs . takeOptNum opts . treeOps pgf opts, + options = treeOpOptions undefined{-pgf-}, + flags = [("number","take at most this many trees")] ++ treeOpFlags undefined{-pgf-} + }), +-} + ("q", emptyCommandInfo { + longname = "quit", + synopsis = "exit GF interpreter" + }), + ("r", emptyCommandInfo { + longname = "reload", + synopsis = "repeat the latest import command" + }), +{- + ("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 = \env@(pgf, mos) opts _ -> do + let file = valStrOpts "file" "_gftmp" opts + let exprs [] = ([],empty) + exprs ((n,s):ls) | null s + = exprs ls + exprs ((n,s):ls) = case H.readExpr s of + Just e -> let (es,err) = exprs ls + in case H.inferExpr pgf e of + Right (e,t) -> (e:es,err) + Left tcerr -> (es,"on line" <+> n <> ':' $$ nest 2 (H.ppTcError tcerr) $$ err) + Nothing -> let (es,err) = exprs ls + in (es,"on line" <+> n <> ':' <+> "parse error" $$ err) + returnFromLines ls = case exprs ls of + (es, err) | null es -> return $ pipeMessage $ render (err $$ "no trees found") + | otherwise -> return $ pipeWithMessage es (render err) + + s <- restricted $ readFile file + case opts of + _ | isOpt "lines" opts && isOpt "tree" opts -> + returnFromLines (zip [1::Int ..] (lines s)) + _ | isOpt "tree" opts -> + returnFromLines [(1::Int,s)] + _ | isOpt "lines" opts -> return (fromStrings $ lines s) + _ -> return (fromString s), + flags = [("file","the input file name")] + }), + + ("rt", emptyCommandInfo { + longname = "rank_trees", + synopsis = "show trees in an order of decreasing probability", + explanation = unlines [ + "Order trees from the most to the least probable, using either", + "even distribution in each category (default) or biased as specified", + "by the file given by flag -probs=FILE, where each line has the form", + "'function probability', e.g. 'youPol_Pron 0.01'." + ], + exec = \env@(pgf, mos) opts ts -> do + pgf <- optProbs opts pgf + let tds = H.rankTreesByProbs pgf ts + if isOpt "v" opts + then putStrLn $ + unlines [H.showExpr [] t ++ "\t--" ++ show d | (t,d) <- tds] + else return () + returnFromExprs $ map fst tds, + flags = [ + ("probs","probabilities from this file (format 'f 0.6' per line)") + ], + options = [ + ("v","show all trees with their probability scores") + ], + examples = [ + mkEx "p \"you are here\" | rt -probs=probs | pt -number=1 -- most probable result" + ] + }), + + ("tq", emptyCommandInfo { + longname = "translation_quiz", + syntax = "tq -from=LANG -to=LANG (-cat=CAT)? (-probs=FILE)? TREE?", + synopsis = "start a translation quiz", + exec = \env@(pgf, mos) opts xs -> do + let from = optLangFlag "from" pgf opts + let to = optLangFlag "to" pgf opts + let typ = optType pgf opts + let mt = mexp xs + pgf <- optProbs opts pgf + restricted $ translationQuiz mt pgf from to typ + return void, + flags = [ + ("from","translate from this language"), + ("to","translate to this language"), + ("cat","translate in this category"), + ("number","the maximum number of questions"), + ("probs","file with biased probabilities for generation") + ], + examples = [ + mkEx ("tq -from=Eng -to=Swe -- any trees in startcat"), + mkEx ("tq -from=Eng -to=Swe (AdjCN (PositA ?2) (UseN ?)) -- only trees of this form") + ] + }), + + ("sd", emptyCommandInfo { + longname = "show_dependencies", + syntax = "sd QUALIFIED_CONSTANT+", + synopsis = "show all constants that the given constants depend on", + explanation = unlines [ + "Show recursively all qualified constant names, by tracing back the types and definitions", + "of each constant encountered, but just listing every name once.", + "This command requires a source grammar to be in scope, imported with 'import -retain'.", + "Notice that the accuracy is better if the modules are compiled with the flag -optimize=noexpand.", + "This command must be a line of its own, and thus cannot be a part of a pipe." + ], + options = [ + ("size","show the size of the source code for each constants (number of constructors)") + ], + examples = [ + mkEx "sd ParadigmsEng.mkV ParadigmsEng.mkN -- show all constants on which mkV and mkN depend", + mkEx "sd -size ParadigmsEng.mkV -- show all constants on which mkV depends, together with size" + ], + needsTypeCheck = False + }), +-} + ("se", emptyCommandInfo { + longname = "set_encoding", + synopsis = "set the encoding used in current terminal", + syntax = "se ID", + examples = [ + mkEx "se cp1251 -- set encoding to cp1521", + mkEx "se utf8 -- set encoding to utf8 (default)" + ], + needsTypeCheck = False + }), + ("sp", emptyCommandInfo { + longname = "system_pipe", + synopsis = "send argument to a system command", + syntax = "sp -command=\"SYSTEMCOMMAND\", alt. ? SYSTEMCOMMAND", + exec = \_ opts arg -> do + let syst = optComm opts -- ++ " " ++ tmpi + {- + let tmpi = "_tmpi" --- + let tmpo = "_tmpo" + restricted $ writeFile tmpi $ toString arg + restrictedSystem $ syst ++ " <" ++ tmpi ++ " >" ++ tmpo + fmap fromString $ restricted $ readFile tmpo, + -} + fmap fromString . restricted . readShellProcess syst $ toString arg, + flags = [ + ("command","the system command applied to the argument") + ], + examples = [ + mkEx "gt | l | ? wc -- generate trees, linearize, and count words" + ] + }), +{- + ("so", emptyCommandInfo { + longname = "show_operations", + syntax = "so (-grep=STRING)* TYPE?", + synopsis = "show all operations in scope, possibly restricted to a value type", + explanation = unlines [ + "Show the names and type signatures of all operations available in the current resource.", + "This command requires a source grammar to be in scope, imported with 'import -retain'.", + "The operations include the parameter constructors that are in scope.", + "The optional TYPE filters according to the value type.", + "The grep STRINGs filter according to other substrings of the type signatures.", + "This command must be a line of its own, and thus cannot be a part", + "of a pipe." + ], + flags = [ + ("grep","substring used for filtering (the command can have many of these)") + ], + options = [ + ("raw","show the types in computed forms (instead of category names)") + ], + needsTypeCheck = False + }), + + ("ss", emptyCommandInfo { + longname = "show_source", + syntax = "ss (-strip)? (-save)? MODULE*", + synopsis = "show the source code of modules in scope, possibly just headers", + explanation = unlines [ + "Show compiled source code, i.e. as it is included in GF object files.", + "This command requires a source grammar to be in scope, imported with 'import -retain'.", + "The optional MODULE arguments cause just these modules to be shown.", + "The -size and -detailedsize options show code size as the number of constructor nodes.", + "This command must be a line of its own, and thus cannot be a part of a pipe." + ], + options = [ + ("detailedsize", "instead of code, show the sizes of all judgements and modules"), + ("save", "save each MODULE in file MODULE.gfh instead of printing it on terminal"), + ("size", "instead of code, show the sizes of all modules"), + ("strip","show only type signatures of oper's and lin's, not their definitions") + ], + examples = [ + mkEx "ss -- print complete current source grammar on terminal", + mkEx "ss -strip -save MorphoFin -- print the headers in file MorphoFin.gfh" + ], + needsTypeCheck = False + }), +-} + ("ut", emptyCommandInfo { + longname = "unicode_table", + synopsis = "show a transliteration table for a unicode character set", + exec = \_ opts _ -> do + let t = concatMap prOpt (take 1 opts) + let out = maybe "no such transliteration" characterTable $ transliteration t + return $ fromString out, + options = transliterationPrintNames + }), +{- + ("vd", emptyCommandInfo { + longname = "visualize_dependency", + synopsis = "show word dependency tree graphically", + explanation = unlines [ + "Prints a dependency tree in the .dot format (the graphviz format, default)", + "or the CoNLL/MaltParser format (flag -output=conll for training, malt_input", + "for unanalysed input).", + "By default, the last argument is the head of every abstract syntax", + "function; moreover, the head depends on the head of the function above.", + "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 png, unless overridden by the", + "flag -format." + ], + exec = \env@(pgf, mos) opts es -> do + let debug = isOpt "v" opts + let file = valStrOpts "file" "" opts + let outp = valStrOpts "output" "dot" opts + mlab <- case file of + "" -> return Nothing + _ -> (Just . H.getDepLabels . lines) `fmap` restricted (readFile file) + let lang = optLang pgf opts + let grphs = unlines $ map (H.graphvizDependencyTree outp debug mlab Nothing pgf lang) es + if isFlag "view" opts || isFlag "format" opts then do + let file s = "_grphd." ++ s + let view = optViewGraph opts + let format = optViewFormat opts + restricted $ writeUTF8File (file "dot") grphs + restrictedSystem $ "dot -T" ++ format ++ " " ++ file "dot" ++ " > " ++ file format + restrictedSystem $ view ++ " " ++ file format + return void + else return $ fromString grphs, + examples = [ + mkEx "gr | vd -- generate a tree and show dependency tree in .dot", + mkEx "gr | vd -view=open -- generate a tree and display dependency tree on a Mac", + mkEx "gr -number=1000 | vd -file=dep.labels -output=malt -- generate training treebank", + mkEx "gr -number=100 | vd -file=dep.labels -output=malt_input -- generate test sentences" + ], + options = [ + ("v","show extra information") + ], + flags = [ + ("file","configuration file for labels per fun, format 'fun l1 ... label ... l2'"), + ("format","format of the visualization file (default \"png\")"), + ("output","output format of graph source (default \"dot\")"), + ("view","program to open the resulting file (default \"open\")"), + ("lang","the language of analysis") + ] + }), + + + ("vp", emptyCommandInfo { + longname = "visualize_parse", + synopsis = "show parse tree graphically", + explanation = unlines [ + "Prints a parse tree 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 png, unless overridden by the", + "flag -format." + ], + exec = \env@(pgf, mos) opts es -> do + let lang = optLang pgf opts + let gvOptions=H.GraphvizOptions {H.noLeaves = isOpt "noleaves" opts && not (isOpt "showleaves" opts), + H.noFun = isOpt "nofun" opts || not (isOpt "showfun" opts), + H.noCat = isOpt "nocat" opts && not (isOpt "showcat" opts), + H.nodeFont = valStrOpts "nodefont" "" opts, + H.leafFont = valStrOpts "leaffont" "" opts, + H.nodeColor = valStrOpts "nodecolor" "" opts, + H.leafColor = valStrOpts "leafcolor" "" opts, + H.nodeEdgeStyle = valStrOpts "nodeedgestyle" "solid" opts, + H.leafEdgeStyle = valStrOpts "leafedgestyle" "dashed" opts + } + let grph = if null es + then [] + else H.graphvizParseTree pgf lang gvOptions (head es) + if isFlag "view" opts || isFlag "format" opts then do + let file s = "_grph." ++ s + let view = optViewGraph opts + let format = optViewFormat opts + restricted $ writeUTF8File (file "dot") grph + restrictedSystem $ "dot -T" ++ format ++ " " ++ file "dot" ++ " > " ++ file format + restrictedSystem $ view ++ " " ++ file format + return void + else return $ fromString grph, + examples = [ + mkEx "p \"John walks\" | vp -- generate a tree and show parse tree as .dot script", + mkEx "gr | vp -view=\"open\" -- generate a tree and display parse tree on a Mac" + ], + options = [ + ("showcat","show categories in the tree nodes (default)"), + ("nocat","don't show categories"), + ("showfun","show function names in the tree nodes"), + ("nofun","don't show function names (default)"), + ("showleaves","show the leaves of the tree (default)"), + ("noleaves","don't show the leaves of the tree (i.e., only the abstract tree)") + ], + flags = [ + ("format","format of the visualization file (default \"png\")"), + ("view","program to open the resulting file (default \"open\")"), + ("nodefont","font for tree nodes (default: Times -- graphviz standard font)"), + ("leaffont","font for tree leaves (default: nodefont)"), + ("nodecolor","color for tree nodes (default: black -- graphviz standard color)"), + ("leafcolor","color for tree leaves (default: nodecolor)"), + ("nodeedgestyle","edge style between tree nodes (solid/dashed/dotted/bold, default: solid)"), + ("leafedgestyle","edge style for links to leaves (solid/dashed/dotted/bold, default: dashed)") + ] + }), + + ("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.", + "With option -mk, use for showing library style function names of form 'mkC'." + ], + exec = \env@(pgf, mos) opts es -> + if isOpt "mk" opts + then return $ fromString $ unlines $ map (tree2mk pgf) es + else if isOpt "api" opts + then do + let ss = map exprToAPI es + mapM_ putStrLn ss + return void + else do + let funs = not (isOpt "nofun" opts) + let cats = not (isOpt "nocat" opts) + let grph = unlines (map (H.graphvizAbstractTree pgf (funs,cats)) es) -- True=digraph + if isFlag "view" opts || isFlag "format" opts then do + let file s = "_grph." ++ s + let view = optViewGraph opts + let format = optViewFormat opts + restricted $ writeUTF8File (file "dot") grph + restrictedSystem $ "dot -T" ++ format ++ " " ++ file "dot" ++ " > " ++ file format + restrictedSystem $ view ++ " " ++ file format + return void + else return $ fromString grph, + examples = [ + mkEx "p \"hello\" | vt -- parse a string and show trees as graph script", + mkEx "p \"hello\" | vt -view=\"open\" -- parse a string and display trees on a Mac" + ], + options = [ + ("api", "show the tree with function names converted to 'mkC' with value cats C"), + ("mk", "similar to -api, deprecated"), + ("nofun","don't show functions but only categories"), + ("nocat","don't show categories but only functions") + ], + flags = [ + ("format","format of the visualization file (default \"png\")"), + ("view","program to open the resulting file (default \"open\")") + ] + }), +-} + ("wf", emptyCommandInfo { + longname = "write_file", + synopsis = "send string or tree to a file", + exec = \_ opts arg -> do + let file = valStrOpts "file" "_gftmp" opts + if isOpt "append" opts + then restricted $ appendFile file (toString arg) + else restricted $ writeUTF8File file (toString arg) + return void, + options = [ + ("append","append to file, instead of overwriting it") + ], + flags = [("file","the output filename")] + }){-, + ("ai", emptyCommandInfo { + longname = "abstract_info", + syntax = "ai IDENTIFIER or ai EXPR", + synopsis = "Provides an information about a function, an expression or a category from the abstract syntax", + explanation = unlines [ + "The command has one argument which is either function, expression or", + "a category defined in the abstract syntax of the current grammar. ", + "If the argument is a function then ?its type is printed out.", + "If it is a category then the category definition is printed.", + "If a whole expression is given it prints the expression with refined", + "metavariables and the type of the expression." + ], + exec = \env@(pgf, mos) opts arg -> do + case arg of + [H.EFun id]->case Map.lookup id (H.funs (H.abstract pgf)) of + Just fd -> do putStrLn $ render (H.ppFun id fd) + let (_,_,_,prob) = fd + putStrLn ("Probability: "++show prob) + return void + Nothing -> case Map.lookup id (H.cats (H.abstract pgf)) of + Just cd -> do putStrLn $ + render (H.ppCat id cd $$ + if null (H.functionsToCat pgf id) + then empty + else ' ' $$ + vcat [H.ppFun fid (ty,0,Just ([],[]),0) | (fid,ty) <- H.functionsToCat pgf id] $$ + ' ') + let (_,_,prob) = cd + putStrLn ("Probability: "++show prob) + return void + Nothing -> do putStrLn ("unknown category of function identifier "++show id) + return void + [e] -> case H.inferExpr pgf e of + Left tcErr -> error $ render (H.ppTcError tcErr) + Right (e,ty) -> do putStrLn ("Expression: "++H.showExpr [] e) + putStrLn ("Type: "++H.showType [] ty) + putStrLn ("Probability: "++show (H.probTree pgf e)) + return void + _ -> do putStrLn "a single identifier or expression is expected from the command" + return void, + needsTypeCheck = False + })-} + ] + where +{- + par pgf opts s = case optOpenTypes opts of + [] -> [H.parse_ pgf lang (optType pgf opts) (Just dp) s | lang <- optLangs pgf opts] + open_typs -> [H.parseWithRecovery pgf lang (optType pgf opts) open_typs (Just dp) s | lang <- optLangs pgf opts] + where + dp = valIntOpts "depth" 4 opts +-} + cParse env@(pgf,_) opts ss = + parsed [ C.parse cnc cat s | s<-ss,(lang,cnc)<-cncs] + where + cat = optCat pgf opts + cncs = optConcs env opts + parsed rs = Piped (ts,unlines msgs) + where + ts = [hsExpr t|Right ts<-rs,(t,p)<-takeOptNum opts ts] + msgs = concatMap (either err ok) rs + err msg = ["Parse failed: "++msg] + ok = map (C.showExpr . fst).takeOptNum opts + + cLins env opts ts = [C.linearize cnc t|t<-ts,(lang,cnc)<-cncs] + where + cncs = optConcs env opts + + optConcs = optConcsFlag "lang" + + optConcsFlag f (pgf,cncs) opts = + case valStrOpts f "" opts of + "" -> Map.toList cncs + lang -> mapMaybe pickLang (chunks ',' lang) + where + pickLang l = pick l `mplus` pick fl + where + fl = C.abstractName pgf++l + pick l = (,) l `fmap` Map.lookup l cncs + +{- + optLins pgf opts ts = case opts of + _ | isOpt "groups" opts -> + map (unlines . snd) $ H.groupResults + [[(lang, linear pgf opts lang t) | lang <- optLangs pgf opts] | t <- ts] + _ -> map (optLin pgf opts) ts + optLin pgf opts t = unlines $ + case opts of + _ | isOpt "treebank" opts && isOpt "chunks" opts -> + (H.showCId (H.abstractName pgf) ++ ": " ++ H.showExpr [] t) : + [H.showCId lang ++ ": " ++ li | (lang,li) <- linChunks pgf opts t] --linear pgf opts lang t | lang <- optLangs pgf opts] + _ | isOpt "treebank" opts -> + (H.showCId (H.abstractName pgf) ++ ": " ++ H.showExpr [] t) : + [H.showCId lang ++ ": " ++ linear pgf opts lang t | lang <- optLangs pgf opts] + _ | isOpt "chunks" opts -> map snd $ linChunks pgf opts t + _ -> [linear pgf opts lang t | lang <- optLangs pgf opts] + linChunks pgf opts t = + [(lang, unwords (intersperse "<+>" (map (linear pgf opts lang) (treeChunks t)))) | lang <- optLangs pgf opts] + + linear :: H.PGF -> [Option] -> H.CId -> H.Expr -> String + linear pgf opts lang = let unl = unlex opts lang in case opts of + _ | isOpt "all" opts -> unlines . concat . intersperse [[]] . + map (map (unl . snd)) . H.tabularLinearizes pgf lang + _ | isOpt "list" opts -> commaList . concat . intersperse [[]] . + map (map (unl . snd)) . H.tabularLinearizes pgf lang + _ | isOpt "table" opts -> unlines . concat . intersperse [[]] . + map (map (\(p,v) -> p+++":"+++unl v)) . H.tabularLinearizes pgf lang + _ | isOpt "bracket" opts -> unwords . map H.showBracketedString . H.bracketedLinearize pgf lang + _ -> unl . H.linearize pgf lang + + -- replace each non-atomic constructor with mkC, where C is the val cat + tree2mk pgf = H.showExpr [] . t2m where + t2m t = case H.unApp t of + Just (cid,ts@(_:_)) -> H.mkApp (mk cid) (map t2m ts) + _ -> t + mk = H.mkCId . ("mk" ++) . H.showCId . H.lookValCat (H.abstract pgf) +-} + unlex opts lang = stringOps Nothing (getUnlex opts lang ++ map prOpt opts) ---- + + getUnlex opts lang = case words (valStrOpts "unlexer" "" opts) of + lexs -> case lookup lang + [(H.mkCId la,tail le) | lex <- lexs, let (la,le) = span (/='=') lex, not (null le)] of + Just le -> chunks ',' le + _ -> [] +{- + commaList [] = [] + commaList ws = concat $ head ws : map (", " ++) (tail ws) +-} +-- 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 pgf opts lang = {- trace (unwords optsC) $ -} stringOps Nothing optsC where ---- + optsC = case lookConcrFlag pgf (H.mkCId lang) (H.mkCId "coding") of + Just (LStr "utf8") -> filter (/="to_utf8") $ map prOpt opts + Just (LStr other) | isOpt "to_utf8" opts -> + let cod = ("from_" ++ other) + in cod : filter (/=cod) (map prOpt opts) + _ -> map prOpt opts + + optRestricted opts pgf = + H.restrictPGF (\f -> and [H.hasLin pgf la f | la <- optLangs pgf opts]) pgf + + optLang = optLangFlag "lang" + optLangs = optLangsFlag "lang" + + optLangsFlag f pgf opts = case valStrOpts f "" opts of + "" -> H.languages pgf + lang -> map (completeLang pgf) (chunks ',' lang) + + completeLang pgf la = let cla = (H.mkCId la) in + if elem cla (H.languages pgf) + then cla + else (H.mkCId (H.showCId (H.abstractName pgf) ++ la)) + + optLangFlag f pgf opts = head $ optLangsFlag f pgf opts ++ [H.wildCId] + + optOpenTypes opts = case valStrOpts "openclass" "" opts of + "" -> [] + cats -> mapMaybe H.readType (chunks ',' cats) + + optProbs opts pgf = case valStrOpts "probs" "" opts of + "" -> return pgf + file -> do + probs <- restricted $ H.readProbabilitiesFromFile file pgf + return (H.setProbabilities probs pgf) +-} + optTranslit opts = case (valStrOpts "to" "" opts, valStrOpts "from" "" opts) of + ("","") -> return id + (file,"") -> do + src <- restricted $ readFile file + return $ transliterateWithFile file src False + (_,file) -> do + src <- restricted $ readFile file + return $ transliterateWithFile file src True +{- + optFile opts = valStrOpts "file" "_gftmp" opts +-} + optCat pgf opts = valStrOpts "cat" (C.startCat pgf) opts +{- + optType pgf opts = + let str = valStrOpts "cat" (H.showCId $ H.lookStartCat pgf) opts + in case H.readType str of + Just ty -> case H.checkType pgf ty of + Left tcErr -> error $ render (H.ppTcError tcErr) + Right ty -> ty + Nothing -> error ("Can't parse '"++str++"' as a type") +-} + optComm opts = valStrOpts "command" "" opts +{- + optViewFormat opts = valStrOpts "format" "png" opts + optViewGraph opts = valStrOpts "view" "open" opts + optNum opts = valIntOpts "number" 1 opts +-} + optNumInf opts = valIntOpts "number" 1000000000 opts ---- 10^9 + takeOptNum opts = take (optNumInf opts) +{- + fromParse opts [] = ([],[]) + fromParse opts ((s,(po,bs)):ps) + | isOpt "bracket" opts = (es, H.showBracketedString bs + ++ "\n" ++ msg) + | otherwise = case po of + H.ParseOk ts -> let Piped (es',msg') = fromExprs ts + in (es'++es,msg'++msg) + H.TypeError errs -> ([], render ("The parsing is successful but the type checking failed with error(s):" $$ + nest 2 (vcat (map (H.ppTcError . snd) errs))) + ++ "\n" ++ msg) + H.ParseFailed i -> ([], "The parser failed at token " ++ show (words s !! max 0 (i-1)) + ++ "\n" ++ msg) + H.ParseIncomplete-> ([], "The sentence is not complete") + where + (es,msg) = fromParse opts ps +-} + returnFromCExprs = returnFromExprs . map hsExpr + returnFromExprs es = + return $ case es of + [] -> pipeMessage "no trees found" + _ -> fromExprs es +{- + prGrammar env@(pgf,mos) opts + | isOpt "pgf" opts = do + let pgf1 = if isOpt "opt" opts then H.optimizePGF pgf else pgf + let outfile = valStrOpts "file" (H.showCId (H.abstractName pgf) ++ ".pgf") opts + restricted $ encodeFile outfile pgf1 + putStrLn $ "wrote file " ++ outfile + return void + | isOpt "cats" opts = return $ fromString $ unwords $ map H.showCId $ H.categories pgf + | isOpt "funs" opts = return $ fromString $ unlines $ map showFun $ funsigs pgf + | isOpt "fullform" opts = return $ fromString $ concatMap (morpho mos "" prFullFormLexicon) $ optLangs pgf opts + | isOpt "langs" opts = return $ fromString $ unwords $ map H.showCId $ H.languages pgf + + | isOpt "lexc" opts = return $ fromString $ concatMap (morpho mos "" prLexcLexicon) $ optLangs pgf opts + | isOpt "missing" opts = return $ fromString $ unlines $ [unwords (H.showCId la:":": map H.showCId cs) | + la <- optLangs pgf opts, let cs = H.missingLins pgf la] + | isOpt "words" opts = return $ fromString $ concatMap (morpho mos "" prAllWords) $ optLangs pgf opts + | otherwise = do fmt <- readOutputFormat (valStrOpts "printer" "pgf_pretty" opts) + return $ fromString $ concatMap snd $ exportPGF noOptions fmt pgf + + funsigs pgf = [(f,ty) | (f,(ty,_,_,_)) <- Map.assocs (H.funs (H.abstract pgf))] + showFun (f,ty) = H.showCId f ++ " : " ++ H.showType [] ty ++ " ;" + + morphos (pgf,mos) opts s = + [(s,morpho mos [] (\mo -> H.lookupMorpho mo s) la) | la <- optLangs pgf opts] + + morpho mos z f la = maybe z f $ Map.lookup la mos + + optMorpho (pgf,mos) opts = morpho mos (error "no morpho") id (head (optLangs pgf opts)) + + optClitics opts = case valStrOpts "clitics" "" opts of + "" -> [] + cs -> map reverse $ chunks ',' cs + + mexp xs = case xs of + t:_ -> Just t + _ -> Nothing +-} + -- ps -f -g s returns g (f s) + stringOps menv opts s = foldr (menvop . app) s (reverse opts) where + app f = maybe id id (stringOp f) + menvop op = maybe op (\ (b,e) -> opInEnv b e op) menv + + envFlag fs = case valStrOpts "env" "global" fs of + "quotes" -> Just ("\"","\"") + _ -> Nothing +{- + treeOps pgf opts s = foldr app s (reverse opts) where + app (OOpt op) | Just (Left f) <- treeOp pgf op = f + app (OFlag op (VId x)) | Just (Right f) <- treeOp pgf op = f (H.mkCId x) + app _ = id +-} +stringOpOptions = sort $ [ + ("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_utf8","decode from utf8 (default)"), + ("lextext","text-like lexer"), + ("lexcode","code-like lexer"), + ("lexmixed","mixture of text and code, as in LaTeX (code between $...$, \\(...)\\, \\[...\\])"), + ("to_cp1251","encode to cp1251 (Cyrillic used in Bulgarian resource)"), + ("to_html","wrap in a html file with linebreaks"), + ("to_utf8","encode to utf8 (default)"), + ("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)") + ] ++ + concat [ + [("from_" ++ p, "from unicode to GF " ++ n ++ " transliteration"), + ("to_" ++ p, "from GF " ++ n ++ " transliteration to unicode")] | + (p,n) <- transliterationPrintNames] +{- +treeOpOptions pgf = [(op,expl) | (op,(expl,Left _)) <- allTreeOps pgf] +treeOpFlags pgf = [(op,expl) | (op,(expl,Right _)) <- allTreeOps pgf] + +translationQuiz :: Maybe H.Expr -> H.PGF -> H.Language -> H.Language -> H.Type -> IO () +translationQuiz mex pgf ig og typ = do + tts <- translationList mex pgf ig og typ infinity + mkQuiz "Welcome to GF Translation Quiz." tts + +morphologyQuiz :: Maybe H.Expr -> H.PGF -> H.Language -> H.Type -> IO () +morphologyQuiz mex pgf ig typ = do + tts <- morphologyList mex pgf ig typ infinity + mkQuiz "Welcome to GF Morphology Quiz." tts + +-- | the maximal number of precompiled quiz problems +infinity :: Int +infinity = 256 + +prLexcLexicon :: H.Morpho -> String +prLexcLexicon mo = + unlines $ "Multichar_Symbols":multichars:"":"LEXICON Root" : [prLexc l p ++ ":" ++ w ++ " # ;" | (w,lps) <- morpho, (l,p) <- lps] ++ ["END"] + where + morpho = H.fullFormLexicon mo + prLexc l p = H.showCId l ++ concat (mkTags (words p)) + mkTags p = case p of + "s":ws -> mkTags ws --- remove record field + ws -> map ('+':) ws + + multichars = unwords $ nub $ concat [mkTags (words p) | (w,lps) <- morpho, (l,p) <- lps] + -- thick_A+(AAdj+Posit+Gen):thick's # ; + +prFullFormLexicon :: H.Morpho -> String +prFullFormLexicon mo = + unlines (map prMorphoAnalysis (H.fullFormLexicon mo)) + +prAllWords :: H.Morpho -> String +prAllWords mo = + unwords [w | (w,_) <- H.fullFormLexicon mo] + +prMorphoAnalysis :: (String,[(H.Lemma,H.Analysis)]) -> String +prMorphoAnalysis (w,lps) = + unlines (w:[H.showCId l ++ " : " ++ p | (l,p) <- lps]) +-} + +trie = render . pptss . H.toTrie . map H.toATree + where + pptss [ts] = "*"<+>nest 2 (ppts ts) + pptss tss = vcat [i<+>nest 2 (ppts ts)|(i,ts)<-zip [(1::Int)..] tss] + + ppts = vcat . map ppt + + ppt t = + case t of + H.Oth e -> pp (H.showExpr [] e) + H.Ap f [[]] -> pp (H.showCId f) + H.Ap f tss -> H.showCId f $$ nest 2 (pptss tss) + +hsExpr c = + case C.unApp c of + Just (f,cs) -> H.mkApp (H.mkCId f) (map hsExpr cs) + _ -> error "GF.Command.Commands2.hsExpr" + +cExpr e = + case H.unApp e of + Just (f,es) -> C.mkApp (H.showCId f) (map cExpr es) + _ -> error "GF.Command.Commands2.cExpr" + +needPGF exec (mb_pgf,cncs) opts ts = + case mb_pgf of + Just pgf -> exec (pgf,cncs) opts ts + _ -> fail "Import a grammar before using this command" diff --git a/src/compiler/GF/Infra/Option.hs b/src/compiler/GF/Infra/Option.hs index 51aa44b82..a9a517a6e 100644 --- a/src/compiler/GF/Infra/Option.hs +++ b/src/compiler/GF/Infra/Option.hs @@ -73,7 +73,10 @@ errors = raise . unlines -- Types -data Mode = ModeVersion | ModeHelp | ModeInteractive | ModeRun | ModeCompiler +data Mode = ModeVersion | ModeHelp + | ModeInteractive | ModeRun + | ModeInteractive2 | ModeRun2 + | ModeCompiler | ModeServer {-port::-}Int deriving (Show,Eq,Ord) @@ -302,6 +305,8 @@ optDescr = Option ['j'] ["jobs"] (OptArg jobs "N") "Compile N modules in parallel with -batch (default 1).", Option [] ["interactive"] (NoArg (mode ModeInteractive)) "Run in interactive mode (default).", Option [] ["run"] (NoArg (mode ModeRun)) "Run in interactive mode, showing output only (no other messages).", + Option [] ["cshell"] (NoArg (mode ModeInteractive2)) "Start the C run-time shell.", + Option [] ["crun"] (NoArg (mode ModeRun2)) "Start the C run-time shell, showing output only (no other messages).", Option [] ["server"] (OptArg modeServer "port") $ "Run in HTTP server mode on given port (default "++show defaultPort++").", Option [] ["document-root"] (ReqArg gfDocuRoot "DIR") diff --git a/src/compiler/GF/Infra/SIO.hs b/src/compiler/GF/Infra/SIO.hs index 5ca683707..e24a6cb35 100644 --- a/src/compiler/GF/Infra/SIO.hs +++ b/src/compiler/GF/Infra/SIO.hs @@ -1,5 +1,6 @@ -- | Shell IO: a monad that can restrict acesss to arbitrary IO and has the -- ability to capture output that normally would be sent to stdout. +{-# LANGUAGE CPP #-} module GF.Infra.SIO( -- * The SIO monad SIO, @@ -11,6 +12,9 @@ module GF.Infra.SIO( newStdGen,print,putStrLn, -- ** Specific to GF importGrammar,importSource, +#ifdef C_RUNTIME + readPGF2, +#endif putStrLnFlush,runInterruptibly,lazySIO, -- * Restricted accesss to arbitrary (potentially unsafe) IO operations -- | If the environment variable GF_RESTRICTED is defined, these @@ -33,6 +37,9 @@ import qualified System.Random as IO(newStdGen) import qualified GF.Infra.UseIO as IO(getLibraryDirectory) import qualified GF.System.Signal as IO(runInterruptibly) import qualified GF.Command.Importing as GF(importGrammar, importSource) +#ifdef C_RUNTIME +import qualified PGF2 +#endif -- * The SIO monad @@ -96,3 +103,7 @@ lazySIO = lift1 lazyIO importGrammar pgf opts files = lift0 $ GF.importGrammar pgf opts files importSource opts files = lift0 $ GF.importSource opts files + +#ifdef C_RUNTIME +readPGF2 = lift0 . PGF2.readPGF +#endif diff --git a/src/compiler/GF/Interactive2.hs b/src/compiler/GF/Interactive2.hs new file mode 100644 index 000000000..ac7247a8d --- /dev/null +++ b/src/compiler/GF/Interactive2.hs @@ -0,0 +1,538 @@ +{-# LANGUAGE ScopedTypeVariables, CPP #-} +-- | GF interactive mode (with the C run-time system) +module GF.Interactive2 (mainGFI,mainRunGFI{-,mainServerGFI-}) where +import Prelude hiding (putStrLn,print) +import qualified Prelude as P(putStrLn) +import GF.Command.Interpreter(CommandEnv(..),commands,mkCommandEnv,interpretCommandLine) +--import GF.Command.Importing(importSource,importGrammar) +import GF.Command.Commands2(flags,options,PGFEnv,pgfEnv,emptyPGFEnv,allCommands) +import GF.Command.Abstract +import GF.Command.Parse(readCommandLine,pCommand) +import GF.Data.Operations (Err(..),chunks,err,raise,done) +import GF.Grammar hiding (Ident,isPrefixOf) +import GF.Grammar.Analyse +import GF.Grammar.Parser (runP, pExp) +import GF.Grammar.ShowTerm +import GF.Grammar.Lookup (allOpers,allOpersTo) +import GF.Compile.Rename(renameSourceTerm) +--import GF.Compile.Compute.Concrete (computeConcrete,checkPredefError) +import qualified GF.Compile.Compute.ConcreteNew as CN(normalForm,resourceValues) +import GF.Compile.TypeCheck.RConcrete as TC(inferLType,ppType) +import GF.Infra.Dependencies(depGraph) +import GF.Infra.CheckM +import GF.Infra.UseIO(ioErrorText) +import GF.Infra.SIO +import GF.Infra.Option +import qualified System.Console.Haskeline as Haskeline +--import GF.Text.Coding(decodeUnicode,encodeUnicode) + +--import GF.Compile.Coding(codeTerm) + +import qualified PGF2 as C +import qualified PGF as H +import qualified PGF.Internal as H(emptyPGF,abstract,funs,lookStartCat) + +import Data.Char +import Data.List(nub,isPrefixOf,isInfixOf,partition) +import qualified Data.Map as Map +--import qualified Data.ByteString.Char8 as BS +import qualified Data.ByteString.UTF8 as UTF8(fromString) +import qualified Text.ParserCombinators.ReadP as RP +--import System.IO(utf8) +--import System.CPUTime(getCPUTime) +import System.Directory({-getCurrentDirectory,-}getAppUserDataDirectory) +import System.FilePath(takeExtensions) +import Control.Exception(SomeException,fromException,evaluate,try) +import Control.Monad +import GF.Text.Pretty (render) +import qualified GF.System.Signal as IO(runInterruptibly) +{- +#ifdef SERVER_MODE +import GF.Server(server) +#endif +-} +import GF.System.Console(changeConsoleEncoding) + +import GF.Infra.BuildInfo(buildInfo) +import Data.Version(showVersion) +import Paths_gf(version) + +-- | Run the GF Shell in quiet mode (@gf -run@). +mainRunGFI :: Options -> [FilePath] -> IO () +mainRunGFI opts files = shell (beQuiet opts) files + +beQuiet = addOptions (modifyFlags (\f -> f{optVerbosity=Quiet})) + +-- | Run the interactive GF Shell +mainGFI :: Options -> [FilePath] -> IO () +mainGFI opts files = do + P.putStrLn welcome + shell opts files + +shell opts files = loop opts =<< runSIO (importInEnv emptyGFEnv opts files) +{- +#ifdef SERVER_MODE +-- | Run the GF Server (@gf -server@). +-- The 'Int' argument is the port number for the HTTP service. +mainServerGFI opts0 port files = + server jobs port root (execute1 opts) + =<< runSIO (importInEnv emptyGFEnv opts files) + where + root = flag optDocumentRoot opts + opts = beQuiet opts0 + jobs = join (flag optJobs opts) +#else +mainServerGFI opts files = + error "GF has not been compiled with server mode support" +#endif +-} +-- | Read end execute commands until it is time to quit +loop :: Options -> GFEnv -> IO () +loop opts gfenv = maybe done (loop opts) =<< readAndExecute1 opts gfenv + +-- | Read and execute one command, returning Just an updated environment for +-- | the next command, or Nothing when it is time to quit +readAndExecute1 :: Options -> GFEnv -> IO (Maybe GFEnv) +readAndExecute1 opts gfenv = + runSIO . execute1 opts gfenv =<< readCommand opts gfenv + +-- | Read a command +readCommand :: Options -> GFEnv -> IO String +readCommand opts gfenv0 = + case flag optMode opts of + ModeRun -> tryGetLine + _ -> fetchCommand gfenv0 + +-- | Optionally show how much CPU time was used to run an IO action +optionallyShowCPUTime :: Options -> SIO a -> SIO a +optionallyShowCPUTime opts act + | not (verbAtLeast opts Normal) = act + | otherwise = do t0 <- getCPUTime + r <- act + t1 <- getCPUTime + let dt = t1-t0 + putStrLnFlush $ show (dt `div` 1000000000) ++ " msec" + return r + +{- +loopOptNewCPU opts gfenv' + | not (verbAtLeast opts Normal) = return gfenv' + | otherwise = do + cpu' <- getCPUTime + putStrLnFlush (show ((cpu' - cputime gfenv') `div` 1000000000) ++ " msec") + return $ gfenv' {cputime = cpu'} +-} + +-- | Execute a given command, returning Just an updated environment for +-- | the next command, or Nothing when it is time to quit +execute1 :: Options -> GFEnv -> String -> SIO (Maybe GFEnv) +execute1 opts gfenv0 s0 = + interruptible $ optionallyShowCPUTime opts $ + case pwords s0 of + -- special commands, requiring source grammar in env + {-"eh":w:_ -> do + cs <- readFile w >>= return . map words . lines + gfenv' <- foldM (flip (process False benv)) gfenv cs + loopNewCPU gfenv' -} + "q" :_ -> quit + "!" :ws -> system_command ws +-- "cc":ws -> compute_concrete ws +-- "sd":ws -> show_deps ws +-- "so":ws -> show_operations ws +-- "ss":ws -> show_source ws +-- "dg":ws -> dependency_graph ws + "eh":ws -> eh ws + "i" :ws -> import_ ws + -- other special commands, working on GFEnv + "e" :_ -> empty + "dc":ws -> define_command ws + "dt":ws -> define_tree ws + "ph":_ -> print_history + "r" :_ -> reload_last + "se":ws -> set_encoding ws + -- ordinary commands, working on CommandEnv + _ -> do interpretCommandLine env s0 + continue gfenv + where +-- loopNewCPU = fmap Just . loopOptNewCPU opts + continue = return . Just + stop = return Nothing + env = commandenv gfenv0 +-- sgr = grammar gfenv0 + gfenv = gfenv0 {history = s0 : history gfenv0} + pwords s = case words s of + w:ws -> getCommandOp w :ws + ws -> ws + + interruptible act = + either (\e -> printException e >> return (Just gfenv)) return + =<< runInterruptibly act + + -- Special commands: + + quit = do when (verbAtLeast opts Normal) $ putStrLn "See you." + stop + + system_command ws = do restrictedSystem $ unwords ws ; continue gfenv +{- + compute_concrete ws = do + let + pOpts style q ("-table" :ws) = pOpts TermPrintTable q ws + pOpts style q ("-all" :ws) = pOpts TermPrintAll q ws + pOpts style q ("-list" :ws) = pOpts TermPrintList q ws + pOpts style q ("-one" :ws) = pOpts TermPrintOne q ws + pOpts style q ("-default":ws) = pOpts TermPrintDefault q ws + pOpts style q ("-unqual" :ws) = pOpts style Unqualified ws + pOpts style q ("-qual" :ws) = pOpts style Qualified ws + pOpts style q ws = (style,q,unwords ws) + + (style,q,s) = pOpts TermPrintDefault Qualified ws + {- + (new,ws') = case ws of + "-new":ws' -> (True,ws') + "-old":ws' -> (False,ws') + _ -> (flag optNewComp opts,ws) + -} + case runP pExp (UTF8.fromString s) of + Left (_,msg) -> putStrLn msg + Right t -> putStrLn . err id (showTerm sgr style q) + . checkComputeTerm sgr + $ {-codeTerm (decodeUnicode utf8 . BS.pack)-} t + continue gfenv + + show_deps ws = do + let (os,xs) = partition (isPrefixOf "-") ws + ops <- case xs of + _:_ -> do + let ts = [t | Right t <- map (runP pExp . UTF8.fromString) xs] + err error (return . nub . concat) $ mapM (constantDepsTerm sgr) ts + _ -> error "expected one or more qualified constants as argument" + let prTerm = showTerm sgr TermPrintDefault Qualified + let size = sizeConstant sgr + let printed + | elem "-size" os = + let sz = map size ops in + unlines $ ("total: " ++ show (sum sz)) : + [prTerm f ++ "\t" ++ show s | (f,s) <- zip ops sz] + | otherwise = unwords $ map prTerm ops + putStrLn $ printed + continue gfenv + + show_operations ws = + case greatestResource sgr of + Nothing -> putStrLn "no source grammar in scope; did you import with -retain?" >> continue gfenv + Just mo -> do + let (os,ts) = partition (isPrefixOf "-") ws + let greps = [drop 6 o | o <- os, take 6 o == "-grep="] + let isRaw = elem "-raw" os + ops <- case ts of + _:_ -> do + let Right t = runP pExp (UTF8.fromString (unwords ts)) + ty <- err error return $ checkComputeTerm sgr t + return $ allOpersTo sgr ty + _ -> return $ allOpers sgr + let sigs = [(op,ty) | ((mo,op),ty,pos) <- ops] + let printer = if isRaw + then showTerm sgr TermPrintDefault Qualified + else (render . TC.ppType) + let printed = [unwords [showIdent op, ":", printer ty] | (op,ty) <- sigs] + mapM_ putStrLn [l | l <- printed, all (flip isInfixOf l) greps] + continue gfenv + + show_source ws = do + let (os,ts) = partition (isPrefixOf "-") ws + let strip = if elem "-strip" os then stripSourceGrammar else id + let mygr = strip $ case ts of + _:_ -> mGrammar [(i,m) | (i,m) <- modules sgr, elem (render i) ts] + [] -> sgr + case 0 of + _ | elem "-detailedsize" os -> putStrLn (printSizesGrammar mygr) + _ | elem "-size" os -> do + let sz = sizesGrammar mygr + putStrLn $ unlines $ + ("total\t" ++ show (fst sz)): + [render j ++ "\t" ++ show (fst k) | (j,k) <- snd sz] + _ | elem "-save" os -> mapM_ + (\ m@(i,_) -> let file = (render i ++ ".gfh") in + restricted $ writeFile file (render (ppModule Qualified m)) >> P.putStrLn ("wrote " ++ file)) + (modules mygr) + _ -> putStrLn $ render mygr + continue gfenv + + dependency_graph ws = + do let stop = case ws of + ('-':'o':'n':'l':'y':'=':fs):_ -> Just $ chunks ',' fs + _ -> Nothing + restricted $ writeFile "_gfdepgraph.dot" (depGraph stop sgr) + putStrLn "wrote graph in file _gfdepgraph.dot" + continue gfenv +-} + eh [w] = -- Ehhh? Reads commands from a file, but does not execute them + do cs <- restricted (readFile w) >>= return . map (interpretCommandLine env) . lines + continue gfenv + eh _ = do putStrLn "eh command not parsed" + continue gfenv + + import_ args = + do gfenv' <- case parseOptions args of + Ok (opts',files) -> do + curr_dir <- getCurrentDirectory + lib_dir <- getLibraryDirectory (addOptions opts opts') + importInEnv gfenv (addOptions opts (fixRelativeLibPaths curr_dir lib_dir opts')) files + Bad err -> do + putStrLn $ "Command parse error: " ++ err + return gfenv + continue gfenv' + + empty = continue $ gfenv { + commandenv=emptyCommandEnv --, grammar = () + } + + define_command (f:ws) = + case readCommandLine (unwords ws) of + Just comm -> continue $ gfenv { + commandenv = env { + commandmacros = Map.insert f comm (commandmacros env) + } + } + _ -> dc_not_parsed + define_command _ = dc_not_parsed + + dc_not_parsed = putStrLn "command definition not parsed" >> continue gfenv + + define_tree (f:ws) = + case H.readExpr (unwords ws) of + Just exp -> continue $ gfenv { + commandenv = env { + expmacros = Map.insert f exp (expmacros env) + } + } + _ -> dt_not_parsed + define_tree _ = dt_not_parsed + + dt_not_parsed = putStrLn "value definition not parsed" >> continue gfenv + + print_history = mapM_ putStrLn (reverse (history gfenv0))>> continue gfenv + + reload_last = do + let imports = [(s,ws) | s <- history gfenv0, ("i":ws) <- [pwords s]] + case imports of + (s,ws):_ -> do + putStrLn $ "repeating latest import: " ++ s + import_ ws + _ -> do + putStrLn $ "no import in history" + continue gfenv + + set_encoding [c] = + do let cod = renameEncoding c + restricted $ changeConsoleEncoding cod + continue gfenv + set_encoding _ = putStrLn "se command not parsed" >> continue gfenv + + +printException e = maybe (print e) (putStrLn . ioErrorText) (fromException e) + +checkComputeTerm sgr t = do + mo <- maybe (raise "no source grammar in scope") return $ greatestResource sgr + ((t,_),_) <- runCheck $ do t <- renameSourceTerm sgr mo t + inferLType sgr [] t + t1 <- return (CN.normalForm (CN.resourceValues noOptions sgr) (L NoLoc identW) t) + checkPredefError t1 + +fetchCommand :: GFEnv -> IO String +fetchCommand gfenv = do + path <- getAppUserDataDirectory "gf_history" + let settings = + Haskeline.Settings { + Haskeline.complete = wordCompletion gfenv, + Haskeline.historyFile = Just path, + Haskeline.autoAddHistory = True + } + res <- IO.runInterruptibly $ Haskeline.runInputT settings (Haskeline.getInputLine (prompt gfenv)) + case res of + Left _ -> return "" + Right Nothing -> return "q" + Right (Just s) -> return s + +importInEnv :: GFEnv -> Options -> [FilePath] -> SIO GFEnv +importInEnv gfenv opts files = + case files of + _ | flag optRetainResource opts -> + do putStrLn "Flag -retain is not supported in this shell" + return gfenv + [file] | takeExtensions file == ".pgf" -> importPGF file + [] -> return gfenv + _ -> do putStrLn "Can only import one .pgf file" + return gfenv + where + importPGF file = + do case multigrammar (commandenv gfenv) of + Just _ -> putStrLnFlush "Discarding previous grammar" + _ -> done + pgf1 <- readPGF2 file + let gfenv' = gfenv { commandenv = commandEnv pgf1 } + when (verbAtLeast opts Normal) $ + let langs = Map.keys . concretes $ commandenv gfenv' + in putStrLnFlush . unwords $ "\nLanguages:":langs + return gfenv' + +tryGetLine = do + res <- try getLine + case res of + Left (e :: SomeException) -> return "q" + Right l -> return l + +welcome = unlines [ + " ", + " * * * ", + " * * ", + " * * ", + " * ", + " * ", + " * * * * * * * ", + " * * * ", + " * * * * * * ", + " * * * ", + " * * * ", + " ", + "This is GF version "++showVersion version++". ", + buildInfo, + "License: see help -license. ", +--"Bug reports: http://code.google.com/p/grammatical-framework/issues/list", + "", + "This shell uses the C run-time system. See help for available commands." + ] + +prompt env = abs ++ "> " + where + abs = maybe "" C.abstractName (multigrammar (commandenv env)) + +data GFEnv = GFEnv { +--grammar :: (), -- gfo grammar -retain +--retain :: (), -- grammar was imported with -retain flag + commandenv :: CommandEnv PGFEnv, + history :: [String] + } + +emptyGFEnv :: GFEnv +emptyGFEnv = GFEnv {-() ()-} emptyCommandEnv [] {-0-} + +commandEnv pgf = mkCommandEnv (pgfEnv pgf) allCommands +emptyCommandEnv = mkCommandEnv emptyPGFEnv allCommands +multigrammar = fst . pgfenv +concretes = snd . pgfenv + +wordCompletion gfenv (left,right) = do + case wc_type (reverse left) of + CmplCmd pref + -> ret (length pref) [Haskeline.simpleCompletion name | name <- Map.keys (commands cmdEnv), isPrefixOf pref name] +{- + CmplStr (Just (Command _ opts _)) s0 + -> do mb_state0 <- try (evaluate (H.initState pgf (optLang opts) (optType opts))) + case mb_state0 of + Right state0 -> let (rprefix,rs) = break isSpace (reverse s0) + s = reverse rs + prefix = reverse rprefix + ws = words s + in case loop state0 ws of + Nothing -> ret 0 [] + Just state -> let compls = H.getCompletions state prefix + in ret (length prefix) (map (\x -> Haskeline.simpleCompletion x) (Map.keys compls)) + Left (_ :: SomeException) -> ret 0 [] +-} + CmplOpt (Just (Command n _ _)) pref + -> case Map.lookup n (commands cmdEnv) of + Just inf -> do let flg_compls = [Haskeline.Completion ('-':flg++"=") ('-':flg) False | (flg,_) <- flags inf, isPrefixOf pref flg] + opt_compls = [Haskeline.Completion ('-':opt) ('-':opt) True | (opt,_) <- options inf, isPrefixOf pref opt] + ret (length pref+1) + (flg_compls++opt_compls) + Nothing -> ret (length pref) [] + CmplIdent (Just (Command "i" _ _)) _ -- HACK: file name completion for command i + -> Haskeline.completeFilename (left,right) + + CmplIdent _ pref + -> case mb_pgf of + Just pgf -> ret (length pref) + [Haskeline.simpleCompletion name + | name <- C.functions pgf, + isPrefixOf pref name] + _ -> ret (length pref) [] + + _ -> ret 0 [] + where + mb_pgf = multigrammar cmdEnv + cmdEnv = commandenv gfenv +{- + optLang opts = valStrOpts "lang" (head $ Map.keys (concretes cmdEnv)) opts + optType opts = + let str = valStrOpts "cat" (H.showCId $ H.lookStartCat pgf) opts + in case H.readType str of + Just ty -> ty + Nothing -> error ("Can't parse '"++str++"' as type") + + loop ps [] = Just ps + loop ps (t:ts) = case H.nextState ps (H.simpleParseInput t) of + Left es -> Nothing + Right ps -> loop ps ts +-} + ret len xs = return (drop len left,xs) + + +data CompletionType + = CmplCmd Ident + | CmplStr (Maybe Command) String + | CmplOpt (Maybe Command) Ident + | CmplIdent (Maybe Command) Ident + deriving Show + +wc_type :: String -> CompletionType +wc_type = cmd_name + where + cmd_name cs = + let cs1 = dropWhile isSpace cs + in go cs1 cs1 + where + go x [] = CmplCmd x + go x (c:cs) + | isIdent c = go x cs + | otherwise = cmd x cs + + cmd x [] = ret CmplIdent x "" 0 + cmd _ ('|':cs) = cmd_name cs + cmd _ (';':cs) = cmd_name cs + cmd x ('"':cs) = str x cs cs + cmd x ('-':cs) = option x cs cs + cmd x (c :cs) + | isIdent c = ident x (c:cs) cs + | otherwise = cmd x cs + + option x y [] = ret CmplOpt x y 1 + option x y ('=':cs) = optValue x y cs + option x y (c :cs) + | isIdent c = option x y cs + | otherwise = cmd x cs + + optValue x y ('"':cs) = str x y cs + optValue x y cs = cmd x cs + + ident x y [] = ret CmplIdent x y 0 + ident x y (c:cs) + | isIdent c = ident x y cs + | otherwise = cmd x cs + + str x y [] = ret CmplStr x y 1 + str x y ('\"':cs) = cmd x cs + str x y ('\\':c:cs) = str x y cs + str x y (c:cs) = str x y cs + + ret f x y d = f cmd y + where + x1 = take (length x - length y - d) x + x2 = takeWhile (\c -> isIdent c || isSpace c || c == '-' || c == '=' || c == '"') x1 + + cmd = case [x | (x,cs) <- RP.readP_to_S pCommand x2, all isSpace cs] of + [x] -> Just x + _ -> Nothing + + isIdent c = c == '_' || c == '\'' || isAlphaNum c diff --git a/src/compiler/GF/Main.hs b/src/compiler/GF/Main.hs index 1679c376c..642ddf565 100644 --- a/src/compiler/GF/Main.hs +++ b/src/compiler/GF/Main.hs @@ -1,7 +1,11 @@ -- | GF main program (grammar compiler, interactive shell, http server) +{-# LANGUAGE CPP #-} module GF.Main where import GF.Compiler -import GF.Interactive +import qualified GF.Interactive as GFI1 +#ifdef C_RUNTIME +import qualified GF.Interactive2 as GFI2 +#endif import GF.Data.ErrM import GF.Infra.Option import GF.Infra.UseIO @@ -43,7 +47,17 @@ mainOpts opts files = case flag optMode opts of ModeVersion -> putStrLn $ "Grammatical Framework (GF) version " ++ showVersion version ++ "\n" ++ buildInfo ModeHelp -> putStrLn helpMessage - ModeInteractive -> mainGFI opts files - ModeRun -> mainRunGFI opts files - ModeServer port -> mainServerGFI opts port files + ModeServer port -> GFI1.mainServerGFI opts port files ModeCompiler -> mainGFC opts files + ModeInteractive -> GFI1.mainGFI opts files + ModeRun -> GFI1.mainRunGFI opts files +#ifdef C_RUNTIME + ModeInteractive2 -> GFI2.mainGFI opts files + ModeRun2 -> GFI2.mainRunGFI opts files +#else + ModeInteractive2 -> noCruntime + ModeRun2 -> noCruntime + where + noCruntime = do ePutStrLn "GF configured without C run-time support" + exitFailure +#endif diff --git a/src/runtime/haskell-bind/PGF2.hsc b/src/runtime/haskell-bind/PGF2.hsc index 618976539..555f641a0 100644 --- a/src/runtime/haskell-bind/PGF2.hsc +++ b/src/runtime/haskell-bind/PGF2.hsc @@ -15,7 +15,7 @@ module PGF2 (-- * CId CId, -- * PGF - PGF,readPGF,AbsName,abstractName,startCat, + PGF,readPGF,AbsName,abstractName,Cat,startCat, -- * Concrete syntax ConcName,Concr,languages,parse,parseWithHeuristics, hasLinearization,linearize,linearizeAll,alignWords,