diff options
Diffstat (limited to 'src/GF/Compile/GFCCtoHaskell.hs')
| -rw-r--r-- | src/GF/Compile/GFCCtoHaskell.hs | 91 |
1 files changed, 52 insertions, 39 deletions
diff --git a/src/GF/Compile/GFCCtoHaskell.hs b/src/GF/Compile/GFCCtoHaskell.hs index 3fc75df74..a8fd321b0 100644 --- a/src/GF/Compile/GFCCtoHaskell.hs +++ b/src/GF/Compile/GFCCtoHaskell.hs @@ -14,13 +14,14 @@ -- AR 11/11/1999 -- 7/12/2000 -- 18/5/2004 ----------------------------------------------------------------------------- -module GF.Compile.GFCCtoHaskell (grammar2haskell, grammar2haskellGADT) where +module GF.Compile.GFCCtoHaskell (grammar2haskell) where import PGF.CId import PGF.Data import PGF.Macros import GF.Data.Operations +import GF.Infra.Option import GF.Text.UTF8 import Data.List --(isPrefixOf, find, intersperse) @@ -29,24 +30,21 @@ import qualified Data.Map as Map type Prefix = String -> String -- | the main function -grammar2haskell :: String -- ^ Constructor prefix +grammar2haskell :: Options -> String -- ^ Module name. -> PGF -> String -grammar2haskell prefix name gr = encodeUTF8 $ foldr (++++) [] $ - haskPreamble name ++ [datatypes gId gr', gfinstances gId gr'] +grammar2haskell opts name gr = encodeUTF8 $ foldr (++++) [] $ + pragmas ++ haskPreamble name ++ [types, gfinstances gId lexical gr'] where gr' = hSkeleton gr - gId = (prefix++) - -grammar2haskellGADT :: String -- ^ Constructor prefix - -> String -- ^ Module name. - -> PGF - -> String -grammar2haskellGADT prefix name gr = encodeUTF8 $ foldr (++++) [] $ - ["{-# OPTIONS_GHC -fglasgow-exts #-}"] ++ - haskPreamble name ++ [datatypesGADT gId gr', gfinstances gId gr'] - where gr' = hSkeleton gr - gId = (prefix++) + gadt = haskellOption opts HaskellGADT + lexical cat = haskellOption opts HaskellLexical && isLexicalCat opts cat + gId | haskellOption opts HaskellNoPrefix = id + | otherwise = ("G"++) + pragmas | gadt = ["{-# OPTIONS_GHC -fglasgow-exts #-}"] + | otherwise = [] + types | gadt = datatypesGADT gId lexical gr' + | otherwise = datatypes gId lexical gr' haskPreamble name = [ @@ -86,49 +84,62 @@ type OIdent = String type HSkeleton = [(OIdent, [(OIdent, [OIdent])])] -datatypes, gfinstances :: Prefix -> (String,HSkeleton) -> String -datatypes gId = (foldr (+++++) "") . (filter (/="")) . (map (hDatatype gId)) . snd -gfinstances gId (m,g) = (foldr (+++++) "") $ (filter (/="")) $ (map (gfInstance gId m)) g +datatypes :: Prefix -> (OIdent -> Bool) -> (String,HSkeleton) -> String +datatypes gId lexical = (foldr (+++++) "") . (filter (/="")) . (map (hDatatype gId lexical)) . snd + +gfinstances :: Prefix -> (OIdent -> Bool) -> (String,HSkeleton) -> String +gfinstances gId lexical (m,g) = (foldr (+++++) "") $ (filter (/="")) $ (map (gfInstance gId lexical m)) g -hDatatype :: Prefix -> (OIdent, [(OIdent, [OIdent])]) -> String -gfInstance :: Prefix -> String -> (OIdent, [(OIdent, [OIdent])]) -> String -hDatatype _ ("Cn",_) = "" --- -hDatatype _ (cat,[]) = "" -hDatatype gId (cat,rules) | isListCat (cat,rules) = +hDatatype :: Prefix -> (OIdent -> Bool) -> (OIdent, [(OIdent, [OIdent])]) -> String +hDatatype _ _ ("Cn",_) = "" --- +hDatatype _ _ (cat,[]) = "" +hDatatype gId _ (cat,rules) | isListCat (cat,rules) = "newtype" +++ gId cat +++ "=" +++ gId cat +++ "[" ++ gId (elemCat cat) ++ "]" +++ "deriving Show" -hDatatype gId (cat,rules) = +hDatatype gId lexical (cat,rules) = "data" +++ gId cat +++ "=" ++ (if length rules == 1 then "" else "\n ") +++ - foldr1 (\x y -> x ++ "\n |" +++ y) - [gId f +++ foldr (+++) "" (map (gId) xx) | (f,xx) <- rules] ++++ + foldr1 (\x y -> x ++ "\n |" +++ y) constructors ++++ " deriving Show" + where + constructors = [gId f +++ foldr (+++) "" (map (gId) xx) | (f,xx) <- nonLexicalRules (lexical cat) rules] + ++ if lexical cat then [lexicalConstructor cat +++ "String"] else [] + +nonLexicalRules :: Bool -> [(OIdent, [OIdent])] -> [(OIdent, [OIdent])] +nonLexicalRules False rules = rules +nonLexicalRules True rules = [r | r@(f,t) <- rules, not (null t)] + +lexicalConstructor :: OIdent -> String +lexicalConstructor cat = "Lex" ++ cat -- GADT version of data types -datatypesGADT :: Prefix -> (String,HSkeleton) -> String -datatypesGADT gId (_,skel) = +datatypesGADT :: Prefix -> (OIdent -> Bool) -> (String,HSkeleton) -> String +datatypesGADT gId lexical (_,skel) = unlines (concatMap (hCatTypeGADT gId) skel) +++++ - "data Tree :: * -> * where" ++++ unlines (concatMap (map (" "++) . hDatatypeGADT gId) skel) + "data Tree :: * -> * where" ++++ unlines (concatMap (map (" "++) . hDatatypeGADT gId lexical) skel) hCatTypeGADT :: Prefix -> (OIdent, [(OIdent, [OIdent])]) -> [String] hCatTypeGADT gId (cat,rules) = ["type"+++gId cat+++"="+++"Tree"+++gId cat++"_", "data"+++gId cat++"_"] -hDatatypeGADT :: Prefix -> (OIdent, [(OIdent, [OIdent])]) -> [String] -hDatatypeGADT gId (cat, rules) +hDatatypeGADT :: Prefix -> (OIdent -> Bool) -> (OIdent, [(OIdent, [OIdent])]) -> [String] +hDatatypeGADT gId lexical (cat, rules) | isListCat (cat,rules) = [gId cat+++"::"+++"["++gId (elemCat cat)++"]" +++ "->" +++ t] | otherwise = - [ gId f +++ "::" +++ concatMap (\a -> gId a +++ "-> ") args ++ t | (f,args) <- rules ] + [ gId f +++ "::" +++ concatMap (\a -> gId a +++ "-> ") args ++ t + | (f,args) <- nonLexicalRules (lexical cat) rules ] + ++ if lexical cat then [lexicalConstructor cat +++ ":: String ->"+++ t] else [] where t = "Tree" +++ gId cat ++ "_" -gfInstance gId m crs = hInstance gId m crs ++++ fInstance gId m crs +gfInstance :: Prefix -> (OIdent -> Bool) -> String -> (OIdent, [(OIdent, [OIdent])]) -> String +gfInstance gId lexical m crs = hInstance gId lexical m crs ++++ fInstance gId lexical m crs ----hInstance m ("Cn",_) = "" --- seems to belong to an old applic. AR 18/5/2004 -hInstance _ m (cat,[]) = "" -hInstance gId m (cat,rules) +hInstance _ _ m (cat,[]) = "" +hInstance gId lexical m (cat,rules) | isListCat (cat,rules) = "instance Gf" +++ gId cat +++ "where" ++++ " gf (" ++ gId cat +++ "[" ++ concat (intersperse "," baseVars) ++ "])" @@ -139,7 +150,8 @@ hInstance gId m (cat,rules) -- ++++ " gf (" ++ gId cat +++ "xs) = error (\"Bad " ++ cat ++ " value: \" ++ show xs)" | otherwise = "instance Gf" +++ gId cat +++ "where\n" ++ - unlines [mkInst f xx | (f,xx) <- rules] + unlines ([mkInst f xx | (f,xx) <- nonLexicalRules (lexical cat) rules] + ++ if lexical cat then [" gf (" ++ lexicalConstructor cat +++ "x) = Fun (mkCId x) []"] else []) where ec = elemCat cat baseVars = mkVars (baseSize (cat,rules)) @@ -152,11 +164,12 @@ hInstance gId m (cat,rules) ----fInstance m ("Cn",_) = "" --- -fInstance _ m (cat,[]) = "" -fInstance gId m (cat,rules) = +fInstance _ _ m (cat,[]) = "" +fInstance gId lexical m (cat,rules) = " fg t =" ++++ " case t of" ++++ - unlines [mkInst f xx | (f,xx) <- rules] ++++ + unlines [mkInst f xx | (f,xx) <- nonLexicalRules (lexical cat) rules] ++++ + (if lexical cat then " Fun i [] -> " ++ lexicalConstructor cat +++ "(prCId i)" else "") ++++ " _ -> error (\"no" +++ cat ++ " \" ++ show t)" where mkInst f xx = |