diff options
author | idontgetoutmuch <dominic@steinitz.org> | 2018-04-01 05:43:38 -0700 |
---|---|---|
committer | GitHub <noreply@github.com> | 2018-04-01 05:43:38 -0700 |
commit | c8c6a3e414bb08e3f818f58c121ddc99396b4f1e (patch) | |
tree | daf3add31de83efcc74b41755c2d05c811242ce6 /packages/base/src/Internal/Vector.hs | |
parent | d83b17190029c11e3ab8b504e5cdc917f5863120 (diff) | |
parent | 1a68793247b8845cefad4d157e4f4d25b1731b42 (diff) |
Merge pull request #262 from idontgetoutmuch/master
Implement CI
Diffstat (limited to 'packages/base/src/Internal/Vector.hs')
-rw-r--r-- | packages/base/src/Internal/Vector.hs | 7 |
1 files changed, 7 insertions, 0 deletions
diff --git a/packages/base/src/Internal/Vector.hs b/packages/base/src/Internal/Vector.hs index 67d0416..dedb822 100644 --- a/packages/base/src/Internal/Vector.hs +++ b/packages/base/src/Internal/Vector.hs | |||
@@ -1,6 +1,7 @@ | |||
1 | {-# LANGUAGE MagicHash, UnboxedTuples, BangPatterns, FlexibleContexts #-} | 1 | {-# LANGUAGE MagicHash, UnboxedTuples, BangPatterns, FlexibleContexts #-} |
2 | {-# LANGUAGE TypeSynonymInstances #-} | 2 | {-# LANGUAGE TypeSynonymInstances #-} |
3 | 3 | ||
4 | {-# OPTIONS_GHC -fno-warn-orphans #-} | ||
4 | 5 | ||
5 | -- | | 6 | -- | |
6 | -- Module : Internal.Vector | 7 | -- Module : Internal.Vector |
@@ -40,6 +41,7 @@ import qualified Data.Vector.Storable as Vector | |||
40 | import Data.Vector.Storable(Vector, fromList, unsafeToForeignPtr, unsafeFromForeignPtr, unsafeWith) | 41 | import Data.Vector.Storable(Vector, fromList, unsafeToForeignPtr, unsafeFromForeignPtr, unsafeWith) |
41 | 42 | ||
42 | import Data.Binary | 43 | import Data.Binary |
44 | import Data.Binary.Put | ||
43 | import Control.Monad(replicateM) | 45 | import Control.Monad(replicateM) |
44 | import qualified Data.ByteString.Internal as BS | 46 | import qualified Data.ByteString.Internal as BS |
45 | import Data.Vector.Storable.Internal(updPtr) | 47 | import Data.Vector.Storable.Internal(updPtr) |
@@ -92,6 +94,7 @@ createVector n = do | |||
92 | 94 | ||
93 | -} | 95 | -} |
94 | 96 | ||
97 | safeRead :: Storable a => Vector a -> (Ptr a -> IO c) -> c | ||
95 | safeRead v = inlinePerformIO . unsafeWith v | 98 | safeRead v = inlinePerformIO . unsafeWith v |
96 | {-# INLINE safeRead #-} | 99 | {-# INLINE safeRead #-} |
97 | 100 | ||
@@ -283,11 +286,13 @@ foldVectorWithIndex f x v = unsafePerformIO $ | |||
283 | go (dim v -1) x | 286 | go (dim v -1) x |
284 | {-# INLINE foldVectorWithIndex #-} | 287 | {-# INLINE foldVectorWithIndex #-} |
285 | 288 | ||
289 | foldLoop :: (Int -> t -> t) -> t -> Int -> t | ||
286 | foldLoop f s0 d = go (d - 1) s0 | 290 | foldLoop f s0 d = go (d - 1) s0 |
287 | where | 291 | where |
288 | go 0 s = f (0::Int) s | 292 | go 0 s = f (0::Int) s |
289 | go !j !s = go (j - 1) (f j s) | 293 | go !j !s = go (j - 1) (f j s) |
290 | 294 | ||
295 | foldVectorG :: Storable t1 => (Int -> (Int -> t1) -> t -> t) -> t -> Vector t1 -> t | ||
291 | foldVectorG f s0 v = foldLoop g s0 (dim v) | 296 | foldVectorG f s0 v = foldLoop g s0 (dim v) |
292 | where g !k !s = f k (safeRead v . flip peekElemOff) s | 297 | where g !k !s = f k (safeRead v . flip peekElemOff) s |
293 | {-# INLINE g #-} -- Thanks to Ryan Ingram (http://permalink.gmane.org/gmane.comp.lang.haskell.cafe/46479) | 298 | {-# INLINE g #-} -- Thanks to Ryan Ingram (http://permalink.gmane.org/gmane.comp.lang.haskell.cafe/46479) |
@@ -390,8 +395,10 @@ chunks d = let c = d `div` chunk | |||
390 | m = d `mod` chunk | 395 | m = d `mod` chunk |
391 | in if m /= 0 then reverse (m:(replicate c chunk)) else (replicate c chunk) | 396 | in if m /= 0 then reverse (m:(replicate c chunk)) else (replicate c chunk) |
392 | 397 | ||
398 | putVector :: (Storable t, Binary t) => Vector t -> Data.Binary.Put.PutM () | ||
393 | putVector v = mapM_ put $! toList v | 399 | putVector v = mapM_ put $! toList v |
394 | 400 | ||
401 | getVector :: (Storable a, Binary a) => Int -> Get (Vector a) | ||
395 | getVector d = do | 402 | getVector d = do |
396 | xs <- replicateM d get | 403 | xs <- replicateM d get |
397 | return $! fromList xs | 404 | return $! fromList xs |