{-# LANGUAGE TemplateHaskell, BangPatterns #-}

{- 
ToDo:

* Better error handling
** ?vars, which are not bound
** Malformed SQL
* Hanging connections. We properly need some kind of time-out.
* Handling null values

runStmt and prepareStmt has quite similar implementation. Think about
refactoring them. But it is not as easy as it first looks.

-}

module Database.MetaHDBC.SqlExpr
    ( runStmt, prepareStmt, strict
    -- 
    , ExprParts(..), Parameter(..), PrepareParts(..)
    , rethrowDoing, sqlInfo, makeExprParts
    -- * Helper functions to construct directly runned statements (runStmt)
    , runStmtLHS, runStmtRHS
    -- * Helper function to construct prepared statements
    , makePrepStmtParts, prepStmtLHS, prepStmtQ, execPrepStmtRHS, returnExecPrepStmtLHS
    )
where

import Database.MetaHDBC.Connection
import Database.MetaHDBC.SqlTypeIdExpQ
import Database.MetaHDBC.SimpleSqlParser
import Database.MetaHDBC.OdbcInferTypes

import Language.Haskell.TH

import Database.HDBC

import Control.Monad(when)

-- |Makes the query result from prepareStmt or runStmt strict.
strict :: IO [a] -> IO [a]
strict xs = do xs' <- xs
               strictList xs'

-- |Common parts for both statements run directly (runStmt) and
-- prepared statements.
data ExprParts = ExprParts
    { parameters     :: [Parameter]  -- ^Positional parameters
    , returnTypes    :: [SqlColDesc] -- ^Description of values returned from a SQL statement
    , dbSqlExpr      :: String       -- ^The SQL expression which is passed on to the database
    , connectionName :: Name         -- ^Name of the 'Connection' parameter. 
    }

-- |Describing a positional parameter
data Parameter = Parameter
    { parmName :: Name
    , typeID   :: SqlColDesc
    , isBound  :: Bool
    }

-- |Parts used in prepared statements
data PrepareParts = PrepareParts
    { exprParts :: ExprParts
    , stmtName  :: Name
    }

-- |Returns all parameters which is unbound.
unboundParameters :: ExprParts -> [Parameter]
unboundParameters parts = filter (not . isBound) $ parameters parts

-- |Contructs expression-parts. A database is contacting to parse the
-- SQL and infer correct types.
makeExprParts :: String -> String -> Q ExprParts
makeExprParts dsn extendedSql =
    do (varNames, sqlExpr, paramInfo, returnInfo) <- runIO $ inferTypes dsn extendedSql
       parameters' <- sequence $ zipWith3 makeParameter [0..] varNames paramInfo
       connName    <- newName "connection"
       return $ ExprParts parameters' returnInfo sqlExpr connName
    where
      makeParameter :: Int -> String -> SqlColDesc -> Q Parameter
      makeParameter pos "" typeID' = do n <- newName ("x" ++ show pos)
                                        return $ Parameter n typeID' False
      makeParameter _ xs typeID' = return $ Parameter (mkName xs) typeID' True


-- *** Run statements ***

-- |Statically typed one-off (not prepared) SQL statement.
runStmt :: String    -- ^Data source name (DSN)
        -> String    -- ^SQL statement extended with question marks for parameteres
        -> ExpQ      -- ^The expression has type 
                     -- /Connection -> a1 -> ... -> an -> IO [x1, ... xm])/,
                     -- where /a1-an/ are inputs to the statement (due to placeholder
                     -- arguments), and /x1-xm/ are the outputs from the statement.
                     --
                     -- If there are no outputs from the statement (e.g. an insert
                     -- statement) the number of affected rows is returned.
runStmt dsn extendedSql =
    do parts <- makeExprParts dsn extendedSql
       runStmtLHS parts (runStmtRHS parts)

-- | Constructs a lambda which given a connection and parameters will
-- execute 'expr'. See 'runStmtRHS'.
runStmtLHS :: ExprParts
           -> ExpQ       -- ^Expression which is expected to access the database
           -> ExpQ
runStmtLHS parts expr = lamE (map varP (connectionName parts:sqlExprParms)) expr
    where sqlExprParms = map parmName $ unboundParameters parts

-- |Creates an exprresion which runs a SQL statement on a database
-- server.  It is expected that the connection variable and parameters
-- has already been bound. See also 'runStmtLHS'.
runStmtRHS :: ExprParts -> ExpQ
runStmtRHS parts =
    let sql = dbSqlExpr parts
    in if null (returnTypes parts)
          then [| run $(varE (connectionName parts)) sql $(convertParams parts) |]
          else [| do rows <- quickQuery $(varE (connectionName parts)) sql $(convertParams parts)
                     return (map $(fromRow (returnTypes parts)) rows)
                |]


-- *** Prepared statements ***

-- |Statically typed prepared SQL statement. 
prepareStmt :: String     -- ^Data source name (DSN)
            -> String     -- ^SQL statement extended with question marks for parameteres
            -> ExpQ       -- ^ The expression has type 
                          -- /Connection -> IO (a1 -> ... -> an -> IO [x1, ... xm])/,
                          -- where /a1-an/ are inputs to the statement (due to placeholder
                          -- arguments), and /x1-xm/ are the outputs from the statement. 
                          --
                          -- If there are no outputs from the statement (e.g. an insert
                          -- statement) the number of affected rows is returned.
prepareStmt dsn extendedSql =
    do parts <- makePrepStmtParts dsn extendedSql
       prepStmtLHS parts [ prepStmtQ parts
                         , returnExecPrepStmtLHS parts [execPrepStmtRHS parts]
                         ]

-- | Creates parts for a prepared statement. Calls 'makeExprParts'. 
makePrepStmtParts :: String -> String -> Q PrepareParts
makePrepStmtParts dsn extendedSql =
    do parts <- makeExprParts dsn extendedSql
       preStmtName <- newName "preStmt"
       return $ PrepareParts parts preStmtName

-- | Lambda for prepared statements. 
prepStmtLHS :: PrepareParts -> [StmtQ] -> ExpQ
prepStmtLHS (PrepareParts parts _) stmtQs =
    lam1E (varP (connectionName parts)) (doE stmtQs)

-- |A StmtQ which prepares a statement on a database.
prepStmtQ :: PrepareParts
          -> StmtQ
prepStmtQ (PrepareParts parts preStmtName) =
    let sql = dbSqlExpr parts
    in bindS (varP preStmtName)
           [| prepare $(varE (connectionName parts)) sql `rethrowDoing` "calling prepare" |]

-- |A StmtQ to execute a statement on a database.
execPrepStmtRHS :: PrepareParts -> StmtQ
execPrepStmtRHS (PrepareParts parts preStmtName) =
    let sql = dbSqlExpr parts
        expr = if null (returnTypes parts)
                  then [| execute $(varE preStmtName) $(convertParams parts) |]
                  else [| do rows <- fetchRows $(varE preStmtName) $(convertParams parts)
                             return (map $(fromRow (returnTypes parts)) rows)
                        |]
    in noBindS expr

-- |Creates a StmtQ of type: IO (a1-an -> IO ... ). Where a1-an are
-- the parameters which must be bound.
returnExecPrepStmtLHS :: PrepareParts -> [StmtQ] -> StmtQ
returnExecPrepStmtLHS (PrepareParts parts _) statements =
    noBindS $ appE [|return|] (lamE pattern (doE statements))
        where pattern = map (varP . parmName) $ unboundParameters parts

-- |Converts parameters to SqlValue. The conversions is based upon the
-- SqlTypeId-s retried from the database and stored in 'parts'.
convertParams :: ExprParts
           -> ExpQ
convertParams parts = listE $ map convertParam (parameters parts)
    where convertParam p = appE (toSqlColDesc $ typeID p) (varE $ parmName p)



-- |Returns textual information about a query. The returned 'String'
-- is useful as presentation to a user, not for further processing.
sqlInfo :: String -> String -> IO String
sqlInfo dsn extendedSql =
    do (varNames, sqlExpr, paramInfo, columnInfo) <- inferTypes dsn extendedSql
       let varsString       = show $ zip varNames paramInfo
           columnInfoString = show columnInfo 
       return ("Extended sql: " ++ extendedSql        ++ "\n" ++
               "Parsed sql:   " ++ sqlExpr            ++ "\n" ++
               "Variables:    " ++ varsString         ++ "\n" ++
               "Column info:  " ++ columnInfoString ++ "\n"
              )

-- |Executes a prepared statement and returns all rows. The rows are
-- retrieved lazily.
fetchRows :: Statement -> [SqlValue] -> IO [[SqlValue]]
fetchRows preStmt params =
    do execute preStmt params                `rethrowDoing` "executing prepared statement"
       fetchAllRows preStmt                  `rethrowDoing` "fetch all rows"

rethrowDoing :: IO a -> String -> IO a       
rethrowDoing command doing =
    command `catchSql` (\e -> fail ("Exception when trying \"" ++ doing ++
                                    "\" : " ++ seErrorMsg e))

-- |Parses sql and gets a database server to infer types for selected
-- types and placeholder types.
inferTypes :: String -> String
           -> IO ([String], String, [SqlColDesc], [SqlColDesc])
inferTypes dsn extendedSql =
    do let (varNames, sqlExpr) = simpleSqlParser extendedSql
       (paramInfo, columnInfo) <- dbInferTypes dsn sqlExpr
       when (length varNames /= length paramInfo)
                (fail "Database server and MetaHDBC disagrees about number of placeholder arguments")
       return (varNames, sqlExpr, paramInfo, columnInfo)

-- |Outputs returned from running a SQL statement needs to be
-- converted into Haskell types. This TH function returns an
-- expression which do this conversion.
fromRow :: [SqlColDesc] -> ExpQ
fromRow xs = 
    do es <- mapM fromSqlColDesc xs
       -- es <- mapM (fromSqlTypeId . colType) xs
       names <- mapM (\i -> newName ("x" ++ show i)) [0..(length es - 1)]
       return $ LamE [ListP (map VarP names)] (TupE $ map (\(e, n) -> AppE e (VarE n)) $ zip es names)

-- Expimental cahcing-connection

cachingStmt :: String -- ^Data source name (DSN)
            -> String -- ^SQL statement extended with question marks for parameteres
            -> ExpQ   -- ^The expression has type 
                      -- /Connection -> a1 -> ... -> an -> IO [x1, ... xm])/,
                      -- where /a1-an/ are inputs to the statement (due to placeholder
                      -- arguments), and /x1-xm/ are the outputs from the statement.
                      --
                      -- If there are no outputs from the statement (e.g. an insert
                      -- statement) the unit type is returned.
cachingStmt dsn extendedSql =
    do (conn, params, prepareStmtQ, executeExpQ) <- prepareParts' dsn extendedSql
       lamE (map varP (conn:params)) (doE [prepareStmtQ, executeExpQ])

prepareParts' :: String
              -> String
              -> Q (Name, [Name], StmtQ, StmtQ)
prepareParts' dsn extendedSql =
    do (varNames, sqlExpr, paramInfo, columnInfo) <- runIO $ inferTypes dsn extendedSql
       (parmNames, parmExpr) <- fromParams' (zip varNames paramInfo)
       connName    <- newName "connection"
       preStmtName <- newName "preStmt"
       let prepareExpQ = 
               bindS (varP preStmtName) [| cachingPrepare $(varE connName) sqlExpr 
                                                `rethrowDoing` "calling cachingPrepare" |]
           executeExpQ = noBindS $
               [| do rows <- fetchRows $(varE preStmtName) $( parmExpr )
                     $( if null columnInfo
                           then [| return () |]
                           else [| return $ map ( $(fromRow columnInfo) ) rows |]
                      )
                |]
       return (connName, parmNames, prepareExpQ, executeExpQ)

-- |Parameters given to a SQL statement needs to be converted from
-- there Haskell type to something HDBC understand - namely SqlValue.
-- This TH function returns an expression to do the conversion. The
-- returned function is split into its pattern and its body.
fromParams' :: [(String, SqlColDesc)]   -- ^(variable name, type). Variable names may be equal to \"\".
            -> Q ([Name], ExpQ)
fromParams' xs =
    do toFuns <- mapM toSqlColDesc (map snd xs)
       let newNameOrBoundVar ("", i) = do n <- newName ("x" ++ show i)
                                          return (n, True)
           newNameOrBoundVar (ys, _) = return (mkName ys, False)
       names <- mapM newNameOrBoundVar $ zip (map fst xs) [0::Int ..]
       -- let (freeVars, boundVars) = partition snd names
       return ( map fst $ filter snd names
              , listE $ map (\(n, f) -> appE f (varE n)) (zip (map fst names) (map return toFuns)))


-- End: Expimental caching-connection