From d294b70395cdea15cd10d94b5a14a90ad10d724b Mon Sep 17 00:00:00 2001 From: krasimir Date: Fri, 11 Sep 2009 13:45:34 +0000 Subject: [PATCH] polish the PGF API and make Expr and Type abstract types. Tree is a type synonym of Expr --- src/GF/Command/Commands.hs | 16 +++---- src/GF/Command/TreeOperations.hs | 1 + src/GF/Compile/Export.hs | 4 +- src/GF/Compile/GFCCtoHaskell.hs | 4 +- src/GF/Compile/GFCCtoJS.hs | 20 ++++----- src/GF/Compile/GFCCtoProlog.hs | 2 +- src/GF/Compile/GenerateFCFG.hs | 12 ++--- src/GF/Compile/GeneratePMCFG.hs | 12 ++--- src/GF/Compile/PGFPretty.hs | 16 +++---- src/GF/Speech/CFG.hs | 4 +- src/GF/Speech/PGFToCFG.hs | 6 +-- src/GF/Speech/SISR.hs | 4 +- src/GF/Speech/SRG.hs | 4 +- src/GF/Speech/VoiceXML.hs | 18 ++++---- src/GFC.hs | 2 +- src/GFI.hs | 8 ++-- src/PGF.hs | 48 ++++++++++++-------- src/PGF/CId.hs | 23 ++++++---- src/PGF/Check.hs | 4 +- src/PGF/Data.hs | 4 +- src/PGF/Expr.hs | 26 ++++++----- src/PGF/Linearize.hs | 12 ++--- src/PGF/Macros.hs | 4 +- src/PGF/PMCFG.hs | 4 +- src/PGF/Paraphrase.hs | 1 - src/PGF/Parsing/FCFG/Incremental.hs | 11 ++--- src/PGF/ShowLinearize.hs | 4 +- src/PGF/Tree.hs | 10 ++--- src/PGF/Type.hs | 6 +-- src/PGF/TypeCheck.hs | 68 ++++++++++++++++++----------- src/PGF/VisualizeTree.hs | 6 +-- 31 files changed, 205 insertions(+), 159 deletions(-) diff --git a/src/GF/Command/Commands.hs b/src/GF/Command/Commands.hs index a660fa55a..5e655c360 100644 --- a/src/GF/Command/Commands.hs +++ b/src/GF/Command/Commands.hs @@ -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 diff --git a/src/GF/Command/TreeOperations.hs b/src/GF/Command/TreeOperations.hs index b4fdff5ae..0489dd23f 100644 --- a/src/GF/Command/TreeOperations.hs +++ b/src/GF/Command/TreeOperations.hs @@ -5,6 +5,7 @@ module GF.Command.TreeOperations ( import GF.Compile.TypeCheck import PGF +import PGF.Data import Data.List diff --git a/src/GF/Compile/Export.hs b/src/GF/Compile/Export.hs index 051889b59..d03eb947e 100644 --- a/src/GF/Compile/Export.hs +++ b/src/GF/Compile/Export.hs @@ -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. diff --git a/src/GF/Compile/GFCCtoHaskell.hs b/src/GF/Compile/GFCCtoHaskell.hs index 675cecad5..eb428f221 100644 --- a/src/GF/Compile/GFCCtoHaskell.hs +++ b/src/GF/Compile/GFCCtoHaskell.hs @@ -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 diff --git a/src/GF/Compile/GFCCtoJS.hs b/src/GF/Compile/GFCCtoJS.hs index 6a82d02d9..dce3949c6 100644 --- a/src/GF/Compile/GFCCtoJS.hs +++ b/src/GF/Compile/GFCCtoJS.hs @@ -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 ] diff --git a/src/GF/Compile/GFCCtoProlog.hs b/src/GF/Compile/GFCCtoProlog.hs index 3e30dccc3..a31fe4b84 100644 --- a/src/GF/Compile/GFCCtoProlog.hs +++ b/src/GF/Compile/GFCCtoProlog.hs @@ -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 diff --git a/src/GF/Compile/GenerateFCFG.hs b/src/GF/Compile/GenerateFCFG.hs index 096572659..52e95f686 100644 --- a/src/GF/Compile/GenerateFCFG.hs +++ b/src/GF/Compile/GenerateFCFG.hs @@ -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 = diff --git a/src/GF/Compile/GeneratePMCFG.hs b/src/GF/Compile/GeneratePMCFG.hs index 22bb47b60..2f1fe1580 100644 --- a/src/GF/Compile/GeneratePMCFG.hs +++ b/src/GF/Compile/GeneratePMCFG.hs @@ -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" diff --git a/src/GF/Compile/PGFPretty.hs b/src/GF/Compile/PGFPretty.hs index 309ce5c31..679714db5 100644 --- a/src/GF/Compile/PGFPretty.hs +++ b/src/GF/Compile/PGFPretty.hs @@ -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 diff --git a/src/GF/Speech/CFG.hs b/src/GF/Speech/CFG.hs index 6a34dfba3..9ec8416c5 100644 --- a/src/GF/Speech/CFG.hs +++ b/src/GF/Speech/CFG.hs @@ -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 ++ ")" diff --git a/src/GF/Speech/PGFToCFG.hs b/src/GF/Speech/PGFToCFG.hs index 4165e0aa1..d22a4ea8d 100644 --- a/src/GF/Speech/PGFToCFG.hs +++ b/src/GF/Speech/PGFToCFG.hs @@ -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]] diff --git a/src/GF/Speech/SISR.hs b/src/GF/Speech/SISR.hs index 7933a2597..f966d96b9 100644 --- a/src/GF/Speech/SISR.hs +++ b/src/GF/Speech/SISR.hs @@ -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") diff --git a/src/GF/Speech/SRG.hs b/src/GF/Speech/SRG.hs index 5d1bbdfed..2270ec7a1 100644 --- a/src/GF/Speech/SRG.hs +++ b/src/GF/Speech/SRG.hs @@ -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. diff --git a/src/GF/Speech/VoiceXML.hs b/src/GF/Speech/VoiceXML.hs index a30342cd0..cf6f7120f 100644 --- a/src/GF/Speech/VoiceXML.hs +++ b/src/GF/Speech/VoiceXML.hs @@ -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" -- diff --git a/src/GFC.hs b/src/GFC.hs index 713f8b7c9..778792878 100644 --- a/src/GFC.hs +++ b/src/GFC.hs @@ -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 = diff --git a/src/GFI.hs b/src/GFI.hs index 654022c72..170e4be34 100644 --- a/src/GFI.hs +++ b/src/GFI.hs @@ -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") diff --git a/src/PGF.hs b/src/PGF.hs index ec735da88..3bca42148 100644 --- a/src/PGF.hs +++ b/src/PGF.hs @@ -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) diff --git a/src/PGF/CId.hs b/src/PGF/CId.hs index 0d1a2f5c6..fea304d9d 100644 --- a/src/PGF/CId.hs +++ b/src/PGF/CId.hs @@ -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 \ No newline at end of file + isIdentRest c = c == '_' || c == '\'' || isAlphaNum c + +ppCId :: CId -> PP.Doc +ppCId = PP.text . showCId diff --git a/src/PGF/Check.hs b/src/PGF/Check.hs index 363dc9239..58b66cfe4 100644 --- a/src/PGF/Check.hs +++ b/src/PGF/Check.hs @@ -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) diff --git a/src/PGF/Data.hs b/src/PGF/Data.hs index 50e11f289..38027e96e 100644 --- a/src/PGF/Data.hs +++ b/src/PGF/Data.hs @@ -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 diff --git a/src/PGF/Expr.hs b/src/PGF/Expr.hs index 42f9138c9..ae9756cd8 100644 --- a/src/PGF/Expr.hs +++ b/src/PGF/Expr.hs @@ -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 diff --git a/src/PGF/Linearize.hs b/src/PGF/Linearize.hs index 3ee170640..418ed9d5a 100644 --- a/src/PGF/Linearize.hs +++ b/src/PGF/Linearize.hs @@ -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 diff --git a/src/PGF/Macros.hs b/src/PGF/Macros.hs index f6a11799b..05980d823 100644 --- a/src/PGF/Macros.hs +++ b/src/PGF/Macros.hs @@ -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 "?" diff --git a/src/PGF/PMCFG.hs b/src/PGF/PMCFG.hs index 480c7d91f..4957f5295 100644 --- a/src/PGF/PMCFG.hs +++ b/src/PGF/PMCFG.hs @@ -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 '>' diff --git a/src/PGF/Paraphrase.hs b/src/PGF/Paraphrase.hs index ee615f6ac..58d15b2e8 100644 --- a/src/PGF/Paraphrase.hs +++ b/src/PGF/Paraphrase.hs @@ -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) diff --git a/src/PGF/Parsing/FCFG/Incremental.hs b/src/PGF/Parsing/FCFG/Incremental.hs index dbc738a05..cae0ad80f 100644 --- a/src/PGF/Parsing/FCFG/Incremental.hs +++ b/src/PGF/Parsing/FCFG/Incremental.hs @@ -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 diff --git a/src/PGF/ShowLinearize.hs b/src/PGF/ShowLinearize.hs index 274b534dd..d739d38f5 100644 --- a/src/PGF/ShowLinearize.hs +++ b/src/PGF/ShowLinearize.hs @@ -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 diff --git a/src/PGF/Tree.hs b/src/PGF/Tree.hs index 94802e70b..c2d2f33f5 100644 --- a/src/PGF/Tree.hs +++ b/src/PGF/Tree.hs @@ -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 ----------------------------------------------------- diff --git a/src/PGF/Type.hs b/src/PGF/Type.hs index 34aaeaf7b..dbd52343b 100644 --- a/src/PGF/Type.hs +++ b/src/PGF/Type.hs @@ -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)) diff --git a/src/PGF/TypeCheck.hs b/src/PGF/TypeCheck.hs index ddccc2e70..b5f6159b8 100644 --- a/src/PGF/TypeCheck.hs +++ b/src/PGF/TypeCheck.hs @@ -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 diff --git a/src/PGF/VisualizeTree.hs b/src/PGF/VisualizeTree.hs index 8871e9f84..bf21ff581 100644 --- a/src/PGF/VisualizeTree.hs +++ b/src/PGF/VisualizeTree.hs @@ -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"