Commit f3293eba authored by Henrik Tramberend's avatar Henrik Tramberend
Browse files

Working on tester and gettign there

parent f912ea67
{
"version": "0.1.0",
"command": "stack",
"suppressTaskName": true,
"isShellCommand": true,
"args": [],
"tasks": [
{
"taskName": "build",
"args": [
"build"
],
"isBuildCommand": true,
"problemMatcher": [
{
"owner": "stack",
"fileLocation": "absolute",
"pattern": [
{
"regexp": "^(.*):(\\d+):(\\d+):$",
"file": 1,
"line": 2,
"column": 3
},
{
"regexp": "^\\s+(.*)$",
"message": 1
}
]
},
{
"owner": "stack",
"fileLocation": "absolute",
"pattern": [
{
"regexp": "^(.*):(\\d+):(\\d+):\\s+(Warning):\\s+(.*)$",
"file": 1,
"line": 2,
"column": 3,
"severity": 4,
"message": 5
}
]
},
{
"owner": "stack",
"fileLocation": "absolute",
"pattern": [
{
"regexp": "^(.*):(\\d+):(\\d+):\\s+(Warning|Error):$",
"file": 1,
"line": 2,
"column": 3,
"severity": 4
},
{
"regexp": "^\\s+(.*)$",
"message": 1
}
]
}
]
},
{
"taskName": "clean",
"args": [
"clean"
],
"isBuildCommand": false,
"isTestCommand": false
},
{
"taskName": "test",
"args": [
"test"
],
"isTestCommand": true,
"problemMatcher": [
{
"owner": "hspec",
"fileLocation": [
"relative",
"${workspaceRoot}"
],
"pattern": [
{
"regexp": "^\\s+(.*):(\\d+):",
"file": 1,
"line": 2
},
{
"regexp": "^\\s+\\d+\\)\\s+(.*)",
"message": 1
}
]
}
]
}
]
}
\ No newline at end of file
......@@ -19,11 +19,6 @@ import Utilities
import Context
import Embed
globA :: FilePattern -> Action [FilePath]
globA pattern =
do projectDir <- getProjectDir
liftIO $ globDir1 (compile pattern) projectDir
main :: IO ()
main = do
-- Calculate some directories
......
......@@ -7,7 +7,9 @@ import Data.Typeable
import qualified Data.Text as T
import qualified Data.Text.Encoding as E
import qualified Data.Yaml as Y
import qualified Data.HashMap.Strict as Map
import Data.Yaml.Pretty as Y
import Data.Hashable
import qualified Data.ByteString.Char8 as B
import Debug.Trace
import Development.Shake
......@@ -24,19 +26,28 @@ import Text.Pandoc
import Text.Pandoc.PDF
import Text.Pandoc.Walk
import Utilities
import Context
import Filter
import Test
import Student
import Embed
replaceSuffix srcSuffix targetSuffix filename = dropSuffix srcSuffix filename ++ targetSuffix
main :: IO ()
main = do
-- Calculate some directories
projectDir <- calcProjectDirectory
let privateDir = projectDir </> "private"
-- Find questions
questionFiles <- glob "**/*-quest.yaml"
questionSources <- glob "**/*-quest.yaml"
-- Find exams
examFiles <- glob "**/*-exam.yaml"
examSources <- glob "**/*-exam.yaml"
let exams =
map
(replaceSuffix "-exam.yaml" "-exam.pdf" .
combine privateDir . makeRelative projectDir)
examSources
-- Meta data
metaFiles <- glob "**/*-meta.yaml"
-- Calculate targets
......@@ -44,62 +55,155 @@ main = do
-- 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"]
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
--
"//*-exam.pdf" %>
\out -> do
let examPath =
(replaceSuffix "-exam.pdf" "-exam.yaml" .
combine projectDir . makeRelative privateDir)
out
need $ [examPath]
questions <- readQuestions questionSources
exam <- readExamData examPath
let studentInfoPath =
adjustLocalUrl
projectDir
(takeDirectory examPath)
(examStudentInfoFile exam)
Students hashMap <- readStudentInfo studentInfoPath (examTrack exam)
renderExam exam questions (Map.elems hashMap) out
--
phony
"clean" $
removeFilesAfter "." ["private"]
-- | Filters questions by LectureIds and ExcludedTopicIds.
filterQuestions
:: [T.Text] -> [T.Text] -> [(Question, FilePath)] -> [(Question, FilePath)]
filterQuestions includeLectures excludeTopics questions =
filter (not . (flip elem) excludeTopics . qstLectureId . fst) $
filter ((flip elem) includeLectures . qstLectureId . fst) questions
-- | Groups questions first by LectureId and then by TopicId into nested HashMaps.
groupQuestions
:: [(Question, FilePath)] -> Map.HashMap T.Text (Map.HashMap T.Text [(Question, FilePath)])
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
renderExam :: Exam -> [(Question, FilePath)] -> [Student] -> FilePath -> Action ()
renderExam exam questions students out = do
let candidates = filterQuestions (examLectureIds exam) (examExcludedTopicIds exam) questions
mapM_ (renderExamFor candidates) students
putNormal $ "Rendered exam: " ++ out
where
renderExamFor :: [(Question, FilePath)] -> Student -> Action ()
renderExamFor candidates student = do
-- | Initialize the RNG with a hash over the student data.
-- Should produce the identical exam for the student each time.
let gen = mkStdGen (hash student)
let questions =
take (examNumberOfQuestions exam) $ shuffle' candidates (length candidates) gen
putNormal $ show (std_displayName student)
mapM_ (putNormal . show . qstLectureId . fst) questions
-- | 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
return $
Students $
Map.filter
(\s ->
std_track s == track)
hashMap
-- Reads all the questions and returns them along with the base directory of
-- each.
readTests
readQuestions
:: [FilePath] -> Action [(Question, FilePath)]
readTests files = mapM readTest files
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)
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)
-- Renders a catalog of all questions (TODO sorted by LectureId and TopicId).
renderCatalog
......@@ -151,12 +255,12 @@ shuffleAnswers
:: Question -> Action Question
shuffleAnswers q =
case qstAnswer q of
MultipleChoice choices correct -> do
MultipleChoice choices -> do
let n = length choices
order <- liftIO $ newOrder n
return
q
{ qstAnswer = MultipleChoice (shuffle choices order) (shuffle correct order)
{ qstAnswer = MultipleChoice (shuffle choices order)
}
otherwise -> return q
......@@ -165,7 +269,8 @@ examStationary =
Exam
{ examStudentInfoFile = "PATH/TO/STUDENT/INFO"
, examDateTime = "DATE_TIME"
, examDurationInMinutes = "DURATION_IN_MINUTES"
, examDurationInMinutes = 0
, examNumberOfQuestions = 0
, examTrack = 1
, examLectureIds = ["LECTURE_ID"]
, examExcludedTopicIds = ["EXCLUDED_TOPIC_ID"]
......@@ -180,8 +285,10 @@ multipleChoiceStationary =
, qstPoints = 5
, qstQuestion = "THE QUESTION?"
, qstAnswer = MultipleChoice
{ answCorrect = ["ANSWER_1", "ANSWER_2"]
, answIncorrect = ["DISTRACTOR_1", "DISTRACTOR_2"]
{ answChoices = [ Choice "ANSWER_1" True
, Choice "ANSWER_2" True
, Choice "DISTRACTOR_1" False
, Choice "DISTRACTOR_2" False]
}
, qstDifficulty = Medium
, qstComment = "COMMENT"
......
Points: 5
LectureId: Some lecture id
LectureId: LECTURE_ID
Answer:
CorrectAnswer: THE ANSWER.
tag: FreeForm
......
Points: 5
LectureId: Some lecture id
LectureId: LECTURE_ID
Answer:
tag: FillText
CorrectWords:
......
Points: 5
LectureId: Some lecture id
LectureId: LECTURE_ID
Answer:
tag: MultipleChoice
Correct:
- ANSWER_1
- ANSWER_2
Incorrect:
- DISTRACTOR_1
- DISTRACTOR_2
Choices:
- Correct: true
TheAnswer: ANSWER_1
- Correct: true
TheAnswer: ANSWER_2
- Correct: false
TheAnswer: DISTRACTOR_1
- Correct: false
TheAnswer: DISTRACTOR_2
TopicId: Some topic id
Title: MULTIPLE CHOICE
Difficulty: Medium
......
......@@ -4,6 +4,7 @@
|---------------|----------------|
| Titel | **{{Title}}** |
| Id | {{TopicId}} |
| Base | {{BaseDir}} |
| Vorlesung | {{LectureId}} |
| Schwierigkeit | {{Difficulty}} |
| Punkte | {{Points}} |
......
......@@ -4,6 +4,7 @@
|---------------|----------------|
| Titel | **{{Title}}** |
| Id | {{TopicId}} |
| Base | {{BaseDir}} |
| Vorlesung | {{LectureId}} |
| Schwierigkeit | {{Difficulty}} |
| Punkte | {{Points}} |
......
......@@ -4,6 +4,7 @@
|---------------|----------------|
| Titel | **{{Title}}** |
| Id | {{TopicId}} |
| Base | {{BaseDir}} |
| Vorlesung | {{LectureId}} |
| Schwierigkeit | {{Difficulty}} |
| Punkte | {{Points}} |
......@@ -13,14 +14,8 @@
*Antworten:*
{{\#Answer.Correct}}
{{\#Answer.Choices}}
- $\boxtimes$ {{.}}
- {{\#Correct}}$\boxtimes${{/Correct}}{{\^Correct}}$\square${{/Correct}} {{TheAnswer}}
{{/Answer.Correct}}
{{\#Answer.Incorrect}}
- $\square$ {{.}}
{{/Answer.Incorrect}}
{{/Answer.Choices}}
......@@ -30,6 +30,7 @@ library
, time
, shake
, process
, hashable
, extra
, filepath
, Glob
......@@ -79,8 +80,10 @@ executable tester
, filepath
, pandoc
, pandoc-types
, unordered-containers
, text
, yaml
, hashable
, mustache
, highlighting-kate
, random
......
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TemplateHaskell, DeriveGeneric #-}
-- | Provides data types for the student information. Data is read from YAML files.
module Student (Student(..), Students(..)) where
module Student
(Student(..)
,Students(..))
where
import Control.Exception
import Data.Yaml
......@@ -10,23 +12,31 @@ import Data.Aeson.Types
import Data.Aeson.TH
import qualified Data.HashMap.Strict as Map
import qualified Data.Text as T
data Student =
Student { std_uid :: T.Text
, std_department :: T.Text
, std_displayName :: T.Text
, std_employeeNumber :: T.Text
, std_givenName :: T.Text
, std_mail :: T.Text
, std_sAMAccountName :: T.Text
, std_sn :: T.Text
, std_track :: Int
}
deriving (Eq,Show)
data Students = Students (Map.HashMap T.Text Student) deriving (Eq, Show)
$(deriveJSON defaultOptions{fieldLabelModifier = drop 4} ''Student)
$(deriveJSON defaultOptions ''Students)
import GHC.Generics (Generic)
import Data.Hashable
data Student = Student
{ std_uid :: T.Text
, std_department :: T.Text
, std_displayName :: T.Text
, std_employeeNumber :: T.Text
, std_givenName :: T.Text
, std_mail :: T.Text
, std_sAMAccountName :: T.Text
, std_sn :: T.Text
, std_track :: Int
} deriving (Eq,Show,Generic)
instance Hashable Student
data Students =
Students (Map.HashMap T.Text Student)
deriving (Eq,Show)
$(deriveJSON
defaultOptions
{ fieldLabelModifier = drop 4
}
''Student)
$(deriveJSON defaultOptions ''Students)
\ No newline at end of file
{-# LANGUAGE TemplateHaskell, OverloadedStrings #-}
module Test
(Question(..), Answer(..), Difficulty(..), Exam(..), Templates,
compileTesterTemplates, selectTemplate)
where
(Question(..)
,Answer(..)
,Choice(..)
,Difficulty(..)
,Exam(..)
,Templates
,compileTesterTemplates
,selectTemplate)
where
import Data.Aeson.TH
import Control.Exception
import Data.Yaml
import Data.Aeson.Types
......@@ -18,7 +25,6 @@ import qualified Text.Mustache as M
import qualified Text.Mustache.Types as MT
import Embed
import Utilities
import Data.Aeson.TH
data Question = Question
{ qstTopicId :: T.Text
......@@ -31,9 +37,13 @@ data Question = Question
, qstComment :: T.Text
} deriving (Eq,Show,Typeable)
data Choice = Choice
{ choiceTheAnswer :: T.Text
, choiceCorrect :: Bool
} deriving (Eq,Show,Typeable)
data Answer
= MultipleChoice { answCorrect :: [T.Text]
, answIncorrect :: [T.Text]}
= MultipleChoice { answChoices :: [Choice]}
| FillText { answFillText :: T.Text
, answCorrectWords :: [T.Text]}
| FreeForm { answHeightInMm :: Int
......@@ -49,12 +59,19 @@ data Difficulty
data Exam = Exam
{ examStudentInfoFile :: FilePath
, examDateTime :: T.Text
, examDurationInMinutes :: T.Text
, examDurationInMinutes :: Int
, examNumberOfQuestions :: Int
, examTrack :: Int
, examLectureIds :: [T.Text]
, examExcludedTopicIds :: [T.Text]
} deriving (Eq,Show,Typeable)
$(deriveJSON
defaultOptions
{ fieldLabelModifier = drop 6
}
''Choice)