reintroduce the compiler API

src/compiler/api/GF/Command/Abstract.hs

@@ -0,0 +1,109 @@
+module GF.Command.Abstract(module GF.Command.Abstract,Expr,showExpr,Literal(..),Term) where
+
+import PGF2
+import GF.Grammar.Grammar(Term)
+
+type Ident = String
+
+type CommandLine = [Pipe]
+
+type Pipe = [Command]
+
+data Command
+   = Command Ident [Option] Argument
+   deriving Show
+
+data TransactionCommand
+   = CreateFun [Option] Fun Type
+   | CreateCat [Option] Cat [Hypo]
+   | CreateConcrete [Option] ConcName
+   | CreateLin [Option] Fun Term Bool
+   | CreateLincat [Option] Cat Term
+   | DropFun [Option] Fun
+   | DropCat [Option] Cat
+   | DropConcrete [Option] ConcName
+   | DropLin [Option] Fun
+   | DropLincat [Option] Cat
+   deriving Show
+
+data Option
+  = OOpt Ident
+  | OFlag Ident Literal
+  deriving (Eq,Ord,Show)
+
+data Argument
+  = AExpr Expr
+  | ATerm Term
+  | ANoArg
+  | AMacro Ident
+  deriving Show
+
+valIntOpts :: String -> Int -> [Option] -> Int
+valIntOpts flag def opts =
+  case [v | OFlag f (LInt v) <- opts, f == flag] of
+    (v:_) -> fromIntegral v
+    _     -> def
+
+valFltOpts :: String -> Double -> [Option] -> Double
+valFltOpts flag def opts =
+  case [v | OFlag f v <- opts, v <- toFlt v, f == flag] of
+    (v:_) -> v
+    _     -> def
+  where
+    toFlt (LInt v) = [fromIntegral v]
+    toFlt (LFlt f) = [f]
+    toFlt _        = []
+
+valStrOpts :: String -> String -> [Option] -> String
+valStrOpts flag def opts =
+  case listFlags flag opts of
+    v:_ -> valueString v
+    _   -> def
+
+maybeIntOpts :: String -> a -> (Int -> a) -> [Option] -> a
+maybeIntOpts flag def fn opts =
+  case [v | OFlag f (LInt v) <- opts, f == flag] of
+    (v:_) -> fn (fromIntegral v)
+    _     -> def
+
+maybeStrOpts :: String -> a -> (String -> a) -> [Option] -> a
+maybeStrOpts flag def fn opts =
+  case listFlags flag opts of
+    v:_ -> fn (valueString v)
+    _   -> def
+
+listFlags flag opts = [v | OFlag f v <- opts, f == flag]
+
+valueString v =
+  case v of
+    LInt v -> show v
+    LFlt v -> show v
+    LStr v -> v
+
+isOpt :: String -> [Option] -> Bool
+isOpt o opts = elem (OOpt o) opts
+
+isFlag :: String -> [Option] -> Bool
+isFlag o opts = elem o [x | OFlag x _ <- opts]
+
+optsAndFlags :: [Option] -> ([Option],[Option])
+optsAndFlags = foldr add ([],[]) where
+  add o (os,fs) = case o of
+    OOpt _    -> (o:os,fs)
+    OFlag _ _ -> (os,o:fs)
+
+prOpt :: Option -> String
+prOpt o = case o of
+  OOpt i    -> i
+  OFlag f x -> f ++ "=" ++ show x
+
+mkOpt :: String -> Option
+mkOpt = OOpt
+
+-- abbreviation convention from gf commands
+getCommandOp s = case break (=='_') s of
+     (a:_,_:b:_) -> [a,b]  -- axx_byy --> ab
+     _ -> case s of
+       [a,b] -> s          -- ab  --> ab
+       a:_ -> [a]          -- axx --> a
+

src/compiler/api/GF/Command/CommandInfo.hs

@@ -0,0 +1,81 @@
+module GF.Command.CommandInfo where
+import GF.Command.Abstract(Option,Expr,Term)
+import GF.Text.Pretty(render)
+import GF.Grammar.Grammar(Term(K))
+import GF.Grammar.Printer() -- instance Pretty Term
+import PGF2(mkStr,unStr,showExpr)
+
+data CommandInfo m = CommandInfo {
+  exec     :: [Option] -> CommandArguments -> m CommandOutput,
+  synopsis :: String,
+  syntax   :: String,
+  explanation :: String,
+  longname :: String,
+  options  :: [(String,String)],
+  flags    :: [(String,String)],
+  examples :: [(String,String)],
+  needsTypeCheck :: Bool
+  }
+
+mapCommandExec f c = c { exec = \ opts ts -> f (exec c opts ts) }
+
+--emptyCommandInfo :: CommandInfo env
+emptyCommandInfo = CommandInfo {
+  exec = error "command not implemented",
+  synopsis = "",
+  syntax = "",
+  explanation = "",
+  longname = "",
+  options = [],
+  flags = [],
+  examples = [],
+  needsTypeCheck = True
+  }
+--------------------------------------------------------------------------------
+
+class Monad m => TypeCheckArg m where typeCheckArg :: Expr -> m Expr
+
+--------------------------------------------------------------------------------
+
+data CommandArguments = Exprs [(Expr,Float)] | Strings [String] | Term Term
+
+newtype CommandOutput = Piped (CommandArguments,String) ---- errors, etc
+
+-- ** Converting command output
+fromStrings ss         = Piped (Strings ss, unlines ss)
+fromExprs show_p es    = Piped (Exprs es,unlines (map (\(e,p) -> (if show_p then (++) ("["++show p++"] ") else id) (showExpr [] e)) es))
+fromString  s          = Piped (Strings [s], s)
+pipeWithMessage es msg = Piped (Exprs es,msg)
+pipeMessage msg        = Piped (Exprs [],msg)
+pipeExprs   es         = Piped (Exprs es,[]) -- only used in emptyCommandInfo
+void                   = Piped (Exprs [],"")
+
+-- ** Converting command input
+
+toStrings args =
+    case args of
+      Strings ss -> ss
+      Exprs es -> zipWith showAsString (True:repeat False) es
+      Term t -> [render t]
+  where
+    showAsString first (e,p) =
+      case unStr e of
+        Just s  -> s
+        Nothing -> ['\n'|not first] ++
+                   showExpr [] e ---newline needed in other cases than the first
+
+toExprs args =
+  case args of
+    Exprs es -> map fst es
+    Strings ss -> map mkStr ss
+    Term t -> [mkStr (render t)]
+
+toTerm args =
+  case args of
+    Term t -> t
+    Strings ss -> K $ unwords ss -- hmm
+    Exprs es -> K $ unwords $ map (showExpr [] . fst) es -- hmm
+
+-- ** Creating documentation
+
+mkEx s = let (command,expl) = break (=="--") (words s) in (unwords command, unwords (drop 1 expl))

src/compiler/api/GF/Command/CommonCommands.hs

@@ -0,0 +1,251 @@
+-- | Commands that work in any type of environment, either because they don't
+-- use the PGF, or because they are just documented here and implemented
+-- elsewhere
+module GF.Command.CommonCommands where
+import Data.List(sort)
+import GF.Command.CommandInfo
+import qualified Data.Map as Map
+import GF.Infra.SIO
+import GF.Infra.UseIO(writeUTF8File)
+import GF.Infra.Option(renameEncoding)
+import GF.System.Console(changeConsoleEncoding)
+import GF.System.Process
+import GF.Command.Abstract --(isOpt,valStrOpts,prOpt)
+import GF.Text.Pretty
+import GF.Text.Transliterations
+import GF.Text.Lexing(stringOp,opInEnv)
+import Data.Char (isSpace)
+
+import PGF2(showExpr)
+
+extend old new = Map.union (Map.fromList new) old -- Map.union is left-biased
+
+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",
+     examples = [
+       ("! ls *.gf",  "list all GF files in the working directory")
+       ]
+     }),
+  ("?", emptyCommandInfo {
+     synopsis = "system pipe: send value from previous command to a system command",
+     syntax   = "? SYSTEMCOMMAND",
+     examples = [
+       ("gt | l | ? wc",  "generate, linearize, word-count")
+       ]
+     }),
+  ("dc",  emptyCommandInfo {
+     longname = "define_command",
+     syntax = "dc IDENT COMMANDLINE",
+     synopsis = "define a command macro",
+     explanation = unlines [
+       "Defines IDENT as macro for COMMANDLINE, until IDENT gets redefined.",
+       "A call of the command has the form %IDENT. The command may take an",
+       "argument, which in COMMANDLINE is marked as ?0. Both strings and",
+       "trees can be arguments. Currently at most one argument is possible.",
+       "This command must be a line of its own, and thus cannot be a part",
+       "of a pipe."
+       ]
+     }),
+  ("dt",  emptyCommandInfo {
+     longname = "define_tree",
+     syntax = "dt IDENT (TREE | STRING | \"<\" COMMANDLINE)",
+     synopsis = "define a tree or string macro",
+     explanation = unlines [
+       "Defines IDENT as macro for TREE or STRING, until IDENT gets redefined.",
+       "The defining value can also come from a command, preceded by \"<\".",
+       "If the command gives many values, the first one is selected.",
+       "A use of the macro has the form %IDENT. Currently this use cannot be",
+       "a subtree of another tree. This command must be a line of its own",
+       "and thus cannot be a part of a pipe."
+       ],
+     examples = [
+       mkEx ("dt ex \"hello world\"                    -- define ex as string"),
+       mkEx ("dt ex UseN man_N                         -- define ex as string"),
+       mkEx ("dt ex < p -cat=NP \"the man in the car\" -- define ex as parse result"),
+       mkEx ("l -lang=LangSwe %ex | ps -to_utf8        -- linearize the tree ex")
+       ]
+     }),
+  ("e",  emptyCommandInfo {
+     longname = "empty",
+     synopsis = "empty the environment"
+     }),
+  ("eh",  emptyCommandInfo {
+     longname = "execute_history",
+     syntax = "eh FILE",
+     synopsis = "read commands from a file and execute them"
+     }),
+  ("ph", emptyCommandInfo {
+     longname = "print_history",
+     synopsis = "print command history",
+     explanation = unlines [
+       "Prints the commands issued during the GF session.",
+       "The result is readable by the eh command.",
+       "The result can be used as a script when starting GF."
+       ],
+     examples = [
+      mkEx "ph | wf -file=foo.gfs  -- save the history into a file"
+      ]
+     }),
+  ("ps", emptyCommandInfo {
+     longname = "put_string",
+     syntax = "ps OPT? STRING",
+     synopsis = "return a string, possibly processed with a function",
+     explanation = unlines [
+       "Returns a string obtained from its argument string by applying",
+       "string processing functions in the order given in the command line",
+       "option list. Thus 'ps -f -g s' returns g (f s). Typical string processors",
+       "are lexers and unlexers, but also character encoding conversions are possible.",
+       "The unlexers preserve the division of their input to lines.",
+       "To see transliteration tables, use command ut."
+       ],
+     examples = [
+       mkEx "l (EAdd 3 4) | ps -unlexcode    -- linearize code-like output",
+       mkEx "ps -lexcode | p -cat=Exp        -- parse code-like input",
+       mkEx "gr -cat=QCl | l | ps -bind      -- linearization output from LangFin",
+       mkEx "ps -to_devanagari \"A-p\"         -- show Devanagari in UTF8 terminal",
+       mkEx "rf -file=Hin.gf | ps -env=quotes -to_devanagari -- convert translit to UTF8",
+       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",
+       mkEx "ps -lexgreek \"a)gavoi` a)'nvrwpoi' tines*\" -- normalize ancient greek accentuation"
+       ],
+     exec = \opts x-> do
+               let (os,fs) = optsAndFlags opts
+               trans <- optTranslit opts
+
+               if isOpt "lines" opts 
+                  then return $ fromStrings $ map (trans . stringOps (envFlag fs) (map prOpt os)) $ toStrings x
+                  else return ((fromString . trans . stringOps (envFlag fs) (map prOpt os) . toString) x),
+     options = [
+       ("lines","apply the operation separately to each input line, returning a list of lines")
+       ] ++
+       stringOpOptions,
+     flags = [
+       ("env","apply in this environment only"),
+       ("from","backward-apply transliteration defined in this file (format 'unicode translit' per line)"),
+       ("to",  "forward-apply transliteration defined in this file")
+       ]
+     }),
+  ("q",  emptyCommandInfo {
+     longname = "quit",
+     synopsis = "exit GF interpreter"
+     }),
+  ("r",  emptyCommandInfo {
+     longname = "reload",
+     synopsis = "repeat the latest import command"
+     }),
+
+  ("se", emptyCommandInfo {
+     longname = "set_encoding",
+     synopsis = "set the encoding used in current terminal",
+     syntax   = "se ID",
+     examples = [
+      mkEx "se cp1251 -- set encoding to cp1521",
+      mkEx "se utf8   -- set encoding to utf8 (default)"
+      ],
+     needsTypeCheck = False,
+     exec = \ opts ts ->
+       case words (toString ts) of
+         [c] -> do let cod = renameEncoding c
+                   restricted $ changeConsoleEncoding cod
+                   return void
+         _ -> return (pipeMessage "se command not parsed")
+    }),
+  ("sp", emptyCommandInfo {
+     longname = "system_pipe",
+     synopsis = "send argument to a system command",
+     syntax   = "sp -command=\"SYSTEMCOMMAND\", alt. ? SYSTEMCOMMAND",
+     exec = \opts arg -> do
+       let syst = optComm opts  -- ++ " " ++ tmpi
+       {-
+       let tmpi = "_tmpi" ---
+       let tmpo = "_tmpo"
+       restricted $ writeFile tmpi $ toString arg
+       restrictedSystem $ syst ++ " <" ++ tmpi ++ " >" ++ tmpo
+       fmap fromString $ restricted $ readFile tmpo,
+       -}
+       fmap (fromStrings . lines) . restricted . readShellProcess syst . unlines . map (dropWhile (=='\n')) $ toStrings $ arg,
+
+     flags = [
+       ("command","the system command applied to the argument")
+       ],
+     examples = [
+       mkEx "gt | l | ? wc  -- generate trees, linearize, and count words"
+       ]
+     }),
+  ("ut", emptyCommandInfo {
+     longname = "unicode_table",
+     synopsis = "show a transliteration table for a unicode character set",
+     exec = \opts _ -> do
+         let t = concatMap prOpt (take 1 opts)
+         let out = maybe "no such transliteration" characterTable $ transliteration t
+         return $ fromString out,
+     options = transliterationPrintNames
+     }),
+  ("wf", emptyCommandInfo {
+     longname = "write_file",
+     synopsis = "send string or tree to a file",
+     exec = \opts arg-> do
+         let file = valStrOpts "file" "_gftmp" opts
+         if isOpt "append" opts
+           then restricted $ appendFile file (toLines arg)
+           else restricted $ writeUTF8File file (toLines arg)
+         return void,
+     options = [
+       ("append","append to file, instead of overwriting it")
+       ],
+     flags = [("file","the output filename")]
+     })
+  ]
+ where
+   optComm opts = valStrOpts "command" "" opts
+
+   optTranslit opts = case (valStrOpts "to" "" opts, valStrOpts "from" "" opts) of
+     ("","")  -> return id
+     (file,"") -> do
+       src <- restricted $ readFile file
+       return $ transliterateWithFile file src False
+     (_,file) -> do
+       src <- restricted $ readFile file
+       return $ transliterateWithFile file src True
+
+stringOps menv opts s = foldr (menvop . app) s (reverse opts)
+  where
+    app f = maybe id id (stringOp (const False) f)
+    menvop op = maybe op (\ (b,e) -> opInEnv b e op) menv
+
+envFlag fs =
+  case valStrOpts "env" "global" fs of
+    "quotes" -> Just ("\"","\"")
+    _ -> Nothing
+
+stringOpOptions = sort $ [
+       ("chars","lexer that makes every non-space character a token"),
+       ("from_cp1251","decode from cp1251 (Cyrillic used in Bulgarian resource)"),
+       ("from_utf8","decode from utf8 (default)"),
+       ("lextext","text-like lexer"),
+       ("lexcode","code-like lexer"),
+       ("lexmixed","mixture of text and code, as in LaTeX (code between $...$, \\(...)\\, \\[...\\])"),
+       ("lexgreek","lexer normalizing ancient Greek accentuation"),
+       ("lexgreek2","lexer normalizing ancient Greek accentuation for text with vowel length annotations"),
+       ("to_cp1251","encode to cp1251 (Cyrillic used in Bulgarian resource)"),
+       ("to_html","wrap in a html file with linebreaks"),
+       ("to_utf8","encode to utf8 (default)"),
+       ("unlextext","text-like unlexer"),
+       ("unlexcode","code-like unlexer"),
+       ("unlexmixed","mixture of text and code (code between $...$, \\(...)\\, \\[...\\])"),
+       ("unchars","unlexer that puts no spaces between tokens"),
+       ("unlexgreek","unlexer de-normalizing ancient Greek accentuation"),
+       ("unwords","unlexer that puts a single space between tokens (default)"),
+       ("words","lexer that assumes tokens separated by spaces (default)")
+       ] ++
+      concat [
+       [("from_" ++ p, "from unicode to GF " ++ n ++ " transliteration"),
+        ("to_"   ++ p, "from GF " ++ n ++ " transliteration to unicode")] |
+                                    (p,n) <- transliterationPrintNames]
+
+-- ** Converting command input
+toString  = unwords . toStrings
+toLines = unlines . toStrings

src/compiler/api/GF/Command/Help.hs

@@ -0,0 +1,91 @@
+module GF.Command.Help where
+import GF.Command.Messages
+import GF.Command.Abstract(isOpt,getCommandOp)
+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
+
+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 args ->
+       let
+        msg = case toStrings args of
+          _ | isOpt "changes" opts -> changesMsg
+          _ | isOpt "coding" opts -> codingMsg
+          _ | isOpt "license" opts -> licenseMsg
+          [s] -> let co = getCommandOp s 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/api/GF/Command/Importing.hs

@@ -0,0 +1,95 @@
+module GF.Command.Importing (importGrammar, importSource) where
+
+import PGF2
+import PGF2.Transactions
+
+import GF.Compile
+import GF.Compile.Multi (readMulti)
+import GF.Compile.GetGrammar (getBNFCRules, getEBNFRules)
+import GF.Grammar (ModuleName,SourceGrammar) -- for cc command
+import GF.Grammar.BNFC
+import GF.Grammar.EBNF
+import GF.Grammar.CFG
+import GF.Compile.CFGtoPGF
+import GF.Infra.UseIO(die,tryIOE)
+import GF.Infra.Option
+import GF.Data.ErrM
+
+import System.FilePath
+import System.Directory
+import qualified Data.Set as Set
+import qualified Data.Map as Map
+import Control.Monad(foldM)
+import Control.Exception(catch,throwIO)
+
+-- import a grammar in an environment where it extends an existing grammar
+importGrammar :: (FilePath -> IO PGF) -> Maybe PGF -> Options -> [FilePath] -> IO (Maybe PGF)
+importGrammar readNGF pgf0 opts  _
+  | Just name <- flag optBlank opts = do
+        mb_ngf_file <- if snd (flag optLinkTargets opts)
+                         then do let fname = name <.> ".ngf"
+                                 putStr ("(Boot image "++fname++") ")
+                                 return (Just fname)
+                         else do return Nothing
+        pgf <- newNGF name mb_ngf_file 0
+        return (Just pgf)
+importGrammar readNGF pgf0 _    [] = return pgf0
+importGrammar readNGF pgf0 opts fs
+  | all (extensionIs ".cf")   fs = fmap Just $ importCF opts fs getBNFCRules bnfc2cf
+  | all (extensionIs ".ebnf") fs = fmap Just $ importCF opts fs getEBNFRules ebnf2cf
+  | all (extensionIs ".gfm")  fs = do
+        ascss <- mapM readMulti fs
+        let cs = concatMap snd ascss
+        importGrammar readNGF pgf0 opts cs
+  | all (\f -> extensionIs ".gf" f || extensionIs ".gfo" f) fs = do
+        res <- tryIOE $ compileToPGF opts pgf0 fs
+        case res of
+          Ok pgf  -> return (Just pgf)
+          Bad msg -> do putStrLn ('\n':'\n':msg)
+                        return pgf0
+  | all (extensionIs ".pgf") fs = foldM (importPGF opts) pgf0 fs
+  | all (extensionIs ".ngf") fs = do
+        case fs of
+          [f] -> fmap Just $ readNGF f
+          _   -> die $ "Only one .ngf file could be loaded at a time"
+  | otherwise =  die $ "Don't know what to do with these input files: " ++ unwords fs
+  where
+    extensionIs ext = (== ext) .  takeExtension
+
+importPGF :: Options -> Maybe PGF -> FilePath -> IO (Maybe PGF)
+importPGF opts Nothing    f
+  | snd (flag optLinkTargets opts) = do let f' = replaceExtension f ".ngf"
+                                        exists <- doesFileExist f'
+                                        if exists
+                                          then removeFile f'
+                                          else return ()
+                                        putStr ("(Boot image "++f'++") ")
+                                        mb_probs <- case flag optProbsFile opts of
+                                                      Nothing   -> return Nothing
+                                                      Just file -> fmap Just (readProbabilitiesFromFile file)
+                                        fmap Just (bootNGFWithProbs f mb_probs f')
+  | otherwise                      = do mb_probs <- case flag optProbsFile opts of
+                                                      Nothing   -> return Nothing
+                                                      Just file -> fmap Just (readProbabilitiesFromFile file)
+                                        fmap Just (readPGFWithProbs f mb_probs)
+importPGF opts (Just pgf) f        = fmap Just (modifyPGF pgf (mergePGF f) `catch`
+                                                (\e@(PGFError loc msg) ->
+                                                      if msg == "The abstract syntax names doesn't match"
+                                                        then do putStrLn (msg++", previous concretes discarded.")
+                                                                readPGF f
+                                                        else throwIO e))
+
+importSource :: Options -> [FilePath] -> IO (ModuleName,SourceGrammar)
+importSource opts files = fmap snd (batchCompile opts files)
+
+-- for different cf formats
+importCF opts files get convert = impCF
+  where
+    impCF = do
+      rules <- fmap (convert . concat) $ mapM (get opts) files
+      startCat <- case rules of
+                    (Rule cat _ _ : _) -> return cat
+                    _                  -> fail "empty CFG"
+      probs <- maybe (return Map.empty) readProbabilitiesFromFile (flag optProbsFile opts)
+      let pgf = cf2pgf opts (last files) (mkCFG startCat Set.empty rules) probs
+      return pgf

src/compiler/api/GF/Command/Interpreter.hs

@@ -0,0 +1,107 @@
+module GF.Command.Interpreter (
+  CommandEnv(..),mkCommandEnv,
+  interpretCommandLine,
+  getCommandOp
+  ) where
+import GF.Command.CommandInfo
+import GF.Command.Abstract
+import GF.Command.Parse
+import GF.Infra.UseIO(putStrLnE)
+import PGF2
+
+import Control.Monad(when)
+import qualified Data.Map as Map
+import GF.Infra.UseIO (Output)
+import qualified Control.Monad.Fail as Fail
+
+data CommandEnv m = CommandEnv {
+  commands      :: Map.Map String (CommandInfo m),
+  commandmacros :: Map.Map String CommandLine,
+  expmacros     :: Map.Map String Expr
+  }
+
+--mkCommandEnv :: PGFEnv -> CommandEnv
+mkCommandEnv cmds = CommandEnv cmds Map.empty Map.empty
+
+--interpretCommandLine :: CommandEnv -> String -> SIO ()
+interpretCommandLine :: (Fail.MonadFail m, Output m, TypeCheckArg m) => CommandEnv m -> String -> m ()
+interpretCommandLine env line =
+  case readCommandLine line of
+    Just []    -> return ()
+    Just pipes -> mapM_ (interpretPipe env) pipes
+    Nothing    -> putStrLnE $ "command not parsed: "++line
+
+interpretPipe env cs = do
+     Piped v@(_,s) <- intercs cs void
+     putStrLnE s
+     return ()
+  where
+   intercs [] args = return args
+   intercs (c:cs) (Piped (args,_)) = interc c args >>= intercs cs
+
+   interc comm@(Command co opts arg) args =
+     case co of
+       '%':f -> case Map.lookup f (commandmacros env) of
+         Just css ->
+           do args <- getCommandTrees env False arg args
+              mapM_ (interpretPipe env) (appLine args css)
+              return void
+         Nothing  -> do
+           putStrLnE $ "command macro " ++ co ++ " not interpreted"
+           return void
+       _ -> interpret env args comm
+
+   appLine = map . map . appCommand
+
+-- | macro definition applications: replace ?i by (exps !! i)
+appCommand :: CommandArguments -> Command -> Command
+appCommand args c@(Command i os arg) = case arg of
+  AExpr e -> Command i os (AExpr (exprSubstitute e (toExprs args)))
+  _       -> c
+
+-- | return the trees to be sent in pipe, and the output possibly printed
+--interpret :: CommandEnv -> [Expr] -> Command -> SIO CommandOutput
+interpret env trees comm = 
+  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
+--- 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)
+
+--getCommandInfo :: CommandEnv -> String -> Either String (CommandInfo PGFEnv)
+getCommandInfo env cmd = 
+  case Map.lookup (getCommandOp cmd) (commands env) of
+    Just info -> return info
+    Nothing   -> fail $ "command not found: " ++ cmd
+
+--checkOpts :: CommandInfo env -> [Option] -> Either String ()
+checkOpts info opts = 
+  case
+    [o | OOpt  o   <- opts, notElem o ("tr" : map fst (options info))] ++
+    [o | OFlag o _ <- opts, notElem o (map fst (flags info))]
+  of
+    []  -> return () 
+    [o] -> fail $ "option not interpreted: " ++ o
+    os  -> fail $ "options not interpreted: " ++ unwords os
+
+--getCommandTrees :: CommandEnv -> Bool -> Argument -> [Expr] -> Either String [Expr]
+getCommandTrees env needsTypeCheck a args =
+  case a of
+    AMacro m -> case Map.lookup m (expmacros env) of
+                  Just e -> one e
+                  _      -> return (Exprs []) -- report error?
+    AExpr e -> if needsTypeCheck
+               then one =<< typeCheckArg e
+               else one e
+    ATerm t -> return (Term t)
+    ANoArg  -> return args  -- use piped
+  where
+    one e = return (Exprs [(e,0)]) -- ignore piped

src/compiler/api/GF/Command/Messages.hs

@@ -0,0 +1,83 @@
+module GF.Command.Messages where
+
+import GF.Infra.BuildInfo(buildInfo)
+import Data.Version(showVersion)
+import Paths_gf(version)
+
+
+welcome = unlines [
+  "                              ",
+  "         *  *  *              ",
+  "      *           *           ",
+  "    *               *         ",
+  "   *                          ",
+  "   *                          ",
+  "   *        * * * * * *       ",
+  "   *        *         *       ",
+  "    *       * * * *  *        ",
+  "      *     *      *          ",
+  "         *  *  *              ",
+  "                              ",
+  "This is GF version "++showVersion version++". ",
+  buildInfo,
+  "License: see help -license.   "--,
+  -- Google Code is shutting down August 2015
+--"Bug reports: http://code.google.com/p/grammatical-framework/issues/list"
+  ]
+
+licenseMsg = unlines [
+ "Copyright (c)", 
+ "Krasimir Angelov, Bj\246rn Bringert, H\229kan Burden, Hans-Joachim Daniels,",
+ "Ramona Enache, Markus Forsberg, Thomas Hallgren, Harald Hammarstr\246m,",
+ "Kristofer Johannisson, Janna Khegai, Peter Ljungl\246f, Petri M\228enp\228\228, and", 
+ "Aarne Ranta, 1998-2010.",
+ "",
+ "The compiler is under GNU General Public License (GPL)",
+ "while all Haskell and most GF libraries that come with the distribution are",
+ "under dual GNU Lesser General Public License (LGPL) and BSD License,",
+ "see LICENSE in the GF source distribution for details."
+ ]
+
+codingMsg = unlines [
+  "The GF shell uses Unicode internally, but assumes user input to be UTF8",
+  "and converts terminal and file output to UTF8. If your terminal is not UTF8", 
+  "see 'help set_encoding."
+ ]
+
+changesMsg = unlines [
+  "While GF 3.0 is backward compatible with source grammars, the shell commands", 
+  "have changed from version 2.9. Below the most importand changes. Bug reports",
+  "and feature requests should be sent to http://trac.haskell.org/gf/.",
+  "",
+  "af     use wf -append",
+  "at     not supported",
+  "eh     not yet supported", 
+  "es     no longer supported; use javascript generation",
+  "g      not yet supported", 
+  "l      now by default multilingual",
+  "ml     not yet supported", 
+  "p      now by default multilingual",
+  "pi     not yet supported", 
+  "pl     not yet supported", 
+  "pm     subsumed to pg",
+  "po     not yet supported",
+  "pt     not yet supported", 
+  "r      not yet supported",
+  "rf     changed syntax",
+  "rl     not supported",
+  "s      no longer needed",
+  "sa     not supported",
+  "sf     not supported",
+  "si     not supported",
+  "so     not yet supported", 
+  "t      use pipe with l and p",
+  "tb     use l -treebank",
+  "tl     not yet supported", 
+  "tq     changed syntax",
+  "ts     not supported",
+  "tt     use ps",
+  "ut     not supported",
+  "vg     not yet supported",
+  "wf     changed syntax",
+  "wt     not supported"
+  ]

src/compiler/api/GF/Command/Parse.hs

@@ -0,0 +1,150 @@
+module GF.Command.Parse(readCommandLine, readTransactionCommand, pCommand) where
+
+import PGF(pExpr,pIdent)
+import PGF2(BindType(..),readType,readContext)
+import GF.Infra.Ident(identS)
+import GF.Grammar.Grammar(Term(Abs))
+import GF.Grammar.Parser(runPartial,pTerm)
+import GF.Command.Abstract
+
+import Data.Char(isDigit,isSpace)
+import Control.Monad(liftM2)
+import Text.ParserCombinators.ReadP
+
+readCommandLine :: String -> Maybe CommandLine
+readCommandLine s =
+    case [x | (x,cs) <- readP_to_S pCommandLine s, all isSpace cs] of
+      [x] -> Just x
+      _   -> Nothing
+
+pCommandLine =
+  (skipSpaces >> char '-' >> char '-' >> pTheRest >> return [])   -- comment
+  <++
+  (sepBy (skipSpaces >> pPipe) (skipSpaces >> char ';'))
+
+pPipe = sepBy1 (skipSpaces >> pCommand) (skipSpaces >> char '|')
+
+pCommand = (do
+  cmd  <- pIdent <++ (char '%' >> fmap ('%':) pIdent)
+  skipSpaces
+  opts <- sepBy pOption skipSpaces
+  arg  <- if getCommandOp cmd == "cc" then pArgTerm else pArgument
+  return (Command cmd opts arg)
+  )
+    <++ (do
+  char '?'
+  skipSpaces
+  c <- pSystemCommand
+  return (Command "sp" [OFlag "command" (LStr c)] ANoArg)
+  )
+
+readTransactionCommand :: String -> Maybe TransactionCommand
+readTransactionCommand s =
+    case [x | (x,cs) <- readP_to_S pTransactionCommand s, all isSpace cs] of
+      [x] -> Just x
+      _   -> Nothing
+
+pTransactionCommand = do
+  skipSpaces
+  cmd <- pIdent
+  skipSpaces
+  opts <- sepBy pOption skipSpaces
+  skipSpaces
+  kwd <- pIdent
+  skipSpaces
+  case kwd of
+    "fun" | take 1 cmd == "c" -> do
+               f <- pIdent
+               skipSpaces
+               char ':'
+               skipSpaces
+               ty <- readS_to_P (\s -> case readType s of
+                                         Just ty -> [(ty,"")]
+                                         Nothing -> [])
+               return (CreateFun opts f ty)
+          | take 1 cmd == "d" -> do
+                f <- pIdent
+                return (DropFun opts f)
+    "cat" | take 1 cmd == "c" -> do
+               c <- pIdent
+               skipSpaces
+               ctxt <- readS_to_P (\s -> case readContext s of
+                                           Just ty -> [(ty,"")]
+                                           Nothing -> [])
+               return (CreateCat opts c ctxt)
+          | take 1 cmd == "d" -> do
+                c <- pIdent
+                return (DropCat opts c)
+    "concrete"
+          | take 1 cmd == "c" -> do
+               name <- pIdent
+               return (CreateConcrete opts name)
+          | take 1 cmd == "d" -> do
+               name <- pIdent
+               return (DropConcrete opts name)
+    "lin" | elem (take 1 cmd) ["c","a"] -> do
+               f <- pIdent
+               skipSpaces
+               args <- sepBy pIdent skipSpaces
+               skipSpaces
+               char '='
+               skipSpaces
+               t  <- readS_to_P (\s -> case runPartial pTerm s of
+                                         Right (s,t) -> [(t,s)]
+                                         _ -> [])
+               return (CreateLin opts f (foldr (Abs Explicit . identS) t args) (take 1 cmd == "a"))
+          | take 1 cmd == "d" -> do
+                f <- pIdent
+                return (DropLin opts f)
+    "lincat"
+          | take 1 cmd == "c" -> do
+               f <- pIdent
+               skipSpaces
+               char '='
+               skipSpaces
+               t  <- readS_to_P (\s -> case runPartial pTerm s of
+                                         Right (s,t) -> [(t,s)]
+                                         _ -> [])
+               return (CreateLincat opts f t)
+          | take 1 cmd == "d" -> do
+                f <- pIdent
+                return (DropLincat opts f)
+    _     -> pfail
+
+pOption = do
+  char '-'
+  flg <- pIdent
+  option (OOpt flg) (fmap (OFlag flg) (char '=' >> pValue))
+
+pValue = do
+  fmap LInt (readS_to_P reads)
+  <++
+  fmap LFlt (readS_to_P reads)
+  <++
+  fmap LStr (readS_to_P reads)
+  <++
+  fmap LStr pFilename
+
+pFilename = liftM2 (:) (satisfy isFileFirst) (munch (not . isSpace)) where
+  isFileFirst c = not (isSpace c) && not (isDigit c)
+
+pArgument =
+  option ANoArg
+    (fmap AExpr pExpr
+              <++
+    (skipSpaces >> char '%' >> fmap AMacro pIdent))
+
+pArgTerm = ATerm `fmap` readS_to_P sTerm
+  where
+    sTerm s = case runPartial pTerm s of
+                Right (s,t) -> [(t,s)]
+                _ -> []
+
+pSystemCommand =
+    (char '"' >> (manyTill (pEsc <++ get) (char '"')))
+      <++
+    pTheRest
+  where
+    pEsc = char '\\' >> get
+
+pTheRest = munch (const True)

src/compiler/api/GF/Command/SourceCommands.hs

@@ -0,0 +1,282 @@
+-- | Commands requiring source grammar in env
+module GF.Command.SourceCommands(HasGrammar(..),sourceCommands) where
+
+import Prelude hiding (putStrLn)
+import qualified Prelude as P(putStrLn)
+import Data.List(nub,isInfixOf,isPrefixOf)
+import qualified Data.ByteString.UTF8 as UTF8(fromString)
+import qualified Data.Map as Map
+
+import GF.Infra.SIO(MonadSIO(..),restricted)
+import GF.Infra.Dependencies(depGraph)
+import GF.Infra.CheckM
+import GF.Text.Pretty(render,pp)
+import GF.Data.Str(sstr)
+import GF.Data.Operations (chunks,err,raise)
+
+import GF.Grammar hiding (Ident,isPrefixOf)
+import GF.Grammar.Analyse
+import GF.Grammar.Parser (runP, pExp)
+import GF.Grammar.ShowTerm
+import GF.Grammar.Lookup (allOpers,allOpersTo)
+import GF.Compile.Rename(renameSourceTerm)
+import GF.Compile.Compute.Concrete(normalForm)
+import GF.Compile.TypeCheck.Concrete as TC(inferLType,ppType)
+import GF.Compile.TypeCheck.Primitives(predefMod)
+
+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",
+     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 or -resource when importing the grammar,",
+       "if you want the definitions to be available 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"),
+       ("trace","trace computations")
+       ],
+     needsTypeCheck = False, -- why not True?
+     exec = withStrings compute_concrete
+     }),
+  ("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,
+     exec = withStrings dependency_graph
+     }),
+  ("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,
+     exec = withStrings show_deps
+     }),
+
+  ("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.",
+       "If no grammar is loaded with 'import -retain' or 'import -resource',",
+       "then only the predefined operations are in scope.",
+       "The operations include also 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)")
+       ],
+     examples = [
+         mkEx "so Det -- show all opers that create a Det",
+         mkEx "so -grep=Prep -- find opers relating to Prep",
+         mkEx "so | wf -file=/tmp/opers -- write the list of opers to a file"
+       ],
+     needsTypeCheck = False,
+     exec = withStrings show_operations
+     }),
+
+  ("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,
+     exec = withStrings show_source
+     })
+  ]
+  where
+    withStrings exec opts ts =
+      do sgr <- getGrammar
+         liftSIO (exec opts (toStrings ts) sgr)
+
+    compute_concrete opts ws sgr = fmap fst $ runCheck $
+      case runP pExp (UTF8.fromString s) of
+        Left (_,msg) -> return $ pipeMessage msg
+        Right t      -> do t <- checkComputeTerm opts sgr t
+                           return (fromString (showTerm sgr style q t))
+      where
+        (style,q) = pOpts TermPrintDefault Qualified opts
+        s = unwords ws
+
+        pOpts style q []     = (style,q)
+        pOpts style q (o:os) =
+          case o of
+            OOpt "table"   -> pOpts TermPrintTable   q           os
+            OOpt "all"     -> pOpts TermPrintAll     q           os
+            OOpt "list"    -> pOpts TermPrintList    q           os
+            OOpt "one"     -> pOpts TermPrintOne     q           os
+            OOpt "default" -> pOpts TermPrintDefault q           os
+            OOpt "unqual"  -> pOpts style            Unqualified os
+            OOpt "qual"    -> pOpts style            Qualified   os
+            _              -> pOpts style            q           os
+
+    show_deps os xs sgr = do
+          ops <- case xs of
+             _:_ -> do
+               let ts = [t | Right t <- map (runP pExp . UTF8.fromString) xs]
+               err error (return . nub . concat) $ mapM (constantDepsTerm sgr) ts
+             _   -> error "expected one or more qualified constants as argument"
+          let prTerm = showTerm sgr TermPrintDefault Qualified
+          let size = sizeConstant sgr
+          let printed
+                | isOpt "size" os =
+                    let sz = map size ops in
+                    unlines $ ("total: " ++ show (sum sz)) :
+                              [prTerm f ++ "\t" ++ show s | (f,s) <- zip ops sz]
+                | otherwise = unwords $ map prTerm ops
+          return $ fromString printed
+
+    show_operations os ts sgr0 = fmap fst $ runCheck $ do
+      let (sgr,mo) = case greatestResource sgr0 of
+                       Nothing -> (mGrammar [predefMod], fst predefMod)
+                       Just mo -> (sgr0,mo)
+          greps = map valueString (listFlags "grep" os)
+      ops <- case ts of
+               _:_ -> do let Right t = runP pExp (UTF8.fromString (unwords ts))
+                         ty <- checkComputeTerm os sgr t
+                         return $ allOpersTo sgr ty
+               _   -> return $ allOpers sgr
+      let sigs = [(op,ty) | ((mo,op),ty,pos) <- ops]
+          printer = showTerm sgr TermPrintDefault
+                             (if isOpt "raw" os then Qualified else Unqualified)
+          printed = [unwords [showIdent op, ":", printer ty] | (op,ty) <- sigs]
+      return . fromString $ unlines [l | l <- printed, all (`isInfixOf` l) greps]
+
+    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]
+            [] -> sgr
+      case () of
+        _ | isOpt "detailedsize" os ->
+               return . fromString $ printSizesGrammar mygr
+        _ | isOpt "size" os -> do
+               let sz = sizesGrammar mygr
+               return . fromStrings $
+                 ("total\t" ++ show (fst sz)):
+                 [render j ++ "\t" ++ show (fst k) | (j,k) <- snd sz]
+        _ | isOpt "save" os ->
+              do mapM_ saveModule (modules mygr)
+                 return void
+              where
+                saveModule m@(i,_) =
+                  let file = (render i ++ ".gfh")
+                  in restricted $
+                        do writeFile file (render (ppModule Qualified m))
+                           P.putStrLn ("wrote " ++ file)
+
+        _ -> return . fromString $ render mygr
+
+    dependency_graph opts ws sgr =
+      do let stop = case valStrOpts "only" "" opts of
+                      "" -> Nothing
+                      fs -> Just $ chunks ',' fs
+         restricted $
+            do writeFile "_gfdepgraph.dot" (depGraph stop sgr)
+               P.putStrLn "wrote graph in file _gfdepgraph.dot"
+         return void
+
+checkComputeTerm os sgr0 t =
+  do let (sgr,mo) = case greatestResource sgr0 of
+                      Nothing -> (mGrammar [predefMod], fst predefMod)
+                      Just mo -> (sgr0,mo)
+     t <- renameSourceTerm sgr mo t
+     (t,_) <- inferLType sgr [] t
+     fmap evalStr (normalForm sgr t)
+  where
+    -- ** Try to compute pre{...} tokens in token sequences
+    evalStr t =
+      case t of
+        C t1 t2 -> foldr1 C (evalC [t])
+        _ -> composSafeOp evalStr t
+
+    evalC (C t1 t2:ts) = evalC (t1:t2:ts)
+    evalC (t1@(Alts t tts):ts) = case evalC ts of
+                              K s:ts' -> matchPrefix t tts s:K s:ts'
+                              ts' -> evalStr t1:ts'
+    evalC (t:ts) = evalStr t:evalC ts
+    evalC [] = []
+
+    matchPrefix t0 tts0 s = foldr match1 t tts
+      where
+        alts@(Alts t tts) = evalStr (Alts t0 tts0)
+
+        match1 (u,a) r = err (const alts) ok (strsFromTerm a)
+          where ok as = if any (`isPrefixOf` s) (map sstr as)
+                        then u
+                        else r

src/compiler/api/GF/Command/TreeOperations.hs

@@ -0,0 +1,39 @@
+module GF.Command.TreeOperations (
+  treeOp,
+  allTreeOps,
+  ) where
+
+import PGF2(Expr,PGF,Fun,compute,mkApp,unApp,unMeta,exprSize,exprFunctions)
+import Data.List
+
+type TreeOp = [Expr] -> [Expr]
+
+treeOp :: PGF -> String -> Maybe (Either TreeOp (Fun -> TreeOp))
+treeOp pgf f = fmap snd $ lookup f $ allTreeOps pgf
+
+allTreeOps :: PGF -> [(String,(String,Either TreeOp (Fun -> TreeOp)))]
+allTreeOps pgf = [
+   ("compute",("compute by using semantic definitions (def)",
+      Left  $ map (compute pgf))),
+   ("largest",("sort trees from largest to smallest, in number of nodes",
+      Left  $ largest)),
+   ("nub",("remove duplicate trees",
+      Left  $ nub)),
+   ("smallest",("sort trees from smallest to largest, in number of nodes",
+      Left  $ smallest)),
+   ("subtrees",("return all fully applied subtrees (stopping at abstractions), by default sorted from the largest",
+      Left  $ concatMap subtrees)),
+   ("funs",("return all fun functions appearing in the tree, with duplications",
+      Left  $ \es -> [mkApp f [] | e <- es, f <- exprFunctions e]))
+  ]
+
+largest :: [Expr] -> [Expr]
+largest = reverse . smallest
+
+smallest :: [Expr] -> [Expr]
+smallest = sortBy (\t u -> compare (exprSize t) (exprSize u))
+
+subtrees :: Expr -> [Expr]
+subtrees t = t : case unApp t of
+  Just (f,ts) -> concatMap subtrees ts
+  _ -> []  -- don't go under abstractions