From 50ed99e9b164e1b90bc061c10c75206f5fbb930f Mon Sep 17 00:00:00 2001 From: bjorn Date: Wed, 15 Oct 2008 11:38:34 +0000 Subject: [PATCH] Added OPTIONS class to make options handling somewhat nicer. Next, I will merge Flags and ModuleFlags. --- src/GF/Compile.hs | 6 +-- src/GF/Compile/Coding.hs | 2 +- src/GF/Compile/Export.hs | 2 +- src/GF/Compile/GetGrammar.hs | 2 +- src/GF/Compile/GrammarToGFCC.hs | 4 +- src/GF/Compile/Optimize.hs | 6 +-- src/GF/Compile/ReadFiles.hs | 2 +- src/GF/Compile/Rebuild.hs | 2 +- src/GF/Infra/Modules.hs | 8 ++-- src/GF/Infra/Option.hs | 72 ++++++++++++++++---------------- src/GF/Source/SourceToGrammar.hs | 22 +++++----- 11 files changed, 65 insertions(+), 63 deletions(-) diff --git a/src/GF/Compile.hs b/src/GF/Compile.hs index 289bdd92b..226602616 100644 --- a/src/GF/Compile.hs +++ b/src/GF/Compile.hs @@ -68,13 +68,13 @@ link opts cnc gr = do optimize :: Options -> PGF -> PGF optimize opts = cse . suf - where os = moduleFlag optOptimizations opts + where os = flag optOptimizations opts cse = if OptCSE `Set.member` os then cseOptimize else id suf = if OptStem `Set.member` os then suffixOptimize else id buildParser :: Options -> PGF -> PGF buildParser opts = - if moduleFlag optBuildParser opts then addParsers else id + if flag optBuildParser opts then addParsers else id batchCompile :: Options -> [FilePath] -> IOE SourceGrammar batchCompile opts files = do @@ -112,7 +112,7 @@ compileModule opts1 env file = do opts0 <- getOptionsFromFile file let opts = addOptions opts0 opts1 let fdir = dropFileName file - let ps0 = moduleFlag optLibraryPath opts + let ps0 = flag optLibraryPath opts ps1 <- ioeIO $ extendPathEnv $ fdir : ps0 let ps2 = ps1 ++ map (fdir ) ps0 ps <- ioeIO $ fmap nub $ mapM canonicalizePath ps2 diff --git a/src/GF/Compile/Coding.hs b/src/GF/Compile/Coding.hs index 704e95201..89e458956 100644 --- a/src/GF/Compile/Coding.hs +++ b/src/GF/Compile/Coding.hs @@ -15,7 +15,7 @@ encodeStringsInModule = codeSourceModule encodeUTF8 decodeStringsInModule :: SourceModule -> SourceModule decodeStringsInModule mo = case mo of - (_,ModMod m) -> case moduleFlag optEncoding (moduleOptions (flags m)) of + (_,ModMod m) -> case flag optEncoding (flags m) of UTF_8 -> codeSourceModule decodeUTF8 mo CP_1251 -> codeSourceModule decodeCP1251 mo _ -> mo diff --git a/src/GF/Compile/Export.hs b/src/GF/Compile/Export.hs index 8b924113d..575a9dc84 100644 --- a/src/GF/Compile/Export.hs +++ b/src/GF/Compile/Export.hs @@ -51,7 +51,7 @@ exportPGF opts fmt pgf = FmtRegExp -> single "rexp" regexpPrinter FmtFA -> single "dot" slfGraphvizPrinter where - name = fromMaybe (prCId (absname pgf)) (moduleFlag optName opts) + name = fromMaybe (prCId (absname pgf)) (flag optName opts) multi :: String -> (PGF -> String) -> [(FilePath,String)] multi ext pr = [(name <.> ext, pr pgf)] diff --git a/src/GF/Compile/GetGrammar.hs b/src/GF/Compile/GetGrammar.hs index 6f02ac824..f9cdbcc14 100644 --- a/src/GF/Compile/GetGrammar.hs +++ b/src/GF/Compile/GetGrammar.hs @@ -38,7 +38,7 @@ import System.Cmd (system) getSourceModule :: Options -> FilePath -> IOE SourceModule getSourceModule opts file0 = do - file <- foldM runPreprocessor file0 (moduleFlag optPreprocessors opts) + file <- foldM runPreprocessor file0 (flag optPreprocessors opts) string <- readFileIOE file let tokens = myLexer string mo1 <- ioeErr $ pModDef tokens diff --git a/src/GF/Compile/GrammarToGFCC.hs b/src/GF/Compile/GrammarToGFCC.hs index e57937f52..5b2d14586 100644 --- a/src/GF/Compile/GrammarToGFCC.hs +++ b/src/GF/Compile/GrammarToGFCC.hs @@ -240,13 +240,13 @@ reorder abs cg = M.MGrammar $ predefADefs = [(c, AbsCat (Yes []) Nope) | c <- [cFloat,cInt,cString]] aflags = - concatModuleOptions [M.flags mo | (_,mo) <- M.allModMod cg, M.isModAbs mo] + concatOptions [M.flags mo | (_,mo) <- M.allModMod cg, M.isModAbs mo] cncs = sortIds [(lang, concr lang) | lang <- M.allConcretes cg abs] concr la = (flags, sortIds (predefCDefs ++ jments)) where jments = Look.allOrigInfos cg la - flags = concatModuleOptions + flags = concatOptions [M.flags mo | (i,mo) <- mos, M.isModCnc mo, Just r <- [lookup i (M.allExtendSpecs cg la)]] diff --git a/src/GF/Compile/Optimize.hs b/src/GF/Compile/Optimize.hs index 83cbeb57a..ca3e6ec3e 100644 --- a/src/GF/Compile/Optimize.hs +++ b/src/GF/Compile/Optimize.hs @@ -58,8 +58,8 @@ optimizeModule opts mse@(ms,eenv) mo@(_,mi) = case mi of return (mo2,eenv) _ -> evalModule oopts mse mo where - oopts = addOptions opts (moduleOptions (flagsModule mo)) - optim = moduleFlag optOptimizations oopts + oopts = opts `addOptions` toOptions (flagsModule mo) + optim = flag optOptimizations oopts evalModule :: Options -> ([(Ident,SourceModInfo)],EEnv) -> (Ident,SourceModInfo) -> Err ((Ident,SourceModInfo),EEnv) @@ -102,7 +102,7 @@ evalResInfo oopts gr (c,info) = case info of where comp = if optres then computeConcrete gr else computeConcreteRec gr eIn cat = errIn ("Error optimizing" +++ cat +++ prt c +++ ":") - optim = moduleFlag optOptimizations oopts + optim = flag optOptimizations oopts optres = OptExpand `Set.member` optim diff --git a/src/GF/Compile/ReadFiles.hs b/src/GF/Compile/ReadFiles.hs index a8558963e..67535227b 100644 --- a/src/GF/Compile/ReadFiles.hs +++ b/src/GF/Compile/ReadFiles.hs @@ -210,4 +210,4 @@ getOptionsFromFile file = do s <- ioeIO $ readFileIfStrict file let ls = filter (BS.isPrefixOf (BS.pack "--#")) $ BS.lines s fs = map (BS.unpack . BS.unwords . BS.words . BS.drop 3) ls - ioeErr $ liftM moduleOptions $ parseModuleOptions fs + ioeErr $ liftM toOptions $ parseModuleOptions fs diff --git a/src/GF/Compile/Rebuild.hs b/src/GF/Compile/Rebuild.hs index 5dc781887..04fc43d10 100644 --- a/src/GF/Compile/Rebuild.hs +++ b/src/GF/Compile/Rebuild.hs @@ -81,7 +81,7 @@ rebuildModule ms mo@(i,mi) = do ++ [oSimple i | i <- map snd insts] ---- --- check if me is incomplete - let fs1 = addModuleOptions fs fs_ -- new flags have priority + let fs1 = fs `addOptions` fs_ -- new flags have priority let js0 = [ci | ci@(c,_) <- tree2list js, isInherited incl c] let js1 = buildTree (tree2list js_ ++ js0) let ps1 = buildTree (tree2list ps_ ++ tree2list ps0) diff --git a/src/GF/Infra/Modules.hs b/src/GF/Infra/Modules.hs index 913afc89e..6c40944da 100644 --- a/src/GF/Infra/Modules.hs +++ b/src/GF/Infra/Modules.hs @@ -129,15 +129,15 @@ addOpenQualif i j (Module mt ms fs me ops js ps) = Module mt ms fs me (oQualif i j : ops) js ps addFlag :: ModuleOptions -> Module i t -> Module i t -addFlag f mo = mo {flags = addModuleOptions (flags mo) f} +addFlag f mo = mo {flags = flags mo `addOptions` f} flagsModule :: (i,ModInfo i a) -> ModuleOptions flagsModule (_,mi) = case mi of ModMod m -> flags m - _ -> noModuleOptions + _ -> noOptions allFlags :: MGrammar i a -> ModuleOptions -allFlags gr = concatModuleOptions $ map flags $ [m | (_, ModMod m) <- modules gr] +allFlags gr = concatOptions $ map flags $ [m | (_, ModMod m) <- modules gr] mapModules :: (Module i a -> Module i a) -> MGrammar i a -> MGrammar i a @@ -270,7 +270,7 @@ emptyModInfo = ModMod emptyModule emptyModule :: Module i a emptyModule = Module - MTResource MSComplete noModuleOptions [] [] emptyBinTree emptyBinTree + MTResource MSComplete noOptions [] [] emptyBinTree emptyBinTree -- | we store the module type with the identifier data IdentM i = IdentM { diff --git a/src/GF/Infra/Option.hs b/src/GF/Infra/Option.hs index 1a62c94ae..7b8a50db1 100644 --- a/src/GF/Infra/Option.hs +++ b/src/GF/Infra/Option.hs @@ -11,13 +11,12 @@ module GF.Infra.Option -- * Option pretty-printing moduleOptionsGFO, -- * Option manipulation + OPTIONS(..), addOptions, concatOptions, noOptions, - moduleOptions, - addModuleOptions, concatModuleOptions, noModuleOptions, modifyFlags, modifyModuleFlags, helpMessage, -- * Checking specific options - flag, moduleFlag, cfgTransform, haskellOption, + flag, cfgTransform, haskellOption, isLexicalCat, -- * Setting specific options setOptimization, setCFGTransform, @@ -200,7 +199,7 @@ parseModuleOptions :: [String] -> Err ModuleOptions parseModuleOptions args | not (null errs) = errors errs | not (null files) = errors $ map ("Non-option among module options: " ++) files - | otherwise = liftM concatModuleOptions $ sequence flags + | otherwise = liftM concatOptions $ sequence flags where (flags, files, errs) = getOpt RequireOrder moduleOptDescr args -- Showing options @@ -217,42 +216,45 @@ moduleOptionsGFO (ModuleOptions o) = -- Option manipulation -noOptions :: Options -noOptions = Options id +class OPTIONS a where + toOptions :: a -> Options + fromOptions :: Options -> a -addOptions :: Options -- ^ Existing options. - -> Options -- ^ Options to add (these take preference). - -> Options -addOptions (Options o1) (Options o2) = Options (o2 . o1) +instance OPTIONS Options where + toOptions = id + fromOptions = id -concatOptions :: [Options] -> Options +instance OPTIONS ModuleOptions where + toOptions (ModuleOptions f) = Options (\fs -> fs { optModuleFlags = f (optModuleFlags fs) }) + fromOptions (Options f) = ModuleOptions (\fs -> optModuleFlags (f (defaultFlags { optModuleFlags = fs}))) + +instance OPTIONS Flags where + toOptions fs = Options (\_ -> fs) + fromOptions (Options f) = f defaultFlags + +instance OPTIONS ModuleFlags where + toOptions mfs = Options (\fs -> fs { optModuleFlags = mfs }) + fromOptions (Options f) = optModuleFlags (f defaultFlags) + +flag :: (OPTIONS a, OPTIONS b) => (a -> c) -> b -> c +flag f o = f (fromOptions (toOptions o)) + +addOptions :: OPTIONS a => a -> a -> a +addOptions x y = let Options o1 = toOptions x + Options o2 = toOptions y + in fromOptions (Options (o2 . o1)) + +noOptions :: OPTIONS a => a +noOptions = fromOptions (Options id) + +concatOptions :: OPTIONS a => [a] -> a concatOptions = foldr addOptions noOptions -moduleOptions :: ModuleOptions -> Options -moduleOptions (ModuleOptions f) = Options (\o -> o { optModuleFlags = f (optModuleFlags o) }) - -addModuleOptions :: ModuleOptions -- ^ Existing options. - -> ModuleOptions -- ^ Options to add (these take preference). - -> ModuleOptions -addModuleOptions (ModuleOptions o1) (ModuleOptions o2) = ModuleOptions (o2 . o1) - -concatModuleOptions :: [ModuleOptions] -> ModuleOptions -concatModuleOptions = foldr addModuleOptions noModuleOptions - -noModuleOptions :: ModuleOptions -noModuleOptions = ModuleOptions id - -flag :: (Flags -> a) -> Options -> a -flag f (Options o) = f (o defaultFlags) - -moduleFlag :: (ModuleFlags -> a) -> Options -> a -moduleFlag f = flag (f . optModuleFlags) - modifyFlags :: (Flags -> Flags) -> Options modifyFlags = Options modifyModuleFlags :: (ModuleFlags -> ModuleFlags) -> Options -modifyModuleFlags = moduleOptions . ModuleOptions +modifyModuleFlags = toOptions . ModuleOptions {- @@ -454,7 +456,7 @@ optDescr = "Remove name qualifiers when pretty-printing.", Option [] ["retain"] (NoArg (set $ \o -> o { optRetainResource = True })) "Retain opers.", Option [] ["prob"] (NoArg (prob True)) "Read probabilities from '--# prob' pragmas." - ] ++ map (fmap (liftM moduleOptions)) moduleOptDescr + ] ++ map (fmap (liftM toOptions)) moduleOptDescr where phase x = set $ \o -> o { optStopAfterPhase = x } mode x = set $ \o -> o { optMode = x } verbosity mv = case mv of @@ -583,10 +585,10 @@ verbAtLeast :: Options -> Verbosity -> Bool verbAtLeast opts v = flag optVerbosity opts >= v dump :: Options -> Dump -> Bool -dump opts d = moduleFlag ((d `elem`) . optDump) opts +dump opts d = flag ((d `elem`) . optDump) opts cfgTransform :: Options -> CFGTransform -> Bool -cfgTransform opts t = Set.member t (moduleFlag optCFGTransforms opts) +cfgTransform opts t = Set.member t (flag optCFGTransforms opts) haskellOption :: Options -> HaskellOption -> Bool haskellOption opts o = Set.member o (flag optHaskellOptions opts) diff --git a/src/GF/Source/SourceToGrammar.hs b/src/GF/Source/SourceToGrammar.hs index 9c67f5c19..2bf7ae9ef 100644 --- a/src/GF/Source/SourceToGrammar.hs +++ b/src/GF/Source/SourceToGrammar.hs @@ -115,16 +115,16 @@ transModDef x = case x of defs0 <- mapM trDef $ getTopDefs defs poss0 <- return [(i,p) | Left ds <- defs0, (i,p,_) <- ds] defs' <- U.buildAnyTree [(i,d) | Left ds <- defs0, (i,_,d) <- ds] - flags' <- return $ concatModuleOptions [o | Right o <- defs0] + flags' <- return $ concatOptions [o | Right o <- defs0] let poss1 = buildPosTree id' poss0 return (id', GM.ModMod (GM.Module mtyp' mstat' flags' extends' opens' defs' poss1)) MReuse _ -> do - return (id', GM.ModMod (GM.Module mtyp' mstat' noModuleOptions [] [] emptyBinTree poss)) + return (id', GM.ModMod (GM.Module mtyp' mstat' noOptions [] [] emptyBinTree poss)) MUnion imps -> do imps' <- mapM transIncluded imps return (id', - GM.ModMod (GM.Module (GM.MTUnion mtyp' imps') mstat' noModuleOptions [] [] emptyBinTree poss)) + GM.ModMod (GM.Module (GM.MTUnion mtyp' imps') mstat' noOptions [] [] emptyBinTree poss)) MWith m insts -> mkBody xx $ MWithEBody [] m insts NoOpens [] MWithBody m insts opens defs -> mkBody xx $ MWithEBody [] m insts opens defs @@ -137,7 +137,7 @@ transModDef x = case x of defs0 <- mapM trDef $ getTopDefs defs poss0 <- return [(i,p) | Left ds <- defs0, (i,p,_) <- ds] defs' <- U.buildAnyTree [(i,d) | Left ds <- defs0, (i,_,d) <- ds] - flags' <- return $ concatModuleOptions [o | Right o <- defs0] + flags' <- return $ concatOptions [o | Right o <- defs0] let poss1 = buildPosTree id' poss0 return (id', GM.ModWith (GM.Module mtyp' mstat' flags' extends' opens' defs' poss1) m' insts') @@ -264,7 +264,7 @@ transAbsDef x = case x of DefTrans defs -> do defs' <- liftM concat $ mapM getDefsGen defs returnl [(c, nopos, G.AbsTrans f) | ((c,p),(_,Yes f)) <- defs'] - DefFlag defs -> liftM (Right . concatModuleOptions) $ mapM transFlagDef defs + DefFlag defs -> liftM (Right . concatOptions) $ mapM transFlagDef defs _ -> Bad $ "illegal definition in abstract module:" ++++ printTree x where -- to get data constructors as terms @@ -350,7 +350,7 @@ transResDef x = case x of defs' <- liftM concat $ mapM getDefs defs returnl [(f, p, G.ResOper pt pe) | ((f,p),(pt,pe)) <- defs'] - DefFlag defs -> liftM (Right . concatModuleOptions) $ mapM transFlagDef defs + DefFlag defs -> liftM (Right . concatOptions) $ mapM transFlagDef defs _ -> Bad $ "illegal definition form in resource" +++ printTree x where mkOverload op@(c,p,j) = case j of @@ -400,7 +400,7 @@ transCncDef x = case x of DefPrintOld defs -> do --- a guess, for backward compatibility defs' <- liftM concat $ mapM transPrintDef defs returnl [(f, nopos, G.CncFun Nothing nope (yes e)) | (f,e) <- defs'] - DefFlag defs -> liftM (Right . concatModuleOptions) $ mapM transFlagDef defs + DefFlag defs -> liftM (Right . concatOptions) $ mapM transFlagDef defs DefPattern defs -> do defs' <- liftM concat $ mapM getDefs defs let defs2 = [(f, termInPattern t) | (f,(_,Yes t)) <- defs'] @@ -727,10 +727,10 @@ transOldGrammar opts name0 x = case x of ne = NoExt q = CMCompl - name = maybe name0 (++ ".gf") $ moduleFlag optName opts - absName = identPI $ maybe topic id $ moduleFlag optAbsName opts - resName = identPI $ maybe ("Res" ++ lang) id $ moduleFlag optResName opts - cncName = identPI $ maybe lang id $ moduleFlag optCncName opts + name = maybe name0 (++ ".gf") $ flag optName opts + absName = identPI $ maybe topic id $ flag optAbsName opts + resName = identPI $ maybe ("Res" ++ lang) id $ flag optResName opts + cncName = identPI $ maybe lang id $ flag optCncName opts identPI s = PIdent ((0,0),BS.pack s)