{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TupleSections #-}
module Fresnel.Prism
( -- * Prisms
  Prism
, Prism'
, IsPrism
  -- * Construction
, prism
, prism'
  -- * Elimination
, withPrism
, matching
, matching'
, is
, isn't
  -- * Relations
, only
, nearly
  -- * Combinators
, without
, below
, aside
  -- * Unpacked
, UnpackedPrism(..)
, unpackedPrism
) where

import Control.Monad (guard)
import Data.Bifunctor (Bifunctor(..))
import Data.Profunctor
import Fresnel.Iso.Internal (IsIso)
import Fresnel.Optic
import Fresnel.Optional (is, isn't, matching, matching')
import Fresnel.Prism.Internal (IsPrism)

-- Prisms

type Prism s t a b = forall p . IsPrism p => Optic p s t a b

type Prism' s a = Prism s s a a


-- Construction

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
inj s -> Either t a
prj = (s -> Either t a)
-> (Either t b -> t) -> p (Either t a) (Either t b) -> p s t
forall (p :: * -> * -> *) a b c d.
Profunctor p =>
(a -> b) -> (c -> d) -> p b c -> p a d
dimap s -> Either t a
prj ((t -> t) -> (b -> t) -> Either t b -> t
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either t -> t
forall a. a -> a
id b -> t
inj) (p (Either t a) (Either t b) -> p s t)
-> (p a b -> p (Either t a) (Either t b)) -> p a b -> p s t
forall b c a. (b -> c) -> (a -> b) -> a -> c
. p a b -> p (Either t a) (Either t b)
forall (p :: * -> * -> *) a b c.
Choice p =>
p a b -> p (Either c a) (Either c b)
right'

prism' :: (b -> s) -> (s -> Maybe a) -> Prism s s a b
prism' :: (b -> s) -> (s -> Maybe a) -> Prism s s a b
prism' b -> s
inj s -> Maybe a
prj = (b -> s) -> (s -> Either s a) -> Prism s s a b
forall b t s a. (b -> t) -> (s -> Either t a) -> Prism s t a b
prism b -> s
inj (\ 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
prj s
s))


-- Elimination

withPrism :: Prism s t a b -> (((b -> t) -> (s -> Either t a) -> r) -> r)
withPrism :: Prism s t a b -> ((b -> t) -> (s -> Either t a) -> r) -> r
withPrism Prism s t a b
o = UnpackedPrism a b s t
-> forall r. ((b -> t) -> (s -> Either t a) -> r) -> r
forall a b s t.
UnpackedPrism a b s t
-> forall r. ((b -> t) -> (s -> Either t a) -> r) -> r
withUnpackedPrism (Optic (UnpackedPrism a b) s t a b
Prism s t a b
o ((b -> b) -> (a -> Either b a) -> UnpackedPrism a b a b
forall b t s a.
(b -> t) -> (s -> Either t a) -> UnpackedPrism a b s t
unpackedPrism b -> b
forall a. a -> a
id a -> Either b a
forall a b. b -> Either a b
Right))


-- Relations

only :: Eq a => a -> Prism' a ()
only :: a -> Prism' a ()
only a
a = a -> (a -> Bool) -> Prism' a ()
forall a. a -> (a -> Bool) -> Prism' a ()
nearly a
a (a
a a -> a -> Bool
forall a. Eq a => a -> a -> Bool
==)

nearly :: a -> (a -> Bool) -> Prism' a ()
nearly :: a -> (a -> Bool) -> Prism' a ()
nearly a
a a -> Bool
p = (() -> a) -> (a -> Maybe ()) -> Prism' a ()
forall b s a. (b -> s) -> (s -> Maybe a) -> Prism s s a b
prism' (a -> () -> a
forall a b. a -> b -> a
const a
a) (Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Maybe ()) -> (a -> Bool) -> a -> Maybe ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Bool
p)


-- Combinators

without :: Prism s1 t1 a1 b1 -> Prism s2 t2 a2 b2 -> Prism (Either s1 s2) (Either t1 t2) (Either a1 a2) (Either b1 b2)
without :: Prism s1 t1 a1 b1
-> Prism s2 t2 a2 b2
-> Prism
     (Either s1 s2) (Either t1 t2) (Either a1 a2) (Either b1 b2)
without Prism s1 t1 a1 b1
o1 Prism s2 t2 a2 b2
o2 = Prism s1 t1 a1 b1
-> ((b1 -> t1)
    -> (s1 -> Either t1 a1)
    -> Optic
         p (Either s1 s2) (Either t1 t2) (Either a1 a2) (Either b1 b2))
-> Optic
     p (Either s1 s2) (Either t1 t2) (Either a1 a2) (Either b1 b2)
forall s t a b r.
Prism s t a b -> ((b -> t) -> (s -> Either t a) -> r) -> r
withPrism Prism s1 t1 a1 b1
o1 (((b1 -> t1)
  -> (s1 -> Either t1 a1)
  -> Optic
       p (Either s1 s2) (Either t1 t2) (Either a1 a2) (Either b1 b2))
 -> Optic
      p (Either s1 s2) (Either t1 t2) (Either a1 a2) (Either b1 b2))
-> ((b1 -> t1)
    -> (s1 -> Either t1 a1)
    -> Optic
         p (Either s1 s2) (Either t1 t2) (Either a1 a2) (Either b1 b2))
-> Optic
     p (Either s1 s2) (Either t1 t2) (Either a1 a2) (Either b1 b2)
forall a b. (a -> b) -> a -> b
$ \ b1 -> t1
inj1 s1 -> Either t1 a1
prj1 -> Prism s2 t2 a2 b2
-> ((b2 -> t2)
    -> (s2 -> Either t2 a2)
    -> Optic
         p (Either s1 s2) (Either t1 t2) (Either a1 a2) (Either b1 b2))
-> Optic
     p (Either s1 s2) (Either t1 t2) (Either a1 a2) (Either b1 b2)
forall s t a b r.
Prism s t a b -> ((b -> t) -> (s -> Either t a) -> r) -> r
withPrism Prism s2 t2 a2 b2
o2 (((b2 -> t2)
  -> (s2 -> Either t2 a2)
  -> Optic
       p (Either s1 s2) (Either t1 t2) (Either a1 a2) (Either b1 b2))
 -> Optic
      p (Either s1 s2) (Either t1 t2) (Either a1 a2) (Either b1 b2))
-> ((b2 -> t2)
    -> (s2 -> Either t2 a2)
    -> Optic
         p (Either s1 s2) (Either t1 t2) (Either a1 a2) (Either b1 b2))
-> Optic
     p (Either s1 s2) (Either t1 t2) (Either a1 a2) (Either b1 b2)
forall a b. (a -> b) -> a -> b
$ \ b2 -> t2
inj2 s2 -> Either t2 a2
prj2 ->
  (Either b1 b2 -> Either t1 t2)
-> (Either s1 s2 -> Either (Either t1 t2) (Either a1 a2))
-> Prism
     (Either s1 s2) (Either t1 t2) (Either a1 a2) (Either b1 b2)
forall b t s a. (b -> t) -> (s -> Either t a) -> Prism s t a b
prism ((b1 -> t1) -> (b2 -> t2) -> Either b1 b2 -> Either t1 t2
forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap b1 -> t1
inj1 b2 -> t2
inj2) ((s1 -> Either (Either t1 t2) (Either a1 a2))
-> (s2 -> Either (Either t1 t2) (Either a1 a2))
-> Either s1 s2
-> Either (Either t1 t2) (Either a1 a2)
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either ((t1 -> Either t1 t2)
-> (a1 -> Either a1 a2)
-> Either t1 a1
-> Either (Either t1 t2) (Either a1 a2)
forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap t1 -> Either t1 t2
forall a b. a -> Either a b
Left a1 -> Either a1 a2
forall a b. a -> Either a b
Left (Either t1 a1 -> Either (Either t1 t2) (Either a1 a2))
-> (s1 -> Either t1 a1)
-> s1
-> Either (Either t1 t2) (Either a1 a2)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. s1 -> Either t1 a1
prj1) ((t2 -> Either t1 t2)
-> (a2 -> Either a1 a2)
-> Either t2 a2
-> Either (Either t1 t2) (Either a1 a2)
forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap t2 -> Either t1 t2
forall a b. b -> Either a b
Right a2 -> Either a1 a2
forall a b. b -> Either a b
Right (Either t2 a2 -> Either (Either t1 t2) (Either a1 a2))
-> (s2 -> Either t2 a2)
-> s2
-> Either (Either t1 t2) (Either a1 a2)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. s2 -> Either t2 a2
prj2))

below :: Traversable f => Prism' s a -> Prism' (f s) (f a)
below :: Prism' s a -> Prism' (f s) (f a)
below Prism' s a
o = Prism' s a
-> ((a -> s)
    -> (s -> Either s a) -> Optic p (f s) (f s) (f a) (f a))
-> Optic p (f s) (f s) (f a) (f a)
forall s t a b r.
Prism s t a b -> ((b -> t) -> (s -> Either t a) -> r) -> r
withPrism Prism' s a
o (((a -> s) -> (s -> Either s a) -> Optic p (f s) (f s) (f a) (f a))
 -> Optic p (f s) (f s) (f a) (f a))
-> ((a -> s)
    -> (s -> Either s a) -> Optic p (f s) (f s) (f a) (f a))
-> Optic p (f s) (f s) (f a) (f a)
forall a b. (a -> b) -> a -> b
$ \ a -> s
inj s -> Either s a
prj -> (f a -> f s) -> (f s -> Either (f s) (f a)) -> Prism' (f s) (f a)
forall b t s a. (b -> t) -> (s -> Either t a) -> Prism s t a b
prism ((a -> s) -> f a -> f s
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> s
inj) ((f s -> Either (f s) (f a)) -> Prism' (f s) (f a))
-> (f s -> Either (f s) (f a)) -> Prism' (f s) (f a)
forall a b. (a -> b) -> a -> b
$ \ f s
s -> (s -> f s) -> Either s (f a) -> Either (f s) (f a)
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (f s -> s -> f s
forall a b. a -> b -> a
const f s
s) ((s -> Either s a) -> f s -> Either s (f a)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse s -> Either s a
prj f s
s)

aside :: Prism s t a b -> Prism (e, s) (e, t) (e, a) (e, b)
aside :: Prism s t a b -> Prism (e, s) (e, t) (e, a) (e, b)
aside Prism s t a b
o = Prism s t a b
-> ((b -> t)
    -> (s -> Either t a) -> Optic p (e, s) (e, t) (e, a) (e, b))
-> Optic p (e, s) (e, t) (e, a) (e, b)
forall s t a b r.
Prism s t a b -> ((b -> t) -> (s -> Either t a) -> r) -> r
withPrism Prism s t a b
o (((b -> t)
  -> (s -> Either t a) -> Optic p (e, s) (e, t) (e, a) (e, b))
 -> Optic p (e, s) (e, t) (e, a) (e, b))
-> ((b -> t)
    -> (s -> Either t a) -> Optic p (e, s) (e, t) (e, a) (e, b))
-> Optic p (e, s) (e, t) (e, a) (e, b)
forall a b. (a -> b) -> a -> b
$ \ b -> t
inj s -> Either t a
prj -> ((e, b) -> (e, t))
-> ((e, s) -> Either (e, t) (e, a))
-> Prism (e, s) (e, t) (e, a) (e, b)
forall b t s a. (b -> t) -> (s -> Either t a) -> Prism s t a b
prism ((b -> t) -> (e, b) -> (e, t)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap b -> t
inj) (((e, s) -> Either (e, t) (e, a))
 -> Prism (e, s) (e, t) (e, a) (e, b))
-> ((e, s) -> Either (e, t) (e, a))
-> Prism (e, s) (e, t) (e, a) (e, b)
forall a b. (a -> b) -> a -> b
$ \ (e
e, s
s) -> (t -> (e, t))
-> (a -> (e, a)) -> Either t a -> Either (e, t) (e, a)
forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap (e
e,) (e
e,) (s -> Either t a
prj s
s)


-- Unpacked

newtype UnpackedPrism a b s t = UnpackedPrism { UnpackedPrism a b s t
-> forall r. ((b -> t) -> (s -> Either t a) -> r) -> r
withUnpackedPrism :: forall r . ((b -> t) -> (s -> Either t a) -> r) -> r }

instance Functor (UnpackedPrism a b s) where
  fmap :: (a -> b) -> UnpackedPrism a b s a -> UnpackedPrism a b s b
fmap = (a -> b) -> UnpackedPrism a b s a -> UnpackedPrism a b s b
forall (p :: * -> * -> *) b c a.
Profunctor p =>
(b -> c) -> p a b -> p a c
rmap

instance Profunctor (UnpackedPrism a b) where
  dimap :: (a -> b)
-> (c -> d) -> UnpackedPrism a b b c -> UnpackedPrism a b a d
dimap a -> b
f c -> d
g (UnpackedPrism forall r. ((b -> c) -> (b -> Either c a) -> r) -> r
r) = ((b -> c) -> (b -> Either c a) -> UnpackedPrism a b a d)
-> UnpackedPrism a b a d
forall r. ((b -> c) -> (b -> Either c a) -> r) -> r
r (((b -> c) -> (b -> Either c a) -> UnpackedPrism a b a d)
 -> UnpackedPrism a b a d)
-> ((b -> c) -> (b -> Either c a) -> UnpackedPrism a b a d)
-> UnpackedPrism a b a d
forall a b. (a -> b) -> a -> b
$ \ b -> c
inj b -> Either c a
prj -> (b -> d) -> (a -> Either d a) -> UnpackedPrism a b a d
forall b t s a.
(b -> t) -> (s -> Either t a) -> UnpackedPrism a b s t
unpackedPrism (c -> d
g (c -> d) -> (b -> c) -> b -> d
forall b c a. (b -> c) -> (a -> b) -> a -> c
. b -> c
inj) ((c -> Either d a) -> (a -> Either d a) -> Either c a -> Either d a
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (d -> Either d a
forall a b. a -> Either a b
Left (d -> Either d a) -> (c -> d) -> c -> Either d a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. c -> d
g) a -> Either d a
forall a b. b -> Either a b
Right (Either c a -> Either d a) -> (a -> Either c a) -> a -> Either d a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. b -> Either c a
prj (b -> Either c a) -> (a -> b) -> a -> Either c a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> b
f)

instance Choice (UnpackedPrism a b) where
  left' :: UnpackedPrism a b a b
-> UnpackedPrism a b (Either a c) (Either b c)
left' (UnpackedPrism forall r. ((b -> b) -> (a -> Either b a) -> r) -> r
r) = ((b -> b)
 -> (a -> Either b a)
 -> UnpackedPrism a b (Either a c) (Either b c))
-> UnpackedPrism a b (Either a c) (Either b c)
forall r. ((b -> b) -> (a -> Either b a) -> r) -> r
r (((b -> b)
  -> (a -> Either b a)
  -> UnpackedPrism a b (Either a c) (Either b c))
 -> UnpackedPrism a b (Either a c) (Either b c))
-> ((b -> b)
    -> (a -> Either b a)
    -> UnpackedPrism a b (Either a c) (Either b c))
-> UnpackedPrism a b (Either a c) (Either b c)
forall a b. (a -> b) -> a -> b
$ \ b -> b
inj a -> Either b a
prj -> (b -> Either b c)
-> (Either a c -> Either (Either b c) a)
-> UnpackedPrism a b (Either a c) (Either b c)
forall b t s a.
(b -> t) -> (s -> Either t a) -> UnpackedPrism a b s t
unpackedPrism (b -> Either b c
forall a b. a -> Either a b
Left (b -> Either b c) -> (b -> b) -> b -> Either b c
forall b c a. (b -> c) -> (a -> b) -> a -> c
. b -> b
inj) ((a -> Either (Either b c) a)
-> (c -> Either (Either b c) a)
-> Either a c
-> Either (Either b c) a
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either ((b -> Either (Either b c) a)
-> (a -> Either (Either b c) a)
-> Either b a
-> Either (Either b c) a
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Either b c -> Either (Either b c) a
forall a b. a -> Either a b
Left (Either b c -> Either (Either b c) a)
-> (b -> Either b c) -> b -> Either (Either b c) a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. b -> Either b c
forall a b. a -> Either a b
Left) a -> Either (Either b c) a
forall a b. b -> Either a b
Right (Either b a -> Either (Either b c) a)
-> (a -> Either b a) -> a -> Either (Either b c) a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Either b a
prj) (Either b c -> Either (Either b c) a
forall a b. a -> Either a b
Left (Either b c -> Either (Either b c) a)
-> (c -> Either b c) -> c -> Either (Either b c) a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. c -> Either b c
forall a b. b -> Either a b
Right))

instance IsIso (UnpackedPrism a b)
instance IsPrism (UnpackedPrism a b)


unpackedPrism :: (b -> t) -> (s -> Either t a) -> UnpackedPrism a b s t
unpackedPrism :: (b -> t) -> (s -> Either t a) -> UnpackedPrism a b s t
unpackedPrism b -> t
inj s -> Either t a
prj = (forall r. ((b -> t) -> (s -> Either t a) -> r) -> r)
-> UnpackedPrism a b s t
forall a b s t.
(forall r. ((b -> t) -> (s -> Either t a) -> r) -> r)
-> UnpackedPrism a b s t
UnpackedPrism (\ (b -> t) -> (s -> Either t a) -> r
k -> (b -> t) -> (s -> Either t a) -> r
k b -> t
inj s -> Either t a
prj)