module Distribution.Fields.Pretty (
CommentPosition (..),
PrettyField (..),
showFields,
showFields',
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
data CommentPosition = CommentBefore [String] | CommentAfter [String] | NoComment
data PrettyField ann
= PrettyField ann FieldName PP.Doc
| PrettySection ann FieldName [PP.Doc] [PrettyField ann]
| PrettyEmpty
deriving (Functor, Foldable, Traversable)
showFields :: (ann -> CommentPosition) -> [PrettyField ann] -> String
showFields rann = showFields' rann (const id) 4
showFields'
:: (ann -> CommentPosition)
-> (ann -> [String] -> [String])
-> Int
-> [PrettyField ann]
-> String
showFields' rann post n = unlines . renderFields (Opts rann indent post)
where
indent | n == 4 = indent4
| n == 2 = indent2
| otherwise = (replicate (max n 1) ' ' ++)
indent4 :: String -> String
indent4 [] = []
indent4 xs = ' ' : ' ' : ' ' : ' ' : xs
indent2 :: String -> String
indent2 [] = []
indent2 xs = ' ' : ' ' : xs
data Opts ann = Opts
{ _optAnnotation :: ann -> CommentPosition
, _optIndent :: String -> String
, _optPostprocess :: ann -> [String] -> [String]
}
renderFields :: Opts ann -> [PrettyField ann] -> [String]
renderFields opts fields = flattenBlocks blocks
where
len = maxNameLength 0 fields
blocks = filter (not . null . _contentsBlock)
$ map (renderField opts len) fields
maxNameLength !acc [] = acc
maxNameLength !acc (PrettyField _ name _ : rest) = maxNameLength (max acc (BS.length name)) rest
maxNameLength !acc (PrettySection {} : rest) = maxNameLength acc rest
maxNameLength !acc (PrettyEmpty : rest) = maxNameLength acc rest
data Block = Block
{ _beforeBlock :: Margin
, _afterBlock :: Margin
, _contentsBlock :: [String]
}
data Margin = Margin | NoMargin
deriving Eq
instance Semigroup Margin where
NoMargin <> NoMargin = NoMargin
_ <> _ = Margin
flattenBlocks :: [Block] -> [String]
flattenBlocks = go0 where
go0 [] = []
go0 (Block _before after strs : blocks) = strs ++ go after blocks
go _surr' [] = []
go surr' (Block before after strs : blocks) = ins $ strs ++ go after blocks where
ins | surr' <> before == Margin = ("" :)
| otherwise = id
renderField :: Opts ann -> Int -> PrettyField ann -> Block
renderField (Opts rann indent post) fw (PrettyField ann name doc) =
Block before after content
where
content = case comments of
CommentBefore cs -> cs ++ post ann lines'
CommentAfter cs -> post ann lines' ++ cs
NoComment -> post ann lines'
comments = rann ann
before = case comments of
CommentBefore [] -> NoMargin
CommentAfter [] -> NoMargin
NoComment -> NoMargin
_ -> Margin
(lines', after) = case lines narrow of
[] -> ([ name' ++ ":" ], NoMargin)
[singleLine] | length singleLine < 60
-> ([ name' ++ ": " ++ replicate (fw length name') ' ' ++ narrow ], NoMargin)
_ -> ((name' ++ ":") : map indent (lines (PP.render doc)), Margin)
name' = fromUTF8BS name
narrow = PP.renderStyle narrowStyle doc
narrowStyle :: PP.Style
narrowStyle = PP.style { PP.lineLength = PP.lineLength PP.style fw }
renderField opts@(Opts rann indent post) _ (PrettySection ann name args fields) = Block Margin Margin $
attachComments
(post ann [ PP.render $ PP.hsep $ PP.text (fromUTF8BS name) : args ])
++
map indent (renderFields opts fields)
where
attachComments content = case rann ann of
CommentBefore cs -> cs ++ content
CommentAfter cs -> content ++ cs
NoComment -> content
renderField _ _ PrettyEmpty = Block NoMargin NoMargin mempty
genericFromParsecFields
:: Applicative f
=> (FieldName -> [P.FieldLine ann] -> f PP.Doc)
-> (FieldName -> [P.SectionArg ann] -> f [PP.Doc])
-> [P.Field ann]
-> f [PrettyField ann]
genericFromParsecFields f g = goMany where
goMany = traverse go
go (P.Field (P.Name ann name) fls) = PrettyField ann name <$> f name fls
go (P.Section (P.Name ann name) secargs fs) = PrettySection ann name <$> g name secargs <*> goMany fs
prettyFieldLines :: FieldName -> [P.FieldLine ann] -> PP.Doc
prettyFieldLines _ fls = PP.vcat
[ PP.text $ fromUTF8BS bs
| P.FieldLine _ bs <- fls
]
prettySectionArgs :: FieldName -> [P.SectionArg ann] -> [PP.Doc]
prettySectionArgs _ = map $ \case
P.SecArgName _ bs -> showToken $ fromUTF8BS bs
P.SecArgStr _ bs -> showToken $ fromUTF8BS bs
P.SecArgOther _ bs -> PP.text $ fromUTF8BS bs
fromParsecFields :: [P.Field ann] -> [PrettyField ann]
fromParsecFields = runIdentity . genericFromParsecFields
(Identity .: prettyFieldLines)
(Identity .: prettySectionArgs)
where
(.:) :: (a -> b) -> (c -> d -> a) -> (c -> d -> b)
(f .: g) x y = f (g x y)