Gregor Kleen
parent
51522efc7c
commit
2a6248e3d5
@ -228,4 +228,35 @@ SubmissionColumnAuthorshipStatementTime: Zeitstempel
|
||||
SubmissionColumnAuthorshipStatementWording: Wortlaut
|
||||
SubmissionFilterAuthorshipStatementCurrent: Aktueller Wortlaut
|
||||
|
||||
SubmissionNoUsers: Diese Abgabe hat keine assoziierten Benutzer!
|
||||
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
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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" <>)
|
||||
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
}
|
||||
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
)
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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 ';'
|
||||
|
||||
@ -0,0 +1,2 @@
|
||||
$newline never
|
||||
Tabellen von Übungsblattabgaben können nun als CSV exportiert werden
|
||||
@ -0,0 +1,2 @@
|
||||
$newline never
|
||||
Tables of exercise sheet submissions can now be exported as CSV
|
||||
10
test/Data/Scientific/InstancesSpec.hs
Normal file
10
test/Data/Scientific/InstancesSpec.hs
Normal file
@ -0,0 +1,10 @@
|
||||
module Data.Scientific.InstancesSpec where
|
||||
|
||||
import TestImport
|
||||
import Data.Scientific
|
||||
|
||||
|
||||
spec :: Spec
|
||||
spec = modifyMaxSuccess (* 10) $
|
||||
lawsCheckHspec (Proxy @Scientific)
|
||||
[ pathPieceLaws ]
|
||||
38
test/Utils/CsvSpec.hs
Normal file
38
test/Utils/CsvSpec.hs
Normal file
@ -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;"
|
||||
Loading…
Reference in New Issue
Block a user