{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}
module Shpadoinkle.Widgets.Table
( Sort (..)
, SortCol (..)
, compareOn
, negateSort
, Tabular (..)
, Column, Row
, Theme (..)
, toggleSort
, view
, viewWith
) where
import Control.Arrow (second)
import Data.Aeson
import qualified Data.ByteString.Lazy as BSL
import Data.Kind
import Data.List (sortBy)
import Data.Proxy
import Data.Text
import Data.Text.Encoding (decodeUtf8, encodeUtf8)
import GHC.Generics
import Servant.API (FromHttpApiData (..),
ToHttpApiData (..))
import Shpadoinkle
import Shpadoinkle.Html hiding (a, a', max, min, s, s', u,
u')
import qualified Shpadoinkle.Html as Html
import Shpadoinkle.Widgets.Types
data Sort = ASC | DESC
deriving (Show, Read, Eq, Ord, Bounded, Enum, Generic, ToJSON, FromJSON, NFData)
instance Semigroup Sort where (<>) = min
instance Monoid Sort where mempty = maxBound
negateSort :: Sort -> Sort
negateSort ASC = DESC
negateSort DESC = ASC
data SortCol a = SortCol (Column a) Sort
deriving instance Show (Column a) => Show (SortCol a)
deriving instance Read (Column a) => Read (SortCol a)
deriving instance Eq (Column a) => Eq (SortCol a)
deriving instance Ord (Column a) => Ord (SortCol a)
deriving instance Functor Column => Functor SortCol
deriving instance Generic (SortCol a)
instance NFData (Column a) => NFData (SortCol a)
instance (ToJSON (Column a)) => ToJSON (SortCol a)
instance (FromJSON (Column a)) => FromJSON (SortCol a)
instance ToJSON (Column a) => ToHttpApiData (SortCol a) where
toUrlPiece = decodeUtf8 . BSL.toStrict . encode
toQueryParam = toUrlPiece
instance FromJSON (Column a) => FromHttpApiData (SortCol a) where
parseUrlPiece = maybe (Left "could not decode SortCol JSON") Right . decode . BSL.fromStrict . encodeUtf8
instance Ord (Column a) => Semigroup (SortCol a) where
SortCol a s <> SortCol a' s' = SortCol (max a a') (min s s')
instance ( Bounded (Column a)
, Ord (Column a)
, Enum (Column a)
) => Monoid (SortCol a) where
mempty = SortCol minBound maxBound
compareOn :: Ord a => Sort -> a -> a -> Ordering
compareOn DESC = compare
compareOn ASC = flip compare
data family Column (a :: Type) :: Type
data family Row (a :: Type) :: Type
class Tabular a where
type Effect a (m :: Type -> Type) :: Constraint
type Effect a m = Applicative m
toRows :: a -> [Row a]
toFilter :: a -> (Row a -> Bool)
toFilter = const (const True)
toCell :: Functor m => Effect a m => a -> Row a -> Column a -> [Html m a]
sortTable :: SortCol a -> Row a -> Row a -> Ordering
ascendingIcon :: Functor m => Effect a m => Proxy a -> Html m (a, SortCol a)
ascendingIcon _ = text "↑"
descendingIcon :: Functor m => Effect a m => Proxy a -> Html m (a, SortCol a)
descendingIcon _ = text "↓"
handleSort :: Monad m => Effect a m => a -> SortCol a -> Continuation m (a, SortCol a)
handleSort _ _ = pur id
toggleSort :: Eq (Column a) => Column a -> SortCol a -> SortCol a
toggleSort c (SortCol c' s) = if c == c' then SortCol c $ negateSort s else SortCol c mempty
data Theme m a = Theme
{ tableProps :: a -> SortCol a -> [(Text, Prop m (a, SortCol a))]
, headProps :: a -> SortCol a -> [(Text, Prop m (a, SortCol a))]
, htrProps :: a -> SortCol a -> [(Text, Prop m (a, SortCol a))]
, trProps :: a -> SortCol a -> Row a -> [(Text, Prop m (a, SortCol a))]
, thProps :: a -> SortCol a -> Column a -> [(Text, Prop m (a, SortCol a))]
, bodyProps :: a -> SortCol a -> [(Text, Prop m (a, SortCol a))]
, tdProps :: a -> SortCol a -> Row a -> Column a -> [(Text, Prop m a)]
} deriving Generic
instance Semigroup (Theme m a) where
Theme t u v w x y z <> Theme t' u' v' w' x' y' z' =
Theme (t <> t') (u <> u') (v <> v') (w <> w') (x <> x') (y <> y') (z <> z')
instance Monoid (Theme m a) where
mempty = Theme mempty mempty mempty mempty mempty mempty mempty
view :: forall m a.
( Tabular a
, Effect a m
, Monad m
, Humanize (Column a)
, Bounded (Column a)
, Ord (Column a)
, Enum (Column a) )
=> a -> SortCol a -> Html m (a, SortCol a)
view = viewWith mempty
viewWith :: forall m a.
( Tabular a
, Effect a m
, Monad m
, Humanize (Column a)
, Bounded (Column a)
, Ord (Column a)
, Enum (Column a) )
=> Theme m a -> a -> SortCol a -> Html m (a, SortCol a)
viewWith Theme {..} xs s@(SortCol sorton sortorder) =
table (tableProps xs s)
[ thead (headProps xs s) [ tr (htrProps xs s) $ cth_ <$> [minBound..maxBound] ]
, tbody (bodyProps xs s) $ do
row <- sortBy (sortTable s) (toRows xs)
return . filterRow row . tr (trProps xs s row) . fmap leftC $
(\c -> td (tdProps xs s row c) $ toCell xs row c) <$> [minBound..maxBound]
]
where
f = toFilter xs
filterRow :: Row a -> Html m (a, SortCol a) -> Html m (a, SortCol a)
filterRow row el = if f row then el
else mapProps addDisplayNoneStyle el
addDisplayNoneStyle = (<> [("style", textProp "display: none")])
cth_ c = th (thProps xs s c) . pure . Html.a
[ onClickC . voidRunContinuationT $ do
commit . pur . second $ toggleSort c
commit . kleisli $ \(xs', s') -> return $ handleSort xs' s'
]
. mappend [ text (humanize c) ] . pure $
if c == sorton then
case sortorder of ASC -> ascendingIcon Proxy; DESC -> descendingIcon Proxy
else ""