From bbe66c8dc354f93435f43e51eb69868c3877d707 Mon Sep 17 00:00:00 2001
From: Kei Hibino <ex8k.hibino@gmail.com>
Date: Mon, 13 May 2013 16:56:14 +0900
Subject: [PATCH] Add a module which generates SQL strings to use sql-words.

---
 .../src/Database/Relational/Query.hs          |  5 ++-
 .../src/Database/Relational/Query/SQL.hs      | 34 +++++++++++++++++++
 .../src/Database/Relational/Query/Type.hs     | 13 +++++--
 3 files changed, 49 insertions(+), 3 deletions(-)
 create mode 100644 relational-join/src/Database/Relational/Query/SQL.hs

diff --git a/relational-join/src/Database/Relational/Query.hs b/relational-join/src/Database/Relational/Query.hs
index b964dcf6..d6c5b552 100644
--- a/relational-join/src/Database/Relational/Query.hs
+++ b/relational-join/src/Database/Relational/Query.hs
@@ -27,5 +27,8 @@ import Database.Relational.Query.Projection
    value, valueTrue, valueFalse, valueNull, placeholder)
 import Database.Relational.Query.Relation (Relation, PrimeRelation, toSQL, fromTable)
 import Database.Relational.Query.Join
-import Database.Relational.Query.Type (Query, untypeQuery, fromRelation)
+import Database.Relational.Query.Type
+  (Query, untypeQuery, fromRelation,
+   Update, untypeUpdate, typedPrimaryUpdate,
+   Insert, untypeInsert, typedInsert)
 import Database.Relational.Query.Derives
diff --git a/relational-join/src/Database/Relational/Query/SQL.hs b/relational-join/src/Database/Relational/Query/SQL.hs
new file mode 100644
index 00000000..88e5e88f
--- /dev/null
+++ b/relational-join/src/Database/Relational/Query/SQL.hs
@@ -0,0 +1,34 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module Database.Relational.Query.SQL (
+  primaryUpdateSQL', primaryUpdateSQL,
+
+  insertSQL', insertSQL
+  ) where
+
+import Language.SQL.Keyword (Keyword(..), (.=.))
+import qualified Language.SQL.Keyword as SQL
+import Database.Relational.Query.Table (Table, name, columns)
+
+
+primaryUpdateSQL' :: String -> [String] -> String -> String
+primaryUpdateSQL' table cols pkey =
+  SQL.unwordsSQL
+  $ [UPDATE, SQL.word table, SET, assignments `SQL.sepBy` ", ",
+     WHERE, SQL.word pkey, "= ?"]
+  where assignments = map (\f -> SQL.word f .=. "?") . filter (/= pkey) $ cols
+
+primaryUpdateSQL :: Table r -> String -> String
+primaryUpdateSQL tbl = primaryUpdateSQL' (name tbl) (columns tbl)
+
+
+insertSQL' :: String -> [String] -> String
+insertSQL' table cols =
+  SQL.unwordsSQL
+  $ [INSERT, INTO, SQL.word table, cols' `SQL.parenSepBy` ", ",
+     VALUES, pfs `SQL.parenSepBy` ", "]
+  where cols' = map SQL.word cols
+        pfs      = replicate (length cols) "?"
+
+insertSQL :: Table r -> String
+insertSQL tbl = insertSQL' (name tbl) (columns tbl)
diff --git a/relational-join/src/Database/Relational/Query/Type.hs b/relational-join/src/Database/Relational/Query/Type.hs
index db2a46f1..10327e2e 100644
--- a/relational-join/src/Database/Relational/Query/Type.hs
+++ b/relational-join/src/Database/Relational/Query/Type.hs
@@ -2,12 +2,15 @@
 module Database.Relational.Query.Type (
   Query (untypeQuery), unsafeTypedQuery, fromRelation,
 
-  Update(untypeUpdate), unsafeTypedUpdate,
-  Insert(untypeInsert), unsafeTypedInsert
+  Update(untypeUpdate), unsafeTypedUpdate, typedPrimaryUpdate,
+  Insert(untypeInsert), unsafeTypedInsert, typedInsert
   ) where
 
 import Database.Relational.Query.Relation (PrimeRelation)
 import qualified Database.Relational.Query.Relation as Relation
+import Database.Relational.Query.Table (Table)
+import Database.Relational.Query.SQL (primaryUpdateSQL, insertSQL)
+
 
 newtype Query p a = Query { untypeQuery :: String }
 
@@ -26,7 +29,13 @@ newtype Update p a = Update { untypeUpdate :: String }
 unsafeTypedUpdate :: String -> Update p a
 unsafeTypedUpdate =  Update
 
+typedPrimaryUpdate :: Table r -> String -> Update p r
+typedPrimaryUpdate tbl =  unsafeTypedUpdate . primaryUpdateSQL tbl
+
 newtype Insert a   = Insert { untypeInsert :: String }
 
 unsafeTypedInsert :: String -> Insert a
 unsafeTypedInsert =  Insert
+
+typedInsert :: Table r -> Insert r
+typedInsert =  unsafeTypedInsert . insertSQL