1 --------------------------------------------------------------------------------
2 {-# LANGUAGE OverloadedStrings #-}
4 import qualified Data.Map.Lazy as Map
5 import qualified Data.Text
6 import qualified Data.Text.Lazy as T
7 import qualified Data.Text.Lazy.Encoding as T
8 import Data.Monoid (mappend)
10 import qualified Text.MMark as MMark
11 import qualified Text.MMark.Extension as MMark
12 import qualified Text.MMark.Extension.Common as MMark
13 import qualified Text.Megaparsec.Error as Mega
14 import System.Directory
15 import System.FilePath
19 import Eventlog.VegaTemplate
20 import Eventlog.HtmlTemplate
21 import qualified Text.Blaze.Html.Renderer.Text as Blaze
23 --------------------------------------------------------------------------------
26 eventLogs <- renderEventLogs
30 compile copyFileCompiler
34 compile compressCssCompiler
36 match (fromList ["about.rst", "contact.markdown"]) $ do
37 route $ setExtension "html"
38 compile $ pandocCompiler
39 >>= loadAndApplyTemplate "templates/default.html" defaultContext
44 compile $ mmarkCompiler eventLogs
45 >>= loadAndApplyTemplate "templates/post.html" postCtx
46 >>= loadAndApplyTemplate "templates/default.html" postCtx
49 create ["archive.html"] $ do
50 route $ setExtension "html"
52 posts <- recentFirst =<< loadAll "posts/*"
54 listField "posts" postCtx (return posts) `mappend`
55 constField "title" "Archives" `mappend`
59 >>= loadAndApplyTemplate "templates/archive.html" archiveCtx
60 >>= loadAndApplyTemplate "templates/default.html" archiveCtx
65 match "index.html" $ do
68 posts <- recentFirst =<< loadAll "posts/*"
70 listField "posts" postCtx (return posts) `mappend`
74 >>= applyAsTemplate indexCtx
75 >>= loadAndApplyTemplate "templates/default.html" indexCtx
79 match "templates/*" $ compile templateBodyCompiler
82 --------------------------------------------------------------------------------
83 postCtx :: Context String
85 dateField "date" "%B %e, %Y" `mappend`
89 indexHtml = customRoute go
91 go i = let fp = toFilePath i
92 in takeDirectory fp </> takeBaseName fp </> "index.html"
94 removeIndexes :: Item FilePath -> Compiler (Item FilePath)
95 removeIndexes = return . fmap (withUrls removeIndex)
98 | takeFileName fp == "index.html" = takeDirectory fp
101 conf = defaultConfiguration
102 { deployCommand = "rsync -a _site/ luke@lukelau.me:/var/www/luke/haskell" }
104 mmarkCompiler :: Map.Map FilePath (Html ()) -> Compiler (Item String)
105 mmarkCompiler eventlogs = do
106 fp <- getResourceFilePath
107 getResourceLBS >>= withItemBody (\lbs ->
108 let text = T.toStrict $ T.decodeUtf8 lbs
109 in case MMark.parse fp text of
110 Left e -> error (Mega.errorBundlePretty e)
112 let html = MMark.render (MMark.useExtensions extensions doc)
113 in return $ T.unpack $ renderText html)
115 where extensions = [ MMark.ghcSyntaxHighlighter
118 , eventLogsExt eventlogs
121 renderEventLogs :: IO (Map.Map FilePath (Html ()))
122 renderEventLogs = foldM render mempty =<< listDirectory "eventlogs"
125 let args = Args { sorting = Size
129 , heapProfile = False
130 , noIncludejs = False
133 , userColourScheme = ""
136 (_, dat) <- generateJson ("eventlogs" </> fp) args
137 let conf = ChartConfig 450 500 True "accent" (AreaChart Stacked)
139 html = div_ [style_ "overflow: scroll"] $ do
140 forM_ vegaScripts $ \url ->
141 script_ [src_ url] ("" :: T.Text) :: Html ()
142 toHtmlRaw $ Blaze.renderHtml $ renderChartWithJson 1 dat (vegaJsonText conf)
143 return $ Map.insert fp html acc
145 vegaScripts = [ "https://cdn.jsdelivr.net/npm/vega@5.4.0"
146 , "https://cdn.jsdelivr.net/npm/vega-lite@3.3.0"
147 , "https://cdn.jsdelivr.net/npm/vega-embed@4.2.0"
150 eventLogsExt :: Map.Map FilePath (Html ()) -> MMark.Extension
151 eventLogsExt eventLogs = MMark.blockRender go
153 go :: (MMark.Block (MMark.Ois, Html ()) -> Html ()) -> MMark.Block (MMark.Ois, Html ()) -> Html ()
154 go f (MMark.CodeBlock (Just "eventlog") url) = eventLogs Map.! (Data.Text.unpack (Data.Text.strip url))