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

-- | The class of values from which time may be parsed
class Strptime a where
    -- | Given a format string in the format of C's 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.
    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 80 "Data/Time/Parse.hsc" #-}
          last <- strptime_c cs (castPtr ztf) p_tm
          if last == nullPtr
            then return Nothing
            else do
              sec   <-  ((\hsc_ptr -> peekByteOff hsc_ptr 0)) p_tm :: IO CInt
{-# LINE 85 "Data/Time/Parse.hsc" #-}
              min   <-  ((\hsc_ptr -> peekByteOff hsc_ptr 4)) p_tm :: IO CInt
{-# LINE 86 "Data/Time/Parse.hsc" #-}
              hour  <-  ((\hsc_ptr -> peekByteOff hsc_ptr 8)) p_tm :: IO CInt
{-# LINE 87 "Data/Time/Parse.hsc" #-}
              mday  <-  ((\hsc_ptr -> peekByteOff hsc_ptr 12)) p_tm :: IO CInt
{-# LINE 88 "Data/Time/Parse.hsc" #-}
              month <-  ((\hsc_ptr -> peekByteOff hsc_ptr 16)) p_tm :: IO CInt
{-# LINE 89 "Data/Time/Parse.hsc" #-}
              year  <-  ((\hsc_ptr -> peekByteOff hsc_ptr 20)) p_tm :: IO CInt
{-# LINE 90 "Data/Time/Parse.hsc" #-}
              let day = fromGregorian (fromIntegral (year+1900)) (1+fromIntegral month) (fromIntegral mday)
              let tod = TimeOfDay (fromIntegral hour) (fromIntegral min) (fromIntegral sec)
              
              touchForeignPtr fztf
              
              return $ Just (LocalTime day tod, last `minusPtr` cs)

type CTm = () -- struct tm

foreign import ccall unsafe "time.h strptime"
    strptime_c :: CString -> CString -> Ptr CTm -> IO CString