chore(day): make form columns compile eventually

src/Foundation/Type.hs

@@ -105,8 +105,8 @@ instance HasCookieSettings RegisteredCookie UniWorX where
 instance (MonadHandler m, HandlerSite m ~ UniWorX) => ReadLogSettings m where
   readLogSettings = liftIO . readTVarIO =<< getsYesod (view _appLogSettings)
 
-
+type DB = YesodDB UniWorX 
-type DB = YesodDB UniWorX
+  --    ~     ReaderT SqlBackend     (HandlerFor UniWorX)
 type DBRead = ReaderT SqlReadBackend (HandlerFor UniWorX)
 type Form x = Html -> MForm (HandlerFor UniWorX) (FormResult x, WidgetFor UniWorX ())
 type MsgRenderer = MsgRendererS UniWorX -- see Utils

src/Handler/School/DayTasks.hs

@@ -34,16 +34,16 @@ import Database.Esqueleto.Utils.TH
 
 
 
-data DailyTableAction = DailyActDummy -- just a dummy, since we don't now yet which actions we will be needing
+-- data DailyTableAction = DailyActDummy -- just a dummy, since we don't now yet which actions we will be needing
-  deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic)
+--   deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic)
 
-instance Universe DailyTableAction
+-- instance Universe DailyTableAction
-instance Finite DailyTableAction
+-- instance Finite DailyTableAction
-nullaryPathPiece ''DailyTableAction $ camelToPathPiece' 2
+-- nullaryPathPiece ''DailyTableAction $ camelToPathPiece' 2
-embedRenderMessage ''UniWorX ''DailyTableAction id
+-- embedRenderMessage ''UniWorX ''DailyTableAction id
 
-data DailyTableActionData = DailyActDummyData
+-- data DailyTableActionData = DailyActDummyData
-  deriving (Eq, Ord, Read, Show, Generic)
+--   deriving (Eq, Ord, Read, Show, Generic)
 
 -- | partial JSON object to be used for filtering with "@>"
 --   ensure that a GIN index for the jsonb column is created in Model.Migration.Definitions
@@ -153,6 +153,7 @@ type DailyTableOutput = E.SqlQuery
   , E.SqlExpr (E.Value (Maybe CompanyId))
   , E.SqlExpr (E.Value (Maybe [QualificationId]))
   )
+
 type DailyTableData   = DBRow
   ( Entity Course
   , Entity Tutorial
@@ -165,6 +166,17 @@ type DailyTableData   = DBRow
   , E.Value (Maybe [QualificationId])
   )
 
+data DailyFormData = DailyFormData
+  { dailyFormDrivingPermit    :: Maybe UserDrivingPermit
+  , dailyFormEyeExam          :: Maybe UserEyeExam
+  , dailyFormParticipantNote  :: Maybe Text
+  , dailyFormAttendance       :: Bool
+  , dailyFormAttendanceNote   :: Maybe Text
+  , dailyFormParkingToken     :: Bool
+  } deriving (Eq, Show)
+
+makeLenses_ ''DailyFormData
+
 -- force declarations before this point to avoid staging restrictions
 $(return [])
 
@@ -233,51 +245,60 @@ drivingPermitField = selectField' Nothing optionsFinite
 eyeExamField :: (RenderMessage (HandlerSite m) FormMessage, MonadHandler m, HandlerSite m ~ UniWorX) => Field m UserEyeExam
 eyeExamField = selectField' Nothing optionsFinite
 
-colParticipantPermitField :: ASetter' a (Maybe UserDrivingPermit) -> Colonnade Sortable DailyTableData (DBCell _ (FormResult (DBFormResult TutorialParticipantId a DailyTableData)))
+colParticipantPermitField :: Colonnade Sortable DailyTableData (DBCell _ (FormResult (DBFormResult TutorialParticipantId DailyFormData DailyTableData)))
-colParticipantPermitField l = sortable (Just "permit") (i18nCell MsgTutorialNote) $ formCell id -- lens focussing on the form result within the larger DBResult; id iff the form delivers the only result of the table
+colParticipantPermitField = colParticipantPermitField' _dailyFormDrivingPermit
+
+colParticipantPermitField' :: ASetter' a (Maybe UserDrivingPermit) -> Colonnade Sortable DailyTableData (DBCell _ (FormResult (DBFormResult TutorialParticipantId a DailyTableData)))
+colParticipantPermitField' l = sortable (Just "permit") (i18nCell MsgTutorialNote) $ formCell id -- lens focussing on the form result within the larger DBResult; id iff the form delivers the only result of the table
   (views (resultParticipant . _entityKey) return) -- generate row identfifiers for use in form result
   (\(view (resultParticipant . _entityVal . _tutorialParticipantDrivingPermit) -> x) mkUnique ->
     over (_1.mapped) (l .~) . over _2 fvWidget <$> mopt drivingPermitField (fsUniq mkUnique "permit") (Just x)
   )   -- Given the row data and a callback to make an input name suitably unique generate the MForm
 
-colParticipantEyeExamField :: ASetter' a (Maybe UserEyeExam) -> Colonnade Sortable DailyTableData (DBCell _ (FormResult (DBFormResult TutorialParticipantId a DailyTableData)))
+colParticipantEyeExamField :: Colonnade Sortable DailyTableData (DBCell _ (FormResult (DBFormResult TutorialParticipantId DailyFormData DailyTableData)))
-colParticipantEyeExamField l = sortable (Just "permit") (i18nCell MsgTutorialNote) $ formCell id -- lens focussing on the form result within the larger DBResult; id iff the form delivers the only result of the table
+colParticipantEyeExamField = colParticipantEyeExamField' _dailyFormEyeExam
-  (views (resultParticipant . _entityKey) return) -- generate row identfifiers for use in form result
+
+colParticipantEyeExamField' :: ASetter' a (Maybe UserEyeExam) -> Colonnade Sortable DailyTableData (DBCell _ (FormResult (DBFormResult TutorialParticipantId a DailyTableData)))
+colParticipantEyeExamField' l = sortable (Just "permit") (i18nCell MsgTutorialNote) $ formCell id
+  (views (resultParticipant . _entityKey) return)
   (\(view (resultParticipant . _entityVal . _tutorialParticipantEyeExam) -> x) mkUnique ->
     over (_1.mapped) (l .~) . over _2 fvWidget <$> mopt eyeExamField (fsUniq mkUnique "eye-exam") (Just x)
-  )   -- Given the row data and a callback to make an input name suitably unique generate the MForm
+  )
 
-colParticipantNoteField :: ASetter' a (Maybe Text) -> Colonnade Sortable DailyTableData (DBCell _ (FormResult (DBFormResult TutorialParticipantId a DailyTableData)))
+colParticipantNoteField :: Colonnade Sortable DailyTableData (DBCell _ (FormResult (DBFormResult TutorialParticipantId DailyFormData DailyTableData)))
-colParticipantNoteField l = sortable (Just "note-participant") (i18nCell MsgTutorialNote) $ (cellAttrs <>~ [("style","width:60%")]) <$> formCell id -- lens focussing on the form result within the larger DBResult; id iff the form delivers the only result of the table
+colParticipantNoteField = sortable (Just "note-participant") (i18nCell MsgTutorialNote) $ (cellAttrs <>~ [("style","width:60%")]) <$> formCell id
-  (views (resultParticipant . _entityKey) return) -- generate row identfifiers for use in form result
+  (views (resultParticipant . _entityKey) return)
   (\(view (resultParticipant . _entityVal . _tutorialParticipantNote) -> note) mkUnique ->
-    over (_1.mapped) ((l .~) . assertM (not . null) . fmap (Text.strip . unTextarea)) . over _2 fvWidget <$>
+    over (_1.mapped) ((_dailyFormParticipantNote .~) . assertM (not . null) . fmap (Text.strip . unTextarea)) . over _2 fvWidget <$>
       mopt textareaField (fsUniq mkUnique "note-participant") (Just $ Textarea <$> note)
-  )   -- Given the row data and a callback to make an input name suitably unique generate the MForm
+  )
 
-colAttendanceField :: Text -> ASetter' a Bool -> Colonnade Sortable DailyTableData (DBCell _ (FormResult (DBFormResult TutorialParticipantId a DailyTableData)))
+colAttendanceField :: Text -> Colonnade Sortable DailyTableData (DBCell _ (FormResult (DBFormResult TutorialParticipantId DailyFormData DailyTableData)))
-colAttendanceField dday l = sortable (Just "attendance") (i18nCell $ MsgTutorialDayAttendance dday) $ formCell id -- lens focussing on the form result within the larger DBResult; id iff the form delivers the only result of the table
+colAttendanceField dday = sortable (Just "attendance") (i18nCell $ MsgTutorialDayAttendance dday) $ formCell id
-  (views (resultParticipant . _entityKey) return) -- generate row identfifiers for use in form result
+  (views (resultParticipant . _entityKey) return)
   (\(preview (resultParticipantDay . _tutorialParticipantDayAttendance) -> attendance) mkUnique ->
-    over (_1.mapped) (l .~) . over _2 fvWidget <$> mreq checkBoxField (fsUniq mkUnique "attendance") attendance
+    over (_1.mapped) (_dailyFormAttendance .~) . over _2 fvWidget <$> mreq checkBoxField (fsUniq mkUnique "attendance") attendance
-  )   -- Given the row data and a callback to make an input name suitably unique generate the MForm
+  )
 
-colAttendnaceNoteField :: Text -> ASetter' a (Maybe Text) -> Colonnade Sortable DailyTableData (DBCell _ (FormResult (DBFormResult TutorialParticipantId a DailyTableData)))
+colAttendanceNoteField :: Text -> Colonnade Sortable DailyTableData (DBCell _ (FormResult (DBFormResult TutorialParticipantId DailyFormData DailyTableData)))
-colAttendnaceNoteField dday l = sortable (Just "note-attendance") (i18nCell $ MsgTutorialDayNote dday) $ (cellAttrs <>~ [("style","width:60%")]) <$> formCell id -- lens focussing on the form result within the larger DBResult; id iff the form delivers the only result of the table
+colAttendanceNoteField dday = sortable (Just "note-attendance") (i18nCell $ MsgTutorialDayNote dday) $ (cellAttrs <>~ [("style","width:60%")]) <$> formCell id
-  (views (resultParticipant . _entityKey) return) -- generate row identfifiers for use in form result
+  (views (resultParticipant . _entityKey) return)
   (\(preview (resultParticipantDay . _tutorialParticipantDayNote) -> note) mkUnique ->
-    over (_1.mapped) ((l .~) . assertM (not . null) . fmap (Text.strip . unTextarea)) . over _2 fvWidget <$>
+    over (_1.mapped) ((_dailyFormAttendanceNote .~) . assertM (not . null) . fmap (Text.strip . unTextarea)) . over _2 fvWidget <$>
       mopt textareaField (fsUniq mkUnique "note-attendance") (Textarea <<$>> note)
-  )   -- Given the row data and a callback to make an input name suitably unique generate the MForm
+  )
 
-colParkingField :: ASetter' a Bool -> Colonnade Sortable DailyTableData (DBCell _ (FormResult (DBFormResult TutorialParticipantId a DailyTableData)))
+colParkingField :: Colonnade Sortable DailyTableData (DBCell _ (FormResult (DBFormResult TutorialParticipantId DailyFormData DailyTableData)))
-colParkingField l = sortable (Just "parking") (i18nCell MsgTableUserParkingToken) $ formCell id -- lens focussing on the form result within the larger DBResult; id iff the form delivers the only result of the table
+colParkingField = colParkingField' _dailyFormParkingToken
-  (views (resultParticipant . _entityKey) return) -- generate row identfifiers for use in form result
+
+colParkingField' :: ASetter' a Bool -> Colonnade Sortable DailyTableData (DBCell _ (FormResult (DBFormResult TutorialParticipantId a DailyTableData)))
+colParkingField' l = sortable (Just "parking") (i18nCell MsgTableUserParkingToken) $ formCell id
+  (views (resultParticipant . _entityKey) return)
   (\(preview (resultUserDay . _userDayParkingToken) -> parking) mkUnique ->
     over (_1.mapped) (l .~) . over _2 fvWidget <$> mreq checkBoxField (fsUniq mkUnique "parktoken") parking
-  )   -- Given the row data and a callback to make an input name suitably unique generate the MForm
+  )
 
-mkDailyTable :: Bool -> SchoolId -> Day -> DB (FormResult (DailyTableActionData, Set TutorialId), Widget)
+mkDailyTable :: Bool -> SchoolId -> Day -> DB (FormResult (DBFormResult TutorialParticipantId DailyFormData DailyTableData), Widget)
 mkDailyTable isAdmin ssh nd = do
   tutLessons <- getDayTutorials' ssh (nd,nd)
   dday <- formatTime SelFormatDate nd
@@ -303,7 +324,7 @@ mkDailyTable isAdmin ssh nd = do
       return (crs, tut, tpu, usr, avs, udy, tdy, selectCompanyUserPrime usr, associatedQualifications)
     dbtRowKey = queryParticipant >>> (E.^. TutorialParticipantId)
     dbtProj   = dbtProjId
-    dbtColonnade = mconcat
+    dbtColonnade = formColonnade $ mconcat
       [ -- dbSelect (applying _2) id (return . view (resultTutorial . _entityKey))
         sortable (Just "course")    (i18nCell MsgFilterCourse)     $ \(view $ resultCourse . _entityVal -> c) -> courseCell c
       , sortable (Just "tutorial")  (i18nCell MsgCourseTutorial)   $ \row ->
@@ -328,7 +349,12 @@ mkDailyTable isAdmin ssh nd = do
       , sortable (Just "attendance")    (i18nCell $ MsgTutorialDayAttendance dday) $ \(preview $ resultParticipantDay . _tutorialParticipantDayAttendance        -> x) -> x & cellMaybe tickmarkCell
       , sortable (Just "note-attend")   (i18nCell $ MsgTutorialDayNote       dday) $ \(preview $ resultParticipantDay . _tutorialParticipantDayNote . _Just      -> x) -> x & cellMaybe textCell
       , sortable (Just "parking")       (i18nCell   MsgTableUserParkingToken)      $ \(preview $ resultUserDay . _userDayParkingToken -> x) -> maybeCell x tickmarkCell
-      -- , colParkingField id -- TODO
+      , colParticipantPermitField
+      , colParticipantEyeExamField
+      , colParticipantNoteField
+      , colAttendanceField     dday
+      , colAttendanceNoteField dday
+      , colParkingField
       ]
     dbtSorting = Map.fromList
       [ sortUserNameLink queryUser
@@ -365,33 +391,40 @@ mkDailyTable isAdmin ssh nd = do
     dbtCsvEncode = noCsvEncode
     dbtCsvDecode = Nothing
     dbtExtraReps = []
-    dbtParams = DBParamsForm
+    dbtParams    = def { dbParamsFormAction = Just $ SomeRoute $ SchoolR ssh $ SchoolDayR nd }
-      { dbParamsFormMethod = POST
+    -- dbtParams = DBParamsForm
-      , dbParamsFormAction = Nothing -- Just $ SomeRoute currentRoute
+    --   { dbParamsFormMethod = POST
-      , dbParamsFormAttrs  = []
+    --   , dbParamsFormAction = Nothing -- Just $ SomeRoute currentRoute
-      , dbParamsFormSubmit = FormNoSubmit
+    --   , dbParamsFormAttrs  = []
-      , dbParamsFormAdditional = \_csrf -> return (FormMissing, mempty)
+    --   , dbParamsFormSubmit = FormSubmit
-      -- , dbParamsFormSubmit = FormSubmit
+    --   , dbParamsFormAdditional = \frag -> do
-      -- , dbParamsFormAdditional
+    --       let acts :: Map DailyTableAction (AForm Handler DailyTableActionData)
-      --     = let acts :: Map MCTableAction (AForm Handler MCTableActionData)
+    --           acts = mconcat
-      --           acts = mconcat
+    --                   [ singletonMap DailyActDummy $ pure DailyActDummyData
-      --             [ singletonMap MCActDummy $ pure MCActDummyData
+    --                    ]
-      --             ]
+    --       (actionRes, action) <- multiActionM acts "" Nothing mempty
-      --        in renderAForm FormStandard
+    --       return ((, mempty) . Last . Just <$> actionRes, toWidget frag <> action)
-      --          $  (, mempty) . First . Just
+    --   -- , dbParamsFormAdditional
-      --         <$> multiActionA acts (fslI MsgTableAction) Nothing
+    --   --     = let acts :: Map DailyTableAction (AForm Handler DailyTableActionData)
-      , dbParamsFormEvaluate = liftHandler . runFormPost
+    --   --           acts = mconcat
-      , dbParamsFormResult   = id
+    --   --             [ singletonMap DailyActDummy $ pure DailyActDummyData
-      , dbParamsFormIdent    = def
+    --   --             ]
-      }
+    --   --        in renderAForm FormStandard
-    postprocess :: FormResult (First DailyTableActionData, DBFormResult TutorialId Bool DailyTableData)
+    --   --          $  (, mempty) . First . Just
-                -> FormResult (      DailyTableActionData,          Set TutorialId)
+    --   --         <$> multiActionA acts (fslI MsgTableAction) Nothing
-    postprocess inp = do
+    --   , dbParamsFormEvaluate = liftHandler . runFormPost
-        (First (Just act), jobMap) <- inp
+    --   , dbParamsFormResult   = _1
-        let jobSet = Map.keysSet . Map.filter id $ getDBFormResult (const False) jobMap
+    --   , dbParamsFormIdent    = def
-        return (act, jobSet)
+    --   }
+    -- postprocess :: FormResult (First DailyTableActionData, DBFormResult TutorialParticipantId Bool DailyTableData)
+    --             -> FormResult (      DailyTableActionData,          Set TutorialId)
+    -- postprocess inp = do
+    --     (First (Just act), jobMap) <- inp
+    --     let jobSet = Map.keysSet . Map.filter id $ getDBFormResult (const False) jobMap
+    --     return (act, jobSet)
     psValidator = def & defaultSorting [SortAscBy "user-name", SortAscBy "course", SortAscBy "tutorial"]
-  over _1 postprocess <$> dbTable psValidator DBTable{..}
+  -- over _1 postprocess <$> dbTable psValidator DBTable{..}
+  dbTable psValidator DBTable{..}
 
 
 getSchoolDayR,  postSchoolDayR :: SchoolId -> Day -> Handler Html