Replace dummy discussion widget with a real one

This commit is contained in:
fr33domlover 2016-05-19 15:49:39 +00:00
parent 93aeae36a8
commit cdfaec81f2
4 changed files with 83 additions and 17 deletions

View file

@ -20,12 +20,13 @@ where
import Prelude import Prelude
import Control.Arrow (second)
import Data.Graph.Inductive.Graph (mkGraph, lab') import Data.Graph.Inductive.Graph (mkGraph, lab')
import Data.Graph.Inductive.PatriciaTree (Gr) import Data.Graph.Inductive.PatriciaTree (Gr)
import Data.Graph.Inductive.Query.DFS (dffWith) import Data.Graph.Inductive.Query.DFS (dffWith)
import Data.Maybe (isNothing, mapMaybe) import Data.Maybe (isNothing, mapMaybe)
import Data.Tree (Tree (..), Forest) import Data.Tree (Forest)
import Database.Persist (Entity (..), selectList, (==.)) import Database.Esqueleto hiding (isNothing)
import Yesod.Persist.Core (runDB) import Yesod.Persist.Core (runDB)
import qualified Data.HashMap.Lazy as M (fromList, lookup) import qualified Data.HashMap.Lazy as M (fromList, lookup)
@ -34,29 +35,37 @@ import Data.Tree.Local (sortForestOn)
import Vervis.Foundation import Vervis.Foundation
import Vervis.Model import Vervis.Model
getMessages :: DiscussionId -> Handler [Entity Message] getMessages :: DiscussionId -> Handler [(Entity Message, Sharer)]
getMessages did = runDB $ selectList [MessageRoot ==. did] [] getMessages did = fmap (map $ second entityVal) $ runDB $
select $ from $ \ (message, person, sharer) -> do
where_ $
message ^. MessageRoot ==. val did &&.
message ^. MessageAuthor ==. person ^. PersonId &&.
person ^. PersonIdent ==. sharer ^. SharerId
return (message, sharer)
discussionTree :: [Entity Message] -> Forest (Entity Message) discussionTree :: [(Entity Message, Sharer)] -> Forest (Message, Sharer)
discussionTree messages = discussionTree mss =
let nodes = zip [1..] messages let numbered = zip [1..] mss
nodeMap = M.fromList $ map (\ (n, Entity mid _m) -> (mid, n)) nodes mkEntry n ((Entity mid _m), _s) = (mid, n)
mkEdge n (Entity _ m) = nodeMap = M.fromList $ map (uncurry mkEntry) numbered
mkEdge n (m, _s) =
case messageParent m of case messageParent m of
Nothing -> Nothing Nothing -> Nothing
Just mid -> Just mid ->
case M.lookup mid nodeMap of case M.lookup mid nodeMap of
Nothing -> error "message parent not in discussion" Nothing -> error "message parent not in discussion"
Just p -> Just (p, n, ()) Just p -> Just (p, n, ())
nodes = map (\ (n, (Entity _ m, s)) -> (n, (m, s))) numbered
edges = mapMaybe (uncurry mkEdge) nodes edges = mapMaybe (uncurry mkEdge) nodes
graph = mkGraph nodes edges :: Gr (Entity Message) () graph = mkGraph nodes edges :: Gr (Message, Sharer) ()
roots = [n | (n, Entity _ m) <- nodes, isNothing $ messageParent m] roots = [n | (n, (m, _s)) <- nodes, isNothing $ messageParent m]
in dffWith lab' roots graph in dffWith lab' roots graph
sortByTime :: Forest (Entity Message) -> Forest (Entity Message) sortByTime :: Forest (Message, Sharer) -> Forest (Message, Sharer)
sortByTime = sortForestOn $ messageCreated . entityVal sortByTime = sortForestOn $ messageCreated . fst
-- | Get the tree of messages in a given discussion, with siblings sorted from -- | Get the tree of messages in a given discussion, with siblings sorted from
-- old to new. -- old to new.
getDiscussion :: DiscussionId -> Handler (Forest (Entity Message)) getDiscussion :: DiscussionId -> Handler (Forest (Message, Sharer))
getDiscussion did = sortByTime . discussionTree <$> getMessages did getDiscussion did = sortByTime . discussionTree <$> getMessages did

View file

@ -20,10 +20,44 @@ where
import Prelude import Prelude
import Control.Monad.IO.Class (liftIO)
import Data.Foldable (traverse_)
import Data.Maybe (fromMaybe)
import Data.Text (Text)
import Data.Time.Clock (UTCTime, diffUTCTime, getCurrentTime)
import Data.Tree (Tree (..))
import Text.Cassius (cassiusFile)
import Yesod.Core.Handler (newIdent)
import Yesod.Core.Widget (whamlet, toWidget, handlerToWidget)
import Data.EventTime.Local (intervalToEventTime, showEventTime)
import Data.Time.Clock.Local ()
import Vervis.Discussion (getDiscussion)
import Vervis.Foundation import Vervis.Foundation
import Vervis.Model (DiscussionId) import Vervis.MediaType (MediaType (Markdown))
import Vervis.Model
import Vervis.Render (renderSourceT)
import Vervis.Settings (widgetFile) import Vervis.Settings (widgetFile)
messageW :: Sharer -> UTCTime -> UTCTime -> Text -> Widget
messageW sharer created now content =
$(widgetFile "discussion/widget/message")
messageTreeW :: Text -> UTCTime -> Tree (Message, Sharer) -> Widget
messageTreeW cReplies now t = go t
where
go (Node (message, sharer) trees) = do
messageW sharer (messageCreated message) now (messageContent message)
[whamlet|
<div .#{cReplies}>
$forall tree <- trees
^{go tree}
|]
discussionW :: DiscussionId -> Widget discussionW :: DiscussionId -> Widget
discussionW did = do discussionW did = do
$(widgetFile "discussion/widget/tree") forest <- handlerToWidget $ getDiscussion did
cReplies <- newIdent
now <- liftIO getCurrentTime
toWidget $(cassiusFile "templates/discussion/widget/tree.cassius")
traverse_ (messageTreeW cReplies now) forest

View file

@ -12,4 +12,10 @@ $# You should have received a copy of the CC0 Public Domain Dedication along
$# with this software. If not, see $# with this software. If not, see
$# <http://creativecommons.org/publicdomain/zero/1.0/>. $# <http://creativecommons.org/publicdomain/zero/1.0/>.
[[[ [TODO] the discussion system is still being developed ]]] <div>
<a href=@{PersonR $ sharerIdent sharer}>
#{fromMaybe (sharerIdent sharer) $ sharerName sharer}
<div>
#{showEventTime $ intervalToEventTime $ diffUTCTime now created}
<div>
^{renderSourceT Markdown content}

View file

@ -0,0 +1,17 @@
/* 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/>.
*/
.#{cReplies}
margin-left: 2em