Framework for forms in dbTable

src/Foundation.hs

@@ -154,6 +154,9 @@ instance RenderMessage UniWorX TermIdentifier where
     Winter -> renderMessage' $ MsgWinterTerm year
     where renderMessage' = renderMessage foundation ls
 
+instance RenderMessage UniWorX String where
+  renderMessage f ls str = renderMessage f ls $ Text.pack str
+
 
 -- Access Control
 data AccessPredicate

src/Handler/Sheet.hs

@@ -9,6 +9,7 @@
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE PartialTypeSignatures #-}
 
 module Handler.Sheet where
 
@@ -23,7 +24,7 @@ import qualified Data.Text as T
 -- import Data.Function ((&))
 --
 import Colonnade hiding (fromMaybe, singleton)
-import Yesod.Colonnade
+import qualified Yesod.Colonnade as Yesod
 --
 import qualified Data.UUID.Cryptographic as UUID
 import qualified Data.Conduit.List as C
@@ -180,7 +181,7 @@ getSheetList courseEnt = do
     setTitle $ toHtml $ T.append "Übungsblätter " csh
     if null sheets
       then [whamlet|Es wurden noch keine Übungsblätter angelegt.|]
-      else encodeWidgetTable tableDefault colSheets sheets
+      else Yesod.encodeWidgetTable tableDefault colSheets sheets
 
 
 -- Show single sheet
@@ -211,12 +212,14 @@ getSShowR tid csh shn = do
               E.&&. E.not_ (E.isNothing $ file E.^. FileContent)
         -- return desired columns
         return $ (file E.^. FileTitle, file E.^. FileModified, sheetFile E.^. SheetFileType)
-  let colonnadeFiles = mconcat
+  let
-        [ sortable (Just "type") "Typ" $ \(_,_, E.Value ftype) -> textCell $ toPathPiece ftype
+    colonnadeFiles :: Colonnade Sortable _ (DBCell (WidgetT UniWorX IO) ())
-        , sortable (Just "path") "Dateiname" $ anchorCell (\(E.Value fName,_,E.Value fType) -> CSheetR tid csh shn (SFileR fType fName))
+    colonnadeFiles = mconcat
-                                                          (\(E.Value fName,_,_) -> str2widget fName)
+      [ sortable (Just "type") "Typ" $ \(_,_, E.Value ftype) -> textCell $ toPathPiece ftype
-        , sortable (Just "time") "Modifikation" $ \(_,E.Value modified,_) -> stringCell $ formatTimeGerWDT (modified :: UTCTime)
+      , sortable (Just "path") "Dateiname" $ anchorCell (\(E.Value fName,_,E.Value fType) -> CSheetR tid csh shn (SFileR fType fName))
-        ]
+                                                        (\(E.Value fName,_,_) -> str2widget fName)
+      , sortable (Just "time") "Modifikation" $ \(_,E.Value modified,_) -> stringCell $ formatTimeGerWDT (modified :: UTCTime)
+      ]
   fileTable <- dbTable def $ DBTable
     { dbtSQLQuery = fileData
     , dbtColonnade = colonnadeFiles

src/Handler/Submission.hs

@@ -13,6 +13,7 @@
 {-# LANGUAGE ViewPatterns #-}
 {-# LANGUAGE PatternGuards #-}
 {-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE PartialTypeSignatures #-}
 
 module Handler.Submission where
 
@@ -49,7 +50,7 @@ import Data.Bifunctor
 import System.FilePath
 
 import Colonnade hiding (bool)
-import Yesod.Colonnade
+import qualified Yesod.Colonnade as Yesod
 import qualified Text.Blaze.Html5.Attributes as HA
 
 
@@ -236,7 +237,8 @@ submissionHelper tid csh shn (SubmissionMode mcid) = do
   let formText  = Nothing :: Maybe UniWorXMessage
   actionUrl <- Data.Maybe.fromJust <$> getCurrentRoute
   -- Maybe construct a table to display uploaded archive files
-  let colonnadeFiles cid = mconcat
+  let colonnadeFiles :: _ -> Colonnade Sortable _ (DBCell (WidgetT UniWorX IO) ())
+      colonnadeFiles cid = mconcat
         -- [ sortable (Just "type") "Typ" $ \(_,_, E.Value ftype) -> textCell $ toPathPiece ftype
         [ sortable (Just "path") "Dateiname" $ anchorCell (\(Entity _ File{..}) -> SubmissionDownloadSingleR cid fileTitle)
                                                           (\(Entity _ File{..}) -> str2widget fileTitle)
@@ -356,9 +358,9 @@ submissionTable = do
     anchorSubmission (_, cUUID, _) = SubmissionDemoR cUUID
     submissionText (cID, _, _) = toWidget . toPathPiece . CI.foldedCase $ ciphertext cID
     colonnade = mconcat
-      [ headed "Abgabe-ID" $ anchorCell anchorSubmission submissionText
+      [ headed "Abgabe-ID" $ Yesod.anchorCell anchorSubmission submissionText
-      , headed "Kurs" $ anchorCell anchorCourse courseText
+      , headed "Kurs" $ Yesod.anchorCell anchorCourse courseText
-      , headed "Blatt" $ \(_, _, (_, Entity _ Sheet{..}, _)) -> textCell $ sheetName
+      , headed "Blatt" $ \(_, _, (_, Entity _ Sheet{..}, _)) -> Yesod.textCell $ sheetName
       ]
     toExternal :: (CryptoFileNameSubmission, CryptoUUIDSubmission, a) -> Handler CryptoUUIDSubmission
     toExternal (_, cID, _) = return cID

src/Handler/Term.hs

@@ -7,6 +7,7 @@
            , MultiParamTypeClasses
            , TypeFamilies
            , FlexibleContexts
+           , PartialTypeSignatures
   #-}
 
 module Handler.Term where
@@ -18,7 +19,6 @@ import Handler.Utils
 import Yesod.Form.Bootstrap3
 
 import Colonnade hiding (bool)
-import Yesod.Colonnade
 
 import qualified Database.Esqueleto as E
 
@@ -41,33 +41,35 @@ getTermShowR = do
   selectRep $ do
     provideRep $ toJSON . map fst <$> runDB (E.select $ E.from termData)
     provideRep $ do
-      let colonnadeTerms = mconcat
+      let
-            [ sortable Nothing "Kürzel" $ \(Entity tid Term{..},_) -> cell $ do
+        colonnadeTerms :: Colonnade Sortable _ (DBCell (WidgetT UniWorX IO) ())
-                -- Scrap this if to slow, create term edit page instead
+        colonnadeTerms = mconcat
-                adminLink <- handlerToWidget $ isAuthorized (TermEditExistR tid) False
+          [ sortable Nothing "Kürzel" $ \(Entity tid Term{..},_) -> cell $ do
-                [whamlet|
+              -- Scrap this if to slow, create term edit page instead
-                  $if adminLink == Authorized
+              adminLink <- handlerToWidget $ isAuthorized (TermEditExistR tid) False
-                    <a href=@{TermEditExistR tid}>
+              [whamlet|
-                      #{termToText termName}
+                $if adminLink == Authorized
-                  $else
+                  <a href=@{TermEditExistR tid}>
-                      #{termToText termName}
+                    #{termToText termName}
-                |]
+                $else
-            , sortable (Just "lecture-start") "Beginn Vorlesungen" $ \(Entity _ Term{..},_) ->
+                    #{termToText termName}
-                stringCell $ formatTimeGerWD termLectureStart
+              |]
-            , sortable (Just "lecture-end") "Ende Vorlesungen"   $ \(Entity _ Term{..},_) ->
+          , sortable (Just "lecture-start") "Beginn Vorlesungen" $ \(Entity _ Term{..},_) ->
-                stringCell $ formatTimeGerWD termLectureEnd
+              stringCell $ formatTimeGerWD termLectureStart
-            , sortable Nothing "Aktiv" $ \(Entity _ Term{..},_) ->
+          , sortable (Just "lecture-end") "Ende Vorlesungen"   $ \(Entity _ Term{..},_) ->
-                textCell $ bool "" tickmark termActive
+              stringCell $ formatTimeGerWD termLectureEnd
-            , sortable Nothing "Kursliste" $ anchorCell
+          , sortable Nothing "Aktiv" $ \(Entity _ Term{..},_) ->
-                (\(Entity tid _, _) -> TermCourseListR tid)
+              textCell $ (bool "" tickmark termActive :: Text)
-                (\(_, E.Value numCourses) -> [whamlet|_{MsgNumCourses numCourses}|])
+          , sortable Nothing "Kursliste" $ anchorCell
-            , sortable (Just "start") "Semesteranfang" $ \(Entity _ Term{..},_) ->
+            (\(Entity tid _, _) -> TermCourseListR tid)
+            (\(_, E.Value numCourses) -> [whamlet|_{MsgNumCourses numCourses}|])
+          , sortable (Just "start") "Semesteranfang" $ \(Entity _ Term{..},_) ->
               stringCell $ formatTimeGerWD termStart
-            , sortable (Just "end") "Semesterende"   $ \(Entity _ Term{..},_) ->
+          , sortable (Just "end") "Semesterende"   $ \(Entity _ Term{..},_) ->
               stringCell $ formatTimeGerWD termEnd
-            , sortable Nothing "Feiertage im Semester" $ \(Entity _ Term{..},_) ->
+          , sortable Nothing "Feiertage im Semester" $ \(Entity _ Term{..},_) ->
               stringCell $ (intercalate ", ") $ map formatTimeGerWD termHolidays
-            ]
+          ]
       table <- dbTable def $ DBTable
         { dbtSQLQuery = termData
         , dbtColonnade = colonnadeTerms

src/Handler/Utils/Table/Pagination.hs

@@ -10,29 +10,32 @@
            , FlexibleInstances
            , MultiParamTypeClasses
            , TypeFamilies
+           , ScopedTypeVariables
+           , TupleSections
+           , RankNTypes
   #-}
 
 module Handler.Utils.Table.Pagination
   ( SortColumn(..), SortDirection(..)
   , FilterColumn(..), IsFilterColumn
   , DBRow(..), DBOutput
-  , DBTable(..)
+  , DBTable(..), IsDBTable(..)
   , PaginationSettings(..)
   , PSValidator(..)
   , Sortable(..), sortable
   , dbTable
+  , textCell, stringCell, anchorCell
   ) where
 
 import Handler.Utils.Table.Pagination.Types
 
-import Import
+import Import hiding (Proxy(..))
 import qualified Database.Esqueleto as E
 import qualified Database.Esqueleto.Internal.Sql as E (SqlSelect,unsafeSqlValue)
 import qualified Database.Esqueleto.Internal.Language as E (From)
 import Text.Blaze (Attribute)
 import qualified Text.Blaze.Html5.Attributes as Html5
 import qualified Text.Blaze.Html5 as Html5
-import Yesod.Core.Types (Body(..),GWData(..),WidgetT(..))
 
 import qualified Data.Binary.Builder as Builder
 
@@ -42,6 +45,7 @@ import Data.CaseInsensitive (CI)
 import qualified Data.CaseInsensitive as CI
 
 import Control.Monad.RWS hiding ((<>), Foldable(..), mapM_, forM_)
+import Control.Monad.Writer hiding ((<>), Foldable(..), mapM_, forM_)
 
 import Data.Map (Map, (!))
 import qualified Data.Map as Map
@@ -50,12 +54,15 @@ import Data.Profunctor (lmap)
 
 import Colonnade hiding (bool, fromMaybe, singleton)
 import Colonnade.Encode
-import Yesod.Colonnade
 
 import Text.Hamlet (hamletFile)
 
 import Data.Ratio ((%))
 
+import Control.Lens
+
+import Data.Proxy
+
 
 data SortColumn t = forall a. PersistField a => SortColumn { getSortColumn :: t -> E.SqlExpr (E.Value a) }
 
@@ -106,28 +113,28 @@ data DBRow r = DBRow
 class DBOutput r r' where
   dbProj :: r -> r'
 
-instance DBOutput r r where
+instance DBOutput (DBRow r) (DBRow r) where
   dbProj = id
 instance DBOutput (DBRow r) r where
   dbProj = dbrOutput
 instance DBOutput (DBRow r) (Int64, r) where
   dbProj = (,) <$> dbrIndex <*> dbrOutput
 
- 
+data DBTable m x = forall a r r' h i t.
-data DBTable = forall a r r' h i t.
   ( ToSortable h, Functor h
   , E.SqlSelect a r, DBOutput (DBRow r) r'
   , PathPiece i
   , E.From E.SqlQuery E.SqlExpr E.SqlBackend t
   ) => DBTable
   { dbtSQLQuery :: t -> E.SqlQuery a
-  , dbtColonnade :: Colonnade h r' (Cell UniWorX)
+  , dbtColonnade :: Colonnade h r' (DBCell m x)
   , dbtSorting :: Map Text (SortColumn t)
   , dbtFilter :: Map Text (FilterColumn t)
-  , dbtAttrs :: Attribute
+  , dbtAttrs :: Attribute -- FIXME: currently unused
   , dbtIdent :: i
   }
 
+
 data PaginationSettings = PaginationSettings
   { psSorting      :: [(Text, SortDirection)]
   , psFilter       :: Map Text [Text]
@@ -145,9 +152,9 @@ instance Default PaginationSettings where
     , psShortcircuit = False
     }
 
-newtype PSValidator = PSValidator { runPSValidator :: DBTable -> Maybe PaginationSettings -> ([SomeMessage UniWorX], PaginationSettings) }
+newtype PSValidator m x = PSValidator { runPSValidator :: DBTable m x -> Maybe PaginationSettings -> ([SomeMessage UniWorX], PaginationSettings) }
 
-instance Default PSValidator where
+instance Default (PSValidator m x) where
   def = PSValidator $ \DBTable{..} -> \case
     Nothing -> def
     Just ps -> swap . (\act -> execRWS act () ps) $ do
@@ -156,8 +163,59 @@ instance Default PSValidator where
         modify $ \ps -> ps { psLimit = psLimit def }
         tell . pure $ SomeMessage MsgPSLimitNonPositive
 
+class (MonadHandler m, Monoid x) => IsDBTable (m :: * -> *) (x :: *) where
+  type DBResult m x :: *
+  type DBResult' m x :: *
 
-dbTable :: PSValidator -> DBTable -> Handler Widget
+  data DBCell m x :: *
+  cellAttrs :: Lens' (DBCell m x) [(Text, Text)]
+  cellContents :: DBCell m x -> WriterT x m Widget
+
+  cell :: Widget -> DBCell m x
+
+    
+  dbWidget :: Proxy m -> Proxy x -> Iso' (DBResult m x) (Widget, DBResult' m x)
+  runDBTable :: forall m'. (MonadHandler m', HandlerSite m' ~ UniWorX) => m (Widget, x) -> m' (DBResult m x)
+
+instance IsDBTable (WidgetT UniWorX IO) () where
+  type DBResult (WidgetT UniWorX IO) () = Widget
+  type DBResult' (WidgetT UniWorX IO) () = ()
+
+  data DBCell (WidgetT UniWorX IO) () = WidgetCell
+    { dbCellAttrs :: [(Text, Text)]
+    , dbCellContents :: Widget
+    }
+  cellAttrs = lens dbCellAttrs $ \w as -> w { dbCellAttrs = as }
+  cellContents = return . dbCellContents
+
+  cell = WidgetCell []
+  
+  dbWidget Proxy Proxy = iso (, ()) $ view _1
+  runDBTable = return . join . fmap (view _1)
+
+instance Monoid a => IsDBTable (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerT UniWorX IO)) (FormResult a) where
+  type DBResult (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerT UniWorX IO)) (FormResult a) = ((FormResult a, Widget), Enctype)
+  type DBResult' (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerT UniWorX IO)) (FormResult a) = (FormResult a, Enctype)
+
+  data DBCell (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerT UniWorX IO)) (FormResult a) = FormCell
+    { formCellAttrs :: [(Text, Text)]
+    , formCellContents :: MForm (HandlerT UniWorX IO) (FormResult a, Widget)
+    }
+  cellAttrs = lens formCellAttrs $ \w as -> w { formCellAttrs = as }
+  cellContents = WriterT . fmap swap . formCellContents
+
+  cell widget = FormCell [] $ return (mempty, widget)
+  
+  dbWidget Proxy Proxy = iso ((,) <$> view (_1._2) <*> ((,) <$> view (_1._1) <*> view _2))
+                             ((,) <$> ((,) <$> view (_2._1) <*> view _1) <*> view (_2._2))
+  -- runDBTable :: MForm (HandlerT UniWorX IO) (Widget, FormResult a) -> m ((FormResult a, Widget), Enctype)
+  runDBTable = undefined -- use runFormPost
+
+instance IsDBTable m a => IsString (DBCell m a) where
+  fromString = cell . fromString
+      
+
+dbTable :: forall m x. IsDBTable m x => PSValidator m x -> DBTable m x -> Handler (DBResult m x)
 dbTable PSValidator{..} dbtable@(DBTable{ dbtIdent = (toPathPiece -> dbtIdent), dbtColonnade = (lmap dbProj -> dbtColonnade), .. }) = do
   let
     sortingOptions = mkOptionList
@@ -214,23 +272,39 @@ dbTable PSValidator{..} dbtable@(DBTable{ dbtIdent = (toPathPiece -> dbtIdent),
       | otherwise = 0
     rows = map (\((E.Value i, E.Value n), r) -> DBRow i n r) rows'
 
-  bool return (sendResponse <=< tblLayout) psShortcircuit $ do
+    table' :: WriterT x m Widget
-    getParams <- handlerToWidget $ queryToQueryText . Wai.queryString . reqWaiRequest <$> getRequest
+    table' = do
-    let table = $(widgetFile "table/colonnade")
+      getParams <- liftHandlerT $ queryToQueryText . Wai.queryString . reqWaiRequest <$> getRequest
-        pageCount = max 1 . ceiling $ rowCount % psLimit
+
-        pageNumbers = [0..pred pageCount]
+      let
         tblLink f = decodeUtf8 . Builder.toLazyByteString . renderQueryText True $ f getParams
 
-        withSortLinks Sortable{ sortableContent = Cell{..}, .. } = Cell
+        genHeaders SortableP{..} = forM (toSortable . oneColonnadeHead <$> getColonnade dbtColonnade) $ \Sortable{..} -> do
-          { cellContents = $(widgetFile "table/sortable-header")
+          widget <- cellContents sortableContent
-          , cellAttrs = maybe mempty (const sortableAttr) sortableKey <> cellAttrs
+          let
-          }
-          where
             directions = [dir | (k, dir) <- psSorting, Just k == sortableKey ]
-            sortableAttr = Html5.class_ . fromString . unwords $ "sortable" : foldMap toAttr directions
+            isSortable = isJust sortableKey
-            toAttr SortAsc = ["sorted-asc"]
+            isSorted = (`elem` directions)
-            toAttr SortDesc = ["sorted-desc"]
+            attrs = sortableContent ^. cellAttrs
-    $(widgetFile "table/layout")
+          return $(widgetFile "table/cell/header")
+
+      wHeaders <- maybe (return Nothing) (fmap Just . genHeaders) pSortable
+
+      wRows <- forM rows $ \row -> forM (oneColonnadeEncode <$> getColonnade dbtColonnade) $ \(($ row) -> cell) -> do
+        widget <- cellContents cell
+        let attrs = cell ^. cellAttrs
+        return $(widgetFile "table/cell/body")
+      
+      let table = $(widgetFile "table/colonnade")
+          pageCount = max 1 . ceiling $ rowCount % psLimit
+          pageNumbers = [0..pred pageCount]
+
+      return $(widgetFile "table/layout")
+
+    dbWidget' :: Iso' (DBResult m x) (Widget, DBResult' m x)
+    dbWidget' = dbWidget (Proxy :: Proxy m) (Proxy :: Proxy x)
+
+  bool return (sendResponse <=< tblLayout . view (dbWidget' . _1)) psShortcircuit <=< runDBTable $ runWriterT table'
   where
     tblLayout :: Widget -> Handler Html
     tblLayout tbl' = do
@@ -240,22 +314,17 @@ dbTable PSValidator{..} dbtable@(DBTable{ dbtIdent = (toPathPiece -> dbtIdent),
     setParam :: Text -> Maybe Text -> QueryText -> QueryText
     setParam key v qt = (key, v) : [ i | i@(key', _) <- qt, key' /= key ]
 
-widgetFromCell ::
+--- DBCell utility functions
-  (Attribute -> WidgetT site IO () -> WidgetT site IO ())
-  -> Cell site
-  -> WidgetT site IO ()
-widgetFromCell f (Cell attrs contents) =
-  f attrs contents
-td,th ::
-  Attribute -> WidgetT site IO () -> WidgetT site IO ()
 
-td = liftParent Html5.td
+textCell, stringCell :: (RenderMessage UniWorX msg, IsDBTable m a) => msg -> DBCell m a
-th = liftParent Html5.th
+stringCell = textCell
+textCell msg = cell [whamlet|_{msg}|]
 
-liftParent :: (Html -> Html) -> Attribute -> WidgetT site IO a -> WidgetT site IO a
+anchorCell :: IsDBTable m a
-liftParent el attrs (WidgetT f) = WidgetT $ \hdata -> do
+           => (r -> Route UniWorX)
-  (a,gwd) <- f hdata
+           -> (r -> Widget)
-  let Body bodyFunc = gwdBody gwd
+           -> (r -> DBCell m a)
-      newBodyFunc render =
+anchorCell mkRoute mkWidget val = cell $(widgetFile "table/cell/link")
-        el Html5.! attrs $ (bodyFunc render)
+  where
-  return (a,gwd { gwdBody = Body newBodyFunc })
+    route = mkRoute val
+    widget = mkWidget val

src/Handler/Utils/Table/Pagination/Types.hs

@@ -40,4 +40,3 @@ instance ToSortable Headed where
 
 instance ToSortable Headless where
   pSortable = Nothing
- 

templates/table/cell/body.hamlet

@@ -0,0 +1,2 @@
+<td *{attrs}>
+  ^{widget}

templates/table/cell/header.hamlet

@@ -0,0 +1,11 @@
+<th *{attrs} :isSortable:.sortable :isSorted SortAsc:.sorted-asc :isSorted SortDesc:.sorted-desc>
+  $maybe flag <- sortableKey
+    $case directions
+      $of [SortAsc]
+        <a .table__th-link href=#{tblLink $ setParam (wIdent "sorting") (Just $ flag <> "-desc")}>
+          ^{widget}
+      $of _
+        <a .table__th-link href=#{tblLink $ setParam (wIdent "sorting") (Just $ flag <> "-asc")}>
+          ^{widget}
+  $nothing
+    ^{widget}

templates/table/cell/link.hamlet

@@ -0,0 +1,2 @@
+<a href=@{route}>
+  ^{widget}

templates/table/colonnade.hamlet

@@ -1,18 +1,13 @@
 $newline never
 <table id="#{dbtIdent}" .table.table--striped.table--hover>
-  $maybe sortableP <- pSortable
+  $maybe wHeaders' <- wHeaders
-    $with toSortable <- toSortable sortableP
+    <thead>
-      <thead>
+      <tr .table__row.table__row--head>
-        <tr .table__row.table__row--head>
+        $forall widget <- wHeaders'
-          $forall OneColonnade{..} <- getColonnade dbtColonnade
+          ^{widget}
-            <!-- TODO: give ths a class 'table__th' -->
-            <!-- TODO: wrap content of th in 'div.table__th-content' -->
-            ^{widgetFromCell th $ withSortLinks $ toSortable oneColonnadeHead}
   $nothing
   <tbody>
-    $forall row <- rows
+    $forall row <- wRows
       <tr .table__row>
-        $forall OneColonnade{..} <- getColonnade dbtColonnade
+        $forall widget <- row
-          <!-- TODO: give tds a class 'table__td' -->
+          ^{widget}
-          <!-- TODO: wrap content of td in 'div.table__td-content' -->
-          ^{widgetFromCell td $ oneColonnadeEncode row}