Ticket tree widget
This commit is contained in:
parent
fe7aeb5162
commit
b5014a0f5f
3 changed files with 95 additions and 4 deletions
|
@ -17,21 +17,27 @@ module Vervis.Widget.Ticket
|
|||
( TicketSummary (..)
|
||||
, ticketDepW
|
||||
, ticketSummaryW
|
||||
, ticketTreeVW
|
||||
, ticketTreeDW
|
||||
)
|
||||
where
|
||||
|
||||
import Prelude
|
||||
|
||||
import Control.Arrow ((***))
|
||||
import Control.Arrow ((&&&), (***))
|
||||
import Data.HashMap.Lazy (HashMap)
|
||||
import Data.Maybe (mapMaybe)
|
||||
import Data.Text (Text)
|
||||
import Data.Time.Clock (UTCTime)
|
||||
import Yesod.Core.Handler (getCurrentRoute)
|
||||
import Yesod.Core (newIdent)
|
||||
import Yesod.Core (MonadHandler, newIdent)
|
||||
import Yesod.Core.Handler (getCurrentRoute, getRequest, YesodRequest (..))
|
||||
import Yesod.Core.Widget (whamlet)
|
||||
|
||||
import qualified Data.HashMap.Lazy as M (toList)
|
||||
import qualified Data.Text as T (pack, unpack)
|
||||
import qualified Data.Text as T (null, pack, unpack)
|
||||
import qualified Data.Text.Read as TR (decimal)
|
||||
|
||||
import Data.Graph.DirectedAcyclic.View.Tree
|
||||
import Vervis.Foundation
|
||||
import Vervis.Model
|
||||
import Vervis.Model.Ident
|
||||
|
@ -68,3 +74,54 @@ ticketSummaryW shr prj ts mcs = do
|
|||
mparams = map (tshow *** tshow) . M.toList <$> mcs
|
||||
mroute <- getCurrentRoute
|
||||
$(widgetFile "ticket/widget/summary")
|
||||
|
||||
-- I'm noticing a pattern. A problem. Some of my widget functions take data and
|
||||
-- directly represent it in HTML. Others take some other more general
|
||||
-- structures, then pick the relevant pieces and generate HTML. Others involve
|
||||
-- IO actions, especially DB access.
|
||||
--
|
||||
-- So here's an idea to try. Instead of the W suffix, have 3 suffixes:
|
||||
--
|
||||
-- * /VW/ - view widget, direct data to HTML conversion
|
||||
-- * /DW/ - data widget, takes more general data and picks some for the view
|
||||
-- * /PW/ - persistent widget, takes data from filesystem or DB
|
||||
ticketTreeVW
|
||||
:: ShrIdent
|
||||
-> PrjIdent
|
||||
-> Text
|
||||
-> DagViewTree TicketSummary (TicketSummary, HashMap Int Int)
|
||||
-> Widget
|
||||
ticketTreeVW shr prj cDeps t = go t
|
||||
where
|
||||
summary = ticketSummaryW shr prj
|
||||
go (FullNode ts trees) = do
|
||||
summary ts Nothing
|
||||
[whamlet|
|
||||
<div .#{cDeps}>
|
||||
$forall tree <- trees
|
||||
^{go tree}
|
||||
|]
|
||||
go (LinkNode (ts, cs)) = summary ts (Just cs)
|
||||
|
||||
-- | In the request's GET parameters, find ones of the form @N=M@ where N and M
|
||||
-- are integers. Return a list of pairs corresponding to those parameters.
|
||||
getParentChoices :: MonadHandler m => m [(Int, Int)]
|
||||
getParentChoices = mapMaybe readInts . reqGetParams <$> getRequest
|
||||
where
|
||||
readInts (ct, pt) =
|
||||
case (TR.decimal ct, TR.decimal pt) of
|
||||
(Right (c, cr), Right (p, pr)) ->
|
||||
if T.null cr && T.null pr
|
||||
then Just (c, p)
|
||||
else Nothing
|
||||
_ -> Nothing
|
||||
|
||||
ticketTreeDW
|
||||
:: ShrIdent -> PrjIdent -> [TicketSummary] -> [(Int, Int)] -> Widget
|
||||
ticketTreeDW shr prj summaries deps = do
|
||||
cDeps <- newIdent
|
||||
choices <- getParentChoices
|
||||
let nodes = map (tsNumber &&& id) summaries
|
||||
oneTree = ticketTreeVW shr prj cDeps
|
||||
forest = map oneTree $ dagViewTree nodes deps choices
|
||||
$(widgetFile "ticket/widget/tree")
|
||||
|
|
17
templates/ticket/widget/tree.cassius
Normal file
17
templates/ticket/widget/tree.cassius
Normal 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/>.
|
||||
*/
|
||||
|
||||
.#{cDeps}
|
||||
margin-left: 2em
|
17
templates/ticket/widget/tree.hamlet
Normal file
17
templates/ticket/widget/tree.hamlet
Normal 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/>.
|
||||
|
||||
<div>
|
||||
$forall tree <- forest
|
||||
^{tree}
|
Loading…
Reference in a new issue