From 4b73181a8b29138121a7bf0f63eb2a688d47142e Mon Sep 17 00:00:00 2001 From: Oliver Braun Date: Tue, 6 Jun 2017 12:07:17 +0200 Subject: [PATCH] replace String with Text in Validation #8 --- plexams-cli/Plexams/CLI/Commands.hs | 8 +- plexams-cli/plexams-cli.cabal | 1 + plexams-core/Plexams/Types.hs | 29 +++++- plexams-core/Plexams/Validation.hs | 14 ++- plexams-core/Plexams/Validation/Exports.hs | 35 +++---- plexams-core/Plexams/Validation/Rooms.hs | 26 +++--- .../Plexams/Validation/ScheduledExams.hs | 91 +++++++++++-------- plexams-core/Plexams/Validation/Sources.hs | 22 +++-- plexams-core/plexams-core.cabal | 1 + 9 files changed, 144 insertions(+), 83 deletions(-) diff --git a/plexams-cli/Plexams/CLI/Commands.hs b/plexams-cli/Plexams/CLI/Commands.hs index 0a30ff9..cd15b8a 100644 --- a/plexams-cli/Plexams/CLI/Commands.hs +++ b/plexams-cli/Plexams/CLI/Commands.hs @@ -1,8 +1,11 @@ +{-# LANGUAGE OverloadedStrings #-} module Plexams.CLI.Commands ( runCommand ) where import Data.List (intercalate) +import qualified Data.Text as Text +import qualified Data.Text.IO as Text import Plexams.CLI.Types import Plexams.Export.HTML import Plexams.Export.Markdown @@ -50,7 +53,8 @@ validate config = stdoutOrFile config . validate' where validate' plan = let (ok, msgs) = P.validate plan - in "\n# " ++ show ok ++ "\n\n" ++ intercalate "\n\n" msgs + in "\n# " ++ show ok ++ "\n\n" ++ intercalate "\n\n" + (map Text.unpack msgs) query :: Config -> Plan -> IO () query config plan = stdoutOrFile config @@ -73,7 +77,7 @@ export config plan = Nothing -> return () Just fp -> do (valRes, msgs) <- P.validateZPAExport fp plan - putStrLn $ intercalate "\n\n" msgs + Text.putStrLn $ Text.intercalate "\n\n" msgs print valRes Export Handicaps -> stdoutOrFile config $ exportHandicaps plan diff --git a/plexams-cli/plexams-cli.cabal b/plexams-cli/plexams-cli.cabal index 98fc898..6d8cd7b 100644 --- a/plexams-cli/plexams-cli.cabal +++ b/plexams-cli/plexams-cli.cabal @@ -43,6 +43,7 @@ library , plexams-core , plexams-generators , plexams-gui + , text , time , containers default-language: Haskell2010 diff --git a/plexams-core/Plexams/Types.hs b/plexams-core/Plexams/Types.hs index 27683c4..e89d97c 100644 --- a/plexams-core/Plexams/Types.hs +++ b/plexams-core/Plexams/Types.hs @@ -1,4 +1,5 @@ -{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedStrings #-} module Plexams.Types ( -- * Config SemesterConfig(..) @@ -69,12 +70,14 @@ import Data.Char (digitToInt) import Data.List (intercalate, partition, sortBy, (\\)) import qualified Data.Map as M import Data.Maybe (isJust, mapMaybe) +import Data.Monoid ((<>)) import Data.Ord (Down (Down), comparing) import qualified Data.Set as S import Data.Text (Text, unpack) import Data.Time.Calendar import GHC.Exts (groupWith) import GHC.Generics +import TextShow (TextShow, showb) data SemesterConfig = SemesterConfig @@ -322,15 +325,35 @@ instance Show Group where ++ maybe "" show mS ++ maybe "" (("("++) . (++")") . show) mReg +instance TextShow Group where + showb (Group d mI mS mReg) = showb d + <> maybe "" showb mI + <> maybe "" showb mS + <> maybe "" (("("<>) . (<>")") . showb) mReg + data Degree = IB | IC | IF | GO | IG | IN | IS deriving (Show, Eq, Ord, Read, Enum) +instance TextShow Degree where + showb IB = "IB" + showb IC = "IC" + showb IF = "IF" + showb GO = "GO" + showb IG = "IG" + showb IN = "IN" + showb IS = "IS" + allDegrees :: [Degree] allDegrees = [IB .. IS] data Subgroup = A | B | C deriving (Show, Eq, Ord) +instance TextShow Subgroup where + showb A = "A" + showb B = "B" + showb C = "C" + instance Read Group where readsPrec _ str = [(parseGroup str, "")] @@ -371,6 +394,10 @@ data Person = Person } deriving (Eq, Show, Ord) +instance TextShow Person where + showb (Person id shortName _) = + showb id <> ". " <> showb shortName + data AddExamToSlot = AddExamToSlot { planManipAnCode :: Integer diff --git a/plexams-core/Plexams/Validation.hs b/plexams-core/Plexams/Validation.hs index 48a8565..1611a79 100644 --- a/plexams-core/Plexams/Validation.hs +++ b/plexams-core/Plexams/Validation.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE OverloadedStrings #-} module Plexams.Validation ( validate , module Plexams.Validation.Exports @@ -8,6 +9,7 @@ import Control.Monad.Writer import Data.List (nub) import qualified Data.Map as M import Data.Maybe (isJust, mapMaybe) +import Data.Text (Text, append) import GHC.Exts (groupWith) import Plexams.Query import Plexams.Types @@ -15,11 +17,12 @@ import Plexams.Validation.Exports import qualified Plexams.Validation.Rooms import qualified Plexams.Validation.ScheduledExams import qualified Plexams.Validation.Sources +import TextShow (showt) -validate :: Plan -> (ValidationResult, [String]) +validate :: Plan -> (ValidationResult, [Text]) validate = runWriter . validate' -validate' :: Plan -> Writer [String] ValidationResult +validate' :: Plan -> Writer [Text] ValidationResult validate' plan = do tell ["# Validation"] sourcesOk <- Plexams.Validation.Sources.validate plan @@ -34,7 +37,7 @@ validate' plan = do , roomsOk ] -validateLecturersMax3ExamDays :: Plan -> Writer [String] ValidationResult +validateLecturersMax3ExamDays :: Plan -> Writer [Text] ValidationResult validateLecturersMax3ExamDays plan = do let lecturerWithMoreThan3ExamDays = filter ((>3) . length . nub . snd) $ lecturerExamDays plan @@ -43,7 +46,8 @@ validateLecturersMax3ExamDays plan = do unless ok $ mapM_ (\(l,d) -> tell ["- More than 3 days of exams: " - ++ personShortName l - ++ ": " ++ show d]) + `append` showt (personShortName l) + `append` ": " + `append` showt d]) lecturerWithMoreThan3ExamDays return $ if ok then EverythingOk else SoftConstraintsBroken diff --git a/plexams-core/Plexams/Validation/Exports.hs b/plexams-core/Plexams/Validation/Exports.hs index c439d6f..84afb18 100644 --- a/plexams-core/Plexams/Validation/Exports.hs +++ b/plexams-core/Plexams/Validation/Exports.hs @@ -1,21 +1,24 @@ +{-# LANGUAGE OverloadedStrings #-} module Plexams.Validation.Exports ( validateZPAExport ) where import Control.Monad.Writer +import Data.Text (Text, append) import Plexams.Import.Misc (importZPAExamsFromJSONFile) import Plexams.Types +import TextShow (showt) -validateZPAExport :: FilePath -> Plan -> IO (ValidationResult, [String]) +validateZPAExport :: FilePath -> Plan -> IO (ValidationResult, [Text]) validateZPAExport fp plan = do maybeZpaExams <- importZPAExamsFromJSONFile fp case maybeZpaExams of Nothing -> return ( HardConstraintsBroken - , ["ZPAExams cannot be imported from "++ fp]) + , ["ZPAExams cannot be imported from " `append` showt fp]) Just zpaExams -> return $ runWriter $ validate zpaExams plan validate :: [ZPAExam] -> Plan - -> Writer [String] ValidationResult + -> Writer [Text] ValidationResult validate zpaExams plan = do tell ["# Validating ZPA export"] allOk <- allZPAExamsInExams zpaExams plan @@ -23,52 +26,52 @@ validate zpaExams plan = do return $ validationResult [allOk, allExported] allZPAExamsInExams :: [ZPAExam] -> Plan - -> Writer [String] ValidationResult + -> Writer [Text] ValidationResult allZPAExamsInExams zpaExams plan = validationResult <$> mapM (`zpaExamInExams` allExams plan) zpaExams where zpaExamInExams :: ZPAExam -> [Exam] - -> Writer [String] ValidationResult + -> Writer [Text] ValidationResult zpaExamInExams zpaExam exams = case filter ((== zpaExamAnCode zpaExam) . anCode) exams of [] -> do - tell ["Exported exam " ++ show (zpaExamAnCode zpaExam) - ++ " does not exist"] + tell ["Exported exam " `append` showt (zpaExamAnCode zpaExam) + `append` " does not exist"] return HardConstraintsBroken [exam] -> do plannedByMeOk <- if plannedByMe exam then return EverythingOk else do - tell ["Exported exam " ++ show (zpaExamAnCode zpaExam) - ++ " is not planned by me"] + tell ["Exported exam " `append` showt (zpaExamAnCode zpaExam) + `append` " is not planned by me"] return HardConstraintsBroken dayOk <- if zpaExamDate zpaExam == examDateAsString exam plan then return EverythingOk else do - tell ["Exported exam " ++ show (zpaExamAnCode zpaExam) - ++ " has wrong date"] + tell ["Exported exam " `append` showt (zpaExamAnCode zpaExam) + `append` " has wrong date"] return HardConstraintsBroken slotOk <- if zpaExamTime zpaExam == examSlotAsString exam plan then return EverythingOk else do - tell ["Exported exam " ++ show (zpaExamAnCode zpaExam) - ++ " has wrong time"] + tell ["Exported exam " `append` showt (zpaExamAnCode zpaExam) + `append` " has wrong time"] return HardConstraintsBroken return $ validationResult [plannedByMeOk, dayOk, slotOk] allPlannedExamsInZPAExams :: [ZPAExam] -> Plan - -> Writer [String] ValidationResult + -> Writer [Text] ValidationResult allPlannedExamsInZPAExams zpaExams plan = do let examsPlannedByMe = filter plannedByMe $ allExams plan validationResult <$> mapM (`examExported` zpaExams) examsPlannedByMe where - examExported :: Exam -> [ZPAExam] -> Writer [String] ValidationResult + examExported :: Exam -> [ZPAExam] -> Writer [Text] ValidationResult examExported exam zpaExams = if anCode exam `elem` map zpaExamAnCode zpaExams then return EverythingOk else do - tell ["Exam " ++ show (anCode exam) ++ " not exported"] + tell ["Exam " `append` showt (anCode exam) `append` " not exported"] return HardConstraintsBroken diff --git a/plexams-core/Plexams/Validation/Rooms.hs b/plexams-core/Plexams/Validation/Rooms.hs index 1d63f42..ad1243a 100644 --- a/plexams-core/Plexams/Validation/Rooms.hs +++ b/plexams-core/Plexams/Validation/Rooms.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE OverloadedStrings #-} module Plexams.Validation.Rooms ( validate ) where @@ -8,11 +9,13 @@ import Data.List (nub) import qualified Data.Map as M import Data.Maybe (isJust, mapMaybe) import qualified Data.Set as S +import Data.Text (Text, append) import GHC.Exts (groupWith) import Plexams.Query import Plexams.Types +import TextShow (showt) -validate :: Plan -> Writer [String] ValidationResult +validate :: Plan -> Writer [Text] ValidationResult validate plan = do tell ["## Validating Rooms"] enoughRoomsForExams <- validateEnoughRoomsForExams plan @@ -24,46 +27,47 @@ validate plan = do , differentRoomsInSlot ] -validateEnoughRoomsForExams :: Plan -> Writer [String] ValidationResult +validateEnoughRoomsForExams :: Plan -> Writer [Text] ValidationResult validateEnoughRoomsForExams plan = do tell ["### Validating enough rooms for exam (hard)"] validationResult <$> mapM validateEnoughRoomsForExam (filter plannedByMe $ scheduledExams plan) -validateEnoughRoomsForExam :: Exam -> Writer [String] ValidationResult +validateEnoughRoomsForExam :: Exam -> Writer [Text] ValidationResult validateEnoughRoomsForExam exam = do let regs = registrations exam seats = sum $ map maxSeats $ rooms exam when (regs>seats) $ - tell ["- exam " ++ show exam ++ " not enough rooms planned"] + tell ["- exam " `append` showt (anCode exam) + `append` " not enough rooms planned"] return $ if regs<=seats then EverythingOk else HardConstraintsBroken -validationStillReserveForExams :: Plan -> Writer [String] ValidationResult +validationStillReserveForExams :: Plan -> Writer [Text] ValidationResult validationStillReserveForExams plan = do tell ["### Validating if there are at least 2 empty seats left for exam (soft)"] validationResult <$> mapM validationStillReserveForExam (filter plannedByMe $ scheduledExams plan) -validationStillReserveForExam :: Exam -> Writer [String] ValidationResult +validationStillReserveForExam :: Exam -> Writer [Text] ValidationResult validationStillReserveForExam exam = do let regs = registrations exam seats = sum $ map maxSeats $ rooms exam when (regs+2>=seats) $ - tell ["- exam " ++ show exam - ++ " not enough reserve seats left: " - ++ show regs ++"/" ++ show seats] + tell ["- exam " `append` showt (anCode exam) + `append` " not enough reserve seats left: " + `append` showt regs `append`"/" `append` showt seats] return $ if regs+2<=seats then EverythingOk else SoftConstraintsBroken -validateDifferentRoomsInSlots :: Plan -> Writer [String] ValidationResult +validateDifferentRoomsInSlots :: Plan -> Writer [Text] ValidationResult validateDifferentRoomsInSlots plan = do tell ["### Validating different rooms in slot (hard)"] validationResult <$> mapM validateDifferentRoomsInSlot (M.elems (slots plan)) -validateDifferentRoomsInSlot :: Slot -> Writer [String] ValidationResult +validateDifferentRoomsInSlot :: Slot -> Writer [Text] ValidationResult validateDifferentRoomsInSlot slot = do tell ["TODO: fixme"] return HardConstraintsBroken diff --git a/plexams-core/Plexams/Validation/ScheduledExams.hs b/plexams-core/Plexams/Validation/ScheduledExams.hs index c16bf59..2babe06 100644 --- a/plexams-core/Plexams/Validation/ScheduledExams.hs +++ b/plexams-core/Plexams/Validation/ScheduledExams.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE OverloadedStrings #-} module Plexams.Validation.ScheduledExams ( validate ) where @@ -8,11 +9,13 @@ import Data.List (nub) import qualified Data.Map as M import Data.Maybe (isJust, mapMaybe) import qualified Data.Set as S +import Data.Text (Text, append) import GHC.Exts (groupWith) import Plexams.Query import Plexams.Types +import TextShow (showt) -validate :: Plan -> Writer [String] ValidationResult +validate :: Plan -> Writer [Text] ValidationResult validate plan = do constraintsOk <- validateScheduleConstraints plan tell ["## Validating Schedule"] @@ -32,7 +35,7 @@ validate plan = do , studentsMaxTwoExamsPerDay ] -validateGOSlots :: Plan -> Writer [String] ValidationResult +validateGOSlots :: Plan -> Writer [Text] ValidationResult validateGOSlots plan = do tell ["### Checking GO-Slots! (hard)"] let allowedSlots = goSlots $ semesterConfig plan @@ -44,10 +47,11 @@ validateGOSlots plan = do goOk = null examsInOtherSlots unless goOk $ forM_ examsInOtherSlots $ \exam -> - tell [ "- GO exam " ++ show (anCode exam) ++ " in wrong slot" ] + tell [ "- GO exam " `append` showt (anCode exam) + `append` " in wrong slot" ] return $ if goOk then EverythingOk else HardConstraintsBroken -validateSameNameSameSlot :: Plan -> Writer [String] ValidationResult +validateSameNameSameSlot :: Plan -> Writer [Text] ValidationResult validateSameNameSameSlot plan = do let examsGroupedByNameWithDifferentSlots = filter ((>1) . length . nub . map slot) @@ -63,21 +67,21 @@ validateSameNameSameSlot plan = do unless ok $ mapM_ ( tell . (:[]) - . ("- exams with same name but different slots: "++) - . show + . ("- exams with same name but different slots: "`append`) + . showt . map (anCode &&& slot) ) examsGroupedByNameWithDifferentSlots return $ if ok then EverythingOk else SoftConstraintsBroken -validateOverlapsInSameSlot :: Plan -> Writer [String] ValidationResult +validateOverlapsInSameSlot :: Plan -> Writer [Text] ValidationResult validateOverlapsInSameSlot plan = do tell ["### Checking overlaps in same slot (hard)"] validateOverlaps (overlaps <$> constraints plan) (map (M.elems . examsInSlot) $ M.elems $ slots plan) validateOverlaps :: Maybe [Overlaps] -> [[Exam]] - -> Writer [String] ValidationResult + -> Writer [Text] ValidationResult validateOverlaps Nothing _ = do tell ["#### no overlaps found"] return EverythingOk @@ -85,19 +89,19 @@ validateOverlaps (Just overlaps) exams = validationResult <$> mapM (validateOverlapsForExams overlaps) exams validateOverlapsForExams :: [Overlaps] -> [Exam] - -> Writer [String] ValidationResult + -> Writer [Text] ValidationResult validateOverlapsForExams overlaps exams = validationResult <$> mapM (`validateOverlapsForExams'` exams) overlaps validateOverlapsForExams' :: Overlaps -> [Exam] - -> Writer [String] ValidationResult + -> Writer [Text] ValidationResult validateOverlapsForExams' overlaps [] = return EverythingOk validateOverlapsForExams' overlaps (exam:exams) = do examOk <- validateOverlapsForExam overlaps exam exams tailOk <- validateOverlapsForExams' overlaps exams return $ validationResult [examOk, tailOk] -validateOverlapsInAdjacentSlots :: Plan -> Writer [String] ValidationResult +validateOverlapsInAdjacentSlots :: Plan -> Writer [Text] ValidationResult validateOverlapsInAdjacentSlots plan = do tell ["### Checking overlaps in adjacent slots (hard)"] let maxDays = (\x -> x-1) $ length $ examDays $ semesterConfig plan @@ -110,7 +114,7 @@ validateOverlapsInAdjacentSlots plan = do daySlotPairs validateOverlapsTwoLists (overlaps <$> constraints plan) exams -validateOverlapsSameDay :: Plan -> Writer [String] ValidationResult +validateOverlapsSameDay :: Plan -> Writer [Text] ValidationResult validateOverlapsSameDay plan = do tell ["### Checking overlaps on same day (soft)"] let maxDays = (\x -> x-1) $ length $ examDays $ semesterConfig plan @@ -129,7 +133,7 @@ validateOverlapsSameDay plan = do _ -> valRes validateOverlapsTwoLists :: Maybe [Overlaps] -> [([Exam],[Exam])] - -> Writer [String] ValidationResult + -> Writer [Text] ValidationResult validateOverlapsTwoLists Nothing _ = do tell ["#### no overlaps found"] return EverythingOk @@ -137,12 +141,12 @@ validateOverlapsTwoLists (Just overlaps) exams = validationResult <$> mapM (validateOverlapsTwoListsForExams overlaps) exams validateOverlapsTwoListsForExams :: [Overlaps] -> ([Exam],[Exam]) - -> Writer [String] ValidationResult + -> Writer [Text] ValidationResult validateOverlapsTwoListsForExams overlaps (ex1, ex2) = validationResult <$> mapM (validateOverlapsTwoListsForExams' ex1 ex2) overlaps validateOverlapsTwoListsForExams' :: [Exam] -> [Exam] -> Overlaps - -> Writer [String] ValidationResult + -> Writer [Text] ValidationResult validateOverlapsTwoListsForExams' [] _ _ = return EverythingOk validateOverlapsTwoListsForExams' (exam:exams) otherExams overlaps = do examOk <- validateOverlapsForExam overlaps exam otherExams @@ -150,7 +154,7 @@ validateOverlapsTwoListsForExams' (exam:exams) otherExams overlaps = do return $ validationResult [ examOk, tailOk ] validateOverlapsForExam :: Overlaps -> Exam -> [Exam] - -> Writer [String] ValidationResult + -> Writer [Text] ValidationResult validateOverlapsForExam _ _ [] = return EverythingOk validateOverlapsForExam overlaps exam exams = do let overlapsForExam = @@ -161,16 +165,16 @@ validateOverlapsForExam overlaps exam exams = do exams ok = null overlappingExams forM_ overlappingExams $ \(other, Just studs) -> - tell ["- " ++ show (olGroup overlaps) - ++ ": Exam " ++ show (anCode exam) - ++ " overlaps with exam " ++ show other - ++ " for " ++ show studs ++ " Students"] + tell ["- " `append` showt (olGroup overlaps) + `append` ": Exam " `append` showt (anCode exam) + `append` " overlaps with exam " `append` showt other + `append` " for " `append` showt studs `append` " Students"] return $ if ok then EverythingOk else HardConstraintsBroken -------------------------------------------------------------------------------- -- validate constraints from constraints file -------------------------------------------------------------------------------- -validateScheduleConstraints :: Plan -> Writer [String] Bool +validateScheduleConstraints :: Plan -> Writer [Text] Bool validateScheduleConstraints plan = do tell ["## Validate schedule constraints from file"] let maybeConstraints = constraints plan @@ -189,12 +193,12 @@ validateScheduleConstraints plan = do ------------------ -- not on same day ------------------ -validateNotOnSameDay :: Plan -> [[Ancode]] -> Writer [String] Bool +validateNotOnSameDay :: Plan -> [[Ancode]] -> Writer [Text] Bool validateNotOnSameDay plan listOfAncodes = do tell ["### Validate exams not on same day"] and <$> mapM (validateNotOnSameDay' plan) listOfAncodes -validateNotOnSameDay' :: Plan -> [Ancode] -> Writer [String] Bool +validateNotOnSameDay' :: Plan -> [Ancode] -> Writer [Text] Bool validateNotOnSameDay' plan ancodes = do let ancodesAndDays = filter (isJust . snd) @@ -209,56 +213,62 @@ validateNotOnSameDay' plan ancodes = do ancodesAndDaysOk = (== length ancodesAndDays) $ length $ nub $ map snd ancodesAndDays unless ancodesAndDaysOk $ - tell ["- not okay for " ++ show ancodesAndDays] + tell ["- not okay for " `append` showt ancodesAndDays] return ancodesAndDaysOk -------------------- -- one of these days -------------------- -validateOneOfTheseDays :: Plan -> [(Ancode, [Int])] -> Writer [String] Bool +validateOneOfTheseDays :: Plan -> [(Ancode, [Int])] -> Writer [Text] Bool validateOneOfTheseDays plan ancodesAndDays = do tell ["### Validate exams on one of these days"] and <$> mapM (validateOneOfTheseDays' plan) ancodesAndDays -validateOneOfTheseDays' :: Plan -> (Ancode, [Int]) -> Writer [String] Bool +validateOneOfTheseDays' :: Plan -> (Ancode, [Int]) -> Writer [Text] Bool validateOneOfTheseDays' plan (ancode, days) = do let exams = queryByAnCode ancode plan oneOfTheseDaysOk = case slot $ head exams of Nothing -> True Just (d,_) -> d `elem` days if null exams - then tell ["- exam " ++ show ancode ++ " not found"] >> return True + then tell ["- exam " `append` showt ancode + `append` " not found"] >> return True else do unless oneOfTheseDaysOk $ - tell ["- exam " ++ show ancode ++ " not on one of " ++ show days] + tell ["- exam " `append` showt ancode + `append` " not on one of " + `append` showt days] return oneOfTheseDaysOk ------------- -- fixed slot ------------- -validateFixSlot :: Plan -> [(Ancode, (Int,Int))] -> Writer [String] Bool +validateFixSlot :: Plan -> [(Ancode, (Int,Int))] -> Writer [Text] Bool validateFixSlot plan ancodesAndSlots = do tell ["### Validate exams in fixed slot"] and <$> mapM (validateFixSlot' plan) ancodesAndSlots -validateFixSlot' :: Plan -> (Ancode, (Int,Int)) -> Writer [String] Bool +validateFixSlot' :: Plan -> (Ancode, (Int,Int)) -> Writer [Text] Bool validateFixSlot' plan (ancode, (d,s)) = do let exams = queryByAnCode ancode plan fixedSlotOk = case slot $ head exams of Nothing -> True Just (d',s') -> d' == d && s' == s if null exams - then tell ["- exam " ++ show ancode ++ " not found"] >> return True + then tell ["- exam " `append` showt ancode + `append` " not found"] >> return True else do unless fixedSlotOk $ - tell ["- exam " ++ show ancode ++ " not in slot " ++ show (d,s)] + tell ["- exam " `append` showt ancode + `append` " not in slot " + `append` showt (d,s)] return fixedSlotOk ------------------------------------------------------- -- each lecturer should have zero or one exams per slot ------------------------------------------------------- -validateLecturerMaxOneExamPerSlot :: Plan -> Writer [String] ValidationResult +validateLecturerMaxOneExamPerSlot :: Plan -> Writer [Text] ValidationResult validateLecturerMaxOneExamPerSlot plan = do tell ["### Validate numbers of exams per lecturer per slot (soft)"] let listsOfLecturers = map (\(s,es) -> ( s @@ -270,7 +280,7 @@ validateLecturerMaxOneExamPerSlot plan = do slotsWithDuplicates = filter (((/=) <$> nub <*> id) . snd) listsOfLecturers forM_ slotsWithDuplicates $ \(slot, lecturers) -> tell ["- ecturer has more then one exam in slot: " - ++ show lecturers] + `append` showt lecturers] return $ if null slotsWithDuplicates then EverythingOk else SoftConstraintsBroken @@ -281,11 +291,11 @@ validateLecturerMaxOneExamPerSlot plan = do -- TODO: Unterscheidung ob zwei Erstprüfungen an einem Tag oder Wiederholungs- -- prüfungen -validateStudentsMaxTwoExamsPerDay :: Plan -> Writer [String] ValidationResult +validateStudentsMaxTwoExamsPerDay :: Plan -> Writer [Text] ValidationResult validateStudentsMaxTwoExamsPerDay plan = do -- TODO: hard/soft okay? tell ["### Validate numbers of exams per student per day" - ++" (2 are soft, 3 are hard, but not if noOfExams > 13)"] + `append`" (2 are soft, 3 are hard, but not if noOfExams > 13)"] let examsPerDays :: [[Ancode]] examsPerDays = map (\d -> concatMap (M.keys . examsInSlot) @@ -310,9 +320,12 @@ validateStudentsMaxTwoExamsPerDay plan = do let three = any (>2) noOfExams tell [(if three then "- Student has three or more exams a day:" else "- Student has two exams per day: ") - ++ show noOfExams ++ " of " ++ show (length exams) ++ ", MtkNr " - ++ show mtknr - ++ " \n" ++ show exams] + `append` showt noOfExams + `append` " of " + `append` showt (length exams) + `append` ", MtkNr " + `append` showt mtknr + `append` " \n" `append` showt exams] return $ if null studentsWithMoreThanOneExamPerDay then EverythingOk diff --git a/plexams-core/Plexams/Validation/Sources.hs b/plexams-core/Plexams/Validation/Sources.hs index 852e71e..e3c2a13 100644 --- a/plexams-core/Plexams/Validation/Sources.hs +++ b/plexams-core/Plexams/Validation/Sources.hs @@ -1,12 +1,15 @@ +{-# LANGUAGE OverloadedStrings #-} module Plexams.Validation.Sources ( validate ) where import Control.Monad.Writer import qualified Data.Map as M +import Data.Text (Text, append) import Plexams.Types +import TextShow -validate :: Plan -> Writer [String] ValidationResult +validate :: Plan -> Writer [Text] ValidationResult validate plan = do tell ["## Validating Sources"] validateRegsAndOverlaps plan @@ -14,7 +17,7 @@ validate plan = do -- Overlaps einer Prüfung mit sich selbst muss der Anmeldezahl -- für diese Gruppe entsprechen -- und das ganze muss symmetrisch sein. -validateRegsAndOverlaps :: Plan -> Writer [String] ValidationResult +validateRegsAndOverlaps :: Plan -> Writer [Text] ValidationResult validateRegsAndOverlaps plan = do let maybeOverlaps = overlaps <$> constraints plan case maybeOverlaps of @@ -25,21 +28,22 @@ validateRegsAndOverlaps plan = do validationResult <$> mapM validateOverlapsForGroups overlaps -- Überprüft die Symmetrie der Overlaps -validateOverlapsForGroups :: Overlaps -> Writer [String] ValidationResult +validateOverlapsForGroups :: Overlaps -> Writer [Text] ValidationResult validateOverlapsForGroups overlaps = do - let group = show $ olGroup overlaps + let group = showt $ olGroup overlaps flatOverlaps = concatMap (\(a,m) -> map (\(b,c) -> (a,b,c)) $ M.toList m) $ M.toList $ olOverlaps overlaps - tell ["### Checking integrity of overlaps file for " ++ group ++ " (hard)"] + tell ["### Checking integrity of overlaps file for " + `append` group `append` " (hard)"] validationResult <$> mapM (findSymm group flatOverlaps) flatOverlaps -findSymm :: String -> [(Integer, Integer, Integer)] - -> (Integer, Integer, Integer) -> Writer [String] ValidationResult +findSymm :: Text -> [(Integer, Integer, Integer)] + -> (Integer, Integer, Integer) -> Writer [Text] ValidationResult findSymm group flatOverlaps o@(a,b,c) = do let found = (b,a,c) `elem` flatOverlaps unless found $ - tell ["- Overlaps for " ++ group - ++ " are not symmetric " ++ show o ++ " "] + tell ["- Overlaps for " `append` group + `append` " are not symmetric " `append` showt o `append` " "] return $ if found then EverythingOk else HardConstraintsBroken diff --git a/plexams-core/plexams-core.cabal b/plexams-core/plexams-core.cabal index 245783c..f5d07e5 100644 --- a/plexams-core/plexams-core.cabal +++ b/plexams-core/plexams-core.cabal @@ -38,6 +38,7 @@ library , containers , mtl , text + , text-show , time , vector , yaml