-- |
-- Description: Functions related to Hakyll compilers used by other modules for this website.
-- Copyright: Copyright (C) 2023 Yoo Chung
-- License: All rights reserved
-- Maintainer: web@chungyc.org
--
-- Various Hakyll compilers and functions to assist use of Hakyll compilers.
module Web.Site.Compilers
  ( -- * Compilers
    haskellCompiler,

    -- * Pandoc options

    -- | Pandoc reader and writer options that can be used with 'pandocCompilerWith'.
    mathReaderWith,
    mathWriterWith,
    getTocOptionsWith,

    -- * Custom contexts
    siteContext,

    -- * Utilities
    cleanupIndexUrl,
  )
where

import Data.ByteString.Lazy (ByteString)
import Hakyll
import Text.Pandoc (compileTemplate, runPure, runWithDefaultPartials)
import Text.Pandoc.Options

-- $setup
-- >>> :set -XOverloadedStrings
-- >>> import Data.ByteString.Lazy
-- >>> import Hakyll

-- |
-- Run the Haskell code in the underlying file and use its output.
--
-- For example,
--
-- >>> let _ = compile $ haskellCompiler []
--
-- The Haskell code will be executed using @runhaskell@.
-- It will run with @-XGHC2021@ and @-XOverloadedStrings@.
--
-- Extra flags can also be passed to @runhaskell@.
-- For example,
--
-- >>> let _ = compile $ haskellCompiler ["-XTypeFamilies"]
--
-- This can compile both Haskell code and literate Haskell code.
haskellCompiler ::
  -- | Extra flags to pass to @runhaskell@.
  [String] ->
  Compiler (Item ByteString)
haskellCompiler :: [String] -> Compiler (Item ByteString)
haskellCompiler [String]
args = do
  file <- Compiler String
getResourceFilePath
  emptyItem >>= withItemBody (run file)
  where
    -- Run the Haskell code in the given file and return its standard output.
    run :: String -> ByteString -> Compiler ByteString
run String
f = String -> [String] -> ByteString -> Compiler ByteString
unixFilterLBS String
"runhaskell" ([String] -> ByteString -> Compiler ByteString)
-> [String] -> ByteString -> Compiler ByteString
forall a b. (a -> b) -> a -> b
$ [[String]] -> [String]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[String]
defaultArgs, [String]
args, [String
f]]

    -- Default flags to always use with @runhaskell@.
    defaultArgs :: [String]
defaultArgs = [String
"-XGHC2021", String
"-XOverloadedStrings"]

    -- We will run the code from the file directly,
    -- so we don't care about any content in an item.
    emptyItem :: Compiler (Item ByteString)
emptyItem = ByteString -> Compiler (Item ByteString)
forall a. a -> Compiler (Item a)
makeItem ByteString
""

-- |
-- Add support for properly parsing math in the reader options.
--
-- Should be used in conjunction with 'mathWriterWith' for proper math rendering.
-- For example:
--
-- >>> let readerOptions = mathReaderWith defaultHakyllReaderOptions
-- >>> let writerOptions = mathWriterWith defaultHakyllWriterOptions
-- >>> let _ = pandocCompilerWith readerOptions writerOptions
mathReaderWith :: ReaderOptions -> ReaderOptions
mathReaderWith :: ReaderOptions -> ReaderOptions
mathReaderWith ReaderOptions
options =
  ReaderOptions
options
    { readerExtensions =
        readerExtensions options
          <> extensionsFromList
            [ Ext_tex_math_single_backslash,
              Ext_tex_math_double_backslash,
              Ext_tex_math_dollars,
              Ext_latex_macros
            ]
    }

-- |
-- Add support for writing out math to HTML in the writer options.
--
-- Should be used in conjunction with 'mathReaderWith'
-- to read input that is to be rendered as math.
-- For example:
--
-- >>> let readerOptions = mathReaderWith defaultHakyllReaderOptions
-- >>> let writerOptions = mathWriterWith defaultHakyllWriterOptions
-- >>> let _ = pandocCompilerWith readerOptions writerOptions
--
-- Pages which use math should define the @include-math@ metadata field
-- to ensure that the resources necessary for rendering math is included.
mathWriterWith :: WriterOptions -> WriterOptions
mathWriterWith :: WriterOptions -> WriterOptions
mathWriterWith WriterOptions
options =
  WriterOptions
options
    { -- We use KaTeX to render math, but the auto-render extension depends
      -- on how Pandoc writes out math in MathJax.  It does not work with
      -- how Pandoc writes out math in KaTeX.
      writerHTMLMathMethod = MathJax ""
    }

-- |
-- Rewrite the writer options to include a table of contents
-- if the source has a @toc@ field in its metadata.
-- If there is no such field, the given writer options are returned as is.
--
-- For example:
--
-- >>> let _ = getTocOptionsWith defaultHakyllWriterOptions
getTocOptionsWith :: WriterOptions -> Compiler WriterOptions
getTocOptionsWith :: WriterOptions -> Compiler WriterOptions
getTocOptionsWith WriterOptions
options = do
  identifier <- Compiler Identifier
getUnderlying
  tocField <- getMetadataField identifier "toc"
  return $ getOptions tocField
  where
    getOptions :: Maybe String -> WriterOptions
getOptions Maybe String
Nothing = WriterOptions
options
    getOptions (Just String
_) =
      WriterOptions
options
        { writerTableOfContents = True,
          writerTOCDepth = 3,
          writerTemplate = tocTemplate
        }

    -- Pandoc metadata is not Hakyll metadata,
    -- so Pandoc has to take care of writing out the table of contents,
    -- instead of Hakyll being able to write it out with its own templates.
    tocTemplate :: Maybe (Template Text)
tocTemplate
      | Right (Right Template Text
t) <- Text -> Either PandocError (Either String (Template Text))
build Text
templateSource = Template Text -> Maybe (Template Text)
forall a. a -> Maybe a
Just Template Text
t
      | Bool
otherwise = Maybe (Template Text)
forall a. Maybe a
Nothing
    build :: Text -> Either PandocError (Either String (Template Text))
build = PandocPure (Either String (Template Text))
-> Either PandocError (Either String (Template Text))
forall a. PandocPure a -> Either PandocError a
runPure (PandocPure (Either String (Template Text))
 -> Either PandocError (Either String (Template Text)))
-> (Text -> PandocPure (Either String (Template Text)))
-> Text
-> Either PandocError (Either String (Template Text))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WithDefaultPartials PandocPure (Either String (Template Text))
-> PandocPure (Either String (Template Text))
forall (m :: * -> *) a. WithDefaultPartials m a -> m a
runWithDefaultPartials (WithDefaultPartials PandocPure (Either String (Template Text))
 -> PandocPure (Either String (Template Text)))
-> (Text
    -> WithDefaultPartials PandocPure (Either String (Template Text)))
-> Text
-> PandocPure (Either String (Template Text))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String
-> Text
-> WithDefaultPartials PandocPure (Either String (Template Text))
forall (m :: * -> *) a.
(TemplateMonad m, TemplateTarget a) =>
String -> Text -> m (Either String (Template a))
compileTemplate String
""
    templateSource :: Text
templateSource = Text
"<nav class='toc'><h2>Contents</h2>\n$toc$\n</nav>\n$body$"

-- | Default context used for the site.
-- Adds customizations specific to this site to "defaultContext".
-- In particular,
--
-- * Cleans @index.html@ URLs into directory URLs ending with @/@.
--
-- Use this when compiling items for this site instead of "defaultContext".
siteContext :: Context String
siteContext :: Context String
siteContext = String -> (Item String -> Compiler String) -> Context String
forall a. String -> (Item a -> Compiler String) -> Context a
field String
"url" Item String -> Compiler String
forall {a}. Item a -> Compiler String
clean Context String -> Context String -> Context String
forall a. Semigroup a => a -> a -> a
<> Context String
defaultContext
  where
    -- Clean up "index.html" from URLs.
    clean :: Item a -> Compiler String
clean Item a
item = do
      path <- Identifier -> Compiler (Maybe String)
getRoute (Item a -> Identifier
forall a. Item a -> Identifier
itemIdentifier Item a
item)
      case path of
        Maybe String
Nothing -> String -> Compiler String
forall a. String -> Compiler a
noResult String
"no route for identifier"
        Just String
s -> String -> Compiler String
forall a. a -> Compiler a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (String -> Compiler String)
-> (String -> String) -> String -> Compiler String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
cleanupIndexUrl (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
toUrl (String -> Compiler String) -> String -> Compiler String
forall a b. (a -> b) -> a -> b
$ String
s

-- |
-- If the given URL is local and ends with @index.html@, strip the latter.
--
-- For example:
--
-- >>> cleanupIndexUrl "/article/index.html"
-- "/article/"
-- >>> cleanupIndexUrl "/article/page.html"
-- "/article/page.html"
-- >>> cleanupIndexUrl "http://chungyc.org/article/index.html"
-- "http://chungyc.org/article/index.html"
--
-- URLs are cleaned up by default with "siteContext",
-- so one will usually not call this directly.
cleanupIndexUrl :: String -> String
cleanupIndexUrl :: String -> String
cleanupIndexUrl url :: String
url@(Char
'/' : String
_)
  | Maybe String
Nothing <- Maybe String
prefix = String
url
  | Just String
s <- Maybe String
prefix = String
s
  where
    prefix :: Maybe String
prefix = String -> String -> Maybe String
needlePrefix String
"index.html" String
url
cleanupIndexUrl String
url = String
url