02007dd · reflex · git.iko.soy

git.iko.soy/reflex

on develop help sign in

Take all functions out of the Reflex class when specializing

02007ddRyan Trinkle10 years ago

reflex.cabal+1

compare with develop

unifiedsplit

@@ -55,6 +55,7 @@ library

55 Reflex.Dynamic.TH,

56 Reflex.Dynamic.Uniq,

57 Reflex.DynamicWriter,

58+ Reflex.FunctorMaybe,

58 Reflex.Host.Class,

59 Reflex.Host.Class,

59 Reflex.Optimizer,

60 Reflex.Optimizer,

60 Reflex.Patch,

61 Reflex.Patch,

src/Data/Functor/Misc.hs+54

@@ -3,6 +3,7 @@

3{-# LANGUAGE FlexibleInstances #-}

4{-# LANGUAGE GADTs #-}

5{-# LANGUAGE KindSignatures #-}

6+{-# LANGUAGE LambdaCase #-}

6{-# LANGUAGE MultiParamTypeClasses #-}

7{-# LANGUAGE MultiParamTypeClasses #-}

7{-# LANGUAGE PolyKinds #-}

8{-# LANGUAGE PolyKinds #-}

8{-# LANGUAGE RankNTypes #-}

9{-# LANGUAGE RankNTypes #-}

@@ -23,6 +24,10 @@ module Data.Functor.Misc

23 , mapWithFunctorToDMap

24 , mapWithFunctorToDMap

24 , mapKeyValuePairsMonotonic

25 , mapKeyValuePairsMonotonic

25 , combineDMapsWithKey

26 , combineDMapsWithKey

27+ , EitherTag (..)

28+ , dmapToThese

29+ , eitherToDSum

30+ , dsumToEither

26 -- * Deprecated functions

31 -- * Deprecated functions

27 , sequenceDmap

32 , sequenceDmap

28 , wrapDMap

33 , wrapDMap

@@ -134,6 +139,55 @@ combineDMapsWithKey f mg mh = DMap.fromList $ go (DMap.toList mg) (DMap.toList m

134 GEQ -> (gk :=> f gk (These gv hv)) : go gs' hs'

139 GEQ -> (gk :=> f gk (These gv hv)) : go gs' hs'

135 GGT -> (hk :=> f hk (That hv)) : go gs hs'

140 GGT -> (hk :=> f hk (That hv)) : go gs hs'

136

141

142+-- | Extract the values of a 'DMap' of 'EitherTag's.

143+dmapToThese :: DMap (EitherTag a b) Identity -> Maybe (These a b)

144+dmapToThese m = case (DMap.lookup LeftTag m, DMap.lookup RightTag m) of

145+ (Nothing, Nothing) -> Nothing

146+ (Just (Identity a), Nothing) -> Just $ This a

147+ (Nothing, Just (Identity b)) -> Just $ That b

148+ (Just (Identity a), Just (Identity b)) -> Just $ These a b

149+

150+-- | Tag type for 'Either' to use it as a 'DSum'.

151+data EitherTag l r a where

152+ LeftTag :: EitherTag l r l

153+ RightTag :: EitherTag l r r

154+

155+instance GEq (EitherTag l r) where

156+ geq a b = case (a, b) of

157+ (LeftTag, LeftTag) -> Just Refl

158+ (RightTag, RightTag) -> Just Refl

159+ _ -> Nothing

160+

161+instance GCompare (EitherTag l r) where

162+ gcompare a b = case (a, b) of

163+ (LeftTag, LeftTag) -> GEQ

164+ (LeftTag, RightTag) -> GLT

165+ (RightTag, LeftTag) -> GGT

166+ (RightTag, RightTag) -> GEQ

167+

168+instance GShow (EitherTag l r) where

169+ gshowsPrec _ a = case a of

170+ LeftTag -> showString "LeftTag"

171+ RightTag -> showString "RightTag"

172+

173+instance (Show l, Show r) => ShowTag (EitherTag l r) Identity where

174+ showTaggedPrec t n (Identity a) = case t of

175+ LeftTag -> showsPrec n a

176+ RightTag -> showsPrec n a

177+

178+-- | Convert 'Either' to a 'DSum'. Inverse of 'dsumToEither'.

179+eitherToDSum :: Either a b -> DSum (EitherTag a b) Identity

180+eitherToDSum = \case

181+ Left a -> (LeftTag :=> Identity a)

182+ Right b -> (RightTag :=> Identity b)

183+

184+-- | Convert 'DSum' to 'Either'. Inverse of 'eitherToDSum'.

185+dsumToEither :: DSum (EitherTag a b) Identity -> Either a b

186+dsumToEither = \case

187+ (LeftTag :=> Identity a) -> Left a

188+ (RightTag :=> Identity b) -> Right b

189+

190+

137--------------------------------------------------------------------------------

191--------------------------------------------------------------------------------

138-- Deprecated functions

192-- Deprecated functions

139--------------------------------------------------------------------------------

193--------------------------------------------------------------------------------

src/Reflex/Class.hs+109−65

@@ -17,6 +17,9 @@

17{-# LANGUAGE TypeOperators #-}

18{-# LANGUAGE UndecidableInstances #-}

19{-# OPTIONS_GHC -fplugin=Reflex.Optimizer #-}

20+#ifdef SPECIALIZE_TO_SPIDERTIMELINE_GLOBAL

21+{-# OPTIONS_GHC -Wno-redundant-constraints #-}

22+#endif

21-- | This module contains the Reflex interface, as well as a variety of

24-- | This module contains the Reflex interface, as well as a variety of

22-- convenience functions for working with 'Event's, 'Behavior's, and other

25-- convenience functions for working with 'Event's, 'Behavior's, and other

@@ -93,8 +96,33 @@ module Reflex.Class

93 , onceE

96 , onceE

94 , sequenceThese

97 , sequenceThese

95#ifdef SPECIALIZE_TO_SPIDERTIMELINE_GLOBAL

98#ifdef SPECIALIZE_TO_SPIDERTIMELINE_GLOBAL

99+ , Spider

100+ , SpiderEnv

96 , SpiderTimeline

101 , SpiderTimeline

97 , Global

102 , Global

103+ , Behavior (..)

104+ , Event (..)

105+ , Dynamic (..)

106+ , Incremental (..)

107+ , never

108+ , constant

109+ , push

110+ , pull

111+ , merge

112+ , fan

113+ , switch

114+ , coincidence

115+ , current

116+ , updated

117+ , unsafeBuildDynamic

118+ , unsafeBuildIncremental

119+ , mergeIncremental

120+ , currentIncremental

121+ , updatedIncremental

122+ , incrementalToDynamic

123+ , behaviorCoercion

124+ , eventCoercion

125+ , dynamicCoercion

98#endif

126#endif

99 ) where

127 ) where

100

128

@@ -109,17 +137,14 @@ import Control.Monad.Trans.Writer (WriterT ())

109import Data.Align

137import Data.Align

110import Data.Bifunctor

138import Data.Bifunctor

111import Data.Coerce

139import Data.Coerce

112−import Data.Dependent.Map (DMap, DSum (..), GCompare (..), GOrdering (..))

140+import Data.Dependent.Map (DMap, DSum (..), GCompare (..))

113import qualified Data.Dependent.Map as DMap

141import qualified Data.Dependent.Map as DMap

114−import Data.Dependent.Sum (ShowTag (..))

115import Data.Either

142import Data.Either

116import Data.Foldable

143import Data.Foldable

117import Data.Functor.Bind hiding (join)

144import Data.Functor.Bind hiding (join)

118import qualified Data.Functor.Bind as Bind

145import qualified Data.Functor.Bind as Bind

119import Data.Functor.Misc

146import Data.Functor.Misc

120import Data.Functor.Plus

147import Data.Functor.Plus

121−import Data.GADT.Compare ((:~:) (..), GEq (..))

122−import Data.GADT.Show (GShow (..))

123import Data.List.NonEmpty (NonEmpty (..))

148import Data.List.NonEmpty (NonEmpty (..))

124import Data.Map (Map)

149import Data.Map (Map)

125import Data.Maybe

150import Data.Maybe

@@ -130,6 +155,14 @@ import Data.These

130import Data.Traversable

155import Data.Traversable

131import Data.Type.Coercion

156import Data.Type.Coercion

132import Reflex.Patch

157import Reflex.Patch

158+import Reflex.FunctorMaybe

159+

160+#ifdef SPECIALIZE_TO_SPIDERTIMELINE_GLOBAL

161+import Reflex.Spider.Internal (Global, SpiderPullM, SpiderPushM (..), HasSpiderTimeline, EventM, readBehaviorUntracked, readBehaviorTracked, dynamicHoldIdentity, dynamicHold, dynamicDynIdentity, newMapDyn, dynamicCurrent, dynamicUpdated, unsafeDyn, dynamicConst, behaviorHoldIdentity, SpiderHost (..), runFrame, runSpiderHostFrame, SpiderHostFrame (..))

162+import qualified Reflex.Spider.Internal

163+import qualified Reflex.Spider.Internal as S

164+import Unsafe.Coerce

165+#endif

133

166

134-- Note: must come last to silence warnings due to AMP on GHC < 7.10

167-- Note: must come last to silence warnings due to AMP on GHC < 7.10

135import Prelude hiding (foldl, mapM, mapM_, sequence, sequence_)

168import Prelude hiding (foldl, mapM, mapM_, sequence, sequence_)

@@ -172,6 +205,11 @@ class ( MonadHold t (PushM t)

172 -- 'Event', with a rule that the 'Behavior' will change if and only if the

205 -- 'Event', with a rule that the 'Behavior' will change if and only if the

173 -- 'Event' fires.

206 -- 'Event' fires.

174 data Incremental t :: * -> *

207 data Incremental t :: * -> *

208+ -- | A monad for doing complex push-based calculations efficiently

209+ type PushM t :: * -> *

210+ -- | A monad for doing complex pull-based calculations efficiently

211+ type PullM t :: * -> *

212+#ifndef SPECIALIZE_TO_SPIDERTIMELINE_GLOBAL

175 -- | An 'Event' with no occurrences

213 -- | An 'Event' with no occurrences

176 never :: Event t a

214 never :: Event t a

177 -- | Create a 'Behavior' that always has the given value

215 -- | Create a 'Behavior' that always has the given value

@@ -180,13 +218,9 @@ class ( MonadHold t (PushM t)

180 -- 'Behavior's and hold 'Event's, and use the results to produce a occurring

218 -- 'Behavior's and hold 'Event's, and use the results to produce a occurring

181 -- (Just) or non-occurring (Nothing) result

219 -- (Just) or non-occurring (Nothing) result

182 push :: (a -> PushM t (Maybe b)) -> Event t a -> Event t b

220 push :: (a -> PushM t (Maybe b)) -> Event t a -> Event t b

183− -- | A monad for doing complex push-based calculations efficiently

184− type PushM t :: * -> *

185 -- | Create a 'Behavior' by reading from other 'Behavior's; the result will be

221 -- | Create a 'Behavior' by reading from other 'Behavior's; the result will be

186 -- recomputed whenever any of the read 'Behavior's changes

222 -- recomputed whenever any of the read 'Behavior's changes

187 pull :: PullM t a -> Behavior t a

223 pull :: PullM t a -> Behavior t a

188− -- | A monad for doing complex pull-based calculations efficiently

189− type PullM t :: * -> *

190 -- | Merge a collection of events; the resulting 'Event' will only occur if at

224 -- | Merge a collection of events; the resulting 'Event' will only occur if at

191 -- least one input event is occuring, and will contain all of the input keys

225 -- least one input event is occuring, and will contain all of the input keys

192 -- that are occurring simultaneously

226 -- that are occurring simultaneously

@@ -229,6 +263,73 @@ class ( MonadHold t (PushM t)

229 -- | Construct a 'Coercion' for a 'Dynamic' given an 'Coercion' for its

263 -- | Construct a 'Coercion' for a 'Dynamic' given an 'Coercion' for its

230 -- occurrence type

264 -- occurrence type

231 dynamicCoercion :: Coercion a b -> Coercion (Dynamic t a) (Dynamic t b)

265 dynamicCoercion :: Coercion a b -> Coercion (Dynamic t a) (Dynamic t b)

266+#endif

267+

268+#ifdef SPECIALIZE_TO_SPIDERTIMELINE_GLOBAL

269+instance t ~ SpiderTimeline Global => Reflex t where

270+ newtype Behavior t a = SpiderBehavior { unSpiderBehavior :: Reflex.Spider.Internal.Behavior Global a }

271+ newtype Event t a = SpiderEvent { unSpiderEvent :: Reflex.Spider.Internal.Event Global a }

272+ newtype Dynamic t a = SpiderDynamic { unSpiderDynamic :: Reflex.Spider.Internal.Dynamic Global (Identity a) } -- deriving (Functor, Applicative, Monad)

273+ newtype Incremental t p = SpiderIncremental { unSpiderIncremental :: Reflex.Spider.Internal.Dynamic Global p }

274+ type PullM t = SpiderPullM Global

275+ type PushM t = SpiderPushM Global

276+never :: Reflex t => Event t a

277+constant :: Reflex t => a -> Behavior t a

278+push :: Reflex t => (a -> PushM t (Maybe b)) -> Event t a -> Event t b

279+pull :: Reflex t => PullM t a -> Behavior t a

280+merge :: (Reflex t, GCompare k) => DMap k (Event t) -> Event t (DMap k Identity)

281+fan :: (Reflex t, GCompare k) => Event t (DMap k Identity) -> EventSelector t k

282+switch :: Reflex t => Behavior t (Event t a) -> Event t a

283+coincidence :: Reflex t => Event t (Event t a) -> Event t a

284+current :: Reflex t => Dynamic t a -> Behavior t a

285+updated :: Reflex t => Dynamic t a -> Event t a

286+unsafeBuildDynamic :: Reflex t => PullM t a -> Event t a -> Dynamic t a

287+unsafeBuildIncremental :: (Reflex t, Patch p) => PullM t (PatchTarget p) -> Event t p -> Incremental t p

288+mergeIncremental :: (Reflex t, GCompare k) => Incremental t (PatchDMap k (Event t)) -> Event t (DMap k Identity)

289+currentIncremental :: (Reflex t, Patch p) => Incremental t p -> Behavior t (PatchTarget p)

290+updatedIncremental :: (Reflex t, Patch p) => Incremental t p -> Event t p

291+incrementalToDynamic :: (Reflex t, Patch p) => Incremental t p -> Dynamic t (PatchTarget p)

292+behaviorCoercion :: Reflex t => Coercion a b -> Coercion (Behavior t a) (Behavior t b)

293+eventCoercion :: Reflex t => Coercion a b -> Coercion (Event t a) (Event t b)

294+dynamicCoercion :: Reflex t => Coercion a b -> Coercion (Dynamic t a) (Dynamic t b)

295+{-# INLINE never #-}

296+never = SpiderEvent S.eventNever

297+{-# INLINE constant #-}

298+constant = SpiderBehavior . S.behaviorConst

299+{-# INLINE push #-}

300+push f = SpiderEvent . S.push (coerce f) . unSpiderEvent

301+{-# INLINE pull #-}

302+pull = SpiderBehavior . S.pull . coerce

303+{-# INLINE merge #-}

304+merge = SpiderEvent . S.merge . S.dynamicConst . (coerce :: DMap k (Event (SpiderTimeline x)) -> DMap k (S.Event x))

305+{-# INLINE fan #-}

306+fan e = EventSelector $ SpiderEvent . S.select (S.fan (unSpiderEvent e))

307+{-# INLINE switch #-}

308+switch = SpiderEvent . S.switch . (coerce :: S.Behavior x (Event (SpiderTimeline x) a) -> S.Behavior x (S.Event x a)) . unSpiderBehavior

309+{-# INLINE coincidence #-}

310+coincidence = SpiderEvent . S.coincidence . (coerce :: S.Event x (Event (SpiderTimeline x) a) -> S.Event x (S.Event x a)) . unSpiderEvent

311+{-# INLINE current #-}

312+current = SpiderBehavior . S.dynamicCurrent . unSpiderDynamic

313+{-# INLINE updated #-}

314+updated = SpiderEvent . fmap runIdentity . dynamicUpdated . unSpiderDynamic

315+{-# INLINE unsafeBuildDynamic #-}

316+unsafeBuildDynamic readV0 v' = SpiderDynamic $ dynamicDynIdentity $ unsafeDyn (coerce readV0) $ coerce $ unSpiderEvent v'

317+{-# INLINE unsafeBuildIncremental #-}

318+unsafeBuildIncremental readV0 dv = SpiderIncremental $ S.dynamicDyn $ unsafeDyn (coerce readV0) $ unSpiderEvent dv

319+{-# INLINE mergeIncremental #-}

320+mergeIncremental = SpiderEvent . S.merge . (unsafeCoerce :: S.Dynamic x (PatchDMap k (Event (SpiderTimeline x))) -> S.Dynamic x (PatchDMap k (S.Event x))) . unSpiderIncremental

321+{-# INLINE currentIncremental #-}

322+currentIncremental = SpiderBehavior . dynamicCurrent . unSpiderIncremental

323+{-# INLINE updatedIncremental #-}

324+updatedIncremental = SpiderEvent . dynamicUpdated . unSpiderIncremental

325+{-# INLINE incrementalToDynamic #-}

326+incrementalToDynamic (SpiderIncremental i) = SpiderDynamic $ dynamicDynIdentity $ unsafeDyn (readBehaviorUntracked $ dynamicCurrent i) $ flip S.push (dynamicUpdated i) $ \p -> do

327+ c <- readBehaviorUntracked $ dynamicCurrent i

328+ return $ Identity <$> apply p c

329+eventCoercion Coercion = Coercion

330+behaviorCoercion Coercion = Coercion

331+dynamicCoercion = unsafeCoerce

332+#endif

232

333

233-- | Coerce a 'Behavior' between representationally-equivalent value types

334-- | Coerce a 'Behavior' between representationally-equivalent value types

234coerceBehavior :: (Reflex t, Coercible a b) => Behavior t a -> Behavior t b

335coerceBehavior :: (Reflex t, Coercible a b) => Behavior t a -> Behavior t b

@@ -409,15 +510,6 @@ instance (Reflex t, Semigroup a) => Semigroup (Behavior t a) where

409 times1p n = fmap $ times1p n

510 times1p n = fmap $ times1p n

410#endif

511#endif

411

512

412−--TODO: See if there's a better class in the standard libraries already

413−-- | A class for values that combines filtering and mapping using 'Maybe'.

414−class FunctorMaybe f where

415− -- | Combined mapping and filtering function.

416− fmapMaybe :: (a -> Maybe b) -> f a -> f b

417−

418−instance FunctorMaybe [] where

419− fmapMaybe f = catMaybes . fmap f

420−

421-- | Flipped version of 'fmapMaybe'.

513-- | Flipped version of 'fmapMaybe'.

422fforMaybe :: FunctorMaybe f => f a -> (a -> Maybe b) -> f b

514fforMaybe :: FunctorMaybe f => f a -> (a -> Maybe b) -> f b

423fforMaybe = flip fmapMaybe

515fforMaybe = flip fmapMaybe

@@ -517,54 +609,6 @@ traceEvent s = traceEventWith $ \x -> s <> ": " <> show x

517traceEventWith :: Reflex t => (a -> String) -> Event t a -> Event t a

609traceEventWith :: Reflex t => (a -> String) -> Event t a -> Event t a

518traceEventWith f = push $ \x -> trace (f x) $ return $ Just x

610traceEventWith f = push $ \x -> trace (f x) $ return $ Just x

519

611

520−-- | Tag type for 'Either' to use it as a 'DSum'.

521−data EitherTag l r a where

522− LeftTag :: EitherTag l r l

523− RightTag :: EitherTag l r r

524−

525−instance GEq (EitherTag l r) where

526− geq a b = case (a, b) of

527− (LeftTag, LeftTag) -> Just Refl

528− (RightTag, RightTag) -> Just Refl

529− _ -> Nothing

530−

531−instance GCompare (EitherTag l r) where

532− gcompare a b = case (a, b) of

533− (LeftTag, LeftTag) -> GEQ

534− (LeftTag, RightTag) -> GLT

535− (RightTag, LeftTag) -> GGT

536− (RightTag, RightTag) -> GEQ

537−

538−instance GShow (EitherTag l r) where

539− gshowsPrec _ a = case a of

540− LeftTag -> showString "LeftTag"

541− RightTag -> showString "RightTag"

542−

543−instance (Show l, Show r) => ShowTag (EitherTag l r) Identity where

544− showTaggedPrec t n (Identity a) = case t of

545− LeftTag -> showsPrec n a

546− RightTag -> showsPrec n a

547−

548−-- | Convert 'Either' to a 'DSum'. Inverse of 'dsumToEither'.

549−eitherToDSum :: Either a b -> DSum (EitherTag a b) Identity

550−eitherToDSum = \case

551− Left a -> (LeftTag :=> Identity a)

552− Right b -> (RightTag :=> Identity b)

553−

554−-- | Convert 'DSum' to 'Either'. Inverse of 'eitherToDSum'.

555−dsumToEither :: DSum (EitherTag a b) Identity -> Either a b

556−dsumToEither = \case

557− (LeftTag :=> Identity a) -> Left a

558− (RightTag :=> Identity b) -> Right b

559−

560−-- | Extract the values of a 'DMap' of 'EitherTag's.

561−dmapToThese :: DMap (EitherTag a b) Identity -> Maybe (These a b)

562−dmapToThese m = case (DMap.lookup LeftTag m, DMap.lookup RightTag m) of

563− (Nothing, Nothing) -> Nothing

564− (Just (Identity a), Nothing) -> Just $ This a

565− (Nothing, Just (Identity b)) -> Just $ That b

566− (Just (Identity a), Just (Identity b)) -> Just $ These a b

567−

568instance (Semigroup a, Reflex t) => Semigroup (Event t a) where

612instance (Semigroup a, Reflex t) => Semigroup (Event t a) where

569 (<>) = alignWith (mergeThese (<>))

613 (<>) = alignWith (mergeThese (<>))

570 sconcat = fmap sconcat . mergeList . toList

614 sconcat = fmap sconcat . mergeList . toList

src/Reflex/FunctorMaybe.hsnew file+13

@@ -0,0 +1,13 @@

1+module Reflex.FunctorMaybe where

3+import Data.Maybe

5+--TODO: See if there's a better class in the standard libraries already

6+-- | A class for values that combines filtering and mapping using 'Maybe'.

7+class FunctorMaybe f where

8+ -- | Combined mapping and filtering function.

9+ fmapMaybe :: (a -> Maybe b) -> f a -> f b

10+

11+instance FunctorMaybe [] where

12+ fmapMaybe f = catMaybes . fmap f

13+

src/Reflex/Host/Class.hs+12

@@ -1,3 +1,4 @@

1+{-# LANGUAGE CPP #-}

1{-# LANGUAGE ExistentialQuantification #-}

2{-# LANGUAGE ExistentialQuantification #-}

2{-# LANGUAGE FlexibleContexts #-}

3{-# LANGUAGE FlexibleContexts #-}

3{-# LANGUAGE FlexibleInstances #-}

4{-# LANGUAGE FlexibleInstances #-}

@@ -44,9 +45,20 @@ import Data.Dependent.Sum (DSum (..))

44import Data.GADT.Compare

45import Data.GADT.Compare

45import Data.Monoid

46import Data.Monoid

48+#ifdef SPECIALIZE_TO_SPIDERTIMELINE_GLOBAL

49+import Reflex.Spider.Internal (HasSpiderTimeline, SpiderHost (..), SpiderHostFrame (..), Subscriber (..), SpiderEventHandle (..), RootTrigger, runFrame, subscribe, scheduleClear, newEventWithTriggerIO, newFanEventWithTriggerIO, EventM (..), run)

50+import qualified Reflex.Spider.Internal

51+import Data.IORef

52+import Control.Monad.Primitive (touch)

53+#endif

54+

47-- Note: this import must come last to silence warnings from AMP

55-- Note: this import must come last to silence warnings from AMP

48import Prelude hiding (foldl, mapM, mapM_, sequence, sequence_)

56import Prelude hiding (foldl, mapM, mapM_, sequence, sequence_)

58+#ifdef SPECIALIZE_TO_SPIDERTIMELINE_GLOBAL

59+#include "../Spider/SpiderTimelineHost.include.hs"

60+#endif

61+

50-- | Framework implementation support class for the reflex implementation

62-- | Framework implementation support class for the reflex implementation

51-- represented by @t@.

63-- represented by @t@.

52class ( Reflex t

64class ( Reflex t

src/Reflex/Optimizer.hs+7−1

@@ -1,5 +1,6 @@

1{-# LANGUAGE CPP #-}

2{-# LANGUAGE LambdaCase #-}

3+{-# LANGUAGE OverloadedStrings #-}

3module Reflex.Optimizer (plugin) where

4module Reflex.Optimizer (plugin) where

4#ifdef ghcjs_HOST_OS

5#ifdef ghcjs_HOST_OS

@@ -10,14 +11,19 @@ plugin = undefined

11#else

12#else

13−import GhcPlugins

14import Control.Arrow

15+import CoreMonad

16+import Data.String

17+import GhcPlugins

16plugin :: Plugin

19plugin :: Plugin

17plugin = defaultPlugin { installCoreToDos = install }

20plugin = defaultPlugin { installCoreToDos = install }

19install :: [CommandLineOption] -> [CoreToDo] -> CoreM [CoreToDo]

22install :: [CommandLineOption] -> [CoreToDo] -> CoreM [CoreToDo]

20install [] p = return $ makeInlinable : p

23install [] p = return $ makeInlinable : p

24+install options@(_:_) p = do

25+ warnMsg $ "Reflex.Optimizer: ignoring " <> fromString (show $ length options) <> " command-line options"

26+ install [] p

22makeInlinable :: CoreToDo

28makeInlinable :: CoreToDo

23makeInlinable = CoreDoPluginPass "MakeInlinable" $ \modGuts -> do

29makeInlinable = CoreDoPluginPass "MakeInlinable" $ \modGuts -> do

src/Reflex/Pure.hs−1

@@ -31,7 +31,6 @@ import Data.MemoTrie

31import Data.Monoid

32import Data.Type.Coercion

33import Reflex.Class

34−import Reflex.Patch

36data Pure t

35data Pure t

src/Reflex/Spider/Internal.hs+12−191

@@ -41,6 +41,7 @@ import qualified Data.Dependent.Map as DMap

41import Data.Foldable hiding (concat, elem, sequence_)

42import Data.Function

43import Data.Functor.Constant

44+import Data.Functor.Misc

44import Data.Functor.Product

45import Data.Functor.Product

45import Data.GADT.Compare

46import Data.GADT.Compare

46import Data.IntMap.Strict (IntMap)

47import Data.IntMap.Strict (IntMap)

@@ -54,11 +55,11 @@ import Data.Some (Some)

54import qualified Data.Some as Some

55import qualified Data.Some as Some

55import Data.These

56import Data.These

56import Data.Traversable

57import Data.Traversable

57−import Data.Type.Coercion

58import Data.Word

59import GHC.Exts

60import GHC.IORef (IORef (..))

61import GHC.Stack

62+import Reflex.FunctorMaybe

62import System.IO.Unsafe

63import System.IO.Unsafe

63import System.Mem.Weak

64import System.Mem.Weak

64import Unsafe.Coerce

65import Unsafe.Coerce

@@ -73,12 +74,13 @@ import Data.Tree (Forest, Tree (..), drawForest)

74import Data.WeakBag (WeakBag, WeakBagTicket)

75import Data.WeakBag (WeakBag, WeakBagTicket)

75import qualified Data.WeakBag as WeakBag

76import qualified Data.WeakBag as WeakBag

77+#ifndef SPECIALIZE_TO_SPIDERTIMELINE_GLOBAL

78+import Data.Type.Coercion

79+import qualified Reflex.Class

76import qualified Reflex.Class as R

80import qualified Reflex.Class as R

77−#ifdef SPECIALIZE_TO_SPIDERTIMELINE_GLOBAL

78−import Reflex.Class (SpiderTimeline, Global)

81+import qualified Reflex.Host.Class

79#endif

82#endif

80import Reflex.Patch

83import Reflex.Patch

81−import qualified Reflex.Host.Class as R

83-- Note: must come last to silence warnings due to AMP on GHC < 7.10

85-- Note: must come last to silence warnings due to AMP on GHC < 7.10

84import Prelude hiding (any, concat, mapM, mapM_, sequence)

86import Prelude hiding (any, concat, mapM, mapM_, sequence)

@@ -678,6 +680,8 @@ data Hold x p

678#endif

680#endif

679 }

681 }

680

682

683+data Global

684+

681{-# NOINLINE globalSpiderTimelineEnv #-}

685{-# NOINLINE globalSpiderTimelineEnv #-}

682globalSpiderTimelineEnv :: SpiderTimelineEnv Global

686globalSpiderTimelineEnv :: SpiderTimelineEnv Global

683!globalSpiderTimelineEnv = unsafePerformIO unsafeNewSpiderTimelineEnv

687!globalSpiderTimelineEnv = unsafePerformIO unsafeNewSpiderTimelineEnv

@@ -1041,12 +1045,12 @@ newInvalidatorSwitch subd = return $! InvalidatorSwitch subd

1041newInvalidatorPull :: Pull x a -> IO (Invalidator x)

1045newInvalidatorPull :: Pull x a -> IO (Invalidator x)

1042newInvalidatorPull p = return $! InvalidatorPull p

1046newInvalidatorPull p = return $! InvalidatorPull p

1043

1047

1044−instance HasSpiderTimeline x => R.FunctorMaybe (Event x) where

1048+instance HasSpiderTimeline x => FunctorMaybe (Event x) where

1045 fmapMaybe f = push $ return . f

1049 fmapMaybe f = push $ return . f

1046

1050

1047instance HasSpiderTimeline x => Align (Event x) where

1051instance HasSpiderTimeline x => Align (Event x) where

1048 nil = eventNever

1052 nil = eventNever

1049− align ea eb = R.fmapMaybe R.dmapToThese $ merge $ dynamicConst $ DMap.fromList [R.LeftTag :=> ea, R.RightTag :=> eb]

1053+ align ea eb = fmapMaybe dmapToThese $ merge $ dynamicConst $ DMap.fromList [LeftTag :=> ea, RightTag :=> eb]

1050

1054

1051newtype Dyn x p = Dyn { unDyn :: IORef (Either (BehaviorM x (PatchTarget p), Event x p) (Hold x p)) }

1055newtype Dyn x p = Dyn { unDyn :: IORef (Either (BehaviorM x (PatchTarget p), Event x p) (Hold x p)) }

1052

1056

@@ -1073,15 +1077,6 @@ unsafeDyn :: BehaviorM x (PatchTarget p) -> Event x p -> Dyn x p

1073unsafeDyn readV0 v' = Dyn $ unsafeNewIORef x $ Left x

1077unsafeDyn readV0 v' = Dyn $ unsafeNewIORef x $ Left x

1074 where x = (readV0, v')

1078 where x = (readV0, v')

1075

1079

1076−newJoinDyn :: HasSpiderTimeline x => Dynamic x (Identity (Dynamic x (Identity a))) -> Dyn x (Identity a)

1077−newJoinDyn d =

1078− let readV0 = readBehaviorTracked . dynamicCurrent =<< readBehaviorTracked (dynamicCurrent d)

1079− eOuter = push (fmap (Just . Identity) . readBehaviorUntracked . dynamicCurrent . runIdentity) $ dynamicUpdated d

1080− eInner = switch $ dynamicUpdated <$> dynamicCurrent d

1081− eBoth = coincidence $ dynamicUpdated . runIdentity <$> dynamicUpdated d

1082− v' = unSpiderEvent $ R.leftmost $ map SpiderEvent [eBoth, eOuter, eInner]

1083− in unsafeDyn readV0 v'

1084−

1085-- ResultM can read behaviors and events

1080-- ResultM can read behaviors and events

1086type ResultM = EventM

1081type ResultM = EventM

1087

1082

@@ -1855,14 +1850,12 @@ invalidate toReconnectRef wis = do

1855-- Reflex integration

1850-- Reflex integration

1856--------------------------------------------------------------------------------

1851--------------------------------------------------------------------------------

1857

1852

1858−-- | The default, global Spider environment

1859−type Spider = SpiderTimeline Global

1860−

1861#ifndef SPECIALIZE_TO_SPIDERTIMELINE_GLOBAL

1853#ifndef SPECIALIZE_TO_SPIDERTIMELINE_GLOBAL

1862-- When we're specializing, we include this from Reflex.Class instead, because

1854-- When we're specializing, we include this from Reflex.Class instead, because

1863-- it needs access to these types; when we're not, we want them here, so our

1855-- it needs access to these types; when we're not, we want them here, so our

1864-- instance isn't an orphan instance.

1856-- instance isn't an orphan instance.

1865#include "SpiderTimeline.include.hs"

1857#include "SpiderTimeline.include.hs"

1858+#include "SpiderTimelineHost.include.hs"

1866#endif

1859#endif

1867

1860

1868unsafeNewSpiderTimelineEnv :: forall x. IO (SpiderTimelineEnv x)

1861unsafeNewSpiderTimelineEnv :: forall x. IO (SpiderTimelineEnv x)

@@ -1892,34 +1885,7 @@ newtype SpiderPullM x a = SpiderPullM (BehaviorM x a) deriving (Functor, Applica

1892

1885

1893newtype SpiderPushM x a = SpiderPushM (ComputeM x a) deriving (Functor, Applicative, Monad, MonadIO, MonadFix)

1886newtype SpiderPushM x a = SpiderPushM (ComputeM x a) deriving (Functor, Applicative, Monad, MonadIO, MonadFix)

1894

1887

1895−instance HasSpiderTimeline x => Functor (R.Dynamic (SpiderTimeline x)) where

1896− fmap f = SpiderDynamic . newMapDyn f . unSpiderDynamic

1897−

1898−instance HasSpiderTimeline x => Applicative (R.Dynamic (SpiderTimeline x)) where

1899− pure = SpiderDynamic . dynamicConst

1900− SpiderDynamic a <*> SpiderDynamic b = SpiderDynamic $ zipDynWith ($) a b

1901− _ *> b = b

1902− a <* _ = a

1903−

1904−instance HasSpiderTimeline x => Monad (R.Dynamic (SpiderTimeline x)) where

1905− {-# INLINE return #-}

1906− return = pure

1907− {-# INLINE (>>=) #-}

1908− x >>= f = SpiderDynamic $ dynamicDynIdentity $ newJoinDyn $ newMapDyn (unSpiderDynamic . f) $ unSpiderDynamic x

1909− {-# INLINE (>>) #-}

1910− _ >> y = y

1911− {-# INLINE fail #-}

1912− fail _ = error "Dynamic does not support 'fail'"

1913−

1914−#ifdef SPECIALIZE_TO_SPIDERTIMELINE_GLOBAL

1888+#ifndef SPECIALIZE_TO_SPIDERTIMELINE_GLOBAL

1915−instance t ~ SpiderTimeline Global => R.Reflex t where

1916− newtype Behavior t a = SpiderBehavior { unSpiderBehavior :: Behavior Global a }

1917− newtype Event t a = SpiderEvent { unSpiderEvent :: Event Global a }

1918− newtype Dynamic t a = SpiderDynamic { unSpiderDynamic :: Dynamic Global (Identity a) } -- deriving (Functor, Applicative, Monad)

1919− newtype Incremental t p = SpiderIncremental { unSpiderIncremental :: Dynamic Global p }

1920− type PullM t = SpiderPullM Global

1921− type PushM t = SpiderPushM Global

1922−#else

1923instance HasSpiderTimeline x => R.Reflex (SpiderTimeline x) where

1889instance HasSpiderTimeline x => R.Reflex (SpiderTimeline x) where

1924 {-# SPECIALIZE instance R.Reflex (SpiderTimeline Global) #-}

1890 {-# SPECIALIZE instance R.Reflex (SpiderTimeline Global) #-}

1925 newtype Behavior (SpiderTimeline x) a = SpiderBehavior { unSpiderBehavior :: Behavior x a }

1891 newtype Behavior (SpiderTimeline x) a = SpiderBehavior { unSpiderBehavior :: Behavior x a }

@@ -1928,7 +1894,6 @@ instance HasSpiderTimeline x => R.Reflex (SpiderTimeline x) where

1928 newtype Incremental (SpiderTimeline x) p = SpiderIncremental { unSpiderIncremental :: Dynamic x p }

1894 newtype Incremental (SpiderTimeline x) p = SpiderIncremental { unSpiderIncremental :: Dynamic x p }

1929 type PullM (SpiderTimeline x) = SpiderPullM x

1895 type PullM (SpiderTimeline x) = SpiderPullM x

1930 type PushM (SpiderTimeline x) = SpiderPushM x

1896 type PushM (SpiderTimeline x) = SpiderPushM x

1931−#endif

1932 {-# INLINABLE never #-}

1897 {-# INLINABLE never #-}

1933 never = SpiderEvent eventNever

1898 never = SpiderEvent eventNever

1934 {-# INLINABLE constant #-}

1899 {-# INLINABLE constant #-}

@@ -1966,63 +1931,7 @@ instance HasSpiderTimeline x => R.Reflex (SpiderTimeline x) where

1966 eventCoercion Coercion = Coercion

1931 eventCoercion Coercion = Coercion

1967 behaviorCoercion Coercion = Coercion

1932 behaviorCoercion Coercion = Coercion

1968 dynamicCoercion = unsafeCoerce --TODO: How can we avoid this unsafeCoerce? This is safe only because we know how Identity works as a Patch instance

1933 dynamicCoercion = unsafeCoerce --TODO: How can we avoid this unsafeCoerce? This is safe only because we know how Identity works as a Patch instance

1969−

1970−instance HasSpiderTimeline x => R.MonadSample (SpiderTimeline x) (EventM x) where

1971− {-# INLINABLE sample #-}

1972− sample (SpiderBehavior b) = readBehaviorUntracked b

1973−

1974−instance HasSpiderTimeline x => R.MonadHold (SpiderTimeline x) (EventM x) where

1975− {-# INLINABLE hold #-}

1976− hold = holdSpiderEventM

1977− {-# INLINABLE holdDyn #-}

1978− holdDyn = holdDynSpiderEventM

1979− {-# INLINABLE holdIncremental #-}

1980− holdIncremental = holdIncrementalSpiderEventM

1981−

1982−holdSpiderEventM :: HasSpiderTimeline x => a -> R.Event (SpiderTimeline x) a -> EventM x (R.Behavior (SpiderTimeline x) a)

1983−holdSpiderEventM v0 e = fmap (SpiderBehavior . behaviorHoldIdentity) $ hold v0 $ coerce $ unSpiderEvent e

1984−

1985−holdDynSpiderEventM :: HasSpiderTimeline x => a -> R.Event (SpiderTimeline x) a -> EventM x (R.Dynamic (SpiderTimeline x) a)

1986−holdDynSpiderEventM v0 e = fmap (SpiderDynamic . dynamicHoldIdentity) $ hold v0 $ coerce $ unSpiderEvent e

1987−

1988−holdIncrementalSpiderEventM :: (HasSpiderTimeline x, Patch p) => PatchTarget p -> R.Event (SpiderTimeline x) p -> EventM x (R.Incremental (SpiderTimeline x) p)

1989−holdIncrementalSpiderEventM v0 e = fmap (SpiderIncremental . dynamicHold) $ hold v0 $ unSpiderEvent e

1990−

1991−instance HasSpiderTimeline x => R.MonadHold (SpiderTimeline x) (SpiderHost x) where

1992− {-# INLINABLE hold #-}

1993− hold v0 e = R.runHostFrame $ R.hold v0 e

1994− {-# INLINABLE holdDyn #-}

1995− holdDyn v0 e = R.runHostFrame $ R.holdDyn v0 e

1996− {-# INLINABLE holdIncremental #-}

1997− holdIncremental v0 e = R.runHostFrame $ R.holdIncremental v0 e

1998−

1999−instance HasSpiderTimeline x => R.MonadSample (SpiderTimeline x) (SpiderHost x) where

2000− {-# INLINABLE sample #-}

2001− sample = runFrame . readBehaviorUntracked . unSpiderBehavior

2002−

2003−instance (

2004−#ifdef SPECIALIZE_TO_SPIDERTIMELINE_GLOBAL

2005− x ~ Global

2006−#endif

2007− ) => R.MonadSample (SpiderTimeline x) (SpiderPullM x) where

2008− {-# INLINABLE sample #-}

2009− sample = coerce . readBehaviorTracked . unSpiderBehavior

2010−

2011−instance (

2012−#ifdef SPECIALIZE_TO_SPIDERTIMELINE_GLOBAL

2013− x ~ Global

2014#endif

1934#endif

2015− ) => R.MonadSample (SpiderTimeline x) (SpiderPushM x) where

2016− {-# INLINABLE sample #-}

2017− sample (SpiderBehavior b) = SpiderPushM $ readBehaviorUntracked b

2018−

2019−instance HasSpiderTimeline x => R.MonadHold (SpiderTimeline x) (SpiderPushM x) where

2020− {-# INLINABLE hold #-}

2021− hold v0 e = R.current <$> R.holdDyn v0 e

2022− {-# INLINABLE holdDyn #-}

2023− holdDyn v0 (SpiderEvent e) = SpiderPushM $ fmap (SpiderDynamic . dynamicHoldIdentity) $ hold v0 $ coerce e

2024− {-# INLINABLE holdIncremental #-}

2025− holdIncremental v0 (SpiderEvent e) = SpiderPushM $ SpiderIncremental . dynamicHold <$> hold v0 e

2026

1935

2027data RootTrigger x a = forall k. GCompare k => RootTrigger (WeakBag (Subscriber x a), IORef (DMap k Identity), k a)

1936data RootTrigger x a = forall k. GCompare k => RootTrigger (WeakBag (Subscriber x a), IORef (DMap k Identity), k a)

2028

1937

@@ -2031,35 +1940,6 @@ data SpiderEventHandle x a = SpiderEventHandle

2031 , spiderEventHandleValue :: IORef (Maybe a)

1940 , spiderEventHandleValue :: IORef (Maybe a)

2032 }

1941 }

2033

1942

2034−instance HasSpiderTimeline x => R.MonadSubscribeEvent (SpiderTimeline x) (SpiderHostFrame x) where

2035− {-# INLINABLE subscribeEvent #-}

2036− subscribeEvent e = SpiderHostFrame $ do

2037− --TODO: Unsubscribe eventually (manually and/or with weak ref)

2038− val <- liftIO $ newIORef Nothing

2039− subscription <- subscribe (unSpiderEvent e) $ Subscriber

2040− { subscriberPropagate = \a -> do

2041− liftIO $ writeIORef val $ Just a

2042− scheduleClear val

2043− , subscriberInvalidateHeight = \_ -> return ()

2044− , subscriberRecalculateHeight = \_ -> return ()

2045− }

2046− return $ SpiderEventHandle

2047− { spiderEventHandleSubscription = subscription

2048− , spiderEventHandleValue = val

2049− }

2050−

2051−instance HasSpiderTimeline x => R.ReflexHost (SpiderTimeline x) where

2052− type EventTrigger (SpiderTimeline x) = RootTrigger x

2053− type EventHandle (SpiderTimeline x) = SpiderEventHandle x

2054− type HostFrame (SpiderTimeline x) = SpiderHostFrame x

2055−

2056−instance HasSpiderTimeline x => R.MonadReadEvent (SpiderTimeline x) (ReadPhase x) where

2057− {-# NOINLINE readEvent #-}

2058− readEvent h = ReadPhase $ fmap (fmap return) $ liftIO $ do

2059− result <- readIORef $ spiderEventHandleValue h

2060− touch h

2061− return result

2062−

2063instance MonadRef (EventM x) where

1943instance MonadRef (EventM x) where

2064 type Ref (EventM x) = Ref IO

1944 type Ref (EventM x) = Ref IO

2065 {-# INLINABLE newRef #-}

1945 {-# INLINABLE newRef #-}

@@ -2108,17 +1988,6 @@ instance Monad (SpiderHostFrame x) where

2108 {-# INLINABLE fail #-}

1988 {-# INLINABLE fail #-}

2109 fail s = SpiderHostFrame $ fail s

1989 fail s = SpiderHostFrame $ fail s

2110

1990

2111−instance HasSpiderTimeline x => R.MonadSample (SpiderTimeline x) (SpiderHostFrame x) where

2112− sample = SpiderHostFrame . readBehaviorUntracked . unSpiderBehavior --TODO: This can cause problems with laziness, so we should get rid of it if we can

2113−

2114−instance HasSpiderTimeline x => R.MonadHold (SpiderTimeline x) (SpiderHostFrame x) where

2115− {-# INLINABLE hold #-}

2116− hold v0 e = SpiderHostFrame $ fmap (SpiderBehavior . behaviorHoldIdentity) $ hold v0 $ coerce $ unSpiderEvent e

2117− {-# INLINABLE holdDyn #-}

2118− holdDyn v0 e = SpiderHostFrame $ fmap (SpiderDynamic . dynamicHoldIdentity) $ hold v0 $ coerce $ unSpiderEvent e

2119− {-# INLINABLE holdIncremental #-}

2120− holdIncremental v0 e = SpiderHostFrame $ fmap (SpiderIncremental . dynamicHold) $ hold v0 $ unSpiderEvent e

2121−

2122newEventWithTriggerIO :: (RootTrigger x a -> IO (IO ())) -> IO (Event x a)

1991newEventWithTriggerIO :: (RootTrigger x a -> IO (IO ())) -> IO (Event x a)

2123newEventWithTriggerIO f = do

1992newEventWithTriggerIO f = do

2124 es <- newFanEventWithTriggerIO $ \Refl -> f

1993 es <- newFanEventWithTriggerIO $ \Refl -> f

@@ -2135,49 +2004,8 @@ newFanEventWithTriggerIO f = do

2135 }

2004 }

2136 return $ EventSelector $ \k -> eventRoot k r

2005 return $ EventSelector $ \k -> eventRoot k r

2137

2006

2138−instance (

2139−#ifdef SPECIALIZE_TO_SPIDERTIMELINE_GLOBAL

2140− x ~ Global

2141−#endif

2142− ) => R.MonadReflexCreateTrigger (SpiderTimeline x) (SpiderHost x) where

2143− newEventWithTrigger = SpiderHost . lift . fmap SpiderEvent . newEventWithTriggerIO

2144− newFanEventWithTrigger f = SpiderHost $ lift $ do

2145− es <- newFanEventWithTriggerIO f

2146− return $ R.EventSelector $ SpiderEvent . select es

2147−

2148−instance (

2149−#ifdef SPECIALIZE_TO_SPIDERTIMELINE_GLOBAL

2150− x ~ Global

2151−#endif

2152− ) => R.MonadReflexCreateTrigger (SpiderTimeline x) (SpiderHostFrame x) where

2153− newEventWithTrigger = SpiderHostFrame . EventM . liftIO . fmap SpiderEvent . newEventWithTriggerIO

2154− newFanEventWithTrigger f = SpiderHostFrame $ EventM $ liftIO $ do

2155− es <- newFanEventWithTriggerIO f

2156− return $ R.EventSelector $ SpiderEvent . select es

2157−

2158−instance HasSpiderTimeline x => R.MonadSubscribeEvent (SpiderTimeline x) (SpiderHost x) where

2159− {-# INLINABLE subscribeEvent #-}

2160− subscribeEvent = runFrame . runSpiderHostFrame . R.subscribeEvent

2161−

2162newtype ReadPhase x a = ReadPhase (ResultM x a) deriving (Functor, Applicative, Monad, MonadFix)

2007newtype ReadPhase x a = ReadPhase (ResultM x a) deriving (Functor, Applicative, Monad, MonadFix)

2163

2008

2164−instance HasSpiderTimeline x => R.MonadSample (SpiderTimeline x) (ReadPhase x) where

2165− {-# INLINABLE sample #-}

2166− sample = ReadPhase . R.sample

2167−

2168−instance HasSpiderTimeline x => R.MonadHold (SpiderTimeline x) (ReadPhase x) where

2169− {-# INLINABLE hold #-}

2170− hold v0 e = ReadPhase $ R.hold v0 e

2171− {-# INLINABLE holdDyn #-}

2172− holdDyn v0 e = ReadPhase $ R.holdDyn v0 e

2173− {-# INLINABLE holdIncremental #-}

2174− holdIncremental v0 e = ReadPhase $ R.holdIncremental v0 e

2175−

2176−instance HasSpiderTimeline x => R.MonadReflexHost (SpiderTimeline x) (SpiderHost x) where

2177− type ReadPhase (SpiderHost x) = ReadPhase x

2178− fireEventsAndRead es (ReadPhase a) = run es a

2179− runHostFrame = runFrame . runSpiderHostFrame

2180−

2181instance MonadRef (SpiderHost x) where

2009instance MonadRef (SpiderHost x) where

2182 type Ref (SpiderHost x) = Ref IO

2010 type Ref (SpiderHost x) = Ref IO

2183 newRef = SpiderHost . newRef

2011 newRef = SpiderHost . newRef

@@ -2199,10 +2027,3 @@ instance MonadAtomicRef (SpiderHostFrame x) where

2199instance PrimMonad (SpiderHostFrame x) where

2027instance PrimMonad (SpiderHostFrame x) where

2200 type PrimState (SpiderHostFrame x) = PrimState IO

2028 type PrimState (SpiderHostFrame x) = PrimState IO

2201 primitive = SpiderHostFrame . EventM . primitive

2029 primitive = SpiderHostFrame . EventM . primitive

2202−

2203−--------------------------------------------------------------------------------

2204−-- Deprecated items

2205−--------------------------------------------------------------------------------

2206−

2207−{-# DEPRECATED SpiderEnv "Use 'SpiderTimelineEnv' instead" #-}

2208−type SpiderEnv = SpiderTimeline

src/Reflex/Spider/SpiderTimeline.include.hs+118−2

@@ -1,5 +1,121 @@

1-- | Designates the default, global Spider timeline

2−data Global

3−

4data SpiderTimeline x

2data SpiderTimeline x

5type role SpiderTimeline nominal

3type role SpiderTimeline nominal

5+-- | The default, global Spider environment

6+type Spider = SpiderTimeline Global

8+instance HasSpiderTimeline x => Reflex.Class.MonadSample (SpiderTimeline x) (EventM x) where

9+ {-# INLINABLE sample #-}

10+ sample (SpiderBehavior b) = readBehaviorUntracked b

11+

12+instance HasSpiderTimeline x => Reflex.Class.MonadHold (SpiderTimeline x) (EventM x) where

13+ {-# INLINABLE hold #-}

14+ hold = holdSpiderEventM

15+ {-# INLINABLE holdDyn #-}

16+ holdDyn = holdDynSpiderEventM

17+ {-# INLINABLE holdIncremental #-}

18+ holdIncremental = holdIncrementalSpiderEventM

19+

20+instance (

21+#ifdef SPECIALIZE_TO_SPIDERTIMELINE_GLOBAL

22+ x ~ Global

23+#endif

24+ ) => Reflex.Class.MonadSample (SpiderTimeline x) (SpiderPullM x) where

25+ {-# INLINABLE sample #-}

26+ sample = coerce . readBehaviorTracked . unSpiderBehavior

27+

28+instance (

29+#ifdef SPECIALIZE_TO_SPIDERTIMELINE_GLOBAL

30+ x ~ Global

31+#endif

32+ ) => Reflex.Class.MonadSample (SpiderTimeline x) (SpiderPushM x) where

33+ {-# INLINABLE sample #-}

34+ sample (SpiderBehavior b) = SpiderPushM $ readBehaviorUntracked b

35+

36+instance HasSpiderTimeline x => Reflex.Class.MonadHold (SpiderTimeline x) (SpiderPushM x) where

37+ {-# INLINABLE hold #-}

38+ hold v0 e = Reflex.Class.current <$> Reflex.Class.holdDyn v0 e

39+ {-# INLINABLE holdDyn #-}

40+ holdDyn v0 (SpiderEvent e) = SpiderPushM $ fmap (SpiderDynamic . dynamicHoldIdentity) $ Reflex.Spider.Internal.hold v0 $ coerce e

41+ {-# INLINABLE holdIncremental #-}

42+ holdIncremental v0 (SpiderEvent e) = SpiderPushM $ SpiderIncremental . dynamicHold <$> Reflex.Spider.Internal.hold v0 e

43+

44+instance HasSpiderTimeline x => Monad (Reflex.Class.Dynamic (SpiderTimeline x)) where

45+ {-# INLINE return #-}

46+ return = pure

47+ {-# INLINE (>>=) #-}

48+ x >>= f = SpiderDynamic $ dynamicDynIdentity $ newJoinDyn $ newMapDyn (unSpiderDynamic . f) $ unSpiderDynamic x

49+ {-# INLINE (>>) #-}

50+ _ >> y = y

51+ {-# INLINE fail #-}

52+ fail _ = error "Dynamic does not support 'fail'"

53+

54+newJoinDyn :: HasSpiderTimeline x => Reflex.Spider.Internal.Dynamic x (Identity (Reflex.Spider.Internal.Dynamic x (Identity a))) -> Reflex.Spider.Internal.Dyn x (Identity a)

55+newJoinDyn d =

56+ let readV0 = readBehaviorTracked . dynamicCurrent =<< readBehaviorTracked (dynamicCurrent d)

57+ eOuter = Reflex.Spider.Internal.push (fmap (Just . Identity) . readBehaviorUntracked . dynamicCurrent . runIdentity) $ dynamicUpdated d

58+ eInner = Reflex.Spider.Internal.switch $ dynamicUpdated <$> dynamicCurrent d

59+ eBoth = Reflex.Spider.Internal.coincidence $ dynamicUpdated . runIdentity <$> dynamicUpdated d

60+ v' = unSpiderEvent $ Reflex.Class.leftmost $ map SpiderEvent [eBoth, eOuter, eInner]

61+ in unsafeDyn readV0 v'

62+

63+instance HasSpiderTimeline x => Functor (Reflex.Class.Dynamic (SpiderTimeline x)) where

64+ fmap f = SpiderDynamic . newMapDyn f . unSpiderDynamic

65+

66+instance HasSpiderTimeline x => Applicative (Reflex.Class.Dynamic (SpiderTimeline x)) where

67+ pure = SpiderDynamic . dynamicConst

68+ SpiderDynamic a <*> SpiderDynamic b = SpiderDynamic $ Reflex.Spider.Internal.zipDynWith ($) a b

69+ _ *> b = b

70+ a <* _ = a

71+

72+holdSpiderEventM :: HasSpiderTimeline x => a -> Reflex.Class.Event (SpiderTimeline x) a -> EventM x (Reflex.Class.Behavior (SpiderTimeline x) a)

73+holdSpiderEventM v0 e = fmap (SpiderBehavior . behaviorHoldIdentity) $ Reflex.Spider.Internal.hold v0 $ coerce $ unSpiderEvent e

74+

75+holdDynSpiderEventM :: HasSpiderTimeline x => a -> Reflex.Class.Event (SpiderTimeline x) a -> EventM x (Reflex.Class.Dynamic (SpiderTimeline x) a)

76+holdDynSpiderEventM v0 e = fmap (SpiderDynamic . dynamicHoldIdentity) $ Reflex.Spider.Internal.hold v0 $ coerce $ unSpiderEvent e

77+

78+holdIncrementalSpiderEventM :: (HasSpiderTimeline x, Patch p) => PatchTarget p -> Reflex.Class.Event (SpiderTimeline x) p -> EventM x (Reflex.Class.Incremental (SpiderTimeline x) p)

79+holdIncrementalSpiderEventM v0 e = fmap (SpiderIncremental . dynamicHold) $ Reflex.Spider.Internal.hold v0 $ unSpiderEvent e

80+

81+instance HasSpiderTimeline x => Reflex.Class.MonadHold (SpiderTimeline x) (SpiderHost x) where

82+ {-# INLINABLE hold #-}

83+ hold v0 e = runFrame . runSpiderHostFrame $ Reflex.Class.hold v0 e

84+ {-# INLINABLE holdDyn #-}

85+ holdDyn v0 e = runFrame . runSpiderHostFrame $ Reflex.Class.holdDyn v0 e

86+ {-# INLINABLE holdIncremental #-}

87+ holdIncremental v0 e = runFrame . runSpiderHostFrame $ Reflex.Class.holdIncremental v0 e

88+

89+instance HasSpiderTimeline x => Reflex.Class.MonadSample (SpiderTimeline x) (SpiderHostFrame x) where

90+ sample = SpiderHostFrame . readBehaviorUntracked . unSpiderBehavior --TODO: This can cause problems with laziness, so we should get rid of it if we can

91+

92+instance HasSpiderTimeline x => Reflex.Class.MonadHold (SpiderTimeline x) (SpiderHostFrame x) where

93+ {-# INLINABLE hold #-}

94+ hold v0 e = SpiderHostFrame $ fmap (SpiderBehavior . behaviorHoldIdentity) $ Reflex.Spider.Internal.hold v0 $ coerce $ unSpiderEvent e

95+ {-# INLINABLE holdDyn #-}

96+ holdDyn v0 e = SpiderHostFrame $ fmap (SpiderDynamic . dynamicHoldIdentity) $ Reflex.Spider.Internal.hold v0 $ coerce $ unSpiderEvent e

97+ {-# INLINABLE holdIncremental #-}

98+ holdIncremental v0 e = SpiderHostFrame $ fmap (SpiderIncremental . dynamicHold) $ Reflex.Spider.Internal.hold v0 $ unSpiderEvent e

99+

100+instance HasSpiderTimeline x => Reflex.Class.MonadSample (SpiderTimeline x) (SpiderHost x) where

101+ {-# INLINABLE sample #-}

102+ sample = runFrame . readBehaviorUntracked . unSpiderBehavior

103+

104+instance HasSpiderTimeline x => Reflex.Class.MonadSample (SpiderTimeline x) (Reflex.Spider.Internal.ReadPhase x) where

105+ {-# INLINABLE sample #-}

106+ sample = Reflex.Spider.Internal.ReadPhase . Reflex.Class.sample

107+

108+instance HasSpiderTimeline x => Reflex.Class.MonadHold (SpiderTimeline x) (Reflex.Spider.Internal.ReadPhase x) where

109+ {-# INLINABLE hold #-}

110+ hold v0 e = Reflex.Spider.Internal.ReadPhase $ Reflex.Class.hold v0 e

111+ {-# INLINABLE holdDyn #-}

112+ holdDyn v0 e = Reflex.Spider.Internal.ReadPhase $ Reflex.Class.holdDyn v0 e

113+ {-# INLINABLE holdIncremental #-}

114+ holdIncremental v0 e = Reflex.Spider.Internal.ReadPhase $ Reflex.Class.holdIncremental v0 e

115+

116+--------------------------------------------------------------------------------

117+-- Deprecated items

118+--------------------------------------------------------------------------------

119+

120+{-# DEPRECATED SpiderEnv "Use 'SpiderTimelineEnv' instead" #-}

121+type SpiderEnv = SpiderTimeline

src/Reflex/Spider/SpiderTimelineHost.include.hsnew file+57

@@ -0,0 +1,57 @@

1+instance HasSpiderTimeline x => Reflex.Host.Class.MonadSubscribeEvent (SpiderTimeline x) (SpiderHostFrame x) where

2+ {-# INLINABLE subscribeEvent #-}

3+ subscribeEvent e = SpiderHostFrame $ do

4+ --TODO: Unsubscribe eventually (manually and/or with weak ref)

5+ val <- liftIO $ newIORef Nothing

6+ subscription <- subscribe (unSpiderEvent e) $ Subscriber

7+ { subscriberPropagate = \a -> do

8+ liftIO $ writeIORef val $ Just a

9+ scheduleClear val

10+ , subscriberInvalidateHeight = \_ -> return ()

11+ , subscriberRecalculateHeight = \_ -> return ()

12+ }

13+ return $ SpiderEventHandle

14+ { spiderEventHandleSubscription = subscription

15+ , spiderEventHandleValue = val

16+ }

17+

18+instance HasSpiderTimeline x => Reflex.Host.Class.ReflexHost (SpiderTimeline x) where

19+ type EventTrigger (SpiderTimeline x) = RootTrigger x

20+ type EventHandle (SpiderTimeline x) = SpiderEventHandle x

21+ type HostFrame (SpiderTimeline x) = SpiderHostFrame x

22+

23+instance HasSpiderTimeline x => Reflex.Host.Class.MonadReadEvent (SpiderTimeline x) (Reflex.Spider.Internal.ReadPhase x) where

24+ {-# NOINLINE readEvent #-}

25+ readEvent h = Reflex.Spider.Internal.ReadPhase $ fmap (fmap return) $ liftIO $ do

26+ result <- readIORef $ spiderEventHandleValue h

27+ touch h

28+ return result

29+

30+instance (

31+#ifdef SPECIALIZE_TO_SPIDERTIMELINE_GLOBAL

32+ x ~ Global

33+#endif

34+ ) => Reflex.Host.Class.MonadReflexCreateTrigger (SpiderTimeline x) (SpiderHost x) where

35+ newEventWithTrigger = SpiderHost . lift . fmap SpiderEvent . newEventWithTriggerIO

36+ newFanEventWithTrigger f = SpiderHost $ lift $ do

37+ es <- newFanEventWithTriggerIO f

38+ return $ Reflex.Class.EventSelector $ SpiderEvent . Reflex.Spider.Internal.select es

39+

40+instance (

41+#ifdef SPECIALIZE_TO_SPIDERTIMELINE_GLOBAL

42+ x ~ Global

43+#endif

44+ ) => Reflex.Host.Class.MonadReflexCreateTrigger (SpiderTimeline x) (SpiderHostFrame x) where

45+ newEventWithTrigger = SpiderHostFrame . EventM . liftIO . fmap SpiderEvent . newEventWithTriggerIO

46+ newFanEventWithTrigger f = SpiderHostFrame $ EventM $ liftIO $ do

47+ es <- newFanEventWithTriggerIO f

48+ return $ Reflex.Class.EventSelector $ SpiderEvent . Reflex.Spider.Internal.select es

49+

50+instance HasSpiderTimeline x => Reflex.Host.Class.MonadSubscribeEvent (SpiderTimeline x) (SpiderHost x) where

51+ {-# INLINABLE subscribeEvent #-}

52+ subscribeEvent = runFrame . runSpiderHostFrame . Reflex.Host.Class.subscribeEvent

53+

54+instance HasSpiderTimeline x => Reflex.Host.Class.MonadReflexHost (SpiderTimeline x) (SpiderHost x) where

55+ type ReadPhase (SpiderHost x) = Reflex.Spider.Internal.ReadPhase x

56+ fireEventsAndRead es (Reflex.Spider.Internal.ReadPhase a) = run es a

57+ runHostFrame = runFrame . runSpiderHostFrame