summaryrefslogtreecommitdiff
path: root/src/GF/Command
diff options
context:
space:
mode:
Diffstat (limited to 'src/GF/Command')
-rw-r--r--src/GF/Command/Commands.hs31
-rw-r--r--src/GF/Command/Interpreter.hs98
-rw-r--r--src/GF/Command/TreeOperations.hs36
3 files changed, 73 insertions, 92 deletions
diff --git a/src/GF/Command/Commands.hs b/src/GF/Command/Commands.hs
index 07d710e0a..65f64ef11 100644
--- a/src/GF/Command/Commands.hs
+++ b/src/GF/Command/Commands.hs
@@ -32,6 +32,7 @@ import GF.Command.TreeOperations ---- temporary place for typecheck and compute
import GF.Data.Operations
import GF.Text.Coding
+import Data.List
import Data.Maybe
import qualified Data.Map as Map
import System.Cmd
@@ -283,7 +284,7 @@ allCommands cod env@(pgf, mos) = Map.fromList [
_ | isOpt "changes" opts -> changesMsg
_ | isOpt "coding" opts -> codingMsg
_ | isOpt "license" opts -> licenseMsg
- [t] -> let co = getCommandOp (showExpr t) in
+ [t] -> let co = getCommandOp (showExpr [] t) in
case lookCommand co (allCommands cod env) of ---- new map ??!!
Just info -> commandHelp True (co,info)
_ -> "command not found"
@@ -615,23 +616,29 @@ allCommands cod env@(pgf, mos) = Map.fromList [
],
exec = \opts arg -> do
case arg of
- [EVar id] -> case Map.lookup id (funs (abstract pgf)) of
+ [EFun id] -> case Map.lookup id (funs (abstract pgf)) of
Just (ty,_,eqs) -> return $ fromString $
- render (text "fun" <+> text (prCId id) <+> colon <+> ppType 0 ty $$
+ render (text "fun" <+> text (prCId id) <+> colon <+> ppType 0 [] ty $$
if null eqs
then empty
- else text "def" <+> vcat [text (prCId id) <+> hsep (map (ppPatt 9) patts) <+> char '=' <+> ppExpr 0 res | Equ patts res <- eqs])
+ else text "def" <+> vcat [let (scope,ds) = mapAccumL (ppPatt 9) [] patts
+ in text (prCId id) <+> hsep ds <+> char '=' <+> ppExpr 0 scope res | Equ patts res <- eqs])
Nothing -> case Map.lookup id (cats (abstract pgf)) of
Just hyps -> do return $ fromString $
- render (text "cat" <+> text (prCId id) <+> hsep (map ppHypo hyps) $$
+ render (text "cat" <+> text (prCId id) <+> hsep (snd (mapAccumL ppHypo [] hyps)) $$
if null (functionsToCat pgf id)
then empty
else space $$
- text "fun" <+> vcat [text (prCId fid) <+> colon <+> ppType 0 ty
+ text "fun" <+> vcat [text (prCId fid) <+> colon <+> ppType 0 [] ty
| (fid,ty) <- functionsToCat pgf id])
Nothing -> do putStrLn "unknown identifier"
return void
- _ -> do putStrLn "a single identifier is expected from the command"
+ [e] -> case inferExpr pgf e of
+ Left tcErr -> error $ render (ppTcError tcErr)
+ Right (e,ty) -> do putStrLn ("Expression: "++showExpr [] e)
+ putStrLn ("Type: "++showType [] ty)
+ return void
+ _ -> do putStrLn "a single identifier or expression is expected from the command"
return void
})
]
@@ -689,7 +696,9 @@ allCommands cod env@(pgf, mos) = Map.fromList [
optType opts =
let str = valStrOpts "cat" (prCId $ lookStartCat pgf) opts
in case readType str of
- Just ty -> ty
+ Just ty -> case checkType pgf ty of
+ Left tcErr -> error $ render (ppTcError tcErr)
+ Right ty -> ty
Nothing -> error ("Can't parse '"++str++"' as type")
optComm opts = valStrOpts "command" "" opts
optViewFormat opts = valStrOpts "format" "png" opts
@@ -710,10 +719,10 @@ allCommands cod env@(pgf, mos) = Map.fromList [
returnFromExprs es = return $ case es of
[] -> ([], "no trees found")
- _ -> (es,unlines (map showExpr es))
+ _ -> (es,unlines (map (showExpr []) es))
prGrammar opts
- | isOpt "cats" opts = return $ fromString $ unwords $ map showType $ categories pgf
+ | isOpt "cats" opts = return $ fromString $ unwords $ map (showType []) $ categories pgf
| isOpt "fullform" opts = return $ fromString $ concatMap (prFullFormLexicon . morpho) $ optLangs opts
| isOpt "missing" opts = return $ fromString $ unlines $ [unwords (prCId la:":": map prCId cs) |
la <- optLangs opts, let cs = missingLins pgf la]
@@ -739,7 +748,7 @@ allCommands cod env@(pgf, mos) = Map.fromList [
showAsString t = case t of
ELit (LStr s) -> s
- _ -> "\n" ++ showExpr t --- newline needed in other cases than the first
+ _ -> "\n" ++ showExpr [] t --- newline needed in other cases than the first
stringOpOptions = sort $ [
("bind","bind tokens separated by Prelude.BIND, i.e. &+"),
diff --git a/src/GF/Command/Interpreter.hs b/src/GF/Command/Interpreter.hs
index 23b928ed6..2ace4cde6 100644
--- a/src/GF/Command/Interpreter.hs
+++ b/src/GF/Command/Interpreter.hs
@@ -12,14 +12,13 @@ import GF.Command.Abstract
import GF.Command.Parse
import PGF
import PGF.Data
-import PGF.Macros
import PGF.Morphology
import GF.System.Signal
import GF.Infra.UseIO
import GF.Infra.Option
-import GF.Data.ErrM ----
-
+import Text.PrettyPrint
+import Control.Monad.Error
import qualified Data.Map as Map
data CommandEnv = CommandEnv {
@@ -43,12 +42,6 @@ interpretCommandLine enc env line =
case readCommandLine line of
Just [] -> return ()
Just pipes -> mapM_ (interpretPipe enc env) pipes
-{-
- Just pipes -> do res <- runInterruptibly (mapM_ (interpretPipe enc env) pipes)
- case res of
- Left ex -> putStrLnFlush $ enc (show ex)
- Right x -> return x
--}
Nothing -> putStrLnFlush "command not parsed"
interpretPipe enc env cs = do
@@ -60,12 +53,15 @@ interpretPipe enc env cs = do
intercs (trees,_) (c:cs) = do
treess2 <- interc trees c
intercs treess2 cs
- interc es comm@(Command co _ arg) = case co of
+ interc es comm@(Command co opts arg) = case co of
'%':f -> case Map.lookup f (commandmacros env) of
- Just css -> do
- mapM_ (interpretPipe enc env) (appLine (getCommandArg env arg es) css)
- return ([],[]) ---- return ?
- _ -> do
+ Just css ->
+ case getCommandTrees env arg es of
+ Right es -> do mapM_ (interpretPipe enc env) (appLine es css)
+ return ([],[])
+ Left msg -> do putStrLn ('\n':msg)
+ return ([],[])
+ Nothing -> do
putStrLn $ "command macro " ++ co ++ " not interpreted"
return ([],[])
_ -> interpret enc env es comm
@@ -82,43 +78,53 @@ appCommand xs c@(Command i os arg) = case arg of
EApp e1 e2 -> EApp (app e1) (app e2)
ELit l -> ELit l
EMeta i -> xs !! i
- EVar x -> EVar x
+ EFun x -> EFun x
-- return the trees to be sent in pipe, and the output possibly printed
interpret :: (String -> String) -> CommandEnv -> [Expr] -> Command -> IO CommandOutput
-interpret enc env trees0 comm = case lookCommand co comms of
- Just info -> do
- checkOpts info
- tss@(_,s) <- exec info opts trees
- optTrace $ enc s
- return tss
- _ -> do
- putStrLn $ "command " ++ co ++ " not interpreted"
- return ([],[])
- where
- optTrace = if isOpt "tr" opts then putStrLn else const (return ())
- (co,opts,trees) = getCommand env comm trees0
- comms = commands env
- checkOpts info =
- case
- [o | OOpt o <- opts, notElem o ("tr" : map fst (options info))] ++
- [o | OFlag o _ <- opts, notElem o (map fst (flags info))]
- of
- [] -> return ()
- [o] -> putStrLn $ "option not interpreted: " ++ o
- os -> putStrLn $ "options not interpreted: " ++ unwords os
+interpret enc env trees comm =
+ case getCommand env trees comm of
+ Left msg -> do putStrLn ('\n':msg)
+ return ([],[])
+ Right (info,opts,trees) -> do tss@(_,s) <- exec info opts trees
+ if isOpt "tr" opts
+ then putStrLn (enc s)
+ else return ()
+ return tss
-- analyse command parse tree to a uniform datastructure, normalizing comm name
--- the env is needed for macro lookup
-getCommand :: CommandEnv -> Command -> [Expr] -> (String,[Option],[Expr])
-getCommand env co@(Command c opts arg) ts =
- (getCommandOp c,opts,getCommandArg env arg ts)
+getCommand :: CommandEnv -> [Expr] -> Command -> Either String (CommandInfo,[Option],[Expr])
+getCommand env es co@(Command c opts arg) = do
+ info <- getCommandInfo env c
+ checkOpts info opts
+ es <- getCommandTrees env arg es
+ return (info,opts,es)
+
+getCommandInfo :: CommandEnv -> String -> Either String CommandInfo
+getCommandInfo env cmd =
+ case lookCommand (getCommandOp cmd) (commands env) of
+ Just info -> return info
+ Nothing -> fail $ "command " ++ cmd ++ " not interpreted"
-getCommandArg :: CommandEnv -> Argument -> [Expr] -> [Expr]
-getCommandArg env a ts = case a of
- AMacro m -> case Map.lookup m (expmacros env) of
- Just t -> [t]
- _ -> []
- AExpr t -> [t] -- ignore piped
- ANoArg -> ts -- use piped
+checkOpts :: CommandInfo -> [Option] -> Either String ()
+checkOpts info opts =
+ case
+ [o | OOpt o <- opts, notElem o ("tr" : map fst (options info))] ++
+ [o | OFlag o _ <- opts, notElem o (map fst (flags info))]
+ of
+ [] -> return ()
+ [o] -> fail $ "option not interpreted: " ++ o
+ os -> fail $ "options not interpreted: " ++ unwords os
+getCommandTrees :: CommandEnv -> Argument -> [Expr] -> Either String [Expr]
+getCommandTrees env a es =
+ case a of
+ AMacro m -> case Map.lookup m (expmacros env) of
+ Just e -> return [e]
+ _ -> return []
+ AExpr e -> case inferExpr (multigrammar env) e of
+ Left tcErr -> fail $ render (ppTcError tcErr)
+ Right (e,ty) -> return [e] -- ignore piped
+ ANoArg -> return es -- use piped
+
diff --git a/src/GF/Command/TreeOperations.hs b/src/GF/Command/TreeOperations.hs
index 262ce35b5..45f927afc 100644
--- a/src/GF/Command/TreeOperations.hs
+++ b/src/GF/Command/TreeOperations.hs
@@ -20,9 +20,7 @@ allTreeOps pgf = [
("paraphrase",("paraphrase by using semantic definitions (def)",
map tree2expr . nub . concatMap (paraphrase pgf . expr2tree))),
("smallest",("sort trees from smallest to largest, in number of nodes",
- smallest)),
- ("typecheck",("type check and solve metavariables; reject if incorrect",
- concatMap (typecheck pgf)))
+ smallest))
]
smallest :: [Expr] -> [Expr]
@@ -31,35 +29,3 @@ smallest = sortBy (\t u -> compare (size t) (size u)) where
EAbs _ e -> size e + 1
EApp e1 e2 -> size e1 + size e2 + 1
_ -> 1
-
-{-
-toTree :: G.Term -> Tree
-toTree t = case M.termForm t of
- Ok (xx,f,aa) -> Abs xx (Fun f (map toTree aa))
-
-fromTree :: Tree -> G.Term
-fromTree t = case t of
- Abs xx b -> M.mkAbs xx (fromTree b)
- Var x -> M.vr x
- Fun f ts -> M.mkApp f (map fromTree ts)
--}
-
-{-
-data Tree =
- Abs [CId] Tree -- ^ lambda abstraction. The list of variables is non-empty
- | Var CId -- ^ variable
- | Fun CId [Tree] -- ^ function application
- | Lit Literal -- ^ literal
- | Meta Int -- ^ meta variable
-
-data Literal =
- LStr String -- ^ string constant
- | LInt Integer -- ^ integer constant
- | LFlt Double -- ^ floating point constant
-
-mkType :: A.Type -> C.Type
-mkType t = case GM.typeForm t of
- Ok (hyps,(_,cat),args) -> C.DTyp (mkContext hyps) (i2i cat) (map mkExp args)
-
-mkExp :: A.Term -> C.Expr
--}
generated by cgit v1.2.3 (git 2.39.1) at 2026-05-20 21:58:36 +0000