diff --git a/changelog.md b/changelog.md --- a/changelog.md +++ b/changelog.md @@ -1,3 +1,10 @@ +3.5.12.0 +======== +- @csamak + - [#405](https://github.com/bitemyapp/esqueleto/pull/405) + - `ToMaybe` instances are now derived for Maybe records. + See [Issue #401](https://github.com/bitemyapp/esqueleto/issues/401). + 3.5.11.2 ======== - @arguri diff --git a/esqueleto.cabal b/esqueleto.cabal --- a/esqueleto.cabal +++ b/esqueleto.cabal @@ -2,7 +2,7 @@ name: esqueleto -version: 3.5.11.2 +version: 3.5.12.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 @@ -34,7 +34,7 @@ import Control.Monad (forM) import Data.Foldable (foldl') import GHC.Exts (IsString(fromString)) -import Data.Maybe (mapMaybe, fromMaybe, listToMaybe) +import Data.Maybe (mapMaybe, fromMaybe, listToMaybe, isJust) -- | Takes the name of a Haskell record type and creates a variant of that -- record prefixed with @Sql@ which can be used in esqueleto expressions. This @@ -187,17 +187,23 @@ sqlSelectInstanceDec <- makeSqlSelectInstance info sqlMaybeRecordDec <- makeSqlMaybeRecord info toMaybeInstanceDec <- makeToMaybeInstance info + sqlMaybeToMaybeInstanceDec <- makeSqlMaybeToMaybeInstance info sqlMaybeRecordSelectInstanceDec <- makeSqlMaybeRecordSelectInstance info toAliasInstanceDec <- makeToAliasInstance info + sqlMaybeToAliasInstanceDec <- makeSqlMaybeToAliasInstance info toAliasReferenceInstanceDec <- makeToAliasReferenceInstance info + sqlMaybeToAliasReferenceInstanceDec <- makeSqlMaybeToAliasReferenceInstance info pure [ recordDec , sqlSelectInstanceDec , sqlMaybeRecordDec , toMaybeInstanceDec + , sqlMaybeToMaybeInstanceDec , sqlMaybeRecordSelectInstanceDec , toAliasInstanceDec + , sqlMaybeToAliasInstanceDec , toAliasReferenceInstanceDec + , sqlMaybeToAliasReferenceInstanceDec ] -- | Information about a record we need to generate the declarations. @@ -646,19 +652,23 @@ (RecGadtC names _fields _ret) -> head names makeToAliasInstance :: RecordInfo -> Q Dec -makeToAliasInstance info@RecordInfo {..} = do - toAliasDec' <- toAliasDec info +makeToAliasInstance RecordInfo {..} = makeToAliasInstanceFor sqlName sqlFields + +makeSqlMaybeToAliasInstance :: RecordInfo -> Q Dec +makeSqlMaybeToAliasInstance RecordInfo {..} = makeToAliasInstanceFor sqlMaybeName sqlMaybeFields + +makeToAliasInstanceFor :: Name -> [(Name, Type)] -> Q Dec +makeToAliasInstanceFor name fields = do + toAliasDec' <- toAliasDec name fields let overlap = Nothing instanceConstraints = [] - instanceType = - (ConT ''ToAlias) - `AppT` (ConT sqlName) + instanceType = (ConT ''ToAlias) `AppT` (ConT name) pure $ InstanceD overlap instanceConstraints instanceType [toAliasDec'] -toAliasDec :: RecordInfo -> Q Dec -toAliasDec RecordInfo {..} = do +toAliasDec :: Name -> [(Name, Type)] -> Q Dec +toAliasDec name fields = do (statements, fieldPatterns, fieldExps) <- - unzip3 <$> forM sqlFields (\(fieldName', _) -> do + unzip3 <$> forM fields (\(fieldName', _) -> do fieldPatternName <- newName (nameBase fieldName') boundValueName <- newName (nameBase fieldName') pure @@ -673,35 +683,40 @@ FunD 'toAlias [ Clause - [ RecP sqlName fieldPatterns + [ RecP name fieldPatterns ] ( NormalB $ DoE #if MIN_VERSION_template_haskell(2,17,0) Nothing #endif - (statements ++ [NoBindS $ AppE (VarE 'pure) (RecConE sqlName fieldExps)]) + (statements ++ [NoBindS $ AppE (VarE 'pure) (RecConE name fieldExps)]) ) -- `where` clause. [] ] makeToAliasReferenceInstance :: RecordInfo -> Q Dec -makeToAliasReferenceInstance info@RecordInfo {..} = do - toAliasReferenceDec' <- toAliasReferenceDec info +makeToAliasReferenceInstance RecordInfo {..} = makeToAliasReferenceInstanceFor sqlName sqlFields + +makeSqlMaybeToAliasReferenceInstance :: RecordInfo -> Q Dec +makeSqlMaybeToAliasReferenceInstance RecordInfo {..} = + makeToAliasReferenceInstanceFor sqlMaybeName sqlMaybeFields + +makeToAliasReferenceInstanceFor :: Name -> [(Name, Type)] -> Q Dec +makeToAliasReferenceInstanceFor name fields = do + toAliasReferenceDec' <- toAliasReferenceDec name fields let overlap = Nothing instanceConstraints = [] - instanceType = - (ConT ''ToAliasReference) - `AppT` (ConT sqlName) + instanceType = (ConT ''ToAliasReference) `AppT` (ConT name) pure $ InstanceD overlap instanceConstraints instanceType [toAliasReferenceDec'] -toAliasReferenceDec :: RecordInfo -> Q Dec -toAliasReferenceDec RecordInfo {..} = do +toAliasReferenceDec :: Name -> [(Name, Type)] -> Q Dec +toAliasReferenceDec name fields = do identInfo <- newName "identInfo" (statements, fieldPatterns, fieldExps) <- - unzip3 <$> forM sqlFields (\(fieldName', _) -> do + unzip3 <$> forM fields (\(fieldName', _) -> do fieldPatternName <- newName (nameBase fieldName') boundValueName <- newName (nameBase fieldName') pure @@ -717,14 +732,14 @@ 'toAliasReference [ Clause [ VarP identInfo - , RecP sqlName fieldPatterns + , RecP name fieldPatterns ] ( NormalB $ DoE #if MIN_VERSION_template_haskell(2,17,0) Nothing #endif - (statements ++ [NoBindS $ AppE (VarE 'pure) (RecConE sqlName fieldExps)]) + (statements ++ [NoBindS $ AppE (VarE 'pure) (RecConE name fieldExps)]) ) -- `where` clause. [] @@ -745,7 +760,7 @@ -- | Generates a `ToMaybe` instance for the given record. makeToMaybeInstance :: RecordInfo -> Q Dec makeToMaybeInstance info@RecordInfo {..} = do - toMaybeTDec' <- toMaybeTDec info + toMaybeTDec' <- toMaybeTDec sqlName sqlMaybeName toMaybeDec' <- toMaybeDec info let overlap = Nothing instanceConstraints = [] @@ -753,10 +768,20 @@ 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) +-- | Generates a `ToMaybe` instance for the SqlMaybe of the given record. +makeSqlMaybeToMaybeInstance :: RecordInfo -> Q Dec +makeSqlMaybeToMaybeInstance RecordInfo {..} = do + sqlMaybeToMaybeTDec' <- toMaybeTDec sqlMaybeName sqlMaybeName + let toMaybeIdDec = FunD 'toMaybe [ Clause [] (NormalB (VarE 'id)) []] + overlap = Nothing + instanceConstraints = [] + instanceType = (ConT ''ToMaybe) `AppT` (ConT sqlMaybeName) + pure $ InstanceD overlap instanceConstraints instanceType [sqlMaybeToMaybeTDec', toMaybeIdDec] + +-- | Generates a `type ToMaybeT ... = ...` declaration for the given names. +toMaybeTDec :: Name -> Name -> Q Dec +toMaybeTDec nameLeft nameRight = do + pure $ mkTySynInstD ''ToMaybeT (ConT nameLeft) (ConT nameRight) where mkTySynInstD className lhsArg rhs = #if MIN_VERSION_template_haskell(2,15,0) @@ -851,57 +876,28 @@ ] -- | Generates the `sqlSelectProcessRow` declaration for an `SqlSelect` --- instance. +-- instance for a SqlMaybe. 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 - + -- See sqlSelectProcessRowDec, which is similar but does not have special handling for Maybe + (statements, fieldExps) <- + unzip <$> forM (zip fields sqlMaybeFields) (\((fieldName', fieldType), (_, sqlType')) -> do + valueName <- newName (nameBase fieldName') + pattern <- sqlSelectProcessRowPat fieldType valueName + pure + ( BindS + pattern + (AppTypeE (VarE 'takeColumns) sqlType') + , (valueName, wrapJust fieldType $ VarE valueName) + )) colsName <- newName "columns" + processName <- newName "process" - 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 - ) - ] + bodyExp <- [e| + first (fromString ("Failed to parse " ++ $(lift $ nameBase sqlMaybeName) ++ ": ") <>) + (evalStateT $(varE processName) $(varE colsName)) + |] pure $ FunD @@ -909,8 +905,40 @@ [ Clause [VarP colsName] (NormalB bodyExp) - [] + -- `where` + [ ValD + (VarP processName) + (NormalB $ + DoE +#if MIN_VERSION_template_haskell(2,17,0) + Nothing +#endif + (statements ++ [ + NoBindS $ AppE (VarE 'pure) ( + CondE + (AppE + (VarE 'or) + (ListE $ fmap (\(n, _) -> AppE (VarE 'isJust) (VarE n)) fieldExps)) + (case snd <$> fieldExps of + [] -> ConE constructorName + x:xs -> foldl' + (\a b -> InfixE (Just a) (VarE '(<*>)) (Just b)) + (InfixE (Just $ ConE constructorName) (VarE '(<$>)) (Just x)) + xs) + (ConE 'Nothing) + ) + ] + ) + ) + [] + ] ] + where + wrapJust x = case x of + AppT (ConT ((==) ''Entity -> True)) _innerType -> id + ((ConT ((==) ''Maybe -> True)) `AppT` _inner) -> AppE (ConE 'Just) + (ConT _) -> id + _ -> error $ show x -- | Generates the `sqlSelectColCount` declaration for an `SqlSelect` instance. sqlMaybeSelectColCountDec :: RecordInfo -> Q Dec diff --git a/test/Common/Record.hs b/test/Common/Record.hs --- a/test/Common/Record.hs +++ b/test/Common/Record.hs @@ -21,21 +21,14 @@ 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.Internal.Internal (SqlSelect(..)) -import Database.Esqueleto.Record ( - DeriveEsqueletoRecordSettings(..), - defaultDeriveEsqueletoRecordSettings, - deriveEsqueletoRecord, - deriveEsqueletoRecordWith, - takeColumns, - takeMaybeColumns, - ) +import Database.Esqueleto.Record + ( DeriveEsqueletoRecordSettings(..) + , defaultDeriveEsqueletoRecordSettings + , deriveEsqueletoRecord + , deriveEsqueletoRecordWith + ) import GHC.Records data MyRecord = @@ -67,10 +60,16 @@ data MyNestedRecord = MyNestedRecord { myName :: Text , myRecord :: MyRecord + , myMaybeRecord :: Maybe MyRecord } deriving (Show, Eq) +data MyNestedMaybeRecord = MyNestedMaybeRecord + {myNestedRecord :: Maybe MyRecord} + deriving (Show, Eq) + $(deriveEsqueletoRecord ''MyNestedRecord) +$(deriveEsqueletoRecord ''MyNestedMaybeRecord) myNestedRecordQuery :: SqlQuery SqlMyNestedRecord myNestedRecordQuery = do @@ -89,8 +88,34 @@ , myUser = user , myAddress = address } + , myMaybeRecord = + SqlMaybeMyRecord + { myName = castString $ user ^. #name + , myAge = val $ Just 10 + , myUser = toMaybe user + , myAddress = address + } } +myNestedMaybeRecordQuery :: SqlQuery SqlMyNestedMaybeRecord +myNestedMaybeRecordQuery = do + user :& address <- + from $ + table @User + `leftJoin` table @Address + `on` (do \(user :& address) -> user ^. #address ==. address ?. #id) + pure + SqlMyNestedMaybeRecord + { + myNestedRecord = + SqlMaybeMyRecord + { myName = castString $ user ^. #name + , myAge = val $ Just 10 + , myUser = toMaybe user + , myAddress = address + } + } + data MyModifiedRecord = MyModifiedRecord { myModifiedName :: Text @@ -198,6 +223,107 @@ } -> addr1 == addr2 -- The keys should match. _ -> False) + itDb "can select nested maybe records" $ do + setup + records <- select myNestedMaybeRecordQuery + let sortedRecords = sortOn (\MyNestedMaybeRecord {myNestedRecord} -> case myNestedRecord of + Just r -> getField @"myName" r + Nothing -> "No name" + ) records + liftIO $ sortedRecords !! 0 + `shouldSatisfy` + (\case MyNestedMaybeRecord + { + myNestedRecord = Just + MyRecord { myName = "Rebecca" + , myAge = Just 10 + , myUser = Entity _ User { userAddress = Nothing + , userName = "Rebecca" + } + , myAddress = Nothing + } + } -> True + _ -> False) + + liftIO $ sortedRecords !! 1 + `shouldSatisfy` + (\case MyNestedMaybeRecord + { + myNestedRecord = Just + MyRecord { myName = "Some Guy" + , myAge = Just 10 + , myUser = Entity _ User { userAddress = Just addr1 + , userName = "Some Guy" + } + , myAddress = Just (Entity addr2 Address {addressAddress = "30-50 Feral Hogs Rd"}) + } + } -> addr1 == addr2 -- The keys should match. + _ -> False) + + itDb "can select nested nothing records" $ do + setup + records <- select $ do + user :& address <- + from $ table @User `leftJoin` table @Address `on` (do \(_ :& _) -> val False) + pure + SqlMyNestedMaybeRecord + { + myNestedRecord = + SqlMaybeMyRecord + { myName = val Nothing + , myAge = val Nothing + , myUser = toMaybe user + , myAddress = address + } + } + liftIO $ records `shouldBe` + [MyNestedMaybeRecord { myNestedRecord = Nothing }, MyNestedMaybeRecord { myNestedRecord = Nothing}] + + itDb "can left join on nested maybed records" $ do + setup + records <- select $ do + from + ( table @User + `leftJoin` myNestedMaybeRecordQuery + `on` (do \(user :& record) -> just (user ^. #id) ==. getField @"myUser" (getField @"myNestedRecord" record) ?. #id) + ) + let sortedRecords = sortOn (\(Entity _ user :& _) -> getField @"userName" user) records + liftIO $ sortedRecords !! 0 + `shouldSatisfy` + (\case (_ :& Just (MyNestedMaybeRecord + { + myNestedRecord = Just + MyRecord { myName = "Rebecca", + myAddress = Nothing + } + } + )) -> True + _ -> False) + liftIO $ sortedRecords !! 1 + `shouldSatisfy` + (\case ( _ :& Just (MyNestedMaybeRecord + { myNestedRecord = Just + MyRecord { myName = "Some Guy" + , myAddress = (Just (Entity _ Address {addressAddress = "30-50 Feral Hogs Rd"})) + } + } + )) -> True + _ -> False) + + itDb "can left join on nothing nested records" $ do + setup + records <- select $ do + from (table @User `leftJoin` myNestedMaybeRecordQuery `on` (do \(_ :& _) -> val False)) + let sortedRecords = sortOn (\(Entity _ user :& _) -> getField @"userName" user) records + liftIO $ sortedRecords !! 0 + `shouldSatisfy` + (\case (_ :& Nothing) -> True + _ -> False) + liftIO $ sortedRecords !! 1 + `shouldSatisfy` + (\case (_ :& Nothing) -> True + _ -> False) + itDb "can be used in a CTE" $ do setup records <- select $ do @@ -271,9 +397,9 @@ , myAddress = (Just (Entity addr2 Address {addressAddress = "30-50 Feral Hogs Rd"})) } )) -> True - _ -> True) + _ -> False) - itDb "can can handle joins on records with Nothing" $ do + itDb "can handle joins on records with Nothing" $ do setup records <- select $ do from @@ -291,7 +417,7 @@ , myAddress = (Just (Entity addr2 Address {addressAddress = "30-50 Feral Hogs Rd"})) } )) -> True - _ -> True) + _ -> False) itDb "can left join on nested records" $ do setup @@ -312,7 +438,7 @@ , myAddress = (Just (Entity addr2 Address {addressAddress = "30-50 Feral Hogs Rd"})) } })) -> True - _ -> True) + _ -> False) itDb "can handle multiple left joins on the same record" $ do setup @@ -331,7 +457,7 @@ , myAddress = (Just (Entity addr2 Address {addressAddress = "30-50 Feral Hogs Rd"})) } })) -> True - _ -> True) + _ -> False) liftIO $ sortedRecords !! 1 `shouldSatisfy` (\case (_ :& _ :& Just (MyNestedRecord {myRecord = MyRecord {myName = "Rebecca", myAddress = Nothing}})) -> True