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

fixed the printing of predefined and list categories in haskell=gadt

Browse Source
This commit is contained in:
aarne
2011-04-06 07:45:35 +00:00
parent 7416c9acb3
commit 393976d889
1 changed files with 35 additions and 23 deletions
Download Patch File Download Diff File Expand all files Collapse all files

58
src/compiler/GF/Compile/PGFtoHaskell.hs
View File

@@ -67,11 +67,11 @@ haskPreamble gadt name =
" gf :: a -> PGF.Tree", " gf :: a -> PGF.Tree",
" fg :: PGF.Tree -> a", " fg :: PGF.Tree -> a",
"", "",
predefInst "GString" "String" "unStr" "mkStr", predefInst gadt "GString" "String" "unStr" "mkStr",
"", "",
predefInst "GInt" "Int" "unInt" "mkInt", predefInst gadt "GInt" "Int" "unInt" "mkInt",
"", "",
predefInst "GFloat" "Double" "unDouble" "mkDouble", predefInst gadt "GFloat" "Double" "unDouble" "mkDouble",
"", "",
"----------------------------------------------------", "----------------------------------------------------",
"-- below this line machine-generated", "-- below this line machine-generated",
@@ -79,8 +79,12 @@ haskPreamble gadt name =
"" ""
] ]
predefInst gtyp typ destr consr = predefInst gadt gtyp typ destr consr =
"newtype" +++ gtyp +++ "=" +++ gtyp +++ typ +++ " deriving Show" +++++ (if gadt
then []
else ("newtype" +++ gtyp +++ "=" +++ gtyp +++ typ +++ " deriving Show\n\n")
)
++
"instance Gf" +++ gtyp +++ "where" ++++ "instance Gf" +++ gtyp +++ "where" ++++
" gf (" ++ gtyp +++ "x) =" +++ consr +++ "x" ++++ " gf (" ++ gtyp +++ "x) =" +++ consr +++ "x" ++++
" fg t =" ++++ " fg t =" ++++
@@ -121,12 +125,20 @@ nonLexicalRules True rules = [r | r@(f,t) <- rules, not (null t)]
lexicalConstructor :: OIdent -> String lexicalConstructor :: OIdent -> String
lexicalConstructor cat = "Lex" ++ cat lexicalConstructor cat = "Lex" ++ cat
predefTypeSkel = [(c,[]) | c <- ["String", "Int", "Float"]]
-- GADT version of data types -- GADT version of data types
datatypesGADT :: Prefix -> (OIdent -> Bool) -> (String,HSkeleton) -> String datatypesGADT :: Prefix -> (OIdent -> Bool) -> (String,HSkeleton) -> String
datatypesGADT gId lexical (_,skel) = datatypesGADT gId lexical (_,skel) =
unlines (concatMap (hCatTypeGADT gId) skel) unlines (concatMap (hCatTypeGADT gId) (skel ++ predefTypeSkel))
+++++ +++++
"data Tree :: * -> * where" ++++ unlines (concatMap (map (" "++) . hDatatypeGADT gId lexical) skel) "data Tree :: * -> * where" ++++
unlines (concatMap (map (" "++) . hDatatypeGADT gId lexical) skel) ++++
unlines [
" GString :: String -> Tree GString_",
" GInt :: Int -> Tree GInt_",
" GFloat :: Double -> Tree GFloat_"
]
hCatTypeGADT :: Prefix -> (OIdent, [(OIdent, [OIdent])]) -> [String] hCatTypeGADT :: Prefix -> (OIdent, [(OIdent, [OIdent])]) -> [String]
hCatTypeGADT gId (cat,rules) hCatTypeGADT gId (cat,rules)
@@ -147,19 +159,20 @@ prCompos gId lexical (_,catrules) =
["instance Compos Tree where", ["instance Compos Tree where",
" compos r a f t = case t of"] " compos r a f t = case t of"]
++ ++
[" " ++ prComposCons (gId f) xs | (c,rs) <- catrules, (f,xs) <- rs, not (null xs)] [" " ++ prComposCons (gId f) xs | (c,rs) <- catrules, not (isListCat (c,rs)),
(f,xs) <- rs, not (null xs)]
++
[" " ++ prComposCons (gId c) ["x1"] | (c,rs) <- catrules, isListCat (c,rs)]
++ ++
[" _ -> r t"] [" _ -> r t"]
where where
prComposCons f xs = let vs = mkVars (length xs) in prComposCons f xs = let vs = mkVars (length xs) in
f +++ unwords vs +++ "->" +++ rhs f (zip vs xs) f +++ unwords vs +++ "->" +++ rhs f (zip vs xs)
rhs f vcs = "r" +++ f +++ unwords (map prRec vcs) rhs f vcs = "r" +++ f +++ unwords (map (prRec f) vcs)
prRec (v,c) prRec f (v,c)
| isList c = "`a` foldr (a . a (r (:)) . f) (r [])" +++ v | isList f = "`a` foldr (a . a (r (:)) . f) (r [])" +++ v
| otherwise = "`a`" +++ "f" +++ v | otherwise = "`a`" +++ "f" +++ v
isList c = case lookup c catrules of isList f = (gId "List") `isPrefixOf` f
Just rs -> isListCat (c,rs)
_ -> False
gfInstance :: Prefix -> (OIdent -> Bool) -> String -> (OIdent, [(OIdent, [OIdent])]) -> String gfInstance :: Prefix -> (OIdent -> Bool) -> String -> (OIdent, [(OIdent, [OIdent])]) -> String
gfInstance gId lexical m crs = hInstance gId lexical m crs ++++ fInstance gId lexical m crs gfInstance gId lexical m crs = hInstance gId lexical m crs ++++ fInstance gId lexical m crs
@@ -194,29 +207,28 @@ mkVars n = ["x" ++ show i | i <- [1..n]]
fInstance _ _ m (cat,[]) = "" fInstance _ _ m (cat,[]) = ""
fInstance gId lexical m (cat,rules) = fInstance gId lexical m (cat,rules) =
" fg t =" ++++ " fg t =" ++++
" case unApp t of" ++++ (if isList
then " " ++ gId cat ++ " (fgs t) where\n fgs t = case unApp t of"
else " case unApp t of") ++++
unlines [mkInst f xx | (f,xx) <- nonLexicalRules (lexical cat) rules] ++++ unlines [mkInst f xx | (f,xx) <- nonLexicalRules (lexical cat) rules] ++++
(if lexical cat then " (i,[]) -> " ++ lexicalConstructor cat +++ "(prCId i)" else "") ++++ (if lexical cat then " (i,[]) -> " ++ lexicalConstructor cat +++ "(prCId i)" else "") ++++
" _ -> error (\"no" +++ cat ++ " \" ++ show t)" " _ -> error (\"no" +++ cat ++ " \" ++ show t)"
where where
isList = isListCat (cat,rules)
mkInst f xx = mkInst f xx =
" Just (i," ++ " Just (i," ++
"[" ++ prTList "," xx' ++ "])" +++ "[" ++ prTList "," xx' ++ "])" +++
"| i == mkCId \"" ++ f ++ "\" ->" +++ mkRHS f xx' "| i == mkCId \"" ++ f ++ "\" ->" +++ mkRHS f xx'
where xx' = ["x" ++ show i | (_,i) <- zip xx [1..]] where xx' = ["x" ++ show i | (_,i) <- zip xx [1..]]
mkRHS f vars mkRHS f vars
| isListCat (cat,rules) = | isList =
if "Base" `isPrefixOf` f then if "Base" `isPrefixOf` f
gId cat +++ "[" ++ prTList ", " [ "fg" +++ x | x <- vars ] ++ "]" then "[" ++ prTList ", " [ "fg" +++ x | x <- vars ] ++ "]"
else else "fg" +++ (vars !! 0) +++ ":" +++ "fgs" +++ (vars !! 1)
let (i,t) = (init vars,last vars)
in "let" +++ gId cat +++ "xs = fg " ++ t +++ "in" +++
gId cat +++ prParenth (prTList ":" (["fg"+++v | v <- i] ++ ["xs"]))
| otherwise = | otherwise =
gId f +++ gId f +++
prTList " " [prParenth ("fg" +++ x) | x <- vars] prTList " " [prParenth ("fg" +++ x) | x <- vars]
--type HSkeleton = [(OIdent, [(OIdent, [OIdent])])] --type HSkeleton = [(OIdent, [(OIdent, [OIdent])])]
hSkeleton :: PGF -> (String,HSkeleton) hSkeleton :: PGF -> (String,HSkeleton)
hSkeleton gr = hSkeleton gr =