From 642733712a92e7f178e201120c27f8601cba0520 Mon Sep 17 00:00:00 2001
From: Kei Hibino <ex8k.hibino@gmail.com>
Date: Thu, 16 May 2013 01:59:54 +0900
Subject: [PATCH] Add Projectable overloadings and defines binary operators on
 Projectables.

---
 relational-join/relational-join.cabal         |   1 +
 .../src/Database/Relational/Query/Derives.hs  |   3 +-
 .../src/Database/Relational/Query/Expr.hs     |  31 +---
 .../Database/Relational/Query/Expr/Unsafe.hs  |   7 +-
 .../src/Database/Relational/Query/Join.hs     |   8 +-
 .../src/Database/Relational/Query/Product.hs  |   4 +-
 .../Database/Relational/Query/Projectable.hs  | 151 ++++++++++++++++++
 .../Database/Relational/Query/Projection.hs   |  62 +------
 8 files changed, 172 insertions(+), 95 deletions(-)
 create mode 100644 relational-join/src/Database/Relational/Query/Projectable.hs

diff --git a/relational-join/relational-join.cabal b/relational-join/relational-join.cabal
index b89066a6..ea81a6f8 100644
--- a/relational-join/relational-join.cabal
+++ b/relational-join/relational-join.cabal
@@ -24,6 +24,7 @@ library
                        Database.Relational.Query.Pi.Unsafe
                        Database.Relational.Query.Constraint
                        Database.Relational.Query.Projection
+                       Database.Relational.Query.Projectable
                        Database.Relational.Query.Join
                        Database.Relational.Query.Expr
                        Database.Relational.Query.Expr.Unsafe
diff --git a/relational-join/src/Database/Relational/Query/Derives.hs b/relational-join/src/Database/Relational/Query/Derives.hs
index 9e61defa..500c57d1 100644
--- a/relational-join/src/Database/Relational/Query/Derives.hs
+++ b/relational-join/src/Database/Relational/Query/Derives.hs
@@ -13,8 +13,7 @@ import Database.Record (PersistableWidth)
 import Database.Relational.Query.Table (Table)
 import qualified Database.Relational.Query.Table as Table
 import Database.Relational.Query.Relation (Relation, PrimeRelation)
-import Database.Relational.Query.Expr ((.=.))
-import Database.Relational.Query.Projection (placeholder)
+import Database.Relational.Query.Projectable (placeholder, (.=.))
 import Database.Relational.Query.Join (relation, inner, wheres, (!))
 import Database.Relational.Query.Constraint
    (Key, Primary, Unique, projectionKey, uniqueKey,
diff --git a/relational-join/src/Database/Relational/Query/Expr.hs b/relational-join/src/Database/Relational/Query/Expr.hs
index fe5279c4..3135deff 100644
--- a/relational-join/src/Database/Relational/Query/Expr.hs
+++ b/relational-join/src/Database/Relational/Query/Expr.hs
@@ -7,9 +7,7 @@ module Database.Relational.Query.Expr (
 
   valueExpr,
 
-  just, unsafeFromJust,
-
-  (.=.), (.<>.), (.>.), (.<.), and, or
+  just, unsafeFromJust
   ) where
 
 import Prelude hiding (and, or)
@@ -19,9 +17,7 @@ import qualified Data.ByteString.Char8 as BS
 import Data.Text (Text)
 import qualified Data.Text as T
 
-import qualified Language.SQL.Keyword as SQL
-
-import Database.Relational.Query.Expr.Unsafe (Expr(Expr, showExpr), compareBinOp)
+import Database.Relational.Query.Expr.Unsafe (Expr(Expr, showExpr))
 
 
 intExprSQL :: (Show a, Integral a) => a -> String
@@ -76,26 +72,3 @@ just =  Expr . showExpr
 
 unsafeFromJust :: Expr (Maybe ft) -> Expr ft
 unsafeFromJust =  Expr . showExpr
-
-
-(.=.) :: Expr ft -> Expr ft -> Expr Bool
-(.=.) =  compareBinOp (SQL..=.)
-
-(.<>.) :: Expr ft -> Expr ft -> Expr Bool
-(.<>.) =  compareBinOp (SQL..<>.)
-
-(.>.) :: Expr ft -> Expr ft -> Expr Bool
-(.>.) =  compareBinOp (SQL.defineBinOp (SQL.word ">"))
-
-(.<.) :: Expr ft -> Expr ft -> Expr Bool
-(.<.) =  compareBinOp (SQL.defineBinOp (SQL.word "<"))
-
-and :: Expr Bool ->  Expr Bool ->  Expr Bool
-and =  compareBinOp SQL.and
-
-or :: Expr Bool ->  Expr Bool ->  Expr Bool
-or =  compareBinOp SQL.or
-
-infixr 4 .=., .<>.
-infixr 3 `and`
-infixr 2 `or`
diff --git a/relational-join/src/Database/Relational/Query/Expr/Unsafe.hs b/relational-join/src/Database/Relational/Query/Expr/Unsafe.hs
index 109dd5cb..4c318d72 100644
--- a/relational-join/src/Database/Relational/Query/Expr/Unsafe.hs
+++ b/relational-join/src/Database/Relational/Query/Expr/Unsafe.hs
@@ -2,7 +2,7 @@
 module Database.Relational.Query.Expr.Unsafe (
   Expr(Expr, showExpr),
 
-  compareBinOp, binOp
+  compareBinOp, numBinOp, binOp
   ) where
 
 import qualified Language.SQL.Keyword as SQL
@@ -24,3 +24,8 @@ binOp op a b = Expr . paren . SQL.wordShow
 compareBinOp :: (SQL.Keyword -> SQL.Keyword -> SQL.Keyword)
              -> Expr ft -> Expr ft -> Expr Bool
 compareBinOp =  binOp
+
+numBinOp :: Num a
+         => (SQL.Keyword -> SQL.Keyword -> SQL.Keyword)
+         -> Expr a -> Expr a -> Expr a
+numBinOp =  binOp
diff --git a/relational-join/src/Database/Relational/Query/Join.hs b/relational-join/src/Database/Relational/Query/Join.hs
index 0f2d33e3..a09b7551 100644
--- a/relational-join/src/Database/Relational/Query/Join.hs
+++ b/relational-join/src/Database/Relational/Query/Join.hs
@@ -30,8 +30,10 @@ import Database.Relational.Query.Product
   (QueryProduct, JoinAttr(Inner, Outer), growProduct, restrictProduct)
 import qualified Database.Relational.Query.Product as Product
 
-import Database.Relational.Query.Projection (Projection, Projectable(project))
+import Database.Relational.Query.Projection (Projection)
 import qualified Database.Relational.Query.Projection as Projection
+import Database.Relational.Query.Projectable (Projectable(project))
+import qualified Database.Relational.Query.Projectable as Projectable
 
 import Database.Relational.Query.Pi (Pi)
 
@@ -59,7 +61,7 @@ updateRestriction' :: Expr Bool -> Context -> Context
 updateRestriction' e1 ctx =
   ctx { restriction = Just . uf . restriction $ ctx }
   where uf  Nothing = e1
-        uf (Just e0) = e0 `Expr.and` e1
+        uf (Just e0) = e0 `Projectable.and` e1
 
 updateOrderBy' :: Order -> Expr t -> Context -> Context
 updateOrderBy' order e ctx =
@@ -123,7 +125,7 @@ record :: Qualified (Relation r) -> Projection r
 record =  snd . record'
 
 expr :: Projection ft -> Expr ft
-expr =  Projection.toExpr
+expr =  project
 
 compose :: Projection a -> Projection b -> Projection (c a b)
 compose =  Projection.compose
diff --git a/relational-join/src/Database/Relational/Query/Product.hs b/relational-join/src/Database/Relational/Query/Product.hs
index 54b1ba28..7aed4a3b 100644
--- a/relational-join/src/Database/Relational/Query/Product.hs
+++ b/relational-join/src/Database/Relational/Query/Product.hs
@@ -7,8 +7,8 @@ module Database.Relational.Query.Product (
   ) where
 
 import Prelude hiding (and)
-import Database.Relational.Query.Expr (Expr, showExpr, and)
-import Database.Relational.Query.Projection (valueTrue)
+import Database.Relational.Query.Expr (Expr, showExpr)
+import Database.Relational.Query.Projectable (valueTrue, and)
 import Database.Relational.Query.AliasId (Qualified)
 import Database.Relational.Query.Sub (SubQuery)
 import qualified Database.Relational.Query.Sub as SubQuery
diff --git a/relational-join/src/Database/Relational/Query/Projectable.hs b/relational-join/src/Database/Relational/Query/Projectable.hs
new file mode 100644
index 00000000..8ee56e61
--- /dev/null
+++ b/relational-join/src/Database/Relational/Query/Projectable.hs
@@ -0,0 +1,151 @@
+module Database.Relational.Query.Projectable (
+  Projectable (project),
+
+  value,
+
+  valueTrue, valueFalse,
+
+  SqlProjectable (unsafeSqlValue),
+  valueNull, placeholder,
+
+  ProjectableSqlTerm (unsafeSqlTerm),
+  unsafeBinOp,
+
+  (.=.), (.<>.), (.>.), (.<.), and, or,
+
+  (.+.), (.-.), (./.), (.*.)
+  ) where
+
+import Prelude hiding (and, or)
+
+import Data.List (intercalate)
+
+import qualified Language.SQL.Keyword as SQL
+
+import Database.Relational.Query.Expr (Expr, ShowConstantSQL (showConstantSQL))
+import qualified Database.Relational.Query.Expr.Unsafe as UnsafeExpr
+
+import Database.Relational.Query.Projection (Projection, columns, unsafeFromColumns)
+
+
+sqlString :: Projection r -> String
+sqlString =  d . columns  where
+  d ([])  = error $ "Projection: no columns."
+  d ([c]) = c
+  d (cs) = '(' : intercalate ", " cs ++ [')']
+
+toExpr :: Projection r -> Expr r
+toExpr =  UnsafeExpr.Expr . sqlString  where
+
+class Projectable p where
+  project :: Projection a -> p a
+
+instance Projectable Projection where
+  project = id
+
+instance Projectable Expr where
+  project = toExpr
+
+unsafeSqlProjection :: String -> Projection t
+unsafeSqlProjection =  unsafeFromColumns . (:[])
+
+
+class SqlProjectable p where
+  unsafeSqlValue :: String -> p t
+
+instance SqlProjectable Projection where
+  unsafeSqlValue = unsafeSqlProjection
+
+instance SqlProjectable Expr where
+  unsafeSqlValue = UnsafeExpr.Expr
+
+valueNull :: SqlProjectable p => p (Maybe a)
+valueNull =  unsafeSqlValue "NULL"
+
+placeholder :: SqlProjectable p => p t
+placeholder =  unsafeSqlValue "?"
+
+value :: (ShowConstantSQL t, SqlProjectable p) => t -> p t
+value =  unsafeSqlValue . showConstantSQL
+
+valueTrue :: SqlProjectable p => p Bool
+valueTrue =  value True
+
+valueFalse :: SqlProjectable p => p Bool
+valueFalse =  value False
+
+
+class ProjectableSqlTerm p where
+  unsafeSqlTerm :: p a -> String
+
+instance ProjectableSqlTerm Projection where
+  unsafeSqlTerm = sqlString
+
+instance ProjectableSqlTerm Expr where
+  unsafeSqlTerm = UnsafeExpr.showExpr
+
+
+unsafeBinOp :: (SqlProjectable p, ProjectableSqlTerm p)
+            => (SQL.Keyword -> SQL.Keyword -> SQL.Keyword)
+            -> p a -> p a -> p b
+unsafeBinOp op a b = unsafeSqlValue . paren . SQL.wordShow
+                     $ op (wordTerm a) (wordTerm b)
+  where wordTerm = SQL.word . unsafeSqlTerm
+        paren = ('(' :) . (++[')'])
+
+compareBinOp :: (SqlProjectable p, ProjectableSqlTerm p)
+             => (SQL.Keyword -> SQL.Keyword -> SQL.Keyword)
+             -> p a -> p a -> p Bool
+compareBinOp =  unsafeBinOp
+
+numBinOp :: (SqlProjectable p, ProjectableSqlTerm p, Num a)
+         => (SQL.Keyword -> SQL.Keyword -> SQL.Keyword)
+         -> p a -> p a -> p a
+numBinOp =  unsafeBinOp
+
+
+(.=.) :: (SqlProjectable p, ProjectableSqlTerm p)
+      => p ft -> p ft -> p Bool
+(.=.) =  compareBinOp (SQL..=.)
+
+(.<>.) :: (SqlProjectable p, ProjectableSqlTerm p)
+       => p ft -> p ft -> p Bool
+(.<>.) =  compareBinOp (SQL..<>.)
+
+compareBinOp' :: (SqlProjectable p, ProjectableSqlTerm p)
+              => String -> p ft -> p ft -> p Bool
+compareBinOp' =  compareBinOp . SQL.defineBinOp . SQL.word
+
+(.>.) :: (SqlProjectable p, ProjectableSqlTerm p)
+      => p ft -> p ft -> p Bool
+(.>.) =  compareBinOp' ">"
+
+(.<.) :: (SqlProjectable p, ProjectableSqlTerm p)
+      => p ft -> p ft -> p Bool
+(.<.) =  compareBinOp' "<"
+
+and :: (SqlProjectable p, ProjectableSqlTerm p)
+    => p Bool ->  p Bool ->  p Bool
+and =  compareBinOp SQL.and
+
+or :: (SqlProjectable p, ProjectableSqlTerm p)
+   => p Bool ->  p Bool ->  p Bool
+or =  compareBinOp SQL.or
+
+numBinOp' :: (SqlProjectable p, ProjectableSqlTerm p, Num a)
+          => String -> p a -> p a -> p a
+numBinOp' = numBinOp . SQL.defineBinOp . SQL.word
+
+(.+.) =  numBinOp' "+"
+(.-.) =  numBinOp' "-"
+(./.) =  numBinOp' "/"
+(.*.) =  numBinOp' "*"
+
+(.+.), (.-.), (./.), (.*.) :: (SqlProjectable p, ProjectableSqlTerm p, Num a)
+                           => p a -> p a -> p a
+
+infixl 7 .*., ./.
+infixl 6 .+., .-.
+infix  4 .=., .<>., .>., .<.
+infixr 3 `and`
+infixr 2 `or`
diff --git a/relational-join/src/Database/Relational/Query/Projection.hs b/relational-join/src/Database/Relational/Query/Projection.hs
index d9d5276a..0248b43a 100644
--- a/relational-join/src/Database/Relational/Query/Projection.hs
+++ b/relational-join/src/Database/Relational/Query/Projection.hs
@@ -5,35 +5,24 @@ module Database.Relational.Query.Projection (
 
   columns,
 
+  unsafeFromColumns,
+
   compose, fromQualifiedSubQuery,
 
-  toExpr,
-
-  pi, piMaybe, flattenMaybe, Projectable (project),
-
-  value,
-
-  valueTrue, valueFalse,
-
-  SqlProjectable (unsafeSqlValue),
-  valueNull, placeholder
+  pi, piMaybe, flattenMaybe
   ) where
 
 import Prelude hiding ((!!), pi)
 
 import Data.Array (Array, listArray)
 import qualified Data.Array as Array
-import Data.List (intercalate)
 
 import Database.Record
   (PersistableWidth, persistableWidth, PersistableRecordWidth)
-import Database.Record.Persistable
-  (runPersistableRecordWidth)
+import Database.Record.Persistable (runPersistableRecordWidth)
 
 import Database.Relational.Query.Pi (Pi)
 import qualified Database.Relational.Query.Pi as Pi
-import Database.Relational.Query.Expr (Expr, ShowConstantSQL (showConstantSQL))
-import qualified Database.Relational.Query.Expr.Unsafe as UnsafeExpr
 import Database.Relational.Query.AliasId (Qualified)
 import Database.Relational.Query.Sub (SubQuery, queryWidth)
 import qualified Database.Relational.Query.Sub as SubQuery
@@ -90,12 +79,6 @@ compose (Composed a) (Composed b) = Composed $ a ++ b
 fromQualifiedSubQuery :: Qualified SubQuery -> Projection t
 fromQualifiedSubQuery =  unsafeFromUnit . Sub
 
-toExpr :: Projection t -> Expr t
-toExpr =  UnsafeExpr.Expr . d . columns  where
-  d ([])  = error $ "expr: no columns."
-  d ([c]) = c
-  d (cs)  = '(' : intercalate ", " cs ++ [')']
-
 
 unsafeProject :: PersistableRecordWidth b -> Projection a' -> Pi a b -> Projection b'
 unsafeProject pr p pi' =
@@ -111,40 +94,3 @@ flattenMaybe (Composed pus) = Composed pus
 
 piMaybe :: PersistableWidth b => Projection (Maybe a) -> Pi a b -> Projection (Maybe b)
 piMaybe =  unsafeProject persistableWidth
-
-class Projectable p where
-  project :: Projection a -> p a
-
-instance Projectable Projection where
-  project = id
-
-instance Projectable Expr where
-  project = toExpr
-
-unsafeSqlProjection :: String -> Projection t
-unsafeSqlProjection =  unsafeFromColumns . (:[])
-
-
-class SqlProjectable p where
-  unsafeSqlValue :: String -> p t
-
-instance SqlProjectable Projection where
-  unsafeSqlValue = unsafeSqlProjection
-
-instance SqlProjectable Expr where
-  unsafeSqlValue = UnsafeExpr.Expr
-
-valueNull :: SqlProjectable p => p (Maybe a)
-valueNull =  unsafeSqlValue "NULL"
-
-placeholder :: SqlProjectable p => p t
-placeholder =  unsafeSqlValue "?"
-
-value :: (ShowConstantSQL t, SqlProjectable p) => t -> p t
-value =  unsafeSqlValue . showConstantSQL
-
-valueTrue :: SqlProjectable p => p Bool
-valueTrue =  value True
-
-valueFalse :: SqlProjectable p => p Bool
-valueFalse =  value False