DecodeM.hs

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

module KDL.Decoder.Internal.DecodeM (
  -- * Decoding errors
  module KDL.Decoder.Internal.Error,

  -- * DecodeM monad
  DecodeM (..),
  DecodeHints,
  runDecodeM,
  decodeThrow,
  failM,
  mapErrors,
  addContext,
  discardHints,
) where

import Control.Applicative (Alternative (..))
import Data.Bifunctor (first)
import Data.Default (def)
import Data.List.NonEmpty (NonEmpty (..))
import Data.List.NonEmpty qualified as NonEmpty
import Data.Text (Text)
import KDL.Decoder.Internal.Error
import KDL.Decoder.Internal.Error qualified as Error
import KDL.Types (Span)
import Prelude hiding (span)

-- | The monad that returns either a 'DecodeError' or a result of type @a@.
data DecodeM a
  = DecodeM_Found a DecodeHints
  | DecodeM_Fail (NonEmpty BaseDecodeError)

-- | Hints to provide additional context in a future error after a successful
-- branch.
--
-- Take this motivating example: a node takes an arbitrary number of string
-- args. If you pass some strings then a number, it'll successfully parse up to
-- the number and return success, only for the node to fail later with
-- "unexpected argument: 123". But the true error was
-- "unexpected number, expected string".
type DecodeHints = [BaseDecodeError]

instance Functor DecodeM where
  fmap f = \case
    DecodeM_Found a es -> DecodeM_Found (f a) es
    DecodeM_Fail es -> DecodeM_Fail es
instance Applicative DecodeM where
  pure x = DecodeM_Found x mempty
  l <*> r =
    case (l, r) of
      (DecodeM_Found f es1, DecodeM_Found a es2) -> DecodeM_Found (f a) (es1 <> es2)
      (DecodeM_Found _ es1, DecodeM_Fail es2) -> DecodeM_Fail (mergeHintsL es1 es2)
      (DecodeM_Fail es1, DecodeM_Found _ es2) -> DecodeM_Fail (mergeHintsR es1 es2)
      (DecodeM_Fail es1, DecodeM_Fail es2) -> DecodeM_Fail (mergeErrors es1 es2)
instance Monad DecodeM where
  (>>) = (*>)
  m >>= k =
    case m of
      DecodeM_Fail es1 -> DecodeM_Fail es1
      DecodeM_Found a es1 ->
        case k a of
          DecodeM_Found b es2 -> DecodeM_Found b (es1 <> es2)
          DecodeM_Fail es2 -> DecodeM_Fail (mergeHintsL es1 es2)
instance Alternative DecodeM where
  empty = failM "<empty>"
  l <|> r =
    case l of
      DecodeM_Found a es1 -> DecodeM_Found a es1
      DecodeM_Fail es1 ->
        case r of
          DecodeM_Found a es2 -> DecodeM_Found a (NonEmpty.toList es1 <> es2)
          DecodeM_Fail es2 -> DecodeM_Fail (mergeErrors es1 es2)

-- | Run a 'DecodeM' action and return the result or the deepest error found.
runDecodeM :: DecodeM a -> Either DecodeError a
runDecodeM = \case
  DecodeM_Found a _ -> Right a
  DecodeM_Fail errors -> Left DecodeError{filepath = Nothing, errors}

{----- mergeErrors -----}

mergeErrors ::
  NonEmpty BaseDecodeError ->
  NonEmpty BaseDecodeError ->
  NonEmpty BaseDecodeError
mergeErrors es1 es2 =
  case compare (key es1) (key es2) of
    LT -> es2
    EQ -> es1 <> es2
    GT -> es1
 where
  key = length . (.path) . fst . NonEmpty.head

mergeHintsL ::
  DecodeHints ->
  NonEmpty BaseDecodeError ->
  NonEmpty BaseDecodeError
mergeHintsL l r = maybe r (\l' -> mergeErrors l' r) (NonEmpty.nonEmpty l)

mergeHintsR ::
  NonEmpty BaseDecodeError ->
  DecodeHints ->
  NonEmpty BaseDecodeError
mergeHintsR l r = maybe l (\r' -> mergeErrors l r') (NonEmpty.nonEmpty r)

{----- DecodeM operations -----}

mapErrors :: (BaseDecodeError -> BaseDecodeError) -> DecodeM a -> DecodeM a
mapErrors f = \case
  DecodeM_Found a es -> DecodeM_Found a (map f es)
  DecodeM_Fail es -> DecodeM_Fail (fmap f es)

mapErrorContext :: (Error.Context -> Error.Context) -> DecodeM a -> DecodeM a
mapErrorContext f = mapErrors (first f)

-- | Throw an error.
decodeThrow :: DecodeErrorKind -> DecodeM a
decodeThrow e = DecodeM_Fail . NonEmpty.singleton $ (def, e)

-- | Throw a 'DecodeError_Custom' error.
failM :: Text -> DecodeM a
failM = decodeThrow . DecodeError_Custom

-- | Add context to all errors that occur in the given action.
addContext :: Span -> ContextItem -> DecodeM a -> DecodeM a
addContext span ctxItem = mapErrorContext $ \ctx ->
  ctx
    { path = ctxItem : ctx.path
    , -- Span should only be attached to the nearest context; i.e. the first
      -- addContext that runs
      span = ctx.span <|> span'
    }
 where
  -- Ignore span if it's empty
  span' = if span == def then Nothing else Just span

-- | Discard hints after validating that an error context is successful.
discardHints :: DecodeM a -> DecodeM a
discardHints = \case
  DecodeM_Found a _ -> DecodeM_Found a mempty
  DecodeM_Fail es -> DecodeM_Fail es