{-# LANGUAGE PatternSynonyms #-}
{-|
Module      : Toml
Description : TOML parsing, printing, and codecs
Copyright   : (c) Eric Mertens, 2023
License     : ISC
Maintainer  : emertens@gmail.com

This is the high-level interface to the toml-parser library.
It enables parsing, printing, and conversion into and out of
application-specific representations.

This parser implements TOML 1.1.0 <https://toml.io/en/v1.1.0>
as carefully as possible.

Use "Toml.Schema" to implement functions mapping between TOML
values and your application types.

Use "Toml.Syntax" and "Toml.Semantics" for low-level TOML syntax
processing and semantic validation. Most applications will not
need to use these modules directly unless the application is
about TOML itself.

The types and functions of this package are parameterized over
an annotation type in order to allow applications to provide
detailed feedback messages tracked back to specific source
locations in an original TOML file. While the default annotation
is a simple file position, some applications might upgrade this
annotation to track multiple file names or synthetically generated
sources. Other applications won't need source location and can
replace annotations with a simple unit type.

-}
module Toml (

    -- * Types
    Table,
    Value,

    -- * Located types
    Located(..),
    Position(..),
    Table'(..),
    Value'(..),
    valueAnn,
    valueType,
    forgetTableAnns,
    forgetValueAnns,

    -- * Parsing
    decode',
    decode,
    parse,
    DecodeError,
    Result(..),

    -- * Printing
    encode,
    prettyToml,
    DocClass(..),

    -- * Error rendering
    prettyDecodeError,
    prettyLocated,
    prettyMatchMessage,
    prettySemanticError,
    ) where

import Data.Text (Text)
import Text.Printf (printf)
import Toml.Pretty
import Toml.Schema
import Toml.Semantics
import Toml.Syntax

-- | Parse a TOML formatted 'String' or report a structured error message.
parse' :: Text -> Either DecodeError (Table' Position)
parse' :: Text -> Either DecodeError (Table' Position)
parse' Text
str =
    case Text -> Either (Located [Char]) [Expr Position]
parseRawToml Text
str of
        Left Located [Char]
e -> DecodeError -> Either DecodeError (Table' Position)
forall a b. a -> Either a b
Left (Located [Char] -> DecodeError
ErrSyntax Located [Char]
e)
        Right [Expr Position]
exprs ->
            case [Expr Position]
-> Either (SemanticError Position) (Table' Position)
forall a. [Expr a] -> Either (SemanticError a) (Table' a)
semantics [Expr Position]
exprs of
                Left SemanticError Position
e -> DecodeError -> Either DecodeError (Table' Position)
forall a b. a -> Either a b
Left (SemanticError Position -> DecodeError
ErrSemantics SemanticError Position
e)
                Right Table' Position
tab -> Table' Position -> Either DecodeError (Table' Position)
forall a b. b -> Either a b
Right Table' Position
tab

-- | Parse a TOML formatted 'String' or report a human-readable error message.
parse :: Text -> Either String (Table' Position)
parse :: Text -> Either [Char] (Table' Position)
parse Text
str =
    case Text -> Either DecodeError (Table' Position)
parse' Text
str of
        Left DecodeError
e -> [Char] -> Either [Char] (Table' Position)
forall a b. a -> Either a b
Left (DecodeError -> [Char]
prettyDecodeError DecodeError
e)
        Right Table' Position
x -> Table' Position -> Either [Char] (Table' Position)
forall a b. b -> Either a b
Right Table' Position
x

-- | Sum of errors that can occur during TOML decoding
data DecodeError
    = ErrSyntax    (Located String)         -- ^ Error during the lexer/parser phase
    | ErrSemantics (SemanticError Position) -- ^ Error during TOML validation
    | ErrSchema    (MatchMessage Position)  -- ^ Error during schema matching

-- | Decode TOML syntax into an application value.
decode' :: FromValue a => Text -> Result DecodeError a
decode' :: forall a. FromValue a => Text -> Result DecodeError a
decode' Text
str =
    case Text -> Either DecodeError (Table' Position)
parse' Text
str of
        Left DecodeError
e -> [DecodeError] -> Result DecodeError a
forall e a. [e] -> Result e a
Failure [DecodeError
e]
        Right Table' Position
tab ->
            case Matcher Position a -> Result (MatchMessage Position) a
forall l a. Matcher l a -> Result (MatchMessage l) a
runMatcher (Value' Position -> Matcher Position a
forall l. Value' l -> Matcher l a
forall a l. FromValue a => Value' l -> Matcher l a
fromValue (Position -> Table' Position -> Value' Position
forall a. a -> Table' a -> Value' a
Table' Position
startPos Table' Position
tab)) of
                Failure [MatchMessage Position]
es -> [DecodeError] -> Result DecodeError a
forall e a. [e] -> Result e a
Failure (MatchMessage Position -> DecodeError
ErrSchema (MatchMessage Position -> DecodeError)
-> [MatchMessage Position] -> [DecodeError]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [MatchMessage Position]
es)
                Success [MatchMessage Position]
ws a
x -> [DecodeError] -> a -> Result DecodeError a
forall e a. [e] -> a -> Result e a
Success (MatchMessage Position -> DecodeError
ErrSchema (MatchMessage Position -> DecodeError)
-> [MatchMessage Position] -> [DecodeError]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [MatchMessage Position]
ws) a
x

-- | Wrapper rending error and warning messages into human-readable strings.
decode :: FromValue a => Text -> Result String a
decode :: forall a. FromValue a => Text -> Result [Char] a
decode Text
str =
    case Text -> Result DecodeError a
forall a. FromValue a => Text -> Result DecodeError a
decode' Text
str of
        Failure [DecodeError]
e -> [[Char]] -> Result [Char] a
forall e a. [e] -> Result e a
Failure ((DecodeError -> [Char]) -> [DecodeError] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map DecodeError -> [Char]
prettyDecodeError [DecodeError]
e)
        Success [DecodeError]
w a
x -> [[Char]] -> a -> Result [Char] a
forall e a. [e] -> a -> Result e a
Success ((DecodeError -> [Char]) -> [DecodeError] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map DecodeError -> [Char]
prettyDecodeError [DecodeError]
w) a
x

-- | Use the 'ToTable' instance to encode a value to a TOML string.
encode :: ToTable a => a -> TomlDoc
encode :: forall a. ToTable a => a -> TomlDoc
encode = Table' () -> TomlDoc
forall a. Table' a -> TomlDoc
prettyToml (Table' () -> TomlDoc) -> (a -> Table' ()) -> a -> TomlDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Table' ()
forall a. ToTable a => a -> Table' ()
toTable

-- | Human-readable representation of a 'DecodeError'
prettyDecodeError :: DecodeError -> String
prettyDecodeError :: DecodeError -> [Char]
prettyDecodeError = \case
    ErrSyntax Located [Char]
e -> Located [Char] -> [Char]
prettyLocated Located [Char]
e
    ErrSemantics SemanticError Position
e -> SemanticError Position -> [Char]
prettySemanticError SemanticError Position
e
    ErrSchema MatchMessage Position
e -> MatchMessage Position -> [Char]
prettyMatchMessage MatchMessage Position
e

-- | Render a TOML decoding error as a human-readable string.
prettyMatchMessage :: MatchMessage Position -> String
prettyMatchMessage :: MatchMessage Position -> [Char]
prettyMatchMessage (MatchMessage Maybe Position
loc [Scope]
scope [Char]
msg) = [Char]
prefix [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
msg [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" in " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
path
    where
        prefix :: [Char]
prefix =
            case Maybe Position
loc of
                Maybe Position
Nothing -> [Char]
""
                Just Position
l -> Position -> [Char]
prettyPosition Position
l [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
": "
        path :: [Char]
path =
            case [Scope]
scope of
                [] -> [Char]
"<top-level>"
                ScopeKey Text
key : [Scope]
scope' -> Doc (ZonkAny 2) -> [Char] -> [Char]
forall a. Show a => a -> [Char] -> [Char]
shows (Text -> Doc (ZonkAny 2)
forall a. Text -> Doc a
prettySimpleKey Text
key) ((Scope -> [Char] -> [Char]) -> [Char] -> [Scope] -> [Char]
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Scope -> [Char] -> [Char]
f [Char]
"" [Scope]
scope')
                ScopeIndex Int
i : [Scope]
scope' -> (Scope -> [Char] -> [Char]) -> [Char] -> [Scope] -> [Char]
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Scope -> [Char] -> [Char]
f [Char]
"" (Int -> Scope
ScopeIndex Int
i Scope -> [Scope] -> [Scope]
forall a. a -> [a] -> [a]
: [Scope]
scope') -- should be impossible

        f :: Scope -> [Char] -> [Char]
f (ScopeIndex Int
i) = Char -> [Char] -> [Char]
showChar Char
'[' ([Char] -> [Char]) -> ([Char] -> [Char]) -> [Char] -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> [Char] -> [Char]
forall a. Show a => a -> [Char] -> [Char]
shows Int
i ([Char] -> [Char]) -> ([Char] -> [Char]) -> [Char] -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> [Char] -> [Char]
showChar Char
']'
        f (ScopeKey Text
key) = Char -> [Char] -> [Char]
showChar Char
'.' ([Char] -> [Char]) -> ([Char] -> [Char]) -> [Char] -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Doc (ZonkAny 1) -> [Char] -> [Char]
forall a. Show a => a -> [Char] -> [Char]
shows (Text -> Doc (ZonkAny 1)
forall a. Text -> Doc a
prettySimpleKey Text
key)

-- | Render a semantic TOML error in a human-readable string.
prettySemanticError :: SemanticError Position -> String
prettySemanticError :: SemanticError Position -> [Char]
prettySemanticError (SemanticError Position
a Text
key SemanticErrorKind
kind) =
    [Char] -> [Char] -> [Char] -> [Char] -> [Char]
forall r. PrintfType r => [Char] -> r
printf [Char]
"%s: key error: %s %s" (Position -> [Char]
prettyPosition Position
a) (Doc (ZonkAny 0) -> [Char]
forall a. Show a => a -> [Char]
show (Text -> Doc (ZonkAny 0)
forall a. Text -> Doc a
prettySimpleKey Text
key))
    case SemanticErrorKind
kind of
        SemanticErrorKind
AlreadyAssigned -> [Char]
"is already assigned" :: String
        SemanticErrorKind
ClosedTable     -> [Char]
"is a closed table"
        SemanticErrorKind
ImplicitlyTable -> [Char]
"is already implicitly defined to be a table"