From aba36832f6e1b53b31557e6c2a6a3a6e194180df Mon Sep 17 00:00:00 2001 From: Felipe Lessa Date: Mon, 3 Sep 2012 15:42:28 -0300 Subject: [PATCH] Second prototype, now using finally tagless style. --- esqueleto.cabal | 15 +- src/Database/Esqueleto.hs | 15 +- src/Database/Esqueleto/Internal/Language.hs | 200 ++++++------ src/Database/Esqueleto/Internal/Sql.hs | 329 ++++++++++++++++++++ src/Database/Esqueleto/Internal/Types.hs | 68 ---- 5 files changed, 450 insertions(+), 177 deletions(-) create mode 100644 src/Database/Esqueleto/Internal/Sql.hs delete mode 100644 src/Database/Esqueleto/Internal/Types.hs diff --git a/esqueleto.cabal b/esqueleto.cabal index f4b22ed..e7a32d9 100644 --- a/esqueleto.cabal +++ b/esqueleto.cabal @@ -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 diff --git a/src/Database/Esqueleto.hs b/src/Database/Esqueleto.hs index 21bd521..9af731d 100644 --- a/src/Database/Esqueleto.hs +++ b/src/Database/Esqueleto.hs @@ -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 diff --git a/src/Database/Esqueleto/Internal/Language.hs b/src/Database/Esqueleto/Internal/Language.hs index b9042bc..96d135a 100644 --- a/src/Database/Esqueleto/Internal/Language.hs +++ b/src/Database/Esqueleto/Internal/Language.hs @@ -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 ||. diff --git a/src/Database/Esqueleto/Internal/Sql.hs b/src/Database/Esqueleto/Internal/Sql.hs new file mode 100644 index 0000000..cd28b81 --- /dev/null +++ b/src/Database/Esqueleto/Internal/Sql.hs @@ -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 <> "(") diff --git a/src/Database/Esqueleto/Internal/Types.hs b/src/Database/Esqueleto/Internal/Types.hs deleted file mode 100644 index fbc81c9..0000000 --- a/src/Database/Esqueleto/Internal/Types.hs +++ /dev/null @@ -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)