{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE NoFieldSelectors #-}

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

  -- * Internal
  parseCliArgs,
  CLIParseResult (..),
  CLIFlagStore,
) where

import Control.Monad (when)
import Control.Monad.IO.Class (MonadIO, liftIO)
import Control.Monad.Trans.Class qualified as Trans
import Control.Monad.Trans.Except qualified as Trans
import Control.Monad.Trans.State qualified as Trans
import Data.Bifunctor (first, second)
import Data.Dynamic (Dynamic, fromDynamic, toDyn)
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.Proxy (Proxy (..))
import Data.Set qualified as Set
import Data.Text (Text)
import Data.Text qualified as Text
import Data.Text.IO qualified as Text
import Data.Typeable (TypeRep, Typeable, typeOf, typeRep)
import System.Environment (getArgs)
import System.Exit (exitFailure, exitSuccess)
import System.IO (stderr)
import System.IO.Unsafe (unsafePerformIO)
import UnliftIO.Exception (throwIO)

import Skeletest.Internal.Error (SkeletestError (..), invariantViolation)
import Skeletest.Internal.TestTargets (TestTargets, parseTestTargets)

-- | 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
--       { flagDefault = "foo"
--       , flagParse = \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
flagFromBool :: Bool -> a
      }
  | RequiredFlag
      { forall a. FlagSpec a -> String -> Either String a
flagParse :: String -> Either String a
      }
  | OptionalFlag
      { forall a. FlagSpec a -> a
flagDefault :: a
      , flagParse :: String -> Either String a
      }

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. 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 -> SkeletestError -> IO a
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO (SkeletestError -> IO a) -> SkeletestError -> IO a
forall a b. (a -> b) -> a -> b
$ Text -> SkeletestError
CliFlagNotFound (String -> Text
Text.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ forall a. IsFlag a => String
flagName @a)
  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)

{----- 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
  args0 <- IO [String]
getArgs
  case parseCliArgs (builtinFlags <> flags) args0 of
    CLISetupFailure Text
msg -> do
      Handle -> Text -> IO ()
Text.hPutStrLn Handle
stderr (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ Text
"ERROR: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
msg
      IO TestTargets
forall a. IO a
exitFailure
    CLIParseResult
CLIHelpRequested -> do
      Text -> IO ()
Text.putStrLn Text
helpText
      IO TestTargets
forall a. IO a
exitSuccess
    CLIParseFailure Text
msg -> do
      Handle -> Text -> IO ()
Text.hPutStrLn Handle
stderr (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
      IO TestTargets
forall a. IO a
exitFailure
    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)
      ]

    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
      }

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
  longFlags <- Either CLIParseResult (Map Text Flag)
extractLongFlags
  shortFlags <- extractShortFlags

  -- quick sweep for --help/-h after flag validation; skip parsing flags if so
  when (any (`elem` ["--help", "-h"]) args) $ Left CLIHelpRequested

  (args', flagStore) <- first CLIParseFailure $ parseCliArgsWith longFlags shortFlags args
  testTargets <- first CLIParseFailure $ parseTestTargets args'
  flagStore' <- first CLIParseFailure $ resolveFlags flags flagStore
  pure CLIParseSuccess{testTargets, flagStore = flagStore'}
  where
    extractLongFlags :: Either CLIParseResult (Map Text Flag)
extractLongFlags =
      (Text -> Text)
-> [(Text, Flag)] -> Either CLIParseResult (Map Text Flag)
forall name a.
Ord name =>
(name -> Text) -> [(name, a)] -> Either CLIParseResult (Map name a)
toFlagMap Text -> Text
renderLongFlag ([(Text, Flag)] -> Either CLIParseResult (Map Text Flag))
-> [(Text, Flag)] -> Either CLIParseResult (Map Text Flag)
forall a b. (a -> b) -> a -> b
$
        [ (String -> Text
Text.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ forall a. IsFlag a => String
flagName @a, Flag
f)
        | f :: Flag
f@(Flag (Proxy a
Proxy :: Proxy a)) <- [Flag]
flags
        ]

    extractShortFlags :: Either CLIParseResult (Map Char Flag)
extractShortFlags =
      (Char -> Text)
-> [(Char, Flag)] -> Either CLIParseResult (Map Char Flag)
forall name a.
Ord name =>
(name -> Text) -> [(name, a)] -> Either CLIParseResult (Map name a)
toFlagMap Char -> Text
renderShortFlag ([(Char, Flag)] -> Either CLIParseResult (Map Char Flag))
-> [(Char, Flag)] -> Either CLIParseResult (Map Char Flag)
forall a b. (a -> b) -> a -> b
$
        [ (Char
shortFlag, Flag
f)
        | f :: Flag
f@(Flag (Proxy a
Proxy :: Proxy a)) <- [Flag]
flags
        , Just Char
shortFlag <- Maybe Char -> [Maybe Char]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe Char -> [Maybe Char]) -> Maybe Char -> [Maybe Char]
forall a b. (a -> b) -> a -> b
$ forall a. IsFlag a => Maybe Char
flagShort @a
        ]

    toFlagMap :: (Ord name) => (name -> Text) -> [(name, a)] -> Either CLIParseResult (Map name a)
    toFlagMap :: forall name a.
Ord name =>
(name -> Text) -> [(name, a)] -> Either CLIParseResult (Map name a)
toFlagMap name -> Text
renderFlag [(name, a)]
vals =
      let go :: Set name -> [(name, b)] -> Either CLIParseResult (Map name a)
go Set name
seen = \case
            [] -> Map name a -> Either CLIParseResult (Map name a)
forall a b. b -> Either a b
Right (Map name a -> Either CLIParseResult (Map name a))
-> Map name a -> Either CLIParseResult (Map name a)
forall a b. (a -> b) -> a -> b
$ [(name, a)] -> Map name a
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(name, a)]
vals
            (name
name, b
_) : [(name, b)]
xs
              | name
name name -> Set name -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set name
seen -> CLIParseResult -> Either CLIParseResult (Map name a)
forall a b. a -> Either a b
Left (CLIParseResult -> Either CLIParseResult (Map name a))
-> (Text -> CLIParseResult)
-> Text
-> Either CLIParseResult (Map name a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> CLIParseResult
CLISetupFailure (Text -> Either CLIParseResult (Map name a))
-> Text -> Either CLIParseResult (Map name a)
forall a b. (a -> b) -> a -> b
$ Text
"Flag registered multiple times: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> name -> Text
renderFlag name
name
              | Bool
otherwise -> Set name -> [(name, b)] -> Either CLIParseResult (Map name a)
go (name -> Set name -> Set name
forall a. Ord a => a -> Set a -> Set a
Set.insert name
name Set name
seen) [(name, b)]
xs
       in Set name -> [(name, a)] -> Either CLIParseResult (Map name a)
forall {b}.
Set name -> [(name, b)] -> Either CLIParseResult (Map name a)
go Set name
forall a. Set a
Set.empty [(name, a)]
vals

type ArgParserM = Trans.StateT ([Text], CLIFlagStore) (Trans.Except Text)

parseCliArgsWith :: Map Text Flag -> Map Char Flag -> [String] -> Either Text ([Text], CLIFlagStore)
parseCliArgsWith :: Map Text Flag
-> Map Char Flag -> [String] -> Either Text ([Text], CLIFlagStore)
parseCliArgsWith Map Text Flag
longFlags Map Char Flag
shortFlags = Except Text ([Text], CLIFlagStore)
-> Either Text ([Text], CLIFlagStore)
forall e a. Except e a -> Either e a
Trans.runExcept (Except Text ([Text], CLIFlagStore)
 -> Either Text ([Text], CLIFlagStore))
-> ([String] -> Except Text ([Text], CLIFlagStore))
-> [String]
-> Either Text ([Text], CLIFlagStore)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (StateT ([Text], CLIFlagStore) (Except Text) ()
 -> ([Text], CLIFlagStore) -> Except Text ([Text], CLIFlagStore))
-> ([Text], CLIFlagStore)
-> StateT ([Text], CLIFlagStore) (Except Text) ()
-> Except Text ([Text], CLIFlagStore)
forall a b c. (a -> b -> c) -> b -> a -> c
flip StateT ([Text], CLIFlagStore) (Except Text) ()
-> ([Text], CLIFlagStore) -> Except Text ([Text], CLIFlagStore)
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m s
Trans.execStateT ([], CLIFlagStore
forall k a. Map k a
Map.empty) (StateT ([Text], CLIFlagStore) (Except Text) ()
 -> Except Text ([Text], CLIFlagStore))
-> ([String] -> StateT ([Text], CLIFlagStore) (Except Text) ())
-> [String]
-> Except Text ([Text], CLIFlagStore)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> StateT ([Text], CLIFlagStore) (Except Text) ()
parseArgs
  where
    parseArgs :: [String] -> StateT ([Text], CLIFlagStore) (Except Text) ()
parseArgs = \case
      [] -> () -> StateT ([Text], CLIFlagStore) (Except Text) ()
forall a. a -> StateT ([Text], CLIFlagStore) (Except Text) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
      String
"--" : [String]
rest -> [String] -> StateT ([Text], CLIFlagStore) (Except Text) ()
addArgs [String]
rest
      String
curr : [String]
rest
        | Just Text
longFlag <- Text -> Text -> Maybe Text
Text.stripPrefix Text
"--" (String -> Text
Text.pack String
curr) -> Text -> [String] -> StateT ([Text], CLIFlagStore) (Except Text) ()
parseLongFlag Text
longFlag [String]
rest
        | Just Text
chars <- Text -> Text -> Maybe Text
Text.stripPrefix Text
"-" (String -> Text
Text.pack String
curr) ->
            case Text -> String
Text.unpack Text
chars of
              [] -> Text -> StateT ([Text], CLIFlagStore) (Except Text) ()
forall {a} {a}.
a -> StateT ([Text], CLIFlagStore) (ExceptT a Identity) a
argError Text
"Invalid flag: -"
              [Char
shortFlag] -> Char -> [String] -> StateT ([Text], CLIFlagStore) (Except Text) ()
parseShortFlag Char
shortFlag [String]
rest
              String
_ -> Text -> StateT ([Text], CLIFlagStore) (Except Text) ()
forall {a} {a}.
a -> StateT ([Text], CLIFlagStore) (ExceptT a Identity) a
argError (Text -> StateT ([Text], CLIFlagStore) (Except Text) ())
-> Text -> StateT ([Text], CLIFlagStore) (Except Text) ()
forall a b. (a -> b) -> a -> b
$ Text
"Invalid flag: -" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
chars
        | Bool
otherwise -> [String] -> StateT ([Text], CLIFlagStore) (Except Text) ()
addArgs [String
curr] StateT ([Text], CLIFlagStore) (Except Text) ()
-> StateT ([Text], CLIFlagStore) (Except Text) ()
-> StateT ([Text], CLIFlagStore) (Except Text) ()
forall a b.
StateT ([Text], CLIFlagStore) (Except Text) a
-> StateT ([Text], CLIFlagStore) (Except Text) b
-> StateT ([Text], CLIFlagStore) (Except Text) b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> [String] -> StateT ([Text], CLIFlagStore) (Except Text) ()
parseArgs [String]
rest

    parseLongFlag :: Text -> [String] -> StateT ([Text], CLIFlagStore) (Except Text) ()
parseLongFlag Text
name [String]
args =
      let (Text
name', [String]
args') =
            case HasCallStack => Text -> Text -> (Text, Text)
Text -> Text -> (Text, Text)
Text.breakOn Text
"=" Text
name of
              (Text
_, Text
"") -> (Text
name, [String]
args)
              (Text
n, Text
post) -> (Text
n, (Int -> String -> String
forall a. Int -> [a] -> [a]
drop Int
1 (String -> String) -> (Text -> String) -> Text -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
Text.unpack) Text
post String -> [String] -> [String]
forall a. a -> [a] -> [a]
: [String]
args)
       in (Text -> Text)
-> Map Text Flag
-> Text
-> [String]
-> StateT ([Text], CLIFlagStore) (Except Text) ()
forall name.
Ord name =>
(name -> Text)
-> Map name Flag
-> name
-> [String]
-> StateT ([Text], CLIFlagStore) (Except Text) ()
parseFlag Text -> Text
renderLongFlag Map Text Flag
longFlags Text
name' [String]
args'
    parseShortFlag :: Char -> [String] -> StateT ([Text], CLIFlagStore) (Except Text) ()
parseShortFlag = (Char -> Text)
-> Map Char Flag
-> Char
-> [String]
-> StateT ([Text], CLIFlagStore) (Except Text) ()
forall name.
Ord name =>
(name -> Text)
-> Map name Flag
-> name
-> [String]
-> StateT ([Text], CLIFlagStore) (Except Text) ()
parseFlag Char -> Text
renderShortFlag Map Char Flag
shortFlags

    parseFlag :: (Ord name) => (name -> Text) -> Map name Flag -> name -> [String] -> ArgParserM ()
    parseFlag :: forall name.
Ord name =>
(name -> Text)
-> Map name Flag
-> name
-> [String]
-> StateT ([Text], CLIFlagStore) (Except Text) ()
parseFlag name -> Text
renderFlag Map name Flag
flagMap name
name [String]
args = do
      Flag (Proxy :: Proxy a) <-
        case name -> Map name Flag -> Maybe Flag
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup name
name Map name Flag
flagMap of
          Maybe Flag
Nothing -> Text -> StateT ([Text], CLIFlagStore) (Except Text) Flag
forall {a} {a}.
a -> StateT ([Text], CLIFlagStore) (ExceptT a Identity) a
argError (Text -> StateT ([Text], CLIFlagStore) (Except Text) Flag)
-> Text -> StateT ([Text], CLIFlagStore) (Except Text) Flag
forall a b. (a -> b) -> a -> b
$ Text
"Unknown flag: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> name -> Text
renderFlag name
name
          Just Flag
f -> Flag -> StateT ([Text], CLIFlagStore) (Except Text) Flag
forall a. a -> StateT ([Text], CLIFlagStore) (Except Text) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Flag
f
      let parseFlagArg String -> StateT ([Text], CLIFlagStore) (Except Text) a
parseArg =
            case [String]
args of
              [] -> Text -> StateT ([Text], CLIFlagStore) (Except Text) ()
forall {a} {a}.
a -> StateT ([Text], CLIFlagStore) (ExceptT a Identity) a
argError (Text -> StateT ([Text], CLIFlagStore) (Except Text) ())
-> Text -> StateT ([Text], CLIFlagStore) (Except Text) ()
forall a b. (a -> b) -> a -> b
$ Text
"Flag requires argument: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> name -> Text
renderFlag name
name
              String
curr : [String]
rest -> String -> StateT ([Text], CLIFlagStore) (Except Text) a
parseArg String
curr StateT ([Text], CLIFlagStore) (Except Text) a
-> (a -> StateT ([Text], CLIFlagStore) (Except Text) ())
-> StateT ([Text], CLIFlagStore) (Except Text) ()
forall a b.
StateT ([Text], CLIFlagStore) (Except Text) a
-> (a -> StateT ([Text], CLIFlagStore) (Except Text) b)
-> StateT ([Text], CLIFlagStore) (Except Text) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= a -> StateT ([Text], CLIFlagStore) (Except Text) ()
forall a.
Typeable a =>
a -> StateT ([Text], CLIFlagStore) (Except Text) ()
addFlagStore StateT ([Text], CLIFlagStore) (Except Text) ()
-> StateT ([Text], CLIFlagStore) (Except Text) ()
-> StateT ([Text], CLIFlagStore) (Except Text) ()
forall a b.
StateT ([Text], CLIFlagStore) (Except Text) a
-> StateT ([Text], CLIFlagStore) (Except Text) b
-> StateT ([Text], CLIFlagStore) (Except Text) b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> [String] -> StateT ([Text], CLIFlagStore) (Except Text) ()
parseArgs [String]
rest
      case flagSpec @a of
        SwitchFlag{Bool -> a
flagFromBool :: forall a. FlagSpec a -> Bool -> a
flagFromBool :: Bool -> a
flagFromBool} -> a -> StateT ([Text], CLIFlagStore) (Except Text) ()
forall a.
Typeable a =>
a -> StateT ([Text], CLIFlagStore) (Except Text) ()
addFlagStore (Bool -> a
flagFromBool Bool
True) StateT ([Text], CLIFlagStore) (Except Text) ()
-> StateT ([Text], CLIFlagStore) (Except Text) ()
-> StateT ([Text], CLIFlagStore) (Except Text) ()
forall a b.
StateT ([Text], CLIFlagStore) (Except Text) a
-> StateT ([Text], CLIFlagStore) (Except Text) b
-> StateT ([Text], CLIFlagStore) (Except Text) b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> [String] -> StateT ([Text], CLIFlagStore) (Except Text) ()
parseArgs [String]
args
        RequiredFlag{String -> Either String a
flagParse :: forall a. FlagSpec a -> String -> Either String a
flagParse :: String -> Either String a
flagParse} -> (String -> StateT ([Text], CLIFlagStore) (Except Text) a)
-> StateT ([Text], CLIFlagStore) (Except Text) ()
forall {a}.
Typeable a =>
(String -> StateT ([Text], CLIFlagStore) (Except Text) a)
-> StateT ([Text], CLIFlagStore) (Except Text) ()
parseFlagArg (ExceptT Text Identity a
-> StateT ([Text], CLIFlagStore) (Except Text) a
forall (m :: * -> *) a.
Monad m =>
m a -> StateT ([Text], CLIFlagStore) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
Trans.lift (ExceptT Text Identity a
 -> StateT ([Text], CLIFlagStore) (Except Text) a)
-> (String -> ExceptT Text Identity a)
-> String
-> StateT ([Text], CLIFlagStore) (Except Text) a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Either Text a -> ExceptT Text Identity a
forall (m :: * -> *) e a. Monad m => Either e a -> ExceptT e m a
Trans.except (Either Text a -> ExceptT Text Identity a)
-> (String -> Either Text a) -> String -> ExceptT Text Identity a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (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)
-> (String -> Either String a) -> String -> Either Text a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Either String a
flagParse)
        OptionalFlag{String -> Either String a
flagParse :: forall a. FlagSpec a -> String -> Either String a
flagParse :: String -> Either String a
flagParse} -> (String -> StateT ([Text], CLIFlagStore) (Except Text) a)
-> StateT ([Text], CLIFlagStore) (Except Text) ()
forall {a}.
Typeable a =>
(String -> StateT ([Text], CLIFlagStore) (Except Text) a)
-> StateT ([Text], CLIFlagStore) (Except Text) ()
parseFlagArg (ExceptT Text Identity a
-> StateT ([Text], CLIFlagStore) (Except Text) a
forall (m :: * -> *) a.
Monad m =>
m a -> StateT ([Text], CLIFlagStore) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
Trans.lift (ExceptT Text Identity a
 -> StateT ([Text], CLIFlagStore) (Except Text) a)
-> (String -> ExceptT Text Identity a)
-> String
-> StateT ([Text], CLIFlagStore) (Except Text) a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Either Text a -> ExceptT Text Identity a
forall (m :: * -> *) e a. Monad m => Either e a -> ExceptT e m a
Trans.except (Either Text a -> ExceptT Text Identity a)
-> (String -> Either Text a) -> String -> ExceptT Text Identity a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (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)
-> (String -> Either String a) -> String -> Either Text a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Either String a
flagParse)

    argError :: a -> StateT ([Text], CLIFlagStore) (ExceptT a Identity) a
argError = ExceptT a Identity a
-> StateT ([Text], CLIFlagStore) (ExceptT a Identity) a
forall (m :: * -> *) a.
Monad m =>
m a -> StateT ([Text], CLIFlagStore) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
Trans.lift (ExceptT a Identity a
 -> StateT ([Text], CLIFlagStore) (ExceptT a Identity) a)
-> (a -> ExceptT a Identity a)
-> a
-> StateT ([Text], CLIFlagStore) (ExceptT a Identity) a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> ExceptT a Identity a
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
Trans.throwE

    addArgs :: [String] -> ArgParserM ()
    addArgs :: [String] -> StateT ([Text], CLIFlagStore) (Except Text) ()
addArgs [String]
args = (([Text], CLIFlagStore) -> ([Text], CLIFlagStore))
-> StateT ([Text], CLIFlagStore) (Except Text) ()
forall (m :: * -> *) s. Monad m => (s -> s) -> StateT s m ()
Trans.modify (([Text] -> [Text])
-> ([Text], CLIFlagStore) -> ([Text], CLIFlagStore)
forall a b c. (a -> b) -> (a, c) -> (b, c)
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first ([Text] -> [Text] -> [Text]
forall a. Semigroup a => a -> a -> a
<> (String -> Text) -> [String] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map String -> Text
Text.pack [String]
args))

    addFlagStore :: (Typeable a) => a -> ArgParserM ()
    addFlagStore :: forall a.
Typeable a =>
a -> StateT ([Text], CLIFlagStore) (Except Text) ()
addFlagStore a
x = (([Text], CLIFlagStore) -> ([Text], CLIFlagStore))
-> StateT ([Text], CLIFlagStore) (Except Text) ()
forall (m :: * -> *) s. Monad m => (s -> s) -> StateT s m ()
Trans.modify ((CLIFlagStore -> CLIFlagStore)
-> ([Text], CLIFlagStore) -> ([Text], CLIFlagStore)
forall b c a. (b -> c) -> (a, b) -> (a, c)
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second (a -> CLIFlagStore -> CLIFlagStore
forall a. Typeable a => a -> CLIFlagStore -> CLIFlagStore
insertFlagStore a
x))

resolveFlags :: [Flag] -> CLIFlagStore -> Either Text CLIFlagStore
resolveFlags :: [Flag] -> CLIFlagStore -> Either Text CLIFlagStore
resolveFlags = (CLIFlagStore -> [Flag] -> Either Text CLIFlagStore)
-> [Flag] -> CLIFlagStore -> Either Text CLIFlagStore
forall a b c. (a -> b -> c) -> b -> a -> c
flip ((CLIFlagStore -> Flag -> Either Text CLIFlagStore)
-> CLIFlagStore -> [Flag] -> Either Text CLIFlagStore
forall {f :: * -> *} {t} {t}.
Monad f =>
(t -> t -> f t) -> t -> [t] -> f t
foldlM CLIFlagStore -> Flag -> Either Text CLIFlagStore
go)
  where
    go :: CLIFlagStore -> Flag -> Either Text CLIFlagStore
go CLIFlagStore
flagStore (Flag (Proxy a
Proxy :: Proxy a)) = do
      let 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)
      case forall a. IsFlag a => FlagSpec a
flagSpec @a of
        SwitchFlag{Bool -> a
flagFromBool :: forall a. FlagSpec a -> Bool -> a
flagFromBool :: Bool -> a
flagFromBool} ->
          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
$
            if TypeRep
rep TypeRep -> CLIFlagStore -> Bool
forall k a. Ord k => k -> Map k a -> Bool
`Map.member` CLIFlagStore
flagStore
              then CLIFlagStore
flagStore
              else a -> CLIFlagStore -> CLIFlagStore
forall a. Typeable a => a -> CLIFlagStore -> CLIFlagStore
insertFlagStore (Bool -> a
flagFromBool Bool
False) CLIFlagStore
flagStore
        RequiredFlag{} ->
          if TypeRep
rep TypeRep -> CLIFlagStore -> Bool
forall k a. Ord k => k -> Map k a -> Bool
`Map.member` CLIFlagStore
flagStore
            then CLIFlagStore -> Either Text CLIFlagStore
forall a. a -> Either Text a
forall (f :: * -> *) a. Applicative f => a -> f a
pure CLIFlagStore
flagStore
            else Text -> Either Text CLIFlagStore
forall a b. a -> Either a b
Left (Text -> Either Text CLIFlagStore)
-> Text -> Either Text CLIFlagStore
forall a b. (a -> b) -> a -> b
$ Text
"Required flag not set: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
renderLongFlag (String -> Text
Text.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ forall a. IsFlag a => String
flagName @a)
        OptionalFlag{a
flagDefault :: forall a. FlagSpec a -> a
flagDefault :: a
flagDefault} ->
          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
$
            if TypeRep
rep TypeRep -> CLIFlagStore -> Bool
forall k a. Ord k => k -> Map k a -> Bool
`Map.member` CLIFlagStore
flagStore
              then CLIFlagStore
flagStore
              else a -> CLIFlagStore -> CLIFlagStore
forall a. Typeable a => a -> CLIFlagStore -> CLIFlagStore
insertFlagStore a
flagDefault CLIFlagStore
flagStore

    foldlM :: (t -> t -> f t) -> t -> [t] -> f t
foldlM t -> t -> f t
f t
z = \case
      [] -> t -> f t
forall a. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure t
z
      t
x : [t]
xs -> do
        z' <- t -> t -> f t
f t
z t
x
        foldlM f z' xs

renderLongFlag :: Text -> Text
renderLongFlag :: Text -> Text
renderLongFlag = (Text
"--" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>)

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