-----------------------------------------------------------------------------
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards   #-}
-----------------------------------------------------------------------------
-- |
-- Module      :  Miso.Flow.Utils.Dom
-- License     :  BSD3-style (see the file LICENSE)
--
-- Port of @utils\/dom.ts@ from @\@xyflow\/system@. These functions need a
-- live DOM, so unlike the rest of "Miso.Flow.Utils" they run in 'IO'
-- (call them from @update@ effects, not from @view@).
----------------------------------------------------------------------------
module Miso.Flow.Utils.Dom
  ( getDimensions
  , getBoundingRect
  , getHostForElement
  , isInputDOMNode
  , isMouseEvent
  , getEventPosition
  , PointerPosition (..)
  , getPointerPosition
  , getHandleBounds
  ) where
-----------------------------------------------------------------------------
import           Control.Monad (forM, filterM)
import           Data.Maybe (fromMaybe)
import           Prelude hiding ((!!))
-----------------------------------------------------------------------------
import           Miso.DSL
import           Miso.Effect (DOMRef)
import           Miso.String (MisoString)
-----------------------------------------------------------------------------
import           Miso.Flow.Types
import           Miso.Flow.Utils.General
  ( pointToRendererPoint
  , snapPosition
  )
-----------------------------------------------------------------------------
-- | @offsetWidth@ \/ @offsetHeight@ of an element.
getDimensions :: DOMRef -> IO Dimensions
getDimensions :: JSVal -> IO Dimensions
getDimensions JSVal
el = do
  w <- JSVal -> IO Double
forall a. FromJSVal a => JSVal -> IO a
fromJSValUnchecked (JSVal -> IO Double) -> IO JSVal -> IO Double
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< JSVal
el JSVal -> MisoString -> IO JSVal
forall o. ToObject o => o -> MisoString -> IO JSVal
! MisoString
"offsetWidth"
  h <- fromJSValUnchecked =<< el ! "offsetHeight"
  pure (Dimensions w h)
-----------------------------------------------------------------------------
-- | @getBoundingClientRect()@ as a 'Rect'.
getBoundingRect :: DOMRef -> IO Rect
getBoundingRect :: JSVal -> IO Rect
getBoundingRect JSVal
el = do
  r <- JSVal
el JSVal -> MisoString -> () -> IO JSVal
forall object args.
(ToObject object, ToArgs args) =>
object -> MisoString -> args -> IO JSVal
# MisoString
"getBoundingClientRect" (() -> IO JSVal) -> () -> IO JSVal
forall a b. (a -> b) -> a -> b
$ ()
  x <- fromJSValUnchecked =<< r ! "left"
  y <- fromJSValUnchecked =<< r ! "top"
  w <- fromJSValUnchecked =<< r ! "width"
  h <- fromJSValUnchecked =<< r ! "height"
  pure (Rect x y w h)
-----------------------------------------------------------------------------
-- | Root node (document or shadow root) hosting the element.
getHostForElement :: DOMRef -> IO JSVal
getHostForElement :: JSVal -> IO JSVal
getHostForElement JSVal
el = do
  root <- JSVal
el JSVal -> MisoString -> () -> IO JSVal
forall object args.
(ToObject object, ToArgs args) =>
object -> MisoString -> args -> IO JSVal
# MisoString
"getRootNode" (() -> IO JSVal) -> () -> IO JSVal
forall a b. (a -> b) -> a -> b
$ ()
  undef <- isUndefined root
  if undef then jsg "document" else pure root
-----------------------------------------------------------------------------
-- | 'True' when the (keyboard) event targets an input-like element or an
-- element inside @.nokey@.
isInputDOMNode :: JSVal -> IO Bool
isInputDOMNode :: JSVal -> IO Bool
isInputDOMNode JSVal
event = do
  path <- JSVal
event JSVal -> MisoString -> () -> IO JSVal
forall object args.
(ToObject object, ToArgs args) =>
object -> MisoString -> args -> IO JSVal
# MisoString
"composedPath" (() -> IO JSVal) -> () -> IO JSVal
forall a b. (a -> b) -> a -> b
$ ()
  pathHead <- path !! 0
  headUndef <- isUndefined pathHead
  target <- if headUndef then event ! "target" else pure pathHead
  targetNull <- isNull target
  targetUndef <- isUndefined target
  if targetNull || targetUndef
    then pure False
    else do
      nodeType <- fromJSVal =<< target ! "nodeType"
      if nodeType /= Just (1 :: Int)
        then pure False
        else do
          name <- fromJSValUnchecked =<< target ! "nodeName"
          editable <- fromJSValUnchecked =<<
            (target # "hasAttribute" $ ["contenteditable" :: MisoString])
          closest <- target # "closest" $ [".nokey" :: MisoString]
          inNoKey <- not <$> isNull closest
          pure $ name `elem` (["INPUT", "SELECT", "TEXTAREA"] :: [MisoString])
                   || editable
                   || inNoKey
-----------------------------------------------------------------------------
-- | 'True' when the event carries mouse (not touch) coordinates.
isMouseEvent :: JSVal -> IO Bool
isMouseEvent :: JSVal -> IO Bool
isMouseEvent JSVal
event = do
  x <- JSVal
event JSVal -> MisoString -> IO JSVal
forall o. ToObject o => o -> MisoString -> IO JSVal
! MisoString
"clientX"
  not <$> isUndefined x
-----------------------------------------------------------------------------
-- | Client position of a mouse or touch event, optionally relative to
-- the given bounds.
getEventPosition :: JSVal -> Maybe Rect -> IO XYPosition
getEventPosition :: JSVal -> Maybe Rect -> IO XYPosition
getEventPosition JSVal
event Maybe Rect
mBounds = do
  mouse <- JSVal -> IO Bool
isMouseEvent JSVal
event
  (x, y) <-
    if mouse
      then do
        x <- fromJSValUnchecked =<< event ! "clientX"
        y <- fromJSValUnchecked =<< event ! "clientY"
        pure (x, y)
      else do
        touches <- event ! "touches"
        t0 <- touches !! 0
        x <- fromJSValUnchecked =<< t0 ! "clientX"
        y <- fromJSValUnchecked =<< t0 ! "clientY"
        pure (x, y)
  let bx = Double -> (Rect -> Double) -> Maybe Rect -> Double
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Double
0 Rect -> Double
rectX Maybe Rect
mBounds
      by = Double -> (Rect -> Double) -> Maybe Rect -> Double
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Double
0 Rect -> Double
rectY Maybe Rect
mBounds
  pure (XYPosition (x - bx) (y - by))
-----------------------------------------------------------------------------
-- | Pointer position in flow coordinates, with the snapped variant used
-- to skip no-movement drag events.
data PointerPosition = PointerPosition
  { PointerPosition -> XYPosition
pointerPosition :: !XYPosition
  , PointerPosition -> Double
pointerXSnapped :: !Double
  , PointerPosition -> Double
pointerYSnapped :: !Double
  } deriving (Int -> PointerPosition -> ShowS
[PointerPosition] -> ShowS
PointerPosition -> String
(Int -> PointerPosition -> ShowS)
-> (PointerPosition -> String)
-> ([PointerPosition] -> ShowS)
-> Show PointerPosition
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> PointerPosition -> ShowS
showsPrec :: Int -> PointerPosition -> ShowS
$cshow :: PointerPosition -> String
show :: PointerPosition -> String
$cshowList :: [PointerPosition] -> ShowS
showList :: [PointerPosition] -> ShowS
Show, PointerPosition -> PointerPosition -> Bool
(PointerPosition -> PointerPosition -> Bool)
-> (PointerPosition -> PointerPosition -> Bool)
-> Eq PointerPosition
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: PointerPosition -> PointerPosition -> Bool
== :: PointerPosition -> PointerPosition -> Bool
$c/= :: PointerPosition -> PointerPosition -> Bool
/= :: PointerPosition -> PointerPosition -> Bool
Eq)
-----------------------------------------------------------------------------
-- | Port of @getPointerPosition@.
getPointerPosition
  :: JSVal
  -- ^ mouse or touch event
  -> Transform
  -> Bool
  -- ^ snap to grid
  -> Maybe SnapGrid
  -> Maybe Rect
  -- ^ container bounds
  -> IO PointerPosition
getPointerPosition :: JSVal
-> Transform
-> Bool
-> Maybe SnapGrid
-> Maybe Rect
-> IO PointerPosition
getPointerPosition JSVal
event Transform
transform Bool
snapToGrid Maybe SnapGrid
mSnapGrid Maybe Rect
mBounds = do
  XYPosition x y <- JSVal -> Maybe Rect -> IO XYPosition
getEventPosition JSVal
event Maybe Rect
forall a. Maybe a
Nothing
  let pointerPos = XYPosition -> Transform -> Bool -> SnapGrid -> XYPosition
pointToRendererPoint
        (Double -> Double -> XYPosition
XYPosition (Double
x Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double -> (Rect -> Double) -> Maybe Rect -> Double
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Double
0 Rect -> Double
rectX Maybe Rect
mBounds) (Double
y Double -> Double -> Double
forall a. Num a => a -> a -> a
- Double -> (Rect -> Double) -> Maybe Rect -> Double
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Double
0 Rect -> Double
rectY Maybe Rect
mBounds))
        Transform
transform
        Bool
False
        (Double -> Double -> SnapGrid
SnapGrid Double
1 Double
1)
      snapped =
        if Bool
snapToGrid
          then XYPosition -> SnapGrid -> XYPosition
snapPosition XYPosition
pointerPos (SnapGrid -> Maybe SnapGrid -> SnapGrid
forall a. a -> Maybe a -> a
fromMaybe (Double -> Double -> SnapGrid
SnapGrid Double
0 Double
0) Maybe SnapGrid
mSnapGrid)
          else XYPosition
pointerPos
  pure PointerPosition
    { pointerPosition = pointerPos
    , pointerXSnapped = xyX snapped
    , pointerYSnapped = xyY snapped
    }
-----------------------------------------------------------------------------
-- | Measure the handles of the given type inside a node element,
-- relative to the node; port of @getHandleBounds@.
getHandleBounds
  :: HandleType
  -> DOMRef
  -- ^ node element
  -> Rect
  -- ^ node bounds (client rect)
  -> Double
  -- ^ zoom
  -> NodeId
  -> IO (Maybe [Handle])
getHandleBounds :: HandleType
-> JSVal -> Rect -> Double -> MisoString -> IO (Maybe [Handle])
getHandleBounds HandleType
handleType JSVal
nodeElement Rect
nodeBounds Double
zoom MisoString
nid = do
  handleList <- JSVal
nodeElement JSVal -> MisoString -> [MisoString] -> IO JSVal
forall object args.
(ToObject object, ToArgs args) =>
object -> MisoString -> args -> IO JSVal
# MisoString
"querySelectorAll"
    ([MisoString] -> IO JSVal) -> [MisoString] -> IO JSVal
forall a b. (a -> b) -> a -> b
$ [ MisoString
"." MisoString -> MisoString -> MisoString
forall a. Semigroup a => a -> a -> a
<> HandleType -> MisoString
handleTypeToText HandleType
handleType ]
  len <- fromJSValUnchecked =<< handleList ! "length"
  if (len :: Int) == 0
    then pure Nothing
    else do
      els <- filterM (fmap not . isUndefined) =<<
        forM [0 .. len - 1] (handleList !!)
      handles <- forM els $ \JSVal
handle -> do
        bounds <- JSVal
handle JSVal -> MisoString -> () -> IO JSVal
forall object args.
(ToObject object, ToArgs args) =>
object -> MisoString -> args -> IO JSVal
# MisoString
"getBoundingClientRect" (() -> IO JSVal) -> () -> IO JSVal
forall a b. (a -> b) -> a -> b
$ ()
        left <- fromJSValUnchecked =<< bounds ! "left"
        top <- fromJSValUnchecked =<< bounds ! "top"
        hid <- fromJSVal =<< (handle # "getAttribute" $ ["data-handleid" :: MisoString])
        posAttr <- fromJSVal =<< (handle # "getAttribute" $ ["data-handlepos" :: MisoString])
        Dimensions w h <- getDimensions handle
        pure Handle
          { hId = hid
          , hNodeId = nid
          , hPosition = fromMaybe PositionBottom (positionFromText =<< posAttr)
          , hX = (left - rectX nodeBounds) / zoom
          , hY = (top - rectY nodeBounds) / zoom
          , hType = handleType
          , hWidth = w
          , hHeight = h
          }
      pure (Just handles)
-----------------------------------------------------------------------------