Merge pull request #9 from foxhound-systems/final-expr

Convert SqlExpr to a final encoding

src/Database/Esqueleto/Experimental/From.hs

@@ -52,7 +52,7 @@ instance PersistEntity a => From (Table a) where
     runFrom e@Table = do
         let ed = entityDef $ getVal e
         ident <- newIdentFor (entityDB ed)
-        let entity = EEntity ident
+        let entity = unsafeSqlEntity ident
         pure $ (entity, FromStart ident ed)
           where
             getVal ::  Table ent -> Proxy ent

src/Database/Esqueleto/Experimental/ToAlias.hs

@@ -16,20 +16,22 @@ class ToAlias a where
     toAlias :: a -> SqlQuery a
 
 instance ToAlias (SqlExpr (Value a)) where
-    toAlias v@(EAliasedValue _ _) = pure v
+    toAlias e@(ERaw m f)
-    toAlias v = do
+      | Just _ <- sqlExprMetaAlias m, not (sqlExprMetaIsReference m) = pure e
-        ident <- newIdentFor (DBName "v")
+      | otherwise = do
-        pure $ EAliasedValue ident v
+            ident <- newIdentFor (DBName "v")
+            pure $ ERaw noMeta{sqlExprMetaAlias = Just ident} f
 
 instance ToAlias (SqlExpr (Entity a)) where
-    toAlias v@(EAliasedEntityReference _ _) = pure v
+    toAlias (ERaw m f) = do
-    toAlias v@(EAliasedEntity _ _) = pure v
-    toAlias (EEntity tableIdent) = do
        ident <- newIdentFor (DBName "v")
-       pure $ EAliasedEntity ident tableIdent
+       pure $ ERaw m{sqlExprMetaIsReference = False, sqlExprMetaAlias = Just ident} f
 
 instance ToAlias (SqlExpr (Maybe (Entity a))) where
-    toAlias (EMaybe e) = EMaybe <$> toAlias e
+    -- FIXME: Code duplication because the compiler doesnt like half final encoding
+    toAlias (ERaw m f) = do
+       ident <- newIdentFor (DBName "v")
+       pure $ ERaw m{sqlExprMetaIsReference = False, sqlExprMetaAlias = Just ident} f
 
 instance (ToAlias a, ToAlias b) => ToAlias (a,b) where
     toAlias (a,b) = (,) <$> toAlias a <*> toAlias b

src/Database/Esqueleto/Experimental/ToAliasReference.hs

@@ -1,10 +1,11 @@
 {-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE TypeFamilies #-}
 
 module Database.Esqueleto.Experimental.ToAliasReference
     where
 
-import Database.Esqueleto.Experimental.ToAlias
+import Data.Coerce
 import Database.Esqueleto.Internal.Internal hiding (From, from, on)
 import Database.Esqueleto.Internal.PersistentImport
 
@@ -16,18 +17,21 @@ class ToAliasReference a where
     toAliasReference :: Ident -> a -> SqlQuery a
 
 instance ToAliasReference (SqlExpr (Value a)) where
-    toAliasReference aliasSource (EAliasedValue aliasIdent _) = pure $ EValueReference aliasSource (\_ -> aliasIdent)
+    toAliasReference aliasSource (ERaw m _)
-    toAliasReference _           v@(ERaw _ _)                 = toAlias v
+      | Just alias <- sqlExprMetaAlias m = pure $ ERaw m{sqlExprMetaIsReference = True} $ \_ info ->
-    toAliasReference _           v@(ECompositeKey _)          = toAlias v
+          (useIdent info aliasSource <> "." <> useIdent info alias, [])
-    toAliasReference s             (EValueReference _ b)      = pure $ EValueReference s b
+    toAliasReference _ e = pure e
 
 instance ToAliasReference (SqlExpr (Entity a)) where
-    toAliasReference aliasSource (EAliasedEntity ident _) = pure $ EAliasedEntityReference aliasSource ident
+    toAliasReference aliasSource (ERaw m _)
-    toAliasReference _ e@(EEntity _) = toAlias e
+      | Just _ <- sqlExprMetaAlias m, False <- sqlExprMetaIsReference m =
-    toAliasReference s   (EAliasedEntityReference _ b) = pure $ EAliasedEntityReference s b
+          pure $ ERaw m{sqlExprMetaIsReference = True} $ \_ info ->
+            (useIdent info aliasSource, [])
+    toAliasReference _ e = pure e
 
 instance ToAliasReference (SqlExpr (Maybe (Entity a))) where
-    toAliasReference s (EMaybe e) = EMaybe <$> toAliasReference s e
+    toAliasReference aliasSource e =
+        coerce <$> toAliasReference aliasSource (coerce e :: SqlExpr (Entity a))
 
 
 instance (ToAliasReference a, ToAliasReference b) => ToAliasReference (a, b) where

src/Database/Esqueleto/Experimental/ToMaybe.hs

@@ -21,7 +21,7 @@ instance ToMaybe (SqlExpr (Maybe a)) where
 
 instance ToMaybe (SqlExpr (Entity a)) where
     type ToMaybeT (SqlExpr (Entity a)) = SqlExpr (Maybe (Entity a))
-    toMaybe = EMaybe
+    toMaybe (ERaw f m) = (ERaw f m)
 
 instance ToMaybe (SqlExpr (Value a)) where
     type ToMaybeT (SqlExpr (Value a)) = SqlExpr (Value (Maybe (Nullable a)))

src/Database/Esqueleto/Internal/Sql.hs

@@ -37,8 +37,8 @@ module Database.Esqueleto.Internal.Sql
       -- * The guts
     , unsafeSqlCase
     , unsafeSqlBinOp
-    , unsafeSqlBinOpComposite
     , unsafeSqlValue
+    , unsafeSqlEntity
     , unsafeSqlCastAs
     , unsafeSqlFunction
     , unsafeSqlExtractSubField

src/Database/Esqueleto/PostgreSQL.hs

@@ -83,18 +83,18 @@ unsafeSqlAggregateFunction
     -> a
     -> [OrderByClause]
     -> SqlExpr (Value b)
-unsafeSqlAggregateFunction name mode args orderByClauses = ERaw Never $ \info ->
+unsafeSqlAggregateFunction name mode args orderByClauses = ERaw noMeta $ \_ info ->
     let (orderTLB, orderVals) = makeOrderByNoNewline info orderByClauses
         -- Don't add a space if we don't have order by clauses
         orderTLBSpace =
             case orderByClauses of
-                [] -> ""
+                []    -> ""
                 (_:_) -> " "
         (argsTLB, argsVals) =
-            uncommas' $ map (\(ERaw _ f) -> f info) $ toArgList args
+            uncommas' $ map (\(ERaw _ f) -> f Never info) $ toArgList args
         aggMode =
             case mode of
-                AggModeAll -> ""
+                AggModeAll      -> ""
                 -- ALL is the default, so we don't need to
                 -- specify it
                 AggModeDistinct -> "DISTINCT "
@@ -182,7 +182,7 @@ upsert
     )
     => record
     -- ^ new record to insert
-    -> [SqlExpr (Update record)]
+    -> [SqlExpr (Entity record) -> SqlExpr Update]
     -- ^ updates to perform if the record already exists
     -> R.ReaderT SqlBackend m (Entity record)
     -- ^ the record in the database after the operation
@@ -200,7 +200,7 @@ upsertBy
     -- ^ uniqueness constraint to find by
     -> record
     -- ^ new record to insert
-    -> [SqlExpr (Update record)]
+    -> [SqlExpr (Entity record) -> SqlExpr Update]
     -- ^ updates to perform if the record already exists
     -> R.ReaderT SqlBackend m (Entity record)
     -- ^ the record in the database after the operation
@@ -276,7 +276,7 @@ insertSelectWithConflict
     -- a unique "MyUnique 0", "MyUnique undefined" would work as well.
     -> SqlQuery (SqlExpr (Insertion val))
     -- ^ Insert query.
-    -> (SqlExpr (Entity val) -> SqlExpr (Entity val) -> [SqlExpr (Update val)])
+    -> (SqlExpr (Entity val) -> SqlExpr (Entity val) -> [SqlExpr (Entity val) -> SqlExpr Update])
     -- ^ A list of updates to be applied in case of the constraint being
     -- violated. The expression takes the current and excluded value to produce
     -- the updates.
@@ -292,22 +292,22 @@ insertSelectWithConflictCount
      . (FinalResult a, KnowResult a ~ Unique val, MonadIO m, PersistEntity val)
     => a
     -> SqlQuery (SqlExpr (Insertion val))
-    -> (SqlExpr (Entity val) -> SqlExpr (Entity val) -> [SqlExpr (Update val)])
+    -> (SqlExpr (Entity val) -> SqlExpr (Entity val) -> [SqlExpr (Entity val) -> SqlExpr Update])
     -> SqlWriteT m Int64
 insertSelectWithConflictCount unique query conflictQuery = do
     conn <- R.ask
     uncurry rawExecuteCount $
         combine
-            (toRawSql INSERT_INTO (conn, initialIdentState) (fmap EInsertFinal query))
+            (toRawSql INSERT_INTO (conn, initialIdentState) query)
             (conflict conn)
   where
     proxy :: Proxy val
     proxy = Proxy
     updates = conflictQuery entCurrent entExcluded
     combine (tlb1,vals1) (tlb2,vals2) = (builderToText (tlb1 `mappend` tlb2), vals1 ++ vals2)
-    entExcluded = EEntity $ I "excluded"
+    entExcluded = unsafeSqlEntity (I "excluded")
     tableName = unDBName . entityDB . entityDef
-    entCurrent = EEntity $ I (tableName proxy)
+    entCurrent = unsafeSqlEntity (I (tableName proxy))
     uniqueDef = toUniqueDef unique
     constraint = TLB.fromText . unDBName . uniqueDBName $ uniqueDef
     renderedUpdates :: (BackendCompatible SqlBackend backend) => backend -> (TLB.Builder, [PersistValue])
@@ -355,13 +355,11 @@ filterWhere
     -> SqlExpr (Value Bool)
     -- ^ Filter clause
     -> SqlExpr (Value a)
-filterWhere aggExpr clauseExpr = ERaw Never $ \info ->
+filterWhere aggExpr clauseExpr = ERaw noMeta $ \_ info ->
     let (aggBuilder, aggValues) = case aggExpr of
-            ERaw _ aggF     -> aggF info
+            ERaw _ aggF     -> aggF Never info
-            ECompositeKey _ -> throw $ CompositeKeyErr FilterWhereAggError
         (clauseBuilder, clauseValues) = case clauseExpr of
-            ERaw _ clauseF  -> clauseF info
+            ERaw _ clauseF  -> clauseF Never info
-            ECompositeKey _ -> throw $ CompositeKeyErr FilterWhereClauseError
     in ( aggBuilder <> " FILTER (WHERE " <> clauseBuilder <> ")"
        , aggValues <> clauseValues
        )

test/Common/Test.hs

@@ -1,6 +1,6 @@
 {-# LANGUAGE CPP #-}
-{-# LANGUAGE DataKinds #-}
 {-# LANGUAGE ConstraintKinds #-}
+{-# LANGUAGE DataKinds #-}
 {-# LANGUAGE DeriveGeneric #-}
 {-# LANGUAGE DerivingStrategies #-}
 {-# LANGUAGE EmptyDataDecls #-}
@@ -385,7 +385,7 @@ testSubSelect run = do
                     v `shouldBe` [Value 1]
 
     describe "subSelectList" $ do
-        it "is safe on empty databases as well as good databases" $ do
+        it "is safe on empty databases as well as good databases" $ run $ do
             let query =
                     from $ \n -> do
                     where_ $ n ^. NumbersInt `in_` do
@@ -394,16 +394,15 @@ testSubSelect run = do
                             where_ $ n' ^. NumbersInt >=. val 3
                             pure (n' ^. NumbersInt)
                     pure n
+            empty <- select query
 
-            empty <- run $ do
+            full <- do
-                select query
-
-            full <- run $ do
                 setup
                 select query
 
-            empty `shouldBe` []
+            liftIO $ do
-            full `shouldSatisfy` (not . null)
+                empty `shouldBe` []
+                full `shouldSatisfy` (not . null)
 
     describe "subSelectMaybe" $ do
         it "is equivalent to joinV . subSelect" $ do
@@ -888,12 +887,14 @@ testSelectSubQuery run = describe "select subquery" $ do
         l1Deeds <- mapM (\k -> insert' $ Deed k (entityKey l1e)) (map show [1..3 :: Int])
         let l1WithDeeds = do d <- l1Deeds
                              pure (l1e, Just d)
-        ret <- select $ Experimental.from $ do
+        let q = Experimental.from $ do
-          (lords :& deeds) <-
+                  (lords :& deeds) <-
-              Experimental.from $ Table @Lord
+                      Experimental.from $ Table @Lord
-              `LeftOuterJoin` Table @Deed
+                      `LeftOuterJoin` Table @Deed
-              `Experimental.on` (\(l :& d) -> just (l ^. LordId) ==. d ?. DeedOwnerId)
+                      `Experimental.on` (\(l :& d) -> just (l ^. LordId) ==. d ?. DeedOwnerId)
-          pure (lords, deeds)
+                  pure (lords, deeds)
+
+        ret <- select q
         liftIO $ ret `shouldMatchList` ((l3e, Nothing) : l1WithDeeds)
 
     it "lets you order by alias" $ run $ do
@@ -1078,17 +1079,6 @@ testSelectWhere run = describe "select where_" $ do
                         ( val $ PointKey 1 2
                         , val $ PointKey 5 6 )
                 liftIO $ ret `shouldBe` [()]
-            it "works when using ECompositeKey constructor" $ run $ do
-                insert_ $ Point 1 2 ""
-                ret <-
-                  select $
-                  from $ \p -> do
-                  where_ $
-                    p ^. PointId
-                      `between`
-                        ( EI.ECompositeKey $ const ["3", "4"]
-                        , EI.ECompositeKey $ const ["5", "6"] )
-                liftIO $ ret `shouldBe` []
 
     it "works with avg_" $ run $ do
         _ <- insert' p1
@@ -1851,9 +1841,10 @@ testRenderSql run = do
       (c, expr) <- run $ do
         conn <- ask
         let Right c = P.mkEscapeChar conn
+        let user = EI.unsafeSqlEntity (EI.I "user")
+            blogPost = EI.unsafeSqlEntity (EI.I "blog_post")
         pure $ (,) c $ EI.renderExpr conn $
-          EI.EEntity (EI.I "user") ^. PersonId
+          user ^. PersonId ==. blogPost ^. BlogPostAuthorId
-          ==. EI.EEntity (EI.I "blog_post") ^. BlogPostAuthorId
       expr
         `shouldBe`
           Text.intercalate (Text.singleton c) ["", "user", ".", "id", ""]
@@ -1865,23 +1856,6 @@ testRenderSql run = do
       expr <- run $ ask >>= \c -> pure $ EI.renderExpr c (val (PersonKey 0) ==. val (PersonKey 1))
       expr `shouldBe` "? = ?"
 
-  describe "EEntity Ident behavior" $ do
-      let render :: SqlExpr (Entity val) -> Text.Text
-          render (EI.EEntity (EI.I ident)) = ident
-          render _ = error "guess we gotta handle this in the test suite now"
-      it "renders sensibly" $ run $ do
-          _ <- insert $ Foo 2
-          _ <- insert $ Foo 3
-          _ <- insert $ Person "hello" Nothing Nothing 3
-          results <- select $
-              from $ \(a `LeftOuterJoin` b) -> do
-              on $ a ^. FooName ==. b ^. PersonFavNum
-              pure (val (render a), val (render b))
-          liftIO $
-              head results
-              `shouldBe`
-              (Value "Foo", Value "Person")
-
   describe "ExprParser" $ do
     let parse parser = AP.parseOnly (parser '#')
     describe "parseEscapedChars" $ do