module Aftok.Timeline where

import Prelude
import Control.Alt ((<|>))
import Control.Monad.Rec.Class (forever)
import Control.Monad.State (State, put, get, evalState)
import Control.Monad.Trans.Class (lift)
import Control.Monad.Maybe.Trans (MaybeT(..), runMaybeT)
import Data.Array (reverse, cons)
import Data.Date (Date)
import Data.DateTime as DT
import Data.DateTime (DateTime(..), date)
import Data.DateTime.Instant (Instant, unInstant, fromDateTime, toDateTime)
import Data.Either (Either(..))
import Data.Foldable (length)
import Data.Map as M
import Data.Maybe (Maybe(..), maybe, isJust, isNothing, fromMaybe)
import Data.Symbol (SProxy(..))
import Data.Time.Duration (Milliseconds(..), Hours(..), Days(..))
import Data.Traversable (traverse_, traverse)
import Data.Tuple (Tuple(..))
import Data.Unfoldable as U
import Effect.Aff as Aff
import Effect.Aff (Aff)
import Effect.Class (liftEffect)
import Effect.Exception (error)
import Effect.Now (now)
import Halogen as H
import Halogen.Query.EventSource (EventSource)
import Halogen.Query.EventSource as EventSource
import Halogen.HTML.Core (ClassName(..))
import Halogen.HTML as HH
import Halogen.HTML.CSS as CSS
import Halogen.HTML.Events as E
import Halogen.HTML.Properties as P
import CSS (backgroundColor, clear, clearBoth, border, rgb, solid, borderRadius, marginLeft)
import CSS.Display (display, flex)
import CSS.Geometry (width, height)
import CSS.Size (px, pct)
import Aftok.Api.Timeline as TL
import Aftok.Api.Timeline
  ( TimelineError
  , Event(..)
  , Interval(..)
  , TimeInterval
  , KeyedEvent
  , TimeSpan
  , start
  , end
  , interval
  , event
  , eventTime
  , keyedEvent
  )
import Aftok.ProjectList as ProjectList
import Aftok.Types
  ( System
  , ProjectId
  , dateStr
  )

type TimelineLimits
  = { bounds :: TimeInterval
    , current :: Instant
    }

data TimelineEvent
  = LoggedEvent (KeyedEvent Instant)
  | PhantomEvent Instant

instance showTimelineEvent :: Show TimelineEvent where
  show = case _ of
    LoggedEvent kev -> "Real event at " <> show (event kev)
    PhantomEvent i -> "Phantom at " <> show i

tlEventTime :: TimelineEvent -> Instant
tlEventTime = case _ of
  LoggedEvent kev -> eventTime <<< event $ kev
  PhantomEvent i -> i

type DayIntervals
  = { dayBounds :: TimeInterval
    , loggedIntervals :: Array (Interval TimelineEvent)
    }

type History
  = M.Map Date DayIntervals

type Input
  = Maybe ProjectId

type TimelineState
  = { selectedProject :: Maybe ProjectId
    , history :: M.Map Date DayIntervals
    , active :: Maybe (Interval TimelineEvent)
    , activeHistory :: M.Map Date DayIntervals
    }

data TimelineAction
  = Initialize
  | ProjectSelected (Maybe ProjectId)
  | Start
  | Stop
  | Refresh

type Slot id
  = forall query. H.Slot query ProjectList.Output id

type Slots
  = ( projectList :: ProjectList.Slot Unit
    )

_projectList = SProxy :: SProxy "projectList"

type Capability m
  = { timer :: EventSource m TimelineAction
    , logStart :: ProjectId -> m (Either TimelineError (KeyedEvent Instant))
    , logEnd :: ProjectId -> m (Either TimelineError (KeyedEvent Instant))
    , listIntervals :: ProjectId -> TimeSpan -> m (Either TimelineError (Array (Interval (KeyedEvent Instant))))
    , getLatestEvent :: ProjectId -> m (Either TimelineError (Maybe (KeyedEvent Instant)))
    }

component ::
  forall query m.
  Monad m =>
  System m ->
  Capability m ->
  ProjectList.Capability m ->
  H.Component HH.HTML query Input ProjectList.Output m
component system caps pcaps =
  H.mkComponent
    { initialState
    , render
    , eval:
        H.mkEval
          $ H.defaultEval
              { handleAction = handleAction
              , initialize = Just Initialize
              , receive = Just <<< ProjectSelected
              }
    }
  where
  initialState :: Input -> TimelineState
  initialState input =
    { selectedProject: input
    , history: M.empty
    , active: Nothing
    , activeHistory: M.empty
    }

  render :: TimelineState -> H.ComponentHTML TimelineAction Slots m
  render st =
    HH.section
      [ P.classes (ClassName <$> [ "section-border", "border-primary" ]) ]
      [ HH.div
          [ P.classes (ClassName <$> [ "container", "pt-6" ]) ]
          [ HH.h1
              [ P.classes (ClassName <$> [ "mb-0", "font-weight-bold", "text-center" ]) ]
              [ HH.text "Time Tracker" ]
          , HH.p
              [ P.classes (ClassName <$> [ "col-md-5", "text-muted", "text-center", "mx-auto" ]) ]
              [ HH.text "Your project timeline" ]
          , HH.div_
              [ HH.slot
                  _projectList
                  unit
                  (ProjectList.component system pcaps)
                  st.selectedProject
                  (Just <<< (\(ProjectList.ProjectChange pid) -> ProjectSelected (Just pid)))
              ]
          , HH.div
              [ P.classes (ClassName <$> if isNothing st.selectedProject then [ "collapse" ] else []) ]
              ( [ HH.div_
                    [ HH.button
                        [ P.classes (ClassName <$> [ "btn", "btn-primary", "float-left", "my-2" ])
                        , E.onClick \_ -> Just Start
                        , P.disabled (isJust st.active)
                        ]
                        [ HH.text "Start Work" ]
                    , HH.button
                        [ P.classes (ClassName <$> [ "btn", "btn-primary", "float-right", "my-2" ])
                        , E.onClick \_ -> Just Stop
                        , P.disabled (isNothing st.active)
                        ]
                        [ HH.text "Stop Work" ]
                    ]
                ]
                  <> (historyLine <$> reverse (M.toUnfoldable $ unionHistories st.history st.activeHistory))
              )
          ]
      ]

  handleAction :: TimelineAction -> H.HalogenM TimelineState TimelineAction Slots ProjectList.Output m Unit
  handleAction action = do
    case action of
      Initialize -> do
        void $ H.subscribe caps.timer
        currentProject <- H.gets (_.selectedProject)
        traverse_ setStateForProject currentProject
      ProjectSelected pidMay -> do
        oldActive <- isJust <$> H.gets (_.active)
        currentProject <- H.gets (_.selectedProject)
        when (currentProject /= pidMay) $ do
          -- End any active intervals when switching projects.
          when oldActive $ traverse_ logEnd currentProject
          traverse_ projectSelected pidMay
      Start -> do
        project <- H.gets (_.selectedProject)
        traverse_ logStart project
      Stop -> do
        currentProject <- H.gets (_.selectedProject)
        traverse_ logEnd currentProject
      Refresh -> do
        t <- lift $ system.now
        H.modify_ (refresh t)
    -- common updates, irrespective of action
    active <- H.gets (_.active)
    activeHistory <- lift <<< map (fromMaybe M.empty) <<< runMaybeT $ toHistory system (U.fromMaybe active)
    H.modify_ (_ { activeHistory = activeHistory })
    where
      projectSelected pid = do
        setStateForProject pid
        H.raise (ProjectList.ProjectChange pid)

  logStart :: ProjectId -> H.HalogenM TimelineState TimelineAction Slots ProjectList.Output m Unit
  logStart pid = do
    logged <- lift $ caps.logStart pid
    case logged of
      Left err -> lift <<< system.log $ "Failed to start timer: " <> show err
      Right t -> H.modify_ (updateStart t)

  logEnd :: ProjectId -> H.HalogenM TimelineState TimelineAction Slots ProjectList.Output m Unit
  logEnd pid = do
    logged <- lift $ caps.logEnd pid
    case logged of
      Left err -> lift <<< system.log $ "Failed to stop timer: " <> show err
      Right t -> do
        currentState <- H.get
        updatedState <- lift $ updateStop system t currentState
        H.put updatedState

  setStateForProject :: ProjectId -> H.HalogenM TimelineState TimelineAction Slots ProjectList.Output m Unit
  setStateForProject pid = do
    timeSpan <- TL.Before <$> lift system.nowDateTime -- FIXME, should come from a form control
    intervals' <- lift $ caps.listIntervals pid timeSpan
    intervals <-
      lift
        $ case intervals' of
            Left err ->
              (system.log $ "Error occurred listing intervals" <> show err)
                *> pure []
            Right ivals -> pure $ map (map LoggedEvent) ivals
    history' <- lift <<< runMaybeT $ toHistory system intervals
    hist <- case history' of
      Nothing -> lift $ system.log "Project history was empty." *> pure M.empty
      Just h -> pure h
    latestEventResponse <- lift $ caps.getLatestEvent pid
    now <- lift $ system.now
    active <-
      lift
        $ case latestEventResponse of
            Left err ->
              (system.log $ "Error occurred retrieving the latest event: " <> show err)
                *> pure Nothing
            Right latestEvent -> do
              let
                activeInterval :: TL.KeyedEvent Instant -> m (Maybe (Interval TimelineEvent))
                activeInterval ev = case event ev of
                  TL.StartEvent i ->
                    (system.log $ "Project has an open active interval starting " <> show i)
                      *> (Just <<< interval (LoggedEvent ev) <<< PhantomEvent <$> system.now)
                  TL.StopEvent _ -> pure Nothing
              join <$> traverse activeInterval latestEvent
    H.modify_ (_ { selectedProject = Just pid, history = hist, active = active })

historyLine ::
  forall w i.
  Tuple Date DayIntervals ->
  HH.HTML w i
historyLine (Tuple d xs) = datedLine d xs.dayBounds xs.loggedIntervals

datedLine ::
  forall w i.
  Date ->
  TimeInterval ->
  Array (Interval TimelineEvent) ->
  HH.HTML w i
datedLine d dateBounds xs =
  HH.div
    [ CSS.style do
        clear clearBoth
    ]
    [ HH.text $ dateStr d <> ": " <> show (length xs :: Int)
    , HH.div
        [ CSS.style do
            border solid (px 3.0) (rgb 0x00 0xFF 0x00)
            borderRadius px5 px5 px5 px5
            height (px $ 44.0)
            display flex
        , P.classes (ClassName <$> [ "my-2" ])
        ]
        (evalState (traverse (intervalHtml dateBounds) xs) 0.0)
    ]
  where
  px5 = px 5.0

intervalHtml ::
  forall w i.
  TimeInterval ->
  Interval TimelineEvent ->
  State Number (HH.HTML w i)
intervalHtml (Interval limits) (Interval i) = do
  offset <- get
  let
    maxWidth = ilen limits.start limits.end

    ileft = ilen limits.start (tlEventTime i.start)

    iwidth = ilen (tlEventTime i.start) (tlEventTime i.end)

    px5 = px (5.0)

    toPct n = 100.0 * n / maxWidth
  put $ toPct (ilen limits.start (tlEventTime i.end))
  pure
    $ HH.div
        [ CSS.style do
            backgroundColor (rgb 0xf0 0x98 0x18)
            marginLeft (pct $ toPct ileft - offset)
            width (pct $ max (toPct iwidth) 0.5)
            borderRadius px5 px5 px5 px5
        ]
        []

timer :: EventSource Aff TimelineAction
timer =
  EventSource.affEventSource \emitter -> do
    fiber <-
      Aff.forkAff
        $ forever do
            Aff.delay $ Aff.Milliseconds 10000.0
            EventSource.emit emitter Refresh
    pure
      $ EventSource.Finalizer do
          Aff.killFiber (error "Event source finalized") fiber

updateStart :: KeyedEvent Instant -> TimelineState -> TimelineState
updateStart ev s = s { active = s.active <|> Just (TL.interval (LoggedEvent ev) (PhantomEvent <<< eventTime <<< event $ ev)) }

updateStop ::
  forall m.
  Monad m =>
  System m ->
  KeyedEvent Instant ->
  TimelineState ->
  m TimelineState
updateStop system ev st = do
  let
    updateHistory i = runMaybeT $ toHistory system [ TL.interval (start i) (LoggedEvent ev) ]
  newHistory <- join <$> traverse updateHistory st.active
  pure
    { selectedProject: st.selectedProject
    , history: maybe st.history (unionHistories st.history) newHistory
    , active: Nothing
    , activeHistory: M.empty
    }

refresh :: Instant -> TimelineState -> TimelineState
refresh t s =
  s
    { active = map (\i -> TL.interval (start i) (PhantomEvent t)) s.active
    }

ilen :: Instant -> Instant -> Number
ilen _start _end =
  let
    n (Milliseconds x) = x
  in
    n (unInstant _end) - n (unInstant _start)

apiCapability :: Capability Aff
apiCapability =
  { timer: timer
  , logStart: TL.apiLogStart
  , logEnd: TL.apiLogEnd
  , listIntervals: TL.apiListIntervals
  , getLatestEvent: TL.apiLatestEvent
  }

mockCapability :: Capability Aff
mockCapability =
  { timer: timer
  , logStart: \_ -> Right <<< keyedEvent "" <<< StartEvent <$> liftEffect now
  , logEnd: \_ -> Right <<< keyedEvent "" <<< StopEvent <$> liftEffect now
  , listIntervals: \_ _ -> Right <$> pure []
  , getLatestEvent: \_ -> Right <$> pure Nothing
  }

utcDayBounds :: Instant -> TimeInterval
utcDayBounds i =
  let
    startOfDay = DateTime (date $ toDateTime i) bottom

    endOfDay = DT.adjust (Days 1.0) startOfDay

    startInstant = fromDateTime startOfDay
  in
    TL.interval startInstant (maybe startInstant fromDateTime endOfDay)

localDayBounds ::
  forall m.
  Monad m =>
  System m ->
  Instant ->
  MaybeT m (Tuple Date TimeInterval)
localDayBounds system t = do
  Tuple date start <- MaybeT $ system.dateFFI.midnightLocal t
  nextNoon <-
    MaybeT <<< pure
      $ fromDateTime
      <$> ( DT.adjust (Hours 12.0) <=< DT.adjust (Days 1.0)
            $ (toDateTime start)
        )
  Tuple _ end <- MaybeT $ system.dateFFI.midnightLocal nextNoon
  pure $ Tuple date (interval start end)

splitInterval ::
  forall m.
  Monad m =>
  System m ->
  Interval TimelineEvent ->
  MaybeT m (Array (Tuple Date DayIntervals))
splitInterval system i = do
  lift <<< system.log $ "Splitting interval " <> show i
  -- day bounds are based on the start event.
  Tuple date bounds <- localDayBounds system (tlEventTime $ start i)
  lift <<< system.log $ "Splitting on day bounds: " <> show (start bounds) <> " to " <> show (end bounds)
  split <-
    if tlEventTime (end i) < end bounds then do
      lift <<< system.log $ "Split complete"
      pure [ Tuple date { dayBounds: bounds, loggedIntervals: [ i ] } ]
    else do
      let
        splitEvent = PhantomEvent (end bounds)

        currInterval = Tuple date { dayBounds: bounds, loggedIntervals: [ interval (start i) splitEvent ] }

        nextInterval = interval splitEvent (end i)
      lift <<< system.log $ "Split required; first fragment: " <> show currInterval <> "; next interval: " <> show nextInterval
      cons currInterval <$> splitInterval system nextInterval
  --lift <<< system.log $ "Split result: " <> show split
  pure split

toHistory ::
  forall m.
  Monad m =>
  System m ->
  Array (Interval TimelineEvent) ->
  MaybeT m (M.Map Date DayIntervals)
toHistory system xs = do
  splits <- join <$> traverse (splitInterval system) xs
  pure $ M.fromFoldableWith unionDayIntervals splits

unionDayIntervals :: DayIntervals -> DayIntervals -> DayIntervals
unionDayIntervals d1 d2 =
  { dayBounds: d1.dayBounds -- FIXME, need to be sure these match
  , loggedIntervals: d1.loggedIntervals <> d2.loggedIntervals
  }

unionHistories :: History -> History -> History
unionHistories = M.unionWith unionDayIntervals