forked from GitHub/gf-core
reintroduce the compiler API
This commit is contained in:
Krasimir Angelov
282
src/compiler/api/GF/Command/SourceCommands.hs
Normal file
282
src/compiler/api/GF/Command/SourceCommands.hs
Normal file
@@ -0,0 +1,282 @@
|
||||
-- | 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)
|
||||
import GF.Compile.TypeCheck.Concrete as TC(inferLType,ppType)
|
||||
import GF.Compile.TypeCheck.Primitives(predefMod)
|
||||
|
||||
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 sgr0 = fmap fst $ runCheck $ do
|
||||
let (sgr,mo) = case greatestResource sgr0 of
|
||||
Nothing -> (mGrammar [predefMod], fst predefMod)
|
||||
Just mo -> (sgr0,mo)
|
||||
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 sgr0 t =
|
||||
do let (sgr,mo) = case greatestResource sgr0 of
|
||||
Nothing -> (mGrammar [predefMod], fst predefMod)
|
||||
Just mo -> (sgr0,mo)
|
||||
t <- renameSourceTerm sgr mo t
|
||||
(t,_) <- inferLType sgr [] t
|
||||
fmap evalStr (normalForm sgr 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
|
||||
Reference in New Issue
Block a user