Added option to treat some categories as lexical when generating Haskell data types.

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 =