{-# LANGUAGE DeriveFunctor         #-}
{-# LANGUAGE MultiParamTypeClasses #-}
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
    { forall s a.
PrettyFieldGrammar s a -> CabalSpecVersion -> s -> [PrettyField ()]
fieldGrammarPretty :: CabalSpecVersion -> s -> [PrettyField ()]
    }
  deriving (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
<$ :: forall a b. a -> PrettyFieldGrammar s b -> PrettyFieldGrammar s a
$c<$ :: forall s a b. a -> PrettyFieldGrammar s b -> PrettyFieldGrammar s a
fmap :: forall a b.
(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 :: forall a. a -> PrettyFieldGrammar s a
pure a
_ = forall s a.
(CabalSpecVersion -> s -> [PrettyField ()])
-> PrettyFieldGrammar s a
PrettyFG (\CabalSpecVersion
_ s
_ -> forall a. Monoid a => a
mempty)
    PrettyFG CabalSpecVersion -> s -> [PrettyField ()]
f <*> :: forall a b.
PrettyFieldGrammar s (a -> b)
-> PrettyFieldGrammar s a -> PrettyFieldGrammar s b
<*> PrettyFG CabalSpecVersion -> s -> [PrettyField ()]
x = forall s a.
(CabalSpecVersion -> s -> [PrettyField ()])
-> PrettyFieldGrammar s a
PrettyFG (\CabalSpecVersion
v s
s -> CabalSpecVersion -> s -> [PrettyField ()]
f CabalSpecVersion
v s
s forall a. Semigroup a => a -> a -> a
<> CabalSpecVersion -> s -> [PrettyField ()]
x CabalSpecVersion
v s
s)

-- | We can use 'PrettyFieldGrammar' to pp print the @s@.
--
-- /Note:/ there is not trailing @($+$ text "")@.
prettyFieldGrammar :: CabalSpecVersion -> PrettyFieldGrammar s a -> s -> [PrettyField ()]
prettyFieldGrammar :: forall s a.
CabalSpecVersion -> PrettyFieldGrammar s a -> s -> [PrettyField ()]
prettyFieldGrammar = forall a b c. (a -> b -> c) -> b -> a -> c
flip forall s a.
PrettyFieldGrammar s a -> CabalSpecVersion -> s -> [PrettyField ()]
fieldGrammarPretty

instance FieldGrammar Pretty PrettyFieldGrammar where
    blurFieldGrammar :: forall a b d.
ALens' a b -> PrettyFieldGrammar b d -> PrettyFieldGrammar a d
blurFieldGrammar ALens' a b
f (PrettyFG CabalSpecVersion -> b -> [PrettyField ()]
pp) = forall s a.
(CabalSpecVersion -> s -> [PrettyField ()])
-> PrettyFieldGrammar s a
PrettyFG (\CabalSpecVersion
v -> CabalSpecVersion -> b -> [PrettyField ()]
pp CabalSpecVersion
v forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s t a b. ALens s t a b -> s -> a
aview ALens' a b
f)

    uniqueFieldAla :: forall b a s.
(Pretty b, Newtype a b) =>
FieldName -> (a -> b) -> ALens' s a -> PrettyFieldGrammar s a
uniqueFieldAla FieldName
fn a -> b
_pack ALens' s a
l = forall s a.
(CabalSpecVersion -> s -> [PrettyField ()])
-> PrettyFieldGrammar s a
PrettyFG forall a b. (a -> b) -> a -> b
$ \CabalSpecVersion
_v s
s ->
        FieldName -> Doc -> [PrettyField ()]
ppField FieldName
fn (forall a. Pretty a => a -> Doc
pretty (forall o n. Newtype o n => (o -> n) -> o -> n
pack' a -> b
_pack (forall s t a b. ALens s t a b -> s -> a
aview ALens' s a
l s
s)))

    booleanFieldDef :: forall s.
FieldName -> ALens' s Bool -> Bool -> PrettyFieldGrammar s Bool
booleanFieldDef FieldName
fn ALens' s Bool
l Bool
def = forall s a.
(CabalSpecVersion -> s -> [PrettyField ()])
-> PrettyFieldGrammar s a
PrettyFG forall {p}. p -> s -> [PrettyField ()]
pp
      where
        pp :: p -> s -> [PrettyField ()]
pp p
_v s
s
            | Bool
b forall a. Eq a => a -> a -> Bool
== Bool
def  = forall a. Monoid a => a
mempty
            | Bool
otherwise = FieldName -> Doc -> [PrettyField ()]
ppField FieldName
fn (String -> Doc
PP.text (forall a. Show a => a -> String
show Bool
b))
          where
            b :: Bool
b = forall s t a b. ALens s t a b -> s -> a
aview ALens' s Bool
l s
s

    optionalFieldAla :: forall b a s.
(Pretty b, Newtype a b) =>
FieldName
-> (a -> b) -> ALens' s (Maybe a) -> PrettyFieldGrammar s (Maybe a)
optionalFieldAla FieldName
fn a -> b
_pack ALens' s (Maybe a)
l = forall s a.
(CabalSpecVersion -> s -> [PrettyField ()])
-> PrettyFieldGrammar s a
PrettyFG CabalSpecVersion -> s -> [PrettyField ()]
pp
      where
        pp :: CabalSpecVersion -> s -> [PrettyField ()]
pp CabalSpecVersion
v s
s = case forall s t a b. ALens s t a b -> s -> a
aview ALens' s (Maybe a)
l s
s of
            Maybe a
Nothing -> forall a. Monoid a => a
mempty
            Just a
a  -> FieldName -> Doc -> [PrettyField ()]
ppField FieldName
fn (forall a. Pretty a => CabalSpecVersion -> a -> Doc
prettyVersioned CabalSpecVersion
v (forall o n. Newtype o n => (o -> n) -> o -> n
pack' a -> b
_pack a
a))

    optionalFieldDefAla :: forall b a s.
(Pretty b, Newtype a b, Eq a) =>
FieldName -> (a -> b) -> ALens' s a -> a -> PrettyFieldGrammar s a
optionalFieldDefAla FieldName
fn a -> b
_pack ALens' s a
l a
def = forall s a.
(CabalSpecVersion -> s -> [PrettyField ()])
-> PrettyFieldGrammar s a
PrettyFG CabalSpecVersion -> s -> [PrettyField ()]
pp
      where
        pp :: CabalSpecVersion -> s -> [PrettyField ()]
pp CabalSpecVersion
v s
s
            | a
x forall a. Eq a => a -> a -> Bool
== a
def  = forall a. Monoid a => a
mempty
            | Bool
otherwise = FieldName -> Doc -> [PrettyField ()]
ppField FieldName
fn (forall a. Pretty a => CabalSpecVersion -> a -> Doc
prettyVersioned CabalSpecVersion
v (forall o n. Newtype o n => (o -> n) -> o -> n
pack' a -> b
_pack a
x))
          where
            x :: a
x = forall s t a b. ALens s t a b -> s -> a
aview ALens' s a
l s
s

    freeTextField :: forall s.
FieldName
-> ALens' s (Maybe String) -> PrettyFieldGrammar s (Maybe String)
freeTextField FieldName
fn ALens' s (Maybe String)
l = forall s a.
(CabalSpecVersion -> s -> [PrettyField ()])
-> PrettyFieldGrammar s a
PrettyFG CabalSpecVersion -> s -> [PrettyField ()]
pp where
        pp :: CabalSpecVersion -> s -> [PrettyField ()]
pp CabalSpecVersion
v s
s = forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall a. Monoid a => a
mempty (FieldName -> Doc -> [PrettyField ()]
ppField FieldName
fn forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Doc
showFT) (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 forall a. Ord a => a -> a -> Bool
>= CabalSpecVersion
CabalSpecV3_0 = String -> Doc
showFreeTextV3
                   | Bool
otherwise          = String -> Doc
showFreeText

    -- it's ok to just show, as showFreeText of empty string is empty.
    freeTextFieldDef :: forall s.
FieldName -> ALens' s String -> PrettyFieldGrammar s String
freeTextFieldDef FieldName
fn ALens' s String
l = forall s a.
(CabalSpecVersion -> s -> [PrettyField ()])
-> PrettyFieldGrammar s a
PrettyFG CabalSpecVersion -> s -> [PrettyField ()]
pp where
        pp :: CabalSpecVersion -> s -> [PrettyField ()]
pp CabalSpecVersion
v s
s = FieldName -> Doc -> [PrettyField ()]
ppField FieldName
fn (String -> Doc
showFT (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 forall a. Ord a => a -> a -> Bool
>= CabalSpecVersion
CabalSpecV3_0 = String -> Doc
showFreeTextV3
                   | Bool
otherwise          = String -> Doc
showFreeText

    freeTextFieldDefST :: forall s.
FieldName -> ALens' s ShortText -> PrettyFieldGrammar s ShortText
freeTextFieldDefST = forall (g :: * -> * -> *) s (c :: * -> Constraint).
(Functor (g s), FieldGrammar c g) =>
FieldName -> ALens' s ShortText -> g s ShortText
defaultFreeTextFieldDefST

    monoidalFieldAla :: forall b a s.
(Pretty b, Monoid a, Newtype a b) =>
FieldName -> (a -> b) -> ALens' s a -> PrettyFieldGrammar s a
monoidalFieldAla FieldName
fn a -> b
_pack ALens' s a
l = forall s a.
(CabalSpecVersion -> s -> [PrettyField ()])
-> PrettyFieldGrammar s a
PrettyFG CabalSpecVersion -> s -> [PrettyField ()]
pp
      where
        pp :: CabalSpecVersion -> s -> [PrettyField ()]
pp CabalSpecVersion
v s
s = FieldName -> Doc -> [PrettyField ()]
ppField FieldName
fn (forall a. Pretty a => CabalSpecVersion -> a -> Doc
prettyVersioned CabalSpecVersion
v (forall o n. Newtype o n => (o -> n) -> o -> n
pack' a -> b
_pack (forall s t a b. ALens s t a b -> s -> a
aview ALens' s a
l s
s)))

    prefixedFields :: forall s.
FieldName
-> ALens' s [(String, String)]
-> PrettyFieldGrammar s [(String, String)]
prefixedFields FieldName
_fnPfx ALens' s [(String, String)]
l = forall s a.
(CabalSpecVersion -> s -> [PrettyField ()])
-> PrettyFieldGrammar s a
PrettyFG (\CabalSpecVersion
_ -> [(String, String)] -> [PrettyField ()]
pp forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s t a b. ALens s t a b -> s -> a
aview ALens' s [(String, String)]
l)
      where
        pp :: [(String, String)] -> [PrettyField ()]
pp [(String, String)]
xs =
            -- always print the field, even its Doc is empty.
            -- i.e. don't use ppField
            [ forall ann. ann -> FieldName -> Doc -> PrettyField ann
PrettyField () (String -> FieldName
toUTF8BS String
n) forall a b. (a -> b) -> a -> b
$ [Doc] -> Doc
PP.vcat forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map String -> Doc
PP.text forall a b. (a -> b) -> a -> b
$ String -> [String]
lines String
s
            | (String
n, String
s) <- [(String, String)]
xs
            -- fnPfx `isPrefixOf` n
            ]

    knownField :: forall s. FieldName -> PrettyFieldGrammar s ()
knownField FieldName
_           = forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    deprecatedSince :: forall s a.
CabalSpecVersion
-> String -> PrettyFieldGrammar s a -> PrettyFieldGrammar s a
deprecatedSince CabalSpecVersion
_ String
_ PrettyFieldGrammar s a
x  = PrettyFieldGrammar s a
x
    -- TODO: as PrettyFieldGrammar isn't aware of cabal-version: we output the field
    -- this doesn't affect roundtrip as `removedIn` fields cannot be parsed
    -- so invalid documents can be only manually constructed.
    removedIn :: forall s a.
CabalSpecVersion
-> String -> PrettyFieldGrammar s a -> PrettyFieldGrammar s a
removedIn CabalSpecVersion
_ String
_ PrettyFieldGrammar s a
x        = PrettyFieldGrammar s a
x
    availableSince :: forall a s.
CabalSpecVersion
-> a -> PrettyFieldGrammar s a -> PrettyFieldGrammar s a
availableSince CabalSpecVersion
_ a
_     = forall a. a -> a
id
    hiddenField :: forall s a. PrettyFieldGrammar s a -> PrettyFieldGrammar s a
hiddenField PrettyFieldGrammar s a
_          = forall s a.
(CabalSpecVersion -> s -> [PrettyField ()])
-> PrettyFieldGrammar s a
PrettyFG (\CabalSpecVersion
_ -> forall a. Monoid a => a
mempty)

ppField :: FieldName -> Doc -> [PrettyField ()]
ppField :: FieldName -> Doc -> [PrettyField ()]
ppField FieldName
name Doc
fielddoc
    | Doc -> Bool
PP.isEmpty Doc
fielddoc = []
    | Bool
otherwise        = [ forall ann. ann -> FieldName -> Doc -> PrettyField ann
PrettyField () FieldName
name Doc
fielddoc ]