diff --git a/changelog.md b/changelog.md index 1cf09376b..1f3dc1295 100644 --- 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 index 44ff6fef3..eb42d6c48 100644 --- a/esqueleto.cabal +++ b/esqueleto.cabal @@ -2,7 +2,7 @@ cabal-version: 1.12 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 index 7bea76564..cdc9913be 100644 --- a/src/Database/Esqueleto/Record.hs +++ b/src/Database/Esqueleto/Record.hs @@ -34,7 +34,7 @@ import Data.Text (Text) 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 @@ deriveEsqueletoRecordWith settings originalName = do 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 @@ nonRecordConstructorMessage con = (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 @@ toAliasDec RecordInfo {..} = do 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 @@ toAliasReferenceDec RecordInfo {..} = do '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 @@ makeSqlMaybeRecord RecordInfo {..} = do -- | 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 @@ makeToMaybeInstance info@RecordInfo {..} = do 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 @@ sqlMaybeSelectColsDec RecordInfo {..} = do ] -- | 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 @@ sqlMaybeSelectProcessRowDec RecordInfo {..} = do [ 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 index cf92b5690..7c36b1d80 100644 --- 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 @@ myRecordQuery = do 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,6 +88,32 @@ myNestedRecordQuery = do , 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 = @@ -198,6 +223,107 @@ testDeriveEsqueletoRecord = describe "deriveEsqueletoRecord" $ do } -> 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 @@ -273,7 +399,7 @@ testDeriveEsqueletoRecord = describe "deriveEsqueletoRecord" $ do )) -> 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