impure-containers 0.3 → 0.3.1

raw patch · 8 files changed

+395/−11 lines, 8 filesdep +transformersPVP ok

version bump matches the API change (PVP)

Dependencies added: transformers

API changes (from Hackage documentation)

Files

• impure-containers.cabal +13/−6
• src/Data/Graph/Immutable.hs +0/−3
• src/Data/Primitive/Array/Maybe.hs +48/−0
• src/Data/Primitive/Bool.hs +67/−0
• src/Data/Primitive/MutVar/Maybe.hs +53/−0
• src/Data/Primitive/PrimArray.hs +58/−0
• src/Data/Trie/Mutable/Bits.hs +93/−0
• test/Spec.hs +63/−2

@@ -1,5 +1,5 @@ name:                impure-containers-version:             0.3+version:             0.3.1 synopsis:            Mutable containers in haskell description:         Please see README.md homepage:            https://github.com/andrewthad/impure-containers#readme@@ -28,8 +28,14 @@     -- Data.Vector.Unique     Data.Graph.Immutable     Data.Graph.Mutable+    Data.Trie.Mutable.Bits     Data.ArrayList.Generic     Data.Graph.Types+    Data.Primitive.PrimArray+    Data.Primitive.Array.Maybe+    Data.Primitive.MutVar.Maybe+    Data.Primitive.Bool+    -- Data.Containers.Impure.Internal   other-modules:     Data.HashMap.Mutable.Internal.Array     Data.HashMap.Mutable.Internal.CacheLine@@ -73,11 +79,11 @@    -- ghc-prof-options: -prof -auto-all -  if impl(ghc >= 6.12.0)-    ghc-options: -Wall -fwarn-tabs -funbox-strict-fields -O2-                 -fno-warn-unused-do-bind-  else-    ghc-options: -Wall -fwarn-tabs -funbox-strict-fields -O2+  ghc-options:+    -Wall -fwarn-tabs -funbox-strict-fields+    -fno-warn-unused-do-bind+    -- Turn this one back on later+    -- -O2  Flag unsafe-tricks   Description: turn on unsafe GHC tricks@@ -114,6 +120,7 @@     , HUnit     , test-framework-hunit     , vector+    , transformers   ghc-options:         -threaded -rtsopts -with-rtsopts=-N   default-language:    Haskell2010 

@@ -23,9 +23,6 @@ import qualified Data.Vector.Unboxed as U import qualified Data.Vector.Unboxed.Mutable as MU --- mapVertices :: (v -> w) -> Graph g e v -> Graph g e w--- mapVertices = fmap- dijkstra :: (Ord s, Monoid s)   => (v -> v -> s -> e -> s)   -> s -- ^ Weight to assign start vertex

@@ -0,0 +1,48 @@+{-# LANGUAGE MagicHash #-}++-- | This uses some unsafe hackery.+module Data.Primitive.Array.Maybe +  ( MutableMaybeArray+  , newMaybeArray+  , readMaybeArray+  , writeMaybeArray+  ) where++import Control.Monad.Primitive+import Data.Primitive.Array+import GHC.Prim (reallyUnsafePtrEquality#,Any)+import Unsafe.Coerce (unsafeCoerce)++newtype MutableMaybeArray s a = MutableMaybeArray (MutableArray s Any)++unsafeToMaybe :: Any -> Maybe a+unsafeToMaybe a = +  case reallyUnsafePtrEquality# a nothingSurrogate of+    0# -> Just (unsafeCoerce a)+    _  -> Nothing+{-# INLINE unsafeToMaybe #-}++nothingSurrogate :: Any+nothingSurrogate = error "nothingSurrogate: This value should not be forced!"+{-# NOINLINE nothingSurrogate #-}++newMaybeArray :: PrimMonad m => Int -> Maybe a -> m (MutableMaybeArray (PrimState m) a)+newMaybeArray i ma = case ma of+  Just a -> do+    x <- newArray i (unsafeCoerce a)+    return (MutableMaybeArray x)+  Nothing -> do +    x <- newArray i nothingSurrogate+    return (MutableMaybeArray x)++readMaybeArray :: PrimMonad m => MutableMaybeArray (PrimState m) a -> Int -> m (Maybe a)+readMaybeArray (MutableMaybeArray m) ix = do+  a <- readArray m ix+  return (unsafeToMaybe a)++writeMaybeArray :: PrimMonad m => MutableMaybeArray (PrimState m) a -> Int -> Maybe a -> m ()+writeMaybeArray (MutableMaybeArray marr) ix ma = case ma of+  Just a -> writeArray marr ix (unsafeCoerce a)+  Nothing -> writeArray marr ix nothingSurrogate++

@@ -0,0 +1,67 @@+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE UnboxedTuples #-}++module Data.Primitive.Bool +  ( BoolByte(..)+  ) where++import Data.Primitive.Types+import qualified Data.Primitive.Types as P+import Data.Word+import GHC.Prim +import GHC.Types (Int(..))++{-@ data BoolByte = BoolByte { getBoolByte :: Bool } @-}+newtype BoolByte = BoolByte { getBoolByte :: Bool }++toBool :: Word8 -> BoolByte+toBool w = case w of+  0 -> BoolByte False+  _ -> BoolByte True+{-# INLINE toBool #-}++toBool# :: Word# -> BoolByte+toBool# w# = case eqWord# w# 0## of+  0# -> BoolByte False+  _  -> BoolByte True+{-# INLINE toBool# #-}++fromBool# :: BoolByte -> Word#+fromBool# (BoolByte b) = case b of+  True -> 1##+  False -> 0##+{-# INLINE fromBool# #-}++fromBool :: BoolByte -> Word8+fromBool (BoolByte b) = case b of+  True -> 1+  False -> 0++instance Prim BoolByte where+  sizeOf# _ = 1#+  alignment# _ = 1#+  indexByteArray# arr# i# = toBool# (indexWord8Array# arr# i#)               +  readByteArray# arr# i# s# = +    case readWord8Array# arr# i# s# of        +      { (# s1#, x# #) -> (# s1#, toBool# x# #) }  +  writeByteArray# arr# i# b s# = +    writeWord8Array# arr# i# (fromBool# b) s#    +  setByteArray# arr# i# n# b s# = P.setByteArray# arr# i# n# (fromBool b) s#+  indexOffAddr# addr# i# = toBool (indexOffAddr# addr# i#)+  readOffAddr#  addr# i# s# = +    case readOffAddr# addr# i# s# of+      (# s1#, w #) -> (# s1#, toBool w #)+  writeOffAddr# addr# i# b s# = writeOffAddr# addr# i# (fromBool b) s#+  setOffAddr# addr# i# n# b s# = +    setOffAddr# addr# i# n# (fromBool b) s#+  {-# INLINE sizeOf# #-}                                        +  {-# INLINE alignment# #-}                                     +  {-# INLINE indexByteArray# #-}                                +  {-# INLINE readByteArray# #-}                                 +  {-# INLINE writeByteArray# #-}                                +  {-# INLINE setByteArray# #-}                                  +  {-# INLINE indexOffAddr# #-}                                  +  {-# INLINE readOffAddr# #-}                                   +  {-# INLINE writeOffAddr# #-}                                  +  {-# INLINE setOffAddr# #-}                                    +

@@ -0,0 +1,53 @@+{-# LANGUAGE MagicHash    #-} +{-# LANGUAGE BangPatterns #-}++module Data.Primitive.MutVar.Maybe +  ( MutMaybeVar+  , newMutMaybeVar+  , readMutMaybeVar+  , writeMutMaybeVar+  ) where++import Data.Primitive.MutVar+import Control.Monad.Primitive++import Unsafe.Coerce+import GHC.Prim++import Data.Maybe++newtype MutMaybeVar s a = MutMaybeVar (MutVar s Any)++-- | nothingSurrogate stands in for the value Nothing; we distinguish it by pointer+nothingSurrogate :: Any+nothingSurrogate = error "Data.Primitive.MutVar.Maybe.nothingSurrogate evaluated"+{-# NOINLINE nothingSurrogate #-}++newMutMaybeVar :: PrimMonad m => Maybe a -> m (MutMaybeVar (PrimState m) a)+newMutMaybeVar ma = case ma of+  Just a -> do+    x <- newMutVar (unsafeCoerce a)+    return (MutMaybeVar x)+  Nothing -> do+    x <- newMutVar nothingSurrogate+    return (MutMaybeVar x)+{-# INLINE newMutMaybeVar #-}++readMutMaybeVar :: PrimMonad m => MutMaybeVar (PrimState m) a -> m (Maybe a)+readMutMaybeVar (MutMaybeVar r) = do+  x <- readMutVar r+  return $ toMaybe x+{-# INLINE readMutMaybeVar #-}++toMaybe :: Any -> Maybe a+toMaybe x = case reallyUnsafePtrEquality# x nothingSurrogate of+  0# -> Just $ unsafeCoerce x+  _ -> Nothing+{-# INLINE toMaybe #-}++writeMutMaybeVar :: PrimMonad m => MutMaybeVar (PrimState m) a -> Maybe a -> m ()+writeMutMaybeVar (MutMaybeVar r) ma = case ma of+  Just a -> writeMutVar r $ unsafeCoerce a+  Nothing -> writeMutVar r nothingSurrogate+{-# INLINE writeMutMaybeVar #-}+

@@ -0,0 +1,58 @@+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE UnboxedTuples #-}++module Data.Primitive.PrimArray +  ( MutablePrimArray(..)+  , newPrimArray+  , readPrimArray+  , writePrimArray+  , sizeofMutablePrimArray+  , setPrimArray+  ) where++import Control.Monad.Primitive+import Data.Primitive.ByteArray+import Data.Primitive.Types+import GHC.Prim (newByteArray#,quotInt#,sizeofMutableByteArray#,(*#))+import GHC.Types (Int(..))++newtype MutablePrimArray s a = MutablePrimArray (MutableByteArray s)++newPrimArray :: (PrimMonad m, Prim a) => Int -> m (MutablePrimArray (PrimState m) a)+newPrimArray (I# n#) = result+  where+  result = primitive (\s# -> case newByteArray# (n# *# (sizeOf# (toUndefined1 result))) s# of+      (# s'#, arr# #) -> (# s'#, MutablePrimArray (MutableByteArray arr#) #)+    )++readPrimArray :: (Prim a, PrimMonad m) => MutablePrimArray (PrimState m) a -> Int -> m a+readPrimArray (MutablePrimArray m) = readByteArray m+{-# INLINE readPrimArray #-}++writePrimArray :: (Prim a, PrimMonad m) => MutablePrimArray (PrimState m) a -> Int -> a -> m ()+writePrimArray (MutablePrimArray m) = writeByteArray m+{-# INLINE writePrimArray #-}++sizeofMutablePrimArray :: Prim a => MutablePrimArray s a -> Int+sizeofMutablePrimArray p@(MutablePrimArray (MutableByteArray arr#)) =+  I# (quotInt# (sizeofMutableByteArray# arr#) (sizeOf# (toUndefined2 p)))+{-# INLINE sizeofMutablePrimArray #-}++setPrimArray+  :: (Prim a, PrimMonad m) +  => MutablePrimArray (PrimState m) a -- ^ array to fill+  -> Int -- ^ offset into array+  -> Int -- ^ number of values to fill+  -> a   -- ^ value to fill with+  -> m ()+setPrimArray (MutablePrimArray m) = setByteArray m++-- A hack to avoid adding forall statements to+-- other type signatures.+toUndefined1 :: m (MutablePrimArray (PrimState m) a) -> a+toUndefined1 _ = undefined++toUndefined2 :: MutablePrimArray s a -> a+toUndefined2 _ = undefined++

@@ -0,0 +1,93 @@+{-# LANGUAGE BangPatterns #-}++module Data.Trie.Mutable.Bits where++import Control.Monad.Primitive+import Data.Bits+import Data.Primitive.ByteArray+import Data.Primitive.Array+import Data.Primitive.MutVar.Maybe+import Data.Word+import GHC.TypeLits+import Data.Primitive.PrimArray+import Data.Primitive.Bool (BoolByte(..))++data MTrie s k v = MTrie+  { trieValue :: !(MutMaybeVar s v)+  , trieLeft  :: !(MutMaybeVar s (MTrie s k v))+  , trieRight :: !(MutMaybeVar s (MTrie s k v))+  }++new :: PrimMonad m => m (MTrie (PrimState m) k v)+new = MTrie+  <$> newMutMaybeVar Nothing+  <*> newMutMaybeVar Nothing+  <*> newMutMaybeVar Nothing++-- | This gives the best match, that is, the+--   value stored at the longest prefix that+--   matched this key.+lookup :: (FiniteBits k, PrimMonad m)+  => MTrie (PrimState m) k v+  -> k+  -> m (Maybe v)+lookup theTrie theKey = go Nothing theTrie theKey where+  totalBits :: Int+  totalBits = finiteBitSize theKey+  -- mask :: k+  mask = bit (totalBits - 1)+  -- zero :: k+  zero = zeroBits+  go !mres (MTrie valRef leftRef rightRef) key = do+    mval <- readMutMaybeVar valRef+    let mresNext = case mval of+          Nothing -> mres+          Just res -> Just res+        chosenRef = if (mask .&. key) == zero+          then leftRef+          else rightRef+    chosen <- readMutMaybeVar chosenRef+    case chosen of+      Nothing -> return mresNext+      Just nextTrie -> go mresNext nextTrie (unsafeShiftL key 1)++insert :: (FiniteBits k, PrimMonad m)+  => MTrie (PrimState m) k v+  -> k -- ^ prefix key+  -> v -- ^ value+  -> m ()+insert trie key = insertPrefix trie (finiteBitSize key) key++insertPrefix :: (FiniteBits k, PrimMonad m)+  => MTrie (PrimState m) k v+  -> Int -- ^ significant bits from key+  -> k -- ^ prefix key+  -> v -- ^ value+  -> m ()+insertPrefix theTrie theSig theKey value =+  if theSig > totalBits+    then return ()+    else go theSig theKey theTrie+  where+  totalBits :: Int+  totalBits = finiteBitSize theKey+  -- mask :: k+  mask = bit (totalBits - 1)+  -- zero :: k+  zero = zeroBits+  go !significant !key (MTrie valRef leftRef rightRef) = if significant > 0+    then do+      let chosenRef = if (mask .&. key) == zero+            then leftRef+            else rightRef+      chosen <- readMutMaybeVar chosenRef+      nextTrie <- case chosen of+        Nothing -> do+          nextTrie <- new+          writeMutMaybeVar chosenRef (Just nextTrie)+          return nextTrie+        Just nextTrie -> return nextTrie+      go (significant - 1) (unsafeShiftL key 1) nextTrie+    else writeMutMaybeVar valRef (Just value)++

@@ -10,8 +10,10 @@ import Test.HUnit                           (Assertion,(@?=)) import Data.Monoid                          (All(..)) import Data.Traversable+import Data.Foldable import Control.Applicative import Data.Coerce+import Data.Functor.Compose  import Data.Word import Data.Function (on)@@ -23,11 +25,14 @@ import qualified Data.Map.Strict as Map import Debug.Trace +import Data.Primitive.Array.Maybe+ import qualified Data.Vector as V import qualified Data.ArrayList.Generic as ArrayList import qualified Data.Heap.Mutable.ModelD as HeapD import qualified Data.Graph.Mutable as MGraph import qualified Data.Graph.Immutable as Graph+import qualified Data.Trie.Mutable.Bits as BitTrie  main :: IO () main = defaultMain tests@@ -46,6 +51,13 @@     [ testProperty "Building only from vertices" graphBuildingVertices     , testProperty "Trivial case for Dijkstras Algorithm" dijkstraEasyDistance     ]+  , testGroup "MaybeArray"+    [ testCase "Values are as expected" maybeArrayWorks+    ]+  , testGroup "Bit Trie"+    [ testProperty "Basic Insert and Lookup" bitTrieBasic+    , testProperty "Prefixes" bitTriePrefix+    ]   ]  testElements :: Int@@ -140,8 +152,6 @@                    for vlist $ \vb ->                      Const (All $ Graph.lookupEdge va vb g == Just onlyEdge) -data Thing = Thing- -- Every node is connected to at most two other nodes. The end -- nodes only have one neighbor. Go from one end node to the other. dijkstraEasyDistance :: [Word32] -> Bool@@ -163,3 +173,54 @@           let expected = Min (sum xs)            in expected == Graph.dijkstra (\_ _ (Min x) distance -> Min (x + distance)) (Min 0) start end g +data Thing = Foo | Bar Int | Baz Bool+  deriving (Eq,Show)++maybeArrayWorks :: IO ()+maybeArrayWorks = do+  arr <- newMaybeArray 17 Nothing+  writeMaybeArray arr 0 (Just Foo)+  writeMaybeArray arr 9 (Just (Bar 62))+  writeMaybeArray arr 16 (Just (Baz True))+  a <- readMaybeArray arr 0+  b <- readMaybeArray arr 9+  c <- readMaybeArray arr 16+  d <- readMaybeArray arr 12+  arr2 <- newMaybeArray 17 (Just (Baz True))+  writeMaybeArray arr 2 Nothing+  writeMaybeArray arr 7 (Just (Bar 15))+  e <- readMaybeArray arr 2+  f <- readMaybeArray arr 7+  (a,b,c,d,e,f) @?=+    ( Just Foo, Just $ Bar 62+    , Just $ Baz True, Nothing+    , Nothing, Just (Bar 15)+    )++bitTrieBasic :: [Word8] -> Bool+bitTrieBasic xs =+  let res = runST $ do+        trie <- BitTrie.new+        for_ xs $ \x -> BitTrie.insert trie x x+        Const (All res) <- getCompose $ for_ xs $ \x -> Compose $ do+          m <- BitTrie.lookup trie x+          return $ Const $ case m of+            Nothing -> All False+            Just y -> All (x == y)+        return res+   in res == True++bitTriePrefix :: Word8 -> Bool+bitTriePrefix x = do+  let res = runST $ do+        trie <- BitTrie.new+        BitTrie.insertPrefix trie 4 0xF0 'B'+        BitTrie.insertPrefix trie 1 0x80 'A'+        BitTrie.insertPrefix trie 4 0x00 'C'+        m <- BitTrie.lookup trie x+        return $ case () of+          () | x <  0x10 -> m == Just 'C'+             | x >= 0xF0 -> m == Just 'B'+             | x >= 0x80 -> m == Just 'A'+             | otherwise -> m == Nothing+   in res == True