From 94c88cebf139c6dea27e2cdf62b59b02a8ea3501 Mon Sep 17 00:00:00 2001 From: Stefan Dresselhaus Date: Tue, 25 Jul 2017 13:52:48 +0200 Subject: [PATCH] implemented quiz, tooltips not working atm. --- app/Clean.hs | 21 ++++++++ app/Quiz.hs | 102 +++++++++++--------------------------- pandoc-slide-filter.cabal | 8 +++ 3 files changed, 58 insertions(+), 73 deletions(-) create mode 100644 app/Clean.hs diff --git a/app/Clean.hs b/app/Clean.hs new file mode 100644 index 0000000..fcb5f71 --- /dev/null +++ b/app/Clean.hs @@ -0,0 +1,21 @@ +#!/usr/bin/env runhaskell +{-# LANGUAGE ScopedTypeVariables #-} + +import Text.Pandoc.JSON +import Control.Exception +import Data.Monoid ((<>)) +import Data.List (partition, isInfixOf) + +main :: IO () +main = toJSONFilter clean + +clean :: Block -> [Block] +clean (Plain []) = [] +clean (Para []) = [] +clean (LineBlock []) = [] +clean (BlockQuote []) = [] +clean (OrderedList _ []) = [] +clean (BulletList []) = [] +clean (DefinitionList []) = [] +clean x = [x] + diff --git a/app/Quiz.hs b/app/Quiz.hs index e2a71c8..c4687bb 100644 --- a/app/Quiz.hs +++ b/app/Quiz.hs @@ -2,90 +2,46 @@ {-# LANGUAGE ScopedTypeVariables #-} import Text.Pandoc.JSON +import Text.Pandoc.Walk import Control.Exception import Data.Monoid ((<>)) import Data.List (partition) main :: IO () -main = toJSONFilter media +main = toJSONFilter quizLift -media :: Inline -> IO [Inline] -media (Image ("audio",att,att') [] (filename,_)) = return $ [toHtml $ ""] - where - (direct, css) = classToPlain att -media (Image ("audio",att,att') alt (filename,_)) = return $ [toHtml $ "
"] - ++ [toHtml $ "
"] - ++ alt - ++ [toHtml $ "
"] - where - (direct, css) = classToPlain att ---no description of video -media (Image ("video", att, att') [] (filename,_)) = return $ [toHtml $ ""] - where - (direct, css) = classToPlain att ---with description of video -media (Image ("video", att, att') alt (filename,_)) = return $ [toHtml $ "
"] - ++ [toHtml $ ""] - ++ [toHtml $ "
"] - ++ alt - ++ [toHtml $ "
"] - where - (direct, css) = classToPlain att ---no description of image -media (Image ("img", att, att') [] (filename,_)) = return $ [toHtml $ "
"] - ++ [toHtml $ " unwords direct <> " src=\"" <> filename <> "\"" <> attToString ("",css,att') <> ">"] - ++ [toHtml $ "
"] - where - (direct, css) = classToPlain att ---with description of image -media (Image ("img", att, att') alt (filename,_)) = return $ [toHtml $ "
"] - ++ [toHtml $ " unwords direct <> " src=\"" <> filename <> "\"" <> attToString ("",css,att') <> ">"] - ++ [toHtml $ "
"] - ++ alt - ++ [toHtml $ "
"] - where - (direct, css) = classToPlain att -media (Image ("svg", att, att') [] (filename,_)) = handle (\(fileerror :: IOException) -> return [toHtml $ "Could not read file: " <> filename <> "
" <> show fileerror]) $ - do - svg <- readFile filename - return $ [toHtml $ "
unwords direct <> " " <> attToString ("", css, att') <> ">"] -- use attributes on figure, as svg gets dumped in.. - ++ [toHtml $ svg] - ++ [toHtml $ "
"] - where - (direct, css) = classToPlain att -media (Image ("svg", att, att') alt (filename,_)) = handle (\(fileerror :: IOException) -> return $ [toHtml $ "Could not read file: " <> filename <> "
" <> show filename]) $ - do - svg <- readFile filename - return $ [toHtml $ "
unwords direct <> " " <> attToString ("", css, att') <> ">"] -- use attributes on figure, as svg gets dumped in.. - ++ [toHtml $ svg] - ++ [toHtml $ "
"] - ++ alt - ++ [toHtml $ "
"] - where - (direct, css) = classToPlain att -media (Image ("demo", att, att') [] (filename,_)) = return $ [toHtml $ ""] - where - (direct, css) = classToPlain att -media (Image ("demo", att, att') alt (filename,_)) = return $ [toHtml $ "
"] - ++ [toHtml $ ""] - ++ [toHtml $ "
"] - ++ alt - ++ [toHtml $ "
"] - where - (direct, css) = classToPlain att +quizLift :: Block -> [Block] +quizLift pb@(Plain b) = fmap makeQuiz (query findQuiz pb) ++ [Plain (filter ((==) [] . findQuiz) b)] +quizLift pb@(Para b) = fmap makeQuiz (query findQuiz pb) ++ [Plain (filter ((==) [] . findQuiz) b)] +quizLift x = [x] -media x = return [x] + +findQuiz :: Inline -> [(Attr, [Inline], Maybe [Inline])] +findQuiz (Span attributes@(id, att, att') answerText) + | "answer" `elem` att = [(attributes, answerText, Nothing)] +findQuiz (Link attributes@(id, att, att') answerText (tooltip,_)) + | "answer" `elem` att = [(attributes, answerText, Just [toHtml tooltip])] +findQuiz x = [] + +makeQuiz :: (Attr, [Inline], Maybe [Inline]) -> Block +makeQuiz (att, answer, Nothing) = Div att [Plain answer] +makeQuiz (att, answer, Just tooltip) = Div att [Plain answer, Div ("",["tooltip"],[]) [Plain tooltip]] + +-- quiz :: Inline -> [Inline] +-- quiz (Span attributes@(id, att, att') answerText) +-- | "answer" `elem` att = [toHtml $ "
attToString attributes <> ">"] +-- ++ answerText +-- ++ [toHtml $ "
"] +-- quiz (Link attributes@(id, att, att') answerText (tooltip,_)) +-- | "answer" `elem` att = [toHtml $ "
attToString attributes <> ">"] +-- ++ answerText +-- ++ [toHtml $ "
" <> tooltip <> "
"] +-- ++ [toHtml $ "
"] +-- quiz x = [x] attToString :: Attr -> String attToString (ident, classes, kvpairs) = ident <> " class=\"" <> unwords classes <> "\" " <> unwords ((\(k,v) -> k <> "=\"" <> v <> "\"") <$> kvpairs) -classToPlain :: [String] -> ([String],[String]) -classToPlain = partition (`elem` [ "data-autoplay" - , "controls" - ] - ) - toHtml :: String -> Inline toHtml = RawInline (Format "html") diff --git a/pandoc-slide-filter.cabal b/pandoc-slide-filter.cabal index 108db18..b9f0a90 100644 --- a/pandoc-slide-filter.cabal +++ b/pandoc-slide-filter.cabal @@ -37,6 +37,14 @@ executable quiz , pandoc-types default-language: Haskell2010 +executable clean + hs-source-dirs: app + main-is: Clean.hs + ghc-options: -threaded -rtsopts -with-rtsopts=-N + build-depends: base + , pandoc-types + default-language: Haskell2010 + source-repository head type: git location: https://github.com/Drezil/pandoc-slide-filter