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

Remove more cruft

parent 69248f52
before_script:
- stack upgrade
build:
script:
- stack build
test:
script:
- stack test
\ No newline at end of file
indent-size: 2
line-length: 80
force-trailing-newline: true
\ No newline at end of file
[![build status](https://cgmgit.beuth-hochschule.de/teaching/decker/badges/master/build.svg)](https://cgmgit.beuth-hochschule.de/teaching/decker/commits/master)
# decker # decker
A markdown based tool for slide deck creation. A markdown based tool for slide deck creation.
...@@ -96,3 +98,9 @@ chmod a+x decker ...@@ -96,3 +98,9 @@ chmod a+x decker
- `decker publish` - `decker publish`
Publish the generated files to a remote location using `rsync` if the location is specified in the meta data. The keys `rsync-destination.host` and `rsync-destination.path` specify the publishing destination. Publish the generated files to a remote location using `rsync` if the location is specified in the meta data. The keys `rsync-destination.host` and `rsync-destination.path` specify the publishing destination.
## Contributions
### Pull requests
Contributions are accepted via pull requests. Before working on a feature, please write up an issue and discuss it with me.
\ No newline at end of file
{-- Author: Henrik Tramberend <henrik@tramberend.de> --}
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DeriveGeneric #-}
......
{-- Author: Henrik Tramberend <henrik@tramberend.de> --}
module Common module Common
( DeckerException(..) ( DeckerException(..)
) where ) where
......
{-- Author: Henrik Tramberend <henrik@tramberend.de> --}
{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveDataTypeable #-}
module Context module Context
......
{-- Author: Henrik Tramberend <henrik@tramberend.de> --}
{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TemplateHaskell #-}
module Embed module Embed
......
module Example where
{-- Author: Henrik Tramberend <henrik@tramberend.de> --}
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
module Filter module Filter
......
-- | Generally useful functions on pansoc data structures. Some in the IO monad. {-- Author: Henrik Tramberend <henrik@tramberend.de> --}
module Pandoc module Pandoc
( (
) where ) where
......
{-- Author: Henrik Tramberend <henrik@tramberend.de> --}
module Project module Project
( findResource ( findResource
, readResource , readResource
......
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, DeriveGeneric #-}
-- | Provides data types for the student information. Data is read from YAML files.
module Student
( Student(..)
, Students(..)
) where
import Control.Exception
import Data.Aeson.TH
import Data.Aeson.Types
import qualified Data.HashMap.Strict as Map
import Data.Hashable
import qualified Data.Text as T
import Data.Yaml
import GHC.Generics (Generic)
data Student = Student
{ std_displayName :: T.Text
, std_employeeNumber :: T.Text
, std_givenName :: T.Text
, std_mail :: T.Text
, std_sAMAccountName :: T.Text
, std_sn :: T.Text
, std_track :: Int
} deriving (Eq, Show, Generic)
instance Hashable Student
data Students = Students
{ stds_course :: T.Text
, stds_semester :: T.Text
, stds_students :: Map.HashMap T.Text Student
} deriving (Eq, Show)
-- Students (Map.HashMap T.Text Student)
$(deriveJSON defaultOptions {fieldLabelModifier = drop 4} ''Student)
$(deriveJSON defaultOptions {fieldLabelModifier = drop 5} ''Students)
{-# LANGUAGE TemplateHaskell, OverloadedStrings, DeriveGeneric #-}
module Test
( Question(..)
, Answer(..)
, Choice(..)
, OneAnswer(..)
, Difficulty(..)
, Exam(..)
, StudentExam(..)
, Templates
, compileTesterTemplates
, selectTemplate
) where
import Data.Aeson.TH
import Control.Exception
import Data.Yaml
import Data.Aeson.Types
import Data.Char
import Data.Maybe
import GHC.Generics
import qualified Data.Text as T
import qualified Data.Text.Encoding as E
import qualified Data.ByteString.Char8 as B
import Data.Typeable
import qualified Text.Mustache as M
import qualified Text.Mustache.Types as MT
import Embed
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)
data Choice = Choice
{ choiceTheAnswer :: T.Text
, choiceCorrect :: Bool
} deriving (Eq, Show, Typeable)
data OneAnswer = OneAnswer
{ oneDetail :: T.Text
, oneCorrect :: T.Text
} deriving (Eq, Show, Typeable)
data Answer
= MultipleChoice { answChoices :: [Choice]}
| FillText { answFillText :: T.Text
, answCorrectWords :: [T.Text]}
| FreeForm { answHeightInMm :: Int
, answCorrectAnswer :: T.Text}
| MultipleAnswers { answWidthInMm :: Int
, answAnswers :: [OneAnswer]}
deriving (Eq, Show, Typeable)
data Difficulty
= Easy
| Medium
| Hard
deriving (Eq, Show, Typeable)
data Exam = Exam
{ examTitle :: T.Text
, examModule :: T.Text
, examStudentInfoFile :: FilePath
, examDateTime :: T.Text
, examDurationInMinutes :: Int
, examNumberOfQuestions :: Int
, examTracks :: [Int]
, examLectureIds :: [T.Text]
, examExcludedTopicIds :: [T.Text]
} deriving (Eq, Show, Typeable)
data StudentExam = StudentExam
{ stdexExam :: Exam
, stdexStudent :: Student
}
$(deriveJSON
defaultOptions
{ fieldLabelModifier = drop 5
}
''StudentExam)
$(deriveJSON
defaultOptions
{ fieldLabelModifier = drop 6
}
''Choice)
$(deriveJSON
defaultOptions
{ fieldLabelModifier = drop 3
}
''OneAnswer)
$(deriveJSON
defaultOptions
{ fieldLabelModifier = drop 4
}
''Answer)
questionOptions =
defaultOptions
{ fieldLabelModifier = drop 3
}
instance ToJSON Question where
toJSON = genericToJSON questionOptions
toEncoding = genericToEncoding questionOptions
instance FromJSON Question where
parseJSON (Object q) =
Question <$> q .: "TopicId" <*> q .: "LectureId" <*> q .: "Title" <*>
q .: "Points" <*>
q .: "Question" <*>
q .: "Answer" <*>
q .: "Difficulty" <*>
q .: "Comment" <*>
q .:? "CurrentNumber" .!= 0 <*>
q .:? "BasePath" .!= "."
parseJSON invalid = typeMismatch "Question" invalid
-- $(deriveJSON
-- defaultOptions
-- { fieldLabelModifier = drop 3
-- }
-- ''Question)
$(deriveJSON
defaultOptions
{ fieldLabelModifier = drop 4
}
''Exam)
$(deriveJSON defaultOptions ''Difficulty)
mcKey = typeOf $ MultipleChoice []
ftKey = typeOf $ FillText "" []
ffKey = typeOf $ FreeForm 0 ""
type Templates = [(TypeRep, M.Template)]
selectTemplate :: Templates -> Question -> M.Template
-- selectTemplate templates question = fromJust $ lookup (typeOf $ qstAnswer question) templates
selectTemplate templates question =
case qstAnswer question of
MultipleChoice _ ->
compileMustacheTemplate $ fixMustacheMarkup testerMultipleChoiceTemplate
MultipleAnswers _ _ ->
compileMustacheTemplate $ fixMustacheMarkup testerMultipleAnswersTemplate
FillText _ _ ->
compileMustacheTemplate $ fixMustacheMarkup testerFillTextTemplate
FreeForm _ _ ->
compileMustacheTemplate $ fixMustacheMarkup testerFreeFormTemplate
compileTesterTemplates :: Templates
compileTesterTemplates =
[ ( mcKey
, compileMustacheTemplate $ fixMustacheMarkup testerMultipleChoiceTemplate)
, (ftKey, compileMustacheTemplate $ fixMustacheMarkup testerFillTextTemplate)
, (ffKey, compileMustacheTemplate $ fixMustacheMarkup testerFreeFormTemplate)
]
compileMustacheTemplate :: T.Text -> M.Template
compileMustacheTemplate string =
case M.compileTemplate "" string of
Left err -> throw $ MustacheException $ show err
Right template -> template
{-- Author: Henrik Tramberend <henrik@tramberend.de> --}
module Utilities module Utilities
( calcProjectDirectory ( calcProjectDirectory
, spawn , spawn
......
module Watch (waitForTwitchPassive) where {-- Author: Henrik Tramberend <henrik@tramberend.de> --}
module Watch
-- | A non-polling file watcher based on fsnotify ( waitForTwitchPassive
) where
import Data.List
import System.FilePath
import System.FilePath.Glob
import Control.Concurrent.MVar import Control.Concurrent.MVar
-- | A non-polling file watcher based on fsnotify
import Data.List
import System.FSNotify import System.FSNotify
import System.FilePath
import System.FilePath.Glob
-- | Wait for something to happen on one of the matching files -- | Wait for something to happen on one of the matching files
-- in one of the supplied directories. -- in one of the supplied directories.
waitForTwitch :: [FilePath] -> [Pattern] -> IO FilePath waitForTwitch :: [FilePath] -> [Pattern] -> IO FilePath
waitForTwitch directories patterns = do waitForTwitch directories patterns = do
done <- newEmptyMVar done <- newEmptyMVar
mgr <- startManager mgr <- startManager
stops <- watchIt mgr done stops <- watchIt mgr done
filepath <- takeMVar done filepath <- takeMVar done
sequence_ stops sequence_ stops
stopManager mgr stopManager mgr
return filepath return filepath
where
-- Match a filepath against the supplied patterns -- Match a filepath against the supplied patterns
isWatchedFile event = where
any ((flip match) (eventPath event)) patterns isWatchedFile event = any ((flip match) (eventPath event)) patterns
-- Stop the watch manager and notify the main thread -- Stop the watch manager and notify the main thread
stopWatching mgr done event = do stopWatching mgr done event = do
putMVar done (eventPath event) putMVar done (eventPath event)
-- Watch everything within the supplied dirs -- Watch everything within the supplied dirs
watchInDir mgr done dir = watchTree mgr dir isWatchedFile (stopWatching mgr done) watchInDir mgr done dir =
watchIt mgr done = do watchTree mgr dir isWatchedFile (stopWatching mgr done)
mapM (watchInDir mgr done) directories watchIt mgr done = do
mapM (watchInDir mgr done) directories
twitchPatterns = map compile ["**/*.md", "**/*.yaml", "**/*.png", "**/*.jpg"] twitchPatterns =
map compile ["**/*.md", "**/*.yaml", "**/*.png", "**/*.jpg", "**/*.mp4"]
waitForTwitchPassive files = do waitForTwitchPassive files = do
let dirs = nub (map takeDirectory files) let dirs = nub (map takeDirectory files)
waitForTwitch dirs twitchPatterns waitForTwitch dirs twitchPatterns
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