diff --git a/src/Handler/Course.hs b/src/Handler/Course.hs index 287266462..03152e5be 100644 --- a/src/Handler/Course.hs +++ b/src/Handler/Course.hs @@ -192,7 +192,7 @@ getCourseListR :: Handler Html getCourseListR = do -- TODO: Suchfunktion für Kurse und Kürzel!!! muid <- maybeAuthId let colonnade = widgetColonnade $ mconcat - [ colCourseDescr _1 + [ colCourseDescr $ _dbrOutput . _1 . _entityVal , colCShort , colTerm , maybe mempty (const colRegistered) muid diff --git a/src/Handler/Profile.hs b/src/Handler/Profile.hs index 106c35c54..a277d704c 100644 --- a/src/Handler/Profile.hs +++ b/src/Handler/Profile.hs @@ -167,29 +167,6 @@ postProfileR = do --- instance HasCourse (DBRow (Entity Course, a)) where --- course = _dbrOutput . _1 . _entityVal - -instance HasCourse a => HasCourse (Entity a) where - course = _entityVal . course - -instance HasCourse a => HasCourse (a,b) where - course = _1 . course - --- instance {-# OVERLAPPABLE #-} HasCourse b => HasCourse (a,b) where --- course = _2 . course - -instance HasCourse a => HasCourse (a,b,c,d) where - course = _1 . course - -instance HasCourse a => HasCourse (DBRow a) where - course = _dbrOutput . course - --- - --- type CourseTableData = E.SqlExpr (Entity Course) `E.InnerJoin` E.SqlExpr (Entity CourseParticipant) --- NOTE: use withType instead as a flexible inlines Type signature - getProfileDataR :: Handler Html getProfileDataR = do (uid, User{..}) <- requireAuthPair @@ -212,7 +189,8 @@ getProfileDataR = do , course E.^. CourseShorthand ) , dbtColonnade = mconcat - [ colsCourseLink' $ _dbrOutput + [ dbRow + , colsCourseLink' $ _dbrOutput -- [ colsCourseLink $ (over each _unValue) . _dbrOutput -- different types in Tuple prevents "over each" ] , dbtProj = return @@ -256,7 +234,8 @@ getProfileDataR = do { dbtIdent = "courseMembership" :: Text , dbtSQLQuery = courseData , dbtColonnade = mconcat - [ colsCourseCompleteG + [ dbRow + , colCourseDescr $ _dbrOutput . _1 . _entityVal -- TODO , sortable (Just "time") (i18nCell MsgRegistered) $ do regTime <- view $ _dbrOutput . _2 . _unValue return $ timeCell regTime @@ -307,7 +286,8 @@ getProfileDataR = do ) return (crse, sht, submission, lastSubEdit submission) , dbtColonnade = mconcat - [ colsCourseLink' $ _dbrOutput . _1 + [ dbRow + , colsCourseLink' $ _dbrOutput . _1 , sortable (Just "sheet") (i18nCell MsgSheet) $ do shn <- view $ _dbrOutput . _2 . _unValue crse <- view $ _dbrOutput . _1 @@ -321,6 +301,8 @@ getProfileDataR = do shn <- view $ _dbrOutput . _2 . _unValue sid <- view $ _dbrOutput . _3 . _entityKey crse <- view $ _dbrOutput . _1 + + let tid = crse ^. _1 . _unValue ssh = crse ^. _2 . _unValue csh = crse ^. _4 . _unValue diff --git a/src/Handler/Utils/Table/Convenience.hs b/src/Handler/Utils/Table/Convenience.hs index 95293a02b..56bcd9227 100644 --- a/src/Handler/Utils/Table/Convenience.hs +++ b/src/Handler/Utils/Table/Convenience.hs @@ -18,7 +18,7 @@ import qualified Database.Esqueleto as E (Value(..)) -- newtype CourseLink = CourseLink (TermId, SchoolId, CourseId, CourseShorthand) -- cannot be in Types due to CourseId type CourseLink = (TermId, SchoolId, CourseId, CourseShorthand) -- cannot be in Types due to CourseId -- TODO: can we get rid of this type through lenses? -type CourseLink' = (E.Value TermId, E.Value SchoolId, E.Value CourseId, E.Value CourseShorthand) -- cannot be in Types due to CourseId +type CourseLink' = (E.Value TermId, E.Value SchoolId, E.Value CourseId, E.Value CourseShorthand) -- cannot be in Types due to CourseId @@ -89,19 +89,19 @@ submissionCell (crse, E.Value shn, submission) = -- Generic Columns +-- -colCourseDescr :: (HasEntity c Course, HasDBRow s r, IsDBTable m a) => +-- - ((c -> Const Course c) -> r -> Const Course r) -> Colonnade Sortable s (DBCell m a) +-- -colCourseDescr courseLens = sortable (Just "course") (i18nCell MsgCourse) $ do +-- - crs <- view $ _dbrOutput . courseLens . _entityVal +-- - return $ courseCell crs +-- - -colCourseDescr :: (HasEntity c Course, HasDBRow s r, IsDBTable m a) => - ((c -> Const Course c) -> r -> Const Course r) -> Colonnade Sortable s (DBCell m a) -colCourseDescr courseLens = sortable (Just "course") (i18nCell MsgCourse) $ do - crs <- view $ _dbrOutput . courseLens . _entityVal - return $ courseCell crs - -colCourseDescr_ :: IsDBTable m a => Getting Course s Course -> Colonnade Sortable s (DBCell m a) -colCourseDescr_ getter = +colCourseDescr :: IsDBTable m a => Getting Course s Course -> Colonnade Sortable s (DBCell m a) +colCourseDescr getter = sortable (Just "course") (i18nCell MsgCourse) $ do crs <- view getter return $ courseCell crs - +{- colCourseDescrG :: (HasCourse s, IsDBTable m a) => Colonnade Sortable s (DBCell m a) colCourseDescrG = sortable (Just "course") (i18nCell MsgCourse) $ do @@ -120,6 +120,7 @@ colsCourseCompleteG = mconcat crs <- view course return $ courseCell crs ] +-} colsCourseLink :: (IsDBTable m a) => Getting CourseLink s CourseLink -> Colonnade Sortable s (DBCell m a) colsCourseLink getter = mconcat diff --git a/src/Handler/Utils/Table/Pagination.hs b/src/Handler/Utils/Table/Pagination.hs index a4bd71657..b051470b5 100644 --- a/src/Handler/Utils/Table/Pagination.hs +++ b/src/Handler/Utils/Table/Pagination.hs @@ -498,6 +498,7 @@ tickmarkCell False = mempty anchorCell :: IsDBTable m a => Route UniWorX -> Widget -> DBCell m a anchorCell = anchorCellM . return +{-# DEPRECATED anchorCell' "For compatibility with Colonnade; better use anchorCell instead." #-} anchorCell' :: IsDBTable m a => (r -> Route UniWorX) -> (r -> Widget) diff --git a/src/Utils/Lens.hs b/src/Utils/Lens.hs index e998bc1ca..888453072 100644 --- a/src/Utils/Lens.hs +++ b/src/Utils/Lens.hs @@ -7,16 +7,18 @@ module Utils.Lens ( module Utils.Lens ) where import Import.NoFoundation import Control.Lens as Utils.Lens +import Utils.Lens.TH + import qualified Database.Esqueleto as E (Value(..)) _unValue :: Lens' (E.Value a) a _unValue f (E.Value a) = E.Value <$> f a -makeClassy_ ''Entity +makeLenses_ ''Entity -makeClassy_ ''SheetCorrector +makeLenses_ ''SheetCorrector -makeClassy_ ''Course +makeLenses_ ''Course -- makeClassy_ ''Load diff --git a/src/Utils/Lens/TH.hs b/src/Utils/Lens/TH.hs new file mode 100644 index 000000000..6f5bf4c14 --- /dev/null +++ b/src/Utils/Lens/TH.hs @@ -0,0 +1,47 @@ +module Utils.Lens.TH where + +import Control.Lens +import Control.Lens.Internal.FieldTH +import Language.Haskell.TH + +-- import Control.Lens.Misc +{- NOTE: The code for lensRules_ and makeLenses_ was stolen from package lens-misc-0.0.2.0, + which was currently unavailable in our stack snapshot. + See https://github.com/louispan/lens-misc +-} + +-- | A 'LensRules' used by 'makeLenses_'. +lensRules_ :: LensRules +lensRules_ = lensRules + & lensField .~ \_ _ n -> [TopName (mkName ('_':nameBase n))] + +-- | Build lenses (and traversals) with a sensible default configuration. +-- Works the same as 'makeLenses' except that +-- the resulting lens is also prefixed with an underscore. +-- +-- /e.g./ +-- +-- @ +-- data FooBar +-- = Foo { x, y :: 'Int' } +-- | Bar { x :: 'Int' } +-- 'makeLenses' ''FooBar +-- @ +-- +-- will create +-- +-- @ +-- _x :: 'Lens'' FooBar 'Int' +-- _x f (Foo a b) = (\\a\' -> Foo a\' b) \<$\> f a +-- _x f (Bar a) = Bar \<$\> f a +-- _y :: 'Traversal'' FooBar 'Int' +-- _y f (Foo a b) = (\\b\' -> Foo a b\') \<$\> f b +-- _y _ c\@(Bar _) = pure c +-- @ +-- +-- @ +-- 'makeLenses_' = 'makeLensesWith' 'lensRules_' +-- @ + +makeLenses_ :: Name -> DecsQ +makeLenses_ = makeFieldOptics lensRules_