diff --git a/COPYRIGHT.txt b/COPYRIGHT.txt new file mode 100644 --- /dev/null +++ b/COPYRIGHT.txt @@ -0,0 +1,20 @@ +SybWidget - A library to ease the constructions of user interfaces. + +Copyright (C) 2006 Mads Lindstrøm + +This library is free software; you can redistribute it and/or +modify it under the terms of the GNU Lesser General Public +License as published by the Free Software Foundation; either +version 2.1 of the License, or (at your option) any later version. + +This library is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +Lesser General Public License for more details. + +You should have received a copy of the GNU Lesser General Public +License along with this library; if not, write to the Free Software +Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA + + +The author can be contacted at mads_lindstroem@yahoo.dk diff --git a/MetaHDBC.cabal b/MetaHDBC.cabal new file mode 100644 --- /dev/null +++ b/MetaHDBC.cabal @@ -0,0 +1,35 @@ +Name: MetaHDBC +Version: 0.1.2 +Cabal-version: >=1.6 +Copyright: Mads Lindstrøm +License: LGPL +License-file: COPYRIGHT.txt +Author: Mads Lindstrøm +Maintainer: Mads Lindstrøm +Category: Database +Synopsis: Statically checked database access +Description: + Using Template Haskell and HDBC to do statically checked + database access. +Tested-with: GHC==7.0.3 +Build-type: Simple +Stability: experimental + +Library + Build-Depends: base >= 4 && < 5, mtl,HDBC>=2.2.7.0,HDBC-odbc>=2.2.3.0,template-haskell>=2.2.5.0,convertible>=1.0.10.0 + Ghc-options: -Wall + Exposed-modules: + Database.MetaHDBC + ,Database.MetaHDBC.Connection + ,Database.MetaHDBC.OdbcInferTypes + ,Database.MetaHDBC.SimpleSqlParser + ,Database.MetaHDBC.SqlExpr + ,Database.MetaHDBC.SqlTypeIdExpQ + other-modules: + Extensions: + hs-source-dirs: src + + +source-repository head + type: darcs + location: http://code.haskell.org/MetaHDBC diff --git a/Setup.lhs b/Setup.lhs new file mode 100644 --- /dev/null +++ b/Setup.lhs @@ -0,0 +1,4 @@ +#! /usr/bin/env runhaskell + +> import Distribution.Simple +> main = defaultMain diff --git a/src/Database/MetaHDBC.hs b/src/Database/MetaHDBC.hs new file mode 100644 --- /dev/null +++ b/src/Database/MetaHDBC.hs @@ -0,0 +1,18 @@ +-- |Re-exports MetaHDBC modules and a little part HDBC.ODBC. +module Database.MetaHDBC + ( module Database.MetaHDBC.SimpleSqlParser + , module Database.MetaHDBC.SqlExpr + , module Database.MetaHDBC.SqlTypeIdExpQ + , cachingConnection + -- Re-exported from hdbc-odbc + , H.disconnect, H.commit, H.rollback, H.connectODBC, H.Connection + ) +where + +import Database.MetaHDBC.SimpleSqlParser +import Database.MetaHDBC.SqlExpr +import Database.MetaHDBC.SqlTypeIdExpQ +import Database.MetaHDBC.Connection + +import qualified Database.HDBC as H +import qualified Database.HDBC.ODBC as H diff --git a/src/Database/MetaHDBC/Connection.hs b/src/Database/MetaHDBC/Connection.hs new file mode 100644 --- /dev/null +++ b/src/Database/MetaHDBC/Connection.hs @@ -0,0 +1,145 @@ +module Database.MetaHDBC.Connection + +where + +import Database.HDBC as HDBC +import Database.HDBC.ODBC as HDBC +import qualified Data.HashTable as M +import Control.Concurrent.MVar + +{- Caching prepared statements + +Investigating various optimizations - maybe we can avoid the need for +seperate run and prepare statements. + +* Automatic prepare: +** Change connection to data Connection = (HDBC.Connection, Map String Statement) +** On each execute: +*** At compile-time: compute a string stmtId = Module name ++ line number +*** At run-time: Lookup the Stement in the map via stmtId +*** if do not statement exist then create it +*** execute query + +The computed map-key should be as short as possible. Think about, at +compile-time, generating globally unique Int-s. The unique id-s must +be attached to a connection somehow, as two identical sql statements +with two different connections should be prepared twice. The map +(SmartConnection) solution below do just that. + +We could also compress the string (at compile-time) to archieve better +comparison speed. +http://hackage.haskell.org/cgi-bin/hackage-scripts/package/bzlib . We +can a UTF-8 library to encode the [Char +http://hackage.haskell.org/packages/archive/utf8-string/0.3/doc/html/Codec-Binary-UTF8-String.html +. See also http://haskell.org/haskellwiki/Performance/Strings . + + +See also http://www.haskell.org/haskellwiki/Global_keys and +http://www.haskell.org/haskellwiki/Global_variables . + += Database generated unique numbers = + +We could create a table (String, Int), and generate unique numbers +this way. Or maybe it could be a single row table with the next +unique number. The unique numbers would be generated at compile-time. + += Data.Unique = + +We could use unsafePerformIO and newUnique. But where do we place this +call? If we place it in the Template Haskell ExpQ-code (the code to +be spliced in) and generate the Unique values at run-time, then the +user must place no-inline pragmas and compile with -fno-cse. See +http://cvs.haskell.org/Hugs/pages/libraries/base/System-IO-Unsafe.html +. Not a good option. + +We could also generate the unique values at compile-time. But then +what about seperate compilation. Wouldn't that reset the unique +counter? + +And how unique is the Unique? Unique within the splice. Unique within +the compilation? If the latter, a combination of +(Language.Haskell.TH.currentModule, newUnique) should be safe. + += Concurrent statements which are equal (the same SQL) ? = + +Note, in this context, concurrently do not imply multi-threaded. It +just means that we have started to execute a statement and before +fetching all the rows, then we start another execution of the same +statement. + +What if we want two statements, containing the same SQL, to be +executed concurrently? This cannot not be done, as they are cached and +returns the same statement. The user would have to have two +connections. + +If we used (module name, newUnique) then we could actually do it +provided that user duplicated his SQL statements. + += Module name and line number = + +* http://hackage.haskell.org/trac/ghc/ticket/1803 + +-} + +data CachingConnection = + CachingConnection { hdbcConnection :: HDBC.Connection + , statementMap :: MVar (M.HashTable String HDBC.Statement) + } + +cachingConnection :: String -> IO CachingConnection +cachingConnection dsn = + do conn <- connectODBC dsn + stmtMap <- newMVar =<< M.new (==) M.hashString + return $ CachingConnection conn stmtMap + +-- FIXME: remove putStrLn-s +cachingPrepare :: CachingConnection -> String -> IO HDBC.Statement +cachingPrepare conn sqlStmt = + do putStrLn "Entering cachingPrepare" + maybeStmt <- withMVar (statementMap conn) (\m -> M.lookup m sqlStmt) + case maybeStmt of + Just stmt -> putStrLn "Returning existing stmt" >> return stmt + Nothing -> secondLookup + where + secondLookup :: IO HDBC.Statement + secondLookup = + do -- We do not want the ODBC-call prepare to occur while locking + -- the MVar, as it can potentially take a logn time. + putStrLn "Creating new stmt" + stmt <- prepare (hdbcConnection conn) sqlStmt + withMVar (statementMap conn) + (\m -> do -- need to make another lookup, in case another thread + -- has created the statement in between the first lookup + -- and "now". + maybeStmt <- M.lookup m sqlStmt + case maybeStmt of + Just otherThreadsStmt -> return otherThreadsStmt + Nothing -> do M.insert m sqlStmt stmt + return stmt + ) + +{- +import System.IO.Unsafe + +cachingStmt dsn extendedSql = + do (vars, parsedSqlExpr, paramInfo, columnInfo) <- runIO $ inferTypes dsn extendedSql + (parmPatterns, parmExpr) <- fromParams (zip vars paramInfo) + [| \conn -> $( lamE (map varP parmPatterns) + [| do let preStmt = foobar conn parsedSqlExpr + rows <- fetchRows preStmt $( parmExpr ) + $( if null columnInfo + then [| return () |] + else [| return $ map ( $(fromRow columnInfo) ) rows |] + ) + |] + ) + |] + + +{-# NOINLINE foobar #-} +foobar conn parsedSqlExpr = unsafePerformIO ((putStrLn "preparing statement" >> prepare conn parsedSqlExpr) `rethrowDoing` "calling prepare") + +-- do (conn, params, prepareStmtQ, executeExpQ) <- prepareParts dsn extendedSql +-- lamE (map varP (conn:params)) (doE [noBindS (appE [| return . id |] (doE [prepareStmtQ])), executeExpQ]) + +-} diff --git a/src/Database/MetaHDBC/OdbcInferTypes.hs b/src/Database/MetaHDBC/OdbcInferTypes.hs new file mode 100644 --- /dev/null +++ b/src/Database/MetaHDBC/OdbcInferTypes.hs @@ -0,0 +1,38 @@ +module Database.MetaHDBC.OdbcInferTypes + ( dbInferTypes, strictList + ) +where + +import Database.HDBC +import Database.HDBC.ODBC + +-- import Control.Exception + +-- |Asks a ODBC database to infer selected types and placeholder types. +dbInferTypes :: String -- ^Data source name + -> String -- ^SQL + -> IO ([SqlColDesc], [SqlColDesc]) -- ^(parameter/input -info, return/column/output -info) +dbInferTypes dsn sqlExpr = + do c <- connectODBC dsn `catchSql` connectError + (paramInfo', description') <- getQueryInfo c sqlExpr `catchSql` queryInfoError + -- print (paramInfo, description) + paramInfo <- strictList paramInfo' + description <- strictList description' + let desc = map snd description + -- print (paramInfo, description) -- FIXME + -- commit c + -- disconnect c -- `rethrowDoing` "disconnecting" + -- FIXME: discornect, but make sure everything is evaluated before discornnecting + -- DB2 gives us problem if we disconnect explicitly. Thus we drop it for now. + return (paramInfo, desc) + where + connectError e = fail ("Could not connect to: " ++ dsn ++ ".\n" ++ + "Error message ODBC: " ++ seErrorMsg e) + queryInfoError e = fail ("Error while getting type information from the database server.\n" ++ + "Error message from database: " ++ seErrorMsg e ++ + "\nThe error orcurred while preparing:\n" ++ + sqlExpr ++ "\n") + +strictList :: [a] -> IO [a] +strictList [] = return [] +strictList ys = (last ys) `seq` (return ys) diff --git a/src/Database/MetaHDBC/SimpleSqlParser.hs b/src/Database/MetaHDBC/SimpleSqlParser.hs new file mode 100644 --- /dev/null +++ b/src/Database/MetaHDBC/SimpleSqlParser.hs @@ -0,0 +1,32 @@ +module Database.MetaHDBC.SimpleSqlParser + ( simpleSqlParser ) +where + +import Data.Char +import Data.List(intersperse) + +-- varid -> (small {small | large | digit | ' }) +-- small -> ascSmall | uniSmall | _ + +-- |Parses an extended SQL string. The extionsion is that we allow +-- variable-ids after placeholders (question marks). We return the +-- list of identifiers and the SQL string without the variable-ids. If +-- no variable-id is found after a placeholder, the empty string is +-- returned as variable-id. +simpleSqlParser :: String -> ([String], String) +simpleSqlParser sql = + case splitWhen '?' sql of + [] -> ([], "") + (x:xs) -> let (vars, rests) = unzip $ map parseVar xs + in (vars, concat $ intersperse "?" (x:rests)) + +parseVar :: String -> (String, String) -- (var, rest) +parseVar [] = ("", []) +parseVar (x:xs) | isLower x = span (\c -> isAlphaNum c || c == '\'') (x:xs) + | otherwise = ("", x:xs) + +splitWhen :: (Eq a) => a -> [a] -> [[a]] +splitWhen splitter xs + = case break (== splitter) xs of + (ys, []) -> [ys] + (ys, (_:zs)) -> ys : splitWhen splitter zs diff --git a/src/Database/MetaHDBC/SqlExpr.hs b/src/Database/MetaHDBC/SqlExpr.hs new file mode 100644 --- /dev/null +++ b/src/Database/MetaHDBC/SqlExpr.hs @@ -0,0 +1,287 @@ +{-# 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 + diff --git a/src/Database/MetaHDBC/SqlTypeIdExpQ.hs b/src/Database/MetaHDBC/SqlTypeIdExpQ.hs new file mode 100644 --- /dev/null +++ b/src/Database/MetaHDBC/SqlTypeIdExpQ.hs @@ -0,0 +1,127 @@ +{-# 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.")