vervis/src/Vervis/Discussion.hs

{- This file is part of Vervis.
 -
 - Written in 2016 by fr33domlover <fr33domlover@riseup.net>.
 -
 - ♡ Copying is an act of love. Please copy, reuse and share.
 -
 - The author(s) have dedicated all copyright and related and neighboring
 - rights to this software to the public domain worldwide. This software is
 - distributed without any warranty.
 -
 - You should have received a copy of the CC0 Public Domain Dedication along
 - with this software. If not, see
 - <http://creativecommons.org/publicdomain/zero/1.0/>.
 -}

module Vervis.Discussion
    ( getDiscussion
    )
where

import Prelude

import Data.Graph.Inductive.Graph (mkGraph, lab')
import Data.Graph.Inductive.PatriciaTree (Gr)
import Data.Graph.Inductive.Query.DFS (dffWith)
import Data.Maybe (isNothing, mapMaybe)
import Data.Tree (Tree (..), Forest)
import Database.Persist (Entity (..), selectList, (==.))
import Yesod.Persist.Core (runDB)

import qualified Data.HashMap.Lazy as M (fromList, lookup)

import Data.Tree.Local (sortForestOn)
import Vervis.Foundation
import Vervis.Model

getMessages :: DiscussionId -> Handler [Entity Message]
getMessages did = runDB $ selectList [MessageRoot ==. did] []

discussionTree :: [Entity Message] -> Forest (Entity Message)
discussionTree messages =
    let nodes = zip [1..] messages
        nodeMap = M.fromList $ map (\ (n, Entity mid _m) -> (mid, n)) nodes
        mkEdge n (Entity _ m) =
            case messageParent m of
                Nothing  -> Nothing
                Just mid ->
                    case M.lookup mid nodeMap of
                        Nothing -> error "message parent not in discussion"
                        Just p  -> Just (p, n, ())
        edges = mapMaybe (uncurry mkEdge) nodes
        graph = mkGraph nodes edges :: Gr (Entity Message) ()
        roots = [n | (n, Entity _ m) <- nodes, isNothing $ messageParent m]
    in  dffWith lab' roots graph

sortByTime :: Forest (Entity Message) -> Forest (Entity Message)
sortByTime = sortForestOn $ messageCreated . entityVal

-- | Get the tree of messages in a given discussion, with siblings sorted from
-- old to new.
getDiscussion :: DiscussionId -> Handler (Forest (Entity Message))
getDiscussion did = sortByTime . discussionTree <$> getMessages did