content: {-# LANGUAGE GADTs #-}
  {-# LANGUAGE PolyKinds #-}
  {-# LANGUAGE RankNTypes #-}
  {-# LANGUAGE TypeOperators #-}
  {-# LANGUAGE ConstraintKinds #-}
  {-# LANGUAGE FlexibleContexts #-}
  {-# LANGUAGE NoImplicitPrelude #-}
  {-# LANGUAGE UndecidableInstances #-}
  {-# OPTIONS_GHC -Wall #-}
  --------------------------------------------------------------------
  -- |
  -- Copyright :  (c) Edward Kmett 2014
  -- License   :  BSD3
  -- Maintainer:  Edward Kmett <ekmett@gmail.com>
  -- Stability :  experimental
  -- Portability: non-portable
  --
  --------------------------------------------------------------------
  module Hask.Prism where
  
  import qualified Control.Arrow as Arrow
  import Hask.Core
  
  class (Precocartesian ((~>) :: i -> i -> *), Profunctor p) => Choice (p :: i -> i -> *) where
    {-# MINIMAL _Left | _Right #-}
    _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
  
  -- In lens terms this is a 'Review'
  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
  