Move specialized code and types to Rib.Simple (#18)

* Move specialized code and types to Rib.Simple

Everything else is supposed to be generic, to be used by users wanting
greater customization without hardcoded stuff.

* parametrize parsePage to be of `page` as well

* Rename to renderPage

to match parsePage

* Fix broken url

* Some simplification

* more cleanup

README.md

@@ -21,7 +21,7 @@ $ cloc --by-file example/*.hs
 -------------------------------------------------------------------------------
 File                             blank        comment           code
 -------------------------------------------------------------------------------
-example/Main.hs                     23             16            102
+example/Main.hs                     19              9            100
 -------------------------------------------------------------------------------
 ```
 
@@ -40,7 +40,7 @@ Or simply (no cabal file needed),
 
 ```bash
 
-nix-shell ../default.nix --run "ghcid -c 'ghci -Wall -i../rib/src Main.hs' -T 'Rib.App.dev Main.settings' --reload=Main.hs"
+nix-shell ../default.nix --run "ghcid -c 'ghci -Wall -i../src Main.hs' -T 'Rib.App.dev Main.settings' --reload=Main.hs"
 ```
 
 

example/Main.hs

@@ -20,12 +20,15 @@ import GHC.Generics
 import Clay hiding (type_)
 import Lucid
 
-import qualified Rib
 import qualified Rib.App as App
 import Rib.Pandoc
 import qualified Rib.Settings as S
-import Rib.Types
+import Rib.Simple (Page (..), Post (..))
+import qualified Rib.Simple as Simple
 
+-- TODO: Consider using Read instead of FromJSON as that is human-friendly in
+-- Yaml metadata.
+-- And then remove aeson from cabal.
 data PostCategory
   = Programming
   | Other
@@ -34,9 +37,9 @@ data PostCategory
 -- | Configure this site here.
 --
 -- See `S.Settings` for the settings available.
-settings :: S.Settings
-settings = Rib.defaultSiteSettings
-  { S.pageWidget = pageWidget
+settings :: S.Settings Page
+settings = Simple.settings
+  { S.renderPage = renderPage
   -- ^ How to render a page type
   }
 
@@ -75,8 +78,8 @@ pageStyle = body ? do
       width $ pct 50
     footer ? textAlign center
 
-pageWidget :: Page -> Html ()
-pageWidget page = with html_ [lang_ "en"] $ do
+renderPage :: Page -> Html ()
+renderPage page = with html_ [lang_ "en"] $ do
   head_ $ do
     meta_ [name_ "charset", content_ "utf-8"]
     meta_ [name_ "description", content_ "Sridhar's notes"]
@@ -103,7 +106,7 @@ pageWidget page = with html_ [lang_ "en"] $ do
             postList otherPosts
           Page_Post post ->
             with article_ [class_ "post"] $
-              toHtmlRaw =<< pandoc2Html (_post_doc post)
+              toHtmlRaw $ pandoc2Html $ _post_doc post
         with a_ [class_ "ui green right ribbon label", href_ "https://www.srid.ca"] "Sridhar Ratnakumar"
     -- Load Google fonts at the very end for quicker page load.
     forM_ googleFonts $ \f ->
@@ -117,7 +120,7 @@ pageWidget page = with html_ [lang_ "en"] $ do
       Page_Post post -> postTitle post
 
     -- Render the post title (Markdown supported)
-    postTitle = maybe "Untitled" (toHtmlRaw <=< pandocInlines2Html) . getPandocMetaInlines "title" . _post_doc
+    postTitle = maybe "Untitled" (toHtmlRaw . pandocInlines2Html) . getPandocMetaInlines "title" . _post_doc
 
     -- Render a list of posts
     postList :: [Post] -> Html ()
@@ -125,4 +128,4 @@ pageWidget page = with html_ [lang_ "en"] $ do
       with div_ [class_ "item"] $ do
         with a_ [class_ "header", href_ (_post_url x)] $
           postTitle x
-        small_ $ maybe mempty (toHtmlRaw <=< pandocInlines2Html) $ getPandocMetaInlines "description" $ _post_doc x
+        small_ $ maybe mempty (toHtmlRaw . pandocInlines2Html) $ getPandocMetaInlines "description" $ _post_doc x

rib.cabal

@@ -19,14 +19,13 @@ source-repository head
 
 library
   exposed-modules:
-      Rib
-    , Rib.App
+      Rib.App
     , Rib.Pandoc
     , Rib.Settings
-    , Rib.Types
+    , Rib.Shake
+    , Rib.Simple
   other-modules:
-      Rib.Shake
-    , Rib.Server
+      Rib.Server
   hs-source-dirs:
       src
   ghc-options: -Wall -Wincomplete-uni-patterns -Wincomplete-record-updates
@@ -67,7 +66,6 @@ executable rib-example
       aeson
     , base
     , clay
-    , directory
     , lucid
     , rib
     , text

src/Rib.hs

@@ -1,39 +0,0 @@
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE Rank2Types #-}
-{-# LANGUAGE ScopedTypeVariables #-}
--- | TODO: Use this as the only exposed module for Rib?
-module Rib where
-
-import Data.Default (Default (def))
-import qualified Data.Text as T
-
-import Lucid
-import Text.Pandoc
-
-import Rib.Settings
-import Rib.Shake
-
-defaultSiteSettings :: Settings
-defaultSiteSettings = Settings
-  { pageWidget = pre_ . toHtml . T.pack . show
-  , parsePage = either (error . show) id . runPure . readMarkdown markdownOptions
-
-  , contentDir = "content"
-  , destDir = "content.generated"
-  , rebuildPatterns = ["**/*.html", "**/*.md"]
-
-  , buildRules = simpleBuildRules ["static//**"] ["*.md"]
-  }
-  where
-    -- | Reasonable options for reading a markdown file
-    markdownOptions :: ReaderOptions
-    markdownOptions = def { readerExtensions = exts }
-     where
-      exts = mconcat
-        [ extensionsFromList
-          [ Ext_yaml_metadata_block
-          , Ext_fenced_code_attributes
-          , Ext_auto_identifiers
-          ]
-        , githubMarkdownExtensions
-        ]

src/Rib/App.hs

@@ -41,21 +41,21 @@ cli = modes
   ]
 
 -- | CLI entry point for running the Rib app
-run :: S.Settings -> IO ()
+run :: S.Settings page -> IO ()
 run cfg = runWith cfg =<< cmdArgs cli
 
 -- | Run development server that watches and generates files in addition to
 -- serving them.
 --
 -- This should be used with ghcid's `-T` argument.
-dev :: S.Settings -> IO ()
+dev :: S.Settings page -> IO ()
 dev cfg = runWith cfg $ Serve devPort True
   where
     devPort = 8080
 
 -- | Like `run` but uses the given `App` mode instead of reading it from CLI
 -- arguments.
-runWith :: S.Settings -> App -> IO ()
+runWith :: S.Settings page -> App -> IO ()
 runWith cfg = \case
   Watch -> withManager $ \mgr -> do
     -- Begin with a *full* generation as the HTML layout may have been changed.

src/Rib/Pandoc.hs

@@ -47,15 +47,30 @@ pandoc2Html' = runPure . writeHtml5String settings
     settings :: WriterOptions
     settings = def
 
--- TODO: remove Monad and use error (like hakyll does)
-pandoc2Html :: Monad m => Pandoc -> m Text
-pandoc2Html = either (fail . show) pure . pandoc2Html'
+pandoc2Html :: Pandoc -> Text
+pandoc2Html = either (error . show) id . pandoc2Html'
 
 pandocInlines2Html' :: [Inline] -> Either PandocError Text
-pandocInlines2Html' = pandoc2Html . Pandoc mempty . pure . Plain
+pandocInlines2Html' = pandoc2Html' . Pandoc mempty . pure . Plain
 
-pandocInlines2Html :: Monad m => [Inline] -> m Text
-pandocInlines2Html = either (fail . show) pure . pandocInlines2Html'
+pandocInlines2Html :: [Inline] -> Text
+pandocInlines2Html = either (error . show) id . pandocInlines2Html'
 
 highlightingStyle :: Text
 highlightingStyle = T.pack $ styleToCss tango
+
+parsePandoc :: Text -> Pandoc
+parsePandoc = either (error . show) id . runPure . readMarkdown markdownReaderOptions
+  where
+    -- | Reasonable options for reading a markdown file
+    markdownReaderOptions :: ReaderOptions
+    markdownReaderOptions = def { readerExtensions = exts }
+      where
+      exts = mconcat
+        [ extensionsFromList
+          [ Ext_yaml_metadata_block
+          , Ext_fenced_code_attributes
+          , Ext_auto_identifiers
+          ]
+        , githubMarkdownExtensions
+        ]

src/Rib/Settings.hs

@@ -4,24 +4,18 @@
 
 module Rib.Settings where
 
-import Data.Text (Text)
-
 import Development.Shake
 import Lucid (Html)
-import Text.Pandoc
-
-import Rib.Types
-
 
 -- | Settings for building a static site.
 --
 -- TODO: When settings change it should invalidate Shake cache. How do we do it?
-data Settings = Settings
-  { pageWidget :: Page -> Html ()
+data Settings page = Settings
+  { renderPage :: page -> Html ()
   -- ^ Lucid widget for the page
 
-  , parsePage :: Text -> Pandoc
-  -- ^ Parse a text document like Markdown into Pandoc structure
+  , parsePage :: FilePath -> Action page
+  -- ^ Parse a text document like Markdown into Page structure
 
   , contentDir :: FilePath
   -- ^ Directory name of the source content
@@ -35,11 +29,6 @@ data Settings = Settings
   -- We rebuild only the post files, assuming html/css/md file parsing has
   -- changed in our Haskell source.
 
-  , buildRules :: Settings -> Action ()
+  , buildRules :: Settings page -> Action ()
   -- ^ Build rules specifying how to build the site
-  --
-  -- A simple implementation is included, which you may copy over to customize
-  -- your own version.
-  --
-  -- TODO: Better API than ReaderT of a tuple?
   }

src/Rib/Shake.hs

@@ -1,38 +1,28 @@
 {-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE RecordWildCards #-}
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RecordWildCards #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TupleSections #-}
 
 module Rib.Shake
   ( ribShake
-  , simpleBuildRules
   , parsePandocCached
   ) where
 
-import Control.Monad
-import Control.Monad.IO.Class (liftIO)
-import Data.Aeson (decode, encode)
+import Data.Aeson
 import Data.Bool (bool)
-import qualified Data.ByteString.Char8 as BS8
 import Data.Maybe
-import qualified Data.Text.Encoding as T
 
 import Development.Shake
-import Development.Shake.FilePath ((-<.>), (</>))
 import Development.Shake.Forward (cacheAction, shakeForward)
-import Lucid
-import Text.Pandoc (Pandoc)
 
-import Rib.Server (getHTMLFileUrl)
 import qualified Rib.Settings as S
-import Rib.Types
 
 
 ribShake
   :: Bool
   -- ^ Force generate of requested targes
-  -> S.Settings
+  -> S.Settings page
   -- ^ Site settings
   -> IO ()
 ribShake forceGen cfg = do
@@ -43,42 +33,9 @@ ribShake forceGen cfg = do
   shakeForward opts $
     S.buildRules cfg cfg
 
--- Build rules for the simplest site possible.
---
--- Just posts and static files.
-simpleBuildRules
-  :: [FilePath]
-  -- ^ Which files are considered to be static files.
-  -> [FilePath]
-  -- ^ Which files are considered to be post files
-  -> S.Settings
-  -> Action ()
-simpleBuildRules staticFilePatterns postFilePatterns cfg@S.Settings {..} = do
-  -- Copy static assets
-  files <- getDirectoryFiles contentDir staticFilePatterns
-  void $ forP files $ \inp ->
-    copyFileChanged (contentDir </> inp) (destDir </> inp)
-
-  -- Generate posts
-  postFiles <- getDirectoryFiles contentDir postFilePatterns
-  posts <- forP postFiles $ \f -> do
-    let out = destDir </> f -<.> "html"
-        inp = contentDir </> f
-    doc <- parsePandocCached cfg inp
-    let post = Post doc $ getHTMLFileUrl f
-    liftIO $ renderToFile out $ pageWidget $ Page_Post post
-    pure post
-
-  -- Generate the main table of contents
-  -- TODO: Support `draft` property
-  liftIO $ renderToFile (destDir </> "index.html") $
-    pageWidget $ Page_Index posts
-
-parsePandocCached :: S.Settings -> FilePath -> Action Pandoc
+parsePandocCached :: (FromJSON page, ToJSON page) => S.Settings page -> FilePath -> Action page
 parsePandocCached cfg f =
-  jsonCacheAction f $ parsePandoc $ S.parsePage cfg
+  jsonCacheAction f $ S.parsePage cfg f
   where
     jsonCacheAction k =
       fmap (fromMaybe (error "cache error") . decode) . cacheAction k . fmap encode
-    parsePandoc parse =
-      parse . T.decodeUtf8 . BS8.pack <$> readFile' f

src/Rib/Simple.hs

@@ -0,0 +1,86 @@
+{-# LANGUAGE DeriveAnyClass #-}
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RecordWildCards #-}
+
+-- Sensible defaults for writing the most simple static site
+module Rib.Simple
+  ( Page(..)
+  , Post(..)
+  , simpleBuildRules
+  , settings
+  ) where
+
+import Control.Monad
+import Data.Aeson (FromJSON, ToJSON)
+import Data.Text (Text)
+import qualified Data.Text as T
+import GHC.Generics (Generic)
+
+import Development.Shake
+import Development.Shake.FilePath
+import Lucid
+import Text.Pandoc (Pandoc)
+
+import Rib.Pandoc (parsePandoc)
+import Rib.Server (getHTMLFileUrl)
+import qualified Rib.Settings as S
+
+-- | Represents a HTML page that will be generated
+data Page
+  = Page_Index [Post]
+  | Page_Post Post
+  deriving (Generic, Show, FromJSON, ToJSON)
+
+-- | A Post corresponding to the Markdown content
+data Post = Post
+  { _post_doc :: Pandoc
+  , _post_url :: Text
+  }
+  deriving (Generic, Eq, Ord, Show, FromJSON, ToJSON)
+
+-- Build rules for the simplest site possible.
+--
+-- Just posts and static files.
+simpleBuildRules
+  :: [FilePath]
+  -- ^ Which files are considered to be static files.
+  -> [FilePath]
+  -- ^ Which files are considered to be post files
+  -> S.Settings Page
+  -> Action ()
+simpleBuildRules staticFilePatterns postFilePatterns S.Settings {..} = do
+  -- Copy static assets
+  files <- getDirectoryFiles contentDir staticFilePatterns
+  void $ forP files $ \inp ->
+    copyFileChanged (contentDir </> inp) (destDir </> inp)
+
+  -- Generate posts
+  postFiles <- getDirectoryFiles contentDir postFilePatterns
+  posts <- forP postFiles $ \f -> do
+    let out = destDir </> f -<.> "html"
+        inp = contentDir </> f
+    Page_Post post <- parsePage inp
+    liftIO $ renderToFile out $ renderPage $ Page_Post post
+    pure post
+
+  -- Generate the main table of contents
+  -- TODO: Support `draft` property
+  liftIO $ renderToFile (destDir </> "index.html") $
+    renderPage $ Page_Index posts
+
+
+settings :: S.Settings Page
+settings = S.Settings
+  { renderPage = \page -> do
+      h1_ "TODO: You should override the pageWidget function in your settings"
+      pre_ $ toHtml $ T.pack $ show page
+  , parsePage = \f -> do
+      doc <- parsePandoc . T.pack <$> readFile' f
+      pure $ Page_Post $ Post doc $ getHTMLFileUrl $ dropDirectory1 f
+  , contentDir = "content"
+  , destDir = "content.generated"
+  , rebuildPatterns = ["**/*.html", "**/*.md"]
+
+  , buildRules = simpleBuildRules ["static//**"] ["*.md"]
+  }

src/Rib/Types.hs

@@ -1,35 +0,0 @@
-{-# LANGUAGE DeriveAnyClass #-}
-{-# LANGUAGE DeriveGeneric #-}
-{-# LANGUAGE LambdaCase #-}
-{-# LANGUAGE OverloadedStrings #-}
-
-module Rib.Types
-  ( Page(..)
-  , Post(..)
-  , PostFilePath(..)
-  ) where
-
-import Data.Aeson (FromJSON, ToJSON)
-import Data.Text (Text)
-import GHC.Generics (Generic)
-
-import Development.Shake.Classes (Binary, Hashable, NFData)
-import Text.Pandoc (Pandoc)
-
--- | Represents a HTML page that will be generated
-data Page
-  = Page_Index [Post]
-  | Page_Post Post
-  deriving (Generic, Show, FromJSON, ToJSON)
-
--- | A JSON serializable representation of a post's metadata
-data Post = Post
-  { _post_doc :: Pandoc
-  , _post_url :: Text
-  }
-  deriving (Generic, Eq, Ord, Show, FromJSON, ToJSON)
-
--- A simple wrapper data-type which implements 'ShakeValue';
--- Used as a Shake Cache key to build a cache of post objects.
-newtype PostFilePath = PostFilePath FilePath
-  deriving (Show, Eq, Hashable, Binary, NFData, Generic)