Distribution/FieldGrammar/Pretty.hs

    {-# LANGUAGE DeriveFunctor #-}
    module Distribution.FieldGrammar.Pretty (
        PrettyFieldGrammar,
        prettyFieldGrammar,
        ) where

    import           Distribution.Compat.Lens
    import           Distribution.Compat.Newtype
    import           Distribution.Compat.Prelude
    import           Distribution.Pretty         (Pretty (..))
    import           Distribution.Simple.Utils   (fromUTF8BS)
    import           Prelude ()
    import           Text.PrettyPrint            (Doc)
    import qualified Text.PrettyPrint            as PP

    import Distribution.FieldGrammar.Class
    import Distribution.ParseUtils         (ppField)

    newtype PrettyFieldGrammar s a = PrettyFG
        { fieldGrammarPretty :: s -> Doc
        }
      deriving (Functor)

    instance Applicative (PrettyFieldGrammar s) where
        pure _ = PrettyFG (\_ -> mempty)
        PrettyFG f <*> PrettyFG x = PrettyFG (\s -> f s PP.$$ x s)

    -- | We can use 'PrettyFieldGrammar' to pp print the @s@.
    --
    -- /Note:/ there is not trailing @($+$ text "")@.
    prettyFieldGrammar :: PrettyFieldGrammar s a -> s -> Doc
    prettyFieldGrammar = fieldGrammarPretty

    instance FieldGrammar PrettyFieldGrammar where
        blurFieldGrammar f (PrettyFG pp) = PrettyFG (pp . aview f)

        uniqueFieldAla fn _pack l = PrettyFG $ \s ->
            ppField (fromUTF8BS fn) (pretty (pack' _pack (aview l s)))

        booleanFieldDef fn l def = PrettyFG pp
          where
            pp s
                | b == def  = mempty
                | otherwise = ppField (fromUTF8BS fn) (PP.text (show b))
              where
                b = aview l s

        optionalFieldAla fn _pack l = PrettyFG pp
          where
            pp s = case aview l s of
                Nothing -> mempty
                Just a  -> ppField (fromUTF8BS fn) (pretty (pack' _pack a))

        optionalFieldDefAla fn _pack l def = PrettyFG pp
          where
            pp s
                | x == def  = mempty
                | otherwise = ppField (fromUTF8BS fn) (pretty (pack' _pack x))
              where
                x = aview l s

        monoidalFieldAla fn _pack l = PrettyFG pp
          where
            pp s = ppField  (fromUTF8BS fn) (pretty (pack' _pack (aview l s)))

        prefixedFields _fnPfx l = PrettyFG (pp . aview l)
          where
            pp xs = PP.vcat
                -- always print the field, even its Doc is empty
                -- i.e. don't use ppField
                [ PP.text n <<>> PP.colon PP.<+> (PP.vcat $ map PP.text $ lines s)
                | (n, s) <- xs
                -- fnPfx `isPrefixOf` n
                ]

        knownField _           = pure ()
        deprecatedSince [] _ _ = PrettyFG (\_ -> mempty)
        deprecatedSince _  _ x = x
        availableSince _ _     = id
        hiddenField _          = PrettyFG (\_ -> mempty)