Cabal-syntax/src/Distribution/FieldGrammar/FieldDescrs.hs

   1 {-# LANGUAGE DeriveFunctor #-}
   2 {-# LANGUAGE FlexibleInstances #-}
   3 {-# LANGUAGE MultiParamTypeClasses #-}
   4 {-# LANGUAGE RankNTypes #-}
   5 {-# LANGUAGE UndecidableInstances #-}
   6
   7 module Distribution.FieldGrammar.FieldDescrs
   8   ( FieldDescrs
   9   , fieldDescrPretty
  10   , fieldDescrParse
  11   , fieldDescrsToList
  12   ) where
  13
  14 import Distribution.Compat.Prelude
  15 import Prelude ()
  16
  17 import Distribution.Compat.Lens (aview, cloneLens)
  18 import Distribution.Compat.Newtype
  19 import Distribution.FieldGrammar
  20 import Distribution.Pretty (Pretty (..), showFreeText)
  21 import Distribution.Utils.String (trim)
  22
  23 import qualified Data.Map as Map
  24 import qualified Distribution.Compat.CharParsing as C
  25 import qualified Distribution.Fields as P
  26 import qualified Distribution.Parsec as P
  27 import qualified Text.PrettyPrint as Disp
  28
  29 -- strict pair
  30 data SP s = SP
  31   { pPretty :: !(s -> Disp.Doc)
  32   , pParse :: !(forall m. P.CabalParsing m => s -> m s)
  33   }
  34
  35 -- | A collection of field parsers and pretty-printers.
  36 newtype FieldDescrs s a = F {runF :: Map P.FieldName (SP s)}
  37   deriving (Functor)
  38
  39 instance Applicative (FieldDescrs s) where
  40   pure _ = F mempty
  41   f <*> x = F (mappend (runF f) (runF x))
  42
  43 singletonF :: P.FieldName -> (s -> Disp.Doc) -> (forall m. P.CabalParsing m => s -> m s) -> FieldDescrs s a
  44 singletonF fn f g = F $ Map.singleton fn (SP f g)
  45
  46 -- | Lookup a field value pretty-printer.
  47 fieldDescrPretty :: FieldDescrs s a -> P.FieldName -> Maybe (s -> Disp.Doc)
  48 fieldDescrPretty (F m) fn = pPretty <$> Map.lookup fn m
  49
  50 -- | Lookup a field value parser.
  51 fieldDescrParse :: P.CabalParsing m => FieldDescrs s a -> P.FieldName -> Maybe (s -> m s)
  52 fieldDescrParse (F m) fn = (\f -> pParse f) <$> Map.lookup fn m
  53
  54 fieldDescrsToList
  55   :: P.CabalParsing m
  56   => FieldDescrs s a
  57   -> [(P.FieldName, s -> Disp.Doc, s -> m s)]
  58 fieldDescrsToList = map mk . Map.toList . runF
  59   where
  60     mk (name, SP ppr parse) = (name, ppr, parse)
  61
  62 -- | /Note:/ default values are printed.
  63 instance FieldGrammar ParsecPretty FieldDescrs where
  64   blurFieldGrammar l (F m) = F (fmap blur m)
  65     where
  66       blur (SP f g) = SP (f . aview l) (cloneLens l g)
  67
  68   booleanFieldDef fn l _def = singletonF fn f g
  69     where
  70       f s = Disp.text (show (aview l s))
  71       g s = cloneLens l (const P.parsec) s
  72
  73   -- Note: eta expansion is needed for RankNTypes type-checking to work.
  74
  75   uniqueFieldAla fn _pack l = singletonF fn f g
  76     where
  77       f s = pretty (pack' _pack (aview l s))
  78       g s = cloneLens l (const (unpack' _pack <$> P.parsec)) s
  79
  80   optionalFieldAla fn _pack l = singletonF fn f g
  81     where
  82       f s = maybe mempty (pretty . pack' _pack) (aview l s)
  83       g s = cloneLens l (const (Just . unpack' _pack <$> P.parsec)) s
  84
  85   optionalFieldDefAla fn _pack l _def = singletonF fn f g
  86     where
  87       f s = pretty (pack' _pack (aview l s))
  88       g s = cloneLens l (const (unpack' _pack <$> P.parsec)) s
  89
  90   freeTextField fn l = singletonF fn f g
  91     where
  92       f s = maybe mempty showFreeText (aview l s)
  93       g s = cloneLens l (const (Just <$> parsecFreeText)) s
  94
  95   freeTextFieldDef fn l = singletonF fn f g
  96     where
  97       f s = showFreeText (aview l s)
  98       g s = cloneLens l (const parsecFreeText) s
  99
 100   freeTextFieldDefST = defaultFreeTextFieldDefST
 101
 102   monoidalFieldAla fn _pack l = singletonF fn f g
 103     where
 104       f s = pretty (pack' _pack (aview l s))
 105       g s = cloneLens l (\x -> mappend x . unpack' _pack <$> P.parsec) s
 106
 107   prefixedFields _fnPfx _l = F mempty
 108   knownField _ = pure ()
 109   deprecatedSince _ _ x = x
 110   removedIn _ _ x = x
 111   availableSince _ _ = id
 112   hiddenField _ = F mempty
 113
 114 parsecFreeText :: P.CabalParsing m => m String
 115 parsecFreeText = dropDotLines <$ C.spaces <*> many C.anyChar
 116   where
 117     -- Example package with dot lines
 118     -- http://hackage.haskell.org/package/copilot-cbmc-0.1/copilot-cbmc.cabal
 119     dropDotLines "." = "."
 120     dropDotLines x = intercalate "\n" . map dotToEmpty . lines $ x
 121
 122     dotToEmpty x | trim' x == "." = ""
 123     dotToEmpty x = trim x
 124
 125     trim' :: String -> String
 126     trim' = dropWhileEnd (`elem` (" \t" :: String))
 127
 128 class (P.Parsec a, Pretty a) => ParsecPretty a
 129 instance (P.Parsec a, Pretty a) => ParsecPretty a