Commit 904023d6 authored by Henrik Tramberend's avatar Henrik Tramberend
Browse files

Merge branch 'master' into mario

parents 1824c6f8 1c8a515c
......@@ -77,6 +77,7 @@ dependencies:
- network-uri
- pandoc
- pandoc-types
- pretty-simple
- process
- pureMD5
- random
......
......@@ -235,6 +235,34 @@ div.exa-quest[data-solved] div.exa-ff div.solution {
display: block;
}
div.exa-nu {
margin: 0em;
padding-left: 0em;
padding-top: 0.3em;
padding-bottom: 0em;
}
div.exa-nu h3 {
margin: 0em;
padding-left: 0em;
padding-top: 0.3em;
font-weight: bold;
}
div.exa-nu textarea {
width: 100%;
resize: none;
font-family: "Source Code Pro", monospace;
}
div.exa-nu div.solution {
display: none;
}
div.exa-quest[data-solved] div.exa-nu div.solution {
display: block;
}
table.exa-ma i.correct {
color: darkgreen;
width: 1.3em;
......
......@@ -39,6 +39,12 @@ function gradeFF(exam) {
score.textContent += "0 / 0";
}
function gradeNU(exam) {
let nuAnswer = exam.querySelector("div.solution div.correct");
let score = exam.querySelector("div.score span.display");
score.textContent += "0 / 0";
}
function gradeMA(exam) {
let maAnswer = exam.querySelector("table.exa-ma");
if (maAnswer !== null) {
......@@ -144,6 +150,22 @@ function prepareExaminer() {
});
}
// Free form answer
let nuAnswer = exam.querySelector("div.exa-nu");
if (nuAnswer !== null) {
let textarea = nuAnswer.querySelector("textarea");
solve.addEventListener("click", _ => {
gradeNU(exam);
setAttribute(exam, "solved", true);
textarea.setAttribute("readonly", true);
});
again.addEventListener("click", _ => {
removeAttribute(exam, "solved");
textarea.removeAttribute("readonly");
textarea.value = "";
});
}
// Multiple answers
let maAnswer = exam.querySelector("table.exa-ma");
if (maAnswer !== null) {
......
......@@ -30,6 +30,7 @@ import Text.Decker.Internal.Common
import Text.Decker.Internal.Meta
import Text.Pandoc
import Text.Pandoc.Walk
import Text.Pretty.Simple
import qualified Text.URI as URI
-- | Renders a question to Pandoc AST.
......@@ -57,7 +58,7 @@ renderQuestion meta base qst =
)
[]
]
<> rawHtml' (H.h2 $ toHtml $ _qstTitle qst)
<> rawHtml' (H.h2 $ toHtml $ parseToBlocks base (_qstTitle qst))
<> [Div ("", ["question"], []) $ parseToBlocks base (_qstQuestion qst)]
<> renderAnswer (_qstAnswer qst)
<> [ rawHtml' $
......@@ -119,8 +120,8 @@ renderQuestion meta base qst =
let select = H.select $ H.optgroup $ toHtml $ map mkOption answers
mkOption (OneAnswer _ correct) = H.option $ toHtml correct
mkDetail (OneAnswer detail correct) =
H.tr ! A.class_ "detail" ! dataAttribute "correct" (toValue correct) $
toHtml [H.td ! A.class_ "result" $ "", H.td $ toHtml detail, H.td select]
H.tr ! A.class_ "detail" ! dataAttribute "correct" (toValue $ correct) $
toHtml [H.td ! A.class_ "result" $ "", H.td $ toHtml $ parseToBlocks base detail, H.td select]
in rawHtml' $
H.table ! A.class_ "answer exa-ma" $
H.tbody $
......@@ -198,5 +199,7 @@ examinerFilter pandoc@(Pandoc meta _) = walkM expandQuestion pandoc
let result = Y.decodeEither' $ encodeUtf8 source
case result of
Left err -> throw $ InternalException $ show err
Right question -> return $ renderQuestion meta base question
Right question -> do
let q = renderQuestion meta base question
return q
expandQuestion block = return block
......@@ -45,7 +45,7 @@ data Answer
_answCorrectAnswer :: Text
}
| Numerical
{ _answCorrectNumber :: Float
{ _answCorrectNumber :: Int
}
| MultipleAnswers
{ _answWidthInMm :: Int,
......@@ -70,6 +70,7 @@ data Question = Question
_qstAnswer :: Answer,
_qstDifficulty :: Difficulty,
_qstComment :: Text,
_qstShuffleAnswers :: Bool,
_qstCurrentNumber :: Int,
_qstFilePath :: String
}
......@@ -97,6 +98,7 @@ instance FromJSON Question where
<*> q .: "Answer"
<*> q .: "Difficulty"
<*> q .: "Comment"
<*> q .:? "ShuffleAnswers" .!= True
<*> q .:? "CurrentNumber" .!= 0
<*> q .:? "FilePath" .!= "."
parseJSON invalid = typeMismatch "Question" invalid
......
......@@ -10,8 +10,6 @@
module Text.Decker.Exam.Render
( renderQuestion,
renderCatalog,
renderQuestionToHtml,
compileQuestionToHtml,
)
where
......@@ -37,6 +35,7 @@ import Text.Decker.Reader.Markdown
-- import Text.Groom
import Text.Pandoc
import Text.Pandoc.Walk
import Text.Pretty.Simple
compileQuestionToHtml :: Meta -> FilePath -> Question -> Action Question
compileQuestionToHtml meta base quest = do
......@@ -88,8 +87,9 @@ renderAnswerToHtml answer@MultipleAnswers {} =
H.td (preEscapedText $ one ^. oneDetail)
H.td (preEscapedText $ one ^. oneCorrect)
renderAnswerToHtml answer@FreeForm {} = do
let height = show (_answHeightInMm answer) :: Text
H.p ! H.dataAttribute "height" (toValue height) $ preEscapedText $ answer ^. answCorrectAnswer
H.text $ answer ^. answCorrectAnswer
renderAnswerToHtml answer@Numerical {} = do
H.text $ answer ^. answCorrectAnswer
renderAnswerToHtml answer@FillText {} =
H.p "Not yet implemented"
......
......@@ -97,7 +97,10 @@ renderXmlCatalog questions out = do
XML.NodeElement $
XML.Element "answernumbering" M.empty [XML.NodeContent "none"],
XML.NodeElement $
XML.Element "shuffleanswers" M.empty [XML.NodeContent "1"],
XML.Element
"shuffleanswers"
M.empty
[XML.NodeContent (if _qstShuffleAnswers question then "1" else "0")],
XML.NodeElement $
XML.Element
"defaultgrade"
......@@ -131,15 +134,15 @@ renderXmlCatalog questions out = do
[ XML.NodeElement $
XML.Element
"answer"
(M.fromList [("fraction", "0")])
[XML.NodeElement $ XML.Element "text" M.empty []]
(M.fromList [("fraction", "100")])
[XML.NodeElement $ XML.Element "text" M.empty [XML.NodeContent correctAnswer]]
]
renderAnswer (Numerical correctAnswer) =
[ XML.NodeElement $
XML.Element
"answer"
(M.fromList [("fraction", "0")])
[XML.NodeElement $ XML.Element "text" M.empty []]
(M.fromList [("fraction", "100")])
[XML.NodeElement $ XML.Element "text" M.empty [XML.NodeContent (show correctAnswer)]]
]
renderAnswer (MultipleAnswers widthInMm answers) =
map renderSubQuestion answers
......@@ -204,7 +207,12 @@ xmlAnswerType q =
-- | Inserts the title into the question text.
insertTitle :: Question -> Question
insertTitle q =
q {_qstQuestion = T.concat ["# ", _qstTitle q, "\n\n", _qstQuestion q]}
let style =
"<style>"
<> " div.formulation.clearfix { background-color: #f9f9f9; color: #000; border: solid 1px #ccc; }"
<> " div.formulation.clearfix h1 { font-size: 1.5rem; font-weight: bold; }"
<> "</style>\n\n"
in q {_qstQuestion = T.concat [style, "# ", _qstTitle q, "\n\n", _qstQuestion q]}
sortQuestions :: [Question] -> [Question]
sortQuestions =
......@@ -246,6 +254,10 @@ embedCode :: Block -> Block
embedCode (CodeBlock attr code) = CodeBlock attr code
embedCode block = block
killSinglePara :: Pandoc -> Pandoc
killSinglePara (Pandoc meta [Para inlines]) = Pandoc meta [Plain inlines]
killSinglePara pandoc = pandoc
readFileBase64 :: FilePath -> IO String
readFileBase64 path = UTF8.toString . B64.encode <$> BS.readFile path
......@@ -253,7 +265,7 @@ renderHtml :: FilePath -> T.Text -> Action T.Text
renderHtml base markdown =
case parseMarkdown markdown of
Right pandoc -> do
embedded <- walkM (embedImages base) (walk embedCode pandoc)
embedded <- killSinglePara <$> walkM (embedImages base) (walk embedCode pandoc)
case renderHtml5 embedded of
Right html5 -> return html5
Left errMsg -> throw $ PandocException (show errMsg)
......
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE FlexibleInstances #-}
module Text.Decker.Filter.Slide
( Slide(..)
, _Slide
, attribValue
, blocks
, dropByClass
, keepByClass
, firstClass
, fromSlides
, fromSlidesWrapped
, classes
, hasAnyClass
, hasClass
, header
, isBoxDelim
, toSlides
) where
{-# LANGUAGE OverloadedStrings #-}
import Text.Pandoc.Lens
module Text.Decker.Filter.Slide
( Slide (..),
_Slide,
attribValue,
blocks,
dropByClass,
keepByClass,
firstClass,
fromSlides,
fromSlidesWrapped,
classes,
hasAnyClass,
hasClass,
header,
isBoxDelim,
toSlides,
)
where
import Control.Lens
import Data.List
import Data.List.Split
import Data.Maybe
import qualified Data.Text as Text
import Text.Pandoc
import Text.Pandoc.Definition ()
import qualified Data.Text as Text
import Text.Pandoc.Lens
-- A slide has maybe a header followed by zero or more blocks.
data Slide = Slide
{ _header :: Maybe Block
, _body :: [Block]
} deriving (Eq, Show)
{ _header :: Maybe Block,
_body :: [Block]
}
deriving (Eq, Show)
-- | A lens for header access on a slide. See
-- https://www.schoolofhaskell.com/school/to-infinity-and-beyond/pick-of-the-week/a-little-lens-starter-tutorial
header :: Lens' Slide (Maybe Block)
header = lens (\(Slide h _) -> h) (\(Slide _ b) h -> Slide h b)
-- | A lens for blocks access on a slide.
-- | A lens for blocks access on a slide.
blocks :: Lens' Slide [Block]
blocks = lens (\(Slide _ b) -> b) (\(Slide h _) b -> Slide h b)
......@@ -47,15 +49,15 @@ blocks = lens (\(Slide _ b) -> b) (\(Slide h _) b -> Slide h b)
_Slide :: Prism' Slide (Maybe Block, [Block])
_Slide = prism' (uncurry Slide) (\(Slide h b) -> Just (h, b))
-- | Attributes of a slide are those of the header
-- | Attributes of a slide are those of the header
instance HasAttr Slide where
attributes f (Slide (Just (Header n a s)) b) =
fmap (\a' -> Slide (Just (Header n a' s)) b) (f a)
attributes _ x = pure x
-- | Attributes of a list of blocks are those of the first block.
-- | Attributes of a list of blocks are those of the first block.
instance HasAttr [Block] where
attributes f (b:bs) =
attributes f (b : bs) =
fmap (\a' -> set attributes a' b : bs) (f (view attributes b))
attributes _ x = pure x
......@@ -66,32 +68,32 @@ toSlides blocks = map extractHeader $ filter (not . null) slideBlocks
where
slideBlocks =
split (keepDelimsL $ whenElt isSlideSeparator) $ killEmpties blocks
-- Deconstruct a list of blocks into a Slide
extractHeader (header@(Header 1 _ _):bs) = Slide (Just header) bs
extractHeader (HorizontalRule:bs) = extractHeader bs
-- Deconstruct a list of blocks into a Slide
extractHeader (header@(Header 1 _ _) : bs) = Slide (Just header) bs
extractHeader (HorizontalRule : bs) = extractHeader bs
extractHeader blocks = Slide Nothing blocks
-- Remove redundant slide markers
killEmpties (HorizontalRule:header@Header {}:blocks) =
-- Remove redundant slide markers
killEmpties (HorizontalRule : header@Header {} : blocks) =
header : killEmpties blocks
killEmpties (b:bs) = b : killEmpties bs
killEmpties (b : bs) = b : killEmpties bs
killEmpties [] = []
-- Render slides as a list of Blocks. Always separate slides with a horizontal
-- rule. Slides with the `notes` classes are wrapped in ASIDE and are used as
-- spreaker notes by RevalJs.
-- speaker notes by Reval. Slides with no header get an empty header prepended.
fromSlides :: [Slide] -> [Block]
fromSlides = concatMap prependHeader
where
prependHeader (Slide (Just header) body)
| hasClass "notes" header =
[RawBlock "html" "<aside class=\"notes\">"] ++
demoteHeaders (header : body) ++
[RawBlock "html" "</aside>"]
[RawBlock "html" "<aside class=\"notes\">"]
++ demoteHeaders (header : body)
++ [RawBlock "html" "</aside>"]
prependHeader (Slide (Just header) body) = HorizontalRule : header : body
prependHeader (Slide Nothing body) = HorizontalRule : body
prependHeader (Slide Nothing body) = HorizontalRule : Header 1 nullAttr [] : body
-- | Converts slides to lists of blocks that are wrapped in divs. Used to
-- control page breaks in handout generation.
-- |  Converts slides to lists of blocks that are wrapped in divs. Used to
-- control page breaks in handout generation.
fromSlidesWrapped :: [Slide] -> [Block]
fromSlidesWrapped = concatMap wrapBlocks
where
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment