diff --git a/colonnade/default.nix b/colonnade/default.nix new file mode 100644 index 0000000..b73a8e3 --- /dev/null +++ b/colonnade/default.nix @@ -0,0 +1,8 @@ +{ frontend ? false }: +let + pname = "colonnade"; + main = (import ../nix/default.nix { + inherit frontend; + }); +in + main.${pname} diff --git a/colonnade/shell.nix b/colonnade/shell.nix new file mode 100644 index 0000000..910b922 --- /dev/null +++ b/colonnade/shell.nix @@ -0,0 +1 @@ +(import ./. {}).env diff --git a/nix/default.nix b/nix/default.nix index d66e05c..b21c746 100644 --- a/nix/default.nix +++ b/nix/default.nix @@ -1,47 +1,73 @@ -{ package, test ? true, frontend ? false }: -let bootstrap = import {}; +{ frontend ? false }: + +let _nixpkgs = import {}; + nixpkgs = _nixpkgs.fetchFromGitHub { + owner = "NixOS"; + repo = "nixpkgs"; + rev = "5c4a404b0d0e5125070dde5c1787210149157e83"; + sha256 = "0a478l0dxzy5hglavkilxjkh45zfg31q50hgkv1npninc4lpv5f7"; + }; + pkgs = import nixpkgs { config = {}; overlays = []; }; + fetch-github-json = owner: repo: path: let commit = builtins.fromJSON (builtins.readFile path); - in bootstrap.fetchFromGitHub { - inherit owner repo; - inherit (commit) rev sha256; + in pkgs.fetchFromGitHub { + name = "${repo}-${commit.rev}"; + inherit owner repo; + inherit (commit) rev sha256; }; - reflex-platform = import (fetch-github-json "reflex-frp" "reflex-platform" ./reflex-platform.json) {}; - compiler = if frontend then "ghcjs" else "ghc"; - overrides = (builtins.getAttr compiler reflex-platform).override { + + reflex-platform = import (fetch-github-json "layer-3-communications" "reflex-platform" ./reflex-platform.json) {}; + jsaddle-src = fetch-github-json "ghcjs" "jsaddle" ./jsaddle.json; + compiler = "ghc8_2_1"; + + filterPredicate = p: type: + let path = baseNameOf p; in !( + (type == "directory" && pkgs.lib.hasPrefix "dist" path) + || (type == "symlink" && pkgs.lib.hasPrefix "result" path) + || pkgs.lib.hasPrefix ".ghc" path + || pkgs.lib.hasPrefix ".git" path + || pkgs.lib.hasSuffix "~" path + || pkgs.lib.hasSuffix ".o" path + || pkgs.lib.hasSuffix ".so" path + || pkgs.lib.hasSuffix ".nix" path); + + overrides = reflex-platform.${compiler}.override { overrides = self: super: with reflex-platform; - let options = pkg: lib.overrideCabal pkg (drv: { doCheck = test; }); - filterPredicate = p: type: - let path = baseNameOf p; in - !builtins.any (x: x) - [(type == "directory" && path == "dist") - (type == "symlink" && path == "result") - (type == "directory" && path == ".git")]; - in { - mkDerivation = args: super.mkDerivation (args // - (if nixpkgs.stdenv.isDarwin && !frontend then { - postCompileBuildDriver = '' - echo "Patching dynamic library dependencies" - # 1. Link all dylibs from 'dynamic-library-dirs's in package confs to $out/lib/links - mkdir -p $out/lib/links - for d in $(grep dynamic-library-dirs $packageConfDir/*|awk '{print $2}'); do - ln -s $d/*.dylib $out/lib/links - done + with reflex-platform.lib; + with reflex-platform.nixpkgs.haskell.lib; + with reflex-platform.nixpkgs.haskellPackages; + let + cp = file: (self.callPackage (./deps + "/${file}.nix") {}); + build-from-json = name: str: self.callCabal2nix name str {}; + build = name: path: self.callCabal2nix name (builtins.filterSource filterPredicate path) {}; + in + { + gtk2hs-buildtools = self.callPackage ./gtk2hs-buildtools.nix {}; + colonnade = build "colonnade" ../colonnade; + siphon = build "siphon" ../siphon; + reflex-dom-colonnade = build "reflex-dom-colonnade" ../reflex-dom-colonnade; + lucid-colonnade = build "lucid-colonnade" ../lucid-colonnade; + blaze-colonnade = build "blaze-colonnade" ../blaze-colonnade; + yesod-colonnade = build "yesod-colonnade" ../yesod-colonnade; + } // + { + jsaddle = doJailbreak (build-from-json "jsaddle" "${jsaddle-src}/jsaddle"); + jsaddle-webkitgtk = doJailbreak (build-from-json "jsaddle-webkitgtk" "${jsaddle-src}/jsaddle-webkitgtk"); + jsaddle-webkit2gtk = doJailbreak (build-from-json "jsaddle-webkit2gtk" "${jsaddle-src}/jsaddle-webkit2gtk"); + jsaddle-wkwebview = doJailbreak (build-from-json "jsaddle-wkwebview" "${jsaddle-src}/jsaddle-wkwebview"); + jsaddle-clib = doJailbreak (build-from-json "jsaddle-clib" "${jsaddle-src}/jsaddle-clib"); + jsaddle-warp = dontCheck (doJailbreak (build-from-json "jsaddle-warp" "${jsaddle-src}/jsaddle-warp")); + }; - # 2. Patch 'dynamic-library-dirs' in package confs to point to the symlink dir - for f in $packageConfDir/*.conf; do - sed -i "s,dynamic-library-dirs: .*,dynamic-library-dirs: $out/lib/links," $f - done - - # 3. Recache package database - ghc-pkg --package-db="$packageConfDir" recache - ''; - } else {})); - } // import ./overrides.nix { inherit options filterPredicate lib cabal2nixResult self super; }; }; - drv = builtins.getAttr package overrides; -in if reflex-platform.nixpkgs.lib.inNixShell then - reflex-platform.workOn overrides drv -else - drv +in rec { + inherit reflex-platform fetch-github-json overrides nixpkgs pkgs; + colonnade = overrides.colonnade; + siphon = overrides.siphon; + reflex-dom-colonnade = overrides.reflex-dom-colonnade; + lucid-colonnade = overrides.lucid-colonnade; + blaze-colonnade = overrides.blaze-colonnade; + yesod-colonnade = overrides.yesod-colonnade; +} diff --git a/nix/gtk2hs-buildtools.nix b/nix/gtk2hs-buildtools.nix new file mode 100644 index 0000000..725ef00 --- /dev/null +++ b/nix/gtk2hs-buildtools.nix @@ -0,0 +1,20 @@ +{ mkDerivation, alex, array, base, Cabal, containers, directory +, filepath, happy, hashtables, pretty, process, random, stdenv +}: +mkDerivation { + pname = "gtk2hs-buildtools"; + version = "0.13.4.0"; + sha256 = "0f3e6ba90839efd43efe8cecbddb6478a55e2ce7788c57a0add4df477dede679"; + isLibrary = true; + isExecutable = true; + enableSeparateDataOutput = true; + libraryHaskellDepends = [ + array base Cabal containers directory filepath hashtables pretty + process random + ]; + libraryToolDepends = [ alex happy ]; + executableHaskellDepends = [ base ]; + homepage = "http://projects.haskell.org/gtk2hs/"; + description = "Tools to build the Gtk2Hs suite of User Interface libraries"; + license = stdenv.lib.licenses.gpl2; +} diff --git a/nix/jsaddle.json b/nix/jsaddle.json new file mode 100644 index 0000000..c71a65f --- /dev/null +++ b/nix/jsaddle.json @@ -0,0 +1,6 @@ +{ + "owner": "ghcjs", + "repo": "jsaddle", + "rev": "b423436565fce7f69a65d843c71fc52dc455bf54", + "sha256": "09plndkh5wnbqi34x3jpaz0kjdjgyf074faf5xk97rsm81vhz8kk" +} diff --git a/reflex-dom-colonnade/default.nix b/reflex-dom-colonnade/default.nix index 457863f..07b1c13 100644 --- a/reflex-dom-colonnade/default.nix +++ b/reflex-dom-colonnade/default.nix @@ -1,5 +1,8 @@ -{ test ? "true" }: -let parseBool = str: with builtins; - let json = fromJSON str; in if isBool json then json else throw "nix parseBool: ${str} is not a bool."; +{ frontend ? false }: +let + pname = "reflex-dom-colonnade"; + main = (import ../nix/default.nix { + inherit frontend; + }); in -import ../nix/default.nix { package = "reflex-dom-colonnade"; frontend = false; test = parseBool test; } + main.${pname} diff --git a/reflex-dom-colonnade/shell.nix b/reflex-dom-colonnade/shell.nix new file mode 100644 index 0000000..910b922 --- /dev/null +++ b/reflex-dom-colonnade/shell.nix @@ -0,0 +1 @@ +(import ./. {}).env diff --git a/reflex-dom-colonnade/src/Reflex/Dom/Colonnade.hs b/reflex-dom-colonnade/src/Reflex/Dom/Colonnade.hs index 60b2052..5e83d74 100644 --- a/reflex-dom-colonnade/src/Reflex/Dom/Colonnade.hs +++ b/reflex-dom-colonnade/src/Reflex/Dom/Colonnade.hs @@ -41,6 +41,7 @@ module Reflex.Dom.Colonnade , sectioned , paginated , paginatedExpandable + , paginatedExpandableLazy , paginatedCapped -- * Cell Functions , cell @@ -56,29 +57,29 @@ module Reflex.Dom.Colonnade , semUiFixedPagination ) where +import Colonnade (Colonnade,Headed,Headless,Fascia,Cornice,Headedness(..)) +import Control.Applicative (liftA2) +import Control.Monad (forM) +import Control.Monad.Fix (MonadFix) +import Control.Monad.Trans.Reader (ReaderT) +import Data.Foldable (Foldable(..),for_,forM_,foldlM) +import Data.Map.Strict (Map) +import Data.Monoid (Sum(..)) +import Data.Proxy +import Data.Semigroup (Semigroup(..)) import Data.String (IsString(..)) +import Data.Text (Text) +import Data.Traversable (for) +import Data.Vector (Vector) +import Reflex.Dom +import qualified Colonnade as C +import qualified Colonnade.Encode as E +import qualified Data.Map.Strict as M +import qualified Data.Profunctor as PF import qualified Data.Text as T import qualified Data.Text.Lazy as LT import qualified Data.Text.Lazy.Builder as LT -import qualified Data.Map.Strict as M import qualified Data.Vector as V -import qualified Data.Profunctor as PF -import Data.Map.Strict (Map) -import Data.Vector (Vector) -import Data.Text (Text) -import Data.Foldable (Foldable(..),for_,forM_,foldlM) -import Data.Traversable (for) -import Data.Semigroup (Semigroup(..)) -import Control.Applicative (liftA2) -import Reflex.Dom -import Colonnade (Colonnade,Headed,Headless,Fascia,Cornice,Headedness(..)) -import Data.Monoid (Sum(..)) -import Data.Proxy -import Control.Monad.Fix (MonadFix) -import Control.Monad (forM) -import Control.Monad.Trans.Reader (ReaderT) -import qualified Colonnade as C -import qualified Colonnade.Encode as E data Cell t m b = Cell { cellAttrs :: !(Dynamic t (M.Map T.Text T.Text)) @@ -171,11 +172,13 @@ class Sizable t b h | h -> b where sizableSize :: h a -> Dynamic t Int sizableCast :: Proxy t -> h a -> b a --- instance (Headedness h, Reflex t) => Headedness (Resizable t h) where --- headednessPure = Resizable (pure 1) . headednessPure --- headednessContents = do --- f <- headednessContents --- Just (\(Resizable _ a) -> f a) +instance (Headedness h, Reflex t) => Headedness (Resizable t h) where + headednessPure = Resizable (pure 1) . headednessPure + headednessExtract = do + f <- headednessExtract + Just (\(Resizable _ a) -> f a) + headednessExtractForall = headednessExtractForall + instance (Headedness h, Reflex t) => Sizable t h (Resizable t h) where sizableSize = resizableSize @@ -308,7 +311,7 @@ bodyResizableLazy bodyAttrs trAttrs colonnade collection = do _ <- dyn $ flip fmap largestSizes $ \s -> do let colonnade' = E.Colonnade (V.map snd (V.filter (\(sz,_) -> sz > 0) (V.zip s (E.getColonnade colonnade)))) bodyResizable bodyAttrs trAttrs colonnade' collection - return () + pure () setColspanOrHide :: Int -> Map Text Text -> Map Text Text setColspanOrHide i m @@ -431,7 +434,7 @@ capped tableAttrs headAttrs bodyAttrs trAttrs fascia cornice collection = elAttr "table" tableAttrs $ do h <- encodeCorniceHead headAttrs fascia (E.annotate cornice) b <- body (pure bodyAttrs) (pure . trAttrs) (E.discard cornice) collection - return (h `mappend` b) + pure (h `mappend` b) -- | This is useful when you want to be able to toggle the visibility -- of columns after the table has been built. In additon to the @@ -456,7 +459,7 @@ cappedResizable tableAttrs headAttrs bodyAttrs beneathBody trAttrs fascia cornic _ <- encodeCorniceResizableHead headAttrs fascia annCornice bodyResizableLazy (pure bodyAttrs) (pure . trAttrs) (E.discard cornice) collection c <- beneathBody - return (c, E.size annCornice) + pure (c, E.size annCornice) -- | Same as 'cappedResizable' but without the @\@ wrapping it. -- Also, it does not take extra content to go beneath the @\@. @@ -473,9 +476,9 @@ cappedResizableTableless headAttrs bodyAttrs trAttrs fascia cornice collection = let annCornice = dynamicAnnotate cornice _ <- encodeCorniceResizableHead headAttrs fascia annCornice bodyResizableLazy (pure bodyAttrs) (pure . trAttrs) (E.discard cornice) collection - return (E.size annCornice) + pure (E.size annCornice) -cappedTableless :: +cappedTableless :: forall t b h m f e c p a. (Headedness b, Sizable t b h, MonadWidget t m, Foldable f, Monoid e, Cellular t m c) => Dynamic t (Map Text Text) -- ^ @\@ tag attributes -> Dynamic t (Map Text Text) -- ^ @\@ tag attributes @@ -485,13 +488,14 @@ cappedTableless :: -> f a -- ^ Collection of data -> m (Dynamic t Int) cappedTableless headAttrs bodyAttrs trAttrs fascia cornice collection = do - let annCornice = dynamicAnnotateGeneral cornice + let annCornice :: E.AnnotatedCornice (Dynamic t Int) b p a (c e) + annCornice = dynamicAnnotateGeneral cornice _ <- encodeCorniceHeadGeneral headAttrs fascia annCornice bodyResizableLazy bodyAttrs trAttrs (C.mapHeadedness sizedToResizable (E.uncapAnnotated annCornice)) collection - return (E.size annCornice) - + pure (E.size annCornice) + sizedToResizable :: E.Sized (Dynamic t Int) h a -> Resizable t h a sizedToResizable (E.Sized sz h) = Resizable sz h @@ -559,7 +563,7 @@ cappedTraversing tableAttrs headAttrs bodyAttrs trAttrs fascia cornice collectio elAttr "table" tableAttrs $ do _ <- encodeCorniceHead headAttrs fascia (E.annotate cornice) b <- bodyTraversing bodyAttrs trAttrs (E.discard cornice) collection - return b + pure b dynamicBody :: (DomBuilder t m, PostBuild t m, Foldable f, Semigroup e, Monoid e) => Dynamic t (M.Map T.Text T.Text) @@ -642,11 +646,11 @@ expandable tableAttrs tdExpandedAttrs as encoding@(E.Colonnade v) = do elist <- E.rowMonadicWith [] (++) encoding (fmap (\k -> [k]) . elFromCell "td") a let e = leftmost elist e' = flip fmap e $ \mwidg -> case mwidg of - Nothing -> return () + Nothing -> pure () Just widg -> el "tr" $ do elDynAttr "td" (M.insert "colspan" (T.pack (show vlen)) <$> tdExpandedAttrs) widg - return e' - widgetHold (return ()) e' + pure e' + widgetHold (pure ()) e' -- expandableResizableTableless :: forall t m f a b. (MonadWidget t m, Foldable f) -- => f a -- ^ Values @@ -687,7 +691,7 @@ paginated (Bureau tableAttrs theadAttrs bodyAttrs trAttrs) (Pagination pageSize makeVals page = V.generate pageSize $ \ix -> do p <- page v <- vecD - return (maybe (Visible False aDef) (Visible True) (v V.!? (p * pageSize + ix))) + pure (maybe (Visible False aDef) (Visible True) (v V.!? (p * pageSize + ix))) totalPages :: Dynamic t Int totalPages = fmap ((`divRoundUp` pageSize) . V.length) vecD hideWhenUnipage :: Dynamic t (Map Text Text) -> Dynamic t (Map Text Text) @@ -698,7 +702,7 @@ paginated (Bureau tableAttrs theadAttrs bodyAttrs trAttrs) (Pagination pageSize trAttrsLifted d = do Visible isVisible a <- d attrs <- trAttrs a - return (if isVisible then attrs else M.insertWith T.append "style" "display:none;" attrs) + pure (if isVisible then attrs else M.insertWith T.append "style" "display:none;" attrs) size :: Dynamic t Int size = coerceDynamic (foldMap (\x -> coerceDynamic (sizableSize (E.oneColonnadeHead x)) :: Dynamic t (Sum Int)) (E.getColonnade col)) elDynAttr "table" tableAttrs $ case arrange of @@ -711,15 +715,15 @@ paginated (Bureau tableAttrs theadAttrs bodyAttrs trAttrs) (Pagination pageSize let attrs = zipDynWith insertSizeAttr size tfootThAttrs elDynAttr "th" attrs $ do makePagination totalPages - return e + pure e _ -> error "Reflex.Dom.Colonnade: paginated: write this code" -- dynAfter :: forall t m a b. MonadWidget t m => Event t a -> (Dynamic t a -> m (Event t b)) -> m (Event t b) -- dynAfter e f = do -- e1 <- headE e -- let em1 = fmap (\a1 -> holdDyn a1 e >>= f) e1 --- de <- widgetHold (return never) em1 --- return (switch (current de)) +-- de <- widgetHold (pure never) em1 +-- pure (switch (current de)) -- paginatedCappedLazy :: forall t b h m a c p e. -- (Sizable t b h, Cellular t m c, Headedness b, MonadFix m, Functor h, MonadHold t m, Monoid e) @@ -740,7 +744,7 @@ paginated (Bureau tableAttrs theadAttrs bodyAttrs trAttrs) (Pagination pageSize -- makeVals page = V.generate pageSize $ \ix -> do -- p <- page -- v <- vecD --- return (maybe (Visible False aDef) (Visible True) (v V.!? (p * pageSize + ix))) +-- pure (maybe (Visible False aDef) (Visible True) (v V.!? (p * pageSize + ix))) -- totalPages :: Dynamic t Int -- totalPages = fmap ((`divRoundUp` pageSize) . V.length) vecD -- hideWhenUnipage :: Dynamic t (Map Text Text) -> Dynamic t (Map Text Text) @@ -751,7 +755,7 @@ paginated (Bureau tableAttrs theadAttrs bodyAttrs trAttrs) (Pagination pageSize -- trAttrsLifted d = do -- Visible isVisible a <- d -- attrs <- trAttrs a --- return (if isVisible then attrs else M.insertWith T.append "style" "display:none;" attrs) +-- pure (if isVisible then attrs else M.insertWith T.append "style" "display:none;" attrs) -- elDynAttr "table" tableAttrs $ case arrange of -- ArrangementFooter tfootAttrs tfootTrAttrs tfootThAttrs -> mdo -- let vals = makeVals page @@ -761,7 +765,7 @@ paginated (Bureau tableAttrs theadAttrs bodyAttrs trAttrs) (Pagination pageSize -- let attrs = zipDynWith insertSizeAttr size tfootThAttrs -- elDynAttr "th" attrs $ do -- makePagination totalPages --- return e +-- pure e -- _ -> error "Reflex.Dom.Colonnade: paginatedCapped: write this code" @@ -780,7 +784,7 @@ paginatedCapped (Chest tableAttrs theadAttrs fascia bodyAttrs trAttrs) (Paginati makeVals page = V.generate pageSize $ \ix -> do p <- page v <- vecD - return (maybe (Visible False aDef) (Visible True) (v V.!? (p * pageSize + ix))) + pure (maybe (Visible False aDef) (Visible True) (v V.!? (p * pageSize + ix))) totalPages :: Dynamic t Int totalPages = fmap ((`divRoundUp` pageSize) . V.length) vecD hideWhenUnipage :: Dynamic t (Map Text Text) -> Dynamic t (Map Text Text) @@ -791,7 +795,7 @@ paginatedCapped (Chest tableAttrs theadAttrs fascia bodyAttrs trAttrs) (Paginati trAttrsLifted d = do Visible isVisible a <- d attrs <- trAttrs a - return (if isVisible then attrs else M.insertWith T.append "style" "display:none;" attrs) + pure (if isVisible then attrs else M.insertWith T.append "style" "display:none;" attrs) elDynAttr "table" tableAttrs $ case arrange of ArrangementFooter tfootAttrs tfootTrAttrs tfootThAttrs -> mdo let vals = makeVals page @@ -801,9 +805,8 @@ paginatedCapped (Chest tableAttrs theadAttrs fascia bodyAttrs trAttrs) (Paginati let attrs = zipDynWith insertSizeAttr size tfootThAttrs elDynAttr "th" attrs $ do makePagination totalPages - return () + pure () _ -> error "Reflex.Dom.Colonnade: paginatedCapped: write this code" - -- | A paginated table with a fixed number of rows. Each row can -- expand a section beneath it, represented as an additional @@ -828,7 +831,7 @@ paginatedExpandable (Bureau tableAttrs theadAttrs bodyAttrs trAttrs) (Pagination makeVals page = V.generate pageSize $ \ix -> do p <- page v <- vecD - return (maybe (Visible False aDef) (Visible True) (v V.!? (p * pageSize + ix))) + pure (maybe (Visible False aDef) (Visible True) (v V.!? (p * pageSize + ix))) totalPages :: Dynamic t Int totalPages = fmap ((`divRoundUp` pageSize) . V.length) vecD hideWhenUnipage :: Dynamic t (Map Text Text) -> Dynamic t (Map Text Text) @@ -839,7 +842,7 @@ paginatedExpandable (Bureau tableAttrs theadAttrs bodyAttrs trAttrs) (Pagination trAttrsLifted d = do Visible isVisible a <- d attrs <- trAttrs a - return (if isVisible then attrs else M.insertWith T.append "style" "display:none;" attrs) + pure (if isVisible then attrs else M.insertWith T.append "style" "display:none;" attrs) size :: Dynamic t Int size = coerceDynamic (foldMap (\x -> coerceDynamic (sizableSize (E.oneColonnadeHead x)) :: Dynamic t (Sum Int)) (E.getColonnade col)) elDynAttr "table" tableAttrs $ case arrange of @@ -852,21 +855,70 @@ paginatedExpandable (Bureau tableAttrs theadAttrs bodyAttrs trAttrs) (Pagination let attrs = zipDynWith insertSizeAttr size tfootThAttrs elDynAttr "th" attrs $ do makePagination totalPages - return () - _ -> error "Reflex.Dom.Colonnade: paginated: write this code" + pure () + _ -> error "Reflex.Dom.Colonnade: paginatedExpandable: write this code" +-- | A paginated table with a fixed number of rows. Each row can +-- expand a section beneath it, represented as an additional +-- table row. CSS rules that give the table a striped appearance +-- are unlikely to work since there are hidden rows. +paginatedExpandableLazy :: forall t b h m a c. + (Sizable t b h, Cellular t m c, Headedness b, MonadFix m, Functor h, Functor c, MonadHold t m, MonadWidget t m, Headedness h, h ~ b) + => Bureau t b a -- ^ table class settings + -> Pagination t m -- ^ pagination settings + -> a -- ^ An inhabitant of type @a@ only used for the cells in hidden rows. + -> (Dynamic t a -> m ()) -- expandable extra content + -> Colonnade (Resizable t h) (Dynamic t a) (c (Dynamic t Bool)) + -- ^ Column blueprint. The boolean event enables and disables the expansion. + -> Dynamic t (Vector a) -- ^ table row data + -> m () +paginatedExpandableLazy (Bureau tableAttrs theadAttrs bodyAttrs trAttrs) (Pagination pageSize arrange makePagination) aDef expansion col vecD = do + let colLifted :: Colonnade (Resizable t h) (Dynamic t (Visible a)) (c (Dynamic t Bool)) + colLifted = PF.lmap (fmap (\(Visible _ a) -> a)) col + expansionLifted :: Dynamic t (Visible a) -> m () + expansionLifted = expansion . fmap (\(Visible _ a) -> a) + makeVals :: Dynamic t Int -> Vector (Dynamic t (Visible a)) + makeVals page = V.generate pageSize $ \ix -> do + p <- page + v <- vecD + pure (maybe (Visible False aDef) (Visible True) (v V.!? (p * pageSize + ix))) + totalPages :: Dynamic t Int + totalPages = fmap ((`divRoundUp` pageSize) . V.length) vecD + hideWhenUnipage :: Dynamic t (Map Text Text) -> Dynamic t (Map Text Text) + hideWhenUnipage = zipDynWith + ( \ct attrs -> if ct > 1 then attrs else M.insert "style" "display:none;" attrs + ) totalPages + trAttrsLifted :: Dynamic t (Visible a) -> Dynamic t (Map Text Text) + trAttrsLifted d = do + Visible isVisible a <- d + attrs <- trAttrs a + pure (if isVisible then attrs else M.insertWith T.append "style" "display:none;" attrs) + size :: Dynamic t Int + size = coerceDynamic (foldMap (\x -> coerceDynamic (sizableSize (E.oneColonnadeHead x)) :: Dynamic t (Sum Int)) (E.getColonnade col)) + elDynAttr "table" tableAttrs $ case arrange of + ArrangementFooter tfootAttrs tfootTrAttrs tfootThAttrs -> mdo + tableHeader theadAttrs colLifted + let vals = makeVals page + tableBodyExpandableLazy size expansionLifted bodyAttrs trAttrsLifted colLifted vals (Visible True aDef) + page <- elDynAttr "tfoot" (hideWhenUnipage tfootAttrs) $ do + elDynAttr "tr" tfootTrAttrs $ do + let attrs = zipDynWith insertSizeAttr size tfootThAttrs + elDynAttr "th" attrs $ do + makePagination totalPages + pure () + _ -> error "Reflex.Dom.Colonnade: paginatedExpandableLazy: write this code" divRoundUp :: Int -> Int -> Int divRoundUp a b = case divMod a b of (x,y) -> if y == 0 then x else x + 1 - + tableHeader :: forall t b h c a m x. (Reflex t, Sizable t b h, Cellular t m c, Headedness b) => b (Dynamic t (Map Text Text), Dynamic t (Map Text Text)) -> Colonnade h a (c x) -> m () tableHeader theadAttrsWrap col = case headednessExtractForall of - Nothing -> return () + Nothing -> pure () Just extractForall -> do let (theadAttrs,trAttrs) = extract theadAttrsWrap elDynAttr "thead" theadAttrs $ do @@ -875,7 +927,7 @@ tableHeader theadAttrsWrap col = case headednessExtractForall of where extract :: forall y. b y -> y extract = E.runExtractForall extractForall - + tableBody :: (DomBuilder t m, PostBuild t m, Foldable f, Monoid e, Cellular t m c, Sizable t b h) => Dynamic t (M.Map T.Text T.Text) -> (a -> Dynamic t (M.Map T.Text T.Text)) @@ -885,9 +937,35 @@ tableBody :: (DomBuilder t m, PostBuild t m, Foldable f, Monoid e, Cellular t m tableBody bodyAttrs trAttrs col collection = elDynAttr "tbody" bodyAttrs $ foldlM (\m a -> do e <- elDynAttr "tr" (trAttrs a) (rowSizable col a) - return (mappend m e) + pure (mappend m e) ) mempty collection +-- | As of now, the *expandable* content is only as lazy as tableBodyExpandable is, meaning it is still generated with the initial value. +tableBodyExpandableLazy :: forall t m c b a h. (Headedness h, MonadFix m, DomBuilder t m, MonadHold t m, PostBuild t m, Cellular t m c, Sizable t b h) + => Dynamic t Int -- ^ number of visible columns in the table + -> (Dynamic t a -> m ()) + -> Dynamic t (Map Text Text) + -> (Dynamic t a -> Dynamic t (Map Text Text)) + -> Colonnade (Resizable t h) (Dynamic t a) (c (Dynamic t Bool)) + -> Vector (Dynamic t a) + -> a -- ^ initial value, a hack + -> m () +tableBodyExpandableLazy colCount renderExpansion bodyAttrs trAttrs colonnade collection a0 = do + let sizeVec :: Vector (Dynamic t Int) + sizeVec = V.map (resizableSize . E.oneColonnadeHead) (E.getColonnade colonnade) + let sizeVecD :: Dynamic t (Vector Int) + sizeVecD = fmap V.fromList (distributeListOverDynPure (V.toList sizeVec)) + sizeVec0 :: Vector Int <- sample (current sizeVecD) + largestSizes :: Dynamic t (Vector Int) <- foldDynMaybe + ( \incoming largest -> + let v = V.zipWith max incoming largest + in if v == largest then Nothing else Just v + ) sizeVec0 (updated sizeVecD) + _ <- dyn $ flip fmap largestSizes $ \s -> do + let colonnade' = E.Colonnade (V.map snd (V.filter (\(sz,_) -> sz > 0) (V.zip s (E.getColonnade colonnade)))) + tableBodyExpandable colCount renderExpansion bodyAttrs trAttrs colonnade' collection a0 + pure () + -- | This function has a implementation that is careful to only -- redraw the expansion rows, which are usually hidden, when -- it is necessary to do so. @@ -903,8 +981,8 @@ tableBodyExpandable :: forall t m c b a h. (DomBuilder t m, MonadHold t m, PostB tableBodyExpandable colCount renderExpansion bodyAttrs trAttrs col collection a0 = elDynAttr "tbody" bodyAttrs $ mapM_ (\a -> do let attrs = trAttrs a - expanded <- elDynAttr "tr" attrs (rowSizableReified (return False) (zipDynWith (||)) col a) - visibleVal <- gateDynamic expanded a0 a + expanded :: Dynamic t Bool <- elDynAttr "tr" attrs (rowSizableReified (pure False) (zipDynWith (||)) col a) + visibleVal :: Dynamic t a <- gateDynamic expanded a0 a elDynAttr "tr" (zipDynWith insertVisibilityAttr expanded attrs) $ do -- TODO: possibly provide a way to customize these attributes let expansionTdAttrs = pure M.empty @@ -945,7 +1023,7 @@ rowSizableReified theEmpty theAppend (E.Colonnade v) a = V.foldM (\m oc -> do attrs = zipDynWith insertSizeAttr sz (cellularAttrs c) e <- elDynAttr "td" attrs $ do cellularContents c - return (theAppend m e) + pure (theAppend m e) ) theEmpty v rowSizable :: (Sizable t b h, Cellular t m c, Monoid e) @@ -958,7 +1036,7 @@ rowSizable (E.Colonnade v) a = V.foldM (\m oc -> do attrs = zipDynWith insertSizeAttr sz (cellularAttrs c) e <- elDynAttr "td" attrs $ do cellularContents c - return (mappend m e) + pure (mappend m e) ) mempty v insertVisibilityAttr :: Bool -> Map Text Text -> Map Text Text @@ -986,7 +1064,7 @@ semUiFixedPagination :: MonadWidget t m semUiFixedPagination maxPageCount extraClass pageCount = do elClass "div" (T.append "ui pagination menu " extraClass) $ mdo (bckEl,()) <- elClass' "a" "icon item" $ do - elClass "i" "left chevron icon" (return ()) + elClass "i" "left chevron icon" (pure ()) let bck = Backward <$ domEvent Click bckEl posList <- forM (enumFromTo 0 (maxPageCount - 1)) $ \i -> do let attrs = zipDynWith (\ct pg -> M.unionsWith (<>) @@ -996,16 +1074,16 @@ semUiFixedPagination maxPageCount extraClass pageCount = do ] ) pageCount page (pageEl, ()) <- elDynAttr' "a" attrs (text (T.pack (show (i + 1)))) - return (Position i <$ domEvent Click pageEl) + pure (Position i <$ domEvent Click pageEl) (fwdEl,()) <- elClass' "a" "icon item" $ do - elClass "i" "right chevron icon" (return ()) + elClass "i" "right chevron icon" (pure ()) let fwd = Forward <$ domEvent Click fwdEl let moveEv = leftmost (fwd : bck : (Position 0 <$ updated pageCount) : posList) page <- foldDynM (\move oldPage -> case move of - Backward -> return (max 0 (oldPage - 1)) + Backward -> pure (max 0 (oldPage - 1)) Forward -> do nowPageCount <- sample (current pageCount) - return (min (nowPageCount - 1) (oldPage + 1)) - Position updatedPage -> return updatedPage + pure (min (nowPageCount - 1) (oldPage + 1)) + Position updatedPage -> pure updatedPage ) 0 moveEv holdUniqDyn page