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"
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
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
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)
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)
unsafeReadBuffer (ABuffer_Date32 arr) ix
= A.unsafeReadBuffer arr ix
unsafeWriteBuffer (ABuffer_Date32 arr) ix x
= A.unsafeWriteBuffer arr ix x
unsafeGrowBuffer (ABuffer_Date32 arr) bump
= liftM ABuffer_Date32 $ A.unsafeGrowBuffer arr bump
unsafeFreezeBuffer (ABuffer_Date32 arr)
= liftM AArray_Date32 $ A.unsafeFreezeBuffer arr
unsafeThawBuffer (AArray_Date32 arr)
= liftM ABuffer_Date32 $ A.unsafeThawBuffer arr
unsafeSliceBuffer st len (ABuffer_Date32 buf)
= liftM ABuffer_Date32 $ A.unsafeSliceBuffer st len buf
touchBuffer (ABuffer_Date32 buf)
= A.touchBuffer buf
bufferLayout (ABuffer_Date32 buf)
= A.Auto $ A.extent $ A.bufferLayout buf
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)
pack :: (Word, Word, Word) -> Date32
pack (yy, mm, dd)
= Date32
$ ((fromIntegral yy .&. 0x0ffff) `shiftL` 16)
.|. ((fromIntegral mm .&. 0x0ff) `shiftL` 8)
.|. (fromIntegral dd .&. 0x0ff)
unpack :: Date32 -> (Word, Word, Word)
unpack (Date32 date)
= ( fromIntegral $ (date `shiftR` 16) .&. 0x0ffff
, fromIntegral $ (date `shiftR` 8) .&. 0x0ff
, fromIntegral $ date .&. 0x0ff)
next :: Date32 -> Date32
next (Date32 (W32# date))
= Date32 (W32# (next' date))
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)
2 -> if yy `mod` 4 == 0
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)
4 -> if dd >= 30 then (yy, 5, 1) else (yy, mm, dd + 1)
5 -> if dd >= 31 then (yy, 6, 1) else (yy, mm, dd + 1)
6 -> if dd >= 30 then (yy, 7, 1) else (yy, mm, dd + 1)
7 -> if dd >= 31 then (yy, 8, 1) else (yy, mm, dd + 1)
8 -> if dd >= 31 then (yy, 9, 1) else (yy, mm, dd + 1)
9 -> if dd >= 30 then (yy, 10, 1) else (yy, mm, dd + 1)
10 -> if dd >= 31 then (yy, 11, 1) else (yy, mm, dd + 1)
11 -> if dd >= 30 then (yy, 12, 1) else (yy, mm, dd + 1)
12 -> if dd >= 31 then (yy + 1, 1, 1) else (yy, mm, dd + 1)
_ -> (0, 0, 0)
= case pack (yy', mm', dd') of
Date32 (W32# w) -> w
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)
pretty :: Char
-> Date32
-> 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']
readYYYYsMMsDD :: Char -> Array Char -> Maybe Date32
readYYYYsMMsDD !c !arr
| I# len <- A.length arr
, (# 1#, yy, ix1 #) <- readIntFromOffset# arr 0#
, 1# <- ix1 <# len
, arr `index` (I# ix1) == c
, (# 1#, mm, ix2 #) <- readIntFromOffset# arr (ix1 +# 1#)
, 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
readDDsMMsYYYY :: Char -> Array Char -> Maybe Date32
readDDsMMsYYYY !c !arr
| I# len <- A.length arr
, (# 1#, dd, ix1 #) <- readIntFromOffset# arr 0#
, 1# <- ix1 <# len
, arr `index` (I# ix1) == c
, (# 1#, mm, ix2 #) <- readIntFromOffset# arr (ix1 +# 1#)
, 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