{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE QuantifiedConstraints #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE TypeFamilies #-}
module Data.Profunctor.Optic.Prism (
Prism
, Prism'
, Cxprism
, Cxprism'
, prism
, prism'
, handling
, clonePrism
, just
, nothing
, compared
, prefixed
, only
, nearly
, nthbit
, sync
, async
, exception
, asyncException
, withPrism
, aside
, without
, below
, toPastroSum
, toTambaraSum
, Choice(..)
) 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.Carrier
import Data.Profunctor.Optic.Iso
import Data.Profunctor.Optic.Import
import Data.Profunctor.Optic.Types
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)
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
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)
compared :: 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 = filterOn $ \e -> case fromException (toException e) of
Just (SomeAsyncException _) -> False
Nothing -> True
where filterOn f = iso (branch' f) join . right'
async :: Exception e => Prism' e e
async = filterOn $ \e -> case fromException (toException e) of
Just (SomeAsyncException _) -> True
Nothing -> False
where filterOn f = iso (branch' f) join . right'
exception :: Exception e => Prism' SomeException e
exception = prism' fromException toException
asyncException :: Exception e => Prism' SomeException e
asyncException = prism' asyncExceptionFromException asyncExceptionToException
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)