diff --git a/src/Database/Esqueleto/Utils/TH.hs b/src/Database/Esqueleto/Utils/TH.hs index 546d85b29..f996ae160 100644 --- a/src/Database/Esqueleto/Utils/TH.hs +++ b/src/Database/Esqueleto/Utils/TH.hs @@ -9,7 +9,7 @@ module Database.Esqueleto.Utils.TH , sqlInTuple, sqlInTuples , _unValue , unValueN, unValueNIs - , sqlIJproj, sqlLOJproj, sqlFOJproj + , sqlIJproj, sqlLOJproj, sqlFOJproj, sqlMIXproj, sqlMIXproj' ) where import ClassyPrelude @@ -99,7 +99,7 @@ unValueNIs arity uvIdx = do -- | Generic projections for InnerJoin-tuples -- gives I-th element of N-tuple of left-associative InnerJoin-pairs, i.e. -- --- > $(projN n m) :: (t1 `E.InnerJoin` .. `E.InnerJoin` tn) -> tm@ (for m<=n) +-- > $(sqlIJproj n m) :: (t1 `E.InnerJoin` .. `E.InnerJoin` tn) -> tm@ (for m<=n) sqlIJproj :: Int -> Int -> ExpQ sqlIJproj = leftAssociativePairProjection 'E.InnerJoin @@ -108,3 +108,27 @@ sqlLOJproj = leftAssociativePairProjection 'E.LeftOuterJoin sqlFOJproj :: Int -> Int -> ExpQ sqlFOJproj = leftAssociativePairProjection 'E.FullOuterJoin + +-- | Generic projections for Join-tuple +-- gives i-th element of n-tuple of left-associative join pairs, i.e. +-- +-- > $(sqlMIXproj "IR" 3) :: ((t1 `E.InnerJoin` t2) `E.RightOuterJoin` t3) -> t3 +sqlMIXproj :: String -> Int -> ExpQ +sqlMIXproj = leftAssociativeProjection . map decodeJoin + where + decodeJoin 'I' = 'E.InnerJoin + decodeJoin 'L' = 'E.LeftOuterJoin + decodeJoin 'R' = 'E.RightOuterJoin + decodeJoin 'F' = 'E.FullOuterJoin + decodeJoin 'O' = 'E.FullOuterJoin + decodeJoin 'X' = 'E.CrossJoin + 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 +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 diff --git a/src/Handler/LMS.hs b/src/Handler/LMS.hs index 15a9f2d34..a1f69c7e4 100644 --- a/src/Handler/LMS.hs +++ b/src/Handler/LMS.hs @@ -299,19 +299,22 @@ instance CsvColumnsExplained LmsTableCsv where type LmsTableExpr = ( E.SqlExpr (Entity QualificationUser) `E.InnerJoin` E.SqlExpr (Entity User) `E.InnerJoin` E.SqlExpr (Entity LmsUser) - ) `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity QualificationUserBlock)) + `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity QualificationUserBlock)) + ) +-- due to GHC staging restrictions, we use the preprocessor instead +#define LMS_TABLE_JOIN "IIL" queryQualUser :: LmsTableExpr -> E.SqlExpr (Entity QualificationUser) -queryQualUser = $(sqlIJproj 3 1) . $(sqlLOJproj 2 1) +queryQualUser = $(sqlMIXproj LMS_TABLE_JOIN 1) queryUser :: LmsTableExpr -> E.SqlExpr (Entity User) -queryUser = $(sqlIJproj 3 2) . $(sqlLOJproj 2 1) +queryUser = $(sqlMIXproj LMS_TABLE_JOIN 2) queryLmsUser :: LmsTableExpr -> E.SqlExpr (Entity LmsUser) -queryLmsUser = $(sqlIJproj 3 3) . $(sqlLOJproj 2 1) +queryLmsUser = $(sqlMIXproj LMS_TABLE_JOIN 3) queryQualBlock :: LmsTableExpr -> E.SqlExpr (Maybe (Entity QualificationUserBlock)) -queryQualBlock = $(sqlLOJproj 2 2) +queryQualBlock = $(sqlMIXproj LMS_TABLE_JOIN 4) type LmsTableData = DBRow (Entity QualificationUser, Entity User, Entity LmsUser, Maybe (Entity QualificationUserBlock), E.Value (Maybe [Maybe UTCTime]), E.Value (Maybe CompanyId), E.Value Bool) diff --git a/src/Handler/School/DayTasks.hs b/src/Handler/School/DayTasks.hs index e37793048..f23b377bd 100644 --- a/src/Handler/School/DayTasks.hs +++ b/src/Handler/School/DayTasks.hs @@ -28,8 +28,10 @@ import qualified Database.Esqueleto.Experimental as E import qualified Database.Esqueleto.PostgreSQL as E import qualified Database.Esqueleto.Legacy as EL (on, from) -- only `on` and `from` are different, needed for dbTable using Esqueleto.Legacy import qualified Database.Esqueleto.Utils as E +import Database.Esqueleto.PostgreSQL.JSON ((@>.)) +import qualified Database.Esqueleto.PostgreSQL.JSON as E hiding ((?.)) import Database.Esqueleto.Utils.TH -import Database.Esqueleto.PostgreSQL.JSON as E + data DailyTableAction = DailyActDummy -- just a dummy, since we don't now yet which actions we will be needing @@ -95,33 +97,59 @@ getDayTutorials ssh dlimit@(dstart, dend ) | otherwise = Nothing + type DailyTableExpr = - ( E.SqlExpr (Entity Course) - `E.InnerJoin` E.SqlExpr (Entity Tutorial) - `E.InnerJoin` E.SqlExpr (Entity TutorialParticipant) - `E.InnerJoin` E.SqlExpr (Entity User) + ( E.SqlExpr (Entity Course) + `E.InnerJoin` E.SqlExpr (Entity Tutorial) + `E.InnerJoin` E.SqlExpr (Entity TutorialParticipant) + `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) + , E.SqlExpr (Entity Tutorial) + , E.SqlExpr (Entity TutorialParticipant) + , E.SqlExpr (Entity User) + , E.SqlExpr (Maybe (Entity UserAvs)) + , E.SqlExpr (E.Value (Maybe CompanyId)) + , E.SqlExpr (E.Value (Maybe [QualificationId])) ) -type DailyTableOutput = E.SqlQuery (E.SqlExpr (Entity Course), E.SqlExpr (Entity Tutorial), E.SqlExpr (Entity TutorialParticipant), E.SqlExpr (Entity User), E.SqlExpr (E.Value (Maybe CompanyId)), E.SqlExpr (E.Value (Maybe [QualificationId]))) type DailyTableData = DBRow ( Entity Course , Entity Tutorial , Entity TutorialParticipant , Entity User + , Maybe (Entity UserAvs) , E.Value (Maybe CompanyId) , E.Value (Maybe [QualificationId]) ) +-- force declarations before this point +$(return []) + + queryCourse :: DailyTableExpr -> E.SqlExpr (Entity Course) -queryCourse = $(sqlIJproj 4 1) +queryCourse = $(sqlMIXproj DAILY_TABLE_JOIN 1) queryTutorial :: DailyTableExpr -> E.SqlExpr (Entity Tutorial) -queryTutorial = $(sqlIJproj 4 2) +queryTutorial = $(sqlMIXproj DAILY_TABLE_JOIN 2) queryParticipant :: DailyTableExpr -> E.SqlExpr (Entity TutorialParticipant) -queryParticipant = $(sqlIJproj 4 3) +-- queryParticipant = $(sqlMIXproj' ''DailyTableExpr 3) -- TODO reify seems problematic for now +queryParticipant = $(sqlMIXproj DAILY_TABLE_JOIN 3) queryUser :: DailyTableExpr -> E.SqlExpr (Entity User) -queryUser = $(sqlIJproj 4 4) +queryUser = $(sqlMIXproj DAILY_TABLE_JOIN 4) + +queryUserAvs :: DailyTableExpr -> E.SqlExpr (Maybe (Entity UserAvs)) +queryUserAvs = $(sqlMIXproj DAILY_TABLE_JOIN 5) resultCourse :: Lens' DailyTableData (Entity Course) resultCourse = _dbrOutput . _1 @@ -132,17 +160,17 @@ resultTutorial = _dbrOutput . _2 resultParticipant :: Lens' DailyTableData (Entity TutorialParticipant) resultParticipant = _dbrOutput . _3 --- resultCompanyId :: Traversal' DailyTableData CompanyId --- resultCompanyId = _dbrOutput . _3 . _entityVal . _tutorialParticipantCompany . _Just - resultUser :: Lens' DailyTableData (Entity User) resultUser = _dbrOutput . _4 +resultUserAvs :: Traversal' DailyTableData UserAvs +resultUserAvs = _dbrOutput . _5 . _Just . _entityVal + resultCompanyId :: Traversal' DailyTableData CompanyId -resultCompanyId = _dbrOutput . _5 . _unValue . _Just +resultCompanyId = _dbrOutput . _6 . _unValue . _Just resultCourseQualis :: Traversal' DailyTableData [QualificationId] -resultCourseQualis = _dbrOutput . _6 . _unValue . _Just +resultCourseQualis = _dbrOutput . _7 . _unValue . _Just instance HasEntity DailyTableData User where @@ -151,22 +179,26 @@ instance HasEntity DailyTableData User where instance HasUser DailyTableData where hasUser = resultUser . _entityVal +-- see colRatedField' for an example of formCell usage + + mkDailyTable :: Bool -> SchoolId -> Day -> DB (FormResult (DailyTableActionData, Set TutorialId), Widget) mkDailyTable isAdmin ssh nd = do tuts <- getDayTutorials ssh (nd,nd) let dbtSQLQuery :: DailyTableExpr -> DailyTableOutput - dbtSQLQuery (crs `E.InnerJoin` tut `E.InnerJoin` tpu `E.InnerJoin` usr) = do + dbtSQLQuery (crs `E.InnerJoin` tut `E.InnerJoin` tpu `E.InnerJoin` usr `E.LeftOuterJoin` avs) = do EL.on $ tut E.^. TutorialCourse E.==. crs E.^. CourseId EL.on $ tut E.^. TutorialId E.==. tpu E.^. TutorialParticipantTutorial EL.on $ usr E.^. UserId E.==. tpu E.^. TutorialParticipantUser + EL.on $ usr E.^. UserId E.=?. avs E.?. UserAvsUser E.where_ $ tut E.^. TutorialId `E.in_` E.valList tuts let associatedQualifications = E.subSelectMaybe . EL.from $ \cq -> do E.where_ $ cq E.^. CourseQualificationCourse E.==. crs E.^. CourseId let cqQual = cq E.^. CourseQualificationQualification cqOrder = [E.asc $ cq E.^. CourseQualificationSortOrder, E.asc cqQual] return $ E.arrayAggWith E.AggModeAll cqQual cqOrder - return (crs, tut, tpu, usr, selectCompanyUserPrime usr, associatedQualifications) + return (crs, tut, tpu, usr, avs, selectCompanyUserPrime usr, associatedQualifications) dbtRowKey = queryTutorial >>> (E.^. TutorialId) dbtProj = dbtProjId dbtColonnade = mconcat @@ -182,6 +214,7 @@ mkDailyTable isAdmin ssh nd = do , sortable (Just "booking-company") (i18nCell MsgTableBookingCompany) $ \(view $ resultParticipant . _entityVal . _tutorialParticipantCompany -> mcid) -> cellMaybe companyIdCell mcid , colUserNameModalHdr MsgCourseParticipant ForProfileDataR , colUserMatriclenr isAdmin + , sortable (Just "card-no") (i18nCell MsgAvsCardNo) $ \(preview $ resultUserAvs . _userAvsLastCardNo . _Just -> cn :: Maybe AvsFullCardNo) -> cellMaybe (textCell . tshowAvsFullCardNo) cn ] dbtSorting = Map.fromList [ sortUserNameLink queryUser @@ -190,6 +223,7 @@ mkDailyTable isAdmin ssh nd = do , ("tutorial" , SortColumn $ queryTutorial >>> (E.^. TutorialName)) , ("user-company" , SortColumn $ queryUser >>> selectCompanyUserPrime) , ("booking-company", SortColumn $ queryParticipant >>> (E.^. TutorialParticipantCompany)) + , ("card-no" , SortColumn $ queryUserAvs >>> (E.?. UserAvsLastCardNo)) ] dbtFilter = Map.fromList [ fltrUserNameEmail queryUser diff --git a/src/Utils/TH.hs b/src/Utils/TH.hs index 88982048b..b10815093 100644 --- a/src/Utils/TH.hs +++ b/src/Utils/TH.hs @@ -55,6 +55,98 @@ 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 +-- 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 + | otherwise = do + x <- newName "x" + lamE [pat x n] (varE x) + where + pat x 0 = varP x + pat x w@(pred -> v) + | 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` +extractConstructorNames :: Name -> Q [Name] +extractConstructorNames td = do + TyConI (TySynD _ [] ty) <- reify td + return (go ty) + where + go :: Type -> [Name] + go (AppT (AppT (ConT name) rest) _) = name : go rest + go _ = [] + +{- +Example: + +Suppose + type LmsTableExpr = ( E.SqlExpr (Entity QualificationUser) + `E.InnerJoin` E.SqlExpr (Entity User) + `E.InnerJoin` E.SqlExpr (Entity LmsUser) + `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity QualificationUserBlock)) + ) +then + info <- reify ''LmsTableExpr +with + info = TyConI (TySynD Handler.Utils.LMS.LmsTableExpr [] + (AppT + (AppT + (ConT Database.Esqueleto.Internal.Internal.LeftOuterJoin) + (AppT + (AppT + (ConT Database.Esqueleto.Internal.Internal.InnerJoin) + (AppT + (AppT + (ConT Database.Esqueleto.Internal.Internal.InnerJoin) + (AppT + (ConT Database.Esqueleto.Internal.Internal.SqlExpr) + (AppT + (ConT Database.Persist.Class.PersistEntity.Entity) + (ConT Model.QualificationUser) + ) ) ) + (AppT (ConT Database.Esqueleto.Internal.Internal.SqlExpr) + (AppT + (ConT Database.Persist.Class.PersistEntity.Entity) + (ConT Model.User) + ) ) ) ) ) + (AppT + (ConT Database.Esqueleto.Internal.Internal.SqlExpr) + (AppT + (ConT Database.Persist.Class.PersistEntity.Entity) + (ConT Model.LmsUser) + ) ) ) ) + (AppT + (ConT Database.Esqueleto.Internal.Internal.SqlExpr) + (AppT + (ConT GHC.Maybe.Maybe) + (AppT + (ConT Database.Persist.Class.PersistEntity.Entity) + (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 _ = [] +-} + --------------- -- Functions -- diff --git a/test/Database/Fill.hs b/test/Database/Fill.hs index d8646159f..bafe207ae 100644 --- a/test/Database/Fill.hs +++ b/test/Database/Fill.hs @@ -744,10 +744,10 @@ fillDb = do for_ [jost] $ \uid -> void . insert' $ UserSchool uid avn False void . insert' $ UserAvs (AvsPersonId 12345678) jost 87654321 (n_day' $ -12) (Just "Some Message here") Nothing Nothing Nothing - void . insert' $ UserAvs (AvsPersonId 2) svaupel 2 (n_day' $ -22) Nothing Nothing Nothing Nothing + void . insert' $ UserAvs (AvsPersonId 2) svaupel 2 (n_day' $ -22) Nothing Nothing Nothing (readAvsFullCardNo "12345.6") void . insert' $ UserAvs (AvsPersonId 3) gkleen 3 (n_day' $ -32) Nothing Nothing Nothing Nothing void . insert' $ UserAvs (AvsPersonId 4) sbarth 4 now Nothing Nothing Nothing Nothing - void . insert' $ UserAvs (AvsPersonId 5) fhamann 5 now (Just "another message from avs synch") Nothing Nothing Nothing + void . insert' $ UserAvs (AvsPersonId 5) fhamann 5 now (Just "another message from avs synch") Nothing Nothing (readAvsFullCardNo "77777.7") void . insert' $ UserAvs (AvsPersonId 77) tinaTester 77 now Nothing Nothing Nothing Nothing let f_descr = Just $ htmlToStoredMarkup [shamlet|

Berechtigung zum Führen eines Fahrzeuges auf den Fahrstrassen des Vorfeldes.|]