src/Reflex/Dynamic.hs · patch

git.iko.soy/patch

363 lines 15 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 , traceDyn

26 , traceDynWith

27 , splitDyn

28 , Demux

29 , demux

30 , getDemuxed

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

32 , FHList (..)

33 , distributeFHListOverDyn

34 ) where

36import Reflex.Class

37import Data.Functor.Misc

39import Control.Monad

40import Control.Monad.Fix

41import Control.Monad.Identity

42import Data.These

43import Data.Align

44import Data.Dependent.Map (DMap)

45import qualified Data.Dependent.Map as DMap

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

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

48import Data.Monoid

49import Data.HList (HList (..), hBuild)

51data Dynamic t a

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

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

55current (Dynamic b _) = b

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

58updated (Dynamic _ e) = e

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

61constDyn x = Dynamic (constant x) never

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

64holdDyn v0 e = do

65 b <- hold v0 e

66 return $ Dynamic b e

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

69nubDyn d =

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

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

73{-

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

75 fmap f d =

76 let e' = fmap f $ updated d

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

78 b0 = fmap f $ current d

80-}

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

83mapDyn f = mapDynM $ return . f

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

86forDyn = flip mapDyn

88{-# INLINE mapDynM #-}

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

90mapDynM f (~(Dynamic b e)) = do

91 let e' = push (liftM Just . f :: a -> PushM t (Maybe b)) e

92 eb' = fmap constant e'

93 v0 = pull $ f =<< sample b

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

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

96 return $ Dynamic b' e'

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

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

100

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

102foldDynM f z e = do

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

104 v <- sample b'

105 liftM Just $ f o v

106 b' <- hold z e'

107 return $ Dynamic b' e'

108

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

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

111

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

113toggle = foldDyn (const not)

114

115-- | Switches to the new event whenever it receives one. Switching occurs *before* occurring the inner event.

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

117switchPromptlyDyn de =

118 let eLag = switch $ current de

119 eCoincidences = coincidence $ updated de

120 in leftmost [eCoincidences, eLag]

121

122{-

123

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

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

126

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

128firstE [] = return never

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

130

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

132concatEventsWith _ [] = return never

133concatEventsWith _ [e] = return e

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

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

136

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

138mconcatE = concatEventsWith mappend

139-}

140

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

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

143

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

145mconcatDyn es = do

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

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

148

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

150distributeDMapOverDyn dm = case DMap.toList dm of

151 [] -> return $ constDyn DMap.empty

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

153 _ -> do

154 let edmPre = merge $ rewrapDMap updated dm

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

156 let f _ = \case

157 This origDyn -> sample $ current origDyn

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

159 These _ (Identity newVal) -> return newVal

160 sequenceDmap $ combineDMapsWithKey f dm (wrapDMap Identity o)

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

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

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

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

165 return $ Dynamic bdm edm

166

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

168combineDyn f (~(Dynamic ba ea)) (~(Dynamic bb eb)) = do

169 let eab = align ea eb

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

171 (a, b) <- case o of

172 This a -> do

173 b <- sample bb

174 return (a, b)

175 That b -> do

176 a <- sample ba

177 return (a, b)

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

179 return $ Just $ f a b

180 c0 :: Behavior t c = pull $ liftM2 f (sample ba) (sample bb)

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

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

183 return $ Dynamic bc ec

184

185{-

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

187tagInnerDyn e =

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

189 eFast = coincidence $ fmap updated e

190 in leftmost [eFast, eSlow]

191-}

192

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

194joinDyn dd =

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

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

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

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

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

200 in Dynamic b' e'

201

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

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

204

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

206traceDynWith f d =

207 let e' = traceEventWith f $ updated d

208 in Dynamic (current d) e'

209

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

211tagDyn = attachDynWith const

212

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

214attachDyn = attachDynWith (,)

215

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

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

218

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

220attachDynWithMaybe f d e =

221 let e' = attach (current d) e

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

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

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

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

226

227--------------------------------------------------------------------------------

228-- Demux

229--------------------------------------------------------------------------------

230

231data Demux t k = Demux (Behavior t k) (EventSelector t (Const2 k Bool))

232

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

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

235

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

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

238getDemuxed (Demux bk es) k = do

239 let e = select es (Const2 k)

240 bb <- hold (liftM (==k) $ sample bk) $ fmap return e

241 let b = pull $ join $ sample bb

242 return $ Dynamic b e

243

244--------------------------------------------------------------------------------

245-- collectDyn

246--------------------------------------------------------------------------------

247

248--TODO: This whole section is badly in need of cleanup