Document.hs

{-# LANGUAGE CPP #-}
{-# LANGUAGE PackageImports #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ConstraintKinds #-}
module GHCJS.DOM.Document (
    module Export
  , createElement
  , createElement_
  , createElementNS
  , createElementNS_
) where

#ifdef GHCJS_DOM_DEBUG

import Control.Monad (void)
import Control.Monad.IO.Class (MonadIO, liftIO)
import Data.IORef (atomicModifyIORef', IORef, newIORef, readIORef)
import GHC.Stack
       (SrcLoc, CallStack, callStack, getCallStack, HasCallStack)
import System.IO.Unsafe (unsafePerformIO)
import Text.Read (readMaybe)

import GHCJS.DOM.Types (Element(..), MonadDOM, ToJSString, JSString)
import GHCJS.DOM.Debug.Internal (cacheStack)
import GHCJS.DOM.Element (setAttribute, getAttribute)
#ifdef MIN_VERSION_ghcjs_dom_jsffi
import qualified "ghcjs-dom-jsffi" GHCJS.DOM.Document as Raw (createElement, createElement_, createElementNS, createElementNS_)
import "ghcjs-dom-jsffi" GHCJS.DOM.Document as Export hiding (createElement, createElement_, createElementNS, createElementNS_)
#else
import qualified "jsaddle-dom" GHCJS.DOM.Document as Raw (createElement, createElement_, createElementNS, createElementNS_)
import "jsaddle-dom" GHCJS.DOM.Document as Export hiding (createElement, createElement_, createElementNS, createElementNS_)
#endif


createElement
    :: (MonadDOM m, IsDocument doc, ToJSString localName, HasCallStack)
    => doc
    -> localName
    -> m Element
createElement doc localName = do
    e <- Raw.createElement doc localName
    let cs = getCallStack callStack
    setAttribute e ("hs-creator"::JSString) . show =<< cacheStack cs
    return e

createElement_
    :: (MonadDOM m, IsDocument doc, ToJSString localName, HasCallStack)
    => doc
    -> localName
    -> m ()
createElement_ doc localName = void $ createElement doc localName

createElementNS
    :: (MonadDOM m, IsDocument doc, ToJSString namespaceURI, ToJSString qualifiedName, HasCallStack)
    => doc
    -> Maybe namespaceURI
    -> qualifiedName
    -> m Element
createElementNS doc namespaceURI qualifiedName = do
    e <- Raw.createElementNS doc namespaceURI qualifiedName
    setAttribute e ("haskell-stack"::JSString) . show =<< cacheStack (getCallStack callStack)
    return e

createElementNS_
    :: (MonadDOM m, IsDocument doc, ToJSString namespaceURI, ToJSString qualifiedName, HasCallStack)
    => doc
    -> Maybe namespaceURI
    -> qualifiedName
    -> m ()
createElementNS_ doc namespaceURI qualifiedName = void $ createElementNS doc namespaceURI qualifiedName

#else

#ifdef MIN_VERSION_ghcjs_dom_jsffi
import "ghcjs-dom-jsffi" GHCJS.DOM.Document (createElement, createElement_, createElementNS, createElementNS_)
import "ghcjs-dom-jsffi" GHCJS.DOM.Document as Export hiding (createElement, createElement_, createElementNS, createElementNS_)
#else
import "jsaddle-dom" GHCJS.DOM.Document (createElement, createElement_, createElementNS, createElementNS_)
import "jsaddle-dom" GHCJS.DOM.Document as Export hiding (createElement, createElement_, createElementNS, createElementNS_)
#endif

#endif