{-# LANGUAGE GADTs #-}
# LANGUAGE PolyKinds #
{-# LANGUAGE RankNTypes #-}
# LANGUAGE TypeOperators #
{-# LANGUAGE ConstraintKinds #-}
# LANGUAGE FlexibleContexts #
# LANGUAGE NoImplicitPrelude #
# LANGUAGE UndecidableInstances #
# OPTIONS_GHC -Wall #
--------------------------------------------------------------------
-- |
  Copyright :   ( c )   2014
-- License   :  BSD3
  Maintainer :     <  >
-- 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

# LANGUAGE GADTs #
# LANGUAGE RankNTypes #
# LANGUAGE ConstraintKinds #
------------------------------------------------------------------
 |
 License   :  BSD3
 Stability :  experimental
 Portability: non-portable

------------------------------------------------------------------
# MINIMAL _Left | _Right #
 In lens terms this is a 'Review'
# LANGUAGE PolyKinds #
# LANGUAGE TypeOperators #
# LANGUAGE FlexibleContexts #
# LANGUAGE NoImplicitPrelude #
# LANGUAGE UndecidableInstances #
# OPTIONS_GHC -Wall #
  Copyright :   ( c )   2014
  Maintainer :     <  >
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
