Skip to content

Commit eab2cfb

Browse files
mtesseractmtesseract
committed
Import
0 parents  commit eab2cfb

File tree

10 files changed

+341
-0
lines changed

10 files changed

+341
-0
lines changed

‎.gitignore

+19
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,19 @@
1+
dist
2+
dist-*
3+
cabal-dev
4+
*.o
5+
*.hi
6+
*.chi
7+
*.chs.h
8+
*.dyn_o
9+
*.dyn_hi
10+
.hpc
11+
.hsenv
12+
.cabal-sandbox/
13+
cabal.sandbox.config
14+
*.prof
15+
*.aux
16+
*.hp
17+
*.eventlog
18+
.stack-work/
19+
cabal.project.local

‎LICENSE

+30
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,30 @@
1+
Copyright Moritz Schulte (c) 2016, 2017
2+
3+
All rights reserved.
4+
5+
Redistribution and use in source and binary forms, with or without
6+
modification, are permitted provided that the following conditions are met:
7+
8+
* Redistributions of source code must retain the above copyright
9+
notice, this list of conditions and the following disclaimer.
10+
11+
* Redistributions in binary form must reproduce the above
12+
copyright notice, this list of conditions and the following
13+
disclaimer in the documentation and/or other materials provided
14+
with the distribution.
15+
16+
* Neither the name of Author name here nor the names of other
17+
contributors may be used to endorse or promote products derived
18+
from this software without specific prior written permission.
19+
20+
THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
21+
"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
22+
LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
23+
A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
24+
OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
25+
SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
26+
LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
27+
DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
28+
THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
29+
(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
30+
OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

‎README.md

+11
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,11 @@
1+
# async-timer
2+
3+
Example:
4+
5+
let conf = defaultTimerConf & timerConfSetInitDelay 500 -- 500 ms
6+
& timerConfSetInterval 1000 -- 1 s
7+
8+
withAsyncTimer conf $ \ timer -> do
9+
forM_ [1..10] $ \_ -> do
10+
timerWait timer
11+
putStrLn "Tick"

‎Setup.hs

+2
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,2 @@
1+
import Distribution.Simple
2+
main = defaultMain

‎async-timer.cabal

+47
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,47 @@
1+
name: async-timer
2+
version: 0.1.2
3+
synopsis: Support for timer based execution of IO actions
4+
description: Please see README.md
5+
homepage: https://github.com/mtesseract/async-timer
6+
license: BSD3
7+
license-file: LICENSE
8+
author: Moritz Schulte
9+
maintainer: [email protected]
10+
copyright: 2016, 2017 Moritz Schulte
11+
category: Concurrency
12+
build-type: Simple
13+
extra-source-files: README.md
14+
cabal-version: >=1.10
15+
16+
library
17+
hs-source-dirs: src
18+
exposed-modules: Control.Concurrent.Async.Timer
19+
, Control.Concurrent.Async.Timer.Unsafe
20+
other-modules: Control.Concurrent.Async.Timer.Internal
21+
build-depends: base >= 4.7 && < 5
22+
, lifted-async
23+
, classy-prelude
24+
default-language: Haskell2010
25+
default-extensions: NoImplicitPrelude
26+
ghc-options: -Wall
27+
28+
test-suite async-timer-test
29+
type: exitcode-stdio-1.0
30+
hs-source-dirs: test
31+
main-is: Spec.hs
32+
build-depends: base
33+
, classy-prelude
34+
, async-timer
35+
, HUnit
36+
, test-framework
37+
, test-framework-hunit
38+
, containers
39+
, criterion
40+
ghc-options: -threaded -rtsopts -with-rtsopts=-N
41+
default-language: Haskell2010
42+
default-extensions: NoImplicitPrelude
43+
, OverloadedStrings
44+
45+
source-repository head
46+
type: git
47+
location: https://github.com/mtesseract/async-timer

‎src/Control/Concurrent/Async/Timer.hs

+30
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,30 @@
1+
{-# LANGUAGE FlexibleContexts #-}
2+
{-# LANGUAGE MultiParamTypeClasses #-}
3+
{-# LANGUAGE RankNTypes #-}
4+
5+
module Control.Concurrent.Async.Timer
6+
( Timer
7+
, defaultTimerConf
8+
, timerConfSetInitDelay
9+
, timerConfSetInterval
10+
, withAsyncTimer
11+
, timerWait
12+
) where
13+
14+
import ClassyPrelude
15+
import Control.Concurrent.Async.Timer.Internal
16+
17+
withAsyncTimer :: forall m b. (MonadBaseControl IO m, Forall (Pure m))
18+
=> TimerConf -> (Timer -> m b) -> m b
19+
withAsyncTimer conf io = do
20+
mVar <- newEmptyMVar
21+
let timer = Timer { timerMVar = mVar }
22+
timerTrigger = void $ tryPutMVar mVar ()
23+
initDelay' = toMicroseconds $ _timerConfInitDelay conf
24+
interval' = toMicroseconds $ _timerConfInterval conf
25+
timerThread = timerLoop (threadDelay initDelay')
26+
(threadDelay interval')
27+
timerTrigger
28+
withAsync timerThread $ const (io timer)
29+
30+
where toMicroseconds x = x * (10 ^ (3 :: Int))

‎src/Control/Concurrent/Async/Timer/Internal.hs

+37
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,37 @@
1+
{-# LANGUAGE FlexibleContexts #-}
2+
{-# LANGUAGE ForeignFunctionInterface #-}
3+
{-# LANGUAGE InterruptibleFFI #-}
4+
{-# LANGUAGE MultiParamTypeClasses #-}
5+
6+
module Control.Concurrent.Async.Timer.Internal where
7+
8+
import ClassyPrelude
9+
10+
-- | Sleep 'dt' milliseconds.
11+
millisleep :: Int64 -> IO ()
12+
millisleep dt = threadDelay (fromIntegral dt * 10 ^ (3 :: Int))
13+
14+
data TimerConf = TimerConf { _timerConfInitDelay :: Int
15+
, _timerConfInterval :: Int }
16+
17+
defaultTimerConf :: TimerConf
18+
defaultTimerConf = TimerConf { _timerConfInitDelay = 0
19+
, _timerConfInterval = 1000 }
20+
21+
timerConfSetInitDelay :: Int -> TimerConf -> TimerConf
22+
timerConfSetInitDelay n conf = conf { _timerConfInitDelay = n }
23+
24+
timerConfSetInterval :: Int -> TimerConf -> TimerConf
25+
timerConfSetInterval n conf = conf { _timerConfInterval = n }
26+
27+
data Timer = Timer { timerMVar :: MVar () }
28+
29+
timerLoop :: MonadBaseControl IO m
30+
=> m () -> m () -> m () -> m ()
31+
timerLoop initDelay intervalDelay timerTrigger = do
32+
initDelay
33+
forever $ timerTrigger >> intervalDelay
34+
35+
timerWait :: MonadBaseControl IO m
36+
=> Timer -> m ()
37+
timerWait = void . takeMVar . timerMVar

‎src/Control/Concurrent/Async/Timer/Unsafe.hs

+31
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,31 @@
1+
{-# LANGUAGE FlexibleContexts #-}
2+
{-# LANGUAGE MultiParamTypeClasses #-}
3+
{-# LANGUAGE RankNTypes #-}
4+
5+
module Control.Concurrent.Async.Timer.Unsafe
6+
( Timer
7+
, defaultTimerConf
8+
, timerConfSetInitDelay
9+
, timerConfSetInterval
10+
, withAsyncTimer
11+
, timerWait
12+
) where
13+
14+
import ClassyPrelude
15+
import qualified Control.Concurrent.Async.Lifted as Unsafe
16+
import Control.Concurrent.Async.Timer.Internal
17+
18+
withAsyncTimer :: forall m b. (MonadBaseControl IO m)
19+
=> TimerConf -> (Timer -> m b) -> m b
20+
withAsyncTimer conf io = do
21+
mVar <- newEmptyMVar
22+
let timer = Timer { timerMVar = mVar }
23+
timerTrigger = void $ tryPutMVar mVar ()
24+
initDelay' = toMicroseconds $ _timerConfInitDelay conf
25+
interval' = toMicroseconds $ _timerConfInterval conf
26+
timerThread = timerLoop (threadDelay initDelay')
27+
(threadDelay interval')
28+
timerTrigger
29+
Unsafe.withAsync timerThread $ const (io timer)
30+
31+
where toMicroseconds x = x * (10 ^ (3 :: Int))

‎stack.yaml

+66
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,66 @@
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+
# http://docs.haskellstack.org/en/stable/yaml_configuration/
6+
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+
# resolver: ghcjs-0.1.0_ghc-7.10.2
15+
# resolver:
16+
# name: custom-snapshot
17+
# location: "./custom-snapshot.yaml"
18+
resolver: lts-8.5
19+
20+
# User packages to be built.
21+
# Various formats can be used as shown in the example below.
22+
#
23+
# packages:
24+
# - some-directory
25+
# - https://example.com/foo/bar/baz-0.0.2.tar.gz
26+
# - location:
27+
# git: https://github.com/commercialhaskell/stack.git
28+
# commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a
29+
# - location: https://github.com/commercialhaskell/stack/commit/e7b331f14bcffb8367cd58fbfc8b40ec7642100a
30+
# extra-dep: true
31+
# subdirs:
32+
# - auto-update
33+
# - wai
34+
#
35+
# A package marked 'extra-dep: true' will only be built if demanded by a
36+
# non-dependency (i.e. a user package), and its test suites and benchmarks
37+
# will not be run. This is useful for tweaking upstream packages.
38+
packages:
39+
- '.'
40+
# Dependency packages to be pulled from upstream that are not in the resolver
41+
# (e.g., acme-missiles-0.3)
42+
extra-deps: []
43+
44+
# Override default flag values for local packages and extra-deps
45+
flags: {}
46+
47+
# Extra package databases containing global packages
48+
extra-package-dbs: []
49+
50+
# Control whether we use the GHC we find on the path
51+
# system-ghc: true
52+
#
53+
# Require a specific version of stack, using version ranges
54+
# require-stack-version: -any # Default
55+
# require-stack-version: ">=1.2"
56+
#
57+
# Override the architecture used by stack, especially useful on Windows
58+
# arch: i386
59+
# arch: x86_64
60+
#
61+
# Extra directories used by stack for building
62+
# extra-include-dirs: [/path/to/dir]
63+
# extra-lib-dirs: [/path/to/dir]
64+
#
65+
# Allow a newer minor version of GHC than the snapshot specifies
66+
# compiler-check: newer-minor

‎test/Spec.hs

+68
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,68 @@
1+
module Main where
2+
3+
import ClassyPrelude
4+
import Data.Function ((&))
5+
import Test.Framework (Test, defaultMain, testGroup)
6+
import Test.Framework.Providers.HUnit (testCase)
7+
import Test.HUnit ((@?=))
8+
import Criterion.Measurement
9+
import Control.Concurrent.Async.Timer
10+
import Data.Typeable
11+
12+
data MyException = MyException
13+
deriving (Show, Typeable)
14+
15+
instance Exception MyException
16+
17+
main :: IO ()
18+
main = do
19+
cap <- getNumCapabilities
20+
putStrLn ""
21+
putStrLn $ "Cap = " ++ tshow cap
22+
defaultMain tests
23+
24+
tests :: [Test.Framework.Test]
25+
tests =
26+
[ testGroup "1st Test Group"
27+
[ testCase "1st Test" test1 ]
28+
]
29+
30+
test1 :: IO ()
31+
test1 = do
32+
let conf = defaultTimerConf & timerConfSetInitDelay 0
33+
& timerConfSetInterval 1000 -- ms
34+
35+
counter <- newIORef 0
36+
times <- newIORef []
37+
38+
withAsyncTimer conf $ \ timer -> do
39+
forM_ [1..10] $ \_ -> do
40+
timerWait timer
41+
void $ fork $ myAction counter times
42+
43+
threadDelay 1000
44+
n <- readIORef counter
45+
n @?= 10
46+
47+
ts <- readIORef times
48+
let deltas = case ts of
49+
[] -> []
50+
_ : tsTail -> map (\ (a, b) -> a - b) $ zip ts tsTail
51+
52+
diff = sum deltas - 9
53+
forM_ deltas (\ dt -> putStrLn $ "dt = " ++ tshow dt)
54+
putStrLn $ "average dt = " ++ tshow diff
55+
return ()
56+
57+
where myAction :: IORef Int -> IORef [Double] -> IO ()
58+
myAction counter times = do
59+
t <- getTime
60+
n <- readIORef counter
61+
if n == 10
62+
then throwIO MyException
63+
else return ()
64+
let n' = n + 1
65+
writeIORef counter n'
66+
modifyIORef times (t :)
67+
putStrLn $ "Tick no. " ++ tshow n' ++ " (t = " ++ tshow t ++ ")"
68+
threadDelay 500000

0 commit comments

Comments
 (0)