cabal-install/src/Distribution/Deprecated/ViewAsFieldDescr.hs

   1 module Distribution.Deprecated.ViewAsFieldDescr
   2   ( viewAsFieldDescr
   3   ) where
   4
   5 import Distribution.Client.Compat.Prelude hiding (get)
   6 import Prelude ()
   7
   8 import qualified Data.List.NonEmpty as NE
   9 import Distribution.ReadE (parsecToReadE)
  10 import Distribution.Simple.Command
  11 import Text.PrettyPrint (cat, comma, punctuate, text)
  12 import Text.PrettyPrint as PP (empty)
  13
  14 import Distribution.Deprecated.ParseUtils (FieldDescr (..), runE, syntaxError)
  15
  16 -- | to view as a FieldDescr, we sort the list of interfaces (Req > Bool >
  17 -- Choice > Opt) and consider only the first one.
  18 viewAsFieldDescr :: OptionField a -> FieldDescr a
  19 viewAsFieldDescr (OptionField _n []) =
  20   error "Distribution.command.viewAsFieldDescr: unexpected"
  21 viewAsFieldDescr (OptionField n (d : dd)) = FieldDescr n get set
  22   where
  23     optDescr = head $ NE.sortBy cmp (d :| dd)
  24
  25     cmp :: OptDescr a -> OptDescr a -> Ordering
  26     ReqArg{} `cmp` ReqArg{} = EQ
  27     ReqArg{} `cmp` _ = GT
  28     BoolOpt{} `cmp` ReqArg{} = LT
  29     BoolOpt{} `cmp` BoolOpt{} = EQ
  30     BoolOpt{} `cmp` _ = GT
  31     ChoiceOpt{} `cmp` ReqArg{} = LT
  32     ChoiceOpt{} `cmp` BoolOpt{} = LT
  33     ChoiceOpt{} `cmp` ChoiceOpt{} = EQ
  34     ChoiceOpt{} `cmp` _ = GT
  35     OptArg{} `cmp` OptArg{} = EQ
  36     OptArg{} `cmp` _ = LT
  37
  38     --    get :: a -> Doc
  39     get t = case optDescr of
  40       ReqArg _ _ _ _ ppr ->
  41         (cat . punctuate comma . map text . ppr) t
  42       OptArg _ _ _ _ _ ppr ->
  43         case ppr t of
  44           [] -> PP.empty
  45           (Nothing : _) -> text "True"
  46           (Just a : _) -> text a
  47       ChoiceOpt alts ->
  48         fromMaybe PP.empty $
  49           listToMaybe
  50             [text lf | (_, (_, lf : _), _, enabled) <- alts, enabled t]
  51       BoolOpt _ _ _ _ enabled -> (maybe PP.empty pretty . enabled) t
  52
  53     --    set :: LineNo -> String -> a -> ParseResult a
  54     set line val a =
  55       case optDescr of
  56         ReqArg _ _ _ readE _ -> ($ a) `liftM` runE line n readE val
  57         -- We parse for a single value instead of a
  58         -- list, as one can't really implement
  59         -- parseList :: ReadE a -> ReadE [a] with
  60         -- the current ReadE definition
  61         ChoiceOpt{} ->
  62           case getChoiceByLongFlag optDescr val of
  63             Just f -> return (f a)
  64             _ -> syntaxError line val
  65         BoolOpt _ _ _ setV _ -> (`setV` a) `liftM` runE line n (parsecToReadE ("<viewAsFieldDescr>" ++) parsec) val
  66         OptArg _ _ _ readE _ _ -> ($ a) `liftM` runE line n readE val
  67
  68 -- Optional arguments are parsed just like
  69 -- required arguments here; we don't
  70 -- provide a method to set an OptArg field
  71 -- to the default value.
  72
  73 getChoiceByLongFlag :: OptDescr a -> String -> Maybe (a -> a)
  74 getChoiceByLongFlag (ChoiceOpt alts) val =
  75   listToMaybe
  76     [ set | (_, (_sf, lf : _), set, _) <- alts, lf == val
  77     ]
  78 getChoiceByLongFlag _ _ =
  79   error "Distribution.command.getChoiceByLongFlag: expected a choice option"