From b745f31f7baa3017afa7e8a28cbde8f80d21e7b9 Mon Sep 17 00:00:00 2001
From: Kei Hibino <ex8k.hibino@gmail.com>
Date: Wed, 8 May 2013 16:37:38 +0900
Subject: [PATCH] Add TH functions to define Table type.

---
 .../src/Database/Relational/Query/TH.hs       | 65 +++++++++++++++----
 1 file changed, 52 insertions(+), 13 deletions(-)

diff --git a/relational-join/src/Database/Relational/Query/TH.hs b/relational-join/src/Database/Relational/Query/TH.hs
index 2c845471..39b5ea4b 100644
--- a/relational-join/src/Database/Relational/Query/TH.hs
+++ b/relational-join/src/Database/Relational/Query/TH.hs
@@ -1,30 +1,69 @@
 {-# LANGUAGE TemplateHaskell #-}
 
 module Database.Relational.Query.TH (
-  VarName, inlineQuery
+  defineTable, defineTableDefault,
+  defineRecordAndTableDefault,
+
+  inlineQuery
   ) where
 
+import Data.Char (toUpper, toLower)
+
 import Language.Haskell.TH
   (Q, reify, Info (VarI), TypeQ, Type (AppT, ConT),
-   Dec, sigD, valD, varP, normalB, stringE, listE)
-import Language.Haskell.TH.Name.CamelCase (VarName, varName)
+   Dec, sigD, valD, varP, normalB, stringE, listE, varE)
+import Language.Haskell.TH.Name.CamelCase
+  (VarName, varName, ConName, varNameWithPrefix, varCamelcaseName)
 import Language.Haskell.TH.Name.Extra (compileError, simpleValD)
 
+import Database.Record.TH (recordTypeDefault, defineRecordDefault)
+
 import Database.Relational.Query.Table (Table)
 import qualified Database.Relational.Query.Table as Table
-import Database.Relational.Query.Relation (Relation, toSQL)
+import Database.Relational.Query.Relation (Relation, toSQL, fromTable)
 import Database.Relational.Query.Type (Query, unsafeTypedQuery)
 
-defineTableInfo :: VarName
-                -> TypeQ
-                -> String
-                -> [String]
-                -> Int
-                -> Q [Dec]
-defineTableInfo tableVar' recordType table fields width = do
+
+tableSQL :: String -> String -> String
+tableSQL schema table = map toUpper schema ++ '.' : map toLower table
+
+defineTable :: VarName  -- ^ Table declaration variable name
+            -> VarName  -- ^ Relation declaration variable name
+            -> TypeQ    -- ^ Record type
+            -> String   -- ^ Table name in SQL ex. FOO_SCHEMA.table0
+            -> [String] -- ^ Column names
+            -> Q [Dec]  -- ^ Table and Relation declaration
+defineTable tableVar' relVar' recordType table columns = do
   let tableVar = varName tableVar'
-  simpleValD tableVar [t| Table $(recordType) |]
-    [| Table.table $(stringE table) $(listE $ map stringE fields) |]
+  tableV <- simpleValD tableVar [t| Table $(recordType) |]
+            [| Table.table $(stringE table) $(listE $ map stringE columns) |]
+  let relVar   = varName relVar'
+  relV   <- simpleValD relVar   [t| Relation $(recordType) |]
+            [| fromTable $(varE tableVar) |]
+  return $ tableV ++ relV
+
+defineTableDefault :: String   -- ^ Schema name
+                   -> String   -- ^ Table name
+                   -> [String] -- ^ Column names
+                   -> Q [Dec]  -- ^ Result declarations
+defineTableDefault schema table columns =
+  defineTable
+  (table `varNameWithPrefix` "tableOf")
+  (varCamelcaseName table)
+  (recordTypeDefault table)
+  (tableSQL schema table)
+  columns
+
+defineRecordAndTableDefault :: TypeQ             -- ^ SQL value type
+                            -> String            -- ^ Schema name
+                            -> String            -- ^ Table name
+                            -> [(String, TypeQ)] -- ^ Column names and types
+                            -> [ConName]         -- ^ Record derivings
+                            -> Q [Dec]           -- ^ Result declarations
+defineRecordAndTableDefault sqlValueType schema table columns drives = do
+  recDs   <- defineRecordDefault sqlValueType table columns drives
+  tableDs <- defineTableDefault schema table (map fst columns)
+  return $ recDs ++ tableDs
 
 inlineQuery :: VarName -> Relation r -> VarName -> TypeQ -> Q [Dec]
 inlineQuery relVar' rel qVar' paramType =  do