{-# Language OverloadedStrings, GADTs #-}
module Toml.Pretty (
TomlDoc,
DocClass(..),
prettyToml,
prettyTomlOrdered,
prettyValue,
prettyToken,
prettySectionKind,
prettySimpleKey,
prettyKey,
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)
data DocClass
= TableClass
| KeyClass
| StringClass
| NumberClass
| DateClass
| BoolClass
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)
type TomlDoc = Doc DocClass
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
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)
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
'_'
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
"\""
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)
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
"\"\"\""
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)
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))
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
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))
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
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)
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
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)
isTable :: Value -> Bool
isTable :: Value -> Bool
isTable Table {} = Bool
True
isTable Value
_ = Bool
False
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
prettyToml ::
Table ->
TomlDoc
prettyToml :: Table -> TomlDoc
prettyToml = KeyProjection -> SectionKind -> [String] -> Table -> TomlDoc
prettyToml_ KeyProjection
NoProjection SectionKind
TableKind []
prettyTomlOrdered ::
Ord a =>
([String] -> String -> a) ->
Table ->
TomlDoc
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 []
data KeyProjection where
NoProjection :: KeyProjection
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)
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"
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"
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