{-# 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,

    -- * Locations
    prettyLocated,
    prettyPosition,
    ) 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.Text (Text)
import Data.Text qualified as Text
import Data.Time (ZonedTime(zonedTimeZone), TimeZone (timeZoneMinutes))
import Data.Time.Format (formatTime, defaultTimeLocale)
import Prettyprinter
import Text.Printf (printf)
import Toml.Semantics
import Toml.Syntax.Lexer (Token(..))
import Toml.Syntax.Position (Located(..), Position(..))
import Toml.Syntax.Types (SectionKind(..))

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

-- | Renders a simple-key using quotes where necessary.
prettySimpleKey :: Text -> Doc a
prettySimpleKey :: forall a. Text -> Doc a
prettySimpleKey Text
str
    | Bool -> Bool
not (Text -> Bool
Text.null Text
str), (Char -> Bool) -> Text -> Bool
Text.all Char -> Bool
isBareKey Text
str = Text -> Doc a
forall a ann. Pretty a => a -> Doc ann
forall a. Text -> Doc a
pretty Text
str
    | Bool
otherwise = String -> Doc a
forall a. IsString a => String -> a
fromString (String -> String
quoteString (Text -> String
Text.unpack Text
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 :: String -> String
quoteString = (Char
'"'Char -> String -> String
forall a. a -> [a] -> [a]
:) (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
go
    where
        go :: String -> String
go = \case
            String
""        -> String
"\"" -- terminator
            Char
'"'  : String
xs -> Char
'\\' Char -> String -> String
forall a. a -> [a] -> [a]
: Char
'"'  Char -> String -> String
forall a. a -> [a] -> [a]
: String -> String
go String
xs
            Char
'\\' : String
xs -> Char
'\\' Char -> String -> String
forall a. a -> [a] -> [a]
: Char
'\\' Char -> String -> String
forall a. a -> [a] -> [a]
: String -> String
go String
xs
            Char
'\b' : String
xs -> Char
'\\' Char -> String -> String
forall a. a -> [a] -> [a]
: Char
'b'  Char -> String -> String
forall a. a -> [a] -> [a]
: String -> String
go String
xs
            Char
'\f' : String
xs -> Char
'\\' Char -> String -> String
forall a. a -> [a] -> [a]
: Char
'f'  Char -> String -> String
forall a. a -> [a] -> [a]
: String -> String
go String
xs
            Char
'\n' : String
xs -> Char
'\\' Char -> String -> String
forall a. a -> [a] -> [a]
: Char
'n'  Char -> String -> String
forall a. a -> [a] -> [a]
: String -> String
go String
xs
            Char
'\r' : String
xs -> Char
'\\' Char -> String -> String
forall a. a -> [a] -> [a]
: Char
'r'  Char -> String -> String
forall a. a -> [a] -> [a]
: String -> String
go String
xs
            Char
'\t' : String
xs -> Char
'\\' Char -> String -> String
forall a. a -> [a] -> [a]
: Char
't'  Char -> String -> String
forall a. a -> [a] -> [a]
: String -> String
go String
xs
            Char
x    : String
xs
                | Char -> Bool
isPrint Char
x     -> Char
x Char -> String -> String
forall a. a -> [a] -> [a]
: String -> String
go String
xs
                | Char
x Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
<= Char
'\xffff' -> String -> Int -> String -> String
forall r. PrintfType r => String -> r
printf String
"\\u%04X%s" (Char -> Int
ord Char
x) (String -> String
go String
xs)
                | Bool
otherwise     -> String -> Int -> String -> String
forall r. PrintfType r => String -> r
printf String
"\\U%08X%s" (Char -> Int
ord Char
x) (String -> String
go String
xs)

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

-- | Pretty-print a section heading. The result is annotated as a 'TableClass'.
prettySectionKind :: SectionKind -> NonEmpty Text -> TomlDoc
prettySectionKind :: SectionKind -> NonEmpty Text -> Doc DocClass
prettySectionKind SectionKind
TableKind      NonEmpty Text
key =
    DocClass -> Doc DocClass -> Doc DocClass
forall ann. ann -> Doc ann -> Doc ann
annotate DocClass
TableClass (Doc DocClass -> Doc DocClass
forall ann xxx. Doc ann -> Doc xxx
unAnnotate (Doc DocClass
forall ann. Doc ann
lbracket Doc DocClass -> Doc DocClass -> Doc DocClass
forall a. Semigroup a => a -> a -> a
<> NonEmpty Text -> Doc DocClass
prettyKey NonEmpty Text
key Doc DocClass -> Doc DocClass -> Doc DocClass
forall a. Semigroup a => a -> a -> a
<> Doc DocClass
forall ann. Doc ann
rbracket))
prettySectionKind SectionKind
ArrayTableKind NonEmpty Text
key =
    DocClass -> Doc DocClass -> Doc DocClass
forall ann. ann -> Doc ann -> Doc ann
annotate DocClass
TableClass (Doc DocClass -> Doc DocClass
forall ann xxx. Doc ann -> Doc xxx
unAnnotate (Doc DocClass
forall ann. Doc ann
lbracket Doc DocClass -> Doc DocClass -> Doc DocClass
forall a. Semigroup a => a -> a -> a
<> Doc DocClass
forall ann. Doc ann
lbracket Doc DocClass -> Doc DocClass -> Doc DocClass
forall a. Semigroup a => a -> a -> a
<> NonEmpty Text -> Doc DocClass
prettyKey NonEmpty Text
key Doc DocClass -> Doc DocClass -> Doc DocClass
forall a. Semigroup a => a -> a -> a
<> Doc DocClass
forall ann. Doc ann
rbracket Doc DocClass -> Doc DocClass -> Doc DocClass
forall a. Semigroup a => a -> a -> a
<> Doc DocClass
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        Text
_ -> String
"bare key"
    Token
TokTrue             -> String
"true literal"
    Token
TokFalse            -> String
"false literal"
    TokString         Text
_ -> String
"string"
    TokMlString       Text
_ -> 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 :: Text -> Value' l -> TomlDoc
prettyAssignment :: forall l. Text -> Value' l -> Doc DocClass
prettyAssignment = NonEmpty Text -> Value' l -> Doc DocClass
forall {l}. NonEmpty Text -> Value' l -> Doc DocClass
go (NonEmpty Text -> Value' l -> Doc DocClass)
-> (Text -> NonEmpty Text) -> Text -> Value' l -> Doc DocClass
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> NonEmpty Text
forall a. a -> NonEmpty a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
    where
        go :: NonEmpty Text -> Value' l -> Doc DocClass
go NonEmpty Text
ks (Table' l
_ (MkTable (Map Text (l, Value' l) -> [(Text, (l, Value' l))]
forall k a. Map k a -> [(k, a)]
Map.assocs -> [(Text
k,(l
_, Value' l
v))]))) = NonEmpty Text -> Value' l -> Doc DocClass
go (Text -> NonEmpty Text -> NonEmpty Text
forall a. a -> NonEmpty a -> NonEmpty a
NonEmpty.cons Text
k NonEmpty Text
ks) Value' l
v
        go NonEmpty Text
ks Value' l
v = NonEmpty Text -> Doc DocClass
prettyKey (NonEmpty Text -> NonEmpty Text
forall a. NonEmpty a -> NonEmpty a
NonEmpty.reverse NonEmpty Text
ks) Doc DocClass -> Doc DocClass -> Doc DocClass
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Doc DocClass
forall ann. Doc ann
equals Doc DocClass -> Doc DocClass -> Doc DocClass
forall ann. Doc ann -> Doc ann -> Doc ann
<+> Value' l -> Doc DocClass
forall l. Value' l -> Doc DocClass
prettyValue Value' l
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' l -> TomlDoc
prettyValue :: forall l. Value' l -> Doc DocClass
prettyValue = \case
    Integer' l
_ Integer
i           -> DocClass -> Doc DocClass -> Doc DocClass
forall ann. ann -> Doc ann -> Doc ann
annotate DocClass
NumberClass (Integer -> Doc DocClass
forall ann. Integer -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Integer
i)
    Double' l
_   Double
f
        | Double -> Bool
forall a. RealFloat a => a -> Bool
isNaN Double
f       -> DocClass -> Doc DocClass -> Doc DocClass
forall ann. ann -> Doc ann -> Doc ann
annotate DocClass
NumberClass Doc DocClass
"nan"
        | Double -> Bool
forall a. RealFloat a => a -> Bool
isInfinite Double
f  -> DocClass -> Doc DocClass -> Doc DocClass
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 Doc DocClass
"inf" else Doc DocClass
"-inf")
        | Bool
otherwise     -> DocClass -> Doc DocClass -> Doc DocClass
forall ann. ann -> Doc ann -> Doc ann
annotate DocClass
NumberClass (Double -> Doc DocClass
forall ann. Double -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty Double
f)
    List' l
_ [Value' l]
a           -> Doc DocClass -> Doc DocClass
forall ann. Doc ann -> Doc ann
align ([Doc DocClass] -> Doc DocClass
forall ann. [Doc ann] -> Doc ann
list [Value' l -> Doc DocClass
forall l. Value' l -> Doc DocClass
prettyValue Value' l
v | Value' l
v <- [Value' l]
a])
    Table' l
_ (MkTable Map Text (l, Value' l)
t) -> Doc DocClass
forall ann. Doc ann
lbrace Doc DocClass -> Doc DocClass -> Doc DocClass
forall a. Semigroup a => a -> a -> a
<> (Doc DocClass -> Doc DocClass -> Doc DocClass)
-> [Doc DocClass] -> Doc DocClass
forall (t :: * -> *) ann.
Foldable t =>
(Doc ann -> Doc ann -> Doc ann) -> t (Doc ann) -> Doc ann
concatWith (Doc DocClass -> Doc DocClass -> Doc DocClass -> Doc DocClass
forall ann. Doc ann -> Doc ann -> Doc ann -> Doc ann
surround Doc DocClass
", ") [Text -> Value' l -> Doc DocClass
forall l. Text -> Value' l -> Doc DocClass
prettyAssignment Text
k Value' l
v | (Text
k,(l
_, Value' l
v)) <- Map Text (l, Value' l) -> [(Text, (l, Value' l))]
forall k a. Map k a -> [(k, a)]
Map.assocs Map Text (l, Value' l)
t] Doc DocClass -> Doc DocClass -> Doc DocClass
forall a. Semigroup a => a -> a -> a
<> Doc DocClass
forall ann. Doc ann
rbrace
    Bool' l
_ Bool
True        -> DocClass -> Doc DocClass -> Doc DocClass
forall ann. ann -> Doc ann -> Doc ann
annotate DocClass
BoolClass Doc DocClass
"true"
    Bool' l
_ Bool
False       -> DocClass -> Doc DocClass -> Doc DocClass
forall ann. ann -> Doc ann -> Doc ann
annotate DocClass
BoolClass Doc DocClass
"false"
    Text' l
_ Text
str         -> Text -> Doc DocClass
prettySmartString Text
str
    TimeOfDay' l
_ TimeOfDay
tod    -> DocClass -> Doc DocClass -> Doc DocClass
forall ann. ann -> Doc ann -> Doc ann
annotate DocClass
DateClass (String -> Doc DocClass
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' l
_ ZonedTime
zt
        | TimeZone -> Int
timeZoneMinutes (ZonedTime -> TimeZone
zonedTimeZone ZonedTime
zt) Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 ->
                           DocClass -> Doc DocClass -> Doc DocClass
forall ann. ann -> Doc ann -> Doc ann
annotate DocClass
DateClass (String -> Doc DocClass
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 -> Doc DocClass -> Doc DocClass
forall ann. ann -> Doc ann -> Doc ann
annotate DocClass
DateClass (String -> Doc DocClass
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' l
_ LocalTime
lt     -> DocClass -> Doc DocClass -> Doc DocClass
forall ann. ann -> Doc ann -> Doc ann
annotate DocClass
DateClass (String -> Doc DocClass
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' l
_ Day
d            -> DocClass -> Doc DocClass -> Doc DocClass
forall ann. ann -> Doc ann -> Doc ann
annotate DocClass
DateClass (String -> Doc DocClass
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 :: Text -> TomlDoc
prettySmartString :: Text -> Doc DocClass
prettySmartString Text
str
    | Char
'\n' Char -> String -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` Text -> String
Text.unpack Text
str = -- Text.elem isn't in text-1.2
        (Int -> Doc DocClass) -> Doc DocClass
forall ann. (Int -> Doc ann) -> Doc ann
column \Int
i ->
        (PageWidth -> Doc DocClass) -> Doc DocClass
forall ann. (PageWidth -> Doc ann) -> Doc ann
pageWidth \case
            AvailablePerLine Int
n Double
_ | Text -> Int
Text.length Text
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 ->
                Text -> Doc DocClass
prettyMlString Text
str
            PageWidth
_ -> Text -> Doc DocClass
prettyString Text
str
    | Bool
otherwise = Text -> Doc DocClass
prettyString Text
str

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

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

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

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

-- | Predicate for table values.
isTable :: Value' l -> Bool
isTable :: forall l. Value' l -> Bool
isTable Table'{} = Bool
True
isTable Value' l
_        = Bool
False

-- | Predicate for tables that can be rendered with a single assignment.
-- These can be collapsed using dotted-key notation on the left-hand side
-- of a @=@.
isSingularTable :: Table' l -> Bool
isSingularTable :: forall l. Table' l -> Bool
isSingularTable (MkTable (Map Text (l, Value' l) -> [(l, Value' l)]
forall k a. Map k a -> [a]
Map.elems -> [(l
_, Value' l
v)])) = Value' l -> Bool
forall l. Value' l -> Bool
isSimple Value' l
v
isSingularTable Table' l
_ = 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' a {- ^ table to print -} ->
    TomlDoc {- ^ TOML syntax -}
prettyToml :: forall a. Table' a -> Doc DocClass
prettyToml = KeyProjection -> SectionKind -> [Text] -> Table' a -> Doc DocClass
forall l.
KeyProjection -> SectionKind -> [Text] -> Table' l -> Doc DocClass
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 ancillary 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
-- @
prettyTomlOrdered ::
  Ord a =>
  ([Text] -> Text -> a) {- ^ table path -> key -> projection -} ->
  Table' l {- ^ table to print -} ->
  TomlDoc {- ^ TOML syntax -}
prettyTomlOrdered :: forall a l.
Ord a =>
([Text] -> Text -> a) -> Table' l -> Doc DocClass
prettyTomlOrdered [Text] -> Text -> a
proj = KeyProjection -> SectionKind -> [Text] -> Table' l -> Doc DocClass
forall l.
KeyProjection -> SectionKind -> [Text] -> Table' l -> Doc DocClass
prettyToml_ (([Text] -> Text -> a) -> KeyProjection
forall a. Ord a => ([Text] -> Text -> a) -> KeyProjection
KeyProjection [Text] -> Text -> 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 => ([Text] -> Text -> a) -> KeyProjection

prettyToml_ :: KeyProjection -> SectionKind -> [Text] -> Table' l -> TomlDoc
prettyToml_ :: forall l.
KeyProjection -> SectionKind -> [Text] -> Table' l -> Doc DocClass
prettyToml_ KeyProjection
mbKeyProj SectionKind
kind [Text]
prefix (MkTable Map Text (l, Value' l)
t) = [Doc DocClass] -> Doc DocClass
forall ann. [Doc ann] -> Doc ann
vcat ([Doc DocClass]
topLines [Doc DocClass] -> [Doc DocClass] -> [Doc DocClass]
forall a. [a] -> [a] -> [a]
++ [Doc DocClass]
subtables)
    where
        order :: [(Text, (l, Value' l))] -> [(Text, (l, Value' l))]
order =
            case KeyProjection
mbKeyProj of
                KeyProjection
NoProjection    -> [(Text, (l, Value' l))] -> [(Text, (l, Value' l))]
forall a. a -> a
id
                KeyProjection [Text] -> Text -> a
f -> ((Text, (l, Value' l)) -> a)
-> [(Text, (l, Value' l))] -> [(Text, (l, Value' l))]
forall b a. Ord b => (a -> b) -> [a] -> [a]
sortOn ([Text] -> Text -> a
f [Text]
prefix (Text -> a)
-> ((Text, (l, Value' l)) -> Text) -> (Text, (l, Value' l)) -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text, (l, Value' l)) -> Text
forall a b. (a, b) -> a
fst)

        kvs :: [(Text, (l, Value' l))]
kvs = [(Text, (l, Value' l))] -> [(Text, (l, Value' l))]
order (Map Text (l, Value' l) -> [(Text, (l, Value' l))]
forall k a. Map k a -> [(k, a)]
Map.assocs Map Text (l, Value' l)
t)

        -- this table will require no subsequent tables to be defined
        simpleToml :: Bool
simpleToml = ((l, Value' l) -> Bool) -> Map Text (l, Value' l) -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (Value' l -> Bool
forall l. Value' l -> Bool
isSimple (Value' l -> Bool)
-> ((l, Value' l) -> Value' l) -> (l, Value' l) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (l, Value' l) -> Value' l
forall a b. (a, b) -> b
snd) Map Text (l, Value' l)
t

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

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

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

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

        subtables :: [Doc DocClass]
subtables = [[Text] -> Value' l -> Doc DocClass
prettySection ([Text]
prefix [Text] -> [Text] -> [Text]
forall a. [a] -> [a] -> [a]
++ [Text
k]) Value' l
v | Bool -> Bool
not Bool
simpleToml, (Text
k,(l
_, Value' l
v)) <- [(Text, (l, Value' l))]
sections]

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

-- | Pretty-print as @line:col: message@
prettyLocated :: Located String -> String
prettyLocated :: Located String -> String
prettyLocated (Located Position
p String
s) = String -> String -> String -> String
forall r. PrintfType r => String -> r
printf String
"%s: %s" (Position -> String
prettyPosition Position
p) String
s

-- | Pretty-print as @line:col@
prettyPosition :: Position -> String
prettyPosition :: Position -> String
prettyPosition Position
p = String -> Int -> Int -> String
forall r. PrintfType r => String -> r
printf String
"%d:%d" (Position -> Int
posLine Position
p) (Position -> Int
posColumn Position
p)