repa-array-4.1.0.1: Data/Repa/Bits/Date32.hs
{-# 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 #-}