GitHub/gf-core
1
0
Fork 1
mirror of https://github.com/GrammaticalFramework/gf-core.git synced 2026-04-22 19:22:50 -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 module GF.Command.CommandInfo where
import GF.Command.Abstract(Option,Expr) import GF.Command.Abstract(Option,Expr)
import GF.Infra.SIO(SIO)
import qualified PGF as H(showExpr) import qualified PGF as H(showExpr)
import qualified PGF.Internal as H(Literal(LStr),Expr(ELit)) ---- import qualified PGF.Internal as H(Literal(LStr),Expr(ELit)) ----
import GF.Text.Pretty(Doc)
data CommandInfo env = CommandInfo { data CommandInfo m = CommandInfo {
exec :: env -> [Option] -> [Expr] -> SIO CommandOutput, exec :: [Option] -> [Expr] -> m CommandOutput,
synopsis :: String, synopsis :: String,
syntax :: String, syntax :: String,
explanation :: String, explanation :: String,
@@ -17,11 +15,11 @@ data CommandInfo env = CommandInfo {
needsTypeCheck :: Bool 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 { emptyCommandInfo = CommandInfo {
exec = \_ _ ts -> return $ pipeExprs ts, ---- exec = error "command not implemented",
synopsis = "", synopsis = "",
syntax = "", syntax = "",
explanation = "", explanation = "",
@@ -33,10 +31,7 @@ emptyCommandInfo = CommandInfo {
} }
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
class TypeCheckArg env where typeCheckArg :: env -> Expr -> Either Doc Expr class Monad m => TypeCheckArg m where typeCheckArg :: Expr -> m Expr
instance TypeCheckArg env => TypeCheckArg (x,env) where
typeCheckArg (x,env) = typeCheckArg env
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------

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

@@ -1,5 +1,6 @@
{-# LANGUAGE FlexibleInstances, UndecidableInstances #-}
module GF.Command.Commands ( module GF.Command.Commands (
PGFEnv,pgf,mos,pgfEnv,pgfCommands, PGFEnv,HasPGFEnv(..),pgf,mos,pgfEnv,pgfCommands,
options,flags, options,flags,
) where ) where
import Prelude hiding (putStrLn) import Prelude hiding (putStrLn)
@@ -8,11 +9,7 @@ import PGF
import PGF.Internal(lookStartCat,functionsToCat,lookValCat,restrictPGF,hasLin) import PGF.Internal(lookStartCat,functionsToCat,lookValCat,restrictPGF,hasLin)
import PGF.Internal(abstract,funs,cats,Expr(EFun)) ---- import PGF.Internal(abstract,funs,cats,Expr(EFun)) ----
--import PGF.Morphology(isInMorpho,morphoKnown)
import PGF.Internal(ppFun,ppCat) 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 PGF.Internal(optimizePGF)
import GF.Compile.Export import GF.Compile.Export
@@ -21,14 +18,10 @@ import GF.Compile.ExampleBased
import GF.Infra.Option (noOptions, readOutputFormat, outputFormatsExpl) import GF.Infra.Option (noOptions, readOutputFormat, outputFormatsExpl)
import GF.Infra.UseIO(writeUTF8File) import GF.Infra.UseIO(writeUTF8File)
import GF.Infra.SIO import GF.Infra.SIO
--import GF.Data.ErrM ----
import GF.Command.Abstract import GF.Command.Abstract
--import GF.Command.Messages
import GF.Command.CommandInfo import GF.Command.CommandInfo
import GF.Command.CommonCommands import GF.Command.CommonCommands
--import GF.Text.Lexing
import GF.Text.Clitics import GF.Text.Clitics
--import GF.Text.Transliterations
import GF.Quiz import GF.Quiz
import GF.Command.TreeOperations ---- temporary place for typecheck and compute 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.List(intersperse,nub)
import Data.Maybe import Data.Maybe
import qualified Data.Map as Map 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 GF.Text.Pretty
import Data.List (sort) import Data.List (sort)
--import Debug.Trace --import Debug.Trace
--import System.Random (newStdGen) ----
data PGFEnv = Env {pgf::PGF,mos::Map.Map Language Morpho} 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 pgfEnv pgf = Env pgf mos
where mos = Map.fromList [(la,buildMorpho pgf la) | la <- languages pgf] where mos = Map.fromList [(la,buildMorpho pgf la) | la <- languages pgf]
instance TypeCheckArg PGFEnv where class (Functor m,Monad m,MonadSIO m) => HasPGFEnv m where getPGFEnv :: m PGFEnv
typeCheckArg (Env pgf _) = either (Left . ppTcError) (Right . fst) . inferExpr pgf
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 [ pgfCommands = Map.fromList [
("aw", emptyCommandInfo { ("aw", emptyCommandInfo {
longname = "align_words", longname = "align_words",
@@ -68,7 +61,7 @@ pgfCommands = Map.fromList [
"by the flag. The target format is postscript, unless overridden by the", "by the flag. The target format is postscript, unless overridden by the",
"flag -format." "flag -format."
], ],
exec = \ (Env pgf mos) opts es -> do exec = getEnv $ \ opts es (Env pgf mos) -> do
let langs = optLangs pgf opts let langs = optLangs pgf opts
if isOpt "giza" opts if isOpt "giza" opts
then do then do
@@ -115,16 +108,16 @@ pgfCommands = Map.fromList [
"by the flag '-clitics'. The list of stems is given as the list of words", "by the flag '-clitics'. The list of stems is given as the list of words",
"of the language given by the '-lang' flag." "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 -> _ | isOpt "raw" opts ->
return . fromString . return . fromString .
unlines . map (unwords . map (concat . intersperse "+")) . unlines . map (unwords . map (concat . intersperse "+")) .
map (getClitics (isInMorpho (optMorpho env opts)) (optClitics opts)) . map (getClitics (isInMorpho (optMorpho env opts)) (optClitics opts)) .
concatMap words . toStrings concatMap words $ toStrings ts
_ -> _ ->
return . fromStrings . return . fromStrings .
getCliticsText (isInMorpho (optMorpho env opts)) (optClitics opts) . getCliticsText (isInMorpho (optMorpho env opts)) (optClitics opts) .
concatMap words . toStrings, concatMap words $ toStrings ts,
flags = [ flags = [
("clitics","the list of possible clitics (comma-separated, no spaces)"), ("clitics","the list of possible clitics (comma-separated, no spaces)"),
("lang", "the language of analysis") ("lang", "the language of analysis")
@@ -159,7 +152,7 @@ pgfCommands = Map.fromList [
("lang","the language in which to parse"), ("lang","the language in which to parse"),
("probs","file with probabilities to rank the parses") ("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 let file = optFile opts
pgf <- optProbs opts pgf pgf <- optProbs opts pgf
let printer = if (isOpt "api" opts) then exprToAPI else (showExpr []) let printer = if (isOpt "api" opts) then exprToAPI else (showExpr [])
@@ -193,7 +186,7 @@ pgfCommands = Map.fromList [
("depth","the maximum generation depth"), ("depth","the maximum generation depth"),
("probs", "file with biased probabilities (format 'f 0.4' one by line)") ("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) pgf <- optProbs opts (optRestricted opts pgf)
gen <- newStdGen gen <- newStdGen
let dp = valIntOpts "depth" 4 opts 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 -cat=NP -depth=2 -- trees in the category NP to depth 2",
mkEx "gt (AdjCN ? (UseN ?)) -- trees of form (AdjCN ? (UseN ?))" 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 pgfr = optRestricted opts pgf
let dp = valIntOpts "depth" 4 opts let dp = valIntOpts "depth" 4 opts
let ts = case mexp xs of 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 "gr -lang=LangHin -cat=Cl | l -table -to_devanagari -- hindi table",
mkEx "l -unlexer=\"LangAra=to_arabic LangHin=to_devanagari\" -- different unlexers" 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 = [ options = [
("all", "show all forms and variants, one by line (cf. l -list)"), ("all", "show all forms and variants, one by line (cf. l -list)"),
("bracket","show tree structure with brackets and paths to nodes"), ("bracket","show tree structure with brackets and paths to nodes"),
@@ -302,7 +295,7 @@ pgfCommands = Map.fromList [
examples = [ examples = [
mkEx "l -lang=LangSwe,LangNor -chunks ? a b (? c d)" 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 = [ options = [
("treebank","show the tree and tag linearizations with language names") ("treebank","show the tree and tag linearizations with language names")
] ++ stringOpOptions, ] ++ stringOpOptions,
@@ -318,18 +311,18 @@ pgfCommands = Map.fromList [
"Prints all the analyses of space-separated words in the input string,", "Prints all the analyses of space-separated words in the input string,",
"using the morphological analyser of the actual grammar (see command pg)" "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 -> _ | isOpt "missing" opts ->
return . fromString . unwords . return . fromString . unwords .
morphoMissing (optMorpho env opts) . morphoMissing (optMorpho env opts) .
concatMap words . toStrings concatMap words $ toStrings ts
_ | isOpt "known" opts -> _ | isOpt "known" opts ->
return . fromString . unwords . return . fromString . unwords .
morphoKnown (optMorpho env opts) . morphoKnown (optMorpho env opts) .
concatMap words . toStrings concatMap words $ toStrings ts
_ -> return . fromString . unlines . _ -> return . fromString . unlines .
map prMorphoAnalysis . concatMap (morphos env opts) . map prMorphoAnalysis . concatMap (morphos env opts) .
concatMap words . toStrings , concatMap words $ toStrings ts,
flags = [ flags = [
("lang","the languages of analysis (comma-separated, no spaces)") ("lang","the languages of analysis (comma-separated, no spaces)")
], ],
@@ -343,7 +336,7 @@ pgfCommands = Map.fromList [
longname = "morpho_quiz", longname = "morpho_quiz",
synopsis = "start a morphology quiz", synopsis = "start a morphology quiz",
syntax = "mq (-cat=CAT)? (-probs=FILE)? TREE?", 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 lang = optLang pgf opts
let typ = optType pgf opts let typ = optType pgf opts
pgf <- optProbs opts pgf pgf <- optProbs opts pgf
@@ -371,7 +364,7 @@ pgfCommands = Map.fromList [
"the parser. For example if -openclass=\"A,N,V\" is given, the parser", "the parser. For example if -openclass=\"A,N,V\" is given, the parser",
"will accept unknown adjectives, nouns and verbs with the resource grammar." "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]), return . Piped $ fromParse opts (concat [map ((,) s) (par pgf opts s) | s <- toStrings ts]),
flags = [ flags = [
("cat","target category of parsing"), ("cat","target category of parsing"),
@@ -402,7 +395,7 @@ pgfCommands = Map.fromList [
" " ++ opt ++ "\t\t" ++ expl | " " ++ opt ++ "\t\t" ++ expl |
((opt,_),expl) <- outputFormatsExpl, take 1 expl /= "*" ((opt,_),expl) <- outputFormatsExpl, take 1 expl /= "*"
]), ]),
exec = \env opts _ -> prGrammar env opts, exec = getEnv $ \opts _ env -> prGrammar env opts,
flags = [ flags = [
--"cat", --"cat",
("file", "set the file name when printing with -pgf option"), ("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 "pt -compute (plus one two) -- compute value",
mkEx "p \"4 dogs love 5 cats\" | pt -transfer=digits2numeral | l -- four...five..." mkEx "p \"4 dogs love 5 cats\" | pt -transfer=digits2numeral | l -- four...five..."
], ],
exec = \ (Env pgf mos) opts -> exec = getEnv $ \ opts ts (Env pgf mos) ->
returnFromExprs . takeOptNum opts . treeOps pgf opts, returnFromExprs . takeOptNum opts $ treeOps pgf opts ts,
options = treeOpOptions undefined{-pgf-}, options = treeOpOptions undefined{-pgf-},
flags = [("number","take at most this many trees")] ++ treeOpFlags 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"), ("lines","return the list of lines, instead of the singleton of all contents"),
("tree","convert strings into trees") ("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 file = valStrOpts "file" "_gftmp" opts
let exprs [] = ([],empty) let exprs [] = ([],empty)
exprs ((n,s):ls) | null s 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", "by the file given by flag -probs=FILE, where each line has the form",
"'function probability', e.g. 'youPol_Pron 0.01'." "'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 pgf <- optProbs opts pgf
let tds = rankTreesByProbs pgf ts let tds = rankTreesByProbs pgf ts
if isOpt "v" opts if isOpt "v" opts
@@ -514,7 +507,7 @@ pgfCommands = Map.fromList [
longname = "translation_quiz", longname = "translation_quiz",
syntax = "tq -from=LANG -to=LANG (-cat=CAT)? (-probs=FILE)? TREE?", syntax = "tq -from=LANG -to=LANG (-cat=CAT)? (-probs=FILE)? TREE?",
synopsis = "start a translation quiz", 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 from = optLangFlag "from" pgf opts
let to = optLangFlag "to" pgf opts let to = optLangFlag "to" pgf opts
let typ = optType 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", "by the flag. The target format is png, unless overridden by the",
"flag -format." "flag -format."
], ],
exec = \ (Env pgf mos) opts es -> do exec = getEnv $ \ opts es (Env pgf mos) -> do
let debug = isOpt "v" opts let debug = isOpt "v" opts
let file = valStrOpts "file" "" opts let file = valStrOpts "file" "" opts
let outp = valStrOpts "output" "dot" 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", "by the flag. The target format is png, unless overridden by the",
"flag -format." "flag -format."
], ],
exec = \ (Env pgf mos) opts es -> do exec = getEnv $ \ opts es (Env pgf mos) -> do
let lang = optLang pgf opts let lang = optLang pgf opts
let gvOptions = GraphvizOptions {noLeaves = isOpt "noleaves" opts && not (isOpt "showleaves" opts), let gvOptions = GraphvizOptions {noLeaves = isOpt "noleaves" opts && not (isOpt "showleaves" opts),
noFun = isOpt "nofun" opts || not (isOpt "showfun" opts), noFun = isOpt "nofun" opts || not (isOpt "showfun" opts),
@@ -660,7 +653,7 @@ pgfCommands = Map.fromList [
"flag -format.", "flag -format.",
"With option -mk, use for showing library style function names of form 'mkC'." "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 if isOpt "mk" opts
then return $ fromString $ unlines $ map (tree2mk pgf) es then return $ fromString $ unlines $ map (tree2mk pgf) es
else if isOpt "api" opts else if isOpt "api" opts
@@ -708,7 +701,7 @@ pgfCommands = Map.fromList [
"If a whole expression is given it prints the expression with refined", "If a whole expression is given it prints the expression with refined",
"metavariables and the type of the expression." "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 case arg of
[EFun id] -> case Map.lookup id (funs (abstract pgf)) of [EFun id] -> case Map.lookup id (funs (abstract pgf)) of
Just fd -> do putStrLn $ render (ppFun id fd) Just fd -> do putStrLn $ render (ppFun id fd)
@@ -740,6 +733,8 @@ pgfCommands = Map.fromList [
}) })
] ]
where where
getEnv exec opts ts = liftSIO . exec opts ts =<< getPGFEnv
par pgf opts s = case optOpenTypes opts of par pgf opts s = case optOpenTypes opts of
[] -> [parse_ pgf lang (optType pgf opts) (Just dp) s | lang <- optLangs pgf opts] [] -> [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] 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 ( module GF.Command.Commands2 (
PGFEnv,pgf,concs,pgfEnv,emptyPGFEnv,allCommands, PGFEnv,HasPGFEnv(..),pgf,concs,pgfEnv,emptyPGFEnv,pgfCommands,
options, flags, options, flags,
) where ) where
import Prelude hiding (putStrLn) import Prelude hiding (putStrLn)
@@ -19,13 +20,11 @@ import qualified PGF as H
--import GF.Compile.ExampleBased --import GF.Compile.ExampleBased
--import GF.Infra.Option (noOptions, readOutputFormat, outputFormatsExpl) --import GF.Infra.Option (noOptions, readOutputFormat, outputFormatsExpl)
--import GF.Infra.UseIO(writeUTF8File) --import GF.Infra.UseIO(writeUTF8File)
--import GF.Infra.SIO import GF.Infra.SIO(MonadSIO,liftSIO)
--import GF.Data.ErrM ---- --import GF.Data.ErrM ----
import GF.Command.Abstract import GF.Command.Abstract
--import GF.Command.Messages --import GF.Command.Messages
import GF.Command.CommandInfo import GF.Command.CommandInfo
import GF.Command.Help
import GF.Command.CommonCommands
--import GF.Text.Lexing --import GF.Text.Lexing
--import GF.Text.Clitics --import GF.Text.Clitics
--import GF.Text.Transliterations --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) pgfEnv pgf = Env (Just pgf) (C.languages pgf)
emptyPGFEnv = Env Nothing Map.empty emptyPGFEnv = Env Nothing Map.empty
instance TypeCheckArg PGFEnv where class (Monad m,MonadSIO m) => HasPGFEnv m where getPGFEnv :: m PGFEnv
typeCheckArg env e = Right e -- no type checker available !!
instance Monad m => TypeCheckArg m where
typeCheckArg = return -- no type checker available !!
allCommands :: Map.Map String (CommandInfo PGFEnv) pgfCommands :: HasPGFEnv m => Map.Map String (CommandInfo m)
allCommands = extend commonCommands [ pgfCommands = Map.fromList [
{- {-
("aw", emptyCommandInfo { ("aw", emptyCommandInfo {
longname = "align_words", longname = "align_words",
@@ -140,57 +140,6 @@ allCommands = extend commonCommands [
mkEx "ca -lang=Fin -clitics=ko,ni \"nukkuuko minun vaimoni\" | p -- to parse Finnish" 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 { ("eb", emptyCommandInfo {
@@ -269,7 +218,7 @@ allCommands = extend commonCommands [
examples = [ examples = [
mkEx "ga -- all trees in the startcat", mkEx "ga -- all trees in the startcat",
mkEx "ga -cat=NP -number=16 -- 16 trees in the category NP"], 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) let ts = map fst (C.generateAll pgf cat)
cat = optCat pgf opts cat = optCat pgf opts
in returnFromCExprs (takeOptNum opts ts), in returnFromCExprs (takeOptNum opts ts),
@@ -306,7 +255,6 @@ allCommands = extend commonCommands [
returnFromExprs $ take (optNumInf opts) ts returnFromExprs $ take (optNumInf opts) ts
}), }),
-} -}
helpCommand allCommands,
("i", emptyCommandInfo { ("i", emptyCommandInfo {
longname = "import", longname = "import",
synopsis = "import a grammar from a compiled .pgf file", synopsis = "import a grammar from a compiled .pgf file",
@@ -346,8 +294,8 @@ allCommands = extend commonCommands [
], ],
examples = [ examples = [
mkEx "l -lang=LangSwe,LangNor no_Utt -- linearize tree to LangSwe and LangNor"], mkEx "l -lang=LangSwe,LangNor no_Utt -- linearize tree to LangSwe and LangNor"],
exec = needPGF $ \ env opts -> exec = needPGF $ \ opts ts env ->
return . fromStrings . cLins env opts . map cExpr return . fromStrings . cLins env opts $ map cExpr ts
}), }),
{- {-
("l", emptyCommandInfo { ("l", emptyCommandInfo {
@@ -470,7 +418,7 @@ allCommands = extend commonCommands [
examples = [ examples = [
mkEx "p \"this fish is fresh\" | l -lang=Swe -- try parsing with all languages and translate the successful parses to Swedish" 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 { ("p", emptyCommandInfo {
@@ -657,76 +605,6 @@ allCommands = extend commonCommands [
mkEx ("tq -from=Eng -to=Swe (AdjCN (PositA ?2) (UseN ?)) -- only trees of this form") 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 { ("vd", emptyCommandInfo {
longname = "visualize_dependency", longname = "visualize_dependency",
synopsis = "show word dependency tree graphically", synopsis = "show word dependency tree graphically",
@@ -1205,7 +1083,8 @@ cExpr e =
Just (f,es) -> C.mkApp (H.showCId f) (map cExpr es) Just (f,es) -> C.mkApp (H.showCId f) (map cExpr es)
_ -> error "GF.Command.Commands2.cExpr" _ -> error "GF.Command.Commands2.cExpr"
needPGF exec (Env mb_pgf cncs) opts ts = needPGF exec opts ts =
case mb_pgf of do Env mb_pgf cncs <- getPGFEnv
Just pgf -> exec (pgf,cncs) opts ts case mb_pgf of
_ -> fail "Import a grammar before using this command" 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 extend old new = Map.union (Map.fromList new) old -- Map.union is left-biased
commonCommands :: Map.Map String (CommandInfo env) commonCommands :: (Monad m,MonadSIO m) => Map.Map String (CommandInfo m)
commonCommands = Map.fromList [ commonCommands = fmap (mapCommandExec liftSIO) $ Map.fromList [
("!", emptyCommandInfo { ("!", emptyCommandInfo {
synopsis = "system command: escape to system shell", synopsis = "system command: escape to system shell",
syntax = "! SYSTEMCOMMAND", 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 "rf -file=Ara.gf | ps -from_utf8 -env=quotes -from_arabic -- convert UTF8 to transliteration",
mkEx "ps -to=chinese.trans \"abc\" -- apply transliteration defined in file chinese.trans" mkEx "ps -to=chinese.trans \"abc\" -- apply transliteration defined in file chinese.trans"
], ],
exec = \_ opts x -> do exec = \opts x-> do
let (os,fs) = optsAndFlags opts let (os,fs) = optsAndFlags opts
trans <- optTranslit opts trans <- optTranslit opts
@@ -139,7 +139,7 @@ commonCommands = Map.fromList [
mkEx "se utf8 -- set encoding to utf8 (default)" mkEx "se utf8 -- set encoding to utf8 (default)"
], ],
needsTypeCheck = False, needsTypeCheck = False,
exec = \ _ opts ts -> exec = \ opts ts ->
case words (toString ts) of case words (toString ts) of
[c] -> do let cod = renameEncoding c [c] -> do let cod = renameEncoding c
restricted $ changeConsoleEncoding cod restricted $ changeConsoleEncoding cod
@@ -150,7 +150,7 @@ commonCommands = Map.fromList [
longname = "system_pipe", longname = "system_pipe",
synopsis = "send argument to a system command", synopsis = "send argument to a system command",
syntax = "sp -command=\"SYSTEMCOMMAND\", alt. ? SYSTEMCOMMAND", syntax = "sp -command=\"SYSTEMCOMMAND\", alt. ? SYSTEMCOMMAND",
exec = \_ opts arg -> do exec = \opts arg -> do
let syst = optComm opts -- ++ " " ++ tmpi let syst = optComm opts -- ++ " " ++ tmpi
{- {-
let tmpi = "_tmpi" --- let tmpi = "_tmpi" ---
@@ -171,12 +171,12 @@ commonCommands = Map.fromList [
longname = "to_trie", longname = "to_trie",
syntax = "to_trie", syntax = "to_trie",
synopsis = "combine a list of trees into a trie", synopsis = "combine a list of trees into a trie",
exec = \ _ _ -> return . fromString . trie exec = \ _ ts -> return . fromString $ trie ts
}), }),
("ut", emptyCommandInfo { ("ut", emptyCommandInfo {
longname = "unicode_table", longname = "unicode_table",
synopsis = "show a transliteration table for a unicode character set", synopsis = "show a transliteration table for a unicode character set",
exec = \_ opts _ -> do exec = \opts _ -> do
let t = concatMap prOpt (take 1 opts) let t = concatMap prOpt (take 1 opts)
let out = maybe "no such transliteration" characterTable $ transliteration t let out = maybe "no such transliteration" characterTable $ transliteration t
return $ fromString out, return $ fromString out,
@@ -185,7 +185,7 @@ commonCommands = Map.fromList [
("wf", emptyCommandInfo { ("wf", emptyCommandInfo {
longname = "write_file", longname = "write_file",
synopsis = "send string or tree to a file", synopsis = "send string or tree to a file",
exec = \_ opts arg -> do exec = \opts arg-> do
let file = valStrOpts "file" "_gftmp" opts let file = valStrOpts "file" "_gftmp" opts
if isOpt "append" opts if isOpt "append" opts
then restricted $ appendFile file (toString arg) 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' 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 $ [ commandHelp full (co,info) = unlines . compact $ [
co ++ optionally (", " ++) (longname info), co ++ optionally (", " ++) (longname info),
synopsis info] ++ if full then [ synopsis info] ++ if full then [
@@ -26,7 +26,7 @@ commandHelp full (co,info) = unlines . compact $ [
-- for printing with txt2tags formatting -- for printing with txt2tags formatting
commandHelpTags :: Bool -> (String,CommandInfo env) -> String --commandHelpTags :: Bool -> (String,CommandInfo env) -> String
commandHelpTags full (co,info) = unlines . compact $ [ commandHelpTags full (co,info) = unlines . compact $ [
"#VSPACE","", "#VSPACE","",
"===="++hdrname++"====", "===="++hdrname++"====",
@@ -75,7 +75,7 @@ helpCommand allCommands =
("license","show copyright and license information"), ("license","show copyright and license information"),
("t2t","output help in txt2tags format") ("t2t","output help in txt2tags format")
], ],
exec = \_ opts ts -> exec = \opts ts ->
let let
msg = case ts of msg = case ts of
_ | isOpt "changes" opts -> changesMsg _ | isOpt "changes" opts -> changesMsg

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

@@ -1,67 +1,57 @@
module GF.Command.Interpreter ( module GF.Command.Interpreter (
CommandEnv,pgfenv,commands,commandmacros,expmacros, CommandEnv(..),mkCommandEnv,
mkCommandEnv,
--emptyCommandEnv,
interpretCommandLine, interpretCommandLine,
--interpretPipe,
getCommandOp getCommandOp
) where ) where
import Prelude hiding (putStrLn)
import GF.Command.CommandInfo import GF.Command.CommandInfo
import GF.Command.Abstract import GF.Command.Abstract
import GF.Command.Parse import GF.Command.Parse
--import PGF
import PGF.Internal(Expr(..)) import PGF.Internal(Expr(..))
--import PGF.Morphology import GF.Infra.UseIO(putStrLnE)
import GF.Infra.SIO(putStrLn,putStrLnFlush)
import GF.Text.Pretty(render) import GF.Text.Pretty(render)
import Control.Monad(when) import Control.Monad(when)
--import Control.Monad.Error()
import qualified Data.Map as Map import qualified Data.Map as Map
data CommandEnv env = CommandEnv { data CommandEnv m = CommandEnv {
pgfenv :: env, commands :: Map.Map String (CommandInfo m),
commands :: Map.Map String (CommandInfo env),
commandmacros :: Map.Map String CommandLine, commandmacros :: Map.Map String CommandLine,
expmacros :: Map.Map String Expr expmacros :: Map.Map String Expr
} }
--mkCommandEnv :: PGFEnv -> CommandEnv --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 :: CommandEnv -> String -> SIO ()
interpretCommandLine env line = interpretCommandLine env line =
case readCommandLine line of case readCommandLine line of
Just [] -> return () Just [] -> return ()
Just pipes -> mapM_ (interpretPipe env) pipes Just pipes -> mapM_ (interpretPipe env) pipes
Nothing -> putStrLnFlush "command not parsed" Nothing -> putStrLnE "command not parsed"
interpretPipe env cs = do interpretPipe env cs = do
Piped v@(_,s) <- intercs void cs Piped v@(_,s) <- intercs cs void
putStrLnFlush s putStrLnE s
return () return ()
where where
intercs treess [] = return treess intercs [] treess = return treess
intercs (Piped (trees,_)) (c:cs) = do intercs (c:cs) (Piped (trees,_)) = interc c trees >>= intercs cs
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))
-- 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 :: [Expr] -> Command -> Command
appCommand xs c@(Command i os arg) = case arg of appCommand xs c@(Command i os arg) = case arg of
AExpr e -> Command i os (AExpr (app e)) 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 EMeta i -> xs !! i
EFun x -> EFun x 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 :: CommandEnv -> [Expr] -> Command -> SIO CommandOutput
interpret env trees comm = interpret env trees comm =
case getCommand env trees comm of do (info,opts,trees) <- getCommand env trees comm
Left msg -> do putStrLn ('\n':msg) tss@(Piped (_,s)) <- exec info opts trees
return void when (isOpt "tr" opts) $ putStrLnE s
Right (info,opts,trees) -> do let cmdenv = pgfenv env return tss
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 -- | analyse command parse tree to a uniform datastructure, normalizing comm name
--- the env is needed for macro lookup --- the env is needed for macro lookup
--getCommand :: CommandEnv -> [Expr] -> Command -> Either String (CommandInfo PGFEnv,[Option],[Expr]) --getCommand :: CommandEnv -> [Expr] -> Command -> Either String (CommandInfo PGFEnv,[Option],[Expr])
getCommand env es co@(Command c opts arg) = do getCommand env es co@(Command c opts arg) =
info <- getCommandInfo env c do info <- getCommandInfo env c
checkOpts info opts checkOpts info opts
es <- getCommandTrees env (needsTypeCheck info) arg es es <- getCommandTrees env (needsTypeCheck info) arg es
return (info,opts,es) return (info,opts,es)
--getCommandInfo :: CommandEnv -> String -> Either String (CommandInfo PGFEnv) --getCommandInfo :: CommandEnv -> String -> Either String (CommandInfo PGFEnv)
getCommandInfo env cmd = getCommandInfo env cmd =
@@ -100,7 +87,7 @@ getCommandInfo env cmd =
Just info -> return info Just info -> return info
Nothing -> fail $ "command not found: " ++ cmd Nothing -> fail $ "command not found: " ++ cmd
checkOpts :: CommandInfo env -> [Option] -> Either String () --checkOpts :: CommandInfo env -> [Option] -> Either String ()
checkOpts info opts = checkOpts info opts =
case case
[o | OOpt o <- opts, notElem o ("tr" : map fst (options info))] ++ [o | OOpt o <- opts, notElem o ("tr" : map fst (options info))] ++
@@ -114,12 +101,11 @@ checkOpts info opts =
getCommandTrees env needsTypeCheck a es = getCommandTrees env needsTypeCheck a es =
case a of case a of
AMacro m -> case Map.lookup m (expmacros env) of AMacro m -> case Map.lookup m (expmacros env) of
Just e -> return [e] Just e -> one e
_ -> return [] _ -> return [] -- report error?
AExpr e -> if needsTypeCheck AExpr e -> if needsTypeCheck
then case typeCheckArg (pgfenv env) e of then one =<< typeCheckArg e
Left tcErr -> fail $ render tcErr else one e
Right e -> return [e] -- ignore piped
else return [e]
ANoArg -> return es -- use piped 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 -- | Commands requiring source grammar in env
module GF.Command.SourceCommands(sourceCommands) where module GF.Command.SourceCommands(HasGrammar(..),sourceCommands) where
import Prelude hiding (putStrLn) import Prelude hiding (putStrLn)
import qualified Prelude as P(putStrLn) import qualified Prelude as P(putStrLn)
import Data.List(nub,isInfixOf) import Data.List(nub,isInfixOf)
import qualified Data.ByteString.UTF8 as UTF8(fromString) import qualified Data.ByteString.UTF8 as UTF8(fromString)
import qualified Data.Map as Map import qualified Data.Map as Map
import GF.Infra.SIO import GF.Infra.SIO(MonadSIO(..),restricted)
import GF.Infra.Option(noOptions) import GF.Infra.Option(noOptions)
import GF.Data.Operations (chunks,err,raise) import GF.Data.Operations (chunks,err,raise)
import GF.Text.Pretty(render) 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.Abstract(Option(..),isOpt,listFlags,valueString,valStrOpts)
import GF.Command.CommandInfo 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 [ sourceCommands = Map.fromList [
("cc", emptyCommandInfo { ("cc", emptyCommandInfo {
longname = "compute_concrete", longname = "compute_concrete",
@@ -152,9 +156,11 @@ sourceCommands = Map.fromList [
}) })
] ]
where 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 case runP pExp (UTF8.fromString s) of
Left (_,msg) -> return $ pipeMessage msg Left (_,msg) -> return $ pipeMessage msg
Right t -> return $ err pipeMessage Right t -> return $ err pipeMessage
@@ -176,7 +182,7 @@ sourceCommands = Map.fromList [
OOpt "qual" -> pOpts style Qualified os OOpt "qual" -> pOpts style Qualified os
_ -> pOpts style q os _ -> pOpts style q os
show_deps sgr os xs = do show_deps os xs sgr = do
ops <- case xs of ops <- case xs of
_:_ -> do _:_ -> do
let ts = [t | Right t <- map (runP pExp . UTF8.fromString) xs] let ts = [t | Right t <- map (runP pExp . UTF8.fromString) xs]
@@ -192,7 +198,7 @@ sourceCommands = Map.fromList [
| otherwise = unwords $ map prTerm ops | otherwise = unwords $ map prTerm ops
return $ fromString printed return $ fromString printed
show_operations sgr os ts = show_operations os ts sgr =
case greatestResource sgr of case greatestResource sgr of
Nothing -> return $ fromString "no source grammar in scope; did you import with -retain?" Nothing -> return $ fromString "no source grammar in scope; did you import with -retain?"
Just mo -> do Just mo -> do
@@ -211,7 +217,7 @@ sourceCommands = Map.fromList [
let printed = [unwords [showIdent op, ":", printer ty] | (op,ty) <- sigs] let printed = [unwords [showIdent op, ":", printer ty] | (op,ty) <- sigs]
return . fromString $ unlines [l | l <- printed, all (`isInfixOf` l) greps] 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 strip = if isOpt "strip" os then stripSourceGrammar else id
let mygr = strip $ case ts of let mygr = strip $ case ts of
_:_ -> mGrammar [(i,m) | (i,m) <- modules sgr, elem (render i) ts] _:_ -> mGrammar [(i,m) | (i,m) <- modules sgr, elem (render i) ts]
@@ -236,7 +242,7 @@ sourceCommands = Map.fromList [
_ -> return . fromString $ render mygr _ -> return . fromString $ render mygr
dependency_graph sgr opts ws = dependency_graph opts ws sgr =
do let stop = case valStrOpts "only" "" opts of do let stop = case valStrOpts "only" "" opts of
"" -> Nothing "" -> Nothing
fs -> Just $ chunks ',' fs fs -> Just $ chunks ',' fs

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

@@ -20,7 +20,7 @@ module GF.Data.Operations (
lookupErr, lookupErr,
-- ** Error monad class -- ** Error monad class
ErrorMonad(..), checks, doUntil, --allChecks, checkAgain, ErrorMonad(..), checks, --doUntil, allChecks, checkAgain,
liftErr, liftErr,
-- ** Checking -- ** Checking
@@ -363,10 +363,11 @@ allChecks :: ErrorMonad m => [m a] -> m [a]
allChecks ms = case ms of allChecks ms = case ms of
(m: ms) -> let rs = allChecks ms in handle_ (liftM2 (:) m rs) rs (m: ms) -> let rs = allChecks ms in handle_ (liftM2 (:) m rs) rs
_ -> return [] _ -> return []
-}
doUntil :: ErrorMonad m => (a -> Bool) -> [m a] -> m a doUntil :: ErrorMonad m => (a -> Bool) -> [m a] -> m a
doUntil cond ms = case ms of doUntil cond ms = case ms of
a:as -> do a:as -> do
v <- a v <- a
if cond v then return v else doUntil cond as if cond v then return v else doUntil cond as
_ -> raise "no result" _ -> 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.Maybe
import Data.List import Data.List
import Control.Monad (MonadPlus(..),liftM) import Control.Monad (MonadPlus(..),liftM,when)
import PGF.Utilities import PGF.Utilities
-- * functions on lists -- * functions on lists
@@ -136,6 +136,10 @@ mapBoth = map . apBoth
whenMP :: MonadPlus m => Bool -> a -> m a whenMP :: MonadPlus m => Bool -> a -> m a
whenMP b x = if b then return x else mzero 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 -- * functions on Maybes
-- | Returns true if the argument is Nothing or Just [] -- | 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 -- | 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. -- ability to capture output that normally would be sent to stdout.
{-# LANGUAGE CPP #-} {-# LANGUAGE CPP, FlexibleInstances, FlexibleContexts #-}
module GF.Infra.SIO( module GF.Infra.SIO(
-- * The SIO monad -- * The SIO monad
SIO, SIO,MonadSIO(..),
-- * Running SIO operations -- * Running SIO operations
runSIO,hRunSIO,captureSIO, runSIO,hRunSIO,captureSIO,
-- * Unrestricted, safe operations -- * Unrestricted, safe operations
@@ -25,12 +25,14 @@ module GF.Infra.SIO(
import Prelude hiding (putStrLn,print) import Prelude hiding (putStrLn,print)
import Control.Applicative(Applicative(..)) import Control.Applicative(Applicative(..))
import Control.Monad(liftM,ap) import Control.Monad(liftM,ap)
import Control.Monad.Trans(MonadTrans(..))
import System.IO(hPutStrLn,hFlush,stdout) import System.IO(hPutStrLn,hFlush,stdout)
import GF.System.Catch(try) import GF.System.Catch(try)
import System.Process(system) import System.Process(system)
import System.Environment(getEnv) import System.Environment(getEnv)
import Control.Concurrent.Chan(newChan,writeChan,getChanContents) import Control.Concurrent.Chan(newChan,writeChan,getChanContents)
import GF.Infra.Concurrency(lazyIO) import GF.Infra.Concurrency(lazyIO)
import GF.Infra.UseIO(Output(..))
import qualified System.CPUTime as IO(getCPUTime) import qualified System.CPUTime as IO(getCPUTime)
import qualified System.Directory as IO(getCurrentDirectory) import qualified System.Directory as IO(getCurrentDirectory)
import qualified System.Random as IO(newStdGen) import qualified System.Random as IO(newStdGen)
@@ -56,6 +58,19 @@ instance Monad SIO where
return x = SIO (const (return x)) return x = SIO (const (return x))
SIO m1 >>= xm2 = SIO $ \ h -> m1 h >>= \ x -> unS (xm2 x) h 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 -- * Running SIO operations
-- | Run normally -- | Run normally

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

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