diff --git a/CCWF.hs b/CCWF.hs new file mode 100644 index 0000000..29f5d0b --- /dev/null +++ b/CCWF.hs @@ -0,0 +1,11 @@ +-- | Chalmers course +module CCWF + ( -- * Configuring and updating pages + Website (..), Info (..), Materials (..) + , URL, Teacher (..), Lecture (..) + + -- * Building the website + , mkWebsite + ) where +import CCWF.Config +import CCWF.Impl diff --git a/CCWF/Config.hs b/CCWF/Config.hs new file mode 100644 index 0000000..522ecf0 --- /dev/null +++ b/CCWF/Config.hs @@ -0,0 +1,75 @@ +-- | Per-website configuration for CCWF. +module CCWF.Config where + +type URL = String + +-- | A course website consists of relatively static course information, and +-- relatively static course materials. +data Website = Website + { courseInfo :: Info + , courseMaterials :: Materials + } + +-- | Lectures, files and news items: course materials that will likely be +-- updated frequently. +data Materials = Materials + { -- | Latest news for the course, in order from newest to latest. + -- Can contain markdown. + newsItems :: [String] + -- | All lectures for the course. These make up the table on the @lectures@ + -- page. + , lectures :: [Lecture] + -- | Files that are related to the course, but not tied to any particular + -- lecture. + , miscFiles :: [FilePath] + } + +-- | Course information: this should change only about once per year. +data Info = Info + { -- | The main teacher of the course. + teacher :: Teacher + -- | The examiner of the course, if different from the main teacher. + , examiner :: Maybe Teacher + -- | Any assistants working on the course. + -- The name, email, etc. of the first assistant in the list are accessible + -- as @assistant@, @assistantemail@, etc. + , assistants :: [Teacher] + -- | URL of the course syllabus. This is mandatory for all Chalmers courses. + , syllabusURL :: URL + -- | URL of the course's Google group, if any. + , googleGroupURL :: Maybe URL + -- | URL of the course's lab submission system, if any. + , submissionURL :: Maybe URL + -- | URL of external schedule for course, if any. + , scheduleURL :: Maybe URL + -- | All lab deadlines. + , labDeadlines :: [String] + } + +-- | Bio for the teacher responsible for the course. +-- Name, phone and email are mandatory. +data Teacher = Teacher + { -- | Full name of teacher. + teacherName :: String + -- | Work email. + , teacherEmail :: String + -- | Work phone. + , teacherPhone :: String + -- | Does the teacher have a biography? + , teacherBioURL :: Maybe URL + -- | Room number of/directions to teacher's office. + , teacherOffice :: Maybe String + -- | Office hours, when the teacher is available for answering questions. + , teacherHours :: Maybe String + } + +-- | An entry in the list of course lectures. +data Lecture = Lecture + { -- | When did the lecture take place? + lectureDate :: String + -- | What was it about? Preferably one (short) sentence. + , lectureDescription :: String + -- | Any auxilliary material associated with the course. + -- These files need to be present in the @files@ directory. + , lectureFiles :: [(String, FilePath)] + } diff --git a/CCWF/Impl.hs b/CCWF/Impl.hs new file mode 100644 index 0000000..86d48bd --- /dev/null +++ b/CCWF/Impl.hs @@ -0,0 +1,217 @@ +{-# LANGUAGE OverloadedStrings, RecordWildCards, TupleSections #-} +module CCWF.Impl where +import Hakyll +import Control.Monad +import Data.Char +import Data.List +import Data.Time +import Data.Function (on) +import System.Directory (doesFileExist) +import System.FilePath (takeBaseName) +import Text.Read +import CCWF.Config + +-- | Build a website from a configuration. +mkWebsite :: Website -> IO () +mkWebsite (Website (Info{..}) (Materials{..})) = do + -- Check that all lecture files are present + (courseYear, _, _) <- toGregorian . utctDay <$> getCurrentTime + let files = [ "./files/" ++ file + | fs <- map lectureFiles lectures + , (_, file) <- fs + ] ++ map ("./files/" ++) miscFiles + files' <- filterM (fmap not . doesFileExist) files + unless (null files') $ do + putStrLn $ "The following essential files could not be found:" + forM_ files' $ putStrLn . (" " ++) + error "Some files were missing from the ./files directory!" + + hakyll $ do + -- CSS files are just compressed + match "css/*" $ do + route idRoute + compile compressCssCompiler + + -- JS files are just copied + match "js/*" $ do + route idRoute + compile copyFileCompiler + + -- Images too + match "images/*" $ do + route idRoute + compile copyFileCompiler + + -- Lectures files are copied into files/ + match "files/*" $ do + route idRoute + compile copyFileCompiler + + -- Don't do anything fancy with templates + match "templates/*" $ do + compile templateCompiler + + -- Add an explicit dependency on this file + match "website.hs" $ do + compile $ makeItem () + hsdep <- makePatternDependency "website.hs" + + -- Pages are read from the @pages@ subdirectory. + rulesExtraDependencies [hsdep] $ match "pages/*.md" $ do + route $ gsubRoute "pages/" (const "") + `composeRoutes` gsubRoute ".md" (const "") + `composeRoutes` customRoute (mkPath . toFilePath) + compile $ do + metas <- getAllMetadata "pages/*.md" + self <- takeBaseName <$> getResourceFilePath + let -- Menu items, sorted by their menuorder metadata entry. + -- Items without menuorder are sorted randomly among themselves, + -- after any entries with a specified order. + menuitems = map snd $ sortBy (\a b -> compare (fst a) (fst b)) $ + [ (menuOrder meta, Item (noIndex ident) title) + | (ident, meta) <- metas + , Just title <- [lookupString "title" meta] + ] + -- Context for the page content; contains metadata set in the + -- markdown file for each page, as well as some info set at the + -- top of this file. + ctx = mconcat + [ constField "year" (show courseYear) + , constField "syllabus" syllabusURL + , constField "group" (maybe "" id googleGroupURL) + , constField "submissions" (maybe "" id submissionURL) + , constField "schedule" (maybe "" id scheduleURL) + , constField "S" "$" + , mconcat + [ constField ("deadline" ++ show num) date + | (date, num) <- zip labDeadlines [1..] + ] + , teacherFields "teacher" teacher + , maybe mempty (teacherFields "examiner") examiner + , case assistants of + (ass:_) -> teacherFields "assistant" ass + _ -> mempty + , listField "assistants" mkTeacherListItemCtx (pure assistantItems) + , listField "menuitems" (mkMenuCtx self) + (pure menuitems) + , listField "lectures" mkLectureCtx + (zipWithM (curry makeItem) [1..] lectures) + , if length newsItems > 3 + then listField "news" defaultContext (pure newsItemItems) + else mempty + , listField "latestnews" defaultContext (pure $ take 3 newsItemItems) + , defaultContext + ] + applyMeAsTemplate ctx ctx + where + newsItemItems = map (Item (fromFilePath "")) newsItems + assistantItems = map (Item (fromFilePath "")) assistants + +-- | Create a list item context for a teacher. +-- Used for the list of assistants. +mkTeacherListItemCtx :: Context Teacher +mkTeacherListItemCtx = mconcat + [ field "full" $ \(Item _ t) -> pure $ teacherName t + , field "email" $ \(Item _ t) -> pure $ teacherEmail t + , field "bio" $ \(Item _ t) -> pure $ maybe "" id $ teacherBioURL t + , field "phone" $ \(Item _ t) -> pure $ teacherPhone t + , field "office" $ \(Item _ t) -> pure $ maybe "" id $ teacherOffice t + , field "hours" $ \(Item _ t) -> pure $ maybe "" id $ teacherHours t + ] + +-- | Create context fields for a teacher. +teacherFields :: String -> Teacher -> Context a +teacherFields prefix (Teacher {..}) = mconcat + [ constField prefix (head $ words teacherName) + , constField (prefix ++ "full") teacherName + , constField (prefix ++ "email") teacherEmail + , constField (prefix ++ "bio") (maybe "" id teacherBioURL) + , constField (prefix ++ "phone") teacherPhone + , maybe mempty (constField (prefix ++ "office")) teacherOffice + , maybe mempty (constField (prefix ++ "hours")) teacherHours + ] + +-- | Get the menu order from a piece of metadata. +menuOrder :: Metadata -> Int +menuOrder meta = + maybe 1000000 + (round :: Double -> Int) + (readMaybe =<< lookupString "menuorder" meta) + +-- | Set the CSS class of a menu item based on its identifier and the +-- identifier of the current page. If the identifier matches the current +-- page, the item should be displayed as selected. +menuItemClass :: String -> Item a -> String +menuItemClass current itm + | current == takeBaseName (toFilePath (itemIdentifier itm)) = + "selected" + | current == "index" && null (toFilePath (itemIdentifier itm)) = + "selected" + | otherwise = + "unselected" + +mkLectureCtx :: Context (Int, Lecture) +mkLectureCtx = mconcat + [ field "date" $ \(Item _ (_, l)) -> do + pure $ lectureDate l + , field "description" $ \(Item _ (_, l)) -> do + pure $ show $ lectureDescription l + , listFieldWith "lecturefiles" defaultContext $ \(Item _ (_, l)) -> do + pure $ [ Item (fromFilePath file) name + | (name, file) <- lectureFiles l] + , field "number" $ \(Item _ (n, _)) -> + pure $ show n + ] + +-- | Build the context for the menu. The @submenuitems@ field will contain all +-- sub-menu items for the currently active page. +-- Note that URLs are relativized in a horrible, hacky way, which needs to +-- be changed if the directory hierarchy of the course homepage changes. +mkMenuCtx :: String + -> Context String +mkMenuCtx self = mconcat + [ field "selected" (pure . menuItemClass self) + , listFieldWith "submenuitems" defaultContext $ \itm -> do + when (takeBaseName (toFilePath (itemIdentifier itm)) /= self) $ do + fail "not my submenu" + submenuitems <- words <$> getMetadataField' (itemIdentifier itm) "submenu" + forM (zip (mkTitles submenuitems) submenuitems) $ \(title, ident) -> do + pure $ Item (fromFilePath $ "#" ++ ident) title + , field "url" $ pure . itemToUrl + , defaultContext + ] + where + itemToUrl = ("/" ++) . takeBaseName . toFilePath . itemIdentifier + mkTitles = map capitalize . map toSpaces + + capitalize (x:xs) = toUpper x : xs + + toSpaces = map toSpace + + toSpace '_' = ' ' + toSpace c = c + +-- | Render the current page as markdown, then use the current page as a +-- template (i.e. it may include substitutions), and render it as markdown +-- again. Finally, apply the default template to the end result and +-- relativize all URLs. +applyMeAsTemplate :: Context String -> Context String -> Compiler (Item String) +applyMeAsTemplate pageCtx topCtx = do + getResourceBody + >>= renderPandoc + >>= applyAsTemplate pageCtx + >>= renderPandoc + >>= loadAndApplyTemplate "templates/default.html" topCtx + >>= relativizeUrls + +-- | Turn a path @p@ (stripped of prefix and extension) into @p/index.html@. +mkPath :: FilePath -> FilePath +mkPath "index" = "index.html" +mkPath p = p ++ "/index.html" + +-- | Turn an identifier into an empty identifier if the identifier is @index@, +-- otherwise return the identifier unchanged. +noIndex :: Identifier -> Identifier +noIndex ident + | takeBaseName (toFilePath ident) == "index" = fromFilePath "" + | otherwise = ident diff --git a/pages/about.md b/pages/about.md index fc53395..67f3f4a 100644 --- a/pages/about.md +++ b/pages/about.md @@ -100,4 +100,4 @@ instructions. Two things should be noted: The second step is to actually submit your solution, by clicking the *Submit* button. **It is not enough to only upload; you must also submit!** -[Go to the submission system](\$fire\$) +[Go to the submission system](\$submissions\$) diff --git a/pages/lectures.md b/pages/lectures.md index 61c6ac5..63667eb 100644 --- a/pages/lectures.md +++ b/pages/lectures.md @@ -9,7 +9,7 @@ Lectures Lectures take place on Tuesdays 13-15 in EL41 and Fridays 13-15 in EL42. Not all available times are used. The complete schedule is available in -[TimeEdit](\$timeedit\$). Note that if you use an iCal or vCal-compatible +[TimeEdit](\$schedule\$). Note that if you use an iCal or vCal-compatible calendar, you can download the course schedule from TimeEdit. The following is a preliminary plan for the lectures. Changes will be announced diff --git a/pages/project.md b/pages/project.md index 9f4f5ea..5347b9f 100644 --- a/pages/project.md +++ b/pages/project.md @@ -25,7 +25,6 @@ submenu: deadlines grading javalette frontend extensions testing code_generation * [x86 generation](#x86) * [Optimization study](#optstudy) * [Other extensions](#moreextensions) -* [Testing](#testing) @@ -1351,7 +1350,7 @@ declare i32 @printf(i8*, ...) nounwind ``` What remains is a definition of the format string `@fstr` as a global constant -(`\0A` is `\n`), the `getelementpointer` instruction that returns a pointer to +(`\\0A` is `\\n`), the `getelementpointer` instruction that returns a pointer to the beginning of the format string and a call to `printf` with the result value. Note that the call to `printInt` has been inlined, i.e. replaced by a call to `printf`; so linking includes optimizations across files. @@ -1360,17 +1359,17 @@ We can now run `a.out.bc` using the just-in-time compiler `lli`. Or, if we prefer, we can produce native assembly code with `llc`. On my x86 machine, this gives -```asm +``` .text .align 4,0x90 .globl _main _main: - subl $$12, %esp - movl $$5040, 4(%esp) - movl $$_fstr, (%esp) + subl $S$12, %esp + movl $S$5040, 4(%esp) + movl $S$_fstr, (%esp) call _printf xorl %eax, %eax - addl $$12, %esp + addl $S$12, %esp ret .cstring _fstr: ## fstr diff --git a/pages/schedule.md b/pages/schedule.md index ebb8bd3..cd068f7 100644 --- a/pages/schedule.md +++ b/pages/schedule.md @@ -3,9 +3,9 @@ title: Schedule menuorder: 5 --- - + Schedule ======== -The official schedule for the course is available on [TimeEdit](\$timeedit\$). +The official schedule for the course is available on [TimeEdit](\$schedule\$). diff --git a/website.hs b/website.hs index 28acf3b..4808229 100644 --- a/website.hs +++ b/website.hs @@ -1,332 +1,113 @@ -{-# LANGUAGE OverloadedStrings, RecordWildCards, TupleSections #-} -import Hakyll -import Control.Monad -import Data.Char -import Data.List -import Data.Time -import System.Directory (doesFileExist) -import System.FilePath (takeBaseName) -import Text.Read +import CCWF ------------------------------------------------------------------------- -- * News, lectures and files. Routine updates should mostly happen here. ------------------------------------------------------------------------- --- | Latest news, in order from newest to latest. Can contain markdown. -newsItems :: [Item String] -newsItems = map (Item (fromFilePath "")) $ - [ "June 28. Responsive design - it now looks *fabulous* on mobile devices!" - , "June 27. Birth of the new course homepage." - ] - --- | All lectures for the course. These make up the table on the @lectures@ --- page. --- --- Make sure to put any files mentioned in the list of lecture files --- into the @files@ subdirectory before rebuilding the course homepage, to --- ensure that they all get included. -lectures :: [Lecture] -lectures = - [ Lecture "April 12" "Introduction, project overview" - [("old", "lect01-6up.pdf")] - , Lecture "April 15" "Software Engineering for Compilers" - [("old", "lect02-6up.pdf"), ("code", "state.tar.gz")] - , Lecture "April 22" "LLVM: tools, language" - [("old", "lect03-6up.pdf")] - , Lecture "April 26" "Code generation for LLVM" - [("old", "lect04-6up.pdf"), ("code", "evenodd.ll")] - , Lecture "May 3" "Project extensions: arrays, dynamic structures, objects" - [("old", "lect05-6up.pdf")] - , Lecture "May 10" "Code generation for x86" - [("old", "lect06-6up.pdf")] - , Lecture "May 13" "Functions" - [("old", "lect07-6up.pdf")] - , Lecture "May 16" "Control flow graphs, data analysis" - [("old", "lect08-6up.pdf")] - , Lecture "May 24" "Guest lecture/project summary" - [("old", "lect09-6up.pdf"), ("guest", "/guest_lecture_myreen-6up.pdf")] - ] - --- | Files we provide that are not tied to any particular lecture. -miscFiles :: [FilePath] -miscFiles = ["runtime.ll", "Javalette.cf", "tester.tar.gz"] - +materials = Materials + { -- | Latest news, in order from newest to latest. Can contain markdown. + newsItems = + [ "June 28. Responsive design - it now looks *fabulous* on mobile devices!" + , "June 27. Birth of the new course homepage." + ] + + -- | All lectures for the course. These make up the table on the @lectures@ + -- page. + -- + -- Make sure to put any files mentioned in the list of lecture files + -- into the @files@ subdirectory before rebuilding the course homepage, to + -- ensure that they all get included. + , lectures = + [ Lecture "April 12" "Introduction, project overview" + [("old", "lect01-6up.pdf")] + , Lecture "April 15" "Software Engineering for Compilers" + [("old", "lect02-6up.pdf"), ("code", "state.tar.gz")] + , Lecture "April 22" "LLVM: tools, language" + [("old", "lect03-6up.pdf")] + , Lecture "April 26" "Code generation for LLVM" + [("old", "lect04-6up.pdf"), ("code", "evenodd.ll")] + , Lecture "May 3" "Project extensions: arrays, dynamic structures, objects" + [("old", "lect05-6up.pdf")] + , Lecture "May 10" "Code generation for x86" + [("old", "lect06-6up.pdf")] + , Lecture "May 13" "Functions" + [("old", "lect07-6up.pdf")] + , Lecture "May 16" "Control flow graphs, data analysis" + [("old", "lect08-6up.pdf")] + , Lecture "May 24" "Guest lecture/project summary" + [("old", "lect09-6up.pdf"), ("guest", "/guest_lecture_myreen-6up.pdf")] + ] + + -- | Files we provide that are not tied to any particular lecture. + , miscFiles = ["runtime.ll", "Javalette.cf", "tester.tar.gz"] + } ---------------------------------------------------------------------------- -- * Course-specific configuration - should only need changing once per year ---------------------------------------------------------------------------- --- | Name of course responsible, plus email. --- This is parameterized to make course handovers easier, since the name --- and/or email of the course responsible pops up here and there throughout --- the project description and course homepage.. --- --- First name is available to templates as @teacher@, full name as --- @teacherfull@, email as @teacheremail@, bio URL as @teacherbio@, phone --- as @teacherphone@, office as @teacheroffice@ and office hours as --- @teacherhours@. --- --- Currently, the examiner and the de facto course responsible are not one --- and the same. If this situation changes, or if the examiner changes, don't --- forget to make the appropriate modifications to @pages/about.md@. --- --- Similarly, if the course should evolve to need more than one assistant, --- or add change the duties of the course responsible or assistant , --- please update @pages/about.md@ as appropriate. Use 'labDeadlines' --- and its use in @pages/exam.md@ as an example of adding a list of things --- to a page. -teacher :: Teacher -teacher = Teacher - { teacherName = "Alex Gerdes" - , teacherEmail = "alexg \"at\" chalmers.se" - , teacherBioURL = Just "http://www.cse.chalmers.se/~alexg" - , teacherPhone = "+46 31 772 6154" - , teacherOffice = Just "Room 6466 in the EDIT building." - , teacherHours = Just "Thursdays 13:15 - 15:00" - } - --- | Same information as for 'teacher'. All fields are available to templates --- the same as for @teacher@, but with the prefix @assistant@ instead of --- @teacher@. -assistant :: Teacher -assistant = Teacher - { teacherName = "Anton Ekblad" - , teacherEmail = "antonek \"at\" chalmers.se" - , teacherPhone = "+46 31 772 1028" - , teacherBioURL = Just "http://ekblad.cc" - , teacherOffice = Just "Room 5463 in the EDIT building." - , teacherHours = Nothing - } - --- | URL of the official course syllabus for 2017. --- This changes every year: don't forget to update! --- Available to templates as @syllabus@. -syllabusURL :: String -syllabusURL = "https://www.student.chalmers.se/sp/course?course_id=24405" - --- | URL of the Google group for this year's instance. Don't forget to update! --- Available to templates as @group@. -googleGroupURL :: String -googleGroupURL = "javascript:alert('No group yet!');" - --- | URL of this year's Fire instance. Don't forget to update! --- Available to templates as @fire@. -fireURL :: String -fireURL = "javascript:alert('No Fire yet!');" - --- | URL of the course's TimeEdit schedule. Available to templates as --- @timeedit@. -timeEditURL :: String -timeEditURL = "https://se.timeedit.net/web/chalmers/db1/public/ri1X50gQ1560YvQQ05Z6779Y0Zy6007331Y50Q089.html" - --- | The deadlines for the three labs. --- Available to templates as @deadline1/2/3@. -labDeadlines :: [String] -labDeadlines = - [ "Sunday, April 24 at 23:59" - , "Sunday, May 15 at 23:59" - , "Sunday, May 29 at 23:59" - ] - - ---------------------------------------------------- --- * Only implementation details beyond this point. ---------------------------------------------------- - -data Teacher = Teacher - { teacherName :: String - , teacherEmail :: String - , teacherPhone :: String - , teacherBioURL :: Maybe String - , teacherOffice :: Maybe String - , teacherHours :: Maybe String - } - -data Lecture = Lecture - { lectureDate :: String - , lectureDescription :: String - , lectureFiles :: [(String, FilePath)] +info = Info + { -- | Name of course responsible, plus email. + -- This is parameterized to make course handovers easier, since the name + -- and/or email of the course responsible pops up here and there throughout + -- the project description and course homepage.. + -- + -- First name is available to templates as @teacher@, full name as + -- @teacherfull@, email as @teacheremail@, bio URL as @teacherbio@, phone + -- as @teacherphone@, office as @teacheroffice@ and office hours as + -- @teacherhours@. + teacher = Teacher + { teacherName = "Alex Gerdes" + , teacherEmail = "alexg \"at\" chalmers.se" + , teacherBioURL = Just "http://www.cse.chalmers.se/~alexg" + , teacherPhone = "+46 31 772 6154" + , teacherOffice = Just "Room 6466 in the EDIT building." + , teacherHours = Just "Thursdays 13:15 - 15:00" + } + + -- | The examiner of the course, if different from the course responsible. + , examiner = Nothing + + -- | Same information as for 'teacher'. All fields of the first assistant + -- are available to templates the same as for @teacher@, but with the + -- prefix @assistant@ instead of @teacher@. + -- The full list of assistants is available as @assistants@. + , assistants = + [ Teacher + { teacherName = "Anton Ekblad" + , teacherEmail = "antonek \"at\" chalmers.se" + , teacherPhone = "+46 31 772 1028" + , teacherBioURL = Just "http://ekblad.cc" + , teacherOffice = Just "Room 5463 in the EDIT building." + , teacherHours = Nothing + } + ] + + -- | URL of the official course syllabus for 2017. + -- This changes every year: don't forget to update! + -- Available to templates as @syllabus@. + , syllabusURL = "https://www.student.chalmers.se/sp/course?course_id=24405" + + -- | URL of the Google group for this year's instance. Don't forget to update! + -- Available to templates as @group@. + , googleGroupURL = Just "javascript:alert('No group yet!');" + + -- | URL of the lab submission system used this year, if any. + -- Don't forget to update! + -- Available to templates as @submissions@. + , submissionURL = Just "javascript:alert('No Fire yet!');" + + -- | URL of the course's TimeEdit schedule. Available to templates as + -- @schedule@. + , scheduleURL = Just "https://se.timeedit.net/web/chalmers/db1/public/ri1X50gQ1560YvQQ05Z6779Y0Zy6007331Y50Q089.html" + + -- | The deadlines for the three labs. + -- Available to templates as @deadline1/2/3@. + , labDeadlines = + [ "Sunday, April 24 at 23:59" + , "Sunday, May 15 at 23:59" + , "Sunday, May 29 at 23:59" + ] } -main = do - -- Check that all lecture files are present - (courseYear, _, _) <- toGregorian . utctDay <$> getCurrentTime - let files = [ "./files/" ++ file - | fs <- map lectureFiles lectures - , (_, file) <- fs - ] ++ map ("./files/" ++) miscFiles - files' <- filterM (fmap not . doesFileExist) files - unless (null files') $ do - putStrLn $ "The following essential files could not be found:" - forM_ files' $ putStrLn . (" " ++) - error "Some files were missing from the ./files directory!" - - hakyll $ do - -- CSS files are just compressed - match "css/*" $ do - route idRoute - compile compressCssCompiler - - -- JS files are just copied - match "js/*" $ do - route idRoute - compile copyFileCompiler - - -- Images too - match "images/*" $ do - route idRoute - compile copyFileCompiler - - -- Lectures files are copied into files/ - match "files/*" $ do - route idRoute - compile copyFileCompiler - - -- Don't do anything fancy with templates - match "templates/*" $ do - compile templateCompiler - - -- Add an explicit dependency on this file - match "website.hs" $ do - compile $ makeItem () - hsdep <- makePatternDependency "website.hs" - - -- Pages are read from the @pages@ subdirectory. - rulesExtraDependencies [hsdep] $ match "pages/*.md" $ do - route $ gsubRoute "pages/" (const "") - `composeRoutes` gsubRoute ".md" (const "") - `composeRoutes` customRoute (mkPath . toFilePath) - compile $ do - metas <- getAllMetadata "pages/*.md" - self <- takeBaseName <$> getResourceFilePath - let -- Menu items, sorted by their menuorder metadata entry. - -- Items without menuorder are sorted randomly among themselves, - -- after any entries with a specified order. - menuitems = map snd $ sortBy (\a b -> compare (fst a) (fst b)) $ - [ (menuOrder meta, Item (noIndex ident) title) - | (ident, meta) <- metas - , Just title <- [lookupString "title" meta] - ] - -- Context for the page content; contains metadata set in the - -- markdown file for each page, as well as some info set at the - -- top of this file. - ctx = mconcat - [ constField "year" (show courseYear) - , constField "syllabus" syllabusURL - , constField "group" googleGroupURL - , constField "fire" fireURL - , constField "timeedit" timeEditURL - , mconcat - [ constField ("deadline" ++ show num) date - | (date, num) <- zip labDeadlines [1..] - ] - , teacherFields "teacher" teacher - , teacherFields "assistant" assistant - , listField "menuitems" (mkMenuCtx self) - (pure menuitems) - , listField "lectures" mkLectureCtx - (mapM (makeItem . fst) (zip [0..] lectures)) - , if length newsItems > 3 - then listField "news" defaultContext (pure newsItems) - else mempty - , listField "latestnews" defaultContext (pure $ take 3 newsItems) - , defaultContext - ] - applyMeAsTemplate ctx ctx - --- | Create context fields for a teacher. -teacherFields :: String -> Teacher -> Context a -teacherFields prefix (Teacher {..}) = mconcat - [ constField prefix (head $ words teacherName) - , constField (prefix ++ "full") teacherName - , constField (prefix ++ "email") teacherEmail - , constField (prefix ++ "bio") (maybe "" id teacherBioURL) - , constField (prefix ++ "phone") teacherPhone - , maybe mempty (constField (prefix ++ "office")) teacherOffice - , maybe mempty (constField (prefix ++ "hours")) teacherHours - ] - --- | Get the menu order from a piece of metadata. -menuOrder :: Metadata -> Int -menuOrder meta = - maybe 1000000 - (round :: Double -> Int) - (readMaybe =<< lookupString "menuorder" meta) - --- | Set the CSS class of a menu item based on its identifier and the --- identifier of the current page. If the identifier matches the current --- page, the item should be displayed as selected. -menuItemClass :: String -> Item a -> String -menuItemClass current itm - | current == takeBaseName (toFilePath (itemIdentifier itm)) = - "selected" - | current == "index" && null (toFilePath (itemIdentifier itm)) = - "selected" - | otherwise = - "unselected" - -mkLectureCtx :: Context Int -mkLectureCtx = mconcat - [ field "date" $ \(Item _ n) -> do - pure $ lectureDate (lectures !! n) - , field "description" $ \(Item _ n) -> do - pure $ show $ lectureDescription (lectures !! n) - , listFieldWith "lecturefiles" defaultContext $ \(Item _ n) -> do - pure $ [ Item (fromFilePath file) name - | (name, file) <- lectureFiles $ lectures !! n] - , field "number" $ \(Item _ n) -> - pure $ show (n+1) - ] - --- | Build the context for the menu. The @submenuitems@ field will contain all --- sub-menu items for the currently active page. --- Note that URLs are relativized in a horrible, hacky way, which needs to --- be changed if the directory hierarchy of the course homepage changes. -mkMenuCtx :: String - -> Context String -mkMenuCtx self = mconcat - [ field "selected" (pure . menuItemClass self) - , listFieldWith "submenuitems" defaultContext $ \itm -> do - when (takeBaseName (toFilePath (itemIdentifier itm)) /= self) $ do - fail "not my submenu" - submenuitems <- words <$> getMetadataField' (itemIdentifier itm) "submenu" - forM (zip (mkTitles submenuitems) submenuitems) $ \(title, ident) -> do - pure $ Item (fromFilePath $ "#" ++ ident) title - , field "url" $ pure . itemToUrl - , defaultContext - ] - where - itemToUrl = ("/" ++) . takeBaseName . toFilePath . itemIdentifier - mkTitles = map capitalize . map toSpaces - - capitalize (x:xs) = toUpper x : xs - - toSpaces = map toSpace - - toSpace '_' = ' ' - toSpace c = c - --- | Render the current page as markdown, then use the current page as a --- template (i.e. it may include substitutions), and render it as markdown --- again. Finally, apply the default template to the end result and --- relativize all URLs. -applyMeAsTemplate :: Context String -> Context String -> Compiler (Item String) -applyMeAsTemplate pageCtx topCtx = do - getResourceBody - >>= renderPandoc - >>= applyAsTemplate pageCtx - >>= renderPandoc - >>= loadAndApplyTemplate "templates/default.html" topCtx - >>= relativizeUrls - --- | Turn a path @p@ (stripped of prefix and extension) into @p/index.html@. -mkPath :: FilePath -> FilePath -mkPath "index" = "index.html" -mkPath p = p ++ "/index.html" - --- | Turn an identifier into an empty identifier if the identifier is @index@, --- otherwise return the identifier unchanged. -noIndex :: Identifier -> Identifier -noIndex ident - | takeBaseName (toFilePath ident) == "index" = fromFilePath "" - | otherwise = ident +main = mkWebsite (Website info materials)