{-# LANGUAGE CPP #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE KindSignatures #-}
module GHCJS.DOM.Debug.Internal (
    DomHasCallStack
  , debugEnabled
  , cachedStacks
  , cacheStack
  , lookupStack
  , getElementStack
) where

import Control.Monad (void)
import Control.Monad.IO.Class (MonadIO, liftIO)
import Data.Map (Map)
import qualified Data.Map as M (insert, size, lookup)
import Data.IORef (atomicModifyIORef', IORef, newIORef, readIORef)
import GHC.Stack
       (SrcLoc, CallStack, callStack, getCallStack, HasCallStack)
import GHC.Exts (Constraint)
import System.IO.Unsafe (unsafePerformIO)
import Text.Read (readMaybe)

import GHCJS.DOM.Types (Element(..), MonadDOM, ToJSString, JSString)
import GHCJS.DOM.Element (setAttribute, getAttribute)

#ifdef GHCJS_DOM_DEBUG

type DomHasCallStack = (HasCallStack :: Constraint)
debugEnabled :: Bool
debugEnabled = True

#else

type DomHasCallStack = (() :: Constraint)

debugEnabled :: Bool
debugEnabled :: Bool
debugEnabled = Bool
False

#endif

cachedStacks :: IORef (Map String Int, Map Int [(String, SrcLoc)])
cachedStacks :: IORef (Map String Int, Map Int [(String, SrcLoc)])
cachedStacks = IO (IORef (Map String Int, Map Int [(String, SrcLoc)]))
-> IORef (Map String Int, Map Int [(String, SrcLoc)])
forall a. IO a -> a
unsafePerformIO (IO (IORef (Map String Int, Map Int [(String, SrcLoc)]))
 -> IORef (Map String Int, Map Int [(String, SrcLoc)]))
-> IO (IORef (Map String Int, Map Int [(String, SrcLoc)]))
-> IORef (Map String Int, Map Int [(String, SrcLoc)])
forall a b. (a -> b) -> a -> b
$ (Map String Int, Map Int [(String, SrcLoc)])
-> IO (IORef (Map String Int, Map Int [(String, SrcLoc)]))
forall a. a -> IO (IORef a)
newIORef (Map String Int
forall a. Monoid a => a
mempty, Map Int [(String, SrcLoc)]
forall a. Monoid a => a
mempty)
{-# NOINLINE cachedStacks #-}

lookupStack :: MonadIO m => Int -> m (Maybe [(String, SrcLoc)])
lookupStack :: Int -> m (Maybe [(String, SrcLoc)])
lookupStack Int
n = do
    (Map String Int
_, Map Int [(String, SrcLoc)]
intToStack) <- IO (Map String Int, Map Int [(String, SrcLoc)])
-> m (Map String Int, Map Int [(String, SrcLoc)])
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Map String Int, Map Int [(String, SrcLoc)])
 -> m (Map String Int, Map Int [(String, SrcLoc)]))
-> IO (Map String Int, Map Int [(String, SrcLoc)])
-> m (Map String Int, Map Int [(String, SrcLoc)])
forall a b. (a -> b) -> a -> b
$ IORef (Map String Int, Map Int [(String, SrcLoc)])
-> IO (Map String Int, Map Int [(String, SrcLoc)])
forall a. IORef a -> IO a
readIORef IORef (Map String Int, Map Int [(String, SrcLoc)])
cachedStacks
    Maybe [(String, SrcLoc)] -> m (Maybe [(String, SrcLoc)])
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe [(String, SrcLoc)] -> m (Maybe [(String, SrcLoc)]))
-> Maybe [(String, SrcLoc)] -> m (Maybe [(String, SrcLoc)])
forall a b. (a -> b) -> a -> b
$ Int -> Map Int [(String, SrcLoc)] -> Maybe [(String, SrcLoc)]
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Int
n Map Int [(String, SrcLoc)]
intToStack

getElementStack :: MonadDOM m => Element -> m (Maybe [(String, SrcLoc)])
getElementStack :: Element -> m (Maybe [(String, SrcLoc)])
getElementStack Element
e =
    Element -> JSString -> m (Maybe String)
forall (m :: * -> *) self qualifiedName result.
(MonadDOM m, IsElement self, ToJSString qualifiedName,
 FromJSString result) =>
self -> qualifiedName -> m (Maybe result)
getAttribute Element
e (JSString
"hs-creator" :: JSString) m (Maybe String)
-> (Maybe String -> m (Maybe [(String, SrcLoc)]))
-> m (Maybe [(String, SrcLoc)])
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Just String
a -> case String -> Maybe Int
forall a. Read a => String -> Maybe a
readMaybe String
a of
            Just Int
n -> Int -> m (Maybe [(String, SrcLoc)])
forall (m :: * -> *).
MonadIO m =>
Int -> m (Maybe [(String, SrcLoc)])
lookupStack Int
n
            Maybe Int
Nothing -> Maybe [(String, SrcLoc)] -> m (Maybe [(String, SrcLoc)])
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe [(String, SrcLoc)]
forall a. Maybe a
Nothing
        Maybe String
Nothing -> Maybe [(String, SrcLoc)] -> m (Maybe [(String, SrcLoc)])
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe [(String, SrcLoc)]
forall a. Maybe a
Nothing

cacheStack :: MonadIO m => [(String, SrcLoc)] -> m Int
cacheStack :: [(String, SrcLoc)] -> m Int
cacheStack [(String, SrcLoc)]
cs = do
    let csString :: String
csString = [(String, SrcLoc)] -> String
forall a. Show a => a -> String
show [(String, SrcLoc)]
cs
    IO Int -> m Int
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Int -> m Int) -> IO Int -> m Int
forall a b. (a -> b) -> a -> b
$ IORef (Map String Int, Map Int [(String, SrcLoc)])
-> ((Map String Int, Map Int [(String, SrcLoc)])
    -> ((Map String Int, Map Int [(String, SrcLoc)]), Int))
-> IO Int
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef (Map String Int, Map Int [(String, SrcLoc)])
cachedStacks (((Map String Int, Map Int [(String, SrcLoc)])
  -> ((Map String Int, Map Int [(String, SrcLoc)]), Int))
 -> IO Int)
-> ((Map String Int, Map Int [(String, SrcLoc)])
    -> ((Map String Int, Map Int [(String, SrcLoc)]), Int))
-> IO Int
forall a b. (a -> b) -> a -> b
$ \(Map String Int
stackToInt, Map Int [(String, SrcLoc)]
intToStack) ->
        case String -> Map String Int -> Maybe Int
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup String
csString Map String Int
stackToInt of
            Just Int
n -> ((Map String Int
stackToInt, Map Int [(String, SrcLoc)]
intToStack), Int
n)
            Maybe Int
Nothing ->
                let n :: Int
n = Map String Int -> Int
forall k a. Map k a -> Int
M.size Map String Int
stackToInt in
                ((String -> Int -> Map String Int -> Map String Int
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert String
csString Int
n Map String Int
stackToInt, Int
-> [(String, SrcLoc)]
-> Map Int [(String, SrcLoc)]
-> Map Int [(String, SrcLoc)]
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert Int
n [(String, SrcLoc)]
cs Map Int [(String, SrcLoc)]
intToStack), Int
n)