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

2 files changed, 36 insertions, 34 deletions

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
-concatOptions = foldr addOptions noOptions
+instance OPTIONS ModuleOptions where
+    toOptions (ModuleOptions f) = Options (\fs -> fs { optModuleFlags = f (optModuleFlags fs) })
+    fromOptions (Options f) = ModuleOptions (\fs -> optModuleFlags (f (defaultFlags { optModuleFlags = fs})))
 
-moduleOptions :: ModuleOptions -> Options
-moduleOptions (ModuleOptions f) = Options (\o -> o { optModuleFlags = f (optModuleFlags o) })
+instance OPTIONS Flags where
+    toOptions fs = Options (\_ -> fs)
+    fromOptions (Options f) = f defaultFlags
 
-addModuleOptions :: ModuleOptions -- ^ Existing options.
-                 -> ModuleOptions -- ^ Options to add (these take preference).
-                 -> ModuleOptions
-addModuleOptions (ModuleOptions o1) (ModuleOptions o2) = ModuleOptions (o2 . o1)
+instance OPTIONS ModuleFlags where
+    toOptions mfs = Options (\fs -> fs { optModuleFlags = mfs })
+    fromOptions (Options f) = optModuleFlags (f defaultFlags)
 
-concatModuleOptions :: [ModuleOptions] -> ModuleOptions
-concatModuleOptions = foldr addModuleOptions noModuleOptions
+flag :: (OPTIONS a, OPTIONS b) => (a -> c) -> b -> c
+flag f o = f (fromOptions (toOptions o))
 
-noModuleOptions :: ModuleOptions
-noModuleOptions = ModuleOptions id
+addOptions :: OPTIONS a => a -> a -> a
+addOptions x y = let Options o1 = toOptions x
+                     Options o2 = toOptions y
+                  in fromOptions (Options (o2 . o1))
 
-flag :: (Flags -> a) -> Options -> a
-flag f (Options o) = f (o defaultFlags)
+noOptions :: OPTIONS a => a
+noOptions = fromOptions (Options id)
 
-moduleFlag :: (ModuleFlags -> a) -> Options -> a
-moduleFlag f = flag (f . optModuleFlags)
+concatOptions :: OPTIONS a => [a] -> a
+concatOptions = foldr addOptions noOptions
 
 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)