module DB.HSQL.Type.Time where
import Control.Monad(mplus)
import System.IO.Unsafe(unsafePerformIO)
import System.Time(ClockTime(..),CalendarTime(..)
,getClockTime,toCalendarTime,toUTCTime)
import Text.ParserCombinators.ReadP(ReadP,char,skipSpaces,readP_to_S)
import Text.Read.Lex(readDecP)
import Foreign(Ptr,allocaBytes,pokeByteOff)
import Foreign.C(CTime,CInt)
import DB.HSQL.Type
(SqlType(SqlTimeTZ,SqlTime,SqlDate,SqlDateTimeTZ,SqlDateTime
,SqlTimeStamp,SqlText))
import Database.HSQL.Types(SqlBind(..))
mkClockTime :: Int -> Int -> Int -> Int -> Int -> Int -> Int -> ClockTime
mkClockTime year mon mday hour min sec tz =
unsafePerformIO $ do
allocaBytes (44) $ \p_tm -> do
((\hsc_ptr -> pokeByteOff hsc_ptr 0)) p_tm (fromIntegral sec :: CInt)
((\hsc_ptr -> pokeByteOff hsc_ptr 4)) p_tm (fromIntegral min :: CInt)
((\hsc_ptr -> pokeByteOff hsc_ptr 8)) p_tm (fromIntegral hour :: CInt)
((\hsc_ptr -> pokeByteOff hsc_ptr 12)) p_tm (fromIntegral mday :: CInt)
((\hsc_ptr -> pokeByteOff hsc_ptr 16)) p_tm (fromIntegral (mon1) :: CInt)
((\hsc_ptr -> pokeByteOff hsc_ptr 20)) p_tm (fromIntegral (year1900) :: CInt)
((\hsc_ptr -> pokeByteOff hsc_ptr 32)) p_tm (1 :: CInt)
t <- mktime p_tm
let t'=
fromEnum t
return (TOD (fromIntegral t' + fromIntegral (tzcurrTZ)) 0)
foreign import ccall unsafe
mktime :: Ptr () -> IO CTime
currTZ :: Int
currTZ =
ctTZ (unsafePerformIO (getClockTime >>= toCalendarTime))
parseTZ :: ReadP Int
parseTZ =
(char '+' >> readDecP) `mplus` (char '-' >> fmap negate readDecP)
f_read :: ReadP a -> String -> Maybe a
f_read f s = case readP_to_S f s of
[(x,_)] -> Just x
readHMS :: ReadP (Int, Int, Int)
readHMS = do
hour <- readDecP
char ':'
minutes <- readDecP
char ':'
seconds <- readDecP
return (hour, minutes, seconds)
readYMD :: ReadP (Int, Int, Int)
readYMD = do
year <- readDecP
char '-'
month <- readDecP
char '-'
day <- readDecP
return (year, month, day)
readDateTime :: ReadP (Int, Int, Int, Int, Int, Int)
readDateTime = do
(year, month, day) <- readYMD
skipSpaces
(hour, minutes, seconds) <- readHMS
return (year, month, day, hour, minutes, seconds)
instance SqlBind ClockTime where
fromSqlValue SqlTimeTZ s = f_read getTimeTZ s
where getTimeTZ :: ReadP ClockTime
getTimeTZ = do
(hour, minutes, seconds) <- readHMS
(char '.' >> readDecP) `mplus` (return 0)
tz <- parseTZ
return (mkClockTime 1970 1 1 hour minutes seconds (tz*3600))
fromSqlValue SqlTime s = f_read getTime s
where getTime :: ReadP ClockTime
getTime = do
(hour, minutes, seconds) <- readHMS
return (mkClockTime 1970 1 1 hour minutes seconds currTZ)
fromSqlValue SqlDate s = f_read getDate s
where getDate :: ReadP ClockTime
getDate = do
(year, month, day) <- readYMD
return (mkClockTime year month day 0 0 0 currTZ)
fromSqlValue SqlDateTimeTZ s = f_read getDateTimeTZ s
where getDateTimeTZ :: ReadP ClockTime
getDateTimeTZ = do
(year, month, day, hour, minutes, seconds) <- readDateTime
char '.' >> readDecP
tz <- parseTZ
return (mkClockTime year month day
hour minutes seconds
(tz*3600))
fromSqlValue t s
| t == SqlDateTime || t == SqlTimeStamp || t == SqlText =
f_read getDateTime s
where getDateTime :: ReadP ClockTime
getDateTime = do
(year, month, day, hour, minutes, seconds) <-
readDateTime
return (mkClockTime year month day
hour minutes seconds
currTZ)
fromSqlValue _ _ = Nothing
toSqlValue ct =
'\'' : (shows (ctYear t) . score .
shows (ctMonth t) . score .
shows (ctDay t) . space .
shows (ctHour t) . colon .
shows (ctMin t) . colon .
shows (ctSec t)) "'"
where t = toUTCTime ct
score = showChar '-'
space = showChar ' '
colon = showChar ':'