View effect (#271)

* Add Tagged Effect

* Add View effect

polysemy.cabal

@@ -4,7 +4,7 @@ cabal-version: 1.24
 --
 -- see: https://github.com/sol/hpack
 --
--- hash: 8a6be6da10631778dfdd107f8abaf266ea185e5b22d4a9ba78283ec5eff648b2
+-- hash: 522ece75c59adca1fc23637f8f0f6a2a5185fc52a0eb4c003c3a9dd76d1a94f6
 
 name:           polysemy
 version:        1.2.3.0
@@ -78,6 +78,7 @@ library
       Polysemy.State
       Polysemy.Tagged
       Polysemy.Trace
+      Polysemy.View
       Polysemy.Writer
   other-modules:
       Polysemy.Internal.PluginLookup
@@ -138,6 +139,7 @@ test-suite polysemy-test
       OutputSpec
       ThEffectSpec
       TypeErrors
+      ViewSpec
       WriterSpec
       Paths_polysemy
   hs-source-dirs:

src/Polysemy/Tagged.hs

@@ -6,6 +6,7 @@ module Polysemy.Tagged
 
     -- * Actions
   , tag
+  , tagged
 
     -- * Interpretations
   , untag
@@ -22,6 +23,7 @@ import Polysemy.Internal.Union
 newtype Tagged k e m a where
   Tagged :: forall k e m a. e m a -> Tagged k e m a
 
+
 ------------------------------------------------------------------------------
 -- | Tag uses of an effect, effectively gaining access to the
 -- tagged effect locally.
@@ -40,7 +42,8 @@ newtype Tagged k e m a where
 --   'tag' @k @('Polysemy.Reader.Reader' i) $ 'Polysemy.Reader.local' @i f ('raise' m)
 -- @
 --
-tag :: forall k e r a
+tag
+    :: forall k e r a
      . Member (Tagged k e) r
     => Sem (e ': r) a
     -> Sem r a
@@ -50,11 +53,28 @@ tag = hoistSem $ \u -> case decomp u of
   Left g -> hoist (tag @k) g
 {-# INLINE tag #-}
 
+
+------------------------------------------------------------------------------
+-- | A reinterpreting version of 'tag'.
+tagged
+    :: forall k e r a
+     . Sem (e ': r) a
+    -> Sem (Tagged k e ': r) a
+tagged = hoistSem $ \u ->
+  case decompCoerce u of
+    Right (Weaving e s wv ex ins) ->
+      injWeaving $ Weaving (Tagged @k e) s (tagged @k . wv) ex ins
+    Left g -> hoist (tagged @k) g
+{-# INLINE tagged #-}
+
+
+
 ------------------------------------------------------------------------------
 -- | Run a @'Tagged' k e@ effect through reinterpreting it to @e@
-untag :: forall k e r a
-       . Sem (Tagged k e ': r) a
-      -> Sem (e ': r) a
+untag
+    :: forall k e r a
+     . Sem (Tagged k e ': r) a
+    -> Sem (e ': r) a
 -- TODO(KingoftheHomeless): I think this is safe to replace with 'unsafeCoerce',
 -- but doing so probably worsens performance, as it hampers optimizations.
 -- Once GHC 8.10 rolls out, I will benchmark and compare.
@@ -64,12 +84,14 @@ untag = hoistSem $ \u -> case decompCoerce u of
   Left g -> hoist untag g
 {-# INLINE untag #-}
 
+
 ------------------------------------------------------------------------------
 -- | Transform a @'Tagged' k1 e@ effect into a @'Tagged' k2 e@ effect
-retag :: forall k1 k2 e r a
-       . Member (Tagged k2 e) r
-      => Sem (Tagged k1 e ': r) a
-      -> Sem r a
+retag
+    :: forall k1 k2 e r a
+     . Member (Tagged k2 e) r
+    => Sem (Tagged k1 e ': r) a
+    -> Sem r a
 retag = hoistSem $ \u -> case decomp u of
   Right (Weaving (Tagged e) s wv ex ins) ->
     injWeaving $ Weaving (Tagged @k2 e) s (retag @_ @k2 . wv) ex ins

src/Polysemy/View.hs

@@ -0,0 +1,76 @@
+{-# LANGUAGE TemplateHaskell #-}
+
+module Polysemy.View
+  ( -- * Effect
+    View (..)
+
+    -- * Actions
+  , see
+
+    -- * Interpretations
+  , viewToState
+  , viewToInput
+  ) where
+
+import Polysemy
+import Polysemy.Input
+import Polysemy.State
+import Polysemy.Tagged
+
+
+------------------------------------------------------------------------------
+-- | A 'View' is an expensive computation that should be cached.
+data View v m a where
+  See :: View v m v
+
+makeSem ''View
+
+
+------------------------------------------------------------------------------
+-- | Transform a 'View' into an 'Input'.
+viewToInput
+    :: forall v i r a
+     . Member (Input i) r
+    => (i -> v)
+    -> Sem (View v ': r) a
+    -> Sem r a
+viewToInput f = interpret $ \case
+  See -> f <$> input
+
+
+------------------------------------------------------------------------------
+-- | Get a 'View' as an exensive computation over an underlying 'State' effect.
+-- This 'View' is only invalidated when the underlying 'State' changes.
+viewToState
+    :: forall v s r a
+     . Member (State s) r
+    => (s -> Sem r v)
+    -> Sem (View v ': r) a
+    -> Sem r a
+viewToState f = do
+  evalState Dirty
+    . untag @"view" @(State (Cached v))
+    . intercept @(State s)
+      ( \case
+        Get -> get
+        Put s -> do
+          put s
+          tag @"view" @(State (Cached v)) $ put $ Dirty @v
+      )
+    . reinterpret @(View v)
+      ( \case
+          See -> do
+            dirty <- tagged @"view" $ get @(Cached v)
+            case dirty of
+              Dirty -> do
+                s <- get
+                v' <- raise $ f s
+                tagged @"view" $ put $ Cached v'
+                pure v'
+              Cached v -> pure v
+      )
+
+
+data Cached a = Cached a | Dirty
+  deriving (Eq, Ord, Show, Functor)
+

test/ViewSpec.hs

@@ -0,0 +1,40 @@
+module ViewSpec where
+
+import Polysemy
+import Polysemy.State
+import Polysemy.Trace
+import Polysemy.View
+import Test.Hspec
+
+
+check_see :: Members '[View String, Trace] r => Sem r ()
+check_see = trace . ("saw " ++) =<< see
+
+spec :: Spec
+spec = parallel $ do
+  describe "View effect" $ do
+    it "should cache views" $ do
+      let a = run
+            . runTraceList
+            . runState @Int 0
+            . viewToState @String @Int (\i -> do
+                  trace $ "caching "  ++ show i
+                  pure $ show i  ) $ do
+              check_see
+              check_see
+              put @Int 3
+              trace "it's lazy"
+              put @Int 5
+              check_see
+              check_see
+              get @Int
+
+      a `shouldBe` ([ "caching 0"
+                    , "saw 0"
+                    , "saw 0"
+                    , "it's lazy"
+                    , "caching 5"
+                    , "saw 5"
+                    , "saw 5"
+                    ], (5, 5))
+