GitHub/gf-core
1
0
Fork 1
mirror of https://github.com/GrammaticalFramework/gf-core.git synced 2026-05-22 17:42:51 -06:00
Code Issues Packages Projects Releases Wiki Activity

hopefully complete and correct typechecker in PGF

Browse Source
This commit is contained in:
krasimir
2009-09-06 20:31:52 +00:00
parent 26367d6a1e
commit 54dbfeef48
18 changed files with 914 additions and 492 deletions
Download Patch File Download Diff File Expand all files Collapse all files

31
src/GF/Command/Commands.hs
View File

@@ -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. &+"),

98
src/GF/Command/Interpreter.hs
View File

@@ -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)
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
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"
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

36
src/GF/Command/TreeOperations.hs
View File

@@ -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
-}