{-# 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 :: forall (m :: * -> *). MonadJSM m => m (JSM ())
addDebugMenu = (SrcLoc -> Maybe String) -> m (JSM ())
forall (m :: * -> *).
MonadJSM m =>
(SrcLoc -> Maybe String) -> m (JSM ())
addDebugMenu' (Maybe String -> SrcLoc -> Maybe String
forall a b. a -> b -> a
const Maybe String
forall a. Maybe a
Nothing)

addDebugMenu' :: MonadJSM m => (SrcLoc -> Maybe String) -> m (JSM ())
addDebugMenu' :: forall (m :: * -> *).
MonadJSM m =>
(SrcLoc -> Maybe String) -> m (JSM ())
addDebugMenu' SrcLoc -> Maybe String
getSourceLink = JSM (JSM ()) -> m (JSM ())
forall (m :: * -> *) a. MonadJSM m => JSM a -> m a
liftJSM (JSM (JSM ()) -> m (JSM ())) -> JSM (JSM ()) -> m (JSM ())
forall a b. (a -> b) -> a -> b
$ do
    let menuId :: JSString
menuId = JSString
"ghcjs-dom-debug" :: JSString
    Document
doc <- JSM Document
forall (m :: * -> *). MonadDOM m => m Document
currentDocumentUnchecked
    HTMLStyleElement
style <- (JSVal -> HTMLStyleElement) -> Element -> HTMLStyleElement
forall obj obj'.
(Coercible obj JSVal, IsGObject obj') =>
(JSVal -> obj') -> obj -> obj'
uncheckedCastTo JSVal -> HTMLStyleElement
HTMLStyleElement (Element -> HTMLStyleElement)
-> JSM Element -> JSM HTMLStyleElement
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Document -> JSString -> JSM Element
forall (m :: * -> *) self localName.
(MonadDOM m, IsDocument self, ToJSString localName) =>
self -> localName -> m Element
createElement Document
doc (JSString
"style" :: JSString)
    HTMLStyleElement -> JSString -> JSM ()
forall (m :: * -> *) val.
(MonadDOM m, ToJSString val) =>
HTMLStyleElement -> val -> m ()
setType HTMLStyleElement
style (JSString
"text/css" :: JSString)
    HTMLStyleElement -> JSString -> JSM ()
forall (m :: * -> *) self val.
(MonadDOM m, IsElement self, ToJSString val) =>
self -> val -> m ()
setInnerHTML HTMLStyleElement
style (JSString -> JSM ()) -> JSString -> JSM ()
forall a b. (a -> b) -> a -> b
$ [JSString] -> JSString
forall a. Monoid a => [a] -> a
mconcat [
        JSString
"#", JSString
menuId, JSString
", #", JSString
menuId, JSString
" ul ul{"
      , JSString
"  display: block;"
      , JSString
"  position: absolute;"
      , JSString
"  box-shadow: 0 4px 8px 0 rgba(0, 0, 0, 0.2), 0 6px 20px 0 rgba(0, 0, 0, 0.19);"
      , JSString
"  padding: 2px;"
      , JSString
"  z-index:1000;"
      , JSString
"  margin: 0;"
      , JSString
"  list-style-type: none;"
      , JSString
"  list-style: none;"
      , JSString
"  background-color:#fff;"
      , JSString
"  color:#000;"
      , JSString
"}\n"
      , JSString
"#", JSString
menuId, JSString
" ul{"
      , JSString
"  list-style-type: none;"
      , JSString
"  margin: 0;"
      , JSString
"  padding: 2px;"
      , JSString
"  cursor: pointer;"
      , JSString
"}\n"
      , JSString
"#", JSString
menuId, JSString
" li{"
      , JSString
"  white-space: nowrap;"
      , JSString
"}\n"
      , JSString
"#", JSString
menuId, JSString
" ul ul{"
      , JSString
"  display: none;"
      , JSString
"}\n"
      , JSString
"#", JSString
menuId, JSString
">li:hover{"
      , JSString
"  background-color:#ddd;"
      , JSString
"}\n"
      , JSString
"#", JSString
menuId, JSString
" li:hover ul{"
      , JSString
"  display: inline-block;"
      , JSString
"  position: absolute;"
      , JSString
"  z-index:1001;"
      , JSString
"}\n"
      ]
    Document -> JSString -> JSM HTMLCollection
forall (m :: * -> *) self qualifiedName.
(MonadDOM m, IsDocument self, ToJSString qualifiedName) =>
self -> qualifiedName -> m HTMLCollection
getElementsByTagName Document
doc (JSString
"head" :: JSString) JSM HTMLCollection
-> (HTMLCollection -> JSM Element) -> JSM Element
forall a b. JSM a -> (a -> JSM b) -> JSM b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (HTMLCollection -> Word -> JSM Element
forall (m :: * -> *) self.
(MonadDOM m, IsHTMLCollection self) =>
self -> Word -> m Element
`itemUnchecked` Word
0) JSM Element -> (Element -> JSM ()) -> JSM ()
forall a b. JSM a -> (a -> JSM b) -> JSM b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (Element -> HTMLStyleElement -> JSM ()
forall (m :: * -> *) self node.
(MonadDOM m, IsNode self, IsNode node) =>
self -> node -> m ()
`appendChild_` HTMLStyleElement
style)
    HTMLElement
body <- Document -> JSM HTMLElement
forall (m :: * -> *) self.
(MonadDOM m, IsDocument self) =>
self -> m HTMLElement
getBodyUnchecked Document
doc
    SaferEventListener HTMLAnchorElement MouseEvent
clickListener <- EventM HTMLAnchorElement MouseEvent ()
-> DOM (SaferEventListener HTMLAnchorElement MouseEvent)
forall e t.
IsEvent e =>
EventM t e () -> DOM (SaferEventListener t e)
newListener (EventM HTMLAnchorElement MouseEvent ()
 -> DOM (SaferEventListener HTMLAnchorElement MouseEvent))
-> EventM HTMLAnchorElement MouseEvent ()
-> DOM (SaferEventListener HTMLAnchorElement MouseEvent)
forall a b. (a -> b) -> a -> b
$ do
        EventM HTMLAnchorElement MouseEvent (Maybe HTMLAnchorElement)
forall e t. (IsEvent e, IsGObject t) => EventM t e (Maybe t)
target EventM HTMLAnchorElement MouseEvent (Maybe HTMLAnchorElement)
-> (Maybe HTMLAnchorElement
    -> EventM HTMLAnchorElement MouseEvent ())
-> EventM HTMLAnchorElement MouseEvent ()
forall a b.
ReaderT MouseEvent JSM a
-> (a -> ReaderT MouseEvent JSM b) -> ReaderT MouseEvent JSM b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
            Just (HTMLAnchorElement
t :: HTMLAnchorElement) ->
                HTMLAnchorElement
-> JSString -> ReaderT MouseEvent JSM (Maybe String)
forall (m :: * -> *) self qualifiedName result.
(MonadDOM m, IsElement self, ToJSString qualifiedName,
 FromJSString result) =>
self -> qualifiedName -> m (Maybe result)
getAttribute HTMLAnchorElement
t (JSString
"hs-srcloc" :: JSString)
                    ReaderT MouseEvent JSM (Maybe String)
-> (Maybe String -> EventM HTMLAnchorElement MouseEvent ())
-> EventM HTMLAnchorElement MouseEvent ()
forall a b.
ReaderT MouseEvent JSM a
-> (a -> ReaderT MouseEvent JSM b) -> ReaderT MouseEvent JSM b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (String -> EventM HTMLAnchorElement MouseEvent ())
-> Maybe String -> EventM HTMLAnchorElement MouseEvent ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (IO () -> EventM HTMLAnchorElement MouseEvent ()
forall a. IO a -> ReaderT MouseEvent JSM a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> EventM HTMLAnchorElement MouseEvent ())
-> (String -> IO ())
-> String
-> EventM HTMLAnchorElement MouseEvent ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Handle -> String -> IO ()
hPutStrLn Handle
stderr (String -> IO ()) -> (String -> String) -> String -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String
"OPEN " String -> String -> String
forall a. Semigroup a => a -> a -> a
<>))
            Maybe HTMLAnchorElement
Nothing -> () -> EventM HTMLAnchorElement MouseEvent ()
forall a. a -> ReaderT MouseEvent JSM a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
        Document -> JSString -> ReaderT MouseEvent JSM (Maybe Element)
forall (m :: * -> *) self elementId.
(MonadDOM m, IsNonElementParentNode self, ToJSString elementId) =>
self -> elementId -> m (Maybe Element)
getElementById Document
doc JSString
menuId ReaderT MouseEvent JSM (Maybe Element)
-> (Maybe Element -> EventM HTMLAnchorElement MouseEvent ())
-> EventM HTMLAnchorElement MouseEvent ()
forall a b.
ReaderT MouseEvent JSM a
-> (a -> ReaderT MouseEvent JSM b) -> ReaderT MouseEvent JSM b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (Element -> EventM HTMLAnchorElement MouseEvent ())
-> Maybe Element -> EventM HTMLAnchorElement MouseEvent ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_
            (\Element
e -> Element
-> JSString -> JSString -> EventM HTMLAnchorElement MouseEvent ()
forall (m :: * -> *) self qualifiedName value.
(MonadDOM m, IsElement self, ToJSString qualifiedName,
 ToJSString value) =>
self -> qualifiedName -> value -> m ()
setAttribute Element
e (JSString
"style" :: JSString) (JSString
"display: none;" :: JSString))
    Document
-> EventName Document MouseEvent
-> EventM HTMLAnchorElement MouseEvent ()
-> JSM (JSM ())
forall t e.
(IsEventTarget t, IsEvent e) =>
t -> EventName t e -> EventM t e () -> JSM (JSM ())
on Document
doc EventName Document MouseEvent
forall self.
(IsGlobalEventHandlers self, IsEventTarget self) =>
EventName self MouseEvent
contextMenu (EventM HTMLAnchorElement MouseEvent () -> JSM (JSM ()))
-> EventM HTMLAnchorElement MouseEvent () -> JSM (JSM ())
forall a b. (a -> b) -> a -> b
$ EventM Any MouseEvent Bool
forall e t. IsMouseEvent e => EventM t e Bool
mouseShiftKey EventM Any MouseEvent Bool
-> (Bool -> EventM HTMLAnchorElement MouseEvent ())
-> EventM HTMLAnchorElement MouseEvent ()
forall a b.
ReaderT MouseEvent JSM a
-> (a -> ReaderT MouseEvent JSM b) -> ReaderT MouseEvent JSM b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Bool
True -> ((Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Double)
-> (Int -> Double) -> (Int, Int) -> (Double, Double)
forall b c b' c'. (b -> c) -> (b' -> c') -> (b, b') -> (c, c')
forall (a :: * -> * -> *) b c b' c'.
Arrow a =>
a b c -> a b' c' -> a (b, b') (c, c')
*** Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral) ((Int, Int) -> (Double, Double))
-> ReaderT MouseEvent JSM (Int, Int)
-> ReaderT MouseEvent JSM (Double, Double)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ReaderT MouseEvent JSM (Int, Int)
forall e t. IsMouseEvent e => EventM t e (Int, Int)
mouseClientXY) ReaderT MouseEvent JSM (Double, Double)
-> ((Double, Double) -> ReaderT MouseEvent JSM (Maybe Element))
-> ReaderT MouseEvent JSM (Maybe Element)
forall a b.
ReaderT MouseEvent JSM a
-> (a -> ReaderT MouseEvent JSM b) -> ReaderT MouseEvent JSM b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (Double -> Double -> ReaderT MouseEvent JSM (Maybe Element))
-> (Double, Double) -> ReaderT MouseEvent JSM (Maybe Element)
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry (Document
-> Double -> Double -> ReaderT MouseEvent JSM (Maybe Element)
forall (m :: * -> *) self.
(MonadDOM m, IsDocumentOrShadowRoot self) =>
self -> Double -> Double -> m (Maybe Element)
elementFromPoint Document
doc) ReaderT MouseEvent JSM (Maybe Element)
-> (Maybe Element -> EventM HTMLAnchorElement MouseEvent ())
-> EventM HTMLAnchorElement MouseEvent ()
forall a b.
ReaderT MouseEvent JSM a
-> (a -> ReaderT MouseEvent JSM b) -> ReaderT MouseEvent JSM b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
            Just Element
e ->  do
                EventM HTMLAnchorElement MouseEvent ()
forall e t. IsEvent e => EventM t e ()
preventDefault
                HTMLDivElement
menu <- Document -> JSString -> ReaderT MouseEvent JSM (Maybe Element)
forall (m :: * -> *) self elementId.
(MonadDOM m, IsNonElementParentNode self, ToJSString elementId) =>
self -> elementId -> m (Maybe Element)
getElementById Document
doc JSString
menuId ReaderT MouseEvent JSM (Maybe Element)
-> (Maybe Element -> ReaderT MouseEvent JSM HTMLDivElement)
-> ReaderT MouseEvent JSM HTMLDivElement
forall a b.
ReaderT MouseEvent JSM a
-> (a -> ReaderT MouseEvent JSM b) -> ReaderT MouseEvent JSM b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
                    Just Element
menu -> Element -> JSString -> EventM HTMLAnchorElement MouseEvent ()
forall (m :: * -> *) self val.
(MonadDOM m, IsElement self, ToJSString val) =>
self -> val -> m ()
setInnerHTML Element
menu (JSString
"" :: JSString) EventM HTMLAnchorElement MouseEvent ()
-> ReaderT MouseEvent JSM HTMLDivElement
-> ReaderT MouseEvent JSM HTMLDivElement
forall a b.
ReaderT MouseEvent JSM a
-> ReaderT MouseEvent JSM b -> ReaderT MouseEvent JSM b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> HTMLDivElement -> ReaderT MouseEvent JSM HTMLDivElement
forall a. a -> ReaderT MouseEvent JSM a
forall (m :: * -> *) a. Monad m => a -> m a
return ((JSVal -> HTMLDivElement) -> Element -> HTMLDivElement
forall obj obj'.
(Coercible obj JSVal, IsGObject obj') =>
(JSVal -> obj') -> obj -> obj'
uncheckedCastTo JSVal -> HTMLDivElement
HTMLDivElement Element
menu)
                    Maybe Element
Nothing -> do
                        HTMLDivElement
menu <- (JSVal -> HTMLDivElement) -> Element -> HTMLDivElement
forall obj obj'.
(Coercible obj JSVal, IsGObject obj') =>
(JSVal -> obj') -> obj -> obj'
uncheckedCastTo JSVal -> HTMLDivElement
HTMLDivElement (Element -> HTMLDivElement)
-> ReaderT MouseEvent JSM Element
-> ReaderT MouseEvent JSM HTMLDivElement
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Document -> JSString -> ReaderT MouseEvent JSM Element
forall (m :: * -> *) self localName.
(MonadDOM m, IsDocument self, ToJSString localName) =>
self -> localName -> m Element
createElement Document
doc (JSString
"div" :: JSString)
                        HTMLDivElement
-> JSString -> JSString -> EventM HTMLAnchorElement MouseEvent ()
forall (m :: * -> *) self qualifiedName value.
(MonadDOM m, IsElement self, ToJSString qualifiedName,
 ToJSString value) =>
self -> qualifiedName -> value -> m ()
setAttribute HTMLDivElement
menu (JSString
"id" :: JSString) JSString
menuId
                        HTMLElement
-> HTMLDivElement -> EventM HTMLAnchorElement MouseEvent ()
forall (m :: * -> *) self node.
(MonadDOM m, IsNode self, IsNode node) =>
self -> node -> m ()
appendChild_ HTMLElement
body HTMLDivElement
menu
                        HTMLDivElement -> ReaderT MouseEvent JSM HTMLDivElement
forall a. a -> ReaderT MouseEvent JSM a
forall (m :: * -> *) a. Monad m => a -> m a
return HTMLDivElement
menu

                if Bool
debugEnabled
                    then do
                        HTMLUListElement
ul <- (JSVal -> HTMLUListElement) -> Element -> HTMLUListElement
forall obj obj'.
(Coercible obj JSVal, IsGObject obj') =>
(JSVal -> obj') -> obj -> obj'
uncheckedCastTo JSVal -> HTMLUListElement
HTMLUListElement (Element -> HTMLUListElement)
-> ReaderT MouseEvent JSM Element
-> ReaderT MouseEvent JSM HTMLUListElement
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Document -> JSString -> ReaderT MouseEvent JSM Element
forall (m :: * -> *) self localName.
(MonadDOM m, IsDocument self, ToJSString localName) =>
self -> localName -> m Element
createElement Document
doc (JSString
"ul" :: JSString)
                        HTMLDivElement
-> HTMLUListElement -> EventM HTMLAnchorElement MouseEvent ()
forall (m :: * -> *) self node.
(MonadDOM m, IsNode self, IsNode node) =>
self -> node -> m ()
appendChild_ HTMLDivElement
menu HTMLUListElement
ul
                        Document
-> SaferEventListener HTMLAnchorElement MouseEvent
-> HTMLUListElement
-> Element
-> EventM HTMLAnchorElement MouseEvent ()
forall (m :: * -> *).
MonadJSM m =>
Document
-> SaferEventListener HTMLAnchorElement MouseEvent
-> HTMLUListElement
-> Element
-> m ()
addMenu Document
doc SaferEventListener HTMLAnchorElement MouseEvent
clickListener HTMLUListElement
ul Element
e
                    else do
                        HTMLAnchorElement
a <- (JSVal -> HTMLAnchorElement) -> Element -> HTMLAnchorElement
forall obj obj'.
(Coercible obj JSVal, IsGObject obj') =>
(JSVal -> obj') -> obj -> obj'
uncheckedCastTo JSVal -> HTMLAnchorElement
HTMLAnchorElement (Element -> HTMLAnchorElement)
-> ReaderT MouseEvent JSM Element
-> ReaderT MouseEvent JSM HTMLAnchorElement
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Document -> JSString -> ReaderT MouseEvent JSM Element
forall (m :: * -> *) self localName.
(MonadDOM m, IsDocument self, ToJSString localName) =>
self -> localName -> m Element
createElement Document
doc (JSString
"a" :: JSString)
                        HTMLDivElement
-> HTMLAnchorElement -> EventM HTMLAnchorElement MouseEvent ()
forall (m :: * -> *) self node.
(MonadDOM m, IsNode self, IsNode node) =>
self -> node -> m ()
appendChild_ HTMLDivElement
menu HTMLAnchorElement
a
                        Document -> JSString -> ReaderT MouseEvent JSM Text
forall (m :: * -> *) self data'.
(MonadDOM m, IsDocument self, ToJSString data') =>
self -> data' -> m Text
createTextNode Document
doc (JSString
"The ghcjs-dom debug cabal flag is switched off" :: JSString)
                            ReaderT MouseEvent JSM Text
-> (Text -> EventM HTMLAnchorElement MouseEvent ())
-> EventM HTMLAnchorElement MouseEvent ()
forall a b.
ReaderT MouseEvent JSM a
-> (a -> ReaderT MouseEvent JSM b) -> ReaderT MouseEvent JSM b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= HTMLAnchorElement -> Text -> EventM HTMLAnchorElement MouseEvent ()
forall (m :: * -> *) self node.
(MonadDOM m, IsNode self, IsNode node) =>
self -> node -> m ()
appendChild_ HTMLAnchorElement
a
                        HTMLAnchorElement
-> JSString -> JSString -> EventM HTMLAnchorElement MouseEvent ()
forall (m :: * -> *) self qualifiedName value.
(MonadDOM m, IsElement self, ToJSString qualifiedName,
 ToJSString value) =>
self -> qualifiedName -> value -> m ()
setAttribute HTMLAnchorElement
a (JSString
"href" :: JSString)
                            (JSString
"https://github.com/ghcjs/ghcjs-dom/blob/master/README.md#debug" :: JSString)
                        HTMLAnchorElement
-> JSString -> JSString -> EventM HTMLAnchorElement MouseEvent ()
forall (m :: * -> *) self qualifiedName value.
(MonadDOM m, IsElement self, ToJSString qualifiedName,
 ToJSString value) =>
self -> qualifiedName -> value -> m ()
setAttribute HTMLAnchorElement
a (JSString
"target" :: JSString) (JSString
"_blank" :: JSString)
                        JSM () -> EventM HTMLAnchorElement MouseEvent ()
forall (m :: * -> *) a. MonadJSM m => JSM a -> m a
liftJSM (JSM () -> EventM HTMLAnchorElement MouseEvent ())
-> JSM () -> EventM HTMLAnchorElement MouseEvent ()
forall a b. (a -> b) -> a -> b
$ HTMLAnchorElement
-> EventName HTMLAnchorElement MouseEvent
-> SaferEventListener HTMLAnchorElement MouseEvent
-> Bool
-> JSM ()
forall t e.
(IsEventTarget t, IsEvent e) =>
t -> EventName t e -> SaferEventListener t e -> Bool -> JSM ()
addListener HTMLAnchorElement
a EventName HTMLAnchorElement MouseEvent
forall self.
(IsGlobalEventHandlers self, IsEventTarget self) =>
EventName self MouseEvent
click SaferEventListener HTMLAnchorElement MouseEvent
clickListener Bool
False

                (Int
pageX, Int
pageY) <- ReaderT MouseEvent JSM (Int, Int)
forall e t. IsUIEvent e => EventM t e (Int, Int)
uiPageXY
                HTMLDivElement
-> JSString -> String -> EventM HTMLAnchorElement MouseEvent ()
forall (m :: * -> *) self qualifiedName value.
(MonadDOM m, IsElement self, ToJSString qualifiedName,
 ToJSString value) =>
self -> qualifiedName -> value -> m ()
setAttribute HTMLDivElement
menu (JSString
"style" :: JSString) (String
"display: block; left: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show Int
pageX String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"px; top:" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show Int
pageY String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"px;" )
            Maybe Element
Nothing -> () -> EventM HTMLAnchorElement MouseEvent ()
forall a. a -> ReaderT MouseEvent JSM a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
        Bool
False -> () -> EventM HTMLAnchorElement MouseEvent ()
forall a. a -> ReaderT MouseEvent JSM a
forall (m :: * -> *) a. Monad m => a -> m a
return ()

  where
    addMenu :: MonadJSM m => Document -> SaferEventListener HTMLAnchorElement MouseEvent -> HTMLUListElement -> Element -> m ()
    addMenu :: forall (m :: * -> *).
MonadJSM m =>
Document
-> SaferEventListener HTMLAnchorElement MouseEvent
-> HTMLUListElement
-> Element
-> m ()
addMenu Document
doc SaferEventListener HTMLAnchorElement MouseEvent
clickListener HTMLUListElement
parentMenu = Element -> m ()
forall {m :: * -> *}. MonadJSM m => Element -> m ()
loop
      where
        loop :: Element -> m ()
loop Element
e = do
            Element -> m (Maybe [(String, SrcLoc)])
forall (m :: * -> *).
MonadDOM m =>
Element -> m (Maybe [(String, SrcLoc)])
getElementStack Element
e m (Maybe [(String, SrcLoc)])
-> (Maybe [(String, SrcLoc)] -> m ()) -> m ()
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ([(String, SrcLoc)] -> m ()) -> Maybe [(String, SrcLoc)] -> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Document
-> SaferEventListener HTMLAnchorElement MouseEvent
-> HTMLUListElement
-> Element
-> [(String, SrcLoc)]
-> m ()
forall (m :: * -> *).
MonadJSM m =>
Document
-> SaferEventListener HTMLAnchorElement MouseEvent
-> HTMLUListElement
-> Element
-> [(String, SrcLoc)]
-> m ()
addElementMenu Document
doc SaferEventListener HTMLAnchorElement MouseEvent
clickListener HTMLUListElement
parentMenu Element
e)
            Element -> m (Maybe Element)
forall (m :: * -> *) self.
(MonadDOM m, IsNode self) =>
self -> m (Maybe Element)
getParentElement Element
e m (Maybe Element) -> (Maybe Element -> m ()) -> m ()
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (Element -> m ()) -> Maybe Element -> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Element -> m ()
loop

    addElementMenu
        :: MonadJSM m
        => Document
        -> SaferEventListener HTMLAnchorElement MouseEvent
        -> HTMLUListElement
        -> Element
        -> [(String, SrcLoc)]
        -> m ()
    addElementMenu :: forall (m :: * -> *).
MonadJSM m =>
Document
-> SaferEventListener HTMLAnchorElement MouseEvent
-> HTMLUListElement
-> Element
-> [(String, SrcLoc)]
-> m ()
addElementMenu Document
doc SaferEventListener HTMLAnchorElement MouseEvent
clickListener HTMLUListElement
parentMenu Element
e [(String, SrcLoc)]
cs = do
        String
tagName <- (Char -> Char) -> String -> String
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower (String -> String) -> m String -> m String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Element -> m String
forall (m :: * -> *) self result.
(MonadDOM m, IsElement self, FromJSString result) =>
self -> m result
getTagName Element
e
        Element
parentLi <- Document -> JSString -> m Element
forall (m :: * -> *) self localName.
(MonadDOM m, IsDocument self, ToJSString localName) =>
self -> localName -> m Element
createElement Document
doc (JSString
"li" :: JSString)
        HTMLUListElement -> Element -> m ()
forall (m :: * -> *) self node.
(MonadDOM m, IsNode self, IsNode node) =>
self -> node -> m ()
appendChild_ HTMLUListElement
parentMenu Element
parentLi
        Document -> String -> m Text
forall (m :: * -> *) self data'.
(MonadDOM m, IsDocument self, ToJSString data') =>
self -> data' -> m Text
createTextNode Document
doc String
tagName m Text -> (Text -> m ()) -> m ()
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Element -> Text -> m ()
forall (m :: * -> *) self node.
(MonadDOM m, IsNode self, IsNode node) =>
self -> node -> m ()
appendChild_ Element
parentLi
        Element
ul <- Document -> JSString -> m Element
forall (m :: * -> *) self localName.
(MonadDOM m, IsDocument self, ToJSString localName) =>
self -> localName -> m Element
createElement Document
doc (JSString
"ul" :: JSString)
        Element -> Element -> m ()
forall (m :: * -> *) self node.
(MonadDOM m, IsNode self, IsNode node) =>
self -> node -> m ()
appendChild_ Element
parentLi Element
ul
        [(String, SrcLoc)] -> ((String, SrcLoc) -> m ()) -> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ ([(String, SrcLoc)] -> [(String, SrcLoc)]
forall a. [a] -> [a]
reverse [(String, SrcLoc)]
cs) (((String, SrcLoc) -> m ()) -> m ())
-> ((String, SrcLoc) -> m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ \(String
f, SrcLoc
loc) -> do
            Element
li <- Document -> JSString -> m Element
forall (m :: * -> *) self localName.
(MonadDOM m, IsDocument self, ToJSString localName) =>
self -> localName -> m Element
createElement Document
doc (JSString
"li" :: JSString)
            Element -> Element -> m ()
forall (m :: * -> *) self node.
(MonadDOM m, IsNode self, IsNode node) =>
self -> node -> m ()
appendChild_ Element
ul Element
li
            HTMLAnchorElement
a <- (JSVal -> HTMLAnchorElement) -> Element -> HTMLAnchorElement
forall obj obj'.
(Coercible obj JSVal, IsGObject obj') =>
(JSVal -> obj') -> obj -> obj'
uncheckedCastTo JSVal -> HTMLAnchorElement
HTMLAnchorElement (Element -> HTMLAnchorElement) -> m Element -> m HTMLAnchorElement
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Document -> JSString -> m Element
forall (m :: * -> *) self localName.
(MonadDOM m, IsDocument self, ToJSString localName) =>
self -> localName -> m Element
createElement Document
doc (JSString
"a" :: JSString)
            Element -> HTMLAnchorElement -> m ()
forall (m :: * -> *) self node.
(MonadDOM m, IsNode self, IsNode node) =>
self -> node -> m ()
appendChild_ Element
li HTMLAnchorElement
a
            Document -> String -> m Text
forall (m :: * -> *) self data'.
(MonadDOM m, IsDocument self, ToJSString data') =>
self -> data' -> m Text
createTextNode Document
doc (String
f String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> SrcLoc -> String
srcLocFile SrcLoc
loc String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
":" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show (SrcLoc -> Int
srcLocStartLine SrcLoc
loc))
                m Text -> (Text -> m ()) -> m ()
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= HTMLAnchorElement -> Text -> m ()
forall (m :: * -> *) self node.
(MonadDOM m, IsNode self, IsNode node) =>
self -> node -> m ()
appendChild_ HTMLAnchorElement
a
            Maybe String -> (String -> m ()) -> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (SrcLoc -> Maybe String
getSourceLink SrcLoc
loc) ((String -> m ()) -> m ()) -> (String -> m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ \String
link -> do
                HTMLAnchorElement -> JSString -> String -> m ()
forall (m :: * -> *) self qualifiedName value.
(MonadDOM m, IsElement self, ToJSString qualifiedName,
 ToJSString value) =>
self -> qualifiedName -> value -> m ()
setAttribute HTMLAnchorElement
a (JSString
"href" :: JSString) String
link
                HTMLAnchorElement -> JSString -> JSString -> m ()
forall (m :: * -> *) self qualifiedName value.
(MonadDOM m, IsElement self, ToJSString qualifiedName,
 ToJSString value) =>
self -> qualifiedName -> value -> m ()
setAttribute HTMLAnchorElement
a (JSString
"target" :: JSString) (JSString
"_blank" :: JSString)
            HTMLAnchorElement -> JSString -> String -> m ()
forall (m :: * -> *) self qualifiedName value.
(MonadDOM m, IsElement self, ToJSString qualifiedName,
 ToJSString value) =>
self -> qualifiedName -> value -> m ()
setAttribute HTMLAnchorElement
a (JSString
"hs-srcloc" :: JSString) (String -> m ()) -> String -> m ()
forall a b. (a -> b) -> a -> b
$ SrcLoc -> String
prettySrcLoc SrcLoc
loc
            JSM () -> m ()
forall (m :: * -> *) a. MonadJSM m => JSM a -> m a
liftJSM (JSM () -> m ()) -> JSM () -> m ()
forall a b. (a -> b) -> a -> b
$ HTMLAnchorElement
-> EventName HTMLAnchorElement MouseEvent
-> SaferEventListener HTMLAnchorElement MouseEvent
-> Bool
-> JSM ()
forall t e.
(IsEventTarget t, IsEvent e) =>
t -> EventName t e -> SaferEventListener t e -> Bool -> JSM ()
addListener HTMLAnchorElement
a EventName HTMLAnchorElement MouseEvent
forall self.
(IsGlobalEventHandlers self, IsEventTarget self) =>
EventName self MouseEvent
click SaferEventListener HTMLAnchorElement MouseEvent
clickListener Bool
False

    prettySrcLoc :: SrcLoc -> String
    prettySrcLoc :: SrcLoc -> String
prettySrcLoc SrcLoc {Int
String
srcLocStartLine :: SrcLoc -> Int
srcLocFile :: SrcLoc -> String
srcLocPackage :: String
srcLocModule :: String
srcLocFile :: String
srcLocStartLine :: Int
srcLocStartCol :: Int
srcLocEndLine :: Int
srcLocEndCol :: Int
srcLocPackage :: SrcLoc -> String
srcLocModule :: SrcLoc -> String
srcLocStartCol :: SrcLoc -> Int
srcLocEndLine :: SrcLoc -> Int
srcLocEndCol :: SrcLoc -> Int
..} = [String] -> String
forall a. Monoid a => [a] -> a
mconcat
        [ String
srcLocFile          , String
":("
        , Int -> String
forall a. Show a => a -> String
show Int
srcLocStartLine, String
","
        , Int -> String
forall a. Show a => a -> String
show Int
srcLocStartCol , String
")-("
        , Int -> String
forall a. Show a => a -> String
show Int
srcLocEndLine  , String
","
        , Int -> String
forall a. Show a => a -> String
show Int
srcLocEndCol   , String
") in "
        , String
srcLocPackage, String
":", String
srcLocModule
        ]