seems to be working now

This commit is contained in:
Pagwin 2024-08-01 01:50:40 -04:00
parent daeaf9b9ec
commit 8f8b33517a
No known key found for this signature in database
GPG key ID: 81137023740CA260
5 changed files with 31 additions and 44 deletions

View file

@ -4,8 +4,6 @@
-- https://hackage.haskell.org/package/pandoc-3.2.1/docs/doc-index-All.html -- https://hackage.haskell.org/package/pandoc-3.2.1/docs/doc-index-All.html
-- https://hackage.haskell.org/package/mustache-2.4.2/docs/doc-index.html -- https://hackage.haskell.org/package/mustache-2.4.2/docs/doc-index.html
-- --
{-# LANGUAGE ApplicativeDo, DataKinds, DeriveGeneric #-}
{-# LANGUAGE DerivingVia, TypeApplications #-}
module Main where module Main where
@ -70,8 +68,9 @@ assets = map (outputDir </>) assetGlobs |%> \target -> do
pages :: Rules () pages :: Rules ()
pages = map indexHtmlOutputPath pagePaths |%> \target -> do pages = map indexHtmlOutputPath pagePaths |%> \target -> do
let src = indexHtmlSourcePath target let src = indexHtmlSourcePath target
(meta, html) <- typstToHtml src let metaSrc = indexHtmlMetaPath target
html <- typstToHtml src
meta <- yamlToPost metaSrc
let page = Page (postTitle meta) html let page = Page (postTitle meta) html
applyTemplateAndWrite "default.html" page target applyTemplateAndWrite "default.html" page target
Shake.putInfo $ "Built " <> target <> " from " <> src Shake.putInfo $ "Built " <> target <> " from " <> src
@ -102,15 +101,14 @@ rss :: Rules ()
rss = outputDir </> "index.xml" %> \target -> do rss = outputDir </> "index.xml" %> \target -> do
postPaths <- Shake.getDirectoryFiles "" postGlobs postPaths <- Shake.getDirectoryFiles "" postGlobs
posts <- sortOn (Ord.Down . postDate) <$> forM postPaths readPost posts <- sortOn (Ord.Down . postDate) <$> forM postPaths readPost
-- figure out how to convert this into applyTemplateAndWrite applyTemplateAndWrite "feed.xml" (HM.singleton "posts" posts) target
feed <- applyTemplate "feed.xml" $ HM.singleton "posts" posts
Shake.putInfo $ "Built " <> target Shake.putInfo $ "Built " <> target
readPost :: FilePath -> Action Post readPost :: FilePath -> Action Post
readPost postPath = do readPost postPath = do
(post, html) <- typstToHtml postPath html <- typstToHtml postPath
Shake.putInfo $ show post post <- yamlToPost $ typstMetaPath postPath
Shake.putInfo $ "Read " <> postPath Shake.putInfo $ "Read " <> postPath
return $ post return $ post
{ {

View file

@ -1,6 +1,3 @@
{-# LANGUAGE ApplicativeDo, DataKinds, DeriveGeneric #-}
{-# LANGUAGE DerivingVia, LambdaCase, TypeApplications #-}
module Templates where module Templates where
import Development.Shake import Development.Shake
import Data.Aeson (ToJSON) import Data.Aeson (ToJSON)

View file

@ -1,6 +1,3 @@
{-# LANGUAGE ApplicativeDo, DataKinds, DeriveGeneric #-}
{-# LANGUAGE DerivingVia, TypeApplications #-}
module Types where module Types where
import Deriving.Aeson import Deriving.Aeson

View file

@ -1,20 +1,17 @@
{-# LANGUAGE ApplicativeDo, DataKinds, NamedFieldPuns #-}
{-# LANGUAGE DerivingVia, LambdaCase, TypeApplications #-}
module Utilities where module Utilities where
import Data.Text (Text) import Data.Text (Text)
import Development.Shake.FilePath ((<.>), (</>)) import Development.Shake.FilePath ((<.>), (</>))
import qualified Data.Text as T import qualified Data.Text as T
import Data.Yaml.Aeson
import qualified Development.Shake as Shake import qualified Development.Shake as Shake
import qualified Development.Shake.FilePath as Shake import qualified Development.Shake.FilePath as Shake
import qualified Text.Pandoc as Pandoc import qualified Text.Pandoc as Pandoc
import Config import Config
import Development.Shake (Action) import Development.Shake (Action)
import Text.Pandoc
import Data.Aeson as A
import Data.Time (UTCTime(UTCTime), formatTime, defaultTimeLocale, parseTimeM)
import Types import Types
import Data.Maybe (fromJust) import Data.Maybe (fromMaybe)
import Data.Time
indexHtmlOutputPath :: FilePath -> FilePath indexHtmlOutputPath :: FilePath -> FilePath
indexHtmlOutputPath srcPath = indexHtmlOutputPath srcPath =
@ -27,42 +24,40 @@ indexHtmlSourcePath =
. Shake.dropTrailingPathSeparator . Shake.dropTrailingPathSeparator
. Shake.dropFileName . Shake.dropFileName
typstToHtml :: FilePath -> Action (Post, Text) indexHtmlMetaPath :: FilePath -> FilePath
indexHtmlMetaPath = typstMetaPath . indexHtmlSourcePath
typstMetaPath :: FilePath -> FilePath
typstMetaPath typstPath = Shake.dropExtension typstPath <.> "yaml"
typstToHtml :: FilePath -> Action Text
typstToHtml filePath = do typstToHtml filePath = do
content <- Shake.readFile' filePath content <- Shake.readFile' filePath
Shake.quietly . Shake.traced "Typst to HTML" $ do Shake.quietly . Shake.traced "Typst to HTML" $ do
doc@(Pandoc meta _) <- runPandoc . Pandoc.readTypst readerOptions . T.pack $ content doc <- runPandoc . Pandoc.readTypst readerOptions . T.pack $ content
meta' <- fromMeta meta
let dateTransformedMeta = dateTransform meta'
html <- runPandoc . Pandoc.writeHtml5String writerOptions $ doc html <- runPandoc . Pandoc.writeHtml5String writerOptions $ doc
return (fromJust dateTransformedMeta, html) return html
where where
readerOptions = readerOptions =
Pandoc.def {Pandoc.readerExtensions = Pandoc.pandocExtensions} Pandoc.def {Pandoc.readerExtensions = Pandoc.pandocExtensions}
writerOptions = writerOptions =
Pandoc.def {Pandoc.writerExtensions = Pandoc.pandocExtensions} Pandoc.def {Pandoc.writerExtensions = Pandoc.pandocExtensions}
fromMeta (Meta meta) =
A.fromJSON . A.toJSON <$> traverse metaValueToJSON meta >>= \case
Success res -> pure res
Error err -> fail $ "json conversion error:" <> err
metaValueToJSON = \case
MetaMap m -> A.toJSON <$> traverse metaValueToJSON m
MetaList m -> A.toJSONList <$> traverse metaValueToJSON m
MetaBool m -> pure $ A.toJSON m
MetaString m -> pure $ A.toJSON $ T.strip m
MetaInlines m -> metaValueToJSON $ MetaBlocks [Plain m]
MetaBlocks m ->
fmap (A.toJSON . T.strip)
. runPandoc
. Pandoc.writePlain Pandoc.def
$ Pandoc mempty m
runPandoc action = runPandoc action =
Pandoc.runIO (Pandoc.setVerbosity Pandoc.ERROR >> action) Pandoc.runIO (Pandoc.setVerbosity Pandoc.ERROR >> action)
>>= either (fail . show) return >>= either (fail . show) return
yamlToPost :: FilePath -> Action Post
yamlToPost path = do
post <- decodeFileThrow path
let post' = dateTransform post
return $ fromMaybe post post'
where
dateTransform post@(Post{postDate}) = do dateTransform post@(Post{postDate}) = do
postDate' <- dateStrTransform $ T.unpack $ fromJust postDate postDate' <- postDate
let postDate'' = dateStrTransform $ T.unpack postDate'
Just post { Just post {
postDate = Just postDate' postDate = postDate''
} }
dateStrTransform date = do dateStrTransform date = do
date' <- parseTimeM False defaultTimeLocale "%Y-%-m-%-d" date date' <- parseTimeM False defaultTimeLocale "%Y-%-m-%-d" date

View file

@ -65,10 +65,10 @@ executable psb
other-modules: Config Utilities Templates Types other-modules: Config Utilities Templates Types
-- LANGUAGE extensions used by modules in this package. -- LANGUAGE extensions used by modules in this package.
-- other-extensions: default-extensions: ApplicativeDo DataKinds NamedFieldPuns DerivingVia LambdaCase TypeApplications DeriveGeneric
-- Other library packages from which modules are imported. -- Other library packages from which modules are imported.
build-depends: base ^>=4.17.2.1, mustache ^>=2.4.2, pandoc ^>=3.2.1, shake ^>= 0.19.8, deriving-aeson ^>= 0.2.9, aeson, text, time, unordered-containers build-depends: base ^>=4.17.2.1, mustache ^>=2.4.2, pandoc ^>=3.2.1, shake ^>= 0.19.8, deriving-aeson ^>= 0.2.9, aeson, text, time, unordered-containers, yaml
-- Directories containing source files. -- Directories containing source files.
hs-source-dirs: app hs-source-dirs: app