PureScript Halogen demo for drawing on a canvas using Hooks

Main.purs

module Main where

import Prelude

import Data.Maybe (Maybe(..))
import Data.Newtype (class Newtype)
import Data.Traversable (sequence, traverse_)
import Effect (Effect)
import Effect.Aff.Class (class MonadAff)
import Effect.Class (liftEffect)
import Graphics.Canvas (Context2D, fillRect, getCanvasElementById, getContext2D, setFillStyle)
import Halogen as H
import Halogen.Aff as HA
import Halogen.HTML as HH
import Halogen.HTML.Properties as HP
import Halogen.Hooks (Hook, UseEffect)
import Halogen.Hooks as Hooks
import Halogen.VDom.Driver (runUI)

main :: Effect Unit
main =
  HA.runHalogenAff do
    body <- HA.awaitBody
    runUI canvasComponent unit body

canvasComponent ::
  forall query input output m.
  MonadAff m =>
  H.Component HH.HTML query input output m
canvasComponent =
  Hooks.component \_ _ -> Hooks.do
    drawOnCanvas
    Hooks.pure $ HH.canvas [ HP.id_ "canvas", HP.width 300, HP.height 300 ]

newtype DrawOnCanvas hooks
  = DrawOnCanvas (UseEffect hooks)

derive instance newtypeDrawOnCanvas :: Newtype (DrawOnCanvas hooks) _

drawOnCanvas :: forall m. MonadAff m => Hook m DrawOnCanvas Unit
drawOnCanvas =
  Hooks.wrap Hooks.do
    Hooks.captures {} Hooks.useTickEffect do
      mcanvas <- liftEffect $ getCanvasElementById "canvas"
      mcontext <- liftEffect $ sequence $ getContext2D <$> mcanvas
      traverse_ drawRect mcontext
      pure Nothing
    Hooks.pure unit

drawRect :: forall m. MonadAff m => Context2D -> m Unit
drawRect context = do
  liftEffect $ setFillStyle context "red"
  liftEffect
    $ fillRect context { x: 100.0, y: 50.0, width: 200.0, height: 25.0 }