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
class Strptime a where
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
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
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
min <- ((\hsc_ptr -> peekByteOff hsc_ptr 4)) p_tm :: IO CInt
hour <- ((\hsc_ptr -> peekByteOff hsc_ptr 8)) p_tm :: IO CInt
mday <- ((\hsc_ptr -> peekByteOff hsc_ptr 12)) p_tm :: IO CInt
month <- ((\hsc_ptr -> peekByteOff hsc_ptr 16)) p_tm :: IO CInt
year <- ((\hsc_ptr -> peekByteOff hsc_ptr 20)) p_tm :: IO CInt
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 = ()
foreign import ccall unsafe "hstrptime.h hstrptime"
hstrptime_c :: CString -> CString -> Ptr CTm -> Ptr Double -> Ptr Int -> IO CString