{-# LANGUAGE Rank2Types #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE TypeFamilies #-}
module Control.Lens.Reified where
import Control.Applicative
import Control.Arrow
import qualified Control.Category as Cat
import Control.Comonad
import Control.Lens.Action
import Control.Lens.Fold
import Control.Lens.Getter
import Control.Lens.Internal.Indexed
import Control.Lens.Traversal (ignored,beside)
import Control.Lens.Type
import Control.Monad
import Control.Monad.Reader.Class
import Data.Distributive
import Data.Foldable
import Data.Functor.Compose
import Data.Functor.Bind
import Data.Functor.Extend
import Data.Functor.Identity
import Data.Functor.Plus
import Data.Profunctor
import Data.Profunctor.Rep
import Data.Semigroup
newtype ReifiedLens s t a b = Lens { runLens :: Lens s t a b }
type ReifiedLens' s a = ReifiedLens s s a a
newtype ReifiedIndexedLens i s t a b = IndexedLens { runIndexedLens :: IndexedLens i s t a b }
type ReifiedIndexedLens' i s a = ReifiedIndexedLens i s s a a
newtype ReifiedIndexedTraversal i s t a b = IndexedTraversal { runIndexedTraversal :: IndexedTraversal i s t a b }
type ReifiedIndexedTraversal' i s a = ReifiedIndexedTraversal i s s a a
newtype ReifiedTraversal s t a b = Traversal { runTraversal :: Traversal s t a b }
type ReifiedTraversal' s a = ReifiedTraversal s s a a
newtype ReifiedGetter s a = Getter { runGetter :: Getter s a }
instance Distributive (ReifiedGetter s) where
distribute as = Getter $ to $ \s -> fmap (\(Getter l) -> view l s) as
instance Functor (ReifiedGetter s) where
fmap f l = Getter (runGetter l.to f)
{-# INLINE fmap #-}
instance Semigroup s => Extend (ReifiedGetter s) where
duplicated (Getter l) = Getter $ to $ \m -> Getter $ to $ \n -> view l (m <> n)
{-# INLINE duplicated #-}
instance Monoid s => Comonad (ReifiedGetter s) where
extract (Getter l) = view l mempty
{-# INLINE extract #-}
duplicate (Getter l) = Getter $ to $ \m -> Getter $ to $ \n -> view l (mappend m n)
{-# INLINE duplicate #-}
instance Monoid s => ComonadApply (ReifiedGetter s) where
Getter mf <@> Getter ma = Getter $ to $ \s -> view mf s (view ma s)
{-# INLINE (<@>) #-}
m <@ _ = m
{-# INLINE (<@) #-}
_ @> m = m
{-# INLINE (@>) #-}
instance Apply (ReifiedGetter s) where
Getter mf <.> Getter ma = Getter $ to $ \s -> view mf s (view ma s)
{-# INLINE (<.>) #-}
m <. _ = m
{-# INLINE (<.) #-}
_ .> m = m
{-# INLINE (.>) #-}
instance Applicative (ReifiedGetter s) where
pure a = Getter $ to $ \_ -> a
{-# INLINE pure #-}
Getter mf <*> Getter ma = Getter $ to $ \s -> view mf s (view ma s)
{-# INLINE (<*>) #-}
m <* _ = m
{-# INLINE (<*) #-}
_ *> m = m
{-# INLINE (*>) #-}
instance Bind (ReifiedGetter s) where
Getter ma >>- f = Getter $ to $ \s -> view (runGetter (f (view ma s))) s
{-# INLINE (>>-) #-}
instance Monad (ReifiedGetter s) where
return a = Getter $ to $ \_ -> a
{-# INLINE return #-}
Getter ma >>= f = Getter $ to $ \s -> view (runGetter (f (view ma s))) s
{-# INLINE (>>=) #-}
instance MonadReader s (ReifiedGetter s) where
ask = Getter id
{-# INLINE ask #-}
local f m = Getter (to f . runGetter m)
{-# INLINE local #-}
instance Profunctor ReifiedGetter where
dimap f g l = Getter $ to f.runGetter l.to g
{-# INLINE dimap #-}
lmap g l = Getter $ to g.runGetter l
{-# INLINE lmap #-}
rmap f l = Getter $ runGetter l.to f
{-# INLINE rmap #-}
instance Corepresentable ReifiedGetter where
type Corep ReifiedGetter = Identity
cotabulate f = Getter $ to (f . Identity)
corep (Getter l) = view l . runIdentity
instance Representable ReifiedGetter where
type Rep ReifiedGetter = Identity
tabulate f = Getter $ to (runIdentity . f)
rep (Getter l) = Identity . view l
instance Conjoined ReifiedGetter
instance Strong ReifiedGetter where
first' l = Getter $ \f (s,c) ->
coerce $ runGetter l (dimap (flip (,) c) coerce f) s
{-# INLINE first' #-}
second' l = Getter $ \f (c,s) ->
coerce $ runGetter l (dimap ((,) c) coerce f) s
{-# INLINE second' #-}
instance Choice ReifiedGetter where
left' l = Getter $ to $ left' $ view $ runGetter l
{-# INLINE left' #-}
right' l = Getter $ to $ right' $ view $ runGetter l
{-# INLINE right' #-}
instance Cat.Category ReifiedGetter where
id = Getter id
l . r = Getter (runGetter r.runGetter l)
{-# INLINE (.) #-}
instance Arrow ReifiedGetter where
arr f = Getter (to f)
{-# INLINE arr #-}
first l = Getter $ to $ first $ view $ runGetter l
{-# INLINE first #-}
second l = Getter $ to $ second $ view $ runGetter l
{-# INLINE second #-}
Getter l *** Getter r = Getter $ to $ view l *** view r
{-# INLINE (***) #-}
Getter l &&& Getter r = Getter $ to $ view l &&& view r
{-# INLINE (&&&) #-}
instance ArrowApply ReifiedGetter where
app = Getter $ to $ \(Getter bc, b) -> view bc b
{-# INLINE app #-}
instance ArrowChoice ReifiedGetter where
left l = Getter $ to $ left $ view $ runGetter l
{-# INLINE left #-}
right l = Getter $ to $ right $ view $ runGetter l
{-# INLINE right #-}
Getter l +++ Getter r = Getter $ to $ view l +++ view r
{-# INLINE (+++) #-}
Getter l ||| Getter r = Getter $ to $ view l ||| view r
{-# INLINE (|||) #-}
instance ArrowLoop ReifiedGetter where
loop l = Getter $ to $ loop $ view $ runGetter l
{-# INLINE loop #-}
newtype ReifiedIndexedGetter i s a = IndexedGetter { runIndexedGetter :: IndexedGetter i s a }
instance Profunctor (ReifiedIndexedGetter i) where
dimap f g l = IndexedGetter (to f . runIndexedGetter l . to g)
{-# INLINE dimap #-}
instance Representable (ReifiedIndexedGetter i) where
type Rep (ReifiedIndexedGetter i) = (,) i
tabulate f = IndexedGetter $ ito f
{-# INLINE tabulate #-}
rep = iview . runIndexedGetter
{-# INLINE rep #-}
instance Strong (ReifiedIndexedGetter i) where
first' l = IndexedGetter $ \f (s,c) ->
coerce $ runIndexedGetter l (dimap (flip (,) c) coerce f) s
{-# INLINE first' #-}
second' l = IndexedGetter $ \f (c,s) ->
coerce $ runIndexedGetter l (dimap ((,) c) coerce f) s
{-# INLINE second' #-}
instance Functor (ReifiedIndexedGetter i s) where
fmap f l = IndexedGetter (runIndexedGetter l.to f)
{-# INLINE fmap #-}
instance Semigroup i => Apply (ReifiedIndexedGetter i s) where
IndexedGetter mf <.> IndexedGetter ma = IndexedGetter $ \k s ->
case iview mf s of
(i, f) -> case iview ma s of
(j, a) -> coerce $ indexed k (i <> j) (f a)
{-# INLINE (<.>) #-}
newtype ReifiedFold s a = Fold { runFold :: Fold s a }
instance Profunctor ReifiedFold where
dimap f g l = Fold (to f . runFold l . to g)
{-# INLINE dimap #-}
rmap g l = Fold (runFold l . to g)
{-# INLINE rmap #-}
lmap f l = Fold (to f . runFold l)
{-# INLINE lmap #-}
instance Representable ReifiedFold where
type Rep ReifiedFold = []
tabulate f = Fold (folding f)
rep = toListOf . runFold
instance Strong ReifiedFold where
first' l = Fold $ \f (s,c) ->
coerce $ runFold l (dimap (flip (,) c) coerce f) s
{-# INLINE first' #-}
second' l = Fold $ \f (c,s) ->
coerce $ runFold l (dimap ((,) c) coerce f) s
{-# INLINE second' #-}
instance Choice ReifiedFold where
left' (Fold l) = Fold $ folding $ \esc -> case esc of
Left s -> Left <$> toListOf l s
Right c -> [Right c]
{-# INLINE left' #-}
right' (Fold l) = Fold $ folding $ \ecs -> case ecs of
Left c -> [Left c]
Right s -> Right <$> toListOf l s
{-# INLINE right' #-}
instance Cat.Category ReifiedFold where
id = Fold id
l . r = Fold (runFold r . runFold l)
{-# INLINE (.) #-}
instance Arrow ReifiedFold where
arr f = Fold (to f)
{-# INLINE arr #-}
first = first'
{-# INLINE first #-}
second = second'
{-# INLINE second #-}
Fold l *** Fold r = Fold $ folding $ \(x,y) -> (,) <$> toListOf l x <*> toListOf r y
{-# INLINE (***) #-}
Fold l &&& Fold r = Fold $ folding $ \x -> (,) <$> toListOf l x <*> toListOf r x
{-# INLINE (&&&) #-}
instance ArrowChoice ReifiedFold where
left = left'
{-# INLINE left #-}
right = right'
{-# INLINE right #-}
instance ArrowApply ReifiedFold where
app = Fold $ folding $ \(Fold bc, b) -> toListOf bc b
{-# INLINE app #-}
instance Functor (ReifiedFold s) where
fmap f l = Fold (runFold l.to f)
{-# INLINE fmap #-}
instance Apply (ReifiedFold s) where
Fold mf <.> Fold ma = Fold $ folding $ \s -> toListOf mf s <.> toListOf ma s
{-# INLINE (<.>) #-}
Fold mf <. Fold ma = Fold $ folding $ \s -> toListOf mf s <. toListOf ma s
{-# INLINE (<.) #-}
Fold mf .> Fold ma = Fold $ folding $ \s -> toListOf mf s .> toListOf ma s
{-# INLINE (.>) #-}
instance Applicative (ReifiedFold s) where
pure a = Fold $ folding $ \_ -> [a]
{-# INLINE pure #-}
Fold mf <*> Fold ma = Fold $ folding $ \s -> toListOf mf s <*> toListOf ma s
{-# INLINE (<*>) #-}
Fold mf <* Fold ma = Fold $ folding $ \s -> toListOf mf s <* toListOf ma s
{-# INLINE (<*) #-}
Fold mf *> Fold ma = Fold $ folding $ \s -> toListOf mf s *> toListOf ma s
{-# INLINE (*>) #-}
instance Alternative (ReifiedFold s) where
empty = Fold ignored
{-# INLINE empty #-}
Fold ma <|> Fold mb = Fold $ folding (\s -> toListOf ma s ++ toListOf mb s)
{-# INLINE (<|>) #-}
instance Bind (ReifiedFold s) where
Fold ma >>- f = Fold $ folding $ \s -> toListOf ma s >>- \a -> toListOf (runFold (f a)) s
{-# INLINE (>>-) #-}
instance Monad (ReifiedFold s) where
return a = Fold $ folding $ \_ -> [a]
{-# INLINE return #-}
Fold ma >>= f = Fold $ folding $ \s -> toListOf ma s >>= \a -> toListOf (runFold (f a)) s
{-# INLINE (>>=) #-}
instance MonadPlus (ReifiedFold s) where
mzero = empty
{-# INLINE mzero #-}
mplus = (<|>)
{-# INLINE mplus #-}
instance MonadReader s (ReifiedFold s) where
ask = Fold id
{-# INLINE ask #-}
local f m = Fold (to f . runFold m)
{-# INLINE local #-}
instance Semigroup (ReifiedFold s a) where
(<>) = (<|>)
{-# INLINE (<>) #-}
instance Monoid (ReifiedFold s a) where
mempty = Fold ignored
{-# INLINE mempty #-}
mappend = (<|>)
{-# INLINE mappend #-}
instance Alt (ReifiedFold s) where
(<!>) = (<|>)
{-# INLINE (<!>) #-}
instance Plus (ReifiedFold s) where
zero = Fold ignored
{-# INLINE zero #-}
newtype ReifiedIndexedFold i s a = IndexedFold { runIndexedFold :: IndexedFold i s a }
instance Semigroup (ReifiedIndexedFold i s a) where
(<>) = (<!>)
{-# INLINE (<>) #-}
instance Monoid (ReifiedIndexedFold i s a) where
mempty = IndexedFold ignored
{-# INLINE mempty #-}
mappend = (<!>)
{-# INLINE mappend #-}
instance Alt (ReifiedIndexedFold i s) where
IndexedFold ma <!> IndexedFold mb = IndexedFold $
ifolding $ \s -> itoListOf ma s ++ itoListOf mb s
{-# INLINE (<!>) #-}
instance Plus (ReifiedIndexedFold i s) where
zero = IndexedFold ignored
{-# INLINE zero #-}
instance Functor (ReifiedIndexedFold i s) where
fmap f l = IndexedFold (runIndexedFold l . to f)
{-# INLINE fmap #-}
instance Profunctor (ReifiedIndexedFold i) where
dimap f g l = IndexedFold (to f . runIndexedFold l . to g)
{-# INLINE dimap #-}
lmap f l = IndexedFold (to f . runIndexedFold l)
{-# INLINE lmap #-}
rmap g l = IndexedFold (runIndexedFold l . to g)
{-# INLINE rmap #-}
instance Representable (ReifiedIndexedFold i) where
type Rep (ReifiedIndexedFold i) = Compose [] ((,) i)
tabulate k = IndexedFold $ \f -> coerce . traverse_ (coerce . uncurry (indexed f)) . getCompose . k
{-# INLINE tabulate #-}
rep (IndexedFold l) = Compose . itoListOf l
{-# INLINE rep #-}
instance Strong (ReifiedIndexedFold i) where
first' l = IndexedFold $ \f (s,c) ->
coerce $ runIndexedFold l (dimap (flip (,) c) coerce f) s
{-# INLINE first' #-}
second' l = IndexedFold $ \f (c,s) ->
coerce $ runIndexedFold l (dimap ((,) c) coerce f) s
{-# INLINE second' #-}
newtype ReifiedMonadicFold m s a = MonadicFold { runMonadicFold :: MonadicFold m s a }
instance Profunctor (ReifiedMonadicFold m) where
dimap f g l = MonadicFold (to f . runMonadicFold l . to g)
{-# INLINE dimap #-}
rmap g l = MonadicFold (runMonadicFold l . to g)
{-# INLINE rmap #-}
lmap f l = MonadicFold (to f . runMonadicFold l)
{-# INLINE lmap #-}
instance Strong (ReifiedMonadicFold m) where
first' l = MonadicFold $ \f (s,c) ->
coerce $ runMonadicFold l (dimap (flip (,) c) coerce f) s
{-# INLINE first' #-}
second' l = MonadicFold $ \f (c,s) ->
coerce $ runMonadicFold l (dimap ((,) c) coerce f) s
{-# INLINE second' #-}
instance Choice (ReifiedMonadicFold m) where
left' (MonadicFold l) = MonadicFold $
to tuplify.beside (folded.l.to Left) (folded.to Right)
where
tuplify (Left lval) = (Just lval,Nothing)
tuplify (Right rval) = (Nothing,Just rval)
{-# INLINE left' #-}
instance Cat.Category (ReifiedMonadicFold m) where
id = MonadicFold id
l . r = MonadicFold (runMonadicFold r . runMonadicFold l)
{-# INLINE (.) #-}
instance Arrow (ReifiedMonadicFold m) where
arr f = MonadicFold (to f)
{-# INLINE arr #-}
first = first'
{-# INLINE first #-}
second = second'
{-# INLINE second #-}
instance ArrowChoice (ReifiedMonadicFold m) where
left = left'
{-# INLINE left #-}
right = right'
{-# INLINE right #-}
instance ArrowApply (ReifiedMonadicFold m) where
app = MonadicFold $ \cHandler (argFold,b) ->
runMonadicFold (pure b >>> argFold) cHandler (argFold,b)
{-# INLINE app #-}
instance Functor (ReifiedMonadicFold m s) where
fmap f l = MonadicFold (runMonadicFold l.to f)
{-# INLINE fmap #-}
instance Apply (ReifiedMonadicFold m s) where
mf <.> ma = mf &&& ma >>> (MonadicFold $ to (uncurry ($)))
{-# INLINE (<.>) #-}
instance Applicative (ReifiedMonadicFold m s) where
pure a = MonadicFold $ folding $ \_ -> [a]
{-# INLINE pure #-}
mf <*> ma = mf <.> ma
{-# INLINE (<*>) #-}
instance Alternative (ReifiedMonadicFold m s) where
empty = MonadicFold ignored
{-# INLINE empty #-}
MonadicFold ma <|> MonadicFold mb = MonadicFold $ to (\x->(x,x)).beside ma mb
{-# INLINE (<|>) #-}
instance Semigroup (ReifiedMonadicFold m s a) where
(<>) = (<|>)
{-# INLINE (<>) #-}
instance Monoid (ReifiedMonadicFold m s a) where
mempty = MonadicFold ignored
{-# INLINE mempty #-}
mappend = (<|>)
{-# INLINE mappend #-}
instance Alt (ReifiedMonadicFold m s) where
(<!>) = (<|>)
{-# INLINE (<!>) #-}
instance Plus (ReifiedMonadicFold m s) where
zero = MonadicFold ignored
{-# INLINE zero #-}
newtype ReifiedSetter s t a b = Setter { runSetter :: Setter s t a b }
type ReifiedSetter' s a = ReifiedSetter s s a a
newtype ReifiedIndexedSetter i s t a b =
IndexedSetter { runIndexedSetter :: IndexedSetter i s t a b }
type ReifiedIndexedSetter' i s a = ReifiedIndexedSetter i s s a a
newtype ReifiedIso s t a b = Iso { runIso :: Iso s t a b }
type ReifiedIso' s a = ReifiedIso s s a a
newtype ReifiedPrism s t a b = Prism { runPrism :: Prism s t a b }
type ReifiedPrism' s a = ReifiedPrism s s a a