108 lines
3.4 KiB
Haskell
108 lines
3.4 KiB
Haskell
{-# LANGUAGE TemplateHaskell #-}
|
|
{-# LANGUAGE NoImplicitPrelude #-}
|
|
{-# LANGUAGE RecordWildCards #-}
|
|
{-# LANGUAGE NamedFieldPuns #-}
|
|
{-# LANGUAGE ViewPatterns #-}
|
|
{-# LANGUAGE OverloadedStrings #-}
|
|
{-# LANGUAGE DeriveGeneric, DeriveDataTypeable #-}
|
|
|
|
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
|
{-# OPTIONS_GHC -fno-warn-name-shadowing #-}
|
|
|
|
module Handler.Utils.Zip.Rating
|
|
( Rating(..)
|
|
, getRating
|
|
, formatRating
|
|
, parseRating
|
|
) where
|
|
|
|
import Import hiding ((</>))
|
|
|
|
import Text.PrettyPrint.Leijen.Text hiding ((<$>))
|
|
|
|
import Control.Monad.Trans.Maybe
|
|
|
|
import Data.Text (Text)
|
|
import qualified Data.Text as Text
|
|
import qualified Data.Text.Encoding as Text
|
|
|
|
import qualified Data.Text.Lazy.Encoding as Lazy.Text
|
|
|
|
import qualified Data.ByteString.Lazy as Lazy (ByteString)
|
|
|
|
import Text.Read (readEither)
|
|
|
|
import GHC.Generics (Generic)
|
|
import Data.Typeable (Typeable)
|
|
|
|
|
|
instance HasResolution prec => Pretty (Fixed prec) where
|
|
pretty = pretty . show
|
|
|
|
|
|
data Rating = Rating
|
|
{ ratingCourseName :: Text
|
|
, ratingSheetName :: Text
|
|
, ratingSubmissionId :: SubmissionId
|
|
, ratingComment :: Maybe Text
|
|
, ratingPoints :: Maybe Points
|
|
} deriving (Read, Show, Eq, Generic, Typeable)
|
|
|
|
|
|
getRating :: SubmissionId -> YesodDB UniWorX (Maybe Rating)
|
|
getRating ratingSubmissionId = runMaybeT $ do
|
|
Submission{ submissionSheetId, submissionRatingComment = ratingComment, submissionRatingPoints = ratingPoints } <- MaybeT $ get ratingSubmissionId
|
|
Sheet{ sheetCourseId, sheetName = ratingSheetName } <- MaybeT $ get submissionSheetId
|
|
Course{ courseName = ratingCourseName } <- MaybeT $ get sheetCourseId
|
|
return Rating{..}
|
|
|
|
formatRating :: Rating -> Lazy.ByteString
|
|
formatRating Rating{..} = let
|
|
doc = renderPretty 1 45 $ foldr (<$$>) mempty
|
|
[ "= Bitte nur Bewertung und Kommentare ändern ="
|
|
, "============================================="
|
|
, "========== UniWorx Bewertungsdatei =========="
|
|
, "======= diese Datei ist UTF8 encodiert ======"
|
|
, "Informationen zum Übungsblatt:"
|
|
, indent 2 $ foldr (<$$>) mempty
|
|
[ "Veranstaltung:" <+> pretty ratingCourseName
|
|
, "Blatt:" <+> pretty ratingSheetName
|
|
]
|
|
, "Abgabe-Id:" <+> pretty (show ratingSubmissionId) -- FIXME
|
|
, "============================================="
|
|
, "Bewertung:" <+> pretty ratingPoints
|
|
, "=========== Beginn der Kommentare ==========="
|
|
, pretty ratingComment
|
|
]
|
|
in Lazy.Text.encodeUtf8 $ displayT doc
|
|
|
|
|
|
parseRating :: ByteString
|
|
-> Either Text ( Maybe Points
|
|
, Maybe Text -- ^ Rating comment
|
|
)
|
|
parseRating input = do
|
|
inputText <- first tshow $ Text.decodeUtf8' input
|
|
let
|
|
(headerLines, commentLines) = break (sep `Text.isInfixOf`) $ Text.lines inputText
|
|
ratingLines = filter (rating `Text.isInfixOf`) headerLines
|
|
sep = "Beginn der Kommentare"
|
|
rating = "Bewertung:"
|
|
comment' <- case commentLines of
|
|
(_:commentLines') -> Right . Text.strip $ Text.unlines commentLines'
|
|
_ -> Left $ "Missing separator “" <> sep <> "”"
|
|
let
|
|
comment
|
|
| Text.null comment' = Nothing
|
|
| otherwise = Just comment'
|
|
ratingLine' <- case ratingLines of
|
|
[l] -> Right l
|
|
_ -> Left $ "Multiple occurances of “" <> rating <> "”"
|
|
let
|
|
(_, ratingLine) = Text.breakOnEnd rating ratingLine'
|
|
ratingStr = Text.unpack $ Text.strip ratingLine
|
|
rating <- case () of
|
|
_ | null ratingStr -> return Nothing
|
|
| otherwise -> first tshow $ Just <$> readEither ratingStr
|
|
return (rating, comment)
|