{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedRecordDot #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE TypeAbstractions #-}
{-# LANGUAGE NoFieldSelectors #-}

module Skeletest.Internal.CLI (
  Flag (..),
  flag,
  IsFlag (..),
  FlagSpec (..),
  FlagType (..),
  getFlag,
  loadCliArgs,

  -- * General flags
  ANSIFlag (..),
  FormatFlag (..),
  getFormatFlag,

  -- * Internal
  parseCliArgsWith,
  FlagInfos,
  SomeFlagSpec (..),
  CLIParseResult (..),
) where

import Control.Monad (when)
import Control.Monad.IO.Class (MonadIO, liftIO)
import Data.Bifunctor (first)
import Data.Dynamic (Dynamic, fromDynamic, toDyn)
import Data.Foldable (foldlM)
import Data.Foldable qualified as Seq (toList)
import Data.Foldable1 qualified as Foldable1
import Data.IORef (IORef, newIORef, readIORef, writeIORef)
import Data.List.NonEmpty qualified as NonEmpty
import Data.Map (Map)
import Data.Map qualified as Map
import Data.Maybe (fromMaybe)
import Data.Proxy (Proxy (..))
import Data.Sequence (Seq)
import Data.Sequence qualified as Seq
import Data.Text (Text)
import Data.Text qualified as Text
import Data.Typeable (TypeRep, Typeable, typeOf, typeRep)
import Skeletest.Internal.Error (invariantViolation, skeletestError)
import Skeletest.Internal.Exit (TestExitCode (..), exitWith)
import Skeletest.Internal.TestTargets (TestTargets, parseTestTargets)
import Skeletest.Internal.Utils.Color qualified as Color
import Skeletest.Internal.Utils.Term qualified as Term
import System.Environment (getArgs)
import System.IO.Unsafe (unsafePerformIO)

#if !MIN_VERSION_base(4, 20, 0)
import Data.Foldable (foldl')
#endif

-- | Register a CLI flag.
--
-- Usage:
--
-- @
-- {- MyFixture.hs -}
-- import Skeletest
--
-- newtype MyFlag = MyFlag String
-- instance IsFlag MyFlag where
--   flagName = "my-flag"
--   flagHelp = "The value for MyFixture"
--   flagSpec =
--     OptionalFlag
--       { default_ = "foo"
--       , parse = \case
--           "illegal" -> Left "invalid flag value"
--           s -> Right (MyFlag s)
--       }
--
-- instance Fixture MyFixture where
--   fixtureAction = do
--     MyFlag val <- getFlag
--     ...
--
-- {- Main.hs -}
-- import MyFixture
--
-- cliFlags =
--   [ flag @MyFlag
--   ]
-- @
data Flag = forall a. (IsFlag a) => Flag (Proxy a)

flag :: forall a. (IsFlag a) => Flag
flag :: forall a. IsFlag a => Flag
flag = Proxy a -> Flag
forall a. IsFlag a => Proxy a -> Flag
Flag (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @a)

class (Typeable a) => IsFlag a where
  flagName :: String

  flagShort :: Maybe Char
  flagShort = Maybe Char
forall a. Maybe a
Nothing

  -- | The placeholder for the flag to show in the help text, if
  -- the flag takes an argument.
  flagMetaVar :: String
  flagMetaVar = String
"VAR"

  flagHelp :: String

  flagSpec :: FlagSpec a

data FlagSpec a
  = SwitchFlag
      { forall a. FlagSpec a -> Bool -> a
fromBool :: Bool -> a
      }
  | RequiredFlag
      { forall a. FlagSpec a -> String -> Either String a
parse :: String -> Either String a
      }
  | OptionalFlag
      { forall a. FlagSpec a -> a
default_ :: a
      , parse :: String -> Either String a
      }
  | forall x.
    MultiFlag
      { ()
type_ :: FlagType x
      , ()
parseMulti :: [x] -> Either String a
      }

data FlagType x where
  FlagType_Switch :: FlagType Bool
  FlagType_Arg :: FlagType String

getFlag :: forall a m. (MonadIO m, IsFlag a) => m a
getFlag :: forall a (m :: * -> *). (MonadIO m, IsFlag a) => m a
getFlag =
  IO a -> m a
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO a -> m a) -> IO a -> m a
forall a b. (a -> b) -> a -> b
$
    TypeRep -> IO (Maybe Dynamic)
lookupCliFlag TypeRep
rep IO (Maybe Dynamic) -> (Maybe Dynamic -> IO a) -> IO a
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      Just Dynamic
dyn ->
        case Dynamic -> Maybe a
forall a. Typeable a => Dynamic -> Maybe a
fromDynamic Dynamic
dyn of
          Just a
a -> a -> IO a
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
a
          Maybe a
Nothing ->
            String -> IO a
forall a. HasCallStack => String -> a
invariantViolation (String -> IO a) -> ([String] -> String) -> [String] -> IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> String
unwords ([String] -> IO a) -> [String] -> IO a
forall a b. (a -> b) -> a -> b
$
              [ String
"CLI flag store contained incorrect types."
              , String
"Expected: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> TypeRep -> String
forall a. Show a => a -> String
show TypeRep
rep String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"."
              , String
"Got: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Dynamic -> String
forall a. Show a => a -> String
show Dynamic
dyn
              ]
      Maybe Dynamic
Nothing ->
        Text -> IO a
forall (m :: * -> *) a. MonadIO m => Text -> m a
skeletestError (Text -> IO a) -> ([Text] -> Text) -> [Text] -> IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Text] -> Text
Text.unwords ([Text] -> IO a) -> [Text] -> IO a
forall a b. (a -> b) -> a -> b
$
          [ Text
"CLI flag '" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
Text.pack (forall a. IsFlag a => String
flagName @a) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"' was not registered."
          , Text
"Did you add it to cliFlags in Main.hs?"
          ]
 where
  rep :: TypeRep
rep = Proxy a -> TypeRep
forall {k} (proxy :: k -> *) (a :: k).
Typeable a =>
proxy a -> TypeRep
typeRep (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @a)

{----- General flags -----}

newtype ANSIFlag = ANSIFlag (Maybe Bool)
instance IsFlag ANSIFlag where
  flagName :: String
flagName = String
"ansi"
  flagHelp :: String
flagHelp = String
"Whether to enable ANSI output: auto (default), always, never"
  flagSpec :: FlagSpec ANSIFlag
flagSpec =
    OptionalFlag
      { default_ :: ANSIFlag
default_ = Maybe Bool -> ANSIFlag
ANSIFlag Maybe Bool
forall a. Maybe a
Nothing
      , parse :: String -> Either String ANSIFlag
parse = \case
          String
"auto" -> ANSIFlag -> Either String ANSIFlag
forall a b. b -> Either a b
Right (ANSIFlag -> Either String ANSIFlag)
-> (Maybe Bool -> ANSIFlag) -> Maybe Bool -> Either String ANSIFlag
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe Bool -> ANSIFlag
ANSIFlag (Maybe Bool -> Either String ANSIFlag)
-> Maybe Bool -> Either String ANSIFlag
forall a b. (a -> b) -> a -> b
$ Maybe Bool
forall a. Maybe a
Nothing
          String
"always" -> ANSIFlag -> Either String ANSIFlag
forall a b. b -> Either a b
Right (ANSIFlag -> Either String ANSIFlag)
-> (Maybe Bool -> ANSIFlag) -> Maybe Bool -> Either String ANSIFlag
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe Bool -> ANSIFlag
ANSIFlag (Maybe Bool -> Either String ANSIFlag)
-> Maybe Bool -> Either String ANSIFlag
forall a b. (a -> b) -> a -> b
$ Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
True
          String
"never" -> ANSIFlag -> Either String ANSIFlag
forall a b. b -> Either a b
Right (ANSIFlag -> Either String ANSIFlag)
-> (Maybe Bool -> ANSIFlag) -> Maybe Bool -> Either String ANSIFlag
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe Bool -> ANSIFlag
ANSIFlag (Maybe Bool -> Either String ANSIFlag)
-> Maybe Bool -> Either String ANSIFlag
forall a b. (a -> b) -> a -> b
$ Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
False
          String
s -> String -> Either String ANSIFlag
forall a b. a -> Either a b
Left (String -> Either String ANSIFlag)
-> String -> Either String ANSIFlag
forall a b. (a -> b) -> a -> b
$ String
"invalid value: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
s
      }

data FormatFlag
  = FormatFlag_Minimal
  | FormatFlag_Full
  | FormatFlag_Verbose
  deriving (Int -> FormatFlag -> String -> String
[FormatFlag] -> String -> String
FormatFlag -> String
(Int -> FormatFlag -> String -> String)
-> (FormatFlag -> String)
-> ([FormatFlag] -> String -> String)
-> Show FormatFlag
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: Int -> FormatFlag -> String -> String
showsPrec :: Int -> FormatFlag -> String -> String
$cshow :: FormatFlag -> String
show :: FormatFlag -> String
$cshowList :: [FormatFlag] -> String -> String
showList :: [FormatFlag] -> String -> String
Show, FormatFlag -> FormatFlag -> Bool
(FormatFlag -> FormatFlag -> Bool)
-> (FormatFlag -> FormatFlag -> Bool) -> Eq FormatFlag
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: FormatFlag -> FormatFlag -> Bool
== :: FormatFlag -> FormatFlag -> Bool
$c/= :: FormatFlag -> FormatFlag -> Bool
/= :: FormatFlag -> FormatFlag -> Bool
Eq)

instance IsFlag (Maybe FormatFlag) where
  flagName :: String
flagName = String
"format"
  flagHelp :: String
flagHelp = String
"The format of the output"
  flagSpec :: FlagSpec (Maybe FormatFlag)
flagSpec =
    OptionalFlag
      { default_ :: Maybe FormatFlag
default_ = Maybe FormatFlag
forall a. Maybe a
Nothing
      , parse :: String -> Either String (Maybe FormatFlag)
parse = \case
          String
"minimal" -> Maybe FormatFlag -> Either String (Maybe FormatFlag)
forall a b. b -> Either a b
Right (Maybe FormatFlag -> Either String (Maybe FormatFlag))
-> Maybe FormatFlag -> Either String (Maybe FormatFlag)
forall a b. (a -> b) -> a -> b
$ FormatFlag -> Maybe FormatFlag
forall a. a -> Maybe a
Just FormatFlag
FormatFlag_Minimal
          String
"full" -> Maybe FormatFlag -> Either String (Maybe FormatFlag)
forall a b. b -> Either a b
Right (Maybe FormatFlag -> Either String (Maybe FormatFlag))
-> Maybe FormatFlag -> Either String (Maybe FormatFlag)
forall a b. (a -> b) -> a -> b
$ FormatFlag -> Maybe FormatFlag
forall a. a -> Maybe a
Just FormatFlag
FormatFlag_Full
          String
"verbose" -> Maybe FormatFlag -> Either String (Maybe FormatFlag)
forall a b. b -> Either a b
Right (Maybe FormatFlag -> Either String (Maybe FormatFlag))
-> Maybe FormatFlag -> Either String (Maybe FormatFlag)
forall a b. (a -> b) -> a -> b
$ FormatFlag -> Maybe FormatFlag
forall a. a -> Maybe a
Just FormatFlag
FormatFlag_Verbose
          String
s -> String -> Either String (Maybe FormatFlag)
forall a b. a -> Either a b
Left (String -> Either String (Maybe FormatFlag))
-> String -> Either String (Maybe FormatFlag)
forall a b. (a -> b) -> a -> b
$ String
"Unknown format: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
s
      }

getFormatFlag :: IO FormatFlag
getFormatFlag :: IO FormatFlag
getFormatFlag = IO (Maybe FormatFlag)
forall a (m :: * -> *). (MonadIO m, IsFlag a) => m a
getFlag IO (Maybe FormatFlag)
-> (Maybe FormatFlag -> IO FormatFlag) -> IO FormatFlag
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= IO FormatFlag
-> (FormatFlag -> IO FormatFlag)
-> Maybe FormatFlag
-> IO FormatFlag
forall b a. b -> (a -> b) -> Maybe a -> b
maybe IO FormatFlag
getDefault FormatFlag -> IO FormatFlag
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
 where
  getDefault :: IO FormatFlag
getDefault = do
    Bool
supportsANSI <- Handle -> IO Bool
Term.supportsANSI Handle
Term.stdout
    FormatFlag -> IO FormatFlag
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (FormatFlag -> IO FormatFlag) -> FormatFlag -> IO FormatFlag
forall a b. (a -> b) -> a -> b
$
      if Bool
supportsANSI
        then FormatFlag
FormatFlag_Minimal
        else FormatFlag
FormatFlag_Full

{----- Load CLI arguments -----}

-- | Parse the CLI arguments using the given user-defined flags, then
-- stores the flags in the global state and returns the positional
-- arguments.
loadCliArgs :: [Flag] -> [Flag] -> IO TestTargets
loadCliArgs :: [Flag] -> [Flag] -> IO TestTargets
loadCliArgs [Flag]
builtinFlags [Flag]
flags = do
  [String]
args0 <- IO [String]
getArgs
  case [Flag] -> [String] -> CLIParseResult
parseCliArgs ([Flag]
builtinFlags [Flag] -> [Flag] -> [Flag]
forall a. Semigroup a => a -> a -> a
<> [Flag]
flags) [String]
args0 of
    CLISetupFailure Text
msg -> do
      Text -> IO ()
Term.outputErr (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ Text -> Text
Color.red (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ Text
"ERROR: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
msg
      TestExitCode -> IO TestTargets
forall a. TestExitCode -> IO a
exitWith TestExitCode
ExitCLIFailure
    CLIParseResult
CLIHelpRequested -> do
      Text -> IO ()
Term.output Text
helpText
      TestExitCode -> IO TestTargets
forall a. TestExitCode -> IO a
exitWith TestExitCode
ExitSuccess
    CLIParseFailure Text
msg -> do
      Text -> IO ()
Term.outputErr (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ Text
msg Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\n\n" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
helpText
      TestExitCode -> IO TestTargets
forall a. TestExitCode -> IO a
exitWith TestExitCode
ExitCLIFailure
    CLIParseSuccess{TestTargets
testTargets :: TestTargets
testTargets :: CLIParseResult -> TestTargets
testTargets, CLIFlagStore
flagStore :: CLIFlagStore
flagStore :: CLIParseResult -> CLIFlagStore
flagStore} -> do
      CLIFlagStore -> IO ()
setCliFlagStore CLIFlagStore
flagStore
      TestTargets -> IO TestTargets
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure TestTargets
testTargets
 where
  helpText :: Text
helpText = [Flag] -> [Flag] -> Text
getHelpText [Flag]
builtinFlags [Flag]
flags

getHelpText :: [Flag] -> [Flag] -> Text
getHelpText :: [Flag] -> [Flag] -> Text
getHelpText [Flag]
builtinFlags [Flag]
customFlags =
  Text -> [Text] -> Text
Text.intercalate Text
"\n\n" ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$
    Text
"Usage: skeletest [OPTIONS] [--] [TARGETS]" Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: ((Text, Text) -> Text) -> [(Text, Text)] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map ((Text -> Text -> Text) -> (Text, Text) -> Text
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Text -> Text -> Text
renderSection) [(Text, Text)]
helpSections
 where
  helpSections :: [(Text, Text)]
helpSections =
    ((Text, Text) -> Bool) -> [(Text, Text)] -> [(Text, Text)]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> ((Text, Text) -> Bool) -> (Text, Text) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Bool
Text.null (Text -> Bool) -> ((Text, Text) -> Text) -> (Text, Text) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text, Text) -> Text
forall a b. (a, b) -> b
snd) ([(Text, Text)] -> [(Text, Text)])
-> [(Text, Text)] -> [(Text, Text)]
forall a b. (a -> b) -> a -> b
$
      [ (Text
"TEST SELECTION", Text
testSelectionDocs)
      , (Text
"BUILTIN OPTIONS", [(Text, Maybe Char, Maybe Text, Text)] -> Text
renderFlagList [(Text, Maybe Char, Maybe Text, Text)]
builtinFlagDocs)
      , (Text
"CUSTOM OPTIONS", [(Text, Maybe Char, Maybe Text, Text)] -> Text
renderFlagList [(Text, Maybe Char, Maybe Text, Text)]
customFlagDocs)
      ]

  testSelectionDocs :: Text
testSelectionDocs =
    Text -> [Text] -> Text
Text.intercalate Text
"\n" ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$
      [ Text
"Test targets may be specified as plain positional arguments, with the following syntax:"
      , Text
"    * Tests including substring:      '[myFooFunc]'"
      , Text
"    * Tests tagged with marker:       '@fast'"
      , Text
"    * Tests in file, relative to CWD: 'test/MyLib/FooSpec.hs'"
      , Text
"    * Tests matching pattern in file: 'test/MyLib/FooSpec.hs[myFooFunc]'"
      , Text
"        * Syntax sugar for '(test/MyLib/FooSpec.hs and [myFooFunc])'"
      , Text
"    * Tests matching both targets:    '[func1] and [func2]'"
      , Text
"    * Tests matching either target:   '[func1] or [func2]'"
      , Text
"    * Tests not matching target:      'not [func1]'"
      , Text
""
      , Text
"More examples:"
      , Text
"    * 'test/MySpec.hs and ([myFooFunc] or [myBarFunc]) and @fast'"
      , Text
"    * '[myFooFunc] or test/MySpec.hs[myBarFunc]'"
      , Text
""
      , Text
"When multiple targets are specified, they are joined with 'or'."
      ]

  builtinFlagDocs :: [(Text, Maybe Char, Maybe Text, Text)]
builtinFlagDocs = (Text
"help", Char -> Maybe Char
forall a. a -> Maybe a
Just Char
'h', Maybe Text
forall a. Maybe a
Nothing, Text
"Display this help text") (Text, Maybe Char, Maybe Text, Text)
-> [(Text, Maybe Char, Maybe Text, Text)]
-> [(Text, Maybe Char, Maybe Text, Text)]
forall a. a -> [a] -> [a]
: [Flag] -> [(Text, Maybe Char, Maybe Text, Text)]
fromFlags [Flag]
builtinFlags
  customFlagDocs :: [(Text, Maybe Char, Maybe Text, Text)]
customFlagDocs = [Flag] -> [(Text, Maybe Char, Maybe Text, Text)]
fromFlags [Flag]
customFlags
  fromFlags :: [Flag] -> [(Text, Maybe Char, Maybe Text, Text)]
fromFlags [Flag]
flags =
    [ (String -> Text
Text.pack (forall a. IsFlag a => String
flagName @a), forall a. IsFlag a => Maybe Char
flagShort @a, Maybe Text
mMetaVar, String -> Text
Text.pack (forall a. IsFlag a => String
flagHelp @a))
    | Flag (Proxy a
Proxy :: Proxy a) <- [Flag]
flags
    , let mMetaVar :: Maybe Text
mMetaVar =
            case forall a. IsFlag a => FlagSpec a
flagSpec @a of
              SwitchFlag{} -> Maybe Text
forall a. Maybe a
Nothing
              RequiredFlag{} -> Text -> Maybe Text
forall a. a -> Maybe a
Just (Text -> Maybe Text) -> Text -> Maybe Text
forall a b. (a -> b) -> a -> b
$ String -> Text
Text.pack (forall a. IsFlag a => String
flagMetaVar @a)
              OptionalFlag{} -> Text -> Maybe Text
forall a. a -> Maybe a
Just (Text -> Maybe Text) -> Text -> Maybe Text
forall a b. (a -> b) -> a -> b
$ String -> Text
Text.pack (forall a. IsFlag a => String
flagMetaVar @a)
              MultiFlag{} -> Text -> Maybe Text
forall a. a -> Maybe a
Just (Text -> Maybe Text) -> Text -> Maybe Text
forall a b. (a -> b) -> a -> b
$ String -> Text
Text.pack (forall a. IsFlag a => String
flagMetaVar @a)
    ]

  renderSection :: Text -> Text -> Text
renderSection Text
title Text
body =
    Text -> [Text] -> Text
Text.intercalate Text
"\n" ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$
      [ Text
"===== " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
title
      , Text
""
      , Text
body
      ]

  renderFlagList :: [(Text, Maybe Char, Maybe Text, Text)] -> Text
renderFlagList [(Text, Maybe Char, Maybe Text, Text)]
flagList =
    Text -> [Text] -> Text
Text.intercalate Text
"\n" ([Text] -> Text)
-> ([(Text, Text)] -> [Text]) -> [(Text, Text)] -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(Text, Text)] -> [Text]
mkTabular ([(Text, Text)] -> Text) -> [(Text, Text)] -> Text
forall a b. (a -> b) -> a -> b
$
      [ (Text
shortName Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
renderLongFlag Text
longName Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
metaVar, Text
help)
      | (Text
longName, Maybe Char
mShortName, Maybe Text
mMetaVar, Text
help) <- [(Text, Maybe Char, Maybe Text, Text)]
flagList
      , let
          shortName :: Text
shortName =
            case Maybe Char
mShortName of
              Just Char
short -> Char -> Text
renderShortFlag Char
short Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", "
              Maybe Char
Nothing -> Text
""
          metaVar :: Text
metaVar =
            case Maybe Text
mMetaVar of
              Just Text
meta -> Text
" <" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
meta Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
">"
              Maybe Text
Nothing -> Text
""
      ]

  mkTabular :: [(Text, Text)] -> [Text]
mkTabular [(Text, Text)]
rows0 =
    case [(Text, Text)] -> Maybe (NonEmpty (Text, Text))
forall a. [a] -> Maybe (NonEmpty a)
NonEmpty.nonEmpty [(Text, Text)]
rows0 of
      Maybe (NonEmpty (Text, Text))
Nothing -> []
      Just NonEmpty (Text, Text)
rows ->
        let fstColWidth :: Int
fstColWidth = NonEmpty Int -> Int
forall a. Ord a => NonEmpty a -> a
forall (t :: * -> *) a. (Foldable1 t, Ord a) => t a -> a
Foldable1.maximum (NonEmpty Int -> Int) -> NonEmpty Int -> Int
forall a b. (a -> b) -> a -> b
$ ((Text, Text) -> Int) -> NonEmpty (Text, Text) -> NonEmpty Int
forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
NonEmpty.map (Text -> Int
Text.length (Text -> Int) -> ((Text, Text) -> Text) -> (Text, Text) -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text, Text) -> Text
forall a b. (a, b) -> a
fst) NonEmpty (Text, Text)
rows
            margin :: Int
margin = Int
2 -- space between columns
         in [ Text
a Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text -> Text
Text.replicate (Int
fstColWidth Int -> Int -> Int
forall a. Num a => a -> a -> a
- Text -> Int
Text.length Text
a Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
margin) Text
" " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
b
            | (Text
a, Text
b) <- NonEmpty (Text, Text) -> [(Text, Text)]
forall a. NonEmpty a -> [a]
NonEmpty.toList NonEmpty (Text, Text)
rows
            ]

{----- Parse args -----}

data CLIParseResult
  = CLISetupFailure Text
  | CLIHelpRequested
  | CLIParseFailure Text
  | CLIParseSuccess
      { CLIParseResult -> TestTargets
testTargets :: TestTargets
      , CLIParseResult -> CLIFlagStore
flagStore :: CLIFlagStore
      }

type FlagInfos = [(Text, Maybe Char, SomeFlagSpec)]
data SomeFlagSpec = forall a. (Typeable a) => SomeFlagSpec (FlagSpec a)

parseCliArgs :: [Flag] -> [String] -> CLIParseResult
parseCliArgs :: [Flag] -> [String] -> CLIParseResult
parseCliArgs [Flag]
flags [String]
args = (CLIParseResult -> CLIParseResult)
-> (CLIParseResult -> CLIParseResult)
-> Either CLIParseResult CLIParseResult
-> CLIParseResult
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either CLIParseResult -> CLIParseResult
forall a. a -> a
id CLIParseResult -> CLIParseResult
forall a. a -> a
id (Either CLIParseResult CLIParseResult -> CLIParseResult)
-> Either CLIParseResult CLIParseResult -> CLIParseResult
forall a b. (a -> b) -> a -> b
$ do
  FlagInfos
flagInfos <- [Flag] -> Either CLIParseResult FlagInfos
getFlagInfos [Flag]
flags
  CLIParseResult -> Either CLIParseResult CLIParseResult
forall a. a -> Either CLIParseResult a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (CLIParseResult -> Either CLIParseResult CLIParseResult)
-> CLIParseResult -> Either CLIParseResult CLIParseResult
forall a b. (a -> b) -> a -> b
$ FlagInfos -> [String] -> CLIParseResult
parseCliArgsWith FlagInfos
flagInfos [String]
args

getFlagInfos :: [Flag] -> Either CLIParseResult FlagInfos
getFlagInfos :: [Flag] -> Either CLIParseResult FlagInfos
getFlagInfos [Flag]
flags = do
  let infos :: FlagInfos
infos = (Flag -> (Text, Maybe Char, SomeFlagSpec)) -> [Flag] -> FlagInfos
forall a b. (a -> b) -> [a] -> [b]
map Flag -> (Text, Maybe Char, SomeFlagSpec)
fromFlag [Flag]
flags
  [Text] -> Either CLIParseResult ()
checkDups [Text -> Text
renderLongFlag Text
name | (Text
name, Maybe Char
_, SomeFlagSpec
_) <- FlagInfos
infos]
  [Text] -> Either CLIParseResult ()
checkDups [Char -> Text
renderShortFlag Char
c | (Text
_, Just Char
c, SomeFlagSpec
_) <- FlagInfos
infos]
  FlagInfos -> Either CLIParseResult FlagInfos
forall a. a -> Either CLIParseResult a
forall (f :: * -> *) a. Applicative f => a -> f a
pure FlagInfos
infos
 where
  fromFlag :: Flag -> (Text, Maybe Char, SomeFlagSpec)
fromFlag (Flag (Proxy @a)) =
    let name :: Text
name = String -> Text
Text.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ forall a. IsFlag a => String
flagName @a
        spec :: SomeFlagSpec
spec = FlagSpec a -> SomeFlagSpec
forall a. Typeable a => FlagSpec a -> SomeFlagSpec
SomeFlagSpec (forall a. IsFlag a => FlagSpec a
flagSpec @a)
     in (Text
name, forall a. IsFlag a => Maybe Char
flagShort @a, SomeFlagSpec
spec)

  checkDups :: [Text] -> Either CLIParseResult ()
checkDups [Text]
vals =
    case Map Text Int -> [Text]
forall k a. Map k a -> [k]
Map.keys (Map Text Int -> [Text])
-> ([Text] -> Map Text Int) -> [Text] -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int -> Bool) -> Map Text Int -> Map Text Int
forall a k. (a -> Bool) -> Map k a -> Map k a
Map.filter (Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
1) (Map Text Int -> Map Text Int)
-> ([Text] -> Map Text Int) -> [Text] -> Map Text Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int -> Int -> Int) -> [(Text, Int)] -> Map Text Int
forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
Map.fromListWith Int -> Int -> Int
forall a. Num a => a -> a -> a
(+) ([(Text, Int)] -> Map Text Int)
-> ([Text] -> [(Text, Int)]) -> [Text] -> Map Text Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text -> (Text, Int)) -> [Text] -> [(Text, Int)]
forall a b. (a -> b) -> [a] -> [b]
map (,Int
1 :: Int) ([Text] -> [Text]) -> [Text] -> [Text]
forall a b. (a -> b) -> a -> b
$ [Text]
vals of
      [] -> () -> Either CLIParseResult ()
forall a. a -> Either CLIParseResult a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
      Text
dup : [Text]
_ -> CLIParseResult -> Either CLIParseResult ()
forall a b. a -> Either a b
Left (CLIParseResult -> Either CLIParseResult ())
-> (Text -> CLIParseResult) -> Text -> Either CLIParseResult ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> CLIParseResult
CLISetupFailure (Text -> Either CLIParseResult ())
-> Text -> Either CLIParseResult ()
forall a b. (a -> b) -> a -> b
$ Text
"Flag registered multiple times: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
dup

parseCliArgsWith :: FlagInfos -> [String] -> CLIParseResult
parseCliArgsWith :: FlagInfos -> [String] -> CLIParseResult
parseCliArgsWith FlagInfos
flagInfos [String]
args = (CLIParseResult -> CLIParseResult)
-> (CLIParseResult -> CLIParseResult)
-> Either CLIParseResult CLIParseResult
-> CLIParseResult
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either CLIParseResult -> CLIParseResult
forall a. a -> a
id CLIParseResult -> CLIParseResult
forall a. a -> a
id (Either CLIParseResult CLIParseResult -> CLIParseResult)
-> Either CLIParseResult CLIParseResult -> CLIParseResult
forall a b. (a -> b) -> a -> b
$ do
  -- quick sweep for --help/-h; skip parsing flags if so
  Bool -> Either CLIParseResult () -> Either CLIParseResult ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ((String -> Bool) -> [String] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (String -> [String] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [String
"--help", String
"-h"]) [String]
args) (Either CLIParseResult () -> Either CLIParseResult ())
-> Either CLIParseResult () -> Either CLIParseResult ()
forall a b. (a -> b) -> a -> b
$ CLIParseResult -> Either CLIParseResult ()
forall a b. a -> Either a b
Left CLIParseResult
CLIHelpRequested

  (Map Text [Text]
flagVals, [Text]
args') <- FlagInfos
-> [Text] -> Either CLIParseResult (Map Text [Text], [Text])
collectCLIArgs FlagInfos
flagInfos ([Text] -> Either CLIParseResult (Map Text [Text], [Text]))
-> [Text] -> Either CLIParseResult (Map Text [Text], [Text])
forall a b. (a -> b) -> a -> b
$ (String -> Text) -> [String] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map String -> Text
Text.pack [String]
args
  TestTargets
testTargets <- (Text -> CLIParseResult)
-> Either Text TestTargets -> Either CLIParseResult TestTargets
forall a b c. (a -> b) -> Either a c -> Either b c
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first Text -> CLIParseResult
CLIParseFailure (Either Text TestTargets -> Either CLIParseResult TestTargets)
-> Either Text TestTargets -> Either CLIParseResult TestTargets
forall a b. (a -> b) -> a -> b
$ [Text] -> Either Text TestTargets
parseTestTargets [Text]
args'
  CLIFlagStore
flagStore <- FlagInfos -> Map Text [Text] -> Either CLIParseResult CLIFlagStore
parseCLIFlags FlagInfos
flagInfos Map Text [Text]
flagVals
  CLIParseResult -> Either CLIParseResult CLIParseResult
forall a. a -> Either CLIParseResult a
forall (f :: * -> *) a. Applicative f => a -> f a
pure CLIParseSuccess{TestTargets
testTargets :: TestTargets
testTargets :: TestTargets
testTargets, CLIFlagStore
flagStore :: CLIFlagStore
flagStore :: CLIFlagStore
flagStore}

collectCLIArgs ::
  FlagInfos ->
  [Text] ->
  Either CLIParseResult (Map Text [Text], [Text])
collectCLIArgs :: FlagInfos
-> [Text] -> Either CLIParseResult (Map Text [Text], [Text])
collectCLIArgs FlagInfos
flagInfos [Text]
args0 = (Text -> CLIParseResult)
-> Either Text (Map Text [Text], [Text])
-> Either CLIParseResult (Map Text [Text], [Text])
forall a b c. (a -> b) -> Either a c -> Either b c
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first Text -> CLIParseResult
CLIParseFailure (Either Text (Map Text [Text], [Text])
 -> Either CLIParseResult (Map Text [Text], [Text]))
-> Either Text (Map Text [Text], [Text])
-> Either CLIParseResult (Map Text [Text], [Text])
forall a b. (a -> b) -> a -> b
$ do
  (Map Text (Seq Text)
flagVals, Seq Text
posArgs) <- Map Text (Seq Text)
-> Seq Text
-> [Text]
-> Either Text (Map Text (Seq Text), Seq Text)
go Map Text (Seq Text)
forall k a. Map k a
Map.empty Seq Text
forall a. Seq a
Seq.empty [Text]
args0
  (Map Text [Text], [Text]) -> Either Text (Map Text [Text], [Text])
forall a. a -> Either Text a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((Seq Text -> [Text]) -> Map Text (Seq Text) -> Map Text [Text]
forall a b k. (a -> b) -> Map k a -> Map k b
Map.map Seq Text -> [Text]
forall a. Seq a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
Seq.toList Map Text (Seq Text)
flagVals, Seq Text -> [Text]
forall a. Seq a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
Seq.toList Seq Text
posArgs)
 where
  go :: Map Text (Seq Text) -> Seq Text -> [Text] -> Either Text (Map Text (Seq Text), Seq Text)
  go :: Map Text (Seq Text)
-> Seq Text
-> [Text]
-> Either Text (Map Text (Seq Text), Seq Text)
go Map Text (Seq Text)
flagVals Seq Text
posArgs = \case
    [] -> (Map Text (Seq Text), Seq Text)
-> Either Text (Map Text (Seq Text), Seq Text)
forall a b. b -> Either a b
Right (Map Text (Seq Text)
flagVals, Seq Text
posArgs)
    Text
"--" : [Text]
rest -> (Map Text (Seq Text), Seq Text)
-> Either Text (Map Text (Seq Text), Seq Text)
forall a b. b -> Either a b
Right (Map Text (Seq Text)
flagVals, Seq Text
posArgs Seq Text -> Seq Text -> Seq Text
forall a. Semigroup a => a -> a -> a
<> [Text] -> Seq Text
forall a. [a] -> Seq a
Seq.fromList [Text]
rest)
    Text
curr : [Text]
rest
      | Just Text
rawFlag <- Text -> Text -> Maybe Text
Text.stripPrefix Text
"--" Text
curr -> do
          (Text
name, Text
arg, [Text]
rest') <- Text -> [Text] -> Either Text (Text, Text, [Text])
parseLongFlag Text
rawFlag [Text]
rest
          Map Text (Seq Text)
-> Seq Text
-> [Text]
-> Either Text (Map Text (Seq Text), Seq Text)
go (Map Text (Seq Text) -> (Text, Text) -> Map Text (Seq Text)
addFlag Map Text (Seq Text)
flagVals (Text
name, Text
arg)) Seq Text
posArgs [Text]
rest'
      | Just Text
rawFlag <- Text -> Text -> Maybe Text
Text.stripPrefix Text
"-" Text
curr -> do
          ([(Text, Text)]
args, [Text]
rest') <- Text -> [Text] -> Either Text ([(Text, Text)], [Text])
parseShortFlags Text
rawFlag [Text]
rest
          let flagVals' :: Map Text (Seq Text)
flagVals' = (Map Text (Seq Text) -> (Text, Text) -> Map Text (Seq Text))
-> Map Text (Seq Text) -> [(Text, Text)] -> Map Text (Seq Text)
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' Map Text (Seq Text) -> (Text, Text) -> Map Text (Seq Text)
addFlag Map Text (Seq Text)
flagVals [(Text, Text)]
args
          Map Text (Seq Text)
-> Seq Text
-> [Text]
-> Either Text (Map Text (Seq Text), Seq Text)
go Map Text (Seq Text)
flagVals' Seq Text
posArgs [Text]
rest'
      | Bool
otherwise -> do
          Map Text (Seq Text)
-> Seq Text
-> [Text]
-> Either Text (Map Text (Seq Text), Seq Text)
go Map Text (Seq Text)
flagVals (Seq Text
posArgs Seq Text -> Text -> Seq Text
forall a. Seq a -> a -> Seq a
Seq.|> Text
curr) [Text]
rest

  longFlags :: Map Text SomeFlagSpec
longFlags = [(Text, SomeFlagSpec)] -> Map Text SomeFlagSpec
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(Text
name, SomeFlagSpec
spec) | (Text
name, Maybe Char
_, SomeFlagSpec
spec) <- FlagInfos
flagInfos]
  parseLongFlag :: Text -> [Text] -> Either Text (Text, Text, [Text])
parseLongFlag Text
rawFlag [Text]
rest = do
    let (Text
name, Maybe Text
mArg) =
          case HasCallStack => Text -> Text -> (Text, Text)
Text -> Text -> (Text, Text)
Text.breakOn Text
"=" Text
rawFlag of
            (Text
_, Text
"") -> (Text
rawFlag, Maybe Text
forall a. Maybe a
Nothing)
            (Text
n, Text
post) -> (Text
n, Text -> Maybe Text
forall a. a -> Maybe a
Just (Text -> Maybe Text) -> Text -> Maybe Text
forall a b. (a -> b) -> a -> b
$ Int -> Text -> Text
Text.drop Int
1 Text
post)
        flagDisp :: Text
flagDisp = Text -> Text
renderLongFlag Text
name
    SomeFlagSpec FlagSpec a
spec <-
      Either Text SomeFlagSpec
-> (SomeFlagSpec -> Either Text SomeFlagSpec)
-> Maybe SomeFlagSpec
-> Either Text SomeFlagSpec
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Text -> Either Text SomeFlagSpec
forall a b. a -> Either a b
Left (Text -> Either Text SomeFlagSpec)
-> Text -> Either Text SomeFlagSpec
forall a b. (a -> b) -> a -> b
$ Text
"Unknown flag: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
flagDisp) SomeFlagSpec -> Either Text SomeFlagSpec
forall a. a -> Either Text a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe SomeFlagSpec -> Either Text SomeFlagSpec)
-> Maybe SomeFlagSpec -> Either Text SomeFlagSpec
forall a b. (a -> b) -> a -> b
$
        Text -> Map Text SomeFlagSpec -> Maybe SomeFlagSpec
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Text
name Map Text SomeFlagSpec
longFlags
    (Text
arg, [Text]
rest') <- FlagSpec a
-> Text -> Maybe Text -> [Text] -> Either Text (Text, [Text])
forall {a} {a}.
(Semigroup a, IsString a) =>
FlagSpec a -> a -> Maybe a -> [a] -> Either a (a, [a])
validateArg FlagSpec a
spec Text
flagDisp Maybe Text
mArg [Text]
rest
    (Text, Text, [Text]) -> Either Text (Text, Text, [Text])
forall a. a -> Either Text a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text
name, Text
arg, [Text]
rest')

  shortFlags :: Map Char (Text, SomeFlagSpec)
shortFlags = [(Char, (Text, SomeFlagSpec))] -> Map Char (Text, SomeFlagSpec)
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(Char
c, (Text
name, SomeFlagSpec
spec)) | (Text
name, Just Char
c, SomeFlagSpec
spec) <- FlagInfos
flagInfos]
  parseShortFlags :: Text -> [Text] -> Either Text ([(Text, Text)], [Text])
parseShortFlags Text
rawFlag [Text]
rest = do
    (Char
char, Text
rawFlag') <-
      Either Text (Char, Text)
-> ((Char, Text) -> Either Text (Char, Text))
-> Maybe (Char, Text)
-> Either Text (Char, Text)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Text -> Either Text (Char, Text)
forall a b. a -> Either a b
Left Text
"Invalid flag: -") (Char, Text) -> Either Text (Char, Text)
forall a. a -> Either Text a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (Char, Text) -> Either Text (Char, Text))
-> Maybe (Char, Text) -> Either Text (Char, Text)
forall a b. (a -> b) -> a -> b
$
        Text -> Maybe (Char, Text)
Text.uncons Text
rawFlag
    let flagDisp :: Text
flagDisp = Char -> Text
renderShortFlag Char
char
    (Text
name, SomeFlagSpec FlagSpec a
spec) <-
      Either Text (Text, SomeFlagSpec)
-> ((Text, SomeFlagSpec) -> Either Text (Text, SomeFlagSpec))
-> Maybe (Text, SomeFlagSpec)
-> Either Text (Text, SomeFlagSpec)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Text -> Either Text (Text, SomeFlagSpec)
forall a b. a -> Either a b
Left (Text -> Either Text (Text, SomeFlagSpec))
-> Text -> Either Text (Text, SomeFlagSpec)
forall a b. (a -> b) -> a -> b
$ Text
"Unknown flag: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
flagDisp) (Text, SomeFlagSpec) -> Either Text (Text, SomeFlagSpec)
forall a. a -> Either Text a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (Text, SomeFlagSpec) -> Either Text (Text, SomeFlagSpec))
-> Maybe (Text, SomeFlagSpec) -> Either Text (Text, SomeFlagSpec)
forall a b. (a -> b) -> a -> b
$
        Char -> Map Char (Text, SomeFlagSpec) -> Maybe (Text, SomeFlagSpec)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Char
char Map Char (Text, SomeFlagSpec)
shortFlags
    let mArg :: Maybe Text
mArg =
          if (Bool -> Bool
not (Bool -> Bool) -> (Text -> Bool) -> Text -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Bool
Text.null) Text
rawFlag' Bool -> Bool -> Bool
&& FlagSpec a -> Bool
forall a. FlagSpec a -> Bool
expectsArg FlagSpec a
spec
            then Text -> Maybe Text
forall a. a -> Maybe a
Just Text
rawFlag'
            else Maybe Text
forall a. Maybe a
Nothing
        parseNext :: [Text] -> Either Text ([(Text, Text)], [Text])
parseNext =
          if (Bool -> Bool
not (Bool -> Bool) -> (Text -> Bool) -> Text -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Bool
Text.null) Text
rawFlag' Bool -> Bool -> Bool
&& (Bool -> Bool
not (Bool -> Bool) -> (FlagSpec a -> Bool) -> FlagSpec a -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FlagSpec a -> Bool
forall a. FlagSpec a -> Bool
expectsArg) FlagSpec a
spec
            then Text -> [Text] -> Either Text ([(Text, Text)], [Text])
parseShortFlags Text
rawFlag'
            else \[Text]
rest' -> ([(Text, Text)], [Text]) -> Either Text ([(Text, Text)], [Text])
forall a. a -> Either Text a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([], [Text]
rest')
    (Text
arg, [Text]
rest') <- FlagSpec a
-> Text -> Maybe Text -> [Text] -> Either Text (Text, [Text])
forall {a} {a}.
(Semigroup a, IsString a) =>
FlagSpec a -> a -> Maybe a -> [a] -> Either a (a, [a])
validateArg FlagSpec a
spec Text
flagDisp Maybe Text
mArg [Text]
rest
    ([(Text, Text)]
args, [Text]
rest'') <- [Text] -> Either Text ([(Text, Text)], [Text])
parseNext [Text]
rest'
    ([(Text, Text)], [Text]) -> Either Text ([(Text, Text)], [Text])
forall a. a -> Either Text a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((Text
name, Text
arg) (Text, Text) -> [(Text, Text)] -> [(Text, Text)]
forall a. a -> [a] -> [a]
: [(Text, Text)]
args, [Text]
rest'')

  validateArg :: FlagSpec a -> a -> Maybe a -> [a] -> Either a (a, [a])
validateArg FlagSpec a
spec a
flagDisp Maybe a
mArg [a]
rest = do
    if FlagSpec a -> Bool
forall a. FlagSpec a -> Bool
expectsArg FlagSpec a
spec
      then case (Maybe a
mArg, [a]
rest) of
        (Just a
arg, [a]
_) -> (a, [a]) -> Either a (a, [a])
forall a. a -> Either a a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (a
arg, [a]
rest)
        (Maybe a
Nothing, a
arg : [a]
rest') -> (a, [a]) -> Either a (a, [a])
forall a. a -> Either a a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (a
arg, [a]
rest')
        (Maybe a
Nothing, []) -> a -> Either a (a, [a])
forall a b. a -> Either a b
Left (a -> Either a (a, [a])) -> a -> Either a (a, [a])
forall a b. (a -> b) -> a -> b
$ a
"Flag '" a -> a -> a
forall a. Semigroup a => a -> a -> a
<> a
flagDisp a -> a -> a
forall a. Semigroup a => a -> a -> a
<> a
"' requires argument"
      else case (Maybe a
mArg, [a]
rest) of
        (Just a
arg, [a]
_) -> a -> Either a (a, [a])
forall a b. a -> Either a b
Left (a -> Either a (a, [a])) -> a -> Either a (a, [a])
forall a b. (a -> b) -> a -> b
$ a
"Flag '" a -> a -> a
forall a. Semigroup a => a -> a -> a
<> a
flagDisp a -> a -> a
forall a. Semigroup a => a -> a -> a
<> a
"' does not take arguments, got: " a -> a -> a
forall a. Semigroup a => a -> a -> a
<> a
arg
        (Maybe a, [a])
_ -> (a, [a]) -> Either a (a, [a])
forall a. a -> Either a a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (a
"", [a]
rest)

  expectsArg :: FlagSpec a -> Bool
  expectsArg :: forall a. FlagSpec a -> Bool
expectsArg = \case
    SwitchFlag{} -> Bool
False
    RequiredFlag{} -> Bool
True
    OptionalFlag{} -> Bool
True
    MultiFlag{FlagType x
type_ :: ()
type_ :: FlagType x
type_} ->
      case FlagType x
type_ of
        FlagType x
FlagType_Switch -> Bool
False
        FlagType x
FlagType_Arg -> Bool
True

  addFlag :: Map Text (Seq Text) -> (Text, Text) -> Map Text (Seq Text)
  addFlag :: Map Text (Seq Text) -> (Text, Text) -> Map Text (Seq Text)
addFlag Map Text (Seq Text)
flagVals (Text
name, Text
arg) =
    (Maybe (Seq Text) -> Maybe (Seq Text))
-> Text -> Map Text (Seq Text) -> Map Text (Seq Text)
forall k a.
Ord k =>
(Maybe a -> Maybe a) -> k -> Map k a -> Map k a
Map.alter
      (Seq Text -> Maybe (Seq Text)
forall a. a -> Maybe a
Just (Seq Text -> Maybe (Seq Text))
-> (Maybe (Seq Text) -> Seq Text)
-> Maybe (Seq Text)
-> Maybe (Seq Text)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Seq Text -> Text -> Seq Text
forall a. Seq a -> a -> Seq a
Seq.|> Text
arg) (Seq Text -> Seq Text)
-> (Maybe (Seq Text) -> Seq Text) -> Maybe (Seq Text) -> Seq Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Seq Text -> Maybe (Seq Text) -> Seq Text
forall a. a -> Maybe a -> a
fromMaybe Seq Text
forall a. Seq a
Seq.empty)
      Text
name
      Map Text (Seq Text)
flagVals

parseCLIFlags :: FlagInfos -> Map Text [Text] -> Either CLIParseResult CLIFlagStore
parseCLIFlags :: FlagInfos -> Map Text [Text] -> Either CLIParseResult CLIFlagStore
parseCLIFlags FlagInfos
flagInfos Map Text [Text]
flagVals = (Text -> CLIParseResult)
-> Either Text CLIFlagStore -> Either CLIParseResult CLIFlagStore
forall a b c. (a -> b) -> Either a c -> Either b c
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first Text -> CLIParseResult
CLIParseFailure (Either Text CLIFlagStore -> Either CLIParseResult CLIFlagStore)
-> Either Text CLIFlagStore -> Either CLIParseResult CLIFlagStore
forall a b. (a -> b) -> a -> b
$ (CLIFlagStore
 -> (Text, Maybe Char, SomeFlagSpec) -> Either Text CLIFlagStore)
-> CLIFlagStore -> FlagInfos -> Either Text CLIFlagStore
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldlM CLIFlagStore
-> (Text, Maybe Char, SomeFlagSpec) -> Either Text CLIFlagStore
go CLIFlagStore
forall k a. Map k a
Map.empty FlagInfos
flagInfos
 where
  go :: CLIFlagStore
-> (Text, Maybe Char, SomeFlagSpec) -> Either Text CLIFlagStore
go CLIFlagStore
flagStore (Text
name, Maybe Char
_, SomeFlagSpec FlagSpec a
spec0) = do
    let vals :: [Text]
vals = [Text] -> Text -> Map Text [Text] -> [Text]
forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault [] Text
name Map Text [Text]
flagVals
    a
val <- (String -> Text) -> Either String a -> Either Text a
forall a b c. (a -> b) -> Either a c -> Either b c
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first String -> Text
Text.pack (Either String a -> Either Text a)
-> ([Text] -> Either String a) -> [Text] -> Either Text a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> FlagSpec a -> [String] -> Either String a
forall a. Text -> FlagSpec a -> [String] -> Either String a
parse Text
name FlagSpec a
spec0 ([String] -> Either String a)
-> ([Text] -> [String]) -> [Text] -> Either String a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text -> String) -> [Text] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Text -> String
Text.unpack ([Text] -> Either Text a) -> [Text] -> Either Text a
forall a b. (a -> b) -> a -> b
$ [Text]
vals
    CLIFlagStore -> Either Text CLIFlagStore
forall a. a -> Either Text a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (CLIFlagStore -> Either Text CLIFlagStore)
-> CLIFlagStore -> Either Text CLIFlagStore
forall a b. (a -> b) -> a -> b
$ a -> CLIFlagStore -> CLIFlagStore
forall a. Typeable a => a -> CLIFlagStore -> CLIFlagStore
insertFlagStore a
val CLIFlagStore
flagStore

  parse :: Text -> FlagSpec a -> [String] -> Either String a
  parse :: forall a. Text -> FlagSpec a -> [String] -> Either String a
parse Text
name FlagSpec a
spec0 [String]
vals =
    case FlagSpec a
spec0 of
      spec :: FlagSpec a
spec@SwitchFlag{} -> do
        a -> Either String a
forall a. a -> Either String a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (FlagSpec a
spec.fromBool (Bool -> a) -> Bool -> a
forall a b. (a -> b) -> a -> b
$ (Bool -> Bool
not (Bool -> Bool) -> ([String] -> Bool) -> [String] -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null) [String]
vals)
      spec :: FlagSpec a
spec@RequiredFlag{} -> do
        String
val <- Either String String
-> (String -> Either String String)
-> Maybe String
-> Either String String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Text -> Either String String
forall {b}. Text -> Either String b
throwRequired Text
name) String -> Either String String
forall a. a -> Either String a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe String -> Either String String)
-> Maybe String -> Either String String
forall a b. (a -> b) -> a -> b
$ [String] -> Maybe String
forall {b}. [b] -> Maybe b
getLast [String]
vals
        FlagSpec a
spec.parse String
val
      spec :: FlagSpec a
spec@OptionalFlag{} -> do
        case [String] -> Maybe String
forall {b}. [b] -> Maybe b
getLast [String]
vals of
          Maybe String
Nothing -> a -> Either String a
forall a. a -> Either String a
forall (f :: * -> *) a. Applicative f => a -> f a
pure FlagSpec a
spec.default_
          Just String
val -> FlagSpec a
spec.parse String
val
      MultiFlag{FlagType x
type_ :: ()
type_ :: FlagType x
type_, [x] -> Either String a
parseMulti :: ()
parseMulti :: [x] -> Either String a
parseMulti} -> do
        [x] -> Either String a
parseMulti ([x] -> Either String a) -> [x] -> Either String a
forall a b. (a -> b) -> a -> b
$
          case FlagType x
type_ of
            FlagType x
FlagType_Switch -> x
Bool
True x -> [String] -> [x]
forall a b. a -> [b] -> [a]
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ [String]
vals
            FlagType x
FlagType_Arg -> [x]
[String]
vals

  throwRequired :: Text -> Either String b
throwRequired Text
name = String -> Either String b
forall a b. a -> Either a b
Left (String -> Either String b) -> String -> Either String b
forall a b. (a -> b) -> a -> b
$ String
"Flag '" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> (Text -> String
Text.unpack (Text -> String) -> (Text -> Text) -> Text -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
renderLongFlag) Text
name String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"' is required"
  getLast :: [b] -> Maybe b
getLast = (NonEmpty b -> b) -> Maybe (NonEmpty b) -> Maybe b
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap NonEmpty b -> b
forall a. NonEmpty a -> a
NonEmpty.last (Maybe (NonEmpty b) -> Maybe b)
-> ([b] -> Maybe (NonEmpty b)) -> [b] -> Maybe b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [b] -> Maybe (NonEmpty b)
forall a. [a] -> Maybe (NonEmpty a)
NonEmpty.nonEmpty

renderLongFlag :: Text -> Text
renderLongFlag :: Text -> Text
renderLongFlag = (Text
"--" <>)

renderShortFlag :: Char -> Text
renderShortFlag :: Char -> Text
renderShortFlag Char
c = String -> Text
Text.pack [Char
'-', Char
c]

{----- CLIFlagStore -----}

type CLIFlagStore = Map TypeRep Dynamic

insertFlagStore :: (Typeable a) => a -> CLIFlagStore -> CLIFlagStore
insertFlagStore :: forall a. Typeable a => a -> CLIFlagStore -> CLIFlagStore
insertFlagStore a
x = TypeRep -> Dynamic -> CLIFlagStore -> CLIFlagStore
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert (a -> TypeRep
forall a. Typeable a => a -> TypeRep
typeOf a
x) (a -> Dynamic
forall a. Typeable a => a -> Dynamic
toDyn a
x)

cliFlagStoreRef :: IORef CLIFlagStore
cliFlagStoreRef :: IORef CLIFlagStore
cliFlagStoreRef = IO (IORef CLIFlagStore) -> IORef CLIFlagStore
forall a. IO a -> a
unsafePerformIO (IO (IORef CLIFlagStore) -> IORef CLIFlagStore)
-> IO (IORef CLIFlagStore) -> IORef CLIFlagStore
forall a b. (a -> b) -> a -> b
$ CLIFlagStore -> IO (IORef CLIFlagStore)
forall a. a -> IO (IORef a)
newIORef CLIFlagStore
forall k a. Map k a
Map.empty
{-# NOINLINE cliFlagStoreRef #-}

setCliFlagStore :: CLIFlagStore -> IO ()
setCliFlagStore :: CLIFlagStore -> IO ()
setCliFlagStore = IORef CLIFlagStore -> CLIFlagStore -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef CLIFlagStore
cliFlagStoreRef

lookupCliFlag :: TypeRep -> IO (Maybe Dynamic)
lookupCliFlag :: TypeRep -> IO (Maybe Dynamic)
lookupCliFlag TypeRep
rep = TypeRep -> CLIFlagStore -> Maybe Dynamic
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup TypeRep
rep (CLIFlagStore -> Maybe Dynamic)
-> IO CLIFlagStore -> IO (Maybe Dynamic)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IORef CLIFlagStore -> IO CLIFlagStore
forall a. IORef a -> IO a
readIORef IORef CLIFlagStore
cliFlagStoreRef