{-# 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
newtype AssumedRowHeight = AssumedRowHeight Int
deriving (Eq, Ord, Generic, ToJSON, FromJSON, Read, Show, Num, Enum, Real, Integral)
newtype AssumedTableHeight = AssumedTableHeight Int
deriving (Eq, Ord, Generic, ToJSON, FromJSON, Read, Show, Num, Enum, Real, Integral)
newtype CurrentScrollY = CurrentScrollY Int
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
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 -> [] }