{-# 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)

-- | We can use 'PrettyFieldGrammar' to pp print the @s@.
--
-- /Note:/ there is not trailing @($+$ text "")@.
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 =
            -- always print the field, even its Doc is empty.
            -- i.e. don't use ppField
            [ 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
            -- fnPfx `isPrefixOf` n
            ]

    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
    -- 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 :: 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 ]