{-# LANGUAGE RankNTypes, ScopedTypeVariables, TemplateHaskell #-} -- | Timeline reporting output. Prouces a svg with columns. module OrgStat.Outputs.Timeline ( processTimeline ) where import Data.Colour.CIE (luminance) import Data.List (lookup, nub) import qualified Data.List as L import qualified Data.Text as T import Data.Time (Day, DiffTime, LocalTime(..), defaultTimeLocale, formatTime, timeOfDayToTime) import Diagrams.Backend.SVG (B) import qualified Diagrams.Prelude as D import qualified Prelude import Text.Printf (printf) import Universum import OrgStat.Ast (Clock(..), Org(..), orgClocks, traverseTree) import OrgStat.Outputs.Types (TimelineOutput(..), TimelineParams, tpBackground, tpColorSalt, tpColumnHeight, tpColumnWidth, tpLegend, tpTopDay) import OrgStat.Util (addLocalTime, hashColour) ---------------------------------------------------------------------------- -- Processing clocks ---------------------------------------------------------------------------- -- [(a, [b])] -> [(a, b)] allClocks :: [(Text, [(DiffTime, DiffTime)])] -> [(Text, (DiffTime, DiffTime))] allClocks tasks = do (label, clocks) <- tasks clock <- clocks pure (label, clock) -- separate list for each day selectDays :: [Day] -> [(Text, [Clock])] -> [[(Text, [(DiffTime, DiffTime)])]] selectDays days tasks = flip map days $ \day -> filter (not . null . snd) $ map (second (selectDay day)) tasks where selectDay :: Day -> [Clock] -> [(DiffTime, DiffTime)] selectDay day clocks = do Clock (LocalTime dFrom tFrom) (LocalTime dTo tTo) <- clocks guard $ any (== day) [dFrom, dTo] let tFrom' = if dFrom == day then timeOfDayToTime tFrom else fromInteger 0 let tTo' = if dTo == day then timeOfDayToTime tTo else fromInteger (24*60*60) pure (tFrom', tTo') -- total time for each task totalTimes :: [(Text, [(DiffTime, DiffTime)])] -> [(Text, DiffTime)] totalTimes tasks = map (second clocksSum) tasks where clocksSum :: [(DiffTime, DiffTime)] -> DiffTime clocksSum clocks = sum $ map (\(start, end) -> end - start) clocks -- list of leaves orgToList :: Org -> [(Text, [Clock])] orgToList = orgToList' "" where orgToList' :: Text -> Org -> [(Text, [Clock])] orgToList' _pr org = --let path = pr <> "/" <> _orgTitle org let path = _orgTitle org in (path, _orgClocks org) : concatMap (orgToList' path) (_orgSubtrees org) ---------------------------------------------------------------------------- -- Drawing ---------------------------------------------------------------------------- diffTimeSeconds :: DiffTime -> Integer diffTimeSeconds time = floor $ toRational time diffTimeMinutes :: DiffTime -> Integer diffTimeMinutes time = diffTimeSeconds time `div` 60 -- diffTimeHours :: DiffTime -> Integer -- diffTimeHours time = diffTimeMinutes time `div` 60 labelColour :: TimelineParams -> Text -> D.Colour Double labelColour params _label = hashColour (params ^. tpColorSalt) _label -- | Returns if the label is to be shown. Second param is font-related -- heuristic constant, third is length of interval. fitLabelHeight :: TimelineParams -> Double -> Double -> Bool fitLabelHeight params n h = h >= (params ^. tpColumnHeight) * n -- | Decides by , width of column -- and string, should it be truncated. And returns modified string. fitLabelWidth :: TimelineParams -> Double -> Text -> Text fitLabelWidth params n s = if T.length s <= toTake then s else T.take toTake s <> ".." where toTake = floor $ n * ((params ^. tpColumnWidth) ** 1.2) -- rectangle with origin in the top-left corner topLeftRect :: Double -> Double -> D.Diagram B topLeftRect w h = D.rect w h & D.moveOriginTo (D.p2 (-w/2, h/2)) -- timeline for a single day timelineDay :: TimelineParams -> Day -> [(Text, (DiffTime, DiffTime))] -> D.Diagram B timelineDay params day clocks = mconcat [ timeticks , dateLabel , mconcat (map showClock clocks) , clocksBackground ] where width = 140 * (params ^. tpColumnWidth) ticksWidth = 20 height = 700 * (params ^. tpColumnHeight) timeticks :: D.Diagram B timeticks = mconcat $ flip map [(0::Int)..23] $ \hour -> mconcat [ D.alignedText 0.5 1 (show hour) & D.font "DejaVu Sans" & D.fontSize 8 & D.moveTo (D.p2 (ticksWidth/2, -5)) & D.fc (D.sRGB24 150 150 150) , D.strokeT (D.p2 (0,0) D.~~ (D.p2 (ticksWidth, 0))) & D.translateY (-0.5) & D.lwO 1 & D.lc (D.sRGB24 200 200 200) ] & D.moveTo (D.p2 (0, negate $ fromInteger . round $ height * (fromIntegral hour / 24))) & D.moveOriginTo (D.p2 (ticksWidth, 0)) dateLabel :: D.Diagram B dateLabel = mconcat [ D.strutY 20 , D.alignedText 0.5 0 (formatTime defaultTimeLocale "%a, %d.%m.%Y" day) & D.font "DejaVu Sans" & D.fontSize 12 & D.moveOriginTo (D.p2 (-width/2, 0)) ] clocksBackground :: D.Diagram B clocksBackground = topLeftRect width height & D.lw D.none & D.fc (params ^. tpBackground) contrastFrom c = if luminance c < 0.14 then D.sRGB24 224 224 224 else D.black showClock :: (Text, (DiffTime, DiffTime)) -> D.Diagram B showClock (label, (start, end)) = let w = width h = (* height) $ fromInteger (diffTimeMinutes $ end - start) / (24*60) y = (* height) $ fromInteger (diffTimeMinutes start) / (24*60) bgboxColour = labelColour params label bgbox = topLeftRect w h & D.lw D.none & D.fc bgboxColour label' = D.alignedText 0 0.5 (T.unpack $ fitLabelWidth params 21 label) & D.font "DejaVu Sans" & D.fontSize 10 & D.fc (contrastFrom bgboxColour) & D.moveTo (D.p2 (5, -h/2)) box = mconcat $ bool [] [label'] (fitLabelHeight params 12 h) ++ [bgbox] in box & D.moveTo (D.p2 (0, -y)) -- timelines for several days, with top lists timelineDays :: TimelineParams -> [Day] -> [[(Text, (DiffTime, DiffTime))]] -> [[(Text, DiffTime)]] -> D.Diagram B timelineDays params days clocks topLists = (D.strutY 10 D.===) $ D.hcat $ flip map (days `zip` (clocks `zip` topLists)) $ \(day, (dayClocks, topList)) -> D.vsep 5 [ timelineDay params day dayClocks , taskList params topList True ] -- task list, with durations and colours taskList :: TimelineParams -> [(Text, DiffTime)] -> Bool -> D.Diagram B taskList params labels fit = D.vsep 5 $ map oneTask $ reverse $ sortOn snd labels where oneTask :: (Text, DiffTime) -> D.Diagram B oneTask (label, time) = D.hsep 3 [ D.alignedText 1 0.5 (showTime time) & D.font "DejaVu Sans" & D.fontSize 10 & D.translateX 20 , D.rect 12 12 & D.fc (labelColour params label) & D.lw D.none , D.alignedText 0 0.5 (T.unpack $ bool label (fitLabelWidth params 18 label) fit) & D.font "DejaVu Sans" & D.fontSize 10 ] showTime :: DiffTime -> Prelude.String showTime time = printf "%d:%02d" hours minutes where (hours, minutes) = diffTimeMinutes time `divMod` 60 emptyReport :: D.Diagram B emptyReport = mconcat [ D.strutY 20 , D.strutX 40 , D.alignedText 0.5 0 "empty" & D.font "DejaVu Sans" & D.fontSize 8 ] timelineReport :: TimelineParams -> Org -> TimelineOutput timelineReport params org = if (null $ concat $ org ^.. traverseTree . orgClocks) then TimelineOutput $ D.vsep 30 [emptyReport] else TimelineOutput pic where lookupDef :: Eq a => b -> a -> [(a, b)] -> b lookupDef d a xs = fromMaybe d $ lookup a xs -- These two should be taken from the Org itself (min/max). (from,to) = let c = concat $ org ^.. traverseTree . orgClocks in (L.minimum (map cFrom c), L.maximum (map cTo c)) -- period to show. Right border is -1min, we assume it's non-inclusive daysToShow = [localDay from .. localDay ((negate 120 :: Int) `addLocalTime` to)] -- unfiltered leaves tasks :: [(Text, [Clock])] tasks = orgToList org -- tasks from the given period, split by days byDay :: [[(Text, [(DiffTime, DiffTime)])]] byDay = selectDays daysToShow tasks -- total durations for each task, split by days byDayDurations :: [[(Text, DiffTime)]] byDayDurations = map totalTimes byDay -- total durations for the whole period allDaysDurations :: [(Text, DiffTime)] allDaysDurations = let allTasks = nub $ map fst $ concat byDayDurations in flip map allTasks $ \task -> (task,) $ sum $ flip map byDayDurations $ \durations -> lookupDef (fromInteger 0) task durations -- split clocks clocks :: [[(Text, (DiffTime, DiffTime))]] clocks = map allClocks byDay -- top list for each day topLists :: [[(Text, DiffTime)]] topLists = map (take (params ^. tpTopDay) . reverse . sortOn (\(_task, time) -> time)) byDayDurations optLegend | params ^. tpLegend = [taskList params allDaysDurations False] | otherwise = [] pic = D.vsep 30 $ [ timelineDays params daysToShow clocks topLists ] ++ optLegend processTimeline :: TimelineParams -> Org -> TimelineOutput processTimeline params org = timelineReport params org