module Hask.Prism where
import qualified Control.Arrow as Arrow
import Hask.Core
class (Precocartesian ((~>) :: i -> i -> *), Profunctor p) => Choice (p :: i -> i -> *) where
_Left :: p a b -> p (a + c) (b + c)
_Left = dimap swap swap . _Right
_Right :: p a b -> p (c + a) (c + b)
_Right = dimap swap swap . _Left
instance Choice (->) where
_Left = Arrow.left
_Right = Arrow.right
instance Choice (Nat :: (i -> *) -> (i -> *) -> *) where
_Left (Nat f) = Nat $ _Lift (_Left f)
_Right (Nat g) = Nat $ _Lift (_Right g)
instance Choice (Nat :: (i -> j -> *) -> (i -> j -> *) -> *) where
_Left (Nat f) = Nat $ _Lift (_Left f)
_Right (Nat g) = Nat $ _Lift (_Right g)
instance Choice Tagged where
_Left = bimap inl inl
_Right = bimap inr inr
instance Precocartesian ((~>) :: i -> i -> *) => Choice (Beget (r :: i)) where
_Left = bimap inl inl
_Right = bimap inr inr
instance Precocartesian ((~>)::i->i-> *) => Choice (Self :: i -> i -> *) where
_Left = _Self first
_Right = _Self fmap1
type Begetter t b = forall p. (Choice p, Functor p) => p b b -> p t t
unto :: Bifunctor p => (b ~> t) -> p b b -> p t t
unto f = bimap f f
type Prism s t a b = forall p. Choice p => p a b -> p s t