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

   1 {-# LANGUAGE DeriveFunctor #-}
   2 {-# LANGUAGE MultiParamTypeClasses #-}
   3
   4 module Distribution.FieldGrammar.Pretty
   5   ( PrettyFieldGrammar
   6   , prettyFieldGrammar
   7   ) where
   8
   9 import Distribution.CabalSpecVersion
  10 import Distribution.Compat.Lens
  11 import Distribution.Compat.Newtype
  12 import Distribution.Compat.Prelude
  13 import Distribution.Fields.Field (FieldName)
  14 import Distribution.Fields.Pretty (PrettyField (..))
  15 import Distribution.Pretty (Pretty (..), showFreeText, showFreeTextV3)
  16 import Distribution.Utils.Generic (toUTF8BS)
  17 import Text.PrettyPrint (Doc)
  18 import qualified Text.PrettyPrint as PP
  19 import Prelude ()
  20
  21 import Distribution.FieldGrammar.Class
  22
  23 newtype PrettyFieldGrammar s a = PrettyFG
  24   { fieldGrammarPretty :: CabalSpecVersion -> s -> [PrettyField ()]
  25   }
  26   deriving (Functor)
  27
  28 instance Applicative (PrettyFieldGrammar s) where
  29   pure _ = PrettyFG (\_ _ -> mempty)
  30   PrettyFG f <*> PrettyFG x = PrettyFG (\v s -> f v s <> x v s)
  31
  32 -- | We can use 'PrettyFieldGrammar' to pp print the @s@.
  33 --
  34 -- /Note:/ there is not trailing @($+$ text "")@.
  35 prettyFieldGrammar :: CabalSpecVersion -> PrettyFieldGrammar s a -> s -> [PrettyField ()]
  36 prettyFieldGrammar = flip fieldGrammarPretty
  37
  38 instance FieldGrammar Pretty PrettyFieldGrammar where
  39   blurFieldGrammar f (PrettyFG pp) = PrettyFG (\v -> pp v . aview f)
  40
  41   uniqueFieldAla fn _pack l = PrettyFG $ \_v s ->
  42     ppField fn (pretty (pack' _pack (aview l s)))
  43
  44   booleanFieldDef fn l def = PrettyFG pp
  45     where
  46       pp _v s
  47         | b == def = mempty
  48         | otherwise = ppField fn (PP.text (show b))
  49         where
  50           b = aview l s
  51
  52   optionalFieldAla fn _pack l = PrettyFG pp
  53     where
  54       pp v s = case aview l s of
  55         Nothing -> mempty
  56         Just a -> ppField fn (prettyVersioned v (pack' _pack a))
  57
  58   optionalFieldDefAla fn _pack l def = PrettyFG pp
  59     where
  60       pp v s
  61         | x == def = mempty
  62         | otherwise = ppField fn (prettyVersioned v (pack' _pack x))
  63         where
  64           x = aview l s
  65
  66   freeTextField fn l = PrettyFG pp
  67     where
  68       pp v s = maybe mempty (ppField fn . showFT) (aview l s)
  69         where
  70           showFT
  71             | v >= CabalSpecV3_0 = showFreeTextV3
  72             | otherwise = showFreeText
  73
  74   -- it's ok to just show, as showFreeText of empty string is empty.
  75   freeTextFieldDef fn l = PrettyFG pp
  76     where
  77       pp v s = ppField fn (showFT (aview l s))
  78         where
  79           showFT
  80             | v >= CabalSpecV3_0 = showFreeTextV3
  81             | otherwise = showFreeText
  82
  83   freeTextFieldDefST = defaultFreeTextFieldDefST
  84
  85   monoidalFieldAla fn _pack l = PrettyFG pp
  86     where
  87       pp v s = ppField fn (prettyVersioned v (pack' _pack (aview l s)))
  88
  89   prefixedFields _fnPfx l = PrettyFG (\_ -> pp . aview l)
  90     where
  91       pp xs =
  92         -- always print the field, even its Doc is empty.
  93         -- i.e. don't use ppField
  94         [ PrettyField () (toUTF8BS n) $ PP.vcat $ map PP.text $ lines s
  95         | (n, s) <- xs
  96         -- fnPfx `isPrefixOf` n
  97         ]
  98
  99   knownField _ = pure ()
 100   deprecatedSince _ _ x = x
 101
 102   -- TODO: as PrettyFieldGrammar isn't aware of cabal-version: we output the field
 103   -- this doesn't affect roundtrip as `removedIn` fields cannot be parsed
 104   -- so invalid documents can be only manually constructed.
 105   removedIn _ _ x = x
 106   availableSince _ _ = id
 107   hiddenField _ = PrettyFG (\_ -> mempty)
 108
 109 ppField :: FieldName -> Doc -> [PrettyField ()]
 110 ppField name fielddoc
 111   | PP.isEmpty fielddoc = []
 112   | otherwise = [PrettyField () name fielddoc]