Canvas schematic arrows

SmartArt.purs

module SmartArt where

import Prelude (bind, ($), (+), (*), (-), (/), pure)
import Control.Monad.Eff (Eff)
import Graphics.Canvas (CANVAS, fillPath, setFillStyle, moveTo, lineTo, fillText, setFont, measureText, Context2D)
import Data.List (List(..))

drawArrows :: forall eff. Context2D -> Number -> Number -> Number -> List String -> Eff (canvas :: CANVAS | eff) Number
drawArrows ctx dx x y Nil = pure x
drawArrows ctx dx x y (Cons l ls) = do
  drawnWidth <- drawArrow ctx x y l
  drawArrows ctx dx (x + drawnWidth + dx) y ls

drawArrow :: forall eff. Context2D -> Number -> Number -> String -> Eff (canvas :: CANVAS | eff) Number
drawArrow ctx x y txt = do
  setFillStyle "#FF00AA" ctx
  let u = 20.0
      rectHeight = 4.0
      arrowLength = 3.0
      arrowDelta = 1.0
      padding = 5.0

  setFont "normal 20pt sans-serif" ctx

  m <- measureText ctx txt

  let rectLength = m.width + 2.0 * padding

  fillPath ctx $ do
    moveTo ctx x y
    lineTo ctx (x + rectLength) y
    lineTo ctx (x + rectLength) (y - (arrowDelta * u))
    lineTo ctx (x + (rectLength + (arrowLength) * u)) (y + (rectHeight * u / 2.0))
    lineTo ctx (x + rectLength) (y + (rectHeight * u + (arrowDelta * u)))
    lineTo ctx (x + rectLength) (y + (rectHeight * u))
    lineTo ctx x (y + (rectHeight * u))
    lineTo ctx x y

  setFillStyle "#000000" ctx

  fillText ctx txt (x + padding) (y + 10.0 + (rectHeight * u / 2.0))

  pure (rectLength + (arrowLength * u))