commands ss to show source, and sd to show the dependencies of a constant

2 files changed, 80 insertions, 2 deletions

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)
+