{-# LANGUAGE DeriveFunctor #-}
module Distribution.FieldGrammar.Pretty (
PrettyFieldGrammar,
prettyFieldGrammar,
) where
import Distribution.CabalSpecVersion
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 (..), showFreeText, showFreeTextV3)
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 -> CabalSpecVersion -> s -> [PrettyField ()]
fieldGrammarPretty :: CabalSpecVersion -> 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 _ = (CabalSpecVersion -> s -> [PrettyField ()])
-> PrettyFieldGrammar s a
forall s a.
(CabalSpecVersion -> s -> [PrettyField ()])
-> PrettyFieldGrammar s a
PrettyFG (\_ _ -> [PrettyField ()]
forall a. Monoid a => a
mempty)
PrettyFG f :: CabalSpecVersion -> s -> [PrettyField ()]
f <*> :: PrettyFieldGrammar s (a -> b)
-> PrettyFieldGrammar s a -> PrettyFieldGrammar s b
<*> PrettyFG x :: CabalSpecVersion -> s -> [PrettyField ()]
x = (CabalSpecVersion -> s -> [PrettyField ()])
-> PrettyFieldGrammar s b
forall s a.
(CabalSpecVersion -> s -> [PrettyField ()])
-> PrettyFieldGrammar s a
PrettyFG (\v :: CabalSpecVersion
v s :: s
s -> CabalSpecVersion -> s -> [PrettyField ()]
f CabalSpecVersion
v s
s [PrettyField ()] -> [PrettyField ()] -> [PrettyField ()]
forall a. Semigroup a => a -> a -> a
<> CabalSpecVersion -> s -> [PrettyField ()]
x CabalSpecVersion
v s
s)
prettyFieldGrammar :: CabalSpecVersion -> PrettyFieldGrammar s a -> s -> [PrettyField ()]
prettyFieldGrammar :: CabalSpecVersion -> PrettyFieldGrammar s a -> s -> [PrettyField ()]
prettyFieldGrammar = (PrettyFieldGrammar s a
-> CabalSpecVersion -> s -> [PrettyField ()])
-> CabalSpecVersion
-> PrettyFieldGrammar s a
-> s
-> [PrettyField ()]
forall a b c. (a -> b -> c) -> b -> a -> c
flip PrettyFieldGrammar s a -> CabalSpecVersion -> s -> [PrettyField ()]
forall s a.
PrettyFieldGrammar s a -> CabalSpecVersion -> 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 :: CabalSpecVersion -> b -> [PrettyField ()]
pp) = (CabalSpecVersion -> a -> [PrettyField ()])
-> PrettyFieldGrammar a c
forall s a.
(CabalSpecVersion -> s -> [PrettyField ()])
-> PrettyFieldGrammar s a
PrettyFG (\v :: CabalSpecVersion
v -> CabalSpecVersion -> b -> [PrettyField ()]
pp CabalSpecVersion
v (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 = (CabalSpecVersion -> s -> [PrettyField ()])
-> PrettyFieldGrammar s a
forall s a.
(CabalSpecVersion -> s -> [PrettyField ()])
-> PrettyFieldGrammar s a
PrettyFG ((CabalSpecVersion -> s -> [PrettyField ()])
-> PrettyFieldGrammar s a)
-> (CabalSpecVersion -> s -> [PrettyField ()])
-> PrettyFieldGrammar s a
forall a b. (a -> b) -> a -> b
$ \_v :: CabalSpecVersion
_v s :: s
s ->
FieldName -> Doc -> [PrettyField ()]
ppField FieldName
fn (b -> Doc
forall a. Pretty a => a -> Doc
pretty ((a -> b) -> a -> b
forall o n. Newtype o n => (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 = (CabalSpecVersion -> s -> [PrettyField ()])
-> PrettyFieldGrammar s Bool
forall s a.
(CabalSpecVersion -> s -> [PrettyField ()])
-> PrettyFieldGrammar s a
PrettyFG CabalSpecVersion -> s -> [PrettyField ()]
forall p. p -> s -> [PrettyField ()]
pp
where
pp :: p -> s -> [PrettyField ()]
pp _v :: p
_v 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 = (CabalSpecVersion -> s -> [PrettyField ()])
-> PrettyFieldGrammar s (Maybe a)
forall s a.
(CabalSpecVersion -> s -> [PrettyField ()])
-> PrettyFieldGrammar s a
PrettyFG CabalSpecVersion -> s -> [PrettyField ()]
pp
where
pp :: CabalSpecVersion -> s -> [PrettyField ()]
pp v :: CabalSpecVersion
v 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 (CabalSpecVersion -> b -> Doc
forall a. Pretty a => CabalSpecVersion -> a -> Doc
prettyVersioned CabalSpecVersion
v ((a -> b) -> a -> b
forall o n. Newtype o n => (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 = (CabalSpecVersion -> s -> [PrettyField ()])
-> PrettyFieldGrammar s a
forall s a.
(CabalSpecVersion -> s -> [PrettyField ()])
-> PrettyFieldGrammar s a
PrettyFG CabalSpecVersion -> s -> [PrettyField ()]
pp
where
pp :: CabalSpecVersion -> s -> [PrettyField ()]
pp v :: CabalSpecVersion
v 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 (CabalSpecVersion -> b -> Doc
forall a. Pretty a => CabalSpecVersion -> a -> Doc
prettyVersioned CabalSpecVersion
v ((a -> b) -> a -> b
forall o n. Newtype o n => (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
freeTextField :: FieldName
-> ALens' s (Maybe String) -> PrettyFieldGrammar s (Maybe String)
freeTextField fn :: FieldName
fn l :: ALens' s (Maybe String)
l = (CabalSpecVersion -> s -> [PrettyField ()])
-> PrettyFieldGrammar s (Maybe String)
forall s a.
(CabalSpecVersion -> s -> [PrettyField ()])
-> PrettyFieldGrammar s a
PrettyFG CabalSpecVersion -> s -> [PrettyField ()]
pp where
pp :: CabalSpecVersion -> s -> [PrettyField ()]
pp v :: CabalSpecVersion
v s :: s
s = [PrettyField ()]
-> (String -> [PrettyField ()]) -> Maybe String -> [PrettyField ()]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [PrettyField ()]
forall a. Monoid a => a
mempty (FieldName -> Doc -> [PrettyField ()]
ppField FieldName
fn (Doc -> [PrettyField ()])
-> (String -> Doc) -> String -> [PrettyField ()]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Doc
showFT) (ALens' s (Maybe String) -> s -> Maybe String
forall s t a b. ALens s t a b -> s -> a
aview ALens' s (Maybe String)
l s
s) where
showFT :: String -> Doc
showFT | CabalSpecVersion
v CabalSpecVersion -> CabalSpecVersion -> Bool
forall a. Ord a => a -> a -> Bool
>= CabalSpecVersion
CabalSpecV3_0 = String -> Doc
showFreeTextV3
| Bool
otherwise = String -> Doc
showFreeText
freeTextFieldDef :: FieldName -> ALens' s String -> PrettyFieldGrammar s String
freeTextFieldDef fn :: FieldName
fn l :: ALens' s String
l = (CabalSpecVersion -> s -> [PrettyField ()])
-> PrettyFieldGrammar s String
forall s a.
(CabalSpecVersion -> s -> [PrettyField ()])
-> PrettyFieldGrammar s a
PrettyFG CabalSpecVersion -> s -> [PrettyField ()]
pp where
pp :: CabalSpecVersion -> s -> [PrettyField ()]
pp v :: CabalSpecVersion
v s :: s
s = FieldName -> Doc -> [PrettyField ()]
ppField FieldName
fn (String -> Doc
showFT (ALens' s String -> s -> String
forall s t a b. ALens s t a b -> s -> a
aview ALens' s String
l s
s)) where
showFT :: String -> Doc
showFT | CabalSpecVersion
v CabalSpecVersion -> CabalSpecVersion -> Bool
forall a. Ord a => a -> a -> Bool
>= CabalSpecVersion
CabalSpecV3_0 = String -> Doc
showFreeTextV3
| Bool
otherwise = String -> Doc
showFreeText
monoidalFieldAla :: FieldName -> (a -> b) -> ALens' s a -> PrettyFieldGrammar s a
monoidalFieldAla fn :: FieldName
fn _pack :: a -> b
_pack l :: ALens' s a
l = (CabalSpecVersion -> s -> [PrettyField ()])
-> PrettyFieldGrammar s a
forall s a.
(CabalSpecVersion -> s -> [PrettyField ()])
-> PrettyFieldGrammar s a
PrettyFG CabalSpecVersion -> s -> [PrettyField ()]
pp
where
pp :: CabalSpecVersion -> s -> [PrettyField ()]
pp v :: CabalSpecVersion
v s :: s
s = FieldName -> Doc -> [PrettyField ()]
ppField FieldName
fn (CabalSpecVersion -> b -> Doc
forall a. Pretty a => CabalSpecVersion -> a -> Doc
prettyVersioned CabalSpecVersion
v ((a -> b) -> a -> b
forall o n. Newtype o n => (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 = (CabalSpecVersion -> s -> [PrettyField ()])
-> PrettyFieldGrammar s [(String, String)]
forall s a.
(CabalSpecVersion -> 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 ()
forall ann. ann -> FieldName -> Doc -> PrettyField ann
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 _ = (CabalSpecVersion -> s -> [PrettyField ()])
-> PrettyFieldGrammar s a
forall s a.
(CabalSpecVersion -> s -> [PrettyField ()])
-> PrettyFieldGrammar s a
PrettyFG (\_ -> s -> [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 ()
forall ann. ann -> FieldName -> Doc -> PrettyField ann
PrettyField () FieldName
name Doc
fielddoc ]