-
Notifications
You must be signed in to change notification settings - Fork 107
New issue
Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.
By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.
Already on GitHub? Sign in to your account
Support nested records in deriveEsqueletoRecord
#324
Merged
parsonsmatt
merged 8 commits into
bitemyapp:master
from
9999years:rbt/dux-531-nested-records
Aug 1, 2022
Merged
Changes from 6 commits
Commits
Show all changes
8 commits
Select commit
Hold shift + click to select a range
77660e6
Support nested records in `deriveEsqueletoRecord`
9999years 7cad771
Bump version to 3.5.6.1
9999years 066f579
Use TypeOperators to make code more readable
9999years 5b3e22e
Update changelog
9999years 949cf18
Another readability pass
9999years 45f3667
Use `TemplateHaskell`
9999years 4d5bd85
Use `listToMaybe` instead of a `case` expression
9999years 2bc9d4b
Add nested record selection test
9999years File filter
Filter by extension
Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
There are no files selected for viewing
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
Original file line number | Diff line number | Diff line change | ||||||||
---|---|---|---|---|---|---|---|---|---|---|
@@ -1,10 +1,11 @@ | ||||||||||
{-# LANGUAGE ScopedTypeVariables #-} | ||||||||||
{-# LANGUAGE TemplateHaskellQuotes #-} | ||||||||||
{-# LANGUAGE CPP #-} | ||||||||||
{-# LANGUAGE LambdaCase #-} | ||||||||||
{-# LANGUAGE OverloadedStrings #-} | ||||||||||
{-# LANGUAGE RecordWildCards #-} | ||||||||||
{-# LANGUAGE ViewPatterns #-} | ||||||||||
{-# LANGUAGE ScopedTypeVariables #-} | ||||||||||
{-# LANGUAGE TemplateHaskell #-} | ||||||||||
{-# LANGUAGE TypeApplications #-} | ||||||||||
{-# LANGUAGE OverloadedStrings #-} | ||||||||||
{-# LANGUAGE CPP #-} | ||||||||||
{-# LANGUAGE ViewPatterns #-} | ||||||||||
|
||||||||||
module Database.Esqueleto.Record | ||||||||||
( deriveEsqueletoRecord | ||||||||||
|
@@ -16,11 +17,13 @@ import Database.Esqueleto.Experimental | |||||||||
(Entity, PersistValue, SqlExpr, Value(..), (:&)(..)) | ||||||||||
import Database.Esqueleto.Internal.Internal (SqlSelect(..)) | ||||||||||
import Language.Haskell.TH | ||||||||||
import Language.Haskell.TH.Syntax | ||||||||||
import Data.Bifunctor (first) | ||||||||||
import Data.Text (Text) | ||||||||||
import Control.Monad (forM) | ||||||||||
import Data.Foldable (foldl') | ||||||||||
import GHC.Exts (IsString(fromString)) | ||||||||||
import Data.Maybe (mapMaybe, fromMaybe) | ||||||||||
|
||||||||||
-- | 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 | ||||||||||
|
@@ -169,16 +172,19 @@ getRecordInfo name = do | |||||||||
RecC name' _fields -> name' | ||||||||||
con -> error $ nonRecordConstructorMessage con | ||||||||||
fields = getFields constructor | ||||||||||
sqlFields = toSqlField `map` fields | ||||||||||
sqlName = makeSqlName name | ||||||||||
|
||||||||||
sqlFields <- mapM toSqlField fields | ||||||||||
|
||||||||||
pure RecordInfo {..} | ||||||||||
where | ||||||||||
getFields :: Con -> [(Name, Type)] | ||||||||||
getFields (RecC _name fields) = [(fieldName', fieldType') | (fieldName', _bang, fieldType') <- fields] | ||||||||||
getFields con = error $ nonRecordConstructorMessage con | ||||||||||
|
||||||||||
toSqlField (fieldName', ty) = (fieldName', sqlFieldType ty) | ||||||||||
toSqlField (fieldName', ty) = do | ||||||||||
sqlTy <- sqlFieldType ty | ||||||||||
pure (fieldName', sqlTy) | ||||||||||
|
||||||||||
-- | Create a new name by prefixing @Sql@ to a given name. | ||||||||||
makeSqlName :: Name -> Name | ||||||||||
|
@@ -189,17 +195,28 @@ makeSqlName name = mkName $ "Sql" ++ nameBase name | |||||||||
-- * @'Entity' x@ is transformed into @'SqlExpr' ('Entity' x)@. | ||||||||||
-- * @'Maybe' ('Entity' x)@ is transformed into @'SqlExpr' ('Maybe' ('Entity' x))@. | ||||||||||
-- * @x@ is transformed into @'SqlExpr' ('Value' x)@. | ||||||||||
sqlFieldType :: Type -> Type | ||||||||||
sqlFieldType fieldType = | ||||||||||
case fieldType of | ||||||||||
-- Entity x -> SqlExpr (Entity x) | ||||||||||
AppT (ConT ((==) ''Entity -> True)) _innerType -> AppT (ConT ''SqlExpr) fieldType | ||||||||||
-- Maybe (Entity x) -> SqlExpr (Maybe (Entity x)) | ||||||||||
AppT | ||||||||||
(ConT ((==) ''Maybe -> True)) | ||||||||||
(AppT (ConT ((==) ''Entity -> True)) _innerType) -> AppT (ConT ''SqlExpr) fieldType | ||||||||||
-- x -> SqlExpr (Value x) | ||||||||||
_ -> AppT (ConT ''SqlExpr) (AppT (ConT ''Value) fieldType) | ||||||||||
-- * If there exists an instance @'SqlSelect' sql x@, then @x@ is transformed into @sql@. | ||||||||||
-- | ||||||||||
-- This function should match `sqlSelectProcessRowPat`. | ||||||||||
sqlFieldType :: Type -> Q Type | ||||||||||
sqlFieldType fieldType = do | ||||||||||
maybeSqlType <- reifySqlSelectType fieldType | ||||||||||
|
||||||||||
pure $ | ||||||||||
flip fromMaybe maybeSqlType $ | ||||||||||
case fieldType of | ||||||||||
-- Entity x -> SqlExpr (Entity x) | ||||||||||
AppT (ConT ((==) ''Entity -> True)) _innerType -> AppT (ConT ''SqlExpr) fieldType | ||||||||||
|
||||||||||
-- Maybe (Entity x) -> SqlExpr (Maybe (Entity x)) | ||||||||||
(ConT ((==) ''Maybe -> True)) | ||||||||||
`AppT` ((ConT ((==) ''Entity -> True)) | ||||||||||
`AppT` _innerType) -> AppT (ConT ''SqlExpr) fieldType | ||||||||||
|
||||||||||
-- x -> SqlExpr (Value x) | ||||||||||
_ -> (ConT ''SqlExpr) | ||||||||||
`AppT` ((ConT ''Value) | ||||||||||
`AppT` fieldType) | ||||||||||
|
||||||||||
-- | Generates the declaration for an @Sql@-prefixed record, given the original | ||||||||||
-- record's information. | ||||||||||
|
@@ -222,9 +239,9 @@ makeSqlSelectInstance info@RecordInfo {..} = do | |||||||||
let overlap = Nothing | ||||||||||
instanceConstraints = [] | ||||||||||
instanceType = | ||||||||||
AppT | ||||||||||
(AppT (ConT ''SqlSelect) (ConT sqlName)) | ||||||||||
(ConT name) | ||||||||||
(ConT ''SqlSelect) | ||||||||||
`AppT` (ConT sqlName) | ||||||||||
`AppT` (ConT name) | ||||||||||
|
||||||||||
pure $ InstanceD overlap instanceConstraints instanceType [sqlSelectColsDec', sqlSelectColCountDec', sqlSelectProcessRowDec'] | ||||||||||
|
||||||||||
|
@@ -265,9 +282,9 @@ sqlSelectColsDec RecordInfo {..} = do | |||||||||
, RecP sqlName fieldPatterns | ||||||||||
] | ||||||||||
( NormalB $ | ||||||||||
AppE | ||||||||||
(AppE (VarE 'sqlSelectCols) (VarE identInfo)) | ||||||||||
(ParensE joinedFields) | ||||||||||
(VarE 'sqlSelectCols) | ||||||||||
`AppE` (VarE identInfo) | ||||||||||
`AppE` (ParensE joinedFields) | ||||||||||
) | ||||||||||
-- `where` clause. | ||||||||||
[] | ||||||||||
|
@@ -318,9 +335,10 @@ sqlSelectProcessRowDec RecordInfo {..} = do | |||||||||
(statements, fieldExps) <- | ||||||||||
unzip <$> forM (zip fields sqlFields) (\((fieldName', fieldType), (_, sqlType')) -> do | ||||||||||
valueName <- newName (nameBase fieldName') | ||||||||||
pattern <- sqlSelectProcessRowPat fieldType valueName | ||||||||||
pure | ||||||||||
( BindS | ||||||||||
(sqlSelectProcessRowPat fieldType valueName) | ||||||||||
pattern | ||||||||||
(AppTypeE (VarE 'takeColumns) sqlType') | ||||||||||
, (mkName $ nameBase fieldName', VarE valueName) | ||||||||||
)) | ||||||||||
|
@@ -334,31 +352,17 @@ sqlSelectProcessRowDec RecordInfo {..} = do | |||||||||
-- (evalStateT $processName $colsName) | ||||||||||
-- where $processName = do $statements | ||||||||||
-- pure $name {$fieldExps} | ||||||||||
bodyExp <- [e| | ||||||||||
first (fromString ("Failed to parse " ++ $(lift $ nameBase name) ++ ": ") <>) | ||||||||||
(evalStateT $(varE processName) $(varE colsName)) | ||||||||||
|] | ||||||||||
|
||||||||||
pure $ | ||||||||||
FunD | ||||||||||
'sqlSelectProcessRow | ||||||||||
[ Clause | ||||||||||
[VarP colsName] | ||||||||||
( NormalB $ | ||||||||||
AppE | ||||||||||
( AppE | ||||||||||
(VarE 'first) | ||||||||||
( InfixE | ||||||||||
(Just $ AppE | ||||||||||
(VarE 'fromString) | ||||||||||
(LitE $ StringL $ "Failed to parse " ++ nameBase name ++ ": ")) | ||||||||||
(VarE '(<>)) | ||||||||||
Nothing | ||||||||||
) | ||||||||||
) | ||||||||||
( AppE | ||||||||||
( AppE | ||||||||||
(VarE 'evalStateT) | ||||||||||
(VarE processName) | ||||||||||
) | ||||||||||
(VarE colsName) | ||||||||||
) | ||||||||||
) | ||||||||||
(NormalB bodyExp) | ||||||||||
-- `where` clause | ||||||||||
[ ValD | ||||||||||
(VarP processName) | ||||||||||
|
@@ -379,22 +383,81 @@ sqlSelectProcessRowDec RecordInfo {..} = do | |||||||||
-- * A type of @'Entity' x@ gives a pattern of @var@. | ||||||||||
-- * A type of @'Maybe' ('Entity' x)@ gives a pattern of @var@. | ||||||||||
-- * A type of @x@ gives a pattern of @'Value' var@. | ||||||||||
sqlSelectProcessRowPat :: Type -> Name -> Pat | ||||||||||
sqlSelectProcessRowPat fieldType var = | ||||||||||
case fieldType of | ||||||||||
-- Entity x -> var | ||||||||||
AppT (ConT ((==) ''Entity -> True)) _innerType -> VarP var | ||||||||||
-- Maybe (Entity x) -> var | ||||||||||
AppT | ||||||||||
(ConT ((==) ''Maybe -> True)) | ||||||||||
(AppT (ConT ((==) ''Entity -> True)) _innerType) -> VarP var | ||||||||||
-- x -> Value var | ||||||||||
-- * If there exists an instance @'SqlSelect' sql x@, then a type of @x@ gives a pattern of @var@. | ||||||||||
-- | ||||||||||
-- This function should match `sqlFieldType`. | ||||||||||
sqlSelectProcessRowPat :: Type -> Name -> Q Pat | ||||||||||
sqlSelectProcessRowPat fieldType var = do | ||||||||||
maybeSqlType <- reifySqlSelectType fieldType | ||||||||||
|
||||||||||
case maybeSqlType of | ||||||||||
Just _ -> pure $ VarP var | ||||||||||
Nothing -> case fieldType of | ||||||||||
-- Entity x -> var | ||||||||||
AppT (ConT ((==) ''Entity -> True)) _innerType -> pure $ VarP var | ||||||||||
-- Maybe (Entity x) -> var | ||||||||||
(ConT ((==) ''Maybe -> True)) | ||||||||||
`AppT` ((ConT ((==) ''Entity -> True)) | ||||||||||
`AppT` _innerType) -> pure $ VarP var | ||||||||||
-- x -> Value var | ||||||||||
#if MIN_VERSION_template_haskell(2,18,0) | ||||||||||
_ -> ConP 'Value [] [VarP var] | ||||||||||
_ -> pure $ ConP 'Value [] [VarP var] | ||||||||||
#else | ||||||||||
_ -> ConP 'Value [VarP var] | ||||||||||
_ -> pure $ ConP 'Value [VarP var] | ||||||||||
#endif | ||||||||||
|
||||||||||
-- Given a type, find the corresponding SQL type. | ||||||||||
-- | ||||||||||
-- If there exists an instance `SqlSelect sql ty`, then the SQL type for `ty` | ||||||||||
-- is `sql`. | ||||||||||
-- | ||||||||||
-- This function definitely works for records and instances generated by this | ||||||||||
-- module, and might work for instances outside of it. | ||||||||||
reifySqlSelectType :: Type -> Q (Maybe Type) | ||||||||||
reifySqlSelectType originalType = do | ||||||||||
-- Here we query the compiler for Instances of `SqlSelect a $(originalType)`; | ||||||||||
-- the API for this is super weird, it interprets a list of types as being | ||||||||||
-- applied as successive arguments to the typeclass name. | ||||||||||
-- | ||||||||||
-- See: https://gitlab.haskell.org/ghc/ghc/-/issues/21825 | ||||||||||
-- | ||||||||||
-- >>> reifyInstances ''SqlSelect [VarT (mkName "a"), ConT ''MyRecord] | ||||||||||
-- [ InstanceD Nothing | ||||||||||
-- [] | ||||||||||
-- (AppT (AppT (ConT Database.Esqueleto.Internal.Internal.SqlSelect) | ||||||||||
-- (ConT Ghci3.SqlMyRecord)) | ||||||||||
-- (ConT Ghci3.MyRecord)) | ||||||||||
-- [] | ||||||||||
-- ] | ||||||||||
tyVarName <- newName "a" | ||||||||||
instances <- reifyInstances ''SqlSelect [VarT tyVarName, originalType] | ||||||||||
|
||||||||||
-- Given the original type (`originalType`) and an instance type for a | ||||||||||
-- `SqlSelect` instance, get the SQL type which corresponds to the original | ||||||||||
-- type. | ||||||||||
let extractSqlRecord :: Type -> Type -> Maybe Type | ||||||||||
extractSqlRecord originalTy instanceTy = | ||||||||||
case instanceTy of | ||||||||||
(ConT ((==) ''SqlSelect -> True)) | ||||||||||
`AppT` sqlTy | ||||||||||
`AppT` ((==) originalTy -> True) -> Just sqlTy | ||||||||||
_ -> Nothing | ||||||||||
|
||||||||||
-- Filter `instances` to the instances which match `originalType`. | ||||||||||
filteredInstances :: [Type] | ||||||||||
filteredInstances = | ||||||||||
flip mapMaybe instances | ||||||||||
(\case InstanceD _overlap | ||||||||||
_constraints | ||||||||||
(extractSqlRecord originalType -> Just sqlRecord) | ||||||||||
_decs -> | ||||||||||
Just sqlRecord | ||||||||||
_ -> Nothing) | ||||||||||
|
||||||||||
case filteredInstances of | ||||||||||
sqlType : _ -> pure $ Just sqlType | ||||||||||
_ -> pure Nothing | ||||||||||
There was a problem hiding this comment. Choose a reason for hiding this commentThe reason will be displayed to describe this comment to others. Learn more.
Suggested change
|
||||||||||
|
||||||||||
-- | 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 file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
Add this suggestion to a batch that can be applied as a single commit.
This suggestion is invalid because no changes were made to the code.
Suggestions cannot be applied while the pull request is closed.
Suggestions cannot be applied while viewing a subset of changes.
Only one suggestion per line can be applied in a batch.
Add this suggestion to a batch that can be applied as a single commit.
Applying suggestions on deleted lines is not supported.
You must change the existing code in this line in order to create a valid suggestion.
Outdated suggestions cannot be applied.
This suggestion has been applied or marked resolved.
Suggestions cannot be applied from pending reviews.
Suggestions cannot be applied on multi-line comments.
Suggestions cannot be applied while the pull request is queued to merge.
Suggestion cannot be applied right now. Please check back later.
There was a problem hiding this comment.
Choose a reason for hiding this comment
The reason will be displayed to describe this comment to others. Learn more.
hm,
listToMaybe . mapMaybe f
is alsofind (isJust . f)
- may be easier or more concise to write like that?There was a problem hiding this comment.
Choose a reason for hiding this comment
The reason will be displayed to describe this comment to others. Learn more.
I don't think so, because
find
only returns the element but I also need themapMaybe
part to transform and extract the sql type.There was a problem hiding this comment.
Choose a reason for hiding this comment
The reason will be displayed to describe this comment to others. Learn more.
Oh, good point!