tester.hs 18.4 KB
Newer Older
1
2
{-# LANGUAGE OverloadedStrings #-}

Henrik Tramberend's avatar
Henrik Tramberend committed
3
4
5
import Control.Monad ()
import Control.Exception
import Data.Maybe ()
Henrik Tramberend's avatar
Henrik Tramberend committed
6
import Data.List
Henrik Tramberend's avatar
Henrik Tramberend committed
7
8
import Data.Typeable
import qualified Data.Text as T
Henrik Tramberend's avatar
Henrik Tramberend committed
9
import qualified Data.Text.IO as T
Henrik Tramberend's avatar
Henrik Tramberend committed
10
11
import qualified Data.Text.Encoding as E
import qualified Data.Yaml as Y
12
import qualified Data.HashMap.Strict as Map
Henrik Tramberend's avatar
Henrik Tramberend committed
13
import Data.Yaml.Pretty as Y
14
import Data.Hashable
Henrik Tramberend's avatar
Henrik Tramberend committed
15
import Data.Maybe
Henrik Tramberend's avatar
Henrik Tramberend committed
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
import qualified Data.ByteString.Char8 as B
import Debug.Trace
import Development.Shake
import Development.Shake.FilePath
import System.FilePath ()
import System.FilePath.Glob
import System.Directory
import System.Random
import System.Random.Shuffle
import qualified Text.Mustache as M
import qualified Text.Mustache.Types as MT
import Text.Highlighting.Kate.Styles
import Text.Pandoc
import Text.Pandoc.PDF
import Text.Pandoc.Walk
import Utilities
32
import Context
Henrik Tramberend's avatar
Henrik Tramberend committed
33
34
import Filter
import Test
35
import Student
Henrik Tramberend's avatar
Henrik Tramberend committed
36
37
import Embed

38
39
replaceSuffix srcSuffix targetSuffix filename = dropSuffix srcSuffix filename ++ targetSuffix

Henrik Tramberend's avatar
Henrik Tramberend committed
40
main :: IO ()
41
42
43
44
45
main = do
    -- Calculate some directories
    projectDir <- calcProjectDirectory
    let privateDir = projectDir </> "private"
    -- Find questions
46
    questionSources <- glob "**/*-quest.yaml"
47
    -- Find exams
48
49
50
51
52
53
    examSources <- glob "**/*-exam.yaml"
    let exams = 
            map
                (replaceSuffix "-exam.yaml" "-exam.pdf" .
                 combine privateDir . makeRelative projectDir)
                examSources
54
55
56
57
58
    let solutions = 
            map
                (replaceSuffix "-exam.yaml" "-solution.pdf" .
                 combine privateDir . makeRelative projectDir)
                examSources
59
60
61
62
63
64
65
    -- Meta data
    metaFiles <- glob "**/*-meta.yaml"
    -- Calculate targets
    let catalog = privateDir </> "complete-quest-catalog.pdf"
    -- Prepare Mustache templates
    let templates = compileTesterTemplates
    --- 
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
    context <- makeActionContext projectDir privateDir "" ""
    runShakeInContext context shakeOptions $
        do do want ["catalog"]
              --
              catalog %>
                  \out -> do
                      allQuestions <- readQuestions questionSources
                      renderCatalog projectDir templates allQuestions out
              --
              phony
                  "catalog" $
                  need [catalog]
              --
              phony
                  "new-exam" $
                  do let string = Y.encodePretty Y.defConfig examStationary
                     liftIO $ B.writeFile "new-exam.yaml" string
              --
              phony
                  "new-mc" $
                  do let string = Y.encodePretty Y.defConfig multipleChoiceStationary
                     liftIO $ B.writeFile "new-mc-quest.yaml" string
              --
              phony
                  "new-ft" $
                  do let string = Y.encodePretty Y.defConfig fillTextStationary
                     liftIO $ B.writeFile "new-ft-quest.yaml" string
              --
              phony
                  "new-f" $
                  do let string = Y.encodePretty Y.defConfig freeStationary
                     liftIO $ B.writeFile "new-f-quest.yaml" string
              --
              phony
                  "exams" $
                  need exams
              --
103
104
105
106
              phony
                  "solutions" $
                  need solutions
              --
107
108
109
110
111
112
113
              "//*-exam.pdf" %>
                  \out -> do
                      let examPath = 
                              (replaceSuffix "-exam.pdf" "-exam.yaml" .
                               combine projectDir . makeRelative privateDir)
                                  out
                      need $ [examPath]
114
115
116
117
118
119
120
121
122
                      buildExam projectDir "exam" examPath questionSources out
              --
              "//*-solution.pdf" %>
                  \out -> do
                      let examPath = 
                              (replaceSuffix "-solution.pdf" "-exam.yaml" .
                               combine projectDir . makeRelative privateDir)
                                  out
                      buildExam projectDir "solution" examPath questionSources out
123
124
125
126
127
              --
              phony
                  "clean" $
                  removeFilesAfter "." ["private"]

128
129
130
131
132
133
134
135
136
137
138
139
buildExam projectDir disposition examSource questionSources out = do
    need $ [examSource]
    questions <- readQuestions questionSources
    exam <- readExamData examSource
    let studentInfoPath = 
            adjustLocalUrl projectDir (takeDirectory examSource) (examStudentInfoFile exam)
    Students studentMap <- readStudentInfo studentInfoPath (examTrack exam)
    let examData = generateExam exam questions (Map.elems studentMap)
    templates <- compileTemplates disposition
    examPandoc <- compileExam projectDir templates examData
    compilePandocPdf examPandoc out

Henrik Tramberend's avatar
Henrik Tramberend committed
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
compileTemplates :: FilePath -> Action MT.TemplateCache
compileTemplates disposition = do
    let templateNames = 
            [ "title-page.md"
            , "student-title-page.md"
            , "multiple-choice.md"
            , "fill-text.md"
            , "free-form.md"]
    compiled <- mapM (compileProjectTemplate disposition) templateNames
    return $ Map.fromList $ zip templateNames compiled

compileProjectTemplate :: FilePath -> FilePath -> Action MT.Template
compileProjectTemplate disposition name = do
    projectDir <- getProjectDir
    let filename = projectDir </> "exams" </> "templates" </> disposition </> name
    need [filename]
    text <- liftIO $ T.readFile $ filename
    let result = M.compileTemplate name (fixMustacheMarkupText text)
    return $
        case result of
            Right templ -> templ
            Left parseError -> 
                throw $
                MustacheException $ "Error parsing mustache template: " ++ (show parseError)

compilePandocPdf :: Pandoc -> FilePath -> Action ()
compilePandocPdf exam out = do
    let variables = 
168
169
170
171
            [ ("documentclass", "scrartcl")
            , ("lang", "german")
            , ("babel-lang", "german")
            , ("classoption", "fontsize=13pt")]
Henrik Tramberend's avatar
Henrik Tramberend committed
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
    let options = 
            def
            { writerStandalone = True
            , writerVariables = variables
            , writerTemplate = examLatexTemplate
            , writerHighlight = True
            , writerHighlightStyle = pygments
            , writerCiteMethod = Citeproc
            }
    putNormal $ "# pandoc (for " ++ out ++ ")"
    pandocMakePdf options exam out

compileQuestion :: FilePath -> MT.TemplateCache -> (Question, FilePath) -> Action Pandoc
compileQuestion projectDir templates question = do
    return $ compileToPandoc question
  where
    compileToPandoc :: (Question, FilePath) -> Pandoc
    compileToPandoc (quest,base) = 
        case readMarkdown def (renderMarkdown quest) of
            Left err -> throw $ PandocException (show err)
            Right pandoc -> walk (adjustImageUrls base) pandoc
    adjustImageUrls base (Image attr inlines (url,title)) = 
        (Image attr inlines (adjustLocalUrl projectDir base url, title))
    adjustImageUrls _ inline = inline
    renderMarkdown question = 
        T.unpack $ M.substitute (chooseTemplate templates question) (MT.mFromJSON question)

compileToPandoc
    :: Y.ToJSON a
    => MT.Template -> a -> Pandoc
compileToPandoc template thing = 
    case readMarkdown def $ T.unpack $ M.substitute template $ MT.mFromJSON thing of
        Left err -> throw $ PandocException (show err)
        Right pandoc -> pandoc

chooseTemplate :: MT.TemplateCache -> Question -> MT.Template
chooseTemplate templates question = 
    fromJust $
    case qstAnswer question of
        MultipleChoice _ -> Map.lookup "multiple-choice.md" templates
        FillText _ _ -> Map.lookup "fill-text.md" templates
        FreeForm _ _ -> Map.lookup "free-form.md" templates

lookupTemplate :: String -> MT.TemplateCache -> MT.Template
lookupTemplate name templates = 
    case Map.lookup name templates of
        Just t -> t
        Nothing -> throw $ MustacheException $ "Cannot lookup template: " ++ name

compileExam :: FilePath
            -> MT.TemplateCache
            -> (Exam, [(Student, [(Question, FilePath)])])
            -> Action Pandoc
compileExam projectDir templates (exam,students) = do
    let title = compileToPandoc (lookupTemplate "title-page.md" templates) exam
    list <- mapM (compileStudentExam projectDir templates exam) students
    return $ joinPandoc $ title : list

compileStudentExam :: FilePath
                   -> MT.TemplateCache
                   -> Exam
                   -> (Student, [(Question, FilePath)])
                   -> Action Pandoc
compileStudentExam projectDir templates exam (student,questions) = do
    let title = 
            compileToPandoc (lookupTemplate "student-title-page.md" templates) $
            StudentExam exam student
    list <- mapM (compileQuestion projectDir templates) questions
    return $ joinPandoc $ title : list

{-
compileExam :: (Exam, [(Student, [(Question, FilePath)])]) -> Action T.Text
compileExam exam = do
    projectDir <- getProjectDir
    let templateFile = "exam-template.md"
    result <- liftIO $ M.automaticCompile [projectDir </> "test" </> "exams"] templateFile
    let template = 
            case result of
                Right templ -> templ
                Left parseError -> 
                    throw $
                    MustacheException $ "Error parsing mustache template: " ++ (show parseError)
    return $ M.substitute template (MT.mFromJSON exam)
-}
{-
renderExam:: (Exam, [(Student, [Question])]) -> FilePath -> Action ()
renderExam exam pdfPath = do
    titlePage <- renderTitlePage (fst exam) (length $ snd exam)
    studentExams <- mapM (renderStudentExams $ fst exam) $ snd exam
renderExam exam pdfPath = do
    frontPage = renderFrontPage exam 
-}
joinPandoc
    :: [Pandoc] -> Pandoc
joinPandoc list = 
    Pandoc nullMeta $
    concatMap
        (\(Pandoc _ blocks) -> 
              blocks)
        list

273
274
275
276
-- | Filters questions by LectureIds and ExcludedTopicIds.
filterQuestions
    :: [T.Text] -> [T.Text] -> [(Question, FilePath)] -> [(Question, FilePath)]
filterQuestions includeLectures excludeTopics questions = 
Henrik Tramberend's avatar
Henrik Tramberend committed
277
    filter (not . (flip elem) excludeTopics . qstTopicId . fst) $
278
279
    filter ((flip elem) includeLectures . qstLectureId . fst) questions

280
281
type GroupedQuestions = Map.HashMap T.Text (Map.HashMap T.Text [(Question, FilePath)])

282
283
-- | Groups questions first by LectureId and then by TopicId into nested HashMaps.
groupQuestions
284
    :: [(Question, FilePath)] -> GroupedQuestions
285
286
287
288
289
290
groupQuestions questions = 
    let byLectureId = foldl (groupBy qstLectureId) Map.empty questions
    in Map.map (foldl (groupBy qstTopicId) Map.empty) byLectureId
  where
    groupBy attrib rmap question = Map.insertWith (++) (attrib $ fst question) [question] rmap

Henrik Tramberend's avatar
Henrik Tramberend committed
291
292
293
294
295
296
297
298
299
generateExam :: Exam
             -> [(Question, FilePath)]
             -> [Student]
             -> (Exam, [(Student, [(Question, FilePath)])])
generateExam exam questions students = 
    let sorted = sortOn std_employeeNumber students
        candidates = filterQuestions (examLectureIds exam) (examExcludedTopicIds exam) questions
        studentQuestions = map (selectQuestionsForStudent candidates) sorted
    in (exam, studentQuestions)
300
  where
Henrik Tramberend's avatar
Henrik Tramberend committed
301
302
303
304
    selectQuestionsForStudent :: [(Question, FilePath)]
                              -> Student
                              -> (Student, [(Question, FilePath)])
    selectQuestionsForStudent candidates student = 
305
        -- | Initialize the RNG with a hash over the student data. 
Henrik Tramberend's avatar
Henrik Tramberend committed
306
307
        -- Should produce the identical exam for one student each time and different 
        -- exams for all students every time.
308
        let gen = mkStdGen (hash student)
309
310
311
312
313
314
315
316
317
318
319
            -- Shuffle the deck of questions
            shuffled = shuffle' candidates (length candidates) gen
            -- Remove questions with duplicate TopicId. Keep the first one.
            singled = 
                nubBy
                    (\(q1,_) (q2,_) -> 
                          qstTopicId q1 == qstTopicId q2)
                    shuffled
            -- Take the number of questions that is needed
            selection = take (examNumberOfQuestions exam) singled
            -- Shuffle multiple choices
Henrik Tramberend's avatar
Henrik Tramberend committed
320
            questions = map (shuffleChoices gen) selection
321
322
323
            -- Number the questions 
            numbered = map numberQuestion (zip [1 ..] questions)
        in (student, numbered)
Henrik Tramberend's avatar
Henrik Tramberend committed
324
325
326
327
328
329
330
331
332
333
    shuffleChoices gen (question,basePath) = 
        let answer = 
                case qstAnswer question of
                    MultipleChoice choices -> 
                        MultipleChoice $ shuffle' choices (length choices) gen
                    _ -> qstAnswer question
        in ( question
             { qstAnswer = answer
             }
           , basePath)
334
335
336
337
338
    numberQuestion (n,(q,p)) = 
        ( q
          { qstCurrentNumber = n
          }
        , p)
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374

-- | Throw, result is shitty.
maybeThrowYaml
    :: Y.FromJSON a
    => FilePath -> Either Y.ParseException a -> a
maybeThrowYaml _ (Right yaml) = yaml
maybeThrowYaml path (Left exception) = 
    throw $ YamlException $ "Error parsing YAML file: " ++ path ++ ", " ++ (show exception)

-- | Reads a YAML file or throws.
readYAML
    :: Y.FromJSON a
    => FilePath -> Action a
readYAML path = do
    result <- liftIO $ Y.decodeFileEither path
    let contents = 
            case result of
                Right yaml -> yaml
                Left exception -> 
                    throw $
                    YamlException $
                    "Error parsing YAML file: " ++
                    path ++ ", " ++ (Y.prettyPrintParseException exception)
    return contents

-- Reads exam data from file
readExamData
    :: FilePath -> Action Exam
readExamData = readYAML

-- Reads info from all participating students.
readStudentInfo
    :: FilePath -> Int -> Action Students
readStudentInfo path track = do
    need [path]
    Students hashMap <- readYAML path
Henrik Tramberend's avatar
Henrik Tramberend committed
375
376
377
378
379
380
381
    let trackStudents = 
            Map.filter
                (\s -> 
                      std_track s == track)
                hashMap
    putNormal $ "Students in track " ++ show track ++ ": " ++ show (length trackStudents)
    return $ Students trackStudents
Henrik Tramberend's avatar
Henrik Tramberend committed
382
383
384

-- Reads all the questions and returns them along with the base directory of
-- each.
385
readQuestions
386
    :: [FilePath] -> Action [(Question, FilePath)]
387
388
389
390
391
392
393
394
395
396
397
398
399
readQuestions files = mapM readQuestion files

readQuestion :: FilePath -> Action (Question, FilePath)
readQuestion file = do
    need [file]
    result <- liftIO $ Y.decodeFileEither file
    let question = 
            case result of
                Right yaml -> yaml
                Left exception -> 
                    throw $
                    YamlException $ "Error parsing YAML file: " ++ file ++ ", " ++ (show exception)
    return (question, takeDirectory file)
Henrik Tramberend's avatar
Henrik Tramberend committed
400

401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
-- Renders a catalog of all questions (TODO sorted by LectureId and TopicId).
renderCatalog
    :: FilePath -> Templates -> [(Question, FilePath)] -> FilePath -> Action ()
renderCatalog projectDir templates questions out = do
    let markdown = 
            map
                (\(q,b) -> 
                      (renderMarkdown q, b))
                questions
    let pandoc = map parseMarkdown markdown
    need $ concatMap extractLocalImagePathes pandoc
    let catalog = 
            Pandoc nullMeta $
            concatMap
                (\(Pandoc _ blocks) -> 
                      blocks)
                pandoc
    let options = 
            def
            { writerStandalone = True
            , writerTemplate = B.unpack testLatexTemplate
            , writerHighlight = True
            , writerHighlightStyle = pygments
            , writerCiteMethod = Citeproc
            }
    putNormal $ "# pandoc (for " ++ out ++ ")"
    pandocMakePdf options catalog out
  where
    parseMarkdown (markdown,base) = 
        case readMarkdown def markdown of
Henrik Tramberend's avatar
Henrik Tramberend committed
431
432
            Left err -> throw $ PandocException (show err)
            Right pandoc -> walk (adjustImageUrls base) pandoc
433
434
435
436
437
    adjustImageUrls base (Image attr inlines (url,title)) = 
        (Image attr inlines (adjustLocalUrl projectDir base url, title))
    adjustImageUrls _ inline = inline
    renderMarkdown question = 
        T.unpack $ M.substitute (selectTemplate templates question) (MT.mFromJSON question)
Henrik Tramberend's avatar
Henrik Tramberend committed
438
439

-- TODO Make this work
440
441
442
443
444
newOrder
    :: Int -> IO [Int]
newOrder n = do
    gen <- getStdGen
    return $ shuffle' [0 .. (n - 1)] n gen
Henrik Tramberend's avatar
Henrik Tramberend committed
445
446

-- TODO Make this work
447
448
449
450
shuffleAnswers
    :: Question -> Action Question
shuffleAnswers q = 
    case qstAnswer q of
451
        MultipleChoice choices -> do
452
453
454
455
            let n = length choices
            order <- liftIO $ newOrder n
            return
                q
456
                { qstAnswer = MultipleChoice (shuffle choices order)
457
458
459
460
461
462
                }
        otherwise -> return q

examStationary :: Exam
examStationary = 
    Exam
Henrik Tramberend's avatar
Henrik Tramberend committed
463
464
465
    { examModule = "MODULE"
    , examTitle = "TITLE"
    , examStudentInfoFile = "PATH/TO/STUDENT/INFO"
466
    , examDateTime = "DATE_TIME"
467
468
    , examDurationInMinutes = 0
    , examNumberOfQuestions = 0
469
470
471
472
    , examTrack = 1
    , examLectureIds = ["LECTURE_ID"]
    , examExcludedTopicIds = ["EXCLUDED_TOPIC_ID"]
    }
Henrik Tramberend's avatar
Henrik Tramberend committed
473
474

multipleChoiceStationary :: Question
475
multipleChoiceStationary = 
476
    Question
477
478
    { qstTopicId = "TOPIC_ID"
    , qstLectureId = "LECTURE_ID"
479
480
481
482
    , qstTitle = "MULTIPLE CHOICE"
    , qstPoints = 5
    , qstQuestion = "THE QUESTION?"
    , qstAnswer = MultipleChoice
483
484
485
486
      { answChoices = [ Choice "ANSWER_1" True
                      , Choice "ANSWER_2" True
                      , Choice "DISTRACTOR_1" False
                      , Choice "DISTRACTOR_2" False]
487
488
489
      }
    , qstDifficulty = Medium
    , qstComment = "COMMENT"
490
491
    , qstCurrentNumber = 0
    , qstBasePath = "."
492
    }
Henrik Tramberend's avatar
Henrik Tramberend committed
493
494

fillTextStationary :: Question
495
fillTextStationary = 
496
    Question
497
498
    { qstTopicId = "TOPIC_ID"
    , qstLectureId = "LECTURE_ID"
499
500
501
502
503
504
505
506
507
    , qstTitle = "FILL TEXT"
    , qstPoints = 5
    , qstQuestion = "THE QUESTION?"
    , qstAnswer = FillText
      { answFillText = "FILL THE ___ IN THE ___."
      , answCorrectWords = ["HOLES", "TEXT"]
      }
    , qstDifficulty = Medium
    , qstComment = "COMMENT"
508
509
    , qstCurrentNumber = 0
    , qstBasePath = "."
510
    }
Henrik Tramberend's avatar
Henrik Tramberend committed
511
512

freeStationary :: Question
513
freeStationary = 
514
    Question
515
516
    { qstTopicId = "TOPIC_ID"
    , qstLectureId = "LECTURE_ID"
517
518
519
520
521
522
523
524
525
    , qstTitle = "FREE"
    , qstPoints = 5
    , qstQuestion = "THE QUESTION?"
    , qstAnswer = FreeForm
      { answHeightInMm = 20
      , answCorrectAnswer = "THE ANSWER."
      }
    , qstDifficulty = Medium
    , qstComment = "COMMENT"
526
527
    , qstCurrentNumber = 0
    , qstBasePath = "."
528
    }