msyds/gf-core
1
0
Fork 0
forked from GitHub/gf-core
Code Pull Requests Activity

polish the PGF API and make Expr and Type abstract types. Tree is a type synonym of Expr

Browse Source
This commit is contained in:
krasimir
2009-09-11 13:45:34 +00:00
parent 7a13751a10
commit d294b70395
31 changed files with 205 additions and 159 deletions
Download Patch File Download Diff File Expand all files Collapse all files

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

@@ -615,18 +615,18 @@ allCommands cod env@(pgf, mos) = Map.fromList [
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 (ty,_,eqs) -> return $ fromString $ Just (ty,_,eqs) -> return $ fromString $
render (text "fun" <+> text (prCId id) <+> colon <+> ppType 0 [] ty $$ render (text "fun" <+> ppCId id <+> colon <+> ppType 0 [] ty $$
if null eqs if null eqs
then empty then empty
else text "def" <+> vcat [let (scope,ds) = mapAccumL (ppPatt 9) [] patts 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]) in ppCId id <+> hsep ds <+> char '=' <+> ppExpr 0 scope res | Equ patts res <- eqs])
Nothing -> case Map.lookup id (cats (abstract pgf)) of Nothing -> case Map.lookup id (cats (abstract pgf)) of
Just hyps -> do return $ fromString $ Just hyps -> do return $ fromString $
render (text "cat" <+> text (prCId id) <+> hsep (snd (mapAccumL ppHypo [] hyps)) $$ render (text "cat" <+> ppCId id <+> hsep (snd (mapAccumL ppHypo [] hyps)) $$
if null (functionsToCat pgf id) if null (functionsToCat pgf id)
then empty then empty
else space $$ else space $$
text "fun" <+> vcat [text (prCId fid) <+> colon <+> ppType 0 [] ty text "fun" <+> vcat [ppCId fid <+> colon <+> ppType 0 [] ty
| (fid,ty) <- functionsToCat pgf id]) | (fid,ty) <- functionsToCat pgf id])
Nothing -> do putStrLn "unknown identifier" Nothing -> do putStrLn "unknown identifier"
return void return void
@@ -647,8 +647,8 @@ allCommands cod env@(pgf, mos) = Map.fromList [
optLin opts t = unlines $ optLin opts t = unlines $
case opts of case opts of
_ | isOpt "treebank" opts -> (prCId (abstractName pgf) ++ ": " ++ showExpr [] t) : _ | isOpt "treebank" opts -> (showCId (abstractName pgf) ++ ": " ++ showExpr [] t) :
[prCId lang ++ ": " ++ linear opts lang t | lang <- optLangs opts] [showCId lang ++ ": " ++ linear opts lang t | lang <- optLangs opts]
_ -> [linear opts lang t | lang <- optLangs opts] _ -> [linear opts lang t | lang <- optLangs opts]
linear :: [Option] -> CId -> Expr -> String linear :: [Option] -> CId -> Expr -> String
@@ -689,7 +689,7 @@ allCommands cod env@(pgf, mos) = Map.fromList [
lang -> map mkCId (chunks ',' lang) lang -> map mkCId (chunks ',' lang)
optLang opts = head $ optLangs opts ++ [wildCId] optLang opts = head $ optLangs opts ++ [wildCId]
optType opts = optType opts =
let str = valStrOpts "cat" (prCId $ lookStartCat pgf) opts let str = valStrOpts "cat" (showCId $ lookStartCat pgf) opts
in case readType str of in case readType str of
Just ty -> case checkType pgf ty of Just ty -> case checkType pgf ty of
Left tcErr -> error $ render (ppTcError tcErr) Left tcErr -> error $ render (ppTcError tcErr)
@@ -714,7 +714,7 @@ allCommands cod env@(pgf, mos) = Map.fromList [
prGrammar opts 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 "fullform" opts = return $ fromString $ concatMap (prFullFormLexicon . morpho) $ optLangs opts
| isOpt "missing" opts = return $ fromString $ unlines $ [unwords (prCId la:":": map prCId cs) | | isOpt "missing" opts = return $ fromString $ unlines $ [unwords (showCId la:":": map showCId cs) |
la <- optLangs opts, let cs = missingLins pgf la] la <- optLangs opts, let cs = missingLins pgf la]
| otherwise = do fmt <- readOutputFormat (valStrOpts "printer" "pgf_pretty" opts) | otherwise = do fmt <- readOutputFormat (valStrOpts "printer" "pgf_pretty" opts)
return $ fromString $ concatMap snd $ exportPGF noOptions fmt pgf return $ fromString $ concatMap snd $ exportPGF noOptions fmt pgf

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

@@ -5,6 +5,7 @@ module GF.Command.TreeOperations (
import GF.Compile.TypeCheck import GF.Compile.TypeCheck
import PGF import PGF
import PGF.Data
import Data.List import Data.List

4
src/GF/Compile/Export.hs
View File

@@ -48,13 +48,13 @@ exportPGF opts fmt pgf =
FmtRegExp -> single "rexp" regexpPrinter FmtRegExp -> single "rexp" regexpPrinter
FmtFA -> single "dot" slfGraphvizPrinter FmtFA -> single "dot" slfGraphvizPrinter
where where
name = fromMaybe (prCId (absname pgf)) (flag optName opts) name = fromMaybe (showCId (absname pgf)) (flag optName opts)
multi :: String -> (PGF -> String) -> [(FilePath,String)] multi :: String -> (PGF -> String) -> [(FilePath,String)]
multi ext pr = [(name <.> ext, pr pgf)] multi ext pr = [(name <.> ext, pr pgf)]
single :: String -> (PGF -> CId -> String) -> [(FilePath,String)] single :: String -> (PGF -> CId -> String) -> [(FilePath,String)]
single ext pr = [(prCId cnc <.> ext, pr pgf cnc) | cnc <- cncnames pgf] single ext pr = [(showCId cnc <.> ext, pr pgf cnc) | cnc <- cncnames pgf]
-- | Get the name of the concrete syntax to generate output from. -- | Get the name of the concrete syntax to generate output from.
-- FIXME: there should be an option to change this. -- FIXME: there should be an option to change this.

4
src/GF/Compile/GFCCtoHaskell.hs
View File

@@ -193,8 +193,8 @@ fInstance gId lexical m (cat,rules) =
--type HSkeleton = [(OIdent, [(OIdent, [OIdent])])] --type HSkeleton = [(OIdent, [(OIdent, [OIdent])])]
hSkeleton :: PGF -> (String,HSkeleton) hSkeleton :: PGF -> (String,HSkeleton)
hSkeleton gr = hSkeleton gr =
(prCId (absname gr), (showCId (absname gr),
[(prCId c, [(prCId f, map prCId cs) | (f, (cs,_)) <- fs]) | [(showCId c, [(showCId f, map showCId cs) | (f, (cs,_)) <- fs]) |
fs@((_, (_,c)):_) <- fns] fs@((_, (_,c)):_) <- fns]
) )
where where

20
src/GF/Compile/GFCCtoJS.hs
View File

@@ -23,10 +23,10 @@ pgf2js :: PGF -> String
pgf2js pgf = pgf2js pgf =
encodeUTF8 $ JS.printTree $ JS.Program [JS.ElStmt $ JS.SDeclOrExpr $ JS.Decl [JS.DInit (JS.Ident n) grammar]] encodeUTF8 $ JS.printTree $ JS.Program [JS.ElStmt $ JS.SDeclOrExpr $ JS.Decl [JS.DInit (JS.Ident n) grammar]]
where where
n = prCId $ absname pgf n = showCId $ absname pgf
as = abstract pgf as = abstract pgf
cs = Map.assocs (concretes pgf) cs = Map.assocs (concretes pgf)
start = prCId $ M.lookStartCat pgf start = showCId $ M.lookStartCat pgf
grammar = new "GFGrammar" [js_abstract, js_concrete] grammar = new "GFGrammar" [js_abstract, js_concrete]
js_abstract = abstract2js start as js_abstract = abstract2js start as
js_concrete = JS.EObj $ map (concrete2js start n) cs js_concrete = JS.EObj $ map (concrete2js start n) cs
@@ -37,15 +37,15 @@ abstract2js start ds = new "GFAbstract" [JS.EStr start, JS.EObj $ map absdef2js
absdef2js :: (CId,(Type,Int,[Equation])) -> JS.Property absdef2js :: (CId,(Type,Int,[Equation])) -> JS.Property
absdef2js (f,(typ,_,_)) = absdef2js (f,(typ,_,_)) =
let (args,cat) = M.catSkeleton typ in let (args,cat) = M.catSkeleton typ in
JS.Prop (JS.IdentPropName (JS.Ident (prCId f))) (new "Type" [JS.EArray [JS.EStr (prCId x) | x <- args], JS.EStr (prCId cat)]) JS.Prop (JS.IdentPropName (JS.Ident (showCId f))) (new "Type" [JS.EArray [JS.EStr (showCId x) | x <- args], JS.EStr (showCId cat)])
concrete2js :: String -> String -> (CId,Concr) -> JS.Property concrete2js :: String -> String -> (CId,Concr) -> JS.Property
concrete2js start n (c, cnc) = concrete2js start n (c, cnc) =
JS.Prop l (new "GFConcrete" ([flags,(JS.EObj $ ((map (cncdef2js n (prCId c)) ds) ++ litslins))] ++ JS.Prop l (new "GFConcrete" ([flags,(JS.EObj $ ((map (cncdef2js n (showCId c)) ds) ++ litslins))] ++
maybe [] (parser2js start) (parser cnc))) maybe [] (parser2js start) (parser cnc)))
where where
flags = mapToJSObj JS.EStr $ cflags cnc flags = mapToJSObj JS.EStr $ cflags cnc
l = JS.IdentPropName (JS.Ident (prCId c)) l = JS.IdentPropName (JS.Ident (showCId c))
ds = concatMap Map.assocs [lins cnc, opers cnc, lindefs cnc] ds = concatMap Map.assocs [lins cnc, opers cnc, lindefs cnc]
litslins = [JS.Prop (JS.StringPropName "Int") (JS.EFun [children] [JS.SReturn $ new "Arr" [JS.EIndex (JS.EVar children) (JS.EInt 0)]]), litslins = [JS.Prop (JS.StringPropName "Int") (JS.EFun [children] [JS.SReturn $ new "Arr" [JS.EIndex (JS.EVar children) (JS.EInt 0)]]),
JS.Prop (JS.StringPropName "Float") (JS.EFun [children] [JS.SReturn $ new "Arr" [JS.EIndex (JS.EVar children) (JS.EInt 0)]]), JS.Prop (JS.StringPropName "Float") (JS.EFun [children] [JS.SReturn $ new "Arr" [JS.EIndex (JS.EVar children) (JS.EInt 0)]]),
@@ -53,7 +53,7 @@ concrete2js start n (c, cnc) =
cncdef2js :: String -> String -> (CId,Term) -> JS.Property cncdef2js :: String -> String -> (CId,Term) -> JS.Property
cncdef2js n l (f, t) = JS.Prop (JS.IdentPropName (JS.Ident (prCId f))) (JS.EFun [children] [JS.SReturn (term2js n l t)]) cncdef2js n l (f, t) = JS.Prop (JS.IdentPropName (JS.Ident (showCId f))) (JS.EFun [children] [JS.SReturn (term2js n l t)])
term2js :: String -> String -> Term -> JS.Expr term2js :: String -> String -> Term -> JS.Expr
term2js n l t = f t term2js n l t = f t
@@ -66,7 +66,7 @@ term2js n l t = f t
K t -> tokn2js t K t -> tokn2js t
V i -> JS.EIndex (JS.EVar children) (JS.EInt i) V i -> JS.EIndex (JS.EVar children) (JS.EInt i)
C i -> new "Int" [JS.EInt i] C i -> new "Int" [JS.EInt i]
F f -> JS.ECall (JS.EMember (JS.EIndex (JS.EMember (JS.EVar $ JS.Ident n) (JS.Ident "concretes")) (JS.EStr l)) (JS.Ident "rule")) [JS.EStr (prCId f), JS.EVar children] F f -> JS.ECall (JS.EMember (JS.EIndex (JS.EMember (JS.EVar $ JS.Ident n) (JS.Ident "concretes")) (JS.EStr l)) (JS.Ident "rule")) [JS.EStr (showCId f), JS.EVar children]
FV xs -> new "Variants" (map f xs) FV xs -> new "Variants" (map f xs)
W str x -> new "Suffix" [JS.EStr str, f x] W str x -> new "Suffix" [JS.EStr str, f x]
TM _ -> new "Meta" [] TM _ -> new "Meta" []
@@ -94,7 +94,7 @@ parser2js start p = [new "Parser" [JS.EStr start,
JS.EArray $ [frule2js p cat prod | (cat,set) <- IntMap.toList (productions p), prod <- Set.toList set], JS.EArray $ [frule2js p cat prod | (cat,set) <- IntMap.toList (productions p), prod <- Set.toList set],
JS.EObj $ map cats (Map.assocs (startCats p))]] JS.EObj $ map cats (Map.assocs (startCats p))]]
where where
cats (c,is) = JS.Prop (JS.IdentPropName (JS.Ident (prCId c))) (JS.EArray (map JS.EInt is)) cats (c,is) = JS.Prop (JS.IdentPropName (JS.Ident (showCId c))) (JS.EArray (map JS.EInt is))
frule2js :: ParserInfo -> FCat -> Production -> JS.Expr frule2js :: ParserInfo -> FCat -> Production -> JS.Expr
frule2js p res (FApply funid args) = new "Rule" [JS.EInt res, name2js (f,ps), JS.EArray (map JS.EInt args), lins2js p lins] frule2js p res (FApply funid args) = new "Rule" [JS.EInt res, name2js (f,ps), JS.EArray (map JS.EInt args), lins2js p lins]
@@ -114,7 +114,7 @@ frule2js p res (FCoerce arg) = new "Rule" [JS.EInt res, daughter 0, JS.EArray [J
name2js :: (CId,[Profile]) -> JS.Expr name2js :: (CId,[Profile]) -> JS.Expr
name2js (f,ps) = new "FunApp" $ [JS.EStr $ prCId f, JS.EArray (map fromProfile ps)] name2js (f,ps) = new "FunApp" $ [JS.EStr $ showCId f, JS.EArray (map fromProfile ps)]
where where
fromProfile :: Profile -> JS.Expr fromProfile :: Profile -> JS.Expr
fromProfile [] = new "MetaVar" [] fromProfile [] = new "MetaVar" []
@@ -135,4 +135,4 @@ new :: String -> [JS.Expr] -> JS.Expr
new f xs = JS.ENew (JS.Ident f) xs new f xs = JS.ENew (JS.Ident f) xs
mapToJSObj :: (a -> JS.Expr) -> Map CId a -> JS.Expr mapToJSObj :: (a -> JS.Expr) -> Map CId a -> JS.Expr
mapToJSObj f m = JS.EObj [ JS.Prop (JS.IdentPropName (JS.Ident (prCId k))) (f v) | (k,v) <- Map.toList m ] mapToJSObj f m = JS.EObj [ JS.Prop (JS.IdentPropName (JS.Ident (showCId k))) (f v) | (k,v) <- Map.toList m ]

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

@@ -163,7 +163,7 @@ instance PLPrint CId where
plp cid | isLogicalVariable str || plp cid | isLogicalVariable str ||
cid == wildCId = plVar str cid == wildCId = plVar str
| otherwise = plAtom str | otherwise = plAtom str
where str = prCId cid where str = showCId cid
instance PLPrint Literal where instance PLPrint Literal where
plp (LStr s) = plp s plp (LStr s) = plp s

12
src/GF/Compile/GenerateFCFG.hs
View File

@@ -72,7 +72,7 @@ expandHOAS funs lins lincats = (funs' ++ hoFuns ++ varFuns,
-- lincat for the _Var category -- lincat for the _Var category
varLincat = Map.singleton varCat (R [S []]) varLincat = Map.singleton varCat (R [S []])
lincatOf c = fromMaybe (error $ "No lincat for " ++ prCId c) $ Map.lookup c lincats lincatOf c = fromMaybe (error $ "No lincat for " ++ showCId c) $ Map.lookup c lincats
modifyRec :: ([Term] -> [Term]) -> Term -> Term modifyRec :: ([Term] -> [Term]) -> Term -> Term
modifyRec f (R xs) = R (f xs) modifyRec f (R xs) = R (f xs)
@@ -82,13 +82,13 @@ expandHOAS funs lins lincats = (funs' ++ hoFuns ++ varFuns,
catName :: (Int,CId) -> CId catName :: (Int,CId) -> CId
catName (0,c) = c catName (0,c) = c
catName (n,c) = mkCId ("_" ++ show n ++ prCId c) catName (n,c) = mkCId ("_" ++ show n ++ showCId c)
funName :: (Int,CId) -> CId funName :: (Int,CId) -> CId
funName (n,c) = mkCId ("__" ++ show n ++ prCId c) funName (n,c) = mkCId ("__" ++ show n ++ showCId c)
varFunName :: CId -> CId varFunName :: CId -> CId
varFunName c = mkCId ("_Var_" ++ prCId c) varFunName c = mkCId ("_Var_" ++ showCId c)
-- replaces __NCat with _B and _Var_Cat with _. -- replaces __NCat with _B and _Var_Cat with _.
-- the temporary names are just there to avoid name collisions. -- the temporary names are just there to avoid name collisions.
@@ -404,7 +404,7 @@ genFCatArg cnc_defs ctype env@(GrammarEnv last_id catSet seqSet funSet prodSet)
addConstraint path0 index0 cs = (path0,index0) : cs addConstraint path0 index0 cs = (path0,index0) : cs
gen_tcs (F id) path acc = case Map.lookup id cnc_defs of gen_tcs (F id) path acc = case Map.lookup id cnc_defs of
Just term -> gen_tcs term path acc Just term -> gen_tcs term path acc
Nothing -> error ("unknown identifier: "++prCId id) Nothing -> error ("unknown identifier: "++showCId id)
@@ -463,7 +463,7 @@ mkSingletonSelectors cnc_defs term = sels0
loop path (sels,tcss) (S _) = (mkSelector [path] tcss0 : sels, tcss) loop path (sels,tcss) (S _) = (mkSelector [path] tcss0 : sels, tcss)
loop path (sels,tcss) (F id) = case Map.lookup id cnc_defs of loop path (sels,tcss) (F id) = case Map.lookup id cnc_defs of
Just term -> loop path (sels,tcss) term Just term -> loop path (sels,tcss) term
Nothing -> error ("unknown identifier: "++prCId id) Nothing -> error ("unknown identifier: "++showCId id)
mkSelector :: [FPath] -> [[(FPath,FIndex)]] -> TermSelector mkSelector :: [FPath] -> [[(FPath,FIndex)]] -> TermSelector
mkSelector rcs tcss = mkSelector rcs tcss =

12
src/GF/Compile/GeneratePMCFG.hs
View File

@@ -281,13 +281,13 @@ convertTerm cnc_defs sel ctype (K (KS t)) = return (Str [FSymKS [t]])
convertTerm cnc_defs sel ctype (K (KP s v))=return (Str [FSymKP s v]) convertTerm cnc_defs sel ctype (K (KP s v))=return (Str [FSymKP s v])
convertTerm cnc_defs sel ctype (F id) = case Map.lookup id cnc_defs of convertTerm cnc_defs sel ctype (F id) = case Map.lookup id cnc_defs of
Just term -> convertTerm cnc_defs sel ctype term Just term -> convertTerm cnc_defs sel ctype term
Nothing -> error ("unknown id " ++ prCId id) Nothing -> error ("unknown id " ++ showCId id)
convertTerm cnc_defs sel ctype (W s t) = do convertTerm cnc_defs sel ctype (W s t) = do
ss <- case t of ss <- case t of
R ss -> return ss R ss -> return ss
F f -> case Map.lookup f cnc_defs of F f -> case Map.lookup f cnc_defs of
Just (R ss) -> return ss Just (R ss) -> return ss
_ -> error ("unknown id " ++ prCId f) _ -> error ("unknown id " ++ showCId f)
convertRec cnc_defs sel ctype [K (KS (s ++ s1)) | K (KS s1) <- ss] convertRec cnc_defs sel ctype [K (KS (s ++ s1)) | K (KS s1) <- ss]
convertTerm cnc_defs sel ctype x = error ("convertTerm ("++show x++")") convertTerm cnc_defs sel ctype x = error ("convertTerm ("++show x++")")
@@ -331,7 +331,7 @@ evalTerm cnc_defs path (P term sel) = do index <- evalTerm cnc_defs [] sel
evalTerm cnc_defs path (FV terms) = variants terms >>= evalTerm cnc_defs path evalTerm cnc_defs path (FV terms) = variants terms >>= evalTerm cnc_defs path
evalTerm cnc_defs path (F id) = case Map.lookup id cnc_defs of evalTerm cnc_defs path (F id) = case Map.lookup id cnc_defs of
Just term -> evalTerm cnc_defs path term Just term -> evalTerm cnc_defs path term
Nothing -> error ("unknown id " ++ prCId id) Nothing -> error ("unknown id " ++ showCId id)
evalTerm cnc_defs path x = error ("evalTerm ("++show x++")") evalTerm cnc_defs path x = error ("evalTerm ("++show x++")")
@@ -361,7 +361,7 @@ emptyGrammarEnv cnc_defs lincats =
getMultipliers m ms (C max_index) = (m*(max_index+1),m : ms) getMultipliers m ms (C max_index) = (m*(max_index+1),m : ms)
getMultipliers m ms (F id) = case Map.lookup id cnc_defs of getMultipliers m ms (F id) = case Map.lookup id cnc_defs of
Just term -> getMultipliers m ms term Just term -> getMultipliers m ms term
Nothing -> error ("unknown identifier: "++prCId id) Nothing -> error ("unknown identifier: "++showCId id)
expandHOAS abs_defs cnc_defs lincats env = expandHOAS abs_defs cnc_defs lincats env =
foldl add_varFun (foldl (\env ncat -> add_hoFun (add_hoCat env ncat) ncat) env hoTypes) hoCats foldl add_varFun (foldl (\env ncat -> add_hoFun (add_hoCat env ncat) ncat) env hoTypes) hoCats
@@ -400,7 +400,7 @@ expandHOAS abs_defs cnc_defs lincats env =
in env3 in env3
where where
(arg,res) = case Map.lookup cat lincats of (arg,res) = case Map.lookup cat lincats of
Nothing -> error $ "No lincat for " ++ prCId cat Nothing -> error $ "No lincat for " ++ showCId cat
Just ctype -> (protoFCat cnc_defs (0,cat) ctype, protoFCat cnc_defs (n,cat) ctype) Just ctype -> (protoFCat cnc_defs (0,cat) ctype, protoFCat cnc_defs (n,cat) ctype)
-- add one PMCFG function for each high-order category: _V : Var -> Cat -- add one PMCFG function for each high-order category: _V : Var -> Cat
@@ -414,7 +414,7 @@ expandHOAS abs_defs cnc_defs lincats env =
in env3 in env3
where where
res = case Map.lookup cat lincats of res = case Map.lookup cat lincats of
Nothing -> error $ "No lincat for " ++ prCId cat Nothing -> error $ "No lincat for " ++ showCId cat
Just ctype -> protoFCat cnc_defs (0,cat) ctype Just ctype -> protoFCat cnc_defs (0,cat) ctype
_B = mkCId "_B" _B = mkCId "_B"

16
src/GF/Compile/PGFPretty.hs
View File

@@ -21,7 +21,7 @@ prPMCFGPretty :: PGF -> CId -> String
prPMCFGPretty pgf lang = render $ prPMCFGPretty pgf lang = render $
case lookParser pgf lang of case lookParser pgf lang of
Nothing -> empty Nothing -> empty
Just pinfo -> text "language" <+> text (prCId lang) $$ ppPMCFG pinfo Just pinfo -> text "language" <+> ppCId lang $$ ppPMCFG pinfo
prAbs :: Abstr -> Doc prAbs :: Abstr -> Doc
@@ -29,13 +29,13 @@ prAbs a = prAll prCat (cats a) $$ prAll prFun (funs a)
prCat :: CId -> [Hypo] -> Doc prCat :: CId -> [Hypo] -> Doc
prCat c h | isLiteralCat c = empty prCat c h | isLiteralCat c = empty
| otherwise = text "cat" <+> text (prCId c) | otherwise = text "cat" <+> ppCId c
prFun :: CId -> (Type,Int,[Equation]) -> Doc prFun :: CId -> (Type,Int,[Equation]) -> Doc
prFun f (t,_,_) = text "fun" <+> text (prCId f) <+> text ":" <+> prType t prFun f (t,_,_) = text "fun" <+> ppCId f <+> text ":" <+> prType t
prType :: Type -> Doc prType :: Type -> Doc
prType t = parens (hsep (punctuate (text ",") (map (text . prCId) cs))) <+> text "->" <+> text (prCId c) prType t = parens (hsep (punctuate (text ",") (map ppCId cs))) <+> text "->" <+> ppCId c
where (cs,c) = catSkeleton t where (cs,c) = catSkeleton t
@@ -46,14 +46,14 @@ prCnc abstr name c = prAll prLinCat (lincats c) $$ prAll prLin (lins (expand c))
where where
prLinCat :: CId -> Term -> Doc prLinCat :: CId -> Term -> Doc
prLinCat c t | isLiteralCat c = empty prLinCat c t | isLiteralCat c = empty
| otherwise = text "lincat" <+> text (prCId c) <+> text "=" <+> pr 0 t | otherwise = text "lincat" <+> ppCId c <+> text "=" <+> pr 0 t
where where
pr p (R ts) = prec p 1 (hsep (punctuate (text " *") (map (pr 1) ts))) pr p (R ts) = prec p 1 (hsep (punctuate (text " *") (map (pr 1) ts)))
pr _ (S []) = text "Str" pr _ (S []) = text "Str"
pr _ (C n) = text "Int_" <> text (show (n+1)) pr _ (C n) = text "Int_" <> text (show (n+1))
prLin :: CId -> Term -> Doc prLin :: CId -> Term -> Doc
prLin f t = text "lin" <+> text (prCId f) <+> text "=" <+> pr 0 t prLin f t = text "lin" <+> ppCId f <+> text "=" <+> pr 0 t
where where
pr :: Int -> Term -> Doc pr :: Int -> Term -> Doc
pr p (R ts) = text "<" <+> hsep (punctuate (text ",") (map (pr 0) ts)) <+> text ">" pr p (R ts) = text "<" <+> hsep (punctuate (text ",") (map (pr 0) ts)) <+> text ">"
@@ -66,7 +66,7 @@ prCnc abstr name c = prAll prLinCat (lincats c) $$ prAll prLin (lins (expand c))
pr _ t = error $ "PGFPretty.prLin " ++ show t pr _ t = error $ "PGFPretty.prLin " ++ show t
linCat :: Concr -> CId -> Term linCat :: Concr -> CId -> Term
linCat cnc c = Map.findWithDefault (error $ "lincat: " ++ prCId c) c (lincats cnc) linCat cnc c = Map.findWithDefault (error $ "lincat: " ++ showCId c) c (lincats cnc)
prec :: Int -> Int -> Doc -> Doc prec :: Int -> Int -> Doc -> Doc
prec p m | p >= m = parens prec p m | p >= m = parens
@@ -84,7 +84,7 @@ expand cnc = cnc { lins = Map.map (f "") (lins cnc) }
f w (FV ts) = FV (map (f w) ts) f w (FV ts) = FV (map (f w) ts)
f w (W s t) = f (w++s) t f w (W s t) = f (w++s) t
f w (K (KS t)) = K (KS (w++t)) f w (K (KS t)) = K (KS (w++t))
f w (F o) = f w (Map.findWithDefault (error $ "Bad oper: " ++ prCId o) o (opers cnc)) f w (F o) = f w (Map.findWithDefault (error $ "Bad oper: " ++ showCId o) o (opers cnc))
f w t = t f w t = t
-- Utilities -- Utilities

4
src/GF/Speech/CFG.hs
View File

@@ -298,12 +298,12 @@ prProductions prods =
prCFTerm :: CFTerm -> String prCFTerm :: CFTerm -> String
prCFTerm = pr 0 prCFTerm = pr 0
where where
pr p (CFObj f args) = paren p (prCId f ++ " (" ++ concat (intersperse "," (map (pr 0) args)) ++ ")") pr p (CFObj f args) = paren p (showCId f ++ " (" ++ concat (intersperse "," (map (pr 0) args)) ++ ")")
pr p (CFAbs i t) = paren p ("\\x" ++ show i ++ ". " ++ pr 0 t) pr p (CFAbs i t) = paren p ("\\x" ++ show i ++ ". " ++ pr 0 t)
pr p (CFApp t1 t2) = paren p (pr 1 t1 ++ "(" ++ pr 0 t2 ++ ")") pr p (CFApp t1 t2) = paren p (pr 1 t1 ++ "(" ++ pr 0 t2 ++ ")")
pr _ (CFRes i) = "$" ++ show i pr _ (CFRes i) = "$" ++ show i
pr _ (CFVar i) = "x" ++ show i pr _ (CFVar i) = "x" ++ show i
pr _ (CFMeta c) = "?" ++ prCId c pr _ (CFMeta c) = "?" ++ showCId c
paren 0 x = x paren 0 x = x
paren 1 x = "(" ++ x ++ ")" paren 1 x = "(" ++ x ++ ")"

6
src/GF/Speech/PGFToCFG.hs
View File

@@ -31,7 +31,7 @@ toBNF f pgf cnc = prCFG $ f $ pgfToCFG pgf cnc
pgfToCFG :: PGF pgfToCFG :: PGF
-> CId -- ^ Concrete syntax name -> CId -- ^ Concrete syntax name
-> CFG -> CFG
pgfToCFG pgf lang = mkCFG (prCId (lookStartCat pgf)) extCats (startRules ++ concatMap fruleToCFRule rules) pgfToCFG pgf lang = mkCFG (showCId (lookStartCat pgf)) extCats (startRules ++ concatMap fruleToCFRule rules)
where where
pinfo = fromMaybe (error "pgfToCFG: No parser.") (lookParser pgf lang) pinfo = fromMaybe (error "pgfToCFG: No parser.") (lookParser pgf lang)
@@ -40,7 +40,7 @@ pgfToCFG pgf lang = mkCFG (prCId (lookStartCat pgf)) extCats (startRules ++ conc
, prod <- Set.toList set] , prod <- Set.toList set]
fcatCats :: Map FCat Cat fcatCats :: Map FCat Cat
fcatCats = Map.fromList [(fc, prCId c ++ "_" ++ show i) fcatCats = Map.fromList [(fc, showCId c ++ "_" ++ show i)
| (c,fcs) <- Map.toList (startCats pinfo), | (c,fcs) <- Map.toList (startCats pinfo),
(fc,i) <- zip fcs [1..]] (fc,i) <- zip fcs [1..]]
@@ -67,7 +67,7 @@ pgfToCFG pgf lang = mkCFG (prCId (lookStartCat pgf)) extCats (startRules ++ conc
extCats = Set.fromList $ map lhsCat startRules extCats = Set.fromList $ map lhsCat startRules
startRules :: [CFRule] startRules :: [CFRule]
startRules = [CFRule (prCId c) [NonTerminal (fcatToCat fc r)] (CFRes 0) startRules = [CFRule (showCId c) [NonTerminal (fcatToCat fc r)] (CFRes 0)
| (c,fcs) <- Map.toList (startCats pinfo), | (c,fcs) <- Map.toList (startCats pinfo),
fc <- fcs, not (isLiteralFCat fc), fc <- fcs, not (isLiteralFCat fc),
r <- [0..catLinArity fc-1]] r <- [0..catLinArity fc-1]]

4
src/GF/Speech/SISR.hs
View File

@@ -50,12 +50,12 @@ catSISR t (c,i) fmt
profileFinalSISR :: CFTerm -> SISRFormat -> SISRTag profileFinalSISR :: CFTerm -> SISRFormat -> SISRTag
profileFinalSISR term fmt = [JS.DExpr $ fmtOut fmt `ass` f term] profileFinalSISR term fmt = [JS.DExpr $ fmtOut fmt `ass` f term]
where where
f (CFObj n ts) = tree (prCId n) (map f ts) f (CFObj n ts) = tree (showCId n) (map f ts)
f (CFAbs v x) = JS.EFun [var v] [JS.SReturn (f x)] f (CFAbs v x) = JS.EFun [var v] [JS.SReturn (f x)]
f (CFApp x y) = JS.ECall (f x) [f y] f (CFApp x y) = JS.ECall (f x) [f y]
f (CFRes i) = JS.EIndex (JS.EVar args) (JS.EInt (fromIntegral i)) f (CFRes i) = JS.EIndex (JS.EVar args) (JS.EInt (fromIntegral i))
f (CFVar v) = JS.EVar (var v) f (CFVar v) = JS.EVar (var v)
f (CFMeta typ) = obj [("name",JS.EStr "?"), ("type",JS.EStr (prCId typ))] f (CFMeta typ) = obj [("name",JS.EStr "?"), ("type",JS.EStr (showCId typ))]
fmtOut SISR_WD20030401 = JS.EVar (JS.Ident "$") fmtOut SISR_WD20030401 = JS.EVar (JS.Ident "$")
fmtOut SISR_1_0 = JS.EVar (JS.Ident "out") fmtOut SISR_1_0 = JS.EVar (JS.Ident "out")

4
src/GF/Speech/SRG.hs
View File

@@ -113,12 +113,12 @@ makeNonRecursiveSRG opts = mkSRG cfgToSRG id
mkSRG :: (CFG -> [SRGRule]) -> (CFG -> CFG) -> PGF -> CId -> SRG mkSRG :: (CFG -> [SRGRule]) -> (CFG -> CFG) -> PGF -> CId -> SRG
mkSRG mkRules preprocess pgf cnc = mkSRG mkRules preprocess pgf cnc =
SRG { srgName = prCId cnc, SRG { srgName = showCId cnc,
srgStartCat = cfgStartCat cfg, srgStartCat = cfgStartCat cfg,
srgExternalCats = cfgExternalCats cfg, srgExternalCats = cfgExternalCats cfg,
srgLanguage = getSpeechLanguage pgf cnc, srgLanguage = getSpeechLanguage pgf cnc,
srgRules = mkRules cfg } srgRules = mkRules cfg }
where cfg = renameCats (prCId cnc) $ preprocess $ pgfToCFG pgf cnc where cfg = renameCats (showCId cnc) $ preprocess $ pgfToCFG pgf cnc
-- | Renames all external cats C to C_cat, and all internal cats C_X (where X is any string), -- | Renames all external cats C to C_cat, and all internal cats C_X (where X is any string),
-- to C_N where N is an integer. -- to C_N where N is an integer.

18
src/GF/Speech/VoiceXML.hs
View File

@@ -29,7 +29,7 @@ import Debug.Trace
grammar2vxml :: PGF -> CId -> String grammar2vxml :: PGF -> CId -> String
grammar2vxml pgf cnc = showsXMLDoc (skel2vxml name language start skel qs) "" grammar2vxml pgf cnc = showsXMLDoc (skel2vxml name language start skel qs) ""
where skel = pgfSkeleton pgf where skel = pgfSkeleton pgf
name = prCId cnc name = showCId cnc
qs = catQuestions pgf cnc (map fst skel) qs = catQuestions pgf cnc (map fst skel)
language = getSpeechLanguage pgf cnc language = getSpeechLanguage pgf cnc
start = lookStartCat pgf start = lookStartCat pgf
@@ -73,7 +73,7 @@ lin gr fun = do
getCatQuestion :: CId -> CatQuestions -> String getCatQuestion :: CId -> CatQuestions -> String
getCatQuestion c qs = getCatQuestion c qs =
fromMaybe (error "No question for category " ++ prCId c) (lookup c qs) fromMaybe (error "No question for category " ++ showCId c) (lookup c qs)
-- --
-- * Generate VoiceXML -- * Generate VoiceXML
@@ -93,7 +93,7 @@ grammarURI name = name ++ ".grxml"
catForms :: String -> CatQuestions -> CId -> [(CId, [CId])] -> [XML] catForms :: String -> CatQuestions -> CId -> [(CId, [CId])] -> [XML]
catForms gr qs cat fs = catForms gr qs cat fs =
comments [prCId cat ++ " category."] comments [showCId cat ++ " category."]
++ [cat2form gr qs cat fs] ++ [cat2form gr qs cat fs]
cat2form :: String -> CatQuestions -> CId -> [(CId, [CId])] -> XML cat2form :: String -> CatQuestions -> CId -> [(CId, [CId])] -> XML
@@ -111,20 +111,20 @@ cat2form gr qs cat fs =
fun2sub :: String -> CId -> CId -> [CId] -> [XML] fun2sub :: String -> CId -> CId -> [CId] -> [XML]
fun2sub gr cat fun args = fun2sub gr cat fun args =
comments [prCId fun ++ " : (" comments [showCId fun ++ " : ("
++ concat (intersperse ", " (map prCId args)) ++ concat (intersperse ", " (map showCId args))
++ ") " ++ prCId cat] ++ ss ++ ") " ++ showCId cat] ++ ss
where where
ss = zipWith mkSub [0..] args ss = zipWith mkSub [0..] args
mkSub n t = subdialog s [("src","#"++catFormId t), mkSub n t = subdialog s [("src","#"++catFormId t),
("cond","term.name == "++string (prCId fun))] ("cond","term.name == "++string (showCId fun))]
[param "old" v, [param "old" v,
filled [] [assign v (s++".term")]] filled [] [assign v (s++".term")]]
where s = prCId fun ++ "_" ++ show n where s = showCId fun ++ "_" ++ show n
v = "term.args["++show n++"]" v = "term.args["++show n++"]"
catFormId :: CId -> String catFormId :: CId -> String
catFormId c = prCId c ++ "_cat" catFormId c = showCId c ++ "_cat"
-- --

2
src/GFC.hs
View File

@@ -74,7 +74,7 @@ writePGF opts pgf = do
putPointE Normal opts ("Writing " ++ outfile ++ "...") $ ioeIO $ encodeFile outfile pgf putPointE Normal opts ("Writing " ++ outfile ++ "...") $ ioeIO $ encodeFile outfile pgf
grammarName :: Options -> PGF -> String grammarName :: Options -> PGF -> String
grammarName opts pgf = fromMaybe (prCId (absname pgf)) (flag optName opts) grammarName opts pgf = fromMaybe (showCId (absname pgf)) (flag optName opts)
writeOutput :: Options -> FilePath-> String -> IOE () writeOutput :: Options -> FilePath-> String -> IOE ()
writeOutput opts file str = writeOutput opts file str =

8
src/GFI.hs
View File

@@ -184,7 +184,7 @@ importInEnv gfenv opts files
pgf0 = multigrammar (commandenv gfenv) pgf0 = multigrammar (commandenv gfenv)
pgf1 <- importGrammar pgf0 opts' files pgf1 <- importGrammar pgf0 opts' files
if (verbAtLeast opts Normal) if (verbAtLeast opts Normal)
then putStrLnFlush $ unwords $ "\nLanguages:" : map prCId (languages pgf1) then putStrLnFlush $ unwords $ "\nLanguages:" : map showCId (languages pgf1)
else return () else return ()
return $ gfenv { commandenv = mkCommandEnv (coding gfenv) pgf1 } return $ gfenv { commandenv = mkCommandEnv (coding gfenv) pgf1 }
@@ -215,7 +215,7 @@ welcome = unlines [
prompt env prompt env
| abs == wildCId = "> " | abs == wildCId = "> "
| otherwise = prCId abs ++ "> " | otherwise = showCId abs ++ "> "
where where
abs = abstractName (multigrammar env) abs = abstractName (multigrammar env)
@@ -265,7 +265,7 @@ wordCompletion gfenv line0 prefix0 p =
CmplIdent _ pref CmplIdent _ pref
-> do mb_abs <- try (evaluate (abstract pgf)) -> do mb_abs <- try (evaluate (abstract pgf))
case mb_abs of case mb_abs of
Right abs -> ret ' ' [name | cid <- Map.keys (funs abs), let name = prCId cid, isPrefixOf pref name] Right abs -> ret ' ' [name | cid <- Map.keys (funs abs), let name = showCId cid, isPrefixOf pref name]
Left (_ :: SomeException) -> ret ' ' [] Left (_ :: SomeException) -> ret ' ' []
_ -> ret ' ' [] _ -> ret ' ' []
where where
@@ -276,7 +276,7 @@ wordCompletion gfenv line0 prefix0 p =
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 =
let str = valStrOpts "cat" (prCId $ lookStartCat pgf) opts let str = valStrOpts "cat" (showCId $ lookStartCat pgf) opts
in case readType str of in case readType str of
Just ty -> ty Just ty -> ty
Nothing -> error ("Can't parse '"++str++"' as type") Nothing -> error ("Can't parse '"++str++"' as type")

48
src/PGF.hs
View File

@@ -16,6 +16,10 @@ module PGF(
-- * PGF -- * PGF
PGF, PGF,
readPGF, readPGF,
-- * Identifiers
CId, mkCId, wildCId,
showCId, readCId,
-- * Languages -- * Languages
Language, Language,
@@ -23,19 +27,19 @@ module PGF(
languages, abstractName, languageCode, languages, abstractName, languageCode,
-- * Types -- * Types
Type(..), Hypo(..), Type,
showType, readType, showType, readType,
categories, startCat, categories, startCat,
-- * Functions -- * Functions
functions, functionType, functions, functionType,
-- * Expressions -- * Expressions & Trees
-- ** Identifiers -- ** Tree
CId, mkCId, prCId, wildCId, Tree,
-- ** Expr -- ** Expr
Literal(..), Expr(..), Expr,
showExpr, readExpr, showExpr, readExpr,
-- * Operations -- * Operations
@@ -50,13 +54,22 @@ module PGF(
PGF.compute, paraphrase, PGF.compute, paraphrase,
-- ** Type Checking -- ** Type Checking
-- | The type checker in PGF does both type checking and renaming
-- i.e. it verifies that all identifiers are declared and it
-- distinguishes between global function or type indentifiers and
-- variable names. The type checker should always be applied on
-- expressions entered by the user i.e. those produced via functions
-- like 'readType' and 'readExpr' because otherwise unexpected results
-- could appear. All typechecking functions returns updated versions
-- of the input types or expressions because the typechecking could
-- also lead to metavariables instantiations.
checkType, checkExpr, inferExpr, checkType, checkExpr, inferExpr,
ppTcError, TcError(..), TcError(..), ppTcError,
-- ** Word Completion (Incremental Parsing) -- ** Word Completion (Incremental Parsing)
complete, complete,
Incremental.ParseState, Incremental.ParseState,
Incremental.initState, Incremental.nextState, Incremental.getCompletions, Incremental.extractExps, Incremental.initState, Incremental.nextState, Incremental.getCompletions, Incremental.extractTrees,
-- ** Generation -- ** Generation
generateRandom, generateAll, generateAllDepth generateRandom, generateAll, generateAllDepth
@@ -68,6 +81,7 @@ import PGF.Generate
import PGF.TypeCheck import PGF.TypeCheck
import PGF.Paraphrase import PGF.Paraphrase
import PGF.Macros import PGF.Macros
import PGF.Expr (Tree)
import PGF.Data hiding (functions) import PGF.Data hiding (functions)
import PGF.Binary import PGF.Binary
import qualified PGF.Parsing.FCFG.Active as Active import qualified PGF.Parsing.FCFG.Active as Active
@@ -96,7 +110,7 @@ import Control.Monad
readPGF :: FilePath -> IO PGF readPGF :: FilePath -> IO PGF
-- | Linearizes given expression as string in the language -- | Linearizes given expression as string in the language
linearize :: PGF -> Language -> Expr -> String linearize :: PGF -> Language -> Tree -> String
-- | Tries to parse the given string in the specified language -- | Tries to parse the given string in the specified language
-- and to produce abstract syntax expression. An empty -- and to produce abstract syntax expression. An empty
@@ -104,25 +118,25 @@ linearize :: PGF -> Language -> Expr -> String
-- contain more than one element if the grammar is ambiguous. -- contain more than one element if the grammar is ambiguous.
-- Throws an exception if the given language cannot be used -- Throws an exception if the given language cannot be used
-- for parsing, see 'canParse'. -- for parsing, see 'canParse'.
parse :: PGF -> Language -> Type -> String -> [Expr] parse :: PGF -> Language -> Type -> String -> [Tree]
-- | Checks whether the given language can be used for parsing. -- | Checks whether the given language can be used for parsing.
canParse :: PGF -> Language -> Bool canParse :: PGF -> Language -> Bool
-- | The same as 'linearizeAllLang' but does not return -- | The same as 'linearizeAllLang' but does not return
-- the language. -- the language.
linearizeAll :: PGF -> Expr -> [String] linearizeAll :: PGF -> Tree -> [String]
-- | Linearizes given expression as string in all languages -- | Linearizes given expression as string in all languages
-- available in the grammar. -- available in the grammar.
linearizeAllLang :: PGF -> Expr -> [(Language,String)] linearizeAllLang :: PGF -> Tree -> [(Language,String)]
-- | Show the printname of a type -- | Show the printname of a type
showPrintName :: PGF -> Language -> Type -> String showPrintName :: PGF -> Language -> Type -> String
-- | The same as 'parseAllLang' but does not return -- | The same as 'parseAllLang' but does not return
-- the language. -- the language.
parseAll :: PGF -> Type -> String -> [[Expr]] parseAll :: PGF -> Type -> String -> [[Tree]]
-- | Tries to parse the given string with all available languages. -- | Tries to parse the given string with all available languages.
-- Languages which cannot be used for parsing (see 'canParse') -- Languages which cannot be used for parsing (see 'canParse')
@@ -132,7 +146,7 @@ parseAll :: PGF -> Type -> String -> [[Expr]]
-- (this is a list, since grammars can be ambiguous). -- (this is a list, since grammars can be ambiguous).
-- Only those languages -- Only those languages
-- for which at least one parsing is possible are listed. -- for which at least one parsing is possible are listed.
parseAllLang :: PGF -> Type -> String -> [(Language,[Expr])] parseAllLang :: PGF -> Type -> String -> [(Language,[Tree])]
-- | The same as 'generateAllDepth' but does not limit -- | The same as 'generateAllDepth' but does not limit
-- the depth in the generation. -- the depth in the generation.
@@ -213,8 +227,8 @@ parse pgf lang typ s =
Just pinfo -> if Map.lookup (mkCId "erasing") (cflags cnc) == Just "on" Just pinfo -> if Map.lookup (mkCId "erasing") (cflags cnc) == Just "on"
then Incremental.parse pgf lang typ (words s) then Incremental.parse pgf lang typ (words s)
else Active.parse "t" pinfo typ (words s) else Active.parse "t" pinfo typ (words s)
Nothing -> error ("No parser built for language: " ++ prCId lang) Nothing -> error ("No parser built for language: " ++ showCId lang)
Nothing -> error ("Unknown language: " ++ prCId lang) Nothing -> error ("Unknown language: " ++ showCId lang)
canParse pgf cnc = isJust (lookParser pgf cnc) canParse pgf cnc = isJust (lookParser pgf cnc)
@@ -260,7 +274,7 @@ complete pgf from typ input =
in case foldM Incremental.nextState state0 ws of in case foldM Incremental.nextState state0 ws of
Nothing -> [] Nothing -> []
Just state -> Just state ->
(if null prefix && not (null (Incremental.extractExps state typ)) then [unwords ws ++ " "] else []) (if null prefix && not (null (Incremental.extractTrees state typ)) then [unwords ws ++ " "] else [])
++ [unwords (ws++[c]) ++ " " | c <- Map.keys (Incremental.getCompletions state prefix)] ++ [unwords (ws++[c]) ++ " " | c <- Map.keys (Incremental.getCompletions state prefix)]
where where
tokensAndPrefix :: String -> ([String],String) tokensAndPrefix :: String -> ([String],String)

23
src/PGF/CId.hs
View File

@@ -1,16 +1,19 @@
module PGF.CId (CId(..), module PGF.CId (CId(..),
mkCId, readCId, prCId, mkCId, wildCId,
wildCId, readCId, showCId,
pCId, pIdent) where
-- utils
pCId, pIdent, ppCId) where
import Control.Monad import Control.Monad
import qualified Data.ByteString.Char8 as BS import qualified Data.ByteString.Char8 as BS
import Data.Char import Data.Char
import qualified Text.ParserCombinators.ReadP as RP import qualified Text.ParserCombinators.ReadP as RP
import qualified Text.PrettyPrint as PP
-- | An abstract data type that represents -- | An abstract data type that represents
-- function identifier in PGF. -- identifiers for functions and categories in PGF.
newtype CId = CId BS.ByteString deriving (Eq,Ord) newtype CId = CId BS.ByteString deriving (Eq,Ord)
wildCId :: CId wildCId :: CId
@@ -20,17 +23,18 @@ wildCId = CId (BS.singleton '_')
mkCId :: String -> CId mkCId :: String -> CId
mkCId s = CId (BS.pack s) mkCId s = CId (BS.pack s)
-- | Reads an identifier from 'String'. The function returns 'Nothing' if the string is not valid identifier.
readCId :: String -> Maybe CId readCId :: String -> Maybe CId
readCId s = case [x | (x,cs) <- RP.readP_to_S pCId s, all isSpace cs] of readCId s = case [x | (x,cs) <- RP.readP_to_S pCId s, all isSpace cs] of
[x] -> Just x [x] -> Just x
_ -> Nothing _ -> Nothing
-- | Renders the identifier as 'String' -- | Renders the identifier as 'String'
prCId :: CId -> String showCId :: CId -> String
prCId (CId x) = BS.unpack x showCId (CId x) = BS.unpack x
instance Show CId where instance Show CId where
showsPrec _ = showString . prCId showsPrec _ = showString . showCId
instance Read CId where instance Read CId where
readsPrec _ = RP.readP_to_S pCId readsPrec _ = RP.readP_to_S pCId
@@ -45,4 +49,7 @@ pIdent :: RP.ReadP String
pIdent = liftM2 (:) (RP.satisfy isIdentFirst) (RP.munch isIdentRest) pIdent = liftM2 (:) (RP.satisfy isIdentFirst) (RP.munch isIdentRest)
where where
isIdentFirst c = c == '_' || isLetter c isIdentFirst c = c == '_' || isLetter c
isIdentRest c = c == '_' || c == '\'' || isAlphaNum c isIdentRest c = c == '_' || c == '\'' || isAlphaNum c
ppCId :: CId -> PP.Doc
ppCId = PP.text . showCId

4
src/PGF/Check.hs
View File

@@ -30,7 +30,7 @@ labelBoolErr ms iob = do
checkConcrete :: PGF -> (CId,Concr) -> Err ((CId,Concr),Bool) checkConcrete :: PGF -> (CId,Concr) -> Err ((CId,Concr),Bool)
checkConcrete pgf (lang,cnc) = checkConcrete pgf (lang,cnc) =
labelBoolErr ("happened in language " ++ prCId lang) $ do labelBoolErr ("happened in language " ++ showCId lang) $ do
(rs,bs) <- mapM checkl (Map.assocs (lins cnc)) >>= return . unzip (rs,bs) <- mapM checkl (Map.assocs (lins cnc)) >>= return . unzip
return ((lang,cnc{lins = Map.fromAscList rs}),and bs) return ((lang,cnc{lins = Map.fromAscList rs}),and bs)
where where
@@ -38,7 +38,7 @@ checkConcrete pgf (lang,cnc) =
checkLin :: PGF -> CId -> (CId,Term) -> Err ((CId,Term),Bool) checkLin :: PGF -> CId -> (CId,Term) -> Err ((CId,Term),Bool)
checkLin pgf lang (f,t) = checkLin pgf lang (f,t) =
labelBoolErr ("happened in function " ++ prCId f) $ do labelBoolErr ("happened in function " ++ showCId f) $ do
(t',b) <- checkTerm (lintype pgf lang f) t --- $ inline pgf lang t (t',b) <- checkTerm (lintype pgf lang f) t --- $ inline pgf lang t
return ((f,t'),b) return ((f,t'),b)

4
src/PGF/Data.hs
View File

@@ -1,7 +1,7 @@
module PGF.Data (module PGF.Data, module PGF.Expr, module PGF.Type, module PGF.PMCFG) where module PGF.Data (module PGF.Data, module PGF.Expr, module PGF.Type, module PGF.PMCFG) where
import PGF.CId import PGF.CId
import PGF.Expr hiding (Value, Env) import PGF.Expr hiding (Value, Env, Tree)
import PGF.Type import PGF.Type
import PGF.PMCFG import PGF.PMCFG
@@ -92,4 +92,4 @@ readLanguage :: String -> Maybe Language
readLanguage = readCId readLanguage = readCId
showLanguage :: Language -> String showLanguage :: Language -> String
showLanguage = prCId showLanguage = showCId

26
src/PGF/Expr.hs
View File

@@ -1,4 +1,4 @@
module PGF.Expr(Expr(..), Literal(..), Patt(..), Equation(..), module PGF.Expr(Tree, Expr(..), Literal(..), Patt(..), Equation(..),
readExpr, showExpr, pExpr, ppExpr, ppPatt, readExpr, showExpr, pExpr, ppExpr, ppPatt,
normalForm, normalForm,
@@ -31,8 +31,14 @@ data Literal =
type MetaId = Int type MetaId = Int
-- | An expression represents a potentially unevaluated expression -- | Tree is the abstract syntax representation of a given sentence
-- in the abstract syntax of the grammar. -- in some concrete syntax. Technically 'Tree' is a type synonym
-- of 'Expr'.
type Tree = Expr
-- | An expression in the abstract syntax of the grammar. It could be
-- both parameter of a dependent type or an abstract syntax tree for
-- for some sentence.
data Expr = data Expr =
EAbs CId Expr -- ^ lambda abstraction EAbs CId Expr -- ^ lambda abstraction
| EApp Expr Expr -- ^ application | EApp Expr Expr -- ^ application
@@ -127,7 +133,7 @@ pStr = RP.char '"' >> (RP.manyTill (pEsc RP.<++ RP.get) (RP.char '"'))
ppExpr :: Int -> [CId] -> Expr -> PP.Doc ppExpr :: Int -> [CId] -> Expr -> PP.Doc
ppExpr d scope (EAbs x e) = let (xs,e1) = getVars [x] e ppExpr d scope (EAbs x e) = let (xs,e1) = getVars [x] e
in ppParens (d > 1) (PP.char '\\' PP.<> in ppParens (d > 1) (PP.char '\\' PP.<>
PP.hsep (PP.punctuate PP.comma (List.map (PP.text . prCId) (reverse xs))) PP.<+> PP.hsep (PP.punctuate PP.comma (List.map ppCId (reverse xs))) PP.<+>
PP.text "->" PP.<+> PP.text "->" PP.<+>
ppExpr 1 (xs++scope) e1) ppExpr 1 (xs++scope) e1)
where where
@@ -136,14 +142,14 @@ ppExpr d scope (EAbs x e) = let (xs,e1) = getVars [x] e
ppExpr d scope (EApp e1 e2) = ppParens (d > 3) ((ppExpr 3 scope e1) PP.<+> (ppExpr 4 scope e2)) ppExpr d scope (EApp e1 e2) = ppParens (d > 3) ((ppExpr 3 scope e1) PP.<+> (ppExpr 4 scope e2))
ppExpr d scope (ELit l) = ppLit l ppExpr d scope (ELit l) = ppLit l
ppExpr d scope (EMeta n) = ppMeta n ppExpr d scope (EMeta n) = ppMeta n
ppExpr d scope (EFun f) = PP.text (prCId f) ppExpr d scope (EFun f) = ppCId f
ppExpr d scope (EVar i) = PP.text (prCId (scope !! i)) ppExpr d scope (EVar i) = ppCId (scope !! i)
ppExpr d scope (ETyped e ty)= ppParens (d > 0) (ppExpr 0 scope e PP.<+> PP.colon PP.<+> ppType 0 scope ty) ppExpr d scope (ETyped e ty)= ppParens (d > 0) (ppExpr 0 scope e PP.<+> PP.colon PP.<+> ppType 0 scope ty)
ppPatt d scope (PApp f ps) = let (scope',ds) = mapAccumL (ppPatt 2) scope ps ppPatt d scope (PApp f ps) = let (scope',ds) = mapAccumL (ppPatt 2) scope ps
in (scope',ppParens (not (List.null ps) && d > 1) (PP.text (prCId f) PP.<+> PP.hsep ds)) in (scope',ppParens (not (List.null ps) && d > 1) (ppCId f PP.<+> PP.hsep ds))
ppPatt d scope (PLit l) = (scope,ppLit l) ppPatt d scope (PLit l) = (scope,ppLit l)
ppPatt d scope (PVar f) = (scope,PP.text (prCId f)) ppPatt d scope (PVar f) = (scope,ppCId f)
ppPatt d scope PWild = (scope,PP.char '_') ppPatt d scope PWild = (scope,PP.char '_')
ppLit (LStr s) = PP.text (show s) ppLit (LStr s) = PP.text (show s)
@@ -200,7 +206,7 @@ eval funs env (EFun f) = case Map.lookup f funs of
Equ [] e : _ -> eval funs [] e Equ [] e : _ -> eval funs [] e
_ -> VApp f [] _ -> VApp f []
else VApp f [] else VApp f []
Nothing -> error ("unknown function "++prCId f) Nothing -> error ("unknown function "++showCId f)
eval funs env (EApp e1 e2) = apply funs env e1 [eval funs env e2] eval funs env (EApp e1 e2) = apply funs env e1 [eval funs env e2]
eval funs env (EAbs x e) = VClosure env (EAbs x e) eval funs env (EAbs x e) = VClosure env (EAbs x e)
eval funs env (EMeta i) = VMeta i env [] eval funs env (EMeta i) = VMeta i env []
@@ -215,7 +221,7 @@ apply funs env (EFun f) vs = case Map.lookup f funs of
then let (as,vs') = splitAt a vs then let (as,vs') = splitAt a vs
in match funs f eqs as vs' in match funs f eqs as vs'
else VApp f vs else VApp f vs
Nothing -> error ("unknown function "++prCId f) Nothing -> error ("unknown function "++showCId f)
apply funs env (EApp e1 e2) vs = apply funs env e1 (eval funs env e2 : vs) apply funs env (EApp e1 e2) vs = apply funs env e1 (eval funs env e2 : vs)
apply funs env (EAbs x e) (v:vs) = apply funs (v:env) e vs apply funs env (EAbs x e) (v:vs) = apply funs (v:env) e vs
apply funs env (EMeta i) vs = VMeta i env vs apply funs env (EMeta i) vs = VMeta i env vs

12
src/PGF/Linearize.hs
View File

@@ -59,14 +59,14 @@ linTree :: PGF -> CId -> Expr -> Term
linTree pgf lang = lin . expr2tree linTree pgf lang = lin . expr2tree
where where
lin (Abs xs e ) = case lin e of lin (Abs xs e ) = case lin e of
R ts -> R $ ts ++ (Data.List.map (kks . prCId) xs) R ts -> R $ ts ++ (Data.List.map (kks . showCId) xs)
TM s -> R $ (TM s) : (Data.List.map (kks . prCId) xs) TM s -> R $ (TM s) : (Data.List.map (kks . showCId) xs)
lin (Fun fun es) = let argVariants = mapM (liftVariants . lin) es lin (Fun fun es) = let argVariants = mapM (liftVariants . lin) es
in variants [compute pgf lang args $ look fun | args <- argVariants] in variants [compute pgf lang args $ look fun | args <- argVariants]
lin (Lit (LStr s)) = R [kks (show s)] -- quoted lin (Lit (LStr s)) = R [kks (show s)] -- quoted
lin (Lit (LInt i)) = R [kks (show i)] lin (Lit (LInt i)) = R [kks (show i)]
lin (Lit (LFlt d)) = R [kks (show d)] lin (Lit (LFlt d)) = R [kks (show d)]
lin (Var x) = TM (prCId x) lin (Var x) = TM (showCId x)
lin (Meta i) = TM (show i) lin (Meta i) = TM (show i)
look = lookLin pgf lang look = lookLin pgf lang
@@ -130,15 +130,15 @@ linTreeMark :: PGF -> CId -> Expr -> Term
linTreeMark pgf lang = lin [] . expr2tree linTreeMark pgf lang = lin [] . expr2tree
where where
lin p (Abs xs e ) = case lin p e of lin p (Abs xs e ) = case lin p e of
R ts -> R $ ts ++ (Data.List.map (kks . prCId) xs) R ts -> R $ ts ++ (Data.List.map (kks . showCId) xs)
TM s -> R $ (TM s) : (Data.List.map (kks . prCId) xs) TM s -> R $ (TM s) : (Data.List.map (kks . showCId) xs)
lin p (Fun fun es) = let argVariants = lin p (Fun fun es) = let argVariants =
mapM (\ (i,e) -> liftVariants $ lin (sub p i) e) (zip [0..] es) mapM (\ (i,e) -> liftVariants $ lin (sub p i) e) (zip [0..] es)
in variants [mark p $ compute pgf lang args $ look fun | args <- argVariants] in variants [mark p $ compute pgf lang args $ look fun | args <- argVariants]
lin p (Lit (LStr s)) = mark p $ R [kks (show s)] -- quoted lin p (Lit (LStr s)) = mark p $ R [kks (show s)] -- quoted
lin p (Lit (LInt i)) = mark p $ R [kks (show i)] lin p (Lit (LInt i)) = mark p $ R [kks (show i)]
lin p (Lit (LFlt d)) = mark p $ R [kks (show d)] lin p (Lit (LFlt d)) = mark p $ R [kks (show d)]
lin p (Var x) = mark p $ TM (prCId x) lin p (Var x) = mark p $ TM (showCId x)
lin p (Meta i) = mark p $ TM (show i) lin p (Meta i) = mark p $ TM (show i)
look = lookLin pgf lang look = lookLin pgf lang

4
src/PGF/Macros.hs
View File

@@ -69,7 +69,7 @@ lookAbsFlag pgf f =
lookConcr :: PGF -> CId -> Concr lookConcr :: PGF -> CId -> Concr
lookConcr pgf cnc = lookConcr pgf cnc =
lookMap (error $ "Missing concrete syntax: " ++ prCId cnc) cnc $ concretes pgf lookMap (error $ "Missing concrete syntax: " ++ showCId cnc) cnc $ concretes pgf
lookConcrFlag :: PGF -> CId -> CId -> Maybe String lookConcrFlag :: PGF -> CId -> CId -> Maybe String
lookConcrFlag pgf lang f = Map.lookup f $ cflags $ lookConcr pgf lang lookConcrFlag pgf lang f = Map.lookup f $ cflags $ lookConcr pgf lang
@@ -129,7 +129,7 @@ contextLength ty = case ty of
DTyp hyps _ _ -> length hyps DTyp hyps _ _ -> length hyps
term0 :: CId -> Term term0 :: CId -> Term
term0 = TM . prCId term0 = TM . showCId
tm0 :: Term tm0 :: Term
tm0 = TM "?" tm0 = TM "?"

4
src/PGF/PMCFG.hs
View File

@@ -72,13 +72,13 @@ ppProduction (fcat,FConst _ ss) =
ppFCat fcat <+> text "->" <+> ppStrs ss ppFCat fcat <+> text "->" <+> ppStrs ss
ppFun (funid,FFun fun _ arr) = ppFun (funid,FFun fun _ arr) =
ppFunId funid <+> text ":=" <+> parens (hcat (punctuate comma (map ppSeqId (elems arr)))) <+> brackets (text (prCId fun)) ppFunId funid <+> text ":=" <+> parens (hcat (punctuate comma (map ppSeqId (elems arr)))) <+> brackets (ppCId fun)
ppSeq (seqid,seq) = ppSeq (seqid,seq) =
ppSeqId seqid <+> text ":=" <+> hsep (map ppSymbol (elems seq)) ppSeqId seqid <+> text ":=" <+> hsep (map ppSymbol (elems seq))
ppStartCat (id,fcats) = ppStartCat (id,fcats) =
text (prCId id) <+> text ":=" <+> brackets (hcat (punctuate comma (map ppFCat fcats))) ppCId id <+> text ":=" <+> brackets (hcat (punctuate comma (map ppFCat fcats)))
ppSymbol (FSymCat d r) = char '<' <> int d <> comma <> int r <> char '>' ppSymbol (FSymCat d r) = char '<' <> int d <> comma <> int r <> char '>'
ppSymbol (FSymLit d r) = char '<' <> int d <> comma <> int r <> char '>' ppSymbol (FSymLit d r) = char '<' <> int d <> comma <> int r <> char '>'

1
src/PGF/Paraphrase.hs
View File

@@ -16,7 +16,6 @@ module PGF.Paraphrase (
import PGF.Data import PGF.Data
import PGF.Tree import PGF.Tree
import PGF.Macros (lookDef,isData) import PGF.Macros (lookDef,isData)
import PGF.Expr
import PGF.CId import PGF.CId
import Data.List (nub,sort,group) import Data.List (nub,sort,group)

11
src/PGF/Parsing/FCFG/Incremental.hs
View File

@@ -4,7 +4,7 @@ module PGF.Parsing.FCFG.Incremental
, initState , initState
, nextState , nextState
, getCompletions , getCompletions
, extractExps , extractTrees
, parse , parse
) where ) where
@@ -21,12 +21,13 @@ import Control.Monad
import GF.Data.SortedList import GF.Data.SortedList
import PGF.CId import PGF.CId
import PGF.Data import PGF.Data
import PGF.Expr(Tree)
import PGF.Macros import PGF.Macros
import PGF.TypeCheck import PGF.TypeCheck
import Debug.Trace import Debug.Trace
parse :: PGF -> Language -> Type -> [String] -> [Expr] parse :: PGF -> Language -> Type -> [String] -> [Expr]
parse pgf lang typ toks = maybe [] (\ps -> extractExps ps typ) (foldM nextState (initState pgf lang typ) toks) parse pgf lang typ toks = maybe [] (\ps -> extractTrees ps typ) (foldM nextState (initState pgf lang typ) toks)
-- | Creates an initial parsing state for a given language and -- | Creates an initial parsing state for a given language and
-- startup category. -- startup category.
@@ -43,7 +44,7 @@ initState pgf lang (DTyp _ start _) =
pinfo = pinfo =
case lookParser pgf lang of case lookParser pgf lang of
Just pinfo -> pinfo Just pinfo -> pinfo
_ -> error ("Unknown language: " ++ prCId lang) _ -> error ("Unknown language: " ++ showCId lang)
in State pgf in State pgf
pinfo pinfo
@@ -97,8 +98,8 @@ getCompletions (State pgf pinfo chart items) w =
-- that spans the whole input consumed so far. The trees are also -- that spans the whole input consumed so far. The trees are also
-- limited by the category specified, which is usually -- limited by the category specified, which is usually
-- the same as the startup category. -- the same as the startup category.
extractExps :: ParseState -> Type -> [Expr] extractTrees :: ParseState -> Type -> [Tree]
extractExps (State pgf pinfo chart items) ty@(DTyp _ start _) = extractTrees (State pgf pinfo chart items) ty@(DTyp _ start _) =
nubsort [e1 | e <- exps, Right e1 <- [checkExpr pgf e ty]] nubsort [e1 | e <- exps, Right e1 <- [checkExpr pgf e ty]]
where where
(mb_agenda,acc) = TMap.decompose items (mb_agenda,acc) = TMap.decompose items

4
src/PGF/ShowLinearize.hs
View File

@@ -103,11 +103,11 @@ collectWords pgf lang =
[(f,c,0) | (f,(DTyp [] c _,_,_)) <- Map.toList $ funs $ abstract pgf] [(f,c,0) | (f,(DTyp [] c _,_,_)) <- Map.toList $ funs $ abstract pgf]
where where
collOne (f,c,i) = collOne (f,c,i) =
fromRec f [prCId c] (recLinearize pgf lang (foldl EApp (EFun f) (replicate i (EMeta 888)))) fromRec f [showCId c] (recLinearize pgf lang (foldl EApp (EFun f) (replicate i (EMeta 888))))
fromRec f v r = case r of fromRec f v r = case r of
RR rs -> concat [fromRec f v t | (_,t) <- rs] RR rs -> concat [fromRec f v t | (_,t) <- rs]
RT rs -> concat [fromRec f (p:v) t | (p,t) <- rs] RT rs -> concat [fromRec f (p:v) t | (p,t) <- rs]
RFV rs -> concatMap (fromRec f v) rs RFV rs -> concatMap (fromRec f v) rs
RS s -> [(s,[(prCId f,unwords (reverse v))])] RS s -> [(s,[(showCId f,unwords (reverse v))])]
RCon c -> [] ---- inherent RCon c -> [] ---- inherent

10
src/PGF/Tree.hs
View File

@@ -5,7 +5,7 @@ module PGF.Tree
) where ) where
import PGF.CId import PGF.CId
import PGF.Expr import PGF.Expr hiding (Tree)
import Data.Char import Data.Char
import Data.List as List import Data.List as List
@@ -56,14 +56,14 @@ pTree isNested = RP.skipSpaces >> (pParen RP.<++ pAbs RP.<++ pApp RP.<++ fmap Li
return (Fun f ts) return (Fun f ts)
ppTree d (Abs xs t) = ppParens (d > 0) (PP.char '\\' PP.<> ppTree d (Abs xs t) = ppParens (d > 0) (PP.char '\\' PP.<>
PP.hsep (PP.punctuate PP.comma (List.map (PP.text . prCId) xs)) PP.<+> PP.hsep (PP.punctuate PP.comma (List.map ppCId xs)) PP.<+>
PP.text "->" PP.<+> PP.text "->" PP.<+>
ppTree 0 t) ppTree 0 t)
ppTree d (Fun f []) = PP.text (prCId f) ppTree d (Fun f []) = ppCId f
ppTree d (Fun f ts) = ppParens (d > 0) (PP.text (prCId f) PP.<+> PP.hsep (List.map (ppTree 1) ts)) ppTree d (Fun f ts) = ppParens (d > 0) (ppCId f PP.<+> PP.hsep (List.map (ppTree 1) ts))
ppTree d (Lit l) = ppLit l ppTree d (Lit l) = ppLit l
ppTree d (Meta n) = ppMeta n ppTree d (Meta n) = ppMeta n
ppTree d (Var id) = PP.text (prCId id) ppTree d (Var id) = ppCId id
----------------------------------------------------- -----------------------------------------------------

6
src/PGF/Type.hs
View File

@@ -75,10 +75,10 @@ ppType d scope (DTyp hyps cat args)
| otherwise = let (scope',hdocs) = mapAccumL ppHypo scope hyps | otherwise = let (scope',hdocs) = mapAccumL ppHypo scope hyps
in ppParens (d > 0) (foldr (\hdoc doc -> hdoc PP.<+> PP.text "->" PP.<+> doc) (ppRes scope' cat args) hdocs) in ppParens (d > 0) (foldr (\hdoc doc -> hdoc PP.<+> PP.text "->" PP.<+> doc) (ppRes scope' cat args) hdocs)
where where
ppRes scope cat es = PP.text (prCId cat) PP.<+> PP.hsep (map (ppExpr 4 scope) es) ppRes scope cat es = ppCId cat PP.<+> PP.hsep (map (ppExpr 4 scope) es)
ppHypo scope (Hyp typ) = ( scope,ppType 1 scope typ) ppHypo scope (Hyp typ) = ( scope,ppType 1 scope typ)
ppHypo scope (HypV x typ) = let y = freshName x scope ppHypo scope (HypV x typ) = let y = freshName x scope
in (y:scope,PP.parens (PP.text (prCId y) PP.<+> PP.char ':' PP.<+> ppType 0 scope typ)) in (y:scope,PP.parens (ppCId y PP.<+> PP.char ':' PP.<+> ppType 0 scope typ))
ppHypo scope (HypI x typ) = let y = freshName x scope ppHypo scope (HypI x typ) = let y = freshName x scope
in (y:scope,PP.braces (PP.text (prCId y) PP.<+> PP.char ':' PP.<+> ppType 0 scope typ)) in (y:scope,PP.braces (ppCId y PP.<+> PP.char ':' PP.<+> ppType 0 scope typ))

68
src/PGF/TypeCheck.hs
View File

@@ -135,33 +135,46 @@ addConstraint i j env vs c = do
-- Type errors -- Type errors
----------------------------------------------------- -----------------------------------------------------
-- | If an error occurs in the typechecking phase
-- the type checker returns not a plain text error message
-- but a 'TcError' structure which describes the error.
data TcError data TcError
= UnknownCat CId = UnknownCat CId -- ^ Unknown category name was found.
| UnknownFun CId | UnknownFun CId -- ^ Unknown function name was found.
| WrongCatArgs Scope Type CId Int Int | WrongCatArgs [CId] Type CId Int Int -- ^ A category was applied to wrong number of arguments.
| TypeMismatch Scope Expr Type Type -- The first integer is the number of expected arguments and
| NotFunType Scope Expr Type -- the second the number of given arguments.
| CannotInferType Scope Expr -- The @[CId]@ argument is the list of free variables
| UnresolvedMetaVars Scope Expr [MetaId] -- in the type. It should be used for the 'showType' function.
| TypeMismatch [CId] Expr Type Type -- ^ The expression is not of the expected type.
-- The first type is the expected type, while
-- the second is the inferred. The @[CId]@ argument is the list
-- of free variables in both the expression and the type.
-- It should be used for the 'showType' and 'showExpr' functions.
| NotFunType [CId] Expr Type -- ^ Something that is not of function type was applied to an argument.
| CannotInferType [CId] Expr -- ^ It is not possible to infer the type of an expression.
| UnresolvedMetaVars [CId] Expr [MetaId] -- ^ Some metavariables have to be instantiated in order to complete the typechecking.
-- | Renders the type checking error to a document. See 'Text.PrettyPrint'.
ppTcError :: TcError -> Doc ppTcError :: TcError -> Doc
ppTcError (UnknownCat cat) = text "Category" <+> text (prCId cat) <+> text "is not in scope" ppTcError (UnknownCat cat) = text "Category" <+> ppCId cat <+> text "is not in scope"
ppTcError (UnknownFun fun) = text "Function" <+> text (prCId fun) <+> text "is not in scope" ppTcError (UnknownFun fun) = text "Function" <+> ppCId fun <+> text "is not in scope"
ppTcError (WrongCatArgs scope ty cat m n) = ppTcError (WrongCatArgs xs ty cat m n) = text "Category" <+> ppCId cat <+> text "should have" <+> int m <+> text "argument(s), but has been given" <+> int n $$
text "Category" <+> text (prCId cat) <+> text "should have" <+> int m <+> text "argument(s), but has been given" <+> int n $$ text "In the type:" <+> ppType 0 xs ty
text "In the type:" <+> ppType 0 (scopeVars scope) ty ppTcError (TypeMismatch xs e ty1 ty2) = text "Couldn't match expected type" <+> ppType 0 xs ty1 $$
ppTcError (TypeMismatch scope e ty1 ty2) = text "Couldn't match expected type" <+> ppType 0 (scopeVars scope) ty1 $$ text " against inferred type" <+> ppType 0 xs ty2 $$
text " against inferred type" <+> ppType 0 (scopeVars scope) ty2 $$ text "In the expression:" <+> ppExpr 0 xs e
text "In the expression:" <+> ppExpr 0 (scopeVars scope) e ppTcError (NotFunType xs e ty) = text "A function type is expected for the expression" <+> ppExpr 0 xs e <+> text "instead of type" <+> ppType 0 xs ty
ppTcError (NotFunType scope e ty) = text "A function type is expected for the expression" <+> ppExpr 0 (scopeVars scope) e <+> text "instead of type" <+> ppType 0 (scopeVars scope) ty ppTcError (CannotInferType xs e) = text "Cannot infer the type of expression" <+> ppExpr 0 xs e
ppTcError (CannotInferType scope e) = text "Cannot infer the type of expression" <+> ppExpr 0 (scopeVars scope) e ppTcError (UnresolvedMetaVars xs e ms) = text "Meta variable(s)" <+> fsep (List.map ppMeta ms) <+> text "should be resolved" $$
ppTcError (UnresolvedMetaVars scope e xs) = text "Meta variable(s)" <+> fsep (List.map ppMeta xs) <+> text "should be resolved" $$ text "in the expression:" <+> ppExpr 0 xs e
text "in the expression:" <+> ppExpr 0 (scopeVars scope) e
----------------------------------------------------- -----------------------------------------------------
-- checkType -- checkType
----------------------------------------------------- -----------------------------------------------------
-- | Check whether a given type is consistent with the abstract
-- syntax of the grammar.
checkType :: PGF -> Type -> Either TcError Type checkType :: PGF -> Type -> Either TcError Type
checkType pgf ty = checkType pgf ty =
case unTcM (tcType emptyScope ty >>= refineType) (abstract pgf) 0 IntMap.empty of case unTcM (tcType emptyScope ty >>= refineType) (abstract pgf) 0 IntMap.empty of
@@ -177,7 +190,7 @@ tcType scope ty@(DTyp hyps cat es) = do
if m == n if m == n
then do (delta,es) <- tcHypoExprs scope [] (zip es c_hyps) then do (delta,es) <- tcHypoExprs scope [] (zip es c_hyps)
return (DTyp hyps cat es) return (DTyp hyps cat es)
else tcError (WrongCatArgs scope ty cat n m) else tcError (WrongCatArgs (scopeVars scope) ty cat n m)
tcHypos :: Scope -> [Hypo] -> TcM (Scope,[Hypo]) tcHypos :: Scope -> [Hypo] -> TcM (Scope,[Hypo])
tcHypos scope [] = return (scope,[]) tcHypos scope [] = return (scope,[])
@@ -215,6 +228,7 @@ tcHypoExpr scope delta e (HypV x ty) = do
-- checkExpr -- checkExpr
----------------------------------------------------- -----------------------------------------------------
-- | Checks an expression against a specified type.
checkExpr :: PGF -> Expr -> Type -> Either TcError Expr checkExpr :: PGF -> Expr -> Type -> Either TcError Expr
checkExpr pgf e ty = checkExpr pgf e ty =
case unTcM (do e <- tcExpr emptyScope e (TTyp [] ty) case unTcM (do e <- tcExpr emptyScope e (TTyp [] ty)
@@ -234,7 +248,7 @@ tcExpr scope e0@(EAbs x e) tty =
e (TTyp ((VGen (scopeSize scope) []):delta) (DTyp hs c es)) e (TTyp ((VGen (scopeSize scope) []):delta) (DTyp hs c es))
return (EAbs x e) return (EAbs x e)
_ -> do ty <- evalType (scopeSize scope) tty _ -> do ty <- evalType (scopeSize scope) tty
tcError (NotFunType scope e0 ty) tcError (NotFunType (scopeVars scope) e0 ty)
tcExpr scope (EMeta _) tty = do tcExpr scope (EMeta _) tty = do
i <- newMeta scope i <- newMeta scope
return (EMeta i) return (EMeta i)
@@ -249,6 +263,10 @@ tcExpr scope e0 tty = do
-- inferExpr -- inferExpr
----------------------------------------------------- -----------------------------------------------------
-- | Tries to infer the type of a given expression. Note that
-- even if the expression is type correct it is not always
-- possible to infer its type in the GF type system.
-- In this case the function returns the 'CannotInferType' error.
inferExpr :: PGF -> Expr -> Either TcError (Expr,Type) inferExpr :: PGF -> Expr -> Either TcError (Expr,Type)
inferExpr pgf e = inferExpr pgf e =
case unTcM (do (e,tty) <- infExpr emptyScope e case unTcM (do (e,tty) <- infExpr emptyScope e
@@ -266,7 +284,7 @@ infExpr scope e0@(EApp e1 e2) = do
(TTyp delta1 (DTyp (h:hs) c es)) -> do (delta1,e2) <- tcHypoExpr scope delta1 e2 h (TTyp delta1 (DTyp (h:hs) c es)) -> do (delta1,e2) <- tcHypoExpr scope delta1 e2 h
return (EApp e1 e2,TTyp delta1 (DTyp hs c es)) return (EApp e1 e2,TTyp delta1 (DTyp hs c es))
_ -> do ty1 <- evalType (scopeSize scope) tty1 _ -> do ty1 <- evalType (scopeSize scope) tty1
tcError (NotFunType scope e1 ty1) tcError (NotFunType (scopeVars scope) e1 ty1)
infExpr scope e0@(EFun x) = do infExpr scope e0@(EFun x) = do
case lookupVar x scope of case lookupVar x scope of
Just (i,tty) -> return (EVar i,tty) Just (i,tty) -> return (EVar i,tty)
@@ -284,7 +302,7 @@ infExpr scope (ETyped e ty) = do
ty <- tcType scope ty ty <- tcType scope ty
e <- tcExpr scope e (TTyp (scopeEnv scope) ty) e <- tcExpr scope e (TTyp (scopeEnv scope) ty)
return (ETyped e ty,TTyp (scopeEnv scope) ty) return (ETyped e ty,TTyp (scopeEnv scope) ty)
infExpr scope e = tcError (CannotInferType scope e) infExpr scope e = tcError (CannotInferType (scopeVars scope) e)
----------------------------------------------------- -----------------------------------------------------
-- eqType -- eqType
@@ -299,7 +317,7 @@ eqType scope k i0 tty1@(TTyp delta1 ty1@(DTyp hyps1 cat1 es1)) tty2@(TTyp delta2
raiseTypeMatchError = do ty1 <- evalType k tty1 raiseTypeMatchError = do ty1 <- evalType k tty1
ty2 <- evalType k tty2 ty2 <- evalType k tty2
e <- refineExpr (EMeta i0) e <- refineExpr (EMeta i0)
tcError (TypeMismatch scope e ty1 ty2) tcError (TypeMismatch (scopeVars scope) e ty1 ty2)
eqHyps :: Int -> Env -> [Hypo] -> Env -> [Hypo] -> TcM (Int,Env,Env) eqHyps :: Int -> Env -> [Hypo] -> Env -> [Hypo] -> TcM (Int,Env,Env)
eqHyps k delta1 [] delta2 [] = eqHyps k delta1 [] delta2 [] =
@@ -402,7 +420,7 @@ checkResolvedMetaStore scope e = TcM (\abstr metaid ms ->
let xs = [i | (i,mv) <- IntMap.toList ms, not (isResolved mv)] let xs = [i | (i,mv) <- IntMap.toList ms, not (isResolved mv)]
in if List.null xs in if List.null xs
then Ok metaid ms () then Ok metaid ms ()
else Fail (UnresolvedMetaVars scope e xs)) else Fail (UnresolvedMetaVars (scopeVars scope) e xs))
where where
isResolved (MUnbound _ []) = True isResolved (MUnbound _ []) = True
isResolved (MGuarded _ _ _) = True isResolved (MGuarded _ _ _) = True

6
src/PGF/VisualizeTree.hs
View File

@@ -19,7 +19,7 @@ module PGF.VisualizeTree ( visualizeTrees, alignLinearize
,PosText(..),readPosText ,PosText(..),readPosText
) where ) where
import PGF.CId (prCId) import PGF.CId (showCId)
import PGF.Data import PGF.Data
import PGF.Tree import PGF.Tree
import PGF.Linearize import PGF.Linearize
@@ -42,14 +42,14 @@ tree2graph pgf (funs,cats) = prf [] where
concat [prf (j:ps) t | (j,t) <- zip [0..] trees] concat [prf (j:ps) t | (j,t) <- zip [0..] trees]
prn ps cid = prn ps cid =
let let
fun = if funs then prCId cid else "" fun = if funs then showCId cid else ""
cat = if cats then prCat cid else "" cat = if cats then prCat cid else ""
colon = if funs && cats then " : " else "" colon = if funs && cats then " : " else ""
lab = "\"" ++ fun ++ colon ++ cat ++ "\"" lab = "\"" ++ fun ++ colon ++ cat ++ "\""
in (show(show (ps :: [Int])),lab) in (show(show (ps :: [Int])),lab)
pra i nod t@(Fun cid _) = nod ++ arr ++ fst (prn i cid) ++ " [style = \"solid\"];" pra i nod t@(Fun cid _) = nod ++ arr ++ fst (prn i cid) ++ " [style = \"solid\"];"
arr = " -- " -- if digr then " -> " else " -- " arr = " -- " -- if digr then " -> " else " -- "
prCat = prCId . lookValCat pgf prCat = showCId . lookValCat pgf
prGraph digr ns = concat $ map (++"\n") $ [graph ++ "{\n"] ++ ns ++ ["}"] where prGraph digr ns = concat $ map (++"\n") $ [graph ++ "{\n"] ++ ns ++ ["}"] where
graph = if digr then "digraph" else "graph" graph = if digr then "digraph" else "graph"