{-# Language OverloadedStrings, GADTs #-}
module Toml.Pretty (
TomlDoc,
DocClass(..),
prettyToml,
prettyTomlOrdered,
prettyValue,
prettyToken,
prettySectionKind,
prettySimpleKey,
prettyKey,
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)
data DocClass
= TableClass
| KeyClass
| StringClass
| NumberClass
| DateClass
| BoolClass
deriving (ReadPrec [DocClass]
ReadPrec DocClass
Int -> ReadS DocClass
ReadS [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 -> String -> String
[DocClass] -> String -> String
DocClass -> String
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
showList :: [DocClass] -> String -> String
$cshowList :: [DocClass] -> String -> String
show :: DocClass -> String
$cshow :: DocClass -> String
showsPrec :: Int -> DocClass -> String -> String
$cshowsPrec :: Int -> DocClass -> String -> String
Show, DocClass -> DocClass -> Bool
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
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
Ord)
type TomlDoc = Doc DocClass
prettyKey :: NonEmpty String -> TomlDoc
prettyKey :: NonEmpty String -> Doc DocClass
prettyKey = forall ann. ann -> Doc ann -> Doc ann
annotate DocClass
KeyClass forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> NonEmpty a -> NonEmpty a
NonEmpty.intersperse forall ann. Doc ann
dot forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. String -> Doc a
prettySimpleKey
prettySimpleKey :: String -> Doc a
prettySimpleKey :: forall a. String -> Doc a
prettySimpleKey String
str
| Bool -> Bool
not (forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
str), forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Char -> Bool
isBareKey String
str = forall a. IsString a => String -> a
fromString String
str
| Bool
otherwise = forall a. IsString a => String -> a
fromString (String -> String
quoteString String
str)
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 forall a. Eq a => a -> a -> Bool
== Char
'-' Bool -> Bool -> Bool
|| Char
x forall a. Eq a => a -> a -> Bool
== Char
'_'
quoteString :: String -> String
quoteString :: String -> String
quoteString = (Char
'"'forall a. a -> [a] -> [a]
:) forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
go
where
go :: String -> String
go = \case
String
"" -> String
"\""
Char
'"' : String
xs -> Char
'\\' forall a. a -> [a] -> [a]
: Char
'"' forall a. a -> [a] -> [a]
: String -> String
go String
xs
Char
'\\' : String
xs -> Char
'\\' forall a. a -> [a] -> [a]
: Char
'\\' forall a. a -> [a] -> [a]
: String -> String
go String
xs
Char
'\b' : String
xs -> Char
'\\' forall a. a -> [a] -> [a]
: Char
'b' forall a. a -> [a] -> [a]
: String -> String
go String
xs
Char
'\f' : String
xs -> Char
'\\' forall a. a -> [a] -> [a]
: Char
'f' forall a. a -> [a] -> [a]
: String -> String
go String
xs
Char
'\n' : String
xs -> Char
'\\' forall a. a -> [a] -> [a]
: Char
'n' forall a. a -> [a] -> [a]
: String -> String
go String
xs
Char
'\r' : String
xs -> Char
'\\' forall a. a -> [a] -> [a]
: Char
'r' forall a. a -> [a] -> [a]
: String -> String
go String
xs
Char
'\t' : String
xs -> Char
'\\' forall a. a -> [a] -> [a]
: Char
't' forall a. a -> [a] -> [a]
: String -> String
go String
xs
Char
x : String
xs
| Char -> Bool
isPrint Char
x -> Char
x forall a. a -> [a] -> [a]
: String -> String
go String
xs
| Char
x forall a. Ord a => a -> a -> Bool
<= Char
'\xffff' -> forall r. PrintfType r => String -> r
printf String
"\\u%04X%s" (Char -> Int
ord Char
x) (String -> String
go String
xs)
| Bool
otherwise -> forall r. PrintfType r => String -> r
printf String
"\\U%08X%s" (Char -> Int
ord Char
x) (String -> String
go String
xs)
prettySectionKind :: SectionKind -> NonEmpty String -> TomlDoc
prettySectionKind :: SectionKind -> NonEmpty String -> Doc DocClass
prettySectionKind SectionKind
TableKind NonEmpty String
key =
forall ann. ann -> Doc ann -> Doc ann
annotate DocClass
TableClass (forall ann xxx. Doc ann -> Doc xxx
unAnnotate (forall ann. Doc ann
lbracket forall a. Semigroup a => a -> a -> a
<> NonEmpty String -> Doc DocClass
prettyKey NonEmpty String
key forall a. Semigroup a => a -> a -> a
<> forall ann. Doc ann
rbracket))
prettySectionKind SectionKind
ArrayTableKind NonEmpty String
key =
forall ann. ann -> Doc ann -> Doc ann
annotate DocClass
TableClass (forall ann xxx. Doc ann -> Doc xxx
unAnnotate (forall ann. Doc ann
lbracket forall a. Semigroup a => a -> a -> a
<> forall ann. Doc ann
lbracket forall a. Semigroup a => a -> a -> a
<> NonEmpty String -> Doc DocClass
prettyKey NonEmpty String
key forall a. Semigroup a => a -> a -> a
<> forall ann. Doc ann
rbracket forall a. Semigroup a => a -> a -> a
<> forall ann. Doc ann
rbracket))
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 -> Doc DocClass
prettyAssignment = NonEmpty String -> Value -> Doc DocClass
go forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a. Applicative f => a -> f a
pure
where
go :: NonEmpty String -> Value -> Doc DocClass
go NonEmpty String
ks (Table (forall k a. Map k a -> [(k, a)]
Map.assocs -> [(String
k,Value
v)])) = NonEmpty String -> Value -> Doc DocClass
go (forall a. a -> NonEmpty a -> NonEmpty a
NonEmpty.cons String
k NonEmpty String
ks) Value
v
go NonEmpty String
ks Value
v = NonEmpty String -> Doc DocClass
prettyKey (forall a. NonEmpty a -> NonEmpty a
NonEmpty.reverse NonEmpty String
ks) forall ann. Doc ann -> Doc ann -> Doc ann
<+> forall ann. Doc ann
equals forall ann. Doc ann -> Doc ann -> Doc ann
<+> Value -> Doc DocClass
prettyValue Value
v
prettyValue :: Value -> TomlDoc
prettyValue :: Value -> Doc DocClass
prettyValue = \case
Integer Integer
i -> forall ann. ann -> Doc ann -> Doc ann
annotate DocClass
NumberClass (forall a ann. Pretty a => a -> Doc ann
pretty Integer
i)
Float Double
f
| forall a. RealFloat a => a -> Bool
isNaN Double
f -> forall ann. ann -> Doc ann -> Doc ann
annotate DocClass
NumberClass Doc DocClass
"nan"
| forall a. RealFloat a => a -> Bool
isInfinite Double
f -> forall ann. ann -> Doc ann -> Doc ann
annotate DocClass
NumberClass (if Double
f forall a. Ord a => a -> a -> Bool
> Double
0 then Doc DocClass
"inf" else Doc DocClass
"-inf")
| Bool
otherwise -> forall ann. ann -> Doc ann -> Doc ann
annotate DocClass
NumberClass (forall a ann. Pretty a => a -> Doc ann
pretty Double
f)
Array [Value]
a -> forall ann. Doc ann -> Doc ann
align (forall ann. [Doc ann] -> Doc ann
list [Value -> Doc DocClass
prettyValue Value
v | Value
v <- [Value]
a])
Table Table
t -> forall ann. Doc ann
lbrace forall a. Semigroup a => a -> a -> a
<> forall (t :: * -> *) ann.
Foldable t =>
(Doc ann -> Doc ann -> Doc ann) -> t (Doc ann) -> Doc ann
concatWith (forall ann. Doc ann -> Doc ann -> Doc ann -> Doc ann
surround Doc DocClass
", ") [String -> Value -> Doc DocClass
prettyAssignment String
k Value
v | (String
k,Value
v) <- forall k a. Map k a -> [(k, a)]
Map.assocs Table
t] forall a. Semigroup a => a -> a -> a
<> forall ann. Doc ann
rbrace
Bool Bool
True -> forall ann. ann -> Doc ann -> Doc ann
annotate DocClass
BoolClass Doc DocClass
"true"
Bool Bool
False -> forall ann. ann -> Doc ann -> Doc ann
annotate DocClass
BoolClass Doc DocClass
"false"
String String
str -> forall ann. ann -> Doc ann -> Doc ann
annotate DocClass
StringClass (forall a. IsString a => String -> a
fromString (String -> String
quoteString String
str))
TimeOfDay TimeOfDay
tod -> forall ann. ann -> Doc ann -> Doc ann
annotate DocClass
DateClass (forall a. IsString a => String -> a
fromString (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) forall a. Eq a => a -> a -> Bool
== Int
0 ->
forall ann. ann -> Doc ann -> Doc ann
annotate DocClass
DateClass (forall a. IsString a => String -> a
fromString (forall t. FormatTime t => TimeLocale -> String -> t -> String
formatTime TimeLocale
defaultTimeLocale String
"%Y-%m-%dT%H:%M:%S%QZ" ZonedTime
zt))
| Bool
otherwise -> forall ann. ann -> Doc ann -> Doc ann
annotate DocClass
DateClass (forall a. IsString a => String -> a
fromString (forall t. FormatTime t => TimeLocale -> String -> t -> String
formatTime TimeLocale
defaultTimeLocale String
"%Y-%m-%dT%H:%M:%S%Q%Ez" ZonedTime
zt))
LocalTime LocalTime
lt -> forall ann. ann -> Doc ann -> Doc ann
annotate DocClass
DateClass (forall a. IsString a => String -> a
fromString (forall t. FormatTime t => TimeLocale -> String -> t -> String
formatTime TimeLocale
defaultTimeLocale String
"%Y-%m-%dT%H:%M:%S%Q" LocalTime
lt))
Day Day
d -> forall ann. ann -> Doc ann -> Doc ann
annotate DocClass
DateClass (forall a. IsString a => String -> a
fromString (forall t. FormatTime t => TimeLocale -> String -> t -> String
formatTime TimeLocale
defaultTimeLocale String
"%Y-%m-%d" Day
d))
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
x -> Table -> Bool
isSingularTable Table
x
Array [Value]
x -> forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Value]
x Bool -> Bool -> Bool
|| Bool -> Bool
not (forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Value -> Bool
isTable [Value]
x)
isTable :: Value -> Bool
isTable :: Value -> Bool
isTable Table {} = Bool
True
isTable Value
_ = Bool
False
isSingularTable :: Table -> Bool
isSingularTable :: Table -> Bool
isSingularTable (forall k a. Map k a -> [a]
Map.elems -> [Value
v]) = Value -> Bool
isAlwaysSimple Value
v
isSingularTable Table
_ = Bool
False
prettyToml ::
Table ->
TomlDoc
prettyToml :: Table -> Doc DocClass
prettyToml = KeyProjection -> SectionKind -> [String] -> Table -> Doc DocClass
prettyToml_ KeyProjection
NoProjection SectionKind
TableKind []
prettyTomlOrdered ::
Ord a =>
([String] -> String -> a) ->
Table ->
TomlDoc
prettyTomlOrdered :: forall a.
Ord a =>
([String] -> String -> a) -> Table -> Doc DocClass
prettyTomlOrdered [String] -> String -> a
proj = KeyProjection -> SectionKind -> [String] -> Table -> Doc DocClass
prettyToml_ (forall a. Ord a => ([String] -> String -> a) -> KeyProjection
KeyProjection [String] -> String -> a
proj) SectionKind
TableKind []
data KeyProjection where
NoProjection :: KeyProjection
KeyProjection :: Ord a => ([String] -> String -> a) -> KeyProjection
prettyToml_ :: KeyProjection -> SectionKind -> [String] -> Table -> TomlDoc
prettyToml_ :: KeyProjection -> SectionKind -> [String] -> Table -> Doc DocClass
prettyToml_ KeyProjection
mbKeyProj SectionKind
kind [String]
prefix Table
t = forall ann. [Doc ann] -> Doc ann
vcat ([Doc DocClass]
topLines forall a. [a] -> [a] -> [a]
++ [Doc DocClass]
subtables)
where
order :: [(String, Value)] -> [(String, Value)]
order =
case KeyProjection
mbKeyProj of
KeyProjection
NoProjection -> forall a. a -> a
id
KeyProjection [String] -> String -> a
f -> forall b a. Ord b => (a -> b) -> [a] -> [a]
sortOn ([String] -> String -> a
f [String]
prefix forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst)
([(String, Value)]
simple, [(String, Value)]
sections) = forall a. (a -> Bool) -> [a] -> ([a], [a])
partition (Value -> Bool
isAlwaysSimple forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd) ([(String, Value)] -> [(String, Value)]
order (forall k a. Map k a -> [(k, a)]
Map.assocs Table
t))
topLines :: [Doc DocClass]
topLines = [forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold [Doc DocClass]
topElts | let topElts :: [Doc DocClass]
topElts = [Doc DocClass]
headers forall a. [a] -> [a] -> [a]
++ [Doc DocClass]
assignments, Bool -> Bool
not (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Doc DocClass]
topElts)]
headers :: [Doc DocClass]
headers =
case forall a. [a] -> Maybe (NonEmpty a)
NonEmpty.nonEmpty [String]
prefix of
Just NonEmpty String
key | Bool -> Bool
not (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(String, Value)]
simple) Bool -> Bool -> Bool
|| forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(String, Value)]
sections Bool -> Bool -> Bool
|| SectionKind
kind forall a. Eq a => a -> a -> Bool
== SectionKind
ArrayTableKind ->
[SectionKind -> NonEmpty String -> Doc DocClass
prettySectionKind SectionKind
kind NonEmpty String
key forall a. Semigroup a => a -> a -> a
<> forall ann. Doc ann
hardline]
Maybe (NonEmpty String)
_ -> []
assignments :: [Doc DocClass]
assignments = [String -> Value -> Doc DocClass
prettyAssignment String
k Value
v forall a. Semigroup a => a -> a -> a
<> forall ann. Doc ann
hardline | (String
k,Value
v) <- [(String, Value)]
simple]
subtables :: [Doc DocClass]
subtables = [NonEmpty String -> Value -> Doc DocClass
prettySection ([String]
prefix forall a. [a] -> a -> NonEmpty a
`snoc` String
k) Value
v | (String
k,Value
v) <- [(String, Value)]
sections]
prettySection :: NonEmpty String -> Value -> Doc DocClass
prettySection NonEmpty String
key (Table Table
tab) =
KeyProjection -> SectionKind -> [String] -> Table -> Doc DocClass
prettyToml_ KeyProjection
mbKeyProj SectionKind
TableKind (forall a. NonEmpty a -> [a]
NonEmpty.toList NonEmpty String
key) Table
tab
prettySection NonEmpty String
key (Array [Value]
a) =
forall ann. [Doc ann] -> Doc ann
vcat [KeyProjection -> SectionKind -> [String] -> Table -> Doc DocClass
prettyToml_ KeyProjection
mbKeyProj SectionKind
ArrayTableKind (forall a. NonEmpty a -> [a]
NonEmpty.toList NonEmpty String
key) Table
tab | Table Table
tab <- [Value]
a]
prettySection NonEmpty String
_ Value
_ = forall a. HasCallStack => String -> a
error String
"prettySection applied to simple value"
snoc :: [a] -> a -> NonEmpty a
snoc :: forall a. [a] -> a -> NonEmpty a
snoc [] a
y = a
y forall a. a -> [a] -> NonEmpty a
:| []
snoc (a
x : [a]
xs) a
y = a
x forall a. a -> [a] -> NonEmpty a
:| [a]
xs forall a. [a] -> [a] -> [a]
++ [a
y]
prettySemanticError :: SemanticError -> String
prettySemanticError :: SemanticError -> String
prettySemanticError (SemanticError String
key SemanticErrorKind
kind) =
forall r. PrintfType r => String -> r
printf String
"key error: %s %s" (forall a. Show a => a -> String
show (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"
prettyMatchMessage :: MatchMessage -> String
prettyMatchMessage :: MatchMessage -> String
prettyMatchMessage (MatchMessage [Scope]
scope String
msg) =
String
msg forall a. [a] -> [a] -> [a]
++ String
" in top" forall a. [a] -> [a] -> [a]
++ forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Scope -> String -> String
f String
"" [Scope]
scope
where
f :: Scope -> String -> String
f (ScopeIndex Int
i) = (Char
'[' forall a. a -> [a] -> [a]
:) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> String -> String
shows Int
i forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char
']'forall a. a -> [a] -> [a]
:)
f (ScopeKey String
key) = (Char
'.' forall a. a -> [a] -> [a]
:) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> String -> String
shows (forall a. String -> Doc a
prettySimpleKey String
key)