diff --git a/src/compiler/GF/Compile/PGFtoHaskell.hs b/src/compiler/GF/Compile/PGFtoHaskell.hs index 6356c9f6d..bc8e59f57 100644 --- a/src/compiler/GF/Compile/PGFtoHaskell.hs +++ b/src/compiler/GF/Compile/PGFtoHaskell.hs @@ -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 }" ] - diff --git a/src/compiler/GF/Infra/Option.hs b/src/compiler/GF/Infra/Option.hs index 6b7ff0cad..2a2ffd176 100644 --- a/src/compiler/GF/Infra/Option.hs +++ b/src/compiler/GF/Infra/Option.hs @@ -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 -- - 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