Convert more code to use TH quotes

bitemyapp · Jun 7, 2024 · efc2ba2 · efc2ba2
1 parent 3c74faa
commit efc2ba2
Showing 1 changed file with 20 additions and 69 deletions.
diff --git 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`