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)

-- | to view as a FieldDescr, we sort the list of interfaces (Req > Bool >
-- Choice > Opt) and consider only the first one.
viewAsFieldDescr :: OptionField a -> FieldDescr a
viewAsFieldDescr :: forall a. 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
d OptDescr a -> [OptDescr a] -> NonEmpty (OptDescr a)
forall a. a -> [a] -> NonEmpty a
:| [OptDescr a]
dd)

    cmp :: OptDescr a -> OptDescr a -> Ordering
    ReqArg{} cmp :: forall a. 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 -> 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)
_ (Name, 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 -> String -> a -> ParseResult a
    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
        -- We parse for a single value instead of a
        -- list, as one can't really implement
        -- parseList :: ReadE a -> ReadE [a] with
        -- the current ReadE definition
        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 a. 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
forall (m :: * -> *). CabalParsing m => m Bool
parsec) Name
val
        OptArg Name
_ OptFlags
_ Name
_ ReadE (a -> a)
readE (Name, 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

-- Optional arguments are parsed just like
-- required arguments here; we don't
-- provide a method to set an OptArg field
-- to the default value.

getChoiceByLongFlag :: OptDescr a -> String -> Maybe (a -> a)
getChoiceByLongFlag :: forall a. 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"