context 0.1.0.0 → 0.1.1.0

raw patch · 9 files changed

+188/−35 lines, 9 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• CHANGELOG.md +6/−0
• context.cabal +3/−2
• library/Context.hs +7/−25
• library/Context/Concurrent.hs +0/−2
• library/Context/Internal.hs +61/−0
• library/Context/Storage.hs +0/−5
• library/Context/View.hs +10/−0
• package.yaml +1/−1
• test-suite/Test/ContextSpec.hs +100/−0

@@ -1,5 +1,11 @@ # Change log +## 0.1.1.0++* Add `Context.View` module, which includes the `View` type + `view`, `viewMay`,+  and `toView` functions+* Re-export `Context.View` from `Context`+ ## 0.1.0.0  Initial release

@@ -4,10 +4,10 @@ -- -- see: https://github.com/sol/hpack ----- hash: f039a0aad49f186ced980c33e32c16906b02598865a644fb1142fda2f631183d+-- hash: ce95004f91aeb67f72f59d4f0974849fc2faec02ea490576740aab04f9ccf575  name:           context-version:        0.1.0.0+version:        0.1.1.0 synopsis:       Thread-indexed, nested contexts description:    Thread-indexed storage around arbitrary context values. The interface supports                 nesting context values per thread, and at any point, the calling thread may@@ -38,6 +38,7 @@       Context.Implicit       Context.Internal       Context.Storage+      Context.View   other-modules:       Paths_context   hs-source-dirs:

@@ -1,9 +1,4 @@-{-# LANGUAGE DeriveAnyClass #-}-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE DerivingStrategies #-}-{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE NoImplicitPrelude #-}-{-# LANGUAGE StrictData #-}  module Context   ( -- * Introduction@@ -26,6 +21,9 @@   , mineMay   , minesMay +    -- * Views+  , module Context.View+     -- * Exceptions   , NotFoundException(NotFoundException, threadId) @@ -37,24 +35,13 @@   ) where  import Context.Concurrent-import Context.Internal (Store, mineMay, use)+import Context.Internal (NotFoundException(NotFoundException, threadId), Store, mineMay, use) import Context.Storage-import Control.Exception (Exception)+import Context.View import Control.Monad ((<=<))-import GHC.Generics (Generic) import Prelude import qualified Context.Internal as Internal-import qualified Control.Exception as Exception --- | An exception which may be thrown via 'mine', 'mines', and 'adjust' when the--- calling thread does not have a registered context.------ @since 0.1.0.0-data NotFoundException = NotFoundException-  { threadId :: ThreadId-  } deriving stock (Eq, Generic, Show)-    deriving anyclass Exception- -- | Provides a new, non-empty 'Store' that uses the specified context value as a -- default when the calling thread has no registered context. 'mine', 'mines', -- and 'adjust' are guaranteed to never throw 'NotFoundException' when applied@@ -88,7 +75,7 @@ -- -- @since 0.1.0.0 mine :: Store ctx -> IO ctx-mine = maybe throwContextNotFound pure <=< mineMay+mine = maybe Internal.throwContextNotFound pure <=< mineMay  -- | Provide the calling thread a selection from its current context in the -- specified 'Store'. Throws a 'NotFoundException' when the calling@@ -96,7 +83,7 @@ -- -- @since 0.1.0.0 mines :: Store ctx -> (ctx -> a) -> IO a-mines store = maybe throwContextNotFound pure <=< minesMay store+mines store = maybe Internal.throwContextNotFound pure <=< minesMay store  -- | Provide the calling thread a selection from its current context in the -- specified 'Store', if present.@@ -104,11 +91,6 @@ -- @since 0.1.0.0 minesMay :: Store ctx -> (ctx -> a) -> IO (Maybe a) minesMay store selector = fmap (fmap selector) $ mineMay store--throwContextNotFound :: IO a-throwContextNotFound = do-  threadId <- myThreadId-  Exception.throwIO $ NotFoundException { threadId }  -- $intro --

@@ -1,6 +1,4 @@ {-# LANGUAGE BlockArguments #-}-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE RankNTypes #-} 

@@ -1,4 +1,7 @@ {-# LANGUAGE BlockArguments #-}+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE GADTs #-}@@ -14,6 +17,7 @@     -- ** Store-related     Store(Store, ref, key)   , State(State, stacks, def)+  , NotFoundException(NotFoundException, threadId)   , withStore   , newStore   , use@@ -22,7 +26,14 @@   , mineMay   , mineMayOnDefault   , setDefault+  , throwContextNotFound +    -- ** View-related+  , View(MkView)+  , view+  , viewMay+  , toView+     -- ** Propagation-related   , PropagationStrategy(NoPropagation, LatestPropagation)   , Registry(Registry, ref)@@ -39,9 +50,12 @@   ) where  import Control.Concurrent (ThreadId)+import Control.Exception (Exception)+import Control.Monad ((<=<)) import Data.IORef (IORef) import Data.Map.Strict (Map) import Data.Unique (Unique)+import GHC.Generics (Generic) import GHC.Stack (HasCallStack) import Prelude import System.IO.Unsafe (unsafePerformIO)@@ -65,6 +79,15 @@   , def :: Maybe ctx   } +-- | An exception which may be thrown when the calling thread does not have a+-- registered context.+--+-- @since 0.1.0.0+data NotFoundException = NotFoundException+  { threadId :: ThreadId+  } deriving stock (Eq, Generic, Show)+    deriving anyclass Exception+ -- | The 'PropagationStrategy' controls the behavior used by -- "Context.Concurrent" when propagating context from a "parent" thread to a new -- thread.@@ -100,6 +123,11 @@   IORef.atomicModifyIORef' ref \state ->     (state { def = Just context }, ()) +throwContextNotFound :: IO a+throwContextNotFound = do+  threadId <- Concurrent.myThreadId+  Exception.throwIO $ NotFoundException { threadId }+ -- | Provide the calling thread its current context from the specified -- 'Store', if present. --@@ -216,6 +244,39 @@         (state { stacks = Map.delete threadId stacks }, ())       Just (_context : rest) ->         (state { stacks = Map.insert threadId rest stacks }, ())++-- | A 'View' provides a read-only view into a 'Store'. 'View' trades the+-- 'Store' ability to register new context for the ability to arbitrarily+-- transform context values locally to the 'View'.+--+-- @since 0.2.0.0+data View ctx where+  MkView :: (ctx' -> ctx) -> Store ctx' -> View ctx++instance Functor View where+  fmap g (MkView f store) = MkView (g . f) store++-- | Provide the calling thread a view of its current context from the specified+-- 'View'. Throws a 'Context.NotFoundException' when the calling thread has no+-- registered context.+--+-- @since 0.2.0.0+view :: View ctx -> IO ctx+view = maybe throwContextNotFound pure <=< viewMay++-- | Provide the calling thread a view of its current context from the specified+-- 'View', if present.+--+-- @since 0.2.0.0+viewMay :: View ctx -> IO (Maybe ctx)+viewMay = \case+  MkView f store -> fmap (fmap f) $ mineMay store++-- | Create a 'View' from the provided 'Store'.+--+-- @since 0.2.0.0+toView :: Store ctx -> View ctx+toView = MkView id  data AnyStore where   MkAnyStore :: forall ctx. Store ctx -> AnyStore

@@ -1,9 +1,4 @@-{-# LANGUAGE DeriveAnyClass #-}-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE DerivingStrategies #-}-{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE NoImplicitPrelude #-}-{-# LANGUAGE StrictData #-}  module Context.Storage   ( -- * Introduction

@@ -0,0 +1,10 @@+{-# LANGUAGE NoImplicitPrelude #-}++module Context.View+  ( View+  , view+  , viewMay+  , toView+  ) where++import Context.Internal (View, view, viewMay, toView)

@@ -1,5 +1,5 @@ name: context-version: '0.1.0.0'+version: '0.1.1.0' github: "jship/context" license: MIT license-file: LICENSE.md

@@ -19,6 +19,10 @@   { stuff :: Int   } deriving stock (Eq, Show) +data OtherThing = OtherThing+  { otherStuff :: Int+  } deriving stock (Eq, Show)+ spec :: Spec spec = do   describe "withEmptyStore" do@@ -471,9 +475,105 @@           Context.setDefault store Thing { stuff = 2 }           Context.mineMay store `shouldReturn` Just Thing { stuff = 2 } +    describe "viewMay" do+      it "empty" do+        Context.withEmptyStore @Thing \store -> do+          let storeView = fmap toOtherThing $ Context.toView store+          Context.viewMay storeView `shouldReturn` Nothing+      it "single context" do+        Context.withEmptyStore @Thing \store -> do+          let storeView = fmap toOtherThing $ Context.toView store+          Context.use store Thing { stuff = 1 } do+            Context.viewMay storeView `shouldReturn` Just OtherThing { otherStuff = 1 }+          Context.viewMay storeView `shouldReturn` Nothing+      it "nested contexts" do+        Context.withEmptyStore @Thing \store -> do+          let storeView = fmap toOtherThing $ Context.toView store+          Context.use store Thing { stuff = 1 } do+            Context.viewMay storeView `shouldReturn` Just OtherThing { otherStuff = 1 }+            Context.use store Thing { stuff = 2 } do+              Context.viewMay storeView `shouldReturn` Just OtherThing { otherStuff = 2 }+              Context.use store Thing { stuff = 3 } do+                Context.viewMay storeView `shouldReturn` Just OtherThing { otherStuff = 3 }+              Context.viewMay storeView `shouldReturn` Just OtherThing { otherStuff = 2 }+            Context.use store Thing { stuff = 4 } do+              Context.viewMay storeView `shouldReturn` Just OtherThing { otherStuff = 4 }+            Context.viewMay storeView `shouldReturn` Just OtherThing { otherStuff = 1 }+          Context.viewMay storeView `shouldReturn` Nothing+      it "concurrent nested contexts" do+        let mkContext i = Thing { stuff = i }+        Context.withEmptyStore @Thing \store -> do+          let storeView = fmap toOtherThing $ Context.toView store+          Async.forConcurrently_ [1 :: Int ..10] $ const do+            Context.viewMay storeView `shouldReturn` Nothing+            Context.use store (mkContext 1) do+              Context.viewMay storeView `shouldReturn` Just (toOtherThing $ mkContext 1)+              Context.use store (mkContext 2) do+                Context.viewMay storeView `shouldReturn` Just (toOtherThing $ mkContext 2)+                Context.use store (mkContext 3) do+                  Context.viewMay storeView `shouldReturn` Just (toOtherThing $ mkContext 3)+                Context.viewMay storeView `shouldReturn` Just (toOtherThing $ mkContext 2)+              Context.use store (mkContext 4) do+                Context.viewMay storeView `shouldReturn` Just (toOtherThing $ mkContext 4)+              Context.viewMay storeView `shouldReturn` Just (toOtherThing $ mkContext 1)+            Context.viewMay storeView `shouldReturn` Nothing+          Context.viewMay storeView `shouldReturn` Nothing++    describe "view" do+      it "empty" do+        Context.withEmptyStore @Thing \store -> do+          let storeView = fmap toOtherThing $ Context.toView store+          threadId <- Concurrent.myThreadId+          Context.view storeView `shouldThrow` notFound threadId+      it "single context" do+        Context.withEmptyStore @Thing \store -> do+          let storeView = fmap toOtherThing $ Context.toView store+          threadId <- Concurrent.myThreadId+          Context.use store Thing { stuff = 1 } do+            Context.view storeView `shouldReturn` OtherThing { otherStuff = 1 }+          Context.view storeView `shouldThrow` notFound threadId+      it "nested contexts" do+        Context.withEmptyStore @Thing \store -> do+          let storeView = fmap toOtherThing $ Context.toView store+          threadId <- Concurrent.myThreadId+          Context.use store Thing { stuff = 1 } do+            Context.view storeView `shouldReturn` OtherThing { otherStuff = 1 }+            Context.use store Thing { stuff = 2 } do+              Context.view storeView `shouldReturn` OtherThing { otherStuff = 2 }+              Context.use store Thing { stuff = 3 } do+                Context.view storeView `shouldReturn` OtherThing { otherStuff = 3 }+              Context.view storeView `shouldReturn` OtherThing { otherStuff = 2 }+            Context.use store Thing { stuff = 4 } do+              Context.view storeView `shouldReturn` OtherThing { otherStuff = 4 }+            Context.view storeView `shouldReturn` OtherThing { otherStuff = 1 }+          Context.view storeView `shouldThrow` notFound threadId+      it "concurrent nested contexts" do+        let mkContext i = Thing { stuff = i }+        initThreadId <- Concurrent.myThreadId+        Context.withEmptyStore @Thing \store -> do+          let storeView = fmap toOtherThing $ Context.toView store+          Async.forConcurrently_ [1 :: Int ..10] $ const do+            threadId <- Concurrent.myThreadId+            Context.view storeView `shouldThrow` notFound threadId+            Context.use store (mkContext 1) do+              Context.view storeView `shouldReturn` (toOtherThing $ mkContext 1)+              Context.use store (mkContext 2) do+                Context.view storeView `shouldReturn` (toOtherThing $ mkContext 2)+                Context.use store (mkContext 3) do+                  Context.view storeView `shouldReturn` (toOtherThing $ mkContext 3)+                Context.view storeView `shouldReturn` (toOtherThing $ mkContext 2)+              Context.use store (mkContext 4) do+                Context.view storeView `shouldReturn` (toOtherThing $ mkContext 4)+              Context.view storeView `shouldReturn` (toOtherThing $ mkContext 1)+            Context.view storeView `shouldThrow` notFound threadId+          Context.view storeView `shouldThrow` notFound initThreadId+ notFound :: ThreadId -> Context.NotFoundException -> Bool notFound threadId notFoundEx =   Context.NotFoundException { Context.threadId } == notFoundEx  modifier :: Thing -> Thing modifier thing = thing { stuff = 2 * stuff thing }++toOtherThing :: Thing -> OtherThing+toOtherThing Thing { stuff } = OtherThing { otherStuff = stuff }