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

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

15
import Data.Aeson.TH
Henrik Tramberend's avatar
Henrik Tramberend committed
16
17
18
19
20
import Control.Exception
import Data.Yaml
import Data.Aeson.Types
import Data.Char
import Data.Maybe
21
import GHC.Generics
Henrik Tramberend's avatar
Henrik Tramberend committed
22
23
24
25
26
27
28
29
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
30
import Student
Henrik Tramberend's avatar
Henrik Tramberend committed
31

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

45
46
47
48
49
data Choice = Choice
    { choiceTheAnswer :: T.Text
    , choiceCorrect :: Bool
    } deriving (Eq,Show,Typeable)

Henrik Tramberend's avatar
Henrik Tramberend committed
50
data Answer
51
    = MultipleChoice { answChoices :: [Choice]}
52
53
54
55
56
    | FillText { answFillText :: T.Text
               , answCorrectWords :: [T.Text]}
    | FreeForm { answHeightInMm :: Int
               , answCorrectAnswer :: T.Text}
    deriving (Eq,Show,Typeable)
Henrik Tramberend's avatar
Henrik Tramberend committed
57

58
59
60
61
62
data Difficulty
    = Easy 
    | Medium 
    | Hard 
    deriving (Eq,Show,Typeable)
Henrik Tramberend's avatar
Henrik Tramberend committed
63

64
data Exam = Exam
Henrik Tramberend's avatar
Henrik Tramberend committed
65
66
67
    { examTitle :: T.Text
    , examModule :: T.Text
    , examStudentInfoFile :: FilePath
68
    , examDateTime :: T.Text
69
70
    , examDurationInMinutes :: Int
    , examNumberOfQuestions :: Int
71
72
73
74
    , examTrack :: Int
    , examLectureIds :: [T.Text]
    , examExcludedTopicIds :: [T.Text]
    } deriving (Eq,Show,Typeable)
Henrik Tramberend's avatar
Henrik Tramberend committed
75

Henrik Tramberend's avatar
Henrik Tramberend committed
76
77
78
79
80
81
82
83
84
85
86
data StudentExam = StudentExam
    { stdexExam :: Exam
    , stdexStudent :: Student
    } 

$(deriveJSON
      defaultOptions
      { fieldLabelModifier = drop 5
      }
      ''StudentExam)

87
88
89
90
91
92
$(deriveJSON
      defaultOptions
      { fieldLabelModifier = drop 6
      }
      ''Choice)

93
94
95
96
97
98
$(deriveJSON
      defaultOptions
      { fieldLabelModifier = drop 4
      }
      ''Answer)

99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
questionOptions = 
    defaultOptions
    { fieldLabelModifier = drop 3
    }

instance ToJSON Question where
    toJSON = genericToJSON questionOptions
    toEncoding = genericToEncoding questionOptions

instance FromJSON Question where
    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

-- $(deriveJSON
--       defaultOptions
--       { fieldLabelModifier = drop 3
--       }
--       ''Question)
124
125
126
127
128
$(deriveJSON
      defaultOptions
      { fieldLabelModifier = drop 4
      }
      ''Exam)
Henrik Tramberend's avatar
Henrik Tramberend committed
129
130
131

$(deriveJSON defaultOptions ''Difficulty)

132
mcKey = typeOf $ MultipleChoice []
133

Henrik Tramberend's avatar
Henrik Tramberend committed
134
ftKey = typeOf $ FillText "" []
135

136
ffKey = typeOf $ FreeForm 0 ""
Henrik Tramberend's avatar
Henrik Tramberend committed
137

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

140
selectTemplate :: Templates -> Question -> M.Template
141
-- selectTemplate templates question = fromJust $ lookup (typeOf $ qstAnswer question) templates
142
143
selectTemplate templates question = 
    case qstAnswer question of
144
        MultipleChoice _ -> 
145
146
147
            compileMustacheTemplate $ fixMustacheMarkup testerMultipleChoiceTemplate
        FillText _ _ -> compileMustacheTemplate $ fixMustacheMarkup testerFillTextTemplate
        FreeForm _ _ -> compileMustacheTemplate $ fixMustacheMarkup testerFreeFormTemplate
Henrik Tramberend's avatar
Henrik Tramberend committed
148
149

compileTesterTemplates :: Templates
150
151
152
153
154
155
156
157
158
159
compileTesterTemplates = 
    [ (mcKey, compileMustacheTemplate $ fixMustacheMarkup testerMultipleChoiceTemplate)
    , (ftKey, compileMustacheTemplate $ fixMustacheMarkup testerFillTextTemplate)
    , (ffKey, compileMustacheTemplate $ fixMustacheMarkup testerFreeFormTemplate)]

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