{-# LANGUAGE TemplateHaskell, FlexibleContexts #-}

module Database.MetaHDBC.SqlTypeIdExpQ
    ( fromSqlTypeId, toSqlTypeId
    , fromSqlColDesc, toSqlColDesc
    )
where

import Language.Haskell.TH
import Database.HDBC
import Data.Convertible

-- What about null values? Think HDBC treats it as Maybe values.

-- see http://www.postgresql.com.cn/docs/8.3/static/datatype.html
-- see http://software.complete.org/static/hdbc/doc/Database-HDBC-ColTypes.html

-- | Like 'fromSqlTypeId' but also considers if the SqlValue is nullable.
fromSqlColDesc :: SqlColDesc -> ExpQ
fromSqlColDesc desc = 
    case (colNullable desc) of
      -- This function is used when taking values out of the database.
      -- It is therefore safest to assume that values are nullable,
      -- if we cannot get any information about it being nullable or not.
      (Just False) -> fromSqlTypeId (colType desc)
      _            -> [| maybeFromTypeId $(fromSqlTypeId (colType desc)) |]

-- maybeFromTypeId :: Convertible SqlValue a => (SqlValue -> a) -> (SqlValue -> Maybe a)
-- maybeFromTypeId _ = fromSql

maybeFromTypeId :: Convertible SqlValue a => (SqlValue -> a) -> (SqlValue -> Maybe a)
maybeFromTypeId _ = fromSql

-- | Like 'toSqlTypeId' but also considers if the SqlValue is nullable.
toSqlColDesc :: SqlColDesc -> ExpQ
toSqlColDesc desc = 
    case (colNullable desc) of
      -- This function is used when putting values into the database.
      -- It is therefore safest to assume that values are not nullable,
      -- if we cannot get any information about it being nullable or not.
      --
      -- But it also has the effect that we cannot say put null values into
      -- a nullable field.
      (Just True)  -> [| maybeToTypeId $(toSqlTypeId (colType desc)) |]
      _            -> toSqlTypeId (colType desc)

maybeToTypeId :: Convertible a SqlValue => (a -> SqlValue) -> (Maybe a -> SqlValue)
maybeToTypeId _ = toSql

-- | Given a 'SqlTypeId' it returns a function f which transforms a
-- SqlValue into another type. The return type of f is dependent upon
-- the value of 'SqlTypeId'. The function f is encapsulated in an
-- 'ExpQ'. Also see 'toSqlTypeId'.
fromSqlTypeId :: SqlTypeId -> ExpQ
-- String
fromSqlTypeId SqlCharT            = [| fromSql :: (SqlValue -> String) |]
fromSqlTypeId SqlVarCharT         = [| fromSql :: (SqlValue -> String) |]
fromSqlTypeId SqlLongVarCharT     = [| fromSql :: (SqlValue -> String) |]
fromSqlTypeId SqlWCharT           = [| fromSql :: (SqlValue -> String) |]
fromSqlTypeId SqlWVarCharT        = [| fromSql :: (SqlValue -> String) |]
fromSqlTypeId SqlWLongVarCharT    = [| fromSql :: (SqlValue -> String) |]
-- Integer
fromSqlTypeId SqlSmallIntT        = [| fromSql :: (SqlValue -> Int) |]
fromSqlTypeId SqlIntegerT         = [| fromSql :: (SqlValue -> Int) |]
fromSqlTypeId SqlTinyIntT         = [| fromSql :: (SqlValue -> Int) |]
fromSqlTypeId SqlBigIntT          = [| fromSql :: (SqlValue -> Integer) |]
-- Floating point
fromSqlTypeId SqlRealT            = [| fromSql :: (SqlValue -> Float) |]
fromSqlTypeId SqlFloatT           = [| fromSql :: (SqlValue -> Float) |]
fromSqlTypeId SqlDoubleT          = [| fromSql :: (SqlValue -> Double) |]
-- Decimal & Numeric are equivalent
-- Should look at scale and precision for numeric and decimal
fromSqlTypeId SqlDecimalT         = [| fromSql :: (SqlValue -> Double) |] -- Ratio Integer) |]
fromSqlTypeId SqlNumericT         = [| fromSql :: (SqlValue -> Double) |] -- Ratio Integer) |]
-- Binary
fromSqlTypeId SqlBinaryT          = [| fromSql :: (SqlValue -> String) |]
fromSqlTypeId SqlVarBinaryT       = [| fromSql :: (SqlValue -> String) |]
fromSqlTypeId SqlLongVarBinaryT   = [| fromSql :: (SqlValue -> String) |]
-- Data & time
-- We just use strings - properly not correct
fromSqlTypeId SqlDateT            = [| fromSql :: (SqlValue -> String) |]
fromSqlTypeId SqlTimeT            = [| fromSql :: (SqlValue -> String) |]
fromSqlTypeId SqlTimestampT       = [| fromSql :: (SqlValue -> String) |]
fromSqlTypeId SqlUTCDateTimeT     = [| fromSql :: (SqlValue -> String) |]
fromSqlTypeId SqlUTCTimeT         = [| fromSql :: (SqlValue -> String) |]
fromSqlTypeId (SqlIntervalT _)    = [| fromSql :: (SqlValue -> String) |]
-- Misc
fromSqlTypeId SqlBitT             = [| fromSql :: (SqlValue -> Bool) |]
fromSqlTypeId SqlGUIDT            = [| fromSql :: (SqlValue -> Bool) |]
fromSqlTypeId (SqlUnknownT _)     = [| fromSql :: (SqlValue -> String) |]
-- fromSqlTypeId (SqlUnknownT s)     = [| error ("fromSqlTypeId got SqlUnkonownT: " ++ s) |]
-- fromSqlTypeId x = error ("No fromSqlTypeId for: " ++ show x)


-- | The opposite of 'fromSqlTypeId' in that it returns a function
-- from a type to 'SqlValue'. Similarly the function is returned in a
-- 'ExpQ'. See 'fromSqlTypeId'.
toSqlTypeId :: SqlTypeId -> ExpQ
-- String
toSqlTypeId SqlCharT            = [| toSql :: (String -> SqlValue) |]
toSqlTypeId SqlVarCharT         = [| toSql :: (String -> SqlValue) |]
toSqlTypeId SqlLongVarCharT     = [| toSql :: (String -> SqlValue) |]
toSqlTypeId SqlWCharT           = [| toSql :: (String -> SqlValue) |]
toSqlTypeId SqlWVarCharT        = [| toSql :: (String -> SqlValue) |]
toSqlTypeId SqlWLongVarCharT    = [| toSql :: (String -> SqlValue) |]
-- Integer
toSqlTypeId SqlSmallIntT        = [| toSql :: (Int -> SqlValue) |]
toSqlTypeId SqlIntegerT         = [| toSql :: (Int -> SqlValue) |]
toSqlTypeId SqlTinyIntT         = [| toSql :: (Int -> SqlValue) |]
toSqlTypeId SqlBigIntT          = [| toSql :: (Integer -> SqlValue) |]
-- Floating point
toSqlTypeId SqlRealT            = [| toSql :: (Float -> SqlValue) |]
toSqlTypeId SqlFloatT           = [| toSql :: (Float -> SqlValue) |]
toSqlTypeId SqlDoubleT          = [| toSql :: (Double -> SqlValue) |]
-- Decimal & Numeric are equivalent
-- Should look at scale and precision for numeric and decimal
toSqlTypeId SqlDecimalT         = [| toSql :: (Double -> SqlValue) |] -- Ratio Integer) |]
toSqlTypeId SqlNumericT         = [| toSql :: (Double -> SqlValue) |] -- Ratio Integer) |]
-- Binary
toSqlTypeId SqlBinaryT          = [| toSql :: (String -> SqlValue) |]
toSqlTypeId SqlVarBinaryT       = [| toSql :: (String -> SqlValue) |]
toSqlTypeId SqlLongVarBinaryT   = [| toSql :: (String -> SqlValue) |]
-- SqlUnknownT
toSqlTypeId (SqlUnknownT _)     = [| toSql :: (String -> SqlValue) |]
-- missing a lot of types here - but this is just a proff of concept
toSqlTypeId x = error ("toSqlTypeId: " ++ show x ++ 
                       " not implemented for SqlTypeIdExpQ.toSqlTypeId yet.")