diff --git a/src/Database/Esqueleto/Utils/TH.hs b/src/Database/Esqueleto/Utils/TH.hs index f996ae160..b3eb51643 100644 --- a/src/Database/Esqueleto/Utils/TH.hs +++ b/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 diff --git a/src/Handler/School/DayTasks.hs b/src/Handler/School/DayTasks.hs index f23b377bd..08f24cc72 100644 --- a/src/Handler/School/DayTasks.hs +++ b/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 diff --git a/src/Utils/TH.hs b/src/Utils/TH.hs index b10815093..c8b14d704 100644 --- a/src/Utils/TH.hs +++ b/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 _ = [] -}