msyds/gf-core
1
0
Fork 0
forked from GitHub/gf-core
Code Pull Requests Activity

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

Browse Source
This commit is contained in:
bjorn
2008-09-03 15:42:11 +00:00
parent 6f42ba8693
commit dbe3571fcc
3 changed files with 45 additions and 35 deletions
Download Patch File Download Diff File Expand all files Collapse all files

5
src/GF/Compile/Export.hs
View File

@@ -31,8 +31,8 @@ exportPGF opts fmt pgf =
case fmt of case fmt of
FmtPGF -> multi "pgf" printPGF FmtPGF -> multi "pgf" printPGF
FmtJavaScript -> multi "js" pgf2js FmtJavaScript -> multi "js" pgf2js
FmtHaskell -> multi "hs" (grammar2haskell name) FmtHaskell -> multi "hs" (grammar2haskell hsPrefix name)
FmtHaskell_GADT -> multi "hs" (grammar2haskellGADT name) FmtHaskell_GADT -> multi "hs" (grammar2haskellGADT hsPrefix name)
FmtProlog -> multi "pl" grammar2prolog FmtProlog -> multi "pl" grammar2prolog
FmtProlog_Abs -> multi "pl" grammar2prolog_abs FmtProlog_Abs -> multi "pl" grammar2prolog_abs
FmtBNF -> single "bnf" bnfPrinter FmtBNF -> single "bnf" bnfPrinter
@@ -47,6 +47,7 @@ exportPGF opts fmt pgf =
where where
name = fromMaybe (prCId (absname pgf)) (moduleFlag optName opts) name = fromMaybe (prCId (absname pgf)) (moduleFlag optName opts)
sisr = flag optSISR opts sisr = flag optSISR opts
hsPrefix = flag optHaskellPrefix opts
multi :: String -> (PGF -> String) -> [(FilePath,String)] multi :: String -> (PGF -> String) -> [(FilePath,String)]
multi ext pr = [(name <.> ext, pr pgf)] multi ext pr = [(name <.> ext, pr pgf)]

70
src/GF/Compile/GFCCtoHaskell.hs
View File

@@ -26,23 +26,27 @@ import GF.Text.UTF8
import Data.List --(isPrefixOf, find, intersperse) import Data.List --(isPrefixOf, find, intersperse)
import qualified Data.Map as Map import qualified Data.Map as Map
type Prefix = String -> String
-- | the main function -- | the main function
grammar2haskell :: String -- ^ Module name. grammar2haskell :: String -- ^ Constructor prefix
-> String -- ^ Module name.
-> PGF -> PGF
-> String -> String
grammar2haskell name gr = encodeUTF8 $ foldr (++++) [] $ grammar2haskell prefix name gr = encodeUTF8 $ foldr (++++) [] $
haskPreamble name ++ [datatypes gr', gfinstances gr'] haskPreamble name ++ [datatypes gId gr', gfinstances gId gr']
where gr' = hSkeleton gr where gr' = hSkeleton gr
gId = (prefix++)
grammar2haskellGADT :: String -> PGF -> String grammar2haskellGADT :: String -- ^ Constructor prefix
grammar2haskellGADT name gr = encodeUTF8 $ foldr (++++) [] $ -> String -- ^ Module name.
-> PGF
-> String
grammar2haskellGADT prefix name gr = encodeUTF8 $ foldr (++++) [] $
["{-# OPTIONS_GHC -fglasgow-exts #-}"] ++ ["{-# OPTIONS_GHC -fglasgow-exts #-}"] ++
haskPreamble name ++ [datatypesGADT gr', gfinstances gr'] haskPreamble name ++ [datatypesGADT gId gr', gfinstances gId gr']
where gr' = hSkeleton gr where gr' = hSkeleton gr
gId = (prefix++)
-- | by this you can prefix all identifiers with stg; the default is 'G'
gId :: OIdent -> OIdent
gId i = 'G':i
haskPreamble name = haskPreamble name =
[ [
@@ -82,49 +86,49 @@ type OIdent = String
type HSkeleton = [(OIdent, [(OIdent, [OIdent])])] type HSkeleton = [(OIdent, [(OIdent, [OIdent])])]
datatypes, gfinstances :: (String,HSkeleton) -> String datatypes, gfinstances :: Prefix -> (String,HSkeleton) -> String
datatypes = (foldr (+++++) "") . (filter (/="")) . (map hDatatype) . snd datatypes gId = (foldr (+++++) "") . (filter (/="")) . (map (hDatatype gId)) . snd
gfinstances (m,g) = (foldr (+++++) "") $ (filter (/="")) $ (map (gfInstance m)) g gfinstances gId (m,g) = (foldr (+++++) "") $ (filter (/="")) $ (map (gfInstance gId m)) g
hDatatype :: (OIdent, [(OIdent, [OIdent])]) -> String hDatatype :: Prefix -> (OIdent, [(OIdent, [OIdent])]) -> String
gfInstance :: String -> (OIdent, [(OIdent, [OIdent])]) -> String gfInstance :: Prefix -> String -> (OIdent, [(OIdent, [OIdent])]) -> String
hDatatype ("Cn",_) = "" --- hDatatype _ ("Cn",_) = "" ---
hDatatype (cat,[]) = "" hDatatype _ (cat,[]) = ""
hDatatype (cat,rules) | isListCat (cat,rules) = hDatatype gId (cat,rules) | isListCat (cat,rules) =
"newtype" +++ gId cat +++ "=" +++ gId cat +++ "[" ++ gId (elemCat cat) ++ "]" "newtype" +++ gId cat +++ "=" +++ gId cat +++ "[" ++ gId (elemCat cat) ++ "]"
+++ "deriving Show" +++ "deriving Show"
hDatatype (cat,rules) = hDatatype gId (cat,rules) =
"data" +++ gId cat +++ "=" ++ "data" +++ gId cat +++ "=" ++
(if length rules == 1 then "" else "\n ") +++ (if length rules == 1 then "" else "\n ") +++
foldr1 (\x y -> x ++ "\n |" +++ y) 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" " deriving Show"
-- GADT version of data types -- GADT version of data types
datatypesGADT :: (String,HSkeleton) -> String datatypesGADT :: Prefix -> (String,HSkeleton) -> String
datatypesGADT (_,skel) = datatypesGADT gId (_,skel) =
unlines (concatMap hCatTypeGADT 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 :: Prefix -> (OIdent, [(OIdent, [OIdent])]) -> [String]
hCatTypeGADT (cat,rules) hCatTypeGADT gId (cat,rules)
= ["type"+++gId cat+++"="+++"Tree"+++gId cat++"_", = ["type"+++gId cat+++"="+++"Tree"+++gId cat++"_",
"data"+++gId cat++"_"] "data"+++gId cat++"_"]
hDatatypeGADT :: (OIdent, [(OIdent, [OIdent])]) -> [String] hDatatypeGADT :: Prefix -> (OIdent, [(OIdent, [OIdent])]) -> [String]
hDatatypeGADT (cat, rules) hDatatypeGADT gId (cat, rules)
| isListCat (cat,rules) = [gId cat+++"::"+++"["++gId (elemCat cat)++"]" +++ "->" +++ t] | isListCat (cat,rules) = [gId cat+++"::"+++"["++gId (elemCat cat)++"]" +++ "->" +++ t]
| otherwise = | otherwise =
[ gId f +++ "::" +++ concatMap (\a -> gId a +++ "-> ") args ++ t | (f,args) <- rules ] [ gId f +++ "::" +++ concatMap (\a -> gId a +++ "-> ") args ++ t | (f,args) <- rules ]
where t = "Tree" +++ gId cat ++ "_" 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 ("Cn",_) = "" --- seems to belong to an old applic. AR 18/5/2004
hInstance m (cat,[]) = "" hInstance _ m (cat,[]) = ""
hInstance m (cat,rules) hInstance gId m (cat,rules)
| isListCat (cat,rules) = | isListCat (cat,rules) =
"instance Gf" +++ gId cat +++ "where" ++++ "instance Gf" +++ gId cat +++ "where" ++++
" gf (" ++ gId cat +++ "[" ++ concat (intersperse "," baseVars) ++ "])" " gf (" ++ gId cat +++ "[" ++ concat (intersperse "," baseVars) ++ "])"
@@ -148,8 +152,8 @@ hInstance m (cat,rules)
----fInstance m ("Cn",_) = "" --- ----fInstance m ("Cn",_) = "" ---
fInstance m (cat,[]) = "" fInstance _ m (cat,[]) = ""
fInstance m (cat,rules) = fInstance gId m (cat,rules) =
" fg t =" ++++ " fg t =" ++++
" case t of" ++++ " case t of" ++++
unlines [mkInst f xx | (f,xx) <- rules] ++++ unlines [mkInst f xx | (f,xx) <- rules] ++++

5
src/GF/Infra/Option.hs
View File

@@ -150,6 +150,7 @@ data Flags = Flags {
optGFODir :: FilePath, optGFODir :: FilePath,
optOutputFormats :: [OutputFormat], optOutputFormats :: [OutputFormat],
optSISR :: Maybe SISRFormat, optSISR :: Maybe SISRFormat,
optHaskellPrefix :: String,
optOutputFile :: Maybe FilePath, optOutputFile :: Maybe FilePath,
optOutputDir :: Maybe FilePath, optOutputDir :: Maybe FilePath,
optRecomp :: Recomp, optRecomp :: Recomp,
@@ -294,6 +295,7 @@ defaultFlags = Flags {
optGFODir = ".", optGFODir = ".",
optOutputFormats = [FmtPGF], optOutputFormats = [FmtPGF],
optSISR = Nothing, optSISR = Nothing,
optHaskellPrefix = "G",
optOutputFile = Nothing, optOutputFile = Nothing,
optOutputDir = Nothing, optOutputDir = Nothing,
optRecomp = RecompIfNewer, optRecomp = RecompIfNewer,
@@ -401,6 +403,8 @@ optDescr =
Option [] ["sisr"] (ReqArg sisrFmt "FMT") Option [] ["sisr"] (ReqArg sisrFmt "FMT")
(unlines ["Include SISR tags in generated speech recognition grammars.", (unlines ["Include SISR tags in generated speech recognition grammars.",
"FMT can be one of: old, 1.0"]), "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") Option ['o'] ["output-file"] (ReqArg outFile "FILE")
"Save output in FILE (default is out.X, where X depends on output format.", "Save output in FILE (default is out.X, where X depends on output format.",
Option ['D'] ["output-dir"] (ReqArg outDir "DIR") Option ['D'] ["output-dir"] (ReqArg outDir "DIR")
@@ -432,6 +436,7 @@ optDescr =
"old" -> set $ \o -> o { optSISR = Just SISR_WD20030401 } "old" -> set $ \o -> o { optSISR = Just SISR_WD20030401 }
"1.0" -> set $ \o -> o { optSISR = Just SISR_1_0 } "1.0" -> set $ \o -> o { optSISR = Just SISR_1_0 }
_ -> fail $ "Unknown SISR format: " ++ show x _ -> fail $ "Unknown SISR format: " ++ show x
hsPrefix x = set $ \o -> o { optHaskellPrefix = x }
outFile x = set $ \o -> o { optOutputFile = Just x } outFile x = set $ \o -> o { optOutputFile = Just x }
outDir x = set $ \o -> o { optOutputDir = Just x } outDir x = set $ \o -> o { optOutputDir = Just x }
recomp x = set $ \o -> o { optRecomp = x } recomp x = set $ \o -> o { optRecomp = x }