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

Fixed a strange shuffle bug and one more answer type

parent b2b306e2
......@@ -21,121 +21,130 @@ import Embed
main :: IO ()
main = do
-- Calculate some directories
projectDir <- calcProjectDirectory
let publicDir = projectDir </> "public"
let cacheDir = projectDir </> "cache"
let supportDir = publicDir </> "support"
-- Find sources. These are formulated as actions in the Action mondad, such
-- that each new iteration rescans all possible source files.
let deckSourcesA = globA "**/*-deck.md"
let pageSourcesA = globA "**/*-page.md"
let allSourcesA = deckSourcesA <++> pageSourcesA
let allMarkdownA = globA "**/*.md"
let allImagesA = globA "**/*.png" <++> globA "**/*.jpg"
let metaA = globA "**/*-meta.yaml"
-- Calculate targets
let decksA = deckSourcesA >>= calcTargets ".md" ".html"
let decksPdfA = deckSourcesA >>= calcTargets ".md" ".pdf"
let handoutsA = deckSourcesA >>= calcTargets "-deck.md" "-handout.html"
let handoutsPdfA = deckSourcesA >>= calcTargets "-deck.md" "-handout.pdf"
let pagesA = pageSourcesA >>= calcTargets ".md" ".html"
let pagesPdfA = pageSourcesA >>= calcTargets ".md" ".pdf"
let indexSource = projectDir </> "index.md"
let index = publicDir </> "index.html"
let indexA = return [index] :: Action [FilePath]
let everythingA = decksA <++> handoutsA <++> pagesA
let everythingPdfA = decksPdfA <++> handoutsPdfA <++> pagesPdfA
let cruft = map (combine projectDir) [ "index.md.generated"
, "server.log"
, "//.shake"
]
context <- makeActionContext projectDir publicDir cacheDir supportDir
runShakeInContext context options $ do
want ["html"]
phony "decks" $ do
decksA >>= need
phony "html" $ do
everythingA <++> indexA >>= need
phony "pdf" $ do
pagesPdfA <++> handoutsPdfA <++> indexA >>= need
phony "pdf-decks" $ do
decksPdfA <++> indexA >>= need
phony "watch" $ do
need ["html"]
projectDir <- calcProjectDirectory
let publicDir = projectDir </> "public"
let cacheDir = projectDir </> "cache"
let supportDir = publicDir </> "support"
-- Find sources. These are formulated as actions in the Action mondad, such
-- that each new iteration rescans all possible source files.
let deckSourcesA = globA "**/*-deck.md"
let pageSourcesA = globA "**/*-page.md"
let allSourcesA = deckSourcesA <++> pageSourcesA
let allMarkdownA = globA "**/*.md"
let allImagesA = globA "**/*.png" <++> globA "**/*.jpg"
let metaA = globA "**/*-meta.yaml"
-- Calculate targets
let decksA = deckSourcesA >>= calcTargets ".md" ".html"
let decksPdfA = deckSourcesA >>= calcTargets ".md" ".pdf"
let handoutsA = deckSourcesA >>= calcTargets "-deck.md" "-handout.html"
let handoutsPdfA = deckSourcesA >>= calcTargets "-deck.md" "-handout.pdf"
let pagesA = pageSourcesA >>= calcTargets ".md" ".html"
let pagesPdfA = pageSourcesA >>= calcTargets ".md" ".pdf"
let indexSource = projectDir </> "index.md"
let index = publicDir </> "index.html"
let indexA = return [index] :: Action [FilePath]
let everythingA = decksA <++> handoutsA <++> pagesA
let everythingPdfA = decksPdfA <++> handoutsPdfA <++> pagesPdfA
let cruft =
map (combine projectDir) ["index.md.generated", "server.log", "//.shake"]
context <- makeActionContext projectDir publicDir cacheDir supportDir
runShakeInContext context options $
--
do want ["html"]
--
phony "decks" $ do decksA >>= need
--
phony "html" $ do everythingA <++> indexA >>= need
--
phony "pdf" $ do pagesPdfA <++> handoutsPdfA <++> indexA >>= need
--
phony "pdf-decks" $ do decksPdfA <++> indexA >>= need
--
phony "watch" $
do need ["html"]
allMarkdownA <++> metaA <++> allImagesA >>= watchFiles
phony "server" $ do
need ["watch", "support"]
--
phony "server" $
do need ["watch", "support"]
runHttpServer publicDir True
phony "example" writeExampleProject
priority 2 $ "//*-deck.html" %> \out -> do
src <- calcSource "-deck.html" "-deck.md" out
markdownToHtmlDeck src out
priority 2 $ "//*-deck.pdf" %> \out -> do
let src = replaceSuffix "-deck.pdf" "-deck.html" out
need [src]
putNormal $ src ++ " -> " ++ out
runHttpServer publicDir False
code <- cmd "decktape.sh reveal" ("http://localhost:8888" </> (makeRelative publicDir src)) out
case code of
ExitFailure _ -> do
throw $ DecktapeException "Unknown."
ExitSuccess ->
return ()
priority 2 $ "//*-handout.html" %> \out -> do
src <- calcSource "-handout.html" "-deck.md" out
markdownToHtmlHandout src out
priority 2 $ "//*-handout.pdf" %> \out -> do
src <- calcSource "-handout.pdf" "-deck.md" out
markdownToPdfHandout src out
priority 2 $ "//*-page.html" %> \out -> do
src <- calcSource "-page.html" "-page.md" out
markdownToHtmlPage src out
priority 2 $ "//*-page.pdf" %> \out -> do
src <- calcSource "-page.pdf" "-page.md" out
markdownToPdfPage src out
priority 2 $ index %> \out -> do
exists <- Development.Shake.doesFileExist indexSource
let src = if exists then indexSource else indexSource <.> "generated"
markdownToHtmlPage src out
indexSource <.> "generated" %> \out -> do
decks <- decksA
handouts <- handoutsA
pages <- pagesA
writeIndex out (takeDirectory index) decks handouts pages
phony "clean" $ do
removeFilesAfter publicDir ["//"]
--
phony "example" writeExampleProject
--
phony "index" $ need [index]
--
priority 2 $
"//*-deck.html" %>
\out -> do
src <- calcSource "-deck.html" "-deck.md" out
markdownToHtmlDeck src out
--
priority 2 $
"//*-deck.pdf" %>
\out -> do
let src = replaceSuffix "-deck.pdf" "-deck.html" out
need [src]
putNormal $ src ++ " -> " ++ out
runHttpServer publicDir False
code <-
cmd
"decktape.sh reveal"
("http://localhost:8888" </> (makeRelative publicDir src))
out
case code of
ExitFailure _ -> do
throw $ DecktapeException "Unknown."
ExitSuccess -> return ()
--
priority 2 $
"//*-handout.html" %>
\out -> do
src <- calcSource "-handout.html" "-deck.md" out
markdownToHtmlHandout src out
--
priority 2 $
"//*-handout.pdf" %>
\out -> do
src <- calcSource "-handout.pdf" "-deck.md" out
markdownToPdfHandout src out
--
priority 2 $
"//*-page.html" %>
\out -> do
src <- calcSource "-page.html" "-page.md" out
markdownToHtmlPage src out
--
priority 2 $
"//*-page.pdf" %>
\out -> do
src <- calcSource "-page.pdf" "-page.md" out
markdownToPdfPage src out
--
priority 2 $
index %>
\out -> do
exists <- Development.Shake.doesFileExist indexSource
let src =
if exists
then indexSource
else indexSource <.> "generated"
markdownToHtmlPage src out
--
indexSource <.> "generated" %>
\out -> do
decks <- decksA
handouts <- handoutsA
pages <- pagesA
need $ decks ++ handouts ++ pages
writeIndex out (takeDirectory index) decks handouts pages
--
phony "clean" $
do removeFilesAfter publicDir ["//"]
removeFilesAfter projectDir cruft
phony "help" $
liftIO $ putStr deckerHelpText
phony "plan" $ do
putNormal $ "project directory: " ++ projectDir
--
phony "help" $ liftIO $ putStr deckerHelpText
--
phony "plan" $
do putNormal $ "project directory: " ++ projectDir
putNormal $ "public directory: " ++ publicDir
putNormal $ "support directory: " ++ supportDir
putNormal "meta:"
......@@ -144,46 +153,58 @@ main = do
allSourcesA >>= mapM_ putNormal
putNormal "targets:"
everythingA <++> everythingPdfA >>= mapM_ putNormal
phony "meta" $ do
metaData <- metaA >>= readMetaData
--
phony "meta" $
do metaData <- metaA >>= readMetaData
liftIO $ B.putStr $ encodePretty defConfig metaData
phony "support" $ do
putNormal $ "# write embedded files for (" ++ supportDir ++ ")"
--
phony "support" $
do putNormal $ "# write embedded files for (" ++ supportDir ++ ")"
writeEmbeddedFiles deckerSupportDir supportDir
phony "publish" $ do
need ["support"]
--
phony "publish" $
do need ["support"]
everythingA <++> indexA >>= need
metaData <- readMetaDataForDir projectDir
let host = metaValueAsString "rsync-destination.host" metaData
let path = metaValueAsString "rsync-destination.path" metaData
if isJust host && isJust path
then do
let src = publicDir ++ "/"
let dst = intercalate ":" [fromJust host, fromJust path]
cmd "ssh " (fromJust host) "mkdir -p" (fromJust path) :: Action ()
cmd "rsync -a" src dst :: Action ()
else throw RsyncUrlException
then do
let src = publicDir ++ "/"
let dst = intercalate ":" [fromJust host, fromJust path]
cmd "ssh " (fromJust host) "mkdir -p" (fromJust path) :: Action ()
cmd "rsync -a" src dst :: Action ()
else throw RsyncUrlException
-- Calculate some directories
-- | Some constants that might need tweaking
options = shakeOptions{shakeFiles=".shake"}
options =
shakeOptions
{ shakeFiles = ".shake"
}
replaceSuffix srcSuffix targetSuffix filename = dropSuffix srcSuffix filename ++ targetSuffix
replaceSuffix srcSuffix targetSuffix filename =
dropSuffix srcSuffix filename ++ targetSuffix
-- | Calculates the target pathes from a list of source files.
calcTargets :: String -> String -> [FilePath] -> Action [FilePath]
calcTargets srcSuffix targetSuffix sources =
do projectDir <- getProjectDir
publicDir <- getPublicDir
return $ map (replaceSuffix srcSuffix targetSuffix . combine publicDir . makeRelative projectDir) sources
calcTargets srcSuffix targetSuffix sources = do
projectDir <- getProjectDir
publicDir <- getPublicDir
return $
map
(replaceSuffix srcSuffix targetSuffix .
combine publicDir . makeRelative projectDir)
sources
-- | Calculate the source file from the target path. Calls need.
calcSource :: String -> String -> FilePath -> Action FilePath
calcSource targetSuffix srcSuffix target =
do projectDir <- getProjectDir
publicDir <- getPublicDir
let src = (replaceSuffix targetSuffix srcSuffix . combine projectDir . makeRelative publicDir) target
need [src]
return src
calcSource targetSuffix srcSuffix target = do
projectDir <- getProjectDir
publicDir <- getPublicDir
let src =
(replaceSuffix targetSuffix srcSuffix .
combine projectDir . makeRelative publicDir)
target
need [src]
return src
This diff is collapsed.
\newpage
# Aufgabe {{CurrentNumber}}: {{Title}}
{{Question}}
{{\#Answer.CorrectAnswers}}
1. \underline{ \hspace{ {{Answer.Width}} } }
{{/Answer.CorrectAnswers}}
\newpage
# Aufgabe: {{Title}}
| | |
......
\newpage
# Aufgabe: {{Title}}
| | |
|---------------|----------------|
| Titel | **{{Title}}** |
| Id | {{TopicId}} |
| Vorlesung | {{LectureId}} |
| Schwierigkeit | {{Difficulty}} |
| Punkte | {{Points}} |
| Kommentar | {{Comment}} |
{{Question}}
{{\#Answer.Answers}}
- {{Detail}}: {{Correct}}
{{/Answer.Answers}}
......@@ -15,9 +15,10 @@ cabal-version: >=1.10
library
hs-source-dirs: src
exposed-modules: Pandoc, Test, Embed, Context, Utilities, Filter, Student
exposed-modules: Pandoc, Test, Embed, Context, Utilities, Filter, Student, Shuffle
build-depends: base
, aeson
, random
, pandoc-types
, pandoc-citeproc
, containers
......@@ -73,6 +74,7 @@ executable tester
ghc-options: -threaded -rtsopts -with-rtsopts=-N
build-depends: base
, slides
, process
, shake
, Glob
, bytestring
......@@ -87,7 +89,6 @@ executable tester
, mustache
, highlighting-kate
, random
, random-shuffle
default-language: Haskell2010
-- executable include-pandoc-filter
......
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE DeriveGeneric #-}
data Assignment = Assignment {
}
\ No newline at end of file
module Assignment
(
) where
import Control.Lens
import Data.Time
import Data.Yaml
import qualified Data.HashMap.Strict as M
import GHC.Generics
data DueDate = DueDate
{ _date :: UTCTime
, _track :: Int
} deriving (Show, Generic)
instance FromJSON DueDate
data Assignment = Assignment
{ _tag :: String
, _artefacts :: [String]
, _due :: [DueDate]
} deriving (Show, Generic)
instance FromJSON Assignment
type Assignments = M.HashMap String Assignment
data AssignmentInfo = AssignmentInfo
{ _graceperiod :: Int
, _assignments :: Assignments
} deriving (Show, Generic)
{-# LANGUAGE TemplateHaskell #-}
module Embed
(deckerHelpText
,deckerExampleDir
,deckerSupportDir
,deckTemplate
,pageTemplate
,pageLatexTemplate
,examLatexTemplate
,handoutTemplate
,handoutLatexTemplate
,testerMultipleChoiceTemplate
,testerFillTextTemplate
,testerFreeFormTemplate
,testLatexTemplate)
where
( deckerHelpText
, deckerExampleDir
, deckerSupportDir
, deckTemplate
, pageTemplate
, pageLatexTemplate
, examLatexTemplate
, handoutTemplate
, handoutLatexTemplate
, testerMultipleChoiceTemplate
, testerMultipleAnswersTemplate
, testerFillTextTemplate
, testerFreeFormTemplate
, testLatexTemplate
) where
import Data.FileEmbed
import qualified Data.ByteString.Char8 as B
......@@ -26,37 +27,48 @@ deckerSupportDir :: [(FilePath, B.ByteString)]
deckerSupportDir = $(makeRelativeToProject "resource/support" >>= embedDir)
deckerHelpText :: String
deckerHelpText = B.unpack $(makeRelativeToProject "resource/help-page.md" >>= embedFile)
deckerHelpText =
B.unpack $(makeRelativeToProject "resource/help-page.md" >>= embedFile)
deckTemplate :: String
deckTemplate = B.unpack $(makeRelativeToProject "resource/deck.html" >>= embedFile)
deckTemplate =
B.unpack $(makeRelativeToProject "resource/deck.html" >>= embedFile)
pageTemplate :: String
pageTemplate = B.unpack $(makeRelativeToProject "resource/page.html" >>= embedFile)
pageTemplate =
B.unpack $(makeRelativeToProject "resource/page.html" >>= embedFile)
pageLatexTemplate :: String
pageLatexTemplate = B.unpack $(makeRelativeToProject "resource/page.tex" >>= embedFile)
pageLatexTemplate =
B.unpack $(makeRelativeToProject "resource/page.tex" >>= embedFile)
examLatexTemplate :: String
examLatexTemplate = B.unpack $(makeRelativeToProject "resource/exam.tex" >>= embedFile)
examLatexTemplate =
B.unpack $(makeRelativeToProject "resource/exam.tex" >>= embedFile)
handoutTemplate :: String
handoutTemplate = B.unpack $(makeRelativeToProject "resource/handout.html" >>= embedFile)
handoutTemplate =
B.unpack $(makeRelativeToProject "resource/handout.html" >>= embedFile)
handoutLatexTemplate :: String
handoutLatexTemplate = B.unpack $(makeRelativeToProject "resource/handout.tex" >>= embedFile)
handoutLatexTemplate =
B.unpack $(makeRelativeToProject "resource/handout.tex" >>= embedFile)
testerMultipleChoiceTemplate :: B.ByteString
testerMultipleChoiceTemplate =
$(makeRelativeToProject "resource/mc-quest-catalog-template.md" >>= embedFile)
testerMultipleChoiceTemplate =
$(makeRelativeToProject "resource/mc-quest-catalog-template.md" >>= embedFile)
testerMultipleAnswersTemplate :: B.ByteString
testerMultipleAnswersTemplate =
$(makeRelativeToProject "resource/ma-quest-catalog-template.md" >>= embedFile)
testerFillTextTemplate :: B.ByteString
testerFillTextTemplate =
$(makeRelativeToProject "resource/ft-quest-catalog-template.md" >>= embedFile)
testerFillTextTemplate =
$(makeRelativeToProject "resource/ft-quest-catalog-template.md" >>= embedFile)
testerFreeFormTemplate :: B.ByteString
testerFreeFormTemplate =
$(makeRelativeToProject "resource/ff-quest-catalog-template.md" >>= embedFile)
testerFreeFormTemplate =
$(makeRelativeToProject "resource/ff-quest-catalog-template.md" >>= embedFile)
testLatexTemplate :: B.ByteString
testLatexTemplate = $(makeRelativeToProject "resource/test.tex" >>= embedFile)
\ No newline at end of file
testLatexTemplate = $(makeRelativeToProject "resource/test.tex" >>= embedFile)
module Shuffle
( fisherYates
) where
import System.Random
import Data.Map as M
fisherYatesStep
:: RandomGen g
=> (M.Map Int a, g) -> (Int, a) -> (M.Map Int a, g)
fisherYatesStep (m, gen) (i, x) = ((M.insert j x . M.insert i (m ! j)) m, gen')
where
(j, gen') = randomR (0, i) gen
fisherYates
:: RandomGen g
=> g -> [a] -> ([a], g)
fisherYates gen [] = ([], gen)
fisherYates gen l =
toElems $
Prelude.foldl fisherYatesStep (initial (head l) gen) (numerate (tail l))
where
toElems (x, y) = (elems x, y)
numerate = zip [1 ..]
initial x gen = (singleton 0 x, gen)
{-# LANGUAGE TemplateHaskell, OverloadedStrings, DeriveGeneric #-}
module Test
(Question(..)
,Answer(..)
,Choice(..)
,Difficulty(..)
,Exam(..)
,StudentExam(..)
,Templates
,compileTesterTemplates
,selectTemplate)
where
( Question(..)
, Answer(..)
, Choice(..)
, OneAnswer(..)
, Difficulty(..)
, Exam(..)
, StudentExam(..)
, Templates
, compileTesterTemplates
, selectTemplate
) where
import Data.Aeson.TH
import Control.Exception
......@@ -30,91 +31,105 @@ import Utilities
import Student
data Question = Question
{ qstTopicId :: T.Text
, qstLectureId :: T.Text
, qstTitle :: T.Text
, qstPoints :: Int
, qstQuestion :: T.Text
, qstAnswer :: Answer
, qstDifficulty :: Difficulty
, qstComment :: T.Text
, qstCurrentNumber :: Int
, qstBasePath :: String
} deriving (Eq,Show,Typeable,Generic)
{ qstTopicId :: T.Text
, qstLectureId :: T.Text
, qstTitle :: T.Text
, qstPoints :: Int
, qstQuestion :: T.Text
, qstAnswer :: Answer
, qstDifficulty :: Difficulty
, qstComment :: T.Text
, qstCurrentNumber :: Int
, qstBasePath :: String
} deriving (Eq, Show, Typeable, Generic)
data Choice = Choice
{ choiceTheAnswer :: T.Text
, choiceCorrect :: Bool