Refactor GF shell modules to improve modularity and reusability

+ Move type CommandInfo from GF.Command.Commands to a new module
  GF.Commands.CommandInfo and make it independent of the PGF type.
+ Make the module GF.Command.Interpreter independent of the PGF type and
  eliminate the import of GF.Command.Commands.
+ Move the implementation of the "help" command to its own module
  GF.Command.Help

gf.cabal

@@ -161,7 +161,9 @@ Library
 
     DarcsVersion_gf
     GF.Command.Abstract
+    GF.Command.CommandInfo
     GF.Command.Commands
+    GF.Command.Help
     GF.Command.Importing
     GF.Command.Interpreter
     GF.Command.Messages

src/compiler/GF/Command/Abstract.hs

@@ -1,6 +1,6 @@
-module GF.Command.Abstract where
+module GF.Command.Abstract(module GF.Command.Abstract,Expr,showExpr) where
 
-import PGF(CId,mkCId,Expr)
+import PGF(CId,mkCId,Expr,showExpr)
 
 type Ident = String
 

src/compiler/GF/Command/CommandInfo.hs

@@ -0,0 +1,57 @@
+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,
+  synopsis :: String,
+  syntax   :: String,
+  explanation :: String,
+  longname :: String,
+  options  :: [(String,String)],
+  flags    :: [(String,String)],
+  examples :: [(String,String)],
+  needsTypeCheck :: Bool
+  }
+
+emptyCommandInfo :: CommandInfo env
+emptyCommandInfo = CommandInfo {
+  exec = \_ _ ts -> return $ pipeExprs ts, ----
+  synopsis = "",
+  syntax = "",
+  explanation = "",
+  longname = "",
+  options = [],
+  flags = [],
+  examples = [],
+  needsTypeCheck = True
+  }
+--------------------------------------------------------------------------------
+
+class TypeCheckArg env where typeCheckArg :: env -> Expr -> Either Doc Expr
+
+--------------------------------------------------------------------------------
+
+newtype CommandOutput  = Piped {fromPipe :: ([Expr],String)} ---- errors, etc
+
+-- ** Converting command output
+fromStrings ss         = Piped (map stringAsExpr ss, unlines ss)
+fromExprs   es         = Piped (es,unlines (map (H.showExpr []) es))
+fromString  s          = Piped ([stringAsExpr s], s)
+pipeWithMessage es msg = Piped (es,msg)
+pipeMessage msg        = Piped ([],msg)
+pipeExprs   es         = Piped (es,[]) -- only used in emptyCommandInfo
+void                   = Piped ([],"")
+
+stringAsExpr = H.ELit . H.LStr -- should be a pattern macro
+
+-- ** Converting command input
+toString  = unwords . toStrings
+toStrings = map showAsString
+  where
+    showAsString t = case t of
+      H.ELit (H.LStr s) -> s
+      _ -> "\n" ++ H.showExpr [] t ---newline needed in other cases than the first

src/compiler/GF/Command/Commands.hs

@@ -1,21 +1,14 @@
-{-# LANGUAGE PatternGuards #-}
+{-# LANGUAGE PatternGuards, TypeSynonymInstances, FlexibleInstances #-}
 module GF.Command.Commands (
-  allCommands,
+  PGFEnv,pgfEnv,allCommands,
-  lookCommand,
+  options,flags,
-  exec,
-  isOpt,
-  options,
-  flags,
-  needsTypeCheck,
-  CommandInfo,
-  CommandOutput(..),void
   ) where
 import Prelude hiding (putStrLn)
 
 import PGF
 
 import PGF.Internal(lookStartCat,functionsToCat,lookValCat,restrictPGF,hasLin)
-import PGF.Internal(abstract,funs,cats,Literal(LStr),Expr(EFun,ELit)) ----
+import PGF.Internal(abstract,funs,cats,Expr(EFun)) ----
 --import PGF.Morphology(isInMorpho,morphoKnown)
 import PGF.Internal(ppFun,ppCat)
 --import PGF.Probabilistic(rankTreesByProbs,probTree,setProbabilities)
@@ -31,7 +24,9 @@ import GF.Infra.UseIO(writeUTF8File)
 import GF.Infra.SIO
 --import GF.Data.ErrM ----
 import GF.Command.Abstract
-import GF.Command.Messages
+--import GF.Command.Messages
+import GF.Command.CommandInfo
+import GF.Command.Help
 import GF.Text.Lexing
 import GF.Text.Clitics
 import GF.Text.Transliterations
@@ -55,113 +50,14 @@ import Data.List (sort)
 
 type PGFEnv = (PGF, Map.Map Language Morpho)
 
-data CommandInfo = CommandInfo {
+pgfEnv pgf = (pgf,mos)
-  exec     :: PGFEnv -> [Option] -> [Expr] -> SIO CommandOutput,
+  where mos = Map.fromList [(la,buildMorpho pgf la) | la <- languages pgf]
-  synopsis :: String,
-  syntax   :: String,
-  explanation :: String,
-  longname :: String,
-  options  :: [(String,String)],
-  flags    :: [(String,String)],
-  examples :: [(String,String)],
-  needsTypeCheck :: Bool
-  }
 
---------------------------------------------------------------------------------
+instance TypeCheckArg PGFEnv where
-newtype CommandOutput  = Piped {fromPipe :: ([Expr],String)} ---- errors, etc
+  typeCheckArg (pgf,_) = either (Left . ppTcError) (Right . fst) . inferExpr pgf
-
--- Converting command output:
-fromStrings ss         = Piped (map (ELit . LStr) ss, unlines ss)
-fromExprs   es         = Piped (es,unlines (map (showExpr []) es))
-fromString  s          = Piped ([ELit (LStr s)], s)
-pipeWithMessage es msg = Piped (es,msg)
-pipeMessage msg        = Piped ([],msg)
-pipeExprs   es         = Piped (es,[]) -- only used in emptyCommandInfo
-void                   = Piped ([],"")
-
--- Converting command input:
-toString  = unwords . toStrings
-toStrings = map showAsString
-  where
-    showAsString t = case t of
-      ELit (LStr s) -> s
-      _ -> "\n" ++ showExpr [] t ---newline needed in other cases than the first
-
---------------------------------------------------------------------------------
-
-emptyCommandInfo :: CommandInfo
-emptyCommandInfo = CommandInfo {
-  exec = \_ _ ts -> return $ pipeExprs ts, ----
-  synopsis = "",
-  syntax = "",
-  explanation = "",
-  longname = "",
-  options = [],
-  flags = [],
-  examples = [],
-  needsTypeCheck = True
-  }
-
-lookCommand :: String -> Map.Map String CommandInfo -> Maybe CommandInfo
-lookCommand = Map.lookup
-
-commandHelpAll :: [Option] -> String
-commandHelpAll opts = unlines $
-  commandHelp' opts (isOpt "full" opts) `map` Map.toList allCommands
-
-commandHelp' opts = if isOpt "t2t" opts then commandHelpTags else commandHelp
-
-commandHelp :: Bool -> (String,CommandInfo) -> String
-commandHelp full (co,info) = unlines . compact $ [
-  co ++ optionally (", " ++) (longname info),
-  synopsis info] ++ if full then [
-  "",
-  optionally (("syntax:" ++++).("  "++).(++"\n")) (syntax info),
-  explanation info,
-  section "options:"  [" -" ++ o ++ "\t" ++ e | (o,e) <- options info],
-  section "flags:"    [" -" ++ o ++ "\t" ++ e | (o,e) <- flags info],
-  section "examples:" ["  " ++ o ++ "\t--" ++ e | (o,e) <- examples info]
-  ] else []
-
--- for printing with txt2tags formatting
-
-commandHelpTags :: Bool -> (String,CommandInfo) -> String
-commandHelpTags full (co,info) = unlines . compact $ [
-  "#VSPACE","",
-  "===="++hdrname++"====",
-  "#NOINDENT",
-  name ++ ": " ++
-  "//" ++ synopsis info ++ ".//"] ++ if full then [
-  "","#TINY","",
-  explanation info,
-  optionally ("- Syntax: "++) (lit (syntax info)),
-  section "- Options:\n"  [" | ``-" ++ o ++ "`` | " ++ e | (o,e) <- options info],
-  section "- Flags:\n"    [" | ``-" ++ o ++ "`` | " ++ e | (o,e) <- flags info],
-  section "- Examples:\n" [" | ``"  ++ o ++ "`` | " ++ e | (o,e) <- examples info],
-  "", "#NORMAL", ""
-  ] else []
- where
-   hdrname = co ++ equal (longname info)
-   name = lit co ++ equal (lit (longname info))
-
-   lit = optionally (wrap "``")
-   equal = optionally (" = "++)
--- verbatim = optionally (wrap ["```"])
-   wrap d s = d++s++d
-
-section hdr = optionally ((hdr++++).unlines)
-
-optionally f [] = []
-optionally f s  = f s
-
-compact [] = []
-compact ([]:xs@([]:_)) = compact xs
-compact (x:xs) = x:compact xs
-
-mkEx s = let (command,expl) = break (=="--") (words s) in (unwords command, unwords (drop 1 expl))
 
 -- this list must no more be kept sorted by the command name
-allCommands :: Map.Map String CommandInfo
+allCommands :: Map.Map String (CommandInfo PGFEnv)
 allCommands = Map.fromList [
   ("!", emptyCommandInfo {
      synopsis = "system command: escape to system shell",
@@ -440,35 +336,7 @@ allCommands = Map.fromList [
                   Nothing -> generateAllDepth pgfr (optType pgf opts) (Just dp)
        returnFromExprs $ take (optNumInf opts) ts
      }),
-  ("h", emptyCommandInfo {
+  helpCommand allCommands,
-     longname = "help",
-     syntax = "h (-full)? COMMAND?",
-     synopsis = "get description of a command, or a the full list of commands",
-     explanation = unlines [
-       "Displays information concerning the COMMAND.",
-       "Without argument, shows the synopsis of all commands."
-       ],
-     options = [
-       ("changes","give a summary of changes from GF 2.9"),
-       ("coding","give advice on character encoding"),
-       ("full","give full information of the commands"),
-       ("license","show copyright and license information"),
-       ("t2t","output help in txt2tags format")
-       ],
-     exec = \_ opts ts ->
-       let
-        msg = case ts of
-          _ | isOpt "changes" opts -> changesMsg
-          _ | isOpt "coding" opts -> codingMsg
-          _ | isOpt "license" opts -> licenseMsg
-          [t] -> let co = getCommandOp (showExpr [] t) in
-                 case lookCommand co allCommands of
-                   Just info -> commandHelp' opts True (co,info)
-                   _ -> "command not found"
-          _ -> commandHelpAll opts
-       in return (fromString msg),
-     needsTypeCheck = False
-     }),
   ("i", emptyCommandInfo {
      longname = "import",
      synopsis = "import a grammar from source code or compiled .pgf file",

src/compiler/GF/Command/Help.hs

@@ -0,0 +1,93 @@
+module GF.Command.Help where
+import GF.Command.Messages
+import GF.Command.Abstract(isOpt,getCommandOp,showExpr)
+import GF.Command.CommandInfo
+
+import GF.Data.Operations((++++))
+import qualified Data.Map as Map
+
+
+commandHelpAll' allCommands opts = unlines $
+  commandHelp' opts (isOpt "full" opts) `map` Map.toList allCommands
+
+commandHelp' opts = if isOpt "t2t" opts then commandHelpTags else commandHelp
+
+commandHelp :: Bool -> (String,CommandInfo env) -> String
+commandHelp full (co,info) = unlines . compact $ [
+  co ++ optionally (", " ++) (longname info),
+  synopsis info] ++ if full then [
+  "",
+  optionally (("syntax:" ++++).("  "++).(++"\n")) (syntax info),
+  explanation info,
+  section "options:"  [" -" ++ o ++ "\t" ++ e | (o,e) <- options info],
+  section "flags:"    [" -" ++ o ++ "\t" ++ e | (o,e) <- flags info],
+  section "examples:" ["  " ++ o ++ "\t--" ++ e | (o,e) <- examples info]
+  ] else []
+
+-- for printing with txt2tags formatting
+
+commandHelpTags :: Bool -> (String,CommandInfo env) -> String
+commandHelpTags full (co,info) = unlines . compact $ [
+  "#VSPACE","",
+  "===="++hdrname++"====",
+  "#NOINDENT",
+  name ++ ": " ++
+  "//" ++ synopsis info ++ ".//"] ++ if full then [
+  "","#TINY","",
+  explanation info,
+  optionally ("- Syntax: "++) (lit (syntax info)),
+  section "- Options:\n"  [" | ``-" ++ o ++ "`` | " ++ e | (o,e) <- options info],
+  section "- Flags:\n"    [" | ``-" ++ o ++ "`` | " ++ e | (o,e) <- flags info],
+  section "- Examples:\n" [" | ``"  ++ o ++ "`` | " ++ e | (o,e) <- examples info],
+  "", "#NORMAL", ""
+  ] else []
+ where
+   hdrname = co ++ equal (longname info)
+   name = lit co ++ equal (lit (longname info))
+
+   lit = optionally (wrap "``")
+   equal = optionally (" = "++)
+-- verbatim = optionally (wrap ["```"])
+   wrap d s = d++s++d
+
+section hdr = optionally ((hdr++++).unlines)
+
+optionally f [] = []
+optionally f s  = f s
+
+compact [] = []
+compact ([]:xs@([]:_)) = compact xs
+compact (x:xs) = x:compact xs
+
+mkEx s = let (command,expl) = break (=="--") (words s) in (unwords command, unwords (drop 1 expl))
+
+helpCommand allCommands =
+  ("h", emptyCommandInfo {
+     longname = "help",
+     syntax = "h (-full)? COMMAND?",
+     synopsis = "get description of a command, or a the full list of commands",
+     explanation = unlines [
+       "Displays information concerning the COMMAND.",
+       "Without argument, shows the synopsis of all commands."
+       ],
+     options = [
+       ("changes","give a summary of changes from GF 2.9"),
+       ("coding","give advice on character encoding"),
+       ("full","give full information of the commands"),
+       ("license","show copyright and license information"),
+       ("t2t","output help in txt2tags format")
+       ],
+     exec = \_ opts ts ->
+       let
+        msg = case ts of
+          _ | isOpt "changes" opts -> changesMsg
+          _ | isOpt "coding" opts -> codingMsg
+          _ | isOpt "license" opts -> licenseMsg
+          [t] -> let co = getCommandOp (showExpr [] t) in
+                 case Map.lookup co allCommands of
+                   Just info -> commandHelp' opts True (co,info)
+                   _ -> "command not found"
+          _ -> commandHelpAll' allCommands opts
+       in return (fromString msg),
+     needsTypeCheck = False
+     })

src/compiler/GF/Command/Interpreter.hs

@@ -1,44 +1,37 @@
 module GF.Command.Interpreter (
-  CommandEnv,commands,multigrammar,commandmacros,expmacros,
+  CommandEnv,pgfenv,commands,commandmacros,expmacros,
   mkCommandEnv,
-  emptyCommandEnv,
+--emptyCommandEnv,
   interpretCommandLine,
-  interpretPipe,
+--interpretPipe,
   getCommandOp
   ) where
 import Prelude hiding (putStrLn)
 
-import GF.Command.Commands
+import GF.Command.CommandInfo
 import GF.Command.Abstract
 import GF.Command.Parse
-import PGF
+--import PGF
-import PGF.Internal
+import PGF.Internal(Expr(..))
 --import PGF.Morphology
-import GF.Infra.SIO
+import GF.Infra.SIO(putStrLn,putStrLnFlush)
 
-import GF.Text.Pretty
+import GF.Text.Pretty(render)
 import Control.Monad(when)
 --import Control.Monad.Error()
 import qualified Data.Map as Map
 
-data CommandEnv = CommandEnv {
+data CommandEnv env = CommandEnv {
-  multigrammar  :: PGF,
+  pgfenv        :: env,
-  morphos       :: Map.Map Language Morpho,
+  commands      :: Map.Map String (CommandInfo env),
---commands      :: Map.Map String CommandInfo,
   commandmacros :: Map.Map String CommandLine,
   expmacros     :: Map.Map String Expr
   }
-commands _ = allCommands
 
-mkCommandEnv :: PGF -> CommandEnv
+--mkCommandEnv :: PGFEnv -> CommandEnv
-mkCommandEnv pgf = 
+mkCommandEnv env cmds = CommandEnv env cmds Map.empty Map.empty
-  let mos = Map.fromList [(la,buildMorpho pgf la) | la <- languages pgf] in
-    CommandEnv pgf mos {-allCommands-} Map.empty Map.empty
 
-emptyCommandEnv :: CommandEnv
+--interpretCommandLine :: CommandEnv -> String -> SIO ()
-emptyCommandEnv = mkCommandEnv emptyPGF
-
-interpretCommandLine :: CommandEnv -> String -> SIO ()
 interpretCommandLine env line =
   case readCommandLine line of
     Just []    -> return ()
@@ -48,7 +41,7 @@ interpretCommandLine env line =
 interpretPipe env cs = do
      Piped v@(_,s) <- intercs void cs
      putStrLnFlush s
-     return v
+     return ()
   where
    intercs treess [] = return treess
    intercs (Piped (trees,_)) (c:cs) = do
@@ -82,32 +75,32 @@ appCommand xs c@(Command i os arg) = case arg of
     EFun x     -> EFun x
 
 -- return the trees to be sent in pipe, and the output possibly printed
-interpret :: CommandEnv -> [Expr] -> Command -> SIO CommandOutput
+--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 = (multigrammar env,morphos env)
+    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
 
 -- 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,[Option],[Expr])
+--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)
 
-getCommandInfo :: CommandEnv -> String -> Either String CommandInfo
+--getCommandInfo :: CommandEnv -> String -> Either String (CommandInfo PGFEnv)
 getCommandInfo env cmd = 
-  case lookCommand (getCommandOp cmd) (commands env) of
+  case Map.lookup (getCommandOp cmd) (commands env) of
     Just info -> return info
-    Nothing   -> fail $ "command " ++ cmd ++ " not interpreted"
+    Nothing   -> fail $ "command not found: " ++ cmd
 
-checkOpts :: CommandInfo -> [Option] -> Either String ()
+checkOpts :: CommandInfo env -> [Option] -> Either String ()
 checkOpts info opts = 
   case
     [o | OOpt  o   <- opts, notElem o ("tr" : map fst (options info))] ++
@@ -117,16 +110,16 @@ checkOpts info opts =
     [o] -> fail $ "option not interpreted: " ++ o
     os  -> fail $ "options not interpreted: " ++ unwords os
 
-getCommandTrees :: CommandEnv -> Bool -> Argument -> [Expr] -> Either String [Expr]
+--getCommandTrees :: CommandEnv -> Bool -> Argument -> [Expr] -> Either String [Expr]
 getCommandTrees env needsTypeCheck a es =
   case a of
     AMacro m -> case Map.lookup m (expmacros env) of
                   Just e -> return [e]
                   _      -> return [] 
     AExpr e -> if needsTypeCheck
-                 then case inferExpr (multigrammar env) e of
+                 then case typeCheckArg (pgfenv env) e of
-                        Left tcErr   -> fail $ render (ppTcError tcErr)
+                        Left tcErr -> fail $ render tcErr
-                        Right (e,ty) -> return [e] -- ignore piped
+                        Right e    -> return [e] -- ignore piped
                  else return [e]
     ANoArg  -> return es  -- use piped
 

src/compiler/GF/Interactive.hs

@@ -3,9 +3,9 @@
 module GF.Interactive (mainGFI,mainRunGFI,mainServerGFI) where
 import Prelude hiding (putStrLn,print)
 import qualified Prelude as P(putStrLn)
-import GF.Command.Interpreter(CommandEnv(..),commands,mkCommandEnv,emptyCommandEnv,interpretCommandLine)
+import GF.Command.Interpreter(CommandEnv(..),pgfenv,commands,mkCommandEnv,interpretCommandLine)
 --import GF.Command.Importing(importSource,importGrammar)
-import GF.Command.Commands(flags,options)
+import GF.Command.Commands(flags,options,PGFEnv,pgfEnv,allCommands)
 import GF.Command.Abstract
 import GF.Command.Parse(readCommandLine,pCommand)
 import GF.Data.Operations (Err(..),chunks,err,raise,done)
@@ -29,7 +29,7 @@ import qualified System.Console.Haskeline as Haskeline
 --import GF.Compile.Coding(codeTerm)
 
 import PGF
-import PGF.Internal(emptyPGF,abstract,funs,lookStartCat)
+import PGF.Internal(abstract,funs,lookStartCat,emptyPGF)
 
 import Data.Char
 import Data.List(nub,isPrefixOf,isInfixOf,partition)
@@ -357,10 +357,10 @@ importInEnv gfenv opts files
         do src <- importSource opts files
            pgf <- lazySIO importPGF -- duplicates some work, better to link src
            return $ gfenv {grammar = src, retain=True,
-                           commandenv = mkCommandEnv pgf}
+                           commandenv = commandEnv pgf }
     | otherwise =
         do pgf1 <- importPGF
-           return $ gfenv { commandenv = mkCommandEnv pgf1 }
+           return $ gfenv { commandenv = commandEnv pgf1 }
   where
     importPGF =
       do let opts' = addOptions (setOptimization OptCSE False) opts
@@ -406,13 +406,16 @@ prompt env
 data GFEnv = GFEnv {
   grammar :: Grammar, -- gfo grammar -retain
   retain :: Bool,  -- grammar was imported with -retain flag
-  commandenv :: CommandEnv,
+  commandenv :: CommandEnv PGFEnv,
   history    :: [String]
   }
 
 emptyGFEnv :: GFEnv
-emptyGFEnv =
+emptyGFEnv = GFEnv emptyGrammar False emptyCommandEnv [] {-0-}
-  GFEnv emptyGrammar False (mkCommandEnv emptyPGF) [] {-0-}
+
+commandEnv pgf = mkCommandEnv (pgfEnv pgf) allCommands
+emptyCommandEnv = commandEnv emptyPGF
+multigrammar = fst . pgfenv
 
 wordCompletion gfenv (left,right) = do
   case wc_type (reverse left) of