Second prototype, now using finally tagless style.
This commit is contained in:
Felipe Lessa
parent
acc119e61f
commit
aba36832f6
@ -15,14 +15,17 @@ cabal-version: >=1.8
|
||||
library
|
||||
exposed-modules:
|
||||
Database.Esqueleto
|
||||
Database.Esqueleto.Internal.Types
|
||||
Database.Esqueleto.Internal.Language
|
||||
Database.Esqueleto.Internal.Sql
|
||||
-- other-modules:
|
||||
build-depends:
|
||||
base == 4.5.*
|
||||
, text == 0.11.*
|
||||
, persistent == 1.0.*
|
||||
, transformers == 0.3.*
|
||||
, monad-supply == 0.3.*
|
||||
base == 4.5.*
|
||||
, text == 0.11.*
|
||||
, persistent >= 1.0.1 && < 1.1
|
||||
, transformers == 0.3.*
|
||||
, monad-supply == 0.3.*
|
||||
|
||||
, monad-logger
|
||||
, resourcet
|
||||
hs-source-dirs: src/
|
||||
ghc-options: -Wall
|
||||
|
||||
@ -1,15 +1,14 @@
|
||||
{-# LANGUAGE FlexibleContexts, FlexibleInstances, GADTs #-}
|
||||
|
||||
module Database.Esqueleto
|
||||
( -- * Queries
|
||||
Query
|
||||
, select
|
||||
( -- * Language
|
||||
Esqueleto
|
||||
|
||||
-- * Queries
|
||||
, from
|
||||
, where_
|
||||
|
||||
-- * Expressions
|
||||
, Expr
|
||||
, Value
|
||||
, (^.)
|
||||
, val
|
||||
, sub
|
||||
@ -32,7 +31,11 @@ module Database.Esqueleto
|
||||
, (-.)
|
||||
, (*.)
|
||||
, (/.)
|
||||
|
||||
-- * SQL backend
|
||||
, SqlQuery
|
||||
, select
|
||||
) where
|
||||
|
||||
import Database.Esqueleto.Internal.Types
|
||||
import Database.Esqueleto.Internal.Language
|
||||
import Database.Esqueleto.Internal.Sql
|
||||
|
||||
@ -1,50 +1,62 @@
|
||||
{-# LANGUAGE FlexibleContexts, FlexibleInstances, GADTs #-}
|
||||
{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, FunctionalDependencies, TypeFamilies #-}
|
||||
module Database.Esqueleto.Internal.Language
|
||||
( -- * Constructing queries
|
||||
select
|
||||
( Esqueleto(..)
|
||||
, from
|
||||
, where_
|
||||
|
||||
-- * Expressions
|
||||
, (^.)
|
||||
, val
|
||||
, sub
|
||||
|
||||
-- ** Comparison operators
|
||||
, (==.)
|
||||
, (>=.)
|
||||
, (>.)
|
||||
, (<=.)
|
||||
, (<.)
|
||||
, (!=.)
|
||||
|
||||
-- ** Boolean operators
|
||||
, not_
|
||||
, (&&.)
|
||||
, (||.)
|
||||
|
||||
-- ** Numerical operators
|
||||
, (+.)
|
||||
, (-.)
|
||||
, (*.)
|
||||
, (/.)
|
||||
) where
|
||||
|
||||
import Control.Applicative (Applicative(..), (<$>))
|
||||
import Database.Persist.GenericSql
|
||||
import Database.Persist.Store
|
||||
import Database.Persist.Query (PersistQuery)
|
||||
import qualified Control.Monad.Supply as S
|
||||
|
||||
import Database.Esqueleto.Internal.Types
|
||||
|
||||
|
||||
-- | TODO
|
||||
select :: PersistQuery SqlPersist m => Query a -> SqlPersist m a
|
||||
select = undefined
|
||||
-- | Finally tagless representation of Esqueleto's EDSL.
|
||||
class (Functor query, Applicative query, Monad query) =>
|
||||
Esqueleto query expr backend | query -> expr backend, expr -> query backend where
|
||||
-- | Single entity version of 'from'.
|
||||
fromSingle :: ( PersistEntity val
|
||||
, PersistEntityBackend val ~ backend)
|
||||
=> query (expr (Entity val))
|
||||
|
||||
-- | @WHERE@ clause: restrict the query's result.
|
||||
where_ :: expr (Single Bool) -> query ()
|
||||
|
||||
-- | Execute a subquery in an expression.
|
||||
sub :: query (expr a) -> expr a
|
||||
|
||||
-- | Project a field of an entity.
|
||||
(^.) :: (PersistEntity val, PersistField typ) =>
|
||||
expr (Entity val) -> EntityField val typ -> expr (Single typ)
|
||||
|
||||
-- | Lift a constant value from Haskell-land to the query.
|
||||
val :: PersistField typ => typ -> expr (Single typ)
|
||||
|
||||
not_ :: expr (Single Bool) -> expr (Single Bool)
|
||||
|
||||
(==.) :: PersistField typ => expr (Single typ) -> expr (Single typ) -> expr (Single Bool)
|
||||
(>=.) :: PersistField typ => expr (Single typ) -> expr (Single typ) -> expr (Single Bool)
|
||||
(>.) :: PersistField typ => expr (Single typ) -> expr (Single typ) -> expr (Single Bool)
|
||||
(<=.) :: PersistField typ => expr (Single typ) -> expr (Single typ) -> expr (Single Bool)
|
||||
(<.) :: PersistField typ => expr (Single typ) -> expr (Single typ) -> expr (Single Bool)
|
||||
(!=.) :: PersistField typ => expr (Single typ) -> expr (Single typ) -> expr (Single Bool)
|
||||
|
||||
(&&.) :: expr (Single Bool) -> expr (Single Bool) -> expr (Single Bool)
|
||||
(||.) :: expr (Single Bool) -> expr (Single Bool) -> expr (Single Bool)
|
||||
|
||||
(+.) :: (Num a, PersistField a) => expr (Single a) -> expr (Single a) -> expr (Single a)
|
||||
(-.) :: (Num a, PersistField a) => expr (Single a) -> expr (Single a) -> expr (Single a)
|
||||
(/.) :: (Num a, PersistField a) => expr (Single a) -> expr (Single a) -> expr (Single a)
|
||||
(*.) :: (Num a, PersistField a) => expr (Single a) -> expr (Single a) -> expr (Single a)
|
||||
|
||||
-- Fixity declarations
|
||||
infixl 9 ^.
|
||||
infixl 7 *., /.
|
||||
infixl 6 +., -.
|
||||
infix 4 ==., >=., >., <=., <., !=.
|
||||
infixr 3 &&.
|
||||
infixr 2 ||.
|
||||
|
||||
|
||||
class From a where
|
||||
class Esqueleto query expr backend => From query expr backend a where
|
||||
-- | @FROM@ clause: bring an entity into scope.
|
||||
--
|
||||
-- The following types implement 'from':
|
||||
@ -58,72 +70,66 @@ class From a where
|
||||
-- Note that using 'from' for the same entity twice does work
|
||||
-- and corresponds to a self-join. You don't even need to use
|
||||
-- two different calls to 'from', you may use a tuple.
|
||||
from :: Query a
|
||||
from :: query a
|
||||
|
||||
instance (PersistEntity val, PersistEntityBackend val ~ SqlPersist) => From (Expr (Entity val)) where
|
||||
from = Q $ ETable <$> S.supply
|
||||
instance (From a, From b) => From (a, b) where
|
||||
instance ( Esqueleto query expr backend
|
||||
, PersistEntity val
|
||||
, PersistEntityBackend val ~ backend
|
||||
) => From query expr backend (expr (Entity val)) where
|
||||
from = fromSingle
|
||||
|
||||
instance ( From query expr backend a
|
||||
, From query expr backend b
|
||||
) => From query expr backend (a, b) where
|
||||
from = (,) <$> from <*> from
|
||||
instance (From a, From b, From c) => From (a, b, c) where
|
||||
|
||||
instance ( From query expr backend a
|
||||
, From query expr backend b
|
||||
, From query expr backend c
|
||||
) => From query expr backend (a, b, c) where
|
||||
from = (,,) <$> from <*> from <*> from
|
||||
instance (From a, From b, From c, From d) => From (a, b, c, d) where
|
||||
|
||||
instance ( From query expr backend a
|
||||
, From query expr backend b
|
||||
, From query expr backend c
|
||||
, From query expr backend d
|
||||
) => From query expr backend (a, b, c, d) where
|
||||
from = (,,,) <$> from <*> from <*> from <*> from
|
||||
instance (From a, From b, From c, From d, From e) => From (a, b, c, d, e) where
|
||||
|
||||
instance ( From query expr backend a
|
||||
, From query expr backend b
|
||||
, From query expr backend c
|
||||
, From query expr backend d
|
||||
, From query expr backend e
|
||||
) => From query expr backend (a, b, c, d, e) where
|
||||
from = (,,,,) <$> from <*> from <*> from <*> from <*> from
|
||||
instance (From a, From b, From c, From d, From e, From f) => From (a, b, c, d, e, f) where
|
||||
|
||||
instance ( From query expr backend a
|
||||
, From query expr backend b
|
||||
, From query expr backend c
|
||||
, From query expr backend d
|
||||
, From query expr backend e
|
||||
, From query expr backend f
|
||||
) => From query expr backend (a, b, c, d, e, f) where
|
||||
from = (,,,,,) <$> from <*> from <*> from <*> from <*> from <*> from
|
||||
instance (From a, From b, From c, From d, From e, From f, From g) => From (a, b, c, d, e, f, g) where
|
||||
|
||||
instance ( From query expr backend a
|
||||
, From query expr backend b
|
||||
, From query expr backend c
|
||||
, From query expr backend d
|
||||
, From query expr backend e
|
||||
, From query expr backend f
|
||||
, From query expr backend g
|
||||
) => From query expr backend (a, b, c, d, e, f, g) where
|
||||
from = (,,,,,,) <$> from <*> from <*> from <*> from <*> from <*> from <*> from
|
||||
instance (From a, From b, From c, From d, From e, From f, From g, From h) => From (a, b, c, d, e, f, g, h) where
|
||||
|
||||
instance ( From query expr backend a
|
||||
, From query expr backend b
|
||||
, From query expr backend c
|
||||
, From query expr backend d
|
||||
, From query expr backend e
|
||||
, From query expr backend f
|
||||
, From query expr backend g
|
||||
, From query expr backend h
|
||||
) => From query expr backend (a, b, c, d, e, f, g, h) where
|
||||
from = (,,,,,,,) <$> from <*> from <*> from <*> from <*> from <*> from <*> from <*> from
|
||||
|
||||
|
||||
-- | @WHERE@ clause: restrict the query's result.
|
||||
where_ :: Value Bool -> Query ()
|
||||
where_ = undefined
|
||||
|
||||
|
||||
-- | Execute a subquery in an expression.
|
||||
sub :: Query (Expr a) -> Expr a
|
||||
sub = ESub
|
||||
|
||||
|
||||
-- | Project a field of an entity.
|
||||
(^.) :: PersistField typ => Expr (Entity val) -> EntityField val typ -> Value typ
|
||||
(^.) = EProj
|
||||
|
||||
|
||||
-- | Lift a constant value from Haskell-land to the query.
|
||||
val :: PersistField typ => typ -> Value typ
|
||||
val = EVal
|
||||
|
||||
|
||||
(==.), (>=.), (>.), (<=.), (<.), (!=.) :: PersistField typ => Value typ -> Value typ -> Value Bool
|
||||
(==.) = EBinOp OEq
|
||||
(>=.) = EBinOp OGeq
|
||||
(>.) = EBinOp OGt
|
||||
(<=.) = EBinOp OLeq
|
||||
(<.) = EBinOp OLt
|
||||
(!=.) = EBinOp ONeq
|
||||
|
||||
not_ :: Value Bool -> Value Bool
|
||||
not_ = ENot
|
||||
|
||||
(&&.), (||.) :: Value Bool -> Value Bool -> Value Bool
|
||||
(&&.) = EBinOp OAnd
|
||||
(||.) = EBinOp OOr
|
||||
|
||||
(+.), (-.), (/.), (*.) :: (Num a, PersistField a) => Value a -> Value a -> Value a
|
||||
(+.) = EBinOp OAdd
|
||||
(-.) = EBinOp OSub
|
||||
(/.) = EBinOp ODiv
|
||||
(*.) = EBinOp OMult
|
||||
|
||||
|
||||
-- Fixity declarations
|
||||
infixl 9 ^.
|
||||
infixl 7 *., /.
|
||||
infixl 6 +., -.
|
||||
infix 4 ==., >=., >., <=., <., !=.
|
||||
infixr 3 &&.
|
||||
infixr 2 ||.
|
||||
|
||||
329
src/Database/Esqueleto/Internal/Sql.hs
Normal file
329
src/Database/Esqueleto/Internal/Sql.hs
Normal file
@ -0,0 +1,329 @@
|
||||
{-# LANGUAGE ConstraintKinds, MultiParamTypeClasses, TypeFamilies, FlexibleContexts, GADTs, OverloadedStrings #-}
|
||||
module Database.Esqueleto.Internal.Sql
|
||||
( SqlQuery
|
||||
, select
|
||||
, toRawSelectSql
|
||||
) where
|
||||
|
||||
import Control.Applicative (Applicative(..), (<$>))
|
||||
import Control.Monad (ap)
|
||||
import Control.Monad.Logger (MonadLogger)
|
||||
import Control.Monad.Trans.Resource (MonadResourceBase)
|
||||
import Data.List (intersperse)
|
||||
import Data.Monoid (Monoid(..), (<>))
|
||||
import Database.Persist.EntityDef
|
||||
import Database.Persist.GenericSql
|
||||
import Database.Persist.GenericSql.Internal (Connection(escapeName))
|
||||
import Database.Persist.Store
|
||||
import qualified Control.Monad.Supply as S
|
||||
import qualified Control.Monad.Trans.Reader as R
|
||||
import qualified Control.Monad.Trans.Writer as W
|
||||
import qualified Data.Text as T
|
||||
import qualified Data.Text.Lazy as TL
|
||||
import qualified Data.Text.Lazy.Builder as TLB
|
||||
|
||||
import Database.Esqueleto.Internal.Language
|
||||
|
||||
|
||||
-- | SQL backend for 'Esqueleto' using 'SqlPersist'.
|
||||
newtype SqlQuery a =
|
||||
Q { unQ :: W.WriterT SideData (S.Supply Ident) a }
|
||||
|
||||
instance Functor SqlQuery where
|
||||
fmap f = Q . fmap f . unQ
|
||||
|
||||
instance Monad SqlQuery where
|
||||
return = Q . return
|
||||
m >>= f = Q (unQ m >>= unQ . f)
|
||||
|
||||
instance Applicative SqlQuery where
|
||||
pure = return
|
||||
(<*>) = ap
|
||||
|
||||
|
||||
-- | Side data written by 'SqlQuery'.
|
||||
data SideData = SideData { sdFromClause :: ![FromClause]
|
||||
, sdWhereClause :: !WhereClause
|
||||
}
|
||||
|
||||
instance Monoid SideData where
|
||||
mempty = SideData mempty mempty
|
||||
SideData f w `mappend` SideData f' w' =
|
||||
SideData (f <> f') (w <> w')
|
||||
|
||||
|
||||
-- | A part of a @FROM@ clause.
|
||||
data FromClause = From Ident EntityDef
|
||||
|
||||
|
||||
-- | A complere @WHERE@ clause.
|
||||
data WhereClause = Where (SqlExpr (Single Bool))
|
||||
| NoWhere
|
||||
|
||||
instance Monoid WhereClause where
|
||||
mempty = NoWhere
|
||||
NoWhere `mappend` w = w
|
||||
w `mappend` NoWhere = w
|
||||
Where e1 `mappend` Where e2 = Where (e1 &&. e2)
|
||||
|
||||
|
||||
-- | Identifier used for tables.
|
||||
newtype Ident = I TLB.Builder
|
||||
|
||||
|
||||
-- | Infinite list of identifiers.
|
||||
idents :: () -- ^ Avoid keeping everything in memory.
|
||||
-> [Ident]
|
||||
idents _ =
|
||||
let alpha = ['A'..'Z']
|
||||
letters 1 = map return alpha
|
||||
letters n = (:) <$> alpha <*> letters (n-1)
|
||||
everything = concat (map letters [(1::Int)..])
|
||||
in map (I . TLB.fromString . ('T':)) everything
|
||||
|
||||
|
||||
-- | An expression on the SQL backend.
|
||||
data SqlExpr a where
|
||||
EEntity :: Ident -> SqlExpr (Entity val)
|
||||
ERaw :: (Connection -> TLB.Builder) -> [PersistValue] -> SqlExpr (Single a)
|
||||
|
||||
instance Esqueleto SqlQuery SqlExpr SqlPersist where
|
||||
fromSingle = Q $ do
|
||||
ident <- S.supply
|
||||
let from_ = From ident $ entityDef (getVal ret)
|
||||
ret = EEntity ident
|
||||
getVal :: SqlExpr (Entity val) -> val
|
||||
getVal = error "SqlQuery/getVal: never here"
|
||||
W.tell mempty { sdFromClause = [from_] }
|
||||
return ret
|
||||
|
||||
where_ expr = Q $ W.tell mempty { sdWhereClause = Where expr }
|
||||
|
||||
EEntity (I ident) ^. field = ERaw (\conn -> ident <> ("." <> name conn field)) []
|
||||
where name conn = fromDBName conn . fieldDB . persistFieldDef
|
||||
|
||||
val = ERaw (const "?") . return . toPersistValue
|
||||
|
||||
not_ (ERaw b vals) = ERaw (\conn -> "NOT " <> parens (b conn)) vals
|
||||
|
||||
(==.) = binop " = "
|
||||
(>=.) = binop " >= "
|
||||
(>.) = binop " > "
|
||||
(<=.) = binop " <= "
|
||||
(<.) = binop " < "
|
||||
(!=.) = binop " != "
|
||||
(&&.) = binop " AND "
|
||||
(||.) = binop " OR "
|
||||
(+.) = binop " + "
|
||||
(-.) = binop " - "
|
||||
(/.) = binop " / "
|
||||
(*.) = binop " * "
|
||||
|
||||
|
||||
fromDBName :: Connection -> DBName -> TLB.Builder
|
||||
fromDBName conn = TLB.fromText . escapeName conn
|
||||
|
||||
binop :: TLB.Builder -> SqlExpr (Single a) -> SqlExpr (Single b) -> SqlExpr (Single c)
|
||||
binop op (ERaw b1 vals1) (ERaw b2 vals2) = ERaw b (vals1 <> vals2)
|
||||
where
|
||||
b conn = parens (b1 conn) <> op <> parens (b2 conn)
|
||||
|
||||
|
||||
-- | TODO
|
||||
select :: ( SqlSelect a
|
||||
, RawSql (SqlSelectRet r)
|
||||
, MonadLogger m
|
||||
, MonadResourceBase m)
|
||||
=> SqlQuery a -> SqlPersist m [SqlSelectRet r]
|
||||
select query = do
|
||||
conn <- getConnection
|
||||
uncurry rawSql $ toRawSelectSql conn query
|
||||
|
||||
|
||||
-- | Get current database 'Connection'.
|
||||
getConnection :: Monad m => SqlPersist m Connection
|
||||
getConnection = SqlPersist R.ask
|
||||
|
||||
|
||||
-- | Pretty prints a 'SqlQuery' into a SQL query.
|
||||
toRawSelectSql :: SqlSelect a => Connection -> SqlQuery a -> (T.Text, [PersistValue])
|
||||
toRawSelectSql conn query =
|
||||
let (ret, SideData fromClauses whereClauses) =
|
||||
flip S.evalSupply (idents ()) $
|
||||
W.runWriterT $
|
||||
unQ query
|
||||
|
||||
(selectText, selectVars) = makeSelect conn ret
|
||||
(whereText, whereVars) = makeWhere conn whereClauses
|
||||
|
||||
text = TL.toStrict $
|
||||
TLB.toLazyText $
|
||||
mconcat
|
||||
[ "SELECT "
|
||||
, selectText
|
||||
, makeFrom conn fromClauses
|
||||
, whereText
|
||||
]
|
||||
|
||||
in (text, selectVars <> whereVars)
|
||||
|
||||
|
||||
class RawSql (SqlSelectRet a) => SqlSelect a where
|
||||
type SqlSelectRet a :: *
|
||||
makeSelect :: Connection -> a -> (TLB.Builder, [PersistValue])
|
||||
|
||||
instance RawSql a => SqlSelect (SqlExpr a) where
|
||||
type SqlSelectRet (SqlExpr a) = a
|
||||
makeSelect _ (EEntity _) = ("??", mempty)
|
||||
makeSelect conn (ERaw b vals) = (parens (b conn), vals)
|
||||
|
||||
instance (SqlSelect a, SqlSelect b) => SqlSelect (a, b) where
|
||||
type SqlSelectRet (a, b) = (SqlSelectRet a, SqlSelectRet b)
|
||||
makeSelect conn (a, b) = makeSelect conn a <> makeSelect conn b
|
||||
instance (SqlSelect a, SqlSelect b, SqlSelect c) => SqlSelect (a, b, c) where
|
||||
type SqlSelectRet (a, b, c) =
|
||||
( SqlSelectRet a
|
||||
, SqlSelectRet b
|
||||
, SqlSelectRet c
|
||||
)
|
||||
makeSelect conn (a, b, c) =
|
||||
mconcat
|
||||
[ makeSelect conn a
|
||||
, makeSelect conn b
|
||||
, makeSelect conn c
|
||||
]
|
||||
instance ( SqlSelect a
|
||||
, SqlSelect b
|
||||
, SqlSelect c
|
||||
, SqlSelect d
|
||||
) => SqlSelect (a, b, c, d) where
|
||||
type SqlSelectRet (a, b, c, d) =
|
||||
( SqlSelectRet a
|
||||
, SqlSelectRet b
|
||||
, SqlSelectRet c
|
||||
, SqlSelectRet d
|
||||
)
|
||||
makeSelect conn (a, b, c, d) =
|
||||
mconcat
|
||||
[ makeSelect conn a
|
||||
, makeSelect conn b
|
||||
, makeSelect conn c
|
||||
, makeSelect conn d
|
||||
]
|
||||
instance ( SqlSelect a
|
||||
, SqlSelect b
|
||||
, SqlSelect c
|
||||
, SqlSelect d
|
||||
, SqlSelect e
|
||||
) => SqlSelect (a, b, c, d, e) where
|
||||
type SqlSelectRet (a, b, c, d, e) =
|
||||
( SqlSelectRet a
|
||||
, SqlSelectRet b
|
||||
, SqlSelectRet c
|
||||
, SqlSelectRet d
|
||||
, SqlSelectRet e
|
||||
)
|
||||
makeSelect conn (a, b, c, d, e) =
|
||||
mconcat
|
||||
[ makeSelect conn a
|
||||
, makeSelect conn b
|
||||
, makeSelect conn c
|
||||
, makeSelect conn d
|
||||
, makeSelect conn e
|
||||
]
|
||||
instance ( SqlSelect a
|
||||
, SqlSelect b
|
||||
, SqlSelect c
|
||||
, SqlSelect d
|
||||
, SqlSelect e
|
||||
, SqlSelect f
|
||||
) => SqlSelect (a, b, c, d, e, f) where
|
||||
type SqlSelectRet (a, b, c, d, e, f) =
|
||||
( SqlSelectRet a
|
||||
, SqlSelectRet b
|
||||
, SqlSelectRet c
|
||||
, SqlSelectRet d
|
||||
, SqlSelectRet e
|
||||
, SqlSelectRet f
|
||||
)
|
||||
makeSelect conn (a, b, c, d, e, f) =
|
||||
mconcat
|
||||
[ makeSelect conn a
|
||||
, makeSelect conn b
|
||||
, makeSelect conn c
|
||||
, makeSelect conn d
|
||||
, makeSelect conn e
|
||||
, makeSelect conn f
|
||||
]
|
||||
instance ( SqlSelect a
|
||||
, SqlSelect b
|
||||
, SqlSelect c
|
||||
, SqlSelect d
|
||||
, SqlSelect e
|
||||
, SqlSelect f
|
||||
, SqlSelect g
|
||||
) => SqlSelect (a, b, c, d, e, f, g) where
|
||||
type SqlSelectRet (a, b, c, d, e, f, g) =
|
||||
( SqlSelectRet a
|
||||
, SqlSelectRet b
|
||||
, SqlSelectRet c
|
||||
, SqlSelectRet d
|
||||
, SqlSelectRet e
|
||||
, SqlSelectRet f
|
||||
, SqlSelectRet g
|
||||
)
|
||||
makeSelect conn (a, b, c, d, e, f, g) =
|
||||
mconcat
|
||||
[ makeSelect conn a
|
||||
, makeSelect conn b
|
||||
, makeSelect conn c
|
||||
, makeSelect conn d
|
||||
, makeSelect conn e
|
||||
, makeSelect conn f
|
||||
, makeSelect conn g
|
||||
]
|
||||
instance ( SqlSelect a
|
||||
, SqlSelect b
|
||||
, SqlSelect c
|
||||
, SqlSelect d
|
||||
, SqlSelect e
|
||||
, SqlSelect f
|
||||
, SqlSelect g
|
||||
, SqlSelect h
|
||||
) => SqlSelect (a, b, c, d, e, f, g, h) where
|
||||
type SqlSelectRet (a, b, c, d, e, f, g, h) =
|
||||
( SqlSelectRet a
|
||||
, SqlSelectRet b
|
||||
, SqlSelectRet c
|
||||
, SqlSelectRet d
|
||||
, SqlSelectRet e
|
||||
, SqlSelectRet f
|
||||
, SqlSelectRet g
|
||||
, SqlSelectRet h
|
||||
)
|
||||
makeSelect conn (a, b, c, d, e, f, g, h) =
|
||||
mconcat
|
||||
[ makeSelect conn a
|
||||
, makeSelect conn b
|
||||
, makeSelect conn c
|
||||
, makeSelect conn d
|
||||
, makeSelect conn e
|
||||
, makeSelect conn f
|
||||
, makeSelect conn g
|
||||
, makeSelect conn h
|
||||
]
|
||||
|
||||
|
||||
makeFrom :: Connection -> [FromClause] -> TLB.Builder
|
||||
makeFrom conn = mconcat . intersperse ", " . map mk
|
||||
where
|
||||
mk (From (I i) def) = fromDBName conn (entityDB def) <> (" AS " <> i)
|
||||
|
||||
|
||||
makeWhere :: Connection -> WhereClause -> (TLB.Builder, [PersistValue])
|
||||
makeWhere _ NoWhere = mempty
|
||||
makeWhere conn (Where (ERaw b vals)) = ("\nWHERE " <> b conn, vals)
|
||||
|
||||
|
||||
parens :: TLB.Builder -> TLB.Builder
|
||||
parens b = "(" <> (b <> "(")
|
||||
@ -1,68 +0,0 @@
|
||||
{-# LANGUAGE FlexibleContexts, FlexibleInstances, GADTs #-}
|
||||
module Database.Esqueleto.Internal.Types
|
||||
( Query(..)
|
||||
, Ident(..)
|
||||
, Expr(..)
|
||||
, BinOp(..)
|
||||
, Value
|
||||
) where
|
||||
|
||||
import Control.Applicative (Applicative(..))
|
||||
import Control.Monad (ap)
|
||||
import Data.Text (Text)
|
||||
import Database.Persist.GenericSql
|
||||
import Database.Persist.Store
|
||||
import qualified Control.Monad.Supply as S
|
||||
|
||||
|
||||
-- | TODO
|
||||
newtype Query a =
|
||||
Q { unQ :: S.Supply Ident a }
|
||||
|
||||
instance Functor Query where
|
||||
fmap f = Q . fmap f . unQ
|
||||
|
||||
instance Monad Query where
|
||||
return = Q . return
|
||||
m >>= f = Q (unQ m >>= unQ . f)
|
||||
|
||||
instance Applicative Query where
|
||||
pure = return
|
||||
(<*>) = ap
|
||||
|
||||
|
||||
-- | Identifier used for tables.
|
||||
newtype Ident = Ident Text
|
||||
|
||||
|
||||
-- | TODO
|
||||
data Expr a where
|
||||
ETable :: (PersistEntity val, PersistEntityBackend val ~ SqlPersist) => Ident -> Expr (Entity val)
|
||||
ESub :: Query (Expr a) -> Expr a
|
||||
EProj :: PersistField typ => Expr (Entity val) -> EntityField val typ -> Expr (Single typ)
|
||||
EVal :: PersistField typ => typ -> Expr (Single typ)
|
||||
EBinOp :: BinOp a b r -> Expr (Single a) -> Expr (Single b) -> Expr (Single r)
|
||||
ENot :: Expr (Single Bool) -> Expr (Single Bool)
|
||||
|
||||
|
||||
-- | A binary operation.
|
||||
data BinOp a b r where
|
||||
OEq :: PersistField typ => BinOp typ typ Bool
|
||||
OGeq :: PersistField typ => BinOp typ typ Bool
|
||||
OGt :: PersistField typ => BinOp typ typ Bool
|
||||
OLeq :: PersistField typ => BinOp typ typ Bool
|
||||
OLt :: PersistField typ => BinOp typ typ Bool
|
||||
ONeq :: PersistField typ => BinOp typ typ Bool
|
||||
|
||||
OAnd :: BinOp Bool Bool Bool
|
||||
OOr :: BinOp Bool Bool Bool
|
||||
|
||||
OAdd :: (Num a, PersistField a) => BinOp a a a
|
||||
OSub :: (Num a, PersistField a) => BinOp a a a
|
||||
ODiv :: (Num a, PersistField a) => BinOp a a a
|
||||
OMult :: (Num a, PersistField a) => BinOp a a a
|
||||
|
||||
|
||||
-- | A 'Value' is just a type synonym for expressions whose types
|
||||
-- are not entities but simple values.
|
||||
type Value a = Expr (Single a)
|
||||
Loading…
Reference in New Issue
Block a user