test.hs 4.39 KB
Newer Older
1
{-# LANGUAGE TemplateHaskell, OverloadedStrings, DeriveGeneric #-}
Henrik Tramberend's avatar
Henrik Tramberend committed
2

3
module Test
4 5 6 7 8 9 10 11 12 13 14
  ( Question(..)
  , Answer(..)
  , Choice(..)
  , OneAnswer(..)
  , Difficulty(..)
  , Exam(..)
  , StudentExam(..)
  , Templates
  , compileTesterTemplates
  , selectTemplate
  ) where
Henrik Tramberend's avatar
Henrik Tramberend committed
15

16
import Data.Aeson.TH
Henrik Tramberend's avatar
Henrik Tramberend committed
17 18 19 20 21
import Control.Exception
import Data.Yaml
import Data.Aeson.Types
import Data.Char
import Data.Maybe
22
import GHC.Generics
Henrik Tramberend's avatar
Henrik Tramberend committed
23 24 25 26 27 28 29 30
import qualified Data.Text as T
import qualified Data.Text.Encoding as E
import qualified Data.ByteString.Char8 as B
import Data.Typeable
import qualified Text.Mustache as M
import qualified Text.Mustache.Types as MT
import Embed
import Utilities
Henrik Tramberend's avatar
Henrik Tramberend committed
31
import Student
Henrik Tramberend's avatar
Henrik Tramberend committed
32

33
data Question = Question
34 35 36 37 38 39 40 41 42 43 44
  { qstTopicId :: T.Text
  , qstLectureId :: T.Text
  , qstTitle :: T.Text
  , qstPoints :: Int
  , qstQuestion :: T.Text
  , qstAnswer :: Answer
  , qstDifficulty :: Difficulty
  , qstComment :: T.Text
  , qstCurrentNumber :: Int
  , qstBasePath :: String
  } deriving (Eq, Show, Typeable, Generic)
Henrik Tramberend's avatar
Henrik Tramberend committed
45

46
data Choice = Choice
47 48 49 50 51 52 53 54
  { choiceTheAnswer :: T.Text
  , choiceCorrect :: Bool
  } deriving (Eq, Show, Typeable)

data OneAnswer = OneAnswer
  { oneDetail :: T.Text
  , oneCorrect :: T.Text
  } deriving (Eq, Show, Typeable)
55

Henrik Tramberend's avatar
Henrik Tramberend committed
56
data Answer
57 58 59 60 61 62 63 64
  = MultipleChoice { answChoices :: [Choice]}
  | FillText { answFillText :: T.Text
            ,  answCorrectWords :: [T.Text]}
  | FreeForm { answHeightInMm :: Int
            ,  answCorrectAnswer :: T.Text}
  | MultipleAnswers { answWidthInMm :: Int
                   ,  answAnswers :: [OneAnswer]}
  deriving (Eq, Show, Typeable)
Henrik Tramberend's avatar
Henrik Tramberend committed
65

66
data Difficulty
67 68 69 70
  = Easy
  | Medium
  | Hard
  deriving (Eq, Show, Typeable)
Henrik Tramberend's avatar
Henrik Tramberend committed
71

72
data Exam = Exam
73 74 75 76 77 78
  { examTitle :: T.Text
  , examModule :: T.Text
  , examStudentInfoFile :: FilePath
  , examDateTime :: T.Text
  , examDurationInMinutes :: Int
  , examNumberOfQuestions :: Int
79
  , examTracks :: [Int]
80 81 82
  , examLectureIds :: [T.Text]
  , examExcludedTopicIds :: [T.Text]
  } deriving (Eq, Show, Typeable)
Henrik Tramberend's avatar
Henrik Tramberend committed
83

Henrik Tramberend's avatar
Henrik Tramberend committed
84
data StudentExam = StudentExam
85 86 87
  { stdexExam :: Exam
  , stdexStudent :: Student
  }
Henrik Tramberend's avatar
Henrik Tramberend committed
88 89

$(deriveJSON
90 91 92 93
    defaultOptions
    { fieldLabelModifier = drop 5
    }
    ''StudentExam)
Henrik Tramberend's avatar
Henrik Tramberend committed
94

95
$(deriveJSON
96 97 98 99
    defaultOptions
    { fieldLabelModifier = drop 6
    }
    ''Choice)
100

101
$(deriveJSON
102 103 104
    defaultOptions
    { fieldLabelModifier = drop 3
    }
105 106 107 108 109 110 111 112 113 114 115 116
    ''OneAnswer)

$(deriveJSON
    defaultOptions
    { fieldLabelModifier = drop 4
    }
    ''Answer)

questionOptions =
  defaultOptions
  { fieldLabelModifier = drop 3
  }
117 118

instance ToJSON Question where
119 120
  toJSON = genericToJSON questionOptions
  toEncoding = genericToEncoding questionOptions
121 122

instance FromJSON Question where
123 124 125 126 127 128 129 130 131 132
  parseJSON (Object q) =
    Question <$> q .: "TopicId" <*> q .: "LectureId" <*> q .: "Title" <*>
    q .: "Points" <*>
    q .: "Question" <*>
    q .: "Answer" <*>
    q .: "Difficulty" <*>
    q .: "Comment" <*>
    q .:? "CurrentNumber" .!= 0 <*>
    q .:? "BasePath" .!= "."
  parseJSON invalid = typeMismatch "Question" invalid
133 134 135 136 137 138

-- $(deriveJSON
--       defaultOptions
--       { fieldLabelModifier = drop 3
--       }
--       ''Question)
139
$(deriveJSON
140 141 142 143
    defaultOptions
    { fieldLabelModifier = drop 4
    }
    ''Exam)
Henrik Tramberend's avatar
Henrik Tramberend committed
144 145 146

$(deriveJSON defaultOptions ''Difficulty)

147
mcKey = typeOf $ MultipleChoice []
148

Henrik Tramberend's avatar
Henrik Tramberend committed
149
ftKey = typeOf $ FillText "" []
150

151
ffKey = typeOf $ FreeForm 0 ""
Henrik Tramberend's avatar
Henrik Tramberend committed
152

153
type Templates = [(TypeRep, M.Template)]
Henrik Tramberend's avatar
Henrik Tramberend committed
154

155
selectTemplate :: Templates -> Question -> M.Template
156
-- selectTemplate templates question = fromJust $ lookup (typeOf $ qstAnswer question) templates
157 158 159 160 161 162 163 164 165 166
selectTemplate templates question =
  case qstAnswer question of
    MultipleChoice _ ->
      compileMustacheTemplate $ fixMustacheMarkup testerMultipleChoiceTemplate
    MultipleAnswers _ _ ->
      compileMustacheTemplate $ fixMustacheMarkup testerMultipleAnswersTemplate
    FillText _ _ ->
      compileMustacheTemplate $ fixMustacheMarkup testerFillTextTemplate
    FreeForm _ _ ->
      compileMustacheTemplate $ fixMustacheMarkup testerFreeFormTemplate
Henrik Tramberend's avatar
Henrik Tramberend committed
167 168

compileTesterTemplates :: Templates
169 170 171 172 173 174
compileTesterTemplates =
  [ ( mcKey
    , compileMustacheTemplate $ fixMustacheMarkup testerMultipleChoiceTemplate)
  , (ftKey, compileMustacheTemplate $ fixMustacheMarkup testerFillTextTemplate)
  , (ffKey, compileMustacheTemplate $ fixMustacheMarkup testerFreeFormTemplate)
  ]
175 176

compileMustacheTemplate :: T.Text -> M.Template
177 178 179 180
compileMustacheTemplate string =
  case M.compileTemplate "" string of
    Left err -> throw $ MustacheException $ show err
    Right template -> template