indexed-profunctors (empty) → 0.1

raw patch · 4 files changed

+1030/−0 lines, 4 filesdep +basesetup-changed

Dependencies added: base

Files

LICENSE +131/−0
Setup.hs +4/−0
indexed-profunctors.cabal +30/−0
src/Data/Profunctor/Indexed.hs +865/−0

+ LICENSE view

@@ -0,0 +1,131 @@+Copyright (c) 2017-2019, Well-Typed LLP++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * Redistributions in binary form must reproduce the above+      copyright notice, this list of conditions and the following+      disclaimer in the documentation and/or other materials provided+      with the distribution.++    * Neither the name of Well-Typed LLP nor the names of other+      contributors may be used to endorse or promote products derived+      from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.+++This software incorporates code from the lens package (available from+https://hackage.haskell.org/package/lens) under the following license:++Copyright 2012-2016 Edward Kmett++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions+are met:++1. Redistributions of source code must retain the above copyright+   notice, this list of conditions and the following disclaimer.++2. Redistributions in binary form must reproduce the above copyright+   notice, this list of conditions and the following disclaimer in the+   documentation and/or other materials provided with the distribution.++THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND ANY EXPRESS OR+IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED+WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE+DISCLAIMED.  IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR+ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL+DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS+OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)+HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,+STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN+ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE+POSSIBILITY OF SUCH DAMAGE.+++This software incorporates code from the profunctors package (available from+https://hackage.haskell.org/package/profunctors) under the following license:++Copyright 2011-2015 Edward Kmett++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions+are met:++1. Redistributions of source code must retain the above copyright+   notice, this list of conditions and the following disclaimer.++2. Redistributions in binary form must reproduce the above copyright+   notice, this list of conditions and the following disclaimer in the+   documentation and/or other materials provided with the distribution.++3. Neither the name of the author nor the names of his contributors+   may be used to endorse or promote products derived from this software+   without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND ANY EXPRESS OR+IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED+WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE+DISCLAIMED.  IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR+ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL+DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS+OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)+HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,+STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN+ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE+POSSIBILITY OF SUCH DAMAGE.+++This software incorporates code from the tagged package (available from+https://hackage.haskell.org/package/tagged) under the following license:++Copyright (c) 2009-2015 Edward Kmett+All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are+met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * Redistributions in binary form must reproduce the above+      copyright notice, this list of conditions and the following+      disclaimer in the documentation and/or other materials provided+      with the distribution.++    * Neither the name of Edward Kmett nor the names of other+      contributors may be used to endorse or promote products derived+      from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

+ Setup.hs view

@@ -0,0 +1,4 @@+import Distribution.Simple++main :: IO ()+main = defaultMain

+ indexed-profunctors.cabal view

@@ -0,0 +1,30 @@+name:          indexed-profunctors+version:       0.1+license:       BSD3+license-file:  LICENSE+build-type:    Simple+cabal-version: 1.24+maintainer:    optics@well-typed.com+author:        Adam Gundry, Andres Löh, Andrzej Rybczak, Oleg Grenrus+tested-with:   GHC ==8.0.2 || ==8.2.2 || ==8.4.4 || ==8.6.5 || ==8.8.1, GHCJS ==8.4+synopsis:      Utilities for indexed profunctors+category:      Data, Optics, Lenses, Profunctors+description:+  This package contains basic definitions related to indexed profunctors.  These+  are primarily intended as internal utilities to support the @optics@ and+  @generic-lens@ package families.++bug-reports:   https://github.com/well-typed/optics/issues+source-repository head+  type:     git+  location: https://github.com/well-typed/optics.git+  subdir:   indexed-profunctors++library+  default-language: Haskell2010+  hs-source-dirs:   src+  ghc-options:      -Wall++  build-depends: base                   >= 4.9        && <5++  exposed-modules:    Data.Profunctor.Indexed

+ src/Data/Profunctor/Indexed.hs view

@@ -0,0 +1,865 @@+{-# LANGUAGE DefaultSignatures #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TupleSections #-}+{-# OPTIONS_HADDOCK not-home #-}++-- | Definitions of concrete profunctors and profunctor classes.+module Data.Profunctor.Indexed+  (+    -- * Profunctor classes+    Profunctor(..)+  , lcoerce+  , rcoerce+  , Strong(..)+  , Costrong(..)+  , Choice(..)+  , Cochoice(..)+  , Visiting(..)+  , Mapping(..)+  , Traversing(..)++    -- * Concrete profunctors+  , Star(..)+  , reStar++  , Forget(..)+  , reForget++  , ForgetM(..)++  , FunArrow(..)+  , reFunArrow++  , IxStar(..)++  , IxForget(..)++  , IxForgetM(..)++  , IxFunArrow(..)++  , StarA(..)+  , runStarA++  , IxStarA(..)+  , runIxStarA++  , Exchange(..)+  , Store(..)+  , Market(..)+  , AffineMarket(..)+  , Tagged(..)+  , Context(..)++   -- * Utilities+  , (#.)+  , (.#)+  ) where++import Data.Coerce (Coercible, coerce)+import Data.Functor.Const+import Data.Functor.Identity++----------------------------------------+-- Concrete profunctors++-- | Needed for traversals.+newtype Star f i a b = Star { runStar :: a -> f b }++-- | Needed for getters and folds.+newtype Forget r i a b = Forget { runForget :: a -> r }++-- | Needed for affine folds.+newtype ForgetM r i a b = ForgetM { runForgetM :: a -> Maybe r }++-- | Needed for setters.+newtype FunArrow i a b = FunArrow { runFunArrow :: a -> b }++-- | Needed for indexed traversals.+newtype IxStar f i a b = IxStar { runIxStar :: i -> a -> f b }++-- | Needed for indexed folds.+newtype IxForget r i a b = IxForget { runIxForget :: i -> a -> r }++-- | Needed for indexed affine folds.+newtype IxForgetM r i a b = IxForgetM { runIxForgetM :: i -> a -> Maybe r }++-- | Needed for indexed setters.+newtype IxFunArrow i a b = IxFunArrow { runIxFunArrow :: i -> a -> b }++----------------------------------------+-- Utils++-- | Needed for conversion of affine traversal back to its VL representation.+data StarA f i a b = StarA (forall r. r -> f r) (a -> f b)++-- | Unwrap 'StarA'.+runStarA :: StarA f i a b -> a -> f b+runStarA (StarA _ k) = k+{-# INLINE runStarA #-}++-- | Needed for conversion of indexed affine traversal back to its VL+-- representation.+data IxStarA f i a b = IxStarA (forall r. r -> f r) (i -> a -> f b)++-- | Unwrap 'StarA'.+runIxStarA :: IxStarA f i a b -> i -> a -> f b+runIxStarA (IxStarA _ k) = k+{-# INLINE runIxStarA #-}++----------------------------------------++-- | Repack 'Star' to change its index type.+reStar :: Star f i a b -> Star f j a b+reStar (Star k) = Star k+{-# INLINE reStar #-}++-- | Repack 'Forget' to change its index type.+reForget :: Forget r i a b -> Forget r j a b+reForget (Forget k) = Forget k+{-# INLINE reForget #-}++-- | Repack 'FunArrow' to change its index type.+reFunArrow :: FunArrow i a b -> FunArrow j a b+reFunArrow (FunArrow k) = FunArrow k+{-# INLINE reFunArrow #-}++----------------------------------------+-- Classes and instances++class Profunctor p where+  dimap :: (a -> b) -> (c -> d) -> p i b c -> p i a d+  lmap  :: (a -> b)             -> p i b c -> p i a c+  rmap  ::             (c -> d) -> p i b c -> p i b d++  lcoerce' :: Coercible a b => p i a c -> p i b c+  default lcoerce'+    :: Coercible (p i a c) (p i b c)+    => p i a c+    -> p i b c+  lcoerce' = coerce+  {-# INLINE lcoerce' #-}++  rcoerce' :: Coercible a b => p i c a -> p i c b+  default rcoerce'+    :: Coercible (p i c a) (p i c b)+    => p i c a+    -> p i c b+  rcoerce' = coerce+  {-# INLINE rcoerce' #-}++  conjoined__+    :: (p i a b -> p i s t)+    -> (p i a b -> p j s t)+    -> (p i a b -> p j s t)+  default conjoined__+    :: Coercible (p i s t) (p j s t)+    => (p i a b -> p i s t)+    -> (p i a b -> p j s t)+    -> (p i a b -> p j s t)+  conjoined__ f _ = coerce . f+  {-# INLINE conjoined__ #-}++  ixcontramap :: (j -> i) -> p i a b -> p j a b+  default ixcontramap+    :: Coercible (p i a b) (p j a b)+    => (j -> i)+    -> p i a b+    -> p j a b+  ixcontramap _ = coerce+  {-# INLINE ixcontramap #-}++-- | 'rcoerce'' with type arguments rearranged for TypeApplications.+rcoerce :: (Coercible a b, Profunctor p) => p i c a -> p i c b+rcoerce = rcoerce'+{-# INLINE rcoerce #-}++-- | 'lcoerce'' with type arguments rearranged for TypeApplications.+lcoerce :: (Coercible a b, Profunctor p) => p i a c -> p i b c+lcoerce = lcoerce'+{-# INLINE lcoerce #-}++instance Functor f => Profunctor (StarA f) where+  dimap f g (StarA point k) = StarA point (fmap g . k . f)+  lmap  f   (StarA point k) = StarA point (k . f)+  rmap    g (StarA point k) = StarA point (fmap g . k)+  {-# INLINE dimap #-}+  {-# INLINE lmap #-}+  {-# INLINE rmap #-}++  rcoerce' = rmap coerce+  {-# INLINE rcoerce' #-}++instance Functor f => Profunctor (Star f) where+  dimap f g (Star k) = Star (fmap g . k . f)+  lmap  f   (Star k) = Star (k . f)+  rmap    g (Star k) = Star (fmap g . k)+  {-# INLINE dimap #-}+  {-# INLINE lmap #-}+  {-# INLINE rmap #-}++  rcoerce' = rmap coerce+  {-# INLINE rcoerce' #-}++instance Profunctor (Forget r) where+  dimap f _ (Forget k) = Forget (k . f)+  lmap  f   (Forget k) = Forget (k . f)+  rmap   _g (Forget k) = Forget k+  {-# INLINE dimap #-}+  {-# INLINE lmap #-}+  {-# INLINE rmap #-}++instance Profunctor (ForgetM r) where+  dimap f _ (ForgetM k) = ForgetM (k . f)+  lmap  f   (ForgetM k) = ForgetM (k . f)+  rmap   _g (ForgetM k) = ForgetM k+  {-# INLINE dimap #-}+  {-# INLINE lmap #-}+  {-# INLINE rmap #-}++instance Profunctor FunArrow where+  dimap f g (FunArrow k) = FunArrow (g . k . f)+  lmap  f   (FunArrow k) = FunArrow (k . f)+  rmap    g (FunArrow k) = FunArrow (g . k)+  {-# INLINE dimap #-}+  {-# INLINE lmap #-}+  {-# INLINE rmap #-}++instance Functor f => Profunctor (IxStarA f) where+  dimap f g (IxStarA point k) = IxStarA point (\i -> fmap g . k i . f)+  lmap  f   (IxStarA point k) = IxStarA point (\i -> k i . f)+  rmap    g (IxStarA point k) = IxStarA point (\i -> fmap g . k i)+  {-# INLINE dimap #-}+  {-# INLINE lmap #-}+  {-# INLINE rmap #-}++  rcoerce' = rmap coerce+  {-# INLINE rcoerce' #-}++  conjoined__ _ f = f+  ixcontramap ij (IxStarA point k) = IxStarA point $ \i -> k (ij i)+  {-# INLINE conjoined__ #-}+  {-# INLINE ixcontramap #-}++instance Functor f => Profunctor (IxStar f) where+  dimap f g (IxStar k) = IxStar (\i -> fmap g . k i . f)+  lmap  f   (IxStar k) = IxStar (\i -> k i . f)+  rmap    g (IxStar k) = IxStar (\i -> fmap g . k i)+  {-# INLINE dimap #-}+  {-# INLINE lmap #-}+  {-# INLINE rmap #-}++  rcoerce' = rmap coerce+  {-# INLINE rcoerce' #-}++  conjoined__ _ f = f+  ixcontramap ij (IxStar k) = IxStar $ \i -> k (ij i)+  {-# INLINE conjoined__ #-}+  {-# INLINE ixcontramap #-}++instance Profunctor (IxForget r) where+  dimap f _ (IxForget k) = IxForget (\i -> k i . f)+  lmap  f   (IxForget k) = IxForget (\i -> k i . f)+  rmap   _g (IxForget k) = IxForget k+  {-# INLINE dimap #-}+  {-# INLINE lmap #-}+  {-# INLINE rmap #-}++  conjoined__ _ f = f+  ixcontramap ij (IxForget k) = IxForget $ \i -> k (ij i)+  {-# INLINE conjoined__ #-}+  {-# INLINE ixcontramap #-}++instance Profunctor (IxForgetM r) where+  dimap f _ (IxForgetM k) = IxForgetM (\i -> k i . f)+  lmap  f   (IxForgetM k) = IxForgetM (\i -> k i . f)+  rmap   _g (IxForgetM k) = IxForgetM k+  {-# INLINE dimap #-}+  {-# INLINE lmap #-}+  {-# INLINE rmap #-}++  conjoined__ _ f = f+  ixcontramap ij (IxForgetM k) = IxForgetM $ \i -> k (ij i)+  {-# INLINE conjoined__ #-}+  {-# INLINE ixcontramap #-}++instance Profunctor IxFunArrow where+  dimap f g (IxFunArrow k) = IxFunArrow (\i -> g . k i . f)+  lmap  f   (IxFunArrow k) = IxFunArrow (\i -> k i . f)+  rmap    g (IxFunArrow k) = IxFunArrow (\i -> g . k i)+  {-# INLINE dimap #-}+  {-# INLINE lmap #-}+  {-# INLINE rmap #-}++  conjoined__ _ f = f+  ixcontramap ij (IxFunArrow k) = IxFunArrow $ \i -> k (ij i)+  {-# INLINE conjoined__ #-}+  {-# INLINE ixcontramap #-}++----------------------------------------++class Profunctor p => Strong p where+  first'  :: p i a b -> p i (a, c) (b, c)+  second' :: p i a b -> p i (c, a) (c, b)++  -- There are a few places where default implementation is good enough.+  linear+    :: (forall f. Functor f => (a -> f b) -> s -> f t)+    -> p i a b+    -> p i s t+  linear f = dimap+    ((\(Context bt a) -> (a, bt)) . f (Context id))+    (\(b, bt) -> bt b)+    . first'+  {-# INLINE linear #-}++  -- There are a few places where default implementation is good enough.+  ilinear+    :: (forall f. Functor f => (i -> a -> f b) -> s -> f t)+    -> p       j  a b+    -> p (i -> j) s t+  default ilinear+    :: Coercible (p j s t) (p (i -> j) s t)+    => (forall f. Functor f => (i -> a -> f b) -> s -> f t)+    -> p       j  a b+    -> p (i -> j) s t+  ilinear f = coerce . linear (\afb -> f $ \_ -> afb)+  {-# INLINE ilinear #-}++instance Functor f => Strong (StarA f) where+  first'  (StarA point k) = StarA point $ \ ~(a, c) -> (\b' -> (b', c)) <$> k a+  second' (StarA point k) = StarA point $ \ ~(c, a) -> (,) c <$> k a+  {-# INLINE first' #-}+  {-# INLINE second' #-}++  linear f (StarA point k) = StarA point (f k)+  {-# INLINE linear #-}++instance Functor f => Strong (Star f) where+  first'  (Star k) = Star $ \ ~(a, c) -> (\b' -> (b', c)) <$> k a+  second' (Star k) = Star $ \ ~(c, a) -> (,) c <$> k a+  {-# INLINE first' #-}+  {-# INLINE second' #-}++  linear f (Star k) = Star (f k)+  {-# INLINE linear #-}++instance Strong (Forget r) where+  first'  (Forget k) = Forget (k . fst)+  second' (Forget k) = Forget (k . snd)+  {-# INLINE first' #-}+  {-# INLINE second' #-}++  linear f (Forget k) = Forget (getConst #. f (Const #. k))+  {-# INLINE linear #-}++instance Strong (ForgetM r) where+  first'  (ForgetM k) = ForgetM (k . fst)+  second' (ForgetM k) = ForgetM (k . snd)+  {-# INLINE first' #-}+  {-# INLINE second' #-}++  linear f (ForgetM k) = ForgetM (getConst #. f (Const #. k))+  {-# INLINE linear #-}++instance Strong FunArrow where+  first'  (FunArrow k) = FunArrow $ \ ~(a, c) -> (k a, c)+  second' (FunArrow k) = FunArrow $ \ ~(c, a) -> (c, k a)+  {-# INLINE first' #-}+  {-# INLINE second' #-}++  linear f (FunArrow k) = FunArrow $ runIdentity #. f (Identity #. k)+  {-# INLINE linear #-}++instance Functor f => Strong (IxStarA f) where+  first'  (IxStarA point k) = IxStarA point $ \i ~(a, c) -> (\b' -> (b', c)) <$> k i a+  second' (IxStarA point k) = IxStarA point $ \i ~(c, a) -> (,) c <$> k i a+  {-# INLINE first' #-}+  {-# INLINE second' #-}++  linear f (IxStarA point k) = IxStarA point $ \i -> f (k i)+  ilinear f (IxStarA point k) = IxStarA point $ \ij -> f $ \i -> k (ij i)+  {-# INLINE linear #-}+  {-# INLINE ilinear #-}++instance Functor f => Strong (IxStar f) where+  first'  (IxStar k) = IxStar $ \i ~(a, c) -> (\b' -> (b', c)) <$> k i a+  second' (IxStar k) = IxStar $ \i ~(c, a) -> (,) c <$> k i a+  {-# INLINE first' #-}+  {-# INLINE second' #-}++  linear f (IxStar k) = IxStar $ \i -> f (k i)+  ilinear f (IxStar k) = IxStar $ \ij -> f $ \i -> k (ij i)+  {-# INLINE linear #-}+  {-# INLINE ilinear #-}++instance Strong (IxForget r) where+  first'  (IxForget k) = IxForget $ \i -> k i . fst+  second' (IxForget k) = IxForget $ \i -> k i . snd+  {-# INLINE first' #-}+  {-# INLINE second' #-}++  linear f (IxForget k) = IxForget $ \i -> getConst #. f (Const #. k i)+  ilinear f (IxForget k) = IxForget $ \ij -> getConst #. f (\i -> Const #. k (ij i))+  {-# INLINE linear #-}+  {-# INLINE ilinear #-}++instance Strong (IxForgetM r) where+  first'  (IxForgetM k) = IxForgetM $ \i -> k i . fst+  second' (IxForgetM k) = IxForgetM $ \i -> k i . snd+  {-# INLINE first' #-}+  {-# INLINE second' #-}++  linear f (IxForgetM k) = IxForgetM $ \i -> getConst #. f (Const #. k i)+  ilinear f (IxForgetM k) = IxForgetM $ \ij -> getConst #. f (\i -> Const #. k (ij i))+  {-# INLINE linear #-}+  {-# INLINE ilinear #-}++instance Strong IxFunArrow where+  first'  (IxFunArrow k) = IxFunArrow $ \i ~(a, c) -> (k i a, c)+  second' (IxFunArrow k) = IxFunArrow $ \i ~(c, a) -> (c, k i a)+  {-# INLINE first' #-}+  {-# INLINE second' #-}++  linear f (IxFunArrow k) = IxFunArrow $ \i ->+    runIdentity #. f (Identity #. k i)+  ilinear f (IxFunArrow k) = IxFunArrow $ \ij ->+    runIdentity #. f (\i -> Identity #. k (ij i))+  {-# INLINE linear #-}+  {-# INLINE ilinear #-}++----------------------------------------++class Profunctor p => Costrong p where+  unfirst  :: p i (a, d) (b, d) -> p i a b+  unsecond :: p i (d, a) (d, b) -> p i a b++----------------------------------------++class Profunctor p => Choice p where+  left'  :: p i a b -> p i (Either a c) (Either b c)+  right' :: p i a b -> p i (Either c a) (Either c b)++instance Functor f => Choice (StarA f) where+  left'  (StarA point k) = StarA point $ either (fmap Left . k) (point . Right)+  right' (StarA point k) = StarA point $ either (point . Left) (fmap Right . k)+  {-# INLINE left' #-}+  {-# INLINE right' #-}++instance Applicative f => Choice (Star f) where+  left'  (Star k) = Star $ either (fmap Left . k) (pure . Right)+  right' (Star k) = Star $ either (pure . Left) (fmap Right . k)+  {-# INLINE left' #-}+  {-# INLINE right' #-}++instance Monoid r => Choice (Forget r) where+  left'  (Forget k) = Forget $ either k (const mempty)+  right' (Forget k) = Forget $ either (const mempty) k+  {-# INLINE left' #-}+  {-# INLINE right' #-}++instance Choice (ForgetM r) where+  left'  (ForgetM k) = ForgetM $ either k (const Nothing)+  right' (ForgetM k) = ForgetM $ either (const Nothing) k+  {-# INLINE left' #-}+  {-# INLINE right' #-}++instance Choice FunArrow where+  left'  (FunArrow k) = FunArrow $ either (Left . k) Right+  right' (FunArrow k) = FunArrow $ either Left (Right . k)+  {-# INLINE left' #-}+  {-# INLINE right' #-}++instance Functor f => Choice (IxStarA f) where+  left'  (IxStarA point k) =+    IxStarA point $ \i -> either (fmap Left . k i) (point . Right)+  right' (IxStarA point k) =+    IxStarA point $ \i -> either (point . Left) (fmap Right . k i)+  {-# INLINE left' #-}+  {-# INLINE right' #-}++instance Applicative f => Choice (IxStar f) where+  left'  (IxStar k) = IxStar $ \i -> either (fmap Left . k i) (pure . Right)+  right' (IxStar k) = IxStar $ \i -> either (pure . Left) (fmap Right . k i)+  {-# INLINE left' #-}+  {-# INLINE right' #-}++instance Monoid r => Choice (IxForget r) where+  left'  (IxForget k) = IxForget $ \i -> either (k i) (const mempty)+  right' (IxForget k) = IxForget $ \i -> either (const mempty) (k i)+  {-# INLINE left' #-}+  {-# INLINE right' #-}++instance Choice (IxForgetM r) where+  left'  (IxForgetM k) = IxForgetM $ \i -> either (k i) (const Nothing)+  right' (IxForgetM k) = IxForgetM $ \i -> either (const Nothing) (k i)+  {-# INLINE left' #-}+  {-# INLINE right' #-}++instance Choice IxFunArrow where+  left'  (IxFunArrow k) = IxFunArrow $ \i -> either (Left . k i) Right+  right' (IxFunArrow k) = IxFunArrow $ \i -> either Left (Right . k i)+  {-# INLINE left' #-}+  {-# INLINE right' #-}++----------------------------------------++class Profunctor p => Cochoice p where+  unleft  :: p i (Either a d) (Either b d) -> p i a b+  unright :: p i (Either d a) (Either d b) -> p i a b++instance Cochoice (Forget r) where+  unleft  (Forget k) = Forget (k . Left)+  unright (Forget k) = Forget (k . Right)+  {-# INLINE unleft #-}+  {-# INLINE unright #-}++instance Cochoice (ForgetM r) where+  unleft  (ForgetM k) = ForgetM (k . Left)+  unright (ForgetM k) = ForgetM (k . Right)+  {-# INLINE unleft #-}+  {-# INLINE unright #-}++instance Cochoice (IxForget r) where+  unleft  (IxForget k) = IxForget $ \i -> k i . Left+  unright (IxForget k) = IxForget $ \i -> k i . Right+  {-# INLINE unleft #-}+  {-# INLINE unright #-}++instance Cochoice (IxForgetM r) where+  unleft  (IxForgetM k) = IxForgetM (\i -> k i . Left)+  unright (IxForgetM k) = IxForgetM (\i -> k i . Right)+  {-# INLINE unleft #-}+  {-# INLINE unright #-}++----------------------------------------++class (Choice p, Strong p) => Visiting p where+  visit+    :: forall i s t a b+    . (forall f. Functor f => (forall r. r -> f r) -> (a -> f b) -> s -> f t)+    -> p i a b+    -> p i s t+  visit f =+    let match :: s -> Either a t+        match s = f Right Left s+        update :: s -> b -> t+        update s b = runIdentity $ f Identity (\_ -> Identity b) s+    in dimap (\s -> (match s, s))+             (\(ebt, s) -> either (update s) id ebt)+       . first'+       . left'+  {-# INLINE visit #-}++  ivisit+    :: (forall f. Functor f => (forall r. r -> f r) -> (i -> a -> f b) -> s -> f t)+    -> p       j  a b+    -> p (i -> j) s t+  default ivisit+    :: Coercible (p j s t) (p (i -> j) s t)+    => (forall f. Functor f => (forall r. r -> f r) -> (i -> a -> f b) -> s -> f t)+    -> p       j  a b+    -> p (i -> j) s t+  ivisit f = coerce . visit (\point afb -> f point $ \_ -> afb)+  {-# INLINE ivisit #-}+++instance Functor f => Visiting (StarA f) where+  visit  f (StarA point k) = StarA point $ f point k+  ivisit f (StarA point k) = StarA point $ f point (\_ -> k)+  {-# INLINE visit #-}+  {-# INLINE ivisit #-}++instance Applicative f => Visiting (Star f) where+  visit  f (Star k) = Star $ f pure k+  ivisit f (Star k) = Star $ f pure (\_ -> k)+  {-# INLINE visit #-}+  {-# INLINE ivisit #-}++instance Monoid r => Visiting (Forget r) where+  visit  f (Forget k) = Forget $ getConst #. f pure (Const #. k)+  ivisit f (Forget k) = Forget $ getConst #. f pure (\_ -> Const #. k)+  {-# INLINE visit #-}+  {-# INLINE ivisit #-}++instance Visiting (ForgetM r) where+  visit  f (ForgetM k) =+    ForgetM $ getConst #. f (\_ -> Const Nothing) (Const #. k)+  ivisit f (ForgetM k) =+    ForgetM $ getConst #. f (\_ -> Const Nothing) (\_ -> Const #. k)+  {-# INLINE visit #-}+  {-# INLINE ivisit #-}++instance Visiting FunArrow where+  visit  f (FunArrow k) = FunArrow $ runIdentity #. f pure (Identity #. k)+  ivisit f (FunArrow k) = FunArrow $ runIdentity #. f pure (\_ -> Identity #. k)+  {-# INLINE visit #-}+  {-# INLINE ivisit #-}++instance Functor f => Visiting (IxStarA f) where+  visit  f (IxStarA point k) = IxStarA point $ \i  -> f point (k i)+  ivisit f (IxStarA point k) = IxStarA point $ \ij -> f point $ \i -> k (ij i)+  {-# INLINE visit #-}+  {-# INLINE ivisit #-}++instance Applicative f => Visiting (IxStar f) where+  visit  f (IxStar k) = IxStar $ \i  -> f pure (k i)+  ivisit f (IxStar k) = IxStar $ \ij -> f pure $ \i -> k (ij i)+  {-# INLINE visit #-}+  {-# INLINE ivisit #-}++instance Monoid r => Visiting (IxForget r) where+  visit  f (IxForget k) =+    IxForget $ \i  -> getConst #. f pure (Const #. k i)+  ivisit f (IxForget k) =+    IxForget $ \ij -> getConst #. f pure (\i -> Const #. k (ij i))+  {-# INLINE visit #-}+  {-# INLINE ivisit #-}++instance Visiting (IxForgetM r) where+  visit  f (IxForgetM k) =+    IxForgetM $ \i  -> getConst #. f (\_ -> Const Nothing) (Const #. k i)+  ivisit f (IxForgetM k) =+    IxForgetM $ \ij -> getConst #. f (\_ -> Const Nothing) (\i -> Const #. k (ij i))+  {-# INLINE visit #-}+  {-# INLINE ivisit #-}++instance Visiting IxFunArrow where+  visit  f (IxFunArrow k) =+    IxFunArrow $ \i  -> runIdentity #. f pure (Identity #. k i)+  ivisit f (IxFunArrow k) =+    IxFunArrow $ \ij -> runIdentity #. f pure (\i -> Identity #. k (ij i))+  {-# INLINE visit #-}+  {-# INLINE ivisit #-}++----------------------------------------++class Visiting p => Traversing p where+  wander+    :: (forall f. Applicative f => (a -> f b) -> s -> f t)+    -> p i a b+    -> p i s t+  iwander+    :: (forall f. Applicative f => (i -> a -> f b) -> s -> f t)+    -> p       j  a b+    -> p (i -> j) s t++instance Applicative f => Traversing (Star f) where+  wander  f (Star k) = Star $ f k+  iwander f (Star k) = Star $ f (\_ -> k)+  {-# INLINE wander #-}+  {-# INLINE iwander #-}++instance Monoid r => Traversing (Forget r) where+  wander  f (Forget k) = Forget $ getConst #. f (Const #. k)+  iwander f (Forget k) = Forget $ getConst #. f (\_ -> Const #. k)+  {-# INLINE wander #-}+  {-# INLINE iwander #-}++instance Traversing FunArrow where+  wander  f (FunArrow k) = FunArrow $ runIdentity #. f (Identity #. k)+  iwander f (FunArrow k) = FunArrow $ runIdentity #. f (\_ -> Identity #. k)+  {-# INLINE wander #-}+  {-# INLINE iwander #-}++instance Applicative f => Traversing (IxStar f) where+  wander  f (IxStar k) = IxStar $ \i -> f (k i)+  iwander f (IxStar k) = IxStar $ \ij -> f $ \i -> k (ij i)+  {-# INLINE wander #-}+  {-# INLINE iwander #-}++instance Monoid r => Traversing (IxForget r) where+  wander  f (IxForget k) =+    IxForget $ \i -> getConst #. f (Const #. k i)+  iwander f (IxForget k) =+    IxForget $ \ij -> getConst #. f (\i -> Const #. k (ij i))+  {-# INLINE wander #-}+  {-# INLINE iwander #-}++instance Traversing IxFunArrow where+  wander  f (IxFunArrow k) =+    IxFunArrow $ \i -> runIdentity #. f (Identity #. k i)+  iwander f (IxFunArrow k) =+    IxFunArrow $ \ij -> runIdentity #. f (\i -> Identity #. k (ij i))+  {-# INLINE wander #-}+  {-# INLINE iwander #-}++----------------------------------------++class Traversing p => Mapping p where+  roam+    :: ((a -> b) -> s -> t)+    -> p i a b+    -> p i s t+  iroam+    :: ((i -> a -> b) -> s -> t)+    -> p       j  a b+    -> p (i -> j) s t++instance Mapping FunArrow where+  roam  f (FunArrow k) = FunArrow $ f k+  iroam f (FunArrow k) = FunArrow $ f (const k)+  {-# INLINE roam #-}+  {-# INLINE iroam #-}++instance Mapping IxFunArrow where+  roam  f (IxFunArrow k) = IxFunArrow $ \i -> f (k i)+  iroam f (IxFunArrow k) = IxFunArrow $ \ij -> f $ \i -> k (ij i)+  {-# INLINE roam #-}+  {-# INLINE iroam #-}+++  -- | Type to represent the components of an isomorphism.+data Exchange a b i s t =+  Exchange (s -> a) (b -> t)++instance Profunctor (Exchange a b) where+  dimap ss tt (Exchange sa bt) = Exchange (sa . ss) (tt . bt)+  lmap  ss    (Exchange sa bt) = Exchange (sa . ss) bt+  rmap     tt (Exchange sa bt) = Exchange sa        (tt . bt)+  {-# INLINE dimap #-}+  {-# INLINE lmap #-}+  {-# INLINE rmap #-}++-- | Type to represent the components of a lens.+data Store a b i s t = Store (s -> a) (s -> b -> t)++instance Profunctor (Store a b) where+  dimap f g (Store get set) = Store (get . f) (\s -> g . set (f s))+  lmap  f   (Store get set) = Store (get . f) (\s -> set (f s))+  rmap    g (Store get set) = Store get       (\s -> g . set s)+  {-# INLINE dimap #-}+  {-# INLINE lmap #-}+  {-# INLINE rmap #-}++instance Strong (Store a b) where+  first' (Store get set) = Store (get . fst) (\(s, c) b -> (set s b, c))+  second' (Store get set) = Store (get . snd) (\(c, s) b -> (c, set s b))+  {-# INLINE first' #-}+  {-# INLINE second' #-}++-- | Type to represent the components of a prism.+data Market a b i s t = Market (b -> t) (s -> Either t a)++instance Functor (Market a b i s) where+  fmap f (Market bt seta) = Market (f . bt) (either (Left . f) Right . seta)+  {-# INLINE fmap #-}++instance Profunctor (Market a b) where+  dimap f g (Market bt seta) = Market (g . bt) (either (Left . g) Right . seta . f)+  lmap  f   (Market bt seta) = Market bt (seta . f)+  rmap    g (Market bt seta) = Market (g . bt) (either (Left . g) Right . seta)+  {-# INLINE dimap #-}+  {-# INLINE lmap #-}+  {-# INLINE rmap #-}++instance Choice (Market a b) where+  left' (Market bt seta) = Market (Left . bt) $ \sc -> case sc of+    Left s -> case seta s of+      Left t -> Left (Left t)+      Right a -> Right a+    Right c -> Left (Right c)+  right' (Market bt seta) = Market (Right . bt) $ \cs -> case cs of+    Left c -> Left (Left c)+    Right s -> case seta s of+      Left t -> Left (Right t)+      Right a -> Right a+  {-# INLINE left' #-}+  {-# INLINE right' #-}++-- | Type to represent the components of an affine traversal.+data AffineMarket a b i s t = AffineMarket (s -> b -> t) (s -> Either t a)++instance Profunctor (AffineMarket a b) where+  dimap f g (AffineMarket sbt seta) = AffineMarket+    (\s b -> g (sbt (f s) b))+    (either (Left . g) Right . seta . f)+  lmap f (AffineMarket sbt seta) = AffineMarket+    (\s b -> sbt (f s) b)+    (seta . f)+  rmap g (AffineMarket sbt seta) = AffineMarket+    (\s b -> g (sbt s b))+    (either (Left . g) Right . seta)+  {-# INLINE dimap #-}+  {-# INLINE lmap #-}+  {-# INLINE rmap #-}++instance Choice (AffineMarket a b) where+  left' (AffineMarket sbt seta) = AffineMarket+    (\e b -> bimap (flip sbt b) id e)+    (\sc -> case sc of+      Left s -> bimap Left id (seta s)+      Right c -> Left (Right c))+  right' (AffineMarket sbt seta) = AffineMarket+    (\e b -> bimap id (flip sbt b) e)+    (\sc -> case sc of+      Left c -> Left (Left c)+      Right s -> bimap Right id (seta s))+  {-# INLINE left' #-}+  {-# INLINE right' #-}++instance Strong (AffineMarket a b) where+  first' (AffineMarket sbt seta) = AffineMarket+    (\(a, c) b -> (sbt a b, c))+    (\(a, c) -> bimap (,c) id (seta a))+  second' (AffineMarket sbt seta) = AffineMarket+    (\(c, a) b -> (c, sbt a b))+    (\(c, a) -> bimap (c,) id (seta a))+  {-# INLINE first' #-}+  {-# INLINE second' #-}++bimap :: (a -> b) -> (c -> d) -> Either a c -> Either b d+bimap f g = either (Left . f) (Right . g)++instance Visiting (AffineMarket a b)+++-- | Tag a value with not one but two phantom type parameters (so that 'Tagged'+-- can be used as an indexed profunctor).+newtype Tagged i a b = Tagged { unTagged :: b }++instance Functor (Tagged i a) where+  fmap f = Tagged #. f .# unTagged+  {-# INLINE fmap #-}++instance Profunctor Tagged where+  dimap _f g = Tagged #. g .# unTagged+  lmap  _f   = coerce+  rmap     g = Tagged #. g .# unTagged+  {-# INLINE dimap #-}+  {-# INLINE lmap #-}+  {-# INLINE rmap #-}++instance Choice Tagged where+  left'  = Tagged #. Left  .# unTagged+  right' = Tagged #. Right .# unTagged+  {-# INLINE left' #-}+  {-# INLINE right' #-}++instance Costrong Tagged where+  unfirst (Tagged bd) = Tagged (fst bd)+  unsecond (Tagged db) = Tagged (snd db)+  {-# INLINE unfirst #-}+  {-# INLINE unsecond #-}+++data Context a b t = Context (b -> t) a+  deriving Functor++-- | Composition operator where the first argument must be an identity+-- function up to representational equivalence (e.g. a newtype wrapper+-- or unwrapper), and will be ignored at runtime.+(#.) :: Coercible b c => (b -> c) -> (a -> b) -> (a -> c)+(#.) _f = coerce+infixl 8 .#+{-# INLINE (#.) #-}++-- | Composition operator where the second argument must be an+-- identity function up to representational equivalence (e.g. a+-- newtype wrapper or unwrapper), and will be ignored at runtime.+(.#) :: Coercible a b => (b -> c) -> (a -> b) -> (a -> c)+(.#) f _g = coerce f+infixr 9 #.+{-# INLINE (.#) #-}