Added OPTIONS class to make options handling somewhat nicer. Next, I will merge Flags and ModuleFlags.

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

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

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)]

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

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)]]

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
 
 

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

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)

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 {

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)

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)