replicateN

Author: echatav

.gitignore

@@ -23,3 +23,4 @@ stack.yaml.lock
 tags
 .*.swp
 .qodo
+SCRATCH*

TODO

@@ -1,10 +1,12 @@
 TODO
 
 x Monadic interface ala Lysxia
-  Parsec profunctor with TokenTest & NonTerminal errors ala Leijen
+  Monadic example grammar
+  More Tests
+  Parsec profunctor with either TokenTest or NonTerminal errors ala Leijen
   Categoric interface with diid
   Arrowic?
-  Tests
+  Read Chomsky
   Documents
   Announcement
   Delete TODO

src/Data/Profunctor/Do/Bond.hs

@@ -12,14 +12,17 @@ module Data.Profunctor.Do.Bond
   ( -- *
     (>>=)
   , (>>)
+  , (<$>)
   , fail
   , return
   ) where
 
+import Control.Lens (Optic)
+import Control.Monad (join)
 import Data.Profunctor (Profunctor (dimap))
 import Data.Profunctor.Do.Polyadic.Bind (fail)
-import Data.Profunctor.Monadic (Monadic (bondM))
-import Prelude hiding ((>>), (>>=), fail)
+import Data.Profunctor.Monadic (Monadic (liftP, bondM))
+import Prelude (Applicative (pure), const, fmap, flip, fst, snd, return, (.))
 
 (>>=) :: Monadic m p => p m a a -> (a -> p m b c) -> p m (a,b) (a,c)
 infixl 1 >>=
@@ -28,3 +31,10 @@ infixl 1 >>=
 (>>) :: Monadic m p => p m () () -> p m b c -> p m b c
 infixl 1 >>
 x >> y = dimap ((),) snd (x >>= const y)
+
+(<$>)
+  :: (Monadic m p, Applicative m)
+  => Optic (p m) m s t a b
+  -> p m (a,()) (b,()) -> p m s t
+infixl 4 <$>
+f <$> x = join (fmap liftP (f (dimap (,()) (pure . fst) x)))

src/Data/Profunctor/Grammar.hs

@@ -214,10 +214,10 @@ instance Monad m => Polyadic m Printor where
     (Printor mg, f) <- mf a
     (b, g) <- mg a
     return (b, g . f)
-  bondP f (Printor m) = Printor $ \(a0,b) -> do
-    (a1,g) <- m a0
-    (c,h) <- runPrintor (f a1) b
-    return ((a1,c), h . g)
+  bondP f (Printor m) = Printor $ \(x,b) -> do
+    (y,g) <- m x
+    (c,h) <- runPrintor (f y) b
+    return ((y,c), h . g)
 instance Applicative f => Distributor (Printor s s f) where
   zeroP = Printor absurd
   Printor p >+< Printor q = Printor $

src/Data/Profunctor/Monadic.hs

@@ -34,16 +34,16 @@ class
   bondM :: (a -> p m b c) -> p m a a -> p m (a,b) (a,c)
 instance Monad m => Monadic m Kleisli where
   liftP = Kleisli . return
-  bondM g (Kleisli f) = Kleisli $ \(a0,b) -> do
-    a1 <- f a0
-    c <- runKleisli (g a1) b
-    return (a1,c)
+  bondM g (Kleisli f) = Kleisli $ \(x,b) -> do
+    y <- f x
+    c <- runKleisli (g y) b
+    return (y,c)
 instance Monad m => Monadic m Star where
   liftP = Star . return
-  bondM g (Star f) = Star $ \(a0,b) -> do
-    a1 <- f a0
-    c <- runStar (g a1) b
-    return (a1,c)
+  bondM g (Star f) = Star $ \(x,b) -> do
+    y <- f x
+    c <- runStar (g y) b
+    return (y,c)
 
 monochrome_
   :: (Monadic m p, Applicative m)

src/Data/Profunctor/Monoidal.hs

@@ -5,7 +5,7 @@ module Data.Profunctor.Monoidal
     Monoidal
   , oneP, (>*<), (>*), (*<)
   , dimap2, foreverP, replicateP
-  , (>:<), asEmpty
+  , (>:<), asEmpty, replicateN
   , meander, eotFunList
   ) where
 
@@ -115,6 +115,12 @@ asEmpty = _Empty >? oneP
 x >:< xs = _Cons >? x >*< xs
 infixr 5 >:<
 
+replicateN
+  :: (Monoidal p, Choice p, AsEmpty s, AsEmpty t, Cons s t a b)
+  => Int -> p a b -> p s t
+replicateN n _ | n <= 0 = lmap (const Empty) asEmpty
+replicateN n a = a >:< replicateN (n-1) a
+
 {- | For any `Monoidal`, `Choice` & `Strong` `Profunctor`,
 `meander` is invertible and gives a default implementation for the
 `Data.Profunctor.Traversing.wander`