From dbe3571fcc09da247836a1bf464a878087feeebf Mon Sep 17 00:00:00 2001 From: bjorn Date: Wed, 3 Sep 2008 15:42:11 +0000 Subject: [PATCH] Added --haskell-prefix option for changing the constructor prefix in generated Haskell modules. --- src/GF/Compile/Export.hs | 5 ++- src/GF/Compile/GFCCtoHaskell.hs | 70 +++++++++++++++++---------------- src/GF/Infra/Option.hs | 5 +++ 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 }