Commit 2fb012d6 authored by Henrik Tramberend's avatar Henrik Tramberend
Browse files

Merge branch 'master' into mario

parents 17190c2b 342d7adf
......@@ -21,6 +21,7 @@ decker.cabal
dist/
node_modules
public/
private/
resource/support/vendor/**
stack.yaml.lock
test/decks/*.svg
......@@ -19,7 +19,9 @@ import NeatInterpolation
import qualified System.Directory as Dir
import System.FilePath.Posix
import System.IO
import Text.Decker.Exam.Question
import Text.Decker.Exam.Render
import Text.Decker.Exam.Xml
import Text.Decker.Internal.Common
import Text.Decker.Internal.External
import Text.Decker.Internal.Helper
......@@ -231,15 +233,22 @@ run = do
meta <- getGlobalMeta
renderQuestion meta src out
--
publicDir <//> "quest-catalog.html" %> \out -> do
privateDir <//> "quest-catalog.html" %> \out -> do
meta <- getGlobalMeta
targets <- getTargets
sources <- mapM (calcSource "-quest.html" "-quest.yaml") (targets ^. questions)
need sources
liftIO $ print sources
renderCatalog meta sources out
--
privateDir <//> "quest-catalog.xml" %> \out -> do
targets <- getTargets
sources <- mapM (calcSource "-quest.html" "-quest.yaml") (targets ^. questions)
need sources
questions <- liftIO $ mapM readQuestion sources
renderXmlCatalog questions out
phony "catalogs" $ do
need ["public/quest-catalog.html"]
need ["private/quest-catalog.html", "private/quest-catalog.xml"]
--
indexFile %> \out -> do
exists <- liftIO $ Dir.doesFileExist indexSource
......
......@@ -26,10 +26,27 @@ div.exa-quest textarea {
.reveal div.exa-quest {
overflow-y: scroll;
overflow-x: scroll;
overflow-x: auto;
max-height: 600px;
}
.reveal div.exa-quest::-webkit-scrollbar {
width: 9px;
}
.reveal div.exa-quest::-webkit-scrollbar-track {
-webkit-border-radius: 5px;
border-radius: 5px;
background: rgba(0, 0, 0, 0.1);
}
.reveal div.exa-quest::-webkit-scrollbar-thumb {
-webkit-border-radius: 5px;
border-radius: 5px;
background: rgba(0, 0, 0, 0.2);
}
.reveal div.exa-quest::-webkit-scrollbar-thumb:hover {
background: rgba(0, 0, 0, 0.4);
}
.handout div.exa-quest {
padding: 1em;
border: solid 1px lightgray;
......
......@@ -97,6 +97,22 @@ renderQuestion meta base qst =
]
]
]
renderAnswer (Numerical answer) =
[ Div
("", ["answer", "exa-nu"], [])
[ rawHtml' $
H.textarea ! A.class_ "answer"
! A.placeholder (toValue $ lookupInDictionary "exam.placeholder" meta)
! A.rows "1"
$ "",
Div
("", ["solution"], [])
[ rawHtml' $
H.h3 (toHtml $ lookupInDictionary "exam.solution" meta),
Div ("", ["correct"], []) $ parseToBlocks base (show answer)
]
]
]
-- For now, use OS drop-downs. Later maybe use
-- https://github.com/vorotina/vanilla-select.
renderAnswer (MultipleAnswers width answers) =
......
......@@ -15,8 +15,8 @@ import Data.Typeable
import qualified Data.Yaml as Y
import GHC.Generics hiding (Meta)
import Relude
import Text.Decker.Internal.Meta
import System.Directory
import Text.Decker.Internal.Meta
data Choice = Choice
{ _choiceTheAnswer :: Text,
......@@ -44,6 +44,9 @@ data Answer
{ _answHeightInMm :: Int,
_answCorrectAnswer :: Text
}
| Numerical
{ _answCorrectNumber :: Float
}
| MultipleAnswers
{ _answWidthInMm :: Int,
_answAnswers :: [OneAnswer]
......
......@@ -11,6 +11,7 @@ module Text.Decker.Exam.Render
( renderQuestion,
renderCatalog,
renderQuestionToHtml,
compileQuestionToHtml,
)
where
......@@ -39,25 +40,21 @@ import Text.Pandoc.Walk
compileQuestionToHtml :: Meta -> FilePath -> Question -> Action Question
compileQuestionToHtml meta base quest = do
let render = renderSnippetToHtml meta base
traverseOf qstTitle render
=<< traverseOf qstQuestion render
=<< traverseOf qstAnswer (compileAnswerToHtml meta base) quest
compileAnswerToHtml :: Meta -> FilePath -> Answer -> Action Answer
compileAnswerToHtml meta base mc@MultipleChoice {} = do
let render = renderSnippetToHtml meta base
traverseOf (answChoices . traverse . choiceTheAnswer) render mc
compileAnswerToHtml meta base ma@MultipleAnswers {} = do
let render = renderSnippetToHtml meta base
traverseOf (answAnswers . traverse . oneDetail) render
=<< traverseOf (answAnswers . traverse . oneDetail) render ma
compileAnswerToHtml meta base ff@FreeForm {} = do
let render = renderSnippetToHtml meta base
traverseOf answCorrectAnswer render ff
compileAnswerToHtml meta base ft@FillText {} = do
let render = renderSnippetToHtml meta base
traverseOf (answCorrectWords . traverse) render ft
where
render = renderSnippetToHtml meta base
compileAnswerToHtml :: Meta -> FilePath -> Answer -> Action Answer
compileAnswerToHtml meta base mc@MultipleChoice {} = do
traverseOf (answChoices . traverse . choiceTheAnswer) render mc
compileAnswerToHtml meta base ma@MultipleAnswers {} = do
traverseOf (answAnswers . traverse . oneDetail) render
=<< traverseOf (answAnswers . traverse . oneCorrect) render ma
compileAnswerToHtml meta base ff@FreeForm {} = return ff
compileAnswerToHtml meta base nu@Numerical {} = return nu
compileAnswerToHtml meta base ft@FillText {} = do
traverseOf (answCorrectWords . traverse) render ft
-- | Renders a Markdown snippet to HTML applying the full Decker media filter.
renderSnippetToHtml :: Meta -> FilePath -> Text -> Action Text
......
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DeriveTraversable #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE NoImplicitPrelude #-}
module Text.Decker.Exam.Xml
......@@ -10,58 +6,28 @@ module Text.Decker.Exam.Xml
)
where
import Relude
import Text.Decker.Internal.URI
import Text.Decker.Internal.Exception
import Text.Decker.Exam.Question
import Text.Decker.Exam.Render hiding (renderQuestion)
import Control.Exception
import Control.Monad
import Control.Monad.Loops
import Control.Lens hiding (Choice)
import qualified Data.ByteString as BS
import qualified Data.ByteString.Base64 as B64
import qualified Data.ByteString.Char8 as B
import qualified Data.ByteString.Lazy as LB
import qualified Data.ByteString.UTF8 as UTF8
import qualified Data.HashMap.Strict as Map
import Data.Hashable
import Data.IORef
import Data.List
import Data.List.Extra
import qualified Data.Map as M
import Data.Maybe
import qualified Data.Set as Set
import qualified Data.Text as T
import qualified Data.Text.Encoding as E
import qualified Data.Text.IO as T
import Data.Typeable
import Data.XML.Types (Content (..))
import qualified Data.Yaml as Y
import Data.Yaml.Pretty as Y
import Debug.Trace
import Development.Shake
import Development.Shake.FilePath
import Network.URI
import System.Directory
import System.Exit
import System.FilePath
import System.FilePath.Glob as Glob
import System.Process
import System.Random
import qualified Text.Mustache as M
import qualified Text.Mustache.Types as MT
import Relude
import Text.Decker.Exam.Question
import Text.Decker.Internal.Exception
import Text.Decker.Internal.URI
import Text.Pandoc
import Text.Pandoc.Highlighting
import Text.Pandoc.PDF
import Text.Pandoc.Walk
import Text.Printf
import qualified Text.XML as XML
-- Renders a catalog of all questions sorted by LectureId and TopicId.
renderXmlCatalog ::
FilePath -> [Question] -> FilePath -> Action ()
renderXmlCatalog projectDir questions out = do
rendered <- mapM (renderQuestion . insertTitle) questions
[Question] -> FilePath -> Action ()
renderXmlCatalog questions out = do
rendered <- mapM (renderMarkdownFields . insertTitle) questions
let sorted = sortQuestions rendered
nodes = concatMap renderXML sorted
quiz = XML.Element "quiz" M.empty nodes
......@@ -152,7 +118,6 @@ renderXmlCatalog projectDir questions out = do
++ renderAnswer (_qstAnswer question)
)
where
answer = renderAnswer (_qstAnswer question)
renderAnswer (MultipleChoice choices) =
map (renderChoice $ correctAnswers choices) choices
renderAnswer (FillText fillText correctWords) =
......@@ -169,6 +134,13 @@ renderXmlCatalog projectDir questions out = do
(M.fromList [("fraction", "0")])
[XML.NodeElement $ XML.Element "text" M.empty []]
]
renderAnswer (Numerical correctAnswer) =
[ XML.NodeElement $
XML.Element
"answer"
(M.fromList [("fraction", "0")])
[XML.NodeElement $ XML.Element "text" M.empty []]
]
renderAnswer (MultipleAnswers widthInMm answers) =
map renderSubQuestion answers
renderSubQuestion answer =
......@@ -226,9 +198,9 @@ xmlAnswerType q =
MultipleChoice choices -> "multichoice"
FillText fillText correctWords -> "essay"
FreeForm heightInMm correctAnswer -> "essay"
Numerical correctAnswer -> "numerical"
MultipleAnswers widthInMm answers -> "matching"
-- | Inserts the title into the question text.
insertTitle :: Question -> Question
insertTitle q =
......@@ -237,14 +209,27 @@ insertTitle q =
sortQuestions :: [Question] -> [Question]
sortQuestions =
sortBy
(\a b ->
case compare (_qstLectureId a) (_qstLectureId b) of
EQ -> compare (_qstTopicId a) (_qstTopicId b)
c -> c)
( \a b ->
case compare (_qstLectureId a) (_qstLectureId b) of
EQ -> compare (_qstTopicId a) (_qstTopicId b)
c -> c
)
renderQuestion :: Question -> Action Question
renderQuestion question =
mapM (renderHtml (takeDirectory $ _qstFilePath question)) question
renderMarkdownFields :: Question -> Action Question
renderMarkdownFields question = do
traverseOf qstTitle render question
>>= traverseOf qstQuestion render
>>= traverseOf qstAnswer renderAnswer
where
render = renderHtml (takeDirectory $ _qstFilePath question)
renderAnswer answer@MultipleChoice {} =
traverseOf (answChoices . each . choiceTheAnswer) render answer
renderAnswer answer@FillText {} = traverseOf answFillText render answer
renderAnswer answer@FreeForm {} = return answer
renderAnswer answer@Numerical {} = return answer
renderAnswer answer@MultipleAnswers {} =
traverseOf (answAnswers . each . oneDetail) render answer
>>= traverseOf (answAnswers . each . oneCorrect) render
embedImages :: FilePath -> Inline -> Action Inline
embedImages base (Image (id, cls, kv) inlines (url, title)) = do
......@@ -277,14 +262,13 @@ renderHtml base markdown =
readerOptions = def {readerExtensions = pandocExtensions}
writerOptions =
def
{ writerHTMLMathMethod = MathJax ""
, writerExtensions = pandocExtensions
, writerHighlightStyle = Nothing
{ writerHTMLMathMethod = MathJax "",
writerExtensions = pandocExtensions,
writerHighlightStyle = Nothing
}
parseMarkdown = runPure . readMarkdown readerOptions
renderHtml5 = runPure . writeHtml5String writerOptions
useCDATA :: Content -> Bool
useCDATA (ContentText txt) = False -- length (T.lines txt) > 1
useCDATA _ = False
-- useCDATA :: Content -> Bool
-- useCDATA (ContentText txt) = False -- length (T.lines txt) > 1
-- useCDATA _ = False
......@@ -76,6 +76,8 @@ projectDir = "."
publicDir = "public"
privateDir = "private"
supportDir = "public/support"
devSupportDir = "resource/support"
......
......@@ -6,69 +6,77 @@
--
-- Note that both 'Inline', 'Block', and 'MetaValue' have 'Plated' instances
-- which are useful for traversing the AST.
--
--
-- This file was taken out of https://github.com/bgamari/pandoc-lens.git at d7959c9.
-- The original repo does not seem to be maintained very actively and will not compile
-- with lts-13.3.
module Text.Pandoc.Lens
( -- * Documents
Pandoc
, body
, meta
-- * Blocks
-- | Prisms are provided for the constructors of 'Block'
-- as well as a 'Plated' instance.
, Block
, _Plain
, _Para
, _CodeBlock
, _BlockQuote
, _OrderedList
, _BulletList
, _DefinitionList
, _Header
, _HorizontalRule
, _Div
, _Null
-- * Inlines
-- | Prisms are provided for the constructors of 'Inline'
-- as well as a 'Plated' instance.
, Inline
, _Str
, _Emph
, _Strong
, _Strikeout
, _Superscript
, _Subscript
, _SmallCaps
, _Quoted
, _Cite
, _Code
, _Space
, _LineBreak
, _Math
, _RawInline
, _Link
, _Image
, _Note
, _Span
, inlinePrePlate
-- * Metadata
-- | Prisms are provided for the constructors of 'MetaValue'
-- as well as a 'Plated' instance.
, MetaValue
, _MetaMap
, _MetaList
, _MetaBool
, _MetaString
, _MetaInlines
, _MetaBlocks
-- * Attributes
, HasAttr(..)
, attrIdentifier
, attrClasses
, attrs
) where
( -- * Documents
Pandoc,
body,
meta,
-- * Blocks
-- | Prisms are provided for the constructors of 'Block'
-- as well as a 'Plated' instance.
Block,
_Plain,
_Para,
_CodeBlock,
_BlockQuote,
_OrderedList,
_BulletList,
_DefinitionList,
_Header,
_HorizontalRule,
_Div,
_Null,
-- * Inlines
-- | Prisms are provided for the constructors of 'Inline'
-- as well as a 'Plated' instance.
Inline,
_Str,
_Emph,
_Strong,
_Strikeout,
_Superscript,
_Subscript,
_SmallCaps,
_Quoted,
_Cite,
_Code,
_Space,
_LineBreak,
_Math,
_RawInline,
_Link,
_Image,
_Note,
_Span,
inlinePrePlate,
-- * Metadata
-- | Prisms are provided for the constructors of 'MetaValue'
-- as well as a 'Plated' instance.
MetaValue,
_MetaMap,
_MetaList,
_MetaBool,
_MetaString,
_MetaInlines,
_MetaBlocks,
-- * Attributes
HasAttr (..),
attrIdentifier,
attrClasses,
attrs,
)
where
import Control.Lens
import Data.Map (Map)
......@@ -160,8 +168,8 @@ _Header = prism' (\(a, b) -> Header a nullAttr b) f
_HorizontalRule :: Prism' Block ()
_HorizontalRule = prism' (const HorizontalRule) f
where
f HorizontalRule = Just ()
f _ = Nothing
f HorizontalRule = Just ()
f _ = Nothing
-- | A prism on a 'Div' 'Block'
_Div :: Prism' Block [Block]
......@@ -371,9 +379,8 @@ instance Plated MetaValue where
_ -> pure inl
-- | An object that has attributes
class HasAttr a
-- | A traversal over the attributes of an object
where
class HasAttr a where
-- | A traversal over the attributes of an object
attributes :: Traversal' a Attr
instance HasAttr Block 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