checkbox

gistfile1.hs

{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs            #-}
{-# LANGUAGE TemplateHaskell  #-}

module Widgets.Setting where

import           Control.Applicative
import           Control.Monad
import           Control.Monad.IO.Class
import           Data.Default
import           Data.Map                   (Map)
import qualified Data.Map                   as Map
import           Data.Maybe
import           GHCJS.DOM
import           GHCJS.DOM.DOMWindow        (domWindowGetLocalStorage)
import           GHCJS.DOM.Element
import           GHCJS.DOM.HTMLElement
import           GHCJS.DOM.HTMLElement      (htmlElementSetInnerText)
import           GHCJS.DOM.HTMLInputElement
import           GHCJS.DOM.HTMLLabelElement
import           GHCJS.DOM.Node             (nodeAppendChild)
import           GHCJS.DOM.Storage
import           GHCJS.DOM.Types            (Element (..))
import           Reflex
import           Reflex.Dom
import           Safe                       (readMay)
import Data.Monoid ((<>))

foreign import javascript unsafe "jQuery($1).checkbox() " makeCheckbox :: HTMLElement -> IO ()

data Setting t =
  Setting {_setting_value :: Dynamic t Bool}

setPref :: String -> String -> IO ()
setPref key val =
  do mbWindow <- currentWindow
     case mbWindow of
       Nothing -> return ()
       Just win ->
         do Just storage <- domWindowGetLocalStorage win
            storageSetItem storage key val

getPref :: Read a => String -> a -> IO a
getPref key def =
  do mbWindow <- currentWindow
     case mbWindow of
       Nothing -> return def
       Just win ->
         do Just storage <- domWindowGetLocalStorage win
            fromMaybe def . readMay <$>
              storageGetItem storage key

setting :: MonadWidget t m => String -> m (Setting t)
setting labelText =
  do val <- liftIO (getPref labelText False)
     (parent,(input,_)) <-
       elAttr' "div" ("class" =: "ui toggle checkbox") $
       do el "label" (text labelText)
          elAttr' "input"
                  ("type" =: "checkbox" <>
                   if val
                      then "checked" =: "checked"
                      else mempty) $
            return ()
     liftIO (makeCheckbox $ _el_element parent)
     eClick <-
       wrapDomEvent (_el_element parent)
                    elementOnclick $
       liftIO $
       do checked <-
            htmlInputElementGetChecked
              (castToHTMLInputElement $ _el_element input)
          setPref labelText $ show checked
          return checked
     dValue <- holdDyn val eClick
     return (Setting dValue)