content: {-# LANGUAGE NamedFieldPuns #-}
  module Test.Options
  ( -- * Options
    Options(..)
  , defaultOptions
  , entries_
  , args_
    -- * Args optics
  , maxSuccess_
  , maxSize_
  , maxShrinks_
  , replay_
    -- * CLI options
  , parseOpts
  , defaultOpts
  , printErrors
  , header
  , withOptions
  ) where
  
  import Control.Monad ((<=<))
  import Data.Bool (bool)
  import Data.Foldable (traverse_)
  import Data.List (intercalate)
  import Fresnel.Lens (Lens', lens)
  import Fresnel.Setter (set, (%~))
  import Numeric (readDec)
  import System.Console.GetOpt
  import System.Environment (getProgName)
  import System.Exit (exitFailure, exitSuccess)
  import System.IO (hPutStrLn, stderr)
  import Test.QuickCheck (Args(..), stdArgs)
  import Test.QuickCheck.Random (QCGen)
  
  -- Options
  
  data Options = Options
    { entries :: [String]
    , args    :: Args
    }
  
  defaultOptions :: Options
  defaultOptions = Options{ entries = [], args = stdArgs{ maxSuccess = 250, chatty = False }}
  
  entries_ :: Lens' Options [String]
  entries_ = lens entries (\ o entries -> o{ entries })
  
  args_ :: Lens' Options Args
  args_ = lens args (\ o args -> o{ args })
  
  
  -- Args optics
  
  maxSuccess_ :: Lens' Args Int
  maxSuccess_ = lens maxSuccess (\ a maxSuccess -> a{ maxSuccess })
  
  maxSize_ :: Lens' Args Int
  maxSize_ = lens maxSize (\ a maxSize -> a{ maxSize })
  
  maxShrinks_ :: Lens' Args Int
  maxShrinks_ = lens maxShrinks (\ a maxShrinks -> a{ maxShrinks })
  
  replay_ :: Lens' Args (Maybe (QCGen, Int))
  replay_ = lens replay (\ a replay -> a{ replay })
  
  
  -- CLI options
  
  parseOpts :: [OptDescr (Options -> Options)] -> [String] -> Either [String] Options
  parseOpts opts args
    | null other
    , null errs = Right options
    | otherwise = Left (map ("Unrecognized argument: " ++) other ++ errs)
    where
    options = foldr ($) defaultOptions mods
    (mods, other, errs) = getOpt RequireOrder opts args
  
  defaultOpts :: [OptDescr (Options -> Options)]
  defaultOpts =
    [ Option "n" ["successes"] (ReqArg (set (args_.maxSuccess_)    . int)  "N")    "require N successful tests before concluding the property passes"
    , Option "z" ["size"]      (ReqArg (set (args_.maxSize_)       . int)  "N")    "increase the size parameter to a maximum of N for successive tests of a property"
    , Option "s" ["shrinks"]   (ReqArg (set (args_.maxShrinks_)    . int)  "N")    "perform a maximum of N shrinks; setting this to 0 disables shrinking"
    , Option "m" ["match"]     (ReqArg (\ s -> entries_ %~ (s:))           "NAME") "include the named group or property; can be used multiple times to include multiple groups/properties"
    , Option "r" ["replay"]    (ReqArg (set (args_.replay_) . Just . read) "SEED") "the seed and size to repeat"
    ]
    where
    int = fst . head . readDec
  
  printErrors :: [OptDescr a] -> [String] -> IO Bool
  printErrors opts errs = do
    name <- getProgName
    False <$ traverse_ (hPutStrLn stderr) (errs ++ [usageInfo (header name opts) opts])
  
  header :: String -> [OptDescr a] -> String
  header name opts = "Usage: " ++ name ++ " " ++ unwords (map opt opts) where
    opt (Option short long a _) = bracket (intercalate "|" ([ arg a ['-',c] | c <- short ] ++ map (arg a . ("--" ++)) long))
    arg (NoArg _)    = id
    arg (ReqArg _ s) = (++ " " ++ s)
    arg (OptArg _ s) = (++ bracket s)
    bracket s = "[" ++ s ++ "]"
  
  withOptions :: [OptDescr (Options -> Options)] -> (Options -> IO Bool) -> [String] -> IO ()
  withOptions opts f = bool exitFailure exitSuccess <=< either (printErrors opts) f . parseOpts opts
  