{-# LANGUAGE TypeFamilies #-}
module Toml.Printer
( PrintOptions(..)
, defaultOptions
, pretty
, prettyOptions
, prettyKey
) where
import Data.Bifunctor (first)
import Data.Function (on)
import Data.HashMap.Strict (HashMap)
import Data.List (sortBy, splitAt)
import Data.List.NonEmpty (NonEmpty)
import Data.Monoid ((<>))
import Data.Text (Text)
import Data.Time (ZonedTime, defaultTimeLocale, formatTime)
import Toml.PrefixTree (Key (..), Piece (..), PrefixMap, PrefixTree (..))
import Toml.Type (AnyValue (..), TOML (..), Value (..))
import qualified Data.HashMap.Strict as HashMap
import qualified Data.List.NonEmpty as NonEmpty
import qualified Data.Text as Text
data PrintOptions = PrintOptions
{
printOptionsSorting :: !(Maybe (Key -> Key -> Ordering))
, printOptionsIndent :: !Int
}
defaultOptions :: PrintOptions
defaultOptions = PrintOptions (Just compare) 2
pretty :: TOML -> Text
pretty = prettyOptions defaultOptions
prettyOptions :: PrintOptions -> TOML -> Text
prettyOptions options = Text.unlines . prettyTomlInd options 0 ""
prettyTomlInd :: PrintOptions
-> Int
-> Text
-> TOML
-> [Text]
prettyTomlInd options i prefix TOML{..} = concat
[ prettyKeyValue options i tomlPairs
, prettyTables options i prefix tomlTables
, prettyTableArrays options i prefix tomlTableArrays
]
prettyKey :: Key -> Text
prettyKey = Text.intercalate "." . map unPiece . NonEmpty.toList . unKey
prettyKeyValue :: PrintOptions -> Int -> HashMap Key AnyValue -> [Text]
prettyKeyValue options i = mapOrdered (\kv -> [kvText kv]) options . HashMap.toList
where
kvText :: (Key, AnyValue) -> Text
kvText (k, AnyValue v) =
tabWith options i <> prettyKey k <> " = " <> valText v
valText :: Value t -> Text
valText (Bool b) = Text.toLower $ showText b
valText (Integer n) = showText n
valText (Double d) = showDouble d
valText (Text s) = showText s
valText (Zoned z) = showZonedTime z
valText (Local l) = showText l
valText (Day d) = showText d
valText (Hours h) = showText h
valText (Array a) = "[" <> Text.intercalate ", " (map valText a) <> "]"
showText :: Show a => a -> Text
showText = Text.pack . show
showDouble :: Double -> Text
showDouble d | isInfinite d && d < 0 = "-inf"
| isInfinite d = "inf"
| isNaN d = "nan"
| otherwise = showText d
showZonedTime :: ZonedTime -> Text
showZonedTime t = Text.pack $ showZonedDateTime t <> showZonedZone t
where
showZonedDateTime = formatTime defaultTimeLocale "%FT%T%Q"
showZonedZone
= (\(x,y) -> x ++ ":" ++ y)
. (\z -> splitAt (length z - 2) z)
. formatTime defaultTimeLocale "%z"
prettyTables :: PrintOptions -> Int -> Text -> PrefixMap TOML -> [Text]
prettyTables options i pref asPieces = mapOrdered (prettyTable . snd) options asKeys
where
asKeys :: [(Key, PrefixTree TOML)]
asKeys = map (first pieceToKey) $ HashMap.toList asPieces
pieceToKey :: Piece -> Key
pieceToKey = Key . pure
prettyTable :: PrefixTree TOML -> [Text]
prettyTable (Leaf k toml) =
let name = addPrefix k pref
in "": tabWith options i <> prettyTableName name :
dropWhile (== "") (prettyTomlInd options (i + 1) name toml)
prettyTable (Branch k mToml prefMap) =
let name = addPrefix k pref
nextI = i + 1
toml = case mToml of
Nothing -> []
Just t -> prettyTomlInd options nextI name t
in "": tabWith options i <> prettyTableName name :
dropWhile (== "") (toml ++ prettyTables options nextI name prefMap)
prettyTableName :: Text -> Text
prettyTableName n = "[" <> n <> "]"
prettyTableArrays :: PrintOptions -> Int -> Text -> HashMap Key (NonEmpty TOML) -> [Text]
prettyTableArrays options i pref = mapOrdered arrText options . HashMap.toList
where
arrText :: (Key, NonEmpty TOML) -> [Text]
arrText (k, ne) =
let name = addPrefix k pref
render toml =
"": tabWith options i <> "[[" <> name <> "]]" :
dropWhile (== "") (prettyTomlInd options (i + 1) name toml)
in concatMap render $ NonEmpty.toList ne
tabWith :: PrintOptions -> Int -> Text
tabWith PrintOptions{..} n = Text.replicate (n * printOptionsIndent) " "
mapOrdered :: ((Key, v) -> [t]) -> PrintOptions -> [(Key, v)] -> [t]
mapOrdered f options = case printOptionsSorting options of
Just sorter -> concatMap f . sortBy (sorter `on` fst)
Nothing -> concatMap f
addPrefix :: Key -> Text -> Text
addPrefix key = \case
"" -> prettyKey key
prefix -> prefix <> "." <> prettyKey key