feat(exams): show exam results

src/Database/Esqueleto/Utils.hs

@@ -11,6 +11,7 @@ module Database.Esqueleto.Utils
   , mkContainsFilter, mkContainsFilterWith
   , mkExistsFilter
   , anyFilter, allFilter
+  , orderByList
   , orderByOrd, orderByEnum
   , lower, ciEq
   ) where
@@ -167,12 +168,16 @@ allFilter fltrs needle criterias = F.foldr aux true fltrs
     aux fltr acc = fltr needle criterias E.&&. acc
 
 
+orderByList :: PersistField a => [a] -> E.SqlExpr (E.Value a) -> E.SqlExpr (E.Value Int)
+orderByList vals
+  = let sortUni = zip [1..] vals -- memoize this, might not work due to polymorphism
+     in \x -> E.case_ [ (x E.==. E.val u, E.val i) | (i,u) <- sortUni ] (E.val . succ $ List.length vals)
+  
 orderByOrd :: (Ord a, Finite a, PersistField a) => E.SqlExpr (E.Value a) -> E.SqlExpr (E.Value Int)
-orderByOrd = let sortUni = zip [1..] $ List.sort universeF in -- memoize this, might not work due to polymorphism
+orderByOrd = orderByList $ List.sort universeF
-    \x -> E.case_ [ (x E.==. E.val u, E.val i) | (i,u) <- sortUni ] (E.val (-1))
 
 orderByEnum :: (Enum a, Finite a, PersistField a) => E.SqlExpr (E.Value a) -> E.SqlExpr (E.Value Int)
-orderByEnum x = E.case_ [ (x E.==. E.val u, E.val $ fromEnum u) | u <- universeF ] (E.val (-1))
+orderByEnum = orderByList $ List.sortOn fromEnum universeF
 
 
 lower :: E.SqlString s => E.SqlExpr (E.Value s) -> E.SqlExpr (E.Value s)

src/Foundation.hs

@@ -334,6 +334,23 @@ instance RenderMessage UniWorX StudyDegreeTerm where
 instance RenderMessage UniWorX ExamGrade where
   renderMessage _ _ = pack . (showFixed False :: Deci -> String) . fromRational . review numberGrade
 
+instance RenderMessage UniWorX ExamPassed where
+  renderMessage foundation ls = \case
+    ExamPassed True  -> mr MsgExamPassed
+    ExamPassed False -> mr MsgExamNotPassed
+    where
+      mr :: RenderMessage UniWorX msg => msg -> Text
+      mr = renderMessage foundation ls
+
+instance RenderMessage UniWorX a => RenderMessage UniWorX (ExamResult' a) where
+  renderMessage foundation ls = \case
+    ExamAttended{..} -> mr examResult
+    ExamNoShow       -> mr MsgExamResultNoShow
+    ExamVoided       -> mr MsgExamResultVoided
+    where
+      mr :: RenderMessage UniWorX msg => msg -> Text
+      mr = renderMessage foundation ls
+
 
 -- ToMessage instances for converting raw numbers to Text (no internationalization)
 

src/Handler/Exam/Users.hs

@@ -36,8 +36,8 @@ import Control.Arrow (Kleisli(..))
 import Database.Persist.Sql (deleteWhereCount, updateWhereCount)
 
 
-type ExamUserTableExpr = (E.SqlExpr (Entity ExamRegistration) `E.InnerJoin` E.SqlExpr (Entity User)) `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity ExamOccurrence)) `E.LeftOuterJoin` (E.SqlExpr (Maybe (Entity CourseParticipant)) `E.LeftOuterJoin` (E.SqlExpr (Maybe (Entity StudyFeatures)) `E.InnerJoin` E.SqlExpr (Maybe (Entity StudyDegree)) `E.InnerJoin` E.SqlExpr (Maybe (Entity StudyTerms))))
+type ExamUserTableExpr = (E.SqlExpr (Entity ExamRegistration) `E.InnerJoin` E.SqlExpr (Entity User)) `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity ExamOccurrence)) `E.LeftOuterJoin` (E.SqlExpr (Maybe (Entity CourseParticipant)) `E.LeftOuterJoin` (E.SqlExpr (Maybe (Entity StudyFeatures)) `E.InnerJoin` E.SqlExpr (Maybe (Entity StudyDegree)) `E.InnerJoin` E.SqlExpr (Maybe (Entity StudyTerms)))) `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity ExamResult))
-type ExamUserTableData = DBRow (Entity ExamRegistration, Entity User, Maybe (Entity ExamOccurrence), Maybe (Entity StudyFeatures), Maybe (Entity StudyDegree), Maybe (Entity StudyTerms))
+type ExamUserTableData = DBRow (Entity ExamRegistration, Entity User, Maybe (Entity ExamOccurrence), Maybe (Entity StudyFeatures), Maybe (Entity StudyDegree), Maybe (Entity StudyTerms), Maybe (Entity ExamResult))
 
 instance HasEntity ExamUserTableData User where
   hasEntity = _dbrOutput . _2
@@ -49,22 +49,25 @@ _userTableOccurrence :: Lens' ExamUserTableData (Maybe (Entity ExamOccurrence))
 _userTableOccurrence = _dbrOutput . _3
 
 queryUser :: ExamUserTableExpr -> E.SqlExpr (Entity User)
-queryUser = $(sqlIJproj 2 2) . $(sqlLOJproj 3 1)
+queryUser = $(sqlIJproj 2 2) . $(sqlLOJproj 4 1)
 
 queryStudyFeatures :: ExamUserTableExpr -> E.SqlExpr (Maybe (Entity StudyFeatures))
-queryStudyFeatures = $(sqlIJproj 3 1) . $(sqlLOJproj 2 2) . $(sqlLOJproj 3 3)
+queryStudyFeatures = $(sqlIJproj 3 1) . $(sqlLOJproj 2 2) . $(sqlLOJproj 4 3)
 
 queryExamRegistration :: ExamUserTableExpr -> E.SqlExpr (Entity ExamRegistration)
-queryExamRegistration = $(sqlIJproj 2 1) . $(sqlLOJproj 3 1)
+queryExamRegistration = $(sqlIJproj 2 1) . $(sqlLOJproj 4 1)
 
 queryExamOccurrence :: ExamUserTableExpr -> E.SqlExpr (Maybe (Entity ExamOccurrence))
-queryExamOccurrence = $(sqlLOJproj 3 2)
+queryExamOccurrence = $(sqlLOJproj 4 2)
 
 queryStudyDegree :: ExamUserTableExpr -> E.SqlExpr (Maybe (Entity StudyDegree))
-queryStudyDegree = $(sqlIJproj 3 2) . $(sqlLOJproj 2 2) . $(sqlLOJproj 3 3)
+queryStudyDegree = $(sqlIJproj 3 2) . $(sqlLOJproj 2 2) . $(sqlLOJproj 4 3)
 
 queryStudyField :: ExamUserTableExpr -> E.SqlExpr (Maybe (Entity StudyTerms))
-queryStudyField = $(sqlIJproj 3 3) . $(sqlLOJproj 2 2) . $(sqlLOJproj 3 3)
+queryStudyField = $(sqlIJproj 3 3) . $(sqlLOJproj 2 2) . $(sqlLOJproj 4 3)
+
+queryExamResult :: ExamUserTableExpr -> E.SqlExpr (Maybe (Entity ExamResult))
+queryExamResult = $(sqlLOJproj 4 4)
 
 resultExamRegistration :: Lens' ExamUserTableData (Entity ExamRegistration)
 resultExamRegistration = _dbrOutput . _1
@@ -84,6 +87,9 @@ resultStudyField = _dbrOutput . _6 . _Just
 resultExamOccurrence :: Traversal' ExamUserTableData (Entity ExamOccurrence)
 resultExamOccurrence = _dbrOutput . _3 . _Just
 
+resultExamResult :: Traversal' ExamUserTableData (Entity ExamResult)
+resultExamResult = _dbrOutput . _7 . _Just
+
 data ExamUserTableCsv = ExamUserTableCsv
   { csvEUserSurname :: Maybe Text
   , csvEUserName :: Maybe Text
@@ -200,7 +206,9 @@ postEUsersR tid ssh csh examn = do
     let
       examUsersDBTable = DBTable{..}
         where
-          dbtSQLQuery ((examRegistration `E.InnerJoin` user) `E.LeftOuterJoin` occurrence `E.LeftOuterJoin` (courseParticipant `E.LeftOuterJoin` (studyFeatures `E.InnerJoin` studyDegree `E.InnerJoin` studyField))) = do
+          dbtSQLQuery ((examRegistration `E.InnerJoin` user) `E.LeftOuterJoin` occurrence `E.LeftOuterJoin` (courseParticipant `E.LeftOuterJoin` (studyFeatures `E.InnerJoin` studyDegree `E.InnerJoin` studyField)) `E.LeftOuterJoin` examResult) = do
+            E.on $ examResult E.?. ExamResultUser E.==. E.just (user E.^. UserId)
+             E.&&. examResult E.?. ExamResultExam E.==. E.just (E.val eid)
             E.on $ studyField E.?. StudyTermsId E.==. studyFeatures E.?. StudyFeaturesField
             E.on $ studyDegree E.?. StudyDegreeId E.==. studyFeatures E.?. StudyFeaturesDegree
             E.on $ studyFeatures E.?. StudyFeaturesId E.==. E.joinV (courseParticipant E.?. CourseParticipantField)
@@ -210,7 +218,7 @@ postEUsersR tid ssh csh examn = do
              E.&&. occurrence E.?. ExamOccurrenceId   E.==. examRegistration E.^. ExamRegistrationOccurrence
             E.on $ examRegistration E.^. ExamRegistrationUser E.==. user E.^. UserId
             E.where_ $ examRegistration E.^. ExamRegistrationExam E.==. E.val eid
-            return (examRegistration, user, occurrence, studyFeatures, studyDegree, studyField)
+            return (examRegistration, user, occurrence, studyFeatures, studyDegree, studyField, examResult)
           dbtRowKey = queryExamRegistration >>> (E.^. ExamRegistrationId)
           dbtProj = return
           dbtColonnade = mconcat $ catMaybes
@@ -229,6 +237,8 @@ postEUsersR tid ssh csh examn = do
                 SheetGradeSummary{achievedPoints} <- examBonusAchieved uid bonus
                 SheetGradeSummary{sumSheetsPoints} <- examBonusPossible uid bonus
                 return $ propCell (getSum achievedPoints) (getSum sumSheetsPoints)
+            , guardOn examShowGrades $ sortable (Just "result") (i18nCell MsgExamResult) $ maybe mempty i18nCell . preview (resultExamResult . _entityVal . _examResultResult)
+            , guardOn (not examShowGrades) $ sortable (Just "result-bool") (i18nCell MsgExamResult) $ maybe mempty i18nCell . preview (resultExamResult . _entityVal . _examResultResult . to (over _examResult $ view passingGrade))
             ]
           dbtSorting = Map.fromList
             [ sortUserNameLink     queryUser
@@ -239,6 +249,8 @@ postEUsersR tid ssh csh examn = do
             , sortDegreeShort      queryStudyDegree
             , sortFeaturesSemester queryStudyFeatures
             , ("occurrence", SortColumn $ queryExamOccurrence >>> (E.?. ExamOccurrenceName))
+            , ("result", SortColumn $ queryExamResult >>> (E.?. ExamResultResult))
+            , ("result-bool", SortColumn $ queryExamResult >>> (E.?. ExamResultResult) >>> E.orderByList [Just ExamVoided, Just ExamNoShow, Just $ ExamAttended Grade50])
             ]
           dbtFilter = Map.fromList
             [ fltrUserNameEmail    queryUser
@@ -247,14 +259,30 @@ postEUsersR tid ssh csh examn = do
             , fltrDegree           queryStudyDegree
             , fltrFeaturesSemester queryStudyFeatures
             , ("occurrence", FilterColumn . E.mkContainsFilterWith Just $ queryExamOccurrence >>> (E.?. ExamOccurrenceName))
+            , ("result", FilterColumn . E.mkExactFilterWith Just $ queryExamResult >>> (E.?. ExamResultResult))
+            , ( "result-bool"
+              , FilterColumn $ \row criteria -> if
+                  | Set.null criteria -> E.true
+                  | otherwise -> let passed :: [ExamResultGrade]
+                                     passed = filter (\res -> preview (_examResult . passingGrade) res == Just (ExamPassed True)) universeF
+                                     criteria' = Set.map (fmap $ review passingGrade) criteria
+                                     criteria''
+                                       | ExamAttended (ExamPassed True) `Set.member` criteria
+                                       = criteria' `Set.union` Set.fromList passed
+                                       | otherwise  
+                                       = criteria'
+                                  in queryExamResult row E.?. ExamResultResult `E.in_` E.valList (Just <$> Set.toList criteria'')
+              )
             ]
-          dbtFilterUI mPrev = mconcat
+          dbtFilterUI mPrev = mconcat $ catMaybes
-            [ fltrUserNameEmailUI    mPrev
+            [ Just $ fltrUserNameEmailUI    mPrev
-            , fltrUserMatriclenrUI   mPrev
+            , Just $ fltrUserMatriclenrUI   mPrev
-            , fltrFieldUI            mPrev
+            , Just $ fltrFieldUI            mPrev
-            , fltrDegreeUI           mPrev
+            , Just $ fltrDegreeUI           mPrev
-            , fltrFeaturesSemesterUI mPrev
+            , Just $ fltrFeaturesSemesterUI mPrev
-            , prismAForm (singletonFilter "occurrence") mPrev $ aopt textField (fslI MsgExamOccurrence)
+            , Just $ prismAForm (singletonFilter "occurrence") mPrev $ aopt textField (fslI MsgExamOccurrence)
+            , guardOn examShowGrades $ prismAForm (singletonFilter "result" . maybePrism _PathPiece) mPrev $ aopt (examResultField examGradeField) (fslI MsgExamResult)
+            , guardOn (not examShowGrades) $ prismAForm (singletonFilter "result" . maybePrism _PathPiece) mPrev $ aopt (examResultField examPassedField) (fslI MsgExamResult)
             ]
           dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout }
           dbtParams = DBParamsForm

src/Handler/Utils/Form.hs

@@ -1015,7 +1015,7 @@ examResultField innerField = Field
       , is _ExamNoShow res || is _ExamVoided res
         -> return . Right $ Just res
       | otherwise
-        -> fmap (fmap ExamAttended) <$> fieldParse innerField ts fs
+        -> fmap (fmap ExamAttended) <$> fieldParse innerField (filter (not . (`elem` ["attended", "no-show", "voided"])) ts) fs
   , fieldView = \theId name attrs val isReq -> do
       innerId <- newIdent
       let
@@ -1025,11 +1025,26 @@ examResultField innerField = Field
         innerVal = val >>= maybe (Left "") return . preview _ExamAttended
       [whamlet|
         $newline never
-        <select id=#{theId} name=#{name} *{attrs} :isReq:required>
+        <div>
-          <option value="attended" :is _ExamAttended val':selected>_{MsgExamResultAttended}
+          <select id=#{theId} name=#{name} *{attrs} :isReq:required style="display: inline-block">
-          <option value="no-show" :is _ExamNoShow val':selected>_{MsgExamResultNoShow}
+            <option value="attended" :is _ExamAttended val':selected>_{MsgExamResultAttended}
-          <option value="voided" :is _ExamVoided val':selected>_{MsgExamResultVoided}
+            <option value="no-show" :is _ExamNoShow val':selected>_{MsgExamResultNoShow}
-        <fieldset uw-interactive-fieldset data-conditional-input=#{theId} data-conditional-value="attended">
+            <option value="voided" :is _ExamVoided val':selected>_{MsgExamResultVoided}
-          ^{fieldView innerField innerId name attrs innerVal False}
+          <fieldset uw-interactive-fieldset .interactive-fieldset__target data-conditional-input=#{theId} data-conditional-value="attended" style="display: inline-block">
+            ^{fieldView innerField innerId name attrs innerVal False}
       |]
   }
+
+examGradeField :: forall m.
+                  ( MonadHandler m
+                  , HandlerSite m ~ UniWorX
+                  )
+               => Field m ExamGrade
+examGradeField = hoistField liftHandlerT $ selectField optionsFinite
+
+examPassedField :: forall m.
+                   ( MonadHandler m
+                   , HandlerSite m ~ UniWorX
+                   )
+                => Field m ExamPassed
+examPassedField = hoistField liftHandlerT $ selectField optionsFinite

src/Model/Types/Exam.hs

@@ -12,7 +12,8 @@ module Model.Types.Exam
 import Import.NoModel
 import Model.Types.Common
 
-import Control.Lens
+import Control.Lens hiding (universe)
+import Utils.Lens.TH
 
 import qualified Data.Csv as Csv
 
@@ -28,6 +29,7 @@ deriveJSON defaultOptions
   } ''ExamResult'
 derivePersistFieldJSON ''ExamResult'
 
+makeLenses_ ''ExamResult'
 makePrisms ''ExamResult'
 
 instance PathPiece res => PathPiece (ExamResult' res) where
@@ -73,6 +75,14 @@ instance Csv.FromField res => Csv.FromField (ExamResult' res) where
   parseField "no-show" = pure ExamNoShow
   parseField x = ExamAttended <$> Csv.parseField x
 
+instance Universe res => Universe (ExamResult' res) where
+  universe = concat
+    [ pure ExamVoided
+    , pure ExamNoShow
+    , ExamAttended <$> universe
+    ]
+instance Finite res => Finite (ExamResult' res)
+
 
 data ExamBonusRule = ExamNoBonus
                    | ExamBonusPoints

src/Utils/Lens.hs

@@ -140,6 +140,7 @@ makeLenses_ ''PredDNF
 
 makeLenses_ ''ExamBonusRule
 makeLenses_ ''ExamGradingRule
+makeLenses_ ''ExamResult
 
 makeLenses_ ''UTCTime