Isolate library and executable (#11)

* Split library and executable

* Abstract out pandoc stuff from example

* Put example content under ./example

* Simplify HTML render configuration

.gitignore

@@ -2,4 +2,4 @@ dist-newstyle
 dist
 result
 .shake
-generated
+content.generated

README.md

@@ -6,7 +6,9 @@ Credit for this image: https://www.svgrepo.com/svg/24439/ribs
 <img src="https://raw.githubusercontent.com/srid/rib/master/site/images/ribs.svg?sanitize=true" width="150" />
 
 Rib is a static site generator written in Haskell using sensible technologies
-like `Shake` and `Reflex`.
+like `Shake` and `Reflex`. See `./example` to see how the library can be used;
+it contains the author's actual website. It is still a work in progress but will
+soon be ready for general use.
 
 ## Local server when editing only content
 
@@ -18,14 +20,12 @@ nix-build -A ghc.rib
 ## ... when hacking on Haskell sources
 
 ```bash
-nix-shell -A shells.ghc --run "ghcid -T Main.dev"
+nix-shell -A shells.ghc --run "ghcid -c 'cabal new-repl rib-example' -T 'System.Directory.withCurrentDirectory \"example\" \$ Main.dev'"
 ```
 
 ## TODO
 
 - Use my own jsonCache' and drop dependency on Slick
-- Literate haskell
-  - Include rendered Main.lhs as a post in notes.srid.ca
 
 ### Article Ideas
 

example/CSS.hs

@@ -4,12 +4,13 @@ module CSS where
 
 import Prelude hiding (div, (**))
 
-import Control.Monad (forM_)
+import Control.Monad
 import Data.Text (Text)
 
 import Clay
 
--- All these font names should exist in Google Fonts
+googleFonts :: [Text]
+googleFonts = [headerFont, contentFont, codeFont]
 
 headerFont :: Text
 headerFont = "Comfortaa"
@@ -20,9 +21,12 @@ contentFont = "Open Sans"
 codeFont :: Text
 codeFont = "Roboto Mono"
 
-siteStyle :: Css
-siteStyle = body ? do
+-- | Main style for the site
+style :: Css
+style = body ? do
   div # "#thesite" ? do
+    marginTop $ em 1
+    marginBottom $ em 2
     fontFamily [contentFont] [sansSerif]
     forM_ [h1, h2, h3, h4, h5, h6, ".header"] $ \sel -> sel ?
       fontFamily [headerFont] [sansSerif]

example/HTML.hs

@@ -0,0 +1,84 @@
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE OverloadedStrings #-}
+
+module HTML where
+
+import Control.Monad
+import Data.List (partition)
+import qualified Data.Text as T
+import qualified Data.Text.Lazy as TL
+
+import qualified Clay
+import Reflex.Dom.Core
+
+import Reflex.Dom.Pandoc.Document (elPandocDoc, elPandocInlines)
+import qualified Reflex.Dom.Pandoc.SyntaxHighlighting as SyntaxHighlighting
+
+import Rib.Types (Page (..), Post (..), PostCategory (..), getPostAttribute, getPostAttributeJson)
+
+import qualified CSS
+
+-- | HTML for page type
+pageWidget :: DomBuilder t m => Page -> m ()
+pageWidget page = elAttr "html" ("lang" =: "en") $ do
+  el "head" $ do
+    mapM_ (uncurry elMeta)
+      [ ("charset", "UTF-8")
+      , ("description", "Sridhar's notes")
+      , ("author", "Sridhar Ratnakumar")
+      , ("viewport", "width=device-width, initial-scale=1")
+      ]
+    el "title" pageTitle
+    mapM_ elStyleClay [CSS.style, SyntaxHighlighting.style]
+    elLinkStylesheet semanticUiCss
+
+  el "body" $ do
+    elAttr "div" ("class" =: "ui text container" <> "id" =: "thesite") $ do
+      divClass "ui raised segment" $ do
+        -- Header
+        elAttr "a" ("class" =: "ui violet ribbon label" <> "href" =: "/") $ text "Srid's notes"
+        -- Main content
+        elClass "h1" "ui huge header" pageTitle
+        case page of
+          Page_Index posts -> do
+            let (progPosts, otherPosts) =
+                  partition ((== Just Programming) . getPostAttributeJson "category") posts
+            elClass "h2" "ui header" $ text "Haskell & Nix notes"
+            postList progPosts
+            elClass "h2" "ui header" $ text "Other notes"
+            postList otherPosts
+          Page_Post post ->
+            elClass "article" "post" $
+              elPandocDoc $ _post_doc post
+        -- Footer
+        elAttr "a" ("class" =: "ui green right ribbon label" <> "href" =: "https://www.srid.ca") $
+          text "Sridhar Ratnakumar"
+
+    -- Load Google fonts at the very end for quicker page load.
+    mapM_ elLinkGoogleFont CSS.googleFonts
+
+  where
+    pageTitle = case page of
+      Page_Index _ -> text "Srid's notes"
+      Page_Post post -> postTitle post
+
+    -- Render the post title (Markdown supported)
+    postTitle = maybe (text "Untitled") elPandocInlines . getPostAttribute "title"
+
+    -- Render a list of posts
+    postList ps = divClass "ui relaxed divided list" $ forM_ ps $ \p ->
+      divClass "item" $ do
+        elAttr "a" ("class" =: "header" <> "href" =: _post_url p) $
+          postTitle p
+        el "small" $ maybe blank elPandocInlines $ getPostAttribute "description" p
+
+    semanticUiCss = "https://cdn.jsdelivr.net/npm/semantic-ui@2.4.2/dist/semantic.min.css"
+
+    elMeta k v =
+      elAttr "meta" ("name" =: k <> "content" =: v) blank
+    elLinkStylesheet url =
+      elAttr "link" ("href" =: url <> "rel" =: "stylesheet") blank
+    elLinkGoogleFont name = elLinkStylesheet $
+      "https://fonts.googleapis.com/css?family=" <> T.replace " " "-" name
+    elStyleClay =
+      elAttr "style" ("type" =: "text/css") . text . TL.toStrict . Clay.render

example/Main.hs

@@ -15,9 +15,9 @@ import qualified HTML
 -- | Configure this site here.
 --
 -- See `S.Settings` for the settings available.
-siteSettings :: S.Settings
+siteSettings :: S.Settings x
 siteSettings = def
-  { S.pageHTML = HTML.pageHTML
+  { S.pageWidget = HTML.pageWidget
   -- ^ How to render a page type
   }
 

example/content/haskell-nix.md

@@ -1,7 +1,7 @@
 ---
 title: "Nix tutorial for Haskellers"
 description: How to develop *Haskell* projects using *Nix*
-category: Programming
+category: '"Programming"'
 ---
 
 The goal of this article is to get you comfortable managing simple Haskell
@@ -133,7 +133,7 @@ compiler.developPackage {
 }
 ```
 
-In order you compute the `sha256` hash you can use `nix-prefetch-git`:
+In order to compute the `sha256` hash you can use `nix-prefetch-git`:
 
 ```bash
 nix-prefetch-git \

rib.cabal

@@ -17,11 +17,20 @@ source-repository head
   type: git
   location: https://github.com/srid/rib
 
-executable rib
-  main-is: Main.hs
+library
+  exposed-modules:
+      Rib.App
+    , Rib.Settings
+    , Rib.Types
+    , Reflex.Dom.Pandoc.Document
+    , Reflex.Dom.Pandoc.SyntaxHighlighting
+  other-modules:
+      Rib.Shake
+    , Rib.Server
+    , Reflex.Dom.Pandoc.Util
   hs-source-dirs:
       src
-  ghc-options: -threaded -rtsopts -with-rtsopts=-N -Wall -Wincomplete-uni-patterns -Wincomplete-record-updates
+  ghc-options: -Wall -Wincomplete-uni-patterns -Wincomplete-record-updates
   build-depends:
       aeson
     , async
@@ -51,3 +60,19 @@ executable rib
     , wai-extra
     , warp
   default-language: Haskell2010
+
+executable rib-example
+  main-is: Main.hs
+  other-modules:
+      CSS
+    , HTML
+  hs-source-dirs: example
+  ghc-options: -threaded -rtsopts -with-rtsopts=-N -Wall -Wincomplete-uni-patterns -Wincomplete-record-updates
+  build-depends:
+      base
+    , clay
+    , data-default
+    , directory
+    , reflex-dom-core
+    , rib
+    , text

src/HTML.hs

@@ -1,93 +0,0 @@
-{-# LANGUAGE LambdaCase #-}
-{-# LANGUAGE OverloadedStrings #-}
-
-module HTML where
-
-import Control.Monad (forM_)
-import qualified Data.Aeson as Aeson
-import qualified Data.ByteString.Char8 as BS8
-import Data.List (partition)
-import qualified Data.Text as T
-import qualified Data.Text.Lazy as TL
-
-import qualified Clay
-import Reflex.Dom.Core
-import Text.Pandoc (Block (Plain), Inline (Str), Pandoc (Pandoc))
-import Text.Pandoc.UTF8 (fromStringLazy)
-
-import Reflex.Dom.Pandoc.Document (elPandocDoc)
-import qualified Reflex.Dom.Pandoc.SyntaxHighlighting as SyntaxHighlighting
-
-import Rib.Types (Page (..), Post (..), PostCategory (..), getPostAttribute)
-
-import CSS (codeFont, contentFont, headerFont, siteStyle)
-
-pageHTML :: Page -> IO String
-pageHTML = fmap BS8.unpack . renderHTML . pageWidget
-  where
-    -- | Convert a Reflex DOM widget into HTML
-    renderHTML :: StaticWidget x a -> IO BS8.ByteString
-    renderHTML = fmap snd . renderStatic
-
--- | The entire HTML layout is here.
-pageWidget :: DomBuilder t m => Page -> m ()
-pageWidget page = do
-  let pageTitle = case page of
-        Page_Index _ -> text "Srid's notes"
-        Page_Post post -> postTitle post
-  elAttr "html" ("lang" =: "en") $ el "head" $ do
-    elMeta "charset" "UTF-8"
-    elMeta "description" "Sridhar's notes"
-    elMeta "author" "Sridhar Ratnakumar"
-    elMeta "viewport" "width=device-width, initial-scale=1"
-    el "title" pageTitle
-    elAttr "style" ("type" =: "text/css") $ text $ TL.toStrict $ Clay.render siteStyle
-    elAttr "style" ("type" =: "text/css") $ text $ TL.toStrict $ Clay.render SyntaxHighlighting.style
-    elAttr "link" ("rel" =: "stylesheet" <> "href" =: semUiCdn) blank
-  el "body" $ do
-    elAttr "div" ("class" =: "ui text container" <> "id" =: "thesite") $ do
-      el "br" blank
-      divClass "ui raised segment" $ do
-        -- Header
-        elAttr "a" ("class" =: "ui violet ribbon label" <> "href" =: "/") $ text "Srid's notes"
-        -- Main content
-        elClass "h1" "ui huge header" pageTitle
-        case page of
-          Page_Index posts -> do
-            let (progPosts, otherPosts) =
-                  partition ((== Just Programming) . postCategory) posts
-            elClass "h2" "ui header" $ text "Haskell & Nix notes"
-            postList progPosts
-            elClass "h2" "ui header" $ text "Other notes"
-            postList otherPosts
-          Page_Post post ->
-            elClass "article" "post" $
-              elPandocDoc $ _post_doc post
-        -- Footer
-        elAttr "a" ("class" =: "ui green right ribbon label" <> "href" =: "https://www.srid.ca") $ text "Sridhar Ratnakumar"
-    el "br" blank
-    el "br" blank
-    mapM_ elLinkGoogleFont [headerFont, contentFont, codeFont]
-  where
-    postList ps = divClass "ui relaxed divided list" $ forM_ ps $ \p ->
-      divClass "item" $ do
-        elAttr "a" ("class" =: "header" <> "href" =: _post_url p) $
-          postTitle p
-        el "small" $ maybe blank pandocInlines $ getPostAttribute "description" p
-
-    postTitle = maybe (text "Untitled") pandocInlines . getPostAttribute "title"
-    postCategory post = getPostAttribute "category" post >>= \case
-      [Str category] -> do
-        let categoryJson = "\"" <> category <> "\""
-        Aeson.decode $ fromStringLazy categoryJson
-      _ -> error "Invalid category format"
-
-    -- TODO: Put this in Markdown module, and reuse renderBlocks
-    pandocInlines xs = elPandocDoc $ Pandoc mempty [Plain xs]
-
-    semUiCdn = "https://cdn.jsdelivr.net/npm/semantic-ui@2.4.2/dist/semantic.min.css"
-    elLinkGoogleFont name =
-      elAttr "link" ("href" =: fontUrl <> "rel" =: "stylesheet" <> "type" =: "text/css") blank
-      where
-        fontUrl = "https://fonts.googleapis.com/css?family=" <> (T.replace " " "-" name)
-    elMeta k v = elAttr "meta" ("name" =: k <> "content" =: v) blank

src/Reflex/Dom/Pandoc/Document.hs

@@ -1,7 +1,10 @@
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE OverloadedStrings #-}
 
-module Reflex.Dom.Pandoc.Document where
+module Reflex.Dom.Pandoc.Document
+  ( elPandocDoc
+  , elPandocInlines
+  )where
 
 import Control.Monad (forM_)
 import qualified Data.Text as T
@@ -76,3 +79,9 @@ elPandocDoc (Pandoc _meta blocks) = renderBlocks blocks
     notImplemented x = do
       el "strong" $ text "NotImplemented: "
       el "pre" $ el "code" $ text $ T.pack $ show x
+
+-- | Render list of Pandoc inlines
+--
+-- Useful when dealing with metadata values
+elPandocInlines :: DomBuilder t m => [Inline] -> m ()
+elPandocInlines xs = elPandocDoc $ Pandoc mempty [Plain xs]

src/Rib/App.hs

@@ -36,16 +36,16 @@ cli = modes
   , Generate
       { force = False &= help "Force generation of all files"
       } &= help "Generate the site"
-        &= auto  -- | Generate is the default command.
+        &= auto  -- Generate is the default command.
   ]
 
 -- | CLI entry point for running the Rib app
-run :: S.Settings -> IO ()
+run :: S.Settings x -> IO ()
 run cfg = runWith cfg =<< cmdArgs cli
 
 -- | Like `run` but uses the given `App` mode instead of reading it from CLI
 -- arguments.
-runWith :: S.Settings -> App -> IO ()
+runWith :: S.Settings x -> App -> IO ()
 runWith cfg = \case
   Watch -> withManager $ \mgr -> do
     -- Begin with a *full* generation as the HTML layout may have been changed.

src/Rib/Settings.hs

@@ -1,19 +1,23 @@
+{-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE Rank2Types #-}
+{-# LANGUAGE ScopedTypeVariables #-}
 
 module Rib.Settings where
 
 import Data.Default (Default (def))
 import Data.Text (Text)
+import qualified Data.Text as T
 
 import Development.Shake.FilePath (FilePath)
+import Reflex.Dom.Core
 import Text.Pandoc (Extension (..), Pandoc, ReaderOptions, extensionsFromList, githubMarkdownExtensions,
                     readMarkdown, readerExtensions, runPure)
 
 import Rib.Types (Page)
 
 
-data Settings = Settings
-  { pageHTML :: Page -> IO String
+data Settings x = Settings
+  { pageWidget :: Page -> StaticWidget x ()
   -- ^ Reflex widget for the page
   , parsePage :: Text -> Pandoc
   -- ^ Parse a text document like Markdown into Pandoc structure
@@ -32,12 +36,12 @@ data Settings = Settings
   -- changed in our Haskell source.
   }
 
-instance Default Settings where
+instance Default (Settings x) where
   def = Settings
-    { pageHTML = pure . show
+    { pageWidget = el "tt" . text . T.pack . show
     , parsePage = either (error . show) id . runPure . readMarkdown markdownOptions
-    , contentDir = "site"
-    , destDir = "generated"
+    , contentDir = "content"
+    , destDir = "content.generated"
     , staticFilePatterns = ["images//*"]
     , postFilePatterns = ["*.md"]
     , rebuildPatterns = ["**/*.html", "**/*.md"]

src/Rib/Shake.hs

@@ -16,6 +16,7 @@ import Development.Shake (Action, Rebuild (..), Verbosity (Chatty), copyFileChan
                           readFile', shakeArgs, shakeOptions, shakeRebuild, shakeVerbosity, want, writeFile',
                           (%>), (|%>), (~>))
 import Development.Shake.FilePath (dropDirectory1, dropExtension, (-<.>), (</>))
+import Reflex.Dom.Core (renderStatic)
 
 import Slick (jsonCache')
 
@@ -26,11 +27,11 @@ import Rib.Types
 ribShake
   :: Bool
   -- ^ Force generate of requested targes
-  -> S.Settings
+  -> S.Settings x
   -- ^ Site settings
   -> IO ()
 ribShake forceGen cfg = withArgs [] $ do
-  -- ^ The withArgs above is to ensure that our own app arguments is not
+  -- The withArgs above is to ensure that our own app arguments is not
   -- confusing Shake.
   let opts = shakeOptions
         { shakeVerbosity = Chatty
@@ -64,13 +65,13 @@ ribShake forceGen cfg = withArgs [] $ do
     (S.destDir cfg </> "index.html") %> \out -> do
       files <- getDirectoryFiles (S.contentDir cfg) $ S.postFilePatterns cfg
       posts <- traverse (getPostCached . PostFilePath . (S.contentDir cfg </>)) files
-      html <- liftIO $ S.pageHTML cfg $ Page_Index posts
+      html <- liftIO $ renderPost $ Page_Index posts
       writeFile' out html
 
     -- rule for actually building posts
     (S.destDir cfg </> "*.html") %> \out -> do
       post <- getPostCached $ PostFilePath $ destToSrc out -<.> "md"
-      html <- liftIO $ S.pageHTML cfg $ Page_Post post
+      html <- liftIO $ renderPost $ Page_Post post
       writeFile' out html
 
   where
@@ -83,6 +84,8 @@ ribShake forceGen cfg = withArgs [] $ do
           postURL = T.pack $ ("/" ++) . dropDirectory1 . dropExtension $ postPath
       pure $ Post doc postURL
 
+    renderPost = fmap (BS8.unpack . snd) . renderStatic . S.pageWidget cfg
+
     -- | Convert 'build' filepaths into source file filepaths
     destToSrc :: FilePath -> FilePath
     destToSrc = (S.contentDir cfg </>) . dropDirectory1

src/Rib/Types.hs

@@ -1,16 +1,25 @@
 {-# LANGUAGE DeriveAnyClass #-}
 {-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE OverloadedStrings #-}
 
-module Rib.Types where
+module Rib.Types
+  ( Page(..)
+  , Post(..)
+  , PostCategory(..)
+  , PostFilePath(..)
+  , getPostAttribute
+  , getPostAttributeJson
+  ) where
 
-import Data.Aeson (FromJSON, ToJSON)
+import Data.Aeson (FromJSON, ToJSON, decode)
 import qualified Data.Map as Map
 import Data.Text (Text)
 import GHC.Generics (Generic)
 
 import Development.Shake.Classes (Binary, Hashable, NFData)
-import Text.Pandoc (Inline, Meta (unMeta), MetaValue (MetaInlines), Pandoc (Pandoc))
+import Text.Pandoc (Inline (Str), Meta (unMeta), MetaValue (MetaInlines), Pandoc (Pandoc))
+import Text.Pandoc.UTF8 (fromStringLazy)
 
 -- | Represents a HTML page that will be generated
 data Page
@@ -46,3 +55,15 @@ getPostAttribute k (Post (Pandoc meta _) _) =
     -- comment above.
     Just (MetaInlines inlines) -> Just inlines
     _ -> Nothing
+
+-- Like getPostAttribute but expects the value to be JSON encoding of a type.
+getPostAttributeJson :: FromJSON a => String -> Post -> Maybe a
+getPostAttributeJson k p = do
+  v <- getPostAttributeRaw k p
+  decode $ fromStringLazy v
+
+getPostAttributeRaw :: String -> Post -> Maybe String
+getPostAttributeRaw k p = do
+  getPostAttribute k p >>= \case
+    [Str v] -> Just v
+    _ -> Nothing