{-# LANGUAGE OverloadedLists #-}

module Shrun.Configuration.Args.Parsing.Utils
  ( -- * Simple help
    mkHelp,
    mkHelpNoLine,

    -- * Disabled parser
    withDisabledParser,
    mWithDisabledParser,
    withDisabledParserNoOpts,

    -- * Switch parser
    switchParser,
    switchParserNoLine,
    switchParserOpts,

    -- * Misc
    autoStripUnderscores,
    itemize,
    itemizeNoLine,
    itemizeHelper,
    toChunk,
    toMDoc,
  )
where

import Options.Applicative (OptionFields, Parser)
import Options.Applicative qualified as OA
import Options.Applicative.Builder (Mod, ReadM)
import Options.Applicative.Help.Chunk (Chunk (Chunk))
import Options.Applicative.Help.Chunk qualified as Chunk
import Options.Applicative.Help.Pretty qualified as Pretty
import Shrun.Configuration.Data.ConfigPhase qualified as ConfigPhase
import Shrun.Configuration.Data.WithDisabled (WithDisabled)
import Shrun.Configuration.Data.WithDisabled qualified as WD
import Shrun.Prelude
import Shrun.Utils qualified as ShrunUtils
import Text.Read (Read)

-- Looks a bit convoluted, but this gets us what we want:
-- 1. lines aligned (paragraph)
-- 2. linebreak at the end (fmap hardline)
mkHelp :: String -> OA.Mod f a
mkHelp :: forall (f :: Type -> Type) a. String -> Mod f a
mkHelp =
  Maybe (Doc AnsiStyle) -> Mod f a
forall (f :: Type -> Type) a. Maybe (Doc AnsiStyle) -> Mod f a
OA.helpDoc
    (Maybe (Doc AnsiStyle) -> Mod f a)
-> (String -> Maybe (Doc AnsiStyle)) -> String -> Mod f a
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> Type) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. (Doc AnsiStyle -> Doc AnsiStyle)
-> Maybe (Doc AnsiStyle) -> Maybe (Doc AnsiStyle)
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap (Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall a. Semigroup a => a -> a -> a
<> Doc AnsiStyle
forall ann. Doc ann
Pretty.hardline)
    (Maybe (Doc AnsiStyle) -> Maybe (Doc AnsiStyle))
-> (String -> Maybe (Doc AnsiStyle))
-> String
-> Maybe (Doc AnsiStyle)
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> Type) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. String -> Maybe (Doc AnsiStyle)
toMDoc

mkHelpNoLine :: String -> OA.Mod f a
mkHelpNoLine :: forall (f :: Type -> Type) a. String -> Mod f a
mkHelpNoLine = Maybe (Doc AnsiStyle) -> Mod f a
forall (f :: Type -> Type) a. Maybe (Doc AnsiStyle) -> Mod f a
OA.helpDoc (Maybe (Doc AnsiStyle) -> Mod f a)
-> (String -> Maybe (Doc AnsiStyle)) -> String -> Mod f a
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> Type) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. String -> Maybe (Doc AnsiStyle)
toMDoc

-- | Reads 'Text', strips underscores, then uses the Read class. This is
-- essentially 'auto' but removes underscores. This is used for nicer
-- numeric values e.g. allowing parsing "1_000_000" as a Num.
autoStripUnderscores :: (Read a) => ReadM a
autoStripUnderscores :: forall a. Read a => ReadM a
autoStripUnderscores = ReadM Text
forall s. IsString s => ReadM s
OA.str ReadM Text -> (Text -> ReadM a) -> ReadM a
forall a b. ReadM a -> (a -> ReadM b) -> ReadM b
forall (m :: Type -> Type) a b. Monad m => m a -> (a -> m b) -> m b
>>= Text -> ReadM a
forall (m :: Type -> Type) a. (MonadFail m, Read a) => Text -> m a
ShrunUtils.readStripUnderscores

-- | Constructs a parser for (Maybe (WithDisabled a)).
mWithDisabledParser ::
  -- | Reader for a.
  ReadM a ->
  -- | Modifier list e.g. option name, help text.
  List (Mod OA.OptionFields (WithDisabled a)) ->
  -- | Metavar string.
  Tuple2 Bool (List String) ->
  Parser (Maybe (WithDisabled a))
mWithDisabledParser :: forall a.
ReadM a
-> [Mod OptionFields (WithDisabled a)]
-> (Bool, [String])
-> Parser (Maybe (WithDisabled a))
mWithDisabledParser ReadM a
rdr [Mod OptionFields (WithDisabled a)]
opts = Parser (WithDisabled a) -> Parser (Maybe (WithDisabled a))
forall (f :: Type -> Type) a. Alternative f => f a -> f (Maybe a)
OA.optional (Parser (WithDisabled a) -> Parser (Maybe (WithDisabled a)))
-> ((Bool, [String]) -> Parser (WithDisabled a))
-> (Bool, [String])
-> Parser (Maybe (WithDisabled a))
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> Type) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. ReadM a
-> [Mod OptionFields (WithDisabled a)]
-> (Bool, [String])
-> Parser (WithDisabled a)
forall a.
ReadM a
-> [Mod OptionFields (WithDisabled a)]
-> (Bool, [String])
-> Parser (WithDisabled a)
withDisabledParser ReadM a
rdr [Mod OptionFields (WithDisabled a)]
opts

-- | Constructs a parser for (WithDisabled a).
withDisabledParser ::
  -- | Reader for a.
  ReadM a ->
  -- | Modifier list e.g. option name, help text.
  List (Mod OA.OptionFields (WithDisabled a)) ->
  -- | Metavar string.
  Tuple2 Bool (List String) ->
  Parser (WithDisabled a)
withDisabledParser :: forall a.
ReadM a
-> [Mod OptionFields (WithDisabled a)]
-> (Bool, [String])
-> Parser (WithDisabled a)
withDisabledParser ReadM a
rdr [Mod OptionFields (WithDisabled a)]
opts (Bool, [String])
mv =
  ReadM a
-> [Mod OptionFields (WithDisabled a)] -> Parser (WithDisabled a)
forall a.
ReadM a
-> [Mod OptionFields (WithDisabled a)] -> Parser (WithDisabled a)
withDisabledParserNoOpts ReadM a
rdr [Mod OptionFields (WithDisabled a)]
opts'
  where
    metavar :: String
metavar = (Bool, [String]) -> String
forall a. (IsString a, Monoid a) => (Bool, [a]) -> a
ShrunUtils.mkMetaStr (Bool, [String])
mv

    opts' :: [Mod OptionFields (WithDisabled a)]
opts' =
      [String] -> Mod OptionFields (WithDisabled a)
forall (f :: Type -> Type) a. HasCompleter f => [String] -> Mod f a
OA.completeWith [String
Item [String]
"off"]
        Mod OptionFields (WithDisabled a)
-> [Mod OptionFields (WithDisabled a)]
-> [Mod OptionFields (WithDisabled a)]
forall a. a -> [a] -> [a]
: String -> Mod OptionFields (WithDisabled a)
forall (f :: Type -> Type) a. HasMetavar f => String -> Mod f a
OA.metavar String
metavar
        Mod OptionFields (WithDisabled a)
-> [Mod OptionFields (WithDisabled a)]
-> [Mod OptionFields (WithDisabled a)]
forall a. a -> [a] -> [a]
: [Mod OptionFields (WithDisabled a)]
opts

-- | Constructs a parser for (Maybe (WithDisabled a)).
withDisabledParserNoOpts ::
  -- | Reader for a.
  ReadM a ->
  -- | Modifier list e.g. option name, help text.
  List (Mod OA.OptionFields (WithDisabled a)) ->
  Parser (WithDisabled a)
withDisabledParserNoOpts :: forall a.
ReadM a
-> [Mod OptionFields (WithDisabled a)] -> Parser (WithDisabled a)
withDisabledParserNoOpts ReadM a
rdr [Mod OptionFields (WithDisabled a)]
opts = Parser (WithDisabled a)
mainParser
  where
    mainParser :: Parser (WithDisabled a)
mainParser =
      ReadM (WithDisabled a)
-> Mod OptionFields (WithDisabled a) -> Parser (WithDisabled a)
forall a. ReadM a -> Mod OptionFields a -> Parser a
OA.option
        ReadM (WithDisabled a)
reader
        ([Mod OptionFields (WithDisabled a)]
-> Mod OptionFields (WithDisabled a)
forall a. Monoid a => [a] -> a
mconcat [Mod OptionFields (WithDisabled a)]
opts)

    reader :: ReadM (WithDisabled a)
reader = do
      Text
txt <- ReadM Text
forall s. IsString s => ReadM s
OA.str
      Text -> ReadM a -> ReadM (WithDisabled a)
forall (f :: Type -> Type) a.
Applicative f =>
Text -> f a -> f (WithDisabled a)
WD.disabledParser Text
txt ReadM a
rdr

switchParser :: (Bool -> a) -> String -> String -> Parser (Maybe a)
switchParser :: forall a. (Bool -> a) -> String -> String -> Parser (Maybe a)
switchParser = (String -> Mod OptionFields Bool)
-> Mod OptionFields Bool
-> (Bool -> a)
-> String
-> String
-> Parser (Maybe a)
forall a.
(String -> Mod OptionFields Bool)
-> Mod OptionFields Bool
-> (Bool -> a)
-> String
-> String
-> Parser (Maybe a)
switchParserHelper String -> Mod OptionFields Bool
forall (f :: Type -> Type) a. String -> Mod f a
mkHelp Mod OptionFields Bool
forall a. Monoid a => a
mempty

switchParserOpts :: Mod OA.OptionFields Bool -> (Bool -> a) -> String -> String -> Parser (Maybe a)
switchParserOpts :: forall a.
Mod OptionFields Bool
-> (Bool -> a) -> String -> String -> Parser (Maybe a)
switchParserOpts = (String -> Mod OptionFields Bool)
-> Mod OptionFields Bool
-> (Bool -> a)
-> String
-> String
-> Parser (Maybe a)
forall a.
(String -> Mod OptionFields Bool)
-> Mod OptionFields Bool
-> (Bool -> a)
-> String
-> String
-> Parser (Maybe a)
switchParserHelper String -> Mod OptionFields Bool
forall (f :: Type -> Type) a. String -> Mod f a
mkHelp

switchParserNoLine :: (Bool -> a) -> String -> String -> Parser (Maybe a)
switchParserNoLine :: forall a. (Bool -> a) -> String -> String -> Parser (Maybe a)
switchParserNoLine = (String -> Mod OptionFields Bool)
-> Mod OptionFields Bool
-> (Bool -> a)
-> String
-> String
-> Parser (Maybe a)
forall a.
(String -> Mod OptionFields Bool)
-> Mod OptionFields Bool
-> (Bool -> a)
-> String
-> String
-> Parser (Maybe a)
switchParserHelper String -> Mod OptionFields Bool
forall (f :: Type -> Type) a. String -> Mod f a
mkHelpNoLine Mod OptionFields Bool
forall a. Monoid a => a
mempty

switchParserHelper ::
  -- | Help function, determines final newlines behavior.
  (String -> Mod OA.OptionFields Bool) ->
  -- | Additional options.
  Mod OA.OptionFields Bool ->
  -- | Type constructor.
  (Bool -> a) ->
  -- | Option name.
  String ->
  -- | Help text.
  String ->
  Parser (Maybe a)
switchParserHelper :: forall a.
(String -> Mod OptionFields Bool)
-> Mod OptionFields Bool
-> (Bool -> a)
-> String
-> String
-> Parser (Maybe a)
switchParserHelper String -> Mod OptionFields Bool
mkHelpFn Mod OptionFields Bool
opts Bool -> a
cons String
name String
helpTxt = (Bool -> a) -> Maybe Bool -> Maybe a
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap Bool -> a
cons (Maybe Bool -> Maybe a) -> Parser (Maybe Bool) -> Parser (Maybe a)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser (Maybe Bool)
mainParser
  where
    mainParser :: Parser (Maybe Bool)
mainParser =
      Parser Bool -> Parser (Maybe Bool)
forall (f :: Type -> Type) a. Alternative f => f a -> f (Maybe a)
OA.optional
        (Parser Bool -> Parser (Maybe Bool))
-> Parser Bool -> Parser (Maybe Bool)
forall a b. (a -> b) -> a -> b
$ ReadM Bool -> Mod OptionFields Bool -> Parser Bool
forall a. ReadM a -> Mod OptionFields a -> Parser a
OA.option
          ReadM Bool
readBool
          ( [Mod OptionFields Bool] -> Mod OptionFields Bool
forall a. Monoid a => [a] -> a
mconcat
              [ Item [Mod OptionFields Bool]
Mod OptionFields Bool
opts,
                String -> Mod OptionFields Bool
forall (f :: Type -> Type) a. HasName f => String -> Mod f a
OA.long String
name,
                String -> Mod OptionFields Bool
forall (f :: Type -> Type) a. HasMetavar f => String -> Mod f a
OA.metavar String
"(on | off)",
                [String] -> Mod OptionFields Bool
forall (f :: Type -> Type) a. HasCompleter f => [String] -> Mod f a
OA.completeWith [String
Item [String]
"on", String
Item [String]
"off"],
                String -> Mod OptionFields Bool
mkHelpFn String
helpTxt
              ]
          )

    readBool :: ReadM Bool
readBool = forall s. IsString s => ReadM s
OA.str @Text ReadM Text -> (Text -> ReadM Bool) -> ReadM Bool
forall a b. ReadM a -> (a -> ReadM b) -> ReadM b
forall (m :: Type -> Type) a b. Monad m => m a -> (a -> m b) -> m b
>>= Text -> ReadM Bool
forall (m :: Type -> Type). MonadFail m => Text -> m Bool
ConfigPhase.parseSwitch

toMDoc :: String -> Maybe DocOA
toMDoc :: String -> Maybe (Doc AnsiStyle)
toMDoc = Chunk (Doc AnsiStyle) -> Maybe (Doc AnsiStyle)
forall a. Chunk a -> Maybe a
Chunk.unChunk (Chunk (Doc AnsiStyle) -> Maybe (Doc AnsiStyle))
-> (String -> Chunk (Doc AnsiStyle))
-> String
-> Maybe (Doc AnsiStyle)
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> Type) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. String -> Chunk (Doc AnsiStyle)
Chunk.paragraph

-- | Make an itemized list e.g.
--
-- @
--   itemize [intro, l1, l2, l2]
--
--   ==> intro
--
--       - l1
--       - l2
--       - l3
-- @
itemize :: NESeq String -> Mod OptionFields a
itemize :: forall a. NESeq String -> Mod OptionFields a
itemize =
  Maybe (Doc AnsiStyle) -> Mod OptionFields a
forall (f :: Type -> Type) a. Maybe (Doc AnsiStyle) -> Mod f a
OA.helpDoc
    (Maybe (Doc AnsiStyle) -> Mod OptionFields a)
-> (NESeq String -> Maybe (Doc AnsiStyle))
-> NESeq String
-> Mod OptionFields a
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> Type) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Chunk (Doc AnsiStyle) -> Maybe (Doc AnsiStyle)
forall a. Chunk a -> Maybe a
Chunk.unChunk
    (Chunk (Doc AnsiStyle) -> Maybe (Doc AnsiStyle))
-> (NESeq String -> Chunk (Doc AnsiStyle))
-> NESeq String
-> Maybe (Doc AnsiStyle)
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> Type) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. (Doc AnsiStyle -> Doc AnsiStyle)
-> Chunk (Doc AnsiStyle) -> Chunk (Doc AnsiStyle)
forall a b. (a -> b) -> Chunk a -> Chunk b
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap (Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall a. Semigroup a => a -> a -> a
<> Doc AnsiStyle
forall ann. Doc ann
Pretty.line)
    (Chunk (Doc AnsiStyle) -> Chunk (Doc AnsiStyle))
-> (NESeq String -> Chunk (Doc AnsiStyle))
-> NESeq String
-> Chunk (Doc AnsiStyle)
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> Type) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. NESeq String -> Chunk (Doc AnsiStyle)
itemizeHelper

-- | 'itemize' that does not append a trailing newline. Useful for the last
-- option in a group, as groups already start a newline.
itemizeNoLine :: NESeq String -> Mod OptionFields a
itemizeNoLine :: forall a. NESeq String -> Mod OptionFields a
itemizeNoLine =
  Maybe (Doc AnsiStyle) -> Mod OptionFields a
forall (f :: Type -> Type) a. Maybe (Doc AnsiStyle) -> Mod f a
OA.helpDoc
    (Maybe (Doc AnsiStyle) -> Mod OptionFields a)
-> (NESeq String -> Maybe (Doc AnsiStyle))
-> NESeq String
-> Mod OptionFields a
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> Type) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Chunk (Doc AnsiStyle) -> Maybe (Doc AnsiStyle)
forall a. Chunk a -> Maybe a
Chunk.unChunk
    (Chunk (Doc AnsiStyle) -> Maybe (Doc AnsiStyle))
-> (NESeq String -> Chunk (Doc AnsiStyle))
-> NESeq String
-> Maybe (Doc AnsiStyle)
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> Type) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. NESeq String -> Chunk (Doc AnsiStyle)
itemizeHelper

itemizeHelper :: NESeq String -> Chunk DocOA
itemizeHelper :: NESeq String -> Chunk (Doc AnsiStyle)
itemizeHelper (String
intro :<|| Seq String
ds) =
  [Chunk (Doc AnsiStyle)] -> Chunk (Doc AnsiStyle)
Chunk.vcatChunks
    ([Chunk (Doc AnsiStyle)] -> Chunk (Doc AnsiStyle))
-> [Chunk (Doc AnsiStyle)] -> Chunk (Doc AnsiStyle)
forall a b. (a -> b) -> a -> b
$ Seq (Chunk (Doc AnsiStyle)) -> [Chunk (Doc AnsiStyle)]
forall a. Seq a -> [a]
forall (t :: Type -> Type) a. Foldable t => t a -> [a]
toList
      ( String -> Chunk (Doc AnsiStyle)
Chunk.paragraph String
intro
          Chunk (Doc AnsiStyle)
-> Seq (Chunk (Doc AnsiStyle)) -> Seq (Chunk (Doc AnsiStyle))
forall a. a -> Seq a -> Seq a
:<| Doc AnsiStyle -> Chunk (Doc AnsiStyle)
forall a. a -> Chunk a
toChunk Doc AnsiStyle
forall ann. Doc ann
Pretty.softline
          Chunk (Doc AnsiStyle)
-> Seq (Chunk (Doc AnsiStyle)) -> Seq (Chunk (Doc AnsiStyle))
forall a. a -> Seq a -> Seq a
:<| (String -> Chunk (Doc AnsiStyle)
toItem (String -> Chunk (Doc AnsiStyle))
-> Seq String -> Seq (Chunk (Doc AnsiStyle))
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> Seq String
ds)
      )
  where
    toItem :: String -> Chunk (Doc AnsiStyle)
toItem String
d =
      (Doc AnsiStyle -> Doc AnsiStyle)
-> Chunk (Doc AnsiStyle) -> Chunk (Doc AnsiStyle)
forall a b. (a -> b) -> Chunk a -> Chunk b
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap (Int -> Doc AnsiStyle -> Doc AnsiStyle
forall ann. Int -> Doc ann -> Doc ann
Pretty.nest Int
2)
        (Chunk (Doc AnsiStyle) -> Chunk (Doc AnsiStyle))
-> (String -> Chunk (Doc AnsiStyle))
-> String
-> Chunk (Doc AnsiStyle)
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> Type) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. String -> Chunk (Doc AnsiStyle)
Chunk.paragraph
        (String -> Chunk (Doc AnsiStyle))
-> String -> Chunk (Doc AnsiStyle)
forall a b. (a -> b) -> a -> b
$ (String
"- " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
d)

toChunk :: a -> Chunk a
toChunk :: forall a. a -> Chunk a
toChunk = Maybe a -> Chunk a
forall a. Maybe a -> Chunk a
Chunk (Maybe a -> Chunk a) -> (a -> Maybe a) -> a -> Chunk a
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> Type) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. a -> Maybe a
forall a. a -> Maybe a
Just