{-# 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 #-}