GF.Command.Command: turn CommandOutput into a newtype

The output from commands is represented as ([Expr],String), where the [Expr] is
used when data is piped between commands and the String is used for the final
output. The String can represent the same list of trees as the [Expr] and/or
contain diagnostic information.

Sometimes the data that is piped between commands is not a list of trees, but
e.g. a string or a list of strings. In those cases, functions like fromStrings
and toStrings are used to encode the data as a [Expr].

This patch introduces a newtype for CommandOutput and collects the functions
dealing with command output in one place to make it clearer what is going on.
It also makes it easier to change to a more direct representation of piped
data, and make pipes more "type safe", if desired.

src/compiler/GF/Command/Commands.hs

@@ -8,7 +8,7 @@ module GF.Command.Commands (
   flags,
   needsTypeCheck,
   CommandInfo,
-  CommandOutput
+  CommandOutput(..),void
   ) where
 import Prelude hiding (putStrLn)
 
@@ -52,7 +52,8 @@ import Data.List (sort)
 import Debug.Trace
 --import System.Random (newStdGen) ----
 
-type CommandOutput = ([Expr],String) ---- errors, etc
+
+type PGFEnv = (PGF, Map.Map Language Morpho)
 
 data CommandInfo = CommandInfo {
   exec     :: PGFEnv -> [Option] -> [Expr] -> SIO CommandOutput,
@@ -66,9 +67,31 @@ data CommandInfo = CommandInfo {
   needsTypeCheck :: Bool
   }
 
+--------------------------------------------------------------------------------
+newtype CommandOutput  = Piped {fromPipe :: ([Expr],String)} ---- errors, etc
+
+-- 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 (ts,[]), ----
+  exec = \_ _ ts -> return $ pipeExprs ts, ----
   synopsis = "",
   syntax = "",
   explanation = "",
@@ -135,8 +158,6 @@ compact [] = []
 compact ([]:xs@([]:_)) = compact xs
 compact (x:xs) = x:compact xs
 
-type PGFEnv = (PGF, Map.Map Language Morpho)
-
 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
@@ -570,7 +591,7 @@ allCommands = Map.fromList [
        "will accept unknown adjectives, nouns and verbs with the resource grammar."
        ],
      exec = \env@(pgf, mos) opts ts ->
-              return $ fromParse opts (concat [map ((,) s) (par pgf opts s) | s <- toStrings ts]),
+              return . Piped $ fromParse opts (concat [map ((,) s) (par pgf opts s) | s <- toStrings ts]),
      flags = [
        ("cat","target category of parsing"),
        ("lang","the languages of parsing (comma-separated, no spaces)"),
@@ -720,8 +741,8 @@ allCommands = Map.fromList [
                                 Nothing -> let (es,err) = exprs ls
                                            in (es,text "on line" <+> int n <> colon <+> text "parse error" $$ err)
            returnFromLines ls = case exprs ls of
-                                  (es, err) | null es   -> return ([], render (err $$ text "no trees found"))
+                                  (es, err) | null es   -> return $ pipeMessage $ render (err $$ text "no trees found")
-                                            | otherwise -> return (es, render err)
+                                            | otherwise -> return $ pipeWithMessage es (render err)
 
        s <- restricted $ readFile file
        case opts of
@@ -1093,8 +1114,6 @@ allCommands = Map.fromList [
      where
        dp = valIntOpts "depth" 4 opts
 
-   void = ([],[])
-
    optLins pgf opts ts = case opts of
      _ | isOpt "groups" opts ->
        map (unlines . snd) $ groupResults
@@ -1202,18 +1221,12 @@ allCommands = Map.fromList [
    optNumInf opts = valIntOpts "number" 1000000000 opts ---- 10^9
    takeOptNum opts = take (optNumInf opts)
 
-   fromExprs   es = (es,unlines (map (showExpr []) es))
+   fromParse opts []     = ([],[])
-   fromStrings ss = (map (ELit . LStr) ss, unlines ss)
-   fromString  s  = ([ELit (LStr s)], s)
-   toStrings = map showAsString
-   toString = unwords . toStrings
-
-   fromParse opts []     = ([],"")
    fromParse opts ((s,(po,bs)):ps)
      | isOpt "bracket" opts = (es, showBracketedString bs
                                    ++ "\n" ++ msg)
      | otherwise            = case po of
-                                ParseOk ts     -> let (es',msg') = fromExprs ts
+                                ParseOk ts     -> let Piped (es',msg') = fromExprs ts
                                                   in (es'++es,msg'++msg)
                                 TypeError errs -> ([], render (text "The parsing is successful but the type checking failed with error(s):" $$
                                                                nest 2 (vcat (map (ppTcError . snd) errs)))
@@ -1225,7 +1238,7 @@ allCommands = Map.fromList [
        (es,msg) = fromParse opts ps
 
    returnFromExprs es = return $ case es of
-     [] -> ([], "no trees found")
+     [] -> pipeMessage "no trees found"
      _  -> fromExprs es
 
    prGrammar env@(pgf,mos) opts
@@ -1279,10 +1292,6 @@ allCommands = Map.fromList [
      app (OFlag op (VId x)) | Just (Right f) <- treeOp pgf op = f (mkCId x)
      app _                                                    = id
 
-   showAsString t = case t of
-     ELit (LStr s) -> s
-     _ -> "\n" ++ showExpr [] t  --- newline needed in other cases than the first
-
 stringOpOptions = sort $ [
        ("bind","bind tokens separated by Prelude.BIND, i.e. &+"),
        ("chars","lexer that makes every non-space character a token"),
@@ -1353,12 +1362,12 @@ execToktok (pgf, _) opts exprs = do
   case getLang opts of
     Nothing -> do
       let output = concatMap toStringList [t input | (_,t) <- Map.toList tokenizers]
-      return ([ELit $ LStr o | o <- output],unlines output)
+      return (fromStrings output)
     Just lang -> case Map.lookup lang tokenizers of
       Just tok -> do
         let output = toStringList $ tok input
-        return ([ELit $ LStr o | o <- output],unlines output)
+        return (fromStrings output)
-      Nothing -> return ([],"Unknown language: " ++ show lang)
+      Nothing -> return (pipeMessage ("Unknown language: " ++ show lang))
   where input = case exprs of
           [ELit (LStr s)] -> s
           _ -> ""

src/compiler/GF/Command/Interpreter.hs

@@ -19,7 +19,8 @@ import GF.Infra.SIO
 import GF.Infra.Option
 
 import Text.PrettyPrint
-import Control.Monad.Error
+import Control.Monad(when)
+--import Control.Monad.Error()
 import qualified Data.Map as Map
 
 data CommandEnv = CommandEnv {
@@ -47,12 +48,12 @@ interpretCommandLine env line =
     Nothing    -> putStrLnFlush "command not parsed"
 
 interpretPipe env cs = do
-     v@(_,s) <- intercs ([],"") cs
+     Piped v@(_,s) <- intercs void cs
      putStrLnFlush s
      return v
   where
    intercs treess [] = return treess
-   intercs (trees,_) (c:cs) = do
+   intercs (Piped (trees,_)) (c:cs) = do
      treess2 <- interc trees c
      intercs treess2 cs
    interc es comm@(Command co opts arg) = case co of
@@ -60,12 +61,12 @@ interpretPipe env cs = do
        Just css ->
          case getCommandTrees env False arg es of
            Right es -> do mapM_ (interpretPipe env) (appLine es css) 
-                          return ([],[])
+                          return void
            Left msg -> do putStrLn ('\n':msg)
-                          return ([],[])
+                          return void
        Nothing  -> do
          putStrLn $ "command macro " ++ co ++ " not interpreted"
-         return ([],[])
+         return void
      _ -> interpret env es comm
    appLine es = map (map (appCommand es))
 
@@ -87,12 +88,10 @@ interpret :: CommandEnv -> [Expr] -> Command -> SIO CommandOutput
 interpret env trees comm = 
   case getCommand env trees comm of
     Left  msg               -> do putStrLn ('\n':msg)
-                                  return ([],[])
+                                  return void
     Right (info,opts,trees) -> do let cmdenv = (multigrammar env,morphos env)
-                                  tss@(_,s) <- exec info cmdenv opts trees
+                                  tss@(Piped (_,s)) <- exec info cmdenv opts trees
-                                  if isOpt "tr" opts
+                                  when (isOpt "tr" opts) $ putStrLn s
-                                    then putStrLn s
-                                    else return ()
                                   return tss
 
 -- analyse command parse tree to a uniform datastructure, normalizing comm name