GitHub/gf-core
1
0
Fork 1
mirror of https://github.com/GrammaticalFramework/gf-core.git synced 2026-05-23 09:52:55 -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
-}

6
src/GF/Compile/GFCCtoProlog.hs
View File

@@ -68,7 +68,7 @@ plAbstract (name, Abstr aflags funs cats _catfuns) =
plCat :: (CId, [Hypo]) -> String
plCat (cat, hypos) = plFact "cat" (plTypeWithHypos typ)
where ((_,subst), hypos') = alphaConvert emptyEnv hypos
args = reverse [EVar x | (_,x) <- subst]
args = reverse [EFun x | (_,x) <- subst]
typ = DTyp hypos' cat args
plFun :: (CId, (Type, Int, [Equation])) -> String
@@ -119,7 +119,7 @@ instance PLPrint Hypo where
plp (HypV var typ) = plOper ":" (plp var) (plp typ)
instance PLPrint Expr where
plp (EVar x) = plp x
plp (EFun x) = plp x
plp (EAbs x e) = plOper "^" (plp x) (plp e)
plp (EApp e e') = plOper " * " (plp e) (plp e')
plp (ELit lit) = plp lit
@@ -279,7 +279,7 @@ instance AlphaConvert Expr where
alphaConvert env (EApp e1 e2) = (env'', EApp e1' e2')
where (env', e1') = alphaConvert env e1
(env'', e2') = alphaConvert env' e2
alphaConvert env expr@(EVar i) = (env, maybe expr EVar (lookup i (snd env)))
alphaConvert env expr@(EFun i) = (env, maybe expr EFun (lookup i (snd env)))
alphaConvert env expr = (env, expr)
-- pattern variables are not alpha converted

53
src/GF/Compile/GrammarToGFCC.hs
View File

@@ -70,17 +70,17 @@ canon2gfcc opts pars cgr@(M.MGrammar ((a,abm):cms)) =
gflags = Map.empty
aflags = Map.fromList [(mkCId f,x) | (f,x) <- optionsPGF (M.flags abm)]
mkDef (Just eqs) = [C.Equ (map mkPatt ps) (mkExp e) | (ps,e) <- eqs]
mkDef (Just eqs) = [C.Equ ps' (mkExp scope' e) | (ps,e) <- eqs, let (scope',ps') = mapAccumL mkPatt [] ps]
mkDef Nothing = []
mkArrity (Just a) = a
mkArrity Nothing = 0
-- concretes
lfuns = [(f', (mkType ty, mkArrity ma, mkDef pty)) |
lfuns = [(f', (mkType [] ty, mkArrity ma, mkDef pty)) |
(f,AbsFun (Just ty) ma pty) <- tree2list (M.jments abm), let f' = i2i f]
funs = Map.fromAscList lfuns
lcats = [(i2i c, mkContext cont) |
lcats = [(i2i c, snd (mkContext [] cont)) |
(c,AbsCat (Just cont) _) <- tree2list (M.jments abm)]
cats = Map.fromAscList lcats
catfuns = Map.fromList
@@ -118,36 +118,45 @@ canon2gfcc opts pars cgr@(M.MGrammar ((a,abm):cms)) =
i2i :: Ident -> CId
i2i = CId . ident2bs
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)
mkType :: [Ident] -> A.Type -> C.Type
mkType scope t =
case GM.typeForm t of
Ok (hyps,(_,cat),args) -> let (scope',hyps') = mkContext scope hyps
in C.DTyp hyps' (i2i cat) (map (mkExp scope') args)
mkExp :: A.Term -> C.Expr
mkExp t = case GM.termForm t of
Ok (xs,c,args) -> mkAbs xs (mkApp c (map mkExp args))
mkExp :: [Ident] -> A.Term -> C.Expr
mkExp scope t = case GM.termForm t of
Ok (xs,c,args) -> mkAbs xs (mkApp (reverse xs++scope) c (map (mkExp scope) args))
where
mkAbs xs t = foldr (C.EAbs . i2i) t xs
mkApp c args = case c of
Q _ c -> foldl C.EApp (C.EVar (i2i c)) args
QC _ c -> foldl C.EApp (C.EVar (i2i c)) args
Vr x -> C.EVar (i2i x)
mkApp scope c args = case c of
Q _ c -> foldl C.EApp (C.EFun (i2i c)) args
QC _ c -> foldl C.EApp (C.EFun (i2i c)) args
Vr x -> case lookup x (zip scope [0..]) of
Just i -> foldl C.EApp (C.EVar i) args
Nothing -> foldl C.EApp (C.EMeta 0) args
EInt i -> C.ELit (C.LInt i)
EFloat f -> C.ELit (C.LFlt f)
K s -> C.ELit (C.LStr s)
Meta (MetaSymb i) -> C.EMeta i
_ -> C.EMeta 0
mkPatt p = case p of
A.PP _ c ps -> C.PApp (i2i c) (map mkPatt ps)
A.PV x -> C.PVar (i2i x)
A.PW -> C.PWild
A.PInt i -> C.PLit (C.LInt i)
A.PFloat f -> C.PLit (C.LFlt f)
A.PString s -> C.PLit (C.LStr s)
mkPatt scope p =
case p of
A.PP _ c ps -> let (scope',ps') = mapAccumL mkPatt scope ps
in (scope',C.PApp (i2i c) ps')
A.PV x -> (x:scope,C.PVar (i2i x))
A.PW -> ( scope,C.PWild)
A.PInt i -> ( scope,C.PLit (C.LInt i))
A.PFloat f -> ( scope,C.PLit (C.LFlt f))
A.PString s -> ( scope,C.PLit (C.LStr s))
mkContext :: A.Context -> [C.Hypo]
mkContext hyps = [(if x == identW then C.Hyp else C.HypV (i2i x)) (mkType ty) | (x,ty) <- hyps]
mkContext :: [Ident] -> A.Context -> ([Ident],[C.Hypo])
mkContext scope hyps = mapAccumL (\scope (x,ty) -> let ty' = mkType scope ty
in if x == identW
then ( scope,C.Hyp ty')
else (x:scope,C.HypV (i2i x) ty')) scope hyps
mkTerm :: Term -> C.Term
mkTerm tr = case tr of