{-# 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.Utils.Generic (toUTF8BS)
import Text.PrettyPrint (Doc)
import qualified Text.PrettyPrint as PP
import Prelude ()

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 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
$cfmap :: forall s a b.
(a -> b) -> PrettyFieldGrammar s a -> PrettyFieldGrammar s b
fmap :: forall a b.
(a -> b) -> PrettyFieldGrammar s a -> PrettyFieldGrammar s b
$c<$ :: forall s a b. a -> PrettyFieldGrammar s b -> PrettyFieldGrammar s a
<$ :: forall a b. a -> PrettyFieldGrammar s b -> PrettyFieldGrammar s a
Functor)

instance Applicative (PrettyFieldGrammar s) where
  pure :: forall a. a -> PrettyFieldGrammar s a
pure a
_ = (CabalSpecVersion -> s -> [PrettyField ()])
-> PrettyFieldGrammar s a
forall s a.
(CabalSpecVersion -> s -> [PrettyField ()])
-> PrettyFieldGrammar s a
PrettyFG (\CabalSpecVersion
_ s
_ -> [PrettyField ()]
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 = (CabalSpecVersion -> s -> [PrettyField ()])
-> PrettyFieldGrammar s b
forall s a.
(CabalSpecVersion -> s -> [PrettyField ()])
-> PrettyFieldGrammar s a
PrettyFG (\CabalSpecVersion
v 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)

-- | 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 = (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 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) = (CabalSpecVersion -> a -> [PrettyField ()])
-> PrettyFieldGrammar a d
forall s a.
(CabalSpecVersion -> s -> [PrettyField ()])
-> PrettyFieldGrammar s a
PrettyFG (\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 :: 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 = (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
$ \CabalSpecVersion
_v 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 :: forall s.
FieldName -> ALens' s Bool -> Bool -> PrettyFieldGrammar s Bool
booleanFieldDef FieldName
fn ALens' s Bool
l 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 p
_v 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 :: 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 = (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 CabalSpecVersion
v 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
        Maybe a
Nothing -> [PrettyField ()]
forall a. Monoid a => a
mempty
        Just 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 :: 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 = (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 CabalSpecVersion
v 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 :: forall s.
FieldName
-> ALens' s (Maybe String) -> PrettyFieldGrammar s (Maybe String)
freeTextField FieldName
fn 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 CabalSpecVersion
v 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

  -- 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 = (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 CabalSpecVersion
v 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

  freeTextFieldDefST :: forall s.
FieldName -> ALens' s ShortText -> PrettyFieldGrammar s ShortText
freeTextFieldDefST = FieldName -> ALens' s ShortText -> PrettyFieldGrammar s ShortText
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 = (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 CabalSpecVersion
v 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 :: forall s.
FieldName
-> ALens' s [(String, String)]
-> PrettyFieldGrammar s [(String, String)]
prefixedFields FieldName
_fnPfx ALens' s [(String, String)]
l = (CabalSpecVersion -> s -> [PrettyField ()])
-> PrettyFieldGrammar s [(String, String)]
forall s a.
(CabalSpecVersion -> s -> [PrettyField ()])
-> PrettyFieldGrammar s a
PrettyFG (\CabalSpecVersion
_ -> [(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 [(String, String)]
xs =
        -- always print the field, even its Doc is empty.
        -- i.e. don't use ppField
        [ () -> 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
        | (String
n, String
s) <- [(String, String)]
xs
        -- fnPfx `isPrefixOf` n
        ]

  knownField :: forall s. FieldName -> PrettyFieldGrammar s ()
knownField FieldName
_ = () -> PrettyFieldGrammar s ()
forall a. a -> PrettyFieldGrammar s a
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
_ = PrettyFieldGrammar s a -> PrettyFieldGrammar s a
forall a. a -> a
id
  hiddenField :: forall s a. PrettyFieldGrammar s a -> PrettyFieldGrammar s a
hiddenField PrettyFieldGrammar s a
_ = (CabalSpecVersion -> s -> [PrettyField ()])
-> PrettyFieldGrammar s a
forall s a.
(CabalSpecVersion -> s -> [PrettyField ()])
-> PrettyFieldGrammar s a
PrettyFG (\CabalSpecVersion
_ -> s -> [PrettyField ()]
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 = [() -> FieldName -> Doc -> PrettyField ()
forall ann. ann -> FieldName -> Doc -> PrettyField ann
PrettyField () FieldName
name Doc
fielddoc]