Draft optics implementation

.gitignore

@@ -1 +1,2 @@
 /dist-newstyle
+cabal.project.local

Plutarch/CPS/Optics/Iso.hs

@@ -0,0 +1,15 @@
+{-# LANGUAGE FlexibleInstances #-}
+
+module Plutarch.CPS.Optics.Iso where
+
+import Plutarch.CPS.Optics.Optic
+import Plutarch.CPS.Profunctor
+
+type CIso r s t a b = forall p. (IsCIso r p) => COptic r p s t a b
+
+type CIso' r s a = CIso r s s a a
+
+class (CProfunctor r p) => IsCIso r p
+
+instance IsCIso r (->)
+instance (Functor f) => IsCIso r (CStar r f)

Plutarch/CPS/Optics/Lens.hs

@@ -0,0 +1,47 @@
+{-# LANGUAGE FlexibleInstances #-}
+
+module Plutarch.CPS.Optics.Lens where
+
+import Control.Monad
+import Control.Monad.Trans.Cont
+import Plutarch.CPS.Optics.Iso
+import Plutarch.CPS.Optics.Optic
+import Plutarch.CPS.Profunctor
+
+type CLens r s t a b = forall p. (IsCLens r p) => COptic r p s t a b
+
+type CLens' r s a = CLens r s s a a
+
+class (IsCIso r p, CStrong r p) => IsCLens r p
+
+instance (Functor f) => IsCLens r (CStar r f)
+
+clens :: (s -> Cont r a) -> (s -> b -> Cont r t) -> CLens r s t a b
+clens get set = cdimap (\s -> (s,) <$> get s) (uncurry set) . csecond'
+
+withCLens :: CLens r s t a b -> ((s -> Cont r a) -> (s -> b -> Cont r t) -> r') -> r'
+withCLens o f = f (clensGet l) (clensSet l)
+  where
+    l = o $ ConcreteLens {clensGet = return, clensSet = const return}
+
+data ConcreteLens r a b s t = ConcreteLens
+  { clensGet :: s -> Cont r a
+  , clensSet :: s -> b -> t
+  }
+
+instance CProfunctor r (ConcreteLens r a b) where
+  cdimap ab cd l =
+    ConcreteLens
+      { clensGet = ab >=> clensGet l
+      , clensSet = \a b -> ab a >>= \b' -> clensSet l b' b >>= cd
+      }
+
+instance CStrong r (ConcreteLens r a b) where
+  cfirst' l =
+    ConcreteLens
+      { clensGet = clensGet l . fst
+      , clensSet = \(a, c) b -> (,c) <$> clensSet l a b
+      }
+
+instance IsCIso r (ConcreteLens r a b)
+instance IsCLens r (ConcreteLens r a b)

Plutarch/CPS/Optics/Optic.hs

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

Plutarch/CPS/Optics/Optional.hs

@@ -0,0 +1,83 @@
+{-# LANGUAGE FlexibleInstances #-}
+
+module Plutarch.CPS.Optics.Optional where
+
+import Plutarch.CPS.Optics.Lens
+import Plutarch.CPS.Optics.Optic
+import Plutarch.CPS.Optics.Prism
+
+import Control.Arrow
+import Control.Monad
+
+import Control.Monad.Trans.Cont
+import Plutarch.CPS.Optics.Iso
+import Plutarch.CPS.Profunctor
+
+type COptional r s t a b = forall p. (IsCOptional r p) => COptic r p s t a b
+
+type COptional' r s a = COptional r s s a a
+
+class (IsCLens r p, IsCPrism r p) => IsCOptional r p
+
+instance (Applicative f) => IsCOptional r (CStar r f)
+
+withCOptional :: COptional r s t a b -> ((s -> Cont r (Either t a)) -> (s -> b -> Cont r t) -> r') -> r'
+withCOptional o f = f (coptionalGet l >=> either (fmap Left) (return . Right)) (coptionalSet l)
+  where
+    l = o $ ConcreteOptional {coptionalGet = return . Right, coptionalSet = const return}
+
+data ConcreteOptional r a b s t = ConcreteOptional
+  { coptionalGet :: s -> Cont r (Either t a)
+  , coptionalSet :: s -> b -> t
+  }
+
+instance CProfunctor r (ConcreteOptional r a b) where
+  cdimap ab cd o =
+    ConcreteOptional
+      { coptionalGet =
+          ab >=> coptionalGet o >=> return . left (>>= cd)
+      , coptionalSet = \a b -> ab a >>= \b' -> coptionalSet o b' b >>= cd
+      }
+
+instance CStrong r (ConcreteOptional r a b) where
+  cfirst' o =
+    ConcreteOptional
+      { coptionalGet = \(a, c) -> left (fmap (,c)) <$> coptionalGet o a
+      , coptionalSet = \(a, c) b -> (,c) <$> coptionalSet o a b
+      }
+
+  csecond' o =
+    ConcreteOptional
+      { coptionalGet = \(c, a) -> left (fmap (c,)) <$> coptionalGet o a
+      , coptionalSet = \(c, a) b -> (c,) <$> coptionalSet o a b
+      }
+
+instance CChoice r (ConcreteOptional r a b) where
+  cleft' o =
+    ConcreteOptional
+      { coptionalGet =
+          either
+            ( coptionalGet o
+                >=> return . left (fmap Left)
+            )
+            (return . Left . return . Right)
+      , coptionalSet =
+          \e b -> either (\a -> Left <$> coptionalSet o a b) (return . Right) e
+      }
+
+  cright' o =
+    ConcreteOptional
+      { coptionalGet =
+          either
+            (return . Left . return . Left)
+            ( coptionalGet o
+                >=> return . left (fmap Right)
+            )
+      , coptionalSet =
+          \e b -> either (return . Left) (\a -> Right <$> coptionalSet o a b) e
+      }
+
+instance IsCIso r (ConcreteOptional r a b)
+instance IsCLens r (ConcreteOptional r a b)
+instance IsCPrism r (ConcreteOptional r a b)
+instance IsCOptional r (ConcreteOptional r a b)

Plutarch/CPS/Optics/Prism.hs

@@ -0,0 +1,62 @@
+{-# LANGUAGE FlexibleInstances #-}
+
+module Plutarch.CPS.Optics.Prism where
+
+import Control.Monad
+import Control.Monad.Trans.Cont
+import Plutarch.CPS.Optics.Iso
+import Plutarch.CPS.Optics.Optic
+import Plutarch.CPS.Profunctor
+
+type CPrism r s t a b = forall p. IsCPrism r p => COptic r p s t a b
+
+type CPrism' r a b = CPrism r a a b b
+
+class (IsCIso r p, CChoice r p) => IsCPrism r p
+
+instance (Applicative f) => IsCPrism r (CStar r f)
+
+cprism :: (b -> Cont r t) -> (s -> Cont r (Either t a)) -> CPrism r s t a b
+cprism inj prj = cdimap prj (either return inj) . cright'
+
+cprism' :: (b -> Cont r s) -> (s -> Cont r (Maybe a)) -> CPrism r s s a b
+cprism' inj prj = cprism inj (\s -> prj s >>= maybe (return $ Left s) (return . Right))
+
+withCPrism ::
+  CPrism r s t a b ->
+  ((b -> Cont r t) -> (s -> Cont r (Either t a)) -> r') ->
+  r'
+withCPrism o f =
+  f (cprismSet l) (cprismGet l >=> either (fmap Left) (return . Right))
+  where
+    l = o $ ConcretePrism {cprismSet = return, cprismGet = return . Right}
+
+data ConcretePrism r a b s t = ConcretePrism
+  { cprismGet :: s -> Cont r (Either t a)
+  , cprismSet :: b -> t
+  }
+
+instance CProfunctor r (ConcretePrism r a b) where
+  cdimap ab cd p =
+    ConcretePrism
+      { cprismGet =
+          ab
+            >=> cprismGet p
+            >=> either
+              (\c -> Left . return <$> (c >>= cd))
+              (return . Right)
+      , cprismSet = cprismSet p >=> cd
+      }
+
+instance CChoice r (ConcretePrism r a b) where
+  cleft' p =
+    ConcretePrism
+      { cprismGet =
+          either
+            (cprismGet p >=> either (fmap (Left . return . Left)) (return . Right))
+            (return . Left . return . Right)
+      , cprismSet = fmap Left . cprismSet p
+      }
+
+instance IsCIso r (ConcretePrism r a b)
+instance IsCPrism r (ConcretePrism r a b)

Plutarch/CPS/Optics/Traversal.hs

@@ -0,0 +1,55 @@
+{-# LANGUAGE FlexibleInstances #-}
+
+module Plutarch.CPS.Optics.Traversal(
+  CTraversal,
+  CTraversal',
+  ctraverse,
+  ctraverseOf,
+  ctraversal,
+  ) where
+
+import Control.Monad.Trans.Cont
+import Plutarch.CPS.Optics.Optic
+import Plutarch.CPS.Optics.Optional
+import Plutarch.CPS.Profunctor
+
+type CTraversal r s t a b = forall p. (IsCTraversal r p) => COptic r p s t a b
+
+type CTraversal' r s a = CTraversal r s s a a
+
+class (IsCOptional r p, CMonoidal r p) => IsCTraversal r p
+
+instance (Applicative f) => IsCTraversal r (CStar r f)
+
+ctraverse :: (CChoice r p, CMonoidal r p) => p a (Cont r b) -> p (FunList a c t) (Cont r (FunList b c t))
+ctraverse k = cdimap (return . unFunList) (return . FunList) . cright' $ cpar k (ctraverse k)
+
+ctraverseOf ::
+  (Applicative f) =>
+  CTraversal r s t a b ->
+  (a -> Cont r (f b)) ->
+  s ->
+  Cont r (f (Cont r t))
+ctraverseOf p = runCStar . p . CStar . (fmap . fmap . fmap) return
+
+newtype FunList a b t = FunList {unFunList :: Either t (a, FunList a b (b -> t))}
+
+single :: a -> FunList a b b
+single a = FunList $ Right (a, FunList $ Left id)
+
+instance Functor (FunList a b) where
+  fmap f (FunList (Left t)) = FunList (Left (f t))
+  fmap f (FunList (Right (a, as))) = FunList (Right (a, fmap (f .) as))
+
+instance Applicative (FunList a b) where
+  pure = FunList . Left
+  FunList (Left f) <*> l' = fmap f l'
+  FunList (Right (a, l)) <*> l' = FunList (Right (a, fmap flip l <*> l'))
+
+fuse :: FunList b b t -> Cont r t
+fuse = either return (\(a, c) -> ($ a) <$> fuse c) . unFunList
+
+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

@@ -0,0 +1,77 @@
+{-# LANGUAGE FlexibleInstances #-}
+
+module Plutarch.CPS.Profunctor where
+
+import Control.Applicative
+import Control.Monad
+import Control.Monad.Trans.Cont
+import Data.Tuple
+
+newtype CStar r f a b = CStar {runCStar :: a -> Cont r (f b)}
+
+class CProfunctor r p where
+  cdimap :: (a -> Cont r b) -> (c -> Cont r d) -> p b (Cont r c) -> p a (Cont r d)
+
+clmap :: (CProfunctor r p) => (a -> Cont r b) -> p b (Cont r c) -> p a (Cont r c)
+clmap f = cdimap f return
+
+crmap :: (CProfunctor r p) => (b -> Cont r c) -> p a (Cont r b) -> p a (Cont r c)
+crmap = cdimap return
+
+instance CProfunctor r (->) where
+  cdimap ab cd bc = ab >=> bc >=> cd
+
+instance (Functor f) => CProfunctor r (CStar r f) where
+  cdimap ab cd (CStar bc) = CStar $ ab >=> bc >=> return . fmap (>>= cd)
+
+class (CProfunctor r p) => CStrong r p where
+  cfirst' :: p a (Cont r b) -> p (a, c) (Cont r (b, c))
+  cfirst' = cdimap (return . swap) (return . swap) . csecond'
+
+  csecond' :: p a (Cont r b) -> p (c, a) (Cont r (c, b))
+  csecond' = cdimap (return . swap) (return . swap) . cfirst'
+
+instance CStrong r (->) where
+  cfirst' ab (a, c) = (,c) <$> ab a
+  csecond' ab (c, a) = (c,) <$> ab a
+
+instance (Functor f) => CStrong r (CStar r f) where
+  cfirst' (CStar afb) = CStar \(a, c) -> (fmap . fmap . fmap) (,c) (afb a)
+  csecond' (CStar afb) = CStar \(c, a) -> (fmap . fmap . fmap) (c,) (afb a)
+
+class (CProfunctor r p) => CChoice r p where
+  cleft' :: p a (Cont r b) -> p (Either a c) (Cont r (Either b c))
+  cleft' = cdimap (return . either Right Left) (return . either Right Left) . cright'
+
+  cright' :: p a (Cont r b) -> p (Either c a) (Cont r (Either c b))
+  cright' = cdimap (return . either Right Left) (return . either Right Left) . cleft'
+
+instance CChoice r (->) where
+  cleft' ab = either (fmap Left . ab) (return . Right)
+  cright' ab = either (return . Left) (fmap Right . ab)
+
+instance (Applicative f) => CChoice r (CStar r f) where
+  cleft' (CStar afb) =
+    CStar $
+      either
+        ((fmap . fmap . fmap) Left . afb)
+        (return . pure . return . Right)
+
+  cright' (CStar afb) =
+    CStar $
+      either
+        (return . pure . return . Left)
+        ((fmap . fmap . fmap) Right . afb)
+
+class (CProfunctor r p) => CMonoidal r p where
+  cunit :: p () (Cont r ())
+  cpar :: p a (Cont r b) -> p c (Cont r d) -> p (a, c) (Cont r (b, d))
+
+instance CMonoidal r (->) where
+  cunit () = return ()
+  cpar ab cd (a, c) = (,) <$> ab a <*> cd c
+
+instance (Applicative f) => CMonoidal r (CStar r f) where
+  cunit = CStar $ \() -> return . pure . return $ ()
+  cpar (CStar afb) (CStar cfd) =
+    CStar (\(a, c) -> (liftA2 . liftA2) (,) <$> afb a <*> cfd c)

Plutarch/Cont.hs

@@ -0,0 +1,17 @@
+module Plutarch.Cont(PCont, pmatchCont) where
+
+import Control.Monad.Trans.Cont
+
+import Plutarch.Core
+
+type PCont edsl r = Cont (Term edsl r)
+
+pmatchCont ::
+  (
+    PConstructable edsl a,
+    IsPType edsl r
+  ) =>
+  (PConcrete edsl a -> PCont edsl r b) ->
+  Term edsl a ->
+  PCont edsl r b
+pmatchCont cnt t = cont \c -> pmatch t \con -> runCont (cnt con) c