> {-# LANGUAGE TypeSynonymInstances #-}
> {-# LANGUAGE FlexibleInstances #-}
> {-# LANGUAGE OverlappingInstances #-}
> {-# LANGUAGE UndecidableInstances #-}

> module Database.Util where

> import System.Time
> import Control.Monad.Trans (liftIO)
> import Control.Monad.Reader
> import Data.Int
> import Data.List
> import Data.Char
> import Data.Time
> import Data.Word (Word8)
> import Foreign.Ptr (Ptr, castPtr)
> import Foreign.Marshal.Array (peekArray)
> import Numeric (showHex)
> import Text.Printf

> class Show a => MyShow a where show_ :: a -> String
> instance MyShow String where show_ s = s
> instance (Show a) => MyShow a where show_ s = show s

> print_ :: (MonadIO m, MyShow a) => a -> m ()
> print_ s = liftIO (putStrLn (show_ s))

> mkUTCTime :: (Integral a, Real b) => a -> a -> a -> a -> a -> b -> UTCTime
> mkUTCTime year month day hour minute second =
>   localTimeToUTC (hoursToTimeZone 0)
>     (LocalTime
>       (fromGregorian (fromIntegral year) (fromIntegral month) (fromIntegral day))
>       (TimeOfDay (fromIntegral hour) (fromIntegral minute) (realToFrac second)))

> mkCalTime :: Integral a => a -> a -> a -> a -> a -> a -> CalendarTime
> mkCalTime year month day hour minute second =
>   CalendarTime
>     { ctYear = fromIntegral year
>     , ctMonth = toEnum (fromIntegral month - 1)
>     , ctDay = fromIntegral day
>     , ctHour = fromIntegral hour
>     , ctMin = fromIntegral minute
>     , ctSec = fromIntegral second
>     , ctPicosec = 0
>     , ctWDay = Sunday
>     , ctYDay = -1
>     , ctTZName = "UTC"
>     , ctTZ = 0
>     , ctIsDST = False
>     }

> int64ToDateParts :: Int64 -> (Int64, Int64, Int64, Int64, Int64, Int64)
> int64ToDateParts i =
>   let
>     year1 = (i `quot` 10000000000)
>     month = ((abs i) `rem` 10000000000) `quot` 100000000
>     day = ((abs i) `rem` 100000000) `quot` 1000000
>     hour = ((abs i) `rem` 1000000) `quot` 10000
>     minute = ((abs i) `rem` 10000) `quot` 100
>     second = ((abs i) `rem` 100)
>   in (year1, month, day, hour, minute, second)

> datePartsToInt64 ::
>   (Integral a1, Integral a2, Integral a3, Integral a4, Integral a5, Integral a6)
>   => (a1, a2, a3, a4, a5, a6) -> Int64 
> datePartsToInt64 (year, month, day, hour, minute, second) =
>   let
>     yearm :: Int64
>     yearm = 10000000000
>     sign :: Int64
>     sign = if year < 0 then -1 else 1
>   in  yearm * fromIntegral year
>   + sign * 100000000 * fromIntegral month
>   + sign * 1000000 * fromIntegral day
>   + sign * 10000 * fromIntegral hour
>   + sign * 100 * fromIntegral minute
>   + sign * fromIntegral second

> calTimeToInt64 :: CalendarTime -> Int64
> calTimeToInt64 ct =
>   datePartsToInt64
>     ( ctYear ct, fromEnum (ctMonth ct) + 1, ctDay ct
>     , ctHour ct, ctMin ct, ctSec ct)

> utcTimeToInt64 utc =
>   let
>     (LocalTime ltday time) = utcToLocalTime (hoursToTimeZone 0) utc
>     (TimeOfDay hour minute second) = time
>     (year, month, day) = toGregorian ltday
>   in datePartsToInt64 (year, month, day, hour, minute, round second)

> int64ToCalTime :: Int64 -> CalendarTime
> int64ToCalTime i =
>   let (year, month, day, hour, minute, second) = int64ToDateParts i
>   in mkCalTime year month day hour minute second

> int64ToUTCTime :: Int64 -> UTCTime
> int64ToUTCTime i =
>   let (year, month, day, hour, minute, second) = int64ToDateParts i
>   in mkUTCTime year month day hour minute second

> zeroPad n i =
>   if i < 0
>   then "-" ++ (zeroPad n (abs i))
>   else take (n - length (show i)) (repeat '0') ++ show i

> substr i n s = take n (drop (i-1) s)

> wordsBy :: (Char -> Bool) -> String -> [String] 
> wordsBy pred s = skipNonMatch pred s

> skipNonMatch :: (Char -> Bool) -> String -> [String] 
> skipNonMatch pred "" = []
> skipNonMatch pred (c:cs)
>   | pred c = scanWord pred cs [c]
>   | otherwise = skipNonMatch pred cs

> scanWord pred "" acc = [reverse acc]
> scanWord pred (c:cs) acc
>   | pred c = scanWord pred cs (c:acc)
>   | otherwise = [reverse acc] ++ skipNonMatch pred cs

> positions :: Eq a => [a] -> [a] -> [Int]
> positions [] _ = []
> positions s ins = map fst (filter (isPrefixOf s . snd) (zip [1..] (tails ins)))

> pgDatetimetoUTCTime :: String -> UTCTime
> pgDatetimetoUTCTime s =
>   let (year, month, day, hour, minute, second, tz) = pgDatetimeToParts s
>   in mkUTCTime year month day hour minute second

> isoDatetimeToUTCTime s = pgDatetimetoUTCTime s

> pgDatetimetoCalTime :: String -> CalendarTime
> pgDatetimetoCalTime s =
>   let (year, month, day, hour, minute, second, tz) = pgDatetimeToParts s
>   in mkCalTime year month day hour minute (round second)

> myIsInfixOf srch list = or (map (isPrefixOf srch) (tails list))

> pgDatetimeToParts :: String -> (Int, Int, Int, Int, Int, Double, Int)
> pgDatetimeToParts s =
>   let
>     pred c = isAlphaNum c || c == '.'
>     ws = wordsBy pred s
>     parts :: [Int]; parts = map read (take 5 ws)
>     secs :: Double; secs = read (ws!!5)
>     hasTZ = myIsInfixOf "+" s
>     tz :: Int; tz = if hasTZ then read (ws !! 6) else 0
>     isBC = myIsInfixOf "BC" s
>     -- It seems only PostgreSQL uses the AD/BC suffix.
>     -- If BC is present then we need to do something odd with the year.
>     year :: Int; year = if isBC then (- ((parts !! 0) - 1)) else parts !! 0
>   in (year, (parts !! 1), (parts !! 2)
>      , (parts !! 3), (parts !! 4), secs, tz)

> utcTimeToIsoString :: (Integral a, Integral b) =>
>   UTCTime -> String -> (a -> a) -> (b -> String) -> String
> utcTimeToIsoString utc dtSep adjYear mkSuffix =
>   let
>     (LocalTime ltday time) = utcToLocalTime (hoursToTimeZone 0) utc
>     (TimeOfDay hour minute second) = time
>     (year1, month, day) = toGregorian ltday
>     suffix = mkSuffix (fromIntegral year1)
>     year = adjYear (fromIntegral year1)
>     s1 :: Double; s1 = realToFrac second
>     secs :: String; secs = printf "%09.6f" s1
>   in zeroPad 4 year
>     ++ "-" ++ zeroPad 2 month
>     ++ "-" ++ zeroPad 2 day
>     ++ dtSep ++ zeroPad 2 hour
>     ++ ":" ++ zeroPad 2 minute
>     ++ ":" ++ secs
>     ++ "+00" ++ suffix

> utcTimeToPGDatetime :: UTCTime -> String
> utcTimeToPGDatetime utc = utcTimeToIsoString utc "T" adjYear mkSuffix
>   where 
>     mkSuffix year1 = if year1 < 1 then " BC" else " AD"
>     adjYear year1 = if year1 < 1 then abs(year1 - 1) else year1

> utcTimeToIsoDatetime :: UTCTime -> String
> utcTimeToIsoDatetime utc = utcTimeToIsoString utc "T" id (const "Z") 

> utcTimeToOdbcDatetime :: UTCTime -> String
> utcTimeToOdbcDatetime utc = utcTimeToIsoString utc " " id (const "")

> calTimeToPGDatetime :: CalendarTime -> String
> calTimeToPGDatetime ct =
>   let
>     (year1, month, day, hour, minute, second, pico, tzsecs) =
>       ( ctYear ct, fromEnum (ctMonth ct) + 1, ctDay ct
>       , ctHour ct, ctMin ct, ctSec ct, ctPicosec ct, ctTZ ct)
>     suffix = if year1 < 1 then " BC" else " AD"
>     year = if year1 < 1 then abs(year1 - 1) else year1
>     s1 :: Double; s1 = realToFrac second + ((fromIntegral pico) / (10.0 ^ 12) )
>     secs :: String; secs = printf "%09.6f" s1
>   in zeroPad 4 year
>     ++ "-" ++ zeroPad 2 month
>     ++ "-" ++ zeroPad 2 day
>     ++ " " ++ zeroPad 2 hour
>     ++ ":" ++ zeroPad 2 minute
>     ++ ":" ++ secs
>     ++ "+00" ++ suffix

> printArrayContents :: Int -> Ptr Word8 -> IO ()
> printArrayContents sz ptr = do
>   putStrLn ("printArrayContents: sz = " ++ show sz)
>   l <- peekArray sz ptr
>   let
>     toHex :: Word8 -> String;
>     toHex i = (if i < 16 then "0" else "") ++ showHex i ""
>   putStrLn (concat (intersperse " " (map toHex l)))
>   let
>     toChar :: Word8 -> String
>     toChar i = if 31 < i && i < 127 then [chr (fromIntegral i)] else " "
>   putStrLn (concat (intersperse "  " (map toChar l)))