diff options
| -rw-r--r-- | gf.cabal | 1 | ||||
| -rw-r--r-- | src/compiler/GF/Command/Abstract.hs | 18 | ||||
| -rw-r--r-- | src/compiler/GF/Command/CommandInfo.hs | 5 | ||||
| -rw-r--r-- | src/compiler/GF/Command/Commands.hs | 123 | ||||
| -rw-r--r-- | src/compiler/GF/Command/SourceCommands.hs | 253 | ||||
| -rw-r--r-- | src/compiler/GF/Interactive.hs | 161 |
6 files changed, 299 insertions, 262 deletions
@@ -165,6 +165,7 @@ Library GF.Command.CommandInfo GF.Command.Commands GF.Command.CommonCommands + GF.Command.SourceCommands GF.Command.Help GF.Command.Importing GF.Command.Interpreter diff --git a/src/compiler/GF/Command/Abstract.hs b/src/compiler/GF/Command/Abstract.hs index 5035a33d3..0a664d1ca 100644 --- a/src/compiler/GF/Command/Abstract.hs +++ b/src/compiler/GF/Command/Abstract.hs @@ -43,14 +43,20 @@ valIntOpts flag def opts = valStrOpts :: String -> String -> [Option] -> String valStrOpts flag def opts = - case [v | OFlag f v <- opts, f == flag] of - (VStr v:_) -> v - (VId v:_) -> v - (VInt v:_) -> show v - _ -> def + case listFlags flag opts of + v:_ -> valueString v + _ -> def + +listFlags flag opts = [v | OFlag f v <- opts, f == flag] + +valueString v = + case v of + VStr v -> v + VId v -> v + VInt v -> show v isOpt :: String -> [Option] -> Bool -isOpt o opts = elem o [x | OOpt x <- opts] +isOpt o opts = elem (OOpt o) opts isFlag :: String -> [Option] -> Bool isFlag o opts = elem o [x | OFlag x _ <- opts] diff --git a/src/compiler/GF/Command/CommandInfo.hs b/src/compiler/GF/Command/CommandInfo.hs index 696d14cbc..f73aa35e1 100644 --- a/src/compiler/GF/Command/CommandInfo.hs +++ b/src/compiler/GF/Command/CommandInfo.hs @@ -17,6 +17,8 @@ data CommandInfo env = CommandInfo { needsTypeCheck :: Bool } +mapCommandEnv f c = c { exec = exec c . f } + emptyCommandInfo :: CommandInfo env emptyCommandInfo = CommandInfo { exec = \_ _ ts -> return $ pipeExprs ts, ---- @@ -33,6 +35,9 @@ emptyCommandInfo = CommandInfo { class TypeCheckArg env where typeCheckArg :: env -> Expr -> Either Doc Expr +instance TypeCheckArg env => TypeCheckArg (x,env) where + typeCheckArg (x,env) = typeCheckArg env + -------------------------------------------------------------------------------- newtype CommandOutput = Piped {fromPipe :: ([Expr],String)} ---- errors, etc diff --git a/src/compiler/GF/Command/Commands.hs b/src/compiler/GF/Command/Commands.hs index f2c835ff1..c69dc64ed 100644 --- a/src/compiler/GF/Command/Commands.hs +++ b/src/compiler/GF/Command/Commands.hs @@ -1,5 +1,5 @@ module GF.Command.Commands ( - PGFEnv,pgf,mos,pgfEnv,allCommands, + PGFEnv,pgf,mos,pgfEnv,pgfCommands, options,flags, ) where import Prelude hiding (putStrLn) @@ -26,7 +26,6 @@ import GF.Command.Abstract --import GF.Command.Messages import GF.Command.CommandInfo import GF.Command.CommonCommands -import GF.Command.Help --import GF.Text.Lexing import GF.Text.Clitics --import GF.Text.Transliterations @@ -56,9 +55,8 @@ pgfEnv pgf = Env pgf mos instance TypeCheckArg PGFEnv where typeCheckArg (Env pgf _) = either (Left . ppTcError) (Right . fst) . inferExpr pgf --- this list must no more be kept sorted by the command name -allCommands :: Map.Map String (CommandInfo PGFEnv) -allCommands = extend commonCommands [ +pgfCommands :: Map.Map String (CommandInfo PGFEnv) +pgfCommands = Map.fromList [ ("aw", emptyCommandInfo { longname = "align_words", synopsis = "show word alignments between languages graphically", @@ -139,54 +137,6 @@ allCommands = extend commonCommands [ ] }), - ("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 - }), - ("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 - }), ("eb", emptyCommandInfo { longname = "example_based", syntax = "eb (-probs=FILE | -lang=LANG)* -file=FILE.gfe", @@ -281,7 +231,6 @@ allCommands = extend commonCommands [ Nothing -> 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", @@ -586,72 +535,6 @@ allCommands = extend commonCommands [ ] }), - ("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 - }), - - ("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 - }), ("vd", emptyCommandInfo { longname = "visualize_dependency", diff --git a/src/compiler/GF/Command/SourceCommands.hs b/src/compiler/GF/Command/SourceCommands.hs new file mode 100644 index 000000000..7c18f5033 --- /dev/null +++ b/src/compiler/GF/Command/SourceCommands.hs @@ -0,0 +1,253 @@ +-- | Commands requiring source grammar in env +module GF.Command.SourceCommands(sourceCommands) where +import Prelude hiding (putStrLn) +import qualified Prelude as P(putStrLn) +import Data.List(nub,isInfixOf) +import qualified Data.ByteString.UTF8 as UTF8(fromString) +import qualified Data.Map as Map + +import GF.Infra.SIO +import GF.Infra.Option(noOptions) +import GF.Data.Operations (chunks,err,raise) +import GF.Text.Pretty(render) + +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 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(runCheck) + +import GF.Command.Abstract(Option(..),isOpt,listFlags,valueString,valStrOpts) +import GF.Command.CommandInfo + +sourceCommands = 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"), + ("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, -- why not True? + exec = withStrings compute_concrete + }), + ("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, + exec = withStrings dependency_graph + }), + ("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, + exec = withStrings show_deps + }), + + ("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)") + ], + examples = [ + mkEx "so Det -- show all opers that create a Det", + mkEx "so -grep=Prep -- find opers relating to Prep", + mkEx "so | wf -file=/tmp/opers -- write the list of opers to a file" + ], + needsTypeCheck = False, + exec = withStrings show_operations + }), + + ("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, + exec = withStrings show_source + }) + ] + where + withStrings exec sgr opts = do exec sgr opts . toStrings + + compute_concrete sgr opts ws = + case runP pExp (UTF8.fromString s) of + Left (_,msg) -> return $ pipeMessage msg + Right t -> return $ err pipeMessage + (fromString . showTerm sgr style q) + $ checkComputeTerm sgr t + where + (style,q) = pOpts TermPrintDefault Qualified opts + s = unwords ws + + pOpts style q [] = (style,q) + pOpts style q (o:os) = + case o of + OOpt "table" -> pOpts TermPrintTable q os + OOpt "all" -> pOpts TermPrintAll q os + OOpt "list" -> pOpts TermPrintList q os + OOpt "one" -> pOpts TermPrintOne q os + OOpt "default" -> pOpts TermPrintDefault q os + OOpt "unqual" -> pOpts style Unqualified os + OOpt "qual" -> pOpts style Qualified os + _ -> pOpts style q os + + show_deps sgr os xs = do + 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 + | isOpt "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 + return $ fromString printed + + show_operations sgr os ts = + case greatestResource sgr of + Nothing -> return $ fromString "no source grammar in scope; did you import with -retain?" + Just mo -> do + let greps = map valueString (listFlags "grep" os) + let isRaw = isOpt "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] + return . fromString $ unlines [l | l <- printed, all (`isInfixOf` l) greps] + + show_source sgr os ts = do + let strip = if isOpt "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 () of + _ | isOpt "detailedsize" os -> + return . fromString $ printSizesGrammar mygr + _ | isOpt "size" os -> do + let sz = sizesGrammar mygr + return . fromStrings $ + ("total\t" ++ show (fst sz)): + [render j ++ "\t" ++ show (fst k) | (j,k) <- snd sz] + _ | isOpt "save" os -> + do mapM_ saveModule (modules mygr) + return void + where + saveModule m@(i,_) = + let file = (render i ++ ".gfh") + in restricted $ + do writeFile file (render (ppModule Qualified m)) + P.putStrLn ("wrote " ++ file) + + _ -> return . fromString $ render mygr + + dependency_graph sgr opts ws = + do let stop = case valStrOpts "only" "" opts of + "" -> Nothing + fs -> Just $ chunks ',' fs + restricted $ + do writeFile "_gfdepgraph.dot" (depGraph stop sgr) + P.putStrLn "wrote graph in file _gfdepgraph.dot" + return void + +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 diff --git a/src/compiler/GF/Interactive.hs b/src/compiler/GF/Interactive.hs index d0311479f..216c5f1e2 100644 --- a/src/compiler/GF/Interactive.hs +++ b/src/compiler/GF/Interactive.hs @@ -5,21 +5,15 @@ import Prelude hiding (putStrLn,print) import qualified Prelude as P(putStrLn) import GF.Command.Interpreter(CommandEnv(..),pgfenv,commands,mkCommandEnv,interpretCommandLine) --import GF.Command.Importing(importSource,importGrammar) -import GF.Command.Commands(flags,options,PGFEnv,pgf,pgfEnv,allCommands) +import GF.Command.Commands(flags,options,PGFEnv,pgf,pgfEnv,pgfCommands) +import GF.Command.CommonCommands(commonCommands,extend) +import GF.Command.SourceCommands(sourceCommands) +import GF.Command.CommandInfo(mapCommandEnv) +import GF.Command.Help(helpCommand) import GF.Command.Abstract import GF.Command.Parse(readCommandLine,pCommand) -import GF.Data.Operations (Err(..),chunks,err,raise,done) +import GF.Data.Operations (Err(..),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 @@ -32,17 +26,14 @@ import PGF import PGF.Internal(abstract,funs,lookStartCat,emptyPGF) import Data.Char -import Data.List(nub,isPrefixOf,isInfixOf,partition) +import Data.List(isPrefixOf) 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 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) @@ -123,18 +114,14 @@ 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 + -- special commands {-"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 + -- cc, sd, so, ss and dg are now in GF.Commands.SourceCommands "eh":ws -> eh ws "i" :ws -> import_ ws -- other special commands, working on GFEnv @@ -152,7 +139,6 @@ execute1 opts gfenv0 s0 = 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 @@ -169,98 +155,6 @@ execute1 opts gfenv0 s0 = 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 @@ -278,9 +172,7 @@ execute1 opts gfenv0 s0 = return gfenv continue gfenv' - empty = continue $ gfenv { - commandenv=emptyCommandEnv, grammar = emptyGrammar - } + empty = continue $ gfenv { commandenv=emptyCommandEnv } define_command (f:ws) = case readCommandLine (unwords ws) of @@ -327,13 +219,6 @@ execute1 opts gfenv0 s0 = 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" @@ -354,11 +239,11 @@ importInEnv gfenv opts files | flag optRetainResource opts = do src <- importSource opts files pgf <- lazySIO importPGF -- duplicates some work, better to link src - return $ gfenv {grammar = src, retain=True, - commandenv = commandEnv pgf } + return $ gfenv {retain=True, commandenv = commandEnv src pgf } | otherwise = do pgf1 <- importPGF - return $ gfenv { commandenv = commandEnv pgf1 } + return $ gfenv { retain=False, + commandenv = commandEnv emptyGrammar pgf1 } where importPGF = do let opts' = addOptions (setOptimization OptCSE False) opts @@ -383,18 +268,22 @@ prompt env abs = abstractName (multigrammar (commandenv env)) data GFEnv = GFEnv { - grammar :: Grammar, -- gfo grammar -retain - retain :: Bool, -- grammar was imported with -retain flag - commandenv :: CommandEnv PGFEnv, - history :: [String] + retain :: Bool, -- grammar was imported with -retain flag + commandenv :: CommandEnv (Grammar,PGFEnv), + history :: [String] } emptyGFEnv :: GFEnv -emptyGFEnv = GFEnv emptyGrammar False emptyCommandEnv [] {-0-} +emptyGFEnv = GFEnv False emptyCommandEnv [] {-0-} + +commandEnv sgr pgf = mkCommandEnv (sgr,pgfEnv pgf) allCommands +emptyCommandEnv = commandEnv emptyGrammar emptyPGF +multigrammar = pgf . snd . pgfenv -commandEnv pgf = mkCommandEnv (pgfEnv pgf) allCommands -emptyCommandEnv = commandEnv emptyPGF -multigrammar = pgf . pgfenv +allCommands = + extend (fmap (mapCommandEnv snd) pgfCommands) [helpCommand allCommands] + `Map.union` (fmap (mapCommandEnv fst) sourceCommands) + `Map.union` commonCommands wordCompletion gfenv (left,right) = do case wc_type (reverse left) of |