SJ uses Lenses for great good or for havoc? Discuss!

src/Handler/Course.hs

@@ -16,7 +16,12 @@
 module Handler.Course where
 
 import Import
+
+import Control.Lens
+import Utils.Lens
+import Utils.TH
 import Handler.Utils
+import Handler.Utils.Table.Convenience
 
 -- import Data.Time
 import qualified Data.Text as T
@@ -42,16 +47,21 @@ colCourse = sortable (Just "course") (i18nCell MsgCourse)
             anchorCell (CourseR courseTerm courseSchool courseShorthand CShowR)
               [whamlet|#{display courseName}|]
 
-colCourseDescr :: IsDBTable m a => Colonnade _ CourseTableData (DBCell m a)
+-- colCourseDescr1 :: IsDBTable m a => Colonnade Sortable CourseTableData (DBCell m a)
-colCourseDescr = sortable (Just "course") (i18nCell MsgCourse)
+-- colCourseDescr1 = sortable (Just "course") (i18nCell MsgCourse)
-          $ \DBRow{ dbrOutput=(Entity cid Course{..}, _, _, _) } -> mappend
+--           $ \DBRow{ dbrOutput=(Entity _cid course, _, _, _) } ->
-            ( anchorCell (CourseR courseTerm courseSchool courseShorthand CShowR) [whamlet|#{display courseName}|] )
+--               courseCell course
-            ( case courseDescription of
-                Nothing      -> mempty
-                (Just descr) -> cell [whamlet| <span style="float:right"> ^{modalStatic descr} |]
-            )
 
-colDescription :: IsDBTable m a => Colonnade _ CourseTableData (DBCell m a)
+-- colCourseDescr1 :: IsDBTable m a => Colonnade Sortable CourseTableData (DBCell m a)
+-- colCourseDescr1 = sortable (Just "course") (i18nCell MsgCourse) $ do
+--           course <- view $ _dbrOutput . _1 . _entityVal
+--           return $ courseCell course
+
+-- colCourseDescr1 :: IsDBTable m a => Colonnade Sortable CourseTableData (DBCell m a)
+-- colCourseDescr1 = colCourseDescr _1
+
+
+colDescription :: IsDBTable m a => Colonnade Sortable CourseTableData (DBCell m a)
 colDescription = sortable Nothing (i18nCell MsgCourseDescription)
           $ \DBRow{ dbrOutput=(Entity cid Course{..}, _, _, _) } ->
             case courseDescription of
@@ -91,7 +101,8 @@ colSchoolShort = sortable (Just "schoolshort") (i18nCell MsgCourseSchoolShort)
 colRegFrom :: IsDBTable m a => Colonnade _ CourseTableData (DBCell m a)
 colRegFrom = sortable (Just "register-from") (i18nCell MsgRegisterFrom)
           $ \DBRow{ dbrOutput=(Entity cid Course{..}, _, _, _) } ->
-            cell $ traverse (formatTime SelFormatDateTime) courseRegisterFrom >>= maybe mempty toWidget
+            maybe mempty timeCell courseRegisterFrom
+            -- cell $ traverse (formatTime SelFormatDateTime) courseRegisterFrom >>= maybe mempty toWidget
 
 colRegTo :: IsDBTable m a => Colonnade _ CourseTableData (DBCell m a)
 colRegTo = sortable (Just "register-to") (i18nCell MsgRegisterTo)
@@ -178,7 +189,7 @@ getCourseListR :: Handler Html
 getCourseListR = do -- TODO: Suchfunktion für Kurse und Kürzel!!!
   muid <- maybeAuthId
   let colonnade = widgetColonnade $ mconcat
-        [ colCourseDescr
+        [ colCourseDescr _1
         , colCShort
         , colTerm
         , maybe mempty (const colRegistered) muid

src/Handler/Profile.hs

@@ -14,6 +14,8 @@ module Handler.Profile where
 import Import
 
 import Handler.Utils
+import Handler.Utils.Table.Convenience
+
 import Utils.Lens
 -- import Colonnade hiding (fromMaybe, singleton)
 -- import Yesod.Colonnade
@@ -142,6 +144,29 @@ postProfileR = do
   -- TODO
   getProfileR
 
+----------------------------------------
+-- TODO: Are these really a good idea?
+--  If yes: Move to appropriate Place: Utils.Lens and Utils.Table.Convenience
+
+-- 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
+
+--
 
 
 getProfileDataR  :: Handler Html
@@ -153,23 +178,30 @@ getProfileDataR = do
   -- Tabelle mit allen Teilnehmer: Kurs (link), Datum
   courseTable <- do
         let -- should be inlined
-            -- courseCol :: IsDBTable m a => Colonnade Sortable (DBRow (Entity Course, Entity CourseParticipant)) (DBCell m a)
+            courseCol :: IsDBTable m a => Colonnade Sortable (DBRow (Entity Course, E.Value UTCTime)) (DBCell m a)
             courseCol = sortable (Just "course") (i18nCell MsgCourse) $ do -- (->) a Monad
-              Course{..} <- view $ _dbrOutput . _1 . _entityVal -- view == ^.
+              course <- view $ _dbrOutput . _1 . _entityVal -- view == ^.
               -- "preview _left" in order to match Either (result is Maybe)
-              return $ anchorCell (CourseR courseTerm courseSchool courseShorthand CShowR)
+              return $ courseCell course
-                                  (citext2widget courseName)
+
-            --courseData :: (E.InnerJoin (E.SqlExpr (Entity Course)) (E.SqlExpr (Entity CourseParticipant)))
+--             termCol = sortable (Just "school") (i18nCell MsgCourseSchool) $ do
-            --                -> E.SqlQuery (E.SqlExpr (Entity Course), E.SqlExpr (Entity CourseParticipant))
+--               Course{..} <- view $ _dbrOutput . _1 . _entityVal
+--               return $ anchorCell (TermsSchoolCourseListR
+
+            courseData :: (E.InnerJoin (E.SqlExpr (Entity Course)) (E.SqlExpr (Entity CourseParticipant)))
+                            -> E.SqlQuery (E.SqlExpr (Entity Course), E.SqlExpr (E.Value UTCTime))
             courseData = \(course `E.InnerJoin` participant) -> do
               E.on $ course E.^. CourseId E.==. participant E.^. CourseParticipantCourse
               E.where_ $ participant E.^. CourseParticipantUser E.==. E.val uid
-              return (course, participant)
+              return (course, participant E.^. CourseParticipantRegistration)
         dbTableWidget' def $ DBTable
           { dbtIdent     = "courseMembership" :: Text
           , dbtSQLQuery  = courseData
           , dbtColonnade = mconcat
-              [ courseCol
+              [ colCourseDescrG
+              , sortable (Just "time") (i18nCell MsgRegistered) $ do
+                  regTime <- view $ _dbrOutput . _2 . _unValue
+                  return $ timeCell regTime
               ]
           , dbtProj      = return
           , dbtSorting   = Map.fromList

src/Utils/Lens.hs

@@ -7,9 +7,17 @@ module Utils.Lens ( module Utils.Lens ) where
 
 import Import.NoFoundation
 import Control.Lens as Utils.Lens
+import qualified Database.Esqueleto as E (Value(..))
+
+_unValue :: Lens' (E.Value a) a
+_unValue f (E.Value a) = E.Value <$> f a
 
 makeClassy_ ''Entity
 
 makeClassy_ ''SheetCorrector
 
+makeClassy_ ''Course
+
 -- makeClassy_ ''Load
+
+

src/Utils/TH.hs

@@ -17,14 +17,12 @@ import Language.Haskell.TH
 ------------
 
 -- Alternatively uses lenses: "^. _3" projects the 3rd component of an n-tuple for any n >=3, requires import Control.Lens
-{-
 projNI :: Int -> Int -> ExpQ -- generic projection gives I-th element of N-tuple, i.e. snd3 = $(projNI 3 2)  --ghci -fth
 -- $(projN n m) :: (t1,..,tn) -> tm (for m<=n)
 projNI n i = lamE [pat] rhs
   where pat = tupP (map varP xs)
         rhs = varE (xs !! (i - 1))
         xs  = [ mkName $ "x" ++ show j | j <- [1..n] ]
--}
         
 ---------------
 -- Functions --

src/index.md

@@ -75,6 +75,9 @@ Handler.Utils.Table.Pagination
 Handler.Utils.Table.Pagination.Types
   : `Sortable`-Headedness for colonnade
 
+Handler.Utils.Table.Convenience
+  : extends dbTable with UniWorX specific functions, such as special courseCell
+
 Handler.Utils.Templates
   : Modals