{-# LANGUAGE CPP #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE UnicodeSyntax #-}
module Configuration.Utils.CommandLine
( MParser
, (.::)
, (%::)
, boolReader
, boolOption
, boolOption_
, enableDisableFlag
, fileOption
, eitherReadP
, jsonOption
, jsonReader
, module Options.Applicative
) where
import Configuration.Utils.Internal
import Configuration.Utils.Operators
import Control.Applicative
import Control.Monad.Writer hiding (mapM_)
import Data.Aeson
import qualified Data.ByteString.Lazy.Char8 as BL8
import qualified Data.CaseInsensitive as CI
import Data.Maybe
import Data.Monoid.Unicode
import Data.String
import qualified Data.Text as T
import Options.Applicative hiding (Parser, Success)
import qualified Options.Applicative.Types as O
import qualified Options.Applicative as O
import qualified Options.Applicative.Builder.Internal as O
import Prelude hiding (any, concatMap, mapM_)
import qualified Text.ParserCombinators.ReadP as P hiding (string)
#if MIN_VERSION_base(4,13,0)
import Prelude.Unicode hiding ((×))
#else
import Prelude.Unicode
#endif
type MParser a = O.Parser (a → a)
(.::) ∷ (Alternative f, Applicative f) ⇒ Lens' a b → f b → f (a → a)
.:: :: Lens' a b -> f b -> f (a -> a)
(.::) Lens' a b
a f b
opt = ((b -> Identity b) -> a -> Identity a) -> b -> a -> a
forall a b s t.
((a -> Identity b) -> s -> Identity t) -> b -> s -> t
set (b -> Identity b) -> a -> Identity a
Lens' a b
a (b -> a -> a) -> f b -> f (a -> a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> f b
opt f (a -> a) -> f (a -> a) -> f (a -> a)
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (a -> a) -> f (a -> a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure a -> a
forall a. a -> a
id
infixr 5 .::
{-# INLINE (.::) #-}
(%::) ∷ (Alternative f, Applicative f) ⇒ Lens' a b → f (b → b) → f (a → a)
%:: :: Lens' a b -> f (b -> b) -> f (a -> a)
(%::) Lens' a b
a f (b -> b)
opt = ((b -> Identity b) -> a -> Identity a) -> (b -> b) -> a -> a
forall a b s t.
((a -> Identity b) -> s -> Identity t) -> (a -> b) -> s -> t
over (b -> Identity b) -> a -> Identity a
Lens' a b
a ((b -> b) -> a -> a) -> f (b -> b) -> f (a -> a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> f (b -> b)
opt f (a -> a) -> f (a -> a) -> f (a -> a)
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (a -> a) -> f (a -> a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure a -> a
forall a. a -> a
id
infixr 5 %::
{-# INLINE (%::) #-}
boolReader
∷ (Eq a, Show a, CI.FoldCase a, IsString a, IsString e, Monoid e)
⇒ a
→ Either e Bool
boolReader :: a -> Either e Bool
boolReader a
x = case a -> CI a
forall s. FoldCase s => s -> CI s
CI.mk a
x of
CI a
"true" → Bool -> Either e Bool
forall a b. b -> Either a b
Right Bool
True
CI a
"false" → Bool -> Either e Bool
forall a b. b -> Either a b
Right Bool
False
CI a
_ → e -> Either e Bool
forall a b. a -> Either a b
Left (e -> Either e Bool) -> e -> Either e Bool
forall a b. (a -> b) -> a -> b
$ e
"failed to read Boolean value " e -> e -> e
forall α. Monoid α => α -> α -> α
⊕ String -> e
forall a. IsString a => String -> a
fromString (a -> String
forall a. Show a => a -> String
show a
x)
e -> e -> e
forall α. Monoid α => α -> α -> α
⊕ e
". Expected either \"true\" or \"false\""
boolOption
∷ O.Mod O.OptionFields Bool
→ O.Parser Bool
boolOption :: Mod OptionFields Bool -> Parser Bool
boolOption Mod OptionFields Bool
mods = ReadM Bool -> Mod OptionFields Bool -> Parser Bool
forall a. ReadM a -> Mod OptionFields a -> Parser a
O.option ((String -> Either String Bool) -> ReadM Bool
forall a. (String -> Either String a) -> ReadM a
O.eitherReader (String -> Either String Bool
forall a e.
(Eq a, Show a, FoldCase a, IsString a, IsString e, Monoid e) =>
a -> Either e Bool
boolReader ∷ String → Either String Bool))
(Mod OptionFields Bool -> Parser Bool)
-> Mod OptionFields Bool -> Parser Bool
forall a b. (a -> b) -> a -> b
% String -> Mod OptionFields Bool
forall (f :: * -> *) a. HasMetavar f => String -> Mod f a
O.metavar String
"true|false"
Mod OptionFields Bool
-> Mod OptionFields Bool -> Mod OptionFields Bool
forall α. Monoid α => α -> α -> α
⊕ [String] -> Mod OptionFields Bool
forall (f :: * -> *) a. HasCompleter f => [String] -> Mod f a
O.completeWith [String
"true", String
"false", String
"TRUE", String
"FALSE", String
"True", String
"False"]
Mod OptionFields Bool
-> Mod OptionFields Bool -> Mod OptionFields Bool
forall α. Monoid α => α -> α -> α
⊕ Mod OptionFields Bool
mods
boolOption_
∷ O.Mod O.FlagFields Bool
→ O.Parser Bool
boolOption_ :: Mod FlagFields Bool -> Parser Bool
boolOption_ Mod FlagFields Bool
mods = Bool -> Mod FlagFields Bool -> Parser Bool
forall a. a -> Mod FlagFields a -> Parser a
flag' Bool
True Mod FlagFields Bool
mods Parser Bool -> Parser Bool -> Parser Bool
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Bool -> Mod FlagFields Bool -> Parser Bool
forall a. a -> Mod FlagFields a -> Parser a
flag' Bool
False Mod FlagFields Bool
nomods
where
O.Mod FlagFields Bool -> FlagFields Bool
f DefaultProp Bool
d OptProperties -> OptProperties
o = Mod FlagFields Bool
mods
O.FlagFields [OptName]
names Bool
_ = FlagFields Bool -> FlagFields Bool
f (FlagFields Bool -> FlagFields Bool)
-> FlagFields Bool -> FlagFields Bool
forall a b. (a -> b) -> a -> b
$ [OptName] -> Bool -> FlagFields Bool
forall a. [OptName] -> a -> FlagFields a
O.FlagFields [] Bool
False
longName :: OptName -> Maybe String
longName (O.OptShort Char
_) = Maybe String
forall a. Maybe a
Nothing
longName (O.OptLong String
l) = String -> Maybe String
forall a. a -> Maybe a
Just String
l
longNames :: [String]
longNames = (OptName -> Maybe String) -> [OptName] -> [String]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe OptName -> Maybe String
longName [OptName]
names
noName :: α -> α
noName α
l = α
"no-" α -> α -> α
forall α. Monoid α => α -> α -> α
⊕ α
l
mapFlags :: FlagFields a -> FlagFields a
mapFlags FlagFields a
flags = FlagFields a
flags
{ flagNames :: [OptName]
O.flagNames = (OptName -> Maybe OptName) -> [OptName] -> [OptName]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (\OptName
l → String -> OptName
O.OptLong (String -> OptName) -> (String -> String) -> String -> OptName
forall β γ α. (β -> γ) -> (α -> β) -> α -> γ
∘ String -> String
forall α. (Monoid α, IsString α) => α -> α
noName (String -> OptName) -> Maybe String -> Maybe OptName
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> OptName -> Maybe String
longName OptName
l) (FlagFields a -> [OptName]
forall a. FlagFields a -> [OptName]
O.flagNames FlagFields a
flags)
}
nomods :: Mod FlagFields Bool
nomods = (FlagFields Bool -> FlagFields Bool)
-> DefaultProp Bool
-> (OptProperties -> OptProperties)
-> Mod FlagFields Bool
forall (f :: * -> *) a.
(f a -> f a)
-> DefaultProp a -> (OptProperties -> OptProperties) -> Mod f a
O.Mod (FlagFields Bool -> FlagFields Bool
forall a. FlagFields a -> FlagFields a
mapFlags (FlagFields Bool -> FlagFields Bool)
-> (FlagFields Bool -> FlagFields Bool)
-> FlagFields Bool
-> FlagFields Bool
forall β γ α. (β -> γ) -> (α -> β) -> α -> γ
∘ FlagFields Bool -> FlagFields Bool
f) DefaultProp Bool
d OptProperties -> OptProperties
o
Mod FlagFields Bool -> Mod FlagFields Bool -> Mod FlagFields Bool
forall α. Monoid α => α -> α -> α
⊕ Mod FlagFields Bool
-> (String -> Mod FlagFields Bool)
-> Maybe String
-> Mod FlagFields Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Mod FlagFields Bool
forall a. Monoid a => a
mempty (\String
l → String -> Mod FlagFields Bool
forall (f :: * -> *) a. String -> Mod f a
help (String -> Mod FlagFields Bool) -> String -> Mod FlagFields Bool
forall a b. (a -> b) -> a -> b
$ String
"unset flag " String -> String -> String
forall α. Monoid α => α -> α -> α
⊕ String
l) ([String] -> Maybe String
forall a. [a] -> Maybe a
listToMaybe ([String] -> Maybe String) -> [String] -> Maybe String
forall a b. (a -> b) -> a -> b
$ [String] -> [String]
forall a. [a] -> [a]
reverse [String]
longNames)
enableDisableFlag
∷ O.Mod O.FlagFields Bool
→ O.Parser Bool
enableDisableFlag :: Mod FlagFields Bool -> Parser Bool
enableDisableFlag Mod FlagFields Bool
mods = Bool -> Mod FlagFields Bool -> Parser Bool
forall a. a -> Mod FlagFields a -> Parser a
flag' Bool
True Mod FlagFields Bool
enmods Parser Bool -> Parser Bool -> Parser Bool
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Bool -> Mod FlagFields Bool -> Parser Bool
forall a. a -> Mod FlagFields a -> Parser a
flag' Bool
False Mod FlagFields Bool
dismods
where
O.Mod FlagFields Bool -> FlagFields Bool
f DefaultProp Bool
d OptProperties -> OptProperties
o = Mod FlagFields Bool
mods
O.FlagFields [OptName]
names Bool
_ = FlagFields Bool -> FlagFields Bool
f (FlagFields Bool -> FlagFields Bool)
-> FlagFields Bool -> FlagFields Bool
forall a b. (a -> b) -> a -> b
$ [OptName] -> Bool -> FlagFields Bool
forall a. [OptName] -> a -> FlagFields a
O.FlagFields [] Bool
False
longName :: OptName -> Maybe String
longName (O.OptShort Char
_) = Maybe String
forall a. Maybe a
Nothing
longName (O.OptLong String
l) = String -> Maybe String
forall a. a -> Maybe a
Just String
l
longNames :: [String]
longNames = (OptName -> Maybe String) -> [OptName] -> [String]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe OptName -> Maybe String
longName [OptName]
names
disName :: α -> α
disName α
l = α
"disable-" α -> α -> α
forall α. Monoid α => α -> α -> α
⊕ α
l
enName :: α -> α
enName α
l = α
"enable-" α -> α -> α
forall α. Monoid α => α -> α -> α
⊕ α
l
mapDisFlags :: FlagFields a -> FlagFields a
mapDisFlags FlagFields a
flags = FlagFields a
flags
{ flagNames :: [OptName]
O.flagNames = (OptName -> Maybe OptName) -> [OptName] -> [OptName]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (\OptName
l → String -> OptName
O.OptLong (String -> OptName) -> (String -> String) -> String -> OptName
forall β γ α. (β -> γ) -> (α -> β) -> α -> γ
∘ String -> String
forall α. (Monoid α, IsString α) => α -> α
disName (String -> OptName) -> Maybe String -> Maybe OptName
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> OptName -> Maybe String
longName OptName
l) (FlagFields a -> [OptName]
forall a. FlagFields a -> [OptName]
O.flagNames FlagFields a
flags)
}
dismods :: Mod FlagFields Bool
dismods = (FlagFields Bool -> FlagFields Bool)
-> DefaultProp Bool
-> (OptProperties -> OptProperties)
-> Mod FlagFields Bool
forall (f :: * -> *) a.
(f a -> f a)
-> DefaultProp a -> (OptProperties -> OptProperties) -> Mod f a
O.Mod (FlagFields Bool -> FlagFields Bool
forall a. FlagFields a -> FlagFields a
mapDisFlags (FlagFields Bool -> FlagFields Bool)
-> (FlagFields Bool -> FlagFields Bool)
-> FlagFields Bool
-> FlagFields Bool
forall β γ α. (β -> γ) -> (α -> β) -> α -> γ
∘ FlagFields Bool -> FlagFields Bool
f) DefaultProp Bool
d OptProperties -> OptProperties
o
Mod FlagFields Bool -> Mod FlagFields Bool -> Mod FlagFields Bool
forall α. Monoid α => α -> α -> α
⊕ Mod FlagFields Bool
-> (String -> Mod FlagFields Bool)
-> Maybe String
-> Mod FlagFields Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Mod FlagFields Bool
forall a. Monoid a => a
mempty (\String
l → String -> Mod FlagFields Bool
forall (f :: * -> *) a. String -> Mod f a
help (String -> Mod FlagFields Bool) -> String -> Mod FlagFields Bool
forall a b. (a -> b) -> a -> b
$ String
"unset flag " String -> String -> String
forall α. Monoid α => α -> α -> α
⊕ String
l) ([String] -> Maybe String
forall a. [a] -> Maybe a
listToMaybe ([String] -> Maybe String) -> [String] -> Maybe String
forall a b. (a -> b) -> a -> b
$ [String] -> [String]
forall a. [a] -> [a]
reverse [String]
longNames)
mapLong :: (String -> String) -> OptName -> OptName
mapLong String -> String
g (O.OptLong String
l) = String -> OptName
O.OptLong (String -> String
g String
l)
mapLong String -> String
_ OptName
s = OptName
s
mapEnFlags :: FlagFields a -> FlagFields a
mapEnFlags FlagFields a
flags = FlagFields a
flags
{ flagNames :: [OptName]
O.flagNames = (OptName -> OptName) -> [OptName] -> [OptName]
forall a b. (a -> b) -> [a] -> [b]
map ((String -> String) -> OptName -> OptName
mapLong String -> String
forall α. (Monoid α, IsString α) => α -> α
enName) (FlagFields a -> [OptName]
forall a. FlagFields a -> [OptName]
O.flagNames FlagFields a
flags)
}
enmods :: Mod FlagFields Bool
enmods = (FlagFields Bool -> FlagFields Bool)
-> DefaultProp Bool
-> (OptProperties -> OptProperties)
-> Mod FlagFields Bool
forall (f :: * -> *) a.
(f a -> f a)
-> DefaultProp a -> (OptProperties -> OptProperties) -> Mod f a
O.Mod (FlagFields Bool -> FlagFields Bool
forall a. FlagFields a -> FlagFields a
mapEnFlags (FlagFields Bool -> FlagFields Bool)
-> (FlagFields Bool -> FlagFields Bool)
-> FlagFields Bool
-> FlagFields Bool
forall β γ α. (β -> γ) -> (α -> β) -> α -> γ
∘ FlagFields Bool -> FlagFields Bool
f) DefaultProp Bool
d OptProperties -> OptProperties
o
fileOption
∷ O.Mod O.OptionFields String
→ O.Parser FilePath
fileOption :: Mod OptionFields String -> Parser String
fileOption Mod OptionFields String
mods = Mod OptionFields String -> Parser String
forall s. IsString s => Mod OptionFields s -> Parser s
O.strOption
(Mod OptionFields String -> Parser String)
-> Mod OptionFields String -> Parser String
forall a b. (a -> b) -> a -> b
% String -> Mod OptionFields String
forall (f :: * -> *) a. HasMetavar f => String -> Mod f a
O.metavar String
"FILE"
Mod OptionFields String
-> Mod OptionFields String -> Mod OptionFields String
forall α. Monoid α => α -> α -> α
⊕ String -> Mod OptionFields String
forall (f :: * -> *) a. HasCompleter f => String -> Mod f a
O.action String
"file"
Mod OptionFields String
-> Mod OptionFields String -> Mod OptionFields String
forall α. Monoid α => α -> α -> α
⊕ Mod OptionFields String
mods
eitherReadP
∷ T.Text
→ P.ReadP a
→ T.Text
→ Either T.Text a
eitherReadP :: Text -> ReadP a -> Text -> Either Text a
eitherReadP Text
label ReadP a
p Text
s =
case [ a
x | (a
x,String
"") ← ReadP a -> ReadS a
forall a. ReadP a -> ReadS a
P.readP_to_S ReadP a
p (Text -> String
T.unpack Text
s) ] of
[a
x] → a -> Either Text a
forall a b. b -> Either a b
Right a
x
[] → Text -> Either Text a
forall a b. a -> Either a b
Left (Text -> Either Text a) -> Text -> Either Text a
forall a b. (a -> b) -> a -> b
$ Text
"eitherReadP: no parse for " Text -> Text -> Text
forall α. Monoid α => α -> α -> α
⊕ Text
label Text -> Text -> Text
forall α. Monoid α => α -> α -> α
⊕ Text
" of " Text -> Text -> Text
forall α. Monoid α => α -> α -> α
⊕ Text
s
[a]
_ → Text -> Either Text a
forall a b. a -> Either a b
Left (Text -> Either Text a) -> Text -> Either Text a
forall a b. (a -> b) -> a -> b
$ Text
"eitherReadP: ambigous parse for " Text -> Text -> Text
forall α. Monoid α => α -> α -> α
⊕ Text
label Text -> Text -> Text
forall α. Monoid α => α -> α -> α
⊕ Text
" of " Text -> Text -> Text
forall α. Monoid α => α -> α -> α
⊕ Text
s
jsonOption ∷ FromJSON a ⇒ Mod OptionFields a → O.Parser a
jsonOption :: Mod OptionFields a -> Parser a
jsonOption = ReadM a -> Mod OptionFields a -> Parser a
forall a. ReadM a -> Mod OptionFields a -> Parser a
O.option ReadM a
forall a. FromJSON a => ReadM a
jsonReader
jsonReader ∷ FromJSON a ⇒ ReadM a
jsonReader :: ReadM a
jsonReader = (String -> Either String a) -> ReadM a
forall a. (String -> Either String a) -> ReadM a
eitherReader ((String -> Either String a) -> ReadM a)
-> (String -> Either String a) -> ReadM a
forall a b. (a -> b) -> a -> b
$ ByteString -> Either String a
forall a. FromJSON a => ByteString -> Either String a
eitherDecode' (ByteString -> Either String a)
-> (String -> ByteString) -> String -> Either String a
forall β γ α. (β -> γ) -> (α -> β) -> α -> γ
∘ String -> ByteString
BL8.pack