# LANGUAGE TypeFamilies #
# LANGUAGE RecursiveDo #
{-# LANGUAGE OverloadedStrings #-}
# LANGUAGE LambdaCase #
module IDE.Web.Widget.ContextMenu where

import Control.Lens ((^.))

import Data.Bool (bool)
import Data.Text (Text)
import qualified Data.Text as T (pack)

import Language.Javascript.JSaddle (liftJSM, js1)

import GHCJS.Marshal (FromJSVal(..))
import GHCJS.DOM (currentDocumentUnchecked)
import GHCJS.DOM.Types (HTMLElement(..), uncheckedCastTo)
import qualified GHCJS.DOM.Types as DOM (Element(..))
import qualified GHCJS.DOM.Event as Event (getTargetUnchecked)
import GHCJS.DOM.EventM
       (event, uiPageY, uiPageX, onSync, preventDefault)
import qualified GHCJS.DOM.GlobalEventHandlers as DOM (contextMenu)
import GHCJS.DOM.GlobalEventHandlers (touchStart, mouseDown)

import Clay
       (shadowWithSpread, black, bsColor, boxShadow,
        absolute, padding, px, borderRadius, vGradient, backgroundImage,
        position, (?), Css, Color(..), nil, zIndex)

import Reflex
       (leftmost, ffor, Event, never, holdDyn, switchHold,
        FunctorMaybe(..), fmapMaybe)
import Reflex.Dom.Core
       (wrapDomEventMaybe, elAttr', wrapDomEvent, EventResult,
        Element, MonadWidget, DomBuilderSpace, dyn, (=:), _element_raw)

contextMenuCss :: Css
contextMenuCss =
  ".context-menu" ? do
    position absolute
    backgroundImage (vGradient (Rgba 64 64 64 0.9) (Rgba 32 32 32 0.9))
    borderRadius (px 5) (px 5) (px 5) (px 5)
    padding nil nil nil nil
    boxShadow (pure $ bsColor black $ shadowWithSpread (px 0) (px 0) (px 10) (px 3))
    zIndex 1000

contextMenu
  :: MonadWidget t m
  => Element EventResult (DomBuilderSpace m) t
  -> m (Event t a)
  -> m (Event t (), Event t a)
contextMenu parent menu = mdo
  contextmenuE <- wrapDomEvent (uncheckedCastTo HTMLElement $ _element_raw parent)
    (`onSync` DOM.contextMenu) $ do
      preventDefault
      x <- uiPageX
      y <- uiPageY
      return (x, y)
  showContextMenuD <- holdDyn Nothing $ leftmost
    [ Just <$> contextmenuE
    , Nothing <$ events
    ]
  events <- (switchHold never =<<) . dyn $ ffor showContextMenuD $ \case
    Nothing -> return never
    Just (x, y) -> do
      (menuElement, menuEvent) <- elAttr' "div" ("class" =: "context-menu"
          <> "style" =: T.pack ("top:" <> show y <> "px; left:" <> show x <> "px;")) menu
      doc <- currentDocumentUnchecked
      docMouseDownE <- wrapDomEventMaybe doc (`onSync` mouseDown) $ do
        t <- event >>= Event.getTargetUnchecked
        fmap (bool (Just ()) Nothing) . liftJSM $ _element_raw menuElement ^. js1 ("contains" :: Text) t >>= fromJSValUnchecked
      docTouchStartE <- wrapDomEventMaybe doc (`onSync` touchStart) $ do
        t <- event >>= Event.getTargetUnchecked
        fmap (bool (Just ()) Nothing) . liftJSM $ _element_raw menuElement ^. js1 ("contains" :: Text) t >>= fromJSValUnchecked
       docScrollE < - wrapDomEvent doc ( ` onSync ` touchStart ) $ return ( )
      return $ leftmost [ Nothing <$ docMouseDownE, Nothing <$ docTouchStartE, Just <$> menuEvent ]
  return (() <$ contextmenuE, fmapMaybe id events)

# LANGUAGE OverloadedStrings #
# LANGUAGE TypeFamilies #
# LANGUAGE RecursiveDo #
# LANGUAGE LambdaCase #
module IDE.Web.Widget.ContextMenu where

import Control.Lens ((^.))

import Data.Bool (bool)
import Data.Text (Text)
import qualified Data.Text as T (pack)

import Language.Javascript.JSaddle (liftJSM, js1)

import GHCJS.Marshal (FromJSVal(..))
import GHCJS.DOM (currentDocumentUnchecked)
import GHCJS.DOM.Types (HTMLElement(..), uncheckedCastTo)
import qualified GHCJS.DOM.Types as DOM (Element(..))
import qualified GHCJS.DOM.Event as Event (getTargetUnchecked)
import GHCJS.DOM.EventM
       (event, uiPageY, uiPageX, onSync, preventDefault)
import qualified GHCJS.DOM.GlobalEventHandlers as DOM (contextMenu)
import GHCJS.DOM.GlobalEventHandlers (touchStart, mouseDown)

import Clay
       (shadowWithSpread, black, bsColor, boxShadow,
        absolute, padding, px, borderRadius, vGradient, backgroundImage,
        position, (?), Css, Color(..), nil, zIndex)

import Reflex
       (leftmost, ffor, Event, never, holdDyn, switchHold,
        FunctorMaybe(..), fmapMaybe)
import Reflex.Dom.Core
       (wrapDomEventMaybe, elAttr', wrapDomEvent, EventResult,
        Element, MonadWidget, DomBuilderSpace, dyn, (=:), _element_raw)

contextMenuCss :: Css
contextMenuCss =
  ".context-menu" ? do
    position absolute
    backgroundImage (vGradient (Rgba 64 64 64 0.9) (Rgba 32 32 32 0.9))
    borderRadius (px 5) (px 5) (px 5) (px 5)
    padding nil nil nil nil
    boxShadow (pure $ bsColor black $ shadowWithSpread (px 0) (px 0) (px 10) (px 3))
    zIndex 1000

contextMenu
  :: MonadWidget t m
  => Element EventResult (DomBuilderSpace m) t
  -> m (Event t a)
  -> m (Event t (), Event t a)
contextMenu parent menu = mdo
  contextmenuE <- wrapDomEvent (uncheckedCastTo HTMLElement $ _element_raw parent)
    (`onSync` DOM.contextMenu) $ do
      preventDefault
      x <- uiPageX
      y <- uiPageY
      return (x, y)
  showContextMenuD <- holdDyn Nothing $ leftmost
    [ Just <$> contextmenuE
    , Nothing <$ events
    ]
  events <- (switchHold never =<<) . dyn $ ffor showContextMenuD $ \case
    Nothing -> return never
    Just (x, y) -> do
      (menuElement, menuEvent) <- elAttr' "div" ("class" =: "context-menu"
          <> "style" =: T.pack ("top:" <> show y <> "px; left:" <> show x <> "px;")) menu
      doc <- currentDocumentUnchecked
      docMouseDownE <- wrapDomEventMaybe doc (`onSync` mouseDown) $ do
        t <- event >>= Event.getTargetUnchecked
        fmap (bool (Just ()) Nothing) . liftJSM $ _element_raw menuElement ^. js1 ("contains" :: Text) t >>= fromJSValUnchecked
      docTouchStartE <- wrapDomEventMaybe doc (`onSync` touchStart) $ do
        t <- event >>= Event.getTargetUnchecked
        fmap (bool (Just ()) Nothing) . liftJSM $ _element_raw menuElement ^. js1 ("contains" :: Text) t >>= fromJSValUnchecked
       docScrollE < - wrapDomEvent doc ( ` onSync ` touchStart ) $ return ( )
      return $ leftmost [ Nothing <$ docMouseDownE, Nothing <$ docTouchStartE, Just <$> menuEvent ]
  return (() <$ contextmenuE, fmapMaybe id events)
