diff --git a/src/Database/Esqueleto/Record.hs b/src/Database/Esqueleto/Record.hs index 32a512be9..18e2f7b97 100644 --- a/src/Database/Esqueleto/Record.hs +++ b/src/Database/Esqueleto/Record.hs @@ -784,15 +784,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 @@ -818,27 +814,13 @@ 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| sqlSelectCols $(varP identInfo) $(pure $ RecP sqlMaybeName fieldPatterns) = + sqlSelectCols $(varE identInfo) $(pure joinedFields) + |] -- | Generates the `sqlSelectProcessRow` declaration for an `SqlSelect` -- instance. -sqlMaybeSelectProcessRowDec :: RecordInfo -> Q Dec +sqlMaybeSelectProcessRowDec :: RecordInfo -> Q [Dec] sqlMaybeSelectProcessRowDec RecordInfo {..} = do let sqlOp x = case x of @@ -871,35 +853,20 @@ sqlMaybeSelectProcessRowDec RecordInfo {..} = do colsName <- newName "columns" - 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 - ) - ] - - pure $ - FunD - 'sqlSelectProcessRow - [ Clause - [VarP colsName] - (NormalB bodyExp) - [] - ] + [d| sqlSelectProcessRow $(varP colsName) = do + $(pure joinedFields) <- sqlSelectProcessRow $(varE colsName) + pure $ $( + case fieldNames of + [] -> conE constructorName + (_,_,e):xs -> foldl' + (\acc (_,_,e2) -> appE (appE (varE '(<*>)) acc) (pure e2)) + [|fmap $(conE constructorName) $(pure e)|] + xs + ) + |] -- | 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 @@ -909,23 +876,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| 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`