{-# Language OverloadedStrings, GADTs #-} {-| Module : Toml.Pretty Description : Human-readable representations for error messages Copyright : (c) Eric Mertens, 2023 License : ISC Maintainer : emertens@gmail.com This module provides human-readable renderers for types used in this package to assist error message production. The generated 'Doc' values are annotated with 'DocClass' values to assist in producing syntax-highlighted outputs. To extract a plain String representation, use 'show'. -} module Toml.Pretty ( -- * Types TomlDoc, DocClass(..), -- * Printing semantic values prettyToml, prettyTomlOrdered, prettyValue, -- * Printing syntactic components prettyToken, prettySectionKind, -- * Printing keys prettySimpleKey, prettyKey, -- * Pretty errors prettySemanticError, prettyMatchMessage, ) where import Data.Char (ord, isAsciiLower, isAsciiUpper, isDigit, isPrint) import Data.Foldable (fold) import Data.List (partition, sortOn) import Data.List.NonEmpty (NonEmpty((:|))) import Data.List.NonEmpty qualified as NonEmpty import Data.Map qualified as Map import Data.String (fromString) import Data.Time (ZonedTime(zonedTimeZone), TimeZone (timeZoneMinutes)) import Data.Time.Format (formatTime, defaultTimeLocale) import Prettyprinter import Text.Printf (printf) import Toml.FromValue.Matcher (MatchMessage(..), Scope (..)) import Toml.Lexer (Token(..)) import Toml.Parser.Types (SectionKind(..)) import Toml.Semantics (SemanticError (..), SemanticErrorKind (..)) import Toml.Value (Value(..), Table) -- | Annotation used to enable styling pretty-printed TOML data DocClass = TableClass -- ^ top-level @[key]@ and @[[key]]@ | KeyClass -- ^ dotted keys, left-hand side of assignments | StringClass -- ^ string literals | NumberClass -- ^ number literals | DateClass -- ^ date and time literals | BoolClass -- ^ boolean literals deriving (Read, Show, Eq, Ord) -- | Pretty-printer document with TOML class attributes to aid -- in syntax-highlighting. type TomlDoc = Doc DocClass -- | Renders a dotted-key using quotes where necessary and annotated -- as a 'KeyClass'. prettyKey :: NonEmpty String -> TomlDoc prettyKey = annotate KeyClass . fold . NonEmpty.intersperse dot . fmap prettySimpleKey -- | Renders a simple-key using quotes where necessary. prettySimpleKey :: String -> Doc a prettySimpleKey str | not (null str), all isBareKey str = fromString str | otherwise = fromString (quoteString str) -- | Predicate for the character-class that is allowed in bare keys isBareKey :: Char -> Bool isBareKey x = isAsciiLower x || isAsciiUpper x || isDigit x || x == '-' || x == '_' -- | Quote a string using basic string literal syntax. quoteString :: String -> String quoteString = ('"':) . go where go = \case "" -> "\"" -- terminator '"' : xs -> '\\' : '"' : go xs '\\' : xs -> '\\' : '\\' : go xs '\b' : xs -> '\\' : 'b' : go xs '\f' : xs -> '\\' : 'f' : go xs '\n' : xs -> '\\' : 'n' : go xs '\r' : xs -> '\\' : 'r' : go xs '\t' : xs -> '\\' : 't' : go xs x : xs | isPrint x -> x : go xs | x <= '\xffff' -> printf "\\u%04X%s" (ord x) (go xs) | otherwise -> printf "\\U%08X%s" (ord x) (go xs) -- | Pretty-print a section heading. The result is annotated as a 'TableClass'. prettySectionKind :: SectionKind -> NonEmpty String -> TomlDoc prettySectionKind TableKind key = annotate TableClass (unAnnotate (lbracket <> prettyKey key <> rbracket)) prettySectionKind ArrayTableKind key = annotate TableClass (unAnnotate (lbracket <> lbracket <> prettyKey key <> rbracket <> rbracket)) -- | Render token for human-readable error messages. prettyToken :: Token -> String prettyToken = \case TokComma -> "','" TokEquals -> "'='" TokPeriod -> "'.'" TokSquareO -> "'['" TokSquareC -> "']'" Tok2SquareO -> "'[['" Tok2SquareC -> "']]'" TokCurlyO -> "'{'" TokCurlyC -> "'}'" TokNewline -> "end-of-line" TokBareKey _ -> "bare key" TokTrue -> "true literal" TokFalse -> "false literal" TokString _ -> "string" TokMlString _ -> "multi-line string" TokInteger _ -> "integer" TokFloat _ -> "float" TokOffsetDateTime _ -> "offset date-time" TokLocalDateTime _ -> "local date-time" TokLocalDate _ -> "local date" TokLocalTime _ -> "local time" TokEOF -> "end-of-input" prettyAssignment :: String -> Value -> TomlDoc prettyAssignment = go . pure where go ks (Table (Map.assocs -> [(k,v)])) = go (NonEmpty.cons k ks) v go ks v = prettyKey (NonEmpty.reverse ks) <+> equals <+> prettyValue v -- | Render a value suitable for assignment on the right-hand side -- of an equals sign. This value will always use inline table and list -- syntax. prettyValue :: Value -> TomlDoc prettyValue = \case Integer i -> annotate NumberClass (pretty i) Float f | isNaN f -> annotate NumberClass "nan" | isInfinite f -> annotate NumberClass (if f > 0 then "inf" else "-inf") | otherwise -> annotate NumberClass (pretty f) Array a -> align (list [prettyValue v | v <- a]) Table t -> lbrace <> concatWith (surround ", ") [prettyAssignment k v | (k,v) <- Map.assocs t] <> rbrace Bool True -> annotate BoolClass "true" Bool False -> annotate BoolClass "false" String str -> annotate StringClass (fromString (quoteString str)) TimeOfDay tod -> annotate DateClass (fromString (formatTime defaultTimeLocale "%H:%M:%S%Q" tod)) ZonedTime zt | timeZoneMinutes (zonedTimeZone zt) == 0 -> annotate DateClass (fromString (formatTime defaultTimeLocale "%Y-%m-%dT%H:%M:%S%QZ" zt)) | otherwise -> annotate DateClass (fromString (formatTime defaultTimeLocale "%Y-%m-%dT%H:%M:%S%Q%Ez" zt)) LocalTime lt -> annotate DateClass (fromString (formatTime defaultTimeLocale "%Y-%m-%dT%H:%M:%S%Q" lt)) Day d -> annotate DateClass (fromString (formatTime defaultTimeLocale "%Y-%m-%d" d)) -- | Predicate for values that should be completely rendered on the -- righthand-side of an @=@. isAlwaysSimple :: Value -> Bool isAlwaysSimple = \case Integer _ -> True Float _ -> True Bool _ -> True String _ -> True TimeOfDay _ -> True ZonedTime _ -> True LocalTime _ -> True Day _ -> True Table x -> isSingularTable x Array x -> null x || not (all isTable x) -- | Predicate for table values. isTable :: Value -> Bool isTable Table {} = True isTable _ = False -- | Predicate for tables that can be rendered with a single assignment. -- These can be collapsed using dotted-key notation on the lefthand-side -- of a @=@. isSingularTable :: Table -> Bool isSingularTable (Map.elems -> [v]) = isAlwaysSimple v isSingularTable _ = False -- | Render a complete TOML document using top-level table and array of -- table sections where possible. -- -- Keys are sorted alphabetically. To provide a custom ordering, see -- 'prettyTomlOrdered'. prettyToml :: Table {- ^ table to print -} -> TomlDoc {- ^ TOML syntax -} prettyToml = prettyToml_ NoProjection TableKind [] -- | Render a complete TOML document like 'prettyToml' but use a -- custom key ordering. The comparison function has access to the -- complete key path. Note that only keys in the same table will -- every be compared. -- -- This operation allows you to render your TOML files with the -- most important sections first. A TOML file describing a package -- might desire to have the @[package]@ section first before any -- of the ancilliary configuration sections. -- -- The /table path/ is the name of the table being sorted. This allows -- the projection to be aware of which table is being sorted. -- -- The /key/ is the key in the table being sorted. These are the -- keys that will be compared to each other. -- -- Here's a projection that puts the @package@ section first, the -- @secondary@ section second, and then all remaining cases are -- sorted alphabetically afterward. -- -- @ -- example :: [String] -> String -> Either Int String -- example [] "package" = Left 1 -- example [] "second" = Left 2 -- example _ other = Right other -- @ -- -- We could also put the tables in reverse-alphabetical order -- by leveraging an existing newtype. -- -- @ -- reverseOrderProj :: [String] -> String -> Down String -- reverseOrderProj _ = Down -- @ -- -- @since 1.2.1.0 prettyTomlOrdered :: Ord a => ([String] -> String -> a) {- ^ table path -> key -> projection -} -> Table {- ^ table to print -} -> TomlDoc {- ^ TOML syntax -} prettyTomlOrdered proj = prettyToml_ (KeyProjection proj) TableKind [] -- | Optional projection used to order rendered tables data KeyProjection where -- | No projection provided; alphabetical order used NoProjection :: KeyProjection -- | Projection provided: table name and current key are available KeyProjection :: Ord a => ([String] -> String -> a) -> KeyProjection prettyToml_ :: KeyProjection -> SectionKind -> [String] -> Table -> TomlDoc prettyToml_ mbKeyProj kind prefix t = vcat (topLines ++ subtables) where order = case mbKeyProj of NoProjection -> id KeyProjection f -> sortOn (f prefix . fst) (simple, sections) = partition (isAlwaysSimple . snd) (order (Map.assocs t)) topLines = [fold topElts | let topElts = headers ++ assignments, not (null topElts)] headers = case NonEmpty.nonEmpty prefix of Just key | not (null simple) || null sections || kind == ArrayTableKind -> [prettySectionKind kind key <> hardline] _ -> [] assignments = [prettyAssignment k v <> hardline | (k,v) <- simple] subtables = [prettySection (prefix `snoc` k) v | (k,v) <- sections] prettySection key (Table tab) = prettyToml_ mbKeyProj TableKind (NonEmpty.toList key) tab prettySection key (Array a) = vcat [prettyToml_ mbKeyProj ArrayTableKind (NonEmpty.toList key) tab | Table tab <- a] prettySection _ _ = error "prettySection applied to simple value" -- | Create a 'NonEmpty' with a given prefix and last element. snoc :: [a] -> a -> NonEmpty a snoc [] y = y :| [] snoc (x : xs) y = x :| xs ++ [y] -- | Render a semantic TOML error in a human-readable string. -- -- @since 1.3.0.0 prettySemanticError :: SemanticError -> String prettySemanticError (SemanticError key kind) = printf "key error: %s %s" (show (prettySimpleKey key)) case kind of AlreadyAssigned -> "is already assigned" :: String ClosedTable -> "is a closed table" ImplicitlyTable -> "is already implicitly defined to be a table" -- | Render a TOML decoding error as a human-readable string. -- -- @since 1.3.0.0 prettyMatchMessage :: MatchMessage -> String prettyMatchMessage (MatchMessage scope msg) = msg ++ " in top" ++ foldr f "" scope where f (ScopeIndex i) = ('[' :) . shows i . (']':) f (ScopeKey key) = ('.' :) . shows (prettySimpleKey key)