command ss to show source (including gfo) in text; to be extended

3 files changed, 35 insertions, 3 deletions

diff --git a/src/compiler/GF/Grammar/Grammar.hs b/src/compiler/GF/Grammar/Grammar.hs
index 0234bdcb8..2c84351af 100644
--- a/src/compiler/GF/Grammar/Grammar.hs
+++ b/src/compiler/GF/Grammar/Grammar.hs
@@ -16,6 +16,7 @@
 
 module GF.Grammar.Grammar (SourceGrammar,
         emptySourceGrammar,mGrammar,
+        stripSourceGrammar,
         SourceModInfo,
         SourceModule,
         mapSourceModule,
@@ -239,3 +240,20 @@ ident2label c = LIdent (ident2bs c)
 label2ident :: Label -> Ident
 label2ident (LIdent s) = identC s
 label2ident (LVar i)   = identC (BS.pack ('$':show i))
+
+
+stripSourceGrammar :: SourceGrammar -> SourceGrammar
+stripSourceGrammar sgr = sgr --mGrammar [(i, m{jments = Map.map }) | (i,m) <- modules sgr]
+
+stripInfo :: Info -> Info
+stripInfo i = case i of
+  AbsCat _ -> i
+  AbsFun mt mi me mb -> AbsFun mt mi Nothing mb
+  ResParam mp mt -> ResParam mp Nothing
+  ResValue lt -> i ----
+  ResOper mt md -> ResOper mt Nothing
+  ResOverload is fs -> ResOverload is [(lty, L loc (EInt 0)) | (lty,L loc _) <- fs]
+  CncCat mty mte mtf -> CncCat mty Nothing Nothing
+  CncFun mict mte mtf -> CncFun mict Nothing Nothing
+  AnyInd b f -> i
+
diff --git a/src/compiler/GF/Grammar/Printer.hs b/src/compiler/GF/Grammar/Printer.hs
index 3319f86e8..fc9d31802 100644
--- a/src/compiler/GF/Grammar/Printer.hs
+++ b/src/compiler/GF/Grammar/Printer.hs
@@ -10,6 +10,7 @@
 module GF.Grammar.Printer

            ( TermPrintQual(..)

            , ppLabel

+           , ppGrammar

            , ppModule

            , ppJudgement

            , ppTerm

@@ -33,6 +34,9 @@ import qualified Data.Map as Map
 

 data TermPrintQual = Qualified | Unqualified

 

+ppGrammar :: SourceGrammar -> Doc

+ppGrammar sgr = vcat $ map (ppModule Qualified) $ modules sgr

+

 ppModule :: TermPrintQual -> SourceModule -> Doc

 ppModule q (mn, ModInfo mtype mstat opts exts with opens _ jments) =

     hdr $$ nest 2 (ppOptions opts $$ vcat (map (ppJudgement q) defs)) $$ ftr

diff --git a/src/compiler/GFI.hs b/src/compiler/GFI.hs
index 74edf95d7..4e6e05715 100644
--- a/src/compiler/GFI.hs
+++ b/src/compiler/GFI.hs
@@ -10,6 +10,7 @@ import GF.Data.ErrM
 import GF.Data.Operations (chunks,err)
 import GF.Grammar hiding (Ident)
 import GF.Grammar.Parser (runP, pExp)
+import GF.Grammar.Printer (ppGrammar, ppModule)
 import GF.Grammar.ShowTerm
 import GF.Grammar.Lookup (allOpers,allOpersTo)
 import GF.Compile.Rename
@@ -19,7 +20,8 @@ import GF.Infra.Dependencies
 import GF.Infra.CheckM
 import GF.Infra.UseIO
 import GF.Infra.Option
-import GF.Infra.Modules (greatestResource, modules, emptyModInfo)
+import GF.Infra.Modules (greatestResource, modules, emptyModInfo, mGrammar)
+import GF.Infra.Ident (showIdent)
 import GF.Infra.BuildInfo (buildInfo)
 import qualified System.Console.Haskeline as Haskeline
 import GF.Text.Coding
@@ -126,6 +128,7 @@ execute1 opts gfenv0 s0 =
     "!" :ws  -> system_command ws
     "cc":ws  -> compute_concrete ws
     "so":ws  -> show_operations ws
+    "ss":ws  -> show_source ws
     "dg":ws  -> dependency_graph ws
     "eh":ws  -> eh ws
     "i" :ws  -> import_ ws
@@ -183,7 +186,7 @@ execute1 opts gfenv0 s0 =
 
     show_operations ws =
       case greatestResource sgr of
-        Nothing -> putStrLn "no source grammar in scope" >> continue gfenv
+        Nothing -> putStrLn "no source grammar in scope; did you import with -retain?" >> continue gfenv
         Just mo -> do
           let (os,ts) = partition (isPrefixOf "-") ws
           let greps = [drop 6 o | o <- os, take 6 o == "-grep="]
@@ -201,7 +204,14 @@ 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
+      continue gfenv
     dependency_graph ws =
       do let stop = case ws of
                ('-':'o':'n':'l':'y':'=':fs):_ -> Just $ chunks ',' fs