diff --git a/Data/Repa/Scalar/Date32.hs b/Data/Repa/Scalar/Date32.hs new file mode 100644 --- /dev/null +++ b/Data/Repa/Scalar/Date32.hs @@ -0,0 +1,260 @@ + +module Data.Repa.Scalar.Date32 + ( Date32 + + -- * Projections + , year, month, day + + -- * Packing and Unpacking + , pack + , unpack + + -- * Operators + , next + + -- * Loading + , loadYYYYsMMsDD + , loadDDsMMsYYYY) +where +import Data.Word +import Data.Bits +import GHC.Exts +import GHC.Word +import Foreign.Storable +import Foreign.Ptr +import Control.Monad +import Data.Repa.Scalar.Int +import qualified Foreign.Ptr as F +import qualified Foreign.Storable as F +import Prelude as P + + +-- | 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 #-} + + +--------------------------------------------------------------------------------------------------- +-- | 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 :: (Int, Int, Int) -> 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 -> (Int, Int, Int) +unpack (Date32 date) + = ( fromIntegral $ (date `shiftR` 16) .&. 0x0ffff + , fromIntegral $ (date `shiftR` 8) .&. 0x0ff + , fromIntegral $ date .&. 0x0ff) +{-# INLINE unpack #-} + + +-- | Take the year number of a `Date32`. +year :: Date32 -> Int +year date + = case unpack date of + (yy, _, _) -> yy + + +-- | Take the month number of a `Date32`. +month :: Date32 -> Int +month date + = case unpack date of + (_, mm, _) -> mm + + +-- | Take the day number of a `Date32`. +day :: Date32 -> Int +day date + = case unpack date of + (_, _, dd) -> dd + + +--------------------------------------------------------------------------------------------------- +-- | 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' #-} + + +--------------------------------------------------------------------------------------------------- +-- | Read a date in YYYYsMMsDD format from the given buffer. +loadYYYYsMMsDD + :: Word8 -- ^ Separating character. + -> Ptr Word8 -- ^ Buffer. + -> Int -- ^ Length of buffer. + -> IO (Maybe (Date32, Int)) -- ^ Result. + +loadYYYYsMMsDD !sep !buf (I# len_) + = loadYear + where loadYear + | (# 1#, yy, ix' #) <- loadInt# buf len_ + = sep1 ix' yy + | otherwise = return Nothing + + sep1 ix yy + | 1# <- ix <# len_ + = F.peekByteOff buf (I# ix) >>= \(r :: Word8) + -> if r == sep + then loadMonth (ix +# 1#) yy + else return Nothing + + | otherwise = return Nothing + + loadMonth ix yy + | 1# <- ix <# len_ + , (# 1#, mm, o #) <- loadInt# (buf `F.plusPtr` (I# ix)) len_ + = sep2 (ix +# o) yy mm + | otherwise = return Nothing + + sep2 ix yy mm + | 1# <- ix <# len_ + = F.peekByteOff buf (I# ix) >>= \(r :: Word8) + -> if r == sep + then loadDay (ix +# 1#) yy mm + else return Nothing + + | otherwise = return Nothing + + loadDay ix yy mm + | 1# <- ix <# len_ + , (# 1#, dd, o #) <- loadInt# (buf `F.plusPtr` (I# ix)) len_ + = return + $ Just (pack ( fromIntegral (I# yy) + , fromIntegral (I# mm) + , fromIntegral (I# dd)) + , I# (ix +# o)) + + | otherwise = return Nothing +{-# INLINE loadYYYYsMMsDD #-} + + +--------------------------------------------------------------------------------------------------- +-- | Read a date in YYYYsMMsDD format from the given buffer. +loadDDsMMsYYYY + :: Word8 -- ^ Separating character. + -> Ptr Word8 -- ^ Buffer. + -> Int -- ^ Length of buffer. + -> IO (Maybe (Date32, Int)) -- ^ Result. + +loadDDsMMsYYYY !sep !buf (I# len_) + = loadDay + where loadDay + | (# 1#, dd, ix' #) <- loadInt# buf len_ + = sep1 ix' dd + | otherwise = return Nothing + + sep1 ix dd + | 1# <- ix <# len_ + = F.peekByteOff buf (I# ix) >>= \(r :: Word8) + -> if r == sep + then loadMonth (ix +# 1#) dd + else return Nothing + + | otherwise = return Nothing + + loadMonth ix dd + | 1# <- ix <# len_ + , (# 1#, mm, o #) <- loadInt# (buf `F.plusPtr` (I# ix)) len_ + = sep2 (ix +# o) dd mm + | otherwise = return Nothing + + sep2 ix dd mm + | 1# <- ix <# len_ + = F.peekByteOff buf (I# ix) >>= \(r :: Word8) + -> if r == sep + then loadYear (ix +# 1#) dd mm + else return Nothing + + | otherwise = return Nothing + + loadYear ix dd mm + | 1# <- ix <# len_ + , (# 1#, yy, o #) <- loadInt# (buf `F.plusPtr` (I# ix)) len_ + = return + $ Just (pack ( fromIntegral (I# yy) + , fromIntegral (I# mm) + , fromIntegral (I# dd)) + , I# (ix +# o)) + + | otherwise = return Nothing +{-# INLINE loadDDsMMsYYYY #-} + + diff --git a/Data/Repa/Scalar/Double.hs b/Data/Repa/Scalar/Double.hs new file mode 100644 --- /dev/null +++ b/Data/Repa/Scalar/Double.hs @@ -0,0 +1,79 @@ + +-- | Loading and storing doubles directly from/to memory buffers. +module Data.Repa.Scalar.Double + ( -- * Loading + loadDouble + + -- * Storing + , storeDoubleShortest + , storeDoubleFixed) +where +import Data.Word +import GHC.Exts +import qualified Data.ByteString.Internal as BS +import qualified Data.Double.Conversion.ByteString as DC +import qualified Foreign.Ptr as F +import qualified Foreign.ForeignPtr as F +import qualified Foreign.Storable as F +import qualified Foreign.Marshal.Alloc as F +import qualified Foreign.Marshal.Utils as F + + +-- Double ----------------------------------------------------------------------------------------- +-- | Load an ASCII `Double` from a foreign buffer +-- returning the value and number of characters read. +loadDouble + :: Ptr Word8 -- ^ Buffer holding ASCII representation. + -> Int -- ^ Length of buffer. + -> IO (Double, Int) -- ^ Result, and number of characters read from buffer. + +loadDouble !pIn !len + = F.allocaBytes (len + 1) $ \pBuf -> + F.alloca $ \pRes -> + do + -- Copy the data to our new buffer. + F.copyBytes pBuf pIn (fromIntegral len) + + -- Poke a 0 on the end to ensure it's null terminated. + F.pokeByteOff pBuf len (0 :: Word8) + + -- Call the C strtod function + let !d = strtod pBuf pRes + + -- Read back the end pointer. + res <- F.peek pRes + + return (d, res `F.minusPtr` pBuf) +{-# INLINE loadDouble #-} + + +-- TODO: strtod will skip whitespace before the actual double, +-- but we probably want to avoid this to be consistent. +foreign import ccall unsafe + strtod :: Ptr Word8 -> Ptr (Ptr Word8) -> Double + + + +-- | Store an ASCII `Double`, yielding a freshly allocated buffer +-- and its length. +-- +-- * The value is printed as either (sign)digits.digits, +-- or in exponential format, depending on which is shorter. +-- +-- * The result is buffer not null terminated. +-- +storeDoubleShortest :: Double -> IO (F.ForeignPtr Word8, Int) +storeDoubleShortest d + = case DC.toShortest d of + BS.PS p _ n -> return (p, n) +{-# INLINE storeDoubleShortest #-} + + +-- | Like `showDoubleShortest`, but use a fixed number of digits after +-- the decimal point. +storeDoubleFixed :: Int -> Double -> IO (F.ForeignPtr Word8, Int) +storeDoubleFixed !prec !d + = case DC.toFixed prec d of + BS.PS p _ n -> return (p, n) +{-# INLINE storeDoubleFixed #-} + diff --git a/Data/Repa/Scalar/Int.hs b/Data/Repa/Scalar/Int.hs new file mode 100644 --- /dev/null +++ b/Data/Repa/Scalar/Int.hs @@ -0,0 +1,127 @@ + +-- | Loading and storing integers directly from/to memory buffers. +module Data.Repa.Scalar.Int + ( -- * Loading + loadInt + , loadInt# + , loadIntWith# + + -- * Storing + , storeInt) +where +import Data.Word +import Data.Char +import GHC.Exts +import qualified Data.ByteString.Internal as BS +import qualified Data.Double.Conversion.ByteString as DC +import qualified Foreign.ForeignPtr as F +import qualified Foreign.Storable as F + + +-- Int -------------------------------------------------------------------------------------------- +-- | Load an ASCII `Int` from a foreign buffer, +-- returning the value and number of characters read. +loadInt :: Ptr Word8 -- ^ Buffer holding digits. + -> Int -- ^ Length of buffer. + -> IO (Maybe (Int, Int)) -- ^ Int read, and length of digits. + +loadInt !ptr (I# len) + = case loadInt# ptr len of + (# 0#, _, _ #) -> return $ Nothing + (# _, n, ix #) -> return $ Just (I# n, I# ix) +{-# INLINE loadInt #-} + + +-- | Like `loadInt`, but via unboxed types. +loadInt# + :: Ptr Word8 -- ^ Buffer holding digits. + -> Int# -- ^ Length of buffer. + -> (# Int#, Int#, Int# #) -- ^ Convert success?, value, length read. + +loadInt# buf len + = let peek8 ix + -- accursed .. may increase sharing of the result value, + -- but this isn't a problem here because the result is not + -- mutable, and will be unboxed by the simplifier anyway. + = case BS.accursedUnutterablePerformIO (F.peekByteOff buf (I# ix)) of + (w8 :: Word8) -> case fromIntegral w8 of + I# i -> i + {-# INLINE peek8 #-} + + in loadIntWith# peek8 len +{-# NOINLINE loadInt# #-} + + +-- | Like `loadInt#`, but use the given function to get characters +-- from the input buffer. +loadIntWith# + :: (Int# -> Int#) -- ^ Function to get a byte from the source. + -> Int# -- ^ Length of buffer + -> (# Int#, Int#, Int# #) -- ^ Convert success?, value, length read. + +loadIntWith# !get len + = start 0# + where + start !ix + | 1# <- ix >=# len = (# 0#, 0#, 0# #) + | otherwise = sign ix + {-# INLINE start #-} + + -- Check for explicit sign character, + -- and encode what it was as an integer. + sign !ix + | !s <- get 0# + = case chr $ fromIntegral (I# s) of + '-' -> loop 1# (ix +# 1#) 0# + '+' -> loop 2# (ix +# 1#) 0# + _ -> loop 0# ix 0# + {-# INLINE sign #-} + + loop !neg !ix !n + -- We've hit the end of the array. + | 1# <- ix >=# len + = end neg ix n + + | otherwise + = case get ix of + -- Current character is a digit, so add it to the accmulator. + w | 1# <- w >=# 0x30# + , 1# <- w <=# 0x039# + -> loop neg ( ix +# 1#) + ((n *# 10#) +# (w -# 0x30#)) + + -- Current character is not a digit. + | otherwise + -> end neg ix n + + end !neg !ix !n + -- We didn't find any digits, and there was no explicit sign. + | 1# <- ix ==# 0# + , 1# <- neg ==# 0# + = (# 0#, 0#, 0# #) + + -- We didn't find any digits, but there was an explicit sign. + | 1# <- ix ==# 1# + , 1# <- neg /=# 0# + = (# 0#, 0#, 0# #) + + -- Number was explicitly negated. + | 1# <- neg ==# 1# + , I# n' <- negate (I# n) + = (# 1#, n', ix #) + + -- Number was not negated. + | otherwise + = (# 1#, n, ix #) + {-# NOINLINE end #-} +{-# INLINE loadIntWith# #-} + + +-- | Store an ASCII `Int`, allocating a new buffer. +storeInt :: Int -> IO (F.ForeignPtr Word8) +storeInt i + = case DC.toFixed 0 (fromIntegral i) of + BS.PS p _ _ -> return p +{-# INLINE storeInt #-} + + diff --git a/Data/Repa/Scalar/Product.hs b/Data/Repa/Scalar/Product.hs new file mode 100644 --- /dev/null +++ b/Data/Repa/Scalar/Product.hs @@ -0,0 +1,266 @@ +{-# OPTIONS_GHC -fno-warn-unticked-promoted-constructors #-} +module Data.Repa.Scalar.Product + ( -- * Product type + (:*:) (..) + , IsProdList (..) + + -- * Selecting + , Select (..) + + -- * Discarding + , Discard (..), Keep(..), Drop(..) + + -- * Masking + , Mask (..)) +where +import Data.Repa.Scalar.Singleton.Nat +import qualified Data.Vector.Unboxed as U +import qualified Data.Vector.Generic as G +import qualified Data.Vector.Generic.Mutable as M + + +--------------------------------------------------------------------------------------------------- +-- | Strict product type, written infix. +data a :*: b + = !a :*: !b + deriving (Eq, Show) + +infixr :*: + + +class IsProdList p where + -- | Check if a sequence of products forms a valid list, + -- using () for the nil value. + -- + -- @ + -- isProdList (1 :*: 4 :*: 5) ... no instance + -- + -- isProdList (1 :*: 4 :*: ()) = True + -- @ + -- + isProdList :: p -> Bool + +instance IsProdList () where + isProdList _ = True + {-# INLINE isProdList #-} + + +instance IsProdList fs => IsProdList (f :*: fs) where + isProdList (_ :*: xs) = isProdList xs + {-# INLINE isProdList #-} + + +--------------------------------------------------------------------------------------------------- +class IsProdList t + => Select (n :: N) t where + type Select' n t + -- | Return just the given field in this tuple. + select :: Nat n -> t -> Select' n t + + +instance IsProdList ts + => Select Z (t1 :*: ts) where + type Select' Z (t1 :*: ts) = t1 + select Zero (t1 :*: _) = t1 + {-# INLINE select #-} + + +instance Select n ts + => Select (S n) (t1 :*: ts) where + type Select' (S n) (t1 :*: ts) = Select' n ts + select (Succ n) (_ :*: xs) = select n xs + {-# INLINE select #-} + + +--------------------------------------------------------------------------------------------------- +class IsProdList t + => Discard (n :: N) t where + type Discard' n t + -- | Discard the given field in this tuple. + discard :: Nat n -> t -> Discard' n t + + +instance IsProdList ts + => Discard Z (t1 :*: ts) where + type Discard' Z (t1 :*: ts) = ts + discard Zero (_ :*: xs) = xs + {-# INLINE discard #-} + + +instance Discard n ts + => Discard (S n) (t1 :*: ts) where + type Discard' (S n) (t1 :*: ts) = t1 :*: Discard' n ts + discard (Succ n) (x1 :*: xs) = x1 :*: discard n xs + {-# INLINE discard #-} + + +--------------------------------------------------------------------------------------------------- +-- | Singleton to indicate a field that should be dropped. +data Drop = Drop + +-- | Singleton to indicate a field that should be kept. +data Keep = Keep + + +-- | Class of data types that can have parts masked out. +class (IsProdList m, IsProdList t) => Mask m t where + type Mask' m t + -- | Mask out some component of a type. + -- + -- @ + -- mask (Keep :*: Drop :*: Keep :*: ()) + -- (1 :*: \"foo\" :*: \'a\' :*: ()) = (1 :*: \'a\' :*: ()) + -- + -- mask (Drop :*: Drop :*: Drop :*: ()) + -- (1 :*: \"foo\" :*: \'a\' :*: ()) = () + -- @ + -- + mask :: m -> t -> Mask' m t + + +instance Mask () () where + type Mask' () () = () + mask () () = () + {-# INLINE mask #-} + + +instance Mask ms ts + => Mask (Keep :*: ms) (t1 :*: ts) where + type Mask' (Keep :*: ms) (t1 :*: ts) = t1 :*: Mask' ms ts + mask (_ :*: ms) (x1 :*: xs) = x1 :*: mask ms xs + {-# INLINE mask #-} + + +instance Mask ms ts + => Mask (Drop :*: ms) (t1 :*: ts) where + type Mask' (Drop :*: ms) (t1 :*: ts) = Mask' ms ts + mask (_ :*: ms) (_ :*: xs) = mask ms xs + {-# INLINE mask #-} + + +-- Unboxed ---------------------------------------------------------------------------------------- +-- Unboxed instance adapted from: +-- http://code.haskell.org/vector/internal/unbox-tuple-instances +-- +data instance U.Vector (a :*: b) + = V_Prod + {-# UNPACK #-} !Int + !(U.Vector a) + !(U.Vector b) + + +instance (U.Unbox a, U.Unbox b) + => U.Unbox (a :*: b) + + +data instance U.MVector s (a :*: b) + = MV_Prod {-# UNPACK #-} !Int + !(U.MVector s a) + !(U.MVector s b) + + +instance (U.Unbox a, U.Unbox b) + => M.MVector U.MVector (a :*: b) where + + basicLength (MV_Prod n_ _as _bs) = n_ + {-# INLINE basicLength #-} + + basicUnsafeSlice i_ m_ (MV_Prod _n_ as bs) + = MV_Prod m_ (M.basicUnsafeSlice i_ m_ as) + (M.basicUnsafeSlice i_ m_ bs) + {-# INLINE basicUnsafeSlice #-} + + basicOverlaps (MV_Prod _n_1 as1 bs1) (MV_Prod _n_2 as2 bs2) + = M.basicOverlaps as1 as2 + || M.basicOverlaps bs1 bs2 + {-# INLINE basicOverlaps #-} + + basicUnsafeNew n_ + = do as <- M.basicUnsafeNew n_ + bs <- M.basicUnsafeNew n_ + return $ MV_Prod n_ as bs + {-# INLINE basicUnsafeNew #-} + + basicUnsafeReplicate n_ (a :*: b) + = do as <- M.basicUnsafeReplicate n_ a + bs <- M.basicUnsafeReplicate n_ b + return $ MV_Prod n_ as bs + {-# INLINE basicUnsafeReplicate #-} + + basicUnsafeRead (MV_Prod _n_ as bs) i_ + = do a <- M.basicUnsafeRead as i_ + b <- M.basicUnsafeRead bs i_ + return (a :*: b) + {-# INLINE basicUnsafeRead #-} + + basicUnsafeWrite (MV_Prod _n_ as bs) i_ (a :*: b) + = do M.basicUnsafeWrite as i_ a + M.basicUnsafeWrite bs i_ b + {-# INLINE basicUnsafeWrite #-} + + basicClear (MV_Prod _n_ as bs) + = do M.basicClear as + M.basicClear bs + {-# INLINE basicClear #-} + + basicSet (MV_Prod _n_ as bs) (a :*: b) + = do M.basicSet as a + M.basicSet bs b + {-# INLINE basicSet #-} + + basicUnsafeCopy (MV_Prod _n_1 as1 bs1) (MV_Prod _n_2 as2 bs2) + = do M.basicUnsafeCopy as1 as2 + M.basicUnsafeCopy bs1 bs2 + {-# INLINE basicUnsafeCopy #-} + + basicUnsafeMove (MV_Prod _n_1 as1 bs1) (MV_Prod _n_2 as2 bs2) + = do M.basicUnsafeMove as1 as2 + M.basicUnsafeMove bs1 bs2 + {-# INLINE basicUnsafeMove #-} + + basicUnsafeGrow (MV_Prod n_ as bs) m_ + = do as' <- M.basicUnsafeGrow as m_ + bs' <- M.basicUnsafeGrow bs m_ + return $ MV_Prod (m_ + n_) as' bs' + {-# INLINE basicUnsafeGrow #-} + + +instance (U.Unbox a, U.Unbox b) + => G.Vector U.Vector (a :*: b) where + basicUnsafeFreeze (MV_Prod n_ as bs) + = do as' <- G.basicUnsafeFreeze as + bs' <- G.basicUnsafeFreeze bs + return $ V_Prod n_ as' bs' + {-# INLINE basicUnsafeFreeze #-} + + basicUnsafeThaw (V_Prod n_ as bs) + = do as' <- G.basicUnsafeThaw as + bs' <- G.basicUnsafeThaw bs + return $ MV_Prod n_ as' bs' + {-# INLINE basicUnsafeThaw #-} + + basicLength (V_Prod n_ _as _bs) + = n_ + {-# INLINE basicLength #-} + + basicUnsafeSlice i_ m_ (V_Prod _n_ as bs) + = V_Prod m_ (G.basicUnsafeSlice i_ m_ as) + (G.basicUnsafeSlice i_ m_ bs) + {-# INLINE basicUnsafeSlice #-} + + basicUnsafeIndexM (V_Prod _n_ as bs) i_ + = do a <- G.basicUnsafeIndexM as i_ + b <- G.basicUnsafeIndexM bs i_ + return (a :*: b) + {-# INLINE basicUnsafeIndexM #-} + + basicUnsafeCopy (MV_Prod _n_1 as1 bs1) (V_Prod _n_2 as2 bs2) + = do G.basicUnsafeCopy as1 as2 + G.basicUnsafeCopy bs1 bs2 + {-# INLINE basicUnsafeCopy #-} + + elemseq _ (a :*: b) + = G.elemseq (undefined :: U.Vector a) a + . G.elemseq (undefined :: U.Vector b) b + {-# INLINE elemseq #-} + diff --git a/Data/Repa/Scalar/Singleton/Bool.hs b/Data/Repa/Scalar/Singleton/Bool.hs new file mode 100644 --- /dev/null +++ b/Data/Repa/Scalar/Singleton/Bool.hs @@ -0,0 +1,18 @@ +{-# OPTIONS_GHC -fno-warn-unticked-promoted-constructors #-} +module Data.Repa.Scalar.Singleton.Bool + ( B (..) + , Boolean (..)) +where + +data B = Y | N + +deriving instance Show B + + +data Boolean (b :: B) where + Yes :: Boolean Y + No :: Boolean N + +deriving instance Show (Boolean b) + + diff --git a/Data/Repa/Scalar/Singleton/Nat.hs b/Data/Repa/Scalar/Singleton/Nat.hs new file mode 100644 --- /dev/null +++ b/Data/Repa/Scalar/Singleton/Nat.hs @@ -0,0 +1,106 @@ +{-# OPTIONS_GHC -fno-warn-unticked-promoted-constructors #-} +{-# LANGUAGE UndecidableInstances #-} +-- | Singleton-typed natural numbers and arithmetic. +-- +-- Used for indexing into hetrogenous list types. +-- +module Data.Repa.Scalar.Singleton.Nat + ( N (..) + , Nat (..) + , Add (..) + , Mul (..) + + -- * Literals + , nat0, nat1, nat2, nat3, nat4, nat5, nat6, nat7, nat8, nat9) +where + + +-- | Peano natural numbers. +data N = Z | S N + + +deriving instance Show N + + +-- | Peano natural number singletons. +data Nat (n :: N) where + Zero :: Nat Z + Succ :: Nat n -> Nat (S n) + +deriving instance Show (Nat n) + + +--------------------------------------------------------------------------------------------------- +class Add x y where + type AddR x y :: N + -- | Addition of singleton typed natural numbers. + add :: Nat x -> Nat y -> Nat (AddR x y) + +instance Add Z x where + type AddR Z y = y + add Zero y = y + {-# INLINE add #-} + +instance Add x (S y) => Add (S x) y where + type AddR (S x) y = AddR x (S y) + add (Succ x) y = add x (Succ y) + {-# INLINE add #-} + + +--------------------------------------------------------------------------------------------------- +class Mul x y where + type MulR x y :: N + -- | Multiplication of singleton typed natural numbers. + mul :: Nat x -> Nat y -> Nat (MulR x y) + +instance Mul Z x where + type MulR Z y = Z + mul Zero _ = Zero + +instance (Mul x y, Add (MulR x y) y) + => Mul (S x) y where + type MulR (S x) y = AddR (MulR x y) y + mul (Succ x) y = add (mul x y) y + + +--------------------------------------------------------------------------------------------------- +nat0 :: Nat Z +nat0 = Zero +{-# INLINE nat0 #-} + +nat1 :: Nat (S Z) +nat1 = Succ Zero +{-# INLINE nat1 #-} + +nat2 :: Nat (S (S Z)) +nat2 = Succ $ Succ Zero +{-# INLINE nat2 #-} + +nat3 :: Nat (S (S (S Z))) +nat3 = Succ $ Succ $ Succ Zero +{-# INLINE nat3 #-} + +nat4 :: Nat (S (S (S (S Z)))) +nat4 = Succ $ Succ $ Succ $ Succ Zero +{-# INLINE nat4 #-} + +nat5 :: Nat (S (S (S (S (S Z))))) +nat5 = Succ $ Succ $ Succ $ Succ $ Succ Zero +{-# INLINE nat5 #-} + +nat6 :: Nat (S (S (S (S (S (S Z)))))) +nat6 = Succ $ Succ $ Succ $ Succ $ Succ $ Succ Zero +{-# INLINE nat6 #-} + +nat7 :: Nat (S (S (S (S (S (S (S Z))))))) +nat7 = Succ $ Succ $ Succ $ Succ $ Succ $ Succ $ Succ Zero +{-# INLINE nat7 #-} + +nat8 :: Nat (S (S (S (S (S (S (S (S Z)))))))) +nat8 = Succ $ Succ $ Succ $ Succ $ Succ $ Succ $ Succ $ Succ Zero +{-# INLINE nat8 #-} + +nat9 :: Nat (S (S (S (S (S (S (S (S (S Z))))))))) +nat9 = Succ $ Succ $ Succ $ Succ $ Succ $ Succ $ Succ $ Succ $ Succ Zero +{-# INLINE nat9 #-} + diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,25 @@ +Copyright (c) 2014-2015, The Repa Development Team + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + +- Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. + +- Redistributions in binary form must reproduce the above copyright notice, + this list of conditions and the following disclaimer in the documentation + and/or other materials provided with the distribution. + +- The names of the copyright holders may not be used to endorse or promote + products derived from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, +INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND +FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE +COPYRIGHT HOLDERS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, +INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, +OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF +LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE +OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF +ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/repa-scalar.cabal b/repa-scalar.cabal new file mode 100644 --- /dev/null +++ b/repa-scalar.cabal @@ -0,0 +1,55 @@ +Name: repa-scalar +Version: 4.2.0.1 +License: BSD3 +License-file: LICENSE +Author: The Repa Development Team +Maintainer: Ben Lippmeier +Build-Type: Simple +Cabal-Version: >=1.6 +Stability: experimental +Category: Data Structures +Homepage: http://repa.ouroborus.net +Bug-reports: repa@ouroborus.net +Description: Scalar data types and conversions. +Synopsis: Scalar data types and conversions. + +source-repository head + type: git + location: https://github.com/DDCSF/repa.git + +Library + build-Depends: + base == 4.8.*, + primitive == 0.6.*, + vector == 0.10.*, + bytestring == 0.10.*, + double-conversion == 2.0.* + + exposed-modules: + Data.Repa.Scalar.Date32 + Data.Repa.Scalar.Double + Data.Repa.Scalar.Int + Data.Repa.Scalar.Singleton.Nat + Data.Repa.Scalar.Singleton.Bool + Data.Repa.Scalar.Product + + ghc-options: + -Wall -fno-warn-missing-signatures + -O2 + + + extensions: + GADTs + DataKinds + MagicHash + BangPatterns + TypeFamilies + UnboxedTuples + TypeOperators + KindSignatures + PatternGuards + FlexibleInstances + StandaloneDeriving + ScopedTypeVariables + MultiParamTypeClasses + ForeignFunctionInterface