refactor(TH): minor code clean up

src/Database/Esqueleto/Utils/TH.hs

@@ -1,4 +1,4 @@
--- SPDX-FileCopyrightText: 2022 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Sarah Vaupel <vaupel.sarah@campus.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>
+-- SPDX-FileCopyrightText: 2022-24 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Sarah Vaupel <vaupel.sarah@campus.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>,Steffen Jost <s.jost@fraport.de>
 --
 -- SPDX-License-Identifier: AGPL-3.0-or-later
 
@@ -26,6 +26,9 @@ import Data.List (foldr1, foldl)
 import Utils.TH
 import Control.Lens.Iso (Iso', iso)
 
+{-# ANN module ("HLint: ignore Redundant bracket"::String) #-}
+
+
 class E.SqlSelect a r => SqlIn a r | a -> r, r -> a where
   sqlIn :: a -> [r] -> E.SqlExpr (E.Value Bool)
 
@@ -125,10 +128,6 @@ sqlMIXproj = leftAssociativeProjection . map decodeJoin
     decodeJoin 'C' = 'E.CrossJoin
     decodeJoin  c  = error $ "Database.Esqueleto.Utils.TH.sqlMIXproj: received unknown SQL join kind \"" ++ c:"\""  -- always raised at compile time, so this is ok
 
---  Alternative using `refiy`, but impractical due to TH staging restrictions
---    and currently confuses type and expression constructors somehow
+--  Alternative using `reify`; works, but may require `$(return [])` between type definition and call to workaround ghc staging problems
 sqlMIXproj' :: Name -> Int -> ExpQ
-sqlMIXproj' t i = do
-  ns <- extractConstructorNames t
-  -- ns' <- maybeMapM (lookupValueName . nameBase) ns -- failed attempt change type-constructor names to identical expression-constructors
-  leftAssociativeProjection (reverse ns) i
+sqlMIXproj' t i = extractConstructorNames t >>= flip leftAssociativeProjection i

src/Utils/TH.hs

@@ -1,4 +1,4 @@
--- SPDX-FileCopyrightText: 2022 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>
+-- SPDX-FileCopyrightText: 2022-24 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>,Steffen Jost <s.jost@fraport.de>
 --
 -- SPDX-License-Identifier: AGPL-3.0-or-later
 
@@ -55,11 +55,11 @@ leftAssociativePairProjection constructor n i = do
       | w==i      = conP constructor [wildP, varP x]
       | otherwise = conP constructor [pat x (pred w), wildP]
 
--- | Generic projections N-tuples that are actually left-associative pairs with differing constructors
+-- | Generic projections n-tuples that are actually left-associative pairs with differing constructors
 --   i.e. @$(leftAssociativePairProjection [c1,c2,..,cn] m :: (..(t1 `c1` t2) `c2` .. `cn` t(n+1) -> tm@ (for m<=n+1)
 leftAssociativeProjection :: [Name] -> Int -> ExpQ
 leftAssociativeProjection constructors@(length -> n) (pred -> i)
-  | n < i  = error $ "leftAssciativeProjection not given enough constructors: " <> show constructors
+  | n < i  = error $ "Util.TH.leftAssociativeProjection not given enough constructors: " <> show constructors
   | otherwise = do
     x <- newName "x"
     lamE [pat x n] (varE x)
@@ -69,39 +69,32 @@ leftAssociativeProjection constructors@(length -> n) (pred -> i)
       | w==i      = conP (constructors !! v) [wildP, varP x]
       | otherwise = conP (constructors !! v) [pat x v, wildP]
 
--- Extract constructor names from a type definition of left-associative pair-constructors
--- PROBLEM: returns the wrong names: E.g. for `data LeftOuterJoinTC a b = a `LeftOuterJoinEC` b we get `LeftOuterJoinTC`, but we need `LeftOuterJoinEC`
+-- Extract constructor names from a type definition of left-associative pair-constructors (i.e. Esqueleto-Joins in a table-expression type)
 extractConstructorNames :: Name -> Q [Name]
 extractConstructorNames td = do
-  TyConI (TySynD _ [] ty) <- reify td
-  concatMapM getDataConstructors (go ty)
+  TyConI (TySynD _ [] ty) <- reify td -- executed at compile time, so failure is acceptable
+  reverse . concat <$> mapM getDataConstructors (go ty)
   where
     go :: Type -> [Name]
     go (AppT (AppT (ConT name) rest) _) = name : go rest
     go _                                = []
 
-    -- At this point we have the Type-Constructors, but we actually need the Data-Constructors.
-    -- We might possibly use something like the following:
-
+    -- At this point we have the Type-Constructors, but we actually need the Data-Constructors:
     getDataConstructors :: Name -> Q [Name]
     getDataConstructors conName = do
       info <- reify conName
       case info of
-        TyConI (DataD _ _ _ _ constr _) -> return $ concatMap getConNames constr
-        TyConI (NewtypeD _ _ _ _ constr _) -> return $ getConNames constr
+        TyConI (DataD    _ _ _ _ constr _) -> return $ concatMap getConNames constr
+        TyConI (NewtypeD _ _ _ _ constr _) -> return $           getConNames constr
         _ -> return []
 
     getConNames :: Con -> [Name]
-    getConNames (NormalC name _) = [name]
-    getConNames (RecC name _) = [name]
+    getConNames (NormalC  name _) = [name]
+    getConNames (RecC     name _) = [name]
     getConNames (InfixC _ name _) = [name]
     getConNames (ForallC _ _ con) = getConNames con
     getConNames _ = []
 
-    concatMapM :: Monad m => (a -> m [b]) -> [a] -> m [b]
-    concatMapM f xs = concat <$> mapM f xs
-
-
 {-
 Example:
 
@@ -149,8 +142,6 @@ with
             (ConT Database.Persist.Class.PersistEntity.Entity)
             (ConT Model.QualificationUserBlock)
   ) ) ) ) )
-
-
 -}