add expandable to reflex-dom-colonnade

.gitignore

@@ -5,8 +5,6 @@ cabal.config
 cabal.sandbox.config
 *.chi
 *.chs.h
-config/client_session_key.aes
-playground/
 dist*
 .DS_Store
 *.dyn_hi
@@ -19,23 +17,13 @@ dist*
 *.o
 *.prof
 *.sqlite3
-untracked/
-uploads/
-static/combined/
-static/tmp/
 *.swp
 .virtualenv
 .stack-work/
-yesod-devel/
 tmp/
-config/client_session_key.aes
-playground/auth.txt
 **/*.dump-hi
 tags
 TAGS
+colonnade/ex1.hs
 
-docs/db/unthreat
+reflex-dom-colonnade/result
-ex1.hs
-
-geolite-csv/data/large
-geolite-lmdb/data/large

nix/default.nix

@@ -0,0 +1,47 @@
+{ package, test ? true, frontend ? false }:
+let bootstrap = import <nixpkgs> {};
+    fetch-github-json = owner: repo: path:
+      let commit = builtins.fromJSON (builtins.readFile path);
+      in bootstrap.fetchFromGitHub {
+            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 {
+      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
+
+                # 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

nix/overrides.nix

@@ -0,0 +1,7 @@
+{ options ? (x: x), filterPredicate ? (x: true), lib, cabal2nixResult, self, super }:
+let build = path: options (self.callPackage (cabal2nixResult (builtins.filterSource filterPredicate path)) {});
+in {
+  # Core Libraries
+  colonnade = lib.dontCheck (build ../colonnade);
+  reflex-dom-colonnade = build ../reflex-dom-colonnade;
+}

nix/reflex-platform.json

@@ -0,0 +1,7 @@
+{
+  "url": "https://github.com/reflex-frp/reflex-platform",
+  "rev": "a16213b82f05808ad96b81939850a32ecedd18eb",
+  "date": "2017-05-05T11:40:26-04:00",
+  "sha256": "0dfm8pcpk2zpkfrc9gxh79pkk4ac8ljfm5nqv0sksd64qlhhpj4f",
+  "fetchSubmodules": true
+}

reflex-dom-colonnade/default.nix

@@ -0,0 +1,5 @@
+{ 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.";
+in
+import ../nix/default.nix { package = "reflex-dom-colonnade"; frontend = false; test = parseBool test; }

reflex-dom-colonnade/reflex-dom-colonnade.cabal

@@ -26,7 +26,6 @@ library
     , reflex-dom == 0.4.*
     , containers >= 0.5 && < 0.6
   default-language: Haskell2010
-  ghc-options:      -Wall
 
 source-repository head
   type:     git

reflex-dom-colonnade/src/Reflex/Dom/Colonnade.hs

@@ -5,6 +5,8 @@
 {-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE UndecidableInstances #-}
 
+{-# OPTIONS_GHC -Wall -Werror #-}
+
 module Reflex.Dom.Colonnade
   (
   -- * Types
@@ -16,6 +18,7 @@ module Reflex.Dom.Colonnade
   , cappedTraversing
   , dynamic
   , dynamicCapped
+  , expandable
     -- * Cell Functions
   , cell
   , charCell
@@ -30,7 +33,8 @@ 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 Data.Foldable (Foldable(..),for_)
+import qualified Data.Vector as V
+import Data.Foldable (Foldable(..),for_,forM_)
 import Data.Traversable (for)
 import Data.Semigroup (Semigroup(..))
 import Control.Applicative (liftA2)
@@ -89,7 +93,7 @@ basic ::
   -> Colonnade Headed a (Cell t m ()) -- ^ Data encoding strategy
   -> f a -- ^ Collection of data
   -> m ()
-basic tableAttrs = static tableAttrs Nothing mempty (const mempty)
+basic tableAttrs = static tableAttrs (Just (M.empty,M.empty)) mempty (const mempty)
 
 body :: (DomBuilder t m, PostBuild t m, Foldable f, Monoid e)
   => M.Map T.Text T.Text
@@ -237,3 +241,31 @@ dynamicCapped tableAttrs headAttrs bodyAttrs trAttrs fascia cornice collection =
     -- TODO: Figure out what this ignored argument represents and dont ignore it
     _ <- encodeCorniceHeadDynamic headAttrs fascia (E.annotate cornice)
     dynamicBody bodyAttrs trAttrs (E.discard cornice) collection
+
+-- | Table with cells that can create expanded content
+--   between the rows.
+expandable :: (MonadWidget t m, Foldable f)
+  => Dynamic t (M.Map T.Text T.Text) -- ^ @\<table\>@ tag attributes
+  -> Dynamic t (M.Map T.Text T.Text) -- ^ Attributes of expanded @\<td\>@
+  -> f a -- ^ Values
+  -> Colonnade Headed a (Cell t m (Event t (Maybe (m ()))))
+     -- ^ Encoding into cells with events that can fire to create additional content under the row
+  -> m ()
+expandable tableAttrs tdExpandedAttrs as encoding@(E.Colonnade v) = do
+  let vlen = V.length v
+  elDynAttr "table" tableAttrs $ do
+    -- Discarding this result is technically the wrong thing
+    -- to do, but I cannot imagine why anyone would want to
+    -- drop down content under the heading.
+    _ <- el "thead" $ el "tr" $ E.headerMonadicGeneral_ encoding (elFromCell "th")
+    el "tbody" $ forM_ as $ \a -> do
+      e' <- el "tr" $ 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 ()
+              Just widg -> el "tr" $ do
+                elDynAttr "td" (M.insert "colspan" (T.pack (show vlen)) <$> tdExpandedAttrs) widg
+        return e'
+      widgetHold (return ()) e'
+