Ast.hs

{-# LANGUAGE RankNTypes, TemplateHaskell #-}

-- | Abstract syntax tree for org.

module OrgStat.Ast
       ( Clock (..)
       , Org (..)
       , orgTitle
       , orgTags
       , orgClocks
       , orgSubtrees

       , clockDuration
       , orgDurations
       , orgTotalDuration
       , orgMeanDuration
       , orgMedianDuration
       , orgPomodoroNum
       , filterHasClock
       , cutFromTo
       , fmapOrgLens
       , traverseTree
       , atDepth
       , mergeClocks
       ) where

import Control.Lens (ASetter', makeLenses)
import Data.List ((!!))
import Data.Time (LocalTime, NominalDiffTime, diffUTCTime, localTimeToUTC, utc)

import Universum

----------------------------------------------------------------------------
-- Types
----------------------------------------------------------------------------

-- | Org clock representation -- a pair of time in UTC. Should be
-- local time in fact, but we'll assume that UTC timestamps support in
-- org will be added at some point. For now all tags are to be read in
-- local time.
data Clock = Clock
    { cFrom :: LocalTime
    , cTo   :: LocalTime
    } deriving (Show,Eq,Ord)

-- | Main datatype of org AST. It may contain some metadata if needed
-- (e.g. current node depth, children number etc). Content of headers
-- is ignored.
data Org = Org
    { _orgTitle    :: Text
    , _orgTags     :: [Text]
    , _orgClocks   :: [Clock]
    , _orgSubtrees :: [Org]
    } deriving (Show,Eq)

makeLenses ''Org

----------------------------------------------------------------------------
-- Helpers and lenses
----------------------------------------------------------------------------

-- | Merge adjacent clocks from the list into one, return sorted list.
glueAdjacent :: [Clock] -> [Clock]
glueAdjacent clocks = go (sort clocks)
  where
    go [] = []
    go [x] = [x]
    go (a:b:xs) = if cTo a >= cFrom b then go (Clock (cFrom a) (cTo b) : xs)
                                      else a : go (b:xs)

-- | Duration of the clock
clockDuration :: Clock -> NominalDiffTime
clockDuration (Clock (localTimeToUTC utc -> from) (localTimeToUTC utc -> to)) =
    diffUTCTime to from

-- | All durations of a single org file
orgDurations :: Org -> [NominalDiffTime]
orgDurations org =
    map clockDuration $ glueAdjacent $ concat $ org ^.. traverseTree . orgClocks

-- | Calculate total clocks duration in org tree.
orgTotalDuration :: Org -> NominalDiffTime
orgTotalDuration = sum . orgDurations

-- | Calculate mean duration of clocks in the given org tree.
orgMeanDuration :: Org -> NominalDiffTime
orgMeanDuration = mean . orgDurations
  where
    mean [] = 0
    mean xs = sum xs / fromIntegral (length xs)

-- | Calculate mean duration of clocks in the given org tree.
orgMedianDuration :: Org -> NominalDiffTime
orgMedianDuration = median . orgDurations
  where
    median [] = 0
    median [a] = a
    median xs = let sorted = sort xs in
                let n = length xs in
                if odd n then sorted !! (n `div` 2)
                         else (sorted !! (n `div` 2 - 1) + sorted !! (n `div` 2)) / 2

-- | Number of intervals \geq 25min. Intervals that are (25 * n + p)
-- mins long with p < 25 count as n pomodoros.
orgPomodoroNum :: Org -> Int
orgPomodoroNum =
    sum . map (\dur -> truncate dur `div` (25 * 60 :: Int)) . orgDurations

-- | Remove subtrees that have zero total duration.
filterHasClock :: Org -> Org
filterHasClock = orgSubtrees %~ mapMaybe dfs
  where
    dfs :: Org -> Maybe Org
    dfs o = do
        let children = mapMaybe dfs (o ^. orgSubtrees)
        let ownDur = sum $ map clockDuration (o ^. orgClocks)
        if ownDur == 0 && null children
            then Nothing
            else Just $ o & orgSubtrees .~ children

cutFromTo :: (LocalTime, LocalTime) -> Org -> Org
cutFromTo (from, to) o
    | from >= to = error "cutFromTo: from >= to"
    | otherwise = o & traverseTree %~ filterClocks
  where
    -- Cuts clock relatively to from/to or discards if it's not in the
    -- interval.
    fitClock :: Clock -> Maybe Clock
    fitClock Clock{..} = do
        guard $ cFrom <= to
        guard $ cTo >= from
        pure $ Clock (max cFrom from) (min cTo to)

    filterClocks :: Org -> Org
    filterClocks = orgClocks %~ mapMaybe fitClock

-- | Functor-like 'fmap' on field chosen by lens.
fmapOrgLens :: ASetter' Org a -> (a -> a) -> Org -> Org
fmapOrgLens l f o = o & l %~ f & orgSubtrees %~ map (fmapOrgLens l f)

-- | Traverses node and subnodes, all recursively. Bottom-top.
traverseTree :: Traversal' Org Org
traverseTree f o = o'
  where
    o' = liftA2 (\org x -> org & orgSubtrees .~ x) (f o) traversedChildren
    traversedChildren = traverse (traverseTree f) $ o ^. orgSubtrees

atDepth :: Int -> Traversal' Org Org
atDepth i _ o | i < 0 = pure o
atDepth 0 f o = f o
atDepth n f o =
    (\x -> o & orgSubtrees .~ x) <$> traverse (atDepth (n-1) f) (o ^. orgSubtrees)

-- TODO This should consider the following situation:
-- Task A: 00:03 - 00:10
-- Task B: 00:10 - 00:11
-- Task A: 00:11 - 00:12
--
-- It will merge A, and thus A will interlap with B, which is undesirable.
-- | Merges task clocks that have less then 2m delta between them into
-- one.
mergeClocks :: Org -> Org
mergeClocks = fmapOrgLens orgClocks (mergeClocksDo . sort)
  where
    toUTC = localTimeToUTC utc
    mergeClocksDo [] = []
    mergeClocksDo [x] = [x]
    mergeClocksDo (a:b:xs)
        | toUTC (cFrom b) `diffUTCTime ` toUTC (cTo a) < 2*60 =
          mergeClocksDo $ (Clock (cFrom a) (cTo b)):xs
        | otherwise = a : mergeClocksDo (b:xs)