module Data.Repa.Scalar.Date32 ( Date32 -- * Projections , year, month, day -- * Packing and Unpacking , pack , unpack -- * Operators , next , diffDays -- * 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 Data.Time.Calendar as Time 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 {-# INLINE year #-} -- | Take the month number of a `Date32`. month :: Date32 -> Int month date = case unpack date of (_, mm, _) -> mm {-# INLINE month #-} -- | Take the day number of a `Date32`. day :: Date32 -> Int day date = case unpack date of (_, _, dd) -> dd {-# INLINE day #-} --------------------------------------------------------------------------------------------------- -- | 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' #-} -- | Take the number of days between two `Date32`s diffDays :: Date32 -> Date32 -> Integer diffDays date1 date2 | (y1, m1, d1) <- unpack date1 , (y2, m2, d2) <- unpack date2 = Time.diffDays (Time.fromGregorian (fromIntegral y1) m1 d1) (Time.fromGregorian (fromIntegral y2) m2 d2) --------------------------------------------------------------------------------------------------- -- | 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# <- 4# <=# len_ , (# 1#, yy, ix' #) <- loadInt' buf 4# = sep1 ix' yy | otherwise = return Nothing sep1 ix yy | 1# <- (ix +# 1#) <=# 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 +# 2#) <=# len_ , (# 1#, mm, o #) <- loadInt' (buf `F.plusPtr` (I# ix)) 2# = sep2 (ix +# o) yy mm | otherwise = return Nothing sep2 ix yy mm | 1# <- (ix +# 1#) <=# 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 +# 2#) <=# len_ , (# 1#, dd, o #) <- loadInt' (buf `F.plusPtr` (I# ix)) 2# = return $ Just (pack ( fromIntegral (I# yy) , fromIntegral (I# mm) , fromIntegral (I# dd)) , I# (ix +# o)) | otherwise = return Nothing {-# NOINLINE 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# <- 2# <=# len_ , (# 1#, dd, o #) <- loadInt' buf 2# = sep1 o dd | otherwise = return Nothing sep1 ix dd | 1# <- (ix +# 1#) <=# 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 +# 2#) <=# len_ , (# 1#, mm, o #) <- loadInt' (buf `F.plusPtr` (I# ix)) 2# = sep2 (ix +# o) dd mm | otherwise = return Nothing sep2 ix dd mm | 1# <- (ix +# 1#) <=# 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 +# 4#) <=# len_ , (# 1#, yy, o #) <- loadInt' (buf `F.plusPtr` (I# ix)) 4# = return $ Just (pack ( fromIntegral (I# yy) , fromIntegral (I# mm) , fromIntegral (I# dd)) , I# (ix +# o)) | otherwise = return Nothing {-# NOINLINE loadDDsMMsYYYY #-} loadInt' (Ptr addr) len = loadInt# addr len {-# INLINE loadInt' #-}