diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -219,7 +219,7 @@ - `ON` clause is attached directly to the relevant join, so you never need to worry about how they're ordered, nor will you ever run into bugs where the `on` clause is on the wrong `JOIN` -- The `ON` clause lambda will all the available tables in it. This forbids +- The `ON` clause lambda will exclusively have all the available tables in it. This forbids runtime errors where an `ON` clause refers to a table that isn't in scope yet. - You can join on a table twice, and the aliases work out fine with the `ON` clause. diff --git a/changelog.md b/changelog.md --- a/changelog.md +++ b/changelog.md @@ -1,3 +1,10 @@ +3.5.11.0 +======== +- @9999years, @halogenandtoast + - [#378](https://github.com/bitemyapp/esqueleto/pull/378) + - `ToMaybe` instances are now derived for records so you can now left + join them in queries + 3.5.10.3 ======== - @ttuegel diff --git a/esqueleto.cabal b/esqueleto.cabal --- a/esqueleto.cabal +++ b/esqueleto.cabal @@ -2,7 +2,7 @@ name: esqueleto -version: 3.5.10.3 +version: 3.5.11.0 synopsis: Type-safe EDSL for SQL queries on persistent backends. description: @esqueleto@ is a bare bones, type-safe EDSL for SQL queries that works with unmodified @persistent@ SQL backends. Its language closely resembles SQL, so you don't have to learn new concepts, just new syntax, and it's fairly easy to predict the generated SQL and optimize it for your backend. Most kinds of errors committed when writing SQL are caught as compile-time errors---although it is possible to write type-checked @esqueleto@ queries that fail at runtime. . diff --git a/src/Database/Esqueleto/Record.hs b/src/Database/Esqueleto/Record.hs --- a/src/Database/Esqueleto/Record.hs +++ b/src/Database/Esqueleto/Record.hs @@ -1,5 +1,7 @@ {-# LANGUAGE CPP #-} +{-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE LambdaCase #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -13,6 +15,8 @@ , DeriveEsqueletoRecordSettings(..) , defaultDeriveEsqueletoRecordSettings + , takeColumns + , takeMaybeColumns ) where import Control.Monad.Trans.State.Strict (StateT(..), evalStateT) @@ -20,6 +24,7 @@ import Database.Esqueleto.Experimental (Entity, PersistValue, SqlExpr, Value(..), (:&)(..)) import Database.Esqueleto.Experimental.ToAlias (ToAlias(..)) +import Database.Esqueleto.Experimental.ToMaybe (ToMaybe(..)) import Database.Esqueleto.Experimental.ToAliasReference (ToAliasReference(..)) import Database.Esqueleto.Internal.Internal (SqlSelect(..)) import Language.Haskell.TH @@ -130,11 +135,21 @@ -- name to produce the SQL record's type name and constructor name. -- -- @since 3.5.8.0 + , sqlMaybeNameModifier :: String -> String + -- ^ Function applied to the Haskell record's type name and constructor + -- name to produce the 'ToMaybe' record's type name and constructor name. + -- + -- @since 3.5.11.0 , sqlFieldModifier :: String -> String -- ^ Function applied to the Haskell record's field names to produce the -- SQL record's field names. -- -- @since 3.5.8.0 + , sqlMaybeFieldModifier :: String -> String + -- ^ Function applied to the Haskell record's field names to produce the + -- 'ToMaybe' SQL record's field names. + -- + -- @since 3.5.11.0 } -- | The default codegen settings for 'deriveEsqueletoRecord'. @@ -148,7 +163,9 @@ defaultDeriveEsqueletoRecordSettings :: DeriveEsqueletoRecordSettings defaultDeriveEsqueletoRecordSettings = DeriveEsqueletoRecordSettings { sqlNameModifier = ("Sql" ++) + , sqlMaybeNameModifier = ("SqlMaybe" ++) , sqlFieldModifier = id + , sqlMaybeFieldModifier = id } -- | Takes the name of a Haskell record type and creates a variant of that @@ -168,11 +185,17 @@ -- instance is available in GHC 8. recordDec <- makeSqlRecord info sqlSelectInstanceDec <- makeSqlSelectInstance info + sqlMaybeRecordDec <- makeSqlMaybeRecord info + toMaybeInstanceDec <- makeToMaybeInstance info + sqlMaybeRecordSelectInstanceDec <- makeSqlMaybeRecordSelectInstance info toAliasInstanceDec <- makeToAliasInstance info toAliasReferenceInstanceDec <- makeToAliasReferenceInstance info pure [ recordDec , sqlSelectInstanceDec + , sqlMaybeRecordDec + , toMaybeInstanceDec + , sqlMaybeRecordSelectInstanceDec , toAliasInstanceDec , toAliasReferenceInstanceDec ] @@ -185,6 +208,8 @@ name :: Name , -- | The generated SQL record's name. sqlName :: Name + , -- | The generated SQL 'ToMaybe' record's name. + sqlMaybeName :: Name , -- | The original record's constraints. If this isn't empty it'll probably -- cause problems, but it's easy to pass around so might as well. constraints :: Cxt @@ -200,12 +225,17 @@ constructorName :: Name , -- | The generated SQL record's constructor name. sqlConstructorName :: Name + , -- | The generated SQL 'ToMaybe' record's constructor name. + sqlMaybeConstructorName :: Name , -- | The original record's field names and types, derived from the -- constructors. fields :: [(Name, Type)] , -- | The generated SQL record's field names and types, computed -- with 'sqlFieldType'. sqlFields :: [(Name, Type)] + , -- | The generated SQL 'ToMaybe' record's field names and types, computed + -- with 'sqlMaybeFieldType'. + sqlMaybeFields :: [(Name, Type)] } -- | Get a `RecordInfo` instance for the given record name. @@ -228,9 +258,12 @@ con -> error $ nonRecordConstructorMessage con fields = getFields constructor sqlName = makeSqlName settings name + sqlMaybeName = makeSqlMaybeName settings name sqlConstructorName = makeSqlName settings constructorName + sqlMaybeConstructorName = makeSqlMaybeName settings constructorName sqlFields <- mapM toSqlField fields + sqlMaybeFields <- mapM toSqlMaybeField fields pure RecordInfo {..} where @@ -243,10 +276,19 @@ sqlTy <- sqlFieldType ty pure (modifier fieldName', sqlTy) + toSqlMaybeField (fieldName', ty) = do + let modifier = mkName . sqlMaybeFieldModifier settings . nameBase + sqlTy <- sqlMaybeFieldType ty + pure (modifier fieldName', sqlTy) + -- | Create a new name by prefixing @Sql@ to a given name. makeSqlName :: DeriveEsqueletoRecordSettings -> Name -> Name makeSqlName settings name = mkName $ sqlNameModifier settings $ nameBase name +-- | Create a new name by prefixing @SqlMaybe@ to a given name. +makeSqlMaybeName :: DeriveEsqueletoRecordSettings -> Name -> Name +makeSqlMaybeName settings name = mkName $ sqlMaybeNameModifier settings $ nameBase name + -- | Transforms a record field type into a corresponding `SqlExpr` type. -- -- * @'Entity' x@ is transformed into @'SqlExpr' ('Entity' x)@. @@ -275,6 +317,40 @@ `AppT` ((ConT ''Value) `AppT` fieldType) +-- | Transforms a record field type into a corresponding `SqlExpr` `ToMaybe` type. +-- +-- * @'Entity' x@ is transformed into @'SqlExpr' ('Maybe' ('Entity' x))@. +-- * @'Maybe' ('Entity' x)@ is transformed into @'SqlExpr' ('Maybe' ('Maybe' ('Entity' x)))@. +-- * @x@ is transformed into @'SqlExpr' ('Value' ('Maybe' x))@. +-- * If there exists an instance @'SqlSelect' sql x@, then @x@ is transformed into @sql@. +-- +-- This function should match `sqlSelectProcessRowPat`. +sqlMaybeFieldType :: Type -> Q Type +sqlMaybeFieldType fieldType = do + maybeSqlType <- reifySqlSelectType fieldType + + pure $ maybe convertFieldType convertSqlType maybeSqlType + where + convertSqlType = ((ConT ''ToMaybeT) `AppT`) + convertFieldType = case fieldType of + -- Entity x -> SqlExpr (Entity x) -> SqlExpr (Maybe (Entity x)) + AppT (ConT ((==) ''Entity -> True)) _innerType -> + (ConT ''SqlExpr) `AppT` ((ConT ''Maybe) `AppT` fieldType) + + -- Maybe (Entity x) -> SqlExpr (Maybe (Entity x)) -> SqlExpr (Maybe (Entity x)) + (ConT ((==) ''Maybe -> True)) + `AppT` ((ConT ((==) ''Entity -> True)) + `AppT` _innerType) -> + (ConT ''SqlExpr) `AppT` fieldType + + -- Maybe x -> SqlExpr (Value (Maybe x)) -> SqlExpr (Value (Maybe x)) + inner@((ConT ((==) ''Maybe -> True)) `AppT` _inner) -> (ConT ''SqlExpr) `AppT` ((ConT ''Value) `AppT` inner) + + -- x -> SqlExpr (Value x) -> SqlExpr (Value (Maybe x)) + _ -> (ConT ''SqlExpr) + `AppT` ((ConT ''Value) + `AppT` ((ConT ''Maybe) `AppT` fieldType)) + -- | Generates the declaration for an @Sql@-prefixed record, given the original -- record's information. makeSqlRecord :: RecordInfo -> Q Dec @@ -652,3 +728,234 @@ [] ] +-- | Generates the declaration for an @SqlMaybe@-prefixed record, given the original +-- record's information. +makeSqlMaybeRecord :: RecordInfo -> Q Dec +makeSqlMaybeRecord RecordInfo {..} = do + let newConstructor = RecC sqlMaybeConstructorName (makeField `map` sqlMaybeFields) + derivingClauses = [] + pure $ DataD constraints sqlMaybeName typeVarBinders kind [newConstructor] derivingClauses + where + makeField (fieldName', fieldType) = + (fieldName', Bang NoSourceUnpackedness NoSourceStrictness, fieldType) + + +-- | Generates a `ToMaybe` instance for the given record. +makeToMaybeInstance :: RecordInfo -> Q Dec +makeToMaybeInstance info@RecordInfo {..} = do + toMaybeTDec' <- toMaybeTDec info + toMaybeDec' <- toMaybeDec info + let overlap = Nothing + instanceConstraints = [] + instanceType = (ConT ''ToMaybe) `AppT` (ConT sqlName) + + pure $ InstanceD overlap instanceConstraints instanceType [toMaybeTDec', toMaybeDec'] + +-- | Generates a `type ToMaybeT ... = ...` declaration for the given record. +toMaybeTDec :: RecordInfo -> Q Dec +toMaybeTDec RecordInfo {..} = do + pure $ mkTySynInstD ''ToMaybeT (ConT sqlName) (ConT sqlMaybeName) + where + mkTySynInstD className lhsArg rhs = +#if MIN_VERSION_template_haskell(2,15,0) + let binders = Nothing + lhs = ConT className `AppT` lhsArg + in + TySynInstD $ TySynEqn binders lhs rhs +#else + TySynInstD className $ TySynEqn [lhsArg] rhs +#endif + +-- | Generates a `toMaybe value = ...` declaration for the given record. +toMaybeDec :: RecordInfo -> Q Dec +toMaybeDec RecordInfo {..} = do + (fieldPatterns, fieldExps) <- + unzip <$> forM (zip sqlFields sqlMaybeFields) (\((fieldName', _), (maybeFieldName', _)) -> do + fieldPatternName <- newName (nameBase fieldName') + pure + ( (fieldName', VarP fieldPatternName) + , (maybeFieldName', VarE 'toMaybe `AppE` VarE fieldPatternName) + )) + + pure $ + FunD + 'toMaybe + [ Clause + [ RecP sqlName fieldPatterns + ] + (NormalB $ RecConE sqlMaybeName fieldExps) + [] + ] + +-- | Generates an `SqlSelect` instance for the given record and its +-- @Sql@-prefixed variant. +makeSqlMaybeRecordSelectInstance :: RecordInfo -> Q Dec +makeSqlMaybeRecordSelectInstance info@RecordInfo {..} = do + sqlSelectColsDec' <- sqlMaybeSelectColsDec info + sqlSelectColCountDec' <- sqlMaybeSelectColCountDec info + sqlSelectProcessRowDec' <- sqlMaybeSelectProcessRowDec info + let overlap = Nothing + instanceConstraints = [] + instanceType = + (ConT ''SqlSelect) + `AppT` (ConT sqlMaybeName) + `AppT` (AppT (ConT ''Maybe) (ConT name)) + + pure $ InstanceD overlap instanceConstraints instanceType [sqlSelectColsDec', sqlSelectColCountDec', sqlSelectProcessRowDec'] + +-- | Generates the `sqlSelectCols` declaration for an `SqlSelect` instance. +sqlMaybeSelectColsDec :: RecordInfo -> Q Dec +sqlMaybeSelectColsDec RecordInfo {..} = do + -- Pairs of record field names and local variable names. + fieldNames <- forM sqlMaybeFields (\(name', _type) -> do + var <- newName $ nameBase name' + pure (name', var)) + + -- Patterns binding record fields to local variables. + let fieldPatterns :: [FieldPat] + fieldPatterns = [(name', VarP var) | (name', var) <- fieldNames] + + -- Local variables for fields joined with `:&` in a single expression. + joinedFields :: Exp + joinedFields = + case snd `map` fieldNames of + [] -> TupE [] + [f1] -> VarE f1 + f1 : rest -> + let helper lhs field = + InfixE + (Just lhs) + (ConE '(:&)) + (Just $ VarE field) + in foldl' helper (VarE f1) rest + + identInfo <- newName "identInfo" + -- Roughly: + -- sqlSelectCols $identInfo SqlFoo{..} = sqlSelectCols $identInfo $joinedFields + pure $ + FunD + 'sqlSelectCols + [ Clause + [ VarP identInfo + , RecP sqlMaybeName fieldPatterns + ] + ( NormalB $ + (VarE 'sqlSelectCols) + `AppE` (VarE identInfo) + `AppE` (ParensE joinedFields) + ) + -- `where` clause. + [] + ] + +-- | Generates the `sqlSelectProcessRow` declaration for an `SqlSelect` +-- instance. +sqlMaybeSelectProcessRowDec :: RecordInfo -> Q Dec +sqlMaybeSelectProcessRowDec RecordInfo {..} = do + let + sqlOp x = case x of + -- AppT (ConT ((==) ''Entity -> True)) _innerType -> id + -- (ConT ((==) ''Maybe -> True)) `AppT` ((ConT ((==) ''Entity -> True)) `AppT` _innerType) -> (AppE (VarE 'pure)) + -- inner@((ConT ((==) ''Maybe -> True)) `AppT` _inner) -> (AppE (VarE 'unValue)) + (AppT (ConT ((==) ''SqlExpr -> True)) (AppT (ConT ((==) ''Value -> True)) _)) -> (AppE (VarE 'unValue)) + (AppT (ConT ((==) ''SqlExpr -> True)) (AppT (ConT ((==) ''Entity -> True)) _)) -> id + (AppT (ConT ((==) ''SqlExpr -> True)) (AppT (ConT ((==) ''Maybe -> True)) _)) -> (AppE (VarE 'pure)) + (ConT _) -> id + _ -> error $ show x + + fieldNames <- forM sqlFields (\(name', typ) -> do + var <- newName $ nameBase name' + pure (name', var, sqlOp typ (VarE var))) + + let + joinedFields = + case (\(_,x,_) -> x) `map` fieldNames of + [] -> TupP [] + [f1] -> VarP f1 + f1 : rest -> + let helper lhs field = + InfixP + lhs + '(:&) + (VarP field) + in foldl' helper (VarP f1) rest + + + colsName <- newName "columns" + + let +#if MIN_VERSION_template_haskell(2,17,0) + bodyExp = DoE Nothing +#else + bodyExp = DoE +#endif + [ BindS joinedFields (AppE (VarE 'sqlSelectProcessRow) (VarE colsName)) + , NoBindS + $ AppE (VarE 'pure) ( + case fieldNames of + [] -> ConE constructorName + (_,_,e):xs -> foldl' + (\acc (_,_,e2) -> AppE (AppE (VarE '(<*>)) acc) e2) + (AppE (AppE (VarE 'fmap) (ConE constructorName)) e) + xs + ) + ] + + pure $ + FunD + 'sqlSelectProcessRow + [ Clause + [VarP colsName] + (NormalB bodyExp) + [] + ] + +-- | Generates the `sqlSelectColCount` declaration for an `SqlSelect` instance. +sqlMaybeSelectColCountDec :: RecordInfo -> Q Dec +sqlMaybeSelectColCountDec RecordInfo {..} = do + let joinedTypes = + case snd `map` sqlMaybeFields of + [] -> TupleT 0 + t1 : rest -> + let helper lhs ty = + InfixT lhs ''(:&) ty + in foldl' helper t1 rest + + -- Roughly: + -- sqlSelectColCount _ = sqlSelectColCount (Proxy @($joinedTypes)) + pure $ + FunD + 'sqlSelectColCount + [ Clause + [WildP] + ( NormalB $ + AppE (VarE 'sqlSelectColCount) $ + ParensE $ + AppTypeE + (ConE 'Proxy) + joinedTypes + ) + -- `where` clause. + [] + ] + +-- | Statefully parse some number of columns from a list of `PersistValue`s, +-- where the number of columns to parse is determined by `sqlSelectColCount` +-- for @a@. +-- +-- This is used to implement `sqlSelectProcessRow` for records created with +-- `deriveEsqueletoRecord`. +takeMaybeColumns :: + forall a b. + (SqlSelect a (ToMaybeT b)) => + StateT [PersistValue] (Either Text) (ToMaybeT b) +takeMaybeColumns = StateT (\pvs -> + let targetColCount = + sqlSelectColCount (Proxy @a) + (target, other) = + splitAt targetColCount pvs + in if length target == targetColCount + then do + value <- sqlSelectProcessRow target + Right (value, other) + else Left "Insufficient columns when trying to parse a column") diff --git a/test/Common/Record.hs b/test/Common/Record.hs --- a/test/Common/Record.hs +++ b/test/Common/Record.hs @@ -14,20 +14,29 @@ {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} -- Tests for `Database.Esqueleto.Record`. module Common.Record (testDeriveEsqueletoRecord) where import Common.Test.Import hiding (from, on) +import Control.Monad.Trans.State.Strict (StateT(..), evalStateT) +import Data.Bifunctor (first) import Data.List (sortOn) +import Data.Maybe (catMaybes) +import Data.Proxy (Proxy(..)) import Database.Esqueleto.Experimental -import Database.Esqueleto.Record - ( DeriveEsqueletoRecordSettings(..) - , defaultDeriveEsqueletoRecordSettings - , deriveEsqueletoRecord - , deriveEsqueletoRecordWith - ) +import Database.Esqueleto.Internal.Internal (SqlSelect(..)) +import Database.Esqueleto.Record ( + DeriveEsqueletoRecordSettings(..), + defaultDeriveEsqueletoRecordSettings, + deriveEsqueletoRecord, + deriveEsqueletoRecordWith, + takeColumns, + takeMaybeColumns, + ) +import GHC.Records data MyRecord = MyRecord @@ -112,6 +121,15 @@ , myModifiedAddressSql = address } +mySubselectRecordQuery :: SqlQuery (SqlExpr (Maybe (Entity Address))) +mySubselectRecordQuery = do + _ :& record <- from $ + table @User + `leftJoin` + myRecordQuery + `on` (do \(user :& record) -> just (user ^. #id) ==. getField @"myUser" record ?. #id) + pure $ getField @"myAddress" record + testDeriveEsqueletoRecord :: SpecDb testDeriveEsqueletoRecord = describe "deriveEsqueletoRecord" $ do let setup :: MonadIO m => SqlPersistT m () @@ -208,7 +226,6 @@ } -> addr1 == addr2 -- The keys should match. _ -> False) - itDb "can select user-modified records" $ do setup records <- select myModifiedRecordQuery @@ -234,4 +251,88 @@ } , myModifiedAddress = Just (Entity addr2 Address {addressAddress = "30-50 Feral Hogs Rd"}) } -> addr1 == addr2 -- The keys should match. + _ -> False) + + itDb "can left join on records" $ do + setup + records <- select $ do + from + ( table @User + `leftJoin` myRecordQuery `on` (do \(user :& record) -> just (user ^. #id) ==. getField @"myUser" record ?. #id) + ) + let sortedRecords = sortOn (\(Entity _ user :& _) -> getField @"userName" user) records + liftIO $ sortedRecords !! 0 + `shouldSatisfy` + (\case (_ :& Just (MyRecord {myName = "Rebecca", myAddress = Nothing})) -> True + _ -> False) + liftIO $ sortedRecords !! 1 + `shouldSatisfy` + (\case ( _ :& Just ( MyRecord { myName = "Some Guy" + , myAddress = (Just (Entity addr2 Address {addressAddress = "30-50 Feral Hogs Rd"})) + } + )) -> True + _ -> True) + + itDb "can can handle joins on records with Nothing" $ do + setup + records <- select $ do + from + ( table @User + `leftJoin` myRecordQuery `on` (do \(user :& record) -> user ^. #address ==. getField @"myAddress" record ?. #id) + ) + let sortedRecords = sortOn (\(Entity _ user :& _) -> getField @"userName" user) records + liftIO $ sortedRecords !! 0 + `shouldSatisfy` + (\case (_ :& Nothing) -> True + _ -> False) + liftIO $ sortedRecords !! 1 + `shouldSatisfy` + (\case ( _ :& Just ( MyRecord { myName = "Some Guy" + , myAddress = (Just (Entity addr2 Address {addressAddress = "30-50 Feral Hogs Rd"})) + } + )) -> True + _ -> True) + + itDb "can left join on nested records" $ do + setup + records <- select $ do + from + ( table @User + `leftJoin` myNestedRecordQuery + `on` (do \(user :& record) -> just (user ^. #id) ==. getField @"myUser" (getField @"myRecord" record) ?. #id) + ) + let sortedRecords = sortOn (\(Entity _ user :& _) -> getField @"userName" user) records + liftIO $ sortedRecords !! 0 + `shouldSatisfy` + (\case (_ :& Just (MyNestedRecord {myRecord = MyRecord {myName = "Rebecca", myAddress = Nothing}})) -> True + _ -> False) + liftIO $ sortedRecords !! 1 + `shouldSatisfy` + (\case ( _ :& Just ( MyNestedRecord { myRecord = MyRecord { myName = "Some Guy" + , myAddress = (Just (Entity addr2 Address {addressAddress = "30-50 Feral Hogs Rd"})) + } + })) -> True + _ -> True) + + itDb "can handle multiple left joins on the same record" $ do + setup + records <- select $ do + from + ( table @User + `leftJoin` myNestedRecordQuery + `on` (do \(user :& record) -> just (user ^. #id) ==. getField @"myUser" (getField @"myRecord" record) ?. #id) + `leftJoin` myNestedRecordQuery + `on` (do \(user :& record1 :& record2) -> getField @"myUser" (getField @"myRecord" record1) ?. #id !=. getField @"myUser" (getField @"myRecord" record2) ?. #id) + ) + let sortedRecords = sortOn (\(Entity _ user :& _ :& _) -> getField @"userName" user) records + liftIO $ sortedRecords !! 0 + `shouldSatisfy` + (\case ( _ :& _ :& Just ( MyNestedRecord { myRecord = MyRecord { myName = "Some Guy" + , myAddress = (Just (Entity addr2 Address {addressAddress = "30-50 Feral Hogs Rd"})) + } + })) -> True + _ -> True) + liftIO $ sortedRecords !! 1 + `shouldSatisfy` + (\case (_ :& _ :& Just (MyNestedRecord {myRecord = MyRecord {myName = "Rebecca", myAddress = Nothing}})) -> True _ -> False)