module Punch where

import Prelude hiding (log)

import Control.Monad (unless)
import Data.Char (isSpace)
import Data.List (tails)
import Data.Time
import GHC.Stack (HasCallStack)

oops :: HasCallStack => a
oops = error "internal error"

-- | Time interval denoted by a pair of a start and stop time
--
-- The start time is included in the interval and the stop time is excluded (see
-- 'occursIn').
type Interval time = (time, time)

occursIn :: AbstractTime time => time -> Interval time -> Bool
occursIn t (t1, t2) = t1 <= t && t < t2

class ( Ord time
      , Ord (DayOf time)
      , Enum (DayOf time)
      , Num (MeasuredTime time)
      ) =>
      AbstractTime time
  where
  type DayOf time
  type MeasuredTime time

  dayOf :: time -> DayOf time

  -- | The length of a time interval
  --
  -- If the @start >= stop@, then the interval length is 0.
  intervalLength :: Interval time -> MeasuredTime time

  -- | Start of the day
  midnightOf :: DayOf time -> time

instance AbstractTime LocalTime where
  type DayOf        LocalTime = Day
  type MeasuredTime LocalTime = NominalDiffTime
  dayOf          = localDay
  intervalLength = max 0 . uncurry (flip diffLocalTime)
  midnightOf d   = LocalTime {localDay = d, localTimeOfDay = midnight}

data PunchError time
  = DoubleEvent (Punch time) (Punch time)
  | NonIncreasingTime (Punch time) (Punch time)
  | FormatError String
  deriving (Show)

-- | A punch entry
data Punch time
  = Start time    -- ^ Start an interval
  | Stop time     -- ^ Stop an interval
  | Period String -- ^ Mark the start of a period
  deriving (Eq, Show, Read)

-- | A punch time log
type Log time = [Punch time]

isEvent :: Punch time -> Bool
isEvent (Start _)  = True
isEvent (Stop _)   = True
isEvent (Period _) = False

-- | Check that the log is valid
validLog :: AbstractTime time => [Punch time] -> Either (PunchError time) ()
validLog = go . filter isEvent
  where
    go [] = return ()
    go [_] = return ()
    go (p1 : p2 : log)
      | Start _  <- p1, Start _  <- p2 = Left $ DoubleEvent p1 p2
      | Stop _   <- p1, Stop _   <- p2 = Left $ DoubleEvent p1 p2
      | Start t1 <- p1, Stop t2  <- p2, t2 <= t1 = Left $ NonIncreasingTime p1 p2
      | Stop t1  <- p1, Start t2 <- p2, t2 < t1  = Left $ NonIncreasingTime p1 p2
      | otherwise = go (p2:log)

-- | Convert a valid 'Log' into a sequence of intervals
--
-- Any leading 'Stop' event or trailing 'Start' event will be ignored.
intervals :: Log time -> [Interval time]
intervals = go . filter isEvent
  where
    go []                         = []
    go [Start _]                  = []
    go (Stop _ : log)             = go log
    go (Start t1 : Stop t2 : log) = (t1, t2) : go log
    go _ = oops

fromIntervals :: [Interval time] -> Log time
fromIntervals = concatMap (\(t1, t2) -> [Start t1, Stop t2])

-- | Check that the list of intervals is valid
validIntervals ::
     AbstractTime time => [Interval time] -> Either (PunchError time) ()
validIntervals is = do
  sequence_
    [ unless (t1 < t2) $ Left (NonIncreasingTime (Start t1) (Stop t2))
    | (t1, t2) <- is
    ]
  sequence_
    [ unless (t1 <= t2) $ Left (NonIncreasingTime (Stop t1) (Start t2))
    | ((_, t1), (t2, _)) <- zip is (tail is)
    ]

-- | Keep the intervals that include times on or after the given day
--
-- If the given day starts in the middle of an interval, that interval will be
-- adjusted to start in the beginning of the day.
fromDay :: AbstractTime time => DayOf time -> [Interval time] -> [Interval time]
fromDay day = go
  where
    go [] = []
    go (i@(start, stop) : is)
      | stop <= mid = go is
      | start < mid = (mid, stop) : is
      | otherwise   = i : go is
      where
        mid = midnightOf day

-- | Keep the intervals that include times before the given day
--
-- If the given day starts in the middle of an interval, that interval will be
-- adjusted to end right before the new day.
toDay :: AbstractTime time => DayOf time -> [Interval time] -> [Interval time]
toDay day = go
  where
    go [] = []
    go (i@(start, stop) : is)
      | stop <= mid = i : go is
      | start < mid = [(start, mid)]
      | otherwise   = []
      where
        mid = midnightOf day

-- | Remove the log suffix whose events occur on or after the given day
betweenDays ::
     AbstractTime time
  => DayOf time -- ^ Start day (inclusive)
  -> DayOf time -- ^ End day (exclusive)
  -> [Interval time]
  -> [Interval time]
betweenDays start end = toDay end . fromDay start

-- | Add a 'Stop' event at the current time if the last event in the log is a
-- 'Start'
stopNow ::
     time -- ^ Current time (must be after the last 'Start' time in the log)
  -> Log time
  -> Log time
stopNow now log = case log' of
  Start _:_ -> log ++ [Stop now]
  _ -> log
  where
    log' = dropWhile (not . isEvent) $ reverse log

-- | Measure the total logged time
totalTime ::
     AbstractTime time
  => [Interval time]
  -> MeasuredTime time
totalTime = sum . map intervalLength

-- | List all periods in a log
--
-- Each period runs from the corresponding 'Period' marker to the end of the
-- log.
listPeriods :: Log time -> [(String, Log time)]
listPeriods log = [(p, log') | Period p:log' <- tails log]

-- | Parse a 'Punch' event
parsePunch :: Read time => String -> Either (PunchError time) (Punch time)
parsePunch s = case reads s' of
  [(p, "")] -> return p
  _ -> Left $ FormatError s'
  where
    s' = reverse $ dropWhile isSpace $ reverse s

-- | Remove any suffix starting with "--"
stripComment :: String -> String
stripComment "" = ""
stripComment ('-':'-':_) = ""
stripComment (c:cs) = c : stripComment cs

-- | Parse a 'Log'
parseLog :: Read time => String -> Either (PunchError time) (Log time)
parseLog =
  mapM parsePunch .
  filter (not . null) . map (dropWhile isSpace . stripComment) . lines