{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE DerivingStrategies, DeriveFunctor, DerivingVia, StandaloneDeriving #-}

module DSV.ViewType
  ( View (..), overViewError, inputAsViewError, applyView, viewOrThrow, viewOrThrowInput, constView, maybeView, viewMaybe, viewOr, viewOr'
  , discardViewError, (>>>-), (<<<-)
  ) where

import DSV.IO
import DSV.Prelude
import DSV.Validation

-- base
import Control.Arrow
import Control.Category

newtype View e a b = View (a -> Validation e b)
    deriving stock a -> View e a b -> View e a a
(a -> b) -> View e a a -> View e a b
(forall a b. (a -> b) -> View e a a -> View e a b)
-> (forall a b. a -> View e a b -> View e a a)
-> Functor (View e a)
forall a b. a -> View e a b -> View e a a
forall a b. (a -> b) -> View e a a -> View e a b
forall e a a b. a -> View e a b -> View e a a
forall e a a b. (a -> b) -> View e a a -> View e a b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> View e a b -> View e a a
$c<$ :: forall e a a b. a -> View e a b -> View e a a
fmap :: (a -> b) -> View e a a -> View e a b
$cfmap :: forall e a a b. (a -> b) -> View e a a -> View e a b
Functor

deriving via Compose ((->) a) (Validation e)
    instance Semigroup e => Applicative (View e a)

instance Category (View e)
  where
    id :: View e a a
id = (a -> Validation e a) -> View e a a
forall e a b. (a -> Validation e b) -> View e a b
View a -> Validation e a
forall err a. a -> Validation err a
Success

    View b -> Validation e c
f . :: View e b c -> View e a b -> View e a c
. View a -> Validation e b
g =
      (a -> Validation e c) -> View e a c
forall e a b. (a -> Validation e b) -> View e a b
View ((a -> Validation e c) -> View e a c)
-> (a -> Validation e c) -> View e a c
forall a b. (a -> b) -> a -> b
$ \a
x ->
        case a -> Validation e b
g a
x of
          Failure e
e -> e -> Validation e c
forall err a. err -> Validation err a
Failure e
e
          Success b
y -> b -> Validation e c
f b
y

instance Arrow (View e)
  where
    arr :: (b -> c) -> View e b c
arr b -> c
f = (b -> Validation e c) -> View e b c
forall e a b. (a -> Validation e b) -> View e a b
View (c -> Validation e c
forall err a. a -> Validation err a
Success (c -> Validation e c) -> (b -> c) -> b -> Validation e c
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. b -> c
f)

    first :: View e b c -> View e (b, d) (c, d)
first (View b -> Validation e c
f) =
      ((b, d) -> Validation e (c, d)) -> View e (b, d) (c, d)
forall e a b. (a -> Validation e b) -> View e a b
View (((b, d) -> Validation e (c, d)) -> View e (b, d) (c, d))
-> ((b, d) -> Validation e (c, d)) -> View e (b, d) (c, d)
forall a b. (a -> b) -> a -> b
$ \(b
x, d
y) ->
        case b -> Validation e c
f b
x of
          Failure e
e -> e -> Validation e (c, d)
forall err a. err -> Validation err a
Failure e
e
          Success c
z -> (c, d) -> Validation e (c, d)
forall err a. a -> Validation err a
Success (c
z, d
y)

    second :: View e b c -> View e (d, b) (d, c)
second (View b -> Validation e c
f) =
      ((d, b) -> Validation e (d, c)) -> View e (d, b) (d, c)
forall e a b. (a -> Validation e b) -> View e a b
View (((d, b) -> Validation e (d, c)) -> View e (d, b) (d, c))
-> ((d, b) -> Validation e (d, c)) -> View e (d, b) (d, c)
forall a b. (a -> b) -> a -> b
$ \(d
x, b
y) ->
        case b -> Validation e c
f b
y of
          Failure e
e -> e -> Validation e (d, c)
forall err a. err -> Validation err a
Failure e
e
          Success c
z -> (d, c) -> Validation e (d, c)
forall err a. a -> Validation err a
Success (d
x, c
z)

applyView :: forall e a b .
    View e a b -> a -> Validation e b

applyView :: View e a b -> a -> Validation e b
applyView (View a -> Validation e b
f) a
x = a -> Validation e b
f a
x

viewOrThrow :: forall m e a b.
    (Exception e, MonadThrow m) =>
    View e a b -> a -> m b

viewOrThrow :: View e a b -> a -> m b
viewOrThrow (View a -> Validation e b
f) a
x =
    case a -> Validation e b
f a
x of
        Failure e
e -> e -> m b
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM e
e
        Success b
y -> b -> m b
forall (f :: * -> *) a. Applicative f => a -> f a
pure b
y

viewMaybe :: forall e a b .
    View e a b -> a -> Maybe b

viewMaybe :: View e a b -> a -> Maybe b
viewMaybe View e a b
v a
x =
    case View e a b -> a -> Validation e b
forall e a b. View e a b -> a -> Validation e b
applyView View e a b
v a
x of
        Success b
y -> b -> Maybe b
forall a. a -> Maybe a
Just b
y
        Failure e
_ -> Maybe b
forall a. Maybe a
Nothing

viewOr :: forall e a b .
    b -> View e a b -> a -> b

viewOr :: b -> View e a b -> a -> b
viewOr b
z View e a b
v a
x =
    case View e a b -> a -> Validation e b
forall e a b. View e a b -> a -> Validation e b
applyView View e a b
v a
x of
        Success b
y -> b
y
        Failure e
_ -> b
z

viewOr' :: forall m e a b .
    Applicative m =>
    (a -> e -> m b)
    -> View e a b
    -> a
    -> m b

viewOr' :: (a -> e -> m b) -> View e a b -> a -> m b
viewOr' a -> e -> m b
f View e a b
v a
a =
    case View e a b -> a -> Validation e b
forall e a b. View e a b -> a -> Validation e b
applyView View e a b
v a
a of
        Failure e
e -> a -> e -> m b
f a
a e
e
        Success b
b -> b -> m b
forall (f :: * -> *) a. Applicative f => a -> f a
pure b
b

viewOrThrowInput :: forall m ex e a b .
    (Exception ex, MonadThrow m) =>
    (a -> ex)
    -> View e a b
    -> a
    -> m b

viewOrThrowInput :: (a -> ex) -> View e a b -> a -> m b
viewOrThrowInput a -> ex
f View e a b
v a
a =
    case View e a b -> a -> Validation e b
forall e a b. View e a b -> a -> Validation e b
applyView View e a b
v a
a of
        Failure e
_ -> ex -> m b
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM (a -> ex
f a
a)
        Success b
b -> b -> m b
forall (f :: * -> *) a. Applicative f => a -> f a
pure b
b

constView :: forall e a b .
    b -> View e a b

constView :: b -> View e a b
constView b
x = (a -> Validation e b) -> View e a b
forall e a b. (a -> Validation e b) -> View e a b
View (\a
_ -> b -> Validation e b
forall err a. a -> Validation err a
Success b
x)

maybeView :: forall a b.
    (a -> Maybe b)
    -> View () a b

maybeView :: (a -> Maybe b) -> View () a b
maybeView a -> Maybe b
f = (a -> Validation () b) -> View () a b
forall e a b. (a -> Validation e b) -> View e a b
View (Validation () b
-> (b -> Validation () b) -> Maybe b -> Validation () b
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (() -> Validation () b
forall err a. err -> Validation err a
Failure ()) b -> Validation () b
forall err a. a -> Validation err a
Success (Maybe b -> Validation () b)
-> (a -> Maybe b) -> a -> Validation () b
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. a -> Maybe b
f)

overViewError :: forall e1 e2 a b .
    (e1 -> e2) -> View e1 a b -> View e2 a b

overViewError :: (e1 -> e2) -> View e1 a b -> View e2 a b
overViewError e1 -> e2
f (View a -> Validation e1 b
v) =
  (a -> Validation e2 b) -> View e2 a b
forall e a b. (a -> Validation e b) -> View e a b
View ((a -> Validation e2 b) -> View e2 a b)
-> (a -> Validation e2 b) -> View e2 a b
forall a b. (a -> b) -> a -> b
$ \a
x ->
    case a -> Validation e1 b
v a
x of
      Failure e1
e -> e2 -> Validation e2 b
forall err a. err -> Validation err a
Failure (e1 -> e2
f e1
e)
      Success b
s -> b -> Validation e2 b
forall err a. a -> Validation err a
Success b
s

inputAsViewError :: forall e a b. View e a b -> View a a b
inputAsViewError :: View e a b -> View a a b
inputAsViewError (View a -> Validation e b
v) =
    (a -> Validation a b) -> View a a b
forall e a b. (a -> Validation e b) -> View e a b
View ((a -> Validation a b) -> View a a b)
-> (a -> Validation a b) -> View a a b
forall a b. (a -> b) -> a -> b
$ \a
x ->
      case a -> Validation e b
v a
x of
        Failure e
_ -> a -> Validation a b
forall err a. err -> Validation err a
Failure a
x
        Success b
s -> b -> Validation a b
forall err a. a -> Validation err a
Success b
s

discardViewError :: View e a b -> View () a b

discardViewError :: View e a b -> View () a b
discardViewError = (e -> ()) -> View e a b -> View () a b
forall e1 e2 a b. (e1 -> e2) -> View e1 a b -> View e2 a b
overViewError (\e
_ -> ())

(<<<-) :: View e1 b c -> View e2 a b -> View () a c
View e1 b c
f <<<- :: View e1 b c -> View e2 a b -> View () a c
<<<- View e2 a b
g = View e1 b c -> View () b c
forall e a b. View e a b -> View () a b
discardViewError View e1 b c
f View () b c -> View () a b -> View () a c
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
<<< View e2 a b -> View () a b
forall e a b. View e a b -> View () a b
discardViewError View e2 a b
g

(>>>-) :: View e2 a b -> View e1 b c -> View () a c
View e2 a b
f >>>- :: View e2 a b -> View e1 b c -> View () a c
>>>- View e1 b c
g = View e2 a b -> View () a b
forall e a b. View e a b -> View () a b
discardViewError View e2 a b
f View () a b -> View () b c -> View () a c
forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> View e1 b c -> View () b c
forall e a b. View e a b -> View () a b
discardViewError View e1 b c
g