packages feed

MetaHDBC (empty) → 0.1.2

raw patch · 9 files changed

+706/−0 lines, 9 filesdep +HDBCdep +HDBC-odbcdep +basesetup-changed

Dependencies added: HDBC, HDBC-odbc, base, convertible, mtl, template-haskell

Files

+ COPYRIGHT.txt view
@@ -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
+ MetaHDBC.cabal view
@@ -0,0 +1,35 @@+Name:           MetaHDBC+Version:        0.1.2+Cabal-version:  >=1.6+Copyright:      Mads Lindstrøm <mads.lindstroem@gmail.com>+License:        LGPL+License-file:   COPYRIGHT.txt+Author:         Mads Lindstrøm <mads.lindstroem@gmail.com>+Maintainer:     Mads Lindstrøm <mads.lindstroem@gmail.com>+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
+ Setup.lhs view
@@ -0,0 +1,4 @@+#! /usr/bin/env runhaskell++> import Distribution.Simple+> main = defaultMain
+ src/Database/MetaHDBC.hs view
@@ -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
+ src/Database/MetaHDBC/Connection.hs view
@@ -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])++-}
+ src/Database/MetaHDBC/OdbcInferTypes.hs view
@@ -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)
+ src/Database/MetaHDBC/SimpleSqlParser.hs view
@@ -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
+ src/Database/MetaHDBC/SqlExpr.hs view
@@ -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+
+ src/Database/MetaHDBC/SqlTypeIdExpQ.hs view
@@ -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.")