1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
|
-- |
-- Module: Control.Wire.Session
-- Copyright: (c) 2013 Ertugrul Soeylemez
-- License: BSD3
-- Maintainer: Ertugrul Soeylemez <es@ertes.de>
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveFoldable #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE DeriveTraversable #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE MultiParamTypeClasses #-}
module Control.Wire.Session
( -- * State delta types
HasTime(..),
Session(..),
-- ** Wires with time
Timed(..),
clockSession,
clockSession_,
countSession,
countSession_
)
where
import Control.Applicative
import Control.Monad.IO.Class
import Data.Data
import Data.Foldable (Foldable)
import Data.Semigroup
import Data.Time.Clock
import Data.Traversable (Traversable)
-- | State delta types with time deltas.
class (Monoid s, Real t) => HasTime t s | s -> t where
-- | Extract the current time delta.
dtime :: s -> t
-- | State delta generators as required for wire sessions, most notably
-- to generate time deltas. These are mini-wires with the sole purpose
-- of generating these deltas.
newtype Session m s =
Session {
stepSession :: m (s, Session m s)
}
deriving (Functor)
instance (Applicative m) => Applicative (Session m) where
pure x = let s = Session (pure (x, s)) in s
Session ff <*> Session fx =
Session $ liftA2 (\(f, sf) (x, sx) -> (f x, sf <*> sx)) ff fx
-- | This state delta type denotes time deltas. This is necessary for
-- most FRP applications.
data Timed t s = Timed t s
deriving (Data, Eq, Foldable, Functor,
Ord, Read, Show, Traversable, Typeable)
instance (Semigroup s, Monoid s, Real t) => HasTime t (Timed t s) where
dtime (Timed dt _) = dt
instance (Semigroup s, Num t) => Semigroup (Timed t s) where
Timed dt1 ds1 <> Timed dt2 ds2 =
let dt = dt1 + dt2
ds = ds1 <> ds2
in dt `seq` ds `seq` Timed dt ds
instance (Semigroup s, Monoid s, Num t) => Monoid (Timed t s) where
mempty = Timed 0 mempty
mappend = (<>)
-- | State delta generator for a real time clock.
clockSession :: (MonadIO m) => Session m (s -> Timed NominalDiffTime s)
clockSession =
Session $ do
t0 <- liftIO getCurrentTime
return (Timed 0, loop t0)
where
loop t' =
Session $ do
t <- liftIO getCurrentTime
let dt = diffUTCTime t t'
dt `seq` return (Timed dt, loop t)
-- | Non-extending version of 'clockSession'.
clockSession_ :: (Applicative m, MonadIO m) => Session m (Timed NominalDiffTime ())
clockSession_ = clockSession <*> pure ()
-- | State delta generator for a simple counting clock. Denotes a fixed
-- framerate. This is likely more useful than 'clockSession' for
-- simulations and real-time games.
countSession ::
(Applicative m)
=> t -- ^ Increment size.
-> Session m (s -> Timed t s)
countSession dt =
let loop = Session (pure (Timed dt, loop))
in loop
-- | Non-extending version of 'countSession'.
countSession_ :: (Applicative m) => t -> Session m (Timed t ())
countSession_ dt = countSession dt <*> pure ()
|
