c1bcc10 · patch · git.iko.soy

git.iko.soy/patch

on develop help sign in

Get rid of sum type for Behavior

c1bcc10Ryan Trinkle10 years ago

src/Reflex/Spider/Internal.hs+73−67

compare with develop

unifiedsplit

@@ -585,6 +585,69 @@ data EventSubscription x a = EventSubscription

585unsubscribe :: EventSubscription x a -> IO ()

586unsubscribe (EventSubscription msln _) = forM_ msln $ \sln -> WeakBag.remove sln

587

588+--------------------------------------------------------------------------------

589+-- Behavior

590+--------------------------------------------------------------------------------

591+

592+newtype Behavior x a = Behavior { readBehaviorTracked :: BehaviorM x a }

593+

594+behaviorHold :: Hold x p a -> Behavior x a

595+behaviorHold !h = Behavior $ readHoldTracked h

596+

597+behaviorHoldIdentity :: Hold x Identity a -> Behavior x a

598+behaviorHoldIdentity = behaviorHold

599+

600+behaviorConst :: a -> Behavior x a

601+behaviorConst !a = Behavior $ return a

602+

603+behaviorPull :: Pull x a -> Behavior x a

604+behaviorPull !p = Behavior $ do

605+ val <- liftIO $ readIORef $ pullValue p

606+ case val of

607+ Just subscribed -> do

608+ askParentsRef >>= mapM_ (\r -> liftIO $ modifyIORef' r (SomeBehaviorSubscribed (BehaviorSubscribedPull subscribed) :))

609+ askInvalidator >>= mapM_ (\wi -> liftIO $ modifyIORef' (pullSubscribedInvalidators subscribed) (wi:))

610+ liftIO $ touch $ pullSubscribedOwnInvalidator subscribed

611+ return $ pullSubscribedValue subscribed

612+ Nothing -> do

613+ i <- liftIO $ newInvalidatorPull p

614+ wi <- liftIO $ mkWeakPtrWithDebug i "InvalidatorPull"

615+ parentsRef <- liftIO $ newIORef []

616+ holdInits <- askBehaviorHoldInits

617+ a <- liftIO $ runReaderT (unBehaviorM $ pullCompute p) (Just (wi, parentsRef), holdInits)

618+ invsRef <- liftIO . newIORef . maybeToList =<< askInvalidator

619+ parents <- liftIO $ readIORef parentsRef

620+ let subscribed = PullSubscribed

621+ { pullSubscribedValue = a

622+ , pullSubscribedInvalidators = invsRef

623+ , pullSubscribedOwnInvalidator = i

624+ , pullSubscribedParents = parents

625+ }

626+ liftIO $ writeIORef (pullValue p) $ Just subscribed

627+ askParentsRef >>= mapM_ (\r -> liftIO $ modifyIORef' r (SomeBehaviorSubscribed (BehaviorSubscribedPull subscribed) :))

628+ return a

629+

630+behaviorDyn :: R.Patch p => Dyn x p a -> Behavior x a

631+behaviorDyn !d = Behavior $ readHoldTracked =<< getDynHold d

632+

633+behaviorDynIdentity :: Dyn x Identity a -> Behavior x a

634+behaviorDynIdentity = behaviorDyn

635+

636+{-# INLINE readHoldTracked #-}

637+readHoldTracked :: Hold x p a -> BehaviorM x a

638+readHoldTracked h = do

639+ result <- liftIO $ readIORef $ holdValue h

640+ askInvalidator >>= mapM_ (\wi -> liftIO $ modifyIORef' (holdInvalidators h) (wi:))

641+ askParentsRef >>= mapM_ (\r -> liftIO $ modifyIORef' r (SomeBehaviorSubscribed (BehaviorSubscribedHold h) :))

642+ return result

643+

644+{-# SPECIALIZE readBehaviorUntracked :: Behavior x a -> BehaviorM x a #-}

645+{-# SPECIALIZE readBehaviorUntracked :: Behavior x a -> EventM x a #-}

646+readBehaviorUntracked :: Defer (SomeHoldInit x) m => Behavior x a -> m a

647+readBehaviorUntracked b = do

648+ holdInits <- getDeferralQueue

649+ liftIO $ runBehaviorM (readBehaviorTracked b) Nothing holdInits --TODO: Specialize readBehaviorTracked to the Nothing and Just cases

650+

588--------------------------------------------------------------------------------

651--------------------------------------------------------------------------------

589-- Combinators

652-- Combinators

590--------------------------------------------------------------------------------

653--------------------------------------------------------------------------------

@@ -996,11 +1059,11 @@ data Dynamic x p a

996{-# INLINE current #-}

1059{-# INLINE current #-}

997current :: R.Patch p => Dynamic x p a -> Behavior x a

1060current :: R.Patch p => Dynamic x p a -> Behavior x a

998current = \case

1061current = \case

999− DynamicHold h -> BehaviorHold h

1062+ DynamicHold h -> behaviorHold h

1000− DynamicHoldIdentity h -> BehaviorHoldIdentity h

1063+ DynamicHoldIdentity h -> behaviorHoldIdentity h

1001− DynamicConst a -> BehaviorConst a

1064+ DynamicConst a -> behaviorConst a

1002− DynamicDyn d -> BehaviorDyn d

1065+ DynamicDyn d -> behaviorDyn d

1003− DynamicDynIdentity d -> BehaviorDynIdentity d

1066+ DynamicDynIdentity d -> behaviorDynIdentity d

1004

1067

1005--TODO: If you only need updated, not current, can we avoid actually constructing the Hold?

1068--TODO: If you only need updated, not current, can we avoid actually constructing the Hold?

1006{-# INLINE updated #-}

1069{-# INLINE updated #-}

@@ -1051,7 +1114,7 @@ instance Monad (Dynamic x Identity) where

1051 {-# INLINE return #-}

1114 {-# INLINE return #-}

1052 return = pure

1115 return = pure

1053 {-# INLINE (>>=) #-}

1116 {-# INLINE (>>=) #-}

1054− x >>= f = DynamicDynIdentity $ newJoinDyn $ newMapDyn f x --TODO: (>>), fail

1117+ x >>= f = DynamicDynIdentity $ newJoinDyn $ newMapDyn f x

1055 {-# INLINE (>>) #-}

1118 {-# INLINE (>>) #-}

1056 _ >> y = y

1119 _ >> y = y

1057 {-# INLINE fail #-}

1120 {-# INLINE fail #-}

@@ -1072,15 +1135,6 @@ newJoinDyn d =

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

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

1073 in unsafeDyn readV0 v'

1136 in unsafeDyn readV0 v'

1074

1137

1075−--type role Behavior representational

1076−data Behavior x a

1077− = forall p. BehaviorHold !(Hold x p a)

1078− | BehaviorHoldIdentity !(Hold x Identity a)

1079− | BehaviorConst !a

1080− | BehaviorPull !(Pull x a)

1081− | BehaviorDynIdentity !(Dyn x Identity a)

1082− | forall p. R.Patch p => BehaviorDyn !(Dyn x p a)

1083−

1084-- ResultM can read behaviors and events

1138-- ResultM can read behaviors and events

1085type ResultM = EventM

1139type ResultM = EventM

1086

1140

@@ -1105,7 +1159,7 @@ push f e = eventPush $ Push

1105

1159

1106{-# NOINLINE pull #-}

1160{-# NOINLINE pull #-}

1107pull :: BehaviorM x a -> Behavior x a

1161pull :: BehaviorM x a -> Behavior x a

1108−pull a = BehaviorPull $ Pull

1162+pull a = behaviorPull $ Pull

1109 { pullCompute = a

1163 { pullCompute = a

1110 , pullValue = unsafeNewIORef a Nothing

1164 , pullValue = unsafeNewIORef a Nothing

1111#ifdef DEBUG_NODEIDS

1165#ifdef DEBUG_NODEIDS

@@ -1267,13 +1321,6 @@ propagateSubscriberHold h a = do

1267

1321

1268data SomeResetCoincidence x = forall a. SomeResetCoincidence !(EventSubscription x a) !(Maybe (CoincidenceSubscribed x a)) -- The CoincidenceSubscriber will be present only if heights need to be reset

1322data SomeResetCoincidence x = forall a. SomeResetCoincidence !(EventSubscription x a) !(Maybe (CoincidenceSubscribed x a)) -- The CoincidenceSubscriber will be present only if heights need to be reset

1269

1323

1270−{-# SPECIALIZE readBehaviorUntracked :: Behavior x a -> BehaviorM x a #-}

1271−{-# SPECIALIZE readBehaviorUntracked :: Behavior x a -> EventM x a #-}

1272−readBehaviorUntracked :: Defer (SomeHoldInit x) m => Behavior x a -> m a

1273−readBehaviorUntracked b = do

1274− holdInits <- getDeferralQueue

1275− liftIO $ runBehaviorM (readBehaviorTracked b) Nothing holdInits --TODO: Specialize readBehaviorTracked to the Nothing and Just cases

1276−

1277runBehaviorM :: BehaviorM x a -> Maybe (Weak (Invalidator x), IORef [SomeBehaviorSubscribed x]) -> IORef [SomeHoldInit x] -> IO a

1324runBehaviorM :: BehaviorM x a -> Maybe (Weak (Invalidator x), IORef [SomeBehaviorSubscribed x]) -> IORef [SomeHoldInit x] -> IO a

1278runBehaviorM a mwi holdInits = runReaderT (unBehaviorM a) (mwi, holdInits)

1325runBehaviorM a mwi holdInits = runReaderT (unBehaviorM a) (mwi, holdInits)

1279

1326

@@ -1296,47 +1343,6 @@ askBehaviorHoldInits = do

1296 (_, !his) <- BehaviorM ask

1343 (_, !his) <- BehaviorM ask

1297 return his

1344 return his

1298

1345

1299−readBehaviorTracked :: Behavior x a -> BehaviorM x a

1300−readBehaviorTracked b = case b of

1301− BehaviorHold h -> readHoldTracked h

1302− BehaviorHoldIdentity h -> readHoldTracked h

1303− BehaviorConst a -> return a

1304− BehaviorPull p -> do

1305− val <- liftIO $ readIORef $ pullValue p

1306− case val of

1307− Just subscribed -> do

1308− askParentsRef >>= mapM_ (\r -> liftIO $ modifyIORef' r (SomeBehaviorSubscribed (BehaviorSubscribedPull subscribed) :))

1309− askInvalidator >>= mapM_ (\wi -> liftIO $ modifyIORef' (pullSubscribedInvalidators subscribed) (wi:))

1310− liftIO $ touch $ pullSubscribedOwnInvalidator subscribed

1311− return $ pullSubscribedValue subscribed

1312− Nothing -> do

1313− i <- liftIO $ newInvalidatorPull p

1314− wi <- liftIO $ mkWeakPtrWithDebug i "InvalidatorPull"

1315− parentsRef <- liftIO $ newIORef []

1316− holdInits <- askBehaviorHoldInits

1317− a <- liftIO $ runReaderT (unBehaviorM $ pullCompute p) (Just (wi, parentsRef), holdInits)

1318− invsRef <- liftIO . newIORef . maybeToList =<< askInvalidator

1319− parents <- liftIO $ readIORef parentsRef

1320− let subscribed = PullSubscribed

1321− { pullSubscribedValue = a

1322− , pullSubscribedInvalidators = invsRef

1323− , pullSubscribedOwnInvalidator = i

1324− , pullSubscribedParents = parents

1325− }

1326− liftIO $ writeIORef (pullValue p) $ Just subscribed

1327− askParentsRef >>= mapM_ (\r -> liftIO $ modifyIORef' r (SomeBehaviorSubscribed (BehaviorSubscribedPull subscribed) :))

1328− return a

1329− BehaviorDyn d -> readHoldTracked =<< getDynHold d

1330− BehaviorDynIdentity d -> readHoldTracked =<< getDynHold d

1331−

1332−{-# INLINE readHoldTracked #-}

1333−readHoldTracked :: Hold x p a -> BehaviorM x a

1334−readHoldTracked h = do

1335− result <- liftIO $ readIORef $ holdValue h

1336− askInvalidator >>= mapM_ (\wi -> liftIO $ modifyIORef' (holdInvalidators h) (wi:))

1337− askParentsRef >>= mapM_ (\r -> liftIO $ modifyIORef' r (SomeBehaviorSubscribed (BehaviorSubscribedHold h) :))

1338− return result

1339−

1340{-# INLINE getDynHold #-}

1346{-# INLINE getDynHold #-}

1341getDynHold :: (Defer (SomeHoldInit x) m, R.Patch p) => Dyn x p a -> m (Hold x p a)

1347getDynHold :: (Defer (SomeHoldInit x) m, R.Patch p) => Dyn x p a -> m (Hold x p a)

1342getDynHold d = do

1348getDynHold d = do

@@ -2020,7 +2026,7 @@ instance R.Reflex (SpiderEnv x) where

2020 {-# INLINABLE never #-}

2026 {-# INLINABLE never #-}

2021 never = SpiderEvent eventNever

2027 never = SpiderEvent eventNever

2022 {-# INLINABLE constant #-}

2028 {-# INLINABLE constant #-}

2023− constant = SpiderBehavior . BehaviorConst

2029+ constant = SpiderBehavior . behaviorConst

2024 {-# INLINABLE push #-}

2030 {-# INLINABLE push #-}

2025 push f = SpiderEvent . push (coerce f) . unSpiderEvent

2031 push f = SpiderEvent . push (coerce f) . unSpiderEvent

2026 {-# INLINABLE pull #-}

2032 {-# INLINABLE pull #-}

@@ -2065,7 +2071,7 @@ instance R.MonadHold (SpiderEnv x) (EventM x) where

2065 holdIncremental = holdIncrementalSpiderEventM

2071 holdIncremental = holdIncrementalSpiderEventM

2066

2072

2067holdSpiderEventM :: a -> R.Event (SpiderEnv x) a -> EventM x (R.Behavior (SpiderEnv x) a)

2073holdSpiderEventM :: a -> R.Event (SpiderEnv x) a -> EventM x (R.Behavior (SpiderEnv x) a)

2068−holdSpiderEventM v0 e = fmap (SpiderBehavior . BehaviorHoldIdentity) $ hold v0 $ coerce $ unSpiderEvent e

2074+holdSpiderEventM v0 e = fmap (SpiderBehavior . behaviorHoldIdentity) $ hold v0 $ coerce $ unSpiderEvent e

2069

2075

2070holdDynSpiderEventM :: a -> R.Event (SpiderEnv x) a -> EventM x (R.Dynamic (SpiderEnv x) a)

2076holdDynSpiderEventM :: a -> R.Event (SpiderEnv x) a -> EventM x (R.Dynamic (SpiderEnv x) a)

2071holdDynSpiderEventM v0 e = fmap (SpiderDynamic . DynamicHoldIdentity) $ hold v0 $ coerce $ unSpiderEvent e

2077holdDynSpiderEventM v0 e = fmap (SpiderDynamic . DynamicHoldIdentity) $ hold v0 $ coerce $ unSpiderEvent e

@@ -2185,7 +2191,7 @@ instance R.MonadSample (SpiderEnv x) (SpiderHostFrame x) where

2185

2191

2186instance R.MonadHold (SpiderEnv x) (SpiderHostFrame x) where

2192instance R.MonadHold (SpiderEnv x) (SpiderHostFrame x) where

2187 {-# INLINABLE hold #-}

2193 {-# INLINABLE hold #-}

2188− hold v0 e = SpiderHostFrame $ fmap (SpiderBehavior . BehaviorHoldIdentity) $ hold v0 $ coerce $ unSpiderEvent e

2194+ hold v0 e = SpiderHostFrame $ fmap (SpiderBehavior . behaviorHoldIdentity) $ hold v0 $ coerce $ unSpiderEvent e

2189 {-# INLINABLE holdDyn #-}

2195 {-# INLINABLE holdDyn #-}

2190 holdDyn v0 e = SpiderHostFrame $ fmap (SpiderDynamic . DynamicHoldIdentity) $ hold v0 $ coerce $ unSpiderEvent e

2196 holdDyn v0 e = SpiderHostFrame $ fmap (SpiderDynamic . DynamicHoldIdentity) $ hold v0 $ coerce $ unSpiderEvent e

2191 {-# INLINABLE holdIncremental #-}

2197 {-# INLINABLE holdIncremental #-}