{-# LANGUAGE DeriveGeneric              #-}
{-# LANGUAGE ExtendedDefaultRules       #-}
{-# LANGUAGE FlexibleContexts           #-}
{-# LANGUAGE FlexibleInstances          #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE OverloadedStrings          #-}
{-# LANGUAGE RankNTypes                 #-}
{-# LANGUAGE ScopedTypeVariables        #-}
{-# LANGUAGE TypeFamilies               #-}
{-# OPTIONS_GHC -Wno-type-defaults      #-}


module Shpadoinkle.Widgets.Table.Lazy
  ( AssumedRowHeight (..)
  , AssumedTableHeight (..)
  , CurrentScrollY (..)
  , LazyTabular (..)
  , LazyTable (..)
  , DebounceScroll
  , LazyTableScrollConfig (..)
  , lazyTable
  ) where


import Prelude hiding (div)

import Control.Arrow (second)
import Data.Aeson
import Data.Functor.Identity
import Data.List (sortBy)
import Data.Maybe (fromMaybe)
import Data.Proxy
import Data.Text hiding (filter, find, take)
import GHC.Generics

import Language.Javascript.JSaddle hiding (JSM, MonadJSM)
import Shpadoinkle
import Shpadoinkle.Html (div)
import Shpadoinkle.Widgets.Table
import Shpadoinkle.Widgets.Types

default (Text)


class Tabular a => LazyTabular a where
  countRows :: a -> Int


data LazyTable a = LazyTable a AssumedTableHeight AssumedRowHeight CurrentScrollY RowsToShow (SortCol a) [Row (LazyTable a)]


newtype RowsToShow = RowsToShow Int
  deriving (Eq, Ord, Num, Real, Bounded, Enum, Read, Show, ToJSON, FromJSON, Generic)


data instance (Row (LazyTable a)) = LazyRow (Row a) | FakeRow


data instance (Column (LazyTable a)) = LazyColumn (Column a)


instance Humanize (Column a) => Humanize (Column (LazyTable a)) where
  humanize (LazyColumn c) = humanize c


instance Bounded (Column a) => Bounded (Column (LazyTable a)) where
  minBound = LazyColumn minBound
  maxBound = LazyColumn maxBound


instance Eq (Column a) => Eq (Column (LazyTable a)) where
  (LazyColumn a) == (LazyColumn b) = a == b


instance Enum (Column a) => Enum (Column (LazyTable a)) where
  toEnum = LazyColumn . toEnum
  fromEnum (LazyColumn c) = fromEnum c


instance Ord (Column a) => Ord (Column (LazyTable a)) where
  compare (LazyColumn a) (LazyColumn b) = compare a b


instance Tabular a => Tabular (LazyTable a) where
  type Effect (LazyTable a) m = Effect a m
  toRows (LazyTable _ _ _ _ _ _ rows) = rows ++ [FakeRow]
  toCell (LazyTable xs _ _ _ _ _ _) (LazyRow r) (LazyColumn c) =
    mapToLazyTable <$> toCell xs r c
  toCell _ FakeRow _ = []
  sortTable sc (LazyRow a) (LazyRow b) = sortTable (fromLazySortCol sc) a b
  sortTable _ FakeRow FakeRow = EQ
  sortTable _ _ FakeRow = LT
  sortTable _ FakeRow _ = GT
  ascendingIcon _ = mapToLazyTableSc $ ascendingIcon Proxy
  descendingIcon _ = mapToLazyTableSc $ descendingIcon Proxy


-- Require the user to provide assumptions about the height of each row and the height of the container rather than querying the DOM for this information. Also make the assumption that all rows have equal height.
newtype AssumedRowHeight = AssumedRowHeight Int -- measured in pixels
  deriving (Eq, Ord, Generic, ToJSON, FromJSON, Read, Show, Num, Enum, Real, Integral)


newtype AssumedTableHeight = AssumedTableHeight Int -- measued in pixels
  deriving (Eq, Ord, Generic, ToJSON, FromJSON, Read, Show, Num, Enum, Real, Integral)


newtype CurrentScrollY = CurrentScrollY Int -- measured in pixels
  deriving (Eq, Ord, Generic, ToJSON, FromJSON, Read, Show, Num, Enum, Real, Integral)


type DebounceScroll m a = (RawNode -> RawEvent -> JSM (Continuation m a))
                       -> (RawNode -> RawEvent -> JSM (Continuation m a))


data LazyTableScrollConfig m a b = ContainerIsScrollable (DebounceScroll m (b, CurrentScrollY))
                                 | TbodyIsScrollable (DebounceScroll m (LazyTable a, SortCol (LazyTable a)))
  deriving Generic


toLazySortCol :: SortCol a -> SortCol (LazyTable a)
toLazySortCol (SortCol c' s') = SortCol (LazyColumn c') s'


fromLazySortCol :: SortCol (LazyTable a) -> SortCol a
fromLazySortCol (SortCol (LazyColumn c') s') = SortCol c' s'


mapFromLazyTableSc :: Tabular a => Functor m => Continuous f
                 => LazyTable a
                 -> f m (LazyTable a, SortCol (LazyTable a)) -> f m ((a, SortCol a), CurrentScrollY)
mapFromLazyTableSc (LazyTable _ tableHeight rowHeight _ _ _ _) = liftC
  (\(LazyTable tab _ _ sy _ _ _, sc') _ -> ((tab, fromLazySortCol sc'), sy))
  (\((tab, sc), sy) -> ( toLazyTable tableHeight rowHeight sy tab sc
                       , toLazySortCol sc ))


mapToLazyTable :: Functor m => Continuous f => Tabular a
               => f m a -> f m (LazyTable a)
mapToLazyTable = liftC
  (\tab (LazyTable _ tableHeight rowHeight scrollY _ sc _)
    -> toLazyTable tableHeight rowHeight scrollY tab sc)
  (\(LazyTable tab _ _ _ _ _ _) -> tab)


mapToLazyTableSc :: Functor m => Continuous f => Tabular a
                 => f m (a, SortCol a) -> f m (LazyTable a, SortCol (LazyTable a))
mapToLazyTableSc = liftC
  (\(tab, sc) (LazyTable _ tableHeight rowHeight scrollY _ _ _, _)
    -> ( toLazyTable tableHeight rowHeight scrollY tab sc
       , toLazySortCol sc ))
  (\(LazyTable tab _ _ _ _ _ _, sc) -> (tab, fromLazySortCol sc))


toLazyTable :: Tabular a
  => AssumedTableHeight -> AssumedRowHeight -> CurrentScrollY
  -> a -> SortCol a -> LazyTable a
toLazyTable tabh@(AssumedTableHeight height) rowh@(AssumedRowHeight rowHeight) sy@(CurrentScrollY scrollY) xs sc
  = LazyTable xs tabh rowh sy (RowsToShow rowsToShow) sc
                 . fmap LazyRow
                 . take rowsToShow
                 . sortBy (sortTable sc)
                 . filter (toFilter xs)
                 $ toRows xs
  where
    pixelsToFill :: Double
    -- TODO: make these coefficients (8 and 1.5) configurable?
    pixelsToFill = 8 * fromIntegral height + 1.5 * fromIntegral scrollY

    rowsToShow :: Int = 1 + truncate (pixelsToFill / fromIntegral rowHeight)


lazyTable :: forall m a b.
  ( LazyTabular a
  , Effect a m
  , MonadJSM m
  , Humanize (Column a)
  , Bounded  (Column a)
  , Ord      (Column a)
  , Enum     (Column a) )
  => Theme m a
  -> AssumedTableHeight
  -> AssumedRowHeight
  -> LazyTableScrollConfig m a b
  -> (Html m ((a, SortCol a), CurrentScrollY) -> Html m (b, CurrentScrollY))
  -> a
  -> SortCol a
  -> CurrentScrollY
  -> Html m (b, CurrentScrollY)
lazyTable theme tableHeight rowHeight@(AssumedRowHeight rowHeight')
          scrollConfig container xs sc@(SortCol c s) scrollY =
    addContainerScrollHandler
  . container
  . addContainerFakeHeight
  . mapFromLazyTableSc lazyTab
  $ viewWith lazyTheme lazyTab (SortCol (LazyColumn c) s)
  where
    lazyTab@(LazyTable _ _ _ _ _ _ _) = toLazyTable tableHeight rowHeight scrollY xs sc

    totalRows = countRows xs

    addContainerFakeHeight = case scrollConfig of
      ContainerIsScrollable _ -> div [("style", textProp fakeHeightStyle)] . (:[])
      TbodyIsScrollable _ -> id

    addContainerScrollHandler = case scrollConfig of
      ContainerIsScrollable debounceScroll ->
        runIdentity . props (Identity . (listenRaw "scroll" (debounceScroll scrollHandlerContainer) :))
      TbodyIsScrollable _ -> id

    scrollHandlerContainer = \(RawNode n) _ ->
      pur . second . const . CurrentScrollY . fromMaybe 0
        <$> (fromJSVal =<< n ! "scrollTop")

    scrollHandlerTbody :: RawNode -> RawEvent -> JSM (Continuation m (LazyTable a, SortCol (LazyTable a)))
    scrollHandlerTbody = \(RawNode n) _ -> do
      sy <- CurrentScrollY . fromMaybe 0 <$> (fromJSVal =<< n ! "scrollTop")
      return . pur $ \(LazyTable t th rh _ rts sc' rs, sc'') -> (LazyTable t th rh sy rts sc' rs, sc'')

    fakeHeightStyle =
      "height: " <> pack (show (totalRows * rowHeight')) <> "px;"

    fakeRowHeightStyle totalRows' (RowsToShow rts) =
      "height: " <> pack (show ((totalRows' - rts) * rowHeight')) <> "px;"

    lazyTheme :: Theme m (LazyTable a)
    lazyTheme = case theme of
      Theme tp hp hrp rp thp bp dp -> Theme
        { tableProps = \(LazyTable xs' _ _ _ _ _ _) sc' ->
            second mapToLazyTableSc <$> tp xs' (fromLazySortCol sc')
        , headProps = \(LazyTable xs' _ _ _ _ _ _) sc' ->
            second mapToLazyTableSc <$> hp xs' (fromLazySortCol sc')
        , htrProps = \(LazyTable xs' _ _ _ _ _ _) sc' ->
            second mapToLazyTableSc <$> hrp xs' (fromLazySortCol sc')
        , trProps = \(LazyTable xs' _ _ _ rts _ _) sc' r ->
            case r of
              LazyRow r' -> second mapToLazyTableSc <$> rp xs' (fromLazySortCol sc') r'
              FakeRow -> [("style", textProp (fakeRowHeightStyle (countRows xs') rts))]
        , thProps = \(LazyTable xs' _ _ _ _ _ _) sc' (LazyColumn c') ->
            second mapToLazyTableSc <$> thp xs' (fromLazySortCol sc') c'
        , bodyProps = \(LazyTable xs' _ _ _ _ _ _) sc' ->
            (second mapToLazyTableSc <$> bp xs' (fromLazySortCol sc'))
            ++
            (case scrollConfig of
              ContainerIsScrollable _ -> []
              TbodyIsScrollable debounceScroll -> [ listenRaw "scroll" $ debounceScroll scrollHandlerTbody ])
        , tdProps = \(LazyTable xs' _ _ _ _ _ _) sc' r (LazyColumn c') ->
            case r of
              LazyRow r' -> second mapToLazyTable <$> dp xs' (fromLazySortCol sc') r' c'
              FakeRow -> [] }