GitHub/gf-core
1
0
Fork 1
mirror of https://github.com/GrammaticalFramework/gf-core.git synced 2026-04-09 04:59:31 -06:00
Code Issues Packages Projects Releases Wiki Activity

GF Shell: refactoring for improved modularity and reusability:

Browse Source 
+ Generalize the CommandInfo type by parameterizing it on the monad
  instead of just the environment.
+ Generalize the commands defined in
  GF.Command.{Commands,Commands2,CommonCommands,SourceCommands,HelpCommand}
  to work in any monad that supports the needed operations.
+ Liberate GF.Command.Interpreter from the IO monad.
  Also, move the current PGF from CommandEnv to GFEnv in
  GF.Interactive, making the command interpreter even more generic.
+ Use a state monad to maintain the state of the interpreter in
  GF.{Interactive,Interactive2}.
This commit is contained in:
hallgren
2015-08-13 10:49:50 +00:00
parent d860a921e0
commit 87e64a804c
13 changed files with 441 additions and 481 deletions
Download Patch File Download Diff File Expand all files Collapse all files

17
src/compiler/GF/Command/CommandInfo.hs
View File

@@ -1,12 +1,10 @@
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,
data CommandInfo m = CommandInfo {
exec :: [Option] -> [Expr] -> m CommandOutput,
synopsis :: String,
syntax :: String,
explanation :: String,
@@ -17,11 +15,11 @@ data CommandInfo env = CommandInfo {
needsTypeCheck :: Bool
}
mapCommandEnv f c = c { exec = exec c . f }
mapCommandExec f c = c { exec = \ opts ts -> f (exec c opts ts) }
emptyCommandInfo :: CommandInfo env
--emptyCommandInfo :: CommandInfo env
emptyCommandInfo = CommandInfo {
exec = \_ _ ts -> return $ pipeExprs ts, ----
exec = error "command not implemented",
synopsis = "",
syntax = "",
explanation = "",
@@ -33,10 +31,7 @@ emptyCommandInfo = CommandInfo {
}
--------------------------------------------------------------------------------
class TypeCheckArg env where typeCheckArg :: env -> Expr -> Either Doc Expr
instance TypeCheckArg env => TypeCheckArg (x,env) where
typeCheckArg (x,env) = typeCheckArg env
class Monad m => TypeCheckArg m where typeCheckArg :: Expr -> m Expr
--------------------------------------------------------------------------------

75
src/compiler/GF/Command/Commands.hs
View File

@@ -1,5 +1,6 @@
{-# LANGUAGE FlexibleInstances, UndecidableInstances #-}
module GF.Command.Commands (
PGFEnv,pgf,mos,pgfEnv,pgfCommands,
PGFEnv,HasPGFEnv(..),pgf,mos,pgfEnv,pgfCommands,
options,flags,
) where
import Prelude hiding (putStrLn)
@@ -8,11 +9,7 @@ import PGF
import PGF.Internal(lookStartCat,functionsToCat,lookValCat,restrictPGF,hasLin)
import PGF.Internal(abstract,funs,cats,Expr(EFun)) ----
--import PGF.Morphology(isInMorpho,morphoKnown)
import PGF.Internal(ppFun,ppCat)
--import PGF.Probabilistic(rankTreesByProbs,probTree,setProbabilities)
--import PGF.Generate (generateRandomFrom) ----
--import PGF.Tree (Tree(Fun), expr2tree, tree2expr)
import PGF.Internal(optimizePGF)
import GF.Compile.Export
@@ -21,14 +18,10 @@ import GF.Compile.ExampleBased
import GF.Infra.Option (noOptions, readOutputFormat, outputFormatsExpl)
import GF.Infra.UseIO(writeUTF8File)
import GF.Infra.SIO
--import GF.Data.ErrM ----
import GF.Command.Abstract
--import GF.Command.Messages
import GF.Command.CommandInfo
import GF.Command.CommonCommands
--import GF.Text.Lexing
import GF.Text.Clitics
--import GF.Text.Transliterations
import GF.Quiz
import GF.Command.TreeOperations ---- temporary place for typecheck and compute
@@ -39,12 +32,9 @@ import PGF.Internal (encodeFile)
import Data.List(intersperse,nub)
import Data.Maybe
import qualified Data.Map as Map
--import System.Cmd(system) -- use GF.Infra.UseIO.restricedSystem instead!
--import GF.System.Process
import GF.Text.Pretty
import Data.List (sort)
--import Debug.Trace
--import System.Random (newStdGen) ----
data PGFEnv = Env {pgf::PGF,mos::Map.Map Language Morpho}
@@ -52,10 +42,13 @@ data PGFEnv = Env {pgf::PGF,mos::Map.Map Language Morpho}
pgfEnv pgf = Env pgf mos
where mos = Map.fromList [(la,buildMorpho pgf la) | la <- languages pgf]
instance TypeCheckArg PGFEnv where
typeCheckArg (Env pgf _) = either (Left . ppTcError) (Right . fst) . inferExpr pgf
class (Functor m,Monad m,MonadSIO m) => HasPGFEnv m where getPGFEnv :: m PGFEnv
pgfCommands :: Map.Map String (CommandInfo PGFEnv)
instance HasPGFEnv m => TypeCheckArg m where
typeCheckArg e = (either (fail . render . ppTcError) (return . fst)
. flip inferExpr e . pgf) =<< getPGFEnv
pgfCommands :: HasPGFEnv m => Map.Map String (CommandInfo m)
pgfCommands = Map.fromList [
("aw", emptyCommandInfo {
longname = "align_words",
@@ -68,7 +61,7 @@ pgfCommands = Map.fromList [
"by the flag. The target format is postscript, unless overridden by the",
"flag -format."
],
exec = \ (Env pgf mos) opts es -> do
exec = getEnv $ \ opts es (Env pgf mos) -> do
let langs = optLangs pgf opts
if isOpt "giza" opts
then do
@@ -115,16 +108,16 @@ pgfCommands = Map.fromList [
"by the flag '-clitics'. The list of stems is given as the list of words",
"of the language given by the '-lang' flag."
],
exec = \env opts -> case opts of
exec = getEnv $ \opts ts env -> case opts of
_ | isOpt "raw" opts ->
return . fromString .
unlines . map (unwords . map (concat . intersperse "+")) .
map (getClitics (isInMorpho (optMorpho env opts)) (optClitics opts)) .
concatMap words . toStrings
concatMap words $ toStrings ts
_ ->
return . fromStrings .
getCliticsText (isInMorpho (optMorpho env opts)) (optClitics opts) .
concatMap words . toStrings,
concatMap words $ toStrings ts,
flags = [
("clitics","the list of possible clitics (comma-separated, no spaces)"),
("lang", "the language of analysis")
@@ -159,7 +152,7 @@ pgfCommands = Map.fromList [
("lang","the language in which to parse"),
("probs","file with probabilities to rank the parses")
],
exec = \ env@(Env pgf mos) opts _ -> do
exec = getEnv $ \ opts _ env@(Env pgf mos) -> do
let file = optFile opts
pgf <- optProbs opts pgf
let printer = if (isOpt "api" opts) then exprToAPI else (showExpr [])
@@ -193,7 +186,7 @@ pgfCommands = Map.fromList [
("depth","the maximum generation depth"),
("probs", "file with biased probabilities (format 'f 0.4' one by line)")
],
exec = \ (Env pgf mos) opts xs -> do
exec = getEnv $ \ opts xs (Env pgf mos) -> do
pgf <- optProbs opts (optRestricted opts pgf)
gen <- newStdGen
let dp = valIntOpts "depth" 4 opts
@@ -223,7 +216,7 @@ pgfCommands = Map.fromList [
mkEx "gt -cat=NP -depth=2 -- trees in the category NP to depth 2",
mkEx "gt (AdjCN ? (UseN ?)) -- trees of form (AdjCN ? (UseN ?))"
],
exec = \ (Env pgf mos) opts xs -> do
exec = getEnv $ \ opts xs (Env pgf mos) -> do
let pgfr = optRestricted opts pgf
let dp = valIntOpts "depth" 4 opts
let ts = case mexp xs of
@@ -277,7 +270,7 @@ pgfCommands = Map.fromList [
mkEx "gr -lang=LangHin -cat=Cl | l -table -to_devanagari -- hindi table",
mkEx "l -unlexer=\"LangAra=to_arabic LangHin=to_devanagari\" -- different unlexers"
],
exec = \ (Env pgf mos) opts -> return . fromStrings . optLins pgf opts,
exec = getEnv $ \ opts ts (Env pgf mos) -> return . fromStrings $ optLins pgf opts ts,
options = [
("all", "show all forms and variants, one by line (cf. l -list)"),
("bracket","show tree structure with brackets and paths to nodes"),
@@ -302,7 +295,7 @@ pgfCommands = Map.fromList [
examples = [
mkEx "l -lang=LangSwe,LangNor -chunks ? a b (? c d)"
],
exec = \ (Env pgf mos) opts -> return . fromStrings . optLins pgf (opts ++ [OOpt "chunks"]),
exec = getEnv $ \ opts ts (Env pgf mos) -> return . fromStrings $ optLins pgf (opts ++ [OOpt "chunks"]) ts,
options = [
("treebank","show the tree and tag linearizations with language names")
] ++ stringOpOptions,
@@ -318,18 +311,18 @@ pgfCommands = Map.fromList [
"Prints all the analyses of space-separated words in the input string,",
"using the morphological analyser of the actual grammar (see command pg)"
],
exec = \env opts -> case opts of
exec = getEnv $ \opts ts env -> case opts of
_ | isOpt "missing" opts ->
return . fromString . unwords .
morphoMissing (optMorpho env opts) .
concatMap words . toStrings
concatMap words $ toStrings ts
_ | isOpt "known" opts ->
return . fromString . unwords .
morphoKnown (optMorpho env opts) .
concatMap words . toStrings
concatMap words $ toStrings ts
_ -> return . fromString . unlines .
map prMorphoAnalysis . concatMap (morphos env opts) .
concatMap words . toStrings ,
concatMap words $ toStrings ts,
flags = [
("lang","the languages of analysis (comma-separated, no spaces)")
],
@@ -343,7 +336,7 @@ pgfCommands = Map.fromList [
longname = "morpho_quiz",
synopsis = "start a morphology quiz",
syntax = "mq (-cat=CAT)? (-probs=FILE)? TREE?",
exec = \ (Env pgf mos) opts xs -> do
exec = getEnv $ \ opts xs (Env pgf mos) -> do
let lang = optLang pgf opts
let typ = optType pgf opts
pgf <- optProbs opts pgf
@@ -371,7 +364,7 @@ pgfCommands = Map.fromList [
"the parser. For example if -openclass=\"A,N,V\" is given, the parser",
"will accept unknown adjectives, nouns and verbs with the resource grammar."
],
exec = \ (Env pgf mos) opts ts ->
exec = getEnv $ \ opts ts (Env pgf mos) ->
return . Piped $ fromParse opts (concat [map ((,) s) (par pgf opts s) | s <- toStrings ts]),
flags = [
("cat","target category of parsing"),
@@ -402,7 +395,7 @@ pgfCommands = Map.fromList [
" " ++ opt ++ "\t\t" ++ expl |
((opt,_),expl) <- outputFormatsExpl, take 1 expl /= "*"
]),
exec = \env opts _ -> prGrammar env opts,
exec = getEnv $ \opts _ env -> prGrammar env opts,
flags = [
--"cat",
("file", "set the file name when printing with -pgf option"),
@@ -438,8 +431,8 @@ pgfCommands = Map.fromList [
mkEx "pt -compute (plus one two) -- compute value",
mkEx "p \"4 dogs love 5 cats\" | pt -transfer=digits2numeral | l -- four...five..."
],
exec = \ (Env pgf mos) opts ->
returnFromExprs . takeOptNum opts . treeOps pgf opts,
exec = getEnv $ \ opts ts (Env pgf mos) ->
returnFromExprs . takeOptNum opts $ treeOps pgf opts ts,
options = treeOpOptions undefined{-pgf-},
flags = [("number","take at most this many trees")] ++ treeOpFlags undefined{-pgf-}
}),
@@ -457,7 +450,7 @@ pgfCommands = Map.fromList [
("lines","return the list of lines, instead of the singleton of all contents"),
("tree","convert strings into trees")
],
exec = \ (Env pgf mos) opts _ -> do
exec = getEnv $ \ opts _ (Env pgf mos) -> do
let file = valStrOpts "file" "_gftmp" opts
let exprs [] = ([],empty)
exprs ((n,s):ls) | null s
@@ -492,7 +485,7 @@ pgfCommands = Map.fromList [
"by the file given by flag -probs=FILE, where each line has the form",
"'function probability', e.g. 'youPol_Pron 0.01'."
],
exec = \ (Env pgf mos) opts ts -> do
exec = getEnv $ \ opts ts (Env pgf mos) -> do
pgf <- optProbs opts pgf
let tds = rankTreesByProbs pgf ts
if isOpt "v" opts
@@ -514,7 +507,7 @@ pgfCommands = Map.fromList [
longname = "translation_quiz",
syntax = "tq -from=LANG -to=LANG (-cat=CAT)? (-probs=FILE)? TREE?",
synopsis = "start a translation quiz",
exec = \ (Env pgf mos) opts xs -> do
exec = getEnv $ \ opts xs (Env pgf mos) -> do
let from = optLangFlag "from" pgf opts
let to = optLangFlag "to" pgf opts
let typ = optType pgf opts
@@ -551,7 +544,7 @@ pgfCommands = Map.fromList [
"by the flag. The target format is png, unless overridden by the",
"flag -format."
],
exec = \ (Env pgf mos) opts es -> do
exec = getEnv $ \ opts es (Env pgf mos) -> do
let debug = isOpt "v" opts
let file = valStrOpts "file" "" opts
let outp = valStrOpts "output" "dot" opts
@@ -599,7 +592,7 @@ pgfCommands = Map.fromList [
"by the flag. The target format is png, unless overridden by the",
"flag -format."
],
exec = \ (Env pgf mos) opts es -> do
exec = getEnv $ \ opts es (Env pgf mos) -> do
let lang = optLang pgf opts
let gvOptions = GraphvizOptions {noLeaves = isOpt "noleaves" opts && not (isOpt "showleaves" opts),
noFun = isOpt "nofun" opts || not (isOpt "showfun" opts),
@@ -660,7 +653,7 @@ pgfCommands = Map.fromList [
"flag -format.",
"With option -mk, use for showing library style function names of form 'mkC'."
],
exec = \ (Env pgf mos) opts es ->
exec = getEnv $ \ opts es (Env pgf mos) ->
if isOpt "mk" opts
then return $ fromString $ unlines $ map (tree2mk pgf) es
else if isOpt "api" opts
@@ -708,7 +701,7 @@ pgfCommands = Map.fromList [
"If a whole expression is given it prints the expression with refined",
"metavariables and the type of the expression."
],
exec = \ (Env pgf mos) opts arg -> do
exec = getEnv $ \ opts arg (Env pgf mos) -> do
case arg of
[EFun id] -> case Map.lookup id (funs (abstract pgf)) of
Just fd -> do putStrLn $ render (ppFun id fd)
@@ -740,6 +733,8 @@ pgfCommands = Map.fromList [
})
]
where
getEnv exec opts ts = liftSIO . exec opts ts =<< getPGFEnv
par pgf opts s = case optOpenTypes opts of
[] -> [parse_ pgf lang (optType pgf opts) (Just dp) s | lang <- optLangs pgf opts]
open_typs -> [parseWithRecovery pgf lang (optType pgf opts) open_typs (Just dp) s | lang <- optLangs pgf opts]

155
src/compiler/GF/Command/Commands2.hs
View File

@@ -1,5 +1,6 @@
{-# LANGUAGE FlexibleInstances, UndecidableInstances #-}
module GF.Command.Commands2 (
PGFEnv,pgf,concs,pgfEnv,emptyPGFEnv,allCommands,
PGFEnv,HasPGFEnv(..),pgf,concs,pgfEnv,emptyPGFEnv,pgfCommands,
options, flags,
) where
import Prelude hiding (putStrLn)
@@ -19,13 +20,11 @@ import qualified PGF as H
--import GF.Compile.ExampleBased
--import GF.Infra.Option (noOptions, readOutputFormat, outputFormatsExpl)
--import GF.Infra.UseIO(writeUTF8File)
--import GF.Infra.SIO
import GF.Infra.SIO(MonadSIO,liftSIO)
--import GF.Data.ErrM ----
import GF.Command.Abstract
--import GF.Command.Messages
import GF.Command.CommandInfo
import GF.Command.Help
import GF.Command.CommonCommands
--import GF.Text.Lexing
--import GF.Text.Clitics
--import GF.Text.Transliterations
@@ -53,12 +52,13 @@ data PGFEnv = Env {pgf::Maybe C.PGF,concs::Map.Map C.ConcName C.Concr}
pgfEnv pgf = Env (Just pgf) (C.languages pgf)
emptyPGFEnv = Env Nothing Map.empty
instance TypeCheckArg PGFEnv where
typeCheckArg env e = Right e -- no type checker available !!
class (Monad m,MonadSIO m) => HasPGFEnv m where getPGFEnv :: m PGFEnv
instance Monad m => TypeCheckArg m where
typeCheckArg = return -- no type checker available !!
allCommands :: Map.Map String (CommandInfo PGFEnv)
allCommands = extend commonCommands [
pgfCommands :: HasPGFEnv m => Map.Map String (CommandInfo m)
pgfCommands = Map.fromList [
{-
("aw", emptyCommandInfo {
longname = "align_words",
@@ -140,57 +140,6 @@ allCommands = extend commonCommands [
mkEx "ca -lang=Fin -clitics=ko,ni \"nukkuuko minun vaimoni\" | p -- to parse Finnish"
]
}),
("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 when importing the grammar, if you want",
"the definitions to be retained 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")
],
needsTypeCheck = False
}),
-}
{-
("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
}),
-}
{-
("eb", emptyCommandInfo {
@@ -269,7 +218,7 @@ allCommands = extend commonCommands [
examples = [
mkEx "ga -- all trees in the startcat",
mkEx "ga -cat=NP -number=16 -- 16 trees in the category NP"],
exec = needPGF $ \ env@(pgf,_) opts _ ->
exec = needPGF $ \ opts _ env@(pgf,_) ->
let ts = map fst (C.generateAll pgf cat)
cat = optCat pgf opts
in returnFromCExprs (takeOptNum opts ts),
@@ -306,7 +255,6 @@ allCommands = extend commonCommands [
returnFromExprs $ take (optNumInf opts) ts
}),
-}
helpCommand allCommands,
("i", emptyCommandInfo {
longname = "import",
synopsis = "import a grammar from a compiled .pgf file",
@@ -346,8 +294,8 @@ allCommands = extend commonCommands [
],
examples = [
mkEx "l -lang=LangSwe,LangNor no_Utt -- linearize tree to LangSwe and LangNor"],
exec = needPGF $ \ env opts ->
return . fromStrings . cLins env opts . map cExpr
exec = needPGF $ \ opts ts env ->
return . fromStrings . cLins env opts $ map cExpr ts
}),
{-
("l", emptyCommandInfo {
@@ -470,7 +418,7 @@ allCommands = extend commonCommands [
examples = [
mkEx "p \"this fish is fresh\" | l -lang=Swe -- try parsing with all languages and translate the successful parses to Swedish"
],
exec = needPGF $ \ env opts -> return . cParse env opts . toStrings
exec = needPGF $ \ opts ts env -> return . cParse env opts $ toStrings ts
})
{-
("p", emptyCommandInfo {
@@ -657,76 +605,6 @@ allCommands = extend commonCommands [
mkEx ("tq -from=Eng -to=Swe (AdjCN (PositA ?2) (UseN ?)) -- only trees of this form")
]
}),
("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
}),
-}
{-
("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.",
"This command requires a source grammar to be in scope, imported with 'import -retain'.",
"The operations include 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)")
],
needsTypeCheck = False
}),
("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
}),
-}
{-
("vd", emptyCommandInfo {
longname = "visualize_dependency",
synopsis = "show word dependency tree graphically",
@@ -1205,7 +1083,8 @@ cExpr e =
Just (f,es) -> C.mkApp (H.showCId f) (map cExpr es)
_ -> error "GF.Command.Commands2.cExpr"
needPGF exec (Env mb_pgf cncs) opts ts =
case mb_pgf of
Just pgf -> exec (pgf,cncs) opts ts
_ -> fail "Import a grammar before using this command"
needPGF exec opts ts =
do Env mb_pgf cncs <- getPGFEnv
case mb_pgf of
Just pgf -> liftSIO $ exec opts ts (pgf,cncs)
_ -> fail "Import a grammar before using this command"

16
src/compiler/GF/Command/CommonCommands.hs
View File

@@ -19,8 +19,8 @@ import qualified PGF as H(showCId,showExpr,toATree,toTrie,Trie(..))
extend old new = Map.union (Map.fromList new) old -- Map.union is left-biased
commonCommands :: Map.Map String (CommandInfo env)
commonCommands = Map.fromList [
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",
@@ -104,7 +104,7 @@ commonCommands = Map.fromList [
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"
],
exec = \_ opts x -> do
exec = \opts x-> do
let (os,fs) = optsAndFlags opts
trans <- optTranslit opts
@@ -139,7 +139,7 @@ commonCommands = Map.fromList [
mkEx "se utf8 -- set encoding to utf8 (default)"
],
needsTypeCheck = False,
exec = \ _ opts ts ->
exec = \ opts ts ->
case words (toString ts) of
[c] -> do let cod = renameEncoding c
restricted $ changeConsoleEncoding cod
@@ -150,7 +150,7 @@ commonCommands = Map.fromList [
longname = "system_pipe",
synopsis = "send argument to a system command",
syntax = "sp -command=\"SYSTEMCOMMAND\", alt. ? SYSTEMCOMMAND",
exec = \_ opts arg -> do
exec = \opts arg -> do
let syst = optComm opts -- ++ " " ++ tmpi
{-
let tmpi = "_tmpi" ---
@@ -171,12 +171,12 @@ commonCommands = Map.fromList [
longname = "to_trie",
syntax = "to_trie",
synopsis = "combine a list of trees into a trie",
exec = \ _ _ -> return . fromString . trie
exec = \ _ ts -> return . fromString $ trie ts
}),
("ut", emptyCommandInfo {
longname = "unicode_table",
synopsis = "show a transliteration table for a unicode character set",
exec = \_ opts _ -> do
exec = \opts _ -> do
let t = concatMap prOpt (take 1 opts)
let out = maybe "no such transliteration" characterTable $ transliteration t
return $ fromString out,
@@ -185,7 +185,7 @@ commonCommands = Map.fromList [
("wf", emptyCommandInfo {
longname = "write_file",
synopsis = "send string or tree to a file",
exec = \_ opts arg -> do
exec = \opts arg-> do
let file = valStrOpts "file" "_gftmp" opts
if isOpt "append" opts
then restricted $ appendFile file (toString arg)

6
src/compiler/GF/Command/Help.hs
View File

@@ -12,7 +12,7 @@ commandHelpAll' allCommands opts = unlines $
commandHelp' opts = if isOpt "t2t" opts then commandHelpTags else commandHelp
commandHelp :: Bool -> (String,CommandInfo env) -> String
--commandHelp :: Bool -> (String,CommandInfo env) -> String
commandHelp full (co,info) = unlines . compact $ [
co ++ optionally (", " ++) (longname info),
synopsis info] ++ if full then [
@@ -26,7 +26,7 @@ commandHelp full (co,info) = unlines . compact $ [
-- for printing with txt2tags formatting
commandHelpTags :: Bool -> (String,CommandInfo env) -> String
--commandHelpTags :: Bool -> (String,CommandInfo env) -> String
commandHelpTags full (co,info) = unlines . compact $ [
"#VSPACE","",
"===="++hdrname++"====",
@@ -75,7 +75,7 @@ helpCommand allCommands =
("license","show copyright and license information"),
("t2t","output help in txt2tags format")
],
exec = \_ opts ts ->
exec = \opts ts ->
let
msg = case ts of
_ | isOpt "changes" opts -> changesMsg

100
src/compiler/GF/Command/Interpreter.hs
View File

@@ -1,67 +1,57 @@
module GF.Command.Interpreter (
CommandEnv,pgfenv,commands,commandmacros,expmacros,
mkCommandEnv,
--emptyCommandEnv,
CommandEnv(..),mkCommandEnv,
interpretCommandLine,
--interpretPipe,
getCommandOp
) where
import Prelude hiding (putStrLn)
import GF.Command.CommandInfo
import GF.Command.Abstract
import GF.Command.Parse
--import PGF
import PGF.Internal(Expr(..))
--import PGF.Morphology
import GF.Infra.SIO(putStrLn,putStrLnFlush)
import GF.Infra.UseIO(putStrLnE)
import GF.Text.Pretty(render)
import Control.Monad(when)
--import Control.Monad.Error()
import qualified Data.Map as Map
data CommandEnv env = CommandEnv {
pgfenv :: env,
commands :: Map.Map String (CommandInfo env),
data CommandEnv m = CommandEnv {
commands :: Map.Map String (CommandInfo m),
commandmacros :: Map.Map String CommandLine,
expmacros :: Map.Map String Expr
}
--mkCommandEnv :: PGFEnv -> CommandEnv
mkCommandEnv env cmds = CommandEnv env cmds Map.empty Map.empty
mkCommandEnv cmds = CommandEnv cmds Map.empty Map.empty
--interpretCommandLine :: CommandEnv -> String -> SIO ()
interpretCommandLine env line =
case readCommandLine line of
Just [] -> return ()
Just pipes -> mapM_ (interpretPipe env) pipes
Nothing -> putStrLnFlush "command not parsed"
Nothing -> putStrLnE "command not parsed"
interpretPipe env cs = do
Piped v@(_,s) <- intercs void cs
putStrLnFlush s
Piped v@(_,s) <- intercs cs void
putStrLnE s
return ()
where
intercs treess [] = return treess
intercs (Piped (trees,_)) (c:cs) = do
treess2 <- interc trees c
intercs treess2 cs
interc es comm@(Command co opts arg) = case co of
'%':f -> case Map.lookup f (commandmacros env) of
Just css ->
case getCommandTrees env False arg es of
Right es -> do mapM_ (interpretPipe env) (appLine es css)
return void
Left msg -> do putStrLn ('\n':msg)
return void
Nothing -> do
putStrLn $ "command macro " ++ co ++ " not interpreted"
return void
_ -> interpret env es comm
appLine es = map (map (appCommand es))
intercs [] treess = return treess
intercs (c:cs) (Piped (trees,_)) = interc c trees >>= intercs cs
-- macro definition applications: replace ?i by (exps !! i)
interc comm@(Command co opts arg) es =
case co of
'%':f -> case Map.lookup f (commandmacros env) of
Just css ->
do es <- getCommandTrees env False arg es
mapM_ (interpretPipe env) (appLine es css)
return void
Nothing -> do
putStrLnE $ "command macro " ++ co ++ " not interpreted"
return void
_ -> interpret env es comm
appLine = map . map . appCommand
-- | macro definition applications: replace ?i by (exps !! i)
appCommand :: [Expr] -> Command -> Command
appCommand xs c@(Command i os arg) = case arg of
AExpr e -> Command i os (AExpr (app e))
@@ -74,25 +64,22 @@ appCommand xs c@(Command i os arg) = case arg of
EMeta i -> xs !! i
EFun x -> EFun x
-- return the trees to be sent in pipe, and the output possibly printed
-- | return the trees to be sent in pipe, and the output possibly printed
--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 = pgfenv env
tss@(Piped (_,s)) <- exec info cmdenv opts trees
when (isOpt "tr" opts) $ putStrLn s
return tss
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
-- | 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)
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 =
@@ -100,7 +87,7 @@ getCommandInfo env cmd =
Just info -> return info
Nothing -> fail $ "command not found: " ++ cmd
checkOpts :: CommandInfo env -> [Option] -> Either String ()
--checkOpts :: CommandInfo env -> [Option] -> Either String ()
checkOpts info opts =
case
[o | OOpt o <- opts, notElem o ("tr" : map fst (options info))] ++
@@ -114,12 +101,11 @@ checkOpts info opts =
getCommandTrees env needsTypeCheck a es =
case a of
AMacro m -> case Map.lookup m (expmacros env) of
Just e -> return [e]
_ -> return []
Just e -> one e
_ -> return [] -- report error?
AExpr e -> if needsTypeCheck
then case typeCheckArg (pgfenv env) e of
Left tcErr -> fail $ render tcErr
Right e -> return [e] -- ignore piped
else return [e]
then one =<< typeCheckArg e
else one e
ANoArg -> return es -- use piped
where
one e = return [e] -- ignore piped

22
src/compiler/GF/Command/SourceCommands.hs
View File

@@ -1,12 +1,12 @@
-- | Commands requiring source grammar in env
module GF.Command.SourceCommands(sourceCommands) where
module GF.Command.SourceCommands(HasGrammar(..),sourceCommands) where
import Prelude hiding (putStrLn)
import qualified Prelude as P(putStrLn)
import Data.List(nub,isInfixOf)
import qualified Data.ByteString.UTF8 as UTF8(fromString)
import qualified Data.Map as Map
import GF.Infra.SIO
import GF.Infra.SIO(MonadSIO(..),restricted)
import GF.Infra.Option(noOptions)
import GF.Data.Operations (chunks,err,raise)
import GF.Text.Pretty(render)
@@ -25,6 +25,10 @@ import GF.Infra.CheckM(runCheck)
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",
@@ -152,9 +156,11 @@ sourceCommands = Map.fromList [
})
]
where
withStrings exec sgr opts = do exec sgr opts . toStrings
withStrings exec opts ts =
do sgr <- getGrammar
liftSIO (exec opts (toStrings ts) sgr)
compute_concrete sgr opts ws =
compute_concrete opts ws sgr =
case runP pExp (UTF8.fromString s) of
Left (_,msg) -> return $ pipeMessage msg
Right t -> return $ err pipeMessage
@@ -176,7 +182,7 @@ sourceCommands = Map.fromList [
OOpt "qual" -> pOpts style Qualified os
_ -> pOpts style q os
show_deps sgr os xs = do
show_deps os xs sgr = do
ops <- case xs of
_:_ -> do
let ts = [t | Right t <- map (runP pExp . UTF8.fromString) xs]
@@ -192,7 +198,7 @@ sourceCommands = Map.fromList [
| otherwise = unwords $ map prTerm ops
return $ fromString printed
show_operations sgr os ts =
show_operations os ts sgr =
case greatestResource sgr of
Nothing -> return $ fromString "no source grammar in scope; did you import with -retain?"
Just mo -> do
@@ -211,7 +217,7 @@ sourceCommands = Map.fromList [
let printed = [unwords [showIdent op, ":", printer ty] | (op,ty) <- sigs]
return . fromString $ unlines [l | l <- printed, all (`isInfixOf` l) greps]
show_source sgr os ts = do
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]
@@ -236,7 +242,7 @@ sourceCommands = Map.fromList [
_ -> return . fromString $ render mygr
dependency_graph sgr opts ws =
dependency_graph opts ws sgr =
do let stop = case valStrOpts "only" "" opts of
"" -> Nothing
fs -> Just $ chunks ',' fs

5
src/compiler/GF/Data/Operations.hs
View File

@@ -20,7 +20,7 @@ module GF.Data.Operations (
lookupErr,
-- ** Error monad class
ErrorMonad(..), checks, doUntil, --allChecks, checkAgain,
ErrorMonad(..), checks, --doUntil, allChecks, checkAgain,
liftErr,
-- ** Checking
@@ -363,10 +363,11 @@ allChecks :: ErrorMonad m => [m a] -> m [a]
allChecks ms = case ms of
(m: ms) -> let rs = allChecks ms in handle_ (liftM2 (:) m rs) rs
_ -> return []
-}
doUntil :: ErrorMonad m => (a -> Bool) -> [m a] -> m a
doUntil cond ms = case ms of
a:as -> do
v <- a
if cond v then return v else doUntil cond as
_ -> raise "no result"
-}

6
src/compiler/GF/Data/Utilities.hs
View File

@@ -16,7 +16,7 @@ module GF.Data.Utilities(module GF.Data.Utilities, module PGF.Utilities) where
import Data.Maybe
import Data.List
import Control.Monad (MonadPlus(..),liftM)
import Control.Monad (MonadPlus(..),liftM,when)
import PGF.Utilities
-- * functions on lists
@@ -136,6 +136,10 @@ mapBoth = map . apBoth
whenMP :: MonadPlus m => Bool -> a -> m a
whenMP b x = if b then return x else mzero
whenM bm m = flip when m =<< bm
repeatM m = whenM m (repeatM m)
-- * functions on Maybes
-- | Returns true if the argument is Nothing or Just []

19
src/compiler/GF/Infra/SIO.hs
View File

@@ -1,9 +1,9 @@
-- | Shell IO: a monad that can restrict acesss to arbitrary IO and has the
-- ability to capture output that normally would be sent to stdout.
{-# LANGUAGE CPP #-}
{-# LANGUAGE CPP, FlexibleInstances, FlexibleContexts #-}
module GF.Infra.SIO(
-- * The SIO monad
SIO,
SIO,MonadSIO(..),
-- * Running SIO operations
runSIO,hRunSIO,captureSIO,
-- * Unrestricted, safe operations
@@ -25,12 +25,14 @@ module GF.Infra.SIO(
import Prelude hiding (putStrLn,print)
import Control.Applicative(Applicative(..))
import Control.Monad(liftM,ap)
import Control.Monad.Trans(MonadTrans(..))
import System.IO(hPutStrLn,hFlush,stdout)
import GF.System.Catch(try)
import System.Process(system)
import System.Environment(getEnv)
import Control.Concurrent.Chan(newChan,writeChan,getChanContents)
import GF.Infra.Concurrency(lazyIO)
import GF.Infra.UseIO(Output(..))
import qualified System.CPUTime as IO(getCPUTime)
import qualified System.Directory as IO(getCurrentDirectory)
import qualified System.Random as IO(newStdGen)
@@ -56,6 +58,19 @@ instance Monad SIO where
return x = SIO (const (return x))
SIO m1 >>= xm2 = SIO $ \ h -> m1 h >>= \ x -> unS (xm2 x) h
instance Output SIO where
ePutStr = lift0 . ePutStr
ePutStrLn = lift0 . ePutStrLn
putStrLnE = putStrLnFlush
--putStrE = --- !!!
class MonadSIO m where liftSIO :: SIO a -> m a
instance MonadSIO SIO where liftSIO = id
instance (MonadTrans t,Monad m,MonadSIO m) => MonadSIO (t m) where
liftSIO = lift . liftSIO
-- * Running SIO operations
-- | Run normally

10
src/compiler/GF/Infra/UseIO.hs
View File

@@ -34,8 +34,9 @@ import System.CPUTime
--import System.Cmd
import Text.Printf
--import Control.Applicative(Applicative(..))
import Control.Monad
import Control.Monad(when,liftM,foldM)
import Control.Monad.Trans(MonadIO(..))
import Control.Monad.State(StateT,lift)
import Control.Exception(evaluate)
--putIfVerb :: MonadIO io => Options -> String -> io ()
@@ -201,6 +202,13 @@ instance Output IOE where
putStrLnE = liftIO . putStrLnE
putStrE = liftIO . putStrE
-}
instance Output m => Output (StateT s m) where
ePutStr = lift . ePutStr
ePutStrLn = lift . ePutStrLn
putStrE = lift . putStrE
putStrLnE = lift . putStrLnE
--putPointE :: Verbosity -> Options -> String -> IO a -> IO a
putPointE v opts msg act = do
when (verbAtLeast opts v) $ putStrE msg

247
src/compiler/GF/Interactive.hs
View File

@@ -1,20 +1,21 @@
{-# LANGUAGE ScopedTypeVariables, CPP #-}
{-# LANGUAGE CPP, ScopedTypeVariables, FlexibleInstances #-}
-- | GF interactive mode
module GF.Interactive (mainGFI,mainRunGFI,mainServerGFI) where
import Prelude hiding (putStrLn,print)
import qualified Prelude as P(putStrLn)
import GF.Command.Interpreter(CommandEnv(..),pgfenv,commands,mkCommandEnv,interpretCommandLine)
import GF.Command.Interpreter(CommandEnv(..),mkCommandEnv,interpretCommandLine)
--import GF.Command.Importing(importSource,importGrammar)
import GF.Command.Commands(flags,options,PGFEnv,pgf,pgfEnv,pgfCommands)
import GF.Command.Commands(flags,options,PGFEnv,HasPGFEnv(..),pgf,pgfEnv,pgfCommands)
import GF.Command.CommonCommands(commonCommands,extend)
import GF.Command.SourceCommands(sourceCommands)
import GF.Command.CommandInfo(mapCommandEnv)
import GF.Command.SourceCommands
--import GF.Command.CommandInfo(mapCommandEnv,liftCommandInfo)
import GF.Command.Help(helpCommand)
import GF.Command.Abstract
import GF.Command.Parse(readCommandLine,pCommand)
import GF.Data.Operations (Err(..),done)
import GF.Data.Utilities(repeatM)
import GF.Grammar hiding (Ident,isPrefixOf)
import GF.Infra.UseIO(ioErrorText)
import GF.Infra.UseIO(ioErrorText,putStrLnE)
import GF.Infra.SIO
import GF.Infra.Option
import qualified System.Console.Haskeline as Haskeline
@@ -33,7 +34,7 @@ import qualified Text.ParserCombinators.ReadP as RP
--import System.CPUTime(getCPUTime)
import System.Directory({-getCurrentDirectory,-}getAppUserDataDirectory)
import Control.Exception(SomeException,fromException,evaluate,try)
import Control.Monad
import Control.Monad.State
import qualified GF.System.Signal as IO(runInterruptibly)
#ifdef SERVER_MODE
import GF.Server(server)
@@ -53,49 +54,58 @@ mainGFI opts files = do
P.putStrLn welcome
shell opts files
shell opts files = loop opts =<< runSIO (importInEnv emptyGFEnv opts files)
shell opts files = flip evalStateT emptyGFEnv $
do mapStateT runSIO $ importInEnv opts files
loop opts
#ifdef SERVER_MODE
-- | Run the GF Server (@gf -server@).
-- The 'Int' argument is the port number for the HTTP service.
mainServerGFI opts0 port files =
server jobs port root (execute1 opts)
=<< runSIO (importInEnv emptyGFEnv opts files)
server jobs port root execute1' . snd
=<< runSIO (runStateT (importInEnv opts files) emptyGFEnv)
where
root = flag optDocumentRoot opts
opts = beQuiet opts0
jobs = join (flag optJobs opts)
execute1' gfenv0 cmd =
do (quit,gfenv) <- runStateT (execute1 opts cmd) gfenv0
return $ if quit then Nothing else Just gfenv
#else
mainServerGFI opts files =
error "GF has not been compiled with server mode support"
#endif
-- | Read end execute commands until it is time to quit
loop :: Options -> GFEnv -> IO ()
loop opts gfenv = maybe done (loop opts) =<< readAndExecute1 opts gfenv
loop :: Options -> StateT GFEnv IO ()
loop opts = repeatM $ readAndExecute1 opts
-- | Read and execute one command, returning Just an updated environment for
-- | the next command, or Nothing when it is time to quit
readAndExecute1 :: Options -> GFEnv -> IO (Maybe GFEnv)
readAndExecute1 opts gfenv =
runSIO . execute1 opts gfenv =<< readCommand opts gfenv
readAndExecute1 :: Options -> StateT GFEnv IO Bool
readAndExecute1 opts =
mapStateT runSIO . execute1 opts =<< readCommand opts
-- | Read a command
readCommand :: Options -> GFEnv -> IO String
readCommand opts gfenv0 =
readCommand :: Options -> StateT GFEnv IO String
readCommand opts =
case flag optMode opts of
ModeRun -> tryGetLine
_ -> fetchCommand gfenv0
ModeRun -> lift tryGetLine
_ -> lift . fetchCommand =<< get
timeIt act =
do t1 <- liftSIO $ getCPUTime
a <- act
t2 <- liftSIO $ getCPUTime
return (t2-t1,a)
-- | Optionally show how much CPU time was used to run an IO action
optionallyShowCPUTime :: Options -> SIO a -> SIO a
optionallyShowCPUTime :: (Monad m,MonadSIO m) => Options -> m a -> m a
optionallyShowCPUTime opts act
| not (verbAtLeast opts Normal) = act
| otherwise = do t0 <- getCPUTime
r <- act
t1 <- getCPUTime
let dt = t1-t0
putStrLnFlush $ show (dt `div` 1000000000) ++ " msec"
| otherwise = do (dt,r) <- timeIt act
liftSIO $ putStrLnFlush $ show (dt `div` 1000000000) ++ " msec"
return r
{-
@@ -107,106 +117,127 @@ loopOptNewCPU opts gfenv'
return $ gfenv' {cputime = cpu'}
-}
type ShellM = StateT GFEnv SIO
-- | Execute a given command, returning Just an updated environment for
-- | the next command, or Nothing when it is time to quit
execute1 :: Options -> GFEnv -> String -> SIO (Maybe GFEnv)
execute1 opts gfenv0 s0 =
interruptible $ optionallyShowCPUTime opts $
case pwords s0 of
-- special commands
{-"eh":w:_ -> do
cs <- readFile w >>= return . map words . lines
gfenv' <- foldM (flip (process False benv)) gfenv cs
loopNewCPU gfenv' -}
"q" :_ -> quit
"!" :ws -> system_command ws
-- cc, sd, so, ss and dg are now in GF.Commands.SourceCommands
"eh":ws -> eh ws
"i" :ws -> import_ ws
-- other special commands, working on GFEnv
"e" :_ -> empty
"dc":ws -> define_command ws
"dt":ws -> define_tree ws
"ph":_ -> print_history
"r" :_ -> reload_last
-- ordinary commands, working on CommandEnv
_ -> do interpretCommandLine env s0
continue gfenv
execute1 :: Options -> String -> ShellM Bool
execute1 opts s0 =
do modify $ \ gfenv0 -> gfenv0 {history = s0 : history gfenv0}
interruptible $ optionallyShowCPUTime opts $
case pwords s0 of
-- cc, sd, so, ss and dg are now in GF.Commands.SourceCommands
-- special commands
"q" :_ -> quit
"!" :ws -> system_command ws
"eh":ws -> eh ws
"i" :ws -> import_ ws
-- other special commands, working on GFEnv
"e" :_ -> empty
"dc":ws -> define_command ws
"dt":ws -> define_tree ws
"ph":_ -> print_history
"r" :_ -> reload_last
-- ordinary commands
_ -> do env <- gets commandenv
interpretCommandLine env s0
continue
where
-- loopNewCPU = fmap Just . loopOptNewCPU opts
continue = return . Just
stop = return Nothing
env = commandenv gfenv0
gfenv = gfenv0 {history = s0 : history gfenv0}
continue,stop :: ShellM Bool
continue = return True
stop = return False
pwords s = case words s of
w:ws -> getCommandOp w :ws
ws -> ws
interruptible :: ShellM Bool -> ShellM Bool
interruptible act =
either (\e -> printException e >> return (Just gfenv)) return
=<< runInterruptibly act
do gfenv <- get
mapStateT (
either (\e -> printException e >> return (True,gfenv)) return
<=< runInterruptibly) act
-- Special commands:
quit = do when (verbAtLeast opts Normal) $ putStrLn "See you."
quit = do when (verbAtLeast opts Normal) $ putStrLnE "See you."
stop
system_command ws = do restrictedSystem $ unwords ws ; continue gfenv
system_command ws = do lift $ restrictedSystem $ unwords ws ; continue
{-"eh":w:_ -> do
cs <- readFile w >>= return . map words . lines
gfenv' <- foldM (flip (process False benv)) gfenv cs
loopNewCPU gfenv' -}
eh [w] = -- Ehhh? Reads commands from a file, but does not execute them
do cs <- restricted (readFile w) >>= return . map (interpretCommandLine env) . lines
continue gfenv
eh _ = do putStrLn "eh command not parsed"
continue gfenv
do env <- gets commandenv
cs <- lift $ restricted (readFile w) >>= return . map (interpretCommandLine env) . lines
continue
eh _ = do putStrLnE "eh command not parsed"
continue
import_ args =
do gfenv' <- case parseOptions args of
Ok (opts',files) -> do
curr_dir <- getCurrentDirectory
lib_dir <- getLibraryDirectory (addOptions opts opts')
importInEnv gfenv (addOptions opts (fixRelativeLibPaths curr_dir lib_dir opts')) files
Bad err -> do
putStrLn $ "Command parse error: " ++ err
return gfenv
continue gfenv'
do case parseOptions args of
Ok (opts',files) -> do
curr_dir <- lift getCurrentDirectory
lib_dir <- lift $ getLibraryDirectory (addOptions opts opts')
importInEnv (addOptions opts (fixRelativeLibPaths curr_dir lib_dir opts')) files
continue
Bad err ->
do putStrLnE $ "Command parse error: " ++ err
continue
continue
empty = continue $ gfenv { commandenv=emptyCommandEnv }
empty = do modify $ \ gfenv -> gfenv { commandenv=emptyCommandEnv }
continue
define_command (f:ws) =
case readCommandLine (unwords ws) of
Just comm -> continue $ gfenv {
commandenv = env {
commandmacros = Map.insert f comm (commandmacros env)
}
}
Just comm ->
do modify $
\ gfenv ->
let env = commandenv gfenv
in gfenv {
commandenv = env {
commandmacros = Map.insert f comm (commandmacros env)
}
}
continue
_ -> dc_not_parsed
define_command _ = dc_not_parsed
dc_not_parsed = putStrLn "command definition not parsed" >> continue gfenv
dc_not_parsed = putStrLnE "command definition not parsed" >> continue
define_tree (f:ws) =
case readExpr (unwords ws) of
Just exp -> continue $ gfenv {
commandenv = env {
expmacros = Map.insert f exp (expmacros env)
}
}
Just exp ->
do modify $
\ gfenv ->
let env = commandenv gfenv
in gfenv { commandenv = env {
expmacros = Map.insert f exp (expmacros env) } }
continue
_ -> dt_not_parsed
define_tree _ = dt_not_parsed
dt_not_parsed = putStrLn "value definition not parsed" >> continue gfenv
dt_not_parsed = putStrLnE "value definition not parsed" >> continue
print_history = mapM_ putStrLn (reverse (history gfenv0))>> continue gfenv
print_history =
do mapM_ putStrLnE . reverse . drop 1 . history =<< get
continue
reload_last = do
gfenv0 <- get
let imports = [(s,ws) | s <- history gfenv0, ("i":ws) <- [pwords s]]
case imports of
(s,ws):_ -> do
putStrLn $ "repeating latest import: " ++ s
putStrLnE $ "repeating latest import: " ++ s
import_ ws
_ -> do
putStrLn $ "no import in history"
continue gfenv
putStrLnE $ "no import in history"
continue
printException e = maybe (print e) (putStrLn . ioErrorText) (fromException e)
@@ -226,20 +257,19 @@ fetchCommand gfenv = do
Right Nothing -> return "q"
Right (Just s) -> return s
importInEnv :: GFEnv -> Options -> [FilePath] -> SIO GFEnv
importInEnv gfenv opts files
| flag optRetainResource opts =
do src <- importSource opts files
pgf <- lazySIO importPGF -- duplicates some work, better to link src
return $ gfenv {retain=True, commandenv = commandEnv src pgf }
| otherwise =
do pgf1 <- importPGF
return $ gfenv { retain=False,
commandenv = commandEnv emptyGrammar pgf1 }
importInEnv :: Options -> [FilePath] -> ShellM ()
importInEnv opts files =
do pgf0 <- gets multigrammar
if flag optRetainResource opts
then do src <- lift $ importSource opts files
pgf <- lift . lazySIO $ importPGF pgf0 -- duplicates some work, better to link src
modify $ \ gfenv -> gfenv {retain=True, pgfenv = (src,pgfEnv pgf)}
else do pgf1 <- lift $ importPGF pgf0
modify $ \ gfenv->gfenv { retain=False,
pgfenv = (emptyGrammar,pgfEnv pgf1) }
where
importPGF =
importPGF pgf0 =
do let opts' = addOptions (setOptimization OptCSE False) opts
pgf0 = multigrammar (commandenv gfenv)
pgf1 <- importGrammar pgf0 opts' files
if (verbAtLeast opts Normal)
then putStrLnFlush $
@@ -257,26 +287,31 @@ prompt env
| retain env || abs == wildCId = "> "
| otherwise = showCId abs ++ "> "
where
abs = abstractName (multigrammar (commandenv env))
abs = abstractName (multigrammar env)
type CmdEnv = (Grammar,PGFEnv)
data GFEnv = GFEnv {
retain :: Bool, -- grammar was imported with -retain flag
commandenv :: CommandEnv (Grammar,PGFEnv),
pgfenv :: CmdEnv,
commandenv :: CommandEnv ShellM,
history :: [String]
}
emptyGFEnv :: GFEnv
emptyGFEnv = GFEnv False emptyCommandEnv [] {-0-}
emptyGFEnv = GFEnv False (emptyGrammar,pgfEnv emptyPGF) emptyCommandEnv [] {-0-}
commandEnv sgr pgf = mkCommandEnv (sgr,pgfEnv pgf) allCommands
emptyCommandEnv = commandEnv emptyGrammar emptyPGF
emptyCommandEnv = mkCommandEnv allCommands
multigrammar = pgf . snd . pgfenv
allCommands =
extend (fmap (mapCommandEnv snd) pgfCommands) [helpCommand allCommands]
`Map.union` (fmap (mapCommandEnv fst) sourceCommands)
extend pgfCommands [helpCommand allCommands]
`Map.union` sourceCommands
`Map.union` commonCommands
instance HasGrammar ShellM where getGrammar = gets (fst . pgfenv)
instance HasPGFEnv ShellM where getPGFEnv = gets (snd . pgfenv)
wordCompletion gfenv (left,right) = do
case wc_type (reverse left) of
CmplCmd pref
@@ -309,7 +344,7 @@ wordCompletion gfenv (left,right) = do
Left (_ :: SomeException) -> ret (length pref) []
_ -> ret 0 []
where
pgf = multigrammar cmdEnv
pgf = multigrammar gfenv
cmdEnv = commandenv gfenv
optLang opts = valCIdOpts "lang" (head (languages pgf)) opts
optType opts =

244
src/compiler/GF/Interactive2.hs
View File

@@ -1,16 +1,19 @@
{-# LANGUAGE ScopedTypeVariables, CPP #-}
{-# LANGUAGE CPP, ScopedTypeVariables, TypeSynonymInstances,FlexibleInstances #-}
-- | GF interactive mode (with the C run-time system)
module GF.Interactive2 (mainGFI,mainRunGFI{-,mainServerGFI-}) where
import Prelude hiding (putStrLn,print)
import qualified Prelude as P(putStrLn)
import GF.Command.Interpreter(CommandEnv(..),commands,mkCommandEnv,interpretCommandLine)
--import GF.Command.Importing(importSource,importGrammar)
import GF.Command.Commands2(flags,options,PGFEnv,pgf,concs,pgfEnv,emptyPGFEnv,allCommands)
import GF.Command.Commands2(flags,options,PGFEnv,HasPGFEnv(..),pgf,concs,pgfEnv,emptyPGFEnv,pgfCommands)
import GF.Command.CommonCommands
import GF.Command.Help(helpCommand)
import GF.Command.Abstract
import GF.Command.Parse(readCommandLine,pCommand)
import GF.Data.Operations (Err(..),done)
import GF.Data.Utilities(repeatM)
import GF.Infra.UseIO(ioErrorText)
import GF.Infra.UseIO(ioErrorText,putStrLnE)
import GF.Infra.SIO
import GF.Infra.Option
import qualified System.Console.Haskeline as Haskeline
@@ -31,7 +34,8 @@ import qualified Text.ParserCombinators.ReadP as RP
import System.Directory({-getCurrentDirectory,-}getAppUserDataDirectory)
import System.FilePath(takeExtensions)
import Control.Exception(SomeException,fromException,try)
import Control.Monad
--import Control.Monad
import Control.Monad.State
import qualified GF.System.Signal as IO(runInterruptibly)
{-
@@ -55,7 +59,10 @@ mainGFI opts files = do
P.putStrLn "This shell uses the C run-time system. See help for available commands."
shell opts files
shell opts files = loop opts =<< runSIO (importInEnv emptyGFEnv opts files)
shell opts files = flip evalStateT emptyGFEnv $
do mapStateT runSIO $ importInEnv opts files
loop opts
{-
#ifdef SERVER_MODE
-- | Run the GF Server (@gf -server@).
@@ -73,31 +80,34 @@ mainServerGFI opts files =
#endif
-}
-- | Read end execute commands until it is time to quit
loop :: Options -> GFEnv -> IO ()
loop opts gfenv = maybe done (loop opts) =<< readAndExecute1 opts gfenv
loop :: Options -> StateT GFEnv IO ()
loop opts = repeatM $ readAndExecute1 opts
-- | Read and execute one command, returning Just an updated environment for
-- | the next command, or Nothing when it is time to quit
readAndExecute1 :: Options -> GFEnv -> IO (Maybe GFEnv)
readAndExecute1 opts gfenv =
runSIO . execute1 opts gfenv =<< readCommand opts gfenv
readAndExecute1 :: Options -> StateT GFEnv IO Bool
readAndExecute1 opts =
mapStateT runSIO . execute1 opts =<< readCommand opts
-- | Read a command
readCommand :: Options -> GFEnv -> IO String
readCommand opts gfenv0 =
readCommand :: Options -> StateT GFEnv IO String
readCommand opts =
case flag optMode opts of
ModeRun -> tryGetLine
_ -> fetchCommand gfenv0
ModeRun -> lift tryGetLine
_ -> lift . fetchCommand =<< get
timeIt act =
do t1 <- liftSIO $ getCPUTime
a <- act
t2 <- liftSIO $ getCPUTime
return (t2-t1,a)
-- | Optionally show how much CPU time was used to run an IO action
optionallyShowCPUTime :: Options -> SIO a -> SIO a
optionallyShowCPUTime :: (Monad m,MonadSIO m) => Options -> m a -> m a
optionallyShowCPUTime opts act
| not (verbAtLeast opts Normal) = act
| otherwise = do t0 <- getCPUTime
r <- act
t1 <- getCPUTime
let dt = t1-t0
putStrLnFlush $ show (dt `div` 1000000000) ++ " msec"
| otherwise = do (dt,r) <- timeIt act
liftSIO $ putStrLnFlush $ show (dt `div` 1000000000) ++ " msec"
return r
{-
@@ -105,112 +115,131 @@ loopOptNewCPU opts gfenv'
| not (verbAtLeast opts Normal) = return gfenv'
| otherwise = do
cpu' <- getCPUTime
putStrLnFlush (show ((cpu' - cputime gfenv') `div` 1000000000) ++ " msec")
putStrLnE (show ((cpu' - cputime gfenv') `div` 1000000000) ++ " msec")
return $ gfenv' {cputime = cpu'}
-}
type ShellM = StateT GFEnv SIO
-- | Execute a given command, returning Just an updated environment for
-- | the next command, or Nothing when it is time to quit
execute1 :: Options -> GFEnv -> String -> SIO (Maybe GFEnv)
execute1 opts gfenv0 s0 =
interruptible $ optionallyShowCPUTime opts $
case pwords s0 of
-- special commands, requiring source grammar in env
{-"eh":w:_ -> do
cs <- readFile w >>= return . map words . lines
gfenv' <- foldM (flip (process False benv)) gfenv cs
loopNewCPU gfenv' -}
"q" :_ -> quit
"!" :ws -> system_command ws
"eh":ws -> eh ws
"i" :ws -> import_ ws
-- other special commands, working on GFEnv
"e" :_ -> empty
"dc":ws -> define_command ws
"dt":ws -> define_tree ws
"ph":_ -> print_history
"r" :_ -> reload_last
-- ordinary commands, working on CommandEnv
_ -> do interpretCommandLine env s0
continue gfenv
execute1 :: Options -> String -> ShellM Bool
execute1 opts s0 =
do modify $ \ gfenv0 -> gfenv0 {history = s0 : history gfenv0}
interruptible $ optionallyShowCPUTime opts $
case pwords s0 of
-- cc, sd, so, ss and dg are now in GF.Commands.SourceCommands
-- special commands
"q" :_ -> quit
"!" :ws -> system_command ws
"eh":ws -> eh ws
"i" :ws -> import_ ws
-- other special commands, working on GFEnv
"e" :_ -> empty
"dc":ws -> define_command ws
"dt":ws -> define_tree ws
"ph":_ -> print_history
"r" :_ -> reload_last
-- ordinary commands
_ -> do env <- gets commandenv
interpretCommandLine env s0
continue
where
-- loopNewCPU = fmap Just . loopOptNewCPU opts
continue = return . Just
stop = return Nothing
env = commandenv gfenv0
-- sgr = grammar gfenv0
gfenv = gfenv0 {history = s0 : history gfenv0}
continue,stop :: ShellM Bool
continue = return True
stop = return False
pwords s = case words s of
w:ws -> getCommandOp w :ws
ws -> ws
interruptible :: ShellM Bool -> ShellM Bool
interruptible act =
either (\e -> printException e >> return (Just gfenv)) return
=<< runInterruptibly act
do gfenv <- get
mapStateT (
either (\e -> printException e >> return (True,gfenv)) return
<=< runInterruptibly) act
-- Special commands:
quit = do when (verbAtLeast opts Normal) $ putStrLn "See you."
quit = do when (verbAtLeast opts Normal) $ putStrLnE "See you."
stop
system_command ws = do restrictedSystem $ unwords ws ; continue gfenv
system_command ws = do lift $ restrictedSystem $ unwords ws ; continue
{-"eh":w:_ -> do
cs <- readFile w >>= return . map words . lines
gfenv' <- foldM (flip (process False benv)) gfenv cs
loopNewCPU gfenv' -}
eh [w] = -- Ehhh? Reads commands from a file, but does not execute them
do cs <- restricted (readFile w) >>= return . map (interpretCommandLine env) . lines
continue gfenv
eh _ = do putStrLn "eh command not parsed"
continue gfenv
do env <- gets commandenv
cs <- lift $ restricted (readFile w) >>= return . map (interpretCommandLine env) . lines
continue
eh _ = do putStrLnE "eh command not parsed"
continue
import_ args =
do gfenv' <- case parseOptions args of
Ok (opts',files) -> do
curr_dir <- getCurrentDirectory
lib_dir <- getLibraryDirectory (addOptions opts opts')
importInEnv gfenv (addOptions opts (fixRelativeLibPaths curr_dir lib_dir opts')) files
Bad err -> do
putStrLn $ "Command parse error: " ++ err
return gfenv
continue gfenv'
do case parseOptions args of
Ok (opts',files) -> do
curr_dir <- lift getCurrentDirectory
lib_dir <- lift $ getLibraryDirectory (addOptions opts opts')
importInEnv (addOptions opts (fixRelativeLibPaths curr_dir lib_dir opts')) files
continue
Bad err ->
do putStrLnE $ "Command parse error: " ++ err
continue
continue
empty = continue $ gfenv {
commandenv=emptyCommandEnv --, grammar = ()
}
empty = do modify $ \ gfenv -> gfenv { commandenv=emptyCommandEnv }
continue
define_command (f:ws) =
case readCommandLine (unwords ws) of
Just comm -> continue $ gfenv {
commandenv = env {
commandmacros = Map.insert f comm (commandmacros env)
}
}
Just comm ->
do modify $
\ gfenv ->
let env = commandenv gfenv
in gfenv {
commandenv = env {
commandmacros = Map.insert f comm (commandmacros env)
}
}
continue
_ -> dc_not_parsed
define_command _ = dc_not_parsed
dc_not_parsed = putStrLn "command definition not parsed" >> continue gfenv
dc_not_parsed = putStrLnE "command definition not parsed" >> continue
define_tree (f:ws) =
case H.readExpr (unwords ws) of
Just exp -> continue $ gfenv {
commandenv = env {
expmacros = Map.insert f exp (expmacros env)
}
}
Just exp ->
do modify $
\ gfenv ->
let env = commandenv gfenv
in gfenv { commandenv = env {
expmacros = Map.insert f exp (expmacros env) } }
continue
_ -> dt_not_parsed
define_tree _ = dt_not_parsed
dt_not_parsed = putStrLn "value definition not parsed" >> continue gfenv
dt_not_parsed = putStrLnE "value definition not parsed" >> continue
print_history = mapM_ putStrLn (reverse (history gfenv0))>> continue gfenv
print_history =
do mapM_ putStrLnE . reverse . drop 1 . history =<< get
continue
reload_last = do
gfenv0 <- get
let imports = [(s,ws) | s <- history gfenv0, ("i":ws) <- [pwords s]]
case imports of
(s,ws):_ -> do
putStrLn $ "repeating latest import: " ++ s
putStrLnE $ "repeating latest import: " ++ s
import_ ws
_ -> do
putStrLn $ "no import in history"
continue gfenv
putStrLnE $ "no import in history"
continue
printException e = maybe (print e) (putStrLn . ioErrorText) (fromException e)
@@ -230,27 +259,26 @@ fetchCommand gfenv = do
Right Nothing -> return "q"
Right (Just s) -> return s
importInEnv :: GFEnv -> Options -> [FilePath] -> SIO GFEnv
importInEnv gfenv opts files =
importInEnv :: Options -> [FilePath] -> ShellM ()
importInEnv opts files =
case files of
_ | flag optRetainResource opts ->
do putStrLn "Flag -retain is not supported in this shell"
return gfenv
putStrLnE "Flag -retain is not supported in this shell"
[file] | takeExtensions file == ".pgf" -> importPGF file
[] -> return gfenv
_ -> do putStrLn "Can only import one .pgf file"
return gfenv
[] -> done
_ -> do putStrLnE "Can only import one .pgf file"
where
importPGF file =
do case multigrammar (commandenv gfenv) of
Just _ -> putStrLnFlush "Discarding previous grammar"
do gfenv <- get
case multigrammar gfenv of
Just _ -> putStrLnE "Discarding previous grammar"
_ -> done
pgf1 <- readPGF2 file
let gfenv' = gfenv { commandenv = commandEnv pgf1 }
pgf1 <- lift $ readPGF2 file
let gfenv' = gfenv { pgfenv = pgfEnv pgf1 }
when (verbAtLeast opts Normal) $
let langs = Map.keys . concretes $ commandenv gfenv'
in putStrLnFlush . unwords $ "\nLanguages:":langs
return gfenv'
let langs = Map.keys . concretes $ gfenv'
in putStrLnE . unwords $ "\nLanguages:":langs
put gfenv'
tryGetLine = do
res <- try getLine
@@ -260,23 +288,31 @@ tryGetLine = do
prompt env = abs ++ "> "
where
abs = maybe "" C.abstractName (multigrammar (commandenv env))
abs = maybe "" C.abstractName (multigrammar env)
data GFEnv = GFEnv {
--grammar :: (), -- gfo grammar -retain
--retain :: (), -- grammar was imported with -retain flag
commandenv :: CommandEnv PGFEnv,
pgfenv :: PGFEnv,
commandenv :: CommandEnv ShellM,
history :: [String]
}
emptyGFEnv :: GFEnv
emptyGFEnv = GFEnv {-() ()-} emptyCommandEnv [] {-0-}
emptyGFEnv = GFEnv {-() ()-} emptyPGFEnv emptyCommandEnv [] {-0-}
commandEnv pgf = mkCommandEnv (pgfEnv pgf) allCommands
emptyCommandEnv = mkCommandEnv emptyPGFEnv allCommands
emptyCommandEnv = mkCommandEnv allCommands
multigrammar = pgf . pgfenv
concretes = concs . pgfenv
allCommands =
extend pgfCommands [helpCommand allCommands]
`Map.union` commonCommands
instance HasPGFEnv ShellM where getPGFEnv = gets pgfenv
-- ** Completion
wordCompletion gfenv (left,right) = do
case wc_type (reverse left) of
CmplCmd pref
@@ -315,7 +351,7 @@ wordCompletion gfenv (left,right) = do
_ -> ret 0 []
where
mb_pgf = multigrammar cmdEnv
mb_pgf = multigrammar gfenv
cmdEnv = commandenv gfenv
{-
optLang opts = valStrOpts "lang" (head $ Map.keys (concretes cmdEnv)) opts