SelectionManager.purs

module SelectionManager where

import Yoga.Prelude.View

import Data.Set (Set)
import Data.Set as Set
import Hooks.UseSelectable (UseSelectable, UseSelectableResult, useSelectable)

type State a =
  { selection ∷ Set a
  , selectables ∷ Set a
  , enabled ∷ Boolean
  }

defaultState ∷ ∀ a. State a
defaultState = { selection: Set.empty, selectables: Set.empty, enabled: true }

data Action a = UpdateSelection ((Set a → Set a))

type Props a =
  { state ∷ State a
  , dispatch ∷ Action a → Effect Unit
  }

reduce ∷ ∀ a. Eq a ⇒ Ord a ⇒ State a → Action a → State a
reduce = case _, _ of
  s@{ selection, enabled: true }, UpdateSelection update → s
    { selection = update selection }
  state, _ → state

useSelectableDispatch ∷
  ∀ a.
  Eq a ⇒
  Ord a ⇒
  State a →
  (Action a → Effect Unit) →
  Set a →
  Hook (UseSelectable a) (UseSelectableResult a)
useSelectableDispatch state dispatch selectables =
  useSelectable
    { selection: state.selection
    , updateSelection: (dispatch <<< UpdateSelection)
    , selectables
    }

UseSelectable.purs

module Hooks.UseSelectable where

import Yoga.Prelude.View

import Data.FoldableWithIndex (traverseWithIndex_)
import Data.Map (Map)
import Data.Map as Map
import Data.Maybe (isNothing)
import Data.Newtype (class Newtype)
import Data.Nullable as Nullable
import Data.Set (Set)
import Data.Set as Set
import Data.Traversable (for)
import Data.TraversableWithIndex (traverseWithIndex)
import Debug (spy)
import Effect.Class.Console as Console
import Effect.Ref as Ref
import Effect.Uncurried (mkEffectFn1)
import Foreign.Internal.Stringify (unsafeStringify)
import Foreign.Object (Object)
import Foreign.Object as Object
import React.Basic.Hooks as React
import Unsafe.Coerce (unsafeCoerce)
import Web.DOM.Element as Element
import Web.HTML.HTMLElement as HTMLElement

type UseSelectableResult a =
  { getOverlappingItems ∷ DOMRect → Effect (Set a)
  , getSelectedBoundingBoxes ∷ Effect (Map a DOMRect)
  , recalculateBoundingBoxes ∷ Effect Unit
  , getItemProps ∷ GetItemProps a
  , getCachedBoundingBox ∷ a → Effect (Maybe DOMRect)
  , deleteStaleRefs ∷ Effect Unit
  , getCurrentBoundingBox ∷ a → Effect (Maybe DOMRect)
  }

type GetItemProps a =
  a → { _aria ∷ Object String, onClick ∷ EventHandler, ref ∷ NodeRef }

newtype UseSelectable a hooks = UseSelectable
  ( UseEffect (Set a)
      ( UseRef (Map a DOMRect)
          (UseRef (Map a Node) hooks)
      )
  )

derive instance Newtype (UseSelectable a hooks) _

useSelectable ∷
  ∀ a.
  Eq a ⇒
  Ord a ⇒
  { selectables ∷ Set a
  , selection ∷ Set a
  , updateSelection ∷ (Set a → Set a) → Effect Unit
  } →
  Hook (UseSelectable a) (UseSelectableResult a)
useSelectable { selection, selectables, updateSelection } = coerceHook
  React.do
    refsRef ∷ Ref (Map a Node) ← React.useRef Map.empty
    bbsRef ∷ Ref (Map a DOMRect) ← React.useRef Map.empty

    React.useEffect selectables do
      refs ← readRef refsRef
      refs # traverseWithIndex_ \item _ →
        when (not Set.member item selectables) do
          modifyRef refsRef (Map.delete item)
          modifyRef bbsRef (Map.delete item)
      mempty

    let
      isChecked item = Set.member item selection
      onClick item = handler_ (updateSelection (Set.toggle item))

      itemRef ∷ a → NodeRef
      itemRef item = unsafeCoerce $ mkEffectFn1
        \(nullableNode ∷ Nullable Node) → do
          for_ (Nullable.toMaybe nullableNode) \node → do
            when (not Set.member item selectables) do
              Console.error
                ( "Got a ref for item " <> unsafeStringify item <>
                    " but it is not in the selectable set"
                )
            modifyRef refsRef (Map.insert item node)
            bbʔ ← getBBʔ node
            for_ bbʔ \bb → do
              modifyRef bbsRef (Map.insert item bb)

      getCachedBoundingBox item = do
        readRef bbsRef <#> Map.lookup item

      deleteStaleRefs = do
        refs ∷ Map a Node ← readRef refsRef
        bbs ∷ Map a DOMRect ← readRef bbsRef
        bbs # traverseWithIndex_ \(item ∷ a) _ → do
          let nodeʔ = Map.lookup item refs
          case nodeʔ of
            Just _ → mempty
            Nothing → do
              modifyRef refsRef (Map.delete item)

      getSelectedBoundingBoxes = ado
        bbs ← readRef bbsRef
        in
          selection
            # Set.mapMaybe (\item → Map.lookup item bbs <#> (item /\ _))
            # Map.fromFoldable

      recalculateBoundingBoxes = do
        writeRef bbsRef Map.empty
        readRef refsRef >>=
          traverseWithIndex_ \item nodeRef → do
            bbʔ ← getBBʔ nodeRef
            for_ bbʔ \bb → do
              modifyRef bbsRef (Map.insert item bb)

      getCurrentBoundingBox item = do
        refs ← readRef refsRef
        for (Map.lookup item refs) getBBʔ <#> join

      getOverlappingItems ∷ DOMRect → Effect (Set a)
      getOverlappingItems { top, left, right, bottom } = do
        resultRef ← Ref.new Set.empty
        bbs ← readRef bbsRef
        for_ (bbs # Map.toUnfoldable ∷ Array _)
          \(item /\ domRect) → do
            when
              ( (domRect.left <= right) && (domRect.right >= left)
                  && (domRect.top <= bottom)
                  && (domRect.bottom >= top)
              )
              do Ref.modify_ (Set.insert item) resultRef
        Ref.read resultRef

    pure
      ( { getOverlappingItems
        , getSelectedBoundingBoxes
        , recalculateBoundingBoxes
        , getCachedBoundingBox
        , getCurrentBoundingBox
        , deleteStaleRefs
        , getItemProps: \i →
            { _aria: Object.fromHomogeneous { checked: show (isChecked i) }
            , onClick: onClick i
            , ref: itemRef i
            }
        } ∷ UseSelectableResult _
      )

getBBʔ ∷ Node → Effect (Maybe DOMRect)
getBBʔ node = runMaybeT do
  element ← (node # Element.fromNode) # pure # MaybeT
  getBoundingClientRect element # lift

modifyRef ∷ ∀ a. Ref a → (a → a) → Effect Unit
modifyRef ref f = do
  val ← readRef ref
  writeRef ref (f val)