{-# 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 :: forall a b. (a -> b) -> DecodeM a -> DecodeM b
fmap a -> b
f = \case
    DecodeM_Found a
a DecodeHints
es -> b -> DecodeHints -> DecodeM b
forall a. a -> DecodeHints -> DecodeM a
DecodeM_Found (a -> b
f a
a) DecodeHints
es
    DecodeM_Fail NonEmpty BaseDecodeError
es -> NonEmpty BaseDecodeError -> DecodeM b
forall a. NonEmpty BaseDecodeError -> DecodeM a
DecodeM_Fail NonEmpty BaseDecodeError
es
instance Applicative DecodeM where
  pure :: forall a. a -> DecodeM a
pure a
x = a -> DecodeHints -> DecodeM a
forall a. a -> DecodeHints -> DecodeM a
DecodeM_Found a
x DecodeHints
forall a. Monoid a => a
mempty
  DecodeM (a -> b)
l <*> :: forall a b. DecodeM (a -> b) -> DecodeM a -> DecodeM b
<*> DecodeM a
r =
    case (DecodeM (a -> b)
l, DecodeM a
r) of
      (DecodeM_Found a -> b
f DecodeHints
es1, DecodeM_Found a
a DecodeHints
es2) -> b -> DecodeHints -> DecodeM b
forall a. a -> DecodeHints -> DecodeM a
DecodeM_Found (a -> b
f a
a) (DecodeHints
es1 DecodeHints -> DecodeHints -> DecodeHints
forall a. Semigroup a => a -> a -> a
<> DecodeHints
es2)
      (DecodeM_Found a -> b
_ DecodeHints
es1, DecodeM_Fail NonEmpty BaseDecodeError
es2) -> NonEmpty BaseDecodeError -> DecodeM b
forall a. NonEmpty BaseDecodeError -> DecodeM a
DecodeM_Fail (DecodeHints -> NonEmpty BaseDecodeError -> NonEmpty BaseDecodeError
mergeHintsL DecodeHints
es1 NonEmpty BaseDecodeError
es2)
      (DecodeM_Fail NonEmpty BaseDecodeError
es1, DecodeM_Found a
_ DecodeHints
es2) -> NonEmpty BaseDecodeError -> DecodeM b
forall a. NonEmpty BaseDecodeError -> DecodeM a
DecodeM_Fail (NonEmpty BaseDecodeError -> DecodeHints -> NonEmpty BaseDecodeError
mergeHintsR NonEmpty BaseDecodeError
es1 DecodeHints
es2)
      (DecodeM_Fail NonEmpty BaseDecodeError
es1, DecodeM_Fail NonEmpty BaseDecodeError
es2) -> NonEmpty BaseDecodeError -> DecodeM b
forall a. NonEmpty BaseDecodeError -> DecodeM a
DecodeM_Fail (NonEmpty BaseDecodeError
-> NonEmpty BaseDecodeError -> NonEmpty BaseDecodeError
mergeErrors NonEmpty BaseDecodeError
es1 NonEmpty BaseDecodeError
es2)
instance Monad DecodeM where
  >> :: forall a b. DecodeM a -> DecodeM b -> DecodeM b
(>>) = DecodeM a -> DecodeM b -> DecodeM b
forall a b. DecodeM a -> DecodeM b -> DecodeM b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
(*>)
  DecodeM a
m >>= :: forall a b. DecodeM a -> (a -> DecodeM b) -> DecodeM b
>>= a -> DecodeM b
k =
    case DecodeM a
m of
      DecodeM_Fail NonEmpty BaseDecodeError
es1 -> NonEmpty BaseDecodeError -> DecodeM b
forall a. NonEmpty BaseDecodeError -> DecodeM a
DecodeM_Fail NonEmpty BaseDecodeError
es1
      DecodeM_Found a
a DecodeHints
es1 ->
        case a -> DecodeM b
k a
a of
          DecodeM_Found b
b DecodeHints
es2 -> b -> DecodeHints -> DecodeM b
forall a. a -> DecodeHints -> DecodeM a
DecodeM_Found b
b (DecodeHints
es1 DecodeHints -> DecodeHints -> DecodeHints
forall a. Semigroup a => a -> a -> a
<> DecodeHints
es2)
          DecodeM_Fail NonEmpty BaseDecodeError
es2 -> NonEmpty BaseDecodeError -> DecodeM b
forall a. NonEmpty BaseDecodeError -> DecodeM a
DecodeM_Fail (DecodeHints -> NonEmpty BaseDecodeError -> NonEmpty BaseDecodeError
mergeHintsL DecodeHints
es1 NonEmpty BaseDecodeError
es2)
instance Alternative DecodeM where
  empty :: forall a. DecodeM a
empty = Text -> DecodeM a
forall a. Text -> DecodeM a
failM Text
"<empty>"
  DecodeM a
l <|> :: forall a. DecodeM a -> DecodeM a -> DecodeM a
<|> DecodeM a
r =
    case DecodeM a
l of
      DecodeM_Found a
a DecodeHints
es1 -> a -> DecodeHints -> DecodeM a
forall a. a -> DecodeHints -> DecodeM a
DecodeM_Found a
a DecodeHints
es1
      DecodeM_Fail NonEmpty BaseDecodeError
es1 ->
        case DecodeM a
r of
          DecodeM_Found a
a DecodeHints
es2 -> a -> DecodeHints -> DecodeM a
forall a. a -> DecodeHints -> DecodeM a
DecodeM_Found a
a (NonEmpty BaseDecodeError -> DecodeHints
forall a. NonEmpty a -> [a]
NonEmpty.toList NonEmpty BaseDecodeError
es1 DecodeHints -> DecodeHints -> DecodeHints
forall a. Semigroup a => a -> a -> a
<> DecodeHints
es2)
          DecodeM_Fail NonEmpty BaseDecodeError
es2 -> NonEmpty BaseDecodeError -> DecodeM a
forall a. NonEmpty BaseDecodeError -> DecodeM a
DecodeM_Fail (NonEmpty BaseDecodeError
-> NonEmpty BaseDecodeError -> NonEmpty BaseDecodeError
mergeErrors NonEmpty BaseDecodeError
es1 NonEmpty BaseDecodeError
es2)

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

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

mergeErrors ::
  NonEmpty BaseDecodeError ->
  NonEmpty BaseDecodeError ->
  NonEmpty BaseDecodeError
mergeErrors :: NonEmpty BaseDecodeError
-> NonEmpty BaseDecodeError -> NonEmpty BaseDecodeError
mergeErrors NonEmpty BaseDecodeError
es1 NonEmpty BaseDecodeError
es2 =
  case Int -> Int -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (NonEmpty BaseDecodeError -> Int
forall {b}. NonEmpty (Context, b) -> Int
key NonEmpty BaseDecodeError
es1) (NonEmpty BaseDecodeError -> Int
forall {b}. NonEmpty (Context, b) -> Int
key NonEmpty BaseDecodeError
es2) of
    Ordering
LT -> NonEmpty BaseDecodeError
es2
    Ordering
EQ -> NonEmpty BaseDecodeError
es1 NonEmpty BaseDecodeError
-> NonEmpty BaseDecodeError -> NonEmpty BaseDecodeError
forall a. Semigroup a => a -> a -> a
<> NonEmpty BaseDecodeError
es2
    Ordering
GT -> NonEmpty BaseDecodeError
es1
 where
  key :: NonEmpty (Context, b) -> Int
key = [ContextItem] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([ContextItem] -> Int)
-> (NonEmpty (Context, b) -> [ContextItem])
-> NonEmpty (Context, b)
-> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (.path) (Context -> [ContextItem])
-> (NonEmpty (Context, b) -> Context)
-> NonEmpty (Context, b)
-> [ContextItem]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Context, b) -> Context
forall a b. (a, b) -> a
fst ((Context, b) -> Context)
-> (NonEmpty (Context, b) -> (Context, b))
-> NonEmpty (Context, b)
-> Context
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NonEmpty (Context, b) -> (Context, b)
forall a. NonEmpty a -> a
NonEmpty.head

mergeHintsL ::
  DecodeHints ->
  NonEmpty BaseDecodeError ->
  NonEmpty BaseDecodeError
mergeHintsL :: DecodeHints -> NonEmpty BaseDecodeError -> NonEmpty BaseDecodeError
mergeHintsL DecodeHints
l NonEmpty BaseDecodeError
r = NonEmpty BaseDecodeError
-> (NonEmpty BaseDecodeError -> NonEmpty BaseDecodeError)
-> Maybe (NonEmpty BaseDecodeError)
-> NonEmpty BaseDecodeError
forall b a. b -> (a -> b) -> Maybe a -> b
maybe NonEmpty BaseDecodeError
r (\NonEmpty BaseDecodeError
l' -> NonEmpty BaseDecodeError
-> NonEmpty BaseDecodeError -> NonEmpty BaseDecodeError
mergeErrors NonEmpty BaseDecodeError
l' NonEmpty BaseDecodeError
r) (DecodeHints -> Maybe (NonEmpty BaseDecodeError)
forall a. [a] -> Maybe (NonEmpty a)
NonEmpty.nonEmpty DecodeHints
l)

mergeHintsR ::
  NonEmpty BaseDecodeError ->
  DecodeHints ->
  NonEmpty BaseDecodeError
mergeHintsR :: NonEmpty BaseDecodeError -> DecodeHints -> NonEmpty BaseDecodeError
mergeHintsR NonEmpty BaseDecodeError
l DecodeHints
r = NonEmpty BaseDecodeError
-> (NonEmpty BaseDecodeError -> NonEmpty BaseDecodeError)
-> Maybe (NonEmpty BaseDecodeError)
-> NonEmpty BaseDecodeError
forall b a. b -> (a -> b) -> Maybe a -> b
maybe NonEmpty BaseDecodeError
l (\NonEmpty BaseDecodeError
r' -> NonEmpty BaseDecodeError
-> NonEmpty BaseDecodeError -> NonEmpty BaseDecodeError
mergeErrors NonEmpty BaseDecodeError
l NonEmpty BaseDecodeError
r') (DecodeHints -> Maybe (NonEmpty BaseDecodeError)
forall a. [a] -> Maybe (NonEmpty a)
NonEmpty.nonEmpty DecodeHints
r)

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

mapErrors :: (BaseDecodeError -> BaseDecodeError) -> DecodeM a -> DecodeM a
mapErrors :: forall a.
(BaseDecodeError -> BaseDecodeError) -> DecodeM a -> DecodeM a
mapErrors BaseDecodeError -> BaseDecodeError
f = \case
  DecodeM_Found a
a DecodeHints
es -> a -> DecodeHints -> DecodeM a
forall a. a -> DecodeHints -> DecodeM a
DecodeM_Found a
a ((BaseDecodeError -> BaseDecodeError) -> DecodeHints -> DecodeHints
forall a b. (a -> b) -> [a] -> [b]
map BaseDecodeError -> BaseDecodeError
f DecodeHints
es)
  DecodeM_Fail NonEmpty BaseDecodeError
es -> NonEmpty BaseDecodeError -> DecodeM a
forall a. NonEmpty BaseDecodeError -> DecodeM a
DecodeM_Fail ((BaseDecodeError -> BaseDecodeError)
-> NonEmpty BaseDecodeError -> NonEmpty BaseDecodeError
forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap BaseDecodeError -> BaseDecodeError
f NonEmpty BaseDecodeError
es)

mapErrorContext :: (Error.Context -> Error.Context) -> DecodeM a -> DecodeM a
mapErrorContext :: forall a. (Context -> Context) -> DecodeM a -> DecodeM a
mapErrorContext Context -> Context
f = (BaseDecodeError -> BaseDecodeError) -> DecodeM a -> DecodeM a
forall a.
(BaseDecodeError -> BaseDecodeError) -> DecodeM a -> DecodeM a
mapErrors ((Context -> Context) -> BaseDecodeError -> BaseDecodeError
forall a b c. (a -> b) -> (a, c) -> (b, c)
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first Context -> Context
f)

-- | Throw an error.
decodeThrow :: DecodeErrorKind -> DecodeM a
decodeThrow :: forall a. DecodeErrorKind -> DecodeM a
decodeThrow DecodeErrorKind
e = NonEmpty BaseDecodeError -> DecodeM a
forall a. NonEmpty BaseDecodeError -> DecodeM a
DecodeM_Fail (NonEmpty BaseDecodeError -> DecodeM a)
-> (BaseDecodeError -> NonEmpty BaseDecodeError)
-> BaseDecodeError
-> DecodeM a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BaseDecodeError -> NonEmpty BaseDecodeError
forall a. a -> NonEmpty a
NonEmpty.singleton (BaseDecodeError -> DecodeM a) -> BaseDecodeError -> DecodeM a
forall a b. (a -> b) -> a -> b
$ (Context
forall a. Default a => a
def, DecodeErrorKind
e)

-- | Throw a 'DecodeError_Custom' error.
failM :: Text -> DecodeM a
failM :: forall a. Text -> DecodeM a
failM = DecodeErrorKind -> DecodeM a
forall a. DecodeErrorKind -> DecodeM a
decodeThrow (DecodeErrorKind -> DecodeM a)
-> (Text -> DecodeErrorKind) -> Text -> DecodeM a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> DecodeErrorKind
DecodeError_Custom

-- | Add context to all errors that occur in the given action.
addContext :: Span -> ContextItem -> DecodeM a -> DecodeM a
addContext :: forall a. Span -> ContextItem -> DecodeM a -> DecodeM a
addContext Span
span ContextItem
ctxItem = (Context -> Context) -> DecodeM a -> DecodeM a
forall a. (Context -> Context) -> DecodeM a -> DecodeM a
mapErrorContext ((Context -> Context) -> DecodeM a -> DecodeM a)
-> (Context -> Context) -> DecodeM a -> DecodeM a
forall a b. (a -> b) -> a -> b
$ \Context
ctx ->
  Context
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' :: Maybe Span
span' = if Span
span Span -> Span -> Bool
forall a. Eq a => a -> a -> Bool
== Span
forall a. Default a => a
def then Maybe Span
forall a. Maybe a
Nothing else Span -> Maybe Span
forall a. a -> Maybe a
Just Span
span

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