Shpadoinkle-widgets 0.2.0.0 → 0.2.0.1
raw patch · 15 files changed
+377/−130 lines, 15 filesdep +attoparsecdep +bytestringdep +eitherdep ~transformers
Dependencies added: attoparsec, bytestring, either, servant
Dependency ranges changed: transformers
Files
- CHANGELOG.md +0/−0
- README.md +1/−1
- Shpadoinkle-widgets.cabal +71/−46
- Shpadoinkle/Widgets/Form/Dropdown.hs +11/−5
- Shpadoinkle/Widgets/Table.hs +25/−14
- Shpadoinkle/Widgets/Table/Lazy.hs +161/−48
- Shpadoinkle/Widgets/Types.hs +2/−0
- Shpadoinkle/Widgets/Types/Choice.hs +6/−2
- Shpadoinkle/Widgets/Types/ConsideredChoice.hs +2/−0
- Shpadoinkle/Widgets/Types/Core.hs +11/−2
- Shpadoinkle/Widgets/Types/Form.hs +4/−2
- Shpadoinkle/Widgets/Types/Pagination.hs +68/−0
- Shpadoinkle/Widgets/Types/Physical.hs +8/−8
- Shpadoinkle/Widgets/Types/Remote.hs +2/−1
- Shpadoinkle/Widgets/Types/Search.hs +5/−1
− CHANGELOG.md
README.md view
@@ -1,6 +1,6 @@ # Shpadoinkle Widgets -[](https://gitlab.com/fresheyeball/Shpadoinkle)+[](https://gitlab.com/platonic/shpadoinkle) [](https://shpadoinkle.org/widgets) [](https://opensource.org/licenses/BSD-3-Clause) [](https://builtwithnix.org)
Shpadoinkle-widgets.cabal view
@@ -1,91 +1,115 @@-cabal-version: 1.12---- This file has been generated from package.yaml by hpack version 0.33.0.------ see: https://github.com/sol/hpack------ hash: 200e32bc905bdf7a4b38b56da888233628b9617d7ed23485264f9732aab4c225--name: Shpadoinkle-widgets-version: 0.2.0.0-synopsis: A collection of common reusable types and components.-description: There are many shared abstractions between various UIs that represent themselves in frameworks and applications. This package provides a useful subset of these concepts as types along with implementations consuming these types.-category: Web-author: Isaac Shapira-maintainer: fresheyeball@protonmail.com-license: BSD3-license-file: LICENSE-build-type: Simple+cabal-version: 2.2+name: Shpadoinkle-widgets+version: 0.2.0.1+category: Web+author: Isaac Shapira+maintainer: isaac.shapira@platonic.systems+license: BSD-3-Clause+license-file: LICENSE+build-type: Simple extra-source-files:- README.md- CHANGELOG.md+ README.md+synopsis:+ A collection of common reusable types and components.+description:+ There are many shared abstractions between various UIs+ that represent themselves in frameworks and applications.+ This package provides a useful subset of these concepts+ as types along with implementations consuming these types. + source-repository head type: git- location: https://gitlab.com/fresheyeball/Shpadoinkle.git+ location: https://gitlab.com/platonic/shpadoinkle.git + flag testing description: Provide test kit around QuickCheck manual: True default: False ++common ghc-options+ ghc-options:+ -Wall+ -Wcompat+ -fwarn-redundant-constraints+ -fwarn-incomplete-uni-patterns+ -fwarn-tabs+ -fwarn-incomplete-record-updates+ -fwarn-identities++ library+ import: ghc-options+ exposed-modules:- Shpadoinkle.Widgets.Form.Input- Shpadoinkle.Widgets.Form.Dropdown- Shpadoinkle.Widgets.Table- Shpadoinkle.Widgets.Table.Lazy- Shpadoinkle.Widgets.Types- Shpadoinkle.Widgets.Types.Choice- Shpadoinkle.Widgets.Types.ConsideredChoice- Shpadoinkle.Widgets.Types.Core- Shpadoinkle.Widgets.Types.Form- Shpadoinkle.Widgets.Types.Physical- Shpadoinkle.Widgets.Types.Remote- Shpadoinkle.Widgets.Types.Search- Shpadoinkle.Widgets.Validation- other-modules:- Paths_Shpadoinkle_widgets- hs-source-dirs:- ./.- ghc-options: -Wall -Wcompat -fwarn-redundant-constraints -fwarn-incomplete-uni-patterns -fwarn-tabs -fwarn-incomplete-record-updates -fwarn-identities+ Shpadoinkle.Widgets.Form.Input+ Shpadoinkle.Widgets.Form.Dropdown+ Shpadoinkle.Widgets.Table+ Shpadoinkle.Widgets.Table.Lazy+ Shpadoinkle.Widgets.Types+ Shpadoinkle.Widgets.Types.Choice+ Shpadoinkle.Widgets.Types.ConsideredChoice+ Shpadoinkle.Widgets.Types.Core+ Shpadoinkle.Widgets.Types.Form+ Shpadoinkle.Widgets.Types.Pagination+ Shpadoinkle.Widgets.Types.Physical+ Shpadoinkle.Widgets.Types.Remote+ Shpadoinkle.Widgets.Types.Search+ Shpadoinkle.Widgets.Validation++ hs-source-dirs: .+ build-depends: Shpadoinkle , Shpadoinkle-html+ , attoparsec >=0.13 && <0.15 , aeson >=1.4.4 && <1.6 , base >=4.12.0 && <4.16+ , bytestring >=0.10.8 && <0.12 , compactable >=0.1.2 && <0.2 , containers >=0.6.0 && <0.7 , edit-distance >=0.2.2 && <0.3+ , either >=5.0 && <5.1 , email-validate >=2.3.2 && <2.4 , jsaddle >=0.9.7 && <0.20 , mtl >=2.2.2 && <2.3+ , servant >=0.16 && <0.19 , stm >=2.5.0 && <2.6 , template-haskell >=2.14.0 && <2.17 , text >=1.2.3 && <1.3+ , transformers >=0.5.0 && <0.6 , unliftio >=0.2.12 && <0.3+ if flag(testing) exposed-modules:- Test.QuickCheck.Classes.Hspec- Test.QuickCheck.Classes.FoldableOrd+ Test.QuickCheck.Classes.Hspec+ Test.QuickCheck.Classes.FoldableOrd+ cpp-options: -DTESTING+ build-depends: QuickCheck , hspec , quickcheck-classes , quickcheck-classes-base , transformers+ default-language: Haskell2010 + test-suite unit+ import: ghc-options+ type: exitcode-stdio-1.0+ main-is: Test.hs- other-modules:- Paths_Shpadoinkle_widgets- hs-source-dirs:- tests- ghc-options: -Wall -Wcompat -fwarn-redundant-constraints -fwarn-incomplete-uni-patterns -fwarn-tabs -fwarn-incomplete-record-updates -fwarn-identities++ hs-source-dirs: tests+ cpp-options: -DTESTING+ build-depends: QuickCheck , Shpadoinkle-widgets@@ -94,4 +118,5 @@ , hspec , quickcheck-classes , quickcheck-classes-base+ default-language: Haskell2010
Shpadoinkle/Widgets/Form/Dropdown.hs view
@@ -56,6 +56,7 @@ deriving instance Generic (Dropdown p a) instance (ToJSON a, ToJSON (Selected p a), ToJSON (Considered p a)) => ToJSON (Dropdown p a) instance (FromJSON a, FromJSON (Selected p a), FromJSON (Considered p a), Ord a) => FromJSON (Dropdown p a)+instance (NFData (Selected p a), NFData (ConsideredChoice p a), NFData a) => NFData (Dropdown p a) instance Control (Dropdown 'One) where@@ -77,12 +78,14 @@ open p = shrug $ p { _toggle = open (_toggle p) } -newtype Config m = Config- { _attrs :: forall a. [(Text, Prop m a)] }+data Config m = Config+ { _attrs :: forall a. [(Text, Prop m a)]+ , _clickAway :: ClickAway+ } defConfig :: Config m-defConfig = Config []+defConfig = Config [] ClosesOnClickAway instance (Compactable (ConsideredChoice p)) => Compactable (Dropdown p) where@@ -177,16 +180,19 @@ dropdown toTheme Config {..} x = let Theme {..} = toTheme x+ ifClickAway = case _clickAway of+ ClosesOnClickAway -> [ onClickAway close ]+ StaysOpenOnClickAway -> []+ in injectProps ([onKeyup $ \case Enter -> act UpArrow -> considerPrev DownArrow -> considerNext _ -> id- , onClickAway close , onClick act , tabbable- ] ++ _attrs) . _wrapper $+ ] ++ ifClickAway ++ _attrs) . _wrapper $ _header (selected x) ++ [ _list $ (\y -> injectProps [ onMouseover (consider' y)
Shpadoinkle/Widgets/Table.hs view
@@ -31,13 +31,15 @@ import Control.Arrow (second) import Data.Aeson-import Data.Functor.Identity+import qualified Data.ByteString.Lazy as BSL import Data.Kind import Data.List (sortBy)-import qualified Data.Map as M 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,@@ -47,7 +49,7 @@ data Sort = ASC | DESC- deriving (Show, Eq, Ord, Bounded, Enum, Generic, ToJSON, FromJSON)+ deriving (Show, Read, Eq, Ord, Bounded, Enum, Generic, ToJSON, FromJSON, NFData) instance Semigroup Sort where (<>) = min@@ -61,14 +63,23 @@ 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') @@ -98,9 +109,11 @@ 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 _ = TextNode "↑"+ ascendingIcon _ = text "↑" descendingIcon :: Functor m => Effect a m => Proxy a -> Html m (a, SortCol a)- descendingIcon _ = TextNode "↓"+ 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@@ -161,17 +174,15 @@ filterRow :: Row a -> Html m (a, SortCol a) -> Html m (a, SortCol a) filterRow row el = if f row then el- else runIdentity $ props (Identity . addDisplayNoneStyle) el+ else mapProps addDisplayNoneStyle el - addDisplayNoneStyle :: [(Text, Prop m (a, SortCol a))] -> [(Text, Prop m (a, SortCol a))]- addDisplayNoneStyle ps =- let pMap = M.fromList ps- styleProp = M.lookup "style" pMap in- case styleProp of- Just (PText sty) -> M.toList (M.insert "style" (textProp $ sty <> "; display: none") pMap)- _ -> M.toList (M.insert "style" (textProp "display: none") pMap)+ addDisplayNoneStyle = (<> [("style", textProp "display: none")]) - cth_ c = th (thProps xs s c) . pure . Html.a [ second rightC . onClick $ toggleSort c ]+ 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
Shpadoinkle/Widgets/Table/Lazy.hs view
@@ -1,12 +1,17 @@+{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE ExtendedDefaultRules #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE UndecidableSuperClasses #-} {-# OPTIONS_GHC -Wno-type-defaults #-} @@ -15,9 +20,16 @@ , AssumedTableHeight (..) , CurrentScrollY (..) , LazyTabular (..)- , LazyTable (..)+ , LazyTable (LazyTable) , DebounceScroll , LazyTableScrollConfig (..)+ , Offset (..)+ , Length (..)+ , Page (..)+ , RowsToShow (..)+ , RowsLoaded (..)+ , Paginator (..)+ , lazyLoadingTable , lazyTable ) where @@ -25,15 +37,15 @@ import Prelude hiding (div) import Control.Arrow (second)+import Control.Monad.Trans.Class (lift) 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@@ -42,23 +54,56 @@ default (Text) +second3 :: (b -> b') -> (a, b, c) -> (a, b', c)+second3 f (x, y, z) = (x, f y, z)++ class Tabular a => LazyTabular a where countRows :: a -> Int -data LazyTable a = LazyTable a AssumedTableHeight AssumedRowHeight CurrentScrollY RowsToShow (SortCol a) [Row (LazyTable a)]+data LazyTable a =+ LazyTable+ { tableData :: a+ , tableHeight :: AssumedTableHeight+ , rowHeight :: AssumedRowHeight+ , scrollY :: CurrentScrollY+ , rowsToShow :: RowsToShow+ , _rowsLoaded :: RowsLoaded+ , paginator :: Paginator a+ , _sortCol :: SortCol a+ , rows :: [Row (LazyTable a)]+ } -newtype RowsToShow = RowsToShow Int- deriving (Eq, Ord, Num, Real, Bounded, Enum, Read, Show, ToJSON, FromJSON, Generic)+newtype RowsToShow = RowsToShow { unRowsToShow :: Int }+ deriving (Eq, Ord, Num, Real, Bounded, Enum, Read, Show, Generic, NFData) +instance ToJSON RowsToShow+instance FromJSON RowsToShow+instance ToJSVal RowsToShow+instance FromJSVal RowsToShow ++newtype RowsLoaded = RowsLoaded { unRowsLoaded :: Int }+ deriving (Eq, Ord, Num, Real, Bounded, Enum, Read, Show, Generic, NFData)++instance ToJSON RowsLoaded+instance FromJSON RowsLoaded+instance ToJSVal RowsLoaded+instance FromJSVal RowsLoaded++ data instance (Row (LazyTable a)) = LazyRow (Row a) | FakeRow newtype instance (Column (LazyTable a)) = LazyColumn (Column a) +unLazySortCol :: SortCol (LazyTable a) -> SortCol a+unLazySortCol (SortCol (LazyColumn col) ord) = SortCol col ord++ instance Humanize (Column a) => Humanize (Column (LazyTable a)) where humanize (LazyColumn c) = humanize c @@ -81,11 +126,11 @@ compare (LazyColumn a) (LazyColumn b) = compare a b -instance Tabular a => Tabular (LazyTable a) where+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+ toRows LazyTable {rows} = rows ++ [FakeRow]+ toCell LazyTable {tableData} (LazyRow r) (LazyColumn c) =+ mapToLazyTable <$> toCell tableData r c toCell _ FakeRow _ = [] sortTable sc (LazyRow a) (LazyRow b) = sortTable (fromLazySortCol sc) a b sortTable _ FakeRow FakeRow = EQ@@ -93,26 +138,31 @@ sortTable _ FakeRow _ = GT ascendingIcon _ = mapToLazyTableSc $ ascendingIcon Proxy descendingIcon _ = mapToLazyTableSc $ descendingIcon Proxy+ handleSort LazyTable {tableData, rowsToShow, paginator} sc = voidRunContinuationT $ do+ tableData' <- lift $ unPaginator paginator tableData (unLazySortCol sc) (Page 0 (Length (unRowsToShow rowsToShow)))+ commit . pur $ \(LazyTable _ th' rh' sy' rts' _ paginator' _ _, sc') ->+ (LazyTable tableData' th' rh' sy' rts'+ (RowsLoaded (unRowsToShow rowsToShow))+ paginator'+ (unLazySortCol sc')+ (LazyRow <$> toRows tableData')+ , sc') -- 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)+ deriving (Eq, Ord, Generic, ToJSON, FromJSON, Read, Show, Num, Enum, Real, Integral, NFData) 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)+ deriving (Eq, Ord, Generic, ToJSON, FromJSON, Read, Show, Num, Enum, Real, Integral, NFData) 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))+data LazyTableScrollConfig m a b = ContainerIsScrollable (DebounceScroll m (b, CurrentScrollY, RowsLoaded)) | TbodyIsScrollable (DebounceScroll m (LazyTable a, SortCol (LazyTable a))) deriving Generic @@ -126,53 +176,68 @@ 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 ))+ => LazyTable a+ -> f m (LazyTable a, SortCol (LazyTable a))+ -> f m ((a, SortCol a), CurrentScrollY, RowsLoaded)+mapFromLazyTableSc (LazyTable _xs tableHeight rowHeight _sy _rts _rl paginator _sc _rs) = liftC+ (\(LazyTable tab _ _ sy _ rl _ _ _, sc') _ -> ((tab, fromLazySortCol sc'), sy, rl))+ (\((tab, sc), sy, rl) -> ( toLazyTable tableHeight rowHeight sy rl paginator tab sc+ , toLazySortCol sc )) -mapToLazyTable :: Functor m => Continuous f => Tabular a+mapToLazyTable :: forall m a f. 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)+ (\tab (LazyTable _ tableHeight rowHeight scrollY _ rowsLoaded paginator sc _)+ -> toLazyTable tableHeight rowHeight scrollY rowsLoaded paginator 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+ (\(tab, sc) (LazyTable _ tableHeight rowHeight scrollY _ rowsLoaded paginator _ _, _)+ -> ( toLazyTable tableHeight rowHeight scrollY rowsLoaded paginator tab sc , toLazySortCol sc ))- (\(LazyTable tab _ _ _ _ _ _, sc) -> (tab, fromLazySortCol sc))+ (\(LazyTable {tableData}, sc) -> (tableData, 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+ -> RowsLoaded -> Paginator a -> a -> SortCol a -> LazyTable a+toLazyTable tabh rowh sy rowsLoaded paginator xs sc+ = LazyTable xs tabh rowh sy (RowsToShow numRows) rowsLoaded paginator sc . fmap LazyRow- . take rowsToShow+ . take numRows . sortBy (sortTable sc) . filter (toFilter xs) $ toRows xs+ where numRows = computeRowsToShow tabh rowh sy+++computeRowsToShow :: AssumedTableHeight -> AssumedRowHeight -> CurrentScrollY+ -> Int+computeRowsToShow (AssumedTableHeight height) (AssumedRowHeight rowHeight) (CurrentScrollY scrollY) =+ 1 + truncate (pixelsToFill / fromIntegral rowHeight) 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) +-- | A Paginator takes a tabular data type `a` and a sort order and a page and returns an action which yields a new tabular value with the values in the given page range included.+newtype Paginator a = Paginator { unPaginator :: forall m. ( Applicative m, Effect a m ) => a -> SortCol a -> Page -> m a } ++-- | A trivialPaginator is a no-op paginator, for when the data is all there already.+trivialPaginator :: Paginator a+trivialPaginator = Paginator (\x _ _ -> pure x)++ lazyTable :: forall m a b. ( LazyTabular a+ , Monad m , Effect a m- , MonadJSM m , Humanize (Column a) , Bounded (Column a) , Ord (Column a)@@ -186,7 +251,41 @@ -> SortCol a -> CurrentScrollY -> Html m (b, CurrentScrollY)-lazyTable theme tableHeight rowHeight@(AssumedRowHeight rowHeight')+lazyTable theme tableHeight rowHeight scrollConfig container xs sc scrollY+ = removeRowsLoaded $+ lazyLoadingTable trivialPaginator (RowsLoaded 0) theme tableHeight rowHeight scrollConfig+ liftedContainer xs sc scrollY+ where+ liftedContainer = addRowsLoaded . container . removeRowsLoaded++ addRowsLoaded :: Continuous f => f m (x, y) -> f m (x, y, RowsLoaded)+ addRowsLoaded = liftC (\(x,y) (_,_,r) -> (x,y,r)) (\(x,y,_) -> (x,y))++ removeRowsLoaded :: Continuous f => f m (x, y, RowsLoaded) -> f m (x, y)+ removeRowsLoaded = liftC (\(x,y,_) _ -> (x,y)) (\(x,y) -> (x,y,0))+++lazyLoadingTable :: forall m a b.+ ( LazyTabular a+ , Monad m+ , Effect a m+ , Humanize (Column a)+ , Bounded (Column a)+ , Ord (Column a)+ , Enum (Column a) )+ => Paginator a+ -> RowsLoaded+ -> Theme m a+ -> AssumedTableHeight+ -> AssumedRowHeight+ -> LazyTableScrollConfig m a b+ -> (Html m ((a, SortCol a), CurrentScrollY, RowsLoaded)+ -> Html m (b, CurrentScrollY, RowsLoaded))+ -> a+ -> SortCol a+ -> CurrentScrollY+ -> Html m (b, CurrentScrollY, RowsLoaded)+lazyLoadingTable paginator rowsLoaded theme tableHeight rowHeight@(AssumedRowHeight rowHeight') scrollConfig container xs sc@(SortCol c s) scrollY = addContainerScrollHandler . container@@ -194,7 +293,7 @@ . mapFromLazyTableSc lazyTab $ viewWith lazyTheme lazyTab (SortCol (LazyColumn c) s) where- lazyTab@LazyTable {} = toLazyTable tableHeight rowHeight scrollY xs sc+ lazyTab@LazyTable {} = toLazyTable tableHeight rowHeight scrollY rowsLoaded paginator xs sc totalRows = countRows xs @@ -204,17 +303,31 @@ addContainerScrollHandler = case scrollConfig of ContainerIsScrollable debounceScroll ->- runIdentity . props (Identity . (listenRaw "scroll" (debounceScroll scrollHandlerContainer) :))+ mapProps ([listenRaw "scroll" (debounceScroll scrollHandlerContainer)] <>) TbodyIsScrollable _ -> id scrollHandlerContainer (RawNode n) _ =- pur . second . const . CurrentScrollY . fromMaybe 0+ pur . second3 . 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'')+ let totalRows' = computeRowsToShow tableHeight rowHeight sy+ offset = Offset $ unRowsLoaded rowsLoaded+ newRows = Length $ totalRows' - unRowsLoaded rowsLoaded+ if newRows > 0+ then return . voidRunContinuationT $ do+ xs' <- lift $ unPaginator paginator xs sc (Page offset newRows)+ commit . pur $ \(LazyTable {tableHeight = tableHeight', rowHeight = rowHeight'', paginator = paginator'}, sc') ->+ (LazyTable xs' tableHeight' rowHeight'' sy+ (RowsToShow totalRows')+ (RowsLoaded totalRows')+ paginator'+ (unLazySortCol sc')+ (LazyRow <$> toRows xs')+ , sc')+ else return . pur $ \(tab, sc') -> (tab { scrollY = sy }, sc') fakeHeightStyle = "height: " <> pack (show (totalRows * rowHeight')) <> "px;"@@ -225,25 +338,25 @@ lazyTheme :: Theme m (LazyTable a) lazyTheme = case theme of Theme tp hp hrp rp thp bp dp -> Theme- { tableProps = \(LazyTable xs' _ _ _ _ _ _) sc' ->+ { tableProps = \LazyTable {tableData = xs'} sc' -> second mapToLazyTableSc <$> tp xs' (fromLazySortCol sc')- , headProps = \(LazyTable xs' _ _ _ _ _ _) sc' ->+ , headProps = \LazyTable {tableData = xs'} sc' -> second mapToLazyTableSc <$> hp xs' (fromLazySortCol sc')- , htrProps = \(LazyTable xs' _ _ _ _ _ _) sc' ->+ , htrProps = \LazyTable {tableData = xs'} sc' -> second mapToLazyTableSc <$> hrp xs' (fromLazySortCol sc')- , trProps = \(LazyTable xs' _ _ _ rts _ _) sc' r ->+ , trProps = \LazyTable {tableData = xs', rowsToShow = 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') ->+ , thProps = \LazyTable {tableData = xs'} sc' (LazyColumn c') -> second mapToLazyTableSc <$> thp xs' (fromLazySortCol sc') c'- , bodyProps = \(LazyTable xs' _ _ _ _ _ _) sc' ->+ , bodyProps = \LazyTable {tableData = 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') ->+ , tdProps = \LazyTable {tableData = xs'} sc' r (LazyColumn c') -> case r of LazyRow r' -> second mapToLazyTable <$> dp xs' (fromLazySortCol sc') r' c' FakeRow -> [] }
Shpadoinkle/Widgets/Types.hs view
@@ -3,6 +3,7 @@ , module Shpadoinkle.Widgets.Types.Choice , module Shpadoinkle.Widgets.Types.ConsideredChoice , module Shpadoinkle.Widgets.Types.Form+ , module Shpadoinkle.Widgets.Types.Pagination , module Shpadoinkle.Widgets.Types.Physical , module Shpadoinkle.Widgets.Types.Remote , module Shpadoinkle.Widgets.Types.Search@@ -13,6 +14,7 @@ import Shpadoinkle.Widgets.Types.ConsideredChoice import Shpadoinkle.Widgets.Types.Core import Shpadoinkle.Widgets.Types.Form+import Shpadoinkle.Widgets.Types.Pagination import Shpadoinkle.Widgets.Types.Physical import Shpadoinkle.Widgets.Types.Remote import Shpadoinkle.Widgets.Types.Search
Shpadoinkle/Widgets/Types/Choice.hs view
@@ -1,6 +1,7 @@ {-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-}@@ -13,6 +14,7 @@ {-# LANGUAGE ViewPatterns #-} #ifdef TESTING+{-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE QuantifiedConstraints #-} #endif@@ -30,6 +32,7 @@ import Data.Proxy import Data.Set as Set import GHC.Generics (Generic)+import Shpadoinkle (NFData) #ifdef TESTING import Data.Monoid (Sum (..)) import Test.QuickCheck@@ -40,7 +43,7 @@ data Pick = One | AtleastOne | Many- deriving (Eq, Ord, Show, Generic)+ deriving (Eq, Ord, Show, Generic, NFData) type family Selected (p :: Pick) (a :: Type) :: Type where@@ -60,6 +63,7 @@ deriving instance (Eq (Selected p a), Eq a) => Eq (Choice p a) deriving instance (Ord (Selected p a), Ord a) => Ord (Choice p a) deriving instance Generic (Choice p a)+instance (NFData (Selected p a), NFData a) => NFData (Choice p a) instance (ToJSON (Selected p a), ToJSON a) => ToJSON (Choice p a) instance (FromJSON (Selected p a), FromJSON a, Ord a) => FromJSON (Choice p a) @@ -192,7 +196,7 @@ newtype ApplyOrd f a = ApplyOrd { unApplyOrd :: f a } deriving instance (forall x. Eq x => Eq (f x), Eq a) => Eq (ApplyOrd f a) deriving instance (forall x. Show x => Show (f x), Show a) => Show (ApplyOrd f a)-deriving instance+deriving newtype instance ( forall x. (Ord x, Arbitrary x) => Arbitrary (f x) , Ord a , Arbitrary a
Shpadoinkle/Widgets/Types/ConsideredChoice.hs view
@@ -25,6 +25,7 @@ import Data.Proxy import Data.Set as Set import GHC.Generics (Generic)+import Shpadoinkle (NFData) #ifdef TESTING import Test.QuickCheck (Arbitrary (..)) #endif@@ -45,6 +46,7 @@ deriving instance (Ord (Selected p a), Ord (Considered p a), Ord a) => Ord (ConsideredChoice p a) deriving instance (Foldable (Choice p), Foldable (Considered p)) => Foldable (ConsideredChoice p) deriving instance Generic (ConsideredChoice p a)+instance (NFData (Selected p a), NFData (Considered p a), NFData a) => NFData (ConsideredChoice p a) instance (FromJSON a, FromJSON (Considered p a), FromJSON (Selected p a), Ord a) => FromJSON (ConsideredChoice p a) instance (ToJSON a, ToJSON (Considered p a), ToJSON (Selected p a)) => ToJSON (ConsideredChoice p a)
Shpadoinkle/Widgets/Types/Core.hs view
@@ -27,9 +27,13 @@ data Hygiene = Clean | Dirty- deriving (Eq, Ord, Show, Read, Enum, Bounded, Generic, ToJSON, FromJSON)+ deriving (Eq, Ord, Show, Read, Enum, Bounded, Generic, ToJSON, FromJSON, NFData) +data ClickAway = ClosesOnClickAway | StaysOpenOnClickAway+ deriving (Eq, Ord, Show, Read, Enum, Bounded, Generic, ToJSON, FromJSON, NFData)++ instance Semigroup Hygiene where Clean <> Clean = Clean _ <> _ = Dirty@@ -40,7 +44,7 @@ data Ability = Enabled | Disabled- deriving (Eq, Ord, Show, Enum, Bounded)+ deriving (Eq, Ord, Show, Read, Enum, Bounded, Generic, ToJSON, FromJSON, NFData) toBool :: Ability -> Bool@@ -60,6 +64,10 @@ {-# INLINE humanize #-} +instance Humanize () where+ humanize _ = pack "∅"++ instance Humanize Text where humanize = id {-# INLINE humanize #-}@@ -78,6 +86,7 @@ instance {-# OVERLAPPABLE #-} Humanize a => Present a+ #ifdef TESTING instance Arbitrary Hygiene where arbitrary = arbitraryBoundedEnum
Shpadoinkle/Widgets/Types/Form.hs view
@@ -36,13 +36,14 @@ import Test.QuickCheck (Arbitrary (..), elements) #endif +import Shpadoinkle (NFData) import Shpadoinkle.Widgets.Types.Core (Hygiene) data Input a = Input { _hygiene :: Hygiene , _value :: a- } deriving (Eq, Ord, Show, Read, Functor, Traversable, Foldable, Generic, ToJSON, FromJSON)+ } deriving (Eq, Ord, Show, Read, Functor, Traversable, Foldable, Generic, ToJSON, FromJSON, NFData) #ifdef TESTING@@ -90,10 +91,11 @@ newtype Placeholder = Placeholder { unPlaceholder :: Text } deriving newtype (Eq, Ord, Show, Read, IsString, Semigroup, Monoid, ToJSON, FromJSON) deriving stock Generic+ deriving anyclass NFData data Validated e a = Validated a | Invalid e [e]- deriving (Eq, Ord, Show, Read, Generic, ToJSON, FromJSON, Functor, Foldable, Traversable)+ deriving (Eq, Ord, Show, Read, Generic, ToJSON, FromJSON, Functor, Foldable, Traversable, NFData) instance Semigroup (Validated e a) where
+ Shpadoinkle/Widgets/Types/Pagination.hs view
@@ -0,0 +1,68 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}+++module Shpadoinkle.Widgets.Types.Pagination+ ( CurrentScrollY (..)+ , Offset (..)+ , Length (..)+ , Page (..)+ ) where+++import Data.Aeson+import qualified Data.Attoparsec.Text as A+import Data.Either.Combinators (mapLeft)+import Data.Text (pack)+import GHC.Generics+import Language.Javascript.JSaddle hiding (JSM, MonadJSM)+import Servant.API (FromHttpApiData (..),+ ToHttpApiData (..))+import Shpadoinkle+++newtype CurrentScrollY = CurrentScrollY Int -- measured in pixels+ deriving (Eq, Ord, Generic, ToJSON, FromJSON, Read, Show, Num, Enum, Real, Integral, NFData)+++newtype Length = Length Int+ deriving (Eq, Ord, Generic, Read, Show, Num, Enum, Real, Integral, ToHttpApiData, FromHttpApiData)++instance ToJSON Length+instance FromJSON Length+instance ToJSVal Length+instance FromJSVal Length+instance NFData Length+++newtype Offset = Offset Int+ deriving (Eq, Ord, Generic, Read, Show, Num, Enum, Real, Integral, ToHttpApiData, FromHttpApiData)++instance ToJSON Offset+instance FromJSON Offset+instance ToJSVal Offset+instance FromJSVal Offset+instance NFData Offset+++data Page = Page { pageOffset :: Offset, pageLength :: Length }+ deriving (Eq, Ord, Generic, Read, Show)++instance ToJSON Page+instance FromJSON Page+instance ToJSVal Page+instance FromJSVal Page+instance NFData Page++instance ToHttpApiData Page where+ toUrlPiece (Page off len) = toUrlPiece off <> "," <> toUrlPiece len+ toQueryParam pg = toUrlPiece pg++instance FromHttpApiData Page where+ parseUrlPiece = (mapLeft pack .) . A.parseOnly $ do+ off <- Offset <$> A.signed A.decimal+ _ <- A.char ','+ len <- Length <$> A.signed A.decimal+ return $ Page off len
Shpadoinkle/Widgets/Types/Physical.hs view
@@ -9,23 +9,23 @@ import Data.Aeson-import Data.Functor.Identity import GHC.Generics #ifdef TESTING import Test.QuickCheck (Arbitrary (..), arbitraryBoundedEnum) #endif +import Shpadoinkle (NFData) import Shpadoinkle.Html hiding (s) import Shpadoinkle.Widgets.Types.Core data Toggle = Closed Hygiene | Open- deriving (Eq, Ord, Show, Read, Generic, ToJSON, FromJSON)+ deriving (Eq, Ord, Show, Read, Generic, ToJSON, FromJSON, NFData) data Hover = MouseOver | MouseOut- deriving (Eq, Ord, Enum, Bounded, Show, Read, Generic, ToJSON, FromJSON)+ deriving (Eq, Ord, Enum, Bounded, Show, Read, Generic, ToJSON, FromJSON, NFData) instance Semigroup Hover where@@ -41,10 +41,10 @@ withHover :: ((Hover, a) -> Html m (Hover, a)) -> (Hover, a) -> Html m (Hover, a)-withHover f = runIdentity . props- (Identity . mappend [ onMouseenter $ (MouseOver, ) . snd- , onMouseleave $ (MouseOut, ) . snd- ]) . f+withHover f =+ injectProps [ onMouseenter $ (MouseOver, ) . snd+ , onMouseleave $ (MouseOut, ) . snd+ ] . f togHygiene :: Toggle -> Hygiene@@ -101,7 +101,7 @@ data Visbility = Visible | Hidden- deriving (Eq, Ord, Show, Enum, Bounded, Generic)+ deriving (Eq, Ord, Show, Read, Enum, Bounded, Generic) #ifdef TESTING
Shpadoinkle/Widgets/Types/Remote.hs view
@@ -10,6 +10,7 @@ import Control.Applicative import Data.Aeson (FromJSON, ToJSON) import GHC.Generics+import Shpadoinkle (NFData) #ifdef TESTING import Test.QuickCheck (Arbitrary (..), elements) #endif@@ -20,7 +21,7 @@ | Failure e | Loading | NotAsked- deriving (Eq, Ord, Show, Read, Generic, Functor, Foldable, Traversable, ToJSON, FromJSON)+ deriving (Eq, Ord, Show, Read, Generic, Functor, Foldable, Traversable, ToJSON, FromJSON, NFData) instance Applicative (Remote e) where
Shpadoinkle/Widgets/Types/Search.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}@@ -16,20 +17,23 @@ import Data.Text (Text, isInfixOf, splitOn, strip, toLower, unpack) import GHC.Generics (Generic)+import Shpadoinkle (NFData) import Text.EditDistance (defaultEditCosts, levenshteinDistance) newtype Search = Search { unSearch :: Text } deriving newtype (Eq, Ord, Show, Read, IsString, Semigroup, Monoid, ToJSON, FromJSON) deriving stock Generic+ deriving anyclass NFData newtype EditDistance = EditDistance { unEditDistance :: Int } deriving newtype (Eq, Ord, Show, Read, ToJSON, FromJSON) deriving stock Generic+ deriving anyclass NFData -data Levenshtiened a = Levenshtiened { _distance :: !EditDistance, _unLevenshtiened :: a } deriving Eq+data Levenshtiened a = Levenshtiened { _distance :: !EditDistance, _unLevenshtiened :: a } deriving (Eq, Show, Read, Generic, NFData) instance Eq a => Ord (Levenshtiened a) where compare (Levenshtiened x _) (Levenshtiened y _) = unEditDistance x `compare` unEditDistance y