Show table of contents for notes

src/Main.hs

@@ -170,7 +170,7 @@ undoEdit (Edit'SetCategoryTitle catId old new) = do
     then return (Left "title has been changed further")
     else Right () <$ dbUpdate (SetCategoryTitle catId old)
 undoEdit (Edit'SetCategoryNotes catId old new) = do
-  now <- markdownBlockText . view notes <$> dbQuery (GetCategory catId)
+  now <- view (notes.mdText) <$> dbQuery (GetCategory catId)
   if now /= new
     then return (Left "notes have been changed further")
     else Right () <$ dbUpdate (SetCategoryNotes catId old)
@@ -195,22 +195,22 @@ undoEdit (Edit'SetItemKind itemId old new) = do
     then return (Left "kind has been changed further")
     else Right () <$ dbUpdate (SetItemKind itemId old)
 undoEdit (Edit'SetItemDescription itemId old new) = do
-  now <- markdownBlockText . view description <$> dbQuery (GetItem itemId)
+  now <- view (description.mdText) <$> dbQuery (GetItem itemId)
   if now /= new
     then return (Left "description has been changed further")
     else Right () <$ dbUpdate (SetItemDescription itemId old)
 undoEdit (Edit'SetItemNotes itemId old new) = do
-  now <- markdownBlockText . view notes <$> dbQuery (GetItem itemId)
+  now <- view (notes.mdText) <$> dbQuery (GetItem itemId)
   if now /= new
     then return (Left "notes have been changed further")
     else Right () <$ dbUpdate (SetItemNotes itemId old)
 undoEdit (Edit'SetItemEcosystem itemId old new) = do
-  now <- markdownBlockText . view ecosystem <$> dbQuery (GetItem itemId)
+  now <- view (ecosystem.mdText) <$> dbQuery (GetItem itemId)
   if now /= new
     then return (Left "ecosystem has been changed further")
     else Right () <$ dbUpdate (SetItemEcosystem itemId old)
 undoEdit (Edit'SetTraitContent itemId traitId old new) = do
-  now <- markdownInlineText . view content <$> dbQuery (GetTrait itemId traitId)
+  now <- view (content.mdText) <$> dbQuery (GetTrait itemId traitId)
   if now /= new
     then return (Left "trait has been changed further")
     else Right () <$ dbUpdate (SetTraitContent itemId traitId old)

src/Markdown.hs

@@ -1,21 +1,38 @@
 {-# LANGUAGE
 OverloadedStrings,
+TemplateHaskell,
+MultiParamTypeClasses,
+FunctionalDependencies,
+FlexibleInstances,
 NoImplicitPrelude
   #-}
 
 
 module Markdown
 (
-  renderMarkdownInline,
-  renderMarkdownBlock,
+  -- * Types
   MarkdownInline(..),
   MarkdownBlock(..),
+
+  -- * Lenses
+  mdHtml,
+  mdText,
+  mdMarkdown,
+
+  -- * Rendering
+  renderMarkdownInline,
+  renderMarkdownBlock,
+
+  -- * Miscellaneous
+  extractSections,
 )
 where
 
 
 -- General
 import BasePrelude hiding (Space)
+-- Lenses
+import Lens.Micro.Platform
 -- Monad transformers and monads
 import Control.Monad.Writer
 import Data.Functor.Identity
@@ -30,6 +47,8 @@ import Lucid.Base
 import Blaze.ByteString.Builder (Builder)
 -- Sequence (used by Cheapskate)
 import Data.Sequence
+-- Tree (used by extractSections)
+import Data.Tree
 -- Markdown
 import Cheapskate
 import Cheapskate.Lucid
@@ -40,6 +59,19 @@ import ShortcutLinks.All (hackage)
 import Data.SafeCopy
 
 
+data MarkdownInline = MarkdownInline {
+  markdownInlineMdText     :: Text,
+  markdownInlineMdHtml     :: !Builder,
+  markdownInlineMdMarkdown :: !Inlines }
+
+data MarkdownBlock = MarkdownBlock {
+  markdownBlockMdText     :: Text,
+  markdownBlockMdHtml     :: !Builder,
+  markdownBlockMdMarkdown :: !Blocks }
+
+makeFields ''MarkdownInline
+makeFields ''MarkdownBlock
+
 -- | Convert a Markdown structure to a string with formatting removed.
 stringify :: Inline -> Text
 stringify = execWriter . walkM go
@@ -101,8 +133,16 @@ parseLink = either (Left . show) Right . parse p ""
            <*> optional (T.pack <$> opt)
            <*> optional (T.pack <$> text)
 
+extractSections :: Blocks -> Forest Inlines
+extractSections blocks = go sections
+  where
+    sections = [(level, contents) | Header level contents <- toList blocks]
+    go [] = []
+    go ((level,contents):xs) = let (sub, rest) = span ((>level).fst) xs
+                               in  Node contents (go sub) : go rest
+
 renderMarkdownInline :: Text -> MarkdownInline
-renderMarkdownInline s = MarkdownInline s (htmlToBuilder md)
+renderMarkdownInline s = MarkdownInline s (htmlToBuilder md) inlines
   where
     Doc opts blocks = markdown def{allowRawHtml=False} s
     inlines = extractInlines =<< blocks
@@ -117,35 +157,27 @@ renderMarkdownInline s = MarkdownInline s (htmlToBuilder md)
     extractInlines HRule = mempty
 
 renderMarkdownBlock :: Text -> MarkdownBlock
-renderMarkdownBlock s = MarkdownBlock s (htmlToBuilder md)
+renderMarkdownBlock s = MarkdownBlock s (htmlToBuilder md) blocks
   where
-    md = renderDoc . highlightDoc . walk shortcutLinks . markdown def $ s
-
-data MarkdownInline = MarkdownInline {
-  markdownInlineText :: Text,
-  markdownInlineHtml :: !Builder }
-
-data MarkdownBlock = MarkdownBlock {
-  markdownBlockText :: Text,
-  markdownBlockHtml :: !Builder }
+    Doc opts blocks = highlightDoc . walk shortcutLinks . markdown def $ s
+    md = renderDoc (Doc opts blocks)
 
 instance Eq MarkdownInline where
-  (==) = (==) `on` markdownInlineText
+  (==) = (==) `on` view mdText
 instance Eq MarkdownBlock where
-  (==) = (==) `on` markdownBlockText
+  (==) = (==) `on` view mdText
 
 instance Show MarkdownInline where
-  show = show . markdownInlineText
-
+  show = show . view mdText
 instance Show MarkdownBlock where
-  show = show . markdownBlockText
+  show = show . view mdText
 
 instance ToHtml MarkdownInline where
-  toHtml    = builderToHtml . markdownInlineHtml
-  toHtmlRaw = builderToHtml . markdownInlineHtml
+  toHtml    = builderToHtml . view mdHtml
+  toHtmlRaw = builderToHtml . view mdHtml
 instance ToHtml MarkdownBlock where
-  toHtml    = builderToHtml . markdownBlockHtml
-  toHtmlRaw = builderToHtml . markdownBlockHtml
+  toHtml    = builderToHtml . view mdHtml
+  toHtmlRaw = builderToHtml . view mdHtml
 
 builderToHtml :: Monad m => Builder -> HtmlT m ()
 builderToHtml b = HtmlT (return (\_ -> b, ()))
@@ -161,10 +193,10 @@ instance IsString MarkdownBlock where
 instance SafeCopy MarkdownInline where
   version = 0
   kind = base
-  putCopy = contain . safePut . markdownInlineText
+  putCopy = contain . safePut . view mdText
   getCopy = contain $ renderMarkdownInline <$> safeGet
 instance SafeCopy MarkdownBlock where
   version = 0
   kind = base
-  putCopy = contain . safePut . markdownBlockText
+  putCopy = contain . safePut . view mdText
   getCopy = contain $ renderMarkdownBlock <$> safeGet

src/Types.hs

@@ -752,7 +752,7 @@ setCategoryTitle catId title' = do
 setCategoryNotes :: Uid Category -> Text -> Acid.Update GlobalState (Edit, Category)
 setCategoryNotes catId notes' = do
   oldNotes <- categoryById catId . notes <<.= renderMarkdownBlock notes'
-  let edit = Edit'SetCategoryNotes catId (markdownBlockText oldNotes) notes'
+  let edit = Edit'SetCategoryNotes catId (oldNotes ^. mdText) notes'
   (edit,) <$> use (categoryById catId)
 
 setItemName :: Uid Item -> Text -> Acid.Update GlobalState (Edit, Item)
@@ -811,13 +811,13 @@ setItemDescription itemId description' = do
   oldDescr <- itemById itemId . description <<.=
                 renderMarkdownBlock description'
   let edit = Edit'SetItemDescription itemId
-               (markdownBlockText oldDescr) description'
+               (oldDescr ^. mdText) description'
   (edit,) <$> use (itemById itemId)
 
 setItemNotes :: Uid Item -> Text -> Acid.Update GlobalState (Edit, Item)
 setItemNotes itemId notes' = do
   oldNotes <- itemById itemId . notes <<.= renderMarkdownBlock notes'
-  let edit = Edit'SetItemNotes itemId (markdownBlockText oldNotes) notes'
+  let edit = Edit'SetItemNotes itemId (oldNotes ^. mdText) notes'
   (edit,) <$> use (itemById itemId)
 
 setItemEcosystem :: Uid Item -> Text -> Acid.Update GlobalState (Edit, Item)
@@ -825,7 +825,7 @@ setItemEcosystem itemId ecosystem' = do
   oldEcosystem <- itemById itemId . ecosystem <<.=
                     renderMarkdownBlock ecosystem'
   let edit = Edit'SetItemEcosystem itemId
-               (markdownBlockText oldEcosystem) ecosystem'
+               (oldEcosystem ^. mdText) ecosystem'
   (edit,) <$> use (itemById itemId)
 
 setTraitContent :: Uid Item -> Uid Trait -> Text -> Acid.Update GlobalState (Edit, Trait)
@@ -833,7 +833,7 @@ setTraitContent itemId traitId content' = do
   oldContent <- itemById itemId . traitById traitId . content <<.=
                   renderMarkdownInline content'
   let edit = Edit'SetTraitContent itemId traitId
-               (markdownInlineText oldContent) content'
+               (oldContent ^. mdText) content'
   (edit,) <$> use (itemById itemId . traitById traitId)
 
 -- delete

src/View.hs

@@ -52,6 +52,8 @@ where
 
 -- General
 import BasePrelude hiding (Category)
+-- Default
+import Data.Default
 -- Lenses
 import Lens.Micro.Platform hiding ((&))
 -- Monads and monad transformers
@@ -59,6 +61,7 @@ import Control.Monad.IO.Class
 import Control.Monad.Reader
 -- Containers
 import qualified Data.Map as M
+import Data.Tree
 -- Text
 import qualified Data.Text as T
 import qualified Data.Text.IO as T
@@ -68,6 +71,9 @@ import NeatInterpolation
 import Lucid hiding (for_)
 -- Time
 import Data.Time.Format.Human
+-- Markdown
+import Cheapskate.Lucid
+import Cheapskate.Types
 
 -- Local
 import Config
@@ -903,16 +909,24 @@ renderItemNotes item = do
   let thisId = "item-notes-" <> uidToText (item^.uid)
       this   = JS.selectId thisId
   div_ [id_ thisId, class_ "item-notes"] $ do
-    -- TODO: this duplicates code from renderCategoryNotes, try to reduce
-    -- duplication
 
     section "collapsed" [shown] $ do
-      textButton "show notes/examples" $
+      textButton "expand notes" $
         JS.switchSection (this, "expanded" :: Text)
+      br_ []
+      let toc = extractSections (item^.notes.mdMarkdown)
+      unless (null toc) $ div_ [class_ "notes-toc"] $ do
+        let renderTOC :: Monad m => Forest Inlines -> HtmlT m ()
+            renderTOC [] = return ()
+            renderTOC xs = ul_ $ do
+              for_ xs $ \(Node x children) -> li_ $ do
+                renderInlines def x
+                renderTOC children
+        renderTOC toc
 
     section "expanded" [noScriptShown] $ do
       let buttons = do
-            textButton "hide notes" $
+            textButton "collapse notes" $
               JS.switchSection (this, "collapsed" :: Text)
             emptySpan "1em"
             textButton "edit notes" $
@@ -1013,7 +1027,7 @@ markdownEditor
   -> (JS -> JS)     -- ^ “Submit” handler, receiving the contents of the editor
   -> JS             -- ^ “Cancel” handler
   -> HtmlT m ()
-markdownEditor attr (markdownBlockText -> s) submit cancel = do
+markdownEditor attr (view mdText -> s) submit cancel = do
   textareaUid <- randomLongUid
   -- Autocomplete has to be turned off thanks to
   -- <http://stackoverflow.com/q/8311455>.
@@ -1045,7 +1059,7 @@ smallMarkdownEditor
   -> (JS -> JS)     -- ^ “Submit” handler, receiving the contents of the editor
   -> Maybe JS       -- ^ “Cancel” handler (if “Cancel” is needed)
   -> HtmlT m ()
-smallMarkdownEditor attr (markdownInlineText -> s) submit mbCancel = do
+smallMarkdownEditor attr (view mdText -> s) submit mbCancel = do
   textareaId <- randomLongUid
   let val = JS $ format "document.getElementById(\"{}\").value" [textareaId]
   textarea_ ([class_ "fullwidth", uid_ textareaId, autocomplete_ "off",

static/css.css

@@ -119,3 +119,7 @@ textarea.big {
 
 textarea.fullwidth {
   resize: vertical; }
+
+.notes-toc {
+  background-color: rgba(10, 10, 10, 0.1);
+  padding: 1px 0; }