minor refactor

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
+instance HasEntity UserTableData CourseParticipant where
-  -- hasUser = _entityVal
+  hasEntity = _dbrOutput . _2
-  hasUser = _dbrOutput . _1 . _entityVal
 
 instance HasEntity UserTableData User where
   hasEntity = _dbrOutput . _1
 
--- there can be only one due to FunctionalDependency violation if we use MakeClassy on Entity
+instance HasUser UserTableData where
-instance HasEntity UserTableData CourseParticipant where
+  -- hasUser = _entityVal
-  hasEntity = _dbrOutput . _2
+  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 :: IsDBTable m a => TermId -> SchoolId -> CourseShorthand -> Colonnade _ UserTableData (DBCell m a)
--- colUserParticipantLink tid ssh csh = sortable (Just "participant") (i18nCell MsgCourseMember) (cellHasUserLink courseLink)
+colUserParticipantLink tid ssh csh = sortable (Just "participant") (i18nCell MsgCourseMember) (cellHasUserLink courseLink)
---   where
+  where
---     courseLink = CourseR tid ssh csh . CUserR
+    courseLink = CourseR tid ssh csh . CUserR
 
 colUserMatriclenr :: IsDBTable m a => Colonnade _ UserTableData (DBCell m a)
 colUserMatriclenr = sortable (Just "matriclenumber") (i18nCell MsgMatrikelNr) cellHasMatrikelnummer

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
+  let userEntity = user ^. hasEntityUser
-      userEntity = user ^. hasEntity
       uid   = userEntity ^. _entityKey
       nWdgt = nameWidget (userEntity ^. _entityVal . _userDisplayName) (userEntity ^.  _entityVal . _userSurname)
   in  anchorCellM (toLink <$> encrypt uid) nWdgt

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:
+-- Lens Definitions for our Types
--- 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)
 
 -- 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
+makeLenses_ ''Entity
-  -- hasUser = _entityVal . hasUser
+-- BUILD SERVER FAILS TO MAKE HADDOCK FOR THE ONE BELOW:
--- This is what we would want instead:
+-- 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