Render body elements

- TODO: quote links need to be parsed, display properly and
  handled

chandlr.cabal

@@ -75,6 +75,7 @@ executable chandlr
                       Component.ThreadView
                       Component.Thread.Files
                       Component.Thread.Intro
+                      Component.BodyRender
                       Routes
                       Common.AttachmentType
                       BodyParser

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

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)
+

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)
         ]
     ]