Added --haskell-prefix option for changing the constructor prefix in generated Haskell modules.

3 files changed, 45 insertions, 35 deletions

diff --git a/src/GF/Compile/Export.hs b/src/GF/Compile/Export.hs
index bd4f88df4..2aac9ad13 100644
--- a/src/GF/Compile/Export.hs
+++ b/src/GF/Compile/Export.hs
@@ -31,8 +31,8 @@ exportPGF opts fmt pgf =
     case fmt of
       FmtPGF          -> multi "pgf" printPGF
       FmtJavaScript   -> multi "js"  pgf2js
-      FmtHaskell      -> multi "hs"  (grammar2haskell name)
-      FmtHaskell_GADT -> multi "hs"  (grammar2haskellGADT name)
+      FmtHaskell      -> multi "hs"  (grammar2haskell hsPrefix name)
+      FmtHaskell_GADT -> multi "hs"  (grammar2haskellGADT hsPrefix name)
       FmtProlog       -> multi "pl"  grammar2prolog 
       FmtProlog_Abs   -> multi "pl"  grammar2prolog_abs 
       FmtBNF          -> single "bnf"   bnfPrinter
@@ -47,6 +47,7 @@ exportPGF opts fmt pgf =
  where
    name = fromMaybe (prCId (absname pgf)) (moduleFlag optName opts)
    sisr = flag optSISR opts
+   hsPrefix = flag optHaskellPrefix opts
 
    multi :: String -> (PGF -> String) -> [(FilePath,String)]
    multi ext pr = [(name <.> ext, pr pgf)]
diff --git a/src/GF/Compile/GFCCtoHaskell.hs b/src/GF/Compile/GFCCtoHaskell.hs
index 59db9c364..3fc75df74 100644
--- a/src/GF/Compile/GFCCtoHaskell.hs
+++ b/src/GF/Compile/GFCCtoHaskell.hs
@@ -26,23 +26,27 @@ import GF.Text.UTF8
 import Data.List --(isPrefixOf, find, intersperse)
 import qualified Data.Map as Map
 
+type Prefix = String -> String
+
 -- | the main function
-grammar2haskell :: String  -- ^ Module name.
+grammar2haskell :: String -- ^ Constructor prefix 
+                -> String  -- ^ Module name.
                 -> PGF
                 -> String
-grammar2haskell name gr = encodeUTF8 $ foldr (++++) [] $  
-  haskPreamble name ++ [datatypes gr', gfinstances gr']
+grammar2haskell prefix name gr = encodeUTF8 $ foldr (++++) [] $  
+  haskPreamble name ++ [datatypes gId gr', gfinstances gId gr']
     where gr' = hSkeleton gr
+          gId = (prefix++)
 
-grammar2haskellGADT :: String -> PGF -> String
-grammar2haskellGADT name gr = encodeUTF8 $ foldr (++++) [] $  
+grammar2haskellGADT :: String  -- ^ Constructor prefix
+                    -> String   -- ^ Module name.
+                    -> PGF
+                    -> String
+grammar2haskellGADT prefix name gr = encodeUTF8 $ foldr (++++) [] $  
   ["{-# OPTIONS_GHC -fglasgow-exts #-}"] ++ 
-  haskPreamble name ++ [datatypesGADT gr', gfinstances gr']
+  haskPreamble name ++ [datatypesGADT gId gr', gfinstances gId 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
+          gId = (prefix++)
 
 haskPreamble name =
  [
@@ -82,49 +86,49 @@ type OIdent = String
 
 type HSkeleton = [(OIdent, [(OIdent, [OIdent])])]
 
-datatypes, gfinstances :: (String,HSkeleton) -> String
-datatypes   = (foldr (+++++) "") . (filter (/="")) . (map hDatatype) . snd
-gfinstances (m,g) = (foldr (+++++) "") $ (filter (/="")) $ (map (gfInstance m)) g
+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
 
-hDatatype  :: (OIdent, [(OIdent, [OIdent])]) -> String
-gfInstance :: String -> (OIdent, [(OIdent, [OIdent])]) -> String
+hDatatype  :: Prefix -> (OIdent, [(OIdent, [OIdent])]) -> String
+gfInstance :: Prefix -> String -> (OIdent, [(OIdent, [OIdent])]) -> String
 
-hDatatype ("Cn",_) = "" ---
-hDatatype (cat,[]) = ""
-hDatatype (cat,rules) | isListCat (cat,rules) = 
+hDatatype _ ("Cn",_) = "" ---
+hDatatype _ (cat,[]) = ""
+hDatatype gId (cat,rules) | isListCat (cat,rules) = 
  "newtype" +++ gId cat +++ "=" +++ gId cat +++ "[" ++ gId (elemCat cat) ++ "]" 
   +++ "deriving Show"
-hDatatype (cat,rules) =
+hDatatype gId (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] ++++
+        [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)
+datatypesGADT :: Prefix -> (String,HSkeleton) -> String
+datatypesGADT gId (_,skel) = 
+    unlines (concatMap (hCatTypeGADT gId) skel)
     +++++
-    "data Tree :: * -> * where" ++++ unlines (concatMap (map ("  "++) . hDatatypeGADT) skel)
+    "data Tree :: * -> * where" ++++ unlines (concatMap (map ("  "++) . hDatatypeGADT gId) skel)
 
-hCatTypeGADT :: (OIdent, [(OIdent, [OIdent])]) -> [String]
-hCatTypeGADT (cat,rules)
+hCatTypeGADT :: Prefix -> (OIdent, [(OIdent, [OIdent])]) -> [String]
+hCatTypeGADT gId (cat,rules)
     = ["type"+++gId cat+++"="+++"Tree"+++gId cat++"_",
        "data"+++gId cat++"_"]
 
-hDatatypeGADT :: (OIdent, [(OIdent, [OIdent])]) -> [String]
-hDatatypeGADT (cat, rules) 
+hDatatypeGADT :: Prefix -> (OIdent, [(OIdent, [OIdent])]) -> [String]
+hDatatypeGADT gId (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 ++ "_"
 
-gfInstance m crs = hInstance m crs ++++ fInstance m crs
+gfInstance gId m crs = hInstance gId m crs ++++ fInstance gId m crs
 
 ----hInstance m ("Cn",_) = "" --- seems to belong to an old applic. AR 18/5/2004
-hInstance m (cat,[]) = "" 
-hInstance m (cat,rules) 
+hInstance _ m (cat,[]) = "" 
+hInstance gId m (cat,rules) 
  | isListCat (cat,rules) =
   "instance Gf" +++ gId cat +++ "where" ++++
      "  gf (" ++ gId cat +++ "[" ++ concat (intersperse "," baseVars) ++ "])" 
@@ -148,8 +152,8 @@ hInstance m (cat,rules)
 
 
 ----fInstance m ("Cn",_) = "" ---
-fInstance m (cat,[]) = ""
-fInstance m (cat,rules) =
+fInstance _ m (cat,[]) = ""
+fInstance gId m (cat,rules) =
   "  fg t =" ++++
   "    case t of" ++++
   unlines [mkInst f xx | (f,xx) <- rules] ++++
diff --git a/src/GF/Infra/Option.hs b/src/GF/Infra/Option.hs
index ed8551957..dfb2a2aa0 100644
--- a/src/GF/Infra/Option.hs
+++ b/src/GF/Infra/Option.hs
@@ -150,6 +150,7 @@ data Flags = Flags {
       optGFODir          :: FilePath,
       optOutputFormats   :: [OutputFormat],
       optSISR            :: Maybe SISRFormat,
+      optHaskellPrefix   :: String,
       optOutputFile      :: Maybe FilePath,
       optOutputDir       :: Maybe FilePath,
       optRecomp          :: Recomp,
@@ -294,6 +295,7 @@ defaultFlags = Flags {
       optGFODir          = ".",
       optOutputFormats   = [FmtPGF],
       optSISR            = Nothing,
+      optHaskellPrefix   = "G",
       optOutputFile      = Nothing,
       optOutputDir       = Nothing,
       optRecomp          = RecompIfNewer,
@@ -401,6 +403,8 @@ optDescr =
      Option [] ["sisr"] (ReqArg sisrFmt "FMT") 
         (unlines ["Include SISR tags in generated speech recognition grammars.",
                   "FMT can be one of: old, 1.0"]),
+     Option [] ["haskell-prefix"] (ReqArg hsPrefix "PREFIX") 
+                "Constructor prefix for generated Haskell code. Default: G",
      Option ['o'] ["output-file"] (ReqArg outFile "FILE") 
            "Save output in FILE (default is out.X, where X depends on output format.",
      Option ['D'] ["output-dir"] (ReqArg outDir "DIR") 
@@ -432,6 +436,7 @@ optDescr =
                          "old" -> set $ \o -> o { optSISR = Just SISR_WD20030401 }
                          "1.0" -> set $ \o -> o { optSISR = Just SISR_1_0 }
                          _     -> fail $ "Unknown SISR format: " ++ show x
+       hsPrefix    x = set $ \o -> o { optHaskellPrefix = x }
        outFile     x = set $ \o -> o { optOutputFile = Just x }
        outDir      x = set $ \o -> o { optOutputDir = Just x }
        recomp      x = set $ \o -> o { optRecomp = x }