added WrappedFoldable and WithoutSpeculation

Control/Concurrent/Speculation.hs

@@ -1,4 +1,4 @@
-{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE BangPatterns, FlexibleContexts, DeriveFoldable, DeriveFunctor, DeriveTraversable #-}
 module Control.Concurrent.Speculation
     ( spec
     , evaluated
@@ -7,16 +7,20 @@ module Control.Concurrent.Speculation
 --    , specFoldl'
 --    , specFoldr'
     , Speculative(..)
+    , WrappedFoldable(..)
+    , WithoutSpeculation(..)
     ) where
 
 import Prelude hiding (foldl, foldl1, foldr, foldr1)
 import Data.Array
 import Data.Ix ()
 import Data.Foldable
+import Data.Traversable
 import Data.IntMap (IntMap)
 import Data.Map (Map)
 import Data.Set (Set)
 import Data.Sequence (Seq)
+import Data.Data
 import Control.Parallel (par)
 
 import Data.Bits
@@ -25,14 +29,18 @@ import Unsafe.Coerce
 
 data Box a = Box a
 
--- | Inspect the dynamic pointer tagging bits of a closure
+-- | Inspect the dynamic pointer tagging bits of a closure. This is an impure function that
+-- relies on GHC internals and will falsely return 0, but (hopefully) never give the wrong tag number if it returns 
+-- a non-0 value.
 tag :: a -> Int
 tag a = unsafeCoerce (Box a) .&. (sizeOf (undefined :: Int) - 1)
+{-# INLINE tag #-}
 
 -- | Returns a guess as to whether or not a value has been evaluated. This is an impure function
 -- that relies on GHC internals and will return false negatives, but (hopefully) no false positives.
 evaluated :: a -> Bool
 evaluated a = tag a /= 0
+{-# INLINE evaluated #-}
 
 -- | Evaluate a function using a cheap guess at the argument in parallel with forcing the argument.
 --
@@ -48,16 +56,20 @@ spec guess f a
             else f a
     where 
         speculation = f guess
+{-# INLINE spec #-}
 
-
+-- | Compute a right biased fold. The estimator function provides a guess at the value of the suffix
 specFoldr :: (Speculative f, Eq b) => (Int -> b) -> (a -> b -> b) -> b -> f a -> b
 specFoldr = specFoldrN 0
+{-# INLINE specFoldr #-}
 
+-- | Compute a left-biased fold. The estimator function provides a guess at the value of the prefix
 specFoldl  :: (Speculative f, Eq b) => (Int -> b) -> (b -> a -> b) -> b -> f a -> b
 specFoldl = specFoldlN 0
+{-# INLINE specFoldl #-}
 
 class Foldable f => Speculative f where
-    -- | Compute a right biased fold. the estimator function is a guess at the value of the suffix
+    -- | Compute a right-biased fold. The estimator function is a guess at the value of the prefix
     specFoldr1 :: Eq a => (Int -> a) -> (a -> a -> a) -> f a -> a
     specFoldrN :: Eq b => Int -> (Int -> b) -> (a -> b -> b) -> b -> f a -> b
 
@@ -116,3 +128,69 @@ instance Speculative Seq
 -- specFoldr' g f z0 xs = specFoldl g' f' id xs z0 where
 --    f' x k z = k $! f x z
 --    g' = undefined -- n z = f (g n) z
+
+newtype WrappedFoldable f a = WrappedFoldable { getWrappedFoldable :: f a } 
+    deriving (Functor, Foldable, Traversable)
+
+instance Foldable f => Speculative (WrappedFoldable f)
+
+instance Typeable1 f => Typeable1 (WrappedFoldable f) where
+    typeOf1 tfa = mkTyConApp wrappedTyCon [typeOf1 (undefined `asArgsType` tfa)]
+        where asArgsType :: f a -> t f a -> f a
+              asArgsType = const
+    
+wrappedTyCon :: TyCon
+wrappedTyCon = mkTyCon "Control.Concurrent.Speculation.WrappedFoldable"
+{-# NOINLINE wrappedTyCon #-}
+
+wrappedConstr :: Constr
+wrappedConstr = mkConstr wrappedDataType "WrappedFoldable" [] Prefix
+{-# NOINLINE wrappedConstr #-}
+
+wrappedDataType :: DataType
+wrappedDataType = mkDataType "Control.Concurrent.Speculation.WrappedFoldable" [wrappedConstr]
+{-# NOINLINE wrappedDataType #-}
+
+instance (Typeable1 f, Data (f a), Data a) => Data (WrappedFoldable f a) where
+    gfoldl f z (WrappedFoldable a) = z WrappedFoldable `f` a
+    toConstr _ = wrappedConstr
+    gunfold k z c = case constrIndex c of
+        1 -> k (z WrappedFoldable)
+        _ -> error "gunfold"
+    dataTypeOf _ = wrappedDataType
+    dataCast1 f = gcast1 f
+
+newtype WithoutSpeculation f a = WithoutSpeculation { getWithoutSpeculation :: f a } 
+    deriving (Functor, Foldable, Traversable)
+
+instance Typeable1 f => Typeable1 (WithoutSpeculation f) where
+    typeOf1 tfa = mkTyConApp withoutTyCon [typeOf1 (undefined `asArgsType` tfa)]
+        where asArgsType :: f a -> t f a -> f a
+              asArgsType = const
+
+instance Foldable f => Speculative (WithoutSpeculation f) where
+    specFoldr1 _   = foldr1
+    specFoldrN _ _ = foldr
+    specFoldl1 _   = foldl1
+    specFoldlN _ _ = foldl
+
+withoutTyCon :: TyCon
+withoutTyCon = mkTyCon "Control.Concurrent.Speculation.WithoutSpeculation"
+{-# NOINLINE withoutTyCon #-}
+
+withoutConstr :: Constr
+withoutConstr = mkConstr withoutDataType "WithoutSpeculation" [] Prefix
+{-# NOINLINE withoutConstr #-}
+
+withoutDataType :: DataType
+withoutDataType = mkDataType "Control.Concurrent.Speculation.WithoutSpeculation" [withoutConstr]
+{-# NOINLINE withoutDataType #-}
+
+instance (Typeable1 f, Data (f a), Data a) => Data (WithoutSpeculation f a) where
+    gfoldl f z (WithoutSpeculation a) = z WithoutSpeculation `f` a
+    toConstr _ = withoutConstr
+    gunfold k z c = case constrIndex c of
+        1 -> k (z WithoutSpeculation)
+        _ -> error "gunfold"
+    dataTypeOf _ = withoutDataType
+    dataCast1 f = gcast1 f

speculation.cabal

@@ -1,11 +1,11 @@
 name:           speculation
-version:        0.0.0
+version:        0.0.1
 license:        BSD3
 license-file:   LICENSE
 author:         Edward A. Kmett
 maintainer:     Edward A. Kmett <ekmett@gmail.com>
 stability:      experimental
-homepage:       http://comonad.com/reader
+homepage:       http://github.com/ekmett/speculation
 category:       Concurrency
 synopsis:       A framework for safe, programmable, speculative parallelism
 description:    A framework for safe, programmable, speculative parallelism, loosely based on