fraport/fradrive
3
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

fix(rating-files): support integral points values

Browse Source 
Fixes #604
This commit is contained in:
Gregor Kleen 2020-06-24 14:01:52 +02:00
parent 342c64a93a
commit 62dd7b9f04
4 changed files with 19 additions and 3 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

7
src/Handler/Utils/Rating/Format.hs
View File

@ -91,6 +91,8 @@ formatRating (MsgRenderer mr) DateTimeFormatter{..} cID Rating{ ratingValues = R
-> mempty
| has (_passingBound . _Left) mode
-> mapEvents (str' "passed") (YAML.Scalar () . maybe YAML.SNull YAML.SBool $ gradingPassed mode =<< ratingPoints)
| Just ratingPoints' <- ratingPoints ^? _Just . _Integer
-> mapEvents (str' "points") (YAML.Scalar () $ YAML.SInt ratingPoints')
| otherwise
-> mapEvents (str' "points") (YAML.Scalar () $ maybe YAML.SNull (YAML.SFloat . realToFrac) ratingPoints)
, mapEvents (str' "rating_done") (YAML.Scalar () $ YAML.SBool ratingDone)
@ -177,7 +179,10 @@ formatRating (MsgRenderer mr) DateTimeFormatter{..} cID Rating{ ratingValues = R
instance ns ~ CryptoIDNamespace (CI FilePath) SubmissionId => YAML.FromYAML (Maybe UTCTime -> Maybe Text -> (Rating', Maybe (Explicit.CryptoFileName ns))) where
parseYAML = YAML.withMap "Rating'" $ \m -> do
ratingDone <- m YAML..:? "rating_done" YAML..!= False
ratingPoints' <- fmap (realToFixed :: Double -> Points) <$> m YAML..:? "points"
ratingPoints' <- asum
[ fmap (fromIntegral :: Integer -> Points) <$> m YAML..:? "points"
, fmap (realToFixed :: Double -> Points) <$> m YAML..:? "points"
]
ratingPassed <- fmap (bool 0 1) <$> m YAML..:? "passed"
let ratingPoints = ratingPoints' <|> ratingPassed
cIDNode = listToMaybe . Map.elems $ Map.filterWithKey isCIDNode m

3
src/Utils.hs
View File

@ -359,6 +359,9 @@ cutOffPercent (abs -> offset) (abs -> full) (abs -> achieved)
where
percent = achieved / full
_Integer :: (RealFrac a, Integral b) => Prism' a b
_Integer = prism' fromIntegral $ fmap (view _1) . assertM' (has $ _2 . only 0) . properFraction
------------
-- Monoid --
------------

2
src/Utils/Lens.hs
View File

@ -232,8 +232,8 @@ makeLenses_ ''ExternalExamOfficeSchool
makeLenses_ ''ExternalExamStaff
makeLenses_ ''ExternalExamResult
makeLenses_ ''Rating
makeLenses_ ''Rating'
-- makeClassy_ ''Load

10
test/Handler/Utils/RatingSpec.hs
View File

@ -10,16 +10,24 @@ import qualified Data.ByteString.Lazy as LBS
import qualified Data.Text as Text
import Utils (assertM, MsgRendererS(..))
import Utils (assertM, MsgRendererS(..), _Integer)
import Text.Shakespeare.I18N (renderMessage)
import Utils.Lens (_ratingValues, _ratingPoints)
spec :: Spec
spec = describe "Rating file parsing/pretty-printing" $ do
it "roundtrips" . property $ \(_ :: SubmissionId, subId) (mRating -> rating) ->
parseRating' (formatRating mr' def subId rating) === Just (ratingValues rating)
it "roundtrips for integral points" . property $ \(_ :: SubmissionId, subId) (over (_ratingValues . _ratingPoints . _Just) (fromInteger . round) . mRating -> rating) ->
has (_ratingValues . _ratingPoints . _Just . _Integer) rating
==> parseRating' (formatRating mr' def subId rating) === Just (ratingValues rating)
it "has idempotent formatting" . property $ \(_ :: SubmissionId, subId) (mRating -> rating) ->
fmap (\r' -> formatRating mr' def subId $ rating { ratingValues = r' }) (parseRating' $ formatRating mr' def subId rating) === Just (formatRating mr' def subId rating)
it "has idempotent formatting for integral points" . property $ \(_ :: SubmissionId, subId) (over (_ratingValues . _ratingPoints . _Just) (fromInteger . round) . mRating -> rating) ->
has (_ratingValues . _ratingPoints . _Just . _Integer) rating
==> fmap (\r' -> formatRating mr' def subId $ rating { ratingValues = r' }) (parseRating' $ formatRating mr' def subId rating) === Just (formatRating mr' def subId rating)
where
mr' :: forall site. MsgRendererS site
mr' = MsgRenderer $ renderMessage (error "foundation inspected" :: site) []