Add color input, closes #5

Author: sharkdp

bower.json

@@ -20,6 +20,7 @@
     "purescript-signal": "^5.0.0",
     "purescript-foldable-traversable": "^0.4.1",
     "purescript-canvas": "^0.4.0",
+    "purescript-colors": "^0.1.4",
     "purescript-drawing": "^0.4.0",
     "purescript-smolder": "^3.0.1"
   }

src/Flare.js

@@ -314,4 +314,17 @@ exports.toFieldset = function(label) {
   };
 };
 
+exports.cColor = createComponent("color",
+  function(initial) {
+    var input = document.createElement("input");
+    input.type = "color";
+    input.value = initial;
+    return input;
+  },
+  "input",
+  function(t, initial) {
+    return t.value;
+  }
+);
+
 // vim: ts=2:sw=2

src/Flare.purs

@@ -29,6 +29,8 @@ module Flare
   , select_
   , radioGroup
   , radioGroup_
+  , color
+  , color_
   , fieldset
   , applyUIFlipped
   , (<**>)
@@ -45,14 +47,16 @@ module Flare
 import Prelude
 
 import Data.Array (head, catMaybes)
-import Data.Maybe (Maybe(..))
+import Data.Maybe (Maybe(..), fromMaybe)
 import Data.Monoid (class Monoid, mempty)
 import Data.Foldable (traverse_)
 import Data.Traversable (traverse)
 
 import Control.Apply (lift2)
 import Control.Monad.Eff (Eff)
 
+import Color (Color, toHexString, fromHexString)
+
 import DOM (DOM)
 import DOM.Node.Types (Element())
 
@@ -148,6 +152,7 @@ foreign import cBoolean :: CreateComponent Boolean
 foreign import cButton :: forall a. a -> CreateComponent a
 foreign import cSelect :: forall a. Array a -> (a -> String) -> CreateComponent a
 foreign import cRadioGroup :: forall a. Array a -> (a -> String) -> CreateComponent a
+foreign import cColor :: CreateComponent String
 
 -- | Set up the HTML element for a given component and create the corresponding
 -- | signal channel.
@@ -285,6 +290,15 @@ radioGroup label default xs toString = createUI (cRadioGroup xs toString) label
 radioGroup_ :: forall e a. a -> Array a -> (a -> String) -> UI e a
 radioGroup_ = radioGroup ""
 
+-- | Creates a color picker input field from a label and default `Color`.
+color :: forall e. Label -> Color -> UI e Color
+color label default = (fromMaybe default <<< fromHexString) <$>
+                        createUI cColor label (toHexString default)
+
+-- | Like `color`, but without a label.
+color_ :: forall e. Color -> UI e Color
+color_ = color ""
+
 foreign import toFieldset :: Label -> Array Element -> Element
 
 -- | Group the components of a UI inside a fieldset element with a given title.

test/Main.purs

@@ -62,8 +62,8 @@ ui6 = (greet <$> (select "Language" English [French, German] toString))
 
 -- Example 7
 
-plot m n1 s time =
-      filled (fillColor (hsl 333.0 0.6 0.5)) $
+plot m n1 s col time =
+      filled (fillColor col) $
         path (map point angles)
 
       where point phi = { x: 100.0 + radius phi * cos phi
@@ -81,6 +81,7 @@ plot m n1 s time =
 ui7 = plot <$> (numberSlider "m"  0.0 10.0 1.0  7.0)
            <*> (numberSlider "n1" 1.0 10.0 0.1  4.0)
            <*> (numberSlider "s"  4.0 16.0 0.1 14.0)
+           <*> (color "Color" (hsl 333.0 0.6 0.5))
            <*> lift animationFrame
 
 -- Example 8