From 9f04cee54abba90aa49f2d59c6ac4a65ffe6f78d Mon Sep 17 00:00:00 2001 From: Matthew Justin Bauer Date: Wed, 7 Feb 2018 22:20:06 -0600 Subject: [PATCH 001/241] Fix doc for "switcher" A small fix for a typo in Reflex.Class. --- src/Reflex/Class.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/Reflex/Class.hs b/src/Reflex/Class.hs index 5d87113f..3f0dd24e 100644 --- a/src/Reflex/Class.hs +++ b/src/Reflex/Class.hs @@ -363,8 +363,8 @@ instance Reflex t => Align (Event t) where gate :: Reflex t => Behavior t Bool -> Event t a -> Event t a gate = attachWithMaybe $ \allow a -> if allow then Just a else Nothing --- | Create a new behavior given a starting behavior and switch to a the --- behvior carried by the event when it fires. +-- | Create a new behavior given a starting behavior and switch to the +-- behavior carried by the event when it fires. switcher :: (Reflex t, MonadHold t m) => Behavior t a -> Event t (Behavior t a) -> m (Behavior t a) switcher b eb = pull . (sample <=< sample) <$> hold b eb From c2d5c14960be2a7038e887a4230cc191e1bd170c Mon Sep 17 00:00:00 2001 From: Ross MacLeod Date: Sat, 9 Jun 2018 21:10:09 -0400 Subject: [PATCH 002/241] add missing functions to Reflex.Patch.MapWithMove that Reflex.Patch.DMapWithMove has specifically: Semigroup instance Monoid instance insertMapKey deleteMapKey moveMapKey swapMapKey --- src/Reflex/Patch/MapWithMove.hs | 136 ++++++++++++++++++++++++++++---- 1 file changed, 121 insertions(+), 15 deletions(-) diff --git a/src/Reflex/Patch/MapWithMove.hs b/src/Reflex/Patch/MapWithMove.hs index 3d60b067..50017e52 100644 --- a/src/Reflex/Patch/MapWithMove.hs +++ b/src/Reflex/Patch/MapWithMove.hs @@ -3,6 +3,7 @@ {-# LANGUAGE DeriveTraversable #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE LambdaCase #-} +{-# LANGUAGE PatternGuards #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} -- | 'Patch'es on 'Map' that can insert, delete, and move values from one key to @@ -19,7 +20,9 @@ import Data.List import Data.Map (Map) import qualified Data.Map as Map import Data.Maybe +import Data.Semigroup (Semigroup (..), (<>)) import qualified Data.Set as Set +import Data.These import Data.Tuple -- | Patch a DMap with additions, deletions, and moves. Invariant: If key @k1@ @@ -38,6 +41,79 @@ data NodeInfo k v = NodeInfo } deriving (Show, Read, Eq, Ord, Functor, Foldable, Traversable) +-- | Describe how a key's new value should be produced +data From k v + = From_Insert v -- ^ Insert the given value here + | From_Delete -- ^ Delete the existing value, if any, from here + | From_Move !k -- ^ Move the value here from the given key + deriving (Show, Read, Eq, Ord, Functor, Foldable, Traversable) + +-- | Describe where a key's old value will go. If this is 'Just', that means +-- the key's old value will be moved to the given other key; if it is 'Nothing', +-- that means it will be deleted. +type To = Maybe + +-- |Helper data structure used for composing patches using the monoid instance. +data Fixup k v + = Fixup_Delete + | Fixup_Update (These (From k v) (To k)) + +-- |Compose patches having the same effect as applying the patches in turn: @'applyAlways' (p <> q) == 'applyAlways' p . 'applyAlways' q@ +instance Ord k => Semigroup (PatchMapWithMove k v) where + (<>) = mappend + +-- |Compose patches having the same effect as applying the patches in turn: @'applyAlways' (p <> q) == 'applyAlways' p . 'applyAlways' q@ +instance Ord k => Monoid (PatchMapWithMove k v) where + mempty = PatchMapWithMove mempty + PatchMapWithMove ma `mappend` PatchMapWithMove mb = PatchMapWithMove m + where + connections = Map.toList $ Map.intersectionWith (\ a b -> (_nodeInfo_to a, _nodeInfo_from b)) ma mb + h :: (k, (Maybe k, From k v)) -> [(k, Fixup k v)] + h (_, (mToAfter, editBefore)) = case (mToAfter, editBefore) of + (Just toAfter, From_Move fromBefore) + | fromBefore == toAfter + -> [(toAfter, Fixup_Delete)] + | otherwise + -> [ (toAfter, Fixup_Update (This editBefore)) + , (fromBefore, Fixup_Update (That mToAfter)) + ] + (Nothing, From_Move fromBefore) -> [(fromBefore, Fixup_Update (That mToAfter))] -- The item is destroyed in the second patch, so indicate that it is destroyed in the source map + (Just toAfter, _) -> [(toAfter, Fixup_Update (This editBefore))] + (Nothing, _) -> [] + mergeFixups Fixup_Delete Fixup_Delete = Fixup_Delete + mergeFixups (Fixup_Update a) (Fixup_Update b) + | This x <- a, That y <- b + = Fixup_Update $ These x y + | That y <- a, This x <- b + = Fixup_Update $ These x y + mergeFixups _ _ = error "PatchMapWithMove: incompatible fixups" + fixups = Map.fromListWith mergeFixups $ concatMap h connections + combineNodeInfos nia nib = NodeInfo + { _nodeInfo_from = _nodeInfo_from nia + , _nodeInfo_to = _nodeInfo_to nib + } + applyFixup ni = \case + Fixup_Delete -> Nothing + Fixup_Update u -> Just $ NodeInfo + { _nodeInfo_from = fromMaybe (_nodeInfo_from ni) $ getHere u + , _nodeInfo_to = fromMaybe (_nodeInfo_to ni) $ getThere u + } + m = Map.differenceWith applyFixup (Map.unionWith combineNodeInfos ma mb) fixups + +-- |Project the @a@ from a @'These' a b@, identical to @preview '_Here'@ but without using preview +getHere :: These a b -> Maybe a +getHere = \case + This a -> Just a + These a _ -> Just a + That _ -> Nothing + +-- |Project the @b@ from a @'These' a b@, identical to @preview '_There'@ but without using preview +getThere :: These a b -> Maybe b +getThere = \case + This _ -> Nothing + These _ b -> Just b + That b -> Just b + -- | Create a 'PatchMapWithMove', validating it patchMapWithMove :: Ord k => Map k (NodeInfo k v) -> Maybe (PatchMapWithMove k v) patchMapWithMove m = if valid then Just $ PatchMapWithMove m else Nothing @@ -52,22 +128,51 @@ patchMapWithMove m = if valid then Just $ PatchMapWithMove m else Nothing unPatchMapWithMove :: PatchMapWithMove k v -> Map k (NodeInfo k v) unPatchMapWithMove (PatchMapWithMove p) = p --- | Warning: when using this function, you must ensure that the invariants of --- 'PatchMapWithMove' are preserved; they will not be checked. -unsafePatchMapWithMove :: Map k (NodeInfo k v) -> PatchMapWithMove k v -unsafePatchMapWithMove = PatchMapWithMove +-- | Make a @'PatchMapWithMove' k v@ which has the effect of inserting or updating a value @v@ to the given key @k@, like 'Map.insert'. +insertMapKey :: k -> v -> PatchMapWithMove k v +insertMapKey k v = PatchMapWithMove . Map.singleton k $ NodeInfo (From_Insert v) Nothing --- | Describe how a key's new value should be produced -data From k v - = From_Insert v -- ^ Insert the given value here - | From_Delete -- ^ Delete the existing value, if any, from here - | From_Move !k -- ^ Move the value here from the given key - deriving (Show, Read, Eq, Ord, Functor, Foldable, Traversable) +-- |Make a @'PatchMapWithMove' k v@ which has the effect of moving the value from the first key @k@ to the second key @k@, equivalent to: +-- +-- @ +-- 'Map.delete' src (maybe map ('Map.insert' dst) (Map.lookup src map)) +-- @ +moveMapKey :: Ord k => k -> k -> PatchMapWithMove k v +moveMapKey src dst + | src == dst = mempty + | otherwise = + PatchMapWithMove $ Map.fromList + [ (dst, NodeInfo (From_Move src) Nothing) + , (src, NodeInfo From_Delete (Just dst)) + ] --- | Describe where a key's old value will go. If this is 'Just', that means --- the key's old value will be moved to the given other key; if it is 'Nothing', --- that means it will be deleted. -type To = Maybe +-- |Make a @'PatchMapWithMove' k v@ which has the effect of swapping two keys in the mapping, equivalent to: +-- +-- @ +-- let aMay = Map.lookup a map +-- bMay = Map.lookup b map +-- in maybe id (Map.insert a) (bMay `mplus` aMay) +-- . maybe id (Map.insert b) (aMay `mplus` bMay) +-- . Map.delete a . Map.delete b $ map +-- @ +swapMapKey :: Ord k => k -> k -> PatchMapWithMove k v +swapMapKey src dst + | src == dst = mempty + | otherwise = + PatchMapWithMove $ Map.fromList + [ (dst, NodeInfo (From_Move src) (Just src)) + , (src, NodeInfo (From_Move dst) (Just dst)) + ] + +-- |Make a @'PatchMapWithMove' k v@ which has the effect of deleting a key in the mapping, equivalent to 'Map.delete'. +deleteMapKey :: k -> PatchMapWithMove k v +deleteMapKey k = PatchMapWithMove . Map.singleton k $ NodeInfo From_Delete Nothing + +-- | Wrap a @'Map' k (NodeInfo k v)@ representing patch changes into a @'PatchMapWithMove' k v@, without checking any invariants. +-- +-- __Warning:__ when using this function, you must ensure that the invariants of 'PatchMapWithMove' are preserved; they will not be checked. +unsafePatchMapWithMove :: Map k (NodeInfo k v) -> PatchMapWithMove k v +unsafePatchMapWithMove = PatchMapWithMove -- | Apply the insertions, deletions, and moves to a given 'Map' instance Ord k => Patch (PatchMapWithMove k v) where @@ -81,10 +186,11 @@ instance Ord k => Patch (PatchMapWithMove k v) where From_Delete -> Just () _ -> Nothing --- | Returns all the new elements that will be added to the 'Map' +-- | Returns all the new elements that will be added to the 'Map'. patchMapWithMoveNewElements :: PatchMapWithMove k v -> [v] patchMapWithMoveNewElements = Map.elems . patchMapWithMoveNewElementsMap +-- | Return a @'Map' k v@ with all the inserts/updates from the given @'PatchMapWithMove' k v@. patchMapWithMoveNewElementsMap :: PatchMapWithMove k v -> Map k v patchMapWithMoveNewElementsMap (PatchMapWithMove p) = Map.mapMaybe f p where f ni = case _nodeInfo_from ni of From e79511edaa3419116d41ec61b5ee1c4bb8b9c512 Mon Sep 17 00:00:00 2001 From: Ross MacLeod Date: Sat, 9 Jun 2018 23:25:11 -0400 Subject: [PATCH 003/241] complete doc comments for Data.Map.Misc, Reflex.FastWeak, Reflex.Patch.DMap, Reflex.Patch.DMapWithMove, Reflex.Patch.IntMap, and Reflex.Patch.Map --- src/Data/Map/Misc.hs | 33 +++++++++++++++------ src/Reflex/FastWeak.hs | 51 ++++++++++++++++++++++++++++---- src/Reflex/Patch/DMap.hs | 24 ++++++++++----- src/Reflex/Patch/DMapWithMove.hs | 5 ++-- src/Reflex/Patch/IntMap.hs | 14 ++++++++- src/Reflex/Patch/Map.hs | 3 +- 6 files changed, 103 insertions(+), 27 deletions(-) diff --git a/src/Data/Map/Misc.hs b/src/Data/Map/Misc.hs index 93d8463d..84a5067c 100644 --- a/src/Data/Map/Misc.hs +++ b/src/Data/Map/Misc.hs @@ -1,4 +1,5 @@ {-# LANGUAGE LambdaCase #-} +-- |Additional functions for manipulating 'Map's. module Data.Map.Misc ( -- * Working with Maps @@ -10,7 +11,6 @@ module Data.Map.Misc ) where import Data.Align -import Data.Either import Data.Map (Map) import qualified Data.Map as Map import Data.Maybe @@ -18,12 +18,21 @@ import Data.Set (Set) import qualified Data.Set as Set import Data.These +-- |Produce a @'Map' k (Maybe v)@ by comparing two @'Map' k v@s, @old@ and @new@ respectively. @Just@ represents an association present in @new@ and @Nothing@ +-- represents an association only present in @old@ but no longer present in @new@. +-- +-- Similar to 'diffMap' but doesn't require 'Eq' on the values, thus can't tell if a value has changed or not. diffMapNoEq :: (Ord k) => Map k v -> Map k v -> Map k (Maybe v) diffMapNoEq olds news = flip Map.mapMaybe (align olds news) $ \case This _ -> Just Nothing These _ new -> Just $ Just new That new -> Just $ Just new +-- |Produce a @'Map' k (Maybe v)@ by comparing two @'Map' k v@s, @old@ and @new respectively. @Just@ represents an association present in @new@ and either not +-- present in @old@ or where the value has changed. @Nothing@ represents an association only present in @old@ but no longer present in @new@. +-- +-- See also 'diffMapNoEq' for a similar but weaker version which does not require 'Eq' on the values but thus can't indicated a value not changing between +-- @old@ and @new@ with @Nothing@. diffMap :: (Ord k, Eq v) => Map k v -> Map k v -> Map k (Maybe v) diffMap olds news = flip Map.mapMaybe (align olds news) $ \case This _ -> Just Nothing @@ -32,6 +41,9 @@ diffMap olds news = flip Map.mapMaybe (align olds news) $ \case | otherwise -> Just $ Just new That new -> Just $ Just new +-- |Given a @'Map' k (Maybe v)@ representing keys to insert/update (@Just@) or delete (@Nothing@), produce a new map from the given input @'Map' k v@. +-- +-- See also 'Reflex.Patch.Map' and 'Reflex.Patch.MapWithMove'. applyMap :: Ord k => Map k (Maybe v) -> Map k v -> Map k v applyMap patch old = insertions `Map.union` (old `Map.difference` deletions) where (deletions, insertions) = mapPartitionEithers $ maybeToEither <$> patch @@ -39,16 +51,19 @@ applyMap patch old = insertions `Map.union` (old `Map.difference` deletions) Nothing -> Left () Just r -> Right r +-- |Split a @'Map' k (Either a b)@ into @Map k a@ and @Map k b@, equivalent to @'Map.mapEither' id@ mapPartitionEithers :: Map k (Either a b) -> (Map k a, Map k b) -mapPartitionEithers m = (fromLeft <$> ls, fromRight <$> rs) - where (ls, rs) = Map.partition isLeft m - fromLeft (Left l) = l - fromLeft _ = error "mapPartitionEithers: fromLeft received a Right value; this should be impossible" - fromRight (Right r) = r - fromRight _ = error "mapPartitionEithers: fromRight received a Left value; this should be impossible" +mapPartitionEithers = Map.mapEither id --- | Apply a map patch to a set --- > applyMapKeysSet patch (Map.keysSet m) == Map.keysSet (applyMap patch m) +-- |Given a @'Map' k (Maybe v)@ representing keys to insert/update (@Just@) or delete (@Nothing@), produce a new @'Set' k@ from the given input set. +-- +-- Equivalent to: +-- +-- @ +-- applyMapKeysSet patch ('Map.keysSet' m) == 'Map.keysSet' ('applyMap' patch m) +-- @ +-- +-- but avoids the intervening @Map@ and needs no values. applyMapKeysSet :: Ord k => Map k (Maybe v) -> Set k -> Set k applyMapKeysSet patch old = Map.keysSet insertions `Set.union` (old `Set.difference` Map.keysSet deletions) where (insertions, deletions) = Map.partition isJust patch diff --git a/src/Reflex/FastWeak.hs b/src/Reflex/FastWeak.hs index 20238ddf..0b338f8e 100644 --- a/src/Reflex/FastWeak.hs +++ b/src/Reflex/FastWeak.hs @@ -5,6 +5,15 @@ {-# LANGUAGE ForeignFunctionInterface #-} {-# LANGUAGE JavaScriptFFI #-} #endif + +-- |Contains 'FastWeak', a weak pointer to some value, and 'FastWeakTicket' which ensures the value referred to by a 'FastWeak' stays live while the ticket is +-- held (live). +-- +-- On GHC or GHCJS when not built with the @fast-weak@ cabal flag, 'FastWeak' is a wrapper around the simple version of 'System.Mem.Weak.Weak' where the key +-- and value are the same. +-- +-- On GHCJS when built with the @fast-weak@ cabal flag, 'FastWeak' is implemented directly in JS using @h$FastWeak@ and @h$FastWeakTicket@ which are a +-- nonstandard part of the GHCJS RTS. __FIXME__ module Reflex.FastWeak ( FastWeakTicket , FastWeak @@ -35,29 +44,52 @@ import System.Mem.Weak #ifdef GHCJS_FAST_WEAK +-- |A 'FastWeak' which has been promoted to a strong reference. 'getFastWeakTicketValue' can be used to get the referred to value without fear of @Nothing, +-- and 'getFastWeakTicketWeak' can be used to get the weak version. +-- +-- Implemented by way of special support in the GHCJS RTS, @h$FastWeakTicket@. newtype FastWeakTicket a = FastWeakTicket JSVal +-- |A reference to some value which can be garbage collected if there are only weak references to the value left. +-- +-- 'getFastWeakValue' can be used to try and obtain a strong reference to the value. +-- +-- The value in a @FastWeak@ can also be kept alive by obtaining a 'FastWeakTicket' using 'getFastWeakTicket' if the value hasn't been collected yet. +-- +-- Implemented by way of special support in the GHCJS RTS, @h$FastWeak@. newtype FastWeak a = FastWeak JSVal -- Just designed to mirror JSVal, so that we can unsafeCoerce between the two data Val a = Val { unVal :: a } --- | Coerce a JSVal that represents the heap object of a value of type 'a' into a value of type 'a' +-- | Coerce a JSVal that represents the heap object of a value of type @a@ into a value of type @a@ unsafeFromRawJSVal :: JSVal -> a unsafeFromRawJSVal v = unVal (unsafeCoerce v) +-- | Coerce a heap object of type @a@ into a 'JSVal' which represents that object. unsafeToRawJSVal :: a -> JSVal unsafeToRawJSVal v = unsafeCoerce (Val v) #else +-- |A 'FastWeak' which has been promoted to a strong reference. 'getFastWeakTicketValue' can be used to get the referred to value without fear of @Nothing, +-- and 'getFastWeakTicketWeak' can be used to get the weak version. data FastWeakTicket a = FastWeakTicket { _fastWeakTicket_val :: !a , _fastWeakTicket_weak :: {-# UNPACK #-} !(Weak a) } +-- |A reference to some value which can be garbage collected if there are only weak references to the value left. +-- +-- 'getFastWeakValue' can be used to try and obtain a strong reference to the value. +-- +-- The value in a @FastWeak@ can also be kept alive by obtaining a 'FastWeakTicket' using 'getFastWeakTicket' if the value hasn't been collected yet. +-- +-- Synonymous with 'Weak'. type FastWeak a = Weak a #endif --- This needs to be in IO so we know that we've relinquished the ticket +-- |Return the @a@ kept alive by the given 'FastWeakTicket'. +-- +-- This needs to be in IO so we know that we've relinquished the ticket. getFastWeakTicketValue :: FastWeakTicket a -> IO a #ifdef GHCJS_FAST_WEAK getFastWeakTicketValue t = do @@ -69,6 +101,7 @@ foreign import javascript unsafe "$r = $1.val;" js_ticketVal :: FastWeakTicket a getFastWeakTicketValue = return . _fastWeakTicket_val #endif +-- |Get the value referred to by a 'FastWeak' if it hasn't yet been collected, or @Nothing@ if it has been collected. getFastWeakValue :: FastWeak a -> IO (Maybe a) #ifdef GHCJS_FAST_WEAK getFastWeakValue w = do @@ -84,6 +117,8 @@ foreign import javascript unsafe "$r = ($1.ticket === null) ? null : $1.ticket.v getFastWeakValue = deRefWeak #endif +-- |Try to create a 'FastWeakTicket' for the given 'FastWeak' which will ensure the referred to value remains alive. Returns @Just@ if the value hasn't been +-- collected and a ticket can therefore be obtained, @Nothing@ if it's been collected. getFastWeakTicket :: forall a. FastWeak a -> IO (Maybe (FastWeakTicket a)) #ifdef GHCJS_FAST_WEAK getFastWeakTicket w = do @@ -103,8 +138,10 @@ getFastWeakTicket w = do } #endif --- I think it's fine if this is lazy - it'll retain the 'a', but so would the output; we just need to make sure it's forced before we start relying on the associated FastWeak to actually be weak +-- |Create a 'FastWeakTicket' directly from a value, creating a 'FastWeak' in the process which can be obtained with 'getFastWeakTicketValue'. mkFastWeakTicket :: a -> IO (FastWeakTicket a) +-- I think it's fine if this is lazy - it'll retain the 'a', but so would the output; we just need to make sure it's forced before we start relying on the +-- associated FastWeak to actually be weak #ifdef GHCJS_FAST_WEAK mkFastWeakTicket v = js_fastWeakTicket (unsafeToRawJSVal v) @@ -119,11 +156,15 @@ mkFastWeakTicket v = do } #endif +-- |Demote a 'FastWeakTicket' which ensures the value is alive to a 'FastWeak' which doesn't. Note that unless the ticket or another for the same 'FastWeak' is +-- held some other way the value might be collected immediately. +getFastWeakTicketWeak :: FastWeakTicket a -> IO (FastWeak a) -- Needs IO so that it can force the value - otherwise, could end up with a reference to the Ticket, which would retain the value #ifdef GHCJS_FAST_WEAK -foreign import javascript unsafe "$r = $1.weak;" getFastWeakTicketWeak :: FastWeakTicket a -> IO (FastWeak a) +foreign import javascript unsafe "$r = $1.weak;" getFastWeakTicketWeak' :: FastWeakTicket a -> IO (FastWeak a) +{-# INLINE getFastWeakTicketWeak #-} +getFastWeakTicketWeak = getFastWeakTicketWeak' #else -getFastWeakTicketWeak :: FastWeakTicket a -> IO (FastWeak a) getFastWeakTicketWeak = return . _fastWeakTicket_weak #endif diff --git a/src/Reflex/Patch/DMap.hs b/src/Reflex/Patch/DMap.hs index d44a87fc..1b89ee75 100644 --- a/src/Reflex/Patch/DMap.hs +++ b/src/Reflex/Patch/DMap.hs @@ -5,6 +5,7 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeFamilies #-} +-- | 'Patch'es on 'DMap' that consist only of insertions (or overwrites) and deletions. module Reflex.Patch.DMap where import Reflex.Patch.Class @@ -20,14 +21,15 @@ import qualified Data.Map as Map import Data.Semigroup (Semigroup (..)) import Data.Some (Some) --- | A set of changes to a 'DMap'. Any element may be inserted/updated or --- deleted. +-- | A set of changes to a 'DMap'. Any element may be inserted/updated or deleted. Insertions are represented as @'ComposeMaybe' (Just value)@, while +-- deletions are represented as @'ComposeMaybe' Nothing@. newtype PatchDMap k v = PatchDMap { unPatchDMap :: DMap k (ComposeMaybe v) } deriving instance GCompare k => Semigroup (PatchDMap k v) deriving instance GCompare k => Monoid (PatchDMap k v) +-- |Apply the insertions or deletions to a given 'DMap'. instance GCompare k => Patch (PatchDMap k v) where type PatchTarget (PatchDMap k v) = DMap k v apply (PatchDMap diff) old = Just $! insertions `DMap.union` (old `DMap.difference` deletions) --TODO: return Nothing sometimes --Note: the strict application here is critical to ensuring that incremental merges don't hold onto all their prerequisite events forever; can we make this more robust? @@ -37,32 +39,38 @@ instance GCompare k => Patch (PatchDMap k v) where Nothing -> Just $ Constant () Just _ -> Nothing +-- | Map a function @v a -> v' a@ over any inserts/updates in the given @'PatchDMap' k v@ to produce a @'PatchDMap' k v'@. mapPatchDMap :: (forall a. v a -> v' a) -> PatchDMap k v -> PatchDMap k v' mapPatchDMap f (PatchDMap p) = PatchDMap $ DMap.map (ComposeMaybe . fmap f . getComposeMaybe) p -traversePatchDMap :: Applicative m => (forall a. v a -> m (v' a)) -> PatchDMap k v -> m (PatchDMap k v') +-- | Map an effectful function @v a -> f (v' a)@ over any inserts/updates in the given @'PatchDMap' k v@ to produce a @'PatchDMap' k v'@. +traversePatchDMap :: Applicative f => (forall a. v a -> f (v' a)) -> PatchDMap k v -> f (PatchDMap k v') traversePatchDMap f = traversePatchDMapWithKey $ const f +-- | Map an effectful function @k a -> v a -> f (v' a)@ over any inserts/updates in the given @'PatchDMap' k v@ to produce a @'PatchDMap' k v'@. traversePatchDMapWithKey :: Applicative m => (forall a. k a -> v a -> m (v' a)) -> PatchDMap k v -> m (PatchDMap k v') traversePatchDMapWithKey f (PatchDMap p) = PatchDMap <$> DMap.traverseWithKey (\k (ComposeMaybe v) -> ComposeMaybe <$> traverse (f k) v) p +-- | Weaken a @'PatchDMap' k v@ to a @'PatchMap' (Some k) v'@ using a function @v a -> v'@ to weaken each value contained in the patch. weakenPatchDMapWith :: (forall a. v a -> v') -> PatchDMap k v -> PatchMap (Some k) v' weakenPatchDMapWith f (PatchDMap p) = PatchMap $ weakenDMapWith (fmap f . getComposeMaybe) p -patchDMapToPatchMapWith :: (f v -> v') -> PatchDMap (Const2 k v) f -> PatchMap k v' +-- | Convert a weak @'PatchDMap' ('Const2' k a) v@ where the @a@ is known by way of the @Const2@ into a @'PatchMap' k v'@ using a rank 1 function @v a -> v'@. +patchDMapToPatchMapWith :: (v a -> v') -> PatchDMap (Const2 k a) v -> PatchMap k v' patchDMapToPatchMapWith f (PatchDMap p) = PatchMap $ dmapToMapWith (fmap f . getComposeMaybe) p -const2PatchDMapWith :: forall k v f a. (v -> f a) -> PatchMap k v -> PatchDMap (Const2 k a) f +-- | Convert a @'PatchMap' k v@ into a @'PatchDMap' ('Const2' k a) v'@ using a function @v -> v' a@. +const2PatchDMapWith :: forall k v v' a. (v -> v' a) -> PatchMap k v -> PatchDMap (Const2 k a) v' const2PatchDMapWith f (PatchMap p) = PatchDMap $ DMap.fromDistinctAscList $ g <$> Map.toAscList p - where g :: (k, Maybe v) -> DSum (Const2 k a) (ComposeMaybe f) + where g :: (k, Maybe v) -> DSum (Const2 k a) (ComposeMaybe v') g (k, e) = Const2 k :=> ComposeMaybe (f <$> e) +-- | Convert a @'PatchIntMap' v@ into a @'PatchDMap' ('Const2' Int a) v'@ using a function @v -> v' a@. const2IntPatchDMapWith :: forall v f a. (v -> f a) -> PatchIntMap v -> PatchDMap (Const2 IntMap.Key a) f const2IntPatchDMapWith f (PatchIntMap p) = PatchDMap $ DMap.fromDistinctAscList $ g <$> IntMap.toAscList p where g :: (IntMap.Key, Maybe v) -> DSum (Const2 IntMap.Key a) (ComposeMaybe f) g (k, e) = Const2 k :=> ComposeMaybe (f <$> e) --- | Get the values that will be deleted if the given patch is applied to the --- given 'DMap'. Includes values that will be replaced. +-- | Get the values that will be replaced or deleted if the given patch is applied to the given 'DMap'. getDeletions :: GCompare k => PatchDMap k v -> DMap k v' -> DMap k v' getDeletions (PatchDMap p) m = DMap.intersectionWithKey (\_ v _ -> v) m p diff --git a/src/Reflex/Patch/DMapWithMove.hs b/src/Reflex/Patch/DMapWithMove.hs index 3380b8cb..80479a70 100644 --- a/src/Reflex/Patch/DMapWithMove.hs +++ b/src/Reflex/Patch/DMapWithMove.hs @@ -121,6 +121,7 @@ validationErrorsForPatchDMapWithMove m = Just $ "unbalanced move at source key " <> gshow src <> " supposedly going to " <> gshow dst <> " but destination key is not moving" unbalancedMove _ = Nothing +-- |Test whether two @'PatchDMapWithMove' k v@ contain the same patch operations. instance EqTag k (NodeInfo k v) => Eq (PatchDMapWithMove k v) where PatchDMapWithMove a == PatchDMapWithMove b = a == b @@ -362,6 +363,7 @@ const2PatchDMapWithMoveWith f (PatchMapWithMove p) = PatchDMapWithMove $ DMap.fr , _nodeInfo_to = ComposeMaybe $ Const2 <$> MapWithMove._nodeInfo_to ni } +-- | Apply the insertions, deletions, and moves to a given 'DMap'. instance GCompare k => Patch (PatchDMapWithMove k v) where type PatchTarget (PatchDMapWithMove k v) = DMap k v apply (PatchDMapWithMove p) old = Just $! insertions `DMap.union` (old `DMap.difference` deletions) --TODO: return Nothing sometimes --Note: the strict application here is critical to ensuring that incremental merges don't hold onto all their prerequisite events forever; can we make this more robust? @@ -377,8 +379,7 @@ instance GCompare k => Patch (PatchDMapWithMove k v) where From_Delete -> Just $ Constant () _ -> Nothing --- | Get the values that will be deleted or moved if the given patch is applied --- to the given 'DMap'. +-- | Get the values that will be replaced, deleted, or moved if the given patch is applied to the given 'DMap'. getDeletionsAndMoves :: GCompare k => PatchDMapWithMove k v -> DMap k v' -> DMap k (Product v' (ComposeMaybe k)) getDeletionsAndMoves (PatchDMapWithMove p) m = DMap.intersectionWithKey f m p where f _ v ni = Pair v $ _nodeInfo_to ni diff --git a/src/Reflex/Patch/IntMap.hs b/src/Reflex/Patch/IntMap.hs index 463788c4..fc3ec1b4 100644 --- a/src/Reflex/Patch/IntMap.hs +++ b/src/Reflex/Patch/IntMap.hs @@ -4,6 +4,7 @@ {-# LANGUAGE DeriveTraversable #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE TypeFamilies #-} +-- |Module containing 'PatchIntMap', a 'Patch' for 'IntMap' which allows for insert/update or delete of associations. module Reflex.Patch.IntMap where import Prelude hiding (lookup) @@ -13,8 +14,11 @@ import Data.Maybe import Data.Semigroup import Reflex.Patch.Class +-- |'Patch' for 'IntMap' which represents insertion or deletion of keys in the mapping. Internally represented by 'IntMap (Maybe a)', where @Just@ means +-- insert/update and @Nothing@ means delete. newtype PatchIntMap a = PatchIntMap (IntMap (Maybe a)) deriving (Functor, Foldable, Traversable, Monoid) +-- |Apply the insertions or deletions to a given 'IntMap'. instance Patch (PatchIntMap a) where type PatchTarget (PatchIntMap a) = IntMap a apply (PatchIntMap p) v = if IntMap.null p then Nothing else Just $ @@ -37,14 +41,22 @@ instance Semigroup (PatchIntMap v) where GT -> x #endif -traverseIntMapPatchWithKey :: Applicative t => (Int -> a -> t b) -> PatchIntMap a -> t (PatchIntMap b) +-- |Map a function @Int -> a -> b@ over all @a@s in the given @'PatchIntMap' a@ (that is, all inserts/updates), producing a @PatchIntMap b@. +mapIntMapPatchWithKey :: (Int -> a -> b) -> PatchIntMap a -> PatchIntMap b +mapIntMapPatchWithKey f (PatchIntMap m) = PatchIntMap $ IntMap.mapWithKey (\ k mv -> f k <$> mv) m + +-- |Map an effectful function @Int -> a -> f b@ over all @a@s in the given @'PatchIntMap' a@ (that is, all inserts/updates), producing a @f (PatchIntMap b)@. +traverseIntMapPatchWithKey :: Applicative f => (Int -> a -> f b) -> PatchIntMap a -> f (PatchIntMap b) traverseIntMapPatchWithKey f (PatchIntMap m) = PatchIntMap <$> IntMap.traverseWithKey (\k mv -> traverse (f k) mv) m +-- |Extract all @a@s inserted/updated by the given @'PatchIntMap' a@. patchIntMapNewElements :: PatchIntMap a -> [a] patchIntMapNewElements (PatchIntMap m) = catMaybes $ IntMap.elems m +-- |Convert the given @'PatchIntMap' a@ into an @'IntMap' a@ with all the inserts/updates in the given patch. patchIntMapNewElementsMap :: PatchIntMap a -> IntMap a patchIntMapNewElementsMap (PatchIntMap m) = IntMap.mapMaybe id m +-- |Subset the given @'IntMap' a@ to contain only the keys that would be deleted by the given @'PatchIntMap' a@. getDeletions :: PatchIntMap v -> IntMap v' -> IntMap v' getDeletions (PatchIntMap m) v = IntMap.intersection v m diff --git a/src/Reflex/Patch/Map.hs b/src/Reflex/Patch/Map.hs index c5c74f7b..89f1c398 100644 --- a/src/Reflex/Patch/Map.hs +++ b/src/Reflex/Patch/Map.hs @@ -18,8 +18,7 @@ import Data.Maybe newtype PatchMap k v = PatchMap { unPatchMap :: Map k (Maybe v) } deriving (Show, Read, Eq, Ord) --- | Applying a 'PatchMap' will update the 'Map' by performing the insertions --- and deletions specified +-- |Apply the insertions or deletions to a given 'Map'. instance Ord k => Patch (PatchMap k v) where type PatchTarget (PatchMap k v) = Map k v {-# INLINABLE apply #-} From 538e87964a7986e8cea230e5fcae3bb3b88ccf94 Mon Sep 17 00:00:00 2001 From: Ken Micklas Date: Wed, 18 Jul 2018 15:39:19 -0400 Subject: [PATCH 004/241] Suppress nil patch events in QueryT as an optimization Note that this now requires the query type to have an `Eq` instance. --- src/Reflex/Query/Base.hs | 51 +++++++++++++++++----------------------- 1 file changed, 22 insertions(+), 29 deletions(-) diff --git a/src/Reflex/Query/Base.hs b/src/Reflex/Query/Base.hs index 5391ae72..6f1cff9c 100644 --- a/src/Reflex/Query/Base.hs +++ b/src/Reflex/Query/Base.hs @@ -64,26 +64,19 @@ getQueryTLoweredResultValue (QueryTLoweredResult (v, _)) = v getQueryTLoweredResultWritten :: QueryTLoweredResult t q v -> [Behavior t q] getQueryTLoweredResultWritten (QueryTLoweredResult (_, w)) = w -{- -let sampleBs :: forall m'. MonadSample t m' => [Behavior t q] -> m' q - sampleBs = foldlM (\b a -> (b <>) <$> sample a) mempty - bs' = fmapCheap snd $ r' - patches = unsafeBuildIncremental (sampleBs bs0) $ - flip pushCheap bs' $ \bs -> do - p <- (~~) <$> sampleBs bs <*> sample (currentIncremental patches) - return (Just (AdditivePatch p)) --} +maskMempty :: (Eq a, Monoid a) => a -> Maybe a +maskMempty x = if x == mempty then Nothing else Just x -instance (Reflex t, MonadFix m, Group q, Additive q, Query q, MonadHold t m, Adjustable t m) => Adjustable t (QueryT t q m) where +instance (Reflex t, MonadFix m, Group q, Additive q, Query q, Eq q, MonadHold t m, Adjustable t m) => Adjustable t (QueryT t q m) where runWithReplace (QueryT a0) a' = do ((r0, bs0), r') <- QueryT $ lift $ runWithReplace (runStateT a0 []) $ fmapCheap (flip runStateT [] . unQueryT) a' let sampleBs :: forall m'. MonadSample t m' => [Behavior t q] -> m' q sampleBs = foldlM (\b a -> (b <>) <$> sample a) mempty bs' = fmapCheap snd $ r' bbs <- hold bs0 bs' - let patches = flip pushAlwaysCheap bs' $ \newBs -> do + let patches = flip pushCheap bs' $ \newBs -> do oldBs <- sample bbs - (~~) <$> sampleBs newBs <*> sampleBs oldBs + maskMempty <$> ((~~) <$> sampleBs newBs <*> sampleBs oldBs) QueryT $ modify $ (:) $ pull $ sampleBs =<< sample bbs QueryT $ lift $ tellEvent patches return (r0, fmapCheap fst r') @@ -115,19 +108,19 @@ instance (Reflex t, MonadFix m, Group q, Additive q, Query q, MonadHold t m, Adj let p k bs = case Map.lookup k bs0 of Nothing -> case bs of -- If the update is to delete the state for a child that doesn't exist, the patch is mempty. - Nothing -> return mempty + Nothing -> return Nothing -- If the update is to update the state for a child that doesn't exist, the patch is the sample of the new state. - Just newBs -> sampleBs newBs + Just newBs -> Just <$> sampleBs newBs Just oldBs -> case bs of -- If the update is to delete the state for a child that already exists, the patch is the negation of the child's current state - Nothing -> negateG <$> sampleBs oldBs + Nothing -> Just . negateG <$> sampleBs oldBs -- If the update is to update the state for a child that already exists, the patch is the negation of sampling the child's current state -- composed with the sampling the child's new state. - Just newBs -> (~~) <$> sampleBs newBs <*> sampleBs oldBs + Just newBs -> maskMempty <$> ((~~) <$> sampleBs newBs <*> sampleBs oldBs) -- we compute the patch by iterating over the update PatchMap and proceeding by cases. Then we fold over the -- child patches and wrap them in AdditivePatch. - patch <- AdditivePatch . fold <$> Map.traverseWithKey p bs' - return (apply pbs bs0, Just patch) + patch <- fold <$> Map.traverseWithKey p bs' + return (apply pbs bs0, AdditivePatch <$> patch) (qpatch :: Event t (AdditivePatch q)) <- mapAccumMaybeM_ accumBehaviors liftedBs0 liftedBs' tellQueryIncremental $ unsafeBuildIncremental (fold <$> mapM sampleBs liftedBs0) qpatch return (liftedResult0, liftedResult') @@ -159,28 +152,28 @@ instance (Reflex t, MonadFix m, Group q, Additive q, Query q, MonadHold t m, Adj p k bs = case Map.lookup k bs0 of Nothing -> case MapWithMove._nodeInfo_from bs of -- If the update is to delete the state for a child that doesn't exist, the patch is mempty. - MapWithMove.From_Delete -> return mempty + MapWithMove.From_Delete -> return Nothing -- If the update is to update the state for a child that doesn't exist, the patch is the sample of the new state. - MapWithMove.From_Insert newBs -> sampleBs newBs + MapWithMove.From_Insert newBs -> Just <$> sampleBs newBs MapWithMove.From_Move k' -> case Map.lookup k' bs0 of - Nothing -> return mempty - Just newBs -> sampleBs newBs + Nothing -> return Nothing + Just newBs -> Just <$> sampleBs newBs Just oldBs -> case MapWithMove._nodeInfo_from bs of -- If the update is to delete the state for a child that already exists, the patch is the negation of the child's current state - MapWithMove.From_Delete -> negateG <$> sampleBs oldBs + MapWithMove.From_Delete -> Just . negateG <$> sampleBs oldBs -- If the update is to update the state for a child that already exists, the patch is the negation of sampling the child's current state -- composed with the sampling the child's new state. - MapWithMove.From_Insert newBs -> (~~) <$> sampleBs newBs <*> sampleBs oldBs + MapWithMove.From_Insert newBs -> maskMempty <$> ((~~) <$> sampleBs newBs <*> sampleBs oldBs) MapWithMove.From_Move k' - | k' == k -> return mempty + | k' == k -> return Nothing | otherwise -> case Map.lookup k' bs0 of -- If we are moving from a non-existent key, that is a delete - Nothing -> negateG <$> sampleBs oldBs - Just newBs -> (~~) <$> sampleBs newBs <*> sampleBs oldBs + Nothing -> Just . negateG <$> sampleBs oldBs + Just newBs -> maskMempty <$> ((~~) <$> sampleBs newBs <*> sampleBs oldBs) -- we compute the patch by iterating over the update PatchMap and proceeding by cases. Then we fold over the -- child patches and wrap them in AdditivePatch. - patch <- AdditivePatch . fold <$> Map.traverseWithKey p bs' - return (apply pbs bs0, Just patch) + patch <- fold <$> Map.traverseWithKey p bs' + return (apply pbs bs0, AdditivePatch <$> patch) (qpatch :: Event t (AdditivePatch q)) <- mapAccumMaybeM_ accumBehaviors' liftedBs0 liftedBs' tellQueryIncremental $ unsafeBuildIncremental (fold <$> mapM sampleBs liftedBs0) qpatch return (liftedResult0, liftedResult') From 7494f057f7106b7475a84758ba17c4cc3993ac18 Mon Sep 17 00:00:00 2001 From: Ken Micklas Date: Wed, 18 Jul 2018 16:55:45 -0400 Subject: [PATCH 005/241] Use maskMempty even for non-difference cases --- src/Reflex/Query/Base.hs | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) diff --git a/src/Reflex/Query/Base.hs b/src/Reflex/Query/Base.hs index 6f1cff9c..d8c19811 100644 --- a/src/Reflex/Query/Base.hs +++ b/src/Reflex/Query/Base.hs @@ -110,10 +110,10 @@ instance (Reflex t, MonadFix m, Group q, Additive q, Query q, Eq q, MonadHold t -- If the update is to delete the state for a child that doesn't exist, the patch is mempty. Nothing -> return Nothing -- If the update is to update the state for a child that doesn't exist, the patch is the sample of the new state. - Just newBs -> Just <$> sampleBs newBs + Just newBs -> maskMempty <$> sampleBs newBs Just oldBs -> case bs of -- If the update is to delete the state for a child that already exists, the patch is the negation of the child's current state - Nothing -> Just . negateG <$> sampleBs oldBs + Nothing -> maskMempty . negateG <$> sampleBs oldBs -- If the update is to update the state for a child that already exists, the patch is the negation of sampling the child's current state -- composed with the sampling the child's new state. Just newBs -> maskMempty <$> ((~~) <$> sampleBs newBs <*> sampleBs oldBs) @@ -154,13 +154,13 @@ instance (Reflex t, MonadFix m, Group q, Additive q, Query q, Eq q, MonadHold t -- If the update is to delete the state for a child that doesn't exist, the patch is mempty. MapWithMove.From_Delete -> return Nothing -- If the update is to update the state for a child that doesn't exist, the patch is the sample of the new state. - MapWithMove.From_Insert newBs -> Just <$> sampleBs newBs + MapWithMove.From_Insert newBs -> maskMempty <$> sampleBs newBs MapWithMove.From_Move k' -> case Map.lookup k' bs0 of Nothing -> return Nothing - Just newBs -> Just <$> sampleBs newBs + Just newBs -> maskMempty <$> sampleBs newBs Just oldBs -> case MapWithMove._nodeInfo_from bs of -- If the update is to delete the state for a child that already exists, the patch is the negation of the child's current state - MapWithMove.From_Delete -> Just . negateG <$> sampleBs oldBs + MapWithMove.From_Delete -> maskMempty . negateG <$> sampleBs oldBs -- If the update is to update the state for a child that already exists, the patch is the negation of sampling the child's current state -- composed with the sampling the child's new state. MapWithMove.From_Insert newBs -> maskMempty <$> ((~~) <$> sampleBs newBs <*> sampleBs oldBs) @@ -168,7 +168,7 @@ instance (Reflex t, MonadFix m, Group q, Additive q, Query q, Eq q, MonadHold t | k' == k -> return Nothing | otherwise -> case Map.lookup k' bs0 of -- If we are moving from a non-existent key, that is a delete - Nothing -> Just . negateG <$> sampleBs oldBs + Nothing -> maskMempty . negateG <$> sampleBs oldBs Just newBs -> maskMempty <$> ((~~) <$> sampleBs newBs <*> sampleBs oldBs) -- we compute the patch by iterating over the update PatchMap and proceeding by cases. Then we fold over the -- child patches and wrap them in AdditivePatch. From 47614f806408d0e374b446090f5601327fd464b8 Mon Sep 17 00:00:00 2001 From: Will Fancher Date: Thu, 19 Jul 2018 17:19:26 -0400 Subject: [PATCH 006/241] Format the Collection module --- src/Reflex/Collection.hs | 197 +++++++++++++++++++++++++++++---------- 1 file changed, 148 insertions(+), 49 deletions(-) diff --git a/src/Reflex/Collection.hs b/src/Reflex/Collection.hs index d64913f5..06ab212d 100644 --- a/src/Reflex/Collection.hs +++ b/src/Reflex/Collection.hs @@ -37,84 +37,183 @@ import Reflex.Class import Reflex.Dynamic import Reflex.PostBuild.Class -listHoldWithKey :: forall t m k v a. (Ord k, Adjustable t m, MonadHold t m) => Map k v -> Event t (Map k (Maybe v)) -> (k -> v -> m a) -> m (Dynamic t (Map k a)) +listHoldWithKey + :: forall t m k v a + . (Ord k, Adjustable t m, MonadHold t m) + => Map k v + -> Event t (Map k (Maybe v)) + -> (k -> v -> m a) + -> m (Dynamic t (Map k a)) listHoldWithKey m0 m' f = do let dm0 = mapWithFunctorToDMap $ Map.mapWithKey f m0 - dm' = fmap (PatchDMap . mapWithFunctorToDMap . Map.mapWithKey (\k v -> ComposeMaybe $ fmap (f k) v)) m' + dm' = fmap + (PatchDMap . mapWithFunctorToDMap . Map.mapWithKey + (\k v -> ComposeMaybe $ fmap (f k) v) + ) + m' (a0, a') <- sequenceDMapWithAdjust dm0 dm' - fmap dmapToMap . incrementalToDynamic <$> holdIncremental a0 a' --TODO: Move the dmapToMap to the righthand side so it doesn't get fully redone every time ---TODO: Something better than Dynamic t (Map k v) - we want something where the Events carry diffs, not the whole value -listWithKey :: forall t k v m a. (Ord k, Adjustable t m, PostBuild t m, MonadFix m, MonadHold t m) => Dynamic t (Map k v) -> (k -> Dynamic t v -> m a) -> m (Dynamic t (Map k a)) + --TODO: Move the dmapToMap to the righthand side so it doesn't get + --fully redone every time + fmap dmapToMap . incrementalToDynamic <$> holdIncremental a0 a' + +--TODO: Something better than Dynamic t (Map k v) - we want something +--where the Events carry diffs, not the whole value +listWithKey + :: forall t k v m a + . (Ord k, Adjustable t m, PostBuild t m, MonadFix m, MonadHold t m) + => Dynamic t (Map k v) + -> (k -> Dynamic t v -> m a) + -> m (Dynamic t (Map k a)) listWithKey vals mkChild = do postBuild <- getPostBuild let childValChangedSelector = fanMap $ updated vals - -- We keep track of changes to children values in the mkChild function we pass to listHoldWithKey - -- The other changes we need to keep track of are child insertions and deletions. diffOnlyKeyChanges - -- keeps track of insertions and deletions but ignores value changes, since they're already accounted for. - diffOnlyKeyChanges olds news = flip Map.mapMaybe (align olds news) $ \case - This _ -> Just Nothing - These _ _ -> Nothing - That new -> Just $ Just new + + -- We keep track of changes to children values in the mkChild + -- function we pass to listHoldWithKey The other changes we need + -- to keep track of are child insertions and + -- deletions. diffOnlyKeyChanges keeps track of insertions and + -- deletions but ignores value changes, since they're already + -- accounted for. + diffOnlyKeyChanges olds news = + flip Map.mapMaybe (align olds news) $ \case + This _ -> Just Nothing + These _ _ -> Nothing + That new -> Just $ Just new rec sentVals :: Dynamic t (Map k v) <- foldDyn applyMap Map.empty changeVals let changeVals :: Event t (Map k (Maybe v)) - changeVals = attachWith diffOnlyKeyChanges (current sentVals) $ leftmost - [ updated vals - , tag (current vals) postBuild --TODO: This should probably be added to the attachWith, not to the updated; if we were using diffMap instead of diffMapNoEq, I think it might not work - ] + changeVals = + attachWith diffOnlyKeyChanges (current sentVals) $ leftmost + [ updated vals + + -- TODO: This should probably be added to the + -- attachWith, not to the updated; if we were using + -- diffMap instead of diffMapNoEq, I think it might not + -- work + , tag (current vals) postBuild + ] listHoldWithKey Map.empty changeVals $ \k v -> mkChild k =<< holdDyn v (select childValChangedSelector $ Const2 k) {-# DEPRECATED listWithKey' "listWithKey' has been renamed to listWithKeyShallowDiff; also, its behavior has changed to fix a bug where children were always rebuilt (never updated)" #-} -listWithKey' :: (Ord k, Adjustable t m, MonadFix m, MonadHold t m) => Map k v -> Event t (Map k (Maybe v)) -> (k -> v -> Event t v -> m a) -> m (Dynamic t (Map k a)) +listWithKey' + :: (Ord k, Adjustable t m, MonadFix m, MonadHold t m) + => Map k v + -> Event t (Map k (Maybe v)) + -> (k -> v -> Event t v -> m a) + -> m (Dynamic t (Map k a)) listWithKey' = listWithKeyShallowDiff --- | Display the given map of items (in key order) using the builder function provided, and update it with the given event. 'Nothing' update entries will delete the corresponding children, and 'Just' entries will create them if they do not exist or send an update event to them if they do. -listWithKeyShallowDiff :: (Ord k, Adjustable t m, MonadFix m, MonadHold t m) => Map k v -> Event t (Map k (Maybe v)) -> (k -> v -> Event t v -> m a) -> m (Dynamic t (Map k a)) +-- | Display the given map of items (in key order) using the builder +-- function provided, and update it with the given event. 'Nothing' +-- update entries will delete the corresponding children, and 'Just' +-- entries will create them if they do not exist or send an update +-- event to them if they do. +listWithKeyShallowDiff + :: (Ord k, Adjustable t m, MonadFix m, MonadHold t m) + => Map k v + -> Event t (Map k (Maybe v)) + -> (k -> v -> Event t v -> m a) + -> m (Dynamic t (Map k a)) listWithKeyShallowDiff initialVals valsChanged mkChild = do let childValChangedSelector = fanMap $ fmap (Map.mapMaybe id) valsChanged sentVals <- foldDyn applyMap (void initialVals) $ fmap (fmap void) valsChanged let relevantPatch patch _ = case patch of - Nothing -> Just Nothing -- Even if we let a Nothing through when the element doesn't already exist, this doesn't cause a problem because it is ignored - Just _ -> Nothing -- We don't want to let spurious re-creations of items through - listHoldWithKey initialVals (attachWith (flip (Map.differenceWith relevantPatch)) (current sentVals) valsChanged) $ \k v -> - mkChild k v $ select childValChangedSelector $ Const2 k - ---TODO: Something better than Dynamic t (Map k v) - we want something where the Events carry diffs, not the whole value --- | Create a dynamically-changing set of Event-valued widgets. --- This is like listWithKey, specialized for widgets returning (Event t a). listWithKey would return 'Dynamic t (Map k (Event t a))' in this scenario, but listViewWithKey flattens this to 'Event t (Map k a)' via 'switch'. -listViewWithKey :: (Ord k, Adjustable t m, PostBuild t m, MonadHold t m, MonadFix m) => Dynamic t (Map k v) -> (k -> Dynamic t v -> m (Event t a)) -> m (Event t (Map k a)) -listViewWithKey vals mkChild = switch . fmap mergeMap <$> listViewWithKey' vals mkChild - -listViewWithKey' :: (Ord k, Adjustable t m, PostBuild t m, MonadHold t m, MonadFix m) => Dynamic t (Map k v) -> (k -> Dynamic t v -> m a) -> m (Behavior t (Map k a)) + + -- Even if we let a Nothing through when the element doesn't + -- already exist, this doesn't cause a problem because it is + -- ignored + Nothing -> Just Nothing + + -- We don't want to let spurious re-creations of items through + Just _ -> Nothing + listHoldWithKey + initialVals + (attachWith (flip (Map.differenceWith relevantPatch)) + (current sentVals) + valsChanged + ) + $ \k v -> mkChild k v $ select childValChangedSelector $ Const2 k + +--TODO: Something better than Dynamic t (Map k v) - we want something +--where the Events carry diffs, not the whole value +-- | Create a dynamically-changing set of Event-valued widgets. This +-- is like listWithKey, specialized for widgets returning (Event t +-- a). listWithKey would return 'Dynamic t (Map k (Event t a))' in +-- this scenario, but listViewWithKey flattens this to 'Event t (Map +-- k a)' via 'switch'. +listViewWithKey + :: (Ord k, Adjustable t m, PostBuild t m, MonadHold t m, MonadFix m) + => Dynamic t (Map k v) + -> (k -> Dynamic t v -> m (Event t a)) + -> m (Event t (Map k a)) +listViewWithKey vals mkChild = + switch . fmap mergeMap <$> listViewWithKey' vals mkChild + +listViewWithKey' + :: (Ord k, Adjustable t m, PostBuild t m, MonadHold t m, MonadFix m) + => Dynamic t (Map k v) + -> (k -> Dynamic t v -> m a) + -> m (Behavior t (Map k a)) listViewWithKey' vals mkChild = current <$> listWithKey vals mkChild --- | Create a dynamically-changing set of widgets, one of which is selected at any time. -selectViewListWithKey :: forall t m k v a. (Adjustable t m, Ord k, PostBuild t m, MonadHold t m, MonadFix m) - => Dynamic t k -- ^ Current selection key - -> Dynamic t (Map k v) -- ^ Dynamic key/value map - -> (k -> Dynamic t v -> Dynamic t Bool -> m (Event t a)) -- ^ Function to create a widget for a given key from Dynamic value and Dynamic Bool indicating if this widget is currently selected - -> m (Event t (k, a)) -- ^ Event that fires when any child's return Event fires. Contains key of an arbitrary firing widget. +-- | Create a dynamically-changing set of widgets, one of which is +-- selected at any time. +selectViewListWithKey + :: forall t m k v a + . (Adjustable t m, Ord k, PostBuild t m, MonadHold t m, MonadFix m) + => Dynamic t k + -- ^ Current selection key + -> Dynamic t (Map k v) + -- ^ Dynamic key/value map + -> (k -> Dynamic t v -> Dynamic t Bool -> m (Event t a)) + -- ^ Function to create a widget for a given key from Dynamic value + -- and Dynamic Bool indicating if this widget is currently selected + -> m (Event t (k, a)) + -- ^ Event that fires when any child's return Event fires. Contains + -- key of an arbitrary firing widget. selectViewListWithKey selection vals mkChild = do - let selectionDemux = demux selection -- For good performance, this value must be shared across all children + -- For good performance, this value must be shared across all children + let selectionDemux = demux selection selectChild <- listWithKey vals $ \k v -> do let selected = demuxed selectionDemux k selectSelf <- mkChild k v selected return $ fmap ((,) k) selectSelf return $ switchPromptlyDyn $ leftmost . Map.elems <$> selectChild -selectViewListWithKey_ :: forall t m k v a. (Adjustable t m, Ord k, PostBuild t m, MonadHold t m, MonadFix m) - => Dynamic t k -- ^ Current selection key - -> Dynamic t (Map k v) -- ^ Dynamic key/value map - -> (k -> Dynamic t v -> Dynamic t Bool -> m (Event t a)) -- ^ Function to create a widget for a given key from Dynamic value and Dynamic Bool indicating if this widget is currently selected - -> m (Event t k) -- ^ Event that fires when any child's return Event fires. Contains key of an arbitrary firing widget. -selectViewListWithKey_ selection vals mkChild = fmap fst <$> selectViewListWithKey selection vals mkChild +selectViewListWithKey_ + :: forall t m k v a + . (Adjustable t m, Ord k, PostBuild t m, MonadHold t m, MonadFix m) + => Dynamic t k + -- ^ Current selection key + -> Dynamic t (Map k v) + -- ^ Dynamic key/value map + -> (k -> Dynamic t v -> Dynamic t Bool -> m (Event t a)) + -- ^ Function to create a widget for a given key from Dynamic value + -- and Dynamic Bool indicating if this widget is currently selected + -> m (Event t k) + -- ^ Event that fires when any child's return Event fires. Contains + -- key of an arbitrary firing widget. +selectViewListWithKey_ selection vals mkChild = + fmap fst <$> selectViewListWithKey selection vals mkChild --- | Create a dynamically-changing set of widgets from a Dynamic key/value map. --- Unlike the 'withKey' variants, the child widgets are insensitive to which key they're associated with. -list :: (Ord k, Adjustable t m, MonadHold t m, PostBuild t m, MonadFix m) => Dynamic t (Map k v) -> (Dynamic t v -> m a) -> m (Dynamic t (Map k a)) +-- | Create a dynamically-changing set of widgets from a Dynamic +-- key/value map. Unlike the 'withKey' variants, the child widgets +-- are insensitive to which key they're associated with. +list + :: (Ord k, Adjustable t m, MonadHold t m, PostBuild t m, MonadFix m) + => Dynamic t (Map k v) + -> (Dynamic t v -> m a) + -> m (Dynamic t (Map k a)) list dm mkChild = listWithKey dm (\_ dv -> mkChild dv) -- | Create a dynamically-changing set of widgets from a Dynamic list. -simpleList :: (Adjustable t m, MonadHold t m, PostBuild t m, MonadFix m) => Dynamic t [v] -> (Dynamic t v -> m a) -> m (Dynamic t [a]) -simpleList xs mkChild = fmap (fmap (map snd . Map.toList)) $ flip list mkChild $ fmap (Map.fromList . zip [(1::Int)..]) xs +simpleList + :: (Adjustable t m, MonadHold t m, PostBuild t m, MonadFix m) + => Dynamic t [v] + -> (Dynamic t v -> m a) + -> m (Dynamic t [a]) +simpleList xs mkChild = + fmap (fmap (map snd . Map.toList)) $ flip list mkChild $ fmap + (Map.fromList . zip [(1 :: Int) ..]) + xs From b55c6079a9c5029ae84afa40ff3415d95411be9c Mon Sep 17 00:00:00 2001 From: Ryan Trinkle Date: Fri, 27 Jul 2018 21:01:26 -0400 Subject: [PATCH 007/241] Add factorEvent; fix hlint --- src/Reflex/Class.hs | 38 ++++++++++++++++++++++++++++++++++++-- src/Reflex/Dynamic.hs | 28 +++++++++------------------- 2 files changed, 45 insertions(+), 21 deletions(-) diff --git a/src/Reflex/Class.hs b/src/Reflex/Class.hs index bbb66435..4fc12a20 100644 --- a/src/Reflex/Class.hs +++ b/src/Reflex/Class.hs @@ -9,6 +9,7 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE NoMonomorphismRestriction #-} +{-# LANGUAGE PolyKinds #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE RecursiveDo #-} {-# LANGUAGE RoleAnnotations #-} @@ -59,6 +60,7 @@ module Reflex.Class , EitherTag (..) , eitherToDSum , dsumToEither + , factorEvent -- ** Collapsing 'Event . Event' , switchHold , switchHoldPromptly @@ -157,8 +159,11 @@ import Data.Align import Data.Bifunctor import Data.Coerce import Data.Default -import Data.Dependent.Map (DMap, DSum (..), GCompare (..)) +import Data.Dependent.Map (DMap, DSum (..)) import qualified Data.Dependent.Map as DMap +import Data.Functor.Compose +import Data.Functor.Product +import Data.GADT.Compare (GEq (..), GCompare (..), (:~:) (..)) import Data.FastMutableIntMap (PatchIntMap) import Data.Foldable import Data.Functor.Bind @@ -169,6 +174,8 @@ import qualified Data.IntMap.Strict as IntMap import Data.List.NonEmpty (NonEmpty (..)) import Data.Map (Map) import Data.Semigroup (Semigroup, sconcat, stimes, (<>)) +import Data.Some (Some) +import qualified Data.Some as Some import Data.String import Data.These import Data.Type.Coercion @@ -592,7 +599,7 @@ takeWhileE => (a -> Bool) -> Event t a -> m (Event t a) -takeWhileE f e = takeWhileJustE (\v -> guard (f v) $> v) e +takeWhileE f = takeWhileJustE $ \v -> guard (f v) $> v -- | Take the streak of occurrences starting at the current time for which the -- event returns 'Just b'. @@ -897,6 +904,33 @@ alignEventWithMaybe f ea eb = $ merge $ DMap.fromList [LeftTag :=> ea, RightTag :=> eb] +factorEvent + :: forall t m k v a. + ( Reflex t + , MonadFix m + , MonadHold t m + , GEq k + ) + => k a + -> Event t (DSum k v) + -> m (Event t (v a), Event t (DSum k (Product v (Compose (Event t) v)))) +factorEvent k0 kv' = do + key :: Behavior t (Some k) <- hold (Some.This k0) $ fmapCheap (\(k :=> _) -> Some.This k) kv' + let inner :: forall m' b. (MonadFix m', MonadHold t m') => k b -> m' (Event t (v b)) + inner k = do + let f :: DSum k v -> Maybe (v b) + f (newK :=> newV) = case newK `geq` k of + Just Refl -> Just newV + Nothing -> Nothing + takeWhileJustE f kv' + update = flip push kv' $ \(newKey :=> newVal) -> sample key >>= \case + Some.This oldKey -> case newKey `geq` oldKey of + Just Refl -> return Nothing + Nothing -> do + newInner <- inner newKey + return $ Just $ newKey :=> Pair newVal (Compose newInner) + eInitial <- inner k0 + return (eInitial, update) -------------------------------------------------------------------------------- -- Accumulator diff --git a/src/Reflex/Dynamic.hs b/src/Reflex/Dynamic.hs index fce86953..68b134fd 100644 --- a/src/Reflex/Dynamic.hs +++ b/src/Reflex/Dynamic.hs @@ -102,10 +102,11 @@ import Data.Align import Data.Dependent.Map (DMap) import qualified Data.Dependent.Map as DMap import Data.Dependent.Sum (DSum (..)) +import Data.Functor.Product import Data.GADT.Compare ((:~:) (..), GCompare (..), GEq (..), GOrdering (..)) import Data.Map (Map) import Data.Maybe -import Data.Monoid +import Data.Monoid hiding (Product) import Data.These import Debug.Trace @@ -326,24 +327,13 @@ eitherDyn = fmap (fmap unpack) . factorDyn . fmap eitherToDSum factorDyn :: forall t m k v. (Reflex t, MonadFix m, MonadHold t m, GEq k) => Dynamic t (DSum k v) -> m (Dynamic t (DSum k (Compose (Dynamic t) v))) factorDyn d = do - let inner :: forall m' a. (MonadFix m', MonadHold t m') => k a -> v a -> m' (Dynamic t (v a)) - inner k v0 = (=<<) (holdDyn v0) $ flip takeWhileJustE (updated d) $ - \(newK :=> newV) -> case newK `geq` k of - Just Refl -> Just newV - Nothing -> Nothing - getInitial = do - k0 :=> (v0 :: v a) <- sample $ current d - i0 <- inner k0 v0 - return $ k0 :=> Compose i0 - update = flip push (updated d) $ \(newKey :=> newVal) -> do - (oldKey :=> _) <- sample $ current d - case newKey `geq` oldKey of - Just Refl -> return Nothing - Nothing -> do - newInner <- inner newKey newVal - return $ Just $ newKey :=> Compose newInner - o0 <- getInitial --TODO: Figure out how to get this to run inside something like the first argument to buildDynamic - holdDyn o0 update + k0 :=> v0 <- sample $ current d --TODO: Figure out how to get this to run inside something like the first argument to buildDynamic + (initialEvent, update) <- factorEvent k0 $ updated d + initialD <- holdDyn v0 initialEvent + let f (k :=> Pair v (Compose v')) = do + d' <- holdDyn v v' + pure $ k :=> Compose d' + holdDyn (k0 :=> Compose initialD) $ pushAlwaysCheap f update -------------------------------------------------------------------------------- -- Demux From 6e1898251e37beae9300a04d06e2d72451f92795 Mon Sep 17 00:00:00 2001 From: Oliver Batchelor Date: Wed, 1 Aug 2018 01:00:57 +1200 Subject: [PATCH 008/241] First try at builDynamic with PushM --- src/Reflex/Class.hs | 34 +++++++++++++++++++++----------- src/Reflex/Dynamic.hs | 24 ++++++++++++---------- src/Reflex/DynamicWriter/Base.hs | 8 +++++++- src/Reflex/Query/Base.hs | 7 ++++++- src/Reflex/Spider/Internal.hs | 27 +++++++++++++++++-------- 5 files changed, 69 insertions(+), 31 deletions(-) diff --git a/src/Reflex/Class.hs b/src/Reflex/Class.hs index 4fc12a20..4b1a4151 100644 --- a/src/Reflex/Class.hs +++ b/src/Reflex/Class.hs @@ -61,6 +61,7 @@ module Reflex.Class , eitherToDSum , dsumToEither , factorEvent + , filterEventKey -- ** Collapsing 'Event . Event' , switchHold , switchHoldPromptly @@ -337,7 +338,7 @@ class MonadSample t m => MonadHold t m where holdIncremental :: Patch p => PatchTarget p -> Event t p -> m (Incremental t p) default holdIncremental :: (Patch p, m ~ f m', MonadTrans f, MonadHold t m') => PatchTarget p -> Event t p -> m (Incremental t p) holdIncremental v0 = lift . holdIncremental v0 - buildDynamic :: PullM t a -> Event t a -> m (Dynamic t a) + buildDynamic :: PushM t a -> Event t a -> m (Dynamic t a) {- default buildDynamic :: (m ~ f m', MonadTrans f, MonadHold t m') => PullM t a -> Event t a -> m (Dynamic t a) buildDynamic getV0 = lift . buildDynamic getV0 @@ -904,6 +905,24 @@ alignEventWithMaybe f ea eb = $ merge $ DMap.fromList [LeftTag :=> ea, RightTag :=> eb] +filterEventKey + :: forall t m k v a. + ( Reflex t + , MonadFix m + , MonadHold t m + , GEq k + ) + => k a + -> Event t (DSum k v) + -> m (Event t (v a)) +filterEventKey k kv' = do + let f :: DSum k v -> Maybe (v a) + f (newK :=> newV) = case newK `geq` k of + Just Refl -> Just newV + Nothing -> Nothing + takeWhileJustE f kv' + + factorEvent :: forall t m k v a. ( Reflex t @@ -916,20 +935,13 @@ factorEvent -> m (Event t (v a), Event t (DSum k (Product v (Compose (Event t) v)))) factorEvent k0 kv' = do key :: Behavior t (Some k) <- hold (Some.This k0) $ fmapCheap (\(k :=> _) -> Some.This k) kv' - let inner :: forall m' b. (MonadFix m', MonadHold t m') => k b -> m' (Event t (v b)) - inner k = do - let f :: DSum k v -> Maybe (v b) - f (newK :=> newV) = case newK `geq` k of - Just Refl -> Just newV - Nothing -> Nothing - takeWhileJustE f kv' - update = flip push kv' $ \(newKey :=> newVal) -> sample key >>= \case + let update = flip push kv' $ \(newKey :=> newVal) -> sample key >>= \case Some.This oldKey -> case newKey `geq` oldKey of Just Refl -> return Nothing Nothing -> do - newInner <- inner newKey + newInner <- filterEventKey newKey kv' return $ Just $ newKey :=> Pair newVal (Compose newInner) - eInitial <- inner k0 + eInitial <- filterEventKey k0 kv' return (eInitial, update) -------------------------------------------------------------------------------- diff --git a/src/Reflex/Dynamic.hs b/src/Reflex/Dynamic.hs index 68b134fd..994d918c 100644 --- a/src/Reflex/Dynamic.hs +++ b/src/Reflex/Dynamic.hs @@ -325,16 +325,20 @@ eitherDyn = fmap (fmap unpack) . factorDyn . fmap eitherToDSum LeftTag :=> Compose a -> Left $ coerceDynamic a RightTag :=> Compose b -> Right $ coerceDynamic b -factorDyn :: forall t m k v. (Reflex t, MonadFix m, MonadHold t m, GEq k) => Dynamic t (DSum k v) -> m (Dynamic t (DSum k (Compose (Dynamic t) v))) -factorDyn d = do - k0 :=> v0 <- sample $ current d --TODO: Figure out how to get this to run inside something like the first argument to buildDynamic - (initialEvent, update) <- factorEvent k0 $ updated d - initialD <- holdDyn v0 initialEvent - let f (k :=> Pair v (Compose v')) = do - d' <- holdDyn v v' - pure $ k :=> Compose d' - holdDyn (k0 :=> Compose initialD) $ pushAlwaysCheap f update - +factorDyn :: forall t m k v. (Reflex t, MonadHold t m, GEq k) + => Dynamic t (DSum k v) -> m (Dynamic t (DSum k (Compose (Dynamic t) v))) +factorDyn d = buildDynamic (sample (current d) >>= holdKey) update where + update :: Event t (DSum k (Compose (Dynamic t) v)) + update = flip push (updated d) $ \(newKey :=> newVal) -> do + (oldKey :=> _) <- sample (current d) + case newKey `geq` oldKey of + Just Refl -> return Nothing + Nothing -> Just <$> holdKey (newKey :=> newVal) + + holdKey (k :=> v) = do + inner' <- filterEventKey k (updated d) + inner <- holdDyn v inner' + return $ k :=> Compose inner -------------------------------------------------------------------------------- -- Demux -------------------------------------------------------------------------------- diff --git a/src/Reflex/DynamicWriter/Base.hs b/src/Reflex/DynamicWriter/Base.hs index 18168d43..a003c0fc 100644 --- a/src/Reflex/DynamicWriter/Base.hs +++ b/src/Reflex/DynamicWriter/Base.hs @@ -9,6 +9,7 @@ {-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE StandaloneDeriving #-} #ifdef USE_REFLEX_OPTIMIZER {-# OPTIONS_GHC -fplugin=Reflex.Optimizer #-} #endif @@ -85,7 +86,12 @@ mergeDynIncrementalWithMove a = unsafeBuildIncremental (mapM (sample . current) in Map.differenceWith (\e _ -> Just $ MapWithMove.nodeInfoSetTo Nothing e) pWithNewVals noLongerMovedMap --TODO: Check if any in the second map are not covered? -- | A basic implementation of 'MonadDynamicWriter'. -newtype DynamicWriterT t w m a = DynamicWriterT { unDynamicWriterT :: StateT [Dynamic t w] m a } deriving (Functor, Applicative, Monad, MonadIO, MonadFix, MonadHold t, MonadSample t, MonadAsyncException, MonadException) -- The list is kept in reverse order +newtype DynamicWriterT t w m a = DynamicWriterT { unDynamicWriterT :: StateT [Dynamic t w] m a } + deriving (Functor, Applicative, Monad, MonadIO, MonadFix, MonadAsyncException, MonadException) -- The list is kept in reverse order + +deriving instance MonadHold t m => MonadHold t (DynamicWriterT t w m) +deriving instance MonadSample t m => MonadSample t (DynamicWriterT t w m) + instance MonadRef m => MonadRef (DynamicWriterT t w m) where type Ref (DynamicWriterT t w m) = Ref m diff --git a/src/Reflex/Query/Base.hs b/src/Reflex/Query/Base.hs index b19f97c0..889a1b90 100644 --- a/src/Reflex/Query/Base.hs +++ b/src/Reflex/Query/Base.hs @@ -8,6 +8,8 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE StandaloneDeriving #-} + module Reflex.Query.Base ( QueryT (..) , runQueryT @@ -50,7 +52,10 @@ import Reflex.Requester.Class import Reflex.TriggerEvent.Class newtype QueryT t q m a = QueryT { unQueryT :: StateT [Behavior t q] (EventWriterT t q (ReaderT (Dynamic t (QueryResult q)) m)) a } - deriving (Functor, Applicative, Monad, MonadException, MonadFix, MonadIO, MonadHold t, MonadSample t, MonadAtomicRef) + deriving (Functor, Applicative, Monad, MonadException, MonadFix, MonadIO, MonadAtomicRef) + +deriving instance MonadHold t m => MonadHold t (QueryT t q m) +deriving instance MonadSample t m => MonadSample t (QueryT t q m) runQueryT :: (MonadFix m, Additive q, Group q, Reflex t) => QueryT t q m a -> Dynamic t (QueryResult q) -> m (a, Incremental t (AdditivePatch q)) runQueryT (QueryT a) qr = do diff --git a/src/Reflex/Spider/Internal.hs b/src/Reflex/Spider/Internal.hs index edb4913f..587fe9cd 100644 --- a/src/Reflex/Spider/Internal.hs +++ b/src/Reflex/Spider/Internal.hs @@ -1135,7 +1135,11 @@ instance HasSpiderTimeline x => Align (Event x) where nil = eventNever align ea eb = fmapMaybe dmapToThese $ merge $ dynamicConst $ DMap.fromDistinctAscList [LeftTag :=> ea, RightTag :=> eb] -newtype Dyn x p = Dyn { unDyn :: IORef (Either (BehaviorM x (PatchTarget p), Event x p) (Hold x p)) } +data DynType x p = UnsafeDyn !(BehaviorM x (PatchTarget p), Event x p) + | BuildDyn !(EventM x (PatchTarget p), Event x p) + | HoldDyn !(Hold x p) + +newtype Dyn x p = Dyn { unDyn :: IORef (DynType x p) } newMapDyn :: HasSpiderTimeline x => (a -> b) -> Dynamic x (Identity a) -> Dynamic x (Identity b) newMapDyn f d = dynamicDynIdentity $ unsafeBuildDynamic (fmap f $ readBehaviorTracked $ dynamicCurrent d) (Identity . f . runIdentity <$> dynamicUpdated d) @@ -1156,15 +1160,15 @@ zipDynWith f da db = return $ Just $ Identity $ f a b in dynamicDynIdentity $ unsafeBuildDynamic (f <$> readBehaviorUntracked (dynamicCurrent da) <*> readBehaviorUntracked (dynamicCurrent db)) ec -buildDynamic :: (Defer (SomeDynInit x) m, Patch p) => BehaviorM x (PatchTarget p) -> Event x p -> m (Dyn x p) +buildDynamic :: (Defer (SomeDynInit x) m, Patch p) => EventM x (PatchTarget p) -> Event x p -> m (Dyn x p) buildDynamic readV0 v' = do - result <- liftIO $ newIORef $ Left (readV0, v') + result <- liftIO $ newIORef $ BuildDyn (readV0, v') let !d = Dyn result defer $ SomeDynInit d return d unsafeBuildDynamic :: BehaviorM x (PatchTarget p) -> Event x p -> Dyn x p -unsafeBuildDynamic readV0 v' = Dyn $ unsafeNewIORef x $ Left x +unsafeBuildDynamic readV0 v' = Dyn $ unsafeNewIORef x $ UnsafeDyn x where x = (readV0, v') -- ResultM can read behaviors and events @@ -1374,14 +1378,21 @@ getDynHold :: (Defer (SomeHoldInit x) m, Patch p) => Dyn x p -> m (Hold x p) getDynHold d = do mh <- liftIO $ readIORef $ unDyn d case mh of - Right h -> return h - Left (readV0, v') -> do + HoldDyn h -> return h + UnsafeDyn (readV0, v') -> do holdInits <- getDeferralQueue v0 <- liftIO $ runBehaviorM readV0 Nothing holdInits + hold' v0 v' + BuildDyn (readV0, v') -> do + v0 <- liftIO $ runEventM readV0 + hold' v0 v' + where + hold' v0 v' = do h <- hold v0 v' - liftIO $ writeIORef (unDyn d) $ Right h + liftIO $ writeIORef (unDyn d) $ HoldDyn h return h + -- Always refers to 0 {-# NOINLINE zeroRef #-} zeroRef :: IORef Height @@ -2317,7 +2328,7 @@ holdDynSpiderEventM v0 e = fmap (SpiderDynamic . dynamicHoldIdentity) $ Reflex.S holdIncrementalSpiderEventM :: (HasSpiderTimeline x, Patch p) => PatchTarget p -> Reflex.Class.Event (SpiderTimeline x) p -> EventM x (Reflex.Class.Incremental (SpiderTimeline x) p) holdIncrementalSpiderEventM v0 e = fmap (SpiderIncremental . dynamicHold) $ Reflex.Spider.Internal.hold v0 $ unSpiderEvent e -buildDynamicSpiderEventM :: HasSpiderTimeline x => SpiderPullM x a -> Reflex.Class.Event (SpiderTimeline x) a -> EventM x (Reflex.Class.Dynamic (SpiderTimeline x) a) +buildDynamicSpiderEventM :: HasSpiderTimeline x => SpiderPushM x a -> Reflex.Class.Event (SpiderTimeline x) a -> EventM x (Reflex.Class.Dynamic (SpiderTimeline x) a) buildDynamicSpiderEventM getV0 e = fmap (SpiderDynamic . dynamicDynIdentity) $ Reflex.Spider.Internal.buildDynamic (coerce getV0) $ coerce $ unSpiderEvent e instance HasSpiderTimeline x => Reflex.Class.MonadHold (SpiderTimeline x) (SpiderHost x) where From 8031150dc80dca385f116e6198dc37ccf89a6009 Mon Sep 17 00:00:00 2001 From: Oliver Batchelor Date: Thu, 2 Aug 2018 02:47:03 +1200 Subject: [PATCH 009/241] Add tests --- reflex.cabal | 17 ++++++ test/BuildDynamic.hs | 121 +++++++++++++++++++++++++++++++++++++++++++ test/Test/Run.hs | 8 +++ 3 files changed, 146 insertions(+) create mode 100644 test/BuildDynamic.hs diff --git a/reflex.cabal b/reflex.cabal index 9929f9d0..fd4f40cc 100644 --- a/reflex.cabal +++ b/reflex.cabal @@ -213,6 +213,23 @@ test-suite RequesterT , ref-tf buildable: False + +test-suite BuildDynamic + type: exitcode-stdio-1.0 + main-is: BuildDynamic.hs + hs-source-dirs: test + build-depends: base + , reflex + , dependent-map + + , dependent-sum + , these + , ref-tf + , lens + + other-modules: Test.Run + + test-suite QueryT type: exitcode-stdio-1.0 main-is: QueryT.hs diff --git a/test/BuildDynamic.hs b/test/BuildDynamic.hs new file mode 100644 index 00000000..521c62d6 --- /dev/null +++ b/test/BuildDynamic.hs @@ -0,0 +1,121 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE RecursiveDo #-} + +module Main where + +import Control.Lens +import Control.Monad +import Control.Monad.Fix +import qualified Data.Dependent.Map as DMap +import Data.Dependent.Sum +import Data.These +import Data.Monoid + +import Reflex +import Test.Run + +pushDyn :: (Reflex t, MonadHold t m) => (a -> PushM t b) -> Dynamic t a -> m (Dynamic t b) +pushDyn f d = buildDynamic (sample (current d) >>= f) (pushAlways f (updated d)) + +foldedDyn :: (Reflex t, MonadHold t m) => (a -> a -> a) -> Dynamic t a -> m (Dynamic t a) +foldedDyn f d = fmap join $ flip buildDynamic never $ do + a <- sample (current d) + foldDyn f a (updated d) + +scannedDyn :: (Reflex t, MonadHold t m) => Dynamic t a -> m (Dynamic t [a]) +scannedDyn = fmap (fmap reverse) . foldedDyn (<>) . fmap pure + +scanInnerDyns :: (Reflex t, MonadHold t m) => Dynamic t (Dynamic t a) -> m (Dynamic t [a]) +scanInnerDyns d = do + scans <- scannedDyn d + return (join (fmap distributeListOverDynPure scans)) + + +main :: IO () +main = do + + r <- last <$> runAppB testInnerHoldsE (Just <$> [1..4]) + -- [[[0,1,2],[1,2],[2]]]] + + -- r <- runAppB testScan counter + + -- r <- runAppB testStrictness (fmap Just [1..9]) + + + print r + return () + + where + counter = fmap Just [1..9] <> [Nothing] + eithers = fmap Just [ Left 1, Left 2, Right 3, Left 4, Left 5, Right 6, Right 7, Right 8, Left 9 ] <> [Nothing] + +testIdentity :: (Reflex t, MonadHold t m, MonadFix m) + => Event t Int -> m (Behavior t Int) +testIdentity e = do + d <- holdDyn 0 e + d' <- pushDyn return d + d'' <- pushDyn return d' + + return (current d'') + +testStrictness :: (Reflex t, MonadHold t m, MonadFix m) + => Event t Int -> m (Behavior t Int) +testStrictness e = do + + rec + d'' <- pushDyn return d' + d' <- pushDyn return d + d <- holdDyn 0 e + + return (current d'') + + +testScan :: (Reflex t, MonadHold t m, MonadFix m) + => Event t Int -> m (Behavior t [Int]) +testScan e = do + d <- holdDyn 0 e + scan <- scannedDyn d + return (current scan) + +testFactor :: (Reflex t, MonadHold t m, MonadFix m) + => Event t (Either Int Int) -> m (Behavior t (Either Int Int)) +testFactor e = do + d <- holdDyn (Left 0) e + + eithers <- eitherDyn d + return $ current (join (fmap unFactor eithers)) + + where + unFactor = either (fmap Left) (fmap Right) + +testInnerHolds :: (Reflex t, MonadHold t m, MonadFix m) + => Event t Int -> m (Behavior t [Int]) +testInnerHolds e = do + d <- holdDyn 0 e + + d' <- pushDyn (\a -> foldDyn (:) [a] (updated d)) d + return $ current (join d') + +testInnerHoldsE :: forall t m. (Reflex t, MonadHold t m, MonadFix m) + => Event t Int -> m (Behavior t [[Int]]) +testInnerHoldsE e = do + initial <- f 0 + d <- foldDyn snoc [initial] updates + return $ current (join (fmap distributeListOverDynPure d)) + where + f :: forall n. (MonadHold t n, MonadFix n) => Int -> n (Dynamic t [Int]) + f a = foldDyn snoc [a] e + updates = pushAlways f e + + snoc x xs = xs ++ [x] + +testInnerHolds1 :: (Reflex t, MonadHold t m, MonadFix m) + => Event t Int -> m (Behavior t [[Int]]) +testInnerHolds1 e = do + d <- fmap pure <$> holdDyn 0 e + + d' <- pushDyn (\a -> foldDyn (flip mappend) a (updated d)) d + current <$> scanInnerDyns d' diff --git a/test/Test/Run.hs b/test/Test/Run.hs index 540bd700..66590968 100644 --- a/test/Test/Run.hs +++ b/test/Test/Run.hs @@ -64,3 +64,11 @@ runApp' :: (t ~ SpiderTimeline Global, m ~ SpiderHost Global) runApp' app input = do let app' = fmap (AppOut (pure ())) . app map (map snd) <$> runApp (app' . _appIn_event) () (map (fmap That) input) + +runAppB :: (t ~ SpiderTimeline Global, m ~ SpiderHost Global) + => (Event t eIn -> PerformEventT t m (Behavior t bOut)) + -> [Maybe eIn] + -> IO [[bOut]] +runAppB app input = do + let app' = fmap (flip AppOut never) . app + map (map fst) <$> runApp (app' . _appIn_event) () (map (fmap That) input) From 8fc31ebdea8f951103a0a920dc2a6969a205b5d4 Mon Sep 17 00:00:00 2001 From: Oliver Batchelor Date: Fri, 3 Aug 2018 01:34:01 +1200 Subject: [PATCH 010/241] Add tests for BuildDynamic --- reflex.cabal | 17 ----- test/BuildDynamic.hs | 121 ---------------------------------- test/Reflex/Test/CrossImpl.hs | 3 + test/Reflex/Test/Micro.hs | 67 ++++++++++++++++++- test/semantics.hs | 10 ++- 5 files changed, 71 insertions(+), 147 deletions(-) delete mode 100644 test/BuildDynamic.hs diff --git a/reflex.cabal b/reflex.cabal index fd4f40cc..9929f9d0 100644 --- a/reflex.cabal +++ b/reflex.cabal @@ -213,23 +213,6 @@ test-suite RequesterT , ref-tf buildable: False - -test-suite BuildDynamic - type: exitcode-stdio-1.0 - main-is: BuildDynamic.hs - hs-source-dirs: test - build-depends: base - , reflex - , dependent-map - - , dependent-sum - , these - , ref-tf - , lens - - other-modules: Test.Run - - test-suite QueryT type: exitcode-stdio-1.0 main-is: QueryT.hs diff --git a/test/BuildDynamic.hs b/test/BuildDynamic.hs deleted file mode 100644 index 521c62d6..00000000 --- a/test/BuildDynamic.hs +++ /dev/null @@ -1,121 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE RecursiveDo #-} - -module Main where - -import Control.Lens -import Control.Monad -import Control.Monad.Fix -import qualified Data.Dependent.Map as DMap -import Data.Dependent.Sum -import Data.These -import Data.Monoid - -import Reflex -import Test.Run - -pushDyn :: (Reflex t, MonadHold t m) => (a -> PushM t b) -> Dynamic t a -> m (Dynamic t b) -pushDyn f d = buildDynamic (sample (current d) >>= f) (pushAlways f (updated d)) - -foldedDyn :: (Reflex t, MonadHold t m) => (a -> a -> a) -> Dynamic t a -> m (Dynamic t a) -foldedDyn f d = fmap join $ flip buildDynamic never $ do - a <- sample (current d) - foldDyn f a (updated d) - -scannedDyn :: (Reflex t, MonadHold t m) => Dynamic t a -> m (Dynamic t [a]) -scannedDyn = fmap (fmap reverse) . foldedDyn (<>) . fmap pure - -scanInnerDyns :: (Reflex t, MonadHold t m) => Dynamic t (Dynamic t a) -> m (Dynamic t [a]) -scanInnerDyns d = do - scans <- scannedDyn d - return (join (fmap distributeListOverDynPure scans)) - - -main :: IO () -main = do - - r <- last <$> runAppB testInnerHoldsE (Just <$> [1..4]) - -- [[[0,1,2],[1,2],[2]]]] - - -- r <- runAppB testScan counter - - -- r <- runAppB testStrictness (fmap Just [1..9]) - - - print r - return () - - where - counter = fmap Just [1..9] <> [Nothing] - eithers = fmap Just [ Left 1, Left 2, Right 3, Left 4, Left 5, Right 6, Right 7, Right 8, Left 9 ] <> [Nothing] - -testIdentity :: (Reflex t, MonadHold t m, MonadFix m) - => Event t Int -> m (Behavior t Int) -testIdentity e = do - d <- holdDyn 0 e - d' <- pushDyn return d - d'' <- pushDyn return d' - - return (current d'') - -testStrictness :: (Reflex t, MonadHold t m, MonadFix m) - => Event t Int -> m (Behavior t Int) -testStrictness e = do - - rec - d'' <- pushDyn return d' - d' <- pushDyn return d - d <- holdDyn 0 e - - return (current d'') - - -testScan :: (Reflex t, MonadHold t m, MonadFix m) - => Event t Int -> m (Behavior t [Int]) -testScan e = do - d <- holdDyn 0 e - scan <- scannedDyn d - return (current scan) - -testFactor :: (Reflex t, MonadHold t m, MonadFix m) - => Event t (Either Int Int) -> m (Behavior t (Either Int Int)) -testFactor e = do - d <- holdDyn (Left 0) e - - eithers <- eitherDyn d - return $ current (join (fmap unFactor eithers)) - - where - unFactor = either (fmap Left) (fmap Right) - -testInnerHolds :: (Reflex t, MonadHold t m, MonadFix m) - => Event t Int -> m (Behavior t [Int]) -testInnerHolds e = do - d <- holdDyn 0 e - - d' <- pushDyn (\a -> foldDyn (:) [a] (updated d)) d - return $ current (join d') - -testInnerHoldsE :: forall t m. (Reflex t, MonadHold t m, MonadFix m) - => Event t Int -> m (Behavior t [[Int]]) -testInnerHoldsE e = do - initial <- f 0 - d <- foldDyn snoc [initial] updates - return $ current (join (fmap distributeListOverDynPure d)) - where - f :: forall n. (MonadHold t n, MonadFix n) => Int -> n (Dynamic t [Int]) - f a = foldDyn snoc [a] e - updates = pushAlways f e - - snoc x xs = xs ++ [x] - -testInnerHolds1 :: (Reflex t, MonadHold t m, MonadFix m) - => Event t Int -> m (Behavior t [[Int]]) -testInnerHolds1 e = do - d <- fmap pure <$> holdDyn 0 e - - d' <- pushDyn (\a -> foldDyn (flip mappend) a (updated d)) d - current <$> scanInnerDyns d' diff --git a/test/Reflex/Test/CrossImpl.hs b/test/Reflex/Test/CrossImpl.hs index ebc2c8e7..a813bf04 100644 --- a/test/Reflex/Test/CrossImpl.hs +++ b/test/Reflex/Test/CrossImpl.hs @@ -230,6 +230,9 @@ testCases = rec result <- holdUniqDyn d d <- holdDyn (0 :: Int) e return (current result, updated result) + + + {- , (,) "mergeIncrementalWithMove" $ TestCase (Map.singleton 0 (0 :: Int), Map.fromList [(1, PatchDMapWithMove.moveDMapKey LeftTag RightTag), (2, mempty)]) $ \(b, e :: Event t (PatchDMapWithMove (EitherTag () ()) (Const2 () ()))) -> do x <- holdIncremental (DMap.singleton LeftTag $ void e) $ PatchDMapWithMove.mapPatchDMapWithMove (\(Const2 _) -> void e) <$> e diff --git a/test/Reflex/Test/Micro.hs b/test/Reflex/Test/Micro.hs index f9358de7..50aa55a4 100644 --- a/test/Reflex/Test/Micro.hs +++ b/test/Reflex/Test/Micro.hs @@ -3,6 +3,7 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} +{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE RecursiveDo #-} @@ -23,6 +24,24 @@ import Data.Monoid import Prelude +pushDyn :: (Reflex t, MonadHold t m) => (a -> PushM t b) -> Dynamic t a -> m (Dynamic t b) +pushDyn f d = buildDynamic (sample (current d) >>= f) (pushAlways f (updated d)) + +foldedDyn :: (Reflex t, MonadHold t m) => (a -> a -> a) -> Dynamic t a -> m (Dynamic t a) +foldedDyn f d = fmap join $ flip buildDynamic never $ do + a <- sample (current d) + foldDyn f a (updated d) + +scannedDyn :: (Reflex t, MonadHold t m) => Dynamic t a -> m (Dynamic t [a]) +scannedDyn = fmap (fmap reverse) . foldedDyn (<>) . fmap pure + +scanInnerDyns :: (Reflex t, MonadHold t m) => Dynamic t (Dynamic t a) -> m (Dynamic t [a]) +scanInnerDyns d = do + scans <- scannedDyn d + return (join (fmap distributeListOverDynPure scans)) + + + {-# ANN testCases "HLint: ignore Functor law" #-} testCases :: [(String, TestCase)] testCases = @@ -201,6 +220,14 @@ testCases = bb <- hold (constant "x") $ pushAlways (const $ hold "a" eo) eo return $ pull $ sample =<< sample bb + + , testB "foldDynWhileFiring" $ do + e <- events1 + d <- foldDyn (:) [] $ + pushAlways (\a -> foldDyn (:) [a] e) e + + return $ current (join (fmap distributeListOverDynPure d)) + , testE "joinDyn" $ do e <- events1 bb <- hold "b" e @@ -223,6 +250,38 @@ testCases = d2 <- fmap (fmap (map toUpper)) $ foldDyn (++) "0" =<< events2 return $ current $ zipDynWith (<>) d1 d2 + + , testB "buildDynamicStrictness" $ do + rec + d'' <- pushDyn return d' + d' <- pushDyn return d + d <- holdDyn "0" =<< events1 + + _ <- sample (current d'') + return (current d'') + + , testB "factorDyn" $ do + d <- holdDyn (Left "a") =<< eithers + + eithers <- eitherDyn d + let unFactor = either id id + return $ current (join (fmap unFactor eithers)) + + , testB "pushDynDeep" $ do + e1 <- events1 + e2 <- events2 + + d1 <- holdDyn "d1" =<< events1 + d2 <- holdDyn "d2" =<< events2 + + d <- flip pushDyn d1 $ \a -> + flip pushDyn d2 $ \b -> + flip pushDyn d1 $ \c -> + return (a <> b <> c) + + d' <- pushDyn scanInnerDyns d >>= scanInnerDyns + return $ current d' + , testE "fan-1" $ do e <- fmap toMap <$> events1 let es = select (fanMap e) . Const2 <$> values @@ -264,14 +323,18 @@ testCases = return $ void e lazyHold + ] where events1, events2, events3 :: TestPlan t m => m (Event t String) events1 = plan [(1, "a"), (2, "b"), (5, "c"), (7, "d"), (8, "e")] events2 = plan [(1, "e"), (3, "d"), (4, "c"), (6, "b"), (7, "a")] - events3 = liftA2 mappend events1 events2 + eithers :: TestPlan t m => m (Event t (Either String String)) + eithers = plan [(1, Left "e"), (3, Left "d"), (4, Right "c"), (6, Right "b"), (7, Left "a")] + + values = "abcde" toMap str = Map.fromList $ map (\c -> (c, c)) str @@ -281,5 +344,3 @@ testCases = deep e = leftmost [e, e] leftmost2 e1 e2 = leftmost [e1, e2] - - diff --git a/test/semantics.hs b/test/semantics.hs index b633368d..4e377c78 100644 --- a/test/semantics.hs +++ b/test/semantics.hs @@ -38,12 +38,10 @@ main = do where allTests = concat [ makeGroup "micro" Micro.testCases - , makeGroup "subscribing (100,40)" (Focused.subscribing 100 40) - , makeGroup "firing 1000" (Focused.firing 1000) - , makeGroup "merge 100" (Focused.merging 100) - , makeGroup "fan 50" (Focused.fans 50) + -- , makeGroup "subscribing (100,40)" (Focused.subscribing 100 40) + -- , makeGroup "firing 1000" (Focused.firing 1000) + -- , makeGroup "merge 100" (Focused.merging 100) + -- , makeGroup "fan 50" (Focused.fans 50) ] makeGroup name tests = first (\test -> intercalate "/" [name, test]) <$> tests - - From 147ba41b01395d66be32402bf70ad4330a975149 Mon Sep 17 00:00:00 2001 From: Oliver Batchelor Date: Sat, 4 Aug 2018 10:54:39 +1200 Subject: [PATCH 011/241] Uncomment mistake --- test/semantics.hs | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/test/semantics.hs b/test/semantics.hs index 4e377c78..9ce8317a 100644 --- a/test/semantics.hs +++ b/test/semantics.hs @@ -38,10 +38,10 @@ main = do where allTests = concat [ makeGroup "micro" Micro.testCases - -- , makeGroup "subscribing (100,40)" (Focused.subscribing 100 40) - -- , makeGroup "firing 1000" (Focused.firing 1000) - -- , makeGroup "merge 100" (Focused.merging 100) - -- , makeGroup "fan 50" (Focused.fans 50) + , makeGroup "subscribing (100,40)" (Focused.subscribing 100 40) + , makeGroup "firing 1000" (Focused.firing 1000) + , makeGroup "merge 100" (Focused.merging 100) + , makeGroup "fan 50" (Focused.fans 50) ] makeGroup name tests = first (\test -> intercalate "/" [name, test]) <$> tests From abb0fd90f22df351cc6743472ada7da3eac71090 Mon Sep 17 00:00:00 2001 From: Ryan Trinkle Date: Tue, 7 Aug 2018 12:29:22 -0400 Subject: [PATCH 012/241] Make PerformEventT a transformer again; misc cleanup # Conflicts: # src/Reflex/PerformEvent/Base.hs --- src/Reflex/NotReady/Class.hs | 42 ++++----------- src/Reflex/PerformEvent/Base.hs | 95 +++++++++++++++++---------------- 2 files changed, 58 insertions(+), 79 deletions(-) diff --git a/src/Reflex/NotReady/Class.hs b/src/Reflex/NotReady/Class.hs index 4bc89a77..00a1403a 100644 --- a/src/Reflex/NotReady/Class.hs +++ b/src/Reflex/NotReady/Class.hs @@ -19,8 +19,7 @@ import Control.Monad.Trans import Reflex.Class import Reflex.DynamicWriter.Base (DynamicWriterT) import Reflex.EventWriter.Base (EventWriterT) -import Reflex.Host.Class -import Reflex.PerformEvent.Base (PerformEventT (..)) +import Reflex.PerformEvent.Base (PerformEventT) import Reflex.PostBuild.Base (PostBuildT) import Reflex.Query.Base (QueryT) import Reflex.Requester.Base (RequesterT) @@ -35,34 +34,11 @@ class Monad m => NotReady t m | m -> t where default notReady :: (MonadTrans f, m ~ f m', NotReady t m') => m () notReady = lift notReady -instance NotReady t m => NotReady t (ReaderT r m) where - notReadyUntil = lift . notReadyUntil - notReady = lift notReady - -instance NotReady t m => NotReady t (PostBuildT t m) where - notReadyUntil = lift . notReadyUntil - notReady = lift notReady - -instance NotReady t m => NotReady t (EventWriterT t w m) where - notReadyUntil = lift . notReadyUntil - notReady = lift notReady - -instance NotReady t m => NotReady t (DynamicWriterT t w m) where - notReadyUntil = lift . notReadyUntil - notReady = lift notReady - -instance NotReady t m => NotReady t (QueryT t q m) where - notReadyUntil = lift . notReadyUntil - notReady = lift notReady - -instance (ReflexHost t, NotReady t (HostFrame t)) => NotReady t (PerformEventT t m) where - notReadyUntil = PerformEventT . notReadyUntil - notReady = PerformEventT notReady - -instance NotReady t m => NotReady t (RequesterT t request response m) where - notReadyUntil = lift . notReadyUntil - notReady = lift notReady - -instance NotReady t m => NotReady t (TriggerEventT t m) where - notReadyUntil = lift . notReadyUntil - notReady = lift notReady +instance NotReady t m => NotReady t (ReaderT r m) +instance NotReady t m => NotReady t (PostBuildT t m) +instance NotReady t m => NotReady t (EventWriterT t w m) +instance NotReady t m => NotReady t (DynamicWriterT t w m) +instance NotReady t m => NotReady t (QueryT t q m) +instance NotReady t m => NotReady t (PerformEventT t m) +instance NotReady t m => NotReady t (RequesterT t request response m) +instance NotReady t m => NotReady t (TriggerEventT t m) diff --git a/src/Reflex/PerformEvent/Base.hs b/src/Reflex/PerformEvent/Base.hs index 59d66586..b0d24883 100644 --- a/src/Reflex/PerformEvent/Base.hs +++ b/src/Reflex/PerformEvent/Base.hs @@ -53,31 +53,31 @@ newtype FireCommand t m = FireCommand { runFireCommand :: forall a. [DSum (Event -- | Provides a basic implementation of 'PerformEvent'. Note that, despite the -- name, 'PerformEventT' is not an instance of 'MonadTrans'. -newtype PerformEventT t m a = PerformEventT { unPerformEventT :: RequesterT t (HostFrame t) Identity (HostFrame t) a } - -deriving instance ReflexHost t => Functor (PerformEventT t m) -deriving instance ReflexHost t => Applicative (PerformEventT t m) -deriving instance ReflexHost t => Monad (PerformEventT t m) -deriving instance ReflexHost t => MonadFix (PerformEventT t m) -deriving instance (ReflexHost t, MonadIO (HostFrame t)) => MonadIO (PerformEventT t m) -deriving instance (ReflexHost t, MonadException (HostFrame t)) => MonadException (PerformEventT t m) -deriving instance (ReflexHost t, Monoid a) => Monoid (PerformEventT t m a) -deriving instance (ReflexHost t, S.Semigroup a) => S.Semigroup (PerformEventT t m a) - -instance (PrimMonad (HostFrame t), ReflexHost t) => PrimMonad (PerformEventT t m) where - type PrimState (PerformEventT t m) = PrimState (HostFrame t) - primitive = PerformEventT . lift . primitive - -instance (ReflexHost t, Ref m ~ Ref IO) => PerformEvent t (PerformEventT t m) where - type Performable (PerformEventT t m) = HostFrame t +newtype PerformEventT t m a = PerformEventT { unPerformEventT :: RequesterT t m Identity m a } + +deriving instance Functor m => Functor (PerformEventT t m) +deriving instance Monad m => Applicative (PerformEventT t m) +deriving instance Monad m => Monad (PerformEventT t m) +deriving instance MonadFix m => MonadFix (PerformEventT t m) +deriving instance MonadIO m => MonadIO (PerformEventT t m) +deriving instance MonadException m => MonadException (PerformEventT t m) +deriving instance (Monad m, Monoid a) => Monoid (PerformEventT t m a) +deriving instance (Monad m, S.Semigroup a) => S.Semigroup (PerformEventT t m a) + +instance (PrimMonad m, ReflexHost t) => PrimMonad (PerformEventT t m) where + type PrimState (PerformEventT t m) = PrimState m + primitive = lift . primitive + +instance (Monad m, Reflex t, Ref m ~ Ref IO) => PerformEvent t (PerformEventT t m) where + type Performable (PerformEventT t m) = m {-# INLINABLE performEvent_ #-} performEvent_ = PerformEventT . requesting_ {-# INLINABLE performEvent #-} performEvent = PerformEventT . requestingIdentity -instance (ReflexHost t, PrimMonad (HostFrame t)) => Adjustable t (PerformEventT t m) where +instance (Reflex t, MonadHold t m, MonadFix m, PrimMonad m) => Adjustable t (PerformEventT t m) where runWithReplace outerA0 outerA' = PerformEventT $ runWithReplaceRequesterTWith f (coerce outerA0) (coerceEvent outerA') - where f :: HostFrame t a -> Event t (HostFrame t b) -> RequesterT t (HostFrame t) Identity (HostFrame t) (a, Event t b) + where f :: m a -> Event t (m b) -> RequesterT t m Identity m (a, Event t b) f a0 a' = do result0 <- lift a0 result' <- requestingIdentity a' @@ -86,33 +86,33 @@ instance (ReflexHost t, PrimMonad (HostFrame t)) => Adjustable t (PerformEventT traverseDMapWithKeyWithAdjust f outerDm0 outerDm' = PerformEventT $ traverseDMapWithKeyWithAdjustRequesterTWith (defaultAdjustBase traversePatchDMapWithKey) mapPatchDMap weakenPatchDMapWith patchMapNewElementsMap mergeMapIncremental (\k v -> unPerformEventT $ f k v) (coerce outerDm0) (coerceEvent outerDm') traverseDMapWithKeyWithAdjustWithMove f outerDm0 outerDm' = PerformEventT $ traverseDMapWithKeyWithAdjustRequesterTWith (defaultAdjustBase traversePatchDMapWithMoveWithKey) mapPatchDMapWithMove weakenPatchDMapWithMoveWith patchMapWithMoveNewElementsMap mergeMapIncrementalWithMove (\k v -> unPerformEventT $ f k v) (coerce outerDm0) (coerceEvent outerDm') -defaultAdjustBase :: forall t v v2 k' p. (Monad (HostFrame t), PrimMonad (HostFrame t), Reflex t) - => ((forall a. k' a -> v a -> HostFrame t (v2 a)) -> p k' v -> HostFrame t (p k' v2)) - -> (forall a. k' a -> v a -> HostFrame t (v2 a)) +defaultAdjustBase :: forall t v v2 k' p m. (Monad m, PrimMonad m, Reflex t) + => ((forall a. k' a -> v a -> m (v2 a)) -> p k' v -> m (p k' v2)) + -> (forall a. k' a -> v a -> m (v2 a)) -> DMap k' v -> Event t (p k' v) - -> RequesterT t (HostFrame t) Identity (HostFrame t) (DMap k' v2, Event t (p k' v2)) + -> RequesterT t m Identity m (DMap k' v2, Event t (p k' v2)) defaultAdjustBase traversePatchWithKey f' dm0 dm' = do result0 <- lift $ DMap.traverseWithKey f' dm0 result' <- requestingIdentity $ ffor dm' $ traversePatchWithKey f' return (result0, result') -defaultAdjustIntBase :: forall t v v2 p. (Monad (HostFrame t), PrimMonad (HostFrame t), Reflex t) - => ((IntMap.Key -> v -> HostFrame t v2) -> p v -> HostFrame t (p v2)) - -> (IntMap.Key -> v -> HostFrame t v2) +defaultAdjustIntBase :: forall t v v2 p m. (Monad m, PrimMonad m, Reflex t) + => ((IntMap.Key -> v -> m v2) -> p v -> m (p v2)) + -> (IntMap.Key -> v -> m v2) -> IntMap v -> Event t (p v) - -> RequesterT t (HostFrame t) Identity (HostFrame t) (IntMap v2, Event t (p v2)) + -> RequesterT t m Identity m (IntMap v2, Event t (p v2)) defaultAdjustIntBase traversePatchWithKey f' dm0 dm' = do result0 <- lift $ IntMap.traverseWithKey f' dm0 result' <- requestingIdentity $ ffor dm' $ traversePatchWithKey f' return (result0, result') -instance ReflexHost t => MonadReflexCreateTrigger t (PerformEventT t m) where +instance MonadReflexCreateTrigger t m => MonadReflexCreateTrigger t (PerformEventT t m) where {-# INLINABLE newEventWithTrigger #-} - newEventWithTrigger = PerformEventT . lift . newEventWithTrigger + newEventWithTrigger = lift . newEventWithTrigger {-# INLINABLE newFanEventWithTrigger #-} - newFanEventWithTrigger f = PerformEventT $ lift $ newFanEventWithTrigger f + newFanEventWithTrigger f = lift $ newFanEventWithTrigger f -- | Run a 'PerformEventT' action, returning a 'FireCommand' that allows the -- caller to trigger 'Event's while ensuring that 'performEvent' actions are run @@ -129,7 +129,7 @@ hostPerformEventT :: forall t m a. -> m (a, FireCommand t m) hostPerformEventT a = do (response, responseTrigger) <- newEventWithTriggerRef - (result, eventToPerform) <- runHostFrame $ runRequesterT (unPerformEventT a) response + (result, eventToPerform) <- runRequesterT (unPerformEventT a) response eventToPerformHandle <- subscribeEvent eventToPerform return $ (,) result $ FireCommand $ \triggers (readPhase :: ReadPhase m a') -> do let go :: [DSum (EventTrigger t) Identity] -> m [a'] @@ -141,7 +141,7 @@ hostPerformEventT a = do case mToPerform of Nothing -> return [result'] Just toPerform -> do - responses <- runHostFrame $ traverseRequesterData (\v -> Identity <$> v) toPerform + responses <- traverseRequesterData (\v -> Identity <$> v) toPerform mrt <- readRef responseTrigger let followupEventTriggers = case mrt of Just rt -> [rt :=> Identity responses] @@ -149,31 +149,34 @@ hostPerformEventT a = do (result':) <$> go followupEventTriggers go triggers -instance ReflexHost t => MonadSample t (PerformEventT t m) where +instance MonadSample t m => MonadSample t (PerformEventT t m) where {-# INLINABLE sample #-} - sample = PerformEventT . lift . sample + sample = lift . sample instance (ReflexHost t, MonadHold t m) => MonadHold t (PerformEventT t m) where {-# INLINABLE hold #-} - hold v0 v' = PerformEventT $ lift $ hold v0 v' + hold v0 v' = lift $ hold v0 v' {-# INLINABLE holdDyn #-} - holdDyn v0 v' = PerformEventT $ lift $ holdDyn v0 v' + holdDyn v0 v' = lift $ holdDyn v0 v' {-# INLINABLE holdIncremental #-} - holdIncremental v0 v' = PerformEventT $ lift $ holdIncremental v0 v' + holdIncremental v0 v' = lift $ holdIncremental v0 v' {-# INLINABLE buildDynamic #-} - buildDynamic getV0 v' = PerformEventT $ lift $ buildDynamic getV0 v' + buildDynamic getV0 v' = lift $ buildDynamic getV0 v' {-# INLINABLE headE #-} - headE = PerformEventT . lift . headE + headE = lift . headE -instance (MonadRef (HostFrame t), ReflexHost t) => MonadRef (PerformEventT t m) where - type Ref (PerformEventT t m) = Ref (HostFrame t) +instance (MonadRef m, ReflexHost t) => MonadRef (PerformEventT t m) where + type Ref (PerformEventT t m) = Ref m {-# INLINABLE newRef #-} - newRef = PerformEventT . lift . newRef + newRef = lift . newRef {-# INLINABLE readRef #-} - readRef = PerformEventT . lift . readRef + readRef = lift . readRef {-# INLINABLE writeRef #-} - writeRef r = PerformEventT . lift . writeRef r + writeRef r = lift . writeRef r -instance (MonadAtomicRef (HostFrame t), ReflexHost t) => MonadAtomicRef (PerformEventT t m) where +instance (MonadAtomicRef m, ReflexHost t) => MonadAtomicRef (PerformEventT t m) where {-# INLINABLE atomicModifyRef #-} - atomicModifyRef r = PerformEventT . lift . atomicModifyRef r + atomicModifyRef r = lift . atomicModifyRef r + +instance MonadTrans (PerformEventT t) where + lift = PerformEventT . lift From 39d9392b191ec85052eb8839f6c9f207f9e21885 Mon Sep 17 00:00:00 2001 From: Ryan Trinkle Date: Tue, 7 Aug 2018 13:28:48 -0400 Subject: [PATCH 013/241] Add PrimMonad instance for SpiderHost --- src/Reflex/Spider/Internal.hs | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/src/Reflex/Spider/Internal.hs b/src/Reflex/Spider/Internal.hs index edb4913f..50eb9b4c 100644 --- a/src/Reflex/Spider/Internal.hs +++ b/src/Reflex/Spider/Internal.hs @@ -2555,6 +2555,10 @@ instance Monad (SpiderHost x) where {-# INLINABLE fail #-} fail s = SpiderHost $ fail s +instance PrimMonad (SpiderHost x) where + type PrimState (SpiderHost x) = PrimState IO + primitive = SpiderHost . primitive + -- | Run an action affecting the global Spider timeline; this will be guarded by -- a mutex for that timeline runSpiderHost :: SpiderHost Global a -> IO a From cdc160f5736f60b8c2875e73ab43a577477c75cf Mon Sep 17 00:00:00 2001 From: Ken Micklas Date: Wed, 18 Jul 2018 17:36:46 -0400 Subject: [PATCH 014/241] Add traverseIntMapWithKeyWithAdjust for QueryT --- src/Reflex/Query/Base.hs | 49 ++++++++++++++++++++++++++++++++++++++++ 1 file changed, 49 insertions(+) diff --git a/src/Reflex/Query/Base.hs b/src/Reflex/Query/Base.hs index b19f97c0..0b166429 100644 --- a/src/Reflex/Query/Base.hs +++ b/src/Reflex/Query/Base.hs @@ -29,6 +29,8 @@ import qualified Data.Dependent.Map as DMap import Data.Foldable import Data.Functor.Compose import Data.Functor.Misc +import Data.IntMap (IntMap) +import qualified Data.IntMap as IntMap import Data.Map (Map) import qualified Data.Map as Map import Data.Monoid ((<>)) @@ -88,6 +90,52 @@ instance (Reflex t, MonadFix m, Group q, Additive q, Query q, MonadHold t m, Adj QueryT $ modify $ (:) $ pull $ sampleBs =<< sample bbs QueryT $ lift $ tellEvent patches return (r0, fmapCheap fst r') + + traverseIntMapWithKeyWithAdjust :: forall v v'. (IntMap.Key -> v -> QueryT t q m v') -> IntMap v -> Event t (PatchIntMap v) -> QueryT t q m (IntMap v', Event t (PatchIntMap v')) + traverseIntMapWithKeyWithAdjust f im0 im' = do + let f' :: IntMap.Key -> v -> EventWriterT t q (ReaderT (Dynamic t (QueryResult q)) m) (QueryTLoweredResult t q v') + f' k v = fmap QueryTLoweredResult $ flip runStateT [] $ unQueryT $ f k v + (result0, result') <- QueryT $ lift $ traverseIntMapWithKeyWithAdjust f' im0 im' + let liftedResult0 = IntMap.map (\r -> getQueryTLoweredResultValue r) result0 + liftedResult' = fforCheap result' $ \(PatchIntMap p) -> PatchIntMap $ + IntMap.map (\mr -> fmap getQueryTLoweredResultValue mr) p + liftedBs0 :: IntMap [Behavior t q] + liftedBs0 = IntMap.map (\r -> getQueryTLoweredResultWritten r) result0 + liftedBs' :: Event t (PatchIntMap [Behavior t q]) + liftedBs' = fforCheap result' $ \(PatchIntMap p) -> PatchIntMap $ + IntMap.map (\mr -> fmap getQueryTLoweredResultWritten mr) p + sampleBs :: forall m'. MonadSample t m' => [Behavior t q] -> m' q + sampleBs = foldlM (\b a -> (b <>) <$> sample a) mempty + accumBehaviors :: forall m'. MonadHold t m' + => IntMap [Behavior t q] + -> PatchIntMap [Behavior t q] + -> m' ( Maybe (IntMap [Behavior t q]) + , Maybe (AdditivePatch q)) + -- f accumulates the child behavior state we receive from running traverseIntMapWithKeyWithAdjust for the underlying monad. + -- When an update occurs, it also computes a patch to communicate to the parent QueryT state. + -- bs0 is a Map denoting the behaviors of the current children. + -- pbs is a PatchMap denoting an update to the behaviors of the current children + accumBehaviors bs0 pbs@(PatchIntMap bs') = do + let p k bs = case IntMap.lookup k bs0 of + Nothing -> case bs of + -- If the update is to delete the state for a child that doesn't exist, the patch is mempty. + Nothing -> return mempty + -- If the update is to update the state for a child that doesn't exist, the patch is the sample of the new state. + Just newBs -> sampleBs newBs + Just oldBs -> case bs of + -- If the update is to delete the state for a child that already exists, the patch is the negation of the child's current state + Nothing -> negateG <$> sampleBs oldBs + -- If the update is to update the state for a child that already exists, the patch is the negation of sampling the child's current state + -- composed with the sampling the child's new state. + Just newBs -> (~~) <$> sampleBs newBs <*> sampleBs oldBs + -- we compute the patch by iterating over the update PatchMap and proceeding by cases. Then we fold over the + -- child patches and wrap them in AdditivePatch. + patch <- AdditivePatch . fold <$> IntMap.traverseWithKey p bs' + return (apply pbs bs0, Just patch) + (qpatch :: Event t (AdditivePatch q)) <- mapAccumMaybeM_ accumBehaviors liftedBs0 liftedBs' + tellQueryIncremental $ unsafeBuildIncremental (fold <$> mapM sampleBs liftedBs0) qpatch + return (liftedResult0, liftedResult') + traverseDMapWithKeyWithAdjust :: forall (k :: * -> *) v v'. (DMap.GCompare k) => (forall a. k a -> v a -> QueryT t q m (v' a)) -> DMap k v -> Event t (PatchDMap k v) -> QueryT t q m (DMap k v', Event t (PatchDMap k v')) traverseDMapWithKeyWithAdjust f dm0 dm' = do let f' :: forall a. k a -> v a -> EventWriterT t q (ReaderT (Dynamic t (QueryResult q)) m) (Compose (QueryTLoweredResult t q) v' a) @@ -132,6 +180,7 @@ instance (Reflex t, MonadFix m, Group q, Additive q, Query q, MonadHold t m, Adj (qpatch :: Event t (AdditivePatch q)) <- mapAccumMaybeM_ accumBehaviors liftedBs0 liftedBs' tellQueryIncremental $ unsafeBuildIncremental (fold <$> mapM sampleBs liftedBs0) qpatch return (liftedResult0, liftedResult') + traverseDMapWithKeyWithAdjustWithMove :: forall (k :: * -> *) v v'. (DMap.GCompare k) => (forall a. k a -> v a -> QueryT t q m (v' a)) -> DMap k v -> Event t (PatchDMapWithMove k v) -> QueryT t q m (DMap k v', Event t (PatchDMapWithMove k v')) traverseDMapWithKeyWithAdjustWithMove f dm0 dm' = do let f' :: forall a. k a -> v a -> EventWriterT t q (ReaderT (Dynamic t (QueryResult q)) m) (Compose (QueryTLoweredResult t q) v' a) From 1150ac955db52c137acbfd51a46d58e33f7ede7f Mon Sep 17 00:00:00 2001 From: Ken Micklas Date: Fri, 20 Jul 2018 14:42:16 -0400 Subject: [PATCH 015/241] Add MonadDynamicWriter for QueryT and MonadQuery for DynamicWriterT This fixes #207. --- src/Reflex/DynamicWriter/Base.hs | 6 ++++++ src/Reflex/Query/Base.hs | 4 ++++ 2 files changed, 10 insertions(+) diff --git a/src/Reflex/DynamicWriter/Base.hs b/src/Reflex/DynamicWriter/Base.hs index 18168d43..6059e1d1 100644 --- a/src/Reflex/DynamicWriter/Base.hs +++ b/src/Reflex/DynamicWriter/Base.hs @@ -44,6 +44,7 @@ import Reflex.Host.Class import qualified Reflex.Patch.MapWithMove as MapWithMove import Reflex.PerformEvent.Class import Reflex.PostBuild.Class +import Reflex.Query.Class import Reflex.Requester.Class import Reflex.TriggerEvent.Class @@ -214,3 +215,8 @@ instance Requester t m => Requester t (DynamicWriterT t w m) where type Response (DynamicWriterT t w m) = Response m requesting = lift . requesting requesting_ = lift . requesting_ + +instance (MonadQuery t q m, Monad m) => MonadQuery t q (DynamicWriterT t w m) where + tellQueryIncremental = lift . tellQueryIncremental + askQueryResult = lift askQueryResult + queryIncremental = lift . queryIncremental diff --git a/src/Reflex/Query/Base.hs b/src/Reflex/Query/Base.hs index b19f97c0..7e17d590 100644 --- a/src/Reflex/Query/Base.hs +++ b/src/Reflex/Query/Base.hs @@ -39,6 +39,7 @@ import Data.These import Reflex.Class import Reflex.Adjustable.Class +import Reflex.DynamicWriter.Class import Reflex.EventWriter.Base import Reflex.EventWriter.Class import Reflex.Host.Class @@ -286,3 +287,6 @@ instance Requester t m => Requester t (QueryT t q m) where instance EventWriter t w m => EventWriter t w (QueryT t q m) where tellEvent = lift . tellEvent + +instance MonadDynamicWriter t w m => MonadDynamicWriter t w (QueryT t q m) where + tellDyn = lift . tellDyn From ae6b5999fd2305f83cd573788598e262cc07733b Mon Sep 17 00:00:00 2001 From: Ryan Trinkle Date: Tue, 14 Aug 2018 12:27:42 -0400 Subject: [PATCH 016/241] Add tagMaybe --- src/Reflex/Class.hs | 7 +++++++ 1 file changed, 7 insertions(+) diff --git a/src/Reflex/Class.hs b/src/Reflex/Class.hs index 4b1a4151..c4bae6f4 100644 --- a/src/Reflex/Class.hs +++ b/src/Reflex/Class.hs @@ -68,6 +68,7 @@ module Reflex.Class , switchHoldPromptOnly -- ** Using 'Event's to sample 'Behavior's , tag + , tagMaybe , attach , attachWith , attachWithMaybe @@ -557,6 +558,12 @@ instance Reflex t => Plus (Event t) where tag :: Reflex t => Behavior t b -> Event t a -> Event t b tag b = pushAlways $ \_ -> sample b +-- | Replace each occurrence value of the 'Event' with the value of the +-- 'Behavior' at that time; if it is 'Just', fire with the contained value; if +-- it is 'Nothing', drop the occurrence. +tagMaybe :: Reflex t => Behavior t (Maybe b) -> Event t a -> Event t b +tagMaybe b = push $ \_ -> sample b + -- | Create a new 'Event' that combines occurrences of supplied 'Event' with the -- current value of the 'Behavior'. attach :: Reflex t => Behavior t a -> Event t b -> Event t (a, b) From c200e1cdc19edb8870a36b78c21e18a81433cc8e Mon Sep 17 00:00:00 2001 From: hololeap Date: Wed, 15 Aug 2018 10:58:47 -0600 Subject: [PATCH 017/241] Hide <> from Prelude Since base-4.9.0, Prelude exports `<>` and this creates an ambiguous occurrence wtih `GhcPlugins.<>` --- src/Reflex/Optimizer.hs | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/src/Reflex/Optimizer.hs b/src/Reflex/Optimizer.hs index be40f4b6..19763e03 100644 --- a/src/Reflex/Optimizer.hs +++ b/src/Reflex/Optimizer.hs @@ -16,6 +16,11 @@ import Control.Arrow import CoreMonad import Data.String import GhcPlugins + +#if MIN_VERSION_base(4,9,0) +import Prelude hiding ((<>)) +#endif + #endif #ifdef ghcjs_HOST_OS From f8a3922e81f0e0acbfadba43348e8d0ef880e82a Mon Sep 17 00:00:00 2001 From: Luigy Leon Date: Thu, 16 Aug 2018 19:10:33 -0400 Subject: [PATCH 018/241] Revert "Make PerformEventT a transformer again; misc cleanup" This reverts commit abb0fd90f22df351cc6743472ada7da3eac71090. --- src/Reflex/NotReady/Class.hs | 42 +++++++++++---- src/Reflex/PerformEvent/Base.hs | 95 ++++++++++++++++----------------- 2 files changed, 79 insertions(+), 58 deletions(-) diff --git a/src/Reflex/NotReady/Class.hs b/src/Reflex/NotReady/Class.hs index 00a1403a..4bc89a77 100644 --- a/src/Reflex/NotReady/Class.hs +++ b/src/Reflex/NotReady/Class.hs @@ -19,7 +19,8 @@ import Control.Monad.Trans import Reflex.Class import Reflex.DynamicWriter.Base (DynamicWriterT) import Reflex.EventWriter.Base (EventWriterT) -import Reflex.PerformEvent.Base (PerformEventT) +import Reflex.Host.Class +import Reflex.PerformEvent.Base (PerformEventT (..)) import Reflex.PostBuild.Base (PostBuildT) import Reflex.Query.Base (QueryT) import Reflex.Requester.Base (RequesterT) @@ -34,11 +35,34 @@ class Monad m => NotReady t m | m -> t where default notReady :: (MonadTrans f, m ~ f m', NotReady t m') => m () notReady = lift notReady -instance NotReady t m => NotReady t (ReaderT r m) -instance NotReady t m => NotReady t (PostBuildT t m) -instance NotReady t m => NotReady t (EventWriterT t w m) -instance NotReady t m => NotReady t (DynamicWriterT t w m) -instance NotReady t m => NotReady t (QueryT t q m) -instance NotReady t m => NotReady t (PerformEventT t m) -instance NotReady t m => NotReady t (RequesterT t request response m) -instance NotReady t m => NotReady t (TriggerEventT t m) +instance NotReady t m => NotReady t (ReaderT r m) where + notReadyUntil = lift . notReadyUntil + notReady = lift notReady + +instance NotReady t m => NotReady t (PostBuildT t m) where + notReadyUntil = lift . notReadyUntil + notReady = lift notReady + +instance NotReady t m => NotReady t (EventWriterT t w m) where + notReadyUntil = lift . notReadyUntil + notReady = lift notReady + +instance NotReady t m => NotReady t (DynamicWriterT t w m) where + notReadyUntil = lift . notReadyUntil + notReady = lift notReady + +instance NotReady t m => NotReady t (QueryT t q m) where + notReadyUntil = lift . notReadyUntil + notReady = lift notReady + +instance (ReflexHost t, NotReady t (HostFrame t)) => NotReady t (PerformEventT t m) where + notReadyUntil = PerformEventT . notReadyUntil + notReady = PerformEventT notReady + +instance NotReady t m => NotReady t (RequesterT t request response m) where + notReadyUntil = lift . notReadyUntil + notReady = lift notReady + +instance NotReady t m => NotReady t (TriggerEventT t m) where + notReadyUntil = lift . notReadyUntil + notReady = lift notReady diff --git a/src/Reflex/PerformEvent/Base.hs b/src/Reflex/PerformEvent/Base.hs index b0d24883..59d66586 100644 --- a/src/Reflex/PerformEvent/Base.hs +++ b/src/Reflex/PerformEvent/Base.hs @@ -53,31 +53,31 @@ newtype FireCommand t m = FireCommand { runFireCommand :: forall a. [DSum (Event -- | Provides a basic implementation of 'PerformEvent'. Note that, despite the -- name, 'PerformEventT' is not an instance of 'MonadTrans'. -newtype PerformEventT t m a = PerformEventT { unPerformEventT :: RequesterT t m Identity m a } - -deriving instance Functor m => Functor (PerformEventT t m) -deriving instance Monad m => Applicative (PerformEventT t m) -deriving instance Monad m => Monad (PerformEventT t m) -deriving instance MonadFix m => MonadFix (PerformEventT t m) -deriving instance MonadIO m => MonadIO (PerformEventT t m) -deriving instance MonadException m => MonadException (PerformEventT t m) -deriving instance (Monad m, Monoid a) => Monoid (PerformEventT t m a) -deriving instance (Monad m, S.Semigroup a) => S.Semigroup (PerformEventT t m a) - -instance (PrimMonad m, ReflexHost t) => PrimMonad (PerformEventT t m) where - type PrimState (PerformEventT t m) = PrimState m - primitive = lift . primitive - -instance (Monad m, Reflex t, Ref m ~ Ref IO) => PerformEvent t (PerformEventT t m) where - type Performable (PerformEventT t m) = m +newtype PerformEventT t m a = PerformEventT { unPerformEventT :: RequesterT t (HostFrame t) Identity (HostFrame t) a } + +deriving instance ReflexHost t => Functor (PerformEventT t m) +deriving instance ReflexHost t => Applicative (PerformEventT t m) +deriving instance ReflexHost t => Monad (PerformEventT t m) +deriving instance ReflexHost t => MonadFix (PerformEventT t m) +deriving instance (ReflexHost t, MonadIO (HostFrame t)) => MonadIO (PerformEventT t m) +deriving instance (ReflexHost t, MonadException (HostFrame t)) => MonadException (PerformEventT t m) +deriving instance (ReflexHost t, Monoid a) => Monoid (PerformEventT t m a) +deriving instance (ReflexHost t, S.Semigroup a) => S.Semigroup (PerformEventT t m a) + +instance (PrimMonad (HostFrame t), ReflexHost t) => PrimMonad (PerformEventT t m) where + type PrimState (PerformEventT t m) = PrimState (HostFrame t) + primitive = PerformEventT . lift . primitive + +instance (ReflexHost t, Ref m ~ Ref IO) => PerformEvent t (PerformEventT t m) where + type Performable (PerformEventT t m) = HostFrame t {-# INLINABLE performEvent_ #-} performEvent_ = PerformEventT . requesting_ {-# INLINABLE performEvent #-} performEvent = PerformEventT . requestingIdentity -instance (Reflex t, MonadHold t m, MonadFix m, PrimMonad m) => Adjustable t (PerformEventT t m) where +instance (ReflexHost t, PrimMonad (HostFrame t)) => Adjustable t (PerformEventT t m) where runWithReplace outerA0 outerA' = PerformEventT $ runWithReplaceRequesterTWith f (coerce outerA0) (coerceEvent outerA') - where f :: m a -> Event t (m b) -> RequesterT t m Identity m (a, Event t b) + where f :: HostFrame t a -> Event t (HostFrame t b) -> RequesterT t (HostFrame t) Identity (HostFrame t) (a, Event t b) f a0 a' = do result0 <- lift a0 result' <- requestingIdentity a' @@ -86,33 +86,33 @@ instance (Reflex t, MonadHold t m, MonadFix m, PrimMonad m) => Adjustable t (Per traverseDMapWithKeyWithAdjust f outerDm0 outerDm' = PerformEventT $ traverseDMapWithKeyWithAdjustRequesterTWith (defaultAdjustBase traversePatchDMapWithKey) mapPatchDMap weakenPatchDMapWith patchMapNewElementsMap mergeMapIncremental (\k v -> unPerformEventT $ f k v) (coerce outerDm0) (coerceEvent outerDm') traverseDMapWithKeyWithAdjustWithMove f outerDm0 outerDm' = PerformEventT $ traverseDMapWithKeyWithAdjustRequesterTWith (defaultAdjustBase traversePatchDMapWithMoveWithKey) mapPatchDMapWithMove weakenPatchDMapWithMoveWith patchMapWithMoveNewElementsMap mergeMapIncrementalWithMove (\k v -> unPerformEventT $ f k v) (coerce outerDm0) (coerceEvent outerDm') -defaultAdjustBase :: forall t v v2 k' p m. (Monad m, PrimMonad m, Reflex t) - => ((forall a. k' a -> v a -> m (v2 a)) -> p k' v -> m (p k' v2)) - -> (forall a. k' a -> v a -> m (v2 a)) +defaultAdjustBase :: forall t v v2 k' p. (Monad (HostFrame t), PrimMonad (HostFrame t), Reflex t) + => ((forall a. k' a -> v a -> HostFrame t (v2 a)) -> p k' v -> HostFrame t (p k' v2)) + -> (forall a. k' a -> v a -> HostFrame t (v2 a)) -> DMap k' v -> Event t (p k' v) - -> RequesterT t m Identity m (DMap k' v2, Event t (p k' v2)) + -> RequesterT t (HostFrame t) Identity (HostFrame t) (DMap k' v2, Event t (p k' v2)) defaultAdjustBase traversePatchWithKey f' dm0 dm' = do result0 <- lift $ DMap.traverseWithKey f' dm0 result' <- requestingIdentity $ ffor dm' $ traversePatchWithKey f' return (result0, result') -defaultAdjustIntBase :: forall t v v2 p m. (Monad m, PrimMonad m, Reflex t) - => ((IntMap.Key -> v -> m v2) -> p v -> m (p v2)) - -> (IntMap.Key -> v -> m v2) +defaultAdjustIntBase :: forall t v v2 p. (Monad (HostFrame t), PrimMonad (HostFrame t), Reflex t) + => ((IntMap.Key -> v -> HostFrame t v2) -> p v -> HostFrame t (p v2)) + -> (IntMap.Key -> v -> HostFrame t v2) -> IntMap v -> Event t (p v) - -> RequesterT t m Identity m (IntMap v2, Event t (p v2)) + -> RequesterT t (HostFrame t) Identity (HostFrame t) (IntMap v2, Event t (p v2)) defaultAdjustIntBase traversePatchWithKey f' dm0 dm' = do result0 <- lift $ IntMap.traverseWithKey f' dm0 result' <- requestingIdentity $ ffor dm' $ traversePatchWithKey f' return (result0, result') -instance MonadReflexCreateTrigger t m => MonadReflexCreateTrigger t (PerformEventT t m) where +instance ReflexHost t => MonadReflexCreateTrigger t (PerformEventT t m) where {-# INLINABLE newEventWithTrigger #-} - newEventWithTrigger = lift . newEventWithTrigger + newEventWithTrigger = PerformEventT . lift . newEventWithTrigger {-# INLINABLE newFanEventWithTrigger #-} - newFanEventWithTrigger f = lift $ newFanEventWithTrigger f + newFanEventWithTrigger f = PerformEventT $ lift $ newFanEventWithTrigger f -- | Run a 'PerformEventT' action, returning a 'FireCommand' that allows the -- caller to trigger 'Event's while ensuring that 'performEvent' actions are run @@ -129,7 +129,7 @@ hostPerformEventT :: forall t m a. -> m (a, FireCommand t m) hostPerformEventT a = do (response, responseTrigger) <- newEventWithTriggerRef - (result, eventToPerform) <- runRequesterT (unPerformEventT a) response + (result, eventToPerform) <- runHostFrame $ runRequesterT (unPerformEventT a) response eventToPerformHandle <- subscribeEvent eventToPerform return $ (,) result $ FireCommand $ \triggers (readPhase :: ReadPhase m a') -> do let go :: [DSum (EventTrigger t) Identity] -> m [a'] @@ -141,7 +141,7 @@ hostPerformEventT a = do case mToPerform of Nothing -> return [result'] Just toPerform -> do - responses <- traverseRequesterData (\v -> Identity <$> v) toPerform + responses <- runHostFrame $ traverseRequesterData (\v -> Identity <$> v) toPerform mrt <- readRef responseTrigger let followupEventTriggers = case mrt of Just rt -> [rt :=> Identity responses] @@ -149,34 +149,31 @@ hostPerformEventT a = do (result':) <$> go followupEventTriggers go triggers -instance MonadSample t m => MonadSample t (PerformEventT t m) where +instance ReflexHost t => MonadSample t (PerformEventT t m) where {-# INLINABLE sample #-} - sample = lift . sample + sample = PerformEventT . lift . sample instance (ReflexHost t, MonadHold t m) => MonadHold t (PerformEventT t m) where {-# INLINABLE hold #-} - hold v0 v' = lift $ hold v0 v' + hold v0 v' = PerformEventT $ lift $ hold v0 v' {-# INLINABLE holdDyn #-} - holdDyn v0 v' = lift $ holdDyn v0 v' + holdDyn v0 v' = PerformEventT $ lift $ holdDyn v0 v' {-# INLINABLE holdIncremental #-} - holdIncremental v0 v' = lift $ holdIncremental v0 v' + holdIncremental v0 v' = PerformEventT $ lift $ holdIncremental v0 v' {-# INLINABLE buildDynamic #-} - buildDynamic getV0 v' = lift $ buildDynamic getV0 v' + buildDynamic getV0 v' = PerformEventT $ lift $ buildDynamic getV0 v' {-# INLINABLE headE #-} - headE = lift . headE + headE = PerformEventT . lift . headE -instance (MonadRef m, ReflexHost t) => MonadRef (PerformEventT t m) where - type Ref (PerformEventT t m) = Ref m +instance (MonadRef (HostFrame t), ReflexHost t) => MonadRef (PerformEventT t m) where + type Ref (PerformEventT t m) = Ref (HostFrame t) {-# INLINABLE newRef #-} - newRef = lift . newRef + newRef = PerformEventT . lift . newRef {-# INLINABLE readRef #-} - readRef = lift . readRef + readRef = PerformEventT . lift . readRef {-# INLINABLE writeRef #-} - writeRef r = lift . writeRef r + writeRef r = PerformEventT . lift . writeRef r -instance (MonadAtomicRef m, ReflexHost t) => MonadAtomicRef (PerformEventT t m) where +instance (MonadAtomicRef (HostFrame t), ReflexHost t) => MonadAtomicRef (PerformEventT t m) where {-# INLINABLE atomicModifyRef #-} - atomicModifyRef r = lift . atomicModifyRef r - -instance MonadTrans (PerformEventT t) where - lift = PerformEventT . lift + atomicModifyRef r = PerformEventT . lift . atomicModifyRef r From 9ae420796be2f7fe839bf4b5c9d2cd4f986ed95f Mon Sep 17 00:00:00 2001 From: Luigy Leon Date: Thu, 16 Aug 2018 19:10:58 -0400 Subject: [PATCH 019/241] Revert "Add PrimMonad instance for SpiderHost" This reverts commit 39d9392b191ec85052eb8839f6c9f207f9e21885. --- src/Reflex/Spider/Internal.hs | 4 ---- 1 file changed, 4 deletions(-) diff --git a/src/Reflex/Spider/Internal.hs b/src/Reflex/Spider/Internal.hs index 7ba27228..587fe9cd 100644 --- a/src/Reflex/Spider/Internal.hs +++ b/src/Reflex/Spider/Internal.hs @@ -2566,10 +2566,6 @@ instance Monad (SpiderHost x) where {-# INLINABLE fail #-} fail s = SpiderHost $ fail s -instance PrimMonad (SpiderHost x) where - type PrimState (SpiderHost x) = PrimState IO - primitive = SpiderHost . primitive - -- | Run an action affecting the global Spider timeline; this will be guarded by -- a mutex for that timeline runSpiderHost :: SpiderHost Global a -> IO a From 7ab5470aa19bc56db8c488571996330b4ab62e24 Mon Sep 17 00:00:00 2001 From: dbornside Date: Thu, 16 Aug 2018 19:13:53 -0400 Subject: [PATCH 020/241] move as much stuff as plausible to monoidal-containers --- reflex.cabal | 2 +- src/Data/AppendMap.hs | 296 +----------------------------------------- 2 files changed, 5 insertions(+), 293 deletions(-) diff --git a/reflex.cabal b/reflex.cabal index a8dc18a0..b0bc23b1 100644 --- a/reflex.cabal +++ b/reflex.cabal @@ -46,7 +46,7 @@ library exception-transformers == 0.4.*, lens >= 4.7 && < 5, monad-control >= 1.0.1 && < 1.1, - monoidal-containers >= 0.3.0.2 && < 0.4, + monoidal-containers == 0.4.*, mtl >= 2.1 && < 2.3, prim-uniq >= 0.1.0.1 && < 0.2, primitive >= 0.5 && < 0.7, diff --git a/src/Data/AppendMap.hs b/src/Data/AppendMap.hs index 5b0e4654..e903115d 100644 --- a/src/Data/AppendMap.hs +++ b/src/Data/AppendMap.hs @@ -21,7 +21,7 @@ module Data.AppendMap , module Data.Map.Monoidal ) where -import Prelude hiding (map) +import Prelude hiding (map, null) import Data.Align import Data.Coerce @@ -53,7 +53,7 @@ instance FunctorMaybe (MonoidalMap k) where nonEmptyDelete :: Ord k => k -> MonoidalMap k a -> Maybe (MonoidalMap k a) nonEmptyDelete k vs = let deleted = delete k vs - in if Data.AppendMap.null deleted + in if null deleted then Nothing else Just deleted @@ -62,309 +62,21 @@ mapMaybeNoNull :: (a -> Maybe b) -> Maybe (MonoidalMap token b) mapMaybeNoNull f as = let bs = fmapMaybe f as - in if Data.AppendMap.null bs + in if null bs then Nothing else Just bs -#if !MIN_VERSION_monoidal_containers(0,3,1) -instance (Ord k, Semigroup v) => Semigroup (MonoidalMap k v) where - MonoidalMap a <> MonoidalMap b = MonoidalMap $ Map.unionWith (<>) a b -#endif - +-- TODO: Move instances to `Reflex.Patch` instance (Ord k, Group q) => Group (MonoidalMap k q) where negateG = map negateG instance (Ord k, Additive q) => Additive (MonoidalMap k q) -(!) :: forall k a. Ord k => MonoidalMap k a -> k -> a -(!) = coerce ((Map.!) :: Map k a -> k -> a) -infixl 9 ! - -(\\) :: forall k a b. Ord k => MonoidalMap k a -> MonoidalMap k b -> MonoidalMap k a -(\\) = coerce ((Map.\\) :: Map k a -> Map k b -> Map k a) -infixl 9 {-"-} \\ {-"-} --These comments prevent the C preprocssor from complaining - -null :: forall k a. MonoidalMap k a -> Bool -null = coerce (Map.null :: Map k a -> Bool) - -lookup :: forall k a. Ord k => k -> MonoidalMap k a -> Maybe a -lookup = coerce (Map.lookup :: k -> Map k a -> Maybe a) - -lookupLT :: forall k a. Ord k => k -> MonoidalMap k a -> Maybe (k, a) -lookupLT = coerce (Map.lookupLT :: k -> Map k a -> Maybe (k,a)) - -lookupGT :: forall k a. Ord k => k -> MonoidalMap k a -> Maybe (k, a) -lookupGT = coerce (Map.lookupGT :: k -> Map k a -> Maybe (k,a)) - -lookupLE :: forall k a. Ord k => k -> MonoidalMap k a -> Maybe (k, a) -lookupLE = coerce (Map.lookupLE :: k -> Map k a -> Maybe (k,a)) - -lookupGE :: forall k a. Ord k => k -> MonoidalMap k a -> Maybe (k, a) -lookupGE = coerce (Map.lookupGE :: k -> Map k a -> Maybe (k,a)) - -empty :: forall k a. MonoidalMap k a -empty = coerce (Map.empty :: Map k a) - -insert :: forall k a. Ord k => k -> a -> MonoidalMap k a -> MonoidalMap k a -insert = coerce (Map.insert :: k -> a -> Map k a -> Map k a) - -insertWith :: forall k a. Ord k => (a -> a -> a) -> k -> a -> MonoidalMap k a -> MonoidalMap k a -insertWith = coerce (Map.insertWith :: (a -> a -> a) -> k -> a -> Map k a -> Map k a) - -insertWithKey :: forall k a. Ord k => (k -> a -> a -> a) -> k -> a -> MonoidalMap k a -> MonoidalMap k a -insertWithKey = coerce (Map.insertWithKey :: (k -> a -> a -> a) -> k -> a -> Map k a -> Map k a) - -insertLookupWithKey :: forall k a. Ord k => (k -> a -> a -> a) -> k -> a -> MonoidalMap k a -> (Maybe a, MonoidalMap k a) -insertLookupWithKey = coerce (Map.insertLookupWithKey :: (k -> a -> a -> a) -> k -> a -> Map k a -> (Maybe a, Map k a)) - -delete :: forall k a. Ord k => k -> MonoidalMap k a -> MonoidalMap k a -delete = coerce (Map.delete :: k -> Map k a -> Map k a) - -adjust :: forall k a. Ord k => (a -> a) -> k -> MonoidalMap k a -> MonoidalMap k a -adjust = coerce (Map.adjust :: (a -> a) -> k -> Map k a -> Map k a) - -adjustWithKey :: forall k a. Ord k => (k -> a -> a) -> k -> MonoidalMap k a -> MonoidalMap k a -adjustWithKey = coerce (Map.adjustWithKey :: (k -> a -> a) -> k -> Map k a -> Map k a) - -update :: forall k a. Ord k => (a -> Maybe a) -> k -> MonoidalMap k a -> MonoidalMap k a -update = coerce (Map.update :: (a -> Maybe a) -> k -> Map k a -> Map k a) - -updateWithKey :: forall k a. Ord k => (k -> a -> Maybe a) -> k -> MonoidalMap k a -> MonoidalMap k a -updateWithKey = coerce (Map.updateWithKey :: (k -> a -> Maybe a) -> k -> Map k a -> Map k a) - -updateLookupWithKey :: forall k a. Ord k => (k -> a -> Maybe a) -> k -> MonoidalMap k a -> (Maybe a, MonoidalMap k a) -updateLookupWithKey = coerce (Map.updateLookupWithKey :: (k -> a -> Maybe a) -> k -> Map k a -> (Maybe a, Map k a)) - -alter :: forall k a. Ord k => (Maybe a -> Maybe a) -> k -> MonoidalMap k a -> MonoidalMap k a -alter = coerce (Map.alter :: (Maybe a -> Maybe a) -> k -> Map k a -> Map k a) - -unionWith :: forall k a. Ord k => (a -> a -> a) -> MonoidalMap k a -> MonoidalMap k a -> MonoidalMap k a -unionWith = coerce (Map.unionWith :: (a -> a -> a) -> Map k a -> Map k a -> Map k a) - -unionWithKey :: forall k a. Ord k => (k -> a -> a -> a) -> MonoidalMap k a -> MonoidalMap k a -> MonoidalMap k a -unionWithKey = coerce (Map.unionWithKey :: (k -> a -> a -> a) -> Map k a -> Map k a -> Map k a) - -unionsWith :: forall k a. Ord k => (a -> a -> a) -> [MonoidalMap k a] -> MonoidalMap k a -unionsWith = coerce (Map.unionsWith :: (a -> a -> a) -> [Map k a] -> Map k a) - -difference :: forall k a b. Ord k => MonoidalMap k a -> MonoidalMap k b -> MonoidalMap k a -difference = (\\) - -differenceWith :: forall k a b. Ord k => (a -> b -> Maybe a) -> MonoidalMap k a -> MonoidalMap k b -> MonoidalMap k a -differenceWith = coerce (Map.differenceWith :: (a -> b -> Maybe a) -> Map k a -> Map k b -> Map k a) - -differenceWithKey :: forall k a b. Ord k => (k -> a -> b -> Maybe a) -> MonoidalMap k a -> MonoidalMap k b -> MonoidalMap k a -differenceWithKey = coerce (Map.differenceWithKey :: (k -> a -> b -> Maybe a) -> Map k a -> Map k b -> Map k a) - -intersectionWith :: forall k a b c. Ord k => (a -> b -> c) -> MonoidalMap k a -> MonoidalMap k b -> MonoidalMap k c -intersectionWith = coerce (Map.intersectionWith :: (a -> b -> c) -> Map k a -> Map k b -> Map k c) - -intersectionWithKey :: forall k a b c. Ord k => (k -> a -> b -> c) -> MonoidalMap k a -> MonoidalMap k b -> MonoidalMap k c -intersectionWithKey = coerce (Map.intersectionWithKey :: (k -> a -> b -> c) -> Map k a -> Map k b -> Map k c) - -mergeWithKey :: forall k a b c. Ord k => (k -> a -> b -> Maybe c) -> (MonoidalMap k a -> MonoidalMap k c) -> (MonoidalMap k b -> MonoidalMap k c) -> MonoidalMap k a -> MonoidalMap k b -> MonoidalMap k c -mergeWithKey = coerce (Map.mergeWithKey :: (k -> a -> b -> Maybe c) -> (Map k a -> Map k c) -> (Map k b -> Map k c) -> Map k a -> Map k b -> Map k c) - -map :: (a -> b) -> MonoidalMap k a -> MonoidalMap k b -map = fmap - -mapWithKey :: (k -> a -> b) -> MonoidalMap k a -> MonoidalMap k b -mapWithKey f (MonoidalMap m) = MonoidalMap $ Map.mapWithKey f m - -traverseWithKey :: Applicative t => (k -> a -> t b) -> MonoidalMap k a -> t (MonoidalMap k b) -traverseWithKey f (MonoidalMap m) = MonoidalMap <$> Map.traverseWithKey f m - -mapAccum :: forall k a b c. (a -> b -> (a, c)) -> a -> MonoidalMap k b -> (a, MonoidalMap k c) -mapAccum = coerce (Map.mapAccum :: (a -> b -> (a, c)) -> a -> Map k b -> (a, Map k c)) - -mapAccumWithKey :: forall k a b c. (a -> k -> b -> (a, c)) -> a -> MonoidalMap k b -> (a, MonoidalMap k c) -mapAccumWithKey = coerce (Map.mapAccumWithKey :: (a -> k -> b -> (a, c)) -> a -> Map k b -> (a, Map k c)) - -mapAccumRWithKey :: forall k a b c. (a -> k -> b -> (a, c)) -> a -> MonoidalMap k b -> (a, MonoidalMap k c) -mapAccumRWithKey = coerce (Map.mapAccumRWithKey :: (a -> k -> b -> (a, c)) -> a -> Map k b -> (a, Map k c)) - -mapKeys :: forall k1 k2 a. Ord k2 => (k1 -> k2) -> MonoidalMap k1 a -> MonoidalMap k2 a -mapKeys = coerce (Map.mapKeys :: (k1 -> k2) -> Map k1 a -> Map k2 a) - -mapKeysWith :: forall k1 k2 a. Ord k2 => (a -> a -> a) -> (k1 -> k2) -> MonoidalMap k1 a -> MonoidalMap k2 a -mapKeysWith = coerce (Map.mapKeysWith :: (a -> a -> a) -> (k1 -> k2) -> Map k1 a -> Map k2 a) - -mapKeysMonotonic :: forall k1 k2 a. (k1 -> k2) -> MonoidalMap k1 a -> MonoidalMap k2 a -mapKeysMonotonic = coerce (Map.mapKeysMonotonic :: (k1 -> k2) -> Map k1 a -> Map k2 a) - -foldr :: forall k a b. (a -> b -> b) -> b -> MonoidalMap k a -> b -foldr = coerce (Map.foldr :: (a -> b -> b) -> b -> Map k a -> b) - -foldl :: forall k a b. (a -> b -> a) -> a -> MonoidalMap k b -> a -foldl = coerce (Map.foldl :: (a -> b -> a) -> a -> Map k b -> a) - -foldrWithKey :: forall k a b. (k -> a -> b -> b) -> b -> MonoidalMap k a -> b -foldrWithKey = coerce (Map.foldrWithKey :: (k -> a -> b -> b) -> b -> Map k a -> b) - -foldlWithKey :: forall k a b. (a -> k -> b -> a) -> a -> MonoidalMap k b -> a -foldlWithKey = coerce (Map.foldlWithKey :: (a -> k -> b -> a) -> a -> Map k b -> a) - -foldMapWithKey :: forall k a m. Monoid m => (k -> a -> m) -> MonoidalMap k a -> m -foldMapWithKey = coerce (Map.foldMapWithKey :: (k -> a -> m) -> Map k a -> m) - -foldr' :: forall k a b. (a -> b -> b) -> b -> MonoidalMap k a -> b -foldr' = coerce (Map.foldr' :: (a -> b -> b) -> b -> Map k a -> b) - -foldl' :: forall k a b. (a -> b -> a) -> a -> MonoidalMap k b -> a -foldl' = coerce (Map.foldl' :: (a -> b -> a) -> a -> Map k b -> a) - -foldrWithKey' :: forall k a b. (k -> a -> b -> b) -> b -> MonoidalMap k a -> b -foldrWithKey' = coerce (Map.foldrWithKey' :: (k -> a -> b -> b) -> b -> Map k a -> b) - -foldlWithKey' :: forall k a b. (a -> k -> b -> a) -> a -> MonoidalMap k b -> a -foldlWithKey' = coerce (Map.foldlWithKey' :: (a -> k -> b -> a) -> a -> Map k b -> a) - -keysSet :: forall k a. MonoidalMap k a -> Set k -keysSet = coerce (Map.keysSet :: Map k a -> Set k) - -fromSet :: forall k a. (k -> a) -> Set k -> MonoidalMap k a -fromSet = coerce (Map.fromSet :: (k -> a) -> Set k -> Map k a) - -toList :: forall k a. MonoidalMap k a -> [(k, a)] -toList = coerce (Map.toList :: Map k a -> [(k, a)]) - -fromList :: forall k a. Ord k => [(k, a)] -> MonoidalMap k a -fromList = coerce (Map.fromList :: [(k, a)] -> Map k a) - -fromListWith :: forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> MonoidalMap k a -fromListWith = coerce (Map.fromListWith :: (a -> a -> a) -> [(k, a)] -> Map k a) - -fromListWithKey :: forall k a. Ord k => (k -> a -> a -> a) -> [(k, a)] -> MonoidalMap k a -fromListWithKey = coerce (Map.fromListWithKey :: (k -> a -> a -> a) -> [(k, a)] -> Map k a) - -toAscList :: forall k a. MonoidalMap k a -> [(k, a)] -toAscList = coerce (Map.toAscList :: Map k a -> [(k, a)]) - -toDescList :: forall k a. MonoidalMap k a -> [(k, a)] -toDescList = coerce (Map.toDescList :: Map k a -> [(k, a)]) - -fromAscList :: forall k a. Eq k => [(k, a)] -> MonoidalMap k a -fromAscList = coerce (Map.fromAscList :: [(k, a)] -> Map k a) - -fromAscListWith :: forall k a. Eq k => (a -> a -> a) -> [(k, a)] -> MonoidalMap k a -fromAscListWith = coerce (Map.fromAscListWith :: (a -> a -> a) -> [(k, a)] -> Map k a) - -fromAscListWithKey :: forall k a. Eq k => (k -> a -> a -> a) -> [(k, a)] -> MonoidalMap k a -fromAscListWithKey = coerce (Map.fromAscListWithKey :: (k -> a -> a -> a) -> [(k, a)] -> Map k a) - -fromDistinctAscList :: forall k a. [(k, a)] -> MonoidalMap k a -fromDistinctAscList = coerce (Map.fromDistinctAscList :: [(k, a)] -> Map k a) - -filter :: forall k a. (a -> Bool) -> MonoidalMap k a -> MonoidalMap k a -filter = coerce (Map.filter :: (a -> Bool) -> Map k a -> Map k a) - -filterWithKey :: forall k a. (k -> a -> Bool) -> MonoidalMap k a -> MonoidalMap k a -filterWithKey = coerce (Map.filterWithKey :: (k -> a -> Bool) -> Map k a -> Map k a) - -partition :: forall k a. (a -> Bool) -> MonoidalMap k a -> (MonoidalMap k a, MonoidalMap k a) -partition = coerce (Map.partition :: (a -> Bool) -> Map k a -> (Map k a, Map k a)) - -partitionWithKey :: forall k a. (k -> a -> Bool) -> MonoidalMap k a -> (MonoidalMap k a, MonoidalMap k a) -partitionWithKey = coerce (Map.partitionWithKey :: (k -> a -> Bool) -> Map k a -> (Map k a, Map k a)) - -mapMaybe :: forall k a b. (a -> Maybe b) -> MonoidalMap k a -> MonoidalMap k b -mapMaybe = coerce (Map.mapMaybe :: (a -> Maybe b) -> Map k a -> Map k b) - -mapMaybeWithKey :: forall k a b. (k -> a -> Maybe b) -> MonoidalMap k a -> MonoidalMap k b -mapMaybeWithKey = coerce (Map.mapMaybeWithKey :: (k -> a -> Maybe b) -> Map k a -> Map k b) - -mapEither :: forall k a b c. (a -> Either b c) -> MonoidalMap k a -> (MonoidalMap k b, MonoidalMap k c) -mapEither = coerce (Map.mapEither :: (a -> Either b c) -> Map k a -> (Map k b, Map k c)) - -mapEitherWithKey :: forall k a b c. (k -> a -> Either b c) -> MonoidalMap k a -> (MonoidalMap k b, MonoidalMap k c) -mapEitherWithKey = coerce (Map.mapEitherWithKey :: (k -> a -> Either b c) -> Map k a -> (Map k b, Map k c)) - -split :: forall k a. Ord k => k -> MonoidalMap k a -> (MonoidalMap k a, MonoidalMap k a) -split = coerce (Map.split :: k -> Map k a -> (Map k a, Map k a)) - -splitLookup :: forall k a. Ord k => k -> MonoidalMap k a -> (MonoidalMap k a, Maybe a, MonoidalMap k a) -splitLookup = coerce (Map.splitLookup :: k -> Map k a -> (Map k a, Maybe a, Map k a)) - -splitRoot :: forall k a. MonoidalMap k a -> [MonoidalMap k a] -splitRoot = coerce (Map.splitRoot :: Map k a -> [Map k a]) - -isSubmapOf :: forall k a. (Ord k, Eq a) => MonoidalMap k a -> MonoidalMap k a -> Bool -isSubmapOf = coerce (Map.isSubmapOf :: Map k a -> Map k a -> Bool) - -isSubmapOfBy :: forall k a b. Ord k => (a -> b -> Bool) -> MonoidalMap k a -> MonoidalMap k b -> Bool -isSubmapOfBy = coerce (Map.isSubmapOfBy :: (a -> b -> Bool) -> Map k a -> Map k b -> Bool) - -isProperSubmapOf :: forall k a. (Ord k, Eq a) => MonoidalMap k a -> MonoidalMap k a -> Bool -isProperSubmapOf = coerce (Map.isProperSubmapOf :: Map k a -> Map k a -> Bool) - -isProperSubmapOfBy :: forall k a b. Ord k => (a -> b -> Bool) -> MonoidalMap k a -> MonoidalMap k b -> Bool -isProperSubmapOfBy = coerce (Map.isProperSubmapOfBy :: (a -> b -> Bool) -> Map k a -> Map k b -> Bool) - -lookupIndex :: forall k a. Ord k => k -> MonoidalMap k a -> Maybe Int -lookupIndex = coerce (Map.lookupIndex :: k -> Map k a -> Maybe Int) - -findIndex :: forall k a. Ord k => k -> MonoidalMap k a -> Int -findIndex = coerce (Map.findIndex :: k -> Map k a -> Int) - -elemAt :: forall k a. Int -> MonoidalMap k a -> (k, a) -elemAt = coerce (Map.elemAt :: Int -> Map k a -> (k, a)) - -updateAt :: forall k a. (k -> a -> Maybe a) -> Int -> MonoidalMap k a -> MonoidalMap k a -updateAt = coerce (Map.updateAt :: (k -> a -> Maybe a) -> Int -> Map k a -> Map k a) - -deleteAt :: forall k a. Int -> MonoidalMap k a -> MonoidalMap k a -deleteAt = coerce (Map.deleteAt :: Int -> Map k a -> Map k a) - -findMin :: forall k a. MonoidalMap k a -> (k, a) -findMin = coerce (Map.findMin :: Map k a -> (k, a)) - -findMax :: forall k a. MonoidalMap k a -> (k, a) -findMax = coerce (Map.findMax :: Map k a -> (k, a)) - -deleteMin :: forall k a. MonoidalMap k a -> MonoidalMap k a -deleteMin = coerce (Map.deleteMin :: Map k a -> Map k a) - -deleteMax :: forall k a. MonoidalMap k a -> MonoidalMap k a -deleteMax = coerce (Map.deleteMax :: Map k a -> Map k a) - -deleteFindMin :: forall k a. MonoidalMap k a -> ((k, a), MonoidalMap k a) -deleteFindMin = coerce (Map.deleteFindMin :: Map k a -> ((k, a), Map k a)) - -deleteFindMax :: forall k a. MonoidalMap k a -> ((k, a), MonoidalMap k a) -deleteFindMax = coerce (Map.deleteFindMax :: Map k a -> ((k, a), Map k a)) - -updateMin :: forall k a. (a -> Maybe a) -> MonoidalMap k a -> MonoidalMap k a -updateMin = coerce (Map.updateMin :: (a -> Maybe a) -> Map k a -> Map k a) - -updateMax :: forall k a. (a -> Maybe a) -> MonoidalMap k a -> MonoidalMap k a -updateMax = coerce (Map.updateMax :: (a -> Maybe a) -> Map k a -> Map k a) - -updateMinWithKey :: forall k a. (k -> a -> Maybe a) -> MonoidalMap k a -> MonoidalMap k a -updateMinWithKey = coerce (Map.updateMinWithKey :: (k -> a -> Maybe a) -> Map k a -> Map k a) - -updateMaxWithKey :: forall k a. (k -> a -> Maybe a) -> MonoidalMap k a -> MonoidalMap k a -updateMaxWithKey = coerce (Map.updateMaxWithKey :: (k -> a -> Maybe a) -> Map k a -> Map k a) - -minView :: forall k a. MonoidalMap k a -> Maybe (a, MonoidalMap k a) -minView = coerce (Map.minView :: Map k a -> Maybe (a, Map k a)) - -maxView :: forall k a. MonoidalMap k a -> Maybe (a, MonoidalMap k a) -maxView = coerce (Map.maxView :: Map k a -> Maybe (a, Map k a)) - -minViewWithKey :: forall k a. MonoidalMap k a -> Maybe ((k, a), MonoidalMap k a) -minViewWithKey = coerce (Map.minViewWithKey :: Map k a -> Maybe ((k, a), Map k a)) - -maxViewWithKey :: forall k a. MonoidalMap k a -> Maybe ((k, a), MonoidalMap k a) -maxViewWithKey = coerce (Map.maxViewWithKey :: Map k a -> Maybe ((k, a), Map k a)) - showTree :: forall k a. (Show k, Show a) => MonoidalMap k a -> String showTree = coerce (Map.showTree :: Map k a -> String) showTreeWith :: forall k a. (k -> a -> String) -> Bool -> Bool -> MonoidalMap k a -> String showTreeWith = coerce (Map.showTreeWith :: (k -> a -> String) -> Bool -> Bool -> Map k a -> String) -valid :: forall k a. Ord k => MonoidalMap k a -> Bool -valid = coerce (Map.valid :: Map k a -> Bool) - instance Default (MonoidalMap k a) where def = empty From d49708dba2eabb2635d6f774a30802d9378e1c24 Mon Sep 17 00:00:00 2001 From: John Ericson Date: Fri, 17 Aug 2018 20:03:15 -0400 Subject: [PATCH 021/241] Derive more newtype instances for ProfiledM Put the "deriving" clause on its own line for easier diffing, so we can make sure these don't get out of sync. --- src/Reflex/Profiled.hs | 4 +++- src/Reflex/Spider/Internal.hs | 3 ++- 2 files changed, 5 insertions(+), 2 deletions(-) diff --git a/src/Reflex/Profiled.hs b/src/Reflex/Profiled.hs index 9a43467e..38330f67 100644 --- a/src/Reflex/Profiled.hs +++ b/src/Reflex/Profiled.hs @@ -11,6 +11,7 @@ module Reflex.Profiled where import Control.Lens hiding (children) import Control.Monad +import Control.Monad.Exception import Control.Monad.Fix import Control.Monad.Primitive import Control.Monad.Reader @@ -95,7 +96,8 @@ writeProfilingData :: FilePath -> IO () writeProfilingData p = do writeFile p =<< formatCostCentreTree =<< getCostCentreTree -newtype ProfiledM m a = ProfiledM { runProfiledM :: m a } deriving (Functor, Applicative, Monad, MonadFix) +newtype ProfiledM m a = ProfiledM { runProfiledM :: m a } + deriving (Functor, Applicative, Monad, MonadFix, MonadException, MonadAsyncException) profileEvent :: Reflex t => Event t a -> Event t a profileEvent e = unsafePerformIO $ do diff --git a/src/Reflex/Spider/Internal.hs b/src/Reflex/Spider/Internal.hs index c1109976..57022976 100644 --- a/src/Reflex/Spider/Internal.hs +++ b/src/Reflex/Spider/Internal.hs @@ -2408,7 +2408,8 @@ runSpiderHostForTimeline :: SpiderHost x a -> SpiderTimelineEnv x -> IO a runSpiderHostForTimeline (SpiderHost a) = runReaderT a #endif -newtype SpiderHostFrame x a = SpiderHostFrame { runSpiderHostFrame :: EventM x a } deriving (Functor, Applicative, MonadFix, MonadIO, MonadException, MonadAsyncException) +newtype SpiderHostFrame x a = SpiderHostFrame { runSpiderHostFrame :: EventM x a } + deriving (Functor, Applicative, MonadFix, MonadIO, MonadException, MonadAsyncException) instance Monad (SpiderHostFrame x) where {-# INLINABLE (>>=) #-} From bd07448202884834c20174b9740a1714dd07af21 Mon Sep 17 00:00:00 2001 From: Ken Micklas Date: Fri, 24 Aug 2018 15:49:00 -0400 Subject: [PATCH 022/241] Add default for traverseDMapWithKeyWithAdjust in terms of traverseDMapWithKeyWithAdjustWithMove --- src/Reflex/Adjustable/Class.hs | 44 ++++++++++++++++++++++++++++++---- 1 file changed, 40 insertions(+), 4 deletions(-) diff --git a/src/Reflex/Adjustable/Class.hs b/src/Reflex/Adjustable/Class.hs index 57a1bcbd..6fbeff45 100644 --- a/src/Reflex/Adjustable/Class.hs +++ b/src/Reflex/Adjustable/Class.hs @@ -2,6 +2,7 @@ {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -24,6 +25,7 @@ module Reflex.Adjustable.Class import Control.Monad.Identity import Control.Monad.Reader import Data.Dependent.Map (DMap, GCompare (..)) +import qualified Data.Dependent.Map as DMap import Data.Functor.Constant import Data.Functor.Misc import Data.IntMap.Strict (IntMap) @@ -31,6 +33,7 @@ import qualified Data.IntMap.Strict as IntMap import Data.Map (Map) import Reflex.Class +import Reflex.Patch.DMapWithMove -- | A 'Monad' that supports adjustment over time. After an action has been -- run, if the given events fire, it will adjust itself so that its net effect @@ -39,10 +42,43 @@ import Reflex.Class -- other side-effects) cannot be undone, so it is up to the instance implementer -- to determine what the best meaning for this class is in such cases. class (Reflex t, Monad m) => Adjustable t m | m -> t where - runWithReplace :: m a -> Event t (m b) -> m (a, Event t b) - traverseIntMapWithKeyWithAdjust :: (IntMap.Key -> v -> m v') -> IntMap v -> Event t (PatchIntMap v) -> m (IntMap v', Event t (PatchIntMap v')) - traverseDMapWithKeyWithAdjust :: GCompare k => (forall a. k a -> v a -> m (v' a)) -> DMap k v -> Event t (PatchDMap k v) -> m (DMap k v', Event t (PatchDMap k v')) - traverseDMapWithKeyWithAdjustWithMove :: GCompare k => (forall a. k a -> v a -> m (v' a)) -> DMap k v -> Event t (PatchDMapWithMove k v) -> m (DMap k v', Event t (PatchDMapWithMove k v')) + runWithReplace + :: m a + -> Event t (m b) + -> m (a, Event t b) + + traverseIntMapWithKeyWithAdjust + :: (IntMap.Key -> v -> m v') + -> IntMap v + -> Event t (PatchIntMap v) + -> m (IntMap v', Event t (PatchIntMap v')) + + traverseDMapWithKeyWithAdjust + :: GCompare k + => (forall a. k a -> v a -> m (v' a)) + -> DMap k v + -> Event t (PatchDMap k v) + -> m (DMap k v', Event t (PatchDMap k v')) + {-# INLINABLE traverseDMapWithKeyWithAdjust #-} + traverseDMapWithKeyWithAdjust f dm0 dm' = fmap (fmap (fmap fromPatchWithMove)) $ + traverseDMapWithKeyWithAdjustWithMove f dm0 $ fmap toPatchWithMove dm' + where + toPatchWithMove (PatchDMap m) = PatchDMapWithMove $ DMap.map toNodeInfoWithMove m + toNodeInfoWithMove = \case + ComposeMaybe (Just v) -> NodeInfo (From_Insert v) $ ComposeMaybe Nothing + ComposeMaybe Nothing -> NodeInfo From_Delete $ ComposeMaybe Nothing + fromPatchWithMove (PatchDMapWithMove m) = PatchDMap $ DMap.map fromNodeInfoWithMove m + fromNodeInfoWithMove (NodeInfo from _) = ComposeMaybe $ case from of + From_Insert v -> Just v + From_Delete -> Nothing + From_Move _ -> error "traverseDMapWithKeyWithAdjust: implementation of traverseDMapWithKeyWithAdjustWithMove inserted spurious move" + + traverseDMapWithKeyWithAdjustWithMove + :: GCompare k + => (forall a. k a -> v a -> m (v' a)) + -> DMap k v + -> Event t (PatchDMapWithMove k v) + -> m (DMap k v', Event t (PatchDMapWithMove k v')) instance Adjustable t m => Adjustable t (ReaderT r m) where runWithReplace a0 a' = do From 06ba50db10cc37ef100366a556208b46991def9f Mon Sep 17 00:00:00 2001 From: Ryan Trinkle Date: Sun, 26 Aug 2018 13:46:43 -0400 Subject: [PATCH 023/241] Add `composePatchFunctions` --- src/Reflex/Patch/Class.hs | 12 ++++++++++++ 1 file changed, 12 insertions(+) diff --git a/src/Reflex/Patch/Class.hs b/src/Reflex/Patch/Class.hs index 0c934f0b..233af16f 100644 --- a/src/Reflex/Patch/Class.hs +++ b/src/Reflex/Patch/Class.hs @@ -4,8 +4,12 @@ module Reflex.Patch.Class where import Control.Monad.Identity import Data.Maybe +import Data.Semigroup -- | A 'Patch' type represents a kind of change made to a datastructure. +-- +-- If an instance of 'Patch' is also an instance of 'Semigroup', it should obey +-- the law that @applyAlways (f <> g) == applyAlways f . applyAlways g@. class Patch p where type PatchTarget p :: * -- | Apply the patch @p a@ to the value @a@. If no change is needed, return @@ -20,3 +24,11 @@ applyAlways p t = fromMaybe t $ apply p t instance Patch (Identity a) where type PatchTarget (Identity a) = a apply (Identity a) _ = Just a + +-- | Like '(.)', but composes functions that return patches rather than +-- functions that return new values. The Semigroup instance for patches must +-- apply patches right-to-left, like '(.)'. +composePatchFunctions :: (Patch p, Semigroup p) => (PatchTarget p -> p) -> (PatchTarget p -> p) -> PatchTarget p -> p +composePatchFunctions g f a = + let fp = f a + in g (applyAlways fp a) <> fp From e3e509a58aef2743b19e26d941d93748eeb401cc Mon Sep 17 00:00:00 2001 From: Ryan Trinkle Date: Sun, 26 Aug 2018 13:46:53 -0400 Subject: [PATCH 024/241] Add patchMapWithMoveInsertAll --- src/Reflex/Patch/MapWithMove.hs | 7 +++++++ 1 file changed, 7 insertions(+) diff --git a/src/Reflex/Patch/MapWithMove.hs b/src/Reflex/Patch/MapWithMove.hs index 3d60b067..4777c699 100644 --- a/src/Reflex/Patch/MapWithMove.hs +++ b/src/Reflex/Patch/MapWithMove.hs @@ -48,6 +48,13 @@ patchMapWithMove m = if valid then Just $ PatchMapWithMove m else Nothing From_Move from -> Just (from, to) _ -> Nothing +-- | Create a 'PatchMapWithMove' that inserts everything in the given 'Map' +patchMapWithMoveInsertAll :: Map k v -> PatchMapWithMove k v +patchMapWithMoveInsertAll m = PatchMapWithMove $ flip fmap m $ \v -> NodeInfo + { _nodeInfo_from = From_Insert v + , _nodeInfo_to = Nothing + } + -- | Extract the internal representation of the 'PatchMapWithMove' unPatchMapWithMove :: PatchMapWithMove k v -> Map k (NodeInfo k v) unPatchMapWithMove (PatchMapWithMove p) = p From 9c3c19564c4925285b066435a5a7b85478323af4 Mon Sep 17 00:00:00 2001 From: Ryan Trinkle Date: Sun, 26 Aug 2018 13:47:03 -0400 Subject: [PATCH 025/241] Add accum functions for Incrementals --- src/Reflex/Class.hs | 37 +++++++++++++++++++++++++++++++++++++ 1 file changed, 37 insertions(+) diff --git a/src/Reflex/Class.hs b/src/Reflex/Class.hs index c4bae6f4..cbfb1c3b 100644 --- a/src/Reflex/Class.hs +++ b/src/Reflex/Class.hs @@ -102,6 +102,14 @@ module Reflex.Class , mapAccumM_ , mapAccumMaybe_ , mapAccumMaybeM_ + , accumIncremental + , accumMIncremental + , accumMaybeIncremental + , accumMaybeMIncremental + , mapAccumIncremental + , mapAccumMIncremental + , mapAccumMaybeIncremental + , mapAccumMaybeMIncremental , zipListWithEvent , numberOccurrences , numberOccurrencesFrom @@ -348,6 +356,35 @@ class MonadSample t m => MonadHold t m where -- the supplied 'Event'. headE :: Event t a -> m (Event t a) +accumIncremental :: (Reflex t, Patch p, MonadHold t m, MonadFix m) => (PatchTarget p -> b -> p) -> PatchTarget p -> Event t b -> m (Incremental t p) +accumIncremental f = accumMaybeIncremental $ \v o -> Just $ f v o +accumMIncremental :: (Reflex t, Patch p, MonadHold t m, MonadFix m) => (PatchTarget p -> b -> PushM t p) -> PatchTarget p -> Event t b -> m (Incremental t p) +accumMIncremental f = accumMaybeMIncremental $ \v o -> Just <$> f v o +accumMaybeIncremental :: (Reflex t, Patch p, MonadHold t m, MonadFix m) => (PatchTarget p -> b -> Maybe p) -> PatchTarget p -> Event t b -> m (Incremental t p) +accumMaybeIncremental f = accumMaybeMIncremental $ \v o -> return $ f v o +accumMaybeMIncremental :: (Reflex t, Patch p, MonadHold t m, MonadFix m) => (PatchTarget p -> b -> PushM t (Maybe p)) -> PatchTarget p -> Event t b -> m (Incremental t p) +accumMaybeMIncremental f z e = do + rec let e' = flip push e $ \o -> do + v <- sample $ currentIncremental d' + f v o + d' <- holdIncremental z e' + return d' +mapAccumIncremental :: (Reflex t, Patch p, MonadHold t m, MonadFix m) => (PatchTarget p -> b -> (p, c)) -> PatchTarget p -> Event t b -> m (Incremental t p, Event t c) +mapAccumIncremental f = mapAccumMaybeIncremental $ \v o -> bimap Just Just $ f v o +mapAccumMIncremental :: (Reflex t, Patch p, MonadHold t m, MonadFix m) => (PatchTarget p -> b -> PushM t (p, c)) -> PatchTarget p -> Event t b -> m (Incremental t p, Event t c) +mapAccumMIncremental f = mapAccumMaybeMIncremental $ \v o -> bimap Just Just <$> f v o +mapAccumMaybeIncremental :: (Reflex t, Patch p, MonadHold t m, MonadFix m) => (PatchTarget p -> b -> (Maybe p, Maybe c)) -> PatchTarget p -> Event t b -> m (Incremental t p, Event t c) +mapAccumMaybeIncremental f = mapAccumMaybeMIncremental $ \v o -> return $ f v o +mapAccumMaybeMIncremental :: (Reflex t, Patch p, MonadHold t m, MonadFix m) => (PatchTarget p -> b -> PushM t (Maybe p, Maybe c)) -> PatchTarget p -> Event t b -> m (Incremental t p, Event t c) +mapAccumMaybeMIncremental f z e = do + rec let e' = flip push e $ \o -> do + v <- sample $ currentIncremental d' + result <- f v o + return $ case result of + (Nothing, Nothing) -> Nothing + _ -> Just result + d' <- holdIncremental z $ fmapMaybe fst e' + return (d', fmapMaybe snd e') slowHeadE :: (Reflex t, MonadHold t m, MonadFix m) => Event t a -> m (Event t a) slowHeadE e = do From 09bcdcf44ec99ce152f2bb814fc25066a93a92ad Mon Sep 17 00:00:00 2001 From: Ryan Trinkle Date: Sun, 26 Aug 2018 14:06:18 -0400 Subject: [PATCH 026/241] Fix hlint --- src/Reflex/Query/Base.hs | 8 ++++---- test/hlint.hs | 1 + 2 files changed, 5 insertions(+), 4 deletions(-) diff --git a/src/Reflex/Query/Base.hs b/src/Reflex/Query/Base.hs index 729988b7..971c95af 100644 --- a/src/Reflex/Query/Base.hs +++ b/src/Reflex/Query/Base.hs @@ -102,14 +102,14 @@ instance (Reflex t, MonadFix m, Group q, Additive q, Query q, MonadHold t m, Adj let f' :: IntMap.Key -> v -> EventWriterT t q (ReaderT (Dynamic t (QueryResult q)) m) (QueryTLoweredResult t q v') f' k v = fmap QueryTLoweredResult $ flip runStateT [] $ unQueryT $ f k v (result0, result') <- QueryT $ lift $ traverseIntMapWithKeyWithAdjust f' im0 im' - let liftedResult0 = IntMap.map (\r -> getQueryTLoweredResultValue r) result0 + let liftedResult0 = IntMap.map getQueryTLoweredResultValue result0 liftedResult' = fforCheap result' $ \(PatchIntMap p) -> PatchIntMap $ - IntMap.map (\mr -> fmap getQueryTLoweredResultValue mr) p + IntMap.map (fmap getQueryTLoweredResultValue) p liftedBs0 :: IntMap [Behavior t q] - liftedBs0 = IntMap.map (\r -> getQueryTLoweredResultWritten r) result0 + liftedBs0 = IntMap.map getQueryTLoweredResultWritten result0 liftedBs' :: Event t (PatchIntMap [Behavior t q]) liftedBs' = fforCheap result' $ \(PatchIntMap p) -> PatchIntMap $ - IntMap.map (\mr -> fmap getQueryTLoweredResultWritten mr) p + IntMap.map (fmap getQueryTLoweredResultWritten) p sampleBs :: forall m'. MonadSample t m' => [Behavior t q] -> m' q sampleBs = foldlM (\b a -> (b <>) <$> sample a) mempty accumBehaviors :: forall m'. MonadHold t m' diff --git a/test/hlint.hs b/test/hlint.hs index 85840556..f8b80def 100644 --- a/test/hlint.hs +++ b/test/hlint.hs @@ -20,6 +20,7 @@ main = do , "--ignore=Use >=>" , "--ignore=Use ." , "--ignore=Use unless" + , "--ignore=Reduce duplication" , "--cpp-define=USE_TEMPLATE_HASKELL" ] recurseInto = and <$> sequence From b32839309c144af99cd2d984ad6822c607f03e18 Mon Sep 17 00:00:00 2001 From: Ryan Trinkle Date: Sun, 26 Aug 2018 15:06:13 -0400 Subject: [PATCH 027/241] Implement Monoid PatchMapWithMove --- src/Reflex/Patch/MapWithMove.hs | 61 +++++++++++++++++++++++++++++++++ 1 file changed, 61 insertions(+) diff --git a/src/Reflex/Patch/MapWithMove.hs b/src/Reflex/Patch/MapWithMove.hs index 4777c699..58feffa2 100644 --- a/src/Reflex/Patch/MapWithMove.hs +++ b/src/Reflex/Patch/MapWithMove.hs @@ -3,6 +3,7 @@ {-# LANGUAGE DeriveTraversable #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE LambdaCase #-} +{-# LANGUAGE PatternGuards #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} -- | 'Patch'es on 'Map' that can insert, delete, and move values from one key to @@ -19,7 +20,9 @@ import Data.List import Data.Map (Map) import qualified Data.Map as Map import Data.Maybe +import Data.Semigroup import qualified Data.Set as Set +import Data.These import Data.Tuple -- | Patch a DMap with additions, deletions, and moves. Invariant: If key @k1@ @@ -161,3 +164,61 @@ nodeInfoMapMFrom f ni = fmap (\result -> ni { _nodeInfo_from = result }) $ f $ _ -- | Set the 'To' field of a 'NodeInfo' nodeInfoSetTo :: To k -> NodeInfo k v -> NodeInfo k v nodeInfoSetTo to ni = ni { _nodeInfo_to = to } + +-- |Helper data structure used for composing patches using the monoid instance. +data Fixup k v + = Fixup_Delete + | Fixup_Update (These (From k v) (To k)) + +-- |Compose patches having the same effect as applying the patches in turn: @'applyAlways' (p <> q) == 'applyAlways' p . 'applyAlways' q@ +instance Ord k => Semigroup (PatchMapWithMove k v) where + PatchMapWithMove ma <> PatchMapWithMove mb = PatchMapWithMove m + where + connections = Map.toList $ Map.intersectionWithKey (\_ a b -> (_nodeInfo_to a, _nodeInfo_from b)) ma mb + h :: (k, (Maybe k, From k v)) -> [(k, Fixup k v)] + h (_, (mToAfter, editBefore)) = case (mToAfter, editBefore) of + (Just toAfter, From_Move fromBefore) + | fromBefore == toAfter + -> [(toAfter, Fixup_Delete)] + | otherwise + -> [ (toAfter, Fixup_Update (This editBefore)) + , (fromBefore, Fixup_Update (That mToAfter)) + ] + (Nothing, From_Move fromBefore) -> [(fromBefore, Fixup_Update (That mToAfter))] -- The item is destroyed in the second patch, so indicate that it is destroyed in the source map + (Just toAfter, _) -> [(toAfter, Fixup_Update (This editBefore))] + (Nothing, _) -> [] + mergeFixups _ Fixup_Delete Fixup_Delete = Fixup_Delete + mergeFixups _ (Fixup_Update a) (Fixup_Update b) + | This x <- a, That y <- b + = Fixup_Update $ These x y + | That y <- a, This x <- b + = Fixup_Update $ These x y + mergeFixups _ _ _ = error "PatchMapWithMove: incompatible fixups" + fixups = Map.fromListWithKey mergeFixups $ concatMap h connections + combineNodeInfos _ nia nib = NodeInfo + { _nodeInfo_from = _nodeInfo_from nia + , _nodeInfo_to = _nodeInfo_to nib + } + applyFixup _ ni = \case + Fixup_Delete -> Nothing + Fixup_Update u -> Just $ NodeInfo + { _nodeInfo_from = fromMaybe (_nodeInfo_from ni) $ getHere u + , _nodeInfo_to = fromMaybe (_nodeInfo_to ni) $ getThere u + } + m = Map.differenceWithKey applyFixup (Map.unionWithKey combineNodeInfos ma mb) fixups + getHere :: These a b -> Maybe a + getHere = \case + This a -> Just a + These a _ -> Just a + That _ -> Nothing + getThere :: These a b -> Maybe b + getThere = \case + This _ -> Nothing + These _ b -> Just b + That b -> Just b + +--TODO: Figure out how to implement this in terms of PatchDMapWithMove rather than duplicating it here +-- |Compose patches having the same effect as applying the patches in turn: @'applyAlways' (p <> q) == 'applyAlways' p . 'applyAlways' q@ +instance Ord k => Monoid (PatchMapWithMove k v) where + mempty = PatchMapWithMove mempty + mappend = (<>) From 019b5695a18a176ad7470ffb4d71a56b6331ffb5 Mon Sep 17 00:00:00 2001 From: Ryan Trinkle Date: Sun, 26 Aug 2018 15:06:28 -0400 Subject: [PATCH 028/241] Minor cleanup for Monoid PatchDMapWithMove --- src/Reflex/Patch/DMapWithMove.hs | 36 ++++++++++++++------------------ 1 file changed, 16 insertions(+), 20 deletions(-) diff --git a/src/Reflex/Patch/DMapWithMove.hs b/src/Reflex/Patch/DMapWithMove.hs index b29e698f..42e2e2de 100644 --- a/src/Reflex/Patch/DMapWithMove.hs +++ b/src/Reflex/Patch/DMapWithMove.hs @@ -110,19 +110,14 @@ instance EqTag k (NodeInfo k v) => Eq (PatchDMapWithMove k v) where -- |Higher kinded 2-tuple, identical to @Data.Functor.Product@ from base ≥ 4.9 data Pair1 f g a = Pair1 (f a) (g a) --- |Compose patches having the same effect as applying the patches in turn: @'applyAlways' (p <> q) == 'applyAlways' p . 'applyAlways' q@ -instance GCompare k => Semigroup (PatchDMapWithMove k v) where - (<>) = mappend - -- |Helper data structure used for composing patches using the monoid instance. data Fixup k v a = Fixup_Delete | Fixup_Update (These (From k v a) (To k a)) -- |Compose patches having the same effect as applying the patches in turn: @'applyAlways' (p <> q) == 'applyAlways' p . 'applyAlways' q@ -instance GCompare k => Monoid (PatchDMapWithMove k v) where - mempty = PatchDMapWithMove mempty - PatchDMapWithMove ma `mappend` PatchDMapWithMove mb = PatchDMapWithMove m +instance GCompare k => Semigroup (PatchDMapWithMove k v) where + PatchDMapWithMove ma <> PatchDMapWithMove mb = PatchDMapWithMove m where connections = DMap.toList $ DMap.intersectionWithKey (\_ a b -> Pair1 (_nodeInfo_to a) (_nodeInfo_from b)) ma mb h :: DSum k (Pair1 (ComposeMaybe k) (From k v)) -> [DSum k (Fixup k v)] @@ -156,20 +151,21 @@ instance GCompare k => Monoid (PatchDMapWithMove k v) where , _nodeInfo_to = fromMaybe (_nodeInfo_to ni) $ getThere u } m = DMap.differenceWithKey applyFixup (DMap.unionWithKey combineNodeInfos ma mb) fixups + getHere :: These a b -> Maybe a + getHere = \case + This a -> Just a + These a _ -> Just a + That _ -> Nothing + getThere :: These a b -> Maybe b + getThere = \case + This _ -> Nothing + These _ b -> Just b + That b -> Just b --- |Project the @a@ from a @'These' a b@, identical to @preview '_Here'@ but without using preview -getHere :: These a b -> Maybe a -getHere = \case - This a -> Just a - These a _ -> Just a - That _ -> Nothing - --- |Project the @b@ from a @'These' a b@, identical to @preview '_There'@ but without using preview -getThere :: These a b -> Maybe b -getThere = \case - This _ -> Nothing - These _ b -> Just b - That b -> Just b +-- |Compose patches having the same effect as applying the patches in turn: @'applyAlways' (p <> q) == 'applyAlways' p . 'applyAlways' q@ +instance GCompare k => Monoid (PatchDMapWithMove k v) where + mempty = PatchDMapWithMove mempty + mappend = (<>) {- mappendPatchDMapWithMoveSlow :: forall k v. (ShowTag k v, GCompare k) => PatchDMapWithMove k v -> PatchDMapWithMove k v -> PatchDMapWithMove k v From 5fbef383a3c377d64d2774d5eec1e5f213d85164 Mon Sep 17 00:00:00 2001 From: Doug Beardsley Date: Sun, 26 Aug 2018 19:41:57 -0400 Subject: [PATCH 029/241] Generalize patchThatChangesAndSortsMapWith --- src/Reflex/Patch/MapWithMove.hs | 12 ++++++++---- 1 file changed, 8 insertions(+), 4 deletions(-) diff --git a/src/Reflex/Patch/MapWithMove.hs b/src/Reflex/Patch/MapWithMove.hs index 58feffa2..aab9693d 100644 --- a/src/Reflex/Patch/MapWithMove.hs +++ b/src/Reflex/Patch/MapWithMove.hs @@ -120,11 +120,15 @@ patchThatSortsMapWith cmp m = PatchMapWithMove $ Map.fromList $ catMaybes $ zipW -- will produce a 'Map' with the same values as the second 'Map' but with the -- values sorted with the given ordering function. patchThatChangesAndSortsMapWith :: forall k v. (Ord k, Ord v) => (v -> v -> Ordering) -> Map k v -> Map k v -> PatchMapWithMove k v -patchThatChangesAndSortsMapWith cmp oldByIndex newByIndexUnsorted = patch - where oldByValue = Map.fromListWith Set.union $ swap . first Set.singleton <$> Map.toList oldByIndex - newList = Map.toList newByIndexUnsorted +patchThatChangesAndSortsMapWith cmp oldByIndex newByIndexUnsorted = patchThatChangesMap oldByIndex newByIndex + where newList = Map.toList newByIndexUnsorted newByIndex = Map.fromList $ zip (fst <$> newList) $ sortBy cmp $ snd <$> newList - insertsAndMoves :: Map k (NodeInfo k v) + +-- | Create a 'PatchMapWithMove' that, if applied to the first 'Map' provided, +-- will produce the second 'Map'. +patchThatChangesMap :: (Ord k, Ord v) => Map k v -> Map k v -> PatchMapWithMove k v +patchThatChangesMap oldByIndex newByIndex = patch + where oldByValue = Map.fromListWith Set.union $ swap . first Set.singleton <$> Map.toList oldByIndex (insertsAndMoves, unusedValuesByValue) = flip runState oldByValue $ do let f k v = do remainingValues <- get From 19c1263c5c249e579fea78bb5769dc0d708777a8 Mon Sep 17 00:00:00 2001 From: Cale Gibbard Date: Mon, 3 Sep 2018 21:58:27 -0400 Subject: [PATCH 030/241] Align instance moved to monoidal-containers --- reflex.cabal | 2 +- src/Data/AppendMap.hs | 5 ----- 2 files changed, 1 insertion(+), 6 deletions(-) diff --git a/reflex.cabal b/reflex.cabal index b0bc23b1..6c5fe6f0 100644 --- a/reflex.cabal +++ b/reflex.cabal @@ -46,7 +46,7 @@ library exception-transformers == 0.4.*, lens >= 4.7 && < 5, monad-control >= 1.0.1 && < 1.1, - monoidal-containers == 0.4.*, + monoidal-containers == 0.5.*, mtl >= 2.1 && < 2.3, prim-uniq >= 0.1.0.1 && < 0.2, primitive >= 0.5 && < 0.7, diff --git a/src/Data/AppendMap.hs b/src/Data/AppendMap.hs index e903115d..b3b0caa1 100644 --- a/src/Data/AppendMap.hs +++ b/src/Data/AppendMap.hs @@ -23,14 +23,11 @@ module Data.AppendMap import Prelude hiding (map, null) -import Data.Align import Data.Coerce import Data.Default import Data.Map (Map) import qualified Data.Map as Map import Data.Map.Monoidal -import Data.Semigroup -import Data.Set (Set) import Reflex.Class (FunctorMaybe (..)) import Reflex.Patch (Additive, Group (..)) @@ -44,8 +41,6 @@ _unAppendMap = getMonoidalMap pattern AppendMap :: Map k v -> MonoidalMap k v pattern AppendMap m = MonoidalMap m -deriving instance Ord k => Align (MonoidalMap k) - instance FunctorMaybe (MonoidalMap k) where fmapMaybe = mapMaybe From d2824719c721787b092b16f29ec390fa9120aa17 Mon Sep 17 00:00:00 2001 From: Alexandre Esteves Date: Sun, 16 Sep 2018 20:38:03 +0100 Subject: [PATCH 031/241] Fix typo: relavant -> relevant --- test/Reflex/Plan/Pure.hs | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/test/Reflex/Plan/Pure.hs b/test/Reflex/Plan/Pure.hs index a595b811..65731627 100644 --- a/test/Reflex/Plan/Pure.hs +++ b/test/Reflex/Plan/Pure.hs @@ -55,15 +55,15 @@ instance TestPlan (Pure Int) PurePlan where runPure :: PurePlan a -> (a, IntSet) runPure (PurePlan p) = runStateT p mempty $ 0 -relavantTimes :: IntSet -> IntSet -relavantTimes occs = IntSet.fromList [0..l + 1] +relevantTimes :: IntSet -> IntSet +relevantTimes occs = IntSet.fromList [0..l + 1] where l = fromMaybe 0 (fst <$> IntSet.maxView occs) testBehavior :: (Behavior (Pure Int) a, IntSet) -> IntMap a -testBehavior (b, occs) = IntMap.fromSet (sample b) (relavantTimes occs) +testBehavior (b, occs) = IntMap.fromSet (sample b) (relevantTimes occs) testEvent :: (Event (Pure Int) a, IntSet) -> IntMap (Maybe a) -testEvent (Event readEvent, occs) = IntMap.fromSet readEvent (relavantTimes occs) +testEvent (Event readEvent, occs) = IntMap.fromSet readEvent (relevantTimes occs) From 4a32a8202e180f0919ec36e6770f6af5ce88818e Mon Sep 17 00:00:00 2001 From: Ali Abrar Date: Fri, 28 Sep 2018 01:36:58 -0400 Subject: [PATCH 032/241] Add PrimMonad instance for EventWriterT --- src/Reflex/EventWriter/Base.hs | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/src/Reflex/EventWriter/Base.hs b/src/Reflex/EventWriter/Base.hs index 3a05a56b..3264b37a 100644 --- a/src/Reflex/EventWriter/Base.hs +++ b/src/Reflex/EventWriter/Base.hs @@ -34,6 +34,7 @@ import Reflex.TriggerEvent.Class import Control.Monad.Exception import Control.Monad.Identity +import Control.Monad.Primitive import Control.Monad.Reader import Control.Monad.Ref import Control.Monad.State.Strict @@ -266,6 +267,10 @@ instance (MonadQuery t q m, Monad m) => MonadQuery t q (EventWriterT t w m) wher askQueryResult = lift askQueryResult queryIncremental = lift . queryIncremental +instance PrimMonad m => PrimMonad (EventWriterT t w m) where + type PrimState (EventWriterT t w m) = PrimState m + primitive = lift . primitive + -- | Map a function over the output of a 'EventWriterT'. withEventWriterT :: (Semigroup w, Semigroup w', Reflex t, MonadHold t m) => (w -> w') From 00495afaf8be09c3b023186e1b6b865e5d376116 Mon Sep 17 00:00:00 2001 From: Ryan Trinkle Date: Thu, 11 Oct 2018 16:39:06 -0400 Subject: [PATCH 033/241] Fix version number in default.nix --- default.nix | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/default.nix b/default.nix index 7788b252..551246ad 100644 --- a/default.nix +++ b/default.nix @@ -11,7 +11,7 @@ }: mkDerivation { pname = "reflex"; - version = "0.5.0"; + version = "0.5"; src = builtins.filterSource (path: type: !(builtins.elem (baseNameOf path) [ ".git" "dist" ])) ./.; libraryHaskellDepends = [ base bifunctors containers dependent-map dependent-sum From e1628f73a173f4c7098d9abd7905f43df5a7e172 Mon Sep 17 00:00:00 2001 From: Ryan Trinkle Date: Thu, 11 Oct 2018 17:22:13 -0400 Subject: [PATCH 034/241] Disable dumping extra info --- reflex.cabal | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/reflex.cabal b/reflex.cabal index 8cc5d258..37ef18a2 100644 --- a/reflex.cabal +++ b/reflex.cabal @@ -112,7 +112,7 @@ library Reflex.Widget.Basic, Reflex.Workflow - ghc-options: -Wall -fwarn-redundant-constraints -fwarn-tabs -funbox-strict-fields -O2 -fspecialise-aggressively -ddump-simpl -ddump-to-file -dsuppress-coercions -dsuppress-idinfo + ghc-options: -Wall -fwarn-redundant-constraints -fwarn-tabs -funbox-strict-fields -O2 -fspecialise-aggressively ghc-prof-options: -fprof-auto if flag(debug-trace-events) From 24cc53036665e8981fc69f6b9fc636e729b921bc Mon Sep 17 00:00:00 2001 From: Ryan Trinkle Date: Thu, 11 Oct 2018 17:23:01 -0400 Subject: [PATCH 035/241] Fix some hlint issues --- src/Reflex/Dynamic/TH.hs | 4 ++-- src/Reflex/FunctorMaybe.hs | 4 ++-- 2 files changed, 4 insertions(+), 4 deletions(-) diff --git a/src/Reflex/Dynamic/TH.hs b/src/Reflex/Dynamic/TH.hs index 3327ffc3..e71f4536 100644 --- a/src/Reflex/Dynamic/TH.hs +++ b/src/Reflex/Dynamic/TH.hs @@ -47,8 +47,8 @@ qDynPure qe = do _ -> gmapM f d (e', exprsReversed) <- runStateT (gmapM f e) [] let exprs = reverse exprsReversed - arg = foldr (\a b -> ConE 'FHCons `AppE` a `AppE` b) (ConE 'FHNil) $ map snd exprs - param = foldr (\a b -> ConP 'HCons [VarP a, b]) (ConP 'HNil []) $ map fst exprs + arg = foldr (\a b -> ConE 'FHCons `AppE` snd a `AppE` b) (ConE 'FHNil) exprs + param = foldr (\a b -> ConP 'HCons [VarP (fst a), b]) (ConP 'HNil []) exprs [| $(return $ LamE [param] e') <$> distributeFHListOverDynPure $(return arg) |] -- | Antiquote a 'Dynamic' expression. This can /only/ be used inside of a diff --git a/src/Reflex/FunctorMaybe.hs b/src/Reflex/FunctorMaybe.hs index cc04f2ea..f73e0426 100644 --- a/src/Reflex/FunctorMaybe.hs +++ b/src/Reflex/FunctorMaybe.hs @@ -28,6 +28,6 @@ class FunctorMaybe f where instance FunctorMaybe Maybe where fmapMaybe = (=<<) --- | @fmapMaybe f = catMaybes . fmap f@ +-- | @fmapMaybe = mapMaybe@ instance FunctorMaybe [] where - fmapMaybe f = catMaybes . fmap f + fmapMaybe = mapMaybe From 62ad2e3a9cfd2a2459a4b618c5a027e14bae7fe3 Mon Sep 17 00:00:00 2001 From: Ryan Trinkle Date: Thu, 11 Oct 2018 17:23:10 -0400 Subject: [PATCH 036/241] Eliminate ReaderT in SpiderHost --- src/Reflex/Spider/Internal.hs | 18 +++++++++--------- 1 file changed, 9 insertions(+), 9 deletions(-) diff --git a/src/Reflex/Spider/Internal.hs b/src/Reflex/Spider/Internal.hs index d4ef165f..6fb43e43 100644 --- a/src/Reflex/Spider/Internal.hs +++ b/src/Reflex/Spider/Internal.hs @@ -1217,8 +1217,8 @@ coincidence a = eventCoincidence $ Coincidence run :: forall x b. HasSpiderTimeline x => [DSum (RootTrigger x) Identity] -> ResultM x b -> SpiderHost x b run roots after = do tracePropagate (Proxy :: Proxy x) $ "Running an event frame with " <> show (length roots) <> " events" - t <- SpiderHost ask - result <- SpiderHost $ lift $ withMVar (_spiderTimeline_lock t) $ \_ -> flip runReaderT t $ unSpiderHost $ runFrame $ do + let t = spiderTimeline :: SpiderTimelineEnv x + result <- SpiderHost $ withMVar (_spiderTimeline_lock t) $ \_ -> unSpiderHost $ runFrame $ do rootsToPropagate <- forM roots $ \r@(RootTrigger (_, occRef, k) :=> a) -> do occBefore <- liftIO $ do occBefore <- readIORef occRef @@ -2085,7 +2085,7 @@ clearEventEnv (EventEnv toAssignRef holdInitRef dynInitRef mergeUpdateRef mergeI -- | Run an event action outside of a frame runFrame :: forall x a. HasSpiderTimeline x => EventM x a -> SpiderHost x a --TODO: This function also needs to hold the mutex -runFrame a = SpiderHost $ ask >>= \_ -> lift $ do +runFrame a = SpiderHost $ do let env = _spiderTimeline_eventEnv (spiderTimeline :: SpiderTimelineEnv x) let go = do result <- a @@ -2126,7 +2126,7 @@ runFrame a = SpiderHost $ ask >>= \_ -> lift $ do runEventM $ runHoldInits (eventEnvHoldInits env) (eventEnvDynInits env) (eventEnvMergeInits env) --TODO: Is this actually OK? It seems like it should be, since we know that no events are firing at this point, but it still seems inelegant --TODO: Make sure we touch the pieces of the SwitchSubscribed at the appropriate times sub <- newSubscriberSwitch subscribed - subscription <- runReaderT (unSpiderHost (runFrame ({-# SCC "subscribeSwitch" #-} subscribe e sub))) spiderTimeline --TODO: Assert that the event isn't firing --TODO: This should not loop because none of the events should be firing, but still, it is inefficient + subscription <- unSpiderHost $ runFrame $ {-# SCC "subscribeSwitch" #-} subscribe e sub --TODO: Assert that the event isn't firing --TODO: This should not loop because none of the events should be firing, but still, it is inefficient {- stackTrace <- liftIO $ fmap renderStack $ ccsToStrings =<< (getCCSOf $! switchSubscribedParent subscribed) liftIO $ putStrLn $ (++stackTrace) $ "subd' subscribed to " ++ case e of @@ -2416,8 +2416,8 @@ instance HasSpiderTimeline x => Reflex.Host.Class.MonadReadEvent (SpiderTimeline return result instance Reflex.Host.Class.MonadReflexCreateTrigger (SpiderTimeline x) (SpiderHost x) where - newEventWithTrigger = SpiderHost . lift . fmap SpiderEvent . newEventWithTriggerIO - newFanEventWithTrigger f = SpiderHost $ lift $ do + newEventWithTrigger = SpiderHost . fmap SpiderEvent . newEventWithTriggerIO + newFanEventWithTrigger f = SpiderHost $ do es <- newFanEventWithTriggerIO f return $ Reflex.Class.EventSelector $ SpiderEvent . Reflex.Spider.Internal.select es @@ -2554,7 +2554,7 @@ instance MonadAtomicRef (EventM x) where atomicModifyRef r f = liftIO $ atomicModifyRef r f -- | The monad for actions that manipulate a Spider timeline identified by @x@ -newtype SpiderHost x a = SpiderHost { unSpiderHost :: ReaderT (SpiderTimelineEnv x) IO a } deriving (Functor, Applicative, MonadFix, MonadIO, MonadException, MonadAsyncException) +newtype SpiderHost x a = SpiderHost { unSpiderHost :: IO a } deriving (Functor, Applicative, MonadFix, MonadIO, MonadException, MonadAsyncException) instance Monad (SpiderHost x) where {-# INLINABLE (>>=) #-} @@ -2569,12 +2569,12 @@ instance Monad (SpiderHost x) where -- | Run an action affecting the global Spider timeline; this will be guarded by -- a mutex for that timeline runSpiderHost :: SpiderHost Global a -> IO a -runSpiderHost (SpiderHost a) = runReaderT a globalSpiderTimelineEnv +runSpiderHost (SpiderHost a) = a -- | Run an action affecting a given Spider timeline; this will be guarded by a -- mutex for that timeline runSpiderHostForTimeline :: SpiderHost x a -> SpiderTimelineEnv x -> IO a -runSpiderHostForTimeline (SpiderHost a) = runReaderT a +runSpiderHostForTimeline (SpiderHost a) _ = a newtype SpiderHostFrame x a = SpiderHostFrame { runSpiderHostFrame :: EventM x a } deriving (Functor, Applicative, MonadFix, MonadIO, MonadException, MonadAsyncException) From 15c99fc6adf4926289d12c0e19fa96b9b1a1e731 Mon Sep 17 00:00:00 2001 From: Ryan Trinkle Date: Thu, 11 Oct 2018 17:41:18 -0400 Subject: [PATCH 037/241] Add other-modules to `semantics` test --- reflex.cabal | 7 +++++++ 1 file changed, 7 insertions(+) diff --git a/reflex.cabal b/reflex.cabal index 37ef18a2..7fc0bb71 100644 --- a/reflex.cabal +++ b/reflex.cabal @@ -161,6 +161,13 @@ test-suite semantics reflex, split, transformers >= 0.3 + other-modules: + Reflex.Bench.Focused + Reflex.Plan.Pure + Reflex.Plan.Reflex + Reflex.Test + Reflex.Test.Micro + Reflex.TestPlan test-suite CrossImpl type: exitcode-stdio-1.0 From 7cfa6824c3655b432df4bb888b039c829fa2adc2 Mon Sep 17 00:00:00 2001 From: davean Date: Sun, 14 Oct 2018 14:54:43 -0400 Subject: [PATCH 038/241] Update reflex for newer base libraries. --- reflex.cabal | 8 ++++---- src/Data/AppendMap.hs | 3 ++- src/Reflex/Patch/MapWithMove.hs | 2 +- 3 files changed, 7 insertions(+), 6 deletions(-) diff --git a/reflex.cabal b/reflex.cabal index 7fc0bb71..c582fe78 100644 --- a/reflex.cabal +++ b/reflex.cabal @@ -37,10 +37,10 @@ library hs-source-dirs: src build-depends: MemoTrie == 0.6.*, - base >= 4.7 && < 4.12, + base >= 4.7 && < 4.13, bifunctors >= 5.2 && < 5.6, comonad, - containers == 0.5.*, + containers >= 0.5 && < 0.7, data-default >= 0.5 && < 0.8, dependent-map >= 0.2.4 && < 0.3, exception-transformers == 0.4.*, @@ -55,7 +55,7 @@ library reflection == 2.1.*, semigroupoids >= 4.0 && < 6, semigroups >= 0.16 && < 0.19, - stm == 2.4.*, + stm >= 2.4 && < 2.6, syb >= 0.5 && < 0.8, these >= 0.4 && < 0.8, time >= 1.4 && < 1.9, @@ -130,7 +130,7 @@ library dependent-sum >= 0.3 && < 0.5, haskell-src-exts >= 1.16 && < 1.21, haskell-src-meta >= 0.6 && < 0.9, - template-haskell >= 2.9 && < 2.14 + template-haskell >= 2.9 && < 2.15 exposed-modules: Reflex.Dynamic.TH other-extensions: TemplateHaskell diff --git a/src/Data/AppendMap.hs b/src/Data/AppendMap.hs index b3b0caa1..81b8b1ac 100644 --- a/src/Data/AppendMap.hs +++ b/src/Data/AppendMap.hs @@ -26,7 +26,8 @@ import Prelude hiding (map, null) import Data.Coerce import Data.Default import Data.Map (Map) -import qualified Data.Map as Map +import qualified Data.Map as Map hiding (showTree, showTreeWith) +import qualified Data.Map.Internal.Debug as Map (showTree, showTreeWith) import Data.Map.Monoidal import Reflex.Class (FunctorMaybe (..)) import Reflex.Patch (Additive, Group (..)) diff --git a/src/Reflex/Patch/MapWithMove.hs b/src/Reflex/Patch/MapWithMove.hs index aab9693d..0270203c 100644 --- a/src/Reflex/Patch/MapWithMove.hs +++ b/src/Reflex/Patch/MapWithMove.hs @@ -143,7 +143,7 @@ patchThatChangesMap oldByIndex newByIndex = patch putRemainingKeys $ Set.delete k fromKs return $ NodeInfo (From_Move k) $ Just undefined -- There's an existing value, and it's here, so no patch necessary else do - Just (fromK, remainingKeys) <- return $ Set.minView fromKs -- There's an existing value, but it's not here; move it here + (fromK, remainingKeys) <- return . fromJust $ Set.minView fromKs -- There's an existing value, but it's not here; move it here putRemainingKeys remainingKeys return $ NodeInfo (From_Move fromK) $ Just undefined Map.traverseWithKey f newByIndex From 53559e17f03b1dab24cd96c41b93c02647775286 Mon Sep 17 00:00:00 2001 From: davean Date: Sun, 14 Oct 2018 17:13:19 -0400 Subject: [PATCH 039/241] Fixes to compile the tests with 8.4.3 on cabal new-*. --- reflex.cabal | 46 +++++++++++++++++++++++++++++++++++- test/QueryT.hs | 10 ++++---- test/Reflex/Bench/Focused.hs | 2 +- 3 files changed, 51 insertions(+), 7 deletions(-) diff --git a/reflex.cabal b/reflex.cabal index c582fe78..9f160bf6 100644 --- a/reflex.cabal +++ b/reflex.cabal @@ -178,9 +178,17 @@ test-suite CrossImpl base, containers, dependent-map, + dependent-sum, + deepseq >= 1.3 && < 1.5, mtl, + transformers, ref-tf, reflex + other-modules: + Reflex.Test + Reflex.TestPlan + Reflex.Plan.Reflex + Reflex.Plan.Pure test-suite hlint type: exitcode-stdio-1.0 @@ -199,12 +207,21 @@ test-suite EventWriterT main-is: EventWriterT.hs hs-source-dirs: test build-depends: base + , containers + , deepseq >= 1.3 && < 1.5 , dependent-sum , lens + , mtl , these , transformers , reflex , ref-tf + other-modules: + Reflex.Test + Reflex.TestPlan + Reflex.Plan.Reflex + Reflex.Plan.Pure + Test.Run test-suite RequesterT type: exitcode-stdio-1.0 @@ -219,6 +236,9 @@ test-suite RequesterT , reflex , ref-tf buildable: False + other-modules: + Reflex.TestPlan + Reflex.Plan.Pure test-suite QueryT type: exitcode-stdio-1.0 @@ -228,35 +248,59 @@ test-suite QueryT , containers , dependent-map , dependent-sum + , deepseq >= 1.3 && < 1.5 , lens , monoidal-containers + , mtl , ref-tf , reflex , semigroups , these , transformers - other-modules: Test.Run + other-modules: + Test.Run + Reflex.TestPlan + Reflex.Plan.Reflex + Reflex.Plan.Pure test-suite GC-Semantics type: exitcode-stdio-1.0 main-is: GC.hs hs-source-dirs: test build-depends: base + , containers , dependent-sum , dependent-map + , deepseq >= 1.3 && < 1.5 + , mtl , these , transformers , reflex , ref-tf if impl(ghc < 8) build-depends: semigroups + other-modules: + Reflex.Plan.Pure + Reflex.Plan.Reflex + Reflex.TestPlan + Test.Run test-suite rootCleanup type: exitcode-stdio-1.0 main-is: rootCleanup.hs hs-source-dirs: test build-depends: base + , containers + , deepseq >= 1.3 && < 1.5 + , dependent-sum + , mtl , reflex + , ref-tf + , these + other-modules: + Reflex.Plan.Pure + Reflex.TestPlan + Test.Run benchmark spider-bench type: exitcode-stdio-1.0 diff --git a/test/QueryT.hs b/test/QueryT.hs index 74e49d5a..4f5de5b5 100644 --- a/test/QueryT.hs +++ b/test/QueryT.hs @@ -28,14 +28,14 @@ instance Query MyQuery where type QueryResult MyQuery = () crop _ _ = () -instance (Ord k, Query a, Eq (QueryResult a)) => Query (Selector k a) where +instance (Ord k, Query a, Eq (QueryResult a), Align (MonoidalMap k)) => Query (Selector k a) where type QueryResult (Selector k a) = Selector k (QueryResult a) crop q r = undefined newtype Selector k a = Selector { unSelector :: MonoidalMap k a } deriving (Show, Read, Eq, Ord, Functor) -instance (Ord k, Eq a, Monoid a) => Semigroup (Selector k a) where +instance (Ord k, Eq a, Monoid a, Align (MonoidalMap k)) => Semigroup (Selector k a) where (Selector a) <> (Selector b) = Selector $ fmapMaybe id $ f a b where f = alignWith $ \case @@ -45,14 +45,14 @@ instance (Ord k, Eq a, Monoid a) => Semigroup (Selector k a) where let z = x `mappend` y in if z == mempty then Nothing else Just z -instance (Ord k, Eq a, Monoid a) => Monoid (Selector k a) where +instance (Ord k, Eq a, Monoid a, Align (MonoidalMap k)) => Monoid (Selector k a) where mempty = Selector AMap.empty mappend = (<>) -instance (Eq a, Ord k, Group a) => Group (Selector k a) where +instance (Eq a, Ord k, Group a, Align (MonoidalMap k)) => Group (Selector k a) where negateG = fmap negateG -instance (Eq a, Ord k, Group a) => Additive (Selector k a) +instance (Eq a, Ord k, Group a, Align (MonoidalMap k)) => Additive (Selector k a) main :: IO () main = do diff --git a/test/Reflex/Bench/Focused.hs b/test/Reflex/Bench/Focused.hs index c48d88a5..621ab5a5 100644 --- a/test/Reflex/Bench/Focused.hs +++ b/test/Reflex/Bench/Focused.hs @@ -184,7 +184,7 @@ switchMergeBehaviors mapChanges = pull . joinMap <$> holdMap mapChanges -- | Turn an UpdatedMap into a Dynamic by applying the differences to the initial value holdMapDyn :: (Reflex t, MonadHold t m, MonadFix m, Ord k) => UpdatedMap t k a -> m (Dynamic t (Map k a)) -holdMapDyn (UpdatedMap initial changes) = foldDyn (flip (Map.foldWithKey modify)) initial changes +holdMapDyn (UpdatedMap initial changes) = foldDyn (flip (Map.foldrWithKey modify)) initial changes where modify k Nothing items = Map.delete k items From bc216daf5e4bc0839288707a1cd5117ac4069cd3 Mon Sep 17 00:00:00 2001 From: davean Date: Sun, 14 Oct 2018 17:42:52 -0400 Subject: [PATCH 040/241] -Wall/cabal check cleanup of imports not related to compatability. --- reflex.cabal | 8 +++----- src/Data/AppendMap.hs | 1 - test/Reflex/Test/CrossImpl.hs | 6 ++---- test/Reflex/Test/Micro.hs | 8 ++++---- 4 files changed, 9 insertions(+), 14 deletions(-) diff --git a/reflex.cabal b/reflex.cabal index 9f160bf6..5b023626 100644 --- a/reflex.cabal +++ b/reflex.cabal @@ -113,7 +113,6 @@ library Reflex.Workflow ghc-options: -Wall -fwarn-redundant-constraints -fwarn-tabs -funbox-strict-fields -O2 -fspecialise-aggressively - ghc-prof-options: -fprof-auto if flag(debug-trace-events) cpp-options: -DDEBUG_TRACE_EVENTS @@ -139,7 +138,7 @@ library dependent-sum == 0.4.* if flag(fast-weak) && impl(ghcjs) - ghc-options: -DGHCJS_FAST_WEAK + cpp-options: -DGHCJS_FAST_WEAK if impl(ghcjs) build-depends: ghcjs-base @@ -173,7 +172,7 @@ test-suite CrossImpl type: exitcode-stdio-1.0 main-is: Reflex/Test/CrossImpl.hs hs-source-dirs: test - ghc-options: -O2 -Wall -rtsopts -main-is Reflex.Test.CrossImpl.test + ghc-options: -O2 -Wall -rtsopts build-depends: base, containers, @@ -325,10 +324,9 @@ benchmark saulzar-bench c-sources: bench-cbits/checkCapability.c main-is: RunAll.hs ghc-options: -Wall -O2 -rtsopts -threaded - ghc-prof-options: -fprof-auto build-depends: base, - containers == 0.5.*, + containers >= 0.5 && < 0.7, criterion == 1.1.*, deepseq >= 1.3 && < 1.5, dependent-map, diff --git a/src/Data/AppendMap.hs b/src/Data/AppendMap.hs index 81b8b1ac..dc2af842 100644 --- a/src/Data/AppendMap.hs +++ b/src/Data/AppendMap.hs @@ -26,7 +26,6 @@ import Prelude hiding (map, null) import Data.Coerce import Data.Default import Data.Map (Map) -import qualified Data.Map as Map hiding (showTree, showTreeWith) import qualified Data.Map.Internal.Debug as Map (showTree, showTreeWith) import Data.Map.Monoidal import Reflex.Class (FunctorMaybe (..)) diff --git a/test/Reflex/Test/CrossImpl.hs b/test/Reflex/Test/CrossImpl.hs index a813bf04..03b9937f 100644 --- a/test/Reflex/Test/CrossImpl.hs +++ b/test/Reflex/Test/CrossImpl.hs @@ -12,7 +12,6 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} -module Reflex.Test.CrossImpl (test) where import Prelude hiding (and, foldl, mapM, mapM_, sequence, sequence_) @@ -26,7 +25,6 @@ import qualified Reflex.Spider.Internal as S import Control.Arrow (second, (&&&)) import Control.Monad.Identity hiding (forM, forM_, mapM, mapM_, sequence, sequence_) import Control.Monad.State.Strict hiding (forM, forM_, mapM, mapM_, sequence, sequence_) -import Control.Monad.Writer hiding (forM, forM_, mapM, mapM_, sequence, sequence_) import Data.Dependent.Map (DSum (..)) import Data.Foldable import Data.Map.Strict (Map) @@ -248,8 +246,8 @@ splitRecombineEvent e = in leftmost [ea, eb] -test :: IO () -test = do +main :: IO () +main = do results <- forM testCases $ \(name, TestCase inputs builder) -> do putStrLn $ "Test: " <> name testAgreement builder inputs diff --git a/test/Reflex/Test/Micro.hs b/test/Reflex/Test/Micro.hs index 50aa55a4..29219e72 100644 --- a/test/Reflex/Test/Micro.hs +++ b/test/Reflex/Test/Micro.hs @@ -263,13 +263,13 @@ testCases = , testB "factorDyn" $ do d <- holdDyn (Left "a") =<< eithers - eithers <- eitherDyn d + eithers' <- eitherDyn d let unFactor = either id id - return $ current (join (fmap unFactor eithers)) + return $ current (join (fmap unFactor eithers')) , testB "pushDynDeep" $ do - e1 <- events1 - e2 <- events2 + _ <- events1 + _ <- events2 d1 <- holdDyn "d1" =<< events1 d2 <- holdDyn "d2" =<< events2 From 17cbba72aa5a5ab9ea4ded62a207d5d72f128edf Mon Sep 17 00:00:00 2001 From: davean Date: Sun, 14 Oct 2018 17:52:18 -0400 Subject: [PATCH 041/241] 8.6.1 compatabillity. --- test/QueryT.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/test/QueryT.hs b/test/QueryT.hs index 4f5de5b5..cbd6e079 100644 --- a/test/QueryT.hs +++ b/test/QueryT.hs @@ -4,6 +4,7 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} import Control.Lens import Control.Monad.Fix From 03387bd609ccaafe468a1ae39989a653a27a86d7 Mon Sep 17 00:00:00 2001 From: davean Date: Sun, 14 Oct 2018 23:28:08 -0400 Subject: [PATCH 042/241] Fix benchmarks to work on modern GHC. --- bench-cbits/checkCapability.c | 23 +++++++++++------------ bench/Main.hs | 13 +++++++------ bench/RunAll.hs | 2 +- reflex.cabal | 17 ++++++++++++++--- 4 files changed, 33 insertions(+), 22 deletions(-) diff --git a/bench-cbits/checkCapability.c b/bench-cbits/checkCapability.c index 2608bc96..1f566305 100644 --- a/bench-cbits/checkCapability.c +++ b/bench-cbits/checkCapability.c @@ -42,7 +42,7 @@ typedef struct Task_ { // or just continue immediately. It's a workaround for the fact // that signalling a condition variable doesn't do anything if the // thread is already running, but we want it to be sticky. - rtsBool wakeup; + bool wakeup; #endif // This points to the Capability that the Task "belongs" to. If @@ -62,14 +62,14 @@ typedef struct Task_ { // The current top-of-stack InCall struct InCall_ *incall; - nat n_spare_incalls; + uint32_t n_spare_incalls; struct InCall_ *spare_incalls; - rtsBool worker; // == rtsTrue if this is a worker Task - rtsBool stopped; // this task has stopped or exited Haskell + bool worker; // == rtsTrue if this is a worker Task + bool stopped; // this task has stopped or exited Haskell // So that we can detect when a finalizer illegally calls back into Haskell - rtsBool running_finalizers; + bool running_finalizers; // Links tasks on the returning_tasks queue of a Capability, and // on spare_workers. @@ -88,7 +88,7 @@ struct Capability_ { StgFunTable f; StgRegTable r; - nat no; // capability number. + uint32_t no; // capability number. // The Task currently holding this Capability. This task has // exclusive access to the contents of this Capability (apart from @@ -98,12 +98,12 @@ struct Capability_ { // true if this Capability is running Haskell code, used for // catching unsafe call-ins. - rtsBool in_haskell; + bool in_haskell; // Has there been any activity on this Capability since the last GC? - nat idle; + uint32_t idle; - rtsBool disabled; + bool disabled; // The run queue. The Task owning this Capability has exclusive // access to its run queue, so can wake up threads without @@ -159,7 +159,7 @@ struct Capability_ { #if defined(THREADED_RTS) // Worker Tasks waiting in the wings. Singly-linked. Task *spare_workers; - nat n_spare_workers; // count of above + uint32_t n_spare_workers; // count of above // This lock protects: // running_task @@ -192,10 +192,9 @@ struct Capability_ { // Per-capability STM-related data StgTVarWatchQueue *free_tvar_watch_queues; - StgInvariantCheckQueue *free_invariant_check_queues; StgTRecChunk *free_trec_chunks; StgTRecHeader *free_trec_headers; - nat transaction_tokens; + uint32_t transaction_tokens; } // typedef Capability is defined in RtsAPI.h // We never want a Capability to overlap a cache line with anything // else, so round it up to a cache line size: diff --git a/bench/Main.hs b/bench/Main.hs index aad4fd54..bed63496 100644 --- a/bench/Main.hs +++ b/bench/Main.hs @@ -20,6 +20,7 @@ import qualified Data.Dependent.Map as DMap import Data.Dependent.Sum import Data.Functor.Misc import Data.IORef +import Data.Maybe (fromJust) import Reflex import Reflex.Host.Class @@ -70,7 +71,7 @@ micros = , withSetupWHNF "fireEventsOnly" (newEventWithTriggerRef >>= subscribePair) (\(_, trigger) -> do - Just key <- liftIO $ readIORef trigger + key <- fromJust <$> liftIO (readIORef trigger) fireEvents [key :=> Identity (42 :: Int)]) , withSetupWHNF "fireEventsAndRead(head/merge1)" (setupMerge 1 >>= subscribePair) @@ -84,14 +85,14 @@ micros = , withSetupWHNF "fireEventsOnly(head/merge100)" (setupMerge 100 >>= subscribePair) (\(_, t:_) -> do - Just key <- liftIO $ readIORef t + key <- fromJust <$> liftIO (readIORef t) fireEvents [key :=> Identity (42 :: Int)]) , withSetupWHNF "hold" newEventWithTriggerRef $ \(ev, _) -> hold (42 :: Int) ev , withSetupWHNF "sample" (newEventWithTriggerRef >>= hold (42 :: Int) . fst) sample ] setupMerge :: Int - -> SpiderHost Global ( Event (SpiderEnv Global) (DMap (Const2 Int a) Identity) + -> SpiderHost Global ( Event (SpiderTimeline Global) (DMap (Const2 Int a) Identity) , [IORef (Maybe (EventTrigger Spider a))] ) setupMerge num = do @@ -99,11 +100,11 @@ setupMerge num = do let !m = DMap.fromList [Const2 i :=> v | (i,v) <- zip [0..] evs] pure (merge m, triggers) -subscribePair :: (Event (SpiderEnv Global) a, b) -> SpiderHost Global (EventHandle (SpiderEnv Global) a, b) +subscribePair :: (Event (SpiderTimeline Global) a, b) -> SpiderHost Global (EventHandle (SpiderTimeline Global) a, b) subscribePair (ev, b) = (,b) <$> subscribeEvent ev -fireAndRead :: IORef (Maybe (EventTrigger (SpiderEnv Global) a)) -> a -> EventHandle (SpiderEnv Global) b +fireAndRead :: IORef (Maybe (EventTrigger (SpiderTimeline Global) a)) -> a -> EventHandle (SpiderTimeline Global) b -> SpiderHost Global (Maybe b) fireAndRead trigger val subd = do - Just key <- liftIO $ readIORef trigger + key <- fromJust <$> liftIO (readIORef trigger) fireEventsAndRead [key :=> Identity val] $ readEvent subd >>= sequence diff --git a/bench/RunAll.hs b/bench/RunAll.hs index d0e1c368..6d566117 100644 --- a/bench/RunAll.hs +++ b/bench/RunAll.hs @@ -136,7 +136,7 @@ benchmarks = implGroup "spider" runSpiderHost cases pattern RunTestCaseFlag = "--run-test-case" spawnBenchmark :: String -> Benchmark -spawnBenchmark name = Benchmark name $ Benchmarkable $ \n -> do +spawnBenchmark name = bench name . toBenchmarkable $ \n -> do self <- getExecutablePath callProcess self [RunTestCaseFlag, name, show n, "+RTS", "-N1"] diff --git a/reflex.cabal b/reflex.cabal index 5b023626..63d8c071 100644 --- a/reflex.cabal +++ b/reflex.cabal @@ -303,20 +303,27 @@ test-suite rootCleanup benchmark spider-bench type: exitcode-stdio-1.0 - hs-source-dirs: bench + hs-source-dirs: bench test main-is: Main.hs ghc-options: -Wall -O2 -rtsopts build-depends: base, - criterion == 1.1.*, + containers, + criterion >= 1.1 && < 1.6, deepseq >= 1.3 && < 1.5, dependent-map, dependent-sum, + ref-tf, mtl, primitive, reflex, + split, stm, transformers >= 0.3 + other-modules: + Reflex.TestPlan + Reflex.Plan.Reflex + Reflex.Bench.Focused benchmark saulzar-bench type: exitcode-stdio-1.0 @@ -327,7 +334,7 @@ benchmark saulzar-bench build-depends: base, containers >= 0.5 && < 0.7, - criterion == 1.1.*, + criterion >= 1.1 && < 1.6, deepseq >= 1.3 && < 1.5, dependent-map, dependent-sum, @@ -341,6 +348,10 @@ benchmark saulzar-bench stm, time, transformers >= 0.3 + other-modules: + Reflex.TestPlan + Reflex.Plan.Reflex + Reflex.Bench.Focused source-repository head type: git From 8217c818ae862a7fce1239a6a62ebb9d3cd4cd28 Mon Sep 17 00:00:00 2001 From: hsloan Date: Tue, 16 Oct 2018 22:10:07 +0000 Subject: [PATCH 043/241] use latest release of monoidal-containers --- reflex.cabal | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/reflex.cabal b/reflex.cabal index 63d8c071..59b6457e 100644 --- a/reflex.cabal +++ b/reflex.cabal @@ -46,7 +46,7 @@ library exception-transformers == 0.4.*, lens >= 4.7 && < 5, monad-control >= 1.0.1 && < 1.1, - monoidal-containers == 0.5.*, + monoidal-containers == 0.4.*, mtl >= 2.1 && < 2.3, prim-uniq >= 0.1.0.1 && < 0.2, primitive >= 0.5 && < 0.7, From 9813f900a534dfe3aadbd08226d025d682d3e5e8 Mon Sep 17 00:00:00 2001 From: davean Date: Wed, 17 Oct 2018 13:33:44 -0400 Subject: [PATCH 044/241] Switch where we import showTree* with. The use of CPP seemed the most reasonable local solution to fixing that 'reflex's support window is longer than the re-export compatability window 'containers' provided. --- src/Data/AppendMap.hs | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/src/Data/AppendMap.hs b/src/Data/AppendMap.hs index dc2af842..b84df7a8 100644 --- a/src/Data/AppendMap.hs +++ b/src/Data/AppendMap.hs @@ -26,7 +26,11 @@ import Prelude hiding (map, null) import Data.Coerce import Data.Default import Data.Map (Map) +#if MIN_VERSION_containers(0,5,11) import qualified Data.Map.Internal.Debug as Map (showTree, showTreeWith) +#else +import qualified Data.Map as Map (showTree, showTreeWith) +#endif import Data.Map.Monoidal import Reflex.Class (FunctorMaybe (..)) import Reflex.Patch (Additive, Group (..)) From 240932e52185d196263f01da38511f6e05c0d959 Mon Sep 17 00:00:00 2001 From: davean Date: Wed, 17 Oct 2018 16:25:23 -0400 Subject: [PATCH 045/241] Earlier 'base' versions for CrossImpl and earlier RTS compatability for checkCapability. --- bench-cbits/checkCapability.c | 12 ++++++------ test/Reflex/Test/CrossImpl.hs | 1 + 2 files changed, 7 insertions(+), 6 deletions(-) diff --git a/bench-cbits/checkCapability.c b/bench-cbits/checkCapability.c index 1f566305..2ae967f4 100644 --- a/bench-cbits/checkCapability.c +++ b/bench-cbits/checkCapability.c @@ -42,7 +42,7 @@ typedef struct Task_ { // or just continue immediately. It's a workaround for the fact // that signalling a condition variable doesn't do anything if the // thread is already running, but we want it to be sticky. - bool wakeup; + HsBool wakeup; #endif // This points to the Capability that the Task "belongs" to. If @@ -65,11 +65,11 @@ typedef struct Task_ { uint32_t n_spare_incalls; struct InCall_ *spare_incalls; - bool worker; // == rtsTrue if this is a worker Task - bool stopped; // this task has stopped or exited Haskell + HsBool worker; // == rtsTrue if this is a worker Task + HsBool stopped; // this task has stopped or exited Haskell // So that we can detect when a finalizer illegally calls back into Haskell - bool running_finalizers; + HsBool running_finalizers; // Links tasks on the returning_tasks queue of a Capability, and // on spare_workers. @@ -98,12 +98,12 @@ struct Capability_ { // true if this Capability is running Haskell code, used for // catching unsafe call-ins. - bool in_haskell; + HsBool in_haskell; // Has there been any activity on this Capability since the last GC? uint32_t idle; - bool disabled; + HsBool disabled; // The run queue. The Task owning this Capability has exclusive // access to its run queue, so can wake up threads without diff --git a/test/Reflex/Test/CrossImpl.hs b/test/Reflex/Test/CrossImpl.hs index 03b9937f..f29a06ec 100644 --- a/test/Reflex/Test/CrossImpl.hs +++ b/test/Reflex/Test/CrossImpl.hs @@ -30,6 +30,7 @@ import Data.Foldable import Data.Map.Strict (Map) import qualified Data.Map.Strict as Map import qualified Data.Set as Set +import Data.Monoid import Data.Traversable import System.Exit import System.Mem From 59ef31edc761109dbe1fc9489af6c620e6bea31e Mon Sep 17 00:00:00 2001 From: Ryan Trinkle Date: Fri, 19 Oct 2018 15:13:46 -0400 Subject: [PATCH 046/241] Move some query morphisms into Reflex.Query.Class --- src/Reflex/Query/Base.hs | 7 ------- src/Reflex/Query/Class.hs | 23 +++++++++++++++++++++++ 2 files changed, 23 insertions(+), 7 deletions(-) diff --git a/src/Reflex/Query/Base.hs b/src/Reflex/Query/Base.hs index 971c95af..66dec13f 100644 --- a/src/Reflex/Query/Base.hs +++ b/src/Reflex/Query/Base.hs @@ -278,13 +278,6 @@ instance (Monoid a, Monad m) => Monoid (QueryT t q m a) where instance (S.Semigroup a, Monad m) => S.Semigroup (QueryT t q m a) where (<>) = liftA2 (S.<>) - -mapQuery :: QueryMorphism q q' -> q -> q' -mapQuery = _queryMorphism_mapQuery - -mapQueryResult :: QueryMorphism q q' -> QueryResult q' -> QueryResult q -mapQueryResult = _queryMorphism_mapQueryResult - -- | withQueryT's QueryMorphism argument needs to be a group homomorphism in order to behave correctly withQueryT :: (MonadFix m, PostBuild t m, Group q, Group q', Additive q, Additive q', Query q') => QueryMorphism q q' diff --git a/src/Reflex/Query/Class.hs b/src/Reflex/Query/Class.hs index aeaaddf6..863513df 100644 --- a/src/Reflex/Query/Class.hs +++ b/src/Reflex/Query/Class.hs @@ -15,12 +15,18 @@ module Reflex.Query.Class , MonadQuery (..) , tellQueryDyn , queryDyn + , mapQuery + , mapQueryResult ) where +import Control.Category (Category) +import qualified Control.Category as Cat import Control.Monad.Reader import Data.Bits import Data.Data import Data.Ix +import Data.Map.Monoidal (MonoidalMap) +import qualified Data.Map.Monoidal as MonoidalMap import Data.Semigroup import Foreign.Storable @@ -30,6 +36,10 @@ class (Monoid (QueryResult a), Semigroup (QueryResult a)) => Query a where type QueryResult a :: * crop :: a -> QueryResult a -> QueryResult a +instance (Ord k, Query v) => Query (MonoidalMap k v) where + type QueryResult (MonoidalMap k v) = MonoidalMap k (QueryResult v) + crop q r = MonoidalMap.intersectionWith (flip crop) r q + -- | NB: QueryMorphism's must be group homomorphisms when acting on the query type -- and compatible with the query relationship when acting on the query result data QueryMorphism q q' = QueryMorphism @@ -37,6 +47,19 @@ data QueryMorphism q q' = QueryMorphism , _queryMorphism_mapQueryResult :: QueryResult q' -> QueryResult q } +instance Category QueryMorphism where + id = QueryMorphism id id + qm . qm' = QueryMorphism + { _queryMorphism_mapQuery = mapQuery qm . mapQuery qm' + , _queryMorphism_mapQueryResult = mapQueryResult qm' . mapQueryResult qm + } + +mapQuery :: QueryMorphism q q' -> q -> q' +mapQuery = _queryMorphism_mapQuery + +mapQueryResult :: QueryMorphism q q' -> QueryResult q' -> QueryResult q +mapQueryResult = _queryMorphism_mapQueryResult + -- | This type keeps track of the multiplicity of elements of the view selector that are being used by the app newtype SelectedCount = SelectedCount { unSelectedCount :: Int } deriving (Eq, Ord, Show, Read, Integral, Num, Bounded, Enum, Real, Ix, Bits, FiniteBits, Storable, Data) From 6229dde80d1f14502aa407a401d3075e686ab358 Mon Sep 17 00:00:00 2001 From: Elliot Cameron Date: Tue, 23 Oct 2018 23:39:13 -0400 Subject: [PATCH 047/241] Give [Event|Dynamic]Writer instances of each other --- src/Reflex/DynamicWriter/Base.hs | 6 +++++- src/Reflex/EventWriter/Base.hs | 6 +++++- 2 files changed, 10 insertions(+), 2 deletions(-) diff --git a/src/Reflex/DynamicWriter/Base.hs b/src/Reflex/DynamicWriter/Base.hs index 39119202..8151fc7d 100644 --- a/src/Reflex/DynamicWriter/Base.hs +++ b/src/Reflex/DynamicWriter/Base.hs @@ -38,9 +38,10 @@ import Data.Semigroup import Data.Some (Some) import Data.These -import Reflex.Class import Reflex.Adjustable.Class +import Reflex.Class import Reflex.DynamicWriter.Class +import Reflex.EventWriter.Class (EventWriter, tellEvent) import Reflex.Host.Class import qualified Reflex.Patch.MapWithMove as MapWithMove import Reflex.PerformEvent.Class @@ -226,3 +227,6 @@ instance (MonadQuery t q m, Monad m) => MonadQuery t q (DynamicWriterT t w m) wh tellQueryIncremental = lift . tellQueryIncremental askQueryResult = lift askQueryResult queryIncremental = lift . queryIncremental + +instance EventWriter t w m => EventWriter t w (DynamicWriterT t v m) where + tellEvent = lift . tellEvent diff --git a/src/Reflex/EventWriter/Base.hs b/src/Reflex/EventWriter/Base.hs index 3264b37a..fff435d6 100644 --- a/src/Reflex/EventWriter/Base.hs +++ b/src/Reflex/EventWriter/Base.hs @@ -22,9 +22,10 @@ module Reflex.EventWriter.Base , withEventWriterT ) where -import Reflex.Class import Reflex.Adjustable.Class +import Reflex.Class import Reflex.EventWriter.Class (EventWriter, tellEvent) +import Reflex.DynamicWriter.Class (MonadDynamicWriter, tellDyn) import Reflex.Host.Class import Reflex.PerformEvent.Class import Reflex.PostBuild.Class @@ -267,6 +268,9 @@ instance (MonadQuery t q m, Monad m) => MonadQuery t q (EventWriterT t w m) wher askQueryResult = lift askQueryResult queryIncremental = lift . queryIncremental +instance MonadDynamicWriter t w m => MonadDynamicWriter t w (EventWriterT t v m) where + tellDyn = lift . tellDyn + instance PrimMonad m => PrimMonad (EventWriterT t w m) where type PrimState (EventWriterT t w m) = PrimState m primitive = lift . primitive From 6ddfb78b8843aaeda55fc0beb1bc1a2bf421551e Mon Sep 17 00:00:00 2001 From: Ken Micklas Date: Mon, 22 Oct 2018 17:17:05 -0400 Subject: [PATCH 048/241] Add traverseDMapWithKeyWithAdjust test for EventWriterT --- reflex.cabal | 1 + test/EventWriterT.hs | 55 +++++++++++++++++++++++++++++++++++++++++--- 2 files changed, 53 insertions(+), 3 deletions(-) diff --git a/reflex.cabal b/reflex.cabal index 63d8c071..a35cf8db 100644 --- a/reflex.cabal +++ b/reflex.cabal @@ -208,6 +208,7 @@ test-suite EventWriterT build-depends: base , containers , deepseq >= 1.3 && < 1.5 + , dependent-map , dependent-sum , lens , mtl diff --git a/test/EventWriterT.hs b/test/EventWriterT.hs index fb7edb90..ffab2340 100644 --- a/test/EventWriterT.hs +++ b/test/EventWriterT.hs @@ -1,4 +1,5 @@ {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} {-# LANGUAGE RecursiveDo #-} {-# LANGUAGE ScopedTypeVariables #-} module Main where @@ -6,6 +7,9 @@ module Main where import Control.Lens import Control.Monad import Control.Monad.Fix +import qualified Data.Dependent.Map as DMap +import Data.Functor.Misc +import qualified Data.Map as M import Data.These import Reflex @@ -28,6 +32,10 @@ main = do print os2 os3@[[Nothing, Just [2]]] <- runApp' (unwrapApp testMoribundTellEvent) [Just ()] print os3 + os4@[[Nothing, Just [2]]] <- runApp' (unwrapApp testMoribundTellEventDMap) [Just ()] + print os4 + os5@[[Nothing, Just [1, 2]]] <- runApp' (unwrapApp testLiveTellEventDMap) [Just ()] + print os5 return () unwrapApp :: (Reflex t, Monad m) => (a -> EventWriterT t [Int] m ()) -> a -> m (Event t [Int]) @@ -59,7 +67,48 @@ testMoribundTellEvent => Event t () -> EventWriterT t [Int] m () testMoribundTellEvent pulse = do - rec let tellIntOnReplce :: Int -> EventWriterT t [Int] m () - tellIntOnReplce x = tellEvent $ [x] <$ rwrFinished - (_, rwrFinished) <- runWithReplace (tellIntOnReplce 1) $ tellIntOnReplce 2 <$ pulse + rec let tellIntOnReplace :: Int -> EventWriterT t [Int] m () + tellIntOnReplace x = tellEvent $ [x] <$ rwrFinished + (_, rwrFinished) <- runWithReplace (tellIntOnReplace 1) $ tellIntOnReplace 2 <$ pulse + return () + +-- | The equivalent of 'testMoribundTellEvent' for 'traverseDMapWithKeyWithAdjust'. +testMoribundTellEventDMap + :: forall t m + . ( Reflex t + , Adjustable t m + , MonadHold t m + , MonadFix m + ) + => Event t () + -> EventWriterT t [Int] m () +testMoribundTellEventDMap pulse = do + rec let tellIntOnReplace :: Int -> EventWriterT t [Int] m () + tellIntOnReplace x = tellEvent $ [x] <$ rwrFinished + (_, rwrFinished :: Event t (PatchDMap (Const2 () Int) Identity)) <- + traverseDMapWithKeyWithAdjust + (\(Const2 ()) (Identity v) -> Identity . const v <$> tellIntOnReplace v) + (mapToDMap $ M.singleton () 1) + ((PatchDMap $ DMap.map (ComposeMaybe . Just) $ mapToDMap $ M.singleton () 2) <$ pulse) + return () + +-- | Ensures that elements which are _not_ removed can still fire 'tellEvent's +-- during the same frame as other elements are updated. +testLiveTellEventDMap + :: forall t m + . ( Reflex t + , Adjustable t m + , MonadHold t m + , MonadFix m + ) + => Event t () + -> EventWriterT t [Int] m () +testLiveTellEventDMap pulse = do + rec let tellIntOnReplace :: Int -> EventWriterT t [Int] m () + tellIntOnReplace x = tellEvent $ [x] <$ rwrFinished + (_, rwrFinished :: Event t (PatchDMap (Const2 Int ()) Identity)) <- + traverseDMapWithKeyWithAdjust + (\(Const2 k) (Identity ()) -> Identity <$> tellIntOnReplace k) + (mapToDMap $ M.singleton 1 ()) + ((PatchDMap $ DMap.map (ComposeMaybe . Just) $ mapToDMap $ M.singleton 2 ()) <$ pulse) return () From 64626cf46f4121142cec220a1a7d5b7329886cf6 Mon Sep 17 00:00:00 2001 From: Ken Micklas Date: Thu, 25 Oct 2018 17:07:05 -0400 Subject: [PATCH 049/241] Fix traverse* Adjustable methods in EventWriterT --- src/Reflex/Class.hs | 43 +++++++++++++++++++++++++++ src/Reflex/EventWriter/Base.hs | 53 ++++++++++++++-------------------- src/Reflex/FunctorMaybe.hs | 10 +++++++ 3 files changed, 75 insertions(+), 31 deletions(-) diff --git a/src/Reflex/Class.hs b/src/Reflex/Class.hs index cbfb1c3b..41f98845 100644 --- a/src/Reflex/Class.hs +++ b/src/Reflex/Class.hs @@ -44,6 +44,7 @@ module Reflex.Class -- ** Combining 'Event's , leftmost , mergeMap + , mergeIntMap , mergeMapIncremental , mergeMapIncrementalWithMove , mergeIntMapIncremental @@ -66,6 +67,7 @@ module Reflex.Class , switchHold , switchHoldPromptly , switchHoldPromptOnly + , switchHoldPromptOnlyIncremental -- ** Using 'Event's to sample 'Behavior's , tag , tagMaybe @@ -781,6 +783,10 @@ unsafeMapIncremental f g a = unsafeBuildIncremental (fmap f $ sample $ currentIn mergeMap :: (Reflex t, Ord k) => Map k (Event t a) -> Event t (Map k a) mergeMap = fmap dmapToMap . merge . mapWithFunctorToDMap +-- | Like 'mergeMap' but for 'IntMap'. +mergeIntMap :: Reflex t => IntMap (Event t a) -> Event t (IntMap a) +mergeIntMap = fmap dmapToIntMap . merge . intMapWithFunctorToDMap + -- | Create a merge whose parents can change over time mergeMapIncremental :: (Reflex t, Ord k) => Incremental t (PatchMap k (Event t a)) -> Event t (Map k a) mergeMapIncremental = fmap dmapToMap . mergeIncremental . unsafeMapIncremental mapWithFunctorToDMap (const2PatchDMapWith id) @@ -859,6 +865,43 @@ switchHoldPromptOnly e0 e' = do eLag <- switch <$> hold e0 e' return $ coincidence $ leftmost [e', eLag <$ eLag] +data ApplyElement p + = Append (PatchTarget p) + | Apply p + +-- | Like 'switchHoldPromptOnly' but for a patchable data structure of events. +switchHoldPromptOnlyIncremental + :: forall t m p pt w + . ( Reflex t + , MonadHold t m + , Functor p + , Functor pt + , FunctorMaybe pt + , Monoid (pt (Maybe w)) + , Patch (p (Maybe w)) + , PatchTarget (p (Maybe w)) ~ pt (Maybe w) + , Patch (p (Event t w)) + , PatchTarget (p (Event t w)) ~ pt (Event t w) + ) + => pt (Event t w) + -> Event t (p (Event t w)) + -> (p (Event t w) -> Event t (pt w)) + -> (Incremental t (p (Event t w)) -> Event t (pt w)) + -> m (Event t (pt w)) +switchHoldPromptOnlyIncremental e0 ee mergePatchNewElements mergePatchIncremental = do + let replaced :: Event t (p (Maybe w)) + replaced = fmap (const Nothing) <$> ee + new :: Event t (pt (Maybe w)) + new = fmap (fmap Just) $ coincidence $ fmapCheap mergePatchNewElements ee + held <- fmap (fmap Just) . mergePatchIncremental <$> holdIncremental e0 ee + let e = mergeList [fmapCheap Append held, fmapCheap Apply replaced, fmapCheap Append new] + return $ fmap (fmapMaybe id) $ ffor e $ \chain -> foldl applyElement mempty chain + where + applyElement :: pt (Maybe w) -> ApplyElement (p (Maybe w)) -> pt (Maybe w) + applyElement pt = \case + Append new -> new <> pt + Apply p -> applyAlways p pt + instance Reflex t => Align (Event t) where nil = never align = alignEventWithMaybe Just diff --git a/src/Reflex/EventWriter/Base.hs b/src/Reflex/EventWriter/Base.hs index 3264b37a..95bb5328 100644 --- a/src/Reflex/EventWriter/Base.hs +++ b/src/Reflex/EventWriter/Base.hs @@ -4,6 +4,7 @@ {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE Rank2Types #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -40,7 +41,6 @@ import Control.Monad.Ref import Control.Monad.State.Strict import Data.Dependent.Map (DMap, DSum (..)) import qualified Data.Dependent.Map as DMap -import Data.Foldable import Data.Functor.Compose import Data.Functor.Misc import Data.GADT.Compare (GCompare (..), GEq (..), GOrdering (..)) @@ -48,10 +48,11 @@ import Data.IntMap.Strict (IntMap) import qualified Data.IntMap.Strict as IntMap import Data.List.NonEmpty (NonEmpty (..)) import Data.Map (Map) +import qualified Data.Map as Map import Data.Semigroup import Data.Some (Some) import Data.Tuple -import Data.Type.Equality +import Data.Type.Equality hiding (apply) import Unsafe.Coerce @@ -135,9 +136,9 @@ instance MonadHold t m => MonadHold t (EventWriterT t w m) where instance (Reflex t, Adjustable t m, MonadHold t m, Semigroup w) => Adjustable t (EventWriterT t w m) where runWithReplace = runWithReplaceEventWriterTWith $ \dm0 dm' -> lift $ runWithReplace dm0 dm' - traverseIntMapWithKeyWithAdjust = sequenceIntMapWithAdjustEventWriterTWith (\f dm0 dm' -> lift $ traverseIntMapWithKeyWithAdjust f dm0 dm') patchIntMapNewElements mergeIntIncremental - traverseDMapWithKeyWithAdjust = sequenceDMapWithAdjustEventWriterTWith (\f dm0 dm' -> lift $ traverseDMapWithKeyWithAdjust f dm0 dm') mapPatchDMap weakenPatchDMapWith patchMapNewElements mergeMapIncremental - traverseDMapWithKeyWithAdjustWithMove = sequenceDMapWithAdjustEventWriterTWith (\f dm0 dm' -> lift $ traverseDMapWithKeyWithAdjustWithMove f dm0 dm') mapPatchDMapWithMove weakenPatchDMapWithMoveWith patchMapWithMoveNewElements mergeMapIncrementalWithMove + traverseIntMapWithKeyWithAdjust = sequenceIntMapWithAdjustEventWriterTWith (\f dm0 dm' -> lift $ traverseIntMapWithKeyWithAdjust f dm0 dm') (mergeIntMap . patchIntMapNewElementsMap) mergeIntIncremental + traverseDMapWithKeyWithAdjust = sequenceDMapWithAdjustEventWriterTWith (\f dm0 dm' -> lift $ traverseDMapWithKeyWithAdjust f dm0 dm') mapPatchDMap weakenPatchDMapWith (mergeMap . patchMapNewElementsMap) mergeMapIncremental + traverseDMapWithKeyWithAdjustWithMove = sequenceDMapWithAdjustEventWriterTWith (\f dm0 dm' -> lift $ traverseDMapWithKeyWithAdjustWithMove f dm0 dm') mapPatchDMapWithMove weakenPatchDMapWithMoveWith (mergeMap . patchMapWithMoveNewElementsMap) mergeMapIncrementalWithMove instance Requester t m => Requester t (EventWriterT t w m) where type Request (EventWriterT t w m) = Request m @@ -160,19 +161,19 @@ runWithReplaceEventWriterTWith f a0 a' = do return (fst result0, fmapCheap fst result') -- | Like 'runWithReplaceEventWriterTWith', but for 'sequenceIntMapWithAdjust'. -sequenceIntMapWithAdjustEventWriterTWith :: forall t m p w v v'. (Reflex t, MonadHold t m, Semigroup w, Functor p, Patch (p (Event t w)), PatchTarget (p (Event t w)) ~ IntMap (Event t w)) +sequenceIntMapWithAdjustEventWriterTWith :: forall t m p w v v'. (Reflex t, MonadHold t m, Semigroup w, Functor p, Patch (p (Event t w)), PatchTarget (p (Event t w)) ~ IntMap (Event t w), Patch (p (Maybe w)), PatchTarget (p (Maybe w)) ~ IntMap (Maybe w)) => ( (IntMap.Key -> v -> m (Event t w, v')) -> IntMap v -> Event t (p v) -> EventWriterT t w m (IntMap (Event t w, v'), Event t (p (Event t w, v'))) ) - -> (p (Event t w) -> [Event t w]) + -> (p (Event t w) -> Event t (IntMap w)) -> (Incremental t (p (Event t w)) -> Event t (IntMap w)) -> (IntMap.Key -> v -> EventWriterT t w m v') -> IntMap v -> Event t (p v) -> EventWriterT t w m (IntMap v', Event t (p v')) -sequenceIntMapWithAdjustEventWriterTWith base patchNewElements mergePatchIncremental f dm0 dm' = do +sequenceIntMapWithAdjustEventWriterTWith base mergePatchNewElements mergePatchIncremental f dm0 dm' = do let f' :: IntMap.Key -> v -> m (Event t w, v') f' k v = swap <$> runEventWriterT (f k v) (children0, children') <- base f' dm0 dm' @@ -182,12 +183,15 @@ sequenceIntMapWithAdjustEventWriterTWith base patchNewElements mergePatchIncreme requests0 = fmap fst children0 requests' :: Event t (p (Event t w)) requests' = fmapCheap (fmap fst) children' - childRequestMap :: Incremental t (p (Event t w)) <- holdIncremental requests0 requests' - tellEventsPromptly requests' patchNewElements $ mergePatchIncremental childRequestMap + e <- switchHoldPromptOnlyIncremental requests0 requests' mergePatchNewElements mergePatchIncremental + tellEvent $ fforMaybeCheap e $ \m -> + case IntMap.elems m of + [] -> Nothing + h : t -> Just $ sconcat $ h :| t return (result0, result') -- | Like 'runWithReplaceEventWriterTWith', but for 'sequenceDMapWithAdjust'. -sequenceDMapWithAdjustEventWriterTWith :: forall t m p p' w k v v'. (Reflex t, MonadHold t m, Semigroup w, Patch (p' (Some k) (Event t w)), PatchTarget (p' (Some k) (Event t w)) ~ Map (Some k) (Event t w)) +sequenceDMapWithAdjustEventWriterTWith :: forall t m p p' w k v v'. (Reflex t, MonadHold t m, Semigroup w, Patch (p' (Some k) (Event t w)), PatchTarget (p' (Some k) (Event t w)) ~ Map (Some k) (Event t w), GCompare k, PatchTarget (p' (Some k) w) ~ Map (Some k) w, Patch (p' (Some k) (Maybe w)), PatchTarget (p' (Some k) (Maybe w)) ~ Map (Some k) (Maybe w), Functor (p' (Some k))) => ( (forall a. k a -> v a -> m (Compose ((,) (Event t w)) v' a)) -> DMap k v -> Event t (p k v) @@ -195,13 +199,13 @@ sequenceDMapWithAdjustEventWriterTWith :: forall t m p p' w k v v'. (Reflex t, M ) -> ((forall a. Compose ((,) (Event t w)) v' a -> v' a) -> p k (Compose ((,) (Event t w)) v') -> p k v') -> ((forall a. Compose ((,) (Event t w)) v' a -> Event t w) -> p k (Compose ((,) (Event t w)) v') -> p' (Some k) (Event t w)) - -> (p' (Some k) (Event t w) -> [Event t w]) + -> (p' (Some k) (Event t w) -> Event t (PatchTarget (p' (Some k) w))) -> (Incremental t (p' (Some k) (Event t w)) -> Event t (Map (Some k) w)) -> (forall a. k a -> v a -> EventWriterT t w m (v' a)) -> DMap k v -> Event t (p k v) -> EventWriterT t w m (DMap k v', Event t (p k v')) -sequenceDMapWithAdjustEventWriterTWith base mapPatch weakenPatchWith patchNewElements mergePatchIncremental f dm0 dm' = do +sequenceDMapWithAdjustEventWriterTWith base mapPatch weakenPatchWith mergePatchNewElements mergePatchIncremental f dm0 dm' = do let f' :: forall a. k a -> v a -> m (Compose ((,) (Event t w)) v' a) f' k v = Compose . swap <$> runEventWriterT (f k v) (children0, children') <- base f' dm0 dm' @@ -211,26 +215,13 @@ sequenceDMapWithAdjustEventWriterTWith base mapPatch weakenPatchWith patchNewEle requests0 = weakenDMapWith (fst . getCompose) children0 requests' :: Event t (p' (Some k) (Event t w)) requests' = fforCheap children' $ weakenPatchWith $ fst . getCompose - childRequestMap :: Incremental t (p' (Some k) (Event t w)) <- holdIncremental requests0 requests' - tellEventsPromptly requests' patchNewElements $ mergePatchIncremental childRequestMap + e <- switchHoldPromptOnlyIncremental requests0 requests' mergePatchNewElements mergePatchIncremental + tellEvent $ fforMaybeCheap e $ \m -> + case Map.elems m of + [] -> Nothing + h : t -> Just $ sconcat $ h :| t return (result0, result') -tellEventsPromptly - :: ( Foldable f - , Reflex t - , MonadHold t m - , EventWriter t w m - ) - => Event t a - -> (a -> [Event t w]) - -> Event t (f w) - -> m () -tellEventsPromptly requests' patchNewElements mergedChildRequestMap = do - let patch0 = fforMaybeCheap mergedChildRequestMap $ \m -> case toList m of - [] -> Nothing - h : t -> Just $ sconcat $ h :| t - tellEvent =<< switchHoldPromptOnly patch0 (fmapCheap (mconcat . patchNewElements) requests') - instance PerformEvent t m => PerformEvent t (EventWriterT t w m) where type Performable (EventWriterT t w m) = Performable m performEvent_ = lift . performEvent_ diff --git a/src/Reflex/FunctorMaybe.hs b/src/Reflex/FunctorMaybe.hs index f73e0426..56435608 100644 --- a/src/Reflex/FunctorMaybe.hs +++ b/src/Reflex/FunctorMaybe.hs @@ -4,6 +4,10 @@ module Reflex.FunctorMaybe ( FunctorMaybe (..) ) where +import Data.IntMap (IntMap) +import qualified Data.IntMap as IntMap +import Data.Map (Map) +import qualified Data.Map as Map import Data.Maybe --TODO: See if there's a better class in the standard libraries already @@ -31,3 +35,9 @@ instance FunctorMaybe Maybe where -- | @fmapMaybe = mapMaybe@ instance FunctorMaybe [] where fmapMaybe = mapMaybe + +instance FunctorMaybe (Map k) where + fmapMaybe = Map.mapMaybe + +instance FunctorMaybe IntMap where + fmapMaybe = IntMap.mapMaybe From 976e89db8f20bd207c251c98eb9a5359e9b0bb17 Mon Sep 17 00:00:00 2001 From: Jappie Klooster Date: Wed, 31 Oct 2018 14:32:22 +0100 Subject: [PATCH 050/241] Add eventjoin --- src/Reflex/Class.hs | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/src/Reflex/Class.hs b/src/Reflex/Class.hs index cbfb1c3b..b85bd593 100644 --- a/src/Reflex/Class.hs +++ b/src/Reflex/Class.hs @@ -63,6 +63,7 @@ module Reflex.Class , factorEvent , filterEventKey -- ** Collapsing 'Event . Event' + , eventJoin , switchHold , switchHoldPromptly , switchHoldPromptOnly @@ -817,6 +818,10 @@ fanThese e = fanMap :: (Reflex t, Ord k) => Event t (Map k a) -> EventSelector t (Const2 k a) fanMap = fan . fmap mapToDMap +-- | switcHold never = eventjoin +eventJoin :: (Reflex t, MonadHold t m) => Event t (Event t a) -> m (Event t a) +eventJoin = switchHold never + -- | Switches to the new event whenever it receives one. Only the old event is -- considered the moment a new one is switched in; the output event will fire at -- that moment if only if the old event does. From 6c063e85d24202629d35604c640532e00713cd84 Mon Sep 17 00:00:00 2001 From: Ryan Trinkle Date: Wed, 31 Oct 2018 15:34:43 -0400 Subject: [PATCH 051/241] Small cleanups --- src/Reflex/Class.hs | 14 +++++++------- 1 file changed, 7 insertions(+), 7 deletions(-) diff --git a/src/Reflex/Class.hs b/src/Reflex/Class.hs index 41f98845..a7ba750f 100644 --- a/src/Reflex/Class.hs +++ b/src/Reflex/Class.hs @@ -889,13 +889,13 @@ switchHoldPromptOnlyIncremental -> (Incremental t (p (Event t w)) -> Event t (pt w)) -> m (Event t (pt w)) switchHoldPromptOnlyIncremental e0 ee mergePatchNewElements mergePatchIncremental = do - let replaced :: Event t (p (Maybe w)) - replaced = fmap (const Nothing) <$> ee - new :: Event t (pt (Maybe w)) - new = fmap (fmap Just) $ coincidence $ fmapCheap mergePatchNewElements ee - held <- fmap (fmap Just) . mergePatchIncremental <$> holdIncremental e0 ee - let e = mergeList [fmapCheap Append held, fmapCheap Apply replaced, fmapCheap Append new] - return $ fmap (fmapMaybe id) $ ffor e $ \chain -> foldl applyElement mempty chain + let replaced :: Event t (ApplyElement (p (Maybe w))) + replaced = fmapCheap (Apply . (Nothing <$)) ee + new :: Event t (ApplyElement (p (Maybe w))) + new = fmapCheap (Append . fmap Just) $ coincidence $ fmapCheap mergePatchNewElements ee + held <- fmapCheap (Append . fmap Just) . mergePatchIncremental <$> holdIncremental e0 ee + let e = mergeList [held, replaced, new] + return $ fmap (fmapMaybe id . foldl' applyElement mempty) e where applyElement :: pt (Maybe w) -> ApplyElement (p (Maybe w)) -> pt (Maybe w) applyElement pt = \case From 9a0deec1af9d02072523025af4ede4e959680fbe Mon Sep 17 00:00:00 2001 From: Ali Abrar Date: Mon, 5 Nov 2018 18:21:14 -0500 Subject: [PATCH 052/241] Add BehaviorWriter --- reflex.cabal | 2 + src/Reflex.hs | 2 + src/Reflex/BehaviorWriter/Base.hs | 204 +++++++++++++++++++++++++++++ src/Reflex/BehaviorWriter/Class.hs | 26 ++++ 4 files changed, 234 insertions(+) create mode 100644 src/Reflex/BehaviorWriter/Base.hs create mode 100644 src/Reflex/BehaviorWriter/Class.hs diff --git a/reflex.cabal b/reflex.cabal index 63d8c071..568713d7 100644 --- a/reflex.cabal +++ b/reflex.cabal @@ -73,6 +73,8 @@ library Reflex, Reflex.Class, Reflex.Adjustable.Class, + Reflex.BehaviorWriter.Base, + Reflex.BehaviorWriter.Class, Reflex.Collection, Reflex.Dynamic, Reflex.Dynamic.Uniq, diff --git a/src/Reflex.hs b/src/Reflex.hs index 8387c638..8bc3789d 100644 --- a/src/Reflex.hs +++ b/src/Reflex.hs @@ -7,6 +7,8 @@ module Reflex import Reflex.Class as X import Reflex.Adjustable.Class as X +import Reflex.BehaviorWriter.Base as X +import Reflex.BehaviorWriter.Class as X import Reflex.Collection as X import Reflex.Dynamic as X import Reflex.EventWriter.Base as X diff --git a/src/Reflex/BehaviorWriter/Base.hs b/src/Reflex/BehaviorWriter/Base.hs new file mode 100644 index 00000000..a7a8aad2 --- /dev/null +++ b/src/Reflex/BehaviorWriter/Base.hs @@ -0,0 +1,204 @@ +{-| +Module: Reflex.BehaviorWriter.Base +Description: Implementation of MonadBehaviorWriter +-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE StandaloneDeriving #-} +#ifdef USE_REFLEX_OPTIMIZER +{-# OPTIONS_GHC -fplugin=Reflex.Optimizer #-} +#endif +module Reflex.BehaviorWriter.Base + ( BehaviorWriterT (..) + , runBehaviorWriterT + , withBehaviorWriterT + ) where + +import Control.Monad.Exception +import Control.Monad.Identity +import Control.Monad.IO.Class +import Control.Monad.Reader +import Control.Monad.Ref +import Control.Monad.State.Strict +import Data.Dependent.Map (DMap) +import qualified Data.Dependent.Map as DMap +import Data.Functor.Misc +import Data.IntMap (IntMap) +import qualified Data.IntMap as IntMap +import Data.Map (Map) +import qualified Data.Map as Map +import Data.Some (Some) + +import Reflex.Class +import Reflex.Adjustable.Class +import Reflex.BehaviorWriter.Class +import Reflex.Host.Class +import Reflex.PerformEvent.Class +import Reflex.PostBuild.Class +import Reflex.Query.Class +import Reflex.Requester.Class +import Reflex.TriggerEvent.Class + +-- | A basic implementation of 'MonadBehaviorWriter'. +newtype BehaviorWriterT t w m a = BehaviorWriterT { unBehaviorWriterT :: StateT [Behavior t w] m a } + deriving (Functor, Applicative, Monad, MonadIO, MonadFix, MonadAsyncException, MonadException) -- The list is kept in reverse order + +-- | Run a 'BehaviorWriterT' action. The behavior writer output will be provided +-- along with the result of the action. +runBehaviorWriterT :: (Monad m, Reflex t, Monoid w) => BehaviorWriterT t w m a -> m (a, Behavior t w) +runBehaviorWriterT (BehaviorWriterT a) = do + (result, ws) <- runStateT a [] + return (result, mconcat $ reverse ws) + +-- | Map a function over the output of a 'BehaviorWriterT'. +withBehaviorWriterT :: (Monoid w, Monoid w', Reflex t, MonadHold t m) + => (w -> w') + -> BehaviorWriterT t w m a + -> BehaviorWriterT t w' m a +withBehaviorWriterT f dw = do + (r, d) <- lift $ do + (r, d) <- runBehaviorWriterT dw + let d' = fmap f d + return (r, d') + tellBehavior d + return r + +deriving instance MonadHold t m => MonadHold t (BehaviorWriterT t w m) +deriving instance MonadSample t m => MonadSample t (BehaviorWriterT t w m) + +instance MonadTrans (BehaviorWriterT t w) where + lift = BehaviorWriterT . lift + +instance MonadRef m => MonadRef (BehaviorWriterT t w m) where + type Ref (BehaviorWriterT t w m) = Ref m + newRef = lift . newRef + readRef = lift . readRef + writeRef r = lift . writeRef r + +instance MonadAtomicRef m => MonadAtomicRef (BehaviorWriterT t w m) where + atomicModifyRef r = lift . atomicModifyRef r + +instance MonadReflexCreateTrigger t m => MonadReflexCreateTrigger t (BehaviorWriterT t w m) where + newEventWithTrigger = lift . newEventWithTrigger + newFanEventWithTrigger f = lift $ newFanEventWithTrigger f + +instance (Monad m, Monoid w, Reflex t) => MonadBehaviorWriter t w (BehaviorWriterT t w m) where + tellBehavior w = BehaviorWriterT $ modify (w :) + +instance MonadReader r m => MonadReader r (BehaviorWriterT t w m) where + ask = lift ask + local f (BehaviorWriterT a) = BehaviorWriterT $ mapStateT (local f) a + reader = lift . reader + +instance PerformEvent t m => PerformEvent t (BehaviorWriterT t w m) where + type Performable (BehaviorWriterT t w m) = Performable m + performEvent_ = lift . performEvent_ + performEvent = lift . performEvent + +instance TriggerEvent t m => TriggerEvent t (BehaviorWriterT t w m) where + newTriggerEvent = lift newTriggerEvent + newTriggerEventWithOnComplete = lift newTriggerEventWithOnComplete + newEventWithLazyTriggerWithOnComplete = lift . newEventWithLazyTriggerWithOnComplete + +instance PostBuild t m => PostBuild t (BehaviorWriterT t w m) where + getPostBuild = lift getPostBuild + +instance MonadState s m => MonadState s (BehaviorWriterT t w m) where + get = lift get + put = lift . put + +instance Requester t m => Requester t (BehaviorWriterT t w m) where + type Request (BehaviorWriterT t w m) = Request m + type Response (BehaviorWriterT t w m) = Response m + requesting = lift . requesting + requesting_ = lift . requesting_ + +instance (MonadQuery t q m, Monad m) => MonadQuery t q (BehaviorWriterT t w m) where + tellQueryIncremental = lift . tellQueryIncremental + askQueryResult = lift askQueryResult + queryIncremental = lift . queryIncremental + +instance (Adjustable t m, Monoid w, MonadHold t m, Reflex t) => Adjustable t (BehaviorWriterT t w m) where + runWithReplace a0 a' = do + (result0, result') <- lift $ runWithReplace (runBehaviorWriterT a0) $ runBehaviorWriterT <$> a' + tellBehavior . join =<< hold (snd result0) (snd <$> result') + return (fst result0, fst <$> result') + traverseIntMapWithKeyWithAdjust = traverseIntMapWithKeyWithAdjustImpl traverseIntMapWithKeyWithAdjust + traverseDMapWithKeyWithAdjustWithMove = traverseDMapWithKeyWithAdjustImpl traverseDMapWithKeyWithAdjustWithMove mapPatchDMapWithMove weakenPatchDMapWithMoveWith + +traverseIntMapWithKeyWithAdjustImpl + :: forall t w v' p p' v m. + ( PatchTarget (p' (Behavior t w)) ~ IntMap (Behavior t w) + , Patch (p' (Behavior t w)) + , Monoid w + , Reflex t + , MonadHold t m + , Functor p + , p ~ p' + ) + => ( (IntMap.Key -> v -> m (v', Behavior t w)) + -> IntMap v + -> Event t (p v) + -> m (IntMap (v', Behavior t w), Event t (p (v', Behavior t w))) + ) + -> (IntMap.Key -> v -> BehaviorWriterT t w m v') + -> IntMap v + -> Event t (p v) + -> BehaviorWriterT t w m (IntMap v', Event t (p v')) +traverseIntMapWithKeyWithAdjustImpl base f (dm0 :: IntMap v) dm' = do + (result0, result') <- lift $ base (\k v -> runBehaviorWriterT $ f k v) dm0 dm' + let liftedResult0 = fmap fst result0 + liftedResult' = fmap (fmap fst) result' + liftedWritten0 :: IntMap (Behavior t w) + liftedWritten0 = fmap snd result0 + liftedWritten' = fmap (fmap snd) result' + i <- holdIncremental liftedWritten0 liftedWritten' + tellBehavior $ pull $ do + m <- sample $ currentIncremental i + mconcat . IntMap.elems <$> traverse sample m + return (liftedResult0, liftedResult') + +newtype BehaviorWriterTLoweredResult t w v a = BehaviorWriterTLoweredResult (v a, Behavior t w) + +traverseDMapWithKeyWithAdjustImpl + :: forall t w k v' p p' v m. + ( PatchTarget (p' (Some k) (Behavior t w)) ~ Map (Some k) (Behavior t w) + , Patch (p' (Some k) (Behavior t w)) + , Monoid w + , Reflex t + , MonadHold t m + ) + => ( (forall a. k a -> v a -> m (BehaviorWriterTLoweredResult t w v' a)) + -> DMap k v + -> Event t (p k v) + -> m (DMap k (BehaviorWriterTLoweredResult t w v'), Event t (p k (BehaviorWriterTLoweredResult t w v'))) + ) + -> ((forall a. BehaviorWriterTLoweredResult t w v' a -> v' a) -> p k (BehaviorWriterTLoweredResult t w v') -> p k v') + -> ((forall a. BehaviorWriterTLoweredResult t w v' a -> Behavior t w) -> p k (BehaviorWriterTLoweredResult t w v') -> p' (Some k) (Behavior t w)) + -> (forall a. k a -> v a -> BehaviorWriterT t w m (v' a)) + -> DMap k v + -> Event t (p k v) + -> BehaviorWriterT t w m (DMap k v', Event t (p k v')) +traverseDMapWithKeyWithAdjustImpl base mapPatch weakenPatchWith f (dm0 :: DMap k v) dm' = do + (result0, result') <- lift $ base (\k v -> fmap BehaviorWriterTLoweredResult $ runBehaviorWriterT $ f k v) dm0 dm' + let getValue (BehaviorWriterTLoweredResult (v, _)) = v + getWritten (BehaviorWriterTLoweredResult (_, w)) = w + liftedResult0 = DMap.map getValue result0 + liftedResult' = ffor result' $ mapPatch getValue + liftedWritten0 :: Map (Some k) (Behavior t w) + liftedWritten0 = weakenDMapWith getWritten result0 + liftedWritten' = ffor result' $ weakenPatchWith getWritten + i <- holdIncremental liftedWritten0 liftedWritten' + tellBehavior $ pull $ do + m <- sample $ currentIncremental i + mconcat . Map.elems <$> traverse sample m + return (liftedResult0, liftedResult') diff --git a/src/Reflex/BehaviorWriter/Class.hs b/src/Reflex/BehaviorWriter/Class.hs new file mode 100644 index 00000000..78320634 --- /dev/null +++ b/src/Reflex/BehaviorWriter/Class.hs @@ -0,0 +1,26 @@ +{-| +Module: Reflex.BehaviorWriter.Class +Description: This module defines the 'MonadBehaviorWriter' class +-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE UndecidableInstances #-} +#ifdef USE_REFLEX_OPTIMIZER +{-# OPTIONS_GHC -fplugin=Reflex.Optimizer #-} +#endif +module Reflex.BehaviorWriter.Class + ( MonadBehaviorWriter (..) + ) where + +import Control.Monad.Reader (ReaderT, lift) +import Reflex.Class (Behavior) + +-- | 'MonadBehaviorWriter' efficiently collects 'Behavior' values using 'tellBehavior' +-- and combines them monoidally to provide a 'Behavior' result. +class (Monad m, Monoid w) => MonadBehaviorWriter t w m | m -> t w where + tellBehavior :: Behavior t w -> m () + +instance MonadBehaviorWriter t w m => MonadBehaviorWriter t w (ReaderT r m) where + tellBehavior = lift . tellBehavior From 56fcac1bf971874ebfe7e1fa13133b9e71da27cb Mon Sep 17 00:00:00 2001 From: Ryan Trinkle Date: Thu, 8 Nov 2018 00:10:24 -0500 Subject: [PATCH 053/241] Additional cleanups --- src/Reflex/Class.hs | 67 ++++++++++++++++---------- src/Reflex/EventWriter/Base.hs | 87 +++++++++++++++++++++------------- 2 files changed, 94 insertions(+), 60 deletions(-) diff --git a/src/Reflex/Class.hs b/src/Reflex/Class.hs index a7ba750f..37174396 100644 --- a/src/Reflex/Class.hs +++ b/src/Reflex/Class.hs @@ -48,6 +48,9 @@ module Reflex.Class , mergeMapIncremental , mergeMapIncrementalWithMove , mergeIntMapIncremental + , coincidencePatchMap + , coincidencePatchMapWithMove + , coincidencePatchIntMap , mergeList , mergeWith , difference @@ -193,6 +196,7 @@ import Data.These import Data.Type.Coercion import Reflex.FunctorMaybe import Reflex.Patch +import qualified Reflex.Patch.MapWithMove as PatchMapWithMove import Debug.Trace (trace) @@ -865,42 +869,53 @@ switchHoldPromptOnly e0 e' = do eLag <- switch <$> hold e0 e' return $ coincidence $ leftmost [e', eLag <$ eLag] -data ApplyElement p - = Append (PatchTarget p) - | Apply p +-- | When the given outer event fires, condense the inner events into the contained patch. Non-firing inner events will be replaced with deletions. +coincidencePatchMap :: (Reflex t, Ord k) => Event t (PatchMap k (Event t v)) -> Event t (PatchMap k v) +coincidencePatchMap e = fmapCheap PatchMap $ coincidence $ ffor e $ \(PatchMap m) -> mergeMap $ ffor m $ \case + Nothing -> fmapCheap (const Nothing) e + Just ev -> leftmost [fmapCheap Just ev, fmapCheap (const Nothing) e] + +-- | See 'coincicencePatchMap' +coincidencePatchIntMap :: Reflex t => Event t (PatchIntMap (Event t v)) -> Event t (PatchIntMap v) +coincidencePatchIntMap e = fmapCheap PatchIntMap $ coincidence $ ffor e $ \(PatchIntMap m) -> mergeIntMap $ ffor m $ \case + Nothing -> fmapCheap (const Nothing) e + Just ev -> leftmost [fmapCheap Just ev, fmapCheap (const Nothing) e] + +-- | See 'coincicencePatchMap' +coincidencePatchMapWithMove :: (Reflex t, Ord k) => Event t (PatchMapWithMove k (Event t v)) -> Event t (PatchMapWithMove k v) +coincidencePatchMapWithMove e = fmapCheap unsafePatchMapWithMove $ coincidence $ ffor e $ \p -> mergeMap $ ffor (unPatchMapWithMove p) $ \ni -> case PatchMapWithMove._nodeInfo_from ni of + PatchMapWithMove.From_Delete -> fforCheap e $ \_ -> + ni { PatchMapWithMove._nodeInfo_from = PatchMapWithMove.From_Delete } + PatchMapWithMove.From_Move k -> fforCheap e $ \_ -> + ni { PatchMapWithMove._nodeInfo_from = PatchMapWithMove.From_Move k } + PatchMapWithMove.From_Insert ev -> leftmost + [ fforCheap ev $ \v -> + ni { PatchMapWithMove._nodeInfo_from = PatchMapWithMove.From_Insert v } + , fforCheap e $ \_ -> + ni { PatchMapWithMove._nodeInfo_from = PatchMapWithMove.From_Delete } + ] --- | Like 'switchHoldPromptOnly' but for a patchable data structure of events. switchHoldPromptOnlyIncremental :: forall t m p pt w . ( Reflex t , MonadHold t m - , Functor p - , Functor pt - , FunctorMaybe pt - , Monoid (pt (Maybe w)) - , Patch (p (Maybe w)) - , PatchTarget (p (Maybe w)) ~ pt (Maybe w) , Patch (p (Event t w)) , PatchTarget (p (Event t w)) ~ pt (Event t w) + , Patch (p w) + , PatchTarget (p w) ~ pt w + , Monoid (pt w) ) - => pt (Event t w) + => (Incremental t (p (Event t w)) -> Event t (pt w)) + -> (Event t (p (Event t w)) -> Event t (p w)) + -> pt (Event t w) -> Event t (p (Event t w)) - -> (p (Event t w) -> Event t (pt w)) - -> (Incremental t (p (Event t w)) -> Event t (pt w)) -> m (Event t (pt w)) -switchHoldPromptOnlyIncremental e0 ee mergePatchNewElements mergePatchIncremental = do - let replaced :: Event t (ApplyElement (p (Maybe w))) - replaced = fmapCheap (Apply . (Nothing <$)) ee - new :: Event t (ApplyElement (p (Maybe w))) - new = fmapCheap (Append . fmap Just) $ coincidence $ fmapCheap mergePatchNewElements ee - held <- fmapCheap (Append . fmap Just) . mergePatchIncremental <$> holdIncremental e0 ee - let e = mergeList [held, replaced, new] - return $ fmap (fmapMaybe id . foldl' applyElement mempty) e - where - applyElement :: pt (Maybe w) -> ApplyElement (p (Maybe w)) -> pt (Maybe w) - applyElement pt = \case - Append new -> new <> pt - Apply p -> applyAlways p pt +switchHoldPromptOnlyIncremental mergePatchIncremental coincidencePatch e0 e' = do + lag <- mergePatchIncremental <$> holdIncremental e0 e' + pure $ ffor (align lag (coincidencePatch e')) $ \case + This old -> old + That new -> new `applyAlways` mempty + These old new -> new `applyAlways` old instance Reflex t => Align (Event t) where nil = never diff --git a/src/Reflex/EventWriter/Base.hs b/src/Reflex/EventWriter/Base.hs index 95bb5328..11552027 100644 --- a/src/Reflex/EventWriter/Base.hs +++ b/src/Reflex/EventWriter/Base.hs @@ -4,7 +4,6 @@ {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE Rank2Types #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -136,9 +135,9 @@ instance MonadHold t m => MonadHold t (EventWriterT t w m) where instance (Reflex t, Adjustable t m, MonadHold t m, Semigroup w) => Adjustable t (EventWriterT t w m) where runWithReplace = runWithReplaceEventWriterTWith $ \dm0 dm' -> lift $ runWithReplace dm0 dm' - traverseIntMapWithKeyWithAdjust = sequenceIntMapWithAdjustEventWriterTWith (\f dm0 dm' -> lift $ traverseIntMapWithKeyWithAdjust f dm0 dm') (mergeIntMap . patchIntMapNewElementsMap) mergeIntIncremental - traverseDMapWithKeyWithAdjust = sequenceDMapWithAdjustEventWriterTWith (\f dm0 dm' -> lift $ traverseDMapWithKeyWithAdjust f dm0 dm') mapPatchDMap weakenPatchDMapWith (mergeMap . patchMapNewElementsMap) mergeMapIncremental - traverseDMapWithKeyWithAdjustWithMove = sequenceDMapWithAdjustEventWriterTWith (\f dm0 dm' -> lift $ traverseDMapWithKeyWithAdjustWithMove f dm0 dm') mapPatchDMapWithMove weakenPatchDMapWithMoveWith (mergeMap . patchMapWithMoveNewElementsMap) mergeMapIncrementalWithMove + traverseIntMapWithKeyWithAdjust = sequenceIntMapWithAdjustEventWriterTWith (\f dm0 dm' -> lift $ traverseIntMapWithKeyWithAdjust f dm0 dm') mergeIntIncremental coincidencePatchIntMap + traverseDMapWithKeyWithAdjust = sequenceDMapWithAdjustEventWriterTWith (\f dm0 dm' -> lift $ traverseDMapWithKeyWithAdjust f dm0 dm') mapPatchDMap weakenPatchDMapWith mergeMapIncremental coincidencePatchMap + traverseDMapWithKeyWithAdjustWithMove = sequenceDMapWithAdjustEventWriterTWith (\f dm0 dm' -> lift $ traverseDMapWithKeyWithAdjustWithMove f dm0 dm') mapPatchDMapWithMove weakenPatchDMapWithMoveWith mergeMapIncrementalWithMove coincidencePatchMapWithMove instance Requester t m => Requester t (EventWriterT t w m) where type Request (EventWriterT t w m) = Request m @@ -161,19 +160,29 @@ runWithReplaceEventWriterTWith f a0 a' = do return (fst result0, fmapCheap fst result') -- | Like 'runWithReplaceEventWriterTWith', but for 'sequenceIntMapWithAdjust'. -sequenceIntMapWithAdjustEventWriterTWith :: forall t m p w v v'. (Reflex t, MonadHold t m, Semigroup w, Functor p, Patch (p (Event t w)), PatchTarget (p (Event t w)) ~ IntMap (Event t w), Patch (p (Maybe w)), PatchTarget (p (Maybe w)) ~ IntMap (Maybe w)) - => ( (IntMap.Key -> v -> m (Event t w, v')) - -> IntMap v - -> Event t (p v) - -> EventWriterT t w m (IntMap (Event t w, v'), Event t (p (Event t w, v'))) - ) - -> (p (Event t w) -> Event t (IntMap w)) - -> (Incremental t (p (Event t w)) -> Event t (IntMap w)) - -> (IntMap.Key -> v -> EventWriterT t w m v') - -> IntMap v - -> Event t (p v) - -> EventWriterT t w m (IntMap v', Event t (p v')) -sequenceIntMapWithAdjustEventWriterTWith base mergePatchNewElements mergePatchIncremental f dm0 dm' = do +sequenceIntMapWithAdjustEventWriterTWith + :: forall t m p w v v' + . ( Reflex t + , MonadHold t m + , Semigroup w + , Functor p + , Patch (p (Event t w)) + , PatchTarget (p (Event t w)) ~ IntMap (Event t w) + , Patch (p w) + , PatchTarget (p w) ~ IntMap w + ) + => ( (IntMap.Key -> v -> m (Event t w, v')) + -> IntMap v + -> Event t (p v) + -> EventWriterT t w m (IntMap (Event t w, v'), Event t (p (Event t w, v'))) + ) + -> (Incremental t (p (Event t w)) -> Event t (PatchTarget (p w))) + -> (Event t (p (Event t w)) -> Event t (p w)) + -> (IntMap.Key -> v -> EventWriterT t w m v') + -> IntMap v + -> Event t (p v) + -> EventWriterT t w m (IntMap v', Event t (p v')) +sequenceIntMapWithAdjustEventWriterTWith base mergePatchIncremental coincidencePatch f dm0 dm' = do let f' :: IntMap.Key -> v -> m (Event t w, v') f' k v = swap <$> runEventWriterT (f k v) (children0, children') <- base f' dm0 dm' @@ -183,7 +192,7 @@ sequenceIntMapWithAdjustEventWriterTWith base mergePatchNewElements mergePatchIn requests0 = fmap fst children0 requests' :: Event t (p (Event t w)) requests' = fmapCheap (fmap fst) children' - e <- switchHoldPromptOnlyIncremental requests0 requests' mergePatchNewElements mergePatchIncremental + e <- switchHoldPromptOnlyIncremental mergePatchIncremental coincidencePatch requests0 requests' tellEvent $ fforMaybeCheap e $ \m -> case IntMap.elems m of [] -> Nothing @@ -191,21 +200,31 @@ sequenceIntMapWithAdjustEventWriterTWith base mergePatchNewElements mergePatchIn return (result0, result') -- | Like 'runWithReplaceEventWriterTWith', but for 'sequenceDMapWithAdjust'. -sequenceDMapWithAdjustEventWriterTWith :: forall t m p p' w k v v'. (Reflex t, MonadHold t m, Semigroup w, Patch (p' (Some k) (Event t w)), PatchTarget (p' (Some k) (Event t w)) ~ Map (Some k) (Event t w), GCompare k, PatchTarget (p' (Some k) w) ~ Map (Some k) w, Patch (p' (Some k) (Maybe w)), PatchTarget (p' (Some k) (Maybe w)) ~ Map (Some k) (Maybe w), Functor (p' (Some k))) - => ( (forall a. k a -> v a -> m (Compose ((,) (Event t w)) v' a)) - -> DMap k v - -> Event t (p k v) - -> EventWriterT t w m (DMap k (Compose ((,) (Event t w)) v'), Event t (p k (Compose ((,) (Event t w)) v'))) - ) - -> ((forall a. Compose ((,) (Event t w)) v' a -> v' a) -> p k (Compose ((,) (Event t w)) v') -> p k v') - -> ((forall a. Compose ((,) (Event t w)) v' a -> Event t w) -> p k (Compose ((,) (Event t w)) v') -> p' (Some k) (Event t w)) - -> (p' (Some k) (Event t w) -> Event t (PatchTarget (p' (Some k) w))) - -> (Incremental t (p' (Some k) (Event t w)) -> Event t (Map (Some k) w)) - -> (forall a. k a -> v a -> EventWriterT t w m (v' a)) - -> DMap k v - -> Event t (p k v) - -> EventWriterT t w m (DMap k v', Event t (p k v')) -sequenceDMapWithAdjustEventWriterTWith base mapPatch weakenPatchWith mergePatchNewElements mergePatchIncremental f dm0 dm' = do +sequenceDMapWithAdjustEventWriterTWith + :: forall t m p p' w k v v' + . ( Reflex t + , MonadHold t m + , Semigroup w + , Patch (p' (Some k) (Event t w)) + , PatchTarget (p' (Some k) (Event t w)) ~ Map (Some k) (Event t w) + , GCompare k + , Patch (p' (Some k) w) + , PatchTarget (p' (Some k) w) ~ Map (Some k) w + ) + => ( (forall a. k a -> v a -> m (Compose ((,) (Event t w)) v' a)) + -> DMap k v + -> Event t (p k v) + -> EventWriterT t w m (DMap k (Compose ((,) (Event t w)) v'), Event t (p k (Compose ((,) (Event t w)) v'))) + ) + -> ((forall a. Compose ((,) (Event t w)) v' a -> v' a) -> p k (Compose ((,) (Event t w)) v') -> p k v') + -> ((forall a. Compose ((,) (Event t w)) v' a -> Event t w) -> p k (Compose ((,) (Event t w)) v') -> p' (Some k) (Event t w)) + -> (Incremental t (p' (Some k) (Event t w)) -> Event t (PatchTarget (p' (Some k) w))) + -> (Event t (p' (Some k) (Event t w)) -> Event t (p' (Some k) w)) + -> (forall a. k a -> v a -> EventWriterT t w m (v' a)) + -> DMap k v + -> Event t (p k v) + -> EventWriterT t w m (DMap k v', Event t (p k v')) +sequenceDMapWithAdjustEventWriterTWith base mapPatch weakenPatchWith mergePatchIncremental coincidencePatch f dm0 dm' = do let f' :: forall a. k a -> v a -> m (Compose ((,) (Event t w)) v' a) f' k v = Compose . swap <$> runEventWriterT (f k v) (children0, children') <- base f' dm0 dm' @@ -215,7 +234,7 @@ sequenceDMapWithAdjustEventWriterTWith base mapPatch weakenPatchWith mergePatchN requests0 = weakenDMapWith (fst . getCompose) children0 requests' :: Event t (p' (Some k) (Event t w)) requests' = fforCheap children' $ weakenPatchWith $ fst . getCompose - e <- switchHoldPromptOnlyIncremental requests0 requests' mergePatchNewElements mergePatchIncremental + e <- switchHoldPromptOnlyIncremental mergePatchIncremental coincidencePatch requests0 requests' tellEvent $ fforMaybeCheap e $ \m -> case Map.elems m of [] -> Nothing From 25d85133f3bc11de23d9f9202a2e7f956b5ef1d3 Mon Sep 17 00:00:00 2001 From: James Deikun Date: Thu, 27 Sep 2018 19:08:49 -0400 Subject: [PATCH 054/241] `throttleBatchWithLag`, a generalized `throttle`. Should be suitable for throttling ViewSelector updates in rhyolite. --- src/Reflex/Time.hs | 80 ++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 80 insertions(+) diff --git a/src/Reflex/Time.hs b/src/Reflex/Time.hs index 914d795c..d92ba4a4 100644 --- a/src/Reflex/Time.hs +++ b/src/Reflex/Time.hs @@ -266,6 +266,86 @@ throttle t e = do delayed <- delay t outE return outE +data ThrottleState b + = Immediate + | Buffered (ThrottleBuffer b) + +data ThrottleBuffer b + = BEmpty -- Empty conflicts with lens, and hiding it would require turning + -- on PatternSynonyms + | Full b + +instance Semigroup b => Semigroup (ThrottleBuffer b) where + BEmpty <> x = x + x@(Full _) <> BEmpty = x + Full b1 <> Full b2 = Full $ b1 <> b2 + {-# INLINE (<>) #-} + +instance Semigroup b => Monoid (ThrottleBuffer b) where + mempty = BEmpty + {-# INLINE mempty #-} + mappend = (<>) + {-# INLINE mappend #-} + +-- | Throttle an input event, ensuring that the output event doesn't occur more often than you are ready for it. If the input event occurs too +-- frequently, the output event will contain semigroup-based summaries of the input firings that happened since the last output firing. +-- If the output event has not occurred recently, occurrences of the input event will cause the output event to fire immediately. +-- The first parameter is a function that receives access to the output event, and should construct an event that fires when the receiver is +-- ready for more input. For example, using @delay 20@ would give a simple time-based throttle. +throttleBatchWithLag :: (MonadFix m, MonadHold t m, PerformEvent t m, TriggerEvent t m, MonadIO (Performable m), Semigroup a) => (Event t () -> m (Event t ())) -> Event t a -> m (Event t a) +-- Invariants: +-- * Immediate mode must turn off whenever output is produced. +-- * Output must be produced whenever immediate mode turns from on to off. +-- * Immediate mode can only go from off to on when the delayed event fires. +-- * Every input firing must go into either an immediate output firing or the +-- buffer, but not both. +-- * An existing full buffer must either stay in the buffer or go to output, +-- but not both. +throttleBatchWithLag lag e = do + let f state x = case x of -- (Just $ newState, out) + This a -> -- If only the input event fires + case state of + Immediate -> -- and we're in immediate mode + -- Immediate mode turns off, and the buffer is empty. + -- We fire the output event with the input event value immediately. + (Just $ Buffered $ BEmpty, Just a) + Buffered b -> -- and we're not in immediate mode + -- Immediate mode remains off, and we accumulate the input value. + -- We don't fire the output event. + (Just $ Buffered $ b <> Full a, Nothing) + That _ -> -- If only the delayed output event fires, + case state of + Immediate -> -- and we're in immediate mode + -- Nothing happens. + (Nothing, Nothing) + Buffered BEmpty -> -- and the buffer is empty: + -- Immediate mode turns back on, and the buffer remains empty. + -- We don't fire. + (Just Immediate, Nothing) + Buffered (Full b) -> -- and the buffer is full: + -- Immediate mode remains off, and the buffer is cleared. + -- We fire with the buffered value. + (Just $ Buffered BEmpty, Just b) + These a _ -> -- If both the input and delayed output event fire simultaneously: + case state of + Immediate -> -- and we're in immediate mode + -- Immediate mode turns off, and the buffer is empty. + -- We fire with the input event's value, as it is the most recent we have seen at this moment. + (Just $ Buffered BEmpty, Just a) + Buffered BEmpty -> -- and the buffer is empty: + -- Immediate mode stays off, and the buffer remains empty. + -- We fire with the input event's value. + (Just $ Buffered BEmpty, Just a) + Buffered (Full b) -> -- and the buffer is full: + -- Immediate mode remains off, and the buffer is cleared. + -- We fire with everything including the buffered value. + (Just $ Buffered BEmpty, Just (b <> a)) + rec (_stateDyn, outE) <- mapAccumMaybeDyn f + Immediate -- We start in immediate mode with an empty buffer. + (align e delayed) + delayed <- lag (void outE) + return outE + #ifdef USE_TEMPLATE_HASKELL makeLensesWith (lensRules & simpleLenses .~ True) ''TickInfo #else From 537c268b68704a114ac3b98c5b3cf76e5716906b Mon Sep 17 00:00:00 2001 From: James Deikun Date: Mon, 1 Oct 2018 14:33:04 -0400 Subject: [PATCH 055/241] style things --- src/Reflex/Time.hs | 14 +++++++++++--- 1 file changed, 11 insertions(+), 3 deletions(-) diff --git a/src/Reflex/Time.hs b/src/Reflex/Time.hs index d92ba4a4..e706c3fc 100644 --- a/src/Reflex/Time.hs +++ b/src/Reflex/Time.hs @@ -1,5 +1,7 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveTraversable #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE RecursiveDo #-} @@ -24,12 +26,14 @@ import Control.Monad import Control.Monad.Fix import Control.Monad.IO.Class import Data.Align +import Data.Data (Data) import Data.Fixed import Data.Sequence (Seq, (|>)) import qualified Data.Sequence as Seq import Data.These import Data.Time.Clock import Data.Typeable +import GHC.Generics (Generic) import System.Random data TickInfo @@ -269,16 +273,20 @@ throttle t e = do data ThrottleState b = Immediate | Buffered (ThrottleBuffer b) + deriving (Eq, Ord, Show, Functor, Foldable, Traversable, Generic, Data, Typeable) data ThrottleBuffer b = BEmpty -- Empty conflicts with lens, and hiding it would require turning -- on PatternSynonyms | Full b + deriving (Eq, Ord, Show, Functor, Foldable, Traversable, Generic, Data, Typeable) instance Semigroup b => Semigroup (ThrottleBuffer b) where - BEmpty <> x = x - x@(Full _) <> BEmpty = x - Full b1 <> Full b2 = Full $ b1 <> b2 + x <> y = case x of + BEmpty -> y + Full b1 -> case y of + BEmpty -> x + Full b2 -> Full $ b1 <> b2 {-# INLINE (<>) #-} instance Semigroup b => Monoid (ThrottleBuffer b) where From 2e2e19d37a5f1151fe985190b479016640751578 Mon Sep 17 00:00:00 2001 From: James Deikun Date: Tue, 2 Oct 2018 16:38:04 -0400 Subject: [PATCH 056/241] fix naming and 1 warning --- src/Reflex/Time.hs | 52 +++++++++++++++++++++++----------------------- 1 file changed, 26 insertions(+), 26 deletions(-) diff --git a/src/Reflex/Time.hs b/src/Reflex/Time.hs index e706c3fc..43917688 100644 --- a/src/Reflex/Time.hs +++ b/src/Reflex/Time.hs @@ -271,26 +271,26 @@ throttle t e = do return outE data ThrottleState b - = Immediate - | Buffered (ThrottleBuffer b) + = ThrottleState_Immediate + | ThrottleState_Buffered (ThrottleBuffer b) deriving (Eq, Ord, Show, Functor, Foldable, Traversable, Generic, Data, Typeable) data ThrottleBuffer b - = BEmpty -- Empty conflicts with lens, and hiding it would require turning + = ThrottleBuffer_Empty -- Empty conflicts with lens, and hiding it would require turning -- on PatternSynonyms - | Full b + | ThrottleBuffer_Full b deriving (Eq, Ord, Show, Functor, Foldable, Traversable, Generic, Data, Typeable) instance Semigroup b => Semigroup (ThrottleBuffer b) where x <> y = case x of - BEmpty -> y - Full b1 -> case y of - BEmpty -> x - Full b2 -> Full $ b1 <> b2 + ThrottleBuffer_Empty -> y + ThrottleBuffer_Full b1 -> case y of + ThrottleBuffer_Empty -> x + ThrottleBuffer_Full b2 -> ThrottleBuffer_Full $ b1 <> b2 {-# INLINE (<>) #-} instance Semigroup b => Monoid (ThrottleBuffer b) where - mempty = BEmpty + mempty = ThrottleBuffer_Empty {-# INLINE mempty #-} mappend = (<>) {-# INLINE mappend #-} @@ -300,7 +300,7 @@ instance Semigroup b => Monoid (ThrottleBuffer b) where -- If the output event has not occurred recently, occurrences of the input event will cause the output event to fire immediately. -- The first parameter is a function that receives access to the output event, and should construct an event that fires when the receiver is -- ready for more input. For example, using @delay 20@ would give a simple time-based throttle. -throttleBatchWithLag :: (MonadFix m, MonadHold t m, PerformEvent t m, TriggerEvent t m, MonadIO (Performable m), Semigroup a) => (Event t () -> m (Event t ())) -> Event t a -> m (Event t a) +throttleBatchWithLag :: (MonadFix m, MonadHold t m, PerformEvent t m, Semigroup a) => (Event t () -> m (Event t ())) -> Event t a -> m (Event t a) -- Invariants: -- * Immediate mode must turn off whenever output is produced. -- * Output must be produced whenever immediate mode turns from on to off. @@ -313,43 +313,43 @@ throttleBatchWithLag lag e = do let f state x = case x of -- (Just $ newState, out) This a -> -- If only the input event fires case state of - Immediate -> -- and we're in immediate mode + ThrottleState_Immediate -> -- and we're in immediate mode -- Immediate mode turns off, and the buffer is empty. -- We fire the output event with the input event value immediately. - (Just $ Buffered $ BEmpty, Just a) - Buffered b -> -- and we're not in immediate mode + (Just $ ThrottleState_Buffered $ ThrottleBuffer_Empty, Just a) + ThrottleState_Buffered b -> -- and we're not in immediate mode -- Immediate mode remains off, and we accumulate the input value. -- We don't fire the output event. - (Just $ Buffered $ b <> Full a, Nothing) + (Just $ ThrottleState_Buffered $ b <> ThrottleBuffer_Full a, Nothing) That _ -> -- If only the delayed output event fires, case state of - Immediate -> -- and we're in immediate mode + ThrottleState_Immediate -> -- and we're in immediate mode -- Nothing happens. (Nothing, Nothing) - Buffered BEmpty -> -- and the buffer is empty: + ThrottleState_Buffered ThrottleBuffer_Empty -> -- and the buffer is empty: -- Immediate mode turns back on, and the buffer remains empty. -- We don't fire. - (Just Immediate, Nothing) - Buffered (Full b) -> -- and the buffer is full: + (Just ThrottleState_Immediate, Nothing) + ThrottleState_Buffered (ThrottleBuffer_Full b) -> -- and the buffer is full: -- Immediate mode remains off, and the buffer is cleared. -- We fire with the buffered value. - (Just $ Buffered BEmpty, Just b) + (Just $ ThrottleState_Buffered ThrottleBuffer_Empty, Just b) These a _ -> -- If both the input and delayed output event fire simultaneously: case state of - Immediate -> -- and we're in immediate mode + ThrottleState_Immediate -> -- and we're in immediate mode -- Immediate mode turns off, and the buffer is empty. -- We fire with the input event's value, as it is the most recent we have seen at this moment. - (Just $ Buffered BEmpty, Just a) - Buffered BEmpty -> -- and the buffer is empty: + (Just $ ThrottleState_Buffered ThrottleBuffer_Empty, Just a) + ThrottleState_Buffered ThrottleBuffer_Empty -> -- and the buffer is empty: -- Immediate mode stays off, and the buffer remains empty. -- We fire with the input event's value. - (Just $ Buffered BEmpty, Just a) - Buffered (Full b) -> -- and the buffer is full: + (Just $ ThrottleState_Buffered ThrottleBuffer_Empty, Just a) + ThrottleState_Buffered (ThrottleBuffer_Full b) -> -- and the buffer is full: -- Immediate mode remains off, and the buffer is cleared. -- We fire with everything including the buffered value. - (Just $ Buffered BEmpty, Just (b <> a)) + (Just $ ThrottleState_Buffered ThrottleBuffer_Empty, Just (b <> a)) rec (_stateDyn, outE) <- mapAccumMaybeDyn f - Immediate -- We start in immediate mode with an empty buffer. + ThrottleState_Immediate -- We start in immediate mode with an empty buffer. (align e delayed) delayed <- lag (void outE) return outE From 41e851323500b9e56ec26e297050485fb26ec0a4 Mon Sep 17 00:00:00 2001 From: Alexandre Esteves <2335822+alexfmpe@users.noreply.github.com> Date: Thu, 29 Nov 2018 00:48:09 +0000 Subject: [PATCH 057/241] Fix typo --- src/Reflex/EventWriter/Base.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Reflex/EventWriter/Base.hs b/src/Reflex/EventWriter/Base.hs index 09f04f52..d1efa632 100644 --- a/src/Reflex/EventWriter/Base.hs +++ b/src/Reflex/EventWriter/Base.hs @@ -58,7 +58,7 @@ import Unsafe.Coerce {-# DEPRECATED TellId "Do not construct this directly; use tellId instead" #-} newtype TellId w x - = TellId Int -- ^ WARNING: Do not construct this directly; use 'TellId' instead + = TellId Int -- ^ WARNING: Do not construct this directly; use 'tellId' instead deriving (Show, Eq, Ord, Enum) tellId :: Int -> TellId w w From 1e2c2bbea654c6c9be24272c26664593591aa9fc Mon Sep 17 00:00:00 2001 From: Divam Date: Sat, 22 Dec 2018 14:57:40 +0900 Subject: [PATCH 058/241] Update README.md --- README.md | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/README.md b/README.md index 99f88539..cd8b7865 100644 --- a/README.md +++ b/README.md @@ -1,15 +1,15 @@ -## Reflex +## [Reflex](https://reflex-frp.org/) ### Practical Functional Reactive Programming Reflex is an fully-deterministic, higher-order Functional Reactive Programming (FRP) interface and an engine that efficiently implements that interface. [Reflex-DOM](https://github.com/reflex-frp/reflex-dom) is a framework built on Reflex that facilitates the development of web pages, including highly-interactive single-page apps. -Comprehensive documentation is still a work in progress, but a tutorial for Reflex and Reflex-DOM is available at https://github.com/reflex-frp/reflex-platform and an introductory talk given at the New York Haskell Meetup is available here: [Part 1](https://www.youtube.com/watch?v=mYvkcskJbc4) / [Part 2](https://www.youtube.com/watch?v=3qfc9XFVo2c). - A summary of Reflex functions is available in the [quick reference](Quickref.md). -### Additional resources +Visit https://reflex-frp.org/ for more information, tutorials, documentation and examples. + +### Resources [Get started with Reflex](https://github.com/reflex-frp/reflex-platform) [/r/reflexfrp](https://www.reddit.com/r/reflexfrp) From 2cd9aacb24c8b7c4f2c0ad9ec9b541fcd7a115b6 Mon Sep 17 00:00:00 2001 From: Divam Date: Sat, 22 Dec 2018 15:18:40 +0900 Subject: [PATCH 059/241] make link sentence bold --- README.md | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/README.md b/README.md index cd8b7865..99d375bd 100644 --- a/README.md +++ b/README.md @@ -7,7 +7,7 @@ Reflex is an fully-deterministic, higher-order Functional Reactive Programming ( A summary of Reflex functions is available in the [quick reference](Quickref.md). -Visit https://reflex-frp.org/ for more information, tutorials, documentation and examples. +**Visit https://reflex-frp.org/ for more information, tutorials, documentation and examples.** ### Resources [Get started with Reflex](https://github.com/reflex-frp/reflex-platform) From 5be17e08a33ede5bd135e1399317023ab8a66a49 Mon Sep 17 00:00:00 2001 From: Divam Date: Sat, 22 Dec 2018 16:47:17 +0900 Subject: [PATCH 060/241] Add section on Hacking --- README.md | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/README.md b/README.md index 99d375bd..f697831e 100644 --- a/README.md +++ b/README.md @@ -17,3 +17,8 @@ A summary of Reflex functions is available in the [quick reference](Quickref.md) [hackage](https://hackage.haskell.org/package/reflex) [irc.freenode.net #reflex-frp](http://webchat.freenode.net?channels=%23reflex-frp&uio=d4) + +### Hacking + +Use the `./scripts/hackon reflex` script in [Reflex Platform](https://github.com/reflex-frp/reflex-platform) to checkout the source code of `reflex` locally in `reflex-platform/reflex` directory. +Then do modifications to the source in place, and use the `./tryreflex` or `./scripts/workon` scripts to create the shell to test your changes. From 4ce4f967246e366494ab1cd5667c33911e5ac446 Mon Sep 17 00:00:00 2001 From: Divam Date: Sat, 22 Dec 2018 16:49:58 +0900 Subject: [PATCH 061/241] Add examples link --- README.md | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/README.md b/README.md index f697831e..81c836fb 100644 --- a/README.md +++ b/README.md @@ -7,7 +7,7 @@ Reflex is an fully-deterministic, higher-order Functional Reactive Programming ( A summary of Reflex functions is available in the [quick reference](Quickref.md). -**Visit https://reflex-frp.org/ for more information, tutorials, documentation and examples.** +**Visit https://reflex-frp.org/ for more information, tutorials, documentation and [examples](https://examples.reflex-frp.org/).** ### Resources [Get started with Reflex](https://github.com/reflex-frp/reflex-platform) From 797e105dce3a04d9becd3c60bb02c41045dae710 Mon Sep 17 00:00:00 2001 From: Alexandre Esteves <2335822+alexfmpe@users.noreply.github.com> Date: Thu, 27 Dec 2018 10:25:44 +0000 Subject: [PATCH 062/241] Fix typos --- test/Reflex/TestPlan.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/test/Reflex/TestPlan.hs b/test/Reflex/TestPlan.hs index 1d5bb692..943bb9e3 100644 --- a/test/Reflex/TestPlan.hs +++ b/test/Reflex/TestPlan.hs @@ -26,8 +26,8 @@ import Reflex.Class import Prelude class (Reflex t, MonadHold t m, MonadFix m) => TestPlan t m where - -- | Speicify a plan of an input Event firing - -- Occurances must be in the future (i.e. Time > 0) + -- | Specify a plan of an input Event firing + -- Occurrences must be in the future (i.e. Time > 0) -- Initial specification is plan :: [(Word, a)] -> m (Event t a) From 3fdf73b300866d9dabb35ad99f8580440ba2660c Mon Sep 17 00:00:00 2001 From: Zachary Churchill Date: Mon, 31 Dec 2018 15:32:54 -0500 Subject: [PATCH 063/241] add Reflex.Network documentation I use these functions frequently, and they seem undocumented --- Quickref.md | 17 +++++++++++++++++ 1 file changed, 17 insertions(+) diff --git a/Quickref.md b/Quickref.md index 1db20f54..c2f16d1e 100644 --- a/Quickref.md +++ b/Quickref.md @@ -292,3 +292,20 @@ Th typeclasses and their associated annotations include: [P,T] delay :: NominalDiffTime -> Event t a -> m (Event t a) ``` +## Networks + +```haskell +-- Functions from Reflex.Network used to deal with Dynamics/Events carrying (m a) + +-- Given a Dynamic of network-creating actions, create a network that is recreated whenever the Dynamic updates. +-- The returned Event of network results occurs when the Dynamic does. Note: Often, the type a is an Event, +-- in which case the return value is an Event-of-Events that would typically be flattened (via switchPromptly). +[P,A] networkView :: Dynamic (m a) -> m (Event a) + +-- Given an initial network and an Event of network-creating actions, create a network that is recreated whenever the +-- Event fires. The returned Dynamic of network results occurs when the Event does. Note: Often, the type a is an +-- Event, in which case the return value is a Dynamic-of-Events that would typically be flattened. +[H,A] networkHold :: m a -> Event (m a) -> m (Dynamic a) + +-- Render a placeholder network to be shown while another network is not yet done building +[P,A] untilReady :: m a -> m b -> m (a, Event b) From 666d885c176bbc2d98b6756c448db64722c64f95 Mon Sep 17 00:00:00 2001 From: Phil de Joux Date: Wed, 2 Jan 2019 13:21:53 -0500 Subject: [PATCH 064/241] Fix the typo behvior, choose between a and the. --- src/Reflex/Class.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Reflex/Class.hs b/src/Reflex/Class.hs index 37174396..0676c9b0 100644 --- a/src/Reflex/Class.hs +++ b/src/Reflex/Class.hs @@ -926,7 +926,7 @@ instance Reflex t => Align (Event t) where gate :: Reflex t => Behavior t Bool -> Event t a -> Event t a gate = attachWithMaybe $ \allow a -> if allow then Just a else Nothing --- | Create a new behavior given a starting behavior and switch to a the behvior +-- | Create a new behavior given a starting behavior and switch to a behavior -- carried by the event when it fires. switcher :: (Reflex t, MonadHold t m) => Behavior t a -> Event t (Behavior t a) -> m (Behavior t a) From 846e6e053a7d49db5759c05b60f1281fea2e0632 Mon Sep 17 00:00:00 2001 From: Phil de Joux Date: Fri, 4 Jan 2019 06:21:21 -0500 Subject: [PATCH 065/241] Choose the over a as suggested in review, #251. --- src/Reflex/Class.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/Reflex/Class.hs b/src/Reflex/Class.hs index 0676c9b0..55fae5fa 100644 --- a/src/Reflex/Class.hs +++ b/src/Reflex/Class.hs @@ -926,8 +926,8 @@ instance Reflex t => Align (Event t) where gate :: Reflex t => Behavior t Bool -> Event t a -> Event t a gate = attachWithMaybe $ \allow a -> if allow then Just a else Nothing --- | Create a new behavior given a starting behavior and switch to a behavior --- carried by the event when it fires. +-- | Create a new behavior given a starting behavior and switch to the behavior +-- carried by the event when it fires. switcher :: (Reflex t, MonadHold t m) => Behavior t a -> Event t (Behavior t a) -> m (Behavior t a) switcher b eb = pull . (sample <=< sample) <$> hold b eb From 86f8c828cacfd8b08e59b3cdef32833280f585d1 Mon Sep 17 00:00:00 2001 From: chessai Date: Wed, 9 Jan 2019 17:01:21 -0500 Subject: [PATCH 066/241] outsource dynamic spider's fmap --- src/Reflex/Spider/Internal.hs | 6 +++++- 1 file changed, 5 insertions(+), 1 deletion(-) diff --git a/src/Reflex/Spider/Internal.hs b/src/Reflex/Spider/Internal.hs index 6fb43e43..47f37c10 100644 --- a/src/Reflex/Spider/Internal.hs +++ b/src/Reflex/Spider/Internal.hs @@ -2307,9 +2307,13 @@ newJoinDyn d = in Reflex.Spider.Internal.unsafeBuildDynamic readV0 v' instance HasSpiderTimeline x => Functor (Reflex.Class.Dynamic (SpiderTimeline x)) where - fmap f = SpiderDynamic . newMapDyn f . unSpiderDynamic + fmap = mapDynamicSpider x <$ d = R.unsafeBuildDynamic (return x) $ x <$ R.updated d +mapDynamicSpider :: HasSpiderTimeline x => (a -> b) -> Reflex.Class.Dynamic (SpiderTimeline x) a -> Reflex.Class.Dynamic (SpiderTimeline x) b +mapDynamicSpider f = SpiderDynamic . newMapDyn f . unSpiderDynamic +{-# INLINE [1] mapDynamicSpider #-} + instance HasSpiderTimeline x => Applicative (Reflex.Class.Dynamic (SpiderTimeline x)) where pure = SpiderDynamic . dynamicConst #if MIN_VERSION_base(4,10,0) From 28ca47b7731de4bccde31ce08e58e58294db21b8 Mon Sep 17 00:00:00 2001 From: Ken Micklas Date: Wed, 21 Nov 2018 18:15:48 -0500 Subject: [PATCH 067/241] Add PrimMonad instance for QueryT --- src/Reflex/Query/Base.hs | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/src/Reflex/Query/Base.hs b/src/Reflex/Query/Base.hs index 66dec13f..5ef4e07f 100644 --- a/src/Reflex/Query/Base.hs +++ b/src/Reflex/Query/Base.hs @@ -22,6 +22,7 @@ module Reflex.Query.Base import Control.Applicative (liftA2) import Control.Monad.Exception import Control.Monad.Fix +import Control.Monad.Primitive import Control.Monad.Reader import Control.Monad.Ref import Control.Monad.State.Strict @@ -244,6 +245,10 @@ instance (Reflex t, MonadFix m, Group q, Additive q, Query q, MonadHold t m, Adj instance MonadTrans (QueryT t q) where lift = QueryT . lift . lift . lift +instance PrimMonad m => PrimMonad (QueryT t q m) where + type PrimState (QueryT t q m) = PrimState m + primitive = lift . primitive + instance PostBuild t m => PostBuild t (QueryT t q m) where getPostBuild = lift getPostBuild From a175e612a3f2adf3298dd9cde09940f215b2a62c Mon Sep 17 00:00:00 2001 From: Luigy Leon Date: Wed, 16 Jan 2019 12:43:32 -0500 Subject: [PATCH 068/241] Hlint fixes these were reported to be redundant --- src/Reflex/BehaviorWriter/Base.hs | 2 -- 1 file changed, 2 deletions(-) diff --git a/src/Reflex/BehaviorWriter/Base.hs b/src/Reflex/BehaviorWriter/Base.hs index a7a8aad2..16c94cc3 100644 --- a/src/Reflex/BehaviorWriter/Base.hs +++ b/src/Reflex/BehaviorWriter/Base.hs @@ -6,11 +6,9 @@ Description: Implementation of MonadBehaviorWriter {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE StandaloneDeriving #-} From 90642eea2d836e74a4b411465001796c93be6331 Mon Sep 17 00:00:00 2001 From: Luigy Leon Date: Wed, 16 Jan 2019 13:27:58 -0500 Subject: [PATCH 069/241] Fix build for QueryT test Newer versions than 0.4.0.0 of monoidal-containers will include an align instance, but it is not present in hackage yet. --- test/QueryT.hs | 7 ++++++- 1 file changed, 6 insertions(+), 1 deletion(-) diff --git a/test/QueryT.hs b/test/QueryT.hs index cbd6e079..a1948078 100644 --- a/test/QueryT.hs +++ b/test/QueryT.hs @@ -1,15 +1,16 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE RankNTypes #-} +{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} import Control.Lens import Control.Monad.Fix import Data.Align -import Data.AppendMap () -- for the Align instance import qualified Data.AppendMap as AMap import Data.Functor.Misc import Data.Map (Map) @@ -36,6 +37,10 @@ instance (Ord k, Query a, Eq (QueryResult a), Align (MonoidalMap k)) => Query (S newtype Selector k a = Selector { unSelector :: MonoidalMap k a } deriving (Show, Read, Eq, Ord, Functor) +#if !(MIN_VERSION_monoidal_containers(0,4,1)) +deriving instance Ord k => Align (MonoidalMap k) +#endif + instance (Ord k, Eq a, Monoid a, Align (MonoidalMap k)) => Semigroup (Selector k a) where (Selector a) <> (Selector b) = Selector $ fmapMaybe id $ f a b where From 54aa3c32960390f025abb414fba144fe30f78769 Mon Sep 17 00:00:00 2001 From: Luigy Leon Date: Wed, 16 Jan 2019 14:11:58 -0500 Subject: [PATCH 070/241] Drop travis --- .travis.yml | 16 ---------------- 1 file changed, 16 deletions(-) delete mode 100644 .travis.yml diff --git a/.travis.yml b/.travis.yml deleted file mode 100644 index 0ddf5851..00000000 --- a/.travis.yml +++ /dev/null @@ -1,16 +0,0 @@ -# Cache Buster: 0 -language: nix -cache: - directories: - - /nix -matrix: - include: - - env: COMPILER=ghc7103 - - env: COMPILER=ghc821 - - env: COMPILER=ghc802 - - env: COMPILER=ghcjs -script: - - set -e - - nix-build -E "with (import {}); pkgs.haskell.packages.$COMPILER.callPackage ./default.nix { }" - - nix-collect-garbage -d # This is important to do right before 'script' ends so the cache gets GCed - From 1a7da68f2c1e9ba1db6df6a4a64211d97e595176 Mon Sep 17 00:00:00 2001 From: Luigy Leon Date: Wed, 16 Jan 2019 14:12:07 -0500 Subject: [PATCH 071/241] Add hydra configuration --- hydra.json | 29 ++++++++++++++++++++++ jobsets.json | 70 ++++++++++++++++++++++++++++++++++++++++++++++++++++ release.nix | 15 +++++++++++ 3 files changed, 114 insertions(+) create mode 100644 hydra.json create mode 100644 jobsets.json create mode 100644 release.nix diff --git a/hydra.json b/hydra.json new file mode 100644 index 00000000..a204840a --- /dev/null +++ b/hydra.json @@ -0,0 +1,29 @@ +{ + "enabled": 1, + "hidden": true, + "description": "Jobsets", + "nixexprinput": "src", + "nixexprpath": "jobsets.nix", + "checkinterval": 300, + "schedulingshares": 100, + "enableemail": false, + "emailoverride": "", + "keepnr": 10, + "inputs": { + "src": { + "type": "git", + "value": "https://github.com/reflex-frp/reflex.git develop", + "emailresponsible": false + }, + "nixpkgs": { + "type": "git", + "value": "https://github.com/NixOS/nixpkgs-channels nixos-unstable", + "emailresponsible": false + }, + "prs": { + "type": "githubpulls", + "value": "reflex-frp reflex", + "emailresponsible": false + } + } +} diff --git a/jobsets.json b/jobsets.json new file mode 100644 index 00000000..741badbc --- /dev/null +++ b/jobsets.json @@ -0,0 +1,70 @@ +{ prs }: + +let + pkgs = import ./nixpkgs {}; + mkFetchGithub = value: { + inherit value; + type = "git"; + emailresponsible = false; + }; +in +with pkgs.lib; +let + defaults = jobs: { + inherit (jobs) description; + enabled = 1; + hidden = false; + keepnr = 10; + schedulingshares = 100; + checkinterval = 120; + enableemail = false; + emailoverride = ""; + nixexprinput = "reflex"; + nixexprpath = "release.nix"; + inputs = jobs.inputs // { + nixpkgs = { + type = "git"; + value = "https://github.com/NixOS/nixpkgs-channels nixos-unstable"; + emailresponsible = false; + }; + config = { + type = "nix"; + value = "{ android_sdk.accept_license = true; }"; + emailresponsible = false; + }; + }; + }; + branchJobset = branch: defaults { + description = "reflex-${branch}"; + inputs = { + reflex = { + value = "https://github.com/reflex-frp/reflex ${branch}"; + type = "git"; + emailresponsible = false; + }; + }; + }; + makePr = num: info: { + name = "reflex-pr-${num}"; + value = defaults { + description = "#${num}: ${info.title}"; + inputs = { + reflex = { + #NOTE: This should really use "pull/${num}/merge"; however, GitHub's + #status checks only operate on PR heads. This creates a race + #condition, which can currently only be solved by requiring PRs to be + #up to date before they're merged. See + #https://github.com/isaacs/github/issues/1002 + value = "https://github.com/reflex-frp/reflex pull/${num}/head"; + type = "git"; + emailresponsible = false; + }; + }; + }; + }; + processedPrs = mapAttrs' makePr (builtins.fromJSON (builtins.readFile prs)); + jobsetsAttrs = processedPrs // + genAttrs ["develop"] branchJobset; +in { + jobsets = pkgs.writeText "spec.json" (builtins.toJSON jobsetsAttrs); +} diff --git a/release.nix b/release.nix new file mode 100644 index 00000000..07c04a31 --- /dev/null +++ b/release.nix @@ -0,0 +1,15 @@ +{ rp-src ? (import {}).fetchFromGitHub { + owner = "reflex-frp"; + repo = "reflex-platform"; + rev = "384cd850f3adf1d404bced2424b5f6efb0f415f2"; + sha256 = "1ws77prqx8khmp8j6br1ij4k2v4dlgv170r9fmg0p1jivfbn8y9d"; + } +}: +let + rp = import rp-src {}; + inherit (rp.nixpkgs) lib; + compilers = ["ghc8_4" "ghc8_0" "ghcjs8_4" "ghcjs8_0"]; +in lib.genAttrs compilers (ghc: { + reflex-useTemplateHaskell = rp.${ghc}.callPackage ./. { useTemplateHaskell = true; }; + reflex = rp.${ghc}.callPackage ./. { useTemplateHaskell = false; }; +}) From f874b37ba8df73f177f1749b6c20777224ad77c8 Mon Sep 17 00:00:00 2001 From: Luigy Leon Date: Wed, 16 Jan 2019 17:38:24 -0500 Subject: [PATCH 072/241] jobsets.json -> jobsets.nix --- jobsets.json => jobsets.nix | 0 1 file changed, 0 insertions(+), 0 deletions(-) rename jobsets.json => jobsets.nix (100%) diff --git a/jobsets.json b/jobsets.nix similarity index 100% rename from jobsets.json rename to jobsets.nix From 7ae2190e7267d2d8ca21b9bd30fc9065296f2b83 Mon Sep 17 00:00:00 2001 From: Luigy Leon Date: Wed, 16 Jan 2019 18:08:42 -0500 Subject: [PATCH 073/241] Fix jobsets.nix --- jobsets.nix | 2 +- reflex-platform.nix | 8 ++++++++ release.nix | 8 +------- 3 files changed, 10 insertions(+), 8 deletions(-) create mode 100644 reflex-platform.nix diff --git a/jobsets.nix b/jobsets.nix index 741badbc..bf1c30aa 100644 --- a/jobsets.nix +++ b/jobsets.nix @@ -1,7 +1,7 @@ { prs }: let - pkgs = import ./nixpkgs {}; + pkgs = (import ./reflex-platform.nix {}).nixpkgs; mkFetchGithub = value: { inherit value; type = "git"; diff --git a/reflex-platform.nix b/reflex-platform.nix new file mode 100644 index 00000000..e0b244b1 --- /dev/null +++ b/reflex-platform.nix @@ -0,0 +1,8 @@ +let + reflex-platform-src = (import {}).fetchFromGitHub { + owner = "reflex-frp"; + repo = "reflex-platform"; + rev = "384cd850f3adf1d404bced2424b5f6efb0f415f2"; + sha256 = "1ws77prqx8khmp8j6br1ij4k2v4dlgv170r9fmg0p1jivfbn8y9d"; + }; +in import reflex-platform-src diff --git a/release.nix b/release.nix index 07c04a31..9326cfea 100644 --- a/release.nix +++ b/release.nix @@ -1,12 +1,6 @@ -{ rp-src ? (import {}).fetchFromGitHub { - owner = "reflex-frp"; - repo = "reflex-platform"; - rev = "384cd850f3adf1d404bced2424b5f6efb0f415f2"; - sha256 = "1ws77prqx8khmp8j6br1ij4k2v4dlgv170r9fmg0p1jivfbn8y9d"; - } +{ rp ? import ./reflex-platform.nix {} }: let - rp = import rp-src {}; inherit (rp.nixpkgs) lib; compilers = ["ghc8_4" "ghc8_0" "ghcjs8_4" "ghcjs8_0"]; in lib.genAttrs compilers (ghc: { From 08414ed3a51945ed749a9c36f4ea544bd1042718 Mon Sep 17 00:00:00 2001 From: Luigy Leon Date: Wed, 16 Jan 2019 18:31:06 -0500 Subject: [PATCH 074/241] Remove mention of deprecated switchPromptly --- Quickref.md | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/Quickref.md b/Quickref.md index c2f16d1e..2d42bef9 100644 --- a/Quickref.md +++ b/Quickref.md @@ -299,7 +299,7 @@ Th typeclasses and their associated annotations include: -- Given a Dynamic of network-creating actions, create a network that is recreated whenever the Dynamic updates. -- The returned Event of network results occurs when the Dynamic does. Note: Often, the type a is an Event, --- in which case the return value is an Event-of-Events that would typically be flattened (via switchPromptly). +-- in which case the return value is an Event-of-Events that would typically be flattened (via switchHold). [P,A] networkView :: Dynamic (m a) -> m (Event a) -- Given an initial network and an Event of network-creating actions, create a network that is recreated whenever the From abdda73905051a67a6057473ff758e2e9fe9c792 Mon Sep 17 00:00:00 2001 From: Divam Date: Fri, 18 Jan 2019 19:27:41 +0900 Subject: [PATCH 075/241] Fixes for haddocks --- src/Data/FastWeakBag.hs | 4 ++-- src/Data/WeakBag.hs | 4 ++-- src/Reflex/Class.hs | 25 ++++++++++++------------- src/Reflex/Collection.hs | 8 ++++---- src/Reflex/Dynamic.hs | 31 ++++++++++++++++--------------- src/Reflex/Pure.hs | 8 ++++---- 6 files changed, 40 insertions(+), 40 deletions(-) diff --git a/src/Data/FastWeakBag.hs b/src/Data/FastWeakBag.hs index bdf10a97..e512e85d 100644 --- a/src/Data/FastWeakBag.hs +++ b/src/Data/FastWeakBag.hs @@ -42,8 +42,8 @@ import Data.IORef import System.Mem.Weak #endif --- | A @FastWeakBag a@ holds a set of values of type @a@, but does not retain them - --- that is, they can still be garbage-collected. As long as the @a@s remain +-- | A 'FastWeakBag' holds a set of values of type @/a/@, but does not retain them - +-- that is, they can still be garbage-collected. As long as the @/a/@ values remain -- alive, the 'FastWeakBag' will continue to refer to them. #ifdef GHCJS_FAST_WEAK newtype FastWeakBag a = FastWeakBag JSVal diff --git a/src/Data/WeakBag.hs b/src/Data/WeakBag.hs index 3a5f3720..f7641272 100644 --- a/src/Data/WeakBag.hs +++ b/src/Data/WeakBag.hs @@ -31,8 +31,8 @@ import qualified Data.IntMap.Strict as IntMap import Data.IORef import System.Mem.Weak --- | A @WeakBag a@ holds a set of values of type @a@, but does not retain them - --- that is, they can still be garbage-collected. As long as the @a@s remain +-- | A 'WeakBag' holds a set of values of type @/a/@, but does not retain them - +-- that is, they can still be garbage-collected. As long as the @/a/@ values remain -- alive, the 'WeakBag' will continue to refer to them. data WeakBag a = WeakBag { _weakBag_nextId :: {-# UNPACK #-} !(IORef Int) --TODO: what if this wraps around? diff --git a/src/Reflex/Class.hs b/src/Reflex/Class.hs index 55fae5fa..71d96979 100644 --- a/src/Reflex/Class.hs +++ b/src/Reflex/Class.hs @@ -34,10 +34,9 @@ module Reflex.Class , coerceDynamic , MonadSample (..) , MonadHold (..) - -- ** 'fan'-related types + -- ** 'fan' related types , EventSelector (..) , EventSelectorInt (..) - -- ** 'Incremental'-related types -- * Convenience functions , constDyn , pushAlways @@ -201,7 +200,7 @@ import qualified Reflex.Patch.MapWithMove as PatchMapWithMove import Debug.Trace (trace) -- | The 'Reflex' class contains all the primitive functionality needed for --- Functional Reactive Programming (FRP). The @t@ type parameter indicates +-- Functional Reactive Programming (FRP). The @/t/@ type parameter indicates -- which "timeline" is in use. Timelines are fully-independent FRP contexts, -- and the type of the timeline determines the FRP engine to be used. For most -- purposes, the 'Reflex.Spider' implementation is recommended. @@ -267,7 +266,7 @@ class ( MonadHold t (PushM t) -- | Create a new 'Dynamic'. The given 'PullM' must always return the most -- recent firing of the given 'Event', if any. unsafeBuildDynamic :: PullM t a -> Event t a -> Dynamic t a - -- | Create a new 'Incremental'. The given 'PullM''s value must always change + -- | Create a new 'Incremental'. The given "PullM"'s value must always change -- in the same way that the accumulated application of patches would change -- that value. unsafeBuildIncremental :: Patch p => PullM t (PatchTarget p) -> Event t p -> Incremental t p @@ -310,7 +309,7 @@ coerceDynamic :: (Reflex t, Coercible a b) => Dynamic t a -> Dynamic t b coerceDynamic = coerceWith $ dynamicCoercion Coercion -- | Construct a 'Dynamic' from a 'Behavior' and an 'Event'. The 'Behavior' --- _must_ change when and only when the 'Event' fires, such that the +-- __must__ change when and only when the 'Event' fires, such that the -- 'Behavior''s value is always equal to the most recent firing of the 'Event'; -- if this is not the case, the resulting 'Dynamic' will behave -- nondeterministically. @@ -338,7 +337,7 @@ class MonadSample t m => MonadHold t m where -- value and will be updated whenever the given 'Event' occurs. The update -- takes effect immediately after the 'Event' occurs; if the occurrence that -- sets the 'Behavior' (or one that is simultaneous with it) is used to sample - -- the 'Behavior', it will see the _old_ value of the 'Behavior', not the new + -- the 'Behavior', it will see the __old__ value of the 'Behavior', not the new -- one. hold :: a -> Event t a -> m (Behavior t a) default hold :: (m ~ f m', MonadTrans f, MonadHold t m') => a -> Event t a -> m (Behavior t a) @@ -641,7 +640,7 @@ headTailE e = do -- event returns 'True'. -- -- Starting at the current time, fire all the occurrences of the 'Event' for --- which the given predicate returns 'True'. When 'False' first is returned, +-- which the given predicate returns 'True'. When first 'False' is returned, -- do not fire, and permanently stop firing, even if 'True' values would have -- been encountered later. takeWhileE @@ -656,7 +655,7 @@ takeWhileE f = takeWhileJustE $ \v -> guard (f v) $> v -- event returns 'Just b'. -- -- Starting at the current time, fire all the occurrences of the 'Event' for --- which the given predicate returns 'Just b'. When 'Nothing' first is returned, +-- which the given predicate returns 'Just b'. When first 'Nothing' is returned, -- do not fire, and permanently stop firing, even if 'Just b' values would have -- been encountered later. takeWhileJustE @@ -829,7 +828,7 @@ fanMap = fan . fmap mapToDMap -- | Switches to the new event whenever it receives one. Only the old event is -- considered the moment a new one is switched in; the output event will fire at --- that moment if only if the old event does. +-- that moment only if the old event does. -- -- Because the simultaneous firing case is irrelevant, this function imposes -- laxer "timing requirements" on the overall circuit, avoiding many potential @@ -875,13 +874,13 @@ coincidencePatchMap e = fmapCheap PatchMap $ coincidence $ ffor e $ \(PatchMap m Nothing -> fmapCheap (const Nothing) e Just ev -> leftmost [fmapCheap Just ev, fmapCheap (const Nothing) e] --- | See 'coincicencePatchMap' +-- | See 'coincidencePatchMap' coincidencePatchIntMap :: Reflex t => Event t (PatchIntMap (Event t v)) -> Event t (PatchIntMap v) coincidencePatchIntMap e = fmapCheap PatchIntMap $ coincidence $ ffor e $ \(PatchIntMap m) -> mergeIntMap $ ffor m $ \case Nothing -> fmapCheap (const Nothing) e Just ev -> leftmost [fmapCheap Just ev, fmapCheap (const Nothing) e] --- | See 'coincicencePatchMap' +-- | See 'coincidencePatchMap' coincidencePatchMapWithMove :: (Reflex t, Ord k) => Event t (PatchMapWithMove k (Event t v)) -> Event t (PatchMapWithMove k v) coincidencePatchMapWithMove e = fmapCheap unsafePatchMapWithMove $ coincidence $ ffor e $ \p -> mergeMap $ ffor (unPatchMapWithMove p) $ \ni -> case PatchMapWithMove._nodeInfo_from ni of PatchMapWithMove.From_Delete -> fforCheap e $ \_ -> @@ -942,7 +941,7 @@ zipDyn = zipDynWith (,) -- | Combine two 'Dynamic's with a combining function. The result will change -- whenever either (or both) input 'Dynamic' changes. --- More efficient than liftA2. +-- More efficient than 'liftA2'. zipDynWith :: Reflex t => (a -> b -> c) -> Dynamic t a -> Dynamic t b -> Dynamic t c zipDynWith f da db = let eab = align (updated da) (updated db) @@ -973,7 +972,7 @@ instance (Reflex t, Monoid a) => Monoid (Dynamic t a) where -- | This function converts a 'DMap' whose elements are 'Dynamic's into a -- 'Dynamic' 'DMap'. Its implementation is more efficient than doing the same --- through the use of multiple uses of 'zipWithDyn' or 'Applicative' operators. +-- through the use of multiple uses of 'zipDynWith' or 'Applicative' operators. distributeDMapOverDynPure :: forall t k. (Reflex t, GCompare k) => DMap k (Dynamic t) -> Dynamic t (DMap k Identity) distributeDMapOverDynPure dm = case DMap.toList dm of [] -> constDyn DMap.empty diff --git a/src/Reflex/Collection.hs b/src/Reflex/Collection.hs index 70782829..d0d58eec 100644 --- a/src/Reflex/Collection.hs +++ b/src/Reflex/Collection.hs @@ -139,10 +139,10 @@ listWithKeyShallowDiff initialVals valsChanged mkChild = do --TODO: Something better than Dynamic t (Map k v) - we want something --where the Events carry diffs, not the whole value -- | Create a dynamically-changing set of Event-valued widgets. This --- is like listWithKey, specialized for widgets returning (Event t --- a). listWithKey would return 'Dynamic t (Map k (Event t a))' in --- this scenario, but listViewWithKey flattens this to 'Event t (Map --- k a)' via 'switch'. +-- is like 'listWithKey', specialized for widgets returning @/Event t a/@. +-- 'listWithKey' would return @/Dynamic t (Map k (Event t a))/@ in +-- this scenario, but 'listViewWithKey' flattens this to +-- @/Event t (Map k a)/@ via 'switch'. listViewWithKey :: (Ord k, Adjustable t m, PostBuild t m, MonadHold t m, MonadFix m) => Dynamic t (Map k v) diff --git a/src/Reflex/Dynamic.hs b/src/Reflex/Dynamic.hs index 994d918c..4d5f6d53 100644 --- a/src/Reflex/Dynamic.hs +++ b/src/Reflex/Dynamic.hs @@ -58,6 +58,7 @@ module Reflex.Dynamic , Demux , demux , demuxed + -- * Miscellaneous -- Things that probably aren't very useful: , HList (..) , FHList (..) @@ -67,7 +68,7 @@ module Reflex.Dynamic , AllAreFunctors (..) , HListPtr (..) , distributeFHListOverDynPure - -- Unsafe + -- * Unsafe , unsafeDynamic -- * Deprecated functions , apDyn @@ -130,7 +131,7 @@ holdUniqDyn = holdUniqDynBy (==) holdUniqDynBy :: (Reflex t, MonadHold t m, MonadFix m) => (a -> a -> Bool) -> Dynamic t a -> m (Dynamic t a) holdUniqDynBy eq = scanDynMaybe id (\new old -> if new `eq` old then Nothing else Just new) --- | Dynamic Maybe that can only update from Nothing to Just or Just to Just (i.e., cannot revert to Nothing) +-- | @/Dynamic Maybe/@ that can only update from @/Nothing/@ to @/Just/@ or @/Just/@ to @/Just/@ (i.e., cannot revert to @/Nothing/@) improvingMaybe :: (Reflex t, MonadHold t m, MonadFix m) => Dynamic t (Maybe a) -> m (Dynamic t (Maybe a)) improvingMaybe = scanDynMaybe id (\new _ -> if isJust new then Just new else Nothing) @@ -195,9 +196,9 @@ switchDyn :: forall t a. Reflex t => Dynamic t (Event t a) -> Event t a switchDyn d = switch (current d) -- | Switches to the new 'Event' whenever it receives one. Switching occurs --- *before* the inner 'Event' fires - so if the 'Dynamic' changes and both the +-- __before__ the inner 'Event' fires - so if the 'Dynamic' changes and both the -- old and new inner Events fire simultaneously, the output will fire with the --- value of the *new* 'Event'. +-- value of the __new__ 'Event'. -- -- Prefer 'switchDyn' to this where possible. The timing requirements that -- switching before imposes are likely to bring down your app unless you are @@ -238,7 +239,7 @@ joinDynThroughMap :: forall t k a. (Reflex t, Ord k) => Dynamic t (Map k (Dynami joinDynThroughMap = joinDyn . fmap distributeMapOverDynPure -- | Print the value of the 'Dynamic' when it is first read and on each --- subsequent change that is observed (as traceEvent), prefixed with the +-- subsequent change that is observed (as 'traceEvent'), prefixed with the -- provided string. This should /only/ be used for debugging. -- -- Note: Just like Debug.Trace.trace, the value will only be shown if something @@ -248,7 +249,7 @@ traceDyn s = traceDynWith $ \x -> s <> ": " <> show x -- | Print the result of applying the provided function to the value -- of the 'Dynamic' when it is first read and on each subsequent change --- that is observed (as traceEvent). This should /only/ be used for +-- that is observed (as 'traceEvent'). This should /only/ be used for -- debugging. -- -- Note: Just like Debug.Trace.trace, the value will only be shown if something @@ -264,27 +265,27 @@ traceDynWith f d = -- | Replace the value of the 'Event' with the current value of the 'Dynamic' -- each time the 'Event' occurs. -- --- Note: `tagPromptlyDyn d e` differs from `tag (current d) e` in the case that `e` is firing --- at the same time that `d` is changing. With `tagPromptlyDyn d e`, the *new* value of `d` --- will replace the value of `e`, whereas with `tag (current d) e`, the *old* value +-- Note: @/tagPromptlyDyn d e@/ differs from @/tag (current d) e/@ in the case that @/e/@ is firing +-- at the same time that @/d/@ is changing. With @/tagPromptlyDyn d e/@, the __new__ value of @/d@/ +-- will replace the value of @/e/@, whereas with @/tag (current d) e@/, the __old__ value -- will be used, since the 'Behavior' won't be updated until the end of the frame. -- Additionally, this means that the output 'Event' may not be used to directly change --- the input 'Dynamic', because that would mean its value depends on itself. When creating --- cyclic data flows, generally `tag (current d) e` is preferred. +-- the input 'Dynamic', because that would mean its value depends on itself. __When creating__ +-- __cyclic data flows, generally @/tag (current d) e/@ is preferred.__ tagPromptlyDyn :: Reflex t => Dynamic t a -> Event t b -> Event t a tagPromptlyDyn = attachPromptlyDynWith const -- | Attach the current value of the 'Dynamic' to the value of the -- 'Event' each time it occurs. -- --- Note: `attachPromptlyDyn d` is not the same as `attach (current d)`. See 'tagPromptlyDyn' for details. +-- Note: @/attachPromptlyDyn d/@ is not the same as @/attach (current d)/@. See 'tagPromptlyDyn' for details. attachPromptlyDyn :: Reflex t => Dynamic t a -> Event t b -> Event t (a, b) attachPromptlyDyn = attachPromptlyDynWith (,) -- | Combine the current value of the 'Dynamic' with the value of the -- 'Event' each time it occurs. -- --- Note: `attachPromptlyDynWith f d` is not the same as `attachWith f (current d)`. See 'tagPromptlyDyn' for details. +-- Note: @/attachPromptlyDynWith f d/@ is not the same as @/attachWith f (current d)/@. See 'tagPromptlyDyn' for details. attachPromptlyDynWith :: Reflex t => (a -> b -> c) -> Dynamic t a -> Event t b -> Event t c attachPromptlyDynWith f = attachPromptlyDynWithMaybe $ \a b -> Just $ f a b @@ -302,8 +303,8 @@ attachPromptlyDynWithMaybe f d e = These (_, b) a -> f a b -- Both events are firing, so use the newer value That _ -> Nothing -- The tagging event isn't firing, so don't fire --- | Factor a @Dynamic t (Maybe a)@ into a @Dynamic t (Maybe (Dynamic t a))@, --- such that the outer 'Dynamic' is updated only when the 'Maybe''s constructor +-- | Factor a @/Dynamic t (Maybe a)/@ into a @/Dynamic t (Maybe (Dynamic t a))/@, +-- such that the outer 'Dynamic' is updated only when the "Maybe"'s constructor -- chages from 'Nothing' to 'Just' or vice-versa. Whenever the constructor -- becomes 'Just', an inner 'Dynamic' will be provided, whose value will track -- the 'a' inside the 'Just'; when the constructor becomes 'Nothing', the diff --git a/src/Reflex/Pure.hs b/src/Reflex/Pure.hs index 05bff9f3..b6d0be42 100644 --- a/src/Reflex/Pure.hs +++ b/src/Reflex/Pure.hs @@ -43,12 +43,12 @@ import Data.Type.Coercion import Reflex.Class -- | A completely pure-functional 'Reflex' timeline, identifying moments in time --- with the type @t@. +-- with the type @/t/@. data Pure t --- | The Enum instance of t must be dense: for all x :: t, there must not exist --- any y :: t such that pred x < y < x. The HasTrie instance will be used --- exclusively to memoize functions of t, not for any of its other capabilities. +-- | The 'Enum' instance of @/t/@ must be dense: for all @/x :: t/@, there must not exist +-- any @/y :: t/@ such that @/'pred' x < y < x/@. The 'HasTrie' instance will be used +-- exclusively to memoize functions of @/t/@, not for any of its other capabilities. instance (Enum t, HasTrie t, Ord t) => Reflex (Pure t) where newtype Behavior (Pure t) a = Behavior { unBehavior :: t -> a } From 3e5e2847e201b4ff7e61b545284cf28ec2cd942e Mon Sep 17 00:00:00 2001 From: Divam Date: Fri, 18 Jan 2019 19:48:50 +0900 Subject: [PATCH 076/241] Minor fixes to haddock docs --- src/Reflex/Dynamic.hs | 9 ++++----- 1 file changed, 4 insertions(+), 5 deletions(-) diff --git a/src/Reflex/Dynamic.hs b/src/Reflex/Dynamic.hs index 4d5f6d53..9d50bf61 100644 --- a/src/Reflex/Dynamic.hs +++ b/src/Reflex/Dynamic.hs @@ -265,9 +265,9 @@ traceDynWith f d = -- | Replace the value of the 'Event' with the current value of the 'Dynamic' -- each time the 'Event' occurs. -- --- Note: @/tagPromptlyDyn d e@/ differs from @/tag (current d) e/@ in the case that @/e/@ is firing --- at the same time that @/d/@ is changing. With @/tagPromptlyDyn d e/@, the __new__ value of @/d@/ --- will replace the value of @/e/@, whereas with @/tag (current d) e@/, the __old__ value +-- Note: @/tagPromptlyDyn d e/@ differs from @/tag (current d) e/@ in the case that @/e/@ is firing +-- at the same time that @/d/@ is changing. With @/tagPromptlyDyn d e/@, the __new__ value of @/d/@ +-- will replace the value of @/e/@, whereas with @/tag (current d) e/@, the __old__ value -- will be used, since the 'Behavior' won't be updated until the end of the frame. -- Additionally, this means that the output 'Event' may not be used to directly change -- the input 'Dynamic', because that would mean its value depends on itself. __When creating__ @@ -293,8 +293,7 @@ attachPromptlyDynWith f = attachPromptlyDynWithMaybe $ \a b -> Just $ f a b -- current value of the 'Dynamic' value and possibly filtering if the combining -- function returns 'Nothing'. -- --- Note: `attachPromptlyDynWithMaybe f d` is not the same as `attachWithMaybe f --- (current d)`. See 'tagPromptlyDyn' for details. +-- Note: @/attachPromptlyDynWithMaybe f d/@ is not the same as @/attachWithMaybe f (current d)/@. See 'tagPromptlyDyn' for details. attachPromptlyDynWithMaybe :: Reflex t => (a -> b -> Maybe c) -> Dynamic t a -> Event t b -> Event t c attachPromptlyDynWithMaybe f d e = let e' = attach (current d) e From cb187565415666c62f94b80088fd36a01f7031fd Mon Sep 17 00:00:00 2001 From: George Wilson Date: Mon, 21 Jan 2019 09:23:35 +1000 Subject: [PATCH 077/241] Tighten base lower bound Reflex does not build with GHC 7.10 or below. --- reflex.cabal | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/reflex.cabal b/reflex.cabal index 38569984..9bd1ae8c 100644 --- a/reflex.cabal +++ b/reflex.cabal @@ -37,7 +37,7 @@ library hs-source-dirs: src build-depends: MemoTrie == 0.6.*, - base >= 4.7 && < 4.13, + base >= 4.9 && < 4.13, bifunctors >= 5.2 && < 5.6, comonad, containers >= 0.5 && < 0.7, From 2a98c1f9d9e016392912db5de1bce115c41113cd Mon Sep 17 00:00:00 2001 From: Ali Abrar Date: Tue, 22 Jan 2019 14:01:33 -0500 Subject: [PATCH 078/241] Add forRequesterData --- src/Reflex/Requester/Base.hs | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/src/Reflex/Requester/Base.hs b/src/Reflex/Requester/Base.hs index 66d7aaa4..92f6974d 100644 --- a/src/Reflex/Requester/Base.hs +++ b/src/Reflex/Requester/Base.hs @@ -27,6 +27,7 @@ module Reflex.Requester.Base , RequesterData , RequesterDataKey , traverseRequesterData + , forRequesterData , requesterDataToList , singletonRequesterData ) where @@ -130,6 +131,10 @@ traverseRequesterData f (RequesterData m) = RequesterData <$> traverseTagMapWith MyTagType_Multi2 -> traverse (traverse (traverseRequesterData f)) request MyTagType_Multi3 -> traverse (traverse (traverseRequesterData f)) request +-- | 'traverseRequesterData' with its arguments flipped +forRequesterData :: forall request response m. Applicative m => RequesterData request -> (forall a. request a -> m (response a)) -> m (RequesterData response) +forRequesterData r f = traverseRequesterData f r + data MyTagType :: * -> * where MyTagType_Single :: MyTagType (Single a) MyTagType_Multi :: MyTagType Multi From f26a473e85b39235db38e6064cf9290e7f76d121 Mon Sep 17 00:00:00 2001 From: Luigy Leon Date: Tue, 22 Jan 2019 16:01:47 -0500 Subject: [PATCH 079/241] Add readme and quickref to extra-source-files --- reflex.cabal | 3 +++ 1 file changed, 3 insertions(+) diff --git a/reflex.cabal b/reflex.cabal index 9bd1ae8c..6e036a6e 100644 --- a/reflex.cabal +++ b/reflex.cabal @@ -12,6 +12,9 @@ Build-type: Simple Cabal-version: >=1.9.2 homepage: https://reflex-frp.org bug-reports: https://github.com/reflex-frp/reflex/issues +extra-source-files: + README.md + Quickref.md flag use-reflex-optimizer description: Use the GHC plugin Reflex.Optimizer on some of the modules in the package. This is still experimental. From 4f96b76edc014faf7f81f03bae2f3bf98fa269ce Mon Sep 17 00:00:00 2001 From: Divam Date: Wed, 23 Jan 2019 08:23:24 +0900 Subject: [PATCH 080/241] Minor fixes for docs --- src/Reflex/FastWeak.hs | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/src/Reflex/FastWeak.hs b/src/Reflex/FastWeak.hs index 890ccf99..95548bc7 100644 --- a/src/Reflex/FastWeak.hs +++ b/src/Reflex/FastWeak.hs @@ -74,7 +74,7 @@ unsafeToRawJSVal :: a -> JSVal unsafeToRawJSVal v = unsafeCoerce (Val v) #else -- | A 'FastWeak' which has been promoted to a strong reference. 'getFastWeakTicketValue' --- can be used to get the referred to value without fear of @Nothing, +-- can be used to get the referred to value without fear of @Nothing@, -- and 'getFastWeakTicketWeak' can be used to get the weak version. data FastWeakTicket a = FastWeakTicket { _fastWeakTicket_val :: !a @@ -85,7 +85,8 @@ data FastWeakTicket a = FastWeakTicket -- -- 'getFastWeakValue' can be used to try and obtain a strong reference to the value. -- --- The value in a @FastWeak@ can also be kept alive by obtaining a 'FastWeakTicket' using 'getFastWeakTicket' if the value hasn't been collected yet. +-- The value in a @FastWeak@ can also be kept alive by obtaining a 'FastWeakTicket' using 'getFastWeakTicket' +-- if the value hasn't been collected yet. -- -- Synonymous with 'Weak'. type FastWeak a = Weak a From b146245687045c1f1730ab911b65c373484467f6 Mon Sep 17 00:00:00 2001 From: Divam Date: Wed, 23 Jan 2019 09:10:20 +0900 Subject: [PATCH 081/241] Add deprecated to mapPartitionEithers --- src/Data/Map/Misc.hs | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/src/Data/Map/Misc.hs b/src/Data/Map/Misc.hs index 4762d596..24d131bb 100644 --- a/src/Data/Map/Misc.hs +++ b/src/Data/Map/Misc.hs @@ -46,12 +46,13 @@ diffMap olds news = flip Map.mapMaybe (align olds news) $ \case -- See also 'Reflex.Patch.Map' and 'Reflex.Patch.MapWithMove'. applyMap :: Ord k => Map k (Maybe v) -> Map k v -> Map k v applyMap patch old = insertions `Map.union` (old `Map.difference` deletions) - where (deletions, insertions) = mapPartitionEithers $ maybeToEither <$> patch + where (deletions, insertions) = Map.mapEither id $ maybeToEither <$> patch maybeToEither = \case Nothing -> Left () Just r -> Right r -- |Split a @'Map' k (Either a b)@ into @Map k a@ and @Map k b@, equivalent to @'Map.mapEither' id@ +{-# DEPRECATED mapPartitionEithers "Use 'mapEither' instead" #-} mapPartitionEithers :: Map k (Either a b) -> (Map k a, Map k b) mapPartitionEithers = Map.mapEither id From 218506f036a9ad6937633df0856ba6cf17cd3460 Mon Sep 17 00:00:00 2001 From: Divam Date: Thu, 24 Jan 2019 04:52:10 +0900 Subject: [PATCH 082/241] Fix mapEither usage --- src/Data/Map/Misc.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Data/Map/Misc.hs b/src/Data/Map/Misc.hs index 24d131bb..f0d3e229 100644 --- a/src/Data/Map/Misc.hs +++ b/src/Data/Map/Misc.hs @@ -46,7 +46,7 @@ diffMap olds news = flip Map.mapMaybe (align olds news) $ \case -- See also 'Reflex.Patch.Map' and 'Reflex.Patch.MapWithMove'. applyMap :: Ord k => Map k (Maybe v) -> Map k v -> Map k v applyMap patch old = insertions `Map.union` (old `Map.difference` deletions) - where (deletions, insertions) = Map.mapEither id $ maybeToEither <$> patch + where (deletions, insertions) = Map.mapEither maybeToEither patch maybeToEither = \case Nothing -> Left () Just r -> Right r From 2367e547cf0dc534b452f1c7849b9b336b00dd58 Mon Sep 17 00:00:00 2001 From: Matthew Bauer Date: Tue, 22 Jan 2019 14:35:52 -0500 Subject: [PATCH 083/241] Fix missing Semigroup in ghc 8.0 Prelude in ghc 8.0 does not come with Semigroup. Importing it directly works in 8.0, 8.2, and 8.4. --- src/Reflex/Time.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Reflex/Time.hs b/src/Reflex/Time.hs index 43917688..9241eaab 100644 --- a/src/Reflex/Time.hs +++ b/src/Reflex/Time.hs @@ -28,6 +28,7 @@ import Control.Monad.IO.Class import Data.Align import Data.Data (Data) import Data.Fixed +import Data.Semigroup import Data.Sequence (Seq, (|>)) import qualified Data.Sequence as Seq import Data.These @@ -369,4 +370,3 @@ tickInfo_alreadyElapsed :: Lens' TickInfo NominalDiffTime tickInfo_alreadyElapsed f (TickInfo x1 x2 x3) = (\y -> TickInfo x1 x2 y) <$> f x3 {-# INLINE tickInfo_alreadyElapsed #-} #endif - From 63e88f16b2fccf41ffef4485e65a63d10a642b3e Mon Sep 17 00:00:00 2001 From: Divam Date: Thu, 24 Jan 2019 15:53:14 +0900 Subject: [PATCH 084/241] Add testcase of nested foldDyn from #214 --- test/Reflex/Test/CrossImpl.hs | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/test/Reflex/Test/CrossImpl.hs b/test/Reflex/Test/CrossImpl.hs index f29a06ec..2b706c7a 100644 --- a/test/Reflex/Test/CrossImpl.hs +++ b/test/Reflex/Test/CrossImpl.hs @@ -218,6 +218,11 @@ testCases = bb <- hold b $ pushAlways (const $ hold "asdf" eo) eo let b' = pull $ sample =<< sample bb return (b', e) + , (,) "foldDynWhileFiring" $ TestCase (Map.singleton 0 "zxc", Map.fromList [(1, "qwer"), (2, "lkj")]) $ \(_, e) -> do + d <- foldDyn (:) [] $ + pushAlways (\a -> foldDyn (:) [a] e) e + let b = current (join (fmap distributeListOverDynPure d)) + return (b, e) , (,) "joinDyn" $ TestCase (Map.singleton 0 (0 :: Int), Map.fromList [(1, "qwer"), (2, "lkj")]) $ \(b, e) -> do bb <- hold "b" e bd <- hold never . fmap (const e) =<< headE e From 8d70b34d7f0c5ea76d85d89dfdd01eb61a989123 Mon Sep 17 00:00:00 2001 From: Divam Date: Thu, 24 Jan 2019 19:36:50 +0900 Subject: [PATCH 085/241] Mark distributeListOverDynPure as deprecated, remove duplication. --- src/Reflex/Class.hs | 11 ++++++++++- src/Reflex/Dynamic.hs | 12 ++---------- 2 files changed, 12 insertions(+), 11 deletions(-) diff --git a/src/Reflex/Class.hs b/src/Reflex/Class.hs index 71d96979..879b36fa 100644 --- a/src/Reflex/Class.hs +++ b/src/Reflex/Class.hs @@ -991,7 +991,16 @@ distributeListOverDyn = distributeListOverDynWith id -- | Create a new 'Dynamic' by applying a combining function to a list of 'Dynamic's distributeListOverDynWith :: Reflex t => ([a] -> b) -> [Dynamic t a] -> Dynamic t b -distributeListOverDynWith f = fmap (f . map (\(Const2 _ :=> Identity v) -> v) . DMap.toList) . distributeDMapOverDynPure . DMap.fromList . map (\(k, v) -> Const2 k :=> v) . zip [0 :: Int ..] +distributeListOverDynWith f = + fmap (f . map fromDSum . DMap.toAscList) . + distributeDMapOverDynPure . + DMap.fromDistinctAscList . + zipWith toDSum [0..] + where + toDSum :: Int -> Dynamic t a -> DSum (Const2 Int a) (Dynamic t) + toDSum k v = Const2 k :=> v + fromDSum :: DSum (Const2 Int a) Identity -> a + fromDSum (Const2 _ :=> Identity v) = v -- | Create a new 'Event' that occurs when the first supplied 'Event' occurs -- unless the second supplied 'Event' occurs simultaneously. diff --git a/src/Reflex/Dynamic.hs b/src/Reflex/Dynamic.hs index 9d50bf61..2fe7714b 100644 --- a/src/Reflex/Dynamic.hs +++ b/src/Reflex/Dynamic.hs @@ -220,17 +220,9 @@ distributeMapOverDynPure = fmap dmapToMap . distributeDMapOverDynPure . mapWithF -- | Convert a list with 'Dynamic' elements into a 'Dynamic' of a list with -- non-'Dynamic' elements, preserving the order of the elements. +{-# DEPRECATED distributeListOverDynPure "Use 'distributeListOverDyn' instead" #-} distributeListOverDynPure :: Reflex t => [Dynamic t v] -> Dynamic t [v] -distributeListOverDynPure = - fmap (map fromDSum . DMap.toAscList) . - distributeDMapOverDynPure . - DMap.fromDistinctAscList . - zipWith toDSum [0..] - where - toDSum :: Int -> Dynamic t a -> DSum (Const2 Int a) (Dynamic t) - toDSum k v = Const2 k :=> v - fromDSum :: DSum (Const2 Int a) Identity -> a - fromDSum (Const2 _ :=> Identity v) = v +distributeListOverDynPure = distributeListOverDyn --TODO: Generalize this to functors other than Maps -- | Combine a 'Dynamic' of a 'Map' of 'Dynamic's into a 'Dynamic' From 3785bc08c92ecdc197fde0975713215d4720dd39 Mon Sep 17 00:00:00 2001 From: Tom Smalley Date: Thu, 24 Jan 2019 13:34:11 +0000 Subject: [PATCH 086/241] Make RequesterT tests build again --- reflex.cabal | 4 +++- test/RequesterT.hs | 20 +++++++++++--------- 2 files changed, 14 insertions(+), 10 deletions(-) diff --git a/reflex.cabal b/reflex.cabal index 6e036a6e..c13ba80e 100644 --- a/reflex.cabal +++ b/reflex.cabal @@ -233,14 +233,16 @@ test-suite RequesterT main-is: RequesterT.hs hs-source-dirs: test build-depends: base + , containers + , deepseq >= 1.3 && < 1.5 , dependent-sum , dependent-map , lens + , mtl , these , transformers , reflex , ref-tf - buildable: False other-modules: Reflex.TestPlan Reflex.Plan.Pure diff --git a/test/RequesterT.hs b/test/RequesterT.hs index f495e6c1..77ae53a3 100644 --- a/test/RequesterT.hs +++ b/test/RequesterT.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE BangPatterns #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE RankNTypes #-} @@ -20,18 +21,19 @@ data RequestInt a where main :: IO () main = do - os1@[[Just [10,9,8,7,6,5,4,3,2,1]]] <- runApp' (unwrapApp testOrdering) $ + os1 <- runApp' (unwrapApp testOrdering) $ [ Just () ] print os1 - os2@[[Just [1,3,5,7,9]],[Nothing,Nothing],[Just [2,4,6,8,10]],[Just [2,4,6,8,10],Nothing]] - <- runApp' (unwrapApp testSimultaneous) $ map Just $ - [ This () - , That () - , This () - , These () () - ] + let ![[Just [10,9,8,7,6,5,4,3,2,1]]] = os1 + os2 <- runApp' (unwrapApp testSimultaneous) $ map Just $ + [ This () + , That () + , This () + , These () () + ] print os2 + let ![[Just [1,3,5,7,9]],[Nothing,Nothing],[Just [2,4,6,8,10]],[Just [2,4,6,8,10],Nothing]] = os2 return () unwrapRequest :: DSum tag RequestInt -> Int @@ -43,7 +45,7 @@ unwrapApp :: ( Reflex t, Monad m ) -> m (Event t [Int]) unwrapApp x appIn = do ((), e) <- runRequesterT (x appIn) never - return $ fmap (map unwrapRequest . DMap.toList) e + return $ fmap (map unwrapRequest . requesterDataToList) e testOrdering :: ( Response m ~ Identity , Request m ~ RequestInt From 633193612603cf2b8ea7a56226ef991d978d8510 Mon Sep 17 00:00:00 2001 From: Tom Smalley Date: Thu, 24 Jan 2019 19:54:18 +0000 Subject: [PATCH 087/241] Add EventWriterT moribund tests to RequesterT tests --- test/RequesterT.hs | 81 +++++++++++++++++++++++++++++++++++++++++++++- 1 file changed, 80 insertions(+), 1 deletion(-) diff --git a/test/RequesterT.hs b/test/RequesterT.hs index 77ae53a3..c4c9fdee 100644 --- a/test/RequesterT.hs +++ b/test/RequesterT.hs @@ -2,13 +2,17 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecursiveDo #-} {-# LANGUAGE ScopedTypeVariables #-} module Main where import Control.Lens import Control.Monad +import Control.Monad.Fix import qualified Data.Dependent.Map as DMap import Data.Dependent.Sum +import Data.Functor.Misc +import qualified Data.Map as M import Data.These import Reflex @@ -25,7 +29,6 @@ main = do [ Just () ] print os1 - let ![[Just [10,9,8,7,6,5,4,3,2,1]]] = os1 os2 <- runApp' (unwrapApp testSimultaneous) $ map Just $ [ This () , That () @@ -33,7 +36,17 @@ main = do , These () () ] print os2 + os3 <- runApp' (unwrapApp testMoribundRequest) [Just ()] + print os3 + os4 <- runApp' (unwrapApp testMoribundRequestDMap) [Just ()] + print os4 + os5 <- runApp' (unwrapApp testLiveRequestDMap) [Just ()] + print os5 + let ![[Just [10,9,8,7,6,5,4,3,2,1]]] = os1 let ![[Just [1,3,5,7,9]],[Nothing,Nothing],[Just [2,4,6,8,10]],[Just [2,4,6,8,10],Nothing]] = os2 + let ![[Nothing, Just [2]]] = os3 + let ![[Nothing, Just [2]]] = os4 + let ![[Nothing, Just [1, 2]]] = os5 return () unwrapRequest :: DSum tag RequestInt -> Int @@ -67,3 +80,69 @@ testSimultaneous pulse = do switchE = fmapMaybe (^? there) pulse forM_ [1,3..9] $ \i -> runWithReplace (requestingIdentity (RequestInt i <$ tellE)) $ ffor switchE $ \_ -> requestingIdentity (RequestInt (i+1) <$ tellE) + +-- | Test that a widget requesting and event which fires at the same time it has been replaced +-- doesn't count along with the new widget. +testMoribundRequest + :: forall t m + . ( Reflex t + , Adjustable t m + , MonadHold t m + , MonadFix m + , Response m ~ Identity + , Request m ~ RequestInt + , Requester t m + ) + => Event t () + -> m () +testMoribundRequest pulse = do + rec let requestIntOnReplace x = requestingIdentity $ RequestInt x <$ rwrFinished + (_, rwrFinished) <- runWithReplace (requestIntOnReplace 1) $ requestIntOnReplace 2 <$ pulse + return () + +-- | The equivalent of 'testMoribundRequest' for 'traverseDMapWithKeyWithAdjust'. +testMoribundRequestDMap + :: forall t m + . ( Reflex t + , Adjustable t m + , MonadHold t m + , MonadFix m + , Response m ~ Identity + , Request m ~ RequestInt + , Requester t m + ) + => Event t () + -> m () +testMoribundRequestDMap pulse = do + rec let requestIntOnReplace :: Int -> m () + requestIntOnReplace x = void $ requestingIdentity $ RequestInt x <$ rwrFinished + (_, rwrFinished :: Event t (PatchDMap (Const2 () Int) Identity)) <- + traverseDMapWithKeyWithAdjust + (\(Const2 ()) (Identity v) -> Identity . const v <$> requestIntOnReplace v) + (mapToDMap $ M.singleton () 1) + ((PatchDMap $ DMap.map (ComposeMaybe . Just) $ mapToDMap $ M.singleton () 2) <$ pulse) + return () + +-- | Ensures that elements which are _not_ removed can still fire requests +-- during the same frame as other elements are updated. +testLiveRequestDMap + :: forall t m + . ( Reflex t + , Adjustable t m + , MonadHold t m + , MonadFix m + , Response m ~ Identity + , Request m ~ RequestInt + , Requester t m + ) + => Event t () + -> m () +testLiveRequestDMap pulse = do + rec let requestIntOnReplace :: Int -> m () + requestIntOnReplace x = void $ requestingIdentity $ RequestInt x <$ rwrFinished + (_, rwrFinished :: Event t (PatchDMap (Const2 Int ()) Identity)) <- + traverseDMapWithKeyWithAdjust + (\(Const2 k) (Identity ()) -> Identity <$> requestIntOnReplace k) + (mapToDMap $ M.singleton 1 ()) + ((PatchDMap $ DMap.map (ComposeMaybe . Just) $ mapToDMap $ M.singleton 2 ()) <$ pulse) + return () From baadc4ce2347b8feeef3d691e9bec966078357ad Mon Sep 17 00:00:00 2001 From: Tom Smalley Date: Thu, 24 Jan 2019 20:14:45 +0000 Subject: [PATCH 088/241] Add tests showing RequesterT/EventWriterT inconsistency Issue #233 --- test/EventWriterT.hs | 18 ++++++++++++++++++ test/RequesterT.hs | 21 +++++++++++++++++++++ 2 files changed, 39 insertions(+) diff --git a/test/EventWriterT.hs b/test/EventWriterT.hs index ffab2340..3f2510a2 100644 --- a/test/EventWriterT.hs +++ b/test/EventWriterT.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE BangPatterns #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE RecursiveDo #-} @@ -36,6 +37,9 @@ main = do print os4 os5@[[Nothing, Just [1, 2]]] <- runApp' (unwrapApp testLiveTellEventDMap) [Just ()] print os5 + os6 <- runApp' (unwrapApp delayedPulse) [Just ()] + print os6 + let ![[Nothing, Nothing]] = os6 return () unwrapApp :: (Reflex t, Monad m) => (a -> EventWriterT t [Int] m ()) -> a -> m (Event t [Int]) @@ -112,3 +116,17 @@ testLiveTellEventDMap pulse = do (mapToDMap $ M.singleton 1 ()) ((PatchDMap $ DMap.map (ComposeMaybe . Just) $ mapToDMap $ M.singleton 2 ()) <$ pulse) return () + +delayedPulse + :: forall t m + . ( Reflex t + , Adjustable t m + , MonadHold t m + , MonadFix m + ) + => Event t () + -> EventWriterT t [Int] m () +delayedPulse pulse = void $ flip runWithReplace (pure () <$ pulse) $ do + -- This has the effect of delaying pulse' from pulse + (_, pulse') <- runWithReplace (pure ()) $ pure [1] <$ pulse + tellEvent pulse' diff --git a/test/RequesterT.hs b/test/RequesterT.hs index c4c9fdee..351c32e8 100644 --- a/test/RequesterT.hs +++ b/test/RequesterT.hs @@ -42,11 +42,14 @@ main = do print os4 os5 <- runApp' (unwrapApp testLiveRequestDMap) [Just ()] print os5 + os6 <- runApp' (unwrapApp delayedPulse) [Just ()] + print os6 let ![[Just [10,9,8,7,6,5,4,3,2,1]]] = os1 let ![[Just [1,3,5,7,9]],[Nothing,Nothing],[Just [2,4,6,8,10]],[Just [2,4,6,8,10],Nothing]] = os2 let ![[Nothing, Just [2]]] = os3 let ![[Nothing, Just [2]]] = os4 let ![[Nothing, Just [1, 2]]] = os5 + let ![[Nothing, Nothing]] = os6 return () unwrapRequest :: DSum tag RequestInt -> Int @@ -146,3 +149,21 @@ testLiveRequestDMap pulse = do (mapToDMap $ M.singleton 1 ()) ((PatchDMap $ DMap.map (ComposeMaybe . Just) $ mapToDMap $ M.singleton 2 ()) <$ pulse) return () + +delayedPulse + :: forall t m + . ( Reflex t + , Adjustable t m + , MonadHold t m + , MonadFix m + , Response m ~ Identity + , Request m ~ RequestInt + , PerformEvent t m + , Requester t m + ) + => Event t () + -> m () +delayedPulse pulse = void $ flip runWithReplace (pure () <$ pulse) $ do + -- This has the effect of delaying pulse' from pulse + (_, pulse') <- runWithReplace (pure ()) $ pure (RequestInt 1) <$ pulse + requestingIdentity pulse' From 68d679e59b6a97af12d6ae048df8de2bef86680a Mon Sep 17 00:00:00 2001 From: Luigy Leon Date: Tue, 29 Jan 2019 04:33:34 -0500 Subject: [PATCH 089/241] Tighten these bounds --- reflex.cabal | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/reflex.cabal b/reflex.cabal index 6e036a6e..2b1e907d 100644 --- a/reflex.cabal +++ b/reflex.cabal @@ -60,7 +60,7 @@ library semigroups >= 0.16 && < 0.19, stm >= 2.4 && < 2.6, syb >= 0.5 && < 0.8, - these >= 0.4 && < 0.8, + these >= 0.4 && < 0.7.6, time >= 1.4 && < 1.9, transformers >= 0.2, transformers-compat >= 0.3, From c641dcfd2379c931b0699f0c8de370d2e9d0152d Mon Sep 17 00:00:00 2001 From: Tom Smalley Date: Wed, 30 Jan 2019 10:10:32 +0000 Subject: [PATCH 090/241] Add PrimMonad instance for DynamicWriterT --- src/Reflex/DynamicWriter/Base.hs | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/src/Reflex/DynamicWriter/Base.hs b/src/Reflex/DynamicWriter/Base.hs index 8151fc7d..f5804c94 100644 --- a/src/Reflex/DynamicWriter/Base.hs +++ b/src/Reflex/DynamicWriter/Base.hs @@ -22,6 +22,7 @@ module Reflex.DynamicWriter.Base import Control.Monad.Exception import Control.Monad.Identity import Control.Monad.IO.Class +import Control.Monad.Primitive import Control.Monad.Reader import Control.Monad.Ref import Control.Monad.State.Strict @@ -140,6 +141,10 @@ instance MonadState s m => MonadState s (DynamicWriterT t w m) where get = lift get put = lift . put +instance PrimMonad m => PrimMonad (DynamicWriterT t w m) where + type PrimState (DynamicWriterT t w m) = PrimState m + primitive = lift . primitive + newtype DynamicWriterTLoweredResult t w v a = DynamicWriterTLoweredResult (v a, Dynamic t w) -- | When the execution of a 'DynamicWriterT' action is adjusted using From 31dff1678490bea11aec3f89fdff0966443db2f9 Mon Sep 17 00:00:00 2001 From: Ali Abrar Date: Fri, 8 Feb 2019 21:23:08 -0500 Subject: [PATCH 091/241] Add usage warning to throttleBatchWithLag --- src/Reflex/Time.hs | 2 ++ 1 file changed, 2 insertions(+) diff --git a/src/Reflex/Time.hs b/src/Reflex/Time.hs index 9241eaab..9193b42f 100644 --- a/src/Reflex/Time.hs +++ b/src/Reflex/Time.hs @@ -301,6 +301,8 @@ instance Semigroup b => Monoid (ThrottleBuffer b) where -- If the output event has not occurred recently, occurrences of the input event will cause the output event to fire immediately. -- The first parameter is a function that receives access to the output event, and should construct an event that fires when the receiver is -- ready for more input. For example, using @delay 20@ would give a simple time-based throttle. +-- +-- NB: The provided lag function must *actually* delay the event. throttleBatchWithLag :: (MonadFix m, MonadHold t m, PerformEvent t m, Semigroup a) => (Event t () -> m (Event t ())) -> Event t a -> m (Event t a) -- Invariants: -- * Immediate mode must turn off whenever output is produced. From d69cfc7d238ac37e52c5553488b754284f28f2bd Mon Sep 17 00:00:00 2001 From: Ali Abrar Date: Fri, 8 Feb 2019 22:09:47 -0500 Subject: [PATCH 092/241] Bump dependent-sum; Remove reliance on EqTag --- reflex.cabal | 5 +++-- src/Data/Functor/Misc.hs | 8 -------- src/Reflex/Patch/DMapWithMove.hs | 6 +++--- 3 files changed, 6 insertions(+), 13 deletions(-) diff --git a/reflex.cabal b/reflex.cabal index 2b1e907d..8efa2a20 100644 --- a/reflex.cabal +++ b/reflex.cabal @@ -43,6 +43,7 @@ library base >= 4.9 && < 4.13, bifunctors >= 5.2 && < 5.6, comonad, + constraints-extras >= 0.2, containers >= 0.5 && < 0.7, data-default >= 0.5 && < 0.8, dependent-map >= 0.2.4 && < 0.3, @@ -131,7 +132,7 @@ library if flag(use-template-haskell) cpp-options: -DUSE_TEMPLATE_HASKELL build-depends: - dependent-sum >= 0.3 && < 0.5, + dependent-sum >= 0.5, haskell-src-exts >= 1.16 && < 1.21, haskell-src-meta >= 0.6 && < 0.9, template-haskell >= 2.9 && < 2.15 @@ -140,7 +141,7 @@ library other-extensions: TemplateHaskell else build-depends: - dependent-sum == 0.4.* + dependent-sum >= 0.5 if flag(fast-weak) && impl(ghcjs) cpp-options: -DGHCJS_FAST_WEAK diff --git a/src/Data/Functor/Misc.hs b/src/Data/Functor/Misc.hs index e5950db4..bba0db68 100644 --- a/src/Data/Functor/Misc.hs +++ b/src/Data/Functor/Misc.hs @@ -86,9 +86,6 @@ deriving instance Read k => Read (Const2 k v v) instance Show k => GShow (Const2 k v) where gshowsPrec n x@(Const2 _) = showsPrec n x -instance (Show k, Show (f v)) => ShowTag (Const2 k v) f where - showTaggedPrec (Const2 _) = showsPrec - instance Eq k => GEq (Const2 k v) where geq (Const2 a) (Const2 b) = if a == b @@ -221,11 +218,6 @@ instance GShow (EitherTag l r) where LeftTag -> showString "LeftTag" RightTag -> showString "RightTag" -instance (Show l, Show r) => ShowTag (EitherTag l r) Identity where - showTaggedPrec t n (Identity a) = case t of - LeftTag -> showsPrec n a - RightTag -> showsPrec n a - -- | Convert 'Either' to a 'DSum'. Inverse of 'dsumToEither'. eitherToDSum :: Either a b -> DSum (EitherTag a b) Identity eitherToDSum = \case diff --git a/src/Reflex/Patch/DMapWithMove.hs b/src/Reflex/Patch/DMapWithMove.hs index 70b95edd..3fe7c4f8 100644 --- a/src/Reflex/Patch/DMapWithMove.hs +++ b/src/Reflex/Patch/DMapWithMove.hs @@ -19,9 +19,9 @@ import Reflex.Patch.Class import Reflex.Patch.MapWithMove (PatchMapWithMove (..)) import qualified Reflex.Patch.MapWithMove as MapWithMove +import Data.Constraint.Extras import Data.Dependent.Map (DMap, DSum (..), GCompare (..)) import qualified Data.Dependent.Map as DMap -import Data.Dependent.Sum (EqTag (..)) import Data.Functor.Constant import Data.Functor.Misc import Data.Functor.Product @@ -105,8 +105,8 @@ validationErrorsForPatchDMapWithMove m = unbalancedMove _ = Nothing -- |Test whether two @'PatchDMapWithMove' k v@ contain the same patch operations. -instance EqTag k (NodeInfo k v) => Eq (PatchDMapWithMove k v) where - PatchDMapWithMove a == PatchDMapWithMove b = a == b +instance (GEq k, Has' Eq k (NodeInfo k v)) => Eq (PatchDMapWithMove k v) where + PatchDMapWithMove a == PatchDMapWithMove b = a == b -- |Higher kinded 2-tuple, identical to @Data.Functor.Product@ from base ≥ 4.9 data Pair1 f g a = Pair1 (f a) (g a) From e6daabaedf85710138361c01d0e505c854132e50 Mon Sep 17 00:00:00 2001 From: Alexandre Esteves Date: Sat, 9 Feb 2019 18:04:58 +0000 Subject: [PATCH 093/241] Add 'FunctorMaybe Option' instance --- src/Reflex/FunctorMaybe.hs | 9 +++++++++ 1 file changed, 9 insertions(+) diff --git a/src/Reflex/FunctorMaybe.hs b/src/Reflex/FunctorMaybe.hs index 56435608..e21f8bee 100644 --- a/src/Reflex/FunctorMaybe.hs +++ b/src/Reflex/FunctorMaybe.hs @@ -1,3 +1,7 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE StandaloneDeriving #-} + -- | This module defines the FunctorMaybe class, which extends Functors with the -- ability to delete values. module Reflex.FunctorMaybe @@ -9,6 +13,7 @@ import qualified Data.IntMap as IntMap import Data.Map (Map) import qualified Data.Map as Map import Data.Maybe +import Data.Semigroup (Option(..)) --TODO: See if there's a better class in the standard libraries already @@ -32,6 +37,10 @@ class FunctorMaybe f where instance FunctorMaybe Maybe where fmapMaybe = (=<<) +#if MIN_VERSION_base(4,9,0) +deriving instance FunctorMaybe Option +#endif + -- | @fmapMaybe = mapMaybe@ instance FunctorMaybe [] where fmapMaybe = mapMaybe From 5e1df2e9c316290dd30ceccbd3941b39c00e49d8 Mon Sep 17 00:00:00 2001 From: Alexandre Esteves <2335822+alexfmpe@users.noreply.github.com> Date: Wed, 13 Feb 2019 01:43:44 +0000 Subject: [PATCH 094/241] Fix typos --- src/Reflex/Dynamic.hs | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/Reflex/Dynamic.hs b/src/Reflex/Dynamic.hs index 9d50bf61..aae99b2a 100644 --- a/src/Reflex/Dynamic.hs +++ b/src/Reflex/Dynamic.hs @@ -352,7 +352,7 @@ factorDyn d = buildDynamic (sample (current d) >>= holdKey) update where -- -- > demuxed (demux d) k === fmap (== k) d -- --- However, the when getDemuxed is used multiple times, the complexity is only +-- However, when getDemuxed is used multiple times, the complexity is only -- /O(log(n))/, rather than /O(n)/ for fmap. data Demux t k = Demux { demuxValue :: Behavior t k , demuxSelector :: EventSelector t (Const2 k Bool) @@ -506,7 +506,7 @@ instance AllAreFunctors f t => AllAreFunctors f (h ': t) where -- | Convert a datastructure whose constituent parts are all 'Dynamic's into a -- single 'Dynamic' whose value represents all the current values of the input's --- consitutent 'Dynamic's. +-- constituent 'Dynamic's. collectDynPure :: ( RebuildSortedHList (HListElems b) , IsHList a, IsHList b , AllAreFunctors (Dynamic t) (HListElems b) @@ -585,7 +585,7 @@ distributeDMapOverDyn = return . distributeDMapOverDynPure combineDyn :: forall t m a b c. (Reflex t, Monad m) => (a -> b -> c) -> Dynamic t a -> Dynamic t b -> m (Dynamic t c) combineDyn f a b = return $ zipDynWith f a b --- | A psuedo applicative version of ap for 'Dynamic'. Example useage: +-- | A pseudo applicative version of ap for 'Dynamic'. Example useage: -- -- > do -- > person <- Person `mapDyn` dynFirstName From 4aa722a628c118b079576dc805c103eb34a34264 Mon Sep 17 00:00:00 2001 From: Ali Abrar Date: Wed, 13 Feb 2019 22:57:22 -0500 Subject: [PATCH 095/241] Add PrimMonad for RequesterT; Export some not-so-safe functions for low-level Requester implementations --- src/Reflex/Requester/Base.hs | 8 ++++++++ 1 file changed, 8 insertions(+) diff --git a/src/Reflex/Requester/Base.hs b/src/Reflex/Requester/Base.hs index 92f6974d..9d50ee32 100644 --- a/src/Reflex/Requester/Base.hs +++ b/src/Reflex/Requester/Base.hs @@ -30,6 +30,9 @@ module Reflex.Requester.Base , forRequesterData , requesterDataToList , singletonRequesterData + , multiEntry + , unMultiEntry + , requesting' ) where import Reflex.Class @@ -44,6 +47,7 @@ import Reflex.TriggerEvent.Class import Control.Applicative (liftA2) import Control.Monad.Exception import Control.Monad.Identity +import Control.Monad.Primitive import Control.Monad.Reader import Control.Monad.Ref import Control.Monad.State.Strict @@ -244,6 +248,10 @@ deriving instance MonadHold t m => MonadHold t (RequesterT t request response m) deriving instance PostBuild t m => PostBuild t (RequesterT t request response m) deriving instance TriggerEvent t m => TriggerEvent t (RequesterT t request response m) +instance PrimMonad m => PrimMonad (RequesterT t request response m) where + type PrimState (RequesterT t request response m) = PrimState m + primitive = lift . primitive + -- TODO: Monoid and Semigroup can likely be derived once StateT has them. instance (Monoid a, Monad m) => Monoid (RequesterT t request response m a) where mempty = pure mempty From 6937019e0833a05fc53d67596c911e6871cd461e Mon Sep 17 00:00:00 2001 From: Jack Kelly Date: Thu, 14 Feb 2019 22:09:14 +1100 Subject: [PATCH 096/241] Relax bounds on 'these', add explicit import to avoid clash --- reflex.cabal | 2 +- src/Reflex/Patch/MapWithMove.hs | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/reflex.cabal b/reflex.cabal index 2b1e907d..bdac7694 100644 --- a/reflex.cabal +++ b/reflex.cabal @@ -60,7 +60,7 @@ library semigroups >= 0.16 && < 0.19, stm >= 2.4 && < 2.6, syb >= 0.5 && < 0.8, - these >= 0.4 && < 0.7.6, + these >= 0.4 && < 0.7.7, time >= 1.4 && < 1.9, transformers >= 0.2, transformers-compat >= 0.3, diff --git a/src/Reflex/Patch/MapWithMove.hs b/src/Reflex/Patch/MapWithMove.hs index f031e4dc..8563ff24 100644 --- a/src/Reflex/Patch/MapWithMove.hs +++ b/src/Reflex/Patch/MapWithMove.hs @@ -22,7 +22,7 @@ import qualified Data.Map as Map import Data.Maybe import Data.Semigroup (Semigroup (..), (<>)) import qualified Data.Set as Set -import Data.These +import Data.These (These(..)) import Data.Tuple -- | Patch a DMap with additions, deletions, and moves. Invariant: If key @k1@ From 8dc43b91ab22e76eb37144d119b6e197e1551e5c Mon Sep 17 00:00:00 2001 From: Ali Abrar Date: Sun, 17 Feb 2019 22:21:30 -0500 Subject: [PATCH 097/241] Re-export NotReady --- src/Reflex.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/src/Reflex.hs b/src/Reflex.hs index 8bc3789d..1529280b 100644 --- a/src/Reflex.hs +++ b/src/Reflex.hs @@ -19,6 +19,7 @@ import Reflex.Dynamic.TH as X import Reflex.Dynamic.Uniq as X import Reflex.DynamicWriter.Base as X import Reflex.DynamicWriter.Class as X +import Reflex.NotReady.Class as X import Reflex.PerformEvent.Base as X import Reflex.PerformEvent.Class as X import Reflex.PostBuild.Base as X From c489148702295aa3161d195a09ca34244bdfdcf7 Mon Sep 17 00:00:00 2001 From: Ali Abrar Date: Sun, 17 Feb 2019 22:23:27 -0500 Subject: [PATCH 098/241] Add some more NotReady instances --- src/Reflex/NotReady/Class.hs | 8 ++++++++ 1 file changed, 8 insertions(+) diff --git a/src/Reflex/NotReady/Class.hs b/src/Reflex/NotReady/Class.hs index 4bc89a77..1c67b47a 100644 --- a/src/Reflex/NotReady/Class.hs +++ b/src/Reflex/NotReady/Class.hs @@ -39,6 +39,10 @@ instance NotReady t m => NotReady t (ReaderT r m) where notReadyUntil = lift . notReadyUntil notReady = lift notReady +instance (NotReady t m, Monoid w) => NotReady t (WriterT w m) where + notReadyUntil = lift . notReadyUntil + notReady = lift notReady + instance NotReady t m => NotReady t (PostBuildT t m) where notReadyUntil = lift . notReadyUntil notReady = lift notReady @@ -51,6 +55,10 @@ instance NotReady t m => NotReady t (DynamicWriterT t w m) where notReadyUntil = lift . notReadyUntil notReady = lift notReady +instance (NotReady t m, Monoid w) => NotReady t (BehaviorWriterT t w m) where + notReadyUntil = lift . notReadyUntil + notReady = lift notReady + instance NotReady t m => NotReady t (QueryT t q m) where notReadyUntil = lift . notReadyUntil notReady = lift notReady From a441c8ea8012c7dc31f52c9a7f07f93d6084ef10 Mon Sep 17 00:00:00 2001 From: Luigy Leon Date: Sat, 23 Feb 2019 04:26:21 +0000 Subject: [PATCH 099/241] Add missing imports --- src/Reflex/NotReady/Class.hs | 2 ++ 1 file changed, 2 insertions(+) diff --git a/src/Reflex/NotReady/Class.hs b/src/Reflex/NotReady/Class.hs index 1c67b47a..60160d35 100644 --- a/src/Reflex/NotReady/Class.hs +++ b/src/Reflex/NotReady/Class.hs @@ -15,7 +15,9 @@ module Reflex.NotReady.Class import Control.Monad.Reader (ReaderT) import Control.Monad.Trans +import Control.Monad.Trans.Writer (WriterT) +import Reflex.BehaviorWriter.Base (BehaviorWriterT) import Reflex.Class import Reflex.DynamicWriter.Base (DynamicWriterT) import Reflex.EventWriter.Base (EventWriterT) From ca0eb49fdd4cf3663d395934b82581a47e5f8051 Mon Sep 17 00:00:00 2001 From: Alexandre Esteves Date: Sun, 24 Feb 2019 01:37:59 +0000 Subject: [PATCH 100/241] Conditionally import 'Semigroup' --- src/Reflex/FunctorMaybe.hs | 2 ++ 1 file changed, 2 insertions(+) diff --git a/src/Reflex/FunctorMaybe.hs b/src/Reflex/FunctorMaybe.hs index e21f8bee..e1e95aa8 100644 --- a/src/Reflex/FunctorMaybe.hs +++ b/src/Reflex/FunctorMaybe.hs @@ -13,7 +13,9 @@ import qualified Data.IntMap as IntMap import Data.Map (Map) import qualified Data.Map as Map import Data.Maybe +#if MIN_VERSION_base(4,9,0) import Data.Semigroup (Option(..)) +#endif --TODO: See if there's a better class in the standard libraries already From 64c8527fe27e46b5957fd4c08e7c24ba3343cafd Mon Sep 17 00:00:00 2001 From: Alexandre Esteves Date: Sun, 24 Feb 2019 01:38:37 +0000 Subject: [PATCH 101/241] Add missing haddock hyperlinks --- src/Reflex/FunctorMaybe.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Reflex/FunctorMaybe.hs b/src/Reflex/FunctorMaybe.hs index e1e95aa8..e4da2532 100644 --- a/src/Reflex/FunctorMaybe.hs +++ b/src/Reflex/FunctorMaybe.hs @@ -21,7 +21,7 @@ import Data.Semigroup (Option(..)) -- | A class for values that combines filtering and mapping using 'Maybe'. -- Morally, @'FunctorMaybe' ~ KleisliFunctor 'Maybe'@. Also similar is the --- @Witherable@ typeclass, but it requires @Foldable f@ and @Traverable f@, +-- @Witherable@ typeclass, but it requires @'Foldable' f@ and @'Traversable' f@, -- and e.g. 'Event' is instance of neither. -- -- A definition of 'fmapMaybe' must satisfy the following laws: From e28536fa994aa98d7894f9eb0699680ce5784d50 Mon Sep 17 00:00:00 2001 From: cgibbard Date: Thu, 7 Mar 2019 06:41:36 -0500 Subject: [PATCH 102/241] Update the types of merge and fan DMap has had two parameters for a while. --- Quickref.md | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) diff --git a/Quickref.md b/Quickref.md index 2d42bef9..c13cf8cb 100644 --- a/Quickref.md +++ b/Quickref.md @@ -57,15 +57,15 @@ Since MonadHold depends on MonadSample, any [S] function also runs in [H] contex [ ] mergeWith :: (a -> a -> a) -> [Event a] -> Event a [ ] leftmost :: [Event a] -> Event a [ ] mergeList :: [Event a] -> Event (NonEmpty a) -[ ] merge :: GCompare k => DMap (WrapArg Event k) -> Event (DMap k) +[ ] merge :: GCompare k => DMap k Event -> Event (DMap k Identity) [ ] mergeMap :: Ord k => Map k (Event a) -> Event (Map k a) -- Efficient one-to-many fanout -[ ] fanMap :: Ord k => Event (Map k a) -> EventSelector (Const2 k a) -[ ] fan :: GCompare k => Event (DMap k) -> EventSelector k -[ ] select :: EventSelector k -> k a -> Event a -[ ] fanEither :: Event (Either a b) -> (Event a, Event b) -[ ] fanThese :: Event (These a b) -> (Event a, Event b) +[ ] fanMap :: Ord k => Event (Map k a) -> EventSelector (Const2 k a) +[ ] fan :: GCompare k => Event (DMap k Identity) -> EventSelector k +[ ] select :: EventSelector k -> k a -> Event a +[ ] fanEither :: Event (Either a b) -> (Event a, Event b) +[ ] fanThese :: Event (These a b) -> (Event a, Event b) -- Event to Event via function that can sample current values [ ] push :: (a -> m (Maybe b)) -> Event a -> Event b From 5d511d6422df5c6640e9eb442ede7ad030715df5 Mon Sep 17 00:00:00 2001 From: Jack Kelly Date: Thu, 14 Feb 2019 22:09:14 +1100 Subject: [PATCH 103/241] Relax bounds on 'these', add explicit import to avoid clash (cherry picked from commit 6937019e0833a05fc53d67596c911e6871cd461e) --- reflex.cabal | 2 +- src/Reflex/Patch/MapWithMove.hs | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/reflex.cabal b/reflex.cabal index 2b1e907d..bdac7694 100644 --- a/reflex.cabal +++ b/reflex.cabal @@ -60,7 +60,7 @@ library semigroups >= 0.16 && < 0.19, stm >= 2.4 && < 2.6, syb >= 0.5 && < 0.8, - these >= 0.4 && < 0.7.6, + these >= 0.4 && < 0.7.7, time >= 1.4 && < 1.9, transformers >= 0.2, transformers-compat >= 0.3, diff --git a/src/Reflex/Patch/MapWithMove.hs b/src/Reflex/Patch/MapWithMove.hs index f031e4dc..8563ff24 100644 --- a/src/Reflex/Patch/MapWithMove.hs +++ b/src/Reflex/Patch/MapWithMove.hs @@ -22,7 +22,7 @@ import qualified Data.Map as Map import Data.Maybe import Data.Semigroup (Semigroup (..), (<>)) import qualified Data.Set as Set -import Data.These +import Data.These (These(..)) import Data.Tuple -- | Patch a DMap with additions, deletions, and moves. Invariant: If key @k1@ From a4aaf97b9597a1fea39d5c7c5607c041b3a8e1bc Mon Sep 17 00:00:00 2001 From: Luigy Leon Date: Fri, 8 Mar 2019 07:25:13 -0500 Subject: [PATCH 104/241] Bump version to 0.5.0.1 --- reflex.cabal | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/reflex.cabal b/reflex.cabal index bdac7694..841a7213 100644 --- a/reflex.cabal +++ b/reflex.cabal @@ -1,5 +1,5 @@ Name: reflex -Version: 0.5 +Version: 0.5.0.1 Synopsis: Higher-order Functional Reactive Programming Description: Reflex is a high-performance, deterministic, higher-order Functional Reactive Programming system License: BSD3 From 34cda24a5b6533aa4bd10cfe502c6090a4ebff7b Mon Sep 17 00:00:00 2001 From: Luigy Leon Date: Fri, 8 Mar 2019 07:59:57 -0500 Subject: [PATCH 105/241] Bump version in default.nix --- default.nix | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/default.nix b/default.nix index 551246ad..cdb8bf90 100644 --- a/default.nix +++ b/default.nix @@ -11,7 +11,7 @@ }: mkDerivation { pname = "reflex"; - version = "0.5"; + version = "0.5.0.1"; src = builtins.filterSource (path: type: !(builtins.elem (baseNameOf path) [ ".git" "dist" ])) ./.; libraryHaskellDepends = [ base bifunctors containers dependent-map dependent-sum From 81097f8bc692078ccedbd36a6d578fc8e8955291 Mon Sep 17 00:00:00 2001 From: Ali Abrar Date: Sat, 16 Mar 2019 19:48:58 -0400 Subject: [PATCH 106/241] Add withRequesterT --- src/Reflex/Requester/Base.hs | 16 +++++++++++++++- 1 file changed, 15 insertions(+), 1 deletion(-) diff --git a/src/Reflex/Requester/Base.hs b/src/Reflex/Requester/Base.hs index 9d50ee32..bee529b6 100644 --- a/src/Reflex/Requester/Base.hs +++ b/src/Reflex/Requester/Base.hs @@ -21,6 +21,7 @@ module Reflex.Requester.Base ( RequesterT (..) , runRequesterT + , withRequesterT , runWithReplaceRequesterTWith , traverseIntMapWithKeyWithAdjustRequesterTWith , traverseDMapWithKeyWithAdjustRequesterTWith @@ -265,7 +266,6 @@ instance (S.Semigroup a, Monad m) => S.Semigroup (RequesterT t request response -- requests are made, and responses should be provided in the input 'Event'. -- The 'Tag' keys will be used to return the responses to the same place the -- requests were issued. - runRequesterT :: (Reflex t, Monad m) => RequesterT t request response m a -> Event t (RequesterData response) --TODO: This DMap will be in reverse order, so we need to make sure the caller traverses it in reverse @@ -275,6 +275,20 @@ runRequesterT (RequesterT a) responses = do coerceEvent responses return (result, fmapCheap (RequesterData . TagMap) $ mergeInt $ IntMap.fromDistinctAscList $ _requesterState_requests s) +-- | Map a function over the request and response of a 'RequesterT' +withRequesterT + :: (Reflex t, MonadFix m) + => (forall x. req x -> req' x) -- ^ The function to map over the request + -> (forall x. rsp' x -> rsp x) -- ^ The function to map over the response + -> RequesterT t req rsp m a -- ^ The internal 'RequesterT' whose input and output will be transformed + -> RequesterT t req' rsp' m a -- ^ The resulting 'RequesterT' +withRequesterT freq frsp child = do + rec let rsp = fmap (runIdentity . traverseRequesterData (Identity . frsp)) rsp' + (a, req) <- lift $ runRequesterT child rsp + rsp' <- fmap (flip selectInt 0 . fanInt . fmapCheap unMultiEntry) $ requesting' $ + fmapCheap (multiEntry . IntMap.singleton 0) $ fmap (runIdentity . traverseRequesterData (Identity . freq)) req + return a + instance (Reflex t, Monad m) => Requester t (RequesterT t request response m) where type Request (RequesterT t request response m) = request type Response (RequesterT t request response m) = response From 8b7c5ec22b029109f8e96c4e213ffc5c057fa16e Mon Sep 17 00:00:00 2001 From: Ali Abrar Date: Sat, 16 Mar 2019 19:54:10 -0400 Subject: [PATCH 107/241] Add matchResponsesWithRequests --- src/Reflex/Requester/Base.hs | 82 ++++++++++++++++++++++++++++++++++++ 1 file changed, 82 insertions(+) diff --git a/src/Reflex/Requester/Base.hs b/src/Reflex/Requester/Base.hs index 9d50ee32..4559b1d4 100644 --- a/src/Reflex/Requester/Base.hs +++ b/src/Reflex/Requester/Base.hs @@ -30,6 +30,7 @@ module Reflex.Requester.Base , forRequesterData , requesterDataToList , singletonRequesterData + , matchResponsesWithRequests , multiEntry , unMultiEntry , requesting' @@ -440,3 +441,84 @@ traverseDMapWithKeyWithAdjustRequesterTWith base mapPatch weakenPatchWith patchN promptRequests = coincidence $ fmapCheap (mergeMap . patchNewElements) requests' --TODO: Create a mergeIncrementalPromptly, and use that to eliminate this 'coincidence' requests <- holdIncremental requests0 requests' return (result0, result') + +data Decoder rawResponse response = + forall a. Decoder (RequesterDataKey a) (rawResponse -> response a) + +-- | Matches incoming responses with previously-sent requests +-- and uses the provided request "decoder" function to process +-- incoming responses. +matchResponsesWithRequests + :: forall t rawRequest rawResponse request response m. + ( MonadFix m + , MonadHold t m + , Reflex t + ) + => (forall a. request a -> (rawRequest, rawResponse -> response a)) + -- ^ Given a request (from 'Requester'), produces the wire format of the + -- request and a function used to process the associated response + -> Event t (RequesterData request) + -- ^ The outgoing requests + -> Event t (Int, rawResponse) + -- ^ The incoming responses, tagged by an identifying key + -> m ( Event t (Map Int rawRequest) + , Event t (RequesterData response) + ) + -- ^ A map of outgoing wire-format requests and an event of responses keyed + -- by the 'RequesterData' key of the associated outgoing request +matchResponsesWithRequests f send recv = do + rec nextId <- hold 1 $ fmap (\(next, _, _) -> next) outgoing + waitingFor :: Incremental t (PatchMap Int (Decoder rawResponse response)) <- + holdIncremental mempty $ leftmost + [ fmap (\(_, outstanding, _) -> outstanding) outgoing + , snd <$> incoming + ] + let outgoing = processOutgoing nextId send + incoming = processIncoming waitingFor recv + return (fmap (\(_, _, rawReqs) -> rawReqs) outgoing, fst <$> incoming) + where + -- Tags each outgoing request with an identifying integer key + -- and returns the next available key, a map of response decoders + -- for requests for which there are outstanding responses, and the + -- raw requests to be sent out. + processOutgoing + :: Behavior t Int + -- The next available key + -> Event t (RequesterData request) + -- The outgoing request + -> Event t ( Int + , PatchMap Int (Decoder rawResponse response) + , Map Int rawRequest ) + -- The new next-available-key, a map of requests expecting responses, and the tagged raw requests + processOutgoing nextId out = flip pushAlways out $ \dm -> do + oldNextId <- sample nextId + let (result, newNextId) = flip runState oldNextId $ forM (requesterDataToList dm) $ \(k :=> v) -> do + n <- get + put $ succ n + let (rawReq, rspF) = f v + return (n, rawReq, Decoder k rspF) + patchWaitingFor = PatchMap $ Map.fromList $ + (\(n, _, dec) -> (n, Just dec)) <$> result + toSend = Map.fromList $ (\(n, rawReq, _) -> (n, rawReq)) <$> result + return (newNextId, patchWaitingFor, toSend) + -- Looks up the each incoming raw response in a map of response + -- decoders and returns the decoded response and a patch that can + -- be used to clear the ID of the consumed response out of the queue + -- of expected responses. + processIncoming + :: Incremental t (PatchMap Int (Decoder rawResponse response)) + -- A map of outstanding expected responses + -> Event t (Int, rawResponse) + -- A incoming response paired with its identifying key + -> Event t (RequesterData response, PatchMap Int v) + -- The decoded response and a patch that clears the outstanding responses queue + processIncoming waitingFor inc = flip push inc $ \(n, rawRsp) -> do + wf <- sample $ currentIncremental waitingFor + case Map.lookup n wf of + Nothing -> return Nothing -- TODO How should lookup failures be handled here? They shouldn't ever happen.. + Just (Decoder k rspF) -> do + let rsp = rspF rawRsp + return $ Just + ( singletonRequesterData k rsp + , PatchMap $ Map.singleton n Nothing + ) From b8a0aad9ac5418b065dcaab2f5588cacb5f34e8c Mon Sep 17 00:00:00 2001 From: Ali Abrar Date: Sat, 16 Mar 2019 23:53:22 -0400 Subject: [PATCH 108/241] Add some docs --- src/Reflex/Class.hs | 185 ++++++++++++++++++++++++++++++++----- src/Reflex/Collection.hs | 10 ++ src/Reflex/Dynamic.hs | 8 +- src/Reflex/FastWeak.hs | 16 ++-- src/Reflex/FunctorMaybe.hs | 8 +- src/Reflex/Network.hs | 14 ++- src/Reflex/Optimizer.hs | 12 ++- src/Reflex/Patch.hs | 11 ++- src/Reflex/Profiled.hs | 6 ++ src/Reflex/Pure.hs | 12 ++- src/Reflex/Spider.hs | 7 +- src/Reflex/Time.hs | 36 +++++--- src/Reflex/Workflow.hs | 14 ++- 13 files changed, 270 insertions(+), 69 deletions(-) diff --git a/src/Reflex/Class.hs b/src/Reflex/Class.hs index 71d96979..67955013 100644 --- a/src/Reflex/Class.hs +++ b/src/Reflex/Class.hs @@ -21,9 +21,13 @@ {-# OPTIONS_GHC -fplugin=Reflex.Optimizer #-} #endif --- | This module contains the Reflex interface, as well as a variety of --- convenience functions for working with 'Event's, 'Behavior's, and other --- signals. +-- | +-- Module: +-- Reflex.Class +-- Description: +-- This module contains the Reflex interface, as well as a variety of +-- convenience functions for working with 'Event's, 'Behavior's, and other +-- signals. module Reflex.Class ( module Reflex.Patch -- * Primitives @@ -256,8 +260,7 @@ class ( MonadHold t (PushM t) -- | Create an 'Event' that will occur whenever the currently-selected input -- 'Event' occurs switch :: Behavior t (Event t a) -> Event t a - -- | Create an 'Event' that will occur whenever the input event is occurring - -- and its occurrence value, another 'Event', is also occurring + -- | Create an 'Event' that will occur whenever the input event is occurring -- and its occurrence value, another 'Event', is also occurring coincidence :: Event t (Event t a) -> Event t a -- | Extract the 'Behavior' of a 'Dynamic'. current :: Dynamic t a -> Behavior t a @@ -998,14 +1001,16 @@ distributeListOverDynWith f = fmap (f . map (\(Const2 _ :=> Identity v) -> v) . difference :: Reflex t => Event t a -> Event t b -> Event t a difference = alignEventWithMaybe $ \case This a -> Just a - _ -> Nothing + _ -> Nothing +-- | Zips two values by taking the union of their shapes and combining with the provided function. +-- 'Nothing' values are dropped. alignEventWithMaybe :: Reflex t => (These a b -> Maybe c) -> Event t a -> Event t b -> Event t c -alignEventWithMaybe f ea eb = - fmapMaybe (f <=< dmapToThese) - $ merge - $ DMap.fromList [LeftTag :=> ea, RightTag :=> eb] +alignEventWithMaybe f ea eb = fmapMaybe (f <=< dmapToThese) $ + merge $ DMap.fromList [LeftTag :=> ea, RightTag :=> eb] +-- | Produces an 'Event' that fires only when the input event fires with a 'DSum' key that +-- matches the provided key. filterEventKey :: forall t m k v a. ( Reflex t @@ -1023,7 +1028,10 @@ filterEventKey k kv' = do Nothing -> Nothing takeWhileJustE f kv' - +-- | "Factor" the input 'DSum' 'Event' to produce an 'Event' which +-- fires when the 'DSum' key changes and contains both the value of the +-- 'DSum' at switchover and an 'Event' of values produced by subsequent +-- firings of the input 'Event' that do not change the 'DSum' key. factorEvent :: forall t m k v a. ( Reflex t @@ -1073,26 +1081,94 @@ class Reflex t => Accumulator t f | f -> t where mapAccumMaybe f = mapAccumMaybeM $ \v o -> return $ f v o mapAccumMaybeM :: (MonadHold t m, MonadFix m) => (a -> b -> PushM t (Maybe a, Maybe c)) -> a -> Event t b -> m (f a, Event t c) -accumDyn :: (Reflex t, MonadHold t m, MonadFix m) => (a -> b -> a) -> a -> Event t b -> m (Dynamic t a) +-- | Accumulate a 'Dynamic' by folding occurrences of an 'Event' +-- with the provided function. See 'foldDyn'. +accumDyn + :: (Reflex t, MonadHold t m, MonadFix m) + => (a -> b -> a) + -> a + -> Event t b + -> m (Dynamic t a) accumDyn f = accumMaybeDyn $ \v o -> Just $ f v o -accumMDyn :: (Reflex t, MonadHold t m, MonadFix m) => (a -> b -> PushM t a) -> a -> Event t b -> m (Dynamic t a) + +-- | Accumulate a 'Dynamic' by folding occurrences of an 'Event' +-- with the provided 'PushM' action. +accumMDyn + :: (Reflex t, MonadHold t m, MonadFix m) + => (a -> b -> PushM t a) + -> a + -> Event t b + -> m (Dynamic t a) accumMDyn f = accumMaybeMDyn $ \v o -> Just <$> f v o -accumMaybeDyn :: (Reflex t, MonadHold t m, MonadFix m) => (a -> b -> Maybe a) -> a -> Event t b -> m (Dynamic t a) + +-- | Accumulate a 'Dynamic' by folding occurrences of an 'Event' +-- with the provided function, discarding 'Nothing' results. +accumMaybeDyn + :: (Reflex t, MonadHold t m, MonadFix m) + => (a -> b -> Maybe a) + -> a + -> Event t b + -> m (Dynamic t a) accumMaybeDyn f = accumMaybeMDyn $ \v o -> return $ f v o -accumMaybeMDyn :: (Reflex t, MonadHold t m, MonadFix m) => (a -> b -> PushM t (Maybe a)) -> a -> Event t b -> m (Dynamic t a) + +-- | Accumulate a 'Dynamic' by folding occurrences of an 'Event' +-- with the provided 'PushM' action, discarding 'Nothing' results. +accumMaybeMDyn + :: (Reflex t, MonadHold t m, MonadFix m) + => (a -> b -> PushM t (Maybe a)) + -> a + -> Event t b + -> m (Dynamic t a) accumMaybeMDyn f z e = do rec let e' = flip push e $ \o -> do v <- sample $ current d' f v o d' <- holdDyn z e' return d' -mapAccumDyn :: (Reflex t, MonadHold t m, MonadFix m) => (a -> b -> (a, c)) -> a -> Event t b -> m (Dynamic t a, Event t c) + +-- | Accumulate a 'Dynamic' by folding occurrences of an 'Event' +-- with a function that both accumulates and produces a value to fire +-- as an 'Event'. Returns both the accumulated value and an 'Event'. +mapAccumDyn + :: (Reflex t, MonadHold t m, MonadFix m) + => (a -> b -> (a, c)) + -> a + -> Event t b + -> m (Dynamic t a, Event t c) mapAccumDyn f = mapAccumMaybeDyn $ \v o -> bimap Just Just $ f v o -mapAccumMDyn :: (Reflex t, MonadHold t m, MonadFix m) => (a -> b -> PushM t (a, c)) -> a -> Event t b -> m (Dynamic t a, Event t c) + +-- | Similar to 'mapAccumDyn' except that the combining function is a +-- 'PushM' action. +mapAccumMDyn + :: (Reflex t, MonadHold t m, MonadFix m) + => (a -> b -> PushM t (a, c)) + -> a + -> Event t b + -> m (Dynamic t a, Event t c) mapAccumMDyn f = mapAccumMaybeMDyn $ \v o -> bimap Just Just <$> f v o -mapAccumMaybeDyn :: (Reflex t, MonadHold t m, MonadFix m) => (a -> b -> (Maybe a, Maybe c)) -> a -> Event t b -> m (Dynamic t a, Event t c) + +-- | Accumulate a 'Dynamic' by folding occurrences of an 'Event' with +-- a function that both optionally accumulates and optionally produces +-- a value to fire as a separate output 'Event'. +-- Note that because 'Nothing's are discarded in both cases, the output +-- 'Event' may fire even though the output 'Dynamic' has not changed, and +-- the output 'Dynamic' may update even when the output 'Event' is not firing. +mapAccumMaybeDyn + :: (Reflex t, MonadHold t m, MonadFix m) + => (a -> b -> (Maybe a, Maybe c)) + -> a + -> Event t b + -> m (Dynamic t a, Event t c) mapAccumMaybeDyn f = mapAccumMaybeMDyn $ \v o -> return $ f v o -mapAccumMaybeMDyn :: (Reflex t, MonadHold t m, MonadFix m) => (a -> b -> PushM t (Maybe a, Maybe c)) -> a -> Event t b -> m (Dynamic t a, Event t c) + +-- | Like 'mapAccumMaybeDyn' except that the combining function is a +-- 'PushM' action. +mapAccumMaybeMDyn + :: (Reflex t, MonadHold t m, MonadFix m) + => (a -> b -> PushM t (Maybe a, Maybe c)) + -> a + -> Event t b + -> m (Dynamic t a, Event t c) mapAccumMaybeMDyn f z e = do rec let e' = flip push e $ \o -> do v <- sample $ current d' @@ -1103,15 +1179,39 @@ mapAccumMaybeMDyn f z e = do d' <- holdDyn z $ fmapMaybe fst e' return (d', fmapMaybe snd e') +-- | Accumulate a 'Behavior' by folding occurrences of an 'Event' +-- with the provided function. {-# INLINE accumB #-} -accumB :: (Reflex t, MonadHold t m, MonadFix m) => (a -> b -> a) -> a -> Event t b -> m (Behavior t a) +accumB + :: (Reflex t, MonadHold t m, MonadFix m) + => (a -> b -> a) + -> a + -> Event t b + -> m (Behavior t a) accumB f = accumMaybeB $ \v o -> Just $ f v o + +-- | Like 'accumB' except that the combining function is a 'PushM' action. {-# INLINE accumMB #-} -accumMB :: (Reflex t, MonadHold t m, MonadFix m) => (a -> b -> PushM t a) -> a -> Event t b -> m (Behavior t a) +accumMB + :: (Reflex t, MonadHold t m, MonadFix m) + => (a -> b -> PushM t a) + -> a + -> Event t b + -> m (Behavior t a) accumMB f = accumMaybeMB $ \v o -> Just <$> f v o + +-- | Accumulate a 'Behavior' by folding occurrences of an 'Event' +-- with the provided function, discarding 'Nothing' results. {-# INLINE accumMaybeB #-} -accumMaybeB :: (Reflex t, MonadHold t m, MonadFix m) => (a -> b -> Maybe a) -> a -> Event t b -> m (Behavior t a) +accumMaybeB + :: (Reflex t, MonadHold t m, MonadFix m) + => (a -> b -> Maybe a) + -> a + -> Event t b + -> m (Behavior t a) accumMaybeB f = accumMaybeMB $ \v o -> return $ f v o + +-- | Like 'accumMaybeB' except that the combining function is a 'PushM' action. {-# INLINE accumMaybeMB #-} accumMaybeMB :: (Reflex t, MonadHold t m, MonadFix m) => (a -> b -> PushM t (Maybe a)) -> a -> Event t b -> m (Behavior t a) accumMaybeMB f z e = do @@ -1120,16 +1220,42 @@ accumMaybeMB f z e = do f v o d' <- hold z e' return d' + +-- | Accumulate a 'Behavior' by folding occurrences of an 'Event' +-- with a function that both accumulates and produces a value to fire +-- as an 'Event'. Returns both the accumulated value and an 'Event'. {-# INLINE mapAccumB #-} -mapAccumB :: (Reflex t, MonadHold t m, MonadFix m) => (a -> b -> (a, c)) -> a -> Event t b -> m (Behavior t a, Event t c) +mapAccumB + :: (Reflex t, MonadHold t m, MonadFix m) + => (a -> b -> (a, c)) + -> a + -> Event t b + -> m (Behavior t a, Event t c) mapAccumB f = mapAccumMaybeB $ \v o -> bimap Just Just $ f v o + +-- | Like 'mapAccumB' except that the combining function is a 'PushM' action. {-# INLINE mapAccumMB #-} -mapAccumMB :: (Reflex t, MonadHold t m, MonadFix m) => (a -> b -> PushM t (a, c)) -> a -> Event t b -> m (Behavior t a, Event t c) +mapAccumMB + :: (Reflex t, MonadHold t m, MonadFix m) + => (a -> b -> PushM t (a, c)) + -> a + -> Event t b + -> m (Behavior t a, Event t c) mapAccumMB f = mapAccumMaybeMB $ \v o -> bimap Just Just <$> f v o + +-- | Accumulate a 'Behavior' by folding occurrences of an 'Event' with +-- a function that both optionally accumulates and optionally produces +-- a value to fire as a separate output 'Event'. 'Nothing's are discarded. {-# INLINE mapAccumMaybeB #-} -mapAccumMaybeB :: (Reflex t, MonadHold t m, MonadFix m) => (a -> b -> (Maybe a, Maybe c)) -> a -> Event t b -> m (Behavior t a, Event t c) +mapAccumMaybeB + :: (Reflex t, MonadHold t m, MonadFix m) + => (a -> b -> (Maybe a, Maybe c)) + -> a + -> Event t b + -> m (Behavior t a, Event t c) mapAccumMaybeB f = mapAccumMaybeMB $ \v o -> return $ f v o +-- | LIke 'mapAccumMaybeB' except that the combining function is a 'PushM' action. {-# INLINE mapAccumMaybeMB #-} mapAccumMaybeMB :: (Reflex t, MonadHold t m, MonadFix m) => (a -> b -> PushM t (Maybe a, Maybe c)) -> a -> Event t b -> m (Behavior t a, Event t c) mapAccumMaybeMB f z e = do @@ -1284,38 +1410,47 @@ infixl 4 <@ -- Cheap Functions ------------------ +-- | A "cheap" version of 'pushAlways'. See the performance note on 'pushCheap'. {-# INLINE pushAlwaysCheap #-} pushAlwaysCheap :: Reflex t => (a -> PushM t b) -> Event t a -> Event t b pushAlwaysCheap f = pushCheap (fmap Just . f) +-- | A "cheap" version of 'fmapMaybe'. See the performance note on 'pushCheap'. {-# INLINE fmapMaybeCheap #-} fmapMaybeCheap :: Reflex t => (a -> Maybe b) -> Event t a -> Event t b fmapMaybeCheap f = pushCheap $ return . f +-- | A "cheap" version of 'fforMaybe'. See the performance note on 'pushCheap'. {-# INLINE fforMaybeCheap #-} fforMaybeCheap :: Reflex t => Event t a -> (a -> Maybe b) -> Event t b fforMaybeCheap = flip fmapMaybeCheap +-- | A "cheap" version of 'ffor'. See the performance note on 'pushCheap'. {-# INLINE fforCheap #-} fforCheap :: Reflex t => Event t a -> (a -> b) -> Event t b fforCheap = flip fmapCheap +-- | A "cheap" version of 'fmap'. See the performance note on 'pushCheap'. {-# INLINE fmapCheap #-} fmapCheap :: Reflex t => (a -> b) -> Event t a -> Event t b fmapCheap f = pushCheap $ return . Just . f +-- | A "cheap" version of 'tag'. See the performance note on 'pushCheap'. {-# INLINE tagCheap #-} tagCheap :: Reflex t => Behavior t b -> Event t a -> Event t b tagCheap b = pushAlwaysCheap $ \_ -> sample b +-- | A "cheap" version of 'mergeWithCheap'. See the performance note on 'pushCheap'. {-# INLINE mergeWithCheap #-} mergeWithCheap :: Reflex t => (a -> a -> a) -> [Event t a] -> Event t a mergeWithCheap = mergeWithCheap' id +-- | A "cheap" version of 'mergeWithCheap''. See the performance note on 'pushCheap'. {-# INLINE mergeWithCheap' #-} mergeWithCheap' :: Reflex t => (a -> b) -> (b -> b -> b) -> [Event t a] -> Event t b mergeWithCheap' f g = mergeWithFoldCheap' $ foldl1 g . fmap f +-- | A "cheap" version of 'mergeWithFoldCheap''. See the performance note on 'pushCheap'. {-# INLINE mergeWithFoldCheap' #-} mergeWithFoldCheap' :: Reflex t => (NonEmpty a -> b) -> [Event t a] -> Event t b mergeWithFoldCheap' f es = diff --git a/src/Reflex/Collection.hs b/src/Reflex/Collection.hs index d0d58eec..5be7a00b 100644 --- a/src/Reflex/Collection.hs +++ b/src/Reflex/Collection.hs @@ -10,6 +10,11 @@ #ifdef USE_REFLEX_OPTIMIZER {-# OPTIONS_GHC -fplugin=Reflex.Optimizer #-} #endif +-- | +-- Module: +-- Reflex.Collection +-- Description: +-- module Reflex.Collection ( -- * Widgets on Collections @@ -38,6 +43,9 @@ import Reflex.Adjustable.Class import Reflex.Dynamic import Reflex.PostBuild.Class +-- | Create a set of widgets based on the provided 'Map'. When the +-- input 'Event' fires, remove widgets for keys with the value 'Nothing' +-- and add/replace widgets for keys with 'Just' values. listHoldWithKey :: forall t m k v a . (Ord k, Adjustable t m, MonadHold t m) @@ -182,6 +190,8 @@ selectViewListWithKey selection vals mkChild = do return $ fmap ((,) k) selectSelf return $ switchPromptlyDyn $ leftmost . Map.elems <$> selectChild +-- | Like 'selectViewListWithKey' but discards the value of the list +-- item widget's output 'Event'. selectViewListWithKey_ :: forall t m k v a . (Adjustable t m, Ord k, PostBuild t m, MonadHold t m, MonadFix m) diff --git a/src/Reflex/Dynamic.hs b/src/Reflex/Dynamic.hs index aae99b2a..5e93ebb7 100644 --- a/src/Reflex/Dynamic.hs +++ b/src/Reflex/Dynamic.hs @@ -17,8 +17,12 @@ #ifdef USE_REFLEX_OPTIMIZER {-# OPTIONS_GHC -fplugin=Reflex.Optimizer #-} #endif --- | This module contains various functions for working with 'Dynamic' values. --- 'Dynamic' and its primitives have been moved to the 'Reflex' class. +-- | +-- Module: +-- Reflex.Dynamic +-- Description: +-- This module contains various functions for working with 'Dynamic' values. +-- 'Dynamic' and its primitives have been moved to the 'Reflex' class. module Reflex.Dynamic ( -- * Basics Dynamic -- Abstract so we can preserve the law that the current value is always equal to the most recent update diff --git a/src/Reflex/FastWeak.hs b/src/Reflex/FastWeak.hs index 95548bc7..141f1264 100644 --- a/src/Reflex/FastWeak.hs +++ b/src/Reflex/FastWeak.hs @@ -6,14 +6,18 @@ {-# LANGUAGE JavaScriptFFI #-} #endif --- | 'FastWeak' is a weak pointer to some value, and 'FastWeakTicket' ensures the value --- referred to by a 'FastWeak' stays live while the ticket is held (live). +-- | +-- Module: +-- Reflex.FastWeak +-- Description: +-- 'FastWeak' is a weak pointer to some value, and 'FastWeakTicket' ensures the value +-- referred to by a 'FastWeak' stays live while the ticket is held (live). -- --- On GHC or GHCJS when not built with the @fast-weak@ cabal flag, 'FastWeak' is a wrapper --- around the simple version of 'System.Mem.Weak.Weak' where the key and value are the same. +-- On GHC or GHCJS when not built with the @fast-weak@ cabal flag, 'FastWeak' is a wrapper +-- around the simple version of 'System.Mem.Weak.Weak' where the key and value are the same. -- --- On GHCJS when built with the @fast-weak@ cabal flag, 'FastWeak' is implemented directly --- in JS using @h$FastWeak@ and @h$FastWeakTicket@ which are a nonstandard part of the GHCJS RTS. +-- On GHCJS when built with the @fast-weak@ cabal flag, 'FastWeak' is implemented directly +-- in JS using @h$FastWeak@ and @h$FastWeakTicket@ which are a nonstandard part of the GHCJS RTS. module Reflex.FastWeak ( FastWeakTicket , FastWeak diff --git a/src/Reflex/FunctorMaybe.hs b/src/Reflex/FunctorMaybe.hs index e4da2532..b1d0b9b9 100644 --- a/src/Reflex/FunctorMaybe.hs +++ b/src/Reflex/FunctorMaybe.hs @@ -2,8 +2,12 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE StandaloneDeriving #-} --- | This module defines the FunctorMaybe class, which extends Functors with the --- ability to delete values. +-- | +-- Module: +-- Reflex.FunctorMaybe +-- Description: +-- This module defines the FunctorMaybe class, which extends Functors with the +-- ability to delete values. module Reflex.FunctorMaybe ( FunctorMaybe (..) ) where diff --git a/src/Reflex/Network.hs b/src/Reflex/Network.hs index 6d3b774e..b860526e 100644 --- a/src/Reflex/Network.hs +++ b/src/Reflex/Network.hs @@ -3,6 +3,11 @@ #ifdef USE_REFLEX_OPTIMIZER {-# OPTIONS_GHC -fplugin=Reflex.Optimizer #-} #endif +-- | +-- Module: +-- Reflex.Network +-- Description: +-- This module provides combinators for building FRP graphs/networks and modifying them dynamically. module Reflex.Network ( networkView , networkHold @@ -14,16 +19,17 @@ import Reflex.Adjustable.Class import Reflex.NotReady.Class import Reflex.PostBuild.Class --- | Given a Dynamic of network-creating actions, create a network that is recreated whenever the Dynamic updates. --- The returned Event of network results occurs when the Dynamic does. --- Note: Often, the type 'a' is an Event, in which case the return value is an Event-of-Events that would typically be flattened (via 'switchPromptly'). +-- | A 'Dynamic' "network": Takes a 'Dynamic' of network-creating actions and replaces the network whenever the 'Dynamic' updates. +-- The returned Event of network results fires when the 'Dynamic' updates. +-- Note: Often, the type 'a' is an Event, in which case the return value is an Event-of-Events, where the outer 'Event' fires +-- when switching networks. Such an 'Event' would typically be flattened (via 'switchPromptly'). networkView :: (NotReady t m, Adjustable t m, PostBuild t m) => Dynamic t (m a) -> m (Event t a) networkView child = do postBuild <- getPostBuild let newChild = leftmost [updated child, tagCheap (current child) postBuild] snd <$> runWithReplace notReady newChild --- | Given an initial network and an Event of network-creating actions, create a network that is recreated whenever the Event fires. +-- | Given an initial "network" and an 'Event' of network-creating actions, create a network that is recreated whenever the Event fires. -- The returned Dynamic of network results occurs when the Event does. -- Note: Often, the type 'a' is an Event, in which case the return value is a Dynamic-of-Events that would typically be flattened. networkHold :: (Adjustable t m, MonadHold t m) => m a -> Event t (m a) -> m (Dynamic t a) diff --git a/src/Reflex/Optimizer.hs b/src/Reflex/Optimizer.hs index 19763e03..63ca5cb7 100644 --- a/src/Reflex/Optimizer.hs +++ b/src/Reflex/Optimizer.hs @@ -1,10 +1,14 @@ --- | This module provides a GHC plugin designed to improve code that uses --- Reflex. Currently, it just adds an INLINABLE pragma to any top-level --- definition that doesn't have an explicit inlining pragma. In the future, --- additional optimizations are likely to be added. {-# LANGUAGE CPP #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} +-- | +-- Module: +-- Reflex.Optimizer +-- Description: +-- This module provides a GHC plugin designed to improve code that uses +-- Reflex. Currently, it just adds an INLINABLE pragma to any top-level +-- definition that doesn't have an explicit inlining pragma. In the future, +-- additional optimizations are likely to be added. module Reflex.Optimizer ( plugin ) where diff --git a/src/Reflex/Patch.hs b/src/Reflex/Patch.hs index bce3598f..01bc75ab 100644 --- a/src/Reflex/Patch.hs +++ b/src/Reflex/Patch.hs @@ -1,6 +1,10 @@ --- | This module defines the 'Patch' class, which is used by Reflex to manage --- changes to 'Reflex.Class.Incremental' values. {-# LANGUAGE TypeFamilies #-} +-- | +-- Module: +-- Reflex.Patch +-- Description: +-- This module defines the 'Patch' class, which is used by Reflex to manage +-- changes to 'Reflex.Class.Incremental' values. module Reflex.Patch ( module Reflex.Patch , module X @@ -17,11 +21,8 @@ import Reflex.Patch.Map as X import Reflex.Patch.MapWithMove as X (PatchMapWithMove, patchMapWithMoveNewElements, patchMapWithMoveNewElementsMap, unPatchMapWithMove, unsafePatchMapWithMove) - import Data.Semigroup (Semigroup (..), (<>)) ----- Patches based on commutative groups - -- | A 'Group' is a 'Monoid' where every element has an inverse. class (Semigroup q, Monoid q) => Group q where negateG :: q -> q diff --git a/src/Reflex/Profiled.hs b/src/Reflex/Profiled.hs index dff9fc58..c0322da2 100644 --- a/src/Reflex/Profiled.hs +++ b/src/Reflex/Profiled.hs @@ -8,6 +8,12 @@ {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} +-- | +-- Module: +-- Reflex.Profiled +-- Description: +-- This module contains an instance of the 'Reflex' class that provides +-- profiling/cost-center information. module Reflex.Profiled where import Control.Lens hiding (children) diff --git a/src/Reflex/Pure.hs b/src/Reflex/Pure.hs index b6d0be42..43d38608 100644 --- a/src/Reflex/Pure.hs +++ b/src/Reflex/Pure.hs @@ -13,11 +13,13 @@ -- * MonadSample (Pure t) ((->) t) -- * MonadHold (Pure t) ((->) t) {-# OPTIONS_GHC -fno-warn-orphans #-} - --- | This module provides a pure implementation of Reflex, which is intended to --- serve as a reference for the semantics of the Reflex class. All --- implementations of Reflex should produce the same results as this --- implementation, although performance and laziness/strictness may differ. +-- | +-- Module: Reflex.Pure +-- Description: +-- This module provides a pure implementation of Reflex, which is intended to +-- serve as a reference for the semantics of the Reflex class. All +-- implementations of Reflex should produce the same results as this +-- implementation, although performance and laziness/strictness may differ. module Reflex.Pure ( Pure , Behavior (..) diff --git a/src/Reflex/Spider.hs b/src/Reflex/Spider.hs index decb31f7..6dc64761 100644 --- a/src/Reflex/Spider.hs +++ b/src/Reflex/Spider.hs @@ -1,6 +1,9 @@ {-# LANGUAGE CPP #-} --- | This module exports all of the user-facing functionality of the 'Spider' --- 'Reflex' engine +-- | +-- Module: +-- Reflex.Spider +-- Description: +-- This module exports all of the user-facing functionality of the 'Spider' 'Reflex' engine module Reflex.Spider ( Spider , SpiderTimeline diff --git a/src/Reflex/Time.hs b/src/Reflex/Time.hs index 9193b42f..16bb3e97 100644 --- a/src/Reflex/Time.hs +++ b/src/Reflex/Time.hs @@ -11,6 +11,11 @@ #ifdef USE_TEMPLATE_HASKELL {-# LANGUAGE TemplateHaskell #-} #endif +-- | +-- Module: +-- Reflex.Time +-- Description: +-- Clocks, timers, and other time-related functions. module Reflex.Time where import Reflex.Class @@ -37,38 +42,39 @@ import Data.Typeable import GHC.Generics (Generic) import System.Random +-- | Metadata associated with a timer "tick" data TickInfo = TickInfo { _tickInfo_lastUTC :: UTCTime -- ^ UTC time immediately after the last tick. , _tickInfo_n :: Integer - -- ^ Number of time periods since t0 + -- ^ Number of time periods or ticks since the start of the timer , _tickInfo_alreadyElapsed :: NominalDiffTime - -- ^ Amount of time already elapsed in the current tick period. + -- ^ Amount of time that has elapsed in the current tick period. } deriving (Eq, Ord, Show, Typeable) --- | Special case of 'tickLossyFrom' that uses the post-build event to start the --- tick thread. +-- | Fires an 'Event' once every time provided interval elapses, approximately. +-- The provided 'UTCTime' is used bootstrap the determination of how much time has elapsed with each tick. +-- This is a special case of 'tickLossyFrom' that uses the post-build event to start the tick thread. tickLossy :: (PostBuild t m, PerformEvent t m, TriggerEvent t m, MonadIO (Performable m), MonadFix m) => NominalDiffTime -> UTCTime -> m (Event t TickInfo) tickLossy dt t0 = tickLossyFrom dt t0 =<< getPostBuild --- | Special case of 'tickLossyFrom' that uses the post-build event to start the --- tick thread and the time of the post-build as the tick basis time. +-- | Fires an 'Event' once every time provided interval elapses, approximately. +-- This is a special case of 'tickLossyFrom' that uses the post-build event to start the tick thread and the time of the post-build as the tick basis time. tickLossyFromPostBuildTime :: (PostBuild t m, PerformEvent t m, TriggerEvent t m, MonadIO (Performable m), MonadFix m) => NominalDiffTime -> m (Event t TickInfo) tickLossyFromPostBuildTime dt = do postBuild <- getPostBuild postBuildTime <- performEvent $ liftIO getCurrentTime <$ postBuild tickLossyFrom' $ (dt,) <$> postBuildTime --- | Send events over time with the given basis time and interval --- If the system starts running behind, occurrences will be dropped rather than buffered --- Each occurrence of the resulting event will contain the index of the current interval, with 0 representing the basis time +-- | Fires an 'Event' approximately each time the provided interval elapses. If the system starts running behind, occurrences will be dropped rather than buffered. +-- Each occurrence of the resulting event will contain the index of the current interval, with 0 representing the provided initial time. tickLossyFrom :: (PerformEvent t m, TriggerEvent t m, MonadIO (Performable m), MonadFix m) => NominalDiffTime -- ^ The length of a tick interval -> UTCTime - -- ^ The basis time from which intervals count + -- ^ The basis time from which intervals count and with which the initial calculation of elapsed time will be made. -> Event t a -- ^ Event that starts a tick generation thread. Usually you want this to -- be something like the result of getPostBuild that only fires once. But @@ -76,12 +82,12 @@ tickLossyFrom -> m (Event t TickInfo) tickLossyFrom dt t0 e = tickLossyFrom' $ (dt, t0) <$ e --- | Generalization of tickLossyFrom that takes dt and t0 in the event. +-- | Generalization of tickLossyFrom that takes the delay and initial time as an 'Event'. tickLossyFrom' :: (PerformEvent t m, TriggerEvent t m, MonadIO (Performable m), MonadFix m) => Event t (NominalDiffTime, UTCTime) -- ^ Event that starts a tick generation thread. Usually you want this to - -- be something like the result of getPostBuild that only fires once. But + -- be something like the result of 'getPostBuild' that only fires once. But -- there could be uses for starting multiple timer threads. -> m (Event t TickInfo) tickLossyFrom' e = do @@ -92,12 +98,16 @@ tickLossyFrom' e = do Concurrent.delay $ ceiling $ (fst pair - _tickInfo_alreadyElapsed tick) * 1000000 cb (tick, pair) +-- | Like 'tickLossy', but immediately calculates the first tick and provides a 'Dynamic' that is updated as ticks fire. clockLossy :: (MonadIO m, PerformEvent t m, TriggerEvent t m, MonadIO (Performable m), PostBuild t m, MonadHold t m, MonadFix m) => NominalDiffTime -> UTCTime -> m (Dynamic t TickInfo) clockLossy dt t0 = do initial <- liftIO $ getCurrentTick dt t0 e <- tickLossy dt t0 holdDyn initial e +-- | Generates a 'TickInfo', given the specified interval and timestamp. The 'TickInfo' will include the +-- current time, the number of ticks that have elapsed since the timestamp, and the amount of time that +-- has elapsed since the start time of this tick. getCurrentTick :: NominalDiffTime -> UTCTime -> IO TickInfo getCurrentTick dt t0 = do t <- getCurrentTime @@ -278,7 +288,7 @@ data ThrottleState b data ThrottleBuffer b = ThrottleBuffer_Empty -- Empty conflicts with lens, and hiding it would require turning - -- on PatternSynonyms + -- on PatternSynonyms | ThrottleBuffer_Full b deriving (Eq, Ord, Show, Functor, Foldable, Traversable, Generic, Data, Typeable) diff --git a/src/Reflex/Workflow.hs b/src/Reflex/Workflow.hs index 288f4bb0..c1fcca95 100644 --- a/src/Reflex/Workflow.hs +++ b/src/Reflex/Workflow.hs @@ -1,7 +1,13 @@ {-# LANGUAGE RecursiveDo #-} {-# LANGUAGE ScopedTypeVariables #-} +-- | +-- Module: +-- Reflex.Workflow +-- Description: +-- Provides a convenient way to describe a series of interrelated widgets that +-- can send data to, invoke, and replace one another. Useful for modeling user interface +-- "workflows." module Reflex.Workflow ( - -- * Workflows Workflow (..) , workflow , workflowView @@ -18,21 +24,27 @@ import Reflex.Network import Reflex.NotReady.Class import Reflex.PostBuild.Class +-- | A widget in a workflow +-- When the 'Event' returned by a 'Workflow' fires, the current 'Workflow' is replaced by the one inside the firing 'Event'. A series of 'Workflow's must share the same return type. newtype Workflow t m a = Workflow { unWorkflow :: m (a, Event t (Workflow t m a)) } +-- | Runs a 'Workflow' and returns the 'Dynamic' result of the 'Workflow' (i.e., a 'Dynamic' of the value produced by the current 'Workflow' node, and whose update 'Event' fires whenever one 'Workflow' is replaced by another). workflow :: forall t m a. (Reflex t, Adjustable t m, MonadFix m, MonadHold t m) => Workflow t m a -> m (Dynamic t a) workflow w0 = do rec eResult <- networkHold (unWorkflow w0) $ fmap unWorkflow $ switch $ snd <$> current eResult return $ fmap fst eResult +-- | Similar to 'workflow', but outputs an 'Event' that fires whenever the current 'Workflow' is replaced by the next 'Workflow'. workflowView :: forall t m a. (Reflex t, NotReady t m, Adjustable t m, MonadFix m, MonadHold t m, PostBuild t m) => Workflow t m a -> m (Event t a) workflowView w0 = do rec eResult <- networkView . fmap unWorkflow =<< holdDyn w0 eReplace eReplace <- fmap switch $ hold never $ fmap snd eResult return $ fmap fst eResult +-- | Map a function over a 'Workflow', possibly changing the resturn type. mapWorkflow :: (Reflex t, Functor m) => (a -> b) -> Workflow t m a -> Workflow t m b mapWorkflow f (Workflow x) = Workflow (fmap (f *** fmap (mapWorkflow f)) x) +-- | Map a "cheap" function over a 'Workflow'. Refer to the documentation for 'pushCheap' for more information and performance considerations. mapWorkflowCheap :: (Reflex t, Functor m) => (a -> b) -> Workflow t m a -> Workflow t m b mapWorkflowCheap f (Workflow x) = Workflow (fmap (f *** fmapCheap (mapWorkflowCheap f)) x) From cbbba302c9e07a2a6b70d81b2998f187349d5c72 Mon Sep 17 00:00:00 2001 From: Ali Abrar Date: Sat, 16 Mar 2019 23:57:47 -0400 Subject: [PATCH 109/241] Remove some long-deprecated functions --- src/Data/Functor/Misc.hs | 45 +--------------------------------------- 1 file changed, 1 insertion(+), 44 deletions(-) diff --git a/src/Data/Functor/Misc.hs b/src/Data/Functor/Misc.hs index e5950db4..7afa0289 100644 --- a/src/Data/Functor/Misc.hs +++ b/src/Data/Functor/Misc.hs @@ -38,17 +38,10 @@ module Data.Functor.Misc , dmapToThese , eitherToDSum , dsumToEither - -- * Deprecated functions - , sequenceDmap - , wrapDMap - , rewrapDMap - , unwrapDMap - , unwrapDMapMaybe - , extractFunctorDMap , ComposeMaybe (..) ) where -import Control.Applicative (Applicative, (<$>)) +import Control.Applicative ((<$>)) import Control.Monad.Identity import Data.Dependent.Map (DMap) import qualified Data.Dependent.Map as DMap @@ -249,39 +242,3 @@ newtype ComposeMaybe f a = ComposeMaybe { getComposeMaybe :: Maybe (f a) } deriving (Show, Eq, Ord) deriving instance Functor f => Functor (ComposeMaybe f) - --------------------------------------------------------------------------------- --- Deprecated functions --------------------------------------------------------------------------------- - -{-# INLINE sequenceDmap #-} -{-# DEPRECATED sequenceDmap "Use 'Data.Dependent.Map.traverseWithKey (\\_ -> fmap Identity)' instead" #-} --- | Run the actions contained in the 'DMap' -sequenceDmap :: Applicative t => DMap f t -> t (DMap f Identity) -sequenceDmap = DMap.traverseWithKey $ \_ t -> Identity <$> t - -{-# DEPRECATED wrapDMap "Use 'Data.Dependent.Map.map (f . runIdentity)' instead" #-} --- | Replace the 'Identity' functor for a 'DMap''s values with a different functor -wrapDMap :: (forall a. a -> f a) -> DMap k Identity -> DMap k f -wrapDMap f = DMap.map $ f . runIdentity - -{-# DEPRECATED rewrapDMap "Use 'Data.Dependent.Map.map' instead" #-} --- | Replace one functor for a 'DMap''s values with a different functor -rewrapDMap :: (forall (a :: *). f a -> g a) -> DMap k f -> DMap k g -rewrapDMap = DMap.map - -{-# DEPRECATED unwrapDMap "Use 'Data.Dependent.Map.map (Identity . f)' instead" #-} --- | Replace one functor for a 'DMap''s values with the 'Identity' functor -unwrapDMap :: (forall a. f a -> a) -> DMap k f -> DMap k Identity -unwrapDMap f = DMap.map $ Identity . f - -{-# DEPRECATED unwrapDMapMaybe "Use 'Data.Dependent.Map.mapMaybeWithKey (\\_ a -> fmap Identity $ f a)' instead" #-} --- | Like 'unwrapDMap', but possibly delete some values from the DMap -unwrapDMapMaybe :: GCompare k => (forall a. f a -> Maybe a) -> DMap k f -> DMap k Identity -unwrapDMapMaybe f = DMap.mapMaybeWithKey $ \_ a -> Identity <$> f a - -{-# DEPRECATED extractFunctorDMap "Use 'mapKeyValuePairsMonotonic (\\(Const2 k :=> Identity v) -> Const2 k :=> v)' instead" #-} --- | Eliminate the 'Identity' functor in a 'DMap' and replace it with the --- underlying functor -extractFunctorDMap :: DMap (Const2 k (f v)) Identity -> DMap (Const2 k v) f -extractFunctorDMap = mapKeyValuePairsMonotonic $ \(Const2 k :=> Identity v) -> Const2 k :=> v From 5427c27b1ef567fb1bda5c00ad88aa1fc2250ec2 Mon Sep 17 00:00:00 2001 From: Ali Abrar Date: Sun, 17 Mar 2019 00:01:20 -0400 Subject: [PATCH 110/241] Unorphan MonoidalMap Group and Additive instances --- src/Data/AppendMap.hs | 11 ----------- src/Reflex/Patch.hs | 6 ++++++ 2 files changed, 6 insertions(+), 11 deletions(-) diff --git a/src/Data/AppendMap.hs b/src/Data/AppendMap.hs index b84df7a8..707fbc95 100644 --- a/src/Data/AppendMap.hs +++ b/src/Data/AppendMap.hs @@ -1,15 +1,10 @@ {-# LANGUAGE CPP #-} -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DeriveTraversable #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE RoleAnnotations #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeFamilies #-} {-# OPTIONS_GHC -fno-warn-orphans #-} -- | 'Data.Map' with a better 'Monoid' instance @@ -33,7 +28,6 @@ import qualified Data.Map as Map (showTree, showTreeWith) #endif import Data.Map.Monoidal import Reflex.Class (FunctorMaybe (..)) -import Reflex.Patch (Additive, Group (..)) {-# DEPRECATED AppendMap "Use 'MonoidalMap' instead" #-} type AppendMap = MonoidalMap @@ -66,11 +60,6 @@ mapMaybeNoNull f as = else Just bs -- TODO: Move instances to `Reflex.Patch` -instance (Ord k, Group q) => Group (MonoidalMap k q) where - negateG = map negateG - -instance (Ord k, Additive q) => Additive (MonoidalMap k q) - showTree :: forall k a. (Show k, Show a) => MonoidalMap k a -> String showTree = coerce (Map.showTree :: Map k a -> String) diff --git a/src/Reflex/Patch.hs b/src/Reflex/Patch.hs index 01bc75ab..5eb75329 100644 --- a/src/Reflex/Patch.hs +++ b/src/Reflex/Patch.hs @@ -21,6 +21,7 @@ import Reflex.Patch.Map as X import Reflex.Patch.MapWithMove as X (PatchMapWithMove, patchMapWithMoveNewElements, patchMapWithMoveNewElementsMap, unPatchMapWithMove, unsafePatchMapWithMove) +import Data.Map.Monoidal (MonoidalMap) import Data.Semigroup (Semigroup (..), (<>)) -- | A 'Group' is a 'Monoid' where every element has an inverse. @@ -38,3 +39,8 @@ newtype AdditivePatch p = AdditivePatch { unAdditivePatch :: p } instance Additive p => Patch (AdditivePatch p) where type PatchTarget (AdditivePatch p) = p apply (AdditivePatch p) q = Just $ p <> q + +instance (Ord k, Group q) => Group (MonoidalMap k q) where + negateG = fmap negateG + +instance (Ord k, Additive q) => Additive (MonoidalMap k q) From bef906e8a916b2c73152183a5236feb7f4ac5c64 Mon Sep 17 00:00:00 2001 From: Ali Abrar Date: Sun, 17 Mar 2019 00:55:37 -0400 Subject: [PATCH 111/241] Deprecate FunctorMaybe in favor of Filterable --- default.nix | 4 +- reflex.cabal | 3 +- src/Data/AppendMap.hs | 11 ++--- src/Reflex/Class.hs | 77 ++++++++++++++++++++++------------- src/Reflex/FunctorMaybe.hs | 25 +++--------- src/Reflex/Requester/Base.hs | 4 +- src/Reflex/Spider/Internal.hs | 10 ++--- src/Reflex/Time.hs | 2 +- 8 files changed, 73 insertions(+), 63 deletions(-) diff --git a/default.nix b/default.nix index cdb8bf90..d72ee650 100644 --- a/default.nix +++ b/default.nix @@ -6,7 +6,7 @@ , template-haskell , these, time, transformers , transformers-compat, unbounded-delays, prim-uniq , data-default, filepath, directory, filemanip, ghcjs-base -, monoidal-containers +, monoidal-containers, witherable , useTemplateHaskell ? true }: mkDerivation { @@ -21,7 +21,7 @@ mkDerivation { transformers-compat prim-uniq base bifunctors containers deepseq dependent-map dependent-sum mtl ref-tf split transformers data-default - random time unbounded-delays monoidal-containers + random time unbounded-delays monoidal-containers witherable ] ++ (if ghc.isGhcjs or false then [ ghcjs-base ] else []) ++ (if !useTemplateHaskell then [] else [ diff --git a/reflex.cabal b/reflex.cabal index 841a7213..c136c1ae 100644 --- a/reflex.cabal +++ b/reflex.cabal @@ -64,7 +64,8 @@ library time >= 1.4 && < 1.9, transformers >= 0.2, transformers-compat >= 0.3, - unbounded-delays >= 0.1.0.0 && < 0.2 + unbounded-delays >= 0.1.0.0 && < 0.2, + witherable >= 0.2 && < 0.4 exposed-modules: Data.AppendMap, diff --git a/src/Data/AppendMap.hs b/src/Data/AppendMap.hs index b84df7a8..8ec93da6 100644 --- a/src/Data/AppendMap.hs +++ b/src/Data/AppendMap.hs @@ -31,9 +31,10 @@ import qualified Data.Map.Internal.Debug as Map (showTree, showTreeWith) #else import qualified Data.Map as Map (showTree, showTreeWith) #endif -import Data.Map.Monoidal -import Reflex.Class (FunctorMaybe (..)) import Reflex.Patch (Additive, Group (..)) +import Data.Map.Monoidal hiding (mapMaybe) +import qualified Data.Map.Monoidal as M +import Data.Witherable (Filterable(..)) {-# DEPRECATED AppendMap "Use 'MonoidalMap' instead" #-} type AppendMap = MonoidalMap @@ -45,8 +46,8 @@ _unAppendMap = getMonoidalMap pattern AppendMap :: Map k v -> MonoidalMap k v pattern AppendMap m = MonoidalMap m -instance FunctorMaybe (MonoidalMap k) where - fmapMaybe = mapMaybe +instance Filterable (MonoidalMap k) where + mapMaybe = M.mapMaybe -- | Deletes a key, returning 'Nothing' if the result is empty. nonEmptyDelete :: Ord k => k -> MonoidalMap k a -> Maybe (MonoidalMap k a) @@ -60,7 +61,7 @@ mapMaybeNoNull :: (a -> Maybe b) -> MonoidalMap token a -> Maybe (MonoidalMap token b) mapMaybeNoNull f as = - let bs = fmapMaybe f as + let bs = mapMaybe f as in if null bs then Nothing else Just bs diff --git a/src/Reflex/Class.hs b/src/Reflex/Class.hs index 71d96979..2604fb05 100644 --- a/src/Reflex/Class.hs +++ b/src/Reflex/Class.hs @@ -133,8 +133,9 @@ module Reflex.Class -- * Unsafe functions , unsafeDynamic , unsafeMapIncremental - -- * 'FunctorMaybe' - , FunctorMaybe (..) + -- * 'Filterable' convenience functions + , FunctorMaybe -- fmapMaybe is purposely not exported from deprecated 'FunctorMaybe' and the new alias is exported instead + , fmapMaybe , fforMaybe , ffilter , filterLeft @@ -147,6 +148,7 @@ module Reflex.Class , appendEvents , onceE , sequenceThese + , mapMaybeCheap , fmapMaybeCheap , fmapCheap , fforCheap @@ -193,7 +195,10 @@ import qualified Data.Some as Some import Data.String import Data.These import Data.Type.Coercion -import Reflex.FunctorMaybe +import Data.Witherable (Filterable(..)) +import qualified Data.Witherable as W +import Reflex.FunctorMaybe (FunctorMaybe) +import qualified Reflex.FunctorMaybe import Reflex.Patch import qualified Reflex.Patch.MapWithMove as PatchMapWithMove @@ -388,8 +393,8 @@ mapAccumMaybeMIncremental f z e = do return $ case result of (Nothing, Nothing) -> Nothing _ -> Just result - d' <- holdIncremental z $ fmapMaybe fst e' - return (d', fmapMaybe snd e') + d' <- holdIncremental z $ mapMaybe fst e' + return (d', mapMaybe snd e') slowHeadE :: (Reflex t, MonadHold t m, MonadFix m) => Event t a -> m (Event t a) slowHeadE e = do @@ -399,14 +404,14 @@ slowHeadE e = do -- | An 'EventSelector' allows you to efficiently 'select' an 'Event' based on a -- key. This is much more efficient than filtering for each key with --- 'fmapMaybe'. +-- 'mapMaybe'. newtype EventSelector t k = EventSelector { -- | Retrieve the 'Event' for the given key. The type of the 'Event' is -- determined by the type of the key, so this can be used to fan-out -- 'Event's whose sub-'Event's have different types. -- -- Using 'EventSelector's and the 'fan' primitive is far more efficient than - -- (but equivalent to) using 'fmapMaybe' to select only the relevant + -- (but equivalent to) using 'mapMaybe' to select only the relevant -- occurrences of an 'Event'. select :: forall a. k a -> Event t a } @@ -550,22 +555,25 @@ instance (Reflex t, Semigroup a) => Semigroup (Behavior t a) where times1p n = fmap $ times1p n #endif --- | Flipped version of 'fmapMaybe'. -fforMaybe :: FunctorMaybe f => f a -> (a -> Maybe b) -> f b -fforMaybe = flip fmapMaybe +-- | Alias for 'mapMaybe' +fmapMaybe :: Filterable f => (a -> Maybe b) -> f a -> f b +fmapMaybe = mapMaybe + +-- | Flipped version of 'mapMaybe'. +fforMaybe :: Filterable f => f a -> (a -> Maybe b) -> f b +fforMaybe = flip mapMaybe -- | Filter 'f a' using the provided predicate. --- Relies on 'fforMaybe'. -ffilter :: FunctorMaybe f => (a -> Bool) -> f a -> f a -ffilter f = fmapMaybe $ \x -> if f x then Just x else Nothing +ffilter :: Filterable f => (a -> Bool) -> f a -> f a +ffilter = W.filter -- | Filter 'Left's from 'f (Either a b)' into 'a'. -filterLeft :: FunctorMaybe f => f (Either a b) -> f a -filterLeft = fmapMaybe (either Just (const Nothing)) +filterLeft :: Filterable f => f (Either a b) -> f a +filterLeft = mapMaybe (either Just (const Nothing)) -- | Filter 'Right's from 'f (Either a b)' into 'b'. -filterRight :: FunctorMaybe f => f (Either a b) -> f b -filterRight = fmapMaybe (either (const Nothing) Just) +filterRight :: Filterable f => f (Either a b) -> f b +filterRight = mapMaybe (either (const Nothing) Just) -- | Left-biased event union (prefers left event on simultaneous -- occurrence). @@ -583,13 +591,18 @@ instance Reflex t => Bind (Event t) where instance Reflex t => Functor (Event t) where {-# INLINE fmap #-} - fmap f = fmapMaybe $ Just . f + fmap f = mapMaybe $ Just . f {-# INLINE (<$) #-} x <$ e = fmapCheap (const x) e +-- TODO Remove this instance instance Reflex t => FunctorMaybe (Event t) where {-# INLINE fmapMaybe #-} - fmapMaybe f = push $ return . f + fmapMaybe = mapMaybe + +instance Reflex t => Filterable (Event t) where + {-# INLINE mapMaybe #-} + mapMaybe f = push $ return . f -- | Never: @'zero' = 'never'@. instance Reflex t => Plus (Event t) where @@ -807,7 +820,7 @@ fanEither :: Reflex t => Event t (Either a b) -> (Event t a, Event t b) fanEither e = let justLeft = either Just (const Nothing) justRight = either (const Nothing) Just - in (fmapMaybe justLeft e, fmapMaybe justRight e) + in (mapMaybe justLeft e, mapMaybe justRight e) -- | Split the event into separate events for 'This' and 'That' values, -- allowing them to fire simultaneously when the input value is 'These'. @@ -819,7 +832,7 @@ fanThese e = that (That y) = Just y that (These _ y) = Just y that _ = Nothing - in (fmapMaybe this e, fmapMaybe that e) + in (mapMaybe this e, mapMaybe that e) -- | Split the event into an 'EventSelector' that allows efficient selection of -- the individual 'Event's. @@ -1002,9 +1015,11 @@ difference = alignEventWithMaybe $ \case alignEventWithMaybe :: Reflex t => (These a b -> Maybe c) -> Event t a -> Event t b -> Event t c alignEventWithMaybe f ea eb = - fmapMaybe (f <=< dmapToThese) + mapMaybe (f <=< dmapToThese) $ merge $ DMap.fromList [LeftTag :=> ea, RightTag :=> eb] +alignEventWithMaybe f ea eb = mapMaybe (f <=< dmapToThese) $ + merge $ DMap.fromList [LeftTag :=> ea, RightTag :=> eb] filterEventKey :: forall t m k v a. @@ -1100,8 +1115,8 @@ mapAccumMaybeMDyn f z e = do return $ case result of (Nothing, Nothing) -> Nothing _ -> Just result - d' <- holdDyn z $ fmapMaybe fst e' - return (d', fmapMaybe snd e') + d' <- holdDyn z $ mapMaybe fst e' + return (d', mapMaybe snd e') {-# INLINE accumB #-} accumB :: (Reflex t, MonadHold t m, MonadFix m) => (a -> b -> a) -> a -> Event t b -> m (Behavior t a) @@ -1139,8 +1154,8 @@ mapAccumMaybeMB f z e = do return $ case result of (Nothing, Nothing) -> Nothing _ -> Just result - d' <- hold z $ fmapMaybe fst e' - return (d', fmapMaybe snd e') + d' <- hold z $ mapMaybe fst e' + return (d', mapMaybe snd e') -- | Accumulate occurrences of an 'Event', producing an output occurrence each -- time. Discard the underlying 'Accumulator'. @@ -1288,13 +1303,19 @@ infixl 4 <@ pushAlwaysCheap :: Reflex t => (a -> PushM t b) -> Event t a -> Event t b pushAlwaysCheap f = pushCheap (fmap Just . f) +{-# INLINE mapMaybeCheap #-} +mapMaybeCheap :: Reflex t => (a -> Maybe b) -> Event t a -> Event t b +mapMaybeCheap f = pushCheap $ return . f + +-- | An alias for 'mapMaybeCheap' {-# INLINE fmapMaybeCheap #-} fmapMaybeCheap :: Reflex t => (a -> Maybe b) -> Event t a -> Event t b -fmapMaybeCheap f = pushCheap $ return . f +fmapMaybeCheap = mapMaybeCheap + {-# INLINE fforMaybeCheap #-} fforMaybeCheap :: Reflex t => Event t a -> (a -> Maybe b) -> Event t b -fforMaybeCheap = flip fmapMaybeCheap +fforMaybeCheap = flip mapMaybeCheap {-# INLINE fforCheap #-} fforCheap :: Reflex t => Event t a -> (a -> b) -> Event t b diff --git a/src/Reflex/FunctorMaybe.hs b/src/Reflex/FunctorMaybe.hs index e4da2532..5c647a63 100644 --- a/src/Reflex/FunctorMaybe.hs +++ b/src/Reflex/FunctorMaybe.hs @@ -9,46 +9,33 @@ module Reflex.FunctorMaybe ) where import Data.IntMap (IntMap) -import qualified Data.IntMap as IntMap import Data.Map (Map) -import qualified Data.Map as Map -import Data.Maybe #if MIN_VERSION_base(4,9,0) import Data.Semigroup (Option(..)) #endif +import Data.Witherable --TODO: See if there's a better class in the standard libraries already -- | A class for values that combines filtering and mapping using 'Maybe'. --- Morally, @'FunctorMaybe' ~ KleisliFunctor 'Maybe'@. Also similar is the --- @Witherable@ typeclass, but it requires @'Foldable' f@ and @'Traversable' f@, --- and e.g. 'Event' is instance of neither. --- --- A definition of 'fmapMaybe' must satisfy the following laws: --- --- [/identity/] --- @'fmapMaybe' 'Just' ≡ 'id'@ --- --- [/composition/] --- @'fmapMaybe' (f <=< g) ≡ 'fmapMaybe' f . 'fmapMaybe' g@ +-- Morally, @'FunctorMaybe' ~ KleisliFunctor 'Maybe'@. +{-# DEPRECATED FunctorMaybe "Use 'Filterable' from Data.Witherable instead" #-} class FunctorMaybe f where -- | Combined mapping and filtering function. fmapMaybe :: (a -> Maybe b) -> f a -> f b --- | @fmapMaybe = (=<<) instance FunctorMaybe Maybe where - fmapMaybe = (=<<) + fmapMaybe = mapMaybe #if MIN_VERSION_base(4,9,0) deriving instance FunctorMaybe Option #endif --- | @fmapMaybe = mapMaybe@ instance FunctorMaybe [] where fmapMaybe = mapMaybe instance FunctorMaybe (Map k) where - fmapMaybe = Map.mapMaybe + fmapMaybe = mapMaybe instance FunctorMaybe IntMap where - fmapMaybe = IntMap.mapMaybe + fmapMaybe = mapMaybe diff --git a/src/Reflex/Requester/Base.hs b/src/Reflex/Requester/Base.hs index 9d50ee32..38ff767f 100644 --- a/src/Reflex/Requester/Base.hs +++ b/src/Reflex/Requester/Base.hs @@ -378,7 +378,7 @@ traverseIntMapWithKeyWithAdjustRequesterTWith base patchNewElements mergePatchIn pack = Entry f' :: IntMap.Key -> (Int, v) -> m (Event t (IntMap (RequesterData request)), v') f' k (n, v) = do - (result, myRequests) <- runRequesterT (f k v) $ fmapMaybeCheap (IntMap.lookup n) $ selectInt responses k --TODO: Instead of doing fmapMaybeCheap, can we share a fanInt across all instances of a given key, or at least the ones that are adjacent in time? + (result, myRequests) <- runRequesterT (f k v) $ mapMaybeCheap (IntMap.lookup n) $ selectInt responses k --TODO: Instead of doing mapMaybeCheap, can we share a fanInt across all instances of a given key, or at least the ones that are adjacent in time? return (fmapCheap (IntMap.singleton n) myRequests, result) ndm' <- numberOccurrencesFrom 1 dm' (children0, children') <- base f' (fmap ((,) 0) dm0) $ fmap (\(n, dm) -> fmap ((,) n) dm) ndm' --TODO: Avoid this somehow, probably by adding some sort of per-cohort information passing to Adjustable @@ -426,7 +426,7 @@ traverseDMapWithKeyWithAdjustRequesterTWith base mapPatch weakenPatchWith patchN pack = Entry f' :: forall a. k a -> Compose ((,) Int) v a -> m (Compose ((,) (Event t (IntMap (RequesterData request)))) v' a) f' k (Compose (n, v)) = do - (result, myRequests) <- runRequesterT (f k v) $ fmapMaybeCheap (IntMap.lookup n) $ select responses (Const2 (Some.This k)) + (result, myRequests) <- runRequesterT (f k v) $ mapMaybeCheap (IntMap.lookup n) $ select responses (Const2 (Some.This k)) return $ Compose (fmapCheap (IntMap.singleton n) myRequests, result) ndm' <- numberOccurrencesFrom 1 dm' (children0, children') <- base f' (DMap.map (\v -> Compose (0, v)) dm0) $ fmap (\(n, dm) -> mapPatch (\v -> Compose (n, v)) dm) ndm' diff --git a/src/Reflex/Spider/Internal.hs b/src/Reflex/Spider/Internal.hs index 47f37c10..bfdce701 100644 --- a/src/Reflex/Spider/Internal.hs +++ b/src/Reflex/Spider/Internal.hs @@ -49,16 +49,16 @@ import Data.GADT.Compare import Data.IntMap.Strict (IntMap) import qualified Data.IntMap.Strict as IntMap import Data.IORef -import Data.Maybe +import Data.Maybe hiding (mapMaybe) import Data.Monoid ((<>)) import Data.Proxy import Data.These import Data.Traversable +import Data.Witherable (Filterable, mapMaybe) import GHC.Exts import GHC.IORef (IORef (..)) import GHC.Stack import Reflex.FastWeak -import Reflex.FunctorMaybe import System.IO.Unsafe import System.Mem.Weak import Unsafe.Coerce @@ -1128,12 +1128,12 @@ newInvalidatorSwitch subd = return $! InvalidatorSwitch subd newInvalidatorPull :: Pull x a -> IO (Invalidator x) newInvalidatorPull p = return $! InvalidatorPull p -instance HasSpiderTimeline x => FunctorMaybe (Event x) where - fmapMaybe f = push $ return . f +instance HasSpiderTimeline x => Filterable (Event x) where + mapMaybe f = push $ return . f instance HasSpiderTimeline x => Align (Event x) where nil = eventNever - align ea eb = fmapMaybe dmapToThese $ merge $ dynamicConst $ DMap.fromDistinctAscList [LeftTag :=> ea, RightTag :=> eb] + align ea eb = mapMaybe dmapToThese $ merge $ dynamicConst $ DMap.fromDistinctAscList [LeftTag :=> ea, RightTag :=> eb] data DynType x p = UnsafeDyn !(BehaviorM x (PatchTarget p), Event x p) | BuildDyn !(EventM x (PatchTarget p), Event x p) diff --git a/src/Reflex/Time.hs b/src/Reflex/Time.hs index 9193b42f..3de5c57b 100644 --- a/src/Reflex/Time.hs +++ b/src/Reflex/Time.hs @@ -28,7 +28,7 @@ import Control.Monad.IO.Class import Data.Align import Data.Data (Data) import Data.Fixed -import Data.Semigroup +import Data.Semigroup ((<>)) import Data.Sequence (Seq, (|>)) import qualified Data.Sequence as Seq import Data.These From 309e609143eb56da1ec1dffeadc46d91528ab0f1 Mon Sep 17 00:00:00 2001 From: Ali Abrar Date: Sun, 17 Mar 2019 01:17:22 -0400 Subject: [PATCH 112/241] Fix warnings --- src/Reflex/Dynamic.hs | 3 +-- src/Reflex/Dynamic/TH.hs | 2 +- src/Reflex/DynamicWriter/Base.hs | 2 +- src/Reflex/NotReady/Class.hs | 2 +- src/Reflex/Patch/Class.hs | 2 +- src/Reflex/Query/Class.hs | 2 +- src/Reflex/Time.hs | 2 +- 7 files changed, 7 insertions(+), 8 deletions(-) diff --git a/src/Reflex/Dynamic.hs b/src/Reflex/Dynamic.hs index 5e93ebb7..ebc83809 100644 --- a/src/Reflex/Dynamic.hs +++ b/src/Reflex/Dynamic.hs @@ -107,11 +107,10 @@ import Data.Align import Data.Dependent.Map (DMap) import qualified Data.Dependent.Map as DMap import Data.Dependent.Sum (DSum (..)) -import Data.Functor.Product import Data.GADT.Compare ((:~:) (..), GCompare (..), GEq (..), GOrdering (..)) import Data.Map (Map) import Data.Maybe -import Data.Monoid hiding (Product) +import Data.Monoid ((<>)) import Data.These import Debug.Trace diff --git a/src/Reflex/Dynamic/TH.hs b/src/Reflex/Dynamic/TH.hs index e71f4536..b2006b57 100644 --- a/src/Reflex/Dynamic/TH.hs +++ b/src/Reflex/Dynamic/TH.hs @@ -23,7 +23,7 @@ import Reflex.Dynamic import Control.Monad.State import Data.Data import Data.Generics -import Data.Monoid +import Data.Monoid ((<>)) import qualified Language.Haskell.Exts as Hs import qualified Language.Haskell.Meta.Syntax.Translate as Hs import Language.Haskell.TH diff --git a/src/Reflex/DynamicWriter/Base.hs b/src/Reflex/DynamicWriter/Base.hs index f5804c94..1703e14e 100644 --- a/src/Reflex/DynamicWriter/Base.hs +++ b/src/Reflex/DynamicWriter/Base.hs @@ -35,7 +35,7 @@ import Data.IntMap (IntMap) import qualified Data.IntMap as IntMap import Data.Map (Map) import qualified Data.Map as Map -import Data.Semigroup +import Data.Semigroup (Semigroup(..)) import Data.Some (Some) import Data.These diff --git a/src/Reflex/NotReady/Class.hs b/src/Reflex/NotReady/Class.hs index 60160d35..7dfabeef 100644 --- a/src/Reflex/NotReady/Class.hs +++ b/src/Reflex/NotReady/Class.hs @@ -57,7 +57,7 @@ instance NotReady t m => NotReady t (DynamicWriterT t w m) where notReadyUntil = lift . notReadyUntil notReady = lift notReady -instance (NotReady t m, Monoid w) => NotReady t (BehaviorWriterT t w m) where +instance NotReady t m => NotReady t (BehaviorWriterT t w m) where notReadyUntil = lift . notReadyUntil notReady = lift notReady diff --git a/src/Reflex/Patch/Class.hs b/src/Reflex/Patch/Class.hs index 233af16f..3ba6d7de 100644 --- a/src/Reflex/Patch/Class.hs +++ b/src/Reflex/Patch/Class.hs @@ -4,7 +4,7 @@ module Reflex.Patch.Class where import Control.Monad.Identity import Data.Maybe -import Data.Semigroup +import Data.Semigroup (Semigroup(..)) -- | A 'Patch' type represents a kind of change made to a datastructure. -- diff --git a/src/Reflex/Query/Class.hs b/src/Reflex/Query/Class.hs index 863513df..ff536b58 100644 --- a/src/Reflex/Query/Class.hs +++ b/src/Reflex/Query/Class.hs @@ -27,7 +27,7 @@ import Data.Data import Data.Ix import Data.Map.Monoidal (MonoidalMap) import qualified Data.Map.Monoidal as MonoidalMap -import Data.Semigroup +import Data.Semigroup (Semigroup(..)) import Foreign.Storable import Reflex.Class diff --git a/src/Reflex/Time.hs b/src/Reflex/Time.hs index 16bb3e97..4ae42f26 100644 --- a/src/Reflex/Time.hs +++ b/src/Reflex/Time.hs @@ -33,7 +33,7 @@ import Control.Monad.IO.Class import Data.Align import Data.Data (Data) import Data.Fixed -import Data.Semigroup +import Data.Semigroup (Semigroup(..)) import Data.Sequence (Seq, (|>)) import qualified Data.Sequence as Seq import Data.These From 742d740f7a26575d9562243298921a44b17c4f16 Mon Sep 17 00:00:00 2001 From: Ali Abrar Date: Sun, 17 Mar 2019 01:18:10 -0400 Subject: [PATCH 113/241] Organize exports under correct headings --- src/Reflex/Class.hs | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/src/Reflex/Class.hs b/src/Reflex/Class.hs index 67955013..4b4fe083 100644 --- a/src/Reflex/Class.hs +++ b/src/Reflex/Class.hs @@ -151,6 +151,9 @@ module Reflex.Class , appendEvents , onceE , sequenceThese + , switchPromptly + , switchPromptOnly + -- * "Cheap" functions , fmapMaybeCheap , fmapCheap , fforCheap @@ -159,8 +162,6 @@ module Reflex.Class , tagCheap , mergeWithCheap , mergeWithCheap' - , switchPromptly - , switchPromptOnly -- * Slow, but general, implementations , slowHeadE ) where From 6882aa812881a19920ba731b3e066301d94e44b0 Mon Sep 17 00:00:00 2001 From: Ali Abrar Date: Sun, 17 Mar 2019 01:19:09 -0400 Subject: [PATCH 114/241] Remove some more long-deprecated functions --- src/Reflex/Class.hs | 25 ------- src/Reflex/Collection.hs | 10 --- src/Reflex/Dynamic.hs | 153 +-------------------------------------- src/Reflex/Dynamic/TH.hs | 24 ------ 4 files changed, 1 insertion(+), 211 deletions(-) diff --git a/src/Reflex/Class.hs b/src/Reflex/Class.hs index 4b4fe083..11110916 100644 --- a/src/Reflex/Class.hs +++ b/src/Reflex/Class.hs @@ -148,9 +148,6 @@ module Reflex.Class , ffor2 , ffor3 -- * Deprecated functions - , appendEvents - , onceE - , sequenceThese , switchPromptly , switchPromptOnly -- * "Cheap" functions @@ -1464,28 +1461,6 @@ mergeWithFoldCheap' f es = -- Deprecated functions -------------------------------------------------------------------------------- --- | Create a new 'Event' that occurs if at least one of the supplied 'Event's --- occurs. If both occur at the same time they are combined using 'mappend'. -{-# DEPRECATED appendEvents "If a 'Semigroup a' instance is available, use 'mappend'; otherwise, use 'alignWith (mergeThese mappend)' instead" #-} -appendEvents :: (Reflex t, Monoid a) => Event t a -> Event t a -> Event t a -appendEvents = alignWith $ mergeThese mappend - --- | Alias for 'headE' -{-# DEPRECATED onceE "Use 'headE' instead" #-} -onceE :: MonadHold t m => Event t a -> m (Event t a) -onceE = headE - --- | Run both sides of a 'These' monadically, combining the results. -{-# DEPRECATED sequenceThese "Use bisequenceA or bisequence from the bifunctors package instead" #-} -#ifdef USE_TEMPLATE_HASKELL -{-# ANN sequenceThese "HLint: ignore Use fmap" #-} -#endif -sequenceThese :: Monad m => These (m a) (m b) -> m (These a b) -sequenceThese t = case t of - This ma -> fmap This ma - These ma mb -> liftM2 These ma mb - That mb -> fmap That mb - {-# DEPRECATED switchPromptly "Use 'switchHoldPromptly' instead. The 'switchHold*' naming convention was chosen because those functions are more closely related to each other than they are to 'switch'. " #-} switchPromptly :: (Reflex t, MonadHold t m) => Event t a -> Event t (Event t a) -> m (Event t a) switchPromptly = switchHoldPromptly diff --git a/src/Reflex/Collection.hs b/src/Reflex/Collection.hs index 5be7a00b..ae9c4825 100644 --- a/src/Reflex/Collection.hs +++ b/src/Reflex/Collection.hs @@ -20,7 +20,6 @@ module Reflex.Collection -- * Widgets on Collections listHoldWithKey , listWithKey - , listWithKey' , listWithKeyShallowDiff , listViewWithKey , selectViewListWithKey @@ -104,15 +103,6 @@ listWithKey vals mkChild = do listHoldWithKey Map.empty changeVals $ \k v -> mkChild k =<< holdDyn v (select childValChangedSelector $ Const2 k) -{-# DEPRECATED listWithKey' "listWithKey' has been renamed to listWithKeyShallowDiff; also, its behavior has changed to fix a bug where children were always rebuilt (never updated)" #-} -listWithKey' - :: (Ord k, Adjustable t m, MonadFix m, MonadHold t m) - => Map k v - -> Event t (Map k (Maybe v)) - -> (k -> v -> Event t v -> m a) - -> m (Dynamic t (Map k a)) -listWithKey' = listWithKeyShallowDiff - -- | Display the given map of items (in key order) using the builder -- function provided, and update it with the given event. 'Nothing' -- update entries will delete the corresponding children, and 'Just' diff --git a/src/Reflex/Dynamic.hs b/src/Reflex/Dynamic.hs index ebc83809..36a65d06 100644 --- a/src/Reflex/Dynamic.hs +++ b/src/Reflex/Dynamic.hs @@ -74,32 +74,12 @@ module Reflex.Dynamic , distributeFHListOverDynPure -- * Unsafe , unsafeDynamic - -- * Deprecated functions - , apDyn - , attachDyn - , attachDynWith - , attachDynWithMaybe - , collectDyn - , combineDyn - , distributeDMapOverDyn - , distributeFHListOverDyn - , forDyn - , getDemuxed - , joinDyn - , mapDyn - , mconcatDyn - , nubDyn - , splitDyn - , tagDyn - , uniqDyn - , uniqDynBy ) where import Data.Functor.Compose import Data.Functor.Misc import Reflex.Class -import Control.Applicative ((<*>)) import Control.Monad import Control.Monad.Fix import Control.Monad.Identity @@ -239,7 +219,7 @@ distributeListOverDynPure = -- | Combine a 'Dynamic' of a 'Map' of 'Dynamic's into a 'Dynamic' -- with the current values of the 'Dynamic's in a map. joinDynThroughMap :: forall t k a. (Reflex t, Ord k) => Dynamic t (Map k (Dynamic t a)) -> Dynamic t (Map k a) -joinDynThroughMap = joinDyn . fmap distributeMapOverDynPure +joinDynThroughMap = join . fmap distributeMapOverDynPure -- | Print the value of the 'Dynamic' when it is first read and on each -- subsequent change that is observed (as 'traceEvent'), prefixed with the @@ -550,134 +530,3 @@ instance IsHList (a, b, c, d, e, f) where #if !defined(__GLASGOW_HASKELL__) || __GLASGOW_HASKELL__ < 800 _ -> error "fromHList: impossible" -- Otherwise, GHC complains of a non-exhaustive pattern match; see https://ghc.haskell.org/trac/ghc/ticket/4139 #endif - --------------------------------------------------------------------------------- --- Deprecated functions --------------------------------------------------------------------------------- - --- | Map a function over a 'Dynamic'. -{-# DEPRECATED mapDyn "Use 'return . fmap f' instead of 'mapDyn f'; consider eliminating monadic style" #-} -mapDyn :: (Reflex t, Monad m) => (a -> b) -> Dynamic t a -> m (Dynamic t b) -mapDyn f = return . fmap f - --- | Flipped version of 'mapDyn'. -{-# DEPRECATED forDyn "Use 'return . ffor a' instead of 'forDyn a'; consider eliminating monadic style" #-} -forDyn :: (Reflex t, Monad m) => Dynamic t a -> (a -> b) -> m (Dynamic t b) -forDyn a = return . ffor a - --- | Split the 'Dynamic' into two 'Dynamic's, each taking the respective value --- of the tuple. -{-# DEPRECATED splitDyn "Use 'return . splitDynPure' instead; consider eliminating monadic style" #-} -splitDyn :: (Reflex t, Monad m) => Dynamic t (a, b) -> m (Dynamic t a, Dynamic t b) -splitDyn = return . splitDynPure - --- | Merge the 'Dynamic' values using their 'Monoid' instance. -{-# DEPRECATED mconcatDyn "Use 'return . mconcat' instead; consider eliminating monadic style" #-} -mconcatDyn :: forall t m a. (Reflex t, Monad m, Monoid a) => [Dynamic t a] -> m (Dynamic t a) -mconcatDyn = return . mconcat - --- | This function no longer needs to be monadic; see 'distributeMapOverDynPure'. -{-# DEPRECATED distributeDMapOverDyn "Use 'return . distributeDMapOverDynPure' instead; consider eliminating monadic style" #-} -distributeDMapOverDyn :: (Reflex t, Monad m, GCompare k) => DMap k (Dynamic t) -> m (Dynamic t (DMap k Identity)) -distributeDMapOverDyn = return . distributeDMapOverDynPure - --- | Merge two 'Dynamic's into a new one using the provided function. The new --- 'Dynamic' changes its value each time one of the original 'Dynamic's changes --- its value. -{-# DEPRECATED combineDyn "Use 'return (zipDynWith f a b)' instead of 'combineDyn f a b'; consider eliminating monadic style" #-} -combineDyn :: forall t m a b c. (Reflex t, Monad m) => (a -> b -> c) -> Dynamic t a -> Dynamic t b -> m (Dynamic t c) -combineDyn f a b = return $ zipDynWith f a b - --- | A pseudo applicative version of ap for 'Dynamic'. Example useage: --- --- > do --- > person <- Person `mapDyn` dynFirstName --- > `apDyn` dynListName --- > `apDyn` dynAge --- > `apDyn` dynAddress -{-# DEPRECATED apDyn "Use 'ffor m (<*> a)' instead of 'apDyn m a'; consider eliminating monadic style, since Dynamics are now Applicative and can be used with applicative style directly" #-} -#ifdef USE_TEMPLATE_HASKELL -{-# ANN apDyn "HLint: ignore Use fmap" #-} -#endif -apDyn :: forall t m a b. (Reflex t, Monad m) - => m (Dynamic t (a -> b)) - -> Dynamic t a - -> m (Dynamic t b) -apDyn m a = fmap (<*> a) m - ---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 --- | This function no longer needs to be monadic, so it has been replaced by --- 'demuxed', which is pure. -{-# DEPRECATED getDemuxed "Use 'return . demuxed d' instead of 'getDemuxed d'; consider eliminating monadic style" #-} -getDemuxed :: (Reflex t, Monad m, Eq k) => Demux t k -> k -> m (Dynamic t Bool) -getDemuxed d = return . demuxed d - --- | This function no longer needs to be monadic, so it has been replaced by --- 'distributeFHListOverDynPure', which is pure. -{-# DEPRECATED distributeFHListOverDyn "Use 'return . distributeFHListOverDynPure' instead; consider eliminating monadic style" #-} -distributeFHListOverDyn :: forall t m l. (Reflex t, Monad m, RebuildSortedHList l) => FHList (Dynamic t) l -> m (Dynamic t (HList l)) -distributeFHListOverDyn = return . distributeFHListOverDynPure - --- | This function no longer needs to be monadic, so it has been replaced by --- 'collectDynPure', which is pure. -{-# DEPRECATED collectDyn "Use 'return . collectDynPure' instead; consider eliminating monadic style" #-} -collectDyn :: ( RebuildSortedHList (HListElems b) - , IsHList a, IsHList b - , AllAreFunctors (Dynamic t) (HListElems b) - , Reflex t, Monad m - , HListElems a ~ FunctorList (Dynamic t) (HListElems b) - ) => a -> m (Dynamic t b) -collectDyn = return . collectDynPure - --- | This function has been renamed to 'tagPromptlyDyn' to clarify its --- semantics. -{-# DEPRECATED tagDyn "Use 'tagPromptlyDyn' instead" #-} -tagDyn :: Reflex t => Dynamic t a -> Event t b -> Event t a -tagDyn = tagPromptlyDyn - --- | This function has been renamed to 'attachPromptlyDyn' to clarify its --- semantics. -{-# DEPRECATED attachDyn "Use 'attachPromptlyDyn' instead" #-} -attachDyn :: Reflex t => Dynamic t a -> Event t b -> Event t (a, b) -attachDyn = attachPromptlyDyn - --- | This function has been renamed to 'attachPromptlyDynWith' to clarify its --- semantics. -{-# DEPRECATED attachDynWith "Use 'attachPromptlyDynWith' instead" #-} -attachDynWith :: Reflex t => (a -> b -> c) -> Dynamic t a -> Event t b -> Event t c -attachDynWith = attachPromptlyDynWith - --- | This function has been renamed to 'attachPromptlyDynWithMaybe' to clarify --- its semantics. -{-# DEPRECATED attachDynWithMaybe "Use 'attachPromptlyDynWithMaybe' instead" #-} -attachDynWithMaybe :: Reflex t => (a -> b -> Maybe c) -> Dynamic t a -> Event t b -> Event t c -attachDynWithMaybe = attachPromptlyDynWithMaybe - --- | Combine an inner and outer 'Dynamic' such that the resulting 'Dynamic''s --- current value will always be equal to the current value's current value, and --- will change whenever either the inner or the outer (or both) values change. -{-# DEPRECATED joinDyn "Use 'join' instead" #-} -joinDyn :: Reflex t => Dynamic t (Dynamic t a) -> Dynamic t a -joinDyn = join - --- | WARNING: This function is only pure if @a@'s 'Eq' instance tests --- representational equality. Use 'holdUniqDyn' instead, which is pure in all --- circumstances. Also, note that, unlike 'nub', this function does not prevent --- all recurrences of a value, only consecutive recurrences. -{-# DEPRECATED nubDyn "Use 'holdUniqDyn' instead; note that it returns a MonadHold action rather than a pure Dynamic" #-} -nubDyn :: (Reflex t, Eq a) => Dynamic t a -> Dynamic t a -nubDyn = uniqDyn - --- | WARNING: This function is only pure if @a@'s 'Eq' instance tests --- representational equality. Use 'holdUniqDyn' instead, which is pure in all --- circumstances. -{-# DEPRECATED uniqDyn "Use 'holdUniqDyn' instead; note that it returns a MonadHold action rather than a pure Dynamic" #-} -uniqDyn :: (Reflex t, Eq a) => Dynamic t a -> Dynamic t a -uniqDyn = uniqDynBy (==) - --- | WARNING: This function is impure. Use 'holdUniqDynBy' instead. -{-# DEPRECATED uniqDynBy "Use 'holdUniqDynBy' instead; note that it returns a MonadHold action rather than a pure Dynamic" #-} -uniqDynBy :: Reflex t => (a -> a -> Bool) -> Dynamic t a -> Dynamic t a -uniqDynBy eq d = - let e' = attachWithMaybe (\x x' -> if x' `eq` x then Nothing else Just x') (current d) (updated d) - in unsafeDynamic (current d) e' diff --git a/src/Reflex/Dynamic/TH.hs b/src/Reflex/Dynamic/TH.hs index b2006b57..0d2f1d7e 100644 --- a/src/Reflex/Dynamic/TH.hs +++ b/src/Reflex/Dynamic/TH.hs @@ -13,9 +13,6 @@ module Reflex.Dynamic.TH ( qDynPure , unqDyn , mkDynPure - -- * Deprecated functions - , qDyn - , mkDyn ) where import Reflex.Dynamic @@ -107,24 +104,3 @@ mkDynExp s = case Hs.parseExpWithMode (Hs.defaultParseMode { Hs.extensions = [ H reinstateUnqDyn (TH.Name (TH.OccName occName') (TH.NameQ (TH.ModName modName'))) | modName == modName' && occName == occName' = 'unqMarker reinstateUnqDyn x = x - --------------------------------------------------------------------------------- --- Deprecated --------------------------------------------------------------------------------- - -{-# DEPRECATED qDyn "Instead of $(qDyn x), use return $(qDynPure x)" #-} --- | Like 'qDynPure', but wraps its result monadically using 'return'. This is --- no longer necessary, due to 'Dynamic' being an instance of 'Functor'. -qDyn :: Q Exp -> Q Exp -qDyn qe = [| return $(qDynPure qe) |] - -{-# DEPRECATED mkDyn "Instead of [mkDyn| x |], use return [mkDynPure| x |]" #-} --- | Like 'mkDynPure', but wraps its result monadically using 'return'. This is --- no longer necessary, due to 'Dynamic' being an instance of 'Functor'. -mkDyn :: QuasiQuoter -mkDyn = QuasiQuoter - { quoteExp = \s -> [| return $(mkDynExp s) |] - , quotePat = error "mkDyn: pattern splices are not supported" - , quoteType = error "mkDyn: type splices are not supported" - , quoteDec = error "mkDyn: declaration splices are not supported" - } From 4b98630dd65943a5eed231ea325e3430cbdaa5d1 Mon Sep 17 00:00:00 2001 From: Ali Abrar Date: Sun, 17 Mar 2019 15:04:37 -0400 Subject: [PATCH 115/241] Update Collection.hs --- src/Reflex/Collection.hs | 2 -- 1 file changed, 2 deletions(-) diff --git a/src/Reflex/Collection.hs b/src/Reflex/Collection.hs index 5be7a00b..d90b2193 100644 --- a/src/Reflex/Collection.hs +++ b/src/Reflex/Collection.hs @@ -13,8 +13,6 @@ -- | -- Module: -- Reflex.Collection --- Description: --- module Reflex.Collection ( -- * Widgets on Collections From d0adfca375192da93b1d855a4bc1fbc11ecdd8db Mon Sep 17 00:00:00 2001 From: Ali Abrar Date: Sun, 17 Mar 2019 17:37:47 -0400 Subject: [PATCH 116/241] Re-export mapMaybe from Filterable --- src/Reflex/Class.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/src/Reflex/Class.hs b/src/Reflex/Class.hs index 25eebd17..be468a92 100644 --- a/src/Reflex/Class.hs +++ b/src/Reflex/Class.hs @@ -139,6 +139,7 @@ module Reflex.Class , unsafeMapIncremental -- * 'Filterable' convenience functions , FunctorMaybe -- fmapMaybe is purposely not exported from deprecated 'FunctorMaybe' and the new alias is exported instead + , mapMaybe -- Re-exported for convenience , fmapMaybe , fforMaybe , ffilter From 7ccb414d795af1c9a608a0ac92dfac7d5af9fdee Mon Sep 17 00:00:00 2001 From: Ali Abrar Date: Sun, 17 Mar 2019 17:38:04 -0400 Subject: [PATCH 117/241] Bump to version 0.6 --- reflex.cabal | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/reflex.cabal b/reflex.cabal index c136c1ae..b74deffd 100644 --- a/reflex.cabal +++ b/reflex.cabal @@ -1,5 +1,5 @@ Name: reflex -Version: 0.5.0.1 +Version: 0.6 Synopsis: Higher-order Functional Reactive Programming Description: Reflex is a high-performance, deterministic, higher-order Functional Reactive Programming system License: BSD3 From 6a450ddba31d831553d39bfb5ecd14db1987e010 Mon Sep 17 00:00:00 2001 From: Ali Abrar Date: Sun, 17 Mar 2019 22:53:00 -0400 Subject: [PATCH 118/241] Add Num instance for Dynamic --- src/Reflex/Class.hs | 9 +++++++++ 1 file changed, 9 insertions(+) diff --git a/src/Reflex/Class.hs b/src/Reflex/Class.hs index be468a92..1a20dafb 100644 --- a/src/Reflex/Class.hs +++ b/src/Reflex/Class.hs @@ -548,6 +548,15 @@ instance (Reflex t, Num a) => Num (Behavior t a) where negate = fmap negate signum = fmap signum +instance (Num a, Reflex t) => Num (Dynamic t a) where + (+) = liftA2 (+) + (*) = liftA2 (*) + abs = fmap abs + signum = fmap signum + fromInteger = pure . fromInteger + negate = fmap negate + (-) = liftA2 (-) + instance (Reflex t, Semigroup a) => Semigroup (Behavior t a) where a <> b = pull $ liftM2 (<>) (sample a) (sample b) sconcat = pull . fmap sconcat . mapM sample From 45b45dd1063bca60da9d61e229f2903e699b9f2b Mon Sep 17 00:00:00 2001 From: Ali Abrar Date: Wed, 20 Mar 2019 17:41:02 -0400 Subject: [PATCH 119/241] Add changelog --- ChangeLog.md | 9 +++++++++ reflex.cabal | 1 + 2 files changed, 10 insertions(+) create mode 100644 ChangeLog.md diff --git a/ChangeLog.md b/ChangeLog.md new file mode 100644 index 00000000..cb905ab8 --- /dev/null +++ b/ChangeLog.md @@ -0,0 +1,9 @@ +# Revision history for reflex + +## 0.6.0.0 -- 2019-03-20 + +* Deprecate FunctorMaybe in favor of Data.Witherable.Filterable. We still export fmapMaybe, ffilter, etc., but they all rely on Filterable now. +* Remove many deprecated functions +* Add a Num instance for Dynamic +* Add matchRequestsWithResponses to make it easier to use Requester with protocols that don't do this matching for you +* Add withRequesterT to map functions over the request and response of a RequesterT diff --git a/reflex.cabal b/reflex.cabal index b74deffd..bef46927 100644 --- a/reflex.cabal +++ b/reflex.cabal @@ -15,6 +15,7 @@ bug-reports: https://github.com/reflex-frp/reflex/issues extra-source-files: README.md Quickref.md + ChangeLog.md flag use-reflex-optimizer description: Use the GHC plugin Reflex.Optimizer on some of the modules in the package. This is still experimental. From 767faa134dc57ac83445e89fc03f4a42d699cd53 Mon Sep 17 00:00:00 2001 From: Ali Abrar Date: Thu, 21 Mar 2019 13:53:38 -0400 Subject: [PATCH 120/241] Rename MonadDynamicWriter --- ChangeLog.md | 1 + src/Reflex/DynamicWriter/Base.hs | 4 ++-- src/Reflex/DynamicWriter/Class.hs | 13 +++++++++---- src/Reflex/EventWriter/Base.hs | 4 ++-- src/Reflex/Query/Base.hs | 2 +- 5 files changed, 15 insertions(+), 9 deletions(-) diff --git a/ChangeLog.md b/ChangeLog.md index cb905ab8..fe8ae71a 100644 --- a/ChangeLog.md +++ b/ChangeLog.md @@ -3,6 +3,7 @@ ## 0.6.0.0 -- 2019-03-20 * Deprecate FunctorMaybe in favor of Data.Witherable.Filterable. We still export fmapMaybe, ffilter, etc., but they all rely on Filterable now. +* Rename MonadDynamicWriter to DynamicWriter and add a deprecation for the old name. * Remove many deprecated functions * Add a Num instance for Dynamic * Add matchRequestsWithResponses to make it easier to use Requester with protocols that don't do this matching for you diff --git a/src/Reflex/DynamicWriter/Base.hs b/src/Reflex/DynamicWriter/Base.hs index 1703e14e..643b9ccc 100644 --- a/src/Reflex/DynamicWriter/Base.hs +++ b/src/Reflex/DynamicWriter/Base.hs @@ -88,7 +88,7 @@ mergeDynIncrementalWithMove a = unsafeBuildIncremental (mapM (sample . current) noLongerMovedMap = Map.fromList $ fmap (, ()) noLongerMoved in Map.differenceWith (\e _ -> Just $ MapWithMove.nodeInfoSetTo Nothing e) pWithNewVals noLongerMovedMap --TODO: Check if any in the second map are not covered? --- | A basic implementation of 'MonadDynamicWriter'. +-- | A basic implementation of 'DynamicWriter'. newtype DynamicWriterT t w m a = DynamicWriterT { unDynamicWriterT :: StateT [Dynamic t w] m a } deriving (Functor, Applicative, Monad, MonadIO, MonadFix, MonadAsyncException, MonadException) -- The list is kept in reverse order @@ -116,7 +116,7 @@ runDynamicWriterT (DynamicWriterT a) = do (result, ws) <- runStateT a [] return (result, mconcat $ reverse ws) -instance (Monad m, Monoid w, Reflex t) => MonadDynamicWriter t w (DynamicWriterT t w m) where +instance (Monad m, Monoid w, Reflex t) => DynamicWriter t w (DynamicWriterT t w m) where tellDyn w = DynamicWriterT $ modify (w :) instance MonadReader r m => MonadReader r (DynamicWriterT t w m) where diff --git a/src/Reflex/DynamicWriter/Class.hs b/src/Reflex/DynamicWriter/Class.hs index f06018b5..675f0a15 100644 --- a/src/Reflex/DynamicWriter/Class.hs +++ b/src/Reflex/DynamicWriter/Class.hs @@ -1,4 +1,5 @@ --- | This module defines the 'MonadDynamicWriter' class. +-- | This module defines the 'DynamicWriter' class. +{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FunctionalDependencies #-} @@ -8,17 +9,21 @@ {-# OPTIONS_GHC -fplugin=Reflex.Optimizer #-} #endif module Reflex.DynamicWriter.Class - ( MonadDynamicWriter (..) + ( MonadDynamicWriter + , DynamicWriter(..) ) where import Control.Monad.Reader (ReaderT, lift) import Reflex.Class (Dynamic) +{-# DEPRECATED MonadDynamicWriter "Use 'DynamicWriter' instead" #-} +type MonadDynamicWriter = DynamicWriter + -- | 'MonadDynamicWriter' efficiently collects 'Dynamic' values using 'tellDyn' -- and combines them monoidally to provide a 'Dynamic' result. -class (Monad m, Monoid w) => MonadDynamicWriter t w m | m -> t w where +class (Monad m, Monoid w) => DynamicWriter t w m | m -> t w where tellDyn :: Dynamic t w -> m () -instance MonadDynamicWriter t w m => MonadDynamicWriter t w (ReaderT r m) where +instance DynamicWriter t w m => DynamicWriter t w (ReaderT r m) where tellDyn = lift . tellDyn diff --git a/src/Reflex/EventWriter/Base.hs b/src/Reflex/EventWriter/Base.hs index d1efa632..65b046f7 100644 --- a/src/Reflex/EventWriter/Base.hs +++ b/src/Reflex/EventWriter/Base.hs @@ -25,7 +25,7 @@ module Reflex.EventWriter.Base import Reflex.Adjustable.Class import Reflex.Class import Reflex.EventWriter.Class (EventWriter, tellEvent) -import Reflex.DynamicWriter.Class (MonadDynamicWriter, tellDyn) +import Reflex.DynamicWriter.Class (DynamicWriter, tellDyn) import Reflex.Host.Class import Reflex.PerformEvent.Class import Reflex.PostBuild.Class @@ -278,7 +278,7 @@ instance (MonadQuery t q m, Monad m) => MonadQuery t q (EventWriterT t w m) wher askQueryResult = lift askQueryResult queryIncremental = lift . queryIncremental -instance MonadDynamicWriter t w m => MonadDynamicWriter t w (EventWriterT t v m) where +instance DynamicWriter t w m => DynamicWriter t w (EventWriterT t v m) where tellDyn = lift . tellDyn instance PrimMonad m => PrimMonad (EventWriterT t w m) where diff --git a/src/Reflex/Query/Base.hs b/src/Reflex/Query/Base.hs index 5ef4e07f..bc924477 100644 --- a/src/Reflex/Query/Base.hs +++ b/src/Reflex/Query/Base.hs @@ -340,5 +340,5 @@ instance Requester t m => Requester t (QueryT t q m) where instance EventWriter t w m => EventWriter t w (QueryT t q m) where tellEvent = lift . tellEvent -instance MonadDynamicWriter t w m => MonadDynamicWriter t w (QueryT t q m) where +instance DynamicWriter t w m => DynamicWriter t w (QueryT t q m) where tellDyn = lift . tellDyn From 60567cb24b14fdad06abe0de845e37b51c6ae623 Mon Sep 17 00:00:00 2001 From: Alexandre Esteves <2335822+alexfmpe@users.noreply.github.com> Date: Fri, 22 Mar 2019 02:18:50 +0000 Subject: [PATCH 121/241] Fix typos --- README.md | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/README.md b/README.md index 81c836fb..8bc1c098 100644 --- a/README.md +++ b/README.md @@ -1,7 +1,7 @@ ## [Reflex](https://reflex-frp.org/) ### Practical Functional Reactive Programming -Reflex is an fully-deterministic, higher-order Functional Reactive Programming (FRP) interface and an engine that efficiently implements that interface. +Reflex is a fully-deterministic, higher-order Functional Reactive Programming (FRP) interface and an engine that efficiently implements that interface. [Reflex-DOM](https://github.com/reflex-frp/reflex-dom) is a framework built on Reflex that facilitates the development of web pages, including highly-interactive single-page apps. @@ -20,5 +20,5 @@ A summary of Reflex functions is available in the [quick reference](Quickref.md) ### Hacking -Use the `./scripts/hackon reflex` script in [Reflex Platform](https://github.com/reflex-frp/reflex-platform) to checkout the source code of `reflex` locally in `reflex-platform/reflex` directory. -Then do modifications to the source in place, and use the `./tryreflex` or `./scripts/workon` scripts to create the shell to test your changes. +Use the `./scripts/hack-on reflex` script in [Reflex Platform](https://github.com/reflex-frp/reflex-platform) to checkout the source code of `reflex` locally in `reflex-platform/reflex` directory. +Then do modifications to the source in place, and use the `./try-reflex` or `./scripts/work-on` scripts to create the shell to test your changes. From 1fdcae5c11946bfc3a4c8634f09bf00c2de85370 Mon Sep 17 00:00:00 2001 From: Alexandre Esteves <2335822+alexfmpe@users.noreply.github.com> Date: Fri, 22 Mar 2019 02:31:07 +0000 Subject: [PATCH 122/241] Typo --- Quickref.md | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/Quickref.md b/Quickref.md index c13cf8cb..62b0bcae 100644 --- a/Quickref.md +++ b/Quickref.md @@ -166,7 +166,7 @@ For Events, the returned Event fires whenever the latest Event supplied by the w -- Flatten Behavior-of-Event to Event. Old Event is used during switchover. [ ] switch :: Behavior (Event a) -> Event a --- Flatten Dyanmic-of-Event to Event. New Event is used immediately. +-- Flatten Dynamic-of-Event to Event. New Event is used immediately. [ ] switchDyn :: Dynamic (Event a) -> Event a -- Flatten Event-of-Event to Event that fires when both wrapper AND new Event fire. From f40a0f4ccd3cbedcea7d2d6defedfed96f2e1b13 Mon Sep 17 00:00:00 2001 From: Ali Abrar Date: Fri, 22 Mar 2019 11:13:13 -0400 Subject: [PATCH 123/241] Update changelog for #203 --- ChangeLog.md | 9 +++++---- 1 file changed, 5 insertions(+), 4 deletions(-) diff --git a/ChangeLog.md b/ChangeLog.md index fe8ae71a..9d8d859e 100644 --- a/ChangeLog.md +++ b/ChangeLog.md @@ -4,7 +4,8 @@ * Deprecate FunctorMaybe in favor of Data.Witherable.Filterable. We still export fmapMaybe, ffilter, etc., but they all rely on Filterable now. * Rename MonadDynamicWriter to DynamicWriter and add a deprecation for the old name. -* Remove many deprecated functions -* Add a Num instance for Dynamic -* Add matchRequestsWithResponses to make it easier to use Requester with protocols that don't do this matching for you -* Add withRequesterT to map functions over the request and response of a RequesterT +* Remove many deprecated functions. +* Add a Num instance for Dynamic. +* Add matchRequestsWithResponses to make it easier to use Requester with protocols that don't do this matching for you. +* Add withRequesterT to map functions over the request and response of a RequesterT. +* Suppress nil patches in QueryT as an optimization. The Query type must now have an Eq instance. From b1c950623c1356ef631cceaab73c21cf7b14b3de Mon Sep 17 00:00:00 2001 From: Ali Abrar Date: Fri, 22 Mar 2019 12:13:13 -0400 Subject: [PATCH 124/241] Add Reflex.Time changes to changelog --- ChangeLog.md | 1 + 1 file changed, 1 insertion(+) diff --git a/ChangeLog.md b/ChangeLog.md index 9d8d859e..9d3f83e2 100644 --- a/ChangeLog.md +++ b/ChangeLog.md @@ -9,3 +9,4 @@ * Add matchRequestsWithResponses to make it easier to use Requester with protocols that don't do this matching for you. * Add withRequesterT to map functions over the request and response of a RequesterT. * Suppress nil patches in QueryT as an optimization. The Query type must now have an Eq instance. +* Add throttleBatchWithLag to Reflex.Time. See that module for details. From 66004a0afe92bb3b603603c7fcc6be4c495fc0aa Mon Sep 17 00:00:00 2001 From: Ali Abrar Date: Thu, 28 Mar 2019 14:52:47 -0400 Subject: [PATCH 125/241] Re-export Data.Map.Monoidal; Fix tests --- ChangeLog.md | 5 +++++ default.nix | 2 +- reflex.cabal | 2 +- src/Data/AppendMap.hs | 9 ++++----- src/Reflex/Dynamic.hs | 2 +- src/Reflex/FunctorMaybe.hs | 2 ++ test/RequesterT.hs | 6 +++--- 7 files changed, 17 insertions(+), 11 deletions(-) diff --git a/ChangeLog.md b/ChangeLog.md index 9d3f83e2..f67e82ee 100644 --- a/ChangeLog.md +++ b/ChangeLog.md @@ -10,3 +10,8 @@ * Add withRequesterT to map functions over the request and response of a RequesterT. * Suppress nil patches in QueryT as an optimization. The Query type must now have an Eq instance. * Add throttleBatchWithLag to Reflex.Time. See that module for details. + +## 0.6.1.0 + +* Re-export all of Data.Map.Monoidal +* Fix QueryT and RequesterT tests diff --git a/default.nix b/default.nix index d72ee650..8d9feef4 100644 --- a/default.nix +++ b/default.nix @@ -11,7 +11,7 @@ }: mkDerivation { pname = "reflex"; - version = "0.5.0.1"; + version = "0.6.1"; src = builtins.filterSource (path: type: !(builtins.elem (baseNameOf path) [ ".git" "dist" ])) ./.; libraryHaskellDepends = [ base bifunctors containers dependent-map dependent-sum diff --git a/reflex.cabal b/reflex.cabal index 1ce86123..2f3ab76f 100644 --- a/reflex.cabal +++ b/reflex.cabal @@ -1,5 +1,5 @@ Name: reflex -Version: 0.6 +Version: 0.6.1 Synopsis: Higher-order Functional Reactive Programming Description: Reflex is a high-performance, deterministic, higher-order Functional Reactive Programming system License: BSD3 diff --git a/src/Data/AppendMap.hs b/src/Data/AppendMap.hs index f97a6e6e..1cccb26f 100644 --- a/src/Data/AppendMap.hs +++ b/src/Data/AppendMap.hs @@ -26,9 +26,8 @@ import qualified Data.Map.Internal.Debug as Map (showTree, showTreeWith) #else import qualified Data.Map as Map (showTree, showTreeWith) #endif -import Data.Witherable (Filterable(..)) -import Data.Map.Monoidal (MonoidalMap(..), delete, null, empty) -import qualified Data.Map.Monoidal as M +import qualified Data.Witherable as W +import Data.Map.Monoidal {-# DEPRECATED AppendMap "Use 'MonoidalMap' instead" #-} type AppendMap = MonoidalMap @@ -40,8 +39,8 @@ _unAppendMap = getMonoidalMap pattern AppendMap :: Map k v -> MonoidalMap k v pattern AppendMap m = MonoidalMap m -instance Filterable (MonoidalMap k) where - mapMaybe = M.mapMaybe +instance W.Filterable (MonoidalMap k) where + mapMaybe = mapMaybe -- | Deletes a key, returning 'Nothing' if the result is empty. nonEmptyDelete :: Ord k => k -> MonoidalMap k a -> Maybe (MonoidalMap k a) diff --git a/src/Reflex/Dynamic.hs b/src/Reflex/Dynamic.hs index 36a65d06..d4fef93e 100644 --- a/src/Reflex/Dynamic.hs +++ b/src/Reflex/Dynamic.hs @@ -219,7 +219,7 @@ distributeListOverDynPure = -- | Combine a 'Dynamic' of a 'Map' of 'Dynamic's into a 'Dynamic' -- with the current values of the 'Dynamic's in a map. joinDynThroughMap :: forall t k a. (Reflex t, Ord k) => Dynamic t (Map k (Dynamic t a)) -> Dynamic t (Map k a) -joinDynThroughMap = join . fmap distributeMapOverDynPure +joinDynThroughMap = (distributeMapOverDynPure =<<) -- | Print the value of the 'Dynamic' when it is first read and on each -- subsequent change that is observed (as 'traceEvent'), prefixed with the diff --git a/src/Reflex/FunctorMaybe.hs b/src/Reflex/FunctorMaybe.hs index afa4baa3..223d5e07 100644 --- a/src/Reflex/FunctorMaybe.hs +++ b/src/Reflex/FunctorMaybe.hs @@ -1,6 +1,8 @@ {-# LANGUAGE CPP #-} +#if MIN_VERSION_base(4,9,0) {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE StandaloneDeriving #-} +#endif -- | -- Module: diff --git a/test/RequesterT.hs b/test/RequesterT.hs index 351c32e8..6ebed9de 100644 --- a/test/RequesterT.hs +++ b/test/RequesterT.hs @@ -44,12 +44,12 @@ main = do print os5 os6 <- runApp' (unwrapApp delayedPulse) [Just ()] print os6 - let ![[Just [10,9,8,7,6,5,4,3,2,1]]] = os1 - let ![[Just [1,3,5,7,9]],[Nothing,Nothing],[Just [2,4,6,8,10]],[Just [2,4,6,8,10],Nothing]] = os2 + let ![[Just [1,2,3,4,5,6,7,8,9,10]]] = os1 -- The order is reversed here: see the documentation for 'runRequesterT' + let ![[Just [9,7,5,3,1]],[Nothing,Nothing],[Just [10,8,6,4,2]],[Just [10,8,6,4,2],Nothing]] = os2 let ![[Nothing, Just [2]]] = os3 let ![[Nothing, Just [2]]] = os4 let ![[Nothing, Just [1, 2]]] = os5 - let ![[Nothing, Nothing]] = os6 + -- let ![[Nothing, Nothing]] = os6 -- TODO re-enable this test after issue #233 has been resolved return () unwrapRequest :: DSum tag RequestInt -> Int From ff0ffdde57e161e15fea86b97a574934a91b6682 Mon Sep 17 00:00:00 2001 From: Ali Abrar Date: Thu, 28 Mar 2019 15:18:03 -0400 Subject: [PATCH 126/241] Haddocks for Data.AppendMap --- src/Data/AppendMap.hs | 18 ++++++++++++++---- 1 file changed, 14 insertions(+), 4 deletions(-) diff --git a/src/Data/AppendMap.hs b/src/Data/AppendMap.hs index 1cccb26f..66a085e4 100644 --- a/src/Data/AppendMap.hs +++ b/src/Data/AppendMap.hs @@ -7,10 +7,14 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} {-# OPTIONS_GHC -fno-warn-orphans #-} --- | 'Data.Map' with a better 'Monoid' instance --- --- 'Data.Map' has @mappend = union@, which is left-biased. AppendMap has --- @mappend = unionWith mappend@ instead. +-- | +-- Module: +-- Data.AppendMap +-- Description: +-- Instances and convenience functions for 'Data.Map.Monoidal'. We use +-- monoidal-containers to take advantage of its better monoid instance. +-- 'Data.Map' has @mappend = union@, which is left-biased. 'MonoidalMap' +-- has @mappend = unionWith mappend@ instead. module Data.AppendMap ( module Data.AppendMap , module Data.Map.Monoidal @@ -30,12 +34,15 @@ import qualified Data.Witherable as W import Data.Map.Monoidal {-# DEPRECATED AppendMap "Use 'MonoidalMap' instead" #-} +-- | AppendMap is a synonym for 'Data.Map.Monoidal.MonoidalMap' type AppendMap = MonoidalMap {-# DEPRECATED _unAppendMap "Use 'getMonoidalMap' instead" #-} +-- | A synonym for 'getMonoidalMap' _unAppendMap :: MonoidalMap k v -> Map k v _unAppendMap = getMonoidalMap +-- | Pattern synonym for 'MonoidalMap' pattern AppendMap :: Map k v -> MonoidalMap k v pattern AppendMap m = MonoidalMap m @@ -50,6 +57,7 @@ nonEmptyDelete k vs = then Nothing else Just deleted +-- | Like 'mapMaybe' but indicates whether the resulting container is empty mapMaybeNoNull :: (a -> Maybe b) -> MonoidalMap token a -> Maybe (MonoidalMap token b) @@ -60,9 +68,11 @@ mapMaybeNoNull f as = else Just bs -- TODO: Move instances to `Reflex.Patch` +-- | Displays a 'MonoidalMap' as a tree. See 'Data.Map.Lazy.showTree' for details. showTree :: forall k a. (Show k, Show a) => MonoidalMap k a -> String showTree = coerce (Map.showTree :: Map k a -> String) +-- | Displays a 'MonoidalMap' as a tree, using the supplied function to convert nodes to string. showTreeWith :: forall k a. (k -> a -> String) -> Bool -> Bool -> MonoidalMap k a -> String showTreeWith = coerce (Map.showTreeWith :: (k -> a -> String) -> Bool -> Bool -> Map k a -> String) From 438059a0d135790a4608bbbb34cdc2999a8fe619 Mon Sep 17 00:00:00 2001 From: Ali Abrar Date: Thu, 28 Mar 2019 15:26:28 -0400 Subject: [PATCH 127/241] Haddocks for FastMutableIntMap --- src/Data/FastMutableIntMap.hs | 17 +++++++++++++++++ src/Data/FastWeakBag.hs | 2 +- 2 files changed, 18 insertions(+), 1 deletion(-) diff --git a/src/Data/FastMutableIntMap.hs b/src/Data/FastMutableIntMap.hs index d4ee5820..15ce190c 100644 --- a/src/Data/FastMutableIntMap.hs +++ b/src/Data/FastMutableIntMap.hs @@ -1,4 +1,9 @@ {-# LANGUAGE TypeFamilies #-} +-- | +-- Module: +-- Data.FastMutableIntMap +-- Description: +-- A mutable version of 'IntMap' module Data.FastMutableIntMap ( FastMutableIntMap , new @@ -32,33 +37,43 @@ import Data.IORef import Reflex.Patch.Class import Reflex.Patch.IntMap +-- | A 'FastMutableIntMap' holds a map of values of type @a@ and allows low-overhead modifications via IO. +-- Operations on 'FastMutableIntMap' run in IO. newtype FastMutableIntMap a = FastMutableIntMap (IORef (IntMap a)) +-- | Create a new 'FastMutableIntMap' out of an 'IntMap' new :: IntMap a -> IO (FastMutableIntMap a) new m = FastMutableIntMap <$> newIORef m +-- | Create a new empty 'FastMutableIntMap' newEmpty :: IO (FastMutableIntMap a) newEmpty = FastMutableIntMap <$> newIORef IntMap.empty +-- | Insert an element into a 'FastMutableIntMap' at the given key insert :: FastMutableIntMap a -> Int -> a -> IO () insert (FastMutableIntMap r) k v = modifyIORef' r $ IntMap.insert k v +-- | Attempt to lookup an element by key in a 'FastMutableIntMap' lookup :: FastMutableIntMap a -> Int -> IO (Maybe a) lookup (FastMutableIntMap r) k = IntMap.lookup k <$> readIORef r +-- | Runs the provided action over the intersection of a 'FastMutableIntMap' and an 'IntMap' forIntersectionWithImmutable_ :: MonadIO m => FastMutableIntMap a -> IntMap b -> (a -> b -> m ()) -> m () forIntersectionWithImmutable_ (FastMutableIntMap r) b f = do a <- liftIO $ readIORef r traverse_ (uncurry f) $ IntMap.intersectionWith (,) a b +-- | Runs the provided action over the values of a 'FastMutableIntMap' for_ :: MonadIO m => FastMutableIntMap a -> (a -> m ()) -> m () for_ (FastMutableIntMap r) f = do a <- liftIO $ readIORef r traverse_ f a +-- | Checks whether a 'FastMutableIntMap' is empty isEmpty :: FastMutableIntMap a -> IO Bool isEmpty (FastMutableIntMap r) = IntMap.null <$> readIORef r +-- | Retrieves the size of a 'FastMutableIntMap' size :: FastMutableIntMap a -> IO Int size (FastMutableIntMap r) = IntMap.size <$> readIORef r @@ -69,6 +84,8 @@ getFrozenAndClear (FastMutableIntMap r) = do writeIORef r IntMap.empty return result +-- | Updates the value of a 'FastMutableIntMap' with the given patch (see 'Reflex.Patch.IntMap'), +-- and returns an 'IntMap' with the modified keys and values. applyPatch :: FastMutableIntMap a -> PatchIntMap a -> IO (IntMap a) applyPatch (FastMutableIntMap r) p@(PatchIntMap m) = do v <- readIORef r diff --git a/src/Data/FastWeakBag.hs b/src/Data/FastWeakBag.hs index e512e85d..75dd63b4 100644 --- a/src/Data/FastWeakBag.hs +++ b/src/Data/FastWeakBag.hs @@ -50,7 +50,7 @@ newtype FastWeakBag a = FastWeakBag JSVal #else data FastWeakBag a = FastWeakBag { _weakBag_nextId :: {-# UNPACK #-} !(IORef Int) --TODO: what if this wraps around? - , _weakBag_children :: {-# UNPACK #-} !(IORef (IntMap (Weak a))) + , _weakBag_children :: {-# UNPACK #-} !(IORef (IntMap (Weak a))) -- ^ Map of items contained by the 'FastWeakBag' } #endif From 0c9b5056fba8aac032c1d0beaa45af4cd39477e6 Mon Sep 17 00:00:00 2001 From: Ali Abrar Date: Thu, 28 Mar 2019 15:56:24 -0400 Subject: [PATCH 128/241] Haddocks for Reflex.Class --- src/Reflex/Class.hs | 98 ++++++++++++++++++++++++++++++++++++++++----- 1 file changed, 89 insertions(+), 9 deletions(-) diff --git a/src/Reflex/Class.hs b/src/Reflex/Class.hs index 1a20dafb..7824f338 100644 --- a/src/Reflex/Class.hs +++ b/src/Reflex/Class.hs @@ -300,6 +300,8 @@ class ( MonadHold t (PushM t) fanInt :: Event t (IntMap a) -> EventSelectorInt t a --TODO: Specialize this so that we can take advantage of knowing that there's no changing going on +-- | Constructs a single 'Event' out of a map of events. The output event may fire with multiple +-- keys simultaneously. mergeInt :: Reflex t => IntMap (Event t a) -> Event t (IntMap a) mergeInt m = mergeIntIncremental $ unsafeBuildIncremental (return m) never @@ -368,26 +370,91 @@ class MonadSample t m => MonadHold t m where -- the supplied 'Event'. headE :: Event t a -> m (Event t a) -accumIncremental :: (Reflex t, Patch p, MonadHold t m, MonadFix m) => (PatchTarget p -> b -> p) -> PatchTarget p -> Event t b -> m (Incremental t p) +-- | Accumulate an 'Incremental' with the supplied initial value and the firings of the provided 'Event', +-- using the combining function to produce a patch. +accumIncremental + :: (Reflex t, Patch p, MonadHold t m, MonadFix m) + => (PatchTarget p -> b -> p) + -> PatchTarget p + -> Event t b + -> m (Incremental t p) accumIncremental f = accumMaybeIncremental $ \v o -> Just $ f v o -accumMIncremental :: (Reflex t, Patch p, MonadHold t m, MonadFix m) => (PatchTarget p -> b -> PushM t p) -> PatchTarget p -> Event t b -> m (Incremental t p) + +-- | Similar to 'accumIncremental' but the combining function runs in 'PushM' +accumMIncremental + :: (Reflex t, Patch p, MonadHold t m, MonadFix m) + => (PatchTarget p -> b -> PushM t p) + -> PatchTarget p + -> Event t b + -> m (Incremental t p) accumMIncremental f = accumMaybeMIncremental $ \v o -> Just <$> f v o -accumMaybeIncremental :: (Reflex t, Patch p, MonadHold t m, MonadFix m) => (PatchTarget p -> b -> Maybe p) -> PatchTarget p -> Event t b -> m (Incremental t p) + +-- | Similar to 'accumIncremental' but allows filtering of updates (by dropping updates when the +-- combining function produces @Nothing@) +accumMaybeIncremental + :: (Reflex t, Patch p, MonadHold t m, MonadFix m) + => (PatchTarget p -> b -> Maybe p) + -> PatchTarget p + -> Event t b + -> m (Incremental t p) accumMaybeIncremental f = accumMaybeMIncremental $ \v o -> return $ f v o -accumMaybeMIncremental :: (Reflex t, Patch p, MonadHold t m, MonadFix m) => (PatchTarget p -> b -> PushM t (Maybe p)) -> PatchTarget p -> Event t b -> m (Incremental t p) + +-- | Similar to 'accumMaybeMIncremental' but the combining function runs in 'PushM' +accumMaybeMIncremental + :: (Reflex t, Patch p, MonadHold t m, MonadFix m) + => (PatchTarget p -> b -> PushM t (Maybe p)) + -> PatchTarget p + -> Event t b + -> m (Incremental t p) accumMaybeMIncremental f z e = do rec let e' = flip push e $ \o -> do v <- sample $ currentIncremental d' f v o d' <- holdIncremental z e' return d' -mapAccumIncremental :: (Reflex t, Patch p, MonadHold t m, MonadFix m) => (PatchTarget p -> b -> (p, c)) -> PatchTarget p -> Event t b -> m (Incremental t p, Event t c) + +-- | Accumulate an 'Incremental' by folding occurrences of an 'Event' +-- with a function that both accumulates and produces a value to fire +-- as an 'Event'. Returns both the accumulated value and the constructed +-- 'Event'. +mapAccumIncremental + :: (Reflex t, Patch p, MonadHold t m, MonadFix m) + => (PatchTarget p -> b -> (p, c)) + -> PatchTarget p + -> Event t b + -> m (Incremental t p, Event t c) mapAccumIncremental f = mapAccumMaybeIncremental $ \v o -> bimap Just Just $ f v o -mapAccumMIncremental :: (Reflex t, Patch p, MonadHold t m, MonadFix m) => (PatchTarget p -> b -> PushM t (p, c)) -> PatchTarget p -> Event t b -> m (Incremental t p, Event t c) + +-- | Like 'mapAccumIncremental' but the combining function runs in 'PushM' +mapAccumMIncremental + :: (Reflex t, Patch p, MonadHold t m, MonadFix m) + => (PatchTarget p -> b -> PushM t (p, c)) + -> PatchTarget p + -> Event t b + -> m (Incremental t p, Event t c) mapAccumMIncremental f = mapAccumMaybeMIncremental $ \v o -> bimap Just Just <$> f v o -mapAccumMaybeIncremental :: (Reflex t, Patch p, MonadHold t m, MonadFix m) => (PatchTarget p -> b -> (Maybe p, Maybe c)) -> PatchTarget p -> Event t b -> m (Incremental t p, Event t c) + +-- | Accumulate an 'Incremental' by folding occurrences of an 'Event' with +-- a function that both optionally accumulates and optionally produces +-- a value to fire as a separate output 'Event'. +-- Note that because 'Nothing's are discarded in both cases, the output +-- 'Event' may fire even though the output 'Incremental' has not changed, and +-- the output 'Incremental' may update even when the output 'Event' is not firing. +mapAccumMaybeIncremental + :: (Reflex t, Patch p, MonadHold t m, MonadFix m) + => (PatchTarget p -> b -> (Maybe p, Maybe c)) + -> PatchTarget p + -> Event t b + -> m (Incremental t p, Event t c) mapAccumMaybeIncremental f = mapAccumMaybeMIncremental $ \v o -> return $ f v o -mapAccumMaybeMIncremental :: (Reflex t, Patch p, MonadHold t m, MonadFix m) => (PatchTarget p -> b -> PushM t (Maybe p, Maybe c)) -> PatchTarget p -> Event t b -> m (Incremental t p, Event t c) + +-- | Like 'mapAccumMaybeIncremental' but the combining function is a 'PushM' action +mapAccumMaybeMIncremental + :: (Reflex t, Patch p, MonadHold t m, MonadFix m) + => (PatchTarget p -> b -> PushM t (Maybe p, Maybe c)) + -> PatchTarget p + -> Event t b + -> m (Incremental t p, Event t c) mapAccumMaybeMIncremental f z e = do rec let e' = flip push e $ \o -> do v <- sample $ currentIncremental d' @@ -398,6 +465,7 @@ mapAccumMaybeMIncremental f z e = do d' <- holdIncremental z $ mapMaybe fst e' return (d', mapMaybe snd e') +-- | A somewhat slow implementation of 'headE' slowHeadE :: (Reflex t, MonadHold t m, MonadFix m) => Event t a -> m (Event t a) slowHeadE e = do rec be <- hold e $ fmapCheap (const never) e' @@ -418,6 +486,8 @@ newtype EventSelector t k = EventSelector select :: forall a. k a -> Event t a } +-- | Efficiently select an 'Event' keyed on 'Int'. This is more efficient than manually +-- filtering by key. newtype EventSelectorInt t a = EventSelectorInt { selectInt :: Int -> Event t a } -------------------------------------------------------------------------------- @@ -801,7 +871,12 @@ mergeList :: Reflex t => [Event t a] -> Event t (NonEmpty a) mergeList [] = never mergeList es = mergeWithFoldCheap' id es -unsafeMapIncremental :: (Reflex t, Patch p, Patch p') => (PatchTarget p -> PatchTarget p') -> (p -> p') -> Incremental t p -> Incremental t p' +unsafeMapIncremental + :: (Reflex t, Patch p, Patch p') + => (PatchTarget p -> PatchTarget p') + -> (p -> p') + -> Incremental t p + -> Incremental t p' unsafeMapIncremental f g a = unsafeBuildIncremental (fmap f $ sample $ currentIncremental a) $ g <$> updatedIncremental a -- | Create a new 'Event' combining the map of 'Event's into an 'Event' that @@ -918,6 +993,9 @@ coincidencePatchMapWithMove e = fmapCheap unsafePatchMapWithMove $ coincidence $ ni { PatchMapWithMove._nodeInfo_from = PatchMapWithMove.From_Delete } ] +-- | Given a 'PatchTarget' of events (e.g., a 'Map' with 'Event' values) and an event of 'Patch'es +-- (e.g., a 'PatchMap' with 'Event' values), produce an 'Event' of the 'PatchTarget' type that +-- fires with the patched value. switchHoldPromptOnlyIncremental :: forall t m p pt w . ( Reflex t @@ -1491,8 +1569,10 @@ mergeWithFoldCheap' f es = -------------------------------------------------------------------------------- {-# DEPRECATED switchPromptly "Use 'switchHoldPromptly' instead. The 'switchHold*' naming convention was chosen because those functions are more closely related to each other than they are to 'switch'. " #-} +-- | See 'switchHoldPromptly' switchPromptly :: (Reflex t, MonadHold t m) => Event t a -> Event t (Event t a) -> m (Event t a) switchPromptly = switchHoldPromptly {-# DEPRECATED switchPromptOnly "Use 'switchHoldPromptOnly' instead. The 'switchHold*' naming convention was chosen because those functions are more closely related to each other than they are to 'switch'. " #-} +-- | See 'switchHoldPromptOnly' switchPromptOnly :: (Reflex t, MonadHold t m) => Event t a -> Event t (Event t a) -> m (Event t a) switchPromptOnly = switchHoldPromptOnly From b8a82f1c0f12e679cfd20d5aa0c310266278a438 Mon Sep 17 00:00:00 2001 From: Ali Abrar Date: Thu, 28 Mar 2019 16:13:07 -0400 Subject: [PATCH 129/241] Haddocks for factorDyn and Adjustable --- src/Reflex/Adjustable/Class.hs | 33 ++++++++++++++++++++++++++++--- src/Reflex/Dynamic.hs | 6 ++++++ src/Reflex/DynamicWriter/Class.hs | 1 + 3 files changed, 37 insertions(+), 3 deletions(-) diff --git a/src/Reflex/Adjustable/Class.hs b/src/Reflex/Adjustable/Class.hs index 6fbeff45..d5b872ab 100644 --- a/src/Reflex/Adjustable/Class.hs +++ b/src/Reflex/Adjustable/Class.hs @@ -11,6 +11,13 @@ #ifdef USE_REFLEX_OPTIMIZER {-# OPTIONS_GHC -fplugin=Reflex.Optimizer #-} #endif +-- | +-- Module: +-- Reflex.Adjustable.Class +-- Description: +-- A class for actions that can be "adjusted" over time based on some 'Event' +-- such that, when observed after the firing of any such 'Event', the result +-- is as though the action was originally run with the 'Event's value. module Reflex.Adjustable.Class ( -- * The Adjustable typeclass @@ -94,13 +101,32 @@ instance Adjustable t m => Adjustable t (ReaderT r m) where r <- ask lift $ traverseDMapWithKeyWithAdjustWithMove (\k v -> runReaderT (f k v) r) dm0 dm' -sequenceDMapWithAdjust :: (GCompare k, Adjustable t m) => DMap k m -> Event t (PatchDMap k m) -> m (DMap k Identity, Event t (PatchDMap k Identity)) +-- | Traverse a 'DMap' of 'Adjustable' actions, running each of them. The provided 'Event' of patches +-- to the 'DMap' can add, remove, or update values. +sequenceDMapWithAdjust + :: (GCompare k, Adjustable t m) + => DMap k m + -> Event t (PatchDMap k m) + -> m (DMap k Identity, Event t (PatchDMap k Identity)) sequenceDMapWithAdjust = traverseDMapWithKeyWithAdjust $ \_ -> fmap Identity -sequenceDMapWithAdjustWithMove :: (GCompare k, Adjustable t m) => DMap k m -> Event t (PatchDMapWithMove k m) -> m (DMap k Identity, Event t (PatchDMapWithMove k Identity)) +-- | Traverses a 'DMap' of 'Adjustable' actions, running each of them. The provided 'Event' of patches +-- to the 'DMap' can add, remove, update, move, or swap values. +sequenceDMapWithAdjustWithMove + :: (GCompare k, Adjustable t m) + => DMap k m + -> Event t (PatchDMapWithMove k m) + -> m (DMap k Identity, Event t (PatchDMapWithMove k Identity)) sequenceDMapWithAdjustWithMove = traverseDMapWithKeyWithAdjustWithMove $ \_ -> fmap Identity -mapMapWithAdjustWithMove :: forall t m k v v'. (Adjustable t m, Ord k) => (k -> v -> m v') -> Map k v -> Event t (PatchMapWithMove k v) -> m (Map k v', Event t (PatchMapWithMove k v')) +-- | Traverses a 'Map', running the provided 'Adjustable' action. The provided 'Event' of patches to the 'Map' +-- can add, remove, update, move, or swap values. +mapMapWithAdjustWithMove + :: forall t m k v v'. (Adjustable t m, Ord k) + => (k -> v -> m v') + -> Map k v + -> Event t (PatchMapWithMove k v) + -> m (Map k v', Event t (PatchMapWithMove k v')) mapMapWithAdjustWithMove f m0 m' = do (out0 :: DMap (Const2 k v) (Constant v'), out') <- traverseDMapWithKeyWithAdjustWithMove (\(Const2 k) (Identity v) -> Constant <$> f k v) (mapToDMap m0) (const2PatchDMapWithMoveWith Identity <$> m') return (dmapToMapWith (\(Constant v') -> v') out0, patchDMapWithMoveToPatchMapWithMoveWith (\(Constant v') -> v') <$> out') @@ -110,4 +136,5 @@ mapMapWithAdjustWithMove f m0 m' = do -------------------------------------------------------------------------------- {-# DEPRECATED MonadAdjust "Use Adjustable instead" #-} +-- | Synonym for 'Adjustable' type MonadAdjust = Adjustable diff --git a/src/Reflex/Dynamic.hs b/src/Reflex/Dynamic.hs index d4fef93e..7ee4cfd7 100644 --- a/src/Reflex/Dynamic.hs +++ b/src/Reflex/Dynamic.hs @@ -301,6 +301,8 @@ maybeDyn = fmap (fmap unpack) . eitherDyn . fmap pack Left _ -> Nothing Right a -> Just a +-- | Turns a 'Dynamic t (Either a b)' into a 'Dynamic t (Either (Dynamic t a) (Dynamic t b))' such that +-- the outer 'Dynamic' is updated only when the 'Either' constructor changes (e.g., from 'Left' to 'Right'). eitherDyn :: forall t a b m. (Reflex t, MonadFix m, MonadHold t m) => Dynamic t (Either a b) -> m (Dynamic t (Either (Dynamic t a) (Dynamic t b))) eitherDyn = fmap (fmap unpack) . factorDyn . fmap eitherToDSum where unpack :: DSum (EitherTag a b) (Compose (Dynamic t) Identity) -> Either (Dynamic t a) (Dynamic t b) @@ -308,6 +310,9 @@ eitherDyn = fmap (fmap unpack) . factorDyn . fmap eitherToDSum LeftTag :=> Compose a -> Left $ coerceDynamic a RightTag :=> Compose b -> Right $ coerceDynamic b +-- | Factor a 'Dynamic t DSum' into a 'Dynamic' 'DSum' containing nested 'Dynamic' values. +-- The outer 'Dynamic' updates only when the key of the 'DSum' changes, while the update of the inner +-- 'Dynamic' represents updates within the current key. factorDyn :: forall t m k v. (Reflex t, MonadHold t m, GEq k) => Dynamic t (DSum k v) -> m (Dynamic t (DSum k (Compose (Dynamic t) v))) factorDyn d = buildDynamic (sample (current d) >>= holdKey) update where @@ -322,6 +327,7 @@ factorDyn d = buildDynamic (sample (current d) >>= holdKey) update where inner' <- filterEventKey k (updated d) inner <- holdDyn v inner' return $ k :=> Compose inner + -------------------------------------------------------------------------------- -- Demux -------------------------------------------------------------------------------- diff --git a/src/Reflex/DynamicWriter/Class.hs b/src/Reflex/DynamicWriter/Class.hs index 675f0a15..34767c14 100644 --- a/src/Reflex/DynamicWriter/Class.hs +++ b/src/Reflex/DynamicWriter/Class.hs @@ -17,6 +17,7 @@ import Control.Monad.Reader (ReaderT, lift) import Reflex.Class (Dynamic) {-# DEPRECATED MonadDynamicWriter "Use 'DynamicWriter' instead" #-} +-- | Type synonym for 'DynamicWriter' type MonadDynamicWriter = DynamicWriter -- | 'MonadDynamicWriter' efficiently collects 'Dynamic' values using 'tellDyn' From 62b3f1bf202b74b8bf4c3aa77afb4338b398c70e Mon Sep 17 00:00:00 2001 From: Ali Abrar Date: Thu, 28 Mar 2019 16:45:46 -0400 Subject: [PATCH 130/241] Haddocks for Reflex.Query.Class --- src/Reflex/Query/Class.hs | 28 ++++++++++++++++++++++++---- 1 file changed, 24 insertions(+), 4 deletions(-) diff --git a/src/Reflex/Query/Class.hs b/src/Reflex/Query/Class.hs index ff536b58..0982c3a0 100644 --- a/src/Reflex/Query/Class.hs +++ b/src/Reflex/Query/Class.hs @@ -6,6 +6,13 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} +-- | +-- Module: +-- Reflex.Query.Class +-- Description: +-- A class that ties together queries to some data source and their results, +-- providing methods for requesting data from the source and accumulating +-- streamed results. module Reflex.Query.Class ( Query (..) , QueryMorphism (..) @@ -32,6 +39,10 @@ import Foreign.Storable import Reflex.Class +-- | A 'Query' can be thought of as a declaration of interest in some set of data. +-- A 'QueryResult' is the set of data associated with that interest set. +-- The @crop@ function provides a way to determine what part of a given 'QueryResult' +-- is relevant to a given 'Query'. class (Monoid (QueryResult a), Semigroup (QueryResult a)) => Query a where type QueryResult a :: * crop :: a -> QueryResult a -> QueryResult a @@ -40,8 +51,8 @@ instance (Ord k, Query v) => Query (MonoidalMap k v) where type QueryResult (MonoidalMap k v) = MonoidalMap k (QueryResult v) crop q r = MonoidalMap.intersectionWith (flip crop) r q --- | NB: QueryMorphism's must be group homomorphisms when acting on the query type --- and compatible with the query relationship when acting on the query result +-- | QueryMorphism's must be group homomorphisms when acting on the query type +-- and compatible with the query relationship when acting on the query result. data QueryMorphism q q' = QueryMorphism { _queryMorphism_mapQuery :: q -> q' , _queryMorphism_mapQueryResult :: QueryResult q' -> QueryResult q @@ -54,13 +65,16 @@ instance Category QueryMorphism where , _queryMorphism_mapQueryResult = mapQueryResult qm' . mapQueryResult qm } +-- | Apply a 'QueryMorphism' to a 'Query' mapQuery :: QueryMorphism q q' -> q -> q' mapQuery = _queryMorphism_mapQuery +-- | Map a 'QueryMorphism' to a 'QueryResult' mapQueryResult :: QueryMorphism q q' -> QueryResult q' -> QueryResult q mapQueryResult = _queryMorphism_mapQueryResult --- | This type keeps track of the multiplicity of elements of the view selector that are being used by the app +-- | This type can be used to track of the frequency of interest in a given 'Query'. See note on +-- 'combineSelectedCounts' newtype SelectedCount = SelectedCount { unSelectedCount :: Int } deriving (Eq, Ord, Show, Read, Integral, Num, Bounded, Enum, Real, Ix, Bits, FiniteBits, Storable, Data) @@ -76,10 +90,14 @@ instance Group SelectedCount where instance Additive SelectedCount --- | The Semigroup/Monoid/Group instances for a ViewSelector should use this function which returns Nothing if the result is 0. This allows the pruning of leaves that are no longer wanted. +-- | The Semigroup/Monoid/Group instances for a Query containing 'SelectedCount's should use +-- this function which returns Nothing if the result is 0. This allows the pruning of leaves +-- of the 'Query' that are no longer wanted. combineSelectedCounts :: SelectedCount -> SelectedCount -> Maybe SelectedCount combineSelectedCounts (SelectedCount i) (SelectedCount j) = if i == negate j then Nothing else Just $ SelectedCount (i + j) +-- | A class that allows sending of 'Query's and retrieval of 'QueryResult's. See 'queryDyn' for a commonly +-- used interface. class (Group q, Additive q, Query q) => MonadQuery t q m | m -> q t where tellQueryIncremental :: Incremental t (AdditivePatch q) -> m () askQueryResult :: m (Dynamic t (QueryResult q)) @@ -90,9 +108,11 @@ instance (Monad m, MonadQuery t q m) => MonadQuery t q (ReaderT r m) where askQueryResult = lift askQueryResult queryIncremental = lift . queryIncremental +-- | Produce and send an 'Incremental' 'Query' from a 'Dynamic' 'Query'. tellQueryDyn :: (Reflex t, MonadQuery t q m) => Dynamic t q -> m () tellQueryDyn d = tellQueryIncremental $ unsafeBuildIncremental (sample (current d)) $ attachWith (\old new -> AdditivePatch $ new ~~ old) (current d) (updated d) +-- | Retrieve 'Dynamic'ally updating 'QueryResult's for a 'Dynamic'ally updating 'Query'. queryDyn :: (Reflex t, Monad m, MonadQuery t q m) => Dynamic t q -> m (Dynamic t (QueryResult q)) queryDyn q = do tellQueryDyn q From e3376cb5ecfccc7db9e3daf1bf94982f671edfba Mon Sep 17 00:00:00 2001 From: Sridhar Ratnakumar Date: Fri, 29 Mar 2019 10:13:33 -0400 Subject: [PATCH 131/241] Format types and functions in ChangeLog --- ChangeLog.md | 18 +++++++++--------- 1 file changed, 9 insertions(+), 9 deletions(-) diff --git a/ChangeLog.md b/ChangeLog.md index f67e82ee..2b492749 100644 --- a/ChangeLog.md +++ b/ChangeLog.md @@ -2,16 +2,16 @@ ## 0.6.0.0 -- 2019-03-20 -* Deprecate FunctorMaybe in favor of Data.Witherable.Filterable. We still export fmapMaybe, ffilter, etc., but they all rely on Filterable now. -* Rename MonadDynamicWriter to DynamicWriter and add a deprecation for the old name. +* Deprecate `FunctorMaybe` in favor of `Data.Witherable.Filterable`. We still export `fmapMaybe`, `ffilter`, etc., but they all rely on `Filterable` now. +* Rename `MonadDynamicWriter` to `DynamicWriter` and add a deprecation for the old name. * Remove many deprecated functions. -* Add a Num instance for Dynamic. -* Add matchRequestsWithResponses to make it easier to use Requester with protocols that don't do this matching for you. -* Add withRequesterT to map functions over the request and response of a RequesterT. -* Suppress nil patches in QueryT as an optimization. The Query type must now have an Eq instance. -* Add throttleBatchWithLag to Reflex.Time. See that module for details. +* Add a `Num` instance for `Dynamic`. +* Add `matchRequestsWithResponses` to make it easier to use `Requester` with protocols that don't do this matching for you. +* Add `withRequesterT` to map functions over the request and response of a `RequesterT`. +* Suppress nil patches in `QueryT` as an optimization. The `Query` type must now have an `Eq` instance. +* Add `throttleBatchWithLag` to `Reflex.Time`. See that module for details. ## 0.6.1.0 -* Re-export all of Data.Map.Monoidal -* Fix QueryT and RequesterT tests +* Re-export all of `Data.Map.Monoidal` +* Fix `QueryT` and `RequesterT` tests From d5d5831a9360ee1a09f9338c14edf2b196d61363 Mon Sep 17 00:00:00 2001 From: Ali Abrar Date: Fri, 29 Mar 2019 16:01:29 -0400 Subject: [PATCH 132/241] Add contribution guidelines --- CONTRIBUTING.md | 57 +++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 57 insertions(+) create mode 100644 CONTRIBUTING.md diff --git a/CONTRIBUTING.md b/CONTRIBUTING.md new file mode 100644 index 00000000..fac3017a --- /dev/null +++ b/CONTRIBUTING.md @@ -0,0 +1,57 @@ +# Contribution Guide + +Contributions and issue reports are encouraged and appreciated! + +- [Opening Issues](#opening-issues) +- [Submitting Changes](#submitting-changes) + - [Guidelines for Commit Messages](#guidelines-for-commit-messages) + - [Code Quality](#code-quality) + - [Documentation](#documentation) + +## Opening Issues + +Before opening an issue, please check whether your issue has already been reported. Assuming it has not: + +* Describe the issue you're encountering or the suggestion you're making +* Include any relevant steps to reproduce or code samples you can. It's always easier for us to debug if we have something that demonstrates the error. +* Let us know what version of reflex you were using. If you're using a github checkout, provide the git hash. +* Describe how you're building reflex (i.e., via reflex-platform, cabal install, stack, obelisk, etc.). If you're using reflex-platform or obelisk, provide the git hash of your checkout. + +## Submitting Changes + +### Guidelines for Commit Messages + +#### Summary Line +The summary line of your commit message should summarize the changes being made. Commit messages should be written in the imperative mood and should describe what happens when the commit is applied. + +One way to think about it is that your commit message should be able to complete the sentence: +"When applied, this commit will..." + +#### Body +For breaking changes, new features, refactors, or other major changes, the body of the commit message should describe the motivation behind the change in greater detail and may include references to the issue tracker. The body shouldn't repeat code/comments from the diff. + +### Code Quality + +#### Warnings + +Your pull request should add no new warnings to the project. It should also generally not disable any warnings. + +#### Build and Test + +Make sure the project builds and that the tests pass! This will generally also be checked by CI before merge, but trying it yourself first means you'll catch problems earlier and your contribution can be merged that much sooner! + +### Documentation + +#### In the code +We're always striving to improve documentation. Please include [haddock](https://haskell-haddock.readthedocs.io/en/latest/index.html) documentation for any added code, and update the documentation for any code you modify. + +#### In the [Changelog](ChangeLog.md) +Add an entry to the changelog when your PR: +* Adds a feature +* Deprecates something +* Includes a breaking change +* Makes any other change that will impact users + +#### In the [Readme](README.md) +The readme is the first place a lot of people look for information about the repository. Update any parts of the readme that are affected by your PR. + From b53771223bb7bbf177e667fd4907f476475ea9e5 Mon Sep 17 00:00:00 2001 From: Elliot Cameron <3noch@users.noreply.github.com> Date: Fri, 29 Mar 2019 16:23:01 -0400 Subject: [PATCH 133/241] Use reverse chronological order in ChangeLog --- ChangeLog.md | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/ChangeLog.md b/ChangeLog.md index 2b492749..4367a0ce 100644 --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,5 +1,10 @@ # Revision history for reflex +## 0.6.1.0 + +* Re-export all of `Data.Map.Monoidal` +* Fix `QueryT` and `RequesterT` tests + ## 0.6.0.0 -- 2019-03-20 * Deprecate `FunctorMaybe` in favor of `Data.Witherable.Filterable`. We still export `fmapMaybe`, `ffilter`, etc., but they all rely on `Filterable` now. @@ -10,8 +15,3 @@ * Add `withRequesterT` to map functions over the request and response of a `RequesterT`. * Suppress nil patches in `QueryT` as an optimization. The `Query` type must now have an `Eq` instance. * Add `throttleBatchWithLag` to `Reflex.Time`. See that module for details. - -## 0.6.1.0 - -* Re-export all of `Data.Map.Monoidal` -* Fix `QueryT` and `RequesterT` tests From 9c3d165b9542dcf87c736bb14a655ec2422720ff Mon Sep 17 00:00:00 2001 From: Ryan Trinkle Date: Thu, 4 Apr 2019 02:55:09 -0400 Subject: [PATCH 134/241] Make holdDyn lazy in its Event again I'm not sure when this changed - we don't use the laziness much in reflex-dom, but it should definitely be there --- src/Reflex/Spider/Internal.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Reflex/Spider/Internal.hs b/src/Reflex/Spider/Internal.hs index bfdce701..a6669cea 100644 --- a/src/Reflex/Spider/Internal.hs +++ b/src/Reflex/Spider/Internal.hs @@ -705,7 +705,7 @@ readBehaviorUntracked b = do data Dynamic x p = Dynamic { dynamicCurrent :: !(Behavior x (PatchTarget p)) - , dynamicUpdated :: !(Event x p) + , dynamicUpdated :: Event x p -- This must be lazy; see the comment on holdEvent --TODO: Would this let us eliminate `Dyn`? } dynamicHold :: Hold x p -> Dynamic x p From 163c414281c7a4d57f858f253fd70ad3d4ad153e Mon Sep 17 00:00:00 2001 From: Ali Abrar Date: Thu, 4 Apr 2019 12:05:41 -0400 Subject: [PATCH 135/241] Update changelog for holdDyn fix --- ChangeLog.md | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/ChangeLog.md b/ChangeLog.md index 4367a0ce..18f064bd 100644 --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,5 +1,9 @@ # Revision history for reflex +## Unreleased + +* Fix `holdDyn` so that it is lazy in its event argument + ## 0.6.1.0 * Re-export all of `Data.Map.Monoidal` From 78d9996d71b0b872dbf9d6121bfb1f70dd0ffb30 Mon Sep 17 00:00:00 2001 From: Grey Hill Date: Tue, 16 Apr 2019 20:03:05 -0700 Subject: [PATCH 136/241] Typo --- src/Reflex/Workflow.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Reflex/Workflow.hs b/src/Reflex/Workflow.hs index c1fcca95..c5cb1d1b 100644 --- a/src/Reflex/Workflow.hs +++ b/src/Reflex/Workflow.hs @@ -41,7 +41,7 @@ workflowView w0 = do eReplace <- fmap switch $ hold never $ fmap snd eResult return $ fmap fst eResult --- | Map a function over a 'Workflow', possibly changing the resturn type. +-- | Map a function over a 'Workflow', possibly changing the return type. mapWorkflow :: (Reflex t, Functor m) => (a -> b) -> Workflow t m a -> Workflow t m b mapWorkflow f (Workflow x) = Workflow (fmap (f *** fmap (mapWorkflow f)) x) From 9ec0e5f18f3439715eca042242ad54aeb17145d6 Mon Sep 17 00:00:00 2001 From: Alexandre Esteves Date: Thu, 18 Apr 2019 01:20:35 +0100 Subject: [PATCH 137/241] Bump 'these' upper bound --- reflex.cabal | 2 +- src/Reflex/Class.hs | 8 ++++++++ src/Reflex/Spider/Internal.hs | 7 +++++++ 3 files changed, 16 insertions(+), 1 deletion(-) diff --git a/reflex.cabal b/reflex.cabal index 2f3ab76f..93ea4370 100644 --- a/reflex.cabal +++ b/reflex.cabal @@ -61,7 +61,7 @@ library semigroups >= 0.16 && < 0.19, stm >= 2.4 && < 2.6, syb >= 0.5 && < 0.8, - these >= 0.4 && < 0.7.7, + these >= 0.4 && < 0.9, time >= 1.4 && < 1.9, transformers >= 0.2, transformers-compat >= 0.3, diff --git a/src/Reflex/Class.hs b/src/Reflex/Class.hs index db36a80d..00c014ed 100644 --- a/src/Reflex/Class.hs +++ b/src/Reflex/Class.hs @@ -1018,9 +1018,17 @@ switchHoldPromptOnlyIncremental mergePatchIncremental coincidencePatch e0 e' = d That new -> new `applyAlways` mempty These old new -> new `applyAlways` old +#if MIN_VERSION_these(0, 8, 0) +instance Reflex t => Semialign (Event t) where + align = alignEventWithMaybe Just + instance Reflex t => Align (Event t) where nil = never +#else +instance Reflex t => Align (Event t) where align = alignEventWithMaybe Just + nil = never +#endif -- | Create a new 'Event' that only occurs if the supplied 'Event' occurs and -- the 'Behavior' is true at the time of occurrence. diff --git a/src/Reflex/Spider/Internal.hs b/src/Reflex/Spider/Internal.hs index a6669cea..e9140d0f 100644 --- a/src/Reflex/Spider/Internal.hs +++ b/src/Reflex/Spider/Internal.hs @@ -1131,9 +1131,16 @@ newInvalidatorPull p = return $! InvalidatorPull p instance HasSpiderTimeline x => Filterable (Event x) where mapMaybe f = push $ return . f +#if MIN_VERSION_these(0, 8, 0) +instance HasSpiderTimeline x => Semialign (Event x) where + align ea eb = mapMaybe dmapToThese $ merge $ dynamicConst $ DMap.fromDistinctAscList [LeftTag :=> ea, RightTag :=> eb] +instance HasSpiderTimeline x => Align (Event x) where + nil = eventNever +#else instance HasSpiderTimeline x => Align (Event x) where nil = eventNever align ea eb = mapMaybe dmapToThese $ merge $ dynamicConst $ DMap.fromDistinctAscList [LeftTag :=> ea, RightTag :=> eb] +#endif data DynType x p = UnsafeDyn !(BehaviorM x (PatchTarget p), Event x p) | BuildDyn !(EventM x (PatchTarget p), Event x p) From e6d87148fe71fb9d7e67a47a59e7028334775838 Mon Sep 17 00:00:00 2001 From: Alexandre Esteves Date: Thu, 18 Apr 2019 02:20:47 +0100 Subject: [PATCH 138/241] DRY conditional compilation --- src/Reflex/Class.hs | 10 +++------- src/Reflex/Spider/Internal.hs | 10 +++------- 2 files changed, 6 insertions(+), 14 deletions(-) diff --git a/src/Reflex/Class.hs b/src/Reflex/Class.hs index 00c014ed..dab54ea2 100644 --- a/src/Reflex/Class.hs +++ b/src/Reflex/Class.hs @@ -1018,17 +1018,13 @@ switchHoldPromptOnlyIncremental mergePatchIncremental coincidencePatch e0 e' = d That new -> new `applyAlways` mempty These old new -> new `applyAlways` old +instance Reflex t => Align (Event t) where + nil = never #if MIN_VERSION_these(0, 8, 0) instance Reflex t => Semialign (Event t) where +#endif align = alignEventWithMaybe Just -instance Reflex t => Align (Event t) where - nil = never -#else -instance Reflex t => Align (Event t) where - align = alignEventWithMaybe Just - nil = never -#endif -- | Create a new 'Event' that only occurs if the supplied 'Event' occurs and -- the 'Behavior' is true at the time of occurrence. diff --git a/src/Reflex/Spider/Internal.hs b/src/Reflex/Spider/Internal.hs index e9140d0f..68de74f1 100644 --- a/src/Reflex/Spider/Internal.hs +++ b/src/Reflex/Spider/Internal.hs @@ -1131,16 +1131,12 @@ newInvalidatorPull p = return $! InvalidatorPull p instance HasSpiderTimeline x => Filterable (Event x) where mapMaybe f = push $ return . f -#if MIN_VERSION_these(0, 8, 0) -instance HasSpiderTimeline x => Semialign (Event x) where - align ea eb = mapMaybe dmapToThese $ merge $ dynamicConst $ DMap.fromDistinctAscList [LeftTag :=> ea, RightTag :=> eb] -instance HasSpiderTimeline x => Align (Event x) where - nil = eventNever -#else instance HasSpiderTimeline x => Align (Event x) where nil = eventNever - align ea eb = mapMaybe dmapToThese $ merge $ dynamicConst $ DMap.fromDistinctAscList [LeftTag :=> ea, RightTag :=> eb] +#if MIN_VERSION_these(0, 8, 0) +instance HasSpiderTimeline x => Semialign (Event x) where #endif + align ea eb = mapMaybe dmapToThese $ merge $ dynamicConst $ DMap.fromDistinctAscList [LeftTag :=> ea, RightTag :=> eb] data DynType x p = UnsafeDyn !(BehaviorM x (PatchTarget p), Event x p) | BuildDyn !(EventM x (PatchTarget p), Event x p) From 72516e3dc92938b2fcdfbcc608ba9109aeaf760c Mon Sep 17 00:00:00 2001 From: Grey Hill Date: Sun, 28 Apr 2019 11:41:02 -0700 Subject: [PATCH 139/241] Typo --- src/Reflex/Class.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Reflex/Class.hs b/src/Reflex/Class.hs index db36a80d..9129bd4d 100644 --- a/src/Reflex/Class.hs +++ b/src/Reflex/Class.hs @@ -1363,7 +1363,7 @@ mapAccumMaybeB -> m (Behavior t a, Event t c) mapAccumMaybeB f = mapAccumMaybeMB $ \v o -> return $ f v o --- | LIke 'mapAccumMaybeB' except that the combining function is a 'PushM' action. +-- | Like 'mapAccumMaybeB' except that the combining function is a 'PushM' action. {-# INLINE mapAccumMaybeMB #-} mapAccumMaybeMB :: (Reflex t, MonadHold t m, MonadFix m) => (a -> b -> PushM t (Maybe a, Maybe c)) -> a -> Event t b -> m (Behavior t a, Event t c) mapAccumMaybeMB f z e = do From 1b16a5e62ee7609d05e9fe850ae486be457700b7 Mon Sep 17 00:00:00 2001 From: Ryan Trinkle Date: Mon, 29 Apr 2019 12:06:28 +0000 Subject: [PATCH 140/241] Bump upper bounds --- reflex.cabal | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/reflex.cabal b/reflex.cabal index 93ea4370..2f0cff20 100644 --- a/reflex.cabal +++ b/reflex.cabal @@ -134,7 +134,7 @@ library cpp-options: -DUSE_TEMPLATE_HASKELL build-depends: dependent-sum >= 0.3 && < 0.5, - haskell-src-exts >= 1.16 && < 1.21, + haskell-src-exts >= 1.16 && < 1.22, haskell-src-meta >= 0.6 && < 0.9, template-haskell >= 2.9 && < 2.15 exposed-modules: From 5c191d7b3b66a80347fd41c418e6bb2dba808c0d Mon Sep 17 00:00:00 2001 From: Ken Micklas Date: Mon, 29 Apr 2019 21:48:06 -0400 Subject: [PATCH 141/241] Use Some for more existential types (which should be efficient now that it is a newtype) --- src/Reflex/Spider/Internal.hs | 44 +++++++++++++++++------------------ 1 file changed, 22 insertions(+), 22 deletions(-) diff --git a/src/Reflex/Spider/Internal.hs b/src/Reflex/Spider/Internal.hs index 68de74f1..fbad7574 100644 --- a/src/Reflex/Spider/Internal.hs +++ b/src/Reflex/Spider/Internal.hs @@ -659,7 +659,7 @@ behaviorPull !p = Behavior $ do val <- liftIO $ readIORef $ pullValue p case val of Just subscribed -> do - askParentsRef >>= mapM_ (\r -> liftIO $ modifyIORef' r (SomeBehaviorSubscribed (BehaviorSubscribedPull subscribed) :)) + askParentsRef >>= mapM_ (\r -> liftIO $ modifyIORef' r (SomeBehaviorSubscribed (Some.This (BehaviorSubscribedPull subscribed)) :)) askInvalidator >>= mapM_ (\wi -> liftIO $ modifyIORef' (pullSubscribedInvalidators subscribed) (wi:)) liftIO $ touch $ pullSubscribedOwnInvalidator subscribed return $ pullSubscribedValue subscribed @@ -678,7 +678,7 @@ behaviorPull !p = Behavior $ do , pullSubscribedParents = parents } liftIO $ writeIORef (pullValue p) $ Just subscribed - askParentsRef >>= mapM_ (\r -> liftIO $ modifyIORef' r (SomeBehaviorSubscribed (BehaviorSubscribedPull subscribed) :)) + askParentsRef >>= mapM_ (\r -> liftIO $ modifyIORef' r (SomeBehaviorSubscribed (Some.This (BehaviorSubscribedPull subscribed)) :)) return a behaviorDyn :: Patch p => Dyn x p -> Behavior x (PatchTarget p) @@ -689,7 +689,7 @@ readHoldTracked :: Hold x p -> BehaviorM x (PatchTarget p) readHoldTracked h = do result <- liftIO $ readIORef $ holdValue h askInvalidator >>= mapM_ (\wi -> liftIO $ modifyIORef' (holdInvalidators h) (wi:)) - askParentsRef >>= mapM_ (\r -> liftIO $ modifyIORef' r (SomeBehaviorSubscribed (BehaviorSubscribedHold h) :)) + askParentsRef >>= mapM_ (\r -> liftIO $ modifyIORef' r (SomeBehaviorSubscribed (Some.This (BehaviorSubscribedHold h)) :)) liftIO $ touch h -- Otherwise, if this gets inlined enough, the hold's parent reference may get collected return result @@ -782,9 +782,9 @@ data EventEnv x , eventEnvDynInits :: !(IORef [SomeDynInit x]) , eventEnvMergeUpdates :: !(IORef [SomeMergeUpdate x]) , eventEnvMergeInits :: !(IORef [SomeMergeInit x]) -- Needed for Subscribe - , eventEnvClears :: !(IORef [SomeClear]) -- Needed for Subscribe - , eventEnvIntClears :: !(IORef [SomeIntClear]) - , eventEnvRootClears :: !(IORef [SomeRootClear]) + , eventEnvClears :: !(IORef [Some Clear]) -- Needed for Subscribe + , eventEnvIntClears :: !(IORef [Some IntClear]) + , eventEnvRootClears :: !(IORef [Some RootClear]) , eventEnvCurrentHeight :: !(IORef Height) -- Needed for Subscribe , eventEnvResetCoincidences :: !(IORef [SomeResetCoincidence x]) -- Needed for Subscribe , eventEnvDelayedMerges :: !(IORef (IntMap [EventM x ()])) @@ -856,29 +856,29 @@ putCurrentHeight h = do heightRef <- asksEventEnv eventEnvCurrentHeight liftIO $ writeIORef heightRef $! h -instance HasSpiderTimeline x => Defer SomeClear (EventM x) where +instance HasSpiderTimeline x => Defer (Some Clear) (EventM x) where {-# INLINE getDeferralQueue #-} getDeferralQueue = asksEventEnv eventEnvClears {-# INLINE scheduleClear #-} -scheduleClear :: Defer SomeClear m => IORef (Maybe a) -> m () -scheduleClear r = defer $ SomeClear r +scheduleClear :: Defer (Some Clear) m => IORef (Maybe a) -> m () +scheduleClear r = defer $ Some.This $ Clear r -instance HasSpiderTimeline x => Defer SomeIntClear (EventM x) where +instance HasSpiderTimeline x => Defer (Some IntClear) (EventM x) where {-# INLINE getDeferralQueue #-} getDeferralQueue = asksEventEnv eventEnvIntClears {-# INLINE scheduleIntClear #-} -scheduleIntClear :: Defer SomeIntClear m => IORef (IntMap a) -> m () -scheduleIntClear r = defer $ SomeIntClear r +scheduleIntClear :: Defer (Some IntClear) m => IORef (IntMap a) -> m () +scheduleIntClear r = defer $ Some.This $ IntClear r -instance HasSpiderTimeline x => Defer SomeRootClear (EventM x) where +instance HasSpiderTimeline x => Defer (Some RootClear) (EventM x) where {-# INLINE getDeferralQueue #-} getDeferralQueue = asksEventEnv eventEnvRootClears {-# INLINE scheduleRootClear #-} -scheduleRootClear :: Defer SomeRootClear m => IORef (DMap k Identity) -> m () -scheduleRootClear r = defer $ SomeRootClear r +scheduleRootClear :: Defer (Some RootClear) m => IORef (DMap k Identity) -> m () +scheduleRootClear r = defer $ Some.This $ RootClear r instance HasSpiderTimeline x => Defer (SomeResetCoincidence x) (EventM x) where {-# INLINE getDeferralQueue #-} @@ -951,7 +951,7 @@ data BehaviorSubscribed x a = forall p. BehaviorSubscribedHold (Hold x p) | BehaviorSubscribedPull (PullSubscribed x a) -data SomeBehaviorSubscribed x = forall a. SomeBehaviorSubscribed (BehaviorSubscribed x a) +newtype SomeBehaviorSubscribed x = SomeBehaviorSubscribed (Some (BehaviorSubscribed x)) --type role PullSubscribed representational data PullSubscribed x a @@ -1259,11 +1259,11 @@ scheduleMerge' initialHeight heightRef a = scheduleMerge initialHeight $ do GT -> scheduleMerge' height heightRef a -- The height has been increased (by a coincidence event; TODO: is this the only way?) EQ -> a -data SomeClear = forall a. SomeClear {-# UNPACK #-} !(IORef (Maybe a)) +newtype Clear a = Clear (IORef (Maybe a)) -data SomeIntClear = forall a. SomeIntClear {-# UNPACK #-} !(IORef (IntMap a)) +newtype IntClear a = IntClear (IORef (IntMap a)) -data SomeRootClear = forall k. SomeRootClear {-# UNPACK #-} !(IORef (DMap k Identity)) +newtype RootClear k = RootClear (IORef (DMap k Identity)) data SomeAssignment x = forall a. SomeAssignment {-# UNPACK #-} !(IORef a) {-# UNPACK #-} !(IORef [Weak (Invalidator x)]) a @@ -2096,11 +2096,11 @@ runFrame a = SpiderHost $ do return result result <- runEventM go toClear <- readIORef $ eventEnvClears env - forM_ toClear $ \(SomeClear ref) -> {-# SCC "clear" #-} writeIORef ref Nothing + forM_ toClear $ \(Some.This (Clear ref)) -> {-# SCC "clear" #-} writeIORef ref Nothing toClearInt <- readIORef $ eventEnvIntClears env - forM_ toClearInt $ \(SomeIntClear ref) -> {-# SCC "intClear" #-} writeIORef ref $! IntMap.empty + forM_ toClearInt $ \(Some.This (IntClear ref)) -> {-# SCC "intClear" #-} writeIORef ref $! IntMap.empty toClearRoot <- readIORef $ eventEnvRootClears env - forM_ toClearRoot $ \(SomeRootClear ref) -> {-# SCC "rootClear" #-} writeIORef ref $! DMap.empty + forM_ toClearRoot $ \(Some.This (RootClear ref)) -> {-# SCC "rootClear" #-} writeIORef ref $! DMap.empty toAssign <- readIORef $ eventEnvAssignments env toReconnectRef <- newIORef [] coincidenceInfos <- readIORef $ eventEnvResetCoincidences env From ed1b631d93e8423c344f356e2dbcb51852eae17f Mon Sep 17 00:00:00 2001 From: Alexandre Esteves Date: Thu, 9 May 2019 02:04:35 +0100 Subject: [PATCH 142/241] Replace hackage link with badge --- README.md | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/README.md b/README.md index 8bc1c098..9f736c84 100644 --- a/README.md +++ b/README.md @@ -1,4 +1,7 @@ ## [Reflex](https://reflex-frp.org/) + +[![Hackage](https://img.shields.io/hackage/v/reflex.svg)](http://hackage.haskell.org/package/reflex) + ### Practical Functional Reactive Programming Reflex is a fully-deterministic, higher-order Functional Reactive Programming (FRP) interface and an engine that efficiently implements that interface. @@ -14,8 +17,6 @@ A summary of Reflex functions is available in the [quick reference](Quickref.md) [/r/reflexfrp](https://www.reddit.com/r/reflexfrp) -[hackage](https://hackage.haskell.org/package/reflex) - [irc.freenode.net #reflex-frp](http://webchat.freenode.net?channels=%23reflex-frp&uio=d4) ### Hacking From e9c1aa1c473b3aee47b218e5cac4cc2286407c2c Mon Sep 17 00:00:00 2001 From: Jack Kelly Date: Thu, 30 May 2019 16:01:38 +1000 Subject: [PATCH 143/241] fan: Rewrite haddock --- src/Reflex/Class.hs | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/src/Reflex/Class.hs b/src/Reflex/Class.hs index 9c8f4149..59e087c3 100644 --- a/src/Reflex/Class.hs +++ b/src/Reflex/Class.hs @@ -257,10 +257,10 @@ class ( MonadHold t (PushM t) -- least one input event is occurring, and will contain all of the input keys -- that are occurring simultaneously merge :: GCompare k => DMap k (Event t) -> Event t (DMap k Identity) --TODO: Generalize to get rid of DMap use --TODO: Provide a type-level guarantee that the result is not empty - -- | Efficiently fan-out an event to many destinations. This function should - -- be partially applied, and then the result applied repeatedly to create - -- child events - fan :: GCompare k => Event t (DMap k Identity) -> EventSelector t k --TODO: Can we help enforce the partial application discipline here? The combinator is worthless without it + -- | Efficiently fan-out an event to many destinations. You should save the + -- result in a @let@-binding, and then repeatedly 'select' on the result to + -- create child events + fan :: GCompare k => Event t (DMap k Identity) -> EventSelector t k -- | Create an 'Event' that will occur whenever the currently-selected input -- 'Event' occurs switch :: Behavior t (Event t a) -> Event t a From 244c2a8e41aa019e8af38fd41e3ae82fac664a9e Mon Sep 17 00:00:00 2001 From: Jack Kelly Date: Sun, 9 Jun 2019 11:11:04 +1000 Subject: [PATCH 144/241] Clean up hlints --- src/Data/Functor/Misc.hs | 1 - src/Reflex/Adjustable/Class.hs | 1 - src/Reflex/BehaviorWriter/Class.hs | 1 - src/Reflex/Class.hs | 1 - src/Reflex/DynamicWriter/Class.hs | 2 -- src/Reflex/EventWriter/Class.hs | 1 - src/Reflex/Host/Class.hs | 1 - src/Reflex/NotReady/Class.hs | 1 - src/Reflex/PerformEvent/Base.hs | 2 +- src/Reflex/PerformEvent/Class.hs | 1 - src/Reflex/PostBuild/Class.hs | 1 - src/Reflex/Query/Base.hs | 1 - src/Reflex/Query/Class.hs | 1 - src/Reflex/Requester/Class.hs | 1 - src/Reflex/Spider/Internal.hs | 1 - src/Reflex/TriggerEvent/Class.hs | 1 - 16 files changed, 1 insertion(+), 17 deletions(-) diff --git a/src/Data/Functor/Misc.hs b/src/Data/Functor/Misc.hs index 7afa0289..34494261 100644 --- a/src/Data/Functor/Misc.hs +++ b/src/Data/Functor/Misc.hs @@ -4,7 +4,6 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} -{-# LANGUAGE KindSignatures #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE PatternSynonyms #-} diff --git a/src/Reflex/Adjustable/Class.hs b/src/Reflex/Adjustable/Class.hs index d5b872ab..5d591a31 100644 --- a/src/Reflex/Adjustable/Class.hs +++ b/src/Reflex/Adjustable/Class.hs @@ -3,7 +3,6 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE LambdaCase #-} -{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} diff --git a/src/Reflex/BehaviorWriter/Class.hs b/src/Reflex/BehaviorWriter/Class.hs index 78320634..32d681cc 100644 --- a/src/Reflex/BehaviorWriter/Class.hs +++ b/src/Reflex/BehaviorWriter/Class.hs @@ -5,7 +5,6 @@ Description: This module defines the 'MonadBehaviorWriter' class {-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FunctionalDependencies #-} -{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE UndecidableInstances #-} #ifdef USE_REFLEX_OPTIMIZER {-# OPTIONS_GHC -fplugin=Reflex.Optimizer #-} diff --git a/src/Reflex/Class.hs b/src/Reflex/Class.hs index 59e087c3..84bcc454 100644 --- a/src/Reflex/Class.hs +++ b/src/Reflex/Class.hs @@ -7,7 +7,6 @@ {-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE LambdaCase #-} -{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE NoMonomorphismRestriction #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE RankNTypes #-} diff --git a/src/Reflex/DynamicWriter/Class.hs b/src/Reflex/DynamicWriter/Class.hs index 34767c14..1df9cf61 100644 --- a/src/Reflex/DynamicWriter/Class.hs +++ b/src/Reflex/DynamicWriter/Class.hs @@ -3,7 +3,6 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FunctionalDependencies #-} -{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE UndecidableInstances #-} #ifdef USE_REFLEX_OPTIMIZER {-# OPTIONS_GHC -fplugin=Reflex.Optimizer #-} @@ -27,4 +26,3 @@ class (Monad m, Monoid w) => DynamicWriter t w m | m -> t w where instance DynamicWriter t w m => DynamicWriter t w (ReaderT r m) where tellDyn = lift . tellDyn - diff --git a/src/Reflex/EventWriter/Class.hs b/src/Reflex/EventWriter/Class.hs index 14460380..41aadd35 100644 --- a/src/Reflex/EventWriter/Class.hs +++ b/src/Reflex/EventWriter/Class.hs @@ -2,7 +2,6 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FunctionalDependencies #-} -{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE UndecidableInstances #-} #ifdef USE_REFLEX_OPTIMIZER {-# OPTIONS_GHC -fplugin=Reflex.Optimizer #-} diff --git a/src/Reflex/Host/Class.hs b/src/Reflex/Host/Class.hs index 398d2828..96ca065c 100644 --- a/src/Reflex/Host/Class.hs +++ b/src/Reflex/Host/Class.hs @@ -4,7 +4,6 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE GADTs #-} -{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE RoleAnnotations #-} {-# LANGUAGE ScopedTypeVariables #-} diff --git a/src/Reflex/NotReady/Class.hs b/src/Reflex/NotReady/Class.hs index 7dfabeef..7d1232bd 100644 --- a/src/Reflex/NotReady/Class.hs +++ b/src/Reflex/NotReady/Class.hs @@ -3,7 +3,6 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FunctionalDependencies #-} -{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} #ifdef USE_REFLEX_OPTIMIZER diff --git a/src/Reflex/PerformEvent/Base.hs b/src/Reflex/PerformEvent/Base.hs index 59d66586..32f7fa3b 100644 --- a/src/Reflex/PerformEvent/Base.hs +++ b/src/Reflex/PerformEvent/Base.hs @@ -141,7 +141,7 @@ hostPerformEventT a = do case mToPerform of Nothing -> return [result'] Just toPerform -> do - responses <- runHostFrame $ traverseRequesterData (\v -> Identity <$> v) toPerform + responses <- runHostFrame $ traverseRequesterData (fmap Identity) toPerform mrt <- readRef responseTrigger let followupEventTriggers = case mrt of Just rt -> [rt :=> Identity responses] diff --git a/src/Reflex/PerformEvent/Class.hs b/src/Reflex/PerformEvent/Class.hs index dd1ae292..e6d1c402 100644 --- a/src/Reflex/PerformEvent/Class.hs +++ b/src/Reflex/PerformEvent/Class.hs @@ -5,7 +5,6 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FunctionalDependencies #-} -{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} diff --git a/src/Reflex/PostBuild/Class.hs b/src/Reflex/PostBuild/Class.hs index a80e59f3..8b65a9d0 100644 --- a/src/Reflex/PostBuild/Class.hs +++ b/src/Reflex/PostBuild/Class.hs @@ -4,7 +4,6 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FunctionalDependencies #-} -{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} diff --git a/src/Reflex/Query/Base.hs b/src/Reflex/Query/Base.hs index a224c6f0..be780fcb 100644 --- a/src/Reflex/Query/Base.hs +++ b/src/Reflex/Query/Base.hs @@ -1,7 +1,6 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE InstanceSigs #-} -{-# LANGUAGE KindSignatures #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE RankNTypes #-} diff --git a/src/Reflex/Query/Class.hs b/src/Reflex/Query/Class.hs index 0982c3a0..bec4ace5 100644 --- a/src/Reflex/Query/Class.hs +++ b/src/Reflex/Query/Class.hs @@ -3,7 +3,6 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} -- | diff --git a/src/Reflex/Requester/Class.hs b/src/Reflex/Requester/Class.hs index d23789cc..db4ddb99 100644 --- a/src/Reflex/Requester/Class.hs +++ b/src/Reflex/Requester/Class.hs @@ -6,7 +6,6 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FunctionalDependencies #-} -{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE RecursiveDo #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} diff --git a/src/Reflex/Spider/Internal.hs b/src/Reflex/Spider/Internal.hs index fbad7574..93e50b15 100644 --- a/src/Reflex/Spider/Internal.hs +++ b/src/Reflex/Spider/Internal.hs @@ -9,7 +9,6 @@ {-# LANGUAGE GADTs #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE LambdaCase #-} -{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE MultiWayIf #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE RoleAnnotations #-} diff --git a/src/Reflex/TriggerEvent/Class.hs b/src/Reflex/TriggerEvent/Class.hs index b9740b25..58eaec7d 100644 --- a/src/Reflex/TriggerEvent/Class.hs +++ b/src/Reflex/TriggerEvent/Class.hs @@ -2,7 +2,6 @@ -- new 'Event's that can be triggered from 'IO'. {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FunctionalDependencies #-} -{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE UndecidableInstances #-} module Reflex.TriggerEvent.Class ( TriggerEvent (..) From 089d4e164d295f839e7595337ca85f08648d3c8b Mon Sep 17 00:00:00 2001 From: Alexandre Esteves Date: Wed, 12 Jun 2019 13:20:20 +0100 Subject: [PATCH 145/241] Remove hlint filepath exceptions --- test/hlint.hs | 7 ------- 1 file changed, 7 deletions(-) diff --git a/test/hlint.hs b/test/hlint.hs index f8b80def..ac03ad47 100644 --- a/test/hlint.hs +++ b/test/hlint.hs @@ -29,16 +29,9 @@ main = do ] matchFile = and <$> sequence [ extension ==? ".hs" - , let notElem' = liftOp notElem - in filePath `notElem'` filePathExceptions pwd ] files <- find recurseInto matchFile (pwd "src") --TODO: Someday fix all hints in tests, etc. ideas <- fmap concat $ forM files $ \f -> do putStr $ "linting file " ++ drop (length pwd + 1) f ++ "... " runHlint f if null ideas then exitSuccess else exitFailure - -filePathExceptions :: FilePath -> [FilePath] -filePathExceptions pwd = map (pwd ) $ - [ "src/Data/AppendMap.hs" -- parse error when hlint runs - ] From 9bc1c19d34d3afc8a72e7e0ce90dc2521a8808ae Mon Sep 17 00:00:00 2001 From: Ali Abrar Date: Thu, 13 Jun 2019 23:24:32 -0400 Subject: [PATCH 146/241] Bump dependent-sum to latest version There are some constructor changes and deprecations that this bump introduces, but reflex-dom has started to require the newer version as well. --- default.nix | 2 +- reflex.cabal | 6 +++--- 2 files changed, 4 insertions(+), 4 deletions(-) diff --git a/default.nix b/default.nix index 8d9feef4..0305c6c1 100644 --- a/default.nix +++ b/default.nix @@ -11,7 +11,7 @@ }: mkDerivation { pname = "reflex"; - version = "0.6.1"; + version = "0.6.1.1"; src = builtins.filterSource (path: type: !(builtins.elem (baseNameOf path) [ ".git" "dist" ])) ./.; libraryHaskellDepends = [ base bifunctors containers dependent-map dependent-sum diff --git a/reflex.cabal b/reflex.cabal index 2f0cff20..b0423e2a 100644 --- a/reflex.cabal +++ b/reflex.cabal @@ -1,5 +1,5 @@ Name: reflex -Version: 0.6.1 +Version: 0.6.1.1 Synopsis: Higher-order Functional Reactive Programming Description: Reflex is a high-performance, deterministic, higher-order Functional Reactive Programming system License: BSD3 @@ -133,7 +133,7 @@ library if flag(use-template-haskell) cpp-options: -DUSE_TEMPLATE_HASKELL build-depends: - dependent-sum >= 0.3 && < 0.5, + dependent-sum >= 0.5 && < 0.6, haskell-src-exts >= 1.16 && < 1.22, haskell-src-meta >= 0.6 && < 0.9, template-haskell >= 2.9 && < 2.15 @@ -142,7 +142,7 @@ library other-extensions: TemplateHaskell else build-depends: - dependent-sum == 0.4.* + dependent-sum == 0.5.* if flag(fast-weak) && impl(ghcjs) cpp-options: -DGHCJS_FAST_WEAK From 1024703631f30d6a25581666d93cb379c0dac3b3 Mon Sep 17 00:00:00 2001 From: Ali Abrar Date: Fri, 14 Jun 2019 13:09:41 -0400 Subject: [PATCH 147/241] Fix deprecation warnings related to updated Data.Some --- reflex.cabal | 2 +- src/Data/Functor/Misc.hs | 5 ++-- src/Reflex/Class.hs | 7 +++--- src/Reflex/Patch/DMapWithMove.hs | 7 +++--- src/Reflex/Query/Base.hs | 11 ++++----- src/Reflex/Requester/Base.hs | 5 ++-- src/Reflex/Spider/Internal.hs | 39 ++++++++++++++++---------------- 7 files changed, 35 insertions(+), 41 deletions(-) diff --git a/reflex.cabal b/reflex.cabal index 64212969..0ae6ca26 100644 --- a/reflex.cabal +++ b/reflex.cabal @@ -47,7 +47,7 @@ library constraints-extras >= 0.2, containers >= 0.5 && < 0.7, data-default >= 0.5 && < 0.8, - dependent-map >= 0.2.4 && < 0.3, + dependent-map >= 0.3 && < 0.4, exception-transformers == 0.4.*, lens >= 4.7 && < 5, monad-control >= 1.0.1 && < 1.1, diff --git a/src/Data/Functor/Misc.hs b/src/Data/Functor/Misc.hs index 804ce7bc..0f21c808 100644 --- a/src/Data/Functor/Misc.hs +++ b/src/Data/Functor/Misc.hs @@ -52,8 +52,7 @@ import Data.IntMap (IntMap) import qualified Data.IntMap as IntMap import Data.Map (Map) import qualified Data.Map as Map -import Data.Some (Some) -import qualified Data.Some as Some +import Data.Some (Some(Some)) import Data.These import Data.Typeable hiding (Refl) @@ -121,7 +120,7 @@ intMapWithFunctorToDMap = DMap.fromDistinctAscList . map (\(k, v) -> Const2 k := -- | Convert a 'DMap' to a regular 'Map' by forgetting the types associated with -- the keys, using a function to remove the wrapping 'Functor' weakenDMapWith :: (forall a. v a -> v') -> DMap k v -> Map (Some k) v' -weakenDMapWith f = Map.fromDistinctAscList . map (\(k :=> v) -> (Some.This k, f v)) . DMap.toAscList +weakenDMapWith f = Map.fromDistinctAscList . map (\(k :=> v) -> (Some k, f v)) . DMap.toAscList -------------------------------------------------------------------------------- -- WrapArg diff --git a/src/Reflex/Class.hs b/src/Reflex/Class.hs index 59e087c3..60d61366 100644 --- a/src/Reflex/Class.hs +++ b/src/Reflex/Class.hs @@ -193,8 +193,7 @@ import qualified Data.IntMap.Strict as IntMap import Data.List.NonEmpty (NonEmpty (..)) import Data.Map (Map) import Data.Semigroup (Semigroup, sconcat, stimes, (<>)) -import Data.Some (Some) -import qualified Data.Some as Some +import Data.Some (Some(Some)) import Data.String import Data.These import Data.Type.Coercion @@ -1155,9 +1154,9 @@ factorEvent -> Event t (DSum k v) -> m (Event t (v a), Event t (DSum k (Product v (Compose (Event t) v)))) factorEvent k0 kv' = do - key :: Behavior t (Some k) <- hold (Some.This k0) $ fmapCheap (\(k :=> _) -> Some.This k) kv' + key :: Behavior t (Some k) <- hold (Some k0) $ fmapCheap (\(k :=> _) -> Some k) kv' let update = flip push kv' $ \(newKey :=> newVal) -> sample key >>= \case - Some.This oldKey -> case newKey `geq` oldKey of + Some oldKey -> case newKey `geq` oldKey of Just Refl -> return Nothing Nothing -> do newInner <- filterEventKey newKey kv' diff --git a/src/Reflex/Patch/DMapWithMove.hs b/src/Reflex/Patch/DMapWithMove.hs index 3fe7c4f8..4fb9216c 100644 --- a/src/Reflex/Patch/DMapWithMove.hs +++ b/src/Reflex/Patch/DMapWithMove.hs @@ -30,8 +30,7 @@ import Data.GADT.Show (GShow, gshow) import qualified Data.Map as Map import Data.Maybe import Data.Semigroup (Semigroup (..), (<>)) -import Data.Some (Some) -import qualified Data.Some as Some +import Data.Some (Some(Some)) import Data.These -- | Like 'PatchMapWithMove', but for 'DMap'. Each key carries a 'NodeInfo' which describes how it will be changed by the patch and connects move sources and @@ -311,8 +310,8 @@ weakenPatchDMapWithMoveWith f (PatchDMapWithMove p) = PatchMapWithMove $ weakenD { MapWithMove._nodeInfo_from = case _nodeInfo_from ni of From_Insert v -> MapWithMove.From_Insert $ f v From_Delete -> MapWithMove.From_Delete - From_Move k -> MapWithMove.From_Move $ Some.This k - , MapWithMove._nodeInfo_to = Some.This <$> getComposeMaybe (_nodeInfo_to ni) + From_Move k -> MapWithMove.From_Move $ Some k + , MapWithMove._nodeInfo_to = Some <$> getComposeMaybe (_nodeInfo_to ni) } -- |"Weaken" a @'PatchDMapWithMove' (Const2 k a) v@ to a @'PatchMapWithMove' k v'@. Weaken is in scare quotes because the 'Const2' has already disabled any diff --git a/src/Reflex/Query/Base.hs b/src/Reflex/Query/Base.hs index a224c6f0..4b54ef33 100644 --- a/src/Reflex/Query/Base.hs +++ b/src/Reflex/Query/Base.hs @@ -38,8 +38,7 @@ import Data.Map (Map) import qualified Data.Map as Map import Data.Monoid ((<>)) import qualified Data.Semigroup as S -import Data.Some (Some) -import qualified Data.Some as Some +import Data.Some (Some(Some)) import Data.These import Reflex.Class @@ -145,10 +144,10 @@ instance (Reflex t, MonadFix m, Group q, Additive q, Query q, Eq q, MonadHold t liftedResult' = fforCheap result' $ \(PatchDMap p) -> PatchDMap $ mapKeyValuePairsMonotonic (\(k :=> ComposeMaybe mr) -> k :=> ComposeMaybe (fmap (getQueryTLoweredResultValue . getCompose) mr)) p liftedBs0 :: Map (Some k) [Behavior t q] - liftedBs0 = Map.fromDistinctAscList $ (\(k :=> Compose r) -> (Some.This k, getQueryTLoweredResultWritten r)) <$> DMap.toList result0 + liftedBs0 = Map.fromDistinctAscList $ (\(k :=> Compose r) -> (Some k, getQueryTLoweredResultWritten r)) <$> DMap.toList result0 liftedBs' :: Event t (PatchMap (Some k) [Behavior t q]) liftedBs' = fforCheap result' $ \(PatchDMap p) -> PatchMap $ - Map.fromDistinctAscList $ (\(k :=> ComposeMaybe mr) -> (Some.This k, fmap (getQueryTLoweredResultWritten . getCompose) mr)) <$> DMap.toList p + Map.fromDistinctAscList $ (\(k :=> ComposeMaybe mr) -> (Some k, fmap (getQueryTLoweredResultWritten . getCompose) mr)) <$> DMap.toList p sampleBs :: forall m'. MonadSample t m' => [Behavior t q] -> m' q sampleBs = foldlM (\b a -> (b <>) <$> sample a) mempty accumBehaviors :: forall m'. MonadHold t m' @@ -189,10 +188,10 @@ instance (Reflex t, MonadFix m, Group q, Additive q, Query q, Eq q, MonadHold t let liftedResult0 = mapKeyValuePairsMonotonic (\(k :=> Compose r) -> k :=> getQueryTLoweredResultValue r) result0 liftedResult' = fforCheap result' $ mapPatchDMapWithMove (getQueryTLoweredResultValue . getCompose) liftedBs0 :: Map (Some k) [Behavior t q] - liftedBs0 = Map.fromDistinctAscList $ (\(k :=> Compose r) -> (Some.This k, getQueryTLoweredResultWritten r)) <$> DMap.toList result0 + liftedBs0 = Map.fromDistinctAscList $ (\(k :=> Compose r) -> (Some k, getQueryTLoweredResultWritten r)) <$> DMap.toList result0 liftedBs' :: Event t (PatchMapWithMove (Some k) [Behavior t q]) liftedBs' = fforCheap result' $ weakenPatchDMapWithMoveWith (getQueryTLoweredResultWritten . getCompose) {- \(PatchDMap p) -> PatchMapWithMove $ - Map.fromDistinctAscList $ (\(k :=> mr) -> (Some.This k, fmap (fmap (getQueryTLoweredResultWritten . getCompose)) mr)) <$> DMap.toList p -} + Map.fromDistinctAscList $ (\(k :=> mr) -> (Some k, fmap (fmap (getQueryTLoweredResultWritten . getCompose)) mr)) <$> DMap.toList p -} sampleBs :: forall m'. MonadSample t m' => [Behavior t q] -> m' q sampleBs = foldlM (\b a -> (b <>) <$> sample a) mempty accumBehaviors' :: forall m'. MonadHold t m' diff --git a/src/Reflex/Requester/Base.hs b/src/Reflex/Requester/Base.hs index 9dc76a30..95440eb2 100644 --- a/src/Reflex/Requester/Base.hs +++ b/src/Reflex/Requester/Base.hs @@ -66,8 +66,7 @@ import qualified Data.Map as Map import Data.Monoid ((<>)) import Data.Proxy import qualified Data.Semigroup as S -import Data.Some (Some) -import qualified Data.Some as Some +import Data.Some (Some(Some)) import Data.Type.Equality import Data.Unique.Tag @@ -441,7 +440,7 @@ traverseDMapWithKeyWithAdjustRequesterTWith base mapPatch weakenPatchWith patchN pack = Entry f' :: forall a. k a -> Compose ((,) Int) v a -> m (Compose ((,) (Event t (IntMap (RequesterData request)))) v' a) f' k (Compose (n, v)) = do - (result, myRequests) <- runRequesterT (f k v) $ mapMaybeCheap (IntMap.lookup n) $ select responses (Const2 (Some.This k)) + (result, myRequests) <- runRequesterT (f k v) $ mapMaybeCheap (IntMap.lookup n) $ select responses (Const2 (Some k)) return $ Compose (fmapCheap (IntMap.singleton n) myRequests, result) ndm' <- numberOccurrencesFrom 1 dm' (children0, children') <- base f' (DMap.map (\v -> Compose (0, v)) dm0) $ fmap (\(n, dm) -> mapPatch (\v -> Compose (n, v)) dm) ndm' diff --git a/src/Reflex/Spider/Internal.hs b/src/Reflex/Spider/Internal.hs index fbad7574..50cd479a 100644 --- a/src/Reflex/Spider/Internal.hs +++ b/src/Reflex/Spider/Internal.hs @@ -74,8 +74,7 @@ import Data.Tree (Forest, Tree (..), drawForest) import Data.FastWeakBag (FastWeakBag) import qualified Data.FastWeakBag as FastWeakBag import Data.Reflection -import Data.Some (Some) -import qualified Data.Some as Some +import Data.Some (Some(Some)) import Data.Type.Coercion import Data.WeakBag (WeakBag, WeakBagTicket, _weakBag_children) import qualified Data.WeakBag as WeakBag @@ -582,7 +581,7 @@ eventSubscribedFan !subscribed = EventSubscribed { eventSubscribedHeightRef = eventSubscribedHeightRef $ _eventSubscription_subscribed $ fanSubscribedParent subscribed , eventSubscribedRetained = toAny subscribed #ifdef DEBUG_CYCLES - , eventSubscribedGetParents = return [Some.This $ _eventSubscription_subscribed $ fanSubscribedParent subscribed] + , eventSubscribedGetParents = return [Some $ _eventSubscription_subscribed $ fanSubscribedParent subscribed] , eventSubscribedHasOwnHeightRef = False , eventSubscribedWhoCreated = whoCreatedIORef $ fanSubscribedCachedSubscribed subscribed #endif @@ -595,7 +594,7 @@ eventSubscribedSwitch !subscribed = EventSubscribed #ifdef DEBUG_CYCLES , eventSubscribedGetParents = do s <- readIORef $ switchSubscribedCurrentParent subscribed - return [Some.This $ _eventSubscription_subscribed s] + return [Some $ _eventSubscription_subscribed s] , eventSubscribedHasOwnHeightRef = True , eventSubscribedWhoCreated = whoCreatedIORef $ switchSubscribedCachedSubscribed subscribed #endif @@ -608,8 +607,8 @@ eventSubscribedCoincidence !subscribed = EventSubscribed #ifdef DEBUG_CYCLES , eventSubscribedGetParents = do innerSubscription <- readIORef $ coincidenceSubscribedInnerParent subscribed - let outerParent = Some.This $ _eventSubscription_subscribed $ coincidenceSubscribedOuterParent subscribed - innerParents = maybeToList $ fmap Some.This innerSubscription + let outerParent = Some $ _eventSubscription_subscribed $ coincidenceSubscribedOuterParent subscribed + innerParents = maybeToList $ fmap Some innerSubscription return $ outerParent : innerParents , eventSubscribedHasOwnHeightRef = True , eventSubscribedWhoCreated = whoCreatedIORef $ coincidenceSubscribedCachedSubscribed subscribed @@ -625,13 +624,13 @@ whoCreatedEventSubscribed = eventSubscribedWhoCreated walkInvalidHeightParents :: EventSubscribed x -> IO [Some (EventSubscribed x)] walkInvalidHeightParents s0 = do - subscribers <- flip execStateT mempty $ ($ Some.This s0) $ fix $ \loop (Some.This s) -> do + subscribers <- flip execStateT mempty $ ($ Some s0) $ fix $ \loop (Some s) -> do h <- liftIO $ readIORef $ eventSubscribedHeightRef s when (h == invalidHeight) $ do when (eventSubscribedHasOwnHeightRef s) $ liftIO $ writeIORef (eventSubscribedHeightRef s) $! invalidHeightBeingTraversed - modify (Some.This s :) + modify (Some s :) mapM_ loop =<< liftIO (eventSubscribedGetParents s) - forM_ subscribers $ \(Some.This s) -> writeIORef (eventSubscribedHeightRef s) $! invalidHeight + forM_ subscribers $ \(Some s) -> writeIORef (eventSubscribedHeightRef s) $! invalidHeight return subscribers #endif @@ -659,7 +658,7 @@ behaviorPull !p = Behavior $ do val <- liftIO $ readIORef $ pullValue p case val of Just subscribed -> do - askParentsRef >>= mapM_ (\r -> liftIO $ modifyIORef' r (SomeBehaviorSubscribed (Some.This (BehaviorSubscribedPull subscribed)) :)) + askParentsRef >>= mapM_ (\r -> liftIO $ modifyIORef' r (SomeBehaviorSubscribed (Some (BehaviorSubscribedPull subscribed)) :)) askInvalidator >>= mapM_ (\wi -> liftIO $ modifyIORef' (pullSubscribedInvalidators subscribed) (wi:)) liftIO $ touch $ pullSubscribedOwnInvalidator subscribed return $ pullSubscribedValue subscribed @@ -678,7 +677,7 @@ behaviorPull !p = Behavior $ do , pullSubscribedParents = parents } liftIO $ writeIORef (pullValue p) $ Just subscribed - askParentsRef >>= mapM_ (\r -> liftIO $ modifyIORef' r (SomeBehaviorSubscribed (Some.This (BehaviorSubscribedPull subscribed)) :)) + askParentsRef >>= mapM_ (\r -> liftIO $ modifyIORef' r (SomeBehaviorSubscribed (Some (BehaviorSubscribedPull subscribed)) :)) return a behaviorDyn :: Patch p => Dyn x p -> Behavior x (PatchTarget p) @@ -689,7 +688,7 @@ readHoldTracked :: Hold x p -> BehaviorM x (PatchTarget p) readHoldTracked h = do result <- liftIO $ readIORef $ holdValue h askInvalidator >>= mapM_ (\wi -> liftIO $ modifyIORef' (holdInvalidators h) (wi:)) - askParentsRef >>= mapM_ (\r -> liftIO $ modifyIORef' r (SomeBehaviorSubscribed (Some.This (BehaviorSubscribedHold h)) :)) + askParentsRef >>= mapM_ (\r -> liftIO $ modifyIORef' r (SomeBehaviorSubscribed (Some (BehaviorSubscribedHold h)) :)) liftIO $ touch h -- Otherwise, if this gets inlined enough, the hold's parent reference may get collected return result @@ -862,7 +861,7 @@ instance HasSpiderTimeline x => Defer (Some Clear) (EventM x) where {-# INLINE scheduleClear #-} scheduleClear :: Defer (Some Clear) m => IORef (Maybe a) -> m () -scheduleClear r = defer $ Some.This $ Clear r +scheduleClear r = defer $ Some $ Clear r instance HasSpiderTimeline x => Defer (Some IntClear) (EventM x) where {-# INLINE getDeferralQueue #-} @@ -870,7 +869,7 @@ instance HasSpiderTimeline x => Defer (Some IntClear) (EventM x) where {-# INLINE scheduleIntClear #-} scheduleIntClear :: Defer (Some IntClear) m => IORef (IntMap a) -> m () -scheduleIntClear r = defer $ Some.This $ IntClear r +scheduleIntClear r = defer $ Some $ IntClear r instance HasSpiderTimeline x => Defer (Some RootClear) (EventM x) where {-# INLINE getDeferralQueue #-} @@ -878,7 +877,7 @@ instance HasSpiderTimeline x => Defer (Some RootClear) (EventM x) where {-# INLINE scheduleRootClear #-} scheduleRootClear :: Defer (Some RootClear) m => IORef (DMap k Identity) -> m () -scheduleRootClear r = defer $ Some.This $ RootClear r +scheduleRootClear r = defer $ Some $ RootClear r instance HasSpiderTimeline x => Defer (SomeResetCoincidence x) (EventM x) where {-# INLINE getDeferralQueue #-} @@ -1853,7 +1852,7 @@ mergeSubscriber m getKey = Subscriber else liftIO $ do #ifdef DEBUG_CYCLES nodesInvolvedInCycle <- walkInvalidHeightParents $ eventSubscribedMerge subscribed - stacks <- forM nodesInvolvedInCycle $ \(Some.This es) -> whoCreatedEventSubscribed es + stacks <- forM nodesInvolvedInCycle $ \(Some es) -> whoCreatedEventSubscribed es let cycleInfo = ":\n" <> drawForest (listsToForest stacks) #else let cycleInfo = "" @@ -2096,11 +2095,11 @@ runFrame a = SpiderHost $ do return result result <- runEventM go toClear <- readIORef $ eventEnvClears env - forM_ toClear $ \(Some.This (Clear ref)) -> {-# SCC "clear" #-} writeIORef ref Nothing + forM_ toClear $ \(Some (Clear ref)) -> {-# SCC "clear" #-} writeIORef ref Nothing toClearInt <- readIORef $ eventEnvIntClears env - forM_ toClearInt $ \(Some.This (IntClear ref)) -> {-# SCC "intClear" #-} writeIORef ref $! IntMap.empty + forM_ toClearInt $ \(Some (IntClear ref)) -> {-# SCC "intClear" #-} writeIORef ref $! IntMap.empty toClearRoot <- readIORef $ eventEnvRootClears env - forM_ toClearRoot $ \(Some.This (RootClear ref)) -> {-# SCC "rootClear" #-} writeIORef ref $! DMap.empty + forM_ toClearRoot $ \(Some (RootClear ref)) -> {-# SCC "rootClear" #-} writeIORef ref $! DMap.empty toAssign <- readIORef $ eventEnvAssignments env toReconnectRef <- newIORef [] coincidenceInfos <- readIORef $ eventEnvResetCoincidences env @@ -2460,7 +2459,7 @@ unsafeNewSpiderTimelineEnv = do -- | Create a new SpiderTimelineEnv newSpiderTimeline :: IO (Some SpiderTimelineEnv) -newSpiderTimeline = withSpiderTimeline (pure . Some.This) +newSpiderTimeline = withSpiderTimeline (pure . Some) data LocalSpiderTimeline x s From bccbe428bfd7b888f629aed955ef1f35e39ef872 Mon Sep 17 00:00:00 2001 From: Ali Abrar Date: Fri, 14 Jun 2019 17:50:07 -0400 Subject: [PATCH 148/241] Drop *Tag classes --- ChangeLog.md | 5 +++-- default.nix | 2 +- reflex.cabal | 2 +- 3 files changed, 5 insertions(+), 4 deletions(-) diff --git a/ChangeLog.md b/ChangeLog.md index 18f064bd..7bcecf87 100644 --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,8 +1,9 @@ # Revision history for reflex -## Unreleased +## 0.6.2.0 -* Fix `holdDyn` so that it is lazy in its event argument +* Stop using the now-deprecated `*Tag` classes (e.g., `ShowTag`). +* Fix `holdDyn` so that it is lazy in its event argument. ## 0.6.1.0 diff --git a/default.nix b/default.nix index 0305c6c1..eab1e197 100644 --- a/default.nix +++ b/default.nix @@ -11,7 +11,7 @@ }: mkDerivation { pname = "reflex"; - version = "0.6.1.1"; + version = "0.6.2.0"; src = builtins.filterSource (path: type: !(builtins.elem (baseNameOf path) [ ".git" "dist" ])) ./.; libraryHaskellDepends = [ base bifunctors containers dependent-map dependent-sum diff --git a/reflex.cabal b/reflex.cabal index 0ae6ca26..40ad9ea5 100644 --- a/reflex.cabal +++ b/reflex.cabal @@ -1,5 +1,5 @@ Name: reflex -Version: 0.6.1.1 +Version: 0.6.2.0 Synopsis: Higher-order Functional Reactive Programming Description: Reflex is a high-performance, deterministic, higher-order Functional Reactive Programming system License: BSD3 From 8d8ceecd548f3d4f6e0b8db00a57659511d241a5 Mon Sep 17 00:00:00 2001 From: David Feuer Date: Mon, 8 Jul 2019 00:02:55 -0400 Subject: [PATCH 149/241] Generalize merge --- ChangeLog.md | 4 ++ reflex.cabal | 1 + src/Reflex/Class.hs | 34 ++++++++- src/Reflex/Profiled.hs | 14 ++-- src/Reflex/Pure.hs | 26 ++++--- src/Reflex/Spider/Internal.hs | 131 ++++++++++++++++++++-------------- test/GC.hs | 3 +- 7 files changed, 141 insertions(+), 72 deletions(-) diff --git a/ChangeLog.md b/ChangeLog.md index 18f064bd..2293af98 100644 --- a/ChangeLog.md +++ b/ChangeLog.md @@ -3,6 +3,10 @@ ## Unreleased * Fix `holdDyn` so that it is lazy in its event argument +* Generalize `merge` to `mergeG`, `mergeIncremental` to + `mergeIncrementalG`, and `mergeIncrementalWithMove` + to `mergeIncrementalWithMoveG`. These produce `DMap`s + whose values needn't be `Identity`. ## 0.6.1.0 diff --git a/reflex.cabal b/reflex.cabal index 2f0cff20..b42674cc 100644 --- a/reflex.cabal +++ b/reflex.cabal @@ -48,6 +48,7 @@ library data-default >= 0.5 && < 0.8, dependent-map >= 0.2.4 && < 0.3, exception-transformers == 0.4.*, + profunctors, lens >= 4.7 && < 5, monad-control >= 1.0.1 && < 1.1, monoidal-containers == 0.4.*, diff --git a/src/Reflex/Class.hs b/src/Reflex/Class.hs index 59e087c3..08f4bc2a 100644 --- a/src/Reflex/Class.hs +++ b/src/Reflex/Class.hs @@ -17,6 +17,7 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE Trustworthy #-} #ifdef USE_REFLEX_OPTIMIZER {-# OPTIONS_GHC -fplugin=Reflex.Optimizer #-} #endif @@ -46,6 +47,9 @@ module Reflex.Class , pushAlways -- ** Combining 'Event's , leftmost + , merge + , mergeIncremental + , mergeIncrementalWithMove , mergeMap , mergeIntMap , mergeMapIncremental @@ -256,7 +260,9 @@ class ( MonadHold t (PushM t) -- | Merge a collection of events; the resulting 'Event' will only occur if at -- least one input event is occurring, and will contain all of the input keys -- that are occurring simultaneously - merge :: GCompare k => DMap k (Event t) -> Event t (DMap k Identity) --TODO: Generalize to get rid of DMap use --TODO: Provide a type-level guarantee that the result is not empty + mergeG :: GCompare k => (forall a. q a -> Event t (v a)) + -> DMap k q -> Event t (DMap k v) + --TODO: Generalize to get rid of DMap use --TODO: Provide a type-level guarantee that the result is not empty -- | Efficiently fan-out an event to many destinations. You should save the -- result in a @let@-binding, and then repeatedly 'select' on the result to -- create child events @@ -278,9 +284,14 @@ class ( MonadHold t (PushM t) -- that value. unsafeBuildIncremental :: Patch p => PullM t (PatchTarget p) -> Event t p -> Incremental t p -- | Create a merge whose parents can change over time - mergeIncremental :: GCompare k => Incremental t (PatchDMap k (Event t)) -> Event t (DMap k Identity) + mergeIncrementalG :: GCompare k + => (forall a. q a -> Event t (v a)) + -> Incremental t (PatchDMap k q) + -> Event t (DMap k v) -- | Experimental: Create a merge whose parents can change over time; changing the key of an Event is more efficient than with mergeIncremental - mergeIncrementalWithMove :: GCompare k => Incremental t (PatchDMapWithMove k (Event t)) -> Event t (DMap k Identity) + mergeIncrementalWithMoveG :: GCompare k + => (forall a. q a -> Event t (v a)) + -> Incremental t (PatchDMapWithMove k q) -> Event t (DMap k v) -- | Extract the 'Behavior' component of an 'Incremental' currentIncremental :: Patch p => Incremental t p -> Behavior t (PatchTarget p) -- | Extract the 'Event' component of an 'Incremental' @@ -1558,6 +1569,23 @@ fmapCheap f = pushCheap $ return . Just . f tagCheap :: Reflex t => Behavior t b -> Event t a -> Event t b tagCheap b = pushAlwaysCheap $ \_ -> sample b +-- | Merge a collection of events; the resulting 'Event' will only occur if at +-- least one input event is occurring, and will contain all of the input keys +-- that are occurring simultaneously +merge :: (Reflex t, GCompare k) => DMap k (Event t) -> Event t (DMap k Identity) +merge = mergeG coerceEvent +{-# INLINE merge #-} + +-- | Create a merge whose parents can change over time +mergeIncremental :: (Reflex t, GCompare k) + => Incremental t (PatchDMap k (Event t)) -> Event t (DMap k Identity) +mergeIncremental = mergeIncrementalG coerceEvent + +-- | Experimental: Create a merge whose parents can change over time; changing the key of an Event is more efficient than with mergeIncremental +mergeIncrementalWithMove :: (Reflex t, GCompare k) + => Incremental t (PatchDMapWithMove k (Event t)) -> Event t (DMap k Identity) +mergeIncrementalWithMove = mergeIncrementalWithMoveG coerceEvent + -- | A "cheap" version of 'mergeWithCheap'. See the performance note on 'pushCheap'. {-# INLINE mergeWithCheap #-} mergeWithCheap :: Reflex t => (a -> a -> a) -> [Event t a] -> Event t a diff --git a/src/Reflex/Profiled.hs b/src/Reflex/Profiled.hs index c0322da2..b311a8b5 100644 --- a/src/Reflex/Profiled.hs +++ b/src/Reflex/Profiled.hs @@ -8,6 +8,8 @@ {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RankNTypes #-} -- | -- Module: -- Reflex.Profiled @@ -16,7 +18,6 @@ -- profiling/cost-center information. module Reflex.Profiled where -import Control.Lens hiding (children) import Control.Monad import Control.Monad.Exception import Control.Monad.Fix @@ -33,6 +34,7 @@ import Data.Map (Map) import qualified Data.Map.Strict as Map import Data.Monoid ((<>)) import Data.Ord +import Data.Profunctor.Unsafe ((#.)) import qualified Data.Semigroup as S import Data.Type.Coercion import Foreign.Ptr @@ -133,8 +135,10 @@ instance Reflex t => Reflex (ProfiledTimeline t) where push f (Event_Profiled e) = coerce $ push (coerce f) $ profileEvent e -- Profile before rather than after; this way fanout won't count against us pushCheap f (Event_Profiled e) = coerce $ pushCheap (coerce f) $ profileEvent e pull = Behavior_Profiled . pull . coerce - merge :: forall k. GCompare k => DMap k (Event (ProfiledTimeline t)) -> Event (ProfiledTimeline t) (DMap k Identity) - merge = Event_Profiled . merge . (unsafeCoerce :: DMap k (Event (ProfiledTimeline t)) -> DMap k (Event t)) + mergeG :: forall (k :: z -> *) q v. GCompare k + => (forall a. q a -> Event (ProfiledTimeline t) (v a)) + -> DMap k q -> Event (ProfiledTimeline t) (DMap k v) + mergeG nt = Event_Profiled #. mergeG (coerce nt) fan (Event_Profiled e) = EventSelector $ coerce $ select (fan $ profileEvent e) switch (Behavior_Profiled b) = coerce $ profileEvent $ switch (coerceBehavior b) coincidence (Event_Profiled e) = coerce $ profileEvent $ coincidence (coerceEvent e) @@ -142,8 +146,8 @@ instance Reflex t => Reflex (ProfiledTimeline t) where updated (Dynamic_Profiled d) = coerce $ profileEvent $ updated d unsafeBuildDynamic (ProfiledM a0) (Event_Profiled a') = coerce $ unsafeBuildDynamic a0 a' unsafeBuildIncremental (ProfiledM a0) (Event_Profiled a') = coerce $ unsafeBuildIncremental a0 a' - mergeIncremental = Event_Profiled . mergeIncremental . (unsafeCoerce :: Incremental (ProfiledTimeline t) (PatchDMap k (Event (ProfiledTimeline t))) -> Incremental t (PatchDMap k (Event t))) - mergeIncrementalWithMove = Event_Profiled . mergeIncrementalWithMove . (unsafeCoerce :: Incremental (ProfiledTimeline t) (PatchDMapWithMove k (Event (ProfiledTimeline t))) -> Incremental t (PatchDMapWithMove k (Event t))) + mergeIncrementalG nt = (Event_Profiled . coerce) #. mergeIncrementalG nt + mergeIncrementalWithMoveG nt = (Event_Profiled . coerce) #. mergeIncrementalWithMoveG nt currentIncremental (Incremental_Profiled i) = coerce $ currentIncremental i updatedIncremental (Incremental_Profiled i) = coerce $ profileEvent $ updatedIncremental i incrementalToDynamic (Incremental_Profiled i) = coerce $ incrementalToDynamic i diff --git a/src/Reflex/Pure.hs b/src/Reflex/Pure.hs index 43d38608..cbf89b0c 100644 --- a/src/Reflex/Pure.hs +++ b/src/Reflex/Pure.hs @@ -5,6 +5,8 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE PolyKinds #-} #ifdef USE_REFLEX_OPTIMIZER {-# OPTIONS_GHC -fplugin=Reflex.Optimizer #-} #endif @@ -43,10 +45,11 @@ import Data.MemoTrie import Data.Monoid import Data.Type.Coercion import Reflex.Class +import Data.Kind (Type) -- | A completely pure-functional 'Reflex' timeline, identifying moments in time -- with the type @/t/@. -data Pure t +data Pure (t :: Type) -- | The 'Enum' instance of @/t/@ must be dense: for all @/x :: t/@, there must not exist -- any @/y :: t/@ such that @/'pred' x < y < x/@. The 'HasTrie' instance will be used @@ -79,11 +82,12 @@ instance (Enum t, HasTrie t, Ord t) => Reflex (Pure t) where -- [UNUSED_CONSTRAINT]: The following type signature for merge will produce a -- warning because the GCompare instance is not used; however, removing the -- GCompare instance produces a different warning, due to that constraint - -- being present in the original class definition + -- being present in the original class definition. - --merge :: GCompare k => DMap k (Event (Pure t)) -> Event (Pure t) (DMap k Identity) - merge events = Event $ memo $ \t -> - let currentOccurrences = DMap.mapMaybeWithKey (\_ (Event a) -> Identity <$> a t) events + --mergeG :: GCompare k => (forall a. q a -> Event (Pure t) (v a)) + -- -> DMap k q -> Event (Pure t) (DMap k v) + mergeG nt events = Event $ memo $ \t -> + let currentOccurrences = DMap.mapMaybeWithKey (\_ q -> case nt q of Event a -> a t) events in if DMap.null currentOccurrences then Nothing else Just currentOccurrences @@ -112,8 +116,8 @@ instance (Enum t, HasTrie t, Ord t) => Reflex (Pure t) where --a) -> Incremental (Pure t) p a unsafeBuildIncremental readV0 p = Incremental $ \t -> (readV0 t, unEvent p t) - mergeIncremental = mergeIncrementalImpl - mergeIncrementalWithMove = mergeIncrementalImpl + mergeIncrementalG = mergeIncrementalImpl + mergeIncrementalWithMoveG = mergeIncrementalImpl currentIncremental i = Behavior $ \t -> fst $ unIncremental i t @@ -133,9 +137,11 @@ instance (Enum t, HasTrie t, Ord t) => Reflex (Pure t) where mergeIntIncremental = mergeIntIncrementalImpl -mergeIncrementalImpl :: (PatchTarget p ~ DMap k (Event (Pure t)), GCompare k) => Incremental (Pure t) p -> Event (Pure t) (DMap k Identity) -mergeIncrementalImpl i = Event $ \t -> - let results = DMap.mapMaybeWithKey (\_ (Event e) -> Identity <$> e t) $ fst $ unIncremental i t +mergeIncrementalImpl :: (PatchTarget p ~ DMap k q, GCompare k) + => (forall a. q a -> Event (Pure t) (v a)) + -> Incremental (Pure t) p -> Event (Pure t) (DMap k v) +mergeIncrementalImpl nt i = Event $ \t -> + let results = DMap.mapMaybeWithKey (\_ q -> case nt q of Event e -> e t) $ fst $ unIncremental i t in if DMap.null results then Nothing else Just results diff --git a/src/Reflex/Spider/Internal.hs b/src/Reflex/Spider/Internal.hs index fbad7574..d9eb6473 100644 --- a/src/Reflex/Spider/Internal.hs +++ b/src/Reflex/Spider/Internal.hs @@ -17,9 +17,12 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE InstanceSigs #-} #ifdef USE_REFLEX_OPTIMIZER {-# OPTIONS_GHC -fplugin=Reflex.Optimizer #-} #endif +{-# OPTIONS_GHC -Wunused-binds #-} -- | This module is the implementation of the 'Spider' 'Reflex' engine. It uses -- a graph traversal algorithm to propagate 'Event's and 'Behavior's. module Reflex.Spider.Internal (module Reflex.Spider.Internal) where @@ -49,6 +52,7 @@ import Data.GADT.Compare import Data.IntMap.Strict (IntMap) import qualified Data.IntMap.Strict as IntMap import Data.IORef +import Data.Kind (Type) import Data.Maybe hiding (mapMaybe) import Data.Monoid ((<>)) import Data.Proxy @@ -77,6 +81,7 @@ import Data.Reflection import Data.Some (Some) import qualified Data.Some as Some import Data.Type.Coercion +import Data.Profunctor.Unsafe ((#.), (.#)) import Data.WeakBag (WeakBag, WeakBagTicket, _weakBag_children) import qualified Data.WeakBag as WeakBag import qualified Reflex.Class @@ -1136,13 +1141,14 @@ instance HasSpiderTimeline x => Align (Event x) where #if MIN_VERSION_these(0, 8, 0) instance HasSpiderTimeline x => Semialign (Event x) where #endif - align ea eb = mapMaybe dmapToThese $ merge $ dynamicConst $ DMap.fromDistinctAscList [LeftTag :=> ea, RightTag :=> eb] + align ea eb = mapMaybe dmapToThese $ mergeG coerce $ dynamicConst $ + DMap.fromDistinctAscList [LeftTag :=> ea, RightTag :=> eb] data DynType x p = UnsafeDyn !(BehaviorM x (PatchTarget p), Event x p) | BuildDyn !(EventM x (PatchTarget p), Event x p) | HoldDyn !(Hold x p) -newtype Dyn x p = Dyn { unDyn :: IORef (DynType x p) } +newtype Dyn (x :: Type) p = Dyn { unDyn :: IORef (DynType x p) } newMapDyn :: HasSpiderTimeline x => (a -> b) -> Dynamic x (Identity a) -> Dynamic x (Identity b) newMapDyn f d = dynamicDynIdentity $ unsafeBuildDynamic (fmap f $ readBehaviorTracked $ dynamicCurrent d) (Identity . f . runIdentity <$> dynamicUpdated d) @@ -1688,26 +1694,34 @@ cleanupCoincidenceSubscribed subscribed = do subscribeCoincidenceSubscribed :: CoincidenceSubscribed x a -> Subscriber x a -> IO WeakBagTicket subscribeCoincidenceSubscribed subscribed sub = WeakBag.insert sub (coincidenceSubscribedSubscribers subscribed) (coincidenceSubscribedWeakSelf subscribed) cleanupCoincidenceSubscribed -{-# INLINE merge #-} -merge :: forall k x. (HasSpiderTimeline x, GCompare k) => Dynamic x (PatchDMap k (Event x)) -> Event x (DMap k Identity) -merge d = cacheEvent (mergeCheap d) +{-# INLINE mergeG #-} +mergeG :: forall k q x v. (HasSpiderTimeline x, GCompare k) + => (forall a. q a -> Event x (v a)) + -> Dynamic x (PatchDMap k q) -> Event x (DMap k v) +mergeG nt d = cacheEvent (mergeCheap nt d) {-# INLINE mergeWithMove #-} -mergeWithMove :: forall k x. (HasSpiderTimeline x, GCompare k) => Dynamic x (PatchDMapWithMove k (Event x)) -> Event x (DMap k Identity) -mergeWithMove d = cacheEvent (mergeCheapWithMove d) +mergeWithMove :: forall k v q x. (HasSpiderTimeline x, GCompare k) + => (forall a. q a -> Event x (v a)) + -> Dynamic x (PatchDMapWithMove k q) -> Event x (DMap k v) +mergeWithMove nt d = cacheEvent (mergeCheapWithMove nt d) {-# INLINE [1] mergeCheap #-} -mergeCheap :: forall k x. (HasSpiderTimeline x, GCompare k) => Dynamic x (PatchDMap k (Event x)) -> Event x (DMap k Identity) -mergeCheap = mergeCheap' getInitialSubscribers updateMe destroy +mergeCheap + :: forall k x q v. (HasSpiderTimeline x, GCompare k) + => (forall a. q a -> Event x (v a)) + -> Dynamic x (PatchDMap k q) + -> Event x (DMap k v) +mergeCheap nt = mergeGCheap' getInitialSubscribers updateMe destroy where - updateMe :: MergeUpdateFunc k x (PatchDMap k (Event x)) (MergeSubscribedParent x) + updateMe :: MergeUpdateFunc k v x (PatchDMap k q) (MergeSubscribedParent x) updateMe subscriber heightBagRef oldParents (PatchDMap p) = do let f (subscriptionsToKill, ps) (k :=> ComposeMaybe me) = do (mOldSubd, newPs) <- case me of Nothing -> return $ DMap.updateLookupWithKey (\_ _ -> Nothing) k ps Just e -> do let s = subscriber $ return k - subscription@(EventSubscription _ subd) <- subscribe e s + subscription@(EventSubscription _ subd) <- subscribe (nt e) s newParentHeight <- liftIO $ getEventSubscribedHeight subd let newParent = MergeSubscribedParent subscription liftIO $ modifyIORef' heightBagRef $ heightBagAdd newParentHeight @@ -1717,28 +1731,33 @@ mergeCheap = mergeCheap' getInitialSubscribers updateMe destroy liftIO $ modifyIORef heightBagRef $ heightBagRemove oldHeight return (maybeToList (unMergeSubscribedParent <$> mOldSubd) ++ subscriptionsToKill, newPs) foldM f ([], oldParents) $ DMap.toList p - getInitialSubscribers :: MergeInitFunc k x (MergeSubscribedParent x) + + getInitialSubscribers :: MergeInitFunc k v q x (MergeSubscribedParent x) getInitialSubscribers initialParents subscriber = do subscribers <- forM (DMap.toList initialParents) $ \(k :=> e) -> do let s = subscriber $ return k - (subscription@(EventSubscription _ parentSubd), parentOcc) <- subscribeAndRead e s + (subscription@(EventSubscription _ parentSubd), parentOcc) <- subscribeAndRead (nt e) s height <- liftIO $ getEventSubscribedHeight parentSubd - return (fmap (\x -> k :=> Identity x) parentOcc, height, k :=> MergeSubscribedParent subscription) + return (fmap (\x -> k :=> x) parentOcc, height, k :=> MergeSubscribedParent subscription) return ( DMap.fromDistinctAscList $ mapMaybe (\(x, _, _) -> x) subscribers , fmap (\(_, h, _) -> h) subscribers --TODO: Assert that there's no invalidHeight in here , DMap.fromDistinctAscList $ map (\(_, _, x) -> x) subscribers ) + destroy :: MergeDestroyFunc k (MergeSubscribedParent x) destroy s = forM_ (DMap.toList s) $ \(_ :=> MergeSubscribedParent sub) -> unsubscribe sub {-# INLINE [1] mergeCheapWithMove #-} -mergeCheapWithMove :: forall k x. (HasSpiderTimeline x, GCompare k) => Dynamic x (PatchDMapWithMove k (Event x)) -> Event x (DMap k Identity) -mergeCheapWithMove = mergeCheap' getInitialSubscribers updateMe destroy +mergeCheapWithMove :: forall k x v q. (HasSpiderTimeline x, GCompare k) + => (forall a. q a -> Event x (v a)) + -> Dynamic x (PatchDMapWithMove k q) + -> Event x (DMap k v) +mergeCheapWithMove nt = mergeGCheap' getInitialSubscribers updateMe destroy where - updateMe :: MergeUpdateFunc k x (PatchDMapWithMove k (Event x)) (MergeSubscribedParentWithMove x k) + updateMe :: MergeUpdateFunc k v x (PatchDMapWithMove k q) (MergeSubscribedParentWithMove x k) updateMe subscriber heightBagRef oldParents p = do -- Prepare new parents for insertion - let subscribeParent :: forall a. k a -> Event x a -> EventM x (MergeSubscribedParentWithMove x k a) + let subscribeParent :: forall a. k a -> Event x (v a) -> EventM x (MergeSubscribedParentWithMove x k a) subscribeParent k e = do keyRef <- liftIO $ newIORef k let s = subscriber $ liftIO $ readIORef keyRef @@ -1747,9 +1766,9 @@ mergeCheapWithMove = mergeCheap' getInitialSubscribers updateMe destroy newParentHeight <- getEventSubscribedHeight subd modifyIORef' heightBagRef $ heightBagAdd newParentHeight return $ MergeSubscribedParentWithMove subscription keyRef - p' <- PatchDMapWithMove.traversePatchDMapWithMoveWithKey subscribeParent p + p' <- PatchDMapWithMove.traversePatchDMapWithMoveWithKey (\k q -> subscribeParent k (nt q)) p -- Collect old parents for deletion and update the keys of moved parents - let moveOrDelete :: forall a. k a -> PatchDMapWithMove.NodeInfo k (Event x) a -> MergeSubscribedParentWithMove x k a -> Constant (EventM x (Maybe (EventSubscription x))) a + let moveOrDelete :: forall a. k a -> PatchDMapWithMove.NodeInfo k q a -> MergeSubscribedParentWithMove x k a -> Constant (EventM x (Maybe (EventSubscription x))) a moveOrDelete _ ni parent = Constant $ case getComposeMaybe $ PatchDMapWithMove._nodeInfo_to ni of Nothing -> do oldHeight <- liftIO $ getEventSubscribedHeight $ _eventSubscription_subscribed $ _mergeSubscribedParentWithMove_subscription parent @@ -1760,46 +1779,47 @@ mergeCheapWithMove = mergeCheap' getInitialSubscribers updateMe destroy return Nothing toDelete <- fmap catMaybes $ mapM (\(_ :=> v) -> getConstant v) $ DMap.toList $ DMap.intersectionWithKey moveOrDelete (unPatchDMapWithMove p) oldParents return (toDelete, applyAlways p' oldParents) - getInitialSubscribers :: MergeInitFunc k x (MergeSubscribedParentWithMove x k) + getInitialSubscribers :: MergeInitFunc k v q x (MergeSubscribedParentWithMove x k) getInitialSubscribers initialParents subscriber = do subscribers <- forM (DMap.toList initialParents) $ \(k :=> e) -> do keyRef <- liftIO $ newIORef k let s = subscriber $ liftIO $ readIORef keyRef - (subscription@(EventSubscription _ parentSubd), parentOcc) <- subscribeAndRead e s + (subscription@(EventSubscription _ parentSubd), parentOcc) <- subscribeAndRead (nt e) s height <- liftIO $ getEventSubscribedHeight parentSubd - return (fmap (\x -> k :=> Identity x) parentOcc, height, k :=> MergeSubscribedParentWithMove subscription keyRef) + return (fmap (\x -> k :=> x) parentOcc, height, k :=> MergeSubscribedParentWithMove subscription keyRef) return ( DMap.fromDistinctAscList $ mapMaybe (\(x, _, _) -> x) subscribers , fmap (\(_, h, _) -> h) subscribers --TODO: Assert that there's no invalidHeight in here , DMap.fromDistinctAscList $ map (\(_, _, x) -> x) subscribers ) + destroy :: MergeDestroyFunc k (MergeSubscribedParentWithMove x k) destroy s = forM_ (DMap.toList s) $ \(_ :=> MergeSubscribedParentWithMove sub _) -> unsubscribe sub -type MergeUpdateFunc k x p s - = (forall a. EventM x (k a) -> Subscriber x a) +type MergeUpdateFunc k v x p s + = (forall a. EventM x (k a) -> Subscriber x (v a)) -> IORef HeightBag -> DMap k s -> p -> EventM x ([EventSubscription x], DMap k s) -type MergeInitFunc k x s - = DMap k (Event x) - -> (forall a. EventM x (k a) -> Subscriber x a) - -> EventM x (DMap k Identity, [Height], DMap k s) +type MergeInitFunc k v q x s + = DMap k q + -> (forall a. EventM x (k a) -> Subscriber x (v a)) + -> EventM x (DMap k v, [Height], DMap k s) type MergeDestroyFunc k s = DMap k s -> IO () -data Merge x k s = Merge +data Merge x k v s = Merge { _merge_parentsRef :: {-# UNPACK #-} !(IORef (DMap k s)) , _merge_heightBagRef :: {-# UNPACK #-} !(IORef HeightBag) , _merge_heightRef :: {-# UNPACK #-} !(IORef Height) - , _merge_sub :: {-# UNPACK #-} !(Subscriber x (DMap k Identity)) - , _merge_accumRef :: {-# UNPACK #-} !(IORef (DMap k Identity)) + , _merge_sub :: {-# UNPACK #-} !(Subscriber x (DMap k v)) + , _merge_accumRef :: {-# UNPACK #-} !(IORef (DMap k v)) } -invalidateMergeHeight :: Merge x k s -> IO () +invalidateMergeHeight :: Merge x k v s -> IO () invalidateMergeHeight m = invalidateMergeHeight' (_merge_heightRef m) (_merge_sub m) invalidateMergeHeight' :: IORef Height -> Subscriber x a -> IO () @@ -1809,8 +1829,7 @@ invalidateMergeHeight' heightRef sub = do writeIORef heightRef $! invalidHeight subscriberInvalidateHeight sub oldHeight - -revalidateMergeHeight :: Merge x k s -> IO () +revalidateMergeHeight :: Merge x k v s -> IO () revalidateMergeHeight m = do currentHeight <- readIORef $ _merge_heightRef m when (currentHeight == invalidHeight) $ do -- revalidateMergeHeight may be called multiple times; perhaps the's a way to finesse it to avoid this check @@ -1826,19 +1845,19 @@ revalidateMergeHeight m = do subscriberRecalculateHeight (_merge_sub m) height GT -> error $ "revalidateMergeHeight: more heights (" <> show (heightBagSize heights) <> ") than parents (" <> show (DMap.size parents) <> ") for Merge" -scheduleMergeSelf :: HasSpiderTimeline x => Merge x k s -> Height -> EventM x () +scheduleMergeSelf :: HasSpiderTimeline x => Merge x k v s -> Height -> EventM x () scheduleMergeSelf m height = scheduleMerge' height (_merge_heightRef m) $ do vals <- liftIO $ readIORef $ _merge_accumRef m liftIO $ writeIORef (_merge_accumRef m) $! DMap.empty -- Once we're done with this, we can clear it immediately, because if there's a cacheEvent in front of us, it'll handle subsequent subscribers, and if not, we won't get subsequent subscribers --TODO: Assert that m is not empty subscriberPropagate (_merge_sub m) vals -mergeSubscriber :: forall x k s a. (HasSpiderTimeline x, GCompare k) => Merge x k s -> EventM x (k a) -> Subscriber x a +mergeSubscriber :: forall x k v s a. (HasSpiderTimeline x, GCompare k) => Merge x k v s -> EventM x (k a) -> Subscriber x (v a) mergeSubscriber m getKey = Subscriber { subscriberPropagate = \a -> do oldM <- liftIO $ readIORef $ _merge_accumRef m k <- getKey - let newM = DMap.insertWith (error $ "Same key fired multiple times for Merge") k (Identity a) oldM + let newM = DMap.insertWith (error $ "Same key fired multiple times for Merge") k a oldM tracePropagate (Proxy :: Proxy x) $ " DMap.size oldM = " <> show (DMap.size oldM) <> "; DMap.size newM = " <> show (DMap.size newM) liftIO $ writeIORef (_merge_accumRef m) $! newM when (DMap.null oldM) $ do -- Only schedule the firing once @@ -1869,7 +1888,7 @@ mergeSubscriber m getKey = Subscriber } --TODO: Be able to run as much of this as possible promptly -updateMerge :: (HasSpiderTimeline x, GCompare k) => Merge x k s -> MergeUpdateFunc k x p s -> p -> SomeMergeUpdate x +updateMerge :: (HasSpiderTimeline x, GCompare k) => Merge x k v s -> MergeUpdateFunc k v x p s -> p -> SomeMergeUpdate x updateMerge m updateFunc p = SomeMergeUpdate updateMe (invalidateMergeHeight m) (revalidateMergeHeight m) where updateMe = do oldParents <- liftIO $ readIORef $ _merge_parentsRef m @@ -1877,9 +1896,10 @@ updateMerge m updateFunc p = SomeMergeUpdate updateMe (invalidateMergeHeight m) liftIO $ writeIORef (_merge_parentsRef m) $! newParents return subscriptionsToKill -{-# INLINE mergeCheap' #-} -mergeCheap' :: forall k x p s. (HasSpiderTimeline x, GCompare k, PatchTarget p ~ DMap k (Event x)) => MergeInitFunc k x s -> MergeUpdateFunc k x p s -> MergeDestroyFunc k s -> Dynamic x p -> Event x (DMap k Identity) -mergeCheap' getInitialSubscribers updateFunc destroy d = Event $ \sub -> do +{-# INLINE mergeGCheap' #-} +mergeGCheap' :: forall k v x p s q. (HasSpiderTimeline x, GCompare k, PatchTarget p ~ DMap k q) + => MergeInitFunc k v q x s -> MergeUpdateFunc k v x p s -> MergeDestroyFunc k s -> Dynamic x p -> Event x (DMap k v) +mergeGCheap' getInitialSubscribers updateFunc destroy d = Event $ \sub -> do initialParents <- readBehaviorUntracked $ dynamicCurrent d accumRef <- liftIO $ newIORef $ error "merge: accumRef not yet initialized" heightRef <- liftIO $ newIORef $ error "merge: heightRef not yet initialized" @@ -2462,7 +2482,7 @@ unsafeNewSpiderTimelineEnv = do newSpiderTimeline :: IO (Some SpiderTimelineEnv) newSpiderTimeline = withSpiderTimeline (pure . Some.This) -data LocalSpiderTimeline x s +data LocalSpiderTimeline (x :: Type) s instance Reifies s (SpiderTimelineEnv x) => HasSpiderTimeline (LocalSpiderTimeline x s) where @@ -2480,11 +2500,11 @@ withSpiderTimeline k = do env <- unsafeNewSpiderTimelineEnv reify env $ \s -> k $ localSpiderTimeline s env -newtype SpiderPullM x a = SpiderPullM (BehaviorM x a) deriving (Functor, Applicative, Monad, MonadIO, MonadFix) +newtype SpiderPullM (x :: Type) a = SpiderPullM (BehaviorM x a) deriving (Functor, Applicative, Monad, MonadIO, MonadFix) type ComputeM = EventM -newtype SpiderPushM x a = SpiderPushM (ComputeM x a) deriving (Functor, Applicative, Monad, MonadIO, MonadFix) +newtype SpiderPushM (x :: Type) a = SpiderPushM (ComputeM x a) deriving (Functor, Applicative, Monad, MonadIO, MonadFix) instance HasSpiderTimeline x => R.Reflex (SpiderTimeline x) where {-# SPECIALIZE instance R.Reflex (SpiderTimeline Global) #-} @@ -2504,8 +2524,13 @@ instance HasSpiderTimeline x => R.Reflex (SpiderTimeline x) where pushCheap f = SpiderEvent . pushCheap (coerce f) . unSpiderEvent {-# INLINABLE pull #-} pull = SpiderBehavior . pull . coerce - {-# INLINABLE merge #-} - merge = SpiderEvent . merge . dynamicConst . (coerce :: DMap k (R.Event (SpiderTimeline x)) -> DMap k (Event x)) + {-# INLINABLE mergeG #-} + mergeG + :: forall (k :: k2 -> *) q (v :: k2 -> *). GCompare k + => (forall a. q a -> R.Event (SpiderTimeline x) (v a)) + -> DMap k q + -> R.Event (SpiderTimeline x) (DMap k v) + mergeG nt = SpiderEvent . mergeG (unSpiderEvent #. nt) . dynamicConst {-# INLINABLE fan #-} fan e = R.EventSelector $ SpiderEvent . select (fan (unSpiderEvent e)) {-# INLINABLE switch #-} @@ -2520,10 +2545,10 @@ instance HasSpiderTimeline x => R.Reflex (SpiderTimeline x) where unsafeBuildDynamic readV0 v' = SpiderDynamic $ dynamicDynIdentity $ unsafeBuildDynamic (coerce readV0) $ coerce $ unSpiderEvent v' {-# INLINABLE unsafeBuildIncremental #-} unsafeBuildIncremental readV0 dv = SpiderIncremental $ dynamicDyn $ unsafeBuildDynamic (coerce readV0) $ unSpiderEvent dv - {-# INLINABLE mergeIncremental #-} - mergeIncremental = SpiderEvent . merge . (unsafeCoerce :: Dynamic x (PatchDMap k (R.Event (SpiderTimeline x))) -> Dynamic x (PatchDMap k (Event x))) . unSpiderIncremental - {-# INLINABLE mergeIncrementalWithMove #-} - mergeIncrementalWithMove = SpiderEvent . mergeWithMove . (unsafeCoerce :: Dynamic x (PatchDMapWithMove k (R.Event (SpiderTimeline x))) -> Dynamic x (PatchDMapWithMove k (Event x))) . unSpiderIncremental + {-# INLINABLE mergeIncrementalG #-} + mergeIncrementalG nt = SpiderEvent #. mergeG (coerce #. nt) .# unSpiderIncremental + {-# INLINABLE mergeIncrementalWithMoveG #-} + mergeIncrementalWithMoveG nt = SpiderEvent #. mergeWithMove (coerce #. nt) .# unSpiderIncremental {-# INLINABLE currentIncremental #-} currentIncremental = SpiderBehavior . dynamicCurrent . unSpiderIncremental {-# INLINABLE updatedIncremental #-} @@ -2561,7 +2586,7 @@ instance MonadAtomicRef (EventM x) where atomicModifyRef r f = liftIO $ atomicModifyRef r f -- | The monad for actions that manipulate a Spider timeline identified by @x@ -newtype SpiderHost x a = SpiderHost { unSpiderHost :: IO a } deriving (Functor, Applicative, MonadFix, MonadIO, MonadException, MonadAsyncException) +newtype SpiderHost (x :: Type) a = SpiderHost { unSpiderHost :: IO a } deriving (Functor, Applicative, MonadFix, MonadIO, MonadException, MonadAsyncException) instance Monad (SpiderHost x) where {-# INLINABLE (>>=) #-} @@ -2583,7 +2608,7 @@ runSpiderHost (SpiderHost a) = a runSpiderHostForTimeline :: SpiderHost x a -> SpiderTimelineEnv x -> IO a runSpiderHostForTimeline (SpiderHost a) _ = a -newtype SpiderHostFrame x a = SpiderHostFrame { runSpiderHostFrame :: EventM x a } +newtype SpiderHostFrame (x :: Type) a = SpiderHostFrame { runSpiderHostFrame :: EventM x a } deriving (Functor, Applicative, MonadFix, MonadIO, MonadException, MonadAsyncException) instance Monad (SpiderHostFrame x) where diff --git a/test/GC.hs b/test/GC.hs index cc0c343f..85be7bde 100644 --- a/test/GC.hs +++ b/test/GC.hs @@ -27,6 +27,7 @@ import qualified Reflex.Spider.Internal as S import System.Exit import System.Mem +import Data.Coerce main :: IO () main = do @@ -46,7 +47,7 @@ hostPerf ref = S.runSpiderHost $ do eventToPerform <- Host.runHostFrame $ do (reqMap :: S.Event S.Global (DMap (Const2 Int (DMap Tell (S.SpiderHostFrame S.Global))) Identity)) <- S.SpiderHostFrame - $ fmap ( S.merge + $ fmap ( S.mergeG coerce . S.dynamicHold) $ S.hold DMap.empty -- Construct a new heap object for the subscriber, invalidating any weak references to the subscriber if they are not retained From 5feea4250ea637e6c1514f0600036156e3b022b9 Mon Sep 17 00:00:00 2001 From: David Feuer Date: Sat, 13 Jul 2019 15:54:42 -0400 Subject: [PATCH 150/241] Distribute more generally --- src/Reflex/Class.hs | 18 ++++++++++++++---- 1 file changed, 14 insertions(+), 4 deletions(-) diff --git a/src/Reflex/Class.hs b/src/Reflex/Class.hs index 08f4bc2a..33927985 100644 --- a/src/Reflex/Class.hs +++ b/src/Reflex/Class.hs @@ -88,6 +88,7 @@ module Reflex.Class , gate -- ** Combining 'Dynamic's , distributeDMapOverDynPure + , distributeDMapOverDynPureG , distributeListOverDyn , distributeListOverDynWith , zipDyn @@ -1091,12 +1092,21 @@ instance (Reflex t, Monoid a) => Monoid (Dynamic t a) where -- 'Dynamic' 'DMap'. Its implementation is more efficient than doing the same -- through the use of multiple uses of 'zipDynWith' or 'Applicative' operators. distributeDMapOverDynPure :: forall t k. (Reflex t, GCompare k) => DMap k (Dynamic t) -> Dynamic t (DMap k Identity) -distributeDMapOverDynPure dm = case DMap.toList dm of +distributeDMapOverDynPure = distributeDMapOverDynPureG coerceDynamic + +-- | This function converts a 'DMap' whose elements are 'Dynamic's into a +-- 'Dynamic' 'DMap'. Its implementation is more efficient than doing the same +-- through the use of multiple uses of 'zipDynWith' or 'Applicative' operators. +distributeDMapOverDynPureG + :: forall t k q v. (Reflex t, GCompare k) + => (forall a. q a -> Dynamic t (v a)) + -> DMap k q -> Dynamic t (DMap k v) +distributeDMapOverDynPureG nt dm = case DMap.toList dm of [] -> constDyn DMap.empty - [k :=> v] -> fmap (DMap.singleton k . Identity) v + [k :=> v] -> DMap.singleton k <$> nt v _ -> - let getInitial = DMap.traverseWithKey (\_ -> fmap Identity . sample . current) dm - edmPre = merge $ DMap.map updated dm + let getInitial = DMap.traverseWithKey (\_ -> sample . current . nt) dm + edmPre = mergeG getCompose $ DMap.map (Compose . updated . nt) dm result = unsafeBuildDynamic getInitial $ flip pushAlways edmPre $ \news -> do olds <- sample $ current result return $ DMap.unionWithKey (\_ _ new -> new) olds news From 2e255e9fc19ec705a303d88642d1534b873d5f1d Mon Sep 17 00:00:00 2001 From: Alexandre Esteves Date: Sat, 13 Jul 2019 21:51:25 +0100 Subject: [PATCH 151/241] Add missing details to documentation of 'networkView' and 'workflowView' --- src/Reflex/Network.hs | 2 +- src/Reflex/Workflow.hs | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/src/Reflex/Network.hs b/src/Reflex/Network.hs index b860526e..03348aee 100644 --- a/src/Reflex/Network.hs +++ b/src/Reflex/Network.hs @@ -20,7 +20,7 @@ import Reflex.NotReady.Class import Reflex.PostBuild.Class -- | A 'Dynamic' "network": Takes a 'Dynamic' of network-creating actions and replaces the network whenever the 'Dynamic' updates. --- The returned Event of network results fires when the 'Dynamic' updates. +-- The returned Event of network results fires at post-build time and when the 'Dynamic' updates. -- Note: Often, the type 'a' is an Event, in which case the return value is an Event-of-Events, where the outer 'Event' fires -- when switching networks. Such an 'Event' would typically be flattened (via 'switchPromptly'). networkView :: (NotReady t m, Adjustable t m, PostBuild t m) => Dynamic t (m a) -> m (Event t a) diff --git a/src/Reflex/Workflow.hs b/src/Reflex/Workflow.hs index c5cb1d1b..faba2353 100644 --- a/src/Reflex/Workflow.hs +++ b/src/Reflex/Workflow.hs @@ -34,7 +34,7 @@ workflow w0 = do rec eResult <- networkHold (unWorkflow w0) $ fmap unWorkflow $ switch $ snd <$> current eResult return $ fmap fst eResult --- | Similar to 'workflow', but outputs an 'Event' that fires whenever the current 'Workflow' is replaced by the next 'Workflow'. +-- | Similar to 'workflow', but outputs an 'Event' that fires at post-build time and whenever the current 'Workflow' is replaced by the next 'Workflow'. workflowView :: forall t m a. (Reflex t, NotReady t m, Adjustable t m, MonadFix m, MonadHold t m, PostBuild t m) => Workflow t m a -> m (Event t a) workflowView w0 = do rec eResult <- networkView . fmap unWorkflow =<< holdDyn w0 eReplace From 13e76bb3db6566cdd9e51544ea456eee807ed302 Mon Sep 17 00:00:00 2001 From: David Feuer Date: Sun, 21 Jul 2019 01:16:34 -0400 Subject: [PATCH 152/241] Generalize fan following DMap (#318) Generalize fan to fanG allowing fanning DMaps with arbitrary targets (not just Identity) --- ChangeLog.md | 4 +++ src/Reflex/Class.hs | 34 +++++++++++++++++++++--- src/Reflex/Profiled.hs | 2 +- src/Reflex/Pure.hs | 5 ++-- src/Reflex/Spider/Internal.hs | 50 ++++++++++++++++++----------------- test/GC.hs | 4 +-- 6 files changed, 67 insertions(+), 32 deletions(-) diff --git a/ChangeLog.md b/ChangeLog.md index 11d06324..d2bc088f 100644 --- a/ChangeLog.md +++ b/ChangeLog.md @@ -2,12 +2,16 @@ ## Unreleased +* Generalize `fan` to `fanG` to take a `DMap` with non-`Identity` + values. + * Generalize merging functions: `merge` to `mergeG`, `mergeIncremental` to `mergeIncrementalG`, `distributeDMapOverDynPure` to `distributeDMapOverDynPureG`, `mergeIncrementalWithMove` to `mergeIncrementalWithMoveG`. + ## 0.6.2.0 * Fix `holdDyn` so that it is lazy in its event argument diff --git a/src/Reflex/Class.hs b/src/Reflex/Class.hs index 0792c08b..af36a244 100644 --- a/src/Reflex/Class.hs +++ b/src/Reflex/Class.hs @@ -41,6 +41,7 @@ module Reflex.Class , MonadHold (..) -- ** 'fan' related types , EventSelector (..) + , EventSelectorG (..) , EventSelectorInt (..) -- * Convenience functions , constDyn @@ -64,6 +65,7 @@ module Reflex.Class , alignEventWithMaybe -- ** Breaking up 'Event's , splitE + , fan , fanEither , fanThese , fanMap @@ -260,13 +262,16 @@ class ( MonadHold t (PushM t) -- | Merge a collection of events; the resulting 'Event' will only occur if at -- least one input event is occurring, and will contain all of the input keys -- that are occurring simultaneously + + --TODO: Generalize to get rid of DMap use --TODO: Provide a type-level guarantee that the result is not empty mergeG :: GCompare k => (forall a. q a -> Event t (v a)) -> DMap k q -> Event t (DMap k v) - --TODO: Generalize to get rid of DMap use --TODO: Provide a type-level guarantee that the result is not empty + -- | Efficiently fan-out an event to many destinations. You should save the - -- result in a @let@-binding, and then repeatedly 'select' on the result to + -- result in a @let@-binding, and then repeatedly 'selectG' on the result to -- create child events - fan :: GCompare k => Event t (DMap k Identity) -> EventSelector t k + fanG :: GCompare k => Event t (DMap k v) -> EventSelectorG t k v + -- | Create an 'Event' that will occur whenever the currently-selected input -- 'Event' occurs switch :: Behavior t (Event t a) -> Event t a @@ -310,6 +315,18 @@ class ( MonadHold t (PushM t) mergeIntIncremental :: Incremental t (PatchIntMap (Event t a)) -> Event t (IntMap a) fanInt :: Event t (IntMap a) -> EventSelectorInt t a +-- | Efficiently fan-out an event to many destinations. You should save the +-- result in a @let@-binding, and then repeatedly 'select' on the result to +-- create child events +fan :: forall t k. (Reflex t, GCompare k) + => Event t (DMap k Identity) -> EventSelector t k + --TODO: Can we help enforce the partial application discipline here? The combinator is worthless without it +fan e = EventSelector (fixup (selectG (fanG e) :: k a -> Event t (Identity a)) :: forall a. k a -> Event t a) + where + fixup :: forall a. (k a -> Event t (Identity a)) -> k a -> Event t a + fixup = case eventCoercion Coercion :: Coercion (Event t (Identity a)) (Event t a) of + Coercion -> coerce + --TODO: Specialize this so that we can take advantage of knowing that there's no changing going on -- | Constructs a single 'Event' out of a map of events. The output event may fire with multiple -- keys simultaneously. @@ -497,6 +514,17 @@ newtype EventSelector t k = EventSelector select :: forall a. k a -> Event t a } +newtype EventSelectorG t k v = EventSelectorG + { -- | Retrieve the 'Event' for the given key. The type of the 'Event' is + -- determined by the type of the key, so this can be used to fan-out + -- 'Event's whose sub-'Event's have different types. + -- + -- Using 'EventSelector's and the 'fan' primitive is far more efficient than + -- (but equivalent to) using 'mapMaybe' to select only the relevant + -- occurrences of an 'Event'. + selectG :: forall a. k a -> Event t (v a) + } + -- | Efficiently select an 'Event' keyed on 'Int'. This is more efficient than manually -- filtering by key. newtype EventSelectorInt t a = EventSelectorInt { selectInt :: Int -> Event t a } diff --git a/src/Reflex/Profiled.hs b/src/Reflex/Profiled.hs index b311a8b5..6a9b19d6 100644 --- a/src/Reflex/Profiled.hs +++ b/src/Reflex/Profiled.hs @@ -135,11 +135,11 @@ instance Reflex t => Reflex (ProfiledTimeline t) where push f (Event_Profiled e) = coerce $ push (coerce f) $ profileEvent e -- Profile before rather than after; this way fanout won't count against us pushCheap f (Event_Profiled e) = coerce $ pushCheap (coerce f) $ profileEvent e pull = Behavior_Profiled . pull . coerce + fanG (Event_Profiled e) = EventSelectorG $ coerce $ selectG (fanG $ profileEvent e) mergeG :: forall (k :: z -> *) q v. GCompare k => (forall a. q a -> Event (ProfiledTimeline t) (v a)) -> DMap k q -> Event (ProfiledTimeline t) (DMap k v) mergeG nt = Event_Profiled #. mergeG (coerce nt) - fan (Event_Profiled e) = EventSelector $ coerce $ select (fan $ profileEvent e) switch (Behavior_Profiled b) = coerce $ profileEvent $ switch (coerceBehavior b) coincidence (Event_Profiled e) = coerce $ profileEvent $ coincidence (coerceEvent e) current (Dynamic_Profiled d) = coerce $ current d diff --git a/src/Reflex/Pure.hs b/src/Reflex/Pure.hs index cbf89b0c..73574703 100644 --- a/src/Reflex/Pure.hs +++ b/src/Reflex/Pure.hs @@ -7,6 +7,7 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE PolyKinds #-} + #ifdef USE_REFLEX_OPTIMIZER {-# OPTIONS_GHC -fplugin=Reflex.Optimizer #-} #endif @@ -92,8 +93,8 @@ instance (Enum t, HasTrie t, Ord t) => Reflex (Pure t) where then Nothing else Just currentOccurrences - fan :: GCompare k => Event (Pure t) (DMap k Identity) -> EventSelector (Pure t) k - fan e = EventSelector $ \k -> Event $ \t -> unEvent e t >>= fmap runIdentity . DMap.lookup k + -- fanG :: GCompare k => Event (Pure t) (DMap k v) -> EventSelectorG (Pure t) k v + fanG e = EventSelectorG $ \k -> Event $ \t -> unEvent e t >>= DMap.lookup k switch :: Behavior (Pure t) (Event (Pure t) a) -> Event (Pure t) a switch b = Event $ memo $ \t -> unEvent (unBehavior b t) t diff --git a/src/Reflex/Spider/Internal.hs b/src/Reflex/Spider/Internal.hs index b11a7b92..ee7c7a0a 100644 --- a/src/Reflex/Spider/Internal.hs +++ b/src/Reflex/Spider/Internal.hs @@ -19,6 +19,7 @@ {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE InstanceSigs #-} + #ifdef USE_REFLEX_OPTIMIZER {-# OPTIONS_GHC -fplugin=Reflex.Optimizer #-} #endif @@ -374,7 +375,7 @@ eventRoot !k !r = Event $ wrap eventSubscribedRoot $ liftIO . getRootSubscribed eventNever :: Event x a eventNever = Event $ \_ -> return (EventSubscription (return ()) eventSubscribedNever, Nothing) -eventFan :: (GCompare k, HasSpiderTimeline x) => k a -> Fan x k -> Event x a +eventFan :: (GCompare k, HasSpiderTimeline x) => k a -> Fan x k v -> Event x (v a) eventFan !k !f = Event $ wrap eventSubscribedFan $ getFanSubscribed k f eventSwitch :: HasSpiderTimeline x => Switch x a -> Event x a @@ -426,14 +427,14 @@ newSubscriberHold h = return $ Subscriber , subscriberRecalculateHeight = \_ -> return () } -newSubscriberFan :: forall x k. (HasSpiderTimeline x, GCompare k) => FanSubscribed x k -> IO (Subscriber x (DMap k Identity)) +newSubscriberFan :: forall x k v. (HasSpiderTimeline x, GCompare k) => FanSubscribed x k v -> IO (Subscriber x (DMap k v)) newSubscriberFan subscribed = return $ Subscriber { subscriberPropagate = \a -> {-# SCC "traverseFan" #-} do subs <- liftIO $ readIORef $ fanSubscribedSubscribers subscribed tracePropagate (Proxy :: Proxy x) $ "SubscriberFan" <> showNodeId subscribed <> ": " ++ show (DMap.size subs) ++ " keys subscribed, " ++ show (DMap.size a) ++ " keys firing" liftIO $ writeIORef (fanSubscribedOccurrence subscribed) $ Just a scheduleClear $ fanSubscribedOccurrence subscribed - let f _ (Pair (Identity v) subsubs) = do + let f _ (Pair v subsubs) = do propagate v $ _fanSubscribedChildren_list subsubs return $ Constant () _ <- DMap.traverseWithKey f $ DMap.intersectionWithKey (\_ -> Pair) a subs --TODO: Would be nice to have DMap.traverse_ @@ -581,7 +582,7 @@ eventSubscribedNever = EventSubscribed #endif } -eventSubscribedFan :: FanSubscribed x k -> EventSubscribed x +eventSubscribedFan :: FanSubscribed x k v -> EventSubscribed x eventSubscribedFan !subscribed = EventSubscribed { eventSubscribedHeightRef = eventSubscribedHeightRef $ _eventSubscription_subscribed $ fanSubscribedParent subscribed , eventSubscribedRetained = toAny subscribed @@ -990,7 +991,7 @@ data RootSubscribed x a = forall k. GCompare k => RootSubscribed #endif } -data Root x (k :: * -> *) +data Root x k = Root { rootOccurrence :: !(IORef (DMap k Identity)) -- The currently-firing occurrence of this event , rootSubscribed :: !(IORef (DMap k (RootSubscribed x))) , rootInit :: !(forall a. k a -> RootTrigger x a -> IO (IO ())) @@ -1060,25 +1061,25 @@ heightBagVerify b@(HeightBag s c) = if heightBagVerify = id #endif -data FanSubscribedChildren (x :: *) k a = FanSubscribedChildren - { _fanSubscribedChildren_list :: !(WeakBag (Subscriber x a)) - , _fanSubscribedChildren_self :: {-# NOUNPACK #-} !(k a, FanSubscribed x k) - , _fanSubscribedChildren_weakSelf :: !(IORef (Weak (k a, FanSubscribed x k))) +data FanSubscribedChildren x k v a = FanSubscribedChildren + { _fanSubscribedChildren_list :: !(WeakBag (Subscriber x (v a))) + , _fanSubscribedChildren_self :: {-# NOUNPACK #-} !(k a, FanSubscribed x k v) + , _fanSubscribedChildren_weakSelf :: !(IORef (Weak (k a, FanSubscribed x k v))) } -data FanSubscribed (x :: *) k - = FanSubscribed { fanSubscribedCachedSubscribed :: !(IORef (Maybe (FanSubscribed x k))) - , fanSubscribedOccurrence :: !(IORef (Maybe (DMap k Identity))) - , fanSubscribedSubscribers :: !(IORef (DMap k (FanSubscribedChildren x k))) -- This DMap should never be empty +data FanSubscribed x k v + = FanSubscribed { fanSubscribedCachedSubscribed :: !(IORef (Maybe (FanSubscribed x k v))) + , fanSubscribedOccurrence :: !(IORef (Maybe (DMap k v))) + , fanSubscribedSubscribers :: !(IORef (DMap k (FanSubscribedChildren x k v))) -- This DMap should never be empty , fanSubscribedParent :: !(EventSubscription x) #ifdef DEBUG_NODEIDS , fanSubscribedNodeId :: Int #endif } -data Fan x k - = Fan { fanParent :: !(Event x (DMap k Identity)) - , fanSubscribed :: !(IORef (Maybe (FanSubscribed x k))) +data Fan x k v + = Fan { fanParent :: !(Event x (DMap k v)) + , fanSubscribed :: !(IORef (Maybe (FanSubscribed x k v))) } data SwitchSubscribed x a @@ -1525,7 +1526,7 @@ fanInt p = return (EventSubscription (FastWeakBag.remove t) $! EventSubscribed heightRef $! toAny (_fanInt_subscriptionRef self, t), IntMap.lookup k currentOcc) {-# INLINABLE getFanSubscribed #-} -getFanSubscribed :: (HasSpiderTimeline x, GCompare k) => k a -> Fan x k -> Subscriber x a -> EventM x (WeakBagTicket, FanSubscribed x k, Maybe a) +getFanSubscribed :: (HasSpiderTimeline x, GCompare k) => k a -> Fan x k v -> Subscriber x (v a) -> EventM x (WeakBagTicket, FanSubscribed x k v, Maybe (v a)) getFanSubscribed k f sub = do mSubscribed <- liftIO $ readIORef $ fanSubscribed f case mSubscribed of @@ -1559,7 +1560,7 @@ getFanSubscribed k f sub = do liftIO $ writeIORef (fanSubscribed f) $ Just subscribed return (slnForSub, subscribed, coerce $ DMap.lookup k =<< parentOcc) -cleanupFanSubscribed :: GCompare k => (k a, FanSubscribed x k) -> IO () +cleanupFanSubscribed :: GCompare k => (k a, FanSubscribed x k v) -> IO () cleanupFanSubscribed (k, subscribed) = do subscribers <- readIORef $ fanSubscribedSubscribers subscribed let reducedSubscribers = DMap.delete k subscribers @@ -1571,7 +1572,7 @@ cleanupFanSubscribed (k, subscribed) = do else writeIORef (fanSubscribedSubscribers subscribed) $! reducedSubscribers {-# INLINE subscribeFanSubscribed #-} -subscribeFanSubscribed :: GCompare k => k a -> FanSubscribed x k -> Subscriber x a -> IO WeakBagTicket +subscribeFanSubscribed :: GCompare k => k a -> FanSubscribed x k v -> Subscriber x (v a) -> IO WeakBagTicket subscribeFanSubscribed k subscribed sub = do subscribers <- readIORef $ fanSubscribedSubscribers subscribed case DMap.lookup k subscribers of @@ -2047,14 +2048,15 @@ mergeIntCheap d = Event $ \sub -> do ) newtype EventSelector x k = EventSelector { select :: forall a. k a -> Event x a } +newtype EventSelectorG x k v = EventSelectorG { selectG :: forall a. k a -> Event x (v a) } -fan :: (HasSpiderTimeline x, GCompare k) => Event x (DMap k Identity) -> EventSelector x k -fan e = +fanG :: (HasSpiderTimeline x, GCompare k) => Event x (DMap k v) -> EventSelectorG x k v +fanG e = let f = Fan { fanParent = e , fanSubscribed = unsafeNewIORef e Nothing } - in EventSelector $ \k -> eventFan k f + in EventSelectorG $ \k -> eventFan k f runHoldInits :: HasSpiderTimeline x => IORef [SomeHoldInit x] -> IORef [SomeDynInit x] -> IORef [SomeMergeInit x] -> EventM x () runHoldInits holdInitRef dynInitRef mergeInitRef = do @@ -2523,6 +2525,8 @@ instance HasSpiderTimeline x => R.Reflex (SpiderTimeline x) where pushCheap f = SpiderEvent . pushCheap (coerce f) . unSpiderEvent {-# INLINABLE pull #-} pull = SpiderBehavior . pull . coerce + {-# INLINABLE fanG #-} + fanG e = R.EventSelectorG $ SpiderEvent . selectG (fanG (unSpiderEvent e)) {-# INLINABLE mergeG #-} mergeG :: forall (k :: k2 -> *) q (v :: k2 -> *). GCompare k @@ -2530,8 +2534,6 @@ instance HasSpiderTimeline x => R.Reflex (SpiderTimeline x) where -> DMap k q -> R.Event (SpiderTimeline x) (DMap k v) mergeG nt = SpiderEvent . mergeG (unSpiderEvent #. nt) . dynamicConst - {-# INLINABLE fan #-} - fan e = R.EventSelector $ SpiderEvent . select (fan (unSpiderEvent e)) {-# INLINABLE switch #-} switch = SpiderEvent . switch . (coerce :: Behavior x (R.Event (SpiderTimeline x) a) -> Behavior x (Event x a)) . unSpiderBehavior {-# INLINABLE coincidence #-} diff --git a/test/GC.hs b/test/GC.hs index 85be7bde..0fabf7cb 100644 --- a/test/GC.hs +++ b/test/GC.hs @@ -56,8 +56,8 @@ hostPerf ref = S.runSpiderHost $ do { S.subscriberPropagate = S.subscriberPropagate sub } return (s, o)) - $ runIdentity <$> S.select - (S.fan $ S.pushCheap (return . Just . mapKeyValuePairsMonotonic (\(t :=> e) -> WrapArg t :=> Identity e)) response) + $ runIdentity . runIdentity <$> S.selectG + (S.fanG $ S.pushCheap (return . Just . mapKeyValuePairsMonotonic (\(t :=> e) -> WrapArg t :=> Identity e)) response) (WrapArg Request) return $ alignWith (mergeThese (<>)) (flip S.pushCheap eadd $ \_ -> return $ Just $ DMap.singleton Request $ do From dc3ce150b6a88fc29f2ee0bb60a5bc686d2d0cc8 Mon Sep 17 00:00:00 2001 From: David Feuer Date: Sun, 21 Jul 2019 03:30:58 -0400 Subject: [PATCH 153/241] Use unsafePerformIO better (#325) The previous code was struggling to create artificial dependencies to prevent `unsafePerformIO` calls from being floated out of their proper context. Push the context into each `unsafePerformIO` call so the dependency is real. Reading a bit of the resulting Core, I don't expect to see many (if any) performance regressions. Performance will hopefully improve a bit if/when [GHC issue 15127](https://gitlab.haskell.org/ghc/ghc/issues/15127) is fixed. --- src/Reflex/Spider/Internal.hs | 97 ++++++++++++++++++----------------- 1 file changed, 51 insertions(+), 46 deletions(-) diff --git a/src/Reflex/Spider/Internal.hs b/src/Reflex/Spider/Internal.hs index ee7c7a0a..f130a635 100644 --- a/src/Reflex/Spider/Internal.hs +++ b/src/Reflex/Spider/Internal.hs @@ -198,12 +198,6 @@ nextNodeIdRef = unsafePerformIO $ newIORef 1 newNodeId :: IO Int newNodeId = atomicModifyIORef' nextNodeIdRef $ \n -> (succ n, n) - -{-# NOINLINE unsafeNodeId #-} -unsafeNodeId :: a -> Int -unsafeNodeId a = unsafePerformIO $ do - touch a - newNodeId #endif -------------------------------------------------------------------------------- @@ -307,9 +301,10 @@ cacheEvent e = #else Event $ #endif - let mSubscribedRef :: IORef (FastWeak (CacheSubscribed x a)) - !mSubscribedRef = unsafeNewIORef e emptyFastWeak - in \sub -> {-# SCC "cacheEvent" #-} do + unsafePerformIO $ do + mSubscribedRef :: IORef (FastWeak (CacheSubscribed x a)) + <- newIORef emptyFastWeak + pure $ \sub -> {-# SCC "cacheEvent" #-} do #ifdef DEBUG_TRACE_EVENTS unless (BS8.null callSite) $ liftIO $ BS8.hPutStrLn stderr callSite #endif @@ -1177,18 +1172,12 @@ buildDynamic readV0 v' = do return d unsafeBuildDynamic :: BehaviorM x (PatchTarget p) -> Event x p -> Dyn x p -unsafeBuildDynamic readV0 v' = Dyn $ unsafeNewIORef x $ UnsafeDyn x - where x = (readV0, v') +unsafeBuildDynamic readV0 v' = + Dyn $ unsafePerformIO $ newIORef $ UnsafeDyn (readV0, v') -- ResultM can read behaviors and events type ResultM = EventM -{-# NOINLINE unsafeNewIORef #-} -unsafeNewIORef :: a -> b -> IORef b -unsafeNewIORef a b = unsafePerformIO $ do - touch a - newIORef b - instance HasSpiderTimeline x => Functor (Event x) where fmap f = push $ return . Just . f @@ -1201,26 +1190,35 @@ push f e = cacheEvent (pushCheap f e) {-# INLINABLE pull #-} pull :: BehaviorM x a -> Behavior x a -pull a = behaviorPull $ Pull - { pullCompute = a - , pullValue = unsafeNewIORef a Nothing +pull a = unsafePerformIO $ do + ref <- newIORef Nothing #ifdef DEBUG_NODEIDS - , pullNodeId = unsafeNodeId a + nid <- newNodeId #endif - } + pure $ behaviorPull $ Pull + { pullCompute = a + , pullValue = ref +#ifdef DEBUG_NODEIDS + , pullNodeId = nid +#endif + } {-# INLINABLE switch #-} switch :: HasSpiderTimeline x => Behavior x (Event x a) -> Event x a -switch a = eventSwitch $ Switch - { switchParent = a - , switchSubscribed = unsafeNewIORef a Nothing - } +switch a = unsafePerformIO $ do + ref <- newIORef Nothing + pure $ eventSwitch $ Switch + { switchParent = a + , switchSubscribed = ref + } coincidence :: HasSpiderTimeline x => Event x (Event x a) -> Event x a -coincidence a = eventCoincidence $ Coincidence - { coincidenceParent = a - , coincidenceSubscribed = unsafeNewIORef a Nothing - } +coincidence a = unsafePerformIO $ do + ref <- newIORef Nothing + pure $ eventCoincidence $ Coincidence + { coincidenceParent = a + , coincidenceSubscribed = ref + } -- Propagate the given event occurrence; before cleaning up, run the given action, which may read the state of events and behaviors run :: forall x b. HasSpiderTimeline x => [DSum (RootTrigger x) Identity] -> ResultM x b -> SpiderHost x b @@ -1424,6 +1422,9 @@ getRootSubscribed k r sub = do when debugPropagate $ putStrLn $ "getRootSubscribed: calling rootInit" uninit <- rootInit r k $ RootTrigger (subs, rootOccurrence r, k) writeIORef uninitRef $! uninit +#ifdef DEBUG_NODEIDS + nid <- newNodeId +#endif let !subscribed = RootSubscribed { rootSubscribedKey = k , rootSubscribedCachedSubscribed = cached @@ -1432,7 +1433,7 @@ getRootSubscribed k r sub = do , rootSubscribedUninit = uninit , rootSubscribedWeakSelf = weakSelf #ifdef DEBUG_NODEIDS - , rootSubscribedNodeId = unsafeNodeId (k, r, subs) + , rootSubscribedNodeId = nid #endif } -- If we die at the same moment that all our children die, they will @@ -1481,16 +1482,10 @@ newFanInt = do , _fanInt_occRef = occRef } -{-# NOINLINE unsafeNewFanInt #-} -unsafeNewFanInt :: b -> FanInt x a -unsafeNewFanInt b = unsafePerformIO $ do - touch b - newFanInt - fanInt :: HasSpiderTimeline x => Event x (IntMap a) -> EventSelectorInt x a -fanInt p = - let self = unsafeNewFanInt p - in EventSelectorInt $ \k -> Event $ \sub -> do +fanInt p = unsafePerformIO $ do + self <- newFanInt + pure $ EventSelectorInt $ \k -> Event $ \sub -> do isEmpty <- liftIO $ FastMutableIntMap.isEmpty (_fanInt_subscribers self) when isEmpty $ do -- This is the first subscriber, so we need to subscribe to our input (subscription, parentOcc) <- subscribeAndRead p $ Subscriber @@ -1544,13 +1539,16 @@ getFanSubscribed k f sub = do subscribersRef <- liftIO $ newIORef $ error "getFanSubscribed: subscribersRef not yet initialized" occRef <- liftIO $ newIORef parentOcc when (isJust parentOcc) $ scheduleClear occRef +#ifdef DEBUG_NODEIDS + nid <- liftIO newNodeId +#endif let subscribed = FanSubscribed { fanSubscribedCachedSubscribed = fanSubscribed f , fanSubscribedOccurrence = occRef , fanSubscribedParent = subscription , fanSubscribedSubscribers = subscribersRef #ifdef DEBUG_NODEIDS - , fanSubscribedNodeId = unsafeNodeId f + , fanSubscribedNodeId = nid #endif } let !self = (k, subscribed) @@ -1610,6 +1608,9 @@ getSwitchSubscribed s sub = do when (isJust parentOcc) $ scheduleClear occRef weakSelf <- liftIO $ newIORef $ error "getSwitchSubscribed: weakSelf not yet initialized" (subs, slnForSub) <- liftIO $ WeakBag.singleton sub weakSelf cleanupSwitchSubscribed +#ifdef DEBUG_NODEIDS + nid <- liftIO newNodeId +#endif let !subscribed = SwitchSubscribed { switchSubscribedCachedSubscribed = switchSubscribed s , switchSubscribedOccurrence = occRef @@ -1622,7 +1623,7 @@ getSwitchSubscribed s sub = do , switchSubscribedCurrentParent = subscriptionRef , switchSubscribedWeakSelf = weakSelf #ifdef DEBUG_NODEIDS - , switchSubscribedNodeId = unsafeNodeId s + , switchSubscribedNodeId = nid #endif } liftIO $ writeIORef weakSelf =<< evaluate =<< mkWeakPtrWithDebug subscribed "switchSubscribedWeakSelf" @@ -1667,6 +1668,9 @@ getCoincidenceSubscribed c sub = do scheduleClear innerSubdRef weakSelf <- liftIO $ newIORef $ error "getCoincidenceSubscribed: weakSelf not yet implemented" (subs, slnForSub) <- liftIO $ WeakBag.singleton sub weakSelf cleanupCoincidenceSubscribed +#ifdef DEBUG_NODEIDS + nid <- liftIO newNodeId +#endif let subscribed = CoincidenceSubscribed { coincidenceSubscribedCachedSubscribed = coincidenceSubscribed c , coincidenceSubscribedOccurrence = occRef @@ -1677,7 +1681,7 @@ getCoincidenceSubscribed c sub = do , coincidenceSubscribedInnerParent = innerSubdRef , coincidenceSubscribedWeakSelf = weakSelf #ifdef DEBUG_NODEIDS - , coincidenceSubscribedNodeId = unsafeNodeId c + , coincidenceSubscribedNodeId = nid #endif } liftIO $ writeIORef weakSelf =<< evaluate =<< mkWeakPtrWithDebug subscribed "CoincidenceSubscribed" @@ -2051,12 +2055,13 @@ newtype EventSelector x k = EventSelector { select :: forall a. k a -> Event x a newtype EventSelectorG x k v = EventSelectorG { selectG :: forall a. k a -> Event x (v a) } fanG :: (HasSpiderTimeline x, GCompare k) => Event x (DMap k v) -> EventSelectorG x k v -fanG e = +fanG e = unsafePerformIO $ do + ref <- newIORef Nothing let f = Fan { fanParent = e - , fanSubscribed = unsafeNewIORef e Nothing + , fanSubscribed = ref } - in EventSelectorG $ \k -> eventFan k f + pure $ EventSelectorG $ \k -> eventFan k f runHoldInits :: HasSpiderTimeline x => IORef [SomeHoldInit x] -> IORef [SomeDynInit x] -> IORef [SomeMergeInit x] -> EventM x () runHoldInits holdInitRef dynInitRef mergeInitRef = do From d410f00c0de3d6286ac37f3a4d2c78ad1f42e2c1 Mon Sep 17 00:00:00 2001 From: Ali Abrar Date: Mon, 29 Jul 2019 15:40:06 -0400 Subject: [PATCH 154/241] Update CONTRIBUTING.md --- CONTRIBUTING.md | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/CONTRIBUTING.md b/CONTRIBUTING.md index fac3017a..507447be 100644 --- a/CONTRIBUTING.md +++ b/CONTRIBUTING.md @@ -30,6 +30,10 @@ One way to think about it is that your commit message should be able to complete #### Body For breaking changes, new features, refactors, or other major changes, the body of the commit message should describe the motivation behind the change in greater detail and may include references to the issue tracker. The body shouldn't repeat code/comments from the diff. +### Guidelines for Pull Requests + +Wherever possible, pull requests should add a single feature or fix a single bug. Pull requests should not bundle several unrelated changes. + ### Code Quality #### Warnings From 90aedfcf5bb6ccfdadeb48c0a0c4bf818bf00043 Mon Sep 17 00:00:00 2001 From: Ali Abrar Date: Mon, 29 Jul 2019 15:49:18 -0400 Subject: [PATCH 155/241] Update CONTRIBUTING.md --- CONTRIBUTING.md | 1 + 1 file changed, 1 insertion(+) diff --git a/CONTRIBUTING.md b/CONTRIBUTING.md index 507447be..92bd9d1b 100644 --- a/CONTRIBUTING.md +++ b/CONTRIBUTING.md @@ -5,6 +5,7 @@ Contributions and issue reports are encouraged and appreciated! - [Opening Issues](#opening-issues) - [Submitting Changes](#submitting-changes) - [Guidelines for Commit Messages](#guidelines-for-commit-messages) + - [Guidelines for Pull Requests](#guidelines-for-pull-requests) - [Code Quality](#code-quality) - [Documentation](#documentation) From 45056ff91977e1e2cbe7b2f3057348c774095d77 Mon Sep 17 00:00:00 2001 From: Ali Abrar Date: Thu, 1 Aug 2019 15:30:12 -0400 Subject: [PATCH 156/241] Loosen monoidal-containers version bounds --- default.nix | 2 +- reflex.cabal | 4 ++-- 2 files changed, 3 insertions(+), 3 deletions(-) diff --git a/default.nix b/default.nix index eab1e197..7c874b3f 100644 --- a/default.nix +++ b/default.nix @@ -11,7 +11,7 @@ }: mkDerivation { pname = "reflex"; - version = "0.6.2.0"; + version = "0.6.2.1"; src = builtins.filterSource (path: type: !(builtins.elem (baseNameOf path) [ ".git" "dist" ])) ./.; libraryHaskellDepends = [ base bifunctors containers dependent-map dependent-sum diff --git a/reflex.cabal b/reflex.cabal index 069a4bc1..807c20b7 100644 --- a/reflex.cabal +++ b/reflex.cabal @@ -1,5 +1,5 @@ Name: reflex -Version: 0.6.2.0 +Version: 0.6.2.1 Synopsis: Higher-order Functional Reactive Programming Description: Reflex is a high-performance, deterministic, higher-order Functional Reactive Programming system License: BSD3 @@ -52,7 +52,7 @@ library profunctors, lens >= 4.7 && < 5, monad-control >= 1.0.1 && < 1.1, - monoidal-containers == 0.4.*, + monoidal-containers >= 0.4 && < 0.6, mtl >= 2.1 && < 2.3, prim-uniq >= 0.1.0.1 && < 0.2, primitive >= 0.5 && < 0.7, From c477539ff2b8321082272beaaf67ba1e2786fac1 Mon Sep 17 00:00:00 2001 From: Ali Abrar Date: Thu, 1 Aug 2019 15:56:52 -0400 Subject: [PATCH 157/241] Update ChangeLog.md --- ChangeLog.md | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/ChangeLog.md b/ChangeLog.md index d2bc088f..bea9795d 100644 --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,6 +1,6 @@ # Revision history for reflex -## Unreleased +## 0.6.2.1 * Generalize `fan` to `fanG` to take a `DMap` with non-`Identity` values. From ce9282a62aef1e9c02cfc2ab508aa0084df61b26 Mon Sep 17 00:00:00 2001 From: Oleg Grenrus Date: Sun, 4 Aug 2019 20:03:27 +0300 Subject: [PATCH 158/241] Add haskell-ci setup --- .travis.yml | 170 +++++++++++++++++++++++++++++++++++++++++++++++ cabal.haskell-ci | 2 + cabal.project | 14 ++++ reflex.cabal | 3 + 4 files changed, 189 insertions(+) create mode 100644 .travis.yml create mode 100644 cabal.haskell-ci create mode 100644 cabal.project diff --git a/.travis.yml b/.travis.yml new file mode 100644 index 00000000..6b81409e --- /dev/null +++ b/.travis.yml @@ -0,0 +1,170 @@ +# This Travis job script has been generated by a script via +# +# haskell-ci '--config=cabal.haskell-ci' 'cabal.project' +# +# For more information, see https://github.com/haskell-CI/haskell-ci +# +# version: 0.3.20190804.2 +# +language: c +dist: xenial +sudo: required +git: + # whether to recursively clone submodules + submodules: false +cache: + directories: + - $HOME/.cabal/packages + - $HOME/.cabal/store +before_cache: + - rm -fv $CABALHOME/packages/hackage.haskell.org/build-reports.log + # remove files that are regenerated by 'cabal update' + - rm -fv $CABALHOME/packages/hackage.haskell.org/00-index.* + - rm -fv $CABALHOME/packages/hackage.haskell.org/*.json + - rm -fv $CABALHOME/packages/hackage.haskell.org/01-index.cache + - rm -fv $CABALHOME/packages/hackage.haskell.org/01-index.tar + - rm -fv $CABALHOME/packages/hackage.haskell.org/01-index.tar.idx + - rm -rfv $CABALHOME/packages/head.hackage +matrix: + include: + - compiler: ghc-8.6.5 + addons: {"apt":{"sources":["hvr-ghc"],"packages":["ghc-8.6.5","cabal-install-2.4"]}} + - compiler: ghc-8.4.4 + addons: {"apt":{"sources":["hvr-ghc"],"packages":["ghc-8.4.4","cabal-install-2.4"]}} + - compiler: ghc-8.2.2 + addons: {"apt":{"sources":["hvr-ghc"],"packages":["ghc-8.2.2","cabal-install-2.4"]}} + - compiler: ghc-8.0.2 + addons: {"apt":{"sources":["hvr-ghc"],"packages":["ghc-8.0.2","cabal-install-2.4"]}} +before_install: + - HC=$(echo "/opt/$CC/bin/ghc" | sed 's/-/\//') + - WITHCOMPILER="-w $HC" + - HCPKG="$HC-pkg" + - unset CC + - CABAL=/opt/ghc/bin/cabal + - CABALHOME=$HOME/.cabal + - export PATH="$CABALHOME/bin:$PATH" + - TOP=$(pwd) + - "HCNUMVER=$(${HC} --numeric-version|perl -ne '/^(\\d+)\\.(\\d+)\\.(\\d+)(\\.(\\d+))?$/; print(10000 * $1 + 100 * $2 + ($3 == 0 ? $5 != 1 : $3))')" + - echo $HCNUMVER + - CABAL="$CABAL -vnormal+nowrap+markoutput" + - set -o pipefail + - | + echo 'function blue(s) { printf "\033[0;34m" s "\033[0m " }' >> .colorful.awk + echo 'BEGIN { state = "output"; }' >> .colorful.awk + echo '/^-----BEGIN CABAL OUTPUT-----$/ { state = "cabal" }' >> .colorful.awk + echo '/^-----END CABAL OUTPUT-----$/ { state = "output" }' >> .colorful.awk + echo '!/^(-----BEGIN CABAL OUTPUT-----|-----END CABAL OUTPUT-----)/ {' >> .colorful.awk + echo ' if (state == "cabal") {' >> .colorful.awk + echo ' print blue($0)' >> .colorful.awk + echo ' } else {' >> .colorful.awk + echo ' print $0' >> .colorful.awk + echo ' }' >> .colorful.awk + echo '}' >> .colorful.awk + - cat .colorful.awk + - | + color_cabal_output () { + awk -f $TOP/.colorful.awk + } + - echo text | color_cabal_output +install: + - ${CABAL} --version + - echo "$(${HC} --version) [$(${HC} --print-project-git-commit-id 2> /dev/null || echo '?')]" + - TEST=--enable-tests + - BENCH=--enable-benchmarks + - HEADHACKAGE=false + - rm -f $CABALHOME/config + - | + echo "verbose: normal +nowrap +markoutput" >> $CABALHOME/config + echo "remote-build-reporting: anonymous" >> $CABALHOME/config + echo "write-ghc-environment-files: always" >> $CABALHOME/config + echo "remote-repo-cache: $CABALHOME/packages" >> $CABALHOME/config + echo "logs-dir: $CABALHOME/logs" >> $CABALHOME/config + echo "world-file: $CABALHOME/world" >> $CABALHOME/config + echo "extra-prog-path: $CABALHOME/bin" >> $CABALHOME/config + echo "symlink-bindir: $CABALHOME/bin" >> $CABALHOME/config + echo "installdir: $CABALHOME/bin" >> $CABALHOME/config + echo "build-summary: $CABALHOME/logs/build.log" >> $CABALHOME/config + echo "store-dir: $CABALHOME/store" >> $CABALHOME/config + echo "install-dirs user" >> $CABALHOME/config + echo " prefix: $CABALHOME" >> $CABALHOME/config + echo "repository hackage.haskell.org" >> $CABALHOME/config + echo " url: http://hackage.haskell.org/" >> $CABALHOME/config + - cat $CABALHOME/config + - rm -fv cabal.project cabal.project.local cabal.project.freeze + - travis_retry ${CABAL} v2-update -v + # Generate cabal.project + - rm -rf cabal.project cabal.project.local cabal.project.freeze + - touch cabal.project + - | + echo "packages: ." >> cabal.project + - | + echo "source-repository-package" >> cabal.project + echo " type: git" >> cabal.project + echo " location: https://github.com/mokus0/dependent-sum.git" >> cabal.project + echo " tag: fe726cfd50997792c691d3009a3ee1ba38c435a5" >> cabal.project + echo " subdir: dependent-sum" >> cabal.project + echo "" >> cabal.project + echo "source-repository-package" >> cabal.project + echo " type: git" >> cabal.project + echo " location: https://github.com/obsidiansystems/dependent-map.git" >> cabal.project + echo " tag: a9a438b1fd974891e4ed57cbd43e305cf7c759a9" >> cabal.project + - "for pkg in $($HCPKG list --simple-output); do echo $pkg | sed 's/-[^-]*$//' | (grep -vE -- '^(reflex)$' || true) | sed 's/^/constraints: /' | sed 's/$/ installed/' >> cabal.project.local; done" + - cat cabal.project || true + - cat cabal.project.local || true + - if [ -f "./configure.ac" ]; then (cd "." && autoreconf -i); fi + - ${CABAL} v2-freeze $WITHCOMPILER ${TEST} ${BENCH} | color_cabal_output + - "cat cabal.project.freeze | sed -E 's/^(constraints: *| *)//' | sed 's/any.//'" + - rm cabal.project.freeze + - ${CABAL} v2-build $WITHCOMPILER ${TEST} ${BENCH} --dep -j2 all | color_cabal_output + - ${CABAL} v2-build $WITHCOMPILER --disable-tests --disable-benchmarks --dep -j2 all | color_cabal_output +script: + - DISTDIR=$(mktemp -d /tmp/dist-test.XXXX) + # Packaging... + - ${CABAL} v2-sdist all | color_cabal_output + # Unpacking... + - mv dist-newstyle/sdist/*.tar.gz ${DISTDIR}/ + - cd ${DISTDIR} || false + - find . -maxdepth 1 -type f -name '*.tar.gz' -exec tar -xvf '{}' \; + - find . -maxdepth 1 -type f -name '*.tar.gz' -exec rm '{}' \; + - PKGDIR_reflex="$(find . -maxdepth 1 -type d -regex '.*/reflex-[0-9.]*')" + # Generate cabal.project + - rm -rf cabal.project cabal.project.local cabal.project.freeze + - touch cabal.project + - | + echo "packages: ${PKGDIR_reflex}" >> cabal.project + - | + echo "source-repository-package" >> cabal.project + echo " type: git" >> cabal.project + echo " location: https://github.com/mokus0/dependent-sum.git" >> cabal.project + echo " tag: fe726cfd50997792c691d3009a3ee1ba38c435a5" >> cabal.project + echo " subdir: dependent-sum" >> cabal.project + echo "" >> cabal.project + echo "source-repository-package" >> cabal.project + echo " type: git" >> cabal.project + echo " location: https://github.com/obsidiansystems/dependent-map.git" >> cabal.project + echo " tag: a9a438b1fd974891e4ed57cbd43e305cf7c759a9" >> cabal.project + - "for pkg in $($HCPKG list --simple-output); do echo $pkg | sed 's/-[^-]*$//' | (grep -vE -- '^(reflex)$' || true) | sed 's/^/constraints: /' | sed 's/$/ installed/' >> cabal.project.local; done" + - cat cabal.project || true + - cat cabal.project.local || true + # Building... + # this builds all libraries and executables (without tests/benchmarks) + - ${CABAL} v2-build $WITHCOMPILER --disable-tests --disable-benchmarks all | color_cabal_output + # Building with tests and benchmarks... + # build & run tests, build benchmarks + - ${CABAL} v2-build $WITHCOMPILER ${TEST} ${BENCH} all | color_cabal_output + # Testing... + - ${CABAL} v2-test $WITHCOMPILER ${TEST} ${BENCH} all | color_cabal_output + # cabal check... + - (cd ${PKGDIR_reflex} && ${CABAL} -vnormal check) + # haddock... + - ${CABAL} v2-haddock $WITHCOMPILER ${TEST} ${BENCH} all | color_cabal_output + # Building without installed constraints for packages in global-db... + - rm -f cabal.project.local + - ${CABAL} v2-build $WITHCOMPILER --disable-tests --disable-benchmarks all | color_cabal_output + # Constraint sets + - rm -rf cabal.project.local + # Constraint set no-th + - ${CABAL} v2-build $WITHCOMPILER --disable-tests --disable-benchmarks --constraint='reflex -use-template-haskell' all | color_cabal_output + +# REGENDATA ["--config=cabal.haskell-ci","cabal.project"] +# EOF diff --git a/cabal.haskell-ci b/cabal.haskell-ci new file mode 100644 index 00000000..13accf9b --- /dev/null +++ b/cabal.haskell-ci @@ -0,0 +1,2 @@ +constraint-set no-th + constraints: reflex -use-template-haskell diff --git a/cabal.project b/cabal.project new file mode 100644 index 00000000..13e0d2af --- /dev/null +++ b/cabal.project @@ -0,0 +1,14 @@ +packages: . + +source-repository-package + type: git + location: https://github.com/mokus0/dependent-sum.git + tag: fe726cfd50997792c691d3009a3ee1ba38c435a5 + subdir: dependent-sum + +-- why 0.3 is not in mokus0 tree? +-- this is no-tag-classes branch from obsidiansystems fork +source-repository-package + type: git + location: https://github.com/obsidiansystems/dependent-map.git + tag: a9a438b1fd974891e4ed57cbd43e305cf7c759a9 diff --git a/reflex.cabal b/reflex.cabal index 807c20b7..cbd5d0ab 100644 --- a/reflex.cabal +++ b/reflex.cabal @@ -17,6 +17,9 @@ extra-source-files: Quickref.md ChangeLog.md +tested-with: + GHC ==8.0.2 || ==8.2.2 || ==8.4.4 || ==8.6.5 + flag use-reflex-optimizer description: Use the GHC plugin Reflex.Optimizer on some of the modules in the package. This is still experimental. default: False From 98dc89088c8a70c20286a4282cfd98de641a8cc2 Mon Sep 17 00:00:00 2001 From: Oleg Grenrus Date: Sun, 4 Aug 2019 20:18:48 +0300 Subject: [PATCH 159/241] First round to fix CI --- .travis.yml | 2 -- cabal.haskell-ci | 3 +++ test/EventWriterT.hs | 5 +++++ test/QueryT.hs | 4 ++++ test/RequesterT.hs | 5 +++++ 5 files changed, 17 insertions(+), 2 deletions(-) diff --git a/.travis.yml b/.travis.yml index 6b81409e..06acfe96 100644 --- a/.travis.yml +++ b/.travis.yml @@ -115,8 +115,6 @@ install: - ${CABAL} v2-freeze $WITHCOMPILER ${TEST} ${BENCH} | color_cabal_output - "cat cabal.project.freeze | sed -E 's/^(constraints: *| *)//' | sed 's/any.//'" - rm cabal.project.freeze - - ${CABAL} v2-build $WITHCOMPILER ${TEST} ${BENCH} --dep -j2 all | color_cabal_output - - ${CABAL} v2-build $WITHCOMPILER --disable-tests --disable-benchmarks --dep -j2 all | color_cabal_output script: - DISTDIR=$(mktemp -d /tmp/dist-test.XXXX) # Packaging... diff --git a/cabal.haskell-ci b/cabal.haskell-ci index 13accf9b..c935ad45 100644 --- a/cabal.haskell-ci +++ b/cabal.haskell-ci @@ -1,2 +1,5 @@ +-- https://github.com/haskell/cabal/issues/6106 +install-dependencies: False + constraint-set no-th constraints: reflex -use-template-haskell diff --git a/test/EventWriterT.hs b/test/EventWriterT.hs index 3f2510a2..014c5a2c 100644 --- a/test/EventWriterT.hs +++ b/test/EventWriterT.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE BangPatterns #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-} @@ -13,6 +14,10 @@ import Data.Functor.Misc import qualified Data.Map as M import Data.These +#if defined(MIN_VERSION_these_lens) || (MIN_VERSION_these(0,8,0) && !MIN_VERSION_these(0,9,0)) +import Data.These.Lens +#endif + import Reflex import Reflex.EventWriter.Base import Test.Run diff --git a/test/QueryT.hs b/test/QueryT.hs index a1948078..ac4add3b 100644 --- a/test/QueryT.hs +++ b/test/QueryT.hs @@ -19,6 +19,10 @@ import Data.Map.Monoidal (MonoidalMap) import Data.Semigroup import Data.These +#if defined(MIN_VERSION_these_lens) || (MIN_VERSION_these(0,8,0) && !MIN_VERSION_these(0,9,0)) +import Data.These.Lens +#endif + import Reflex import Reflex.Patch.MapWithMove import Test.Run diff --git a/test/RequesterT.hs b/test/RequesterT.hs index 6ebed9de..3d61d58d 100644 --- a/test/RequesterT.hs +++ b/test/RequesterT.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE BangPatterns #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-} @@ -15,6 +16,10 @@ import Data.Functor.Misc import qualified Data.Map as M import Data.These +#if defined(MIN_VERSION_these_lens) || (MIN_VERSION_these(0,8,0) && !MIN_VERSION_these(0,9,0)) +import Data.These.Lens +#endif + import Reflex import Reflex.Requester.Base import Reflex.Requester.Class From 61b5222aac66701e794f265d53b9ab4bd2bae09d Mon Sep 17 00:00:00 2001 From: Oleg Grenrus Date: Sun, 4 Aug 2019 21:18:30 +0300 Subject: [PATCH 160/241] Allow these-1, HLint fixes --- .travis.yml | 10 +++++++++ cabal.project | 5 +++++ reflex.cabal | 37 ++++++++++++++++++++++++++++++---- src/Reflex/Class.hs | 12 +++++++++++ src/Reflex/Collection.hs | 4 ++++ src/Reflex/Dynamic/TH.hs | 2 +- src/Reflex/EventWriter/Base.hs | 2 +- src/Reflex/Profiled.hs | 6 +++--- src/Reflex/Pure.hs | 5 ----- src/Reflex/Spider/Internal.hs | 10 +++++++++ 10 files changed, 79 insertions(+), 14 deletions(-) diff --git a/.travis.yml b/.travis.yml index 06acfe96..e3aa3179 100644 --- a/.travis.yml +++ b/.travis.yml @@ -108,6 +108,11 @@ install: echo " type: git" >> cabal.project echo " location: https://github.com/obsidiansystems/dependent-map.git" >> cabal.project echo " tag: a9a438b1fd974891e4ed57cbd43e305cf7c759a9" >> cabal.project + echo "" >> cabal.project + echo "source-repository-package" >> cabal.project + echo " type: git" >> cabal.project + echo " location: https://github.com/phadej/monoidal-containers.git" >> cabal.project + echo " tag: f8860ba08385f77128efb45fb9193e6d287e893f" >> cabal.project - "for pkg in $($HCPKG list --simple-output); do echo $pkg | sed 's/-[^-]*$//' | (grep -vE -- '^(reflex)$' || true) | sed 's/^/constraints: /' | sed 's/$/ installed/' >> cabal.project.local; done" - cat cabal.project || true - cat cabal.project.local || true @@ -141,6 +146,11 @@ script: echo " type: git" >> cabal.project echo " location: https://github.com/obsidiansystems/dependent-map.git" >> cabal.project echo " tag: a9a438b1fd974891e4ed57cbd43e305cf7c759a9" >> cabal.project + echo "" >> cabal.project + echo "source-repository-package" >> cabal.project + echo " type: git" >> cabal.project + echo " location: https://github.com/phadej/monoidal-containers.git" >> cabal.project + echo " tag: f8860ba08385f77128efb45fb9193e6d287e893f" >> cabal.project - "for pkg in $($HCPKG list --simple-output); do echo $pkg | sed 's/-[^-]*$//' | (grep -vE -- '^(reflex)$' || true) | sed 's/^/constraints: /' | sed 's/$/ installed/' >> cabal.project.local; done" - cat cabal.project || true - cat cabal.project.local || true diff --git a/cabal.project b/cabal.project index 13e0d2af..8b059a80 100644 --- a/cabal.project +++ b/cabal.project @@ -12,3 +12,8 @@ source-repository-package type: git location: https://github.com/obsidiansystems/dependent-map.git tag: a9a438b1fd974891e4ed57cbd43e305cf7c759a9 + +source-repository-package + type: git + location: https://github.com/phadej/monoidal-containers.git + tag: f8860ba08385f77128efb45fb9193e6d287e893f diff --git a/reflex.cabal b/reflex.cabal index cbd5d0ab..cabd96c4 100644 --- a/reflex.cabal +++ b/reflex.cabal @@ -40,6 +40,11 @@ flag fast-weak default: False manual: True +flag split-these + description: Use split these/semialign packages + manual: False + default: True + library hs-source-dirs: src build-depends: @@ -58,21 +63,26 @@ library monoidal-containers >= 0.4 && < 0.6, mtl >= 2.1 && < 2.3, prim-uniq >= 0.1.0.1 && < 0.2, - primitive >= 0.5 && < 0.7, + primitive >= 0.5 && < 0.8, random == 1.1.*, ref-tf == 0.4.*, reflection == 2.1.*, semigroupoids >= 4.0 && < 6, - semigroups >= 0.16 && < 0.19, + semigroups >= 0.16 && < 0.20, stm >= 2.4 && < 2.6, syb >= 0.5 && < 0.8, - these >= 0.4 && < 0.9, time >= 1.4 && < 1.9, transformers >= 0.2, transformers-compat >= 0.3, unbounded-delays >= 0.1.0.0 && < 0.2, witherable >= 0.2 && < 0.4 + if flag(split-these) + build-depends: these >= 1 && <1.1, + semialign >=1 && <1.1 + else + build-depends: these >= 0.4 && <0.9 + exposed-modules: Data.AppendMap, Data.FastMutableIntMap, @@ -209,7 +219,8 @@ test-suite hlint , directory , filepath , filemanip - , hlint + -- newer versions need ghc-lib-parser, and have failing hints + , hlint <2.1 if impl(ghcjs) buildable: False @@ -228,6 +239,10 @@ test-suite EventWriterT , transformers , reflex , ref-tf + + if flag(split-these) + build-depends: these-lens + other-modules: Reflex.Test Reflex.TestPlan @@ -235,6 +250,7 @@ test-suite EventWriterT Reflex.Plan.Pure Test.Run + test-suite RequesterT type: exitcode-stdio-1.0 main-is: RequesterT.hs @@ -250,9 +266,14 @@ test-suite RequesterT , transformers , reflex , ref-tf + + if flag(split-these) + build-depends: these-lens + other-modules: Reflex.TestPlan Reflex.Plan.Pure + Test.Run test-suite QueryT type: exitcode-stdio-1.0 @@ -271,6 +292,10 @@ test-suite QueryT , semigroups , these , transformers + + if flag(split-these) + build-depends: semialign, these-lens + other-modules: Test.Run Reflex.TestPlan @@ -291,6 +316,10 @@ test-suite GC-Semantics , transformers , reflex , ref-tf + + if flag(split-these) + build-depends: semialign + if impl(ghc < 8) build-depends: semigroups other-modules: diff --git a/src/Reflex/Class.hs b/src/Reflex/Class.hs index af36a244..36f19832 100644 --- a/src/Reflex/Class.hs +++ b/src/Reflex/Class.hs @@ -173,6 +173,14 @@ module Reflex.Class , slowHeadE ) where +#if defined(MIN_VERSION_semialign) +import Prelude hiding (zip, zipWith) + +#if MIN_VERSION_these(0,8,0) +import Data.These.Combinators (justThese) +#endif +#endif + import Control.Applicative import Control.Monad.Identity import Control.Monad.Reader @@ -1063,6 +1071,10 @@ instance Reflex t => Align (Event t) where instance Reflex t => Semialign (Event t) where #endif align = alignEventWithMaybe Just + +#if defined(MIN_VERSION_semialign) + zip x y = mapMaybe justThese $ align x y +#endif -- | Create a new 'Event' that only occurs if the supplied 'Event' occurs and diff --git a/src/Reflex/Collection.hs b/src/Reflex/Collection.hs index a2d7e6b8..16a55c09 100644 --- a/src/Reflex/Collection.hs +++ b/src/Reflex/Collection.hs @@ -27,6 +27,10 @@ module Reflex.Collection , simpleList ) where +#if defined(MIN_VERSION_semialign) +import Prelude hiding (zip, zipWith) +#endif + import Control.Monad.Identity import Data.Align import Data.Functor.Misc diff --git a/src/Reflex/Dynamic/TH.hs b/src/Reflex/Dynamic/TH.hs index 0d2f1d7e..06109d24 100644 --- a/src/Reflex/Dynamic/TH.hs +++ b/src/Reflex/Dynamic/TH.hs @@ -81,7 +81,7 @@ mkDynPure = QuasiQuoter } mkDynExp :: String -> Q Exp -mkDynExp s = case Hs.parseExpWithMode (Hs.defaultParseMode { Hs.extensions = [ Hs.EnableExtension Hs.TemplateHaskell ] }) s of +mkDynExp s = case Hs.parseExpWithMode Hs.defaultParseMode { Hs.extensions = [ Hs.EnableExtension Hs.TemplateHaskell ] } s of Hs.ParseFailed (Hs.SrcLoc _ l c) err -> fail $ "mkDyn:" <> show l <> ":" <> show c <> ": " <> err Hs.ParseOk e -> qDynPure $ return $ everywhere (id `extT` reinstateUnqDyn) $ Hs.toExp $ everywhere (id `extT` antiE) e where TH.Name (TH.OccName occName) (TH.NameG _ _ (TH.ModName modName)) = 'unqMarker diff --git a/src/Reflex/EventWriter/Base.hs b/src/Reflex/EventWriter/Base.hs index 65b046f7..517af0db 100644 --- a/src/Reflex/EventWriter/Base.hs +++ b/src/Reflex/EventWriter/Base.hs @@ -52,7 +52,7 @@ import qualified Data.Map as Map import Data.Semigroup import Data.Some (Some) import Data.Tuple -import Data.Type.Equality hiding (apply) +import Data.Type.Equality import Unsafe.Coerce diff --git a/src/Reflex/Profiled.hs b/src/Reflex/Profiled.hs index 6a9b19d6..9b8a18e8 100644 --- a/src/Reflex/Profiled.hs +++ b/src/Reflex/Profiled.hs @@ -79,9 +79,9 @@ getCostCentreStack = go [] go (cc : l) parent toCostCentreTree :: Ptr CostCentreStack -> Int -> IO CostCentreTree -toCostCentreTree ccs n = do - ccList <- getCostCentreStack ccs - return $ foldr (\cc child -> CostCentreTree 0 n $ Map.singleton cc child) (CostCentreTree n n mempty) ccList +toCostCentreTree ccs n = + foldr (\cc child -> CostCentreTree 0 n $ Map.singleton cc child) (CostCentreTree n n mempty) + <$> getCostCentreStack ccs getCostCentreTree :: IO CostCentreTree getCostCentreTree = do diff --git a/src/Reflex/Pure.hs b/src/Reflex/Pure.hs index 73574703..7bdb58bc 100644 --- a/src/Reflex/Pure.hs +++ b/src/Reflex/Pure.hs @@ -31,14 +31,9 @@ module Reflex.Pure , Incremental (..) ) where -#if !MIN_VERSION_base(4,8,0) -import Control.Applicative -#endif - import Control.Monad import Data.Dependent.Map (DMap, GCompare) import qualified Data.Dependent.Map as DMap -import Data.Functor.Identity import Data.IntMap (IntMap) import qualified Data.IntMap as IntMap import Data.Maybe diff --git a/src/Reflex/Spider/Internal.hs b/src/Reflex/Spider/Internal.hs index f130a635..ca17c408 100644 --- a/src/Reflex/Spider/Internal.hs +++ b/src/Reflex/Spider/Internal.hs @@ -68,6 +68,12 @@ import System.IO.Unsafe import System.Mem.Weak import Unsafe.Coerce +#if defined(MIN_VERSION_semialign) +#if MIN_VERSION_these(0,8,0) +import Data.These.Combinators (justThese) +#endif +#endif + #ifdef DEBUG_CYCLES import Control.Monad.State hiding (forM, forM_, mapM, mapM_, sequence) import Data.List.NonEmpty (NonEmpty (..), nonEmpty) @@ -1139,6 +1145,10 @@ instance HasSpiderTimeline x => Semialign (Event x) where align ea eb = mapMaybe dmapToThese $ mergeG coerce $ dynamicConst $ DMap.fromDistinctAscList [LeftTag :=> ea, RightTag :=> eb] +#if defined(MIN_VERSION_semialign) + zip x y = mapMaybe justThese $ align x y +#endif + data DynType x p = UnsafeDyn !(BehaviorM x (PatchTarget p), Event x p) | BuildDyn !(EventM x (PatchTarget p), Event x p) | HoldDyn !(Hold x p) From 5a8abe2acabf8b3acebe93503837384d663da5c2 Mon Sep 17 00:00:00 2001 From: Oleg Grenrus Date: Sun, 4 Aug 2019 22:22:13 +0300 Subject: [PATCH 161/241] Drop semigroups dependency ... and transformers-compat As GHC-8.0 has Data.Semigroup Also dependent-sum is released. --- cabal.project | 6 ------ reflex.cabal | 7 +------ src/Reflex/Class.hs | 12 ------------ src/Reflex/Patch/IntMap.hs | 8 -------- src/Reflex/Patch/Map.hs | 8 -------- 5 files changed, 1 insertion(+), 40 deletions(-) diff --git a/cabal.project b/cabal.project index 8b059a80..292a9828 100644 --- a/cabal.project +++ b/cabal.project @@ -1,11 +1,5 @@ packages: . -source-repository-package - type: git - location: https://github.com/mokus0/dependent-sum.git - tag: fe726cfd50997792c691d3009a3ee1ba38c435a5 - subdir: dependent-sum - -- why 0.3 is not in mokus0 tree? -- this is no-tag-classes branch from obsidiansystems fork source-repository-package diff --git a/reflex.cabal b/reflex.cabal index cabd96c4..cf7470fa 100644 --- a/reflex.cabal +++ b/reflex.cabal @@ -68,12 +68,10 @@ library ref-tf == 0.4.*, reflection == 2.1.*, semigroupoids >= 4.0 && < 6, - semigroups >= 0.16 && < 0.20, stm >= 2.4 && < 2.6, syb >= 0.5 && < 0.8, time >= 1.4 && < 1.9, - transformers >= 0.2, - transformers-compat >= 0.3, + transformers >= 0.5.2.0, unbounded-delays >= 0.1.0.0 && < 0.2, witherable >= 0.2 && < 0.4 @@ -289,7 +287,6 @@ test-suite QueryT , mtl , ref-tf , reflex - , semigroups , these , transformers @@ -320,8 +317,6 @@ test-suite GC-Semantics if flag(split-these) build-depends: semialign - if impl(ghc < 8) - build-depends: semigroups other-modules: Reflex.Plan.Pure Reflex.Plan.Reflex diff --git a/src/Reflex/Class.hs b/src/Reflex/Class.hs index 36f19832..5cb67683 100644 --- a/src/Reflex/Class.hs +++ b/src/Reflex/Class.hs @@ -677,11 +677,7 @@ instance (Num a, Reflex t) => Num (Dynamic t a) where instance (Reflex t, Semigroup a) => Semigroup (Behavior t a) where a <> b = pull $ liftM2 (<>) (sample a) (sample b) sconcat = pull . fmap sconcat . mapM sample -#if MIN_VERSION_semigroups(0,17,0) stimes n = fmap $ stimes n -#else - times1p n = fmap $ times1p n -#endif -- | Alias for 'mapMaybe' fmapMaybe :: Filterable f => (a -> Maybe b) -> f a -> f b @@ -879,11 +875,7 @@ traceEventWith f = push $ \x -> trace (f x) $ return $ Just x instance (Semigroup a, Reflex t) => Semigroup (Event t a) where (<>) = alignWith (mergeThese (<>)) sconcat = fmap sconcat . mergeList . toList -#if MIN_VERSION_semigroups(0,17,0) stimes n = fmap $ stimes n -#else - times1p n = fmap $ times1p n -#endif instance (Semigroup a, Reflex t) => Monoid (Event t a) where mempty = never @@ -1116,11 +1108,7 @@ zipDynWith f da db = instance (Reflex t, Semigroup a) => Semigroup (Dynamic t a) where (<>) = zipDynWith (<>) -#if MIN_VERSION_semigroups(0,17,0) stimes n = fmap $ stimes n -#else - times1p n = fmap $ times1p n -#endif instance (Reflex t, Monoid a) => Monoid (Dynamic t a) where mconcat = distributeListOverDynWith mconcat diff --git a/src/Reflex/Patch/IntMap.hs b/src/Reflex/Patch/IntMap.hs index 3f9a7fb2..3aba432f 100644 --- a/src/Reflex/Patch/IntMap.hs +++ b/src/Reflex/Patch/IntMap.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveFoldable #-} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE DeriveTraversable #-} @@ -33,14 +32,7 @@ instance Patch (PatchIntMap a) where instance Semigroup (PatchIntMap v) where PatchIntMap a <> PatchIntMap b = PatchIntMap $ a `mappend` b --TODO: Add a semigroup instance for Map -- PatchMap is idempotent, so stimes n is id for every n -#if MIN_VERSION_semigroups(0,17,0) stimes = stimesIdempotentMonoid -#else - times1p n x = case compare n 0 of - LT -> error "stimesIdempotentMonoid: negative multiplier" - EQ -> mempty - GT -> x -#endif -- | Map a function @Int -> a -> b@ over all @a@s in the given @'PatchIntMap' a@ -- (that is, all inserts/updates), producing a @PatchIntMap b@. diff --git a/src/Reflex/Patch/Map.hs b/src/Reflex/Patch/Map.hs index 4d22a058..d0812ae3 100644 --- a/src/Reflex/Patch/Map.hs +++ b/src/Reflex/Patch/Map.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE CPP #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE TypeFamilies #-} -- | 'Patch'es on 'Map' that consist only of insertions (including overwrites) @@ -35,14 +34,7 @@ instance Ord k => Patch (PatchMap k v) where instance Ord k => Semigroup (PatchMap k v) where PatchMap a <> PatchMap b = PatchMap $ a `mappend` b --TODO: Add a semigroup instance for Map -- PatchMap is idempotent, so stimes n is id for every n -#if MIN_VERSION_semigroups(0,17,0) stimes = stimesIdempotentMonoid -#else - times1p n x = case compare n 0 of - LT -> error "stimesIdempotentMonoid: negative multiplier" - EQ -> mempty - GT -> x -#endif -- | The empty 'PatchMap' contains no insertions or deletions instance Ord k => Monoid (PatchMap k v) where From a5f288c5c42d40cad6f671924ad854f89c376740 Mon Sep 17 00:00:00 2001 From: Oleg Grenrus Date: Sun, 4 Aug 2019 22:45:50 +0300 Subject: [PATCH 162/241] Try GHCJS on CI --- .travis.yml | 40 +++++++++++++++++++++++++--------------- cabal.haskell-ci | 2 ++ reflex.cabal | 3 ++- 3 files changed, 29 insertions(+), 16 deletions(-) diff --git a/.travis.yml b/.travis.yml index e3aa3179..551b0735 100644 --- a/.travis.yml +++ b/.travis.yml @@ -7,7 +7,7 @@ # version: 0.3.20190804.2 # language: c -dist: xenial +dist: bionic sudo: required git: # whether to recursively clone submodules @@ -27,6 +27,8 @@ before_cache: - rm -rfv $CABALHOME/packages/head.hackage matrix: include: + - compiler: ghcjs-8.4 + addons: {"apt":{"sources":["hvr-ghc"],"packages":["ghcjs-8.4","cabal-install-3.0"]}} - compiler: ghc-8.6.5 addons: {"apt":{"sources":["hvr-ghc"],"packages":["ghc-8.6.5","cabal-install-2.4"]}} - compiler: ghc-8.4.4 @@ -36,8 +38,25 @@ matrix: - compiler: ghc-8.0.2 addons: {"apt":{"sources":["hvr-ghc"],"packages":["ghc-8.0.2","cabal-install-2.4"]}} before_install: + - | + if [ "$TRAVIS_OS_NAME" = "linux" ]; then + sudo add-apt-repository -y ppa:hvr/ghc; + sudo add-apt-repository -y ppa:hvr/ghcjs; + sudo apt-get update; + sudo apt-get install $CC cabal-install-3.0; + fi - HC=$(echo "/opt/$CC/bin/ghc" | sed 's/-/\//') - WITHCOMPILER="-w $HC" + - | + if echo $CC | grep -q ghcjs; then + GHCJS=true + HC=${HC}js + WITHCOMPILER="--ghcjs ${WITHCOMPILER}js" + else + GHCJS=false; + fi + - if $GHCJS ; then sudo apt-get install -y ghc-8.6.5 ; fi + - if $GHCJS ; then PATH="/opt/ghc/8.6.5/bin:$PATH" ; fi - HCPKG="$HC-pkg" - unset CC - CABAL=/opt/ghc/bin/cabal @@ -69,6 +88,8 @@ before_install: install: - ${CABAL} --version - echo "$(${HC} --version) [$(${HC} --print-project-git-commit-id 2> /dev/null || echo '?')]" + - node --version + - echo $GHCJS - TEST=--enable-tests - BENCH=--enable-benchmarks - HEADHACKAGE=false @@ -92,18 +113,13 @@ install: - cat $CABALHOME/config - rm -fv cabal.project cabal.project.local cabal.project.freeze - travis_retry ${CABAL} v2-update -v + - if $GHCJS ; then ${CABAL} v2-install -w ghc-8.6.5 happy ; fi # Generate cabal.project - rm -rf cabal.project cabal.project.local cabal.project.freeze - touch cabal.project - | echo "packages: ." >> cabal.project - | - echo "source-repository-package" >> cabal.project - echo " type: git" >> cabal.project - echo " location: https://github.com/mokus0/dependent-sum.git" >> cabal.project - echo " tag: fe726cfd50997792c691d3009a3ee1ba38c435a5" >> cabal.project - echo " subdir: dependent-sum" >> cabal.project - echo "" >> cabal.project echo "source-repository-package" >> cabal.project echo " type: git" >> cabal.project echo " location: https://github.com/obsidiansystems/dependent-map.git" >> cabal.project @@ -136,12 +152,6 @@ script: - | echo "packages: ${PKGDIR_reflex}" >> cabal.project - | - echo "source-repository-package" >> cabal.project - echo " type: git" >> cabal.project - echo " location: https://github.com/mokus0/dependent-sum.git" >> cabal.project - echo " tag: fe726cfd50997792c691d3009a3ee1ba38c435a5" >> cabal.project - echo " subdir: dependent-sum" >> cabal.project - echo "" >> cabal.project echo "source-repository-package" >> cabal.project echo " type: git" >> cabal.project echo " location: https://github.com/obsidiansystems/dependent-map.git" >> cabal.project @@ -161,11 +171,11 @@ script: # build & run tests, build benchmarks - ${CABAL} v2-build $WITHCOMPILER ${TEST} ${BENCH} all | color_cabal_output # Testing... - - ${CABAL} v2-test $WITHCOMPILER ${TEST} ${BENCH} all | color_cabal_output + - if ! $GHCJS && [ $HCNUMVER -ge 80000 ] && [ $HCNUMVER -lt 80606 ] ; then ${CABAL} v2-test $WITHCOMPILER ${TEST} ${BENCH} all | color_cabal_output ; fi # cabal check... - (cd ${PKGDIR_reflex} && ${CABAL} -vnormal check) # haddock... - - ${CABAL} v2-haddock $WITHCOMPILER ${TEST} ${BENCH} all | color_cabal_output + - if ! $GHCJS && [ $HCNUMVER -ge 80000 ] && [ $HCNUMVER -lt 80606 ] ; then ${CABAL} v2-haddock $WITHCOMPILER ${TEST} ${BENCH} all | color_cabal_output ; fi # Building without installed constraints for packages in global-db... - rm -f cabal.project.local - ${CABAL} v2-build $WITHCOMPILER --disable-tests --disable-benchmarks all | color_cabal_output diff --git a/cabal.haskell-ci b/cabal.haskell-ci index c935ad45..608074ba 100644 --- a/cabal.haskell-ci +++ b/cabal.haskell-ci @@ -1,3 +1,5 @@ +distribution: bionic + -- https://github.com/haskell/cabal/issues/6106 install-dependencies: False diff --git a/reflex.cabal b/reflex.cabal index cf7470fa..e4c60f7b 100644 --- a/reflex.cabal +++ b/reflex.cabal @@ -18,7 +18,8 @@ extra-source-files: ChangeLog.md tested-with: - GHC ==8.0.2 || ==8.2.2 || ==8.4.4 || ==8.6.5 + GHC ==8.0.2 || ==8.2.2 || ==8.4.4 || ==8.6.5, + GHCJS ==8.4 flag use-reflex-optimizer description: Use the GHC plugin Reflex.Optimizer on some of the modules in the package. This is still experimental. From 646e1c7250480809c57f8b545f93eb0928c881b7 Mon Sep 17 00:00:00 2001 From: Oleg Grenrus Date: Sun, 4 Aug 2019 22:56:27 +0300 Subject: [PATCH 163/241] Another try --- .travis.yml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/.travis.yml b/.travis.yml index 551b0735..c4092af2 100644 --- a/.travis.yml +++ b/.travis.yml @@ -113,7 +113,7 @@ install: - cat $CABALHOME/config - rm -fv cabal.project cabal.project.local cabal.project.freeze - travis_retry ${CABAL} v2-update -v - - if $GHCJS ; then ${CABAL} v2-install -w ghc-8.6.5 happy ; fi + - if $GHCJS ; then (cd /tmp && ${CABAL} v2-install -w ghc-8.6.5 happy) ; fi # Generate cabal.project - rm -rf cabal.project cabal.project.local cabal.project.freeze - touch cabal.project From f79064d9d1acdd2a0e2b27662c744dec96a8a0f0 Mon Sep 17 00:00:00 2001 From: Ali Abrar Date: Sun, 4 Aug 2019 20:55:20 -0400 Subject: [PATCH 164/241] cabal: Remove overridden dependent-map-0.3 --- cabal.project | 7 ------- 1 file changed, 7 deletions(-) diff --git a/cabal.project b/cabal.project index 292a9828..804999cb 100644 --- a/cabal.project +++ b/cabal.project @@ -1,12 +1,5 @@ packages: . --- why 0.3 is not in mokus0 tree? --- this is no-tag-classes branch from obsidiansystems fork -source-repository-package - type: git - location: https://github.com/obsidiansystems/dependent-map.git - tag: a9a438b1fd974891e4ed57cbd43e305cf7c759a9 - source-repository-package type: git location: https://github.com/phadej/monoidal-containers.git From 72d602fcde474682c677158294122e1291c5b184 Mon Sep 17 00:00:00 2001 From: Ali Abrar Date: Sun, 4 Aug 2019 23:15:24 -0400 Subject: [PATCH 165/241] Bump version to 0.6.2.2; Add flag to choose whether to use new split these package --- default.nix | 13 ++++++++----- reflex.cabal | 5 ++--- release.nix | 8 ++++---- 3 files changed, 14 insertions(+), 12 deletions(-) diff --git a/default.nix b/default.nix index 7c874b3f..502ef4c6 100644 --- a/default.nix +++ b/default.nix @@ -7,11 +7,12 @@ , transformers-compat, unbounded-delays, prim-uniq , data-default, filepath, directory, filemanip, ghcjs-base , monoidal-containers, witherable +, semialign ? null, splitThese ? true , useTemplateHaskell ? true }: mkDerivation { pname = "reflex"; - version = "0.6.2.1"; + version = "0.6.2.2"; src = builtins.filterSource (path: type: !(builtins.elem (baseNameOf path) [ ".git" "dist" ])) ./.; libraryHaskellDepends = [ base bifunctors containers dependent-map dependent-sum @@ -26,13 +27,15 @@ mkDerivation { ghcjs-base ] else []) ++ (if !useTemplateHaskell then [] else [ haskell-src-exts haskell-src-meta - ]); + ]) ++ (if splitThese then [ + semialign + ] else []); testHaskellDepends = if ghc.isGhcjs or false then [] else [ hlint filepath directory filemanip ]; - configureFlags = if useTemplateHaskell then [] else [ - "-f-use-template-haskell" - ]; + configureFlags = + stdenv.lib.optional (!useTemplateHaskell) [ "-f-use-template-haskell" ] ++ + stdenv.lib.optional (!splitThese) [ "-f-split-these" ]; homepage = "https://github.com/reflex-frp/reflex"; description = "Higher-order Functional Reactive Programming"; license = stdenv.lib.licenses.bsd3; diff --git a/reflex.cabal b/reflex.cabal index e4c60f7b..64192e8c 100644 --- a/reflex.cabal +++ b/reflex.cabal @@ -1,5 +1,5 @@ Name: reflex -Version: 0.6.2.1 +Version: 0.6.2.2 Synopsis: Higher-order Functional Reactive Programming Description: Reflex is a high-performance, deterministic, higher-order Functional Reactive Programming system License: BSD3 @@ -218,8 +218,7 @@ test-suite hlint , directory , filepath , filemanip - -- newer versions need ghc-lib-parser, and have failing hints - , hlint <2.1 + , hlint >= 2.2.2 && < 2.3 if impl(ghcjs) buildable: False diff --git a/release.nix b/release.nix index 9326cfea..3b101428 100644 --- a/release.nix +++ b/release.nix @@ -3,7 +3,7 @@ let inherit (rp.nixpkgs) lib; compilers = ["ghc8_4" "ghc8_0" "ghcjs8_4" "ghcjs8_0"]; -in lib.genAttrs compilers (ghc: { - reflex-useTemplateHaskell = rp.${ghc}.callPackage ./. { useTemplateHaskell = true; }; - reflex = rp.${ghc}.callPackage ./. { useTemplateHaskell = false; }; -}) +in lib.attrValues (lib.genAttrs compilers (ghc: { + reflex-useTemplateHaskell = rp.${ghc}.callPackage ./. { useTemplateHaskell = true; splitThese = false; }; + reflex = rp.${ghc}.callPackage ./. { useTemplateHaskell = false; splitThese = false; }; +})) From 8ea09b3afaa4a8e3d2c01156a83d774cb0ccb120 Mon Sep 17 00:00:00 2001 From: Ali Abrar Date: Sun, 4 Aug 2019 23:21:28 -0400 Subject: [PATCH 166/241] default.nix: Default splitThese to false in absence of semialign package --- default.nix | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/default.nix b/default.nix index 502ef4c6..3a48df8e 100644 --- a/default.nix +++ b/default.nix @@ -7,7 +7,7 @@ , transformers-compat, unbounded-delays, prim-uniq , data-default, filepath, directory, filemanip, ghcjs-base , monoidal-containers, witherable -, semialign ? null, splitThese ? true +, semialign ? null, splitThese ? (semialign != null) , useTemplateHaskell ? true }: mkDerivation { From 9a63788b30f799e17d31d5fb66fffd56affc6fc1 Mon Sep 17 00:00:00 2001 From: Ali Abrar Date: Mon, 5 Aug 2019 00:02:36 -0400 Subject: [PATCH 167/241] Fix lint failures; Remove overridden dependent-map --- .travis.yml | 10 ---------- cabal.project | 5 ----- src/Data/Functor/Misc.hs | 1 - src/Reflex/Adjustable/Class.hs | 1 - src/Reflex/BehaviorWriter/Class.hs | 1 - src/Reflex/Class.hs | 1 - src/Reflex/EventWriter/Class.hs | 1 - src/Reflex/Host/Class.hs | 1 - src/Reflex/NotReady/Class.hs | 1 - src/Reflex/PerformEvent/Class.hs | 1 - src/Reflex/PostBuild/Class.hs | 1 - src/Reflex/Query/Base.hs | 1 - src/Reflex/Query/Class.hs | 1 - src/Reflex/Requester/Class.hs | 1 - src/Reflex/Spider/Internal.hs | 5 ++--- test/EventWriterT.hs | 5 +---- test/hlint.hs | 1 + 17 files changed, 4 insertions(+), 34 deletions(-) diff --git a/.travis.yml b/.travis.yml index c4092af2..fbed2e39 100644 --- a/.travis.yml +++ b/.travis.yml @@ -120,11 +120,6 @@ install: - | echo "packages: ." >> cabal.project - | - echo "source-repository-package" >> cabal.project - echo " type: git" >> cabal.project - echo " location: https://github.com/obsidiansystems/dependent-map.git" >> cabal.project - echo " tag: a9a438b1fd974891e4ed57cbd43e305cf7c759a9" >> cabal.project - echo "" >> cabal.project echo "source-repository-package" >> cabal.project echo " type: git" >> cabal.project echo " location: https://github.com/phadej/monoidal-containers.git" >> cabal.project @@ -152,11 +147,6 @@ script: - | echo "packages: ${PKGDIR_reflex}" >> cabal.project - | - echo "source-repository-package" >> cabal.project - echo " type: git" >> cabal.project - echo " location: https://github.com/obsidiansystems/dependent-map.git" >> cabal.project - echo " tag: a9a438b1fd974891e4ed57cbd43e305cf7c759a9" >> cabal.project - echo "" >> cabal.project echo "source-repository-package" >> cabal.project echo " type: git" >> cabal.project echo " location: https://github.com/phadej/monoidal-containers.git" >> cabal.project diff --git a/cabal.project b/cabal.project index 804999cb..e6fdbadb 100644 --- a/cabal.project +++ b/cabal.project @@ -1,6 +1 @@ packages: . - -source-repository-package - type: git - location: https://github.com/phadej/monoidal-containers.git - tag: f8860ba08385f77128efb45fb9193e6d287e893f diff --git a/src/Data/Functor/Misc.hs b/src/Data/Functor/Misc.hs index 0f21c808..c5889942 100644 --- a/src/Data/Functor/Misc.hs +++ b/src/Data/Functor/Misc.hs @@ -4,7 +4,6 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} -{-# LANGUAGE KindSignatures #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE PatternSynonyms #-} diff --git a/src/Reflex/Adjustable/Class.hs b/src/Reflex/Adjustable/Class.hs index d5b872ab..5d591a31 100644 --- a/src/Reflex/Adjustable/Class.hs +++ b/src/Reflex/Adjustable/Class.hs @@ -3,7 +3,6 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE LambdaCase #-} -{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} diff --git a/src/Reflex/BehaviorWriter/Class.hs b/src/Reflex/BehaviorWriter/Class.hs index 78320634..32d681cc 100644 --- a/src/Reflex/BehaviorWriter/Class.hs +++ b/src/Reflex/BehaviorWriter/Class.hs @@ -5,7 +5,6 @@ Description: This module defines the 'MonadBehaviorWriter' class {-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FunctionalDependencies #-} -{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE UndecidableInstances #-} #ifdef USE_REFLEX_OPTIMIZER {-# OPTIONS_GHC -fplugin=Reflex.Optimizer #-} diff --git a/src/Reflex/Class.hs b/src/Reflex/Class.hs index 5cb67683..5c718886 100644 --- a/src/Reflex/Class.hs +++ b/src/Reflex/Class.hs @@ -7,7 +7,6 @@ {-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE LambdaCase #-} -{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE NoMonomorphismRestriction #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE RankNTypes #-} diff --git a/src/Reflex/EventWriter/Class.hs b/src/Reflex/EventWriter/Class.hs index 14460380..41aadd35 100644 --- a/src/Reflex/EventWriter/Class.hs +++ b/src/Reflex/EventWriter/Class.hs @@ -2,7 +2,6 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FunctionalDependencies #-} -{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE UndecidableInstances #-} #ifdef USE_REFLEX_OPTIMIZER {-# OPTIONS_GHC -fplugin=Reflex.Optimizer #-} diff --git a/src/Reflex/Host/Class.hs b/src/Reflex/Host/Class.hs index 398d2828..96ca065c 100644 --- a/src/Reflex/Host/Class.hs +++ b/src/Reflex/Host/Class.hs @@ -4,7 +4,6 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE GADTs #-} -{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE RoleAnnotations #-} {-# LANGUAGE ScopedTypeVariables #-} diff --git a/src/Reflex/NotReady/Class.hs b/src/Reflex/NotReady/Class.hs index 7dfabeef..7d1232bd 100644 --- a/src/Reflex/NotReady/Class.hs +++ b/src/Reflex/NotReady/Class.hs @@ -3,7 +3,6 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FunctionalDependencies #-} -{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} #ifdef USE_REFLEX_OPTIMIZER diff --git a/src/Reflex/PerformEvent/Class.hs b/src/Reflex/PerformEvent/Class.hs index dd1ae292..e6d1c402 100644 --- a/src/Reflex/PerformEvent/Class.hs +++ b/src/Reflex/PerformEvent/Class.hs @@ -5,7 +5,6 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FunctionalDependencies #-} -{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} diff --git a/src/Reflex/PostBuild/Class.hs b/src/Reflex/PostBuild/Class.hs index a80e59f3..8b65a9d0 100644 --- a/src/Reflex/PostBuild/Class.hs +++ b/src/Reflex/PostBuild/Class.hs @@ -4,7 +4,6 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FunctionalDependencies #-} -{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} diff --git a/src/Reflex/Query/Base.hs b/src/Reflex/Query/Base.hs index 4b54ef33..a8eae951 100644 --- a/src/Reflex/Query/Base.hs +++ b/src/Reflex/Query/Base.hs @@ -1,7 +1,6 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE InstanceSigs #-} -{-# LANGUAGE KindSignatures #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE RankNTypes #-} diff --git a/src/Reflex/Query/Class.hs b/src/Reflex/Query/Class.hs index 0982c3a0..bec4ace5 100644 --- a/src/Reflex/Query/Class.hs +++ b/src/Reflex/Query/Class.hs @@ -3,7 +3,6 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} -- | diff --git a/src/Reflex/Requester/Class.hs b/src/Reflex/Requester/Class.hs index d23789cc..db4ddb99 100644 --- a/src/Reflex/Requester/Class.hs +++ b/src/Reflex/Requester/Class.hs @@ -6,7 +6,6 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FunctionalDependencies #-} -{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE RecursiveDo #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} diff --git a/src/Reflex/Spider/Internal.hs b/src/Reflex/Spider/Internal.hs index ca17c408..1d1d27ad 100644 --- a/src/Reflex/Spider/Internal.hs +++ b/src/Reflex/Spider/Internal.hs @@ -9,7 +9,6 @@ {-# LANGUAGE GADTs #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE LambdaCase #-} -{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE MultiWayIf #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE RoleAnnotations #-} @@ -1752,7 +1751,7 @@ mergeCheap nt = mergeGCheap' getInitialSubscribers updateMe destroy let s = subscriber $ return k (subscription@(EventSubscription _ parentSubd), parentOcc) <- subscribeAndRead (nt e) s height <- liftIO $ getEventSubscribedHeight parentSubd - return (fmap (\x -> k :=> x) parentOcc, height, k :=> MergeSubscribedParent subscription) + return (fmap (k :=>) parentOcc, height, k :=> MergeSubscribedParent subscription) return ( DMap.fromDistinctAscList $ mapMaybe (\(x, _, _) -> x) subscribers , fmap (\(_, h, _) -> h) subscribers --TODO: Assert that there's no invalidHeight in here , DMap.fromDistinctAscList $ map (\(_, _, x) -> x) subscribers @@ -1800,7 +1799,7 @@ mergeCheapWithMove nt = mergeGCheap' getInitialSubscribers updateMe destroy let s = subscriber $ liftIO $ readIORef keyRef (subscription@(EventSubscription _ parentSubd), parentOcc) <- subscribeAndRead (nt e) s height <- liftIO $ getEventSubscribedHeight parentSubd - return (fmap (\x -> k :=> x) parentOcc, height, k :=> MergeSubscribedParentWithMove subscription keyRef) + return (fmap (k :=>) parentOcc, height, k :=> MergeSubscribedParentWithMove subscription keyRef) return ( DMap.fromDistinctAscList $ mapMaybe (\(x, _, _) -> x) subscribers , fmap (\(_, h, _) -> h) subscribers --TODO: Assert that there's no invalidHeight in here , DMap.fromDistinctAscList $ map (\(_, _, x) -> x) subscribers diff --git a/test/EventWriterT.hs b/test/EventWriterT.hs index 014c5a2c..cd6c3146 100644 --- a/test/EventWriterT.hs +++ b/test/EventWriterT.hs @@ -53,16 +53,13 @@ unwrapApp x appIn = do return e testOrdering :: (Reflex t, Monad m) => Event t () -> EventWriterT t [Int] m () -testOrdering pulse = do - forM_ [10,9..1] $ \i -> tellEvent ([i] <$ pulse) - return () +testOrdering pulse = forM_ [10,9..1] $ \i -> tellEvent ([i] <$ pulse) testSimultaneous :: (Reflex t, Adjustable t m, MonadHold t m) => Event t (These () ()) -> EventWriterT t [Int] m () testSimultaneous pulse = do let e0 = fmapMaybe (^? here) pulse e1 = fmapMaybe (^? there) pulse forM_ [1,3..9] $ \i -> runWithReplace (tellEvent ([i] <$ e0)) $ ffor e1 $ \_ -> tellEvent ([i+1] <$ e0) - return () -- | Test that a widget telling and event which fires at the same time it has been replaced -- doesn't count along with the new widget. diff --git a/test/hlint.hs b/test/hlint.hs index f8b80def..1b5164e1 100644 --- a/test/hlint.hs +++ b/test/hlint.hs @@ -22,6 +22,7 @@ main = do , "--ignore=Use unless" , "--ignore=Reduce duplication" , "--cpp-define=USE_TEMPLATE_HASKELL" + , "--ignore=Use tuple-section" ] recurseInto = and <$> sequence [ fileType ==? Directory From 5fc6f14b53773b1336e7f720703d139ee2262cfe Mon Sep 17 00:00:00 2001 From: Ali Abrar Date: Mon, 5 Aug 2019 00:11:14 -0400 Subject: [PATCH 168/241] cabal: Tighten container version bounds --- reflex.cabal | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/reflex.cabal b/reflex.cabal index 64192e8c..4252b666 100644 --- a/reflex.cabal +++ b/reflex.cabal @@ -54,7 +54,7 @@ library bifunctors >= 5.2 && < 5.6, comonad, constraints-extras >= 0.2, - containers >= 0.5 && < 0.7, + containers >= 0.6 && < 0.7, data-default >= 0.5 && < 0.8, dependent-map >= 0.3 && < 0.4, exception-transformers == 0.4.*, From 2c44f7ac23f0412187e952196a0f131d113d51dd Mon Sep 17 00:00:00 2001 From: Ali Abrar Date: Mon, 5 Aug 2019 00:21:07 -0400 Subject: [PATCH 169/241] cabal: More version bound adjustment --- reflex.cabal | 16 ++++++++-------- 1 file changed, 8 insertions(+), 8 deletions(-) diff --git a/reflex.cabal b/reflex.cabal index 4252b666..6a32d255 100644 --- a/reflex.cabal +++ b/reflex.cabal @@ -52,13 +52,13 @@ library MemoTrie == 0.6.*, base >= 4.9 && < 4.13, bifunctors >= 5.2 && < 5.6, - comonad, - constraints-extras >= 0.2, + comonad >= 5.0.4 && < 5.1, + constraints-extras >= 0.3 && < 0.4, containers >= 0.6 && < 0.7, data-default >= 0.5 && < 0.8, dependent-map >= 0.3 && < 0.4, exception-transformers == 0.4.*, - profunctors, + profunctors >= 5.3 && < 5.5, lens >= 4.7 && < 5, monad-control >= 1.0.1 && < 1.1, monoidal-containers >= 0.4 && < 0.6, @@ -72,7 +72,7 @@ library stm >= 2.4 && < 2.6, syb >= 0.5 && < 0.8, time >= 1.4 && < 1.9, - transformers >= 0.5.2.0, + transformers >= 0.5.6.0 && < 0.6, unbounded-delays >= 0.1.0.0 && < 0.2, witherable >= 0.2 && < 0.4 @@ -156,7 +156,7 @@ library other-extensions: TemplateHaskell else build-depends: - dependent-sum == 0.6.* + dependent-sum >= 0.6 && < 0.7 if flag(fast-weak) && impl(ghcjs) cpp-options: -DGHCJS_FAST_WEAK @@ -180,7 +180,7 @@ test-suite semantics ref-tf, reflex, split, - transformers >= 0.3 + transformers other-modules: Reflex.Bench.Focused Reflex.Plan.Pure @@ -372,7 +372,7 @@ benchmark saulzar-bench ghc-options: -Wall -O2 -rtsopts -threaded build-depends: base, - containers >= 0.5 && < 0.7, + containers, criterion >= 1.1 && < 1.6, deepseq >= 1.3 && < 1.5, dependent-map, @@ -386,7 +386,7 @@ benchmark saulzar-bench split, stm, time, - transformers >= 0.3 + transformers other-modules: Reflex.TestPlan Reflex.Plan.Reflex From 00718056d02ea628c3aa52dbb99b802ee326aecc Mon Sep 17 00:00:00 2001 From: Ali Abrar Date: Mon, 5 Aug 2019 00:30:04 -0400 Subject: [PATCH 170/241] ci, cabal: Update to newly-released monoidal-containers-0.5.0.1 --- .travis.yml | 9 --------- reflex.cabal | 7 ++++--- 2 files changed, 4 insertions(+), 12 deletions(-) diff --git a/.travis.yml b/.travis.yml index fbed2e39..bd084a4f 100644 --- a/.travis.yml +++ b/.travis.yml @@ -119,11 +119,6 @@ install: - touch cabal.project - | echo "packages: ." >> cabal.project - - | - echo "source-repository-package" >> cabal.project - echo " type: git" >> cabal.project - echo " location: https://github.com/phadej/monoidal-containers.git" >> cabal.project - echo " tag: f8860ba08385f77128efb45fb9193e6d287e893f" >> cabal.project - "for pkg in $($HCPKG list --simple-output); do echo $pkg | sed 's/-[^-]*$//' | (grep -vE -- '^(reflex)$' || true) | sed 's/^/constraints: /' | sed 's/$/ installed/' >> cabal.project.local; done" - cat cabal.project || true - cat cabal.project.local || true @@ -147,10 +142,6 @@ script: - | echo "packages: ${PKGDIR_reflex}" >> cabal.project - | - echo "source-repository-package" >> cabal.project - echo " type: git" >> cabal.project - echo " location: https://github.com/phadej/monoidal-containers.git" >> cabal.project - echo " tag: f8860ba08385f77128efb45fb9193e6d287e893f" >> cabal.project - "for pkg in $($HCPKG list --simple-output); do echo $pkg | sed 's/-[^-]*$//' | (grep -vE -- '^(reflex)$' || true) | sed 's/^/constraints: /' | sed 's/$/ installed/' >> cabal.project.local; done" - cat cabal.project || true - cat cabal.project.local || true diff --git a/reflex.cabal b/reflex.cabal index 6a32d255..01e67ed2 100644 --- a/reflex.cabal +++ b/reflex.cabal @@ -61,7 +61,6 @@ library profunctors >= 5.3 && < 5.5, lens >= 4.7 && < 5, monad-control >= 1.0.1 && < 1.1, - monoidal-containers >= 0.4 && < 0.6, mtl >= 2.1 && < 2.3, prim-uniq >= 0.1.0.1 && < 0.2, primitive >= 0.5 && < 0.8, @@ -78,9 +77,11 @@ library if flag(split-these) build-depends: these >= 1 && <1.1, - semialign >=1 && <1.1 + semialign >=1 && <1.1, + monoidal-containers >= 0.5.0.1 && < 0.6 else - build-depends: these >= 0.4 && <0.9 + build-depends: these >= 0.4 && <0.9, + monoidal-containers == 0.5.0.0 exposed-modules: Data.AppendMap, From c31bec293fd4336ca4c65ded1cfda8b4b3b80a88 Mon Sep 17 00:00:00 2001 From: Ali Abrar Date: Mon, 5 Aug 2019 01:07:48 -0400 Subject: [PATCH 171/241] cabal: remove some version bounds --- reflex.cabal | 24 ++++++++++++------------ 1 file changed, 12 insertions(+), 12 deletions(-) diff --git a/reflex.cabal b/reflex.cabal index 01e67ed2..d8f24670 100644 --- a/reflex.cabal +++ b/reflex.cabal @@ -174,7 +174,7 @@ test-suite semantics base, bifunctors, containers, - deepseq >= 1.3 && < 1.5, + deepseq, dependent-map, dependent-sum, mtl, @@ -200,7 +200,7 @@ test-suite CrossImpl containers, dependent-map, dependent-sum, - deepseq >= 1.3 && < 1.5, + deepseq, mtl, transformers, ref-tf, @@ -229,7 +229,7 @@ test-suite EventWriterT hs-source-dirs: test build-depends: base , containers - , deepseq >= 1.3 && < 1.5 + , deepseq , dependent-map , dependent-sum , lens @@ -256,7 +256,7 @@ test-suite RequesterT hs-source-dirs: test build-depends: base , containers - , deepseq >= 1.3 && < 1.5 + , deepseq , dependent-sum , dependent-map , lens @@ -282,7 +282,7 @@ test-suite QueryT , containers , dependent-map , dependent-sum - , deepseq >= 1.3 && < 1.5 + , deepseq , lens , monoidal-containers , mtl @@ -308,7 +308,7 @@ test-suite GC-Semantics , containers , dependent-sum , dependent-map - , deepseq >= 1.3 && < 1.5 + , deepseq , mtl , these , transformers @@ -330,7 +330,7 @@ test-suite rootCleanup hs-source-dirs: test build-depends: base , containers - , deepseq >= 1.3 && < 1.5 + , deepseq , dependent-sum , mtl , reflex @@ -349,8 +349,8 @@ benchmark spider-bench build-depends: base, containers, - criterion >= 1.1 && < 1.6, - deepseq >= 1.3 && < 1.5, + criterion, + deepseq, dependent-map, dependent-sum, ref-tf, @@ -359,7 +359,7 @@ benchmark spider-bench reflex, split, stm, - transformers >= 0.3 + transformers other-modules: Reflex.TestPlan Reflex.Plan.Reflex @@ -374,8 +374,8 @@ benchmark saulzar-bench build-depends: base, containers, - criterion >= 1.1 && < 1.6, - deepseq >= 1.3 && < 1.5, + criterion, + deepseq, dependent-map, dependent-sum, loch-th, From e490ca5a5e0a5920376cdfc15a500a0ceda731dc Mon Sep 17 00:00:00 2001 From: Ali Abrar Date: Mon, 5 Aug 2019 01:16:51 -0400 Subject: [PATCH 172/241] hlint: More linting --- src/Reflex/DynamicWriter/Class.hs | 1 - src/Reflex/PerformEvent/Base.hs | 2 +- src/Reflex/TriggerEvent/Class.hs | 1 - 3 files changed, 1 insertion(+), 3 deletions(-) diff --git a/src/Reflex/DynamicWriter/Class.hs b/src/Reflex/DynamicWriter/Class.hs index 34767c14..1ec33121 100644 --- a/src/Reflex/DynamicWriter/Class.hs +++ b/src/Reflex/DynamicWriter/Class.hs @@ -3,7 +3,6 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FunctionalDependencies #-} -{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE UndecidableInstances #-} #ifdef USE_REFLEX_OPTIMIZER {-# OPTIONS_GHC -fplugin=Reflex.Optimizer #-} diff --git a/src/Reflex/PerformEvent/Base.hs b/src/Reflex/PerformEvent/Base.hs index 59d66586..f502b622 100644 --- a/src/Reflex/PerformEvent/Base.hs +++ b/src/Reflex/PerformEvent/Base.hs @@ -141,7 +141,7 @@ hostPerformEventT a = do case mToPerform of Nothing -> return [result'] Just toPerform -> do - responses <- runHostFrame $ traverseRequesterData (\v -> Identity <$> v) toPerform + responses <- runHostFrame $ traverseRequesterData (Identity <$>) toPerform mrt <- readRef responseTrigger let followupEventTriggers = case mrt of Just rt -> [rt :=> Identity responses] diff --git a/src/Reflex/TriggerEvent/Class.hs b/src/Reflex/TriggerEvent/Class.hs index b9740b25..58eaec7d 100644 --- a/src/Reflex/TriggerEvent/Class.hs +++ b/src/Reflex/TriggerEvent/Class.hs @@ -2,7 +2,6 @@ -- new 'Event's that can be triggered from 'IO'. {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FunctionalDependencies #-} -{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE UndecidableInstances #-} module Reflex.TriggerEvent.Class ( TriggerEvent (..) From 3ca5d070ba72627ca53a773c9dab3064950949ea Mon Sep 17 00:00:00 2001 From: Ali Abrar Date: Mon, 5 Aug 2019 01:47:24 -0400 Subject: [PATCH 173/241] ci: Remove cabal.project.local before building --- .travis.yml | 2 ++ 1 file changed, 2 insertions(+) diff --git a/.travis.yml b/.travis.yml index bd084a4f..e3f79e17 100644 --- a/.travis.yml +++ b/.travis.yml @@ -126,6 +126,7 @@ install: - ${CABAL} v2-freeze $WITHCOMPILER ${TEST} ${BENCH} | color_cabal_output - "cat cabal.project.freeze | sed -E 's/^(constraints: *| *)//' | sed 's/any.//'" - rm cabal.project.freeze + - rm cabal.project.local script: - DISTDIR=$(mktemp -d /tmp/dist-test.XXXX) # Packaging... @@ -145,6 +146,7 @@ script: - "for pkg in $($HCPKG list --simple-output); do echo $pkg | sed 's/-[^-]*$//' | (grep -vE -- '^(reflex)$' || true) | sed 's/^/constraints: /' | sed 's/$/ installed/' >> cabal.project.local; done" - cat cabal.project || true - cat cabal.project.local || true + - rm cabal.project.local # Building... # this builds all libraries and executables (without tests/benchmarks) - ${CABAL} v2-build $WITHCOMPILER --disable-tests --disable-benchmarks all | color_cabal_output From afd44629adae99025cb31feda6b218f8444e13b2 Mon Sep 17 00:00:00 2001 From: Ali Abrar Date: Mon, 5 Aug 2019 02:01:38 -0400 Subject: [PATCH 174/241] cabal: Limit witherable version --- reflex.cabal | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/reflex.cabal b/reflex.cabal index d8f24670..56a095e3 100644 --- a/reflex.cabal +++ b/reflex.cabal @@ -73,7 +73,7 @@ library time >= 1.4 && < 1.9, transformers >= 0.5.6.0 && < 0.6, unbounded-delays >= 0.1.0.0 && < 0.2, - witherable >= 0.2 && < 0.4 + witherable >= 0.2 && < 0.3 if flag(split-these) build-depends: these >= 1 && <1.1, From 28b4addd70a437adbccd75d5728a237f670c3bcf Mon Sep 17 00:00:00 2001 From: Ali Abrar Date: Mon, 5 Aug 2019 01:59:11 -0400 Subject: [PATCH 175/241] cabal: Avoid hlint 2.1.* --- reflex.cabal | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/reflex.cabal b/reflex.cabal index 56a095e3..c944861b 100644 --- a/reflex.cabal +++ b/reflex.cabal @@ -219,7 +219,7 @@ test-suite hlint , directory , filepath , filemanip - , hlint >= 2.2.2 && < 2.3 + , hlint < 2.1 || >= 2.2.2 if impl(ghcjs) buildable: False From 70b7bebd44e7e6507d5e7bb94e1e0e017ef3eccb Mon Sep 17 00:00:00 2001 From: Ali Abrar Date: Mon, 5 Aug 2019 02:06:36 -0400 Subject: [PATCH 176/241] ci: Fix travis config --- .travis.yml | 17 ++++++++++------- 1 file changed, 10 insertions(+), 7 deletions(-) diff --git a/.travis.yml b/.travis.yml index e3f79e17..4384dbfc 100644 --- a/.travis.yml +++ b/.travis.yml @@ -119,14 +119,14 @@ install: - touch cabal.project - | echo "packages: ." >> cabal.project - - "for pkg in $($HCPKG list --simple-output); do echo $pkg | sed 's/-[^-]*$//' | (grep -vE -- '^(reflex)$' || true) | sed 's/^/constraints: /' | sed 's/$/ installed/' >> cabal.project.local; done" - cat cabal.project || true - cat cabal.project.local || true - if [ -f "./configure.ac" ]; then (cd "." && autoreconf -i); fi - ${CABAL} v2-freeze $WITHCOMPILER ${TEST} ${BENCH} | color_cabal_output + - ${CABAL} v2-configure $WITHCOMPILER ${TEST} ${BENCH} | color_cabal_output - "cat cabal.project.freeze | sed -E 's/^(constraints: *| *)//' | sed 's/any.//'" - - rm cabal.project.freeze - - rm cabal.project.local + - rm cabal.project.freeze || true + - rm cabal.project.local || true script: - DISTDIR=$(mktemp -d /tmp/dist-test.XXXX) # Packaging... @@ -143,10 +143,9 @@ script: - | echo "packages: ${PKGDIR_reflex}" >> cabal.project - | - - "for pkg in $($HCPKG list --simple-output); do echo $pkg | sed 's/-[^-]*$//' | (grep -vE -- '^(reflex)$' || true) | sed 's/^/constraints: /' | sed 's/$/ installed/' >> cabal.project.local; done" - cat cabal.project || true - cat cabal.project.local || true - - rm cabal.project.local + - rm cabal.project.local || true # Building... # this builds all libraries and executables (without tests/benchmarks) - ${CABAL} v2-build $WITHCOMPILER --disable-tests --disable-benchmarks all | color_cabal_output @@ -160,12 +159,16 @@ script: # haddock... - if ! $GHCJS && [ $HCNUMVER -ge 80000 ] && [ $HCNUMVER -lt 80606 ] ; then ${CABAL} v2-haddock $WITHCOMPILER ${TEST} ${BENCH} all | color_cabal_output ; fi # Building without installed constraints for packages in global-db... - - rm -f cabal.project.local + - rm -f cabal.project.local || true - ${CABAL} v2-build $WITHCOMPILER --disable-tests --disable-benchmarks all | color_cabal_output # Constraint sets - - rm -rf cabal.project.local + - rm -rf cabal.project.local || true # Constraint set no-th - ${CABAL} v2-build $WITHCOMPILER --disable-tests --disable-benchmarks --constraint='reflex -use-template-haskell' all | color_cabal_output + # Constraint sets + - rm -rf cabal.project.local || true + # Constraint set don't use split these/semialign + - ${CABAL} v2-build $WITHCOMPILER --disable-tests --disable-benchmarks --constraint='reflex -split-these' all | color_cabal_output # REGENDATA ["--config=cabal.haskell-ci","cabal.project"] # EOF From bb75a4be56c07081cdc1988b1b4a9a828d636601 Mon Sep 17 00:00:00 2001 From: Ali Abrar Date: Mon, 5 Aug 2019 02:49:01 -0400 Subject: [PATCH 177/241] changelog: document v0.6.2.2 --- ChangeLog.md | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/ChangeLog.md b/ChangeLog.md index bea9795d..84f0e4d5 100644 --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,5 +1,11 @@ # Revision history for reflex +## 0.6.2.2 + +* Support these >= 1. Add `split-these` flag to control whether to use new these/semialign combination or not. +* Update version bounds to fix some CI failures +* Add travis CI configuration + ## 0.6.2.1 * Generalize `fan` to `fanG` to take a `DMap` with non-`Identity` From d60fcbaf7fd4980a6fafd88ddc824b8edde13902 Mon Sep 17 00:00:00 2001 From: Ali Abrar Date: Mon, 5 Aug 2019 09:16:41 -0400 Subject: [PATCH 178/241] travis: disable benchmarks --- cabal.haskell-ci | 1 + 1 file changed, 1 insertion(+) diff --git a/cabal.haskell-ci b/cabal.haskell-ci index 608074ba..23eef972 100644 --- a/cabal.haskell-ci +++ b/cabal.haskell-ci @@ -2,6 +2,7 @@ distribution: bionic -- https://github.com/haskell/cabal/issues/6106 install-dependencies: False +benchmarks: False constraint-set no-th constraints: reflex -use-template-haskell From 5e037c06c86023c73245b38275c9949e0fb27940 Mon Sep 17 00:00:00 2001 From: David Feuer Date: Mon, 5 Aug 2019 09:35:47 -0400 Subject: [PATCH 179/241] Less unsafeCoerce (#322) * Reduce the use of unsafeCoerce Remove most uses of `unsafeCoerce`. Most of the rest are taken care of in my `mergeG` pull request. --- reflex.cabal | 2 + src/Control/Monad/ReaderIO.hs | 60 ++++++++++++++++++ src/Reflex/Class.hs | 11 ++++ src/Reflex/Profiled.hs | 18 +++--- src/Reflex/Pure.hs | 1 + src/Reflex/Spider/Internal.hs | 112 ++++++++++++++++++++-------------- test/Reflex/Bench/Focused.hs | 12 ++++ 7 files changed, 163 insertions(+), 53 deletions(-) create mode 100644 src/Control/Monad/ReaderIO.hs diff --git a/reflex.cabal b/reflex.cabal index 807c20b7..4e4012a8 100644 --- a/reflex.cabal +++ b/reflex.cabal @@ -56,6 +56,7 @@ library mtl >= 2.1 && < 2.3, prim-uniq >= 0.1.0.1 && < 0.2, primitive >= 0.5 && < 0.7, + profunctors, random == 1.1.*, ref-tf == 0.4.*, reflection == 2.1.*, @@ -71,6 +72,7 @@ library witherable >= 0.2 && < 0.4 exposed-modules: + Control.Monad.ReaderIO Data.AppendMap, Data.FastMutableIntMap, Data.FastWeakBag, diff --git a/src/Control/Monad/ReaderIO.hs b/src/Control/Monad/ReaderIO.hs new file mode 100644 index 00000000..fb5f60c7 --- /dev/null +++ b/src/Control/Monad/ReaderIO.hs @@ -0,0 +1,60 @@ +{-# language RoleAnnotations #-} +{-# language MultiParamTypeClasses #-} +{-# language FlexibleInstances #-} +{-# language CPP #-} +module Control.Monad.ReaderIO + ( + ReaderIO (..) + ) + where + +import Control.Monad.Fix +#if MIN_VERSION_base(4,10,0) +import Control.Applicative +#endif +import Control.Monad +import Control.Monad.Reader.Class +import Control.Monad.IO.Class + +-- | An approximate clone of @RIO@ from the @rio@ package, but not based on +-- @ReaderT@. The trouble with @ReaderT@ is that its third type argument has a +-- @nominal@ role, so we can't coerce through it when it's wrapped in some +-- other @data@ type. Ugh. +newtype ReaderIO e a = ReaderIO { runReaderIO :: e -> IO a } +type role ReaderIO representational representational + +instance Functor (ReaderIO e) where + fmap = liftM + {-# INLINE fmap #-} + a <$ m = m >> pure a + {-# INLINE (<$) #-} + +instance Applicative (ReaderIO e) where + pure a = ReaderIO $ \_ -> pure a + {-# INLINE pure #-} + (<*>) = ap + {-# INLINE (<*>) #-} +#if MIN_VERSION_base(4,10,0) + liftA2 = liftM2 + {-# INLINE liftA2 #-} +#endif + (*>) = (>>) + {-# INLINE (*>) #-} + +instance Monad (ReaderIO e) where + ReaderIO q >>= f = ReaderIO $ \e -> q e >>= \a -> runReaderIO (f a) e + {-# INLINE (>>=) #-} + +instance MonadFix (ReaderIO e) where + mfix f = ReaderIO $ \e -> mfix $ \r -> runReaderIO (f r) e + {-# INLINE mfix #-} + +instance MonadIO (ReaderIO e) where + liftIO m = ReaderIO $ \_ -> m + {-# INLINE liftIO #-} + +instance MonadReader e (ReaderIO e) where + ask = ReaderIO pure + {-# INLINE ask #-} + local f (ReaderIO m) = ReaderIO (m . f) + {-# INLINE local #-} diff --git a/src/Reflex/Class.hs b/src/Reflex/Class.hs index af36a244..916f60c1 100644 --- a/src/Reflex/Class.hs +++ b/src/Reflex/Class.hs @@ -37,6 +37,7 @@ module Reflex.Class , coerceBehavior , coerceEvent , coerceDynamic + , coerceIncremental , MonadSample (..) , MonadHold (..) -- ** 'fan' related types @@ -312,6 +313,10 @@ class ( MonadHold t (PushM t) -- | Construct a 'Coercion' for a 'Dynamic' given an 'Coercion' for its -- occurrence type dynamicCoercion :: Coercion a b -> Coercion (Dynamic t a) (Dynamic t b) + -- | Construct a 'Coercion' for an 'Incremental' given 'Coercion's for its + -- patch target and patch types. + incrementalCoercion + :: Coercion (PatchTarget a) (PatchTarget b) -> Coercion a b -> Coercion (Incremental t a) (Incremental t b) mergeIntIncremental :: Incremental t (PatchIntMap (Event t a)) -> Event t (IntMap a) fanInt :: Event t (IntMap a) -> EventSelectorInt t a @@ -345,6 +350,12 @@ coerceEvent = coerceWith $ eventCoercion Coercion coerceDynamic :: (Reflex t, Coercible a b) => Dynamic t a -> Dynamic t b coerceDynamic = coerceWith $ dynamicCoercion Coercion +-- | Coerce an 'Incremental' between representationally-equivalent value types +coerceIncremental + :: (Reflex t, Coercible a b, Coercible (PatchTarget a) (PatchTarget b)) + => Incremental t a -> Incremental t b +coerceIncremental = coerceWith $ incrementalCoercion Coercion Coercion + -- | Construct a 'Dynamic' from a 'Behavior' and an 'Event'. The 'Behavior' -- __must__ change when and only when the 'Event' fires, such that the -- 'Behavior''s value is always equal to the most recent firing of the 'Event'; diff --git a/src/Reflex/Profiled.hs b/src/Reflex/Profiled.hs index 6a9b19d6..3fa07d58 100644 --- a/src/Reflex/Profiled.hs +++ b/src/Reflex/Profiled.hs @@ -9,6 +9,7 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE PolyKinds #-} +{-# LANGUAGE TypeApplications #-} {-# LANGUAGE RankNTypes #-} -- | -- Module: @@ -151,13 +152,16 @@ instance Reflex t => Reflex (ProfiledTimeline t) where currentIncremental (Incremental_Profiled i) = coerce $ currentIncremental i updatedIncremental (Incremental_Profiled i) = coerce $ profileEvent $ updatedIncremental i incrementalToDynamic (Incremental_Profiled i) = coerce $ incrementalToDynamic i - behaviorCoercion (c :: Coercion a b) = case behaviorCoercion c :: Coercion (Behavior t a) (Behavior t b) of - Coercion -> unsafeCoerce (Coercion :: Coercion (Behavior (ProfiledTimeline t) a) (Behavior (ProfiledTimeline t) a)) --TODO: Figure out how to make this typecheck without the unsafeCoerce - eventCoercion (c :: Coercion a b) = case eventCoercion c :: Coercion (Event t a) (Event t b) of - Coercion -> unsafeCoerce (Coercion :: Coercion (Event (ProfiledTimeline t) a) (Event (ProfiledTimeline t) a)) --TODO: Figure out how to make this typecheck without the unsafeCoerce - dynamicCoercion (c :: Coercion a b) = case dynamicCoercion c :: Coercion (Dynamic t a) (Dynamic t b) of - Coercion -> unsafeCoerce (Coercion :: Coercion (Dynamic (ProfiledTimeline t) a) (Dynamic (ProfiledTimeline t) a)) --TODO: Figure out how to make this typecheck without the unsafeCoerce - mergeIntIncremental = Event_Profiled . mergeIntIncremental . (unsafeCoerce :: Incremental (ProfiledTimeline t) (PatchIntMap (Event (ProfiledTimeline t) a)) -> Incremental t (PatchIntMap (Event t a))) + behaviorCoercion c = + Coercion `trans` behaviorCoercion @t c `trans` Coercion + eventCoercion c = + Coercion `trans` eventCoercion @t c `trans` Coercion + dynamicCoercion c = + Coercion `trans` dynamicCoercion @t c `trans` Coercion + incrementalCoercion c d = + Coercion `trans` incrementalCoercion @t c d `trans` Coercion + mergeIntIncremental = Event_Profiled . mergeIntIncremental . + coerceWith (Coercion `trans` incrementalCoercion Coercion Coercion `trans` Coercion) fanInt (Event_Profiled e) = coerce $ fanInt $ profileEvent e deriving instance Functor (Dynamic t) => Functor (Dynamic (ProfiledTimeline t)) diff --git a/src/Reflex/Pure.hs b/src/Reflex/Pure.hs index 73574703..f24b5196 100644 --- a/src/Reflex/Pure.hs +++ b/src/Reflex/Pure.hs @@ -133,6 +133,7 @@ instance (Enum t, HasTrie t, Ord t) => Reflex (Pure t) where behaviorCoercion Coercion = Coercion eventCoercion Coercion = Coercion dynamicCoercion Coercion = Coercion + incrementalCoercion Coercion Coercion = Coercion fanInt e = EventSelectorInt $ \k -> Event $ \t -> unEvent e t >>= IntMap.lookup k diff --git a/src/Reflex/Spider/Internal.hs b/src/Reflex/Spider/Internal.hs index f130a635..6bef73d3 100644 --- a/src/Reflex/Spider/Internal.hs +++ b/src/Reflex/Spider/Internal.hs @@ -18,6 +18,8 @@ {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE PolyKinds #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE InstanceSigs #-} #ifdef USE_REFLEX_OPTIMIZER @@ -37,7 +39,10 @@ import Control.Monad hiding (forM, forM_, mapM, mapM_) import Control.Monad.Exception import Control.Monad.Identity hiding (forM, forM_, mapM, mapM_) import Control.Monad.Primitive -import Control.Monad.Reader hiding (forM, forM_, mapM, mapM_) +--import Control.Monad.Reader hiding (forM, forM_, mapM, mapM_) +import Control.Monad.Reader.Class +import Control.Monad.IO.Class +import Control.Monad.ReaderIO import Control.Monad.Ref import Data.Align import Data.Coerce @@ -545,6 +550,11 @@ propagateFast a subscribers = withIncreasedDepth $ do toAny :: a -> Any toAny = unsafeCoerce +-- Why do we use Any here, instead of just giving eventSubscribedRetained an +-- existential type? Sadly, GHC does not currently know how to unbox types +-- with existentially quantified fields. So instead we just coerce values +-- to type Any on the way in. Since we never coerce them back, this is +-- perfectly safe. data EventSubscribed x = EventSubscribed { eventSubscribedHeightRef :: {-# UNPACK #-} !(IORef Height) , eventSubscribedRetained :: {-# NOUNPACK #-} !Any @@ -668,7 +678,7 @@ behaviorPull !p = Behavior $ do wi <- liftIO $ mkWeakPtrWithDebug i "InvalidatorPull" parentsRef <- liftIO $ newIORef [] holdInits <- askBehaviorHoldInits - a <- liftIO $ runReaderT (unBehaviorM $ pullCompute p) (Just (wi, parentsRef), holdInits) + a <- liftIO $ runReaderIO (unBehaviorM $ pullCompute p) (Just (wi, parentsRef), holdInits) invsRef <- liftIO . newIORef . maybeToList =<< askInvalidator parents <- liftIO $ readIORef parentsRef let subscribed = PullSubscribed @@ -703,42 +713,46 @@ readBehaviorUntracked b = do -- Dynamic -------------------------------------------------------------------------------- -data Dynamic x p = Dynamic - { dynamicCurrent :: !(Behavior x (PatchTarget p)) +type DynamicS x p = Dynamic x (PatchTarget p) p + +data Dynamic x target p = Dynamic + { dynamicCurrent :: !(Behavior x target) , dynamicUpdated :: Event x p -- This must be lazy; see the comment on holdEvent --TODO: Would this let us eliminate `Dyn`? } -dynamicHold :: Hold x p -> Dynamic x p +deriving instance (HasSpiderTimeline x) => Functor (Dynamic x target) + + + + +dynamicHold :: Hold x p -> DynamicS x p dynamicHold !h = Dynamic { dynamicCurrent = behaviorHold h , dynamicUpdated = eventHold h } -dynamicHoldIdentity :: Hold x (Identity a) -> Dynamic x (Identity a) +dynamicHoldIdentity :: Hold x (Identity a) -> DynamicS x (Identity a) dynamicHoldIdentity = dynamicHold -dynamicConst :: PatchTarget p -> Dynamic x p +dynamicConst :: PatchTarget p -> DynamicS x p dynamicConst !a = Dynamic { dynamicCurrent = behaviorConst a , dynamicUpdated = eventNever } -dynamicDyn :: (HasSpiderTimeline x, Patch p) => Dyn x p -> Dynamic x p +dynamicDyn :: (HasSpiderTimeline x, Patch p) => Dyn x p -> DynamicS x p dynamicDyn !d = Dynamic { dynamicCurrent = behaviorDyn d , dynamicUpdated = eventDyn d } -dynamicDynIdentity :: HasSpiderTimeline x => Dyn x (Identity a) -> Dynamic x (Identity a) +dynamicDynIdentity :: HasSpiderTimeline x => Dyn x (Identity a) -> DynamicS x (Identity a) dynamicDynIdentity = dynamicDyn -------------------------------------------------------------------------------- -- Combinators -------------------------------------------------------------------------------- ---TODO: Figure out why certain things are not 'representational', then make them ---representational so we can use coerce - --type role Hold representational data Hold x p = Hold { holdValue :: !(IORef (PatchTarget p)) @@ -759,20 +773,25 @@ globalSpiderTimelineEnv = unsafePerformIO unsafeNewSpiderTimelineEnv -- | Stores all global data relevant to a particular Spider timeline; only one -- value should exist for each type @x@ -data SpiderTimelineEnv x = SpiderTimelineEnv +newtype SpiderTimelineEnv x = STE {unSTE :: SpiderTimelineEnv' x} +-- We implement SpiderTimelineEnv with a newtype wrapper so +-- we can get the coercions we want safely. +type role SpiderTimelineEnv nominal + +data SpiderTimelineEnv' x = SpiderTimelineEnv { _spiderTimeline_lock :: {-# UNPACK #-} !(MVar ()) , _spiderTimeline_eventEnv :: {-# UNPACK #-} !(EventEnv x) #ifdef DEBUG , _spiderTimeline_depth :: {-# UNPACK #-} !(IORef Int) #endif } -type role SpiderTimelineEnv nominal +type role SpiderTimelineEnv' phantom instance Eq (SpiderTimelineEnv x) where _ == _ = True -- Since only one exists of each type instance GEq SpiderTimelineEnv where - a `geq` b = if _spiderTimeline_lock a == _spiderTimeline_lock b + a `geq` b = if _spiderTimeline_lock (unSTE a) == _spiderTimeline_lock (unSTE b) then Just $ unsafeCoerce Refl -- This unsafeCoerce is safe because the same SpiderTimelineEnv can't have two different 'x' arguments else Nothing @@ -795,7 +814,7 @@ runEventM :: EventM x a -> IO a runEventM = unEventM asksEventEnv :: forall x a. HasSpiderTimeline x => (EventEnv x -> a) -> EventM x a -asksEventEnv f = return $ f $ _spiderTimeline_eventEnv (spiderTimeline :: SpiderTimelineEnv x) +asksEventEnv f = return $ f $ _spiderTimeline_eventEnv (unSTE (spiderTimeline :: SpiderTimelineEnv x)) class MonadIO m => Defer a m where getDeferralQueue :: m (IORef [a]) @@ -933,9 +952,9 @@ getHoldEventSubscription h = do type BehaviorEnv x = (Maybe (Weak (Invalidator x), IORef [SomeBehaviorSubscribed x]), IORef [SomeHoldInit x]) ---type role BehaviorM representational -- BehaviorM can sample behaviors -newtype BehaviorM x a = BehaviorM { unBehaviorM :: ReaderT (BehaviorEnv x) IO a } deriving (Functor, Applicative, MonadIO, MonadFix) +newtype BehaviorM x a = BehaviorM { unBehaviorM :: ReaderIO (BehaviorEnv x) a } + deriving (Functor, Applicative, MonadIO, MonadFix, MonadReader (BehaviorEnv x)) instance Monad (BehaviorM x) where {-# INLINE (>>=) #-} @@ -1145,11 +1164,11 @@ data DynType x p = UnsafeDyn !(BehaviorM x (PatchTarget p), Event x p) newtype Dyn (x :: Type) p = Dyn { unDyn :: IORef (DynType x p) } -newMapDyn :: HasSpiderTimeline x => (a -> b) -> Dynamic x (Identity a) -> Dynamic x (Identity b) +newMapDyn :: HasSpiderTimeline x => (a -> b) -> DynamicS x (Identity a) -> DynamicS x (Identity b) newMapDyn f d = dynamicDynIdentity $ unsafeBuildDynamic (fmap f $ readBehaviorTracked $ dynamicCurrent d) (Identity . f . runIdentity <$> dynamicUpdated d) --TODO: Avoid the duplication between this and R.zipDynWith -zipDynWith :: HasSpiderTimeline x => (a -> b -> c) -> Dynamic x (Identity a) -> Dynamic x (Identity b) -> Dynamic x (Identity c) +zipDynWith :: HasSpiderTimeline x => (a -> b -> c) -> DynamicS x (Identity a) -> DynamicS x (Identity b) -> DynamicS x (Identity c) zipDynWith f da db = let eab = align (dynamicUpdated da) (dynamicUpdated db) ec = flip push eab $ \o -> do @@ -1225,7 +1244,7 @@ run :: forall x b. HasSpiderTimeline x => [DSum (RootTrigger x) Identity] -> Res run roots after = do tracePropagate (Proxy :: Proxy x) $ "Running an event frame with " <> show (length roots) <> " events" let t = spiderTimeline :: SpiderTimelineEnv x - result <- SpiderHost $ withMVar (_spiderTimeline_lock t) $ \_ -> unSpiderHost $ runFrame $ do + result <- SpiderHost $ withMVar (_spiderTimeline_lock (unSTE t)) $ \_ -> unSpiderHost $ runFrame $ do rootsToPropagate <- forM roots $ \r@(RootTrigger (_, occRef, k) :=> a) -> do occBefore <- liftIO $ do occBefore <- readIORef occRef @@ -1289,9 +1308,9 @@ type WeakList a = [Weak a] withIncreasedDepth :: CanTrace x m => m a -> m a withIncreasedDepth a = do spiderTimeline <- askSpiderTimelineEnv - liftIO $ modifyIORef' (_spiderTimeline_depth spiderTimeline) succ + liftIO $ modifyIORef' (_spiderTimeline_depth (unSTE spiderTimeline)) succ result <- a - liftIO $ modifyIORef' (_spiderTimeline_depth spiderTimeline) pred + liftIO $ modifyIORef' (_spiderTimeline_depth (unSTE spiderTimeline)) pred return result #else withIncreasedDepth :: m a -> m a @@ -1318,7 +1337,7 @@ traceMWhen _ b getMessage = when b $ do message <- getMessage #ifdef DEBUG spiderTimeline <- askSpiderTimelineEnv - d <- liftIO $ readIORef $ _spiderTimeline_depth spiderTimeline + d <- liftIO $ readIORef $ _spiderTimeline_depth $ unSTE spiderTimeline #else let d = 0 #endif @@ -1359,25 +1378,25 @@ propagateSubscriberHold h a = do data SomeResetCoincidence x = forall a. SomeResetCoincidence !(EventSubscription x) !(Maybe (CoincidenceSubscribed x a)) -- The CoincidenceSubscriber will be present only if heights need to be reset runBehaviorM :: BehaviorM x a -> Maybe (Weak (Invalidator x), IORef [SomeBehaviorSubscribed x]) -> IORef [SomeHoldInit x] -> IO a -runBehaviorM a mwi holdInits = runReaderT (unBehaviorM a) (mwi, holdInits) +runBehaviorM a mwi holdInits = runReaderIO (unBehaviorM a) (mwi, holdInits) askInvalidator :: BehaviorM x (Maybe (Weak (Invalidator x))) askInvalidator = do - (!m, _) <- BehaviorM ask + (!m, _) <- ask case m of Nothing -> return Nothing Just (!wi, _) -> return $ Just wi askParentsRef :: BehaviorM x (Maybe (IORef [SomeBehaviorSubscribed x])) askParentsRef = do - (!m, _) <- BehaviorM ask + (!m, _) <- ask case m of Nothing -> return Nothing Just (_, !p) -> return $ Just p askBehaviorHoldInits :: BehaviorM x (IORef [SomeHoldInit x]) askBehaviorHoldInits = do - (_, !his) <- BehaviorM ask + (_, !his) <- ask return his {-# INLINE getDynHold #-} @@ -1701,20 +1720,20 @@ subscribeCoincidenceSubscribed subscribed sub = WeakBag.insert sub (coincidenceS {-# INLINE mergeG #-} mergeG :: forall k q x v. (HasSpiderTimeline x, GCompare k) => (forall a. q a -> Event x (v a)) - -> Dynamic x (PatchDMap k q) -> Event x (DMap k v) + -> DynamicS x (PatchDMap k q) -> Event x (DMap k v) mergeG nt d = cacheEvent (mergeCheap nt d) {-# INLINE mergeWithMove #-} mergeWithMove :: forall k v q x. (HasSpiderTimeline x, GCompare k) => (forall a. q a -> Event x (v a)) - -> Dynamic x (PatchDMapWithMove k q) -> Event x (DMap k v) + -> DynamicS x (PatchDMapWithMove k q) -> Event x (DMap k v) mergeWithMove nt d = cacheEvent (mergeCheapWithMove nt d) {-# INLINE [1] mergeCheap #-} mergeCheap :: forall k x q v. (HasSpiderTimeline x, GCompare k) => (forall a. q a -> Event x (v a)) - -> Dynamic x (PatchDMap k q) + -> DynamicS x (PatchDMap k q) -> Event x (DMap k v) mergeCheap nt = mergeGCheap' getInitialSubscribers updateMe destroy where @@ -1754,7 +1773,7 @@ mergeCheap nt = mergeGCheap' getInitialSubscribers updateMe destroy {-# INLINE [1] mergeCheapWithMove #-} mergeCheapWithMove :: forall k x v q. (HasSpiderTimeline x, GCompare k) => (forall a. q a -> Event x (v a)) - -> Dynamic x (PatchDMapWithMove k q) + -> DynamicS x (PatchDMapWithMove k q) -> Event x (DMap k v) mergeCheapWithMove nt = mergeGCheap' getInitialSubscribers updateMe destroy where @@ -1902,7 +1921,7 @@ updateMerge m updateFunc p = SomeMergeUpdate updateMe (invalidateMergeHeight m) {-# INLINE mergeGCheap' #-} mergeGCheap' :: forall k v x p s q. (HasSpiderTimeline x, GCompare k, PatchTarget p ~ DMap k q) - => MergeInitFunc k v q x s -> MergeUpdateFunc k v x p s -> MergeDestroyFunc k s -> Dynamic x p -> Event x (DMap k v) + => MergeInitFunc k v q x s -> MergeUpdateFunc k v x p s -> MergeDestroyFunc k s -> DynamicS x p -> Event x (DMap k v) mergeGCheap' getInitialSubscribers updateFunc destroy d = Event $ \sub -> do initialParents <- readBehaviorUntracked $ dynamicCurrent d accumRef <- liftIO $ newIORef $ error "merge: accumRef not yet initialized" @@ -1951,11 +1970,11 @@ mergeGCheap' getInitialSubscribers updateFunc destroy d = Event $ \sub -> do , occ ) -mergeInt :: forall x a. (HasSpiderTimeline x) => Dynamic x (PatchIntMap (Event x a)) -> Event x (IntMap a) +mergeInt :: forall x a. (HasSpiderTimeline x) => DynamicS x (PatchIntMap (Event x a)) -> Event x (IntMap a) mergeInt = cacheEvent . mergeIntCheap {-# INLINABLE mergeIntCheap #-} -mergeIntCheap :: forall x a. (HasSpiderTimeline x) => Dynamic x (PatchIntMap (Event x a)) -> Event x (IntMap a) +mergeIntCheap :: forall x a. (HasSpiderTimeline x) => DynamicS x (PatchIntMap (Event x a)) -> Event x (IntMap a) mergeIntCheap d = Event $ \sub -> do initialParents <- readBehaviorUntracked $ dynamicCurrent d accum <- liftIO $ FastMutableIntMap.newEmpty @@ -2115,7 +2134,7 @@ clearEventEnv (EventEnv toAssignRef holdInitRef dynInitRef mergeUpdateRef mergeI -- | Run an event action outside of a frame runFrame :: forall x a. HasSpiderTimeline x => EventM x a -> SpiderHost x a --TODO: This function also needs to hold the mutex runFrame a = SpiderHost $ do - let env = _spiderTimeline_eventEnv (spiderTimeline :: SpiderTimelineEnv x) + let env = _spiderTimeline_eventEnv $ unSTE (spiderTimeline :: SpiderTimelineEnv x) let go = do result <- a runHoldInits (eventEnvHoldInits env) (eventEnvDynInits env) (eventEnvMergeInits env) -- This must happen before doing the assignments, in case subscribing a Hold causes existing Holds to be read by the newly-propagated events @@ -2326,7 +2345,7 @@ instance HasSpiderTimeline x => Monad (Reflex.Class.Dynamic (SpiderTimeline x)) fail _ = error "Dynamic does not support 'fail'" {-# INLINABLE newJoinDyn #-} -newJoinDyn :: HasSpiderTimeline x => Reflex.Spider.Internal.Dynamic x (Identity (Reflex.Spider.Internal.Dynamic x (Identity a))) -> Reflex.Spider.Internal.Dyn x (Identity a) +newJoinDyn :: HasSpiderTimeline x => DynamicS x (Identity (DynamicS x (Identity a))) -> Reflex.Spider.Internal.Dyn x (Identity a) newJoinDyn d = let readV0 = readBehaviorTracked . dynamicCurrent =<< readBehaviorTracked (dynamicCurrent d) eOuter = Reflex.Spider.Internal.push (fmap (Just . Identity) . readBehaviorUntracked . dynamicCurrent . runIdentity) $ dynamicUpdated d @@ -2476,7 +2495,7 @@ unsafeNewSpiderTimelineEnv = do #ifdef DEBUG depthRef <- newIORef 0 #endif - return $ SpiderTimelineEnv + return $ STE $ SpiderTimelineEnv { _spiderTimeline_lock = lock , _spiderTimeline_eventEnv = env #ifdef DEBUG @@ -2492,13 +2511,13 @@ data LocalSpiderTimeline (x :: Type) s instance Reifies s (SpiderTimelineEnv x) => HasSpiderTimeline (LocalSpiderTimeline x s) where - spiderTimeline = localSpiderTimeline (Proxy :: Proxy s) $ reflect (Proxy :: Proxy s) + spiderTimeline = localSpiderTimeline Proxy $ reflect (Proxy :: Proxy s) localSpiderTimeline - :: Proxy s + :: proxy s -> SpiderTimelineEnv x -> SpiderTimelineEnv (LocalSpiderTimeline x s) -localSpiderTimeline _ = unsafeCoerce +localSpiderTimeline _ = coerce -- | Pass a new timeline to the given function. withSpiderTimeline :: (forall x. HasSpiderTimeline x => SpiderTimelineEnv x -> IO r) -> IO r @@ -2516,8 +2535,8 @@ instance HasSpiderTimeline x => R.Reflex (SpiderTimeline x) where {-# SPECIALIZE instance R.Reflex (SpiderTimeline Global) #-} newtype Behavior (SpiderTimeline x) a = SpiderBehavior { unSpiderBehavior :: Behavior x a } newtype Event (SpiderTimeline x) a = SpiderEvent { unSpiderEvent :: Event x a } - newtype Dynamic (SpiderTimeline x) a = SpiderDynamic { unSpiderDynamic :: Dynamic x (Identity a) } -- deriving (Functor, Applicative, Monad) - newtype Incremental (SpiderTimeline x) p = SpiderIncremental { unSpiderIncremental :: Dynamic x p } + newtype Dynamic (SpiderTimeline x) a = SpiderDynamic { unSpiderDynamic :: DynamicS x (Identity a) } -- deriving (Functor, Applicative, Monad) + newtype Incremental (SpiderTimeline x) p = SpiderIncremental { unSpiderIncremental :: DynamicS x p } type PullM (SpiderTimeline x) = SpiderPullM x type PushM (SpiderTimeline x) = SpiderPushM x {-# INLINABLE never #-} @@ -2546,7 +2565,7 @@ instance HasSpiderTimeline x => R.Reflex (SpiderTimeline x) where {-# INLINABLE current #-} current = SpiderBehavior . dynamicCurrent . unSpiderDynamic {-# INLINABLE updated #-} - updated = coerce $ SpiderEvent . dynamicUpdated . unSpiderDynamic + updated = SpiderEvent #. dynamicUpdated .# fmap coerce . unSpiderDynamic {-# INLINABLE unsafeBuildDynamic #-} unsafeBuildDynamic readV0 v' = SpiderDynamic $ dynamicDynIdentity $ unsafeBuildDynamic (coerce readV0) $ coerce $ unSpiderEvent v' {-# INLINABLE unsafeBuildIncremental #-} @@ -2565,9 +2584,10 @@ instance HasSpiderTimeline x => R.Reflex (SpiderTimeline x) where return $ Identity <$> apply p c --TODO: Avoid the redundant 'apply' eventCoercion Coercion = Coercion behaviorCoercion Coercion = Coercion - dynamicCoercion = unsafeCoerce --TODO: How can we avoid this unsafeCoerce? This is safe only because we know how Identity works as a Patch instance + dynamicCoercion Coercion = Coercion + incrementalCoercion Coercion Coercion = Coercion {-# INLINABLE mergeIntIncremental #-} - mergeIntIncremental = SpiderEvent . mergeInt . (unsafeCoerce :: Dynamic x (PatchIntMap (R.Event (SpiderTimeline x) a)) -> Dynamic x (PatchIntMap (Event x a))) . unSpiderIncremental + mergeIntIncremental = SpiderEvent . mergeInt . coerce {-# INLINABLE fanInt #-} fanInt e = R.EventSelectorInt $ SpiderEvent . selectInt (fanInt (unSpiderEvent e)) diff --git a/test/Reflex/Bench/Focused.hs b/test/Reflex/Bench/Focused.hs index 621ab5a5..cdfd5dd0 100644 --- a/test/Reflex/Bench/Focused.hs +++ b/test/Reflex/Bench/Focused.hs @@ -130,6 +130,16 @@ mapDynChain = iterM (return . fmap (+1)) joinDynChain :: (Reflex t, MonadHold t m) => Word -> Dynamic t Word -> m (Dynamic t Word) joinDynChain = iterM (\d -> return $ join $ fmap (const d) d) +holdDynChain :: (Reflex t, MonadHold t m) => Word -> Dynamic t Word -> m (Dynamic t Word) +holdDynChain = iterM (\d -> sample (current d) >>= flip holdDyn (updated d)) + +buildDynChain :: (Reflex t, MonadHold t m) => Word -> Dynamic t Word -> m (Dynamic t Word) +buildDynChain = iterM (\d -> do + let b = fmap (+1) (current d) + e = fmap (*2) (updated d) + buildDynamic (sample b) e) + + combineDynChain :: (Reflex t, MonadHold t m) => Word -> Dynamic t Word -> m (Dynamic t Word) combineDynChain = iterM (\d -> return $ zipDynWith (+) d d) @@ -308,6 +318,8 @@ dynamics :: Word -> [(String, TestCase)] dynamics n = [ testE "mapDynChain" $ fmap updated $ mapDynChain n =<< d , testE "joinDynChain" $ fmap updated $ joinDynChain n =<< d + , testE "holdDynChain" $ fmap updated $ holdDynChain n =<< d + , testE "buildDynChain" $ fmap updated $ buildDynChain n =<< d , testE "combineDynChain" $ fmap updated $ combineDynChain n =<< d , testE "dense mergeTree" $ fmap (updated . mergeTreeDyn 8) dense , testE "sparse mergeTree" $ fmap (updated . mergeTreeDyn 8) sparse From dc295b04783cd6ffacbc53325fe531e552730d69 Mon Sep 17 00:00:00 2001 From: Ali Abrar Date: Mon, 5 Aug 2019 10:43:11 -0400 Subject: [PATCH 180/241] travis-ci: Add ghcjs to allowed failures list bc of travis time limit --- .travis.yml | 3 +++ 1 file changed, 3 insertions(+) diff --git a/.travis.yml b/.travis.yml index 4384dbfc..51548458 100644 --- a/.travis.yml +++ b/.travis.yml @@ -37,6 +37,9 @@ matrix: addons: {"apt":{"sources":["hvr-ghc"],"packages":["ghc-8.2.2","cabal-install-2.4"]}} - compiler: ghc-8.0.2 addons: {"apt":{"sources":["hvr-ghc"],"packages":["ghc-8.0.2","cabal-install-2.4"]}} + allow_failures: + - compiler: "ghcjs-8.4" # This hits the travis 50min time limit and fails + before_install: - | if [ "$TRAVIS_OS_NAME" = "linux" ]; then From 0bf106af2935985e617a1f94d8268af14a508021 Mon Sep 17 00:00:00 2001 From: Ali Abrar Date: Mon, 5 Aug 2019 13:54:13 -0400 Subject: [PATCH 181/241] contributing: add note on dependency ver bounds --- CONTRIBUTING.md | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/CONTRIBUTING.md b/CONTRIBUTING.md index 92bd9d1b..1069d7ea 100644 --- a/CONTRIBUTING.md +++ b/CONTRIBUTING.md @@ -45,6 +45,10 @@ Your pull request should add no new warnings to the project. It should also gene Make sure the project builds and that the tests pass! This will generally also be checked by CI before merge, but trying it yourself first means you'll catch problems earlier and your contribution can be merged that much sooner! +#### Dependencies + +Include version bounds whenever adding a dependency to the library stanza of the cabal file. Note that libraries added to reflex.cabal also need to be added to default.nix. + ### Documentation #### In the code From eeeae5f39b76d2779555fcf48e1868c9b12dc205 Mon Sep 17 00:00:00 2001 From: Oliver Batchelor Date: Tue, 6 Aug 2019 16:16:48 +1200 Subject: [PATCH 182/241] Fix merges (#340) * Augment changelog, add profunctor bounds * Document commented instance signature --- ChangeLog.md | 11 +++++++++-- default.nix | 1 + reflex.cabal | 2 +- src/Reflex/Pure.hs | 3 ++- 4 files changed, 13 insertions(+), 4 deletions(-) diff --git a/ChangeLog.md b/ChangeLog.md index bea9795d..ba73e3bb 100644 --- a/ChangeLog.md +++ b/ChangeLog.md @@ -3,14 +3,21 @@ ## 0.6.2.1 * Generalize `fan` to `fanG` to take a `DMap` with non-`Identity` - values. + functor: + * `fan` to `fanG` + * `EventSelectorG` for `fanG` result selector. + +* Reduce the amount of unsafeCoerce in coercing newtypes under Event/Dynamic/Behavior. + * Add fused ReaderIO for the purpose of coercion (ReaderT's third argument has nominal role preventing automated coerce) + * Add incrementalCoercion/coerceIncremental to go with dynamicCoercion/coerceDynamic * Generalize merging functions: `merge` to `mergeG`, `mergeIncremental` to `mergeIncrementalG`, - `distributeDMapOverDynPure` to `distributeDMapOverDynPureG`, `mergeIncrementalWithMove` to `mergeIncrementalWithMoveG`. +* Generalize distribute function: + `distributeDMapOverDynPure` to `distributeDMapOverDynPureG`, ## 0.6.2.0 diff --git a/default.nix b/default.nix index 7c874b3f..af611526 100644 --- a/default.nix +++ b/default.nix @@ -22,6 +22,7 @@ mkDerivation { base bifunctors containers deepseq dependent-map dependent-sum mtl ref-tf split transformers data-default random time unbounded-delays monoidal-containers witherable + profunctors ] ++ (if ghc.isGhcjs or false then [ ghcjs-base ] else []) ++ (if !useTemplateHaskell then [] else [ diff --git a/reflex.cabal b/reflex.cabal index 4e4012a8..35c8c934 100644 --- a/reflex.cabal +++ b/reflex.cabal @@ -49,7 +49,7 @@ library data-default >= 0.5 && < 0.8, dependent-map >= 0.3 && < 0.4, exception-transformers == 0.4.*, - profunctors, + profunctors >= 5.0 && < 6.0, lens >= 4.7 && < 5, monad-control >= 1.0.1 && < 1.1, monoidal-containers >= 0.4 && < 0.6, diff --git a/src/Reflex/Pure.hs b/src/Reflex/Pure.hs index f24b5196..c0e242a0 100644 --- a/src/Reflex/Pure.hs +++ b/src/Reflex/Pure.hs @@ -93,7 +93,8 @@ instance (Enum t, HasTrie t, Ord t) => Reflex (Pure t) where then Nothing else Just currentOccurrences - -- fanG :: GCompare k => Event (Pure t) (DMap k v) -> EventSelectorG (Pure t) k v +-- The instance signature doeesn't compile, leave commented for documentation +-- fanG :: GCompare k => Event (Pure t) (DMap k v) -> EventSelectorG (Pure t) k v fanG e = EventSelectorG $ \k -> Event $ \t -> unEvent e t >>= DMap.lookup k switch :: Behavior (Pure t) (Event (Pure t) a) -> Event (Pure t) a From bf8a772201b822451957c4cc29d32bbb716b57da Mon Sep 17 00:00:00 2001 From: Oliver Batchelor Date: Fri, 9 Aug 2019 23:43:55 +1200 Subject: [PATCH 183/241] Use xenial and manually install node 8 for ghcjs --- .travis.yml | 19 ++++++++++++------- cabal.haskell-ci | 2 +- 2 files changed, 13 insertions(+), 8 deletions(-) diff --git a/.travis.yml b/.travis.yml index 51548458..d58eaf8d 100644 --- a/.travis.yml +++ b/.travis.yml @@ -7,7 +7,7 @@ # version: 0.3.20190804.2 # language: c -dist: bionic +dist: xenial sudo: required git: # whether to recursively clone submodules @@ -25,10 +25,12 @@ before_cache: - rm -fv $CABALHOME/packages/hackage.haskell.org/01-index.tar - rm -fv $CABALHOME/packages/hackage.haskell.org/01-index.tar.idx - rm -rfv $CABALHOME/packages/head.hackage + matrix: include: - compiler: ghcjs-8.4 - addons: {"apt":{"sources":["hvr-ghc"],"packages":["ghcjs-8.4","cabal-install-3.0"]}} + addons: {"apt":{"sources":["hvr-ghc"],"packages":["ghc-8.4.4","cabal-install-3.0"]}} + env: GHCJS_PACKAGE="ghcjs-8.4" - compiler: ghc-8.6.5 addons: {"apt":{"sources":["hvr-ghc"],"packages":["ghc-8.6.5","cabal-install-2.4"]}} - compiler: ghc-8.4.4 @@ -42,11 +44,13 @@ matrix: before_install: - | - if [ "$TRAVIS_OS_NAME" = "linux" ]; then - sudo add-apt-repository -y ppa:hvr/ghc; - sudo add-apt-repository -y ppa:hvr/ghcjs; - sudo apt-get update; - sudo apt-get install $CC cabal-install-3.0; + if [ "$TRAVIS_OS_NAME" = "linux" ] && [ ! -z "$GHCJS_PACKAGE" ]; then + curl -s https://deb.nodesource.com/gpgkey/nodesource.gpg.key | sudo apt-key add -; + sudo sh -c "echo deb https://deb.nodesource.com/node_8.x xenial main > /etc/apt/sources.list.d/nodesource.list"; + sudo add-apt-repository -y ppa:hvr/ghcjs; + sudo apt-get update; + sudo apt-get install nodejs; + sudo apt-get install "$GHCJS_PACKAGE"; fi - HC=$(echo "/opt/$CC/bin/ghc" | sed 's/-/\//') - WITHCOMPILER="-w $HC" @@ -175,3 +179,4 @@ script: # REGENDATA ["--config=cabal.haskell-ci","cabal.project"] # EOF + diff --git a/cabal.haskell-ci b/cabal.haskell-ci index 23eef972..0e01e05a 100644 --- a/cabal.haskell-ci +++ b/cabal.haskell-ci @@ -1,4 +1,4 @@ -distribution: bionic +distribution: xenial -- https://github.com/haskell/cabal/issues/6106 install-dependencies: False From 2305724fddf64f23e468b7ad9f8db8f106cb140f Mon Sep 17 00:00:00 2001 From: Ali Abrar Date: Fri, 9 Aug 2019 12:58:15 -0400 Subject: [PATCH 184/241] default.nix: Add missing profunctors dep --- default.nix | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/default.nix b/default.nix index 033dd81d..d85fcfbe 100644 --- a/default.nix +++ b/default.nix @@ -6,7 +6,7 @@ , template-haskell , these, time, transformers , transformers-compat, unbounded-delays, prim-uniq , data-default, filepath, directory, filemanip, ghcjs-base -, monoidal-containers, witherable +, monoidal-containers, witherable, profunctors , semialign ? null, splitThese ? (semialign != null) , useTemplateHaskell ? true }: From 0b52dc4a59f8ed14b9423787a1ede8b7f6f8548a Mon Sep 17 00:00:00 2001 From: Oliver Batchelor Date: Sun, 11 Aug 2019 14:29:46 +1200 Subject: [PATCH 185/241] Add freeze file to avoid text 1.2.4.0 duplicate instances (#347) * Add freeze file to avoid text 1.2.4.0 which conflicts with th-instances-lift (transitive dependencies) * Don't reset freeze file in travis build --- .travis.yml | 11 ++++++----- cabal.project.freeze | 1 + 2 files changed, 7 insertions(+), 5 deletions(-) create mode 100644 cabal.project.freeze diff --git a/.travis.yml b/.travis.yml index d58eaf8d..bec27aaa 100644 --- a/.travis.yml +++ b/.travis.yml @@ -118,21 +118,20 @@ install: echo "repository hackage.haskell.org" >> $CABALHOME/config echo " url: http://hackage.haskell.org/" >> $CABALHOME/config - cat $CABALHOME/config - - rm -fv cabal.project cabal.project.local cabal.project.freeze + - rm -fv cabal.project cabal.project.local - travis_retry ${CABAL} v2-update -v - if $GHCJS ; then (cd /tmp && ${CABAL} v2-install -w ghc-8.6.5 happy) ; fi # Generate cabal.project - - rm -rf cabal.project cabal.project.local cabal.project.freeze + - rm -rf cabal.project cabal.project.local - touch cabal.project - | echo "packages: ." >> cabal.project - cat cabal.project || true - cat cabal.project.local || true - if [ -f "./configure.ac" ]; then (cd "." && autoreconf -i); fi - - ${CABAL} v2-freeze $WITHCOMPILER ${TEST} ${BENCH} | color_cabal_output + # - ${CABAL} v2-freeze $WITHCOMPILER ${TEST} ${BENCH} | color_cabal_output - ${CABAL} v2-configure $WITHCOMPILER ${TEST} ${BENCH} | color_cabal_output - "cat cabal.project.freeze | sed -E 's/^(constraints: *| *)//' | sed 's/any.//'" - - rm cabal.project.freeze || true - rm cabal.project.local || true script: - DISTDIR=$(mktemp -d /tmp/dist-test.XXXX) @@ -140,12 +139,13 @@ script: - ${CABAL} v2-sdist all | color_cabal_output # Unpacking... - mv dist-newstyle/sdist/*.tar.gz ${DISTDIR}/ + - cp cabal.project.freeze ${DISTDIR}/ || true - cd ${DISTDIR} || false - find . -maxdepth 1 -type f -name '*.tar.gz' -exec tar -xvf '{}' \; - find . -maxdepth 1 -type f -name '*.tar.gz' -exec rm '{}' \; - PKGDIR_reflex="$(find . -maxdepth 1 -type d -regex '.*/reflex-[0-9.]*')" # Generate cabal.project - - rm -rf cabal.project cabal.project.local cabal.project.freeze + - rm -rf cabal.project cabal.project.local - touch cabal.project - | echo "packages: ${PKGDIR_reflex}" >> cabal.project @@ -153,6 +153,7 @@ script: - cat cabal.project || true - cat cabal.project.local || true - rm cabal.project.local || true + - cat cabal.project.freeze || true # Building... # this builds all libraries and executables (without tests/benchmarks) - ${CABAL} v2-build $WITHCOMPILER --disable-tests --disable-benchmarks all | color_cabal_output diff --git a/cabal.project.freeze b/cabal.project.freeze new file mode 100644 index 00000000..0bcc1d6f --- /dev/null +++ b/cabal.project.freeze @@ -0,0 +1 @@ +constraints: any.text < 1.2.4.0 From b941f83c2deac849e1408ca41ee285fb3de88af6 Mon Sep 17 00:00:00 2001 From: Oliver Batchelor Date: Tue, 13 Aug 2019 14:44:07 +1200 Subject: [PATCH 186/241] Update .travis.yml Re-enable ghcjs in Travis (now that time limit is 90 minutes) --- .travis.yml | 4 +--- 1 file changed, 1 insertion(+), 3 deletions(-) diff --git a/.travis.yml b/.travis.yml index bec27aaa..a84ff6f1 100644 --- a/.travis.yml +++ b/.travis.yml @@ -39,9 +39,7 @@ matrix: addons: {"apt":{"sources":["hvr-ghc"],"packages":["ghc-8.2.2","cabal-install-2.4"]}} - compiler: ghc-8.0.2 addons: {"apt":{"sources":["hvr-ghc"],"packages":["ghc-8.0.2","cabal-install-2.4"]}} - allow_failures: - - compiler: "ghcjs-8.4" # This hits the travis 50min time limit and fails - + before_install: - | if [ "$TRAVIS_OS_NAME" = "linux" ] && [ ! -z "$GHCJS_PACKAGE" ]; then From 6173df4e9b3fde46000c24c7958c75f0fa700d13 Mon Sep 17 00:00:00 2001 From: Oleg Grenrus Date: Wed, 14 Aug 2019 11:16:28 +0300 Subject: [PATCH 187/241] Use haskell-ci regenerate I updated `haskell-ci` so there are no manual post updates. In general, manual editing of generated `.travis.yml` is highly discouraged, because it's manual process. `haskell-ci` is quite configurable: The ideal situation is when one can - edit `.cabal` files, `cabal.project` or `cabal.haskell-ci` - `haskell-ci regenerate` - profit! For example when adding new tested-with GHC version. --- .travis.yml | 54 +++++++++++++++++++----------------------------- cabal.haskell-ci | 9 ++++++-- 2 files changed, 28 insertions(+), 35 deletions(-) diff --git a/.travis.yml b/.travis.yml index a84ff6f1..b1c48f45 100644 --- a/.travis.yml +++ b/.travis.yml @@ -4,7 +4,7 @@ # # For more information, see https://github.com/haskell-CI/haskell-ci # -# version: 0.3.20190804.2 +# version: 0.3.20190814 # language: c dist: xenial @@ -25,12 +25,10 @@ before_cache: - rm -fv $CABALHOME/packages/hackage.haskell.org/01-index.tar - rm -fv $CABALHOME/packages/hackage.haskell.org/01-index.tar.idx - rm -rfv $CABALHOME/packages/head.hackage - matrix: include: - compiler: ghcjs-8.4 - addons: {"apt":{"sources":["hvr-ghc"],"packages":["ghc-8.4.4","cabal-install-3.0"]}} - env: GHCJS_PACKAGE="ghcjs-8.4" + addons: {"apt":{"sources":["hvr-ghc"],"packages":["cabal-install-3.0"]}} - compiler: ghc-8.6.5 addons: {"apt":{"sources":["hvr-ghc"],"packages":["ghc-8.6.5","cabal-install-2.4"]}} - compiler: ghc-8.4.4 @@ -39,16 +37,14 @@ matrix: addons: {"apt":{"sources":["hvr-ghc"],"packages":["ghc-8.2.2","cabal-install-2.4"]}} - compiler: ghc-8.0.2 addons: {"apt":{"sources":["hvr-ghc"],"packages":["ghc-8.0.2","cabal-install-2.4"]}} - before_install: - | - if [ "$TRAVIS_OS_NAME" = "linux" ] && [ ! -z "$GHCJS_PACKAGE" ]; then - curl -s https://deb.nodesource.com/gpgkey/nodesource.gpg.key | sudo apt-key add -; - sudo sh -c "echo deb https://deb.nodesource.com/node_8.x xenial main > /etc/apt/sources.list.d/nodesource.list"; + if [ "$TRAVIS_OS_NAME" = "linux" ]; then sudo add-apt-repository -y ppa:hvr/ghcjs; + curl -s https://deb.nodesource.com/gpgkey/nodesource.gpg.key | sudo apt-key add - + sudo apt-add-repository 'https://deb.nodesource.com/node_8.x xenial main' sudo apt-get update; - sudo apt-get install nodejs; - sudo apt-get install "$GHCJS_PACKAGE"; + sudo apt-get install $CC cabal-install-3.0 nodejs; fi - HC=$(echo "/opt/$CC/bin/ghc" | sed 's/-/\//') - WITHCOMPILER="-w $HC" @@ -60,8 +56,8 @@ before_install: else GHCJS=false; fi - - if $GHCJS ; then sudo apt-get install -y ghc-8.6.5 ; fi - - if $GHCJS ; then PATH="/opt/ghc/8.6.5/bin:$PATH" ; fi + - if $GHCJS ; then sudo apt-get install -y ghc-8.4.4 ; fi + - if $GHCJS ; then PATH="/opt/ghc/8.4.4/bin:$PATH" ; fi - HCPKG="$HC-pkg" - unset CC - CABAL=/opt/ghc/bin/cabal @@ -97,6 +93,7 @@ install: - echo $GHCJS - TEST=--enable-tests - BENCH=--enable-benchmarks + - BENCH=--disable-benchmarks - HEADHACKAGE=false - rm -f $CABALHOME/config - | @@ -116,42 +113,39 @@ install: echo "repository hackage.haskell.org" >> $CABALHOME/config echo " url: http://hackage.haskell.org/" >> $CABALHOME/config - cat $CABALHOME/config - - rm -fv cabal.project cabal.project.local + - rm -fv cabal.project cabal.project.local cabal.project.freeze - travis_retry ${CABAL} v2-update -v - - if $GHCJS ; then (cd /tmp && ${CABAL} v2-install -w ghc-8.6.5 happy) ; fi + - if $GHCJS ; then (cd /tmp && ${CABAL} v2-install -w ghc-8.4.4 happy) ; fi # Generate cabal.project - - rm -rf cabal.project cabal.project.local + - rm -rf cabal.project cabal.project.local cabal.project.freeze - touch cabal.project - | echo "packages: ." >> cabal.project + - | - cat cabal.project || true - cat cabal.project.local || true - if [ -f "./configure.ac" ]; then (cd "." && autoreconf -i); fi - # - ${CABAL} v2-freeze $WITHCOMPILER ${TEST} ${BENCH} | color_cabal_output - - ${CABAL} v2-configure $WITHCOMPILER ${TEST} ${BENCH} | color_cabal_output + - ${CABAL} v2-freeze $WITHCOMPILER ${TEST} ${BENCH} | color_cabal_output - "cat cabal.project.freeze | sed -E 's/^(constraints: *| *)//' | sed 's/any.//'" - - rm cabal.project.local || true + - rm cabal.project.freeze script: - DISTDIR=$(mktemp -d /tmp/dist-test.XXXX) # Packaging... - ${CABAL} v2-sdist all | color_cabal_output # Unpacking... - mv dist-newstyle/sdist/*.tar.gz ${DISTDIR}/ - - cp cabal.project.freeze ${DISTDIR}/ || true - cd ${DISTDIR} || false - find . -maxdepth 1 -type f -name '*.tar.gz' -exec tar -xvf '{}' \; - find . -maxdepth 1 -type f -name '*.tar.gz' -exec rm '{}' \; - PKGDIR_reflex="$(find . -maxdepth 1 -type d -regex '.*/reflex-[0-9.]*')" # Generate cabal.project - - rm -rf cabal.project cabal.project.local + - rm -rf cabal.project cabal.project.local cabal.project.freeze - touch cabal.project - | echo "packages: ${PKGDIR_reflex}" >> cabal.project - | - cat cabal.project || true - cat cabal.project.local || true - - rm cabal.project.local || true - - cat cabal.project.freeze || true # Building... # this builds all libraries and executables (without tests/benchmarks) - ${CABAL} v2-build $WITHCOMPILER --disable-tests --disable-benchmarks all | color_cabal_output @@ -159,23 +153,17 @@ script: # build & run tests, build benchmarks - ${CABAL} v2-build $WITHCOMPILER ${TEST} ${BENCH} all | color_cabal_output # Testing... - - if ! $GHCJS && [ $HCNUMVER -ge 80000 ] && [ $HCNUMVER -lt 80606 ] ; then ${CABAL} v2-test $WITHCOMPILER ${TEST} ${BENCH} all | color_cabal_output ; fi + - if ! $GHCJS ; then ${CABAL} v2-test $WITHCOMPILER ${TEST} ${BENCH} all | color_cabal_output ; fi # cabal check... - (cd ${PKGDIR_reflex} && ${CABAL} -vnormal check) # haddock... - - if ! $GHCJS && [ $HCNUMVER -ge 80000 ] && [ $HCNUMVER -lt 80606 ] ; then ${CABAL} v2-haddock $WITHCOMPILER ${TEST} ${BENCH} all | color_cabal_output ; fi - # Building without installed constraints for packages in global-db... - - rm -f cabal.project.local || true - - ${CABAL} v2-build $WITHCOMPILER --disable-tests --disable-benchmarks all | color_cabal_output + - if ! $GHCJS ; then ${CABAL} v2-haddock $WITHCOMPILER ${TEST} ${BENCH} all | color_cabal_output ; fi # Constraint sets - - rm -rf cabal.project.local || true + - rm -rf cabal.project.local # Constraint set no-th - ${CABAL} v2-build $WITHCOMPILER --disable-tests --disable-benchmarks --constraint='reflex -use-template-haskell' all | color_cabal_output - # Constraint sets - - rm -rf cabal.project.local || true - # Constraint set don't use split these/semialign - - ${CABAL} v2-build $WITHCOMPILER --disable-tests --disable-benchmarks --constraint='reflex -split-these' all | color_cabal_output + # Constraint set old-these + - ${CABAL} v2-build $WITHCOMPILER --disable-tests --disable-benchmarks --constraint='these <1' all | color_cabal_output # REGENDATA ["--config=cabal.haskell-ci","cabal.project"] # EOF - diff --git a/cabal.haskell-ci b/cabal.haskell-ci index 0e01e05a..1625daa7 100644 --- a/cabal.haskell-ci +++ b/cabal.haskell-ci @@ -1,8 +1,13 @@ -distribution: xenial +distribution: xenial +benchmarks: False +unconstrained: False +installed: -all -- https://github.com/haskell/cabal/issues/6106 install-dependencies: False -benchmarks: False constraint-set no-th constraints: reflex -use-template-haskell + +constraint-set old-these + constraints: these <1 From 5bba8405da85dc006de45ed5218f3d2d914c6057 Mon Sep 17 00:00:00 2001 From: Oleg Grenrus Date: Wed, 14 Aug 2019 14:02:48 +0300 Subject: [PATCH 188/241] Allow witherable ==0.3.* --- .travis.yml | 2 ++ cabal.haskell-ci | 3 +++ reflex.cabal | 2 +- src/Data/AppendMap.hs | 2 ++ 4 files changed, 8 insertions(+), 1 deletion(-) diff --git a/.travis.yml b/.travis.yml index b1c48f45..24f9ce8e 100644 --- a/.travis.yml +++ b/.travis.yml @@ -164,6 +164,8 @@ script: - ${CABAL} v2-build $WITHCOMPILER --disable-tests --disable-benchmarks --constraint='reflex -use-template-haskell' all | color_cabal_output # Constraint set old-these - ${CABAL} v2-build $WITHCOMPILER --disable-tests --disable-benchmarks --constraint='these <1' all | color_cabal_output + # Constraint set old-witherable + - ${CABAL} v2-build $WITHCOMPILER --disable-tests --disable-benchmarks --constraint='witherable <0.3.2' all | color_cabal_output # REGENDATA ["--config=cabal.haskell-ci","cabal.project"] # EOF diff --git a/cabal.haskell-ci b/cabal.haskell-ci index 1625daa7..50efdf12 100644 --- a/cabal.haskell-ci +++ b/cabal.haskell-ci @@ -11,3 +11,6 @@ constraint-set no-th constraint-set old-these constraints: these <1 + +constraint-set old-witherable + constraints: witherable <0.3.2 diff --git a/reflex.cabal b/reflex.cabal index 90ab2f53..cdd46f0a 100644 --- a/reflex.cabal +++ b/reflex.cabal @@ -74,7 +74,7 @@ library time >= 1.4 && < 1.9, transformers >= 0.5.6.0 && < 0.6, unbounded-delays >= 0.1.0.0 && < 0.2, - witherable >= 0.2 && < 0.3 + witherable >= 0.2 && < 0.4 if flag(split-these) build-depends: these >= 1 && <1.1, diff --git a/src/Data/AppendMap.hs b/src/Data/AppendMap.hs index 66a085e4..148f7a5c 100644 --- a/src/Data/AppendMap.hs +++ b/src/Data/AppendMap.hs @@ -46,8 +46,10 @@ _unAppendMap = getMonoidalMap pattern AppendMap :: Map k v -> MonoidalMap k v pattern AppendMap m = MonoidalMap m +#if !MIN_VERSION_witherable(0,3,2) instance W.Filterable (MonoidalMap k) where mapMaybe = mapMaybe +#endif -- | Deletes a key, returning 'Nothing' if the result is empty. nonEmptyDelete :: Ord k => k -> MonoidalMap k a -> Maybe (MonoidalMap k a) From 710c8508b9ab3baf8164f8fb4df8f5e347c0efe7 Mon Sep 17 00:00:00 2001 From: Oliver Batchelor Date: Tue, 20 Aug 2019 02:29:24 +1200 Subject: [PATCH 189/241] Use align (a merge) instead of coincidence for <.> (#346) --- src/Reflex/Class.hs | 9 ++++++--- 1 file changed, 6 insertions(+), 3 deletions(-) diff --git a/src/Reflex/Class.hs b/src/Reflex/Class.hs index 2e6aef1c..dd5a3d8c 100644 --- a/src/Reflex/Class.hs +++ b/src/Reflex/Class.hs @@ -714,9 +714,12 @@ filterRight = mapMaybe (either (const Nothing) Just) instance Reflex t => Alt (Event t) where ev1 ev2 = leftmost [ev1, ev2] --- | 'Event' intersection (convenient interface to 'coincidence'). +-- | 'Event' intersection. Only occurs when both events are co-incident. instance Reflex t => Apply (Event t) where - evf <.> evx = coincidence (fmap (<$> evx) evf) + evf <.> evx = mapMaybe f (align evf evx) where + f (These g a) = Just (g a) + f _ = Nothing + -- | 'Event' intersection (convenient interface to 'coincidence'). instance Reflex t => Bind (Event t) where @@ -1073,7 +1076,7 @@ instance Reflex t => Align (Event t) where instance Reflex t => Semialign (Event t) where #endif align = alignEventWithMaybe Just - + #if defined(MIN_VERSION_semialign) zip x y = mapMaybe justThese $ align x y #endif From 9b684de49e8c88e95f74e55ed9cca660051df6c5 Mon Sep 17 00:00:00 2001 From: Ali Abrar Date: Fri, 23 Aug 2019 04:20:48 -0400 Subject: [PATCH 190/241] v0.6.2.3 - Add an upper-bound to witherable --- ChangeLog.md | 4 ++++ default.nix | 2 +- reflex.cabal | 4 ++-- 3 files changed, 7 insertions(+), 3 deletions(-) diff --git a/ChangeLog.md b/ChangeLog.md index 6091d627..ee546559 100644 --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,5 +1,9 @@ # Revision history for reflex +## 0.6.2.3 + +* Add an upper-bound to witherable + ## 0.6.2.2 * Support these >= 1. Add `split-these` flag to control whether to use new these/semialign combination or not. diff --git a/default.nix b/default.nix index d85fcfbe..4988c05d 100644 --- a/default.nix +++ b/default.nix @@ -12,7 +12,7 @@ }: mkDerivation { pname = "reflex"; - version = "0.6.2.2"; + version = "0.6.2.3"; src = builtins.filterSource (path: type: !(builtins.elem (baseNameOf path) [ ".git" "dist" ])) ./.; libraryHaskellDepends = [ base bifunctors containers dependent-map dependent-sum diff --git a/reflex.cabal b/reflex.cabal index cdd46f0a..2f523428 100644 --- a/reflex.cabal +++ b/reflex.cabal @@ -1,5 +1,5 @@ Name: reflex -Version: 0.6.2.2 +Version: 0.6.2.3 Synopsis: Higher-order Functional Reactive Programming Description: Reflex is a high-performance, deterministic, higher-order Functional Reactive Programming system License: BSD3 @@ -74,7 +74,7 @@ library time >= 1.4 && < 1.9, transformers >= 0.5.6.0 && < 0.6, unbounded-delays >= 0.1.0.0 && < 0.2, - witherable >= 0.2 && < 0.4 + witherable >= 0.3 && < 0.3.2 if flag(split-these) build-depends: these >= 1 && <1.1, From 5480222a09bd7e5b5a72a4363b31a59f3353db0d Mon Sep 17 00:00:00 2001 From: Ali Abrar Date: Fri, 23 Aug 2019 05:45:49 -0400 Subject: [PATCH 191/241] Update to monoidal-containers 0.6, avoid 0.5 --- ChangeLog.md | 4 ++++ default.nix | 2 +- reflex.cabal | 6 +++--- 3 files changed, 8 insertions(+), 4 deletions(-) diff --git a/ChangeLog.md b/ChangeLog.md index ee546559..3f86168a 100644 --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,5 +1,9 @@ # Revision history for reflex +## 0.6.2.4 + +* Update to monoidal-containers 0.6 + ## 0.6.2.3 * Add an upper-bound to witherable diff --git a/default.nix b/default.nix index 4988c05d..1a514db5 100644 --- a/default.nix +++ b/default.nix @@ -12,7 +12,7 @@ }: mkDerivation { pname = "reflex"; - version = "0.6.2.3"; + version = "0.6.2.4"; src = builtins.filterSource (path: type: !(builtins.elem (baseNameOf path) [ ".git" "dist" ])) ./.; libraryHaskellDepends = [ base bifunctors containers dependent-map dependent-sum diff --git a/reflex.cabal b/reflex.cabal index 2f523428..a0984333 100644 --- a/reflex.cabal +++ b/reflex.cabal @@ -1,5 +1,5 @@ Name: reflex -Version: 0.6.2.3 +Version: 0.6.2.4 Synopsis: Higher-order Functional Reactive Programming Description: Reflex is a high-performance, deterministic, higher-order Functional Reactive Programming system License: BSD3 @@ -79,10 +79,10 @@ library if flag(split-these) build-depends: these >= 1 && <1.1, semialign >=1 && <1.1, - monoidal-containers >= 0.5.0.1 && < 0.6 + monoidal-containers >= 0.6 && < 0.7 else build-depends: these >= 0.4 && <0.9, - monoidal-containers == 0.5.0.0 + monoidal-containers == 0.4.0.0 exposed-modules: Control.Monad.ReaderIO From 44fae82c9bf7c047a0ce77f489ebb33b2704c5ca Mon Sep 17 00:00:00 2001 From: Oliver Batchelor Date: Thu, 29 Aug 2019 17:10:28 +1200 Subject: [PATCH 192/241] Fix broken recursive looping instance --- src/Data/AppendMap.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Data/AppendMap.hs b/src/Data/AppendMap.hs index 148f7a5c..5a3c2b50 100644 --- a/src/Data/AppendMap.hs +++ b/src/Data/AppendMap.hs @@ -48,7 +48,7 @@ pattern AppendMap m = MonoidalMap m #if !MIN_VERSION_witherable(0,3,2) instance W.Filterable (MonoidalMap k) where - mapMaybe = mapMaybe + mapMaybe = W.mapMaybe #endif -- | Deletes a key, returning 'Nothing' if the result is empty. From a5bee16f883fa72de31f04c8e1f82e8ebb3c096f Mon Sep 17 00:00:00 2001 From: Oliver Batchelor Date: Thu, 29 Aug 2019 17:18:44 +1200 Subject: [PATCH 193/241] Use correct module qualification this time --- src/Data/AppendMap.hs | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/src/Data/AppendMap.hs b/src/Data/AppendMap.hs index 5a3c2b50..b080dc1f 100644 --- a/src/Data/AppendMap.hs +++ b/src/Data/AppendMap.hs @@ -32,6 +32,8 @@ import qualified Data.Map as Map (showTree, showTreeWith) #endif import qualified Data.Witherable as W import Data.Map.Monoidal +import qualified Data.Map.Monoidal as MonoidalMap + {-# DEPRECATED AppendMap "Use 'MonoidalMap' instead" #-} -- | AppendMap is a synonym for 'Data.Map.Monoidal.MonoidalMap' @@ -48,7 +50,7 @@ pattern AppendMap m = MonoidalMap m #if !MIN_VERSION_witherable(0,3,2) instance W.Filterable (MonoidalMap k) where - mapMaybe = W.mapMaybe + mapMaybe = MonoidalMap.mapMaybe #endif -- | Deletes a key, returning 'Nothing' if the result is empty. From 8c1378db2f671948c03fe41eea686b7c07fcc349 Mon Sep 17 00:00:00 2001 From: Johannes Gerer Date: Sun, 20 Oct 2019 20:37:13 +0100 Subject: [PATCH 194/241] fix bug in patchThatSortsMapWith. buggy implementation violates the invariant --- src/Reflex/Patch/MapWithMove.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Reflex/Patch/MapWithMove.hs b/src/Reflex/Patch/MapWithMove.hs index 8563ff24..ccdb8b4d 100644 --- a/src/Reflex/Patch/MapWithMove.hs +++ b/src/Reflex/Patch/MapWithMove.hs @@ -155,7 +155,7 @@ patchThatSortsMapWith cmp m = PatchMapWithMove $ Map.fromList $ catMaybes $ zipW Just (from, to) reverseMapping = Map.fromList $ catMaybes $ zipWith f unsorted sorted g (to, _) (from, _) = if to == from then Nothing else - let Just movingTo = Map.lookup from reverseMapping + let Just movingTo = Map.lookup to reverseMapping in Just (to, NodeInfo (From_Move from) $ Just movingTo) -- | Create a 'PatchMapWithMove' that, if applied to the first 'Map' provided, From 74c1db3d977708bfe9ce743a4f76ea9ccd541e00 Mon Sep 17 00:00:00 2001 From: Oleg Grenrus Date: Mon, 21 Oct 2019 13:47:00 +0300 Subject: [PATCH 195/241] Support semialign-1.1 --- reflex.cabal | 2 +- src/Reflex/Class.hs | 10 ++++++++-- src/Reflex/Collection.hs | 5 ++++- src/Reflex/Spider/Internal.hs | 10 ++++++++-- 4 files changed, 21 insertions(+), 6 deletions(-) diff --git a/reflex.cabal b/reflex.cabal index a0984333..e297bf3c 100644 --- a/reflex.cabal +++ b/reflex.cabal @@ -78,7 +78,7 @@ library if flag(split-these) build-depends: these >= 1 && <1.1, - semialign >=1 && <1.1, + semialign >=1 && <1.2, monoidal-containers >= 0.6 && < 0.7 else build-depends: these >= 0.4 && <0.9, diff --git a/src/Reflex/Class.hs b/src/Reflex/Class.hs index dd5a3d8c..4d81a1b9 100644 --- a/src/Reflex/Class.hs +++ b/src/Reflex/Class.hs @@ -173,12 +173,15 @@ module Reflex.Class , slowHeadE ) where -#if defined(MIN_VERSION_semialign) +#ifdef MIN_VERSION_semialign import Prelude hiding (zip, zipWith) #if MIN_VERSION_these(0,8,0) import Data.These.Combinators (justThese) #endif +#if MIN_VERSION_semialign(1,1,0) +import Data.Zip (Zip (..)) +#endif #endif import Control.Applicative @@ -1077,7 +1080,10 @@ instance Reflex t => Semialign (Event t) where #endif align = alignEventWithMaybe Just -#if defined(MIN_VERSION_semialign) +#ifdef MIN_VERSION_semialign +#if MIN_VERSION_semialign(1,1,0) +instance Reflex t => Zip (Event t) where +#endif zip x y = mapMaybe justThese $ align x y #endif diff --git a/src/Reflex/Collection.hs b/src/Reflex/Collection.hs index 16a55c09..952e566c 100644 --- a/src/Reflex/Collection.hs +++ b/src/Reflex/Collection.hs @@ -27,8 +27,11 @@ module Reflex.Collection , simpleList ) where -#if defined(MIN_VERSION_semialign) +#ifdef MIN_VERSION_semialign import Prelude hiding (zip, zipWith) +#if MIN_VERSION_semialign(1,1,0) +import Data.Zip (Zip (..)) +#endif #endif import Control.Monad.Identity diff --git a/src/Reflex/Spider/Internal.hs b/src/Reflex/Spider/Internal.hs index 90ceca78..cf9570cf 100644 --- a/src/Reflex/Spider/Internal.hs +++ b/src/Reflex/Spider/Internal.hs @@ -72,10 +72,13 @@ import System.IO.Unsafe import System.Mem.Weak import Unsafe.Coerce -#if defined(MIN_VERSION_semialign) +#ifdef MIN_VERSION_semialign #if MIN_VERSION_these(0,8,0) import Data.These.Combinators (justThese) #endif +#if MIN_VERSION_semialign(1,1,0) +import Data.Zip (Zip (..)) +#endif #endif #ifdef DEBUG_CYCLES @@ -1163,7 +1166,10 @@ instance HasSpiderTimeline x => Semialign (Event x) where align ea eb = mapMaybe dmapToThese $ mergeG coerce $ dynamicConst $ DMap.fromDistinctAscList [LeftTag :=> ea, RightTag :=> eb] -#if defined(MIN_VERSION_semialign) +#ifdef MIN_VERSION_semialign +#if MIN_VERSION_semialign(1,1,0) +instance HasSpiderTimeline x => Zip (Event x) where +#endif zip x y = mapMaybe justThese $ align x y #endif From 5e6dc64fe2562ac841ad1da7a3b7ed70ad20780d Mon Sep 17 00:00:00 2001 From: Alexandre Esteves Date: Sun, 10 Nov 2019 20:14:09 +0000 Subject: [PATCH 196/241] Remove duplicate dependency on profunctions --- reflex.cabal | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/reflex.cabal b/reflex.cabal index e297bf3c..1dd851b9 100644 --- a/reflex.cabal +++ b/reflex.cabal @@ -58,13 +58,12 @@ library data-default >= 0.5 && < 0.8, dependent-map >= 0.3 && < 0.4, exception-transformers == 0.4.*, - profunctors >= 5.3 && < 5.5, lens >= 4.7 && < 5, monad-control >= 1.0.1 && < 1.1, mtl >= 2.1 && < 2.3, prim-uniq >= 0.1.0.1 && < 0.2, primitive >= 0.5 && < 0.8, - profunctors, + profunctors >= 5.3 && < 5.5, random == 1.1.*, ref-tf == 0.4.*, reflection == 2.1.*, From 0d94d6566f771088d1f505d9a5147d10ada42962 Mon Sep 17 00:00:00 2001 From: John Ericson Date: Wed, 13 Nov 2019 23:04:54 -0500 Subject: [PATCH 197/241] Remove unused files for hydra --- hydra.json | 29 ---------------------- jobsets.nix | 70 ----------------------------------------------------- 2 files changed, 99 deletions(-) delete mode 100644 hydra.json delete mode 100644 jobsets.nix diff --git a/hydra.json b/hydra.json deleted file mode 100644 index a204840a..00000000 --- a/hydra.json +++ /dev/null @@ -1,29 +0,0 @@ -{ - "enabled": 1, - "hidden": true, - "description": "Jobsets", - "nixexprinput": "src", - "nixexprpath": "jobsets.nix", - "checkinterval": 300, - "schedulingshares": 100, - "enableemail": false, - "emailoverride": "", - "keepnr": 10, - "inputs": { - "src": { - "type": "git", - "value": "https://github.com/reflex-frp/reflex.git develop", - "emailresponsible": false - }, - "nixpkgs": { - "type": "git", - "value": "https://github.com/NixOS/nixpkgs-channels nixos-unstable", - "emailresponsible": false - }, - "prs": { - "type": "githubpulls", - "value": "reflex-frp reflex", - "emailresponsible": false - } - } -} diff --git a/jobsets.nix b/jobsets.nix deleted file mode 100644 index bf1c30aa..00000000 --- a/jobsets.nix +++ /dev/null @@ -1,70 +0,0 @@ -{ prs }: - -let - pkgs = (import ./reflex-platform.nix {}).nixpkgs; - mkFetchGithub = value: { - inherit value; - type = "git"; - emailresponsible = false; - }; -in -with pkgs.lib; -let - defaults = jobs: { - inherit (jobs) description; - enabled = 1; - hidden = false; - keepnr = 10; - schedulingshares = 100; - checkinterval = 120; - enableemail = false; - emailoverride = ""; - nixexprinput = "reflex"; - nixexprpath = "release.nix"; - inputs = jobs.inputs // { - nixpkgs = { - type = "git"; - value = "https://github.com/NixOS/nixpkgs-channels nixos-unstable"; - emailresponsible = false; - }; - config = { - type = "nix"; - value = "{ android_sdk.accept_license = true; }"; - emailresponsible = false; - }; - }; - }; - branchJobset = branch: defaults { - description = "reflex-${branch}"; - inputs = { - reflex = { - value = "https://github.com/reflex-frp/reflex ${branch}"; - type = "git"; - emailresponsible = false; - }; - }; - }; - makePr = num: info: { - name = "reflex-pr-${num}"; - value = defaults { - description = "#${num}: ${info.title}"; - inputs = { - reflex = { - #NOTE: This should really use "pull/${num}/merge"; however, GitHub's - #status checks only operate on PR heads. This creates a race - #condition, which can currently only be solved by requiring PRs to be - #up to date before they're merged. See - #https://github.com/isaacs/github/issues/1002 - value = "https://github.com/reflex-frp/reflex pull/${num}/head"; - type = "git"; - emailresponsible = false; - }; - }; - }; - }; - processedPrs = mapAttrs' makePr (builtins.fromJSON (builtins.readFile prs)); - jobsetsAttrs = processedPrs // - genAttrs ["develop"] branchJobset; -in { - jobsets = pkgs.writeText "spec.json" (builtins.toJSON jobsetsAttrs); -} From a64de1d017e9133c007291af6a3b7ef654dcfcf3 Mon Sep 17 00:00:00 2001 From: John Ericson Date: Wed, 13 Nov 2019 23:10:03 -0500 Subject: [PATCH 198/241] Switch to thunk for reflex platform --- dep/reflex-platform/default.nix | 7 +++++++ dep/reflex-platform/github.json | 7 +++++++ reflex-platform.nix | 8 -------- release.nix | 2 +- 4 files changed, 15 insertions(+), 9 deletions(-) create mode 100644 dep/reflex-platform/default.nix create mode 100644 dep/reflex-platform/github.json delete mode 100644 reflex-platform.nix diff --git a/dep/reflex-platform/default.nix b/dep/reflex-platform/default.nix new file mode 100644 index 00000000..7a047786 --- /dev/null +++ b/dep/reflex-platform/default.nix @@ -0,0 +1,7 @@ +# DO NOT HAND-EDIT THIS FILE +import ((import {}).fetchFromGitHub ( + let json = builtins.fromJSON (builtins.readFile ./github.json); + in { inherit (json) owner repo rev sha256; + private = json.private or false; + } +)) diff --git a/dep/reflex-platform/github.json b/dep/reflex-platform/github.json new file mode 100644 index 00000000..e6480d2d --- /dev/null +++ b/dep/reflex-platform/github.json @@ -0,0 +1,7 @@ +{ + "owner": "reflex-frp", + "repo": "reflex-platform", + "branch": "develop", + "rev": "384cd850f3adf1d404bced2424b5f6efb0f415f2", + "sha256": "1ws77prqx8khmp8j6br1ij4k2v4dlgv170r9fmg0p1jivfbn8y9d" +} diff --git a/reflex-platform.nix b/reflex-platform.nix deleted file mode 100644 index e0b244b1..00000000 --- a/reflex-platform.nix +++ /dev/null @@ -1,8 +0,0 @@ -let - reflex-platform-src = (import {}).fetchFromGitHub { - owner = "reflex-frp"; - repo = "reflex-platform"; - rev = "384cd850f3adf1d404bced2424b5f6efb0f415f2"; - sha256 = "1ws77prqx8khmp8j6br1ij4k2v4dlgv170r9fmg0p1jivfbn8y9d"; - }; -in import reflex-platform-src diff --git a/release.nix b/release.nix index 3b101428..139bcd8d 100644 --- a/release.nix +++ b/release.nix @@ -1,4 +1,4 @@ -{ rp ? import ./reflex-platform.nix {} +{ rp ? import ./dep/reflex-platform {} }: let inherit (rp.nixpkgs) lib; From 98a66d77116ff50c3127255973d3bd160cea7b3a Mon Sep 17 00:00:00 2001 From: John Ericson Date: Wed, 13 Nov 2019 23:12:32 -0500 Subject: [PATCH 199/241] Modernize release.nix using way newer reflex-platform, --- dep/reflex-platform/github.json | 4 +-- release.nix | 43 +++++++++++++++++++++++++++------ 2 files changed, 38 insertions(+), 9 deletions(-) diff --git a/dep/reflex-platform/github.json b/dep/reflex-platform/github.json index e6480d2d..2e1c50f0 100644 --- a/dep/reflex-platform/github.json +++ b/dep/reflex-platform/github.json @@ -2,6 +2,6 @@ "owner": "reflex-frp", "repo": "reflex-platform", "branch": "develop", - "rev": "384cd850f3adf1d404bced2424b5f6efb0f415f2", - "sha256": "1ws77prqx8khmp8j6br1ij4k2v4dlgv170r9fmg0p1jivfbn8y9d" + "rev": "338fc907e37d70e6469c529456f33221fb05ca1f", + "sha256": "08gfhpp0pkvvi1wnlpcn6wmpzdjvy5z7dy1h66gp2w8b5cx8hx5h" } diff --git a/release.nix b/release.nix index 139bcd8d..aafc18d2 100644 --- a/release.nix +++ b/release.nix @@ -1,9 +1,38 @@ -{ rp ? import ./dep/reflex-platform {} +{ reflex-platform-fun ? import ./dep/reflex-platform }: + let - inherit (rp.nixpkgs) lib; - compilers = ["ghc8_4" "ghc8_0" "ghcjs8_4" "ghcjs8_0"]; -in lib.attrValues (lib.genAttrs compilers (ghc: { - reflex-useTemplateHaskell = rp.${ghc}.callPackage ./. { useTemplateHaskell = true; splitThese = false; }; - reflex = rp.${ghc}.callPackage ./. { useTemplateHaskell = false; splitThese = false; }; -})) + native-reflex-platform = reflex-platform-fun {}; + inherit (native-reflex-platform.nixpkgs) lib; + systems = ["x86_64-linux" "x86_64-darwin"]; + + perPlatform = lib.genAttrs systems (system: let + reflex-platform = reflex-platform-fun { inherit system; }; + compilers = [ + "ghc" + "ghcjs" + ] ++ lib.optionals (reflex-platform.androidSupport) [ + "ghcAndroidAarch64" + "ghcAndroidAarch32" + ] ++ lib.optionals (reflex-platform.iosSupport) [ + "ghcIosAarch64" + ]; + hsPkgs = lib.genAttrs compilers (ghc: let + ghc' = reflex-platform.${ghc}.override { + overrides = self: super: { + reflex-useTemplateHaskell = self.callPackage ./. { useTemplateHaskell = true; splitThese = false; }; + reflex = self.callPackage ./. { useTemplateHaskell = false; splitThese = false; }; + }; + }; + in { + inherit (ghc') reflex reflex-useTemplateHaskell; + }); + in hsPkgs // { + cache = reflex-platform.pinBuildInputs "reflex-${system}" + (lib.concatLists (map builtins.attrValues (builtins.attrValues hsPkgs))); + }); + + metaCache = native-reflex-platform.pinBuildInputs "reflex-everywhere" + (map (a: a.cache) (builtins.attrValues perPlatform)); + +in perPlatform // { inherit metaCache; } From cb7321ff51fc32cb60c5311b0c4989ce71447cea Mon Sep 17 00:00:00 2001 From: John Ericson Date: Wed, 13 Nov 2019 23:39:44 -0500 Subject: [PATCH 200/241] Use callCabal2nix --- default.nix | 43 ------------------------------------------- release.nix | 4 ++-- 2 files changed, 2 insertions(+), 45 deletions(-) delete mode 100644 default.nix diff --git a/default.nix b/default.nix deleted file mode 100644 index 1a514db5..00000000 --- a/default.nix +++ /dev/null @@ -1,43 +0,0 @@ -{ mkDerivation, ghc, base, bifunctors, containers, deepseq -, dependent-map, dependent-sum, exception-transformers -, haskell-src-exts, haskell-src-meta, hlint, lens, MemoTrie -, monad-control, mtl, primitive, random, ref-tf -, semigroupoids , semigroups, split, stdenv, stm, syb -, template-haskell , these, time, transformers -, transformers-compat, unbounded-delays, prim-uniq -, data-default, filepath, directory, filemanip, ghcjs-base -, monoidal-containers, witherable, profunctors -, semialign ? null, splitThese ? (semialign != null) -, useTemplateHaskell ? true -}: -mkDerivation { - pname = "reflex"; - version = "0.6.2.4"; - src = builtins.filterSource (path: type: !(builtins.elem (baseNameOf path) [ ".git" "dist" ])) ./.; - libraryHaskellDepends = [ - base bifunctors containers dependent-map dependent-sum - exception-transformers lens - MemoTrie monad-control mtl primitive ref-tf semigroupoids - semigroups stm syb template-haskell these transformers - transformers-compat prim-uniq - base bifunctors containers deepseq dependent-map dependent-sum - mtl ref-tf split transformers data-default - random time unbounded-delays monoidal-containers witherable - profunctors - ] ++ (if ghc.isGhcjs or false then [ - ghcjs-base - ] else []) ++ (if !useTemplateHaskell then [] else [ - haskell-src-exts haskell-src-meta - ]) ++ (if splitThese then [ - semialign - ] else []); - testHaskellDepends = if ghc.isGhcjs or false then [] else [ - hlint filepath directory filemanip - ]; - configureFlags = - stdenv.lib.optional (!useTemplateHaskell) [ "-f-use-template-haskell" ] ++ - stdenv.lib.optional (!splitThese) [ "-f-split-these" ]; - homepage = "https://github.com/reflex-frp/reflex"; - description = "Higher-order Functional Reactive Programming"; - license = stdenv.lib.licenses.bsd3; -} diff --git a/release.nix b/release.nix index aafc18d2..4d20b617 100644 --- a/release.nix +++ b/release.nix @@ -20,8 +20,8 @@ let hsPkgs = lib.genAttrs compilers (ghc: let ghc' = reflex-platform.${ghc}.override { overrides = self: super: { - reflex-useTemplateHaskell = self.callPackage ./. { useTemplateHaskell = true; splitThese = false; }; - reflex = self.callPackage ./. { useTemplateHaskell = false; splitThese = false; }; + reflex-useTemplateHaskell = self.callCabal2nixWithOptions "reflex" ./. "-f +use-template-haskell" {}; + reflex = self.callCabal2nixWithOptions "reflex" ./. "-f -use-template-haskell" {}; }; }; in { From 322fd678059d391f1963670de8b99e95174ac160 Mon Sep 17 00:00:00 2001 From: Alexandre Esteves Date: Mon, 25 Nov 2019 02:23:17 +0000 Subject: [PATCH 201/241] Mention 'runWithReplace' in quickref --- Quickref.md | 25 ++++++++++++++----------- 1 file changed, 14 insertions(+), 11 deletions(-) diff --git a/Quickref.md b/Quickref.md index 62b0bcae..fd867c38 100644 --- a/Quickref.md +++ b/Quickref.md @@ -198,7 +198,7 @@ For Events, the returned Event fires whenever the latest Event supplied by the w The functions mentioned above are used to create a static FRP network. There are additional typeclasses that can be used to modify the FRP network, to have it interact with IO action, or to introspect the building of the network. -Th typeclasses and their associated annotations include: +The typeclasses and their associated annotations include: - `PostBuild` Fire an Event when an FRP network has been set up. @@ -206,7 +206,7 @@ Th typeclasses and their associated annotations include: [B] -- Function runs in any monad supporting PostBuild ``` -- `Adjustable` +- `Adjustable` Use Events to add or remove pieces of an FRP network. ```haskell [A] -- Function runs in any monad supporting Adjustable @@ -271,7 +271,7 @@ Th typeclasses and their associated annotations include: ```haskell -- Run side-effecting actions in Event when it occurs; returned Event contains -- results. Side effects run in the (Performable m) monad which is associated with --- the (PerformEvent t m) typeclass constraint. +-- the (PerformEvent t m) typeclass constraint. -- This allows for working with IO when a ((MonadIO (Performable m)) constraint is available. [P] performEvent :: Event (Performable m a ) -> m (Event a) @@ -295,17 +295,20 @@ Th typeclasses and their associated annotations include: ## Networks ```haskell --- Functions from Reflex.Network used to deal with Dynamics/Events carrying (m a) +-- Functions from Reflex.Adjustable / Reflex.Network used to deal with Dynamics/Events carrying (m a) --- Given a Dynamic of network-creating actions, create a network that is recreated whenever the Dynamic updates. --- The returned Event of network results occurs when the Dynamic does. Note: Often, the type a is an Event, +[A] runWithReplace :: m a -> Event t (m b) -> m (a, Event t b) + +-- Given a Dynamic of network-creating actions, create a network that is recreated whenever the Dynamic updates. +-- The returned Event of network results occurs when the Dynamic does. Note: Often, the type a is an Event, -- in which case the return value is an Event-of-Events that would typically be flattened (via switchHold). -[P,A] networkView :: Dynamic (m a) -> m (Event a) +[P,A] networkView :: Dynamic (m a) -> m (Event a) --- Given an initial network and an Event of network-creating actions, create a network that is recreated whenever the --- Event fires. The returned Dynamic of network results occurs when the Event does. Note: Often, the type a is an +-- Given an initial network and an Event of network-creating actions, create a network that is recreated whenever the +-- Event fires. The returned Dynamic of network results occurs when the Event does. Note: Often, the type a is an -- Event, in which case the return value is a Dynamic-of-Events that would typically be flattened. -[H,A] networkHold :: m a -> Event (m a) -> m (Dynamic a) +[H,A] networkHold :: m a -> Event (m a) -> m (Dynamic a) -- Render a placeholder network to be shown while another network is not yet done building -[P,A] untilReady :: m a -> m b -> m (a, Event b) +[P,A] untilReady :: m a -> m b -> m (a, Event b) +``` From 755a0cea6ac1c4886641efffefde5e8d4442b5ee Mon Sep 17 00:00:00 2001 From: Matthew Bauer Date: Mon, 25 Nov 2019 12:15:30 -0500 Subject: [PATCH 202/241] Ignore "traverse_" from hlint MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit In https://travis-ci.org/reflex-frp/reflex/builds/616304027 we notice that hlint suggests: linting file src/Reflex/Spider/Internal.hs... reflex-0.6.2.4/src/Reflex/Spider/Internal.hs:497:13: Warning: Use traverse_ Found: WeakBag.traverse (coincidenceSubscribedSubscribers subscribed) $ invalidateSubscriberHeight outerHeight Perhaps: traverse_ (coincidenceSubscribedSubscribers subscribed) $ invalidateSubscriberHeight outerHeight 1 hint This suggestion isn’t relevant because we don’t have a “traverse_” equivalent for WeakBag.traverse. Looking at the code in Hlint (src/Hint/Monad.hs), it becomes clear that it’s a dumb search for any usage of “traverse”, regardless of being in the Traversable typeclass. What’s less clear is why this used to not be a problem before recently. This error appears to coincide with an update of hlint from v2.2.2 to v2.2.4. To fix this, tell Hlint to ignore “Use traverse_” hints in Reflex. This can be removed once Hlint is taught to distinguise between traverse from the Traversable typeclass and from somewhere else. --- test/hlint.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/test/hlint.hs b/test/hlint.hs index 1b5164e1..d3188eaa 100644 --- a/test/hlint.hs +++ b/test/hlint.hs @@ -23,6 +23,7 @@ main = do , "--ignore=Reduce duplication" , "--cpp-define=USE_TEMPLATE_HASKELL" , "--ignore=Use tuple-section" + , "--ignore=Use traverse_" ] recurseInto = and <$> sequence [ fileType ==? Directory From 52eee43940636ecbb9547be55b7ee9ca42f802a5 Mon Sep 17 00:00:00 2001 From: Matthew Bauer Date: Mon, 25 Nov 2019 16:54:30 -0500 Subject: [PATCH 203/241] Rename Data.{Fast,}WeakBag.traverse to Data.{Fast,}WeakBag.traverse_ Renamed Data.FastWeakBag.traverse and Data.WeakBag.traverse to Data.FastWeakBag.traverse_ and Data.WeakBag.traverse_ respectively. This is a more accurate naming for the function as it has no resulting value in the same way Data.Foldable.traverse_, and unlike Data.Traverseable.traverse which has a resulting value. In addition, we do not have to ignore any hlint warnings any more. --- ChangeLog.md | 6 ++++++ src/Data/FastWeakBag.hs | 13 +++++++++---- src/Data/WeakBag.hs | 11 ++++++++--- src/Reflex/Spider/Internal.hs | 32 ++++++++++++++++---------------- test/hlint.hs | 1 - 5 files changed, 39 insertions(+), 24 deletions(-) diff --git a/ChangeLog.md b/ChangeLog.md index 3f86168a..9eb9a348 100644 --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,5 +1,11 @@ # Revision history for reflex +## Unreleased + +* Data.WeakBag.traverse and Data.FastWeakBag.traverse have been + renamed to Data.WeakBag.traverse_ and Data.FastWeakBag.traverse_ + respectively. + ## 0.6.2.4 * Update to monoidal-containers 0.6 diff --git a/src/Data/FastWeakBag.hs b/src/Data/FastWeakBag.hs index 75dd63b4..2fe8068b 100644 --- a/src/Data/FastWeakBag.hs +++ b/src/Data/FastWeakBag.hs @@ -18,6 +18,7 @@ module Data.FastWeakBag , isEmpty , insert , traverse + , traverse_ , remove -- * Internal functions -- These will not always be available. @@ -116,14 +117,14 @@ foreign import javascript unsafe "(function(){ for(var i = 0; i < $1.tickets.len isEmpty bag = {-# SCC "isEmpty" #-} IntMap.null <$> readIORef (_weakBag_children bag) #endif -{-# INLINE traverse #-} +{-# INLINE traverse_ #-} -- | Visit every node in the given list. If new nodes are appended during the -- traversal, they will not be visited. Every live node that was in the list -- when the traversal began will be visited exactly once; however, no guarantee -- is made about the order of the traversal. -traverse :: forall a m. MonadIO m => FastWeakBag a -> (a -> m ()) -> m () +traverse_ :: forall a m. MonadIO m => FastWeakBag a -> (a -> m ()) -> m () #ifdef GHCJS_FAST_WEAK -traverse wb f = do +traverse_ wb f = do let go cursor = when (not $ js_isNull cursor) $ do val <- liftIO $ js_getTicketValue cursor f $ unsafeFromRawJSVal val @@ -134,13 +135,17 @@ foreign import javascript unsafe "$r = $1.val;" js_getTicketValue :: JSVal -> IO --TODO: Fix the race condition where if a cursor is deleted (presumably using 'remove', below) while we're holding it, it can't find its way back to the correct bag foreign import javascript unsafe "(function(){ for(var i = $1.pos - 1; i >= 0; i--) { if($1.bag.tickets[i] !== null) { return $1.bag.tickets[i]; } }; return null; })()" js_getNext :: FastWeakBagTicket a -> IO JSVal --TODO: Clean up as we go along so this isn't O(n) every time -- Result can be null or a FastWeakBagTicket a #else -traverse (FastWeakBag _ children) f = {-# SCC "traverse" #-} do +traverse_ (FastWeakBag _ children) f = {-# SCC "traverse_" #-} do cs <- liftIO $ readIORef children forM_ cs $ \c -> do ma <- liftIO $ deRefWeak c mapM_ f ma #endif +{-# DEPRECATED traverse "Use 'traverse_' instead" #-} +traverse :: forall a m. MonadIO m => FastWeakBag a -> (a -> m ()) -> m () +traverse = traverse_ + -- | Remove an item from the 'FastWeakBag'; does nothing if invoked multiple times -- on the same 'FastWeakBagTicket'. {-# INLINE remove #-} diff --git a/src/Data/WeakBag.hs b/src/Data/WeakBag.hs index f7641272..cbd01ef1 100644 --- a/src/Data/WeakBag.hs +++ b/src/Data/WeakBag.hs @@ -15,6 +15,7 @@ module Data.WeakBag , singleton , insert , traverse + , traverse_ , remove -- * Internal functions -- These will not always be available. @@ -99,18 +100,22 @@ singleton a wbRef finalizer = {-# SCC "singleton" #-} do ticket <- insert a bag wbRef finalizer return (bag, ticket) -{-# INLINE traverse #-} +{-# INLINE traverse_ #-} -- | Visit every node in the given list. If new nodes are appended during the -- traversal, they will not be visited. Every live node that was in the list -- when the traversal began will be visited exactly once; however, no guarantee -- is made about the order of the traversal. -traverse :: MonadIO m => WeakBag a -> (a -> m ()) -> m () -traverse (WeakBag _ children) f = {-# SCC "traverse" #-} do +traverse_ :: MonadIO m => WeakBag a -> (a -> m ()) -> m () +traverse_ (WeakBag _ children) f = {-# SCC "traverse" #-} do cs <- liftIO $ readIORef children forM_ cs $ \c -> do ma <- liftIO $ deRefWeak c mapM_ f ma +{-# DEPRECATED traverse "Use 'traverse_' instead" #-} +traverse :: MonadIO m => WeakBag a -> (a -> m ()) -> m () +traverse = traverse_ + -- | Remove an item from the 'WeakBag'; does nothing if invoked multiple times -- on the same 'WeakBagTicket'. {-# INLINE remove #-} diff --git a/src/Reflex/Spider/Internal.hs b/src/Reflex/Spider/Internal.hs index cf9570cf..5fd07a13 100644 --- a/src/Reflex/Spider/Internal.hs +++ b/src/Reflex/Spider/Internal.hs @@ -332,9 +332,9 @@ cacheEvent e = scheduleClear occRef propagateFast a subscribers , subscriberInvalidateHeight = \old -> do - FastWeakBag.traverse subscribers $ invalidateSubscriberHeight old + FastWeakBag.traverse_ subscribers $ invalidateSubscriberHeight old , subscriberRecalculateHeight = \new -> do - FastWeakBag.traverse subscribers $ recalculateSubscriberHeight new + FastWeakBag.traverse_ subscribers $ recalculateSubscriberHeight new } when (isJust occ) $ do liftIO $ writeIORef occRef occ -- Set the initial value of occRef; we don't need to do this if occ is Nothing @@ -450,12 +450,12 @@ newSubscriberFan subscribed = return $ Subscriber , subscriberInvalidateHeight = \old -> do when debugInvalidateHeight $ putStrLn $ "invalidateSubscriberHeight: SubscriberFan" <> showNodeId subscribed subscribers <- readIORef $ fanSubscribedSubscribers subscribed - forM_ (DMap.toList subscribers) $ \(_ :=> v) -> WeakBag.traverse (_fanSubscribedChildren_list v) $ invalidateSubscriberHeight old + forM_ (DMap.toList subscribers) $ \(_ :=> v) -> WeakBag.traverse_ (_fanSubscribedChildren_list v) $ invalidateSubscriberHeight old when debugInvalidateHeight $ putStrLn $ "invalidateSubscriberHeight: SubscriberFan" <> showNodeId subscribed <> " done" , subscriberRecalculateHeight = \new -> do when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: SubscriberFan" <> showNodeId subscribed subscribers <- readIORef $ fanSubscribedSubscribers subscribed - forM_ (DMap.toList subscribers) $ \(_ :=> v) -> WeakBag.traverse (_fanSubscribedChildren_list v) $ recalculateSubscriberHeight new + forM_ (DMap.toList subscribers) $ \(_ :=> v) -> WeakBag.traverse_ (_fanSubscribedChildren_list v) $ recalculateSubscriberHeight new when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: SubscriberFan" <> showNodeId subscribed <> " done" } @@ -471,7 +471,7 @@ newSubscriberSwitch subscribed = return $ Subscriber oldHeight <- readIORef $ switchSubscribedHeight subscribed when (oldHeight /= invalidHeight) $ do writeIORef (switchSubscribedHeight subscribed) $! invalidHeight - WeakBag.traverse (switchSubscribedSubscribers subscribed) $ invalidateSubscriberHeight oldHeight + WeakBag.traverse_ (switchSubscribedSubscribers subscribed) $ invalidateSubscriberHeight oldHeight when debugInvalidateHeight $ putStrLn $ "invalidateSubscriberHeight: SubscriberSwitch" <> showNodeId subscribed <> " done" , subscriberRecalculateHeight = \new -> do when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: SubscriberSwitch" <> showNodeId subscribed @@ -494,8 +494,8 @@ newSubscriberCoincidenceOuter subscribed = return $ Subscriber Nothing -> do when (innerHeight > outerHeight) $ liftIO $ do -- If the event fires, it will fire at a later height writeIORef (coincidenceSubscribedHeight subscribed) $! innerHeight - WeakBag.traverse (coincidenceSubscribedSubscribers subscribed) $ invalidateSubscriberHeight outerHeight - WeakBag.traverse (coincidenceSubscribedSubscribers subscribed) $ recalculateSubscriberHeight innerHeight + WeakBag.traverse_ (coincidenceSubscribedSubscribers subscribed) $ invalidateSubscriberHeight outerHeight + WeakBag.traverse_ (coincidenceSubscribedSubscribers subscribed) $ recalculateSubscriberHeight innerHeight Just o -> do -- Since it's already firing, no need to adjust height liftIO $ writeIORef (coincidenceSubscribedOccurrence subscribed) occ scheduleClear $ coincidenceSubscribedOccurrence subscribed @@ -542,14 +542,14 @@ propagate :: a -> WeakBag (Subscriber x a) -> EventM x () propagate a subscribers = withIncreasedDepth $ do -- Note: in the following traversal, we do not visit nodes that are added to the list during our traversal; they are new events, which will necessarily have full information already, so there is no need to traverse them --TODO: Should we check if nodes already have their values before propagating? Maybe we're re-doing work - WeakBag.traverse subscribers $ \s -> subscriberPropagate s a + WeakBag.traverse_ subscribers $ \s -> subscriberPropagate s a -- | Propagate everything at the current height propagateFast :: a -> FastWeakBag (Subscriber x a) -> EventM x () propagateFast a subscribers = withIncreasedDepth $ do -- Note: in the following traversal, we do not visit nodes that are added to the list during our traversal; they are new events, which will necessarily have full information already, so there is no need to traverse them --TODO: Should we check if nodes already have their values before propagating? Maybe we're re-doing work - FastWeakBag.traverse subscribers $ \s -> subscriberPropagate s a + FastWeakBag.traverse_ subscribers $ \s -> subscriberPropagate s a -------------------------------------------------------------------------------- -- EventSubscribed @@ -1527,15 +1527,15 @@ fanInt p = unsafePerformIO $ do liftIO $ writeIORef (_fanInt_occRef self) m scheduleIntClear $ _fanInt_occRef self FastMutableIntMap.forIntersectionWithImmutable_ (_fanInt_subscribers self) m $ \b v -> do --TODO: Do we need to know that no subscribers are being added as we traverse? - FastWeakBag.traverse b $ \s -> do + FastWeakBag.traverse_ b $ \s -> do subscriberPropagate s v , subscriberInvalidateHeight = \old -> do FastMutableIntMap.for_ (_fanInt_subscribers self) $ \b -> do - FastWeakBag.traverse b $ \s -> do + FastWeakBag.traverse_ b $ \s -> do subscriberInvalidateHeight s old , subscriberRecalculateHeight = \new -> do FastMutableIntMap.for_ (_fanInt_subscribers self) $ \b -> do - FastWeakBag.traverse b $ \s -> do + FastWeakBag.traverse_ b $ \s -> do subscriberRecalculateHeight s new } liftIO $ do @@ -2207,7 +2207,7 @@ runFrame a = SpiderHost $ do myHeight <- readIORef $ switchSubscribedHeight subscribed when (parentHeight /= myHeight) $ do writeIORef (switchSubscribedHeight subscribed) $! invalidHeight - WeakBag.traverse (switchSubscribedSubscribers subscribed) $ invalidateSubscriberHeight myHeight + WeakBag.traverse_ (switchSubscribedSubscribers subscribed) $ invalidateSubscriberHeight myHeight mapM_ _someMergeUpdate_invalidateHeight mergeUpdates --TODO: In addition to when the patch is completely empty, we should also not run this if it has some Nothing values, but none of them have actually had any effect; potentially, we could even check for Just values with no effect (e.g. by comparing their IORefs and ignoring them if they are unchanged); actually, we could just check if the new height is different forM_ coincidenceInfos $ \(SomeResetCoincidence subscription mcs) -> do unsubscribe subscription @@ -2248,7 +2248,7 @@ invalidateCoincidenceHeight subscribed = do oldHeight <- readIORef $ coincidenceSubscribedHeight subscribed when (oldHeight /= invalidHeight) $ do writeIORef (coincidenceSubscribedHeight subscribed) $! invalidHeight - WeakBag.traverse (coincidenceSubscribedSubscribers subscribed) $ invalidateSubscriberHeight oldHeight + WeakBag.traverse_ (coincidenceSubscribedSubscribers subscribed) $ invalidateSubscriberHeight oldHeight updateSwitchHeight :: Height -> SwitchSubscribed x a -> IO () updateSwitchHeight new subscribed = do @@ -2256,7 +2256,7 @@ updateSwitchHeight new subscribed = do when (oldHeight == invalidHeight) $ do --TODO: This 'when' should probably be an assertion when (new /= invalidHeight) $ do --TODO: This 'when' should probably be an assertion writeIORef (switchSubscribedHeight subscribed) $! new - WeakBag.traverse (switchSubscribedSubscribers subscribed) $ recalculateSubscriberHeight new + WeakBag.traverse_ (switchSubscribedSubscribers subscribed) $ recalculateSubscriberHeight new recalculateCoincidenceHeight :: CoincidenceSubscribed x a -> IO () recalculateCoincidenceHeight subscribed = do @@ -2265,7 +2265,7 @@ recalculateCoincidenceHeight subscribed = do height <- calculateCoincidenceHeight subscribed when (height /= invalidHeight) $ do writeIORef (coincidenceSubscribedHeight subscribed) $! height - WeakBag.traverse (coincidenceSubscribedSubscribers subscribed) $ recalculateSubscriberHeight height + WeakBag.traverse_ (coincidenceSubscribedSubscribers subscribed) $ recalculateSubscriberHeight height calculateSwitchHeight :: SwitchSubscribed x a -> IO Height calculateSwitchHeight subscribed = getEventSubscribedHeight . _eventSubscription_subscribed =<< readIORef (switchSubscribedCurrentParent subscribed) diff --git a/test/hlint.hs b/test/hlint.hs index d3188eaa..1b5164e1 100644 --- a/test/hlint.hs +++ b/test/hlint.hs @@ -23,7 +23,6 @@ main = do , "--ignore=Reduce duplication" , "--cpp-define=USE_TEMPLATE_HASKELL" , "--ignore=Use tuple-section" - , "--ignore=Use traverse_" ] recurseInto = and <$> sequence [ fileType ==? Directory From 05bc3c31bd3f3bf093d9a0c608c485e1d2d3d444 Mon Sep 17 00:00:00 2001 From: E Cardenas Date: Wed, 4 Dec 2019 17:08:34 -0500 Subject: [PATCH 204/241] fix builds failing due to these-lens pulling in old lens --- default.nix | 3 ++- dep/reflex-platform/github.json | 6 +++--- release.nix | 4 ++-- 3 files changed, 7 insertions(+), 6 deletions(-) diff --git a/default.nix b/default.nix index 1a514db5..6554f739 100644 --- a/default.nix +++ b/default.nix @@ -7,7 +7,7 @@ , transformers-compat, unbounded-delays, prim-uniq , data-default, filepath, directory, filemanip, ghcjs-base , monoidal-containers, witherable, profunctors -, semialign ? null, splitThese ? (semialign != null) +, splitThese ? (semialign != null), semialign ? null, these-lens ? null , useTemplateHaskell ? true }: mkDerivation { @@ -30,6 +30,7 @@ mkDerivation { haskell-src-exts haskell-src-meta ]) ++ (if splitThese then [ semialign + these-lens ] else []); testHaskellDepends = if ghc.isGhcjs or false then [] else [ hlint filepath directory filemanip diff --git a/dep/reflex-platform/github.json b/dep/reflex-platform/github.json index 2e1c50f0..7319adab 100644 --- a/dep/reflex-platform/github.json +++ b/dep/reflex-platform/github.json @@ -1,7 +1,7 @@ { "owner": "reflex-frp", "repo": "reflex-platform", - "branch": "develop", - "rev": "338fc907e37d70e6469c529456f33221fb05ca1f", - "sha256": "08gfhpp0pkvvi1wnlpcn6wmpzdjvy5z7dy1h66gp2w8b5cx8hx5h" + "branch": "jailbreakTheselens", + "rev": "4284ed527c96c373538dc7e31776d9a50ca6aa91", + "sha256": "1m1nkxq7ng9wnqbd77xn8d81f2iz8g61y5m0r3gp0gi0q59jm8ay" } diff --git a/release.nix b/release.nix index aafc18d2..6eeff307 100644 --- a/release.nix +++ b/release.nix @@ -20,8 +20,8 @@ let hsPkgs = lib.genAttrs compilers (ghc: let ghc' = reflex-platform.${ghc}.override { overrides = self: super: { - reflex-useTemplateHaskell = self.callPackage ./. { useTemplateHaskell = true; splitThese = false; }; - reflex = self.callPackage ./. { useTemplateHaskell = false; splitThese = false; }; + reflex-useTemplateHaskell = self.callPackage ./. { useTemplateHaskell = true; }; + reflex = self.callPackage ./. { useTemplateHaskell = false; }; }; }; in { From c075e3659eed027de0841df2b53900255c242425 Mon Sep 17 00:00:00 2001 From: John Ericson Date: Mon, 9 Dec 2019 13:00:17 -0500 Subject: [PATCH 205/241] Add missing these-lens dep The cabal file had it but not the default.nix. --- default.nix | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/default.nix b/default.nix index 1a514db5..6554f739 100644 --- a/default.nix +++ b/default.nix @@ -7,7 +7,7 @@ , transformers-compat, unbounded-delays, prim-uniq , data-default, filepath, directory, filemanip, ghcjs-base , monoidal-containers, witherable, profunctors -, semialign ? null, splitThese ? (semialign != null) +, splitThese ? (semialign != null), semialign ? null, these-lens ? null , useTemplateHaskell ? true }: mkDerivation { @@ -30,6 +30,7 @@ mkDerivation { haskell-src-exts haskell-src-meta ]) ++ (if splitThese then [ semialign + these-lens ] else []); testHaskellDepends = if ghc.isGhcjs or false then [] else [ hlint filepath directory filemanip From 22bdea0013f868dff6f9924109ef146c386cd035 Mon Sep 17 00:00:00 2001 From: John Ericson Date: Mon, 9 Dec 2019 18:56:55 +0000 Subject: [PATCH 206/241] Filter more nix sources that shouldn't pollute the haskell build. --- default.nix | 7 ++++++- 1 file changed, 6 insertions(+), 1 deletion(-) diff --git a/default.nix b/default.nix index 6554f739..0481b11f 100644 --- a/default.nix +++ b/default.nix @@ -13,7 +13,12 @@ mkDerivation { pname = "reflex"; version = "0.6.2.4"; - src = builtins.filterSource (path: type: !(builtins.elem (baseNameOf path) [ ".git" "dist" ])) ./.; + src = builtins.filterSource (path: type: !(builtins.elem (baseNameOf path) [ + "default.nix" + "release.nix" + ".git" + "dist" + ])) ./.; libraryHaskellDepends = [ base bifunctors containers dependent-map dependent-sum exception-transformers lens From a5f07e8ebad39d958f89143f9d207f2412906be1 Mon Sep 17 00:00:00 2001 From: John Ericson Date: Mon, 9 Dec 2019 18:54:36 +0000 Subject: [PATCH 207/241] Fix TH splicing builds in CI `haskell-overlays/splices-load-save/load-splices.nix` in reflex-platform uses the name of the package to pull out the splices. But we have two packages both with the package name "reflex". This hack makes the TH one have the `reflex` attribute name, so we splice with TH. Gross, but gets the job done. --- release.nix | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/release.nix b/release.nix index 6eeff307..540f0851 100644 --- a/release.nix +++ b/release.nix @@ -20,12 +20,12 @@ let hsPkgs = lib.genAttrs compilers (ghc: let ghc' = reflex-platform.${ghc}.override { overrides = self: super: { - reflex-useTemplateHaskell = self.callPackage ./. { useTemplateHaskell = true; }; - reflex = self.callPackage ./. { useTemplateHaskell = false; }; + reflex-dontUseTemplateHaskell = self.callPackage ./. { useTemplateHaskell = false; }; + reflex = self.callPackage ./. { useTemplateHaskell = true; }; }; }; in { - inherit (ghc') reflex reflex-useTemplateHaskell; + inherit (ghc') reflex reflex-dontUseTemplateHaskell; }); in hsPkgs // { cache = reflex-platform.pinBuildInputs "reflex-${system}" From 1c6b77ec7e87c7f9c37479aa4ecedb9b5dc5a847 Mon Sep 17 00:00:00 2001 From: John Ericson Date: Mon, 9 Dec 2019 22:00:59 +0000 Subject: [PATCH 208/241] Strip some non-src files, as before --- release.nix | 13 ++++++++++--- 1 file changed, 10 insertions(+), 3 deletions(-) diff --git a/release.nix b/release.nix index dd994e60..6cd39ef8 100644 --- a/release.nix +++ b/release.nix @@ -19,9 +19,16 @@ let ]; hsPkgs = lib.genAttrs compilers (ghc: let ghc' = reflex-platform.${ghc}.override { - overrides = self: super: { - reflex-dontUseTemplateHaskell = self.callCabal2nixWithOptions "reflex" ./. "-f -use-template-haskell" {}; - reflex = self.callCabal2nixWithOptions "reflex" ./. "-f +use-template-haskell" {}; + overrides = self: super: let + reflexSrc = builtins.filterSource (path: type: !(builtins.elem (baseNameOf path) [ + "default.nix" + "release.nix" + ".git" + "dist" + ])) ./.; + in { + reflex-dontUseTemplateHaskell = self.callCabal2nixWithOptions "reflex" reflexSrc "-f -use-template-haskell" {}; + reflex = self.callCabal2nixWithOptions "reflex" reflexSrc "-f +use-template-haskell" {}; }; }; in { From c603a28ab3cf30986f85e8597480da4b55df5393 Mon Sep 17 00:00:00 2001 From: Jappie Klooster Date: Tue, 10 Dec 2019 14:35:43 +0100 Subject: [PATCH 209/241] Fix spell error in docs --- src/Reflex/Class.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Reflex/Class.hs b/src/Reflex/Class.hs index d169386c..9ec765da 100644 --- a/src/Reflex/Class.hs +++ b/src/Reflex/Class.hs @@ -981,7 +981,7 @@ fanThese e = fanMap :: (Reflex t, Ord k) => Event t (Map k a) -> EventSelector t (Const2 k a) fanMap = fan . fmap mapToDMap --- | switcHold never = eventjoin +-- | 'switchHold' never = eventjoin eventJoin :: (Reflex t, MonadHold t m) => Event t (Event t a) -> m (Event t a) eventJoin = switchHold never From b5d5795f2e31e89e622295d5f3a468af64301d32 Mon Sep 17 00:00:00 2001 From: Jacquin Mininger Date: Tue, 10 Dec 2019 16:53:17 -0500 Subject: [PATCH 210/241] update changelog --- ChangeLog.md | 1 + 1 file changed, 1 insertion(+) diff --git a/ChangeLog.md b/ChangeLog.md index 9eb9a348..59396372 100644 --- a/ChangeLog.md +++ b/ChangeLog.md @@ -5,6 +5,7 @@ * Data.WeakBag.traverse and Data.FastWeakBag.traverse have been renamed to Data.WeakBag.traverse_ and Data.FastWeakBag.traverse_ respectively. +* Fixes a bug in Reflex.Patch.MapWithMove.patchThatSortsMapWith that was producing invalid PatchMapWithMove ## 0.6.2.4 From c8ef0824ff33753e9f3ba8ac4024e40b4ad8e637 Mon Sep 17 00:00:00 2001 From: John Ericson Date: Wed, 11 Dec 2019 11:45:25 -0500 Subject: [PATCH 211/241] Use backticks in new ChangeLog entry --- ChangeLog.md | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/ChangeLog.md b/ChangeLog.md index 59396372..bf0d4692 100644 --- a/ChangeLog.md +++ b/ChangeLog.md @@ -5,7 +5,7 @@ * Data.WeakBag.traverse and Data.FastWeakBag.traverse have been renamed to Data.WeakBag.traverse_ and Data.FastWeakBag.traverse_ respectively. -* Fixes a bug in Reflex.Patch.MapWithMove.patchThatSortsMapWith that was producing invalid PatchMapWithMove +* Fixes a bug in `Reflex.Patch.MapWithMove.patchThatSortsMapWith` that was producing invalid `PatchMapWithMove`. ## 0.6.2.4 From 3020cc737862311f42f5aac069d8afd0330f2463 Mon Sep 17 00:00:00 2001 From: John Ericson Date: Wed, 11 Dec 2019 15:31:17 -0500 Subject: [PATCH 212/241] Clean up wording and markdown in changelog --- ChangeLog.md | 5 ++--- 1 file changed, 2 insertions(+), 3 deletions(-) diff --git a/ChangeLog.md b/ChangeLog.md index bf0d4692..411c7905 100644 --- a/ChangeLog.md +++ b/ChangeLog.md @@ -2,9 +2,8 @@ ## Unreleased -* Data.WeakBag.traverse and Data.FastWeakBag.traverse have been - renamed to Data.WeakBag.traverse_ and Data.FastWeakBag.traverse_ - respectively. +* Data.WeakBag.traverse` and `Data.FastWeakBag.traverse` have been deprecated. + They are replaced with `Data.WeakBag.traverse_` and `Data.FastWeakBag.traverse_`, respectively. * Fixes a bug in `Reflex.Patch.MapWithMove.patchThatSortsMapWith` that was producing invalid `PatchMapWithMove`. ## 0.6.2.4 From 3ccc913380f8b75f7b5da9c80daf2a8686dd106a Mon Sep 17 00:00:00 2001 From: Joe Betz Date: Wed, 11 Dec 2019 23:33:23 +0200 Subject: [PATCH 213/241] add NotReady instances for SpiderTimeline + SpiderHost --- src/Reflex/Spider/Internal.hs | 9 +++++++++ 1 file changed, 9 insertions(+) diff --git a/src/Reflex/Spider/Internal.hs b/src/Reflex/Spider/Internal.hs index 5fd07a13..e4813cc3 100644 --- a/src/Reflex/Spider/Internal.hs +++ b/src/Reflex/Spider/Internal.hs @@ -103,6 +103,7 @@ import qualified Reflex.Host.Class import Reflex.NotReady.Class import Reflex.Patch import qualified Reflex.Patch.DMapWithMove as PatchDMapWithMove +import Reflex.PerformEvent.Base (PerformEventT) #ifdef DEBUG_TRACE_EVENTS import qualified Data.ByteString.Char8 as BS8 @@ -2705,3 +2706,11 @@ instance MonadAtomicRef (SpiderHostFrame x) where instance PrimMonad (SpiderHostFrame x) where type PrimState (SpiderHostFrame x) = PrimState IO primitive = SpiderHostFrame . EventM . primitive + +instance NotReady (SpiderTimeline x) (SpiderHost x) where + notReadyUntil _ = return () + notReady = return () + +instance HasSpiderTimeline x => NotReady (SpiderTimeline x) (PerformEventT (SpiderTimeline x) (SpiderHost x)) where + notReadyUntil _ = return () + notReady = return () \ No newline at end of file From 669b5275203122109b2c08863ebf43b79438db91 Mon Sep 17 00:00:00 2001 From: John Ericson Date: Wed, 11 Dec 2019 18:51:55 -0500 Subject: [PATCH 214/241] Lean on reflex-platform for CI more --- dep/reflex-platform/github.json | 6 ++--- release.nix | 44 ++++++++++++++++++++------------- 2 files changed, 30 insertions(+), 20 deletions(-) diff --git a/dep/reflex-platform/github.json b/dep/reflex-platform/github.json index 7319adab..1d5bef21 100644 --- a/dep/reflex-platform/github.json +++ b/dep/reflex-platform/github.json @@ -1,7 +1,7 @@ { "owner": "reflex-frp", "repo": "reflex-platform", - "branch": "jailbreakTheselens", - "rev": "4284ed527c96c373538dc7e31776d9a50ca6aa91", - "sha256": "1m1nkxq7ng9wnqbd77xn8d81f2iz8g61y5m0r3gp0gi0q59jm8ay" + "branch": "no-th-temporary", + "rev": "7794de7eb9980d47c7b70243a8df5ab945b236f6", + "sha256": "0s1183arrwldcs50qhzgnv94v24n9bgq6dfq64wp0a3q2nzyvgwh" } diff --git a/release.nix b/release.nix index 6cd39ef8..79452f57 100644 --- a/release.nix +++ b/release.nix @@ -17,26 +17,36 @@ let ] ++ lib.optionals (reflex-platform.iosSupport) [ "ghcIosAarch64" ]; - hsPkgs = lib.genAttrs compilers (ghc: let - ghc' = reflex-platform.${ghc}.override { - overrides = self: super: let - reflexSrc = builtins.filterSource (path: type: !(builtins.elem (baseNameOf path) [ - "default.nix" - "release.nix" - ".git" - "dist" - ])) ./.; - in { - reflex-dontUseTemplateHaskell = self.callCabal2nixWithOptions "reflex" reflexSrc "-f -use-template-haskell" {}; - reflex = self.callCabal2nixWithOptions "reflex" reflexSrc "-f +use-template-haskell" {}; + variations = map (v: "reflex" + v) [ + "-dontUseTemplateHaskell" + "" + ]; + compilerPkgs = lib.genAttrs compilers (ghc: let + variationPkgs = lib.genAttrs variations (variation: let + reflex-platform = reflex-platform-fun { + inherit system; + __useTemplateHaskell = variation == "reflex"; # TODO hack + haskellOverlays = [ + # Use this package's source for reflex + (self: super: { + _dep = super._dep // { + reflex = builtins.filterSource (path: type: !(builtins.elem (baseNameOf path) [ + "release.nix" + ".git" + "dist" + ])) ./.; + }; + }) + ]; }; - }; - in { - inherit (ghc') reflex reflex-dontUseTemplateHaskell; + in reflex-platform.${ghc}.reflex); + in variationPkgs // { + cache = reflex-platform.pinBuildInputs "reflex-${system}-${ghc}" + (builtins.attrValues variationPkgs); }); - in hsPkgs // { + in compilerPkgs // { cache = reflex-platform.pinBuildInputs "reflex-${system}" - (lib.concatLists (map builtins.attrValues (builtins.attrValues hsPkgs))); + (map (a: a.cache) (builtins.attrValues compilerPkgs)); }); metaCache = native-reflex-platform.pinBuildInputs "reflex-everywhere" From 7059708c9222d63d6187664bb9942f3f60f050a6 Mon Sep 17 00:00:00 2001 From: John Ericson Date: Thu, 12 Dec 2019 10:49:31 -0500 Subject: [PATCH 215/241] Bump reflex platform --- dep/reflex-platform/github.json | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/dep/reflex-platform/github.json b/dep/reflex-platform/github.json index 1d5bef21..1639e8f1 100644 --- a/dep/reflex-platform/github.json +++ b/dep/reflex-platform/github.json @@ -1,7 +1,7 @@ { "owner": "reflex-frp", "repo": "reflex-platform", - "branch": "no-th-temporary", - "rev": "7794de7eb9980d47c7b70243a8df5ab945b236f6", + "branch": "develop", + "rev": "e7b76dd552a10916c7d8702c11292dac4f4299ea", "sha256": "0s1183arrwldcs50qhzgnv94v24n9bgq6dfq64wp0a3q2nzyvgwh" } From ddd6592d7d53b4b4f969206ced58c6bebb87f9a2 Mon Sep 17 00:00:00 2001 From: John Ericson Date: Thu, 12 Dec 2019 17:14:02 -0500 Subject: [PATCH 216/241] Space Separate ChangeLog entries Markdown works a bit better with this --- ChangeLog.md | 13 +++++++++++++ 1 file changed, 13 insertions(+) diff --git a/ChangeLog.md b/ChangeLog.md index bf0d4692..42bf95c5 100644 --- a/ChangeLog.md +++ b/ChangeLog.md @@ -5,6 +5,7 @@ * Data.WeakBag.traverse and Data.FastWeakBag.traverse have been renamed to Data.WeakBag.traverse_ and Data.FastWeakBag.traverse_ respectively. + * Fixes a bug in `Reflex.Patch.MapWithMove.patchThatSortsMapWith` that was producing invalid `PatchMapWithMove`. ## 0.6.2.4 @@ -18,7 +19,9 @@ ## 0.6.2.2 * Support these >= 1. Add `split-these` flag to control whether to use new these/semialign combination or not. + * Update version bounds to fix some CI failures + * Add travis CI configuration ## 0.6.2.1 @@ -44,21 +47,31 @@ * Fix `holdDyn` so that it is lazy in its event argument These produce `DMap`s whose values needn't be `Identity`. + * Stop using the now-deprecated `*Tag` classes (e.g., `ShowTag`). + * Fix `holdDyn` so that it is lazy in its event argument. ## 0.6.1.0 * Re-export all of `Data.Map.Monoidal` + * Fix `QueryT` and `RequesterT` tests ## 0.6.0.0 -- 2019-03-20 * Deprecate `FunctorMaybe` in favor of `Data.Witherable.Filterable`. We still export `fmapMaybe`, `ffilter`, etc., but they all rely on `Filterable` now. + * Rename `MonadDynamicWriter` to `DynamicWriter` and add a deprecation for the old name. + * Remove many deprecated functions. + * Add a `Num` instance for `Dynamic`. + * Add `matchRequestsWithResponses` to make it easier to use `Requester` with protocols that don't do this matching for you. + * Add `withRequesterT` to map functions over the request and response of a `RequesterT`. + * Suppress nil patches in `QueryT` as an optimization. The `Query` type must now have an `Eq` instance. + * Add `throttleBatchWithLag` to `Reflex.Time`. See that module for details. From 63a8978200711c68ece0d5aa66ba162ade784dd2 Mon Sep 17 00:00:00 2001 From: John Ericson Date: Thu, 12 Dec 2019 17:14:24 -0500 Subject: [PATCH 217/241] Add ChangeLog entry for missing `NotReady` instances --- ChangeLog.md | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/ChangeLog.md b/ChangeLog.md index 42bf95c5..3e72b162 100644 --- a/ChangeLog.md +++ b/ChangeLog.md @@ -8,6 +8,10 @@ * Fixes a bug in `Reflex.Patch.MapWithMove.patchThatSortsMapWith` that was producing invalid `PatchMapWithMove`. +* Add missing `NotReady` instances: + - `instance NotReady (SpiderTimeline x) (SpiderHost x)` + - `instance HasSpiderTimeline x => NotReady (SpiderTimeline x) (PerformEventT (SpiderTimeline x) (SpiderHost x))` + ## 0.6.2.4 * Update to monoidal-containers 0.6 From 881f6b1773e3dab68382f13fbffb09b32a50f78e Mon Sep 17 00:00:00 2001 From: John Ericson Date: Fri, 13 Dec 2019 11:56:41 -0500 Subject: [PATCH 218/241] Cleanup trailing whitespace --- ChangeLog.md | 10 +++++----- src/Control/Monad/ReaderIO.hs | 2 +- src/Reflex/Collection.hs | 2 +- test/Reflex/Bench/Focused.hs | 2 +- 4 files changed, 8 insertions(+), 8 deletions(-) diff --git a/ChangeLog.md b/ChangeLog.md index 3e72b162..90e1f690 100644 --- a/ChangeLog.md +++ b/ChangeLog.md @@ -5,7 +5,7 @@ * Data.WeakBag.traverse and Data.FastWeakBag.traverse have been renamed to Data.WeakBag.traverse_ and Data.FastWeakBag.traverse_ respectively. - + * Fixes a bug in `Reflex.Patch.MapWithMove.patchThatSortsMapWith` that was producing invalid `PatchMapWithMove`. * Add missing `NotReady` instances: @@ -40,16 +40,16 @@ * Add incrementalCoercion/coerceIncremental to go with dynamicCoercion/coerceDynamic * Generalize merging functions: - `merge` to `mergeG`, - `mergeIncremental` to `mergeIncrementalG`, - `mergeIncrementalWithMove` to `mergeIncrementalWithMoveG`. + `merge` to `mergeG`, + `mergeIncremental` to `mergeIncrementalG`, + `mergeIncrementalWithMove` to `mergeIncrementalWithMoveG`. * Generalize distribute function: `distributeDMapOverDynPure` to `distributeDMapOverDynPureG`, ## 0.6.2.0 -* Fix `holdDyn` so that it is lazy in its event argument +* Fix `holdDyn` so that it is lazy in its event argument These produce `DMap`s whose values needn't be `Identity`. * Stop using the now-deprecated `*Tag` classes (e.g., `ShowTag`). diff --git a/src/Control/Monad/ReaderIO.hs b/src/Control/Monad/ReaderIO.hs index fb5f60c7..ad235fe7 100644 --- a/src/Control/Monad/ReaderIO.hs +++ b/src/Control/Monad/ReaderIO.hs @@ -37,7 +37,7 @@ instance Applicative (ReaderIO e) where #if MIN_VERSION_base(4,10,0) liftA2 = liftM2 {-# INLINE liftA2 #-} -#endif +#endif (*>) = (>>) {-# INLINE (*>) #-} diff --git a/src/Reflex/Collection.hs b/src/Reflex/Collection.hs index 952e566c..792e716a 100644 --- a/src/Reflex/Collection.hs +++ b/src/Reflex/Collection.hs @@ -130,7 +130,7 @@ listWithKeyShallowDiff initialVals valsChanged mkChild = do Nothing -> Just Nothing -- We don't want to let spurious re-creations of items through - Just _ -> Nothing + Just _ -> Nothing listHoldWithKey initialVals (attachWith (flip (Map.differenceWith relevantPatch)) diff --git a/test/Reflex/Bench/Focused.hs b/test/Reflex/Bench/Focused.hs index cdfd5dd0..cc19cb34 100644 --- a/test/Reflex/Bench/Focused.hs +++ b/test/Reflex/Bench/Focused.hs @@ -134,7 +134,7 @@ holdDynChain :: (Reflex t, MonadHold t m) => Word -> Dynamic t Word -> m (Dynami holdDynChain = iterM (\d -> sample (current d) >>= flip holdDyn (updated d)) buildDynChain :: (Reflex t, MonadHold t m) => Word -> Dynamic t Word -> m (Dynamic t Word) -buildDynChain = iterM (\d -> do +buildDynChain = iterM (\d -> do let b = fmap (+1) (current d) e = fmap (*2) (updated d) buildDynamic (sample b) e) From 11e47dacf61c4e1e9fb4e028b2189694af6213d3 Mon Sep 17 00:00:00 2001 From: John Ericson Date: Fri, 13 Dec 2019 15:07:18 -0500 Subject: [PATCH 219/241] Remove extra blank link in change log --- ChangeLog.md | 1 - 1 file changed, 1 deletion(-) diff --git a/ChangeLog.md b/ChangeLog.md index 476c9054..754bd343 100644 --- a/ChangeLog.md +++ b/ChangeLog.md @@ -5,7 +5,6 @@ * Data.WeakBag.traverse` and `Data.FastWeakBag.traverse` have been deprecated. They are replaced with `Data.WeakBag.traverse_` and `Data.FastWeakBag.traverse_`, respectively. - * Fixes a bug in `Reflex.Patch.MapWithMove.patchThatSortsMapWith` that was producing invalid `PatchMapWithMove`. * Add missing `NotReady` instances: From c1e65c66bc2e93920282b7469d2b50ee78ab1a00 Mon Sep 17 00:00:00 2001 From: John Ericson Date: Fri, 13 Dec 2019 15:59:50 -0500 Subject: [PATCH 220/241] Fix markdown in change log missing opening back-tick --- ChangeLog.md | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/ChangeLog.md b/ChangeLog.md index 754bd343..4a62d6bd 100644 --- a/ChangeLog.md +++ b/ChangeLog.md @@ -2,7 +2,7 @@ ## Unreleased -* Data.WeakBag.traverse` and `Data.FastWeakBag.traverse` have been deprecated. +* `Data.WeakBag.traverse` and `Data.FastWeakBag.traverse` have been deprecated. They are replaced with `Data.WeakBag.traverse_` and `Data.FastWeakBag.traverse_`, respectively. * Fixes a bug in `Reflex.Patch.MapWithMove.patchThatSortsMapWith` that was producing invalid `PatchMapWithMove`. From bf739a728583117fdae5c4bdf15d5695ae163205 Mon Sep 17 00:00:00 2001 From: John Ericson Date: Sat, 14 Dec 2019 14:59:20 -0500 Subject: [PATCH 221/241] Remove unneeded hiding of Prelude.map `hlint` is complaining. I don't really care either way, so appeasing it. --- src/Data/AppendMap.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Data/AppendMap.hs b/src/Data/AppendMap.hs index b080dc1f..3b3bbb32 100644 --- a/src/Data/AppendMap.hs +++ b/src/Data/AppendMap.hs @@ -20,7 +20,7 @@ module Data.AppendMap , module Data.Map.Monoidal ) where -import Prelude hiding (map, null) +import Prelude hiding (null) import Data.Coerce import Data.Default From 4b04fc4f5aa474406e6f331de5d993154a3a4535 Mon Sep 17 00:00:00 2001 From: John Ericson Date: Fri, 20 Dec 2019 15:09:39 -0500 Subject: [PATCH 222/241] Fix version number for release --- ChangeLog.md | 2 +- reflex.cabal | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/ChangeLog.md b/ChangeLog.md index 4a62d6bd..49869972 100644 --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,6 +1,6 @@ # Revision history for reflex -## Unreleased +## 0.6.3 * `Data.WeakBag.traverse` and `Data.FastWeakBag.traverse` have been deprecated. They are replaced with `Data.WeakBag.traverse_` and `Data.FastWeakBag.traverse_`, respectively. diff --git a/reflex.cabal b/reflex.cabal index 1dd851b9..5268c4e4 100644 --- a/reflex.cabal +++ b/reflex.cabal @@ -1,5 +1,5 @@ Name: reflex -Version: 0.6.2.4 +Version: 0.6.3 Synopsis: Higher-order Functional Reactive Programming Description: Reflex is a high-performance, deterministic, higher-order Functional Reactive Programming system License: BSD3 From 5eeb5d0db5cdd213eea9c4508316f307b4adee65 Mon Sep 17 00:00:00 2001 From: Jappie Klooster Date: Fri, 20 Dec 2019 23:22:27 +0100 Subject: [PATCH 223/241] Remove helper function in favor of updating docs --- src/Reflex/Class.hs | 8 ++------ 1 file changed, 2 insertions(+), 6 deletions(-) diff --git a/src/Reflex/Class.hs b/src/Reflex/Class.hs index 9ec765da..57ab9d28 100644 --- a/src/Reflex/Class.hs +++ b/src/Reflex/Class.hs @@ -76,7 +76,6 @@ module Reflex.Class , factorEvent , filterEventKey -- ** Collapsing 'Event . Event' - , eventJoin , switchHold , switchHoldPromptly , switchHoldPromptOnly @@ -287,7 +286,8 @@ class ( MonadHold t (PushM t) -- | Create an 'Event' that will occur whenever the currently-selected input -- 'Event' occurs switch :: Behavior t (Event t a) -> Event t a - -- | Create an 'Event' that will occur whenever the input event is occurring -- and its occurrence value, another 'Event', is also occurring + -- | Create an 'Event' that will occur whenever the input event is occurring -- and its occurrence value, another 'Event', is also occurring. + -- You maybe looking for 'switchHold' never instead. coincidence :: Event t (Event t a) -> Event t a -- | Extract the 'Behavior' of a 'Dynamic'. current :: Dynamic t a -> Behavior t a @@ -981,10 +981,6 @@ fanThese e = fanMap :: (Reflex t, Ord k) => Event t (Map k a) -> EventSelector t (Const2 k a) fanMap = fan . fmap mapToDMap --- | 'switchHold' never = eventjoin -eventJoin :: (Reflex t, MonadHold t m) => Event t (Event t a) -> m (Event t a) -eventJoin = switchHold never - -- | Switches to the new event whenever it receives one. Only the old event is -- considered the moment a new one is switched in; the output event will fire at -- that moment only if the old event does. From 822a3c3954df7880b782a076a2ca3993b3a9126c Mon Sep 17 00:00:00 2001 From: Jappie Klooster Date: Fri, 20 Dec 2019 23:25:14 +0100 Subject: [PATCH 224/241] Never is also a function --- src/Reflex/Class.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Reflex/Class.hs b/src/Reflex/Class.hs index 57ab9d28..bfa0a1e6 100644 --- a/src/Reflex/Class.hs +++ b/src/Reflex/Class.hs @@ -287,7 +287,7 @@ class ( MonadHold t (PushM t) -- 'Event' occurs switch :: Behavior t (Event t a) -> Event t a -- | Create an 'Event' that will occur whenever the input event is occurring -- and its occurrence value, another 'Event', is also occurring. - -- You maybe looking for 'switchHold' never instead. + -- You maybe looking for 'switchHold' 'never' instead. coincidence :: Event t (Event t a) -> Event t a -- | Extract the 'Behavior' of a 'Dynamic'. current :: Dynamic t a -> Behavior t a From d919a23540aff63227314a6c039e2debf070e1bf Mon Sep 17 00:00:00 2001 From: John Ericson Date: Mon, 23 Dec 2019 10:20:59 -0500 Subject: [PATCH 225/241] Update haddock formatting I think I did this correctly... --- src/Reflex/Class.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Reflex/Class.hs b/src/Reflex/Class.hs index bfa0a1e6..2c8c3645 100644 --- a/src/Reflex/Class.hs +++ b/src/Reflex/Class.hs @@ -287,7 +287,7 @@ class ( MonadHold t (PushM t) -- 'Event' occurs switch :: Behavior t (Event t a) -> Event t a -- | Create an 'Event' that will occur whenever the input event is occurring -- and its occurrence value, another 'Event', is also occurring. - -- You maybe looking for 'switchHold' 'never' instead. + -- You maybe looking for '@switchHold@ @never@' instead. coincidence :: Event t (Event t a) -> Event t a -- | Extract the 'Behavior' of a 'Dynamic'. current :: Dynamic t a -> Behavior t a From 8a9789c7335d2d8b925daa5b312ec5c10a0439c7 Mon Sep 17 00:00:00 2001 From: Hamish Mackenzie Date: Thu, 26 Dec 2019 17:27:20 -0700 Subject: [PATCH 226/241] Fixes for ghc 8.8.1 --- reflex.cabal | 10 +++++----- src/Reflex/Class.hs | 1 - src/Reflex/Spider/Internal.hs | 10 ++++++++++ 3 files changed, 15 insertions(+), 6 deletions(-) diff --git a/reflex.cabal b/reflex.cabal index 5268c4e4..0ba41593 100644 --- a/reflex.cabal +++ b/reflex.cabal @@ -50,7 +50,7 @@ library hs-source-dirs: src build-depends: MemoTrie == 0.6.*, - base >= 4.9 && < 4.13, + base >= 4.9 && < 4.14, bifunctors >= 5.2 && < 5.6, comonad >= 5.0.4 && < 5.1, constraints-extras >= 0.3 && < 0.4, @@ -63,14 +63,14 @@ library mtl >= 2.1 && < 2.3, prim-uniq >= 0.1.0.1 && < 0.2, primitive >= 0.5 && < 0.8, - profunctors >= 5.3 && < 5.5, + profunctors >= 5.3 && < 5.6, random == 1.1.*, ref-tf == 0.4.*, reflection == 2.1.*, semigroupoids >= 4.0 && < 6, stm >= 2.4 && < 2.6, syb >= 0.5 && < 0.8, - time >= 1.4 && < 1.9, + time >= 1.4 && < 1.10, transformers >= 0.5.6.0 && < 0.6, unbounded-delays >= 0.1.0.0 && < 0.2, witherable >= 0.3 && < 0.3.2 @@ -150,9 +150,9 @@ library cpp-options: -DUSE_TEMPLATE_HASKELL build-depends: dependent-sum >= 0.6 && < 0.7, - haskell-src-exts >= 1.16 && < 1.22, + haskell-src-exts >= 1.16 && < 1.23, haskell-src-meta >= 0.6 && < 0.9, - template-haskell >= 2.9 && < 2.15 + template-haskell >= 2.9 && < 2.16 exposed-modules: Reflex.Dynamic.TH other-extensions: TemplateHaskell diff --git a/src/Reflex/Class.hs b/src/Reflex/Class.hs index 2c8c3645..7ccda8d6 100644 --- a/src/Reflex/Class.hs +++ b/src/Reflex/Class.hs @@ -663,7 +663,6 @@ instance Reflex t => Monad (Behavior t) where a >>= f = pull $ sample a >>= sample . f -- Note: it is tempting to write (_ >> b = b); however, this would result in (fail x >> return y) succeeding (returning y), which violates the law that (a >> b = a >>= \_ -> b), since the implementation of (>>=) above actually will fail. Since we can't examine 'Behavior's other than by using sample, I don't think it's possible to write (>>) to be more efficient than the (>>=) above. return = constant - fail = error "Monad (Behavior t) does not support fail" instance (Reflex t, Monoid a) => Monoid (Behavior t a) where mempty = constant mempty diff --git a/src/Reflex/Spider/Internal.hs b/src/Reflex/Spider/Internal.hs index e4813cc3..d17c698d 100644 --- a/src/Reflex/Spider/Internal.hs +++ b/src/Reflex/Spider/Internal.hs @@ -972,8 +972,10 @@ instance Monad (BehaviorM x) where BehaviorM x >> BehaviorM y = BehaviorM $ x >> y {-# INLINE return #-} return x = BehaviorM $ return x +#if !MIN_VERSION_base(4,13,0) {-# INLINE fail #-} fail s = BehaviorM $ fail s +#endif data BehaviorSubscribed x a = forall p. BehaviorSubscribedHold (Hold x p) @@ -2357,8 +2359,10 @@ instance HasSpiderTimeline x => Monad (Reflex.Class.Dynamic (SpiderTimeline x)) x >>= f = SpiderDynamic $ dynamicDynIdentity $ newJoinDyn $ newMapDyn (unSpiderDynamic . f) $ unSpiderDynamic x {-# INLINE (>>) #-} (>>) = (*>) +#if !MIN_VERSION_base(4,13,0) {-# INLINE fail #-} fail _ = error "Dynamic does not support 'fail'" +#endif {-# INLINABLE newJoinDyn #-} newJoinDyn :: HasSpiderTimeline x => DynamicS x (Identity (DynamicS x (Identity a))) -> Reflex.Spider.Internal.Dyn x (Identity a) @@ -2637,6 +2641,10 @@ instance Monad (SpiderHost x) where SpiderHost x >> SpiderHost y = SpiderHost $ x >> y {-# INLINABLE return #-} return x = SpiderHost $ return x +#if MIN_VERSION_base(4,13,0) + +instance MonadFail (SpiderHost x) where +#endif {-# INLINABLE fail #-} fail s = SpiderHost $ fail s @@ -2660,8 +2668,10 @@ instance Monad (SpiderHostFrame x) where SpiderHostFrame x >> SpiderHostFrame y = SpiderHostFrame $ x >> y {-# INLINABLE return #-} return x = SpiderHostFrame $ return x +#if !MIN_VERSION_base(4,13,0) {-# INLINABLE fail #-} fail s = SpiderHostFrame $ fail s +#endif instance NotReady (SpiderTimeline x) (SpiderHostFrame x) where notReadyUntil _ = pure () From c2346ca70a09a84a6d663e46a701b005413b8911 Mon Sep 17 00:00:00 2001 From: John Ericson Date: Mon, 30 Dec 2019 13:51:26 -0500 Subject: [PATCH 227/241] Add back fail method for before base 4.13 --- src/Reflex/Class.hs | 3 +++ 1 file changed, 3 insertions(+) diff --git a/src/Reflex/Class.hs b/src/Reflex/Class.hs index 7ccda8d6..4ec14e3e 100644 --- a/src/Reflex/Class.hs +++ b/src/Reflex/Class.hs @@ -663,6 +663,9 @@ instance Reflex t => Monad (Behavior t) where a >>= f = pull $ sample a >>= sample . f -- Note: it is tempting to write (_ >> b = b); however, this would result in (fail x >> return y) succeeding (returning y), which violates the law that (a >> b = a >>= \_ -> b), since the implementation of (>>=) above actually will fail. Since we can't examine 'Behavior's other than by using sample, I don't think it's possible to write (>>) to be more efficient than the (>>=) above. return = constant +#if !MIN_VERSION_base(4,13,0) + fail = error "Monad (Behavior t) does not support fail" +#endif instance (Reflex t, Monoid a) => Monoid (Behavior t a) where mempty = constant mempty From 4c2f1643125fc08fd7a907a5ac670d04fc227906 Mon Sep 17 00:00:00 2001 From: John Ericson Date: Mon, 30 Dec 2019 13:56:37 -0500 Subject: [PATCH 228/241] Define MonadFail before 8.8. Make a smoother transition --- src/Reflex/Spider/Internal.hs | 21 ++++++++++++++++----- 1 file changed, 16 insertions(+), 5 deletions(-) diff --git a/src/Reflex/Spider/Internal.hs b/src/Reflex/Spider/Internal.hs index d17c698d..c6fa080c 100644 --- a/src/Reflex/Spider/Internal.hs +++ b/src/Reflex/Spider/Internal.hs @@ -43,6 +43,7 @@ import Control.Monad.Reader.Class import Control.Monad.IO.Class import Control.Monad.ReaderIO import Control.Monad.Ref +import qualified Control.Monad.Fail as MonadFail import Data.Align import Data.Coerce import Data.Dependent.Map (DMap, DSum (..)) @@ -974,9 +975,13 @@ instance Monad (BehaviorM x) where return x = BehaviorM $ return x #if !MIN_VERSION_base(4,13,0) {-# INLINE fail #-} - fail s = BehaviorM $ fail s + fail s = MonadFail.fail #endif +instance MonadFail (SpiderHost x) where + {-# INLINABLE fail #-} + fail s = BehaviorM $ fail s + data BehaviorSubscribed x a = forall p. BehaviorSubscribedHold (Hold x p) | BehaviorSubscribedPull (PullSubscribed x a) @@ -2641,10 +2646,12 @@ instance Monad (SpiderHost x) where SpiderHost x >> SpiderHost y = SpiderHost $ x >> y {-# INLINABLE return #-} return x = SpiderHost $ return x -#if MIN_VERSION_base(4,13,0) +#if !MIN_VERSION_base(4,13,0) + {-# INLINABLE fail #-} + fail s = MonadFail.fail +#endif instance MonadFail (SpiderHost x) where -#endif {-# INLINABLE fail #-} fail s = SpiderHost $ fail s @@ -2670,9 +2677,13 @@ instance Monad (SpiderHostFrame x) where return x = SpiderHostFrame $ return x #if !MIN_VERSION_base(4,13,0) {-# INLINABLE fail #-} - fail s = SpiderHostFrame $ fail s + fail s = MonadFail.fail #endif +instance MonadFail (SpiderHostFrame x) where + {-# INLINABLE fail #-} + fail s = SpiderHostFrame $ fail s + instance NotReady (SpiderTimeline x) (SpiderHostFrame x) where notReadyUntil _ = pure () notReady = pure () @@ -2723,4 +2734,4 @@ instance NotReady (SpiderTimeline x) (SpiderHost x) where instance HasSpiderTimeline x => NotReady (SpiderTimeline x) (PerformEventT (SpiderTimeline x) (SpiderHost x)) where notReadyUntil _ = return () - notReady = return () \ No newline at end of file + notReady = return () From 13af1376d4c74e534f411417e02bf88c57070036 Mon Sep 17 00:00:00 2001 From: John Ericson Date: Mon, 30 Dec 2019 14:05:06 -0500 Subject: [PATCH 229/241] Add GHC 8.8.1 to tested-with stanza --- reflex.cabal | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/reflex.cabal b/reflex.cabal index 0ba41593..4142dfc8 100644 --- a/reflex.cabal +++ b/reflex.cabal @@ -18,7 +18,7 @@ extra-source-files: ChangeLog.md tested-with: - GHC ==8.0.2 || ==8.2.2 || ==8.4.4 || ==8.6.5, + GHC ==8.0.2 || ==8.2.2 || ==8.4.4 || ==8.6.5 || ==8.8.1, GHCJS ==8.4 flag use-reflex-optimizer From 58e30807fbdf4e1dc0c8f4a29677dd0134d23bdb Mon Sep 17 00:00:00 2001 From: John Ericson Date: Mon, 30 Dec 2019 14:07:10 -0500 Subject: [PATCH 230/241] Travis do 8.8.1 too --- .travis.yml | 2 ++ 1 file changed, 2 insertions(+) diff --git a/.travis.yml b/.travis.yml index 24f9ce8e..ab117dbb 100644 --- a/.travis.yml +++ b/.travis.yml @@ -29,6 +29,8 @@ matrix: include: - compiler: ghcjs-8.4 addons: {"apt":{"sources":["hvr-ghc"],"packages":["cabal-install-3.0"]}} + - compiler: ghc-8.8.1 + addons: {"apt":{"sources":["hvr-ghc"],"packages":["ghc-8.8.1","cabal-install-3.0"]}} - compiler: ghc-8.6.5 addons: {"apt":{"sources":["hvr-ghc"],"packages":["ghc-8.6.5","cabal-install-2.4"]}} - compiler: ghc-8.4.4 From 3dc85b1cabad1cb098cffded92cca8130937cd5f Mon Sep 17 00:00:00 2001 From: John Ericson Date: Mon, 30 Dec 2019 14:12:53 -0500 Subject: [PATCH 231/241] Import the MonadFail class itself unqualified --- src/Reflex/Spider/Internal.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/src/Reflex/Spider/Internal.hs b/src/Reflex/Spider/Internal.hs index c6fa080c..1f8413d0 100644 --- a/src/Reflex/Spider/Internal.hs +++ b/src/Reflex/Spider/Internal.hs @@ -43,6 +43,7 @@ import Control.Monad.Reader.Class import Control.Monad.IO.Class import Control.Monad.ReaderIO import Control.Monad.Ref +import Control.Monad.Fail (MonadFail) import qualified Control.Monad.Fail as MonadFail import Data.Align import Data.Coerce From 0cbcdde5c09a8108be1a01db8d293111ac7d8875 Mon Sep 17 00:00:00 2001 From: John Ericson Date: Mon, 30 Dec 2019 17:03:32 -0500 Subject: [PATCH 232/241] Change to a `MonadFail BehaviorM` instance as intended --- src/Reflex/Spider/Internal.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Reflex/Spider/Internal.hs b/src/Reflex/Spider/Internal.hs index 1f8413d0..ce322dae 100644 --- a/src/Reflex/Spider/Internal.hs +++ b/src/Reflex/Spider/Internal.hs @@ -979,7 +979,7 @@ instance Monad (BehaviorM x) where fail s = MonadFail.fail #endif -instance MonadFail (SpiderHost x) where +instance MonadFail (BehaviorM x) where {-# INLINABLE fail #-} fail s = BehaviorM $ fail s From 8f460ca86ac9d3f4612e81a07715da116ff39d6a Mon Sep 17 00:00:00 2001 From: John Ericson Date: Mon, 30 Dec 2019 17:04:41 -0500 Subject: [PATCH 233/241] Quantify Control.Monad.fail in MonadFail instances Pre 8.8, we ought to be clear which fail we intend to use here, even though they do the same thing. --- src/Reflex/Spider/Internal.hs | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/Reflex/Spider/Internal.hs b/src/Reflex/Spider/Internal.hs index ce322dae..df356b85 100644 --- a/src/Reflex/Spider/Internal.hs +++ b/src/Reflex/Spider/Internal.hs @@ -981,7 +981,7 @@ instance Monad (BehaviorM x) where instance MonadFail (BehaviorM x) where {-# INLINABLE fail #-} - fail s = BehaviorM $ fail s + fail s = BehaviorM $ MonadFail.fail s data BehaviorSubscribed x a = forall p. BehaviorSubscribedHold (Hold x p) @@ -2654,7 +2654,7 @@ instance Monad (SpiderHost x) where instance MonadFail (SpiderHost x) where {-# INLINABLE fail #-} - fail s = SpiderHost $ fail s + fail s = SpiderHost $ MonadFail.fail s -- | Run an action affecting the global Spider timeline; this will be guarded by -- a mutex for that timeline @@ -2683,7 +2683,7 @@ instance Monad (SpiderHostFrame x) where instance MonadFail (SpiderHostFrame x) where {-# INLINABLE fail #-} - fail s = SpiderHostFrame $ fail s + fail s = SpiderHostFrame $ MonadFail.fail s instance NotReady (SpiderTimeline x) (SpiderHostFrame x) where notReadyUntil _ = pure () From 51b6399d1baddcecf804d6125cf331dc8a1b08d6 Mon Sep 17 00:00:00 2001 From: Hamish Mackenzie Date: Tue, 31 Dec 2019 20:05:32 -0700 Subject: [PATCH 234/241] Only include MonadFail where needed --- src/Reflex/Spider/Internal.hs | 16 ++++------------ 1 file changed, 4 insertions(+), 12 deletions(-) diff --git a/src/Reflex/Spider/Internal.hs b/src/Reflex/Spider/Internal.hs index df356b85..df37d8af 100644 --- a/src/Reflex/Spider/Internal.hs +++ b/src/Reflex/Spider/Internal.hs @@ -976,13 +976,9 @@ instance Monad (BehaviorM x) where return x = BehaviorM $ return x #if !MIN_VERSION_base(4,13,0) {-# INLINE fail #-} - fail s = MonadFail.fail + fail s = BehaviorM $ fail s #endif -instance MonadFail (BehaviorM x) where - {-# INLINABLE fail #-} - fail s = BehaviorM $ MonadFail.fail s - data BehaviorSubscribed x a = forall p. BehaviorSubscribedHold (Hold x p) | BehaviorSubscribedPull (PullSubscribed x a) @@ -2649,7 +2645,7 @@ instance Monad (SpiderHost x) where return x = SpiderHost $ return x #if !MIN_VERSION_base(4,13,0) {-# INLINABLE fail #-} - fail s = MonadFail.fail + fail = MonadFail.fail #endif instance MonadFail (SpiderHost x) where @@ -2678,13 +2674,9 @@ instance Monad (SpiderHostFrame x) where return x = SpiderHostFrame $ return x #if !MIN_VERSION_base(4,13,0) {-# INLINABLE fail #-} - fail s = MonadFail.fail + fail s = SpiderHostFrame $ fail s #endif -instance MonadFail (SpiderHostFrame x) where - {-# INLINABLE fail #-} - fail s = SpiderHostFrame $ MonadFail.fail s - instance NotReady (SpiderTimeline x) (SpiderHostFrame x) where notReadyUntil _ = pure () notReady = pure () @@ -2735,4 +2727,4 @@ instance NotReady (SpiderTimeline x) (SpiderHost x) where instance HasSpiderTimeline x => NotReady (SpiderTimeline x) (PerformEventT (SpiderTimeline x) (SpiderHost x)) where notReadyUntil _ = return () - notReady = return () + notReady = return () \ No newline at end of file From 7c3253d501a4766e6e4eed675bba6b2fb76a3503 Mon Sep 17 00:00:00 2001 From: Hamish Mackenzie Date: Tue, 31 Dec 2019 18:52:40 -0700 Subject: [PATCH 235/241] Use Data.Type.Equality.Refl --- src/Data/Functor/Misc.hs | 1 + src/Reflex/Class.hs | 3 ++- src/Reflex/Dynamic.hs | 3 ++- src/Reflex/Spider/Internal.hs | 1 + 4 files changed, 6 insertions(+), 2 deletions(-) diff --git a/src/Data/Functor/Misc.hs b/src/Data/Functor/Misc.hs index c5889942..058704fb 100644 --- a/src/Data/Functor/Misc.hs +++ b/src/Data/Functor/Misc.hs @@ -53,6 +53,7 @@ import Data.Map (Map) import qualified Data.Map as Map import Data.Some (Some(Some)) import Data.These +import Data.Type.Equality ((:~:)(Refl)) import Data.Typeable hiding (Refl) -------------------------------------------------------------------------------- diff --git a/src/Reflex/Class.hs b/src/Reflex/Class.hs index 4ec14e3e..e8fbb720 100644 --- a/src/Reflex/Class.hs +++ b/src/Reflex/Class.hs @@ -200,7 +200,7 @@ import Data.Dependent.Map (DMap, DSum (..)) import qualified Data.Dependent.Map as DMap import Data.Functor.Compose import Data.Functor.Product -import Data.GADT.Compare (GEq (..), GCompare (..), (:~:) (..)) +import Data.GADT.Compare (GEq (..), GCompare (..)) import Data.FastMutableIntMap (PatchIntMap) import Data.Foldable import Data.Functor.Bind @@ -215,6 +215,7 @@ import Data.Some (Some(Some)) import Data.String import Data.These import Data.Type.Coercion +import Data.Type.Equality ((:~:) (..)) import Data.Witherable (Filterable(..)) import qualified Data.Witherable as W import Reflex.FunctorMaybe (FunctorMaybe) diff --git a/src/Reflex/Dynamic.hs b/src/Reflex/Dynamic.hs index ba92d829..a0c08b59 100644 --- a/src/Reflex/Dynamic.hs +++ b/src/Reflex/Dynamic.hs @@ -87,11 +87,12 @@ import Data.Align import Data.Dependent.Map (DMap) import qualified Data.Dependent.Map as DMap import Data.Dependent.Sum (DSum (..)) -import Data.GADT.Compare ((:~:) (..), GCompare (..), GEq (..), GOrdering (..)) +import Data.GADT.Compare (GCompare (..), GEq (..), GOrdering (..)) import Data.Map (Map) import Data.Maybe import Data.Monoid ((<>)) import Data.These +import Data.Type.Equality ((:~:) (..)) import Debug.Trace diff --git a/src/Reflex/Spider/Internal.hs b/src/Reflex/Spider/Internal.hs index df37d8af..c0057961 100644 --- a/src/Reflex/Spider/Internal.hs +++ b/src/Reflex/Spider/Internal.hs @@ -65,6 +65,7 @@ import Data.Monoid ((<>)) import Data.Proxy import Data.These import Data.Traversable +import Data.Type.Equality ((:~:)(Refl)) import Data.Witherable (Filterable, mapMaybe) import GHC.Exts import GHC.IORef (IORef (..)) From 89e0f41f32db65e183b8f21bdb6239ead8503e5e Mon Sep 17 00:00:00 2001 From: John Ericson Date: Mon, 6 Jan 2020 16:39:56 -0500 Subject: [PATCH 236/241] Only do old these before with GHC pre-8.8 --- .travis.yml | 2 +- cabal.haskell-ci | 1 + 2 files changed, 2 insertions(+), 1 deletion(-) diff --git a/.travis.yml b/.travis.yml index ab117dbb..f905062d 100644 --- a/.travis.yml +++ b/.travis.yml @@ -165,7 +165,7 @@ script: # Constraint set no-th - ${CABAL} v2-build $WITHCOMPILER --disable-tests --disable-benchmarks --constraint='reflex -use-template-haskell' all | color_cabal_output # Constraint set old-these - - ${CABAL} v2-build $WITHCOMPILER --disable-tests --disable-benchmarks --constraint='these <1' all | color_cabal_output + - if $GHCJS || ! $GHCJS && [ $HCNUMVER -lt 80800 ] ; then ${CABAL} v2-build $WITHCOMPILER --disable-tests --disable-benchmarks --constraint='these <1' all | color_cabal_output ; fi # Constraint set old-witherable - ${CABAL} v2-build $WITHCOMPILER --disable-tests --disable-benchmarks --constraint='witherable <0.3.2' all | color_cabal_output diff --git a/cabal.haskell-ci b/cabal.haskell-ci index 50efdf12..d2d91c4b 100644 --- a/cabal.haskell-ci +++ b/cabal.haskell-ci @@ -10,6 +10,7 @@ constraint-set no-th constraints: reflex -use-template-haskell constraint-set old-these + ghc: <8.8 constraints: these <1 constraint-set old-witherable From 3bdcb73b0260208ff3f3d9bed36891101c096a9a Mon Sep 17 00:00:00 2001 From: John Ericson Date: Mon, 6 Jan 2020 16:41:05 -0500 Subject: [PATCH 237/241] Add cabal project and various CI files to nix filtering --- release.nix | 3 +++ 1 file changed, 3 insertions(+) diff --git a/release.nix b/release.nix index 79452f57..12370bb1 100644 --- a/release.nix +++ b/release.nix @@ -34,6 +34,9 @@ let "release.nix" ".git" "dist" + "cabal.haskell-ci" + "cabal.project" + ".travis.yml" ])) ./.; }; }) From cb1be17ce5644aae93c1cfd61fdda312ccb16367 Mon Sep 17 00:00:00 2001 From: John Ericson Date: Mon, 6 Jan 2020 16:51:27 -0500 Subject: [PATCH 238/241] Bump reflex platform used in test --- dep/reflex-platform/github.json | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/dep/reflex-platform/github.json b/dep/reflex-platform/github.json index 1639e8f1..1cd7cdcc 100644 --- a/dep/reflex-platform/github.json +++ b/dep/reflex-platform/github.json @@ -1,7 +1,7 @@ { "owner": "reflex-frp", "repo": "reflex-platform", - "branch": "develop", - "rev": "e7b76dd552a10916c7d8702c11292dac4f4299ea", - "sha256": "0s1183arrwldcs50qhzgnv94v24n9bgq6dfq64wp0a3q2nzyvgwh" + "branch": "master", + "rev": "510b990d0b11f0626afbec5fe8575b5b2395391b", + "sha256": "09cmahsbxr0963wq171c7j139iyzz49hramr4v9nsf684wcwkngv" } From d5a44abf3e48f7ea2f0adc01b6c239121c6ccba3 Mon Sep 17 00:00:00 2001 From: John Ericson Date: Mon, 6 Jan 2020 16:41:05 -0500 Subject: [PATCH 239/241] Add cabal project and various CI files to nix filtering (cherry picked from commit 3bdcb73b0260208ff3f3d9bed36891101c096a9a) --- release.nix | 3 +++ 1 file changed, 3 insertions(+) diff --git a/release.nix b/release.nix index 79452f57..12370bb1 100644 --- a/release.nix +++ b/release.nix @@ -34,6 +34,9 @@ let "release.nix" ".git" "dist" + "cabal.haskell-ci" + "cabal.project" + ".travis.yml" ])) ./.; }; }) From 72ec2a9166192ed8d3441f58da78d647c8e3cdba Mon Sep 17 00:00:00 2001 From: Ali Abrar Date: Tue, 21 May 2019 12:32:31 -0400 Subject: [PATCH 240/241] Add mapQueryT (cherry picked from commit 196cb7e1666b12acb457fa1f129b9f55dc924e3a + changelog) --- ChangeLog.md | 4 ++++ src/Reflex/Query/Base.hs | 5 +++++ 2 files changed, 9 insertions(+) diff --git a/ChangeLog.md b/ChangeLog.md index 49869972..c4cd9013 100644 --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,5 +1,9 @@ # Revision history for reflex +## Unreleased + +* Add `Reflex.Query.Base.mapQueryT`. See that module for documentation + ## 0.6.3 * `Data.WeakBag.traverse` and `Data.FastWeakBag.traverse` have been deprecated. diff --git a/src/Reflex/Query/Base.hs b/src/Reflex/Query/Base.hs index a8eae951..99709451 100644 --- a/src/Reflex/Query/Base.hs +++ b/src/Reflex/Query/Base.hs @@ -16,6 +16,7 @@ module Reflex.Query.Base , mapQueryResult , dynWithQueryT , withQueryT + , mapQueryT ) where import Control.Applicative (liftA2) @@ -287,6 +288,10 @@ withQueryT f a = do (fmapCheap (AdditivePatch . mapQuery f . unAdditivePatch) $ updatedIncremental q) return result +-- | Maps a function over a 'QueryT' that can change the underlying monad +mapQueryT :: (forall b. m b -> n b) -> QueryT t q m a -> QueryT t q n a +mapQueryT f (QueryT a) = QueryT $ mapStateT (mapEventWriterT (mapReaderT f)) a + -- | dynWithQueryT's (Dynamic t QueryMorphism) argument needs to be a group homomorphism at all times in order to behave correctly dynWithQueryT :: (MonadFix m, PostBuild t m, Group q, Additive q, Group q', Additive q', Query q') => Dynamic t (QueryMorphism q q') From 7a0d53c714e8c0d25e398baebec1d49e7a295379 Mon Sep 17 00:00:00 2001 From: John Ericson Date: Thu, 9 Jan 2020 14:21:53 -0500 Subject: [PATCH 241/241] Add changelog entry for 8.8 support Not an interface change, but still notable. --- ChangeLog.md | 2 ++ 1 file changed, 2 insertions(+) diff --git a/ChangeLog.md b/ChangeLog.md index c4cd9013..184a636d 100644 --- a/ChangeLog.md +++ b/ChangeLog.md @@ -2,6 +2,8 @@ ## Unreleased +* Support GHC 8.8 + * Add `Reflex.Query.Base.mapQueryT`. See that module for documentation ## 0.6.3