{-# LANGUAGE RankNTypes #-}

{- |
Module      :  Servant.Checked.Exceptions.Internal.Envelope
License     :  BSD3
Maintainer  :  Dennis Gosnell (cdep.illabout@gmail.com)
Stability   :  experimental
Portability :  unknown

These functions are for working with Optics popularized by the
<https://hackage.haskell.org/package/lens lens> package. Documentation can be
found in the lens package.  These functions are redefined here to remove the
dependency on the lens package.
-}

module Servant.Checked.Exceptions.Internal.Prism
  ( Prism
  , prism
  , Prism'
  , prism'
  , Iso
  , iso
  , review
  , preview
  , (<>~)
  ) where

import Data.Profunctor.Unsafe((#.))
import Control.Applicative
import Data.Coerce
import Data.Functor.Identity
import Data.Monoid
import Data.Profunctor
import Data.Tagged

type Iso s t a b
   = forall p f. (Profunctor p, Functor f) =>
                   p a (f b) -> p s (f t)

type Prism s t a b
   = forall p f. (Choice p, Applicative f) =>
                   p a (f b) -> p s (f t)

type Prism' s a = Prism s s a a

type ASetter s t a b = (a -> Identity b) -> s -> Identity t

iso :: (s -> a) -> (b -> t) -> Iso s t a b
iso :: (s -> a) -> (b -> t) -> Iso s t a b
iso s -> a
sa b -> t
bt = (s -> a) -> (f b -> f t) -> p a (f b) -> p s (f t)
forall (p :: * -> * -> *) a b c d.
Profunctor p =>
(a -> b) -> (c -> d) -> p b c -> p a d
dimap s -> a
sa ((b -> t) -> f b -> f t
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap b -> t
bt)
{-# INLINE iso #-}

prism :: (b -> t) -> (s -> Either t a) -> Prism s t a b
prism :: (b -> t) -> (s -> Either t a) -> Prism s t a b
prism b -> t
bt s -> Either t a
seta = (s -> Either t a)
-> (Either t (f b) -> f t)
-> p (Either t a) (Either t (f b))
-> p s (f t)
forall (p :: * -> * -> *) a b c d.
Profunctor p =>
(a -> b) -> (c -> d) -> p b c -> p a d
dimap s -> Either t a
seta ((t -> f t) -> (f b -> f t) -> Either t (f b) -> f t
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either t -> f t
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((b -> t) -> f b -> f t
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap b -> t
bt)) (p (Either t a) (Either t (f b)) -> p s (f t))
-> (p a (f b) -> p (Either t a) (Either t (f b)))
-> p a (f b)
-> p s (f t)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. p a (f b) -> p (Either t a) (Either t (f b))
forall (p :: * -> * -> *) a b c.
Choice p =>
p a b -> p (Either c a) (Either c b)
right'
{-# INLINE prism #-}

prism' :: (a -> s) -> (s -> Maybe a) -> Prism' s a
prism' :: (a -> s) -> (s -> Maybe a) -> Prism' s a
prism' a -> s
bs s -> Maybe a
sma = (a -> s) -> (s -> Either s a) -> Prism' s a
forall b t s a. (b -> t) -> (s -> Either t a) -> Prism s t a b
prism a -> s
bs (\s
s -> Either s a -> (a -> Either s a) -> Maybe a -> Either s a
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (s -> Either s a
forall a b. a -> Either a b
Left s
s) a -> Either s a
forall a b. b -> Either a b
Right (s -> Maybe a
sma s
s))
{-# INLINE prism' #-}

review :: Prism' t b -> b -> t
review :: Prism' t b -> b -> t
review Prism' t b
p = Tagged t (Identity t) -> t
coerce (Tagged t (Identity t) -> t)
-> (b -> Tagged t (Identity t)) -> b -> t
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Tagged b (Identity b) -> Tagged t (Identity t)
Prism' t b
p (Tagged b (Identity b) -> Tagged t (Identity t))
-> (b -> Tagged b (Identity b)) -> b -> Tagged t (Identity t)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Identity b -> Tagged b (Identity b)
forall k (s :: k) b. b -> Tagged s b
Tagged (Identity b -> Tagged b (Identity b))
-> (b -> Identity b) -> b -> Tagged b (Identity b)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. b -> Identity b
forall a. a -> Identity a
Identity
{-# INLINE review #-}

preview :: Prism' s a -> s -> Maybe a
preview :: Prism' s a -> s -> Maybe a
preview Prism' s a
l = Const (First a) s -> Maybe a
coerce (Const (First a) s -> Maybe a)
-> (s -> Const (First a) s) -> s -> Maybe a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> Const (First a) a) -> s -> Const (First a) s
Prism' s a
l (First a -> Const (First a) a
forall k a (b :: k). a -> Const a b
Const (First a -> Const (First a) a)
-> (a -> First a) -> a -> Const (First a) a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe a -> First a
forall a. Maybe a -> First a
First (Maybe a -> First a) -> (a -> Maybe a) -> a -> First a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Maybe a
forall a. a -> Maybe a
Just)
{-# INLINE preview #-}

over :: ASetter s t a b -> (a -> b) -> s -> t
over :: ASetter s t a b -> (a -> b) -> s -> t
over ASetter s t a b
l a -> b
f = Identity t -> t
forall a. Identity a -> a
runIdentity (Identity t -> t) -> (s -> Identity t) -> s -> t
forall (p :: * -> * -> *) a b c (q :: * -> * -> *).
(Profunctor p, Coercible c b) =>
q b c -> p a b -> p a c
#. ASetter s t a b
l (b -> Identity b
forall a. a -> Identity a
Identity (b -> Identity b) -> (a -> b) -> a -> Identity b
forall (p :: * -> * -> *) a b c (q :: * -> * -> *).
(Profunctor p, Coercible c b) =>
q b c -> p a b -> p a c
#. a -> b
f)
{-# INLINE over #-}

infixr 4 <>~
(<>~) :: Monoid a => ASetter s t a a -> a -> s -> t
ASetter s t a a
l <>~ :: ASetter s t a a -> a -> s -> t
<>~ a
n = ASetter s t a a -> (a -> a) -> s -> t
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over ASetter s t a a
l (a -> a -> a
forall a. Monoid a => a -> a -> a
`mappend` a
n)
{-# INLINE (<>~) #-}