Merge pull request #290 from quasicomputational/2021-040-refactor-opt…

…ions Refactor option passing.
sol · Feb 9, 2021 · f862507 · f862507
2 parents e893335 + 3f4da39
commit f862507
Showing 1 changed file with 71 additions and 28 deletions.
diff --git a/src/Options.hs b/src/Options.hs
@@ -18,8 +18,12 @@ module Options (
 import           Prelude ()
 import           Prelude.Compat
 
+import           Control.Monad.Trans.RWS (RWS, execRWS)
+import qualified Control.Monad.Trans.RWS as RWS
+
+import           Control.Monad (when)
 import           Data.List.Compat
-import           Data.Maybe
+import           Data.Monoid (Endo (Endo))
 
 import qualified Paths_doctest
 import           Data.Version (showVersion)
@@ -89,40 +93,79 @@ defaultPreserveIt = False
 defaultVerbose :: Bool
 defaultVerbose = False
 
-parseOptions :: [String] -> Result Run
-parseOptions args
-  | "--help" `elem` args = Output usage
-  | "--info" `elem` args = Output info
-  | "--version" `elem` args = Output versionInfo
-  | otherwise = case  fmap (fmap (fmap stripOptGhc))
-                   .  fmap (fmap stripVerbose)
-                   .  fmap stripPreserveIt
-                   .  stripFast
-                  <$> stripNoMagic args of
-      (magicMode, (fastMode, (preserveIt, (verbose, (warning, xs))))) ->
-        Result (Run (maybeToList warning) xs magicMode fastMode preserveIt verbose)
+defaultRun :: Run
+defaultRun = Run {
+  runWarnings = []
+, runOptions = []
+, runMagicMode = defaultMagic
+, runFastMode = defaultFastMode
+, runPreserveIt = defaultPreserveIt
+, runVerbose = defaultVerbose
+}
 
-stripNoMagic :: [String] -> (Bool, [String])
-stripNoMagic = stripFlag (not defaultMagic) "--no-magic"
+modifyWarnings :: ([String] -> [String]) -> Run -> Run
+modifyWarnings f run = run { runWarnings = f (runWarnings run) }
 
-stripFast :: [String] -> (Bool, [String])
-stripFast = stripFlag (not defaultFastMode) "--fast"
+setOptions :: [String] -> Run -> Run
+setOptions opts run = run { runOptions = opts }
 
-stripPreserveIt :: [String] -> (Bool, [String])
-stripPreserveIt = stripFlag (not defaultPreserveIt) "--preserve-it"
+setMagicMode :: Bool -> Run -> Run
+setMagicMode magic run = run { runMagicMode = magic }
 
-stripVerbose :: [String] -> (Bool, [String])
-stripVerbose = stripFlag (not defaultVerbose) "--verbose"
+setFastMode :: Bool -> Run -> Run
+setFastMode fast run = run { runFastMode = fast }
 
-stripFlag :: Bool -> String -> [String] -> (Bool, [String])
-stripFlag enableIt flag args = ((flag `elem` args) == enableIt, filter (/= flag) args)
+setPreserveIt :: Bool -> Run -> Run
+setPreserveIt preserveIt run = run { runPreserveIt = preserveIt }
 
-stripOptGhc :: [String] -> (Maybe Warning, [String])
-stripOptGhc = go
+setVerbose :: Bool -> Run -> Run
+setVerbose verbose run = run { runVerbose = verbose }
+
+parseOptions :: [String] -> Result Run
+parseOptions args
+  | "--help" `elem` args = Output usage
+  | "--info" `elem` args = Output info
+  | "--version" `elem` args = Output versionInfo
+  | otherwise = case execRWS parse () args of
+      (xs, Endo setter) ->
+        Result (setOptions xs $ setter defaultRun)
+    where
+      parse :: RWS () (Endo Run) [String] ()
+      parse = do
+        stripNoMagic
+        stripFast
+        stripPreserveIt
+        stripVerbose
+        stripOptGhc
+
+stripNoMagic :: RWS () (Endo Run) [String] ()
+stripNoMagic = stripFlag (setMagicMode False) "--no-magic"
+
+stripFast :: RWS () (Endo Run) [String] ()
+stripFast = stripFlag (setFastMode True) "--fast"
+
+stripPreserveIt :: RWS () (Endo Run) [String] ()
+stripPreserveIt = stripFlag (setPreserveIt True) "--preserve-it"
+
+stripVerbose :: RWS () (Endo Run) [String] ()
+stripVerbose = stripFlag (setVerbose True) "--verbose"
+
+stripFlag :: (Run -> Run) -> String -> RWS () (Endo Run) [String] ()
+stripFlag setter flag = do
+  args <- RWS.get
+  when (flag `elem` args) $
+    RWS.tell (Endo setter)
+  RWS.put (filter (/= flag) args)
+
+stripOptGhc :: RWS () (Endo Run) [String] ()
+stripOptGhc = do
+  issueWarning <- RWS.state go
+  when issueWarning $
+    RWS.tell $ Endo $ modifyWarnings (++ [warning])
   where
     go args = case args of
-      [] -> (Nothing, [])
-      "--optghc" : opt : rest -> (Just warning, opt : snd (go rest))
-      opt : rest -> maybe (fmap (opt :)) (\x (_, xs) -> (Just warning, x : xs)) (stripPrefix "--optghc=" opt) (go rest)
+      [] -> (False, [])
+      "--optghc" : opt : rest -> (True, opt : snd (go rest))
+      opt : rest -> maybe (fmap (opt :)) (\x (_, xs) -> (True, x : xs)) (stripPrefix "--optghc=" opt) (go rest)
 
     warning = "WARNING: --optghc is deprecated, doctest now accepts arbitrary GHC options\ndirectly."