diff --git a/src/compiler/GF/Command/Commands.hs b/src/compiler/GF/Command/Commands.hs index 8d7297f1e..a743ee1f0 100644 --- a/src/compiler/GF/Command/Commands.hs +++ b/src/compiler/GF/Command/Commands.hs @@ -778,6 +778,26 @@ allCommands env@(pgf, mos) = Map.fromList [ ("tq -from=Eng -to=Swe (AdjCN (PositA ?2) (UseN ?)) -- only trees of this form") ] }), + + ("sd", emptyCommandInfo { + longname = "show_dependencies", + syntax = "sd QUALIFIED_CONSTANT", + synopsis = "show all constants that the given constant depends 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 = [ + ], + examples = [ + "sd ParadigmsEng.mkV -- show all constants on which this one depends" + ], + needsTypeCheck = False + }), + ("se", emptyCommandInfo { longname = "set_encoding", synopsis = "set the encoding used in current terminal", @@ -831,6 +851,27 @@ allCommands env@(pgf, mos) = Map.fromList [ 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.", + "This command must be a line of its own, and thus cannot be a part of a pipe." + ], + options = [ + ("save", "save each MODULE in file MODULE.gfh instead of printing it on terminal"), + ("strip","show only type signatures of oper's and lin's, not their definitions") + ], + examples = [ + "ss -- print complete current source grammar on terminal", + "ss -strip -save MorphoFin -- print the headers in file MorphoFin.gfh" + ], + needsTypeCheck = False + }), + ("ut", emptyCommandInfo { longname = "unicode_table", synopsis = "show a transliteration table for a unicode character set", diff --git a/src/compiler/GF/Grammar/Analyse.hs b/src/compiler/GF/Grammar/Analyse.hs index ad538de87..9946c7812 100644 --- a/src/compiler/GF/Grammar/Analyse.hs +++ b/src/compiler/GF/Grammar/Analyse.hs @@ -1,16 +1,20 @@ module GF.Grammar.Analyse ( - stripSourceGrammar + stripSourceGrammar, + constantDepsTerm ) where import GF.Grammar.Grammar import GF.Infra.Ident import GF.Infra.Option --- import GF.Infra.Modules +import GF.Grammar.Macros +import GF.Grammar.Lookup import GF.Data.Operations import qualified Data.Map as Map - +import Data.List (nub) +import Debug.Trace stripSourceGrammar :: SourceGrammar -> SourceGrammar stripSourceGrammar sgr = mGrammar [(i, m{jments = Map.map stripInfo (jments m)}) | (i,m) <- modules sgr] @@ -27,3 +31,36 @@ stripInfo i = case i of CncFun mict mte mtf -> CncFun mict Nothing Nothing AnyInd b f -> i +constantsInTerm :: Term -> [Term] +constantsInTerm = nub . consts where + consts t = case t of + Q _ -> [t] + QC _ -> [t] + _ -> collectOp consts t + +constantDeps :: SourceGrammar -> QIdent -> Err [Term] +constantDeps sgr f = do + ts <- deps f + let cs = [i | t <- ts, i <- getId t] + ds <- mapM deps cs + return $ nub $ concat $ ts:ds + where + deps c = case lookupOverload sgr c of + Ok tts -> + return $ concat [constantsInTerm ty ++ constantsInTerm tr | (_,(ty,tr)) <- tts] + _ -> do + ty <- lookupResType sgr c + tr <- lookupResDef sgr c + return $ constantsInTerm ty ++ constantsInTerm tr + getId t = case t of + Q i -> [i] + QC i -> [i] + _ -> [] + +constantDepsTerm :: SourceGrammar -> Term -> Err [Term] +constantDepsTerm sgr t = case t of + Q i -> constantDeps sgr i + QC i -> constantDeps sgr i + P (Vr r) l -> constantDeps sgr $ (r,label2ident l) --- + _ -> Bad ("expected qualified constant, not " ++ show t) + diff --git a/src/compiler/GFI.hs b/src/compiler/GFI.hs index 4e6e05715..b0e36462e 100644 --- a/src/compiler/GFI.hs +++ b/src/compiler/GFI.hs @@ -9,6 +9,7 @@ import GF.Command.Parse import GF.Data.ErrM import GF.Data.Operations (chunks,err) import GF.Grammar hiding (Ident) +import GF.Grammar.Analyse import GF.Grammar.Parser (runP, pExp) import GF.Grammar.Printer (ppGrammar, ppModule) import GF.Grammar.ShowTerm @@ -127,6 +128,7 @@ execute1 opts gfenv0 s0 = "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 @@ -184,6 +186,17 @@ execute1 opts gfenv0 s0 = Bad s -> putStrLn $ s continue gfenv + show_deps ws = do + let (os,ts) = partition (isPrefixOf "-") ws + ops <- case ts of + _:_ -> do + let Right t = runP pExp (encodeUnicode utf8 (unwords ts)) + err error return $ constantDepsTerm sgr t + _ -> error "give a term as argument" + let printer = showTerm sgr TermPrintDefault Qualified + putStrLn $ unwords $ map printer ops + continue gfenv + show_operations ws = case greatestResource sgr of Nothing -> putStrLn "no source grammar in scope; did you import with -retain?" >> continue gfenv @@ -204,13 +217,19 @@ execute1 opts gfenv0 s0 = 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 (showIdent i) ts] [] -> sgr - putStrLn $ render $ ppGrammar mygr + if elem "-save" os + then mapM_ + (\ m@(i,_) -> let file = (showIdent i ++ ".gfh") in + writeFile file (render (ppModule Qualified m)) >> putStrLn ("wrote " ++ file)) + (modules mygr) + else putStrLn $ render $ ppGrammar mygr continue gfenv dependency_graph ws = do let stop = case ws of