{-# LANGUAGE Rank2Types #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE RoleAnnotations #-}

-----------------------------------------------------------------------------
-- |
-- Module      :  Control.Lens.Internal.Context
-- Copyright   :  (C) 2012-2016 Edward Kmett
-- License     :  BSD-style (see the file LICENSE)
-- Maintainer  :  Edward Kmett <ekmett@gmail.com>
-- Stability   :  experimental
-- Portability :  non-portable
--
----------------------------------------------------------------------------
module Control.Lens.Internal.Context
  ( IndexedFunctor(..)
  , IndexedComonad(..)
  , IndexedComonadStore(..)
  , Sellable(..)
  , Context(..), Context'
  , Pretext(..), Pretext'
  , PretextT(..), PretextT'
  ) where

import Prelude ()

import Control.Arrow
import qualified Control.Category as C
import Control.Comonad
import Control.Comonad.Store.Class
import Control.Lens.Internal.Indexed
import Control.Lens.Internal.Prelude
import Data.Kind
import Data.Profunctor.Rep
import Prelude hiding ((.),id)

------------------------------------------------------------------------------
-- IndexedFunctor
------------------------------------------------------------------------------

-- | This is a Bob Atkey -style 2-argument indexed functor.
--
-- It exists as a superclass for 'IndexedComonad' and expresses the functoriality
-- of an 'IndexedComonad' in its third argument.
class IndexedFunctor w where
  ifmap :: (s -> t) -> w a b s -> w a b t

------------------------------------------------------------------------------
-- IndexedComonad
------------------------------------------------------------------------------

-- | This is a Bob Atkey -style 2-argument indexed comonad.
--
-- It exists as a superclass for 'IndexedComonad' and expresses the functoriality
-- of an 'IndexedComonad' in its third argument.
--
-- The notion of indexed monads is covered in more depth in Bob Atkey's
-- "Parameterized Notions of Computation" <http://bentnib.org/paramnotions-jfp.pdf>
-- and that construction is dualized here.
class IndexedFunctor w => IndexedComonad w where
  {-# MINIMAL iextract, (iduplicate | iextend) #-}

  -- | extract from an indexed comonadic value when the indices match.
  iextract :: w a a t -> t

  -- | duplicate an indexed comonadic value splitting the index.
  iduplicate :: w a c t -> w a b (w b c t)
  iduplicate = (w b c t -> w b c t) -> w a c t -> w a b (w b c t)
forall (w :: * -> * -> * -> *) b c t r a.
IndexedComonad w =>
(w b c t -> r) -> w a c t -> w a b r
iextend w b c t -> w b c t
forall a. a -> a
id
  {-# INLINE iduplicate #-}

  -- | extend a indexed comonadic computation splitting the index.
  iextend :: (w b c t -> r) -> w a c t -> w a b r
  iextend w b c t -> r
f = (w b c t -> r) -> w a b (w b c t) -> w a b r
forall (w :: * -> * -> * -> *) s t a b.
IndexedFunctor w =>
(s -> t) -> w a b s -> w a b t
ifmap w b c t -> r
f (w a b (w b c t) -> w a b r)
-> (w a c t -> w a b (w b c t)) -> w a c t -> w a b r
forall b c a. (b -> c) -> (a -> b) -> a -> c
. w a c t -> w a b (w b c t)
forall (w :: * -> * -> * -> *) a c t b.
IndexedComonad w =>
w a c t -> w a b (w b c t)
iduplicate
  {-# INLINE iextend #-}

------------------------------------------------------------------------------
-- IndexedComonadStore
------------------------------------------------------------------------------

-- | This is an indexed analogue to 'ComonadStore' for when you are working with an
-- 'IndexedComonad'.
class IndexedComonad w => IndexedComonadStore w where
  -- | This is the generalization of 'pos' to an indexed comonad store.
  ipos :: w a c t -> a

  -- | This is the generalization of 'peek' to an indexed comonad store.
  ipeek :: c  -> w a c t -> t
  ipeek c
c = w c c t -> t
forall (w :: * -> * -> * -> *) a t.
IndexedComonad w =>
w a a t -> t
iextract (w c c t -> t) -> (w a c t -> w c c t) -> w a c t -> t
forall b c a. (b -> c) -> (a -> b) -> a -> c
. c -> w a c t -> w c c t
forall (w :: * -> * -> * -> *) b a c t.
IndexedComonadStore w =>
b -> w a c t -> w b c t
iseek c
c
  {-# INLINE ipeek #-}

  -- | This is the generalization of 'peeks' to an indexed comonad store.
  ipeeks :: (a -> c) -> w a c t -> t
  ipeeks a -> c
f = w c c t -> t
forall (w :: * -> * -> * -> *) a t.
IndexedComonad w =>
w a a t -> t
iextract (w c c t -> t) -> (w a c t -> w c c t) -> w a c t -> t
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> c) -> w a c t -> w c c t
forall (w :: * -> * -> * -> *) a b c t.
IndexedComonadStore w =>
(a -> b) -> w a c t -> w b c t
iseeks a -> c
f
  {-# INLINE ipeeks #-}

  -- | This is the generalization of 'seek' to an indexed comonad store.
  iseek :: b  -> w a c t -> w b c t

  -- | This is the generalization of 'seeks' to an indexed comonad store.
  iseeks :: (a -> b) -> w a c t -> w b c t

  -- | This is the generalization of 'experiment' to an indexed comonad store.
  iexperiment :: Functor f => (b -> f c) -> w b c t -> f t
  iexperiment b -> f c
bfc w b c t
wbct = (c -> w b c t -> t
forall (w :: * -> * -> * -> *) c a t.
IndexedComonadStore w =>
c -> w a c t -> t
`ipeek` w b c t
wbct) (c -> t) -> f c -> f t
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> b -> f c
bfc (w b c t -> b
forall (w :: * -> * -> * -> *) a c t.
IndexedComonadStore w =>
w a c t -> a
ipos w b c t
wbct)
  {-# INLINE iexperiment #-}

  -- | We can always forget the rest of the structure of 'w' and obtain a simpler
  -- indexed comonad store model called 'Context'.
  context :: w a b t -> Context a b t
  context w a b t
wabt = (b -> t) -> a -> Context a b t
forall a b t. (b -> t) -> a -> Context a b t
Context (b -> w a b t -> t
forall (w :: * -> * -> * -> *) c a t.
IndexedComonadStore w =>
c -> w a c t -> t
`ipeek` w a b t
wabt) (w a b t -> a
forall (w :: * -> * -> * -> *) a c t.
IndexedComonadStore w =>
w a c t -> a
ipos w a b t
wabt)
  {-# INLINE context #-}

------------------------------------------------------------------------------
-- Sellable
------------------------------------------------------------------------------

-- | This is used internally to construct a 'Control.Lens.Internal.Bazaar.Bazaar', 'Context' or 'Pretext'
-- from a singleton value.
class Corepresentable p => Sellable p w | w -> p where
  sell :: p a (w a b b)

------------------------------------------------------------------------------
-- Context
------------------------------------------------------------------------------

-- | The indexed store can be used to characterize a 'Control.Lens.Lens.Lens'
-- and is used by 'Control.Lens.Lens.cloneLens'.
--
-- @'Context' a b t@ is isomorphic to
-- @newtype 'Context' a b t = 'Context' { runContext :: forall f. 'Functor' f => (a -> f b) -> f t }@,
-- and to @exists s. (s, 'Control.Lens.Lens.Lens' s t a b)@.
--
-- A 'Context' is like a 'Control.Lens.Lens.Lens' that has already been applied to a some structure.
data Context a b t = Context (b -> t) a
-- type role Context representational representational representational

instance IndexedFunctor Context where
  ifmap :: (s -> t) -> Context a b s -> Context a b t
ifmap s -> t
f (Context b -> s
g a
t) = (b -> t) -> a -> Context a b t
forall a b t. (b -> t) -> a -> Context a b t
Context (s -> t
f (s -> t) -> (b -> s) -> b -> t
forall b c a. (b -> c) -> (a -> b) -> a -> c
. b -> s
g) a
t
  {-# INLINE ifmap #-}

instance IndexedComonad Context where
  iextract :: Context a a t -> t
iextract   (Context a -> t
f a
a) = a -> t
f a
a
  {-# INLINE iextract #-}
  iduplicate :: Context a c t -> Context a b (Context b c t)
iduplicate (Context c -> t
f a
a) = (b -> Context b c t) -> a -> Context a b (Context b c t)
forall a b t. (b -> t) -> a -> Context a b t
Context ((c -> t) -> b -> Context b c t
forall a b t. (b -> t) -> a -> Context a b t
Context c -> t
f) a
a
  {-# INLINE iduplicate #-}
  iextend :: (Context b c t -> r) -> Context a c t -> Context a b r
iextend Context b c t -> r
g  (Context c -> t
f a
a) = (b -> r) -> a -> Context a b r
forall a b t. (b -> t) -> a -> Context a b t
Context (Context b c t -> r
g (Context b c t -> r) -> (b -> Context b c t) -> b -> r
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (c -> t) -> b -> Context b c t
forall a b t. (b -> t) -> a -> Context a b t
Context c -> t
f) a
a
  {-# INLINE iextend #-}

instance IndexedComonadStore Context where
  ipos :: Context a c t -> a
ipos (Context c -> t
_ a
a) = a
a
  {-# INLINE ipos #-}
  ipeek :: c -> Context a c t -> t
ipeek c
b (Context c -> t
g a
_) = c -> t
g c
b
  {-# INLINE ipeek #-}
  ipeeks :: (a -> c) -> Context a c t -> t
ipeeks a -> c
f (Context c -> t
g a
a) = c -> t
g (a -> c
f a
a)
  {-# INLINE ipeeks #-}
  iseek :: b -> Context a c t -> Context b c t
iseek b
a (Context c -> t
g a
_) = (c -> t) -> b -> Context b c t
forall a b t. (b -> t) -> a -> Context a b t
Context c -> t
g b
a
  {-# INLINE iseek #-}
  iseeks :: (a -> b) -> Context a c t -> Context b c t
iseeks a -> b
f (Context c -> t
g a
a) = (c -> t) -> b -> Context b c t
forall a b t. (b -> t) -> a -> Context a b t
Context c -> t
g (a -> b
f a
a)
  {-# INLINE iseeks #-}
  iexperiment :: (b -> f c) -> Context b c t -> f t
iexperiment b -> f c
f (Context c -> t
g b
a) = c -> t
g (c -> t) -> f c -> f t
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> b -> f c
f b
a
  {-# INLINE iexperiment #-}
  context :: Context a b t -> Context a b t
context = Context a b t -> Context a b t
forall a. a -> a
id
  {-# INLINE context #-}

instance Functor (Context a b) where
  fmap :: (a -> b) -> Context a b a -> Context a b b
fmap a -> b
f (Context b -> a
g a
t) = (b -> b) -> a -> Context a b b
forall a b t. (b -> t) -> a -> Context a b t
Context (a -> b
f (a -> b) -> (b -> a) -> b -> b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. b -> a
g) a
t
  {-# INLINE fmap #-}

instance a ~ b => Comonad (Context a b) where
  extract :: Context a b a -> a
extract   (Context b -> a
f a
a) = b -> a
f a
b
a
  {-# INLINE extract #-}
  duplicate :: Context a b a -> Context a b (Context a b a)
duplicate (Context b -> a
f a
a) = (b -> Context b b a) -> a -> Context a b (Context b b a)
forall a b t. (b -> t) -> a -> Context a b t
Context ((b -> a) -> b -> Context b b a
forall a b t. (b -> t) -> a -> Context a b t
Context b -> a
f) a
a
  {-# INLINE duplicate #-}
  extend :: (Context a b a -> b) -> Context a b a -> Context a b b
extend Context a b a -> b
g  (Context b -> a
f a
a) = (a -> b) -> a -> Context a a b
forall a b t. (b -> t) -> a -> Context a b t
Context (Context a b a -> b
g (Context a b a -> b) -> (a -> Context a b a) -> a -> b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (b -> a) -> a -> Context a b a
forall a b t. (b -> t) -> a -> Context a b t
Context b -> a
f) a
a
  {-# INLINE extend #-}

instance a ~ b => ComonadStore a (Context a b) where
  pos :: Context a b a -> a
pos = Context a b a -> a
forall (w :: * -> * -> * -> *) a c t.
IndexedComonadStore w =>
w a c t -> a
ipos
  {-# INLINE pos #-}
  peek :: a -> Context a b a -> a
peek = a -> Context a b a -> a
forall (w :: * -> * -> * -> *) c a t.
IndexedComonadStore w =>
c -> w a c t -> t
ipeek
  {-# INLINE peek #-}
  peeks :: (a -> a) -> Context a b a -> a
peeks = (a -> a) -> Context a b a -> a
forall (w :: * -> * -> * -> *) a c t.
IndexedComonadStore w =>
(a -> c) -> w a c t -> t
ipeeks
  {-# INLINE peeks #-}
  seek :: a -> Context a b a -> Context a b a
seek = a -> Context a b a -> Context a b a
forall (w :: * -> * -> * -> *) b a c t.
IndexedComonadStore w =>
b -> w a c t -> w b c t
iseek
  {-# INLINE seek #-}
  seeks :: (a -> a) -> Context a b a -> Context a b a
seeks = (a -> a) -> Context a b a -> Context a b a
forall (w :: * -> * -> * -> *) a b c t.
IndexedComonadStore w =>
(a -> b) -> w a c t -> w b c t
iseeks
  {-# INLINE seeks #-}
  experiment :: (a -> f a) -> Context a b a -> f a
experiment = (a -> f a) -> Context a b a -> f a
forall (w :: * -> * -> * -> *) (f :: * -> *) b c t.
(IndexedComonadStore w, Functor f) =>
(b -> f c) -> w b c t -> f t
iexperiment
  {-# INLINE experiment #-}

instance Sellable (->) Context where
  sell :: a -> Context a b b
sell = (b -> b) -> a -> Context a b b
forall a b t. (b -> t) -> a -> Context a b t
Context b -> b
forall a. a -> a
id
  {-# INLINE sell #-}

-- | @type 'Context'' a s = 'Context' a a s@
type Context' a = Context a a

------------------------------------------------------------------------------
-- Pretext
------------------------------------------------------------------------------

-- | This is a generalized form of 'Context' that can be repeatedly cloned with less
-- impact on its performance, and which permits the use of an arbitrary 'Conjoined'
-- 'Profunctor'
newtype Pretext p a b t = Pretext { Pretext p a b t
-> forall (f :: * -> *). Functor f => p a (f b) -> f t
runPretext :: forall f. Functor f => p a (f b) -> f t }
-- type role Pretext representational nominal nominal nominal

-- | @type 'Pretext'' p a s = 'Pretext' p a a s@
type Pretext' p a = Pretext p a a

instance IndexedFunctor (Pretext p) where
  ifmap :: (s -> t) -> Pretext p a b s -> Pretext p a b t
ifmap s -> t
f (Pretext forall (f :: * -> *). Functor f => p a (f b) -> f s
k) = (forall (f :: * -> *). Functor f => p a (f b) -> f t)
-> Pretext p a b t
forall (p :: * -> * -> *) a b t.
(forall (f :: * -> *). Functor f => p a (f b) -> f t)
-> Pretext p a b t
Pretext ((s -> t) -> f s -> f t
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap s -> t
f (f s -> f t) -> (p a (f b) -> f s) -> p a (f b) -> f t
forall b c a. (b -> c) -> (a -> b) -> a -> c
. p a (f b) -> f s
forall (f :: * -> *). Functor f => p a (f b) -> f s
k)
  {-# INLINE ifmap #-}

instance Functor (Pretext p a b) where
  fmap :: (a -> b) -> Pretext p a b a -> Pretext p a b b
fmap = (a -> b) -> Pretext p a b a -> Pretext p a b b
forall (w :: * -> * -> * -> *) s t a b.
IndexedFunctor w =>
(s -> t) -> w a b s -> w a b t
ifmap
  {-# INLINE fmap #-}

instance Conjoined p => IndexedComonad (Pretext p) where
  iextract :: Pretext p a a t -> t
iextract (Pretext forall (f :: * -> *). Functor f => p a (f a) -> f t
m) = Identity t -> t
forall a. Identity a -> a
runIdentity (Identity t -> t) -> Identity t -> t
forall a b. (a -> b) -> a -> b
$ p a (Identity a) -> Identity t
forall (f :: * -> *). Functor f => p a (f a) -> f t
m ((a -> Identity a) -> p a (Identity a)
forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr a -> Identity a
forall a. a -> Identity a
Identity)
  {-# INLINE iextract #-}
  iduplicate :: Pretext p a c t -> Pretext p a b (Pretext p b c t)
iduplicate (Pretext forall (f :: * -> *). Functor f => p a (f c) -> f t
m) = Compose (Pretext p a b) (Pretext p b c) t
-> Pretext p a b (Pretext p b c t)
forall k1 (f :: k1 -> *) k2 (g :: k2 -> k1) (a :: k2).
Compose f g a -> f (g a)
getCompose (Compose (Pretext p a b) (Pretext p b c) t
 -> Pretext p a b (Pretext p b c t))
-> Compose (Pretext p a b) (Pretext p b c) t
-> Pretext p a b (Pretext p b c t)
forall a b. (a -> b) -> a -> b
$ p a (Compose (Pretext p a b) (Pretext p b c) c)
-> Compose (Pretext p a b) (Pretext p b c) t
forall (f :: * -> *). Functor f => p a (f c) -> f t
m (Pretext p a b (Pretext p b c c)
-> Compose (Pretext p a b) (Pretext p b c) c
forall k k1 (f :: k -> *) (g :: k1 -> k) (a :: k1).
f (g a) -> Compose f g a
Compose (Pretext p a b (Pretext p b c c)
 -> Compose (Pretext p a b) (Pretext p b c) c)
-> p a (Pretext p a b (Pretext p b c c))
-> p a (Compose (Pretext p a b) (Pretext p b c) c)
forall (p :: * -> * -> *) a b c (q :: * -> * -> *).
(Profunctor p, Coercible c b) =>
q b c -> p a b -> p a c
#. p b (Pretext p b c c)
-> p (Pretext p a b b) (Pretext p a b (Pretext p b c c))
forall (p :: * -> * -> *) (f :: * -> *) a b.
(Conjoined p, Functor f) =>
p a b -> p (f a) (f b)
distrib p b (Pretext p b c c)
forall (p :: * -> * -> *) (w :: * -> * -> * -> *) a b.
Sellable p w =>
p a (w a b b)
sell p (Pretext p a b b) (Pretext p a b (Pretext p b c c))
-> p a (Pretext p a b b) -> p a (Pretext p a b (Pretext p b c c))
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
C.. p a (Pretext p a b b)
forall (p :: * -> * -> *) (w :: * -> * -> * -> *) a b.
Sellable p w =>
p a (w a b b)
sell)
  {-# INLINE iduplicate #-}

instance (a ~ b, Conjoined p) => Comonad (Pretext p a b) where
  extract :: Pretext p a b a -> a
extract = Pretext p a b a -> a
forall (w :: * -> * -> * -> *) a t.
IndexedComonad w =>
w a a t -> t
iextract
  {-# INLINE extract #-}
  duplicate :: Pretext p a b a -> Pretext p a b (Pretext p a b a)
duplicate = Pretext p a b a -> Pretext p a b (Pretext p a b a)
forall (w :: * -> * -> * -> *) a c t b.
IndexedComonad w =>
w a c t -> w a b (w b c t)
iduplicate
  {-# INLINE duplicate #-}

instance Conjoined p => IndexedComonadStore (Pretext p) where
  ipos :: Pretext p a c t -> a
ipos (Pretext forall (f :: * -> *). Functor f => p a (f c) -> f t
m) = Const a t -> a
forall a k (b :: k). Const a b -> a
getConst (Const a t -> a) -> Const a t -> a
forall a b. (a -> b) -> a -> b
$ (p a (Const a c) -> Const a t) -> p a (Const a c) -> Const a t
forall (q :: * -> * -> *) a b.
(Representable q, Comonad (Rep q)) =>
q a b -> a -> b
coarr p a (Const a c) -> Const a t
forall (f :: * -> *). Functor f => p a (f c) -> f t
m (p a (Const a c) -> Const a t) -> p a (Const a c) -> Const a t
forall a b. (a -> b) -> a -> b
$ (a -> Const a c) -> p a (Const a c)
forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr a -> Const a c
forall k a (b :: k). a -> Const a b
Const
  {-# INLINE ipos #-}
  ipeek :: c -> Pretext p a c t -> t
ipeek c
a (Pretext forall (f :: * -> *). Functor f => p a (f c) -> f t
m) = Identity t -> t
forall a. Identity a -> a
runIdentity (Identity t -> t) -> Identity t -> t
forall a b. (a -> b) -> a -> b
$ (p a (Identity c) -> Identity t) -> p a (Identity c) -> Identity t
forall (q :: * -> * -> *) a b.
(Representable q, Comonad (Rep q)) =>
q a b -> a -> b
coarr p a (Identity c) -> Identity t
forall (f :: * -> *). Functor f => p a (f c) -> f t
m (p a (Identity c) -> Identity t) -> p a (Identity c) -> Identity t
forall a b. (a -> b) -> a -> b
$ (a -> Identity c) -> p a (Identity c)
forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr (\a
_ -> c -> Identity c
forall a. a -> Identity a
Identity c
a)
  {-# INLINE ipeek #-}
  ipeeks :: (a -> c) -> Pretext p a c t -> t
ipeeks a -> c
f (Pretext forall (f :: * -> *). Functor f => p a (f c) -> f t
m) = Identity t -> t
forall a. Identity a -> a
runIdentity (Identity t -> t) -> Identity t -> t
forall a b. (a -> b) -> a -> b
$ (p a (Identity c) -> Identity t) -> p a (Identity c) -> Identity t
forall (q :: * -> * -> *) a b.
(Representable q, Comonad (Rep q)) =>
q a b -> a -> b
coarr p a (Identity c) -> Identity t
forall (f :: * -> *). Functor f => p a (f c) -> f t
m (p a (Identity c) -> Identity t) -> p a (Identity c) -> Identity t
forall a b. (a -> b) -> a -> b
$ (a -> Identity c) -> p a (Identity c)
forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr (c -> Identity c
forall a. a -> Identity a
Identity (c -> Identity c) -> (a -> c) -> a -> Identity c
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> c
f)
  {-# INLINE ipeeks #-}
  iseek :: b -> Pretext p a c t -> Pretext p b c t
iseek b
a (Pretext forall (f :: * -> *). Functor f => p a (f c) -> f t
m) = (forall (f :: * -> *). Functor f => p b (f c) -> f t)
-> Pretext p b c t
forall (p :: * -> * -> *) a b t.
(forall (f :: * -> *). Functor f => p a (f b) -> f t)
-> Pretext p a b t
Pretext ((p b (f c) -> p a (f c)) -> (p a (f c) -> f t) -> p b (f c) -> f t
forall (p :: * -> * -> *) a b c.
Profunctor p =>
(a -> b) -> p b c -> p a c
lmap ((a -> b) -> p b (f c) -> p a (f c)
forall (p :: * -> * -> *) a b c.
Profunctor p =>
(a -> b) -> p b c -> p a c
lmap (b -> a -> b
forall a b. a -> b -> a
const b
a)) p a (f c) -> f t
forall (f :: * -> *). Functor f => p a (f c) -> f t
m)
  {-# INLINE iseek #-}
  iseeks :: (a -> b) -> Pretext p a c t -> Pretext p b c t
iseeks a -> b
f (Pretext forall (f :: * -> *). Functor f => p a (f c) -> f t
m) = (forall (f :: * -> *). Functor f => p b (f c) -> f t)
-> Pretext p b c t
forall (p :: * -> * -> *) a b t.
(forall (f :: * -> *). Functor f => p a (f b) -> f t)
-> Pretext p a b t
Pretext ((p b (f c) -> p a (f c)) -> (p a (f c) -> f t) -> p b (f c) -> f t
forall (p :: * -> * -> *) a b c.
Profunctor p =>
(a -> b) -> p b c -> p a c
lmap ((a -> b) -> p b (f c) -> p a (f c)
forall (p :: * -> * -> *) a b c.
Profunctor p =>
(a -> b) -> p b c -> p a c
lmap a -> b
f) p a (f c) -> f t
forall (f :: * -> *). Functor f => p a (f c) -> f t
m)
  {-# INLINE iseeks #-}
  iexperiment :: (b -> f c) -> Pretext p b c t -> f t
iexperiment b -> f c
f (Pretext forall (f :: * -> *). Functor f => p b (f c) -> f t
m) = (p b (f c) -> f t) -> p b (f c) -> f t
forall (q :: * -> * -> *) a b.
(Representable q, Comonad (Rep q)) =>
q a b -> a -> b
coarr p b (f c) -> f t
forall (f :: * -> *). Functor f => p b (f c) -> f t
m ((b -> f c) -> p b (f c)
forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr b -> f c
f)
  {-# INLINE iexperiment #-}
  context :: Pretext p a b t -> Context a b t
context (Pretext forall (f :: * -> *). Functor f => p a (f b) -> f t
m) = (p a (Context a b b) -> Context a b t)
-> p a (Context a b b) -> Context a b t
forall (q :: * -> * -> *) a b.
(Representable q, Comonad (Rep q)) =>
q a b -> a -> b
coarr p a (Context a b b) -> Context a b t
forall (f :: * -> *). Functor f => p a (f b) -> f t
m ((a -> Context a b b) -> p a (Context a b b)
forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr a -> Context a b b
forall (p :: * -> * -> *) (w :: * -> * -> * -> *) a b.
Sellable p w =>
p a (w a b b)
sell)
  {-# INLINE context #-}

instance (a ~ b, Conjoined p) => ComonadStore a (Pretext p a b) where
  pos :: Pretext p a b a -> a
pos = Pretext p a b a -> a
forall (w :: * -> * -> * -> *) a c t.
IndexedComonadStore w =>
w a c t -> a
ipos
  {-# INLINE pos #-}
  peek :: a -> Pretext p a b a -> a
peek = a -> Pretext p a b a -> a
forall (w :: * -> * -> * -> *) c a t.
IndexedComonadStore w =>
c -> w a c t -> t
ipeek
  {-# INLINE peek #-}
  peeks :: (a -> a) -> Pretext p a b a -> a
peeks = (a -> a) -> Pretext p a b a -> a
forall (w :: * -> * -> * -> *) a c t.
IndexedComonadStore w =>
(a -> c) -> w a c t -> t
ipeeks
  {-# INLINE peeks #-}
  seek :: a -> Pretext p a b a -> Pretext p a b a
seek = a -> Pretext p a b a -> Pretext p a b a
forall (w :: * -> * -> * -> *) b a c t.
IndexedComonadStore w =>
b -> w a c t -> w b c t
iseek
  {-# INLINE seek #-}
  seeks :: (a -> a) -> Pretext p a b a -> Pretext p a b a
seeks = (a -> a) -> Pretext p a b a -> Pretext p a b a
forall (w :: * -> * -> * -> *) a b c t.
IndexedComonadStore w =>
(a -> b) -> w a c t -> w b c t
iseeks
  {-# INLINE seeks #-}
  experiment :: (a -> f a) -> Pretext p a b a -> f a
experiment = (a -> f a) -> Pretext p a b a -> f a
forall (w :: * -> * -> * -> *) (f :: * -> *) b c t.
(IndexedComonadStore w, Functor f) =>
(b -> f c) -> w b c t -> f t
iexperiment
  {-# INLINE experiment #-}

instance Corepresentable p => Sellable p (Pretext p) where
  sell :: p a (Pretext p a b b)
sell = (Corep p a -> Pretext p a b b) -> p a (Pretext p a b b)
forall (p :: * -> * -> *) d c.
Corepresentable p =>
(Corep p d -> c) -> p d c
cotabulate ((Corep p a -> Pretext p a b b) -> p a (Pretext p a b b))
-> (Corep p a -> Pretext p a b b) -> p a (Pretext p a b b)
forall a b. (a -> b) -> a -> b
$ \ Corep p a
w -> (forall (f :: * -> *). Functor f => p a (f b) -> f b)
-> Pretext p a b b
forall (p :: * -> * -> *) a b t.
(forall (f :: * -> *). Functor f => p a (f b) -> f t)
-> Pretext p a b t
Pretext (p a (f b) -> Corep p a -> f b
forall (p :: * -> * -> *) (f :: * -> *) a b.
Cosieve p f =>
p a b -> f a -> b
`cosieve` Corep p a
w)
  {-# INLINE sell #-}

------------------------------------------------------------------------------
-- PretextT
------------------------------------------------------------------------------



-- | This is a generalized form of 'Context' that can be repeatedly cloned with less
-- impact on its performance, and which permits the use of an arbitrary 'Conjoined'
-- 'Profunctor'.
--
-- The extra phantom 'Functor' is used to let us lie and claim
-- 'Control.Lens.Getter.Getter'-compatibility under limited circumstances.
-- This is used internally to permit a number of combinators to gracefully
-- degrade when applied to a 'Control.Lens.Fold.Fold' or
-- 'Control.Lens.Getter.Getter'.
newtype PretextT p (g :: Type -> Type) a b t = PretextT { PretextT p g a b t
-> forall (f :: * -> *). Functor f => p a (f b) -> f t
runPretextT :: forall f. Functor f => p a (f b) -> f t }

-- really we want PretextT p g a b t to permit the last 3 arguments to be representational iff p and f accept representational arguments
-- but that isn't currently an option in GHC
type role PretextT representational nominal nominal nominal nominal

-- | @type 'PretextT'' p g a s = 'PretextT' p g a a s@
type PretextT' p g a = PretextT p g a a

instance IndexedFunctor (PretextT p g) where
  ifmap :: (s -> t) -> PretextT p g a b s -> PretextT p g a b t
ifmap s -> t
f (PretextT forall (f :: * -> *). Functor f => p a (f b) -> f s
k) = (forall (f :: * -> *). Functor f => p a (f b) -> f t)
-> PretextT p g a b t
forall (p :: * -> * -> *) (g :: * -> *) a b t.
(forall (f :: * -> *). Functor f => p a (f b) -> f t)
-> PretextT p g a b t
PretextT ((s -> t) -> f s -> f t
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap s -> t
f (f s -> f t) -> (p a (f b) -> f s) -> p a (f b) -> f t
forall b c a. (b -> c) -> (a -> b) -> a -> c
. p a (f b) -> f s
forall (f :: * -> *). Functor f => p a (f b) -> f s
k)
  {-# INLINE ifmap #-}

instance Functor (PretextT p g a b) where
  fmap :: (a -> b) -> PretextT p g a b a -> PretextT p g a b b
fmap = (a -> b) -> PretextT p g a b a -> PretextT p g a b b
forall (w :: * -> * -> * -> *) s t a b.
IndexedFunctor w =>
(s -> t) -> w a b s -> w a b t
ifmap
  {-# INLINE fmap #-}

instance Conjoined p => IndexedComonad (PretextT p g) where
  iextract :: PretextT p g a a t -> t
iextract (PretextT forall (f :: * -> *). Functor f => p a (f a) -> f t
m) = Identity t -> t
forall a. Identity a -> a
runIdentity (Identity t -> t) -> Identity t -> t
forall a b. (a -> b) -> a -> b
$ p a (Identity a) -> Identity t
forall (f :: * -> *). Functor f => p a (f a) -> f t
m ((a -> Identity a) -> p a (Identity a)
forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr a -> Identity a
forall a. a -> Identity a
Identity)
  {-# INLINE iextract #-}
  iduplicate :: PretextT p g a c t -> PretextT p g a b (PretextT p g b c t)
iduplicate (PretextT forall (f :: * -> *). Functor f => p a (f c) -> f t
m) = Compose (PretextT p g a b) (PretextT p g b c) t
-> PretextT p g a b (PretextT p g b c t)
forall k1 (f :: k1 -> *) k2 (g :: k2 -> k1) (a :: k2).
Compose f g a -> f (g a)
getCompose (Compose (PretextT p g a b) (PretextT p g b c) t
 -> PretextT p g a b (PretextT p g b c t))
-> Compose (PretextT p g a b) (PretextT p g b c) t
-> PretextT p g a b (PretextT p g b c t)
forall a b. (a -> b) -> a -> b
$ p a (Compose (PretextT p g a b) (PretextT p g b c) c)
-> Compose (PretextT p g a b) (PretextT p g b c) t
forall (f :: * -> *). Functor f => p a (f c) -> f t
m (PretextT p g a b (PretextT p g b c c)
-> Compose (PretextT p g a b) (PretextT p g b c) c
forall k k1 (f :: k -> *) (g :: k1 -> k) (a :: k1).
f (g a) -> Compose f g a
Compose (PretextT p g a b (PretextT p g b c c)
 -> Compose (PretextT p g a b) (PretextT p g b c) c)
-> p a (PretextT p g a b (PretextT p g b c c))
-> p a (Compose (PretextT p g a b) (PretextT p g b c) c)
forall (p :: * -> * -> *) a b c (q :: * -> * -> *).
(Profunctor p, Coercible c b) =>
q b c -> p a b -> p a c
#. p b (PretextT p g b c c)
-> p (PretextT p g a b b) (PretextT p g a b (PretextT p g b c c))
forall (p :: * -> * -> *) (f :: * -> *) a b.
(Conjoined p, Functor f) =>
p a b -> p (f a) (f b)
distrib p b (PretextT p g b c c)
forall (p :: * -> * -> *) (w :: * -> * -> * -> *) a b.
Sellable p w =>
p a (w a b b)
sell p (PretextT p g a b b) (PretextT p g a b (PretextT p g b c c))
-> p a (PretextT p g a b b)
-> p a (PretextT p g a b (PretextT p g b c c))
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
C.. p a (PretextT p g a b b)
forall (p :: * -> * -> *) (w :: * -> * -> * -> *) a b.
Sellable p w =>
p a (w a b b)
sell)
  {-# INLINE iduplicate #-}

instance (a ~ b, Conjoined p) => Comonad (PretextT p g a b) where
  extract :: PretextT p g a b a -> a
extract = PretextT p g a b a -> a
forall (w :: * -> * -> * -> *) a t.
IndexedComonad w =>
w a a t -> t
iextract
  {-# INLINE extract #-}
  duplicate :: PretextT p g a b a -> PretextT p g a b (PretextT p g a b a)
duplicate = PretextT p g a b a -> PretextT p g a b (PretextT p g a b a)
forall (w :: * -> * -> * -> *) a c t b.
IndexedComonad w =>
w a c t -> w a b (w b c t)
iduplicate
  {-# INLINE duplicate #-}

instance Conjoined p => IndexedComonadStore (PretextT p g) where
  ipos :: PretextT p g a c t -> a
ipos (PretextT forall (f :: * -> *). Functor f => p a (f c) -> f t
m) = Const a t -> a
forall a k (b :: k). Const a b -> a
getConst (Const a t -> a) -> Const a t -> a
forall a b. (a -> b) -> a -> b
$ (p a (Const a c) -> Const a t) -> p a (Const a c) -> Const a t
forall (q :: * -> * -> *) a b.
(Representable q, Comonad (Rep q)) =>
q a b -> a -> b
coarr p a (Const a c) -> Const a t
forall (f :: * -> *). Functor f => p a (f c) -> f t
m (p a (Const a c) -> Const a t) -> p a (Const a c) -> Const a t
forall a b. (a -> b) -> a -> b
$ (a -> Const a c) -> p a (Const a c)
forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr a -> Const a c
forall k a (b :: k). a -> Const a b
Const
  {-# INLINE ipos #-}
  ipeek :: c -> PretextT p g a c t -> t
ipeek c
a (PretextT forall (f :: * -> *). Functor f => p a (f c) -> f t
m) = Identity t -> t
forall a. Identity a -> a
runIdentity (Identity t -> t) -> Identity t -> t
forall a b. (a -> b) -> a -> b
$ (p a (Identity c) -> Identity t) -> p a (Identity c) -> Identity t
forall (q :: * -> * -> *) a b.
(Representable q, Comonad (Rep q)) =>
q a b -> a -> b
coarr p a (Identity c) -> Identity t
forall (f :: * -> *). Functor f => p a (f c) -> f t
m (p a (Identity c) -> Identity t) -> p a (Identity c) -> Identity t
forall a b. (a -> b) -> a -> b
$ (a -> Identity c) -> p a (Identity c)
forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr (\a
_ -> c -> Identity c
forall a. a -> Identity a
Identity c
a)
  {-# INLINE ipeek #-}
  ipeeks :: (a -> c) -> PretextT p g a c t -> t
ipeeks a -> c
f (PretextT forall (f :: * -> *). Functor f => p a (f c) -> f t
m) = Identity t -> t
forall a. Identity a -> a
runIdentity (Identity t -> t) -> Identity t -> t
forall a b. (a -> b) -> a -> b
$ (p a (Identity c) -> Identity t) -> p a (Identity c) -> Identity t
forall (q :: * -> * -> *) a b.
(Representable q, Comonad (Rep q)) =>
q a b -> a -> b
coarr p a (Identity c) -> Identity t
forall (f :: * -> *). Functor f => p a (f c) -> f t
m (p a (Identity c) -> Identity t) -> p a (Identity c) -> Identity t
forall a b. (a -> b) -> a -> b
$ (a -> Identity c) -> p a (Identity c)
forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr (c -> Identity c
forall a. a -> Identity a
Identity (c -> Identity c) -> (a -> c) -> a -> Identity c
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> c
f)
  {-# INLINE ipeeks #-}
  iseek :: b -> PretextT p g a c t -> PretextT p g b c t
iseek b
a (PretextT forall (f :: * -> *). Functor f => p a (f c) -> f t
m) = (forall (f :: * -> *). Functor f => p b (f c) -> f t)
-> PretextT p g b c t
forall (p :: * -> * -> *) (g :: * -> *) a b t.
(forall (f :: * -> *). Functor f => p a (f b) -> f t)
-> PretextT p g a b t
PretextT ((p b (f c) -> p a (f c)) -> (p a (f c) -> f t) -> p b (f c) -> f t
forall (p :: * -> * -> *) a b c.
Profunctor p =>
(a -> b) -> p b c -> p a c
lmap ((a -> b) -> p b (f c) -> p a (f c)
forall (p :: * -> * -> *) a b c.
Profunctor p =>
(a -> b) -> p b c -> p a c
lmap (b -> a -> b
forall a b. a -> b -> a
const b
a)) p a (f c) -> f t
forall (f :: * -> *). Functor f => p a (f c) -> f t
m)
  {-# INLINE iseek #-}
  iseeks :: (a -> b) -> PretextT p g a c t -> PretextT p g b c t
iseeks a -> b
f (PretextT forall (f :: * -> *). Functor f => p a (f c) -> f t
m) = (forall (f :: * -> *). Functor f => p b (f c) -> f t)
-> PretextT p g b c t
forall (p :: * -> * -> *) (g :: * -> *) a b t.
(forall (f :: * -> *). Functor f => p a (f b) -> f t)
-> PretextT p g a b t
PretextT ((p b (f c) -> p a (f c)) -> (p a (f c) -> f t) -> p b (f c) -> f t
forall (p :: * -> * -> *) a b c.
Profunctor p =>
(a -> b) -> p b c -> p a c
lmap ((a -> b) -> p b (f c) -> p a (f c)
forall (p :: * -> * -> *) a b c.
Profunctor p =>
(a -> b) -> p b c -> p a c
lmap a -> b
f) p a (f c) -> f t
forall (f :: * -> *). Functor f => p a (f c) -> f t
m)
  {-# INLINE iseeks #-}
  iexperiment :: (b -> f c) -> PretextT p g b c t -> f t
iexperiment b -> f c
f (PretextT forall (f :: * -> *). Functor f => p b (f c) -> f t
m) = (p b (f c) -> f t) -> p b (f c) -> f t
forall (q :: * -> * -> *) a b.
(Representable q, Comonad (Rep q)) =>
q a b -> a -> b
coarr p b (f c) -> f t
forall (f :: * -> *). Functor f => p b (f c) -> f t
m ((b -> f c) -> p b (f c)
forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr b -> f c
f)
  {-# INLINE iexperiment #-}
  context :: PretextT p g a b t -> Context a b t
context (PretextT forall (f :: * -> *). Functor f => p a (f b) -> f t
m) = (p a (Context a b b) -> Context a b t)
-> p a (Context a b b) -> Context a b t
forall (q :: * -> * -> *) a b.
(Representable q, Comonad (Rep q)) =>
q a b -> a -> b
coarr p a (Context a b b) -> Context a b t
forall (f :: * -> *). Functor f => p a (f b) -> f t
m ((a -> Context a b b) -> p a (Context a b b)
forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr a -> Context a b b
forall (p :: * -> * -> *) (w :: * -> * -> * -> *) a b.
Sellable p w =>
p a (w a b b)
sell)
  {-# INLINE context #-}

instance (a ~ b, Conjoined p) => ComonadStore a (PretextT p g a b) where
  pos :: PretextT p g a b a -> a
pos = PretextT p g a b a -> a
forall (w :: * -> * -> * -> *) a c t.
IndexedComonadStore w =>
w a c t -> a
ipos
  {-# INLINE pos #-}
  peek :: a -> PretextT p g a b a -> a
peek = a -> PretextT p g a b a -> a
forall (w :: * -> * -> * -> *) c a t.
IndexedComonadStore w =>
c -> w a c t -> t
ipeek
  {-# INLINE peek #-}
  peeks :: (a -> a) -> PretextT p g a b a -> a
peeks = (a -> a) -> PretextT p g a b a -> a
forall (w :: * -> * -> * -> *) a c t.
IndexedComonadStore w =>
(a -> c) -> w a c t -> t
ipeeks
  {-# INLINE peeks #-}
  seek :: a -> PretextT p g a b a -> PretextT p g a b a
seek = a -> PretextT p g a b a -> PretextT p g a b a
forall (w :: * -> * -> * -> *) b a c t.
IndexedComonadStore w =>
b -> w a c t -> w b c t
iseek
  {-# INLINE seek #-}
  seeks :: (a -> a) -> PretextT p g a b a -> PretextT p g a b a
seeks = (a -> a) -> PretextT p g a b a -> PretextT p g a b a
forall (w :: * -> * -> * -> *) a b c t.
IndexedComonadStore w =>
(a -> b) -> w a c t -> w b c t
iseeks
  {-# INLINE seeks #-}
  experiment :: (a -> f a) -> PretextT p g a b a -> f a
experiment = (a -> f a) -> PretextT p g a b a -> f a
forall (w :: * -> * -> * -> *) (f :: * -> *) b c t.
(IndexedComonadStore w, Functor f) =>
(b -> f c) -> w b c t -> f t
iexperiment
  {-# INLINE experiment #-}

instance Corepresentable p => Sellable p (PretextT p g) where
  sell :: p a (PretextT p g a b b)
sell = (Corep p a -> PretextT p g a b b) -> p a (PretextT p g a b b)
forall (p :: * -> * -> *) d c.
Corepresentable p =>
(Corep p d -> c) -> p d c
cotabulate ((Corep p a -> PretextT p g a b b) -> p a (PretextT p g a b b))
-> (Corep p a -> PretextT p g a b b) -> p a (PretextT p g a b b)
forall a b. (a -> b) -> a -> b
$ \ Corep p a
w -> (forall (f :: * -> *). Functor f => p a (f b) -> f b)
-> PretextT p g a b b
forall (p :: * -> * -> *) (g :: * -> *) a b t.
(forall (f :: * -> *). Functor f => p a (f b) -> f t)
-> PretextT p g a b t
PretextT (p a (f b) -> Corep p a -> f b
forall (p :: * -> * -> *) (f :: * -> *) a b.
Cosieve p f =>
p a b -> f a -> b
`cosieve` Corep p a
w)
  {-# INLINE sell #-}

instance (Profunctor p, Contravariant g) => Contravariant (PretextT p g a b) where
  contramap :: (a -> b) -> PretextT p g a b b -> PretextT p g a b a
contramap a -> b
_ = a -> PretextT p g a b b -> PretextT p g a b a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
(<$) ([Char] -> a
forall a. HasCallStack => [Char] -> a
error [Char]
"contramap: PretextT")
  {-# INLINE contramap #-}

------------------------------------------------------------------------------
-- Utilities
------------------------------------------------------------------------------

-- | We can convert any 'Conjoined' 'Profunctor' to a function,
-- possibly losing information about an index in the process.
coarr :: (Representable q, Comonad (Rep q)) => q a b -> a -> b
coarr :: q a b -> a -> b
coarr q a b
qab = Rep q b -> b
forall (w :: * -> *) a. Comonad w => w a -> a
extract (Rep q b -> b) -> (a -> Rep q b) -> a -> b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. q a b -> a -> Rep q b
forall (p :: * -> * -> *) (f :: * -> *) a b.
Sieve p f =>
p a b -> a -> f b
sieve q a b
qab
{-# INLINE coarr #-}