diff options
Diffstat (limited to 'src/GF/API')
| -rw-r--r-- | src/GF/API/GrammarToHaskell.hs | 88 |
1 files changed, 66 insertions, 22 deletions
diff --git a/src/GF/API/GrammarToHaskell.hs b/src/GF/API/GrammarToHaskell.hs index 6c6620d0c..81acdd47c 100644 --- a/src/GF/API/GrammarToHaskell.hs +++ b/src/GF/API/GrammarToHaskell.hs @@ -5,9 +5,9 @@ -- Stability : (stable) -- Portability : (portable) -- --- > CVS $Date: 2005/04/26 09:54:11 $ +-- > CVS $Date: 2005/06/17 12:39:07 $ -- > CVS $Author: bringert $ --- > CVS $Revision: 1.7 $ +-- > CVS $Revision: 1.8 $ -- -- to write a GF abstract grammar into a Haskell module with translations from -- data objects into GF trees. Example: GSyntax for Agda. @@ -22,6 +22,8 @@ import GF.Grammar.Macros import GF.Infra.Modules import GF.Data.Operations +import Data.List (isPrefixOf, find, intersperse) + -- | the main function grammar2haskell :: GFC.CanonGrammar -> String grammar2haskell gr = foldr (++++) [] $ @@ -82,6 +84,9 @@ hInstance, fInstance :: String -> (OIdent, [(OIdent, [OIdent])]) -> String hDatatype ("Cn",_) = "" --- hDatatype (cat,[]) = "" +hDatatype (cat,rules) | isListCat (cat,rules) = + "newtype" +++ gId cat +++ "=" +++ gId cat +++ "[" ++ gId (elemCat cat) ++ "]" + +++ "deriving Show" hDatatype (cat,rules) = "data" +++ gId cat +++ "=" ++ (if length rules == 1 then "" else "\n ") +++ @@ -90,36 +95,56 @@ hDatatype (cat,rules) = " deriving Show" ----hInstance m ("Cn",_) = "" --- seems to belong to an old applic. AR 18/5/2004 -hInstance m (cat,[]) = "" -hInstance m (cat,rules) = - "instance Gf" +++ gId cat +++ "where" ++ - (if length rules == 1 then "" else "\n") +++ - foldr1 (\x y -> x ++ "\n" +++ y) [mkInst f xx | (f,xx) <- rules] - where - mkInst f xx = - "gf " ++ +hInstance m (cat,[]) = "" +hInstance m (cat,rules) + | isListCat (cat,rules) = + "instance Gf" +++ gId cat +++ "where" ++++ + " gf (" ++ gId cat +++ "[" ++ concat (intersperse "," baseVars) ++ "])" + +++ "=" +++ mkRHS ("Base"++ec) baseVars ++++ + " gf (" ++ gId cat +++ "(x:xs)) = " + ++ mkRHS ("Cons"++ec) ["x",prParenth (gId cat+++"xs")] ++++ + " gf (" ++ gId cat +++ "xs) = error (\"Bad " ++ cat ++ " value: \" ++ show xs)" + | otherwise = + "instance Gf" +++ gId cat +++ "where" ++ + (if length rules == 1 then "" else "\n") +++ + foldr1 (\x y -> x ++ "\n" +++ y) [mkInst f xx | (f,xx) <- rules] + where + ec = elemCat cat + baseVars = mkVars (baseSize (cat,rules)) + mkInst f xx = let xx' = mkVars (length xx) in "gf " ++ (if length xx == 0 then gId f else prParenth (gId f +++ foldr1 (+++) xx')) +++ - "=" +++ - "appqc \"" ++ m ++ "\" \"" ++ f ++ "\"" +++ - "[" ++ prTList ", " ["gf" +++ x | x <- xx'] ++ "]" - where xx' = ["x" ++ show i | (_,i) <- zip xx [1..]] + "=" +++ mkRHS f xx' + mkVars n = ["x" ++ show i | i <- [1..n]] + mkRHS f vars = "appqc \"" ++ m ++ "\" \"" ++ f ++ "\"" +++ + "[" ++ prTList ", " ["gf" +++ x | x <- vars] ++ "]" + ----fInstance m ("Cn",_) = "" --- fInstance m (cat,[]) = "" fInstance m (cat,rules) = - "instance Fg" +++ gId cat +++ "where" ++++ - " fg t =" ++++ - " case termForm t of" ++++ - foldr1 (\x y -> x ++ "\n" ++ y) [mkInst f xx | (f,xx) <- rules] ++++ - " _ -> error (\"no" +++ cat ++ " \" ++ prt t)" + "instance Fg" +++ gId cat +++ "where" ++++ + " fg t =" ++++ + " case termForm t of" ++++ + foldr1 (\x y -> x ++ "\n" ++ y) [mkInst f xx | (f,xx) <- rules] ++++ + " _ -> error (\"no" +++ cat ++ " \" ++ prt t)" where mkInst f xx = " Ok ([], Q (IC \"" ++ m ++ "\") (IC \"" ++ f ++ "\")," ++ "[" ++ prTList "," xx' ++ "])" +++ - "->" +++ - gId f +++ - prTList " " [prParenth ("fg" +++ x) | x <- xx'] + "->" +++ mkRHS f xx' where xx' = ["x" ++ show i | (_,i) <- zip xx [1..]] + mkRHS f vars + | isListCat (cat,rules) = + if "Base" `isPrefixOf` f then + gId cat +++ "[" ++ prTList ", " [ "fg" +++ x | x <- vars ] ++ "]" + else + 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 = + gId f +++ + prTList " " [prParenth ("fg" +++ x) | x <- vars] + hSkeleton :: GFC.CanonGrammar -> (String,HSkeleton) hSkeleton gr = (name,collectR rules [(c,[]) | c <- cats]) where @@ -143,3 +168,22 @@ updateSkeleton cat skel rule = (cat0,rules):rr | cat0 == cat -> (cat0, rule:rules) : rr (cat0,rules):rr -> (cat0, rules) : updateSkeleton cat rr rule +isListCat :: (OIdent, [(OIdent, [OIdent])]) -> Bool +isListCat (cat,rules) = "List" `isPrefixOf` cat && length rules == 2 + && ("Base"++c) `elem` fs && ("Cons"++c) `elem` fs + where c = elemCat cat + fs = map fst rules + +-- | Gets the element category of a list category. +elemCat :: OIdent -> OIdent +elemCat = drop 4 + +isBaseFun :: OIdent -> Bool +isBaseFun f = "Base" `isPrefixOf` f + +isConsFun :: OIdent -> Bool +isConsFun f = "Cons" `isPrefixOf` f + +baseSize :: (OIdent, [(OIdent, [OIdent])]) -> Int +baseSize (_,rules) = length bs + where Just (_,bs) = find (("Base" `isPrefixOf`) . fst) rules
\ No newline at end of file |