diff --git a/messages/uniworx/categories/courses/submission/de-de-formal.msg b/messages/uniworx/categories/courses/submission/de-de-formal.msg index 54a7795d5..b2b734946 100644 --- a/messages/uniworx/categories/courses/submission/de-de-formal.msg +++ b/messages/uniworx/categories/courses/submission/de-de-formal.msg @@ -228,4 +228,35 @@ SubmissionColumnAuthorshipStatementTime: Zeitstempel SubmissionColumnAuthorshipStatementWording: Wortlaut SubmissionFilterAuthorshipStatementCurrent: Aktueller Wortlaut -SubmissionNoUsers: Diese Abgabe hat keine assoziierten Benutzer! \ No newline at end of file +SubmissionNoUsers: Diese Abgabe hat keine assoziierten Benutzer! + +CsvColumnCorrectionTerm: Semester des Kurses der Abgabe +CsvColumnCorrectionSchool: Institut des Kurses der Abgabe +CsvColumnCorrectionCourse: Kürzel des Kurses der Abgabe +CsvColumnCorrectionSheet: Name des Übungsblatts der Abgabe +CsvColumnCorrectionSubmission: Nummer der Abgabe (uwa…) +CsvColumnCorrectionSurname: Nachnamen der Abgebenden als Semikolon (;) separierte Liste +CsvColumnCorrectionFirstName: Vornamen der Abgebenden als Semikolon (;) separierte Liste +CsvColumnCorrectionName: Volle Namen der Abgebenden als Semikolon (;) separierte Liste +CsvColumnCorrectionMatriculation: Matrikelnummern der Abgebenden als Semikolon (;) separierte Liste +CsvColumnCorrectionEmail: E-Mail Adressen der Abgebenden als Semikolon (;) separierte Liste +CsvColumnCorrectionPseudonym: Abgabe-Pseudonyme der Abgebenden als Semikolon (;) separierte Liste +CsvColumnCorrectionSubmissionGroup: Feste Abgabegruppen der Abgebenden als Semikolon (;) separierte Liste +CsvColumnCorrectionAuthorshipStatementState: Zustände der Eigenständigkeitserklärungen ("#{toPathPiece ASMissing}", "#{toPathPiece ASOldStatement}" oder "#{toPathPiece ASExists}") als Semikolon (;) separierte Liste +CsvColumnCorrectionCorrectorName: Voller Name des Korrektors der Abgabe +CsvColumnCorrectionCorrectorEmail: E-Mail Adresse des Korrektors der Abgabe +CsvColumnCorrectionRatingDone: Bewertung abgeschlossen ("t"/"f") +CsvColumnCorrectionRatedAt: Zeitpunkt der Bewertung (ISO 8601) +CsvColumnCorrectionAssigned: Zeitpunkt der Zuteilung des Korrektors (ISO 8601) +CsvColumnCorrectionLastEdit: Zeitpunkt der letzten Änderung der Abgabe (ISO 8601) +CsvColumnCorrectionRatingPoints: Erreichte Punktezahl (Für “_{MsgSheetGradingPassBinary}” entspricht 0 “_{MsgRatingNotPassed}” und alles andere “_{MsgRatingPassed}”) +CsvColumnCorrectionRatingComment: Bewertungskommentar + +CorrectionTableCsvNameSheetCorrections tid@TermId ssh@SchoolId csh@CourseShorthand shn@SheetName: #{foldCase (termToText (unTermKey tid))}-#{foldedCase (unSchoolKey ssh)}-#{foldedCase csh}-#{foldedCase shn}-abgaben +CorrectionTableCsvSheetNameSheetCorrections tid@TermId ssh@SchoolId csh@CourseShorthand shn@SheetName: #{foldCase (termToText (unTermKey tid))}-#{foldedCase (unSchoolKey ssh)}-#{foldedCase csh}-#{foldedCase shn} Abgaben +CorrectionTableCsvNameCourseCorrections tid@TermId ssh@SchoolId csh@CourseShorthand: #{foldCase (termToText (unTermKey tid))}-#{foldedCase (unSchoolKey ssh)}-#{foldedCase csh}-abgaben +CorrectionTableCsvSheetNameCourseCorrections tid@TermId ssh@SchoolId csh@CourseShorthand: #{foldCase (termToText (unTermKey tid))}-#{foldedCase (unSchoolKey ssh)}-#{foldedCase csh} Abgaben +CorrectionTableCsvNameCorrections: abgaben +CorrectionTableCsvSheetNameCorrections: Abgaben +CorrectionTableCsvNameCourseUserCorrections tid@TermId ssh@SchoolId csh@CourseShorthand displayName@Text: #{foldCase (termToText (unTermKey tid))}-#{foldedCase (unSchoolKey ssh)}-#{foldedCase csh}-#{foldCase displayName}-abgaben +CorrectionTableCsvSheetNameCourseUserCorrections tid@TermId ssh@SchoolId csh@CourseShorthand displayName@Text: #{foldCase (termToText (unTermKey tid))}-#{foldedCase (unSchoolKey ssh)}-#{foldedCase csh}-#{foldCase displayName} Abgaben \ No newline at end of file diff --git a/messages/uniworx/categories/courses/submission/en-eu.msg b/messages/uniworx/categories/courses/submission/en-eu.msg index e7f96147c..1e9adbd3b 100644 --- a/messages/uniworx/categories/courses/submission/en-eu.msg +++ b/messages/uniworx/categories/courses/submission/en-eu.msg @@ -228,3 +228,34 @@ SubmissionColumnAuthorshipStatementWording: Wording SubmissionFilterAuthorshipStatementCurrent: Current wording SubmissionNoUsers: This submission has no associated users! + +CsvColumnCorrectionTerm: Term of the course of the submission +CsvColumnCorrectionSchool: School of the course of the submission +CsvColumnCorrectionCourse: Shorthand of the course of the submission +CsvColumnCorrectionSheet: Name of the sheet of the submission +CsvColumnCorrectionSubmission: Number of the submission (uwa…) +CsvColumnCorrectionSurname: Submittor's surnames, separated by semicolon (;) +CsvColumnCorrectionFirstName: Submittor's first names, separated by semicolon (;) +CsvColumnCorrectionName: Submittor's full names, separated by semicolon (;) +CsvColumnCorrectionMatriculation: Submittor's matriculations, separated by semicolon (;) +CsvColumnCorrectionEmail: Submittor's email addresses, separated by semicolon (;) +CsvColumnCorrectionPseudonym: Submittor's submission pseudonyms, separated by semicolon (;) +CsvColumnCorrectionSubmissionGroup: Submittor's submisson groups, separated by semicolon (;) +CsvColumnCorrectionAuthorshipStatementState: States of the statements of authorship ("#{toPathPiece ASMissing}", "#{toPathPiece ASOldStatement}", or "#{toPathPiece ASExists}"), separated by semicolon (;) +CsvColumnCorrectionCorrectorName: Full name of the corrector of the submission +CsvColumnCorrectionCorrectorEmail: Email address of the corrector of the submission +CsvColumnCorrectionRatingDone: Rating done ("t"/"f") +CsvColumnCorrectionRatedAt: Timestamp of rating (ISO 8601) +CsvColumnCorrectionAssigned: Timestamp of when corrector was assigned (ISO 8601) +CsvColumnCorrectionLastEdit: Timestamp of the last edit of the submission (ISO 8601) +CsvColumnCorrectionRatingPoints: Achieved points (for “_{MsgSheetGradingPassBinary}” 0 means “_{MsgRatingNotPassed}”, everything else means “_{MsgRatingPassed}”) +CsvColumnCorrectionRatingComment: Rating comment + +CorrectionTableCsvNameSheetCorrections tid ssh csh shn: #{foldCase (termToText (unTermKey tid))}-#{foldedCase (unSchoolKey ssh)}-#{foldedCase csh}-#{foldedCase shn}-submissions +CorrectionTableCsvSheetNameSheetCorrections tid ssh csh shn: #{foldCase (termToText (unTermKey tid))}-#{foldedCase (unSchoolKey ssh)}-#{foldedCase csh}-#{foldedCase shn} Submissions +CorrectionTableCsvNameCourseCorrections tid ssh csh: #{foldCase (termToText (unTermKey tid))}-#{foldedCase (unSchoolKey ssh)}-#{foldedCase csh}-submissions +CorrectionTableCsvSheetNameCourseCorrections tid ssh csh: #{foldCase (termToText (unTermKey tid))}-#{foldedCase (unSchoolKey ssh)}-#{foldedCase csh} Submissions +CorrectionTableCsvNameCorrections: submissions +CorrectionTableCsvSheetNameCorrections: Submissions +CorrectionTableCsvNameCourseUserCorrections tid ssh csh displayName: #{foldCase (termToText (unTermKey tid))}-#{foldedCase (unSchoolKey ssh)}-#{foldedCase csh}-#{foldCase displayName}-submissions +CorrectionTableCsvSheetNameCourseUserCorrections tid ssh csh displayName: #{foldCase (termToText (unTermKey tid))}-#{foldedCase (unSchoolKey ssh)}-#{foldedCase csh}-#{foldCase displayName} Submissions diff --git a/src/Data/Scientific/Instances.hs b/src/Data/Scientific/Instances.hs index cee91482d..8c0c83e89 100644 --- a/src/Data/Scientific/Instances.hs +++ b/src/Data/Scientific/Instances.hs @@ -9,7 +9,9 @@ import Data.Scientific import Web.PathPieces +import Text.ParserCombinators.ReadP (readP_to_S) + instance PathPiece Scientific where toPathPiece = pack . formatScientific Fixed Nothing - fromPathPiece = readFromPathPiece + fromPathPiece = fmap fst . listToMaybe . filter (\(_, rStr) -> null rStr) . readP_to_S scientificP . unpack diff --git a/src/Data/Word/Word24/Instances.hs b/src/Data/Word/Word24/Instances.hs index e1d6add1a..b80cdc620 100644 --- a/src/Data/Word/Word24/Instances.hs +++ b/src/Data/Word/Word24/Instances.hs @@ -12,6 +12,8 @@ import System.Random (Random(..)) import Data.Aeson (FromJSON(..), ToJSON(..)) import qualified Data.Aeson.Types as Aeson +import Web.PathPieces + import Data.Word.Word24 import Control.Lens @@ -19,6 +21,7 @@ import Control.Lens import Control.Monad.Fail import qualified Data.Scientific as Scientific +import Data.Scientific.Instances () import Data.Binary import Data.Bits @@ -51,6 +54,10 @@ instance FromJSON Word24 where instance ToJSON Word24 where toJSON = Aeson.Number . fromIntegral +instance PathPiece Word24 where + toPathPiece p = toPathPiece (fromIntegral p :: Word32) + fromPathPiece = Scientific.toBoundedInteger <=< fromPathPiece + -- | Big Endian instance Binary Word24 where diff --git a/src/Foundation/I18n.hs b/src/Foundation/I18n.hs index 9dc051554..f85cc309a 100644 --- a/src/Foundation/I18n.hs +++ b/src/Foundation/I18n.hs @@ -308,6 +308,8 @@ embedRenderMessageVariant ''UniWorX ''ADInvalidCredentials ("InvalidCredentials" embedRenderMessage ''UniWorX ''SchoolAuthorshipStatementMode id embedRenderMessage ''UniWorX ''SheetAuthorshipStatementMode id +embedRenderMessage ''UniWorX ''AuthorshipStatementSubmissionState $ concat . ("SubmissionAuthorshipStatementState" :) . drop 1 . splitCamel + newtype ShortSex = ShortSex Sex embedRenderMessageVariant ''UniWorX ''ShortSex ("Short" <>) diff --git a/src/Handler/Course/User.hs b/src/Handler/Course/User.hs index 5db9da78b..7ef122422 100644 --- a/src/Handler/Course/User.hs +++ b/src/Handler/Course/User.hs @@ -240,7 +240,7 @@ courseUserNoteSection (Entity cid Course{..}) (Entity uid _) = do courseUserSubmissionsSection :: Entity Course -> Entity User -> MaybeT Handler Widget -courseUserSubmissionsSection (Entity cid Course{..}) (Entity uid _) = do +courseUserSubmissionsSection (Entity cid Course{..}) (Entity uid User{..}) = do guardM . lift . hasWriteAccessTo $ CourseR courseTerm courseSchool courseShorthand CCorrectionsR let whereClause :: CorrectionTableWhere @@ -268,7 +268,13 @@ courseUserSubmissionsSection (Entity cid Course{..}) (Entity uid _) = do , filterUISubmission ] psValidator = def & defaultPagesize PagesizeAll -- Assisstant always want to see them all at once anyway - (cWdgt, statistics) <- lift . correctionsR' whereClause colonnade filterUI psValidator $ Map.fromList + csvSettings = Just CorrectionTableCsvSettings + { cTableCsvQualification = CorrectionTableCsvQualifySheet + , cTableCsvName = MsgCorrectionTableCsvNameCourseUserCorrections courseTerm courseSchool courseShorthand userDisplayName + , cTableCsvSheetName = MsgCorrectionTableCsvSheetNameCourseUserCorrections courseTerm courseSchool courseShorthand userDisplayName + , cTableShowCorrector = True + } + (cWdgt, statistics) <- lift . correctionsR' whereClause colonnade filterUI csvSettings psValidator $ Map.fromList [ downloadAction , assignAction (Left cid) , deleteAction diff --git a/src/Handler/Course/Users.hs b/src/Handler/Course/Users.hs index 2a12a905c..0d25a488b 100644 --- a/src/Handler/Course/Users.hs +++ b/src/Handler/Course/Users.hs @@ -197,17 +197,13 @@ instance Csv.ToNamedRecord UserTableCsv where , "email" Csv..= csvUserEmail , "study-features" Csv..= csvUserStudyFeatures , "submission-group" Csv..= csvUserSubmissionGroup - ] ++ - [ let tutsStr = Text.intercalate "; " . map CI.original $ csvUserTutorials ^. _1 - in "tutorial" Csv..= tutsStr + , "tutorial" Csv..= CsvSemicolonList (csvUserTutorials ^. _1) ] ++ [ encodeUtf8 (CI.foldedCase regGroup) Csv..= (CI.original <$> mTut) | (regGroup, mTut) <- Map.toList $ csvUserTutorials ^. _2 ] ++ - [ let examsStr = Text.intercalate "; " $ map CI.original csvUserExams - in "exams" Csv..= examsStr - ] ++ - [ "registration" Csv..= csvUserRegistration + [ "exams" Csv..= CsvSemicolonList csvUserExams + , "registration" Csv..= csvUserRegistration ] ++ [ encodeUtf8 (CI.foldedCase shn) Csv..= res | (shn, res) <- Map.toList csvUserSheets diff --git a/src/Handler/Submission/Grade.hs b/src/Handler/Submission/Grade.hs index 1ddb8019e..d805b574e 100644 --- a/src/Handler/Submission/Grade.hs +++ b/src/Handler/Submission/Grade.hs @@ -64,7 +64,7 @@ postCorrectionsGradeR = do & defaultSorting [SortDescBy "ratingtime"] :: PSValidator (MForm (HandlerFor UniWorX)) (FormResult (DBFormResult SubmissionId (Bool, Maybe Points, Maybe Text) CorrectionTableData)) unFormResult = getDBFormResult $ \(view $ resultSubmission . _entityVal -> sub@Submission{..}) -> (submissionRatingDone sub, submissionRatingPoints, submissionRatingComment) - (fmap unFormResult -> tableRes, table) <- runDB $ makeCorrectionsTable whereClause displayColumns filterUI psValidator $ def + (fmap unFormResult -> tableRes, table) <- runDB $ makeCorrectionsTable whereClause displayColumns filterUI Nothing psValidator $ def { dbParamsFormAction = Just $ SomeRoute CorrectionsGradeR } diff --git a/src/Handler/Submission/List.hs b/src/Handler/Submission/List.hs index 14f1fdb29..f1ded3f63 100644 --- a/src/Handler/Submission/List.hs +++ b/src/Handler/Submission/List.hs @@ -14,6 +14,7 @@ module Handler.Submission.List , makeCorrectionsTable , CorrectionTableData, CorrectionTableWhere , ActionCorrections(..), downloadAction, deleteAction, assignAction, autoAssignAction + , CorrectionTableCsvQualification(..), CorrectionTableCsvSettings(..) ) where import Import hiding (link) @@ -23,7 +24,6 @@ import Handler.Utils.Submission import Handler.Utils.SheetType import Handler.Utils.Delete -import Data.List as List (foldr) import qualified Data.Set as Set import qualified Data.Map.Strict as Map @@ -42,6 +42,8 @@ import Database.Persist.Sql (updateWhereCount) import Data.List (genericLength) +import qualified Data.Csv as Csv + data CorrectionTableFilterProj = CorrectionTableFilterProj { corrProjFilterSubmission :: Maybe (Set [CI Char]) @@ -66,7 +68,7 @@ type CorrectionTableExpr = ( E.SqlExpr (Entity Course) `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity User)) type CorrectionTableWhere = forall m. MonadReader CorrectionTableExpr m => m (E.SqlExpr (E.Value Bool)) type CorrectionTableCourseData = (CourseName, CourseShorthand, TermId, SchoolId) -type CorrectionTableUserData = (User, Maybe Pseudonym, Maybe SubmissionGroupName) +type CorrectionTableUserData = (User, Maybe Pseudonym, Maybe SubmissionGroupName, Maybe AuthorshipStatementSubmissionState) type CorrectionTableData = DBRow ( Entity Submission , Entity Sheet , CorrectionTableCourseData @@ -135,6 +137,9 @@ resultUserPseudonym = _2 . _Just resultUserSubmissionGroup :: Traversal' CorrectionTableUserData SubmissionGroupName resultUserSubmissionGroup = _3 . _Just +resultUserAuthorshipStatementState :: Traversal' CorrectionTableUserData AuthorshipStatementSubmissionState +resultUserAuthorshipStatementState = _4 . _Just + resultCryptoID :: Lens' CorrectionTableData CryptoFileNameSubmission resultCryptoID = _dbrOutput . _7 @@ -145,6 +150,159 @@ resultASState :: Lens' CorrectionTableData (Maybe AuthorshipStatementSubmissionS resultASState = _dbrOutput . _9 +data CorrectionTableCsv = CorrectionTableCsv + { csvCorrectionTerm :: Maybe TermIdentifier + , csvCorrectionSchool :: Maybe SchoolShorthand + , csvCorrectionCourse :: Maybe CourseShorthand + , csvCorrectionSheet :: Maybe SheetName + , csvCorrectionSubmission :: Maybe (CI Text) + , csvCorrectionLastEdit :: Maybe UTCTime + , csvCorrectionSurname :: Maybe [Maybe UserSurname] + , csvCorrectionFirstName :: Maybe [Maybe UserFirstName] + , csvCorrectionName :: Maybe [Maybe UserDisplayName] + , csvCorrectionMatriculation :: Maybe [Maybe UserMatriculation] + , csvCorrectionEmail :: Maybe [Maybe UserEmail] + , csvCorrectionPseudonym :: Maybe [Maybe Pseudonym] + , csvCorrectionSubmissionGroup :: Maybe [Maybe SubmissionGroupName] + , csvCorrectionAuthorshipStatementState :: Maybe [Maybe AuthorshipStatementSubmissionState] + , csvCorrectionAssigned :: Maybe UTCTime + , csvCorrectionCorrectorName :: Maybe UserDisplayName + , csvCorrectionCorrectorEmail :: Maybe UserEmail + , csvCorrectionRatingDone :: Maybe Bool + , csvCorrectionRatedAt :: Maybe UTCTime + , csvCorrectionRatingPoints :: Maybe Points + , csvCorrectionRatingComment :: Maybe Text + } deriving (Generic) +makeLenses_ ''CorrectionTableCsv + +correctionTableCsvOptions :: Csv.Options +correctionTableCsvOptions = Csv.defaultOptions { Csv.fieldLabelModifier = camelToPathPiece' 2 } + +instance Csv.ToNamedRecord CorrectionTableCsv where + toNamedRecord CorrectionTableCsv{..} = Csv.namedRecord + [ "term" Csv..= csvCorrectionTerm + , "school" Csv..= csvCorrectionSchool + , "course" Csv..= csvCorrectionCourse + , "sheet" Csv..= csvCorrectionSheet + , "submission" Csv..= csvCorrectionSubmission + , "last-edit" Csv..= csvCorrectionLastEdit + , "surname" Csv..= maybe mempty (Csv.toField . CsvSemicolonList) csvCorrectionSurname + , "first-name" Csv..= maybe mempty (Csv.toField . CsvSemicolonList) csvCorrectionFirstName + , "name" Csv..= maybe mempty (Csv.toField . CsvSemicolonList) csvCorrectionName + , "matriculation" Csv..= maybe mempty (Csv.toField . CsvSemicolonList . mkEmpty) csvCorrectionMatriculation + , "email" Csv..= maybe mempty (Csv.toField . CsvSemicolonList) csvCorrectionEmail + , "pseudonym" Csv..= maybe mempty (Csv.toField . CsvSemicolonList . mkEmpty) csvCorrectionPseudonym + , "submission-group" Csv..= maybe mempty (Csv.toField . CsvSemicolonList . mkEmpty) csvCorrectionSubmissionGroup + , "authorship-statement-state" Csv..= maybe mempty (Csv.toField . CsvSemicolonList . mkEmpty) csvCorrectionAuthorshipStatementState + , "assigned" Csv..= csvCorrectionAssigned + , "corrector-name" Csv..= csvCorrectionCorrectorName + , "corrector-email" Csv..= csvCorrectionCorrectorEmail + , "rating-done" Csv..= csvCorrectionRatingDone + , "rated-at" Csv..= csvCorrectionRatedAt + , "rating-points" Csv..= csvCorrectionRatingPoints + , "rating-comment" Csv..= csvCorrectionRatingComment + ] + where + mkEmpty = \case + [Nothing] -> [] + x -> x + +instance Csv.DefaultOrdered CorrectionTableCsv where + headerOrder = Csv.genericHeaderOrder correctionTableCsvOptions + +instance Csv.FromNamedRecord CorrectionTableCsv where + parseNamedRecord csv + = CorrectionTableCsv + <$> csv .:?? "term" + <*> csv .:?? "school" + <*> csv .:?? "course" + <*> csv .:?? "sheet" + <*> csv .:?? "submission" + <*> csv .:?? "last-edit" + <*> fmap (fmap unCsvSemicolonList) (csv .:?? "surname") + <*> fmap (fmap unCsvSemicolonList) (csv .:?? "first-name") + <*> fmap (fmap unCsvSemicolonList) (csv .:?? "name") + <*> fmap (fmap unCsvSemicolonList) (csv .:?? "matriculation") + <*> fmap (fmap unCsvSemicolonList) (csv .:?? "email") + <*> fmap (fmap unCsvSemicolonList) (csv .:?? "pseudonym") + <*> fmap (fmap unCsvSemicolonList) (csv .:?? "submission-group") + <*> fmap (fmap unCsvSemicolonList) (csv .:?? "authorship-statement-state") + <*> csv .:?? "assigned" + <*> csv .:?? "corrector-name" + <*> csv .:?? "corrector-email" + <*> csv .:?? "rating-done" + <*> csv .:?? "rated-at" + <*> csv .:?? "rating-points" + <*> csv .:?? "rating-comment" + +instance CsvColumnsExplained CorrectionTableCsv where + csvColumnsExplanations = genericCsvColumnsExplanations correctionTableCsvOptions $ Map.fromList + [ ('csvCorrectionTerm , MsgCsvColumnCorrectionTerm) + , ('csvCorrectionSchool , MsgCsvColumnCorrectionSchool) + , ('csvCorrectionCourse , MsgCsvColumnCorrectionCourse) + , ('csvCorrectionSheet , MsgCsvColumnCorrectionSheet) + , ('csvCorrectionSubmission , MsgCsvColumnCorrectionSubmission) + , ('csvCorrectionLastEdit , MsgCsvColumnCorrectionLastEdit) + , ('csvCorrectionSurname , MsgCsvColumnCorrectionSurname) + , ('csvCorrectionFirstName , MsgCsvColumnCorrectionFirstName) + , ('csvCorrectionName , MsgCsvColumnCorrectionName) + , ('csvCorrectionMatriculation , MsgCsvColumnCorrectionMatriculation) + , ('csvCorrectionEmail , MsgCsvColumnCorrectionEmail) + , ('csvCorrectionPseudonym , MsgCsvColumnCorrectionPseudonym) + , ('csvCorrectionSubmissionGroup, MsgCsvColumnCorrectionSubmissionGroup) + , ('csvCorrectionAuthorshipStatementState, MsgCsvColumnCorrectionAuthorshipStatementState) + , ('csvCorrectionAssigned , MsgCsvColumnCorrectionAssigned) + , ('csvCorrectionCorrectorName , MsgCsvColumnCorrectionCorrectorName) + , ('csvCorrectionCorrectorEmail , MsgCsvColumnCorrectionCorrectorEmail) + , ('csvCorrectionRatingDone , MsgCsvColumnCorrectionRatingDone) + , ('csvCorrectionRatedAt , MsgCsvColumnCorrectionRatedAt) + , ('csvCorrectionRatingPoints , MsgCsvColumnCorrectionRatingPoints) + , ('csvCorrectionRatingComment , MsgCsvColumnCorrectionRatingComment) + ] + +data CorrectionTableCsvQualification + = CorrectionTableCsvNoQualification + | CorrectionTableCsvQualifySheet + | CorrectionTableCsvQualifyCourse + deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable) + deriving anyclass (Universe, Finite) + +correctionTableCsvHeader :: Bool -- ^ @showCorrector@ + -> CorrectionTableCsvQualification -> Csv.Header +correctionTableCsvHeader showCorrector qual = Csv.header $ catMaybes + [ guardOn (qual >= CorrectionTableCsvQualifyCourse) "term" + , guardOn (qual >= CorrectionTableCsvQualifyCourse) "school" + , guardOn (qual >= CorrectionTableCsvQualifyCourse) "course" + , guardOn (qual >= CorrectionTableCsvQualifySheet) "sheet" + , pure "submission" + , pure "last-edit" + , pure "surname" + , pure "first-name" + , pure "name" + , pure "matriculation" + , pure "email" + , pure "pseudonym" + , pure "submission-group" + , pure "authorship-statement-state" + , pure "assigned" + , guardOn showCorrector "corrector-name" + , guardOn showCorrector "corrector-email" + , pure "rating-done" + , pure "rated-at" + , pure "rating-points" + , pure "rating-comment" + ] + +data CorrectionTableCsvSettings = forall filename sheetName. + ( RenderMessage UniWorX filename, RenderMessage UniWorX sheetName + ) => CorrectionTableCsvSettings + { cTableCsvQualification :: CorrectionTableCsvQualification + , cTableCsvName :: filename + , cTableCsvSheetName :: sheetName + , cTableShowCorrector :: Bool + } + + -- Where Clauses ratedBy :: UserId -> CorrectionTableWhere ratedBy uid = views querySubmission $ (E.==. E.justVal uid) . (E.^. SubmissionRatingBy) @@ -206,10 +364,10 @@ colSubmittors = sortable (Just "submittors") (i18nCell MsgSubmissionUsers) $ \x ssh = x ^. resultCourseSchool csh = x ^. resultCourseShorthand link uCID = CourseR tid ssh csh $ CUserR uCID - protoCell = listCell (sortOn (view $ _2 . resultUserUser . $(multifocusG 2) _userSurname _userDisplayName) $ itoListOf resultSubmittors x) $ \((encrypt -> mkUCID), u) -> + protoCell = listCell (sortOn (view $ _2 . resultUserUser . $(multifocusG 2) _userSurname _userDisplayName) $ itoListOf resultSubmittors x) $ \(encrypt -> mkUCID, u) -> let User{..} = u ^. resultUserUser mPseudo = u ^? resultUserPseudonym - in anchorCellCM $cacheIdentHere (link <$> mkUCID) $ + in anchorCellCM $cacheIdentHere (link <$> mkUCID) [whamlet| $newline never ^{nameWidget userDisplayName userSurname} @@ -298,7 +456,7 @@ colCommentField' l = sortable (Just "comment") (i18nCell MsgRatingComment) $ (ce (\(view (resultSubmission . _entityVal) -> Submission{..}) mkUnique -> over (_1.mapped) ((l .~) . assertM (not . null) . fmap (Text.strip . unTextarea)) . over _2 fvWidget <$> mopt textareaField (fsUniq mkUnique "comment") (Just $ Textarea <$> submissionRatingComment)) colLastEdit :: IsDBTable m a => Colonnade Sortable CorrectionTableData (DBCell m a) -colLastEdit = sortable (Just "last-edit") (i18nCell MsgTableLastEdit) $ \x -> maybeCell (x ^? resultLastEdit) dateTimeCell +colLastEdit = sortable (Just "last-edit") (i18nCell MsgTableLastEdit) $ \x -> maybeCell (guardOnM (x ^. resultNonAnonymousAccess) $ x ^? resultLastEdit) dateTimeCell colAuthorshipStatementState :: forall m a. IsDBTable m a => Colonnade Sortable CorrectionTableData (DBCell m a) colAuthorshipStatementState = sortable (Just "as-state") (i18nCell MsgSubmissionUserAuthorshipStatementState) $ \x -> @@ -314,7 +472,7 @@ colAuthorshipStatementState = sortable (Just "as-state") (i18nCell MsgSubmission cID = x ^. resultCryptoID asRoute = CSubmissionR tid ssh csh shn cID SubAuthorshipStatementsR - in maybeCell (x ^. resultASState) (\s -> heatC s $ anchorCell asRoute (i18n s :: Widget)) + in maybeCell (guardOnM (x ^. resultNonAnonymousAccess) $ x ^. resultASState) (\s -> heatC s $ anchorCell asRoute (i18n s :: Widget)) filterUICourse :: Handler (OptionList Text) -> DBFilterUI @@ -364,8 +522,8 @@ filterUIAuthorshipStatementState = flip (prismAForm $ singletonFilter "as-state" makeCorrectionsTable :: ( IsDBTable m x, ToSortable h, Functor h ) - => CorrectionTableWhere -> Colonnade h CorrectionTableData (DBCell m x) -> _ -> PSValidator m x -> DBParams m x -> DB (DBResult m x) -makeCorrectionsTable whereClause dbtColonnade dbtFilterUI' psValidator dbtParams + => CorrectionTableWhere -> Colonnade h CorrectionTableData (DBCell m x) -> _ -> Maybe CorrectionTableCsvSettings -> PSValidator m x -> DBParams m x -> DB (DBResult m x) +makeCorrectionsTable whereClause dbtColonnade dbtFilterUI' mCSVSettings psValidator dbtParams = let dbtSQLQuery = runReaderT $ do course <- view queryCourse sheet <- view querySheet @@ -396,12 +554,6 @@ makeCorrectionsTable whereClause dbtColonnade dbtFilterUI' psValidator dbtParams let haystack = map CI.mk . unpack $ toPathPiece cid in guard $ any (`isInfixOf` haystack) criteria - mASDefinition <- lift . lift . $cachedHereBinary shId $ getSheetAuthorshipStatement sheet - asState <- for mASDefinition $ \_ -> - lift . lift . $cachedHereBinary sId $ getSubmissionAuthorshipStatement mASDefinition sId - - forMM_ (preview $ _dbtProjFilter . _corrProjFilterAuthorshipStatementState . _Wrapped . _Just) $ \criterion -> - guard $ asState == Just criterion submittors <- lift . lift . E.select . E.from $ \((submissionUser `E.InnerJoin` user) `E.LeftOuterJoin` pseudonym) -> do E.on $ pseudonym E.?. SheetPseudonymUser E.==. E.just (user E.^. UserId) @@ -416,8 +568,15 @@ makeCorrectionsTable whereClause dbtColonnade dbtFilterUI' psValidator dbtParams return . E.just $ submissionGroup E.^. SubmissionGroupName return (user, pseudonym E.?. SheetPseudonymPseudonym, submissionGroup') - let - submittorMap = List.foldr (\(Entity userId user, E.Value pseudo, E.Value sGroup) -> Map.insert userId (user, pseudo, sGroup)) Map.empty submittors + + mASDefinition <- lift . lift . $cachedHereBinary shId $ getSheetAuthorshipStatement sheet + (submittorMap, fmap getMax -> asState) <- runWriterT . flip foldMapM submittors $ \(Entity userId user, E.Value pseudo, E.Value sGroup) -> do + asState <- for mASDefinition $ \_ -> lift . lift . lift $ getUserAuthorshipStatement mASDefinition sId userId + tell $ Max <$> asState + return $ Map.singleton userId (user, pseudo, sGroup, asState) + + forMM_ (preview $ _dbtProjFilter . _corrProjFilterAuthorshipStatementState . _Wrapped . _Just) $ \criterion -> + guard $ asState == Just criterion forMM_ (view $ _dbtProjFilter . _corrProjFilterPseudonym) $ \criteria -> let haystacks = setOf (folded . resultUserPseudonym . re _PseudonymText . to (map CI.mk . unpack)) submittorMap @@ -502,7 +661,41 @@ makeCorrectionsTable whereClause dbtColonnade dbtFilterUI' psValidator dbtParams dbtFilterUI = fromMaybe mempty dbtFilterUI' dbtStyle = def { dbsFilterLayout = maybe (\_ _ _ -> id) (const defaultDBSFilterLayout) dbtFilterUI' } dbtIdent = "corrections" :: Text - dbtCsvEncode = noCsvEncode + dbtCsvEncode = do + CorrectionTableCsvSettings{..} <- mCSVSettings + return DBTCsvEncode + { dbtCsvExportForm = pure () + , dbtCsvNoExportData = Just id + , dbtCsvDoEncode = \() -> awaitForever $ \(_, row) -> runReaderC row $ do + submittors <- asks $ sortOn (view $ resultUserUser . $(multifocusG 2) _userSurname _userDisplayName ) . toListOf resultSubmittors + forM_ (bool pure (map pure) False submittors) $ \submittors' -> transPipe (withReaderT (, submittors')) $ do + let guardNonAnonymous = runMaybeT . guardMOnM (view $ _1 . resultNonAnonymousAccess) . MaybeT + yieldM $ CorrectionTableCsv + <$> preview (_1 . resultCourseTerm . _TermId) + <*> preview (_1 . resultCourseSchool . _SchoolId) + <*> preview (_1 . resultCourseShorthand) + <*> preview (_1 . resultSheet . _entityVal . _sheetName) + <*> preview (_1 . resultCryptoID . re (_CI . _PathPiece)) + <*> guardNonAnonymous (preview $ _1 . resultLastEdit) + <*> guardNonAnonymous (previews _2 (toListOf $ folded . resultUserUser . _userSurname . re _Just)) + <*> guardNonAnonymous (previews _2 (toListOf $ folded . resultUserUser . _userFirstName . re _Just)) + <*> guardNonAnonymous (previews _2 (toListOf $ folded . resultUserUser . _userDisplayName . re _Just)) + <*> guardNonAnonymous (previews _2 (toListOf $ folded . resultUserUser . _userMatrikelnummer)) + <*> guardNonAnonymous (previews _2 (toListOf $ folded . resultUserUser . _userEmail . re _Just)) + <*> guardNonAnonymous (previews _2 (toListOf $ folded . pre resultUserPseudonym)) + <*> guardNonAnonymous (previews _2 (toListOf $ folded . pre resultUserSubmissionGroup)) + <*> guardNonAnonymous (previews _2 (toListOf $ folded . pre resultUserAuthorshipStatementState)) + <*> preview (_1 . resultSubmission . _entityVal . _submissionRatingAssigned . _Just) + <*> preview (_1 . resultCorrector . _entityVal . _userDisplayName) + <*> preview (_1 . resultCorrector . _entityVal . _userEmail) + <*> preview (_1 . resultSubmission . _entityVal . to submissionRatingDone) + <*> preview (_1 . resultSubmission . _entityVal . _submissionRatingTime . _Just) + <*> preview (_1 . resultSubmission . _entityVal . _submissionRatingPoints . _Just) + <*> preview (_1 . resultSubmission . _entityVal . _submissionRatingComment . _Just) + , dbtCsvName = cTableCsvName, dbtCsvSheetName = cTableCsvSheetName + , dbtCsvHeader = \_ -> return $ correctionTableCsvHeader cTableShowCorrector cTableCsvQualification + , dbtCsvExampleData = Nothing + } dbtCsvDecode = Nothing dbtExtraReps = [] in dbTable psValidator DBTable{..} @@ -524,16 +717,16 @@ data ActionCorrectionsData = CorrDownloadData SubmissionDownloadAnonymous Submis | CorrAutoSetCorrectorData SheetId | CorrDeleteData -correctionsR :: CorrectionTableWhere -> _ -> _ -> _ -> Map ActionCorrections (AForm (HandlerFor UniWorX) ActionCorrectionsData) -> Handler TypedContent -correctionsR whereClause displayColumns dbtFilterUI psValidator actions = do - (table, statistics) <- correctionsR' whereClause displayColumns dbtFilterUI psValidator actions +correctionsR :: CorrectionTableWhere -> _ -> _ -> Maybe CorrectionTableCsvSettings -> _ -> Map ActionCorrections (AForm (HandlerFor UniWorX) ActionCorrectionsData) -> Handler TypedContent +correctionsR whereClause displayColumns dbtFilterUI csvSettings psValidator actions = do + (table, statistics) <- correctionsR' whereClause displayColumns dbtFilterUI csvSettings psValidator actions fmap toTypedContent . defaultLayout $ do setTitleI MsgCourseCorrectionsTitle $(widgetFile "corrections") -correctionsR' :: CorrectionTableWhere -> _ -> _ -> _ -> Map ActionCorrections (AForm (HandlerFor UniWorX) ActionCorrectionsData) -> Handler (Widget, SheetTypeSummary SqlBackendKey) -correctionsR' whereClause displayColumns dbtFilterUI psValidator actions = do +correctionsR' :: CorrectionTableWhere -> _ -> _ -> Maybe CorrectionTableCsvSettings -> _ -> Map ActionCorrections (AForm (HandlerFor UniWorX) ActionCorrectionsData) -> Handler (Widget, SheetTypeSummary SqlBackendKey) +correctionsR' whereClause displayColumns dbtFilterUI csvSettings psValidator actions = do currentRoute <- fromMaybe (error "correctionsR called from 404-handler") <$> getCurrentRoute -- This should never be called from a 404 handler postDeleteR $ \drRecords -> (submissionDeleteRoute drRecords) @@ -542,7 +735,7 @@ correctionsR' whereClause displayColumns dbtFilterUI psValidator actions = do } ((actionRes', statistics), table) <- runDB $ - makeCorrectionsTable whereClause displayColumns dbtFilterUI psValidator DBParamsForm + makeCorrectionsTable whereClause displayColumns dbtFilterUI csvSettings psValidator DBParamsForm { dbParamsFormMethod = POST , dbParamsFormAction = Just $ SomeRoute currentRoute , dbParamsFormAttrs = [] @@ -682,7 +875,12 @@ restrictAnonymous :: PSValidator m x -> PSValidator m x restrictAnonymous = restrictFilter (\k _ -> k /= "user-matriclenumber") . restrictFilter (\k _ -> k /= "user-name-email") . restrictFilter (\k _ -> k /= "submission-group") + . restrictFilter (\k _ -> k /= "as-state") + . restrictSorting (\k _ -> k /= "submittors") + . restrictSorting (\k _ -> k /= "submittors-matriculation") + . restrictSorting (\k _ -> k /= "submittors-group") . restrictSorting (\k _ -> k /= "last-edit") + . restrictSorting (\k _ -> k /= "as-state") restrictCorrector :: PSValidator m x -> PSValidator m x restrictCorrector = restrictFilter (\k _ -> k /= "corrector") @@ -772,7 +970,14 @@ postCorrectionsR = do & restrictAnonymous & defaultSorting [SortDescBy "ratingtime", SortAscBy "assignedtime" ] & defaultFilter (singletonMap "israted" [toPathPiece False]) - correctionsR whereClause colonnade filterUI psValidator $ Map.fromList + + csvSettings = Just CorrectionTableCsvSettings + { cTableCsvQualification = CorrectionTableCsvQualifyCourse + , cTableCsvName = MsgCorrectionTableCsvNameCorrections + , cTableCsvSheetName = MsgCorrectionTableCsvSheetNameCorrections + , cTableShowCorrector = False + } + correctionsR whereClause colonnade filterUI csvSettings psValidator $ Map.fromList [ downloadAction ] @@ -817,7 +1022,13 @@ postCCorrectionsR tid ssh csh = do , filterUISubmission ] psValidator = def & defaultPagesize PagesizeAll -- Assisstant always want to see them all at once anyway - correctionsR whereClause colonnade filterUI psValidator $ Map.fromList + csvSettings = Just CorrectionTableCsvSettings + { cTableCsvQualification = CorrectionTableCsvQualifySheet + , cTableCsvName = MsgCorrectionTableCsvNameCourseCorrections tid ssh csh + , cTableCsvSheetName = MsgCorrectionTableCsvSheetNameCourseCorrections tid ssh csh + , cTableShowCorrector = True + } + correctionsR whereClause colonnade filterUI csvSettings psValidator $ Map.fromList [ downloadAction , assignAction (Left cid) , deleteAction @@ -858,7 +1069,13 @@ postSSubsR tid ssh csh shn = do , filterUISubmission ] psValidator = def & defaultPagesize PagesizeAll -- Assisstant always want to see them all at once anyway - correctionsR whereClause colonnade filterUI psValidator $ Map.fromList + csvSettings = Just CorrectionTableCsvSettings + { cTableCsvQualification = CorrectionTableCsvNoQualification + , cTableCsvName = MsgCorrectionTableCsvNameSheetCorrections tid ssh csh shn + , cTableCsvSheetName = MsgCorrectionTableCsvSheetNameSheetCorrections tid ssh csh shn + , cTableShowCorrector = True + } + correctionsR whereClause colonnade filterUI csvSettings psValidator $ Map.fromList [ downloadAction , assignAction (Right shid) , autoAssignAction shid diff --git a/src/Handler/Utils/StudyFeatures.hs b/src/Handler/Utils/StudyFeatures.hs index e89b05c47..ef0d0a2e6 100644 --- a/src/Handler/Utils/StudyFeatures.hs +++ b/src/Handler/Utils/StudyFeatures.hs @@ -22,8 +22,6 @@ import Handler.Utils.StudyFeatures.Parse import qualified Data.Csv as Csv -import qualified Data.ByteString as ByteString - import qualified Data.Set as Set import Data.RFC5051 (compareUnicode) @@ -65,7 +63,7 @@ instance Csv.ToField UserTableStudyFeature where [] $ ShortStudyFieldType userTableFieldType instance Csv.ToField UserTableStudyFeatures where - toField = ByteString.intercalate "; " . map Csv.toField . view _UserTableStudyFeatures + toField = Csv.toField . CsvSemicolonList . view _UserTableStudyFeatures userTableStudyFeatureSort :: UserTableStudyFeature -> UserTableStudyFeature diff --git a/src/Handler/Utils/Submission.hs b/src/Handler/Utils/Submission.hs index 96a0710f9..b59d1d723 100644 --- a/src/Handler/Utils/Submission.hs +++ b/src/Handler/Utils/Submission.hs @@ -981,20 +981,6 @@ correctionInvisibleWidget tid ssh csh shn cID (Entity subId sub) = runMaybeT $ d return $ notification NotificationBroad =<< messageIconWidget Warning IconInvisible $(widgetFile "submission-correction-invisible") -data AuthorshipStatementSubmissionState - = ASMissing - | ASOldStatement - | ASExists - deriving (Eq, Read, Show, Enum, Bounded, Generic, Typeable) - deriving anyclass (Universe, Finite) - -deriving stock instance Ord AuthorshipStatementSubmissionState -- ^ Larger roughly encodes better; summaries are taken with `max` - -nullaryPathPiece ''AuthorshipStatementSubmissionState $ camelToPathPiece' 1 - -embedRenderMessage ''UniWorX ''AuthorshipStatementSubmissionState $ concat . ("SubmissionAuthorshipStatementState" :) . drop 1 . splitCamel - - getUserAuthorshipStatement :: ( MonadResource m , IsSqlBackend backend, SqlBackendCanRead backend ) diff --git a/src/Model/Types/DateTime.hs b/src/Model/Types/DateTime.hs index 76d427ed9..8f9a3bd28 100644 --- a/src/Model/Types/DateTime.hs +++ b/src/Model/Types/DateTime.hs @@ -133,6 +133,8 @@ instance ToJSON TermIdentifier where instance FromJSON TermIdentifier where parseJSON = withText "Term" $ either (fail . Text.unpack) return . termFromText +pathPieceCsv ''TermIdentifier + {- Must be defined in a later module: termField :: Field (HandlerT UniWorX IO) TermIdentifier termField = checkMMap (return . termFromText) termToText textField diff --git a/src/Model/Types/Submission.hs b/src/Model/Types/Submission.hs index 49dfd12ce..50bee48b8 100644 --- a/src/Model/Types/Submission.hs +++ b/src/Model/Types/Submission.hs @@ -130,3 +130,26 @@ pseudonymWords = folding pseudonymFragments :: Fold Text [PseudonymWord] pseudonymFragments = folding $ mapM (toListOf pseudonymWords) . (\l -> guard (length l == 2) *> l) . filter (not . null) . Text.split (\(CI.mk -> c) -> not $ Set.member c pseudonymCharacters) + + +instance PathPiece Pseudonym where + toPathPiece = review _PseudonymText + fromPathPiece t + | Just p <- t ^? _PseudonymText = Just p + | Just n <- fromPathPiece t = Just $ Pseudonym n + | otherwise = Nothing + +pathPieceCsv ''Pseudonym + + +data AuthorshipStatementSubmissionState + = ASMissing + | ASOldStatement + | ASExists + deriving (Eq, Read, Show, Enum, Bounded, Generic, Typeable) + deriving anyclass (Universe, Finite) + +deriving stock instance Ord AuthorshipStatementSubmissionState -- ^ Larger roughly encodes better; summaries are taken with `max` + +nullaryPathPiece ''AuthorshipStatementSubmissionState $ camelToPathPiece' 1 +pathPieceCsv ''AuthorshipStatementSubmissionState diff --git a/src/Utils/Csv.hs b/src/Utils/Csv.hs index 7070720b1..0a1d1d34d 100644 --- a/src/Utils/Csv.hs +++ b/src/Utils/Csv.hs @@ -10,6 +10,7 @@ module Utils.Csv , toCsvRendered , toDefaultOrderedCsvRendered , csvRenderedToXlsx, Xlsx, Xlsx.fromXlsx + , CsvSemicolonList(..) ) where import ClassyPrelude hiding (lookup) @@ -39,6 +40,19 @@ import qualified Data.Text as Text import qualified Data.Text.Encoding as Text import qualified Data.CaseInsensitive as CI +import qualified Data.Binary.Builder as Builder +import qualified Data.ByteString.Lazy as LBS +import qualified Data.Attoparsec.ByteString as Attoparsec + +import qualified Data.Csv.Parser as Csv +import qualified Data.Csv.Builder as Csv + +import qualified Data.Vector as Vector + +import Data.Char (ord) + +import Control.Monad.Fail + deriving instance Typeable CsvParseError instance Exception CsvParseError @@ -114,3 +128,25 @@ csvRenderedToXlsx sheetName CsvRendered{..} = def & Xlsx.atSheet sheetName ?~ (d addValues = flip foldMap (zip [2..] csvRenderedData) $ \(r, nr) -> flip foldMap (zip [1..] $ toList csvRenderedHeader) $ \(c, hBS) -> case HashMap.lookup hBS nr of Nothing -> mempty Just vBS -> Endo $ Xlsx.cellValueAtRC (r, c) ?~ Xlsx.CellText (decodeUtf8 vBS) + + +newtype CsvSemicolonList a = CsvSemicolonList { unCsvSemicolonList :: [a] } + deriving stock (Read, Show, Generic, Typeable) + deriving newtype (Eq, Ord) + +instance ToField a => ToField (CsvSemicolonList a) where + toField (CsvSemicolonList xs) = dropEnd 2 . LBS.toStrict . Builder.toLazyByteString $ Csv.encodeRecordWith encOpts fs + where + fs = map toField xs + encOpts = defaultEncodeOptions + { encDelimiter = fromIntegral $ ord ';' + , encQuoting = bool QuoteMinimal QuoteAll $ all null fs + , encUseCrLf = True + } + +instance FromField a => FromField (CsvSemicolonList a) where + parseField f + | null f = pure $ CsvSemicolonList [] + | otherwise = fmap CsvSemicolonList . mapM parseField . Vector.toList <=< either fail return $ Attoparsec.parseOnly (Csv.record sep) f + where + sep = fromIntegral $ ord ';' diff --git a/templates/i18n/changelog/corrections-csv-export.de-de-formal.hamlet b/templates/i18n/changelog/corrections-csv-export.de-de-formal.hamlet new file mode 100644 index 000000000..8a44b1939 --- /dev/null +++ b/templates/i18n/changelog/corrections-csv-export.de-de-formal.hamlet @@ -0,0 +1,2 @@ +$newline never +Tabellen von Übungsblattabgaben können nun als CSV exportiert werden diff --git a/templates/i18n/changelog/corrections-csv-export.en-eu.hamlet b/templates/i18n/changelog/corrections-csv-export.en-eu.hamlet new file mode 100644 index 000000000..70a14aa63 --- /dev/null +++ b/templates/i18n/changelog/corrections-csv-export.en-eu.hamlet @@ -0,0 +1,2 @@ +$newline never +Tables of exercise sheet submissions can now be exported as CSV diff --git a/test/Data/Scientific/InstancesSpec.hs b/test/Data/Scientific/InstancesSpec.hs new file mode 100644 index 000000000..0fb95c4f3 --- /dev/null +++ b/test/Data/Scientific/InstancesSpec.hs @@ -0,0 +1,10 @@ +module Data.Scientific.InstancesSpec where + +import TestImport +import Data.Scientific + + +spec :: Spec +spec = modifyMaxSuccess (* 10) $ + lawsCheckHspec (Proxy @Scientific) + [ pathPieceLaws ] diff --git a/test/Utils/CsvSpec.hs b/test/Utils/CsvSpec.hs new file mode 100644 index 000000000..ce556647a --- /dev/null +++ b/test/Utils/CsvSpec.hs @@ -0,0 +1,38 @@ +module Utils.CsvSpec where + +import TestImport + +import Utils.Csv + +import Data.Csv (toField, runParser, parseField) + +import Data.Char (ord) +import qualified Data.ByteString as BS + + +deriving newtype instance Arbitrary a => Arbitrary (CsvSemicolonList a) + + +spec :: Spec +spec = modifyMaxSuccess (* 10) . parallel $ do + lawsCheckHspec (Proxy @(CsvSemicolonList ByteString)) + [ csvFieldLaws ] + describe "CsvSemicolonList" $ do + let + test :: [ByteString] -> ByteString -> Expectation + test (CsvSemicolonList -> x) t = do + toField x `shouldBe` t + runParser (parseField t) `shouldBe` Right x + it "is transparent" . property $ \(bs :: ByteString) + -> let expectTransparent = BS.all (`notElem` [34, 10, 13, fromIntegral $ ord ';']) bs + && not (BS.null bs) + in expectTransparent ==> test [bs] bs + it "behaves as expected on some examples" $ do + test ["foo"] "foo" + test ["foo", "bar"] "foo;bar" + test [] "" + test [""] "\"\"" + test ["", ""] "\"\";\"\"" + test ["foo", ""] "foo;" + test ["", "foo"] ";foo" + test ["", "", "foo", ""] ";;foo;"