Skip to content

GitLab

Commit 30fa652f authored by Henrik Tramberend's avatar Henrik Tramberend
Browse files

Spring cleaning

parent e94ac0ac
Hide whitespace changes
Inline Side-by-side
Showing with 101 additions and 1321 deletions
.gitignore
View file @ 30fa652f
......@@ -13,4 +13,6 @@ index.html
public/
private/
auto/
index.md.generated
\ No newline at end of file
cache/
.vscode/
index.md.generated
.vscode/launch.json deleted 100644 → 0
View file @ e94ac0ac
{
"version": "0.2.0",
"configurations": [
{
"type": "ghc",
"name": "ghci debug viewer Phoityne",
"request": "launch",
"internalConsoleOptions": "openOnSessionStart",
"workspace": "${workspaceRoot}",
"startup": "${workspaceRoot}/test/Spec.hs",
"logFile": "${workspaceRoot}/.vscode/phoityne.log",
"logLevel": "WARNING",
"ghciPrompt": "H>>= ",
"ghciCmd": "stack ghci --test --no-load --no-build --main-is TARGET",
"ghciEnv": {},
"stopOnEntry": true,
"hackageVersion": "0.0.14.0",
"mainArgs": ""
}
]
}
\ No newline at end of file
.vscode/phoityne.log deleted 100644 → 0
View file @ e94ac0ac
2017-06-16 14:34:18 [ThreadId 11] ERROR phoityne - [deleteBreakPointOnGHCi] invalid delete break point. BreakPointData {nameBreakPointData = "Spec", srcPosBreakPointData = SourcePosition {filePathSourcePosition = "/Users/henrik/workspace/decker/test/Spec.hs", startLineNoSourcePosition = 97, startColNoSourcePosition = -1, endLineNoSourcePosition = -1, endColNoSourcePosition = -1}, breakNoBreakPointData = Nothing, conditionBreakPointData = Nothing, hitConditionBreakPointData = Nothing, hitCountBreakPointData = 0}
2017-06-16 14:34:49 [ThreadId 16] ERROR phoityne - load file fail.[/Users/henrik/workspace/decker/test/Spec.hs] file load error. '/Users/henrik/workspace/decker/test/Spec.hs'
2017-06-16 14:36:15 [ThreadId 11] ERROR phoityne - "error: Ambiguous occurrence \8216doesFileExist\8217 It could refer to either \8216Development.Shake.doesFileExist\8217, imported from \8216Development.Shake\8217 at /Users/henrik/workspace/decker/src/Context.hs:10:1-24 (and originally defined in \8216shake-0.15.11:Development.Shake.Rules.Directory\8217) or \8216System.Directory.doesFileExist\8217, imported from \8216System.Directory\8217 at /Users/henrik/workspace/decker/src/Filter.hs:23:1-23"
2017-06-16 14:38:28 [ThreadId 11] ERROR phoityne - "\"extractSourcePosition\" (line 26, column 6):\nunexpected end of input\nexpecting \"Stopped at \" or \"Stopped in \" [INPUT] Resolves a file path to a concrete verified file system path. FAILED [2]\ncacheRemoteFile\n Stores the data behind a URL locally, if possible. Return the local path to the cached file.\ncacheRemoteImages\n Replaces all remote images in the pandoc document with locally caches copies.\nparseStudentData\n Parses student data in YAML format into a nifty data structure.\n\nFailures:\n\n /Users/henrik/workspace/decker/test/Spec.hs:107: \n 1) copyResource Copies an existing resource to the public dir and returns the public URL.\n expected: True\n but got: False\n\n /Users/henrik/workspace/decker/test/Spec.hs:112: \n 2) provisionResource Resolves a file path to a concrete verified file system path.\n expected: True\n but got: False\n\nRandomized with seed 1732182263\n\nFinished in 107.8106 seconds\n10 examples, 2 failures\n*** Exception: ExitFailure 1\nH>>= "
2017-06-16 14:39:38 [ThreadId 11] ERROR phoityne - "error: Variable not in scope: aexists"
2017-06-16 14:39:44 [ThreadId 11] ERROR phoityne - "error: Variable not in scope: aexists"
2017-06-16 14:39:58 [ThreadId 11] ERROR phoityne - "error: Variable not in scope: aexists"
2017-06-16 14:40:20 [ThreadId 11] ERROR phoityne - "error: Variable not in scope: b"
2017-06-16 14:40:23 [ThreadId 11] ERROR phoityne - "error: Variable not in scope: a"
2017-06-16 14:40:32 [ThreadId 11] ERROR phoityne - "error: Variable not in scope: a"
2017-06-16 14:40:32 [ThreadId 11] ERROR phoityne - "error: Variable not in scope: b"
2017-06-16 14:41:01 [ThreadId 11] ERROR phoityne - "error: Ambiguous occurrence \8216doesFileExist\8217 It could refer to either \8216Development.Shake.doesFileExist\8217, imported from \8216Development.Shake\8217 at /Users/henrik/workspace/decker/src/Context.hs:10:1-24 (and originally defined in \8216shake-0.15.11:Development.Shake.Rules.Directory\8217) or \8216System.Directory.doesFileExist\8217, imported from \8216System.Directory\8217 at /Users/henrik/workspace/decker/src/Filter.hs:23:1-23"
2017-06-16 15:24:07 [ThreadId 11] ERROR phoityne - "error: Variable not in scope: a"
2017-06-16 15:24:07 [ThreadId 11] ERROR phoityne - "error: Variable not in scope: b"
2017-06-16 15:26:22 [ThreadId 11] ERROR phoityne - "error: parse error on input \8216then\8217"
2017-06-16 15:26:23 [ThreadId 11] ERROR phoityne - "error: \8226 Variable not in scope: bt \8226 Perhaps you meant one of these: \8216Ghci6.b\8217 (imported from Ghci6), \8216Ghci7.b\8217 (imported from Ghci7), \8216b\8217 (<no location info>)"
.vscode/tasks.json deleted 100644 → 0
View file @ e94ac0ac
{
"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
LICENSE
View file @ 30fa652f
None so far.
\ No newline at end of file
app/dot.hs deleted 100644 → 0
View file @ e94ac0ac
#!/usr/bin/env runhaskell
{-# LANGUAGE OverloadedStrings #-}
-- dot.hs
module Main where
import qualified Data.ByteString.Base64 as B64
import qualified Data.ByteString.Char8 as B
import qualified Data.ByteString.Lazy.Char8 as L
import Data.Digest.Pure.MD5
import Data.List
import Data.List.Split
import System.Exit
import System.IO
import System.Process
import Text.Pandoc.JSON
-- All supported Graphviz render
graphviz :: [String]
graphviz = ["dot", "neato", "twopi", "circo", "fdp", "sfdp", "patchwork"]
-- Searches code block attributes for the first graphviz renderer command
parseAttribs :: Attr -> Maybe (String, String)
parseAttribs (_, _, namevals) = find (((flip elem) graphviz) . fst) namevals
-- Compiles an external Graphviz file to an external PDF file. Returns the name of
-- the PDF file or an error message.
compileExternal :: String -> String -> IO (Either String String)
compileExternal cmd infile = do
let outfile = (Prelude.head $ splitOn "." infile) ++ ".pdf"
result <- readProcessWithExitCode cmd ["-Tpdf", "-o", outfile, infile] ""
case result of
(ExitSuccess, _, _) -> return (Right outfile)
(_, err, _) -> return (Left err)
-- Compiles an external Graphviz file to an external PDF file with a generated filename.
-- Returns the name of the PDF file or an error message.
compileInternal :: String -> String -> IO (Either String String)
compileInternal cmd contents = do
let outfile = cmd ++ "-" ++ (take 8 $ show $ md5 $ L.pack contents) ++ ".pdf"
result <- readProcessWithExitCode cmd ["-Tpdf", "-o", outfile] contents
case result of
(ExitSuccess, _, _) -> return (Right outfile)
(_, err, _) -> return (Left err)
-- Creates a Pandoc Image block from the filename or communicates an inline error message.
generateBlock :: (Either String String) -> IO Block
generateBlock (Right filename) = do
return (Para [Image nullAttr [] (filename, "Generated from code block")])
generateBlock (Left error) = do
hPutStrLn stderr msg
return (Para [Str msg])
where msg = "Error in filter 'graphviz': " ++ error
-- Compiles graphviz code from a code block to an image block
compileGraphviz :: Maybe Format -> Block -> IO Block
compileGraphviz (Just (Format "latex")) cb@(CodeBlock attribs contents) =
case parseAttribs attribs of
Just (graphvizCmd, "") -> compileInternal graphvizCmd contents >>= generateBlock
Just (graphvizCmd, infile) -> compileExternal graphvizCmd infile >>= generateBlock
Nothing -> return cb
compileGraphviz (Just (Format "revealjs")) cb@(CodeBlock (id, classes, namevals) contents) =
-- Examine 'dot' attribute.
case lookup "dot" namevals of
-- Empty file name means 'read from code block'.
Just "" -> do
-- Pipe content to dot, include result via data url on an image tag.
-- Otherwise it is difficult to control the size of the resulting SVG
-- element with CSS.
(exitCode, svg, err) <- readProcessWithExitCode "dot" ["-Tsvg"] contents
if exitCode == ExitSuccess
then return (Para [Image nullAttr [] (svgDataUrl svg, "Generated from code block")])
else return (Para [Str $ "Error running 'dot': " ++ err])
-- Read from file
Just file -> do
(exitCode, svg, err) <- readProcessWithExitCode "dot" ["-Tsvg", file] ""
if exitCode == ExitSuccess
then return (Para [Image nullAttr [] (svgDataUrl svg, "Generated from file " ++ file)])
else return (Para [Str $ "Error running 'dot': " ++ err])
-- Do nothing
Nothing -> return cb
compileGraphviz _ cb = return cb
main :: IO ()
main = toJSONFilter compileGraphviz
-- | Encode a svg snippet into a data url for an image element
svgDataUrl :: String -> String
svgDataUrl svg = "data:image/svg+xml;base64," ++ B.unpack (B64.encode (B.pack svg))
app/examiner.hs deleted 100644 → 0
View file @ e94ac0ac
{-# LANGUAGE OverloadedStrings #-}
import Context
import Control.Exception
import Control.Monad
import qualified Data.ByteString.Char8 as B
import qualified Data.HashMap.Strict as Map
import Data.Hashable
import Data.List
import Data.Maybe ()
import Data.Maybe
import qualified Data.Text as T
import qualified Data.Text.Encoding as E
import qualified Data.Text.IO as T
import Data.Typeable
import qualified Data.Yaml as Y
import Data.Yaml.Pretty as Y
import Debug.Trace
import Development.Shake
import Development.Shake.FilePath
import Embed
import Filter
import Project
import Shuffle
import Student
import System.Directory
import System.Exit
import System.FilePath ()
import System.FilePath.Glob
import System.Process
import System.Random
import Test
import Text.Highlighting.Kate.Styles
import qualified Text.Mustache as M
import qualified Text.Mustache.Types as MT
import Text.Pandoc
import Text.Pandoc.PDF
import Text.Pandoc.Walk
import Utilities
replaceSuffix srcSuffix targetSuffix filename =
dropSuffix srcSuffix filename ++ targetSuffix
main :: IO ()
main = do
dirs <- projectDirectories
let projectDir = (project dirs)
let privateDir = projectDir </> "private"
-- Find questions
questionSources <- glob "**/*-quest.yaml"
-- Find exams
examSources <- glob "**/*-exam.yaml"
let exams =
map
(replaceSuffix "-exam.yaml" "-exam.pdf" .
combine privateDir . makeRelative projectDir)
examSources
let solutions =
map
(replaceSuffix "-exam.yaml" "-solution.pdf" .
combine privateDir . makeRelative projectDir)
examSources
-- Meta data
metaFiles <- glob "**/*-meta.yaml"
-- Calculate targets
let catalog = privateDir </> "complete-quest-catalog.pdf"
-- Prepare Mustache templates
let templates = compileTesterTemplates
---
context <- makeActionContext (ProjectDirs projectDir privateDir "" "")
runShakeInContext context shakeOptions $ do
want ["catalog"]
--
catalog %> \out -> do
allQuestions <- readQuestions questionSources
renderCatalog
projectDir
templates
(sortOn (qstLectureId . fst) 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-multiple-choice" $ do
let string = Y.encodePretty Y.defConfig multipleChoiceStationary
liftIO $ B.writeFile "new-multiple-choice-quest.yaml" string
--
phony "new-multiple-answers" $ do
let string = Y.encodePretty Y.defConfig multipleAnswersStationary
liftIO $ B.writeFile "new-multiple-answers-quest.yaml" string
--
phony "new-fill-text" $ do
let string = Y.encodePretty Y.defConfig fillTextStationary
liftIO $ B.writeFile "new-fill-text-quest.yaml" string
--
phony "new-free-answer" $ do
let string = Y.encodePretty Y.defConfig freeStationary
liftIO $ B.writeFile "new-free-answer-quest.yaml" string
--
phony "exams" $ need exams
--
phony "solutions" $ need solutions
--
"//*-exam.pdf" %> \out -> do
let examPath =
(replaceSuffix "-exam.pdf" "-exam.yaml" .
combine projectDir . makeRelative privateDir)
out
need [examPath]
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
--
phony "clean" $ removeFilesAfter "." ["private"]
-- Calculate some directories
-- | Require a clean working tree to proceed
isWorkingTreeClean :: FilePath -> IO Bool
isWorkingTreeClean root = do
let refreshIndex =
"git -C " ++ root ++ " update-index -q --ignore-submodules --refresh"
let unstangedChanges =
"git -C " ++ root ++ " diff-files --quiet --ignore-submodules --"
let uncommitedChanges =
"git -C " ++
root ++ " diff-index --cached --quiet HEAD --ignore-submodules --"
system refreshIndex
usc <- system unstangedChanges
ucc <- system uncommitedChanges
return (usc == ExitSuccess && ucc == ExitSuccess)
-- | Get the abbreviated id of the last commit.
lastCommitId :: IO String
lastCommitId = do
r <- readProcess "git" ["--no-pager", "log", "-1", "--format=%H"] ""
return $ take 8 r
-- | Return last commit id of clean working dir, or exit with failure.
cleanCommitIdOrFail :: FilePath -> Action String
cleanCommitIdOrFail root = do
clean <- liftIO $ isWorkingTreeClean root
if clean
then throw $
GitException
"Workspace dirty, aborting. Please commit all changes or add them to .gitignore."
else liftIO lastCommitId
-- buildExam projectDir "exam" examPath questionSources out
buildExam ::
FilePath -> String -> FilePath -> [FilePath] -> FilePath -> Action ()
buildExam projectDir disposition examSource questionSources out = do
need [examSource]
putLoud "Reading questions ..."
questions <- readQuestions questionSources
putNormal $ "# Questions: " ++ show (length questions)
putLoud "Reading exam data ..."
exam <- readExamData examSource
let studentInfoPath =
adjustLocalUrl
projectDir
(takeDirectory examSource)
(examStudentInfoFile exam)
let failedStudentPath = projectDir </> "grading/failed-students.yaml"
putLoud "Reading students ..."
Students _ _ studentMap <- readStudentInfo studentInfoPath (examTracks exam)
failedStudents <- readFailedStudents failedStudentPath
putLoud "Generating exam ..."
let successful = filterFailed failedStudents studentMap
let examData = generateExam exam questions $ Map.elems $ successful
putNormal $ "# Students: " ++ show (Map.size successful)
putLoud "About to show exam data ..."
putLoud "Compiling templates ..."
templates <- compileTemplates disposition
putLoud "Compiling exam ..."
examPandoc <- compileExam projectDir templates examData
putLoud "Compiling PDF ..."
compilePandocPdf examPandoc out
filterFailed ::
[T.Text] -> Map.HashMap T.Text Student -> Map.HashMap T.Text Student
filterFailed failed students = foldl (flip Map.delete) students failed
compileTemplates :: FilePath -> Action MT.TemplateCache
compileTemplates disposition = do
let templateNames =
[ "title-page.md"
, "student-title-page.md"
, "multiple-choice.md"
, "multiple-answers.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
dirs <- getProjectDirs
let filename =
(project dirs) </> "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 =
[ ("documentclass", "scrartcl")
, ("lang", "german")
, ("babel-lang", "german")
, ("classoption", "fontsize=13pt")
]
let options =
def
{ writerVariables = variables
, writerTemplate = Just 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
putLoud "Compiling question ..."
return $ compile question
where
compile :: (Question, FilePath) -> Pandoc
compile (quest, base) =
let rendered = renderMarkdown quest
in case readMarkdown def rendered 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
MultipleAnswers _ _ -> Map.lookup "multiple-answers.md" templates
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 =
fromMaybe
(throw $ MustacheException $ "Cannot lookup template: " ++ name)
(Map.lookup name templates)
compileExam ::
FilePath
-> MT.TemplateCache
-> (Exam, [(Student, [(Question, FilePath)])])
-> Action Pandoc
compileExam projectDir templates (exam, students) = do
putLoud "Compiling exam title page ..."
let title = compileToPandoc (lookupTemplate "title-page.md" templates) exam
putLoud "Compiling 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
putLoud "Compiling student title page ..."
let title =
compileToPandoc (lookupTemplate "student-title-page.md" templates) $
StudentExam exam student
putLoud "Compiling student questions ..."
putLoud $ "projectDir: " ++ projectDir
putLoud $ "Templates: " ++ show templates
putLoud $ "Questions" ++ show questions
list <- mapM (compileQuestion projectDir templates) questions
putLoud "Assembling document ..."
return $ joinPandoc $ title : list
joinPandoc :: [Pandoc] -> Pandoc
joinPandoc list =
Pandoc nullMeta $ concatMap (\(Pandoc _ blocks) -> blocks) list
-- | Filters questions by LectureIds and ExcludedTopicIds.
filterQuestions ::
[T.Text] -> [T.Text] -> [(Question, FilePath)] -> [(Question, FilePath)]
filterQuestions includeLectures excludeTopics questions =
filter (not . (flip elem) excludeTopics . qstTopicId . fst) $
filter ((flip elem) includeLectures . qstLectureId . fst) questions
type GroupedQuestions
= Map.HashMap T.Text (Map.HashMap T.Text [(Question, FilePath)])
-- | Groups questions first by LectureId and then by TopicId into nested HashMaps.
groupQuestions :: [(Question, FilePath)] -> GroupedQuestions
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
-- The BUG is probably here!
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)
where
selectQuestionsForStudent ::
[(Question, FilePath)] -> Student -> (Student, [(Question, FilePath)])
-- | Initialize the RNG with a hash over the student data.
-- Should produce the identical exam for one student each time and different
-- exams for all students every time.
selectQuestionsForStudent candidates student =