{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedLabels #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
module Rib.Shake
(
buildHtmlMulti,
buildHtml,
readDocMulti,
buildStaticFiles,
Dirs (..),
)
where
import Data.Aeson
import Development.Shake
import Lucid (Html)
import qualified Lucid
import Named
import Path
import Path.IO
import Rib.Document
import Rib.Markup (Markup)
data Dirs = Dirs (Path Rel Dir, Path Rel Dir)
deriving (Typeable)
getDirs :: Action (Path Rel Dir, Path Rel Dir)
getDirs = getShakeExtra >>= \case
Just (Dirs d) -> return d
Nothing -> fail "Input output directories are not initialized"
ribInputDir :: Action (Path Rel Dir)
ribInputDir = fst <$> getDirs
ribOutputDir :: Action (Path Rel Dir)
ribOutputDir = do
output <- snd <$> getDirs
liftIO $ createDirIfMissing True output
return output
buildStaticFiles :: [Path Rel File] -> Action ()
buildStaticFiles staticFilePatterns = do
input <- ribInputDir
output <- ribOutputDir
files <- getDirectoryFiles' input staticFilePatterns
void $ forP files $ \f ->
copyFileChanged' (input </> f) (output </> f)
where
copyFileChanged' old new =
copyFileChanged (toFilePath old) (toFilePath new)
buildHtmlMulti ::
forall repr meta.
(Markup repr, FromJSON meta) =>
Path Rel File ->
(Document repr meta -> Html ()) ->
Action [Document repr meta]
buildHtmlMulti pat r = do
xs <- readDocMulti pat
void $ forP xs $ \x -> do
outfile <- liftIO $ replaceExtension ".html" $ documentPath x
buildHtml outfile (r x)
pure xs
readDocMulti ::
forall repr meta.
(Markup repr, FromJSON meta) =>
Path Rel File ->
Action [Document repr meta]
readDocMulti pat = do
input <- ribInputDir
fs <- getDirectoryFiles' input [pat]
forP fs $ \f -> do
need $ toFilePath <$> [input </> f]
result <-
runExceptT $
mkDocumentFrom
! #relpath f
! #path (input </> f)
case result of
Left e ->
fail $ "Error converting " <> toFilePath f <> " to HTML: " <> show e
Right v -> pure v
buildHtml :: Path Rel File -> Html () -> Action ()
buildHtml f html = do
output <- ribOutputDir
writeHtml (output </> f) html
where
writeHtml :: MonadIO m => Path b File -> Html () -> m ()
writeHtml p htmlVal =
writeFileLText (toFilePath p) $! Lucid.renderText htmlVal
getDirectoryFiles' :: Path b Dir -> [Path Rel File] -> Action [Path Rel File]
getDirectoryFiles' dir pat =
traverse (liftIO . parseRelFile) =<< getDirectoryFiles (toFilePath dir) (toFilePath <$> pat)