WIP: Show call stack of a node in DOM comments

reflex-dom-core/src/Reflex/Dom/Builder/Class.hs

@@ -60,6 +60,7 @@ import Data.Semigroup
 import Data.String
 import Data.Text (Text)
 import Data.Type.Coercion
+import GHC.Stack
 import GHCJS.DOM.Types (JSM)
 import qualified GHCJS.DOM.Types as DOM
 
@@ -96,8 +97,9 @@ class (Monad m, Reflex t, DomSpace (DomBuilderSpace m), NotReady t m, Adjustable
                    => CommentNodeConfig t -> m (CommentNode (DomBuilderSpace m) t)
   commentNode = lift . commentNode
   {-# INLINABLE commentNode #-}
-  element :: Text -> ElementConfig er t (DomBuilderSpace m) -> m a -> m (Element er (DomBuilderSpace m) t, a)
-  default element :: ( MonadTransControl f
+  element :: HasCallStack => Text -> ElementConfig er t (DomBuilderSpace m) -> m a -> m (Element er (DomBuilderSpace m) t, a)
+  default element :: ( HasCallStack
+                     , MonadTransControl f
                      , StT f a ~ a
                      , m ~ f m'
                      , DomBuilderSpace m' ~ DomBuilderSpace m

reflex-dom-core/src/Reflex/Dom/Builder/Static.hs

@@ -35,6 +35,7 @@ import Data.Functor.Compose
 import Data.Functor.Constant
 import Data.IntMap (IntMap)
 import qualified Data.IntMap as IntMap
+import Data.List (isPrefixOf)
 import qualified Data.Map as Map
 import Data.Map.Misc (applyMap)
 import Data.Monoid ((<>))
@@ -44,6 +45,7 @@ import qualified Data.Text as T
 import Data.Text.Encoding
 import Data.Tuple
 import GHC.Generics
+import GHC.Stack (CallStack, SrcLoc(..), callStack, fromCallSiteList, getCallStack, prettyCallStack)
 import Reflex.Adjustable.Class
 import Reflex.Class
 import Reflex.Dom.Main (DomHost, DomTimeline, runDomHost)
@@ -257,6 +259,18 @@ instance SupportsStaticDomBuilder t m => NotReady t (StaticDomBuilderT t m) wher
   notReadyUntil _ = pure ()
   notReady = pure ()
 
+prependCallStackComment :: DomBuilder t m => CallStack -> m a -> m a
+prependCallStackComment cs w = do
+  let
+    removeSelf :: [([Char], SrcLoc)] -> [([Char], SrcLoc)]
+    removeSelf = filter $ not . ("reflex-dom-core" `isPrefixOf`) . srcLocPackage . snd
+
+    editStack :: CallStack -> CallStack
+    editStack = fromCallSiteList . removeSelf . getCallStack
+
+  void $ commentNode $ def & commentNodeConfig_initialContents .~ T.pack (prettyCallStack $ editStack cs)
+  w
+
 -- TODO: the uses of illegal lenses in this instance causes it to be somewhat less efficient than it can be. replacing them with explicit cases to get the underlying Maybe Event and working with those is ideal.
 instance SupportsStaticDomBuilder t m => DomBuilder t (StaticDomBuilderT t m) where
   type DomBuilderSpace (StaticDomBuilderT t m) = StaticDomSpace
@@ -279,7 +293,7 @@ instance SupportsStaticDomBuilder t m => DomBuilder t (StaticDomBuilderT t m) wh
       Just setContents -> hold (escape initialContents) $ fmapCheap escape setContents --Only because it doesn't get optimized when profiling is on
     return $ CommentNode ()
   {-# INLINABLE element #-}
-  element elementTag cfg child = do
+  element elementTag cfg child = prependCallStackComment callStack $ do
     -- https://www.w3.org/TR/html-markup/syntax.html#syntax-elements
     let voidElements = Set.fromList ["area", "base", "br", "col", "command", "embed", "hr", "img", "input", "keygen", "link", "meta", "param", "source", "track", "wbr"]
     let noEscapeElements = Set.fromList ["style", "script"]

reflex-dom-core/src/Reflex/Dom/Widget/Basic.hs

@@ -90,6 +90,7 @@ import Data.These
 import Data.Traversable
 import Prelude hiding (mapM, mapM_, sequence, sequence_)
 
+import GHC.Stack
 -- | Breaks the given Map into pieces based on the given Set.  Each piece will contain only keys that are less than the key of the piece, and greater than or equal to the key of the piece with the next-smaller key.  There will be one additional piece containing all keys from the original Map that are larger or equal to the largest key in the Set.
 -- Either k () is used instead of Maybe k so that the resulting map of pieces is sorted so that the additional piece has the largest key.
 -- No empty pieces will be included in the output.
@@ -172,39 +173,39 @@ widgetHold_ z = void . widgetHold z
 -- >>> el "div" (text "Hello World")
 -- <div>Hello World</div>
 {-# INLINABLE el #-}
-el :: forall t m a. DomBuilder t m => Text -> m a -> m a
+el :: forall t m a. (HasCallStack, DomBuilder t m) => DomBuilder t m => Text -> m a -> m a
 el elementTag child = snd <$> el' elementTag child
 
 -- | Create a DOM element with attributes
 --
 -- >>> elAttr "a" ("href" =: "https://reflex-frp.org") (text "Reflex-FRP!")
 -- <a href="https://reflex-frp.org">Reflex-FRP!</a>
 {-# INLINABLE elAttr #-}
-elAttr :: forall t m a. DomBuilder t m => Text -> Map Text Text -> m a -> m a
+elAttr :: forall t m a. (HasCallStack, DomBuilder t m) => Text -> Map Text Text -> m a -> m a
 elAttr elementTag attrs child = snd <$> elAttr' elementTag attrs child
 
 -- | Create a DOM element with classes
 --
 -- >>> elClass "div" "row" (return ())
 -- <div class="row"></div>
 {-# INLINABLE elClass #-}
-elClass :: forall t m a. DomBuilder t m => Text -> Text -> m a -> m a
+elClass :: forall t m a. (HasCallStack, DomBuilder t m) => Text -> Text -> m a -> m a
 elClass elementTag c child = snd <$> elClass' elementTag c child
 
 -- | Create a DOM element with Dynamic Attributes
 --
 -- >>> elClass "div" (constDyn ("class" =: "row")) (return ())
 -- <div class="row"></div>
 {-# INLINABLE elDynAttr #-}
-elDynAttr :: forall t m a. (DomBuilder t m, PostBuild t m) => Text -> Dynamic t (Map Text Text) -> m a -> m a
+elDynAttr :: forall t m a. (HasCallStack, DomBuilder t m, PostBuild t m) => Text -> Dynamic t (Map Text Text) -> m a -> m a
 elDynAttr elementTag attrs child = snd <$> elDynAttr' elementTag attrs child
 
 -- | Create a DOM element with a Dynamic Class
 --
 -- >>> elDynClass "div" (constDyn "row") (return ())
 -- <div class="row"></div>
 {-# INLINABLE elDynClass #-}
-elDynClass :: forall t m a. (DomBuilder t m, PostBuild t m) => Text -> Dynamic t Text -> m a -> m a
+elDynClass :: forall t m a. (HasCallStack, DomBuilder t m, PostBuild t m) => Text -> Dynamic t Text -> m a -> m a
 elDynClass elementTag c child = snd <$> elDynClass' elementTag c child
 
 -- | Create a DOM element and return the element
@@ -214,32 +215,32 @@ elDynClass elementTag c child = snd <$> elDynClass' elementTag c child
 --     return $ domEvent Click e
 -- @
 {-# INLINABLE el' #-}
-el' :: forall t m a. DomBuilder t m => Text -> m a -> m (Element EventResult (DomBuilderSpace m) t, a)
+el' :: forall t m a. (HasCallStack, DomBuilder t m) => Text -> m a -> m (Element EventResult (DomBuilderSpace m) t, a)
 el' elementTag = element elementTag def
 
 -- | Create a DOM element with attributes and return the element
 {-# INLINABLE elAttr' #-}
-elAttr' :: forall t m a. DomBuilder t m => Text -> Map Text Text -> m a -> m (Element EventResult (DomBuilderSpace m) t, a)
+elAttr' :: forall t m a. (HasCallStack, DomBuilder t m) => Text -> Map Text Text -> m a -> m (Element EventResult (DomBuilderSpace m) t, a)
 elAttr' elementTag attrs = element elementTag $ def
   & initialAttributes .~ Map.mapKeys (AttributeName Nothing) attrs
 
 -- | Create a DOM element with a class and return the element
 {-# INLINABLE elClass' #-}
-elClass' :: forall t m a. DomBuilder t m => Text -> Text -> m a -> m (Element EventResult (DomBuilderSpace m) t, a)
+elClass' :: forall t m a. (HasCallStack, DomBuilder t m) => Text -> Text -> m a -> m (Element EventResult (DomBuilderSpace m) t, a)
 elClass' elementTag c = elAttr' elementTag ("class" =: c)
 
 -- | Create a DOM element with Dynamic Attributes and return the element
 {-# INLINABLE elDynAttr' #-}
-elDynAttr' :: forall t m a. (DomBuilder t m, PostBuild t m) => Text -> Dynamic t (Map Text Text) -> m a -> m (Element EventResult (DomBuilderSpace m) t, a)
+elDynAttr' :: forall t m a. (HasCallStack, DomBuilder t m, PostBuild t m) => Text -> Dynamic t (Map Text Text) -> m a -> m (Element EventResult (DomBuilderSpace m) t, a)
 elDynAttr' = elDynAttrNS' Nothing
 
 -- | Create a DOM element with a Dynamic class and return the element
 {-# INLINABLE elDynClass' #-}
-elDynClass' :: forall t m a. (DomBuilder t m, PostBuild t m) => Text -> Dynamic t Text -> m a -> m (Element EventResult (DomBuilderSpace m) t, a)
+elDynClass' :: forall t m a. (HasCallStack, DomBuilder t m, PostBuild t m) => Text -> Dynamic t Text -> m a -> m (Element EventResult (DomBuilderSpace m) t, a)
 elDynClass' elementTag c = elDynAttr' elementTag (fmap ("class" =:) c)
 
 {-# INLINABLE elDynAttrNS' #-}
-elDynAttrNS' :: forall t m a. (DomBuilder t m, PostBuild t m) => Maybe Text -> Text -> Dynamic t (Map Text Text) -> m a -> m (Element EventResult (DomBuilderSpace m) t, a)
+elDynAttrNS' :: forall t m a. (HasCallStack, DomBuilder t m, PostBuild t m) => Maybe Text -> Text -> Dynamic t (Map Text Text) -> m a -> m (Element EventResult (DomBuilderSpace m) t, a)
 elDynAttrNS' mns elementTag attrs child = do
   modifyAttrs <- dynamicAttributesToModifyAttributes attrs
   let cfg = def
@@ -251,7 +252,7 @@ elDynAttrNS' mns elementTag attrs child = do
   return result
 
 {-# INLINABLE elDynAttrNS #-}
-elDynAttrNS :: forall t m a. (DomBuilder t m, PostBuild t m) => Maybe Text -> Text -> Dynamic t (Map Text Text) -> m a -> m a
+elDynAttrNS :: forall t m a. (HasCallStack, DomBuilder t m, PostBuild t m) => Maybe Text -> Text -> Dynamic t (Map Text Text) -> m a -> m a
 elDynAttrNS mns elementTag attrs child = fmap snd $ elDynAttrNS' mns elementTag attrs child
 
 dynamicAttributesToModifyAttributes :: (Ord k, PostBuild t m) => Dynamic t (Map k Text) -> m (Event t (Map k (Maybe Text)))
@@ -287,7 +288,7 @@ linkClass s c = do
 link :: DomBuilder t m => Text -> m (Link t)
 link s = linkClass s ""
 
-divClass :: forall t m a. DomBuilder t m => Text -> m a -> m a
+divClass :: forall t m a. (HasCallStack, DomBuilder t m) => Text -> m a -> m a
 divClass = elClass "div"
 
 {-# DEPRECATED dtdd "Use an application specific widget generating function" #-}