{- 
Module      :  Database.Util
Copyright   :  (c) 2004 Oleg Kiselyov, Alistair Bayley
License     :  BSD-style
Maintainer  :  oleg@pobox.com, alistair@abayley.org
Stability   :  experimental
Portability :  non-portable

Utility functions. Mostly used in database back-ends, and tests.
-}



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



{- 
MyShow requires overlapping AND undecidable instances.
-}



class Show a => MyShow a where show_ :: a -> String

instance MyShow String where show_ s = s

instance (Show a) => MyShow a where show_ = show



-- Like 'System.IO.print', except that Strings are not escaped or quoted.



print_ :: (MonadIO m, MyShow a) => a -> m ()

print_ s = liftIO (putStrLn (show_ s))



-- Convenience for making UTCTimes. Assumes the time given is already UTC time

-- i.e. there's no timezone adjustment.



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

    }



{-
20040822073512
   10000000000 (10 ^ 10) * year
     100000000 (10 ^ 8) * month
       1000000 (10 ^ 6) * day
         10000  (10^4) * hour

Use quot and rem, /not/ div and mod,
so that we get sensible behaviour for -ve numbers.
-}



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



{-
2 states:
 - skipNonMatch is for when we are looking for the start of our next word
 - scanWord is for when we are currently scanning a word
-}



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)))



{-
 1234567890123456789012345
"2006-11-24 07:51:49.228+00"
"2006-11-24 07:51:49.228"
"2006-11-24 07:51:49.228 BC"
"2006-11-24 07:51:49+00 BC"

FIXME  use TZ to specify timezone?
Not necessary, PostgreSQL always seems to output
+00 for timezone. It's already adjusted the time,
I think. Need to test this with different server timezones, though.
-}

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)



{-
isInfixOf is defined in the Data.List that comes with ghc-6.6,
but it is not in the libs that come with ghc-6.4.1.
-}



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





-- Parses ISO format datetimes, and also the variation that PostgreSQL uses.



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 :: (Show a, 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 "")





-- Assumes CalendarTime is also UTC i.e. ignores ctTZ component.



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)))