test.hs 4.38 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
79
80
81
82
  { examTitle :: T.Text
  , examModule :: T.Text
  , examStudentInfoFile :: FilePath
  , examDateTime :: T.Text
  , examDurationInMinutes :: Int
  , examNumberOfQuestions :: Int
  , examTrack :: Int
  , 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