{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}

module TOML.Error (
  TOMLError (..),
  NormalizeError (..),
  DecodeContext,
  ContextItem (..),
  DecodeError (..),
  renderTOMLError,
) where

import Control.Exception (Exception (..))
import Data.List.NonEmpty (NonEmpty)
import qualified Data.List.NonEmpty as NonEmpty
import Data.Text (Text)
import qualified Data.Text as Text

import TOML.Value (Table, Value (..), renderValue)

data TOMLError
  = ParseError Text
  | NormalizeError NormalizeError
  | DecodeError DecodeContext DecodeError
  deriving (Int -> TOMLError -> ShowS
[TOMLError] -> ShowS
TOMLError -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [TOMLError] -> ShowS
$cshowList :: [TOMLError] -> ShowS
show :: TOMLError -> String
$cshow :: TOMLError -> String
showsPrec :: Int -> TOMLError -> ShowS
$cshowsPrec :: Int -> TOMLError -> ShowS
Show, TOMLError -> TOMLError -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: TOMLError -> TOMLError -> Bool
$c/= :: TOMLError -> TOMLError -> Bool
== :: TOMLError -> TOMLError -> Bool
$c== :: TOMLError -> TOMLError -> Bool
Eq)

instance Exception TOMLError where
  displayException :: TOMLError -> String
displayException = Text -> String
Text.unpack forall b c a. (b -> c) -> (a -> b) -> a -> c
. TOMLError -> Text
renderTOMLError

data NormalizeError
  = -- | When a key is defined twice, e.g.
    --
    -- @
    -- name = 'First'
    -- name = 'Second'
    -- @
    DuplicateKeyError
      { NormalizeError -> NonEmpty Text
_path :: NonEmpty Text
      , NormalizeError -> Value
_existingValue :: Value
      , NormalizeError -> Value
_valueToSet :: Value
      }
  | -- | When a section is defined twice, e.g.
    --
    -- @
    -- [foo]
    -- a = 1
    --
    -- [foo]
    -- b = 2
    -- @
    DuplicateSectionError
      { NormalizeError -> NonEmpty Text
_sectionKey :: NonEmpty Text
      }
  | -- | When a key attempts to extend an invalid table
    --
    -- @
    -- a = {}
    -- [a.b]
    --
    -- b = {}
    -- b.a = 1
    --
    -- c.x.x = 1
    -- [c.a]
    -- @
    ExtendTableError
      { _path :: NonEmpty Text
      , NormalizeError -> NonEmpty Text
_originalKey :: NonEmpty Text
      }
  | -- | When a section attempts to extend a table within an inline array
    --
    -- @
    -- a = [{ b = 1 }]
    -- [a.c]
    -- @
    ExtendTableInInlineArrayError
      { _path :: NonEmpty Text
      , _originalKey :: NonEmpty Text
      }
  | -- | When a key is already defined, but attempting to create an
    -- implicit array at the same key, e.g.
    --
    -- @
    -- list = [1, 2, 3]
    --
    -- [[list]]
    -- a = 1
    -- @
    ImplicitArrayForDefinedKeyError
      { _path :: NonEmpty Text
      , _existingValue :: Value
      , NormalizeError -> Table
_tableSection :: Table
      }
  | -- | When a non-table value is already defined in a nested key, e.g.
    --
    -- @
    -- a.b = 1
    -- a.b.c.d = 2
    -- @
    NonTableInNestedKeyError
      { _path :: NonEmpty Text
      , _existingValue :: Value
      , _originalKey :: NonEmpty Text
      , NormalizeError -> Value
_originalValue :: Value
      }
  | -- | When a non-table value is already defined in a nested implicit array, e.g.
    --
    -- @
    -- a.b = 1
    --
    -- [[a.b.c]]
    -- d = 2
    -- @
    NonTableInNestedImplicitArrayError
      { _path :: NonEmpty Text
      , _existingValue :: Value
      , _sectionKey :: NonEmpty Text
      , _tableSection :: Table
      }
  deriving (Int -> NormalizeError -> ShowS
[NormalizeError] -> ShowS
NormalizeError -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [NormalizeError] -> ShowS
$cshowList :: [NormalizeError] -> ShowS
show :: NormalizeError -> String
$cshow :: NormalizeError -> String
showsPrec :: Int -> NormalizeError -> ShowS
$cshowsPrec :: Int -> NormalizeError -> ShowS
Show, NormalizeError -> NormalizeError -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: NormalizeError -> NormalizeError -> Bool
$c/= :: NormalizeError -> NormalizeError -> Bool
== :: NormalizeError -> NormalizeError -> Bool
$c== :: NormalizeError -> NormalizeError -> Bool
Eq)

type DecodeContext = [ContextItem]

data ContextItem = Key Text | Index Int
  deriving (Int -> ContextItem -> ShowS
DecodeContext -> ShowS
ContextItem -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: DecodeContext -> ShowS
$cshowList :: DecodeContext -> ShowS
show :: ContextItem -> String
$cshow :: ContextItem -> String
showsPrec :: Int -> ContextItem -> ShowS
$cshowsPrec :: Int -> ContextItem -> ShowS
Show, ContextItem -> ContextItem -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ContextItem -> ContextItem -> Bool
$c/= :: ContextItem -> ContextItem -> Bool
== :: ContextItem -> ContextItem -> Bool
$c== :: ContextItem -> ContextItem -> Bool
Eq)

data DecodeError
  = MissingField
  | InvalidValue Text Value
  | TypeMismatch Value
  | OtherDecodeError Text
  deriving (Int -> DecodeError -> ShowS
[DecodeError] -> ShowS
DecodeError -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [DecodeError] -> ShowS
$cshowList :: [DecodeError] -> ShowS
show :: DecodeError -> String
$cshow :: DecodeError -> String
showsPrec :: Int -> DecodeError -> ShowS
$cshowsPrec :: Int -> DecodeError -> ShowS
Show, DecodeError -> DecodeError -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: DecodeError -> DecodeError -> Bool
$c/= :: DecodeError -> DecodeError -> Bool
== :: DecodeError -> DecodeError -> Bool
$c== :: DecodeError -> DecodeError -> Bool
Eq)

renderTOMLError :: TOMLError -> Text
renderTOMLError :: TOMLError -> Text
renderTOMLError = \case
  ParseError Text
s -> Text
s
  NormalizeError DuplicateKeyError{NonEmpty Text
Value
_valueToSet :: Value
_existingValue :: Value
_path :: NonEmpty Text
_valueToSet :: NormalizeError -> Value
_existingValue :: NormalizeError -> Value
_path :: NormalizeError -> NonEmpty Text
..} ->
    [Text] -> Text
Text.unlines
      [ Text
"Could not add value to path " forall a. Semigroup a => a -> a -> a
<> NonEmpty Text -> Text
showPath NonEmpty Text
_path forall a. Semigroup a => a -> a -> a
<> Text
":"
      , Text
"  Existing value: " forall a. Semigroup a => a -> a -> a
<> Value -> Text
renderValue Value
_existingValue
      , Text
"  Value to set: " forall a. Semigroup a => a -> a -> a
<> Value -> Text
renderValue Value
_valueToSet
      ]
  NormalizeError DuplicateSectionError{NonEmpty Text
_sectionKey :: NonEmpty Text
_sectionKey :: NormalizeError -> NonEmpty Text
..} -> Text
"Found duplicate section: " forall a. Semigroup a => a -> a -> a
<> NonEmpty Text -> Text
showPath NonEmpty Text
_sectionKey
  NormalizeError ExtendTableError{NonEmpty Text
_originalKey :: NonEmpty Text
_path :: NonEmpty Text
_originalKey :: NormalizeError -> NonEmpty Text
_path :: NormalizeError -> NonEmpty Text
..} ->
    [Text] -> Text
Text.unlines
      [ Text
"Invalid table key: " forall a. Semigroup a => a -> a -> a
<> NonEmpty Text -> Text
showPath NonEmpty Text
_originalKey
      , Text
"  Table already statically defined at " forall a. Semigroup a => a -> a -> a
<> NonEmpty Text -> Text
showPath NonEmpty Text
_path
      ]
  NormalizeError ExtendTableInInlineArrayError{NonEmpty Text
_originalKey :: NonEmpty Text
_path :: NonEmpty Text
_originalKey :: NormalizeError -> NonEmpty Text
_path :: NormalizeError -> NonEmpty Text
..} ->
    [Text] -> Text
Text.unlines
      [ Text
"Invalid table key: " forall a. Semigroup a => a -> a -> a
<> NonEmpty Text -> Text
showPath NonEmpty Text
_originalKey
      , Text
"  Table defined in inline array at " forall a. Semigroup a => a -> a -> a
<> NonEmpty Text -> Text
showPath NonEmpty Text
_path
      ]
  NormalizeError ImplicitArrayForDefinedKeyError{NonEmpty Text
Table
Value
_tableSection :: Table
_existingValue :: Value
_path :: NonEmpty Text
_tableSection :: NormalizeError -> Table
_existingValue :: NormalizeError -> Value
_path :: NormalizeError -> NonEmpty Text
..} ->
    [Text] -> Text
Text.unlines
      [ Text
"Could not create implicit array at path " forall a. Semigroup a => a -> a -> a
<> NonEmpty Text -> Text
showPath NonEmpty Text
_path forall a. Semigroup a => a -> a -> a
<> Text
":"
      , Text
"  Existing value: " forall a. Semigroup a => a -> a -> a
<> Value -> Text
renderValue Value
_existingValue
      , Text
"  Array table section: " forall a. Semigroup a => a -> a -> a
<> Value -> Text
renderValue (Table -> Value
Table Table
_tableSection)
      ]
  NormalizeError NonTableInNestedKeyError{NonEmpty Text
Value
_originalValue :: Value
_originalKey :: NonEmpty Text
_existingValue :: Value
_path :: NonEmpty Text
_originalValue :: NormalizeError -> Value
_originalKey :: NormalizeError -> NonEmpty Text
_existingValue :: NormalizeError -> Value
_path :: NormalizeError -> NonEmpty Text
..} ->
    [Text] -> Text
Text.unlines
      [ Text
"Found non-Table at path " forall a. Semigroup a => a -> a -> a
<> NonEmpty Text -> Text
showPath NonEmpty Text
_path forall a. Semigroup a => a -> a -> a
<> Text
" when defining nested key " forall a. Semigroup a => a -> a -> a
<> NonEmpty Text -> Text
showPath NonEmpty Text
_originalKey forall a. Semigroup a => a -> a -> a
<> Text
":"
      , Text
"  Existing value: " forall a. Semigroup a => a -> a -> a
<> Value -> Text
renderValue Value
_existingValue
      , Text
"  Original value: " forall a. Semigroup a => a -> a -> a
<> Value -> Text
renderValue Value
_originalValue
      ]
  NormalizeError NonTableInNestedImplicitArrayError{NonEmpty Text
Table
Value
_tableSection :: Table
_sectionKey :: NonEmpty Text
_existingValue :: Value
_path :: NonEmpty Text
_tableSection :: NormalizeError -> Table
_sectionKey :: NormalizeError -> NonEmpty Text
_existingValue :: NormalizeError -> Value
_path :: NormalizeError -> NonEmpty Text
..} ->
    [Text] -> Text
Text.unlines
      [ Text
"Found non-Table at path " forall a. Semigroup a => a -> a -> a
<> NonEmpty Text -> Text
showPath NonEmpty Text
_path forall a. Semigroup a => a -> a -> a
<> Text
" when initializing implicit array at path " forall a. Semigroup a => a -> a -> a
<> NonEmpty Text -> Text
showPath NonEmpty Text
_sectionKey forall a. Semigroup a => a -> a -> a
<> Text
":"
      , Text
"  Existing value: " forall a. Semigroup a => a -> a -> a
<> Value -> Text
renderValue Value
_existingValue
      , Text
"  Array table section: " forall a. Semigroup a => a -> a -> a
<> Value -> Text
renderValue (Table -> Value
Table Table
_tableSection)
      ]
  DecodeError DecodeContext
ctx DecodeError
e -> Text
"Decode error at '" forall a. Semigroup a => a -> a -> a
<> DecodeContext -> Text
renderDecodeContext DecodeContext
ctx forall a. Semigroup a => a -> a -> a
<> Text
"': " forall a. Semigroup a => a -> a -> a
<> DecodeError -> Text
renderDecodeError DecodeError
e
  where
    showPath :: NonEmpty Text -> Text
showPath NonEmpty Text
path = Text
"\"" forall a. Semigroup a => a -> a -> a
<> Text -> [Text] -> Text
Text.intercalate Text
"." (forall a. NonEmpty a -> [a]
NonEmpty.toList NonEmpty Text
path) forall a. Semigroup a => a -> a -> a
<> Text
"\""

    renderDecodeError :: DecodeError -> Text
renderDecodeError = \case
      DecodeError
MissingField -> Text
"Field does not exist"
      InvalidValue Text
msg Value
v -> Text
"Invalid value: " forall a. Semigroup a => a -> a -> a
<> Text
msg forall a. Semigroup a => a -> a -> a
<> Text
": " forall a. Semigroup a => a -> a -> a
<> Value -> Text
renderValue Value
v
      TypeMismatch Value
v -> Text
"Type mismatch, got: " forall a. Semigroup a => a -> a -> a
<> Value -> Text
renderValue Value
v
      OtherDecodeError Text
msg -> Text
msg

    renderDecodeContext :: DecodeContext -> Text
renderDecodeContext = [Text] -> Text
Text.concat forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map ContextItem -> Text
renderContextItem
    renderContextItem :: ContextItem -> Text
renderContextItem = \case
      Key Text
k -> Text
"." forall a. Semigroup a => a -> a -> a
<> Text
k
      Index Int
i -> Text
"[" forall a. Semigroup a => a -> a -> a
<> String -> Text
Text.pack (forall a. Show a => a -> String
show Int
i) forall a. Semigroup a => a -> a -> a
<> Text
"]"