{-# LANGUAGE BangPatterns #-}
module Distribution.Fields.Pretty (
PrettyField (..),
showFields,
showFields',
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]
showFields :: [PrettyField] -> String
showFields :: [PrettyField] -> String
showFields = Int -> [PrettyField] -> String
showFields' 4
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
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
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)
genericFromParsecFields
:: Applicative f
=> (FieldName -> [P.FieldLine ann] -> f PP.Doc)
-> (FieldName -> [P.SectionArg ann] -> f [PP.Doc])
-> [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
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
]
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
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)