haskellerz-reflex-tutorial.hs

-- My setup with compile loop:
--   $ ./try-reflex
--   $ while (inotifywait -e close_write haskellerz-reflex-tutorial.hs || true); do ghcjs --make haskellerz-reflex-tutorial.hs 2>&1 | tee ghcid.txt; done
-- For my editor:
--   https://github.com/nh2/ghcid-sublime
-- Seeing the compiled result in my browser:
--   ./haskellerz-reflex-tutorial.jsexe/index.html
-- API docs:
--   $ ghc-pkg field reflex     haddock-html
--   $ ghc-pkg field reflex-dom haddock-html
--   Open the printed paths in your browser (appending "index.html" to the end).
-- Cheat sheets:
--   reflex:     https://github.com/reflex-frp/reflex/blob/develop/Quickref.md
--   reflex-dom: https://github.com/reflex-frp/reflex-dom/blob/develop/Quickref.md

{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecursiveDo #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# OPTIONS_GHC -Wall #-}

-- Library imports
import           Control.Monad (when)
import           Control.Monad.IO.Class
import           Data.Default (def)
import           Data.Functor (($>))
import qualified Data.Map as Map
import           Data.Monoid
import           Data.Text (Text)
import qualified Data.Text as T
import           Data.Traversable (for)
-- GHCJS specific imports
import           GHCJS.Types (JSString)
import           GHCJS.DOM.Types (toJSString)
-- Reflex specific imports
import           Reflex
import           Reflex.Dom


tutorialSection :: (MonadWidget t m) => m () -> m ()
tutorialSection widgets = divClass "tutorial-section" widgets


-- | Convenient function that pops up a javascript alert dialog box when an
-- event fires with a message to display.
--
-- Taken from the `reflex-dom-contrib` package.
alertEvent :: forall t m a . MonadWidget t m => (a -> String) -> Event t a -> m ()
alertEvent eventValueToStr e = performEvent_ (alert <$> e)
  where
    -- alert :: (MonadIO m) => String -> IO ()
    alert a = liftIO $ js_alert $ toJSString $ eventValueToStr a

foreign import javascript unsafe
  "alert($1)"
  js_alert :: JSString -> IO ()


showText :: (Show a) => a -> Text
showText = T.pack . show


dynButton :: (MonadWidget t m) => Dynamic t Text -> m (Event t ())
dynButton textDyn = do
  (e, _) <- el' "button" (dynText textDyn)
  return $ domEvent Click e


img :: (MonadWidget t m) => Text -> m ()
img src = elAttr "img" ("src" =: src) (return ())


main :: IO ()
main = mainWidget myWidgets

myWidgets :: forall t m . (MonadWidget t m) => m ()
myWidgets = do
  elAttr
    "link"
    ("href" =: "../haskellerz-reflex-tutorial.css" <>
     "rel" =: "stylesheet" <>
     "type" =: "text/css"
    ) $ return ()

  tutorialSection $ do
    text "Hello, world!"

  tutorialSection $ do
    text "We now have different tutorial sections."

    -- Nested HTML elements.
    el "p" (el "span" (text "Text in a span in a paragraph."))

    -- Nested HTML elements, monadic style.
    el "p" $ do
      el "span" $ do
        text "Text in a span in a paragraph."

  tutorialSection $ do
    -- The type returned by a button is an Event that contains
    -- () -- no more information than the fact that the event occurred.
    -- buttonEv :: Event t () <- button "Click me"
    -- But of course, we may leave the type away, as Haskell infers it.
    buttonEv <- button "Click me"
    alertEvent
      (\val -> "The button was clicked; the event contained: " ++ show val)
      buttonEv

  tutorialSection $ do
    -- Attaching values to events part 1:
    --   Pure values that are in scope.
    --
    -- We modify `Event`s purely via their `Functor`
    -- interface (using `fmap` or `<$>`).
    let myval = 5

    buttonEv :: Event t () <- button "Submit (value in scope)"

    let buttonEvWithLocalVal :: Event t Int
        buttonEvWithLocalVal = fmap (\() -> myval) buttonEv
     -- buttonEvWithLocalVal = (\() -> myval) <$> buttonEv

    alertEvent
      (\val -> "The button was clicked; the event contained: " ++ show val)
      buttonEvWithLocalVal

  tutorialSection $ do
    -- Dynamic values.
    text "Enter your name: "

    nameInput :: TextInput t <- textInput def

    let nameDyn :: Dynamic t Text
        nameDyn = _textInput_value nameInput

    text " Your name is: "
    dynText nameDyn

    divClass "age" $ do
      text "And age: "
      ageDyn <- _textInput_value <$> textInput def

      -- `Dynamic`s are Applicative; that way you can combine them.
      dynText $
        (\n a -> n <> " is " <> a) <$> nameDyn <*> ageDyn

    -- There are lots of other interesting Events and
    -- Dynamics on `TextInput` widgets, for example:
    --   _textInput_value :: Dynamic t Text    -- contents
    --   _textInput_keypress :: Event t Int    -- when a key is pressed
    --   _textInput_hasFocus :: Dynamic t Bool

    -- Having this pure `TextInput` type to pass around,
    -- containing various Events and Dynamics other parts of
    -- the code can react to, is a nice and composable design
    -- approach to GUI programming.

  tutorialSection $ do
    -- Attaching values to events part 2:
    --   Attaching the current value of a Dynamic value
    --   to an Event, when that event happens.
    --
    -- Example: We have a text box (whose events happen
    -- on every key press), but we want an Event to occur
    -- only when the submit button is clicked, and we want
    -- that event to carry the current value of the text box.
    text "What food would you like to order? "
    foodInputDyn <- _textInput_value <$> textInput def
    buttonEv <- button "Order"

    let foodOrderEv :: Event t Text
        foodOrderEv = tagPromptlyDyn foodInputDyn buttonEv

    alertEvent
      (\food -> "Ordered: " ++ T.unpack food)
      foodOrderEv

  tutorialSection $ do
    -- Making Dynamic values from events.
    --
    -- Dynamics contain the "state" of reflex FRP.
    -- Any input/output of information happens via Events.
    -- We declaratively express how events change our state
    -- by using `fold`-like functions.
    -- Recall
    --   foldl   :: (b -> a -> b) -> b -> [a] -> b
    -- What we use now looks very similar:
    --   foldDyn :: (a -> b -> b) -> b -> Event a -> m (Dynamic b)

    -- Helper function:
    let -- Makes a button with a number as label; the event
        -- generated by the label contains that number.
        numberButton :: Int -> m (Event t Int)
        numberButton n = do
          buttonEv <- button (showText n)
          let numberEv = fmap (\() -> n) buttonEv
          return numberEv

    button1Ev <- numberButton 1
    button2Ev <- numberButton 2
    button3Ev <- numberButton 3

    -- Now we want to create an event that happens when
    -- any of the buttons are clicked.
    -- Because multiple Events can in general happen at
    -- the same time (in practice we can't click that fast),
    -- we use `leftmost` to disambiguate which one to prefer.
    let anyButtonEv :: Event t Int
        anyButtonEv = leftmost [button1Ev, button2Ev, button3Ev]

    sumDyn <- foldDyn (+) 0 anyButtonEv

    dynText (showText <$> sumDyn)


  tutorialSection $ do
    -- Dependency loops.
    --
    -- So far our data flow was always one-directional
    -- (e.g. textbox to displayed text).
    -- A Monad captures this well with sequential `do`
    -- notation, where values can syntactically only refer
    -- to earlier declared values.
    -- But sometimes two Dynamic values must depend on
    -- each other -- a loop!
    -- This is possible using MonadFix and `rec` notation
    -- (`RecursiveDo`).

    rec
      textDyn <- _textInput_value <$> textInput def{
                   _textInputConfig_setValue = clearEvent
                 }
      buttonEv <- dynButton (("Clear: " <>) <$> textDyn)
      let clearEvent = const "" <$> buttonEv

      -- Notice how `textDyn` depends on `clearEvent`
      -- defined *below* it. `rec` makes it possible.

    return ()


  tutorialSection $ do
    -- Making widgets:
    --   Bundling state, behaviour and styling in reusable
    --   components, then composing them.

    -- A button that takes the given color when `isColored` is True.
    let colorButton :: Text -> Text -> Dynamic t Bool -> m (Event t ())
        colorButton label colorClass isColored = do
          let classDyn = ffor isColored $ \case
                True  -> colorClass <> " colored"
                False -> colorClass
          (e, _) <- elDynClass' "button" classDyn (text label)
          return $ domEvent Click e

    -- A button that can't be used unless `isEnabled` is True.
    let disableableButton :: Text -> Dynamic t Bool -> m (Event t ())
        disableableButton label isEnabled = do
          let attrsDyn = ffor isEnabled $ \case
                True  -> Map.empty
                False -> Map.fromList [("disabled", "")]
          (e, _) <- elDynAttr' "button" attrsDyn (text label)
          return $ domEvent Click e

    -- A question with yes/no answer buttons.
    let questionWidget :: Text -> m (Dynamic t Bool)
        questionWidget questionText = divClass "question" $ do
          rec
            divClass "questionText" $ text questionText
            yesEv <- colorButton "Yes" "green"          answerDyn
            noEv  <- colorButton "No"  "red"   (not <$> answerDyn)
            answerDyn <- holdDyn False $
              leftmost [ yesEv $> True, noEv $> False ]
          return answerDyn

    -- Some questions one needs to answer if before illegalizing
    -- something.
    let questions :: [Text]
        questions =
          [ "Have you checked with the senate?"
          , "Have you checked that this would be popular with the people?"
          , "Are you really sure?"
          ]

    let illegalizeWidget :: m ()
        illegalizeWidget = do
          text "What do you want to illegalize? "
          whatDyn <- _textInput_value <$> textInput def

          answerDyns <- for questions questionWidget
          let answersDyn = sequence answerDyns :: Dynamic t [Bool]
          let allYesDyn = and <$> answersDyn   :: Dynamic t  Bool

       -- Or shorter
       -- allYesDyn <- fmap and . sequence <$> for questions questionWidget

          buttonEv <- disableableButton "Illegalize!" allYesDyn

          currentlyIllegalDyn :: Dynamic t Text <-
            holdDyn "" (tagPromptlyDyn whatDyn buttonEv)

          let renderImageDyn :: Dynamic t (m ())
              renderImageDyn  =
                ffor currentlyIllegalDyn $ \what -> do
                  when (what /= "") $ do
                    divClass "illegal" $ do
                      img "http://hepwori.github.io/execorder/index.jpg"
                      divClass "illegalText" $ text (what <> " is now illegal.")

          -- So far all elements we've put on the page were static.
          -- `dyn` performs dynamic element rendering.
          -- Notice the type of `renderImageDyn`, it has an `m`
          -- (the widget creation Monad) inside the Dynamic.
          _ <- dyn renderImageDyn

          -- That way, when we enter nothing ("") into the text
          -- box, the `img` tag disappears from the DOM.

          return ()

    illegalizeWidget