content: {-# LANGUAGE ConstraintKinds #-}
  {-# LANGUAGE LambdaCase #-}
  {-# LANGUAGE ScopedTypeVariables #-}
  {-# LANGUAGE OverloadedStrings #-}
  {-# LANGUAGE RecordWildCards #-}
  module GHCJS.DOM.Debug (
      DomHasCallStack
    , debugEnabled
    , getElementStack
    , addDebugMenu
    , addDebugMenu'
  ) where
  
  import Control.Arrow (Arrow(..))
  import Control.Monad.IO.Class (MonadIO(..))
  
  import Data.Char (toLower)
  import Data.Foldable (forM_)
  import Data.Monoid ((<>))
  
  import System.IO (stderr, hPutStrLn)
  
  import GHC.Stack
         (srcLocStartLine, srcLocFile, SrcLoc(..), HasCallStack)
  import GHC.Exts (Constraint)
  
  import GHCJS.DOM (currentDocumentUnchecked)
  import GHCJS.DOM.Types
         (HTMLDivElement(..), HTMLStyleElement(..), uncheckedCastTo,
          HTMLUListElement(..), MouseEvent(..), Document(..), Element(..),
          HTMLAnchorElement(..), MonadJSM, JSM, liftJSM, JSString)
  import GHCJS.DOM.Debug.Internal (DomHasCallStack, getElementStack, debugEnabled)
  import GHCJS.DOM.Document
         (createTextNode, getBodyUnchecked,
          getElementsByTagName, createElement)
  import GHCJS.DOM.DocumentOrShadowRoot (elementFromPoint)
  import GHCJS.DOM.Element
         (getTagName, setAttribute, getAttribute, setInnerHTML)
  import GHCJS.DOM.EventM
         (addListener, uiPageXY, mouseClientXY, mouseShiftKey, target,
          newListener, on, preventDefault)
  import GHCJS.DOM.EventTargetClosures (SaferEventListener(..))
  import GHCJS.DOM.GlobalEventHandlers (click, contextMenu)
  import GHCJS.DOM.HTMLCollection (itemUnchecked)
  import GHCJS.DOM.HTMLStyleElement (setType)
  import GHCJS.DOM.Node (getParentElement, appendChild_)
  import GHCJS.DOM.NonElementParentNode (getElementById)
  
  addDebugMenu :: MonadJSM m => m (JSM ())
  addDebugMenu = addDebugMenu' (const Nothing)
  
  addDebugMenu' :: MonadJSM m => (SrcLoc -> Maybe String) -> m (JSM ())
  addDebugMenu' getSourceLink = liftJSM $ do
      let menuId = "ghcjs-dom-debug" :: JSString
      doc <- currentDocumentUnchecked
      style <- uncheckedCastTo HTMLStyleElement <$> createElement doc ("style" :: JSString)
      setType style ("text/css" :: JSString)
      setInnerHTML style $ mconcat [
          "#", menuId, ", #", menuId, " ul ul{"
        , "  display: block;"
        , "  position: absolute;"
        , "  box-shadow: 0 4px 8px 0 rgba(0, 0, 0, 0.2), 0 6px 20px 0 rgba(0, 0, 0, 0.19);"
        , "  padding: 2px;"
        , "  z-index:1000;"
        , "  margin: 0;"
        , "  list-style-type: none;"
        , "  list-style: none;"
        , "  background-color:#fff;"
        , "  color:#000;"
        , "}\n"
        , "#", menuId, " ul{"
        , "  list-style-type: none;"
        , "  margin: 0;"
        , "  padding: 2px;"
        , "  cursor: pointer;"
        , "}\n"
        , "#", menuId, " li{"
        , "  white-space: nowrap;"
        , "}\n"
        , "#", menuId, " ul ul{"
        , "  display: none;"
        , "}\n"
        , "#", menuId, ">li:hover{"
        , "  background-color:#ddd;"
        , "}\n"
        , "#", menuId, " li:hover ul{"
        , "  display: inline-block;"
        , "  position: absolute;"
        , "  z-index:1001;"
        , "}\n"
        ]
      getElementsByTagName doc ("head" :: JSString) >>= (`itemUnchecked` 0) >>= (`appendChild_` style)
      body <- getBodyUnchecked doc
      clickListener <- newListener $ do
          target >>= \case
              Just (t :: HTMLAnchorElement) ->
                  getAttribute t ("hs-srcloc" :: JSString)
                      >>= mapM_ (liftIO . hPutStrLn stderr . ("OPEN " <>))
              Nothing -> return ()
          getElementById doc menuId >>= mapM_
              (\e -> setAttribute e ("style" :: JSString) ("display: none;" :: JSString))
      on doc contextMenu $ mouseShiftKey >>= \case
          True -> ((fromIntegral *** fromIntegral) <$> mouseClientXY) >>= uncurry (elementFromPoint doc) >>= \case
              Just e ->  do
                  preventDefault
                  menu <- getElementById doc menuId >>= \case
                      Just menu -> setInnerHTML menu ("" :: JSString) >> return (uncheckedCastTo HTMLDivElement menu)
                      Nothing -> do
                          menu <- uncheckedCastTo HTMLDivElement <$> createElement doc ("div" :: JSString)
                          setAttribute menu ("id" :: JSString) menuId
                          appendChild_ body menu
                          return menu
  
                  if debugEnabled
                      then do
                          ul <- uncheckedCastTo HTMLUListElement <$> createElement doc ("ul" :: JSString)
                          appendChild_ menu ul
                          addMenu doc clickListener ul e
                      else do
                          a <- uncheckedCastTo HTMLAnchorElement <$> createElement doc ("a" :: JSString)
                          appendChild_ menu a
                          createTextNode doc ("The ghcjs-dom debug cabal flag is switched off" :: JSString)
                              >>= appendChild_ a
                          setAttribute a ("href" :: JSString)
                              ("https://github.com/ghcjs/ghcjs-dom/blob/master/README.md#debug" :: JSString)
                          setAttribute a ("target" :: JSString) ("_blank" :: JSString)
                          liftJSM $ addListener a click clickListener False
  
                  (pageX, pageY) <- uiPageXY
                  setAttribute menu ("style" :: JSString) ("display: block; left: " <> show pageX <> "px; top:" <> show pageY <> "px;" )
              Nothing -> return ()
          False -> return ()
  
    where
      addMenu :: MonadJSM m => Document -> SaferEventListener HTMLAnchorElement MouseEvent -> HTMLUListElement -> Element -> m ()
      addMenu doc clickListener parentMenu = loop
        where
          loop e = do
              getElementStack e >>= mapM_ (addElementMenu doc clickListener parentMenu e)
              getParentElement e >>= mapM_ loop
  
      addElementMenu
          :: MonadJSM m
          => Document
          -> SaferEventListener HTMLAnchorElement MouseEvent
          -> HTMLUListElement
          -> Element
          -> [(String, SrcLoc)]
          -> m ()
      addElementMenu doc clickListener parentMenu e cs = do
          tagName <- map toLower <$> getTagName e
          parentLi <- createElement doc ("li" :: JSString)
          appendChild_ parentMenu parentLi
          createTextNode doc tagName >>= appendChild_ parentLi
          ul <- createElement doc ("ul" :: JSString)
          appendChild_ parentLi ul
          forM_ (reverse cs) $ \(f, loc) -> do
              li <- createElement doc ("li" :: JSString)
              appendChild_ ul li
              a <- uncheckedCastTo HTMLAnchorElement <$> createElement doc ("a" :: JSString)
              appendChild_ li a
              createTextNode doc (f <> " " <> srcLocFile loc <> ":" <> show (srcLocStartLine loc))
                  >>= appendChild_ a
              forM_ (getSourceLink loc) $ \link -> do
                  setAttribute a ("href" :: JSString) link
                  setAttribute a ("target" :: JSString) ("_blank" :: JSString)
              setAttribute a ("hs-srcloc" :: JSString) $ prettySrcLoc loc
              liftJSM $ addListener a click clickListener False
  
      prettySrcLoc :: SrcLoc -> String
      prettySrcLoc SrcLoc {..} = mconcat
          [ srcLocFile          , ":("
          , show srcLocStartLine, ","
          , show srcLocStartCol , ")-("
          , show srcLocEndLine  , ","
          , show srcLocEndCol   , ") in "
          , srcLocPackage, ":", srcLocModule
          ]
  
  