seems to be working now
This commit is contained in:
parent
daeaf9b9ec
commit
8f8b33517a
5 changed files with 31 additions and 44 deletions
14
app/Main.hs
14
app/Main.hs
|
@ -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
|
||||||
{
|
{
|
||||||
|
|
|
@ -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)
|
||||||
|
|
|
@ -1,6 +1,3 @@
|
||||||
{-# LANGUAGE ApplicativeDo, DataKinds, DeriveGeneric #-}
|
|
||||||
{-# LANGUAGE DerivingVia, TypeApplications #-}
|
|
||||||
|
|
||||||
module Types where
|
module Types where
|
||||||
|
|
||||||
import Deriving.Aeson
|
import Deriving.Aeson
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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
|
||||||
|
|
Loading…
Reference in a new issue