From 2550f7405618a7ef8df16ab149cbff2447963d3c Mon Sep 17 00:00:00 2001 From: SJost Date: Thu, 21 Feb 2019 14:53:45 +0100 Subject: [PATCH] TEST: removing makeCLassyFor maybe build works then? --- src/Handler/Course.hs | 28 +++++++++++++++------------- src/Handler/Utils/Table/Cells.hs | 19 ++++++++++--------- src/Utils/Lens.hs | 25 +++++++++++++------------ src/Utils/Lens/TH.hs | 4 ++-- 4 files changed, 40 insertions(+), 36 deletions(-) diff --git a/src/Handler/Course.hs b/src/Handler/Course.hs index e7cf7276b..bfa554762 100644 --- a/src/Handler/Course.hs +++ b/src/Handler/Course.hs @@ -632,11 +632,12 @@ userTableQuery whereClause returnStatement t@((user `E.InnerJoin` participant) ` E.where_ $ whereClause t return $ returnStatement t -instance HasUser UserTableData where - hasUser = _entityVal - -instance HasEntity UserTableData User where - hasEntity = _dbrOutput . _1 +-- TEST HADDOCK +-- instance HasUser UserTableData where +-- hasUser = _entityVal +-- +-- instance HasEntity UserTableData User where +-- hasEntity = _dbrOutput . _1 -- -- there can be only one -- FunctionalDependency violation -- instance HasEntity UserTableData CourseParticipant where @@ -650,16 +651,17 @@ courseIs cid ((_user `E.InnerJoin` participant) `E.LeftOuterJoin` _note) = parti -- colUserParticipant' = sortable (Just "participant") (i18nCell MsgCourseMember) -- $ \DBRow { dbrOutput=(Entity _ user,_,_) } -> userCell (userDisplayName user) (userSurname user) -colUserParticipant :: IsDBTable m a => Colonnade _ UserTableData (DBCell m a) -colUserParticipant = sortable (Just "participant") (i18nCell MsgCourseMember) cellHasUser +-- TEST HADDOCK +-- 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 +-- colUserMatriclenr :: IsDBTable m a => Colonnade _ UserTableData (DBCell m a) +-- colUserMatriclenr = sortable (Just "matriclenumber") (i18nCell MsgMatrikelNr) cellHasMatrikelnummer colUserComment :: IsDBTable m a => TermId -> SchoolId -> CourseShorthand -> Colonnade _ UserTableData (DBCell m a) colUserComment tid ssh csh = diff --git a/src/Handler/Utils/Table/Cells.hs b/src/Handler/Utils/Table/Cells.hs index 453c04d9e..a2b4ec387 100644 --- a/src/Handler/Utils/Table/Cells.hs +++ b/src/Handler/Utils/Table/Cells.hs @@ -34,17 +34,18 @@ timeCell t = cell $ formatTime SelFormatDateTime t >>= toWidget userCell :: IsDBTable m a => Text -> Text -> DBCell m a userCell displayName surname = cell $ nameWidget displayName surname -cellHasUser :: (IsDBTable m a, HasUser c) => c -> DBCell m a -cellHasUser = liftA2 userCell (view _userDisplayName) (view _userSurname) +-- TEST HADDOCK +-- 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 ^. _entityKey - nWdgt = nameWidget (user ^. _entityVal . _userDisplayName) (user ^. _entityVal . _userSurname) - in anchorCellM (toLink <$> encrypt uid) nWdgt +-- cellHasUserLink :: (IsDBTable m a, HasEntity u User) => (CryptoUUIDUser -> Route UniWorX) -> u -> DBCell m a +-- cellHasUserLink toLink user = +-- let uid = user ^. _entityKey +-- nWdgt = nameWidget (user ^. _entityVal . _userDisplayName) (user ^. _entityVal . _userSurname) +-- in anchorCellM (toLink <$> encrypt uid) nWdgt -cellHasMatrikelnummer :: (IsDBTable m a, HasUser c) => c -> DBCell m a -cellHasMatrikelnummer = maybe mempty textCell . view _userMatrikelnummer +-- cellHasMatrikelnummer :: (IsDBTable m a, HasUser c) => c -> DBCell m a +-- cellHasMatrikelnummer = maybe mempty textCell . view _userMatrikelnummer -- Just for documentation purposes; inline this code instead: maybeTimeCell :: IsDBTable m a => Maybe UTCTime -> DBCell m a diff --git a/src/Utils/Lens.hs b/src/Utils/Lens.hs index 3fea6ff14..42b844180 100644 --- a/src/Utils/Lens.hs +++ b/src/Utils/Lens.hs @@ -25,32 +25,33 @@ _InnerJoinLeft f (E.InnerJoin l r) = (`E.InnerJoin` r) <$> f l _InnerJoinRight :: Lens' (E.InnerJoin l r) r _InnerJoinRight f (E.InnerJoin l r) = (l `E.InnerJoin`) <$> f r - --- makeLenses_ ''Entity -makeClassyFor_ "HasEntity" "hasEntity" ''Entity +-- TEST HADDOCK +makeLenses_ ''Entity +-- makeClassyFor_ "HasEntity" "hasEntity" ''Entity -- class HasEntity c record | c -> record where -- hasEntity :: Lens' c (Entity record) --- makeLenses_ ''Course -makeClassyFor_ "HasCourse" "hasCourse" ''Course +makeLenses_ ''Course +-- makeClassyFor_ "HasCourse" "hasCourse" ''Course -- class HasCourse c where -- hasCourse :: Lens' c Course -instance (HasCourse a) => HasCourse (Entity a) where - hasCourse = _entityVal . hasCourse +-- instance (HasCourse a) => HasCourse (Entity a) where + -- hasCourse = _entityVal . hasCourse -makeClassyFor_ "HasUser" "hasUser" ''User +makeLenses_ ''User +-- makeClassyFor_ "HasUser" "hasUser" ''User -- > :info HasUser --- class HasUser c where {-# MINIMAL hasUser #-} --- hasUser :: Lens' c User +-- class HasUser c where +-- hasUser :: Lens' c User -- MINIMAL -- _userDisplayName :: Lens' c Text -- _userSurname :: Lens' c Text -- _user... -- -- TODO: Is this instance needed? -instance (HasUser a) => HasUser (Entity a) where - hasUser = _entityVal . hasUser +-- instance (HasUser a) => HasUser (Entity a) where + -- hasUser = _entityVal . hasUser -- This is what we would want instead: -- instance (HasEntity a User) => HasUser a where -- hasUser = _entityVal diff --git a/src/Utils/Lens/TH.hs b/src/Utils/Lens/TH.hs index d65e58672..b8d8857a7 100644 --- a/src/Utils/Lens/TH.hs +++ b/src/Utils/Lens/TH.hs @@ -17,7 +17,7 @@ lensRules_ :: LensRules lensRules_ = lensRules & lensField .~ \_ _ n -> [TopName (mkName ('_':nameBase n))] --- | Like lensRules_, but different class and function name +-- | Like @lensRules_@, but different class and function name classyRulesFor_ :: ClassyNamer -> LensRules classyRulesFor_ clsNamer = classyRules & lensClass .~ clsNamer @@ -60,5 +60,5 @@ makeClassyFor_ :: String -> String -> Name -> DecsQ makeClassyFor_ clsName funName = makeFieldOptics (classyRulesFor_ clNamer) where clNamer :: ClassyNamer - -- clNamer _ = Just (clsName, funName) {- for newer versions >= 4.17 =} + -- clNamer _ = Just (clsName, funName) -- for newer versions >= 4.17 clNamer _ = Just (mkName clsName, mkName funName) \ No newline at end of file