GitHub/gf-core
1
0
Fork 1
mirror of https://github.com/GrammaticalFramework/gf-core.git synced 2026-05-20 16:42:51 -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

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