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

GF shell: source commands (cc, sd, so, ss & dg) can now be used in pipes

Browse Source 
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.
This commit is contained in:
hallgren
2015-08-12 11:05:08 +00:00
parent 063912c386
commit 6fff2def39
6 changed files with 299 additions and 262 deletions
Download Patch File Download Diff File Expand all files Collapse all files

1
gf.cabal
View File

@@ -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

18
src/compiler/GF/Command/Abstract.hs
View File

@@ -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]

5
src/compiler/GF/Command/CommandInfo.hs
View File

@@ -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

123
src/compiler/GF/Command/Commands.hs
View File

@@ -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",

253
src/compiler/GF/Command/SourceCommands.hs Normal file
View File

@@ -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

161
src/compiler/GF/Interactive.hs
View File

@@ -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