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/Profunctor.hs

@@ -1,6 +1,7 @@
 {-# LANGUAGE AllowAmbiguousTypes #-}
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE UndecidableSuperClasses #-}
+{-# LANGUAGE UndecidableInstances #-}
 
 module Plutarch.Optics.Profunctor where
 
@@ -72,3 +73,23 @@ 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
+  ppar (PStar h) (PStar k) = PStar _
+
+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,20 @@
+{-# 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