Parse.hsc

{-# LANGUAGE ForeignFunctionInterface, FlexibleInstances #-}
------------------------------------------------------------
-- |
-- 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

#include <time.h>

-- | 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 (#const sizeof(struct tm)) $ \p_tm -> do
          last <- strptime_c cs (castPtr ztf) p_tm
          if last == nullPtr 
            then return Nothing
            else do
              sec   <-  (#peek struct tm,tm_sec  ) p_tm :: IO CInt
              min   <-  (#peek struct tm,tm_min  ) p_tm :: IO CInt
              hour  <-  (#peek struct tm,tm_hour ) p_tm :: IO CInt
              mday  <-  (#peek struct tm,tm_mday ) p_tm :: IO CInt
              month <-  (#peek struct tm,tm_mon  ) p_tm :: IO CInt
              year  <-  (#peek struct tm,tm_year ) p_tm :: IO CInt
              let day = fromGregorian (fromIntegral (year+1900)) (fromIntegral month) (fromIntegral mday)
              let tod = TimeOfDay (fromIntegral hour) (fromIntegral min) (fromIntegral sec)
              
              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