From a0aca19705c527e6d20c9800c7adbc3eb3c476f2 Mon Sep 17 00:00:00 2001
From: krdlab <krdlab@gmail.com>
Date: Sat, 21 Dec 2013 14:13:44 +0900
Subject: [PATCH 01/21] prototype

---
 relational-query-HDBC/example/mysql/LICENSE   |  30 +++++
 relational-query-HDBC/example/mysql/Setup.hs  |   2 +
 .../example/mysql/example.cabal               |  39 +++++++
 relational-query-HDBC/example/mysql/setup.sql |   2 +
 .../example/mysql/src/Main.hs                 |  42 +++++++
 .../example/mysql/src/MySQLTestDataSource.hs  |  33 ++++++
 .../src/Database/HDBC/Schema/MySQL.hs         |  83 ++++++++++++++
 .../src/Database/Relational/Schema/MySQL.hs   | 106 ++++++++++++++++++
 .../Relational/Schema/MySQLInfo/Columns.hs    |  19 ++++
 .../Schema/MySQLInfo/KeyColumnUsage.hs        |  17 +++
 .../Schema/MySQLInfo/TableConstraints.hs      |  15 +++
 11 files changed, 388 insertions(+)
 create mode 100644 relational-query-HDBC/example/mysql/LICENSE
 create mode 100644 relational-query-HDBC/example/mysql/Setup.hs
 create mode 100644 relational-query-HDBC/example/mysql/example.cabal
 create mode 100644 relational-query-HDBC/example/mysql/setup.sql
 create mode 100644 relational-query-HDBC/example/mysql/src/Main.hs
 create mode 100644 relational-query-HDBC/example/mysql/src/MySQLTestDataSource.hs
 create mode 100644 relational-query-HDBC/src/Database/HDBC/Schema/MySQL.hs
 create mode 100644 relational-schemas/src/Database/Relational/Schema/MySQL.hs
 create mode 100644 relational-schemas/src/Database/Relational/Schema/MySQLInfo/Columns.hs
 create mode 100644 relational-schemas/src/Database/Relational/Schema/MySQLInfo/KeyColumnUsage.hs
 create mode 100644 relational-schemas/src/Database/Relational/Schema/MySQLInfo/TableConstraints.hs

diff --git a/relational-query-HDBC/example/mysql/LICENSE b/relational-query-HDBC/example/mysql/LICENSE
new file mode 100644
index 00000000..ba0e33b7
--- /dev/null
+++ b/relational-query-HDBC/example/mysql/LICENSE
@@ -0,0 +1,30 @@
+Copyright (c) 2013, krdlab
+
+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 krdlab 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.
diff --git a/relational-query-HDBC/example/mysql/Setup.hs b/relational-query-HDBC/example/mysql/Setup.hs
new file mode 100644
index 00000000..9a994af6
--- /dev/null
+++ b/relational-query-HDBC/example/mysql/Setup.hs
@@ -0,0 +1,2 @@
+import Distribution.Simple
+main = defaultMain
diff --git a/relational-query-HDBC/example/mysql/example.cabal b/relational-query-HDBC/example/mysql/example.cabal
new file mode 100644
index 00000000..f08f873f
--- /dev/null
+++ b/relational-query-HDBC/example/mysql/example.cabal
@@ -0,0 +1,39 @@
+-- Initial example.cabal generated by cabal init.  For further 
+-- documentation, see http://haskell.org/cabal/users-guide/
+
+name:                example
+version:             0.1.0.0
+synopsis:            mysql example
+-- description:         
+license:             BSD3
+license-file:        LICENSE
+author:              krdlab
+maintainer:          krdlab@gmail.com
+-- copyright:           
+-- category:            
+build-type:          Simple
+-- extra-source-files:  
+cabal-version:       >=1.10
+
+executable example
+  main-is:
+    Main.hs
+  -- other-modules:       
+  other-extensions:
+      TemplateHaskell
+    , FlexibleInstances
+    , MultiParamTypeClasses
+    , MonadComprehensions
+  build-depends:
+      base >=4.6 && <4.7
+    , template-haskell >=2.8 && <2.9
+    , names-th
+    , relational-join
+    , HDBC-session
+    , relational-query-HDBC
+    , HDBC-mysql >=0.6 && <0.7
+    , relational-mysql
+  hs-source-dirs:
+    src
+  default-language:
+    Haskell2010
diff --git a/relational-query-HDBC/example/mysql/setup.sql b/relational-query-HDBC/example/mysql/setup.sql
new file mode 100644
index 00000000..2168a0a4
--- /dev/null
+++ b/relational-query-HDBC/example/mysql/setup.sql
@@ -0,0 +1,2 @@
+USE test;
+CREATE TABLE user (id BIGINT PRIMARY KEY, name VARCHAR(32) NOT NULL, memo TEXT, created_at DATE NOT NULL);
diff --git a/relational-query-HDBC/example/mysql/src/Main.hs b/relational-query-HDBC/example/mysql/src/Main.hs
new file mode 100644
index 00000000..5989c756
--- /dev/null
+++ b/relational-query-HDBC/example/mysql/src/Main.hs
@@ -0,0 +1,42 @@
+{-# LANGUAGE TemplateHaskell       #-}
+{-# LANGUAGE FlexibleInstances     #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE MonadComprehensions   #-}
+
+module Main where
+
+import Data.Int (Int64)
+import Prelude hiding (id)
+
+import Database.Relational.Query  ( query
+                                  , relation
+                                  , wheres
+                                  , (.=.)
+                                  , (!)
+                                  , value
+                                  , relationalQuery
+                                  , Relation
+                                  )
+import Database.HDBC.Session      ( withConnectionIO
+                                  , handleSqlError'
+                                  )
+import Database.HDBC.Record.Query ( runQuery
+                                  )
+import MySQLTestDataSource        (connect, defineTable)
+
+$(defineTable
+    []
+    "test" "user" [])
+
+main :: IO ()
+main = handleSqlError' $ withConnectionIO connect $ \conn -> do
+    r <- runQuery conn (relationalQuery test) ()
+    print r
+    where
+        test :: Relation () String
+        test = relation
+            [ u ! name'
+            | u <- query user
+            , () <- wheres $ u ! id' .=. value (1 :: Int64)
+            ]
+
diff --git a/relational-query-HDBC/example/mysql/src/MySQLTestDataSource.hs b/relational-query-HDBC/example/mysql/src/MySQLTestDataSource.hs
new file mode 100644
index 00000000..09732680
--- /dev/null
+++ b/relational-query-HDBC/example/mysql/src/MySQLTestDataSource.hs
@@ -0,0 +1,33 @@
+module MySQLTestDataSource
+    (
+      connect
+    , defineTable
+    )
+    where
+
+import Language.Haskell.TH                  (Q, Dec, TypeQ)
+import Language.Haskell.TH.Name.CamelCase   (ConName)
+
+import Database.HDBC.Query.TH       (defineTableFromDB)
+import Database.HDBC.Schema.Driver  (typeMap)
+import Database.HDBC.Schema.MySQL   (driverMySQL)
+import Database.HDBC.MySQL          ( Connection
+                                    , connectMySQL
+                                    , MySQLConnectInfo(..)
+                                    , defaultMySQLConnectInfo
+                                    )
+
+{-# ANN module "HLint: ignore Eta reduce" #-}
+
+connect :: IO Connection
+connect = connectMySQL config
+    where
+        config = defaultMySQLConnectInfo {
+                      mysqlUser     = "krdlab"
+                    , mysqlPassword = ""
+                    , mysqlDatabase = "test"
+                    }
+
+defineTable :: [(String, TypeQ)] -> String -> String -> [ConName] -> Q [Dec]
+defineTable tmap scm tbl derives =
+    defineTableFromDB connect (driverMySQL { typeMap = tmap }) scm tbl derives
diff --git a/relational-query-HDBC/src/Database/HDBC/Schema/MySQL.hs b/relational-query-HDBC/src/Database/HDBC/Schema/MySQL.hs
new file mode 100644
index 00000000..69abecb0
--- /dev/null
+++ b/relational-query-HDBC/src/Database/HDBC/Schema/MySQL.hs
@@ -0,0 +1,83 @@
+{-# 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 Language.Haskell.TH.Lib.Extra      as TH
+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                 (defineRecordWithSqlTypeDefaultFromDefined)
+import qualified Database.Relational.Query.Table    as Table
+import           Database.Relational.Schema.MySQL   ( normalizeColumn
+                                                    , notNull 
+                                                    , getType
+                                                    , columnsQuerySQL
+                                                    , primaryKeyQuerySQL
+                                                    )
+
+import           Database.Relational.Schema.MySQLInfo.Columns (Columns(Columns), tableOfColumns)
+import qualified Database.Relational.Schema.MySQLInfo.Columns as Columns
+
+$(defineRecordWithSqlTypeDefaultFromDefined [t| SqlValue |] (Table.shortName tableOfColumns))
+
+logPrefix :: String -> String
+logPrefix = ("MySQL: " ++)
+
+putLog :: String -> IO ()
+putLog = putStrLn . logPrefix
+
+compileErrorIO :: String -> IO a
+compileErrorIO =  TH.compileErrorIO . 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
+    let 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
+
+    types <- mapM getType' cols
+    return (types, notNullIdxs)
+
+-- | Driver implementation
+driverMySQL :: IConnection conn => Driver conn
+driverMySQL =
+    emptyDriver { getFieldsWithMap = getFields' }
+                { getPrimaryKey    = getPrimaryKey' }
diff --git a/relational-schemas/src/Database/Relational/Schema/MySQL.hs b/relational-schemas/src/Database/Relational/Schema/MySQL.hs
new file mode 100644
index 00000000..3b56c566
--- /dev/null
+++ b/relational-schemas/src/Database/Relational/Schema/MySQL.hs
@@ -0,0 +1,106 @@
+{-# LANGUAGE TemplateHaskell #-}
+
+module Database.Relational.Schema.MySQL
+    ( normalizeColumn
+    , notNull
+    , getType
+    , columnsQuerySQL
+    , primaryKeyQuerySQL
+    )
+    where
+
+import           Data.Int               (Int16, Int32, Int64)
+import           Data.Char              (toLower, toUpper)
+import           Data.Map               (Map, fromList)
+import qualified Data.Map               as Map
+import           Data.Time              (LocalTime, Day)
+import           Language.Haskell.TH    (TypeQ)
+import           Control.Applicative    ((<|>))
+
+import Database.Relational.Query        ( Query
+                                        , query
+                                        , relation'
+                                        , wheres
+                                        , (.=.)
+                                        , (!)
+                                        , (><)
+                                        , placeholder
+                                        , asc
+                                        , value
+                                        )
+import Database.Relational.Query.Type   (relationalQuery)
+
+import           Database.Relational.Schema.MySQLInfo.Columns           (Columns, columns)
+import qualified Database.Relational.Schema.MySQLInfo.Columns           as Columns
+import           Database.Relational.Schema.MySQLInfo.TableConstraints  (tableConstraints)
+import qualified Database.Relational.Schema.MySQLInfo.TableConstraints  as Tabconst
+import           Database.Relational.Schema.MySQLInfo.KeyColumnUsage    (keyColumnUsage)
+import qualified Database.Relational.Schema.MySQLInfo.KeyColumnUsage    as Keycoluse
+
+mapFromSqlDefault :: Map String TypeQ
+mapFromSqlDefault = fromList
+    [ ("VARCHAR",   [t|String|])
+    , ("TEXT",      [t|String|])
+    , ("CHAR",      [t|String|])
+    , ("CHARACTER", [t|String|])
+    , ("TIMESTAMP", [t|LocalTime|])
+    , ("DATE",      [t|Day|])
+    , ("SMALLINT",  [t|Int16|])
+    , ("INTEGER",   [t|Int32|])
+    , ("BIGINT",    [t|Int64|])
+    , ("BLOB",      [t|String|])
+    , ("CLOB",      [t|String|])
+    ]
+
+normalizeColumn :: String -> String
+normalizeColumn =  map toLower
+
+notNull :: Columns -> Bool
+notNull =  (== "NO") . Columns.isNullable
+
+getType :: Map String TypeQ
+        -> Columns
+        -> Maybe (String, TypeQ)
+getType mapFromSql rec = do
+    typ <- Map.lookup key mapFromSql
+           <|>
+           Map.lookup key mapFromSqlDefault
+    return (normalizeColumn $ Columns.columnName rec, mayNull typ)
+    where
+        key = map toUpper $ Columns.dataType rec
+        mayNull typ = if notNull rec
+                      then typ
+                      else [t|Maybe $(typ)|]
+
+columnsQuerySQL :: Query (String, String) Columns
+columnsQuerySQL =  relationalQuery columnsRelationFromTable
+    where
+        columnsRelationFromTable =  relation' $ do
+            c <- query columns
+            (schemaP, ()) <- placeholder (\ph -> wheres $ c ! Columns.tableSchema' .=. ph)
+            (nameP  , ()) <- placeholder (\ph -> wheres $ c ! Columns.tableName'   .=. ph)
+            asc $ c ! Columns.ordinalPosition'
+            return (schemaP >< nameP, c)
+
+primaryKeyQuerySQL :: Query (String, String) String
+primaryKeyQuerySQL =  relationalQuery primaryKeyRelation
+    where
+        primaryKeyRelation =  relation' $ do
+            cons  <- query tableConstraints
+            key   <- query keyColumnUsage
+            col   <- query columns
+
+            wheres $ cons ! Tabconst.tableSchema'    .=. col ! Columns.tableSchema'
+            wheres $ cons ! Tabconst.tableName'      .=. col ! Columns.tableName'
+            wheres $ key  ! Keycoluse.columnName'    .=. col ! Columns.columnName'
+            wheres $ cons ! Tabconst.constraintName' .=. key ! Keycoluse.constraintName'
+
+            wheres $ col  ! Columns.isNullable'      .=. value "NO"
+            wheres $ cons ! Tabconst.constraintType' .=. value "PRIMARY KEY"
+
+            (schemaP, ()) <- placeholder (\ph -> wheres $ cons ! Tabconst.tableSchema' .=. ph)
+            (nameP  , ()) <- placeholder (\ph -> wheres $ cons ! Tabconst.tableName'   .=. ph)
+
+            asc  $ key ! Keycoluse.ordinalPosition'
+
+            return   (schemaP >< nameP, key ! Keycoluse.columnName')
diff --git a/relational-schemas/src/Database/Relational/Schema/MySQLInfo/Columns.hs b/relational-schemas/src/Database/Relational/Schema/MySQLInfo/Columns.hs
new file mode 100644
index 00000000..d8d1e8ee
--- /dev/null
+++ b/relational-schemas/src/Database/Relational/Schema/MySQLInfo/Columns.hs
@@ -0,0 +1,19 @@
+{-# LANGUAGE TemplateHaskell #-}
+
+module Database.Relational.Schema.MySQLInfo.Columns where
+
+import Data.Int                     (Int16)
+import Database.Record.TH           (derivingShow)
+import Database.Relational.Query.TH (defineTableTypesAndRecordDefault)
+
+$(defineTableTypesAndRecordDefault
+    "INFORMATION_SCHEMA" "columns"
+    [ ("table_schema",      [t|String|])
+    , ("table_name",        [t|String|])
+    , ("column_name",       [t|String|])
+    , ("ordinal_position",  [t|Int16|])
+    , ("column_default",    [t|Maybe String|])
+    , ("is_nullable",       [t|String|])
+    , ("data_type",         [t|String|])
+    ]
+    [derivingShow])
diff --git a/relational-schemas/src/Database/Relational/Schema/MySQLInfo/KeyColumnUsage.hs b/relational-schemas/src/Database/Relational/Schema/MySQLInfo/KeyColumnUsage.hs
new file mode 100644
index 00000000..95479442
--- /dev/null
+++ b/relational-schemas/src/Database/Relational/Schema/MySQLInfo/KeyColumnUsage.hs
@@ -0,0 +1,17 @@
+{-# LANGUAGE TemplateHaskell #-}
+
+module Database.Relational.Schema.MySQLInfo.KeyColumnUsage where
+
+import Data.Int                     (Int16)
+import Database.Record.TH           (derivingShow)
+import Database.Relational.Query.TH (defineTableTypesAndRecordDefault)
+
+$(defineTableTypesAndRecordDefault
+    "INFORMATION_SCHEMA" "key_column_usage"
+    [ ("constraint_name"    , [t| String |])
+    , ("table_schema"       , [t| String |])
+    , ("table_name"         , [t| String |])
+    , ("column_name"        , [t| String |])
+    , ("ordinal_position"   , [t| Int16 |])
+    ]
+    [derivingShow])
diff --git a/relational-schemas/src/Database/Relational/Schema/MySQLInfo/TableConstraints.hs b/relational-schemas/src/Database/Relational/Schema/MySQLInfo/TableConstraints.hs
new file mode 100644
index 00000000..a2d8d409
--- /dev/null
+++ b/relational-schemas/src/Database/Relational/Schema/MySQLInfo/TableConstraints.hs
@@ -0,0 +1,15 @@
+{-# LANGUAGE TemplateHaskell #-}
+
+module Database.Relational.Schema.MySQLInfo.TableConstraints where
+
+import Database.Record.TH           (derivingShow)
+import Database.Relational.Query.TH (defineTableTypesAndRecordDefault)
+
+$(defineTableTypesAndRecordDefault
+    "INFORMATION_SCHEMA" "table_constraints"
+    [ ("table_schema"       , [t| String |])
+    , ("table_name"         , [t| String |])
+    , ("constraint_name"    , [t| String |])
+    , ("constraint_type"    , [t| String |])
+    ]
+    [derivingShow])

From e22d8e8b6bd4905705c87c865580630df1fee0b8 Mon Sep 17 00:00:00 2001
From: krdlab <krdlab@gmail.com>
Date: Sun, 22 Dec 2013 14:27:46 +0900
Subject: [PATCH 02/21] Modify example

---
 .../example/mysql/example.cabal               |  3 +-
 relational-query-HDBC/example/mysql/setup.sql |  5 +-
 .../example/mysql/src/Main.hs                 | 46 ++++++++-----------
 .../example/mysql/src/MySQLTestDataSource.hs  | 33 +++++++------
 .../example/mysql/src/User.hs                 | 11 +++++
 5 files changed, 52 insertions(+), 46 deletions(-)
 create mode 100644 relational-query-HDBC/example/mysql/src/User.hs

diff --git a/relational-query-HDBC/example/mysql/example.cabal b/relational-query-HDBC/example/mysql/example.cabal
index f08f873f..28cbc676 100644
--- a/relational-query-HDBC/example/mysql/example.cabal
+++ b/relational-query-HDBC/example/mysql/example.cabal
@@ -3,7 +3,7 @@
 
 name:                example
 version:             0.1.0.0
-synopsis:            mysql example
+synopsis:            mysql driver example
 -- description:         
 license:             BSD3
 license-file:        LICENSE
@@ -33,6 +33,7 @@ executable example
     , relational-query-HDBC
     , HDBC-mysql >=0.6 && <0.7
     , relational-mysql
+    , time
   hs-source-dirs:
     src
   default-language:
diff --git a/relational-query-HDBC/example/mysql/setup.sql b/relational-query-HDBC/example/mysql/setup.sql
index 2168a0a4..a64ae7c7 100644
--- a/relational-query-HDBC/example/mysql/setup.sql
+++ b/relational-query-HDBC/example/mysql/setup.sql
@@ -1,2 +1,3 @@
-USE test;
-CREATE TABLE user (id BIGINT PRIMARY KEY, name VARCHAR(32) NOT NULL, memo TEXT, created_at DATE NOT NULL);
+CREATE DATABASE TEST DEFAULT CHARACTER SET UTF8;
+CREATE TABLE TEST.user (id BIGINT PRIMARY KEY, name VARCHAR(32) NOT NULL, memo TEXT, created_at DATE NOT NULL);
+INSERT INTO TEST.user (id, name, created_at) VALUES (1, 'krdlab', NOW());
diff --git a/relational-query-HDBC/example/mysql/src/Main.hs b/relational-query-HDBC/example/mysql/src/Main.hs
index 5989c756..998ca2ca 100644
--- a/relational-query-HDBC/example/mysql/src/Main.hs
+++ b/relational-query-HDBC/example/mysql/src/Main.hs
@@ -1,32 +1,22 @@
-{-# LANGUAGE TemplateHaskell       #-}
-{-# LANGUAGE FlexibleInstances     #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE MonadComprehensions   #-}
-
 module Main where
 
-import Data.Int (Int64)
-import Prelude hiding (id)
+import Database.Relational.Query    ( query
+                                    , relation
+                                    , wheres
+                                    , (.=.)
+                                    , (!)
+                                    , value
+                                    , relationalQuery
+                                    , Relation
+                                    )
+import Database.HDBC.Session        (withConnectionIO, handleSqlError')
+import Database.HDBC.Record.Query   (runQuery)
 
-import Database.Relational.Query  ( query
-                                  , relation
-                                  , wheres
-                                  , (.=.)
-                                  , (!)
-                                  , value
-                                  , relationalQuery
-                                  , Relation
-                                  )
-import Database.HDBC.Session      ( withConnectionIO
-                                  , handleSqlError'
-                                  )
-import Database.HDBC.Record.Query ( runQuery
-                                  )
-import MySQLTestDataSource        (connect, defineTable)
-
-$(defineTable
-    []
-    "test" "user" [])
+import Data.Int                     (Int64)
+import MySQLTestDataSource          (connect)
+import User                         (user)
+import qualified User as U
 
 main :: IO ()
 main = handleSqlError' $ withConnectionIO connect $ \conn -> do
@@ -35,8 +25,8 @@ main = handleSqlError' $ withConnectionIO connect $ \conn -> do
     where
         test :: Relation () String
         test = relation
-            [ u ! name'
-            | u <- query user
-            , () <- wheres $ u ! id' .=. value (1 :: Int64)
+            [ u ! U.name'
+            | u  <- query user
+            , () <- wheres $ u ! U.id' .=. value (1 :: Int64)
             ]
 
diff --git a/relational-query-HDBC/example/mysql/src/MySQLTestDataSource.hs b/relational-query-HDBC/example/mysql/src/MySQLTestDataSource.hs
index 09732680..c85dc4ea 100644
--- a/relational-query-HDBC/example/mysql/src/MySQLTestDataSource.hs
+++ b/relational-query-HDBC/example/mysql/src/MySQLTestDataSource.hs
@@ -1,6 +1,7 @@
 module MySQLTestDataSource
     (
-      connect
+      config
+    , connect
     , defineTable
     )
     where
@@ -8,25 +9,27 @@ module MySQLTestDataSource
 import Language.Haskell.TH                  (Q, Dec, TypeQ)
 import Language.Haskell.TH.Name.CamelCase   (ConName)
 
-import Database.HDBC.Query.TH       (defineTableFromDB)
-import Database.HDBC.Schema.Driver  (typeMap)
-import Database.HDBC.Schema.MySQL   (driverMySQL)
-import Database.HDBC.MySQL          ( Connection
-                                    , connectMySQL
-                                    , MySQLConnectInfo(..)
-                                    , defaultMySQLConnectInfo
-                                    )
+import Database.HDBC.Query.TH               (defineTableFromDB)
+import Database.HDBC.Schema.Driver          (typeMap)
+import Database.HDBC.Schema.MySQL           (driverMySQL)
+import Database.HDBC.MySQL                  ( Connection
+                                            , connectMySQL
+                                            , MySQLConnectInfo(..)
+                                            , defaultMySQLConnectInfo
+                                            )
 
 {-# ANN module "HLint: ignore Eta reduce" #-}
 
+config :: MySQLConnectInfo
+config = defaultMySQLConnectInfo {
+              mysqlUser     = "***" -- TODO
+            , mysqlPassword = ""
+            , mysqlDatabase = "TEST"
+            , mysqlHost     = "***" -- TODO: your mysql host
+            }
+
 connect :: IO Connection
 connect = connectMySQL config
-    where
-        config = defaultMySQLConnectInfo {
-                      mysqlUser     = "krdlab"
-                    , mysqlPassword = ""
-                    , mysqlDatabase = "test"
-                    }
 
 defineTable :: [(String, TypeQ)] -> String -> String -> [ConName] -> Q [Dec]
 defineTable tmap scm tbl derives =
diff --git a/relational-query-HDBC/example/mysql/src/User.hs b/relational-query-HDBC/example/mysql/src/User.hs
new file mode 100644
index 00000000..60f1d3c5
--- /dev/null
+++ b/relational-query-HDBC/example/mysql/src/User.hs
@@ -0,0 +1,11 @@
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+module User where
+
+import Prelude hiding (id)
+import MySQLTestDataSource (defineTable)
+
+$(defineTable
+    []
+    "TEST" "user" [])

From ad0b915274529ef4220c0ec20b23af86c9a475a5 Mon Sep 17 00:00:00 2001
From: krdlab <krdlab@gmail.com>
Date: Sun, 22 Dec 2013 14:46:32 +0900
Subject: [PATCH 03/21] Format

---
 .../src/Database/HDBC/Schema/MySQL.hs         | 55 +++++++++++--------
 .../src/Database/Relational/Schema/MySQL.hs   | 23 ++++----
 2 files changed, 42 insertions(+), 36 deletions(-)

diff --git a/relational-query-HDBC/src/Database/HDBC/Schema/MySQL.hs b/relational-query-HDBC/src/Database/HDBC/Schema/MySQL.hs
index 69abecb0..c27baff1 100644
--- a/relational-query-HDBC/src/Database/HDBC/Schema/MySQL.hs
+++ b/relational-query-HDBC/src/Database/HDBC/Schema/MySQL.hs
@@ -1,10 +1,11 @@
 {-# OPTIONS_GHC -fno-warn-orphans  #-}
 {-# LANGUAGE TemplateHaskell       #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
-
-module Database.HDBC.Schema.MySQL (
-  driverMySQL
-  ) where
+module Database.HDBC.Schema.MySQL
+    (
+      driverMySQL
+    )
+    where
 
 import           Prelude                            hiding (length)
 import           Language.Haskell.TH                (TypeQ)
@@ -12,11 +13,15 @@ import qualified Language.Haskell.TH.Lib.Extra      as TH
 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.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                 (defineRecordWithSqlTypeDefaultFromDefined)
 import qualified Database.Relational.Query.Table    as Table
 import           Database.Relational.Schema.MySQL   ( normalizeColumn
@@ -38,7 +43,7 @@ putLog :: String -> IO ()
 putLog = putStrLn . logPrefix
 
 compileErrorIO :: String -> IO a
-compileErrorIO =  TH.compileErrorIO . logPrefix
+compileErrorIO = TH.compileErrorIO . logPrefix
 
 getPrimaryKey' :: IConnection conn
                => conn
@@ -52,29 +57,31 @@ getPrimaryKey' conn scm tbl = do
     return primaryKeyCols
 
 getFields' :: IConnection conn
-          => TypeMap
-          -> conn
-          -> String
-          -> String
-          -> IO ([(String, TypeQ)], [Int])
+           => 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 ()
-
+        [] -> 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
-    let 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
-
     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
diff --git a/relational-schemas/src/Database/Relational/Schema/MySQL.hs b/relational-schemas/src/Database/Relational/Schema/MySQL.hs
index 3b56c566..79e1267a 100644
--- a/relational-schemas/src/Database/Relational/Schema/MySQL.hs
+++ b/relational-schemas/src/Database/Relational/Schema/MySQL.hs
@@ -1,5 +1,4 @@
 {-# LANGUAGE TemplateHaskell #-}
-
 module Database.Relational.Schema.MySQL
     ( normalizeColumn
     , notNull
@@ -53,10 +52,10 @@ mapFromSqlDefault = fromList
     ]
 
 normalizeColumn :: String -> String
-normalizeColumn =  map toLower
+normalizeColumn = map toLower
 
 notNull :: Columns -> Bool
-notNull =  (== "NO") . Columns.isNullable
+notNull = (== "NO") . Columns.isNullable
 
 getType :: Map String TypeQ
         -> Columns
@@ -73,9 +72,9 @@ getType mapFromSql rec = do
                       else [t|Maybe $(typ)|]
 
 columnsQuerySQL :: Query (String, String) Columns
-columnsQuerySQL =  relationalQuery columnsRelationFromTable
+columnsQuerySQL = relationalQuery columnsRelationFromTable
     where
-        columnsRelationFromTable =  relation' $ do
+        columnsRelationFromTable = relation' $ do
             c <- query columns
             (schemaP, ()) <- placeholder (\ph -> wheres $ c ! Columns.tableSchema' .=. ph)
             (nameP  , ()) <- placeholder (\ph -> wheres $ c ! Columns.tableName'   .=. ph)
@@ -83,12 +82,12 @@ columnsQuerySQL =  relationalQuery columnsRelationFromTable
             return (schemaP >< nameP, c)
 
 primaryKeyQuerySQL :: Query (String, String) String
-primaryKeyQuerySQL =  relationalQuery primaryKeyRelation
+primaryKeyQuerySQL = relationalQuery primaryKeyRelation
     where
-        primaryKeyRelation =  relation' $ do
-            cons  <- query tableConstraints
-            key   <- query keyColumnUsage
-            col   <- query columns
+        primaryKeyRelation = relation' $ do
+            cons <- query tableConstraints
+            key  <- query keyColumnUsage
+            col  <- query columns
 
             wheres $ cons ! Tabconst.tableSchema'    .=. col ! Columns.tableSchema'
             wheres $ cons ! Tabconst.tableName'      .=. col ! Columns.tableName'
@@ -101,6 +100,6 @@ primaryKeyQuerySQL =  relationalQuery primaryKeyRelation
             (schemaP, ()) <- placeholder (\ph -> wheres $ cons ! Tabconst.tableSchema' .=. ph)
             (nameP  , ()) <- placeholder (\ph -> wheres $ cons ! Tabconst.tableName'   .=. ph)
 
-            asc  $ key ! Keycoluse.ordinalPosition'
+            asc $ key ! Keycoluse.ordinalPosition'
 
-            return   (schemaP >< nameP, key ! Keycoluse.columnName')
+            return (schemaP >< nameP, key ! Keycoluse.columnName')

From 3a0acebcb0d71760ca73096426fd5d8b8b8ce974 Mon Sep 17 00:00:00 2001
From: krdlab <krdlab@gmail.com>
Date: Sun, 22 Dec 2013 15:34:28 +0900
Subject: [PATCH 04/21] Add support of basic data types

---
 .../example/mysql/src/Main.hs                 |  6 ++-
 .../src/Database/Relational/Schema/MySQL.hs   | 38 ++++++++++++-------
 2 files changed, 28 insertions(+), 16 deletions(-)

diff --git a/relational-query-HDBC/example/mysql/src/Main.hs b/relational-query-HDBC/example/mysql/src/Main.hs
index 998ca2ca..b9e5ec38 100644
--- a/relational-query-HDBC/example/mysql/src/Main.hs
+++ b/relational-query-HDBC/example/mysql/src/Main.hs
@@ -6,6 +6,7 @@ import Database.Relational.Query    ( query
                                     , wheres
                                     , (.=.)
                                     , (!)
+                                    , (><)
                                     , value
                                     , relationalQuery
                                     , Relation
@@ -14,6 +15,7 @@ import Database.HDBC.Session        (withConnectionIO, handleSqlError')
 import Database.HDBC.Record.Query   (runQuery)
 
 import Data.Int                     (Int64)
+import Data.Time                    (Day)
 import MySQLTestDataSource          (connect)
 import User                         (user)
 import qualified User as U
@@ -23,9 +25,9 @@ main = handleSqlError' $ withConnectionIO connect $ \conn -> do
     r <- runQuery conn (relationalQuery test) ()
     print r
     where
-        test :: Relation () String
+        test :: Relation () (String, Day)
         test = relation
-            [ u ! U.name'
+            [ u ! U.name' >< u ! U.createdAt'
             | u  <- query user
             , () <- wheres $ u ! U.id' .=. value (1 :: Int64)
             ]
diff --git a/relational-schemas/src/Database/Relational/Schema/MySQL.hs b/relational-schemas/src/Database/Relational/Schema/MySQL.hs
index 79e1267a..e4102ea1 100644
--- a/relational-schemas/src/Database/Relational/Schema/MySQL.hs
+++ b/relational-schemas/src/Database/Relational/Schema/MySQL.hs
@@ -8,13 +8,15 @@ module Database.Relational.Schema.MySQL
     )
     where
 
-import           Data.Int               (Int16, Int32, Int64)
+import           Data.Int               (Int8, Int16, Int32, Int64)
 import           Data.Char              (toLower, toUpper)
 import           Data.Map               (Map, fromList)
 import qualified Data.Map               as Map
-import           Data.Time              (LocalTime, Day)
-import           Language.Haskell.TH    (TypeQ)
+import           Data.Time              (Day, LocalTime, TimeOfDay)
+import           Data.Time.Clock.POSIX  (POSIXTime)
+import           Data.ByteString        (ByteString)
 import           Control.Applicative    ((<|>))
+import           Language.Haskell.TH    (TypeQ)
 
 import Database.Relational.Query        ( Query
                                         , query
@@ -38,17 +40,25 @@ import qualified Database.Relational.Schema.MySQLInfo.KeyColumnUsage    as Keyco
 
 mapFromSqlDefault :: Map String TypeQ
 mapFromSqlDefault = fromList
-    [ ("VARCHAR",   [t|String|])
-    , ("TEXT",      [t|String|])
-    , ("CHAR",      [t|String|])
-    , ("CHARACTER", [t|String|])
-    , ("TIMESTAMP", [t|LocalTime|])
-    , ("DATE",      [t|Day|])
-    , ("SMALLINT",  [t|Int16|])
-    , ("INTEGER",   [t|Int32|])
-    , ("BIGINT",    [t|Int64|])
-    , ("BLOB",      [t|String|])
-    , ("CLOB",      [t|String|])
+    [ ("CHAR",       [t| String |])
+    , ("VARCHAR",    [t| String |])
+    , ("TINYTEXT",   [t| String |])
+    , ("TEXT",       [t| String |])
+    , ("MEDIUMTEXT", [t| String |])
+    , ("LONGTEXT",   [t| String |])
+    , ("TINYBLOB",   [t| ByteString |])
+    , ("BLOB",       [t| ByteString |])
+    , ("MEDIUMBLOB", [t| ByteString |])
+    , ("LONGBLOB",   [t| ByteString |])
+    , ("DATE",       [t| Day |])
+    , ("DATETIME",   [t| LocalTime |])
+    , ("TIME",       [t| TimeOfDay |])
+    , ("TIMESTAMP",  [t| POSIXTime |])
+    , ("TINYINT",    [t| Int8 |])
+    , ("SMALLINT",   [t| Int16 |])
+    , ("INT",        [t| Int32 |])
+    , ("INTEGER",    [t| Int32 |])
+    , ("BIGINT",     [t| Int64 |])
     ]
 
 normalizeColumn :: String -> String

From 74c41dd1e5b9b3c7b66fb20ed27e85071c024585 Mon Sep 17 00:00:00 2001
From: krdlab <krdlab@gmail.com>
Date: Wed, 25 Dec 2013 22:00:13 +0900
Subject: [PATCH 05/21] Update "build-depends"

---
 relational-query-HDBC/example/mysql/example.cabal | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/relational-query-HDBC/example/mysql/example.cabal b/relational-query-HDBC/example/mysql/example.cabal
index 28cbc676..1fd72ee6 100644
--- a/relational-query-HDBC/example/mysql/example.cabal
+++ b/relational-query-HDBC/example/mysql/example.cabal
@@ -28,7 +28,7 @@ executable example
       base >=4.6 && <4.7
     , template-haskell >=2.8 && <2.9
     , names-th
-    , relational-join
+    , relational-query
     , HDBC-session
     , relational-query-HDBC
     , HDBC-mysql >=0.6 && <0.7

From a0e047686a2b0c4651d8348f782ad42f7d848214 Mon Sep 17 00:00:00 2001
From: Kei Hibino <ex8k.hibino@gmail.com>
Date: Sat, 28 Dec 2013 18:49:14 +0900
Subject: [PATCH 06/21] Update along with default ProductConstructor instances
 definition.

---
 .../src/Database/Relational/Schema/MySQLInfo/Columns.hs          | 1 +
 .../src/Database/Relational/Schema/MySQLInfo/KeyColumnUsage.hs   | 1 +
 .../src/Database/Relational/Schema/MySQLInfo/TableConstraints.hs | 1 +
 3 files changed, 3 insertions(+)

diff --git a/relational-schemas/src/Database/Relational/Schema/MySQLInfo/Columns.hs b/relational-schemas/src/Database/Relational/Schema/MySQLInfo/Columns.hs
index d8d1e8ee..d4daf296 100644
--- a/relational-schemas/src/Database/Relational/Schema/MySQLInfo/Columns.hs
+++ b/relational-schemas/src/Database/Relational/Schema/MySQLInfo/Columns.hs
@@ -1,4 +1,5 @@
 {-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE FlexibleInstances #-}
 
 module Database.Relational.Schema.MySQLInfo.Columns where
 
diff --git a/relational-schemas/src/Database/Relational/Schema/MySQLInfo/KeyColumnUsage.hs b/relational-schemas/src/Database/Relational/Schema/MySQLInfo/KeyColumnUsage.hs
index 95479442..8889ee2c 100644
--- a/relational-schemas/src/Database/Relational/Schema/MySQLInfo/KeyColumnUsage.hs
+++ b/relational-schemas/src/Database/Relational/Schema/MySQLInfo/KeyColumnUsage.hs
@@ -1,4 +1,5 @@
 {-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE FlexibleInstances #-}
 
 module Database.Relational.Schema.MySQLInfo.KeyColumnUsage where
 
diff --git a/relational-schemas/src/Database/Relational/Schema/MySQLInfo/TableConstraints.hs b/relational-schemas/src/Database/Relational/Schema/MySQLInfo/TableConstraints.hs
index a2d8d409..47887845 100644
--- a/relational-schemas/src/Database/Relational/Schema/MySQLInfo/TableConstraints.hs
+++ b/relational-schemas/src/Database/Relational/Schema/MySQLInfo/TableConstraints.hs
@@ -1,4 +1,5 @@
 {-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE FlexibleInstances #-}
 
 module Database.Relational.Schema.MySQLInfo.TableConstraints where
 

From 01be883bd0910f73c060f1a4fb6e99f651b39e8b Mon Sep 17 00:00:00 2001
From: Kei Hibino <ex8k.hibino@gmail.com>
Date: Sat, 15 Feb 2014 21:48:06 +0900
Subject: [PATCH 07/21] Generate persistable templates from type name TH
 symbol.

---
 relational-query-HDBC/src/Database/HDBC/Schema/MySQL.hs | 9 ++++-----
 1 file changed, 4 insertions(+), 5 deletions(-)

diff --git a/relational-query-HDBC/src/Database/HDBC/Schema/MySQL.hs b/relational-query-HDBC/src/Database/HDBC/Schema/MySQL.hs
index c27baff1..b2354253 100644
--- a/relational-query-HDBC/src/Database/HDBC/Schema/MySQL.hs
+++ b/relational-query-HDBC/src/Database/HDBC/Schema/MySQL.hs
@@ -22,19 +22,18 @@ import           Database.HDBC.Schema.Driver        ( TypeMap
                                                     , getPrimaryKey
                                                     , emptyDriver
                                                     )
-import           Database.Record.TH                 (defineRecordWithSqlTypeDefaultFromDefined)
-import qualified Database.Relational.Query.Table    as Table
+import           Database.Record.TH                 (makeRecordPersistableWithSqlTypeDefaultFromDefined)
 import           Database.Relational.Schema.MySQL   ( normalizeColumn
-                                                    , notNull 
+                                                    , notNull
                                                     , getType
                                                     , columnsQuerySQL
                                                     , primaryKeyQuerySQL
                                                     )
 
-import           Database.Relational.Schema.MySQLInfo.Columns (Columns(Columns), tableOfColumns)
+import           Database.Relational.Schema.MySQLInfo.Columns (Columns)
 import qualified Database.Relational.Schema.MySQLInfo.Columns as Columns
 
-$(defineRecordWithSqlTypeDefaultFromDefined [t| SqlValue |] (Table.shortName tableOfColumns))
+$(makeRecordPersistableWithSqlTypeDefaultFromDefined [t| SqlValue |] ''Columns)
 
 logPrefix :: String -> String
 logPrefix = ("MySQL: " ++)

From 556d98e739342642b5425ab4695ec9611b7f2330 Mon Sep 17 00:00:00 2001
From: krdlab <krdlab@gmail.com>
Date: Tue, 18 Feb 2014 02:12:12 +0900
Subject: [PATCH 08/21] Rename DataSource and User files in the example project

---
 .../src/{MySQLTestDataSource.hs => Example/DataSource.hs}  | 2 +-
 .../example/mysql/src/{ => Example}/User.hs                | 4 ++--
 relational-query-HDBC/example/mysql/src/Main.hs            | 7 ++++---
 3 files changed, 7 insertions(+), 6 deletions(-)
 rename relational-query-HDBC/example/mysql/src/{MySQLTestDataSource.hs => Example/DataSource.hs} (97%)
 rename relational-query-HDBC/example/mysql/src/{ => Example}/User.hs (73%)

diff --git a/relational-query-HDBC/example/mysql/src/MySQLTestDataSource.hs b/relational-query-HDBC/example/mysql/src/Example/DataSource.hs
similarity index 97%
rename from relational-query-HDBC/example/mysql/src/MySQLTestDataSource.hs
rename to relational-query-HDBC/example/mysql/src/Example/DataSource.hs
index c85dc4ea..7f34fab3 100644
--- a/relational-query-HDBC/example/mysql/src/MySQLTestDataSource.hs
+++ b/relational-query-HDBC/example/mysql/src/Example/DataSource.hs
@@ -1,4 +1,4 @@
-module MySQLTestDataSource
+module Example.DataSource
     (
       config
     , connect
diff --git a/relational-query-HDBC/example/mysql/src/User.hs b/relational-query-HDBC/example/mysql/src/Example/User.hs
similarity index 73%
rename from relational-query-HDBC/example/mysql/src/User.hs
rename to relational-query-HDBC/example/mysql/src/Example/User.hs
index 60f1d3c5..953884e7 100644
--- a/relational-query-HDBC/example/mysql/src/User.hs
+++ b/relational-query-HDBC/example/mysql/src/Example/User.hs
@@ -1,10 +1,10 @@
 {-# LANGUAGE TemplateHaskell #-}
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
-module User where
+module Example.User where
 
 import Prelude hiding (id)
-import MySQLTestDataSource (defineTable)
+import Example.DataSource (defineTable)
 
 $(defineTable
     []
diff --git a/relational-query-HDBC/example/mysql/src/Main.hs b/relational-query-HDBC/example/mysql/src/Main.hs
index b9e5ec38..bad22513 100644
--- a/relational-query-HDBC/example/mysql/src/Main.hs
+++ b/relational-query-HDBC/example/mysql/src/Main.hs
@@ -16,9 +16,10 @@ import Database.HDBC.Record.Query   (runQuery)
 
 import Data.Int                     (Int64)
 import Data.Time                    (Day)
-import MySQLTestDataSource          (connect)
-import User                         (user)
-import qualified User as U
+
+import Example.DataSource           (connect)
+import Example.User                 (user)
+import qualified Example.User as U
 
 main :: IO ()
 main = handleSqlError' $ withConnectionIO connect $ \conn -> do

From e3a2f80bfd46f5edf9591ac26f262e0281c5a58d Mon Sep 17 00:00:00 2001
From: krdlab <krdlab@gmail.com>
Date: Fri, 21 Feb 2014 01:12:36 +0900
Subject: [PATCH 09/21] Update example

---
 relational-query-HDBC/example/mysql/setup.sql | 25 +++++++++++++++---
 .../example/mysql/src/Main.hs                 | 26 ++++++++++++++-----
 2 files changed, 41 insertions(+), 10 deletions(-)

diff --git a/relational-query-HDBC/example/mysql/setup.sql b/relational-query-HDBC/example/mysql/setup.sql
index a64ae7c7..df360c53 100644
--- a/relational-query-HDBC/example/mysql/setup.sql
+++ b/relational-query-HDBC/example/mysql/setup.sql
@@ -1,3 +1,22 @@
-CREATE DATABASE TEST DEFAULT CHARACTER SET UTF8;
-CREATE TABLE TEST.user (id BIGINT PRIMARY KEY, name VARCHAR(32) NOT NULL, memo TEXT, created_at DATE NOT NULL);
-INSERT INTO TEST.user (id, name, created_at) VALUES (1, 'krdlab', NOW());
+CREATE DATABASE IF NOT EXISTS TEST DEFAULT CHARACTER SET UTF8;
+
+CREATE TABLE TEST.user (
+      id            BIGINT PRIMARY KEY
+    , name          VARCHAR(32) NOT NULL
+    , email         VARCHAR(255) NOT NULL UNIQUE
+    , passwd_hath   VARCHAR(512) NOT NULL
+    , completed     TINYINT(1) NOT NULL DEFAULT 0
+    , deleted       TINYINT(1) NOT NULL DEFAULT 0
+    , frozen        TINYINT(1) NOT NULL DEFAULT 0
+    , memo          TEXT NOT NULL
+    , created_at    DATE NOT NULL
+    , updated_at    DATE NOT NULL
+);
+
+INSERT INTO TEST.user
+    (id, name, email, passwd_hath, completed, deleted, frozen, memo, created_at, updated_at)
+    VALUES
+    (1, 'krdlab', 'krdlab@gmail.com', 'dummy hashed password 1', 1, 0, 0, '', '2014-02-01', '2014-02-01'),
+    (2, 'foo',    'foo@example.com',  'dummy hashed password 2', 0, 0, 0, '', '2014-02-10', '2014-02-10'),
+    (3, 'bar',    'bar@example.com',  'dummy hashed password 3', 1, 0, 1, 'limit exceeded', '2014-02-11', '2014-02-20')
+    ;
diff --git a/relational-query-HDBC/example/mysql/src/Main.hs b/relational-query-HDBC/example/mysql/src/Main.hs
index bad22513..e64f281a 100644
--- a/relational-query-HDBC/example/mysql/src/Main.hs
+++ b/relational-query-HDBC/example/mysql/src/Main.hs
@@ -5,6 +5,7 @@ import Database.Relational.Query    ( query
                                     , relation
                                     , wheres
                                     , (.=.)
+                                    , (.>=.)
                                     , (!)
                                     , (><)
                                     , value
@@ -14,8 +15,7 @@ import Database.Relational.Query    ( query
 import Database.HDBC.Session        (withConnectionIO, handleSqlError')
 import Database.HDBC.Record.Query   (runQuery)
 
-import Data.Int                     (Int64)
-import Data.Time                    (Day)
+import Data.Time                    (Day, fromGregorian)
 
 import Example.DataSource           (connect)
 import Example.User                 (user)
@@ -23,13 +23,25 @@ import qualified Example.User as U
 
 main :: IO ()
 main = handleSqlError' $ withConnectionIO connect $ \conn -> do
-    r <- runQuery conn (relationalQuery test) ()
-    print r
+    printResults conn sample1
+    printResults conn sample2
     where
-        test :: Relation () (String, Day)
-        test = relation
+        printResults c q = runQuery c (relationalQuery q) () >>= print
+
+        sample1 :: Relation () (String, Day)
+        sample1 = relation
             [ u ! U.name' >< u ! U.createdAt'
             | u  <- query user
-            , () <- wheres $ u ! U.id' .=. value (1 :: Int64)
+            , () <- wheres $ u ! U.completed' .=. value 1
             ]
 
+        sample2 :: Relation () (String, Day)
+        sample2 = relation
+            [ u ! U.email' >< u ! U.createdAt'
+            | u  <- query user
+            , () <- wheres $ u ! U.completed' .=.  value 1
+            , () <- wheres $ u ! U.createdAt' .>=. value (day 2014 2 10)
+            ]
+
+        day = fromGregorian
+

From 62eb333acfbd8817cab9546b57fd7c74fdf71313 Mon Sep 17 00:00:00 2001
From: krdlab <krdlab@gmail.com>
Date: Fri, 21 Feb 2014 01:20:59 +0900
Subject: [PATCH 10/21] Fix 'No instance for (Convertible a SqlValue)'

---
 relational-schemas/src/Database/Relational/Schema/MySQL.hs | 6 +++---
 1 file changed, 3 insertions(+), 3 deletions(-)

diff --git a/relational-schemas/src/Database/Relational/Schema/MySQL.hs b/relational-schemas/src/Database/Relational/Schema/MySQL.hs
index e4102ea1..f706bcd9 100644
--- a/relational-schemas/src/Database/Relational/Schema/MySQL.hs
+++ b/relational-schemas/src/Database/Relational/Schema/MySQL.hs
@@ -8,7 +8,7 @@ module Database.Relational.Schema.MySQL
     )
     where
 
-import           Data.Int               (Int8, Int16, Int32, Int64)
+import           Data.Int               (Int32, Int64)
 import           Data.Char              (toLower, toUpper)
 import           Data.Map               (Map, fromList)
 import qualified Data.Map               as Map
@@ -54,8 +54,8 @@ mapFromSqlDefault = fromList
     , ("DATETIME",   [t| LocalTime |])
     , ("TIME",       [t| TimeOfDay |])
     , ("TIMESTAMP",  [t| POSIXTime |])
-    , ("TINYINT",    [t| Int8 |])
-    , ("SMALLINT",   [t| Int16 |])
+    , ("TINYINT",    [t| Int32 |])
+    , ("SMALLINT",   [t| Int32 |])
     , ("INT",        [t| Int32 |])
     , ("INTEGER",    [t| Int32 |])
     , ("BIGINT",     [t| Int64 |])

From 5e392d8c7c40ed45e9330018d5f7aa1084970661 Mon Sep 17 00:00:00 2001
From: krdlab <krdlab@gmail.com>
Date: Fri, 21 Feb 2014 18:19:11 +0900
Subject: [PATCH 11/21] Change sample queries in the example

---
 relational-query-HDBC/example/mysql/src/Main.hs | 12 ++++++++----
 1 file changed, 8 insertions(+), 4 deletions(-)

diff --git a/relational-query-HDBC/example/mysql/src/Main.hs b/relational-query-HDBC/example/mysql/src/Main.hs
index e64f281a..424cb011 100644
--- a/relational-query-HDBC/example/mysql/src/Main.hs
+++ b/relational-query-HDBC/example/mysql/src/Main.hs
@@ -28,18 +28,22 @@ main = handleSqlError' $ withConnectionIO connect $ \conn -> do
     where
         printResults c q = runQuery c (relationalQuery q) () >>= print
 
+        completed = relation
+            [ u
+            | u  <- query user
+            , () <- wheres $ u ! U.completed' .=. value 1
+            ]
+
         sample1 :: Relation () (String, Day)
         sample1 = relation
             [ u ! U.name' >< u ! U.createdAt'
-            | u  <- query user
-            , () <- wheres $ u ! U.completed' .=. value 1
+            | u  <- query completed
             ]
 
         sample2 :: Relation () (String, Day)
         sample2 = relation
             [ u ! U.email' >< u ! U.createdAt'
-            | u  <- query user
-            , () <- wheres $ u ! U.completed' .=.  value 1
+            | u  <- query completed
             , () <- wheres $ u ! U.createdAt' .>=. value (day 2014 2 10)
             ]
 

From 2beb05d7460ac3d8b008b560c0768656e4ac84ac Mon Sep 17 00:00:00 2001
From: krdlab <krdlab@gmail.com>
Date: Mon, 24 Feb 2014 00:26:16 +0900
Subject: [PATCH 12/21] Fix SQL error when trying to run compile-time code

---
 .../example/mysql/src/Example/DataSource.hs                  | 5 +++--
 1 file changed, 3 insertions(+), 2 deletions(-)

diff --git a/relational-query-HDBC/example/mysql/src/Example/DataSource.hs b/relational-query-HDBC/example/mysql/src/Example/DataSource.hs
index 7f34fab3..c9cdeb1e 100644
--- a/relational-query-HDBC/example/mysql/src/Example/DataSource.hs
+++ b/relational-query-HDBC/example/mysql/src/Example/DataSource.hs
@@ -6,7 +6,7 @@ module Example.DataSource
     )
     where
 
-import Language.Haskell.TH                  (Q, Dec, TypeQ)
+import Language.Haskell.TH                  (Q, Dec, TypeQ, runQ, runIO)
 import Language.Haskell.TH.Name.CamelCase   (ConName)
 
 import Database.HDBC.Query.TH               (defineTableFromDB)
@@ -16,6 +16,7 @@ import Database.HDBC.MySQL                  ( Connection
                                             , connectMySQL
                                             , MySQLConnectInfo(..)
                                             , defaultMySQLConnectInfo
+                                            , withRTSSignalsBlocked
                                             )
 
 {-# ANN module "HLint: ignore Eta reduce" #-}
@@ -32,5 +33,5 @@ connect :: IO Connection
 connect = connectMySQL config
 
 defineTable :: [(String, TypeQ)] -> String -> String -> [ConName] -> Q [Dec]
-defineTable tmap scm tbl derives =
+defineTable tmap scm tbl derives = runIO $ withRTSSignalsBlocked $ runQ $
     defineTableFromDB connect (driverMySQL { typeMap = tmap }) scm tbl derives

From 4d4cc6e12e52322311c7e1613d65e01eeab484ab Mon Sep 17 00:00:00 2001
From: krdlab <krdlab@gmail.com>
Date: Sat, 16 Aug 2014 11:18:14 +0900
Subject: [PATCH 13/21] Update README and example

---
 relational-query-HDBC/example/mysql/example.cabal     | 11 ++++-------
 .../example/mysql/src/Example/DataSource.hs           |  4 ++--
 2 files changed, 6 insertions(+), 9 deletions(-)

diff --git a/relational-query-HDBC/example/mysql/example.cabal b/relational-query-HDBC/example/mysql/example.cabal
index 1fd72ee6..c16f4729 100644
--- a/relational-query-HDBC/example/mysql/example.cabal
+++ b/relational-query-HDBC/example/mysql/example.cabal
@@ -1,6 +1,3 @@
--- Initial example.cabal generated by cabal init.  For further 
--- documentation, see http://haskell.org/cabal/users-guide/
-
 name:                example
 version:             0.1.0.0
 synopsis:            mysql driver example
@@ -16,6 +13,8 @@ build-type:          Simple
 cabal-version:       >=1.10
 
 executable example
+  hs-source-dirs:
+    src
   main-is:
     Main.hs
   -- other-modules:       
@@ -27,14 +26,12 @@ executable example
   build-depends:
       base >=4.6 && <4.7
     , template-haskell >=2.8 && <2.9
+    , HDBC-mysql >=0.6 && <0.7
+    , HDBC-session
     , names-th
     , relational-query
-    , HDBC-session
     , relational-query-HDBC
-    , HDBC-mysql >=0.6 && <0.7
     , relational-mysql
     , time
-  hs-source-dirs:
-    src
   default-language:
     Haskell2010
diff --git a/relational-query-HDBC/example/mysql/src/Example/DataSource.hs b/relational-query-HDBC/example/mysql/src/Example/DataSource.hs
index c9cdeb1e..9f883903 100644
--- a/relational-query-HDBC/example/mysql/src/Example/DataSource.hs
+++ b/relational-query-HDBC/example/mysql/src/Example/DataSource.hs
@@ -23,10 +23,10 @@ import Database.HDBC.MySQL                  ( Connection
 
 config :: MySQLConnectInfo
 config = defaultMySQLConnectInfo {
-              mysqlUser     = "***" -- TODO
+              mysqlUser     = "hrr-tester"
             , mysqlPassword = ""
             , mysqlDatabase = "TEST"
-            , mysqlHost     = "***" -- TODO: your mysql host
+            , mysqlHost     = "127.0.0.1"
             }
 
 connect :: IO Connection

From 78beb095f83cadc1e545e38e8107c90a5664c9d4 Mon Sep 17 00:00:00 2001
From: krdlab <krdlab@gmail.com>
Date: Sat, 16 Aug 2014 12:00:41 +0900
Subject: [PATCH 14/21] Fix typo

---
 relational-query-HDBC/example/mysql/setup.sql | 4 ++--
 1 file changed, 2 insertions(+), 2 deletions(-)

diff --git a/relational-query-HDBC/example/mysql/setup.sql b/relational-query-HDBC/example/mysql/setup.sql
index df360c53..0258cb6b 100644
--- a/relational-query-HDBC/example/mysql/setup.sql
+++ b/relational-query-HDBC/example/mysql/setup.sql
@@ -4,7 +4,7 @@ CREATE TABLE TEST.user (
       id            BIGINT PRIMARY KEY
     , name          VARCHAR(32) NOT NULL
     , email         VARCHAR(255) NOT NULL UNIQUE
-    , passwd_hath   VARCHAR(512) NOT NULL
+    , passwd_hash   VARCHAR(512) NOT NULL
     , completed     TINYINT(1) NOT NULL DEFAULT 0
     , deleted       TINYINT(1) NOT NULL DEFAULT 0
     , frozen        TINYINT(1) NOT NULL DEFAULT 0
@@ -14,7 +14,7 @@ CREATE TABLE TEST.user (
 );
 
 INSERT INTO TEST.user
-    (id, name, email, passwd_hath, completed, deleted, frozen, memo, created_at, updated_at)
+    (id, name, email, passwd_hash, completed, deleted, frozen, memo, created_at, updated_at)
     VALUES
     (1, 'krdlab', 'krdlab@gmail.com', 'dummy hashed password 1', 1, 0, 0, '', '2014-02-01', '2014-02-01'),
     (2, 'foo',    'foo@example.com',  'dummy hashed password 2', 0, 0, 0, '', '2014-02-10', '2014-02-10'),

From 93ab8a40cb7813d809c7ca8e57fb2ba6369e549f Mon Sep 17 00:00:00 2001
From: krdlab <krdlab@gmail.com>
Date: Sat, 16 Aug 2014 12:07:14 +0900
Subject: [PATCH 15/21] Modify example usage

---
 relational-query-HDBC/example/mysql/setup.sql | 3 +++
 1 file changed, 3 insertions(+)

diff --git a/relational-query-HDBC/example/mysql/setup.sql b/relational-query-HDBC/example/mysql/setup.sql
index 0258cb6b..16ddffd3 100644
--- a/relational-query-HDBC/example/mysql/setup.sql
+++ b/relational-query-HDBC/example/mysql/setup.sql
@@ -1,5 +1,6 @@
 CREATE DATABASE IF NOT EXISTS TEST DEFAULT CHARACTER SET UTF8;
 
+DROP TABLE IF EXISTS TEST.user;
 CREATE TABLE TEST.user (
       id            BIGINT PRIMARY KEY
     , name          VARCHAR(32) NOT NULL
@@ -20,3 +21,5 @@ INSERT INTO TEST.user
     (2, 'foo',    'foo@example.com',  'dummy hashed password 2', 0, 0, 0, '', '2014-02-10', '2014-02-10'),
     (3, 'bar',    'bar@example.com',  'dummy hashed password 3', 1, 0, 1, 'limit exceeded', '2014-02-11', '2014-02-20')
     ;
+
+GRANT ALL PRIVILEGES ON TEST.user TO 'hrr-tester'@'127.0.0.1';

From 0be1621fa4a1d43977dd4f535f10aa0c940e2671 Mon Sep 17 00:00:00 2001
From: krdlab <krdlab@gmail.com>
Date: Sat, 16 Aug 2014 13:56:03 +0900
Subject: [PATCH 16/21] Add very simple tests (close #3)

---
 relational-query-HDBC/test/mysql/DB/Source.hs | 28 +++++++++++
 relational-query-HDBC/test/mysql/Spec.hs      | 49 +++++++++++++++++++
 2 files changed, 77 insertions(+)
 create mode 100644 relational-query-HDBC/test/mysql/DB/Source.hs
 create mode 100644 relational-query-HDBC/test/mysql/Spec.hs

diff --git a/relational-query-HDBC/test/mysql/DB/Source.hs b/relational-query-HDBC/test/mysql/DB/Source.hs
new file mode 100644
index 00000000..919b4df3
--- /dev/null
+++ b/relational-query-HDBC/test/mysql/DB/Source.hs
@@ -0,0 +1,28 @@
+module DB.Source (connect, defineTable) where
+
+import Database.HDBC.MySQL                  ( MySQLConnectInfo(..), defaultMySQLConnectInfo
+                                            , Connection, connectMySQL
+                                            )
+import Database.HDBC.Query.TH               (defineTableFromDB)
+import Database.HDBC.Schema.Driver          (typeMap)
+import Database.HDBC.Schema.MySQL           (driverMySQL)
+import Language.Haskell.TH                  (TypeQ, Q, Dec)
+import Language.Haskell.TH.Name.CamelCase   (ConName)
+
+-- {-# ANN module "HLint: ignore Eta reduce" #-}
+
+config :: MySQLConnectInfo
+config = defaultMySQLConnectInfo
+    { mysqlUser     = "hrr-tester"
+    , mysqlPassword = ""
+    , mysqlDatabase = "TEST"
+    , mysqlHost     = "127.0.0.1"
+    }
+
+connect :: IO Connection
+connect = connectMySQL config
+
+defineTable :: [(String, TypeQ)] -> String -> String -> [ConName] -> Q [Dec]
+defineTable tmap =
+    defineTableFromDB connect (driverMySQL { typeMap = tmap })
+
diff --git a/relational-query-HDBC/test/mysql/Spec.hs b/relational-query-HDBC/test/mysql/Spec.hs
new file mode 100644
index 00000000..00b36e05
--- /dev/null
+++ b/relational-query-HDBC/test/mysql/Spec.hs
@@ -0,0 +1,49 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+
+import Test.Hspec
+
+import Prelude hiding (id)
+import Language.Haskell.TH          (runQ)
+
+import Database.HDBC.Session        (withConnectionIO)
+import Database.HDBC.Record.Query   (runQuery')
+import Database.Record.TH           (derivingShow)
+import Database.Relational.Query    ( query
+                                    , relation
+                                    , wheres
+                                    , (.=.)
+                                    , (!)
+                                    , value
+                                    , relationalQuery
+                                    )
+import qualified DB.Source as DB
+
+-- TODO: get and define
+$(DB.defineTable
+    []
+    "TEST" "user" [derivingShow])
+
+main :: IO ()
+main = hspec $ do
+    describe "basic tests" $
+        it "should generate data types" $ do
+            decs <- runQ $ DB.defineTable [] "TEST" "user" []
+            decs `shouldSatisfy` not . null
+
+    describe "run query" $
+        it "should get a record" $ do
+            let test1 = relation $ do
+                    u  <- query user
+                    wheres $ u ! id' .=. value 1
+                    return (u ! name')
+            rs <- runDB test1
+            rs `shouldSatisfy` not . null
+
+  where
+    runDB q =
+        withConnectionIO DB.connect $ \conn ->
+            runQuery' conn (relationalQuery q) ()
+

From 480756f3a2248dcf4de1fb973f5108045077bb93 Mon Sep 17 00:00:00 2001
From: krdlab <krdlab@gmail.com>
Date: Sat, 16 Aug 2014 15:13:46 +0900
Subject: [PATCH 17/21] Remove withRTSSignalsBlocked call on example (test
 MySQL 5.6.x)

---
 .../example/mysql/src/Example/DataSource.hs               | 8 ++------
 relational-query-HDBC/example/mysql/src/Main.hs           | 6 +++---
 2 files changed, 5 insertions(+), 9 deletions(-)

diff --git a/relational-query-HDBC/example/mysql/src/Example/DataSource.hs b/relational-query-HDBC/example/mysql/src/Example/DataSource.hs
index 9f883903..2d1f36ae 100644
--- a/relational-query-HDBC/example/mysql/src/Example/DataSource.hs
+++ b/relational-query-HDBC/example/mysql/src/Example/DataSource.hs
@@ -6,7 +6,7 @@ module Example.DataSource
     )
     where
 
-import Language.Haskell.TH                  (Q, Dec, TypeQ, runQ, runIO)
+import Language.Haskell.TH                  (Q, Dec, TypeQ)
 import Language.Haskell.TH.Name.CamelCase   (ConName)
 
 import Database.HDBC.Query.TH               (defineTableFromDB)
@@ -16,11 +16,8 @@ import Database.HDBC.MySQL                  ( Connection
                                             , connectMySQL
                                             , MySQLConnectInfo(..)
                                             , defaultMySQLConnectInfo
-                                            , withRTSSignalsBlocked
                                             )
 
-{-# ANN module "HLint: ignore Eta reduce" #-}
-
 config :: MySQLConnectInfo
 config = defaultMySQLConnectInfo {
               mysqlUser     = "hrr-tester"
@@ -33,5 +30,4 @@ connect :: IO Connection
 connect = connectMySQL config
 
 defineTable :: [(String, TypeQ)] -> String -> String -> [ConName] -> Q [Dec]
-defineTable tmap scm tbl derives = runIO $ withRTSSignalsBlocked $ runQ $
-    defineTableFromDB connect (driverMySQL { typeMap = tmap }) scm tbl derives
+defineTable tmap = defineTableFromDB connect (driverMySQL { typeMap = tmap })
diff --git a/relational-query-HDBC/example/mysql/src/Main.hs b/relational-query-HDBC/example/mysql/src/Main.hs
index 424cb011..7769660a 100644
--- a/relational-query-HDBC/example/mysql/src/Main.hs
+++ b/relational-query-HDBC/example/mysql/src/Main.hs
@@ -1,4 +1,4 @@
-{-# LANGUAGE MonadComprehensions   #-}
+{-# LANGUAGE MonadComprehensions #-}
 module Main where
 
 import Database.Relational.Query    ( query
@@ -13,7 +13,7 @@ import Database.Relational.Query    ( query
                                     , Relation
                                     )
 import Database.HDBC.Session        (withConnectionIO, handleSqlError')
-import Database.HDBC.Record.Query   (runQuery)
+import Database.HDBC.Record.Query   (runQuery')
 
 import Data.Time                    (Day, fromGregorian)
 
@@ -26,7 +26,7 @@ main = handleSqlError' $ withConnectionIO connect $ \conn -> do
     printResults conn sample1
     printResults conn sample2
     where
-        printResults c q = runQuery c (relationalQuery q) () >>= print
+        printResults c q = runQuery' c (relationalQuery q) () >>= print
 
         completed = relation
             [ u

From efba911d2049d5c3a0c8bc72e42d056e2a3e2909 Mon Sep 17 00:00:00 2001
From: krdlab <krdlab@gmail.com>
Date: Sun, 17 Aug 2014 06:42:54 +0900
Subject: [PATCH 18/21] Fix primaryKeyQuerySQL bug

---
 relational-query-HDBC/test/mysql/Spec.hs      | 15 ++++++++--
 relational-query-HDBC/test/mysql/setup.sql    | 30 +++++++++++++++++++
 .../src/Database/Relational/Schema/MySQL.hs   | 10 ++-----
 3 files changed, 46 insertions(+), 9 deletions(-)
 create mode 100644 relational-query-HDBC/test/mysql/setup.sql

diff --git a/relational-query-HDBC/test/mysql/Spec.hs b/relational-query-HDBC/test/mysql/Spec.hs
index 00b36e05..e1cadd29 100644
--- a/relational-query-HDBC/test/mysql/Spec.hs
+++ b/relational-query-HDBC/test/mysql/Spec.hs
@@ -19,6 +19,9 @@ import Database.Relational.Query    ( query
                                     , value
                                     , relationalQuery
                                     )
+import Database.HDBC.Schema.Driver  (getPrimaryKey)
+import Database.HDBC.Schema.MySQL   (driverMySQL)
+
 import qualified DB.Source as DB
 
 -- TODO: get and define
@@ -28,13 +31,21 @@ $(DB.defineTable
 
 main :: IO ()
 main = hspec $ do
+    describe "getPrimaryKey" $ do
+        it "returns one primary key" $ do
+            keys <- withConnectionIO DB.connect $ \c -> getPrimaryKey driverMySQL c "TEST" "test_pk1"
+            keys `shouldBe` ["a"]
+        it "returns two primary keys" $ do
+            keys <- withConnectionIO DB.connect $ \c -> getPrimaryKey driverMySQL c "TEST" "test_pk2"
+            keys `shouldBe` ["a", "b"]
+
     describe "basic tests" $
-        it "should generate data types" $ do
+        it "returns data types" $ do
             decs <- runQ $ DB.defineTable [] "TEST" "user" []
             decs `shouldSatisfy` not . null
 
     describe "run query" $
-        it "should get a record" $ do
+        it "returns some records" $ do
             let test1 = relation $ do
                     u  <- query user
                     wheres $ u ! id' .=. value 1
diff --git a/relational-query-HDBC/test/mysql/setup.sql b/relational-query-HDBC/test/mysql/setup.sql
new file mode 100644
index 00000000..3e80dc0b
--- /dev/null
+++ b/relational-query-HDBC/test/mysql/setup.sql
@@ -0,0 +1,30 @@
+CREATE DATABASE IF NOT EXISTS TEST DEFAULT CHARACTER SET UTF8;
+
+DROP TABLE IF EXISTS TEST.test_pk1;
+CREATE TABLE TEST.test_pk1 (a INT, b VARCHAR(32) NOT NULL, PRIMARY KEY (a));
+DROP TABLE IF EXISTS TEST.test_pk2;
+CREATE TABLE TEST.test_pk2 (a INT, b INT, c VARCHAR(32) NOT NULL, PRIMARY KEY (a, b));
+
+DROP TABLE IF EXISTS TEST.user;
+CREATE TABLE TEST.user (
+      id            BIGINT PRIMARY KEY
+    , name          VARCHAR(32) NOT NULL
+    , email         VARCHAR(255) NOT NULL UNIQUE
+    , passwd_hash   VARCHAR(512) NOT NULL
+    , completed     TINYINT(1) NOT NULL DEFAULT 0
+    , deleted       TINYINT(1) NOT NULL DEFAULT 0
+    , frozen        TINYINT(1) NOT NULL DEFAULT 0
+    , memo          TEXT NOT NULL
+    , created_at    DATE NOT NULL
+    , updated_at    DATE NOT NULL
+);
+
+INSERT INTO TEST.user
+    (id, name, email, passwd_hash, completed, deleted, frozen, memo, created_at, updated_at)
+    VALUES
+    (1, 'krdlab', 'krdlab@gmail.com', 'dummy hashed password 1', 1, 0, 0, '', '2014-02-01', '2014-02-01'),
+    (2, 'foo',    'foo@example.com',  'dummy hashed password 2', 0, 0, 0, '', '2014-02-10', '2014-02-10'),
+    (3, 'bar',    'bar@example.com',  'dummy hashed password 3', 1, 0, 1, 'limit exceeded', '2014-02-11', '2014-02-20')
+    ;
+
+GRANT ALL PRIVILEGES ON TEST.* TO 'hrr-tester'@'127.0.0.1';
diff --git a/relational-schemas/src/Database/Relational/Schema/MySQL.hs b/relational-schemas/src/Database/Relational/Schema/MySQL.hs
index f706bcd9..9a87564c 100644
--- a/relational-schemas/src/Database/Relational/Schema/MySQL.hs
+++ b/relational-schemas/src/Database/Relational/Schema/MySQL.hs
@@ -97,18 +97,14 @@ primaryKeyQuerySQL = relationalQuery primaryKeyRelation
         primaryKeyRelation = relation' $ do
             cons <- query tableConstraints
             key  <- query keyColumnUsage
-            col  <- query columns
 
-            wheres $ cons ! Tabconst.tableSchema'    .=. col ! Columns.tableSchema'
-            wheres $ cons ! Tabconst.tableName'      .=. col ! Columns.tableName'
-            wheres $ key  ! Keycoluse.columnName'    .=. col ! Columns.columnName'
+            wheres $ cons ! Tabconst.tableSchema'    .=. key ! Keycoluse.tableSchema'
+            wheres $ cons ! Tabconst.tableName'      .=. key ! Keycoluse.tableName'
             wheres $ cons ! Tabconst.constraintName' .=. key ! Keycoluse.constraintName'
 
-            wheres $ col  ! Columns.isNullable'      .=. value "NO"
-            wheres $ cons ! Tabconst.constraintType' .=. value "PRIMARY KEY"
-
             (schemaP, ()) <- placeholder (\ph -> wheres $ cons ! Tabconst.tableSchema' .=. ph)
             (nameP  , ()) <- placeholder (\ph -> wheres $ cons ! Tabconst.tableName'   .=. ph)
+            wheres $ cons ! Tabconst.constraintType' .=. value "PRIMARY KEY"
 
             asc $ key ! Keycoluse.ordinalPosition'
 

From bb83384388043e7a8fef4321b88043fbe1085de5 Mon Sep 17 00:00:00 2001
From: krdlab <krdlab@gmail.com>
Date: Sun, 17 Aug 2014 08:30:46 +0900
Subject: [PATCH 19/21] Add getFieldsWithMap tests

---
 relational-query-HDBC/test/mysql/Spec.hs   | 17 ++++++++++++++---
 relational-query-HDBC/test/mysql/setup.sql |  3 +++
 2 files changed, 17 insertions(+), 3 deletions(-)

diff --git a/relational-query-HDBC/test/mysql/Spec.hs b/relational-query-HDBC/test/mysql/Spec.hs
index e1cadd29..981b8871 100644
--- a/relational-query-HDBC/test/mysql/Spec.hs
+++ b/relational-query-HDBC/test/mysql/Spec.hs
@@ -5,9 +5,9 @@
 
 import Test.Hspec
 
-import Prelude hiding (id)
 import Language.Haskell.TH          (runQ)
-
+import Data.Int                     (Int32)
+import Data.Time                    (LocalTime)
 import Database.HDBC.Session        (withConnectionIO)
 import Database.HDBC.Record.Query   (runQuery')
 import Database.Record.TH           (derivingShow)
@@ -19,9 +19,10 @@ import Database.Relational.Query    ( query
                                     , value
                                     , relationalQuery
                                     )
-import Database.HDBC.Schema.Driver  (getPrimaryKey)
+import Database.HDBC.Schema.Driver  (getPrimaryKey, getFieldsWithMap)
 import Database.HDBC.Schema.MySQL   (driverMySQL)
 
+import Prelude hiding (id)
 import qualified DB.Source as DB
 
 -- TODO: get and define
@@ -39,6 +40,16 @@ main = hspec $ do
             keys <- withConnectionIO DB.connect $ \c -> getPrimaryKey driverMySQL c "TEST" "test_pk2"
             keys `shouldBe` ["a", "b"]
 
+    describe "getFieldsWithMap" $ do
+        it "returns 'NOT NULL' column positions" $ do
+            ( _, ps) <- withConnectionIO DB.connect $ \c -> getFieldsWithMap driverMySQL [] c "TEST" "test_nn1"
+            ps `shouldBe` [0, 2, 4]
+        it "returns column types" $ do
+            (tm,  _) <- withConnectionIO DB.connect $ \c -> getFieldsWithMap driverMySQL [] c "TEST" "test_nn1"
+            types  <- mapM (runQ . snd) tm
+            expect <- mapM runQ [[t|Int32|], [t|Maybe Int32|], [t|String|], [t|Maybe String|], [t|LocalTime|]]
+            types  `shouldBe` expect
+
     describe "basic tests" $
         it "returns data types" $ do
             decs <- runQ $ DB.defineTable [] "TEST" "user" []
diff --git a/relational-query-HDBC/test/mysql/setup.sql b/relational-query-HDBC/test/mysql/setup.sql
index 3e80dc0b..167c991b 100644
--- a/relational-query-HDBC/test/mysql/setup.sql
+++ b/relational-query-HDBC/test/mysql/setup.sql
@@ -5,6 +5,9 @@ CREATE TABLE TEST.test_pk1 (a INT, b VARCHAR(32) NOT NULL, PRIMARY KEY (a));
 DROP TABLE IF EXISTS TEST.test_pk2;
 CREATE TABLE TEST.test_pk2 (a INT, b INT, c VARCHAR(32) NOT NULL, PRIMARY KEY (a, b));
 
+DROP TABLE IF EXISTS TEST.test_nn1;
+CREATE TABLE TEST.test_nn1 (a INT, b INT, c VARCHAR(32) NOT NULL, d TEXT, e DATETIME NOT NULL, PRIMARY KEY (a));
+
 DROP TABLE IF EXISTS TEST.user;
 CREATE TABLE TEST.user (
       id            BIGINT PRIMARY KEY

From 672a803d831b0f9c964a685a7cfc69cc06e3f05b Mon Sep 17 00:00:00 2001
From: krdlab <krdlab@gmail.com>
Date: Wed, 3 Dec 2014 00:55:29 +0900
Subject: [PATCH 20/21] Change upper-versions of some packages

---
 relational-query-HDBC/example/mysql/example.cabal | 4 ++--
 1 file changed, 2 insertions(+), 2 deletions(-)

diff --git a/relational-query-HDBC/example/mysql/example.cabal b/relational-query-HDBC/example/mysql/example.cabal
index c16f4729..0505f064 100644
--- a/relational-query-HDBC/example/mysql/example.cabal
+++ b/relational-query-HDBC/example/mysql/example.cabal
@@ -24,8 +24,8 @@ executable example
     , MultiParamTypeClasses
     , MonadComprehensions
   build-depends:
-      base >=4.6 && <4.7
-    , template-haskell >=2.8 && <2.9
+      base >=4.6 && <5
+    , template-haskell >=2.8
     , HDBC-mysql >=0.6 && <0.7
     , HDBC-session
     , names-th

From 00a2c75d1a4ca352a0b4734f9f8efddac3d662e6 Mon Sep 17 00:00:00 2001
From: krdlab <krdlab@gmail.com>
Date: Wed, 3 Dec 2014 09:26:28 +0900
Subject: [PATCH 21/21] Add aggregate samples

---
 .../example/mysql/example.cabal               |  1 +
 .../example/mysql/src/Main.hs                 | 38 +++++++++++++++++++
 2 files changed, 39 insertions(+)

diff --git a/relational-query-HDBC/example/mysql/example.cabal b/relational-query-HDBC/example/mysql/example.cabal
index 0505f064..b7814a2d 100644
--- a/relational-query-HDBC/example/mysql/example.cabal
+++ b/relational-query-HDBC/example/mysql/example.cabal
@@ -26,6 +26,7 @@ executable example
   build-depends:
       base >=4.6 && <5
     , template-haskell >=2.8
+    , HDBC >=2.3
     , HDBC-mysql >=0.6 && <0.7
     , HDBC-session
     , names-th
diff --git a/relational-query-HDBC/example/mysql/src/Main.hs b/relational-query-HDBC/example/mysql/src/Main.hs
index 7769660a..8a31df9f 100644
--- a/relational-query-HDBC/example/mysql/src/Main.hs
+++ b/relational-query-HDBC/example/mysql/src/Main.hs
@@ -3,19 +3,28 @@ module Main where
 
 import Database.Relational.Query    ( query
                                     , relation
+                                    , aggregateRelation
                                     , wheres
                                     , (.=.)
                                     , (.>=.)
                                     , (!)
                                     , (><)
                                     , value
+                                    , count
+                                    , min'
+                                    , groupBy
+                                    , desc
+                                    , id'
                                     , relationalQuery
                                     , Relation
                                     )
 import Database.HDBC.Session        (withConnectionIO, handleSqlError')
 import Database.HDBC.Record.Query   (runQuery')
+import Database.HDBC                (runRaw, quickQuery', fromSql)
 
 import Data.Time                    (Day, fromGregorian)
+import Data.List                    (isInfixOf)
+import Data.Int                     (Int32, Int64)
 
 import Example.DataSource           (connect)
 import Example.User                 (user)
@@ -23,8 +32,11 @@ import qualified Example.User as U
 
 main :: IO ()
 main = handleSqlError' $ withConnectionIO connect $ \conn -> do
+    setSqlMode conn
     printResults conn sample1
     printResults conn sample2
+    printResults conn sample3
+    printResults conn sample4
     where
         printResults c q = runQuery' c (relationalQuery q) () >>= print
 
@@ -49,3 +61,29 @@ main = handleSqlError' $ withConnectionIO connect $ \conn -> do
 
         day = fromGregorian
 
+        sample3 :: Relation () (Int32, Int64)
+        sample3 = aggregateRelation
+            [ c >< count (u ! U.id')
+            | u  <- query user
+            , c  <- groupBy $ u ! U.completed'
+            , () <- desc $ c ! id'
+            ]
+
+        sample4 :: Relation () (Maybe Day)
+        sample4 = aggregateRelation
+            [ min' (u ! U.createdAt')
+            | u  <- query user
+            ]
+
+        setSqlMode conn = do
+            mode <- quickQuery' conn "SELECT @@SESSION.sql_mode" []
+            newmode <- case mode of
+                [[sqlval]] ->
+                    let val = fromSql sqlval in
+                        if "IGNORE_SPACE" `isInfixOf` val
+                            then return val
+                            else return $ val ++ ",IGNORE_SPACE"
+                _          ->
+                    error "failed to get 'sql_mode'"
+            runRaw conn $ "SET SESSION sql_mode = '" ++ newmode ++ "'"
+