mirror of
https://github.com/aelve/guide.git
synced 2024-11-22 03:12:58 +03:00
Don't use makeFields for Markdown types
This commit is contained in:
Artyom Kazak
parent
17ed66fefe
commit
fe631c0b18
@ -66,7 +66,7 @@ createCategory title' group' =
|
||||
setCategoryNotes :: Uid Category -> CTextEdit -> Guider NoContent
|
||||
setCategoryNotes catId $(fields 'CTextEdit) =
|
||||
logHandler "setCategoryNotes" [attr "catId" catId] $ do
|
||||
serverModified <- markdownBlockMdSource . categoryNotes <$> getCategoryOrFail catId
|
||||
serverModified <- markdownBlockSource . categoryNotes <$> getCategoryOrFail catId
|
||||
checkConflict CTextEdit{..} serverModified
|
||||
addEdit . fst =<< dbUpdate (SetCategoryNotes catId cteModified)
|
||||
pure NoContent
|
||||
@ -140,7 +140,7 @@ setItemInfo itemId $(fields 'CItemInfoEdit) =
|
||||
setItemSummary :: Uid Item -> CTextEdit -> Guider NoContent
|
||||
setItemSummary itemId $(fields 'CTextEdit) =
|
||||
logHandler "setItemSummary" [attr "itemId" itemId] $ do
|
||||
serverModified <- markdownBlockMdSource . itemSummary <$> getItemOrFail itemId
|
||||
serverModified <- markdownBlockSource . itemSummary <$> getItemOrFail itemId
|
||||
checkConflict CTextEdit{..} serverModified
|
||||
addEdit . fst =<< dbUpdate (SetItemSummary itemId cteModified)
|
||||
pure NoContent
|
||||
@ -149,7 +149,7 @@ setItemSummary itemId $(fields 'CTextEdit) =
|
||||
setItemEcosystem :: Uid Item -> CTextEdit -> Guider NoContent
|
||||
setItemEcosystem itemId $(fields 'CTextEdit) =
|
||||
logHandler "setItemEcosystem" [attr "itemId" itemId] $ do
|
||||
serverModified <- markdownBlockMdSource . itemEcosystem <$> getItemOrFail itemId
|
||||
serverModified <- markdownBlockSource . itemEcosystem <$> getItemOrFail itemId
|
||||
checkConflict CTextEdit{..} serverModified
|
||||
addEdit . fst =<< dbUpdate (SetItemEcosystem itemId cteModified)
|
||||
pure NoContent
|
||||
@ -158,7 +158,7 @@ setItemEcosystem itemId $(fields 'CTextEdit) =
|
||||
setItemNotes :: Uid Item -> CTextEdit -> Guider NoContent
|
||||
setItemNotes itemId $(fields 'CTextEdit) =
|
||||
logHandler "setItemNotes" [attr "itemId" itemId] $ do
|
||||
serverModified <- markdownTreeMdSource . itemNotes <$> getItemOrFail itemId
|
||||
serverModified <- markdownTreeSource . itemNotes <$> getItemOrFail itemId
|
||||
checkConflict CTextEdit{..} serverModified
|
||||
addEdit . fst =<< dbUpdate (SetItemNotes itemId cteModified)
|
||||
pure NoContent
|
||||
@ -205,7 +205,7 @@ createTrait itemId $(fields 'CCreateTrait) =
|
||||
setTrait :: Uid Item -> Uid Trait -> CTextEdit -> Guider NoContent
|
||||
setTrait itemId traitId $(fields 'CTextEdit) =
|
||||
logHandler "setTrait" [attr "itemId" itemId, attr "traitId" traitId] $ do
|
||||
serverModified <- markdownInlineMdSource . traitContent <$> getTraitOrFail itemId traitId
|
||||
serverModified <- markdownInlineSource . traitContent <$> getTraitOrFail itemId traitId
|
||||
checkConflict CTextEdit{..} serverModified
|
||||
addEdit . fst =<< dbUpdate (SetTraitContent itemId traitId cteModified)
|
||||
pure NoContent
|
||||
|
||||
@ -693,7 +693,7 @@ toCItemFull $(fields 'Item) = CItemFull
|
||||
, cifEcosystem = toCMarkdown itemEcosystem
|
||||
, cifNotes = toCMarkdown itemNotes
|
||||
, cifLink = itemLink
|
||||
, cifToc = map toCTocHeading (markdownTreeMdTOC itemNotes)
|
||||
, cifToc = map toCTocHeading (markdownTreeTOC itemNotes)
|
||||
}
|
||||
where
|
||||
-- Ignored fields
|
||||
@ -753,22 +753,33 @@ instance ToSchema CMarkdown where
|
||||
class ToCMarkdown md where toCMarkdown :: md -> CMarkdown
|
||||
|
||||
instance ToCMarkdown MarkdownInline where
|
||||
toCMarkdown md = CMarkdown
|
||||
{ cmdText = md^.mdSource
|
||||
, cmdHtml = toText (md^.mdHtml)
|
||||
toCMarkdown $(fields 'MarkdownInline) = CMarkdown
|
||||
{ cmdText = markdownInlineSource
|
||||
, cmdHtml = toText markdownInlineHtml
|
||||
}
|
||||
where
|
||||
-- Ignored fields
|
||||
_ = markdownInlineMarkdown
|
||||
|
||||
instance ToCMarkdown MarkdownBlock where
|
||||
toCMarkdown md = CMarkdown
|
||||
{ cmdText = md^.mdSource
|
||||
, cmdHtml = toText (md^.mdHtml)
|
||||
toCMarkdown $(fields 'MarkdownBlock) = CMarkdown
|
||||
{ cmdText = markdownBlockSource
|
||||
, cmdHtml = toText markdownBlockHtml
|
||||
}
|
||||
where
|
||||
-- Ignored fields
|
||||
_ = markdownBlockMarkdown
|
||||
|
||||
instance ToCMarkdown MarkdownTree where
|
||||
toCMarkdown md = CMarkdown
|
||||
{ cmdText = md^.mdSource
|
||||
toCMarkdown md@($(fields 'MarkdownTree)) = CMarkdown
|
||||
{ cmdText = markdownTreeSource
|
||||
, cmdHtml = toText . renderText $ toHtml md
|
||||
}
|
||||
where
|
||||
-- Ignored fields
|
||||
_ = markdownTreeStructure
|
||||
_ = markdownTreeTOC
|
||||
_ = markdownTreeIdPrefix
|
||||
|
||||
----------------------------------------------------------------------------
|
||||
-- CTocHeading
|
||||
@ -797,7 +808,7 @@ instance ToSchema CTocHeading where
|
||||
-- | 'toCTocHeading' converts a table of contents into the format expected by the frontend.
|
||||
toCTocHeading :: Tree Heading -> CTocHeading
|
||||
toCTocHeading $(fields 'Node) = CTocHeading
|
||||
{ cthContent = toCMarkdown $ headingMd rootLabel
|
||||
{ cthContent = toCMarkdown $ headingMarkdown rootLabel
|
||||
, cthSlug = headingSlug rootLabel
|
||||
, cthSubheadings = map toCTocHeading subForest
|
||||
}
|
||||
@ -942,7 +953,7 @@ toCSearchResult (SRCategory cat) =
|
||||
-- is about).
|
||||
--
|
||||
-- TODO: just extract the first paragraph, not the preface.
|
||||
extractPreface $ toMarkdownTree "" $ view mdSource (categoryNotes cat)
|
||||
extractPreface $ toMarkdownTree "" $ markdownBlockSource (categoryNotes cat)
|
||||
}
|
||||
toCSearchResult (SRItem cat item) =
|
||||
CSRItemResult $ CSRItem
|
||||
|
||||
@ -118,7 +118,7 @@ setMethods = do
|
||||
Spock.post (setRoute <//> categoryVar <//> "notes") $ \catId -> do
|
||||
original <- param' "original"
|
||||
content' <- param' "content"
|
||||
modified <- view (_categoryNotes.mdSource) <$> dbQuery (GetCategory catId)
|
||||
modified <- markdownBlockSource . categoryNotes <$> dbQuery (GetCategory catId)
|
||||
if modified == original
|
||||
then do
|
||||
(edit, category) <- dbUpdate (SetCategoryNotes catId content')
|
||||
@ -161,7 +161,7 @@ setMethods = do
|
||||
Spock.post (setRoute <//> itemVar <//> "description") $ \itemId -> do
|
||||
original <- param' "original"
|
||||
content' <- param' "content"
|
||||
modified <- view (_itemSummary.mdSource) <$> dbQuery (GetItem itemId)
|
||||
modified <- markdownBlockSource . itemSummary <$> dbQuery (GetItem itemId)
|
||||
if modified == original
|
||||
then do
|
||||
(edit, item) <- dbUpdate (SetItemSummary itemId content')
|
||||
@ -176,7 +176,7 @@ setMethods = do
|
||||
Spock.post (setRoute <//> itemVar <//> "ecosystem") $ \itemId -> do
|
||||
original <- param' "original"
|
||||
content' <- param' "content"
|
||||
modified <- view (_itemEcosystem.mdSource) <$> dbQuery (GetItem itemId)
|
||||
modified <- markdownBlockSource . itemEcosystem <$> dbQuery (GetItem itemId)
|
||||
if modified == original
|
||||
then do
|
||||
(edit, item) <- dbUpdate (SetItemEcosystem itemId content')
|
||||
@ -191,7 +191,7 @@ setMethods = do
|
||||
Spock.post (setRoute <//> itemVar <//> "notes") $ \itemId -> do
|
||||
original <- param' "original"
|
||||
content' <- param' "content"
|
||||
modified <- view (_itemNotes.mdSource) <$> dbQuery (GetItem itemId)
|
||||
modified <- markdownTreeSource . itemNotes <$> dbQuery (GetItem itemId)
|
||||
if modified == original
|
||||
then do
|
||||
(edit, item) <- dbUpdate (SetItemNotes itemId content')
|
||||
@ -207,7 +207,8 @@ setMethods = do
|
||||
Spock.post (setRoute <//> itemVar <//> traitVar) $ \itemId traitId -> do
|
||||
original <- param' "original"
|
||||
content' <- param' "content"
|
||||
modified <- view (_traitContent.mdSource) <$> dbQuery (GetTrait itemId traitId)
|
||||
modified <- markdownInlineSource . traitContent <$>
|
||||
dbQuery (GetTrait itemId traitId)
|
||||
if modified == original
|
||||
then do
|
||||
(edit, trait) <- dbUpdate (SetTraitContent itemId traitId content')
|
||||
|
||||
@ -13,18 +13,13 @@ module Guide.Markdown
|
||||
(
|
||||
-- * Types
|
||||
MarkdownInline(..),
|
||||
MarkdownInlineLenses(..),
|
||||
MarkdownBlock(..),
|
||||
MarkdownBlockLenses(..),
|
||||
MarkdownTree(..),
|
||||
MarkdownTreeLenses(..),
|
||||
Heading(..),
|
||||
|
||||
-- * Lenses
|
||||
mdHtml,
|
||||
mdSource,
|
||||
mdMarkdown,
|
||||
mdIdPrefix,
|
||||
mdTree,
|
||||
mdTOC,
|
||||
|
||||
-- * Converting text to Markdown
|
||||
toMarkdownInline,
|
||||
toMarkdownBlock,
|
||||
@ -32,7 +27,6 @@ module Guide.Markdown
|
||||
|
||||
-- * Misc
|
||||
renderMD,
|
||||
markdownNull,
|
||||
extractPreface,
|
||||
)
|
||||
where
|
||||
@ -66,33 +60,33 @@ import qualified Data.Text as T
|
||||
|
||||
|
||||
data MarkdownInline = MarkdownInline {
|
||||
markdownInlineMdSource :: Text,
|
||||
markdownInlineMdHtml :: ByteString,
|
||||
markdownInlineMdMarkdown :: ![MD.Node] }
|
||||
markdownInlineSource :: Text,
|
||||
markdownInlineHtml :: ByteString,
|
||||
markdownInlineMarkdown :: ![MD.Node] }
|
||||
deriving (Generic, Data, Eq)
|
||||
|
||||
data MarkdownBlock = MarkdownBlock {
|
||||
markdownBlockMdSource :: Text,
|
||||
markdownBlockMdHtml :: ByteString,
|
||||
markdownBlockMdMarkdown :: ![MD.Node] }
|
||||
markdownBlockSource :: Text,
|
||||
markdownBlockHtml :: ByteString,
|
||||
markdownBlockMarkdown :: ![MD.Node] }
|
||||
deriving (Generic, Data)
|
||||
|
||||
data MarkdownTree = MarkdownTree {
|
||||
markdownTreeMdSource :: Text,
|
||||
markdownTreeMdTree :: !(Document Text ByteString),
|
||||
markdownTreeMdIdPrefix :: Text,
|
||||
markdownTreeMdTOC :: Forest Heading }
|
||||
markdownTreeSource :: Text,
|
||||
markdownTreeStructure :: !(Document Text ByteString),
|
||||
markdownTreeIdPrefix :: Text,
|
||||
markdownTreeTOC :: Forest Heading }
|
||||
deriving (Generic, Data)
|
||||
|
||||
-- | Table-of-contents heading
|
||||
data Heading = Heading
|
||||
{ headingMd :: MarkdownInline
|
||||
{ headingMarkdown :: MarkdownInline
|
||||
, headingSlug :: Text
|
||||
} deriving (Generic, Data, Eq)
|
||||
|
||||
makeFields ''MarkdownInline
|
||||
makeFields ''MarkdownBlock
|
||||
makeFields ''MarkdownTree
|
||||
makeClassWithLenses ''MarkdownInline
|
||||
makeClassWithLenses ''MarkdownBlock
|
||||
makeClassWithLenses ''MarkdownTree
|
||||
|
||||
parseMD :: Text -> [MD.Node]
|
||||
parseMD s =
|
||||
@ -149,16 +143,17 @@ stringify = T.concat . map go
|
||||
|
||||
-- | Extract everything before the first heading.
|
||||
--
|
||||
-- Note that if you render 'mdSource' of the produced Markdown block, it won't
|
||||
-- necessarily parse into 'mdHtml' from the same block. It's because rendered
|
||||
-- Markdown might depend on links that are defined further in the tree.
|
||||
-- Note that if you render 'markdownBlockSource' of the produced Markdown
|
||||
-- block, it won't necessarily parse into 'markdownBlockHtml' from the same
|
||||
-- block. It's because rendered Markdown might depend on links that are
|
||||
-- defined further in the tree.
|
||||
extractPreface :: MarkdownTree -> MarkdownBlock
|
||||
extractPreface = mkBlock . preface . view mdTree
|
||||
extractPreface = mkBlock . preface . markdownTreeStructure
|
||||
where
|
||||
mkBlock x = MarkdownBlock {
|
||||
markdownBlockMdSource = getSource x,
|
||||
markdownBlockMdHtml = renderMD (stripSource x),
|
||||
markdownBlockMdMarkdown = stripSource x }
|
||||
markdownBlockSource = getSource x,
|
||||
markdownBlockHtml = renderMD (stripSource x),
|
||||
markdownBlockMarkdown = stripSource x }
|
||||
|
||||
-- | Flatten Markdown by concatenating all block elements.
|
||||
extractInlines :: [MD.Node] -> [MD.Node]
|
||||
@ -241,28 +236,28 @@ parseLink = either (Left . show) Right . parse p ""
|
||||
|
||||
toMarkdownInline :: Text -> MarkdownInline
|
||||
toMarkdownInline s = MarkdownInline {
|
||||
markdownInlineMdSource = s,
|
||||
markdownInlineMdHtml = html,
|
||||
markdownInlineMdMarkdown = inlines }
|
||||
markdownInlineSource = s,
|
||||
markdownInlineHtml = html,
|
||||
markdownInlineMarkdown = inlines }
|
||||
where
|
||||
inlines = extractInlines (parseMD s)
|
||||
html = renderMD inlines
|
||||
|
||||
toMarkdownBlock :: Text -> MarkdownBlock
|
||||
toMarkdownBlock s = MarkdownBlock {
|
||||
markdownBlockMdSource = s,
|
||||
markdownBlockMdHtml = html,
|
||||
markdownBlockMdMarkdown = doc }
|
||||
markdownBlockSource = s,
|
||||
markdownBlockHtml = html,
|
||||
markdownBlockMarkdown = doc }
|
||||
where
|
||||
doc = parseMD s
|
||||
html = renderMD doc
|
||||
|
||||
toMarkdownTree :: Text -> Text -> MarkdownTree
|
||||
toMarkdownTree idPrefix s = MarkdownTree {
|
||||
markdownTreeMdSource = s,
|
||||
markdownTreeMdIdPrefix = idPrefix,
|
||||
markdownTreeMdTree = tree,
|
||||
markdownTreeMdTOC = toc }
|
||||
markdownTreeSource = s,
|
||||
markdownTreeIdPrefix = idPrefix,
|
||||
markdownTreeStructure = tree,
|
||||
markdownTreeTOC = toc }
|
||||
where
|
||||
blocks :: [MD.Node]
|
||||
blocks = parseMD s
|
||||
@ -281,9 +276,9 @@ toMarkdownTree idPrefix s = MarkdownTree {
|
||||
|
||||
nodesToMdInline :: WithSource [MD.Node] -> MarkdownInline
|
||||
nodesToMdInline (WithSource src nodes) = MarkdownInline
|
||||
{ markdownInlineMdSource = src
|
||||
, markdownInlineMdHtml = html
|
||||
, markdownInlineMdMarkdown = inlines
|
||||
{ markdownInlineSource = src
|
||||
, markdownInlineHtml = html
|
||||
, markdownInlineMarkdown = inlines
|
||||
}
|
||||
where
|
||||
inlines = extractInlines nodes
|
||||
@ -310,34 +305,34 @@ slugifyDocument slugify doc = doc {
|
||||
return sec{headingAnn = slug}
|
||||
|
||||
instance Show MarkdownInline where
|
||||
show = show . view mdSource
|
||||
show = show . markdownInlineSource
|
||||
instance Show MarkdownBlock where
|
||||
show = show . view mdSource
|
||||
show = show . markdownBlockSource
|
||||
instance Show MarkdownTree where
|
||||
show = show . view mdSource
|
||||
show = show . markdownTreeSource
|
||||
deriving instance Show Heading
|
||||
|
||||
instance A.ToJSON MarkdownInline where
|
||||
toJSON md = A.object [
|
||||
"text" A..= (md^.mdSource),
|
||||
"html" A..= toText (md^.mdHtml) ]
|
||||
"text" A..= markdownInlineSource md,
|
||||
"html" A..= toText (markdownInlineHtml md) ]
|
||||
instance A.ToJSON MarkdownBlock where
|
||||
toJSON md = A.object [
|
||||
"text" A..= (md^.mdSource),
|
||||
"html" A..= toText (md^.mdHtml) ]
|
||||
"text" A..= markdownBlockSource md,
|
||||
"html" A..= toText (markdownBlockHtml md) ]
|
||||
instance A.ToJSON MarkdownTree where
|
||||
toJSON md = A.object [
|
||||
"text" A..= (md^.mdSource) ]
|
||||
"text" A..= markdownTreeSource md ]
|
||||
|
||||
instance ToHtml MarkdownInline where
|
||||
toHtmlRaw = toHtml
|
||||
toHtml = toHtmlRaw . view mdHtml
|
||||
toHtml = toHtmlRaw . markdownInlineHtml
|
||||
instance ToHtml MarkdownBlock where
|
||||
toHtmlRaw = toHtml
|
||||
toHtml = toHtmlRaw . view mdHtml
|
||||
toHtml = toHtmlRaw . markdownBlockHtml
|
||||
instance ToHtml MarkdownTree where
|
||||
toHtmlRaw = toHtml
|
||||
toHtml = toHtmlRaw . renderDoc . view mdTree
|
||||
toHtml = toHtmlRaw . renderDoc . markdownTreeStructure
|
||||
where
|
||||
renderDoc Document{..} = BS.concat $
|
||||
prefaceAnn :
|
||||
@ -356,22 +351,18 @@ instance ToHtml MarkdownTree where
|
||||
instance SafeCopy MarkdownInline where
|
||||
version = 0
|
||||
kind = base
|
||||
putCopy = contain . safePut . view mdSource
|
||||
putCopy = contain . safePut . markdownInlineSource
|
||||
getCopy = contain $ toMarkdownInline <$> safeGet
|
||||
instance SafeCopy MarkdownBlock where
|
||||
version = 0
|
||||
kind = base
|
||||
putCopy = contain . safePut . view mdSource
|
||||
putCopy = contain . safePut . markdownBlockSource
|
||||
getCopy = contain $ toMarkdownBlock <$> safeGet
|
||||
instance SafeCopy MarkdownTree where
|
||||
version = 0
|
||||
kind = base
|
||||
putCopy md = contain $ do
|
||||
safePut (md ^. mdIdPrefix)
|
||||
safePut (md ^. mdSource)
|
||||
safePut (markdownTreeIdPrefix md)
|
||||
safePut (markdownTreeSource md)
|
||||
getCopy = contain $
|
||||
toMarkdownTree <$> safeGet <*> safeGet
|
||||
|
||||
-- | Is a piece of Markdown empty?
|
||||
markdownNull :: HasMdSource a Text => a -> Bool
|
||||
markdownNull = T.null . view mdSource
|
||||
|
||||
@ -50,7 +50,7 @@ search query gs =
|
||||
sortByRank [(SRItemEcosystem cat item, rank)
|
||||
| cat <- categories gs
|
||||
, item <- categoryItems cat
|
||||
, let rank = match query (item ^. _itemEcosystem . mdSource)
|
||||
, let rank = match query (markdownBlockSource (itemEcosystem item))
|
||||
, rank > 0 ]
|
||||
where
|
||||
sortByRank :: [(a, Int)] -> [a]
|
||||
|
||||
@ -128,7 +128,7 @@ undoEdit (Edit'ChangeCategoryEnabledSections catId toEnable toDisable) = do
|
||||
then return (Left "enabled-sections has been changed further")
|
||||
else Right () <$ dbUpdate (ChangeCategoryEnabledSections catId toDisable toEnable)
|
||||
undoEdit (Edit'SetCategoryNotes catId old new) = do
|
||||
now <- view (_categoryNotes . mdSource) <$> dbQuery (GetCategory catId)
|
||||
now <- markdownBlockSource . categoryNotes <$> dbQuery (GetCategory catId)
|
||||
if now /= new
|
||||
then return (Left "notes have been changed further")
|
||||
else Right () <$ dbUpdate (SetCategoryNotes catId old)
|
||||
@ -150,22 +150,22 @@ undoEdit (Edit'SetItemHackage itemId old new) = do
|
||||
then return (Left "Hackage name has been changed further")
|
||||
else Right () <$ dbUpdate (SetItemHackage itemId old)
|
||||
undoEdit (Edit'SetItemSummary itemId old new) = do
|
||||
now <- view (_itemSummary . mdSource) <$> dbQuery (GetItem itemId)
|
||||
now <- markdownBlockSource . itemSummary <$> dbQuery (GetItem itemId)
|
||||
if now /= new
|
||||
then return (Left "description has been changed further")
|
||||
else Right () <$ dbUpdate (SetItemSummary itemId old)
|
||||
undoEdit (Edit'SetItemNotes itemId old new) = do
|
||||
now <- view (_itemNotes . mdSource) <$> dbQuery (GetItem itemId)
|
||||
now <- markdownTreeSource . itemNotes <$> 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 <- view (_itemEcosystem . mdSource) <$> dbQuery (GetItem itemId)
|
||||
now <- markdownBlockSource . itemEcosystem <$> 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 <- view (_traitContent . mdSource) <$> dbQuery (GetTrait itemId traitId)
|
||||
now <- markdownInlineSource . traitContent <$> dbQuery (GetTrait itemId traitId)
|
||||
if now /= new
|
||||
then return (Left "trait has been changed further")
|
||||
else Right () <$ dbUpdate (SetTraitContent itemId traitId old)
|
||||
|
||||
@ -431,7 +431,7 @@ setCategoryGroup catId group' = do
|
||||
setCategoryNotes :: Uid Category -> Text -> Acid.Update GlobalState (Edit, Category)
|
||||
setCategoryNotes catId notes' = do
|
||||
oldNotes <- categoryById catId . _categoryNotes <<.= toMarkdownBlock notes'
|
||||
let edit = Edit'SetCategoryNotes catId (oldNotes ^. mdSource) notes'
|
||||
let edit = Edit'SetCategoryNotes catId (markdownBlockSource oldNotes) notes'
|
||||
(edit,) <$> use (categoryById catId)
|
||||
|
||||
setCategoryStatus :: Uid Category -> CategoryStatus -> Acid.Update GlobalState (Edit, Category)
|
||||
@ -474,23 +474,21 @@ setItemSummary itemId description' = do
|
||||
oldDescr <- itemById itemId . _itemSummary <<.=
|
||||
toMarkdownBlock description'
|
||||
let edit = Edit'SetItemSummary itemId
|
||||
(oldDescr ^. mdSource) description'
|
||||
(markdownBlockSource oldDescr) description'
|
||||
(edit,) <$> use (itemById itemId)
|
||||
|
||||
setItemNotes :: Uid Item -> Text -> Acid.Update GlobalState (Edit, Item)
|
||||
setItemNotes itemId notes' = do
|
||||
let pref = "item-notes-" <> uidToText itemId <> "-"
|
||||
oldNotes <- itemById itemId . _itemNotes <<.=
|
||||
toMarkdownTree pref notes'
|
||||
let edit = Edit'SetItemNotes itemId (oldNotes ^. mdSource) notes'
|
||||
oldNotes <- itemById itemId . _itemNotes <<.= toMarkdownTree pref notes'
|
||||
let edit = Edit'SetItemNotes itemId (markdownTreeSource oldNotes) notes'
|
||||
(edit,) <$> use (itemById itemId)
|
||||
|
||||
setItemEcosystem :: Uid Item -> Text -> Acid.Update GlobalState (Edit, Item)
|
||||
setItemEcosystem itemId ecosystem' = do
|
||||
oldEcosystem <- itemById itemId . _itemEcosystem <<.=
|
||||
toMarkdownBlock ecosystem'
|
||||
oldEcosystem <- itemById itemId . _itemEcosystem <<.= toMarkdownBlock ecosystem'
|
||||
let edit = Edit'SetItemEcosystem itemId
|
||||
(oldEcosystem ^. mdSource) ecosystem'
|
||||
(markdownBlockSource oldEcosystem) ecosystem'
|
||||
(edit,) <$> use (itemById itemId)
|
||||
|
||||
setTraitContent :: Uid Item -> Uid Trait -> Text -> Acid.Update GlobalState (Edit, Trait)
|
||||
@ -498,7 +496,7 @@ setTraitContent itemId traitId content' = do
|
||||
oldContent <- itemById itemId . traitById traitId . _traitContent <<.=
|
||||
toMarkdownInline content'
|
||||
let edit = Edit'SetTraitContent itemId traitId
|
||||
(oldContent ^. mdSource) content'
|
||||
(markdownInlineSource oldContent) content'
|
||||
(edit,) <$> use (itemById itemId . traitById traitId)
|
||||
|
||||
-- delete
|
||||
|
||||
@ -636,7 +636,9 @@ renderSearchResult r = do
|
||||
a_ [class_ "category-link", href_ (mkCategoryLink cat)] $
|
||||
toHtml (categoryTitle cat)
|
||||
div_ [class_ "category-description notes-like"] $
|
||||
toHtml (extractPreface $ toMarkdownTree "" $ cat ^. _categoryNotes . mdSource)
|
||||
toHtml $ extractPreface $
|
||||
toMarkdownTree "" $
|
||||
markdownBlockSource (categoryNotes cat)
|
||||
SRItem cat item -> do
|
||||
a_ [class_ "category-link in-item-sr", href_ (mkCategoryLink cat)] $
|
||||
toHtml (categoryTitle cat)
|
||||
|
||||
@ -158,7 +158,7 @@ renderCategoryNotes category =
|
||||
in div_ [id_ thisId, class_ "category-notes"] $ do
|
||||
section "normal" [shown, noScriptShown] $ do
|
||||
div_ [class_ "notes-like"] $ do
|
||||
if markdownNull (categoryNotes category)
|
||||
if markdownBlockSource (categoryNotes category) == ""
|
||||
then p_ "write something here!"
|
||||
else toHtml (categoryNotes category)
|
||||
textButton "edit description" $
|
||||
@ -168,7 +168,7 @@ renderCategoryNotes category =
|
||||
JS.selectClass "editor"]
|
||||
|
||||
section "editing" [] $ do
|
||||
contents <- if markdownNull (categoryNotes category)
|
||||
contents <- if markdownBlockSource (categoryNotes category) == ""
|
||||
then liftIO $ toMarkdownBlock <$>
|
||||
T.readFile "static/category-notes-template.md"
|
||||
else return (categoryNotes category)
|
||||
@ -176,6 +176,9 @@ renderCategoryNotes category =
|
||||
10 -- rows
|
||||
contents
|
||||
(\val -> JS.withThis JS.submitCategoryNotes
|
||||
(this, categoryUid category, category ^. _categoryNotes . mdSource, val))
|
||||
(this,
|
||||
categoryUid category,
|
||||
markdownBlockSource (categoryNotes category),
|
||||
val))
|
||||
(JS.withThis JS.switchSection (this, "normal" :: Text))
|
||||
"or press Ctrl+Enter to save"
|
||||
|
||||
@ -74,7 +74,7 @@ renderItemForFeed
|
||||
=> Category -> Item -> HtmlT m ()
|
||||
renderItemForFeed category item = do
|
||||
h1_ $ renderItemTitle item
|
||||
unless (markdownNull (itemSummary item)) $
|
||||
unless (markdownBlockSource (itemSummary item) == "") $
|
||||
toHtml (itemSummary item)
|
||||
when (ItemProsConsSection `elem` categoryEnabledSections category) $ do
|
||||
h2_ "Pros"
|
||||
@ -82,11 +82,11 @@ renderItemForFeed category item = do
|
||||
h2_ "Cons"
|
||||
ul_ $ mapM_ (p_ . li_ . toHtml . traitContent) (itemCons item)
|
||||
when (ItemEcosystemSection `elem` categoryEnabledSections category) $ do
|
||||
unless (markdownNull (itemEcosystem item)) $ do
|
||||
unless (markdownBlockSource (itemEcosystem item) == "") $ do
|
||||
h2_ "Ecosystem"
|
||||
toHtml (itemEcosystem item)
|
||||
-- TODO: include .notes-like style here? otherwise the headers are too big
|
||||
unless (markdownNull (itemNotes item)) $ do
|
||||
unless (markdownTreeSource (itemNotes item) == "") $ do
|
||||
h2_ "Notes"
|
||||
toHtml (itemNotes item)
|
||||
|
||||
@ -134,7 +134,7 @@ renderItemEcosystem item =
|
||||
`JS.selectChildren`
|
||||
JS.selectClass "editor"]
|
||||
div_ [class_ "notes-like"] $ do
|
||||
unless (markdownNull (itemEcosystem item)) $
|
||||
unless (markdownBlockSource (itemEcosystem item) == "") $
|
||||
toHtml (itemEcosystem item)
|
||||
|
||||
section "editing" [] $ do
|
||||
@ -147,7 +147,7 @@ renderItemEcosystem item =
|
||||
3 -- rows
|
||||
(itemEcosystem item)
|
||||
(\val -> JS.withThis JS.submitItemEcosystem
|
||||
(this, itemUid item, item ^. _itemEcosystem . mdSource, val))
|
||||
(this, itemUid item, markdownBlockSource (itemEcosystem item), val))
|
||||
(JS.withThis JS.switchSection (this, "normal" :: Text))
|
||||
"or press Ctrl+Enter to save"
|
||||
|
||||
@ -249,10 +249,10 @@ renderItemNotes category item = do
|
||||
-- start happening and then it's better to be prepared.
|
||||
fullLink = mkCategoryLink category <> "#" <> id'
|
||||
a_ [href_ fullLink, onclick_ handler] $
|
||||
toHtmlRaw (markdownInlineMdHtml hMd)
|
||||
toHtmlRaw (markdownInlineHtml hMd)
|
||||
renderTree children
|
||||
let renderTOC = do
|
||||
let toc = item ^. _itemNotes . mdTOC
|
||||
let toc = markdownTreeTOC (itemNotes item)
|
||||
div_ [class_ "notes-toc"] $ do
|
||||
if null toc
|
||||
then p_ (emptySpan "1.5em" >> "<notes are empty>")
|
||||
@ -265,9 +265,9 @@ renderItemNotes category item = do
|
||||
|
||||
section "expanded" [noScriptShown] $ do
|
||||
textareaUid <- randomLongUid
|
||||
contents <- if markdownNull (itemNotes item)
|
||||
contents <- if markdownTreeSource (itemNotes item) == ""
|
||||
then liftIO $ T.readFile "static/item-notes-template.md"
|
||||
else return (item ^. _itemNotes . mdSource)
|
||||
else return (markdownTreeSource (itemNotes item))
|
||||
let buttons = do
|
||||
textButton "collapse notes" $
|
||||
JS.switchSection (this, "collapsed" :: Text)
|
||||
@ -278,7 +278,7 @@ renderItemNotes category item = do
|
||||
this, JS.selectUid editingSectionUid,
|
||||
textareaUid,
|
||||
-- See Note [blurb diffing]
|
||||
markdownNull (itemNotes item),
|
||||
markdownTreeSource (itemNotes item) == "",
|
||||
contents,
|
||||
itemUid item) <>
|
||||
JS.switchSection (this, "editing" :: Text) <>
|
||||
@ -287,10 +287,10 @@ renderItemNotes category item = do
|
||||
buttons
|
||||
renderTOC
|
||||
div_ [class_ "notes-like"] $ do
|
||||
if markdownNull (itemNotes item)
|
||||
if markdownTreeSource (itemNotes item) == ""
|
||||
then p_ "add something!"
|
||||
else toHtml (itemNotes item)
|
||||
unless (markdownNull (itemNotes item)) $
|
||||
unless (markdownTreeSource (itemNotes item) == "") $
|
||||
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
|
||||
|
||||
@ -195,7 +195,7 @@ markdownEditor
|
||||
-> JS -- ^ “Cancel” handler
|
||||
-> Text -- ^ Instruction (e.g. “press Ctrl+Enter to save”)
|
||||
-> HtmlT m ()
|
||||
markdownEditor rows (view mdSource -> src) submit cancel instr = do
|
||||
markdownEditor rows (markdownBlockSource -> src) submit cancel instr = do
|
||||
editorUid <- randomLongUid
|
||||
term "a-editor" [uid_ editorUid,
|
||||
vBind "init-content" src,
|
||||
@ -216,7 +216,7 @@ smallMarkdownEditor
|
||||
-> Text -- ^ Instruction (e.g. “press Enter to add”)
|
||||
-> Maybe Text -- ^ Placeholder
|
||||
-> HtmlT m ()
|
||||
smallMarkdownEditor rows (view mdSource -> src) submit mbCancel instr mbPlaceholder = do
|
||||
smallMarkdownEditor rows (markdownInlineSource -> src) submit mbCancel instr mbPlaceholder = do
|
||||
editorUid <- randomLongUid
|
||||
term "a-editor-mini" ([uid_ editorUid,
|
||||
vBind "init-content" src,
|
||||
|
||||
@ -25,7 +25,7 @@ import Guide.Markdown
|
||||
tests :: Spec
|
||||
tests = describe "Markdown" $ do
|
||||
allMarkdowns $ \convert -> do
|
||||
it "has mdSource filled accurately" $ do
|
||||
it "has the source filled accurately" $ do
|
||||
for_ mdBlockExamples $ \s ->
|
||||
s `shouldBe` fst (convert s)
|
||||
it "only has allowed tags" $ do
|
||||
@ -110,7 +110,7 @@ tests = describe "Markdown" $ do
|
||||
headingMD = MD.Node Nothing (TEXT "foo") []
|
||||
foo2MD = MD.Node (Just (PosInfo 7 1 7 1)) PARAGRAPH
|
||||
[MD.Node Nothing (TEXT "y") []]
|
||||
(toMarkdownTree "i-" s ^. mdTree) `shouldBe` Document {
|
||||
markdownTreeStructure (toMarkdownTree "i-" s) `shouldBe` Document {
|
||||
prefaceAnn = "<p>x</p>\n",
|
||||
preface = WithSource "x\n\n" [prefaceMD],
|
||||
sections = [
|
||||
@ -130,7 +130,7 @@ tests = describe "Markdown" $ do
|
||||
subForest = [] }]}]}
|
||||
it "has a correct TOC" $ do
|
||||
let s = "x\n\n# foo\n\n## foo\n\ny"
|
||||
(toMarkdownTree "i-" s ^. mdTOC) `shouldBe` [
|
||||
markdownTreeTOC (toMarkdownTree "i-" s) `shouldBe` [
|
||||
Node {rootLabel = Heading (toMarkdownInline "# foo\n\n") "i-foo",
|
||||
subForest = [
|
||||
Node {rootLabel = Heading (toMarkdownInline "## foo\n\n") "i-foo_",
|
||||
@ -145,15 +145,15 @@ htmlToText = toText . renderText . toHtml
|
||||
allMarkdowns :: ((Text -> (Text, Text)) -> Spec) -> Spec
|
||||
allMarkdowns f = do
|
||||
describe "inline MD" $
|
||||
f ((view mdSource &&& htmlToText) . toMarkdownInline)
|
||||
f ((markdownInlineSource &&& htmlToText) . toMarkdownInline)
|
||||
blockMarkdowns f
|
||||
|
||||
blockMarkdowns :: ((Text -> (Text, Text)) -> Spec) -> Spec
|
||||
blockMarkdowns f = do
|
||||
describe "block MD" $
|
||||
f ((view mdSource &&& htmlToText) . toMarkdownBlock)
|
||||
f ((markdownBlockSource &&& htmlToText) . toMarkdownBlock)
|
||||
describe "block+toc MD" $
|
||||
f ((view mdSource &&& htmlToText) . toMarkdownTree "")
|
||||
f ((markdownTreeSource &&& htmlToText) . toMarkdownTree "")
|
||||
|
||||
mdInlineExamples :: [Text]
|
||||
mdInlineExamples = [
|
||||
|
||||
Loading…
Reference in New Issue
Block a user