{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE QuantifiedConstraints #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE TypeFamilies #-}
module Data.Profunctor.Optic.Prism (
Prism
, Prism'
, Cxprism
, Cxprism'
, APrism
, APrism'
, prism
, prism'
, cxprism
, handling
, clonePrism
, Coprism
, Coprism'
, Ixprism
, Ixprism'
, ACoprism
, ACoprism'
, coprism
, coprism'
, rehandling
, cloneCoprism
, l1
, r1
, left
, right
, cxright
, just
, nothing
, cxjust
, keyed
, filtered
, compared
, prefixed
, only
, nearly
, nthbit
, sync
, async
, exception
, asyncException
, withPrism
, withCoprism
, aside
, without
, below
, toPastroSum
, toTambaraSum
, PrismRep(..)
, CoprismRep(..)
, Choice(..)
, Cochoice(..)
) where
import Control.Exception
import Control.Monad (guard)
import Data.Bifunctor as B
import Data.Bits (Bits, bit, testBit)
import Data.List (stripPrefix)
import Data.Prd
import Data.Profunctor.Choice
import Data.Profunctor.Optic.Iso
import Data.Profunctor.Optic.Import
import Data.Profunctor.Optic.Type
import GHC.Generics hiding (from, to)
prism :: (s -> t + a) -> (b -> t) -> Prism s t a b
prism sta bt = dimap sta (id ||| bt) . right'
prism' :: (s -> Maybe a) -> (a -> s) -> Prism' s a
prism' sa as = flip prism as $ \s -> maybe (Left s) Right (sa s)
cxprism :: (s -> (k -> t) + a) -> (b -> t) -> Cxprism k s t a b
cxprism skta bt = prism skta (bt .)
handling :: (s -> c + a) -> (c + b -> t) -> Prism s t a b
handling sca cbt = dimap sca cbt . right'
clonePrism :: APrism s t a b -> Prism s t a b
clonePrism o = withPrism o prism
coprism :: (s -> a) -> (b -> a + t) -> Coprism s t a b
coprism sa bat = unright . dimap (id ||| sa) bat
coprism' :: (s -> a) -> (a -> Maybe s) -> Coprism' s a
coprism' tb bt = coprism tb $ \b -> maybe (Left b) Right (bt b)
rehandling :: (c + s -> a) -> (b -> c + t) -> Coprism s t a b
rehandling csa bct = unright . dimap csa bct
cloneCoprism :: ACoprism s t a b -> Coprism s t a b
cloneCoprism o = withCoprism o coprism
l1 :: Prism ((a :+: c) t) ((b :+: c) t) (a t) (b t)
l1 = prism sta L1
where
sta (L1 v) = Right v
sta (R1 v) = Left (R1 v)
{-# INLINE l1 #-}
r1 :: Prism ((c :+: a) t) ((c :+: b) t) (a t) (b t)
r1 = prism sta R1
where
sta (R1 v) = Right v
sta (L1 v) = Left (L1 v)
{-# INLINE r1 #-}
left :: Prism (a + c) (b + c) a b
left = left'
right :: Prism (c + a) (c + b) a b
right = right'
cxright :: (e -> k -> e + b) -> Cxprism k (e + a) (e + b) a b
cxright ekeb = flip cxprism Right $ either (Left . ekeb) Right
just :: Prism (Maybe a) (Maybe b) a b
just = flip prism Just $ maybe (Left Nothing) Right
nothing :: Prism (Maybe a) (Maybe b) () ()
nothing = flip prism (const Nothing) $ maybe (Right ()) (const $ Left Nothing)
cxjust :: (k -> Maybe b) -> Cxprism k (Maybe a) (Maybe b) a b
cxjust kb = flip cxprism Just $ maybe (Left kb) Right
keyed :: Eq a => a -> Prism' (a , b) b
keyed x = flip prism ((,) x) $ \kv@(k,v) -> branch (==x) kv v k
filtered :: (a -> Bool) -> Prism' a a
filtered f = iso (branch' f) join . right
compared :: Eq a => Prd a => a -> Prism' a Ordering
compared x = flip prism' (const x) (pcompare x)
prefixed :: Eq a => [a] -> Prism' [a] [a]
prefixed ps = prism' (stripPrefix ps) (ps ++)
only :: Eq a => a -> Prism' a ()
only x = nearly x (x==)
nearly :: a -> (a -> Bool) -> Prism' a ()
nearly x f = prism' (guard . f) (const x)
nthbit :: Bits s => Int -> Prism' s ()
nthbit n = prism' (guard . (flip testBit n)) (const $ bit n)
sync :: Exception e => Prism' e e
sync = filtered $ \e -> case fromException (toException e) of
Just (SomeAsyncException _) -> False
Nothing -> True
async :: Exception e => Prism' e e
async = filtered $ \e -> case fromException (toException e) of
Just (SomeAsyncException _) -> True
Nothing -> False
exception :: Exception e => Prism' SomeException e
exception = prism' fromException toException
asyncException :: Exception e => Prism' SomeException e
asyncException = prism' asyncExceptionFromException asyncExceptionToException
withPrism :: APrism s t a b -> ((s -> t + a) -> (b -> t) -> r) -> r
withPrism o f = case o (PrismRep Right id) of PrismRep g h -> f g h
withCoprism :: ACoprism s t a b -> ((s -> a) -> (b -> a + t) -> r) -> r
withCoprism o f = case o (CoprismRep id Right) of CoprismRep g h -> f g h
aside :: APrism s t a b -> Prism (e , s) (e , t) (e , a) (e , b)
aside k =
withPrism k $ \sta bt ->
flip prism (fmap bt) $ \(e,s) ->
case sta s of
Left t -> Left (e,t)
Right a -> Right (e,a)
{-# INLINE aside #-}
without :: APrism s t a b -> APrism u v c d -> Prism (s + u) (t + v) (a + c) (b + d)
without k =
withPrism k $ \sta bt k' ->
withPrism k' $ \uevc dv ->
flip prism (bimap bt dv) $ \su ->
case su of
Left s -> bimap Left Left (sta s)
Right u -> bimap Right Right (uevc u)
{-# INLINE without #-}
below :: Traversable f => APrism' s a -> Prism' (f s) (f a)
below k =
withPrism k $ \sta bt ->
flip prism (fmap bt) $ \s ->
case traverse sta s of
Left _ -> Left s
Right t -> Right t
{-# INLINE below #-}
toPastroSum :: APrism s t a b -> p a b -> PastroSum p s t
toPastroSum o p = withPrism o $ \sta bt -> PastroSum (join . B.first bt) p (eswap . sta)
toTambaraSum :: Choice p => APrism s t a b -> p a b -> TambaraSum p s t
toTambaraSum o p = withPrism o $ \sta bt -> TambaraSum (left . prism sta bt $ p)
type APrism s t a b = Optic (PrismRep a b) s t a b
type APrism' s a = APrism s s a a
data PrismRep a b s t = PrismRep (s -> t + a) (b -> t)
instance Functor (PrismRep a b s) where
fmap f (PrismRep sta bt) = PrismRep (first f . sta) (f . bt)
{-# INLINE fmap #-}
instance Profunctor (PrismRep a b) where
dimap f g (PrismRep sta bt) = PrismRep (first g . sta . f) (g . bt)
{-# INLINE dimap #-}
lmap f (PrismRep sta bt) = PrismRep (sta . f) bt
{-# INLINE lmap #-}
rmap = fmap
{-# INLINE rmap #-}
instance Choice (PrismRep a b) where
left' (PrismRep sta bt) = PrismRep (either (first Left . sta) (Left . Right)) (Left . bt)
{-# INLINE left' #-}
right' (PrismRep sta bt) = PrismRep (either (Left . Left) (first Right . sta)) (Right . bt)
{-# INLINE right' #-}
type ACoprism s t a b = Optic (CoprismRep a b) s t a b
type ACoprism' s a = ACoprism s s a a
data CoprismRep a b s t = CoprismRep (s -> a) (b -> a + t)
instance Functor (CoprismRep a b s) where
fmap f (CoprismRep sa bat) = CoprismRep sa (second f . bat)
{-# INLINE fmap #-}
instance Profunctor (CoprismRep a b) where
lmap f (CoprismRep sa bat) = CoprismRep (sa . f) bat
{-# INLINE lmap #-}
rmap = fmap
{-# INLINE rmap #-}
instance Cochoice (CoprismRep a b) where
unleft (CoprismRep sca batc) = CoprismRep (sca . Left) (forgetr $ either (eassocl . batc) Right)
{-# INLINE unleft #-}