diff --git a/chandlr.cabal b/chandlr.cabal index e664ea3..2deb3a9 100644 --- a/chandlr.cabal +++ b/chandlr.cabal @@ -75,6 +75,7 @@ executable chandlr Component.ThreadView Component.Thread.Files Component.Thread.Intro + Component.BodyRender Routes Common.AttachmentType BodyParser diff --git a/src/BodyParser.hs b/src/BodyParser.hs index f5c6b31..f087750 100644 --- a/src/BodyParser.hs +++ b/src/BodyParser.hs @@ -55,12 +55,12 @@ nodeListToList l = do parsePostBody :: Text -> IO [ PostPart ] parsePostBody htmlString = do Just doc <- currentDocument + container <- createElement doc ("div" :: Text) -- Set the innerHTML of the container to the HTML string setInnerHTML container htmlString - -- Iterate over the newly created elements in the container children <- getChildNodes container parseNodeList children diff --git a/src/Component/BodyRender.hs b/src/Component/BodyRender.hs new file mode 100644 index 0000000..c59f267 --- /dev/null +++ b/src/Component/BodyRender.hs @@ -0,0 +1,72 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Component.BodyRender where + +import Miso + ( text + , href_ + , a_ + , View + , target_ + , br_ + , span_ + , class_ + , strong_ + , u_ + , em_ + , s_ + ) + +import BodyParser (PostPart (..)) + +{- + - This is the inverse of parsePostBody from BodyParser except + - that the output is a miso View and not Text. It might be + - worth trying to use quickcheck to verify the bijection between + - Text and DOM by creating random PostParts and seeing if + - ((parsePostBody . render) parts == parts) + - + - (is there an easy way to render a miso View?, that's what's missing + - a f :: View a -> Text) + -} +render :: [ PostPart ] -> [ View a ] +render = map renderPostPart + +renderPostPart :: PostPart -> View a +renderPostPart (SimpleText txt) = text txt +renderPostPart (PostedUrl u) = + a_ + [ href_ u + , target_ "_blank" + ] + [ text u ] +renderPostPart Skip = br_ [] +renderPostPart (Quote url) = + a_ + [ href_ url ] + [ text url ] + +renderPostPart (GreenText parts) = + span_ [ class_ "quote" ] (render parts) + +renderPostPart (OrangeText parts) = + span_ [ class_ "orangeQuote" ] (render parts) + +renderPostPart (RedText parts) = + span_ [ class_ "heading" ] (render parts) + +renderPostPart (Spoiler parts) = + span_ [ class_ "spoiler" ] (render parts) + +renderPostPart (Bold parts) = + strong_ [] (render parts) + +renderPostPart (Underlined parts) = + u_ [] (render parts) + +renderPostPart (Italics parts) = + em_ [] (render parts) + +renderPostPart (Strikethrough parts) = + s_ [] (render parts) + diff --git a/src/Component/ThreadView.hs b/src/Component/ThreadView.hs index ea246be..1d868d2 100644 --- a/src/Component/ThreadView.hs +++ b/src/Component/ThreadView.hs @@ -20,13 +20,12 @@ import Miso , id_ , textProp , h2_ - , rawHtml , Attribute , (<#) , consoleLog ) -import Data.Maybe (maybeToList, catMaybes) +import Data.Maybe (catMaybes) import Miso.String (toMisoString) import GHCJS.DOM.Types (JSString) @@ -39,6 +38,7 @@ import qualified Network.ThreadType as Thread import Component.Thread.Files (files) import Component.Thread.Intro (intro) import BodyParser +import Component.BodyRender type PostWithBody = (Post, [ PostPart ]) @@ -86,7 +86,7 @@ view m = , div_ [ class_ "thread" ] ( (op_post thread_posts) - ++ map (reply m) (drop 1 thread_posts) + ++ map (reply m) (drop 1 (post_bodies m)) ) ] ) @@ -108,9 +108,6 @@ view m = board = Board.pathpart $ head $ Site.boards (site m) -body :: Post -> [ View a ] -body post = map (rawHtml . toMisoString) $ maybeToList $ Post.body post - op :: Model -> Post -> [ View a ] op m op_post = [ files (media_root m) (site m) op_post @@ -123,7 +120,7 @@ op m op_post = [ intro op_post , div_ [ class_ "body" ] - (body op_post) + (body $ post_bodies m) ] ] @@ -133,9 +130,13 @@ op m op_post = | length (Post.attachments op_post) > 1 = [ class_ "multifile" ] | otherwise = [] + body :: [ PostWithBody ] -> [ View a ] + body [] = [] + body x = render $ snd $ head x -reply :: Model -> Post -> View a -reply m post = div_ + +reply :: Model -> PostWithBody -> View a +reply m (post, parts) = div_ [ class_ "postcontainer" , id_ "pc477702" , textProp "data-board" "leftypol" @@ -148,6 +149,6 @@ reply m post = div_ , files (media_root m) (site m) post , div_ [ class_ "body" ] - (body post) + (render parts) ] ]