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

Henrik Tramberend's avatar
Henrik Tramberend committed
3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31
import Control.Monad ()
import Control.Exception
import Data.Maybe ()
import Data.Typeable
import qualified Data.Text as T
import qualified Data.Text.Encoding as E
import qualified Data.Yaml as Y
import Data.Yaml.Pretty as Y
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
import Filter
import Test
import Embed

main :: IO ()
32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83
main = do
    -- Calculate some directories
    projectDir <- calcProjectDirectory
    let privateDir = projectDir </> "private"
    -- Find questions
    questionFiles <- glob "**/*-quest.yaml"
    -- Find exams
    examFiles <- glob "**/*-exam.yaml"
    -- Meta data
    metaFiles <- glob "**/*-meta.yaml"
    -- Calculate targets
    let catalog = privateDir </> "complete-quest-catalog.pdf"
    -- Prepare Mustache templates
    let templates = compileTesterTemplates
    --- 
    shakeArgs
        shakeOptions $
        do want ["catalog"]
           --
           catalog %>
               \out -> 
                    do need questionFiles
                       allQuestions <- readTests questionFiles
                       renderCatalog projectDir templates allQuestions out
           --
           phony
               "catalog" $
               do 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
               "clean" $
               do removeFilesAfter "." ["private"]
Henrik Tramberend's avatar
Henrik Tramberend committed
84 85 86

-- Reads all the questions and returns them along with the base directory of
-- each.
87 88
readTests
    :: [FilePath] -> Action [(Question, FilePath)]
Henrik Tramberend's avatar
Henrik Tramberend committed
89
readTests files = mapM readTest files
90 91 92 93 94 95 96 97 98 99 100 101 102
  where
    readTest :: FilePath -> Action (Question, FilePath)
    readTest file = do
        absolutePath <- liftIO $ makeAbsolute file
        string <- liftIO $ B.readFile absolutePath
        let question = 
                case Y.decodeEither' string of
                    Right yaml -> yaml
                    Left exception -> 
                        throw $
                        YamlException $
                        "Error parsing YAML file: " ++ file ++ ", " ++ (show exception)
        return (question, takeDirectory absolutePath)
Henrik Tramberend's avatar
Henrik Tramberend committed
103

104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133
-- 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
134 135
            Left err -> throw $ PandocException (show err)
            Right pandoc -> walk (adjustImageUrls base) pandoc
136 137 138 139 140
    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
141 142

-- TODO Make this work
143 144 145 146 147
newOrder
    :: Int -> IO [Int]
newOrder n = do
    gen <- getStdGen
    return $ shuffle' [0 .. (n - 1)] n gen
Henrik Tramberend's avatar
Henrik Tramberend committed
148 149

-- TODO Make this work
150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172
shuffleAnswers
    :: Question -> Action Question
shuffleAnswers q = 
    case qstAnswer q of
        MultipleChoice choices correct -> do
            let n = length choices
            order <- liftIO $ newOrder n
            return
                q
                { qstAnswer = MultipleChoice (shuffle choices order) (shuffle correct order)
                }
        otherwise -> return q

examStationary :: Exam
examStationary = 
    Exam
    { examStudentInfoFile = "PATH/TO/STUDENT/INFO"
    , examDateTime = "DATE_TIME"
    , examDurationInMinutes = "DURATION_IN_MINUTES"
    , examTrack = 1
    , examLectureIds = ["LECTURE_ID"]
    , examExcludedTopicIds = ["EXCLUDED_TOPIC_ID"]
    }
Henrik Tramberend's avatar
Henrik Tramberend committed
173 174

multipleChoiceStationary :: Question
175
multipleChoiceStationary = 
176
    Question
177 178
    { qstTopicId = "TOPIC_ID"
    , qstLectureId = "LECTURE_ID"
179 180 181 182 183 184 185 186 187 188
    , qstTitle = "MULTIPLE CHOICE"
    , qstPoints = 5
    , qstQuestion = "THE QUESTION?"
    , qstAnswer = MultipleChoice
      { answCorrect = ["ANSWER_1", "ANSWER_2"]
      , answIncorrect = ["DISTRACTOR_1", "DISTRACTOR_2"]
      }
    , qstDifficulty = Medium
    , qstComment = "COMMENT"
    }
Henrik Tramberend's avatar
Henrik Tramberend committed
189 190

fillTextStationary :: Question
191
fillTextStationary = 
192
    Question
193 194
    { qstTopicId = "TOPIC_ID"
    , qstLectureId = "LECTURE_ID"
195 196 197 198 199 200 201 202 203 204
    , qstTitle = "FILL TEXT"
    , qstPoints = 5
    , qstQuestion = "THE QUESTION?"
    , qstAnswer = FillText
      { answFillText = "FILL THE ___ IN THE ___."
      , answCorrectWords = ["HOLES", "TEXT"]
      }
    , qstDifficulty = Medium
    , qstComment = "COMMENT"
    }
Henrik Tramberend's avatar
Henrik Tramberend committed
205 206

freeStationary :: Question
207
freeStationary = 
208
    Question
209 210
    { qstTopicId = "TOPIC_ID"
    , qstLectureId = "LECTURE_ID"
211 212 213 214 215 216 217 218 219
    , qstTitle = "FREE"
    , qstPoints = 5
    , qstQuestion = "THE QUESTION?"
    , qstAnswer = FreeForm
      { answHeightInMm = 20
      , answCorrectAnswer = "THE ANSWER."
      }
    , qstDifficulty = Medium
    , qstComment = "COMMENT"
220
    }