diff --git a/src/GF/API/GrammarToHaskell.hs b/src/GF/API/GrammarToHaskell.hs index c3ca33247..c8728bada 100644 --- a/src/GF/API/GrammarToHaskell.hs +++ b/src/GF/API/GrammarToHaskell.hs @@ -14,7 +14,7 @@ -- AR 11/11/1999 -- 7/12/2000 -- 18/5/2004 ----------------------------------------------------------------------------- -module GF.API.GrammarToHaskell (grammar2haskell) where +module GF.API.GrammarToHaskell (grammar2haskell, grammar2haskellGADT) where import qualified GF.Canon.GFC as GFC import GF.Grammar.Macros @@ -30,6 +30,12 @@ grammar2haskell gr = foldr (++++) [] $ haskPreamble ++ [datatypes gr', gfinstances gr', fginstances gr'] where gr' = hSkeleton gr +grammar2haskellGADT :: GFC.CanonGrammar -> String +grammar2haskellGADT gr = foldr (++++) [] $ + ["{-# OPTIONS_GHC -fglasgow-exts #-}"] ++ + haskPreamble ++ [datatypesGADT gr', gfinstances gr', fginstances gr'] + where gr' = hSkeleton gr + -- | by this you can prefix all identifiers with stg; the default is 'G' gId :: OIdent -> OIdent gId i = 'G':i @@ -96,6 +102,26 @@ hDatatype (cat,rules) = [gId f +++ foldr (+++) "" (map gId xx) | (f,xx) <- rules] ++++ " deriving Show" +-- GADT version of data types +datatypesGADT :: (String,HSkeleton) -> String +datatypesGADT (_,skel) = + unlines (concatMap hCatTypeGADT skel) + +++++ + "data Tree :: * -> * where" ++++ unlines (concatMap (map (" "++) . hDatatypeGADT) skel) + +hCatTypeGADT :: (OIdent, [(OIdent, [OIdent])]) -> [String] +hCatTypeGADT (cat,rules) + = ["type"+++gId cat+++"="+++"Tree"+++gId cat++"_", + "data"+++gId cat++"_"] + +hDatatypeGADT :: (OIdent, [(OIdent, [OIdent])]) -> [String] +hDatatypeGADT (cat, rules) + | isListCat (cat,rules) = [gId cat+++"::"+++"["++gId (elemCat cat)++"]" +++ "->" +++ t] + | otherwise = + [ gId f +++ "::" +++ concatMap (\a -> gId a +++ "-> ") args ++ t | (f,args) <- rules ] + where t = "Tree" +++ gId cat ++ "_" + + ----hInstance m ("Cn",_) = "" --- seems to belong to an old applic. AR 18/5/2004 hInstance m (cat,[]) = "" hInstance m (cat,rules) @@ -104,8 +130,9 @@ hInstance m (cat,rules) " 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)" + ++ mkRHS ("Cons"++ec) ["x",prParenth (gId cat+++"xs")] +-- no show for GADTs +-- ++++ " gf (" ++ gId cat +++ "xs) = error (\"Bad " ++ cat ++ " value: \" ++ show xs)" | otherwise = "instance Gf" +++ gId cat +++ "where" ++ (if length rules == 1 then "" else "\n") +++ diff --git a/src/GF/Shell/HelpFile.hs b/src/GF/Shell/HelpFile.hs index a54646710..e577d5b46 100644 --- a/src/GF/Shell/HelpFile.hs +++ b/src/GF/Shell/HelpFile.hs @@ -644,6 +644,7 @@ txtHelpFile = "\n -printer=plbnf grammar for BNF Converter, with precedence levels" ++ "\n *-printer=happy source file for Happy parser generator (use lbnf!)" ++ "\n -printer=haskell abstract syntax in Haskell, with transl to/from GF" ++ + "\n -printer=haskell_gadt abstract syntax GADT in Haskell, with transl to/from GF" ++ "\n -printer=morpho full-form lexicon, long format" ++ "\n *-printer=latex LaTeX file (for the tg command)" ++ "\n -printer=fullform full-form lexicon, short format" ++ diff --git a/src/GF/UseGrammar/Custom.hs b/src/GF/UseGrammar/Custom.hs index bbfb1e09e..132c832cd 100644 --- a/src/GF/UseGrammar/Custom.hs +++ b/src/GF/UseGrammar/Custom.hs @@ -270,6 +270,7 @@ customGrammarPrinter = ,(strCI "bnf", \_ -> prBNF False) ,(strCI "absbnf", \_ -> abstract2bnf . stateGrammarST) ,(strCI "haskell", \_ -> grammar2haskell . stateGrammarST) + ,(strCI "haskell_gadt", \_ -> grammar2haskellGADT . stateGrammarST) ,(strCI "transfer", \_ -> grammar2transfer . stateGrammarST) ,(strCI "morpho", \_ -> prMorpho . stateMorpho) ,(strCI "fullform",\_ -> prFullForm . stateMorpho) diff --git a/src/HelpFile b/src/HelpFile index 0b18e34a8..999b26382 100644 --- a/src/HelpFile +++ b/src/HelpFile @@ -615,6 +615,7 @@ q, quit: q -printer=plbnf grammar for BNF Converter, with precedence levels *-printer=happy source file for Happy parser generator (use lbnf!) -printer=haskell abstract syntax in Haskell, with transl to/from GF + -printer=haskell_gadt abstract syntax GADT in Haskell, with transl to/from GF -printer=morpho full-form lexicon, long format *-printer=latex LaTeX file (for the tg command) -printer=fullform full-form lexicon, short format