{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE DeriveFoldable #-}
{-# LANGUAGE DeriveTraversable #-}
{-# LANGUAGE LambdaCase #-}
-- | Cabal-like file AST types: 'Field', 'Section' etc,
--
-- This (intermediate) data type is used for pretty-printing.
--
-- @since 3.0.0.0
--
module Distribution.Fields.Pretty (
    -- * Fields
    CommentPosition (..),
    PrettyField (..),
    showFields,
    showFields',
    -- * Transformation from 'P.Field'
    fromParsecFields,
    genericFromParsecFields,
    prettyFieldLines,
    prettySectionArgs,
    ) where

import Distribution.Compat.Prelude
import Distribution.Pretty         (showToken)
import Prelude ()

import Distribution.Fields.Field   (FieldName)
import Distribution.Utils.Generic  (fromUTF8BS)

import qualified Distribution.Fields.Parser as P

import qualified Data.ByteString  as BS
import qualified Text.PrettyPrint as PP

-- | This type is used to discern when a comment block should go
--   before or after a cabal-like file field, otherwise it would
--   be hardcoded to a single position. It is often used in
--   conjunction with @PrettyField@.
data CommentPosition = CommentBefore [String] | CommentAfter [String] | NoComment

data PrettyField ann
    = PrettyField ann FieldName PP.Doc
    | PrettySection ann FieldName [PP.Doc] [PrettyField ann]
    | PrettyEmpty
  deriving (forall a b. a -> PrettyField b -> PrettyField a
forall a b. (a -> b) -> PrettyField a -> PrettyField 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 -> PrettyField b -> PrettyField a
$c<$ :: forall a b. a -> PrettyField b -> PrettyField a
fmap :: forall a b. (a -> b) -> PrettyField a -> PrettyField b
$cfmap :: forall a b. (a -> b) -> PrettyField a -> PrettyField b
Functor, forall a. Eq a => a -> PrettyField a -> Bool
forall a. Num a => PrettyField a -> a
forall a. Ord a => PrettyField a -> a
forall m. Monoid m => PrettyField m -> m
forall a. PrettyField a -> Bool
forall a. PrettyField a -> Int
forall a. PrettyField a -> [a]
forall a. (a -> a -> a) -> PrettyField a -> a
forall m a. Monoid m => (a -> m) -> PrettyField a -> m
forall b a. (b -> a -> b) -> b -> PrettyField a -> b
forall a b. (a -> b -> b) -> b -> PrettyField a -> b
forall (t :: * -> *).
(forall m. Monoid m => t m -> m)
-> (forall m a. Monoid m => (a -> m) -> t a -> m)
-> (forall m a. Monoid m => (a -> m) -> t a -> m)
-> (forall a b. (a -> b -> b) -> b -> t a -> b)
-> (forall a b. (a -> b -> b) -> b -> t a -> b)
-> (forall b a. (b -> a -> b) -> b -> t a -> b)
-> (forall b a. (b -> a -> b) -> b -> t a -> b)
-> (forall a. (a -> a -> a) -> t a -> a)
-> (forall a. (a -> a -> a) -> t a -> a)
-> (forall a. t a -> [a])
-> (forall a. t a -> Bool)
-> (forall a. t a -> Int)
-> (forall a. Eq a => a -> t a -> Bool)
-> (forall a. Ord a => t a -> a)
-> (forall a. Ord a => t a -> a)
-> (forall a. Num a => t a -> a)
-> (forall a. Num a => t a -> a)
-> Foldable t
product :: forall a. Num a => PrettyField a -> a
$cproduct :: forall a. Num a => PrettyField a -> a
sum :: forall a. Num a => PrettyField a -> a
$csum :: forall a. Num a => PrettyField a -> a
minimum :: forall a. Ord a => PrettyField a -> a
$cminimum :: forall a. Ord a => PrettyField a -> a
maximum :: forall a. Ord a => PrettyField a -> a
$cmaximum :: forall a. Ord a => PrettyField a -> a
elem :: forall a. Eq a => a -> PrettyField a -> Bool
$celem :: forall a. Eq a => a -> PrettyField a -> Bool
length :: forall a. PrettyField a -> Int
$clength :: forall a. PrettyField a -> Int
null :: forall a. PrettyField a -> Bool
$cnull :: forall a. PrettyField a -> Bool
toList :: forall a. PrettyField a -> [a]
$ctoList :: forall a. PrettyField a -> [a]
foldl1 :: forall a. (a -> a -> a) -> PrettyField a -> a
$cfoldl1 :: forall a. (a -> a -> a) -> PrettyField a -> a
foldr1 :: forall a. (a -> a -> a) -> PrettyField a -> a
$cfoldr1 :: forall a. (a -> a -> a) -> PrettyField a -> a
foldl' :: forall b a. (b -> a -> b) -> b -> PrettyField a -> b
$cfoldl' :: forall b a. (b -> a -> b) -> b -> PrettyField a -> b
foldl :: forall b a. (b -> a -> b) -> b -> PrettyField a -> b
$cfoldl :: forall b a. (b -> a -> b) -> b -> PrettyField a -> b
foldr' :: forall a b. (a -> b -> b) -> b -> PrettyField a -> b
$cfoldr' :: forall a b. (a -> b -> b) -> b -> PrettyField a -> b
foldr :: forall a b. (a -> b -> b) -> b -> PrettyField a -> b
$cfoldr :: forall a b. (a -> b -> b) -> b -> PrettyField a -> b
foldMap' :: forall m a. Monoid m => (a -> m) -> PrettyField a -> m
$cfoldMap' :: forall m a. Monoid m => (a -> m) -> PrettyField a -> m
foldMap :: forall m a. Monoid m => (a -> m) -> PrettyField a -> m
$cfoldMap :: forall m a. Monoid m => (a -> m) -> PrettyField a -> m
fold :: forall m. Monoid m => PrettyField m -> m
$cfold :: forall m. Monoid m => PrettyField m -> m
Foldable, Functor PrettyField
Foldable PrettyField
forall (t :: * -> *).
Functor t
-> Foldable t
-> (forall (f :: * -> *) a b.
    Applicative f =>
    (a -> f b) -> t a -> f (t b))
-> (forall (f :: * -> *) a. Applicative f => t (f a) -> f (t a))
-> (forall (m :: * -> *) a b.
    Monad m =>
    (a -> m b) -> t a -> m (t b))
-> (forall (m :: * -> *) a. Monad m => t (m a) -> m (t a))
-> Traversable t
forall (m :: * -> *) a.
Monad m =>
PrettyField (m a) -> m (PrettyField a)
forall (f :: * -> *) a.
Applicative f =>
PrettyField (f a) -> f (PrettyField a)
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> PrettyField a -> m (PrettyField b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> PrettyField a -> f (PrettyField b)
sequence :: forall (m :: * -> *) a.
Monad m =>
PrettyField (m a) -> m (PrettyField a)
$csequence :: forall (m :: * -> *) a.
Monad m =>
PrettyField (m a) -> m (PrettyField a)
mapM :: forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> PrettyField a -> m (PrettyField b)
$cmapM :: forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> PrettyField a -> m (PrettyField b)
sequenceA :: forall (f :: * -> *) a.
Applicative f =>
PrettyField (f a) -> f (PrettyField a)
$csequenceA :: forall (f :: * -> *) a.
Applicative f =>
PrettyField (f a) -> f (PrettyField a)
traverse :: forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> PrettyField a -> f (PrettyField b)
$ctraverse :: forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> PrettyField a -> f (PrettyField b)
Traversable)

-- | Prettyprint a list of fields.
--
-- Note: the first argument should return 'String's without newlines
-- and properly prefixes (with @--@) to count as comments.
-- This unsafety is left in place so one could generate empty lines
-- between comment lines.
--
showFields :: (ann -> CommentPosition) -> [PrettyField ann] -> String
showFields :: forall ann. (ann -> CommentPosition) -> [PrettyField ann] -> String
showFields ann -> CommentPosition
rann = forall ann.
(ann -> CommentPosition)
-> (ann -> [String] -> [String])
-> Int
-> [PrettyField ann]
-> String
showFields' ann -> CommentPosition
rann (forall a b. a -> b -> a
const forall a. a -> a
id) Int
4

-- | 'showFields' with user specified indentation.
showFields'
  :: (ann -> CommentPosition)
     -- ^ Convert an annotation to lined to preceed the field or section.
  -> (ann -> [String] -> [String])
     -- ^ Post-process non-annotation produced lines.
  -> Int
     -- ^ Indentation level.
  -> [PrettyField ann]
     -- ^ Fields/sections to show.
  -> String
showFields' :: forall ann.
(ann -> CommentPosition)
-> (ann -> [String] -> [String])
-> Int
-> [PrettyField ann]
-> String
showFields' ann -> CommentPosition
rann ann -> [String] -> [String]
post Int
n = [String] -> String
unlines forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall ann. Opts ann -> [PrettyField ann] -> [String]
renderFields (forall ann.
(ann -> CommentPosition)
-> (String -> String) -> (ann -> [String] -> [String]) -> Opts ann
Opts ann -> CommentPosition
rann String -> String
indent ann -> [String] -> [String]
post)
  where
    -- few hardcoded, "unrolled"  variants.
    indent :: String -> String
indent | Int
n forall a. Eq a => a -> a -> Bool
== Int
4    = String -> String
indent4
           | Int
n forall a. Eq a => a -> a -> Bool
== Int
2    = String -> String
indent2
           | Bool
otherwise = (forall a. Int -> a -> [a]
replicate (forall a. Ord a => a -> a -> a
max Int
n Int
1) Char
' ' forall a. [a] -> [a] -> [a]
++)

    indent4 :: String -> String
    indent4 :: String -> String
indent4 [] = []
    indent4 String
xs = Char
' ' forall a. a -> [a] -> [a]
: Char
' ' forall a. a -> [a] -> [a]
: Char
' ' forall a. a -> [a] -> [a]
: Char
' ' forall a. a -> [a] -> [a]
: String
xs

    indent2 :: String -> String
    indent2 :: String -> String
indent2 [] = []
    indent2 String
xs = Char
' ' forall a. a -> [a] -> [a]
: Char
' ' forall a. a -> [a] -> [a]
: String
xs

data Opts ann = Opts
  { forall ann. Opts ann -> ann -> CommentPosition
_optAnnotation :: ann -> CommentPosition
  , forall ann. Opts ann -> String -> String
_optIndent :: String -> String
  , forall ann. Opts ann -> ann -> [String] -> [String]
_optPostprocess :: ann -> [String] -> [String]
  }

renderFields :: Opts ann -> [PrettyField ann] -> [String]
renderFields :: forall ann. Opts ann -> [PrettyField ann] -> [String]
renderFields Opts ann
opts [PrettyField ann]
fields = [Block] -> [String]
flattenBlocks [Block]
blocks
  where
    len :: Int
len = forall {ann}. Int -> [PrettyField ann] -> Int
maxNameLength Int
0 [PrettyField ann]
fields
    blocks :: [Block]
blocks = forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => t a -> Bool
null forall b c a. (b -> c) -> (a -> b) -> a -> c
. Block -> [String]
_contentsBlock) -- empty blocks cause extra newlines #8236
           forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (forall ann. Opts ann -> Int -> PrettyField ann -> Block
renderField Opts ann
opts Int
len) [PrettyField ann]
fields

    maxNameLength :: Int -> [PrettyField ann] -> Int
maxNameLength !Int
acc []                            = Int
acc
    maxNameLength !Int
acc (PrettyField ann
_ FieldName
name Doc
_ : [PrettyField ann]
rest) = Int -> [PrettyField ann] -> Int
maxNameLength (forall a. Ord a => a -> a -> a
max Int
acc (FieldName -> Int
BS.length FieldName
name)) [PrettyField ann]
rest
    maxNameLength !Int
acc (PrettySection {}   : [PrettyField ann]
rest)   = Int -> [PrettyField ann] -> Int
maxNameLength Int
acc [PrettyField ann]
rest
    maxNameLength !Int
acc (PrettyField ann
PrettyEmpty : [PrettyField ann]
rest) = Int -> [PrettyField ann] -> Int
maxNameLength Int
acc [PrettyField ann]
rest

-- | Block of lines with flags for optional blank lines before and after
data Block = Block
  { Block -> Margin
_beforeBlock   :: Margin
  , Block -> Margin
_afterBlock    :: Margin
  , Block -> [String]
_contentsBlock :: [String]
  }

data Margin = Margin | NoMargin
  deriving Margin -> Margin -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Margin -> Margin -> Bool
$c/= :: Margin -> Margin -> Bool
== :: Margin -> Margin -> Bool
$c== :: Margin -> Margin -> Bool
Eq

-- | Collapse margins, any margin = margin
instance Semigroup Margin where
    Margin
NoMargin <> :: Margin -> Margin -> Margin
<> Margin
NoMargin = Margin
NoMargin
    Margin
_        <> Margin
_        = Margin
Margin

flattenBlocks :: [Block] -> [String]
flattenBlocks :: [Block] -> [String]
flattenBlocks = [Block] -> [String]
go0 where
    go0 :: [Block] -> [String]
go0 [] = []
    go0 (Block Margin
_before Margin
after [String]
strs : [Block]
blocks) = [String]
strs forall a. [a] -> [a] -> [a]
++ Margin -> [Block] -> [String]
go Margin
after [Block]
blocks

    go :: Margin -> [Block] -> [String]
go Margin
_surr' [] = []
    go  Margin
surr' (Block Margin
before Margin
after [String]
strs : [Block]
blocks) = [String] -> [String]
ins forall a b. (a -> b) -> a -> b
$ [String]
strs forall a. [a] -> [a] -> [a]
++ Margin -> [Block] -> [String]
go Margin
after [Block]
blocks where
        ins :: [String] -> [String]
ins | Margin
surr' forall a. Semigroup a => a -> a -> a
<> Margin
before forall a. Eq a => a -> a -> Bool
== Margin
Margin = (String
"" forall a. a -> [a] -> [a]
:)
            | Bool
otherwise                 = forall a. a -> a
id

renderField :: Opts ann -> Int -> PrettyField ann -> Block
renderField :: forall ann. Opts ann -> Int -> PrettyField ann -> Block
renderField (Opts ann -> CommentPosition
rann String -> String
indent ann -> [String] -> [String]
post) Int
fw (PrettyField ann
ann FieldName
name Doc
doc) =
    Margin -> Margin -> [String] -> Block
Block Margin
before Margin
after [String]
content
  where
    content :: [String]
content = case CommentPosition
comments of
      CommentBefore [String]
cs -> [String]
cs forall a. [a] -> [a] -> [a]
++ ann -> [String] -> [String]
post ann
ann [String]
lines'
      CommentAfter  [String]
cs -> ann -> [String] -> [String]
post ann
ann [String]
lines' forall a. [a] -> [a] -> [a]
++ [String]
cs
      CommentPosition
NoComment        -> ann -> [String] -> [String]
post ann
ann [String]
lines'
    comments :: CommentPosition
comments = ann -> CommentPosition
rann ann
ann
    before :: Margin
before = case CommentPosition
comments of
      CommentBefore [] -> Margin
NoMargin
      CommentAfter  [] -> Margin
NoMargin
      CommentPosition
NoComment        -> Margin
NoMargin
      CommentPosition
_                -> Margin
Margin

    ([String]
lines', Margin
after) = case String -> [String]
lines String
narrow of
        []           -> ([ String
name' forall a. [a] -> [a] -> [a]
++ String
":" ], Margin
NoMargin)
        [String
singleLine] | forall (t :: * -> *) a. Foldable t => t a -> Int
length String
singleLine forall a. Ord a => a -> a -> Bool
< Int
60
                     -> ([ String
name' forall a. [a] -> [a] -> [a]
++ String
": " forall a. [a] -> [a] -> [a]
++ forall a. Int -> a -> [a]
replicate (Int
fw forall a. Num a => a -> a -> a
- forall (t :: * -> *) a. Foldable t => t a -> Int
length String
name') Char
' ' forall a. [a] -> [a] -> [a]
++ String
narrow ], Margin
NoMargin)
        [String]
_            -> ((String
name' forall a. [a] -> [a] -> [a]
++ String
":") forall a. a -> [a] -> [a]
: forall a b. (a -> b) -> [a] -> [b]
map String -> String
indent (String -> [String]
lines (Doc -> String
PP.render Doc
doc)), Margin
Margin)

    name' :: String
name' = FieldName -> String
fromUTF8BS FieldName
name
    narrow :: String
narrow = Style -> Doc -> String
PP.renderStyle Style
narrowStyle Doc
doc

    narrowStyle :: PP.Style
    narrowStyle :: Style
narrowStyle = Style
PP.style { lineLength :: Int
PP.lineLength = Style -> Int
PP.lineLength Style
PP.style forall a. Num a => a -> a -> a
- Int
fw }

renderField opts :: Opts ann
opts@(Opts ann -> CommentPosition
rann String -> String
indent ann -> [String] -> [String]
post) Int
_ (PrettySection ann
ann FieldName
name [Doc]
args [PrettyField ann]
fields) = Margin -> Margin -> [String] -> Block
Block Margin
Margin Margin
Margin forall a b. (a -> b) -> a -> b
$

    [String] -> [String]
attachComments
      (ann -> [String] -> [String]
post ann
ann [ Doc -> String
PP.render forall a b. (a -> b) -> a -> b
$ [Doc] -> Doc
PP.hsep forall a b. (a -> b) -> a -> b
$ String -> Doc
PP.text (FieldName -> String
fromUTF8BS FieldName
name) forall a. a -> [a] -> [a]
: [Doc]
args ])
    forall a. [a] -> [a] -> [a]
++
    forall a b. (a -> b) -> [a] -> [b]
map String -> String
indent (forall ann. Opts ann -> [PrettyField ann] -> [String]
renderFields Opts ann
opts [PrettyField ann]
fields)
  where
    attachComments :: [String] -> [String]
attachComments [String]
content = case ann -> CommentPosition
rann ann
ann of
      CommentBefore [String]
cs -> [String]
cs forall a. [a] -> [a] -> [a]
++ [String]
content
      CommentAfter  [String]
cs -> [String]
content forall a. [a] -> [a] -> [a]
++ [String]
cs
      CommentPosition
NoComment        -> [String]
content

renderField Opts ann
_ Int
_ PrettyField ann
PrettyEmpty = Margin -> Margin -> [String] -> Block
Block Margin
NoMargin Margin
NoMargin forall a. Monoid a => a
mempty

-------------------------------------------------------------------------------
-- Transform from Parsec.Field
-------------------------------------------------------------------------------

genericFromParsecFields
    :: Applicative f
    => (FieldName -> [P.FieldLine ann] -> f PP.Doc)     -- ^ transform field contents
    -> (FieldName -> [P.SectionArg ann] -> f [PP.Doc])  -- ^ transform section arguments
    -> [P.Field ann]
    -> f [PrettyField ann]
genericFromParsecFields :: forall (f :: * -> *) ann.
Applicative f =>
(FieldName -> [FieldLine ann] -> f Doc)
-> (FieldName -> [SectionArg ann] -> f [Doc])
-> [Field ann]
-> f [PrettyField ann]
genericFromParsecFields FieldName -> [FieldLine ann] -> f Doc
f FieldName -> [SectionArg ann] -> f [Doc]
g = [Field ann] -> f [PrettyField ann]
goMany where
    goMany :: [Field ann] -> f [PrettyField ann]
goMany = forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse Field ann -> f (PrettyField ann)
go

    go :: Field ann -> f (PrettyField ann)
go (P.Field (P.Name ann
ann FieldName
name) [FieldLine ann]
fls)          = forall ann. ann -> FieldName -> Doc -> PrettyField ann
PrettyField ann
ann FieldName
name forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FieldName -> [FieldLine ann] -> f Doc
f FieldName
name [FieldLine ann]
fls
    go (P.Section (P.Name ann
ann FieldName
name) [SectionArg ann]
secargs [Field ann]
fs) = forall ann.
ann -> FieldName -> [Doc] -> [PrettyField ann] -> PrettyField ann
PrettySection ann
ann FieldName
name forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FieldName -> [SectionArg ann] -> f [Doc]
g FieldName
name [SectionArg ann]
secargs forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> [Field ann] -> f [PrettyField ann]
goMany [Field ann]
fs

-- | Used in 'fromParsecFields'.
prettyFieldLines :: FieldName -> [P.FieldLine ann] -> PP.Doc
prettyFieldLines :: forall ann. FieldName -> [FieldLine ann] -> Doc
prettyFieldLines FieldName
_ [FieldLine ann]
fls = [Doc] -> Doc
PP.vcat
    [ String -> Doc
PP.text forall a b. (a -> b) -> a -> b
$ FieldName -> String
fromUTF8BS FieldName
bs
    | P.FieldLine ann
_ FieldName
bs <- [FieldLine ann]
fls
    ]

-- | Used in 'fromParsecFields'.
prettySectionArgs :: FieldName -> [P.SectionArg ann] -> [PP.Doc]
prettySectionArgs :: forall ann. FieldName -> [SectionArg ann] -> [Doc]
prettySectionArgs FieldName
_ = forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a -> b) -> a -> b
$ \case
    P.SecArgName ann
_ FieldName
bs  -> String -> Doc
showToken forall a b. (a -> b) -> a -> b
$ FieldName -> String
fromUTF8BS FieldName
bs
    P.SecArgStr ann
_ FieldName
bs   -> String -> Doc
showToken forall a b. (a -> b) -> a -> b
$ FieldName -> String
fromUTF8BS FieldName
bs
    P.SecArgOther ann
_ FieldName
bs -> String -> Doc
PP.text forall a b. (a -> b) -> a -> b
$ FieldName -> String
fromUTF8BS FieldName
bs

-- | Simple variant of 'genericFromParsecField'
fromParsecFields :: [P.Field ann] -> [PrettyField ann]
fromParsecFields :: forall ann. [Field ann] -> [PrettyField ann]
fromParsecFields = forall a. Identity a -> a
runIdentity forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) ann.
Applicative f =>
(FieldName -> [FieldLine ann] -> f Doc)
-> (FieldName -> [SectionArg ann] -> f [Doc])
-> [Field ann]
-> f [PrettyField ann]
genericFromParsecFields
    (forall a. a -> Identity a
Identity forall a b c d. (a -> b) -> (c -> d -> a) -> c -> d -> b
.: forall ann. FieldName -> [FieldLine ann] -> Doc
prettyFieldLines)
    (forall a. a -> Identity a
Identity forall a b c d. (a -> b) -> (c -> d -> a) -> c -> d -> b
.: forall ann. FieldName -> [SectionArg ann] -> [Doc]
prettySectionArgs)
  where
    (.:) :: (a -> b) -> (c -> d -> a) -> (c -> d -> b)
    (a -> b
f .: :: forall a b c d. (a -> b) -> (c -> d -> a) -> c -> d -> b
.: c -> d -> a
g) c
x d
y = a -> b
f (c -> d -> a
g c
x d
y)