src/Reflex/Dynamic.hs · patch

git.iko.soy/patch

466 lines 20 kB history raw

1{-# LANGUAGE TypeFamilies, FlexibleContexts, FlexibleInstances, MultiParamTypeClasses, RankNTypes, GADTs, ScopedTypeVariables, FunctionalDependencies, RecursiveDo, UndecidableInstances, GeneralizedNewtypeDeriving, StandaloneDeriving, EmptyDataDecls, NoMonomorphismRestriction, TypeOperators, DeriveDataTypeable, PackageImports, TemplateHaskell, LambdaCase, DataKinds, PolyKinds #-}

2module Reflex.Dynamic ( Dynamic -- Abstract so we can preserve the law that the current value is always equal to the most recent update

3 , current

4 , updated

5 , constDyn

6 , holdDyn

7 , nubDyn

8 , count

9 , toggle

10 , switchPromptlyDyn

11 , tagDyn

12 , attachDyn

13 , attachDynWith

14 , attachDynWithMaybe

15 , mapDyn

16 , forDyn

17 , mapDynM

18 , foldDyn

19 , foldDynM

20 , combineDyn

21 , collectDyn

22 , mconcatDyn

23 , distributeDMapOverDyn

24 , joinDyn

25 , joinDynThroughMap

26 , traceDyn

27 , traceDynWith

28 , splitDyn

29 , Demux

30 , demux

31 , getDemuxed

32 -- Things that probably aren't very useful:

33 , HList (..)

34 , FHList (..)

35 , distributeFHListOverDyn

36 -- Unsafe

37 , unsafeDynamic

38 ) where

40import Prelude hiding (mapM, mapM_)

42import Reflex.Class

43import Data.Functor.Misc

45import Control.Monad hiding (mapM, mapM_, forM, forM_)

46import Control.Monad.Fix

47import Control.Monad.Identity hiding (mapM, mapM_, forM, forM_)

48import Data.These

49import Data.Traversable (mapM, forM)

50import Data.Align

51import Data.Map (Map)

52import qualified Data.Map as Map

53import Data.Dependent.Map (DMap)

54import qualified Data.Dependent.Map as DMap

55import Data.Dependent.Sum (DSum (..))

56import Data.GADT.Compare (GCompare (..), GEq (..), (:~:) (..), GOrdering (..))

57import Data.Monoid

58--import Data.HList (HList (..), hBuild)

60data HList (l::[*]) where

61 HNil :: HList '[]

62 HCons :: e -> HList l -> HList (e ': l)

64infixr 2 `HCons`

66type family HRevApp (l1 :: [k]) (l2 :: [k]) :: [k]

67type instance HRevApp '[] l = l

68type instance HRevApp (e ': l) l' = HRevApp l (e ': l')

70hRevApp :: HList l1 -> HList l2 -> HList (HRevApp l1 l2)

71hRevApp HNil l = l

72hRevApp (HCons x l) l' = hRevApp l (HCons x l')

74hReverse :: HList l -> HList (HRevApp l '[])

75hReverse l = hRevApp l HNil

77hBuild :: (HBuild' '[] r) => r

78hBuild = hBuild' HNil

80class HBuild' l r where

81 hBuild' :: HList l -> r

83instance (l' ~ HRevApp l '[])

84 => HBuild' l (HList l') where

85 hBuild' l = hReverse l

87instance HBuild' (a ': l) r

88 => HBuild' l (a->r) where

89 hBuild' l x = hBuild' (HCons x l)

91-- | A container for a value that can change over time and allows notifications on changes.

92-- Basically a combination of a 'Behavior' and an 'Event'.

93data Dynamic t a

94 = Dynamic (Behavior t a) (Event t a)

96unsafeDynamic :: Behavior t a -> Event t a -> Dynamic t a

97unsafeDynamic = Dynamic

99-- | Extract the 'Behavior' of a 'Dynamic'.

100current :: Dynamic t a -> Behavior t a

101current (Dynamic b _) = b

102

103-- | Extract the 'Event' of the 'Dynamic'.

104updated :: Dynamic t a -> Event t a

105updated (Dynamic _ e) = e

106

107-- | 'Dynamic' with the constant supplied value.

108constDyn :: Reflex t => a -> Dynamic t a

109constDyn x = Dynamic (constant x) never

110

111-- | Create a 'Dynamic' using the initial value that changes every

112-- time the 'Event' occurs.

113holdDyn :: MonadHold t m => a -> Event t a -> m (Dynamic t a)

114holdDyn v0 e = do

115 b <- hold v0 e

116 return $ Dynamic b e

117

118-- | Create a new 'Dynamic' that only signals changes if the values

119-- actually changed.

120nubDyn :: (Reflex t, Eq a) => Dynamic t a -> Dynamic t a

121nubDyn d =

122 let e' = attachWithMaybe (\x x' -> if x' == x then Nothing else Just x') (current d) (updated d)

123 in Dynamic (current d) e' --TODO: Avoid invalidating the outgoing Behavior

124

125{-

126instance Reflex t => Functor (Dynamic t) where

127 fmap f d =

128 let e' = fmap f $ updated d

129 eb' = push (\b' -> liftM Just $ constant b') e'

130 b0 = fmap f $ current d

131

132-}

133

134-- | Map a function over a 'Dynamic'.

135mapDyn :: (Reflex t, MonadHold t m) => (a -> b) -> Dynamic t a -> m (Dynamic t b)

136mapDyn f = mapDynM $ return . f

137

138-- | Flipped version of 'forDyn'.

139forDyn :: (Reflex t, MonadHold t m) => Dynamic t a -> (a -> b) -> m (Dynamic t b)

140forDyn = flip mapDyn

141

142-- | Map a monadic function over a 'Dynamic'.

143{-# INLINE mapDynM #-}

144mapDynM :: forall t m a b. (Reflex t, MonadHold t m) => (forall m'. MonadSample t m' => a -> m' b) -> Dynamic t a -> m (Dynamic t b)

145mapDynM f d = do

146 let e' = push (liftM Just . f :: a -> PushM t (Maybe b)) $ updated d

147 eb' = fmap constant e'

148 v0 = pull $ f =<< sample (current d)

149 bb' :: Behavior t (Behavior t b) <- hold v0 eb'

150 let b' = pull $ sample =<< sample bb'

151 return $ Dynamic b' e'

152

153-- | Create a 'Dynamic' using the initial value and change it each

154-- time the 'Event' occurs using a folding function on the previous

155-- value and the value of the 'Event'.

156foldDyn :: (Reflex t, MonadHold t m, MonadFix m) => (a -> b -> b) -> b -> Event t a -> m (Dynamic t b)

157foldDyn f = foldDynM (\o v -> return $ f o v)

158

159-- | Create a 'Dynamic' using the initial value and change it each

160-- time the 'Event' occurs using a monadic folding function on the

161-- previous value and the value of the 'Event'.

162foldDynM :: (Reflex t, MonadHold t m, MonadFix m) => (a -> b -> PushM t b) -> b -> Event t a -> m (Dynamic t b)

163foldDynM f z e = do

164 rec let e' = flip push e $ \o -> do

165 v <- sample b'

166 liftM Just $ f o v

167 b' <- hold z e'

168 return $ Dynamic b' e'

169

170-- | Create a new 'Dynamic' that counts the occurences of the 'Event'.

171count :: (Reflex t, MonadHold t m, MonadFix m, Num b) => Event t a -> m (Dynamic t b)

172count e = holdDyn 0 =<< zipListWithEvent const (iterate (+1) 1) e

173

174-- | Create a new 'Dynamic' using the initial value that flips its

175-- value every time the 'Event' occurs.

176toggle :: (Reflex t, MonadHold t m, MonadFix m) => Bool -> Event t a -> m (Dynamic t Bool)

177toggle = foldDyn (const not)

178

179-- | Switches to the new 'Event' whenever it receives one. Switching

180-- occurs *before* occurring the inner 'Event'.

181switchPromptlyDyn :: forall t a. Reflex t => Dynamic t (Event t a) -> Event t a

182switchPromptlyDyn de =

183 let eLag = switch $ current de

184 eCoincidences = coincidence $ updated de

185 in leftmost [eCoincidences, eLag]

186

187{-

188

189mergeEventsWith :: Reflex t m => (a -> a -> a) -> Event t a -> Event t a -> m (Event t a)

190mergeEventsWith f ea eb = mapE (mergeThese f) =<< alignEvents ea eb

191

192firstE :: (Reflex t m) => [Event t a] -> m (Event t a)

193firstE [] = return never

194firstE (h:t) = mergeEventsLeftBiased h =<< firstE t

195

196concatEventsWith :: (Reflex t m) => (a -> a -> a) -> [Event t a] -> m (Event t a)

197concatEventsWith _ [] = return never

198concatEventsWith _ [e] = return e

199concatEventsWith f es = mapEM (liftM (foldl1 f . map (\(Const2 _ :=> v) -> v) . DMap.toList) . sequenceDmap) <=< mergeEventDMap $ DMap.fromList $ map (\(k, v) -> WrapArg (Const2 k) :=> v) $ zip [0 :: Int ..] es

200--concatEventsWith f (h:t) = mergeEventsWith f h =<< concatEventsWith f t

201

202mconcatE :: (Reflex t m, Monoid a) => [Event t a] -> m (Event t a)

203mconcatE = concatEventsWith mappend

204-}

205

206-- | Split the 'Dynamic' into two 'Dynamic's, each taking the

207-- respective value of the tuple.

208splitDyn :: (Reflex t, MonadHold t m) => Dynamic t (a, b) -> m (Dynamic t a, Dynamic t b)

209splitDyn d = liftM2 (,) (mapDyn fst d) (mapDyn snd d)

210

211-- | Merge the 'Dynamic' values using their 'Monoid' instance.

212mconcatDyn :: forall t m a. (Reflex t, MonadHold t m, Monoid a) => [Dynamic t a] -> m (Dynamic t a)

213mconcatDyn es = do

214 ddm :: Dynamic t (DMap (Const2 Int a)) <- distributeDMapOverDyn $ DMap.fromList $ map (\(k, v) -> WrapArg (Const2 k) :=> v) $ zip [0 :: Int ..] es

215 mapDyn (mconcat . map (\(Const2 _ :=> v) -> v) . DMap.toList) ddm

216

217-- | Create a 'Dynamic' with a 'DMap' of values out of a 'DMap' of

218-- Dynamic values.

219distributeDMapOverDyn :: forall t m k. (Reflex t, MonadHold t m, GCompare k) => DMap (WrapArg (Dynamic t) k) -> m (Dynamic t (DMap k))

220distributeDMapOverDyn dm = case DMap.toList dm of

221 [] -> return $ constDyn DMap.empty

222 [WrapArg k :=> v] -> mapDyn (DMap.singleton k) v

223 _ -> do

224 let edmPre = merge $ rewrapDMap updated dm

225 edm :: Event t (DMap k) = flip push edmPre $ \o -> return . Just =<< do

226 let f _ = \case

227 This origDyn -> sample $ current origDyn

228 That _ -> error "distributeDMapOverDyn: should be impossible to have an event occurring that is not present in the original DMap"

229 These _ (Identity newVal) -> return newVal

230 sequenceDmap $ combineDMapsWithKey f dm (wrapDMap Identity o)

231 dm0 :: Behavior t (DMap k) = pull $ do

232 liftM DMap.fromList $ forM (DMap.toList dm) $ \(WrapArg k :=> dv) -> liftM (k :=>) $ sample $ current dv

233 bbdm :: Behavior t (Behavior t (DMap k)) <- hold dm0 $ fmap constant edm

234 let bdm = pull $ sample =<< sample bbdm

235 return $ Dynamic bdm edm

236

237-- | Merge two 'Dynamic's into a new one using the provided

238-- function. The new 'Dynamic' changes its value each time one of the

239-- original 'Dynamic's changes its value.

240combineDyn :: forall t m a b c. (Reflex t, MonadHold t m) => (a -> b -> c) -> Dynamic t a -> Dynamic t b -> m (Dynamic t c)

241combineDyn f da db = do

242 let eab = align (updated da) (updated db)

243 ec = flip push eab $ \o -> do

244 (a, b) <- case o of

245 This a -> do

246 b <- sample $ current db

247 return (a, b)

248 That b -> do

249 a <- sample $ current da

250 return (a, b)

251 These a b -> return (a, b)

252 return $ Just $ f a b

253 c0 :: Behavior t c = pull $ liftM2 f (sample $ current da) (sample $ current db)

254 bbc :: Behavior t (Behavior t c) <- hold c0 $ fmap constant ec

255 let bc :: Behavior t c = pull $ sample =<< sample bbc

256 return $ Dynamic bc ec

257

258{-

259tagInnerDyn :: Reflex t => Event t (Dynamic t a) -> Event t a

260tagInnerDyn e =

261 let eSlow = push (liftM Just . sample . current) e

262 eFast = coincidence $ fmap updated e

263 in leftmost [eFast, eSlow]

264-}

265

266-- | Join a nested 'Dynamic' into a new 'Dynamic' that has the value

267-- of the inner 'Dynamic'.

268joinDyn :: forall t a. (Reflex t) => Dynamic t (Dynamic t a) -> Dynamic t a

269joinDyn dd =

270 let b' = pull $ sample . current =<< sample (current dd)

271 eOuter :: Event t a = pushAlways (sample . current) $ updated dd

272 eInner :: Event t a = switch $ fmap updated (current dd)

273 eBoth :: Event t a = coincidence $ fmap updated (updated dd)

274 e' = leftmost [eBoth, eOuter, eInner]

275 in Dynamic b' e'

276

277--TODO: Generalize this to functors other than Maps

278-- | Combine a 'Dynamic' of a 'Map' of 'Dynamic's into a 'Dynamic'

279-- with the current values of the 'Dynamic's in a map.

280joinDynThroughMap :: forall t k a. (Reflex t, Ord k) => Dynamic t (Map k (Dynamic t a)) -> Dynamic t (Map k a)

281joinDynThroughMap dd =

282 let b' = pull $ mapM (sample . current) =<< sample (current dd)

283 eOuter :: Event t (Map k a) = pushAlways (mapM (sample . current)) $ updated dd

284 eInner :: Event t (Map k a) = attachWith (flip Map.union) b' $ switch $ fmap (mergeMap . fmap updated) (current dd) --Note: the flip is important because Map.union is left-biased

285 readNonFiring :: MonadSample t m => These (Dynamic t a) a -> m a

286 readNonFiring = \case

287 This d -> sample $ current d

288 That a -> return a

289 These _ a -> return a

290 eBoth :: Event t (Map k a) = coincidence $ fmap (\m -> pushAlways (mapM readNonFiring . align m) $ mergeMap $ fmap updated m) (updated dd)

291 e' = leftmost [eBoth, eOuter, eInner]

292 in Dynamic b' e'

293

294-- | Print the value of the 'Dynamic' on each change and prefix it

295-- with the provided string. This should /only/ be used for debugging.

296traceDyn :: (Reflex t, Show a) => String -> Dynamic t a -> Dynamic t a

297traceDyn s = traceDynWith $ \x -> s <> ": " <> show x

298

299-- | Print the result of applying the provided function to the value

300-- of the 'Dynamic' on each change. This should /only/ be used for

301-- debugging.

302traceDynWith :: Reflex t => (a -> String) -> Dynamic t a -> Dynamic t a

303traceDynWith f d =

304 let e' = traceEventWith f $ updated d

305 in Dynamic (current d) e'

306

307-- | Replace the value of the 'Event' with the current value of the 'Dynamic'

308-- each time the 'Event' occurs.

309tagDyn :: Reflex t => Dynamic t a -> Event t b -> Event t a

310tagDyn = attachDynWith const

311

312-- | Attach the current value of the 'Dynamic' to the value of the

313-- 'Event' each time it occurs.

314attachDyn :: Reflex t => Dynamic t a -> Event t b -> Event t (a, b)

315attachDyn = attachDynWith (,)

316

317-- | Combine the current value of the 'Dynamic' with the value of the

318-- 'Event' each time it occurs.

319attachDynWith :: Reflex t => (a -> b -> c) -> Dynamic t a -> Event t b -> Event t c

320attachDynWith f = attachDynWithMaybe $ \a b -> Just $ f a b

321

322-- | Create a new 'Event' by combining the value at each occurence

323-- with the current value of the 'Dynamic' value and possibly

324-- filtering if the combining function returns 'Nothing'.

325attachDynWithMaybe :: Reflex t => (a -> b -> Maybe c) -> Dynamic t a -> Event t b -> Event t c

326attachDynWithMaybe f d e =

327 let e' = attach (current d) e

328 in fforMaybe (align e' $ updated d) $ \case

329 This (a, b) -> f a b -- Only the tagging event is firing, so use that

330 These (_, b) a -> f a b -- Both events are firing, so use the newer value

331 That _ -> Nothing -- The tagging event isn't firing, so don't fire

332

333--------------------------------------------------------------------------------

334-- Demux

335--------------------------------------------------------------------------------

336

337-- | Represents a time changing value together with an 'EventSelector'

338-- for changes to this value.

339data Demux t k = Demux { demuxValue :: Behavior t k

340 , demuxSelector :: EventSelector t (Const2 k Bool)

341 }

342

343-- | Create 'Demux' out of a 'Dynamic' that has the value of the

344-- 'Dynamic' and allows selecting between the values of the 'Event'

345-- and the 'Behavior' of the 'Dynamic' for the occurences of 'Event'

346-- where they differ. Selecting the value of the 'Behavior' will

347-- return 'False' while selecting the value of the 'Event' will return

348-- 'True'.

349demux :: (Reflex t, Ord k) => Dynamic t k -> Demux t k

350demux k = Demux (current k) (fan $ attachWith (\k0 k1 -> if k0 == k1 then DMap.empty else DMap.fromList [Const2 k0 :=> False, Const2 k1 :=> True]) (current k) (updated k))

351

352--TODO: The pattern of using hold (sample b0) can be reused in various places as a safe way of building certain kinds of Dynamics; see if we can factor this out

353-- | Extract the 'Event' of the 'Demux' for the supplied value and

354-- create a 'Dynamic' with the initial value of the equality of the

355-- 'Behavior' and the supplied value. Each occurence of the extracted

356-- 'Event' changes the value of the 'Dynamic'.

357getDemuxed :: (Reflex t, MonadHold t m, Eq k) => Demux t k -> k -> m (Dynamic t Bool)

358getDemuxed d k = do

359 let e = select (demuxSelector d) (Const2 k)

360 bb <- hold (liftM (==k) $ sample $ demuxValue d) $ fmap return e

361 let b = pull $ join $ sample bb

362 return $ Dynamic b e

363

364--------------------------------------------------------------------------------