diff --git a/src/Handler/Course.hs b/src/Handler/Course.hs index 76d2d6a11..2c2690b23 100644 --- a/src/Handler/Course.hs +++ b/src/Handler/Course.hs @@ -632,16 +632,16 @@ userTableQuery whereClause returnStatement t@((user `E.InnerJoin` participant) ` E.where_ $ whereClause t return $ returnStatement t -instance HasUser UserTableData where - -- hasUser = _entityVal - hasUser = _dbrOutput . _1 . _entityVal +instance HasEntity UserTableData CourseParticipant where + hasEntity = _dbrOutput . _2 instance HasEntity UserTableData User where hasEntity = _dbrOutput . _1 --- there can be only one due to FunctionalDependency violation if we use MakeClassy on Entity -instance HasEntity UserTableData CourseParticipant where - hasEntity = _dbrOutput . _2 +instance HasUser UserTableData where + -- hasUser = _entityVal + hasUser = _dbrOutput . _1 . _entityVal + courseIs :: CourseId -> UserTableWhere courseIs cid ((_user `E.InnerJoin` participant) `E.LeftOuterJoin` _note) = participant E.^. CourseParticipantCourse E.==. E.val cid @@ -655,10 +655,10 @@ courseIs cid ((_user `E.InnerJoin` participant) `E.LeftOuterJoin` _note) = parti colUserParticipant :: IsDBTable m a => Colonnade _ UserTableData (DBCell m a) colUserParticipant = sortable (Just "participant") (i18nCell MsgCourseMember) cellHasUser --- colUserParticipantLink :: IsDBTable m a => TermId -> SchoolId -> CourseShorthand -> Colonnade _ UserTableData (DBCell m a) --- colUserParticipantLink tid ssh csh = sortable (Just "participant") (i18nCell MsgCourseMember) (cellHasUserLink courseLink) --- where --- courseLink = CourseR tid ssh csh . CUserR +colUserParticipantLink :: IsDBTable m a => TermId -> SchoolId -> CourseShorthand -> Colonnade _ UserTableData (DBCell m a) +colUserParticipantLink tid ssh csh = sortable (Just "participant") (i18nCell MsgCourseMember) (cellHasUserLink courseLink) + where + courseLink = CourseR tid ssh csh . CUserR colUserMatriclenr :: IsDBTable m a => Colonnade _ UserTableData (DBCell m a) colUserMatriclenr = sortable (Just "matriclenumber") (i18nCell MsgMatrikelNr) cellHasMatrikelnummer diff --git a/src/Handler/Utils/Table/Cells.hs b/src/Handler/Utils/Table/Cells.hs index 0074ce3cc..802ae21a2 100644 --- a/src/Handler/Utils/Table/Cells.hs +++ b/src/Handler/Utils/Table/Cells.hs @@ -38,9 +38,12 @@ cellHasUser :: (IsDBTable m a, HasUser c) => c -> DBCell m a cellHasUser = liftA2 userCell (view _userDisplayName) (view _userSurname) cellHasUserLink :: (IsDBTable m a, HasEntity u User) => (CryptoUUIDUser -> Route UniWorX) -> u -> DBCell m a +-- cellHasUserLink toLink user = +-- let uid = user ^. hasEntityUser . _entityKey +-- nWdgt = nameWidget (user ^. hasEntityUser . _entityVal . _userDisplayName) (user ^. hasEntityUser . _entityVal . _userSurname) +-- in anchorCellM (toLink <$> encrypt uid) nWdgt cellHasUserLink toLink user = - let userEntity :: Entity User -- needed without the functional dependency - userEntity = user ^. hasEntity + let userEntity = user ^. hasEntityUser uid = userEntity ^. _entityKey nWdgt = nameWidget (userEntity ^. _entityVal . _userDisplayName) (userEntity ^. _entityVal . _userSurname) in anchorCellM (toLink <$> encrypt uid) nWdgt diff --git a/src/Utils/Lens.hs b/src/Utils/Lens.hs index 514679daf..b8ac05e63 100644 --- a/src/Utils/Lens.hs +++ b/src/Utils/Lens.hs @@ -26,23 +26,15 @@ _InnerJoinRight :: Lens' (E.InnerJoin l r) r _InnerJoinRight f (E.InnerJoin l r) = (l `E.InnerJoin`) <$> f r -makeLenses_ ''Entity --- BUILD SERVER FAILS TO MAKE HADDOCK FOR THE ONE BELOW: --- makeClassyFor_ "HasEntity" "hasEntity" ''Entity --- class HasEntity c record | c -> record where --- hasEntity :: Lens' c (Entity record) --- --- Manual attempt, leaving out the unwanted functional dependency -class HasEntity c record where - hasEntity :: Lens' c (Entity record) +----------------------------------- +-- Lens Definitions for our Types + -- makeLenses_ ''Course makeClassyFor_ "HasCourse" "hasCourse" ''Course -- class HasCourse c where -- hasCourse :: Lens' c Course --- instance (HasCourse a) => HasCourse (Entity a) where - -- hasCourse = _entityVal . hasCourse -- makeLenses_ ''User makeClassyFor_ "HasUser" "hasUser" ''User @@ -54,12 +46,28 @@ makeClassyFor_ "HasUser" "hasUser" ''User -- _user... -- --- TODO: Is this instance needed? --- instance (HasUser a) => HasUser (Entity a) where - -- hasUser = _entityVal . hasUser --- This is what we would want instead: + +makeLenses_ ''Entity +-- BUILD SERVER FAILS TO MAKE HADDOCK FOR THE ONE BELOW: +-- makeClassyFor_ "HasEntity" "hasEntity" ''Entity +-- class HasEntity c record | c -> record where +-- hasEntity :: Lens' c (Entity record) +-- +-- Manual definition, explicitely leaving out the unwanted Functional Dependency, since we want Instances differing on the result-type +class HasEntity c record where + hasEntity :: Lens' c (Entity record) + +-- Typed convenience to avoid type signatures, due to the missing FunctionalDepenency that we do not want. +hasEntityUser :: (HasEntity a User) => Lens' a (Entity User) +hasEntityUser = hasEntity + +-- This is what we would want, but is an UndecidableInstance since the type is not reduced: -- instance (HasEntity a User) => HasUser a where --- hasUser = _entityVal +-- hasUser = hasEntityUser +-- +-- Possible, but rather useless: +-- instance (HasUser a) => HasUser (Entity a) where +-- hasUser = _entityVal . hasUser makeLenses_ ''SheetCorrector