682422b · reflex · git.iko.soy

git.iko.soy/reflex

on develop help sign in

WIP

682422bRyan Trinkle9 years ago

src/Reflex/Requester/Base.hs+48−2

compare with develop

unifiedsplit

@@ -25,7 +25,10 @@ module Reflex.Requester.Base

25 , traverseIntMapWithKeyWithAdjustRequesterTWith

26 , traverseDMapWithKeyWithAdjustRequesterTWith

27 , RequesterData

28+ , RequesterDataKey

28 , traverseRequesterData

29 , traverseRequesterData

30+ , requesterDataToList

31+ , singletonRequesterData

29 ) where

32 ) where

31import Reflex.Class

34import Reflex.Class

@@ -43,7 +46,7 @@ import Control.Monad.Ref

43import Control.Monad.State.Strict

46import Control.Monad.State.Strict

44import Data.Bits

47import Data.Bits

45import Data.Coerce

48import Data.Coerce

46−import Data.Dependent.Map (DMap)

49+import Data.Dependent.Map (DMap, DSum (..))

47import qualified Data.Dependent.Map as DMap

50import qualified Data.Dependent.Map as DMap

48import qualified Data.Some as Some

51import qualified Data.Some as Some

49import Data.FastMutableIntMap

52import Data.FastMutableIntMap

@@ -52,6 +55,7 @@ import Data.Functor.Misc

52import Data.IntMap.Strict (IntMap)

55import Data.IntMap.Strict (IntMap)

53import qualified Data.IntMap.Strict as IntMap

56import qualified Data.IntMap.Strict as IntMap

54import Data.Map (Map)

57import Data.Map (Map)

58+import qualified Data.Map as Map

55import Data.Monoid ((<>))

59import Data.Monoid ((<>))

56import Data.Unique.Tag

60import Data.Unique.Tag

57import Data.Some (Some)

61import Data.Some (Some)

@@ -66,6 +70,44 @@ newtype TagMap (f :: * -> *) = TagMap (IntMap Any)

67newtype RequesterData f = RequesterData (TagMap (Entry f))

71newtype RequesterData f = RequesterData (TagMap (Entry f))

73+data RequesterDataKey a where

74+ RequesterDataKey_Single :: {-# UNPACK #-} !(MyTag (Single a)) -> RequesterDataKey a

75+ RequesterDataKey_Multi :: {-# UNPACK #-} !(MyTag Multi) -> !(RequesterDataKey a) -> RequesterDataKey a

76+ RequesterDataKey_Multi2 :: {-# UNPACK #-} !(MyTag (Multi2 k)) -> {-# UNPACK #-} !(Some k) -> !(RequesterDataKey a) -> RequesterDataKey a

77+ RequesterDataKey_Multi3 :: {-# UNPACK #-} !(MyTag Multi3) -> Int -> !(RequesterDataKey a) -> RequesterDataKey a

78+

79+singletonRequesterData :: RequesterDataKey a -> f a -> RequesterData f

80+singletonRequesterData rdk v = case rdk of

81+ RequesterDataKey_Single k -> RequesterData $ singletonTagMap k $ Entry v

82+ RequesterDataKey_Multi k k' -> RequesterData $ singletonTagMap k $ Entry $ singletonRequesterData k' v

83+ RequesterDataKey_Multi2 k k' k'' -> RequesterData $ singletonTagMap k $ Entry $ Map.singleton k' $ singletonRequesterData k'' v

84+ RequesterDataKey_Multi3 k k' k'' -> RequesterData $ singletonTagMap k $ Entry $ IntMap.singleton k' $ singletonRequesterData k'' v

85+

86+requesterDataToList :: RequesterData f -> [DSum RequesterDataKey f]

87+requesterDataToList (RequesterData m) = do

88+ k :=> Entry e <- tagMapToList m

89+ case myKeyType k of

90+ MyTagType_Single -> return $ RequesterDataKey_Single k :=> e

91+ MyTagType_Multi -> do

92+ k' :=> e' <- requesterDataToList e

93+ return $ RequesterDataKey_Multi k k' :=> e'

94+ MyTagType_Multi2 -> do

95+ (k', e') <- Map.toList e

96+ k'' :=> e'' <- requesterDataToList e'

97+ return $ RequesterDataKey_Multi2 k k' k'' :=> e''

98+ MyTagType_Multi3 -> do

99+ (k', e') <- IntMap.toList e

100+ k'' :=> e'' <- requesterDataToList e'

101+ return $ RequesterDataKey_Multi3 k k' k'' :=> e''

102+

103+singletonTagMap :: forall f a. MyTag a -> f a -> TagMap f

104+singletonTagMap (MyTag k) v = TagMap $ IntMap.singleton k $ (unsafeCoerce :: f a -> Any) v

105+

106+tagMapToList :: forall f. TagMap f -> [DSum MyTag f]

107+tagMapToList (TagMap m) = fmap f $ IntMap.toList m

108+ where f :: (Int, Any) -> DSum MyTag f

109+ f (k, v) = MyTag k :=> ((unsafeCoerce :: Any -> f a) v)

110+

69traverseTagMapWithKey :: forall t f g. Applicative t => (forall a. MyTag a -> f a -> t (g a)) -> TagMap f -> t (TagMap g)

111traverseTagMapWithKey :: forall t f g. Applicative t => (forall a. MyTag a -> f a -> t (g a)) -> TagMap f -> t (TagMap g)

70traverseTagMapWithKey f (TagMap m) = TagMap <$> IntMap.traverseWithKey g m

112traverseTagMapWithKey f (TagMap m) = TagMap <$> IntMap.traverseWithKey g m

71 where

113 where

@@ -132,6 +174,10 @@ singleEntry = Entry

132multiEntry :: RequesterData f -> Entry f Multi

174multiEntry :: RequesterData f -> Entry f Multi

133multiEntry = Entry

175multiEntry = Entry

134

176

177+{-# INLINE unMultiEntry #-}

178+unMultiEntry :: Entry f Multi -> RequesterData f

179+unMultiEntry = unEntry

180+

135-- | We use a hack here to pretend we have x ~ request a; we don't want to use a GADT, because GADTs (even with zero-size existential contexts) can't be newtypes

181-- | We use a hack here to pretend we have x ~ request a; we don't want to use a GADT, because GADTs (even with zero-size existential contexts) can't be newtypes

136-- WARNING: This type should never be exposed. In particular, this is extremely unsound if a MyTag from one run of runRequesterT is ever compared against a MyTag from another

182-- WARNING: This type should never be exposed. In particular, this is extremely unsound if a MyTag from one run of runRequesterT is ever compared against a MyTag from another

137newtype MyTag x = MyTag Int deriving (Show, Eq, Ord, Enum)

183newtype MyTag x = MyTag Int deriving (Show, Eq, Ord, Enum)

@@ -267,7 +313,7 @@ runWithReplaceRequesterTWith :: forall m t request response a b. (Reflex t, Mona

267 -> Event t (RequesterT t request response m b)

313 -> Event t (RequesterT t request response m b)

268 -> RequesterT t request response m (a, Event t b)

314 -> RequesterT t request response m (a, Event t b)

269runWithReplaceRequesterTWith f a0 a' = do

315runWithReplaceRequesterTWith f a0 a' = do

270− rec response <- fmap (fmapCheap unEntry) $ requesting' $ fmapCheap multiEntry $ switchPromptlyDyn requests --TODO: Investigate whether we can really get rid of the prompt stuff here

316+ rec response <- fmap (fmapCheap unMultiEntry) $ requesting' $ fmapCheap multiEntry $ switchPromptlyDyn requests --TODO: Investigate whether we can really get rid of the prompt stuff here

271 ((result0, requests0), v') <- f (runRequesterT a0 response) $ fmapCheap (`runRequesterT` response) a'

317 ((result0, requests0), v') <- f (runRequesterT a0 response) $ fmapCheap (`runRequesterT` response) a'

272 requests <- holdDyn requests0 $ fmapCheap snd v'

318 requests <- holdDyn requests0 $ fmapCheap snd v'

273 return (result0, fmapCheap fst v')

319 return (result0, fmapCheap fst v')

src/Reflex/Spider/Internal.hs+3−1

@@ -1457,7 +1457,9 @@ newFanInt = do

1457

1458{-# NOINLINE unsafeNewFanInt #-}

1459unsafeNewFanInt :: b -> FanInt x a

1460−unsafeNewFanInt _ = unsafePerformIO newFanInt

1460+unsafeNewFanInt b = unsafePerformIO $ do

1461+ touch b

1462+ newFanInt

1461

1463

1462{-# NOINLINE fanInt #-}

1464{-# NOINLINE fanInt #-}

1463fanInt :: HasSpiderTimeline x => Event x (IntMap a) -> EventSelectorInt x a

1465fanInt :: HasSpiderTimeline x => Event x (IntMap a) -> EventSelectorInt x a