Second prototype, now using finally tagless style.

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.*
+      base          == 4.5.*
-    , text         == 0.11.*
+    , text          == 0.11.*
-    , persistent   == 1.0.*
+    , persistent    >= 1.0.1  && < 1.1
-    , transformers == 0.3.*
+    , transformers  == 0.3.*
-    , monad-supply == 0.3.*
+    , monad-supply  == 0.3.*
+
+    , monad-logger
+    , resourcet
   hs-source-dirs: src/
   ghc-options: -Wall

src/Database/Esqueleto.hs

@@ -1,15 +1,14 @@
 {-# LANGUAGE FlexibleContexts, FlexibleInstances, GADTs #-}
 
 module Database.Esqueleto
-  ( -- * Queries
+  ( -- * Language
-    Query
+    Esqueleto
-  , select
+
+    -- * 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

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
+  ( Esqueleto(..)
-    select
   , 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
+-- | Finally tagless representation of Esqueleto's EDSL.
-select :: PersistQuery SqlPersist m => Query a -> SqlPersist m a
+class (Functor query, Applicative query, Monad query) =>
-select = undefined
+      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
+instance ( Esqueleto query expr backend
-  from = Q $ ETable <$> S.supply
+         , PersistEntity val
-instance (From a, From b) => From (a, b) where
+         , 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 ||.

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 <> "(")

src/Database/Esqueleto/Internal/Types.hs

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