{-# LANGUAGE CPP #-}
{-# LANGUAGE Rank2Types #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
#ifdef TRUSTWORTHY
{-# LANGUAGE Trustworthy #-}
#endif
module Control.Lens.Internal.Indexed
(
Indexed(..)
, Conjoined(..)
, Indexable(..)
, Indexing(..)
, indexing
, Indexing64(..)
, indexing64
) where
import Control.Applicative
import Control.Arrow as Arrow
import Control.Category
import Control.Comonad
import Control.Lens.Internal.Instances ()
import Control.Monad
import Control.Monad.Fix
import Data.Distributive
import Data.Functor.Bind
import Data.Functor.Contravariant
import Data.Int
import Data.Profunctor
import Data.Profunctor.Rep
import Data.Traversable
import Prelude hiding ((.),id)
#ifndef SAFE
import Data.Profunctor.Unsafe
import Unsafe.Coerce
#endif
class
( Choice p, Corepresentable p, Comonad (Corep p), Traversable (Corep p)
, Strong p, Representable p, Monad (Rep p), MonadFix (Rep p), Distributive (Rep p)
, ArrowLoop p, ArrowApply p, ArrowChoice p
) => Conjoined p where
distrib :: Functor f => p a b -> p (f a) (f b)
distrib = tabulate . collect . rep
{-# INLINE distrib #-}
conjoined :: ((p ~ (->)) => q (a -> b) r) -> q (p a b) r -> q (p a b) r
conjoined _ r = r
{-# INLINE conjoined #-}
instance Conjoined (->) where
distrib = fmap
{-# INLINE distrib #-}
conjoined l _ = l
{-# INLINE conjoined #-}
class Conjoined p => Indexable i p where
indexed :: p a b -> i -> a -> b
instance Indexable i (->) where
indexed = const
{-# INLINE indexed #-}
newtype Indexed i a b = Indexed { runIndexed :: i -> a -> b }
instance Functor (Indexed i a) where
fmap g (Indexed f) = Indexed $ \i a -> g (f i a)
{-# INLINE fmap #-}
instance Apply (Indexed i a) where
Indexed f <.> Indexed g = Indexed $ \i a -> f i a (g i a)
{-# INLINE (<.>) #-}
instance Applicative (Indexed i a) where
pure b = Indexed $ \_ _ -> b
{-# INLINE pure #-}
Indexed f <*> Indexed g = Indexed $ \i a -> f i a (g i a)
{-# INLINE (<*>) #-}
instance Bind (Indexed i a) where
Indexed f >>- k = Indexed $ \i a -> runIndexed (k (f i a)) i a
{-# INLINE (>>-) #-}
instance Monad (Indexed i a) where
return b = Indexed $ \_ _ -> b
{-# INLINE return #-}
Indexed f >>= k = Indexed $ \i a -> runIndexed (k (f i a)) i a
{-# INLINE (>>=) #-}
instance MonadFix (Indexed i a) where
mfix f = Indexed $ \ i a -> let o = runIndexed (f o) i a in o
{-# INLINE mfix #-}
instance Profunctor (Indexed i) where
dimap ab cd ibc = Indexed $ \i -> cd . runIndexed ibc i . ab
{-# INLINE dimap #-}
lmap ab ibc = Indexed $ \i -> runIndexed ibc i . ab
{-# INLINE lmap #-}
rmap bc iab = Indexed $ \i -> bc . runIndexed iab i
{-# INLINE rmap #-}
#ifndef SAFE
( .# ) ibc _ = unsafeCoerce ibc
{-# INLINE ( .# ) #-}
( #. ) _ = unsafeCoerce
{-# INLINE ( #. ) #-}
#endif
instance Corepresentable (Indexed i) where
type Corep (Indexed i) = (,) i
cotabulate = Indexed . curry
{-# INLINE cotabulate #-}
corep = uncurry . runIndexed
{-# INLINE corep #-}
instance Representable (Indexed i) where
type Rep (Indexed i) = (->) i
tabulate = Indexed . flip
{-# INLINE tabulate #-}
rep = flip . runIndexed
{-# INLINE rep #-}
instance Choice (Indexed i) where
right' = right
{-# INLINE right' #-}
instance Strong (Indexed i) where
second' = second
{-# INLINE second' #-}
instance Category (Indexed i) where
id = Indexed (const id)
{-# INLINE id #-}
Indexed f . Indexed g = Indexed $ \i -> f i . g i
{-# INLINE (.) #-}
instance Arrow (Indexed i) where
arr f = Indexed (\_ -> f)
{-# INLINE arr #-}
first f = Indexed (Arrow.first . runIndexed f)
{-# INLINE first #-}
second f = Indexed (Arrow.second . runIndexed f)
{-# INLINE second #-}
Indexed f *** Indexed g = Indexed $ \i -> f i *** g i
{-# INLINE (***) #-}
Indexed f &&& Indexed g = Indexed $ \i -> f i &&& g i
{-# INLINE (&&&) #-}
instance ArrowChoice (Indexed i) where
left f = Indexed (left . runIndexed f)
{-# INLINE left #-}
right f = Indexed (right . runIndexed f)
{-# INLINE right #-}
Indexed f +++ Indexed g = Indexed $ \i -> f i +++ g i
{-# INLINE (+++) #-}
Indexed f ||| Indexed g = Indexed $ \i -> f i ||| g i
{-# INLINE (|||) #-}
instance ArrowApply (Indexed i) where
app = Indexed $ \ i (f, b) -> runIndexed f i b
{-# INLINE app #-}
instance ArrowLoop (Indexed i) where
loop (Indexed f) = Indexed $ \i b -> let (c,d) = f i (b, d) in c
{-# INLINE loop #-}
instance Conjoined (Indexed i) where
distrib (Indexed iab) = Indexed $ \i fa -> iab i <$> fa
{-# INLINE distrib #-}
instance i ~ j => Indexable i (Indexed j) where
indexed = runIndexed
{-# INLINE indexed #-}
newtype Indexing f a = Indexing { runIndexing :: Int -> (Int, f a) }
instance Functor f => Functor (Indexing f) where
fmap f (Indexing m) = Indexing $ \i -> case m i of
(j, x) -> (j, fmap f x)
{-# INLINE fmap #-}
instance Apply f => Apply (Indexing f) where
Indexing mf <.> Indexing ma = Indexing $ \i -> case mf i of
(j, ff) -> case ma j of
~(k, fa) -> (k, ff <.> fa)
{-# INLINE (<.>) #-}
instance Applicative f => Applicative (Indexing f) where
pure x = Indexing $ \i -> (i, pure x)
{-# INLINE pure #-}
Indexing mf <*> Indexing ma = Indexing $ \i -> case mf i of
(j, ff) -> case ma j of
~(k, fa) -> (k, ff <*> fa)
{-# INLINE (<*>) #-}
instance Contravariant f => Contravariant (Indexing f) where
contramap f (Indexing m) = Indexing $ \i -> case m i of
(j, ff) -> (j, contramap f ff)
{-# INLINE contramap #-}
indexing :: Indexable Int p => ((a -> Indexing f b) -> s -> Indexing f t) -> p a (f b) -> s -> f t
indexing l iafb s = snd $ runIndexing (l (\a -> Indexing (\i -> i `seq` (i + 1, indexed iafb i a))) s) 0
{-# INLINE indexing #-}
newtype Indexing64 f a = Indexing64 { runIndexing64 :: Int64 -> (Int64, f a) }
instance Functor f => Functor (Indexing64 f) where
fmap f (Indexing64 m) = Indexing64 $ \i -> case m i of
(j, x) -> (j, fmap f x)
{-# INLINE fmap #-}
instance Apply f => Apply (Indexing64 f) where
Indexing64 mf <.> Indexing64 ma = Indexing64 $ \i -> case mf i of
(j, ff) -> case ma j of
~(k, fa) -> (k, ff <.> fa)
{-# INLINE (<.>) #-}
instance Applicative f => Applicative (Indexing64 f) where
pure x = Indexing64 $ \i -> (i, pure x)
{-# INLINE pure #-}
Indexing64 mf <*> Indexing64 ma = Indexing64 $ \i -> case mf i of
(j, ff) -> case ma j of
~(k, fa) -> (k, ff <*> fa)
{-# INLINE (<*>) #-}
instance Contravariant f => Contravariant (Indexing64 f) where
contramap f (Indexing64 m) = Indexing64 $ \i -> case m i of
(j, ff) -> (j, contramap f ff)
{-# INLINE contramap #-}
indexing64 :: Indexable Int64 p => ((a -> Indexing64 f b) -> s -> Indexing64 f t) -> p a (f b) -> s -> f t
indexing64 l iafb s = snd $ runIndexing64 (l (\a -> Indexing64 (\i -> i `seq` (i + 1, indexed iafb i a))) s) 0
{-# INLINE indexing64 #-}