module OrgStat.Report.Timeline
( TimelineParams (..)
, tpColorSalt
, tpLegend
, tpTopDay
, tpColumnWidth
, tpColumnHeight
, tpBackground
, processTimeline
) where
import Control.Lens (makeLenses)
import Data.Colour.CIE (luminance)
import Data.Default (Default (..))
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 (..))
import OrgStat.Report.Types (SVGImageReport (..))
import OrgStat.Util (addLocalTime, hashColour)
data TimelineParams = TimelineParams
{ _tpColorSalt :: !Int
, _tpLegend :: !Bool
, _tpTopDay :: !Int
, _tpColumnWidth :: !Double
, _tpColumnHeight :: !Double
, _tpBackground :: !(D.Colour Double)
} deriving (Show)
instance Default TimelineParams where
def = TimelineParams 0 True 5 1 1 (D.sRGB24 0xf2 0xf2 0xf2)
makeLenses ''TimelineParams
mergeParams :: TimelineParams -> TimelineParams -> TimelineParams
mergeParams lhs rhs = mods lhs
where
mods = foldr1 (.)
[ asId tpColorSalt
, asId tpLegend
, asId tpTopDay
, asId tpColumnWidth
, asId tpColumnHeight
, asId tpBackground ]
asId :: forall b. (Eq b) => Lens' TimelineParams b -> TimelineParams -> TimelineParams
asId l x =
if def ^. l == rhs ^. l
then x else x & l .~ (rhs ^. l)
instance Monoid TimelineParams where
mempty = def
mappend = mergeParams
allClocks :: [(Text, [(DiffTime, DiffTime)])] -> [(Text, (DiffTime, DiffTime))]
allClocks tasks = do
(label, clocks) <- tasks
clock <- clocks
pure (label, clock)
selectDays :: [Day] -> [(Text, [Clock])] -> [[(Text, [(DiffTime, DiffTime)])]]
selectDays days tasks =
foreach 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')
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
orgToList :: Org -> [(Text, [Clock])]
orgToList = orgToList' ""
where
orgToList' :: Text -> Org -> [(Text, [Clock])]
orgToList' _pr org =
let path = _orgTitle org
in (path, _orgClocks org) : concatMap (orgToList' path) (_orgSubtrees org)
diffTimeSeconds :: DiffTime -> Integer
diffTimeSeconds time = floor $ toRational time
diffTimeMinutes :: DiffTime -> Integer
diffTimeMinutes time = diffTimeSeconds time `div` 60
labelColour :: TimelineParams -> Text -> D.Colour Double
labelColour params _label = hashColour (params ^. tpColorSalt) _label
fitLabelHeight :: TimelineParams -> Double -> Double -> Bool
fitLabelHeight params n h = h >= (params ^. tpColumnHeight) * n
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)
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 $
foreach [(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)))
timelineDays
:: TimelineParams
-> [Day]
-> [[(Text, (DiffTime, DiffTime))]]
-> [[(Text, DiffTime)]]
-> D.Diagram B
timelineDays params days clocks topLists =
D.hcat $
foreach (days `zip` (clocks `zip` topLists)) $ \(day, (dayClocks, topList)) ->
D.vsep 5
[ timelineDay params day dayClocks
, taskList params topList True
]
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 -> (LocalTime, LocalTime) -> SVGImageReport
timelineReport params org (from,to) = SVGImage pic
where
lookupDef :: Eq a => b -> a -> [(a, b)] -> b
lookupDef d a xs = fromMaybe d $ lookup a xs
daysToShow = [localDay from ..
localDay ((negate 120 :: Int) `addLocalTime` to)]
tasks :: [(Text, [Clock])]
tasks = orgToList org
byDay :: [[(Text, [(DiffTime, DiffTime)])]]
byDay = selectDays daysToShow tasks
byDayDurations :: [[(Text, DiffTime)]]
byDayDurations = map totalTimes byDay
allDaysDurations :: [(Text, DiffTime)]
allDaysDurations =
let allTasks = nub $ map fst $ concat byDayDurations in
foreach allTasks $ \task ->
(task,) $ sum $ foreach byDayDurations $ \durations ->
lookupDef (fromInteger 0) task durations
clocks :: [[(Text, (DiffTime, DiffTime))]]
clocks = map allClocks byDay
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
:: (MonadThrow m)
=> TimelineParams -> Org -> (LocalTime, LocalTime) -> m SVGImageReport
processTimeline params org fromto = pure $ timelineReport params org fromto