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