{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedRecordDot #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE NoFieldSelectors #-}

module KDL.Decoder.Internal.Error (
  DecodeError (..),
  BaseDecodeError,
  DecodeErrorKind (..),
  Context,
  ContextItem (..),
  renderDecodeError,
) where

import Data.List.NonEmpty (NonEmpty)
import Data.List.NonEmpty qualified as NonEmpty
import Data.Map qualified as Map
import Data.Text (Text)
import Data.Text qualified as Text
import KDL.Render (
  renderIdentifier,
  renderValue,
 )
import KDL.Types (
  Identifier,
  Value,
 )

data DecodeError = DecodeError
  { DecodeError -> Maybe FilePath
filepath :: Maybe FilePath
  , DecodeError -> NonEmpty ([ContextItem], DecodeErrorKind)
errors :: NonEmpty BaseDecodeError
  }
  deriving (Int -> DecodeError -> ShowS
[DecodeError] -> ShowS
DecodeError -> FilePath
(Int -> DecodeError -> ShowS)
-> (DecodeError -> FilePath)
-> ([DecodeError] -> ShowS)
-> Show DecodeError
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> DecodeError -> ShowS
showsPrec :: Int -> DecodeError -> ShowS
$cshow :: DecodeError -> FilePath
show :: DecodeError -> FilePath
$cshowList :: [DecodeError] -> ShowS
showList :: [DecodeError] -> ShowS
Show, DecodeError -> DecodeError -> Bool
(DecodeError -> DecodeError -> Bool)
-> (DecodeError -> DecodeError -> Bool) -> Eq DecodeError
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: DecodeError -> DecodeError -> Bool
== :: DecodeError -> DecodeError -> Bool
$c/= :: DecodeError -> DecodeError -> Bool
/= :: DecodeError -> DecodeError -> Bool
Eq)

type BaseDecodeError = (Context, DecodeErrorKind)
type Context = [ContextItem]

data ContextItem
  = ContextNode
      { ContextItem -> Identifier
name :: Identifier
      , ContextItem -> Int
index :: Int
      }
  | ContextArg
      { index :: Int
      }
  | ContextProp
      { name :: Identifier
      }
  deriving (Int -> ContextItem -> ShowS
[ContextItem] -> ShowS
ContextItem -> FilePath
(Int -> ContextItem -> ShowS)
-> (ContextItem -> FilePath)
-> ([ContextItem] -> ShowS)
-> Show ContextItem
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ContextItem -> ShowS
showsPrec :: Int -> ContextItem -> ShowS
$cshow :: ContextItem -> FilePath
show :: ContextItem -> FilePath
$cshowList :: [ContextItem] -> ShowS
showList :: [ContextItem] -> ShowS
Show, ContextItem -> ContextItem -> Bool
(ContextItem -> ContextItem -> Bool)
-> (ContextItem -> ContextItem -> Bool) -> Eq ContextItem
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ContextItem -> ContextItem -> Bool
== :: ContextItem -> ContextItem -> Bool
$c/= :: ContextItem -> ContextItem -> Bool
/= :: ContextItem -> ContextItem -> Bool
Eq, Eq ContextItem
Eq ContextItem =>
(ContextItem -> ContextItem -> Ordering)
-> (ContextItem -> ContextItem -> Bool)
-> (ContextItem -> ContextItem -> Bool)
-> (ContextItem -> ContextItem -> Bool)
-> (ContextItem -> ContextItem -> Bool)
-> (ContextItem -> ContextItem -> ContextItem)
-> (ContextItem -> ContextItem -> ContextItem)
-> Ord ContextItem
ContextItem -> ContextItem -> Bool
ContextItem -> ContextItem -> Ordering
ContextItem -> ContextItem -> ContextItem
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 :: ContextItem -> ContextItem -> Ordering
compare :: ContextItem -> ContextItem -> Ordering
$c< :: ContextItem -> ContextItem -> Bool
< :: ContextItem -> ContextItem -> Bool
$c<= :: ContextItem -> ContextItem -> Bool
<= :: ContextItem -> ContextItem -> Bool
$c> :: ContextItem -> ContextItem -> Bool
> :: ContextItem -> ContextItem -> Bool
$c>= :: ContextItem -> ContextItem -> Bool
>= :: ContextItem -> ContextItem -> Bool
$cmax :: ContextItem -> ContextItem -> ContextItem
max :: ContextItem -> ContextItem -> ContextItem
$cmin :: ContextItem -> ContextItem -> ContextItem
min :: ContextItem -> ContextItem -> ContextItem
Ord)

data DecodeErrorKind
  = DecodeError_Custom Text
  | DecodeError_ParseError Text
  | DecodeError_ExpectedNode {DecodeErrorKind -> Text
name :: Text, DecodeErrorKind -> Int
index :: Int}
  | DecodeError_ExpectedArg {index :: Int}
  | DecodeError_ExpectedProp {name :: Text}
  | DecodeError_MismatchedAnn {DecodeErrorKind -> Identifier
givenAnn :: Identifier, DecodeErrorKind -> [Text]
validAnns :: [Text]}
  | DecodeError_ValueDecodeFail {DecodeErrorKind -> Text
expectedType :: Text, DecodeErrorKind -> Value
value :: Value}
  | DecodeError_UnexpectedNode {DecodeErrorKind -> Identifier
identifier :: Identifier, index :: Int}
  | DecodeError_UnexpectedArg {index :: Int, value :: Value}
  | DecodeError_UnexpectedProp {identifier :: Identifier, value :: Value}
  deriving (Int -> DecodeErrorKind -> ShowS
[DecodeErrorKind] -> ShowS
DecodeErrorKind -> FilePath
(Int -> DecodeErrorKind -> ShowS)
-> (DecodeErrorKind -> FilePath)
-> ([DecodeErrorKind] -> ShowS)
-> Show DecodeErrorKind
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> DecodeErrorKind -> ShowS
showsPrec :: Int -> DecodeErrorKind -> ShowS
$cshow :: DecodeErrorKind -> FilePath
show :: DecodeErrorKind -> FilePath
$cshowList :: [DecodeErrorKind] -> ShowS
showList :: [DecodeErrorKind] -> ShowS
Show, DecodeErrorKind -> DecodeErrorKind -> Bool
(DecodeErrorKind -> DecodeErrorKind -> Bool)
-> (DecodeErrorKind -> DecodeErrorKind -> Bool)
-> Eq DecodeErrorKind
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: DecodeErrorKind -> DecodeErrorKind -> Bool
== :: DecodeErrorKind -> DecodeErrorKind -> Bool
$c/= :: DecodeErrorKind -> DecodeErrorKind -> Bool
/= :: DecodeErrorKind -> DecodeErrorKind -> Bool
Eq)

renderDecodeError :: DecodeError -> Text
renderDecodeError :: DecodeError -> Text
renderDecodeError DecodeError
decodeError =
  Text -> [Text] -> Text
Text.intercalate Text
"\n"
    ([Text] -> Text)
-> (NonEmpty ([ContextItem], DecodeErrorKind) -> [Text])
-> NonEmpty ([ContextItem], DecodeErrorKind)
-> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (([ContextItem], [DecodeErrorKind]) -> [Text])
-> [([ContextItem], [DecodeErrorKind])] -> [Text]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ([ContextItem], [DecodeErrorKind]) -> [Text]
renderCtxErrors
    ([([ContextItem], [DecodeErrorKind])] -> [Text])
-> (NonEmpty ([ContextItem], DecodeErrorKind)
    -> [([ContextItem], [DecodeErrorKind])])
-> NonEmpty ([ContextItem], DecodeErrorKind)
-> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NonEmpty ([ContextItem], DecodeErrorKind)
-> [([ContextItem], [DecodeErrorKind])]
forall {k} {a}. Ord k => NonEmpty (k, a) -> [(k, [a])]
groupCtxErrors
    (NonEmpty ([ContextItem], DecodeErrorKind) -> Text)
-> NonEmpty ([ContextItem], DecodeErrorKind) -> Text
forall a b. (a -> b) -> a -> b
$ DecodeError
decodeError.errors
 where
  -- Group errors with the same contexts together
  groupCtxErrors :: NonEmpty (k, a) -> [(k, [a])]
groupCtxErrors NonEmpty (k, a)
es =
    Map k [a] -> [(k, [a])]
forall k a. Map k a -> [(k, a)]
Map.toAscList (Map k [a] -> [(k, [a])])
-> ([(k, [a])] -> Map k [a]) -> [(k, [a])] -> [(k, [a])]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([a] -> [a] -> [a]) -> [(k, [a])] -> Map k [a]
forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
Map.fromListWith [a] -> [a] -> [a]
forall a. Semigroup a => a -> a -> a
(<>) ([(k, [a])] -> [(k, [a])]) -> [(k, [a])] -> [(k, [a])]
forall a b. (a -> b) -> a -> b
$
      [ (k
ctx, [a
e])
      | (k
ctx, a
e) <- NonEmpty (k, a) -> [(k, a)]
forall a. NonEmpty a -> [a]
NonEmpty.toList NonEmpty (k, a)
es
      ]

  addPath :: [Text] -> [Text]
addPath =
    case DecodeError
decodeError.filepath of
      Maybe FilePath
Nothing -> [Text] -> [Text]
forall a. a -> a
id
      Just FilePath
fp -> let msg :: Text
msg = Text
"Failed to decode " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> FilePath -> Text
Text.pack FilePath
fp Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
":" in (Text
msg :)

  renderCtxErrors :: ([ContextItem], [DecodeErrorKind]) -> [Text]
renderCtxErrors = \case
    -- Special case parse errors, which shouldn't have a context
    ([ContextItem]
_, [DecodeError_ParseError Text
msg]) -> [Text
msg]
    ([ContextItem]
ctx, [DecodeErrorKind]
errs) -> [Text] -> [Text]
addPath ([Text] -> [Text]) -> [Text] -> [Text]
forall a b. (a -> b) -> a -> b
$ (Text
"At: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> [ContextItem] -> Text
renderCtxItems [ContextItem]
ctx) Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: [DecodeErrorKind] -> [Text]
renderErrors [DecodeErrorKind]
errs

  renderCtxItems :: [ContextItem] -> Text
renderCtxItems [ContextItem]
items
    | [ContextItem] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [ContextItem]
items = Text
"<root>"
    | Bool
otherwise = Text -> [Text] -> Text
Text.intercalate Text
" > " ([Text] -> Text)
-> ([ContextItem] -> [Text]) -> [ContextItem] -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ContextItem -> Text) -> [ContextItem] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map ContextItem -> Text
renderCtxItem ([ContextItem] -> Text) -> [ContextItem] -> Text
forall a b. (a -> b) -> a -> b
$ [ContextItem]
items
  renderCtxItem :: ContextItem -> Text
renderCtxItem = \case
    ContextNode{Int
Identifier
name :: ContextItem -> Identifier
index :: ContextItem -> Int
name :: Identifier
index :: Int
..} -> Identifier -> Text
renderIdentifier Identifier
name Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" #" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall a. Show a => a -> Text
showT Int
index
    ContextArg{Int
index :: ContextItem -> Int
index :: Int
..} -> Text
"arg #" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall a. Show a => a -> Text
showT Int
index
    ContextProp{Identifier
name :: ContextItem -> Identifier
name :: Identifier
..} -> Text
"prop " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Identifier -> Text
renderIdentifier Identifier
name

  renderErrors :: [DecodeErrorKind] -> [Text]
renderErrors = (Text -> Text) -> [Text] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (Text
"  " <>) ([Text] -> [Text])
-> ([DecodeErrorKind] -> [Text]) -> [DecodeErrorKind] -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (DecodeErrorKind -> [Text]) -> [DecodeErrorKind] -> [Text]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Text -> [Text]
Text.lines (Text -> [Text])
-> (DecodeErrorKind -> Text) -> DecodeErrorKind -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DecodeErrorKind -> Text
renderError)
  renderError :: DecodeErrorKind -> Text
renderError = \case
    DecodeError_Custom Text
msg -> Text
msg
    DecodeError_ParseError Text
msg -> Text
msg
    DecodeError_ExpectedNode{Int
Text
name :: DecodeErrorKind -> Text
index :: DecodeErrorKind -> Int
name :: Text
index :: Int
..}
      | Int
index Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 -> Text
"Expected node: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
name
      | Bool
otherwise -> Text
"Expected another node: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
name
    DecodeError_ExpectedArg{Int
index :: DecodeErrorKind -> Int
index :: Int
..} -> Text
"Expected arg #" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall a. Show a => a -> Text
showT Int
index
    DecodeError_ExpectedProp{Text
name :: DecodeErrorKind -> Text
name :: Text
..} -> Text
"Expected prop: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
name
    DecodeError_MismatchedAnn{[Text]
Identifier
givenAnn :: DecodeErrorKind -> Identifier
validAnns :: DecodeErrorKind -> [Text]
givenAnn :: Identifier
validAnns :: [Text]
..} -> Text
"Expected annotation to be one of " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> [Text] -> Text
forall a. Show a => a -> Text
showT [Text]
validAnns Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", got: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Identifier -> Text
renderIdentifier Identifier
givenAnn
    DecodeError_ValueDecodeFail{Text
Value
expectedType :: DecodeErrorKind -> Text
value :: DecodeErrorKind -> Value
expectedType :: Text
value :: Value
..} -> Text
"Expected " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
expectedType Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
", got: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Value -> Text
renderValue Value
value
    DecodeError_UnexpectedNode{Int
Identifier
index :: DecodeErrorKind -> Int
identifier :: DecodeErrorKind -> Identifier
identifier :: Identifier
index :: Int
..} -> Text
"Unexpected node: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Identifier -> Text
renderIdentifier Identifier
identifier Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" #" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall a. Show a => a -> Text
showT Int
index
    DecodeError_UnexpectedArg{Int
Value
index :: DecodeErrorKind -> Int
value :: DecodeErrorKind -> Value
index :: Int
value :: Value
..} -> Text
"Unexpected arg #" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall a. Show a => a -> Text
showT Int
index Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
": " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Value -> Text
renderValue Value
value
    DecodeError_UnexpectedProp{Identifier
Value
value :: DecodeErrorKind -> Value
identifier :: DecodeErrorKind -> Identifier
identifier :: Identifier
value :: Value
..} -> Text
"Unexpected prop: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Identifier -> Text
renderIdentifier Identifier
identifier Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"=" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Value -> Text
renderValue Value
value

  -- Replace with Text.show after requiring at least text-2.1.2
  showT :: (Show a) => a -> Text
  showT :: forall a. Show a => a -> Text
showT = FilePath -> Text
Text.pack (FilePath -> Text) -> (a -> FilePath) -> a -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> FilePath
forall a. Show a => a -> FilePath
show