-------------------------------------------------------------------------------- {-# LANGUAGE OverloadedStrings #-} import Control.Monad import qualified Data.Map.Lazy as Map import qualified Data.Text import qualified Data.Text.Lazy as T import qualified Data.Text.Lazy.Encoding as T import Data.Monoid (mappend) import Hakyll import qualified Text.MMark as MMark import qualified Text.MMark.Extension as MMark import qualified Text.MMark.Extension.Common as MMark import qualified Text.Megaparsec.Error as Mega import System.Directory import System.FilePath import Lucid import Eventlog.Data import Eventlog.Args import Eventlog.VegaTemplate import Eventlog.HtmlTemplate import qualified Text.Blaze.Html.Renderer.Text as Blaze -------------------------------------------------------------------------------- main :: IO () main = do eventLogs <- renderEventLogs hakyllWith conf $ do match "images/*" $ do route idRoute compile copyFileCompiler match "css/*" $ do route idRoute compile compressCssCompiler match (fromList ["about.rst", "contact.markdown"]) $ do route $ setExtension "html" compile $ pandocCompiler >>= loadAndApplyTemplate "templates/default.html" defaultContext >>= relativizeUrls match "posts/*" $ do route indexHtml compile $ mmarkCompiler eventLogs >>= loadAndApplyTemplate "templates/post.html" postCtx >>= loadAndApplyTemplate "templates/default.html" postCtx >>= relativizeUrls create ["archive.html"] $ do route $ setExtension "html" compile $ do posts <- recentFirst =<< loadAll "posts/*" let archiveCtx = listField "posts" postCtx (return posts) `mappend` constField "title" "Archives" `mappend` defaultContext makeItem "" >>= loadAndApplyTemplate "templates/archive.html" archiveCtx >>= loadAndApplyTemplate "templates/default.html" archiveCtx >>= relativizeUrls >>= removeIndexes match "index.html" $ do route idRoute compile $ do posts <- recentFirst =<< loadAll "posts/*" let indexCtx = listField "posts" postCtx (return posts) `mappend` defaultContext getResourceBody >>= applyAsTemplate indexCtx >>= loadAndApplyTemplate "templates/default.html" indexCtx >>= relativizeUrls >>= removeIndexes match "templates/*" $ compile templateBodyCompiler -------------------------------------------------------------------------------- postCtx :: Context String postCtx = dateField "date" "%B %e, %Y" `mappend` defaultContext indexHtml :: Routes indexHtml = customRoute go where go i = let fp = toFilePath i in takeDirectory fp takeBaseName fp "index.html" removeIndexes :: Item FilePath -> Compiler (Item FilePath) removeIndexes = return . fmap (withUrls removeIndex) where removeIndex fp | takeFileName fp == "index.html" = takeDirectory fp | otherwise = fp conf = defaultConfiguration { deployCommand = "rsync -a _site/ luke@lukelau.me:/var/www/luke/haskell" } mmarkCompiler :: Map.Map FilePath (Html ()) -> Compiler (Item String) mmarkCompiler eventlogs = do fp <- getResourceFilePath getResourceLBS >>= withItemBody (\lbs -> let text = T.toStrict $ T.decodeUtf8 lbs in case MMark.parse fp text of Left e -> error (Mega.errorBundlePretty e) Right doc -> let html = MMark.render (MMark.useExtensions extensions doc) in return $ T.unpack $ renderText html) where extensions = [ MMark.ghcSyntaxHighlighter , MMark.skylighting , MMark.footnotes , eventLogsExt eventlogs ] renderEventLogs :: IO (Map.Map FilePath (Html ())) renderEventLogs = foldM render mempty =<< listDirectory "eventlogs" where render acc fp = do let args = Args { sorting = Size , reversing = False , tracePercent = 1 , nBands = 15 , heapProfile = False , noIncludejs = False , json = True , noTraces = True , userColourScheme = "" , files = [] } (_, dat) <- generateJson ("eventlogs" fp) args let conf = ChartConfig 450 500 True "accent" (AreaChart Stacked) html :: Html () html = div_ [style_ "overflow: scroll"] $ do forM_ vegaScripts $ \url -> script_ [src_ url] ("" :: T.Text) :: Html () toHtmlRaw $ Blaze.renderHtml $ renderChartWithJson 1 dat (vegaJsonText conf) return $ Map.insert fp html acc vegaScripts = [ "https://cdn.jsdelivr.net/npm/vega@5.4.0" , "https://cdn.jsdelivr.net/npm/vega-lite@3.3.0" , "https://cdn.jsdelivr.net/npm/vega-embed@4.2.0" ] eventLogsExt :: Map.Map FilePath (Html ()) -> MMark.Extension eventLogsExt eventLogs = MMark.blockRender go where go :: (MMark.Block (MMark.Ois, Html ()) -> Html ()) -> MMark.Block (MMark.Ois, Html ()) -> Html () go f (MMark.CodeBlock (Just "eventlog") url) = eventLogs Map.! (Data.Text.unpack (Data.Text.strip url)) go f x = f x