diff --git a/chandlr.cabal b/chandlr.cabal index c3146d9..e653958 100644 --- a/chandlr.cabal +++ b/chandlr.cabal @@ -75,6 +75,7 @@ executable chandlr Component.ThreadView Component.Thread.Files Component.Thread.Intro + Component.Thread.Model Component.BodyRender Routes Common.AttachmentType diff --git a/src/Component/BodyRender.hs b/src/Component/BodyRender.hs index ae6ef08..b634485 100644 --- a/src/Component/BodyRender.hs +++ b/src/Component/BodyRender.hs @@ -23,6 +23,9 @@ import Miso.String (toMisoString, fromMisoString) import Text.Parsec (ParseError) import BodyParser (PostPart (..)) import QuoteLinkParser +import qualified Component.Thread.Model as Model +import qualified Network.SiteType as Site +import qualified Network.ThreadType as Thread {- - This is the inverse of parsePostBody from BodyParser except @@ -34,21 +37,21 @@ import QuoteLinkParser - (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 +render :: Model.Model -> [ PostPart ] -> [ View a ] +render m = map (renderPostPart m) -renderPostPart :: PostPart -> View a -renderPostPart (SimpleText txt) = text txt -renderPostPart (PostedUrl u) = +renderPostPart :: Model.Model -> PostPart -> View a +renderPostPart _ (SimpleText txt) = text txt +renderPostPart _ (PostedUrl u) = a_ [ href_ u , target_ "_blank" ] [ text u ] -renderPostPart Skip = br_ [] +renderPostPart _ Skip = br_ [] -renderPostPart (Quote url) = elems parse_result +renderPostPart m (Quote url) = elems parse_result where parse_result = parseURL $ fromMisoString url @@ -64,27 +67,27 @@ renderPostPart (Quote url) = elems parse_result [ href_ url ] [ text url ] -renderPostPart (GreenText parts) = - span_ [ class_ "quote" ] (render parts) +renderPostPart m (GreenText parts) = + span_ [ class_ "quote" ] (render m parts) -renderPostPart (OrangeText parts) = - span_ [ class_ "orangeQuote" ] (render parts) +renderPostPart m (OrangeText parts) = + span_ [ class_ "orangeQuote" ] (render m parts) -renderPostPart (RedText parts) = - span_ [ class_ "heading" ] (render parts) +renderPostPart m (RedText parts) = + span_ [ class_ "heading" ] (render m parts) -renderPostPart (Spoiler parts) = - span_ [ class_ "spoiler" ] (render parts) +renderPostPart m (Spoiler parts) = + span_ [ class_ "spoiler" ] (render m parts) -renderPostPart (Bold parts) = - strong_ [] (render parts) +renderPostPart m (Bold parts) = + strong_ [] (render m parts) -renderPostPart (Underlined parts) = - u_ [] (render parts) +renderPostPart m (Underlined parts) = + u_ [] (render m parts) -renderPostPart (Italics parts) = - em_ [] (render parts) +renderPostPart m (Italics parts) = + em_ [] (render m parts) -renderPostPart (Strikethrough parts) = - s_ [] (render parts) +renderPostPart m (Strikethrough parts) = + s_ [] (render m parts) diff --git a/src/Component/Thread/Model.hs b/src/Component/Thread/Model.hs new file mode 100644 index 0000000..cc9bb37 --- /dev/null +++ b/src/Component/Thread/Model.hs @@ -0,0 +1,15 @@ +module Component.Thread.Model where + +import GHCJS.DOM.Types (JSString) +import Network.SiteType (Site) +import Network.PostType (Post) +import BodyParser (PostPart) + +type PostWithBody = (Post, [ PostPart ]) + +data Model = Model + { site :: Site + , media_root :: JSString + , post_bodies :: [ PostWithBody ] + } deriving Eq + diff --git a/src/Component/ThreadView.hs b/src/Component/ThreadView.hs index ace2e39..95e5689 100644 --- a/src/Component/ThreadView.hs +++ b/src/Component/ThreadView.hs @@ -37,17 +37,10 @@ import qualified Network.BoardType as Board import qualified Network.ThreadType as Thread import Component.Thread.Files (files) import Component.Thread.Intro (intro) +import Component.Thread.Model import BodyParser import qualified Component.BodyRender as Body -type PostWithBody = (Post, [ PostPart ]) - -data Model = Model - { site :: Site - , media_root :: JSString - , post_bodies :: [ PostWithBody ] - } deriving Eq - initialModel :: JSString -> Site -> Model initialModel mroot s = Model { site = s @@ -127,7 +120,7 @@ op m op_post = where body :: [ PostWithBody ] -> [ View a ] body [] = [] - body x = Body.render $ snd $ head x + body x = Body.render m $ snd $ head x multi :: Post -> [ Attribute a ] @@ -143,6 +136,9 @@ reply m (post, parts) = div_ , textProp "data-board" "leftypol" ] [ div_ + [ class_ "sidearrows" ] + [ text ">>" ] + , div_ ( [ class_ "post reply" , id_ "reply_477702" @@ -152,6 +148,6 @@ reply m (post, parts) = div_ , files (media_root m) (site m) post , div_ [ class_ "body" ] - (Body.render parts) + (Body.render m parts) ] ]