10965a0..master · typeable/thread-local

.gitignorenew file+3

since splitsnapshots

unifiedsplit

@@ -0,0 +1,3 @@

1+.stack-work

2+*.~undo-tree~

3+stack.yaml.lock

LICENSE → polysemy-state-tls/LICENSErenamed

The content is the same.

polysemy-state-tls/polysemy-state-tls.cabalnew file+28

@@ -0,0 +1,28 @@

1+cabal-version: 3.0

2+name: polysemy-state-tls

3+version: 0.1

4+synopsis: Thread local state interpreter for Polysemy

5+-- description:

6+license: MIT

7+license-file: LICENSE

8+author: Nick

9+maintainer: nick@typeable.io

10+-- copyright:

11+category: Control

12+build-type: Simple

13+extra-doc-files: CHANGELOG.md

14+-- extra-source-files:

15+

16+common warnings

17+ ghc-options: -Wall

18+

19+library

20+ import: warnings

21+ exposed-modules: Polysemy.State.TLS

22+ -- other-modules:

23+ -- other-extensions:

24+ build-depends: base >=4.14 && < 5,

25+ thread-local,

26+ polysemy >= 1.7 && < 1.10

27+ hs-source-dirs: src

28+ default-language: Haskell2010

polysemy-state-tls/src/Polysemy/State/TLS.hsnew file+31

@@ -0,0 +1,31 @@

1+{-# LANGUAGE DataKinds #-}

2+{-# LANGUAGE FlexibleContexts #-}

3+{-# LANGUAGE GADTs #-}

4+{-# LANGUAGE ScopedTypeVariables #-}

5+{-# LANGUAGE TypeOperators #-}

6+module Polysemy.State.TLS where

7+

8+import Control.Concurrent.ThreadLocal

9+import Data.Maybe (fromMaybe)

10+import Polysemy

11+import Polysemy.State

12+

13+

14+-- | Evaluate the 'State' effect using 'ThreadLocal' semantincs.

15+-- Note that this can only work over state being wrapped in 'Maybe', since the storage for the current thread

16+-- can be empty. For an alternative, see 'runTLStateWithDefault'.

17+runTLState :: forall s r a. Member (Embed IO) r => ThreadLocal s -> Sem (State (Maybe s) ': r) a -> Sem r a

18+runTLState tls = interpret f

19+ where f :: forall r' x. State (Maybe s) (Sem r') x -> Sem r x

20+ f Get = embed (fetchThreadLocal tls)

21+ f (Put (Just v)) = embed (insertThreadLocal v tls)

22+ f (Put Nothing) = embed (deleteThreadLocal tls)

23+

24+-- | Evaluate the 'State' effect using 'ThreadLocal' semantincs.

25+-- The default value needs to be provided for cases where the value for the given thread isn't yet set,

26+-- i.e. 'get' is called before 'put'.

27+runTLStateWithDefault :: forall s r a. Member (Embed IO) r => s -> ThreadLocal s -> Sem (State s ': r) a -> Sem r a

28+runTLStateWithDefault def tls = interpret f

29+ where f :: forall r' x. State s (Sem r') x -> Sem r x

30+ f Get = fromMaybe def <$> embed (fetchThreadLocal tls)

31+ f (Put v) = embed (insertThreadLocal v tls)

stack.yaml+3−65

@@ -1,67 +1,5 @@

1−# This file was automatically generated by 'stack init'

1+resolver: lts-21.1

2−#

3−# Some commonly used options have been documented as comments in this file.

4−# For advanced use and comprehensive documentation of the format, please see:

5−# https://docs.haskellstack.org/en/stable/yaml_configuration/

6

2

7−# Resolver to choose a 'specific' stackage snapshot or a compiler version.

8−# A snapshot resolver dictates the compiler version and the set of packages

9−# to be used for project dependencies. For example:

10−#

11−# resolver: lts-3.5

12−# resolver: nightly-2015-09-21

13−# resolver: ghc-7.10.2

14−#

15−# The location of a snapshot can be provided as a file or url. Stack assumes

16−# a snapshot provided as a file might change, whereas a url resource does not.

17−#

18−# resolver: ./custom-snapshot.yaml

19−# resolver: https://example.com/snapshots/2018-01-01.yaml

20−resolver:

21− url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/21/1.yaml

22−

23−# User packages to be built.

24−# Various formats can be used as shown in the example below.

25−#

26−# packages:

27−# - some-directory

28−# - https://example.com/foo/bar/baz-0.0.2.tar.gz

29−# subdirs:

30−# - auto-update

31−# - wai

32packages:

3packages:

33−- .

4+- thread-local

34−# Dependency packages to be pulled from upstream that are not in the resolver.

5+- polysemy-state-tls

35−# These entries can reference officially published versions as well as

36−# forks / in-progress versions pinned to a git hash. For example:

37−#

38−# extra-deps:

39−# - acme-missiles-0.3

40−# - git: https://github.com/commercialhaskell/stack.git

41−# commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a

42−#

43−# extra-deps: []

44−

45−# Override default flag values for local packages and extra-deps

46−# flags: {}

47−

48−# Extra package databases containing global packages

49−# extra-package-dbs: []

50−

51−# Control whether we use the GHC we find on the path

52−# system-ghc: true

53−#

54−# Require a specific version of stack, using version ranges

55−# require-stack-version: -any # Default

56−# require-stack-version: ">=2.9"

57−#

58−# Override the architecture used by stack, especially useful on Windows

59−# arch: i386

60−# arch: x86_64

61−#

62−# Extra directories used by stack for building

63−# extra-include-dirs: [/path/to/dir]

64−# extra-lib-dirs: [/path/to/dir]

65−#

66−# Allow a newer minor version of GHC than the snapshot specifies

67−# compiler-check: newer-minor

thread-local/LICENSEnew file+20

@@ -0,0 +1,20 @@

2+

3+Permission is hereby granted, free of charge, to any person obtaining

4+a copy of this software and associated documentation files (the

5+"Software"), to deal in the Software without restriction, including

6+without limitation the rights to use, copy, modify, merge, publish,

7+distribute, sublicense, and/or sell copies of the Software, and to

8+permit persons to whom the Software is furnished to do so, subject to

9+the following conditions:

10+

11+The above copyright notice and this permission notice shall be included

12+in all copies or substantial portions of the Software.

13+

14+THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,

15+EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF

16+MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.

17+IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY

18+CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,

19+TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE

20+SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.

example/Main.hs → thread-local/example/Main.hsrenamed−1

@@ -11,7 +11,6 @@ import System.Random

11main :: IO ()

12main = do tls <- newThreadLocalWithGC 30

13 replicateConcurrently_ 200000 (f tls)

14−-- printThreadLocal tls

15

14

16f :: ThreadLocal Word -> IO ()

15f :: ThreadLocal Word -> IO ()

17f tls = do v :: Word <- randomIO

16f tls = do v :: Word <- randomIO

src/Control/Concurrent/ThreadLocal.hs → thread-local/src/Control/Concurrent/ThreadLocal.hsrenamed+3

@@ -9,6 +9,9 @@ module Control.Concurrent.ThreadLocal ( ThreadLocal -- exported opaque

9import Control.Concurrent.ThreadLocal.Internal

10import Control.Concurrent.ThreadLocal.GC

11

12+-- | The version of 'newThreadLocal' that also launches a separate GC thread.

13+-- Takes the interval for GC in seconds. GC thread dies automatically once

14+-- 'ThreadLocal' is collected.

12newThreadLocalWithGC :: Word -> IO (ThreadLocal a)

15newThreadLocalWithGC :: Word -> IO (ThreadLocal a)

13newThreadLocalWithGC interval = do tls <- newThreadLocal

16newThreadLocalWithGC interval = do tls <- newThreadLocal

14 addGC tls interval

17 addGC tls interval

src/Control/Concurrent/ThreadLocal/GC.hs → thread-local/src/Control/Concurrent/ThreadLocal/GC.hsrenamed

The content is the same.

src/Control/Concurrent/ThreadLocal/Internal.hs → thread-local/src/Control/Concurrent/ThreadLocal/Internal.hsrenamed+5

@@ -13,6 +13,10 @@ data ThreadLocal a = ThreadLocal { mvar :: MVar (ThreadMap a)

13 }

14

15-- | Create a new thread local storage of type 'a'

16+-- Note that TLS created by this function will accumulate dead threads

17+-- and thus leak memory during its lifetime. This is mostly fine for shorter-living

18+-- instances. If you plan on having this 'ThreadLocal' live longer than a while,

19+-- consider using 'newThreadLocalWithGC' instead.

16newThreadLocal :: IO (ThreadLocal a)

20newThreadLocal :: IO (ThreadLocal a)

17newThreadLocal = do var <- newMVar Map.empty

21newThreadLocal = do var <- newMVar Map.empty

18 return (ThreadLocal var Nothing)

22 return (ThreadLocal var Nothing)

@@ -28,6 +32,7 @@ fetchThreadLocal (ThreadLocal var _) = do tid <- myThreadId

28 m <- readMVar var

32 m <- readMVar var

29 return (Map.lookup tid m)

33 return (Map.lookup tid m)

30

34

35+-- | Delete a currently held value for this thread.

31deleteThreadLocal :: ThreadLocal a -> IO ()

36deleteThreadLocal :: ThreadLocal a -> IO ()

32deleteThreadLocal (ThreadLocal var _) = do tid <- myThreadId

37deleteThreadLocal (ThreadLocal var _) = do tid <- myThreadId

33 modifyMVar_ var (pure . Map.delete tid)

38 modifyMVar_ var (pure . Map.delete tid)

thread-local.cabal → thread-local/thread-local.cabalrenamed

The content is the same.