GitHub/gf-core
1
0
Fork 1
mirror of https://github.com/GrammaticalFramework/gf-core.git synced 2026-04-09 04:59:31 -06:00
Code Issues Packages Projects Releases Wiki 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
[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" <+> ppCId id <+> colon <+> ppType 0 [] ty $$
if null eqs
then empty
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
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)
then empty
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])
Nothing -> do putStrLn "unknown identifier"
return void
@@ -647,8 +647,8 @@ allCommands cod env@(pgf, mos) = Map.fromList [
optLin opts t = unlines $
case opts of
_ | isOpt "treebank" opts -> (prCId (abstractName pgf) ++ ": " ++ showExpr [] t) :
[prCId lang ++ ": " ++ linear opts lang t | lang <- optLangs opts]
_ | isOpt "treebank" opts -> (showCId (abstractName pgf) ++ ": " ++ showExpr [] t) :
[showCId lang ++ ": " ++ linear opts lang t | lang <- optLangs opts]
_ -> [linear opts lang t | lang <- optLangs opts]
linear :: [Option] -> CId -> Expr -> String
@@ -689,7 +689,7 @@ allCommands cod env@(pgf, mos) = Map.fromList [
lang -> map mkCId (chunks ',' lang)
optLang opts = head $ optLangs opts ++ [wildCId]
optType opts =
let str = valStrOpts "cat" (prCId $ lookStartCat pgf) opts
let str = valStrOpts "cat" (showCId $ lookStartCat pgf) opts
in case readType str of
Just ty -> case checkType pgf ty of
Left tcErr -> error $ render (ppTcError tcErr)
@@ -714,7 +714,7 @@ allCommands cod env@(pgf, mos) = Map.fromList [
prGrammar opts
| 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) |
| isOpt "missing" opts = return $ fromString $ unlines $ [unwords (showCId la:":": map showCId cs) |
la <- optLangs opts, let cs = missingLins pgf la]
| otherwise = do fmt <- readOutputFormat (valStrOpts "printer" "pgf_pretty" opts)
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 PGF
import PGF.Data
import Data.List

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

@@ -48,13 +48,13 @@ exportPGF opts fmt pgf =
FmtRegExp -> single "rexp" regexpPrinter
FmtFA -> single "dot" slfGraphvizPrinter
where
name = fromMaybe (prCId (absname pgf)) (flag optName opts)
name = fromMaybe (showCId (absname pgf)) (flag optName opts)
multi :: String -> (PGF -> String) -> [(FilePath,String)]
multi ext pr = [(name <.> ext, pr pgf)]
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.
-- 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])])]
hSkeleton :: PGF -> (String,HSkeleton)
hSkeleton gr =
(prCId (absname gr),
[(prCId c, [(prCId f, map prCId cs) | (f, (cs,_)) <- fs]) |
(showCId (absname gr),
[(showCId c, [(showCId f, map showCId cs) | (f, (cs,_)) <- fs]) |
fs@((_, (_,c)):_) <- fns]
)
where

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

@@ -23,10 +23,10 @@ pgf2js :: PGF -> String
pgf2js pgf =
encodeUTF8 $ JS.printTree $ JS.Program [JS.ElStmt $ JS.SDeclOrExpr $ JS.Decl [JS.DInit (JS.Ident n) grammar]]
where
n = prCId $ absname pgf
n = showCId $ absname pgf
as = abstract pgf
cs = Map.assocs (concretes pgf)
start = prCId $ M.lookStartCat pgf
start = showCId $ M.lookStartCat pgf
grammar = new "GFGrammar" [js_abstract, js_concrete]
js_abstract = abstract2js start as
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 (f,(typ,_,_)) =
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 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)))
where
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]
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)]]),
@@ -53,7 +53,7 @@ concrete2js start n (c, cnc) =
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 n l t = f t
@@ -66,7 +66,7 @@ term2js n l t = f t
K t -> tokn2js t
V i -> JS.EIndex (JS.EVar children) (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)
W str x -> new "Suffix" [JS.EStr str, f x]
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.EObj $ map cats (Map.assocs (startCats p))]]
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 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 (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
fromProfile :: Profile -> JS.Expr
fromProfile [] = new "MetaVar" []
@@ -135,4 +135,4 @@ new :: String -> [JS.Expr] -> JS.Expr
new f xs = JS.ENew (JS.Ident f) xs
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 ||
cid == wildCId = plVar str
| otherwise = plAtom str
where str = prCId cid
where str = showCId cid
instance PLPrint Literal where
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
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 f (R xs) = R (f xs)
@@ -82,13 +82,13 @@ expandHOAS funs lins lincats = (funs' ++ hoFuns ++ varFuns,
catName :: (Int,CId) -> CId
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 (n,c) = mkCId ("__" ++ show n ++ prCId c)
funName (n,c) = mkCId ("__" ++ show n ++ showCId c)
varFunName :: CId -> CId
varFunName c = mkCId ("_Var_" ++ prCId c)
varFunName c = mkCId ("_Var_" ++ showCId c)
-- replaces __NCat with _B and _Var_Cat with _.
-- 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
gen_tcs (F id) path acc = case Map.lookup id cnc_defs of
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) (F id) = case Map.lookup id cnc_defs of
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 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 (F id) = case Map.lookup id cnc_defs of
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
ss <- case t of
R ss -> return ss
F f -> case Map.lookup f cnc_defs of
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]
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 (F id) = case Map.lookup id cnc_defs of
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++")")
@@ -361,7 +361,7 @@ emptyGrammarEnv cnc_defs lincats =
getMultipliers m ms (C max_index) = (m*(max_index+1),m : ms)
getMultipliers m ms (F id) = case Map.lookup id cnc_defs of
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 =
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
where
(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)
-- 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
where
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
_B = mkCId "_B"

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

@@ -21,7 +21,7 @@ prPMCFGPretty :: PGF -> CId -> String
prPMCFGPretty pgf lang = render $
case lookParser pgf lang of
Nothing -> empty
Just pinfo -> text "language" <+> text (prCId lang) $$ ppPMCFG pinfo
Just pinfo -> text "language" <+> ppCId lang $$ ppPMCFG pinfo
prAbs :: Abstr -> Doc
@@ -29,13 +29,13 @@ prAbs a = prAll prCat (cats a) $$ prAll prFun (funs a)
prCat :: CId -> [Hypo] -> Doc
prCat c h | isLiteralCat c = empty
| otherwise = text "cat" <+> text (prCId c)
| otherwise = text "cat" <+> ppCId c
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 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
@@ -46,14 +46,14 @@ prCnc abstr name c = prAll prLinCat (lincats c) $$ prAll prLin (lins (expand c))
where
prLinCat :: CId -> Term -> Doc
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
pr p (R ts) = prec p 1 (hsep (punctuate (text " *") (map (pr 1) ts)))
pr _ (S []) = text "Str"
pr _ (C n) = text "Int_" <> text (show (n+1))
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
pr :: Int -> Term -> Doc
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
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 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 (W s t) = f (w++s) 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
-- Utilities

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

@@ -298,12 +298,12 @@ prProductions prods =
prCFTerm :: CFTerm -> String
prCFTerm = pr 0
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 (CFApp t1 t2) = paren p (pr 1 t1 ++ "(" ++ pr 0 t2 ++ ")")
pr _ (CFRes i) = "$" ++ show i
pr _ (CFVar i) = "x" ++ show i
pr _ (CFMeta c) = "?" ++ prCId c
pr _ (CFMeta c) = "?" ++ showCId c
paren 0 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
-> CId -- ^ Concrete syntax name
-> 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
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]
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),
(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
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),
fc <- fcs, not (isLiteralFCat fc),
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 term fmt = [JS.DExpr $ fmtOut fmt `ass` f term]
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 (CFApp x y) = JS.ECall (f x) [f y]
f (CFRes i) = JS.EIndex (JS.EVar args) (JS.EInt (fromIntegral i))
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_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 mkRules preprocess pgf cnc =
SRG { srgName = prCId cnc,
SRG { srgName = showCId cnc,
srgStartCat = cfgStartCat cfg,
srgExternalCats = cfgExternalCats cfg,
srgLanguage = getSpeechLanguage pgf cnc,
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),
-- 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 cnc = showsXMLDoc (skel2vxml name language start skel qs) ""
where skel = pgfSkeleton pgf
name = prCId cnc
name = showCId cnc
qs = catQuestions pgf cnc (map fst skel)
language = getSpeechLanguage pgf cnc
start = lookStartCat pgf
@@ -73,7 +73,7 @@ lin gr fun = do
getCatQuestion :: CId -> CatQuestions -> String
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
@@ -93,7 +93,7 @@ grammarURI name = name ++ ".grxml"
catForms :: String -> CatQuestions -> CId -> [(CId, [CId])] -> [XML]
catForms gr qs cat fs =
comments [prCId cat ++ " category."]
comments [showCId cat ++ " category."]
++ [cat2form gr qs cat fs]
cat2form :: String -> CatQuestions -> CId -> [(CId, [CId])] -> XML
@@ -111,20 +111,20 @@ cat2form gr qs cat fs =
fun2sub :: String -> CId -> CId -> [CId] -> [XML]
fun2sub gr cat fun args =
comments [prCId fun ++ " : ("
++ concat (intersperse ", " (map prCId args))
++ ") " ++ prCId cat] ++ ss
comments [showCId fun ++ " : ("
++ concat (intersperse ", " (map showCId args))
++ ") " ++ showCId cat] ++ ss
where
ss = zipWith mkSub [0..] args
mkSub n t = subdialog s [("src","#"++catFormId t),
("cond","term.name == "++string (prCId fun))]
("cond","term.name == "++string (showCId fun))]
[param "old" v,
filled [] [assign v (s++".term")]]
where s = prCId fun ++ "_" ++ show n
where s = showCId fun ++ "_" ++ show n
v = "term.args["++show n++"]"
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
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 opts file str =

8
src/GFI.hs
View File

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

48
src/PGF.hs
View File

@@ -16,6 +16,10 @@ module PGF(
-- * PGF
PGF,
readPGF,
-- * Identifiers
CId, mkCId, wildCId,
showCId, readCId,
-- * Languages
Language,
@@ -23,19 +27,19 @@ module PGF(
languages, abstractName, languageCode,
-- * Types
Type(..), Hypo(..),
Type,
showType, readType,
categories, startCat,
-- * Functions
functions, functionType,
-- * Expressions
-- ** Identifiers
CId, mkCId, prCId, wildCId,
-- * Expressions & Trees
-- ** Tree
Tree,
-- ** Expr
Literal(..), Expr(..),
Expr,
showExpr, readExpr,
-- * Operations
@@ -50,13 +54,22 @@ module PGF(
PGF.compute, paraphrase,
-- ** 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,
ppTcError, TcError(..),
TcError(..), ppTcError,
-- ** Word Completion (Incremental Parsing)
complete,
Incremental.ParseState,
Incremental.initState, Incremental.nextState, Incremental.getCompletions, Incremental.extractExps,
Incremental.initState, Incremental.nextState, Incremental.getCompletions, Incremental.extractTrees,
-- ** Generation
generateRandom, generateAll, generateAllDepth
@@ -68,6 +81,7 @@ import PGF.Generate
import PGF.TypeCheck
import PGF.Paraphrase
import PGF.Macros
import PGF.Expr (Tree)
import PGF.Data hiding (functions)
import PGF.Binary
import qualified PGF.Parsing.FCFG.Active as Active
@@ -96,7 +110,7 @@ import Control.Monad
readPGF :: FilePath -> IO PGF
-- | 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
-- 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.
-- Throws an exception if the given language cannot be used
-- 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.
canParse :: PGF -> Language -> Bool
-- | The same as 'linearizeAllLang' but does not return
-- the language.
linearizeAll :: PGF -> Expr -> [String]
linearizeAll :: PGF -> Tree -> [String]
-- | Linearizes given expression as string in all languages
-- available in the grammar.
linearizeAllLang :: PGF -> Expr -> [(Language,String)]
linearizeAllLang :: PGF -> Tree -> [(Language,String)]
-- | Show the printname of a type
showPrintName :: PGF -> Language -> Type -> String
-- | The same as 'parseAllLang' but does not return
-- the language.
parseAll :: PGF -> Type -> String -> [[Expr]]
parseAll :: PGF -> Type -> String -> [[Tree]]
-- | Tries to parse the given string with all available languages.
-- 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).
-- Only those languages
-- 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 depth in the generation.
@@ -213,8 +227,8 @@ parse pgf lang typ s =
Just pinfo -> if Map.lookup (mkCId "erasing") (cflags cnc) == Just "on"
then Incremental.parse pgf lang typ (words s)
else Active.parse "t" pinfo typ (words s)
Nothing -> error ("No parser built for language: " ++ prCId lang)
Nothing -> error ("Unknown language: " ++ prCId lang)
Nothing -> error ("No parser built for language: " ++ showCId lang)
Nothing -> error ("Unknown language: " ++ showCId lang)
canParse pgf cnc = isJust (lookParser pgf cnc)
@@ -260,7 +274,7 @@ complete pgf from typ input =
in case foldM Incremental.nextState state0 ws of
Nothing -> []
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)]
where
tokensAndPrefix :: String -> ([String],String)

23
src/PGF/CId.hs
View File

@@ -1,16 +1,19 @@
module PGF.CId (CId(..),
mkCId, readCId, prCId,
wildCId,
pCId, pIdent) where
mkCId, wildCId,
readCId, showCId,
-- utils
pCId, pIdent, ppCId) where
import Control.Monad
import qualified Data.ByteString.Char8 as BS
import Data.Char
import qualified Text.ParserCombinators.ReadP as RP
import qualified Text.PrettyPrint as PP
-- | 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)
wildCId :: CId
@@ -20,17 +23,18 @@ wildCId = CId (BS.singleton '_')
mkCId :: String -> CId
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 s = case [x | (x,cs) <- RP.readP_to_S pCId s, all isSpace cs] of
[x] -> Just x
_ -> Nothing
-- | Renders the identifier as 'String'
prCId :: CId -> String
prCId (CId x) = BS.unpack x
showCId :: CId -> String
showCId (CId x) = BS.unpack x
instance Show CId where
showsPrec _ = showString . prCId
showsPrec _ = showString . showCId
instance Read CId where
readsPrec _ = RP.readP_to_S pCId
@@ -45,4 +49,7 @@ pIdent :: RP.ReadP String
pIdent = liftM2 (:) (RP.satisfy isIdentFirst) (RP.munch isIdentRest)
where
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 (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
return ((lang,cnc{lins = Map.fromAscList rs}),and bs)
where
@@ -38,7 +38,7 @@ checkConcrete pgf (lang,cnc) =
checkLin :: PGF -> CId -> (CId,Term) -> Err ((CId,Term),Bool)
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
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
import PGF.CId
import PGF.Expr hiding (Value, Env)
import PGF.Expr hiding (Value, Env, Tree)
import PGF.Type
import PGF.PMCFG
@@ -92,4 +92,4 @@ readLanguage :: String -> Maybe Language
readLanguage = readCId
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,
normalForm,
@@ -31,8 +31,14 @@ data Literal =
type MetaId = Int
-- | An expression represents a potentially unevaluated expression
-- in the abstract syntax of the grammar.
-- | Tree is the abstract syntax representation of a given sentence
-- 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 =
EAbs CId Expr -- ^ lambda abstraction
| 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 d scope (EAbs x e) = let (xs,e1) = getVars [x] e
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.<+>
ppExpr 1 (xs++scope) e1)
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 (ELit l) = ppLit l
ppExpr d scope (EMeta n) = ppMeta n
ppExpr d scope (EFun f) = PP.text (prCId f)
ppExpr d scope (EVar i) = PP.text (prCId (scope !! i))
ppExpr d scope (EFun f) = ppCId f
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)
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 (PVar f) = (scope,PP.text (prCId f))
ppPatt d scope (PVar f) = (scope,ppCId f)
ppPatt d scope PWild = (scope,PP.char '_')
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
_ -> 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 (EAbs x e) = VClosure env (EAbs x e)
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
in match funs f eqs as 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 (EAbs x e) (v:vs) = apply funs (v:env) e 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
where
lin (Abs xs e ) = case lin e of
R ts -> R $ ts ++ (Data.List.map (kks . prCId) xs)
TM s -> R $ (TM s) : (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 . showCId) xs)
lin (Fun fun es) = let argVariants = mapM (liftVariants . lin) es
in variants [compute pgf lang args $ look fun | args <- argVariants]
lin (Lit (LStr s)) = R [kks (show s)] -- quoted
lin (Lit (LInt i)) = R [kks (show i)]
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)
look = lookLin pgf lang
@@ -130,15 +130,15 @@ linTreeMark :: PGF -> CId -> Expr -> Term
linTreeMark pgf lang = lin [] . expr2tree
where
lin p (Abs xs e ) = case lin p e of
R ts -> R $ ts ++ (Data.List.map (kks . prCId) xs)
TM s -> R $ (TM s) : (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 . showCId) xs)
lin p (Fun fun es) = let argVariants =
mapM (\ (i,e) -> liftVariants $ lin (sub p i) e) (zip [0..] es)
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 (LInt i)) = mark p $ R [kks (show i)]
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)
look = lookLin pgf lang

4
src/PGF/Macros.hs
View File

@@ -69,7 +69,7 @@ lookAbsFlag pgf f =
lookConcr :: PGF -> CId -> Concr
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 lang f = Map.lookup f $ cflags $ lookConcr pgf lang
@@ -129,7 +129,7 @@ contextLength ty = case ty of
DTyp hyps _ _ -> length hyps
term0 :: CId -> Term
term0 = TM . prCId
term0 = TM . showCId
tm0 :: Term
tm0 = TM "?"

4
src/PGF/PMCFG.hs
View File

@@ -72,13 +72,13 @@ ppProduction (fcat,FConst _ ss) =
ppFCat fcat <+> text "->" <+> ppStrs ss
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) =
ppSeqId seqid <+> text ":=" <+> hsep (map ppSymbol (elems seq))
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 (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.Tree
import PGF.Macros (lookDef,isData)
import PGF.Expr
import PGF.CId
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
, nextState
, getCompletions
, extractExps
, extractTrees
, parse
) where
@@ -21,12 +21,13 @@ import Control.Monad
import GF.Data.SortedList
import PGF.CId
import PGF.Data
import PGF.Expr(Tree)
import PGF.Macros
import PGF.TypeCheck
import Debug.Trace
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
-- startup category.
@@ -43,7 +44,7 @@ initState pgf lang (DTyp _ start _) =
pinfo =
case lookParser pgf lang of
Just pinfo -> pinfo
_ -> error ("Unknown language: " ++ prCId lang)
_ -> error ("Unknown language: " ++ showCId lang)
in State pgf
pinfo
@@ -97,8 +98,8 @@ getCompletions (State pgf pinfo chart items) w =
-- that spans the whole input consumed so far. The trees are also
-- limited by the category specified, which is usually
-- the same as the startup category.
extractExps :: ParseState -> Type -> [Expr]
extractExps (State pgf pinfo chart items) ty@(DTyp _ start _) =
extractTrees :: ParseState -> Type -> [Tree]
extractTrees (State pgf pinfo chart items) ty@(DTyp _ start _) =
nubsort [e1 | e <- exps, Right e1 <- [checkExpr pgf e ty]]
where
(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]
where
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
RR rs -> concat [fromRec f v t | (_,t) <- rs]
RT rs -> concat [fromRec f (p:v) t | (p,t) <- 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

10
src/PGF/Tree.hs
View File

@@ -5,7 +5,7 @@ module PGF.Tree
) where
import PGF.CId
import PGF.Expr
import PGF.Expr hiding (Tree)
import Data.Char
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)
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.<+>
ppTree 0 t)
ppTree d (Fun f []) = PP.text (prCId 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 []) = ppCId f
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 (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
in ppParens (d > 0) (foldr (\hdoc doc -> hdoc PP.<+> PP.text "->" PP.<+> doc) (ppRes scope' cat args) hdocs)
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 (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
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
-----------------------------------------------------
-- | 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
= UnknownCat CId
| UnknownFun CId
| WrongCatArgs Scope Type CId Int Int
| TypeMismatch Scope Expr Type Type
| NotFunType Scope Expr Type
| CannotInferType Scope Expr
| UnresolvedMetaVars Scope Expr [MetaId]
= UnknownCat CId -- ^ Unknown category name was found.
| UnknownFun CId -- ^ Unknown function name was found.
| WrongCatArgs [CId] Type CId Int Int -- ^ A category was applied to wrong number of arguments.
-- The first integer is the number of expected arguments and
-- the second the number of given arguments.
-- The @[CId]@ argument is the list of free variables
-- 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 (UnknownCat cat) = text "Category" <+> text (prCId cat) <+> text "is not in scope"
ppTcError (UnknownFun fun) = text "Function" <+> text (prCId fun) <+> text "is not in scope"
ppTcError (WrongCatArgs scope ty cat m 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 (scopeVars scope) ty
ppTcError (TypeMismatch scope e ty1 ty2) = text "Couldn't match expected type" <+> ppType 0 (scopeVars scope) ty1 $$
text " against inferred type" <+> ppType 0 (scopeVars scope) ty2 $$
text "In the expression:" <+> ppExpr 0 (scopeVars scope) e
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 scope e) = text "Cannot infer the type of expression" <+> ppExpr 0 (scopeVars scope) e
ppTcError (UnresolvedMetaVars scope e xs) = text "Meta variable(s)" <+> fsep (List.map ppMeta xs) <+> text "should be resolved" $$
text "in the expression:" <+> ppExpr 0 (scopeVars scope) e
ppTcError (UnknownCat cat) = text "Category" <+> ppCId cat <+> text "is not in scope"
ppTcError (UnknownFun fun) = text "Function" <+> ppCId fun <+> text "is not in scope"
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 "In the type:" <+> ppType 0 xs ty
ppTcError (TypeMismatch xs e ty1 ty2) = text "Couldn't match expected type" <+> ppType 0 xs ty1 $$
text " against inferred type" <+> ppType 0 xs ty2 $$
text "In the expression:" <+> ppExpr 0 xs 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 (CannotInferType xs e) = text "Cannot infer the type of expression" <+> ppExpr 0 xs e
ppTcError (UnresolvedMetaVars xs e ms) = text "Meta variable(s)" <+> fsep (List.map ppMeta ms) <+> text "should be resolved" $$
text "in the expression:" <+> ppExpr 0 xs e
-----------------------------------------------------
-- checkType
-----------------------------------------------------
-- | Check whether a given type is consistent with the abstract
-- syntax of the grammar.
checkType :: PGF -> Type -> Either TcError Type
checkType pgf ty =
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
then do (delta,es) <- tcHypoExprs scope [] (zip es c_hyps)
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 [] = return (scope,[])
@@ -215,6 +228,7 @@ tcHypoExpr scope delta e (HypV x ty) = do
-- checkExpr
-----------------------------------------------------
-- | Checks an expression against a specified type.
checkExpr :: PGF -> Expr -> Type -> Either TcError Expr
checkExpr pgf e 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))
return (EAbs x e)
_ -> do ty <- evalType (scopeSize scope) tty
tcError (NotFunType scope e0 ty)
tcError (NotFunType (scopeVars scope) e0 ty)
tcExpr scope (EMeta _) tty = do
i <- newMeta scope
return (EMeta i)
@@ -249,6 +263,10 @@ tcExpr scope e0 tty = do
-- 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 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
return (EApp e1 e2,TTyp delta1 (DTyp hs c es))
_ -> do ty1 <- evalType (scopeSize scope) tty1
tcError (NotFunType scope e1 ty1)
tcError (NotFunType (scopeVars scope) e1 ty1)
infExpr scope e0@(EFun x) = do
case lookupVar x scope of
Just (i,tty) -> return (EVar i,tty)
@@ -284,7 +302,7 @@ infExpr scope (ETyped e ty) = do
ty <- tcType scope ty
e <- tcExpr scope e (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
@@ -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
ty2 <- evalType k tty2
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 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)]
in if List.null xs
then Ok metaid ms ()
else Fail (UnresolvedMetaVars scope e xs))
else Fail (UnresolvedMetaVars (scopeVars scope) e xs))
where
isResolved (MUnbound _ []) = True
isResolved (MGuarded _ _ _) = True

6
src/PGF/VisualizeTree.hs
View File

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