Shpadoinkle-widgets 0.0.0.2 → 0.1.0.0

raw patch · 12 files changed

+414/−87 lines, 12 filesdep ~aesondep ~basePVP ok

version bump matches the API change (PVP)

Dependency ranges changed: aeson, base

API changes (from Hackage documentation)

Files

• LICENSE +21/−20
• README.md +1/−0
• Shpadoinkle-widgets.cabal +7/−6
• Shpadoinkle/Widgets/Form/Dropdown.hs +25/−25
• Shpadoinkle/Widgets/Form/Input.hs +6/−6
• Shpadoinkle/Widgets/Table.hs +50/−21
• Shpadoinkle/Widgets/Table/Lazy.hs +249/−0
• Shpadoinkle/Widgets/Types/Choice.hs +7/−2
• Shpadoinkle/Widgets/Types/Form.hs +1/−0
• Shpadoinkle/Widgets/Types/Physical.hs +15/−0
• Shpadoinkle/Widgets/Types/Remote.hs +23/−3
• Shpadoinkle/Widgets/Types/Search.hs +9/−4

@@ -1,26 +1,27 @@-Shpadoinkle Widgets, I think I know exactly what it means-Copyright © 2019 Isaac Shpaira+Shpadoinkle Widgets aka S11 Widgets+Copyright © 2020 Isaac Shapira All rights reserved.  Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met:-1. Redistributions of source code must retain the above copyright-notice, this list of conditions and the following disclaimer.-2. Redistributions in binary form must reproduce the above copyright-notice, this list of conditions and the following disclaimer in the-documentation and/or other materials provided with the distribution.-3. Neither the name of the <`3:organization`> nor the-names of its contributors may be used to endorse or promote products-derived from this software without specific prior written permission. -THIS SOFTWARE IS PROVIDED BY <|2|> ''AS IS'' AND ANY-EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED-WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE-DISCLAIMED. IN NO EVENT SHALL <|2|> BE LIABLE FOR ANY-DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES-(INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;-LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND-ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT-(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS-SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.+ * Redistributions of source code must retain the above copyright notice,+   this list of conditions and the following disclaimer.+ * Redistributions in binary form must reproduce the above copyright+   notice, this list of conditions and the following disclaimer in the+   documentation and/or other materials provided with the distribution.+ * Neither the name of Shpadoinkle nor the names of its contributors may be+   used to endorse or promote products derived from this software without+   specific prior written permission. +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"+AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE+IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE+ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE+LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR+CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF+SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS+INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN+CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)+ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE+POSSIBILITY OF SUCH DAMAGE.

@@ -1,6 +1,7 @@ # Shpadoinkle Widgets  [![Goldwater](https://gitlab.com/fresheyeball/Shpadoinkle/badges/master/pipeline.svg)](https://gitlab.com/fresheyeball/Shpadoinkle)+[![Haddock](https://img.shields.io/badge/haddock-master-informational)](https://shpadoinkle.org/widgets) [![BSD-3](https://img.shields.io/badge/License-BSD%203--Clause-blue.svg)](https://opensource.org/licenses/BSD-3-Clause) [![built with nix](https://img.shields.io/badge/built%20with-nix-41439a)](https://builtwithnix.org) [![Hackage](https://img.shields.io/hackage/v/Shpadoinkle-widgets.svg)](https://hackage.haskell.org/package/Shpadoinkle-widgets)

@@ -4,12 +4,12 @@ -- -- see: https://github.com/sol/hpack ----- hash: 542838a3f2738fff3b9af0f7f7470de5a4419203571bffab2e09a3a3c97fc472+-- hash: 3dd750fddc520269eb2759eb0dfadb6e7617b86f52611b35e5ea407a7b13ca37  name:           Shpadoinkle-widgets-version:        0.0.0.2+version:        0.1.0.0 synopsis:       A collection of common reusable types and components.-description:    There are many shared abstractions between various UI's that represent themselves in frameworks, and applications. This package provides a useful subset of these concepts as types. Along with implimentations consuming these types.+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@@ -29,6 +29,7 @@       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.Core@@ -45,8 +46,8 @@   build-depends:       Shpadoinkle     , Shpadoinkle-html-    , aeson >=1.4.4 && <1.5-    , base >=4.12.0 && <4.15+    , aeson >=1.4.4 && <1.6+    , base >=4.12.0 && <4.16     , compactable >=0.1.2 && <0.2     , containers >=0.6.0 && <0.7     , edit-distance >=0.2.2 && <0.3@@ -70,7 +71,7 @@   build-depends:       QuickCheck     , Shpadoinkle-widgets-    , base >=4.12.0 && <4.15+    , base >=4.12.0 && <4.16     , containers     , hspec   default-language: Haskell2010

@@ -28,7 +28,8 @@   import           Shpadoinkle-import           Shpadoinkle.Html          hiding (p, s, s', selected)+import           Shpadoinkle.Html          hiding (p, s, s', select, select',+                                            selected) import           Shpadoinkle.Keyboard import           Shpadoinkle.Widgets.Types @@ -37,9 +38,9 @@   data Dropdown p a = Dropdown-  { _considered :: ConsideredChoice p a-  , _toggle     :: Toggle-  }+    { _considered :: ConsideredChoice p a+    , _toggle     :: Toggle+    }   deriving instance (Show (Selected p a), Show (Considered p a), Show a)        => Show (Dropdown p a)@@ -123,30 +124,30 @@   shrug (Dropdown c xs) = Dropdown (shrug c) xs  -data Theme m = Theme-  { _wrapper :: forall a. [Html m a] -> Html m a-  , _header  :: forall a. [Html m a] -> [Html m a]-  , _list    :: forall a. [Html m a] -> Html m a-  , _item    :: forall a. [Html m a] -> Html m a-  }+data Theme m p b = Theme+    { _wrapper :: forall a . [Html m a]  -> Html m a+    , _header  :: forall a . Selected p b -> [Html m a]+    , _list    :: forall a . [Html m a]  -> Html m a+    , _item    :: forall a . b            -> Html m a+    }  -semantic :: Dropdown p b -> Theme m+semantic :: Present b => Present (Selected p b) => Dropdown p b -> Theme m p b semantic Dropdown {..} = Theme   { _wrapper = div-    [ className [ ("dropdown", True)-                , ("ui",       True)-                , ("active", _toggle == Open) ]+    [ class' [ ("dropdown", True)+             , ("ui",       True)+             , ("active", _toggle == Open) ]     ]   , _header  = \cs ->-    [ div [ class' "text" ] cs-    , i' [ className ["dropdown", "icon"] ]+    [ div [ class' "text" ] (present cs)+    , i' [ class' ["dropdown", "icon"] ]     ]   , _list    = div-    [ className [ "menu"-                , "transition" ]+    [ class' [ "menu"+             , "transition" ]     ]-  , _item    = div [ className "item" ]+  , _item    = div [ class' "item" ] . present   }  @@ -166,15 +167,14 @@   ( Considered p ~ Maybe   , Consideration Dropdown p   , Consideration ConsideredChoice p-  , Present (Selected p a), Present a, Ord a-  , MonadJSM m-  ) => (forall b. Dropdown p b -> Theme m)+  , Ord a+  ) => (Dropdown p a -> Theme m p a)     -> Config m -> Dropdown p a -> Html m (Dropdown p a) dropdown toTheme Config {..} x =   let     Theme {..} = toTheme x   in injectProps-  ([onKeyup' $ \case+  ([onKeyup $ \case     Enter     -> act x     UpArrow   -> considerPrev x     DownArrow -> considerNext x@@ -182,11 +182,11 @@   , onClick $ act x   , tabbable   ] ++ _attrs) . _wrapper $-  (_header . present $ selected x) +++  (_header $ selected x) ++   [ _list $ (\y -> injectProps     [ onMouseover $ consider' y x     , onFocus     $ consider' y x     , onClick     $ select' x y     , tabbable-    ] . _item $ present y) <$> toList (unselected x)+    ] . _item $ y) <$> toList (unselected x)   ]

@@ -17,10 +17,10 @@ import           Shpadoinkle.Widgets.Types.Search  -type Config m a = Props m (Input a)+type Config m a = [(Text, Prop m (Input a))]  -mkInput :: MonadJSM m => Text -> (Text -> a) -> (a -> Text) -> Config m a -> Input a -> Html m (Input a)+mkInput :: Text -> (Text -> a) -> (a -> Text) -> Config m a -> Input a -> Html m (Input a) mkInput t to from attrs inp = Html.input   ( Html.value (from $ Form._value inp)   : Html.onInput (Input Dirty . to)@@ -28,23 +28,23 @@   : attrs ) []  -fractional :: MonadJSM m => Fractional n => Show n => Config m n -> Input n -> Html m (Input n)+fractional :: Fractional n => Show n => Config m n -> Input n -> Html m (Input n) fractional cfg inp = mkInput "number" to (pack . show) cfg inp where   to t = case double t of     Right (d,"") -> realToFrac d     _            -> _value inp  -integral :: MonadJSM m => Integral n => Show n => Config m n -> Input n -> Html m (Input n)+integral :: Integral n => Show n => Config m n -> Input n -> Html m (Input n) integral cfg inp = mkInput "number" to (pack . show) cfg inp where   to t = case double t of     Right (d,"") -> round d     _            -> _value inp  -search :: MonadJSM m => Config m Search -> Input Search -> Html m (Input Search)+search :: Config m Search -> Input Search -> Html m (Input Search) search = mkInput "search" coerce coerce  -text :: forall m t. (MonadJSM m, Coercible Text t) => Config m t -> Input t -> Html m (Input t)+text :: forall m t. Coercible Text t => Config m t -> Input t -> Html m (Input t) text = mkInput "text" coerce coerce

@@ -1,3 +1,4 @@+{-# LANGUAGE AllowAmbiguousTypes    #-} {-# LANGUAGE ConstraintKinds        #-} {-# LANGUAGE DataKinds              #-} {-# LANGUAGE DeriveAnyClass         #-}@@ -30,14 +31,19 @@   ) where  +import           Control.Arrow             (second) import           Data.Aeson+import           Data.Functor.Identity import           Data.Kind import           Data.List                 (sortBy)+import qualified Data.Map                  as M+import           Data.Proxy import           Data.Text import           GHC.Generics  import           Shpadoinkle-import           Shpadoinkle.Html          hiding (a, a', max, min, s, s')+import           Shpadoinkle.Html          hiding (a, a', max, min, s, s', u,+                                            u') import qualified Shpadoinkle.Html          as Html import           Shpadoinkle.Widgets.Types @@ -88,9 +94,15 @@ class Tabular a where   type Effect a (m :: Type -> Type) :: Constraint   type Effect a m = Applicative m-  toRows    :: a -> [Row a]-  toCell    :: Effect a m => a -> Row a -> Column a -> [Html m a]-  sortTable :: SortCol a -> Row a -> Row a -> Ordering+  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 _ = TextNode "↑"+  descendingIcon :: Functor m => Effect a m => Proxy a -> Html m (a, SortCol a)+  descendingIcon _ = TextNode "↓"   toggleSort :: Eq (Column a) => Column a -> SortCol a -> SortCol a@@ -98,25 +110,27 @@   data Theme m a = Theme-  { tableProps ::             [(Text, Prop m (a, SortCol a))]-  , headProps  ::             [(Text, Prop m (a, SortCol a))]-  , thProps    :: Column a -> [(Text, Prop m (a, SortCol a))]-  , bodyProps  ::             [(Text, Prop m (a, SortCol a))]-  , tdProps    :: Column a -> [(Text, Prop m a)]+  { 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 v w x y z <> Theme v' w' x' y' z' =-    Theme (v <> v') (w <> w') (x <> x') (y <> y') (z <> z')+  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 = Theme mempty mempty mempty mempty mempty mempty mempty   view :: forall m a.   ( Tabular a   , Effect a m-  , Applicative m+  , Monad m   , Humanize (Column a)   , Bounded  (Column a)   , Ord      (Column a)@@ -128,24 +142,39 @@ viewWith :: forall m a.   ( Tabular a   , Effect a m-  , Applicative 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-    [ thead headProps [ tr_ $ cth_ <$> [minBound..maxBound] ]-    , tbody bodyProps $ do+  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 . (fmap (, s)) . tr_ $ (\c -> td (tdProps c) $ toCell xs row c) <$> [minBound..maxBound]+        return . filterRow row . tr (trProps xs s row) . fmap leftC $+          (\c -> td (tdProps xs s row c) $ toCell xs row c) <$> [minBound..maxBound]     ]    where -  cth_ c = th (thProps c) . pure . Html.a [ onClick (xs, toggleSort c s) ]-         . mappend [ text (humanize c) ] . pure . text $+  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 runIdentity $ props (Identity . 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)++  cth_ c = th (thProps xs s c) . pure . Html.a [ second rightC . onClick $ toggleSort c s ]+         . mappend [ text (humanize c) ] . pure $           if c == sorton then-            case sortorder of ASC -> "↑"; DESC -> "↓"+            case sortorder of ASC -> ascendingIcon Proxy; DESC -> descendingIcon Proxy           else ""

@@ -0,0 +1,249 @@+{-# 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 -> [] }

@@ -29,7 +29,7 @@ import           GHC.Generics  -data Pick   = One | AtleastOne | Many+data Pick = One | AtleastOne | Many   type family Selected (p :: Pick) (a :: Type) :: Type where@@ -91,8 +91,13 @@   partition p (Choice x xs) = let (l, r) = Set.partition p xs; (l',r') = Control.Compactable.partition p x in (Choice l' l, Choice r' r)  +-- | Laws:+-- @+-- if toSet a == toSet b then a == b -- toSet is injective+-- toSet (smap f s) == fmap f (toSet s)+-- if valid s then Set.valid (toSet s)+-- @ class SetLike f where-  -- must be injective   toSet :: Ord a => f a -> Set a   smap  :: Ord b => (a -> b) -> f a -> f b   valid :: Ord a => f a -> Bool

@@ -86,6 +86,7 @@ data Validated e a = Validated a | Invalid e [e]   deriving (Eq, Ord, Show, Read, Generic, ToJSON, FromJSON, Functor, Foldable, Traversable) + instance Semigroup (Validated e a) where   Validated a <> Validated _ = Validated a   Validated _ <> x = x

@@ -7,13 +7,28 @@   import           Data.Aeson+import           Data.Functor.Identity import           GHC.Generics +import           Shpadoinkle.Html               hiding (s) import           Shpadoinkle.Widgets.Types.Core   data Toggle = Closed Hygiene | Open   deriving (Eq, Ord, Show, Read, Generic, ToJSON, FromJSON)+++data Hover = MouseOver | MouseOut+  deriving (Eq, Ord, Enum, Bounded, Show, Read, Generic, ToJSON, FromJSON)+++withHover+  :: ((Hover, a) -> Html m (Hover, a))+  ->  (Hover, a) -> Html m (Hover, a)+withHover f s@(_,x) = runIdentity . props+  (Identity . mappend [ onMouseenter (MouseOver, x)+                      , onMouseleave (MouseOut,  x)+                      ]) $ f s   togHygiene :: Toggle -> Hygiene

@@ -1,10 +1,15 @@-{-# LANGUAGE DeriveFunctor #-}-{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DeriveAnyClass    #-}+{-# LANGUAGE DeriveFoldable    #-}+{-# LANGUAGE DeriveFunctor     #-}+{-# LANGUAGE DeriveGeneric     #-}+{-# LANGUAGE DeriveTraversable #-}   module Shpadoinkle.Widgets.Types.Remote where  +import           Control.Applicative+import           Data.Aeson          (FromJSON, ToJSON) import           GHC.Generics  @@ -13,7 +18,7 @@   | Failure e   | Loading   | NotAsked-  deriving (Eq, Ord, Show, Read, Generic, Functor)+  deriving (Eq, Ord, Show, Read, Generic, Functor, Foldable, Traversable, ToJSON, FromJSON)   instance Applicative (Remote e) where@@ -25,6 +30,21 @@   _ <*> Loading   = Loading   NotAsked <*> _  = NotAsked   _ <*> NotAsked  = NotAsked+++instance Alternative (Remote e) where+   empty = NotAsked+   x@(Success _) <|> _ = x+   _ <|> x = x+++instance Semigroup a => Semigroup (Remote e a) where+  Success x <> Success y = Success (x <> y)+  x <> y = x <|> y+++instance Semigroup a => Monoid (Remote e a) where+  mempty = empty   instance Monad (Remote e) where

@@ -25,14 +25,19 @@   deriving stock Generic  -data Levenshtiened a = Levenshtiened { _distance :: !Int, _unLevenshtiened :: a } deriving Eq-instance Eq       a => Ord      (Levenshtiened a) where-  compare (Levenshtiened x _) (Levenshtiened y _) = compare x y+newtype EditDistance = EditDistance { unEditDistance :: Int }+  deriving newtype (Eq, Ord, Show, Read, ToJSON, FromJSON)+  deriving stock Generic  +data Levenshtiened a = Levenshtiened { _distance :: !EditDistance, _unLevenshtiened :: a } deriving Eq+instance Eq       a => Ord    (Levenshtiened a) where+  compare (Levenshtiened x _) (Levenshtiened y _) = unEditDistance x `compare` unEditDistance y++ mkLevenshtiened :: Text -> Search -> a -> Levenshtiened a mkLevenshtiened  t (Search s) x =-  Levenshtiened (levenshteinDistance defaultEditCosts (prep s) (prep t)) x+  Levenshtiened (EditDistance $ levenshteinDistance defaultEditCosts (prep s) (prep t)) x   where prep = unpack . strip