WIP: Refactor Requester modules

reflex.cabal

@@ -57,6 +57,7 @@ library
     containers >= 0.6 && < 0.7,
     data-default >= 0.5 && < 0.8,
     dependent-map >= 0.3 && < 0.4,
+    dlist == 0.8.*,
     exception-transformers == 0.4.*,
     profunctors >= 5.3 && < 5.5,
     lens >= 4.7 && < 5,
@@ -90,13 +91,19 @@ library
     Data.FastMutableIntMap,
     Data.FastWeakBag,
     Data.Functor.Misc,
+    Data.List.Deferred,
+    Data.List.NonEmpty.Deferred,
+    Data.List.NonEmpty.Deferred.Internal,
     Data.Map.Misc,
+    Data.TagMap,
+    Data.Unique.Tag.Local,
+    Data.Unique.Tag.Local.Internal,
     Data.WeakBag,
     Reflex,
-    Reflex.Class,
     Reflex.Adjustable.Class,
     Reflex.BehaviorWriter.Base,
     Reflex.BehaviorWriter.Class,
+    Reflex.Class,
     Reflex.Collection,
     Reflex.Dynamic,
     Reflex.Dynamic.Uniq,
@@ -106,6 +113,7 @@ library
     Reflex.EventWriter,
     Reflex.EventWriter.Base,
     Reflex.EventWriter.Class,
+    Reflex.FanTag,
     Reflex.FastWeak,
     Reflex.FunctorMaybe,
     Reflex.Host.Class,
@@ -127,6 +135,7 @@ library
     Reflex.Query.Base,
     Reflex.Query.Class,
     Reflex.Requester.Base,
+    Reflex.Requester.Base.Internal,
     Reflex.Requester.Class,
     Reflex.Spider,
     Reflex.Spider.Internal,
@@ -137,6 +146,7 @@ library
     Reflex.Workflow
 
   ghc-options: -Wall -fwarn-redundant-constraints -fwarn-tabs -funbox-strict-fields -O2 -fspecialise-aggressively
+  ghc-prof-options: -fprof-auto-calls
 
   if flag(debug-trace-events)
     cpp-options: -DDEBUG_TRACE_EVENTS
@@ -172,6 +182,7 @@ test-suite semantics
   main-is: semantics.hs
   hs-source-dirs: test
   ghc-options: -O2 -Wall -rtsopts
+  ghc-prof-options: -fprof-auto-calls
   build-depends:
     base,
     bifunctors,
@@ -197,6 +208,7 @@ test-suite CrossImpl
   main-is: Reflex/Test/CrossImpl.hs
   hs-source-dirs: test
   ghc-options: -O2 -Wall -rtsopts
+  ghc-prof-options: -fprof-auto-calls
   build-depends:
     base,
     containers,
@@ -259,14 +271,15 @@ test-suite RequesterT
   build-depends: base
                , containers
                , deepseq
-               , dependent-sum
                , dependent-map
+               , dependent-sum
                , lens
                , mtl
+               , primitive
+               , ref-tf
+               , reflex
                , these
                , transformers
-               , reflex
-               , ref-tf
 
   if flag(split-these)
     build-depends: these-lens
@@ -348,6 +361,7 @@ benchmark spider-bench
   hs-source-dirs: bench test
   main-is: Main.hs
   ghc-options: -Wall -O2 -rtsopts
+  ghc-prof-options: -fprof-auto-calls
   build-depends:
     base,
     containers,
@@ -373,6 +387,7 @@ benchmark saulzar-bench
   c-sources: bench-cbits/checkCapability.c
   main-is: RunAll.hs
   ghc-options: -Wall -O2 -rtsopts -threaded
+  ghc-prof-options: -fprof-auto-calls
   build-depends:
     base,
     containers,

src/Data/List/Deferred.hs

@@ -0,0 +1,60 @@
+{-# LANGUAGE LambdaCase #-}
+module Data.List.Deferred
+  ( Deferred
+  , empty
+  , singleton
+  , toNonEmpty
+  , fromNonEmpty
+  , toList
+  ) where
+
+import Data.List.NonEmpty.Deferred.Internal (NonEmptyDeferred (..))
+import qualified Data.List.NonEmpty.Deferred as NonEmpty
+
+data Deferred a
+   = Deferred_Empty
+   | Deferred_Singleton a
+   | Deferred_Append !(NonEmptyDeferred a) !(NonEmptyDeferred a)
+
+{-# INLINE toNonEmpty #-}
+toNonEmpty :: Deferred a -> Maybe (NonEmptyDeferred a)
+toNonEmpty = \case
+  Deferred_Empty -> Nothing
+  Deferred_Singleton a -> Just $ NonEmpty.singleton a
+  Deferred_Append a b -> Just $ a <> b
+
+{-# INLINE fromNonEmpty #-}
+fromNonEmpty :: NonEmptyDeferred a -> Deferred a
+fromNonEmpty = \case
+  NonEmptyDeferred_Singleton a -> Deferred_Singleton a
+  NonEmptyDeferred_Append a b -> Deferred_Append a b
+
+{-# INLINE empty #-}
+empty :: Deferred a
+empty = Deferred_Empty
+
+{-# INLINE singleton #-}
+singleton :: a -> Deferred a
+singleton = fromNonEmpty . NonEmpty.singleton
+
+{-# INLINE toList #-}
+toList :: Deferred a -> [a]
+toList = \case
+  Deferred_Empty -> []
+  Deferred_Singleton a -> [a]
+  Deferred_Append a b -> NonEmpty.toList $ a <> b
+
+instance Semigroup (Deferred a) where
+  (<>) = \case
+    Deferred_Empty -> id
+    a@(Deferred_Singleton va) -> \case
+      Deferred_Empty -> a
+      Deferred_Singleton vb -> Deferred_Append (NonEmpty.singleton va) (NonEmpty.singleton vb)
+      Deferred_Append b1 b2 -> Deferred_Append (NonEmpty.singleton va) (b1 <> b2)
+    a@(Deferred_Append a1 a2) -> \case
+      Deferred_Empty -> a
+      Deferred_Singleton vb -> Deferred_Append (a1 <> a2) (NonEmpty.singleton vb)
+      Deferred_Append b1 b2 -> Deferred_Append (a1 <> a2) (b1 <> b2)
+
+instance Monoid (Deferred a) where
+  mempty = Deferred_Empty

src/Data/List/NonEmpty/Deferred.hs

@@ -0,0 +1,13 @@
+-- | Uses a non-associative internal structure to represent a NonEmpty list, but
+-- prevents external observers from observing the non-associativity.  This
+-- allows O(1) '(<>)'.
+
+{-# LANGUAGE LambdaCase #-}
+module Data.List.NonEmpty.Deferred
+  ( NonEmptyDeferred
+  , singleton
+  , toNonEmpty
+  , toList
+  ) where
+
+import Data.List.NonEmpty.Deferred.Internal

src/Data/List/NonEmpty/Deferred/Internal.hs

@@ -0,0 +1,30 @@
+{-# LANGUAGE LambdaCase #-}
+module Data.List.NonEmpty.Deferred.Internal where
+
+import Data.List.NonEmpty (NonEmpty (..))
+import qualified Data.List.NonEmpty as NonEmpty
+
+data NonEmptyDeferred a
+   = NonEmptyDeferred_Singleton a
+   | NonEmptyDeferred_Append !(NonEmptyDeferred a) !(NonEmptyDeferred a)
+
+{-# INLINE singleton #-}
+singleton :: a -> NonEmptyDeferred a
+singleton = NonEmptyDeferred_Singleton
+
+{-# INLINE toNonEmpty #-}
+toNonEmpty :: NonEmptyDeferred a -> NonEmpty a
+toNonEmpty = go []
+  where go t = \case
+          NonEmptyDeferred_Singleton a -> a :| t
+          NonEmptyDeferred_Append a b -> go (NonEmpty.toList $ go t b) a
+
+{-# INLINE toList #-}
+toList :: NonEmptyDeferred a -> [a]
+toList = go []
+  where go t = \case
+          NonEmptyDeferred_Singleton a -> a : t
+          NonEmptyDeferred_Append a b -> go (go t b) a
+
+instance Semigroup (NonEmptyDeferred a) where
+  (<>) = NonEmptyDeferred_Append

src/Data/TagMap.hs

@@ -0,0 +1,39 @@
+{-# LANGUAGE PolyKinds #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+module Data.TagMap
+  ( TagMap
+  , unTagMap
+  , fromDMap
+  , toDMap
+  , fromList
+  , insert
+  , size
+  ) where
+
+import Data.IntMap (IntMap)
+import qualified Data.IntMap as IntMap
+import Data.Dependent.Map (DMap)
+import qualified Data.Dependent.Map as DMap
+import Data.Dependent.Sum (DSum (..))
+import Data.Unique.Tag.Local
+
+import GHC.Exts (Any)
+import Unsafe.Coerce
+
+-- | Like DMap, but with 'Data.Unique.Tag.Tag' as the keys.  Implemented using 'Data.IntMap.IntMap' under the hood.
+newtype TagMap x (v :: k -> *) = TagMap { unTagMap :: IntMap Any }
+
+fromDMap :: forall k x (v :: k -> *). DMap (Tag x) v -> TagMap x v
+fromDMap = TagMap . IntMap.fromDistinctAscList . fmap (\((k :: Tag x (a :: k)) :=> v) -> (tagId k, (unsafeCoerce :: v a -> Any) v)) . DMap.toAscList
+
+toDMap :: forall x v. TagMap x v -> DMap (Tag x) v
+toDMap = DMap.fromDistinctAscList . fmap (\(k, v) -> (unsafeTagFromId k :=> (unsafeCoerce :: Any -> v a) v)) . IntMap.toAscList . unTagMap
+
+insert :: forall x a v. Tag x a -> v a -> TagMap x v -> TagMap x v
+insert k v = TagMap . IntMap.insert (tagId k) ((unsafeCoerce :: v a -> Any) v) . unTagMap
+
+fromList :: [DSum (Tag x) v] -> TagMap x v
+fromList = TagMap . IntMap.fromList . fmap (\(t :=> v) -> (tagId t, (unsafeCoerce :: v a -> Any) v))
+
+size :: TagMap x v -> Int
+size = IntMap.size . unTagMap

src/Data/Unique/Tag/Local.hs

@@ -0,0 +1,11 @@
+module Data.Unique.Tag.Local
+  ( Tag
+  , TagGen (..)
+  , tagId
+  , unsafeTagFromId
+  , newTag
+  , newTagGen
+  , withTagGen
+  ) where
+
+import Data.Unique.Tag.Local.Internal

src/Data/Unique/Tag/Local/Internal.hs

@@ -0,0 +1,57 @@
+-- | The type-safety of this module depends on two assumptions:
+-- 1. If the `s` parameters on two `TagGen`s can unify, then they contain the same MutVar
+-- 2. Two Tag values made from the same TagGen never contain the same Int
+
+{-# LANGUAGE EmptyDataDecls #-}
+{-# LANGUAGE DeriveFunctor #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE PolyKinds #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE MagicHash #-}
+module Data.Unique.Tag.Local.Internal where
+
+import Control.Monad.Primitive
+import Data.Primitive.MutVar
+import Data.GADT.Compare
+import Data.Some
+import GHC.Exts (Int (..), Int#, MutVar#, unsafeCoerce#)
+
+import Unsafe.Coerce
+
+newtype Tag x a = Tag Int
+
+tagId :: Tag x a -> Int
+tagId (Tag n) = n
+
+-- | WARNING: If you construct a tag with the wrong type, it will result in
+-- incorrect unsafeCoerce applications, which can segfault or cause arbitrary
+-- other damage to your program
+unsafeTagFromId :: Int -> Tag x a
+unsafeTagFromId n = Tag n
+
+-- We use Int because it is supported by e.g. IntMap
+newtype TagGen ps s = TagGen { unTagGen :: MutVar ps Int }
+
+instance Show (TagGen ps s) where
+  show (TagGen (MutVar m)) = show $ I# ((unsafeCoerce# :: MutVar# ps Int -> Int#) m)
+
+instance GEq (TagGen ps) where
+  TagGen a `geq` TagGen b =
+    if a == b
+    then Just $ unsafeCoerce Refl
+    else Nothing
+
+newTag :: PrimMonad m => TagGen (PrimState m) s -> m (Tag s a)
+newTag (TagGen r) = do
+  n <- atomicModifyMutVar' r $ \x -> (succ x, x)
+  pure $ Tag n
+
+newTagGen :: PrimMonad m => m (Some (TagGen (PrimState m)))
+newTagGen = Some . TagGen <$> newMutVar minBound
+
+withTagGen :: PrimMonad m => (forall s. TagGen (PrimState m) s -> m a) -> m a
+withTagGen f = do
+  g <- newTagGen
+  withSome g f