diff --git a/Data/Repa/Array.hs b/Data/Repa/Array.hs --- a/Data/Repa/Array.hs +++ b/Data/Repa/Array.hs @@ -30,8 +30,15 @@ , index , (!) , length - , head, tail, init + , first, last + , head, tail, init + -- * Construction + , empty + , singleton + , generateMaybeS + , generateEitherS + -- * Conversion , fromList , fromLists @@ -43,6 +50,9 @@ -- * Operators + -- ** Replicating + , replicates + -- ** Mapping , map , map2 @@ -54,7 +64,7 @@ , foldsWith -- *** Special Folds - , sum, prod + , sum, product , mean, std , correlate @@ -104,11 +114,34 @@ , segmentOn , dice , diceSep + + -- ** Products + + -- *** Generic + , prod + , unprod + + -- *** Pattern synonyms + -- | These patterns patterns work on arrays of arbitrary element type. + -- + -- (Haddock 2.16.0 has a bug where the type signatures come out monomorphic) + -- + , pattern Prod2 + , pattern Prod3 + , pattern Prod4 + , pattern Prod5 + , pattern Prod6 + , pattern Prod7 + , pattern Prod8 + , pattern Prod9 ) where import Data.Repa.Array.Auto import Prelude - hiding ( map, length, reverse, filter, concat, unlines, foldl, sum - , head, init, tail, zip, unzip) + hiding ( map, length, reverse, filter, concat, unlines, foldl + , sum, product + , last + , head, init, tail + , zip, unzip) diff --git a/Data/Repa/Array/Auto.hs b/Data/Repa/Array/Auto.hs --- a/Data/Repa/Array/Auto.hs +++ b/Data/Repa/Array/Auto.hs @@ -7,8 +7,15 @@ , index , (!) , length + , first, last , head, init, tail + -- * Construction + , empty + , singleton + , generateMaybeS, mapMaybeS + , generateEitherS, mapEitherS + -- * Conversion , fromList , fromLists @@ -20,6 +27,9 @@ -- * Operators + -- ** Replicating + , replicates + -- ** Mapping , map , map2 @@ -27,7 +37,7 @@ -- ** Folding , foldl - , sum, prod + , sum, product , mean, std , correlate , folds @@ -70,6 +80,9 @@ , compact , compactIn + -- ** Processing + , process + -- ** Grouping , groups , groupsWith @@ -78,11 +91,36 @@ , segment , segmentOn , dice - , diceSep) + , diceSep + + -- ** Products + + -- *** Generic + , prod + , unprod + + -- *** Pattern synonyms + -- | These patterns patterns work on arrays of arbitrary element type. + -- + -- (Haddock 2.16.0 has a bug where the type signatures come out monomorphic) + -- + , pattern Prod2 + , pattern Prod3 + , pattern Prod4 + , pattern Prod5 + , pattern Prod6 + , pattern Prod7 + , pattern Prod8 + , pattern Prod9) where import Data.Repa.Array.Auto.Base import Data.Repa.Array.Auto.Operator +import Data.Repa.Array.Material.Auto.InstProduct import Prelude - hiding ( map, length, reverse, filter, concat, unlines, foldl, sum, zip, unzip - , head, init, tail) + hiding ( map, length, reverse, filter, concat, unlines, foldl + , sum, product + , zip, unzip + , head, init, tail, last) + + diff --git a/Data/Repa/Array/Auto/Base.hs b/Data/Repa/Array/Auto/Base.hs --- a/Data/Repa/Array/Auto/Base.hs +++ b/Data/Repa/Array/Auto/Base.hs @@ -7,11 +7,8 @@ import Data.Repa.Array.Material.Auto (A(..)) import qualified Data.Repa.Array.Generic as G import qualified Data.Repa.Array.Meta.Window as A -import qualified Data.Repa.Array.Internals.Target as G -import qualified Data.Repa.Fusion.Unpack as F - -- | Arrays of elements that are automatically layed out into some -- efficient runtime representation. -- @@ -32,7 +29,6 @@ -- | Class of elements where arrays of those elements can be constructed -- in arbitrary order. -type Build a t +type Build a = ( G.Bulk A a - , G.Target A a - , F.Unpack (G.Buffer A a) t) + , G.Target A a) diff --git a/Data/Repa/Array/Auto/Format.hs b/Data/Repa/Array/Auto/Format.hs new file mode 100644 --- /dev/null +++ b/Data/Repa/Array/Auto/Format.hs @@ -0,0 +1,212 @@ + +module Data.Repa.Array.Auto.Format + ( module Data.Repa.Convert.Format + , module Data.Repa.Convert.Formats + + -- * Packing + , packFormat + , packsFormat + , packsFormatLn + + -- * Unpacking + , unpackFormat + , unpacksFormatLn + , UnpackableRow + , A.Unpackables) +where +import Data.Repa.Array.Auto.Base as A +import Data.Repa.Array.Generic.Convert as A +import qualified Data.Repa.Array.Generic as AG +import qualified Data.Repa.Array.Material.Auto as A +import qualified Data.Repa.Array.Material.Auto.Operator.Lines as A +import qualified Data.Repa.Array.Material.Auto.Operator.Unpackables as A +import qualified Data.Repa.Array.Material.Foreign as AF +import qualified Data.Repa.Array.Internals.Target as A +import qualified Data.Repa.Array.Internals.Layout as A +import qualified Data.Repa.Array.Internals.Bulk as A +import qualified Data.Repa.Convert.Format as C +import Data.Repa.Convert.Format +import Data.Repa.Convert.Formats + +import Foreign.ForeignPtr as F +import Foreign.Ptr as F + +import System.IO.Unsafe +import Data.Word +import Data.Char + +import qualified Data.Vector.Storable.Mutable as SM +#include "repa-array.h" + + +--------------------------------------------------------------------------------------------------- +-- | Pack a value into a buffer using the given format. +packFormat + :: C.Packable format + => format -- ^ Format for the value. + -> Value format -- ^ Source value. + -> Maybe (Array Word8) -- ^ Packed binary data. + +packFormat !format !v + | Just lenBytes <- packedSize format v + = unsafePerformIO + $ do + -- The 'lenBytes' we get above is an upper bound on the + -- number of used by the serialised data. + buf@(AF.FBuffer mvec) :: A.Buffer AF.F Word8 + <- A.unsafeNewBuffer (AF.Foreign lenBytes) + + let (fptr, oStart, _) = SM.unsafeToForeignPtr mvec + + -- When we pack the data into the buffer we get the number + -- of bytes actually used, then slice the original buffer + -- down to this size. + withForeignPtr fptr $ \ptr + -> do Just ptr' <- C.unsafeRunPacker (C.pack format v) + (plusPtr ptr oStart) + let len = minusPtr ptr' ptr + buf' <- A.unsafeSliceBuffer 0 len buf + arr <- A.unsafeFreezeBuffer buf' + return $ Just $ A.convert arr + + | otherwise = Nothing +{-# INLINE_ARRAY packFormat #-} + + +-- | Pack an array of values into a buffer using the given format. +-- +-- * The bytes representing each value are concatenated together with no delimitor. +-- +packsFormat + :: (C.Packable format, Show format, A.Bulk A.A (Value format)) + => format -- ^ Format for each value + -> Array (Value format) -- ^ Source values. + -> Maybe (Array Word8) -- ^ Packed binary data. + +packsFormat !format !arr + = let + packRow v + = case packFormat format v of + Nothing + -> error $ unlines + [ "repa-array.packsFormat: conversion failed"] + + Just arr8 -> arr8 + {-# INLINE packRow #-} + + in Just $ AG.concat A.A $ AG.mapS A.N packRow arr +{-# INLINE_ARRAY packsFormat #-} + + +-- | Like `packsFormat`, but append a newline character after +-- every packed element. +-- +-- * If a value cannot be converted then this function just returns `error`. +-- +packsFormatLn + :: (C.Packable format, A.Bulk A.A (Value format)) + => format -- ^ Format for each value + -> Array (Value format) -- ^ Source values. + -> Maybe (Array Word8) -- ^ Packed binary data. + +packsFormatLn !format !arr + = let + !arrNL + = A.fromList A.A [fromIntegral $ ord '\n'] -- TODO: kill lists + + packRow v + = case packFormat format v of + Nothing + -> error $ unlines + [ "repa-array.packsFormat: conversion failed"] + + Just arr8 -> AG.concat A.A $ A.fromList A.A [ arr8, arrNL ] + {-# INLINE packRow #-} + + in Just $ AG.concat A.A $ AG.mapS A.N packRow arr +{-# INLINE_ARRAY packsFormatLn #-} + + + +--------------------------------------------------------------------------------------------------- +-- | Unpack a value from a buffer using the given format. +unpackFormat + :: C.Unpackable format + => format -- ^ Format for the value. + -> Array Word8 -- ^ Packed binary data. + -> Maybe (C.Value format) -- ^ Unpacked value. + +unpackFormat !format !arrBytes + | lenBytes <- A.length arrBytes + = unsafePerformIO + $ let (oStart, _, fptr :: ForeignPtr Word8) + = AF.toForeignPtr $ A.convert arrBytes + in withForeignPtr fptr $ \ptr_ + -> do r <- C.unsafeRunUnpacker + (C.unpack format) + (plusPtr ptr_ oStart) + lenBytes (const False) + case r of + Just (v, _) -> return $ Just v + _ -> return Nothing + + | otherwise = Nothing +{-# INLINE_ARRAY unpackFormat #-} + + + +-- | Unpack an encoded table of values from an array of bytes. +unpacksFormatLn + :: UnpackableRow format + => Sep format -- ^ Format of each row. + -> Array Word8 -- ^ Source data. + -> Array (Value (Sep format)) -- ^ Array of rows. + +unpacksFormatLn format arrSrc@(A.AArray_Word8 arrSrcF) + = unsafePerformIO + $ do + -- Rows are separated by newline characters. + let !wSepRow + = fromIntegral $ ord '\n' + + -- Determine the field separator character. + -- If the format is just () then we're only counting the + -- number of lines in the table, so it doesn't matter + -- what we use for the field separator. + let !wSepField + = case takeSepChar format of + Nothing -> fromIntegral $ ord ' ' + Just c -> fromIntegral $ ord c + + -- Scan through the input data to determine where the lines begin + -- and end. + let (ixsStarts, ixsEnds) + = A.findRowsStartEnd wSepRow arrSrc + + -- Allocate a buffer for the output data. + let len = A.extent $ A.bufferLayout ixsStarts + buf <- A.unsafeNewBuffer (A.Auto len) + + -- Unpack all the rows into the buffer. + mErr <- A.unpacksToBuffer + format + wSepField + arrSrcF + ixsStarts ixsEnds buf + + case mErr of + Nothing + -> A.unsafeFreezeBuffer buf + + -- TODO: return error. + Just err + -> error $ "unsafeFormatLn: parse error " ++ show err +{-# INLINE unpacksFormatLn #-} + + +-- | Dictionaries needed to unpack a row of the given format. +type UnpackableRow format + = ( SepFormat format + , A.Unpackables (Sep format) + , A.Target A.A (Value (Sep format))) + diff --git a/Data/Repa/Array/Auto/IO.hs b/Data/Repa/Array/Auto/IO.hs --- a/Data/Repa/Array/Auto/IO.hs +++ b/Data/Repa/Array/Auto/IO.hs @@ -1,46 +1,80 @@ --- | Array IO +-- | Raw Array IO. module Data.Repa.Array.Auto.IO - ( -- * Raw Array IO - hGetArray, hGetArrayPre - , hPutArray - - -- * XSV files - -- ** Reading - , getArrayFromXSV, hGetArrayFromXSV + ( -- * Via File Names + readFile + , writeFile + , appendFile - -- ** Writing - , putArrayAsXSV, hPutArrayAsXSV) + -- * Via File Handles + , hGetArray, hGetArrayPre + , hPutArray) where import Data.Repa.Array.Auto.Base import Data.Repa.Array.Generic.Convert -import System.IO import Data.Word -import Data.Char -import qualified Data.Repa.Array.Material.Auto as A import qualified Data.Repa.Array.Material.Foreign as A -import qualified Data.Repa.Array.Material.Nested as A -import qualified Data.Repa.Array.Meta as A -import qualified Data.Repa.Array.Generic as A import qualified Foreign.Ptr as F import qualified Foreign.ForeignPtr as F import qualified Foreign.Marshal.Alloc as F import qualified Foreign.Marshal.Utils as F +import qualified System.IO as S +import qualified System.FileLock as S +import Prelude hiding (readFile, writeFile, appendFile) --- | Get data from a file, up to the given number of bytes. -hGetArray :: Handle -> Int -> IO (Array Word8) +--------------------------------------------------------------------------------------------------- +-- | Read an entire file as an array of bytes. +readFile :: FilePath -> IO (Array Word8) +readFile path + = S.withFileLock path S.Shared + $ \_lock -> do + h <- S.openFile path S.ReadMode + S.hSeek h S.SeekFromEnd 0 + len <- S.hTell h + S.hSeek h S.AbsoluteSeek 0 + !arr <- hGetArray h (fromIntegral len) + S.hClose h + return arr +{-# NOINLINE readFile #-} + + +-- | Write an array of bytes to a file. +writeFile :: FilePath -> Array Word8 -> IO () +writeFile path arr + = S.withFileLock path S.Exclusive + $ \_lock -> do + h <- S.openFile path S.WriteMode + hPutArray h arr + S.hClose h +{-# NOINLINE writeFile #-} + + +-- | Append an array of bytes to a file. +appendFile :: FilePath -> Array Word8 -> IO () +appendFile path arr + = S.withFileLock path S.Exclusive + $ \_lock -> do + h <- S.openFile path S.AppendMode + hPutArray h arr + S.hClose h +{-# NOINLINE appendFile #-} + + +--------------------------------------------------------------------------------------------------- +-- | Get data from a file handle, up to the given number of bytes. +hGetArray :: S.Handle -> Int -> IO (Array Word8) hGetArray h len = do buf :: F.Ptr Word8 <- F.mallocBytes len - bytesRead <- hGetBuf h buf len + bytesRead <- S.hGetBuf h buf len fptr <- F.newForeignPtr F.finalizerFree buf return $! convert $! A.fromForeignPtr bytesRead fptr {-# NOINLINE hGetArray #-} --- | Get data from a file, up to the given number of bytes, also +-- | Get data from a file handle, up to the given number of bytes, also -- copying the given data to the front of the new buffer. -hGetArrayPre :: Handle -> Int -> Array Word8 -> IO (Array Word8) +hGetArrayPre :: S.Handle -> Int -> Array Word8 -> IO (Array Word8) hGetArrayPre h len arr | (offset, lenPre, fptrPre :: F.ForeignPtr Word8) <- A.toForeignPtr $ convert arr @@ -49,7 +83,7 @@ let ptrPre = F.plusPtr ptrPre' offset ptrBuf :: F.Ptr Word8 <- F.mallocBytes (lenPre + len) F.copyBytes ptrBuf ptrPre lenPre - lenRead <- hGetBuf h (F.plusPtr ptrBuf lenPre) len + lenRead <- S.hGetBuf h (F.plusPtr ptrBuf lenPre) len let bytesTotal = lenPre + lenRead fptrBuf <- F.newForeignPtr F.finalizerFree ptrBuf return $ convert $! A.fromForeignPtr bytesTotal fptrBuf @@ -57,109 +91,12 @@ -- | Write data into a file. -hPutArray :: Handle -> Array Word8 -> IO () +hPutArray :: S.Handle -> Array Word8 -> IO () hPutArray h arr | (offset, lenPre, fptrPre :: F.ForeignPtr Word8) <- A.toForeignPtr $ convert arr = F.withForeignPtr fptrPre $ \ptr' -> do let ptr = F.plusPtr ptr' offset - hPutBuf h ptr lenPre + S.hPutBuf h ptr lenPre {-# NOINLINE hPutArray #-} - - ---------------------------------------------------------------------------------------------------- --- | Read a XSV file as a nested array. --- We get an array of rows:fields:characters. -getArrayFromXSV - :: Char -- ^ Field separator character, eg '|', ',' or '\t'. - -> FilePath -- ^ Source file handle. - -> IO (Array (Array (Array Char))) - -getArrayFromXSV !cSep !filePath - = do h <- openFile filePath ReadMode - arr <- hGetArrayFromXSV cSep h - hClose h - return arr - - --- | Read an XSV file as a nested array. --- We get an array of rows:fields:characters. -hGetArrayFromXSV - :: Char -- ^ Field separator character, eg '|', ',' or '\t'. - -> Handle -- ^ Source file handle. - -> IO (Array (Array (Array Char))) - -hGetArrayFromXSV !cSep !hIn - = do - -- Find out how much data there is remaining in the file. - start <- hTell hIn - hSeek hIn SeekFromEnd 0 - end <- hTell hIn - let !len = end - start - hSeek hIn AbsoluteSeek start - - -- Read array as Word8s. - !arr8 <- hGetArray hIn (fromIntegral len) - - -- Rows are separated by new lines, - -- fields are separated by the given separator character. - let !nl = fromIntegral $ ord '\n' - let !nc = fromIntegral $ ord cSep - - -- Split XSV file into rows and fields. - -- Convert element data from Word8 to Char. - -- Chars take 4 bytes each, but are standard Haskell and pretty - -- print properly. We've done the dicing on the smaller Word8 - -- version, and now map across the elements vector in the array - -- to do the conversion. - let !arrChar - = A.mapElems - (A.mapElems (A.computeS A.F . A.map (chr . fromIntegral))) - (A.diceSep nc nl arr8) - - return $ convert arrChar - - --------------------------------------------------------------------------------------------------- --- | Write a nested array as an XSV file. --- --- The array contains rows:fields:characters. -putArrayAsXSV - :: Char -- ^ Separator character, eg '|', ',' or '\t' - -> FilePath -- ^ Source file handle. - -> Array (Array (Array Char)) -- ^ Array of row, field, character. - -> IO () - -putArrayAsXSV !cSep !filePath !arrChar - = do h <- openFile filePath WriteMode - hPutArrayAsXSV cSep h arrChar - hClose h - - --- | Write a nested array as an XSV file. --- --- The array contains rows:fields:characters. -hPutArrayAsXSV - :: Char -- ^ Separator character, eg '|', ',' or '\t' - -> Handle -- ^ Source file handle. - -> Array (Array (Array Char)) -- ^ Array of row, field, character. - -> IO () - -hPutArrayAsXSV !cSep !hOut !arrChar - = do - -- Concat result back into Word8s - let !arrC = A.fromList A.U [cSep] - let !arrNL = A.fromList A.U ['\n'] - - let !arrOut - = A.mapS A.A (fromIntegral . ord) - $ A.concat A.U - $ A.mapS A.B (\arrFields - -> A.concat A.U $ A.fromList A.B - [ A.intercalate A.U arrC arrFields, arrNL]) - $ arrChar - - hPutArray hOut arrOut -{-# INLINE hPutArrayAsXSV #-} - diff --git a/Data/Repa/Array/Auto/Operator.hs b/Data/Repa/Array/Auto/Operator.hs --- a/Data/Repa/Array/Auto/Operator.hs +++ b/Data/Repa/Array/Auto/Operator.hs @@ -12,8 +12,15 @@ , index , (!) , length - , head, tail, init + , first, last + , head, tail, init + -- * Construction + , empty + , singleton + , generateMaybeS, mapMaybeS + , generateEitherS, mapEitherS + -- * Conversion , fromList , fromLists @@ -25,6 +32,9 @@ -- * Operators + -- ** Replicating + , replicates + -- ** Mapping , map , map2 @@ -32,7 +42,7 @@ -- ** Folding , foldl - , sum, prod + , sum, product , mean, std -- *** Special Folds @@ -77,6 +87,9 @@ , compact , compactIn + -- ** Processing + , process + -- ** Grouping , groups , groupsWith @@ -100,12 +113,12 @@ import qualified Data.Repa.Array.Meta.Delayed as A import qualified Data.Repa.Array.Meta.Delayed2 as A import qualified Data.Repa.Array.Internals.Bulk as G -import qualified Data.Repa.Fusion.Unpack as F import qualified Data.Repa.Chain as C import qualified Data.Vector.Unboxed as U import Prelude - hiding ( map, length, reverse, filter, concat, unlines, foldl, sum, zip, unzip - , head, tail, init) + hiding ( map, length, reverse, filter, concat, unlines, foldl + , sum, product, zip, unzip + , head, tail, init, last) -- Basic ------------------------------------------------------------------------------------------ @@ -130,11 +143,21 @@ {-# INLINE length #-} --- | O(1). Take the head of an array, or `Nothing` if it's empty. +-- | O(1). Take the first element of an array, or `Nothing` if it's empty. +first :: Elem a => Array a -> Maybe a +first = G.first +{-# INLINE first #-} + + +-- | O(1). Take the last element of an array, or `Nothing` if it's empty. +last :: Elem a => Array a -> Maybe a +last = G.last +{-# INLINE last #-} + + +-- | O(1). alias for `first`. head :: Elem a => Array a -> Maybe a -head arr = if G.length arr < 1 - then Nothing - else Just (arr `index` 0) +head = G.first {-# INLINE head #-} @@ -150,23 +173,82 @@ {-# INLINE init #-} +-- Construction ----------------------------------------------------------------------------------- +-- | O(1). An empty array of the given layout. +empty :: Build a + => Array a +empty = G.empty A +{-# INLINE empty #-} + + +-- | O(1). Create a new empty array containing a single element. +singleton + :: Build a + => a -> Array a +singleton = G.singleton A +{-# INLINE singleton #-} + + +-- | Like `generateS` but use a function that produces Maybe an element. +-- If any element returns `Nothing`, then `Nothing` for the whole array. +generateMaybeS + :: Build a + => Int -> (Int -> Maybe a) + -> Maybe (Array a) +generateMaybeS = G.generateMaybeS A +{-# INLINE generateMaybeS #-} + + +-- | Apply a function to every element of an array, +-- if any application returns `Nothing`, then `Nothing` for the whole result. +mapMaybeS + :: (Elem a, Build b) + => (a -> Maybe b) + -> Array a + -> Maybe (Array b) +mapMaybeS = G.mapMaybeS A +{-# INLINE mapMaybeS #-} + + +-- | Like `generateS` but use a function that produces Either some error +-- or an element. If any element returns `Nothing`, then `Nothing` for +-- the whole array. +generateEitherS + :: Build a + => Int -> (Int -> Either err a) + -> Either err (Array a) +generateEitherS = G.generateEitherS A +{-# INLINE generateEitherS #-} + + +-- | Apply a function to every element of an array, +-- if any application returns `Left`, then `Left` for the whole result. +mapEitherS + :: (Elem a, Build b) + => (a -> Either err b) + -> Array a + -> Either err (Array b) +mapEitherS = G.mapEitherS A +{-# INLINE mapEitherS #-} + + -- Conversion ------------------------------------------------------------------------------------- -- | Convert a list to an array. -fromList :: Build a at +fromList :: Build a => [a] -> Array a fromList = G.fromList A {-# INLINE fromList #-} -- | Convert a nested list to an array. -fromLists :: Build a at +fromLists :: Build a => [[a]] -> Array (Array a) fromLists xs = convert $! N.fromLists A xs {-# INLINE fromLists #-} -- | Convert a triply nested list to a triply nested array. -fromListss :: Build a at +fromListss :: Build a => [[[a]]] -> Array (Array (Array a)) fromListss xs = convert $! N.fromListss A xs {-# INLINE fromListss #-} @@ -200,14 +282,25 @@ -- [10,9,8,7,6,5,4,3,2,1,0] -- @ -- -reverse :: Build a at => Array a -> Array a +reverse :: Build a => Array a -> Array a reverse arr = G.computeS A $! A.reverse arr {-# INLINE reverse #-} +-- Replicating ------------------------------------------------------------------------------------ +-- | Segmented replicate. +replicates + :: (Elem a, Build a) + => Array (Int, a) -> Array a + +replicates arr + = G.replicates A arr +{-# INLINE replicates #-} + + -- Mapping ---------------------------------------------------------------------------------------- -- | Apply a function to all the elements of a list. -map :: (Elem a, Build b bt) +map :: (Elem a, Build b) => (a -> b) -> Array a -> Array b map f arr = G.computeS A $! A.map f arr @@ -218,7 +311,7 @@ -- -- If the arrays don't have the same length then `Nothing`. -- -map2 :: (Elem a, Elem b, Build c ct) +map2 :: (Elem a, Elem b, Build c) => (a -> b -> c) -> Array a -> Array b -> Maybe (Array c) map2 f xs ys = liftM (G.computeS A) $! A.map2 f xs ys @@ -259,9 +352,9 @@ -- | Yield the product of the elements of an array. -prod :: (Elem a, Num a) => Array a -> a -prod = G.prod -{-# INLINE prod #-} +product :: (Elem a, Num a) => Array a -> a +product = G.product +{-# INLINE product #-} -- | Yield the mean value of the elements of an array. @@ -284,7 +377,7 @@ -- prefix is correlated. -- correlate - :: ( Elem a, Floating a) + :: (Elem a, Floating a) => Array a -> Array a -> a correlate = G.correlate {-# INLINE correlate #-} @@ -298,7 +391,7 @@ -- vector of segment lengths or elements was too short relative to the -- other. -- -folds :: (Elem a, Build n nt, Build b bt) +folds :: (Elem a, Build n, Build b) => (a -> b -> b) -- ^ Worker function. -> b -- ^ Initial state when folding segments. -> Array (n, Int) -- ^ Segment names and lengths. @@ -313,7 +406,7 @@ -- | Like `folds`, but take an initial state for the first segment. -- foldsWith - :: (Elem a, Build n nt, Build b bt) + :: (Elem a, Build n, Build b) => (a -> b -> b) -- ^ Worker function. -> b -- ^ Initial state when folding segments. -> Maybe (n, Int, b) -- ^ Name, length and initial state for first segment. @@ -328,7 +421,7 @@ -- Filtering -------------------------------------------------------------------------------------- -- | O(len src) Keep the elements of an array that match the given predicate. -filter :: Build a at +filter :: Build a => (a -> Bool) -> Array a -> Array a filter = G.filter A {-# INLINE filter #-} @@ -410,17 +503,18 @@ -- Sloshing --------------------------------------------------------------------------------------- -- | Concatenate nested arrays. -concat :: (Elem a, Build a at, F.Unpack (Array a) aat) +concat :: (Elem a, Build a) => Array (Array a) -- ^ Arrays to concatenate. -> Array a -concat = G.concat A -{-# INLINE concat #-} +concat arr + = (inline G.concat) A arr +{-# INLINABLE concat #-} -- | O(len result) Concatenate the elements of some nested vector, -- inserting a copy of the provided separator array between each element. concatWith - :: (Elem a, Build a at, F.Unpack (Array a) aat) + :: (Elem a, Build a) => Array a -- ^ Separator array. -> Array (Array a) -- ^ Arrays to concatenate. -> Array a @@ -445,8 +539,7 @@ -- | O(len result) Perform a `concatWith`, adding a newline character to -- the end of each inner array. -unlines :: F.Unpack (Array Char) aat - => Array (Array Char) -> Array Char +unlines :: Array (Array Char) -> Array Char unlines = G.unlines A {-# INLINE unlines #-} @@ -454,7 +547,7 @@ -- | O(len result) Insert a copy of the separator array between the elements of -- the second and concatenate the result. intercalate - :: (Elem a, Build a at, F.Unpack (Array a) aat) + :: (Elem a, Build a) => Array a -- ^ Separator array. -> Array (Array a) -- ^ Arrays to concatenate. -> Array a @@ -497,7 +590,7 @@ -- Merging ---------------------------------------------------------------------------------------- -- | Merge two sorted key-value streams. -merge :: (Ord k, Elem (k, a), Elem (k, b), Build (k, c) ct) +merge :: (Ord k, Elem (k, a), Elem (k, b), Build (k, c)) => (k -> a -> b -> c) -- ^ Combine two values with the same key. -> (k -> a -> c) -- ^ Handle a left value without a right value. -> (k -> b -> c) -- ^ Handle a right value without a left value. @@ -511,7 +604,7 @@ -- | Like `merge`, but only produce the elements where the worker functions -- return `Just`. mergeMaybe - :: (Ord k, Elem (k, a), Elem (k, b), Build (k, c) ct) + :: (Ord k, Elem (k, a), Elem (k, b), Build (k, c)) => (k -> a -> b -> Maybe c) -- ^ Combine two values with the same key. -> (k -> a -> Maybe c) -- ^ Handle a left value without a right value. -> (k -> b -> Maybe c) -- ^ Handle a right value without a left value. @@ -528,8 +621,8 @@ -- We walk over the stream front to back, maintaining an accumulator. -- At each point we can chose to emit an element (or not) -- -compact :: (Elem a, Build b bt) - => (s -> a -> (Maybe b, s)) +compact :: (Elem a, Build b) + => (s -> a -> (s, Maybe b)) -> s -> Array a -> Array b @@ -540,17 +633,28 @@ -- | Like `compact` but use the first value of the stream as the -- initial state, and add the final state to the end of the output. compactIn - :: Build a at - => (a -> a -> (Maybe a, a)) + :: Build a + => (a -> a -> (a, Maybe a)) -> Array a -> Array a compactIn = G.compactIn A {-# INLINE compactIn #-} +-- | Apply a generic stream process to an array. +process :: ( Build a, Build b, Elem b + , G.Target A.A b) + => (s -> a -> (s, Array b)) -- ^ Worker function + -> s -- ^ Initial state. + -> Array a -- ^ Input array. + -> (s, Array b) -- ^ Result state and array. +process = G.process A +{-# INLINE process #-} + + -- Inserting -------------------------------------------------------------------------------------- -- | Insert elements produced by the given function in to an array. -insert :: Build a at +insert :: Build a => (Int -> Maybe a) -> Array a -> Array a insert = G.insert A {-# INLINE insert #-} @@ -635,7 +739,7 @@ -- Grouping --------------------------------------------------------------------------------------- -- | From a stream of values which has consecutive runs of idential values, -- produce a stream of the lengths of these runs. -groups :: (Eq a, Build a at) +groups :: (Eq a, Build a) => Array a -- ^ Input elements. -> (Array (a, Int), Maybe (a, Int)) -- ^ Completed and final segment lengths. @@ -649,7 +753,7 @@ -- consecutive elements should be in the same group. -- Also take an initial starting group and count. groupsWith - :: Build a at + :: Build a => (a -> a -> Bool) -- ^ Comparison function. -> Maybe (a, Int) -- ^ Starting element and count. -> Array a -- ^ Input elements. diff --git a/Data/Repa/Array/Auto/Unpack.hs b/Data/Repa/Array/Auto/Unpack.hs deleted file mode 100644 --- a/Data/Repa/Array/Auto/Unpack.hs +++ /dev/null @@ -1,115 +0,0 @@ - -module Data.Repa.Array.Auto.Unpack - ( module Data.Repa.Convert.Format - , packForeign - , unpackForeign) -where -import Data.Repa.Array.Auto.Base as A -import Data.Repa.Array.Generic.Convert as A -import qualified Data.Repa.Array.Material.Auto as A -import qualified Data.Repa.Array.Material.Foreign as A -import qualified Data.Repa.Array.Internals.Target as A -import qualified Data.Repa.Array.Internals.Bulk as A -import Data.Repa.Convert.Format - -import Foreign.ForeignPtr -import Foreign.Ptr - -import System.IO.Unsafe -import Control.Monad -import Data.Word - -import qualified Data.Vector.Storable.Mutable as SM -#include "repa-array.h" - - ---------------------------------------------------------------------------------------------------- --- | Pack some array elements into a foreign buffer using the given binary --- format. -packForeign - :: (Packable format, A.Bulk A.A (Value format)) - => format -- ^ Binary format for each element. - -> Array (Value format) -- ^ Source elements. - -> Maybe (Array Word8) -- ^ Packed binary data. - -packForeign !format !arrElems - | Just rowSize <- fixedSize format - , lenElems <- A.length arrElems - , lenBytes <- rowSize * lenElems - - = unsafePerformIO - $ do - buf@(A.FBuffer mvec) :: A.Buffer A.F Word8 - <- A.unsafeNewBuffer (A.Foreign lenBytes) - - let (fptr, oStart, _) = SM.unsafeToForeignPtr mvec - - withForeignPtr fptr $ \ptr_ - -> do let ptr = plusPtr ptr_ oStart - - let loop !ixSrc !ixDst - | ixSrc >= lenElems - = return $ Just () - - | otherwise - = Data.Repa.Convert.Format.pack - (plusPtr ptr ixDst) format (A.index arrElems ixSrc) - $ \oElem -> loop (ixSrc + 1) (ixDst + oElem) - - mFinal <- loop 0 0 - case mFinal of - Nothing -> return Nothing - Just _ -> liftM (Just . A.convert) $ A.unsafeFreezeBuffer buf - - | otherwise - = Nothing -{-# INLINE_ARRAY packForeign #-} - - ---------------------------------------------------------------------------------------------------- --- | Unpack an array of elements from a foreign buffer into their standard --- in-memory representation. --- --- The binary format of the elements in the buffer is given by the --- format specififier, while the in-memory representation is chosen --- automagically based on the type of the elements. --- -unpackForeign - :: (Packable format, A.Target A.A (Value format)) - => format -- ^ Binary format for each element. - -> Array Word8 -- ^ Packed binary data. - -> Maybe (Array (Value format)) -- ^ Unpacked elements. - -unpackForeign !format !arrBytes - | Just rowSize <- fixedSize format - , lenBytes <- A.length arrBytes - , lenBytes `mod` rowSize == 0 - , lenElems <- lenBytes `div` rowSize - = unsafePerformIO - $ do - let (oStart, _, fptr :: ForeignPtr Word8) - = A.toForeignPtr $ A.convert arrBytes - - withForeignPtr fptr $ \ptr_ - -> do let ptr = plusPtr ptr_ oStart - buf <- A.unsafeNewBuffer (A.Auto lenElems) - - let loop !ixSrc !ixDst - | ixDst >= lenElems - = return $ Just ixSrc - - | otherwise - = Data.Repa.Convert.Format.unpack - (plusPtr ptr ixSrc) format - $ \(value, oElem) -> do - A.unsafeWriteBuffer buf ixDst value - loop (ixSrc + oElem) (ixDst + 1) - - mFinal <- loop 0 0 - case mFinal of - Nothing -> return Nothing - Just _ -> liftM Just $ A.unsafeFreezeBuffer buf - - | otherwise - = Nothing -{-# INLINE_ARRAY unpackForeign #-} diff --git a/Data/Repa/Array/Auto/XSV.hs b/Data/Repa/Array/Auto/XSV.hs new file mode 100644 --- /dev/null +++ b/Data/Repa/Array/Auto/XSV.hs @@ -0,0 +1,116 @@ + +module Data.Repa.Array.Auto.XSV + ( getArrayFromXSV, hGetArrayFromXSV + , putArrayAsXSV, hPutArrayAsXSV) +where +import Data.Repa.Array.Auto.IO +import Data.Repa.Array.Auto.Base +import Data.Repa.Array.Generic.Convert +import Data.Char +import qualified Data.Repa.Array.Material.Auto as A +import qualified Data.Repa.Array.Material.Nested as A +import qualified Data.Repa.Array.Meta as A +import qualified Data.Repa.Array.Generic as A +import qualified System.IO as S +import qualified System.FileLock as S + + +--------------------------------------------------------------------------------------------------- +-- | Read a XSV file as a nested array. +-- We get an array of rows:fields:characters. +getArrayFromXSV + :: Char -- ^ Field separator character, eg '|', ',' or '\t'. + -> FilePath -- ^ Source file handle. + -> IO (Array (Array (Array Char))) + +getArrayFromXSV !cSep !path + = S.withFileLock path S.Shared + $ \_lock -> do + h <- S.openFile path S.ReadMode + arr <- hGetArrayFromXSV cSep h + S.hClose h + return arr + + +-- | Read an XSV file as a nested array. +-- We get an array of rows:fields:characters. +hGetArrayFromXSV + :: Char -- ^ Field separator character, eg '|', ',' or '\t'. + -> S.Handle -- ^ Source file handle. + -> IO (Array (Array (Array Char))) + +hGetArrayFromXSV !cSep !hIn + = do + -- Find out how much data there is remaining in the file. + start <- S.hTell hIn + S.hSeek hIn S.SeekFromEnd 0 + end <- S.hTell hIn + let !len = end - start + S.hSeek hIn S.AbsoluteSeek start + + -- Read array as Word8s. + !arr8 <- hGetArray hIn (fromIntegral len) + + -- Rows are separated by new lines, + -- fields are separated by the given separator character. + let !nl = fromIntegral $ ord '\n' + let !nc = fromIntegral $ ord cSep + + -- Split XSV file into rows and fields. + -- Convert element data from Word8 to Char. + -- Chars take 4 bytes each, but are standard Haskell and pretty + -- print properly. We've done the dicing on the smaller Word8 + -- version, and now map across the elements vector in the array + -- to do the conversion. + let !arrChar + = A.mapElems + (A.mapElems (A.computeS A.F . A.map (chr . fromIntegral))) + (A.diceSep nc nl arr8) + + return $ convert arrChar + + +-------------------------------------------------------------------------------------------------- +-- | Write a nested array as an XSV file. +-- +-- The array contains rows:fields:characters. +putArrayAsXSV + :: Char -- ^ Separator character, eg '|', ',' or '\t' + -> FilePath -- ^ Source file handle. + -> Array (Array (Array Char)) -- ^ Array of row, field, character. + -> IO () + +putArrayAsXSV !cSep !path !arrChar + = S.withFileLock path S.Exclusive + $ \_lock -> do + h <- S.openFile path S.WriteMode + hPutArrayAsXSV cSep h arrChar + S.hClose h + + +-- | Write a nested array as an XSV file. +-- +-- The array contains rows:fields:characters. +hPutArrayAsXSV + :: Char -- ^ Separator character, eg '|', ',' or '\t' + -> S.Handle -- ^ Source file handle. + -> Array (Array (Array Char)) -- ^ Array of row, field, character. + -> IO () + +hPutArrayAsXSV !cSep !hOut !arrChar + = do + -- Concat result back into Word8s + let !arrC = A.fromList A.U [cSep] + let !arrNL = A.fromList A.U ['\n'] + + let !arrOut + = A.mapS A.A (fromIntegral . ord) + $ A.concat A.U + $ A.mapS A.B (\ arrFields + -> A.concat A.U $ A.fromList A.B + [ A.intercalate A.U arrC arrFields, arrNL]) + $ arrChar + + hPutArray hOut arrOut +{-# INLINE hPutArrayAsXSV #-} + diff --git a/Data/Repa/Array/Generic.hs b/Data/Repa/Array/Generic.hs --- a/Data/Repa/Array/Generic.hs +++ b/Data/Repa/Array/Generic.hs @@ -19,6 +19,7 @@ , Bulk (..), BulkI , (!) , length + , first, last -- * Array Computation , Load @@ -26,11 +27,20 @@ , computeS, computeIntoS -- * Operators + -- ** Construction + , empty + , singleton + , generateMaybeS, mapMaybeS + , generateEitherS, mapEitherS + -- ** Conversion , fromList, fromListInto , toList , convert, copy + -- ** Replicating + , replicates + -- ** Mapping , mapS, map2S @@ -42,6 +52,13 @@ , compact , compactIn + -- ** Processing + , process + + -- ** Unfolding + , unfolds + , StepUnfold (..) + -- ** Filtering , filter @@ -66,7 +83,7 @@ -- ** Folding -- *** Complete fold - , foldl, sum, prod, mean, std + , foldl, sum, product, mean, std , correlate -- *** Segmented fold @@ -75,25 +92,27 @@ , Folds(..) , FoldsDict) where -import Data.Repa.Array.Generic.Target as A import Data.Repa.Array.Generic.Load as A import Data.Repa.Array.Generic.Index as A import Data.Repa.Array.Meta as A import Data.Repa.Array.Internals.Bulk as A +import Data.Repa.Array.Internals.Target as A import Data.Repa.Array.Internals.Operator.Concat as A import Data.Repa.Array.Internals.Operator.Compact as A import Data.Repa.Array.Internals.Operator.Filter as A import Data.Repa.Array.Internals.Operator.Fold as A import Data.Repa.Array.Internals.Operator.Group as A -import Data.Repa.Array.Internals.Operator.Merge as A import Data.Repa.Array.Internals.Operator.Insert as A +import Data.Repa.Array.Internals.Operator.Merge as A +import Data.Repa.Array.Internals.Operator.Process as A import Data.Repa.Array.Internals.Operator.Reduce as A +import Data.Repa.Array.Internals.Operator.Replicate as A import qualified Data.Repa.Array.Generic.Convert as A import qualified Data.Vector.Fusion.Stream.Monadic as V import Control.Monad import Prelude hiding ( reverse, length, map, zipWith, concat, unlines - , foldl, sum + , foldl, sum, product, last , filter) #include "repa-array.h" diff --git a/Data/Repa/Array/Generic/Index.hs b/Data/Repa/Array/Generic/Index.hs --- a/Data/Repa/Array/Generic/Index.hs +++ b/Data/Repa/Array/Generic/Index.hs @@ -1,7 +1,7 @@ -- | Shapes and Indices module Data.Repa.Array.Generic.Index - ( -- * Shapes + ( -- * Shapes Shape (..) , inShape , showShape diff --git a/Data/Repa/Array/Generic/Slice.hs b/Data/Repa/Array/Generic/Slice.hs --- a/Data/Repa/Array/Generic/Slice.hs +++ b/Data/Repa/Array/Generic/Slice.hs @@ -1,82 +1,82 @@ -- | Index space transformation between arrays and slices. module Data.Repa.Array.Generic.Slice - ( All (..) - , Any (..) - , FullShape - , SliceShape - , Slice (..)) + ( All (..) + , Any (..) + , FullShape + , SliceShape + , Slice (..)) where import Data.Repa.Array.Generic.Index -import Prelude hiding (replicate, drop) +import Prelude hiding (replicate, drop) #include "repa-array.h" -- | Select all indices at a certain position. -data All = All +data All = All -- | Place holder for any possible shape. -data Any sh = Any +data Any sh = Any -- | Map a type of the index in the full shape, to the type of the index in the slice. type family FullShape ss -type instance FullShape Z = Z -type instance FullShape (Any sh) = sh -type instance FullShape (sl :. Int) = FullShape sl :. Int -type instance FullShape (sl :. All) = FullShape sl :. Int +type instance FullShape Z = Z +type instance FullShape (Any sh) = sh +type instance FullShape (sl :. Int) = FullShape sl :. Int +type instance FullShape (sl :. All) = FullShape sl :. Int -- | Map the type of an index in the slice, to the type of the index in the full shape. type family SliceShape ss -type instance SliceShape Z = Z -type instance SliceShape (Any sh) = sh -type instance SliceShape (sl :. Int) = SliceShape sl -type instance SliceShape (sl :. All) = SliceShape sl :. Int +type instance SliceShape Z = Z +type instance SliceShape (Any sh) = sh +type instance SliceShape (sl :. Int) = SliceShape sl +type instance SliceShape (sl :. All) = SliceShape sl :. Int -- | Class of index types that can map to slices. class Slice ss where - -- | Map an index of a full shape onto an index of some slice. - sliceOfFull :: ss -> FullShape ss -> SliceShape ss + -- | Map an index of a full shape onto an index of some slice. + sliceOfFull :: ss -> FullShape ss -> SliceShape ss - -- | Map an index of a slice onto an index of the full shape. - fullOfSlice :: ss -> SliceShape ss -> FullShape ss + -- | Map an index of a slice onto an index of the full shape. + fullOfSlice :: ss -> SliceShape ss -> FullShape ss instance Slice Z where - sliceOfFull _ _ = Z + sliceOfFull _ _ = Z {-# INLINE sliceOfFull #-} - fullOfSlice _ _ = Z + fullOfSlice _ _ = Z {-# INLINE fullOfSlice #-} instance Slice (Any sh) where - sliceOfFull _ sh = sh + sliceOfFull _ sh = sh {-# INLINE sliceOfFull #-} - fullOfSlice _ sh = sh + fullOfSlice _ sh = sh {-# INLINE fullOfSlice #-} instance Slice sl => Slice (sl :. Int) where - sliceOfFull (fsl :. _) (ssl :. _) - = sliceOfFull fsl ssl + sliceOfFull (fsl :. _) (ssl :. _) + = sliceOfFull fsl ssl {-# INLINE sliceOfFull #-} - fullOfSlice (fsl :. n) ssl - = fullOfSlice fsl ssl :. n + fullOfSlice (fsl :. n) ssl + = fullOfSlice fsl ssl :. n {-# INLINE fullOfSlice #-} instance Slice sl => Slice (sl :. All) where - sliceOfFull (fsl :. All) (ssl :. s) - = sliceOfFull fsl ssl :. s + sliceOfFull (fsl :. All) (ssl :. s) + = sliceOfFull fsl ssl :. s {-# INLINE sliceOfFull #-} - fullOfSlice (fsl :. All) (ssl :. s) - = fullOfSlice fsl ssl :. s + fullOfSlice (fsl :. All) (ssl :. s) + = fullOfSlice fsl ssl :. s {-# INLINE fullOfSlice #-} diff --git a/Data/Repa/Array/Generic/Target.hs b/Data/Repa/Array/Generic/Target.hs --- a/Data/Repa/Array/Generic/Target.hs +++ b/Data/Repa/Array/Generic/Target.hs @@ -1,9 +1,9 @@ module Data.Repa.Array.Generic.Target - ( -- * Array Targets - Target (..), TargetI - , fromList - , fromListInto) + ( Target (..), TargetI + , empty, singleton + , fromList, fromListInto + , generateMaybeS, mapMaybeS + , generateEitherS, mapEitherS) where import Data.Repa.Array.Internals.Target - diff --git a/Data/Repa/Array/Generic/Unpacks.hs b/Data/Repa/Array/Generic/Unpacks.hs new file mode 100644 --- /dev/null +++ b/Data/Repa/Array/Generic/Unpacks.hs @@ -0,0 +1,134 @@ + +module Data.Repa.Array.Generic.Unpacks + (unsafeUnpacksToBuffer) +where +import Data.Repa.Convert.Format +import Data.Repa.Array.Material.Foreign +import Data.Repa.Array.Internals.Target +import Data.Repa.Array.Internals.Layout + +import Data.IORef +import Data.Word +import qualified Foreign.ForeignPtr as F +import qualified Foreign.Ptr as F + + +-- | Given a buffer containing an encoded table where the values in each +-- column all have the same time, decode all the values from a single +-- column and write them to a buffer. +-- +-- For example, suppose we have a table as follows, where the rows are +-- separated by newline characters and the field separated by spaces. +-- +-- @ +-- RED 1.0 0.0 0.0 +-- GREEN 0.0 1.0 0.0 +-- BLUE 0.0 0.0 1.0 +-- CYAN 0.0 1.0 1.0 +-- @ +-- +-- To decode the second column use: +-- +-- * Format: DoubleAsc, as they are encoded doubles. +-- * Field separator: ' ' as the fields are separated by spaces. +-- * Starting offsets: [3, 21, 38, 55], which are the indices of the starting +-- character of each field in the second column. +-- * Ending offsets: [16, 34, 51, 68], which are the indices of the newline +-- characters. +-- * Destination buffer: an new buffer with at least as many elements as there +-- are lines in the input data. +-- +-- If the parse succeeds then the buffer containing the starting offets is +-- updated so each element is the index of the NEXT field in each column. +-- This allows the client to easilly decode the next column. +-- +-- If there was a parse error then this function returns a pair of the row +-- index and offset in the buffer of the field which could not be parsed. +-- +-- UNSAFE: Both the buffer containing ending offsets, and the destination +-- buffer must be at least as long as the buffer containing starting offsets +-- but this is not checked. If this is not true then the function will +-- will perform an out of bounds access. +-- +-- INLINE: This function is set to INLINE so that it will be specialised +-- at the call site for the given format. For standard formats it's better +-- to use the pre-specialised versions for Auto arrays. +-- +unsafeUnpacksToBuffer + :: forall format lStart lEnd lVal + . ( Unpackable format + , TargetI lStart Int + , TargetI lEnd Int + , TargetI lVal (Value format)) + => format -- ^ Format for each element. + -> Word8 -- ^ Field separator character. + -> Array F Word8 -- ^ Packed binary source data. + -> Buffer lStart Int -- ^ Starting offsets for fields. + -> Buffer lEnd Int -- ^ Ending offsets of rows. + -> Buffer lVal (Value format) -- ^ Destination buffer for parsed fields. + -> IO (Maybe (Int, Int)) -- ^ Nothing on successful parse. + +unsafeUnpacksToBuffer + format cTerm src + ixsStart ixsEnd + bufOut + = do + refError <- newIORef Nothing + loop refError 0 + readIORef refError + + where + -- Length of the column, in rows. + !lenColumn + = extent $ bufferLayout ixsStart + + -- Get unpack the starting pointer form the source buffer. + !(offSrc, _lenSrc, fptrSrc) + = toForeignPtr src + + -- Read all the fields of the column in turn. + loop refError ixField + | ixField >= lenColumn + = return () + + | otherwise + = F.withForeignPtr fptrSrc + $ \ptrSrc + -> do + -- Starting offset of field in source array. + ixStart <- unsafeReadBuffer ixsStart ixField + + -- Ending offset of row in source array. + ixEnd <- unsafeReadBuffer ixsEnd ixField + + -- Get a pointer to the field data in the source array. + let ptrStart + = F.plusPtr ptrSrc (offSrc + ixStart) + + -- Unpack a single field. + r <- unsafeRunUnpacker + (unpack format) + ptrStart + (ixEnd - ixStart + 1) + (== cTerm) + + case r of + -- The field didn't parse. + Nothing + -> writeIORef refError (Just (ixField, ixStart)) + + -- We parsed the field. + Just (x, ptrNext) + -> do + -- Update the starting offset for this field, + -- for when we read the next column. + let !ixStart' = ixStart + F.minusPtr ptrNext ptrStart + 1 + unsafeWriteBuffer ixsStart ixField ixStart' + + -- Write the read field value. + unsafeWriteBuffer bufOut ixField x + + -- Read the next field in the column. + loop refError (ixField + 1) +{-# INLINE unsafeUnpacksToBuffer #-} + diff --git a/Data/Repa/Array/Internals/Bulk.hs b/Data/Repa/Array/Internals/Bulk.hs --- a/Data/Repa/Array/Internals/Bulk.hs +++ b/Data/Repa/Array/Internals/Bulk.hs @@ -3,13 +3,14 @@ ( Bulk (..), BulkI , (!) , length + , first, last , toList , toLists , toListss) where import Data.Repa.Array.Internals.Shape import Data.Repa.Array.Internals.Layout -import Prelude hiding (length) +import Prelude hiding (length, last) #include "repa-array.h" @@ -47,6 +48,26 @@ => Array l a -> Int length !arr = size (extent (layout arr)) {-# INLINE_ARRAY length #-} + + +-- | O(1). Take the first element of an array, if there is one. +first :: BulkI l a + => Array l a -> Maybe a +first !arr + = if length arr >= 1 + then Just $ index arr 0 + else Nothing +{-# INLINE first #-} + + +-- O(1). Take the last element of an array, if there is one. +last :: BulkI l a + => Array l a -> Maybe a +last !arr + = if length arr >= 1 + then Just $ index arr (length arr - 1) + else Nothing +{-# INLINE last #-} -- Conversion ----------------------------------------------------------------- diff --git a/Data/Repa/Array/Internals/Operator/Compact.hs b/Data/Repa/Array/Internals/Operator/Compact.hs --- a/Data/Repa/Array/Internals/Operator/Compact.hs +++ b/Data/Repa/Array/Internals/Operator/Compact.hs @@ -1,25 +1,26 @@ +-- | Compacting operations on arrays. module Data.Repa.Array.Internals.Operator.Compact ( compact - , compactIn ) + , compactIn) where -import Data.Repa.Array.Internals.Layout as A -import Data.Repa.Array.Internals.Target as A -import Data.Repa.Array.Internals.Bulk as A -import Data.Repa.Eval.Stream as A -import Data.Repa.Fusion.Unpack as A -import Data.Repa.Stream as S +import Data.Repa.Array.Internals.Layout as A +import Data.Repa.Array.Internals.Target as A +import Data.Repa.Array.Internals.Bulk as A +import Data.Repa.Eval.Stream as A +import Data.Repa.Stream as S +import Prelude hiding (concat) #include "repa-array.h" -- | Combination of `fold` and `filter`. -- -- We walk over the stream front to back, maintaining an accumulator. --- At each point we can chose to emit an element (or not) -compact :: ( BulkI lSrc a, TargetI lDst b - , Unpack (Buffer lDst b) t0) +-- At each point we can chose to emit an element (or not). +-- +compact :: (BulkI lSrc a, TargetI lDst b) => Name lDst - -> (s -> a -> (Maybe b, s)) + -> (s -> a -> (s, Maybe b)) -> s -> Array lSrc a -> Array lDst b @@ -33,11 +34,11 @@ -- | Like `compact` but use the first value of the stream as the -- initial state, and add the final state to the end of the output. +-- compactIn - :: ( BulkI lSrc a, TargetI lDst a - , Unpack (Buffer lDst a) t0) + :: (BulkI lSrc a, TargetI lDst a) => Name lDst - -> (a -> a -> (Maybe a, a)) + -> (a -> a -> (a, Maybe a)) -> Array lSrc a -> Array lDst a @@ -46,5 +47,4 @@ $ S.compactInS f $ A.streamOfArray arr {-# INLINE_ARRAY compactIn #-} - diff --git a/Data/Repa/Array/Internals/Operator/Concat.hs b/Data/Repa/Array/Internals/Operator/Concat.hs --- a/Data/Repa/Array/Internals/Operator/Concat.hs +++ b/Data/Repa/Array/Internals/Operator/Concat.hs @@ -14,7 +14,6 @@ import Data.Repa.Array.Generic.Load as A import Data.Repa.Array.Internals.Target as A import Data.Repa.Array.Internals.Bulk as A -import qualified Data.Repa.Fusion.Unpack as Fusion import qualified Data.Vector.Unboxed as U import qualified Data.Vector.Fusion.Stream.Monadic as V import System.IO.Unsafe @@ -27,8 +26,7 @@ type ConcatDict lOut lIn tIn lDst a = ( BulkI lOut (Array lIn a) , BulkI lIn a - , TargetI lDst a - , Fusion.Unpack (Array lIn a) tIn) + , TargetI lDst a) --------------------------------------------------------------------------------------------------- @@ -45,7 +43,7 @@ => Name lDst -- ^ Layout for destination. -> Array lOut (Array lIn a) -- ^ Arrays to concatenate. -> Array lDst a -concat nDst vs +concat !nDst !vs | A.length vs == 0 = A.fromList nDst [] @@ -57,29 +55,42 @@ !buf <- unsafeGrowBuffer buf_ len let !iLenY = U.length lens - let loop_concat !iO !iY !row !iX !iLenX - | iX >= iLenX - = if iY >= iLenY - 1 - then return () - else let iY' = iY + 1 - row' = vs `index` iY' - iLenX' = A.length row' - in loop_concat iO iY' row' 0 iLenX' - - | otherwise - = do let x = row `index` iX - unsafeWriteBuffer buf iO x - loop_concat (iO + 1) iY row (iX + 1) iLenX - {-# INLINE_INNER loop_concat #-} - let !row0 = vs `index` 0 let !iLenX0 = A.length row0 - loop_concat 0 0 row0 0 iLenX0 + loop_concat vs row0 buf 0 0 0 iLenX0 iLenY unsafeFreezeBuffer buf {-# INLINE_ARRAY concat #-} +loop_concat + :: ConcatDict lOut lIn tIn lDst a + => Array lOut (Array lIn a) + -> Array lIn a + -> Buffer lDst a + -> Int + -> Int + -> Int + -> Int + -> Int + -> IO () + +loop_concat !arr !row !buf !iO !iY !iX !iLenX !iLenY + | iX >= iLenX + = if iY >= iLenY - 1 + then return () + else let !iY' = iY + 1 + !row' = arr `index` iY' + !iLenX' = A.length row' + in loop_concat arr row' buf iO iY' 0 iLenX' iLenY + + | otherwise + = do let x = row `index` iX + unsafeWriteBuffer buf iO x + loop_concat arr row buf (iO + 1) iY (iX + 1) iLenX iLenY +{-# INLINE [0] loop_concat #-} + + --------------------------------------------------------------------------------------------------- -- | O(len result) Concatenate the elements of some nested vector, -- inserting a copy of the provided separator array between each element. @@ -140,7 +151,7 @@ -- Keep copying the source row. | otherwise - -> do let !x = (Fusion.repack row0 row) `index` (I# iX) + -> do let !x = row `index` (I# iX) unsafeWriteBuffer buf (I# iO) x loop_concatWith sPEC 0# (iO +# 1#) iY row (iX +# 1#) iLenX iS @@ -158,7 +169,7 @@ let !iY' = iY +# 1# let !row' = vs `index` (I# iY') let !(I# iLenX') = A.length row' - loop_concatWith sPEC 0# iO iY' (Fusion.unpack row') 0# iLenX' 0# + loop_concatWith sPEC 0# iO iY' row' 0# iLenX' 0# -- Keep copying from the separator array. | otherwise @@ -168,7 +179,7 @@ -- First row. let !(I# iLenX0) = A.length row0 - loop_concatWith V.SPEC 0# 0# 0# (Fusion.unpack row0) 0# iLenX0 0# + loop_concatWith V.SPEC 0# 0# 0# row0 0# iLenX0 0# unsafeFreezeBuffer buf {-# INLINE_ARRAY concatWith #-} @@ -246,11 +257,11 @@ let !iY' = iY +# 1# let !row' = vs `index` (I# iY') let !(I# iLenX') = A.length row' - loop_intercalate sPEC iO' iY' (Fusion.unpack row') 0# iLenX' + loop_intercalate sPEC iO' iY' row' 0# iLenX' -- Keep copying a source element. | otherwise - = do let x = (Fusion.repack row0 row) `index` (I# iX) + = do let x = row `index` (I# iX) unsafeWriteBuffer buf (I# iO) x loop_intercalate sPEC (iO +# 1#) iY row (iX +# 1#) iLenX {-# INLINE_INNER loop_intercalate #-} @@ -265,7 +276,7 @@ {-# INLINE_INNER loop_intercalate_inject #-} let !(I# iLenX0) = A.length row0 - loop_intercalate V.SPEC 0# 0# (Fusion.unpack row0) 0# iLenX0 + loop_intercalate V.SPEC 0# 0# row0 0# iLenX0 unsafeFreezeBuffer buf {-# INLINE_ARRAY intercalate #-} diff --git a/Data/Repa/Array/Internals/Operator/Filter.hs b/Data/Repa/Array/Internals/Operator/Filter.hs --- a/Data/Repa/Array/Internals/Operator/Filter.hs +++ b/Data/Repa/Array/Internals/Operator/Filter.hs @@ -1,3 +1,4 @@ + -- | Filtering operators on arrays. module Data.Repa.Array.Internals.Operator.Filter ( filter) diff --git a/Data/Repa/Array/Internals/Operator/Fold.hs b/Data/Repa/Array/Internals/Operator/Fold.hs --- a/Data/Repa/Array/Internals/Operator/Fold.hs +++ b/Data/Repa/Array/Internals/Operator/Fold.hs @@ -1,6 +1,8 @@ +-- | Folding operations on arrays. module Data.Repa.Array.Internals.Operator.Fold - ( folds + ( -- * Segmented fold + folds , foldsWith , C.Folds(..), FoldsDict) where @@ -9,10 +11,10 @@ import Data.Repa.Array.Internals.Bulk as A import Data.Repa.Array.Internals.Target as A import Data.Repa.Eval.Chain as A -import Data.Repa.Fusion.Unpack as A -import qualified Data.Repa.Chain as C -import Data.Repa.Option +import Data.Repa.Scalar.Option import System.IO.Unsafe +import qualified Data.Repa.Chain as C +import Prelude hiding (foldl) #include "repa-array.h" @@ -44,7 +46,7 @@ folds nGrp nRes f z vLens vVals = foldsWith nGrp nRes f z Nothing vLens vVals -{-# INLINE folds #-} +{-# INLINE_ARRAY folds #-} -- | Like `folds`, but take an initial state for the first segment. @@ -93,6 +95,4 @@ , Bulk lElt a , Target lGrp n , Target lRes b - , Index lGrp ~ Index lRes - , Unpack (Buffer lGrp n) tGrp - , Unpack (Buffer lRes b) tRes) + , Index lGrp ~ Index lRes) diff --git a/Data/Repa/Array/Internals/Operator/Group.hs b/Data/Repa/Array/Internals/Operator/Group.hs --- a/Data/Repa/Array/Internals/Operator/Group.hs +++ b/Data/Repa/Array/Internals/Operator/Group.hs @@ -1,4 +1,5 @@ +-- | Grouping operations on arrays. module Data.Repa.Array.Internals.Operator.Group ( groups , groupsWith @@ -8,7 +9,6 @@ import Data.Repa.Array.Meta.Tuple as A import Data.Repa.Array.Internals.Bulk as A import Data.Repa.Array.Internals.Target as A -import Data.Repa.Fusion.Unpack as A import Data.Repa.Eval.Chain as A import qualified Data.Repa.Chain as C #include "repa-array.h" @@ -74,8 +74,6 @@ = ( Bulk lElt n , Target lGrp n , Target lLen Int - , Index lGrp ~ Index lLen - , Unpack (Buffer lLen Int) tLen - , Unpack (Buffer lGrp n) tGrp) + , Index lGrp ~ Index lLen) diff --git a/Data/Repa/Array/Internals/Operator/Insert.hs b/Data/Repa/Array/Internals/Operator/Insert.hs --- a/Data/Repa/Array/Internals/Operator/Insert.hs +++ b/Data/Repa/Array/Internals/Operator/Insert.hs @@ -1,4 +1,5 @@ +-- | Insertion operations on arrays. module Data.Repa.Array.Internals.Operator.Insert (insert) where @@ -6,15 +7,13 @@ import Data.Repa.Array.Meta.Tuple as A import Data.Repa.Array.Internals.Bulk as A import Data.Repa.Array.Internals.Target as A -import Data.Repa.Fusion.Unpack as A import Data.Repa.Eval.Stream as A import qualified Data.Repa.Stream as S #include "repa-array.h" -- | Insert elements produced by the given function in to an array. -insert :: ( BulkI lSrc a, TargetI lDst a - , Unpack (Buffer lDst a) t0) +insert :: (BulkI lSrc a, TargetI lDst a) => Name lDst -- ^ Name of destination layout. -> (Int -> Maybe a) -- ^ Produce an element for this index. -> Array lSrc a -- ^ Array of source elements. diff --git a/Data/Repa/Array/Internals/Operator/Merge.hs b/Data/Repa/Array/Internals/Operator/Merge.hs --- a/Data/Repa/Array/Internals/Operator/Merge.hs +++ b/Data/Repa/Array/Internals/Operator/Merge.hs @@ -1,4 +1,5 @@ +-- | Merge operations on arrays. module Data.Repa.Array.Internals.Operator.Merge ( merge , mergeMaybe) @@ -8,7 +9,6 @@ import Data.Repa.Array.Internals.Layout as A import Data.Repa.Stream as S import Data.Repa.Eval.Stream as A -import Data.Repa.Fusion.Unpack as A import qualified Data.Vector.Fusion.Stream as S #include "repa-array.h" @@ -16,8 +16,7 @@ -- | Merge two sorted key-value streams. merge :: ( Ord k , BulkI l1 (k, a), BulkI l2 (k, b) - , TargetI lDst (k, c) - , Unpack (Buffer lDst (k, c)) t0) + , TargetI lDst (k, c)) => Name lDst -- ^ Name of destination layout. -> (k -> a -> b -> c) -- ^ Combine two values with the same key. -> (k -> a -> c) -- ^ Handle a left value without a right value. @@ -39,8 +38,7 @@ mergeMaybe :: ( Ord k , BulkI l1 (k, a), BulkI l2 (k, b) - , TargetI lDst (k, c) - , Unpack (Buffer lDst (k, c)) t0) + , TargetI lDst (k, c)) => Name lDst -> (k -> a -> b -> Maybe c) -- ^ Combine two values with the same key. -> (k -> a -> Maybe c) -- ^ Handle a left value without a right value. diff --git a/Data/Repa/Array/Internals/Operator/Partition.hs b/Data/Repa/Array/Internals/Operator/Partition.hs --- a/Data/Repa/Array/Internals/Operator/Partition.hs +++ b/Data/Repa/Array/Internals/Operator/Partition.hs @@ -1,4 +1,5 @@ +-- | Partition operations on arrays. module Data.Repa.Array.Internals.Operator.Partition ( partition , partitionBy diff --git a/Data/Repa/Array/Internals/Operator/Process.hs b/Data/Repa/Array/Internals/Operator/Process.hs new file mode 100644 --- /dev/null +++ b/Data/Repa/Array/Internals/Operator/Process.hs @@ -0,0 +1,72 @@ + +module Data.Repa.Array.Internals.Operator.Process + ( process + , unfolds, StepUnfold (..)) +where +import Data.Repa.Array.Internals.Operator.Concat as A +import Data.Repa.Array.Internals.Layout as A +import Data.Repa.Array.Internals.Target as A +import Data.Repa.Array.Internals.Bulk as A +import Data.Repa.Chain as C +import Data.Repa.Eval.Chain as A +import Prelude hiding (concat) +#include "repa-array.h" + + +-- | Apply a generic stream process to an array. +-- +process :: ( BulkI lSrc a + , BulkI lDst b, Bulk lDst (Array lDst b) + , TargetI lDst b + , TargetI lDst (Array lDst b)) + => Name lDst -- ^ Name of destination layout. + -> (s -> a -> (s, Array lDst b)) -- ^ Worker function. + -> s -- ^ Initial state. + -> Array lSrc a -- ^ Input array. + -> (s, Array lDst b) -- ^ Result state and array. + +process nDst f s0 arr + = let + work_process s x + = case f s x of + (s', arr') -> return (s', Just arr') + {-# INLINE_ARRAY work_process #-} + + (arrs, (_, s2)) + = A.unchainToArray nDst + $ C.scanMaybeC work_process s0 + $ A.chainOfArray arr + + -- TODO: this concat here is a performance disaster. + -- Callers using 'process' should be rewritten to use 'unfolds' + in (s2, concat nDst arrs) +{-# INLINE_ARRAY process #-} + + + +-- | Apply a generic stream process to an array. +-- +unfolds :: ( BulkI lSrc a + , BulkI lDst b + , TargetI lDst b) + => Name lDst -- ^ Name of destination layout. + -> (a -> s -> (StepUnfold s b)) -- ^ Worker function. + -> s -- ^ Initial state. + -> Array lSrc a -- ^ Input array. + -> (s, Array lDst b) -- ^ Result state and array. + +unfolds nDst f s0 arr + = let + work_process xa s + = case f xa s of + mxb -> return mxb + {-# INLINE_ARRAY work_process #-} + + (arr', (_, s2, _)) + = A.unchainToArray nDst + $ C.unfoldsC work_process s0 + $ A.chainOfArray arr + + in (s2, arr') +{-# INLINE_ARRAY unfolds #-} + diff --git a/Data/Repa/Array/Internals/Operator/Reduce.hs b/Data/Repa/Array/Internals/Operator/Reduce.hs --- a/Data/Repa/Array/Internals/Operator/Reduce.hs +++ b/Data/Repa/Array/Internals/Operator/Reduce.hs @@ -1,9 +1,10 @@ +-- | Reduction operations on arrays. module Data.Repa.Array.Internals.Operator.Reduce ( foldl -- | Specialised reductions. - , prod, sum + , product, sum , mean, std , correlate) where @@ -14,7 +15,7 @@ import Data.Repa.Eval.Stream as A import qualified Data.Vector.Fusion.Stream as S import Prelude - as P hiding (foldl, sum) + as P hiding (foldl, sum, product) #include "repa-array.h" @@ -23,7 +24,7 @@ => (a -> b -> a) -> a -> Array l b -> a foldl f z arr - = S.foldl f z + = S.foldl' f z $ streamOfArray arr {-# INLINE_ARRAY foldl #-} @@ -35,9 +36,9 @@ -- | Yield the product of the elements of an array. -prod :: (BulkI l a, Num a) => Array l a -> a -prod arr = foldl (*) 1 arr -{-# INLINE prod #-} +product :: (BulkI l a, Num a) => Array l a -> a +product arr = foldl (*) 1 arr +{-# INLINE product #-} -- | Yield the mean value of the elements of an array. diff --git a/Data/Repa/Array/Internals/Operator/Replicate.hs b/Data/Repa/Array/Internals/Operator/Replicate.hs new file mode 100644 --- /dev/null +++ b/Data/Repa/Array/Internals/Operator/Replicate.hs @@ -0,0 +1,26 @@ + +-- | Replicate operations on arrays. +module Data.Repa.Array.Internals.Operator.Replicate + ( replicates ) +where +import Data.Repa.Array.Internals.Layout as A +import Data.Repa.Array.Internals.Target as A +import Data.Repa.Array.Internals.Bulk as A +import Data.Repa.Eval.Stream as A +import Data.Repa.Stream as S +#include "repa-array.h" + + +-- | Segmented replicate. +replicates + :: (BulkI lSrc (Int, a), TargetI lDst a) + => Name lDst + -> Array lSrc (Int, a) + -> Array lDst a + +replicates nDst arr + = A.unstreamToArray nDst + $ S.replicatesS + $ A.streamOfArray arr +{-# INLINE_ARRAY replicates #-} + diff --git a/Data/Repa/Array/Internals/Target.hs b/Data/Repa/Array/Internals/Target.hs --- a/Data/Repa/Array/Internals/Target.hs +++ b/Data/Repa/Array/Internals/Target.hs @@ -1,15 +1,23 @@ module Data.Repa.Array.Internals.Target - ( Target (..), TargetI - , fromList, fromListInto) + ( Target (..), TargetI + , empty, singleton + , fromList, fromListInto + , mapMaybeS, mapEitherS + , generateMaybeS, generateEitherS + , unfoldEitherOfLengthIO) where import Data.Repa.Array.Generic.Index as A import Data.Repa.Array.Internals.Bulk as A import System.IO.Unsafe import Control.Monad -import Prelude as P +import qualified Data.Vector.Fusion.Stream.Monadic as S +import Prelude hiding (length) +import qualified Prelude as P +#include "repa-array.h" + -- Target --------------------------------------------------------------------- -- | Class of manifest array representations that can be constructed -- in a random-access manner. @@ -69,6 +77,30 @@ ------------------------------------------------------------------------------- +-- | O(1). An empty array of the given layout. +empty :: TargetI l a + => Name l -> Array l a +empty nDst + = unsafePerformIO + $ do let lDst = create nDst 0 + buf <- unsafeNewBuffer lDst + unsafeFreezeBuffer buf +{-# INLINE_ARRAY empty #-} + + +-- | O(1). Create a new empty array containing a single element. +singleton + :: TargetI l a + => Name l -> a -> Array l a +singleton nDst x + = unsafePerformIO + $ do let lDst = create nDst 1 + buf <- unsafeNewBuffer lDst + unsafeWriteBuffer buf 0 x + unsafeFreezeBuffer buf +{-# INLINE_ARRAY singleton #-} + + -- | O(length src). Construct a linear array from a list of elements. fromList :: TargetI l a => Name l -> [a] -> Array l a @@ -94,9 +126,162 @@ if len /= size (extent lDst) then return Nothing else do - buf <- unsafeNewBuffer lDst + !buf <- unsafeNewBuffer lDst zipWithM_ (unsafeWriteBuffer buf) [0..] xx arr <- unsafeFreezeBuffer buf return $ Just arr {-# NOINLINE fromListInto #-} + + +------------------------------------------------------------------------------- +-- | Apply a function to every element of an array, +-- if any application returns `Nothing`, then `Nothing` for the whole result. +mapMaybeS + :: (BulkI lSrc a, TargetI lDst b) + => Name lDst + -> (a -> Maybe b) + -> Array lSrc a + -> Maybe (Array lDst b) + +mapMaybeS !nDst f arr + = generateMaybeS nDst (length arr) get_maybeS + where + get_maybeS ix + = f (index arr ix) + {-# INLINE get_maybeS #-} +{-# INLINE_ARRAY mapMaybeS #-} + + +-- | Apply a function to every element of an array, +-- if any application returns `Left`, then `Left` for the whole result. +mapEitherS + :: (BulkI lSrc a, TargetI lDst b) + => Name lDst + -> (a -> Either err b) + -> Array lSrc a + -> Either err (Array lDst b) + +mapEitherS !nDst f arr + = generateEitherS nDst (length arr) get_eitherS + where + get_eitherS ix + = f (index arr ix) + {-# INLINE get_eitherS #-} +{-# INLINE_ARRAY mapEitherS #-} + + +------------------------------------------------------------------------------- +-- | Generate an array of the given length by applying a function to +-- every index, sequentially. If any element returns `Nothing`, +-- then `Nothing` for the whole array. +generateMaybeS + :: TargetI l a + => Name l -> Int -> (Int -> Maybe a) + -> Maybe (Array l a) + +generateMaybeS !nDst !len get + = unsafePerformIO + $ do + let lDst = create nDst len + !buf <- unsafeNewBuffer lDst + + let fill_generateMaybeS !ix + | ix >= len + = return ix + + | otherwise + = case get ix of + Nothing + -> return ix + + Just x + -> do unsafeWriteBuffer buf ix $! x + fill_generateMaybeS (ix + 1) + {-# INLINE fill_generateMaybeS #-} + + !pos <- fill_generateMaybeS 0 + if pos < len + then return Nothing + else fmap Just $! unsafeFreezeBuffer buf +{-# INLINE_ARRAY generateMaybeS #-} + + +-- | Generate an array of the given length by applying a function to +-- every index, sequentially. If any element returns `Left`, +-- then `Left` for the whole array. +generateEitherS + :: TargetI l a + => Name l -> Int -> (Int -> Either err a) + -> Either err (Array l a) + +generateEitherS !nDst !len get + = unsafePerformIO + $ do + let lDst = create nDst len + !buf <- unsafeNewBuffer lDst + + let fill_generateEitherS !ix + | ix >= len + = return Nothing + + | otherwise + = case get ix of + Left err + -> return $ Just err + + Right x + -> do unsafeWriteBuffer buf ix $! x + fill_generateEitherS (ix + 1) + {-# INLINE fill_generateEitherS #-} + + !mErr <- fill_generateEitherS 0 + case mErr of + Just err -> return $ Left err + Nothing -> fmap Right $! unsafeFreezeBuffer buf +{-# INLINE_ARRAY generateEitherS #-} + + +--------------------------------------------------------------------------------------------------- +-- | Unfold a new array using the given length and worker function. +-- +-- This is like `generateEither`, except that an accumulator is +-- threaded sequentially through the elements. +-- +unfoldEitherOfLengthIO + :: TargetI l a + => Name l -- ^ Destination format. + -> Int -- ^ Length of array. + -> (Int -> acc -> IO (Either err (acc, a))) -- ^ Worker function. + -> acc -- ^ Starting accumluator + -> IO (Either err (acc, Array l a)) + +unfoldEitherOfLengthIO nDst len get acc0 + = do + let lDst = create nDst len + !buf <- unsafeNewBuffer lDst + + let fill_unfoldEither !sPEC !acc !ix + | ix >= len + = return $ Right acc + + | otherwise + = get ix acc >>= \r + -> case r of + Left err + -> return $ Left err + + Right (acc', x) + -> do unsafeWriteBuffer buf ix $! x + fill_unfoldEither sPEC acc' (ix + 1) + {-# INLINE_INNER fill_unfoldEither #-} + + eErr <- fill_unfoldEither S.SPEC acc0 0 + case eErr of + Left err + -> return $ Left err + + Right acc + -> do arr <- unsafeFreezeBuffer buf + return $ Right (acc, arr) +{-# INLINE_ARRAY unfoldEitherOfLengthIO #-} diff --git a/Data/Repa/Array/Material/Auto.hs b/Data/Repa/Array/Material/Auto.hs --- a/Data/Repa/Array/Material/Auto.hs +++ b/Data/Repa/Array/Material/Auto.hs @@ -3,10 +3,23 @@ ( A (..) , Name (..) , Array (..) - , Buffer (..)) + , Buffer (..) + + -- * Date utils + , rangeDate32) where import Data.Repa.Array.Material.Auto.Base +import Data.Repa.Array.Material.Auto.InstArray +import Data.Repa.Array.Material.Auto.InstBox +import Data.Repa.Array.Material.Auto.InstChar +import Data.Repa.Array.Material.Auto.InstDate32 import Data.Repa.Array.Material.Auto.InstFloat import Data.Repa.Array.Material.Auto.InstInt +import Data.Repa.Array.Material.Auto.InstList +import Data.Repa.Array.Material.Auto.InstMaybe +import Data.Repa.Array.Material.Auto.InstProduct +import Data.Repa.Array.Material.Auto.InstTuple +import Data.Repa.Array.Material.Auto.InstText +import Data.Repa.Array.Material.Auto.InstUnit import Data.Repa.Array.Material.Auto.InstWord import Data.Repa.Array.Internals.Target diff --git a/Data/Repa/Array/Material/Auto/Base.hs b/Data/Repa/Array/Material/Auto/Base.hs --- a/Data/Repa/Array/Material/Auto/Base.hs +++ b/Data/Repa/Array/Material/Auto/Base.hs @@ -5,20 +5,14 @@ , Array (..)) where import Data.Repa.Array.Meta.Tuple as A -import Data.Repa.Array.Meta.Window as A -import Data.Repa.Array.Generic.Convert as A -import Data.Repa.Array.Internals.Bulk as A -import Data.Repa.Array.Internals.Target as A import Data.Repa.Array.Internals.Layout as A import Data.Repa.Array.Material.Boxed as A import Data.Repa.Array.Material.Unboxed as A import Data.Repa.Array.Material.Foreign as A import Data.Repa.Array.Material.Nested as A -import Data.Repa.Fusion.Unpack as F -import Data.Repa.Product as B -import Control.Monad #include "repa-array.h" + -- | Arrays where the elements that are automatically layed out into some -- efficient runtime representation. -- @@ -48,436 +42,4 @@ deriving instance Eq (Name A) deriving instance Show (Name A) - - ----------------------------------------------------------------------------------------------- Char -instance Bulk A Char where - data Array A Char = AArray_Char !(Array F Char) - layout (AArray_Char arr) = Auto (A.length arr) - index (AArray_Char arr) ix = A.index arr ix - {-# INLINE_ARRAY layout #-} - {-# INLINE_ARRAY index #-} - - -deriving instance Show (Array A Char) - - -instance A.Convert F Char A Char where - convert arr = AArray_Char arr - - -instance A.Convert A Char F Char where - convert (AArray_Char arr) = arr - - -instance Windowable A Char where - window st len (AArray_Char arr) - = AArray_Char (window st len arr) - {-# INLINE_ARRAY window #-} - - -instance Unpack (Array F Char) t - => Unpack (Array A Char) t where - unpack (AArray_Char arr) = unpack arr - repack (AArray_Char x) arr = AArray_Char (repack x arr) - - -instance Target A Char where - data Buffer A Char - = ABuffer_Char !(Buffer F Char) - - unsafeNewBuffer (Auto len) - = liftM ABuffer_Char $ unsafeNewBuffer (Foreign len) - {-# INLINE_ARRAY unsafeNewBuffer #-} - - unsafeReadBuffer (ABuffer_Char arr) ix - = unsafeReadBuffer arr ix - {-# INLINE_ARRAY unsafeReadBuffer #-} - - unsafeWriteBuffer (ABuffer_Char arr) ix x - = unsafeWriteBuffer arr ix x - {-# INLINE_ARRAY unsafeWriteBuffer #-} - - unsafeGrowBuffer (ABuffer_Char arr) bump - = liftM ABuffer_Char $ unsafeGrowBuffer arr bump - {-# INLINE_ARRAY unsafeGrowBuffer #-} - - unsafeFreezeBuffer (ABuffer_Char arr) - = liftM AArray_Char $ unsafeFreezeBuffer arr - {-# INLINE_ARRAY unsafeFreezeBuffer #-} - - unsafeThawBuffer (AArray_Char arr) - = liftM ABuffer_Char $ unsafeThawBuffer arr - {-# INLINE_ARRAY unsafeThawBuffer #-} - - unsafeSliceBuffer st len (ABuffer_Char buf) - = liftM ABuffer_Char $ unsafeSliceBuffer st len buf - {-# INLINE_ARRAY unsafeSliceBuffer #-} - - touchBuffer (ABuffer_Char buf) - = touchBuffer buf - {-# INLINE_ARRAY touchBuffer #-} - - bufferLayout (ABuffer_Char buf) - = Auto $ A.extent $ bufferLayout buf - {-# INLINE_ARRAY bufferLayout #-} - - -instance (Unpack (Buffer F Char)) t - => (Unpack (Buffer A Char)) t where - unpack (ABuffer_Char buf) = unpack buf - repack (ABuffer_Char x) buf = ABuffer_Char (repack x buf) - {-# INLINE unpack #-} - {-# INLINE repack #-} - - -instance Eq (Array A Char) where - (==) (AArray_Char arr1) (AArray_Char arr2) = arr1 == arr2 - {-# INLINE (==) #-} - - ------------------------------------------------------------------------------------------------ (,) -instance (Bulk A a, Bulk A b) => Bulk A (a, b) where - data Array A (a, b) = AArray_T2 !(Array (T2 A A) (a, b)) - layout (AArray_T2 arr) = Auto (A.length arr) - index (AArray_T2 arr) ix = A.index arr ix - {-# INLINE_ARRAY layout #-} - {-# INLINE_ARRAY index #-} - - -deriving instance (Show (Array (T2 A A) (a, b))) - => Show (Array A (a, b)) - - -instance ( A.Convert A a1 A a2 - , A.Convert A b1 A b2) - => A.Convert (T2 A A) (a1, b1) A (a2, b2) where - convert (T2Array arrA arrB) - = AArray_T2 (T2Array (convert arrA) (convert arrB)) - {-# INLINE convert #-} - - -instance ( A.Convert A a1 A a2 - , A.Convert A b1 A b2) - => A.Convert A (a1, b1) (T2 A A) (a2, b2) where - convert (AArray_T2 (T2Array arrA arrB)) - = T2Array (convert arrA) (convert arrB) - {-# INLINE convert #-} - - -instance (Windowable A a, Windowable A b) - => Windowable A (a, b) where - window st len (AArray_T2 arr) - = AArray_T2 (window st len arr) - {-# INLINE_ARRAY window #-} - - -instance (Target A a, Target A b) - => Target A (a, b) where - data Buffer A (a, b) - = ABuffer_T2 !(Buffer (T2 A A) (a, b)) - - unsafeNewBuffer (Auto len) - = liftM ABuffer_T2 $ unsafeNewBuffer (Tup2 (Auto len) (Auto len)) - {-# INLINE_ARRAY unsafeNewBuffer #-} - - unsafeReadBuffer (ABuffer_T2 arr) ix - = unsafeReadBuffer arr ix - {-# INLINE_ARRAY unsafeReadBuffer #-} - - unsafeWriteBuffer (ABuffer_T2 arr) ix x - = unsafeWriteBuffer arr ix x - {-# INLINE_ARRAY unsafeWriteBuffer #-} - - unsafeGrowBuffer (ABuffer_T2 arr) bump - = liftM ABuffer_T2 $ unsafeGrowBuffer arr bump - {-# INLINE_ARRAY unsafeGrowBuffer #-} - - unsafeFreezeBuffer (ABuffer_T2 arr) - = liftM AArray_T2 $ unsafeFreezeBuffer arr - {-# INLINE_ARRAY unsafeFreezeBuffer #-} - - unsafeThawBuffer (AArray_T2 arr) - = liftM ABuffer_T2 $ unsafeThawBuffer arr - {-# INLINE_ARRAY unsafeThawBuffer #-} - - unsafeSliceBuffer st len (ABuffer_T2 buf) - = liftM ABuffer_T2 $ unsafeSliceBuffer st len buf - {-# INLINE_ARRAY unsafeSliceBuffer #-} - - touchBuffer (ABuffer_T2 buf) - = touchBuffer buf - {-# INLINE_ARRAY touchBuffer #-} - - bufferLayout (ABuffer_T2 buf) - = Auto $ A.extent $ bufferLayout buf - {-# INLINE_ARRAY bufferLayout #-} - - -instance Unpack (Buffer (T2 A A) (a, b)) t - => Unpack (Buffer A (a, b)) t where - unpack (ABuffer_T2 buf) = unpack buf - repack (ABuffer_T2 x) buf = ABuffer_T2 (repack x buf) - {-# INLINE unpack #-} - {-# INLINE repack #-} - - -instance Eq (Array (T2 A A) (a, b)) - => Eq (Array A (a, b)) where - (==) (AArray_T2 arr1) (AArray_T2 arr2) = arr1 == arr2 - {-# INLINE (==) #-} - - ------------------------------------------------------------------------------------------------ :*: -instance (Bulk A a, Bulk A b) => Bulk A (a :*: b) where - data Array A (a :*: b) = AArray_Prod !(Array A a) !(Array A b) - layout (AArray_Prod arrA _ ) = Auto (A.length arrA) - index (AArray_Prod arrA arrB) ix = A.index arrA ix :*: A.index arrB ix - {-# INLINE_ARRAY layout #-} - {-# INLINE_ARRAY index #-} - - -deriving instance (Show (Array A a), Show (Array A b)) - => Show (Array A (a :*: b)) - - -instance (Windowable A a, Windowable A b) - => Windowable A (a :*: b) where - window st len (AArray_Prod arrA arrB) - = AArray_Prod (window st len arrA) (window st len arrB) - {-# INLINE_ARRAY window #-} - - -instance (Target A a, Target A b) - => Target A (a :*: b) where - data Buffer A (a :*: b) - = ABuffer_Prod !(Buffer A a) !(Buffer A b) - - unsafeNewBuffer l - = liftM2 ABuffer_Prod (unsafeNewBuffer l) (unsafeNewBuffer l) - {-# INLINE_ARRAY unsafeNewBuffer #-} - - unsafeReadBuffer (ABuffer_Prod bufA bufB) ix - = do xA <- unsafeReadBuffer bufA ix - xB <- unsafeReadBuffer bufB ix - return (xA :*: xB) - {-# INLINE_ARRAY unsafeReadBuffer #-} - - unsafeWriteBuffer (ABuffer_Prod bufA bufB) ix (xA :*: xB) - = do unsafeWriteBuffer bufA ix xA - unsafeWriteBuffer bufB ix xB - {-# INLINE_ARRAY unsafeWriteBuffer #-} - - unsafeGrowBuffer (ABuffer_Prod bufA bufB) bump - = do bufA' <- unsafeGrowBuffer bufA bump - bufB' <- unsafeGrowBuffer bufB bump - return $ ABuffer_Prod bufA' bufB' - {-# INLINE_ARRAY unsafeGrowBuffer #-} - - unsafeFreezeBuffer (ABuffer_Prod bufA bufB) - = do arrA <- unsafeFreezeBuffer bufA - arrB <- unsafeFreezeBuffer bufB - return $ AArray_Prod arrA arrB - {-# INLINE_ARRAY unsafeFreezeBuffer #-} - - unsafeThawBuffer (AArray_Prod arrA arrB) - = do bufA <- unsafeThawBuffer arrA - bufB <- unsafeThawBuffer arrB - return $ ABuffer_Prod bufA bufB - {-# INLINE_ARRAY unsafeThawBuffer #-} - - unsafeSliceBuffer st len (ABuffer_Prod bufA bufB) - = do bufA' <- unsafeSliceBuffer st len bufA - bufB' <- unsafeSliceBuffer st len bufB - return $ ABuffer_Prod bufA' bufB' - {-# INLINE_ARRAY unsafeSliceBuffer #-} - - touchBuffer (ABuffer_Prod bufA bufB) - = do touchBuffer bufA - touchBuffer bufB - {-# INLINE_ARRAY touchBuffer #-} - - bufferLayout (ABuffer_Prod bufA _) - = bufferLayout bufA - {-# INLINE_ARRAY bufferLayout #-} - - -instance ( Unpack (Buffer A a) tA - , Unpack (Buffer A b) tB) - => Unpack (Buffer A (a :*: b)) (tA, tB) where - unpack (ABuffer_Prod bufA bufB) - = (unpack bufA, unpack bufB) - - repack (ABuffer_Prod xA xB) (bufA, bufB) - = ABuffer_Prod (repack xA bufA) (repack xB bufB) - {-# INLINE unpack #-} - {-# INLINE repack #-} - - -instance (Eq (Array A a), Eq (Array A b)) - => Eq (Array A (a :*: b)) where - (==) (AArray_Prod arrA1 arrA2) (AArray_Prod arrB1 arrB2) - = arrA1 == arrB1 && arrA2 == arrB2 - {-# INLINE (==) #-} - - ------------------------------------------------------------------------------------------------ [] -instance Bulk A a => Bulk A [a] where - data Array A [a] = AArray_List !(Array B [a]) - layout (AArray_List arr) = Auto (A.length arr) - index (AArray_List arr) ix = A.index arr ix - {-# INLINE_ARRAY layout #-} - {-# INLINE_ARRAY index #-} - -deriving instance Show a => Show (Array A [a]) - - -instance Bulk A a => Windowable A [a] where - window st len (AArray_List arr) - = AArray_List (window st len arr) - {-# INLINE_ARRAY window #-} - - -instance Target A [a] where - data Buffer A [a] - = ABuffer_List !(Buffer B [a]) - - unsafeNewBuffer (Auto len) - = liftM ABuffer_List $ unsafeNewBuffer (Boxed len) - {-# INLINE_ARRAY unsafeNewBuffer #-} - - unsafeReadBuffer (ABuffer_List arr) ix - = unsafeReadBuffer arr ix - {-# INLINE_ARRAY unsafeReadBuffer #-} - - unsafeWriteBuffer (ABuffer_List arr) ix x - = unsafeWriteBuffer arr ix x - {-# INLINE_ARRAY unsafeWriteBuffer #-} - - unsafeGrowBuffer (ABuffer_List arr) bump - = liftM ABuffer_List $ unsafeGrowBuffer arr bump - {-# INLINE_ARRAY unsafeGrowBuffer #-} - - unsafeFreezeBuffer (ABuffer_List arr) - = liftM AArray_List $ unsafeFreezeBuffer arr - {-# INLINE_ARRAY unsafeFreezeBuffer #-} - - unsafeThawBuffer (AArray_List arr) - = liftM ABuffer_List $ unsafeThawBuffer arr - {-# INLINE_ARRAY unsafeThawBuffer #-} - - unsafeSliceBuffer st len (ABuffer_List buf) - = liftM ABuffer_List $ unsafeSliceBuffer st len buf - {-# INLINE_ARRAY unsafeSliceBuffer #-} - - touchBuffer (ABuffer_List buf) - = touchBuffer buf - {-# INLINE_ARRAY touchBuffer #-} - - bufferLayout (ABuffer_List buf) - = Auto $ A.extent $ bufferLayout buf - {-# INLINE_ARRAY bufferLayout #-} - - -instance Unpack (Buffer A [a]) (Buffer A [a]) where - unpack buf = buf - repack _ buf = buf - {-# INLINE unpack #-} - {-# INLINE repack #-} - - -instance Eq a - => Eq (Array A [a]) where - (==) (AArray_List arr1) (AArray_List arr2) = arr1 == arr2 - {-# INLINE (==) #-} - - ---------------------------------------------------------------------------------------------- Array -instance (Bulk A a, Windowable r a, Index r ~ Int) - => Bulk A (Array r a) where - data Array A (Array r a) = AArray_Array !(Array N (Array r a)) - layout (AArray_Array arr) = Auto (A.length arr) - index (AArray_Array arr) ix = A.index arr ix - {-# INLINE_ARRAY layout #-} - {-# INLINE_ARRAY index #-} - -deriving instance Show (Array A a) => Show (Array A (Array A a)) - - -instance Convert r1 a1 r2 a2 - => Convert A (Array r1 a1) N (Array r2 a2) where - convert (AArray_Array (NArray starts lens arr)) - = NArray starts lens (convert arr) - {-# INLINE convert #-} - - -instance Convert r1 a1 r2 a2 - => Convert N (Array r1 a1) A (Array r2 a2) where - convert (NArray starts lens arr) - = AArray_Array (NArray starts lens (convert arr)) - {-# INLINE convert #-} - - -instance Convert r1 a1 r2 a2 - => Convert A (Array r1 a1) A (Array r2 a2) where - convert (AArray_Array (NArray starts lens arr)) - = AArray_Array (NArray starts lens (convert arr)) - {-# INLINE convert #-} - - -instance (Bulk l a, Target l a, Index l ~ Int) - => Target A (Array l a) where - data Buffer A (Array l a) - = ABuffer_Array !(Buffer N (Array l a)) - - unsafeNewBuffer (Auto len) - = liftM ABuffer_Array $ unsafeNewBuffer (Nested len) - {-# INLINE_ARRAY unsafeNewBuffer #-} - - unsafeReadBuffer (ABuffer_Array arr) ix - = unsafeReadBuffer arr ix - {-# INLINE_ARRAY unsafeReadBuffer #-} - - unsafeWriteBuffer (ABuffer_Array arr) ix x - = unsafeWriteBuffer arr ix x - {-# INLINE_ARRAY unsafeWriteBuffer #-} - - unsafeGrowBuffer (ABuffer_Array arr) bump - = liftM ABuffer_Array $ unsafeGrowBuffer arr bump - {-# INLINE_ARRAY unsafeGrowBuffer #-} - - unsafeFreezeBuffer (ABuffer_Array arr) - = liftM AArray_Array $ unsafeFreezeBuffer arr - {-# INLINE_ARRAY unsafeFreezeBuffer #-} - - unsafeThawBuffer (AArray_Array arr) - = liftM ABuffer_Array $ unsafeThawBuffer arr - {-# INLINE_ARRAY unsafeThawBuffer #-} - - unsafeSliceBuffer st len (ABuffer_Array buf) - = liftM ABuffer_Array $ unsafeSliceBuffer st len buf - {-# INLINE_ARRAY unsafeSliceBuffer #-} - - touchBuffer (ABuffer_Array buf) - = touchBuffer buf - {-# INLINE_ARRAY touchBuffer #-} - - bufferLayout (ABuffer_Array buf) - = Auto $ A.extent $ bufferLayout buf - {-# INLINE_ARRAY bufferLayout #-} - - -instance Unpack (Buffer N (Array l a)) t - => Unpack (Buffer A (Array l a)) t where - unpack (ABuffer_Array buf) = unpack buf - repack (ABuffer_Array x) buf = ABuffer_Array (repack x buf) - {-# INLINE unpack #-} - {-# INLINE repack #-} - - -instance (Bulk A a, Windowable l a, Index l ~ Int) - => Windowable A (Array l a) where - window st len (AArray_Array arr) - = AArray_Array (window st len arr) - {-# INLINE_ARRAY window #-} diff --git a/Data/Repa/Array/Material/Auto/InstArray.hs b/Data/Repa/Array/Material/Auto/InstArray.hs new file mode 100644 --- /dev/null +++ b/Data/Repa/Array/Material/Auto/InstArray.hs @@ -0,0 +1,116 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} +{-# LANGUAGE UndecidableInstances #-} +module Data.Repa.Array.Material.Auto.InstArray where +import Data.Repa.Array.Material.Auto.InstWord as A +import Data.Repa.Array.Material.Auto.Base as A +import Data.Repa.Array.Material.Boxed as A +import Data.Repa.Array.Material.Nested as A +import Data.Repa.Array.Material.Foreign as A +import Data.Repa.Array.Meta.Window as A +import Data.Repa.Array.Generic.Convert as A +import Data.Repa.Array.Internals.Layout as A +import Data.Repa.Array.Internals.Bulk as A +import Data.Repa.Array.Internals.Target as A +import qualified Data.Vector.Unboxed as U +import qualified Data.Vector as V +import qualified Data.ByteString.Internal as BS +import qualified Data.Text.Encoding as T +import Data.Text (Text) +import Control.Monad +import Data.Word +#include "repa-array.h" + + +instance (Bulk A a, A.Windowable r a, Index r ~ Int) + => Bulk A (Array r a) where + data Array A (Array r a) = AArray_Array !(Array N (Array r a)) + layout (AArray_Array arr) = Auto (A.length arr) + index (AArray_Array arr) ix = A.index arr ix + {-# INLINE_ARRAY layout #-} + {-# INLINE_ARRAY index #-} + +deriving instance Show (Array A a) => Show (Array A (Array A a)) + + +instance Convert r1 a1 r2 a2 + => Convert A (Array r1 a1) N (Array r2 a2) where + convert (AArray_Array (NArray starts lens arr)) + = NArray starts lens (convert arr) + {-# INLINE_ARRAY convert #-} + + +instance Convert r1 a1 r2 a2 + => Convert N (Array r1 a1) A (Array r2 a2) where + convert (NArray starts lens arr) + = AArray_Array (NArray starts lens (convert arr)) + {-# INLINE_ARRAY convert #-} + + +instance Convert r1 a1 r2 a2 + => Convert A (Array r1 a1) A (Array r2 a2) where + convert (AArray_Array (NArray starts lens arr)) + = AArray_Array (NArray starts lens (convert arr)) + {-# INLINE_ARRAY convert #-} + + +instance Convert A (Array A Word8) B Text where + convert (AArray_Array (NArray starts lens (AArray_Word8 farrElems))) + = let (BS.PS pElems iElems _nElems) + = toByteString farrElems + in BArray $ V.fromList + $ zipWith + (\start len -> T.decodeUtf8 + $ BS.PS pElems (iElems + start) len) + (U.toList starts) + (U.toList lens) + {-# INLINE_ARRAY convert #-} + + +instance (Bulk l a, A.Target l a, Index l ~ Int) + => A.Target A (Array l a) where + data Buffer A (Array l a) + = ABuffer_Array !(A.Buffer N (Array l a)) + + unsafeNewBuffer (Auto len) + = liftM ABuffer_Array $ unsafeNewBuffer (Nested len) + {-# INLINE_ARRAY unsafeNewBuffer #-} + + unsafeReadBuffer (ABuffer_Array arr) ix + = unsafeReadBuffer arr ix + {-# INLINE_ARRAY unsafeReadBuffer #-} + + unsafeWriteBuffer (ABuffer_Array arr) ix x + = unsafeWriteBuffer arr ix x + {-# INLINE_ARRAY unsafeWriteBuffer #-} + + unsafeGrowBuffer (ABuffer_Array arr) bump + = liftM ABuffer_Array $ unsafeGrowBuffer arr bump + {-# INLINE_ARRAY unsafeGrowBuffer #-} + + unsafeFreezeBuffer (ABuffer_Array arr) + = liftM AArray_Array $ unsafeFreezeBuffer arr + {-# INLINE_ARRAY unsafeFreezeBuffer #-} + + unsafeThawBuffer (AArray_Array arr) + = liftM ABuffer_Array $ unsafeThawBuffer arr + {-# INLINE_ARRAY unsafeThawBuffer #-} + + unsafeSliceBuffer st len (ABuffer_Array buf) + = liftM ABuffer_Array $ unsafeSliceBuffer st len buf + {-# INLINE_ARRAY unsafeSliceBuffer #-} + + touchBuffer (ABuffer_Array buf) + = touchBuffer buf + {-# INLINE_ARRAY touchBuffer #-} + + bufferLayout (ABuffer_Array buf) + = Auto $ A.extent $ bufferLayout buf + {-# INLINE_ARRAY bufferLayout #-} + + +instance (Bulk A a, Windowable l a, Index l ~ Int) + => Windowable A (Array l a) where + window st len (AArray_Array arr) + = AArray_Array (window st len arr) + {-# INLINE_ARRAY window #-} + diff --git a/Data/Repa/Array/Material/Auto/InstBox.hs b/Data/Repa/Array/Material/Auto/InstBox.hs new file mode 100644 --- /dev/null +++ b/Data/Repa/Array/Material/Auto/InstBox.hs @@ -0,0 +1,77 @@ +{-# LANGUAGE UndecidableInstances, IncoherentInstances #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +module Data.Repa.Array.Material.Auto.InstBox where +import Data.Repa.Array.Material.Auto.Base as A +import Data.Repa.Array.Material.Boxed as A +import Data.Repa.Array.Meta.Window as A +import Data.Repa.Array.Internals.Bulk as A +import Data.Repa.Array.Internals.Target as A +import Data.Repa.Array.Internals.Layout as A +import Data.Repa.Scalar.Box +import Control.Monad +#include "repa-array.h" + + +instance Bulk B a => Bulk A (Box a) where + data Array A (Box a) = AArray_Box !(Array B a) + layout (AArray_Box arr) = Auto (A.length arr) + index (AArray_Box arr) !ix = Box (A.index arr ix) + {-# INLINE_ARRAY layout #-} + {-# INLINE_ARRAY index #-} + +deriving instance Show a => Show (Array A (Box a)) + + +instance Bulk B a => Windowable A (Box a) where + window st len (AArray_Box arr) + = AArray_Box (window st len arr) + {-# INLINE_ARRAY window #-} + + +instance Target B a => Target A (Box a) where + data Buffer A (Box a) + = ABuffer_Box !(Buffer B a) + + unsafeNewBuffer (Auto len) + = liftM ABuffer_Box $ unsafeNewBuffer (Boxed len) + {-# INLINE_ARRAY unsafeNewBuffer #-} + + unsafeReadBuffer (ABuffer_Box arr) ix + = do x <- unsafeReadBuffer arr ix + return $ Box x + {-# INLINE_ARRAY unsafeReadBuffer #-} + + unsafeWriteBuffer (ABuffer_Box arr) ix (Box x) + = x `seq` unsafeWriteBuffer arr ix x + {-# INLINE_ARRAY unsafeWriteBuffer #-} + + unsafeGrowBuffer (ABuffer_Box arr) bump + = liftM ABuffer_Box $ unsafeGrowBuffer arr bump + {-# INLINE_ARRAY unsafeGrowBuffer #-} + + unsafeFreezeBuffer (ABuffer_Box arr) + = liftM AArray_Box $ unsafeFreezeBuffer arr + {-# INLINE_ARRAY unsafeFreezeBuffer #-} + + unsafeThawBuffer (AArray_Box arr) + = liftM ABuffer_Box $ unsafeThawBuffer arr + {-# INLINE_ARRAY unsafeThawBuffer #-} + + unsafeSliceBuffer st len (ABuffer_Box buf) + = liftM ABuffer_Box $ unsafeSliceBuffer st len buf + {-# INLINE_ARRAY unsafeSliceBuffer #-} + + touchBuffer (ABuffer_Box buf) + = touchBuffer buf + {-# INLINE_ARRAY touchBuffer #-} + + bufferLayout (ABuffer_Box buf) + = Auto $ A.extent $ bufferLayout buf + {-# INLINE_ARRAY bufferLayout #-} + + +instance Eq a + => Eq (Array A (Box a)) where + (==) (AArray_Box arr1) (AArray_Box arr2) = arr1 == arr2 + {-# INLINE_ARRAY (==) #-} + diff --git a/Data/Repa/Array/Material/Auto/InstChar.hs b/Data/Repa/Array/Material/Auto/InstChar.hs new file mode 100644 --- /dev/null +++ b/Data/Repa/Array/Material/Auto/InstChar.hs @@ -0,0 +1,87 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} +{-# LANGUAGE UndecidableInstances #-} +module Data.Repa.Array.Material.Auto.InstChar where +import Data.Repa.Array.Material.Auto.Base as A +import Data.Repa.Array.Material.Boxed as A +import Data.Repa.Array.Material.Foreign as A +import Data.Repa.Array.Meta.Window as A +import Data.Repa.Array.Generic.Convert as A +import Data.Repa.Array.Internals.Layout as A +import Data.Repa.Array.Internals.Bulk as A +import Data.Repa.Array.Internals.Target as A +import Control.Monad +#include "repa-array.h" + + +instance Bulk A Char where + data Array A Char = AArray_Char !(Array F Char) + layout (AArray_Char arr) = Auto (A.length arr) + index (AArray_Char arr) ix = A.index arr ix + {-# INLINE_ARRAY layout #-} + {-# INLINE_ARRAY index #-} + + +deriving instance Show (Array A Char) + + +instance A.Convert F Char A Char where + convert arr = AArray_Char arr + {-# INLINE_ARRAY convert #-} + + +instance A.Convert A Char F Char where + convert (AArray_Char arr) = arr + {-# INLINE_ARRAY convert #-} + + +instance Windowable A Char where + window st len (AArray_Char arr) + = AArray_Char (window st len arr) + {-# INLINE_ARRAY window #-} + + +instance Target A Char where + data Buffer A Char + = ABuffer_Char !(Buffer F Char) + + unsafeNewBuffer (Auto len) + = liftM ABuffer_Char $ unsafeNewBuffer (Foreign len) + {-# INLINE_ARRAY unsafeNewBuffer #-} + + unsafeReadBuffer (ABuffer_Char arr) ix + = unsafeReadBuffer arr ix + {-# INLINE_ARRAY unsafeReadBuffer #-} + + unsafeWriteBuffer (ABuffer_Char arr) ix x + = unsafeWriteBuffer arr ix x + {-# INLINE_ARRAY unsafeWriteBuffer #-} + + unsafeGrowBuffer (ABuffer_Char arr) bump + = liftM ABuffer_Char $ unsafeGrowBuffer arr bump + {-# INLINE_ARRAY unsafeGrowBuffer #-} + + unsafeFreezeBuffer (ABuffer_Char arr) + = liftM AArray_Char $ unsafeFreezeBuffer arr + {-# INLINE_ARRAY unsafeFreezeBuffer #-} + + unsafeThawBuffer (AArray_Char arr) + = liftM ABuffer_Char $ unsafeThawBuffer arr + {-# INLINE_ARRAY unsafeThawBuffer #-} + + unsafeSliceBuffer st len (ABuffer_Char buf) + = liftM ABuffer_Char $ unsafeSliceBuffer st len buf + {-# INLINE_ARRAY unsafeSliceBuffer #-} + + touchBuffer (ABuffer_Char buf) + = touchBuffer buf + {-# INLINE_ARRAY touchBuffer #-} + + bufferLayout (ABuffer_Char buf) + = Auto $ A.extent $ bufferLayout buf + {-# INLINE_ARRAY bufferLayout #-} + + +instance Eq (Array A Char) where + (==) (AArray_Char arr1) (AArray_Char arr2) = arr1 == arr2 + {-# INLINE_ARRAY (==) #-} + diff --git a/Data/Repa/Array/Material/Auto/InstDate32.hs b/Data/Repa/Array/Material/Auto/InstDate32.hs new file mode 100644 --- /dev/null +++ b/Data/Repa/Array/Material/Auto/InstDate32.hs @@ -0,0 +1,90 @@ +{-# LANGUAGE UndecidableInstances #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +module Data.Repa.Array.Material.Auto.InstDate32 + (rangeDate32) +where +import Data.Repa.Array.Material.Auto.InstChar () +import qualified Data.Repa.Array.Material.Auto.Base as A +import qualified Data.Repa.Array.Material.Foreign as A +import qualified Data.Repa.Array.Internals.Target as A +import qualified Data.Repa.Array.Generic.Index as A +import qualified Data.Repa.Array.Generic as A +import qualified Data.Repa.Array.Meta.Window as A +import Data.Repa.Scalar.Date32 +import Control.Monad +import Prelude as P +#include "repa-array.h" + + +instance A.Bulk A.A Date32 where + data Array A.A Date32 = AArray_Date32 !(A.Array A.F Date32) + layout (AArray_Date32 arr) = A.Auto (A.length arr) + index (AArray_Date32 arr) ix = A.index arr ix + {-# INLINE_ARRAY layout #-} + {-# INLINE_ARRAY index #-} + +deriving instance Show (A.Array A.A Date32) + + +instance A.Windowable A.A Date32 where + window st len (AArray_Date32 arr) + = AArray_Date32 (A.window st len arr) + {-# INLINE_ARRAY window #-} + + +instance A.Target A.A Date32 where + data Buffer A.A Date32 + = ABuffer_Date32 !(A.Buffer A.F Date32) + + unsafeNewBuffer (A.Auto len) + = liftM ABuffer_Date32 $ A.unsafeNewBuffer (A.Foreign len) + {-# INLINE_ARRAY unsafeNewBuffer #-} + + unsafeReadBuffer (ABuffer_Date32 arr) ix + = A.unsafeReadBuffer arr ix + {-# INLINE_ARRAY unsafeReadBuffer #-} + + unsafeWriteBuffer (ABuffer_Date32 arr) ix x + = A.unsafeWriteBuffer arr ix x + {-# INLINE_ARRAY unsafeWriteBuffer #-} + + unsafeGrowBuffer (ABuffer_Date32 arr) bump + = liftM ABuffer_Date32 $ A.unsafeGrowBuffer arr bump + {-# INLINE_ARRAY unsafeGrowBuffer #-} + + unsafeFreezeBuffer (ABuffer_Date32 arr) + = liftM AArray_Date32 $ A.unsafeFreezeBuffer arr + {-# INLINE_ARRAY unsafeFreezeBuffer #-} + + unsafeThawBuffer (AArray_Date32 arr) + = liftM ABuffer_Date32 $ A.unsafeThawBuffer arr + {-# INLINE_ARRAY unsafeThawBuffer #-} + + unsafeSliceBuffer st len (ABuffer_Date32 buf) + = liftM ABuffer_Date32 $ A.unsafeSliceBuffer st len buf + {-# INLINE_ARRAY unsafeSliceBuffer #-} + + touchBuffer (ABuffer_Date32 buf) + = A.touchBuffer buf + {-# INLINE_ARRAY touchBuffer #-} + + bufferLayout (ABuffer_Date32 buf) + = A.Auto $ A.extent $ A.bufferLayout buf + {-# INLINE_ARRAY bufferLayout #-} + + +--------------------------------------------------------------------------------------------------- +-- | Yield an array containing a range of dates, inclusive of the end points. +--- +-- TODO: avoid going via lists. +-- +rangeDate32 :: Date32 -> Date32 -> A.Array A.A Date32 +rangeDate32 from to + | to < from = A.fromList A.A [] + | otherwise = A.fromList A.A $ go [] from + where + go !acc !d + | d > to = P.reverse acc + | otherwise = go (d : acc) (next d) +{-# NOINLINE rangeDate32 #-} + diff --git a/Data/Repa/Array/Material/Auto/InstFloat.hs b/Data/Repa/Array/Material/Auto/InstFloat.hs --- a/Data/Repa/Array/Material/Auto/InstFloat.hs +++ b/Data/Repa/Array/Material/Auto/InstFloat.hs @@ -10,7 +10,6 @@ import Data.Repa.Array.Internals.Bulk as A import Data.Repa.Array.Internals.Target as A import Data.Repa.Array.Internals.Layout as A -import Data.Repa.Fusion.Unpack as F import Control.Monad #include "repa-array.h" @@ -26,9 +25,11 @@ instance Convert F Float A Float where convert arr = AArray_Float arr + {-# INLINE_ARRAY convert #-} instance Convert A Float F Float where convert (AArray_Float arr) = arr + {-# INLINE_ARRAY convert #-} instance Windowable A Float where window st len (AArray_Float arr) @@ -76,14 +77,6 @@ {-# INLINE_ARRAY bufferLayout #-} -instance (Unpack (Buffer F Float)) t - => (Unpack (Buffer A Float)) t where - unpack (ABuffer_Float buf) = unpack buf - repack (ABuffer_Float x) buf = ABuffer_Float (repack x buf) - {-# INLINE unpack #-} - {-# INLINE repack #-} - - -------------------------------------------------------------------------------------------- Double instance Bulk A Double where data Array A Double = AArray_Double !(Array F Double) @@ -96,9 +89,11 @@ instance Convert F Double A Double where convert arr = AArray_Double arr + {-# INLINE_ARRAY convert #-} instance Convert A Double F Double where convert (AArray_Double arr) = arr + {-# INLINE_ARRAY convert #-} instance Windowable A Double where window st len (AArray_Double arr) @@ -145,10 +140,3 @@ = Auto $ A.extent $ bufferLayout buf {-# INLINE_ARRAY bufferLayout #-} - -instance (Unpack (Buffer F Double)) t - => (Unpack (Buffer A Double)) t where - unpack (ABuffer_Double buf) = unpack buf - repack (ABuffer_Double x) buf = ABuffer_Double (repack x buf) - {-# INLINE unpack #-} - {-# INLINE repack #-} diff --git a/Data/Repa/Array/Material/Auto/InstInt.hs b/Data/Repa/Array/Material/Auto/InstInt.hs --- a/Data/Repa/Array/Material/Auto/InstInt.hs +++ b/Data/Repa/Array/Material/Auto/InstInt.hs @@ -10,7 +10,6 @@ import Data.Repa.Array.Internals.Bulk as A import Data.Repa.Array.Internals.Target as A import Data.Repa.Array.Internals.Layout as A -import Data.Repa.Fusion.Unpack as F import Data.Int import Control.Monad #include "repa-array.h" @@ -28,9 +27,11 @@ instance Convert F Int A Int where convert arr = AArray_Int arr + {-# INLINE_ARRAY convert #-} instance Convert A Int F Int where convert (AArray_Int arr) = arr + {-# INLINE_ARRAY convert #-} instance Windowable A Int where window st len (AArray_Int arr) @@ -78,14 +79,6 @@ {-# INLINE_ARRAY bufferLayout #-} -instance (Unpack (Buffer F Int)) t - => (Unpack (Buffer A Int)) t where - unpack (ABuffer_Int buf) = unpack buf - repack (ABuffer_Int x) buf = ABuffer_Int (repack x buf) - {-# INLINE unpack #-} - {-# INLINE repack #-} - - --------------------------------------------------------------------------------------------- Int8 instance Bulk A Int8 where data Array A Int8 = AArray_Int8 !(Array F Int8) @@ -98,9 +91,11 @@ instance Convert F Int8 A Int8 where convert arr = AArray_Int8 arr + {-# INLINE_ARRAY convert #-} instance Convert A Int8 F Int8 where convert (AArray_Int8 arr) = arr + {-# INLINE_ARRAY convert #-} instance Windowable A Int8 where window st len (AArray_Int8 arr) @@ -148,14 +143,6 @@ {-# INLINE_ARRAY bufferLayout #-} -instance (Unpack (Buffer F Int8)) t - => (Unpack (Buffer A Int8)) t where - unpack (ABuffer_Int8 buf) = unpack buf - repack (ABuffer_Int8 x) buf = ABuffer_Int8 (repack x buf) - {-# INLINE unpack #-} - {-# INLINE repack #-} - - --------------------------------------------------------------------------------------------- Int16 instance Bulk A Int16 where data Array A Int16 = AArray_Int16 !(Array F Int16) @@ -168,9 +155,11 @@ instance Convert F Int16 A Int16 where convert arr = AArray_Int16 arr + {-# INLINE_ARRAY convert #-} instance Convert A Int16 F Int16 where convert (AArray_Int16 arr) = arr + {-# INLINE_ARRAY convert #-} instance Windowable A Int16 where window st len (AArray_Int16 arr) @@ -218,14 +207,6 @@ {-# INLINE_ARRAY bufferLayout #-} -instance (Unpack (Buffer F Int16)) t - => (Unpack (Buffer A Int16)) t where - unpack (ABuffer_Int16 buf) = unpack buf - repack (ABuffer_Int16 x) buf = ABuffer_Int16 (repack x buf) - {-# INLINE unpack #-} - {-# INLINE repack #-} - - --------------------------------------------------------------------------------------------- Int32 instance Bulk A Int32 where data Array A Int32 = AArray_Int32 !(Array F Int32) @@ -238,9 +219,11 @@ instance Convert F Int32 A Int32 where convert arr = AArray_Int32 arr + {-# INLINE_ARRAY convert #-} instance Convert A Int32 F Int32 where convert (AArray_Int32 arr) = arr + {-# INLINE_ARRAY convert #-} instance Windowable A Int32 where window st len (AArray_Int32 arr) @@ -288,14 +271,6 @@ {-# INLINE_ARRAY bufferLayout #-} -instance (Unpack (Buffer F Int32)) t - => (Unpack (Buffer A Int32)) t where - unpack (ABuffer_Int32 buf) = unpack buf - repack (ABuffer_Int32 x) buf = ABuffer_Int32 (repack x buf) - {-# INLINE unpack #-} - {-# INLINE repack #-} - - --------------------------------------------------------------------------------------------- Int64 instance Bulk A Int64 where data Array A Int64 = AArray_Int64 !(Array F Int64) @@ -308,9 +283,11 @@ instance Convert F Int64 A Int64 where convert arr = AArray_Int64 arr + {-# INLINE_ARRAY convert #-} instance Convert A Int64 F Int64 where convert (AArray_Int64 arr) = arr + {-# INLINE_ARRAY convert #-} instance Windowable A Int64 where window st len (AArray_Int64 arr) @@ -356,12 +333,4 @@ bufferLayout (ABuffer_Int64 buf) = Auto $ A.extent $ bufferLayout buf {-# INLINE_ARRAY bufferLayout #-} - - -instance (Unpack (Buffer F Int64)) t - => (Unpack (Buffer A Int64)) t where - unpack (ABuffer_Int64 buf) = unpack buf - repack (ABuffer_Int64 x) buf = ABuffer_Int64 (repack x buf) - {-# INLINE unpack #-} - {-# INLINE repack #-} diff --git a/Data/Repa/Array/Material/Auto/InstList.hs b/Data/Repa/Array/Material/Auto/InstList.hs new file mode 100644 --- /dev/null +++ b/Data/Repa/Array/Material/Auto/InstList.hs @@ -0,0 +1,81 @@ +{-# LANGUAGE UndecidableInstances, IncoherentInstances #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +module Data.Repa.Array.Material.Auto.InstList + ( A (..) + , Name (..) + , Array (..)) +where +import Data.Repa.Array.Material.Auto.Base as A +import Data.Repa.Array.Material.Boxed as A +import Data.Repa.Array.Meta.Window as A +import Data.Repa.Array.Internals.Bulk as A +import Data.Repa.Array.Internals.Target as A +import Data.Repa.Array.Internals.Layout as A +import Control.Monad +#include "repa-array.h" + + +----------------------------------------------------------------------------------------------- [] +instance Bulk A a => Bulk A [a] where + data Array A [a] = AArray_List !(Array B [a]) + layout (AArray_List arr) = Auto (A.length arr) + index (AArray_List arr) ix = A.index arr ix + {-# INLINE_ARRAY layout #-} + {-# INLINE_ARRAY index #-} + +deriving instance Show a => Show (Array A [a]) + + +instance Bulk A a => Windowable A [a] where + window st len (AArray_List arr) + = AArray_List (window st len arr) + {-# INLINE_ARRAY window #-} + + +instance Target A [a] where + data Buffer A [a] + = ABuffer_List !(Buffer B [a]) + + unsafeNewBuffer (Auto len) + = liftM ABuffer_List $ unsafeNewBuffer (Boxed len) + {-# INLINE_ARRAY unsafeNewBuffer #-} + + unsafeReadBuffer (ABuffer_List arr) ix + = unsafeReadBuffer arr ix + {-# INLINE_ARRAY unsafeReadBuffer #-} + + unsafeWriteBuffer (ABuffer_List arr) ix x + = unsafeWriteBuffer arr ix x + {-# INLINE_ARRAY unsafeWriteBuffer #-} + + unsafeGrowBuffer (ABuffer_List arr) bump + = liftM ABuffer_List $ unsafeGrowBuffer arr bump + {-# INLINE_ARRAY unsafeGrowBuffer #-} + + unsafeFreezeBuffer (ABuffer_List arr) + = liftM AArray_List $ unsafeFreezeBuffer arr + {-# INLINE_ARRAY unsafeFreezeBuffer #-} + + unsafeThawBuffer (AArray_List arr) + = liftM ABuffer_List $ unsafeThawBuffer arr + {-# INLINE_ARRAY unsafeThawBuffer #-} + + unsafeSliceBuffer st len (ABuffer_List buf) + = liftM ABuffer_List $ unsafeSliceBuffer st len buf + {-# INLINE_ARRAY unsafeSliceBuffer #-} + + touchBuffer (ABuffer_List buf) + = touchBuffer buf + {-# INLINE_ARRAY touchBuffer #-} + + bufferLayout (ABuffer_List buf) + = Auto $ A.extent $ bufferLayout buf + {-# INLINE_ARRAY bufferLayout #-} + + +instance Eq a + => Eq (Array A [a]) where + (==) (AArray_List arr1) (AArray_List arr2) = arr1 == arr2 + {-# INLINE (==) #-} + + diff --git a/Data/Repa/Array/Material/Auto/InstMaybe.hs b/Data/Repa/Array/Material/Auto/InstMaybe.hs new file mode 100644 --- /dev/null +++ b/Data/Repa/Array/Material/Auto/InstMaybe.hs @@ -0,0 +1,85 @@ +{-# LANGUAGE UndecidableInstances, IncoherentInstances #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +module Data.Repa.Array.Material.Auto.InstMaybe + ( A (..) + , Name (..) + , Array (..)) +where +import Data.Repa.Array.Material.Auto.Base as A +import Data.Repa.Array.Material.Boxed as A +import Data.Repa.Array.Meta.Window as A +import Data.Repa.Array.Internals.Bulk as A +import Data.Repa.Array.Internals.Target as A +import Data.Repa.Array.Internals.Layout as A +import Control.Monad +#include "repa-array.h" + + +instance Bulk A a => Bulk A (Maybe a) where + data Array A (Maybe a) + = AArray_Maybe !(Array B (Maybe a)) + + layout (AArray_Maybe arr) + = Auto (A.length arr) + {-# INLINE_ARRAY layout #-} + + index (AArray_Maybe arr) ix + = A.index arr ix + {-# INLINE_ARRAY index #-} + +deriving instance Show a => Show (Array A (Maybe a)) + + +instance Bulk A a => Windowable A (Maybe a) where + window st len (AArray_Maybe arr) + = AArray_Maybe (window st len arr) + {-# INLINE_ARRAY window #-} + + +instance Target A (Maybe a) where + data Buffer A (Maybe a) + = ABuffer_Maybe !(Buffer B (Maybe a)) + + unsafeNewBuffer (Auto len) + = liftM ABuffer_Maybe $ unsafeNewBuffer (Boxed len) + {-# INLINE_ARRAY unsafeNewBuffer #-} + + unsafeReadBuffer (ABuffer_Maybe arr) ix + = unsafeReadBuffer arr ix + {-# INLINE_ARRAY unsafeReadBuffer #-} + + unsafeWriteBuffer (ABuffer_Maybe arr) ix !mx + = unsafeWriteBuffer arr ix mx + {-# INLINE_ARRAY unsafeWriteBuffer #-} + + unsafeGrowBuffer (ABuffer_Maybe arr) bump + = liftM ABuffer_Maybe $ unsafeGrowBuffer arr bump + {-# INLINE_ARRAY unsafeGrowBuffer #-} + + unsafeFreezeBuffer (ABuffer_Maybe arr) + = liftM AArray_Maybe $ unsafeFreezeBuffer arr + {-# INLINE_ARRAY unsafeFreezeBuffer #-} + + unsafeThawBuffer (AArray_Maybe arr) + = liftM ABuffer_Maybe $ unsafeThawBuffer arr + {-# INLINE_ARRAY unsafeThawBuffer #-} + + unsafeSliceBuffer st len (ABuffer_Maybe buf) + = liftM ABuffer_Maybe $ unsafeSliceBuffer st len buf + {-# INLINE_ARRAY unsafeSliceBuffer #-} + + touchBuffer (ABuffer_Maybe buf) + = touchBuffer buf + {-# INLINE_ARRAY touchBuffer #-} + + bufferLayout (ABuffer_Maybe buf) + = Auto $ A.extent $ bufferLayout buf + {-# INLINE_ARRAY bufferLayout #-} + + +instance Eq a + => Eq (Array A (Maybe a)) where + (==) (AArray_Maybe arr1) (AArray_Maybe arr2) = arr1 == arr2 + {-# INLINE (==) #-} + + diff --git a/Data/Repa/Array/Material/Auto/InstProduct.hs b/Data/Repa/Array/Material/Auto/InstProduct.hs new file mode 100644 --- /dev/null +++ b/Data/Repa/Array/Material/Auto/InstProduct.hs @@ -0,0 +1,230 @@ +{-# OPTIONS_GHC -fno-warn-orphans -fno-warn-incomplete-patterns #-} +{-# LANGUAGE UndecidableInstances #-} +module Data.Repa.Array.Material.Auto.InstProduct +where +import Data.Repa.Array.Material.Auto.Base as A +import Data.Repa.Array.Material.Auto.InstUnit as A +import Data.Repa.Array.Meta.Tuple as A +import Data.Repa.Array.Meta.Window as A +import Data.Repa.Array.Internals.Bulk as A +import Data.Repa.Array.Internals.Target as A +import Data.Repa.Scalar.Singleton.Nat as D +import Data.Repa.Scalar.Product as D +import Control.Monad +#include "repa-array.h" + + +--------------------------------------------------------------------------------------------------- +-- Arrays of products are stored in columnar format to allow easy selecting +-- and addition of columns. +-- +-- Given an array of type (Array A (Int :*: Char :*: Bool :*: ())), this is +-- stored as a flat array of Int, a flat array of Char, and a flat array of +-- Bool. The unit colunm is stored as a simple count of the number of elements, +-- and serves as the Nil element in the list of column types. +-- +-- Extracting particular column, getting the array of type (Array A Char) +-- is linear in the number of columns. Doing so takes about as long as +-- retrieving a single element from a cons-list. + +----------------------------------------------------------------------------------------------- :*: +instance (Bulk A a, Bulk A b) => Bulk A (a :*: b) where + data Array A (a :*: b) = AArray_Prod !(Array A a) !(Array A b) + layout (AArray_Prod arrA arrB) = Auto (min (A.length arrA) (A.length arrB)) + index (AArray_Prod arrA arrB) ix = A.index arrA ix :*: A.index arrB ix + {-# INLINE_ARRAY layout #-} + {-# INLINE_ARRAY index #-} + + +deriving instance (Show (Array A a), Show (Array A b)) + => Show (Array A (a :*: b)) + + +instance (A.Windowable A a, A.Windowable A b) + => A.Windowable A (a :*: b) where + window st len (AArray_Prod arrA arrB) + = AArray_Prod (window st len arrA) (window st len arrB) + {-# INLINE_ARRAY window #-} + + +instance (Target A a, Target A b) + => Target A (a :*: b) where + data Buffer A (a :*: b) + = ABuffer_Prod !(Buffer A a) !(Buffer A b) + + unsafeNewBuffer l + = liftM2 ABuffer_Prod (unsafeNewBuffer l) (unsafeNewBuffer l) + {-# INLINE_ARRAY unsafeNewBuffer #-} + + unsafeReadBuffer (ABuffer_Prod bufA bufB) ix + = do xA <- unsafeReadBuffer bufA ix + xB <- unsafeReadBuffer bufB ix + return (xA :*: xB) + {-# INLINE_ARRAY unsafeReadBuffer #-} + + unsafeWriteBuffer (ABuffer_Prod bufA bufB) ix (xA :*: xB) + = do unsafeWriteBuffer bufA ix xA + unsafeWriteBuffer bufB ix xB + {-# INLINE_ARRAY unsafeWriteBuffer #-} + + unsafeGrowBuffer (ABuffer_Prod bufA bufB) bump + = do bufA' <- unsafeGrowBuffer bufA bump + bufB' <- unsafeGrowBuffer bufB bump + return $ ABuffer_Prod bufA' bufB' + {-# INLINE_ARRAY unsafeGrowBuffer #-} + + unsafeFreezeBuffer (ABuffer_Prod bufA bufB) + = do arrA <- unsafeFreezeBuffer bufA + arrB <- unsafeFreezeBuffer bufB + return $ AArray_Prod arrA arrB + {-# INLINE_ARRAY unsafeFreezeBuffer #-} + + unsafeThawBuffer (AArray_Prod arrA arrB) + = do bufA <- unsafeThawBuffer arrA + bufB <- unsafeThawBuffer arrB + return $ ABuffer_Prod bufA bufB + {-# INLINE_ARRAY unsafeThawBuffer #-} + + unsafeSliceBuffer st len (ABuffer_Prod bufA bufB) + = do bufA' <- unsafeSliceBuffer st len bufA + bufB' <- unsafeSliceBuffer st len bufB + return $ ABuffer_Prod bufA' bufB' + {-# INLINE_ARRAY unsafeSliceBuffer #-} + + touchBuffer (ABuffer_Prod bufA bufB) + = do touchBuffer bufA + touchBuffer bufB + {-# INLINE_ARRAY touchBuffer #-} + + bufferLayout (ABuffer_Prod bufA _) + = bufferLayout bufA + {-# INLINE_ARRAY bufferLayout #-} + + +instance (Eq (Array A a), Eq (Array A b)) + => Eq (Array A (a :*: b)) where + (==) (AArray_Prod arrA1 arrA2) (AArray_Prod arrB1 arrB2) + = arrA1 == arrB1 && arrA2 == arrB2 + {-# INLINE (==) #-} + + +--------------------------------------------------------------------------------------------- Valid +instance IsProdList (Array A ()) where + isProdList _ = True + {-# INLINE isProdList #-} + + +instance IsProdList (Array A ts) + => IsProdList (Array A (f :*: ts)) where + isProdList (AArray_Prod _ arr2) = isProdList arr2 + {-# INLINE isProdList #-} + + +-------------------------------------------------------------------------------------------- Select +instance IsProdList (Array A ts) + => Select 'Z (Array A (t1 :*: ts)) where + type Select' 'Z (Array A (t1 :*: ts)) = Array A t1 + select Zero (AArray_Prod x1 _) = x1 + {-# INLINE select #-} + + +instance Select n (Array A ts) + => Select ('S n) (Array A (t1 :*: ts)) where + type Select' ('S n) (Array A (t1 :*: ts)) = Select' n (Array A ts) + select (Succ n) (AArray_Prod _ xs) = select n xs + {-# INLINE select #-} + + +------------------------------------------------------------------------------------------- Discard +instance IsProdList (Array A ts) + => Discard 'Z (Array A (t1 :*: ts)) where + type Discard' 'Z (Array A (t1 :*: ts)) = Array A ts + discard Zero (AArray_Prod _ xs) = xs + {-# INLINE discard #-} + + +instance ( Discard n (Array A ts) + , Discard' n (Array A ts) ~ Array A (Discard' n ts)) + => Discard ('S n) (Array A (t1 :*: ts)) where + type Discard' ('S n) (Array A (t1 :*: ts)) = Array A (t1 :*: Discard' n ts) + discard (Succ n) (AArray_Prod x xs) = AArray_Prod x (discard n xs) + {-# INLINE discard #-} + + +---------------------------------------------------------------------------------------------- Mask +instance Mask () (Array A ()) where + type Mask' () (Array A ()) = Array A () + mask () arr = arr + {-# INLINE mask #-} + + +instance ( Mask ms (Array A ts) + , Mask' ms (Array A ts) ~ Array A (Mask' ms ts)) + => Mask (Keep :*: ms) (Array A (t1 :*: ts)) where + type Mask' (Keep :*: ms) (Array A (t1 :*: ts)) = Array A (t1 :*: Mask' ms ts) + mask (Keep :*: ms) (AArray_Prod x1 xs) = AArray_Prod x1 (mask ms xs) + {-# INLINE mask #-} + + +instance ( Mask ms (Array A ts)) + => Mask (Drop :*: ms) (Array A (t1 :*: ts)) where + type Mask' (Drop :*: ms) (Array A (t1 :*: ts)) = Mask' ms (Array A ts) + mask (Drop :*: ms) (AArray_Prod _ xs) = mask ms xs + {-# INLINE mask #-} + + +--------------------------------------------------------------------------------------------------- +-- | Form the product of two arrays, in constant time. +prod :: Array A a -> Array A b -> Array A (a :*: b) +prod a1 a2 = AArray_Prod a1 a2 +{-# INLINE prod #-} + +-- | Unpack a product of two arrays, in constant time. +unprod :: Array A (a :*: b) -> (Array A a, Array A b) +unprod (AArray_Prod a1 a2) = (a1, a2) +{-# INLINE unprod #-} + + +--------------------------------------------------------------------------------------------------- +pattern Prod1 n a1 + = AArray_Prod a1 + (AArray_Unit n) + +pattern Prod2 n a1 a2 + = AArray_Prod a1 (AArray_Prod a2 + (AArray_Unit n)) + +pattern Prod3 n a1 a2 a3 + = AArray_Prod a1 (AArray_Prod a2 (AArray_Prod a3 + (AArray_Unit n))) + +pattern Prod4 n a1 a2 a3 a4 + = AArray_Prod a1 (AArray_Prod a2 (AArray_Prod a3 (AArray_Prod a4 + (AArray_Unit n)))) + +pattern Prod5 n a1 a2 a3 a4 a5 + = AArray_Prod a1 (AArray_Prod a2 (AArray_Prod a3 (AArray_Prod a4 + (AArray_Prod a5 + (AArray_Unit n))))) + +pattern Prod6 n a1 a2 a3 a4 a5 a6 + = AArray_Prod a1 (AArray_Prod a2 (AArray_Prod a3 (AArray_Prod a4 + (AArray_Prod a5 (AArray_Prod a6 + (AArray_Unit n)))))) + +pattern Prod7 n a1 a2 a3 a4 a5 a6 a7 + = AArray_Prod a1 (AArray_Prod a2 (AArray_Prod a3 (AArray_Prod a4 + (AArray_Prod a5 (AArray_Prod a6 (AArray_Prod a7 + (AArray_Unit n))))))) + +pattern Prod8 n a1 a2 a3 a4 a5 a6 a7 a8 + = AArray_Prod a1 (AArray_Prod a2 (AArray_Prod a3 (AArray_Prod a4 + (AArray_Prod a5 (AArray_Prod a6 (AArray_Prod a7 (AArray_Prod a8 + (AArray_Unit n)))))))) + +pattern Prod9 n a1 a2 a3 a4 a5 a6 a7 a8 a9 + = AArray_Prod a1 (AArray_Prod a2 (AArray_Prod a3 (AArray_Prod a4 + (AArray_Prod a5 (AArray_Prod a6 (AArray_Prod a7 (AArray_Prod a8 + (AArray_Prod a9 + (AArray_Unit n))))))))) + diff --git a/Data/Repa/Array/Material/Auto/InstText.hs b/Data/Repa/Array/Material/Auto/InstText.hs new file mode 100644 --- /dev/null +++ b/Data/Repa/Array/Material/Auto/InstText.hs @@ -0,0 +1,81 @@ +{-# LANGUAGE UndecidableInstances, IncoherentInstances #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +module Data.Repa.Array.Material.Auto.InstText + ( A (..) + , Name (..) + , Array (..)) +where +import Data.Repa.Array.Material.Auto.Base as A +import Data.Repa.Array.Material.Boxed as A +import Data.Repa.Array.Meta.Window as A +import Data.Repa.Array.Internals.Bulk as A +import Data.Repa.Array.Internals.Target as A +import Data.Repa.Array.Internals.Layout as A +import Control.Monad +import Data.Text (Text) +#include "repa-array.h" + + +----------------------------------------------------------------------------------------------- [] +-- TODO: The current representation is just a boxed array of Text strings, +-- we want to unpack these into a segmented rep during freezing. +instance Bulk A Text where + data Array A Text = AArray_Text !(Array B Text) + layout (AArray_Text arr) = Auto (A.length arr) + index (AArray_Text arr) ix = A.index arr ix + {-# INLINE_ARRAY layout #-} + {-# INLINE_ARRAY index #-} + +deriving instance Show (Array A Text) + + +instance Windowable A Text where + window st len (AArray_Text arr) + = AArray_Text (window st len arr) + {-# INLINE_ARRAY window #-} + + +instance Target A Text where + data Buffer A Text + = ABuffer_Text !(Buffer B Text) + + unsafeNewBuffer (Auto len) + = liftM ABuffer_Text $ unsafeNewBuffer (Boxed len) + {-# INLINE_ARRAY unsafeNewBuffer #-} + + unsafeReadBuffer (ABuffer_Text arr) ix + = unsafeReadBuffer arr ix + {-# INLINE_ARRAY unsafeReadBuffer #-} + + unsafeWriteBuffer (ABuffer_Text arr) ix x + = unsafeWriteBuffer arr ix x + {-# INLINE_ARRAY unsafeWriteBuffer #-} + + unsafeGrowBuffer (ABuffer_Text arr) bump + = liftM ABuffer_Text $ unsafeGrowBuffer arr bump + {-# INLINE_ARRAY unsafeGrowBuffer #-} + + unsafeFreezeBuffer (ABuffer_Text arr) + = liftM AArray_Text $ unsafeFreezeBuffer arr + {-# INLINE_ARRAY unsafeFreezeBuffer #-} + + unsafeThawBuffer (AArray_Text arr) + = liftM ABuffer_Text $ unsafeThawBuffer arr + {-# INLINE_ARRAY unsafeThawBuffer #-} + + unsafeSliceBuffer st len (ABuffer_Text buf) + = liftM ABuffer_Text $ unsafeSliceBuffer st len buf + {-# INLINE_ARRAY unsafeSliceBuffer #-} + + touchBuffer (ABuffer_Text buf) + = touchBuffer buf + {-# INLINE_ARRAY touchBuffer #-} + + bufferLayout (ABuffer_Text buf) + = Auto $ A.extent $ bufferLayout buf + {-# INLINE_ARRAY bufferLayout #-} + + +instance Eq (Array A Text) where + (==) (AArray_Text arr1) (AArray_Text arr2) = arr1 == arr2 + {-# INLINE (==) #-} diff --git a/Data/Repa/Array/Material/Auto/InstTuple.hs b/Data/Repa/Array/Material/Auto/InstTuple.hs new file mode 100644 --- /dev/null +++ b/Data/Repa/Array/Material/Auto/InstTuple.hs @@ -0,0 +1,98 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} +{-# LANGUAGE UndecidableInstances #-} +module Data.Repa.Array.Material.Auto.InstTuple where +import Data.Repa.Array.Material.Auto.Base as A +import Data.Repa.Array.Material.Boxed as A +import Data.Repa.Array.Meta.Tuple as A +import Data.Repa.Array.Meta.Window as A +import Data.Repa.Array.Generic.Convert as A +import Data.Repa.Array.Internals.Layout as A +import Data.Repa.Array.Internals.Bulk as A +import Data.Repa.Array.Internals.Target as A +import Control.Monad +#include "repa-array.h" + + +instance (Bulk A a, Bulk A b) => Bulk A (a, b) where + data Array A (a, b) = AArray_T2 !(Array (T2 A A) (a, b)) + layout (AArray_T2 arr) = Auto (A.length arr) + index (AArray_T2 arr) ix = A.index arr ix + {-# INLINE_ARRAY layout #-} + {-# INLINE_ARRAY index #-} + + +deriving instance (Show (Array (T2 A A) (a, b))) + => Show (Array A (a, b)) + + +instance ( A.Convert A a1 A a2 + , A.Convert A b1 A b2) + => A.Convert (T2 A A) (a1, b1) A (a2, b2) where + convert (T2Array arrA arrB) + = AArray_T2 (T2Array (convert arrA) (convert arrB)) + {-# INLINE_ARRAY convert #-} + + +instance ( A.Convert A a1 A a2 + , A.Convert A b1 A b2) + => A.Convert A (a1, b1) (T2 A A) (a2, b2) where + convert (AArray_T2 (T2Array arrA arrB)) + = T2Array (convert arrA) (convert arrB) + {-# INLINE_ARRAY convert #-} + + +instance (Windowable A a, Windowable A b) + => Windowable A (a, b) where + window st len (AArray_T2 arr) + = AArray_T2 (window st len arr) + {-# INLINE_ARRAY window #-} + + +instance (Target A a, Target A b) + => Target A (a, b) where + data Buffer A (a, b) + = ABuffer_T2 !(Buffer (T2 A A) (a, b)) + + unsafeNewBuffer (Auto len) + = liftM ABuffer_T2 $ unsafeNewBuffer (Tup2 (Auto len) (Auto len)) + {-# INLINE_ARRAY unsafeNewBuffer #-} + + unsafeReadBuffer (ABuffer_T2 arr) ix + = unsafeReadBuffer arr ix + {-# INLINE_ARRAY unsafeReadBuffer #-} + + unsafeWriteBuffer (ABuffer_T2 arr) ix x + = unsafeWriteBuffer arr ix x + {-# INLINE_ARRAY unsafeWriteBuffer #-} + + unsafeGrowBuffer (ABuffer_T2 arr) bump + = liftM ABuffer_T2 $ unsafeGrowBuffer arr bump + {-# INLINE_ARRAY unsafeGrowBuffer #-} + + unsafeFreezeBuffer (ABuffer_T2 arr) + = liftM AArray_T2 $ unsafeFreezeBuffer arr + {-# INLINE_ARRAY unsafeFreezeBuffer #-} + + unsafeThawBuffer (AArray_T2 arr) + = liftM ABuffer_T2 $ unsafeThawBuffer arr + {-# INLINE_ARRAY unsafeThawBuffer #-} + + unsafeSliceBuffer st len (ABuffer_T2 buf) + = liftM ABuffer_T2 $ unsafeSliceBuffer st len buf + {-# INLINE_ARRAY unsafeSliceBuffer #-} + + touchBuffer (ABuffer_T2 buf) + = touchBuffer buf + {-# INLINE_ARRAY touchBuffer #-} + + bufferLayout (ABuffer_T2 buf) + = Auto $ A.extent $ bufferLayout buf + {-# INLINE_ARRAY bufferLayout #-} + + + +instance Eq (Array (T2 A A) (a, b)) + => Eq (Array A (a, b)) where + (==) (AArray_T2 arr1) (AArray_T2 arr2) = arr1 == arr2 + {-# INLINE (==) #-} + diff --git a/Data/Repa/Array/Material/Auto/InstUnit.hs b/Data/Repa/Array/Material/Auto/InstUnit.hs new file mode 100644 --- /dev/null +++ b/Data/Repa/Array/Material/Auto/InstUnit.hs @@ -0,0 +1,65 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} +module Data.Repa.Array.Material.Auto.InstUnit where +import Data.Repa.Array.Material.Auto.Base as A +import Data.Repa.Array.Material.Boxed as A +import Data.Repa.Array.Meta.Window as A +import Data.Repa.Array.Internals.Bulk as A +import Data.Repa.Array.Internals.Target as A +#include "repa-array.h" + + +instance Bulk A () where + data Array A () = AArray_Unit !Int + layout (AArray_Unit len) = Auto len + index (AArray_Unit _len) _ix = () + {-# INLINE_ARRAY layout #-} + {-# INLINE_ARRAY index #-} + +deriving instance Show (Array A ()) + + +instance Windowable A () where + window _st len' (AArray_Unit _len) + = AArray_Unit len' + + +instance Target A () where + data Buffer A () + = ABuffer_Unit !Int + + unsafeNewBuffer (Auto len) + = return $ ABuffer_Unit len + {-# INLINE_ARRAY unsafeNewBuffer #-} + + unsafeReadBuffer (ABuffer_Unit _len) _ix + = return () + {-# INLINE_ARRAY unsafeReadBuffer #-} + + unsafeWriteBuffer (ABuffer_Unit _len) _ix _x + = return () + {-# INLINE_ARRAY unsafeWriteBuffer #-} + + unsafeGrowBuffer (ABuffer_Unit len) bump + = return $ ABuffer_Unit (len + bump) + {-# INLINE_ARRAY unsafeGrowBuffer #-} + + unsafeFreezeBuffer (ABuffer_Unit len) + = return $ AArray_Unit len + {-# INLINE_ARRAY unsafeFreezeBuffer #-} + + unsafeThawBuffer (AArray_Unit len) + = return $ ABuffer_Unit len + {-# INLINE_ARRAY unsafeThawBuffer #-} + + unsafeSliceBuffer _st len (ABuffer_Unit _len) + = return $ ABuffer_Unit len + {-# INLINE_ARRAY unsafeSliceBuffer #-} + + touchBuffer (ABuffer_Unit _len) + = return () + {-# INLINE_ARRAY touchBuffer #-} + + bufferLayout (ABuffer_Unit len) + = Auto len + {-# INLINE_ARRAY bufferLayout #-} + diff --git a/Data/Repa/Array/Material/Auto/InstWord.hs b/Data/Repa/Array/Material/Auto/InstWord.hs --- a/Data/Repa/Array/Material/Auto/InstWord.hs +++ b/Data/Repa/Array/Material/Auto/InstWord.hs @@ -10,7 +10,6 @@ import Data.Repa.Array.Internals.Bulk as A import Data.Repa.Array.Internals.Target as A import Data.Repa.Array.Internals.Layout as A -import Data.Repa.Fusion.Unpack as F import Data.Word import Control.Monad #include "repa-array.h" @@ -24,13 +23,16 @@ {-# INLINE_ARRAY layout #-} {-# INLINE_ARRAY index #-} + deriving instance Show (Array A Word8) instance Convert F Word8 A Word8 where convert arr = AArray_Word8 arr + {-# INLINE_ARRAY convert #-} instance Convert A Word8 F Word8 where convert (AArray_Word8 arr) = arr + {-# INLINE_ARRAY convert #-} instance Windowable A Word8 where window st len (AArray_Word8 arr) @@ -77,10 +79,3 @@ = Auto $ A.extent $ bufferLayout buf {-# INLINE_ARRAY bufferLayout #-} - -instance (Unpack (Buffer F Word8)) t - => (Unpack (Buffer A Word8)) t where - unpack (ABuffer_Word8 buf) = unpack buf - repack (ABuffer_Word8 x) buf = ABuffer_Word8 (repack x buf) - {-# INLINE unpack #-} - {-# INLINE repack #-} diff --git a/Data/Repa/Array/Material/Auto/Operator/Lines.hs b/Data/Repa/Array/Material/Auto/Operator/Lines.hs new file mode 100644 --- /dev/null +++ b/Data/Repa/Array/Material/Auto/Operator/Lines.hs @@ -0,0 +1,44 @@ + +module Data.Repa.Array.Material.Auto.Operator.Lines + (findRowsStartEnd) +where +import Data.Repa.Array.Material.Auto.Base +import Data.Repa.Array.Material.Auto.InstInt () +import Data.Repa.Array.Material.Auto.InstWord +import Data.Repa.Array.Material.Auto.InstTuple + +import qualified Data.Repa.Array.Generic as G +import qualified Data.Repa.Array.Generic.Target as G +import qualified Data.Repa.Array.Generic.Index as G + +import qualified Data.Repa.Stream as S +import qualified Data.Repa.Eval.Stream as S +import qualified Data.Vector.Fusion.Stream.Monadic as S + +import Data.Word +import System.IO.Unsafe + +-- | Given a row ending byte and a buffer containing encoded rows, +-- get buffers of row starting and ending indices. +findRowsStartEnd + :: Word8 + -> G.Array A Word8 + -> (G.Buffer A Int, G.Buffer A Int) + +findRowsStartEnd wSepLine (AArray_Word8 arrWords) + = unsafePerformIO + $ do + let len = G.extent $ G.layout arrWords + + let (AArray_T2 (T2Array arr1 arr2)) + = S.unstreamToArray A + $ S.findSegmentsS (const True) (== wSepLine) (len - 1) + $ S.indexed + $ S.streamOfArray + $ arrWords + + buf1 <- G.unsafeThawBuffer arr1 + buf2 <- G.unsafeThawBuffer arr2 + + return (buf1, buf2) +{-# NOINLINE findRowsStartEnd #-} diff --git a/Data/Repa/Array/Material/Auto/Operator/Unpackables.hs b/Data/Repa/Array/Material/Auto/Operator/Unpackables.hs new file mode 100644 --- /dev/null +++ b/Data/Repa/Array/Material/Auto/Operator/Unpackables.hs @@ -0,0 +1,207 @@ + +module Data.Repa.Array.Material.Auto.Operator.Unpackables + (Unpackables (..)) +where + +import Data.Repa.Convert.Format +import Data.Repa.Array.Material.Foreign +import Data.Repa.Array.Material.Auto +import qualified Data.Repa.Array.Generic.Unpacks as G + +import Data.Repa.Convert.Formats + +import Data.Word + + +--------------------------------------------------------------------------------------------------- +class Unpackables format where + + -- | Unpack an encoded table of values from an array of bytes, + -- and write the result into an existing buffer. + -- + -- The implementation invokes specialised code for each format. + -- + unpacksToBuffer + :: format + -> Word8 + -> Array F Word8 -- ^ Encoded source data. + -> Buffer A Int -- ^ Starting indices fields in current column. + -> Buffer A Int -- ^ Ending indices each row. + -> Buffer A (Value format) -- ^ Buffer to write the result fields to. + -> IO (Maybe (Int, Int)) + + +instance Unpackable a => Unpackables (MaybeChars a) where + unpacksToBuffer f c arr ixsStart ixsEnd bufOut + = unpacksToBuffer_MaybeChars f c arr ixsStart ixsEnd bufOut + {-# INLINE unpacksToBuffer #-} + + +instance Unpackables VarChars where + unpacksToBuffer f c arr ixsStart ixsEnd bufOut + = unpacksToBuffer_VarChars f c arr ixsStart ixsEnd bufOut + {-# INLINE unpacksToBuffer #-} + + +instance Unpackables VarCharString where + unpacksToBuffer f c arr ixsStart ixsEnd bufOut + = unpacksToBuffer_VarCharString f c arr ixsStart ixsEnd bufOut + {-# INLINE unpacksToBuffer #-} + + +instance Unpackables VarText where + unpacksToBuffer f c arr ixsStart ixsEnd bufOut + = unpacksToBuffer_VarText f c arr ixsStart ixsEnd bufOut + {-# INLINE unpacksToBuffer #-} + + +instance Unpackables VarTextString where + unpacksToBuffer f c arr ixsStart ixsEnd bufOut + = unpacksToBuffer_VarTextString f c arr ixsStart ixsEnd bufOut + {-# INLINE unpacksToBuffer #-} + + +instance Unpackables IntAsc where + unpacksToBuffer f c arr ixsStart ixsEnd bufOut + = unpacksToBuffer_IntAsc f c arr ixsStart ixsEnd bufOut + {-# INLINE unpacksToBuffer #-} + + +instance Unpackables IntAsc0 where + unpacksToBuffer f c arr ixsStart ixsEnd bufOut + = unpacksToBuffer_IntAsc0 f c arr ixsStart ixsEnd bufOut + {-# INLINE unpacksToBuffer #-} + + +instance Unpackables DoubleAsc where + unpacksToBuffer f c arr ixsStart ixsEnd bufOut + = unpacksToBuffer_DoubleAsc f c arr ixsStart ixsEnd bufOut + {-# INLINE unpacksToBuffer #-} + + +instance Unpackables DoubleFixedPack where + unpacksToBuffer f c arr ixsStart ixsEnd bufOut + = unpacksToBuffer_DoubleFixedPack f c arr ixsStart ixsEnd bufOut + {-# INLINE unpacksToBuffer #-} + + +instance Unpackables YYYYsMMsDD where + unpacksToBuffer f c arr ixsStart ixsEnd bufOut + = unpacksToBuffer_YYYYsMMsDD f c arr ixsStart ixsEnd bufOut + {-# INLINE unpacksToBuffer #-} + + +instance Unpackables DDsMMsYYYY where + unpacksToBuffer f c arr ixsStart ixsEnd bufOut + = unpacksToBuffer_DDsMMsYYYY f c arr ixsStart ixsEnd bufOut + {-# INLINE unpacksToBuffer #-} + + +instance Unpackables (Sep ()) where + unpacksToBuffer _f _c _arr _ixsStart _ixsEnd _bufOut + = return Nothing + {-# INLINE unpacksToBuffer #-} + + +instance ( Unpackables f1 + , Unpackables (Sep fs) + , Value (Sep fs) ~ Value fs) + => Unpackables (Sep (f1 :*: fs)) where + + unpacksToBuffer + (SepCons _ fmt1 fmts) + c arr ixsStart ixsEnd + (ABuffer_Prod bufA bufs) + = do mErr <- unpacksToBuffer fmt1 c arr ixsStart ixsEnd bufA + case mErr of + Nothing -> unpacksToBuffer fmts c arr ixsStart ixsEnd bufs + Just err -> return (Just err) + {-# INLINE unpacksToBuffer #-} + -- INLINE so that the sequence of calls to 'unpacksToBuffer' will + -- be unfolded into the client module. The instances themselves are + -- set to NOINLINE, so this won't cause code explosion. + + +--------------------------------------------------------------------------------------------------- +-- The following instances are hand specialised and set to NOINLINE +-- so that we only generate them once, and in this module. +-- We don't want to re-derive this code in client programs. +-- +-- We define a top level binding for each instance to force specialisation. +-- Using the same code directly in a type class instance doesn't seem +-- to work. +-- +type UnpacksColumn format + = format + -> Word8 + -> Array F Word8 + -> Buffer A Int + -> Buffer A Int + -> Buffer A (Value format) + -> IO (Maybe (Int, Int)) + +unpacksToBuffer_MaybeChars :: Unpackable a => UnpacksColumn (MaybeChars a) +unpacksToBuffer_MaybeChars f@(MaybeChars _ _) c arr ixsStart ixsEnd ixsOut + = G.unsafeUnpacksToBuffer f c arr ixsStart ixsEnd ixsOut +{-# NOINLINE unpacksToBuffer_MaybeChars #-} + + +unpacksToBuffer_VarChars :: UnpacksColumn VarChars +unpacksToBuffer_VarChars f@VarChars c arr ixsStart ixsEnd ixsOut + = G.unsafeUnpacksToBuffer f c arr ixsStart ixsEnd ixsOut +{-# NOINLINE unpacksToBuffer_VarChars #-} + + +unpacksToBuffer_VarCharString :: UnpacksColumn VarCharString +unpacksToBuffer_VarCharString f@VarCharString c arr ixsStart ixsEnd ixsOut + = G.unsafeUnpacksToBuffer f c arr ixsStart ixsEnd ixsOut +{-# NOINLINE unpacksToBuffer_VarCharString #-} + + +unpacksToBuffer_VarText :: UnpacksColumn VarText +unpacksToBuffer_VarText f@VarText c arr ixsStart ixsEnd ixsOut + = G.unsafeUnpacksToBuffer f c arr ixsStart ixsEnd ixsOut +{-# NOINLINE unpacksToBuffer_VarText #-} + + +unpacksToBuffer_VarTextString :: UnpacksColumn VarTextString +unpacksToBuffer_VarTextString f@VarTextString c arr ixsStart ixsEnd ixsOut + = G.unsafeUnpacksToBuffer f c arr ixsStart ixsEnd ixsOut +{-# NOINLINE unpacksToBuffer_VarTextString #-} + + +unpacksToBuffer_IntAsc :: UnpacksColumn IntAsc +unpacksToBuffer_IntAsc f@IntAsc c arr ixsStart ixsEnd ixsOut + = G.unsafeUnpacksToBuffer f c arr ixsStart ixsEnd ixsOut +{-# NOINLINE unpacksToBuffer_IntAsc #-} + + +unpacksToBuffer_IntAsc0 :: UnpacksColumn IntAsc0 +unpacksToBuffer_IntAsc0 f@(IntAsc0 _) c arr ixsStart ixsEnd ixsOut + = G.unsafeUnpacksToBuffer f c arr ixsStart ixsEnd ixsOut +{-# NOINLINE unpacksToBuffer_IntAsc0 #-} + + +unpacksToBuffer_DoubleAsc :: UnpacksColumn DoubleAsc +unpacksToBuffer_DoubleAsc f@DoubleAsc c arr ixsStart ixsEnd ixsOut + = G.unsafeUnpacksToBuffer f c arr ixsStart ixsEnd ixsOut +{-# NOINLINE unpacksToBuffer_DoubleAsc #-} + + +unpacksToBuffer_DoubleFixedPack :: UnpacksColumn DoubleFixedPack +unpacksToBuffer_DoubleFixedPack f@(DoubleFixedPack _) c arr ixsStart ixsEnd ixsOut + = G.unsafeUnpacksToBuffer f c arr ixsStart ixsEnd ixsOut +{-# NOINLINE unpacksToBuffer_DoubleFixedPack #-} + + +unpacksToBuffer_YYYYsMMsDD :: UnpacksColumn YYYYsMMsDD +unpacksToBuffer_YYYYsMMsDD f@(YYYYsMMsDD _) c arr ixsStart ixsEnd ixsOut + = G.unsafeUnpacksToBuffer f c arr ixsStart ixsEnd ixsOut +{-# NOINLINE unpacksToBuffer_YYYYsMMsDD #-} + + +unpacksToBuffer_DDsMMsYYYY :: UnpacksColumn DDsMMsYYYY +unpacksToBuffer_DDsMMsYYYY f@(DDsMMsYYYY _) c arr ixsStart ixsEnd ixsOut + = G.unsafeUnpacksToBuffer f c arr ixsStart ixsEnd ixsOut +{-# NOINLINE unpacksToBuffer_DDsMMsYYYY #-} + diff --git a/Data/Repa/Array/Material/Boxed.hs b/Data/Repa/Array/Material/Boxed.hs --- a/Data/Repa/Array/Material/Boxed.hs +++ b/Data/Repa/Array/Material/Boxed.hs @@ -15,7 +15,6 @@ import Data.Repa.Array.Generic.Index as A import Data.Repa.Array.Internals.Bulk as A import Data.Repa.Array.Internals.Target as A -import Data.Repa.Fusion.Unpack import Data.Word import Control.Monad import qualified Data.Vector as V @@ -72,7 +71,7 @@ -- | Boxed windows. instance Windowable B a where window st len (BArray vec) - = BArray (V.slice st len vec) + = BArray (V.unsafeSlice st len vec) {-# INLINE_ARRAY window #-} @@ -126,13 +125,6 @@ {-# SPECIALIZE instance Target B Word16 #-} {-# SPECIALIZE instance Target B Word32 #-} {-# SPECIALIZE instance Target B Word64 #-} - - -instance Unpack (Buffer B a) (VM.IOVector a) where - unpack (BBuffer vec) = vec - repack _ vec = BBuffer vec - {-# INLINE_ARRAY unpack #-} - {-# INLINE_ARRAY repack #-} ------------------------------------------------------------------------------- diff --git a/Data/Repa/Array/Material/Foreign/Base.hs b/Data/Repa/Array/Material/Foreign/Base.hs --- a/Data/Repa/Array/Material/Foreign/Base.hs +++ b/Data/Repa/Array/Material/Foreign/Base.hs @@ -17,8 +17,6 @@ import Data.Repa.Array.Internals.Target as A import Data.Repa.Array.Internals.Bulk as A -import Data.Repa.Fusion.Unpack - import Foreign.ForeignPtr import Foreign.Storable @@ -81,18 +79,12 @@ deriving instance (S.Storable a, Show a) => Show (Array F a) -instance Unpack (Array F a) (S.Vector a) where - unpack (FArray v) = v - repack _ v = FArray v - {-# INLINE_ARRAY unpack #-} - {-# INLINE_ARRAY repack #-} - ------------------------------------------------------------------------------- -- | Windowing Foreign arrays. instance Storable a => Windowable F a where window st len (FArray vec) - = FArray (S.slice st len vec) + = FArray (S.unsafeSlice st len vec) {-# INLINE_ARRAY window #-} {-# SPECIALIZE instance Windowable F Char #-} {-# SPECIALIZE instance Windowable F Int #-} @@ -127,14 +119,6 @@ {-# INLINE unsafeSliceBuffer #-} {-# INLINE touchBuffer #-} {-# INLINE bufferLayout #-} - - --- | Unpack Foreign buffers -instance Unpack (Buffer F a) (M.IOVector a) where - unpack (FBuffer mv) = mv - repack _ mv = FBuffer mv - {-# INLINE_ARRAY unpack #-} - {-# INLINE_ARRAY repack #-} ------------------------------------------------------------------------------- diff --git a/Data/Repa/Array/Material/Nested.hs b/Data/Repa/Array/Material/Nested.hs --- a/Data/Repa/Array/Material/Nested.hs +++ b/Data/Repa/Array/Material/Nested.hs @@ -40,7 +40,6 @@ import Data.Repa.Array.Material.Foreign.Base as A import Data.Repa.Array.Internals.Bulk as A import Data.Repa.Array.Internals.Target as A -import Data.Repa.Fusion.Unpack as A import Data.Repa.Eval.Stream as A import Data.Repa.Stream as S import qualified Data.Repa.Vector.Generic as G @@ -51,7 +50,6 @@ import qualified Data.Vector as VV import Control.Monad.ST import Control.Monad -import Control.Monad.Primitive import GHC.Exts hiding (fromList) import Prelude as P import Prelude hiding (concat) @@ -219,18 +217,6 @@ !arrElems <- unsafeFreezeBuffer bufElems return $ NArray starts lengths arrElems {-# INLINE_ARRAY unsafeFreezeBuffer #-} - --- unsafeThawBuffer (NArray v) --- = FBuffer `liftM` S.unsafeThaw v --- {-# INLINE unsafeThawBuffer #-} - - -instance Unpack (Buffer N (Array l a)) - (VM.IOVector (Array l a)) where - unpack (NBuffer mv) = mv - repack _ mv = NBuffer mv - {-# INLINE_ARRAY unpack #-} - {-# INLINE_ARRAY repack #-} ---------------------------------------------------------------------------------------- Windowable diff --git a/Data/Repa/Array/Material/Strided.hs b/Data/Repa/Array/Material/Strided.hs deleted file mode 100644 --- a/Data/Repa/Array/Material/Strided.hs +++ /dev/null @@ -1,138 +0,0 @@ - -module Data.Repa.Array.Material.Strided - ( S (..) - , Name (..) - , Array (..) - - -- * Conversions - , unsafeCast - , fromForeignPtr, toForeignPtr) -where -import Data.Repa.Array.Meta.Window -import Data.Repa.Array.Internals.Bulk -import Data.Repa.Array.Internals.Layout -import Data.Repa.Fusion.Unpack -import Data.Word -import qualified Foreign.Storable as S -import qualified Foreign.ForeignPtr as F -import qualified Data.ByteString.Internal as BS -#include "repa-array.h" - - --- | Layout for Foreign Strided arrays. --- --- UNSAFE: indexing into foreign strided arrays is not bounds checked. --- You may want to wrap this with a Checked layout as well. --- -data S = Strided - { stridedLength :: !Int } - deriving (Show, Eq) - - -------------------------------------------------------------------------------- -instance Layout S where - data Name S = S - type Index S = Int - - name = S - create S len = Strided len - extent (Strided len) = len - toIndex _ ix = ix - fromIndex _ ix = ix - {-# INLINE_ARRAY name #-} - {-# INLINE_ARRAY create #-} - {-# INLINE_ARRAY extent #-} - {-# INLINE_ARRAY toIndex #-} - {-# INLINE_ARRAY fromIndex #-} - -deriving instance Eq (Name S) -deriving instance Show (Name S) - - -------------------------------------------------------------------------------- -instance S.Storable a => Bulk S a where - data Array S a - = SArray - { sArrayStartBytes :: !Int - , sArrayStrideBytes :: !Int - , sArrayLenElems :: !Int - , sArrayPtr :: !(F.ForeignPtr a) } - - layout (SArray _ _ len _) - = Strided len - - index (SArray start stride len fptr) ix - = BS.inlinePerformIO - $ F.withForeignPtr fptr - $ \ptr -> S.peekByteOff ptr - (start + (toIndex (Strided len) ix) * stride) - {-# INLINE_ARRAY layout #-} - {-# INLINE_ARRAY index #-} - {-# SPECIALIZE instance Bulk S Char #-} - {-# SPECIALIZE instance Bulk S Int #-} - {-# SPECIALIZE instance Bulk S Float #-} - {-# SPECIALIZE instance Bulk S Double #-} - {-# SPECIALIZE instance Bulk S Word8 #-} - {-# SPECIALIZE instance Bulk S Word16 #-} - {-# SPECIALIZE instance Bulk S Word32 #-} - {-# SPECIALIZE instance Bulk S Word64 #-} - - -deriving instance (S.Storable a, Show a) => Show (Array S a) - - -instance Unpack (Array S a) (Int, Int, Int, F.ForeignPtr a) where - unpack (SArray start stride len fptr) = (start, stride, len, fptr) - repack _ (start, stride, len, fptr) = (SArray start stride len fptr) - {-# INLINE unpack #-} - {-# INLINE repack #-} - - -------------------------------------------------------------------------------- -instance S.Storable a => Windowable S a where - window startElems' lenElems' - (SArray startBytes strideBytes _lenElems fptr) - = let lenElem = S.sizeOf (undefined :: a) - in SArray (startBytes + (lenElem * startElems')) - strideBytes lenElems' fptr - {-# INLINE_ARRAY window #-} - {-# SPECIALIZE instance Windowable S Char #-} - {-# SPECIALIZE instance Windowable S Int #-} - {-# SPECIALIZE instance Windowable S Float #-} - {-# SPECIALIZE instance Windowable S Double #-} - {-# SPECIALIZE instance Windowable S Word8 #-} - {-# SPECIALIZE instance Windowable S Word16 #-} - {-# SPECIALIZE instance Windowable S Word32 #-} - {-# SPECIALIZE instance Windowable S Word64 #-} - - -------------------------------------------------------------------------------- --- | O(1). Cast a foreign array from one element type to another. -unsafeCast - :: (S.Storable a, S.Storable b) - => Array S a -> Array S b -unsafeCast (SArray startBytes strideBytes lenElems fptr) - = (SArray startBytes strideBytes lenElems $ F.castForeignPtr fptr) - - --- | O(1). Wrap a `ForeignPtr` as a strided array. -fromForeignPtr - :: Int -- ^ Starting position in bytes. - -> Int -- ^ Stride to get to next element, in bytes. - -> Int -- ^ Length of array in elements. - -> F.ForeignPtr a -- ^ `ForeignPtr` holding the data. - -> Array S a - -fromForeignPtr startBytes strideBytes lenElems fptr - = SArray startBytes strideBytes lenElems fptr -{-# INLINE_ARRAY fromForeignPtr #-} - - --- | O(1). Unwrap a `ForeignPtr` from a strided array. -toForeignPtr - :: Array S a - -> (Int, Int, Int, F.ForeignPtr a) -toForeignPtr (SArray startBytes strideBytes lenElems fptr) - = (startBytes, strideBytes, lenElems, fptr) -{-# INLINE_ARRAY toForeignPtr #-} - diff --git a/Data/Repa/Array/Material/Unboxed.hs b/Data/Repa/Array/Material/Unboxed.hs --- a/Data/Repa/Array/Material/Unboxed.hs +++ b/Data/Repa/Array/Material/Unboxed.hs @@ -15,7 +15,6 @@ import Data.Repa.Array.Generic.Index as A import Data.Repa.Array.Internals.Bulk as A import Data.Repa.Array.Internals.Target as A -import Data.Repa.Fusion.Unpack import Control.Monad import Data.Word import qualified Data.Vector.Unboxed as U @@ -85,18 +84,11 @@ {-# INLINE_ARRAY (==) #-} -instance Unpack (Array U a) (U.Vector a) where - unpack (UArray vec) = vec - repack !_ !vec = UArray vec - {-# INLINE_ARRAY unpack #-} - {-# INLINE_ARRAY repack #-} - - --------------------------------------------------------------------------------------------------- -- | Windowing Unboxed arrays. instance U.Unbox a => Windowable U a where window st len (UArray vec) - = UArray (U.slice st len vec) + = UArray (U.unsafeSlice st len vec) {-# INLINE_ARRAY window #-} {-# SPECIALIZE instance Windowable U Int #-} {-# SPECIALIZE instance Windowable U Float #-} @@ -158,13 +150,6 @@ {-# SPECIALIZE instance Target U Word16 #-} {-# SPECIALIZE instance Target U Word32 #-} {-# SPECIALIZE instance Target U Word64 #-} - - -instance Unpack (Buffer U a) (UM.IOVector a) where - unpack (UBuffer vec) = vec `seq` vec - repack !_ !vec = UBuffer vec - {-# INLINE_ARRAY unpack #-} - {-# INLINE_ARRAY repack #-} --------------------------------------------------------------------------------------------------- diff --git a/Data/Repa/Array/Meta/Dense.hs b/Data/Repa/Array/Meta/Dense.hs --- a/Data/Repa/Array/Meta/Dense.hs +++ b/Data/Repa/Array/Meta/Dense.hs @@ -14,7 +14,6 @@ import Data.Repa.Array.Generic.Index import Data.Repa.Array.Internals.Bulk import Data.Repa.Array.Internals.Target -import Data.Repa.Fusion.Unpack import Control.Monad import Prelude as P @@ -126,15 +125,6 @@ {-# INLINE unsafeFreezeBuffer #-} {-# INLINE touchBuffer #-} {-# INLINE bufferLayout #-} - - -instance Unpack (Buffer r a) tBuf - => Unpack (Buffer (E r l) a) (l, tBuf) where - - unpack (EBuffer l buf) = (l, unpack buf) - repack (EBuffer _ buf) (l, ubuf) = EBuffer l (repack buf ubuf) - {-# INLINE unpack #-} - {-# INLINE repack #-} ------------------------------------------------------------------------------- diff --git a/Data/Repa/Array/Meta/Tuple.hs b/Data/Repa/Array/Meta/Tuple.hs --- a/Data/Repa/Array/Meta/Tuple.hs +++ b/Data/Repa/Array/Meta/Tuple.hs @@ -10,7 +10,6 @@ import Data.Repa.Array.Generic.Index import Data.Repa.Array.Internals.Bulk import Data.Repa.Array.Internals.Target -import Data.Repa.Fusion.Unpack import Control.Monad import Prelude hiding (zip, unzip) #include "repa-array.h" @@ -139,16 +138,6 @@ bufferLayout (T2Buffer buf1 buf2) = Tup2 (bufferLayout buf1) (bufferLayout buf2) - -instance (Unpack (Buffer r1 a) t1, Unpack (Buffer r2 b) t2) - => Unpack (Buffer (T2 r1 r2) (a, b)) (t1, t2) where - unpack (T2Buffer buf1 buf2) - = buf1 `seq` buf2 `seq` (unpack buf1, unpack buf2) - {-# INLINE_ARRAY unpack #-} - - repack !(T2Buffer x1 x2) (buf1, buf2) - = buf1 `seq` buf2 `seq` (T2Buffer (repack x1 buf1) (repack x2 buf2)) - {-# INLINE_ARRAY repack #-} ------------------------------------------------------------------------------- diff --git a/Data/Repa/Bits/Date32.hs b/Data/Repa/Bits/Date32.hs deleted file mode 100644 --- a/Data/Repa/Bits/Date32.hs +++ /dev/null @@ -1,287 +0,0 @@ -{-# LANGUAGE UndecidableInstances #-} -module Data.Repa.Bits.Date32 - ( Date32 - , pack, unpack - , next - , range - , pretty - , readYYYYsMMsDD - , readDDsMMsYYYY) -where -import Data.Repa.Array -import Data.Repa.Array.Auto.Convert -import qualified Data.Repa.Array.Generic.Target as A -import qualified Data.Repa.Array.Generic.Index as A -import qualified Data.Repa.Array.Material.Auto as A -import qualified Data.Repa.Array.Material.Foreign as A -import qualified Data.Repa.Array.Generic as A -import qualified Data.Repa.Array.Meta.Window as A -import qualified Data.Repa.Fusion.Unpack as A -import Data.Word -import Data.Bits -import GHC.Exts -import GHC.Word -import Foreign.Storable -import Foreign.Ptr -import Control.Monad -import Prelude as P -#include "repa-array.h" - --- | A date packed into a 32-bit word. --- --- The bitwise format is: --- --- @ --- 32 16 8 0 --- | year | month | day | --- @ --- --- Pros: Packing and unpacking a Date32 is simpler than using other formats --- that represent dates as a number of days from some epoch. We can also --- avoid worrying about what the epoch should be, and the representation --- will not overflow until year 65536. --- --- Cons: Computing a range of dates is slower than with representations --- using an epoch, as we cannot simply add one to get to the next valid date. --- -newtype Date32 - = Date32 Word32 - deriving (Eq, Ord, Show) - - -instance Storable Date32 where - sizeOf (Date32 w) = sizeOf w - alignment (Date32 w) = alignment w - peek ptr = liftM Date32 (peek (castPtr ptr)) - poke ptr (Date32 w) = poke (castPtr ptr) w - {-# INLINE sizeOf #-} - {-# INLINE alignment #-} - {-# INLINE peek #-} - {-# INLINE poke #-} - - -instance A.Bulk A.A Date32 where - data Array A.A Date32 = AArray_Date32 !(A.Array A.F Date32) - layout (AArray_Date32 arr) = A.Auto (A.length arr) - index (AArray_Date32 arr) ix = A.index arr ix - {-# INLINE_ARRAY layout #-} - {-# INLINE_ARRAY index #-} - -deriving instance Show (A.Array A.A Date32) - - -instance A.Windowable A.A Date32 where - window st len (AArray_Date32 arr) - = AArray_Date32 (A.window st len arr) - {-# INLINE_ARRAY window #-} - - -instance A.Target A.A Date32 where - data Buffer A.A Date32 - = ABuffer_Date32 !(A.Buffer A.F Date32) - - unsafeNewBuffer (A.Auto len) - = liftM ABuffer_Date32 $ A.unsafeNewBuffer (A.Foreign len) - {-# INLINE_ARRAY unsafeNewBuffer #-} - - unsafeReadBuffer (ABuffer_Date32 arr) ix - = A.unsafeReadBuffer arr ix - {-# INLINE_ARRAY unsafeReadBuffer #-} - - unsafeWriteBuffer (ABuffer_Date32 arr) ix x - = A.unsafeWriteBuffer arr ix x - {-# INLINE_ARRAY unsafeWriteBuffer #-} - - unsafeGrowBuffer (ABuffer_Date32 arr) bump - = liftM ABuffer_Date32 $ A.unsafeGrowBuffer arr bump - {-# INLINE_ARRAY unsafeGrowBuffer #-} - - unsafeFreezeBuffer (ABuffer_Date32 arr) - = liftM AArray_Date32 $ A.unsafeFreezeBuffer arr - {-# INLINE_ARRAY unsafeFreezeBuffer #-} - - unsafeThawBuffer (AArray_Date32 arr) - = liftM ABuffer_Date32 $ A.unsafeThawBuffer arr - {-# INLINE_ARRAY unsafeThawBuffer #-} - - unsafeSliceBuffer st len (ABuffer_Date32 buf) - = liftM ABuffer_Date32 $ A.unsafeSliceBuffer st len buf - {-# INLINE_ARRAY unsafeSliceBuffer #-} - - touchBuffer (ABuffer_Date32 buf) - = A.touchBuffer buf - {-# INLINE_ARRAY touchBuffer #-} - - bufferLayout (ABuffer_Date32 buf) - = A.Auto $ A.extent $ A.bufferLayout buf - {-# INLINE_ARRAY bufferLayout #-} - - -instance (A.Unpack (A.Buffer A.F Date32)) t - => (A.Unpack (A.Buffer A.A Date32)) t where - unpack (ABuffer_Date32 buf) = A.unpack buf - repack (ABuffer_Date32 x) buf = ABuffer_Date32 (A.repack x buf) - {-# INLINE unpack #-} - {-# INLINE repack #-} - - ---------------------------------------------------------------------------------------------------- --- | Pack a year, month and day into a `Word32`. --- --- If any components of the date are out-of-range then they will be bit-wise --- truncated so they fit in their destination fields. --- -pack :: (Word, Word, Word) -> Date32 -pack (yy, mm, dd) - = Date32 - $ ((fromIntegral yy .&. 0x0ffff) `shiftL` 16) - .|. ((fromIntegral mm .&. 0x0ff) `shiftL` 8) - .|. (fromIntegral dd .&. 0x0ff) -{-# INLINE pack #-} - - --- | Inverse of `pack`. --- --- This function does a simple bit-wise unpacking of the given `Word32`, --- and does not guarantee that the returned fields are within a valid --- range for the given calendar date. --- -unpack :: Date32 -> (Word, Word, Word) -unpack (Date32 date) - = ( fromIntegral $ (date `shiftR` 16) .&. 0x0ffff - , fromIntegral $ (date `shiftR` 8) .&. 0x0ff - , fromIntegral $ date .&. 0x0ff) -{-# INLINE unpack #-} - - ---------------------------------------------------------------------------------------------------- --- | Yield the next date in the series. --- --- This assumes leap years occur every four years, --- which is valid after year 1900 and before year 2100. --- -next :: Date32 -> Date32 -next (Date32 (W32# date)) - = Date32 (W32# (next' date)) -{-# INLINE next #-} - -next' :: Word# -> Word# -next' !date - | (yy, mm, dd) <- unpack (Date32 (W32# date)) - , (yy', mm', dd') - <- case mm of - 1 -> if dd >= 31 then (yy, 2, 1) else (yy, mm, dd + 1) -- Jan - - 2 -> if yy `mod` 4 == 0 -- Feb - then if dd >= 29 - then (yy, 3, 1) - else (yy, mm, dd + 1) - else if dd >= 28 - then (yy, 3, 1) - else (yy, mm, dd + 1) - - 3 -> if dd >= 31 then (yy, 4, 1) else (yy, mm, dd + 1) -- Mar - 4 -> if dd >= 30 then (yy, 5, 1) else (yy, mm, dd + 1) -- Apr - 5 -> if dd >= 31 then (yy, 6, 1) else (yy, mm, dd + 1) -- May - 6 -> if dd >= 30 then (yy, 7, 1) else (yy, mm, dd + 1) -- Jun - 7 -> if dd >= 31 then (yy, 8, 1) else (yy, mm, dd + 1) -- Jul - 8 -> if dd >= 31 then (yy, 9, 1) else (yy, mm, dd + 1) -- Aug - 9 -> if dd >= 30 then (yy, 10, 1) else (yy, mm, dd + 1) -- Sep - 10 -> if dd >= 31 then (yy, 11, 1) else (yy, mm, dd + 1) -- Oct - 11 -> if dd >= 30 then (yy, 12, 1) else (yy, mm, dd + 1) -- Nov - 12 -> if dd >= 31 then (yy + 1, 1, 1) else (yy, mm, dd + 1) -- Dec - _ -> (0, 0, 0) - = case pack (yy', mm', dd') of - Date32 (W32# w) -> w -{-# NOINLINE next' #-} - - --- | Yield an array containing a range of dates, inclusive of the end points. ---- --- TODO: avoid going via lists. --- -range :: Date32 -> Date32 -> Array Date32 -range from to - | to < from = A.fromList A.A [] - | otherwise = A.fromList A.A $ go [] from - where - go !acc !d - | d > to = P.reverse acc - | otherwise = go (d : acc) (next d) -{-# NOINLINE range #-} - - ---------------------------------------------------------------------------------------------------- --- | Pretty print a `Date32` ---- --- TODO: avoid going via lists. --- -pretty :: Char -- ^ Separator for components. - -> Date32 -- ^ Date to pretty print. - -> Array Char - -pretty !cSep !date - = let (yy, mm, dd) = unpack date - yy' = show yy - mm' = if mm < 10 then "0" ++ show mm else show mm - dd' = if dd < 10 then "0" ++ show dd else show dd - in A.fromList A.A $ P.concat [yy', [cSep], mm', [cSep], dd'] - - ---------------------------------------------------------------------------------------------------- --- | Read a `Date32` in ASCII YYYYsMMsDD format, --- using the given separator character 's'. -readYYYYsMMsDD :: Char -> Array Char -> Maybe Date32 -readYYYYsMMsDD !c !arr - | I# len <- A.length arr - - -- year part - , (# 1#, yy, ix1 #) <- readIntFromOffset# arr 0# - - -- month part - , 1# <- ix1 <# len - , arr `index` (I# ix1) == c - , (# 1#, mm, ix2 #) <- readIntFromOffset# arr (ix1 +# 1#) - - -- day part - , 1# <- ix2 <# len - , arr `index` (I# ix2) == c - , (# 1#, dd, _ #) <- readIntFromOffset# arr (ix2 +# 1#) - - = Just (pack ( fromIntegral (I# yy) - , fromIntegral (I# mm) - , fromIntegral (I# dd))) - - | otherwise - = Nothing -{-# INLINE [0] readYYYYsMMsDD #-} - - ---------------------------------------------------------------------------------------------------- --- | Read a `Date32` in ASCII DDsMMsYYYY format, --- using the given separator character 's'. -readDDsMMsYYYY :: Char -> Array Char -> Maybe Date32 -readDDsMMsYYYY !c !arr - | I# len <- A.length arr - - -- day part - , (# 1#, dd, ix1 #) <- readIntFromOffset# arr 0# - - -- month part - , 1# <- ix1 <# len - , arr `index` (I# ix1) == c - , (# 1#, mm, ix2 #) <- readIntFromOffset# arr (ix1 +# 1#) - - -- year part - , 1# <- ix2 <# len - , arr `index` (I# ix2) == c - , (# 1#, yy, _ #) <- readIntFromOffset# arr (ix2 +# 1#) - - = Just (pack ( fromIntegral (I# yy) - , fromIntegral (I# mm) - , fromIntegral (I# dd))) - - | otherwise - = Nothing -{-# INLINE [0] readDDsMMsYYYY #-} - diff --git a/Data/Repa/Eval/Chain.hs b/Data/Repa/Eval/Chain.hs --- a/Data/Repa/Eval/Chain.hs +++ b/Data/Repa/Eval/Chain.hs @@ -6,7 +6,6 @@ , unchainToArrayIO) where import Data.Repa.Chain (Chain(..), Step(..)) -import Data.Repa.Fusion.Unpack import Data.Repa.Array.Generic.Index as A import Data.Repa.Array.Internals.Bulk as A import Data.Repa.Array.Internals.Target as A @@ -49,7 +48,7 @@ -- | Compute the elements of a pure `Chain`, -- writing them into a new array `Array`. unchainToArray - :: (Target l a, Unpack (Buffer l a) t) + :: Target l a => Name l -> Chain S.Id s a -> (Array l a, s) unchainToArray nDst c = unsafePerformIO @@ -61,7 +60,7 @@ -- | Compute the elements of an `IO` `Chain`, -- writing them to a new `Array`. unchainToArrayIO - :: (Target l a, Unpack (Buffer l a) t) + :: Target l a => Name l -> Chain IO s a -> IO (Array l a, s) unchainToArrayIO nDst (Chain sz s0 step) @@ -99,9 +98,9 @@ = do !vec0 <- unsafeNewBuffer (create nDst zeroDim) !vec1 <- unsafeGrowBuffer vec0 nStart - let go_unchainIO_unknown !sPEC !uvec !i !n !s - = go_unchainIO_unknown1 (repack vec0 uvec) i n s - (\vec' i' n' s' -> go_unchainIO_unknown sPEC (unpack vec') i' n' s') + let go_unchainIO_unknown !uvec !i !n !s + = go_unchainIO_unknown1 uvec i n s + (\vec' i' n' s' -> go_unchainIO_unknown vec' i' n' s') (\result -> return result) go_unchainIO_unknown1 !vec !i !n !s cont done @@ -125,43 +124,7 @@ arr <- unsafeFreezeBuffer vec' done (arr, s') - go_unchainIO_unknown S.SPEC (unpack vec1) 0 nStart s0 + go_unchainIO_unknown vec1 0 nStart s0 {-# INLINE_INNER unchainToArrayIO_unknown #-} {-# INLINE_STREAM unchainToArrayIO #-} - - -{- - -- This consuming function has been desugared so that the recursion - -- is via RealWorld, rather than using a function of type IO. - -- If the recursion is at IO then GHC tries to coerce to and from - -- IO at every recursive call, which messes up SpecConstr. - let go_unchainIO_unknown - :: Unpack (Buffer r a) t - => S.SPEC -> t -> Int -> Int -> s - -> State# RealWorld -> (# State# RealWorld, (Array r DIM1 a, s) #) - - go_unchainIO_unknown !sPEC !uvec !i !n !s !w0 - = case unIO (step s) w0 of - (# w1, Yield e s' #) - | (# w2, (uvec', i', n') #) - <- unIO (do (vec', n') - <- if i >= n - then do vec' <- unsafeGrowBuffer (repack vec0 uvec) n - return (vec', n + n) - else return (repack vec0 uvec, n) - unsafeWriteBuffer vec' i e - return (unpack vec', i + 1, n')) - w1 - -> (go_unchainIO_unknown sPEC uvec' i' n' s') w2 - - (# w1, Skip s' #) - -> (go_unchainIO_unknown sPEC uvec i n s') w1 - - (# w1, Done s' #) - -> (unIO $ do - vec' <- unsafeSliceBuffer 0 i (repack vec0 uvec) - arr <- unsafeFreezeBuffer (Z :. i) vec' - return (arr, s')) w1 - {-# INLINE go_unchainIO_unknown #-} --} diff --git a/Data/Repa/Eval/Stream.hs b/Data/Repa/Eval/Stream.hs --- a/Data/Repa/Eval/Stream.hs +++ b/Data/Repa/Eval/Stream.hs @@ -5,7 +5,6 @@ , unstreamToArray , unstreamToArrayIO) where -import Data.Repa.Fusion.Unpack import Data.Repa.Array.Generic.Index as A import Data.Repa.Array.Internals.Bulk as A import Data.Repa.Array.Internals.Target as A @@ -33,7 +32,7 @@ -- | Compute the elements of a pure `Stream`, -- writing them into a new array `Array`. unstreamToArray - :: (Target l a, Unpack (Buffer l a) t) + :: Target l a => Name l -> S.Stream S.Id a -> Array l a unstreamToArray nDst s @@ -46,7 +45,7 @@ -- | Compute the elements of an `IO` `Stream`, -- writing them to a new `Array`. unstreamToArrayIO - :: (Target l a, Unpack (Buffer l a) t) + :: Target l a => Name l -> S.Stream IO a -> IO (Array l a) unstreamToArrayIO nDst (S.Stream step s0 sz) @@ -84,9 +83,9 @@ = do !vec0 <- unsafeNewBuffer (create nDst zeroDim) !vec1 <- unsafeGrowBuffer vec0 nStart - let go_unstreamIO_unknown !sPEC !uvec !i !n !s - = go_unstreamIO_unknown1 (repack vec0 uvec) i n s - (\vec' i' n' s' -> go_unstreamIO_unknown sPEC (unpack vec') i' n' s') + let go_unstreamIO_unknown !sPEC !vec !i !n !s + = go_unstreamIO_unknown1 vec i n s + (\vec' i' n' s' -> go_unstreamIO_unknown sPEC vec' i' n' s') (\result -> return result) go_unstreamIO_unknown1 !vec !i !n !s cont done @@ -110,6 +109,7 @@ arr <- unsafeFreezeBuffer vec' done arr - go_unstreamIO_unknown S.SPEC (unpack vec1) 0 nStart s0 + go_unstreamIO_unknown S.SPEC vec1 0 nStart s0 {-# INLINE_INNER unstreamToArrayIO_unknown #-} {-# INLINE_STREAM unstreamToArrayIO #-} + diff --git a/Data/Repa/Nice.hs b/Data/Repa/Nice.hs --- a/Data/Repa/Nice.hs +++ b/Data/Repa/Nice.hs @@ -4,12 +4,13 @@ , Str (..) , Tok (..)) where -import Data.Repa.Array.Generic as A -import Data.Repa.Product as B -import Control.Monad -import Data.Word import Data.Int -import Prelude as P +import Data.Word +import Control.Monad +import Data.Repa.Array.Generic as A +import Data.Repa.Scalar.Product as B +import Data.Repa.Scalar.Date32 (Date32) +import Prelude as P -- | Wrapper to indicate a list of characters should be printed as a string, @@ -106,6 +107,12 @@ instance Nicer Word64 where type Nice Word64 = Word64 nice x = x + +-- Dates +instance Nicer Date32 where + type Nice Date32 = Date32 + nice x = x + -- Lists ---------------------------------------------------------------------- diff --git a/Data/Repa/Nice/Present.hs b/Data/Repa/Nice/Present.hs --- a/Data/Repa/Nice/Present.hs +++ b/Data/Repa/Nice/Present.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE TypeSynonymInstances, FlexibleInstances, OverlappingInstances #-} +{-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-} module Data.Repa.Nice.Present ( Presentable (..) , Present (..) @@ -11,14 +11,22 @@ where import Data.Monoid import Data.Word -import Data.Text (Text) -import qualified Data.Text as T -import Data.Repa.Nice (Str(..), Tok(..)) +import Data.Text (Text) +import Data.Repa.Nice (Str(..), Tok(..)) +import Data.Repa.Scalar.Product ((:*:) (..)) +import Data.Repa.Scalar.Date32 (Date32) +import qualified Data.Text as T +import qualified Data.Repa.Scalar.Date32 as Date32 +import Prelude as P + -- | A value, wrapped up nicely. data Present + -- | Nothing to present. + = Blank + -- | An atomic thing. - = Atom Text + | Atom Text -- | Many of the same thing, to display with list brackets @[.. , ..]@ | Many [Present] @@ -32,6 +40,7 @@ depth :: Present -> Int depth pp = case pp of + Blank{} -> 0 Atom{} -> 0 Many ps -> 1 + (case ps of [] -> 0 @@ -53,6 +62,7 @@ -- | Flatten a present into text flatten :: Present -> Text +flatten Blank = T.pack "" flatten (Atom str) = str flatten (Many ps) = T.pack "[" <> (T.intercalate (T.pack ",") $ map flatten ps) <> T.pack "]" @@ -69,54 +79,101 @@ class Presentable a where present :: a -> Present + +instance Presentable () where + present _ = Blank + + instance Presentable Char where present = Atom . T.pack . show + instance Presentable Int where present = Atom . T.pack . show + instance Presentable Float where present = Atom . T.pack . show + instance Presentable Double where present = Atom . T.pack . show + instance Presentable Word8 where present = Atom . T.pack . show + instance Presentable Word16 where present = Atom . T.pack . show + instance Presentable Word32 where present = Atom . T.pack . show + instance Presentable Word64 where present = Atom . T.pack . show + +instance Presentable Date32 where + present d + | (yy, mm, dd) <- Date32.unpack d + = let cSep = '/' + yy' = show yy + mm' = if mm < 10 then "0" ++ show mm else show mm + dd' = if dd < 10 then "0" ++ show dd else show dd + in Atom $ T.pack $ P.concat [yy', [cSep], mm', [cSep], dd'] + + instance Presentable Str where present (Str xs) = Atom $ T.pack (show xs) + instance Presentable Tok where present (Tok xs) = Atom $ T.pack xs + instance Presentable a => Presentable [a] where present xs = Many $ map present xs + instance (Presentable a, Presentable b) + => Presentable (a :*: b) where + + present (xa :*: xb) + = let aa = case present xa of + Blank -> [] + Atom x -> [Atom x] + Many xx -> xx + Some xx -> xx + + bb = case present xb of + Blank -> [] + Atom x -> [Atom x] + Many xx -> xx + Some xx -> xx + in Some (aa ++ bb) + + +instance (Presentable a, Presentable b) => Presentable (a, b) where present (a, b) = Some [present a, present b] + instance (Presentable a, Presentable b, Presentable c) => Presentable (a, b, c) where present (a, b, c) = Some [present a, present b, present c] + instance (Presentable a, Presentable b, Presentable c, Presentable d) => Presentable (a, b, c, d) where present (a, b, c, d) = Some [present a, present b, present c, present d] + instance (Presentable a, Presentable b, Presentable c, Presentable d, Presentable e) => Presentable (a, b, c, d, e) where diff --git a/Data/Repa/Nice/Tabulate.hs b/Data/Repa/Nice/Tabulate.hs --- a/Data/Repa/Nice/Tabulate.hs +++ b/Data/Repa/Nice/Tabulate.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE UndecidableInstances, OverlappingInstances #-} +{-# LANGUAGE UndecidableInstances #-} module Data.Repa.Nice.Tabulate ( tab , tabulate @@ -10,7 +10,6 @@ import Data.List as L import qualified Data.Text as T import Data.Text (Text) -import Data.Monoid import Data.Maybe diff --git a/repa-array.cabal b/repa-array.cabal --- a/repa-array.cabal +++ b/repa-array.cabal @@ -1,5 +1,5 @@ Name: repa-array -Version: 4.1.0.1 +Version: 4.2.2.1 License: BSD3 License-file: LICENSE Author: The Repa Development Team @@ -24,35 +24,39 @@ Library build-Depends: - base == 4.7.*, - primitive == 0.5.*, + base == 4.8.*, + primitive == 0.6.*, vector == 0.10.*, bytestring == 0.10.*, mtl == 2.2.*, double-conversion == 2.0.*, text == 1.2.*, repa-eval == 4.0.0.*, - repa-stream == 4.1.0.*, - repa-convert == 4.1.0.* + repa-stream == 4.2.2.*, + repa-scalar == 4.2.2.*, + repa-convert == 4.2.2.*, + filelock >= 0.1.0 && < 0.2 + exposed-modules: Data.Repa.Array.Auto Data.Repa.Array.Auto.IO + Data.Repa.Array.Auto.XSV Data.Repa.Array.Auto.Convert - Data.Repa.Array.Auto.Unpack + Data.Repa.Array.Auto.Format Data.Repa.Array.Generic.Convert Data.Repa.Array.Generic.Index - Data.Repa.Array.Generic.Load Data.Repa.Array.Generic.Slice + Data.Repa.Array.Generic.Load Data.Repa.Array.Generic.Target + Data.Repa.Array.Generic.Unpacks Data.Repa.Array.Generic Data.Repa.Array.Material.Auto Data.Repa.Array.Material.Boxed Data.Repa.Array.Material.Foreign - Data.Repa.Array.Material.Strided Data.Repa.Array.Material.Nested Data.Repa.Array.Material.Unboxed Data.Repa.Array.Material @@ -66,8 +70,6 @@ Data.Repa.Array.Meta.Window Data.Repa.Array.Meta - Data.Repa.Bits.Date32 - Data.Repa.Eval.Chain Data.Repa.Eval.Stream @@ -84,9 +86,21 @@ Data.Repa.Array.Auto.Base Data.Repa.Array.Auto.Operator + Data.Repa.Array.Material.Auto.Operator.Lines + Data.Repa.Array.Material.Auto.Operator.Unpackables Data.Repa.Array.Material.Auto.Base + Data.Repa.Array.Material.Auto.InstArray + Data.Repa.Array.Material.Auto.InstBox + Data.Repa.Array.Material.Auto.InstChar + Data.Repa.Array.Material.Auto.InstDate32 Data.Repa.Array.Material.Auto.InstFloat Data.Repa.Array.Material.Auto.InstInt + Data.Repa.Array.Material.Auto.InstList + Data.Repa.Array.Material.Auto.InstMaybe + Data.Repa.Array.Material.Auto.InstProduct + Data.Repa.Array.Material.Auto.InstText + Data.Repa.Array.Material.Auto.InstTuple + Data.Repa.Array.Material.Auto.InstUnit Data.Repa.Array.Material.Auto.InstWord Data.Repa.Array.Material.Foreign.Base @@ -98,7 +112,9 @@ Data.Repa.Array.Internals.Operator.Merge Data.Repa.Array.Internals.Operator.Insert Data.Repa.Array.Internals.Operator.Partition + Data.Repa.Array.Internals.Operator.Process Data.Repa.Array.Internals.Operator.Reduce + Data.Repa.Array.Internals.Operator.Replicate Data.Repa.Array.Internals.Operator.Filter Data.Repa.Array.Internals.Bulk @@ -120,26 +136,26 @@ extensions: CPP - BangPatterns - NoMonomorphismRestriction - RankNTypes MagicHash - UnboxedTuples - ScopedTypeVariables + DataKinds + RankNTypes + InstanceSigs + TypeFamilies + ViewPatterns + BangPatterns PatternGuards - FlexibleInstances - FlexibleContexts + UnboxedTuples TypeOperators - TypeFamilies - DefaultSignatures - MultiParamTypeClasses EmptyDataDecls + ConstraintKinds + PatternSynonyms + FlexibleContexts + DefaultSignatures + FlexibleInstances StandaloneDeriving + ScopedTypeVariables + MultiParamTypeClasses FunctionalDependencies - ConstraintKinds ForeignFunctionInterface - ViewPatterns + NoMonomorphismRestriction ExistentialQuantification - InstanceSigs - -