forked from GitHub/gf-core
279 lines
12 KiB
Haskell
279 lines
12 KiB
Haskell
-- | Commands requiring source grammar in env
|
|
module GF.Command.SourceCommands(HasGrammar(..),sourceCommands) where
|
|
|
|
import Prelude hiding (putStrLn)
|
|
import qualified Prelude as P(putStrLn)
|
|
import Data.List(nub,isInfixOf,isPrefixOf)
|
|
import qualified Data.ByteString.UTF8 as UTF8(fromString)
|
|
import qualified Data.Map as Map
|
|
|
|
import GF.Infra.SIO(MonadSIO(..),restricted)
|
|
import GF.Infra.Dependencies(depGraph)
|
|
import GF.Infra.CheckM
|
|
import GF.Text.Pretty(render,pp)
|
|
import GF.Data.Str(sstr)
|
|
import GF.Data.Operations (chunks,err,raise)
|
|
|
|
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(normalForm,Globals(..),stdPredef)
|
|
import GF.Compile.TypeCheck.Concrete as TC(inferLType,ppType)
|
|
|
|
import GF.Command.Abstract(Option(..),isOpt,listFlags,valueString,valStrOpts)
|
|
import GF.Command.CommandInfo
|
|
|
|
class (Monad m,MonadSIO m) => HasGrammar m where
|
|
getGrammar :: m Grammar
|
|
|
|
sourceCommands :: HasGrammar m => Map.Map String (CommandInfo m)
|
|
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 or -resource when importing the grammar,",
|
|
"if you want the definitions to be available 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"),
|
|
("trace","trace computations")
|
|
],
|
|
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.",
|
|
"If no grammar is loaded with 'import -retain' or 'import -resource',",
|
|
"then only the predefined operations are in scope.",
|
|
"The operations include also 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 opts ts =
|
|
do sgr <- getGrammar
|
|
liftSIO (exec opts (toStrings ts) sgr)
|
|
|
|
compute_concrete opts ws sgr = fmap fst $ runCheck $
|
|
case runP pExp (UTF8.fromString s) of
|
|
Left (_,msg) -> return $ pipeMessage msg
|
|
Right t -> do t <- checkComputeTerm opts sgr t
|
|
return (fromString (showTerm sgr style q 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 os xs sgr = 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 os ts sgr = fmap fst $ runCheck $ do
|
|
let greps = map valueString (listFlags "grep" os)
|
|
ops <- case ts of
|
|
_:_ -> do let Right t = runP pExp (UTF8.fromString (unwords ts))
|
|
ty <- checkComputeTerm os sgr t
|
|
return $ allOpersTo sgr ty
|
|
_ -> return $ allOpers sgr
|
|
let sigs = [(op,ty) | ((mo,op),ty,pos) <- ops]
|
|
printer = showTerm sgr TermPrintDefault
|
|
(if isOpt "raw" os then Qualified else Unqualified)
|
|
printed = [unwords [showIdent op, ":", printer ty] | (op,ty) <- sigs]
|
|
return . fromString $ unlines [l | l <- printed, all (`isInfixOf` l) greps]
|
|
|
|
show_source os ts sgr = 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 opts ws sgr =
|
|
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 os sgr t =
|
|
do mo <- case greatestResource sgr of
|
|
Nothing -> checkError (pp "No source grammar in scope")
|
|
Just mo -> return mo
|
|
t <- renameSourceTerm sgr mo t
|
|
(t,_) <- inferLType sgr [] t
|
|
fmap evalStr (normalForm (Gl sgr stdPredef) t)
|
|
where
|
|
-- ** Try to compute pre{...} tokens in token sequences
|
|
evalStr t =
|
|
case t of
|
|
C t1 t2 -> foldr1 C (evalC [t])
|
|
_ -> composSafeOp evalStr t
|
|
|
|
evalC (C t1 t2:ts) = evalC (t1:t2:ts)
|
|
evalC (t1@(Alts t tts):ts) = case evalC ts of
|
|
K s:ts' -> matchPrefix t tts s:K s:ts'
|
|
ts' -> evalStr t1:ts'
|
|
evalC (t:ts) = evalStr t:evalC ts
|
|
evalC [] = []
|
|
|
|
matchPrefix t0 tts0 s = foldr match1 t tts
|
|
where
|
|
alts@(Alts t tts) = evalStr (Alts t0 tts0)
|
|
|
|
match1 (u,a) r = err (const alts) ok (strsFromTerm a)
|
|
where ok as = if any (`isPrefixOf` s) (map sstr as)
|
|
then u
|
|
else r
|