content: {-# LANGUAGE ApplicativeDo #-}
  {-# LANGUAGE FlexibleContexts #-}
  {-# LANGUAGE QuasiQuotes      #-}
  {-# OPTIONS_GHC -Wall #-}
  
  module Web.Suavemente.Input where
  
  import           Control.Arrow ((&&&))
  import           Control.Concurrent.STM.TVar (newTVar, readTVar)
  import           Control.Monad.State.Class (MonadState (..), modify)
  import           Control.Monad.Trans.Class (lift)
  import           Data.Aeson (FromJSON (..), Value, withText)
  import           Data.Aeson.Types (Parser)
  import           Data.Bool (bool)
  import           Data.Colour.SRGB (Colour, sRGB24show, sRGB24read)
  import           Data.Text (unpack)
  import           Text.Blaze (preEscapedString, Markup, ToMarkup (..))
  import           Text.InterpolatedString.Perl6 (qc, q)
  import           Web.Suavemente.Core
  import           Web.Suavemente.Types
  
  ------------------------------------------------------------------------------
  -- | Generate a new name for an HTML element.
  genName :: MonadState Int m => m String
  genName = do
    s <- get
    modify (+1)
    pure $ show s
  
  
  ------------------------------------------------------------------------------
  -- | Constructor for building 'Suave' inputs that are backed by HTML elements.
  mkInput
      :: (Value -> Parser a)
      -> (String -> a -> Markup)  -- ^ Function to construct the HTML element. The first parameter is what should be used for the element's 'id' attribute.
      -> a                        -- ^ The input's initial value.
      -> Suave a
  mkInput p f a = Suave $ do
    name <- genName
    tvar <- lift $ newTVar a
    pure $ Input (f name a) (getEvents p tvar name) (readTVar tvar)
  
  
  ------------------------------------------------------------------------------
  -- | Create an input driven by an HTML slider.
  slider
      :: (ToMarkup a, Num a, FromJSON a)
      => String  -- ^ label
      -> a       -- ^ min
      -> a       -- ^ max
      -> a       -- ^ initial value
      -> Suave a
  slider label l u = mkInput parseJSON $ \name v ->
    preEscapedString
      [qc|<tr><td>
          <label for="{name}">{label}</label>
          </td><td>
          <input id="{name}" oninput="onChangeFunc(event)" type="range" min="{showMarkup l}" max="{showMarkup u}" value="{showMarkup v}" autocomplete="off">
          </td></tr>|]
  
  
  ------------------------------------------------------------------------------
  -- | Create an input driven by an HTML slider, whose domain is the real
  -- numbers.
  realSlider
      :: (ToMarkup a, Num a, Real a, FromJSON a)
      => String  -- ^ label
      -> a       -- ^ min
      -> a       -- ^ max
      -> a       -- ^ step
      -> a       -- ^ initial value
      -> Suave a
  realSlider label l u s = mkInput parseJSON $ \name v ->
    preEscapedString
      [qc|<tr><td>
          <label for="{name}">{label}</label>
          </td><td>
          <input id="{name}" oninput="onChangeFunc(event)" type="range" min="{showMarkup l}" max="{showMarkup u}" step="{showMarkup s}" value="{showMarkup v}" autocomplete="off">
          </td></tr>|]
  
  ------------------------------------------------------------------------------
  -- | Create an input driven by the HTML input, type=color.
  colorPicker
      :: (Ord a, Floating a, RealFrac a)
      => String   -- ^ label
      -> Colour a -- ^ initial value
      -> Suave (Colour a)
  colorPicker label =
    mkInput
    (withText "hex colour representation" (pure . sRGB24read . unpack)) $
    \name v ->
      preEscapedString
      [qc|<tr><td>
          <label for="{name}">{label}</label>
          </td><td>
          <input id="{name}" oninput="onChangeFunc(event)" type="color" value="{sRGB24show v}">
          </td></tr>|]
  
  ------------------------------------------------------------------------------
  -- | Create an input driven by an HTML checkbox.
  checkbox :: String -> Bool -> Suave Bool
  checkbox label = mkInput parseJSON $ \name v ->
    preEscapedString
      [qc|<tr><td>
          <label for="{name}">{label}</label>
          </td><td>
          <input id="{name}" onchange="onChangeFunc(event)" type="checkbox" {bool ("" :: String) "checked='checked'" v} autocomplete="off">
          </td></tr>|]
  
  ------------------------------------------------------------------------------
  -- | Create an input driven by an HTML checkbox without table tags.
  checkbox_ :: String -> Bool -> Suave Bool
  checkbox_ label = mkInput parseJSON $ \name v ->
    preEscapedString
      [qc|
          <label for="{name}">{label}</label>
          <input id="{name}" onchange="onChangeFunc(event)" type="checkbox" {bool ("" :: String) "checked='checked'" v} autocomplete="off">
          |]
  
  ------------------------------------------------------------------------------
  -- | Create an input driven by an HTML textbox.
  textbox
      :: String  -- ^ label
      -> String  -- ^ initial value
      -> Suave String
  textbox label = mkInput parseJSON $ \name v ->
    preEscapedString
      [qc|<tr><td>
          <label for="{name}">{label}</label>
          </td><td>
          <input id="{name}" oninput="onChangeFunc(event)" type="text" value="{v}" autocomplete="off">
          </td></tr>|]
  
  ------------------------------------------------------------------------------
  -- | Create an input driven by an HTML textbox without table tags.
  textbox_
      :: String  -- ^ label
      -> String  -- ^ initial value
      -> Suave String
  textbox_ label = mkInput parseJSON $ \name v ->
    preEscapedString
      [qc|
          <label for="{name}">{label}</label>
          <input id="{name}" oninput="onChangeFunc(event)" type="text" value="{v}" autocomplete="off">
          |]
  
  ------------------------------------------------------------------------------
  -- | Create an input driven by an HTML select.
  dropdown
      :: (FromJSON a, ToMarkup a, Eq a)
      => String  -- ^ label
      -> [(String, a)]
      -> a
      -> Suave a
  dropdown label opts = mkInput parseJSON $ \name d -> preEscapedString $
    mconcat $
      [ [qc|<tr><td><label for="{name}">{label}</label></td><td>|]
      , [qc|<select id="{name}" onchange="onChangeFunc(event)" autocomplete="off">|]
      ] ++
        fmap
          (\(oname, oval) -> [qc|<option {if oval == d then "selected" else ""} value="{showMarkup oval}" >{oname}</option>|])
          opts
      ++
      [ [q|</select>|]
      , [q|</td></tr>|]
      ]
  
  
  ------------------------------------------------------------------------------
  -- | Create an input for enums driven by an HTML select.
  enumDropdown
      :: (FromJSON a, ToMarkup a, Enum a, Bounded a, Eq a)
      => String  -- ^ label
      -> a
      -> Suave a
  enumDropdown label =
    dropdown label $ fmap (showMarkup &&& id) [minBound .. maxBound]
  
  ------------------------------------------------------------------------------
  -- | A checkbox that turns off a class display
  checkboxShow :: String -> String -> Bool -> Suave Bool
  checkboxShow label cl =
    mkInput parseJSON $ \name v ->
    preEscapedString (showJs cl) <>
    preEscapedString [qc|
       <label for="{name}">{label}</label>
       <input id="{name}" onchange="showJs('{cl}','{name}');onChangeFunc(event)" type="checkbox" {bool ("" :: String) "checked='checked'" v} autocomplete="off">
       |]
  
  -- | js to show/hide a class based on a checkbox
  showJs :: String -> String
  showJs cl =
    [qc|
       <script>
          function showJs (cl, box) \{
            var vis = (document.getElementById(box).checked) ? "block" : "none";
            Array.from(document.getElementsByClassName("{cl}")).forEach(x => x.style.display = vis);
          };
       </script>
    |]
  
  -- | Modify the markup of a Suave
  markupF :: (Markup -> Markup) -> Suave a -> Suave a
  markupF f (Suave sa) = Suave $ do
    Input markup s v <- sa
    pure $ Input (f markup) s v
  
  -- | Wrap in a div
  div' :: String -> String -> Suave a -> Suave a
  div' cl st = markupF (\x ->
    preEscapedString [qc|<div class="{cl}" style="{st}">|] <>
    x <>
    preEscapedString "</div>")
  
  -- | show/hide style string
  display :: Bool -> String
  display b = "display:" ++ bool "none" "block" b
  
  -- | A checkbox that toggles visibility of another input (Suave a)
  toggleInput :: String -> Bool -> String -> Suave a -> Suave (Bool, a)
  toggleInput label start cl sa = do
    a <- div' cl (display start) sa
    c <- checkboxShow label cl start
    pure (c,a)
  