Skip to content
This repository

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Fetching contributors…

Octocat-spinner-32-eaf2f5

Cannot retrieve contributors at this time

file 82 lines (73 sloc) 2.76 kb
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81
{-# LANGUAGE TemplateHaskell, QuasiQuotes, OverloadedStrings #-}
module Handler.ShowMap
    ( getShowMapR
    , getShowMapTopicR
    , loadTree
    , showTree
    , loadTreeNode
    ) where

import Wiki
import Handler.Topic (getTopicR)
import Util (renderContent)
import Database.Persist.GenericSql (SqlPersist)
import Text.Hamlet (HtmlUrl, hamlet)

data Tree = Tree
    { treeTopicId :: Maybe TopicId -- FIXME TMapNodeId
    , treeTitle :: Text
    , treeContent :: Maybe TopicContent
    , treeChildren :: [Tree]
    }

showTree :: Int -> [Tree] -> HtmlUrl WikiRoute
showTree depth trees = [hamlet|
$forall tree <- trees
    <section>
        $maybe tid <- treeTopicId tree
            <h1 #topic-#{toSinglePiece tid}>
                <a .topic-link href=@{TopicR tid}>#{treeTitle tree}
        $nothing
            <h1>#{treeTitle tree}
        $maybe c <- treeContent tree
            $maybe tid <- treeTopicId tree
                ^{renderContent tid (topicContentFormat c) (topicContentContent c)}
        ^{showTree (incr depth) $ treeChildren tree}
|]
  where
    incr 6 = 6
    incr i = i + 1

loadTree :: TMapId -> Handler [Tree]
loadTree = runDB . loadTree'

loadTree' :: TMapId -> SqlPersist (GGHandler sub Wiki IO) [Tree]
loadTree' tmid =
    selectList [TMapNodeMap ==. tmid, TMapNodeParent ==. Nothing] [Asc TMapNodePosition] >>= (fmap concat . mapM loadTreeNode)

loadTreeNode :: (TMapNodeId, TMapNode) -> SqlPersist (GGHandler sub Wiki IO) [Tree]
loadTreeNode (tmnid, tmn) = do
    case tMapNodeCmap tmn of
        Nothing -> do
            c <- selectList [TMapNodeParent ==. Just tmnid] [Asc TMapNodePosition] >>= mapM loadTreeNode
            title <-
                case tMapNodeCtopic tmn of
                    Nothing -> return ""
                    Just tid -> do
                        t <- get404 tid
                        return $ topicTitle t
            content <-
                case tMapNodeCtopic tmn of
                    Nothing -> return Nothing
                    Just tid -> do
                        x <- selectList [TopicContentTopic ==. tid] [Desc TopicContentChanged, LimitTo 1]
                        case x of
                            (_, y):_ -> return $ Just y
                            [] -> return Nothing
            return [Tree
                { treeTopicId = tMapNodeCtopic tmn
                , treeTitle = title
                , treeChildren = concat c
                , treeContent = content
                }]
        Just tmid -> loadTree' tmid

getShowMapR :: TMapId -> Handler RepHtml
getShowMapR tmid = do
    tree <- loadTree tmid
    defaultLayout $(widgetFile "show-map")

getShowMapTopicR :: TMapId -> TopicId -> Handler RepHtml
getShowMapTopicR _tmid topicid = getTopicR topicid
Something went wrong with that request. Please try again.