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

3 files changed, 100 insertions, 3 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)
+
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