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.Option(modifyFlags,optTrace) --,noOptions
import GF.Data.Operations (chunks,err,raise)
import GF.Text.Pretty(render)
import GF.Data.Str(sstr)
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,resourceValues)
import GF.Compile.TypeCheck.Concrete 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
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 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"),
("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.",
"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 opts ts =
do sgr <- getGrammar
liftSIO (exec opts (toStrings ts) sgr)
compute_concrete opts ws sgr =
case runP pExp (UTF8.fromString s) of
Left (_,msg) -> return $ pipeMessage msg
Right t -> return $ err pipeMessage
(fromString . showTerm sgr style q)
$ checkComputeTerm opts 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 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 =
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 os 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 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 <- maybe (raise "no source grammar in scope") return $
greatestResource sgr
((t,_),_) <- runCheck $ do t <- renameSourceTerm sgr mo t
inferLType sgr [] t
let opts = modifyFlags (\fs->fs{optTrace=isOpt "trace" os})
t1 = normalForm (resourceValues opts sgr) (L NoLoc identW) t
t2 = evalStr t1
checkPredefError t2
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