Backlinks aka mentions

chandlr.cabal

@@ -81,6 +81,7 @@ executable chandlr
                       Common.AttachmentType
                       BodyParser
                       QuoteLinkParser
+                      PostPartType
 
 
     -- LANGUAGE extensions used by modules in this package.

default.nix

@@ -13,6 +13,7 @@ let
       pkgs.haskellPackages.cabal-install
       new_pkgs.haskellPackages.ghcjs-dom
       new_pkgs.haskellPackages.miso-from-html
+      new_pkgs.haskellPackages.hlint
     ];
   });
 

html/mentions.html

@@ -0,0 +1,4 @@
+<span class="mentioned unimportant">
+  <a class="mentioned-476665" href="#476665">>>476665</a>
+  <a class="mentioned-476666" href="#476666">>>476666</a>
+</span>

src/BodyParser.hs

@@ -2,13 +2,18 @@
 {-# LANGUAGE PackageImports #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE MultiWayIf #-}
+{-# LANGUAGE RecordWildCards #-}
 
 module BodyParser
     ( PostPart (..)
     , parsePostBody
+    , collectBacklinks
+    , Backlinks
     ) where
 
 import Data.Maybe (catMaybes)
+import Data.Map (Map)
+import qualified Data.Map as Map
 import GHCJS.DOM (currentDocument)
 import GHCJS.DOM.Types
     ( Element (..)
@@ -24,30 +29,13 @@ import GHCJS.DOM.JSFFI.Generated.DOMTokenList (contains)
 import Data.Text (Text)
 import Miso (consoleLog)
 import Miso.String (fromMisoString)
-import Text.Parsec (ParseError)
+import qualified Network.PostType as Post
+import Component.Thread.Model (PostWithBody)
 
+import PostPartType
 import QuoteLinkParser
 
 
-data PostPart
-    = SimpleText JSString
-    | PostedUrl JSString
-    | Skip
-    | Quote (Either ParseError ParsedURL)
-        -- Quotes don't seem to be able to be spoilered
-        -- board links (which appear as quotes but start with >>>) break the tag
-    | GreenText     [ PostPart ]
-    | OrangeText    [ PostPart ]
-    | RedText       [ PostPart ]
-    | Spoiler       [ PostPart ]
-    -- you can't seem to spoiler greentext
-    | Bold          [ PostPart ]
-    | Underlined    [ PostPart ]
-    | Italics       [ PostPart ]
-    | Strikethrough [ PostPart ]
-    deriving (Show, Eq)
-
-
 nodeListToList :: NodeList -> IO [ Node ]
 nodeListToList l = do
   len <- NodeList.getLength l
@@ -157,3 +145,27 @@ parseS :: Element -> IO PostPart
 parseS element
     = parseChildNodes element
     >>= return . Strikethrough
+
+type Backlinks = Map Integer [Post.Post]
+
+collectBacklinks :: [PostWithBody] -> Backlinks
+collectBacklinks xs = foldr insertElement Map.empty xs
+  where
+    insertElement :: PostWithBody -> Backlinks -> Backlinks
+    insertElement (post, body) acc = foldr insertPost acc (quotedPosts body)
+      where
+        insertPost postId = Map.insertWith (++) postId [post]
+
+
+quotedPosts :: [ PostPart ] -> [ Integer ]
+quotedPosts [] = []
+quotedPosts (Quote (Right (ParsedURL { postId = Just p })) : xs) = [p] ++ quotedPosts xs
+quotedPosts ((GreenText     xs) : xxs) = quotedPosts xs ++ quotedPosts xxs
+quotedPosts ((OrangeText    xs) : xxs) = quotedPosts xs ++ quotedPosts xxs
+quotedPosts ((RedText       xs) : xxs) = quotedPosts xs ++ quotedPosts xxs
+quotedPosts ((Spoiler       xs) : xxs) = quotedPosts xs ++ quotedPosts xxs
+quotedPosts ((Bold          xs) : xxs) = quotedPosts xs ++ quotedPosts xxs
+quotedPosts ((Underlined    xs) : xxs) = quotedPosts xs ++ quotedPosts xxs
+quotedPosts ((Italics       xs) : xxs) = quotedPosts xs ++ quotedPosts xxs
+quotedPosts ((Strikethrough xs) : xxs) = quotedPosts xs ++ quotedPosts xxs
+quotedPosts _ = []

src/Component/BodyRender.hs

@@ -16,6 +16,7 @@ import Miso
     , u_
     , em_
     , s_
+    , small_
     )
 
 import Miso.String (toMisoString)
@@ -29,6 +30,8 @@ import QuoteLinkParser
 import qualified Component.Thread.Model as Model
 import qualified Network.SiteType as Site
 import qualified Network.BoardType as Board
+import qualified Network.ThreadType as Thread
+import qualified Network.PostType as Post
 
 {-
  - This is the inverse of parsePostBody from BodyParser except
@@ -77,15 +80,24 @@ renderPostPart m (Quote parse_result) = elems parse_result
                     else
                         a_
                             [ href_ u ]
-                            [ text $ ">>" <> post_id ]
+                            $
+                            (text $ ">>" <> post_id)
+                            :
+                            if pid == op_id
+                            then [ small_ [] [ " (OP)" ] ]
+                            else []
 
             where
                 linked_board = toMisoString $ boardName p
 
-                post_id = toMisoString $ show $ fromJust $ postId p
+                pid = fromJust $ postId p
+
+                post_id = toMisoString $ show pid
 
                 current_board = toMisoString $ Board.pathpart $ head $ Site.boards (Model.site m)
 
+                op_id = Post.board_post_id $ head $ Thread.posts $ head $ Board.threads $ head $ Site.boards (Model.site m)
+
 
         full_url :: ParsedURL -> Maybe JSString
         full_url ParsedURL {..} = do

src/Component/Thread/Intro.hs

@@ -14,6 +14,7 @@ import Miso
   , time_
   )
 
+import qualified Data.Map as Map
 import Data.Text (Text, pack)
 import GHCJS.DOM.Types (JSString)
 import Data.Foldable (toList)
@@ -29,6 +30,7 @@ import Network.BoardType (Board)
 import qualified Network.BoardType as Board
 import qualified Network.ThreadType as Thread
 import Network.ThreadType (Thread)
+import BodyParser (Backlinks)
 
 
 formatUTC :: UTCTime -> JSString
@@ -36,8 +38,8 @@ formatUTC time = toMisoString $
     formatTime defaultTimeLocale "%Y-%m-%d (%a) %T" time
 
 
-intro :: Site -> Board -> Thread -> Post -> UTCTime -> View a
+intro :: Site -> Board -> Thread -> Post -> Backlinks -> UTCTime -> View a
-intro site board thread post current_time = span_
+intro site board thread post backlinks current_time = span_
   [ class_ "intro" ]
   ( subject ++
     [ " "
@@ -59,6 +61,7 @@ intro site board thread post current_time = span_
         , href_ $ toMisoString $ post_url <> "#q" <> b_post_id
         ][ text $ toMisoString $ b_post_id ]
     ]
+    ++ mentions
   )
 
   where
@@ -85,6 +88,27 @@ intro site board thread post current_time = span_
     b_post_id :: Text
     b_post_id = pack $ show $ Post.board_post_id post
 
+    mentions :: [ View a ]
+    mentions =
+        case Map.lookup (Post.board_post_id post) backlinks of
+            Nothing -> []
+            Just [] -> []
+            Just xs -> span_
+                [ class_ "mentioned unimportant" ]
+                (map mention xs)
+                : []
+
+    mention :: Post -> View a
+    mention p =
+        a_
+            [ href_ $ "#" <> bpid
+            ]
+            [ text $ ">>" <> bpid ]
+
+        where
+            bpid :: JSString
+            bpid = toMisoString $ show $ Post.board_post_id p
+
 
 -- Convert UTCTime to a human-readable string
 timeAgo :: UTCTime -> UTCTime -> String

src/Component/Thread/Model.hs

@@ -3,7 +3,7 @@ module Component.Thread.Model where
 import GHCJS.DOM.Types (JSString)
 import Network.SiteType (Site)
 import Network.PostType (Post)
-import BodyParser (PostPart)
+import PostPartType (PostPart)
 import Data.Time.Clock (UTCTime)
 
 type PostWithBody = (Post, [ PostPart ])

src/Component/ThreadView.hs

@@ -89,7 +89,7 @@ view m =
         , div_
             [ class_ "thread" ]
             (  (op_post thread_posts)
-            ++ map (reply m) (drop 1 (post_bodies m))
+            ++ map (reply m backlinks) (drop 1 (post_bodies m))
             )
         ]
     )
@@ -101,9 +101,12 @@ view m =
                 concatMap (Board.threads) $
                     Site.boards (site m)
 
+        backlinks :: Backlinks
+        backlinks = collectBacklinks (post_bodies m)
+
         op_post :: [ Post ] -> [ View a ]
         op_post [] = [ h2_ [] [ "There's nothing here" ] ]
-        op_post (x:_) = op m x
+        op_post (x:_) = op m x backlinks
 
         title :: JSString
         title = toMisoString $ (Site.name $ site m) <> " /" <> board <> "/"
@@ -111,8 +114,8 @@ view m =
         board = Board.pathpart $ head $ Site.boards (site m)
 
 
-op :: Model -> Post -> [ View a ]
+op :: Model -> Post -> Backlinks -> [ View a ]
-op m op_post =
+op m op_post backlinks =
     [ files (media_root m) site_ op_post
     , div_
         (
@@ -120,7 +123,7 @@ op m op_post =
             , id_ $ toMisoString $ show $ Post.board_post_id op_post
             ] ++ multi op_post
         )
-        [ intro site_ board thread op_post $ current_time m
+        [ intro site_ board thread op_post backlinks $ current_time m
         , div_
             [ class_ "body" ]
             (body $ post_bodies m)
@@ -148,8 +151,8 @@ multi post
     | otherwise = []
 
 
-reply :: Model -> PostWithBody -> View a
+reply :: Model -> Backlinks -> PostWithBody -> View a
-reply m (post, parts) = div_
+reply m backlinks (post, parts) = div_
     [ class_ "postcontainer"
     , id_ $ toMisoString $ show $ Post.board_post_id post
     ]
@@ -161,7 +164,7 @@ reply m (post, parts) = div_
             [ class_ "post reply"
             ] ++ multi post
         )
-        [ intro site_ board thread post $ current_time m
+        [ intro site_ board thread post backlinks $ current_time m
         , files (media_root m) site_ post
         , div_
             [ class_ "body" ]

src/PostPartType.hs

@@ -0,0 +1,26 @@
+module PostPartType where
+
+import GHCJS.DOM.Types (JSString)
+import Text.Parsec (ParseError)
+
+import QuoteLinkParser (ParsedURL)
+
+data PostPart
+    = SimpleText JSString
+    | PostedUrl JSString
+    | Skip
+    | Quote (Either ParseError ParsedURL)
+        -- Quotes don't seem to be able to be spoilered
+        -- board links (which appear as quotes but start with >>>) break the tag
+    | GreenText     [ PostPart ]
+    | OrangeText    [ PostPart ]
+    | RedText       [ PostPart ]
+    | Spoiler       [ PostPart ]
+    -- you can't seem to spoiler greentext
+    | Bold          [ PostPart ]
+    | Underlined    [ PostPart ]
+    | Italics       [ PostPart ]
+    | Strikethrough [ PostPart ]
+    deriving (Show, Eq)
+
+