Convert more code to use TH quotes

bitemyapp · Oct 29, 2024 · 21a1a1a · 21a1a1a
1 parent 995409c
commit 21a1a1a
Showing 1 changed file with 21 additions and 94 deletions.
diff --git a/src/Database/Esqueleto/Record.hs b/src/Database/Esqueleto/Record.hs
@@ -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
@@ -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| 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
@@ -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| sqlSelectColCount _ = sqlSelectColCount (Proxy @($(pure joinedTypes))) |]
 
 -- | Generates the `sqlSelectProcessRow` declaration for an `SqlSelect`
 -- instance.
@@ -762,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
@@ -780,7 +747,7 @@ 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
@@ -790,15 +757,9 @@ toMaybeDec RecordInfo {..} = do
             , (maybeFieldName', VarE 'toMaybe `AppE` VarE fieldPatternName)
             ))
 
-  pure $
-    FunD
-        'toMaybe
-        [ Clause
-            [ RecP sqlName fieldPatterns
-            ]
-            (NormalB $ RecConE sqlMaybeName fieldExps)
-            []
-        ]
+  [d| toMaybe $(pure $ RecP sqlName fieldPatterns) =
+        $(pure $ RecConE sqlMaybeName fieldExps)
+    |]
 
 -- | Generates an `SqlSelect` instance for the given record and its
 -- @Sql@-prefixed variant.
@@ -809,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
@@ -843,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| sqlSelectCols $(varP identInfo) $(pure $ RecP sqlMaybeName fieldPatterns) =
+        sqlSelectCols $(varE identInfo) $(pure joinedFields)
+    |]
 
 -- | Generates the `sqlSelectProcessRow` declaration for an `SqlSelect`
 -- instance for a SqlMaybe.
@@ -927,7 +870,7 @@ sqlMaybeSelectProcessRowDec RecordInfo {..} = do
       _ -> 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
@@ -937,23 +880,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`