Permalink
Browse files

applicative modify for multilens.

  • Loading branch information...
1 parent 6bd101e commit 55c6bf4fb4d3801ce9adbacf366c0f046b0590d4 @roconnor committed May 20, 2012
Showing with 16 additions and 9 deletions.
  1. +16 −9 src/Data/Lens/Multi/Common.hs
@@ -14,15 +14,7 @@ newtype MultiLens a b = MLens {runMLens :: a -> StaredStore b a}
instance Category MultiLens where
id = totalLens id
- MLens f . MLens g = MLens $ composeHelper f . g
- where
- {- this explicit passing of f is here to allow polymorphic recursion while remaining haskell 98 -}
- composeHelper :: (b -> StaredStore c b) -> StaredStore b d -> StaredStore c d
- composeHelper k (StaredStore x) = coproduct (pure . runIdentity) h' x
- where
- h' y = composeHelper k v <*> k b
- where
- (v, b) = runStoreT y
+ MLens f . g = MLens $ g ^%%= f
-- totalLens is a homomorphism of categories; ie a functor.
totalLens :: Lens a b -> MultiLens a b
@@ -37,3 +29,18 @@ getML (MLens f) = poss . f
modML :: MultiLens a b -> (b -> b) -> a -> a
modML (MLens f) g = peekss g . f
+
+infixr 4 ^%%=
+-- | applicative modify
+-- (id ^%%= h) = h
+-- (f . g) ^%%= h) = (g ^%%= (f ^%%= h))
+(^%%=) :: Applicative f => MultiLens a b -> (b -> f b) -> a -> f a
+MLens f ^%%= g = go g . f
+ where
+ {- this explicit passing of g is here to allow polymorphic recursion while remaining haskell 98 -}
+ go :: Applicative f => (b -> f b) -> (StaredStore b d) -> f d
+ go k (StaredStore s) = coproduct (pure . runIdentity) (r k) s
+ r :: Applicative f => (b -> f b) -> (StoreT b (StaredStore b) d) -> f d
+ r k st = go k h <*> k v
+ where
+ (h, v) = runStoreT st

0 comments on commit 55c6bf4

Please sign in to comment.