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

Break down Rib.Simple into reusable functions (#24)

Browse Source 
* Shake combinators in `Rib.Shake` (which `Rib.Simple` uses)
* doc: Add next/ prev navigation to guide pages using a custom action
* doc: `guide.json` specifies the navigation list
This commit is contained in:
Sridhar Ratnakumar 2019-07-18 09:42:38 -04:00 committed by GitHub
parent ebcd713718
commit ad8576b198
No known key found for this signature in database
GPG Key ID: 4AEE18F83AFDEB23
9 changed files with 186 additions and 152 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
README.md
View File

@ -46,7 +46,7 @@ This will:
- Drop into a nix-shell with needed Haskell dependencies
- Compile the `rib` library and `example/Main.hs` through ghcid
- Whenever Haskell sources change ghcid reloads them
- Run `example/Main.hs:main` with `serve -w` CLI arguments
- Run `example/Main.hs:buildAction` (as if with `serve -w` CLI arguments)
- This does the following:
1. Convert sources in `./example/a` into `./example/b` using Shake
2. Listens for changes to `./example/a`, and re-generate them (i.e., the `-w` argument)

81
doc/Main.hs
View File

@ -1,5 +1,6 @@
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}
module Main where
@ -11,20 +12,23 @@ import qualified Data.ByteString.Lazy as BSL
import Data.Functor ((<&>))
import qualified Data.Map as Map
import Data.Maybe
import Data.Profunctor (dimap)
import Data.Text (Text)
import qualified Data.Text as T
import Data.Text.Encoding (encodeUtf8)
import Clay hiding (type_)
import Clay hiding (filter, not, reverse, type_)
import Development.Shake
import Development.Shake.FilePath
import Lucid
import Text.Pandoc
import qualified Rib.App as App
import Rib.Pandoc (getPandocMetaHTML, highlightingCss, pandoc2Html, parsePandoc)
import Rib.Pandoc (getPandocMetaHTML, getPandocMetaValue, highlightingCss, pandoc2Html, parsePandoc,
setPandocMetaValue)
import Rib.Server (getHTMLFileUrl)
import Rib.Simple (Page (..), Post (..), isDraft)
import qualified Rib.Shake as Shake
import Rib.Simple (Page (..))
import qualified Rib.Simple as Simple
main :: IO ()
@ -32,13 +36,34 @@ main = App.run buildAction
buildAction :: Action ()
buildAction = do
void $ Shake.buildStaticFiles ["static//**"]
toc <- guideToc
void $ Simple.buildStaticFiles ["static//**"]
posts <- Simple.buildPostFiles ["*.md"] renderPage
let postMap = Map.fromList $ posts <&> \post -> (_post_srcPath post, post)
guidePosts <- forM toc $ \slug -> maybe (fail "slug not found") pure $
Map.lookup slug postMap
Simple.buildIndex guidePosts renderPage
posts <- applyGuide toc <$> Shake.readPandocMulti ["*.md"]
void $ forP posts $ \x ->
Shake.buildHtml (fst x -<.> "html") (renderPage $ Page_Post x)
Shake.buildHtml "index.html" $ renderPage $ Page_Index posts
-- | Apply the guide metadata to a list of pages
applyGuide :: (Ord f, Show f) => [f] -> [(f, Pandoc)] -> [(f, Pandoc)]
applyGuide fs xs =
flip mapWithAdj fsComplete $ \mprev (f, doc) mnext -> (f,) $
setPandocMetaValueMaybe "next" mnext $
setPandocMetaValueMaybe "prev" mprev doc
where
-- | Like `fmap` on lists but passes the previous and next element as well.
mapWithAdj :: (Maybe a -> a -> Maybe a -> b) -> [a] -> [b]
mapWithAdj f l = zipWith3 f (rshift1 l) l (shift1 l)
where
shift1 = (<> [Nothing]) . fmap Just . drop 1
rshift1 = dimap reverse reverse shift1
setPandocMetaValueMaybe :: Show a => String -> Maybe a -> Pandoc -> Pandoc
setPandocMetaValueMaybe k mv doc = maybe doc (\v -> setPandocMetaValue k v doc) mv
-- Like `fs` but along with the associated Pandoc document (pulled from `xs`)
fsComplete = fs <&> \f -> (f,) $ fromJust $ Map.lookup f xsMap
xsMap = Map.fromList xs
guideToc :: Action [FilePath]
guideToc = do
@ -63,21 +88,22 @@ renderPage page = with html_ [lang_ "en"] $ do
with a_ [class_ "ui violet ribbon label", href_ "/"] "Rib"
-- Main content
with h1_ [class_ "ui huge header"] $ fromMaybe siteTitle pageTitle
with div_ [class_ "ui note message"] $ pandoc2Html $ parsePandoc
with div_ [class_ "ui warning message"] $ pandoc2Html $ parsePandoc
"Please note: Rib is still a **work in progress**. The API might change before the initial public release. The content you read here should be considered draft version of the upcoming documentation."
case page of
Page_Index posts -> do
p_ "Rib is a static site generator written in Haskell that reuses existing tools (Shake, Lucid and Clay) and is thus non-monolithic."
with div_ [class_ "ui relaxed divided list"] $ forM_ posts $ \x ->
with div_ [class_ "ui relaxed divided list"] $ forM_ posts $ \(f, doc) ->
with div_ [class_ "item"] $ do
with a_ [class_ "header", href_ (getHTMLFileUrl $ _post_srcPath x)] $
postTitle x
small_ $ fromMaybe mempty $ getPandocMetaHTML "description" $ _post_doc x
Page_Post post -> do
when (isDraft post) $
with a_ [class_ "header", href_ (getHTMLFileUrl f)] $
postTitle doc
small_ $ fromMaybe mempty $ getPandocMetaHTML "description" doc
Page_Post (_, doc) -> do
when (Simple.isDraft doc) $
with div_ [class_ "ui warning message"] "This is a draft"
postNav doc
with article_ [class_ "post"] $
pandoc2Html $ _post_doc post
pandoc2Html doc
with a_ [class_ "ui green right ribbon label", href_ "https://github.com/srid/rib"] "Github"
-- Load Google fonts at the very end for quicker page load.
forM_ googleFonts $ \f ->
@ -87,10 +113,25 @@ renderPage page = with html_ [lang_ "en"] $ do
siteTitle = "Rib - Haskell static site generator"
pageTitle = case page of
Page_Index _ -> Nothing
Page_Post post -> Just $ postTitle post
Page_Post (_, doc) -> Just $ postTitle doc
-- Render the post title (Markdown supported)
postTitle = fromMaybe "Untitled" . getPandocMetaHTML "title" . _post_doc
postTitle = fromMaybe "Untitled" . getPandocMetaHTML "title"
-- Post navigation header
postNav :: Pandoc -> Html ()
postNav doc = with div_ [class_ "ui secondary segment"] $
with div_ [class_ "ui grid"] $
with div_ [class_ "four column row"] $
forM_ [("prev", "Prev", "left"), ("next", "Next", "right")] $
\(k, navLabel, navDir) -> with div_ [class_ $ navDir <> " floated column"] $
case getPandocMetaValue k doc of
Nothing -> mempty
-- FIXME: Don't have to specify type here; figure out a better solution.
Just (f :: FilePath, otherDoc :: Pandoc) -> strong_ $
with a_ [class_ "header", href_ (getHTMLFileUrl f)] $ do
navLabel <> ": "
fromMaybe "Untitled" $ getPandocMetaHTML "title" otherDoc
-- | CSS
pageStyle :: Css

27
doc/a/getting-started.md
View File

@ -29,11 +29,10 @@ _This_ file is written in **Markdown**.
Finally, add the Haskell source `Main.hs` that wires everything together. Notice
the following:
- We use `Rib.Simple` that does the necessary Shake machinery for us---take a
peek at that module if you'd like to customize the behaviour of static site
generation by writing your own Shake action---in addition to providing the
`Page` type that distinguishes between a `Post` file (i.e., the Markdown file
above) and the index file (`index.html`), which links to the list of posts.
- We use `Rib.Simple.buildAction` that wires together the necessary Shake
combinators (defined in `Rib.Shake`) for us---take a peek at that module if
you'd like to customize the behaviour of static site generation by writing your
own Shake action.
- `App.run` provides file monitoring and http serving on top of site
generation.
@ -57,7 +56,7 @@ import Lucid
import qualified Rib.App as App
import Rib.Pandoc (getPandocMetaHTML, highlightingCss, pandoc2Html)
import Rib.Server (getHTMLFileUrl)
import Rib.Simple (Page (..), Post (..), isDraft)
import Rib.Simple (Page (..), isDraft)
import qualified Rib.Simple as Simple
main :: IO ()
@ -79,21 +78,21 @@ renderPage page = with html_ [lang_ "en"] $ do
h1_ pageTitle
case page of
Page_Index posts ->
div_ $ forM_ posts $ \post -> div_ $ do
with a_ [href_ (getHTMLFileUrl $ _post_srcPath post)] $ postTitle post
small_ $ maybe mempty toHtmlRaw $ getPandocMetaHTML "description" $ _post_doc post
Page_Post post -> do
when (isDraft post) $
div_ $ forM_ posts $ \(f, doc) -> div_ $ do
with a_ [href_ (getHTMLFileUrl f)] $ postTitle doc
small_ $ maybe mempty toHtmlRaw $ getPandocMetaHTML "description" doc
Page_Post (_, doc) -> do
when (isDraft doc) $
div_ "This is a draft"
with article_ [class_ "post"] $
toHtmlRaw $ pandoc2Html $ _post_doc post
toHtmlRaw $ pandoc2Html doc
where
pageTitle = case page of
Page_Index _ -> "My website!"
Page_Post post -> postTitle post
Page_Post (_, doc) -> postTitle doc
-- Render the post title (Markdown supported)
postTitle = maybe "Untitled" toHtmlRaw . getPandocMetaHTML "title" . _post_doc
postTitle = maybe "Untitled" toHtmlRaw . getPandocMetaHTML "title"
-- | CSS
pageStyle :: Css

16
doc/a/inbox.md
View File

@ -16,13 +16,15 @@ description: This stuff is hidden if not private
- [X] MVP - rib.srid.ca
- [ ] Navigation (next <> title <> prev)
- Define post slugs (/inbox.md => "/inbox.md")
- Make a `map` of posts keyed by their slug
- Have getPageUrl use this
- Define hierarchy in Main.hs:
```
postHierarchy = [ "/introduction", "/getting-started" ]
```
- [X] Post slugs and `guide.json`
- [X] Pandoc metadata system (at least, as simple as `setPandocMetaValue`)
- [ ] Inject next/prev keys into Pandoc metadata
- [X] Patch `DocPage` in the render function passed to `buildHtmlMulti`
- Need to do a lookup guide.json each time, which is okay.
- [X] Include title from yet-unparsed next/prev docs. How? :-S
- [ ] Refactor
- [ ] getting-started: instruct cp example/Main.hs and create a separate page
explaining Main.hs (literate haskell if possible;)
### Rib, for journaling

18
example/Main.hs
View File

@ -13,7 +13,7 @@ import Lucid
import qualified Rib.App as App
import Rib.Pandoc (getPandocMetaHTML, highlightingCss, pandoc2Html)
import Rib.Server (getHTMLFileUrl)
import Rib.Simple (Page (..), Post (..), isDraft)
import Rib.Simple (Page (..), isDraft)
import qualified Rib.Simple as Simple
main :: IO ()
@ -35,21 +35,21 @@ renderPage page = with html_ [lang_ "en"] $ do
h1_ pageTitle
case page of
Page_Index posts ->
div_ $ forM_ posts $ \post -> div_ $ do
with a_ [href_ (getHTMLFileUrl $ _post_srcPath post)] $ postTitle post
small_ $ maybe mempty toHtmlRaw $ getPandocMetaHTML "description" $ _post_doc post
Page_Post post -> do
when (isDraft post) $
div_ $ forM_ posts $ \(f, doc) -> div_ $ do
with a_ [href_ (getHTMLFileUrl f)] $ postTitle doc
small_ $ maybe mempty toHtmlRaw $ getPandocMetaHTML "description" doc
Page_Post (_, doc) -> do
when (isDraft doc) $
div_ "This is a draft"
with article_ [class_ "post"] $
toHtmlRaw $ pandoc2Html $ _post_doc post
toHtmlRaw $ pandoc2Html doc
where
pageTitle = case page of
Page_Index _ -> "My website!"
Page_Post post -> postTitle post
Page_Post (_, doc) -> postTitle doc
-- Render the post title (Markdown supported)
postTitle = maybe "Untitled" toHtmlRaw . getPandocMetaHTML "title" . _post_doc
postTitle = maybe "Untitled" toHtmlRaw . getPandocMetaHTML "title"
-- | CSS
pageStyle :: Css

21
src/Rib/App.hs
View File

@ -14,13 +14,14 @@ module Rib.App
import Control.Concurrent (threadDelay)
import Control.Concurrent.Async (concurrently_)
import Control.Monad (forever, void, when)
import Data.Bool (bool)
import Development.Shake (Action)
import Development.Shake
import Development.Shake.Forward (shakeForward)
import System.Console.CmdArgs
import System.FSNotify (watchTree, withManager)
import qualified Rib.Server as Server
import qualified Rib.Shake as Shake
data App
= Watch
@ -43,7 +44,7 @@ ribInputDir = "a"
-- | CLI entry point for running the Rib app
run :: Action () -> IO ()
run action = runWith action =<< cmdArgs ribCli
run buildAction = runWith buildAction =<< cmdArgs ribCli
where
ribCli = modes
[ Watch
@ -65,19 +66,23 @@ dev p a = runWith a $ Serve p True
-- | Like `run` but uses the given `App` mode instead of reading it from CLI
-- arguments.
runWith :: Action () -> App -> IO ()
runWith action = \case
runWith buildAction = \case
Watch -> withManager $ \mgr -> do
-- Begin with a *full* generation as the HTML layout may have been changed.
runWith action $ Generate True
runWith buildAction $ Generate True
-- And then every time a file changes under the current directory
void $ watchTree mgr ribInputDir (const True) $ const $
runWith action $ Generate False
runWith buildAction $ Generate False
-- Wait forever, effectively.
forever $ threadDelay maxBound
Serve p w -> concurrently_
(when w $ runWith action Watch)
(when w $ runWith buildAction Watch)
(Server.serve p ribOutputDir)
Generate forceGen ->
Shake.ribShake forceGen action
let opts = shakeOptions
{ shakeVerbosity = Chatty
, shakeRebuild = bool [] [(RebuildNow, "**")] forceGen
}
in shakeForward opts buildAction

8
src/Rib/Pandoc.hs
View File

@ -3,6 +3,7 @@
-- | Helpers for working with Pandoc documents
module Rib.Pandoc where
import qualified Data.Map as Map
import Data.Maybe
import Data.Text (Text)
import qualified Data.Text as T
@ -47,6 +48,13 @@ getPandocMetaValue k doc = do
getPandocMetaHTML :: String -> Pandoc -> Maybe (Html ())
getPandocMetaHTML k = fmap pandocInlines2Html . getPandocMetaInlines k
-- | Add, or set, a metadata data key to the given Haskell value
setPandocMetaValue :: Show a => String -> a -> Pandoc -> Pandoc
setPandocMetaValue k v (Pandoc (Meta meta) bs) = Pandoc (Meta meta') bs
where
meta' = Map.insert k v' meta
v' = MetaInlines [Str $ show v]
pandoc2Html' :: Pandoc -> Either PandocError Text
pandoc2Html' = runPure . writeHtml5String settings
where

79
src/Rib/Shake.hs
View File

@ -1,37 +1,74 @@
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}
module Rib.Shake
( ribShake
, jsonCacheAction
, Action
) where
-- | Combinators for working with Shake
module Rib.Shake where
import Control.Monad
import Control.Monad.IO.Class
import Data.Aeson (FromJSON, ToJSON)
import qualified Data.Aeson as Aeson
import Data.Binary
import Data.Bool (bool)
import qualified Data.ByteString.Char8 as BSC
import qualified Data.Text.Encoding as T
import qualified Data.Text.Encoding.Error as T
import Data.Typeable
import Development.Shake
import Development.Shake.Forward (cacheAction, shakeForward)
import Development.Shake.FilePath
import Development.Shake.Forward (cacheAction)
import Lucid
import Text.Pandoc (Pandoc)
import Rib.App (ribInputDir, ribOutputDir)
import Rib.Pandoc (parsePandoc)
-- TODO: Should we get rid of this, and have the user directly call shakeForward?
-- As this way we can get rid of the "framework" feel in Main.hs
ribShake
:: Bool
-- ^ Force generate of requested targets
-> Action ()
-- ^ Site build action
-> IO ()
ribShake forceGen buildAction = do
let opts = shakeOptions
{ shakeVerbosity = Chatty
, shakeRebuild = bool [] [(RebuildNow, "**")] forceGen
}
shakeForward opts buildAction
-- | Shake action to copy static files as is
buildStaticFiles :: [FilePattern] -> Action [FilePath]
buildStaticFiles staticFilePatterns = do
files <- getDirectoryFiles ribInputDir staticFilePatterns
void $ forP files $ \f ->
copyFileChanged (ribInputDir </> f) (ribOutputDir </> f)
pure files
-- | Build multiple HTML files given a pattern of source files
--
-- Call `mkA` to create the final value given a file and its pandoc structure.
-- Return the list of final values used to render their HTMLs.
buildHtmlMulti
:: [FilePattern]
-- ^ Source file patterns
-> ((FilePath, Pandoc) -> Html ())
-> Action [(FilePath, Pandoc)]
buildHtmlMulti pat r = do
xs <- readPandocMulti pat
void $ forP xs $ \x ->
buildHtml (fst x -<.> "html") (r x)
pure xs
readPandocMulti :: [FilePattern] -> Action [(FilePath, Pandoc)]
readPandocMulti pat = do
fs <- getDirectoryFiles ribInputDir pat
forP fs $ \f ->
jsonCacheAction f $ (f, ) <$> readPandoc f
readPandoc :: FilePath -> Action Pandoc
readPandoc =
fmap (parsePandoc . T.decodeUtf8With T.lenientDecode . BSC.pack)
. readFile'
. (ribInputDir </>)
-- | Build a single HTML file with the given value
buildHtml :: FilePath -> Html () -> Action ()
buildHtml f html = do
let out = ribOutputDir </> f
writeHtml out html
writeHtml :: MonadIO m => FilePath -> Html () -> m ()
writeHtml f = liftIO . renderToFile f
-- | Like `Development.Shake.cacheAction` but uses JSON instance instead of Typeable / Binary on `b`.
jsonCacheAction :: (FromJSON b, Typeable k, Binary k, Show k, ToJSON a) => k -> Action a -> Action b

86
src/Rib/Simple.hs
View File

@ -1,94 +1,36 @@
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
-- Sensible defaults for writing the most simple static site
module Rib.Simple where
import Control.Monad
import Control.Monad.IO.Class
import Data.Aeson (FromJSON, ToJSON)
import qualified Data.ByteString.Char8 as BSC
import Data.Maybe
import qualified Data.Text.Encoding as T
import qualified Data.Text.Encoding.Error as T
import GHC.Generics (Generic)
import Development.Shake
import Development.Shake.FilePath
import Lucid
import Text.Pandoc (Pandoc)
import Rib.App (ribInputDir, ribOutputDir)
import Rib.Pandoc (getPandocMetaValue, parsePandoc)
import Rib.Shake (Action, jsonCacheAction)
import Rib.Pandoc (getPandocMetaValue)
import Rib.Shake
-- | Represents a HTML page that will be generated
-- | An HTML page that will be generated
data Page
= Page_Index [Post]
| Page_Post Post
= Page_Index [(FilePath, Pandoc)]
| Page_Post (FilePath, Pandoc)
deriving (Generic, Show, FromJSON, ToJSON)
-- | A Post corresponding to the Markdown content
data Post = Post
{ _post_doc :: Pandoc
, _post_srcPath :: FilePath
}
deriving (Generic, Eq, Ord, Show, FromJSON, ToJSON)
isDraft :: Post -> Bool
isDraft = fromMaybe False . getPandocMetaValue "draft" . _post_doc
-- TODO: Eventually this should be subsumed into our Pandoc metadata system.
isDraft :: Pandoc -> Bool
isDraft = fromMaybe False . getPandocMetaValue "draft"
buildAction :: (Page -> Html ()) -> Action ()
buildAction = buildAction' ["static//**"] ["*.md"]
-- Build rules for the simplest site possible.
--
-- Just posts and static files.
buildAction'
:: [FilePath]
-- ^ Which files are considered to be static files.
-> [FilePath]
-- ^ Which files are considered to be post files
-> (Page -> Html ())
-> Action ()
buildAction' staticFilePatterns postFilePatterns renderPage = do
void $ buildStaticFiles staticFilePatterns
posts <- buildPostFiles postFilePatterns renderPage
buildIndex posts renderPage
-- | Shake action to copy static files as is
buildStaticFiles :: [FilePattern] -> Action [FilePath]
buildStaticFiles staticFilePatterns = do
files <- getDirectoryFiles ribInputDir staticFilePatterns
void $ forP files $ \f ->
copyFileChanged (ribInputDir </> f) (ribOutputDir </> f)
pure files
-- | Shake action for generating HTML for post sources
--
-- Return the list of build post objects.
buildPostFiles :: [FilePattern] -> (Page -> Html ()) -> Action [Post]
buildPostFiles postFilePatterns renderPage = do
postFiles <- getDirectoryFiles ribInputDir postFilePatterns
forP postFiles $ \f -> do
let inp = ribInputDir </> f
out = ribOutputDir </> f -<.> "html"
Page_Post post <- jsonCacheAction inp $ readPage f
writePage renderPage out $ Page_Post post
pure post
buildIndex :: [Post] -> (Page -> Html ()) -> Action ()
buildIndex posts renderPage = do
let publicPosts = filter (not . isDraft) posts
writePage renderPage (ribOutputDir </> "index.html") $ Page_Index publicPosts
readPage :: FilePath -> Action Page
readPage f = do
doc <- parsePandoc . T.decodeUtf8With T.lenientDecode . BSC.pack <$> readFile' (ribInputDir </> f)
pure $ Page_Post $ Post doc f
writePage :: MonadIO m => (Page -> Html ()) -> FilePath -> Page -> m ()
writePage renderPage f = liftIO . renderToFile f . renderPage
buildAction renderPage = do
void $ buildStaticFiles ["static/**"]
posts <- buildHtmlMulti ["*.md"] $ renderPage . Page_Post
let publicPosts = filter (not . isDraft . snd) posts
buildHtml "index.html" $ renderPage $ Page_Index publicPosts