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)
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
[ PP.text n <<>> PP.colon PP.<+> (PP.vcat $ map PP.text $ lines s)
| (n, s) <- xs
]
knownField _ = pure ()
deprecatedSince [] _ _ = PrettyFG (\_ -> mempty)
deprecatedSince _ _ x = x
availableSince _ _ = id
hiddenField _ = PrettyFG (\_ -> mempty)