summaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
Diffstat (limited to 'src')
-rw-r--r--src/compiler/GF/Command/Abstract.hs4
-rw-r--r--src/compiler/GF/Command/CommandInfo.hs57
-rw-r--r--src/compiler/GF/Command/Commands.hs158
-rw-r--r--src/compiler/GF/Command/Help.hs93
-rw-r--r--src/compiler/GF/Command/Interpreter.hs59
-rw-r--r--src/compiler/GF/Interactive.hs19
6 files changed, 202 insertions, 188 deletions
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
- }
-
---------------------------------------------------------------------------------
-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
+pgfEnv pgf = (pgf,mos)
+ where mos = Map.fromList [(la,buildMorpho pgf la) | la <- languages pgf]
-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
generated by cgit v1.2.3 (git 2.39.1) at 2026-05-20 06:43:53 +0000