Isomorphisms as optics

Author: sjoerdvisscher

src/Proarrow/Core.hs

@@ -26,6 +26,14 @@ module Proarrow.Core
   , Promonad(..)
     -- ** Promonad Utilities
   , arr
+    -- * Isomorphisms
+  , Optic
+  , Iso
+  , Iso'
+  , AnIso
+  , iso
+  , from
+  , Exchange(..)
     -- * Object Identities
   , Obj, obj, src, tgt
     -- * Type Family Utilities
@@ -198,3 +206,22 @@ type family UN (w :: j -> k) (wa :: k) :: j
 
 -- | @Is w a@ checks that the kind @a@ is a kind wrapped by @w@.
 type Is w a = a ~ w (UN w a)
+
+-- * Isomophisms (as optics)
+
+type Optic c s t a b = forall p. c p => p a b -> p s t
+type Iso s t a b = Optic Profunctor s t a b
+type Iso' s a = Iso s s a a
+
+iso :: (s ~> a) -> (b ~> t) -> Iso s t a b
+iso sa bt = dimap sa bt
+
+data Exchange a b s t = Exchange (s ~> a) (b ~> t)
+instance CategoryOf k => Profunctor (Exchange a b :: k +-> k) where
+  dimap l r (Exchange sa bt) = Exchange (sa . l) (r . bt)
+  r \\ Exchange sa bt = r \\ sa \\ bt
+
+type AnIso s t a b = Exchange a b a b -> Exchange a b s t
+
+from :: (CategoryOf k, Ob (a :: k), Ob b) => AnIso s t a b -> Iso b a t s
+from l = case l (Exchange id id) of Exchange sa bt -> iso bt sa

src/Proarrow/Profunctor/Constant.hs

@@ -1,9 +1,17 @@
 module Proarrow.Profunctor.Constant where
 
-import Proarrow.Core (CategoryOf (..), Promonad (..), type (+->))
+import Proarrow.Core (CategoryOf (..), Promonad (..), type (+->), Optic)
 import Proarrow.Functor (FunctorForRep (..))
+import Proarrow.Profunctor.Representable (rep, Rep)
+import Proarrow.Profunctor.Corepresentable (corep, Corep)
 
 data family Constant :: k -> j +-> k
 instance (CategoryOf j, CategoryOf k, Ob c) => FunctorForRep (Constant c :: j +-> k) where
   type Constant c @ a = c
   fmap _ = id
+
+view :: forall {k} {c} (s :: k) (t :: k) a b. (CategoryOf k, Ob a, Ob b, c (Rep (Constant a))) => Optic c s t a b -> s ~> a
+view l = rep @(Constant a) l id
+
+review :: forall {k} {c} (s :: k) (t :: k) a b. (CategoryOf k, Ob a, Ob b, c (Corep (Constant b))) => Optic c s t a b -> b ~> t
+review l = corep @(Constant b) l id

src/Proarrow/Profunctor/Corepresentable.hs

@@ -4,7 +4,7 @@ module Proarrow.Profunctor.Corepresentable where
 
 import Data.Kind (Constraint)
 
-import Proarrow.Core (CategoryOf (..), Profunctor (..), Promonad (..), type (+->), lmap)
+import Proarrow.Core (CategoryOf (..), Profunctor (..), Promonad (..), type (+->), lmap, Iso, iso)
 import Proarrow.Object (obj, Obj)
 import Proarrow.Functor (FunctorForRep (..))
 
@@ -45,4 +45,7 @@ instance (FunctorForRep f) => Corepresentable (Corep f) where
   type Corep f %% a = f @ a
   coindex (Corep f) = f
   cotabulate = Corep
-  corepMap = fmap @f
+  corepMap = fmap @f
+
+corep :: forall f a b a' b'. Ob a => Iso (f @ a ~> b) (f @ a' ~> b') (Corep f a b) (Corep f a' b')
+corep = iso Corep unCorep

src/Proarrow/Profunctor/Representable.hs

@@ -6,7 +6,7 @@ import Data.Kind (Constraint)
 import Prelude (type (~))
 
 import Proarrow.Category.Enriched.ThinCategory (Discrete, Thin, ThinProfunctor (..), withEq)
-import Proarrow.Core (CategoryOf (..), Profunctor (..), Promonad (..), (:~>), type (+->), rmap)
+import Proarrow.Core (CategoryOf (..), Profunctor (..), Promonad (..), (:~>), type (+->), rmap, Iso, iso)
 import Proarrow.Functor (FunctorForRep (..))
 import Proarrow.Object (Obj, obj, tgt, src)
 import Proarrow.Profunctor.Corepresentable (Corepresentable (..), dimapCorep, trivialCorep)
@@ -95,4 +95,7 @@ instance (FunctorForRep f) => Representable (Rep f) where
   type Rep f % a = f @ a
   index (Rep f) = f
   tabulate = Rep
-  repMap = fmap @f
+  repMap = fmap @f
+
+rep :: forall f a b a' b'. Ob b => Iso (a ~> f @ b) (a' ~> f @ b') (Rep f a b) (Rep f a' b')
+rep = iso Rep unRep

src/Proarrow/Profunctor/Wrapped.hs

@@ -2,7 +2,7 @@ module Proarrow.Profunctor.Wrapped where
 
 import Proarrow.Category.Instance.Prof (Prof (..))
 import Proarrow.Category.Monoidal (MonoidalProfunctor (..))
-import Proarrow.Core (Profunctor (..), Promonad (..))
+import Proarrow.Core (Profunctor (..), Promonad (..), Iso, iso)
 import Proarrow.Monoid (Comonoid (..), Monoid (..))
 import Proarrow.Profunctor.Day (Day (..), DayUnit (..))
 import Proarrow.Category.Enriched.Dagger (DaggerProfunctor (..))
@@ -44,4 +44,7 @@ instance (Corepresentable p) => Corepresentable (Wrapped p) where
   type Wrapped p %% a = p %% a
   coindex (Wrapped p) = coindex p
   cotabulate f = Wrapped (cotabulate f)
-  corepMap = corepMap @p
+  corepMap = corepMap @p
+
+wrapped :: Iso (p a b) (p a' b') (Wrapped p a b) (Wrapped p a' b')
+wrapped = iso Wrapped unWrapped