module Control.Lens.Reified where
import Control.Applicative
import Control.Arrow
import qualified Control.Category as Cat
import Control.Comonad
import Control.Lens.Fold
import Control.Lens.Getter
import Control.Lens.Internal.Indexed
import Control.Lens.Traversal (ignored)
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.Profunctor.Sieve
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)
instance Semigroup s => Extend (ReifiedGetter s) where
duplicated (Getter l) = Getter $ to $ \m -> Getter $ to $ \n -> view l (m <> n)
instance Monoid s => Comonad (ReifiedGetter s) where
extract (Getter l) = view l mempty
duplicate (Getter l) = Getter $ to $ \m -> Getter $ to $ \n -> view l (mappend m n)
instance Monoid s => ComonadApply (ReifiedGetter s) where
Getter mf <@> Getter ma = Getter $ to $ \s -> view mf s (view ma s)
m <@ _ = m
_ @> m = m
instance Apply (ReifiedGetter s) where
Getter mf <.> Getter ma = Getter $ to $ \s -> view mf s (view ma s)
m <. _ = m
_ .> m = m
instance Applicative (ReifiedGetter s) where
pure a = Getter $ to $ \_ -> a
Getter mf <*> Getter ma = Getter $ to $ \s -> view mf s (view ma s)
m <* _ = m
_ *> m = m
instance Bind (ReifiedGetter s) where
Getter ma >>- f = Getter $ to $ \s -> view (runGetter (f (view ma s))) s
instance Monad (ReifiedGetter s) where
return a = Getter $ to $ \_ -> a
Getter ma >>= f = Getter $ to $ \s -> view (runGetter (f (view ma s))) s
instance MonadReader s (ReifiedGetter s) where
ask = Getter id
local f m = Getter (to f . runGetter m)
instance Profunctor ReifiedGetter where
dimap f g l = Getter $ to f.runGetter l.to g
lmap g l = Getter $ to g.runGetter l
rmap f l = Getter $ runGetter l.to f
instance Cosieve ReifiedGetter Identity where
cosieve (Getter l) = view l . runIdentity
instance Corepresentable ReifiedGetter where
type Corep ReifiedGetter = Identity
cotabulate f = Getter $ to (f . Identity)
instance Sieve ReifiedGetter Identity where
sieve (Getter l) = Identity . view l
instance Representable ReifiedGetter where
type Rep ReifiedGetter = Identity
tabulate f = Getter $ to (runIdentity . f)
instance Costrong ReifiedGetter where
unfirst l = Getter $ to $ unfirst $ view (runGetter l)
instance Conjoined ReifiedGetter
instance Strong ReifiedGetter where
first' l = Getter $ \f (s,c) ->
coerce $ runGetter l (dimap (flip (,) c) coerce f) s
second' l = Getter $ \f (c,s) ->
coerce $ runGetter l (dimap ((,) c) coerce f) s
instance Choice ReifiedGetter where
left' l = Getter $ to $ left' $ view $ runGetter l
right' l = Getter $ to $ right' $ view $ runGetter l
instance Cat.Category ReifiedGetter where
id = Getter id
l . r = Getter (runGetter r.runGetter l)
instance Arrow ReifiedGetter where
arr f = Getter (to f)
first l = Getter $ to $ first $ view $ runGetter l
second l = Getter $ to $ second $ view $ runGetter l
Getter l *** Getter r = Getter $ to $ view l *** view r
Getter l &&& Getter r = Getter $ to $ view l &&& view r
instance ArrowApply ReifiedGetter where
app = Getter $ to $ \(Getter bc, b) -> view bc b
instance ArrowChoice ReifiedGetter where
left l = Getter $ to $ left $ view $ runGetter l
right l = Getter $ to $ right $ view $ runGetter l
Getter l +++ Getter r = Getter $ to $ view l +++ view r
Getter l ||| Getter r = Getter $ to $ view l ||| view r
instance ArrowLoop ReifiedGetter where
loop l = Getter $ to $ loop $ view $ runGetter l
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)
instance Sieve (ReifiedIndexedGetter i) ((,) i) where
sieve = iview . runIndexedGetter
instance Representable (ReifiedIndexedGetter i) where
type Rep (ReifiedIndexedGetter i) = (,) i
tabulate f = IndexedGetter $ ito f
instance Strong (ReifiedIndexedGetter i) where
first' l = IndexedGetter $ \f (s,c) ->
coerce $ runIndexedGetter l (dimap (flip (,) c) coerce f) s
second' l = IndexedGetter $ \f (c,s) ->
coerce $ runIndexedGetter l (dimap ((,) c) coerce f) s
instance Functor (ReifiedIndexedGetter i s) where
fmap f l = IndexedGetter (runIndexedGetter l.to f)
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)
newtype ReifiedFold s a = Fold { runFold :: Fold s a }
instance Profunctor ReifiedFold where
dimap f g l = Fold (to f . runFold l . to g)
rmap g l = Fold (runFold l . to g)
lmap f l = Fold (to f . runFold l)
instance Sieve ReifiedFold [] where
sieve = toListOf . runFold
instance Representable ReifiedFold where
type Rep ReifiedFold = []
tabulate f = Fold (folding f)
instance Strong ReifiedFold where
first' l = Fold $ \f (s,c) ->
coerce $ runFold l (dimap (flip (,) c) coerce f) s
second' l = Fold $ \f (c,s) ->
coerce $ runFold l (dimap ((,) c) coerce f) s
instance Choice ReifiedFold where
left' (Fold l) = Fold $ folding $ \esc -> case esc of
Left s -> Left <$> toListOf l s
Right c -> [Right c]
right' (Fold l) = Fold $ folding $ \ecs -> case ecs of
Left c -> [Left c]
Right s -> Right <$> toListOf l s
instance Cat.Category ReifiedFold where
id = Fold id
l . r = Fold (runFold r . runFold l)
instance Arrow ReifiedFold where
arr f = Fold (to f)
first = first'
second = second'
Fold l *** Fold r = Fold $ folding $ \(x,y) -> (,) <$> toListOf l x <*> toListOf r y
Fold l &&& Fold r = Fold $ folding $ \x -> (,) <$> toListOf l x <*> toListOf r x
instance ArrowChoice ReifiedFold where
left = left'
right = right'
instance ArrowApply ReifiedFold where
app = Fold $ folding $ \(Fold bc, b) -> toListOf bc b
instance Functor (ReifiedFold s) where
fmap f l = Fold (runFold l.to f)
instance Apply (ReifiedFold s) where
Fold mf <.> Fold ma = Fold $ folding $ \s -> toListOf mf s <.> toListOf ma s
Fold mf <. Fold ma = Fold $ folding $ \s -> toListOf mf s <. toListOf ma s
Fold mf .> Fold ma = Fold $ folding $ \s -> toListOf mf s .> toListOf ma s
instance Applicative (ReifiedFold s) where
pure a = Fold $ folding $ \_ -> [a]
Fold mf <*> Fold ma = Fold $ folding $ \s -> toListOf mf s <*> toListOf ma s
Fold mf <* Fold ma = Fold $ folding $ \s -> toListOf mf s <* toListOf ma s
Fold mf *> Fold ma = Fold $ folding $ \s -> toListOf mf s *> toListOf ma s
instance Alternative (ReifiedFold s) where
empty = Fold ignored
Fold ma <|> Fold mb = Fold $ folding (\s -> toListOf ma s ++ toListOf mb s)
instance Bind (ReifiedFold s) where
Fold ma >>- f = Fold $ folding $ \s -> toListOf ma s >>- \a -> toListOf (runFold (f a)) s
instance Monad (ReifiedFold s) where
return a = Fold $ folding $ \_ -> [a]
Fold ma >>= f = Fold $ folding $ \s -> toListOf ma s >>= \a -> toListOf (runFold (f a)) s
instance MonadPlus (ReifiedFold s) where
mzero = empty
mplus = (<|>)
instance MonadReader s (ReifiedFold s) where
ask = Fold id
local f m = Fold (to f . runFold m)
instance Semigroup (ReifiedFold s a) where
(<>) = (<|>)
instance Monoid (ReifiedFold s a) where
mempty = Fold ignored
mappend = (<|>)
instance Alt (ReifiedFold s) where
(<!>) = (<|>)
instance Plus (ReifiedFold s) where
zero = Fold ignored
newtype ReifiedIndexedFold i s a = IndexedFold { runIndexedFold :: IndexedFold i s a }
instance Semigroup (ReifiedIndexedFold i s a) where
(<>) = (<!>)
instance Monoid (ReifiedIndexedFold i s a) where
mempty = IndexedFold ignored
mappend = (<!>)
instance Alt (ReifiedIndexedFold i s) where
IndexedFold ma <!> IndexedFold mb = IndexedFold $
ifolding $ \s -> itoListOf ma s ++ itoListOf mb s
instance Plus (ReifiedIndexedFold i s) where
zero = IndexedFold ignored
instance Functor (ReifiedIndexedFold i s) where
fmap f l = IndexedFold (runIndexedFold l . to f)
instance Profunctor (ReifiedIndexedFold i) where
dimap f g l = IndexedFold (to f . runIndexedFold l . to g)
lmap f l = IndexedFold (to f . runIndexedFold l)
rmap g l = IndexedFold (runIndexedFold l . to g)
instance Sieve (ReifiedIndexedFold i) (Compose [] ((,) i)) where
sieve (IndexedFold l) = Compose . itoListOf l
instance Representable (ReifiedIndexedFold i) where
type Rep (ReifiedIndexedFold i) = Compose [] ((,) i)
tabulate k = IndexedFold $ \f -> coerce . traverse_ (coerce . uncurry (indexed f)) . getCompose . k
instance Strong (ReifiedIndexedFold i) where
first' l = IndexedFold $ \f (s,c) ->
coerce $ runIndexedFold l (dimap (flip (,) c) coerce f) s
second' l = IndexedFold $ \f (c,s) ->
coerce $ runIndexedFold l (dimap ((,) c) coerce f) s
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