srid/rib
1
1
Fork 0
mirror of https://github.com/srid/rib.git synced 2024-11-30 13:52:53 +03:00
Code Issues Projects Releases Wiki Activity

Merge pull request #65 from srid/custom-markup

Browse Source 
Vastly simplify API, so users can use custom parsers
This commit is contained in:
Sridhar Ratnakumar 2019-12-29 20:51:21 -05:00 committed by GitHub
commit dd64cc5a33
No known key found for this signature in database
GPG Key ID: 4AEE18F83AFDEB23
12 changed files with 236 additions and 407 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

7
CHANGELOG.md
View File

@ -2,11 +2,12 @@
## 0.6.0.0 - UNRELEASED
- API: Allow multiple parsers in the same static site
- Changes API of `Rib.buildHtmlMulti`, to use `Data.Some`
- Changes the `documentVal` of `Document` type, to use `Data.Dependent.DSum`
- Significant API simplication: no more type class!
- Allows user to specify their own markup parser as a Haskell function
- Dropped namings "Document" and "Markup" in favour of "Source"
- API: Expose `ribInputDir` and `ribOutputDir` for use in custom Shake actions
- Fix #63: create intermediate directories when generating post HTML
- Advance nixpkgs; require Shake >=0.18.4
## 0.5.0.0

85
README.md
View File

@ -10,14 +10,11 @@ Rib is a Haskell library for writing your own **static site generator**.
How does it compare to Hakyll?
- Use the [Shake](https://shakebuild.com/) build system
- Builtin support for using Haskell DSL to define the HTML
([Lucid](https://chrisdone.com/posts/lucid2/)) & CSS
([Clay](http://fvisser.nl/clay/)) of your site
- Like Hakyll, Rib uses [Pandoc](https://pandoc.org/) for parsing the source
documents. It also supports [MMark](https://github.com/mmark-md/mmark) if you need a lightweight alternative.
- Remain as simple as possible to use (see example below)
- Optional Nix based workflow for easily reproducible environment
- At its core, uses the [Shake](https://shakebuild.com/) build system.
- Allows writing Haskell DSL to define HTML ([Lucid](https://chrisdone.com/posts/lucid2/)) & CSS ([Clay](http://fvisser.nl/clay/)).
- Support for [Pandoc](https://pandoc.org/) (like Hakyll) and [MMark](https://github.com/mmark-md/mmark) (or your custom parser function).
- Remain as simple as possible to use (see example below).
- Optional but recommended Nix-based workflow for easily reproducible environment.
Rib prioritizes the use of *existing* tools over reinventing them, and enables
the user to compose them as they wish instead of having to write code to fit a
@ -42,24 +39,20 @@ Here is how your code may look like if you were to generate your static site
using Rib:
``` haskell
-- First we shall define two datatypes to represent our pages. One, the page
-- itself. Second, the metadata associated with each document.
-- | A generated page is either an index of documents, or an individual document.
-- | A generated page corresponds to either an index of sources, or an
-- individual source.
--
-- `DocMeta` is the metadata type associated with documents.
-- Each `Source` specifies the parser type to use. Rib provides `MMark` and
-- `Pandoc`; but you may define your own as well.
data Page
= -- | Index page, containing a list of documents.
Page_Index [Document DocMeta]
| -- | Individual page associated with a document
Page_Doc (Document DocMeta)
= Page_Index [Source M.MMark]
| Page_Single (Source M.MMark)
-- | Type representing the metadata in our Markdown documents
--
-- Optional fields are of kind Maybe. Other fields must be present.
data DocMeta
= DocMeta
-- | Metadata in our markdown sources. Parsed as JSON.
data SrcMeta
= SrcMeta
{ title :: Text,
-- | Description is optional, hence it is a `Maybe`
description :: Maybe Text
}
deriving (Show, Eq, Generic, FromJSON)
@ -82,19 +75,17 @@ main = Rib.run [reldir|a|] [reldir|b|] generateSite
generateSite = do
-- Copy over the static files
Rib.buildStaticFiles [[relfile|static/**|]]
-- Build individual markup sources, generating .html for each.
docs <-
Rib.buildHtmlMulti patterns $
renderPage . Page_Doc
-- Build individual sources, generating .html for each.
-- The function `buildHtmlMulti` takes the following arguments:
-- - File patterns to build
-- - Function that will parse the file (here we use mmark)
-- - Function that will generate the HTML (see below)
srcs <-
Rib.buildHtmlMulti [[relfile|*.md|]] M.parseIO $
renderPage . Page_Single
-- Build an index.html linking to the aforementioned files.
Rib.buildHtml [relfile|index.html|]
$ renderPage
$ Page_Index docs
-- File patterns to build, using the associated markup parser
patterns =
Map.fromList
[ ([relfile|*.md|], Some Rib.Markup_MMark)
]
Rib.buildHtml [relfile|index.html|] $
renderPage (Page_Index srcs)
-- Define your site HTML here
renderPage :: Page -> Html ()
renderPage page = with html_ [lang_ "en"] $ do
@ -102,7 +93,7 @@ main = Rib.run [reldir|a|] [reldir|b|] generateSite
meta_ [httpEquiv_ "Content-Type", content_ "text/html; charset=utf-8"]
title_ $ case page of
Page_Index _ -> "My website!"
Page_Doc doc -> toHtml $ title $ Rib.documentMeta doc
Page_Single src -> toHtml $ title $ getMeta src
style_ [type_ "text/css"] $ Clay.render pageStyle
body_
$ with div_ [id_ "thesite"]
@ -110,16 +101,22 @@ main = Rib.run [reldir|a|] [reldir|b|] generateSite
with a_ [href_ "/"] "Back to Home"
hr_ []
case page of
Page_Index docs ->
div_ $ forM_ docs $ \doc -> with li_ [class_ "links"] $ do
let meta = Rib.documentMeta doc
b_ $ with a_ [href_ (Rib.documentUrl doc)] $ toHtml $ title meta
maybe mempty Rib.renderMarkdown $
description meta
Page_Doc doc ->
Page_Index srcs ->
div_ $ forM_ srcs $ \src -> with li_ [class_ "links"] $ do
let meta = getMeta src
b_ $ with a_ [href_ (Rib.sourceUrl src)] $ toHtml $ title meta
maybe mempty (M.render . either (error . T.unpack) id . M.parsePure "<desc>") $ description meta
Page_Single src ->
with article_ [class_ "post"] $ do
h1_ $ toHtml $ title $ Rib.documentMeta doc
Rib.documentHtml doc
h1_ $ toHtml $ title $ getMeta src
M.render $ Rib.sourceVal src
-- Get metadata from Markdown YAML block
getMeta :: Source M.MMark -> SrcMeta
getMeta src = case M.projectYaml (Rib.sourceVal src) of
Nothing -> error "No YAML metadata"
Just val -> case fromJSON val of
Aeson.Error e -> error $ "JSON error: " <> e
Aeson.Success v -> v
-- Define your site CSS here
pageStyle :: Css
pageStyle = "div#thesite" ? do

33
default.nix
View File

@ -1,5 +1,5 @@
# Use https://howoldis.herokuapp.com/ to find the next hash to update nixpkgs to.
{ pkgs ? import (builtins.fetchTarball "https://github.com/nixos/nixpkgs/archive/58fb23f72ad.tar.gz") {}
{ pkgs ? import (builtins.fetchTarball "https://github.com/nixos/nixpkgs/archive/af57b17404e.tar.gz") {}
, compiler ? "default"
, root ? ./.
, name ? "rib"
@ -15,10 +15,19 @@ let
h = pkgs.haskell.lib;
githubRepo = fq: rev:
builtins.fetchTarball ("https://github.com/" + fq + "/archive/" + rev + ".tar.gz");
pp = githubRepo "quchen/prettyprinter" "v1.5.1";
ppUnpackSymlinks = hp: pkgs.haskell.lib.overrideCabal hp (drv: {
postUnpack = ''
cp --remove-destination ${pp}/prettyprinter/misc/version-compatibility-macros.h $sourceRoot/misc/
cp --remove-destination ${pp}/prettyprinter/LICENSE.md $sourceRoot/
cp --remove-destination ${pp}/prettyprinter/README.md $sourceRoot/
'';
});
justBuild = p: h.dontHaddock (h.dontCheck p);
in
haskellPackages.developPackage {
root = root;
name = name;
inherit root name;
source-overrides = {
rib = ./.;
# Override haskell packages here:
@ -28,8 +37,6 @@ haskellPackages.developPackage {
githubRepo "mmark-md/mmark" "8f5534d";
mmark-ext =
githubRepo "mmark-md/mmark-ext" "4d1c40e";
named =
githubRepo "monadfix/named" "e684a00";
pandoc-include-code =
githubRepo "owickstrom/pandoc-include-code" "7e4d9d9";
path =
@ -38,14 +45,30 @@ haskellPackages.developPackage {
githubRepo "mrkkrp/path-io" "84ce6a2";
relude =
githubRepo "kowainik/relude" "bfb5f60";
# Not used in rib; but useful to have for users of the library.
dependent-sum =
let dsum = githubRepo "mokus0/dependent-sum" "5ab6d81"; in "${dsum}/dependent-sum";
some = githubRepo "phadej/some" "7e2a9ef5352097954a3a416a5ef12bc35b0d53db"; # 1.0.0.3
# Dhall, and its dependency overrides
# TODO: So many overrides ... might have to provide cachix cache.
dhall =
let dhallHaskell = githubRepo "dhall-lang/dhall-haskell" "1.28.0";
in "${dhallHaskell}/dhall";
atomic-write = githubRepo "stackbuilders/atomic-write" "v0.2.0.7";
generic-random = githubRepo "lysxia/generic-random" "1.3.0.0";
prettyprinter = "${pp}/prettyprinter";
} // source-overrides;
overrides = self: super: {
clay = h.dontCheck super.clay;
path = h.dontCheck super.path;
path-io = h.doJailbreak super.path-io; # Override hardcoded dependency on path ==0.6.*
some = h.doJailbreak super.some;
relude = h.dontCheck super.relude;
prettyprinter = h.dontCheck (ppUnpackSymlinks super.prettyprinter);
dhall = h.dontCheck super.dhall;
rib = justBuild super.rib;
};
modifier =
let

11
rib.cabal
View File

@ -25,13 +25,12 @@ library
exposed-modules:
Rib
Rib.App
Rib.Document
Rib.Markup.MMark
Rib.Markup.Pandoc
Rib.Source
Rib.Parser.MMark
Rib.Parser.Pandoc
Rib.Shake
other-modules:
Prelude
Rib.Markup
Rib.Server
hs-source-dirs: src
default-language: Haskell2010
@ -47,7 +46,6 @@ library
clay >=0.13.1 && <0.14,
cmdargs >=0.10.20 && <0.11,
containers >=0.6.0 && <0.7,
dependent-sum,
directory >= 1.0 && <2.0,
exceptions,
foldl,
@ -58,14 +56,13 @@ library
mmark-ext,
modern-uri,
mtl >=2.2.2 && <2.3,
named,
pandoc >=2.7 && <3,
pandoc-include-code >=1.4.0 && <1.5,
pandoc-types >=1.17.5 && <1.18,
path >= 0.7.0,
path-io,
relude >= 0.6 && < 0.7,
shake,
shake >= 0.18.4,
text >=1.2.3 && <1.3,
wai >=3.2.2 && <3.3,
wai-app-static >=3.1.6 && <3.2,

22
src/Rib.hs
View File

@ -2,20 +2,18 @@
module Rib
( module Rib.App,
module Rib.Shake,
Document,
documentPath,
documentVal,
documentHtml,
documentMeta,
documentUrl,
Markup (..),
renderMarkdown,
renderPandoc,
Source,
SourceReader,
sourcePath,
sourceVal,
sourceUrl,
MMark,
Pandoc,
)
where
import Rib.App
import Rib.Document
import Rib.Markup.MMark (renderMarkdown)
import Rib.Markup.Pandoc (renderPandoc)
import Rib.Source
import Rib.Parser.MMark (MMark)
import Rib.Parser.Pandoc (Pandoc)
import Rib.Shake

1
src/Rib/App.hs
View File

@ -97,6 +97,7 @@ runWith src dst buildAction = \case
shakeOptions
{ shakeVerbosity = Chatty,
shakeRebuild = bool [] [(RebuildNow, "**")] fullGen,
shakeLintInside = [toFilePath src, toFilePath dst],
shakeExtra = addShakeExtra (Dirs (src, dst)) (shakeExtra shakeOptions)
}
in shakeForward opts buildAction

135
src/Rib/Document.hs
View File

@ -1,135 +0,0 @@
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedLabels #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE Rank2Types #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE ViewPatterns #-}
module Rib.Document
( -- * Document type
Document,
Markup (..),
mkDocumentFrom,
-- * Document properties
documentPath,
documentVal,
documentHtml,
documentMeta,
documentUrl,
)
where
import Control.Monad.Except hiding (fail)
import Data.Aeson
import Data.Dependent.Sum
import Data.Some
import Development.Shake.FilePath ((-<.>))
import Lucid (Html)
import Named
import Path hiding ((-<.>))
import Rib.Markup
import Rib.Markup.MMark ()
import Rib.Markup.Pandoc ()
import qualified Text.Show
-- | A document generated from a Markup source file.
data Document meta
= Document
{ -- | Path to the document; relative to the source directory.
_document_path :: Path Rel File,
-- | Parsed representation of the document.
_document_val :: DSum Markup Identity,
-- | HTML rendering of the parsed representation.
_document_html :: Html (),
-- | The parsed metadata.
_document_meta :: meta
}
deriving (Generic)
documentPath :: Document meta -> Path Rel File
documentPath = _document_path
documentVal :: Document meta -> DSum Markup Identity
documentVal = _document_val
documentHtml :: Document meta -> Html ()
documentHtml = _document_html
documentMeta :: Document meta -> meta
documentMeta = _document_meta
-- | Return the URL for the given @.html@ file under serve directory
--
-- File path must be relative to the serve directory.
--
-- You may also pass source paths as long as they map directly to destination
-- path except for file extension.
documentUrl :: Document meta -> Text
documentUrl doc = toText $ toFilePath ([absdir|/|] </> (documentPath doc)) -<.> ".html"
data DocumentError
= DocumentError_MarkupError Text
| DocumentError_MetadataMissing
| DocumentError_MetadataMalformed Text
instance Show DocumentError where
show = \case
DocumentError_MarkupError e -> toString e
DocumentError_MetadataMissing -> "Metadata missing"
DocumentError_MetadataMalformed msg -> "Bad metadata JSON: " <> toString msg
-- | Parse, render to HTML and extract metadata from the given file.
--
-- Return the Document type containing converted values.
mkDocumentFrom ::
forall m b meta.
(MonadError DocumentError m, MonadIO m, FromJSON meta) =>
-- | Which Markup parser to use
Some Markup ->
-- | File path, used only to identify (not access) the document
"relpath" :! Path Rel File ->
-- | Actual file path, for access and reading
"path" :! Path b File ->
m (Document meta)
mkDocumentFrom mp k@(arg #relpath -> k') f = do
v <-
liftEither . first DocumentError_MarkupError
=<< withSomeMarkup (readDoc k f) mp
html <-
liftEither . first DocumentError_MarkupError $
withMarkup renderDoc v
metaValue <-
liftEither . (first DocumentError_MetadataMalformed)
=<< maybeToEither DocumentError_MetadataMissing (withMarkup extractMeta v)
meta <-
liftEither . first (DocumentError_MetadataMalformed . toText) $
resultToEither (fromJSON metaValue)
pure $ Document k' v html meta
where
maybeToEither e = liftEither . maybeToRight e
resultToEither = \case
Error e -> Left e
Success v -> Right v
withMarkup :: (forall doc. IsMarkup doc => doc -> a) -> DSum Markup Identity -> a
withMarkup f = \case
Markup_Pandoc :=> Identity doc -> f doc
Markup_MMark :=> Identity doc -> f doc
withSomeMarkup ::
forall f f1.
(Functor f, Functor f1) =>
(forall doc. IsMarkup doc => f (f1 doc)) ->
Some Markup ->
f (f1 (DSum Markup Identity))
withSomeMarkup g = \case
Some Markup_Pandoc -> fmap (Markup_Pandoc ==>) <$> g
Some Markup_MMark -> fmap (Markup_MMark ==>) <$> g

60
src/Rib/Markup.hs
View File

@ -1,60 +0,0 @@
{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
module Rib.Markup
( -- * Type class
IsMarkup (..),
Markup (..),
)
where
import Data.Aeson (Value)
import Lucid (Html)
import Named
import Path
import Text.MMark (MMark)
import Text.Pandoc (Pandoc)
-- A light-weight markup document structure
data Markup doc where
Markup_Pandoc :: Markup Pandoc
Markup_MMark :: Markup MMark
-- | Class for denoting Markup representations.
--
-- See `Rib.Markup.Pandoc` and `Rib.Markup.MMark` for two available instances.
class IsMarkup repr where
-- | Parse the given markup text
parseDoc ::
-- | File path, used to identify the document only.
Path Rel File ->
-- | Markup text to parse
Text ->
Either Text repr
-- | Like `parseDoc` but take the actual filepath instead of text.
readDoc ::
forall m b.
MonadIO m =>
-- | File path, used to identify the document only.
"relpath" :! Path Rel File ->
-- | Actual path to the file to parse.
"path" :! Path b File ->
m (Either Text repr)
extractMeta ::
repr ->
Maybe (Either Text Value)
-- | Render the document as Lucid HTML
renderDoc ::
repr ->
Either Text (Html ())

40
src/Rib/Markup/MMark.hs → src/Rib/Parser/MMark.hs
View File

@ -1,20 +1,23 @@
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
-- Suppressing orphans warning for `Markup MMark` instance
module Rib.Parser.MMark
( -- * Parsing
parsePure,
parseIO,
module Rib.Markup.MMark
( -- * Manual rendering
renderMarkdown,
-- * Rendering
render,
-- * Extracting information
getFirstImg,
projectYaml,
-- * Re-exports
MMark,
@ -22,37 +25,26 @@ module Rib.Markup.MMark
where
import Control.Foldl (Fold (..))
import Control.Monad.Except
import Lucid (Html)
import Named
import Path
import Rib.Markup
import Text.MMark (MMark)
import Text.MMark (MMark, projectYaml)
import qualified Text.MMark as MMark
import qualified Text.MMark.Extension as Ext
import qualified Text.MMark.Extension.Common as Ext
import qualified Text.Megaparsec as M
import Text.URI (URI)
instance IsMarkup MMark where
-- | Render a MMark document as HTML
render :: MMark -> Html ()
render = MMark.render
parseDoc f s = case MMark.parse (toFilePath f) s of
parsePure :: FilePath -> Text -> Either Text MMark
parsePure k s = case MMark.parse k s of
Left e -> Left $ toText $ M.errorBundlePretty e
Right doc -> Right $ MMark.useExtensions exts $ useTocExt doc
readDoc (Arg k) (Arg f) = do
content <- readFileText (toFilePath f)
pure $ parseDoc k content
extractMeta = fmap Right . MMark.projectYaml
renderDoc = Right . MMark.render
-- | Parse and render the markup directly to HTML
renderMarkdown :: Text -> Html ()
renderMarkdown s = either error id $ runExcept $ do
doc <- liftEither $ parseDoc @MMark [relfile|<memory>.md|] s
liftEither $ renderDoc doc
parseIO :: MonadIO m => Path b File -> m (Either Text MMark)
parseIO f = parsePure (toFilePath f) <$> readFileText (toFilePath f)
-- | Get the first image in the document if one exists
getFirstImg :: MMark -> Maybe URI

115
src/Rib/Markup/Pandoc.hs → src/Rib/Parser/Pandoc.hs
View File

@ -1,23 +1,22 @@
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
-- Suppressing orphans warning for `Markup Pandoc` instance
-- | Helpers for working with Pandoc documents
module Rib.Markup.Pandoc
( -- * Manual rendering
renderPandoc,
module Rib.Parser.Pandoc
( -- * Parsing
PandocFormat (..),
parsePure,
parseIO,
-- * Rendering
render,
renderPandocInlines,
-- * Extracting information
extractMeta,
getH1,
getFirstImg,
@ -29,74 +28,61 @@ where
import Control.Monad.Except
import Data.Aeson
import Lucid (Html, toHtmlRaw)
import Named
import Path
import Relude.Extra.Map ((!?))
import Rib.Markup
import Text.Pandoc
import Text.Pandoc.Filter.IncludeCode (includeCode)
import Text.Pandoc.Walk (query, walkM)
import qualified Text.Show
data RibPandocError
= RibPandocError_PandocError PandocError
| RibPandocError_UnknownFormat UnknownExtension
-- | List of formats supported by Pandoc
--
-- TODO: Complete this list.
data PandocFormat
= PandocFormat_Markdown
| PandocFormat_RST
instance Show RibPandocError where
show = \case
RibPandocError_PandocError e ->
show e
RibPandocError_UnknownFormat s ->
"Unsupported extension: " <> show s
readPandocFormat :: PandocMonad m => PandocFormat -> ReaderOptions -> Text -> m Pandoc
readPandocFormat = \case
PandocFormat_Markdown -> readMarkdown
PandocFormat_RST -> readRST
instance IsMarkup Pandoc where
parsePure :: PandocFormat -> Text -> Either Text Pandoc
parsePure fmt s =
first show $ runExcept $ do
runPure'
$ readPandocFormat fmt readerSettings s
parseDoc k s = first show $ runExcept $ do
r <-
withExcept RibPandocError_UnknownFormat $
detectReader k
withExcept RibPandocError_PandocError
$ runPure'
$ r readerSettings s
readDoc (Arg k) (Arg f) = fmap (first show) $ runExceptT $ do
parseIO :: MonadIO m => PandocFormat -> Path b File -> m (Either Text Pandoc)
parseIO fmt f = fmap (first show) $ runExceptT $ do
content <- readFileText (toFilePath f)
r <-
withExceptT RibPandocError_UnknownFormat $
detectReader k
withExceptT RibPandocError_PandocError $ do
v' <- runIO' $ r readerSettings content
v' <- runIO' $ readPandocFormat fmt readerSettings content
liftIO $ walkM includeSources v'
where
includeSources = includeCode $ Just $ Format "html5"
extractMeta (Pandoc meta _) = flattenMeta meta
renderDoc doc = first show $ runExcept $ do
withExcept RibPandocError_PandocError
$ runPure'
-- | Render a Pandoc document to HTML
render :: Pandoc -> Html ()
render doc =
either error id $ first show $ runExcept $ do
runPure'
$ fmap toHtmlRaw
$ writeHtml5String writerSettings doc
extractMeta :: Pandoc -> Maybe (Either Text Value)
extractMeta (Pandoc meta _) = flattenMeta meta
runPure' :: MonadError PandocError m => PandocPure a -> m a
runPure' = liftEither . runPure
runIO' :: (MonadError PandocError m, MonadIO m) => PandocIO a -> m a
runIO' = liftEither <=< liftIO . runIO
-- | Parse and render the markup directly to HTML
renderPandoc :: Path Rel File -> Text -> Html ()
renderPandoc f s = either (error . show) id $ runExcept $ do
doc <- liftEither $ parseDoc @Pandoc f s
liftEither $ renderDoc doc
-- | Render a list of Pandoc `Text.Pandoc.Inline` values as Lucid HTML
--
-- Useful when working with `Text.Pandoc.Meta` values from the document metadata.
renderPandocInlines :: [Inline] -> Html ()
renderPandocInlines =
either (error . show) toHtmlRaw
. renderDoc
toHtmlRaw
. render
. Pandoc mempty
. pure
. Plain
@ -136,33 +122,6 @@ writerSettings = def {writerExtensions = exts}
-- Internal code
data UnknownExtension
= UnknownExtension String
deriving (Show, Eq)
-- | Detect the Pandoc reader to use based on file extension
detectReader ::
forall m m1.
(MonadError UnknownExtension m, PandocMonad m1) =>
Path Rel File ->
m (ReaderOptions -> Text -> m1 Pandoc)
detectReader f = do
ext <-
liftEither . first (UnknownExtension . show) $
fileExtension f
liftEither . maybeToRight (UnknownExtension ext) $
formats !? ext
where
formats :: Map String (ReaderOptions -> Text -> m1 Pandoc)
formats =
fromList
[ (".md", readMarkdown),
(".rst", readRST),
(".org", readOrg),
(".tex", readLaTeX),
(".ipynb", readIpynb)
]
-- | Flatten a Pandoc 'Meta' into a well-structured JSON object.
--
-- Renders Pandoc text objects into plain strings along the way.

59
src/Rib/Shake.hs
View File

@ -3,6 +3,7 @@
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedLabels #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE Rank2Types #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
@ -15,7 +16,7 @@ module Rib.Shake
buildHtml,
-- * Read helpers
readDocMulti,
readSourceMulti,
-- * Misc
buildStaticFiles,
@ -25,16 +26,12 @@ module Rib.Shake
)
where
import Data.Aeson
import Data.Some
import Development.Shake
import Lucid (Html)
import qualified Lucid
import Named
import Path
import Path.IO
import Relude.Extra.Map
import Rib.Document
import Rib.Source
data Dirs = Dirs (Path Rel Dir, Path Rel Dir)
deriving (Typeable)
@ -67,42 +64,40 @@ buildStaticFiles staticFilePatterns = do
-- | Convert the given pattern of source files into their HTML.
buildHtmlMulti ::
forall meta.
FromJSON meta =>
-- | Source file patterns
Map (Path Rel File) (Some Markup) ->
-- | How to render the given document to HTML
(Document meta -> Html ()) ->
-- | List of relative path to generated HTML and the associated document
Action [Document meta]
buildHtmlMulti pat r = do
xs <- readDocMulti pat
[Path Rel File] ->
-- | How to parse the source
SourceReader repr ->
-- | How to render the given source to HTML
(Source repr -> Html ()) ->
-- | Result
Action [Source repr]
buildHtmlMulti pat parser r = do
xs <- readSourceMulti pat parser
void $ forP xs $ \x -> do
outfile <- liftIO $ replaceExtension ".html" $ documentPath x
outfile <- liftIO $ replaceExtension ".html" $ sourcePath x
buildHtml outfile (r x)
pure xs
-- | Like `readDoc'` but operates on multiple files
readDocMulti ::
forall meta.
(FromJSON meta) =>
-- | Like `readSource'` but operates on multiple files
readSourceMulti ::
-- | Source file patterns
Map (Path Rel File) (Some Markup) ->
Action [Document meta]
readDocMulti pats = do
[Path Rel File] ->
-- | How to parse the source
SourceReader repr ->
-- | Result
Action [Source repr]
readSourceMulti pats parser = do
input <- ribInputDir
fmap concat $ forM (toPairs pats) $ \(pat, dp) -> do
fmap concat $ forM pats $ \pat -> do
fs <- getDirectoryFiles' input [pat]
forP fs $ \f -> do
need $ toFilePath <$> [input </> f]
result <-
runExceptT $
mkDocumentFrom dp
! #relpath f
! #path (input </> f)
forP fs $ \k -> do
let f = input </> k
need $ toFilePath <$> [f]
result <- readSource parser k f
case result of
Left e ->
fail $ "Error converting " <> toFilePath f <> " to HTML: " <> show e
fail $ "Error converting " <> toFilePath k <> " to HTML: " <> show e
Right v -> pure v
-- | Build a single HTML file with the given value

61
src/Rib/Source.hs Normal file
View File

@ -0,0 +1,61 @@
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE Rank2Types #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Rib.Source
( -- * Source type
Source,
SourceReader,
readSource,
-- * Source properties
sourcePath,
sourceVal,
sourceUrl,
)
where
import Development.Shake.FilePath ((-<.>))
import Path hiding ((-<.>))
-- | A source file on disk
data Source repr
= Source
{ -- | Path to the source; relative to the source directory.
_source_path :: Path Rel File,
-- | Parsed representation of the source.
_source_val :: repr
}
deriving (Generic, Functor)
sourcePath :: Source repr -> Path Rel File
sourcePath = _source_path
sourceVal :: Source repr -> repr
sourceVal = _source_val
-- | Return the URL for the given @.html@ file under serve directory
--
-- File path must be relative to the serve directory.
--
-- You may also pass source paths as long as they map directly to destination
-- path except for file extension.
sourceUrl :: Source repr -> Text
sourceUrl doc = toText $ toFilePath ([absdir|/|] </> (sourcePath doc)) -<.> ".html"
-- | A function that parses a source representation out of the given file
type SourceReader repr =
forall m b. MonadIO m => Path b File -> m (Either Text repr)
readSource ::
MonadIO m =>
SourceReader repr ->
Path Rel File ->
Path b File ->
m (Either Text (Source repr))
readSource r k f = fmap (Source k) <$> r f