{-# LANGUAGE TemplateHaskell #-}
module Control.CollectErrors
(
-- * Monad for collecting errors in expressions
  CollectErrors(..), SuitableForCE
, CanTestErrorsCertain(..), hasCertainErrorCE
, CanTestErrorsPresent(..), hasErrorCE
, noValueCE, prependErrorsCE
, filterValuesWithoutErrorCE, getValueIfNoErrorCE
, ce2ConvertResult
-- * Tools for avoiding @CollectErrors(CollectErrors t)@ and putting CE inside containers
, CanEnsureCE(..)
, getValueOrThrowErrorsNCE
, lift1CE, lift2CE, lift2TCE, lift2TLCE, lift3CE
-- ** Tools for pulling errors out of structures
, CanExtractCE(..)
)
where

import Prelude
  (Functor(..), Applicative(..), Monad(..), (<$>), ($), (.)
  , error, const, flip, not, fst, snd, foldMap, (++)
  , Int, Integer, Rational, Double, Bool, Char
  , Maybe(..), Either(..)
  , Show(..), Eq(..)
  , Traversable(..))
import Text.Printf

import Control.Monad (join)

import Data.Monoid
import Data.Maybe (fromJust)

-- import Data.Convertible
import Data.Convertible.Base
import Data.Typeable

-- import Language.Haskell.TH

import Test.QuickCheck

{-|
  A wrapper around values which can accommodate a list of
  (potential) errors that have (maybe) occurred during the computation
  of a value.  A value may be missing, leaving only the error(s).

  Such error collection allows one to write expressions with partial
  functions (ie functions that fail for some inputs) instead of
  branching after each application of such function.
  Dealing with the errors can be moved outside the expression.
  If the error data contain enough information, their list can be used
  to trace the source of the errors.
-}
data CollectErrors es v =
  CollectErrors
    { CollectErrors es v -> Maybe v
getMaybeValueCE :: Maybe v
    , CollectErrors es v -> es
getErrorsCE :: es }

class CanTestErrorsCertain es where
  hasCertainError :: es -> Bool

hasCertainErrorCE :: (CanTestErrorsCertain es) => (CollectErrors es v) -> Bool
hasCertainErrorCE :: CollectErrors es v -> Bool
hasCertainErrorCE (CollectErrors Maybe v
_ es
es) = es -> Bool
forall es. CanTestErrorsCertain es => es -> Bool
hasCertainError es
es

class CanTestErrorsPresent es where
  hasError :: es -> Bool

hasErrorCE :: (CanTestErrorsPresent es) => (CollectErrors es v) -> Bool
hasErrorCE :: CollectErrors es v -> Bool
hasErrorCE (CollectErrors Maybe v
_ es
es) = es -> Bool
forall es. CanTestErrorsPresent es => es -> Bool
hasError es
es

type SuitableForCE es = (Monoid es, Eq es, Show es, CanTestErrorsCertain es)

instance (Show v, SuitableForCE es) => (Show (CollectErrors es v)) where
  show :: CollectErrors es v -> String
show (CollectErrors Maybe v
mv es
es) =
    case Maybe v
mv of
      Just v
v | es
es es -> es -> Bool
forall a. Eq a => a -> a -> Bool
== es
forall a. Monoid a => a
mempty -> v -> String
forall a. Show a => a -> String
show v
v
      Just v
v -> String -> String -> ShowS
forall r. PrintfType r => String -> r
printf String
"%s{%s}" (v -> String
forall a. Show a => a -> String
show v
v) (es -> String
forall a. Show a => a -> String
show es
es)
      Maybe v
Nothing -> String -> ShowS
forall r. PrintfType r => String -> r
printf String
"{%s}" (es -> String
forall a. Show a => a -> String
show es
es)

noValueCE :: es -> CollectErrors es v
noValueCE :: es -> CollectErrors es v
noValueCE es
es = Maybe v -> es -> CollectErrors es v
forall es v. Maybe v -> es -> CollectErrors es v
CollectErrors Maybe v
forall a. Maybe a
Nothing es
es

prependErrorsCE :: (Monoid es) => es -> CollectErrors es v -> CollectErrors es v
prependErrorsCE :: es -> CollectErrors es v -> CollectErrors es v
prependErrorsCE es
es1 (CollectErrors Maybe v
mv es
es2) = Maybe v -> es -> CollectErrors es v
forall es v. Maybe v -> es -> CollectErrors es v
CollectErrors Maybe v
mv (es
es1 es -> es -> es
forall a. Semigroup a => a -> a -> a
<> es
es2)

ce2ConvertResult ::
  (Typeable t, Show t, SuitableForCE es)
  =>
  CollectErrors es t -> Either ConvertError t
ce2ConvertResult :: CollectErrors es t -> Either ConvertError t
ce2ConvertResult (CollectErrors Maybe t
mv es
es) =
  case Maybe t
mv of
    Just t
v | es
es es -> es -> Bool
forall a. Eq a => a -> a -> Bool
== es
forall a. Monoid a => a
mempty -> t -> Either ConvertError t
forall a b. b -> Either a b
Right t
v
    Maybe t
_ -> String -> Maybe t -> Either ConvertError t
forall a b.
(Show a, Typeable a, Typeable b) =>
String -> a -> ConvertResult b
convError (es -> String
forall a. Show a => a -> String
show es
es) Maybe t
mv

{-| A safe way to get a value out of the CollectErrors wrapper. -}
getValueIfNoErrorCE ::
  (SuitableForCE es)
  =>
  CollectErrors es v -> (v -> t) -> (es -> t) -> t
getValueIfNoErrorCE :: CollectErrors es v -> (v -> t) -> (es -> t) -> t
getValueIfNoErrorCE (CollectErrors Maybe v
mv es
es) v -> t
withValue es -> t
withErrors =
  case Maybe v
mv of
    Just v
v | es
es es -> es -> Bool
forall a. Eq a => a -> a -> Bool
== es
forall a. Monoid a => a
mempty -> v -> t
withValue v
v
    Maybe v
_ -> es -> t
withErrors es
es

filterValuesWithoutErrorCE ::
  (SuitableForCE es)
  =>
  [CollectErrors es v] -> [v]
filterValuesWithoutErrorCE :: [CollectErrors es v] -> [v]
filterValuesWithoutErrorCE [] = []
filterValuesWithoutErrorCE (CollectErrors es v
vCE : [CollectErrors es v]
rest) =
  CollectErrors es v -> (v -> [v]) -> (es -> [v]) -> [v]
forall es v t.
SuitableForCE es =>
CollectErrors es v -> (v -> t) -> (es -> t) -> t
getValueIfNoErrorCE CollectErrors es v
vCE (v -> [v] -> [v]
forall a. a -> [a] -> [a]
: [v]
restDone) ([v] -> es -> [v]
forall a b. a -> b -> a
const [v]
restDone)
  where
  restDone :: [v]
restDone = [CollectErrors es v] -> [v]
forall es v. SuitableForCE es => [CollectErrors es v] -> [v]
filterValuesWithoutErrorCE [CollectErrors es v]
rest

-- functor instances:

instance Functor (CollectErrors es) where
  fmap :: (a -> b) -> CollectErrors es a -> CollectErrors es b
fmap a -> b
f (CollectErrors Maybe a
mv es
es) =
    Maybe b -> es -> CollectErrors es b
forall es v. Maybe v -> es -> CollectErrors es v
CollectErrors ((a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f Maybe a
mv) es
es

instance (Monoid es) => Applicative (CollectErrors es) where
  pure :: a -> CollectErrors es a
pure a
v = Maybe a -> es -> CollectErrors es a
forall es v. Maybe v -> es -> CollectErrors es v
CollectErrors (a -> Maybe a
forall a. a -> Maybe a
Just a
v) es
forall a. Monoid a => a
mempty
  (CollectErrors (Just a -> b
a) es
ae) <*> :: CollectErrors es (a -> b)
-> CollectErrors es a -> CollectErrors es b
<*> (CollectErrors (Just a
b) es
be) =
    Maybe b -> es -> CollectErrors es b
forall es v. Maybe v -> es -> CollectErrors es v
CollectErrors (b -> Maybe b
forall a. a -> Maybe a
Just (a -> b
a a
b)) (es
ae es -> es -> es
forall a. Semigroup a => a -> a -> a
<> es
be)
  (CollectErrors Maybe (a -> b)
_ es
ae) <*> (CollectErrors Maybe a
_ es
be) =
    Maybe b -> es -> CollectErrors es b
forall es v. Maybe v -> es -> CollectErrors es v
CollectErrors Maybe b
forall a. Maybe a
Nothing (es
ae es -> es -> es
forall a. Semigroup a => a -> a -> a
<> es
be)

instance (Monoid es) => Monad (CollectErrors es) where
  CollectErrors es a
ae >>= :: CollectErrors es a
-> (a -> CollectErrors es b) -> CollectErrors es b
>>= a -> CollectErrors es b
f =
    case CollectErrors es a
ae of
      CollectErrors (Just a
a) es
es1 ->
        let (CollectErrors Maybe b
mv es
es2) = a -> CollectErrors es b
f a
a in
          Maybe b -> es -> CollectErrors es b
forall es v. Maybe v -> es -> CollectErrors es v
CollectErrors Maybe b
mv (es
es1 es -> es -> es
forall a. Semigroup a => a -> a -> a
<> es
es2)
      CollectErrors Maybe a
_ es
es ->
        Maybe b -> es -> CollectErrors es b
forall es v. Maybe v -> es -> CollectErrors es v
CollectErrors Maybe b
forall a. Maybe a
Nothing es
es

instance (Arbitrary t, Monoid es) => Arbitrary (CollectErrors es t) where
  arbitrary :: Gen (CollectErrors es t)
arbitrary = (\t
v -> Maybe t -> es -> CollectErrors es t
forall es v. Maybe v -> es -> CollectErrors es v
CollectErrors (t -> Maybe t
forall a. a -> Maybe a
Just t
v) es
forall a. Monoid a => a
mempty) (t -> CollectErrors es t) -> Gen t -> Gen (CollectErrors es t)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen t
forall a. Arbitrary a => Gen a
arbitrary

{-|
  A mechanism for adding and removing CollectErrors
  to a type in a manner that depends on
  the shape of the type, especially whether
  it already has CollectErrors.
-}
class
  (Monoid es
  , EnsureCE es (EnsureCE es a) ~ EnsureCE es a
  , EnsureCE es (EnsureNoCE es a) ~ EnsureCE es a
  , EnsureNoCE es (EnsureCE es a) ~ EnsureNoCE es a
  , EnsureNoCE es (EnsureNoCE es a) ~ EnsureNoCE es a)
  =>
  CanEnsureCE es a where
  {-|
    Add CollectErrors to a type except when the type already
    has CollectErrors in it.
  -}
  type EnsureCE es a
  type EnsureCE es a = CollectErrors es a -- default
  type EnsureNoCE es a
  type EnsureNoCE es a = a -- default

  {-|
    Translate a value of a type @a@
    to a value of a type @EnsureCE es a@.
  -}
  ensureCE ::
    Maybe es {-^ sample only -} ->
    a -> EnsureCE es a

  default ensureCE ::
    (EnsureCE es a ~ CollectErrors es a)
    =>
    Maybe es {-^ sample only -} ->
    a -> EnsureCE es a
  ensureCE Maybe es
_ = a -> EnsureCE es a
forall (f :: * -> *) a. Applicative f => a -> f a
pure

  deEnsureCE ::
    Maybe es {-^ sample only -} ->
    EnsureCE es a -> Either es a

  default deEnsureCE ::
    (EnsureCE es a ~ CollectErrors es a, Eq es) =>
    Maybe es {-^ sample only -} ->
    EnsureCE es a -> Either es a
  deEnsureCE Maybe es
_ (CollectErrors mv es) =
    case Maybe a
mv of
      Just a
v | es
es es -> es -> Bool
forall a. Eq a => a -> a -> Bool
== es
forall a. Monoid a => a
mempty -> a -> Either es a
forall a b. b -> Either a b
Right a
v
      Maybe a
_ -> es -> Either es a
forall a b. a -> Either a b
Left es
es

  ensureNoCE ::
    Maybe es {-^ sample only -} ->
    a -> (Maybe (EnsureNoCE es a), es)

  default ensureNoCE ::
    (EnsureNoCE es a ~ a, Eq es, Monoid es) =>
    Maybe es {-^ sample only -} ->
    a -> (Maybe (EnsureNoCE es a), es)
  ensureNoCE Maybe es
_ a
a = (a -> Maybe a
forall a. a -> Maybe a
Just a
a, es
forall a. Monoid a => a
mempty)

  {-|  Make CollectErrors record with no value, only errors. -}
  noValueECE ::
    Maybe a {-^ sample only -} ->
    es -> EnsureCE es a

  default noValueECE ::
    (EnsureCE es a ~ CollectErrors es a)
    =>
    Maybe a ->
    es -> EnsureCE es a
  noValueECE Maybe a
_ = es -> EnsureCE es a
forall es v. es -> CollectErrors es v
noValueCE

  prependErrorsECE ::
    Maybe a ->
    es -> EnsureCE es a -> EnsureCE es a
  default prependErrorsECE ::
    (EnsureCE es a ~ CollectErrors es a)
    =>
    Maybe a ->
    es -> EnsureCE es a -> EnsureCE es a
  prependErrorsECE Maybe a
_ = es -> EnsureCE es a -> EnsureCE es a
forall es v.
Monoid es =>
es -> CollectErrors es v -> CollectErrors es v
prependErrorsCE

-- instance for CollectErrors a:

instance
  (SuitableForCE es, CanEnsureCE es a)
  =>
  CanEnsureCE es (CollectErrors es a)
  where
  type EnsureCE es (CollectErrors es a) = EnsureCE es a
  type EnsureNoCE es (CollectErrors es a) = EnsureNoCE es a

  ensureCE :: Maybe es -> CollectErrors es a -> EnsureCE es (CollectErrors es a)
ensureCE Maybe es
sample_es (CollectErrors Maybe a
mv es
es) =
    case Maybe a
mv of
      Just a
v -> Maybe a -> es -> EnsureCE es a -> EnsureCE es a
forall es a.
CanEnsureCE es a =>
Maybe a -> es -> EnsureCE es a -> EnsureCE es a
prependErrorsECE (a -> Maybe a
forall a. a -> Maybe a
Just a
v) es
es (EnsureCE es a -> EnsureCE es a) -> EnsureCE es a -> EnsureCE es a
forall a b. (a -> b) -> a -> b
$ Maybe es -> a -> EnsureCE es a
forall es a. CanEnsureCE es a => Maybe es -> a -> EnsureCE es a
ensureCE Maybe es
sample_es a
v
      Maybe a
_ -> Maybe a -> es -> EnsureCE es a
forall es a. CanEnsureCE es a => Maybe a -> es -> EnsureCE es a
noValueECE Maybe a
mv es
es
  deEnsureCE :: Maybe es
-> EnsureCE es (CollectErrors es a)
-> Either es (CollectErrors es a)
deEnsureCE Maybe es
sample_es EnsureCE es (CollectErrors es a)
vCE =
    case Maybe es -> EnsureCE es a -> Either es a
forall es a.
CanEnsureCE es a =>
Maybe es -> EnsureCE es a -> Either es a
deEnsureCE Maybe es
sample_es EnsureCE es a
EnsureCE es (CollectErrors es a)
vCE of
      Right a
v -> CollectErrors es a -> Either es (CollectErrors es a)
forall a b. b -> Either a b
Right (CollectErrors es a -> Either es (CollectErrors es a))
-> CollectErrors es a -> Either es (CollectErrors es a)
forall a b. (a -> b) -> a -> b
$ Maybe a -> es -> CollectErrors es a
forall es v. Maybe v -> es -> CollectErrors es v
CollectErrors (a -> Maybe a
forall a. a -> Maybe a
Just a
v) es
forall a. Monoid a => a
mempty
      Left es
es -> es -> Either es (CollectErrors es a)
forall a b. a -> Either a b
Left es
es
  ensureNoCE :: Maybe es
-> CollectErrors es a
-> (Maybe (EnsureNoCE es (CollectErrors es a)), es)
ensureNoCE Maybe es
sample_es (CollectErrors Maybe a
mv es
es) =
    case (a -> (Maybe (EnsureNoCE es a), es))
-> Maybe a -> Maybe (Maybe (EnsureNoCE es a), es)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Maybe es -> a -> (Maybe (EnsureNoCE es a), es)
forall es a.
CanEnsureCE es a =>
Maybe es -> a -> (Maybe (EnsureNoCE es a), es)
ensureNoCE Maybe es
sample_es) Maybe a
mv of
      Just (Just EnsureNoCE es a
v, es
es2) -> (EnsureNoCE es a -> Maybe (EnsureNoCE es a)
forall a. a -> Maybe a
Just EnsureNoCE es a
v, es
es2 es -> es -> es
forall a. Semigroup a => a -> a -> a
<> es
es)
      Just (Maybe (EnsureNoCE es a)
_, es
es2) -> (Maybe (EnsureNoCE es (CollectErrors es a))
forall a. Maybe a
Nothing, es
es2 es -> es -> es
forall a. Semigroup a => a -> a -> a
<> es
es)
      Maybe (Maybe (EnsureNoCE es a), es)
_ -> (Maybe (EnsureNoCE es (CollectErrors es a))
forall a. Maybe a
Nothing, es
forall a. Monoid a => a
mempty)

  noValueECE :: Maybe (CollectErrors es a)
-> es -> EnsureCE es (CollectErrors es a)
noValueECE Maybe (CollectErrors es a)
sample_vCE es
es =
    Maybe a -> es -> EnsureCE es a
forall es a. CanEnsureCE es a => Maybe a -> es -> EnsureCE es a
noValueECE (Maybe (Maybe a) -> Maybe a
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (Maybe (Maybe a) -> Maybe a) -> Maybe (Maybe a) -> Maybe a
forall a b. (a -> b) -> a -> b
$ (CollectErrors es a -> Maybe a)
-> Maybe (CollectErrors es a) -> Maybe (Maybe a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap CollectErrors es a -> Maybe a
forall es v. CollectErrors es v -> Maybe v
getMaybeValueCE Maybe (CollectErrors es a)
sample_vCE) es
es
  prependErrorsECE :: Maybe (CollectErrors es a)
-> es
-> EnsureCE es (CollectErrors es a)
-> EnsureCE es (CollectErrors es a)
prependErrorsECE Maybe (CollectErrors es a)
sample_vCE =
    Maybe a -> es -> EnsureCE es a -> EnsureCE es a
forall es a.
CanEnsureCE es a =>
Maybe a -> es -> EnsureCE es a -> EnsureCE es a
prependErrorsECE (Maybe (Maybe a) -> Maybe a
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (Maybe (Maybe a) -> Maybe a) -> Maybe (Maybe a) -> Maybe a
forall a b. (a -> b) -> a -> b
$ (CollectErrors es a -> Maybe a)
-> Maybe (CollectErrors es a) -> Maybe (Maybe a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap CollectErrors es a -> Maybe a
forall es v. CollectErrors es v -> Maybe v
getMaybeValueCE Maybe (CollectErrors es a)
sample_vCE)

-- instances for ground types, using the default implementations:

instance (SuitableForCE es) => CanEnsureCE es Int
instance (SuitableForCE es) => CanEnsureCE es Integer
instance (SuitableForCE es) => CanEnsureCE es Rational
instance (SuitableForCE es) => CanEnsureCE es Double
instance (SuitableForCE es) => CanEnsureCE es Bool
instance (SuitableForCE es) => CanEnsureCE es Char
instance (SuitableForCE es) => CanEnsureCE es ()

-- instance for Maybe a:

instance
  (SuitableForCE es, CanEnsureCE es a)
  =>
  CanEnsureCE es (Maybe a)
  where
  type EnsureCE es (Maybe a) = Maybe (EnsureCE es a)
  type EnsureNoCE es (Maybe a) = Maybe (EnsureNoCE es a)

  ensureCE :: Maybe es -> Maybe a -> EnsureCE es (Maybe a)
ensureCE Maybe es
sample_es = (a -> EnsureCE es a) -> Maybe a -> Maybe (EnsureCE es a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Maybe es -> a -> EnsureCE es a
forall es a. CanEnsureCE es a => Maybe es -> a -> EnsureCE es a
ensureCE Maybe es
sample_es)
  deEnsureCE :: Maybe es -> EnsureCE es (Maybe a) -> Either es (Maybe a)
deEnsureCE Maybe es
sample_es (Just vCE) = (a -> Maybe a) -> Either es a -> Either es (Maybe a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> Maybe a
forall a. a -> Maybe a
Just (Maybe es -> EnsureCE es a -> Either es a
forall es a.
CanEnsureCE es a =>
Maybe es -> EnsureCE es a -> Either es a
deEnsureCE Maybe es
sample_es EnsureCE es a
vCE)
  deEnsureCE Maybe es
_sample_es EnsureCE es (Maybe a)
Nothing = Maybe a -> Either es (Maybe a)
forall a b. b -> Either a b
Right Maybe a
forall a. Maybe a
Nothing
  ensureNoCE :: Maybe es -> Maybe a -> (Maybe (EnsureNoCE es (Maybe a)), es)
ensureNoCE Maybe es
sample_es (Just a
vCE) =
    case Maybe es -> a -> (Maybe (EnsureNoCE es a), es)
forall es a.
CanEnsureCE es a =>
Maybe es -> a -> (Maybe (EnsureNoCE es a), es)
ensureNoCE Maybe es
sample_es a
vCE of
      (Just EnsureNoCE es a
v, es
es) -> (Maybe (EnsureNoCE es a) -> Maybe (Maybe (EnsureNoCE es a))
forall a. a -> Maybe a
Just (EnsureNoCE es a -> Maybe (EnsureNoCE es a)
forall a. a -> Maybe a
Just EnsureNoCE es a
v), es
es)
      (Maybe (EnsureNoCE es a)
_, es
es) -> (Maybe (EnsureNoCE es (Maybe a))
forall a. Maybe a
Nothing, es
es)
  ensureNoCE Maybe es
_sample_es Maybe a
Nothing = (Maybe (EnsureNoCE es (Maybe a))
forall a. Maybe a
Nothing, es
forall a. Monoid a => a
mempty)

  noValueECE :: Maybe (Maybe a) -> es -> EnsureCE es (Maybe a)
noValueECE Maybe (Maybe a)
sample_vCE es
es = EnsureCE es a -> Maybe (EnsureCE es a)
forall a. a -> Maybe a
Just (Maybe a -> es -> EnsureCE es a
forall es a. CanEnsureCE es a => Maybe a -> es -> EnsureCE es a
noValueECE (Maybe (Maybe a) -> Maybe a
forall a. HasCallStack => Maybe a -> a
fromJust Maybe (Maybe a)
sample_vCE) es
es)

  prependErrorsECE :: Maybe (Maybe a)
-> es -> EnsureCE es (Maybe a) -> EnsureCE es (Maybe a)
prependErrorsECE Maybe (Maybe a)
sample_vCE es
es (Just vCE) =
    EnsureCE es a -> Maybe (EnsureCE es a)
forall a. a -> Maybe a
Just (EnsureCE es a -> Maybe (EnsureCE es a))
-> EnsureCE es a -> Maybe (EnsureCE es a)
forall a b. (a -> b) -> a -> b
$ Maybe a -> es -> EnsureCE es a -> EnsureCE es a
forall es a.
CanEnsureCE es a =>
Maybe a -> es -> EnsureCE es a -> EnsureCE es a
prependErrorsECE (Maybe (Maybe a) -> Maybe a
forall a. HasCallStack => Maybe a -> a
fromJust Maybe (Maybe a)
sample_vCE) es
es EnsureCE es a
vCE
  prependErrorsECE Maybe (Maybe a)
_sample_vCE es
_es EnsureCE es (Maybe a)
Nothing = EnsureCE es (Maybe a)
forall a. Maybe a
Nothing

instance
  (SuitableForCE es, CanEnsureCE es a)
  =>
  CanEnsureCE es (b -> a)
  where
  type EnsureCE es (b -> a) = b -> (EnsureCE es a)
  type EnsureNoCE es (b -> a) = b ->  (EnsureNoCE es a)

  ensureCE :: Maybe es -> (b -> a) -> EnsureCE es (b -> a)
ensureCE Maybe es
sample_es = ((Maybe es -> a -> EnsureCE es a
forall es a. CanEnsureCE es a => Maybe es -> a -> EnsureCE es a
ensureCE Maybe es
sample_es) (a -> EnsureCE es a) -> (b -> a) -> b -> EnsureCE es a
forall b c a. (b -> c) -> (a -> b) -> a -> c
.)
  deEnsureCE :: Maybe es -> EnsureCE es (b -> a) -> Either es (b -> a)
deEnsureCE Maybe es
sample_es EnsureCE es (b -> a)
f =
    (b -> a) -> Either es (b -> a)
forall a b. b -> Either a b
Right ((b -> a) -> Either es (b -> a)) -> (b -> a) -> Either es (b -> a)
forall a b. (a -> b) -> a -> b
$ \ b
a ->
      case Maybe es -> EnsureCE es a -> Either es a
forall es a.
CanEnsureCE es a =>
Maybe es -> EnsureCE es a -> Either es a
deEnsureCE Maybe es
sample_es (EnsureCE es (b -> a)
b -> EnsureCE es a
f b
a) of
        Right a
v -> a
v
        Left es
es -> String -> a
forall a. HasCallStack => String -> a
error (String -> a) -> String -> a
forall a b. (a -> b) -> a -> b
$ String
"deEnsureCE for function: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ es -> String
forall a. Show a => a -> String
show es
es
  ensureNoCE :: Maybe es -> (b -> a) -> (Maybe (EnsureNoCE es (b -> a)), es)
ensureNoCE Maybe es
sample_es b -> a
f = ((b -> EnsureNoCE es a) -> Maybe (b -> EnsureNoCE es a)
forall a. a -> Maybe a
Just b -> EnsureNoCE es a
f', es
forall a. Monoid a => a
mempty)
    where
    f' :: b -> EnsureNoCE es a
f' b
a =
      case Maybe es -> a -> (Maybe (EnsureNoCE es a), es)
forall es a.
CanEnsureCE es a =>
Maybe es -> a -> (Maybe (EnsureNoCE es a), es)
ensureNoCE Maybe es
sample_es (b -> a
f b
a) of
        (Just EnsureNoCE es a
v, es
_) -> EnsureNoCE es a
v
        (Maybe (EnsureNoCE es a)
_, es
es) -> String -> EnsureNoCE es a
forall a. HasCallStack => String -> a
error (String -> EnsureNoCE es a) -> String -> EnsureNoCE es a
forall a b. (a -> b) -> a -> b
$ String
"ensureNoCE for function: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ es -> String
forall a. Show a => a -> String
show es
es

  noValueECE :: Maybe (b -> a) -> es -> EnsureCE es (b -> a)
noValueECE (Maybe (b -> a)
_fvCE :: Maybe (b -> a)) es
es =
    EnsureCE es a -> b -> EnsureCE es a
forall a b. a -> b -> a
const (Maybe a -> es -> EnsureCE es a
forall es a. CanEnsureCE es a => Maybe a -> es -> EnsureCE es a
noValueECE (Maybe a
forall a. Maybe a
Nothing :: Maybe a) es
es)

  prependErrorsECE :: Maybe (b -> a)
-> es -> EnsureCE es (b -> a) -> EnsureCE es (b -> a)
prependErrorsECE (Maybe (b -> a)
_fvCE :: Maybe (b -> a)) es
es =
    ((Maybe a -> es -> EnsureCE es a -> EnsureCE es a
forall es a.
CanEnsureCE es a =>
Maybe a -> es -> EnsureCE es a -> EnsureCE es a
prependErrorsECE (Maybe a
forall a. Maybe a
Nothing :: Maybe a) es
es) (EnsureCE es a -> EnsureCE es a)
-> (b -> EnsureCE es a) -> b -> EnsureCE es a
forall b c a. (b -> c) -> (a -> b) -> a -> c
.)

-- instance (Monoid es) => CanEnsureCE es [a] where
-- instance (Monoid es) => CanEnsureCE es (Either e a) where

{-| An unsafe way to get a value out of an CollectErrors wrapper. -}
getValueOrThrowErrorsNCE ::
  (SuitableForCE es, CanEnsureCE es v, Show v)
  =>
  Maybe es {-^ sample only -} ->
  v -> (EnsureNoCE es v)
getValueOrThrowErrorsNCE :: Maybe es -> v -> EnsureNoCE es v
getValueOrThrowErrorsNCE Maybe es
sample_es v
v =
  case Maybe es -> v -> (Maybe (EnsureNoCE es v), es)
forall es a.
CanEnsureCE es a =>
Maybe es -> a -> (Maybe (EnsureNoCE es a), es)
ensureNoCE Maybe es
sample_es v
v of
    (Just EnsureNoCE es v
vNCE, es
es) | Bool -> Bool
not (es -> Bool
forall es. CanTestErrorsCertain es => es -> Bool
hasCertainError es
es) -> EnsureNoCE es v
vNCE
    (Maybe (EnsureNoCE es v), es)
_ -> String -> EnsureNoCE es v
forall a. HasCallStack => String -> a
error (v -> String
forall a. Show a => a -> String
show v
v)

{-|
  Add error collection support to an unary function whose
  result may already have collected errors.
-}
lift1CE ::
  (SuitableForCE es
  , CanEnsureCE es a, CanEnsureCE es c)
  =>
  (a -> c) ->
  (CollectErrors es a) -> (EnsureCE es c)
lift1CE :: (a -> c) -> CollectErrors es a -> EnsureCE es c
lift1CE a -> c
fn CollectErrors es a
aCE =
  case Maybe a
ma of
    Just a
a ->
      Maybe c -> es -> EnsureCE es c -> EnsureCE es c
forall es a.
CanEnsureCE es a =>
Maybe a -> es -> EnsureCE es a -> EnsureCE es a
prependErrorsECE Maybe c
sample_c es
a_es (EnsureCE es c -> EnsureCE es c) -> EnsureCE es c -> EnsureCE es c
forall a b. (a -> b) -> a -> b
$ Maybe es -> c -> EnsureCE es c
forall es a. CanEnsureCE es a => Maybe es -> a -> EnsureCE es a
ensureCE Maybe es
sample_es (c -> EnsureCE es c) -> c -> EnsureCE es c
forall a b. (a -> b) -> a -> b
$ a -> c
fn a
a
    Maybe a
_ ->
      Maybe c -> es -> EnsureCE es c
forall es a. CanEnsureCE es a => Maybe a -> es -> EnsureCE es a
noValueECE Maybe c
sample_c es
a_es
  where
  CollectErrors Maybe a
ma es
a_es = CollectErrors es a
aCE
  sample_es :: Maybe es
sample_es = es -> Maybe es
forall a. a -> Maybe a
Just es
a_es
  sample_c :: Maybe c
sample_c = a -> c
fn (a -> c) -> Maybe a -> Maybe c
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe a
ma

{-|
  Add error collection support to a binary function whose
  result may already have collected errors.
-}
lift2CE ::
  (SuitableForCE es
  , CanEnsureCE es a, CanEnsureCE es b, CanEnsureCE es c)
  =>
  (a -> b -> c) ->
  (CollectErrors es a) -> (CollectErrors es b) -> (EnsureCE es c)
lift2CE :: (a -> b -> c)
-> CollectErrors es a -> CollectErrors es b -> EnsureCE es c
lift2CE a -> b -> c
fn CollectErrors es a
aCE CollectErrors es b
bCE =
  case (Maybe a
ma, Maybe b
mb) of
    (Just a
a, Just b
b) ->
      Maybe c -> es -> EnsureCE es c -> EnsureCE es c
forall es a.
CanEnsureCE es a =>
Maybe a -> es -> EnsureCE es a -> EnsureCE es a
prependErrorsECE Maybe c
sample_c es
ab_es (EnsureCE es c -> EnsureCE es c) -> EnsureCE es c -> EnsureCE es c
forall a b. (a -> b) -> a -> b
$ Maybe es -> c -> EnsureCE es c
forall es a. CanEnsureCE es a => Maybe es -> a -> EnsureCE es a
ensureCE Maybe es
sample_es (c -> EnsureCE es c) -> c -> EnsureCE es c
forall a b. (a -> b) -> a -> b
$ a -> b -> c
fn a
a b
b
    (Maybe a, Maybe b)
_ ->
      Maybe c -> es -> EnsureCE es c
forall es a. CanEnsureCE es a => Maybe a -> es -> EnsureCE es a
noValueECE Maybe c
sample_c es
ab_es
  where
  CollectErrors Maybe a
ma es
a_es = CollectErrors es a
aCE
  CollectErrors Maybe b
mb es
b_es = CollectErrors es b
bCE
  ab_es :: es
ab_es = es
a_es es -> es -> es
forall a. Semigroup a => a -> a -> a
<> es
b_es
  sample_es :: Maybe es
sample_es = es -> Maybe es
forall a. a -> Maybe a
Just es
a_es
  sample_c :: Maybe c
sample_c = a -> b -> c
fn (a -> b -> c) -> Maybe a -> Maybe (b -> c)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe a
ma Maybe (b -> c) -> Maybe b -> Maybe c
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Maybe b
mb

{-|
  Add error collection support to a binary function whose
  result may already have collected errors.
  A version where the second operand is not lifted, only the first one.
-}
lift2TCE ::
  (SuitableForCE es
  , CanEnsureCE es a, CanEnsureCE es c)
  =>
  (a -> b -> c) ->
  (CollectErrors es a) -> b -> (EnsureCE es c)
lift2TCE :: (a -> b -> c) -> CollectErrors es a -> b -> EnsureCE es c
lift2TCE a -> b -> c
fn CollectErrors es a
aCE b
b =
  case Maybe a
ma of
    (Just a
a) ->
      Maybe c -> es -> EnsureCE es c -> EnsureCE es c
forall es a.
CanEnsureCE es a =>
Maybe a -> es -> EnsureCE es a -> EnsureCE es a
prependErrorsECE Maybe c
sample_c es
a_es (EnsureCE es c -> EnsureCE es c) -> EnsureCE es c -> EnsureCE es c
forall a b. (a -> b) -> a -> b
$ Maybe es -> c -> EnsureCE es c
forall es a. CanEnsureCE es a => Maybe es -> a -> EnsureCE es a
ensureCE Maybe es
sample_es (c -> EnsureCE es c) -> c -> EnsureCE es c
forall a b. (a -> b) -> a -> b
$ a -> b -> c
fn a
a b
b
    Maybe a
_ ->
      Maybe c -> es -> EnsureCE es c
forall es a. CanEnsureCE es a => Maybe a -> es -> EnsureCE es a
noValueECE Maybe c
sample_c es
a_es
  where
  CollectErrors Maybe a
ma es
a_es = CollectErrors es a
aCE
  sample_es :: Maybe es
sample_es = es -> Maybe es
forall a. a -> Maybe a
Just es
a_es
  sample_c :: Maybe c
sample_c = a -> b -> c
fn (a -> b -> c) -> Maybe a -> Maybe (b -> c)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe a
ma Maybe (b -> c) -> Maybe b -> Maybe c
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (b -> Maybe b
forall a. a -> Maybe a
Just b
b)

{-|
  Add error collection support to a binary function whose
  result may already have collected errors.
  A version where the first operand is not lifted, only the second one.
-}
lift2TLCE ::
  (SuitableForCE es
  , CanEnsureCE es b, CanEnsureCE es c)
  =>
  (a -> b -> c) ->
  a -> (CollectErrors es b) -> (EnsureCE es c)
lift2TLCE :: (a -> b -> c) -> a -> CollectErrors es b -> EnsureCE es c
lift2TLCE a -> b -> c
f = (CollectErrors es b -> a -> EnsureCE es c)
-> a -> CollectErrors es b -> EnsureCE es c
forall a b c. (a -> b -> c) -> b -> a -> c
flip ((CollectErrors es b -> a -> EnsureCE es c)
 -> a -> CollectErrors es b -> EnsureCE es c)
-> (CollectErrors es b -> a -> EnsureCE es c)
-> a
-> CollectErrors es b
-> EnsureCE es c
forall a b. (a -> b) -> a -> b
$ (b -> a -> c) -> CollectErrors es b -> a -> EnsureCE es c
forall es a c b.
(SuitableForCE es, CanEnsureCE es a, CanEnsureCE es c) =>
(a -> b -> c) -> CollectErrors es a -> b -> EnsureCE es c
lift2TCE ((a -> b -> c) -> b -> a -> c
forall a b c. (a -> b -> c) -> b -> a -> c
flip a -> b -> c
f)

{-|
  Add error collection support to a binary function whose
  result may already have collected errors.
-}
lift3CE ::
  (SuitableForCE es
  , CanEnsureCE es a, CanEnsureCE es b, CanEnsureCE es c, CanEnsureCE es d)
  =>
  (a -> b -> c -> d) ->
  (CollectErrors es a) -> (CollectErrors es b) -> (CollectErrors es c) -> (EnsureCE es d)
lift3CE :: (a -> b -> c -> d)
-> CollectErrors es a
-> CollectErrors es b
-> CollectErrors es c
-> EnsureCE es d
lift3CE a -> b -> c -> d
fn CollectErrors es a
aCE CollectErrors es b
bCE CollectErrors es c
cCE =
  case (Maybe a
ma, Maybe b
mb, Maybe c
mc) of
    (Just a
a, Just b
b, Just c
c) ->
      Maybe d -> es -> EnsureCE es d -> EnsureCE es d
forall es a.
CanEnsureCE es a =>
Maybe a -> es -> EnsureCE es a -> EnsureCE es a
prependErrorsECE Maybe d
sample_d es
abc_es (EnsureCE es d -> EnsureCE es d) -> EnsureCE es d -> EnsureCE es d
forall a b. (a -> b) -> a -> b
$ Maybe es -> d -> EnsureCE es d
forall es a. CanEnsureCE es a => Maybe es -> a -> EnsureCE es a
ensureCE Maybe es
sample_es (d -> EnsureCE es d) -> d -> EnsureCE es d
forall a b. (a -> b) -> a -> b
$ a -> b -> c -> d
fn a
a b
b c
c
    (Maybe a, Maybe b, Maybe c)
_ ->
      Maybe d -> es -> EnsureCE es d
forall es a. CanEnsureCE es a => Maybe a -> es -> EnsureCE es a
noValueECE Maybe d
sample_d es
abc_es
  where
  CollectErrors Maybe a
ma es
a_es = CollectErrors es a
aCE
  CollectErrors Maybe b
mb es
b_es = CollectErrors es b
bCE
  CollectErrors Maybe c
mc es
c_es = CollectErrors es c
cCE
  abc_es :: es
abc_es = es
a_es es -> es -> es
forall a. Semigroup a => a -> a -> a
<> es
b_es es -> es -> es
forall a. Semigroup a => a -> a -> a
<> es
c_es
  sample_es :: Maybe es
sample_es = es -> Maybe es
forall a. a -> Maybe a
Just es
a_es
  sample_d :: Maybe d
sample_d = a -> b -> c -> d
fn (a -> b -> c -> d) -> Maybe a -> Maybe (b -> c -> d)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe a
ma Maybe (b -> c -> d) -> Maybe b -> Maybe (c -> d)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Maybe b
mb Maybe (c -> d) -> Maybe c -> Maybe d
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Maybe c
mc


{-|
  Ability to lift collected (potential) errors from inside some structure/collection.

  This is useful mostly for structures that use the default implementation of
  'CanEnsureCE es'.
-}
class (SuitableForCE es) => CanExtractCE es f where
  extractCE ::
    (CanEnsureCE es c) =>
    Maybe es ->
    f c -> CollectErrors es (f (EnsureNoCE es c))
  default extractCE ::
    (CanEnsureCE es c, Traversable f) =>
    Maybe es ->
    f c -> CollectErrors es (f (EnsureNoCE es c))
  extractCE Maybe es
sample_es f c
fc =
    case ((Maybe (EnsureNoCE es c), es) -> Maybe (EnsureNoCE es c))
-> f (Maybe (EnsureNoCE es c), es) -> Maybe (f (EnsureNoCE es c))
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Maybe (EnsureNoCE es c), es) -> Maybe (EnsureNoCE es c)
forall a b. (a, b) -> a
fst f (Maybe (EnsureNoCE es c), es)
fcNoCE of
      Just f (EnsureNoCE es c)
fec -> f (EnsureNoCE es c) -> CollectErrors es (f (EnsureNoCE es c))
forall (f :: * -> *) a. Applicative f => a -> f a
pure f (EnsureNoCE es c)
fec
      Maybe (f (EnsureNoCE es c))
_ -> es -> CollectErrors es (f (EnsureNoCE es c))
forall es v. es -> CollectErrors es v
noValueCE (es -> CollectErrors es (f (EnsureNoCE es c)))
-> es -> CollectErrors es (f (EnsureNoCE es c))
forall a b. (a -> b) -> a -> b
$ ((Maybe (EnsureNoCE es c), es) -> es)
-> f (Maybe (EnsureNoCE es c), es) -> es
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (Maybe (EnsureNoCE es c), es) -> es
forall a b. (a, b) -> b
snd f (Maybe (EnsureNoCE es c), es)
fcNoCE
    where
    fcNoCE :: f (Maybe (EnsureNoCE es c), es)
fcNoCE = (c -> (Maybe (EnsureNoCE es c), es))
-> f c -> f (Maybe (EnsureNoCE es c), es)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Maybe es -> c -> (Maybe (EnsureNoCE es c), es)
forall es a.
CanEnsureCE es a =>
Maybe es -> a -> (Maybe (EnsureNoCE es a), es)
ensureNoCE Maybe es
sample_es) f c
fc