From 6fff2def393663522f86e13e2536a9e111e8b2cd Mon Sep 17 00:00:00 2001 From: hallgren Date: Wed, 12 Aug 2015 11:05:08 +0000 Subject: [PATCH] GF shell: source commands (cc, sd, so, ss & dg) can now be used in pipes These commands are now implemented as regular commands (i.e. using the CommandInfo data type) in the new module GF.Command.SourceCommands. The list of commands exported from GF.Command.Commmands now called pgfCommands instead of allCommands. The list allCommands of all commands is now assembled from sourceCommands, pgfCommands, commonCommands and helpCommand in GF.Interactive. --- gf.cabal | 1 + src/compiler/GF/Command/Abstract.hs | 18 +- src/compiler/GF/Command/CommandInfo.hs | 5 + src/compiler/GF/Command/Commands.hs | 123 +---------- src/compiler/GF/Command/SourceCommands.hs | 253 ++++++++++++++++++++++ src/compiler/GF/Interactive.hs | 161 +++----------- 6 files changed, 299 insertions(+), 262 deletions(-) create mode 100644 src/compiler/GF/Command/SourceCommands.hs diff --git a/gf.cabal b/gf.cabal index 219b3b7cf..ac0a3a617 100644 --- a/gf.cabal +++ b/gf.cabal @@ -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 pgf = mkCommandEnv (pgfEnv pgf) allCommands -emptyCommandEnv = commandEnv emptyPGF -multigrammar = pgf . pgfenv +commandEnv sgr pgf = mkCommandEnv (sgr,pgfEnv pgf) allCommands +emptyCommandEnv = commandEnv emptyGrammar emptyPGF +multigrammar = pgf . snd . 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