ViewAsFieldDescr.hs

module Distribution.Deprecated.ViewAsFieldDescr (
    viewAsFieldDescr
    ) where

import Distribution.Client.Compat.Prelude hiding (get)
import Prelude ()

import Distribution.Parsec   (parsec)
import Distribution.Pretty
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 (OptionField _n []) =
  error "Distribution.command.viewAsFieldDescr: unexpected"
viewAsFieldDescr (OptionField n dd) = FieldDescr n get set

    where
      optDescr = head $ sortBy cmp dd

      cmp :: OptDescr a -> OptDescr a -> Ordering
      ReqArg{}    `cmp` ReqArg{}    = EQ
      ReqArg{}    `cmp` _           = GT
      BoolOpt{}   `cmp` ReqArg{}    = LT
      BoolOpt{}   `cmp` BoolOpt{}   = EQ
      BoolOpt{}   `cmp` _           = GT
      ChoiceOpt{} `cmp` ReqArg{}    = LT
      ChoiceOpt{} `cmp` BoolOpt{}   = LT
      ChoiceOpt{} `cmp` ChoiceOpt{} = EQ
      ChoiceOpt{} `cmp` _           = GT
      OptArg{}    `cmp` OptArg{}    = EQ
      OptArg{}    `cmp` _           = LT

--    get :: a -> Doc
      get t = case optDescr of
        ReqArg _ _ _ _ ppr ->
          (cat . punctuate comma . map text . ppr) t

        OptArg _ _ _ _ _ ppr ->
          case ppr t of []        -> PP.empty
                        (Nothing : _) -> text "True"
                        (Just a  : _) -> text a

        ChoiceOpt alts ->
          fromMaybe PP.empty $ listToMaybe
          [ text lf | (_,(_,lf:_), _,enabled) <- alts, enabled t]

        BoolOpt _ _ _ _ enabled -> (maybe PP.empty pretty . enabled) t

--    set :: LineNo -> String -> a -> ParseResult a
      set line val a =
        case optDescr of
          ReqArg _ _ _ readE _    -> ($ a) `liftM` runE line n readE 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 getChoiceByLongFlag optDescr val of
              Just f -> return (f a)
              _      -> syntaxError line val

          BoolOpt _ _ _ setV _    -> (`setV` a) `liftM` runE line n (parsecToReadE ("<viewAsFieldDescr>" ++) parsec) val

          OptArg _ _ _  readE _ _ -> ($ a) `liftM` runE line n readE 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 (ChoiceOpt alts) val = listToMaybe
                                           [ set | (_,(_sf,lf:_), set, _) <- alts
                                                 , lf == val]

getChoiceByLongFlag _ _ =
  error "Distribution.command.getChoiceByLongFlag: expected a choice option"