Error.hs

{-# 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 Control.Exception (Exception (..))
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
  { filepath :: Maybe FilePath
  , errors :: NonEmpty BaseDecodeError
  }
  deriving (Show, Eq)

instance Exception DecodeError where
  displayException = Text.unpack . renderDecodeError

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

data ContextItem
  = ContextNode
      { name :: Identifier
      , index :: Int
      }
  | ContextArg
      { index :: Int
      , label :: Maybe Text
      }
  | ContextProp
      { name :: Identifier
      }
  deriving (Show, Eq, Ord)

data DecodeErrorKind
  = DecodeError_Custom Text
  | DecodeError_ParseError Text
  | DecodeError_ExpectedNode {name :: Text, index :: Int}
  | DecodeError_ExpectedArg {index :: Int, label :: Maybe Text, expectedTypes :: [Text]}
  | DecodeError_ExpectedProp {name :: Text, expectedTypes :: [Text]}
  | DecodeError_MismatchedAnn {givenAnn :: Identifier, validAnns :: [Text]}
  | DecodeError_ValueDecodeFail {expectedType :: Text, value :: Value}
  | DecodeError_UnexpectedNode {identifier :: Identifier, index :: Int}
  | DecodeError_UnexpectedArg {index :: Int, value :: Value}
  | DecodeError_UnexpectedProp {identifier :: Identifier, value :: Value}
  deriving (Show, Eq)

renderDecodeError :: DecodeError -> Text
renderDecodeError decodeError =
  Text.intercalate "\n"
    . concatMap renderCtxErrors
    . groupCtxErrors
    $ decodeError.errors
 where
  -- Group errors with the same contexts together
  groupCtxErrors es =
    Map.toAscList . Map.fromListWith (<>) $
      [ (ctx, [e])
      | (ctx, e) <- NonEmpty.toList es
      ]

  addPath =
    case decodeError.filepath of
      Nothing -> id
      Just fp -> let msg = "Failed to decode " <> Text.pack fp <> ":" in (msg :)

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

  renderCtxItems items
    | null items = "<root>"
    | otherwise = Text.intercalate " > " . map renderCtxItem $ items
  renderCtxItem = \case
    ContextNode{..} -> renderIdentifier name <> " #" <> showT index
    ContextArg{..} -> renderArg index label
    ContextProp{..} -> "prop " <> renderIdentifier name

  renderErrors = map ("  " <>) . concatMap (Text.lines . renderError)
  renderError = \case
    DecodeError_Custom msg -> msg
    DecodeError_ParseError msg -> msg
    DecodeError_ExpectedNode{..}
      | index == 0 -> "Expected node: " <> name
      | otherwise -> "Expected another node: " <> name
    DecodeError_ExpectedArg{..} ->
      Text.concat
        [ "Expected "
        , renderArg index label
        , if null expectedTypes
            then ""
            else " with type: " <> oxfordList "or" expectedTypes
        ]
    DecodeError_ExpectedProp{..} ->
      Text.concat
        [ "Expected prop '" <> name <> "'"
        , if null expectedTypes
            then ""
            else " with type: " <> oxfordList "or" expectedTypes
        ]
    DecodeError_MismatchedAnn{..} -> "Expected annotation to be one of " <> showT validAnns <> ", got: " <> renderIdentifier givenAnn
    DecodeError_ValueDecodeFail{..} -> "Expected " <> expectedType <> ", got: " <> renderValue value
    DecodeError_UnexpectedNode{..} -> "Unexpected node: " <> renderIdentifier identifier <> " #" <> showT index
    DecodeError_UnexpectedArg{..} -> "Unexpected arg #" <> showT index <> ": " <> renderValue value
    DecodeError_UnexpectedProp{..} -> "Unexpected prop: " <> renderIdentifier identifier <> "=" <> renderValue value

  renderArg index label = "arg " <> maybe ("#" <> showT index) (\s -> "'" <> s <> "'") label

  oxfordList conj = \case
    [x] -> x
    [x, y] -> Text.unwords [x, conj, y]
    xs -> Text.intercalate ", " $ mapLast ((conj <> " ") <>) xs
  mapLast f = \case
    [] -> []
    [x] -> [f x]
    x : xs -> x : mapLast f xs

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