From 97c6ffd462522ea78a26ec7de68238d4e64d025b Mon Sep 17 00:00:00 2001 From: hallgren Date: Mon, 10 Aug 2015 13:01:02 +0000 Subject: [PATCH] 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 | 2 + src/compiler/GF/Command/Abstract.hs | 4 +- src/compiler/GF/Command/CommandInfo.hs | 57 +++++++++ src/compiler/GF/Command/Commands.hs | 158 ++----------------------- src/compiler/GF/Command/Help.hs | 93 +++++++++++++++ src/compiler/GF/Command/Interpreter.hs | 59 ++++----- src/compiler/GF/Interactive.hs | 19 +-- 7 files changed, 204 insertions(+), 188 deletions(-) create mode 100644 src/compiler/GF/Command/CommandInfo.hs create mode 100644 src/compiler/GF/Command/Help.hs diff --git a/gf.cabal b/gf.cabal index eb764690e..ad2cae07e 100644 --- a/gf.cabal +++ b/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 diff --git a/src/compiler/GF/Command/Abstract.hs b/src/compiler/GF/Command/Abstract.hs index 8b7b824f0..5035a33d3 100644 --- a/src/compiler/GF/Command/Abstract.hs +++ b/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 diff --git a/src/compiler/GF/Command/CommandInfo.hs b/src/compiler/GF/Command/CommandInfo.hs new file mode 100644 index 000000000..bffb452ce --- /dev/null +++ b/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 diff --git a/src/compiler/GF/Command/Commands.hs b/src/compiler/GF/Command/Commands.hs index 1255b3517..76ccff365 100644 --- a/src/compiler/GF/Command/Commands.hs +++ b/src/compiler/GF/Command/Commands.hs @@ -1,21 +1,14 @@ -{-# LANGUAGE PatternGuards #-} +{-# LANGUAGE PatternGuards, TypeSynonymInstances, FlexibleInstances #-} module GF.Command.Commands ( - allCommands, - lookCommand, - exec, - isOpt, - options, - flags, - needsTypeCheck, - CommandInfo, - CommandOutput(..),void + PGFEnv,pgfEnv,allCommands, + options,flags, ) 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 { - exec :: PGFEnv -> [Option] -> [Expr] -> SIO CommandOutput, - synopsis :: String, - syntax :: String, - explanation :: String, - longname :: String, - options :: [(String,String)], - flags :: [(String,String)], - examples :: [(String,String)], - needsTypeCheck :: Bool - } +pgfEnv pgf = (pgf,mos) + where mos = Map.fromList [(la,buildMorpho pgf la) | la <- languages pgf] --------------------------------------------------------------------------------- -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 $ 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)) +instance TypeCheckArg PGFEnv where + typeCheckArg (pgf,_) = either (Left . ppTcError) (Right . fst) . inferExpr pgf -- 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 { - 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 - }), + helpCommand allCommands, ("i", emptyCommandInfo { longname = "import", synopsis = "import a grammar from source code or compiled .pgf file", diff --git a/src/compiler/GF/Command/Help.hs b/src/compiler/GF/Command/Help.hs new file mode 100644 index 000000000..a1a6c0aaf --- /dev/null +++ b/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 + }) diff --git a/src/compiler/GF/Command/Interpreter.hs b/src/compiler/GF/Command/Interpreter.hs index 3b0f77ace..8650b4002 100644 --- a/src/compiler/GF/Command/Interpreter.hs +++ b/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.Internal +--import PGF +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 { - multigrammar :: PGF, - morphos :: Map.Map Language Morpho, ---commands :: Map.Map String CommandInfo, +data CommandEnv env = CommandEnv { + pgfenv :: env, + commands :: Map.Map String (CommandInfo env), commandmacros :: Map.Map String CommandLine, expmacros :: Map.Map String Expr } -commands _ = allCommands -mkCommandEnv :: PGF -> CommandEnv -mkCommandEnv pgf = - let mos = Map.fromList [(la,buildMorpho pgf la) | la <- languages pgf] in - CommandEnv pgf mos {-allCommands-} Map.empty Map.empty +--mkCommandEnv :: PGFEnv -> CommandEnv +mkCommandEnv env cmds = CommandEnv env cmds Map.empty Map.empty -emptyCommandEnv :: CommandEnv -emptyCommandEnv = mkCommandEnv emptyPGF - -interpretCommandLine :: CommandEnv -> String -> SIO () +--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 - Left tcErr -> fail $ render (ppTcError tcErr) - Right (e,ty) -> return [e] -- ignore piped + then case typeCheckArg (pgfenv env) e of + Left tcErr -> fail $ render tcErr + Right e -> return [e] -- ignore piped else return [e] ANoArg -> return es -- use piped diff --git a/src/compiler/GF/Interactive.hs b/src/compiler/GF/Interactive.hs index 153e699f5..a404e0567 100644 --- a/src/compiler/GF/Interactive.hs +++ b/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 = - GFEnv emptyGrammar False (mkCommandEnv emptyPGF) [] {-0-} +emptyGFEnv = GFEnv emptyGrammar False emptyCommandEnv [] {-0-} + +commandEnv pgf = mkCommandEnv (pgfEnv pgf) allCommands +emptyCommandEnv = commandEnv emptyPGF +multigrammar = fst . pgfenv wordCompletion gfenv (left,right) = do case wc_type (reverse left) of