{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE UndecidableSuperClasses #-}
module Options.Harg.Construct
( option,
flag,
switch,
switch',
argument,
long,
short,
help,
metavar,
envVar,
defaultVal,
defaultStr,
required,
optional,
parseWith,
readParser,
strParser,
boolParser,
manyParser,
)
where
import Data.Char (toLower)
import Data.Kind (Constraint)
import Data.List.Split (splitOn)
import Data.String (IsString (..))
import GHC.TypeLits (AppendSymbol, ErrorMessage (..), Symbol, TypeError)
import Options.Harg.Types
import Text.Read (readMaybe)
class HasLong o (attr :: [OptAttr]) where
long :: String -> o attr a -> o attr a
instance HasLong OptionOpt a where
long s o = o {_oLong = Just s}
instance HasLong FlagOpt a where
long s o = o {_fLong = Just s}
class HasShort o (attr :: [OptAttr]) where
short :: Char -> o attr a -> o attr a
instance HasShort OptionOpt a where
short c o = o {_oShort = Just c}
instance HasShort FlagOpt a where
short c o = o {_fShort = Just c}
class HasHelp o (attr :: [OptAttr]) where
help :: String -> o attr a -> o attr a
instance HasHelp OptionOpt a where
help s o = o {_oHelp = Just s}
instance HasHelp FlagOpt a where
help s o = o {_fHelp = Just s}
instance HasHelp ArgumentOpt a where
help s o = o {_aHelp = Just s}
class HasMetavar o (attr :: [OptAttr]) where
metavar :: String -> o attr a -> o attr a
instance HasMetavar OptionOpt a where
metavar s o = o {_oMetavar = Just s}
instance HasMetavar ArgumentOpt a where
metavar s o = o {_aMetavar = Just s}
class HasEnvVar o (attr :: [OptAttr]) where
envVar :: String -> o attr a -> o attr a
instance HasEnvVar OptionOpt a where
envVar s o = o {_oEnvVar = Just s}
instance HasEnvVar FlagOpt a where
envVar s o = o {_fEnvVar = Just s}
instance HasEnvVar ArgumentOpt a where
envVar s o = o {_aEnvVar = Just s}
class HasDefaultVal o (attr :: [OptAttr]) where
defaultVal ::
( NotInAttrs OptDefault attr (DuplicateAttrMultipleErr "defaultVal" '["defaultStr", "required"]),
NotInAttrs OptOptional attr (IncompatibleAttrsErr "defaultVal" "optional")
) =>
a ->
o attr a ->
o (OptDefault ': attr) a
instance HasDefaultVal OptionOpt a where
defaultVal a o = o {_oDefaultVal = Just a}
instance HasDefaultVal ArgumentOpt a where
defaultVal a o = o {_aDefaultVal = Just a}
class HasDefaultStr o (attr :: [OptAttr]) where
defaultStr ::
( NotInAttrs OptDefault attr (DuplicateAttrMultipleErr "defaultStr" '["defaultVal", "required"]),
NotInAttrs OptOptional attr (IncompatibleAttrsErr "defaultStr" "optional")
) =>
String ->
o attr a ->
o (OptDefault ': attr) a
instance HasDefaultStr OptionOpt a where
defaultStr s o = o {_oDefaultStr = Just s}
instance HasDefaultStr ArgumentOpt a where
defaultStr s o = o {_aDefaultStr = Just s}
class HasRequired o (attr :: [OptAttr]) where
required ::
( NotInAttrs OptDefault attr (DuplicateAttrMultipleErr "required" '["defaultVal", "defaultStr"]),
NotInAttrs OptOptional attr (IncompatibleAttrsErr "required" "optional")
) =>
o attr a ->
o (OptDefault ': attr) a
instance HasRequired OptionOpt a where
required o = o {_oDefaultVal = Nothing}
instance HasRequired ArgumentOpt a where
required o = o {_aDefaultVal = Nothing}
class HasOptional o (attr :: [OptAttr]) where
optional ::
( NotInAttrs OptOptional attr (DuplicateAttrErr "optional"),
NotInAttrs OptDefault attr (IncompatibleAttrsErr "optional" "defaultVal")
) =>
o attr a ->
o (OptOptional ': attr) (Maybe a)
instance HasOptional OptionOpt a where
optional OptionOpt {..} =
OptionOpt
{ _oLong = _oLong,
_oShort = _oShort,
_oHelp = _oHelp,
_oMetavar = _oMetavar,
_oEnvVar = _oEnvVar,
_oDefaultVal = Just Nothing,
_oDefaultStr = Nothing,
_oReader = fmap Just . _oReader
}
instance HasOptional ArgumentOpt a where
optional ArgumentOpt {..} =
ArgumentOpt
{ _aHelp = _aHelp,
_aMetavar = _aMetavar,
_aEnvVar = _aEnvVar,
_aDefaultVal = Just Nothing,
_aDefaultStr = Nothing,
_aReader = fmap Just . _aReader
}
class IsOpt o (attr :: [OptAttr]) where
toOpt :: o attr a -> Opt a
instance IsOpt OptionOpt attr where
toOpt OptionOpt {..} =
Opt
{ _optLong = _oLong,
_optShort = _oShort,
_optHelp = _oHelp,
_optMetavar = _oMetavar,
_optEnvVar = _oEnvVar,
_optDefaultVal = _oDefaultVal,
_optDefaultStr = _oDefaultStr,
_optReader = _oReader,
_optType = OptionOptType
}
instance IsOpt FlagOpt attr where
toOpt FlagOpt {..} =
Opt
{ _optLong = _fLong,
_optShort = _fShort,
_optHelp = _fHelp,
_optMetavar = Nothing,
_optEnvVar = _fEnvVar,
_optDefaultVal = Just _fDefaultVal,
_optDefaultStr = Nothing,
_optReader = _fReader,
_optType = FlagOptType _fActive
}
instance IsOpt ArgumentOpt attr where
toOpt ArgumentOpt {..} =
Opt
{ _optLong = Nothing,
_optShort = Nothing,
_optHelp = _aHelp,
_optMetavar = _aMetavar,
_optEnvVar = _aEnvVar,
_optDefaultVal = _aDefaultVal,
_optDefaultStr = _aDefaultStr,
_optReader = _aReader,
_optType = ArgumentOptType
}
option ::
OptReader a ->
(OptionOpt '[] a -> OptionOpt attr b) ->
Opt b
option p f =
toOpt $ f opt
where
opt =
OptionOpt
{ _oLong = Nothing,
_oShort = Nothing,
_oHelp = Nothing,
_oMetavar = Nothing,
_oEnvVar = Nothing,
_oDefaultVal = Nothing,
_oDefaultStr = Nothing,
_oReader = p
}
flag ::
a ->
a ->
(FlagOpt '[] a -> FlagOpt attr b) ->
Opt b
flag d active f =
toOpt $ f opt
where
opt =
FlagOpt
{ _fLong = Nothing,
_fShort = Nothing,
_fHelp = Nothing,
_fEnvVar = Nothing,
_fDefaultVal = d,
_fActive = active,
_fReader = const (pure d)
}
switch ::
(FlagOpt '[] Bool -> FlagOpt attr Bool) ->
Opt Bool
switch f =
fl {_optReader = boolParser}
where
fl =
flag False True f
switch' ::
(FlagOpt '[] Bool -> FlagOpt attr Bool) ->
Opt Bool
switch' f =
fl {_optReader = boolParser}
where
fl =
flag True False f
argument ::
OptReader a ->
(ArgumentOpt '[] a -> ArgumentOpt attr b) ->
Opt b
argument p f =
toOpt $ f opt
where
opt =
ArgumentOpt
{ _aHelp = Nothing,
_aMetavar = Nothing,
_aEnvVar = Nothing,
_aDefaultVal = Nothing,
_aDefaultStr = Nothing,
_aReader = p
}
parseWith ::
(String -> Maybe a) ->
(String -> Either String a)
parseWith parser s =
maybe (Left err) Right (parser s)
where
err =
"Unable to parse: " <> s
readParser :: Read a => OptReader a
readParser =
parseWith readMaybe
strParser ::
IsString s =>
String ->
Either String s
strParser =
pure . fromString
boolParser :: String -> Either String Bool
boolParser s =
case map toLower s of
"true" -> Right True
"false" -> Right False
_ -> Left ("Unable to parse " <> s <> " to Bool")
manyParser ::
String ->
OptReader a ->
OptReader [a]
manyParser sep parser =
traverse parser . splitOn sep
type QuoteSym (s :: Symbol) =
'Text "`" :<>: 'Text s :<>: 'Text "`"
type family
NotInAttrs
(x :: k)
(xs :: [k])
(err :: ErrorMessage) ::
Constraint
where
NotInAttrs _ '[] _ =
()
NotInAttrs x (x ': _) err =
TypeError err
NotInAttrs x (y ': xs) err =
NotInAttrs x xs err
type family CommaSep (xs :: [Symbol]) :: Symbol where
CommaSep '[] = ""
CommaSep '[x] = " or " `AppendSymbol` x
CommaSep (x ': xs) = " or one of " `AppendSymbol` CommaSep' x xs
type family CommaSep' (s :: Symbol) (xs :: [Symbol]) :: Symbol where
CommaSep' s '[] = s
CommaSep' s (x ': xs) = CommaSep' (s `AppendSymbol` ", " `AppendSymbol` x) xs
type DuplicateAttrErr attr =
QuoteSym attr
:<>: 'Text " is already specified."
type DuplicateAttrMultipleErr attr rest =
QuoteSym attr
:<>: 'Text (CommaSep rest)
:<>: 'Text " has already been specified."
type IncompatibleAttrsErr l r =
QuoteSym l
:<>: 'Text " and "
:<>: QuoteSym r
:<>: 'Text " cannot be mixed in an option definition."