diff --git a/src/Main.hs b/src/Main.hs index 2dc7eaa..62678fe 100644 --- a/src/Main.hs +++ b/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) diff --git a/src/Markdown.hs b/src/Markdown.hs index d0cb070..2cc4ded 100644 --- a/src/Markdown.hs +++ b/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 diff --git a/src/Types.hs b/src/Types.hs index 941350f..774fc12 100644 --- a/src/Types.hs +++ b/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 diff --git a/src/View.hs b/src/View.hs index 77c1042..47ea572 100644 --- a/src/View.hs +++ b/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 -- . @@ -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", diff --git a/static/css.css b/static/css.css index 832ba0f..935cfc5 100644 --- a/static/css.css +++ b/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; }