diff --git a/models/allocations.model b/models/allocations.model index e92987fc3..a7773ab3b 100644 --- a/models/allocations.model +++ b/models/allocations.model @@ -31,6 +31,7 @@ AllocationMatching fingerprint AllocationFingerprint time UTCTime log FileContentReference + deriving Generic AllocationCourse allocation AllocationId @@ -38,6 +39,7 @@ AllocationCourse minCapacity Int -- if the course would get assigned fewer than this many applicants, restart the assignment process without the course acceptSubstitutes UTCTime Maybe UniqueAllocationCourse course + deriving Generic AllocationUser allocation AllocationId @@ -45,17 +47,18 @@ AllocationUser totalCourses Word64 -- number of total allocated courses for this user must be <= than this number priority AllocationPriority Maybe UniqueAllocationUser allocation user - deriving Eq Ord Show + deriving Eq Ord Show Generic AllocationDeregister -- self-inflicted user-deregistrations from an allocated course user UserId course CourseId Maybe time UTCTime reason Text Maybe -- if this deregistration was done by proxy (e.g. the lecturer pressed the button) - deriving Eq Ord Show + deriving Eq Ord Show Generic AllocationNotificationSetting user UserId allocation AllocationId isOptOut Bool - UniqueAllocationNotificationSetting user allocation \ No newline at end of file + UniqueAllocationNotificationSetting user allocation + deriving Generic \ No newline at end of file diff --git a/models/audit.model b/models/audit.model index 4524fdaf1..f2336b3cc 100644 --- a/models/audit.model +++ b/models/audit.model @@ -5,4 +5,4 @@ TransactionLog initiator UserId Maybe -- User associated with performing this action remote IP Maybe -- Remote party that triggered this action via HTTP info Value -- JSON-encoded `Transaction` - deriving Eq Read Show Generic Typeable \ No newline at end of file + deriving Eq Read Show Generic \ No newline at end of file diff --git a/models/changelog.model b/models/changelog.model index 4cc42cb12..58ec60aa0 100644 --- a/models/changelog.model +++ b/models/changelog.model @@ -2,3 +2,4 @@ ChangelogItemFirstSeen item ChangelogItem firstSeen Day Primary item + deriving Generic diff --git a/models/config.model b/models/config.model index 5ec2357d6..202160cc7 100644 --- a/models/config.model +++ b/models/config.model @@ -3,4 +3,5 @@ ClusterConfig setting ClusterSettingsKey -- I.e. Symmetric key for encrypting database-ids for use in URLs, Symmetric key for encrypting user-sessions so they can be saved directly as a browser-cookie, Symmetric key for encrypting error messages which might contain secret information, ... value Value -- JSON-encoded value - Primary setting \ No newline at end of file + Primary setting + deriving Generic \ No newline at end of file diff --git a/models/courses.model b/models/courses.model index d64ec14ac..581704aa5 100644 --- a/models/courses.model +++ b/models/courses.model @@ -3,6 +3,7 @@ DegreeCourse json -- for which degree programmes this course is appropriate fo degree StudyDegreeId terms StudyTermsId UniqueDegreeCourse course degree terms + deriving Generic Course -- Information about a single course; contained info is always visible to all users name (CI Text) description StoredMarkup Maybe -- user-defined large Html, ought to contain module description @@ -36,6 +37,7 @@ CourseEvent time Occurrences note StoredMarkup Maybe lastChanged UTCTime default=now() + deriving Generic CourseAppInstructionFile course CourseId @@ -43,16 +45,19 @@ CourseAppInstructionFile content FileContentReference Maybe modified UTCTime UniqueCourseAppInstructionFile course title + deriving Generic CourseEdit -- who edited when a row in table "Course", kept indefinitely (might be replaced by generic Audit Table; like all ...-Edit tables) user UserId time UTCTime course CourseId + deriving Generic Lecturer -- course ownership user UserId course CourseId type LecturerType default='"lecturer"'::jsonb UniqueLecturer user course -- note: multiple lecturers per course are allowed, but no duplicated rows in this table + deriving Generic CourseParticipant -- course enrolement course CourseId user UserId @@ -61,7 +66,7 @@ CourseParticipant -- course enrolement allocated AllocationId Maybe -- participant was centrally allocated state CourseParticipantState UniqueParticipant user course - deriving Eq Ord Show + deriving Eq Ord Show Generic -- Replace the last two by the following, once an audit log is available -- CourseUserNote -- lecturers of a specific course may share a text note on each enrolled student -- course CourseId @@ -75,13 +80,16 @@ CourseUserNote -- lecturers of a specific course may share a tex user UserId note StoredMarkup -- arbitrary user-defined text; visible only to lecturer of this course UniqueCourseUserNote user course + deriving Generic CourseUserNoteEdit -- who edited a participants course note when user UserId time UTCTime note CourseUserNoteId -- PROBLEM: deleted notes have no modification date any more + deriving Generic CourseUserExamOfficeOptOut course CourseId user UserId school SchoolId UniqueCourseUserExamOfficeOptOut course user school + deriving Generic diff --git a/models/courses/applications.model b/models/courses/applications.model index 4ed26ffd7..b5c342198 100644 --- a/models/courses/applications.model +++ b/models/courses/applications.model @@ -10,6 +10,7 @@ CourseApplication allocationPriority Word64 Maybe time UTCTime default=now() ratingTime UTCTime Maybe + deriving Generic CourseApplicationFile application CourseApplicationId @@ -17,3 +18,4 @@ CourseApplicationFile content FileContentReference Maybe modified UTCTime UniqueCourseApplicationFile application title + deriving Generic diff --git a/models/courses/favourite.model b/models/courses/favourite.model index 1c5077b77..f42f5f6c4 100644 --- a/models/courses/favourite.model +++ b/models/courses/favourite.model @@ -4,7 +4,9 @@ CourseFavourite -- which user accessed which course when, only display reason FavouriteReason lastVisit UTCTime UniqueCourseFavourite user course + deriving Generic CourseNoFavourite user UserId course CourseId - UniqueCourseNoFavourite user course \ No newline at end of file + UniqueCourseNoFavourite user course + deriving Generic \ No newline at end of file diff --git a/models/courses/materials.model b/models/courses/materials.model index 3a4767ec5..d020271bc 100644 --- a/models/courses/materials.model +++ b/models/courses/materials.model @@ -12,4 +12,5 @@ MaterialFile -- a file that is part of a material distribution title FilePath content FileContentReference Maybe modified UTCTime - UniqueMaterialFile material title \ No newline at end of file + UniqueMaterialFile material title + deriving Generic \ No newline at end of file diff --git a/models/courses/news.model b/models/courses/news.model index c31312d2e..c12bbe5d7 100644 --- a/models/courses/news.model +++ b/models/courses/news.model @@ -6,9 +6,11 @@ CourseNews content StoredMarkup summary StoredMarkup Maybe lastEdit UTCTime + deriving Generic CourseNewsFile news CourseNewsId title FilePath content FileContentReference Maybe modified UTCTime - UniqueCourseNewsFile news title \ No newline at end of file + UniqueCourseNewsFile news title + deriving Generic \ No newline at end of file diff --git a/models/exam-office.model b/models/exam-office.model index ab45e3abd..0fbd7330d 100644 --- a/models/exam-office.model +++ b/models/exam-office.model @@ -3,17 +3,21 @@ ExamOfficeField field StudyTermsId forced Bool UniqueExamOfficeField office field + deriving Generic ExamOfficeUser office UserId user UserId UniqueExamOfficeUser office user + deriving Generic ExamOfficeResultSynced school SchoolId Maybe office UserId result ExamResultId time UTCTime + deriving Generic ExamOfficeExternalResultSynced school SchoolId Maybe office UserId result ExternalExamResultId - time UTCTime \ No newline at end of file + time UTCTime + deriving Generic \ No newline at end of file diff --git a/models/exams.model b/models/exams.model index 0abad27a3..1c79e1f7f 100644 --- a/models/exams.model +++ b/models/exams.model @@ -21,6 +21,7 @@ Exam staff Text Maybe partsFrom UTCTime Maybe UniqueExam course name + deriving Generic ExamPart exam ExamId number ExamPartNumber @@ -29,7 +30,7 @@ ExamPart weight Rational UniqueExamPartNumber exam number UniqueExamPartName exam name !force - deriving Read Show Eq Ord Generic Typeable + deriving Read Show Eq Ord Generic ExamOccurrence exam ExamId name ExamOccurrenceName @@ -40,43 +41,47 @@ ExamOccurrence end UTCTime Maybe description StoredMarkup Maybe UniqueExamOccurrence exam name + deriving Generic ExamRegistration exam ExamId user UserId occurrence ExamOccurrenceId Maybe time UTCTime default=now() UniqueExamRegistration exam user - deriving Eq Ord Show + deriving Eq Ord Show Generic ExamPartResult examPart ExamPartId user UserId result ExamResultPoints lastChanged UTCTime default=now() UniqueExamPartResult examPart user - deriving Eq Ord Show + deriving Eq Ord Show Generic ExamBonus exam ExamId user UserId bonus Points lastChanged UTCTime default=now() UniqueExamBonus exam user - deriving Eq Ord Show + deriving Eq Ord Show Generic ExamResult exam ExamId user UserId result ExamResultPassedGrade lastChanged UTCTime default=now() UniqueExamResult exam user - deriving Eq Ord Show + deriving Eq Ord Show Generic ExamCorrector exam ExamId user UserId UniqueExamCorrector exam user + deriving Generic ExamPartCorrector part ExamPartId corrector ExamCorrectorId UniqueExamPartCorrector part corrector + deriving Generic ExamOfficeSchool school SchoolId exam ExamId UniqueExamOfficeSchool exam school + deriving Generic diff --git a/models/external-exams.model b/models/external-exams.model index 0efe62669..06d83b688 100644 --- a/models/external-exams.model +++ b/models/external-exams.model @@ -6,6 +6,7 @@ ExternalExam defaultTime UTCTime Maybe gradingMode ExamGradingMode UniqueExternalExam term school courseName examName + deriving Generic ExternalExamResult user UserId exam ExternalExamId @@ -13,12 +14,14 @@ ExternalExamResult time UTCTime lastChanged UTCTime UniqueExternalExamResult exam user - deriving Eq Ord Show + deriving Eq Ord Show Generic ExternalExamStaff user UserId exam ExternalExamId UniqueExternalExamStaff exam user + deriving Generic ExternalExamOfficeSchool school SchoolId exam ExternalExamId - UniqueExternalExamOfficeSchool exam school \ No newline at end of file + UniqueExternalExamOfficeSchool exam school + deriving Generic \ No newline at end of file diff --git a/models/files.model b/models/files.model index 9a21f75b7..eb0c3ebf3 100644 --- a/models/files.model +++ b/models/files.model @@ -3,28 +3,34 @@ FileContentEntry ix Word64 chunkHash FileContentChunkId UniqueFileContentEntry hash ix + deriving Generic FileContentChunk hash FileContentChunkReference content ByteString contentBased Bool default=false -- For Migration Primary hash + deriving Generic FileContentChunkUnreferenced hash FileContentChunkId since UTCTime UniqueFileContentChunkUnreferenced hash + deriving Generic SessionFile content FileContentReference Maybe touched UTCTime + deriving Generic FileLock content FileContentReference instance InstanceId time UTCTime + deriving Generic FileChunkLock hash FileContentChunkReference instance InstanceId - time UTCTime \ No newline at end of file + time UTCTime + deriving Generic \ No newline at end of file diff --git a/models/invitations.model b/models/invitations.model index c915d08e4..91e3ba610 100644 --- a/models/invitations.model +++ b/models/invitations.model @@ -3,4 +3,5 @@ Invitation for Value data Value expiresAt UTCTime Maybe - UniqueInvitation email for \ No newline at end of file + UniqueInvitation email for + deriving Generic \ No newline at end of file diff --git a/models/jobs.model b/models/jobs.model index 4b8cf82f2..e238f49c6 100644 --- a/models/jobs.model +++ b/models/jobs.model @@ -6,7 +6,7 @@ QueuedJob lockInstance InstanceId Maybe -- instance that has started to execute this job lockTime UTCTime Maybe -- time when execution had begun writeLastExec Bool default=false -- record successful execution to CronLastExec - deriving Eq Read Show Generic Typeable + deriving Eq Read Show Generic -- Jobs are deleted from @QueuedJob@ after they are executed successfully and recorded in @CronLastExec@ -- There is a Cron-system that, at set intervals, queries the database for work to be done in the background (i.e. if a lecturer has set a sheet's submissions to be automatically distributed and the submission deadline passed since the last check, then queue a new job to actually do the distribution) @@ -16,9 +16,11 @@ CronLastExec time UTCTime -- When was the job executed instance InstanceId -- Which uni2work-instance did the work UniqueCronLastExec job + deriving Generic TokenBucket ident TokenBucketIdent lastValue Int64 lastAccess UTCTime - Primary ident \ No newline at end of file + Primary ident + deriving Generic \ No newline at end of file diff --git a/models/mail.model b/models/mail.model index 114c37ce9..b24420e74 100644 --- a/models/mail.model +++ b/models/mail.model @@ -6,8 +6,10 @@ SentMail recipient UserId Maybe headers MailHeaders contentRef SentMailContentId + deriving Generic SentMailContent hash MailContentReference content MailContent - Primary hash \ No newline at end of file + Primary hash + deriving Generic \ No newline at end of file diff --git a/models/schools.model b/models/schools.model index af9e54889..33975b7a3 100644 --- a/models/schools.model +++ b/models/schools.model @@ -16,7 +16,9 @@ SchoolLdap school SchoolId Maybe orgUnit (CI Text) UniqueOrgUnit orgUnit + deriving Generic SchoolTerms school SchoolId terms StudyTermsId - UniqueSchoolTerms school terms \ No newline at end of file + UniqueSchoolTerms school terms + deriving Generic \ No newline at end of file diff --git a/models/sheets.model b/models/sheets.model index a4d1fac2c..92845f112 100644 --- a/models/sheets.model +++ b/models/sheets.model @@ -21,6 +21,7 @@ SheetEdit -- who edited when a row in table "Course", kept i user UserId time UTCTime sheet SheetId + deriving Generic -- For anonoymous external submissions (i.e. paper submission tracked in uni2work) -- Map pseudonyms to users injectively in the context of a single sheet; for the next sheet all-new pseudonyms need to be created @@ -31,13 +32,14 @@ SheetPseudonym user UserId UniqueSheetPseudonym sheet pseudonym UniqueSheetPseudonymUser sheet user + deriving Generic SheetCorrector -- grant corrector role to user for a sheet user UserId sheet SheetId load Load -- portion of work that will be assigned to this corrector state CorrectorState default='CorrectorNormal' -- whether a corrector is assigned his load this time (e.g. in case of sickness) UniqueSheetCorrector user sheet - deriving Show Eq Ord + deriving Show Eq Ord Generic SheetFile -- a file that is part of an exercise sheet sheet SheetId type SheetFileType -- excercise, marking, hint or solution @@ -45,6 +47,7 @@ SheetFile -- a file that is part of an exercise sheet content FileContentReference Maybe modified UTCTime UniqueSheetFile sheet type title + deriving Generic PersonalisedSheetFile sheet SheetId user UserId @@ -53,11 +56,12 @@ PersonalisedSheetFile content FileContentReference Maybe modified UTCTime UniquePersonalisedSheetFile sheet user type title - deriving Eq Ord Read Show Generic Typeable + deriving Eq Ord Read Show Typeable Generic FallbackPersonalisedSheetFilesKey course CourseId index Word24 secret ByteString generated UTCTime - UniqueFallbackPersonalisedSheetFilesKey course index \ No newline at end of file + UniqueFallbackPersonalisedSheetFilesKey course index + deriving Generic \ No newline at end of file diff --git a/models/study-features.model b/models/study-features.model index 1c0b2e111..1c9c9cb20 100644 --- a/models/study-features.model +++ b/models/study-features.model @@ -10,13 +10,14 @@ StudyFeatures -- multiple entries possible for students pursuing several degree valid Bool default=true relevanceCached UUID Maybe UniqueStudyFeatures user degree field type semester - deriving Eq Show + deriving Eq Show Generic -- UniqueUserSubject ubuser degree field -- There exists a counterexample RelevantStudyFeatures term TermId studyFeatures StudyFeaturesId UniqueRelevantStudyFeatures term studyFeatures + deriving Generic StudyDegree -- Studienabschluss key Int -- LMU-internal key @@ -24,7 +25,7 @@ StudyDegree -- Studienabschluss name Text Maybe -- description given by LDAP Primary key -- column key is used as actual DB row key -- newtype Key StudyDegree = StudyDegreeKey' { unStudyDegreeKey :: Int } - deriving Eq Show + deriving Eq Show Generic StudyTerms -- Studiengang key Int -- standardised key shorthand Text Maybe -- admin determined shorthand @@ -33,11 +34,12 @@ StudyTerms -- Studiengang defaultType StudyFieldType Maybe Primary key -- column key is used as actual DB row key -- newtype Key StudyTerms = StudyTermsKey' { unStudyTermsKey :: Int } - deriving Eq Ord Show + deriving Eq Ord Show Generic StudySubTerms child StudyTermsId parent StudyTermsId UniqueStudySubTerms child parent + deriving Generic StudyTermNameCandidate -- No one at LMU is willing and able to tell us the meaning of the keys for StudyDegrees and StudyTerms. -- Each LDAP login provides an unordered set of keys and an unordered set of plain text description with an unknown 1-1 correspondence. -- This table helps us to infer which key belongs to which plain text by recording possible combinations at login. @@ -45,14 +47,14 @@ StudyTermNameCandidate -- No one at LMU is willing and able to tell us the me incidence TermCandidateIncidence -- random id, generated once per login to associate matching pairs key Int -- a possible key for the studyTermName or studySubTermName name Text -- studyTermName as plain text from LDAP - deriving Show Eq Ord + deriving Show Eq Ord Generic StudySubTermParentCandidate incidence TermCandidateIncidence key Int parent Int - deriving Show Eq Ord + deriving Show Eq Ord Generic StudyTermStandaloneCandidate incidence TermCandidateIncidence key Int - deriving Show Eq Ord + deriving Show Eq Ord Generic diff --git a/models/submissions.model b/models/submissions.model index 618306feb..9b9b500fb 100644 --- a/models/submissions.model +++ b/models/submissions.model @@ -10,6 +10,7 @@ SubmissionEdit -- user uploads new version of their submissio user UserId Maybe -- track id, important for group submissions time UTCTime submission SubmissionId + deriving Generic SubmissionFile json -- files that are part of a submission submission SubmissionId title FilePath @@ -18,17 +19,19 @@ SubmissionFile json -- files that are part of a submission isUpdate Bool -- is this the file updated by a corrector (original will always be retained) isDeletion Bool -- only set if isUpdate is also set, but file was deleted by corrector UniqueSubmissionFile submission title isUpdate - deriving Eq Ord Read Show + deriving Eq Ord Read Show Generic SubmissionUser -- which submission belongs to whom user UserId submission SubmissionId UniqueSubmissionUser user submission -- multiple users may share same submission, in case of (ad-hoc) submission groups + deriving Generic SubmissionGroup -- pre-defined submission groups; some courses only allow pre-defined submission groups course CourseId name SubmissionGroupName UniqueSubmissionGroup course name + deriving Generic SubmissionGroupUser -- Registered submission groups, just for checking upon submission, but independent of actual SubmissionUser submissionGroup SubmissionGroupId user UserId UniqueSubmissionGroupUser submissionGroup user - deriving Eq Ord Show \ No newline at end of file + deriving Eq Ord Show Generic \ No newline at end of file diff --git a/models/system-messages.model b/models/system-messages.model index 4fed20bf1..5ba6b3c53 100644 --- a/models/system-messages.model +++ b/models/system-messages.model @@ -13,6 +13,7 @@ SystemMessage defaultLanguage Lang -- Language of @content@ and @summary@ content StoredMarkup -- Detailed message shown when clicking on the @summary@-popup or when no @summary@ is specified summary StoredMarkup Maybe + deriving Generic SystemMessageTranslation -- Translation of a @SystemMessage@ into another language; which language to choose is determined by user-sent HTTP-headers message SystemMessageId @@ -20,9 +21,11 @@ SystemMessageTranslation -- Translation of a @SystemMessage@ into another langua content StoredMarkup summary StoredMarkup Maybe UniqueSystemMessageTranslation message language + deriving Generic SystemMessageHidden message SystemMessageId user UserId time UTCTime - UniqueSystemMessageHidden user message \ No newline at end of file + UniqueSystemMessageHidden user message + deriving Generic \ No newline at end of file diff --git a/models/tutorials.model b/models/tutorials.model index d193ff5d5..a364c203c 100644 --- a/models/tutorials.model +++ b/models/tutorials.model @@ -18,8 +18,10 @@ Tutor tutorial TutorialId user UserId UniqueTutor tutorial user + deriving Generic TutorialParticipant tutorial TutorialId user UserId UniqueTutorialParticipant tutorial user - deriving Eq Ord Show \ No newline at end of file + deriving Eq Ord Show + deriving Generic \ No newline at end of file diff --git a/models/users.model b/models/users.model index a8eb73c12..707da5e2f 100644 --- a/models/users.model +++ b/models/users.model @@ -44,21 +44,25 @@ UserFunction -- Administratively assigned functions (lecturer, admin, evaluation school SchoolId function SchoolFunction UniqueUserFunction user school function + deriving Generic UserSystemFunction user UserId function SystemFunction manual Bool isOptOut Bool UniqueUserSystemFunction user function + deriving Generic UserExamOffice user UserId field StudyTermsId UniqueUserExamOffice user field + deriving Generic UserSchool -- Managed by users themselves, encodes "schools of interest" user UserId school SchoolId isOptOut Bool -- true if this a marker, that the user manually deleted this entry; it should not be recreated automatically UniqueUserSchool user school + deriving Generic UserGroupMember group UserGroupName @@ -67,4 +71,6 @@ UserGroupMember UniquePrimaryUserGroupMember group primary !force UniqueUserGroupMember group user + + deriving Generic diff --git a/models/workflows.model b/models/workflows.model index 7561e9c65..d68a91cee 100644 --- a/models/workflows.model +++ b/models/workflows.model @@ -2,6 +2,7 @@ SharedWorkflowGraph hash WorkflowGraphReference graph (WorkflowGraph FileReference SqlBackendKey) -- UserId Primary hash + deriving Generic WorkflowDefinition graph SharedWorkflowGraphId @@ -9,6 +10,7 @@ WorkflowDefinition name WorkflowDefinitionName instanceCategory WorkflowInstanceCategory Maybe UniqueWorkflowDefinition name scope + deriving Generic WorkflowDefinitionDescription definition WorkflowDefinitionId @@ -16,6 +18,7 @@ WorkflowDefinitionDescription title Text description StoredMarkup Maybe UniqueWorkflowDefinitionDescription definition language + deriving Generic WorkflowDefinitionInstanceDescription definition WorkflowDefinitionId @@ -23,6 +26,7 @@ WorkflowDefinitionInstanceDescription title Text description StoredMarkup Maybe UniqueWorkflowDefinitionInstanceDescription definition language + deriving Generic WorkflowInstance definition WorkflowDefinitionId Maybe @@ -31,6 +35,7 @@ WorkflowInstance name WorkflowInstanceName category WorkflowInstanceCategory Maybe UniqueWorkflowInstance name scope + deriving Generic WorkflowInstanceDescription instance WorkflowInstanceId @@ -38,9 +43,11 @@ WorkflowInstanceDescription title Text description StoredMarkup Maybe UniqueWorkflowInstanceDescription instance language + deriving Generic WorkflowWorkflow instance WorkflowInstanceId Maybe scope (WorkflowScope TermIdentifier SchoolShorthand SqlBackendKey) -- TermId, SchoolId, CourseId graph SharedWorkflowGraphId state (WorkflowState FileReference SqlBackendKey) -- UserId + deriving Generic diff --git a/src/Database/Persist/Class/Instances.hs b/src/Database/Persist/Class/Instances.hs index 4a3a7208c..657a86800 100644 --- a/src/Database/Persist/Class/Instances.hs +++ b/src/Database/Persist/Class/Instances.hs @@ -30,9 +30,6 @@ instance PersistEntity record => Binary (Key record) where putList = Binary.putList . map toPersistValue get = either (fail . unpack) return . fromPersistValue =<< Binary.get -instance PersistEntity record => NFData (Key record) where - rnf = rnf . keyToValues - uniqueToMap :: PersistEntity record => Unique record -> Map (HaskellName, DBName) PersistValue uniqueToMap = fmap Map.fromList $ zip <$> persistUniqueToFieldNames <*> persistUniqueToValues diff --git a/src/Database/Persist/Types/Instances.hs b/src/Database/Persist/Types/Instances.hs index d356217ca..cf05894f2 100644 --- a/src/Database/Persist/Types/Instances.hs +++ b/src/Database/Persist/Types/Instances.hs @@ -26,3 +26,6 @@ instance NFData PersistValue instance (NFData record, NFData (Key record)) => NFData (Entity record) where rnf Entity{..} = rnf entityKey `seq` rnf entityVal + +deriving instance Generic Checkmark +deriving anyclass instance NFData Checkmark diff --git a/src/Model.hs b/src/Model.hs index b8e4c22d9..750e8dd07 100644 --- a/src/Model.hs +++ b/src/Model.hs @@ -33,7 +33,7 @@ type SqlBackendKey = BackendKey SqlBackend -- You can find more information on persistent and how to declare entities -- at: -- http://www.yesodweb.com/book/persistent/ -share [mkPersist sqlSettings, mkDeleteCascade sqlSettings, mkMigrate "migrateUniWorX", mkSave "currentModel"] +share [mkPersist sqlSettings{ mpsDeriveInstances = [''NFData] }, mkDeleteCascade sqlSettings, mkMigrate "migrateUniWorX", mkSave "currentModel"] $(persistDirectoryWith lowerCaseSettings "models") @@ -51,8 +51,6 @@ deriving newtype instance FromJSONKey ExamOccurrenceId deriving instance Show (Unique ExamPart) -deriving anyclass instance NFData ExamPart - -- ToMarkup and ToMessage instances for displaying selected database primary keys instance ToMarkup (Key School) where diff --git a/src/Model/Types/Allocation.hs b/src/Model/Types/Allocation.hs index 90b406364..d78d62cae 100644 --- a/src/Model/Types/Allocation.hs +++ b/src/Model/Types/Allocation.hs @@ -32,6 +32,7 @@ data AllocationPriority = AllocationPriorityNumeric { allocationPriorities :: Vector Integer } | AllocationPriorityOrdinal { allocationOrdinal :: Natural } deriving (Eq, Ord, Read, Show, Generic, Typeable) + deriving anyclass (NFData) deriveJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 1 , constructorTagModifier = camelToPathPiece' 2 @@ -49,7 +50,9 @@ instance Binary AllocationPriority data AllocationPriorityNumericRecord = AllocationPriorityNumericRecord { apmrMatrikelnummer :: UserMatriculation , apmrPriority :: Vector Integer - } deriving (Eq, Ord, Read, Show, Generic, Typeable) + } + deriving (Eq, Ord, Read, Show, Generic, Typeable) + deriving anyclass (NFData) allocationPriorityNumericMap :: Prism' (Map UserMatriculation AllocationPriority) AllocationPriorityNumericRecord allocationPriorityNumericMap = prism' fromPrioRecord toPrioRecord @@ -90,6 +93,7 @@ data AllocationPriorityComparison = AllocationPriorityComparisonNumeric { allocationGradeScale :: Rational } | AllocationPriorityComparisonOrdinal { allocationCloneIndex :: Down Natural, allocationOrdinalScale :: Rational } deriving (Eq, Ord, Read, Show, Generic, Typeable) + deriving anyclass (NFData) type AllocationFingerprint = Digest (SHAKE128 128) diff --git a/src/Model/Types/Course.hs b/src/Model/Types/Course.hs index e7a991d29..e9779a486 100644 --- a/src/Model/Types/Course.hs +++ b/src/Model/Types/Course.hs @@ -16,9 +16,7 @@ import Utils.Lens.TH data LecturerType = CourseLecturer | CourseAssistant deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable) - -instance Universe LecturerType -instance Finite LecturerType + deriving (Universe, Finite, NFData) nullaryPathPiece ''LecturerType $ camelToPathPiece' 1 deriveJSON defaultOptions @@ -33,7 +31,7 @@ data CourseParticipantState = CourseParticipantActive | CourseParticipantInactive { courseParticipantNoShow :: Bool } deriving (Eq, Ord, Read, Show, Generic, Typeable) - deriving anyclass (Hashable) + deriving anyclass (NFData, Hashable) makePrisms ''CourseParticipantState makeLenses_ ''CourseParticipantState diff --git a/src/Model/Types/DateTime.hs b/src/Model/Types/DateTime.hs index 16942e98a..76d427ed9 100644 --- a/src/Model/Types/DateTime.hs +++ b/src/Model/Types/DateTime.hs @@ -153,6 +153,7 @@ data OccurrenceSchedule = ScheduleWeekly , scheduleEnd :: TimeOfDay } deriving (Eq, Ord, Read, Show, Generic, Typeable) + deriving anyclass (NFData) deriveJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 1 @@ -170,6 +171,7 @@ data OccurrenceException = ExceptOccur { exceptTime :: LocalTime } deriving (Eq, Ord, Read, Show, Generic, Typeable) + deriving anyclass (NFData) deriveJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 1 @@ -180,7 +182,9 @@ deriveJSON defaultOptions data Occurrences = Occurrences { occurrencesScheduled :: Set OccurrenceSchedule , occurrencesExceptions :: Set OccurrenceException - } deriving (Eq, Ord, Read, Show, Generic, Typeable) + } + deriving (Eq, Ord, Read, Show, Generic, Typeable) + deriving anyclass (NFData) deriveJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 1 diff --git a/src/Model/Types/Exam.hs b/src/Model/Types/Exam.hs index 509b01538..979713ded 100644 --- a/src/Model/Types/Exam.hs +++ b/src/Model/Types/Exam.hs @@ -78,6 +78,7 @@ data ExamResult' res = ExamAttended { examResult :: res } | ExamNoShow | ExamVoided deriving (Show, Read, Eq, Ord, Functor, Generic, Typeable) + deriving anyclass (NFData) deriveJSON defaultOptions { constructorTagModifier = camelToPathPiece' 1 , fieldLabelModifier = camelToPathPiece' 1 @@ -156,6 +157,7 @@ data ExamBonusRule = ExamBonusManual , bonusRound :: Points } deriving (Show, Read, Eq, Ord, Generic, Typeable) + deriving anyclass (NFData) deriveJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 1 , constructorTagModifier = camelToPathPiece' 1 @@ -171,7 +173,8 @@ data ExamOccurrenceRule = ExamRoomManual | ExamRoomSurname | ExamRoomMatriculation | ExamRoomRandom - deriving (Show, Read, Eq, Ord, Generic, Typeable) + deriving (Show, Read, Eq, Ord, Enum, Bounded, Generic, Typeable) + deriving anyclass (Universe, Finite, NFData) deriveJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 1 , constructorTagModifier = camelToPathPiece' 2 @@ -195,6 +198,7 @@ data ExamOccurrenceMappingDescription | ExamOccurrenceMappingSpecial { eaomrSpecial :: [CI Char] } | ExamOccurrenceMappingRandom deriving (Eq, Ord, Read, Show, Generic, Typeable) + deriving anyclass (NFData) deriveJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 1 , constructorTagModifier = camelToPathPiece' 3 @@ -206,7 +210,9 @@ makePrisms ''ExamOccurrenceMappingDescription data ExamOccurrenceMapping roomId = ExamOccurrenceMapping { examOccurrenceMappingRule :: ExamOccurrenceRule , examOccurrenceMappingMapping :: Map roomId (Set ExamOccurrenceMappingDescription) - } deriving (Eq, Ord, Read, Show, Generic, Typeable) + } + deriving (Eq, Ord, Read, Show, Generic, Typeable) + deriving anyclass (NFData) instance ToJSONKey roomId => ToJSON (ExamOccurrenceMapping roomId) where toJSON = genericToJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 3 @@ -269,8 +275,7 @@ data ExamGrade | Grade13 | Grade10 deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable) -instance Universe ExamGrade -instance Finite ExamGrade + deriving anyclass (Universe, Finite, NFData) numberGrade :: Prism' Rational ExamGrade numberGrade = prism toNumberGrade fromNumberGrade @@ -344,6 +349,7 @@ data ExamGradingRule { examGradingKey :: [Points] -- ^ @[n1, n2, n3, ..., n11]@ means @0 <= p < n1 -> p ~= 5@, @n1 <= p < n2 -> p ~ 4@, @n2 <= p < n3 -> p ~ 3.7@, ..., @n10 <= p -> p ~ 1.0@ } deriving (Eq, Ord, Read, Show, Generic, Typeable) + deriving anyclass (NFData) deriveJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 2 , constructorTagModifier = camelToPathPiece' 2 @@ -358,6 +364,7 @@ derivePersistFieldJSON ''ExamGradingRule newtype ExamPassed = ExamPassed { examPassed :: Bool } deriving (Read, Show, Generic, Typeable) deriving newtype (Eq, Ord, Enum, Bounded, PersistField) + deriving anyclass (NFData) instance PersistFieldSql ExamPassed where sqlType _ = sqlType $ Proxy @Bool @@ -403,8 +410,7 @@ data ExamGradingMode | ExamGradingGrades | ExamGradingMixed deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable) -instance Universe ExamGradingMode -instance Finite ExamGradingMode + deriving anyclass (Universe, Finite, NFData) nullaryPathPiece ''ExamGradingMode $ camelToPathPiece' 2 pathPieceJSON ''ExamGradingMode @@ -478,12 +484,13 @@ data ExamAids = ExamAidsPreset { examAidsPreset :: ExamAidsPreset } | ExamAidsCustom { examAidsCustom :: StoredMarkup } deriving (Eq, Ord, Read, Show, Generic, Typeable) + deriving anyclass (NFData) data ExamAidsPreset = ExamOpenBook | ExamClosedBook deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable) - deriving anyclass (Universe, Finite) + deriving anyclass (Universe, Finite, NFData) deriveJSON defaultOptions { constructorTagModifier = camelToPathPiece' 2 @@ -499,12 +506,13 @@ data ExamOnline = ExamOnlinePreset { examOnlinePreset :: ExamOnlinePreset } | ExamOnlineCustom { examOnlineCustom :: StoredMarkup } deriving (Eq, Ord, Read, Show, Generic, Typeable) + deriving anyclass (NFData) data ExamOnlinePreset = ExamOnline | ExamOffline deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable) - deriving anyclass (Universe, Finite) + deriving anyclass (Universe, Finite, NFData) deriveJSON defaultOptions { constructorTagModifier = camelToPathPiece' 2 @@ -520,12 +528,13 @@ data ExamSynchronicity = ExamSynchronicityPreset { examSynchronicityPreset :: ExamSynchronicityPreset } | ExamSynchronicityCustom { examSynchronicityCustom :: StoredMarkup } deriving (Eq, Ord, Read, Show, Generic, Typeable) + deriving anyclass (NFData) data ExamSynchronicityPreset = ExamSynchronous | ExamAsynchronous deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable) - deriving anyclass (Universe, Finite) + deriving anyclass (Universe, Finite, NFData) deriveJSON defaultOptions { constructorTagModifier = camelToPathPiece' 2 @@ -541,6 +550,7 @@ data ExamRequiredEquipment = ExamRequiredEquipmentPreset { examRequiredEquipmentPreset :: ExamRequiredEquipmentPreset } | ExamRequiredEquipmentCustom { examRequiredEquipmentCustom :: StoredMarkup } deriving (Eq, Ord, Read, Show, Generic, Typeable) + deriving anyclass (NFData) data ExamRequiredEquipmentPreset = ExamRequiredEquipmentNone @@ -551,7 +561,7 @@ data ExamRequiredEquipmentPreset | ExamRequiredEquipmentWebcamMicrophoneInternet | ExamRequiredEquipmentMicrophoneInternet deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable) - deriving anyclass (Universe, Finite) + deriving anyclass (Universe, Finite, NFData) deriveJSON defaultOptions { constructorTagModifier = camelToPathPiece' 2 @@ -570,6 +580,8 @@ data ExamMode = ExamMode , examSynchronicity :: Maybe ExamSynchronicity , examRequiredEquipment :: Maybe ExamRequiredEquipment } + deriving (Generic, Typeable) + deriving anyclass (NFData) deriveJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 1 , sumEncoding = UntaggedValue @@ -582,6 +594,7 @@ data ExamModePredicate | ExamModePredSynchronicity ExamSynchronicityPreset | ExamModePredRequiredEquipment ExamRequiredEquipmentPreset deriving (Eq, Ord, Read, Show, Generic, Typeable) + deriving anyclass (NFData) deriveJSON defaultOptions { constructorTagModifier = camelToPathPiece' 3 , sumEncoding = TaggedObject "setting" "preset" @@ -592,6 +605,7 @@ deriveFinite ''ExamModePredicate newtype ExamModeDNF = ExamModeDNF { examModeDNF :: PredDNF ExamModePredicate } deriving (Eq, Ord, Read, Show, Generic, Typeable) deriving newtype (ToJSON, FromJSON, PathPiece) + deriving anyclass (NFData) derivePersistFieldJSON ''ExamModeDNF @@ -600,7 +614,7 @@ data ExamCloseMode = ExamCloseSeparate | ExamCloseOnFinished { examCloseOnFinishedHidden :: Bool } deriving (Eq, Ord, Read, Show, Generic, Typeable) - deriving anyclass (Binary) + deriving anyclass (Binary, NFData) deriveFinite ''ExamCloseMode finitePathPiece ''ExamCloseMode ["separate", "on-finished", "on-finished-hidden"] derivePersistFieldPathPiece ''ExamCloseMode diff --git a/src/Model/Types/File.hs b/src/Model/Types/File.hs index f397a66e6..28c649dfd 100644 --- a/src/Model/Types/File.hs +++ b/src/Model/Types/File.hs @@ -157,7 +157,7 @@ data FileReference = FileReference , fileReferenceContent :: Maybe FileContentReference , fileReferenceModified :: UTCTime } deriving (Eq, Ord, Read, Show, Generic, Typeable) - deriving anyclass (Hashable, Binary) + deriving anyclass (Hashable, Binary, NFData) makeLenses_ ''FileReference deriveJSON defaultOptions @@ -179,7 +179,7 @@ instance HasFileReference Void where instance HasFileReference FileReference where data FileReferenceResidual FileReference = FileReferenceResidual deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable) - deriving anyclass (Universe, Finite) + deriving anyclass (Universe, Finite, NFData) -- newtype FileReferenceTitleMap FileReference add = FileReferenceFileReferenceTitleMap { unFileReferenceFileReferenceTitleMap :: Map FilePath (FileReferenceTitleMapElem FileReference add) } -- deriving (Eq, Ord, Read, Show, Generic, Typeable) -- deriving newtype (Semigroup, Monoid) @@ -196,6 +196,7 @@ instance HasFileReference PureFile where newtype FileReferenceResidual PureFile = PureFileResidual { unPureFileResidual :: Maybe ByteString } deriving (Eq, Ord, Read, Show, Generic, Typeable) deriving newtype (ToJSON, FromJSON) + deriving anyclass (NFData) _FileReference = iso toFileReference fromFileReference where @@ -213,6 +214,7 @@ instance HasFileReference PureFile where instance (HasFileReference a, HasFileReference b) => HasFileReference (Either a b) where newtype FileReferenceResidual (Either a b) = FileReferenceResidualEither { unFileReferenceResidualEither :: Either (FileReferenceResidual a) (FileReferenceResidual b) } + deriving (Generic, Typeable) _FileReference = iso doSplit doJoin where doSplit (Right r) = over _2 (FileReferenceResidualEither . Right) $ r ^. _FileReference @@ -225,6 +227,7 @@ instance HasFileReference record => HasFileReference (Entity record) where { fileReferenceResidualEntityKey :: Key record , fileReferenceResidualEntityResidual :: FileReferenceResidual record } + deriving (Generic, Typeable) _FileReference = iso doSplit doJoin where doSplit Entity{..} = (fRef, FileReferenceResidualEntity entityKey res) @@ -243,11 +246,14 @@ newtype instance FileReferenceTitleMap FileReference add = FileReferenceFileRefe } deriving (Eq, Ord, Read, Show, Generic, Typeable) deriving newtype (Semigroup, Monoid) + deriving anyclass (NFData) data FileReferenceFileReferenceTitleMapElem add = FileReferenceFileReferenceTitleMapElem { fRefTitleMapContent :: Maybe FileContentReference , fRefTitleMapModified :: UTCTime , fRefTitleMapAdditional :: add - } deriving (Eq, Ord, Read, Show, Generic, Typeable) + } + deriving (Eq, Ord, Read, Show, Generic, Typeable) + deriving anyclass (NFData) makePrisms ''FileReferenceFileReferenceTitleMapElem @@ -265,7 +271,9 @@ instance FileReferenceTitleMapConvertible add FileReference FileReference where data FileFieldUserOption a = FileFieldUserOption { fieldOptionForce :: Bool , fieldOptionDefault :: a - } deriving (Eq, Ord, Read, Show, Generic, Typeable) + } + deriving (Eq, Ord, Read, Show, Generic, Typeable) + deriving anyclass (NFData) deriveJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 2 @@ -279,11 +287,13 @@ data FileField fileid = FileField , fieldMaxFileSize :: Maybe Natural , fieldAdditionalFiles :: FileReferenceTitleMap fileid (FileFieldUserOption Bool) , fieldAllEmptyOk :: Bool - } deriving (Generic, Typeable) + } + deriving (Generic, Typeable) deriving instance Eq (FileReferenceTitleMap fileid (FileFieldUserOption Bool)) => Eq (FileField fileid) deriving instance Ord (FileReferenceTitleMap fileid (FileFieldUserOption Bool)) => Ord (FileField fileid) deriving instance Read (FileReferenceTitleMap fileid (FileFieldUserOption Bool)) => Read (FileField fileid) deriving instance Show (FileReferenceTitleMap fileid (FileFieldUserOption Bool)) => Show (FileField fileid) +deriving anyclass instance NFData (FileReferenceTitleMap fileid (FileFieldUserOption Bool)) => NFData (FileField fileid) instance ToJSON (FileField FileReference) where toJSON FileField{..} = JSON.object $ catMaybes diff --git a/src/Model/Types/Mail.hs b/src/Model/Types/Mail.hs index a6e96ad4f..e3b6cdd93 100644 --- a/src/Model/Types/Mail.hs +++ b/src/Model/Types/Mail.hs @@ -64,11 +64,7 @@ data NotificationTrigger | NTExamOfficeExamResultsChanged | NTCourseRegistered deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable) - -instance Universe NotificationTrigger -instance Finite NotificationTrigger - -instance Hashable NotificationTrigger + deriving anyclass (Universe, Finite, Hashable, NFData) nullaryPathPiece ''NotificationTrigger $ camelToPathPiece' 1 pathPieceJSON ''NotificationTrigger @@ -78,6 +74,7 @@ pathPieceJSONKey ''NotificationTrigger newtype NotificationSettings = NotificationSettings { notificationAllowed :: NotificationTrigger -> Bool } deriving (Generic, Typeable) deriving newtype (Eq, Ord, Read, Show) + deriving anyclass (NFData) instance Default NotificationSettings where def = NotificationSettings $ not . flip HashSet.member defaultOff @@ -117,7 +114,7 @@ instance PathPiece BounceSecret where newtype MailContent = MailContent [Alternatives] deriving (Eq, Show, Generic, Typeable) deriving newtype (ToJSON, FromJSON) - deriving anyclass (Binary) + deriving anyclass (Binary, NFData) derivePersistFieldJSON ''MailContent diff --git a/src/Model/Types/Markup.hs b/src/Model/Types/Markup.hs index f60ffb57e..8170de721 100644 --- a/src/Model/Types/Markup.hs +++ b/src/Model/Types/Markup.hs @@ -30,7 +30,7 @@ data MarkupFormat | MarkupHtml | MarkupPlaintext deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic, Typeable) - deriving anyclass (Universe, Finite) + deriving anyclass (Universe, Finite, NFData) nullaryPathPiece ''MarkupFormat $ camelToPathPiece' 1 pathPieceJSON ''MarkupFormat @@ -38,7 +38,9 @@ data StoredMarkup = StoredMarkup { markupInputFormat :: MarkupFormat , markupInput :: LT.Text , markupOutput :: Html - } deriving (Read, Show, Generic, Typeable) + } + deriving (Read, Show, Generic, Typeable) + deriving anyclass (NFData) htmlToStoredMarkup :: Html -> StoredMarkup htmlToStoredMarkup html = StoredMarkup diff --git a/src/Model/Types/Misc.hs b/src/Model/Types/Misc.hs index d2a0faf12..6bfae3fc6 100644 --- a/src/Model/Types/Misc.hs +++ b/src/Model/Types/Misc.hs @@ -24,7 +24,7 @@ import Web.HttpApiData data StudyFieldType = FieldPrimary | FieldSecondary deriving (Eq, Ord, Enum, Show, Read, Bounded, Generic) - deriving anyclass (Universe, Finite) + deriving anyclass (Universe, Finite, NFData) derivePersistField "StudyFieldType" nullaryPathPiece ''StudyFieldType $ camelToPathPiece' 1 @@ -41,14 +41,12 @@ data Theme | ThemeMossGreen | ThemeSkyLove deriving (Eq, Ord, Bounded, Enum, Show, Read, Generic) + deriving anyclass (Universe, Finite, NFData) deriveJSON defaultOptions { constructorTagModifier = fromJust . stripPrefix "Theme" } ''Theme -instance Universe Theme -instance Finite Theme - nullaryPathPiece ''Theme $ camelToPathPiece' 1 $(deriveSimpleWith ''ToMessage 'toMessage (over Text.packed $ Text.intercalate " " . unsafeTail . splitCamel) ''Theme) -- describe theme to user @@ -64,8 +62,7 @@ data FavouriteReason | FavouriteManual | FavouriteCurrent deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable) -instance Universe FavouriteReason -instance Finite FavouriteReason + deriving anyclass (Universe, Finite, NFData) deriveJSON defaultOptions { constructorTagModifier = camelToPathPiece' 1 } ''FavouriteReason @@ -77,8 +74,7 @@ data Sex | SexFemale | SexNotApplicable deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable) -instance Universe Sex -instance Finite Sex + deriving anyclass (Universe, Finite, NFData) deriveJSON defaultOptions { constructorTagModifier = camelToPathPiece' 1 } ''Sex @@ -129,7 +125,7 @@ data TokenBucketIdent = TokenBucketInjectFiles | TokenBucketInjectFilesCount | TokenBucketPruneFiles | TokenBucketRechunkFiles deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable) - deriving anyclass (Universe, Finite, Hashable) + deriving anyclass (Universe, Finite, Hashable, NFData) nullaryPathPiece ''TokenBucketIdent $ camelToPathPiece' 2 pathPieceJSON ''TokenBucketIdent diff --git a/src/Model/Types/Room.hs b/src/Model/Types/Room.hs index 54ec3eda9..c30fe818a 100644 --- a/src/Model/Types/Room.hs +++ b/src/Model/Types/Room.hs @@ -16,6 +16,7 @@ data RoomReference , roomRefInstructions :: Maybe StoredMarkup } deriving (Eq, Ord, Show, Generic, Typeable) + deriving anyclass (NFData) deriveJSON defaultOptions { constructorTagModifier = camelToPathPiece' 2 diff --git a/src/Model/Types/School.hs b/src/Model/Types/School.hs index 1e4a2d024..0b9f65634 100644 --- a/src/Model/Types/School.hs +++ b/src/Model/Types/School.hs @@ -10,10 +10,7 @@ data SchoolFunction | SchoolExamOffice | SchoolAllocation deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable) -instance Universe SchoolFunction -instance Finite SchoolFunction -instance Hashable SchoolFunction -instance NFData SchoolFunction + deriving anyclass (Universe, Finite, Hashable, NFData) nullaryPathPiece ''SchoolFunction $ camelToPathPiece' 1 pathPieceJSON ''SchoolFunction diff --git a/src/Model/Types/Security.hs b/src/Model/Types/Security.hs index 3e4715d61..5b83645c3 100644 --- a/src/Model/Types/Security.hs +++ b/src/Model/Types/Security.hs @@ -250,7 +250,7 @@ data UserGroupName = UserGroupMetrics | UserGroupCrontab | UserGroupCustom { userGroupCustomName :: CI Text } deriving (Eq, Ord, Read, Show, Generic, Typeable) - deriving anyclass (Hashable) + deriving anyclass (Hashable, NFData) instance PathPiece UserGroupName where toPathPiece UserGroupMetrics = "metrics" diff --git a/src/Model/Types/Sheet.hs b/src/Model/Types/Sheet.hs index 0528cb454..23b1a7f80 100644 --- a/src/Model/Types/Sheet.hs +++ b/src/Model/Types/Sheet.hs @@ -168,7 +168,8 @@ data SheetGroup = Arbitrary { maxParticipants :: Natural } | RegisteredGroups | NoGroups - deriving (Show, Read, Eq, Generic) + deriving (Show, Read, Eq, Generic, Typeable) + deriving anyclass (NFData) deriveJSON defaultOptions ''SheetGroup derivePersistFieldJSON ''SheetGroup @@ -200,7 +201,9 @@ data UploadSpecificFile = UploadSpecificFile , specificFileRequired :: Bool , specificFileEmptyOk :: Bool , specificFileMaxSize :: Maybe Natural - } deriving (Show, Read, Eq, Ord, Generic) + } + deriving (Show, Read, Eq, Ord, Generic, Typeable) + deriving anyclass (NFData) instance ToJSON UploadSpecificFile where toJSON UploadSpecificFile{..} = Aeson.object @@ -229,7 +232,8 @@ data UploadMode = NoUpload | UploadSpecific { uploadSpecificFiles :: NonNull (Set UploadSpecificFile) } - deriving (Show, Read, Eq, Ord, Generic) + deriving (Show, Read, Eq, Ord, Generic, Typeable) + deriving anyclass (NFData) defaultExtensionRestriction :: Maybe (NonNull (Set Extension)) defaultExtensionRestriction = fromNullable $ Set.fromList ["txt", "pdf"] @@ -284,7 +288,8 @@ data SubmissionMode = SubmissionMode { submissionModeCorrector :: Bool , submissionModeUser :: Maybe UploadMode } - deriving (Show, Read, Eq, Ord, Generic) + deriving (Show, Read, Eq, Ord, Generic, Typeable) + deriving anyclass (NFData) deriveJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 2 @@ -319,12 +324,11 @@ data Load -- = ByTutorial { countsToLoad :: Bool } | ByProportion { load :: Rati , byProportion :: Rational -- ^ workload proportion of all submission not assigned to tutorial leaders } deriving (Show, Read, Eq, Ord, Generic) + deriving anyclass (Hashable, NFData) deriveJSON defaultOptions ''Load derivePersistFieldJSON ''Load -instance Hashable Load - instance Semigroup Load where (Load byTut prop) <> (Load byTut' prop') = Load byTut'' (prop + prop') where @@ -346,7 +350,7 @@ instance Monoid Load where data CorrectorState = CorrectorNormal | CorrectorMissing | CorrectorExcused deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic) - deriving anyclass (Universe, Finite, Hashable) + deriving anyclass (Universe, Finite, Hashable, NFData) deriveJSON defaultOptions { constructorTagModifier = fromJust . stripPrefix "Corrector" diff --git a/src/Model/Types/Submission.hs b/src/Model/Types/Submission.hs index 4d52b6939..21fed7e4b 100644 --- a/src/Model/Types/Submission.hs +++ b/src/Model/Types/Submission.hs @@ -56,6 +56,7 @@ newtype Pseudonym = Pseudonym Word24 deriving newtype ( Bounded, Enum, Integral, Num, Real, Ix , PersistField, Random ) + deriving anyclass (NFData) instance PersistFieldSql Pseudonym where sqlType _ = sqlType $ Proxy @Word24 diff --git a/src/Model/Types/Workflow.hs b/src/Model/Types/Workflow.hs index 8ab3510e1..69751dfa7 100644 --- a/src/Model/Types/Workflow.hs +++ b/src/Model/Types/Workflow.hs @@ -78,15 +78,16 @@ newtype WorkflowGraph fileid userid = WorkflowGraph deriving instance (Eq fileid, Eq userid, Typeable fileid, Typeable userid, Eq (FileField fileid)) => Eq (WorkflowGraph fileid userid) deriving instance (Ord fileid, Ord userid, Typeable fileid, Typeable userid, Ord (FileField fileid)) => Ord (WorkflowGraph fileid userid) deriving instance (Show fileid, Show userid, Show (FileField fileid)) => Show (WorkflowGraph fileid userid) +deriving anyclass instance (NFData fileid, NFData userid, NFData (FileField fileid)) => NFData (WorkflowGraph fileid userid) newtype WorkflowGraphReference = WorkflowGraphReference (Digest SHA3_256) deriving (Eq, Ord, Read, Show, Lift, Generic, Typeable) deriving newtype ( PersistField , PathPiece, ToHttpApiData, FromHttpApiData, ToJSON, FromJSON - , Hashable, NFData , ByteArrayAccess , Binary ) + deriving anyclass (Hashable, NFData) instance PersistFieldSql WorkflowGraphReference where sqlType _ = sqlType $ Proxy @(Digest SHA3_256) @@ -96,6 +97,7 @@ instance PersistFieldSql WorkflowGraphReference where newtype WorkflowGraphNodeLabel = WorkflowGraphNodeLabel { unWorkflowGraphNodeLabel :: CI Text } deriving stock (Eq, Ord, Read, Show, Data, Generic, Typeable) deriving newtype (IsString, ToJSON, ToJSONKey, FromJSON, FromJSONKey, PathPiece, PersistField, Binary) + deriving anyclass (NFData) instance PersistFieldSql WorkflowGraphNodeLabel where sqlType _ = sqlType $ Proxy @(CI Text) @@ -112,24 +114,30 @@ data WorkflowGraphNode fileid userid = WGN deriving instance (Eq fileid, Eq userid, Typeable fileid, Typeable userid, Eq (FileField fileid)) => Eq (WorkflowGraphNode fileid userid) deriving instance (Ord fileid, Ord userid, Typeable fileid, Typeable userid, Ord (FileField fileid)) => Ord (WorkflowGraphNode fileid userid) deriving instance (Show fileid, Show userid, Show (FileField fileid)) => Show (WorkflowGraphNode fileid userid) +deriving anyclass instance (NFData fileid, NFData userid, NFData (FileField fileid)) => NFData (WorkflowGraphNode fileid userid) data WorkflowNodeView userid = WorkflowNodeView { wnvViewers :: NonNull (Set (WorkflowRole userid)) , wnvDisplayLabel :: I18nText - } deriving (Eq, Ord, Read, Show, Data, Generic, Typeable) + } + deriving (Eq, Ord, Read, Show, Data, Generic, Typeable) + deriving anyclass (NFData) data WorkflowNodeMessage userid = WorkflowNodeMessage { wnmViewers :: NonNull (Set (WorkflowRole userid)) , wnmRestriction :: Maybe (PredDNF WorkflowGraphRestriction) , wnmStatus :: MessageStatus , wnmContent :: I18nHtml - } deriving (Eq, Ord, Read, Show, Generic, Typeable) + } + deriving (Eq, Ord, Read, Show, Generic, Typeable) + deriving anyclass (NFData) ----- WORKFLOW GRAPH: EDGES ----- newtype WorkflowGraphEdgeLabel = WorkflowGraphEdgeLabel { unWorkflowGraphEdgeLabel :: CI Text } deriving stock (Eq, Ord, Read, Show, Data, Generic, Typeable) deriving newtype (IsString, ToJSON, ToJSONKey, FromJSON, FromJSONKey, PathPiece, PersistField, Binary) + deriving anyclass (NFData) instance PersistFieldSql WorkflowGraphEdgeLabel where sqlType _ = sqlType $ Proxy @(CI Text) @@ -139,6 +147,7 @@ data WorkflowGraphRestriction | WorkflowGraphRestrictionPreviousNode { wgrPreviousNode :: WorkflowGraphNodeLabel } | WorkflowGraphRestrictionInitial deriving (Eq, Ord, Read, Show, Generic, Typeable) + deriving anyclass (NFData) data WorkflowGraphEdge fileid userid = WorkflowGraphEdgeManual @@ -165,13 +174,16 @@ data WorkflowGraphEdge fileid userid deriving instance (Eq fileid, Eq userid, Typeable fileid, Typeable userid, Eq (FileField fileid)) => Eq (WorkflowGraphEdge fileid userid) deriving instance (Ord fileid, Ord userid, Typeable fileid, Typeable userid, Ord (FileField fileid)) => Ord (WorkflowGraphEdge fileid userid) deriving instance (Show fileid, Show userid, Show (FileField fileid)) => Show (WorkflowGraphEdge fileid userid) +deriving anyclass instance (NFData fileid, NFData userid, NFData (FileField fileid)) => NFData (WorkflowGraphEdge fileid userid) data WorkflowEdgeMessage userid = WorkflowEdgeMessage { wemViewers :: NonNull (Set (WorkflowRole userid)) , wemRestriction :: Maybe (PredDNF WorkflowGraphRestriction) , wemStatus :: MessageStatus , wemContent :: I18nHtml - } deriving (Eq, Ord, Read, Show, Generic, Typeable) + } + deriving (Eq, Ord, Read, Show, Generic, Typeable) + deriving anyclass (NFData) -- | A wrapped `Scientific` -- @@ -180,6 +192,7 @@ newtype WorkflowGraphEdgeFormOrder = WorkflowGraphEdgeFormOrder { unWorkflowGrap deriving (Read, Show, Generic, Typeable) deriving (Eq, Ord) via (NTop (Maybe Scientific)) deriving (Semigroup, Monoid) via (Maybe (Min Scientific)) + deriving anyclass (NFData) newtype WorkflowGraphEdgeForm fileid userid = WorkflowGraphEdgeForm @@ -191,11 +204,13 @@ newtype WorkflowGraphEdgeForm fileid userid -- - optional fields are always considered to be filled -- -- since fields can reference other labels this allows arbitrary requirements to be encoded. - } deriving (Generic, Typeable) + } + deriving (Generic, Typeable) deriving instance (Eq fileid, Eq userid, Typeable fileid, Typeable userid, Eq (FileField fileid)) => Eq (WorkflowGraphEdgeForm fileid userid) deriving instance (Ord fileid, Ord userid, Typeable fileid, Typeable userid, Ord (FileField fileid)) => Ord (WorkflowGraphEdgeForm fileid userid) deriving instance (Show fileid, Show userid, Show (FileField fileid)) => Show (WorkflowGraphEdgeForm fileid userid) +deriving anyclass instance (NFData fileid, NFData userid, NFData (FileField fileid)) => NFData (WorkflowGraphEdgeForm fileid userid) ----- WORKFLOW GRAPH: ROLES / ACTORS ----- @@ -213,16 +228,21 @@ data WorkflowRole userid data WorkflowPayloadView userid = WorkflowPayloadView { wpvViewers :: NonNull (Set (WorkflowRole userid)) , wpvDisplayLabel :: I18nText - } deriving (Eq, Ord, Read, Show, Data, Generic, Typeable) + } + deriving (Eq, Ord, Read, Show, Data, Generic, Typeable) + deriving anyclass (NFData) data WorkflowPayloadSpec fileid userid = forall payload. Typeable payload => WorkflowPayloadSpec (WorkflowPayloadField fileid userid payload) deriving (Typeable) deriving instance (Show fileid, Show userid, Show (FileField fileid)) => Show (WorkflowPayloadSpec fileid userid) +instance (NFData fileid, NFData userid, NFData (FileField fileid)) => NFData (WorkflowPayloadSpec fileid userid) where + rnf (WorkflowPayloadSpec pField) = rnf pField data WorkflowPayloadFieldReference deriving (Typeable) +-- Don't forget to update the NFData instance for every change! data WorkflowPayloadField fileid userid (payload :: Type) where WorkflowPayloadFieldText :: { wpftLabel :: I18nText , wpftPlaceholder :: Maybe I18nText @@ -325,6 +345,18 @@ instance (Ord fileid, Ord userid, Typeable fileid, Typeable userid, Ord (FileFie (WorkflowPayloadFieldReference{}, _) -> LT (WorkflowPayloadFieldMultiple{}, _) -> GT +instance (NFData fileid, NFData userid, NFData (FileField fileid)) => NFData (WorkflowPayloadField fileid userid payload) where + rnf = \case + WorkflowPayloadFieldText{..} -> wpftLabel `deepseq` wpftPlaceholder `deepseq` wpftTooltip `deepseq` wpftDefault `deepseq` wpftLarge `deepseq` wpftOptional `deepseq` () + WorkflowPayloadFieldNumber{..} -> wpfnLabel `deepseq` wpfnPlaceholder `deepseq` wpfnTooltip `deepseq` wpfnDefault `deepseq` wpfnMin `deepseq` wpfnMax `deepseq` wpfnStep `deepseq` wpfnOptional `deepseq` () + WorkflowPayloadFieldBool{..} -> wpfbLabel `deepseq` wpfbTooltip `deepseq` wpfbDefault `deepseq` wpfbOptional `deepseq` () + WorkflowPayloadFieldDay{..} -> wpfdLabel `deepseq` wpfdTooltip `deepseq` wpfdDefault `deepseq` wpfdOptional `deepseq` () + WorkflowPayloadFieldFile{..} -> wpffLabel `deepseq` wpffTooltip `deepseq` wpffConfig `deepseq` wpffOptional `deepseq` () + WorkflowPayloadFieldUser{..} -> wpfuLabel `deepseq` wpfuTooltip `deepseq` wpfuDefault `deepseq` wpfuOptional `deepseq` () + WorkflowPayloadFieldCaptureUser -> () + WorkflowPayloadFieldReference{..} -> wpfrTarget `deepseq` () + WorkflowPayloadFieldMultiple{..} -> wpfmLabel `deepseq` wpfmTooltip `deepseq` wpfmDefault `deepseq` wpfmSub `deepseq` wpfmMin `deepseq` wpfmRange `deepseq` () + _WorkflowPayloadSpec :: forall payload fileid userid. ( Typeable payload, Typeable fileid, Typeable userid ) => Prism' (WorkflowPayloadSpec fileid userid) (WorkflowPayloadField fileid userid payload) @@ -332,7 +364,7 @@ _WorkflowPayloadSpec = prism' WorkflowPayloadSpec $ \(WorkflowPayloadSpec pF) -> data WorkflowPayloadField' = WPFText' | WPFNumber' | WPFBool' | WPFDay' | WPFFile' | WPFUser' | WPFCaptureUser' | WPFReference' | WPFMultiple' deriving (Eq, Ord, Enum, Bounded, Show, Read, Data, Generic, Typeable) - deriving anyclass (Universe, Finite) + deriving anyclass (Universe, Finite, NFData) ----- WORKFLOW INSTANCE ----- @@ -349,7 +381,7 @@ data WorkflowScope termid schoolid courseid data WorkflowScope' = WSGlobal' | WSTerm' | WSSchool' | WSTermSchool' | WSCourse' deriving (Eq, Ord, Enum, Bounded, Read, Show, Data, Generic, Typeable) - deriving anyclass (Universe, Finite) + deriving anyclass (Universe, Finite, NFData) classifyWorkflowScope :: WorkflowScope termid schoolid courseid -> WorkflowScope' classifyWorkflowScope = \case @@ -372,6 +404,7 @@ instance PersistFieldSql WorkflowPayloadLabel where newtype WorkflowStateIndex = WorkflowStateIndex { unWorkflowStateIndex :: Word64 } deriving stock (Eq, Ord, Show, Read, Data, Generic, Typeable) deriving newtype (Num, Real, Integral, Enum, Bounded, ToJSON, FromJSON, PathPiece, Binary) + deriving anyclass (NFData) type WorkflowState fileid userid = NonNull (Seq (WorkflowAction fileid userid)) @@ -395,13 +428,16 @@ data WorkflowAction fileid userid = WorkflowAction , wpTime :: UTCTime } deriving (Eq, Ord, Show, Generic, Typeable) + deriving anyclass (NFData) data WorkflowActionInfo fileid userid = WorkflowActionInfo { waiIx :: WorkflowStateIndex , waiFrom :: Maybe WorkflowGraphNodeLabel , waiHistory :: [WorkflowAction fileid userid] , waiAction :: WorkflowAction fileid userid - } deriving (Eq, Ord, Show, Generic, Typeable) + } + deriving (Eq, Ord, Show, Generic, Typeable) + deriving anyclass (NFData) workflowActionInfos :: WorkflowState fileid userid -> [WorkflowActionInfo fileid userid] workflowActionInfos wState @@ -416,6 +452,9 @@ workflowActionInfos wState data WorkflowFieldPayloadW fileid userid = forall payload. IsWorkflowFieldPayload' fileid userid payload => WorkflowFieldPayloadW (WorkflowFieldPayload fileid userid payload) deriving (Typeable) +instance (NFData fileid, NFData userid) => NFData (WorkflowFieldPayloadW fileid userid) where + rnf (WorkflowFieldPayloadW fPayload) = rnf fPayload + instance (Eq fileid, Eq userid, Typeable fileid, Typeable userid) => Eq (WorkflowFieldPayloadW fileid userid) where (WorkflowFieldPayloadW a) == (WorkflowFieldPayloadW b) = case typeOf a `eqTypeRep` typeOf b of @@ -476,6 +515,7 @@ workflowPayloadSort ordFiles ordUsers (WorkflowFieldPayloadW a) (WorkflowFieldPa instance (Show fileid, Show userid) => Show (WorkflowFieldPayloadW fileid userid) where show (WorkflowFieldPayloadW payload) = show payload +-- Don't forget to update the NFData instance for every change! data WorkflowFieldPayload fileid userid (payload :: Type) where WFPText :: Text -> WorkflowFieldPayload fileid userid Text WFPNumber :: Scientific -> WorkflowFieldPayload fileid userid Scientific @@ -489,6 +529,15 @@ deriving instance (Show fileid, Show userid) => Show (WorkflowFieldPayload filei deriving instance (Typeable fileid, Typeable userid, Eq fileid, Eq userid) => Eq (WorkflowFieldPayload fileid userid payload) deriving instance (Typeable fileid, Typeable userid, Ord fileid, Ord userid) => Ord (WorkflowFieldPayload fileid userid payload) +instance (NFData fileid, NFData userid) => NFData (WorkflowFieldPayload fileid userid payload) where + rnf = \case + WFPText t -> rnf t + WFPNumber n -> rnf n + WFPBool b -> rnf b + WFPDay d -> rnf d + WFPFile f -> rnf f + WFPUser u -> rnf u + _WorkflowFieldPayloadW :: forall payload fileid userid. ( IsWorkflowFieldPayload' fileid userid payload, Typeable fileid, Typeable userid ) => Prism' (WorkflowFieldPayloadW fileid userid) (WorkflowFieldPayload fileid userid payload) @@ -496,7 +545,7 @@ _WorkflowFieldPayloadW = prism' WorkflowFieldPayloadW $ \(WorkflowFieldPayloadW data WorkflowFieldPayload' = WFPText' | WFPNumber' | WFPBool' | WFPDay' | WFPFile' | WFPUser' deriving (Eq, Ord, Enum, Bounded, Show, Read, Data, Generic, Typeable) - deriving anyclass (Universe, Finite) + deriving anyclass (Universe, Finite, NFData) type IsWorkflowFieldPayload' fileid userid payload = IsWorkflowFieldPayload fileid fileid userid userid payload payload diff --git a/src/Network/Mail/Mime/Instances.hs b/src/Network/Mail/Mime/Instances.hs index 841ab9f24..3f36d553a 100644 --- a/src/Network/Mail/Mime/Instances.hs +++ b/src/Network/Mail/Mime/Instances.hs @@ -31,9 +31,7 @@ import Control.Lens deriving instance Read Address deriving instance Ord Address deriving instance Generic Address - -instance Hashable Address -instance NFData Address +deriving anyclass instance Hashable Address deriveToJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 1 @@ -58,6 +56,7 @@ instance Csv.DefaultOrdered Address where newtype MailHeaders = MailHeaders Headers deriving (Eq, Ord, Read, Show, Generic, Typeable) + deriving anyclass (NFData) instance ToJSON MailHeaders where toJSON (MailHeaders hs) = toJSON $ over (traverse . _1) decodeUtf8 hs @@ -76,6 +75,13 @@ instance Binary PartContent instance Binary Part instance Binary Address instance Binary Mail + +deriving anyclass instance NFData Encoding +deriving anyclass instance NFData Disposition +deriving anyclass instance NFData PartContent +deriving anyclass instance NFData Part +deriving anyclass instance NFData Address +deriving anyclass instance NFData Mail deriveJSON defaultOptions { constructorTagModifier = camelToPathPiece diff --git a/src/Settings/Cluster.hs b/src/Settings/Cluster.hs index c13ef8c28..faa409b08 100644 --- a/src/Settings/Cluster.hs +++ b/src/Settings/Cluster.hs @@ -7,7 +7,6 @@ module Settings.Cluster ) where import ClassyPrelude.Yesod -import Web.HttpApiData import Data.Kind (Type) @@ -51,21 +50,15 @@ data ClusterSettingsKey | ClusterMemcachedKey | ClusterVerpSecret | ClusterAuthKey - deriving (Eq, Ord, Enum, Bounded, Show, Read) - -instance Universe ClusterSettingsKey -instance Finite ClusterSettingsKey + deriving (Eq, Ord, Enum, Bounded, Show, Read, Generic, Typeable) + deriving anyclass (Universe, Finite, NFData) nullaryPathPiece ''ClusterSettingsKey $ camelToPathPiece' 1 pathPieceJSON ''ClusterSettingsKey pathPieceJSONKey ''ClusterSettingsKey +pathPieceHttpApiData ''ClusterSettingsKey derivePersistFieldPathPiece ''ClusterSettingsKey -instance ToHttpApiData ClusterSettingsKey where - toUrlPiece = toPathPiece -instance FromHttpApiData ClusterSettingsKey where - parseUrlPiece = maybe (Left "Could not parse url piece") Right . fromPathPiece - class (ToJSON (ClusterSettingValue key), FromJSON (ClusterSettingValue key)) => ClusterSetting (key :: ClusterSettingsKey) where type ClusterSettingValue key :: Type diff --git a/src/Utils/ARC.hs b/src/Utils/ARC.hs index 7470e36fe..1545ebf08 100644 --- a/src/Utils/ARC.hs +++ b/src/Utils/ARC.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE BangPatterns #-} + module Utils.ARC ( ARCTick , ARC, initARC @@ -133,17 +135,18 @@ arcAlterF :: forall f k w v. ( Ord k, Hashable k , Functor f , Integral w + , NFData k, NFData w, NFData v ) => k -> (Maybe (v, w) -> f (Maybe (v, w))) -> ARC k w v -> ARCTick -> f (ARC k w v, ARCTick) -- | Unchecked precondition: item weights are always less than `arcMaximumWeight` -arcAlterF unhashedK@(hashed -> k) f oldARC@ARC{..} now +arcAlterF !(force -> unhashedK@(hashed -> k)) f oldARC@ARC{..} now | later <= initialARCTick = uncurry (arcAlterF unhashedK f) $ initARC arcMaximumGhost arcMaximumWeight | otherwise = (, later) <$> if | Just (_p, x@(_, w), arcFrequent') <- HashPSQ.deleteView k arcFrequent - -> f (Just x) <&> \(fromMaybe x -> x'@(_, w')) + -> f (Just x) <&> \(fromMaybe x -> !(force -> x'@(_, w'))) -> let (arcFrequent'', arcFrequentWeight'', arcGhostFrequent') = evictToSize (arcMaximumWeight |- arcTargetRecent |- w') arcFrequent' (arcFrequentWeight - w) arcGhostFrequent in oldARC { arcFrequent = HashPSQ.insert k now x' arcFrequent'' @@ -151,7 +154,7 @@ arcAlterF unhashedK@(hashed -> k) f oldARC@ARC{..} now , arcGhostFrequent = arcGhostFrequent' } | Just (_p, x@(_, w), arcRecent') <- HashPSQ.deleteView k arcRecent - -> f (Just x) <&> \(fromMaybe x -> x'@(_, w')) + -> f (Just x) <&> \(fromMaybe x -> !(force -> x'@(_, w'))) -> let (arcFrequent', arcFrequentWeight', arcGhostFrequent') = evictToSize (arcMaximumWeight |- arcTargetRecent |- w') arcFrequent arcFrequentWeight arcGhostFrequent in oldARC { arcRecent = arcRecent' @@ -165,7 +168,7 @@ arcAlterF unhashedK@(hashed -> k) f oldARC@ARC{..} now Nothing -> oldARC { arcGhostRecent = HashPSQ.insert k now () arcGhostRecent' } - Just x@(_, w) + Just !(force -> x@(_, w)) -> let arcTargetRecent' = min arcMaximumWeight $ arcTargetRecent + max avgWeight (round $ toRational (HashPSQ.size arcGhostFrequent) / toRational (HashPSQ.size arcGhostRecent) * toRational avgWeight) (arcFrequent', arcFrequentWeight', arcGhostFrequent') = evictToSize (arcMaximumWeight |- arcTargetRecent' |- w) arcFrequent arcFrequentWeight arcGhostFrequent (arcRecent', arcRecentWeight', arcGhostRecent'') = evictToSize (max arcTargetRecent' $ arcMaximumWeight |- arcFrequentWeight' |- w) arcRecent arcRecentWeight arcGhostRecent' @@ -183,7 +186,7 @@ arcAlterF unhashedK@(hashed -> k) f oldARC@ARC{..} now Nothing -> oldARC { arcGhostFrequent = HashPSQ.insert k now () arcGhostFrequent' } - Just x@(_, w) + Just !(force -> x@(_, w)) -> let arcTargetRecent' = arcTargetRecent |- max avgWeight (round $ toRational (HashPSQ.size arcGhostRecent) / toRational (HashPSQ.size arcGhostFrequent) * toRational avgWeight) (arcFrequent', arcFrequentWeight', arcGhostFrequent'') = evictToSize (arcMaximumWeight |- arcTargetRecent' |- w) arcFrequent arcFrequentWeight arcGhostFrequent' (arcRecent', arcRecentWeight', arcGhostRecent') = evictToSize (max arcTargetRecent' $ arcMaximumWeight |- arcFrequentWeight' |- w) arcRecent arcRecentWeight arcGhostRecent @@ -200,7 +203,7 @@ arcAlterF unhashedK@(hashed -> k) f oldARC@ARC{..} now Nothing -> oldARC { arcGhostRecent = HashPSQ.insert k now () $ evictGhostToCount arcGhostRecent } - Just x@(_, w) + Just !(force -> x@(_, w)) -> let (arcRecent', arcRecentWeight', arcGhostRecent') = evictToSize (max arcTargetRecent (arcMaximumWeight |- arcFrequentWeight) |- w) arcRecent arcRecentWeight arcGhostRecent in oldARC { arcRecent = HashPSQ.insert k now x arcRecent' @@ -228,6 +231,7 @@ arcAlterF unhashedK@(hashed -> k) f oldARC@ARC{..} now lookupARC :: forall k w v. ( Ord k, Hashable k , Integral w + , NFData k, NFData w, NFData v ) => k -> (ARC k w v, ARCTick) @@ -237,6 +241,7 @@ lookupARC k = getConst . uncurry (arcAlterF k Const) insertARC :: forall k w v. ( Ord k, Hashable k , Integral w + , NFData k, NFData w, NFData v ) => k -> Maybe (v, w) @@ -272,7 +277,7 @@ cachedARC' :: forall k w v m. cachedARC' (ARCHandle arcVar) k f = do oldVal <- lookupARC k <$> readIORef arcVar newVal <- f oldVal - modifyIORef' arcVar $ force . uncurry (insertARC k newVal) + modifyIORef' arcVar $ uncurry (insertARC k newVal) -- Using `modifyIORef'` instead of `atomicModifyIORef'` might very -- well drop newer values computed during the update. -- @@ -304,6 +309,7 @@ lookupARCHandle :: forall k w v m. ( MonadIO m , Ord k, Hashable k , Integral w + , NFData k, NFData w, NFData v ) => ARCHandle k w v -> k diff --git a/src/Utils/DateTime.hs b/src/Utils/DateTime.hs index de3f76087..a5c013b4a 100644 --- a/src/Utils/DateTime.hs +++ b/src/Utils/DateTime.hs @@ -100,6 +100,7 @@ instance HasLocalTime TimeOfDay where newtype DateTimeFormat = DateTimeFormat { unDateTimeFormat :: String } deriving (Eq, Ord, Read, Show, Data, Generic, Typeable) deriving newtype (ToJSON, FromJSON, PersistField, IsString) + deriving anyclass (NFData) instance PersistFieldSql DateTimeFormat where sqlType _ = sqlType $ Proxy @String @@ -108,10 +109,7 @@ instance Hashable DateTimeFormat data SelDateTimeFormat = SelFormatDate | SelFormatTime | SelFormatDateTime deriving (Eq, Ord, Read, Show, Enum, Bounded, Data, Generic, Typeable) - -instance Universe SelDateTimeFormat -instance Finite SelDateTimeFormat -instance Hashable SelDateTimeFormat + deriving anyclass (Universe, Finite, Hashable, NFData) nullaryPathPiece ''SelDateTimeFormat $ camelToPathPiece' 2 pathPieceJSON ''SelDateTimeFormat diff --git a/src/Utils/Icon.hs b/src/Utils/Icon.hs index 11759a60f..cf553465f 100644 --- a/src/Utils/Icon.hs +++ b/src/Utils/Icon.hs @@ -98,6 +98,7 @@ data Icon | IconVideo | IconSubmissionUserDuplicate deriving (Eq, Ord, Enum, Bounded, Show, Read, Generic, Typeable) + deriving anyclass (Universe, Finite, NFData) iconText :: Icon -> Text iconText = \case @@ -175,8 +176,6 @@ iconText = \case IconVideo -> "video" IconSubmissionUserDuplicate -> "copy" -instance Universe Icon -instance Finite Icon nullaryPathPiece ''Icon $ camelToPathPiece' 1 deriveLift ''Icon diff --git a/src/Utils/Message.hs b/src/Utils/Message.hs index 168c3e132..27ccafe41 100644 --- a/src/Utils/Message.hs +++ b/src/Utils/Message.hs @@ -31,7 +31,7 @@ import Text.HTML.SanitizeXSS (sanitizeBalance) data MessageStatus = Error | Warning | Info | Success deriving (Eq, Ord, Enum, Bounded, Show, Read, Lift, Generic, Typeable) - deriving anyclass (Universe, Finite) + deriving anyclass (Universe, Finite, NFData) instance Default MessageStatus where def = Info diff --git a/src/Utils/TH.hs b/src/Utils/TH.hs index b218011d1..7e5e39699 100644 --- a/src/Utils/TH.hs +++ b/src/Utils/TH.hs @@ -222,6 +222,7 @@ mkI18nWidgetEnum (splitCamel -> namebase) basename = do , derivClause (Just AnyclassStrategy) [ conT ''Universe , conT ''Finite + , conT ''NFData ] ] , instanceD (cxt []) (conT ''PathPiece `appT` conT dataName)