packages feed

relational-query-HDBC (empty) → 0.0.1.0

raw patch · 23 files changed

+1780/−0 lines, 23 filesdep +HDBCdep +HDBC-sessiondep +basesetup-changed

Dependencies added: HDBC, HDBC-session, base, containers, convertible, names-th, persistable-record, relational-query, relational-schemas, template-haskell

Files

+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2013, Kei Hibino++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * Redistributions in binary form must reproduce the above+      copyright notice, this list of conditions and the following+      disclaimer in the documentation and/or other materials provided+      with the distribution.++    * Neither the name of Kei Hibino nor the names of other+      contributors may be used to endorse or promote products derived+      from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ relational-query-HDBC.cabal view
@@ -0,0 +1,68 @@+name:                relational-query-HDBC+version:             0.0.1.0+synopsis:            HDBC instance of relational join and typed query for HDBC+description:         This package contains HDBC instance of relational-query and+                     typed query for HDBC.+                     Generating Database table definitions and functions for+                     relational-query by reading table and index definitions+                     from Database system catalogs.+homepage:            http://twitter.com/khibino+license:             BSD3+license-file:        LICENSE+author:              Kei Hibino, Shohei Murayama, Shohei Yasutake, Sho KURODA+maintainer:          ex8k.hibino@gmail.com, shohei.murayama@gmail.com, amutake.s@gmail.com, krdlab@gmail.com+copyright:           Copyright (c) 2013 2014 Kei Hibino, Shohei Murayama, Shohei Yasutake, Sho KURODA+category:            Database+build-type:          Simple+cabal-version:       >=1.10++library+  exposed-modules:+                       Database.HDBC.Record.Persistable+                       Database.HDBC.Record.TH+                       Database.HDBC.Record.Statement+                       Database.HDBC.Record.Query+                       Database.HDBC.Record.Update+                       Database.HDBC.Record.Insert+                       Database.HDBC.Record.InsertQuery+                       Database.HDBC.Record.Delete+                       Database.HDBC.Record.KeyUpdate+                       Database.HDBC.Record+                       Database.HDBC.Query.TH+                       Database.HDBC.SqlValueExtra+                       Database.HDBC.Schema.Driver+                       Database.HDBC.Schema.IBMDB2+                       Database.HDBC.Schema.PostgreSQL+                       Database.HDBC.Schema.SQLServer+                       Database.HDBC.Schema.SQLite3+                       Database.HDBC.Schema.Oracle+                       Database.HDBC.Schema.MySQL++  other-modules:+                       Database.HDBC.Record.InternalTH++  build-depends:         base <5+                       , containers+                       , convertible+                       , template-haskell++                       , names-th+                       , persistable-record+                       , relational-query+                       , relational-schemas+                       , HDBC >=2+                       , HDBC-session++  hs-source-dirs:      src+  ghc-options:         -Wall++  default-language:    Haskell2010+++source-repository head+  type:       git+  location:   https://github.com/khibino/haskell-relational-record++source-repository head+  type:       mercurial+  location:   https://bitbucket.org/khibino/haskell-relational-record
+ src/Database/HDBC/Query/TH.hs view
@@ -0,0 +1,146 @@+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}++-- |+-- Module      : Database.HDBC.Query.TH+-- Copyright   : 2013 Kei Hibino+-- License     : BSD3+--+-- Maintainer  : ex8k.hibino@gmail.com+-- Stability   : experimental+-- Portability : unknown+--+-- This module contains templates to generate Haskell record types+-- and HDBC instances correspond to RDB table schema.+module Database.HDBC.Query.TH (+  makeRecordPersistableDefault,++  defineTableDefault',+  defineTableDefault,++  defineTableFromDB',+  defineTableFromDB,++  inlineVerifiedQuery+  ) where++import Data.Maybe (listToMaybe, fromMaybe)+import qualified Data.Map as Map+import Control.Monad (when)++import Database.HDBC (IConnection, SqlValue, prepare)++import Language.Haskell.TH (Q, runIO, Name, TypeQ, Dec)+import Language.Haskell.TH.Name.CamelCase (ConName, varCamelcaseName)+import Language.Haskell.TH.Lib.Extra (reportWarning, reportMessage)++import Database.Record.TH (makeRecordPersistableWithSqlTypeDefault)+import qualified Database.Record.TH as Record+import Database.Relational.Query (Relation, Config, defaultConfig, relationalQuerySQL)+import Database.Relational.Query.SQL (QuerySuffix)+import qualified Database.Relational.Query.TH as Relational++import Database.HDBC.Session (withConnectionIO)+import Database.HDBC.Record.Persistable ()++import Database.HDBC.Schema.Driver (Driver, getFields, getPrimaryKey)+++-- | Generate all persistable templates against defined record like type constructor.+makeRecordPersistableDefault :: Name    -- ^ Type constructor name+                             -> Q [Dec] -- ^ Resutl declaration+makeRecordPersistableDefault recTypeName = do+  rr <- Relational.makeRelationalRecordDefault recTypeName+  (pair, (_mayNs, cts)) <- Record.reifyRecordType recTypeName+  let width = length cts+  ps <- Record.makeRecordPersistableWithSqlType [t| SqlValue |]+        (Record.persistableFunctionNamesDefault recTypeName) pair width+  return $ rr ++ ps++-- | Generate all HDBC templates about table except for constraint keys using default naming rule.+defineTableDefault' :: Config            -- ^ Configuration to generate query with+                    -> String            -- ^ Schema name+                    -> String            -- ^ Table name+                    -> [(String, TypeQ)] -- ^ List of column name and type+                    -> [ConName]         -- ^ Derivings+                    -> Q [Dec]           -- ^ Result declaration+defineTableDefault' config schema table columns derives = do+  modelD <- Relational.defineTableTypesAndRecordDefault config schema table columns derives+  sqlvD  <- makeRecordPersistableWithSqlTypeDefault [t| SqlValue |] table $ length columns+  return $ modelD ++ sqlvD++-- | Generate all HDBC templates about table using default naming rule.+defineTableDefault :: Config            -- ^ Configuration to generate query with+                   -> String            -- ^ Schema name+                   -> String            -- ^ Table name+                   -> [(String, TypeQ)] -- ^ List of column name and type+                   -> [ConName]         -- ^ Derivings+                   -> [Int]             -- ^ Indexes to represent primary key+                   -> Maybe Int         -- ^ Index of not-null key+                   -> Q [Dec]           -- ^ Result declaration+defineTableDefault config schema table columns derives primary notNull = do+  modelD <- Relational.defineTableDefault config schema table columns derives primary notNull+  sqlvD  <- makeRecordPersistableWithSqlTypeDefault [t| SqlValue |] table $ length columns+  return $ modelD ++ sqlvD++-- | Generate all HDBC templates using system catalog informations with specified config.+defineTableFromDB' :: IConnection conn+                   => IO conn     -- ^ Connect action to system catalog database+                   -> Config      -- ^ Configuration to generate query with+                   -> Driver conn -- ^ Driver definition+                   -> String      -- ^ Schema name+                   -> String      -- ^ Table name+                   -> [ConName]   -- ^ Derivings+                   -> Q [Dec]     -- ^ Result declaration+defineTableFromDB' connect config drv scm tbl derives = do+  let getDBinfo =+        withConnectionIO connect+        (\conn ->  do+            (cols, notNullIdxs) <- getFields drv conn scm tbl+            primCols            <- getPrimaryKey drv conn scm tbl++            return (cols, notNullIdxs, primCols) )++  (cols, notNullIdxs, primaryCols) <- runIO getDBinfo+  when (null primaryCols) . reportWarning+    $ "getPrimaryKey: Primary key not found for table: " ++ scm ++ "." ++ tbl++  let colIxMap = Map.fromList $ zip [c | (c, _) <- cols] [(0 :: Int) .. ]+      ixLookups = [ (k, Map.lookup k colIxMap) | k <- primaryCols ]+      warnLk k = maybe+                 (reportWarning $ "defineTableFromDB: fail to find index of pkey - " ++ k ++ ". Something wrong!!")+                 (const $ return ())+      primaryIxs = fromMaybe [] . sequence $ map snd ixLookups+  mapM_ (uncurry warnLk) ixLookups++  defineTableDefault config scm tbl cols derives primaryIxs (listToMaybe notNullIdxs)++-- | Generate all HDBC templates using system catalog informations.+defineTableFromDB :: IConnection conn+                  => IO conn     -- ^ Connect action to system catalog database+                  -> Driver conn -- ^ Driver definition+                  -> String      -- ^ Schema name+                  -> String      -- ^ Table name+                  -> [ConName]   -- ^ Derivings+                  -> Q [Dec]     -- ^ Result declaration+defineTableFromDB connect = defineTableFromDB' connect defaultConfig++-- | Verify composed 'Query' and inline it in compile type.+inlineVerifiedQuery :: IConnection conn+                    => IO conn      -- ^ Connect action to system catalog database+                    -> Name         -- ^ Top-level variable name which has 'Relation' type+                    -> Relation p r -- ^ Object which has 'Relation' type+                    -> Config       -- ^ Configuration to generate SQL+                    -> QuerySuffix  -- ^ suffix SQL words+                    -> String       -- ^ Variable name to define as inlined query+                    -> Q [Dec]      -- ^ Result declarations+inlineVerifiedQuery connect relVar rel config sufs qns = do+  (p, r) <- Relational.reifyRelation relVar+  let sql = relationalQuerySQL config rel sufs+  _ <- runIO $ withConnectionIO connect+       (\conn -> do+           reportMessage $ "Verify with prepare: " ++ sql+           prepare conn sql)+  Relational.unsafeInlineQuery (return p) (return r) sql (varCamelcaseName qns)
+ src/Database/HDBC/Record.hs view
@@ -0,0 +1,31 @@+-- |+-- Module      : Database.HDBC.Record+-- Copyright   : 2013 Kei Hibino+-- License     : BSD3+--+-- Maintainer  : ex8k.hibino@gmail.com+-- Stability   : experimental+-- Portability : unknown+--+-- This module provides merged namespace of+-- typed 'Query', 'Insert', 'InsertQuery', 'Update', 'KeyUpdate' and 'Delete'+-- running sequences.+module Database.HDBC.Record (+  module Database.HDBC.Record.Query,+  module Database.HDBC.Record.Insert,+  module Database.HDBC.Record.InsertQuery,+  module Database.HDBC.Record.Update,+  module Database.HDBC.Record.KeyUpdate,+  module Database.HDBC.Record.Delete,+  module Database.HDBC.Record.Statement+  ) where++import Database.HDBC.Record.Query hiding (prepare)+import Database.HDBC.Record.Insert hiding (prepare)+import Database.HDBC.Record.InsertQuery hiding (prepare)+import Database.HDBC.Record.Update hiding (prepare)+import Database.HDBC.Record.KeyUpdate hiding (prepare)+import Database.HDBC.Record.Delete hiding (prepare)+import Database.HDBC.Record.Statement++{-# ANN module "HLint: ignore Use import/export shortcut" #-}
+ src/Database/HDBC/Record/Delete.hs view
@@ -0,0 +1,60 @@+{-# LANGUAGE FlexibleContexts #-}++-- |+-- Module      : Database.HDBC.Record.Delete+-- Copyright   : 2013 Kei Hibino+-- License     : BSD3+--+-- Maintainer  : ex8k.hibino@gmail.com+-- Stability   : experimental+-- Portability : unknown+--+-- This module provides typed 'Delete' running sequence+-- which intermediate structres are typed.+module Database.HDBC.Record.Delete (+  PreparedDelete, prepare, prepareDelete,++  runPreparedDelete, runDelete+  ) where++import Database.HDBC (IConnection, SqlValue)++import Database.Relational.Query (Delete)+import Database.Record (ToSql)++import Database.HDBC.Record.Statement+  (prepareNoFetch, PreparedStatement, runPreparedNoFetch, runNoFetch)+++-- | Typed prepared delete type.+type PreparedDelete p = PreparedStatement p ()++-- | Typed prepare delete operation.+prepare :: IConnection conn+        => conn+        -> Delete p+        -> IO (PreparedDelete p)+prepare =  prepareNoFetch++-- | Same as 'prepare'.+prepareDelete :: IConnection conn+              => conn+              -> Delete p+              -> IO (PreparedDelete p)+prepareDelete = prepare++-- | Bind parameters, execute statement and get execution result.+runPreparedDelete :: ToSql SqlValue p+                  => PreparedDelete p+                  -> p+                  -> IO Integer+runPreparedDelete =  runPreparedNoFetch++-- | Prepare delete statement, bind parameters,+--   execute statement and get execution result.+runDelete :: (IConnection conn, ToSql SqlValue p)+          => conn+          -> Delete p+          -> p+          -> IO Integer+runDelete =  runNoFetch
+ src/Database/HDBC/Record/Insert.hs view
@@ -0,0 +1,107 @@+{-# LANGUAGE FlexibleContexts #-}++-- |+-- Module      : Database.HDBC.Record.Insert+-- Copyright   : 2013 Kei Hibino+-- License     : BSD3+--+-- Maintainer  : ex8k.hibino@gmail.com+-- Stability   : experimental+-- Portability : unknown+--+-- This module provides typed 'Insert' running sequence+-- which intermediate structres are typed.+module Database.HDBC.Record.Insert (+  PreparedInsert, prepare, prepareInsert,++  runPreparedInsert, runInsert, mapInsert,++  chunksInsertActions, chunksInsert,+  ) where++import Database.HDBC (IConnection, SqlValue)++import Database.Relational.Query (Insert (..))+import Database.Record (ToSql, fromRecord)++import Database.HDBC.Record.Statement+  (prepareNoFetch, unsafePrepare, PreparedStatement, untypePrepared, BoundStatement (..),+   runPreparedNoFetch, runNoFetch, mapNoFetch, executeNoFetch)+++-- | Typed prepared insert type.+type PreparedInsert a = PreparedStatement a ()++-- | Typed prepare insert operation.+prepare :: IConnection conn+        => conn+        -> Insert a+        -> IO (PreparedInsert a)+prepare =  prepareNoFetch++-- | Same as 'prepare'.+prepareInsert :: IConnection conn+              => conn+              -> Insert a+              -> IO (PreparedInsert a)+prepareInsert = prepare++-- | Bind parameters, execute statement and get execution result.+runPreparedInsert :: ToSql SqlValue a+                  => PreparedInsert a+                  -> a+                  -> IO Integer+runPreparedInsert =  runPreparedNoFetch++-- | Prepare insert statement, bind parameters,+--   execute statement and get execution result.+runInsert :: (IConnection conn, ToSql SqlValue a)+          => conn+          -> Insert a+          -> a+          -> IO Integer+runInsert =  runNoFetch++-- | Prepare and insert each record.+mapInsert :: (IConnection conn, ToSql SqlValue a)+          => conn+          -> Insert a+          -> [a]+          -> IO [Integer]+mapInsert = mapNoFetch+++-- | Unsafely bind chunk of records.+chunkBind :: ToSql SqlValue p => PreparedStatement [p] () -> [p] -> BoundStatement ()+chunkBind q ps = BoundStatement { bound = untypePrepared q, params =  ps >>= fromRecord }++chunks :: Int -> [a] -> [Either [a] [a]]+chunks n = rec'  where+  rec' xs+    | null tl    =  [ if length c == n+                      then Right c+                      else Left  c ]+    | otherwise  =  Right c : rec' tl  where+      (c, tl) = splitAt n xs++-- | Prepare and insert with chunk insert statement. Result is insert action list.+chunksInsertActions :: (IConnection conn, ToSql SqlValue a)+                    => conn+                    -> Insert a+                    -> [a]+                    -> IO [ IO [Integer] ]+chunksInsertActions conn i0 rs = do+  ins    <- unsafePrepare conn $ untypeInsert i0+  iChunk <- unsafePrepare conn $ untypeChunkInsert i0+  let insert (Right c) = do+        rv <- executeNoFetch $ chunkBind iChunk c+        return [rv]+      insert (Left  c) =+        mapM (runPreparedInsert ins) c+  return . map insert $ chunks (chunkSizeOfInsert i0) rs++-- | Prepare and insert with chunk insert statement.+chunksInsert :: (IConnection conn, ToSql SqlValue a) => conn -> Insert a -> [a] -> IO [[Integer]]+chunksInsert conn ins rs = do+  as <- chunksInsertActions conn ins rs+  sequence as
+ src/Database/HDBC/Record/InsertQuery.hs view
@@ -0,0 +1,59 @@+{-# LANGUAGE FlexibleContexts #-}++-- |+-- Module      : Database.HDBC.Record.InsertQuery+-- Copyright   : 2013 Kei Hibino+-- License     : BSD3+--+-- Maintainer  : ex8k.hibino@gmail.com+-- Stability   : experimental+-- Portability : unknown+--+-- This module provides typed 'InsertQuery' running sequence+-- which intermediate structres are typed.+module Database.HDBC.Record.InsertQuery (+  PreparedInsertQuery, prepare, prepareInsertQuery,++  runPreparedInsertQuery, runInsertQuery+  ) where++import Database.HDBC (IConnection, SqlValue)++import Database.Relational.Query (InsertQuery, untypeInsertQuery)+import Database.Record (ToSql)++import Database.HDBC.Record.Statement+  (unsafePrepare, PreparedStatement, runPreparedNoFetch)++-- | Typed prepared insert query type.+type PreparedInsertQuery p = PreparedStatement p ()++-- | Typed prepare insert-query operation.+prepare :: IConnection conn+        => conn+        -> InsertQuery p+        -> IO (PreparedInsertQuery p)+prepare conn = unsafePrepare conn . untypeInsertQuery++-- | Same as 'prepare'.+prepareInsertQuery :: IConnection conn+                   => conn+                   -> InsertQuery p+                   -> IO (PreparedInsertQuery p)+prepareInsertQuery = prepare++-- | Bind parameters, execute statement and get execution result.+runPreparedInsertQuery :: ToSql SqlValue p+                       => PreparedInsertQuery p+                       -> p+                       -> IO Integer+runPreparedInsertQuery =  runPreparedNoFetch++-- | Prepare insert statement, bind parameters,+--   execute statement and get execution result.+runInsertQuery :: (IConnection conn, ToSql SqlValue p)+               => conn+               -> InsertQuery p+               -> p+               -> IO Integer+runInsertQuery conn q p = prepareInsertQuery conn q >>= (`runPreparedInsertQuery` p)
+ src/Database/HDBC/Record/InternalTH.hs view
@@ -0,0 +1,118 @@+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances #-}++-- |+-- Module      : Database.HDBC.Record.InternalTH+-- Copyright   : 2013 Kei Hibino+-- License     : BSD3+--+-- Maintainer  : ex8k.hibino@gmail.com+-- Stability   : experimental+-- Portability : unknown+--+-- This module provides internal definitions used from DB-record templates.+module Database.HDBC.Record.InternalTH (+  -- * Persistable instances along with 'Convertible' instances+  derivePersistableInstancesFromConvertibleSqlValues+  ) where++import Data.Maybe (catMaybes)+import Data.Set (Set)+import qualified Data.Set as Set++import Language.Haskell.TH+  (Q, Dec (InstanceD), Type(AppT, ConT),+   Info (ClassI), reify)+import Data.Convertible (Convertible)+import Database.HDBC (SqlValue)+import Database.HDBC.SqlValueExtra ()+import Database.Record (PersistableWidth)+import Database.Record.TH (deriveNotNullType)+import Database.Record.Instances ()+import Database.Relational.Query.TH (defineScalarDegree)++import Database.HDBC.Record.TH (derivePersistableInstanceFromValue)+++-- | Wrapper type which represents type constructor.+newtype TypeCon = TypeCon { unTypeCon :: Type } deriving Eq++-- | Ord instance for type constructor.+instance Ord TypeCon  where+  TypeCon (ConT an) `compare` TypeCon (ConT bn)    = an `compare` bn+  TypeCon (ConT _)  `compare` TypeCon _            = LT+  TypeCon _         `compare` TypeCon (ConT _)     = GT+  a                 `compare` b       | a == b     = EQ+                                      | otherwise  = EQ++-- | Set of 'TypeCon'.+type TConSet = Set TypeCon++-- | From 'Type' list into 'TConSet'.+fromList :: [Type] -> TConSet+fromList =  Set.fromList . map TypeCon++-- | From 'TConSet' into 'Type' list.+toList :: TConSet -> [Type]+toList =  map unTypeCon . Set.toList+++-- | 'SqlValue' type 'Q'.+sqlValueType :: Q Type+sqlValueType =  [t| SqlValue |]++-- | 'Convertble' pairs with 'SqlValue'.+convertibleSqlValues' :: Q [(Type, Type)]+convertibleSqlValues' =  cvInfo >>= d0  where+  cvInfo = reify ''Convertible+  unknownDeclaration =+    fail . ("convertibleSqlValues: Unknown declaration pattern: " ++)+  d0 (ClassI _ is) = fmap catMaybes . mapM d1 $ is  where+    d1 (InstanceD _cxt (AppT (AppT (ConT _n) a) b) _ds)+      = do qvt <- sqlValueType+           return+             $ if qvt == a || qvt == b+               then case (a, b) of+                 (ConT _, ConT _) -> Just (a, b)+                 _                -> Nothing+               else Nothing+    d1 decl+      =    unknownDeclaration $ show decl+  d0 cls           = unknownDeclaration $ show cls++-- | Get types which are 'Convertible' with.+convertibleSqlValues :: Q TConSet+convertibleSqlValues =  do+  qvt <- sqlValueType+  vs  <- convertibleSqlValues'+  let from = fromList . map snd . filter ((== qvt) . fst) $ vs+      to   = fromList . map fst . filter ((== qvt) . snd) $ vs+  return $ Set.intersection from to++-- | Get types which are instance of 'PersistableWith'.+persistableWidthTypes :: Q TConSet+persistableWidthTypes =  cvInfo >>= d0  where+  cvInfo = reify ''PersistableWidth+  unknownDeclaration =+    fail . ("persistableWidthTypes: Unknown declaration pattern: " ++)+  d0 (ClassI _ is) = fmap fromList . mapM d1 $ is  where+    d1 (InstanceD _cxt (AppT (ConT _n) a) _ds) = return a+    d1 decl                                    = unknownDeclaration $ show decl+  d0 cls           = unknownDeclaration $ show cls++-- | Map instance declarations.+mapInstanceD :: (Q Type -> Q [Dec]) -- ^ Template to declare instances from a type+             -> [Type]              -- ^ Types+             -> Q [Dec]             -- ^ Result declaration template.+mapInstanceD fD = fmap concat . mapM (fD . return)++-- | Template to declare HDBC instances of DB-record along with 'Convertible' instances.+derivePersistableInstancesFromConvertibleSqlValues :: Q [Dec]+derivePersistableInstancesFromConvertibleSqlValues =  do+  wds <- persistableWidthTypes+  svs <- convertibleSqlValues+  ws <- mapInstanceD deriveNotNullType (toList $ Set.difference svs wds)+  let svl = toList svs+  ps <- mapInstanceD derivePersistableInstanceFromValue svl+  ss <- mapInstanceD defineScalarDegree svl+  return $ ws ++ ps ++ ss
+ src/Database/HDBC/Record/KeyUpdate.hs view
@@ -0,0 +1,85 @@+{-# LANGUAGE FlexibleContexts #-}++-- |+-- Module      : Database.HDBC.Record.KeyUpdate+-- Copyright   : 2013 Kei Hibino+-- License     : BSD3+--+-- Maintainer  : ex8k.hibino@gmail.com+-- Stability   : experimental+-- Portability : unknown+--+-- This module provides typed 'KeyUpdate' running sequence+-- which intermediate structres are typed.+module Database.HDBC.Record.KeyUpdate (+  PreparedKeyUpdate,++  prepare, prepareKeyUpdate,++  bindKeyUpdate,++  runPreparedKeyUpdate, runKeyUpdate+  ) where++import Database.HDBC (IConnection, SqlValue, Statement)+import qualified Database.HDBC as HDBC++import Database.Relational.Query+  (KeyUpdate, untypeKeyUpdate, updateValuesWithKey, Pi)+import qualified Database.Relational.Query as Query+import Database.Record (ToSql)++import Database.HDBC.Record.Statement+  (BoundStatement (BoundStatement, bound, params), executeNoFetch)+++-- | Typed prepared key-update type.+data PreparedKeyUpdate p a =+  PreparedKeyUpdate+  {+    -- | Key to specify update target records.+    updateKey         :: Pi a p+    -- | Untyped prepared statement before executed.+  , preparedKeyUpdate :: Statement+  }++-- | Typed prepare key-update operation.+prepare :: IConnection conn+        => conn+        -> KeyUpdate p a+        -> IO (PreparedKeyUpdate p a)+prepare conn ku = fmap (PreparedKeyUpdate key) . HDBC.prepare conn $ sql  where+  sql = untypeKeyUpdate ku+  key = Query.updateKey ku++-- | Same as 'prepare'.+prepareKeyUpdate :: IConnection conn+                 => conn+                 -> KeyUpdate p a+                 -> IO (PreparedKeyUpdate p a)+prepareKeyUpdate =  prepare++-- | Typed operation to bind parameters for 'PreparedKeyUpdate' type.+bindKeyUpdate :: ToSql SqlValue a+              => PreparedKeyUpdate p a+              -> a+              -> BoundStatement ()+bindKeyUpdate pre a =+  BoundStatement { bound = preparedKeyUpdate pre, params = updateValuesWithKey key a }+  where key = updateKey pre++-- | Bind parameters, execute statement and get execution result.+runPreparedKeyUpdate :: ToSql SqlValue a+                     => PreparedKeyUpdate p a+                     -> a+                     -> IO Integer+runPreparedKeyUpdate pre = executeNoFetch . bindKeyUpdate pre++-- | Prepare insert statement, bind parameters,+--   execute statement and get execution result.+runKeyUpdate :: (IConnection conn, ToSql SqlValue a)+             => conn+             -> KeyUpdate p a+             -> a+             -> IO Integer+runKeyUpdate conn q a = prepareKeyUpdate conn q >>= (`runPreparedKeyUpdate` a)
+ src/Database/HDBC/Record/Persistable.hs view
@@ -0,0 +1,43 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE TemplateHaskell #-}++-- |+-- Module      : Database.HDBC.Record.Persistable+-- Copyright   : 2013 Kei Hibino+-- License     : BSD3+--+-- Maintainer  : ex8k.hibino@gmail.com+-- Stability   : experimental+-- Portability : unknown+--+-- This module provides HDBC instance definitions of DB-record.+module Database.HDBC.Record.Persistable (+  persistableSqlValue+  ) where++import Database.Record (PersistableSqlValue, PersistableType (..), PersistableValue (..))+import Database.Record.Persistable (unsafePersistableSqlTypeFromNull)+import qualified Database.Record.Persistable as Record+import Database.HDBC.Record.InternalTH (derivePersistableInstancesFromConvertibleSqlValues)++import Data.Convertible (Convertible)+import Database.HDBC (SqlValue(SqlNull), fromSql, toSql)++instance PersistableType SqlValue  where+  persistableType = unsafePersistableSqlTypeFromNull SqlNull++-- | Derived 'PersistableSqlValue' from 'Convertible'.+persistableSqlValue :: (Convertible SqlValue a, Convertible a SqlValue)+                       => PersistableSqlValue SqlValue a+persistableSqlValue =  Record.persistableSqlValue persistableType fromSql toSql++-- | Infered 'PersistableSqlValue' from 'Convertible'.+instance (Convertible SqlValue a, Convertible a SqlValue)+         => PersistableValue SqlValue a  where+  persistableValue = persistableSqlValue++$(derivePersistableInstancesFromConvertibleSqlValues)
+ src/Database/HDBC/Record/Query.hs view
@@ -0,0 +1,141 @@+{-# LANGUAGE FlexibleContexts #-}++-- |+-- Module      : Database.HDBC.Record.Query+-- Copyright   : 2013 Kei Hibino+-- License     : BSD3+--+-- Maintainer  : ex8k.hibino@gmail.com+-- Stability   : experimental+-- Portability : unknown+--+-- This module provides typed 'Query' running sequence+-- which intermediate structres are typed.+module Database.HDBC.Record.Query (+  PreparedQuery, prepare, prepareQuery,++  fetch, fetchAll, fetchAll',+  listToUnique, fetchUnique, fetchUnique',++  runStatement, runStatement',+  runPreparedQuery, runPreparedQuery',+  runQuery, runQuery'+  ) where++import Data.Maybe (listToMaybe)+import Database.HDBC (IConnection, Statement, SqlValue)+import qualified Database.HDBC as HDBC++import Database.Relational.Query (Query, untypeQuery)+import Database.Record+  (ToSql, RecordFromSql, FromSql(recordFromSql), runToRecord)++import Database.HDBC.Record.Statement+  (unsafePrepare, PreparedStatement,+   bind, BoundStatement,+   execute, ExecutedStatement, executed)+++-- | Typed prepared query type.+type PreparedQuery p a = PreparedStatement p a++-- | Typed prepare query operation.+prepare :: IConnection conn+        => conn                   -- ^ Database connection+        -> Query p a              -- ^ Typed query+        -> IO (PreparedQuery p a) -- ^ Result typed prepared query with parameter type 'p' and result type 'a'+prepare conn = unsafePrepare conn . untypeQuery++-- | Same as 'prepare'.+prepareQuery :: IConnection conn+             => conn                   -- ^ Database connection+             -> Query p a              -- ^ Typed query+             -> IO (PreparedQuery p a) -- ^ Result typed prepared query with parameter type 'p' and result type 'a'+prepareQuery = prepare++-- | Polymorphic fetch operation.+fetchRecordsExplicit :: Functor f+                     => (Statement -> IO (f [SqlValue]) )+                     -> RecordFromSql SqlValue a+                     -> ExecutedStatement a+                     -> IO (f a)+fetchRecordsExplicit fetchs fromSql es = do+  rows <- fetchs (executed es)+  return $ fmap (runToRecord fromSql) rows++-- | Fetch a record.+fetch :: FromSql SqlValue a => ExecutedStatement a -> IO (Maybe a)+fetch =  fetchRecordsExplicit HDBC.fetchRow recordFromSql++-- | Lazily Fetch all records.+fetchAll :: FromSql SqlValue a => ExecutedStatement a -> IO [a]+fetchAll =  fetchRecordsExplicit HDBC.fetchAllRows recordFromSql++-- | Strict version of 'fetchAll'.+fetchAll' :: FromSql SqlValue a => ExecutedStatement a -> IO [a]+fetchAll' =  fetchRecordsExplicit HDBC.fetchAllRows' recordFromSql++-- | Fetch all records but get only first record.+--   Expecting result records is unique.+fetchUnique :: FromSql SqlValue a => ExecutedStatement a -> IO (Maybe a)+fetchUnique es = do+  recs <- fetchAll es+  let z' = listToMaybe recs+  z <- z' `seq` return z'+  HDBC.finish $ executed es+  return z++-- | Fetch expecting result records is unique.+listToUnique :: [a] -> IO (Maybe a)+listToUnique =  d  where+  d []      = return Nothing+  d [r]     = return $ Just r+  d (_:_:_) = fail "fetchUnique': more than one record found."++-- | Fetch all records but get only first record.+--   Expecting result records is unique.+--   Error when records count is more than one.+fetchUnique' :: FromSql SqlValue a => ExecutedStatement a -> IO (Maybe a)+fetchUnique' es = do+  recs <- fetchAll es+  z <- listToUnique recs+  HDBC.finish $ executed es+  return z++-- | Execute statement and lazily fetch all records.+runStatement :: FromSql SqlValue a => BoundStatement a -> IO [a]+runStatement =  (>>= fetchAll) . execute++-- | Strict version of 'runStatement'.+runStatement' :: FromSql SqlValue a => BoundStatement a -> IO [a]+runStatement' =  (>>= fetchAll') . execute++-- | Bind parameters, execute statement and lazily fetch all records.+runPreparedQuery :: (ToSql SqlValue p, FromSql SqlValue a)+                 => PreparedQuery p a -- ^ Statement to bind to+                 -> p                 -- ^ Parameter type+                 -> IO [a]            -- ^ Action to get records+runPreparedQuery ps = runStatement . bind ps++-- | Strict version of 'runPreparedQuery'.+runPreparedQuery' :: (ToSql SqlValue p, FromSql SqlValue a)+                  => PreparedQuery p a -- ^ Statement to bind to+                  -> p                 -- ^ Parameter type+                  -> IO [a]            -- ^ Action to get records+runPreparedQuery' ps = runStatement' . bind ps++-- | Prepare SQL, bind parameters, execute statement and lazily fetch all records.+runQuery :: (IConnection conn, ToSql SqlValue p, FromSql SqlValue a)+         => conn      -- ^ Database connection+         -> Query p a -- ^ Query to get record type 'a' requires parameter 'p'+         -> p         -- ^ Parameter type+         -> IO [a]    -- ^ Action to get records+runQuery conn q p = prepare conn q >>= (`runPreparedQuery` p)++-- | Strict version of 'runQuery'.+runQuery' :: (IConnection conn, ToSql SqlValue p, FromSql SqlValue a)+          => conn      -- ^ Database connection+          -> Query p a -- ^ Query to get record type 'a' requires parameter 'p'+          -> p         -- ^ Parameter type+          -> IO [a]    -- ^ Action to get records+runQuery' conn q p = prepare conn q >>= (`runPreparedQuery'` p)
+ src/Database/HDBC/Record/Statement.hs view
@@ -0,0 +1,124 @@+{-# LANGUAGE FlexibleContexts #-}++-- |+-- Module      : Database.HDBC.Record.Statement+-- Copyright   : 2013 Kei Hibino+-- License     : BSD3+--+-- Maintainer  : ex8k.hibino@gmail.com+-- Stability   : experimental+-- Portability : unknown+--+-- This module provides typed statement running sequence+-- which intermediate structres are typed.+module Database.HDBC.Record.Statement (+  PreparedStatement, untypePrepared, unsafePrepare,++  BoundStatement (..), bind', bind, bindTo,++  ExecutedStatement, executed, result, execute,++  prepareNoFetch, executeNoFetch, runPreparedNoFetch, runNoFetch, mapNoFetch+  ) where++import Database.Relational.Query (UntypeableNoFetch (untypeNoFetch))+import Database.HDBC (IConnection, Statement, SqlValue)+import qualified Database.HDBC as HDBC++import Database.Record+  (RecordToSql, ToSql(recordToSql), runFromRecord)++-- | Typed prepared statement type.+newtype PreparedStatement p a =+  PreparedStatement {+    -- | Untyped prepared statement before executed.+    prepared :: Statement+    }++-- | Typed prepared statement which has bound placeholder parameters.+data BoundStatement a =+  BoundStatement+  {+    -- | Untyped prepared statement before executed.+    bound  :: Statement+    -- | Bound parameters.+  , params :: [SqlValue]+  }++-- | Typed executed statement.+data ExecutedStatement a =+  ExecutedStatement+  { -- | Untyped executed statement.+    executed :: Statement+    -- | Result of HDBC execute.+  , result   :: Integer+  }++-- | Unsafely untype prepared statement.+untypePrepared :: PreparedStatement p a -> Statement+untypePrepared =  prepared++-- | Run prepare and unsafely make Typed prepared statement.+unsafePrepare :: IConnection conn+              => conn                       -- ^ Database connection+              -> String                     -- ^ Raw SQL String+              -> IO (PreparedStatement p a) -- ^ Result typed prepared query with parameter type 'p' and result type 'a'+unsafePrepare conn = fmap PreparedStatement . HDBC.prepare conn++-- | Generalized prepare inferred from 'UntypeableNoFetch' instance.+prepareNoFetch :: (UntypeableNoFetch s, IConnection conn)+               => conn+               -> s p+               -> IO (PreparedStatement p ())+prepareNoFetch conn = unsafePrepare conn . untypeNoFetch++-- | Typed operation to bind parameters.+bind' :: RecordToSql SqlValue p -- ^ Proof object to convert from parameter type 'p' into 'SqlValue' list.+      -> PreparedStatement p a  -- ^ Prepared query to bind to+      -> p                      -- ^ Parameter to bind+      -> BoundStatement a       -- ^ Result parameter bound statement+bind' toSql q p = BoundStatement { bound = prepared q, params = runFromRecord toSql p }++-- | Typed operation to bind parameters. Infered 'RecordToSql' is used.+bind :: ToSql SqlValue p => PreparedStatement p a -> p -> BoundStatement a+bind =  bind' recordToSql++-- | Same as 'bind' except for argument is flipped.+bindTo :: ToSql SqlValue p => p -> PreparedStatement p a -> BoundStatement a+bindTo =  flip bind++-- | Typed execute operation.+execute :: BoundStatement a -> IO (ExecutedStatement a)+execute bs = do+  let stmt = bound bs+  n <- HDBC.execute stmt (params bs)+  return $ ExecutedStatement stmt n++-- | Typed execute operation. Only get result.+executeNoFetch :: BoundStatement () -> IO Integer+executeNoFetch =  fmap result . execute++-- | Bind parameters, execute statement and get execution result.+runPreparedNoFetch :: ToSql SqlValue a+                  => PreparedStatement a ()+                  -> a+                  -> IO Integer+runPreparedNoFetch p = executeNoFetch . (p `bind`)++-- | Prepare and run sequence for polymorphic no-fetch statement.+runNoFetch :: (UntypeableNoFetch s, IConnection conn, ToSql SqlValue a)+           => conn+           -> s a+           -> a+           -> IO Integer+runNoFetch conn s p = prepareNoFetch conn s >>= (`runPreparedNoFetch` p)++-- | Prepare and run it against each parameter list.+mapNoFetch :: (UntypeableNoFetch s, IConnection conn, ToSql SqlValue a)+           => conn+           -> s a+           -> [a]+           -> IO [Integer]+mapNoFetch conn s rs = do+  ps <- prepareNoFetch conn s+  mapM (runPreparedNoFetch ps) rs
+ src/Database/HDBC/Record/TH.hs view
@@ -0,0 +1,33 @@+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances #-}++-- |+-- Module      : Database.HDBC.Record.TH+-- Copyright   : 2013 Kei Hibino+-- License     : BSD3+--+-- Maintainer  : ex8k.hibino@gmail.com+-- Stability   : experimental+-- Portability : unknown+--+-- This module provides DB-record templates depends on HDBC.+module Database.HDBC.Record.TH (+  derivePersistableInstanceFromValue,+  ) where++import Language.Haskell.TH (Q, Dec, Type)+import Database.HDBC (SqlValue)+import Database.HDBC.SqlValueExtra ()+import Database.Record (FromSql(..), valueFromSql, ToSql(..), valueToSql)+++-- | Template to declare HDBC instances of DB-record against single value type.+derivePersistableInstanceFromValue :: Q Type  -- ^ Type to implement instances+                                   -> Q [Dec] -- ^ Result declarations+derivePersistableInstanceFromValue typ =+  [d| instance FromSql SqlValue $(typ)  where+        recordFromSql = valueFromSql++      instance ToSql SqlValue $(typ)  where+        recordToSql = valueToSql+    |]
+ src/Database/HDBC/Record/Update.hs view
@@ -0,0 +1,68 @@+{-# LANGUAGE FlexibleContexts #-}++-- |+-- Module      : Database.HDBC.Record.Update+-- Copyright   : 2013 Kei Hibino+-- License     : BSD3+--+-- Maintainer  : ex8k.hibino@gmail.com+-- Stability   : experimental+-- Portability : unknown+--+-- This module provides typed 'Update' running sequence+-- which intermediate structres are typed.+module Database.HDBC.Record.Update (+  PreparedUpdate, prepare, prepareUpdate,++  runPreparedUpdate, runUpdate, mapUpdate+  ) where++import Database.HDBC (IConnection, SqlValue)++import Database.Relational.Query (Update)+import Database.Record (ToSql)++import Database.HDBC.Record.Statement+  (prepareNoFetch, PreparedStatement, runPreparedNoFetch, runNoFetch, mapNoFetch)+++-- | Typed prepared update type.+type PreparedUpdate p = PreparedStatement p ()++-- | Typed prepare update operation.+prepare :: IConnection conn+        => conn+        -> Update p+        -> IO (PreparedUpdate p)+prepare =  prepareNoFetch++-- | Same as 'prepare'.+prepareUpdate :: IConnection conn+              => conn+              -> Update p+              -> IO (PreparedUpdate p)+prepareUpdate =  prepare++-- | Bind parameters, execute statement and get execution result.+runPreparedUpdate :: ToSql SqlValue p+                  => PreparedUpdate p+                  -> p+                  -> IO Integer+runPreparedUpdate = runPreparedNoFetch++-- | Prepare update statement, bind parameters,+--   execute statement and get execution result.+runUpdate :: (IConnection conn, ToSql SqlValue p)+          => conn+          -> Update p+          -> p+          -> IO Integer+runUpdate =  runNoFetch++-- | Prepare and update with each parameter list.+mapUpdate :: (IConnection conn, ToSql SqlValue a)+          => conn+          -> Update a+          -> [a]+          -> IO [Integer]+mapUpdate = mapNoFetch
+ src/Database/HDBC/Schema/Driver.hs view
@@ -0,0 +1,53 @@+-- |+-- Module      : Database.HDBC.Schema.Driver+-- Copyright   : 2013 Kei Hibino+-- License     : BSD3+--+-- Maintainer  : ex8k.hibino@gmail.com+-- Stability   : experimental+-- Portability : unknown+--+-- This module provides driver interface+-- to load database system catalog via HDBC.+module Database.HDBC.Schema.Driver (+  TypeMap,+  Driver(Driver, typeMap, getFieldsWithMap, getPrimaryKey),+  emptyDriver,+  getFields+  ) where++import Database.HDBC (IConnection)+import Language.Haskell.TH (TypeQ)+++-- | Mapping between type name string of DBMS and type in Haskell.+--   Type name string depends on specification of DBMS system catalogs.+type TypeMap = [(String, TypeQ)]++-- | Interface type to load database system catalog via HDBC.+data Driver conn =+  Driver+  { -- | Custom type mapping of this driver+    typeMap   :: TypeMap++    -- | Get column name and Haskell type pairs and not-null columns index.+  , getFieldsWithMap :: TypeMap                       --  Custom type mapping+                     -> conn                          --  Connection to query system catalog+                     -> String                        --  Schema name string+                     -> String                        --  Table name string+                     -> IO ([(String, TypeQ)], [Int]) --  Action to get column name and Haskell type pairs and not-null columns index.++    -- | Get primary key column name.+  , getPrimaryKey :: conn          --  Connection to query system catalog+                  -> String        --  Schema name string+                  -> String        --  Table name string+                  -> IO [String]   --  Action to get column names of primary key+  }++-- | Empty definition of 'Driver'+emptyDriver :: IConnection conn => Driver conn+emptyDriver =  Driver [] (\_ _ _ _ -> return ([],[])) (\_ _ _ -> return [])++-- | Helper function to call 'getFieldsWithMap' using 'typeMap' of 'Driver'.+getFields :: IConnection conn => Driver conn -> conn -> String -> String -> IO ([(String, TypeQ)], [Int])+getFields drv = getFieldsWithMap drv (typeMap drv)
+ src/Database/HDBC/Schema/IBMDB2.hs view
@@ -0,0 +1,104 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE MultiParamTypeClasses #-}++-- |+-- Module      : Database.HDBC.Schema.IBMDB2+-- Copyright   : 2013 Kei Hibino+-- License     : BSD3+--+-- Maintainer  : ex8k.hibino@gmail.com+-- Stability   : experimental+-- Portability : unknown+--+-- This module provides driver implementation+-- to load IBM-DB2 system catalog via HDBC.+module Database.HDBC.Schema.IBMDB2 (+  driverIBMDB2+  ) where++import Prelude hiding (length)++import Language.Haskell.TH (TypeQ)++import qualified Data.List as List+import Data.Char (toUpper)+import Data.Map (fromList)+import Control.Monad (when)++import Database.HDBC (IConnection, SqlValue)++import Language.Haskell.TH.Lib.Extra (reportMessage)++import Database.HDBC.Record.Query (runQuery')+import Database.HDBC.Record.Persistable ()++import Database.Record.TH (makeRecordPersistableWithSqlTypeDefaultFromDefined)++import Database.Relational.Schema.IBMDB2+  (normalizeColumn, notNull, getType, columnsQuerySQL, primaryKeyQuerySQL)+import Database.Relational.Schema.DB2Syscat.Columns (Columns)+import qualified Database.Relational.Schema.DB2Syscat.Columns as Columns++import Database.HDBC.Schema.Driver+  (TypeMap, Driver, getFieldsWithMap, getPrimaryKey, emptyDriver)+++-- Specify type constructor and data constructor from same table name.+$(makeRecordPersistableWithSqlTypeDefaultFromDefined+  [t| SqlValue |] ''Columns)++logPrefix :: String -> String+logPrefix =  ("IBMDB2: " ++)++putLog :: String -> IO ()+putLog =  reportMessage . logPrefix++compileErrorIO :: String -> IO a+compileErrorIO =  fail . logPrefix++getPrimaryKey' :: IConnection conn+              => conn+              -> String+              -> String+              -> IO [String]+getPrimaryKey' conn scm' tbl' = do+  let tbl = map toUpper tbl'+      scm = map toUpper scm'+  primCols <- runQuery' conn primaryKeyQuerySQL (scm, tbl)+  let primaryKeyCols = normalizeColumn `fmap` primCols+  putLog $ "getPrimaryKey: primary key = " ++ show primaryKeyCols++  return primaryKeyCols++getColumns' :: IConnection conn+          => TypeMap+          -> conn+          -> String+          -> String+          -> IO ([(String, TypeQ)], [Int])+getColumns' tmap conn scm' tbl' = do+  let tbl = map toUpper tbl'+      scm = map toUpper scm'++  cols <- runQuery' conn columnsQuerySQL (scm, tbl)+  when (null cols) . compileErrorIO+    $ "getFields: No columns found: schema = " ++ scm ++ ", table = " ++ tbl++  let notNullIdxs = map fst . filter (notNull . snd) . zip [0..] $ cols+  putLog+    $  "getFields: num of columns = " ++ show (List.length cols)+    ++ ", not null columns = " ++ show notNullIdxs+  let getType' col = case getType (fromList tmap) col of+        Nothing -> compileErrorIO+                   $ "Type mapping is not defined against DB2 type: " ++ Columns.typename col+        Just p  -> return p++  types <- mapM getType' cols+  return (types, notNullIdxs)++-- | Driver implementation+driverIBMDB2 :: IConnection conn => Driver conn+driverIBMDB2 =+  emptyDriver { getFieldsWithMap = getColumns' }+              { getPrimaryKey    = getPrimaryKey' }
+ src/Database/HDBC/Schema/MySQL.hs view
@@ -0,0 +1,88 @@+{-# OPTIONS_GHC -fno-warn-orphans  #-}+{-# LANGUAGE TemplateHaskell       #-}+{-# LANGUAGE MultiParamTypeClasses #-}+module Database.HDBC.Schema.MySQL+    (+      driverMySQL+    )+    where++import           Prelude                            hiding (length)+import           Language.Haskell.TH                (TypeQ)+import qualified Data.List                          as List+import           Data.Map                           (fromList)++import           Database.HDBC                      (IConnection, SqlValue)+import           Database.HDBC.Record.Query         (runQuery')+import           Database.HDBC.Record.Persistable   ()+import           Database.HDBC.Schema.Driver        ( TypeMap+                                                    , Driver+                                                    , getFieldsWithMap+                                                    , getPrimaryKey+                                                    , emptyDriver+                                                    )+import           Database.Record.TH                 (makeRecordPersistableWithSqlTypeDefaultFromDefined)+import           Database.Relational.Schema.MySQL   ( normalizeColumn+                                                    , notNull+                                                    , getType+                                                    , columnsQuerySQL+                                                    , primaryKeyQuerySQL+                                                    )++import           Database.Relational.Schema.MySQLInfo.Columns (Columns)+import qualified Database.Relational.Schema.MySQLInfo.Columns as Columns++$(makeRecordPersistableWithSqlTypeDefaultFromDefined [t| SqlValue |] ''Columns)++logPrefix :: String -> String+logPrefix = ("MySQL: " ++)++putLog :: String -> IO ()+putLog = putStrLn . logPrefix++compileErrorIO :: String -> IO a+compileErrorIO = fail . logPrefix++getPrimaryKey' :: IConnection conn+               => conn+               -> String+               -> String+               -> IO [String]+getPrimaryKey' conn scm tbl = do+    primCols <- runQuery' conn primaryKeyQuerySQL (scm, tbl)+    let primaryKeyCols = normalizeColumn `fmap` primCols+    putLog $ "getPrimaryKey: primary key = " ++ show primaryKeyCols+    return primaryKeyCols++getFields' :: IConnection conn+           => TypeMap+           -> conn+           -> String+           -> String+           -> IO ([(String, TypeQ)], [Int])+getFields' tmap conn scm tbl = do+    cols <- runQuery' conn columnsQuerySQL (scm, tbl)+    case cols of+        [] -> compileErrorIO+                $ "getFields: No columns found: schema = " ++ scm+                ++ ", table = " ++ tbl+        _  -> return ()+    let notNullIdxs = map fst . filter (notNull . snd) . zip [0..] $ cols+    putLog+      $  "getFields: num of columns = " ++ show (List.length cols)+      ++ ", not null columns = " ++ show notNullIdxs+    types <- mapM getType' cols+    return (types, notNullIdxs)+    where+        getType' col =+            case getType (fromList tmap) col of+                Nothing -> compileErrorIO+                             $ "Type mapping is not defined against MySQL type: "+                             ++ Columns.dataType col+                Just p  -> return p++-- | Driver implementation+driverMySQL :: IConnection conn => Driver conn+driverMySQL =+    emptyDriver { getFieldsWithMap = getFields' }+                { getPrimaryKey    = getPrimaryKey' }
+ src/Database/HDBC/Schema/Oracle.hs view
@@ -0,0 +1,85 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}+{-# LANGUAGE TemplateHaskell, MultiParamTypeClasses #-}++module Database.HDBC.Schema.Oracle+    ( driverOracle+    ) where++import Control.Applicative ((<$>))+import Data.Char (toUpper)+import Data.Map (fromList)+import Data.Maybe (catMaybes)+import Language.Haskell.TH (TypeQ)++import Database.HDBC (IConnection, SqlValue)+import Database.HDBC.Record.Query (runQuery')+import Database.HDBC.Record.Persistable ()+import Database.Record.TH (makeRecordPersistableWithSqlTypeDefaultFromDefined)+import Database.HDBC.Schema.Driver+    ( TypeMap, Driver, getFieldsWithMap, getPrimaryKey, emptyDriver+    )++import Database.Relational.Schema.Oracle+    ( normalizeColumn, notNull, getType+    , columnsQuerySQL, primaryKeyQuerySQL+    )+import Database.Relational.Schema.OracleDataDictionary.TabColumns (DbaTabColumns)+import qualified Database.Relational.Schema.OracleDataDictionary.TabColumns as Cols++$(makeRecordPersistableWithSqlTypeDefaultFromDefined+    [t|SqlValue|]+    ''DbaTabColumns)++logPrefix :: String -> String+logPrefix = ("Oracle: " ++)++putLog :: String -> IO ()+putLog = putStrLn . logPrefix++compileErrorIO :: String -> IO a+compileErrorIO = fail . logPrefix++getPrimaryKey' :: IConnection conn+               => conn+               -> String -- ^ owner name+               -> String -- ^ table name+               -> IO [String] -- ^ primary key names+getPrimaryKey' conn owner' tbl' = do+    let owner = map toUpper owner'+        tbl = map toUpper tbl'+    prims <- map normalizeColumn . catMaybes <$>+        runQuery' conn primaryKeyQuerySQL (owner, tbl)+    putLog $ "getPrimaryKey: keys = " ++ show prims+    return prims++getFields' :: IConnection conn+           => TypeMap+           -> conn+           -> String+           -> String+           -> IO ([(String, TypeQ)], [Int])+getFields' tmap conn owner' tbl' = do+    let owner = map toUpper owner'+        tbl = map toUpper tbl'+    cols <- runQuery' conn columnsQuerySQL (owner, tbl)+    case cols of+        [] -> compileErrorIO $+            "getFields: No columns found: owner = " ++ owner ++ ", table = " ++ tbl+        _ -> return ()+    let notNullIdxs = map fst . filter (notNull . snd) . zip [0..] $ cols+    putLog $+        "getFields: num of columns = " ++ show (length cols) +++        ", not null columns = " ++ show notNullIdxs+    let getType' col = case getType (fromList tmap) col of+            Nothing -> compileErrorIO $+                "Type mapping is not defined against Oracle DB type: " +++                show (Cols.dataType col)+            Just p -> return p+    types <- mapM getType' cols+    return (types, notNullIdxs)++-- | Driver for Oracle DB+driverOracle :: IConnection conn => Driver conn+driverOracle =+    emptyDriver { getFieldsWithMap = getFields' }+                { getPrimaryKey = getPrimaryKey' }
+ src/Database/HDBC/Schema/PostgreSQL.hs view
@@ -0,0 +1,112 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE MultiParamTypeClasses #-}++-- |+-- Module      : Database.HDBC.Schema.PostgreSQL+-- Copyright   : 2013 Kei Hibino+-- License     : BSD3+--+-- Maintainer  : ex8k.hibino@gmail.com+-- Stability   : experimental+-- Portability : unknown+--+-- This module provides driver implementation+-- to load PostgreSQL system catalog via HDBC.+module Database.HDBC.Schema.PostgreSQL (+  driverPostgreSQL+  ) where++import Language.Haskell.TH (TypeQ)++import Data.Char (toLower)+import Data.Map (fromList)+import Control.Monad (when)++import Database.HDBC (IConnection, SqlValue)++import Language.Haskell.TH.Lib.Extra (reportMessage)++import Database.HDBC.Record.Query (runQuery')+import Database.HDBC.Record.Persistable ()++import Database.Record.TH (makeRecordPersistableWithSqlTypeDefaultFromDefined)++import Database.Relational.Schema.PostgreSQL+  (normalizeColumn, notNull, getType, columnQuerySQL,+   primaryKeyLengthQuerySQL, primaryKeyQuerySQL)+import Database.Relational.Schema.PgCatalog.PgAttribute (PgAttribute)+import Database.Relational.Schema.PgCatalog.PgType (PgType)+import qualified Database.Relational.Schema.PgCatalog.PgType as Type++import Database.HDBC.Schema.Driver+  (TypeMap, Driver, getFieldsWithMap, getPrimaryKey, emptyDriver)+++$(makeRecordPersistableWithSqlTypeDefaultFromDefined+  [t| SqlValue |] ''PgAttribute)++$(makeRecordPersistableWithSqlTypeDefaultFromDefined+  [t| SqlValue |] ''PgType)++logPrefix :: String -> String+logPrefix =  ("PostgreSQL: " ++)++putLog :: String -> IO ()+putLog =  reportMessage . logPrefix++compileErrorIO :: String -> IO a+compileErrorIO =  fail . logPrefix++getPrimaryKey' :: IConnection conn+              => conn+              -> String+              -> String+              -> IO [String]+getPrimaryKey' conn scm' tbl' = do+  let scm = map toLower scm'+      tbl = map toLower tbl'+  mayKeyLen <- runQuery' conn primaryKeyLengthQuerySQL (scm, tbl)+  case mayKeyLen of+    []        -> do+      putLog   "getPrimaryKey: Primary key not found."+      return []+    [keyLen]  -> do+      primCols <- runQuery' conn (primaryKeyQuerySQL keyLen) (scm, tbl)+      let primaryKeyCols = normalizeColumn `fmap` primCols+      putLog $ "getPrimaryKey: primary key = " ++ show primaryKeyCols+      return primaryKeyCols+    _:_:_     -> do+      putLog   "getPrimaryKey: Fail to detect primary key. Something wrong."+      return []++getColumns' :: IConnection conn+          => TypeMap+          -> conn+          -> String+          -> String+          -> IO ([(String, TypeQ)], [Int])+getColumns' tmap conn scm' tbl' = do+  let scm = map toLower scm'+      tbl = map toLower tbl'+  cols <- runQuery' conn columnQuerySQL (scm, tbl)+  when (null cols) . compileErrorIO+    $ "getFields: No columns found: schema = " ++ scm ++ ", table = " ++ tbl++  let notNullIdxs = map fst . filter (notNull . snd) . zip [0..] $ cols+  putLog+    $  "getFields: num of columns = " ++ show (length cols)+    ++ ", not null columns = " ++ show notNullIdxs+  let getType' col = case getType (fromList tmap) col of+        Nothing -> compileErrorIO+                   $ "Type mapping is not defined against PostgreSQL type: " ++ Type.typname (snd col)+        Just p  -> return p++  types <- mapM getType' cols+  return (types, notNullIdxs)++-- | Driver implementation+driverPostgreSQL :: IConnection conn => Driver conn+driverPostgreSQL =+  emptyDriver { getFieldsWithMap = getColumns' }+              { getPrimaryKey    = getPrimaryKey' }
+ src/Database/HDBC/Schema/SQLServer.hs view
@@ -0,0 +1,87 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE MultiParamTypeClasses #-}++-- |+-- Module      : Database.HDBC.Schema.SQLServer+-- Copyright   : 2013 Shohei Murayama+-- License     : BSD3+--+-- Maintainer  : shohei.murayama@gmail.com+-- Stability   : experimental+-- Portability : unknown+module Database.HDBC.Schema.SQLServer (+  driverSQLServer,+  ) where++import qualified Database.Relational.Schema.SQLServerSyscat.Columns as Columns+import qualified Database.Relational.Schema.SQLServerSyscat.Types as Types++import Data.Map (fromList)+import Data.Maybe (catMaybes)+import Database.HDBC (IConnection, SqlValue)+import Database.HDBC.Record.Query (runQuery')+import Database.HDBC.Record.Persistable ()+import Database.HDBC.Schema.Driver (TypeMap, Driver, getFieldsWithMap, getPrimaryKey, emptyDriver)+import Database.Record.TH (makeRecordPersistableWithSqlTypeDefaultFromDefined)+import Database.Relational.Schema.SQLServer (columnTypeQuerySQL, getType, normalizeColumn,+                                            notNull, primaryKeyQuerySQL)+import Database.Relational.Schema.SQLServerSyscat.Columns (Columns)+import Database.Relational.Schema.SQLServerSyscat.Types (Types)+import Language.Haskell.TH (TypeQ)++$(makeRecordPersistableWithSqlTypeDefaultFromDefined+  [t| SqlValue |] ''Columns)++$(makeRecordPersistableWithSqlTypeDefaultFromDefined+  [t| SqlValue |] ''Types)++logPrefix :: String -> String+logPrefix = ("SQLServer: " ++)++putLog :: String -> IO ()+putLog = putStrLn . logPrefix++compileErrorIO :: String -> IO a+compileErrorIO =  fail . logPrefix++getPrimaryKey' :: IConnection conn+               => conn+               -> String+               -> String+               -> IO [String]+getPrimaryKey' conn scm tbl = do+    prims <- catMaybes `fmap` runQuery' conn primaryKeyQuerySQL (scm,tbl)+    let primColumns = map normalizeColumn prims+    putLog $ "getPrimaryKey: keys=" ++ show primColumns+    return primColumns++getFields' :: IConnection conn+           => TypeMap+           -> conn+           -> String+           -> String+           -> IO ([(String, TypeQ)], [Int])+getFields' tmap conn scm tbl = do+    rows <- runQuery' conn columnTypeQuerySQL (scm, tbl)+    case rows of+      [] -> compileErrorIO+            $ "getFields: No columns found: schema = " ++ scm ++ ", table = " ++ tbl+      _  -> return ()+    let columnId ((cols,_),_) = Columns.columnId cols - 1+    let notNullIdxs = map (fromIntegral . columnId) . filter notNull $ rows+    putLog+        $ "getFields: num of columns = " ++ show (length rows)+        ++ ", not null columns = " ++ show notNullIdxs+    let getType' rec@((_,typs),typScms) = case getType (fromList tmap) rec of+          Nothing -> compileErrorIO+                     $ "Type mapping is not defined against SQLServer type: "+                     ++ typScms ++ "." ++ Types.name typs+          Just p  -> return p+    types <- mapM getType' rows+    return (types, notNullIdxs)++driverSQLServer :: IConnection conn => Driver conn+driverSQLServer =+    emptyDriver { getFieldsWithMap = getFields' }+                { getPrimaryKey    = getPrimaryKey' }
+ src/Database/HDBC/Schema/SQLite3.hs view
@@ -0,0 +1,106 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE MultiParamTypeClasses #-}++-- |+-- Module      : Database.HDBC.Schema.SQLite3+-- Copyright   : 2013 Shohei Murayama+-- License     : BSD3+--+-- Maintainer  : shohei.murayama@gmail.com+-- Stability   : experimental+-- Portability : unknown+module Database.HDBC.Schema.SQLite3 (+  driverSQLite3+  ) where++import qualified Database.Relational.Schema.SQLite3Syscat.IndexInfo as IndexInfo+import qualified Database.Relational.Schema.SQLite3Syscat.IndexList as IndexList+import qualified Database.Relational.Schema.SQLite3Syscat.TableInfo as TableInfo++import Data.List (isPrefixOf, sort, sortBy)+import Data.Map (fromList)+import Database.HDBC (IConnection, SqlValue)+import Database.HDBC.Record.Query (runQuery')+import Database.HDBC.Record.Persistable ()+import Database.HDBC.Schema.Driver (TypeMap, Driver, getFieldsWithMap, getPrimaryKey, emptyDriver)+import Database.Record.TH (makeRecordPersistableWithSqlTypeDefaultFromDefined)+import Database.Relational.Schema.SQLite3 (getType, indexInfoQuerySQL, indexListQuerySQL, normalizeColumn,+                                           normalizeType, notNull, tableInfoQuerySQL)+import Database.Relational.Schema.SQLite3Syscat.IndexInfo (IndexInfo)+import Database.Relational.Schema.SQLite3Syscat.IndexList (IndexList)+import Database.Relational.Schema.SQLite3Syscat.TableInfo (TableInfo)+import Language.Haskell.TH (TypeQ)++$(makeRecordPersistableWithSqlTypeDefaultFromDefined+  [t| SqlValue |] ''TableInfo)++$(makeRecordPersistableWithSqlTypeDefaultFromDefined+  [t| SqlValue |] ''IndexList)++$(makeRecordPersistableWithSqlTypeDefaultFromDefined+  [t| SqlValue |] ''IndexInfo)++logPrefix :: String -> String+logPrefix = ("SQLite3: " ++)++putLog :: String -> IO ()+putLog = putStrLn . logPrefix++compileErrorIO :: String -> IO a+compileErrorIO =  fail . logPrefix++getPrimaryKey' :: IConnection conn+               => conn+               -> String+               -> String+               -> IO [String]+getPrimaryKey' conn scm tbl = do+    tblinfo <- runQuery' conn (tableInfoQuerySQL scm tbl) ()+    let primColumns = map (normalizeColumn . TableInfo.name)+                      . filter ((1 ==) . TableInfo.pk) $ tblinfo+    if length primColumns <= 1 then do+        putLog $ "getPrimaryKey: key=" ++ show primColumns+        return primColumns+     else do+        idxlist <- runQuery' conn (indexListQuerySQL scm tbl) ()+        let idxNames = filter (isPrefixOf "sqlite_autoindex_")+                       . map IndexList.name+                       . filter ((1 ==) . IndexList.unique) $ idxlist+        idxInfos <- mapM (\ixn -> runQuery' conn (indexInfoQuerySQL scm ixn) ()) idxNames+        let isPrimaryKey = (sort primColumns ==) . sort . map (normalizeColumn . IndexInfo.name)+        let idxInfo = concat . take 1 . filter isPrimaryKey $ idxInfos+        let comp x y = compare (IndexInfo.seqno x) (IndexInfo.seqno y)+        let primColumns' = map IndexInfo.name . sortBy comp $ idxInfo+        putLog $ "getPrimaryKey: keys=" ++ show primColumns'+        return primColumns'++getFields' :: IConnection conn+           => TypeMap+           -> conn+           -> String+           -> String+           -> IO ([(String, TypeQ)], [Int])+getFields' tmap conn scm tbl = do+    rows <- runQuery' conn (tableInfoQuerySQL scm tbl) ()+    case rows of+      [] -> compileErrorIO+            $ "getFields: No columns found: schema = " ++ scm ++ ", table = " ++ tbl+      _  -> return ()+    let columnId = TableInfo.cid+    let notNullIdxs = map (fromIntegral . columnId) . filter notNull $ rows+    putLog+        $ "getFields: num of columns = " ++ show (length rows)+        ++ ", not null columns = " ++ show notNullIdxs+    let getType' ti = case getType (fromList tmap) ti of+          Nothing -> compileErrorIO+                     $ "Type mapping is not defined against SQLite3 type: "+                     ++ normalizeType (TableInfo.ctype ti)+          Just p  -> return p+    types <- mapM getType' rows+    return (types, notNullIdxs)++driverSQLite3 :: IConnection conn => Driver conn+driverSQLite3 =+    emptyDriver { getFieldsWithMap = getFields' }+                { getPrimaryKey    = getPrimaryKey' }
+ src/Database/HDBC/SqlValueExtra.hs view
@@ -0,0 +1,30 @@+{-# LANGUAGE MultiParamTypeClasses #-}+{-# OPTIONS -fno-warn-orphans #-}++-- |+-- Module      : Database.HDBC.SqlValueExtra+-- Copyright   : 2013 Kei Hibino+-- License     : BSD3+--+-- Maintainer  : ex8k.hibino@gmail.com+-- Stability   : experimental+-- Portability : unknown+module Database.HDBC.SqlValueExtra () where++import Data.Convertible (Convertible(safeConvert), ConvertResult)+import Data.Int (Int16, Int32)+import Database.HDBC (SqlValue)++safeConvertFromIntegral32 :: Integral a => a -> ConvertResult SqlValue+safeConvertFromIntegral32 i =+  safeConvert (fromIntegral i :: Int32)++safeConvertToIntegral32 :: Integral a => SqlValue -> ConvertResult a+safeConvertToIntegral32 v =+  fmap fromIntegral (safeConvert v :: ConvertResult Int32)++instance Convertible Int16 SqlValue where+  safeConvert = safeConvertFromIntegral32++instance Convertible SqlValue Int16 where+  safeConvert = safeConvertToIntegral32