Skip to content

Commit

Permalink
Refactor option passing.
Browse files Browse the repository at this point in the history
The previous fmap-fmap-fmap style was already at breaking-point, so
rewrite monadically, building up an endomorphism on Run and treating
the not-yet-consumed command line flags as the state.
  • Loading branch information
quasicomputational committed Feb 9, 2021
1 parent e893335 commit 3f4da39
Showing 1 changed file with 71 additions and 28 deletions.
99 changes: 71 additions & 28 deletions src/Options.hs
Original file line number Diff line number Diff line change
Expand Up @@ -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)
Expand Down Expand Up @@ -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."

0 comments on commit 3f4da39

Please sign in to comment.