Skip to content
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.

Sign up for GitHub

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

Use TH quotes more to eliminate some CPP #394

Merged
merged 7 commits into from
Dec 26, 2024
Merged

Use TH quotes more to eliminate some CPP #394

Show file tree
Hide file tree
Changes from 6 commits
Commits
Show all changes
7 commits
Select commit Hold shift + click to select a range
6a7b8de
Remove CPP for ConP
TeofilC Jun 7, 2024
e19e69e
Use quote for toMaybeTDec
TeofilC Jun 7, 2024
995409c
Bump version and add chnglog entry
TeofilC Jun 7, 2024
21a1a1a
Convert more code to use TH quotes
TeofilC Jun 7, 2024
89be96a
Fix newName error
TeofilC Oct 31, 2024
788893e
Merge branch 'master' into wip/teo/less-cpp
parsonsmatt Dec 26, 2024
69cbf67
Merge branch 'master' into wip/teo/less-cpp
parsonsmatt Dec 26, 2024
File filter

Filter by extension

Filter by extension
Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
5 changes: 4 additions & 1 deletion changelog.md
View file
Open in desktop
Original file line number Diff line number Diff line change
@@ -1,5 +1,8 @@
3.5.13.1
3.5.13.2
========
- @TeofilC
- [#394](https://github.com/bitemyapp/esqueleto/pull/394)
- Use TH quotes to eliminate some CPP.
- @csamak
- [#405](https://github.com/bitemyapp/esqueleto/pull/405)
- Fix a bug introduced in 3.5.12.0 where deriveEsqueletoRecord incorrectly errors
Expand Down
139 changes: 26 additions & 113 deletions src/Database/Esqueleto/Record.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -379,15 +379,12 @@ makeSqlSelectInstance info@RecordInfo {..} = do
sqlSelectProcessRowDec' <- sqlSelectProcessRowDec info
let overlap = Nothing
instanceConstraints = []
instanceType =
(ConT ''SqlSelect)
`AppT` (ConT sqlName)
`AppT` (ConT name)
instanceType <- [t| SqlSelect $(conT sqlName) $(conT name) |]

pure $ InstanceD overlap instanceConstraints instanceType [sqlSelectColsDec', sqlSelectColCountDec', sqlSelectProcessRowDec']
pure $ InstanceD overlap instanceConstraints instanceType (sqlSelectColsDec' ++ sqlSelectColCountDec' ++ [ sqlSelectProcessRowDec'])

-- | Generates the `sqlSelectCols` declaration for an `SqlSelect` instance.
sqlSelectColsDec :: RecordInfo -> Q Dec
sqlSelectColsDec :: RecordInfo -> Q [Dec]
sqlSelectColsDec RecordInfo {..} = do
-- Pairs of record field names and local variable names.
fieldNames <- forM sqlFields (\(name', _type) -> do
Expand All @@ -413,26 +410,12 @@ sqlSelectColsDec RecordInfo {..} = do
in foldl' helper (VarE f1) rest

identInfo <- newName "identInfo"
-- Roughly:
-- sqlSelectCols $identInfo SqlFoo{..} = sqlSelectCols $identInfo $joinedFields
pure $
FunD
'sqlSelectCols
[ Clause
[ VarP identInfo
, RecP sqlName fieldPatterns
]
( NormalB $
(VarE 'sqlSelectCols)
`AppE` (VarE identInfo)
`AppE` (ParensE joinedFields)
)
-- `where` clause.
[]
]
[d| $(varP 'sqlSelectCols) = \ $(varP identInfo) $(pure $ RecP sqlName fieldPatterns) ->
sqlSelectCols $(varE identInfo) $(pure joinedFields)
|]

-- | Generates the `sqlSelectColCount` declaration for an `SqlSelect` instance.
sqlSelectColCountDec :: RecordInfo -> Q Dec
sqlSelectColCountDec :: RecordInfo -> Q [Dec]
sqlSelectColCountDec RecordInfo {..} = do
let joinedTypes =
case snd `map` sqlFields of
Expand All @@ -442,23 +425,7 @@ sqlSelectColCountDec RecordInfo {..} = do
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.
[]
]
[d| $(varP 'sqlSelectColCount) = \ _ -> sqlSelectColCount (Proxy @($(pure joinedTypes))) |]

-- | Generates the `sqlSelectProcessRow` declaration for an `SqlSelect`
-- instance.
Expand Down Expand Up @@ -541,11 +508,7 @@ sqlSelectProcessRowPat fieldType var = do
`AppT` ((ConT ((==) ''Entity -> True))
`AppT` _innerType) -> pure $ VarP var
-- x -> Value var
#if MIN_VERSION_template_haskell(2,18,0)
_ -> pure $ ConP 'Value [] [VarP var]
#else
_ -> pure $ ConP 'Value [VarP var]
#endif
_ -> [p| Value $(varP var) |]

-- Given a type, find the corresponding SQL type.
--
Expand Down Expand Up @@ -766,7 +729,7 @@ makeToMaybeInstance info@RecordInfo {..} = do
instanceConstraints = []
instanceType = (ConT ''ToMaybe) `AppT` (ConT sqlName)

pure $ InstanceD overlap instanceConstraints instanceType [toMaybeTDec', toMaybeDec']
pure $ InstanceD overlap instanceConstraints instanceType (toMaybeTDec' ++ toMaybeDec')

-- | Generates a `ToMaybe` instance for the SqlMaybe of the given record.
makeSqlMaybeToMaybeInstance :: RecordInfo -> Q Dec
Expand All @@ -776,25 +739,15 @@ makeSqlMaybeToMaybeInstance RecordInfo {..} = do
overlap = Nothing
instanceConstraints = []
instanceType = (ConT ''ToMaybe) `AppT` (ConT sqlMaybeName)
pure $ InstanceD overlap instanceConstraints instanceType [sqlMaybeToMaybeTDec', toMaybeIdDec]
pure $ InstanceD overlap instanceConstraints instanceType (toMaybeIdDec:sqlMaybeToMaybeTDec')

-- | 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)
let binders = Nothing
lhs = ConT className `AppT` lhsArg
in
TySynInstD $ TySynEqn binders lhs rhs
#else
TySynInstD className $ TySynEqn [lhsArg] rhs
#endif
toMaybeTDec :: Name -> Name -> Q [Dec]
toMaybeTDec nameLeft nameRight =
[d| type instance ToMaybeT $(conT nameLeft) = $(conT nameRight) |]

-- | Generates a `toMaybe value = ...` declaration for the given record.
toMaybeDec :: RecordInfo -> Q Dec
toMaybeDec :: RecordInfo -> Q [Dec]
toMaybeDec RecordInfo {..} = do
(fieldPatterns, fieldExps) <-
unzip <$> forM (zip sqlFields sqlMaybeFields) (\((fieldName', _), (maybeFieldName', _)) -> do
Expand All @@ -804,15 +757,9 @@ toMaybeDec RecordInfo {..} = do
, (maybeFieldName', VarE 'toMaybe `AppE` VarE fieldPatternName)
))

pure $
FunD
'toMaybe
[ Clause
[ RecP sqlName fieldPatterns
]
(NormalB $ RecConE sqlMaybeName fieldExps)
[]
]
[d| $(varP 'toMaybe) = \ $(pure $ RecP sqlName fieldPatterns) ->
$(pure $ RecConE sqlMaybeName fieldExps)
|]

-- | Generates an `SqlSelect` instance for the given record and its
-- @Sql@-prefixed variant.
Expand All @@ -823,15 +770,11 @@ makeSqlMaybeRecordSelectInstance info@RecordInfo {..} = do
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']
instanceType <- [t| SqlSelect $(conT sqlMaybeName) (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 -> Q [Dec]
sqlMaybeSelectColsDec RecordInfo {..} = do
-- Pairs of record field names and local variable names.
fieldNames <- forM sqlMaybeFields (\(name', _type) -> do
Expand All @@ -857,23 +800,9 @@ sqlMaybeSelectColsDec RecordInfo {..} = do
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.
[]
]
[d| $(varP 'sqlSelectCols) = \ $(varP identInfo) $(pure $ RecP sqlMaybeName fieldPatterns) ->
sqlSelectCols $(varE identInfo) $(pure joinedFields)
|]

-- | Generates the `sqlSelectProcessRow` declaration for an `SqlSelect`
-- instance for a SqlMaybe.
Expand Down Expand Up @@ -939,7 +868,7 @@ sqlMaybeSelectProcessRowDec RecordInfo {..} = do
_ -> id

-- | Generates the `sqlSelectColCount` declaration for an `SqlSelect` instance.
sqlMaybeSelectColCountDec :: RecordInfo -> Q Dec
sqlMaybeSelectColCountDec :: RecordInfo -> Q [Dec]
sqlMaybeSelectColCountDec RecordInfo {..} = do
let joinedTypes =
case snd `map` sqlMaybeFields of
Expand All @@ -949,23 +878,7 @@ sqlMaybeSelectColCountDec RecordInfo {..} = do
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.
[]
]
[d| $(varP 'sqlSelectColCount) = \_ -> sqlSelectColCount (Proxy @($(pure joinedTypes))) |]

-- | Statefully parse some number of columns from a list of `PersistValue`s,
-- where the number of columns to parse is determined by `sqlSelectColCount`
Expand Down