|
| 1 | +{-# LANGUAGE BangPatterns #-} |
| 2 | +-- | Cabal-like file AST types: 'Field', 'Section' etc, |
| 3 | +-- |
| 4 | +-- This (intermediate) data type is used for pretty-printing. |
| 5 | +-- |
| 6 | +-- @since 3.0.0.0 |
| 7 | +-- |
| 8 | +module Distribution.Fields.Pretty ( |
| 9 | + -- * Fields |
| 10 | + PrettyField (..), |
| 11 | + showFields, |
| 12 | + showFields', |
| 13 | + -- * Transformation from 'P.Field' |
| 14 | + fromParsecFields, |
| 15 | + genericFromParsecFields, |
| 16 | + prettyFieldLines, |
| 17 | + prettySectionArgs, |
| 18 | + ) where |
| 19 | + |
| 20 | +import Data.Functor.Identity (Identity (..)) |
| 21 | +import Distribution.Pretty (showToken) |
| 22 | + |
| 23 | +import Distribution.Parsec.Field (FieldName) |
| 24 | +import Distribution.Simple.Utils (fromUTF8BS) |
| 25 | + |
| 26 | +import qualified Distribution.Parsec.Parser as P |
| 27 | + |
| 28 | +import qualified Data.ByteString as BS |
| 29 | +import qualified Text.PrettyPrint as PP |
| 30 | + |
| 31 | +data PrettyField |
| 32 | + = PrettyField FieldName PP.Doc |
| 33 | + | PrettySection FieldName [PP.Doc] [PrettyField] |
| 34 | + deriving Show |
| 35 | + |
| 36 | +-- | Prettyprint a list of fields. |
| 37 | +showFields :: [PrettyField] -> String |
| 38 | +showFields = showFields' 4 |
| 39 | + |
| 40 | +-- | 'showFields' with user specified indentation. |
| 41 | +showFields' :: Int -> [PrettyField] -> String |
| 42 | +showFields' n = unlines . renderFields indent where |
| 43 | + -- few hardcoded, "unrolled" variants. |
| 44 | + indent | n == 4 = indent4 |
| 45 | + | n == 2 = indent2 |
| 46 | + | otherwise = (replicate (max n 1) ' ' ++) |
| 47 | + |
| 48 | + indent4 :: String -> String |
| 49 | + indent4 [] = [] |
| 50 | + indent4 xs = ' ' : ' ' : ' ' : ' ' : xs |
| 51 | + |
| 52 | + indent2 :: String -> String |
| 53 | + indent2 [] = [] |
| 54 | + indent2 xs = ' ' : ' ' : xs |
| 55 | + |
| 56 | +renderFields :: (String -> String) -> [PrettyField] -> [String] |
| 57 | +renderFields indent fields = flattenBlocks $ map (renderField indent len) fields |
| 58 | + where |
| 59 | + len = maxNameLength 0 fields |
| 60 | + |
| 61 | + maxNameLength !acc [] = acc |
| 62 | + maxNameLength !acc (PrettyField name _ : rest) = maxNameLength (max acc (BS.length name)) rest |
| 63 | + maxNameLength !acc (PrettySection {} : rest) = maxNameLength acc rest |
| 64 | + |
| 65 | +-- | Block of lines, |
| 66 | +-- Boolean parameter tells whether block should be surrounded by empty lines |
| 67 | +data Block = Block Bool [String] |
| 68 | + |
| 69 | +flattenBlocks :: [Block] -> [String] |
| 70 | +flattenBlocks = go0 where |
| 71 | + go0 [] = [] |
| 72 | + go0 (Block surr strs : blocks) = strs ++ go surr blocks |
| 73 | + |
| 74 | + go _surr' [] = [] |
| 75 | + go surr' (Block surr strs : blocks) = ins $ strs ++ go surr blocks where |
| 76 | + ins | surr' || surr = ("" :) |
| 77 | + | otherwise = id |
| 78 | + |
| 79 | +renderField :: (String -> String) -> Int -> PrettyField -> Block |
| 80 | +renderField indent fw (PrettyField name doc) = Block False $ case lines narrow of |
| 81 | + [] -> [ name' ++ ":" ] |
| 82 | + [singleLine] | length singleLine < 60 |
| 83 | + -> [ name' ++ ": " ++ replicate (fw - length name') ' ' ++ narrow ] |
| 84 | + _ -> (name' ++ ":") : map indent (lines (PP.render doc)) |
| 85 | + where |
| 86 | + name' = fromUTF8BS name |
| 87 | + narrow = PP.renderStyle narrowStyle doc |
| 88 | + |
| 89 | + narrowStyle :: PP.Style |
| 90 | + narrowStyle = PP.style { PP.lineLength = PP.lineLength PP.style - fw } |
| 91 | + |
| 92 | +renderField indent _ (PrettySection name args fields) = Block True $ |
| 93 | + PP.render (PP.hsep $ PP.text (fromUTF8BS name) : args) |
| 94 | + : |
| 95 | + map indent (renderFields indent fields) |
| 96 | + |
| 97 | +------------------------------------------------------------------------------- |
| 98 | +-- Transform from Parsec.Field |
| 99 | +------------------------------------------------------------------------------- |
| 100 | + |
| 101 | +genericFromParsecFields |
| 102 | + :: Applicative f |
| 103 | + => (FieldName -> [P.FieldLine ann] -> f PP.Doc) -- ^ transform field contents |
| 104 | + -> (FieldName -> [P.SectionArg ann] -> f [PP.Doc]) -- ^ transform section arguments |
| 105 | + -> [P.Field ann] |
| 106 | + -> f [PrettyField] |
| 107 | +genericFromParsecFields f g = goMany where |
| 108 | + goMany = traverse go |
| 109 | + |
| 110 | + go (P.Field (P.Name _ann name) fls) = PrettyField name <$> f name fls |
| 111 | + go (P.Section (P.Name _ann name) secargs fs) = PrettySection name <$> g name secargs <*> goMany fs |
| 112 | + |
| 113 | +-- | Used in 'fromParsecFields'. |
| 114 | +prettyFieldLines :: FieldName -> [P.FieldLine ann] -> PP.Doc |
| 115 | +prettyFieldLines _ fls = PP.vcat |
| 116 | + [ PP.text $ fromUTF8BS bs |
| 117 | + | P.FieldLine _ bs <- fls |
| 118 | + ] |
| 119 | + |
| 120 | +-- | Used in 'fromParsecFields'. |
| 121 | +prettySectionArgs :: FieldName -> [P.SectionArg ann] -> [PP.Doc] |
| 122 | +prettySectionArgs _ = map $ \sa -> case sa of |
| 123 | + P.SecArgName _ bs -> showToken $ fromUTF8BS bs |
| 124 | + P.SecArgStr _ bs -> showToken $ fromUTF8BS bs |
| 125 | + P.SecArgOther _ bs -> PP.text $ fromUTF8BS bs |
| 126 | + |
| 127 | +-- | Simple variant of 'genericFromParsecField' |
| 128 | +fromParsecFields :: [P.Field ann] -> [PrettyField] |
| 129 | +fromParsecFields = runIdentity . genericFromParsecFields |
| 130 | + (Identity .: prettyFieldLines) |
| 131 | + (Identity .: prettySectionArgs) |
| 132 | + where |
| 133 | + (.:) :: (a -> b) -> (c -> d -> a) -> (c -> d -> b) |
| 134 | + (f .: g) x y = f (g x y) |
0 commit comments