Fix transcribed to Plutarch

Plutarch/CPS/Optics/Lens.hs

@@ -2,7 +2,8 @@
 
 module Plutarch.CPS.Optics.Lens where
 
-import Control.Monad.Cont
+import Control.Monad
+import Control.Monad.Trans.Cont
 import Plutarch.CPS.Optics.Iso
 import Plutarch.CPS.Optics.Optic
 import Plutarch.CPS.Profunctor

Plutarch/CPS/Optics/Optic.hs

@@ -1,6 +1,6 @@
 module Plutarch.CPS.Optics.Optic where
 
-import Control.Monad.Cont
+import Control.Monad.Trans.Cont
 
 type COptic r p s t a b = p a (Cont r b) -> p s (Cont r t)
 

Plutarch/CPS/Optics/Optional.hs

@@ -7,7 +7,9 @@ import Plutarch.CPS.Optics.Optic
 import Plutarch.CPS.Optics.Prism
 
 import Control.Arrow
-import Control.Monad.Cont
+import Control.Monad
+
+import Control.Monad.Trans.Cont
 import Plutarch.CPS.Optics.Iso
 import Plutarch.CPS.Profunctor
 

Plutarch/CPS/Optics/Prism.hs

@@ -2,7 +2,8 @@
 
 module Plutarch.CPS.Optics.Prism where
 
-import Control.Monad.Cont
+import Control.Monad
+import Control.Monad.Trans.Cont
 import Plutarch.CPS.Optics.Iso
 import Plutarch.CPS.Optics.Optic
 import Plutarch.CPS.Profunctor

Plutarch/CPS/Optics/Traversal.hs

@@ -5,13 +5,10 @@ module Plutarch.CPS.Optics.Traversal(
   CTraversal',
   ctraverse,
   ctraverseOf,
-  ConcreteTraversal(ConcreteTraversal, unConcreteTraversal),
-  FunList,
-  single,
-  traversal,
+  ctraversal,
   ) where
 
-import Control.Monad.Cont
+import Control.Monad.Trans.Cont
 import Plutarch.CPS.Optics.Optic
 import Plutarch.CPS.Optics.Optional
 import Plutarch.CPS.Profunctor
@@ -52,7 +49,7 @@ instance Applicative (FunList a b) where
 fuse :: FunList b b t -> Cont r t
 fuse = either return (\(a, c) -> ($ a) <$> fuse c) . unFunList
 
-newtype ConcreteTraversal r s t a b = ConcreteTraversal {unConcreteTraversal :: s -> Cont r (FunList a b t)}
-
-traversal :: (s -> Cont r (FunList a b t)) -> CTraversal r s t a b
-traversal h = cdimap h fuse . ctraverse
+ctraversal ::
+  (forall f. Applicative f => (a -> f b) -> (s -> Cont r (f t))) ->
+  CTraversal r s t a b
+ctraversal h = cdimap (h single) fuse . ctraverse

Plutarch/CPS/Profunctor.hs

@@ -3,7 +3,8 @@
 module Plutarch.CPS.Profunctor where
 
 import Control.Applicative
-import Control.Monad.Cont
+import Control.Monad
+import Control.Monad.Trans.Cont
 import Data.Tuple
 
 newtype CStar r f a b = CStar {runCStar :: a -> Cont r (f b)}

Plutarch/Cont.hs

@@ -0,0 +1,15 @@
+module Plutarch.Cont(pmatchCont) where
+
+import Control.Monad.Trans.Cont
+
+import Plutarch.Core
+
+pmatchCont ::
+  (
+    EConstructable edsl a,
+    IsEType edsl r
+  ) =>
+  (EConcrete edsl a -> Cont (Term edsl r) b) ->
+  Term edsl a ->
+  Cont (Term edsl r) b
+pmatchCont cnt t = cont \c -> ematch t \con -> runCont (cnt con) c

Plutarch/Optics/Fix.hs

@@ -1,28 +1,42 @@
 {-# LANGUAGE PartialTypeSignatures #-}
-{-# OPTIONS_GHC -Wno-unused-top-binds #-}
-module Plutarch.Optics.Fix(fixt) where
 
-import Data.Fix
-import Control.Lens
+module Plutarch.Optics.Fix(pfix) where
 
-import Data.Functor.Base
 import Data.Function
+import Data.Profunctor
 
-fixt ::
-  (Applicative f) =>
-  (forall ra rb. (ra -> f rb) -> a ra -> f (b rb)) ->
-  Fix a ->
-  f (Fix b)
-fixt f = fmap Fix . (fix (f . dimap unFix (fmap Fix))) . unFix
+import Control.Monad.Trans.Cont
 
-list' :: Traversal (Fix (ListF a)) (Fix (ListF b)) a b
-list' f = fixt (listf f)
+import Plutarch.Core
+import Plutarch.Cont
 
-listf ::
-  (Applicative f) =>
-  (a -> f b) ->
-  (ra -> f rb) ->
-  ListF a ra ->
-  f (ListF b rb)
-listf _ _ Nil = pure Nil
-listf f r (Cons a b) = Cons <$> f a <*> r b
+-- | Not a 'Plutarch.CPS.Optics.Traversal.CTraversal', but can be used to construct one.
+pfix ::
+  (
+    EConstructable edsl (EFix a),
+    EConstructable edsl (a (EFix a)),
+    EConstructable edsl (EFix b),
+    EConstructable edsl (b (EFix b)),
+    EConstructable edsl r,
+    Applicative f
+  ) =>
+  (
+    forall ra rb.
+    (
+      EConstructable edsl (a ra),
+      EConstructable edsl (b rb)
+    ) =>
+    (Term edsl    ra    -> Cont (Term edsl r) (f (Term edsl    rb  ))) ->
+     Term edsl (a ra  ) -> Cont (Term edsl r) (f (Term edsl (b rb  )))
+  ) ->
+     Term edsl (EFix a) -> Cont (Term edsl r) (f (Term edsl (EFix b)))
+pfix f =
+  pmatchCont \(EFix a) ->
+    fmap (econ . EFix)
+      <$> fix
+        (f .
+          dimap
+            (\fa -> ematch fa \(EFix a') -> a')
+            (fmap (fmap (econ . EFix)))
+        )
+        a

Plutarch/Optics/PEither.hs

@@ -1,11 +1,9 @@
-{-# LANGUAGE AllowAmbiguousTypes #-}
-
 module Plutarch.Optics.PEither where
 
 import Plutarch.CPS.Optics.Prism
 
-import Control.Monad.Cont
 import Plutarch.Core
+import Plutarch.Cont
 
 _PLeft ::
   (ESOP edsl, IsEType edsl a, IsEType edsl a', IsEType edsl b, IsEType edsl r) =>
@@ -18,9 +16,9 @@ _PLeft ::
 _PLeft =
   cprism
     (return . pleft)
-    ( \te -> cont \f -> ematch te \case
-        ELeft a -> f . Right $ a
-        ERight b -> f . Left $ pright b
+    (pmatchCont \case
+      ELeft a -> return $ Right a
+      ERight b -> return $ Left (pright b)
     )
 
 _PRight ::
@@ -34,7 +32,7 @@ _PRight ::
 _PRight =
   cprism
     (return . pright)
-    ( \te -> cont \f -> ematch te \case
-        ELeft a -> f . Left $ pleft a
-        ERight b -> f . Right $ b
+    (pmatchCont \case
+        ELeft a -> return $ Left (pleft a)
+        ERight b -> return $ Right b
     )

Plutarch/Optics/PList.hs

@@ -1,64 +1,47 @@
 module Plutarch.Optics.PList where
 
-import Control.Applicative
-import Control.Monad.Cont
+import Control.Monad.Trans.Cont
 import Plutarch.CPS.Optics.Traversal
 import Plutarch.Core
+import Plutarch.Cont
 import Plutarch.PList
-
-plist'' ::
-  ( ESOP edsl
-  , IsEType edsl a
-  , IsEType edsl b
-  , IsEType edsl r
-  , IsEType edsl (EFix (PListF a))
-  , EConstructable edsl (EFix (PListF a))
-  , IsEType edsl (EFix (PListF b))
-  , EConstructable edsl (EFix (PListF b))
-  ) =>
-  Term edsl (EFix (PListF a)) ->
-  Cont
-    (Term edsl r)
-    (FunList (Term edsl a) (Term edsl b) (Term edsl (EFix (PListF b))))
-plist'' fl = cont \f ->
-  ematch fl \(EFix l) -> ematch l \case
-    PNil -> f . pure . econ . EFix . econ $ PNil
-    PCons x xs ->
-      runCont
-        (plist'' xs)
-        (f . liftA2 (\x' -> econ . EFix . econ . PCons x') (single x))
-
-plist' ::
-  ( ESOP edsl
-  , IsEType edsl a
-  , IsEType edsl b
-  , IsEType edsl r
-  , IsEType edsl (EFix (PListF a))
-  , EConstructable edsl (EFix (PListF a))
-  , IsEType edsl (EFix (PListF b))
-  , EConstructable edsl (EFix (PListF b))
-  ) =>
-  Term edsl (PList a) ->
-  Cont
-    (Term edsl r)
-    (FunList (Term edsl a) (Term edsl b) (Term edsl (PList b)))
-plist' fl = fmap (econ . PList) <$> plist'' (ematch fl unPList)
+import Plutarch.Optics.Fix
+import Control.Applicative
 
 plist ::
   ( ESOP edsl
   , IsEType edsl a
   , IsEType edsl b
   , IsEType edsl r
-  , IsEType edsl (EFix (PListF a))
   , EConstructable edsl (EFix (PListF a))
-  , IsEType edsl (EFix (PListF b))
   , EConstructable edsl (EFix (PListF b))
+  , EConstructable edsl r
   ) =>
   CTraversal
     (Term edsl r)
     (Term edsl (PList a))
     (Term edsl (PList b))
     (Term edsl a)
     (Term edsl b)
-plist = traversal plist'
+plist =
+  ctraversal
+    \f -> pmatchCont (\(PList as) -> fmap (econ . PList) <$> plist' f as)
 
+plist' ::
+  (
+    EConstructable edsl (EFix (PListF a)),
+    EConstructable edsl (PListF a (EFix (PListF a))),
+    EConstructable edsl (EFix (PListF b)),
+    EConstructable edsl r,
+    EConstructable edsl (PListF b (EFix (PListF b))),
+    Applicative f
+  ) =>
+  (Term edsl a -> f (Term edsl b)) ->
+  Term edsl (EFix (PListF a)) ->
+  Cont (Term edsl r) (f (Term edsl (EFix (PListF b))))
+plist' f =
+  pfix
+    (\r -> pmatchCont \case
+      PNil -> return $ pure (econ PNil)
+      PCons a as -> fmap econ . liftA2 PCons (f a) <$> r as
+    )

plutarch-core.cabal

@@ -96,6 +96,7 @@ library
     -fprint-equality-relations -fprint-explicit-foralls
 
   exposed-modules:
+    Plutarch.Cont
     Plutarch.Core
     Plutarch.CPS.Optics.Iso
     Plutarch.CPS.Optics.Lens
@@ -117,8 +118,6 @@ library
 
   build-depends:
     , base
-    , data-fix
     , generics-sop
-    , lens
-    , mtl
-    , recursion-schemes
+    , transformers
+    , profunctors