Remove useless Aff stuff

Remove useless Aff stuff

module Hyper.Routing.TypeLevelRouterSpec (spec) where

import Prelude
import Data.Either (Either(..))
import Data.Maybe (Maybe(..))
import Data.String (trim)
import Data.URI (printURI)
import Hyper.Routing.TypeLevelRouter (class FromHttpData, class ToHttpData, type (:/), type (:<|>), type (:>), Capture, Get, RoutingError(..), fromPathPiece, linkTo, runRouter, (:<|>))
import Test.Spec (Spec, describe, it)
import Test.Spec.Assertions (shouldEqual)
import Type.Proxy (Proxy(..))

newtype PostID = PostID Int

instance fromHttpDataPostID :: FromHttpData PostID where
  fromPathPiece s = do
    n <- fromPathPiece s
    if n >= 1
      then Right (PostID n)
      else Left "PostID must be equal to or greater than 1."

instance toHttpDataPostID :: ToHttpData PostID where
  toPathPiece (PostID n) = show n

newtype UserID = UserID String

instance fromHttpDataUserID :: FromHttpData UserID where
  fromPathPiece s =
    case trim s of
      "" -> Left "UserID cannot be blank."
      s' -> Right (UserID s')

instance toHttpDataUserID :: ToHttpData UserID where
  toPathPiece (UserID s) = s

type Root = Get "text/html"
type GetPost = "posts" :/ Capture "id" PostID :> Get "text/plain"
type UserRoutes = "users" :/ Capture "user-id" UserID :> ("profile" :/ Get "text/plain"
                                                          :<|> "settings" :/ Get "text/plain")

type TestAPI =
  Root
  :<|> GetPost
  :<|> UserRoutes -- nested routes with capture

request :: String -> String -> Either RoutingError String
request method url =
  runRouter (Proxy :: Proxy TestAPI) handlers method url
  where
    renderHtml = "
HTML
"
    renderPost (PostID n) = "Post #" <> show n

    userHandlers userId = renderProfile userId :<|> renderSettings userId
    renderProfile (UserID s) = "Profile of " <> s
    renderSettings (UserID s) = "Settings of " <> s

    handlers = (renderHtml :<|> renderPost :<|> userHandlers)

spec :: forall e. Spec e Unit
spec =
  describe "Hyper.Routing.TypeLevelRouter" do
    describe "links" do
      it "returns link for Lit" $
        printURI (linkTo (Proxy :: Proxy Root)) `shouldEqual` "/"

      it "returns link for Lit and Capture" $
        printURI (linkTo (Proxy :: Proxy GetPost) (PostID 10)) `shouldEqual` "/posts/10/"

    describe "route" do
      it "matches root" do
        request "GET" "/" `shouldEqual` Right "
HTML
"

      it "matches custom Capture" do
        request "GET" "/posts/123/" `shouldEqual` Right "Post #123"

      it "validates based on customer Capture instance" do
        request "GET" "/posts/0/"
          `shouldEqual`
          Left (HTTPError 400 (Just "PostID must be equal to or greater than 1."))

      it "matches nested routes" do
        request "GET" "/users/owi/profile/" `shouldEqual` Right "Profile of owi"

module Hyper.Routing.TypeLevelRouterSpec (spec) where

import Prelude
import Control.Monad.Aff (Aff)
import Control.Monad.Eff.Class (liftEff)
import Data.Either (Either(..))
import Data.Maybe (Maybe(..))
import Data.String (trim)
import Data.URI (printURI)
import Hyper.Routing.TypeLevelRouter (class FromHttpData, class ToHttpData, type (:/), type (:<|>), type (:>), Capture, Get, RoutingError(..), fromPathPiece, linkTo, runRouter, (:<|>))
import Test.Spec (Spec, describe, it)
import Test.Spec.Assertions (shouldEqual)
import Type.Proxy (Proxy(..))

newtype PostID = PostID Int

instance fromHttpDataPostID :: FromHttpData PostID where
  fromPathPiece s = do
    n <- fromPathPiece s
    if n >= 1
      then Right (PostID n)
      else Left "PostID must be equal to or greater than 1."

instance toHttpDataPostID :: ToHttpData PostID where
  toPathPiece (PostID n) = show n

newtype UserID = UserID String

instance fromHttpDataUserID :: FromHttpData UserID where
  fromPathPiece s =
    case trim s of
      "" -> Left "UserID cannot be blank."
      s' -> Right (UserID s')

instance toHttpDataUserID :: ToHttpData UserID where
  toPathPiece (UserID s) = s

type Root = Get "text/html"
type GetPost = "posts" :/ Capture "id" PostID :> Get "text/plain"
type UserRoutes = "users" :/ Capture "user-id" UserID :> ("profile" :/ Get "text/plain"
                                                          :<|> "settings" :/ Get "text/plain")

type TestAPI =
  Root
  :<|> GetPost
  :<|> UserRoutes -- nested routes with capture

request :: forall e. String -> String -> Aff e (Either RoutingError String)
request method url =
  case runRouter (Proxy :: Proxy TestAPI) handlers method url of
    Left err -> liftEff (pure (Left err))
    Right e -> liftEff (Right <$> e)
  where
    renderHtml = pure "
HTML
"
    renderPost (PostID n) = pure $ "Post #" <> show n

    userHandlers userId = renderProfile userId :<|> renderSettings userId
    renderProfile (UserID s) = pure $ "Profile of " <> s
    renderSettings (UserID s) = pure $ "Settings of " <> s

    handlers = (renderHtml :<|> renderPost :<|> userHandlers)

spec :: forall e. Spec e Unit
spec =
  describe "Hyper.Routing.TypeLevelRouter" do
    describe "links" do
      it "returns link for Lit" $
        printURI (linkTo (Proxy :: Proxy Root)) `shouldEqual` "/"

      it "returns link for Lit and Capture" $
        printURI (linkTo (Proxy :: Proxy GetPost) (PostID 10)) `shouldEqual` "/posts/10/"

    describe "route" do
      it "matches root" do
        res <- request "GET" "/"
        res `shouldEqual` Right "
HTML
"

      it "matches custom Capture" do
        res <- request "GET" "/posts/123/"
        res `shouldEqual` Right "Post #123"

      it "validates based on customer Capture instance" do
        res <- request "GET" "/posts/0/"
        res `shouldEqual` Left (HTTPError 400 (Just "PostID must be equal to or greater than 1."))

      it "matches nested routes" do
        res <- request "GET" "/users/owi/profile/"
        res `shouldEqual` Right "Profile of owi"


name & refer to layers by strings

name & refer to layers by strings

-- | This module provides a HTML5 canvas interface for the genetics browser,
-- | which wraps and optimizes all rendering calls

module Genetics.Browser.Canvas where

import Prelude

import Control.Monad.Aff (Aff, delay)
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Class (class MonadEff, liftEff)
import Control.Monad.Eff.Ref (REF, Ref)
import Control.Monad.Eff.Ref as Ref
import Control.Monad.Eff.Uncurried (EffFn2, EffFn3, EffFn4, runEffFn2, runEffFn3, runEffFn4)
import Control.Monad.Maybe.Trans (MaybeT(..), runMaybeT)
import Control.Monad.Trans.Class (lift)
import DOM.Node.Types (Element)
import Data.Either (Either(..))
import Data.Foldable (any, fold, foldl, for_)
import Data.Int as Int
import Data.Lens (Getter', Lens', Prism', Traversal, Traversal', iso, lens, lens', prism', re, to, united, view, (^.), (^?))
import Data.Lens.Iso (Iso')
import Data.Lens.Iso.Newtype (_Newtype)
import Data.Lens.Record as Lens
import Data.List (List)
import Data.List as List
import Data.Map (Map)
import Data.Map as Map
import Data.Maybe (Maybe(Nothing, Just), fromMaybe)
import Data.Monoid (class Monoid, mempty)
import Data.Newtype (class Newtype, unwrap)
import Data.Nullable (Nullable, toMaybe)
import Data.Symbol (SProxy(..))
import Data.Time.Duration (Milliseconds)
import Data.Traversable (traverse, traverse_)
import Data.TraversableWithIndex (forWithIndex, traverseWithIndex)
import Data.Tuple (Tuple(Tuple), uncurry)
import Data.Variant (Variant, case_, onMatch)
import Debug.Trace as Debug
import Genetics.Browser.Layer (Component(..), ComponentSlot, Layer(..), LayerDimensions, LayerMask(..), LayerPadding, LayerSlots, LayerType(..), layerSlots)
import Graphics.Canvas (CanvasElement, Context2D)
import Graphics.Canvas as Canvas
import Graphics.Drawing (Drawing, Point)
import Graphics.Drawing (render, translate) as Drawing
import Graphics.Drawing.Font (font, fontString) as Drawing
import Graphics.Drawing.Font (sansSerif)
import Unsafe.Coerce (unsafeCoerce)

_Element :: Iso' CanvasElement Element
_Element = iso unsafeCoerce unsafeCoerce

-- | Create a new CanvasElement, not attached to the DOM, with the provided String as its CSS class
foreign import createCanvas :: ∀ eff.
                               { width :: Number, height :: Number }
                            -> String
                            -> Eff eff CanvasElement

foreign import setElementStyleImpl :: ∀ e.
                                      EffFn3 e
                                      Element String String
                                      Unit

setElementStyle :: Element
                -> String
                -> String
                -> Eff _ Unit
setElementStyle = runEffFn3 setElementStyleImpl

setElementStyles :: Element -> Array (Tuple String String) -> Eff _ Unit
setElementStyles el =
  traverse_ (uncurry $ setElementStyle el)

setCanvasStyles :: CanvasElement -> Array (Tuple String String) -> Eff _ Unit
setCanvasStyles = setElementStyles <<< view _Element

setCanvasStyle :: CanvasElement
               -> String
               -> String
               -> Eff _ Unit
setCanvasStyle ce = setElementStyle (ce ^. _Element)

setCanvasZIndex :: CanvasElement -> Int -> Eff _ Unit
setCanvasZIndex ce i = setCanvasStyle ce "z-index" (show i)

setCanvasPosition :: ∀ r.
                     { left :: Number, top :: Number | r }
                  -> CanvasElement
                  -> Eff _ Unit
setCanvasPosition {left, top} ce =
  setCanvasStyles ce
    [ Tuple "position" "absolute"
    , Tuple "top"  (show top  <> "px")
    , Tuple "left" (show left <> "px") ]

foreign import appendCanvasElem :: ∀ e.
                                   Element
                                -> CanvasElement
                                -> Eff e Unit

-- | Sets some of the browser container's CSS to reasonable defaults
foreign import setContainerStyle :: ∀ e. Element -> Canvas.Dimensions -> Eff e Unit

foreign import drawCopies :: ∀ eff a.
                             EffFn4 eff
                             CanvasElement Canvas.Dimensions Context2D (Array Point)
                             Unit

foreign import setCanvasTranslation :: ∀ e.
                                       Point
                                    -> CanvasElement
                                    -> Eff e Unit

foreign import canvasClickImpl :: ∀ e.
                                  EffFn2 e
                                  CanvasElement (Point -> Eff e Unit)
                                  Unit

canvasClick :: CanvasElement -> (Point -> Eff _ Unit) -> Eff _ Unit
canvasClick = runEffFn2 canvasClickImpl

-- | Attaches two callbacks to the BrowserCanvas click event handler,
-- | provided with the track canvas and static overlay canvas' relative
-- | coordinates of the click, respectively.
browserOnClick :: BrowserCanvas
               -> { track   :: Point -> Eff _ Unit
                  , overlay :: Point -> Eff _ Unit }
               -> Eff _ Unit
browserOnClick (BrowserCanvas bc) {track, overlay} =
  canvasClick bc.staticOverlay \o -> do
    let t = { x: o.x - bc.trackPadding.left
            , y: o.y - bc.trackPadding.top }
    overlay o
    track t

foreign import scrollCanvasImpl :: ∀ e.
                                   EffFn3 e
                                   CanvasElement CanvasElement Point
                                   Unit

scrollCanvas :: BufferedCanvas
             -> Point
             -> Eff _ Unit
scrollCanvas (BufferedCanvas bc) = runEffFn3 scrollCanvasImpl bc.back bc.front

scrollCanvas' :: BrowserContainer
              -> Point
              -> Eff _ Unit
scrollCanvas' (BrowserContainer bc) pt = do
  layers <- Ref.readRef bc.layers

  for_ layers $ \lc -> case lc ^? _LayerCanvas <<< _Buffer of
    Nothing -> pure unit
    Just bc -> scrollCanvas bc pt

foreign import canvasDragImpl :: ∀ eff.
                                 CanvasElement
                              -> ( { during :: Nullable Point
                                   , total :: Nullable Point } -> Eff eff Unit )
                              -> Eff eff Unit

foreign import canvasWheelCBImpl :: ∀ eff.
                                    CanvasElement
                                 -> (Number -> Eff eff Unit)
                                 -> Eff eff Unit

canvasDrag :: (Either Point Point -> Eff _ Unit)
           -> CanvasElement
           -> Eff _ Unit
canvasDrag f el =
  let toEither g {during, total} = case toMaybe during of
        Just p  -> g $ Right p
        Nothing -> g $ Left $ fromMaybe {x:zero, y:zero} $ toMaybe total
  in canvasDragImpl el (toEither f)

-- | Takes a BrowserCanvas and a callback function that is called with the
-- | total dragged distance when a click & drag action is completed.
dragScroll :: BrowserCanvas
           -> (Point -> Eff _ Unit)
           -> Eff _ Unit
dragScroll (BrowserCanvas bc) cb = canvasDrag f bc.staticOverlay
  where f = case _ of
              Left  p     -> cb p
              Right {x} -> do
                let p' = {x: -x, y: 0.0}
                scrollCanvas (_.canvas $ unwrap bc.track) p'
                scrollCanvas bc.trackOverlay p'

dragScroll' :: BrowserContainer
            -> (Point -> Eff _ Unit)
            -> Eff _ Unit
dragScroll' bc'@(BrowserContainer {element}) cb =
  canvasDrag f (unsafeCoerce element) -- actually safe
  where f = case _ of
              Left  p    -> cb p
              Right {x} -> do
                let p' = {x: -x, y: 0.0}
                scrollCanvas' bc' p'

-- | Takes a BrowserCanvas and a callback function that is called with each
-- | wheel scroll `deltaY`. Callback is provided with only the sign of `deltaY`
-- | as to be `deltaMode` agnostic.
wheelZoom :: BrowserCanvas
          -> (Number -> Eff _ Unit)
          -> Eff _ Unit
wheelZoom (BrowserCanvas bc) cb =
  canvasWheelCBImpl bc.staticOverlay cb

wheelZoom' :: BrowserContainer
          -> (Number -> Eff _ Unit)
          -> Eff _ Unit
wheelZoom' bc cb = Debug.trace "unimplemented!" \_ -> pure unit
  -- canvasWheelCBImpl bc.staticOverlay cb

-- | Helper function for erasing the contents of a canvas context given its dimensions
clearCanvas :: Context2D -> Canvas.Dimensions -> Eff _ Unit
clearCanvas ctx {width, height} =
  void $ Canvas.clearRect ctx { x: 0.0, y: 0.0, w: width, h: height }

blankLayer :: LayerContainer
           -> Eff _ Unit
blankLayer (LayerContainer lc) =
  case lc.canvas of
    Buffer bc -> blankBuffer bc
    Static el -> do
      setCanvasTranslation {x: zero, y: zero} el
      ctx <- Canvas.getContext2D el
      clearCanvas ctx lc.dimensions.size

-- TODO browser background color shouldn't be hardcoded
backgroundColor :: String
backgroundColor = "white"

-- TODO the back canvas should have the option of being bigger than
-- the front, to minimize redrawing
-- needs adding the offset of the front canvas, and validating that back >= front
newtype BufferedCanvas =
  BufferedCanvas { back  :: CanvasElement
                 , front :: CanvasElement
                 }

derive instance newtypeBufferedCanvas :: Newtype BufferedCanvas _

createBufferedCanvas :: Canvas.Dimensions
                     -> Eff _ BufferedCanvas
createBufferedCanvas dim = do
  back  <- createCanvas dim "buffer"
  front <- createCanvas dim "front"
  let bc = BufferedCanvas { back, front }
  blankBuffer bc
  pure bc

getBufferedContext :: BufferedCanvas
                   -> Eff _ Context2D
getBufferedContext = Canvas.getContext2D <$> _.front <<< unwrap

setBufferedCanvasSize :: Canvas.Dimensions
                      -> BufferedCanvas
                      -> Eff _ Unit
setBufferedCanvasSize dim bc@(BufferedCanvas {back, front}) = do
  _ <- Canvas.setCanvasDimensions dim back
  _ <- Canvas.setCanvasDimensions dim front
  blankBuffer bc
  pure unit

translateBuffer :: Point
                -> BufferedCanvas
                -> Eff _ Unit
translateBuffer p (BufferedCanvas bc) = do
  setCanvasTranslation p bc.back
  setCanvasTranslation p bc.front

drawToBuffer :: BufferedCanvas
             -> (Context2D -> Eff _ Unit)
             -> Eff _ Unit
drawToBuffer (BufferedCanvas {back}) f = do
  ctx <- Canvas.getContext2D back
  f ctx

drawToLayer :: LayerContainer
            -> (Context2D -> Eff _ Unit)
            -> Eff _ Unit
drawToLayer (LayerContainer lc) f =
  case lc.canvas of
    Static c -> f =<< Canvas.getContext2D c
    Buffer b -> drawToBuffer b f

blankBuffer :: BufferedCanvas
            -> Eff _ Unit
blankBuffer bc@(BufferedCanvas {back, front}) = do
  translateBuffer {x: zero, y: zero} bc

  dim <- Canvas.getCanvasDimensions back

  for_ [back, front]
    $ flip clearCanvas dim <=< Canvas.getContext2D

flipBuffer :: BufferedCanvas
           -> Eff _ Unit
flipBuffer (BufferedCanvas {back, front}) = do
-- NOTE this assumes back and front are the same size
  frontCtx <- Canvas.getContext2D front
  let imgSrc = Canvas.canvasElementToImageSource back

  dim <- Canvas.getCanvasDimensions front

  clearCanvas frontCtx dim
  _ <- Canvas.drawImage frontCtx imgSrc 0.0 0.0
  pure unit

-- | The `width` & `height` of the TrackCanvas is the area glyphs render to;
-- | the browser shows a `width` pixels slice of the whole coordinate system.
-- | `glyphBuffer` is what individual glyphs can be rendered to and copied from, for speed.
newtype TrackCanvas =
  TrackCanvas { canvas      :: BufferedCanvas
              , dimensions  :: Canvas.Dimensions
              , glyphBuffer :: CanvasElement
              }

-- | using hardcoded inner padding for now; makes it look a bit better
trackInnerPad :: Number
trackInnerPad = 5.0

derive instance newtypeTrackCanvas :: Newtype TrackCanvas _

_Dimensions :: ∀ n r1 r2.
               Newtype n { dimensions :: Canvas.Dimensions | r1 }
            => Lens' n Canvas.Dimensions
_Dimensions = _Newtype <<< Lens.prop (SProxy :: SProxy "dimensions")

trackTotalDimensions :: Canvas.Dimensions -> Canvas.Dimensions
trackTotalDimensions d = { width:  d.width  + extra
                         , height: d.height + extra }
  where extra = 2.0 * trackInnerPad

trackCanvas :: Canvas.Dimensions
            -> Eff _ TrackCanvas
trackCanvas dim = do
  canvas <- createBufferedCanvas $ trackTotalDimensions dim
  glyphBuffer <- createCanvas glyphBufferSize "glyphBuffer"

  pure $ TrackCanvas { dimensions: dim
                     , canvas, glyphBuffer }

setTrackCanvasSize :: Canvas.Dimensions
                   -> TrackCanvas
                   -> Eff _ TrackCanvas
setTrackCanvasSize dim (TrackCanvas tc) = do
  setBufferedCanvasSize (trackTotalDimensions dim) tc.canvas
  pure $ TrackCanvas
    $ tc { dimensions = dim }

-- TODO change name to BrowserPadding
type TrackPadding =
  { left :: Number, right :: Number
  , top :: Number, bottom :: Number }

-- | A `BrowserCanvas` consists of a double-buffered `track`
-- | which is what the genetics browser view is rendered onto,
-- | and a transparent `staticOverlay` canvas the UI is rendered onto,
-- | with a (also transparent) `trackOverlay` that scrolls with the track view.

-- | The `dimensions`, `trackPadding`, and track.width/height are
-- | related such that
-- | track.width + horizontal.left + horizontal.right = dimensions.width
-- | track.height + vertical.top + vertical.bottom = dimensions.height
newtype BrowserCanvas =
  BrowserCanvas { track         :: TrackCanvas
                , trackPadding  :: TrackPadding
                , dimensions    :: Canvas.Dimensions
                , staticOverlay :: CanvasElement
                , trackOverlay  :: BufferedCanvas
                , container :: Element
                }

derive instance newtypeBrowserCanvas :: Newtype BrowserCanvas _

newtype BrowserContainer =
  BrowserContainer { layers      :: Ref (Map String LayerContainer)
                   , dimensions  :: Ref LayerDimensions -- ? is this better just kept as a function?
                   , element     :: Element
                   , glyphBuffer :: CanvasElement}

derive instance newtypeBrowserContainer :: Newtype BrowserContainer _

getDimensions :: ∀ m.
                 MonadEff _ m
              => BrowserContainer
              -> m LayerDimensions
getDimensions (BrowserContainer {dimensions}) =
  liftEff $ Ref.readRef dimensions

_Track :: Lens' BrowserCanvas TrackCanvas
_Track = _Newtype <<< Lens.prop (SProxy :: SProxy "track")

foreign import debugBrowserCanvas :: ∀ e.
                                     String
                                  -> BrowserCanvas
                                  -> Eff e Unit

subtractPadding :: Canvas.Dimensions
                -> TrackPadding
                -> Canvas.Dimensions
subtractPadding {width, height} pad =
  { width:  width - pad.left - pad.right
  , height: height - pad.top - pad.bottom }

type UISlot = { offset :: Point
              , size   :: Canvas.Dimensions }

data UISlotGravity = UILeft | UIRight | UITop | UIBottom

derive instance eqUISlotGravity :: Eq UISlotGravity
derive instance ordUISlotGravity :: Ord UISlotGravity

type UISlots = { left   :: UISlot
               , right  :: UISlot
               , top    :: UISlot
               , bottom :: UISlot }

uiSlots :: BrowserCanvas
        -> UISlots
uiSlots (BrowserCanvas bc) =
  let track   = subtractPadding bc.dimensions bc.trackPadding
      browser = bc.dimensions
      pad     = bc.trackPadding
  in { left:   { offset: { x: 0.0, y: pad.top }
               , size:   { height: track.height, width: pad.left }}
     , right:  { offset: { x: browser.width - pad.right, y: pad.top }
               , size:   { height: track.height, width: pad.right }}
     , top:    { offset: { x: pad.left, y: 0.0 }
               , size:   { height: pad.top, width: track.width }}
     , bottom: { offset: { x: browser.width  - pad.right
                         , y: browser.height - pad.bottom }
               , size:   { height: pad.bottom, width: track.width }}
    }

setBrowserCanvasSize :: Canvas.Dimensions
                     -> BrowserCanvas
                     -> Eff _ BrowserCanvas
setBrowserCanvasSize dim (BrowserCanvas bc) = do

  setContainerStyle bc.container dim
  let trackDim = subtractPadding dim bc.trackPadding

  track <- setTrackCanvasSize trackDim bc.track

  setBufferedCanvasSize dim bc.trackOverlay
  _ <- Canvas.setCanvasDimensions dim bc.staticOverlay

  pure $ BrowserCanvas
       $ bc { dimensions = dim
            , track = track }

setBrowserContainerSize :: Canvas.Dimensions
                        -> BrowserContainer
                        -> Eff _ Unit
setBrowserContainerSize dim bc'@(BrowserContainer bc) = do
  -- set the container
  setContainerStyle bc.element dim
  -- set each layer
  _ <- traverseLayers (\l@(LayerContainer lc) -> resizeLayer (lc.dimensions { size = dim }) l) bc'
  -- layers <- getLayers bc
  -- traverse f layers
  pure unit

-- | Creates a `BrowserCanvas` and appends it to the provided element.
-- | Resizes the container element to fit.
browserCanvas :: Canvas.Dimensions
              -> TrackPadding
              -> Element
              -> Eff _ BrowserCanvas
browserCanvas dimensions trackPadding el = do

  setContainerStyle el dimensions

  let trackDim = subtractPadding dimensions trackPadding
  track   <- trackCanvas trackDim

  trackOverlay  <- createBufferedCanvas { width: trackDim.width
                                        , height: dimensions.height }

  staticOverlay <- createCanvas dimensions "staticOverlay"

  let trackEl = _.front  $ unwrap
                $ _.canvas $ unwrap $ track

      trackOverlayEl = _.front $ unwrap $ trackOverlay

  setCanvasZIndex trackEl 10
  setCanvasZIndex trackOverlayEl 20
  setCanvasZIndex staticOverlay 30

  -- TODO handle this nicer maybe idk
  let trackElPosition = { left: trackPadding.left - trackInnerPad
                        , top:  trackPadding.top  - trackInnerPad }

  setCanvasPosition trackElPosition trackEl
  setCanvasPosition { left: trackPadding.left, top: 0.0 } trackOverlayEl
  setCanvasPosition { left: 0.0, top: 0.0} staticOverlay

  appendCanvasElem el trackEl
  appendCanvasElem el trackOverlayEl
  appendCanvasElem el staticOverlay

  pure $ BrowserCanvas { dimensions
                       , track, trackPadding
                       , trackOverlay, staticOverlay
                       , container: el}

-- TODO calculate based on glyph bounding boxes
glyphBufferSize :: Canvas.Dimensions
glyphBufferSize = { width: 15.0, height: 300.0 }

-- | Creates an *empty* BrowserContainer, to which layers can be added
browserContainer :: Canvas.Dimensions
                 -> LayerPadding
                 -> Element
                 -> Eff _ BrowserContainer
browserContainer size padding element = do

  setContainerStyle element size

  glyphBuffer <- createCanvas glyphBufferSize "glyphBuffer"

  dimensions <- Ref.newRef { size, padding }
  layers     <- Ref.newRef mempty

  pure $
    BrowserContainer
      { layers, dimensions, element, glyphBuffer }

-- | Set the CSS z-indices of the Layers in the browser, so their
-- | canvases are drawn in the correct order (i.e. as the
-- | BrowserContainer layer list is ordered)
zIndexLayers :: BrowserContainer
             -> Eff _ Unit
zIndexLayers (BrowserContainer bc) = do
  layers <- Ref.readRef bc.layers
  void $ forWithIndex layers
           (\i l -> setCanvasZIndex
                      (l ^. _LayerCanvas <<< _FrontCanvas) i)

traverseLayers :: ∀ m a.
                  MonadEff _ m
               => (LayerContainer -> m a)
               -> BrowserContainer
               -> m (Map String a)
traverseLayers f bc = do
  layers <- getLayers bc
  traverse f layers

getLayers :: ∀ m.
             MonadEff _ m
          => BrowserContainer
          -> m (Map String LayerContainer)
getLayers (BrowserContainer bc) =
  liftEff $ Ref.readRef bc.layers

resizeLayer :: ∀ m.
               MonadEff _ m
            => LayerDimensions
            -> LayerContainer
            -> m LayerContainer
resizeLayer ld' (LayerContainer lc) = liftEff do
  case lc.canvas of
    Static e -> void $ Canvas.setCanvasDimensions lc.dimensions.size e
    Buffer b -> setBufferedCanvasSize lc.dimensions.size b

  pure $ LayerContainer (lc { dimensions = ld' })

appendLayer :: BrowserContainer
            -> LayerContainer
            -> Eff _ Unit
appendLayer bc@(BrowserContainer {element}) l@(LayerContainer lc)  = do
  layers <- getLayers bc
  appendCanvasElem element (lc.canvas ^. _FrontCanvas)
  zIndexLayers bc

addLayers :: BrowserContainer
          -> List LayerContainer
          -> Eff _ Unit
addLayers bc = traverse_ (appendLayer bc)

deleteLayers :: BrowserContainer
             -> Eff _ Unit
deleteLayers (BrowserContainer bc) = do
  Ref.writeRef bc.layers mempty
  -- TODO update the DOM appropriately,
  -- by just removing the children of bc.element??? or be more specific

  -- maybe expose a function (BrowserContainer -> (LayerContainer -> Eff _ a) -> Eff _ (List a))
  -- so we can effectfully traverse all the layers.
  -- sounds useful at least~~

renderGlyphs :: TrackCanvas
             -> { drawing :: Drawing, points :: Array Point }
             -> Eff _ Unit
renderGlyphs (TrackCanvas tc) {drawing, points} = do
  glyphBfr <- Canvas.getContext2D tc.glyphBuffer
  ctx <- getBufferedContext tc.canvas

  let w = glyphBufferSize.width
      h = glyphBufferSize.height
      x0 = w / 2.0
      y0 = h / 2.0

  clearCanvas glyphBfr glyphBufferSize

  Drawing.render glyphBfr
    $ Drawing.translate x0 y0 drawing

  runEffFn4 drawCopies tc.glyphBuffer glyphBufferSize ctx points

renderGlyphs' :: CanvasElement
              -- -> LayerContainer
              -> Canvas.Context2D
              -> { drawing :: Drawing, points :: Array Point }
              -> Eff _ Unit
renderGlyphs' glyphBuffer ctx {drawing, points} = do
  glyphCtx <- Canvas.getContext2D glyphBuffer

  let w = glyphBufferSize.width
      h = glyphBufferSize.height
      x0 = w / 2.0
      y0 = h / 2.0

  clearCanvas glyphCtx glyphBufferSize

  Drawing.render glyphCtx
    $ Drawing.translate x0 y0 drawing

  runEffFn4 drawCopies glyphBuffer glyphBufferSize ctx points

type Label = { text :: String, point :: Point, gravity :: LabelPlace }

data LabelPlace = LLeft | LCenter | LRight

derive instance eqLabelPlace :: Eq LabelPlace

-- hardcoded global label font for now
-- can't use Drawing.Font because we need raw Canvas to measure the text size,
-- but we can at least use Drawing to generate the font string

labelFontSize :: Int
labelFontSize = 14

labelFont :: String
labelFont = Drawing.fontString $ Drawing.font sansSerif labelFontSize mempty

-- | Calculate the rectangle covered by a label when it'd be rendered
-- | to a provided canvas context
labelBox :: Context2D -> Label -> Eff _ Canvas.Rectangle
labelBox ctx {text, point, gravity} = do
  {width} <- Canvas.withContext ctx do
    _ <- Canvas.setFont labelFont ctx
    Canvas.measureText ctx text

  -- close enough height, actually calculating it is a nightmare
  let height = Int.toNumber labelFontSize
      pad = 14.0 + width / 2.0
      x = case gravity of
        LCenter -> point.x
        LLeft   -> point.x - pad
        LRight  -> point.x + pad

  pure $ { x
         , y: point.y - height
         , w: width, h: height }

-- | Returns `true` if the input rectangles overlap
isOverlapping :: Canvas.Rectangle
              -> Canvas.Rectangle
              -> Boolean
isOverlapping r1 r2 =
     r1.x < r2.x + r2.w
  && r1.x + r1.w > r2.x
  && r1.y < r2.y + r2.h
  && r1.h + r1.y > r2.y

eqRectangle :: Canvas.Rectangle
            -> Canvas.Rectangle
            -> Boolean
eqRectangle {x,y,w,h} r =
     x == r.x && y == r.y
  && w == r.w && h == r.h

appendBoxed :: ∀ r.
               Array {rect :: Canvas.Rectangle | r}
            -> {rect :: Canvas.Rectangle | r}
            -> Array {rect :: Canvas.Rectangle | r}
appendBoxed sofar next =
  let overlapsAny :: Boolean
      overlapsAny = any overlaps sofar
        where overlaps r' = (not $ eqRectangle next.rect r'.rect)
                            && next.rect `isOverlapping` r'.rect
  in if overlapsAny then sofar else sofar <> [next]

renderLabels :: Array Label -> Context2D -> Eff _ Unit
renderLabels ls ctx = do

  boxed <- traverse (\l -> {text: l.text, rect: _} <$> labelBox ctx l) ls

  let toRender = foldl appendBoxed [] boxed

  Canvas.withContext ctx do
    _ <- Canvas.setFont labelFont ctx

    for_ toRender \box ->
      Canvas.fillText ctx box.text
        (box.rect.x - (box.rect.w / 2.0))
        box.rect.y

type Renderable r = { drawings :: Array { drawing :: Drawing
                                        , points :: Array Point }
                    , labels :: Array Label | r }

renderBrowser' :: BrowserContainer
               -> Milliseconds
               -> Number
               -> Map String (List (Layer (_ -> LayerRenderable)))
               -- -> List (Layer ({|LayerSlots ComponentSlot} -> LayerRenderable))
               -> Aff _ Unit
renderBrowser' bc d offset layers lrs = do
  layers <- getLayers bc

  let aa :: List LayerContainer
      aa = layers

      fun :: _ -> Layer (Record _ -> LayerRenderable) -> Aff _ _
      fun lct@(LayerContainer lc) l@(Layer ltype lmask c) = do

        ctx <- layerContext l lct
        let slots = layerSlots lc.dimensions

        _ <- liftEff case c of
          Full     a -> clearCanvas ctx slots.full.size
          Padded r a -> do
            let slot = { width:  slots.padded.size.width  + r * 2.0
                       , height: slots.padded.size.height + r * 2.0 }
            clearCanvas ctx slot
          Outside as -> do
            clearCanvas ctx slots.top.size
            clearCanvas ctx slots.right.size
            clearCanvas ctx slots.bottom.size
            clearCanvas ctx slots.left.size

        let fixed    :: Drawing -> Aff _ Unit
            fixed d  = liftEff do
              Drawing.render ctx d

            drawings :: Array _ -> Aff _ Unit
            drawings ds = do
              for_ ds \s -> do
                liftEff $ renderGlyphs' (unwrap bc).glyphBuffer ctx s
                delay d

            labels   :: Array _ -> Aff _ Unit
            labels ls = do
              -- TODO
              pure unit

            drawLayer :: LayerRenderable -> Aff _ Unit
            drawLayer = case_ # onMatch { fixed, drawings, labels }

        traverse_ drawLayer $ map (_ $ slots) c

        pure unit

      lookup' :: ∀ a. String -> Map String a -> MaybeT (Aff _) a
      lookup' k m = MaybeT $ pure $ Map.lookup k m

  for_ (Map.keys layers) \name -> do
    -- 1. get the layercontainer by name
    ?getLayerContainer
    -- 2. get the list of stuff to render, by layer name
    ?getLayerRenderable
    -- 3. render the stuff

    -- 4. pair layercontainer with the rendered stuff, using provided z-ordering list

    pure unit

renderBrowser :: ∀ a b c.
                 Milliseconds
              -> BrowserCanvas
              -> Number
              -> { tracks     :: { snps :: Renderable a
                                 , annotations :: Renderable b }
                 , relativeUI :: Drawing
                 , fixedUI :: Drawing }
             -> Aff _ Unit
renderBrowser d (BrowserCanvas bc) offset ui = do

  let
      labels = ui.tracks.snps.labels <> ui.tracks.annotations.labels

  -- Render the UI
  liftEff do
    staticOverlayCtx <- Canvas.getContext2D bc.staticOverlay

    clearCanvas staticOverlayCtx bc.dimensions
    Drawing.render staticOverlayCtx ui.fixedUI

    translateBuffer {x: zero, y: zero} bc.trackOverlay
    blankBuffer bc.trackOverlay

    translateBuffer {x: (-offset), y: zero} bc.trackOverlay
    trackOverlayCtx <- getBufferedContext bc.trackOverlay

    Drawing.render trackOverlayCtx ui.relativeUI

    translateBuffer {x: (-offset), y: bc.trackPadding.top} bc.trackOverlay
    renderLabels labels trackOverlayCtx

  -- Render the tracks
  let bfr = (unwrap bc.track).canvas
      cnv = (unwrap bfr).front

  -- TODO extract functions `clearTrack` and `translateTrack` that bake in padding
  ctx <- liftEff $ Canvas.getContext2D cnv
  liftEff do
    dim <- Canvas.getCanvasDimensions cnv

    translateBuffer {x: zero, y: zero} bfr
    clearCanvas ctx $ trackTotalDimensions dim

  liftEff $ translateBuffer { x: trackInnerPad - offset
                            , y: trackInnerPad } bfr

  let snpsTrack  = ui.tracks.snps.drawings
      annotTrack = ui.tracks.annotations.drawings

  for_ [snpsTrack, annotTrack] \t ->
    for_ t \s -> do
      liftEff $ renderGlyphs bc.track s
      delay d

-- TODO it doesn't make sense for LayerContainers to contain the
-- actual size of the element, since that can change externally.
-- however, the LayerPadding should be consistent/only changed by the
-- layer, and so should stay in the LayerContainer.
newtype LayerContainer =
  LayerContainer { dimensions  :: LayerDimensions
                 , canvas      :: LayerCanvas }

data LayerCanvas =
    Static Canvas.CanvasElement
  | Buffer BufferedCanvas

_LayerCanvas :: Lens' LayerContainer LayerCanvas
_LayerCanvas = lens
         (\(LayerContainer lc)    -> lc.canvas)
         (\(LayerContainer lc) ct -> LayerContainer $ lc { canvas = ct })

_FrontCanvas :: Getter' LayerCanvas CanvasElement
_FrontCanvas = to case _ of
  Static c -> c
  Buffer c -> (unwrap c).front

_Buffer :: Prism' LayerCanvas BufferedCanvas
_Buffer = prism' Buffer from
  where from (Static _) = Nothing
        from (Buffer b) = Just b

_Static :: Prism' LayerCanvas CanvasElement
_Static = prism' Static $ case _ of
  Static el -> Just el
  Buffer _  -> Nothing

_LayerBuffer :: Traversal' LayerContainer BufferedCanvas
_LayerBuffer = _LayerCanvas <<< _Buffer

layerContainer :: ∀ a.
                  LayerDimensions
               -> Layer a
               -> Eff _ LayerContainer
layerContainer lDim (Layer lt _ c) = do

  let slots = layerSlots lDim

  let {size, pos} = case c of
        Padded _ _ -> let p' = lDim.padding
                      in { size: slots.padded.size, pos: { left: p'.left, top: p'.top } }
        _        ->      { size: slots.full.size,   pos: { left: 0.0, top: 0.0 } }

  canvas <-
    case lt of
      Fixed     -> Static <$> createCanvas         size "fixed"
      Scrolling -> Buffer <$> createBufferedCanvas size

  setCanvasPosition pos (canvas ^. _FrontCanvas)

  pure $ LayerContainer { dimensions: lDim, canvas }

type LayerRenderable =
  Variant ( fixed    :: Drawing
          , drawings :: Array { drawing :: Drawing
                              , points :: Array Point }
          , labels   :: Array Label )

_fixed :: SProxy "fixed"
_fixed = SProxy

_drawings :: SProxy "drawings"
_drawings = SProxy

_labels :: SProxy "labels"
_labels = SProxy

runLayer' :: ∀ m.
             Monoid m
          => Layer (ComponentSlot -> m)
          -> LayerContainer
          -> m
runLayer' layer@(Layer lt lm com) c@(LayerContainer lc) =
  let slots = layerSlots lc.dimensions
  in case com of
      Full     f -> f slots.full
      Padded r f -> f slots.padded
      Outside  f -> fold [ f.top    slots.top
                         , f.right  slots.right
                         , f.bottom slots.bottom
                         , f.left   slots.left ]

layerContext :: ∀ m a.
                MonadEff _ m
             => Layer a
             -> LayerContainer
             -> m Context2D
layerContext (Layer _ lmask com) (LayerContainer lc) = liftEff do
  ctx <- Canvas.getContext2D $ lc.canvas ^. _FrontCanvas
  _ <- Canvas.transform { m11: one,  m21: zero, m31: zero
                        , m12: zero, m22: one,  m32: zero } ctx

  let whenMasked = when (lmask == Masked)

  case com of
    -- translate to 0.0, 0.0
    Full     _ -> do
      -- whenMasked do
      --   pure unit

      pure ctx
    -- translate inward by the padding
    Padded r _ -> do
      -- whenMasked do
      --   pure unit
      Canvas.translate { translateX: r, translateY: r } ctx
    Outside  _ -> do

      let size = lc.dimensions.size

      whenMasked do
      -- translate to 0.0, set mask to not draw on the padded canvas
        _ <- Canvas.beginPath ctx
        _ <- Canvas.moveTo ctx 0.0        0.0
        _ <- Canvas.lineTo ctx size.width 0.0
        _ <- Canvas.lineTo ctx size.width size.height
        _ <- Canvas.lineTo ctx 0.0        size.height
        _ <- Canvas.lineTo ctx 0.0        0.0
        void $ Canvas.clip ctx

      pure ctx

-- | This module provides a HTML5 canvas interface for the genetics browser,
-- | which wraps and optimizes all rendering calls

module Genetics.Browser.Canvas where

import Prelude

import Control.Monad.Aff (Aff, delay)
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Class (class MonadEff, liftEff)
import Control.Monad.Eff.Ref (REF, Ref)
import Control.Monad.Eff.Ref as Ref
import Control.Monad.Eff.Uncurried (EffFn2, EffFn3, EffFn4, runEffFn2, runEffFn3, runEffFn4)
import DOM.Node.Types (Element)
import Data.Either (Either(..))
import Data.Foldable (any, fold, foldl, for_)
import Data.Int as Int
import Data.Lens (Getter', Lens', Prism', Traversal, Traversal', iso, lens, lens', prism', re, to, united, view, (^.), (^?))
import Data.Lens.Iso (Iso')
import Data.Lens.Iso.Newtype (_Newtype)
import Data.Lens.Record as Lens
import Data.List (List)
import Data.List as List
import Data.Maybe (Maybe(Nothing, Just), fromMaybe)
import Data.Monoid (class Monoid, mempty)
import Data.Newtype (class Newtype, unwrap)
import Data.Nullable (Nullable, toMaybe)
import Data.Symbol (SProxy(..))
import Data.Time.Duration (Milliseconds)
import Data.Traversable (traverse, traverse_)
import Data.TraversableWithIndex (forWithIndex)
import Data.Tuple (Tuple(Tuple), uncurry)
import Data.Variant (Variant, case_, onMatch)
import Debug.Trace as Debug
import Genetics.Browser.Layer (Component(..), ComponentSlot, Layer(..), LayerDimensions, LayerMask(..), LayerPadding, LayerSlots, LayerType(..), layerSlots)
import Graphics.Canvas (CanvasElement, Context2D)
import Graphics.Canvas as Canvas
import Graphics.Drawing (Drawing, Point)
import Graphics.Drawing (render, translate) as Drawing
import Graphics.Drawing.Font (font, fontString) as Drawing
import Graphics.Drawing.Font (sansSerif)
import Unsafe.Coerce (unsafeCoerce)

_Element :: Iso' CanvasElement Element
_Element = iso unsafeCoerce unsafeCoerce

-- | Create a new CanvasElement, not attached to the DOM, with the provided String as its CSS class
foreign import createCanvas :: ∀ eff.
                               { width :: Number, height :: Number }
                            -> String
                            -> Eff eff CanvasElement

foreign import setElementStyleImpl :: ∀ e.
                                      EffFn3 e
                                      Element String String
                                      Unit

setElementStyle :: Element
                -> String
                -> String
                -> Eff _ Unit
setElementStyle = runEffFn3 setElementStyleImpl

setElementStyles :: Element -> Array (Tuple String String) -> Eff _ Unit
setElementStyles el =
  traverse_ (uncurry $ setElementStyle el)

setCanvasStyles :: CanvasElement -> Array (Tuple String String) -> Eff _ Unit
setCanvasStyles = setElementStyles <<< view _Element

setCanvasStyle :: CanvasElement
               -> String
               -> String
               -> Eff _ Unit
setCanvasStyle ce = setElementStyle (ce ^. _Element)

setCanvasZIndex :: CanvasElement -> Int -> Eff _ Unit
setCanvasZIndex ce i = setCanvasStyle ce "z-index" (show i)

setCanvasPosition :: ∀ r.
                     { left :: Number, top :: Number | r }
                  -> CanvasElement
                  -> Eff _ Unit
setCanvasPosition {left, top} ce =
  setCanvasStyles ce
    [ Tuple "position" "absolute"
    , Tuple "top"  (show top  <> "px")
    , Tuple "left" (show left <> "px") ]

foreign import appendCanvasElem :: ∀ e.
                                   Element
                                -> CanvasElement
                                -> Eff e Unit

-- | Sets some of the browser container's CSS to reasonable defaults
foreign import setContainerStyle :: ∀ e. Element -> Canvas.Dimensions -> Eff e Unit

foreign import drawCopies :: ∀ eff a.
                             EffFn4 eff
                             CanvasElement Canvas.Dimensions Context2D (Array Point)
                             Unit

foreign import setCanvasTranslation :: ∀ e.
                                       Point
                                    -> CanvasElement
                                    -> Eff e Unit

foreign import canvasClickImpl :: ∀ e.
                                  EffFn2 e
                                  CanvasElement (Point -> Eff e Unit)
                                  Unit

canvasClick :: CanvasElement -> (Point -> Eff _ Unit) -> Eff _ Unit
canvasClick = runEffFn2 canvasClickImpl

-- | Attaches two callbacks to the BrowserCanvas click event handler,
-- | provided with the track canvas and static overlay canvas' relative
-- | coordinates of the click, respectively.
browserOnClick :: BrowserCanvas
               -> { track   :: Point -> Eff _ Unit
                  , overlay :: Point -> Eff _ Unit }
               -> Eff _ Unit
browserOnClick (BrowserCanvas bc) {track, overlay} =
  canvasClick bc.staticOverlay \o -> do
    let t = { x: o.x - bc.trackPadding.left
            , y: o.y - bc.trackPadding.top }
    overlay o
    track t

foreign import scrollCanvasImpl :: ∀ e.
                                   EffFn3 e
                                   CanvasElement CanvasElement Point
                                   Unit

scrollCanvas :: BufferedCanvas
             -> Point
             -> Eff _ Unit
scrollCanvas (BufferedCanvas bc) = runEffFn3 scrollCanvasImpl bc.back bc.front

scrollCanvas' :: BrowserContainer
              -> Point
              -> Eff _ Unit
scrollCanvas' (BrowserContainer bc) pt = do
  layers <- Ref.readRef bc.layers

  for_ layers $ \lc -> case lc ^? _LayerCanvas <<< _Buffer of
    Nothing -> pure unit
    Just bc -> scrollCanvas bc pt

foreign import canvasDragImpl :: ∀ eff.
                                 CanvasElement
                              -> ( { during :: Nullable Point
                                   , total :: Nullable Point } -> Eff eff Unit )
                              -> Eff eff Unit

foreign import canvasWheelCBImpl :: ∀ eff.
                                    CanvasElement
                                 -> (Number -> Eff eff Unit)
                                 -> Eff eff Unit

canvasDrag :: (Either Point Point -> Eff _ Unit)
           -> CanvasElement
           -> Eff _ Unit
canvasDrag f el =
  let toEither g {during, total} = case toMaybe during of
        Just p  -> g $ Right p
        Nothing -> g $ Left $ fromMaybe {x:zero, y:zero} $ toMaybe total
  in canvasDragImpl el (toEither f)

-- | Takes a BrowserCanvas and a callback function that is called with the
-- | total dragged distance when a click & drag action is completed.
dragScroll :: BrowserCanvas
           -> (Point -> Eff _ Unit)
           -> Eff _ Unit
dragScroll (BrowserCanvas bc) cb = canvasDrag f bc.staticOverlay
  where f = case _ of
              Left  p     -> cb p
              Right {x} -> do
                let p' = {x: -x, y: 0.0}
                scrollCanvas (_.canvas $ unwrap bc.track) p'
                scrollCanvas bc.trackOverlay p'

dragScroll' :: BrowserContainer
            -> (Point -> Eff _ Unit)
            -> Eff _ Unit
dragScroll' bc'@(BrowserContainer {element}) cb =
  canvasDrag f (unsafeCoerce element) -- actually safe
  where f = case _ of
              Left  p    -> cb p
              Right {x} -> do
                let p' = {x: -x, y: 0.0}
                scrollCanvas' bc' p'

-- | Takes a BrowserCanvas and a callback function that is called with each
-- | wheel scroll `deltaY`. Callback is provided with only the sign of `deltaY`
-- | as to be `deltaMode` agnostic.
wheelZoom :: BrowserCanvas
          -> (Number -> Eff _ Unit)
          -> Eff _ Unit
wheelZoom (BrowserCanvas bc) cb =
  canvasWheelCBImpl bc.staticOverlay cb

wheelZoom' :: BrowserContainer
          -> (Number -> Eff _ Unit)
          -> Eff _ Unit
wheelZoom' bc cb = Debug.trace "unimplemented!" \_ -> pure unit
  -- canvasWheelCBImpl bc.staticOverlay cb

-- | Helper function for erasing the contents of a canvas context given its dimensions
clearCanvas :: Context2D -> Canvas.Dimensions -> Eff _ Unit
clearCanvas ctx {width, height} =
  void $ Canvas.clearRect ctx { x: 0.0, y: 0.0, w: width, h: height }

blankLayer :: LayerContainer
           -> Eff _ Unit
blankLayer (LayerContainer lc) =
  case lc.canvas of
    Buffer bc -> blankBuffer bc
    Static el -> do
      setCanvasTranslation {x: zero, y: zero} el
      ctx <- Canvas.getContext2D el
      clearCanvas ctx lc.dimensions.size

-- TODO browser background color shouldn't be hardcoded
backgroundColor :: String
backgroundColor = "white"

-- TODO the back canvas should have the option of being bigger than
-- the front, to minimize redrawing
-- needs adding the offset of the front canvas, and validating that back >= front
newtype BufferedCanvas =
  BufferedCanvas { back  :: CanvasElement
                 , front :: CanvasElement
                 }

derive instance newtypeBufferedCanvas :: Newtype BufferedCanvas _

createBufferedCanvas :: Canvas.Dimensions
                     -> Eff _ BufferedCanvas
createBufferedCanvas dim = do
  back  <- createCanvas dim "buffer"
  front <- createCanvas dim "front"
  let bc = BufferedCanvas { back, front }
  blankBuffer bc
  pure bc

getBufferedContext :: BufferedCanvas
                   -> Eff _ Context2D
getBufferedContext = Canvas.getContext2D <$> _.front <<< unwrap

setBufferedCanvasSize :: Canvas.Dimensions
                      -> BufferedCanvas
                      -> Eff _ Unit
setBufferedCanvasSize dim bc@(BufferedCanvas {back, front}) = do
  _ <- Canvas.setCanvasDimensions dim back
  _ <- Canvas.setCanvasDimensions dim front
  blankBuffer bc
  pure unit

translateBuffer :: Point
                -> BufferedCanvas
                -> Eff _ Unit
translateBuffer p (BufferedCanvas bc) = do
  setCanvasTranslation p bc.back
  setCanvasTranslation p bc.front

drawToBuffer :: BufferedCanvas
             -> (Context2D -> Eff _ Unit)
             -> Eff _ Unit
drawToBuffer (BufferedCanvas {back}) f = do
  ctx <- Canvas.getContext2D back
  f ctx

drawToLayer :: LayerContainer
            -> (Context2D -> Eff _ Unit)
            -> Eff _ Unit
drawToLayer (LayerContainer lc) f =
  case lc.canvas of
    Static c -> f =<< Canvas.getContext2D c
    Buffer b -> drawToBuffer b f

blankBuffer :: BufferedCanvas
            -> Eff _ Unit
blankBuffer bc@(BufferedCanvas {back, front}) = do
  translateBuffer {x: zero, y: zero} bc

  dim <- Canvas.getCanvasDimensions back

  for_ [back, front]
    $ flip clearCanvas dim <=< Canvas.getContext2D

flipBuffer :: BufferedCanvas
           -> Eff _ Unit
flipBuffer (BufferedCanvas {back, front}) = do
-- NOTE this assumes back and front are the same size
  frontCtx <- Canvas.getContext2D front
  let imgSrc = Canvas.canvasElementToImageSource back

  dim <- Canvas.getCanvasDimensions front

  clearCanvas frontCtx dim
  _ <- Canvas.drawImage frontCtx imgSrc 0.0 0.0
  pure unit

-- | The `width` & `height` of the TrackCanvas is the area glyphs render to;
-- | the browser shows a `width` pixels slice of the whole coordinate system.
-- | `glyphBuffer` is what individual glyphs can be rendered to and copied from, for speed.
newtype TrackCanvas =
  TrackCanvas { canvas      :: BufferedCanvas
              , dimensions  :: Canvas.Dimensions
              , glyphBuffer :: CanvasElement
              }

-- | using hardcoded inner padding for now; makes it look a bit better
trackInnerPad :: Number
trackInnerPad = 5.0

derive instance newtypeTrackCanvas :: Newtype TrackCanvas _

_Dimensions :: ∀ n r1 r2.
               Newtype n { dimensions :: Canvas.Dimensions | r1 }
            => Lens' n Canvas.Dimensions
_Dimensions = _Newtype <<< Lens.prop (SProxy :: SProxy "dimensions")

trackTotalDimensions :: Canvas.Dimensions -> Canvas.Dimensions
trackTotalDimensions d = { width:  d.width  + extra
                         , height: d.height + extra }
  where extra = 2.0 * trackInnerPad

trackCanvas :: Canvas.Dimensions
            -> Eff _ TrackCanvas
trackCanvas dim = do
  canvas <- createBufferedCanvas $ trackTotalDimensions dim
  glyphBuffer <- createCanvas glyphBufferSize "glyphBuffer"

  pure $ TrackCanvas { dimensions: dim
                     , canvas, glyphBuffer }

setTrackCanvasSize :: Canvas.Dimensions
                   -> TrackCanvas
                   -> Eff _ TrackCanvas
setTrackCanvasSize dim (TrackCanvas tc) = do
  setBufferedCanvasSize (trackTotalDimensions dim) tc.canvas
  pure $ TrackCanvas
    $ tc { dimensions = dim }

-- TODO change name to BrowserPadding
type TrackPadding =
  { left :: Number, right :: Number
  , top :: Number, bottom :: Number }

-- | A `BrowserCanvas` consists of a double-buffered `track`
-- | which is what the genetics browser view is rendered onto,
-- | and a transparent `staticOverlay` canvas the UI is rendered onto,
-- | with a (also transparent) `trackOverlay` that scrolls with the track view.

-- | The `dimensions`, `trackPadding`, and track.width/height are
-- | related such that
-- | track.width + horizontal.left + horizontal.right = dimensions.width
-- | track.height + vertical.top + vertical.bottom = dimensions.height
newtype BrowserCanvas =
  BrowserCanvas { track         :: TrackCanvas
                , trackPadding  :: TrackPadding
                , dimensions    :: Canvas.Dimensions
                , staticOverlay :: CanvasElement
                , trackOverlay  :: BufferedCanvas
                , container :: Element
                }

derive instance newtypeBrowserCanvas :: Newtype BrowserCanvas _

newtype BrowserContainer =
  BrowserContainer { layers      :: Ref (List LayerContainer)
                   , dimensions  :: Ref LayerDimensions -- ? is this better just kept as a function?
                   , element     :: Element
                   , glyphBuffer :: CanvasElement}

derive instance newtypeBrowserContainer :: Newtype BrowserContainer _

getDimensions :: ∀ m.
                 MonadEff _ m
              => BrowserContainer
              -> m LayerDimensions
getDimensions (BrowserContainer {dimensions}) =
  liftEff $ Ref.readRef dimensions

_Track :: Lens' BrowserCanvas TrackCanvas
_Track = _Newtype <<< Lens.prop (SProxy :: SProxy "track")

foreign import debugBrowserCanvas :: ∀ e.
                                     String
                                  -> BrowserCanvas
                                  -> Eff e Unit

subtractPadding :: Canvas.Dimensions
                -> TrackPadding
                -> Canvas.Dimensions
subtractPadding {width, height} pad =
  { width:  width - pad.left - pad.right
  , height: height - pad.top - pad.bottom }

type UISlot = { offset :: Point
              , size   :: Canvas.Dimensions }

data UISlotGravity = UILeft | UIRight | UITop | UIBottom

derive instance eqUISlotGravity :: Eq UISlotGravity
derive instance ordUISlotGravity :: Ord UISlotGravity

type UISlots = { left   :: UISlot
               , right  :: UISlot
               , top    :: UISlot
               , bottom :: UISlot }

uiSlots :: BrowserCanvas
        -> UISlots
uiSlots (BrowserCanvas bc) =
  let track   = subtractPadding bc.dimensions bc.trackPadding
      browser = bc.dimensions
      pad     = bc.trackPadding
  in { left:   { offset: { x: 0.0, y: pad.top }
               , size:   { height: track.height, width: pad.left }}
     , right:  { offset: { x: browser.width - pad.right, y: pad.top }
               , size:   { height: track.height, width: pad.right }}
     , top:    { offset: { x: pad.left, y: 0.0 }
               , size:   { height: pad.top, width: track.width }}
     , bottom: { offset: { x: browser.width  - pad.right
                         , y: browser.height - pad.bottom }
               , size:   { height: pad.bottom, width: track.width }}
    }

setBrowserCanvasSize :: Canvas.Dimensions
                     -> BrowserCanvas
                     -> Eff _ BrowserCanvas
setBrowserCanvasSize dim (BrowserCanvas bc) = do

  setContainerStyle bc.container dim
  let trackDim = subtractPadding dim bc.trackPadding

  track <- setTrackCanvasSize trackDim bc.track

  setBufferedCanvasSize dim bc.trackOverlay
  _ <- Canvas.setCanvasDimensions dim bc.staticOverlay

  pure $ BrowserCanvas
       $ bc { dimensions = dim
            , track = track }

setBrowserContainerSize :: Canvas.Dimensions
                        -> BrowserContainer
                        -> Eff _ Unit
setBrowserContainerSize dim bc'@(BrowserContainer bc) = do
  -- set the container
  setContainerStyle bc.element dim
  -- set each layer
  _ <- traverseLayers (\l@(LayerContainer lc) -> resizeLayer (lc.dimensions { size = dim }) l) bc'
  -- layers <- getLayers bc
  -- traverse f layers
  pure unit

-- | Creates a `BrowserCanvas` and appends it to the provided element.
-- | Resizes the container element to fit.
browserCanvas :: Canvas.Dimensions
              -> TrackPadding
              -> Element
              -> Eff _ BrowserCanvas
browserCanvas dimensions trackPadding el = do

  setContainerStyle el dimensions

  let trackDim = subtractPadding dimensions trackPadding
  track   <- trackCanvas trackDim

  trackOverlay  <- createBufferedCanvas { width: trackDim.width
                                        , height: dimensions.height }

  staticOverlay <- createCanvas dimensions "staticOverlay"

  let trackEl = _.front  $ unwrap
                $ _.canvas $ unwrap $ track

      trackOverlayEl = _.front $ unwrap $ trackOverlay

  setCanvasZIndex trackEl 10
  setCanvasZIndex trackOverlayEl 20
  setCanvasZIndex staticOverlay 30

  -- TODO handle this nicer maybe idk
  let trackElPosition = { left: trackPadding.left - trackInnerPad
                        , top:  trackPadding.top  - trackInnerPad }

  setCanvasPosition trackElPosition trackEl
  setCanvasPosition { left: trackPadding.left, top: 0.0 } trackOverlayEl
  setCanvasPosition { left: 0.0, top: 0.0} staticOverlay

  appendCanvasElem el trackEl
  appendCanvasElem el trackOverlayEl
  appendCanvasElem el staticOverlay

  pure $ BrowserCanvas { dimensions
                       , track, trackPadding
                       , trackOverlay, staticOverlay
                       , container: el}

-- TODO calculate based on glyph bounding boxes
glyphBufferSize :: Canvas.Dimensions
glyphBufferSize = { width: 15.0, height: 300.0 }

-- | Creates an *empty* BrowserContainer, to which layers can be added
browserContainer :: Canvas.Dimensions
                 -> LayerPadding
                 -> Element
                 -> Eff _ BrowserContainer
browserContainer size padding element = do

  setContainerStyle element size

  glyphBuffer <- createCanvas glyphBufferSize "glyphBuffer"

  dimensions <- Ref.newRef { size, padding }
  layers     <- Ref.newRef mempty

  pure $
    BrowserContainer
      { layers, dimensions, element, glyphBuffer }

-- | Set the CSS z-indices of the Layers in the browser, so their
-- | canvases are drawn in the correct order (i.e. as the
-- | BrowserContainer layer list is ordered)
zIndexLayers :: BrowserContainer
             -> Eff _ Unit
zIndexLayers (BrowserContainer bc) = do
  layers <- Ref.readRef bc.layers
  void $ forWithIndex layers
           (\i l -> setCanvasZIndex
                      (l ^. _LayerCanvas <<< _FrontCanvas) i)

traverseLayers :: ∀ m a.
                  MonadEff _ m
               => (LayerContainer -> m a)
               -> BrowserContainer
               -> m (List a)
traverseLayers f bc = do
  layers <- getLayers bc
  traverse f layers

getLayers :: ∀ m.
             MonadEff _ m
          => BrowserContainer
          -> m (List LayerContainer)
getLayers (BrowserContainer bc) =
  liftEff $ Ref.readRef bc.layers

resizeLayer :: ∀ m.
               MonadEff _ m
            => LayerDimensions
            -> LayerContainer
            -> m LayerContainer
resizeLayer ld' (LayerContainer lc) = liftEff do
  case lc.canvas of
    Static e -> void $ Canvas.setCanvasDimensions lc.dimensions.size e
    Buffer b -> setBufferedCanvasSize lc.dimensions.size b

  pure $ LayerContainer (lc { dimensions = ld' })

appendLayer :: BrowserContainer
            -> LayerContainer
            -> Eff _ Unit
appendLayer bc@(BrowserContainer {element}) l@(LayerContainer lc)  = do
  layers <- getLayers bc
  appendCanvasElem element (lc.canvas ^. _FrontCanvas)
  zIndexLayers bc

addLayers :: BrowserContainer
          -> List LayerContainer
          -> Eff _ Unit
addLayers bc = traverse_ (appendLayer bc)

deleteLayers :: BrowserContainer
             -> Eff _ Unit
deleteLayers (BrowserContainer bc) = do
  Ref.writeRef bc.layers mempty
  -- TODO update the DOM appropriately,
  -- by just removing the children of bc.element??? or be more specific

  -- maybe expose a function (BrowserContainer -> (LayerContainer -> Eff _ a) -> Eff _ (List a))
  -- so we can effectfully traverse all the layers.
  -- sounds useful at least~~

renderGlyphs :: TrackCanvas
             -> { drawing :: Drawing, points :: Array Point }
             -> Eff _ Unit
renderGlyphs (TrackCanvas tc) {drawing, points} = do
  glyphBfr <- Canvas.getContext2D tc.glyphBuffer
  ctx <- getBufferedContext tc.canvas

  let w = glyphBufferSize.width
      h = glyphBufferSize.height
      x0 = w / 2.0
      y0 = h / 2.0

  clearCanvas glyphBfr glyphBufferSize

  Drawing.render glyphBfr
    $ Drawing.translate x0 y0 drawing

  runEffFn4 drawCopies tc.glyphBuffer glyphBufferSize ctx points

renderGlyphs' :: CanvasElement
              -- -> LayerContainer
              -> Canvas.Context2D
              -> { drawing :: Drawing, points :: Array Point }
              -> Eff _ Unit
renderGlyphs' glyphBuffer ctx {drawing, points} = do
  glyphCtx <- Canvas.getContext2D glyphBuffer

  -- ctx <- getBufferedContext tc.canvas

  -- ctx <-

  let w = glyphBufferSize.width
      h = glyphBufferSize.height
      x0 = w / 2.0
      y0 = h / 2.0

  clearCanvas glyphCtx glyphBufferSize

  Drawing.render glyphCtx
    $ Drawing.translate x0 y0 drawing

  runEffFn4 drawCopies glyphBuffer glyphBufferSize ctx points

type Label = { text :: String, point :: Point, gravity :: LabelPlace }

data LabelPlace = LLeft | LCenter | LRight

derive instance eqLabelPlace :: Eq LabelPlace

-- hardcoded global label font for now
-- can't use Drawing.Font because we need raw Canvas to measure the text size,
-- but we can at least use Drawing to generate the font string

labelFontSize :: Int
labelFontSize = 14

labelFont :: String
labelFont = Drawing.fontString $ Drawing.font sansSerif labelFontSize mempty

-- | Calculate the rectangle covered by a label when it'd be rendered
-- | to a provided canvas context
labelBox :: Context2D -> Label -> Eff _ Canvas.Rectangle
labelBox ctx {text, point, gravity} = do
  {width} <- Canvas.withContext ctx do
    _ <- Canvas.setFont labelFont ctx
    Canvas.measureText ctx text

  -- close enough height, actually calculating it is a nightmare
  let height = Int.toNumber labelFontSize
      pad = 14.0 + width / 2.0
      x = case gravity of
        LCenter -> point.x
        LLeft   -> point.x - pad
        LRight  -> point.x + pad

  pure $ { x
         , y: point.y - height
         , w: width, h: height }

-- | Returns `true` if the input rectangles overlap
isOverlapping :: Canvas.Rectangle
              -> Canvas.Rectangle
              -> Boolean
isOverlapping r1 r2 =
     r1.x < r2.x + r2.w
  && r1.x + r1.w > r2.x
  && r1.y < r2.y + r2.h
  && r1.h + r1.y > r2.y

eqRectangle :: Canvas.Rectangle
            -> Canvas.Rectangle
            -> Boolean
eqRectangle {x,y,w,h} r =
     x == r.x && y == r.y
  && w == r.w && h == r.h

appendBoxed :: ∀ r.
               Array {rect :: Canvas.Rectangle | r}
            -> {rect :: Canvas.Rectangle | r}
            -> Array {rect :: Canvas.Rectangle | r}
appendBoxed sofar next =
  let overlapsAny :: Boolean
      overlapsAny = any overlaps sofar
        where overlaps r' = (not $ eqRectangle next.rect r'.rect)
                            && next.rect `isOverlapping` r'.rect
  in if overlapsAny then sofar else sofar <> [next]

renderLabels :: Array Label -> Context2D -> Eff _ Unit
renderLabels ls ctx = do

  boxed <- traverse (\l -> {text: l.text, rect: _} <$> labelBox ctx l) ls

  let toRender = foldl appendBoxed [] boxed

  Canvas.withContext ctx do
    _ <- Canvas.setFont labelFont ctx

    for_ toRender \box ->
      Canvas.fillText ctx box.text
        (box.rect.x - (box.rect.w / 2.0))
        box.rect.y

type Renderable r = { drawings :: Array { drawing :: Drawing
                                        , points :: Array Point }
                    , labels :: Array Label | r }

renderBrowser' :: BrowserContainer
               -> Milliseconds
               -> Number
               -> List (Layer ({|LayerSlots ComponentSlot} -> LayerRenderable))
               -> Aff _ Unit
renderBrowser' bc d offset lrs = do
  layers <- getLayers bc

  let aa :: List LayerContainer
      aa = layers

      fun :: _ -> Layer (Record _ -> LayerRenderable) -> Aff _ _
      fun lct@(LayerContainer lc) l@(Layer ltype lmask c) = do

        ctx <- layerContext l lct
        let slots = layerSlots lc.dimensions

        _ <- liftEff case c of
          Full     a -> clearCanvas ctx slots.full.size
          Padded r a -> do
            let slot = { width:  slots.padded.size.width  + r * 2.0
                       , height: slots.padded.size.height + r * 2.0 }
            clearCanvas ctx slot
          Outside as -> do
            clearCanvas ctx slots.top.size
            clearCanvas ctx slots.right.size
            clearCanvas ctx slots.bottom.size
            clearCanvas ctx slots.left.size

        let fixed    :: Drawing -> Aff _ Unit
            fixed d  = liftEff do
              Drawing.render ctx d

            drawings :: Array _ -> Aff _ Unit
            drawings ds = do
              for_ ds \s -> do
                liftEff $ renderGlyphs' (unwrap bc).glyphBuffer ctx s
                delay d

            labels   :: Array _ -> Aff _ Unit
            labels ls = do
              -- TODO
              pure unit

            drawLayer :: LayerRenderable -> Aff _ Unit
            drawLayer = case_ # onMatch { fixed, drawings, labels }

        traverse_ drawLayer $ map (_ $ slots) c

        pure unit

  -- TODO these lists should be named and lined up properly -- and validated!
  void $ List.zipWithA fun layers lrs

renderBrowser :: ∀ a b c.
                 Milliseconds
              -> BrowserCanvas
              -> Number
              -> { tracks     :: { snps :: Renderable a
                                 , annotations :: Renderable b }
                 , relativeUI :: Drawing
                 , fixedUI :: Drawing }
             -> Aff _ Unit
renderBrowser d (BrowserCanvas bc) offset ui = do

  let
      labels = ui.tracks.snps.labels <> ui.tracks.annotations.labels

  -- Render the UI
  liftEff do
    staticOverlayCtx <- Canvas.getContext2D bc.staticOverlay

    clearCanvas staticOverlayCtx bc.dimensions
    Drawing.render staticOverlayCtx ui.fixedUI

    translateBuffer {x: zero, y: zero} bc.trackOverlay
    blankBuffer bc.trackOverlay

    translateBuffer {x: (-offset), y: zero} bc.trackOverlay
    trackOverlayCtx <- getBufferedContext bc.trackOverlay

    Drawing.render trackOverlayCtx ui.relativeUI

    translateBuffer {x: (-offset), y: bc.trackPadding.top} bc.trackOverlay
    renderLabels labels trackOverlayCtx

  -- Render the tracks
  let bfr = (unwrap bc.track).canvas
      cnv = (unwrap bfr).front

  -- TODO extract functions `clearTrack` and `translateTrack` that bake in padding
  ctx <- liftEff $ Canvas.getContext2D cnv
  liftEff do
    dim <- Canvas.getCanvasDimensions cnv

    translateBuffer {x: zero, y: zero} bfr
    clearCanvas ctx $ trackTotalDimensions dim

  liftEff $ translateBuffer { x: trackInnerPad - offset
                            , y: trackInnerPad } bfr

  let snpsTrack  = ui.tracks.snps.drawings
      annotTrack = ui.tracks.annotations.drawings

  for_ [snpsTrack, annotTrack] \t ->
    for_ t \s -> do
      liftEff $ renderGlyphs bc.track s
      delay d

-- TODO it doesn't make sense for LayerContainers to contain the
-- actual size of the element, since that can change externally.
-- however, the LayerPadding should be consistent/only changed by the
-- layer, and so should stay in the LayerContainer.
newtype LayerContainer =
  LayerContainer { dimensions  :: LayerDimensions
                 , canvas      :: LayerCanvas }

data LayerCanvas =
    Static Canvas.CanvasElement
  | Buffer BufferedCanvas

_LayerCanvas :: Lens' LayerContainer LayerCanvas
_LayerCanvas = lens
         (\(LayerContainer lc)    -> lc.canvas)
         (\(LayerContainer lc) ct -> LayerContainer $ lc { canvas = ct })

_FrontCanvas :: Getter' LayerCanvas CanvasElement
_FrontCanvas = to case _ of
  Static c -> c
  Buffer c -> (unwrap c).front

_Buffer :: Prism' LayerCanvas BufferedCanvas
_Buffer = prism' Buffer from
  where from (Static _) = Nothing
        from (Buffer b) = Just b

_Static :: Prism' LayerCanvas CanvasElement
_Static = prism' Static $ case _ of
  Static el -> Just el
  Buffer _  -> Nothing

_LayerBuffer :: Traversal' LayerContainer BufferedCanvas
_LayerBuffer = _LayerCanvas <<< _Buffer

layerContainer :: ∀ a.
                  LayerDimensions
               -> Layer a
               -> Eff _ LayerContainer
layerContainer lDim (Layer lt _ c) = do

  let slots = layerSlots lDim

  let {size, pos} = case c of
        Padded _ _ -> let p' = lDim.padding
                      in { size: slots.padded.size, pos: { left: p'.left, top: p'.top } }
        _        ->      { size: slots.full.size,   pos: { left: 0.0, top: 0.0 } }

  canvas <-
    case lt of
      Fixed     -> Static <$> createCanvas         size "fixed"
      Scrolling -> Buffer <$> createBufferedCanvas size

  setCanvasPosition pos (canvas ^. _FrontCanvas)

  pure $ LayerContainer { dimensions: lDim, canvas }

type LayerRenderable =
  Variant ( fixed    :: Drawing
          , drawings :: Array { drawing :: Drawing
                              , points :: Array Point }
          , labels   :: Array Label )

_fixed :: SProxy "fixed"
_fixed = SProxy

_drawings :: SProxy "drawings"
_drawings = SProxy

_labels :: SProxy "labels"
_labels = SProxy

runLayer' :: ∀ m.
             Monoid m
          => Layer (ComponentSlot -> m)
          -> LayerContainer
          -> m
runLayer' layer@(Layer lt lm com) c@(LayerContainer lc) =
  let slots = layerSlots lc.dimensions
  in case com of
      Full     f -> f slots.full
      Padded r f -> f slots.padded
      Outside  f -> fold [ f.top    slots.top
                         , f.right  slots.right
                         , f.bottom slots.bottom
                         , f.left   slots.left ]

layerContext :: ∀ m a.
                MonadEff _ m
             => Layer a
             -> LayerContainer
             -> m Context2D
layerContext (Layer _ lmask com) (LayerContainer lc) = liftEff do
  ctx <- Canvas.getContext2D $ lc.canvas ^. _FrontCanvas
  _ <- Canvas.transform { m11: one,  m21: zero, m31: zero
                        , m12: zero, m22: one,  m32: zero } ctx

  let whenMasked = when (lmask == Masked)

  case com of
    -- translate to 0.0, 0.0
    Full     _ -> do
      -- whenMasked do
      --   pure unit

      pure ctx
    -- translate inward by the padding
    Padded r _ -> do
      -- whenMasked do
      --   pure unit
      Canvas.translate { translateX: r, translateY: r } ctx
    Outside  _ -> do

      let size = lc.dimensions.size

      whenMasked do
      -- translate to 0.0, set mask to not draw on the padded canvas
        _ <- Canvas.beginPath ctx
        _ <- Canvas.moveTo ctx 0.0        0.0
        _ <- Canvas.lineTo ctx size.width 0.0
        _ <- Canvas.lineTo ctx size.width size.height
        _ <- Canvas.lineTo ctx 0.0        size.height
        _ <- Canvas.lineTo ctx 0.0        0.0
        void $ Canvas.clip ctx

      pure ctx


Add `pattern` property

Add `pattern` property

-- | A closed signature of type-indexed (refined) HTML properties; these can be
-- | used to ensure correctness by construction, and then erased into the
-- | standard unrefined versions.
module Halogen.HTML.Properties
  ( IProp(..)
  , prop
  , attr
  , ref

  , alt
  , charset
  , class_, classes
  , cols
  , rows
  , colSpan
  , rowSpan
  , for
  , height
  , width
  , href
  , id_
  , name
  , rel
  , src
  , target
  , title

  , method
  , action
  , enctype
  , noValidate

  , type_
  , value
  , step
  , disabled
  , enabled
  , required
  , readOnly
  , spellcheck
  , checked
  , selected
  , placeholder
  , autocomplete
  , autofocus
  , multiple
  , pattern

  , autoplay
  , controls
  , loop
  , muted
  , poster
  , preload

  , draggable
  , tabIndex

  , module I
  ) where

import Prelude

import Data.Foreign (toForeign)
import Data.Maybe (Maybe(..))
import Data.MediaType (MediaType)
import Data.Newtype (class Newtype, unwrap)
import Data.String (joinWith)

import DOM.HTML.Indexed (CSSPixel) as I
import DOM.HTML.Indexed.ButtonType (ButtonType(..)) as I
import DOM.HTML.Indexed.FormMethod (FormMethod(..)) as I
import DOM.HTML.Indexed.InputType (InputType(..)) as I
import DOM.HTML.Indexed.MenuitemType (MenuitemType(..)) as I
import DOM.HTML.Indexed.MenuType (MenuType(..)) as I
import DOM.HTML.Indexed.OnOff (OnOff(..)) as I
import DOM.HTML.Indexed.OrderedListType (OrderedListType(..)) as I
import DOM.HTML.Indexed.PreloadValue (PreloadValue(..)) as I
import DOM.HTML.Indexed.StepValue (StepValue(..)) as I
import DOM.Node.Types (Element)

import Halogen.HTML.Core (class IsProp, ClassName, AttrName, PropName(..), Prop)
import Halogen.HTML.Core as Core
import Halogen.Query.InputF (InputF(..), RefLabel)

import Unsafe.Coerce (unsafeCoerce)

-- | The phantom row `r` can be thought of as a context which is synthesized in
-- | the course of constructing a refined HTML expression.
newtype IProp (r :: # *) i = IProp (Prop (InputF Unit i))

derive instance newtypeIProp :: Newtype (IProp r i) _

-- | Creates an indexed HTML property.
prop
  :: forall value r i
   . IsProp value
  => PropName value
  -> value
  -> IProp r i
prop = (unsafeCoerce :: (PropName value -> value -> Prop (InputF Unit i)) -> PropName value -> value -> IProp r i) Core.prop

-- | Creates an indexed HTML attribute.
attr :: forall r i. AttrName -> String -> IProp r i
attr = (unsafeCoerce :: (AttrName -> String -> Prop (InputF Unit i)) -> AttrName -> String -> IProp r i) Core.attr

-- | The `ref` property allows an input to be raised once a `HTMLElement` has
-- | been created or destroyed in the DOM for the element that the property is
-- | attached to.
ref :: forall r i. RefLabel -> IProp r i
ref = (unsafeCoerce :: ((Maybe Element -> Maybe (InputF Unit i)) -> Prop (InputF Unit i)) -> (Maybe Element -> Maybe (InputF Unit i)) -> IProp r i) Core.ref <<< go
  where
  go :: RefLabel -> Maybe Element -> Maybe (InputF Unit i)
  go p mel = Just $ RefUpdate p (toForeign <$> mel) unit

alt :: forall r i. String -> IProp (alt :: String | r) i
alt = prop (PropName "alt")

charset :: forall r i. String -> IProp (charset :: String | r) i
charset = prop (PropName "charset")

class_ :: forall r i. ClassName -> IProp (class :: String | r) i
class_ = prop (PropName "className") <<< unwrap

classes :: forall r i. Array ClassName -> IProp (class :: String | r) i
classes = prop (PropName "className") <<< joinWith " " <<< map unwrap

cols :: forall r i. Int -> IProp (cols :: Int | r) i
cols = prop (PropName "cols")

rows :: forall r i. Int -> IProp (rows :: Int | r) i
rows = prop (PropName "rows")

colSpan :: forall r i. Int -> IProp (colSpan :: Int | r) i
colSpan = prop (PropName "colSpan")

rowSpan :: forall r i. Int -> IProp (rowSpan :: Int | r) i
rowSpan = prop (PropName "rowSpan")

for :: forall r i. String -> IProp (for :: String | r) i
for = prop (PropName "htmlFor")

height :: forall r i. I.CSSPixel -> IProp (height :: I.CSSPixel | r) i
height = prop (PropName "height")

width :: forall r i. I.CSSPixel -> IProp (width :: I.CSSPixel | r) i
width = prop (PropName "width")

href :: forall r i. String -> IProp (href :: String | r) i
href = prop (PropName "href")

id_ :: forall r i. String -> IProp (id :: String | r) i
id_ = prop (PropName "id")

name :: forall r i. String -> IProp (name :: String | r) i
name = prop (PropName "name")

rel :: forall r i. String -> IProp (rel :: String | r) i
rel = prop (PropName "rel")

src :: forall r i. String -> IProp (src :: String | r) i
src = prop (PropName "src")

target :: forall r i. String -> IProp (target :: String | r) i
target = prop (PropName "target")

title :: forall r i. String -> IProp (title :: String | r) i
title = prop (PropName "title")

method :: forall r i. I.FormMethod -> IProp (method :: I.FormMethod | r) i
method = prop (PropName "method")

action :: forall r i. String -> IProp (action :: String | r) i
action = prop (PropName "action")

enctype :: forall r i. MediaType -> IProp (enctype :: MediaType | r) i
enctype = prop (PropName "enctype")

noValidate :: forall r i. Boolean -> IProp (noValidate :: Boolean | r) i
noValidate = prop (PropName "noValidate")

type_ :: forall r i value. IsProp value => value -> IProp (type :: value | r) i
type_ = prop (PropName "type")

value :: forall r i. String -> IProp (value :: String | r) i
value = prop (PropName "value")

step :: forall r i. I.StepValue -> IProp (step :: I.StepValue | r) i
step = prop (PropName "step")

enabled :: forall r i. Boolean -> IProp (disabled :: Boolean | r) i
enabled = disabled <<< not

disabled :: forall r i. Boolean -> IProp (disabled :: Boolean | r) i
disabled = prop (PropName "disabled")

required :: forall r i. Boolean -> IProp (required :: Boolean | r) i
required = prop (PropName "required")

readOnly :: forall r i. Boolean -> IProp (readOnly :: Boolean | r) i
readOnly = prop (PropName "readOnly")

spellcheck :: forall r i. Boolean -> IProp (spellcheck :: Boolean | r) i
spellcheck = prop (PropName "spellcheck")

checked :: forall r i. Boolean -> IProp (checked :: Boolean | r) i
checked = prop (PropName "checked")

selected :: forall r i. Boolean -> IProp (selected :: Boolean | r) i
selected = prop (PropName "selected")

placeholder :: forall r i. String -> IProp (placeholder :: String | r) i
placeholder = prop (PropName "placeholder")

autocomplete :: forall r i. Boolean -> IProp (autocomplete :: I.OnOff | r) i
autocomplete = prop (PropName "autocomplete") <<< (\b -> if b then I.On else I.Off)

autofocus :: forall r i. Boolean -> IProp (autofocus :: Boolean | r) i
autofocus = prop (PropName "autofocus")

multiple :: forall r i. Boolean -> IProp (multiple :: Boolean | r) i
multiple = prop (PropName "multiple")

pattern :: forall r i. String -> IProp (pattern :: String | r) i
pattern = prop (PropName "pattern")

autoplay :: forall r i. Boolean -> IProp (autoplay :: Boolean | r) i
autoplay = prop (PropName "autoplay")

controls :: forall r i. Boolean -> IProp (controls :: Boolean | r) i
controls = prop (PropName "controls")

loop :: forall r i. Boolean -> IProp (loop :: Boolean | r) i
loop = prop (PropName "loop")

muted :: forall r i. Boolean -> IProp (muted :: Boolean | r) i
muted = prop (PropName "muted")

poster :: forall r i. String -> IProp (poster :: String | r) i
poster = prop (PropName "poster")

preload :: forall r i. I.PreloadValue -> IProp (preload :: I.PreloadValue | r) i
preload = prop (PropName "preload")

draggable :: forall r i. Boolean -> IProp (draggable :: Boolean | r) i
draggable = prop (PropName "draggable")

tabIndex :: forall r i. Int -> IProp (tabIndex :: Int | r) i
tabIndex = prop (PropName "tabIndex")

-- | A closed signature of type-indexed (refined) HTML properties; these can be
-- | used to ensure correctness by construction, and then erased into the
-- | standard unrefined versions.
module Halogen.HTML.Properties
  ( IProp(..)
  , prop
  , attr
  , ref

  , alt
  , charset
  , class_, classes
  , cols
  , rows
  , colSpan
  , rowSpan
  , for
  , height
  , width
  , href
  , id_
  , name
  , rel
  , src
  , target
  , title

  , method
  , action
  , enctype
  , noValidate

  , type_
  , value
  , step
  , disabled
  , enabled
  , required
  , readOnly
  , spellcheck
  , checked
  , selected
  , placeholder
  , autocomplete
  , autofocus
  , multiple

  , autoplay
  , controls
  , loop
  , muted
  , poster
  , preload

  , draggable
  , tabIndex

  , module I
  ) where

import Prelude

import Data.Foreign (toForeign)
import Data.Maybe (Maybe(..))
import Data.MediaType (MediaType)
import Data.Newtype (class Newtype, unwrap)
import Data.String (joinWith)

import DOM.HTML.Indexed (CSSPixel) as I
import DOM.HTML.Indexed.ButtonType (ButtonType(..)) as I
import DOM.HTML.Indexed.FormMethod (FormMethod(..)) as I
import DOM.HTML.Indexed.InputType (InputType(..)) as I
import DOM.HTML.Indexed.MenuitemType (MenuitemType(..)) as I
import DOM.HTML.Indexed.MenuType (MenuType(..)) as I
import DOM.HTML.Indexed.OnOff (OnOff(..)) as I
import DOM.HTML.Indexed.OrderedListType (OrderedListType(..)) as I
import DOM.HTML.Indexed.PreloadValue (PreloadValue(..)) as I
import DOM.HTML.Indexed.StepValue (StepValue(..)) as I
import DOM.Node.Types (Element)

import Halogen.HTML.Core (class IsProp, ClassName, AttrName, PropName(..), Prop)
import Halogen.HTML.Core as Core
import Halogen.Query.InputF (InputF(..), RefLabel)

import Unsafe.Coerce (unsafeCoerce)

-- | The phantom row `r` can be thought of as a context which is synthesized in
-- | the course of constructing a refined HTML expression.
newtype IProp (r :: # *) i = IProp (Prop (InputF Unit i))

derive instance newtypeIProp :: Newtype (IProp r i) _

-- | Creates an indexed HTML property.
prop
  :: forall value r i
   . IsProp value
  => PropName value
  -> value
  -> IProp r i
prop = (unsafeCoerce :: (PropName value -> value -> Prop (InputF Unit i)) -> PropName value -> value -> IProp r i) Core.prop

-- | Creates an indexed HTML attribute.
attr :: forall r i. AttrName -> String -> IProp r i
attr = (unsafeCoerce :: (AttrName -> String -> Prop (InputF Unit i)) -> AttrName -> String -> IProp r i) Core.attr

-- | The `ref` property allows an input to be raised once a `HTMLElement` has
-- | been created or destroyed in the DOM for the element that the property is
-- | attached to.
ref :: forall r i. RefLabel -> IProp r i
ref = (unsafeCoerce :: ((Maybe Element -> Maybe (InputF Unit i)) -> Prop (InputF Unit i)) -> (Maybe Element -> Maybe (InputF Unit i)) -> IProp r i) Core.ref <<< go
  where
  go :: RefLabel -> Maybe Element -> Maybe (InputF Unit i)
  go p mel = Just $ RefUpdate p (toForeign <$> mel) unit

alt :: forall r i. String -> IProp (alt :: String | r) i
alt = prop (PropName "alt")

charset :: forall r i. String -> IProp (charset :: String | r) i
charset = prop (PropName "charset")

class_ :: forall r i. ClassName -> IProp (class :: String | r) i
class_ = prop (PropName "className") <<< unwrap

classes :: forall r i. Array ClassName -> IProp (class :: String | r) i
classes = prop (PropName "className") <<< joinWith " " <<< map unwrap

cols :: forall r i. Int -> IProp (cols :: Int | r) i
cols = prop (PropName "cols")

rows :: forall r i. Int -> IProp (rows :: Int | r) i
rows = prop (PropName "rows")

colSpan :: forall r i. Int -> IProp (colSpan :: Int | r) i
colSpan = prop (PropName "colSpan")

rowSpan :: forall r i. Int -> IProp (rowSpan :: Int | r) i
rowSpan = prop (PropName "rowSpan")

for :: forall r i. String -> IProp (for :: String | r) i
for = prop (PropName "htmlFor")

height :: forall r i. I.CSSPixel -> IProp (height :: I.CSSPixel | r) i
height = prop (PropName "height")

width :: forall r i. I.CSSPixel -> IProp (width :: I.CSSPixel | r) i
width = prop (PropName "width")

href :: forall r i. String -> IProp (href :: String | r) i
href = prop (PropName "href")

id_ :: forall r i. String -> IProp (id :: String | r) i
id_ = prop (PropName "id")

name :: forall r i. String -> IProp (name :: String | r) i
name = prop (PropName "name")

rel :: forall r i. String -> IProp (rel :: String | r) i
rel = prop (PropName "rel")

src :: forall r i. String -> IProp (src :: String | r) i
src = prop (PropName "src")

target :: forall r i. String -> IProp (target :: String | r) i
target = prop (PropName "target")

title :: forall r i. String -> IProp (title :: String | r) i
title = prop (PropName "title")

method :: forall r i. I.FormMethod -> IProp (method :: I.FormMethod | r) i
method = prop (PropName "method")

action :: forall r i. String -> IProp (action :: String | r) i
action = prop (PropName "action")

enctype :: forall r i. MediaType -> IProp (enctype :: MediaType | r) i
enctype = prop (PropName "enctype")

noValidate :: forall r i. Boolean -> IProp (noValidate :: Boolean | r) i
noValidate = prop (PropName "noValidate")

type_ :: forall r i value. IsProp value => value -> IProp (type :: value | r) i
type_ = prop (PropName "type")

value :: forall r i. String -> IProp (value :: String | r) i
value = prop (PropName "value")

step :: forall r i. I.StepValue -> IProp (step :: I.StepValue | r) i
step = prop (PropName "step")

enabled :: forall r i. Boolean -> IProp (disabled :: Boolean | r) i
enabled = disabled <<< not

disabled :: forall r i. Boolean -> IProp (disabled :: Boolean | r) i
disabled = prop (PropName "disabled")

required :: forall r i. Boolean -> IProp (required :: Boolean | r) i
required = prop (PropName "required")

readOnly :: forall r i. Boolean -> IProp (readOnly :: Boolean | r) i
readOnly = prop (PropName "readOnly")

spellcheck :: forall r i. Boolean -> IProp (spellcheck :: Boolean | r) i
spellcheck = prop (PropName "spellcheck")

checked :: forall r i. Boolean -> IProp (checked :: Boolean | r) i
checked = prop (PropName "checked")

selected :: forall r i. Boolean -> IProp (selected :: Boolean | r) i
selected = prop (PropName "selected")

placeholder :: forall r i. String -> IProp (placeholder :: String | r) i
placeholder = prop (PropName "placeholder")

autocomplete :: forall r i. Boolean -> IProp (autocomplete :: I.OnOff | r) i
autocomplete = prop (PropName "autocomplete") <<< (\b -> if b then I.On else I.Off)

autofocus :: forall r i. Boolean -> IProp (autofocus :: Boolean | r) i
autofocus = prop (PropName "autofocus")

multiple :: forall r i. Boolean -> IProp (multiple :: Boolean | r) i
multiple = prop (PropName "multiple")

autoplay :: forall r i. Boolean -> IProp (autoplay :: Boolean | r) i
autoplay = prop (PropName "autoplay")

controls :: forall r i. Boolean -> IProp (controls :: Boolean | r) i
controls = prop (PropName "controls")

loop :: forall r i. Boolean -> IProp (loop :: Boolean | r) i
loop = prop (PropName "loop")

muted :: forall r i. Boolean -> IProp (muted :: Boolean | r) i
muted = prop (PropName "muted")

poster :: forall r i. String -> IProp (poster :: String | r) i
poster = prop (PropName "poster")

preload :: forall r i. I.PreloadValue -> IProp (preload :: I.PreloadValue | r) i
preload = prop (PropName "preload")

draggable :: forall r i. Boolean -> IProp (draggable :: Boolean | r) i
draggable = prop (PropName "draggable")

tabIndex :: forall r i. Int -> IProp (tabIndex :: Int | r) i
tabIndex = prop (PropName "tabIndex")


a bit less ambiguous

a bit less ambiguous

module Data.DOM.Simple.Ajax
  ( ReadyState(..)
  , Url(..)
  , HttpMethod(..)
  , ResponseType(..)
  , ArrayBuffer(..)
  , ArrayBufferView(..)
  , Blob(..)
  , FormData(..)
  , HttpData(..)
  , makeXMLHttpRequest
  , readyState
  , onReadyStateChange
  , open
  , send
  , setResponseType
  , responseType
  , response
  , responseText
  , status
  , statusText
  , setRequestHeader
  , getAllResponseHeaders
  , getResponseHeader
  , overrideMimeType
  ) where

import Prelude

import Control.Monad.Eff
import Data.Function
import Data.Maybe (Maybe(..))
import DOM

import Data.DOM.Simple.Types
import Data.DOM.Simple.Unsafe.Ajax
import Data.DOM.Simple.Document

data ReadyState = Unsent | Opened | HeadersReceived | Loading | Done | UnknownState Int

type Url = String

data HttpMethod = GET | POST | PUT | DELETE | PATCH | HEAD | OPTIONS | JSONP | HttpMethod String

data ResponseType = Default | ArrayBuffer | Blob | Document | Json | Text | MozBlob | MozChunkedText | MozChunkedArrayBuffer

-- These could be given more complete interfaces somewhere:
foreign import data ArrayBuffer :: *
foreign import data ArrayBufferView :: *
foreign import data Blob :: *
foreign import data FormData :: *

data HttpData a
  = NoData
  | TextData String
  | ArrayBufferData ArrayBuffer
  | ArrayBufferViewData ArrayBufferView
  | BlobData Blob
  | FormData FormData
  | DocumentData HTMLDocument -- not necessarily HTML
  | JsonData a

instance showHttpMethod :: Show HttpMethod where
  show GET = "GET"
  show POST = "POST"
  show PUT = "PUT"
  show DELETE = "DELETE"
  show PATCH = "PATCH"
  show HEAD = "HEAD"
  show OPTIONS = "OPTIONS"
  show JSONP = "JSONP"
  show (HttpMethod m) = m

instance showResponseType :: Show ResponseType where
  show Default = ""
  show ArrayBuffer = "arraybuffer"
  show Blob = "blob"
  show Document = "document"
  show Json = "json"
  show Text = "text"
  show MozBlob = "moz-blob"
  show MozChunkedText = "moz-chunked-text"
  show MozChunkedArrayBuffer = "moz-chunked-arraybuffer"

foreign import maybeFn :: forall a b. Fn3 b (a -> b) a b

maybe :: forall a. a -> Maybe a
maybe = runFn3 maybeFn Nothing Just

foreign import makeXMLHttpRequest :: forall eff. (Eff (dom :: DOM | eff) XMLHttpRequest)

readyState :: forall eff. XMLHttpRequest -> Eff (dom :: DOM | eff) ReadyState
readyState x = do
  r <- unsafeReadyState x
  return $ case r of
    0 -> Unsent
    1 -> Opened
    2 -> HeadersReceived
    3 -> Loading
    4 -> Done
    _ -> Unknown r

onReadyStateChange :: forall eff e. Eff e Unit -> XMLHttpRequest -> Eff (dom :: DOM | eff) Unit
onReadyStateChange f x = runFn2 unsafeOnReadyStateChange x f

open :: forall eff. HttpMethod -> Url -> XMLHttpRequest -> Eff (dom :: DOM | eff) Unit
open m u x = runFn3 unsafeOpen x (show m) u

send :: forall eff a. HttpData a -> XMLHttpRequest -> Eff (dom :: DOM | eff) Unit
send NoData                  x = runFn1 unsafeSend x
send (TextData a)            x = runFn2 unsafeSendWithPayload x a
send (ArrayBufferData a)     x = runFn2 unsafeSendWithPayload x a
send (ArrayBufferViewData a) x = runFn2 unsafeSendWithPayload x a
send (BlobData a)            x = runFn2 unsafeSendWithPayload x a
send (DocumentData a)        x = runFn2 unsafeSendWithPayload x a
send (FormData a)            x = runFn2 unsafeSendWithPayload x a
send (JsonData a)            x = runFn2 unsafeSendWithPayload x a -- XXX should be encoded

setResponseType :: forall eff. ResponseType -> XMLHttpRequest -> Eff (dom :: DOM | eff) Unit
setResponseType rt x = runFn2 unsafeSetResponseType x (show rt)

responseType :: forall eff. XMLHttpRequest -> Eff (dom :: DOM | eff) ResponseType
responseType obj = do
  r <- unsafeResponseType obj
  return $ case r of
    "arraybuffer" -> ArrayBuffer
    "blob" -> Blob
    "document" -> Document
    "json" -> Json
    "text" -> Text
    "moz-blob" -> MozBlob
    "moz-chunked-test" -> MozChunkedText
    "moz-chunked-arraybuffer" -> MozChunkedArrayBuffer
    _ -> Default

response :: forall eff a. XMLHttpRequest -> Eff (dom :: DOM | eff) (HttpData a)
response x = do
  t <- responseType x
  case t of
    Default               -> get TextData
    ArrayBuffer           -> get ArrayBufferData
    Blob                  -> get BlobData
    Document              -> get DocumentData
    Json                  -> get JsonData
    Text                  -> get TextData
    MozBlob               -> get BlobData
    MozChunkedText        -> get TextData
    MozChunkedArrayBuffer -> get ArrayBufferData
  where
    get :: forall eff a o. (a -> HttpData o) -> Eff (dom :: DOM | eff) (HttpData o)
    get t = runFn3 maybeFn NoData t <$> unsafeResponse x

foreign import responseText :: forall eff. XMLHttpRequest -> (Eff (dom :: DOM | eff) String)

foreign import status :: forall eff. XMLHttpRequest -> Eff (dom :: DOM | eff) Int

foreign import statusText :: forall eff. XMLHttpRequest -> (Eff (dom :: DOM | eff) String)

foreign import setRequestHeader :: forall eff. String -> String -> XMLHttpRequest -> (Eff (dom :: DOM | eff) Unit)

foreign import getAllResponseHeaders :: forall eff. XMLHttpRequest -> (Eff (dom :: DOM | eff) String)

getResponseHeader :: forall eff. String -> XMLHttpRequest -> Eff (dom :: DOM | eff) (Maybe String)
getResponseHeader k x = maybe <$> runFn2 unsafeGetResponseHeader x k

foreign import overrideMimeType :: forall eff. String -> XMLHttpRequest -> (Eff (dom :: DOM | eff) Unit)

module Data.DOM.Simple.Ajax
  ( ReadyState(..)
  , Url(..)
  , HttpMethod(..)
  , ResponseType(..)
  , ArrayBuffer(..)
  , ArrayBufferView(..)
  , Blob(..)
  , FormData(..)
  , HttpData(..)
  , makeXMLHttpRequest
  , readyState
  , onReadyStateChange
  , open
  , send
  , setResponseType
  , responseType
  , response
  , responseText
  , status
  , statusText
  , setRequestHeader
  , getAllResponseHeaders
  , getResponseHeader
  , overrideMimeType
  ) where

import Prelude

import Control.Monad.Eff
import Data.Function
import Data.Maybe (Maybe(..))
import DOM

import Data.DOM.Simple.Types
import Data.DOM.Simple.Unsafe.Ajax
import Data.DOM.Simple.Document

data ReadyState = Unsent | Opened | HeadersReceived | Loading | Done | Unknown Int

type Url = String

data HttpMethod = GET | POST | PUT | DELETE | PATCH | HEAD | OPTIONS | JSONP | HttpMethod String

data ResponseType = Default | ArrayBuffer | Blob | Document | Json | Text | MozBlob | MozChunkedText | MozChunkedArrayBuffer

-- These could be given more complete interfaces somewhere:
foreign import data ArrayBuffer :: *
foreign import data ArrayBufferView :: *
foreign import data Blob :: *
foreign import data FormData :: *

data HttpData a
  = NoData
  | TextData String
  | ArrayBufferData ArrayBuffer
  | ArrayBufferViewData ArrayBufferView
  | BlobData Blob
  | FormData FormData
  | DocumentData HTMLDocument -- not necessarily HTML
  | JsonData a

instance showHttpMethod :: Show HttpMethod where
  show GET = "GET"
  show POST = "POST"
  show PUT = "PUT"
  show DELETE = "DELETE"
  show PATCH = "PATCH"
  show HEAD = "HEAD"
  show OPTIONS = "OPTIONS"
  show JSONP = "JSONP"
  show (HttpMethod m) = m

instance showResponseType :: Show ResponseType where
  show Default = ""
  show ArrayBuffer = "arraybuffer"
  show Blob = "blob"
  show Document = "document"
  show Json = "json"
  show Text = "text"
  show MozBlob = "moz-blob"
  show MozChunkedText = "moz-chunked-text"
  show MozChunkedArrayBuffer = "moz-chunked-arraybuffer"

foreign import maybeFn :: forall a b. Fn3 b (a -> b) a b

maybe :: forall a. a -> Maybe a
maybe = runFn3 maybeFn Nothing Just

foreign import makeXMLHttpRequest :: forall eff. (Eff (dom :: DOM | eff) XMLHttpRequest)

readyState :: forall eff. XMLHttpRequest -> Eff (dom :: DOM | eff) ReadyState
readyState x = do
  r <- unsafeReadyState x
  return $ case r of
    0 -> Unsent
    1 -> Opened
    2 -> HeadersReceived
    3 -> Loading
    4 -> Done
    _ -> Unknown r

onReadyStateChange :: forall eff e. Eff e Unit -> XMLHttpRequest -> Eff (dom :: DOM | eff) Unit
onReadyStateChange f x = runFn2 unsafeOnReadyStateChange x f

open :: forall eff. HttpMethod -> Url -> XMLHttpRequest -> Eff (dom :: DOM | eff) Unit
open m u x = runFn3 unsafeOpen x (show m) u

send :: forall eff a. HttpData a -> XMLHttpRequest -> Eff (dom :: DOM | eff) Unit
send NoData                  x = runFn1 unsafeSend x
send (TextData a)            x = runFn2 unsafeSendWithPayload x a
send (ArrayBufferData a)     x = runFn2 unsafeSendWithPayload x a
send (ArrayBufferViewData a) x = runFn2 unsafeSendWithPayload x a
send (BlobData a)            x = runFn2 unsafeSendWithPayload x a
send (DocumentData a)        x = runFn2 unsafeSendWithPayload x a
send (FormData a)            x = runFn2 unsafeSendWithPayload x a
send (JsonData a)            x = runFn2 unsafeSendWithPayload x a -- XXX should be encoded

setResponseType :: forall eff. ResponseType -> XMLHttpRequest -> Eff (dom :: DOM | eff) Unit
setResponseType rt x = runFn2 unsafeSetResponseType x (show rt)

responseType :: forall eff. XMLHttpRequest -> Eff (dom :: DOM | eff) ResponseType
responseType obj = do
  r <- unsafeResponseType obj
  return $ case r of
    "arraybuffer" -> ArrayBuffer
    "blob" -> Blob
    "document" -> Document
    "json" -> Json
    "text" -> Text
    "moz-blob" -> MozBlob
    "moz-chunked-test" -> MozChunkedText
    "moz-chunked-arraybuffer" -> MozChunkedArrayBuffer
    _ -> Default

response :: forall eff a. XMLHttpRequest -> Eff (dom :: DOM | eff) (HttpData a)
response x = do
  t <- responseType x
  case t of
    Default               -> get TextData
    ArrayBuffer           -> get ArrayBufferData
    Blob                  -> get BlobData
    Document              -> get DocumentData
    Json                  -> get JsonData
    Text                  -> get TextData
    MozBlob               -> get BlobData
    MozChunkedText        -> get TextData
    MozChunkedArrayBuffer -> get ArrayBufferData
  where
    get :: forall eff a o. (a -> HttpData o) -> Eff (dom :: DOM | eff) (HttpData o)
    get t = runFn3 maybeFn NoData t <$> unsafeResponse x

foreign import responseText :: forall eff. XMLHttpRequest -> (Eff (dom :: DOM | eff) String)

foreign import status :: forall eff. XMLHttpRequest -> Eff (dom :: DOM | eff) Int

foreign import statusText :: forall eff. XMLHttpRequest -> (Eff (dom :: DOM | eff) String)

foreign import setRequestHeader :: forall eff. String -> String -> XMLHttpRequest -> (Eff (dom :: DOM | eff) Unit)

foreign import getAllResponseHeaders :: forall eff. XMLHttpRequest -> (Eff (dom :: DOM | eff) String)

getResponseHeader :: forall eff. String -> XMLHttpRequest -> Eff (dom :: DOM | eff) (Maybe String)
getResponseHeader k x = maybe <$> runFn2 unsafeGetResponseHeader x k

foreign import overrideMimeType :: forall eff. String -> XMLHttpRequest -> (Eff (dom :: DOM | eff) Unit)