GF Shell: refactoring for improved modularity and reusability:

+ Generalize the CommandInfo type by parameterizing it on the monad
  instead of just the environment.
+ Generalize the commands defined in
  GF.Command.{Commands,Commands2,CommonCommands,SourceCommands,HelpCommand}
  to work in any monad that supports the needed operations.
+ Liberate GF.Command.Interpreter from the IO monad.
  Also, move the current PGF from CommandEnv to GFEnv in
  GF.Interactive, making the command interpreter even more generic.
+ Use a state monad to maintain the state of the interpreter in
  GF.{Interactive,Interactive2}.

src/compiler/GF/Command/CommandInfo.hs

@@ -1,12 +1,10 @@
 module GF.Command.CommandInfo where
 import GF.Command.Abstract(Option,Expr)
-import GF.Infra.SIO(SIO)
 import qualified PGF as H(showExpr)
 import qualified PGF.Internal as H(Literal(LStr),Expr(ELit)) ----
-import GF.Text.Pretty(Doc)
 
-data CommandInfo env = CommandInfo {
-  exec     :: env -> [Option] -> [Expr] -> SIO CommandOutput,
+data CommandInfo m = CommandInfo {
+  exec     :: [Option] -> [Expr] -> m CommandOutput,
   synopsis :: String,
   syntax   :: String,
   explanation :: String,
@@ -17,11 +15,11 @@ data CommandInfo env = CommandInfo {
   needsTypeCheck :: Bool
   }
 
-mapCommandEnv f c = c { exec = exec c . f }
+mapCommandExec f c = c { exec = \ opts ts -> f (exec c opts ts) }
 
-emptyCommandInfo :: CommandInfo env
+--emptyCommandInfo :: CommandInfo env
 emptyCommandInfo = CommandInfo {
-  exec = \_ _ ts -> return $ pipeExprs ts, ----
+  exec = error "command not implemented",
   synopsis = "",
   syntax = "",
   explanation = "",
@@ -33,10 +31,7 @@ emptyCommandInfo = CommandInfo {
   }
 --------------------------------------------------------------------------------
 
-class TypeCheckArg env where typeCheckArg :: env -> Expr -> Either Doc Expr
-
-instance TypeCheckArg env => TypeCheckArg (x,env) where
-  typeCheckArg (x,env) = typeCheckArg env
+class Monad m => TypeCheckArg m where typeCheckArg :: Expr -> m Expr
 
 --------------------------------------------------------------------------------
 

src/compiler/GF/Command/Commands.hs

@@ -1,5 +1,6 @@
+{-# LANGUAGE FlexibleInstances, UndecidableInstances #-}
 module GF.Command.Commands (
-  PGFEnv,pgf,mos,pgfEnv,pgfCommands,
+  PGFEnv,HasPGFEnv(..),pgf,mos,pgfEnv,pgfCommands,
   options,flags,
   ) where
 import Prelude hiding (putStrLn)
@@ -8,11 +9,7 @@ import PGF
 
 import PGF.Internal(lookStartCat,functionsToCat,lookValCat,restrictPGF,hasLin)
 import PGF.Internal(abstract,funs,cats,Expr(EFun)) ----
---import PGF.Morphology(isInMorpho,morphoKnown)
 import PGF.Internal(ppFun,ppCat)
---import PGF.Probabilistic(rankTreesByProbs,probTree,setProbabilities)
---import PGF.Generate (generateRandomFrom) ----
---import PGF.Tree (Tree(Fun), expr2tree, tree2expr)
 import PGF.Internal(optimizePGF)
 
 import GF.Compile.Export
@@ -21,14 +18,10 @@ import GF.Compile.ExampleBased
 import GF.Infra.Option (noOptions, readOutputFormat, outputFormatsExpl)
 import GF.Infra.UseIO(writeUTF8File)
 import GF.Infra.SIO
---import GF.Data.ErrM ----
 import GF.Command.Abstract
---import GF.Command.Messages
 import GF.Command.CommandInfo
 import GF.Command.CommonCommands
---import GF.Text.Lexing
 import GF.Text.Clitics
---import GF.Text.Transliterations
 import GF.Quiz
 
 import GF.Command.TreeOperations ---- temporary place for typecheck and compute
@@ -39,12 +32,9 @@ import PGF.Internal (encodeFile)
 import Data.List(intersperse,nub)
 import Data.Maybe
 import qualified Data.Map as Map
---import System.Cmd(system) -- use GF.Infra.UseIO.restricedSystem instead!
---import GF.System.Process
 import GF.Text.Pretty
 import Data.List (sort)
 --import Debug.Trace
---import System.Random (newStdGen) ----
 
 
 data PGFEnv = Env {pgf::PGF,mos::Map.Map Language Morpho}
@@ -52,10 +42,13 @@ data PGFEnv = Env {pgf::PGF,mos::Map.Map Language Morpho}
 pgfEnv pgf = Env pgf mos
   where mos = Map.fromList [(la,buildMorpho pgf la) | la <- languages pgf]
 
-instance TypeCheckArg PGFEnv where
-  typeCheckArg (Env pgf _) = either (Left . ppTcError) (Right . fst) . inferExpr pgf
+class (Functor m,Monad m,MonadSIO m) => HasPGFEnv m where getPGFEnv :: m PGFEnv
 
-pgfCommands :: Map.Map String (CommandInfo PGFEnv)
+instance HasPGFEnv m => TypeCheckArg m where
+  typeCheckArg e = (either (fail . render . ppTcError) (return . fst)
+                    . flip inferExpr e . pgf) =<< getPGFEnv
+
+pgfCommands :: HasPGFEnv m => Map.Map String (CommandInfo m)
 pgfCommands = Map.fromList [
   ("aw", emptyCommandInfo {
      longname = "align_words",
@@ -68,7 +61,7 @@ pgfCommands = Map.fromList [
        "by the flag. The target format is postscript, unless overridden by the",
        "flag -format."
        ],
-     exec = \ (Env pgf mos) opts es -> do
+     exec = getEnv $ \ opts es (Env pgf mos) -> do
          let langs = optLangs pgf opts
          if isOpt "giza" opts
            then do
@@ -115,16 +108,16 @@ pgfCommands = Map.fromList [
        "by the flag '-clitics'. The list of stems is given as the list of words",
        "of the language given by the '-lang' flag."
        ],
-     exec  = \env opts -> case opts of
+     exec  = getEnv $ \opts ts env -> case opts of
                _ | isOpt "raw" opts ->
                     return . fromString .
                     unlines . map (unwords . map (concat . intersperse "+")) .
                     map (getClitics (isInMorpho (optMorpho env opts)) (optClitics opts)) .
-                    concatMap words . toStrings
+                    concatMap words $ toStrings ts
                _ ->
                     return . fromStrings .
                     getCliticsText (isInMorpho (optMorpho env opts)) (optClitics opts) .
-                    concatMap words . toStrings,
+                    concatMap words $ toStrings ts,
      flags = [
        ("clitics","the list of possible clitics (comma-separated, no spaces)"),
        ("lang",   "the language of analysis")
@@ -159,7 +152,7 @@ pgfCommands = Map.fromList [
        ("lang","the language in which to parse"),
        ("probs","file with probabilities to rank the parses")
        ],
-     exec = \ env@(Env pgf mos) opts _ -> do
+     exec = getEnv $ \ opts _ env@(Env pgf mos) -> do
        let file = optFile opts
        pgf <- optProbs opts pgf
        let printer = if (isOpt "api" opts) then exprToAPI else (showExpr [])
@@ -193,7 +186,7 @@ pgfCommands = Map.fromList [
        ("depth","the maximum generation depth"),
        ("probs", "file with biased probabilities (format 'f 0.4' one by line)")
        ],
-     exec = \ (Env pgf mos) opts xs -> do
+     exec = getEnv $ \ opts xs (Env pgf mos) -> do
        pgf <- optProbs opts (optRestricted opts pgf)
        gen <- newStdGen
        let dp = valIntOpts "depth" 4 opts
@@ -223,7 +216,7 @@ pgfCommands = Map.fromList [
        mkEx "gt -cat=NP -depth=2    -- trees in the category NP to depth 2",
        mkEx "gt (AdjCN ? (UseN ?))  -- trees of form (AdjCN ? (UseN ?))"
        ],
-     exec = \ (Env pgf mos) opts xs -> do
+     exec = getEnv $ \ opts xs (Env pgf mos) -> do
        let pgfr = optRestricted opts pgf
        let dp = valIntOpts "depth" 4 opts
        let ts = case mexp xs of
@@ -277,7 +270,7 @@ pgfCommands = Map.fromList [
        mkEx "gr -lang=LangHin -cat=Cl | l -table -to_devanagari -- hindi table",
        mkEx "l -unlexer=\"LangAra=to_arabic LangHin=to_devanagari\" -- different unlexers"
        ],
-     exec = \ (Env pgf mos) opts -> return . fromStrings . optLins pgf opts,
+     exec = getEnv $ \ opts ts (Env pgf mos) -> return . fromStrings $ optLins pgf opts ts,
      options = [
        ("all",    "show all forms and variants, one by line (cf. l -list)"),
        ("bracket","show tree structure with brackets and paths to nodes"),
@@ -302,7 +295,7 @@ pgfCommands = Map.fromList [
      examples = [
        mkEx "l -lang=LangSwe,LangNor -chunks ? a b (? c d)"
        ],
-     exec = \ (Env pgf mos) opts -> return . fromStrings . optLins pgf (opts ++ [OOpt "chunks"]),
+     exec = getEnv $ \ opts ts (Env pgf mos) -> return . fromStrings $ optLins pgf (opts ++ [OOpt "chunks"]) ts,
      options = [
        ("treebank","show the tree and tag linearizations with language names")
        ] ++ stringOpOptions,
@@ -318,18 +311,18 @@ pgfCommands = Map.fromList [
        "Prints all the analyses of space-separated words in the input string,",
        "using the morphological analyser of the actual grammar (see command pg)"
        ],
-     exec  = \env opts -> case opts of
+     exec  = getEnv $ \opts ts env -> case opts of
                _ | isOpt "missing" opts ->
                     return . fromString . unwords .
                     morphoMissing (optMorpho env opts) .
-                    concatMap words . toStrings
+                    concatMap words $ toStrings ts
                _ | isOpt "known" opts ->
                     return . fromString . unwords .
                     morphoKnown (optMorpho env opts) .
-                    concatMap words . toStrings
+                    concatMap words $ toStrings ts
                _ -> return . fromString . unlines .
                     map prMorphoAnalysis . concatMap (morphos env opts) .
-                    concatMap words . toStrings ,
+                    concatMap words $ toStrings ts,
      flags = [
        ("lang","the languages of analysis (comma-separated, no spaces)")
        ],
@@ -343,7 +336,7 @@ pgfCommands = Map.fromList [
      longname = "morpho_quiz",
      synopsis = "start a morphology quiz",
      syntax   = "mq (-cat=CAT)? (-probs=FILE)? TREE?",
-     exec = \ (Env pgf mos) opts xs -> do
+     exec = getEnv $ \ opts xs (Env pgf mos) -> do
          let lang = optLang pgf opts
          let typ  = optType pgf opts
          pgf <- optProbs opts pgf
@@ -371,7 +364,7 @@ pgfCommands = Map.fromList [
        "the parser. For example if -openclass=\"A,N,V\" is given, the parser",
        "will accept unknown adjectives, nouns and verbs with the resource grammar."
        ],
-     exec = \ (Env pgf mos) opts ts ->
+     exec = getEnv $ \ opts ts (Env pgf mos) ->
               return . Piped $ fromParse opts (concat [map ((,) s) (par pgf opts s) | s <- toStrings ts]),
      flags = [
        ("cat","target category of parsing"),
@@ -402,7 +395,7 @@ pgfCommands = Map.fromList [
         " " ++ opt ++ "\t\t" ++ expl |
            ((opt,_),expl) <- outputFormatsExpl, take 1 expl /= "*"
        ]),
-     exec  = \env opts _ -> prGrammar env opts,
+     exec  = getEnv $ \opts _ env -> prGrammar env opts,
      flags = [
        --"cat",
        ("file",   "set the file name when printing with -pgf option"),
@@ -438,8 +431,8 @@ pgfCommands = Map.fromList [
        mkEx "pt -compute (plus one two)                               -- compute value",
        mkEx "p \"4 dogs love 5 cats\" | pt -transfer=digits2numeral | l -- four...five..."
        ],
-     exec = \ (Env pgf mos) opts ->
-            returnFromExprs . takeOptNum opts . treeOps pgf opts,
+     exec = getEnv $ \ opts ts (Env pgf mos) ->
+            returnFromExprs . takeOptNum opts $ treeOps pgf opts ts,
      options = treeOpOptions undefined{-pgf-},
      flags = [("number","take at most this many trees")] ++ treeOpFlags undefined{-pgf-}
      }),
@@ -457,7 +450,7 @@ pgfCommands = Map.fromList [
        ("lines","return the list of lines, instead of the singleton of all contents"),
        ("tree","convert strings into trees")
        ],
-     exec = \ (Env pgf mos) opts _ -> do
+     exec = getEnv $ \ opts _ (Env pgf mos) -> do
        let file = valStrOpts "file" "_gftmp" opts
        let exprs []         = ([],empty)
            exprs ((n,s):ls) | null s
@@ -492,7 +485,7 @@ pgfCommands = Map.fromList [
        "by the file given by flag -probs=FILE, where each line has the form",
        "'function probability', e.g. 'youPol_Pron  0.01'."
        ],
-     exec = \ (Env pgf mos) opts ts -> do
+     exec = getEnv $ \ opts ts (Env pgf mos) -> do
          pgf <- optProbs opts pgf
          let tds = rankTreesByProbs pgf ts
          if isOpt "v" opts
@@ -514,7 +507,7 @@ pgfCommands = Map.fromList [
      longname = "translation_quiz",
      syntax   = "tq -from=LANG -to=LANG (-cat=CAT)? (-probs=FILE)? TREE?",
      synopsis = "start a translation quiz",
-     exec = \ (Env pgf mos) opts xs -> do
+     exec = getEnv $ \ opts xs (Env pgf mos) -> do
          let from = optLangFlag "from" pgf opts
          let to   = optLangFlag "to" pgf opts
          let typ  = optType pgf opts
@@ -551,7 +544,7 @@ pgfCommands = Map.fromList [
        "by the flag. The target format is png, unless overridden by the",
        "flag -format."
        ],
-     exec = \ (Env pgf mos) opts es -> do
+     exec = getEnv $ \ opts es (Env pgf mos) -> do
          let debug = isOpt "v" opts
          let file = valStrOpts "file" "" opts
          let outp = valStrOpts "output" "dot" opts
@@ -599,7 +592,7 @@ pgfCommands = Map.fromList [
        "by the flag. The target format is png, unless overridden by the",
        "flag -format."
        ],
-     exec = \ (Env pgf mos) opts es -> do
+     exec = getEnv $ \ opts es (Env pgf mos) -> do
          let lang = optLang pgf opts
          let gvOptions = GraphvizOptions {noLeaves = isOpt "noleaves" opts && not (isOpt "showleaves" opts),
                                           noFun = isOpt "nofun" opts || not (isOpt "showfun" opts),
@@ -660,7 +653,7 @@ pgfCommands = Map.fromList [
        "flag -format.",
        "With option -mk, use for showing library style function names of form 'mkC'."
        ],
-     exec = \ (Env pgf mos) opts es ->
+     exec = getEnv $ \ opts es (Env pgf mos) ->
        if isOpt "mk" opts
        then return $ fromString $ unlines $ map (tree2mk pgf) es
        else if isOpt "api" opts
@@ -708,7 +701,7 @@ pgfCommands = Map.fromList [
        "If a whole expression is given it prints the expression with refined",
        "metavariables and the type of the expression."
        ],
-     exec = \ (Env pgf mos) opts arg -> do
+     exec = getEnv $ \ opts arg (Env pgf mos) -> do
        case arg of
          [EFun id] -> case Map.lookup id (funs (abstract pgf)) of
                         Just fd -> do putStrLn $ render (ppFun id fd)
@@ -740,6 +733,8 @@ pgfCommands = Map.fromList [
      })
   ]
  where
+   getEnv exec opts ts = liftSIO . exec opts ts =<< getPGFEnv
+
    par pgf opts s = case optOpenTypes opts of
                   []        -> [parse_ pgf lang (optType pgf opts) (Just dp) s | lang <- optLangs pgf opts]
                   open_typs -> [parseWithRecovery pgf lang (optType pgf opts) open_typs (Just dp) s | lang <- optLangs pgf opts]

src/compiler/GF/Command/Commands2.hs

@@ -1,5 +1,6 @@
+{-# LANGUAGE FlexibleInstances, UndecidableInstances #-}
 module GF.Command.Commands2 (
-  PGFEnv,pgf,concs,pgfEnv,emptyPGFEnv,allCommands,
+  PGFEnv,HasPGFEnv(..),pgf,concs,pgfEnv,emptyPGFEnv,pgfCommands,
   options, flags,
   ) where
 import Prelude hiding (putStrLn)
@@ -19,13 +20,11 @@ import qualified PGF as H
 --import GF.Compile.ExampleBased
 --import GF.Infra.Option (noOptions, readOutputFormat, outputFormatsExpl)
 --import GF.Infra.UseIO(writeUTF8File)
---import GF.Infra.SIO
+import GF.Infra.SIO(MonadSIO,liftSIO)
 --import GF.Data.ErrM ----
 import GF.Command.Abstract
 --import GF.Command.Messages
 import GF.Command.CommandInfo
-import GF.Command.Help
-import GF.Command.CommonCommands
 --import GF.Text.Lexing
 --import GF.Text.Clitics
 --import GF.Text.Transliterations
@@ -53,12 +52,13 @@ data PGFEnv = Env {pgf::Maybe C.PGF,concs::Map.Map C.ConcName C.Concr}
 pgfEnv pgf = Env (Just pgf) (C.languages pgf)
 emptyPGFEnv = Env Nothing Map.empty
 
-instance TypeCheckArg PGFEnv where
-  typeCheckArg env e = Right e -- no type checker available !!
+class (Monad m,MonadSIO m) => HasPGFEnv m where getPGFEnv :: m PGFEnv
 
+instance Monad m => TypeCheckArg m where
+  typeCheckArg = return -- no type checker available !!
 
-allCommands :: Map.Map String (CommandInfo PGFEnv)
-allCommands = extend commonCommands [
+pgfCommands :: HasPGFEnv m => Map.Map String (CommandInfo m)
+pgfCommands = Map.fromList [
 {-
   ("aw", emptyCommandInfo {
      longname = "align_words",
@@ -140,57 +140,6 @@ allCommands = extend commonCommands [
        mkEx "ca -lang=Fin -clitics=ko,ni \"nukkuuko minun vaimoni\" | p  -- to parse Finnish"
        ]
      }),
-
-  ("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 when importing the grammar, if you want",
-       "the definitions to be retained 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")
-       ],
-     needsTypeCheck = False
-     }),
--}
-{-
-  ("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
-     }),
 -}
 {-
   ("eb", emptyCommandInfo {
@@ -269,7 +218,7 @@ allCommands = extend commonCommands [
      examples = [
        mkEx "ga                     -- all trees in the startcat",
        mkEx "ga -cat=NP -number=16  -- 16 trees in the category NP"],
-     exec = needPGF $ \ env@(pgf,_) opts _ ->
+     exec = needPGF $ \ opts _ env@(pgf,_) ->
             let ts = map fst (C.generateAll pgf cat)
                 cat = optCat pgf opts
             in returnFromCExprs (takeOptNum opts ts),
@@ -306,7 +255,6 @@ allCommands = extend commonCommands [
        returnFromExprs $ take (optNumInf opts) ts
      }),
 -}
-  helpCommand allCommands,
   ("i", emptyCommandInfo {
      longname = "import",
      synopsis = "import a grammar from a compiled .pgf file",
@@ -346,8 +294,8 @@ allCommands = extend commonCommands [
        ],
      examples = [
        mkEx "l -lang=LangSwe,LangNor no_Utt   -- linearize tree to LangSwe and LangNor"],
-     exec = needPGF $ \ env opts ->
-                      return . fromStrings . cLins env opts . map cExpr
+     exec = needPGF $ \ opts ts env ->
+                      return . fromStrings . cLins env opts $ map cExpr ts
      }),
 {-
   ("l", emptyCommandInfo {
@@ -470,7 +418,7 @@ allCommands = extend commonCommands [
      examples = [
          mkEx "p  \"this fish is fresh\" | l -lang=Swe  -- try parsing with all languages and translate the successful parses to Swedish"
        ],
-     exec = needPGF $ \ env opts -> return . cParse env opts . toStrings
+     exec = needPGF $ \ opts ts env -> return . cParse env opts $ toStrings ts
      })
 {-
   ("p", emptyCommandInfo {
@@ -657,76 +605,6 @@ allCommands = extend commonCommands [
        mkEx ("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 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
-     }),
--}
-{-
-  ("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.",
-       "This command requires a source grammar to be in scope, imported with 'import -retain'.",
-       "The operations include 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)")
-       ],
-     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.",
-       "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
-     }),
--}
-{-
   ("vd", emptyCommandInfo {
      longname = "visualize_dependency",
      synopsis = "show word dependency tree graphically",
@@ -1205,7 +1083,8 @@ cExpr e =
     Just (f,es) -> C.mkApp (H.showCId f) (map cExpr es)
     _ -> error "GF.Command.Commands2.cExpr"
 
-needPGF exec (Env mb_pgf cncs) opts ts =
-  case mb_pgf of
-    Just pgf -> exec (pgf,cncs) opts ts
-    _ -> fail "Import a grammar before using this command"
+needPGF exec opts ts =
+  do Env mb_pgf cncs <- getPGFEnv
+     case mb_pgf of
+       Just pgf -> liftSIO $ exec opts ts (pgf,cncs)
+       _ -> fail "Import a grammar before using this command"

src/compiler/GF/Command/CommonCommands.hs

@@ -19,8 +19,8 @@ import qualified PGF as H(showCId,showExpr,toATree,toTrie,Trie(..))
 
 extend old new = Map.union (Map.fromList new) old -- Map.union is left-biased
 
-commonCommands :: Map.Map String (CommandInfo env)
-commonCommands = Map.fromList [
+commonCommands :: (Monad m,MonadSIO m) => Map.Map String (CommandInfo m)
+commonCommands = fmap (mapCommandExec liftSIO) $ Map.fromList [
   ("!", emptyCommandInfo {
      synopsis = "system command: escape to system shell",
      syntax   = "! SYSTEMCOMMAND",
@@ -104,7 +104,7 @@ commonCommands = Map.fromList [
        mkEx "rf -file=Ara.gf | ps -from_utf8 -env=quotes -from_arabic -- convert UTF8 to transliteration",
        mkEx "ps -to=chinese.trans \"abc\"      -- apply transliteration defined in file chinese.trans"
        ],
-     exec = \_ opts x -> do
+     exec = \opts x-> do
                let (os,fs) = optsAndFlags opts
                trans <- optTranslit opts
 
@@ -139,7 +139,7 @@ commonCommands = Map.fromList [
       mkEx "se utf8   -- set encoding to utf8 (default)"
       ],
      needsTypeCheck = False,
-     exec = \ _ opts ts ->
+     exec = \ opts ts ->
        case words (toString ts) of
          [c] -> do let cod = renameEncoding c
                    restricted $ changeConsoleEncoding cod
@@ -150,7 +150,7 @@ commonCommands = Map.fromList [
      longname = "system_pipe",
      synopsis = "send argument to a system command",
      syntax   = "sp -command=\"SYSTEMCOMMAND\", alt. ? SYSTEMCOMMAND",
-     exec = \_ opts arg -> do
+     exec = \opts arg -> do
        let syst = optComm opts  -- ++ " " ++ tmpi
        {-
        let tmpi = "_tmpi" ---
@@ -171,12 +171,12 @@ commonCommands = Map.fromList [
      longname = "to_trie",
      syntax = "to_trie",
      synopsis = "combine a list of trees into a trie",
-     exec = \ _ _ -> return . fromString . trie
+     exec = \ _ ts -> return . fromString $ trie ts
     }),
   ("ut", emptyCommandInfo {
      longname = "unicode_table",
      synopsis = "show a transliteration table for a unicode character set",
-     exec = \_ opts _ -> do
+     exec = \opts _ -> do
          let t = concatMap prOpt (take 1 opts)
          let out = maybe "no such transliteration" characterTable $ transliteration t
          return $ fromString out,
@@ -185,7 +185,7 @@ commonCommands = Map.fromList [
   ("wf", emptyCommandInfo {
      longname = "write_file",
      synopsis = "send string or tree to a file",
-     exec = \_ opts arg -> do
+     exec = \opts arg-> do
          let file = valStrOpts "file" "_gftmp" opts
          if isOpt "append" opts
            then restricted $ appendFile file (toString arg)

src/compiler/GF/Command/Help.hs

@@ -12,7 +12,7 @@ commandHelpAll' allCommands opts = unlines $
 
 commandHelp' opts = if isOpt "t2t" opts then commandHelpTags else commandHelp
 
-commandHelp :: Bool -> (String,CommandInfo env) -> String
+--commandHelp :: Bool -> (String,CommandInfo env) -> String
 commandHelp full (co,info) = unlines . compact $ [
   co ++ optionally (", " ++) (longname info),
   synopsis info] ++ if full then [
@@ -26,7 +26,7 @@ commandHelp full (co,info) = unlines . compact $ [
 
 -- for printing with txt2tags formatting
 
-commandHelpTags :: Bool -> (String,CommandInfo env) -> String
+--commandHelpTags :: Bool -> (String,CommandInfo env) -> String
 commandHelpTags full (co,info) = unlines . compact $ [
   "#VSPACE","",
   "===="++hdrname++"====",
@@ -75,7 +75,7 @@ helpCommand allCommands =
        ("license","show copyright and license information"),
        ("t2t","output help in txt2tags format")
        ],
-     exec = \_ opts ts ->
+     exec = \opts ts ->
        let
         msg = case ts of
           _ | isOpt "changes" opts -> changesMsg

src/compiler/GF/Command/Interpreter.hs

@@ -1,67 +1,57 @@
 module GF.Command.Interpreter (
-  CommandEnv,pgfenv,commands,commandmacros,expmacros,
-  mkCommandEnv,
---emptyCommandEnv,
+  CommandEnv(..),mkCommandEnv,
   interpretCommandLine,
---interpretPipe,
   getCommandOp
   ) where
-import Prelude hiding (putStrLn)
-
 import GF.Command.CommandInfo
 import GF.Command.Abstract
 import GF.Command.Parse
---import PGF
 import PGF.Internal(Expr(..))
---import PGF.Morphology
-import GF.Infra.SIO(putStrLn,putStrLnFlush)
+import GF.Infra.UseIO(putStrLnE)
 
 import GF.Text.Pretty(render)
 import Control.Monad(when)
---import Control.Monad.Error()
 import qualified Data.Map as Map
 
-data CommandEnv env = CommandEnv {
-  pgfenv        :: env,
-  commands      :: Map.Map String (CommandInfo env),
+data CommandEnv m = CommandEnv {
+  commands      :: Map.Map String (CommandInfo m),
   commandmacros :: Map.Map String CommandLine,
   expmacros     :: Map.Map String Expr
   }
 
 --mkCommandEnv :: PGFEnv -> CommandEnv
-mkCommandEnv env cmds = CommandEnv env cmds Map.empty Map.empty
+mkCommandEnv cmds = CommandEnv cmds Map.empty Map.empty
 
 --interpretCommandLine :: CommandEnv -> String -> SIO ()
 interpretCommandLine env line =
   case readCommandLine line of
     Just []    -> return ()
     Just pipes -> mapM_ (interpretPipe env) pipes
-    Nothing    -> putStrLnFlush "command not parsed"
+    Nothing    -> putStrLnE "command not parsed"
 
 interpretPipe env cs = do
-     Piped v@(_,s) <- intercs void cs
-     putStrLnFlush s
+     Piped v@(_,s) <- intercs cs void
+     putStrLnE s
      return ()
   where
-   intercs treess [] = return treess
-   intercs (Piped (trees,_)) (c:cs) = do
-     treess2 <- interc trees c
-     intercs treess2 cs
-   interc es comm@(Command co opts arg) = case co of
-     '%':f -> case Map.lookup f (commandmacros env) of
-       Just css ->
-         case getCommandTrees env False arg es of
-           Right es -> do mapM_ (interpretPipe env) (appLine es css) 
-                          return void
-           Left msg -> do putStrLn ('\n':msg)
-                          return void
-       Nothing  -> do
-         putStrLn $ "command macro " ++ co ++ " not interpreted"
-         return void
-     _ -> interpret env es comm
-   appLine es = map (map (appCommand es))
+   intercs [] treess = return treess
+   intercs (c:cs) (Piped (trees,_)) = interc c trees >>= intercs cs
 
--- macro definition applications: replace ?i by (exps !! i)
+   interc comm@(Command co opts arg) es =
+     case co of
+       '%':f -> case Map.lookup f (commandmacros env) of
+         Just css ->
+           do es <- getCommandTrees env False arg es
+              mapM_ (interpretPipe env) (appLine es css)
+              return void
+         Nothing  -> do
+           putStrLnE $ "command macro " ++ co ++ " not interpreted"
+           return void
+       _ -> interpret env es comm
+
+   appLine = map . map . appCommand
+
+-- | macro definition applications: replace ?i by (exps !! i)
 appCommand :: [Expr] -> Command -> Command
 appCommand xs c@(Command i os arg) = case arg of
   AExpr e -> Command i os (AExpr (app e))
@@ -74,25 +64,22 @@ appCommand xs c@(Command i os arg) = case arg of
     EMeta i    -> xs !! i
     EFun x     -> EFun x
 
--- return the trees to be sent in pipe, and the output possibly printed
+-- | return the trees to be sent in pipe, and the output possibly printed
 --interpret :: CommandEnv -> [Expr] -> Command -> SIO CommandOutput
 interpret env trees comm = 
-  case getCommand env trees comm of
-    Left  msg               -> do putStrLn ('\n':msg)
-                                  return void
-    Right (info,opts,trees) -> do let cmdenv = pgfenv env
-                                  tss@(Piped (_,s)) <- exec info cmdenv opts trees
-                                  when (isOpt "tr" opts) $ putStrLn s
-                                  return tss
+  do (info,opts,trees) <- getCommand env trees comm
+     tss@(Piped (_,s)) <- exec info opts trees
+     when (isOpt "tr" opts) $ putStrLnE s
+     return tss
 
--- analyse command parse tree to a uniform datastructure, normalizing comm name
+-- | analyse command parse tree to a uniform datastructure, normalizing comm name
 --- the env is needed for macro lookup
 --getCommand :: CommandEnv -> [Expr] -> Command -> Either String (CommandInfo PGFEnv,[Option],[Expr])
-getCommand env es co@(Command c opts arg) = do
-  info <- getCommandInfo  env c
-  checkOpts info opts
-  es   <- getCommandTrees env (needsTypeCheck info) arg es
-  return (info,opts,es)
+getCommand env es co@(Command c opts arg) =
+  do info <- getCommandInfo  env c
+     checkOpts info opts
+     es <- getCommandTrees env (needsTypeCheck info) arg es
+     return (info,opts,es)
 
 --getCommandInfo :: CommandEnv -> String -> Either String (CommandInfo PGFEnv)
 getCommandInfo env cmd = 
@@ -100,7 +87,7 @@ getCommandInfo env cmd =
     Just info -> return info
     Nothing   -> fail $ "command not found: " ++ cmd
 
-checkOpts :: CommandInfo env -> [Option] -> Either String ()
+--checkOpts :: CommandInfo env -> [Option] -> Either String ()
 checkOpts info opts = 
   case
     [o | OOpt  o   <- opts, notElem o ("tr" : map fst (options info))] ++
@@ -114,12 +101,11 @@ checkOpts info opts =
 getCommandTrees env needsTypeCheck a es =
   case a of
     AMacro m -> case Map.lookup m (expmacros env) of
-                  Just e -> return [e]
-                  _      -> return [] 
+                  Just e -> one e
+                  _      -> return [] -- report error?
     AExpr e -> if needsTypeCheck
-                 then case typeCheckArg (pgfenv env) e of
-                        Left tcErr -> fail $ render tcErr
-                        Right e    -> return [e] -- ignore piped
-                 else return [e]
+               then one =<< typeCheckArg e
+               else one e
     ANoArg  -> return es  -- use piped
-
+  where
+    one e = return [e] -- ignore piped

src/compiler/GF/Command/SourceCommands.hs

@@ -1,12 +1,12 @@
 -- | Commands requiring source grammar in env
-module GF.Command.SourceCommands(sourceCommands) where
+module GF.Command.SourceCommands(HasGrammar(..),sourceCommands) where
 import Prelude hiding (putStrLn)
 import qualified Prelude as P(putStrLn)
 import Data.List(nub,isInfixOf)
 import qualified Data.ByteString.UTF8 as UTF8(fromString)
 import qualified Data.Map as Map
 
-import GF.Infra.SIO
+import GF.Infra.SIO(MonadSIO(..),restricted)
 import GF.Infra.Option(noOptions)
 import GF.Data.Operations (chunks,err,raise)
 import GF.Text.Pretty(render)
@@ -25,6 +25,10 @@ import GF.Infra.CheckM(runCheck)
 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",
@@ -152,9 +156,11 @@ sourceCommands = Map.fromList [
      })
   ]
   where
-    withStrings exec sgr opts = do exec sgr opts . toStrings
+    withStrings exec opts ts =
+      do sgr <- getGrammar
+         liftSIO (exec opts (toStrings ts) sgr)
 
-    compute_concrete sgr opts ws =
+    compute_concrete opts ws sgr =
       case runP pExp (UTF8.fromString s) of
         Left (_,msg) -> return $ pipeMessage msg
         Right t      -> return $ err pipeMessage
@@ -176,7 +182,7 @@ sourceCommands = Map.fromList [
             OOpt "qual"    -> pOpts style            Qualified   os
             _              -> pOpts style            q           os
 
-    show_deps sgr os xs = do
+    show_deps os xs sgr = do
           ops <- case xs of
              _:_ -> do
                let ts = [t | Right t <- map (runP pExp . UTF8.fromString) xs]
@@ -192,7 +198,7 @@ sourceCommands = Map.fromList [
                 | otherwise = unwords $ map prTerm ops
           return $ fromString printed
 
-    show_operations sgr os ts =
+    show_operations os ts sgr =
       case greatestResource sgr of
         Nothing -> return $ fromString "no source grammar in scope; did you import with -retain?"
         Just mo -> do
@@ -211,7 +217,7 @@ sourceCommands = Map.fromList [
           let printed = [unwords [showIdent op, ":", printer ty] | (op,ty) <- sigs]
           return . fromString $ unlines [l | l <- printed, all (`isInfixOf` l) greps]
 
-    show_source sgr os ts = do
+    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]
@@ -236,7 +242,7 @@ sourceCommands = Map.fromList [
 
         _ -> return . fromString $ render mygr
 
-    dependency_graph sgr opts ws =
+    dependency_graph opts ws sgr =
       do let stop = case valStrOpts "only" "" opts of
                       "" -> Nothing
                       fs -> Just $ chunks ',' fs