{-# LANGUAGE DeriveFunctor #-}
module Distribution.FieldGrammar.Pretty (
PrettyFieldGrammar,
prettyFieldGrammar,
) where
import Distribution.Compat.Lens
import Distribution.Compat.Newtype
import Distribution.Compat.Prelude
import Distribution.Fields.Field (FieldName)
import Distribution.Fields.Pretty (PrettyField (..))
import Distribution.Pretty (Pretty (..))
import Distribution.Simple.Utils (toUTF8BS)
import Prelude ()
import Text.PrettyPrint (Doc)
import qualified Text.PrettyPrint as PP
import Distribution.FieldGrammar.Class
newtype PrettyFieldGrammar s a = PrettyFG
{ PrettyFieldGrammar s a -> s -> [PrettyField]
fieldGrammarPretty :: s -> [PrettyField]
}
deriving ((a -> b) -> PrettyFieldGrammar s a -> PrettyFieldGrammar s b
(forall a b.
(a -> b) -> PrettyFieldGrammar s a -> PrettyFieldGrammar s b)
-> (forall a b.
a -> PrettyFieldGrammar s b -> PrettyFieldGrammar s a)
-> Functor (PrettyFieldGrammar s)
forall a b. a -> PrettyFieldGrammar s b -> PrettyFieldGrammar s a
forall a b.
(a -> b) -> PrettyFieldGrammar s a -> PrettyFieldGrammar s b
forall s a b. a -> PrettyFieldGrammar s b -> PrettyFieldGrammar s a
forall s a b.
(a -> b) -> PrettyFieldGrammar s a -> PrettyFieldGrammar s b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> PrettyFieldGrammar s b -> PrettyFieldGrammar s a
$c<$ :: forall s a b. a -> PrettyFieldGrammar s b -> PrettyFieldGrammar s a
fmap :: (a -> b) -> PrettyFieldGrammar s a -> PrettyFieldGrammar s b
$cfmap :: forall s a b.
(a -> b) -> PrettyFieldGrammar s a -> PrettyFieldGrammar s b
Functor)
instance Applicative (PrettyFieldGrammar s) where
pure :: a -> PrettyFieldGrammar s a
pure _ = (s -> [PrettyField]) -> PrettyFieldGrammar s a
forall s a. (s -> [PrettyField]) -> PrettyFieldGrammar s a
PrettyFG (\_ -> [PrettyField]
forall a. Monoid a => a
mempty)
PrettyFG f :: s -> [PrettyField]
f <*> :: PrettyFieldGrammar s (a -> b)
-> PrettyFieldGrammar s a -> PrettyFieldGrammar s b
<*> PrettyFG x :: s -> [PrettyField]
x = (s -> [PrettyField]) -> PrettyFieldGrammar s b
forall s a. (s -> [PrettyField]) -> PrettyFieldGrammar s a
PrettyFG (\s :: s
s -> s -> [PrettyField]
f s
s [PrettyField] -> [PrettyField] -> [PrettyField]
forall a. Semigroup a => a -> a -> a
<> s -> [PrettyField]
x s
s)
prettyFieldGrammar :: PrettyFieldGrammar s a -> s -> [PrettyField]
prettyFieldGrammar :: PrettyFieldGrammar s a -> s -> [PrettyField]
prettyFieldGrammar = PrettyFieldGrammar s a -> s -> [PrettyField]
forall s a. PrettyFieldGrammar s a -> s -> [PrettyField]
fieldGrammarPretty
instance FieldGrammar PrettyFieldGrammar where
blurFieldGrammar :: ALens' a b -> PrettyFieldGrammar b c -> PrettyFieldGrammar a c
blurFieldGrammar f :: ALens' a b
f (PrettyFG pp :: b -> [PrettyField]
pp) = (a -> [PrettyField]) -> PrettyFieldGrammar a c
forall s a. (s -> [PrettyField]) -> PrettyFieldGrammar s a
PrettyFG (b -> [PrettyField]
pp (b -> [PrettyField]) -> (a -> b) -> a -> [PrettyField]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ALens' a b -> a -> b
forall s t a b. ALens s t a b -> s -> a
aview ALens' a b
f)
uniqueFieldAla :: FieldName -> (a -> b) -> ALens' s a -> PrettyFieldGrammar s a
uniqueFieldAla fn :: FieldName
fn _pack :: a -> b
_pack l :: ALens' s a
l = (s -> [PrettyField]) -> PrettyFieldGrammar s a
forall s a. (s -> [PrettyField]) -> PrettyFieldGrammar s a
PrettyFG ((s -> [PrettyField]) -> PrettyFieldGrammar s a)
-> (s -> [PrettyField]) -> PrettyFieldGrammar s a
forall a b. (a -> b) -> a -> b
$ \s :: s
s ->
FieldName -> Doc -> [PrettyField]
ppField FieldName
fn (b -> Doc
forall a. Pretty a => a -> Doc
pretty ((a -> b) -> a -> b
forall n o. Newtype n o => (o -> n) -> o -> n
pack' a -> b
_pack (ALens' s a -> s -> a
forall s t a b. ALens s t a b -> s -> a
aview ALens' s a
l s
s)))
booleanFieldDef :: FieldName -> ALens' s Bool -> Bool -> PrettyFieldGrammar s Bool
booleanFieldDef fn :: FieldName
fn l :: ALens' s Bool
l def :: Bool
def = (s -> [PrettyField]) -> PrettyFieldGrammar s Bool
forall s a. (s -> [PrettyField]) -> PrettyFieldGrammar s a
PrettyFG s -> [PrettyField]
pp
where
pp :: s -> [PrettyField]
pp s :: s
s
| Bool
b Bool -> Bool -> Bool
forall a. Eq a => a -> a -> Bool
== Bool
def = [PrettyField]
forall a. Monoid a => a
mempty
| Bool
otherwise = FieldName -> Doc -> [PrettyField]
ppField FieldName
fn (String -> Doc
PP.text (Bool -> String
forall a. Show a => a -> String
show Bool
b))
where
b :: Bool
b = ALens' s Bool -> s -> Bool
forall s t a b. ALens s t a b -> s -> a
aview ALens' s Bool
l s
s
optionalFieldAla :: FieldName
-> (a -> b) -> ALens' s (Maybe a) -> PrettyFieldGrammar s (Maybe a)
optionalFieldAla fn :: FieldName
fn _pack :: a -> b
_pack l :: ALens' s (Maybe a)
l = (s -> [PrettyField]) -> PrettyFieldGrammar s (Maybe a)
forall s a. (s -> [PrettyField]) -> PrettyFieldGrammar s a
PrettyFG s -> [PrettyField]
pp
where
pp :: s -> [PrettyField]
pp s :: s
s = case ALens' s (Maybe a) -> s -> Maybe a
forall s t a b. ALens s t a b -> s -> a
aview ALens' s (Maybe a)
l s
s of
Nothing -> [PrettyField]
forall a. Monoid a => a
mempty
Just a :: a
a -> FieldName -> Doc -> [PrettyField]
ppField FieldName
fn (b -> Doc
forall a. Pretty a => a -> Doc
pretty ((a -> b) -> a -> b
forall n o. Newtype n o => (o -> n) -> o -> n
pack' a -> b
_pack a
a))
optionalFieldDefAla :: FieldName -> (a -> b) -> ALens' s a -> a -> PrettyFieldGrammar s a
optionalFieldDefAla fn :: FieldName
fn _pack :: a -> b
_pack l :: ALens' s a
l def :: a
def = (s -> [PrettyField]) -> PrettyFieldGrammar s a
forall s a. (s -> [PrettyField]) -> PrettyFieldGrammar s a
PrettyFG s -> [PrettyField]
pp
where
pp :: s -> [PrettyField]
pp s :: s
s
| a
x a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
def = [PrettyField]
forall a. Monoid a => a
mempty
| Bool
otherwise = FieldName -> Doc -> [PrettyField]
ppField FieldName
fn (b -> Doc
forall a. Pretty a => a -> Doc
pretty ((a -> b) -> a -> b
forall n o. Newtype n o => (o -> n) -> o -> n
pack' a -> b
_pack a
x))
where
x :: a
x = ALens' s a -> s -> a
forall s t a b. ALens s t a b -> s -> a
aview ALens' s a
l s
s
monoidalFieldAla :: FieldName -> (a -> b) -> ALens' s a -> PrettyFieldGrammar s a
monoidalFieldAla fn :: FieldName
fn _pack :: a -> b
_pack l :: ALens' s a
l = (s -> [PrettyField]) -> PrettyFieldGrammar s a
forall s a. (s -> [PrettyField]) -> PrettyFieldGrammar s a
PrettyFG s -> [PrettyField]
pp
where
pp :: s -> [PrettyField]
pp s :: s
s = FieldName -> Doc -> [PrettyField]
ppField FieldName
fn (b -> Doc
forall a. Pretty a => a -> Doc
pretty ((a -> b) -> a -> b
forall n o. Newtype n o => (o -> n) -> o -> n
pack' a -> b
_pack (ALens' s a -> s -> a
forall s t a b. ALens s t a b -> s -> a
aview ALens' s a
l s
s)))
prefixedFields :: FieldName
-> ALens' s [(String, String)]
-> PrettyFieldGrammar s [(String, String)]
prefixedFields _fnPfx :: FieldName
_fnPfx l :: ALens' s [(String, String)]
l = (s -> [PrettyField]) -> PrettyFieldGrammar s [(String, String)]
forall s a. (s -> [PrettyField]) -> PrettyFieldGrammar s a
PrettyFG ([(String, String)] -> [PrettyField]
pp ([(String, String)] -> [PrettyField])
-> (s -> [(String, String)]) -> s -> [PrettyField]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ALens' s [(String, String)] -> s -> [(String, String)]
forall s t a b. ALens s t a b -> s -> a
aview ALens' s [(String, String)]
l)
where
pp :: [(String, String)] -> [PrettyField]
pp xs :: [(String, String)]
xs =
[ FieldName -> Doc -> PrettyField
PrettyField (String -> FieldName
toUTF8BS String
n) (Doc -> PrettyField) -> Doc -> PrettyField
forall a b. (a -> b) -> a -> b
$ [Doc] -> Doc
PP.vcat ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$ (String -> Doc) -> [String] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map String -> Doc
PP.text ([String] -> [Doc]) -> [String] -> [Doc]
forall a b. (a -> b) -> a -> b
$ String -> [String]
lines String
s
| (n :: String
n, s :: String
s) <- [(String, String)]
xs
]
knownField :: FieldName -> PrettyFieldGrammar s ()
knownField _ = () -> PrettyFieldGrammar s ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
deprecatedSince :: CabalSpecVersion
-> String -> PrettyFieldGrammar s a -> PrettyFieldGrammar s a
deprecatedSince _ _ x :: PrettyFieldGrammar s a
x = PrettyFieldGrammar s a
x
removedIn :: CabalSpecVersion
-> String -> PrettyFieldGrammar s a -> PrettyFieldGrammar s a
removedIn _ _ x :: PrettyFieldGrammar s a
x = PrettyFieldGrammar s a
x
availableSince :: CabalSpecVersion
-> a -> PrettyFieldGrammar s a -> PrettyFieldGrammar s a
availableSince _ _ = PrettyFieldGrammar s a -> PrettyFieldGrammar s a
forall a. a -> a
id
hiddenField :: PrettyFieldGrammar s a -> PrettyFieldGrammar s a
hiddenField _ = (s -> [PrettyField]) -> PrettyFieldGrammar s a
forall s a. (s -> [PrettyField]) -> PrettyFieldGrammar s a
PrettyFG (\_ -> [PrettyField]
forall a. Monoid a => a
mempty)
ppField :: FieldName -> Doc -> [PrettyField]
ppField :: FieldName -> Doc -> [PrettyField]
ppField name :: FieldName
name fielddoc :: Doc
fielddoc
| Doc -> Bool
PP.isEmpty Doc
fielddoc = []
| Bool
otherwise = [ FieldName -> Doc -> PrettyField
PrettyField FieldName
name Doc
fielddoc ]