src/Reflex/Dynamic.hs · patch

git.iko.soy/patch

488 lines 21 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', with a rule that the Behavior will

93-- change if and only if the Event fires.

94data Dynamic t a

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

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

98unsafeDynamic = Dynamic

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

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

102current (Dynamic b _) = b

103

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

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

106updated (Dynamic _ e) = e

107

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

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

110constDyn x = Dynamic (constant x) never

111

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

113-- time the 'Event' occurs.

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

115holdDyn v0 e = do

116 b <- hold v0 e

117 return $ Dynamic b e

118

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

120-- actually changed.

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

122nubDyn d =

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

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

125

126{-

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

128 fmap f d =

129 let e' = fmap f $ updated d

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

131 b0 = fmap f $ current d

132

133-}

134

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

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

137mapDyn f = mapDynM $ return . f

138

139-- | Flipped version of 'mapDyn'.

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

141forDyn = flip mapDyn

142

143-- | Map a monadic function over a 'Dynamic'. The only monadic action that the given function can

144-- perform is 'sample'.

145{-# INLINE mapDynM #-}

146mapDynM :: 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)

147mapDynM f d = do

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

149 eb' = fmap constant e'

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

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

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

153 return $ Dynamic b' e'

154

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

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

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

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

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

160

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

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

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

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

165foldDynM f z e = do

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

167 v <- sample b'

168 liftM Just $ f o v

169 b' <- hold z e'

170 return $ Dynamic b' e'

171

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

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

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

175

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

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

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

179toggle = foldDyn (const not)

180

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

182-- occurs *before* the inner 'Event' fires - so if the 'Dynamic' changes and both the old and new

183-- inner Events fire simultaneously, the output will fire with the value of the *new* 'Event'.

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

185switchPromptlyDyn de =

186 let eLag = switch $ current de

187 eCoincidences = coincidence $ updated de

188 in leftmost [eCoincidences, eLag]

189

190{-

191

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

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

194

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

196firstE [] = return never

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

198

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

200concatEventsWith _ [] = return never

201concatEventsWith _ [e] = return e

202concatEventsWith 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

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

204

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

206mconcatE = concatEventsWith mappend

207-}

208

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

210-- respective value of the tuple.

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

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

213

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

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

216mconcatDyn es = do

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

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

219

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

221-- Dynamic values.

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

223distributeDMapOverDyn dm = case DMap.toList dm of

224 [] -> return $ constDyn DMap.empty

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

226 _ -> do

227 let edmPre = merge $ rewrapDMap updated dm

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

229 let f _ = \case

230 This origDyn -> sample $ current origDyn

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

232 These _ (Identity newVal) -> return newVal

233 sequenceDmap $ combineDMapsWithKey f dm (wrapDMap Identity o)

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

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

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

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

238 return $ Dynamic bdm edm

239

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

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

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

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

244combineDyn f da db = do

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

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

247 (a, b) <- case o of

248 This a -> do

249 b <- sample $ current db

250 return (a, b)

251 That b -> do

252 a <- sample $ current da

253 return (a, b)

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

255 return $ Just $ f a b

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

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

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

259 return $ Dynamic bc ec

260

261{-

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

263tagInnerDyn e =

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

265 eFast = coincidence $ fmap updated e

266 in leftmost [eFast, eSlow]

267-}

268

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

270-- of the inner 'Dynamic'.

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

272joinDyn dd =

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

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

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

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

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

278 in Dynamic b' e'

279

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

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

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

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

284joinDynThroughMap dd =

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

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

287 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

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

289 readNonFiring = \case

290 This d -> sample $ current d

291 That a -> return a

292 These _ a -> return a

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

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

295 in Dynamic b' e'

296

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

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

299--

300-- Note: Just like Debug.Trace.trace, the value will only be shown if something

301-- else in the system is depending on it.

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

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

304

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

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

307-- debugging.

308--

309-- Note: Just like Debug.Trace.trace, the value will only be shown if something

310-- else in the system is depending on it.

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

312traceDynWith f d =

313 let e' = traceEventWith f $ updated d

314 in Dynamic (current d) e'

315

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

317-- each time the 'Event' occurs.

318--

319-- Note: `tagDyn d e` differs from `tag (current d) e` in the case that `e` is firing

320-- at the same time that `d` is changing. With `tagDyn d e`, the *new* value of `d`

321-- will replace the value of `e`, whereas with `tag (current d) e`, the *old* value

322-- will be used, since the 'Behavior' won't be updated until the end of the frame.

323-- Additionally, this means that the output 'Event' may not be used to directly change

324-- the input 'Dynamic', because that would mean its value depends on itself. When creating

325-- cyclic data flows, generally `tag (current d) e` is preferred.

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

327tagDyn = attachDynWith const

328

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

330-- 'Event' each time it occurs.

331--

332-- Note: `attachDyn d` is not the same as `attach (current d)`. See 'tagDyn' for details.

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

334attachDyn = attachDynWith (,)

335

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

337-- 'Event' each time it occurs.

338--

339-- Note: `attachDynWith f d` is not the same as `attachWith f (current d)`. See 'tagDyn' for details.

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

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

342

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

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

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

346--

347-- Note: `attachDynWithMaybe f d` is not the same as `attachWithMaybe f (current d)`. See 'tagDyn' for details.

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

349attachDynWithMaybe f d e =

350 let e' = attach (current d) e

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

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

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

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

355

356--------------------------------------------------------------------------------

357-- Demux

358--------------------------------------------------------------------------------

359

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

361-- that can efficiently detect when the underlying Dynamic has a particular value.

362-- This is useful for representing data like the current selection of a long list.

363--

364-- Semantically,

365-- > getDemuxed (demux d) k === mapDyn (== k) d

366-- However, the when getDemuxed is used multiple times, the complexity is only /O(log(n))/,

367-- rather than /O(n)/ for mapDyn.

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

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

370 }

371

372-- | Demultiplex an input value to a 'Demux' with many outputs. At any given time, whichever output is indicated by the given 'Dynamic' will be 'True'.

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

374demux 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))

375

376--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

377-- | Select a particular output of the 'Demux'; this is equivalent to (but much faster than)

378-- mapping over the original 'Dynamic' and checking whether it is equal to the given key.

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

380getDemuxed d k = do

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

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

383 let b = pull $ join $ sample bb

384 return $ Dynamic b e

385

386--------------------------------------------------------------------------------

387-- collectDyn

388--------------------------------------------------------------------------------