Merge pull request #51 from srid/remove-most-error

API improvements

CHANGELOG.md

@@ -2,12 +2,13 @@
 
 ## 0.5.0.0 (UNRELEASED)
 
-This release comes with major API refactor. Key changes:
+This release comes with a major API refactor. Key changes:
 
-- Support for both Pandoc and MMark parsers
-- Add `Rib.Markup.Markup` type class to polymorphically select the parser
-- Add top-level `Rib` import namespace to ease of use
-- Replace complex metadata handling using straightforward aeson `Value` parsing
+- Added MMark support, as an alternative to Pandoc
+- Allows using arbitrary records to load metadata
+  - This replaces the previous complex metadata API
+- Added `Document` type that uses the custom metadata record
+- Add top-level `Rib` import namespace for ease of use
 - Remove the following:
   - JSON cache
   - `Rib.Simple`
@@ -17,6 +18,7 @@ Other changes:
 
 - Use type-safe path types using the [path](http://hackage.haskell.org/package/path) library.
 - Fix #40: Gracefully handle rendering/ parsing errors, without dying.
+- Misc error reporting improvements
 
 ## 0.4.1.0
 

README.md

@@ -31,15 +31,19 @@ using Rib:
 -- itself. Second, the metadata associated with each document.
 
 -- | A generated page is either an index of documents, or an individual document.
-data Page doc
-  = Page_Index [Document doc]
-  | Page_Doc (Document doc)
+--
+-- The `Document` type takes two type variables:
+-- 1. The first type variable specifies the parser to use: MMark or Pandoc
+-- 2. The second type variable should be your metadata record
+data Page
+  = Page_Index [Document MMark DocMeta]
+  | Page_Doc (Document MMark DocMeta)
 
 -- | Type representing the metadata in our Markdown documents
 --
 -- Note that if a field is not optional (i.e., not Maybe) it must be present.
-data Meta
-  = Meta
+data DocMeta
+  = DocMeta
       { title :: Text,
         description :: Maybe Text
       }
@@ -60,51 +64,46 @@ main = Rib.run [reldir|a|] [reldir|b|] $ do
   -- Copy over the static files
   Rib.buildStaticFiles [[relfile|static/**|]]
   -- Build individual markdown files, generating .html for each.
-  --
-  -- NOTE: We use TypeApplications to specify the type of the `doc` type
-  -- variable, as used in the `Markup doc` constraint in the functions below.
-  -- There are currently two possible values: `MMark` (if you choose to use the
-  -- `mmark` parser) and `Pandoc` (if using pandoc).
-  posts <- Rib.buildHtmlMulti @MMark [relfile|*.md|] (renderPage . Page_Doc)
+  posts <- Rib.buildHtmlMulti [relfile|*.md|] (renderPage . Page_Doc)
   -- Build an index.html linking to the aforementioned files.
   Rib.buildHtml [relfile|index.html|]
     $ renderPage
     $ Page_Index posts
   where
     -- Define your site HTML here
-    renderPage :: Markup doc => Page doc -> Html ()
+    renderPage :: Page -> Html ()
     renderPage page = with html_ [lang_ "en"] $ do
       head_ $ do
         meta_ [httpEquiv_ "Content-Type", content_ "text/html; charset=utf-8"]
         title_ $ case page of
           Page_Index _ -> "My website!"
-          Page_Doc doc -> toHtml $ title $ Rib.getDocumentMeta doc
+          Page_Doc doc -> toHtml $ title $ Rib._document_meta doc
         style_ [type_ "text/css"] $ Clay.render pageStyle
       body_
         $ with div_ [id_ "thesite"]
         $ do
-          -- Main content
           with a_ [href_ "/"] "Back to Home"
           hr_ []
           case page of
             Page_Index docs ->
-              div_ $ forM_ docs $ \doc -> li_ $ do
-                let meta = Rib.getDocumentMeta doc
+              div_ $ forM_ docs $ \doc -> with li_ [class_ "links"] $ do
+                let meta = Rib._document_meta doc
                 b_ $ with a_ [href_ (Rib.getDocumentUrl doc)] $ toHtml $ title meta
-                case description meta of
-                  Just s -> em_ $ small_ $ toHtml s
-                  Nothing -> mempty
+                maybe mempty Rib.renderMarkdown $
+                  description meta
             Page_Doc doc ->
               with article_ [class_ "post"] $ do
-                h1_ $ toHtml $ title $ Rib.getDocumentMeta doc
-                Rib.renderDoc doc
+                h1_ $ toHtml $ title $ Rib._document_meta doc
+                Rib._document_html doc
     -- Define your site CSS here
     pageStyle :: Css
-    pageStyle = div # "#thesite" ? do
-      marginLeft $ pct 20
-      marginTop $ em 4
-      "h1" ? do
-        fontSize $ em 2.3
+    pageStyle = "div#thesite" ? do
+      margin (em 4) (pc 20) (em 1) (pc 20)
+      "li.links" ? do
+        listStyleType none
+        marginTop $ em 1
+        "b" ? fontSize (em 1.2)
+        "p" ? sym margin (px 0)
 ```
 
 (View full [`Main.hs`](https://github.com/srid/rib-sample/blob/master/Main.hs) at rib-sample)

rib.cabal

@@ -25,13 +25,14 @@ library
     exposed-modules:
         Rib
         Rib.App
-        Rib.Markup
+        Rib.Document
         Rib.Markup.MMark
         Rib.Markup.Pandoc
         Rib.Server
         Rib.Shake
     other-modules:
         Prelude
+        Rib.Markup
     hs-source-dirs: src
     default-language: Haskell2010
     ghc-options:

src/Rib.hs

@@ -3,7 +3,7 @@ module Rib
   ( module Rib.App,
     module Rib.Shake,
     module Rib.Server,
-    module Rib.Markup,
+    Document(..),
     MMark,
     renderMarkdown,
     Pandoc,
@@ -12,7 +12,7 @@ module Rib
 where
 
 import Rib.App
-import Rib.Markup
+import Rib.Document
 import Rib.Markup.MMark (MMark, renderMarkdown)
 import Rib.Markup.Pandoc (Pandoc, renderPandoc)
 import Rib.Server

src/Rib/Document.hs

@@ -0,0 +1,95 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE OverloadedLabels #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE ViewPatterns #-}
+
+module Rib.Document
+  ( -- * Document type
+    Document (..),
+    mkDocumentFrom,
+  )
+where
+
+import Control.Monad.Except hiding (fail)
+import Data.Aeson
+import Lucid (Html)
+import Named
+import Path
+import Rib.Markup
+import qualified Text.Show
+
+-- | A document written in a lightweight markup language (LML)
+--
+-- The type variable `repr` indicates the representation type of the Markup
+-- parser to be used.
+data Document repr meta
+  = Document
+      { -- | Path to the document; relative to the source directory.
+        _document_path :: Path Rel File,
+        -- | Parsed representation of the document.
+        _document_val :: repr,
+        -- | HTML rendering of the parsed representation.
+        _document_html :: Html (),
+        -- | Metadata associated with the document as an aeson Value. If no metadata
+        -- is provided this will be Nothing.
+        _document_metaValue :: Maybe Value,
+        -- | The parsed metadata.
+        _document_meta :: meta
+      }
+  deriving (Generic, Show)
+
+data DocumentError repr
+  = DocumentError_MarkupError (MarkupError repr)
+  | DocumentError_MetadataMissing
+  | DocumentError_MetadataBadJSON String
+
+instance Markup repr => Show (DocumentError repr) where
+  show = \case
+    DocumentError_MarkupError e -> toString (showMarkupError @repr e)
+    DocumentError_MetadataMissing -> "Metadata missing"
+    DocumentError_MetadataBadJSON msg -> "Bad metadata JSON: " <> msg
+
+-- | Parse, render to HTML and extract metadata from the given file.
+--
+-- Return the Document type containing converted values.
+mkDocumentFrom ::
+  forall m b repr meta.
+  (MonadError (DocumentError repr) m, MonadIO m, Markup repr, FromJSON meta) =>
+  -- | 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 repr meta)
+mkDocumentFrom k@(arg #relpath -> k') f = do
+  v <-
+    liftEither
+      . first DocumentError_MarkupError
+        =<< liftIO (readDoc k f)
+  html <-
+    liftEither
+      $ first DocumentError_MarkupError
+      $ renderDoc v
+  let metaValueM = extractMeta v
+  metaValue <-
+    maybeToEither
+      DocumentError_MetadataMissing
+      metaValueM
+  meta <-
+    liftEither
+      $ first DocumentError_MetadataBadJSON
+      $ resultToEither
+      $ fromJSON metaValue
+  pure $ Document k' v html metaValueM meta
+  where
+    maybeToEither e = \case
+      Nothing -> throwError e
+      Just v -> pure v
+    resultToEither = \case
+      Error e -> Left e
+      Success v -> Right v

src/Rib/Markup.hs

@@ -10,10 +10,6 @@
 module Rib.Markup
   ( -- * Type class
     Markup (..),
-
-    -- * Document type
-    Document (..),
-    getDocumentMeta,
   )
 where
 
@@ -22,28 +18,6 @@ import Lucid (Html)
 import Named
 import Path
 
--- | A document written in a lightweight markup language (LML)
---
--- The type variable `repr` indicates the representation type of the Markup
--- parser to be used.
-data Document repr
-  = Document
-      { -- | Path to the document; relative to the source directory.
-        _document_path :: Path Rel File,
-        _document_val :: repr,
-        -- | Metadata associated with the document as an aeson Value. If no metadata
-        -- is provided this will be Nothing.
-        _document_meta :: Maybe Value
-      }
-  deriving (Generic, Show)
-
-getDocumentMeta :: FromJSON meta => Document repr -> meta
-getDocumentMeta (Document fp _ mmeta) = case mmeta of
-  Nothing -> error $ toText $ "No metadata in document: " <> toFilePath fp -- TODO: handle errors gracefully
-  Just meta -> case fromJSON meta of
-    Error e -> error $ toText e
-    Success v -> v
-
 -- | Class for denoting Markup representations.
 --
 -- See `Rib.Markup.Pandoc` and `Rib.Markup.MMark` for two available instances.
@@ -59,18 +33,25 @@ class Markup repr where
     Path Rel File ->
     -- | Markup text to parse
     Text ->
-    Either (MarkupError repr) (Document repr)
+    Either (MarkupError repr) repr
 
-  -- | Like `reproc` but take the actual filepath instead of text.
+  -- | Like `parseDoc` but take the actual filepath instead of text.
   readDoc ::
+    forall b.
     -- | File path, used to identify the document only.
     "relpath" :! Path Rel File ->
     -- | Actual path to the file to parse.
     "path" :! Path b File ->
-    IO (Either (MarkupError repr) (Document repr))
+    IO (Either (MarkupError repr) repr)
+
+  extractMeta ::
+    repr ->
+    Maybe Value
 
   -- | Render the document as Lucid HTML
-  renderDoc :: Document repr -> Html ()
+  renderDoc ::
+    repr ->
+    Either (MarkupError repr) (Html ())
 
   -- | Convert `MarkupError` to string
   showMarkupError :: MarkupError repr -> Text

src/Rib/Markup/MMark.hs

@@ -22,6 +22,7 @@ module Rib.Markup.MMark
 where
 
 import Control.Foldl (Fold (..))
+import Control.Monad.Except
 import Lucid (Html)
 import Named
 import Path
@@ -39,25 +40,23 @@ instance Markup MMark where
 
   parseDoc f s = case MMark.parse (toFilePath f) s of
     Left e -> Left e
-    Right doc ->
-      let doc' = MMark.useExtensions exts $ useTocExt doc
-          meta = MMark.projectYaml doc
-       in Right $ Document f doc' meta
+    Right doc -> Right $ MMark.useExtensions exts $ useTocExt doc
 
   readDoc (Arg k) (Arg f) = do
     content <- readFileText (toFilePath f)
     pure $ parseDoc k content
 
-  renderDoc = MMark.render . _document_val
+  extractMeta = MMark.projectYaml
+
+  renderDoc = Right . MMark.render
 
   showMarkupError = toText . M.errorBundlePretty
 
 -- | Parse and render the markup directly to HTML
 renderMarkdown :: Text -> Html ()
-renderMarkdown =
-  renderDoc
-    . either (error . showMarkupError @MMark) id
-    . parseDoc @MMark [relfile|<memory>.md|]
+renderMarkdown s = either (error . showMarkupError @MMark) id $ runExcept $ do
+  doc <- liftEither $ parseDoc @MMark [relfile|<memory>.md|] s
+  liftEither $ renderDoc doc
 
 -- | Get the first image in the document if one exists
 getFirstImg :: MMark -> Maybe URI

src/Rib/Markup/Pandoc.hs

@@ -61,8 +61,7 @@ instance Markup Pandoc where
         $ liftEither
         $ detectReader k
     withExcept RibPandocError_PandocError $
-      mkDoc k
-        <$> parsePure r s
+      parsePure r s
 
   readDoc (Arg k) (Arg f) = runExceptT $ do
     content <- readFileText $ toFilePath f
@@ -70,19 +69,23 @@ instance Markup Pandoc where
       withExceptT RibPandocError_UnknownFormat $
         detectReader k
     withExceptT RibPandocError_PandocError $
-      mkDoc k
-        <$> parse r content
+      parse r content
 
-  renderDoc = render . _document_val
+  extractMeta (Pandoc meta _) = flattenMeta meta
+
+  renderDoc =
+    fmap toHtmlRaw
+      . first RibPandocError_PandocError
+      . liftEither
+      . render'
 
   showMarkupError = toText @String . show
 
 -- | Parse and render the markup directly to HTML
 renderPandoc :: Path Rel File -> Text -> Html ()
-renderPandoc f =
-  renderDoc
-    . either (error . showMarkupError @Pandoc) id
-    . parseDoc @Pandoc f
+renderPandoc f s = either (error . show) id $ runExcept $ do
+  doc <- liftEither $ parseDoc @Pandoc f s
+  liftEither $ renderDoc doc
 
 -- | Pure version of `parse`
 parsePure ::
@@ -100,7 +103,7 @@ parsePure r =
 -- Supports the [includeCode](https://github.com/owickstrom/pandoc-include-code) extension.
 parse ::
   (MonadIO m, MonadError PandocError m) =>
-  -- | Document format. Example: `Text.Pandoc.Readers.readMarkdown`
+  -- | Markup format. Example: `Text.Pandoc.Readers.readMarkdown`
   (ReaderOptions -> Text -> PandocIO Pandoc) ->
   -- | Source text to parse
   Text ->
@@ -112,18 +115,14 @@ parse r s = do
     settings = def {readerExtensions = exts}
     includeSources = includeCode $ Just $ Format "html5"
 
--- | Like `render` but returns the raw HTML string, or the rendering error.
-render' :: Pandoc -> Either PandocError Text
-render' = runPure . writeHtml5String settings
+-- | Render a Pandoc document as HTML
+render' :: Pandoc -> Either PandocError (Html ())
+render' = fmap toHtmlRaw . runPure . writeHtml5String settings
   where
     settings = def {writerExtensions = exts}
 
--- | Render a Pandoc document as Lucid HTML
-render :: Pandoc -> Html ()
-render = either (error . show) toHtmlRaw . render'
-
 -- | Like `renderInlines` but returns the raw HTML string, or the rendering error.
-renderInlines' :: [Inline] -> Either PandocError Text
+renderInlines' :: [Inline] -> Either PandocError (Html ())
 renderInlines' = render' . Pandoc mempty . pure . Plain
 
 -- | Render a list of Pandoc `Text.Pandoc.Inline` values as Lucid HTML
@@ -192,12 +191,6 @@ detectReader f = do
     -- MonadError instead.
     catchInMonadError ef = either (throwError . ef) pure
 
-mkDoc :: Path Rel File -> Pandoc -> Document Pandoc
-mkDoc f v = Document f v $ getMetadata v
-
-getMetadata :: Pandoc -> Maybe Value
-getMetadata (Pandoc meta _) = flattenMeta meta
-
 -- | Flatten a Pandoc 'Meta' into a well-structured JSON object.
 --
 -- Renders Pandoc text objects into plain strings along the way.

src/Rib/Server.hs

@@ -12,9 +12,8 @@ import Development.Shake.FilePath ((-<.>))
 import Network.Wai.Application.Static (defaultFileServerSettings, ssListing, ssLookupFile, staticApp)
 import qualified Network.Wai.Handler.Warp as Warp
 import Path hiding ((-<.>))
-import Rib.Markup (Document (..))
+import Rib.Document (Document (_document_path))
 import WaiAppStatic.Types (StaticSettings)
-import Prelude
 
 -- | WAI Settings suited for serving statically generated websites.
 staticSiteServerSettings :: FilePath -> StaticSettings
@@ -32,11 +31,8 @@ staticSiteServerSettings root =
 --
 -- You may also pass source paths as long as they map directly to destination
 -- path except for file extension.
-getDocumentUrl ::
-  -- | Relative path to a page (extension is ignored)
-  Document t ->
-  Text
-getDocumentUrl (Document f _ _) = toText $ toFilePath ([absdir|/|] </> f) -<.> ".html"
+getDocumentUrl :: Document t meta -> Text
+getDocumentUrl doc = toText $ toFilePath ([absdir|/|] </> (_document_path doc)) -<.> ".html"
 
 -- | Run a HTTP server to serve a directory of static files
 --

src/Rib/Shake.hs

@@ -23,13 +23,15 @@ module Rib.Shake
   )
 where
 
+import Data.Aeson
 import Development.Shake
 import Lucid (Html)
 import qualified Lucid
 import Named
 import Path
 import Path.IO
-import Rib.Markup
+import Rib.Document
+import Rib.Markup (Markup)
 
 data Dirs = Dirs (Path Rel Dir, Path Rel Dir)
   deriving (Typeable)
@@ -62,14 +64,14 @@ buildStaticFiles staticFilePatterns = do
 
 -- | Convert the given pattern of source files into their HTML.
 buildHtmlMulti ::
-  forall t.
-  Markup t =>
+  forall repr meta.
+  (Markup repr, FromJSON meta) =>
   -- | Source file patterns
   Path Rel File ->
   -- | How to render the given document to HTML
-  (Document t -> Html ()) ->
+  (Document repr meta -> Html ()) ->
   -- | List of relative path to generated HTML and the associated document
-  Action [Document t]
+  Action [Document repr meta]
 buildHtmlMulti pat r = do
   xs <- readDocMulti pat
   void $ forP xs $ \x -> do
@@ -79,22 +81,25 @@ buildHtmlMulti pat r = do
 
 -- | Like `readDoc'` but operates on multiple files
 readDocMulti ::
-  forall t.
-  Markup t =>
+  forall repr meta.
+  (Markup repr, FromJSON meta) =>
   -- | Source file patterns
   Path Rel File ->
-  Action [Document t]
+  Action [Document repr meta]
 readDocMulti pat = do
   input <- ribInputDir
   fs <- getDirectoryFiles' input [pat]
   forP fs $ \f -> do
     need $ toFilePath <$> [input </> f]
-    result <-
-      liftIO $
-        readDoc
-          ! #relpath f
-          ! #path (input </> f)
-    pure $ either (error . showMarkupError @t) id result
+    result <- runExceptT $
+      mkDocumentFrom
+        ! #relpath f
+        ! #path (input </> f)
+    -- TODO: Make error reporting nice, without Shake's stack trace ugliness.
+    case result of
+      Left e ->
+        fail $ "Error converting " <> toFilePath f <> " to HTML: " <> show e
+      Right v -> pure v
 
 -- | Build a single HTML file with the given value
 buildHtml :: Path Rel File -> Html () -> Action ()