{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeOperators #-}

module Cardano.CLI.Option.Flag
  ( Flag (Flag)
  , FlagOptions (FlagOptions)
  , Defaultness (..)
  , setDefault
  , mkFlag
  , parserFromFlags
  )
where

import Cardano.CLI.Option.Flag.Type
  ( Defaultness (IsDefault)
  , Flag (Flag)
  , FlagOptions (FlagOptions)
  , defaultFlagOptions
  )
import Cardano.CLI.Option.Flag.Type qualified as Z

import Control.Applicative
import Data.Function
import Data.Generics.Product.Any
import Lens.Micro
import Options.Applicative (Parser)
import Options.Applicative qualified as Opt
import Vary

-- | Create a parser from a help rendering function and list of flags.
-- A default parser is included at the end of parser alternatives for
-- the default flag (there should only be one default, but if more than
-- one is specified, the first such one is used as the default).
parserFromFlags :: Parser a -> (Flag a -> String) -> [Flag a] -> Parser a
parserFromFlags :: forall a. Parser a -> (Flag a -> String) -> [Flag a] -> Parser a
parserFromFlags Parser a
p Flag a -> String
mkHelp [Flag a]
fs =
  [Flag a] -> Parser a
alternatives [Flag a]
fs Parser a -> Parser a -> Parser a
forall a. Parser a -> Parser a -> Parser a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser a
p Parser a -> Parser a -> Parser a
forall a. Parser a -> Parser a -> Parser a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> [Flag a] -> Parser a
forall a. [Flag a] -> Parser a
defaults [Flag a]
fs
 where
  alternatives :: [Flag a] -> Parser a
alternatives [] = Parser a
forall a. Parser a
forall (f :: * -> *) a. Alternative f => f a
empty
  alternatives (Flag a
x : [Flag a]
xs) =
    (Flag a -> String) -> Flag a -> Parser a
forall a. (Flag a -> String) -> Flag a -> Parser a
parserFromFlag Flag a -> String
mkHelp Flag a
x Parser a -> Parser a -> Parser a
forall a. Parser a -> Parser a -> Parser a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> [Flag a] -> Parser a
alternatives [Flag a]
xs

  defaults :: [Flag a] -> Parser a
  defaults :: forall a. [Flag a] -> Parser a
defaults = \case
    [] -> Parser a
forall a. Parser a
forall (f :: * -> *) a. Alternative f => f a
empty
    (Flag a
x : [Flag a]
xs) | Flag a -> Bool
forall a. Flag a -> Bool
flagIsDefault Flag a
x -> Flag a -> Parser a
forall a. Flag a -> Parser a
parserFromFlagDefault Flag a
x Parser a -> Parser a -> Parser a
forall a. Parser a -> Parser a -> Parser a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> [Flag a] -> Parser a
forall a. [Flag a] -> Parser a
defaults [Flag a]
xs
    (Flag a
_ : [Flag a]
xs) -> [Flag a] -> Parser a
forall a. [Flag a] -> Parser a
defaults [Flag a]
xs

flagIsDefault :: Flag a -> Bool
flagIsDefault :: forall a. Flag a -> Bool
flagIsDefault Flag a
flag =
  FlagOptions -> Defaultness
Z.isDefault (Flag a -> FlagOptions
forall a. Flag a -> FlagOptions
Z.options Flag a
flag) Defaultness -> Defaultness -> Bool
forall a. Eq a => a -> a -> Bool
== Defaultness
Z.IsDefault

parserFromFlag :: (Flag a -> String) -> Flag a -> Parser a
parserFromFlag :: forall a. (Flag a -> String) -> Flag a -> Parser a
parserFromFlag Flag a -> String
mkHelp Flag a
flag =
  a -> Mod FlagFields a -> Parser a
forall a. a -> Mod FlagFields a -> Parser a
Opt.flag' (Flag a
flag Flag a -> (Flag a -> a) -> a
forall a b. a -> (a -> b) -> b
& Flag a -> a
forall a. Flag a -> a
Z.value) (Mod FlagFields a -> Parser a) -> Mod FlagFields a -> Parser a
forall a b. (a -> b) -> a -> b
$
    [Mod FlagFields a] -> Mod FlagFields a
forall a. Monoid a => [a] -> a
mconcat
      [ String -> Mod FlagFields a
forall (f :: * -> *) a. HasName f => String -> Mod f a
Opt.long (String -> Mod FlagFields a) -> String -> Mod FlagFields a
forall a b. (a -> b) -> a -> b
$ Flag a
flag Flag a -> (Flag a -> String) -> String
forall a b. a -> (a -> b) -> b
& Flag a -> String
forall a. Flag a -> String
Z.longName
      , String -> Mod FlagFields a
forall (f :: * -> *) a. String -> Mod f a
Opt.help (String -> Mod FlagFields a) -> String -> Mod FlagFields a
forall a b. (a -> b) -> a -> b
$ Flag a -> String
mkHelp Flag a
flag
      ]

parserFromFlagDefault :: Flag a -> Parser a
parserFromFlagDefault :: forall a. Flag a -> Parser a
parserFromFlagDefault Flag a
flag =
  a -> Parser a
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (a -> Parser a) -> a -> Parser a
forall a b. (a -> b) -> a -> b
$ Flag a
flag Flag a -> (Flag a -> a) -> a
forall a b. a -> (a -> b) -> b
& Flag a -> a
forall a. Flag a -> a
Z.value

mkFlag
  :: a :| fs
  => String
  -> String
  -> a
  -> Flag (Vary fs)
mkFlag :: forall a (fs :: [*]).
(a :| fs) =>
String -> String -> a -> Flag (Vary fs)
mkFlag String
longName String
format a
value =
  String -> String -> FlagOptions -> Vary fs -> Flag (Vary fs)
forall a. String -> String -> FlagOptions -> a -> Flag a
Flag String
longName String
format FlagOptions
defaultFlagOptions (a -> Vary fs
forall a (l :: [*]). (a :| l) => a -> Vary l
Vary.from a
value)

setDefault :: Flag a -> Flag a
setDefault :: forall a. Flag a -> Flag a
setDefault Flag a
flag =
  Flag a
flag Flag a -> (Flag a -> Flag a) -> Flag a
forall a b. a -> (a -> b) -> b
& forall {k} (sel :: k) s t a b. HasAny sel s t a b => Lens s t a b
forall (sel :: Symbol) s t a b. HasAny sel s t a b => Lens s t a b
the @"options" ((FlagOptions -> Identity FlagOptions)
 -> Flag a -> Identity (Flag a))
-> ((Defaultness -> Identity Defaultness)
    -> FlagOptions -> Identity FlagOptions)
-> (Defaultness -> Identity Defaultness)
-> Flag a
-> Identity (Flag a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {k} (sel :: k) s t a b. HasAny sel s t a b => Lens s t a b
forall (sel :: Symbol) s t a b. HasAny sel s t a b => Lens s t a b
the @"isDefault" ((Defaultness -> Identity Defaultness)
 -> Flag a -> Identity (Flag a))
-> Defaultness -> Flag a -> Flag a
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Defaultness
IsDefault