module Control.Lens.Internal
(
Context(..)
, Focusing(..)
, FocusingWith(..)
, FocusingPlus(..)
, FocusingOn(..)
, FocusingErr(..), Err(..)
, FocusingMay(..), May(..)
, Traversed(..)
, Sequenced(..)
, Indexing(..), IndexingResult(..)
, Min(..)
, getMin
, Max(..)
, getMax
, ElementOf(..)
, ElementOfResult(..)
, Bazaar(..), bazaar, duplicateBazaar, sell
, Effect(..)
, EffectRWS(..)
, Gettable(..), Accessor(..), Effective(..), ineffective, noEffect, Folding(..)
, Settable(..), Mutator(..)
) where
import Control.Applicative
import Control.Applicative.Backwards
import Control.Category
import Control.Comonad
import Control.Comonad.Store.Class
import Control.Lens.Isomorphic
import Control.Monad
import Prelude hiding ((.),id)
import Data.Functor.Compose
import Data.Functor.Identity
import Data.Monoid
newtype Focusing m c a = Focusing { unfocusing :: m (c, a) }
instance Monad m => Functor (Focusing m c) where
fmap f (Focusing m) = Focusing $ do
(c, a) <- m
return (c, f a)
instance (Monad m, Monoid c) => Applicative (Focusing m c) where
pure a = Focusing (return (mempty, a))
Focusing mf <*> Focusing ma = Focusing $ do
(c, f) <- mf
(d, a) <- ma
return (mappend c d, f a)
newtype FocusingWith w m c a = FocusingWith { unfocusingWith :: m (c, a, w) }
instance Monad m => Functor (FocusingWith w m c) where
fmap f (FocusingWith m) = FocusingWith $ do
(c, a, w) <- m
return (c, f a, w)
instance (Monad m, Monoid c, Monoid w) => Applicative (FocusingWith w m c) where
pure a = FocusingWith (return (mempty, a, mempty))
FocusingWith mf <*> FocusingWith ma = FocusingWith $ do
(c, f, w) <- mf
(d, a, w') <- ma
return (mappend c d, f a, mappend w w')
newtype FocusingPlus w k c a = FocusingPlus { unfocusingPlus :: k (c, w) a }
instance Functor (k (c, w)) => Functor (FocusingPlus w k c) where
fmap f (FocusingPlus as) = FocusingPlus (fmap f as)
instance (Monoid w, Applicative (k (c, w))) => Applicative (FocusingPlus w k c) where
pure = FocusingPlus . pure
FocusingPlus kf <*> FocusingPlus ka = FocusingPlus (kf <*> ka)
newtype FocusingOn f k c a = FocusingOn { unfocusingOn :: k (f c) a }
instance Functor (k (f c)) => Functor (FocusingOn f k c) where
fmap f (FocusingOn as) = FocusingOn (fmap f as)
instance Applicative (k (f c)) => Applicative (FocusingOn f k c) 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 c a = FocusingMay { unfocusingMay :: k (May c) a }
instance Functor (k (May c)) => Functor (FocusingMay k c) where
fmap f (FocusingMay as) = FocusingMay (fmap f as)
instance Applicative (k (May c)) => Applicative (FocusingMay k c) 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 c a = FocusingErr { unfocusingErr :: k (Err e c) a }
instance Functor (k (Err e c)) => Functor (FocusingErr e k c) where
fmap f (FocusingErr as) = FocusingErr (fmap f as)
instance Applicative (k (Err e c)) => Applicative (FocusingErr e k c) where
pure = FocusingErr . pure
FocusingErr kf <*> FocusingErr ka = FocusingErr (kf <*> ka)
data Context c d a = Context (d -> a) c
instance Functor (Context c d) where
fmap f (Context g c) = Context (f . g) c
instance (c ~ d) => Comonad (Context c d) where
extract (Context f c) = f c
duplicate (Context f c) = Context (Context f) c
extend g (Context f c) = Context (g . Context f) c
instance (c ~ d) => ComonadStore c (Context c d) where
pos (Context _ c) = c
peek c (Context g _) = g c
peeks f (Context g c) = g (f c)
seek c (Context g _) = Context g c
seeks f (Context g c) = Context g (f c)
experiment f (Context g c) = g <$> f c
data IndexingResult f a = IndexingResult (f a) !Int
instance Functor f => Functor (IndexingResult f) where
fmap f (IndexingResult fa n) = IndexingResult (fmap f fa) n
newtype Indexing f a = Indexing { runIndexing :: Int -> IndexingResult f a }
instance Functor f => Functor (Indexing f) where
fmap f (Indexing m) = Indexing $ \i -> fmap f (m i)
instance Applicative f => Applicative (Indexing f) where
pure = Indexing . IndexingResult . pure
Indexing mf <*> Indexing ma = Indexing $ \i -> case mf i of
IndexingResult ff j -> case ma j of
IndexingResult fa k -> IndexingResult (ff <*> fa) k
instance Gettable f => Gettable (Indexing f) where
coerce (Indexing m) = Indexing $ \i -> case m i of
IndexingResult ff j -> IndexingResult (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 ElementOfResult f a
= Searching !Int a
| Found !Int (f a)
| NotFound String
instance Functor f => Functor (ElementOfResult f) where
fmap f (Searching i a) = Searching i (f a)
fmap f (Found i as) = Found i (fmap f as)
fmap _ (NotFound e) = NotFound e
newtype ElementOf f a = ElementOf { getElementOf :: Int -> ElementOfResult f a }
instance Functor f => Functor (ElementOf f) where
fmap f (ElementOf m) = ElementOf $ \i -> case m i of
Searching j a -> Searching j (f a)
Found j as -> Found j (fmap f as)
NotFound e -> NotFound e
instance Functor f => Applicative (ElementOf f) where
pure a = ElementOf $ \i -> Searching i a
ElementOf mf <*> ElementOf ma = ElementOf $ \i -> case mf i of
Found j ff -> case ma j of
Found _ _ -> NotFound "multiple results"
Searching k a -> Found k (fmap ($ a) ff)
NotFound e -> NotFound e
Searching j f -> case ma j of
Found k as -> Found k (fmap f as)
Searching k a -> Searching k (f a)
NotFound e -> NotFound e
NotFound e -> NotFound e
newtype Bazaar c d a = Bazaar { _runBazaar :: forall f. Applicative f => (c -> f d) -> f a }
instance Functor (Bazaar c d) where
fmap f (Bazaar k) = Bazaar (fmap f . k)
instance Applicative (Bazaar c d) where
pure a = Bazaar (\_ -> pure a)
Bazaar mf <*> Bazaar ma = Bazaar (\k -> mf k <*> ma k)
instance (c ~ d) => Comonad (Bazaar c d) where
extract (Bazaar m) = runIdentity (m Identity)
duplicate = duplicateBazaar
bazaar :: Applicative f => (c -> f d) -> Bazaar c d b -> f b
bazaar cfd (Bazaar m) = m cfd
duplicateBazaar :: Bazaar c e a -> Bazaar c d (Bazaar d e a)
duplicateBazaar (Bazaar m) = getCompose (m (Compose . fmap sell . sell))
sell :: c -> Bazaar c d d
sell i = Bazaar (\k -> k i)
instance (c ~ d) => ComonadApply (Bazaar c d) 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)
newtype EffectRWS w s m c a = EffectRWS { getEffectRWS :: s -> m (c,s,w) }
instance Functor (EffectRWS w s m c) where
fmap _ (EffectRWS m) = EffectRWS m
instance (Monoid c, Monoid w, Monad m) => Applicative (EffectRWS w s m c) where
pure _ = EffectRWS $ \s -> return (mempty, s, mempty)
EffectRWS m <*> EffectRWS n = EffectRWS $ \s -> m s >>= \ (c,t,w) -> n t >>= \ (c',u,w') -> return (mappend c c', u, mappend w w')
class Functor f => Gettable f where
coerce :: f a -> f b
instance Gettable (Const r) where
coerce (Const m) = Const m
instance Gettable f => Gettable (Backwards f) where
coerce = Backwards . coerce . forwards
instance (Functor f, Gettable g) => Gettable (Compose f g) where
coerce = Compose . fmap coerce . getCompose
instance Gettable (Effect m r) where
coerce (Effect m) = Effect m
instance Gettable (EffectRWS w s m c) where
coerce (EffectRWS m) = EffectRWS m
instance Gettable f => Gettable (ElementOf f) where
coerce (ElementOf m) = ElementOf $ \i -> case m i of
Searching _ _ -> NotFound "coerced while searching"
Found j as -> Found j (coerce as)
NotFound s -> NotFound s
instance Gettable (Accessor r) where
coerce (Accessor m) = Accessor m
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)
class (Monad m, Gettable f) => Effective m r f | f -> m r where
effective :: Isomorphic k => k (m r) (f a)
ineffective :: Effective m r f => Isomorphic k => k (f a) (m r)
ineffective = from effective
instance Effective Identity r (Accessor r) where
effective = isomorphic (Accessor . runIdentity) (Identity . runAccessor)
instance Effective m r f => Effective m (Dual r) (Backwards f) where
effective = isomorphic (Backwards . effective . liftM getDual) (liftM Dual . ineffective . forwards)
instance Monad m => Effective m r (Effect m r) where
effective = isomorphic Effect getEffect
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)
noEffect :: (Applicative f, Gettable f) => f a
noEffect = coerce $ pure ()
class Applicative f => Settable f where
untainted :: f a -> a
instance Settable Identity where
untainted = runIdentity
instance Settable f => Settable (Backwards f) where
untainted = untainted . forwards
instance (Settable f, Settable g) => Settable (Compose f g) where
untainted = untainted . untainted . getCompose
instance Settable Mutator where
untainted = runMutator
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)