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

Add CI check for proper formatting

parent 92314851
......@@ -4,4 +4,8 @@ before_script:
test:
script:
- stack test
\ No newline at end of file
- stack test
formatting:
script:
bin/check-formatting.sh
\ No newline at end of file
......@@ -10,6 +10,7 @@ import Data.Yaml.Pretty
import Development.Shake
import Development.Shake.FilePath
import Embed
import Project
import System.Directory
import System.Exit
import System.FilePath ()
......@@ -18,7 +19,6 @@ import qualified Text.Mustache as M ()
import Text.Pandoc ()
import Text.Printf ()
import Utilities
import Project
version = "0.1.0"
......
#!/bin/sh
# Author: Henrik Tramberend <henrik@tramberend.de>
for f in **/*.hs; do
cat $f | hindent | diff -q - $f || exit
done
\ No newline at end of file
{-- Author: Henrik Tramberend <henrik@tramberend.de> --}
{-- Author: Henrik Tramberend <henrik@tramberend.de> --}
module Common
( DeckerException(..)
) where
......
{-- Author: Henrik Tramberend <henrik@tramberend.de> --}
{-- Author: Henrik Tramberend <henrik@tramberend.de> --}
{-# LANGUAGE DeriveDataTypeable #-}
module Context
(ActionContext(..), makeActionContext, setActionContext, getFilesToWatch,
setFilesToWatch, getServerHandle, setServerHandle, getProjectDirs,
actionContextKey, getActionContext)
where
( ActionContext(..)
, makeActionContext
, setActionContext
, getFilesToWatch
, setFilesToWatch
, getServerHandle
, setServerHandle
, getProjectDirs
, actionContextKey
, getActionContext
) where
import Control.Monad ()
import Development.Shake
import Data.Dynamic
import Data.Maybe ()
import qualified Data.HashMap.Lazy as HashMap
import Data.IORef
import Data.Maybe ()
import Data.Typeable ()
import qualified Data.HashMap.Lazy as HashMap
import System.Process
import Development.Shake
import Project
import System.Process
data ActionContext =
ActionContext {ctxFilesToWatch :: IORef [FilePath]
,ctxServerHandle :: IORef (Maybe ProcessHandle)
,ctxDirs :: ProjectDirs}
deriving (Typeable, Show)
data ActionContext = ActionContext
{ ctxFilesToWatch :: IORef [FilePath]
, ctxServerHandle :: IORef (Maybe ProcessHandle)
, ctxDirs :: ProjectDirs
} deriving (Typeable, Show)
instance Show (IORef a) where
show _ = "IORef"
......@@ -39,28 +45,29 @@ actionContextKey = do
return $ typeOf ctx
makeActionContext :: ProjectDirs -> IO ActionContext
makeActionContext dirs =
do ctx <- defaultActionContext
return $
ctx { ctxDirs = dirs }
makeActionContext dirs = do
ctx <- defaultActionContext
return $ ctx {ctxDirs = dirs}
setActionContext :: ActionContext -> ShakeOptions -> IO ShakeOptions
setActionContext ctx options =
do key <- liftIO $ actionContextKey
let extra = HashMap.insert key (toDyn ctx) $ HashMap.empty
return options {shakeExtra = extra}
setActionContext ctx options = do
key <- liftIO $ actionContextKey
let extra = HashMap.insert key (toDyn ctx) $ HashMap.empty
return options {shakeExtra = extra}
getActionContext :: Action ActionContext
getActionContext = do
options <- getShakeOptions
key <- liftIO $ actionContextKey
let extra = shakeExtra options
let dyn = case HashMap.lookup key extra of
Just d -> d
Nothing -> error "Error looking up action context"
return $ case fromDynamic dyn of
Just d -> d
Nothing -> error "Error upcasting action context"
let dyn =
case HashMap.lookup key extra of
Just d -> d
Nothing -> error "Error looking up action context"
return $
case fromDynamic dyn of
Just d -> d
Nothing -> error "Error upcasting action context"
getFilesToWatch :: Action [FilePath]
getFilesToWatch = do
......@@ -83,7 +90,6 @@ setServerHandle handle = do
liftIO $ writeIORef (ctxServerHandle ctx) handle
getProjectDirs :: Action ProjectDirs
getProjectDirs =
do ctx <- getActionContext
return $ ctxDirs ctx
getProjectDirs = do
ctx <- getActionContext
return $ ctxDirs ctx
{-- Author: Henrik Tramberend <henrik@tramberend.de> --}
{-- Author: Henrik Tramberend <henrik@tramberend.de> --}
{-# LANGUAGE TemplateHaskell #-}
module Embed
......@@ -62,8 +61,10 @@ testerMultipleChoiceTemplate =
testerMultipleAnswersTemplate =
fromJust $ defaultTemplate "ma-quest-catalog-template.md"
testerFillTextTemplate = fromJust $ defaultTemplate "ft-quest-catalog-template.md"
testerFillTextTemplate =
fromJust $ defaultTemplate "ft-quest-catalog-template.md"
testerFreeFormTemplate = fromJust $ defaultTemplate "ff-quest-catalog-template.md"
testerFreeFormTemplate =
fromJust $ defaultTemplate "ff-quest-catalog-template.md"
testLatexTemplate = fromJust $ defaultTemplate "test.tex"
{-- Author: Henrik Tramberend <henrik@tramberend.de> --}
{-- Author: Henrik Tramberend <henrik@tramberend.de> --}
{-# LANGUAGE OverloadedStrings #-}
module Filter
(expandMacros, makeSlides, filterNotes, useCachedImages,
escapeToFilePath, cachePandocImages, extractLocalImagePathes)
where
( expandMacros
, makeSlides
, filterNotes
, useCachedImages
, escapeToFilePath
, cachePandocImages
, extractLocalImagePathes
) where
import qualified Data.ByteString.Char8 as B
import qualified Data.ByteString.Lazy as LB
import qualified Data.ByteString.Lazy.Char8 as L8
import Data.Default ()
import Data.List.Split
import qualified Data.Map as Map (Map, fromList, lookup)
import Data.Maybe
import Debug.Trace
import Network.HTTP.Conduit
import Network.HTTP.Simple
import Network.URI
import System.Directory
import System.FilePath
import Text.Blaze (customAttribute)
import Text.Blaze.Html.Renderer.String
import Text.Blaze.Html5 as H (div, figure, iframe, p, toValue, (!))
......@@ -22,14 +34,6 @@ import Text.Pandoc.JSON
import Text.Pandoc.Walk
import Text.Printf
import Text.Read
import System.Directory
import System.FilePath
import qualified Data.ByteString.Char8 as B
import qualified Data.ByteString.Lazy as LB
import qualified Data.ByteString.Lazy.Char8 as L8
import Network.HTTP.Conduit
import Network.HTTP.Simple
import Network.URI
type MacroFunc = [String] -> Attr -> Target -> Format -> Meta -> Inline
......@@ -38,87 +42,86 @@ type MacroFunc = [String] -> Attr -> Target -> Format -> Meta -> Inline
-- YouTube links: iv_load_policy=3 disables annotations, rel=0 disables related
-- videos. See:
-- https://developers.google.com/youtube/player_parameters?hl=de#IFrame_Player_API
embedYoutubeHtml
:: [String] -> Attr -> Target -> Inline
embedYoutubeHtml args attr (vid,_) =
RawInline (Format "html")
(renderHtml html)
where url =
printf "https://www.youtube.com/embed/%s?iv_load_policy=3&disablekb=1&rel=0&modestbranding=1&autohide=1"
vid :: String
vidWidthStr = macroArg 0 args "560"
vidHeightStr = macroArg 1 args "315"
vidWidth = readDefault 560.0 vidWidthStr :: Float
vidHeight = readDefault 315.0 vidHeightStr :: Float
wrapperStyle =
printf "position:relative;padding-top:25px;padding-bottom:%f%%;height:0;"
(vidHeight / vidWidth * 100.0) :: String
iframeStyle =
"position:absolute;top:0;left:0;width:100%;height:100%;" :: String
figureStyle (_,_,kv) =
foldl (\s (k,v) -> s ++ printf "%s:%s;" k v :: String) "" kv
figureClass (_,cls,_) = unwords cls
html =
H.figure ! class_ (toValue (figureClass attr)) !
style (toValue (figureStyle attr)) $
H.div ! style (toValue wrapperStyle) $
iframe ! style (toValue iframeStyle) ! width (toValue vidWidthStr) !
height (toValue vidHeightStr) !
src (toValue url) !
customAttribute "frameborder" "0" !
customAttribute "allowfullscreen" "" $
p ""
embedYoutubeHtml :: [String] -> Attr -> Target -> Inline
embedYoutubeHtml args attr (vid, _) =
RawInline (Format "html") (renderHtml html)
where
url =
printf
"https://www.youtube.com/embed/%s?iv_load_policy=3&disablekb=1&rel=0&modestbranding=1&autohide=1"
vid :: String
vidWidthStr = macroArg 0 args "560"
vidHeightStr = macroArg 1 args "315"
vidWidth = readDefault 560.0 vidWidthStr :: Float
vidHeight = readDefault 315.0 vidHeightStr :: Float
wrapperStyle =
printf
"position:relative;padding-top:25px;padding-bottom:%f%%;height:0;"
(vidHeight / vidWidth * 100.0) :: String
iframeStyle =
"position:absolute;top:0;left:0;width:100%;height:100%;" :: String
figureStyle (_, _, kv) =
foldl (\s (k, v) -> s ++ printf "%s:%s;" k v :: String) "" kv
figureClass (_, cls, _) = unwords cls
html =
H.figure ! class_ (toValue (figureClass attr)) !
style (toValue (figureStyle attr)) $
H.div ! style (toValue wrapperStyle) $
iframe ! style (toValue iframeStyle) ! width (toValue vidWidthStr) !
height (toValue vidHeightStr) !
src (toValue url) !
customAttribute "frameborder" "0" !
customAttribute "allowfullscreen" "" $
p ""
youtube :: MacroFunc
youtube args attr target (Format f) _
| f `elem` ["html","html5","revealjs"] = embedYoutubeHtml args attr target
youtube _ attr (vid,_) _ _ =
Link nullAttr
[Image attr
[Str text]
(imageUrl,"")]
(videoUrl,"")
where videoUrl =
printf "https://www.youtube.com/embed/%s?iv_load_policy=3&disablekb=0&rel=0&modestbranding=1&autohide=1"
vid :: String
imageUrl =
printf "http://img.youtube.com/vi/%s/maxresdefault.jpg" vid :: String
text = printf "YouTube: %s" vid :: String
| f `elem` ["html", "html5", "revealjs"] = embedYoutubeHtml args attr target
youtube _ attr (vid, _) _ _ =
Link nullAttr [Image attr [Str text] (imageUrl, "")] (videoUrl, "")
where
videoUrl =
printf
"https://www.youtube.com/embed/%s?iv_load_policy=3&disablekb=0&rel=0&modestbranding=1&autohide=1"
vid :: String
imageUrl =
printf "http://img.youtube.com/vi/%s/maxresdefault.jpg" vid :: String
text = printf "YouTube: %s" vid :: String
fontAwesome :: MacroFunc
fontAwesome _ _ (iconName,_) (Format f) _
| f `elem` ["html","html5","revealjs"] =
fontAwesome _ _ (iconName, _) (Format f) _
| f `elem` ["html", "html5", "revealjs"] =
RawInline (Format "html") $ "<i class=\"fa fa-" ++ iconName ++ "\"></i>"
fontAwesome _ _ (iconName,_) _ _ = Str $ "[" ++ iconName ++ "]"
fontAwesome _ _ (iconName, _) _ _ = Str $ "[" ++ iconName ++ "]"
metaValue :: MacroFunc
metaValue _ _ (key,_) _ meta =
metaValue _ _ (key, _) _ meta =
case splitOn "." key of
[] -> Str key
k:ks -> lookup' ks (lookupMeta k meta)
where lookup'
:: [String] -> Maybe MetaValue -> Inline
lookup' [] (Just (MetaString s)) = Str s
lookup' [] (Just (MetaInlines i)) = Span nullAttr i
lookup' (k:ks) (Just (MetaMap metaMap)) =
lookup' ks (Map.lookup k metaMap)
lookup' _ _ = Strikeout [Str key]
where
lookup' :: [String] -> Maybe MetaValue -> Inline
lookup' [] (Just (MetaString s)) = Str s
lookup' [] (Just (MetaInlines i)) = Span nullAttr i
lookup' (k:ks) (Just (MetaMap metaMap)) = lookup' ks (Map.lookup k metaMap)
lookup' _ _ = Strikeout [Str key]
type MacroMap = Map.Map String MacroFunc
macroMap :: MacroMap
macroMap =
Map.fromList [("meta",metaValue),("youtube",youtube),("fa",fontAwesome)]
Map.fromList [("meta", metaValue), ("youtube", youtube), ("fa", fontAwesome)]
readDefault :: Read a
=> a -> String -> a
readDefault
:: Read a
=> a -> String -> a
readDefault default_ string = fromMaybe default_ (readMaybe string)
macroArg :: Int -> [String] -> String -> String
macroArg n args default_ =
if length args > n
then args !! n
else default_
then args !! n
else default_
parseMacro :: String -> Maybe [String]
parseMacro (pre:invocation)
......@@ -127,24 +130,22 @@ parseMacro _ = Nothing
onlyStrings :: [Inline] -> [String]
onlyStrings = reverse . foldl only []
where only ss (Str s) = s : ss
only ss _ = ss
where
only ss (Str s) = s : ss
only ss _ = ss
expand
:: Inline -> Format -> Meta -> Maybe Inline
expand :: Inline -> Format -> Meta -> Maybe Inline
expand (Link attr text target) format meta =
expand_ attr text target format meta
expand x _ _ = Just x
expand_
:: Attr -> [Inline] -> Target -> Format -> Meta -> Maybe Inline
expand_ attr text target format meta =
do name:args <- (parseMacro . unwords . onlyStrings) text
func <- Map.lookup name macroMap
return (func args attr target format meta)
expand_ :: Attr -> [Inline] -> Target -> Format -> Meta -> Maybe Inline
expand_ attr text target format meta = do
name:args <- (parseMacro . unwords . onlyStrings) text
func <- Map.lookup name macroMap
return (func args attr target format meta)
expandInlineMacros
:: Format -> Meta -> Inline -> Inline
expandInlineMacros :: Format -> Meta -> Inline -> Inline
expandInlineMacros format meta inline =
fromMaybe inline (expand inline format meta)
......@@ -169,7 +170,7 @@ isColumnBreak HorizontalRule = True
isColumnBreak _ = False
columnClass :: Attr
columnClass = ("",["column"],[])
columnClass = ("", ["column"], [])
-- Splits the body of a slide into any number of columns.
splitColumns :: [Block] -> [Block]
......@@ -177,64 +178,71 @@ splitColumns slide@(header:body) =
let columns = splitWhen isColumnBreak body
count = length columns
in if count > 1
then header :
concatMap (\(column,n) ->
[Div (""
,["slide-column"
,printf "column-%d" n
,printf "columns-%d" count]
,[])
column])
(Prelude.zip columns
[(1 :: Int) ..])
else slide
then header :
concatMap
(\(column, n) ->
[ Div
( ""
, [ "slide-column"
, printf "column-%d" n
, printf "columns-%d" count
]
, [])
column
])
(Prelude.zip columns [(1 :: Int) ..])
else slide
splitColumns [] = []
-- All fragment related classes from reveal.js have to be moved to the enclosing
-- DIV element. Otherwise to many fragments are produced.fragmentRelated :: [String]
fragmentRelated =
["fragment"
,"grow"
,"shrink"
,"roll-in"
,"fade-in"
,"fade-out"
,"current-visible"
,"highlight-current-blue"
,"highlight-red"
,"highlight-green"
,"highlight-blu"]
[ "fragment"
, "grow"
, "shrink"
, "roll-in"
, "fade-in"
, "fade-out"
, "current-visible"
, "highlight-current-blue"
, "highlight-red"
, "highlight-green"
, "highlight-blu"
]
deFragment :: [String] -> [String]
deFragment = filter (`notElem` fragmentRelated)
wrapBoxes :: [Block] -> [Block]
wrapBoxes (header:body) = header : concatMap wrap boxes
where boxes = split (keepDelimsL $ whenElt isBoxDelim) body
wrap (Header 2 (id_,cls,kvs) text:blocks) =
[Div (id_ ++ "-box","box" : cls,[])
(Header 2 (id_,deFragment cls,kvs) text : blocks)]
wrap box = box
where
boxes = split (keepDelimsL $ whenElt isBoxDelim) body
wrap (Header 2 (id_, cls, kvs) text:blocks) =
[ Div
(id_ ++ "-box", "box" : cls, [])
(Header 2 (id_, deFragment cls, kvs) text : blocks)
]
wrap box = box
wrapBoxes [] = []
-- Wrap headers with class notes into a DIV and promote all header attributes
-- to the DIV.
wrapNoteRevealjs :: [Block] -> [Block]
wrapNoteRevealjs slide@(Header 1 (id_,cls,kvs) inlines:body)
| "notes" `elem` cls = [Div (id_,cls,kvs) slide]
wrapNoteRevealjs slide@(Header 1 (id_, cls, kvs) inlines:body)
| "notes" `elem` cls = [Div (id_, cls, kvs) slide]
wrapNoteRevealjs slide = slide
-- Wrap headers with class notes into a DIV and promote all header attributes
-- to the DIV.
wrapNoteBeamer :: [Block] -> [Block]
wrapNoteBeamer slide@(Header 1 (_,cls,_) _:_)
wrapNoteBeamer slide@(Header 1 (_, cls, _) _:_)
| "notes" `elem` cls = [Div nullAttr slide]
wrapNoteBeamer slide = slide
mapSlides
:: ([Block] -> [Block]) -> Pandoc -> Pandoc
mapSlides :: ([Block] -> [Block]) -> Pandoc -> Pandoc
mapSlides func (Pandoc meta blocks) = Pandoc meta (concatMap func slides)
where slides = split (keepDelimsL $ whenElt isSlideHeader) blocks
where
slides = split (keepDelimsL $ whenElt isSlideHeader) blocks
makeSlides :: Maybe Format -> Pandoc -> Pandoc
makeSlides (Just (Format "revealjs")) =
......@@ -248,13 +256,14 @@ makeSlides _ = id
-- Only consider slides that have the 'notes' class in their header. In all
-- others pick only the boxes that are tagged as notes.
filterSlides :: [Block] -> [Block]
filterSlides slide@(Header 1 (_,cls,_) _:_)
filterSlides slide@(Header 1 (_, cls, _) _:_)
| "notes" `elem` cls = slide
filterSlides (_:body) = concatMap filter boxes
where boxes = split (keepDelimsL $ whenElt isBoxDelim) body
filter box@(Header _ (_,cls,_) _:_)
| "notes" `elem` cls = box
filter _ = []
where
boxes = split (keepDelimsL $ whenElt isBoxDelim) body
filter box@(Header _ (_, cls, _) _:_)
| "notes" `elem` cls = box
filter _ = []
filterSlides _ = []
filterNotes :: Maybe Format -> Pandoc -> Pandoc
......@@ -263,54 +272,52 @@ filterNotes _ = id
escapeToFilePath :: String -> FilePath
escapeToFilePath = map repl
where repl c =
if c `elem` [':','!','/']
then '|'
else c
where
repl c =
if c `elem` [':', '!', '/']
then '|'
else c
useCachedImages :: FilePath -> Inline -> IO Inline
useCachedImages cacheDir img@(Image (ident,cls,values) inlines (url,title)) =
do let cached = cacheDir </> escapeToFilePath url
exists <- doesFileExist cached
if exists
then return (Image (ident,"cached" : cls,values)
inlines
(cached,title))
else return img
useCachedImages cacheDir img@(Image (ident, cls, values) inlines (url, title)) = do
let cached = cacheDir </> escapeToFilePath url
exists <- doesFileExist cached
if exists
then return (Image (ident, "cached" : cls, values) inlines (cached, title))
else return img
useCachedImages _ inline = return inline
localImagePath :: Inline -> [FilePath]
localImagePath (Image _ _ (url, _)) = if isHttpUri url then [] else [url]
localImagePath (Image _ _ (url, _)) =
if isHttpUri url
then []
else [url]
localImagePath _ = []
extractLocalImagePathes :: Pandoc -> [FilePath]
extractLocalImagePathes pandoc =
Text.Pandoc.Walk.query localImagePath pandoc
extractLocalImagePathes pandoc = Text.Pandoc.Walk.query localImagePath pandoc
isHttpUri :: String -> Bool
isHttpUri url =
case parseURI url of
Just uri -> uriScheme uri `elem` ["http:","https:"]
Just uri -> uriScheme uri `elem` ["http:", "https:"]
Nothing -> False
cachePandocImages
:: FilePath -> Inline -> IO Inline
cachePandocImages base img@(Image _ _ (url,_))
| isHttpUri url =
do cacheImageIO url base
return img
cachePandocImages :: FilePath -> Inline -> IO Inline
cachePandocImages base img@(Image _ _ (url, _))
| isHttpUri url = do
cacheImageIO url base
return img
| otherwise = return img
cachePandocImages _ inline = return inline
-- | Download the image behind the URI and save it locally. Return the path of
-- the cached file relative to the base directory.
cacheImageIO
:: String -> FilePath -> IO ()
cacheImageIO uri cacheDir =
do request <- parseRequest uri
result <- httpLBS request
let body = getResponseBody result
let cacheFile = cacheDir </> escapeToFilePath uri
createDirectoryIfMissing True cacheDir
L8.writeFile cacheFile body
cacheImageIO :: String -> FilePath -> IO ()
cacheImageIO uri cacheDir = do
request <- parseRequest uri
result <- httpLBS request
let body = getResponseBody result
let cacheFile = cacheDir </> escapeToFilePath uri
createDirectoryIfMissing True cacheDir
L8.writeFile cacheFile body