git.iko.soy/typeable/thread-local
on master help sign in
Add polysemy interpreters for TLS.
commit01e9993996728116ae15dd529369a1be5be43be7 authorNick <nick@typeable.io> dateWed 19 Jul 2023, 16:05 (3 years ago) parent10965a0
11 files changed+93−66
unifiedsplit
.gitignore+3 LICENSE → polysemy-state-tls/LICENSE polysemy-state-tls/polysemy-state-tls.cabal+28 polysemy-state-tls/src/Polysemy/State/TLS.hs+31 stack.yaml+3−65 thread-local/LICENSE+20 example/Main.hs → thread-local/example/Main.hs−1 src/Control/Concurrent/ThreadLocal.hs → thread-local/src/Control/Concurrent/ThreadLocal.hs+3 src/Control/Concurrent/ThreadLocal/GC.hs → thread-local/src/Control/Concurrent/ThreadLocal/GC.hs src/Control/Concurrent/ThreadLocal/Internal.hs → thread-local/src/Control/Concurrent/ThreadLocal/Internal.hs+5 thread-local.cabal → thread-local/thread-local.cabal
.gitignorenew file+3
@@ -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'
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/
1+resolver: lts-21.1
62
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
323packages:
33−- .
34−# Dependency packages to be pulled from upstream that are not in the resolver.
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
4+- thread-local
5+- polysemy-state-tls
thread-local/LICENSEnew file+20
@@ -0,0 +1,20 @@
1+Copyright (c) 2023 Nick
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
1111main :: IO ()
1212main = do tls <- newThreadLocalWithGC 30
1313 replicateConcurrently_ 200000 (f tls)
14−-- printThreadLocal tls
1514
1615f :: ThreadLocal Word -> IO ()
1716f 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
99import Control.Concurrent.ThreadLocal.Internal
1010import Control.Concurrent.ThreadLocal.GC
1111
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.
1215newThreadLocalWithGC :: Word -> IO (ThreadLocal a)
1316newThreadLocalWithGC interval = do tls <- newThreadLocal
1417 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)
1313 }
1414
1515-- | 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.
1620newThreadLocal :: IO (ThreadLocal a)
1721newThreadLocal = do var <- newMVar Map.empty
1822 return (ThreadLocal var Nothing)
@@ -28,6 +32,7 @@ fetchThreadLocal (ThreadLocal var _) = do tid <- myThreadId
2832 m <- readMVar var
2933 return (Map.lookup tid m)
3034
35+-- | Delete a currently held value for this thread.
3136deleteThreadLocal :: ThreadLocal a -> IO ()
3237deleteThreadLocal (ThreadLocal var _) = do tid <- myThreadId
3338 modifyMVar_ var (pure . Map.delete tid)
thread-local.cabal → thread-local/thread-local.cabalrenamed

The content is the same.