{-# 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 -> b) -> PrettyField a -> PrettyField b)
-> (forall a b. a -> PrettyField b -> PrettyField a)
-> Functor PrettyField
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
$cfmap :: forall a b. (a -> b) -> PrettyField a -> PrettyField b
fmap :: forall a b. (a -> b) -> PrettyField a -> PrettyField b
$c<$ :: forall a b. a -> PrettyField b -> PrettyField a
<$ :: forall a b. a -> PrettyField b -> PrettyField a
Functor, (forall m. Monoid m => PrettyField m -> m)
-> (forall m a. Monoid m => (a -> m) -> PrettyField a -> m)
-> (forall m a. Monoid m => (a -> m) -> PrettyField a -> m)
-> (forall a b. (a -> b -> b) -> b -> PrettyField a -> b)
-> (forall a b. (a -> b -> b) -> b -> PrettyField a -> b)
-> (forall b a. (b -> a -> b) -> b -> PrettyField a -> b)
-> (forall b a. (b -> a -> b) -> b -> PrettyField a -> b)
-> (forall a. (a -> a -> a) -> PrettyField a -> a)
-> (forall a. (a -> a -> a) -> PrettyField a -> a)
-> (forall a. PrettyField a -> [a])
-> (forall a. PrettyField a -> Bool)
-> (forall a. PrettyField a -> Int)
-> (forall a. Eq a => a -> PrettyField a -> Bool)
-> (forall a. Ord a => PrettyField a -> a)
-> (forall a. Ord a => PrettyField a -> a)
-> (forall a. Num a => PrettyField a -> a)
-> (forall a. Num a => PrettyField a -> a)
-> Foldable PrettyField
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
$cfold :: forall m. Monoid m => PrettyField m -> m
fold :: forall m. Monoid m => PrettyField m -> 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
foldMap' :: forall m a. Monoid m => (a -> m) -> PrettyField a -> m
$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
foldr' :: forall a b. (a -> b -> 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
foldl' :: forall b a. (b -> a -> b) -> b -> PrettyField a -> b
$cfoldr1 :: forall a. (a -> a -> a) -> PrettyField a -> a
foldr1 :: forall a. (a -> a -> a) -> PrettyField a -> a
$cfoldl1 :: forall a. (a -> a -> a) -> PrettyField a -> a
foldl1 :: forall a. (a -> a -> a) -> PrettyField a -> a
$ctoList :: forall a. PrettyField a -> [a]
toList :: forall a. PrettyField a -> [a]
$cnull :: forall a. PrettyField a -> Bool
null :: forall a. PrettyField a -> Bool
$clength :: forall a. PrettyField a -> Int
length :: forall a. PrettyField a -> Int
$celem :: forall a. Eq a => a -> PrettyField a -> Bool
elem :: forall a. Eq a => a -> PrettyField a -> Bool
$cmaximum :: forall a. Ord a => PrettyField a -> a
maximum :: forall a. Ord a => PrettyField a -> a
$cminimum :: forall a. Ord a => PrettyField a -> a
minimum :: forall a. Ord a => PrettyField a -> a
$csum :: forall a. Num a => PrettyField a -> a
sum :: forall a. Num a => PrettyField a -> a
$cproduct :: forall a. Num a => PrettyField a -> a
product :: forall a. Num a => PrettyField a -> a
Foldable, Functor PrettyField
Foldable PrettyField
Functor PrettyField
-> Foldable PrettyField
-> (forall (f :: * -> *) a b.
    Applicative f =>
    (a -> f b) -> PrettyField a -> f (PrettyField b))
-> (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 (m :: * -> *) a.
    Monad m =>
    PrettyField (m a) -> m (PrettyField a))
-> Traversable 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)
$ctraverse :: forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> PrettyField a -> f (PrettyField b)
traverse :: forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> PrettyField a -> f (PrettyField b)
$csequenceA :: forall (f :: * -> *) a.
Applicative f =>
PrettyField (f a) -> f (PrettyField a)
sequenceA :: forall (f :: * -> *) a.
Applicative f =>
PrettyField (f a) -> f (PrettyField a)
$cmapM :: forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> PrettyField a -> m (PrettyField b)
mapM :: forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> PrettyField a -> m (PrettyField b)
$csequence :: forall (m :: * -> *) a.
Monad m =>
PrettyField (m a) -> m (PrettyField a)
sequence :: forall (m :: * -> *) a.
Monad m =>
PrettyField (m a) -> m (PrettyField a)
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 = (ann -> CommentPosition)
-> (ann -> [String] -> [String])
-> Int
-> [PrettyField ann]
-> String
forall ann.
(ann -> CommentPosition)
-> (ann -> [String] -> [String])
-> Int
-> [PrettyField ann]
-> String
showFields' ann -> CommentPosition
rann (([String] -> [String]) -> ann -> [String] -> [String]
forall a b. a -> b -> a
const [String] -> [String]
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 ([String] -> String)
-> ([PrettyField ann] -> [String]) -> [PrettyField ann] -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Opts ann -> [PrettyField ann] -> [String]
forall ann. Opts ann -> [PrettyField ann] -> [String]
renderFields ((ann -> CommentPosition)
-> (String -> String) -> (ann -> [String] -> [String]) -> Opts ann
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 Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
4    = String -> String
indent4
           | Int
n Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
2    = String -> String
indent2
           | Bool
otherwise = (Int -> Char -> String
forall a. Int -> a -> [a]
replicate (Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
n Int
1) Char
' ' String -> String -> String
forall a. [a] -> [a] -> [a]
++)

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

    indent2 :: String -> String
    indent2 :: String -> String
indent2 [] = []
    indent2 String
xs = Char
' ' Char -> String -> String
forall a. a -> [a] -> [a]
: Char
' ' Char -> String -> String
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 = Int -> [PrettyField ann] -> Int
forall {ann}. Int -> [PrettyField ann] -> Int
maxNameLength Int
0 [PrettyField ann]
fields
    blocks :: [Block]
blocks = (Block -> Bool) -> [Block] -> [Block]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (Block -> Bool) -> Block -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ([String] -> Bool) -> (Block -> [String]) -> Block -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Block -> [String]
_contentsBlock) -- empty blocks cause extra newlines #8236
           ([Block] -> [Block]) -> [Block] -> [Block]
forall a b. (a -> b) -> a -> b
$ (PrettyField ann -> Block) -> [PrettyField ann] -> [Block]
forall a b. (a -> b) -> [a] -> [b]
map (Opts ann -> Int -> PrettyField ann -> Block
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 (Int -> Int -> Int
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
(Margin -> Margin -> Bool)
-> (Margin -> Margin -> Bool) -> Eq Margin
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Margin -> Margin -> Bool
== :: Margin -> Margin -> Bool
$c/= :: Margin -> Margin -> Bool
/= :: 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 [String] -> [String] -> [String]
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 ([String] -> [String]) -> [String] -> [String]
forall a b. (a -> b) -> a -> b
$ [String]
strs [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ Margin -> [Block] -> [String]
go Margin
after [Block]
blocks where
        ins :: [String] -> [String]
ins | Margin
surr' Margin -> Margin -> Margin
forall a. Semigroup a => a -> a -> a
<> Margin
before Margin -> Margin -> Bool
forall a. Eq a => a -> a -> Bool
== Margin
Margin = (String
"" String -> [String] -> [String]
forall a. a -> [a] -> [a]
:)
            | Bool
otherwise                 = [String] -> [String]
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 [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ ann -> [String] -> [String]
post ann
ann [String]
lines'
      CommentAfter  [String]
cs -> ann -> [String] -> [String]
post ann
ann [String]
lines' [String] -> [String] -> [String]
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' String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
":" ], Margin
NoMargin)
        [String
singleLine] | String -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
singleLine Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
60
                     -> ([ String
name' String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
": " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> Char -> String
forall a. Int -> a -> [a]
replicate (Int
fw Int -> Int -> Int
forall a. Num a => a -> a -> a
- String -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
name') Char
' ' String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
narrow ], Margin
NoMargin)
        [String]
_            -> ((String
name' String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
":") String -> [String] -> [String]
forall a. a -> [a] -> [a]
: (String -> String) -> [String] -> [String]
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 Int -> Int -> Int
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 ([String] -> Block) -> [String] -> Block
forall a b. (a -> b) -> a -> b
$
    
    [String] -> [String]
attachComments
      (ann -> [String] -> [String]
post ann
ann [ Doc -> String
PP.render (Doc -> String) -> Doc -> String
forall a b. (a -> b) -> a -> b
$ [Doc] -> Doc
PP.hsep ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$ String -> Doc
PP.text (FieldName -> String
fromUTF8BS FieldName
name) Doc -> [Doc] -> [Doc]
forall a. a -> [a] -> [a]
: [Doc]
args ])
    [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++
    (String -> String) -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map String -> String
indent (Opts ann -> [PrettyField ann] -> [String]
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 [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String]
content
      CommentAfter  [String]
cs -> [String]
content [String] -> [String] -> [String]
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 [String]
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 = (Field ann -> f (PrettyField ann))
-> [Field ann] -> f [PrettyField ann]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [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)          = ann -> FieldName -> Doc -> PrettyField ann
forall ann. ann -> FieldName -> Doc -> PrettyField ann
PrettyField ann
ann FieldName
name (Doc -> PrettyField ann) -> f Doc -> f (PrettyField ann)
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) = ann -> FieldName -> [Doc] -> [PrettyField ann] -> PrettyField ann
forall ann.
ann -> FieldName -> [Doc] -> [PrettyField ann] -> PrettyField ann
PrettySection ann
ann FieldName
name ([Doc] -> [PrettyField ann] -> PrettyField ann)
-> f [Doc] -> f ([PrettyField ann] -> PrettyField ann)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FieldName -> [SectionArg ann] -> f [Doc]
g FieldName
name [SectionArg ann]
secargs f ([PrettyField ann] -> PrettyField ann)
-> f [PrettyField ann] -> f (PrettyField ann)
forall a b. f (a -> b) -> f a -> f b
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 (String -> Doc) -> String -> Doc
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
_ = (SectionArg ann -> Doc) -> [SectionArg ann] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map ((SectionArg ann -> Doc) -> [SectionArg ann] -> [Doc])
-> (SectionArg ann -> Doc) -> [SectionArg ann] -> [Doc]
forall a b. (a -> b) -> a -> b
$ \case
    P.SecArgName ann
_ FieldName
bs  -> String -> Doc
showToken (String -> Doc) -> String -> Doc
forall a b. (a -> b) -> a -> b
$ FieldName -> String
fromUTF8BS FieldName
bs
    P.SecArgStr ann
_ FieldName
bs   -> String -> Doc
showToken (String -> Doc) -> String -> Doc
forall a b. (a -> b) -> a -> b
$ FieldName -> String
fromUTF8BS FieldName
bs
    P.SecArgOther ann
_ FieldName
bs -> String -> Doc
PP.text (String -> Doc) -> String -> Doc
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 = Identity [PrettyField ann] -> [PrettyField ann]
forall a. Identity a -> a
runIdentity (Identity [PrettyField ann] -> [PrettyField ann])
-> ([Field ann] -> Identity [PrettyField ann])
-> [Field ann]
-> [PrettyField ann]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (FieldName -> [FieldLine ann] -> Identity Doc)
-> (FieldName -> [SectionArg ann] -> Identity [Doc])
-> [Field ann]
-> Identity [PrettyField ann]
forall (f :: * -> *) ann.
Applicative f =>
(FieldName -> [FieldLine ann] -> f Doc)
-> (FieldName -> [SectionArg ann] -> f [Doc])
-> [Field ann]
-> f [PrettyField ann]
genericFromParsecFields
    (Doc -> Identity Doc
forall a. a -> Identity a
Identity (Doc -> Identity Doc)
-> (FieldName -> [FieldLine ann] -> Doc)
-> FieldName
-> [FieldLine ann]
-> Identity Doc
forall a b c d. (a -> b) -> (c -> d -> a) -> c -> d -> b
.: FieldName -> [FieldLine ann] -> Doc
forall ann. FieldName -> [FieldLine ann] -> Doc
prettyFieldLines)
    ([Doc] -> Identity [Doc]
forall a. a -> Identity a
Identity ([Doc] -> Identity [Doc])
-> (FieldName -> [SectionArg ann] -> [Doc])
-> FieldName
-> [SectionArg ann]
-> Identity [Doc]
forall a b c d. (a -> b) -> (c -> d -> a) -> c -> d -> b
.: FieldName -> [SectionArg ann] -> [Doc]
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)