{-# 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 (..),
  runDecodeM,
  decodeThrow,
  failM,
  addContext,
) where

import Control.Applicative (Alternative (..))
import Data.Bifunctor (first)
import Data.List.NonEmpty (NonEmpty (..))
import Data.List.NonEmpty qualified as NonEmpty
import Data.Text (Text)
import KDL.Decoder.Internal.Error

-- | The monad that returns either a 'DecodeError' or a result of type @a@.
--
-- The odd structure here is because of our backtracking semantics. We want to
-- collect all errors that may appear (even if a value is successfully parsed)
-- so that if we get a failure later on, we can return the deepest error, even
-- if it was in 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".
data DecodeM a
  = DecodeM_Found a [BaseDecodeError]
  | DecodeM_Fail (NonEmpty BaseDecodeError)

instance Functor DecodeM where
  fmap :: forall a b. (a -> b) -> DecodeM a -> DecodeM b
fmap a -> b
f = \case
    DecodeM_Found a
a [BaseDecodeError]
es -> b -> [BaseDecodeError] -> DecodeM b
forall a. a -> [BaseDecodeError] -> DecodeM a
DecodeM_Found (a -> b
f a
a) [BaseDecodeError]
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 -> [BaseDecodeError] -> DecodeM a
forall a. a -> [BaseDecodeError] -> DecodeM a
DecodeM_Found a
x []
  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 [BaseDecodeError]
es1, DecodeM_Found a
a [BaseDecodeError]
es2) -> b -> [BaseDecodeError] -> DecodeM b
forall a. a -> [BaseDecodeError] -> DecodeM a
DecodeM_Found (a -> b
f a
a) ([BaseDecodeError] -> [BaseDecodeError] -> [BaseDecodeError]
mergeErrorsLR [BaseDecodeError]
es1 [BaseDecodeError]
es2)
      (DecodeM_Found a -> b
_ [BaseDecodeError]
es1, DecodeM_Fail NonEmpty BaseDecodeError
es2) -> NonEmpty BaseDecodeError -> DecodeM b
forall a. NonEmpty BaseDecodeError -> DecodeM a
DecodeM_Fail ([BaseDecodeError]
-> NonEmpty BaseDecodeError -> NonEmpty BaseDecodeError
mergeErrorsL [BaseDecodeError]
es1 NonEmpty BaseDecodeError
es2)
      (DecodeM_Fail NonEmpty BaseDecodeError
es1, DecodeM_Found a
_ [BaseDecodeError]
es2) -> NonEmpty BaseDecodeError -> DecodeM b
forall a. NonEmpty BaseDecodeError -> DecodeM a
DecodeM_Fail (NonEmpty BaseDecodeError
-> [BaseDecodeError] -> NonEmpty BaseDecodeError
mergeErrorsR NonEmpty BaseDecodeError
es1 [BaseDecodeError]
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 [BaseDecodeError]
es1 ->
        case a -> DecodeM b
k a
a of
          DecodeM_Found b
b [BaseDecodeError]
es2 -> b -> [BaseDecodeError] -> DecodeM b
forall a. a -> [BaseDecodeError] -> DecodeM a
DecodeM_Found b
b ([BaseDecodeError] -> [BaseDecodeError] -> [BaseDecodeError]
mergeErrorsLR [BaseDecodeError]
es1 [BaseDecodeError]
es2)
          DecodeM_Fail NonEmpty BaseDecodeError
es2 -> NonEmpty BaseDecodeError -> DecodeM b
forall a. NonEmpty BaseDecodeError -> DecodeM a
DecodeM_Fail ([BaseDecodeError]
-> NonEmpty BaseDecodeError -> NonEmpty BaseDecodeError
mergeErrorsL [BaseDecodeError]
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 [BaseDecodeError]
es1 -> a -> [BaseDecodeError] -> DecodeM a
forall a. a -> [BaseDecodeError] -> DecodeM a
DecodeM_Found a
a [BaseDecodeError]
es1
      DecodeM_Fail NonEmpty BaseDecodeError
es1 ->
        case DecodeM a
r of
          DecodeM_Found a
a [BaseDecodeError]
es2 -> a -> [BaseDecodeError] -> DecodeM a
forall a. a -> [BaseDecodeError] -> DecodeM a
DecodeM_Found a
a (NonEmpty BaseDecodeError -> [BaseDecodeError]
forall a. NonEmpty a -> [a]
NonEmpty.toList (NonEmpty BaseDecodeError -> [BaseDecodeError])
-> NonEmpty BaseDecodeError -> [BaseDecodeError]
forall a b. (a -> b) -> a -> b
$ NonEmpty BaseDecodeError
-> [BaseDecodeError] -> NonEmpty BaseDecodeError
mergeErrorsR NonEmpty BaseDecodeError
es1 [BaseDecodeError]
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 [BaseDecodeError]
_ -> 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 ::
  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 {a} {b}. NonEmpty ([a], b) -> Int
key NonEmpty BaseDecodeError
es1) (NonEmpty BaseDecodeError -> Int
forall {a} {b}. NonEmpty ([a], 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 ([a], b) -> Int
key = [a] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([a] -> Int)
-> (NonEmpty ([a], b) -> [a]) -> NonEmpty ([a], b) -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([a], b) -> [a]
forall a b. (a, b) -> a
fst (([a], b) -> [a])
-> (NonEmpty ([a], b) -> ([a], b)) -> NonEmpty ([a], b) -> [a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NonEmpty ([a], b) -> ([a], b)
forall a. NonEmpty a -> a
NonEmpty.head

mergeErrorsL ::
  [BaseDecodeError] ->
  NonEmpty BaseDecodeError ->
  NonEmpty BaseDecodeError
mergeErrorsL :: [BaseDecodeError]
-> NonEmpty BaseDecodeError -> NonEmpty BaseDecodeError
mergeErrorsL [BaseDecodeError]
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) ([BaseDecodeError] -> Maybe (NonEmpty BaseDecodeError)
forall a. [a] -> Maybe (NonEmpty a)
NonEmpty.nonEmpty [BaseDecodeError]
l)

mergeErrorsR ::
  NonEmpty BaseDecodeError ->
  [BaseDecodeError] ->
  NonEmpty BaseDecodeError
mergeErrorsR :: NonEmpty BaseDecodeError
-> [BaseDecodeError] -> NonEmpty BaseDecodeError
mergeErrorsR NonEmpty BaseDecodeError
l [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
l (\NonEmpty BaseDecodeError
r' -> NonEmpty BaseDecodeError
-> NonEmpty BaseDecodeError -> NonEmpty BaseDecodeError
mergeErrors NonEmpty BaseDecodeError
l NonEmpty BaseDecodeError
r') ([BaseDecodeError] -> Maybe (NonEmpty BaseDecodeError)
forall a. [a] -> Maybe (NonEmpty a)
NonEmpty.nonEmpty [BaseDecodeError]
r)

mergeErrorsLR ::
  [BaseDecodeError] ->
  [BaseDecodeError] ->
  [BaseDecodeError]
mergeErrorsLR :: [BaseDecodeError] -> [BaseDecodeError] -> [BaseDecodeError]
mergeErrorsLR [BaseDecodeError]
l [BaseDecodeError]
r =
  case ([BaseDecodeError]
l, [BaseDecodeError]
r) of
    ([], [BaseDecodeError]
_) -> [BaseDecodeError]
r
    ([BaseDecodeError]
_, []) -> [BaseDecodeError]
l
    (BaseDecodeError
x : [BaseDecodeError]
xs, BaseDecodeError
y : [BaseDecodeError]
ys) -> NonEmpty BaseDecodeError -> [BaseDecodeError]
forall a. NonEmpty a -> [a]
NonEmpty.toList (NonEmpty BaseDecodeError -> [BaseDecodeError])
-> NonEmpty BaseDecodeError -> [BaseDecodeError]
forall a b. (a -> b) -> a -> b
$ NonEmpty BaseDecodeError
-> NonEmpty BaseDecodeError -> NonEmpty BaseDecodeError
mergeErrors (BaseDecodeError
x BaseDecodeError -> [BaseDecodeError] -> NonEmpty BaseDecodeError
forall a. a -> [a] -> NonEmpty a
:| [BaseDecodeError]
xs) (BaseDecodeError
y BaseDecodeError -> [BaseDecodeError] -> NonEmpty BaseDecodeError
forall a. a -> [a] -> NonEmpty a
:| [BaseDecodeError]
ys)

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 [BaseDecodeError]
es -> a -> [BaseDecodeError] -> DecodeM a
forall a. a -> [BaseDecodeError] -> DecodeM a
DecodeM_Found a
a ((BaseDecodeError -> BaseDecodeError)
-> [BaseDecodeError] -> [BaseDecodeError]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap BaseDecodeError -> BaseDecodeError
f [BaseDecodeError]
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)

-- | 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
$ ([], 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 :: ContextItem -> DecodeM a -> DecodeM a
addContext :: forall a. ContextItem -> DecodeM a -> DecodeM a
addContext ContextItem
ctxItem = (BaseDecodeError -> BaseDecodeError) -> DecodeM a -> DecodeM a
forall a.
(BaseDecodeError -> BaseDecodeError) -> DecodeM a -> DecodeM a
mapErrors (([ContextItem] -> [ContextItem])
-> 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 (ContextItem
ctxItem :))