MenuedWidget.hs

class MonadWidget t m => MonadDiamondWidget t m where
  getGlobalKeydownEvent :: m (Event t Key)
  getGlobalKeyupEvent :: m (Event t Key)
  getKeyLayout :: m (Dynamic t KeyLayout)

menuedWidget
  :: forall t m a b
   . MonadDiamondWidget t m
  => (Event t a -> m b)
  -> Menu a
  -> m ()
menuedWidget widget menu@(Menu actions) =
  if null actions
    then do
      _ <- widget never
      pure ()
    else mdo
      -- widget
      (e, _) <- elAttr' "div" attrs $ widget selectE
      selectE <- mkSelectEvent openD
      openD <- mkOpenDyn e

      widgetHold_ (pure ()) $ ffor (updated openD) $ \case
        True -> menuW menu
        False -> pure ()
  where
    attrs = Map.fromList
      [ ("class", "WithMenu")
      , ("tabindex", "1")
      , ("onmouseenter", "if (document.querySelector('.DiamondMenu') == null) { this.focus({ preventScroll: true }) }")
      , ("onmouseleave", "this.blur()")
      ]

    mkSelectEvent :: Dynamic t Bool -> m (Event t a)
    mkSelectEvent openD = do
      globalKeydownE <- getGlobalKeydownEvent
      keyLayoutD <- getKeyLayout
      let selectFilterD = do
            keyLayout <- keyLayoutD
            pure $ \e -> do
              index <- elemIndex e (keyList keyLayout)
              snd <$> actions !!? index
      pure $ gate (current openD) $ attachWithMaybe ($) (current selectFilterD) globalKeydownE

    mkOpenDyn :: El t -> m (Dynamic t Bool)
    mkOpenDyn e = mdo
      globalKeyupE <- getGlobalKeyupEvent
      focusedB <- hold False $ leftmost
        [ True <$ focusE
        , False <$ blurE
        ]
      let focusE = domEvent Focus e
          blurE = domEvent Blur e
          keyDownE = keyCodeLookup . fromIntegral <$> domEvent Keydown e
          openE = leftmost
            [ gate focusedB (True <$ ffilter (== Shift) keyDownE)
            , False <$ ffilter (== Shift) globalKeyupE
            ]
      holdDyn False openE