Merge pull request #13 from srid/second-site

Improve the library for reuse in a second site

default.nix

@@ -6,11 +6,17 @@
   }) {}
 }:
 
-reflex-platform.project ({ pkgs, ... }: {
-  packages = {
+reflex-platform.project ({ pkgs, hackGet, ... }:
+let
+  pandoc = import ./nix/pandoc.nix { pkgs = pkgs; hackGet = hackGet; };
+in
+{
+  packages = pandoc.packages // {
     rib = ./.;
   };
 
+  overrides = pandoc.overrides;
+
   shells = {
     ghc = ["rib"];
   };

example/Main.hs

@@ -1,4 +1,6 @@
+{-# LANGUAGE DeriveAnyClass #-}
 {-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE DeriveGeneric #-}
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE OverloadedStrings #-}
 
@@ -7,10 +9,12 @@ module Main where
 import Prelude hiding (div, (**))
 
 import Control.Monad
+import Data.Aeson (FromJSON, ToJSON)
 import Data.List (partition)
 import Data.Text (Text)
 import qualified Data.Text as T
 import qualified Data.Text.Lazy as TL
+import GHC.Generics
 
 import Clay
 import Reflex.Dom.Core hiding (display)
@@ -21,9 +25,13 @@ import qualified Reflex.Dom.Pandoc.SyntaxHighlighting as SyntaxHighlighting
 import qualified Rib
 import qualified Rib.App as App
 import qualified Rib.Settings as S
-import Rib.Types (Page (..), Post(..), getPostAttribute, getPostAttributeJson, PostCategory(..))
+import Rib.Types
+import Rib.Pandoc
 
--- TODO: PostCategory and such should not be in library
+data PostCategory
+  = Programming
+  | Other
+  deriving (Generic, Show, Eq, Ord, FromJSON, ToJSON)
 
 -- | Configure this site here.
 --
@@ -93,7 +101,7 @@ pageWidget page = elAttr "html" ("lang" =: "en") $ do
         case page of
           Page_Index posts -> do
             let (progPosts, otherPosts) =
-                  partition ((== Just Programming) . getPostAttributeJson "category") posts
+                  partition ((== Just Programming) . getPandocMetaJson "category" . _post_doc) posts
             elClass "h2" "ui header" $ text "Haskell & Nix notes"
             postList progPosts
             elClass "h2" "ui header" $ text "Other notes"
@@ -114,14 +122,14 @@ pageWidget page = elAttr "html" ("lang" =: "en") $ do
       Page_Post post -> postTitle post
 
     -- Render the post title (Markdown supported)
-    postTitle = maybe (text "Untitled") elPandocInlines . getPostAttribute "title"
+    postTitle = maybe (text "Untitled") elPandocInlines . getPandocMetaInlines "title" . _post_doc
 
     -- Render a list of posts
     postList xs = divClass "ui relaxed divided list" $ forM_ xs $ \x ->
       divClass "item" $ do
         elAttr "a" ("class" =: "header" <> "href" =: _post_url x) $
           postTitle x
-        el "small" $ maybe blank elPandocInlines $ getPostAttribute "description" x
+        el "small" $ maybe blank elPandocInlines $ getPandocMetaInlines "description" $ _post_doc x
 
     semanticUiCss = "https://cdn.jsdelivr.net/npm/semantic-ui@2.4.2/dist/semantic.min.css"
 

nix/dep/README.md

@@ -0,0 +1 @@
+Use `ob thunk {pack|unpack}` to hack on dependencies in this directory.

nix/dep/cmark-gfm-hs/default.nix

@@ -0,0 +1,7 @@
+# DO NOT HAND-EDIT THIS FILE
+import ((import <nixpkgs> {}).fetchFromGitHub (
+  let json = builtins.fromJSON (builtins.readFile ./github.json);
+  in { inherit (json) owner repo rev sha256;
+       private = json.private or false;
+     }
+))

nix/dep/cmark-gfm-hs/github.json

@@ -0,0 +1,7 @@
+{
+  "owner": "kivikakk",
+  "repo": "cmark-gfm-hs",
+  "branch": "master",
+  "rev": "3f4263059c330ffa1d4737f7cf6243c3f41288db",
+  "sha256": "142xhjbl8f5wdrxfcxcdq54dqsnbzhmyk7mb05f5f09p7kghi4kz"
+}

nix/dep/haddock/default.nix

@@ -0,0 +1,7 @@
+# DO NOT HAND-EDIT THIS FILE
+import ((import <nixpkgs> {}).fetchFromGitHub (
+  let json = builtins.fromJSON (builtins.readFile ./github.json);
+  in { inherit (json) owner repo rev sha256;
+       private = json.private or false;
+     }
+))

nix/dep/haddock/github.json

@@ -0,0 +1,7 @@
+{
+  "owner": "haskell",
+  "repo": "haddock",
+  "branch": "ghc-8.4",
+  "rev": "9712d8899d452292913a260058a6dd3346e8d39b",
+  "sha256": "1zw5grv8zrrl9nyzfn74f5v7bc7vgh0l977lpb8yi41js049nw7x"
+}

nix/dep/hslua-module-system/default.nix

@@ -0,0 +1,7 @@
+# DO NOT HAND-EDIT THIS FILE
+import ((import <nixpkgs> {}).fetchFromGitHub (
+  let json = builtins.fromJSON (builtins.readFile ./github.json);
+  in { inherit (json) owner repo rev sha256;
+       private = json.private or false;
+     }
+))

nix/dep/hslua-module-system/github.json

@@ -0,0 +1,7 @@
+{
+  "owner": "hslua",
+  "repo": "hslua-module-system",
+  "branch": "master",
+  "rev": "408b8f0521b1a166976ebef4cd8c15056635e98d",
+  "sha256": "0v6nfjrzad1x1lwdqx72sqjian0h0z9cgxzrjwvbslxjssf013kd"
+}

nix/dep/hslua-module-text/default.nix

@@ -0,0 +1,7 @@
+# DO NOT HAND-EDIT THIS FILE
+import ((import <nixpkgs> {}).fetchFromGitHub (
+  let json = builtins.fromJSON (builtins.readFile ./github.json);
+  in { inherit (json) owner repo rev sha256;
+       private = json.private or false;
+     }
+))

nix/dep/hslua-module-text/github.json

@@ -0,0 +1,7 @@
+{
+  "owner": "hslua",
+  "repo": "hslua-module-text",
+  "branch": "master",
+  "rev": "2282afe0bc3b6f70938e4ea3101bf9d42c59e12f",
+  "sha256": "0jyyp30nyan798h2v1vbxwscs86l9nv3v961yhjkk9xshn2vncdr"
+}

nix/dep/hslua/default.nix

@@ -0,0 +1,7 @@
+# DO NOT HAND-EDIT THIS FILE
+import ((import <nixpkgs> {}).fetchFromGitHub (
+  let json = builtins.fromJSON (builtins.readFile ./github.json);
+  in { inherit (json) owner repo rev sha256;
+       private = json.private or false;
+     }
+))

nix/dep/hslua/github.json

@@ -0,0 +1,7 @@
+{
+  "owner": "hslua",
+  "repo": "hslua",
+  "branch": "master",
+  "rev": "57c8b2a77e8ad6c25a780c51c97c69daf726a662",
+  "sha256": "1q1pcv6rbpn0h7a9p29z9w0z02lr8z1mfvlbzki4dxssc9j0zil3"
+}

nix/dep/ipynb/default.nix

@@ -0,0 +1,7 @@
+# DO NOT HAND-EDIT THIS FILE
+import ((import <nixpkgs> {}).fetchFromGitHub (
+  let json = builtins.fromJSON (builtins.readFile ./github.json);
+  in { inherit (json) owner repo rev sha256;
+       private = json.private or false;
+     }
+))

nix/dep/ipynb/github.json

@@ -0,0 +1,7 @@
+{
+  "owner": "jgm",
+  "repo": "ipynb",
+  "branch": "master",
+  "rev": "dca7186d5adad23d64a69ee0aac6e56e062e0e4f",
+  "sha256": "1iwlg4sj0hn69hkm1karix663jj4vxrkdq33gnv8vz80qrirz0a2"
+}

nix/dep/pandoc-types/default.nix

@@ -0,0 +1,7 @@
+# DO NOT HAND-EDIT THIS FILE
+import ((import <nixpkgs> {}).fetchFromGitHub (
+  let json = builtins.fromJSON (builtins.readFile ./github.json);
+  in { inherit (json) owner repo rev sha256;
+       private = json.private or false;
+     }
+))

nix/dep/pandoc-types/github.json

@@ -0,0 +1,7 @@
+{
+  "owner": "jgm",
+  "repo": "pandoc-types",
+  "branch": "master",
+  "rev": "18d8743704de6c6e59ee1ecb6ff9cbe879ae2863",
+  "sha256": "1g7pffmm0ima45mq4vd2njfj7ncyfxxwmkmfxzxb4h5sdhrk09kq"
+}

nix/dep/pandoc/default.nix

@@ -0,0 +1,7 @@
+# DO NOT HAND-EDIT THIS FILE
+import ((import <nixpkgs> {}).fetchFromGitHub (
+  let json = builtins.fromJSON (builtins.readFile ./github.json);
+  in { inherit (json) owner repo rev sha256;
+       private = json.private or false;
+     }
+))

nix/dep/pandoc/github.json

@@ -0,0 +1,7 @@
+{
+  "owner": "jgm",
+  "repo": "pandoc",
+  "branch": "master",
+  "rev": "020e2a06d53777424bedea1a05c31241fc5e9f96",
+  "sha256": "01sax0lpng0bcj52if8ig38g0wn86c589ws4lml8ppr8f8gg0rqy"
+}

nix/dep/skylighting/default.nix

@@ -0,0 +1,7 @@
+# DO NOT HAND-EDIT THIS FILE
+import ((import <nixpkgs> {}).fetchFromGitHub (
+  let json = builtins.fromJSON (builtins.readFile ./github.json);
+  in { inherit (json) owner repo rev sha256;
+       private = json.private or false;
+     }
+))

nix/dep/skylighting/github.json

@@ -0,0 +1,7 @@
+{
+  "owner": "jgm",
+  "repo": "skylighting",
+  "branch": "master",
+  "rev": "6da46a03981db53797899a7340ea9ef9398b1482",
+  "sha256": "04mw4ys68pjsa98fx084mp3wk00d4gd56cflna7ph1dkggyr671h"
+}

nix/dep/tasty-lua/default.nix

@@ -0,0 +1,7 @@
+# DO NOT HAND-EDIT THIS FILE
+import ((import <nixpkgs> {}).fetchFromGitHub (
+  let json = builtins.fromJSON (builtins.readFile ./github.json);
+  in { inherit (json) owner repo rev sha256;
+       private = json.private or false;
+     }
+))

nix/dep/tasty-lua/github.json

@@ -0,0 +1,7 @@
+{
+  "owner": "hslua",
+  "repo": "tasty-lua",
+  "branch": "master",
+  "rev": "42a679ada86f91b305a1fdcc8006722272f49e4e",
+  "sha256": "1f6hb0h0nb7z94v7ii7f1g9w1bip3hwdp13m39zk641zdfah8prr"
+}

nix/dep/texmath/default.nix

@@ -0,0 +1,7 @@
+# DO NOT HAND-EDIT THIS FILE
+import ((import <nixpkgs> {}).fetchFromGitHub (
+  let json = builtins.fromJSON (builtins.readFile ./github.json);
+  in { inherit (json) owner repo rev sha256;
+       private = json.private or false;
+     }
+))

nix/dep/texmath/github.json

@@ -0,0 +1,7 @@
+{
+  "owner": "jgm",
+  "repo": "texmath",
+  "branch": "master",
+  "rev": "55ef8cc70db4b0199f2588aeb49e9a919f39bb79",
+  "sha256": "1r9bahcnpqxyfs9w2px9lnpw2imanijj13y0byphyzdsnrwqf26j"
+}

nix/pandoc.nix

@@ -0,0 +1,40 @@
+{ pkgs, hackGet }: {
+   packages = {
+    pandoc = hackGet ./dep/pandoc;
+    pandoc-types = hackGet ./dep/pandoc-types;
+    hslua-module-system = hackGet ./dep/hslua-module-system;
+    hslua-module-text = hackGet ./dep/hslua-module-text;
+    ipynb = hackGet ./dep/ipynb;
+    tasty-lua = hackGet ./dep/tasty-lua;
+    hslua = hackGet ./dep/hslua;
+    skylighting = (hackGet ./dep/skylighting) + /skylighting;
+    skylighting-core = (hackGet ./dep/skylighting) + /skylighting-core;
+    cmark-gfm = hackGet ./dep/cmark-gfm-hs;
+    texmath = hackGet ./dep/texmath;
+    haddock-library = (hackGet ./dep/haddock) + /haddock-library;
+    haddock-api = (hackGet ./dep/haddock) + /haddock-api;
+  };
+
+  overrides = self: super: with pkgs.haskell.lib;
+  let
+    skylighting-core = overrideCabal super.skylighting-core (drv: {
+      isExecutable = true;
+      isLibrary = true;
+      configureFlags = [ "-fexecutable" ];  # We need the CLI tool later.
+    });
+  in
+  {
+    hslua-module-system = dontCheck super.hslua-module-system;
+    hslua-module-text = dontCheck super.hslua-module-text;
+    skylighting-core = skylighting-core;
+    skylighting = overrideCabal super.skylighting (drv: {
+      preConfigure = ''
+        ${skylighting-core}/bin/skylighting-extract ${skylighting-core}/xml/*.xml
+        rm -f changelog.md; touch changelog.md  # Workaround failing symlink access
+      '';
+      isExecutable = true;
+      isLibrary = true;
+    });
+    pandoc = doJailbreak super.pandoc;  # Remove the version lock on `haddock-library`
+  };
+}

rib.cabal

@@ -21,6 +21,7 @@ library
   exposed-modules:
       Rib
     , Rib.App
+    , Rib.Pandoc
     , Rib.Settings
     , Rib.Types
     , Reflex.Dom.Pandoc.Document
@@ -47,8 +48,7 @@ library
     , lens
     , lens-aeson
     , mtl
-    , mustache
-    , pandoc
+    , pandoc >= 2.6
     , pandoc-types
     , reflex-dom-core
     , safe
@@ -68,9 +68,9 @@ executable rib-example
   hs-source-dirs: example
   ghc-options: -threaded -rtsopts -with-rtsopts=-N -Wall -Wincomplete-uni-patterns -Wincomplete-record-updates
   build-depends:
-      base
+      aeson
+    , base
     , clay
-    , data-default
     , directory
     , reflex-dom-core
     , rib

src/Reflex/Dom/Pandoc/Document.hs

@@ -8,7 +8,9 @@ module Reflex.Dom.Pandoc.Document
   , elPandocHeading1
   ) where
 
-import Control.Monad (forM_)
+import Control.Monad
+import Data.Bool
+import Data.Maybe
 import qualified Data.Text as T
 
 import Reflex.Dom.Core hiding (Link, Space)
@@ -28,7 +30,7 @@ elPandocDoc (Pandoc _meta blocks) = mapM_ renderBlock blocks
 -- | Render the first level of heading
 elPandocHeading1 :: DomBuilder t m => Pandoc -> m ()
 elPandocHeading1 (Pandoc _meta blocks) = forM_ blocks $ \case
-  Header 1 _ xs -> mapM_ renderInline xs
+  Header 1 _ xs -> elPandocInlines xs
   _ -> blank
 
 -- | Render list of Pandoc inlines
@@ -39,7 +41,13 @@ elPandocInlines = mapM_ renderInline
 
 renderBlock :: DomBuilder t m => Block -> m ()
 renderBlock = \case
-  Plain inlines -> mapM_ renderInline inlines
+  -- Pandoc parses github tasklist as this structure.
+  Plain (Str "☐":Space:is) -> checkboxEl False >> mapM_ renderInline is
+  Plain (Str "☒":Space:is) -> checkboxEl True >> mapM_ renderInline is
+  Para (Str "☐":Space:is) -> checkboxEl False >> mapM_ renderInline is
+  Para (Str "☒":Space:is) -> checkboxEl True >> mapM_ renderInline is
+
+  Plain xs -> mapM_ renderInline xs
   Para xs -> el "p" $ mapM_ renderInline xs
   LineBlock xss -> forM_ xss $ \xs -> do
     mapM_ renderInline xs
@@ -62,6 +70,12 @@ renderBlock = \case
   Div attr xs -> elPandocAttr "div" attr $
     mapM_ renderBlock xs
   Null -> blank
+  where
+    checkboxEl checked = void $ elAttr "input" (mconcat $ catMaybes $
+      [ Just $ "type" =: "checkbox"
+      , Just $ "disabled" =: "True"
+      , bool Nothing (Just $ "checked" =: "True") checked
+      ]) blank
 
 renderInline :: DomBuilder t m => Inline -> m ()
 renderInline = \case

src/Rib/Pandoc.hs

@@ -0,0 +1,41 @@
+{-# LANGUAGE LambdaCase #-}
+
+module Rib.Pandoc where
+
+import Control.Monad
+import Data.Aeson (FromJSON, decode)
+import Data.Maybe
+import Data.Text (Text)
+import qualified Data.Text as T
+
+import Text.Pandoc
+import Text.Pandoc.UTF8 (fromStringLazy)
+
+-- Get the YAML metadata for the given key in a post.
+--
+-- We expect this to return `[Inline]` unless we upgrade pandoc. See
+-- https://github.com/jgm/pandoc/issues/2139#issuecomment-310522113
+getPandocMetaInlines :: String -> Pandoc -> Maybe [Inline]
+getPandocMetaInlines k (Pandoc meta _) =
+  case lookupMeta k meta of
+    Just (MetaInlines inlines) -> Just inlines
+    _ -> Nothing
+
+-- Get the YAML metadata for a key that is a list of text values
+getPandocMetaList :: String -> Pandoc -> Maybe [Text]
+getPandocMetaList k (Pandoc meta _) =
+  case lookupMeta k meta of
+    Just (MetaList vals) -> Just $ catMaybes $ flip fmap vals $ \case
+      MetaInlines [Str val] -> Just $ T.pack val
+      _ -> Nothing
+    _ -> Nothing
+
+getPandocMetaRaw :: String -> Pandoc -> Maybe String
+getPandocMetaRaw k p =
+  getPandocMetaInlines k p >>= \case
+    [Str v] -> Just v
+    _ -> Nothing
+
+-- Like getPandocMeta but expects the value to be JSON encoding of a type.
+getPandocMetaJson :: FromJSON a => String -> Pandoc -> Maybe a
+getPandocMetaJson k = decode . fromStringLazy <=< getPandocMetaRaw k

src/Rib/Types.hs

@@ -6,20 +6,15 @@
 module Rib.Types
   ( Page(..)
   , Post(..)
-  , PostCategory(..)
   , PostFilePath(..)
-  , getPostAttribute
-  , getPostAttributeJson
   ) where
 
-import Data.Aeson (FromJSON, ToJSON, decode)
-import qualified Data.Map as Map
+import Data.Aeson (FromJSON, ToJSON)
 import Data.Text (Text)
 import GHC.Generics (Generic)
 
 import Development.Shake.Classes (Binary, Hashable, NFData)
-import Text.Pandoc (Inline (Str), Meta (unMeta), MetaValue (MetaInlines), Pandoc (Pandoc))
-import Text.Pandoc.UTF8 (fromStringLazy)
+import Text.Pandoc (Pandoc)
 
 -- | Represents a HTML page that will be generated
 data Page
@@ -34,36 +29,7 @@ data Post = Post
   }
   deriving (Generic, Eq, Ord, Show, FromJSON, ToJSON)
 
-data PostCategory
-  = Programming
-  | Other
-  deriving (Generic, Show, Eq, Ord, 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)
-
--- Get the YAML metadata for the given key in a post
---
--- This has to always return `[Inline]` unless we upgrade pandoc. See
--- https://github.com/jgm/pandoc/issues/2139#issuecomment-310522113
-getPostAttribute :: String -> Post -> Maybe [Inline]
-getPostAttribute k (Post (Pandoc meta _) _) =
-  case Map.lookup k (unMeta meta) of
-    -- When a Just value this will always be `MetaInlines`; see note in function
-    -- 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