{-# 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,
    prettyLocated,
    ) 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.Located (Located(..))
import Toml.Parser.Types (SectionKind(..))
import Toml.Position (Position(..))
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 (ReadPrec [DocClass]
ReadPrec DocClass
Int -> ReadS DocClass
ReadS [DocClass]
(Int -> ReadS DocClass)
-> ReadS [DocClass]
-> ReadPrec DocClass
-> ReadPrec [DocClass]
-> Read DocClass
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [DocClass]
$creadListPrec :: ReadPrec [DocClass]
readPrec :: ReadPrec DocClass
$creadPrec :: ReadPrec DocClass
readList :: ReadS [DocClass]
$creadList :: ReadS [DocClass]
readsPrec :: Int -> ReadS DocClass
$creadsPrec :: Int -> ReadS DocClass
Read, Int -> DocClass -> ShowS
[DocClass] -> ShowS
DocClass -> String
(Int -> DocClass -> ShowS)
-> (DocClass -> String) -> ([DocClass] -> ShowS) -> Show DocClass
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [DocClass] -> ShowS
$cshowList :: [DocClass] -> ShowS
show :: DocClass -> String
$cshow :: DocClass -> String
showsPrec :: Int -> DocClass -> ShowS
$cshowsPrec :: Int -> DocClass -> ShowS
Show, DocClass -> DocClass -> Bool
(DocClass -> DocClass -> Bool)
-> (DocClass -> DocClass -> Bool) -> Eq DocClass
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: DocClass -> DocClass -> Bool
$c/= :: DocClass -> DocClass -> Bool
== :: DocClass -> DocClass -> Bool
$c== :: DocClass -> DocClass -> Bool
Eq, Eq DocClass
Eq DocClass
-> (DocClass -> DocClass -> Ordering)
-> (DocClass -> DocClass -> Bool)
-> (DocClass -> DocClass -> Bool)
-> (DocClass -> DocClass -> Bool)
-> (DocClass -> DocClass -> Bool)
-> (DocClass -> DocClass -> DocClass)
-> (DocClass -> DocClass -> DocClass)
-> Ord DocClass
DocClass -> DocClass -> Bool
DocClass -> DocClass -> Ordering
DocClass -> DocClass -> DocClass
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: DocClass -> DocClass -> DocClass
$cmin :: DocClass -> DocClass -> DocClass
max :: DocClass -> DocClass -> DocClass
$cmax :: DocClass -> DocClass -> DocClass
>= :: DocClass -> DocClass -> Bool
$c>= :: DocClass -> DocClass -> Bool
> :: DocClass -> DocClass -> Bool
$c> :: DocClass -> DocClass -> Bool
<= :: DocClass -> DocClass -> Bool
$c<= :: DocClass -> DocClass -> Bool
< :: DocClass -> DocClass -> Bool
$c< :: DocClass -> DocClass -> Bool
compare :: DocClass -> DocClass -> Ordering
$ccompare :: DocClass -> DocClass -> Ordering
$cp1Ord :: Eq DocClass
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 :: NonEmpty String -> TomlDoc
prettyKey = DocClass -> TomlDoc -> TomlDoc
forall ann. ann -> Doc ann -> Doc ann
annotate DocClass
KeyClass (TomlDoc -> TomlDoc)
-> (NonEmpty String -> TomlDoc) -> NonEmpty String -> TomlDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NonEmpty TomlDoc -> TomlDoc
forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold (NonEmpty TomlDoc -> TomlDoc)
-> (NonEmpty String -> NonEmpty TomlDoc)
-> NonEmpty String
-> TomlDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TomlDoc -> NonEmpty TomlDoc -> NonEmpty TomlDoc
forall a. a -> NonEmpty a -> NonEmpty a
NonEmpty.intersperse TomlDoc
forall ann. Doc ann
dot (NonEmpty TomlDoc -> NonEmpty TomlDoc)
-> (NonEmpty String -> NonEmpty TomlDoc)
-> NonEmpty String
-> NonEmpty TomlDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> TomlDoc) -> NonEmpty String -> NonEmpty TomlDoc
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap String -> TomlDoc
forall a. String -> Doc a
prettySimpleKey

-- | Renders a simple-key using quotes where necessary.
prettySimpleKey :: String -> Doc a
prettySimpleKey :: String -> Doc a
prettySimpleKey String
str
    | Bool -> Bool
not (String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
str), (Char -> Bool) -> String -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Char -> Bool
isBareKey String
str = String -> Doc a
forall a. IsString a => String -> a
fromString String
str
    | Bool
otherwise                         = String -> Doc a
forall a. IsString a => String -> a
fromString (ShowS
quoteString String
str)

-- | Predicate for the character-class that is allowed in bare keys
isBareKey :: Char -> Bool
isBareKey :: Char -> Bool
isBareKey Char
x = Char -> Bool
isAsciiLower Char
x Bool -> Bool -> Bool
|| Char -> Bool
isAsciiUpper Char
x Bool -> Bool -> Bool
|| Char -> Bool
isDigit Char
x Bool -> Bool -> Bool
|| Char
x Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'-' Bool -> Bool -> Bool
|| Char
x Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'_'

-- | Quote a string using basic string literal syntax.
quoteString :: String -> String
quoteString :: ShowS
quoteString = (Char
'"'Char -> ShowS
forall a. a -> [a] -> [a]
:) ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
go
    where
        go :: ShowS
go = \case
            String
""        -> String
"\"" -- terminator
            Char
'"'  : String
xs -> Char
'\\' Char -> ShowS
forall a. a -> [a] -> [a]
: Char
'"'  Char -> ShowS
forall a. a -> [a] -> [a]
: ShowS
go String
xs
            Char
'\\' : String
xs -> Char
'\\' Char -> ShowS
forall a. a -> [a] -> [a]
: Char
'\\' Char -> ShowS
forall a. a -> [a] -> [a]
: ShowS
go String
xs
            Char
'\b' : String
xs -> Char
'\\' Char -> ShowS
forall a. a -> [a] -> [a]
: Char
'b'  Char -> ShowS
forall a. a -> [a] -> [a]
: ShowS
go String
xs
            Char
'\f' : String
xs -> Char
'\\' Char -> ShowS
forall a. a -> [a] -> [a]
: Char
'f'  Char -> ShowS
forall a. a -> [a] -> [a]
: ShowS
go String
xs
            Char
'\n' : String
xs -> Char
'\\' Char -> ShowS
forall a. a -> [a] -> [a]
: Char
'n'  Char -> ShowS
forall a. a -> [a] -> [a]
: ShowS
go String
xs
            Char
'\r' : String
xs -> Char
'\\' Char -> ShowS
forall a. a -> [a] -> [a]
: Char
'r'  Char -> ShowS
forall a. a -> [a] -> [a]
: ShowS
go String
xs
            Char
'\t' : String
xs -> Char
'\\' Char -> ShowS
forall a. a -> [a] -> [a]
: Char
't'  Char -> ShowS
forall a. a -> [a] -> [a]
: ShowS
go String
xs
            Char
x    : String
xs
                | Char -> Bool
isPrint Char
x     -> Char
x Char -> ShowS
forall a. a -> [a] -> [a]
: ShowS
go String
xs
                | Char
x Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
<= Char
'\xffff' -> String -> Int -> ShowS
forall r. PrintfType r => String -> r
printf String
"\\u%04X%s" (Char -> Int
ord Char
x) (ShowS
go String
xs)
                | Bool
otherwise     -> String -> Int -> ShowS
forall r. PrintfType r => String -> r
printf String
"\\U%08X%s" (Char -> Int
ord Char
x) (ShowS
go String
xs)

-- | Quote a string using basic string literal syntax.
quoteMlString :: String -> String
quoteMlString :: ShowS
quoteMlString = (String
"\"\"\"\n"String -> ShowS
forall a. [a] -> [a] -> [a]
++) ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
go
    where
        go :: ShowS
go = \case
            String
"" -> String
"\"\"\"" -- terminator
            Char
'"' : Char
'"' : Char
'"' : String
xs -> String
"\"\"\\\"" String -> ShowS
forall a. [a] -> [a] -> [a]
++ ShowS
go String
xs
            Char
'\\' : String
xs -> Char
'\\' Char -> ShowS
forall a. a -> [a] -> [a]
: Char
'\\' Char -> ShowS
forall a. a -> [a] -> [a]
: ShowS
go String
xs
            Char
'\b' : String
xs -> Char
'\\' Char -> ShowS
forall a. a -> [a] -> [a]
: Char
'b' Char -> ShowS
forall a. a -> [a] -> [a]
: ShowS
go String
xs
            Char
'\f' : String
xs -> Char
'\\' Char -> ShowS
forall a. a -> [a] -> [a]
: Char
'f' Char -> ShowS
forall a. a -> [a] -> [a]
: ShowS
go String
xs
            Char
'\t' : String
xs -> Char
'\\' Char -> ShowS
forall a. a -> [a] -> [a]
: Char
't' Char -> ShowS
forall a. a -> [a] -> [a]
: ShowS
go String
xs
            Char
'\n' : String
xs -> Char
'\n' Char -> ShowS
forall a. a -> [a] -> [a]
: ShowS
go String
xs
            Char
'\r' : Char
'\n' : String
xs -> Char
'\r' Char -> ShowS
forall a. a -> [a] -> [a]
: Char
'\n' Char -> ShowS
forall a. a -> [a] -> [a]
: ShowS
go String
xs
            Char
'\r' : String
xs -> Char
'\\' Char -> ShowS
forall a. a -> [a] -> [a]
: Char
'r' Char -> ShowS
forall a. a -> [a] -> [a]
: ShowS
go String
xs
            Char
x    : String
xs
                | Char -> Bool
isPrint Char
x     -> Char
x Char -> ShowS
forall a. a -> [a] -> [a]
: ShowS
go String
xs
                | Char
x Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
<= Char
'\xffff' -> String -> Int -> ShowS
forall r. PrintfType r => String -> r
printf String
"\\u%04X%s" (Char -> Int
ord Char
x) (ShowS
go String
xs)
                | Bool
otherwise     -> String -> Int -> ShowS
forall r. PrintfType r => String -> r
printf String
"\\U%08X%s" (Char -> Int
ord Char
x) (ShowS
go String
xs)

-- | Pretty-print a section heading. The result is annotated as a 'TableClass'.
prettySectionKind :: SectionKind -> NonEmpty String -> TomlDoc
prettySectionKind :: SectionKind -> NonEmpty String -> TomlDoc
prettySectionKind SectionKind
TableKind      NonEmpty String
key =
    DocClass -> TomlDoc -> TomlDoc
forall ann. ann -> Doc ann -> Doc ann
annotate DocClass
TableClass (TomlDoc -> TomlDoc
forall ann xxx. Doc ann -> Doc xxx
unAnnotate (TomlDoc
forall ann. Doc ann
lbracket TomlDoc -> TomlDoc -> TomlDoc
forall a. Semigroup a => a -> a -> a
<> NonEmpty String -> TomlDoc
prettyKey NonEmpty String
key TomlDoc -> TomlDoc -> TomlDoc
forall a. Semigroup a => a -> a -> a
<> TomlDoc
forall ann. Doc ann
rbracket))
prettySectionKind SectionKind
ArrayTableKind NonEmpty String
key =
    DocClass -> TomlDoc -> TomlDoc
forall ann. ann -> Doc ann -> Doc ann
annotate DocClass
TableClass (TomlDoc -> TomlDoc
forall ann xxx. Doc ann -> Doc xxx
unAnnotate (TomlDoc
forall ann. Doc ann
lbracket TomlDoc -> TomlDoc -> TomlDoc
forall a. Semigroup a => a -> a -> a
<> TomlDoc
forall ann. Doc ann
lbracket TomlDoc -> TomlDoc -> TomlDoc
forall a. Semigroup a => a -> a -> a
<> NonEmpty String -> TomlDoc
prettyKey NonEmpty String
key TomlDoc -> TomlDoc -> TomlDoc
forall a. Semigroup a => a -> a -> a
<> TomlDoc
forall ann. Doc ann
rbracket TomlDoc -> TomlDoc -> TomlDoc
forall a. Semigroup a => a -> a -> a
<> TomlDoc
forall ann. Doc ann
rbracket))

-- | Render token for human-readable error messages.
prettyToken :: Token -> String
prettyToken :: Token -> String
prettyToken = \case
    Token
TokComma            -> String
"','"
    Token
TokEquals           -> String
"'='"
    Token
TokPeriod           -> String
"'.'"
    Token
TokSquareO          -> String
"'['"
    Token
TokSquareC          -> String
"']'"
    Token
Tok2SquareO         -> String
"'[['"
    Token
Tok2SquareC         -> String
"']]'"
    Token
TokCurlyO           -> String
"'{'"
    Token
TokCurlyC           -> String
"'}'"
    Token
TokNewline          -> String
"end-of-line"
    TokBareKey        String
_ -> String
"bare key"
    Token
TokTrue             -> String
"true literal"
    Token
TokFalse            -> String
"false literal"
    TokString         String
_ -> String
"string"
    TokMlString       String
_ -> String
"multi-line string"
    TokInteger        Integer
_ -> String
"integer"
    TokFloat          Double
_ -> String
"float"
    TokOffsetDateTime ZonedTime
_ -> String
"offset date-time"
    TokLocalDateTime  LocalTime
_ -> String
"local date-time"
    TokLocalDate      Day
_ -> String
"local date"
    TokLocalTime      TimeOfDay
_ -> String
"local time"
    Token
TokEOF              -> String
"end-of-input"

prettyAssignment :: String -> Value -> TomlDoc
prettyAssignment :: String -> Value -> TomlDoc
prettyAssignment = NonEmpty String -> Value -> TomlDoc
go (NonEmpty String -> Value -> TomlDoc)
-> (String -> NonEmpty String) -> String -> Value -> TomlDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> NonEmpty String
forall (f :: * -> *) a. Applicative f => a -> f a
pure
    where
        go :: NonEmpty String -> Value -> TomlDoc
go NonEmpty String
ks (Table (Table -> [(String, Value)]
forall k a. Map k a -> [(k, a)]
Map.assocs -> [(String
k,Value
v)])) = NonEmpty String -> Value -> TomlDoc
go (String -> NonEmpty String -> NonEmpty String
forall a. a -> NonEmpty a -> NonEmpty a
NonEmpty.cons String
k NonEmpty String
ks) Value
v
        go NonEmpty String
ks Value
v = NonEmpty String -> TomlDoc
prettyKey (NonEmpty String -> NonEmpty String
forall a. NonEmpty a -> NonEmpty a
NonEmpty.reverse NonEmpty String
ks) TomlDoc -> TomlDoc -> TomlDoc
forall ann. Doc ann -> Doc ann -> Doc ann
<+> TomlDoc
forall ann. Doc ann
equals TomlDoc -> TomlDoc -> TomlDoc
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Value -> TomlDoc
prettyValue Value
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 :: Value -> TomlDoc
prettyValue = \case
    Integer Integer
i           -> DocClass -> TomlDoc -> TomlDoc
forall ann. ann -> Doc ann -> Doc ann
annotate DocClass
NumberClass (Integer -> TomlDoc
forall a ann. Pretty a => a -> Doc ann
pretty Integer
i)
    Float   Double
f
        | Double -> Bool
forall a. RealFloat a => a -> Bool
isNaN Double
f       -> DocClass -> TomlDoc -> TomlDoc
forall ann. ann -> Doc ann -> Doc ann
annotate DocClass
NumberClass TomlDoc
"nan"
        | Double -> Bool
forall a. RealFloat a => a -> Bool
isInfinite Double
f  -> DocClass -> TomlDoc -> TomlDoc
forall ann. ann -> Doc ann -> Doc ann
annotate DocClass
NumberClass (if Double
f Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
> Double
0 then TomlDoc
"inf" else TomlDoc
"-inf")
        | Bool
otherwise     -> DocClass -> TomlDoc -> TomlDoc
forall ann. ann -> Doc ann -> Doc ann
annotate DocClass
NumberClass (Double -> TomlDoc
forall a ann. Pretty a => a -> Doc ann
pretty Double
f)
    Array [Value]
a             -> TomlDoc -> TomlDoc
forall ann. Doc ann -> Doc ann
align ([TomlDoc] -> TomlDoc
forall ann. [Doc ann] -> Doc ann
list [Value -> TomlDoc
prettyValue Value
v | Value
v <- [Value]
a])
    Table Table
t             -> TomlDoc
forall ann. Doc ann
lbrace TomlDoc -> TomlDoc -> TomlDoc
forall a. Semigroup a => a -> a -> a
<> (TomlDoc -> TomlDoc -> TomlDoc) -> [TomlDoc] -> TomlDoc
forall (t :: * -> *) ann.
Foldable t =>
(Doc ann -> Doc ann -> Doc ann) -> t (Doc ann) -> Doc ann
concatWith (TomlDoc -> TomlDoc -> TomlDoc -> TomlDoc
forall ann. Doc ann -> Doc ann -> Doc ann -> Doc ann
surround TomlDoc
", ") [String -> Value -> TomlDoc
prettyAssignment String
k Value
v | (String
k,Value
v) <- Table -> [(String, Value)]
forall k a. Map k a -> [(k, a)]
Map.assocs Table
t] TomlDoc -> TomlDoc -> TomlDoc
forall a. Semigroup a => a -> a -> a
<> TomlDoc
forall ann. Doc ann
rbrace
    Bool Bool
True           -> DocClass -> TomlDoc -> TomlDoc
forall ann. ann -> Doc ann -> Doc ann
annotate DocClass
BoolClass TomlDoc
"true"
    Bool Bool
False          -> DocClass -> TomlDoc -> TomlDoc
forall ann. ann -> Doc ann -> Doc ann
annotate DocClass
BoolClass TomlDoc
"false"
    String String
str          -> String -> TomlDoc
prettySmartString String
str
    TimeOfDay TimeOfDay
tod       -> DocClass -> TomlDoc -> TomlDoc
forall ann. ann -> Doc ann -> Doc ann
annotate DocClass
DateClass (String -> TomlDoc
forall a. IsString a => String -> a
fromString (TimeLocale -> String -> TimeOfDay -> String
forall t. FormatTime t => TimeLocale -> String -> t -> String
formatTime TimeLocale
defaultTimeLocale String
"%H:%M:%S%Q" TimeOfDay
tod))
    ZonedTime ZonedTime
zt
        | TimeZone -> Int
timeZoneMinutes (ZonedTime -> TimeZone
zonedTimeZone ZonedTime
zt) Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 ->
                           DocClass -> TomlDoc -> TomlDoc
forall ann. ann -> Doc ann -> Doc ann
annotate DocClass
DateClass (String -> TomlDoc
forall a. IsString a => String -> a
fromString (TimeLocale -> String -> ZonedTime -> String
forall t. FormatTime t => TimeLocale -> String -> t -> String
formatTime TimeLocale
defaultTimeLocale String
"%0Y-%m-%dT%H:%M:%S%QZ" ZonedTime
zt))
        | Bool
otherwise     -> DocClass -> TomlDoc -> TomlDoc
forall ann. ann -> Doc ann -> Doc ann
annotate DocClass
DateClass (String -> TomlDoc
forall a. IsString a => String -> a
fromString (TimeLocale -> String -> ZonedTime -> String
forall t. FormatTime t => TimeLocale -> String -> t -> String
formatTime TimeLocale
defaultTimeLocale String
"%0Y-%m-%dT%H:%M:%S%Q%Ez" ZonedTime
zt))
    LocalTime LocalTime
lt        -> DocClass -> TomlDoc -> TomlDoc
forall ann. ann -> Doc ann -> Doc ann
annotate DocClass
DateClass (String -> TomlDoc
forall a. IsString a => String -> a
fromString (TimeLocale -> String -> LocalTime -> String
forall t. FormatTime t => TimeLocale -> String -> t -> String
formatTime TimeLocale
defaultTimeLocale String
"%0Y-%m-%dT%H:%M:%S%Q" LocalTime
lt))
    Day Day
d               -> DocClass -> TomlDoc -> TomlDoc
forall ann. ann -> Doc ann -> Doc ann
annotate DocClass
DateClass (String -> TomlDoc
forall a. IsString a => String -> a
fromString (TimeLocale -> String -> Day -> String
forall t. FormatTime t => TimeLocale -> String -> t -> String
formatTime TimeLocale
defaultTimeLocale String
"%0Y-%m-%d" Day
d))

prettySmartString :: String -> TomlDoc
prettySmartString :: String -> TomlDoc
prettySmartString String
str
    | Char
'\n' Char -> String -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` String
str =
        (Int -> TomlDoc) -> TomlDoc
forall ann. (Int -> Doc ann) -> Doc ann
column \Int
i ->
        (PageWidth -> TomlDoc) -> TomlDoc
forall ann. (PageWidth -> Doc ann) -> Doc ann
pageWidth \case
            AvailablePerLine Int
n Double
_ | String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
str Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
i ->
                String -> TomlDoc
prettyMlString String
str
            PageWidth
_ -> String -> TomlDoc
prettyString String
str
    | Bool
otherwise = String -> TomlDoc
prettyString String
str

prettyMlString :: String -> TomlDoc
prettyMlString :: String -> TomlDoc
prettyMlString String
str = DocClass -> TomlDoc -> TomlDoc
forall ann. ann -> Doc ann -> Doc ann
annotate DocClass
StringClass ((Int -> TomlDoc) -> TomlDoc
forall ann. (Int -> Doc ann) -> Doc ann
column \Int
i -> Int -> TomlDoc -> TomlDoc
forall ann. Int -> Doc ann -> Doc ann
hang (-Int
i) (String -> TomlDoc
forall a. IsString a => String -> a
fromString (ShowS
quoteMlString String
str)))

prettyString :: String -> TomlDoc
prettyString :: String -> TomlDoc
prettyString String
str = DocClass -> TomlDoc -> TomlDoc
forall ann. ann -> Doc ann -> Doc ann
annotate DocClass
StringClass (String -> TomlDoc
forall a. IsString a => String -> a
fromString (ShowS
quoteString String
str))

-- | Predicate for values that CAN rendered on the
-- righthand-side of an @=@.
isSimple :: Value -> Bool
isSimple :: Value -> Bool
isSimple = \case
    Integer   Integer
_ -> Bool
True
    Float     Double
_ -> Bool
True
    Bool      Bool
_ -> Bool
True
    String    String
_ -> Bool
True
    TimeOfDay TimeOfDay
_ -> Bool
True
    ZonedTime ZonedTime
_ -> Bool
True
    LocalTime LocalTime
_ -> Bool
True
    Day       Day
_ -> Bool
True
    Table     Table
x -> Table -> Bool
isSingularTable Table
x -- differs from isAlwaysSimple
    Array     [Value]
x -> [Value] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Value]
x Bool -> Bool -> Bool
|| Bool -> Bool
not ((Value -> Bool) -> [Value] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Value -> Bool
isTable [Value]
x)

-- | Predicate for values that can be MUST rendered on the
-- righthand-side of an @=@.
isAlwaysSimple :: Value -> Bool
isAlwaysSimple :: Value -> Bool
isAlwaysSimple = \case
    Integer   Integer
_ -> Bool
True
    Float     Double
_ -> Bool
True
    Bool      Bool
_ -> Bool
True
    String    String
_ -> Bool
True
    TimeOfDay TimeOfDay
_ -> Bool
True
    ZonedTime ZonedTime
_ -> Bool
True
    LocalTime LocalTime
_ -> Bool
True
    Day       Day
_ -> Bool
True
    Table     Table
_ -> Bool
False -- differs from isSimple
    Array     [Value]
x -> [Value] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Value]
x Bool -> Bool -> Bool
|| Bool -> Bool
not ((Value -> Bool) -> [Value] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Value -> Bool
isTable [Value]
x)

-- | Predicate for table values.
isTable :: Value -> Bool
isTable :: Value -> Bool
isTable Table {} = Bool
True
isTable Value
_        = Bool
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 :: Table -> Bool
isSingularTable (Table -> [Value]
forall k a. Map k a -> [a]
Map.elems -> [Value
v])  = Value -> Bool
isSimple Value
v
isSingularTable Table
_                   = Bool
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 :: Table -> TomlDoc
prettyToml = KeyProjection -> SectionKind -> [String] -> Table -> TomlDoc
prettyToml_ KeyProjection
NoProjection SectionKind
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 :: ([String] -> String -> a) -> Table -> TomlDoc
prettyTomlOrdered [String] -> String -> a
proj = KeyProjection -> SectionKind -> [String] -> Table -> TomlDoc
prettyToml_ (([String] -> String -> a) -> KeyProjection
forall a. Ord a => ([String] -> String -> a) -> KeyProjection
KeyProjection [String] -> String -> a
proj) SectionKind
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_ :: KeyProjection -> SectionKind -> [String] -> Table -> TomlDoc
prettyToml_ KeyProjection
mbKeyProj SectionKind
kind [String]
prefix Table
t = [TomlDoc] -> TomlDoc
forall ann. [Doc ann] -> Doc ann
vcat ([TomlDoc]
topLines [TomlDoc] -> [TomlDoc] -> [TomlDoc]
forall a. [a] -> [a] -> [a]
++ [TomlDoc]
subtables)
    where
        order :: [(String, Value)] -> [(String, Value)]
order =
            case KeyProjection
mbKeyProj of
                KeyProjection
NoProjection    -> [(String, Value)] -> [(String, Value)]
forall a. a -> a
id
                KeyProjection [String] -> String -> a
f -> ((String, Value) -> a) -> [(String, Value)] -> [(String, Value)]
forall b a. Ord b => (a -> b) -> [a] -> [a]
sortOn ([String] -> String -> a
f [String]
prefix (String -> a)
-> ((String, Value) -> String) -> (String, Value) -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String, Value) -> String
forall a b. (a, b) -> a
fst)

        kvs :: [(String, Value)]
kvs = [(String, Value)] -> [(String, Value)]
order (Table -> [(String, Value)]
forall k a. Map k a -> [(k, a)]
Map.assocs Table
t)

        -- this table will require no subsequent tables to be defined
        simpleToml :: Bool
simpleToml = (Value -> Bool) -> Table -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Value -> Bool
isSimple Table
t

        ([(String, Value)]
simple, [(String, Value)]
sections) = ((String, Value) -> Bool)
-> [(String, Value)] -> ([(String, Value)], [(String, Value)])
forall a. (a -> Bool) -> [a] -> ([a], [a])
partition (Value -> Bool
isAlwaysSimple (Value -> Bool)
-> ((String, Value) -> Value) -> (String, Value) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String, Value) -> Value
forall a b. (a, b) -> b
snd) [(String, Value)]
kvs

        topLines :: [TomlDoc]
topLines = [[TomlDoc] -> TomlDoc
forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold [TomlDoc]
topElts | let topElts :: [TomlDoc]
topElts = [TomlDoc]
headers [TomlDoc] -> [TomlDoc] -> [TomlDoc]
forall a. [a] -> [a] -> [a]
++ [TomlDoc]
assignments, Bool -> Bool
not ([TomlDoc] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [TomlDoc]
topElts)]

        headers :: [TomlDoc]
headers =
            case [String] -> Maybe (NonEmpty String)
forall a. [a] -> Maybe (NonEmpty a)
NonEmpty.nonEmpty [String]
prefix of
                Just NonEmpty String
key | Bool
simpleToml Bool -> Bool -> Bool
|| Bool -> Bool
not ([(String, Value)] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(String, Value)]
simple) Bool -> Bool -> Bool
|| [(String, Value)] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(String, Value)]
sections Bool -> Bool -> Bool
|| SectionKind
kind SectionKind -> SectionKind -> Bool
forall a. Eq a => a -> a -> Bool
== SectionKind
ArrayTableKind ->
                    [SectionKind -> NonEmpty String -> TomlDoc
prettySectionKind SectionKind
kind NonEmpty String
key TomlDoc -> TomlDoc -> TomlDoc
forall a. Semigroup a => a -> a -> a
<> TomlDoc
forall ann. Doc ann
hardline]
                Maybe (NonEmpty String)
_ -> []

        assignments :: [TomlDoc]
assignments = [String -> Value -> TomlDoc
prettyAssignment String
k Value
v TomlDoc -> TomlDoc -> TomlDoc
forall a. Semigroup a => a -> a -> a
<> TomlDoc
forall ann. Doc ann
hardline | (String
k,Value
v) <- if Bool
simpleToml then [(String, Value)]
kvs else [(String, Value)]
simple]

        subtables :: [TomlDoc]
subtables = [[String] -> Value -> TomlDoc
prettySection ([String]
prefix [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String
k]) Value
v | Bool -> Bool
not Bool
simpleToml, (String
k,Value
v) <- [(String, Value)]
sections]

        prettySection :: [String] -> Value -> TomlDoc
prettySection [String]
key (Table Table
tab) =
            KeyProjection -> SectionKind -> [String] -> Table -> TomlDoc
prettyToml_ KeyProjection
mbKeyProj SectionKind
TableKind [String]
key Table
tab
        prettySection [String]
key (Array [Value]
a) =
            [TomlDoc] -> TomlDoc
forall ann. [Doc ann] -> Doc ann
vcat [KeyProjection -> SectionKind -> [String] -> Table -> TomlDoc
prettyToml_ KeyProjection
mbKeyProj SectionKind
ArrayTableKind [String]
key Table
tab | Table Table
tab <- [Value]
a]
        prettySection [String]
_ Value
_ = String -> TomlDoc
forall a. HasCallStack => String -> a
error String
"prettySection applied to simple value"

-- | Render a semantic TOML error in a human-readable string.
--
-- @since 1.3.0.0
prettySemanticError :: SemanticError -> String
prettySemanticError :: SemanticError -> String
prettySemanticError (SemanticError String
key SemanticErrorKind
kind) =
    String -> String -> ShowS
forall r. PrintfType r => String -> r
printf String
"key error: %s %s" (Doc Any -> String
forall a. Show a => a -> String
show (String -> Doc Any
forall a. String -> Doc a
prettySimpleKey String
key))
    case SemanticErrorKind
kind of
        SemanticErrorKind
AlreadyAssigned -> String
"is already assigned" :: String
        SemanticErrorKind
ClosedTable     -> String
"is a closed table"
        SemanticErrorKind
ImplicitlyTable -> String
"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 -> String
prettyMatchMessage (MatchMessage [Scope]
scope String
msg) =
    String
msg String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" in top" String -> ShowS
forall a. [a] -> [a] -> [a]
++ (Scope -> ShowS) -> String -> [Scope] -> String
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Scope -> ShowS
f String
"" [Scope]
scope
    where
        f :: Scope -> ShowS
f (ScopeIndex Int
i) = (Char
'[' Char -> ShowS
forall a. a -> [a] -> [a]
:) ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> ShowS
forall a. Show a => a -> ShowS
shows Int
i ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char
']'Char -> ShowS
forall a. a -> [a] -> [a]
:)
        f (ScopeKey String
key) = (Char
'.' Char -> ShowS
forall a. a -> [a] -> [a]
:) ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Doc Any -> ShowS
forall a. Show a => a -> ShowS
shows (String -> Doc Any
forall a. String -> Doc a
prettySimpleKey String
key)

prettyLocated :: Located String -> String
prettyLocated :: Located String -> String
prettyLocated (Located Position
p String
s) = String -> Int -> Int -> ShowS
forall r. PrintfType r => String -> r
printf String
"%d:%d: %s" (Position -> Int
posLine Position
p) (Position -> Int
posColumn Position
p) String
s