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

Open
wants to merge 5 commits into
base: master
Choose a base branch
from
Open

Use TH quotes more to eliminate some CPP #394

Show file tree
Hide file tree
Changes from all commits
Commits
Show all changes
5 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
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
6 changes: 6 additions & 0 deletions changelog.md
View file
Open in desktop
Original file line number Diff line number Diff line change
@@ -1,3 +1,9 @@
3.5.13.1
========
- @TeofilC
- [#394](https://github.com/bitemyapp/esqueleto/pull/394)
- Use TH quotes to eliminate some CPP.

3.5.13.0
========
- @ac251
Expand Down
2 changes: 1 addition & 1 deletion esqueleto.cabal
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -2,7 +2,7 @@ cabal-version: 1.12

name: esqueleto

version: 3.5.13.0
version: 3.5.13.1
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.
.
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 @@ -261,7 +261,7 @@
(c : _) -> pure c
[] -> fail $ "Cannot derive Esqueleto record for a type with no constructors: " ++ show name
let constructorName =
case head constructors of

Check warning on line 264 in src/Database/Esqueleto/Record.hs

View workflow job for this annotation

GitHub Actions / build (3.10.2.1, 9.8.1) 

In the use of ‘head’

Check warning on line 264 in src/Database/Esqueleto/Record.hs

View workflow job for this annotation

GitHub Actions / build (3.10.2.1, 9.8.1) 

In the use of ‘head’
RecC name' _fields -> name'
con -> error $ nonRecordConstructorMessage con
fields = getFields constructor
Expand Down Expand Up @@ -379,15 +379,12 @@
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 @@
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 @@
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 @@
`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 @@ -648,7 +611,7 @@
-- If there's GADTs where multiple constructors are declared with the
-- same type signature you're evil and furthermore this diagnostic will
-- only show you the first name.
(GadtC names _fields _ret) -> head names

Check warning on line 614 in src/Database/Esqueleto/Record.hs

View workflow job for this annotation

GitHub Actions / build (3.10.2.1, 9.8.1) 

In the use of ‘head’

Check warning on line 614 in src/Database/Esqueleto/Record.hs

View workflow job for this annotation

GitHub Actions / build (3.10.2.1, 9.8.1) 

In the use of ‘head’
(RecGadtC names _fields _ret) -> head names

makeToAliasInstance :: RecordInfo -> Q Dec
Expand Down Expand Up @@ -766,7 +729,7 @@
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 @@
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 @@
, (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 @@
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 @@
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 @@ -941,7 +870,7 @@
_ -> error $ show x

-- | 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 @@ -951,23 +880,7 @@
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
Loading