{-# LINE 1 "Data/Time/Parse.hsc" #-}
{-# LANGUAGE ForeignFunctionInterface, FlexibleInstances #-}
{-# LINE 2 "Data/Time/Parse.hsc" #-}
------------------------------------------------------------
-- |
-- Copyright    :   (c) 2009 Eugene Kirpichov
-- License      :   BSD-style
--
-- Maintainer   :   ekirpichov@gmail.com
-- Stability    :   experimental
-- Portability  :   portable (H98 + FFI)
--
-- strptime wrapper
--
------------------------------------------------------------

module Data.Time.Parse (
    Strptime(..)
) where

import Foreign
import Foreign.C.Types
import Foreign.C.String
import Foreign.ForeignPtr
import Foreign.Marshal.Alloc
import GHC.Ptr

import Data.Time

import qualified Data.ByteString.Char8 as S
import qualified Data.ByteString.Internal as BI
import qualified Data.ByteString.Lazy.Char8 as L
import qualified Data.ByteString.Lazy.Internal as LI


{-# LINE 34 "Data/Time/Parse.hsc" #-}

{-# LINE 35 "Data/Time/Parse.hsc" #-}

-- | The class of values from which time may be parsed
class Strptime a where
    -- | Given a format string in the format of strptime (see <http://linux.die.net/man/3/strptime>)
    -- and a data string, parse a date+time value from the data string and also return the remainder
    -- of the data string. We also support a "%OS" format specifier for fractional seconds, because
    -- we are using the strptime from r-project.org. We also support "%^[+-][N]s" for multiples of 
    -- seconds since epoch, for example "%^-3s" is milliseconds since epoch (N can only be 1 digit)
    strptime  :: a -> a -> Maybe (LocalTime, a)

instance Strptime [Char] where
    strptime f = \s -> do
        (t, n) <- ff s
        return (t, drop n s)
      where ff = strptime_ f
instance Strptime L.ByteString where
    strptime f = \s -> do
        (t, n) <- ff s
        return (t, L.drop (fromIntegral n) s)
      where ff = strptime_ f

instance Strptime S.ByteString where
    strptime f = \s -> do
        (t, n) <- ff s
        return (t, S.drop (fromIntegral n) s)
      where ff = strptime_ f

class Strptime_ a where
    strptime_ :: a -> a -> Maybe (LocalTime, Int)

instance Strptime_ [Char] where
    strptime_ f s = strptime_ (S.pack f) (S.pack s)

instance Strptime_ L.ByteString where
    strptime_ f s = strptime_ (S.concat . L.toChunks $ f) (S.concat . L.toChunks $ s)

instance Strptime_ S.ByteString where
    strptime_ f = unsafePerformIO $ do
      -- Avoid memcpy-ing the format string every time.
      let (pf, ofs, len) = BI.toForeignPtr f
      ztf <- mallocBytes (len+1)
      copyBytes ztf (unsafeForeignPtrToPtr pf) len
      pokeByteOff ztf len (0::Word8)
      fztf <- newForeignPtr_ ztf
      addForeignPtrFinalizer finalizerFree fztf

      return $ \s -> unsafePerformIO $ S.useAsCString s $ \cs -> do
        allocaBytes (44) $ \p_tm -> do
{-# LINE 83 "Data/Time/Parse.hsc" #-}
        alloca $ \p_fsecs -> do
        poke p_fsecs 0
        alloca $ \p_offset -> do
          last <- hstrptime_c cs (castPtr ztf) p_tm p_fsecs p_offset
          if last == nullPtr
            then return Nothing
            else do
              sec   <-  ((\hsc_ptr -> peekByteOff hsc_ptr 0)) p_tm :: IO CInt
{-# LINE 91 "Data/Time/Parse.hsc" #-}
              min   <-  ((\hsc_ptr -> peekByteOff hsc_ptr 4)) p_tm :: IO CInt
{-# LINE 92 "Data/Time/Parse.hsc" #-}
              hour  <-  ((\hsc_ptr -> peekByteOff hsc_ptr 8)) p_tm :: IO CInt
{-# LINE 93 "Data/Time/Parse.hsc" #-}
              mday  <-  ((\hsc_ptr -> peekByteOff hsc_ptr 12)) p_tm :: IO CInt
{-# LINE 94 "Data/Time/Parse.hsc" #-}
              month <-  ((\hsc_ptr -> peekByteOff hsc_ptr 16)) p_tm :: IO CInt
{-# LINE 95 "Data/Time/Parse.hsc" #-}
              year  <-  ((\hsc_ptr -> peekByteOff hsc_ptr 20)) p_tm :: IO CInt
{-# LINE 96 "Data/Time/Parse.hsc" #-}
              fsecs <-  peek p_fsecs
              let day = fromGregorian (fromIntegral (year+1900)) (1+fromIntegral month) (fromIntegral mday)
              let tod = TimeOfDay (fromIntegral hour) (fromIntegral min) (fromIntegral (sec*1000000 + round (fsecs*1000000)) / fromIntegral 1000000)
              
              touchForeignPtr fztf
              
              return $ Just (LocalTime day tod, last `minusPtr` cs)

type CTm = () -- struct tm

foreign import ccall unsafe "hstrptime.h hstrptime"
    hstrptime_c :: CString -> CString -> Ptr CTm -> Ptr Double -> Ptr Int -> IO CString