{-# LANGUAGE FlexibleContexts     #-}
{-# LANGUAGE FlexibleInstances    #-}
{-# LANGUAGE LambdaCase           #-}
{-# LANGUAGE TypeFamilies         #-}
{-# LANGUAGE UndecidableInstances #-}

module Railroad where

import           Data.Bool               (bool)
import           Data.Foldable           (toList)
import           Data.Kind               (Type)
import           Data.Validation         (Validation, toEither)
import           Effectful               (Eff, type (:>))
import           Effectful.Error.Dynamic (Error, throwError_)


type family CErr f :: Type where
  CErr Bool               = ()
  CErr (Maybe a)          = ()
  CErr (Either e a)       = e
  CErr (Validation e a)   = e
  CErr (t a)              = CErr a
type family CRes f :: Type where
  CRes Bool               = ()
  CRes (Maybe a)          = a
  CRes (Either e a)       = a
  CRes (Validation e a)   = a
  CRes (t a)              = t (CRes a)

-- | A catamorphism to Either
class Bifurcate f where
  bifurcate :: f -> Either (CErr f) (CRes f)
instance Bifurcate Bool where
  bifurcate :: Bool -> Either (CErr Bool) (CRes Bool)
bifurcate = Either () () -> Either () () -> Bool -> Either () ()
forall a. a -> a -> Bool -> a
bool (() -> Either () ()
forall a b. a -> Either a b
Left ()) (() -> Either () ()
forall a b. b -> Either a b
Right ())
  -- bool   :: b -> b -> Bool -> b
instance Bifurcate (Maybe a) where
  bifurcate :: Maybe a -> Either (CErr (Maybe a)) (CRes (Maybe a))
bifurcate = Either () a -> (a -> Either () a) -> Maybe a -> Either () a
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (() -> Either () a
forall a b. a -> Either a b
Left ()) a -> Either () a
forall a b. b -> Either a b
Right
  -- maybe  :: b -> (a -> b) -> Maybe a -> b
instance Bifurcate (Either e a) where
  bifurcate :: Either e a -> Either (CErr (Either e a)) (CRes (Either e a))
bifurcate = Either e a -> Either e a
Either e a -> Either (CErr (Either e a)) (CRes (Either e a))
forall a. a -> a
id
  -- either :: (e -> b) -> (a -> b) -> Either e a -> b
instance Bifurcate (Validation e a) where
  bifurcate :: Validation e a
-> Either (CErr (Validation e a)) (CRes (Validation e a))
bifurcate = Validation e a -> Either e a
Validation e a
-> Either (CErr (Validation e a)) (CRes (Validation e a))
forall e a. Validation e a -> Either e a
toEither
  -- validation :: (e -> b) -> (a -> b) -> Validation e a -> b

instance (Traversable t, CErr (t Bool) ~ (), CRes (t Bool) ~ t ())
    => Bifurcate (t Bool) where
  bifurcate :: t Bool -> Either (CErr (t Bool)) (CRes (t Bool))
bifurcate = Either () (t ()) -> Either () (t ())
Either () (t ())
-> Either (CErr (Either () (t ()))) (CRes (Either () (t ())))
forall f. Bifurcate f => f -> Either (CErr f) (CRes f)
bifurcate (Either () (t ()) -> Either () (t ()))
-> (t Bool -> Either () (t ())) -> t Bool -> Either () (t ())
forall b c a. (b -> c) -> (a -> b) -> a -> c
. t (Either () ()) -> Either () (t ())
forall (t :: * -> *) (f :: * -> *) a.
(Traversable t, Applicative f) =>
t (f a) -> f (t a)
forall (f :: * -> *) a. Applicative f => t (f a) -> f (t a)
sequenceA (t (Either () ()) -> Either () (t ()))
-> (t Bool -> t (Either () ())) -> t Bool -> Either () (t ())
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Bool -> Either () ()) -> t Bool -> t (Either () ())
forall a b. (a -> b) -> t a -> t b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Bool -> Either () ()
Bool -> Either (CErr Bool) (CRes Bool)
forall f. Bifurcate f => f -> Either (CErr f) (CRes f)
bifurcate
  -- Bool is not Applicative, so we need to map to Either first
instance (Traversable t, CErr (t (Maybe a)) ~ (), CRes (t (Maybe a)) ~ t a)
    => Bifurcate (t (Maybe a)) where
  bifurcate :: t (Maybe a) -> Either (CErr (t (Maybe a))) (CRes (t (Maybe a)))
bifurcate = Maybe (t a) -> Either () (t a)
Maybe (t a) -> Either (CErr (Maybe (t a))) (CRes (Maybe (t a)))
forall f. Bifurcate f => f -> Either (CErr f) (CRes f)
bifurcate (Maybe (t a) -> Either () (t a))
-> (t (Maybe a) -> Maybe (t a)) -> t (Maybe a) -> Either () (t a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. t (Maybe a) -> Maybe (t a)
forall (t :: * -> *) (f :: * -> *) a.
(Traversable t, Applicative f) =>
t (f a) -> f (t a)
forall (f :: * -> *) a. Applicative f => t (f a) -> f (t a)
sequenceA
instance (Traversable t, CErr (t (Either e a)) ~ e, CRes (t (Either e a)) ~ t a)
    => Bifurcate (t (Either e a)) where
  bifurcate :: t (Either e a)
-> Either (CErr (t (Either e a))) (CRes (t (Either e a)))
bifurcate = t (Either e a) -> Either e (t a)
t (Either e a)
-> Either (CErr (t (Either e a))) (CRes (t (Either e a)))
forall (t :: * -> *) (f :: * -> *) a.
(Traversable t, Applicative f) =>
t (f a) -> f (t a)
forall (f :: * -> *) a. Applicative f => t (f a) -> f (t a)
sequenceA
  -- pedagogically: bifurcate = bifurcate . sequenceA
instance (Traversable t, Semigroup e, CErr (t (Validation e a)) ~ e, CRes (t (Validation e a)) ~ t a)
    => Bifurcate (t (Validation e a)) where
  bifurcate :: t (Validation e a)
-> Either (CErr (t (Validation e a))) (CRes (t (Validation e a)))
bifurcate = Validation e (t a) -> Either e (t a)
forall e a. Validation e a -> Either e a
toEither (Validation e (t a) -> Either e (t a))
-> (t (Validation e a) -> Validation e (t a))
-> t (Validation e a)
-> Either e (t a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. t (Validation e a) -> Validation e (t a)
forall (t :: * -> *) (f :: * -> *) a.
(Traversable t, Applicative f) =>
t (f a) -> f (t a)
forall (f :: * -> *) a. Applicative f => t (f a) -> f (t a)
sequenceA
  -- pedagogically: bifurcate = bifurcate . sequenceA

-- | Collapses a structure into its inner type or an effectful error
collapse :: (Error e :> es, Bifurcate f) => (CErr f -> e) -> f -> Eff es (CRes f)
collapse :: forall e (es :: [Effect]) f.
(Error e :> es, Bifurcate f) =>
(CErr f -> e) -> f -> Eff es (CRes f)
collapse CErr f -> e
toErr = (CErr f -> Eff es (CRes f))
-> (CRes f -> Eff es (CRes f))
-> Either (CErr f) (CRes f)
-> Eff es (CRes f)
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (e -> Eff es (CRes f)
forall e (es :: [Effect]) a.
(HasCallStack, Error e :> es) =>
e -> Eff es a
throwError_ (e -> Eff es (CRes f))
-> (CErr f -> e) -> CErr f -> Eff es (CRes f)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CErr f -> e
toErr) CRes f -> Eff es (CRes f)
forall a. a -> Eff es a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either (CErr f) (CRes f) -> Eff es (CRes f))
-> (f -> Either (CErr f) (CRes f)) -> f -> Eff es (CRes f)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. f -> Either (CErr f) (CRes f)
forall f. Bifurcate f => f -> Either (CErr f) (CRes f)
bifurcate


-- | Collapses a structure using an error mapper.
(??) :: forall a es e. (Error e :> es, Bifurcate a) => Eff es a -> (CErr a -> e) -> Eff es (CRes a)
Eff es a
action ?? :: forall a (es :: [Effect]) e.
(Error e :> es, Bifurcate a) =>
Eff es a -> (CErr a -> e) -> Eff es (CRes a)
?? CErr a -> e
toErr = Eff es a
action Eff es a -> (a -> Eff es (CRes a)) -> Eff es (CRes a)
forall a b. Eff es a -> (a -> Eff es b) -> Eff es b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (CErr a -> e) -> a -> Eff es (CRes a)
forall e (es :: [Effect]) f.
(Error e :> es, Bifurcate f) =>
(CErr f -> e) -> f -> Eff es (CRes f)
collapse CErr a -> e
toErr

-- | Collapses a structure using a constant error.
(?) :: forall es e a. (Error e :> es, Bifurcate a) => Eff es a -> e -> Eff es (CRes a)
Eff es a
action ? :: forall (es :: [Effect]) e a.
(Error e :> es, Bifurcate a) =>
Eff es a -> e -> Eff es (CRes a)
? e
err = Eff es a
action Eff es a -> (CErr a -> e) -> Eff es (CRes a)
forall a (es :: [Effect]) e.
(Error e :> es, Bifurcate a) =>
Eff es a -> (CErr a -> e) -> Eff es (CRes a)
?? e -> CErr a -> e
forall a b. a -> b -> a
const e
err

-- | Collapses any value based on a predicate
(?>) :: forall es e a. (Error e :> es) => Eff es a -> (a -> Bool) -> (a -> e) -> Eff es a
?> :: forall (es :: [Effect]) e a.
(Error e :> es) =>
Eff es a -> (a -> Bool) -> (a -> e) -> Eff es a
(?>) Eff es a
action a -> Bool
predicate a -> e
toErr = do
  val <- Eff es a
action
  if predicate val then pure val else throwError_ $ toErr val

-- | Collapses a structure and recovers to a value dependent on the error
(??~) :: forall es a. Bifurcate a => Eff es a -> (CErr a -> CRes a) -> Eff es (CRes a)
Eff es a
action ??~ :: forall (es :: [Effect]) a.
Bifurcate a =>
Eff es a -> (CErr a -> CRes a) -> Eff es (CRes a)
??~ CErr a -> CRes a
defaultFunc = Eff es a
action Eff es a -> (a -> Eff es (CRes a)) -> Eff es (CRes a)
forall a b. Eff es a -> (a -> Eff es b) -> Eff es b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (CErr a -> Eff es (CRes a))
-> (CRes a -> Eff es (CRes a))
-> Either (CErr a) (CRes a)
-> Eff es (CRes a)
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (CRes a -> Eff es (CRes a)
forall a. a -> Eff es a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (CRes a -> Eff es (CRes a))
-> (CErr a -> CRes a) -> CErr a -> Eff es (CRes a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CErr a -> CRes a
defaultFunc) CRes a -> Eff es (CRes a)
forall a. a -> Eff es a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either (CErr a) (CRes a) -> Eff es (CRes a))
-> (a -> Either (CErr a) (CRes a)) -> a -> Eff es (CRes a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Either (CErr a) (CRes a)
forall f. Bifurcate f => f -> Either (CErr f) (CRes f)
bifurcate

-- | Collapses a structure, and recovers to a constant default value in the error case
(?~) :: forall es a. Bifurcate a => Eff es a -> CRes a -> Eff es (CRes a)
Eff es a
action ?~ :: forall (es :: [Effect]) a.
Bifurcate a =>
Eff es a -> CRes a -> Eff es (CRes a)
?~ CRes a
defaultVal = Eff es a
action Eff es a -> (CErr a -> CRes a) -> Eff es (CRes a)
forall (es :: [Effect]) a.
Bifurcate a =>
Eff es a -> (CErr a -> CRes a) -> Eff es (CRes a)
??~ (CRes a -> CErr a -> CRes a
forall a b. a -> b -> a
const CRes a
defaultVal)


-- TODO: Derive instances for it? Functor?
data CardinalityError ta = IsEmpty | TooMany !ta

-- | Catamorphism for CardinalityError
cardinalityErr :: e -> (ta -> e) -> CardinalityError ta -> e
cardinalityErr :: forall e ta. e -> (ta -> e) -> CardinalityError ta -> e
cardinalityErr e
onEmpty ta -> e
onTooMany = \case
  CardinalityError ta
IsEmpty -> e
onEmpty
  TooMany ta
xs -> ta -> e
onTooMany ta
xs


-- |  Non-empty is sucess state. Returns the collection as-is.
(?+) :: forall es e t a. (Error e :> es, Foldable t)
     => Eff es (t a) -> e -> Eff es (t a)
?+ :: forall (es :: [Effect]) e (t :: * -> *) a.
(Error e :> es, Foldable t) =>
Eff es (t a) -> e -> Eff es (t a)
(?+) Eff es (t a)
action e
err = do
  xs <- Eff es (t a)
action
  if null xs then throwError_ err else pure xs


-- | Single element is sucess state.  Returns the single element
(?!) :: forall es e t a. (Error e :> es, Foldable t)
     => Eff es (t a) -> (CardinalityError (t a) -> e) -> Eff es a
?! :: forall (es :: [Effect]) e (t :: * -> *) a.
(Error e :> es, Foldable t) =>
Eff es (t a) -> (CardinalityError (t a) -> e) -> Eff es a
(?!) Eff es (t a)
action CardinalityError (t a) -> e
toErr = do
  xs <- Eff es (t a)
action
  case toList xs of
    []  -> e -> Eff es a
forall e (es :: [Effect]) a.
(HasCallStack, Error e :> es) =>
e -> Eff es a
throwError_ (e -> Eff es a) -> e -> Eff es a
forall a b. (a -> b) -> a -> b
$ CardinalityError (t a) -> e
toErr CardinalityError (t a)
forall ta. CardinalityError ta
IsEmpty
    [a
x] -> a -> Eff es a
forall a. a -> Eff es a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
x
    [a]
_   -> e -> Eff es a
forall e (es :: [Effect]) a.
(HasCallStack, Error e :> es) =>
e -> Eff es a
throwError_ (e -> Eff es a) -> e -> Eff es a
forall a b. (a -> b) -> a -> b
$ CardinalityError (t a) -> e
toErr (CardinalityError (t a) -> e) -> CardinalityError (t a) -> e
forall a b. (a -> b) -> a -> b
$ t a -> CardinalityError (t a)
forall ta. ta -> CardinalityError ta
TooMany t a
xs


-- | Empty is success state. Returns Unit.
(?∅) :: forall es e t a. (Error e :> es, Foldable t)
     => Eff es (t a) -> ((t a) -> e) -> Eff es ()
?∅ :: forall (es :: [Effect]) e (t :: * -> *) a.
(Error e :> es, Foldable t) =>
Eff es (t a) -> (t a -> e) -> Eff es ()
(?∅) Eff es (t a)
action t a -> e
toErr = do
  xs <- Eff es (t a)
action
  if null xs then pure () else throwError_ (toErr xs)



infixl  0 ??, ?, ?~, ?!, ?+, ?∅
infixl 1 ?>