Traversal attempt

Plutarch/Optics/Lens.hs

@@ -31,36 +31,6 @@ newtype UnpackedPLens edsl a b s t = UnpackedPLens
       r
   }
 
-instance PProfunctor edsl (UnpackedPLens edsl a b) where
-  pdimap f g (UnpackedPLens r) =
-    r \get set -> unpackedPLens (get . f) (unTermF . prmap g . TermF . set . f)
-
-instance
-  (ESOP edsl, IsEType edsl a) =>
-  PStrong edsl (UnpackedPLens edsl a b)
-  where
-  pfirst' (UnpackedPLens r) =
-    r \get set ->
-      unpackedPLens
-        (\tp -> ematch tp \(EPair a _) -> get a)
-        (\tp b -> ematch tp \(EPair a c) -> econ $ EPair (set a b) c)
-
-instance IsPIso edsl (UnpackedPLens edsl a b)
-instance (ESOP edsl, IsEType edsl a) => IsPLens edsl (UnpackedPLens edsl a b)
-
-withPLens ::
-  forall edsl s t a b r.
-  (ESOP edsl, IsEType edsl a) =>
-  PLens edsl s t a b ->
-  (((s :--> a) edsl -> (Term edsl s -> Term edsl b -> Term edsl t) -> r) -> r)
-withPLens o = withUnpackedPLens (o (unpackedPLens id (const id)))
-
-unpackedPLens ::
-  (s :--> a) edsl ->
-  (Term edsl s -> Term edsl b -> Term edsl t) ->
-  UnpackedPLens edsl a b s t
-unpackedPLens get set = UnpackedPLens $ \k -> k get set
-
 pand ::
   (ESOP edsl, IsEType edsl a, IsEType edsl b) =>
   (s :--> a) edsl ->
@@ -73,3 +43,28 @@ puncurry ::
   (Term edsl a -> Term edsl b -> Term edsl c) ->
   (EPair a b :--> c) edsl
 puncurry f tp = ematch tp \(EPair a b) -> f a b
+
+data ConcreteLens edsl a b s t = ConcreteLens
+  { plensGet :: (s :--> a) edsl
+  , plensSet :: Term edsl b -> Term edsl s -> Term edsl t
+  }
+
+instance PProfunctor edsl (ConcreteLens edsl a b) where
+  pdimap f g o = ConcreteLens (plensGet o . f) (\b -> g . plensSet o b . f)
+
+instance
+  (ESOP edsl, IsEType edsl a) =>
+  PStrong edsl (ConcreteLens edsl a b)
+  where
+  pfirst' o =
+    ConcreteLens
+      (\p -> ematch p \(EPair a _) -> plensGet o a)
+      (\b p -> ematch p \(EPair a c) -> econ $ EPair (plensSet o b a) c)
+
+  psecond' o =
+    ConcreteLens
+      (\p -> ematch p \(EPair _ a) -> plensGet o a)
+      (\b p -> ematch p \(EPair c a) -> econ $ EPair c (plensSet o b a))
+
+instance IsPIso edsl (ConcreteLens edsl a b)
+instance (ESOP edsl, IsEType edsl a) => IsPLens edsl (ConcreteLens edsl a b)

Plutarch/Optics/Optional.hs

@@ -1,6 +1,6 @@
-{-# LANGUAGE UndecidableSuperClasses #-}
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE UndecidableInstances #-}
+{-# LANGUAGE UndecidableSuperClasses #-}
 
 module Plutarch.Optics.Optional where
 
@@ -16,15 +16,14 @@ type POptional edsl s t a b = forall p. IsPOptional edsl p => POptic p s t a b
 
 class (IsPLens edsl p, IsPPrism edsl p) => IsPOptional edsl p
 
-newtype UnpackedPOptional edsl a b s t
-  = UnpackedPOptional
+newtype UnpackedPOptional edsl a b s t = UnpackedPOptional
   { withUnpackedPOptional ::
-    forall r.
-      (
-        (s :--> EEither t a) edsl ->
+      forall r.
+      ( (s :--> EEither t a) edsl ->
         (Term edsl s -> Term edsl b -> Term edsl t) ->
         r
-      ) -> r
+      ) ->
+      r
   }
 
 unpackedPOptional ::
@@ -35,7 +34,8 @@ unpackedPOptional prj set = UnpackedPOptional $ \k -> k prj set
 
 instance
   (ESOP edsl, IsEType edsl a, IsEType edsl b) =>
-  PProfunctor edsl (UnpackedPOptional edsl a b) where
+  PProfunctor edsl (UnpackedPOptional edsl a b)
+  where
   pdimap f g (UnpackedPOptional r) =
     r $ \prj set ->
       unpackedPOptional
@@ -44,47 +44,53 @@ instance
 
 instance
   (ESOP edsl, IsEType edsl a, IsEType edsl b) =>
-  PStrong edsl (UnpackedPOptional edsl a b) where
+  PStrong edsl (UnpackedPOptional edsl a b)
+  where
   pfirst' (UnpackedPOptional r) =
     r $ \prj set ->
       unpackedPOptional
-        (\tp -> ematch tp \(EPair a c) -> ematch (prj a) \case
-          ELeft b -> pleft (econ $ EPair b c)
-          ERight a -> pright a)
+        ( \tp -> ematch tp \(EPair a c) -> ematch (prj a) \case
+            ELeft b -> pleft (econ $ EPair b c)
+            ERight a -> pright a
+        )
         (\tp b -> ematch tp \(EPair a c) -> econ $ EPair (set a b) c)
 
   psecond' (UnpackedPOptional r) =
     r $ \prj set ->
       unpackedPOptional
-        (\tp -> ematch tp \(EPair c a) -> ematch (prj a) \case
-          ELeft b -> pleft (econ $ EPair c b)
-          ERight a -> pright a)
+        ( \tp -> ematch tp \(EPair c a) -> ematch (prj a) \case
+            ELeft b -> pleft (econ $ EPair c b)
+            ERight a -> pright a
+        )
         (\tp b -> ematch tp \(EPair a c) -> econ $ EPair a (set c b))
 
 instance
   (ESOP edsl, IsEType edsl a, IsEType edsl b) =>
-  PChoice edsl (UnpackedPOptional edsl a b) where
-    pleft' (UnpackedPOptional r) =
-      r $ \prj set ->
-        unpackedPOptional
-          (peither
+  PChoice edsl (UnpackedPOptional edsl a b)
+  where
+  pleft' (UnpackedPOptional r) =
+    r $ \prj set ->
+      unpackedPOptional
+        ( peither
             (peither (pleft . pleft) pright . prj)
             (pleft . pright)
-          )
-          (\e b -> ematch e \case
+        )
+        ( \e b -> ematch e \case
             ELeft a -> pleft (set a b)
-            ERight c -> pright c)
-
-    pright' (UnpackedPOptional r) =
-      r $ \prj set ->
-        unpackedPOptional
-          (peither
+            ERight c -> pright c
+        )
+
+  pright' (UnpackedPOptional r) =
+    r $ \prj set ->
+      unpackedPOptional
+        ( peither
             (pleft . pleft)
             (peither (pleft . pright) pright . prj)
-          )
-          (\e b -> ematch e \case
+        )
+        ( \e b -> ematch e \case
             ELeft a -> pleft a
-            ERight c -> pright (set c b))
+            ERight c -> pright (set c b)
+        )
 
 instance
   (ESOP edsl, IsEType edsl a, IsEType edsl b) =>
@@ -100,4 +106,4 @@ instance
 
 instance
   (ESOP edsl, IsEType edsl a, IsEType edsl b) =>
-  IsPOptional edsl (UnpackedPOptional edsl a b)
+  IsPOptional edsl (UnpackedPOptional edsl a b)

Plutarch/Optics/PEither.hs

@@ -16,4 +16,4 @@ _PRight ::
   forall edsl a b b'.
   (IsEType edsl a, IsEType edsl b, IsEType edsl b') =>
   PPrism edsl (EEither a b) (EEither a b') b b'
-_PRight = pprism @edsl pright (peither (pleft . pleft) pright)
+_PRight = pprism @edsl pright (peither (pleft . pleft) pright)

Plutarch/Optics/PPair.hs

@@ -22,4 +22,4 @@ psnd_ ::
 psnd_ =
   plens @edsl
     (\tp -> ematch tp \(EPair _ b) -> b)
-    (\ts b' -> ematch ts \(EPair a _) -> econ $ EPair a b')
+    (\ts b' -> ematch ts \(EPair a _) -> econ $ EPair a b')

Plutarch/Optics/Prism.hs

@@ -69,9 +69,9 @@ instance
     r $ \inj prj ->
       unpackedPPrism
         (pleft . inj)
-        (peither
-          (peither (pleft . pleft) pright . prj)
-          (pleft . pright)
+        ( peither
+            (peither (pleft . pleft) pright . prj)
+            (pleft . pright)
         )
 
 instance
@@ -87,4 +87,4 @@ withPPrism ::
   PPrism edsl s t a b ->
   ((b :--> t) edsl -> (s :--> EEither t a) edsl -> r) ->
   r
-withPPrism o = withUnpackedPPrism (o (unpackedPPrism id pright))
+withPPrism o = withUnpackedPPrism (o (unpackedPPrism id pright))

Plutarch/Optics/Profunctor.hs

@@ -1,5 +1,6 @@
 {-# LANGUAGE AllowAmbiguousTypes #-}
 {-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE UndecidableInstances #-}
 {-# LANGUAGE UndecidableSuperClasses #-}
 
 module Plutarch.Optics.Profunctor where
@@ -72,3 +73,22 @@ class (PProfunctor edsl p, ESOP edsl) => PChoice edsl p where
       (peither (econ . ERight) (econ . ELeft))
       . pleft' @edsl
   {-# MINIMAL pleft' | pright' #-}
+
+class (PProfunctor edsl p) => PMonoidal edsl p where
+  punit :: p EUnit EUnit
+  ppar :: p a b -> p c d -> p (EPair a c) (EPair b d)
+
+newtype PStar edsl f d c = PStar {unPStar :: Term edsl d -> f (Term edsl c)}
+
+instance (Functor f) => PProfunctor edsl (PStar edsl f) where
+  pdimap f g (PStar h) = PStar (fmap g . h . f)
+
+instance (ESOP edsl, Functor f) => PStrong edsl (PStar edsl f)
+
+instance (ESOP edsl, Functor f) => PChoice edsl (PStar edsl f)
+
+instance (ESOP edsl, Applicative f) => PMonoidal edsl (PStar edsl f) where
+  punit = PStar pure
+
+pcross :: (ESOP edsl, IsEType edsl a, IsEType edsl b, IsEType edsl c, IsEType edsl d) => (a :--> b) edsl -> (c :--> d) edsl -> (EPair a c :--> EPair b d) edsl
+pcross f g p = ematch p \(EPair a b) -> econ $ EPair (f a) (g b)

Plutarch/Optics/Traversal.hs

@@ -0,0 +1,21 @@
+{-# LANGUAGE UndecidableSuperClasses #-}
+
+module Plutarch.Optics.Traversal where
+
+import Plutarch.Core
+
+import Plutarch.Optics.Optic
+import Plutarch.Optics.Optional
+import Plutarch.Optics.Profunctor
+
+type PTraversal edsl s t a b =
+  forall p.
+  (IsPTraversal edsl p) =>
+  POptic p s t a b
+
+type PTraversal' edsl s a = PTraversal edsl s s a a
+
+class (IsPOptional edsl p, PMonoidal edsl p) => IsPTraversal edsl p
+
+traverseOf :: PTraversal edsl s t a b -> (Term edsl a -> f (Term edsl b)) -> (Term edsl s -> f (Term edsl t))
+traverseOf p = unPStar . p . PStar

Plutarch/PList.hs

@@ -0,0 +1,10 @@
+module Plutarch.PList where
+
+import Plutarch.Core
+import Plutarch.EType
+
+data PListF a self ef
+  = PNil
+  | PCons (ef /$ a) (ef /$ self)
+
+newtype PList a ef = PList (EFix (PListF a) ef)

plutarch-core.cabal

@@ -102,10 +102,13 @@ library
     Plutarch.Optics.Iso
     Plutarch.Optics.Lens
     Plutarch.Optics.Optic
+    Plutarch.Optics.Optional
     Plutarch.Optics.PEither
     Plutarch.Optics.PPair
     Plutarch.Optics.Prism
     Plutarch.Optics.Profunctor
+    Plutarch.Optics.Traversal
+    Plutarch.PList
     Plutarch.Reduce
     Plutarch.STLC
     Plutarch.SystemF