module Distribution.Deprecated.ViewAsFieldDescr (
viewAsFieldDescr
) where
import Distribution.Client.Compat.Prelude hiding (get)
import Prelude ()
import qualified Data.List.NonEmpty as NE
import Distribution.ReadE (parsecToReadE)
import Distribution.Simple.Command
import Text.PrettyPrint (cat, comma, punctuate, text)
import Text.PrettyPrint as PP (empty)
import Distribution.Deprecated.ParseUtils (FieldDescr (..), runE, syntaxError)
viewAsFieldDescr :: OptionField a -> FieldDescr a
viewAsFieldDescr :: OptionField a -> FieldDescr a
viewAsFieldDescr (OptionField Name
_n []) =
Name -> FieldDescr a
forall a. HasCallStack => Name -> a
error Name
"Distribution.command.viewAsFieldDescr: unexpected"
viewAsFieldDescr (OptionField Name
n (OptDescr a
d:[OptDescr a]
dd)) = Name
-> (a -> Doc)
-> (LineNo -> Name -> a -> ParseResult a)
-> FieldDescr a
forall a.
Name
-> (a -> Doc)
-> (LineNo -> Name -> a -> ParseResult a)
-> FieldDescr a
FieldDescr Name
n a -> Doc
get LineNo -> Name -> a -> ParseResult a
set
where
optDescr :: OptDescr a
optDescr = NonEmpty (OptDescr a) -> OptDescr a
forall a. NonEmpty a -> a
head (NonEmpty (OptDescr a) -> OptDescr a)
-> NonEmpty (OptDescr a) -> OptDescr a
forall a b. (a -> b) -> a -> b
$ (OptDescr a -> OptDescr a -> Ordering)
-> NonEmpty (OptDescr a) -> NonEmpty (OptDescr a)
forall a. (a -> a -> Ordering) -> NonEmpty a -> NonEmpty a
NE.sortBy OptDescr a -> OptDescr a -> Ordering
forall a. OptDescr a -> OptDescr a -> Ordering
cmp (OptDescr a
dOptDescr a -> [OptDescr a] -> NonEmpty (OptDescr a)
forall a. a -> [a] -> NonEmpty a
:|[OptDescr a]
dd)
cmp :: OptDescr a -> OptDescr a -> Ordering
ReqArg{} cmp :: OptDescr a -> OptDescr a -> Ordering
`cmp` ReqArg{} = Ordering
EQ
ReqArg{} `cmp` OptDescr a
_ = Ordering
GT
BoolOpt{} `cmp` ReqArg{} = Ordering
LT
BoolOpt{} `cmp` BoolOpt{} = Ordering
EQ
BoolOpt{} `cmp` OptDescr a
_ = Ordering
GT
ChoiceOpt{} `cmp` ReqArg{} = Ordering
LT
ChoiceOpt{} `cmp` BoolOpt{} = Ordering
LT
ChoiceOpt{} `cmp` ChoiceOpt{} = Ordering
EQ
ChoiceOpt{} `cmp` OptDescr a
_ = Ordering
GT
OptArg{} `cmp` OptArg{} = Ordering
EQ
OptArg{} `cmp` OptDescr a
_ = Ordering
LT
get :: a -> Doc
get a
t = case OptDescr a
optDescr of
ReqArg Name
_ OptFlags
_ Name
_ ReadE (a -> a)
_ a -> [Name]
ppr ->
([Doc] -> Doc
cat ([Doc] -> Doc) -> (a -> [Doc]) -> a -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Doc -> [Doc] -> [Doc]
punctuate Doc
comma ([Doc] -> [Doc]) -> (a -> [Doc]) -> a -> [Doc]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Name -> Doc) -> [Name] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map Name -> Doc
text ([Name] -> [Doc]) -> (a -> [Name]) -> a -> [Doc]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> [Name]
ppr) a
t
OptArg Name
_ OptFlags
_ Name
_ ReadE (a -> a)
_ a -> a
_ a -> [Maybe Name]
ppr ->
case a -> [Maybe Name]
ppr a
t of [] -> Doc
PP.empty
(Maybe Name
Nothing : [Maybe Name]
_) -> Name -> Doc
text Name
"True"
(Just Name
a : [Maybe Name]
_) -> Name -> Doc
text Name
a
ChoiceOpt [(Name, OptFlags, a -> a, a -> Bool)]
alts ->
Doc -> Maybe Doc -> Doc
forall a. a -> Maybe a -> a
fromMaybe Doc
PP.empty (Maybe Doc -> Doc) -> Maybe Doc -> Doc
forall a b. (a -> b) -> a -> b
$ [Doc] -> Maybe Doc
forall a. [a] -> Maybe a
listToMaybe
[ Name -> Doc
text Name
lf | (Name
_,(Name
_,Name
lf:[Name]
_), a -> a
_,a -> Bool
enabled) <- [(Name, OptFlags, a -> a, a -> Bool)]
alts, a -> Bool
enabled a
t]
BoolOpt Name
_ OptFlags
_ OptFlags
_ Bool -> a -> a
_ a -> Maybe Bool
enabled -> (Doc -> (Bool -> Doc) -> Maybe Bool -> Doc
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Doc
PP.empty Bool -> Doc
forall a. Pretty a => a -> Doc
pretty (Maybe Bool -> Doc) -> (a -> Maybe Bool) -> a -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Maybe Bool
enabled) a
t
set :: LineNo -> Name -> a -> ParseResult a
set LineNo
line Name
val a
a =
case OptDescr a
optDescr of
ReqArg Name
_ OptFlags
_ Name
_ ReadE (a -> a)
readE a -> [Name]
_ -> ((a -> a) -> a -> a
forall a b. (a -> b) -> a -> b
$ a
a) ((a -> a) -> a) -> ParseResult (a -> a) -> ParseResult a
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
`liftM` LineNo -> Name -> ReadE (a -> a) -> Name -> ParseResult (a -> a)
forall a. LineNo -> Name -> ReadE a -> Name -> ParseResult a
runE LineNo
line Name
n ReadE (a -> a)
readE Name
val
ChoiceOpt{} ->
case OptDescr a -> Name -> Maybe (a -> a)
forall a. OptDescr a -> Name -> Maybe (a -> a)
getChoiceByLongFlag OptDescr a
optDescr Name
val of
Just a -> a
f -> a -> ParseResult a
forall (m :: * -> *) a. Monad m => a -> m a
return (a -> a
f a
a)
Maybe (a -> a)
_ -> LineNo -> Name -> ParseResult a
forall a. LineNo -> Name -> ParseResult a
syntaxError LineNo
line Name
val
BoolOpt Name
_ OptFlags
_ OptFlags
_ Bool -> a -> a
setV a -> Maybe Bool
_ -> (Bool -> a -> a
`setV` a
a) (Bool -> a) -> ParseResult Bool -> ParseResult a
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
`liftM` LineNo -> Name -> ReadE Bool -> Name -> ParseResult Bool
forall a. LineNo -> Name -> ReadE a -> Name -> ParseResult a
runE LineNo
line Name
n ((Name -> Name) -> ParsecParser Bool -> ReadE Bool
forall a. (Name -> Name) -> ParsecParser a -> ReadE a
parsecToReadE (Name
"<viewAsFieldDescr>" Name -> Name -> Name
forall a. [a] -> [a] -> [a]
++) ParsecParser Bool
forall a (m :: * -> *). (Parsec a, CabalParsing m) => m a
parsec) Name
val
OptArg Name
_ OptFlags
_ Name
_ ReadE (a -> a)
readE a -> a
_ a -> [Maybe Name]
_ -> ((a -> a) -> a -> a
forall a b. (a -> b) -> a -> b
$ a
a) ((a -> a) -> a) -> ParseResult (a -> a) -> ParseResult a
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
`liftM` LineNo -> Name -> ReadE (a -> a) -> Name -> ParseResult (a -> a)
forall a. LineNo -> Name -> ReadE a -> Name -> ParseResult a
runE LineNo
line Name
n ReadE (a -> a)
readE Name
val
getChoiceByLongFlag :: OptDescr a -> String -> Maybe (a -> a)
getChoiceByLongFlag :: OptDescr a -> Name -> Maybe (a -> a)
getChoiceByLongFlag (ChoiceOpt [(Name, OptFlags, a -> a, a -> Bool)]
alts) Name
val = [a -> a] -> Maybe (a -> a)
forall a. [a] -> Maybe a
listToMaybe
[ a -> a
set | (Name
_,(Name
_sf,Name
lf:[Name]
_), a -> a
set, a -> Bool
_) <- [(Name, OptFlags, a -> a, a -> Bool)]
alts
, Name
lf Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
val]
getChoiceByLongFlag OptDescr a
_ Name
_ =
Name -> Maybe (a -> a)
forall a. HasCallStack => Name -> a
error Name
"Distribution.command.getChoiceByLongFlag: expected a choice option"