khibino/haskell-relational-record
1
1
Fork 0
mirror of https://github.com/khibino/haskell-relational-record.git synced 2025-01-05 20:04:49 +03:00
Code Issues Projects Releases Wiki Activity

Add Projectable overloadings and defines binary operators on Projectables.

Browse Source
This commit is contained in:
Kei Hibino 2013-05-16 01:59:54 +09:00
parent 951d281327
commit 642733712a
8 changed files with 172 additions and 95 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
relational-join/relational-join.cabal
View File

@ -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

3
relational-join/src/Database/Relational/Query/Derives.hs
View File

@ -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,

31
relational-join/src/Database/Relational/Query/Expr.hs
View File

@ -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`

7
relational-join/src/Database/Relational/Query/Expr/Unsafe.hs
View File

@ -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

8
relational-join/src/Database/Relational/Query/Join.hs
View File

@ -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

4
relational-join/src/Database/Relational/Query/Product.hs
View File

@ -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

151
relational-join/src/Database/Relational/Query/Projectable.hs Normal file
View File

@ -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`

62
relational-join/src/Database/Relational/Query/Projection.hs
View File

@ -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