refactor(TH): add sqlMIXproj' using reify on TableExpr for more comfort

src/Database/Esqueleto/Utils/TH.hs

@@ -131,4 +131,4 @@ 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 ns i
+  leftAssociativeProjection (reverse ns) i

src/Handler/School/DayTasks.hs

@@ -105,12 +105,6 @@ type DailyTableExpr =
     `E.InnerJoin`       E.SqlExpr (Entity User)
     `E.LeftOuterJoin`   E.SqlExpr (Maybe (Entity UserAvs))
   )
--- due to GHC staging restrictions, we use the preprocessor instead
-#define DAILY_TABLE_JOIN "IIIL"
-
--- force declarations before this point
-$(return [])
-
 
 type DailyTableOutput = E.SqlQuery
   ( E.SqlExpr (Entity Course)
@@ -131,25 +125,25 @@ type DailyTableData   = DBRow
   , E.Value (Maybe [QualificationId])
   )
 
--- force declarations before this point
+-- force declarations before this point to avoid staging restrictions
 $(return [])
 
 
 queryCourse :: DailyTableExpr -> E.SqlExpr (Entity Course)
-queryCourse = $(sqlMIXproj DAILY_TABLE_JOIN 1)
+queryCourse = $(sqlMIXproj' ''DailyTableExpr 1)
 
 queryTutorial :: DailyTableExpr -> E.SqlExpr (Entity Tutorial)
-queryTutorial = $(sqlMIXproj DAILY_TABLE_JOIN 2)
+queryTutorial = $(sqlMIXproj' ''DailyTableExpr 2)
 
 queryParticipant :: DailyTableExpr -> E.SqlExpr (Entity TutorialParticipant)
--- queryParticipant = $(sqlMIXproj' ''DailyTableExpr 3) -- TODO reify seems problematic for now
-queryParticipant = $(sqlMIXproj DAILY_TABLE_JOIN 3)
+queryParticipant = $(sqlMIXproj' ''DailyTableExpr 3) -- TODO reify seems problematic for now
+-- queryParticipant = $(sqlMIXproj DAILY_TABLE_JOIN 3)
 
 queryUser :: DailyTableExpr -> E.SqlExpr (Entity User)
-queryUser = $(sqlMIXproj DAILY_TABLE_JOIN 4)
+queryUser = $(sqlMIXproj' ''DailyTableExpr 4)
 
 queryUserAvs :: DailyTableExpr -> E.SqlExpr (Maybe (Entity UserAvs))
-queryUserAvs = $(sqlMIXproj DAILY_TABLE_JOIN 5)
+queryUserAvs = $(sqlMIXproj' ''DailyTableExpr 5)
 
 resultCourse :: Lens' DailyTableData (Entity Course)
 resultCourse = _dbrOutput . _1

src/Utils/TH.hs

@@ -74,12 +74,34 @@ leftAssociativeProjection constructors@(length -> n) (pred -> i)
 extractConstructorNames :: Name -> Q [Name]
 extractConstructorNames td = do
   TyConI (TySynD _ [] ty) <- reify td
-  return (go ty)
+  concatMapM 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:
+
+    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
+        _ -> return []
+
+    getConNames :: Con -> [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:
 
@@ -128,23 +150,7 @@ with
             (ConT Model.QualificationUserBlock)
   ) ) ) ) )
 
-  At this point we have the Type-Constructors, but we actually need the Data-Constructors.
-  We might possibly use something like the following:
 
-    getDataConstructors :: Name -> Q [Name]
-    getDataConstructors conName = do
-      info <- reify conName
-      case info of
-        TyConI (DataD _ _ _ _ cons _) -> return $ concatMap getConNames cons
-        TyConI (NewtypeD _ _ _ _ con _) -> return $ getConNames con
-        _ -> return []
-
-    getConNames :: Con -> [Name]
-    getConNames (NormalC name _) = [name]
-    getConNames (RecC name _) = [name]
-    getConNames (InfixC _ name _) = [name]
-    getConNames (ForallC _ _ con) = getConNames con
-    getConNames _ = []
 -}