{-# LANGUAGE BangPatterns #-}
-- | 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
    PrettyField (..),
    showFields,
    showFields',
    -- * Transformation from 'P.Field'
    fromParsecFields,
    genericFromParsecFields,
    prettyFieldLines,
    prettySectionArgs,
    ) where

import Data.Functor.Identity       (Identity (..))
import Distribution.Compat.Prelude
import Distribution.Pretty         (showToken)
import Prelude ()

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

import qualified Distribution.Fields.Parser as P

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

data PrettyField
    = PrettyField FieldName PP.Doc
    | PrettySection FieldName [PP.Doc] [PrettyField]

-- | Prettyprint a list of fields.
showFields :: [PrettyField] -> String
showFields :: [PrettyField] -> String
showFields = Int -> [PrettyField] -> String
showFields' 4

-- | 'showFields' with user specified indentation.
showFields' :: Int -> [PrettyField] -> String
showFields' :: Int -> [PrettyField] -> String
showFields' n :: Int
n = [String] -> String
unlines ([String] -> String)
-> ([PrettyField] -> [String]) -> [PrettyField] -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> String) -> [PrettyField] -> [String]
renderFields String -> String
indent where
    -- few hardcoded, "unrolled"  variants.
    indent :: String -> String
indent | Int
n Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== 4    = String -> String
indent4
           | Int
n Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== 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 1) ' ' String -> String -> String
forall a. [a] -> [a] -> [a]
++)

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

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

renderFields :: (String -> String) -> [PrettyField] -> [String]
renderFields :: (String -> String) -> [PrettyField] -> [String]
renderFields indent :: String -> String
indent fields :: [PrettyField]
fields = [Block] -> [String]
flattenBlocks ([Block] -> [String]) -> [Block] -> [String]
forall a b. (a -> b) -> a -> b
$ (PrettyField -> Block) -> [PrettyField] -> [Block]
forall a b. (a -> b) -> [a] -> [b]
map ((String -> String) -> Int -> PrettyField -> Block
renderField String -> String
indent Int
len) [PrettyField]
fields
  where
    len :: Int
len = Int -> [PrettyField] -> Int
maxNameLength 0 [PrettyField]
fields

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

-- | Block of lines,
-- Boolean parameter tells whether block should be surrounded by empty lines
data Block = Block Bool [String]

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

    go :: Bool -> [Block] -> [String]
go _surr' :: Bool
_surr' [] = []
    go  surr' :: Bool
surr' (Block surr :: Bool
surr strs :: [String]
strs : blocks :: [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]
++ Bool -> [Block] -> [String]
go Bool
surr [Block]
blocks where
        ins :: [String] -> [String]
ins | Bool
surr' Bool -> Bool -> Bool
|| Bool
surr = ("" String -> [String] -> [String]
forall a. a -> [a] -> [a]
:)
            | Bool
otherwise     = [String] -> [String]
forall a. a -> a
id

renderField :: (String -> String) -> Int -> PrettyField -> Block
renderField :: (String -> String) -> Int -> PrettyField -> Block
renderField indent :: String -> String
indent fw :: Int
fw (PrettyField name :: FieldName
name doc :: Doc
doc) = Bool -> [String] -> Block
Block Bool
False ([String] -> Block) -> [String] -> Block
forall a b. (a -> b) -> a -> b
$ case String -> [String]
lines String
narrow of
    []           -> [ String
name' String -> String -> String
forall a. [a] -> [a] -> [a]
++ ":" ]
    [singleLine :: String
singleLine] | String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
singleLine Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< 60
                 -> [ String
name' String -> String -> String
forall a. [a] -> [a] -> [a]
++ ": " 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 (t :: * -> *) a. Foldable t => t a -> Int
length String
name') ' ' String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
narrow ]
    _            -> (String
name' String -> String -> String
forall a. [a] -> [a] -> [a]
++ ":") 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))
  where
    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 indent :: String -> String
indent _ (PrettySection name :: FieldName
name args :: [Doc]
args fields :: [PrettyField]
fields) = Bool -> [String] -> Block
Block Bool
True ([String] -> Block) -> [String] -> Block
forall a b. (a -> b) -> a -> b
$
    [ 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 ([String] -> [String]) -> [String] -> [String]
forall a b. (a -> b) -> a -> b
$ (String -> String) -> [PrettyField] -> [String]
renderFields String -> String
indent [PrettyField]
fields)

-------------------------------------------------------------------------------
-- 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]
genericFromParsecFields :: (FieldName -> [FieldLine ann] -> f Doc)
-> (FieldName -> [SectionArg ann] -> f [Doc])
-> [Field ann]
-> f [PrettyField]
genericFromParsecFields f :: FieldName -> [FieldLine ann] -> f Doc
f g :: FieldName -> [SectionArg ann] -> f [Doc]
g = [Field ann] -> f [PrettyField]
goMany where
    goMany :: [Field ann] -> f [PrettyField]
goMany = (Field ann -> f PrettyField) -> [Field ann] -> f [PrettyField]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse Field ann -> f PrettyField
go

    go :: Field ann -> f PrettyField
go (P.Field (P.Name _ann :: ann
_ann name :: FieldName
name) fls :: [FieldLine ann]
fls)          = FieldName -> Doc -> PrettyField
PrettyField FieldName
name (Doc -> PrettyField) -> f Doc -> f PrettyField
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
_ann name :: FieldName
name) secargs :: [SectionArg ann]
secargs fs :: [Field ann]
fs) = FieldName -> [Doc] -> [PrettyField] -> PrettyField
PrettySection FieldName
name ([Doc] -> [PrettyField] -> PrettyField)
-> f [Doc] -> f ([PrettyField] -> PrettyField)
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] -> PrettyField)
-> f [PrettyField] -> f PrettyField
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> [Field ann] -> f [PrettyField]
goMany [Field ann]
fs

-- | Used in 'fromParsecFields'.
prettyFieldLines :: FieldName -> [P.FieldLine ann] -> PP.Doc
prettyFieldLines :: FieldName -> [FieldLine ann] -> Doc
prettyFieldLines _ fls :: [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 _ bs :: FieldName
bs <- [FieldLine ann]
fls
    ]

-- | Used in 'fromParsecFields'.
prettySectionArgs :: FieldName -> [P.SectionArg ann] -> [PP.Doc]
prettySectionArgs :: FieldName -> [SectionArg ann] -> [Doc]
prettySectionArgs _ = (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
$ \sa :: SectionArg ann
sa -> case SectionArg ann
sa of
    P.SecArgName _ bs :: FieldName
bs  -> String -> Doc
showToken (String -> Doc) -> String -> Doc
forall a b. (a -> b) -> a -> b
$ FieldName -> String
fromUTF8BS FieldName
bs
    P.SecArgStr _ bs :: FieldName
bs   -> String -> Doc
showToken (String -> Doc) -> String -> Doc
forall a b. (a -> b) -> a -> b
$ FieldName -> String
fromUTF8BS FieldName
bs
    P.SecArgOther _ bs :: 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]
fromParsecFields :: [Field ann] -> [PrettyField]
fromParsecFields = Identity [PrettyField] -> [PrettyField]
forall a. Identity a -> a
runIdentity (Identity [PrettyField] -> [PrettyField])
-> ([Field ann] -> Identity [PrettyField])
-> [Field ann]
-> [PrettyField]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (FieldName -> [FieldLine ann] -> Identity Doc)
-> (FieldName -> [SectionArg ann] -> Identity [Doc])
-> [Field ann]
-> Identity [PrettyField]
forall (f :: * -> *) ann.
Applicative f =>
(FieldName -> [FieldLine ann] -> f Doc)
-> (FieldName -> [SectionArg ann] -> f [Doc])
-> [Field ann]
-> f [PrettyField]
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)
    (f :: a -> b
f .: :: (a -> b) -> (c -> d -> a) -> c -> d -> b
.: g :: c -> d -> a
g) x :: c
x y :: d
y = a -> b
f (c -> d -> a
g c
x d
y)