aelve/guide
1
1
Fork 0
mirror of https://github.com/aelve/guide.git synced 2024-11-27 10:10:50 +03:00
Code Issues Projects Releases Wiki Activity

Linkable sections in item notes

Browse Source 
Fixes #19
This commit is contained in:
Artyom 2016-04-22 01:06:02 +03:00
parent d8ddc2305a
commit f8cee78ac0
5 changed files with 176 additions and 93 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

7
src/JS.hs
View File

@ -314,7 +314,12 @@ expandHash =
[text|
hash = $(location).attr('hash');
if (hash.slice(0,12) == "#item-notes-") {
itemId = hash.slice(12);
if (hash.indexOf('-', 12) != (-1))
// For links to sections of items' notes (from the TOC)
itemId = hash.slice(12, hash.indexOf('-', 12))
else
// For links to items' notes
itemId = hash.slice(12);
expandItemNotes(itemId);
} else
if (hash.slice(0,6) == "#item-") {

6
src/Main.hs
View File

@ -258,7 +258,8 @@ renderMethods = Spock.subcomponent "render" $ do
-- Item notes
Spock.get (itemVar <//> "notes") $ \itemId -> do
item <- dbQuery (GetItem itemId)
lucidIO $ renderItemNotes item
category <- dbQuery (GetCategoryByItem itemId)
lucidIO $ renderItemNotes category item
setMethods :: SpockM () () ServerState ()
setMethods = Spock.subcomponent "set" $ do
@ -334,7 +335,8 @@ setMethods = Spock.subcomponent "set" $ do
content' <- param' "content"
(edit, item) <- dbUpdate (SetItemNotes itemId content')
addEdit edit
lucidIO $ renderItemNotes item
category <- dbQuery (GetCategoryByItem itemId)
lucidIO $ renderItemNotes category item
-- Trait
Spock.post (itemVar <//> traitVar) $ \itemId traitId -> do
content' <- param' "content"

111
src/Markdown.hs
View File

@ -4,6 +4,7 @@ TemplateHaskell,
MultiParamTypeClasses,
FunctionalDependencies,
FlexibleInstances,
FlexibleContexts,
NoImplicitPrelude
#-}
@ -13,18 +14,22 @@ module Markdown
-- * Types
MarkdownInline(..),
MarkdownBlock(..),
MarkdownBlockWithTOC(..),
-- * Lenses
mdHtml,
mdText,
mdMarkdown,
mdIdPrefix,
mdTOC,
-- * Rendering
renderMarkdownInline,
renderMarkdownBlock,
renderMarkdownBlockWithTOC,
-- * Miscellaneous
extractSections,
-- * Misc
markdownNull,
)
where
@ -32,23 +37,25 @@ where
-- General
import BasePrelude hiding (Space)
-- Lenses
import Lens.Micro.Platform
import Lens.Micro.Platform hiding ((&))
-- Monad transformers and monads
import Control.Monad.Writer
import Control.Monad.State
import Data.Functor.Identity
-- Text
import qualified Data.Text as T
import Data.Text (Text)
-- Parsing
import Text.Megaparsec
import Text.Megaparsec hiding (State)
-- HTML
import Lucid
import Lucid.Base
import Blaze.ByteString.Builder (Builder)
-- Sequence (used by Cheapskate)
import Data.Sequence
-- Tree (used by extractSections)
-- Containers
import Data.Sequence ((<|), singleton)
import Data.Tree
import qualified Data.Set as S
import Data.Set (Set)
-- Markdown
import Cheapskate
import Cheapskate.Lucid
@ -58,6 +65,9 @@ import ShortcutLinks.All (hackage)
-- acid-state
import Data.SafeCopy
-- Local
import Utils
data MarkdownInline = MarkdownInline {
markdownInlineMdText :: Text,
@ -69,11 +79,44 @@ data MarkdownBlock = MarkdownBlock {
markdownBlockMdHtml :: !Builder,
markdownBlockMdMarkdown :: !Blocks }
data MarkdownBlockWithTOC = MarkdownBlockWithTOC {
markdownBlockWithTOCMdText :: Text,
markdownBlockWithTOCMdHtml :: !Builder,
markdownBlockWithTOCMdMarkdown :: !Blocks,
markdownBlockWithTOCMdIdPrefix :: Text,
markdownBlockWithTOCMdTOC :: Forest (Inlines, Text) }
makeFields ''MarkdownInline
makeFields ''MarkdownBlock
makeFields ''MarkdownBlockWithTOC
genTOC
:: (Text -> Text) -- ^ Function for generating a slug
-> Blocks -- ^ Markdown
-> (Forest (Inlines, Text), Blocks) -- ^ TOC and modified blocks
genTOC slugify blocks =
let (blocks', (_, headers)) = runState (mapM process blocks) (mempty, [])
in (makeTOC (reverse headers), blocks')
where
makeTOC :: [(Int, Inlines, Text)] -> Forest (Inlines, Text)
makeTOC [] = []
makeTOC ((level,contents,slug):xs) =
let (sub, rest) = span ((>level) . view _1) xs
in Node (contents, slug) (makeTOC sub) : makeTOC rest
--
process :: Block -> State (Set Text, [(Int, Inlines, Text)]) Block
process (Header n is) = do
previousIds <- use _1
let slug = until (`S.notMember` previousIds) (<> "_")
(slugify (stringify is))
_1 %= S.insert slug
_2 %= ((n, is, slug):)
let anchor = RawHtml ("<span id='" <> slug <> "'></span>")
return (Header n (anchor <| is))
process b = return b
-- | Convert a Markdown structure to a string with formatting removed.
stringify :: Inline -> Text
stringify :: Inlines -> Text
stringify = execWriter . walkM go
where
go :: Inline -> Writer Text Inline
@ -98,7 +141,7 @@ shortcutLinks i@(Link is url title) | '@' <- T.head url =
case parseLink (T.replace "%20" " " url) of
Left _err -> i
Right (shortcut, opt, text) -> do
let text' = fromMaybe (stringify i) text
let text' = fromMaybe (stringify (singleton i)) text
let shortcuts = (["hk"], hackage) : allShortcuts
case useShortcutFrom shortcuts shortcut opt text' of
Success link ->
@ -133,14 +176,6 @@ 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) inlines
where
@ -157,20 +192,33 @@ renderMarkdownInline s = MarkdownInline s (htmlToBuilder md) inlines
extractInlines HRule = mempty
renderMarkdownBlock :: Text -> MarkdownBlock
renderMarkdownBlock s = MarkdownBlock s (htmlToBuilder md) blocks
renderMarkdownBlock s = MarkdownBlock {
markdownBlockMdText = s,
markdownBlockMdHtml = htmlToBuilder md,
markdownBlockMdMarkdown = blocks }
where
Doc opts blocks = highlightDoc . walk shortcutLinks . markdown def $ s
md = renderDoc (Doc opts blocks)
instance Eq MarkdownInline where
(==) = (==) `on` view mdText
instance Eq MarkdownBlock where
(==) = (==) `on` view mdText
renderMarkdownBlockWithTOC :: Text -> Text -> MarkdownBlockWithTOC
renderMarkdownBlockWithTOC idPrefix s = MarkdownBlockWithTOC {
markdownBlockWithTOCMdText = s,
markdownBlockWithTOCMdHtml = htmlToBuilder md,
markdownBlockWithTOCMdMarkdown = blocks',
markdownBlockWithTOCMdIdPrefix = idPrefix,
markdownBlockWithTOCMdTOC = toc }
where
Doc opts blocks = highlightDoc . walk shortcutLinks . markdown def $ s
(toc, blocks') = let slugify x = idPrefix <> makeSlug x
in genTOC slugify blocks
md = renderDoc (Doc opts blocks')
instance Show MarkdownInline where
show = show . view mdText
instance Show MarkdownBlock where
show = show . view mdText
instance Show MarkdownBlockWithTOC where
show = show . view mdText
instance ToHtml MarkdownInline where
toHtml = builderToHtml . view mdHtml
@ -178,6 +226,9 @@ instance ToHtml MarkdownInline where
instance ToHtml MarkdownBlock where
toHtml = builderToHtml . view mdHtml
toHtmlRaw = builderToHtml . view mdHtml
instance ToHtml MarkdownBlockWithTOC where
toHtml = builderToHtml . view mdHtml
toHtmlRaw = builderToHtml . view mdHtml
builderToHtml :: Monad m => Builder -> HtmlT m ()
builderToHtml b = HtmlT (return (\_ -> b, ()))
@ -185,11 +236,6 @@ builderToHtml b = HtmlT (return (\_ -> b, ()))
htmlToBuilder :: Html () -> Builder
htmlToBuilder = runIdentity . execHtmlT
instance IsString MarkdownInline where
fromString = renderMarkdownInline . fromString
instance IsString MarkdownBlock where
fromString = renderMarkdownBlock . fromString
instance SafeCopy MarkdownInline where
version = 0
kind = base
@ -200,3 +246,14 @@ instance SafeCopy MarkdownBlock where
kind = base
putCopy = contain . safePut . view mdText
getCopy = contain $ renderMarkdownBlock <$> safeGet
instance SafeCopy MarkdownBlockWithTOC where
version = 0
kind = base
putCopy md = contain $ do
safePut (md ^. mdIdPrefix)
safePut (md ^. mdText)
getCopy = contain $
renderMarkdownBlockWithTOC <$> safeGet <*> safeGet
markdownNull :: HasMdText a Text => a -> Bool
markdownNull = T.null . view mdText

86
src/Types.hs
View File

@ -139,7 +139,7 @@ import Markdown
data Trait = Trait {
_traitUid :: Uid Trait,
_traitContent :: MarkdownInline }
deriving (Eq, Show)
deriving (Show)
-- See Note [acid-state]
deriveSafeCopySimple 2 'extension ''Trait
@ -205,51 +205,52 @@ data Item = Item {
_itemCons :: [Trait],
_itemConsDeleted :: [Trait],
_itemEcosystem :: MarkdownBlock,
_itemNotes :: MarkdownBlock,
_itemNotes :: MarkdownBlockWithTOC,
_itemLink :: Maybe Url,
_itemKind :: ItemKind }
deriving (Eq, Show)
deriving (Show)
deriveSafeCopySimple 8 'extension ''Item
deriveSafeCopySimple 9 'extension ''Item
makeFields ''Item
-- Old version, needed for safe migration. It can most likely be already
-- deleted (if a checkpoint has been created), but it's been left here as a
-- template for future migrations.
data Item_v7 = Item_v7 {
_itemUid_v7 :: Uid Item,
_itemName_v7 :: Text,
_itemCreated_v7 :: UTCTime,
_itemGroup__v7 :: Maybe Text,
_itemDescription_v7 :: MarkdownBlock,
_itemPros_v7 :: [Trait],
_itemProsDeleted_v7 :: [Trait],
_itemCons_v7 :: [Trait],
_itemConsDeleted_v7 :: [Trait],
_itemEcosystem_v7 :: MarkdownBlock,
_itemNotes_v7 :: MarkdownBlock,
_itemLink_v7 :: Maybe Url,
_itemKind_v7 :: ItemKind }
data Item_v8 = Item_v8 {
_itemUid_v8 :: Uid Item,
_itemName_v8 :: Text,
_itemCreated_v8 :: UTCTime,
_itemGroup__v8 :: Maybe Text,
_itemDescription_v8 :: MarkdownBlock,
_itemPros_v8 :: [Trait],
_itemProsDeleted_v8 :: [Trait],
_itemCons_v8 :: [Trait],
_itemConsDeleted_v8 :: [Trait],
_itemEcosystem_v8 :: MarkdownBlock,
_itemNotes_v8 :: MarkdownBlock,
_itemLink_v8 :: Maybe Url,
_itemKind_v8 :: ItemKind }
-- TODO: at the next migration change this to deriveSafeCopySimple!
deriveSafeCopy 7 'base ''Item_v7
deriveSafeCopySimple 8 'base ''Item_v8
instance Migrate Item where
type MigrateFrom Item = Item_v7
migrate Item_v7{..} = Item {
_itemUid = _itemUid_v7,
_itemName = _itemName_v7,
_itemCreated = _itemCreated_v7,
_itemGroup_ = _itemGroup__v7,
_itemDescription = _itemDescription_v7,
_itemPros = _itemPros_v7,
_itemProsDeleted = _itemProsDeleted_v7,
_itemCons = _itemCons_v7,
_itemConsDeleted = _itemConsDeleted_v7,
_itemEcosystem = _itemEcosystem_v7,
_itemNotes = _itemNotes_v7,
_itemLink = _itemLink_v7,
_itemKind = _itemKind_v7 }
type MigrateFrom Item = Item_v8
migrate Item_v8{..} = Item {
_itemUid = _itemUid_v8,
_itemName = _itemName_v8,
_itemCreated = _itemCreated_v8,
_itemGroup_ = _itemGroup__v8,
_itemDescription = _itemDescription_v8,
_itemPros = _itemPros_v8,
_itemProsDeleted = _itemProsDeleted_v8,
_itemCons = _itemCons_v8,
_itemConsDeleted = _itemConsDeleted_v8,
_itemEcosystem = _itemEcosystem_v8,
_itemNotes = let pref = "item-notes-" <> uidToText _itemUid_v8 <> "-"
md = _itemNotes_v8 ^. mdText
in renderMarkdownBlockWithTOC pref md,
_itemLink = _itemLink_v8,
_itemKind = _itemKind_v8 }
--
@ -314,7 +315,7 @@ data Category = Category {
_categoryGroups :: Map Text Hue,
_categoryItems :: [Item],
_categoryItemsDeleted :: [Item] }
deriving (Eq, Show)
deriving (Show)
deriveSafeCopySimple 4 'extension ''Category
makeFields ''Category
@ -661,7 +662,7 @@ addCategory catId title' created' = do
_categoryUid = catId,
_categoryTitle = title',
_categoryCreated = created',
_categoryNotes = "",
_categoryNotes = renderMarkdownBlock "",
_categoryGroups = mempty,
_categoryItems = [],
_categoryItemsDeleted = [] }
@ -682,13 +683,14 @@ addItem catId itemId name' created' kind' = do
_itemName = name',
_itemCreated = created',
_itemGroup_ = Nothing,
_itemDescription = "",
_itemDescription = renderMarkdownBlock "",
_itemPros = [],
_itemProsDeleted = [],
_itemCons = [],
_itemConsDeleted = [],
_itemEcosystem = "",
_itemNotes = "",
_itemEcosystem = renderMarkdownBlock "",
_itemNotes = let pref = "item-notes-" <> uidToText itemId <> "-"
in renderMarkdownBlockWithTOC pref "",
_itemLink = Nothing,
_itemKind = kind' }
categoryById catId . items %= (++ [newItem])
@ -800,7 +802,9 @@ setItemDescription itemId description' = do
setItemNotes :: Uid Item -> Text -> Acid.Update GlobalState (Edit, Item)
setItemNotes itemId notes' = do
oldNotes <- itemById itemId . notes <<.= renderMarkdownBlock notes'
let pref = "item-notes-" <> uidToText itemId <> "-"
oldNotes <- itemById itemId . notes <<.=
renderMarkdownBlockWithTOC pref notes'
let edit = Edit'SetItemNotes itemId (oldNotes ^. mdText) notes'
(edit,) <$> use (itemById itemId)

59
src/View.hs
View File

@ -585,14 +585,14 @@ renderCategoryNotes category = do
section "normal" [shown, noScriptShown] $ do
div_ [class_ "notes-like"] $ do
if category^.notes == ""
if markdownNull (category^.notes)
then p_ "write something here!"
else toHtml (category^.notes)
textButton "edit description" $
JS.switchSection (this, "editing" :: Text)
section "editing" [] $ do
contents <- if category^.notes == ""
contents <- if markdownNull (category^.notes)
then liftIO $ renderMarkdownBlock <$>
T.readFile "static/category-notes-template.md"
else return (category^.notes)
@ -636,7 +636,7 @@ renderItem category item =
renderItemTraits item
renderItemEcosystem item
-- TODO: add a separator here? [very-easy]
renderItemNotes item
renderItemNotes category item
-- TODO: warn when a library isn't on Hackage but is supposed to be
@ -684,8 +684,7 @@ renderItemInfo cat item = do
-- TODO: [very-easy] move this style_ into css.css
span_ [style_ "font-size:150%"] $ do
-- TODO: absolute links again [absolute-links]
let link' = format "/haskell/{}#{}" (categorySlug cat, itemNodeId item)
a_ [class_ "anchor", href_ link'] "#"
a_ [class_ "anchor", href_ (itemLink cat item)] "#"
renderItemTitle item
emptySpan "2em"
toHtml (fromMaybe "other" (item^.group_))
@ -787,7 +786,7 @@ renderItemDescription item = do
section "normal" [shown, noScriptShown] $ do
div_ [class_ "notes-like"] $ do
if item^.description == ""
if markdownNull (item^.description)
then p_ "write something here!"
else toHtml (item^.description)
textButton "edit description" $
@ -812,7 +811,7 @@ renderItemEcosystem item = do
JS.switchSection (this, "editing" :: Text)
section "normal" [shown, noScriptShown] $ do
unless (item^.ecosystem == "") $
unless (markdownNull (item^.ecosystem)) $
toHtml (item^.ecosystem)
section "editing" [] $
@ -837,7 +836,7 @@ renderItemTraits item = do
section "editable" [] $
smallMarkdownEditor
[rows_ "3", placeholder_ "add pro"]
""
(renderMarkdownInline "")
(\val -> JS.addPro (JS.selectUid listUid, item^.uid, val) <>
JS.assign val ("" :: Text))
Nothing
@ -851,7 +850,7 @@ renderItemTraits item = do
section "editable" [] $
smallMarkdownEditor
[rows_ "3", placeholder_ "add con"]
""
(renderMarkdownInline "")
(\val -> JS.addCon (JS.selectUid listUid, item^.uid, val) <>
JS.assign val ("" :: Text))
Nothing
@ -913,8 +912,10 @@ renderTrait itemId trait = do
-- TODO: [very-easy] focus the notes textarea on edit (can use jQuery's
-- .focus() on it)
renderItemNotes :: (MonadIO m, MonadRandom m) => Item -> HtmlT m ()
renderItemNotes item = do
renderItemNotes
:: (MonadIO m, MonadRandom m)
=> Category -> Item -> HtmlT m ()
renderItemNotes category item = do
-- Don't change this ID, it's used in e.g. 'JS.expandHash'
let thisId = "item-notes-" <> uidToText (item^.uid)
this = JS.selectId thisId
@ -922,16 +923,26 @@ renderItemNotes item = do
div_ [id_ thisId, class_ "item-notes"] $ do
let renderTOC = do
let toc = extractSections (item^.notes.mdMarkdown)
let toc = item^.notes.mdTOC
div_ [class_ "notes-toc"] $ do
let renderTree :: Monad m => Forest Inlines -> HtmlT m ()
let renderTree :: Monad m => Forest (Inlines, Text) -> HtmlT m ()
renderTree [] = return ()
renderTree xs = ul_ $ do
for_ xs $ \(Node x children) -> li_ $ do
renderInlines def x
for_ xs $ \(Node (is, id') children) -> li_ $ do
let handler = fromJS (JS.expandItemNotes [item^.uid])
-- The link has to be full because sometimes we are
-- looking at items from pages different from the
-- proper category pages (e.g. if a search returned a
-- list of items). Well, actually it doesn't happen
-- yet (at the moment of writing), but it might start
-- happening and then it's better to be prepared.
fullLink = format "/haskell/{}#{}"
(categorySlug category, id')
a_ [href_ fullLink, onclick_ handler] $
renderInlines def is
renderTree children
if null toc
then p_ "<notes are empty>"
then p_ (emptySpan "1.5em" >> "<notes are empty>")
else renderTree toc
section "collapsed" [shown] $ do
@ -941,7 +952,7 @@ renderItemNotes item = do
section "expanded" [noScriptShown] $ do
textareaUid <- randomLongUid
contents <- if item^.notes == ""
contents <- if markdownNull (item^.notes)
then liftIO $ T.readFile "static/item-notes-template.md"
else return (item^.notes.mdText)
let buttons = do
@ -959,10 +970,10 @@ renderItemNotes item = do
buttons
renderTOC
div_ [class_ "notes-like"] $ do
if item^.notes == ""
if markdownNull (item^.notes)
then p_ "add something!"
else toHtml (item^.notes)
unless (item^.notes == "") $
unless (markdownNull (item^.notes)) $
buttons
-- TODO: [easy] the lower “hide notes” should scroll back to item when
-- the notes are closed (but don't scroll if it's already visible after
@ -977,16 +988,16 @@ renderItemNotes item = do
renderItemForFeed :: Monad m => Item -> HtmlT m ()
renderItemForFeed item = do
h1_ $ renderItemTitle item
when (item^.description /= "") $
unless (markdownNull (item^.description)) $
toHtml (item^.description)
h2_ "Pros"
ul_ $ mapM_ (p_ . li_ . toHtml . view content) (item^.pros)
h2_ "Cons"
ul_ $ mapM_ (p_ . li_ . toHtml . view content) (item^.cons)
when (item^.ecosystem /= "") $ do
unless (markdownNull (item^.ecosystem)) $ do
h2_ "Ecosystem"
toHtml (item^.ecosystem)
when (item^.notes /= "") $ do
unless (markdownNull (item^.notes)) $ do
h2_ "Notes"
toHtml (item^.notes)
@ -1113,6 +1124,10 @@ categoryNodeId category = "category-" <> uidToText (category^.uid)
categoryNode :: Category -> JQuerySelector
categoryNode = JS.selectId . categoryNodeId
itemLink :: Category -> Item -> Text
itemLink category item =
format "/haskell/{}#{}" (categorySlug category, itemNodeId item)
-- See Note [show-hide]; wheh changing these, also look at 'JS.switchSection'.
shown, noScriptShown :: Attribute
shown = class_ " shown "