#ifdef TRUSTWORTHY
#endif
module Control.Lens.Internal
(
May(..)
, Folding(..)
, Effect(..)
, EffectRWS(..)
, Accessor(..)
, Err(..)
, Traversed(..)
, Sequenced(..)
, Focusing(..)
, FocusingWith(..)
, FocusingPlus(..)
, FocusingOn(..)
, FocusingMay(..)
, FocusingErr(..)
, Mutator(..)
, Bazaar(..), bazaar, duplicateBazaar, sell
, BazaarT(..), bazaarT, duplicateBazaarT, sellT
, Context(..)
, Max(..), getMax
, Min(..), getMin
, Indexing(..)
, Indexing64(..)
, Prismoid(..)
, Isoid(..)
, Indexed(..)
, CoA, CoB
) where
import Control.Applicative
import Control.Category
import Control.Comonad
import Control.Comonad.Store.Class
import Control.Lens.Classes
import Control.Monad
import Prelude hiding ((.),id)
import Data.Functor.Compose
import Data.Functor.Identity
import Data.Int
import Data.Monoid
#ifndef SAFE
import Unsafe.Coerce
#endif
#ifndef SAFE
#define UNSAFELY(x) unsafeCoerce
#else
#define UNSAFELY(f) (\g -> g `seq` \x -> (f) (g x))
#endif
newtype Focusing m s a = Focusing { unfocusing :: m (s, a) }
instance Monad m => Functor (Focusing m s) where
fmap f (Focusing m) = Focusing $ do
(s, a) <- m
return (s, f a)
instance (Monad m, Monoid s) => Applicative (Focusing m s) where
pure a = Focusing (return (mempty, a))
Focusing mf <*> Focusing ma = Focusing $ do
(s, f) <- mf
(s', a) <- ma
return (mappend s s', f a)
newtype FocusingWith w m s a = FocusingWith { unfocusingWith :: m (s, a, w) }
instance Monad m => Functor (FocusingWith w m s) where
fmap f (FocusingWith m) = FocusingWith $ do
(s, a, w) <- m
return (s, f a, w)
instance (Monad m, Monoid s, Monoid w) => Applicative (FocusingWith w m s) where
pure a = FocusingWith (return (mempty, a, mempty))
FocusingWith mf <*> FocusingWith ma = FocusingWith $ do
(s, f, w) <- mf
(s', a, w') <- ma
return (mappend s s', f a, mappend w w')
newtype FocusingPlus w k s a = FocusingPlus { unfocusingPlus :: k (s, w) a }
instance Functor (k (s, w)) => Functor (FocusingPlus w k s) where
fmap f (FocusingPlus as) = FocusingPlus (fmap f as)
instance (Monoid w, Applicative (k (s, w))) => Applicative (FocusingPlus w k s) where
pure = FocusingPlus . pure
FocusingPlus kf <*> FocusingPlus ka = FocusingPlus (kf <*> ka)
newtype FocusingOn f k s a = FocusingOn { unfocusingOn :: k (f s) a }
instance Functor (k (f s)) => Functor (FocusingOn f k s) where
fmap f (FocusingOn as) = FocusingOn (fmap f as)
instance Applicative (k (f s)) => Applicative (FocusingOn f k s) where
pure = FocusingOn . pure
FocusingOn kf <*> FocusingOn ka = FocusingOn (kf <*> ka)
newtype May a = May { getMay :: Maybe a }
instance Monoid a => Monoid (May a) where
mempty = May (Just mempty)
May Nothing `mappend` _ = May Nothing
_ `mappend` May Nothing = May Nothing
May (Just a) `mappend` May (Just b) = May (Just (mappend a b))
newtype FocusingMay k s a = FocusingMay { unfocusingMay :: k (May s) a }
instance Functor (k (May s)) => Functor (FocusingMay k s) where
fmap f (FocusingMay as) = FocusingMay (fmap f as)
instance Applicative (k (May s)) => Applicative (FocusingMay k s) where
pure = FocusingMay . pure
FocusingMay kf <*> FocusingMay ka = FocusingMay (kf <*> ka)
newtype Err e a = Err { getErr :: Either e a }
instance Monoid a => Monoid (Err e a) where
mempty = Err (Right mempty)
Err (Left e) `mappend` _ = Err (Left e)
_ `mappend` Err (Left e) = Err (Left e)
Err (Right a) `mappend` Err (Right b) = Err (Right (mappend a b))
newtype FocusingErr e k s a = FocusingErr { unfocusingErr :: k (Err e s) a }
instance Functor (k (Err e s)) => Functor (FocusingErr e k s) where
fmap f (FocusingErr as) = FocusingErr (fmap f as)
instance Applicative (k (Err e s)) => Applicative (FocusingErr e k s) where
pure = FocusingErr . pure
FocusingErr kf <*> FocusingErr ka = FocusingErr (kf <*> ka)
newtype Indexing f a = Indexing { runIndexing :: Int -> (f a, Int) }
instance Functor f => Functor (Indexing f) where
fmap f (Indexing m) = Indexing $ \i -> case m i of
(x, j) -> (fmap f x, j)
instance Applicative f => Applicative (Indexing f) where
pure x = Indexing (\i -> (pure x, i))
Indexing mf <*> Indexing ma = Indexing $ \i -> case mf i of
(ff, j) -> case ma j of
~(fa, k) -> (ff <*> fa, k)
instance Gettable f => Gettable (Indexing f) where
coerce (Indexing m) = Indexing $ \i -> case m i of
(ff, j) -> (coerce ff, j)
newtype Indexing64 f a = Indexing64 { runIndexing64 :: Int64 -> (f a, Int64) }
instance Functor f => Functor (Indexing64 f) where
fmap f (Indexing64 m) = Indexing64 $ \i -> case m i of
(x, j) -> (fmap f x, j)
instance Applicative f => Applicative (Indexing64 f) where
pure x = Indexing64 (\i -> (pure x, i))
Indexing64 mf <*> Indexing64 ma = Indexing64 $ \i -> case mf i of
(ff, j) -> case ma j of
~(fa, k) -> (ff <*> fa, k)
instance Gettable f => Gettable (Indexing64 f) where
coerce (Indexing64 m) = Indexing64 $ \i -> case m i of
(ff, j) -> (coerce ff, j)
newtype Traversed f = Traversed { getTraversed :: f () }
instance Applicative f => Monoid (Traversed f) where
mempty = Traversed (pure ())
Traversed ma `mappend` Traversed mb = Traversed (ma *> mb)
newtype Sequenced m = Sequenced { getSequenced :: m () }
instance Monad m => Monoid (Sequenced m) where
mempty = Sequenced (return ())
Sequenced ma `mappend` Sequenced mb = Sequenced (ma >> mb)
data Min a = NoMin | Min a
instance Ord a => Monoid (Min a) where
mempty = NoMin
mappend NoMin m = m
mappend m NoMin = m
mappend (Min a) (Min b) = Min (min a b)
getMin :: Min a -> Maybe a
getMin NoMin = Nothing
getMin (Min a) = Just a
data Max a = NoMax | Max a
instance Ord a => Monoid (Max a) where
mempty = NoMax
mappend NoMax m = m
mappend m NoMax = m
mappend (Max a) (Max b) = Max (max a b)
getMax :: Max a -> Maybe a
getMax NoMax = Nothing
getMax (Max a) = Just a
data Context a b t = Context (b -> t) a
instance Functor (Context a b) where
fmap f (Context g t) = Context (f . g) t
instance (a ~ b) => Comonad (Context a b) where
extract (Context f a) = f a
duplicate (Context f a) = Context (Context f) a
extend g (Context f a) = Context (g . Context f) a
instance (a ~ b) => ComonadStore a (Context a b) where
pos (Context _ a) = a
peek b (Context g _) = g b
peeks f (Context g a) = g (f a)
seek a (Context g _) = Context g a
seeks f (Context g a) = Context g (f a)
experiment f (Context g a) = g <$> f a
newtype Bazaar a b t = Bazaar { runBazaar :: forall f. Applicative f => (a -> f b) -> f t }
instance Functor (Bazaar a b) where
fmap f (Bazaar k) = Bazaar (fmap f . k)
instance Applicative (Bazaar a b) where
pure a = Bazaar (\_ -> pure a)
Bazaar mf <*> Bazaar ma = Bazaar (\k -> mf k <*> ma k)
instance (a ~ b) => Comonad (Bazaar a b) where
extract (Bazaar m) = runIdentity (m Identity)
duplicate = duplicateBazaar
bazaar :: Applicative f => (a -> f b) -> Bazaar a b t -> f t
bazaar afb (Bazaar m) = m afb
duplicateBazaar :: Bazaar a c t -> Bazaar a b (Bazaar b c t)
duplicateBazaar (Bazaar m) = getCompose (m (Compose . fmap sell . sell))
sell :: a -> Bazaar a b b
sell i = Bazaar (\k -> k i)
instance (a ~ b) => ComonadApply (Bazaar a b) where
(<@>) = (<*>)
newtype Effect m r a = Effect { getEffect :: m r }
instance Functor (Effect m r) where
fmap _ (Effect m) = Effect m
instance (Monad m, Monoid r) => Monoid (Effect m r a) where
mempty = Effect (return mempty)
Effect ma `mappend` Effect mb = Effect (liftM2 mappend ma mb)
instance (Monad m, Monoid r) => Applicative (Effect m r) where
pure _ = Effect (return mempty)
Effect ma <*> Effect mb = Effect (liftM2 mappend ma mb)
instance Gettable (Effect m r) where
coerce (Effect m) = Effect m
instance Monad m => Effective m r (Effect m r) where
effective = Effect
ineffective = getEffect
newtype EffectRWS w st m s a = EffectRWS { getEffectRWS :: st -> m (s,st,w) }
instance Functor (EffectRWS w st m s) where
fmap _ (EffectRWS m) = EffectRWS m
instance Gettable (EffectRWS w st m s) where
coerce (EffectRWS m) = EffectRWS m
instance (Monoid s, Monoid w, Monad m) => Applicative (EffectRWS w st m s) where
pure _ = EffectRWS $ \st -> return (mempty, st, mempty)
EffectRWS m <*> EffectRWS n = EffectRWS $ \st -> m st >>= \ (s,t,w) -> n t >>= \ (s',u,w') -> return (mappend s s', u, mappend w w')
newtype Accessor r a = Accessor { runAccessor :: r }
instance Functor (Accessor r) where
fmap _ (Accessor m) = Accessor m
instance Monoid r => Applicative (Accessor r) where
pure _ = Accessor mempty
Accessor a <*> Accessor b = Accessor (mappend a b)
instance Gettable (Accessor r) where
coerce (Accessor m) = Accessor m
instance Effective Identity r (Accessor r) where
effective = Accessor . runIdentity
ineffective = Identity . runAccessor
newtype Folding f a = Folding { getFolding :: f a }
instance (Gettable f, Applicative f) => Monoid (Folding f a) where
mempty = Folding noEffect
Folding fr `mappend` Folding fs = Folding (fr *> fs)
newtype Mutator a = Mutator { runMutator :: a }
instance Functor Mutator where
fmap f (Mutator a) = Mutator (f a)
instance Applicative Mutator where
pure = Mutator
Mutator f <*> Mutator a = Mutator (f a)
instance Settable Mutator where
untainted = runMutator
untainted# = UNSAFELY(runMutator)
tainted# = UNSAFELY(Mutator)
newtype BazaarT a b (g :: * -> *) t = BazaarT { runBazaarT :: forall f. Applicative f => (a -> f b) -> f t }
instance Functor (BazaarT a b g) where
fmap f (BazaarT k) = BazaarT (fmap f . k)
instance Applicative (BazaarT a b g) where
pure a = BazaarT (\_ -> pure a)
BazaarT mf <*> BazaarT ma = BazaarT (\k -> mf k <*> ma k)
instance (a ~ b) => Comonad (BazaarT a b g) where
extract (BazaarT m) = runIdentity (m Identity)
duplicate = duplicateBazaarT
instance Gettable g => Gettable (BazaarT a b g) where
coerce = (<$) (error "coerced BazaarT")
bazaarT :: Applicative f => (a -> f b) -> BazaarT a b g t -> f t
bazaarT afb (BazaarT m) = m afb
duplicateBazaarT :: BazaarT a c f t -> BazaarT a b f (BazaarT b c f t)
duplicateBazaarT (BazaarT m) = getCompose (m (Compose . fmap sellT . sellT))
sellT :: a -> BazaarT a b f b
sellT i = BazaarT (\k -> k i)
type family ArgOf (f_b :: *) :: *
type instance ArgOf (f b) = b
type family CoA x :: *
type family CoB x :: *
type instance CoA (a -> f_b) = a
type instance CoB (a -> f_b) = ArgOf f_b
data Prismoid ab st where
Prismoid :: Prismoid x x
Prism :: (CoB x -> CoB y) -> (CoA y -> Either (CoB y) (CoA x)) -> Prismoid x y
instance Category Prismoid where
id = Prismoid
x . Prismoid = x
Prismoid . x = x
Prism ty xeys . Prism bt seta = Prism (ty.bt) $ \x ->
case xeys x of
Left y -> Left y
Right s -> case seta s of
Left t -> Left (ty t)
Right a -> Right a
instance Isomorphic Prismoid where
iso sa bt = Prism bt (Right . sa)
instance Prismatic Prismoid where
prism = Prism
data Isoid ab st where
Isoid :: Isoid ab ab
Iso :: (CoA y -> CoA x) -> (CoB x -> CoB y) -> Isoid x y
instance Category Isoid where
id = Isoid
Isoid . x = x
x . Isoid = x
Iso xs ty . Iso sa bt = Iso (sa.xs) (ty.bt)
instance Isomorphic Isoid where
iso = Iso
newtype Indexed i a b = Indexed { withIndex :: (i -> a) -> b }
instance i ~ j => Indexable i (Indexed j) where
indexed = Indexed