{-# 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
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