module Hpack.Render (
Element (..)
, Value (..)
, RenderSettings (..)
, CommaStyle (..)
, defaultRenderSettings
, Alignment (..)
, Nesting
, render
, sortFieldsBy
#ifdef TEST
, Lines (..)
, renderValue
, addSortKey
#endif
) where
import Prelude ()
import Prelude.Compat
import Data.String
import Data.List.Compat
data Value =
Literal String
| CommaSeparatedList [String]
| LineSeparatedList [String]
| WordList [String]
deriving (Eq, Show)
data Element = Stanza String [Element] | Group Element Element | Field String Value
deriving (Eq, Show)
data Lines = SingleLine String | MultipleLines [String]
deriving (Eq, Show)
data CommaStyle = LeadingCommas | TrailingCommas
deriving (Eq, Show)
newtype Nesting = Nesting Int
deriving (Eq, Show, Num, Enum)
newtype Alignment = Alignment Int
deriving (Eq, Show, Num)
data RenderSettings = RenderSettings {
renderSettingsIndentation :: Int
, renderSettingsFieldAlignment :: Alignment
, renderSettingsCommaStyle :: CommaStyle
} deriving (Eq, Show)
defaultRenderSettings :: RenderSettings
defaultRenderSettings = RenderSettings 2 0 LeadingCommas
render :: RenderSettings -> Nesting -> Element -> [String]
render settings nesting (Stanza name elements) = indent settings nesting name : renderElements settings (succ nesting) elements
render settings nesting (Group a b) = render settings nesting a ++ render settings nesting b
render settings nesting (Field name value) = renderField settings nesting name value
renderElements :: RenderSettings -> Nesting -> [Element] -> [String]
renderElements settings nesting = concatMap (render settings nesting)
renderField :: RenderSettings -> Nesting -> String -> Value -> [String]
renderField settings@RenderSettings{..} nesting name value = case renderValue settings value of
SingleLine "" -> []
SingleLine x -> [indent settings nesting (name ++ ": " ++ padding ++ x)]
MultipleLines [] -> []
MultipleLines xs -> (indent settings nesting name ++ ":") : map (indent settings $ succ nesting) xs
where
Alignment fieldAlignment = renderSettingsFieldAlignment
padding = replicate (fieldAlignment length name 2) ' '
renderValue :: RenderSettings -> Value -> Lines
renderValue RenderSettings{..} v = case v of
Literal s -> SingleLine s
WordList ws -> SingleLine $ unwords ws
LineSeparatedList xs -> renderLineSeparatedList renderSettingsCommaStyle xs
CommaSeparatedList xs -> renderCommaSeparatedList renderSettingsCommaStyle xs
renderLineSeparatedList :: CommaStyle -> [String] -> Lines
renderLineSeparatedList style = MultipleLines . map (padding ++)
where
padding = case style of
LeadingCommas -> " "
TrailingCommas -> ""
renderCommaSeparatedList :: CommaStyle -> [String] -> Lines
renderCommaSeparatedList style = MultipleLines . case style of
LeadingCommas -> map renderLeadingComma . zip (True : repeat False)
TrailingCommas -> map renderTrailingComma . reverse . zip (True : repeat False) . reverse
where
renderLeadingComma :: (Bool, String) -> String
renderLeadingComma (isFirst, x)
| isFirst = " " ++ x
| otherwise = ", " ++ x
renderTrailingComma :: (Bool, String) -> String
renderTrailingComma (isLast, x)
| isLast = x
| otherwise = x ++ ","
instance IsString Value where
fromString = Literal
indent :: RenderSettings -> Nesting -> String -> String
indent RenderSettings{..} (Nesting nesting) s = replicate (nesting * renderSettingsIndentation) ' ' ++ s
sortFieldsBy :: [String] -> [Element] -> [Element]
sortFieldsBy existingFieldOrder =
map snd
. sortOn fst
. addSortKey
. map (\a -> (existingIndex a, a))
where
existingIndex :: Element -> Maybe Int
existingIndex (Field name _) = name `elemIndex` existingFieldOrder
existingIndex _ = Nothing
addSortKey :: [(Maybe Int, a)] -> [((Int, Int), a)]
addSortKey = go (1) . zip [0..]
where
go :: Int -> [(Int, (Maybe Int, a))] -> [((Int, Int), a)]
go n xs = case xs of
[] -> []
(x, (Just y, a)) : ys -> ((y, x), a) : go y ys
(x, (Nothing, a)) : ys -> ((n, x), a) : go n ys