diff --git a/src/Database/Esqueleto/Experimental/From.hs b/src/Database/Esqueleto/Experimental/From.hs index 085ff9d..2c0cef8 100644 --- a/src/Database/Esqueleto/Experimental/From.hs +++ b/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 diff --git a/src/Database/Esqueleto/Experimental/ToAlias.hs b/src/Database/Esqueleto/Experimental/ToAlias.hs index fdb9430..39f927a 100644 --- a/src/Database/Esqueleto/Experimental/ToAlias.hs +++ b/src/Database/Esqueleto/Experimental/ToAlias.hs @@ -1,13 +1,12 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeFamilies #-} module Database.Esqueleto.Experimental.ToAlias where -import Database.Esqueleto.Internal.Internal hiding (From, - from, on) -import Database.Esqueleto.Internal.PersistentImport +import Database.Esqueleto.Internal.Internal hiding (From, from, on) +import Database.Esqueleto.Internal.PersistentImport {-# DEPRECATED ToAliasT "This type alias doesn't do anything. Please delete it. Will be removed in the next release." #-} type ToAliasT a = a @@ -17,22 +16,26 @@ class ToAlias a where toAlias :: a -> SqlQuery a instance ToAlias (SqlExpr (Value a)) where - toAlias (ERaw m f) - | Nothing <- sqlExprMetaAlias m = do - ident <- newIdentFor (DBName "v") - pure $ ERaw noMeta{sqlExprMetaAlias = Just ident} $ \_ info -> - let (b, v) = f Never info - in (b <> " AS " <> useIdent info ident, []) + toAlias (ERaw m f) = + case sqlExprMetaAlias m of + Just _ -> pure $ ERaw m f + Nothing -> do + ident <- newIdentFor (DBName "v") + pure $ ERaw noMeta{sqlExprMetaAlias = Just ident} $ \_ info -> + let (b, v) = f Never info + in (b <> " AS " <> useIdent info ident, []) + instance ToAlias (SqlExpr (Entity a)) where - toAlias v@(EAliasedEntityReference _ _) = pure v - toAlias v@(EAliasedEntity _ _) = pure v - toAlias (EEntity tableIdent) = do + toAlias (ERaw m f) = 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 diff --git a/src/Database/Esqueleto/Experimental/ToAliasReference.hs b/src/Database/Esqueleto/Experimental/ToAliasReference.hs index 568758c..f39a37d 100644 --- a/src/Database/Esqueleto/Experimental/ToAliasReference.hs +++ b/src/Database/Esqueleto/Experimental/ToAliasReference.hs @@ -1,14 +1,13 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeFamilies #-} module Database.Esqueleto.Experimental.ToAliasReference where -import Database.Esqueleto.Experimental.ToAlias -import Database.Esqueleto.Internal.Internal hiding (From, - from, on) -import Database.Esqueleto.Internal.PersistentImport +import Database.Esqueleto.Experimental.ToAlias +import Database.Esqueleto.Internal.Internal hiding (From, from, on) +import Database.Esqueleto.Internal.PersistentImport {-# DEPRECATED ToAliasReferenceT "This type alias doesn't do anything. Please delete it. Will be removed in the next release." #-} type ToAliasReferenceT a = a @@ -19,16 +18,24 @@ class ToAliasReference a where instance ToAliasReference (SqlExpr (Value a)) where toAliasReference aliasSource (ERaw m _) - | Just alias <- sqlExprMetaAlias m = pure $ ERaw noMeta $ \p info -> + | Just alias <- sqlExprMetaAlias m = pure $ ERaw m $ \_ info -> (useIdent info aliasSource <> "." <> useIdent info alias, []) + toAliasReference _ e = pure e instance ToAliasReference (SqlExpr (Entity a)) where - toAliasReference aliasSource (EAliasedEntity ident _) = pure $ EAliasedEntityReference aliasSource ident - toAliasReference _ e@(EEntity _) = toAlias e - toAliasReference s (EAliasedEntityReference _ b) = pure $ EAliasedEntityReference s b + toAliasReference aliasSource (ERaw m _) + | Just _ <- sqlExprMetaAlias m, False <- sqlExprMetaIsReference m = + 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 + -- FIXME: Code duplication because the compiler doesnt like half final encoding + toAliasReference aliasSource (ERaw m f) + | Just _ <- sqlExprMetaAlias m, False <- sqlExprMetaIsReference m = + pure $ ERaw m{sqlExprMetaIsReference = True} $ \_ info -> + (useIdent info aliasSource, []) + toAliasReference s e = pure e instance (ToAliasReference a, ToAliasReference b) => ToAliasReference (a, b) where diff --git a/src/Database/Esqueleto/Experimental/ToMaybe.hs b/src/Database/Esqueleto/Experimental/ToMaybe.hs index cc1a0f8..0677bfb 100644 --- a/src/Database/Esqueleto/Experimental/ToMaybe.hs +++ b/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))) diff --git a/src/Database/Esqueleto/Internal/Internal.hs b/src/Database/Esqueleto/Internal/Internal.hs index 8460c73..52127c7 100644 --- a/src/Database/Esqueleto/Internal/Internal.hs +++ b/src/Database/Esqueleto/Internal/Internal.hs @@ -88,7 +88,7 @@ fromStart fromStart = do let ed = entityDef (Proxy :: Proxy a) ident <- newIdentFor (entityDB ed) - let ret = EEntity ident + let ret = unsafeSqlEntity ident f' = FromStart ident ed return (EPreprocessedFrom ret f') @@ -103,7 +103,7 @@ fromStartMaybe = maybelize <$> fromStart maybelize :: SqlExpr (PreprocessedFrom (SqlExpr (Entity a))) -> SqlExpr (PreprocessedFrom (SqlExpr (Maybe (Entity a)))) - maybelize (EPreprocessedFrom ret f') = EPreprocessedFrom (EMaybe ret) f' + maybelize (EPreprocessedFrom (ERaw m f) f') = EPreprocessedFrom (ERaw m f) f' -- | (Internal) Do a @JOIN@. fromJoin @@ -527,9 +527,12 @@ subSelectUnsafe = sub SELECT => SqlExpr (Entity val) -> EntityField val typ -> SqlExpr (Value typ) -(EAliasedEntityReference source base) ^. field = - ERaw noMeta $ \_ info -> - (useIdent info source <> "." <> useIdent info (aliasedEntityColumnIdent base fieldDef), []) +e ^. field + | isIdField field = idFieldValue + | ERaw m f <- e, Just alias <- sqlExprMetaAlias m = + ERaw noMeta $ \_ info -> + f Never info <> ("." <> useIdent info (aliasedEntityColumnIdent alias fieldDef), []) + | otherwise = ERaw noMeta $ \_ info -> (dot info $ persistFieldDef field, []) where fieldDef = if isIdField field then @@ -537,13 +540,6 @@ subSelectUnsafe = sub SELECT head $ entityKeyFields ed else persistFieldDef field - - ed = entityDef $ getEntityVal (Proxy :: Proxy (SqlExpr (Entity val))) - -e ^. field - | isIdField field = idFieldValue - | otherwise = ERaw noMeta $ \_ info -> (dot info $ persistFieldDef field, []) - where idFieldValue = case entityKeyFields ed of idField:[] -> @@ -558,29 +554,19 @@ e ^. field ed = entityDef $ getEntityVal (Proxy :: Proxy (SqlExpr (Entity val))) dot info fieldDef = - useIdent info sourceIdent <> "." <> fieldIdent + sourceIdent info <> "." <> fieldIdent where sourceIdent = case e of - EEntity ident -> ident - EAliasedEntity baseI _ -> baseI - EAliasedEntityReference a b -> - error $ unwords - [ "Used (^.) with an EAliasedEntityReference." - , "Please file this as an Esqueleto bug." - , "EAliasedEntityReference", show a, show b - ] + ERaw _ f -> fmap fst $ f Never fieldIdent = case e of - EEntity _ -> fromDBName info (fieldDB fieldDef) - EAliasedEntity baseI _ -> useIdent info $ aliasedEntityColumnIdent baseI fieldDef - EAliasedEntityReference a b -> - error $ unwords - [ "Used (^.) with an EAliasedEntityReference." - , "Please file this as an Esqueleto bug." - , "EAliasedEntityReference", show a, show b - ] - + ERaw m f -> + case sqlExprMetaAlias m of + Just baseI -> + useIdent info $ aliasedEntityColumnIdent baseI fieldDef + Nothing -> + fromDBName info (fieldDB fieldDef) -- | Project an SqlExpression that may be null, guarding against null cases. withNonNull @@ -598,7 +584,7 @@ withNonNull field f = do => SqlExpr (Maybe (Entity val)) -> EntityField val typ -> SqlExpr (Value (Maybe typ)) -EMaybe r ?. field = just (r ^. field) +ERaw m f ?. field = just (ERaw m f ^. field) -- | Lift a constant value from Haskell-land to the query. val :: PersistField typ => typ -> SqlExpr (Value typ) @@ -2012,12 +1998,14 @@ useIdent info (I ident) = fromDBName info $ DBName ident data SqlExprMeta = SqlExprMeta { sqlExprMetaCompositeFields :: Maybe (IdentInfo -> [TLB.Builder]) , sqlExprMetaAlias :: Maybe Ident + , sqlExprMetaIsReference :: Bool } noMeta :: SqlExprMeta noMeta = SqlExprMeta { sqlExprMetaCompositeFields = Nothing , sqlExprMetaAlias = Nothing + , sqlExprMetaIsReference = False } hasCompositeKeyMeta :: SqlExprMeta -> Bool @@ -2028,16 +2016,6 @@ hasCompositeKeyMeta = Maybe.isJust . sqlExprMetaCompositeFields -- There are many comments describing the constructors of this -- data type. However, Haddock doesn't like GADTs, so you'll have to read them by hitting \"Source\". data SqlExpr a where - -- An entity, created by 'from' (cf. 'fromStart'). - EEntity :: Ident -> SqlExpr (Entity val) - -- Base Table - EAliasedEntity :: Ident -> Ident -> SqlExpr (Entity val) - -- Source Base - EAliasedEntityReference :: Ident -> Ident -> SqlExpr (Entity val) - - -- Just a tag stating that something is nullable. - EMaybe :: SqlExpr a -> SqlExpr (Maybe a) - -- Raw expression: states whether parenthesis are needed -- around this expression, and takes information about the SQL -- connection (mainly for escaping names) and returns both an @@ -2270,6 +2248,10 @@ unsafeSqlValue :: TLB.Builder -> SqlExpr (Value a) unsafeSqlValue v = ERaw noMeta $ \_ _ -> (v, mempty) {-# INLINE unsafeSqlValue #-} +unsafeSqlEntity :: PersistEntity ent => Ident -> SqlExpr (Entity ent) +unsafeSqlEntity ident = ERaw noMeta $ \_ info -> + (useIdent info ident, []) + valueToFunctionArg :: IdentInfo -> SqlExpr (Value a) -> (TLB.Builder, [PersistValue]) valueToFunctionArg info v = case v of @@ -3035,37 +3017,36 @@ unescapedColumnNames ent = -- | You may return an 'Entity' from a 'select' query. instance PersistEntity a => SqlSelect (SqlExpr (Entity a)) (Entity a) where - sqlSelectCols info expr@(EEntity ident) = ret - where - process ed = uncommas $ - map ((name <>) . TLB.fromText) $ - entityColumnNames ed (fst info) - -- 'name' is the biggest difference between 'RawSql' and - -- 'SqlSelect'. We automatically create names for tables - -- (since it's not the user who's writing the FROM - -- clause), while 'rawSql' assumes that it's just the - -- name of the table (which doesn't allow self-joins, for - -- example). - name = useIdent info ident <> "." - ret = let ed = entityDef $ getEntityVal $ return expr - in (process ed, mempty) - sqlSelectCols info expr@(EAliasedEntity aliasIdent tableIdent) = ret - where - process ed = uncommas $ - map ((name <>) . aliasName) $ - unescapedColumnNames ed - aliasName columnName = (fromDBName info columnName) <> " AS " <> aliasedColumnName aliasIdent info (unDBName columnName) - name = useIdent info tableIdent <> "." - ret = let ed = entityDef $ getEntityVal $ return expr - in (process ed, mempty) - sqlSelectCols info expr@(EAliasedEntityReference sourceIdent baseIdent) = ret - where - process ed = uncommas $ - map ((name <>) . aliasedColumnName baseIdent info . unDBName) $ - unescapedColumnNames ed - name = useIdent info sourceIdent <> "." - ret = let ed = entityDef $ getEntityVal $ return expr - in (process ed, mempty) + sqlSelectCols info expr@(ERaw m f) + | Just baseIdent <- sqlExprMetaAlias m, False <- sqlExprMetaIsReference m = + let process ed = uncommas $ + map ((name <>) . aliasName) $ + unescapedColumnNames ed + aliasName columnName = (fromDBName info columnName) <> " AS " <> aliasedColumnName baseIdent info (unDBName columnName) + name = fst (f Never info) <> "." + ed = entityDef $ getEntityVal $ return expr + in (process ed, mempty) + | Just baseIdent <- sqlExprMetaAlias m, True <- sqlExprMetaIsReference m = + let process ed = uncommas $ + map ((name <>) . aliasedColumnName baseIdent info . unDBName) $ + unescapedColumnNames ed + name = fst (f Never info) <> "." + ed = entityDef $ getEntityVal $ return expr + in (process ed, mempty) + | otherwise = + let process ed = uncommas $ + map ((name <>) . TLB.fromText) $ + entityColumnNames ed (fst info) + -- 'name' is the biggest difference between 'RawSql' and + -- 'SqlSelect'. We automatically create names for tables + -- (since it's not the user who's writing the FROM + -- clause), while 'rawSql' assumes that it's just the + -- name of the table (which doesn't allow self-joins, for + -- example). + name = fst (f Never info) <> "." + ed = entityDef $ getEntityVal $ return expr + in (process ed, mempty) + sqlSelectColCount = entityColumnCount . entityDef . getEntityVal sqlSelectProcessRow = parseEntityValues ed where @@ -3076,7 +3057,7 @@ getEntityVal = const Proxy -- | You may return a possibly-@NULL@ 'Entity' from a 'select' query. instance PersistEntity a => SqlSelect (SqlExpr (Maybe (Entity a))) (Maybe (Entity a)) where - sqlSelectCols info (EMaybe ent) = sqlSelectCols info ent + sqlSelectCols info (ERaw m f) = sqlSelectCols info (ERaw m f :: SqlExpr (Entity a)) sqlSelectColCount = sqlSelectColCount . fromEMaybe where fromEMaybe :: Proxy (SqlExpr (Maybe e)) -> Proxy (SqlExpr e) diff --git a/src/Database/Esqueleto/Internal/Sql.hs b/src/Database/Esqueleto/Internal/Sql.hs index 39e895b..2af0009 100644 --- a/src/Database/Esqueleto/Internal/Sql.hs +++ b/src/Database/Esqueleto/Internal/Sql.hs @@ -1,18 +1,18 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE EmptyDataDecls #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE EmptyDataDecls #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FunctionalDependencies #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE InstanceSigs #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE Rank2Types #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} -- | This is an internal module, anything exported by this module @@ -38,6 +38,7 @@ module Database.Esqueleto.Internal.Sql , unsafeSqlCase , unsafeSqlBinOp , unsafeSqlValue + , unsafeSqlEntity , unsafeSqlCastAs , unsafeSqlFunction , unsafeSqlExtractSubField @@ -74,4 +75,4 @@ module Database.Esqueleto.Internal.Sql , associateJoin ) where -import Database.Esqueleto.Internal.Internal +import Database.Esqueleto.Internal.Internal diff --git a/src/Database/Esqueleto/PostgreSQL.hs b/src/Database/Esqueleto/PostgreSQL.hs index 7262dce..01847e6 100644 --- a/src/Database/Esqueleto/PostgreSQL.hs +++ b/src/Database/Esqueleto/PostgreSQL.hs @@ -1,8 +1,8 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE Rank2Types #-} {-# LANGUAGE ScopedTypeVariables #-} -- | This module contain PostgreSQL-specific functions. @@ -31,23 +31,22 @@ module Database.Esqueleto.PostgreSQL ) where #if __GLASGOW_HASKELL__ < 804 -import Data.Semigroup +import Data.Semigroup #endif -import Control.Arrow (first, (***)) -import Control.Exception (throw) -import Control.Monad (void) -import Control.Monad.IO.Class (MonadIO (..)) -import qualified Control.Monad.Trans.Reader as R -import Data.Int (Int64) -import Data.List.NonEmpty (NonEmpty ((:|))) -import qualified Data.List.NonEmpty as NonEmpty -import Data.Proxy (Proxy (..)) -import qualified Data.Text.Internal.Builder as TLB -import Data.Time.Clock (UTCTime) -import Database.Esqueleto.Internal.Internal hiding (random_) -import Database.Esqueleto.Internal.PersistentImport hiding (upsert, - upsertBy) -import Database.Persist.Class (OnlyOneUniqueKey) +import Control.Arrow (first, (***)) +import Control.Exception (throw) +import Control.Monad (void) +import Control.Monad.IO.Class (MonadIO(..)) +import qualified Control.Monad.Trans.Reader as R +import Data.Int (Int64) +import Data.List.NonEmpty (NonEmpty((:|))) +import qualified Data.List.NonEmpty as NonEmpty +import Data.Proxy (Proxy(..)) +import qualified Data.Text.Internal.Builder as TLB +import Data.Time.Clock (UTCTime) +import Database.Esqueleto.Internal.Internal hiding (random_) +import Database.Esqueleto.Internal.PersistentImport hiding (upsert, upsertBy) +import Database.Persist.Class (OnlyOneUniqueKey) -- | (@random()@) Split out into database specific modules -- because MySQL uses `rand()`. @@ -306,9 +305,9 @@ insertSelectWithConflictCount unique query conflictQuery = do 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]) diff --git a/test/Common/Test.hs b/test/Common/Test.hs index 45fb92a..4f1fb4b 100644 --- a/test/Common/Test.hs +++ b/test/Common/Test.hs @@ -1,25 +1,25 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE EmptyDataDecls #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE EmptyDataDecls #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE PartialTypeSignatures #-} -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE Rank2Types #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeSynonymInstances #-} -{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PartialTypeSignatures #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -fno-warn-unused-binds #-} {-# OPTIONS_GHC -fno-warn-deprecations #-} @@ -62,41 +62,37 @@ module Common.Test , Key(..) ) where -import Control.Monad (forM_, replicateM, - replicateM_, void) -import Control.Monad.Catch (MonadCatch) -import Control.Monad.Reader (ask) -import Data.Either -import Data.Time +import Control.Monad (forM_, replicateM, replicateM_, void) +import Control.Monad.Catch (MonadCatch) +import Control.Monad.Reader (ask) +import Data.Either +import Data.Time #if __GLASGOW_HASKELL__ >= 806 -import Control.Monad.Fail (MonadFail) +import Control.Monad.Fail (MonadFail) #endif -import Control.Monad.IO.Class (MonadIO (liftIO)) -import Control.Monad.Logger (MonadLogger (..), - NoLoggingT, - runNoLoggingT) -import Control.Monad.Trans.Reader (ReaderT) -import qualified Data.Attoparsec.Text as AP -import Data.Char (toLower, toUpper) -import Data.Monoid ((<>)) -import Database.Esqueleto -import Database.Esqueleto.Experimental hiding (from, on) -import qualified Database.Esqueleto.Experimental as Experimental -import Database.Persist.TH -import Test.Hspec -import UnliftIO +import Control.Monad.IO.Class (MonadIO(liftIO)) +import Control.Monad.Logger (MonadLogger(..), NoLoggingT, runNoLoggingT) +import Control.Monad.Trans.Reader (ReaderT) +import qualified Data.Attoparsec.Text as AP +import Data.Char (toLower, toUpper) +import Data.Monoid ((<>)) +import Database.Esqueleto +import Database.Esqueleto.Experimental hiding (from, on) +import qualified Database.Esqueleto.Experimental as Experimental +import Database.Persist.TH +import Test.Hspec +import UnliftIO -import Data.Conduit (ConduitT, runConduit, - (.|)) -import qualified Data.Conduit.List as CL -import qualified Data.List as L -import qualified Data.Set as S -import qualified Data.Text as Text -import qualified Data.Text.Internal.Lazy as TL -import qualified Data.Text.Lazy.Builder as TLB +import Data.Conduit (ConduitT, runConduit, (.|)) +import qualified Data.Conduit.List as CL +import qualified Data.List as L +import qualified Data.Set as S +import qualified Data.Text as Text +import qualified Data.Text.Internal.Lazy as TL +import qualified Data.Text.Lazy.Builder as TLB import qualified Database.Esqueleto.Internal.ExprParser as P -import qualified Database.Esqueleto.Internal.Sql as EI -import qualified UnliftIO.Resource as R +import qualified Database.Esqueleto.Internal.Sql as EI +import qualified UnliftIO.Resource as R -- Test schema share [mkPersist sqlSettings, mkMigrate "migrateAll"] [persistUpperCase| @@ -390,7 +386,6 @@ testSubSelect run = do describe "subSelectList" $ do it "is safe on empty databases as well as good databases" $ run $ do - liftIO $ putStrLn "hello" let query = from $ \n -> do where_ $ n ^. NumbersInt `in_` do @@ -399,10 +394,7 @@ testSubSelect run = do where_ $ n' ^. NumbersInt >=. val 3 pure (n' ^. NumbersInt) pure n - empty <- do - liftIO . print =<< renderQuerySelect query - select query - liftIO $ putStrLn "goodbye" + empty <- select query full <- do setup @@ -895,12 +887,15 @@ 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 - (lords :& deeds) <- - Experimental.from $ Table @Lord - `LeftOuterJoin` Table @Deed - `Experimental.on` (\(l :& d) -> just (l ^. LordId) ==. d ?. DeedOwnerId) - pure (lords, deeds) + let q = Experimental.from $ do + (lords :& deeds) <- + Experimental.from $ Table @Lord + `LeftOuterJoin` Table @Deed + `Experimental.on` (\(l :& d) -> just (l ^. LordId) ==. d ?. DeedOwnerId) + pure (lords, deeds) + + liftIO . print =<< renderQuerySelect q + ret <- select q liftIO $ ret `shouldMatchList` ((l3e, Nothing) : l1WithDeeds) it "lets you order by alias" $ run $ do @@ -1847,9 +1842,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 - ==. EI.EEntity (EI.I "blog_post") ^. BlogPostAuthorId + user ^. PersonId ==. blogPost ^. BlogPostAuthorId expr `shouldBe` Text.intercalate (Text.singleton c) ["", "user", ".", "id", ""] @@ -1861,23 +1857,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