diff --git a/.shake/.shake.database b/.shake/.shake.database new file mode 100644 index 0000000..b54b711 Binary files /dev/null and b/.shake/.shake.database differ diff --git a/.shake/.shake.lock b/.shake/.shake.lock new file mode 100644 index 0000000..e69de29 diff --git a/app/Config.hs b/app/Config.hs new file mode 100644 index 0000000..aec80f9 --- /dev/null +++ b/app/Config.hs @@ -0,0 +1,13 @@ +module Config where + +outputDir :: String +outputDir = "publish" + +assetGlobs :: [String] +assetGlobs = ["static/*"] + +pagePaths :: [String] +pagePaths = ["about.md", "contact.md"] + +postGlobs :: [String] +postGlobs = ["posts/*.typ"] diff --git a/app/Main.hs b/app/Main.hs index 6c875b8..ebab481 100755 --- a/app/Main.hs +++ b/app/Main.hs @@ -4,7 +4,7 @@ -- https://hackage.haskell.org/package/mustache-2.4.2/docs/doc-index.html -- {-# LANGUAGE ApplicativeDo, DataKinds, DeriveGeneric #-} -{-# LANGUAGE DerivingVia, LambdaCase, TypeApplications #-} +{-# LANGUAGE DerivingVia, TypeApplications #-} module Main where @@ -27,7 +27,9 @@ import qualified Development.Shake.FilePath as Shake import qualified Text.Mustache as Mus import qualified Text.Mustache.Compile as Mus import qualified Text.Pandoc as Pandoc - +import Config +import Utilities +import Templates -- target = thing we want -- Rule = pattern of thing being made + actions to produce the thing -- Action = actions to produce a thing @@ -39,8 +41,6 @@ main = Shake.shakeArgs Shake.shakeOptions $ do Shake.withTargetDocs "Clean the built site" $ "clean" ~> Shake.removeFilesAfter outputDir ["//*"] -outputDir :: String -outputDir = "publish" buildSite :: Action () buildSite = do @@ -59,6 +59,12 @@ buildSite = do -- remaining pages, index.xml = rss feed Shake.need $ map (outputDir ) ["index.html", "index.xml"] +buildRules :: Rules () +buildRules = do + assets + pages + posts + -- make a rule of the pattern outputDir/asset_name which copes from outputDir/../pages assets :: Rules () assets = map (outputDir ) assetGlobs |%> \target -> do @@ -66,36 +72,53 @@ assets = map (outputDir ) assetGlobs |%> \target -> do Shake.copyFileChanged src target Shake.putInfo $ "Copied " <> target <> " from " <> src -typstToHtml :: FilePath -> Action Text -typstToHtml filePath = do - content <- Shake.readFile' filePath - Shake.quietly . Shake.traced "Typst to HTML" $ do - doc <- runPandoc . Pandoc.readTypst readerOptions . T.pack $ content - - runPandoc . Pandoc.writeHtml5String writerOptions $ doc - where - readerOptions = - Pandoc.def {Pandoc.readerExtensions = Pandoc.pandocExtensions} - writerOptions = - Pandoc.def {Pandoc.writerExtensions = Pandoc.pandocExtensions} - data Page = Page {pageTitle :: Text, pageContent :: Text} deriving (Show, Generic) deriving (ToJSON) via PrefixedSnake "page" Page -assetGlobs :: [String] -assetGlobs = ["static/*"] +pages :: Rules () +pages = map indexHtmlOutputPath pagePaths |%> \target -> do + let src = indexHtmlSourcePath target + (meta, html) <- typstToHtml src -pagePaths :: [String] -pagePaths = ["about.md", "contact.md"] + let page = Page (meta HM.! "title") html + applyTemplateAndWrite "default.html" page target + Shake.putInfo $ "Built " <> target <> " from " <> src -postGlobs :: [String] -postGlobs = ["posts/*.typ"] +data Post = Post + { postTitle :: Text, + postAuthor :: Maybe Text, + postTags :: [Text], + postDate :: Maybe Text, + postContent :: Maybe Text, + postLink :: Maybe Text + } deriving (Show, Generic) + deriving (FromJSON, ToJSON) via PrefixedSnake "post" Post -runPandoc action = - Pandoc.runIO (Pandoc.setVerbosity Pandoc.ERROR >> action) - >>= either (fail . show) return +posts :: Rules () +posts = map indexHtmlOutputPath postGlobs |%> \target -> do + let src = indexHtmlSourcePath target + post <- readPost src + postHtml <- applyTemplate "post.html" post + + let page = Page (postTitle post) postHtml + applyTemplateAndWrite "default.html" page target + Shake.putInfo $ "Built " <> target <> " from " <> src + +readPost :: FilePath -> Action Post +readPost postPath = do + date <- parseTimeM False defaultTimeLocale "%Y-%-m-%-d" + . take 10 + . Shake.takeBaseName + $ postPath + let formattedDate = + T.pack $ formatTime @UTCTime defaultTimeLocale "%b %e, %Y" date + + (post, html) <- typstToHtml postPath + Shake.putInfo $ "Read " <> postPath + return $ post + { postDate = Just formattedDate, + postContent = Just html, + postLink = Just . T.pack $ "/" <> Shake.dropExtension postPath <> "/" + } -indexHtmlOutputPath :: FilePath -> FilePath -indexHtmlOutputPath srcPath = - outputDir Shake.dropExtension srcPath "index.html" diff --git a/app/Templates.hs b/app/Templates.hs new file mode 100644 index 0000000..60df609 --- /dev/null +++ b/app/Templates.hs @@ -0,0 +1,40 @@ +{-# LANGUAGE ApplicativeDo, DataKinds, DeriveGeneric #-} +{-# LANGUAGE DerivingVia, LambdaCase, TypeApplications #-} + +module Templates where +import Development.Shake +import Data.Aeson (ToJSON) +import Data.Text (Text) +import qualified Text.Mustache as Mus +import qualified Text.Mustache.Compile as Mus +import qualified Development.Shake as Shake +import qualified Data.Aeson as A +import qualified Data.Text as T +import Development.Shake.FilePath (()) + +applyTemplate :: ToJSON a => String -> a -> Text +applyTemplate templateName context = do + tmpl <- readTemplate $ "templates" templateName + case Mus.checkedSubstitute tmpl (A.toJSON context) of + ([], text) -> return text + (errs, _) -> fail $ + "Error while substituting template " <> templateName + <> ": " <> unlines (map show errs) + +applyTemplateAndWrite :: ToJSON a => String -> a -> FilePath -> Action () +applyTemplateAndWrite templateName context outputPath = + applyTemplate templateName context + >>= Shake.writeFile' outputPath . T.unpack + +readTemplate :: FilePath -> Action Mus.Template +readTemplate templatePath = do + Shake.need [templatePath] + eTemplate <- Shake.quietly + . Shake.traced "Compile template" + $ Mus.localAutomaticCompile templatePath + case eTemplate of + Right template -> do + Shake.need . Mus.getPartials . Mus.ast $ template + Shake.putInfo $ "Read " <> templatePath + return template + Left err -> fail $ show err diff --git a/app/Utilities.hs b/app/Utilities.hs new file mode 100644 index 0000000..fce2877 --- /dev/null +++ b/app/Utilities.hs @@ -0,0 +1,39 @@ +{-# LANGUAGE ApplicativeDo, DataKinds, DeriveGeneric #-} +{-# LANGUAGE DerivingVia, LambdaCase, TypeApplications #-} +module Utilities where +import Data.Text (Text) +import Development.Shake.FilePath ((<.>), ()) +import qualified Data.Text as T +import qualified Development.Shake as Shake +import qualified Development.Shake.FilePath as Shake +import qualified Text.Pandoc as Pandoc +import Config +import Development.Shake (Action) + +indexHtmlOutputPath :: FilePath -> FilePath +indexHtmlOutputPath srcPath = + outputDir Shake.dropExtension srcPath "index.html" + +indexHtmlSourcePath :: FilePath -> FilePath +indexHtmlSourcePath = + Shake.dropDirectory1 + . (<.> "md") + . Shake.dropTrailingPathSeparator + . Shake.dropFileName + +typstToHtml :: FilePath -> Action Text +typstToHtml filePath = do + content <- Shake.readFile' filePath + Shake.quietly . Shake.traced "Typst to HTML" $ do + doc <- runPandoc . Pandoc.readTypst readerOptions . T.pack $ content + + runPandoc . Pandoc.writeHtml5String writerOptions $ doc + where + readerOptions = + Pandoc.def {Pandoc.readerExtensions = Pandoc.pandocExtensions} + writerOptions = + Pandoc.def {Pandoc.writerExtensions = Pandoc.pandocExtensions} + +runPandoc action = + Pandoc.runIO (Pandoc.setVerbosity Pandoc.ERROR >> action) + >>= either (fail . show) return diff --git a/psb.cabal b/psb.cabal index 2e9a8e1..4341821 100644 --- a/psb.cabal +++ b/psb.cabal @@ -62,7 +62,7 @@ executable psb main-is: Main.hs -- Modules included in this executable, other than Main. - -- other-modules: + other-modules: Config Utilities Templates -- LANGUAGE extensions used by modules in this package. -- other-extensions: