{-# LANGUAGE FlexibleInstances #-}
{-# OPTIONS_GHC -fallow-undecidable-instances -fallow-incoherent-instances #-}

module RESTng.Database.Record where

import Control.Monad (liftM2, liftM3, liftM4, liftM5, ap)
import Database.HDBC.PostgreSQL (Connection)
import Database.HDBC (SqlType, SqlValue, fromSql, quickQuery', run, commit)
import Text.ParserCombinators.Parsec (GenParser, anyToken, parse)
import Data.Maybe (isJust, fromJust, fromMaybe)

import RESTng.Utils(safeHead)
import RESTng.Database.SQL

type SqlValueParser a = GenParser SqlValue () a

sqlFieldParser :: SqlType a => SqlValueParser a
sqlFieldParser = do tok <- anyToken;
                    return $ fromSql tok

class SqlRecord a where
  sqlRecordParser :: SqlValueParser a

--instance SqlType a => SqlRecord a where
--  sqlRecordParser = sqlFieldParser

-- instance for fields. We cannot use the commented lines above since it is duplicated with 
-- "instance RelationalResource a => SqlRecord a" declaration in RESTng

instance SqlRecord Bool where sqlRecordParser = sqlFieldParser
instance SqlRecord Int where sqlRecordParser = sqlFieldParser
instance SqlRecord Integer where sqlRecordParser = sqlFieldParser
instance SqlRecord Double where sqlRecordParser = sqlFieldParser
instance SqlRecord [Char] where sqlRecordParser = sqlFieldParser


instance (SqlRecord a, SqlRecord b) => SqlRecord (a,b) where
  sqlRecordParser = liftM2 (,) sqlRecordParser sqlRecordParser

instance (SqlRecord a, SqlRecord b, SqlRecord c) => SqlRecord (a,b,c) where
  sqlRecordParser = liftM3 (,,) sqlRecordParser sqlRecordParser sqlRecordParser

instance (SqlRecord a, SqlRecord b, SqlRecord c, SqlRecord d) => SqlRecord (a,b,c,d) where
  sqlRecordParser = liftM4 (,,,) sqlRecordParser sqlRecordParser sqlRecordParser sqlRecordParser

instance (SqlRecord a, SqlRecord b, SqlRecord c, SqlRecord d, SqlRecord e) => SqlRecord (a,b,c,d,e) where
  sqlRecordParser = liftM5 (,,,,) sqlRecordParser sqlRecordParser sqlRecordParser sqlRecordParser sqlRecordParser

instance (SqlRecord a, SqlRecord b, SqlRecord c, SqlRecord d, SqlRecord e, SqlRecord f) => SqlRecord (a,b,c,d,e,f) where
  sqlRecordParser = return (,,,,,) `ap` sqlRecordParser `ap` sqlRecordParser `ap` sqlRecordParser 
                                   `ap` sqlRecordParser `ap` sqlRecordParser `ap` sqlRecordParser


-- | Mapping from field type names to SQL type names. Usefull for creating tables
--   Should the default be a "text", or "" (what we will do with field types we don't know about ) 
--  sqlType :: a -> String
--  sqlType _ = "text"


runTransaction :: SqlCommand -> Connection -> IO Integer
runTransaction cmd conn
                      = 
                           do
                             putStrLn $ show (sqlStr, sqlArgs)
                             --FIXME: last line is for debugging. remove it for deployment
                             rowsAffectedQty <- run conn sqlStr sqlArgs
                             commit conn
                             return rowsAffectedQty
                           where
                                (sqlStr, sqlArgs) = ppSqlCommand cmd

runTransactionReturningIds :: SqlCommand -> Connection -> IO [Integer]
runTransactionReturningIds cmd conn
                      = 
                           do
                             putStrLn $ show (sqlStr, sqlArgs)
                             --FIXME: last line is for debugging. remove it for deployment
                             idRows <- quickQuery' conn sqlStr sqlArgs
                             commit conn
                             return (map fromSql $ concat idRows)
                           where
                                (sqlStr, sqlArgs) = ppSqlCommand cmd

runTransactionReturningId :: SqlCommand -> Connection -> IO (Maybe Integer)
runTransactionReturningId cmd conn = runTransactionReturningIds cmd conn >>= return . safeHead


runQueryN :: SqlValueParser a -> SqlCommand -> Connection -> IO [a]
runQueryN parser cmd conn =
                           do
                             putStrLn $ show (sqlStr, sqlArgs)
                             --FIXME: last line is for debugging. remove it for deployment
                             rows <- quickQuery' conn sqlStr sqlArgs
                             --return [ row | (Just row) <- map parseRow rows]
                             -- what happens if the pattern matching fails? is it filtered or it is an exception?
                             return [ fromJust maybeRow | maybeRow <- map parser' rows, isJust maybeRow]
                           where
                                (sqlStr, sqlArgs) = ppSqlCommand cmd
                                parser' sqlvalues = case (parse parser "" sqlvalues) of
                                                      Left err -> Nothing
                                                      Right rec -> Just rec


runQuery01 :: SqlValueParser a -> SqlCommand -> Connection -> IO (Maybe a)
runQuery01 parser cmd conn = runQueryN parser cmd conn >>= (return . safeHead)

runQuery1 :: SqlValueParser a -> SqlCommand -> Connection -> IO a
runQuery1 parser cmd conn = runQueryN parser cmd conn >>= (return . head)