{-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE 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.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) -- timeline for a single day timelineDay :: TimelineParams -> Day -> [(Text, (DiffTime, DiffTime))] -> D.Diagram B timelineDay params day clocks = (D.strutY 5 D.===) $ (dateLabel D.===) $ D.scaleUToY height $ (timeticks D.|||) $ mconcat [ mconcat (map showClock clocks) , background ] where width = 140 * (totalHeight / height) * (params ^. tpColumnWidth) ticksWidth = 20 * (totalHeight / height) height = 700 * (params ^. tpColumnHeight) totalHeight :: Double totalHeight = 24*60 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 (0, -5)) , D.rect ticksWidth 1 & D.lw D.none ] & D.fc (D.sRGB24 150 150 150) & D.moveTo (D.p2 (0, totalHeight - fromIntegral hour * 60)) dateLabel :: D.Diagram B dateLabel = mconcat [ D.strutY 20 , D.alignedText 0 0.65 (formatTime defaultTimeLocale "%a, %d.%m.%Y" day) & D.font "DejaVu Sans" & D.fontSize 12 & D.moveTo (D.p2 (25, 0)) ] background :: D.Diagram B background = D.rect width totalHeight & D.lw D.none & D.fc (params ^. tpBackground) & D.moveOriginTo (D.p2 (-width/2, totalHeight/2)) & D.moveTo (D.p2 (0, totalHeight)) 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 = fromInteger $ diffTimeMinutes $ end - start bgboxColour = labelColour params label bgbox = D.rect 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 (-w/2+10, 0)) box = mconcat $ bool [] [label'] (fitLabelHeight params 14 h) ++ [bgbox] in box & D.moveOriginTo (D.p2 (-w/2, h/2)) & D.moveTo (D.p2 (0, totalHeight - fromInteger (diffTimeMinutes start))) -- timelines for several days, with top lists timelineDays :: TimelineParams -> [Day] -> [[(Text, (DiffTime, DiffTime))]] -> [[(Text, DiffTime)]] -> D.Diagram B timelineDays params days clocks topLists = 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 30 , 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 timelineReport :: TimelineParams -> Org -> TimelineOutput timelineReport params org = 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 (minimum (map cFrom c), 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