GitHub/gf-core
1
0
Fork 1
mirror of https://github.com/GrammaticalFramework/gf-core.git synced 2026-04-09 04:59:31 -06:00
Code Issues Packages Projects Releases Wiki Activity

Merge pull request #120 from GrammaticalFramework/haskell-export

Browse Source 
Add --haskell=pgf2 flag
This commit is contained in:
John J. Camilleri
2021-07-02 09:00:45 +02:00
committed by GitHub
parent d5c6aec3ec b090e9b0ff
commit 3df04295d9
2 changed files with 120 additions and 104 deletions
Download Patch File Download Diff File Expand all files Collapse all files

120
src/compiler/GF/Compile/PGFtoHaskell.hs
View File

@@ -5,7 +5,7 @@
-- Stability : (stable)
-- Portability : (portable)
--
-- > CVS $Date: 2005/06/17 12:39:07 $
-- > CVS $Date: 2005/06/17 12:39:07 $
-- > CVS $Author: bringert $
-- > CVS $Revision: 1.8 $
--
@@ -22,7 +22,7 @@ import PGF.Internal
import GF.Data.Operations
import GF.Infra.Option
import Data.List --(isPrefixOf, find, intersperse)
import Data.List(isPrefixOf,find,intercalate,intersperse,groupBy,sortBy)
import qualified Data.Map as Map
type Prefix = String -> String
@@ -34,11 +34,12 @@ grammar2haskell :: Options
-> PGF
-> String
grammar2haskell opts name gr = foldr (++++) [] $
pragmas ++ haskPreamble gadt name derivingClause extraImports ++
pragmas ++ haskPreamble gadt name derivingClause (extraImports ++ pgfImports) ++
[types, gfinstances gId lexical gr'] ++ compos
where gr' = hSkeleton gr
gadt = haskellOption opts HaskellGADT
dataExt = haskellOption opts HaskellData
pgf2 = haskellOption opts HaskellPGF2
lexical cat = haskellOption opts HaskellLexical && isLexicalCat opts cat
gId | haskellOption opts HaskellNoPrefix = rmForbiddenChars
| otherwise = ("G"++) . rmForbiddenChars
@@ -50,21 +51,23 @@ grammar2haskell opts name gr = foldr (++++) [] $
derivingClause
| dataExt = "deriving (Show,Data)"
| otherwise = "deriving Show"
extraImports | gadt = ["import Control.Monad.Identity",
"import Data.Monoid"]
extraImports | gadt = ["import Control.Monad.Identity", "import Data.Monoid"]
| dataExt = ["import Data.Data"]
| otherwise = []
pgfImports | pgf2 = ["import PGF2 hiding (Tree)", "", "showCId :: CId -> String", "showCId = id"]
| otherwise = ["import PGF hiding (Tree)"]
types | gadt = datatypesGADT gId lexical gr'
| otherwise = datatypes gId derivingClause lexical gr'
compos | gadt = prCompos gId lexical gr' ++ composClass
| otherwise = []
haskPreamble gadt name derivingClause extraImports =
haskPreamble :: Bool -> String -> String -> [String] -> [String]
haskPreamble gadt name derivingClause imports =
[
"module " ++ name ++ " where",
""
] ++ extraImports ++ [
"import PGF hiding (Tree)",
] ++ imports ++ [
"",
"----------------------------------------------------",
"-- automatic translation from GF to Haskell",
"----------------------------------------------------",
@@ -85,10 +88,11 @@ haskPreamble gadt name derivingClause extraImports =
""
]
predefInst :: Bool -> String -> String -> String -> String -> String -> String
predefInst gadt derivingClause gtyp typ destr consr =
(if gadt
then []
else ("newtype" +++ gtyp +++ "=" +++ gtyp +++ typ +++ derivingClause ++ "\n\n")
else "newtype" +++ gtyp +++ "=" +++ gtyp +++ typ +++ derivingClause ++ "\n\n"
)
++
"instance Gf" +++ gtyp +++ "where" ++++
@@ -103,10 +107,10 @@ type OIdent = String
type HSkeleton = [(OIdent, [(OIdent, [OIdent])])]
datatypes :: Prefix -> DerivingClause -> (OIdent -> Bool) -> (String,HSkeleton) -> String
datatypes gId derivingClause lexical = (foldr (+++++) "") . (filter (/="")) . (map (hDatatype gId derivingClause lexical)) . snd
datatypes gId derivingClause lexical = foldr (+++++) "" . filter (/="") . map (hDatatype gId derivingClause lexical) . snd
gfinstances :: Prefix -> (OIdent -> Bool) -> (String,HSkeleton) -> String
gfinstances gId lexical (m,g) = (foldr (+++++) "") $ (filter (/="")) $ (map (gfInstance gId lexical m)) g
gfinstances gId lexical (m,g) = foldr (+++++) "" $ filter (/="") $ map (gfInstance gId lexical m) g
hDatatype :: Prefix -> DerivingClause -> (OIdent -> Bool) -> (OIdent, [(OIdent, [OIdent])]) -> String
@@ -131,16 +135,17 @@ nonLexicalRules True rules = [r | r@(f,t) <- rules, not (null t)]
lexicalConstructor :: OIdent -> String
lexicalConstructor cat = "Lex" ++ cat
predefTypeSkel :: HSkeleton
predefTypeSkel = [(c,[]) | c <- ["String", "Int", "Float"]]
-- GADT version of data types
datatypesGADT :: Prefix -> (OIdent -> Bool) -> (String,HSkeleton) -> String
datatypesGADT gId lexical (_,skel) = unlines $
datatypesGADT gId lexical (_,skel) = unlines $
concatMap (hCatTypeGADT gId) (skel ++ predefTypeSkel) ++
[
"",
[
"",
"data Tree :: * -> * where"
] ++
] ++
concatMap (map (" "++) . hDatatypeGADT gId lexical) skel ++
[
" GString :: String -> Tree GString_",
@@ -164,23 +169,23 @@ hCatTypeGADT gId (cat,rules)
"data"+++gId cat++"_"]
hDatatypeGADT :: Prefix -> (OIdent -> Bool) -> (OIdent, [(OIdent, [OIdent])]) -> [String]
hDatatypeGADT gId lexical (cat, rules)
hDatatypeGADT gId lexical (cat, rules)
| isListCat (cat,rules) = [gId cat+++"::"+++"["++gId (elemCat cat)++"]" +++ "->" +++ t]
| otherwise =
[ gId f +++ "::" +++ concatMap (\a -> gId a +++ "-> ") args ++ t
[ 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 ++ "_"
hEqGADT :: Prefix -> (OIdent -> Bool) -> (OIdent, [(OIdent, [OIdent])]) -> [String]
hEqGADT gId lexical (cat, rules)
| isListCat (cat,rules) = let r = listr cat in ["(" ++ patt "x" r ++ "," ++ patt "y" r ++ ") -> " ++ listeqs]
| isListCat (cat,rules) = let r = listr cat in ["(" ++ patt "x" r ++ "," ++ patt "y" r ++ ") -> " ++ listeqs]
| otherwise = ["(" ++ patt "x" r ++ "," ++ patt "y" r ++ ") -> " ++ eqs r | r <- nonLexicalRules (lexical cat) rules]
++ if lexical cat then ["(" ++ lexicalConstructor cat +++ "x" ++ "," ++ lexicalConstructor cat +++ "y" ++ ") -> x == y"] else []
where
patt s (f,xs) = unwords (gId f : mkSVars s (length xs))
eqs (_,xs) = unwords ("and" : "[" : intersperse "," [x ++ " == " ++ y |
eqs (_,xs) = unwords ("and" : "[" : intersperse "," [x ++ " == " ++ y |
(x,y) <- zip (mkSVars "x" (length xs)) (mkSVars "y" (length xs)) ] ++ ["]"])
listr c = (c,["foo"]) -- foo just for length = 1
listeqs = "and [x == y | (x,y) <- zip x1 y1]"
@@ -189,25 +194,26 @@ prCompos :: Prefix -> (OIdent -> Bool) -> (String,HSkeleton) -> [String]
prCompos gId lexical (_,catrules) =
["instance Compos Tree where",
" compos r a f t = case t of"]
++
++
[" " ++ prComposCons (gId f) xs | (c,rs) <- catrules, not (isListCat (c,rs)),
(f,xs) <- rs, not (null xs)]
++
(f,xs) <- rs, not (null xs)]
++
[" " ++ prComposCons (gId c) ["x1"] | (c,rs) <- catrules, isListCat (c,rs)]
++
++
[" _ -> r t"]
where
prComposCons f xs = let vs = mkVars (length xs) in
prComposCons f xs = let vs = mkVars (length xs) in
f +++ unwords vs +++ "->" +++ rhs f (zip vs xs)
rhs f vcs = "r" +++ f +++ unwords (map (prRec f) vcs)
prRec f (v,c)
prRec f (v,c)
| isList f = "`a` foldr (a . a (r (:)) . f) (r [])" +++ v
| otherwise = "`a`" +++ "f" +++ v
isList f = (gId "List") `isPrefixOf` f
isList f = gId "List" `isPrefixOf` f
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 :: (String -> String) -> (String -> Bool) -> String -> (String, [(OIdent, [OIdent])]) -> String
----hInstance m ("Cn",_) = "" --- seems to belong to an old applic. AR 18/5/2004
hInstance gId _ m (cat,[]) = unlines [
"instance Show" +++ gId cat,
@@ -216,15 +222,15 @@ hInstance gId _ m (cat,[]) = unlines [
" gf _ = undefined",
" fg _ = undefined"
]
hInstance gId lexical m (cat,rules)
hInstance gId lexical m (cat,rules)
| isListCat (cat,rules) =
"instance Gf" +++ gId cat +++ "where" ++++
" gf (" ++ gId cat +++ "[" ++ concat (intersperse "," baseVars) ++ "])"
" gf (" ++ gId cat +++ "[" ++ intercalate "," baseVars ++ "])"
+++ "=" +++ mkRHS ("Base"++ec) baseVars ++++
" gf (" ++ gId cat +++ "(x:xs)) = "
++ mkRHS ("Cons"++ec) ["x",prParenth (gId cat+++"xs")]
" gf (" ++ gId cat +++ "(x:xs)) = "
++ mkRHS ("Cons"++ec) ["x",prParenth (gId cat+++"xs")]
-- no show for GADTs
-- ++++ " gf (" ++ gId cat +++ "xs) = error (\"Bad " ++ cat ++ " value: \" ++ show xs)"
-- ++++ " gf (" ++ gId cat +++ "xs) = error (\"Bad " ++ cat ++ " value: \" ++ show xs)"
| otherwise =
"instance Gf" +++ gId cat +++ "where\n" ++
unlines ([mkInst f xx | (f,xx) <- nonLexicalRules (lexical cat) rules]
@@ -233,19 +239,22 @@ hInstance gId lexical m (cat,rules)
ec = elemCat cat
baseVars = mkVars (baseSize (cat,rules))
mkInst f xx = let xx' = mkVars (length xx) in " gf " ++
(if length xx == 0 then gId f else prParenth (gId f +++ foldr1 (+++) xx')) +++
(if null xx then gId f else prParenth (gId f +++ foldr1 (+++) xx')) +++
"=" +++ mkRHS f xx'
mkRHS f vars = "mkApp (mkCId \"" ++ f ++ "\")" +++
"[" ++ prTList ", " ["gf" +++ x | x <- vars] ++ "]"
mkRHS f vars = "mkApp (mkCId \"" ++ f ++ "\")" +++
"[" ++ prTList ", " ["gf" +++ x | x <- vars] ++ "]"
mkVars :: Int -> [String]
mkVars = mkSVars "x"
mkSVars :: String -> Int -> [String]
mkSVars s n = [s ++ show i | i <- [1..n]]
----fInstance m ("Cn",_) = "" ---
fInstance _ _ m (cat,[]) = ""
fInstance gId lexical m (cat,rules) =
" fg t =" ++++
(if isList
(if isList
then " " ++ gId cat ++ " (fgs t) where\n fgs t = case unApp t of"
else " case unApp t of") ++++
unlines [mkInst f xx | (f,xx) <- nonLexicalRules (lexical cat) rules] ++++
@@ -257,27 +266,28 @@ fInstance gId lexical m (cat,rules) =
" Just (i," ++
"[" ++ prTList "," xx' ++ "])" +++
"| i == mkCId \"" ++ f ++ "\" ->" +++ mkRHS f xx'
where xx' = ["x" ++ show i | (_,i) <- zip xx [1..]]
mkRHS f vars
| isList =
if "Base" `isPrefixOf` f
then "[" ++ prTList ", " [ "fg" +++ x | x <- vars ] ++ "]"
else "fg" +++ (vars !! 0) +++ ":" +++ "fgs" +++ (vars !! 1)
| otherwise =
gId f +++
prTList " " [prParenth ("fg" +++ x) | x <- vars]
where
xx' = ["x" ++ show i | (_,i) <- zip xx [1..]]
mkRHS f vars
| isList =
if "Base" `isPrefixOf` f
then "[" ++ prTList ", " [ "fg" +++ x | x <- vars ] ++ "]"
else "fg" +++ (vars !! 0) +++ ":" +++ "fgs" +++ (vars !! 1)
| otherwise =
gId f +++
prTList " " [prParenth ("fg" +++ x) | x <- vars]
--type HSkeleton = [(OIdent, [(OIdent, [OIdent])])]
hSkeleton :: PGF -> (String,HSkeleton)
hSkeleton gr =
(showCId (absname gr),
let fs =
[(showCId c, [(showCId f, map showCId cs) | (f, (cs,_)) <- fs]) |
hSkeleton gr =
(showCId (absname gr),
let fs =
[(showCId c, [(showCId f, map showCId cs) | (f, (cs,_)) <- fs]) |
fs@((_, (_,c)):_) <- fns]
in fs ++ [(sc, []) | c <- cts, let sc = showCId c, notElem sc (["Int", "Float", "String"] ++ map fst fs)]
in fs ++ [(sc, []) | c <- cts, let sc = showCId c, sc `notElem` (["Int", "Float", "String"] ++ map fst fs)]
)
where
cts = Map.keys (cats (abstract gr))
cts = Map.keys (cats (abstract gr))
fns = groupBy valtypg (sortBy valtyps (map jty (Map.assocs (funs (abstract gr)))))
valtyps (_, (_,x)) (_, (_,y)) = compare x y
valtypg (_, (_,x)) (_, (_,y)) = x == y
@@ -291,9 +301,10 @@ updateSkeleton cat skel rule =
-}
isListCat :: (OIdent, [(OIdent, [OIdent])]) -> Bool
isListCat (cat,rules) = "List" `isPrefixOf` cat && length rules == 2
&& ("Base"++c) `elem` fs && ("Cons"++c) `elem` fs
where c = elemCat cat
fs = map fst rules
&& ("Base"++c) `elem` fs && ("Cons"++c) `elem` fs
where
c = elemCat cat
fs = map fst rules
-- | Gets the element category of a list category.
elemCat :: OIdent -> OIdent
@@ -310,7 +321,7 @@ baseSize (_,rules) = length bs
where Just (_,bs) = find (("Base" `isPrefixOf`) . fst) rules
composClass :: [String]
composClass =
composClass =
[
"",
"class Compos t where",
@@ -337,4 +348,3 @@ composClass =
"",
"newtype C b a = C { unC :: b }"
]

104
src/compiler/GF/Infra/Option.hs
View File

@@ -2,13 +2,13 @@ module GF.Infra.Option
(
-- ** Command line options
-- *** Option types
Options,
Flags(..),
Mode(..), Phase(..), Verbosity(..),
OutputFormat(..),
Options,
Flags(..),
Mode(..), Phase(..), Verbosity(..),
OutputFormat(..),
SISRFormat(..), Optimization(..), CFGTransform(..), HaskellOption(..),
Dump(..), Pass(..), Recomp(..),
outputFormatsExpl,
outputFormatsExpl,
-- *** Option parsing
parseOptions, parseModuleOptions, fixRelativeLibPaths,
-- *** Option pretty-printing
@@ -47,7 +47,7 @@ import PGF.Internal(Literal(..))
import qualified Control.Monad.Fail as Fail
usageHeader :: String
usageHeader = unlines
usageHeader = unlines
["Usage: gf [OPTIONS] [FILE [...]]",
"",
"How each FILE is handled depends on the file name suffix:",
@@ -90,10 +90,10 @@ data Phase = Preproc | Convert | Compile | Link
data OutputFormat = FmtPGFPretty
| FmtCanonicalGF
| FmtCanonicalJson
| FmtJavaScript
| FmtJavaScript
| FmtJSON
| FmtPython
| FmtHaskell
| FmtPython
| FmtHaskell
| FmtJava
| FmtProlog
| FmtBNF
@@ -102,37 +102,42 @@ data OutputFormat = FmtPGFPretty
| FmtNoLR
| FmtSRGS_XML
| FmtSRGS_XML_NonRec
| FmtSRGS_ABNF
| FmtSRGS_ABNF
| FmtSRGS_ABNF_NonRec
| FmtJSGF
| FmtGSL
| FmtJSGF
| FmtGSL
| FmtVoiceXML
| FmtSLF
| FmtRegExp
| FmtFA
deriving (Eq,Ord)
data SISRFormat =
data SISRFormat =
-- | SISR Working draft 1 April 2003
-- <http://www.w3.org/TR/2003/WD-semantic-interpretation-20030401/>
SISR_WD20030401
SISR_WD20030401
| SISR_1_0
deriving (Show,Eq,Ord)
data Optimization = OptStem | OptCSE | OptExpand | OptParametrize
deriving (Show,Eq,Ord)
data CFGTransform = CFGNoLR
data CFGTransform = CFGNoLR
| CFGRegular
| CFGTopDownFilter
| CFGBottomUpFilter
| CFGTopDownFilter
| CFGBottomUpFilter
| CFGStartCatOnly
| CFGMergeIdentical
| CFGRemoveCycles
deriving (Show,Eq,Ord)
data HaskellOption = HaskellNoPrefix | HaskellGADT | HaskellLexical
| HaskellConcrete | HaskellVariants | HaskellData
data HaskellOption = HaskellNoPrefix
| HaskellGADT
| HaskellLexical
| HaskellConcrete
| HaskellVariants
| HaskellData
| HaskellPGF2
deriving (Show,Eq,Ord)
data Warning = WarnMissingLincat
@@ -196,7 +201,7 @@ instance Show Options where
parseOptions :: ErrorMonad err =>
[String] -- ^ list of string arguments
-> err (Options, [FilePath])
parseOptions args
parseOptions args
| not (null errs) = errors errs
| otherwise = do opts <- concatOptions `fmap` liftErr (sequence optss)
return (opts, files)
@@ -208,7 +213,7 @@ parseModuleOptions :: ErrorMonad err =>
-> err Options
parseModuleOptions args = do
(opts,nonopts) <- parseOptions args
if null nonopts
if null nonopts
then return opts
else errors $ map ("Non-option among module options: " ++) nonopts
@@ -281,7 +286,7 @@ defaultFlags = Flags {
optOptimizations = Set.fromList [OptStem,OptCSE,OptExpand,OptParametrize],
optOptimizePGF = False,
optSplitPGF = False,
optCFGTransforms = Set.fromList [CFGRemoveCycles, CFGBottomUpFilter,
optCFGTransforms = Set.fromList [CFGRemoveCycles, CFGBottomUpFilter,
CFGTopDownFilter, CFGMergeIdentical],
optLibraryPath = [],
optStartCat = Nothing,
@@ -301,7 +306,7 @@ defaultFlags = Flags {
-- | Option descriptions
{-# NOINLINE optDescr #-}
optDescr :: [OptDescr (Err Options)]
optDescr =
optDescr =
[
Option ['?','h'] ["help"] (NoArg (mode ModeHelp)) "Show help message.",
Option ['V'] ["version"] (NoArg (mode ModeVersion)) "Display GF version number.",
@@ -327,44 +332,44 @@ optDescr =
-- Option ['t'] ["trace"] (NoArg (trace True)) "Trace computations",
-- Option [] ["no-trace"] (NoArg (trace False)) "Don't trace computations",
Option [] ["gfo-dir"] (ReqArg gfoDir "DIR") "Directory to put .gfo files in (default = '.').",
Option ['f'] ["output-format"] (ReqArg outFmt "FMT")
Option ['f'] ["output-format"] (ReqArg outFmt "FMT")
(unlines ["Output format. FMT can be one of:",
"Canonical GF grammar: canonical_gf, canonical_json, (and haskell with option --haskell=concrete)",
"Multiple concrete: pgf (default), json, js, pgf_pretty, prolog, python, ...", -- gar,
"Single concrete only: bnf, ebnf, fa, gsl, jsgf, regexp, slf, srgs_xml, srgs_abnf, vxml, ....", -- cf, lbnf,
"Abstract only: haskell, ..."]), -- prolog_abs,
Option [] ["sisr"] (ReqArg sisrFmt "FMT")
Option [] ["sisr"] (ReqArg sisrFmt "FMT")
(unlines ["Include SISR tags in generated speech recognition grammars.",
"FMT can be one of: old, 1.0"]),
Option [] ["haskell"] (ReqArg hsOption "OPTION")
("Turn on an optional feature when generating Haskell data types. OPTION = "
Option [] ["haskell"] (ReqArg hsOption "OPTION")
("Turn on an optional feature when generating Haskell data types. OPTION = "
++ concat (intersperse " | " (map fst haskellOptionNames))),
Option [] ["lexical"] (ReqArg lexicalCat "CAT[,CAT[...]]")
Option [] ["lexical"] (ReqArg lexicalCat "CAT[,CAT[...]]")
"Treat CAT as a lexical category.",
Option [] ["literal"] (ReqArg literalCat "CAT[,CAT[...]]")
Option [] ["literal"] (ReqArg literalCat "CAT[,CAT[...]]")
"Treat CAT as a literal category.",
Option ['D'] ["output-dir"] (ReqArg outDir "DIR")
Option ['D'] ["output-dir"] (ReqArg outDir "DIR")
"Save output files (other than .gfo files) in DIR.",
Option [] ["gf-lib-path"] (ReqArg gfLibPath "DIR")
Option [] ["gf-lib-path"] (ReqArg gfLibPath "DIR")
"Overrides the value of GF_LIB_PATH.",
Option [] ["src","force-recomp"] (NoArg (recomp AlwaysRecomp))
Option [] ["src","force-recomp"] (NoArg (recomp AlwaysRecomp))
"Always recompile from source.",
Option [] ["recomp-if-newer"] (NoArg (recomp RecompIfNewer))
Option [] ["recomp-if-newer"] (NoArg (recomp RecompIfNewer))
"(default) Recompile from source if the source is newer than the .gfo file.",
Option [] ["gfo","no-recomp"] (NoArg (recomp NeverRecomp))
Option [] ["gfo","no-recomp"] (NoArg (recomp NeverRecomp))
"Never recompile from source, if there is already .gfo file.",
Option [] ["retain"] (NoArg (set $ \o -> o { optRetainResource = True })) "Retain opers.",
Option [] ["probs"] (ReqArg probsFile "file.probs") "Read probabilities from file.",
Option ['n'] ["name"] (ReqArg name "NAME")
Option ['n'] ["name"] (ReqArg name "NAME")
(unlines ["Use NAME as the name of the output. This is used in the output file names, ",
"with suffixes depending on the formats, and, when relevant, ",
"internally in the output."]),
Option ['i'] [] (ReqArg addLibDir "DIR") "Add DIR to the library search path.",
Option [] ["path"] (ReqArg setLibPath "DIR:DIR:...") "Set the library search path.",
Option [] ["preproc"] (ReqArg preproc "CMD")
Option [] ["preproc"] (ReqArg preproc "CMD")
(unlines ["Use CMD to preprocess input files.",
"Multiple preprocessors can be used by giving this option multiple times."]),
Option [] ["coding"] (ReqArg coding "ENCODING")
Option [] ["coding"] (ReqArg coding "ENCODING")
("Character encoding of the source grammar, ENCODING = utf8, latin1, cp1251, ..."),
Option [] ["startcat"] (ReqArg startcat "CAT") "Grammar start category.",
Option [] ["language"] (ReqArg language "LANG") "Set the speech language flag to LANG in the generated grammar.",
@@ -372,7 +377,7 @@ optDescr =
Option [] ["unlexer"] (ReqArg unlexer "UNLEXER") "Use unlexer UNLEXER.",
Option [] ["pmcfg"] (NoArg (pmcfg True)) "Generate PMCFG (default).",
Option [] ["no-pmcfg"] (NoArg (pmcfg False)) "Don't generate PMCFG (useful for libraries).",
Option [] ["optimize"] (ReqArg optimize "OPT")
Option [] ["optimize"] (ReqArg optimize "OPT")
"Select an optimization package. OPT = all | values | parametrize | none",
Option [] ["optimize-pgf"] (NoArg (optimize_pgf True))
"Enable or disable global grammar optimization. This could significantly reduce the size of the final PGF file",
@@ -447,7 +452,7 @@ optDescr =
optimize x = case lookup x optimizationPackages of
Just p -> set $ \o -> o { optOptimizations = p }
Nothing -> fail $ "Unknown optimization package: " ++ x
optimize_pgf x = set $ \o -> o { optOptimizePGF = x }
splitPGF x = set $ \o -> o { optSplitPGF = x }
@@ -471,7 +476,7 @@ outputFormats :: [(String,OutputFormat)]
outputFormats = map fst outputFormatsExpl
outputFormatsExpl :: [((String,OutputFormat),String)]
outputFormatsExpl =
outputFormatsExpl =
[(("pgf_pretty", FmtPGFPretty),"human-readable pgf"),
(("canonical_gf", FmtCanonicalGF),"Canonical GF source files"),
(("canonical_json", FmtCanonicalJson),"Canonical JSON source files"),
@@ -504,11 +509,11 @@ instance Read OutputFormat where
readsPrec = lookupReadsPrec outputFormats
optimizationPackages :: [(String, Set Optimization)]
optimizationPackages =
optimizationPackages =
[("all", Set.fromList [OptStem,OptCSE,OptExpand,OptParametrize]),
("values", Set.fromList [OptStem,OptCSE,OptExpand]),
("noexpand", Set.fromList [OptStem,OptCSE]),
-- deprecated
("all_subs", Set.fromList [OptStem,OptCSE,OptExpand,OptParametrize]),
("parametrize", Set.fromList [OptStem,OptCSE,OptExpand,OptParametrize]),
@@ -516,7 +521,7 @@ optimizationPackages =
]
cfgTransformNames :: [(String, CFGTransform)]
cfgTransformNames =
cfgTransformNames =
[("nolr", CFGNoLR),
("regular", CFGRegular),
("topdown", CFGTopDownFilter),
@@ -532,7 +537,8 @@ haskellOptionNames =
("lexical", HaskellLexical),
("concrete", HaskellConcrete),
("variants", HaskellVariants),
("data", HaskellData)]
("data", HaskellData),
("pgf2", HaskellPGF2)]
-- | This is for bacward compatibility. Since GHC 6.12 we
-- started using the native Unicode support in GHC but it
@@ -558,7 +564,7 @@ onOff f def = OptArg g "[on,off]"
_ -> fail $ "Expected [on,off], got: " ++ show x
readOutputFormat :: Fail.MonadFail m => String -> m OutputFormat
readOutputFormat s =
readOutputFormat s =
maybe (fail $ "Unknown output format: " ++ show s) return $ lookup s outputFormats
-- FIXME: this is a copy of the function in GF.Devel.UseIO.
@@ -570,7 +576,7 @@ splitInModuleSearchPath s = case break isPathSep s of
isPathSep :: Char -> Bool
isPathSep c = c == ':' || c == ';'
--
--
-- * Convenience functions for checking options
--
@@ -592,7 +598,7 @@ isLiteralCat opts c = Set.member c (flag optLiteralCats opts)
isLexicalCat :: Options -> String -> Bool
isLexicalCat opts c = Set.member c (flag optLexicalCats opts)
--
--
-- * Convenience functions for setting options
--
@@ -623,8 +629,8 @@ readMaybe s = case reads s of
toEnumBounded :: (Bounded a, Enum a, Ord a) => Int -> Maybe a
toEnumBounded i = let mi = minBound
ma = maxBound `asTypeOf` mi
in if i >= fromEnum mi && i <= fromEnum ma
ma = maxBound `asTypeOf` mi
in if i >= fromEnum mi && i <= fromEnum ma
then Just (toEnum i `asTypeOf` mi)
else Nothing