Skip to content

Commit

Permalink
Add DomHasCallStack for ghcjs-dom debug feature
Browse files Browse the repository at this point in the history 
https://github.com/ghcjs/ghcjs-dom/blob/master/README.md#debug
  • Loading branch information
@hamishmack
hamishmack committed Jul 5, 2018
1 parent c800f5b commit f26d424
Show file tree
Hide file tree
Showing 5 changed files with 51 additions and 40 deletions.
2 changes: 1 addition & 1 deletion reflex-dom-core/reflex-dom-core.cabal
View file
Original file line number Diff line number Diff line change
Expand Up @@ -56,7 +56,7 @@ library
dependent-sum-template >= 0.0.0.4 && < 0.1,
directory >= 1.2 && < 1.4,
exception-transformers == 0.4.*,
ghcjs-dom >= 0.9.1.0 && < 0.10,
ghcjs-dom >= 0.9.4.0 && < 0.10,
jsaddle >=0.9.0.0 && <0.10,
-- keycode-0.2 has a bug on firefox
keycode >= 0.2.1 && < 0.3,
Expand Down
26 changes: 17 additions & 9 deletions reflex-dom-core/src/Reflex/Dom/Builder/Class.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -59,6 +59,7 @@ import Data.String
import Data.Text (Text)
import Data.Type.Coercion
import GHCJS.DOM.Types (JSM)
import GHCJS.DOM.Debug (DomHasCallStack)

class Default (EventSpec d EventResult) => DomSpace d where
type EventSpec d :: (EventTag -> *) -> *
Expand All @@ -74,68 +75,75 @@ class Default (EventSpec d EventResult) => DomSpace d where
-- dynamic DOM in the 'Reflex' timeline @t@
class (Monad m, Reflex t, DomSpace (DomBuilderSpace m), NotReady t m, Adjustable t m) => DomBuilder t m | m -> t where
type DomBuilderSpace m :: *
textNode :: TextNodeConfig t -> m (TextNode (DomBuilderSpace m) t)
textNode :: DomHasCallStack => TextNodeConfig t -> m (TextNode (DomBuilderSpace m) t)
default textNode :: ( MonadTrans f
, m ~ f m'
, DomBuilderSpace m' ~ DomBuilderSpace m
, DomBuilder t m'
, DomHasCallStack
)
=> TextNodeConfig t -> m (TextNode (DomBuilderSpace m) t)
textNode = lift . textNode
{-# INLINABLE textNode #-}
element :: Text -> ElementConfig er t (DomBuilderSpace m) -> m a -> m (Element er (DomBuilderSpace m) t, a)
element :: DomHasCallStack => Text -> ElementConfig er t (DomBuilderSpace m) -> m a -> m (Element er (DomBuilderSpace m) t, a)
default element :: ( MonadTransControl f
, StT f a ~ a
, m ~ f m'
, DomBuilderSpace m' ~ DomBuilderSpace m
, DomBuilder t m'
, DomHasCallStack
)
=> Text -> ElementConfig er t (DomBuilderSpace m) -> m a -> m (Element er (DomBuilderSpace m) t, a)
element t cfg child = liftWith $ \run -> element t cfg $ run child
{-# INLINABLE element #-}
inputElement :: InputElementConfig er t (DomBuilderSpace m) -> m (InputElement er (DomBuilderSpace m) t)
inputElement :: DomHasCallStack => InputElementConfig er t (DomBuilderSpace m) -> m (InputElement er (DomBuilderSpace m) t)
default inputElement :: ( MonadTransControl f
, m ~ f m'
, DomBuilderSpace m' ~ DomBuilderSpace m
, DomBuilder t m'
, DomHasCallStack
)
=> InputElementConfig er t (DomBuilderSpace m) -> m (InputElement er (DomBuilderSpace m) t)
inputElement = lift . inputElement
{-# INLINABLE inputElement #-}
textAreaElement :: TextAreaElementConfig er t (DomBuilderSpace m) -> m (TextAreaElement er (DomBuilderSpace m) t)
textAreaElement :: DomHasCallStack => TextAreaElementConfig er t (DomBuilderSpace m) -> m (TextAreaElement er (DomBuilderSpace m) t)
default textAreaElement :: ( MonadTransControl f
, m ~ f m'
, DomBuilderSpace m' ~ DomBuilderSpace m
, DomBuilder t m'
, DomHasCallStack
)
=> TextAreaElementConfig er t (DomBuilderSpace m) -> m (TextAreaElement er (DomBuilderSpace m) t)
textAreaElement = lift . textAreaElement
{-# INLINABLE textAreaElement #-}
selectElement :: SelectElementConfig er t (DomBuilderSpace m) -> m a -> m (SelectElement er (DomBuilderSpace m) t, a)
selectElement :: DomHasCallStack => SelectElementConfig er t (DomBuilderSpace m) -> m a -> m (SelectElement er (DomBuilderSpace m) t, a)
default selectElement :: ( MonadTransControl f
, StT f a ~ a
, m ~ f m'
, DomBuilderSpace m' ~ DomBuilderSpace m
, DomBuilder t m'
, DomHasCallStack
)
=> SelectElementConfig er t (DomBuilderSpace m) -> m a -> m (SelectElement er (DomBuilderSpace m) t, a)
selectElement cfg child = do
liftWith $ \run -> selectElement cfg $ run child
{-# INLINABLE selectElement #-}
placeRawElement :: RawElement (DomBuilderSpace m) -> m ()
placeRawElement :: DomHasCallStack => RawElement (DomBuilderSpace m) -> m ()
default placeRawElement :: ( MonadTrans f
, m ~ f m'
, DomBuilderSpace m' ~ DomBuilderSpace m
, DomBuilder t m'
, DomHasCallStack
)
=> RawElement (DomBuilderSpace m) -> m ()
placeRawElement = lift . placeRawElement
{-# INLINABLE placeRawElement #-}
wrapRawElement :: RawElement (DomBuilderSpace m) -> RawElementConfig er t (DomBuilderSpace m) -> m (Element er (DomBuilderSpace m) t)
wrapRawElement :: DomHasCallStack => RawElement (DomBuilderSpace m) -> RawElementConfig er t (DomBuilderSpace m) -> m (Element er (DomBuilderSpace m) t)
default wrapRawElement :: ( MonadTrans f
, m ~ f m'
, DomBuilderSpace m' ~ DomBuilderSpace m
, DomBuilder t m'
, DomHasCallStack
)
=> RawElement (DomBuilderSpace m) -> RawElementConfig er t (DomBuilderSpace m) -> m (Element er (DomBuilderSpace m) t)
wrapRawElement e cfg = lift $ wrapRawElement e $ cfg
Expand All @@ -145,8 +153,8 @@ class (Monad m, Reflex t, DomSpace (DomBuilderSpace m), NotReady t m, Adjustable

class DomBuilder t m => MountableDomBuilder t m where
type DomFragment m :: *
buildDomFragment :: m a -> m (DomFragment m, a)
mountDomFragment :: DomFragment m -> Event t (DomFragment m) -> m ()
buildDomFragment :: DomHasCallStack => m a -> m (DomFragment m, a)
mountDomFragment :: DomHasCallStack => DomFragment m -> Event t (DomFragment m) -> m ()

type Namespace = Text

Expand Down
3 changes: 2 additions & 1 deletion reflex-dom-core/src/Reflex/Dom/Builder/Immediate.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -135,6 +135,7 @@ import qualified Data.Some as Some
import Data.Text (Text)
import qualified Data.Text as T
import qualified GHCJS.DOM as DOM
import GHCJS.DOM.Debug (DomHasCallStack)
import GHCJS.DOM.RequestAnimationFrameCallback
import GHCJS.DOM.Document (Document, createDocumentFragment, createElement, createElementNS, createTextNode)
import GHCJS.DOM.Element (getScrollTop, removeAttribute, removeAttributeNS, setAttribute, setAttributeNS)
Expand Down Expand Up @@ -377,7 +378,7 @@ wrap e cfg = do
}

{-# INLINABLE makeElement #-}
makeElement :: forall er t m a. (MonadJSM m, MonadFix m, MonadReflexCreateTrigger t m, Adjustable t m) => Text -> ElementConfig er t GhcjsDomSpace -> ImmediateDomBuilderT t m a -> ImmediateDomBuilderT t m ((Element er GhcjsDomSpace t, a), DOM.Element)
makeElement :: forall er t m a. (MonadJSM m, MonadFix m, MonadReflexCreateTrigger t m, Adjustable t m, DomHasCallStack) => Text -> ElementConfig er t GhcjsDomSpace -> ImmediateDomBuilderT t m a -> ImmediateDomBuilderT t m ((Element er GhcjsDomSpace t, a), DOM.Element)
makeElement elementTag cfg child = do
doc <- askDocument
e <- liftJSM $ uncheckedCastTo DOM.Element <$> case cfg ^. namespace of
Expand Down
45 changes: 23 additions & 22 deletions reflex-dom-core/src/Reflex/Dom/Widget/Basic.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -68,6 +68,7 @@ import Reflex.Network
import Reflex.NotReady.Class
import Reflex.PostBuild.Class
import Reflex.Workflow
import GHCJS.DOM.Debug (DomHasCallStack)

import Control.Arrow
import Control.Lens hiding (children, element)
Expand Down Expand Up @@ -108,11 +109,11 @@ partitionMapBySetLT s m0 = Map.fromDistinctAscList $ go (Set.toAscList s) m0

newtype ChildResult t k a = ChildResult { unChildResult :: (a, Event t (Map k (Maybe (ChildResult t k a)))) }

text :: DomBuilder t m => Text -> m ()
text :: (DomBuilder t m, DomHasCallStack) => Text -> m ()
text t = void $ textNode $ def & textNodeConfig_initialContents .~ t

{-# INLINABLE dynText #-}
dynText :: forall t m. (PostBuild t m, DomBuilder t m) => Dynamic t Text -> m ()
dynText :: forall t m. (PostBuild t m, DomBuilder t m, DomHasCallStack) => Dynamic t Text -> m ()
dynText t = do
postBuild <- getPostBuild
void $ textNode $ (def :: TextNodeConfig t) & textNodeConfig_setContents .~ leftmost
Expand All @@ -121,10 +122,10 @@ dynText t = do
]
notReadyUntil postBuild

display :: (PostBuild t m, DomBuilder t m, Show a) => Dynamic t a -> m ()
display :: (PostBuild t m, DomBuilder t m, Show a, DomHasCallStack) => Dynamic t a -> m ()
display = dynText . fmap (T.pack . show)

button :: DomBuilder t m => Text -> m (Event t ())
button :: (DomBuilder t m, DomHasCallStack) => Text -> m (Event t ())
button t = do
(e, _) <- element "button" def $ text t
return $ domEvent Click e
Expand Down Expand Up @@ -154,67 +155,67 @@ 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. (DomBuilder t m, DomHasCallStack) => Text -> m a -> m a
el elementTag child = snd <$> el' elementTag child

-- | Create a DOM element with attributes
-- > elAttr "a" ("href" =: "http://google.com") (text "Google!")
-- <a href="http://google.com">Google!</a>
{-# INLINABLE elAttr #-}
elAttr :: forall t m a. DomBuilder t m => Text -> Map Text Text -> m a -> m a
elAttr :: forall t m a. (DomBuilder t m, DomHasCallStack) => 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. (DomBuilder t m, DomHasCallStack) => 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. (DomBuilder t m, PostBuild t m, DomHasCallStack) => 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. (DomBuilder t m, PostBuild t m, DomHasCallStack) => 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
-- > do (e, _) <- el' "div" (text "Click")
-- > 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. (DomBuilder t m, DomHasCallStack) => 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. (DomBuilder t m, DomHasCallStack) => 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. (DomBuilder t m, DomHasCallStack) => 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. (DomBuilder t m, PostBuild t m, DomHasCallStack) => 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. (DomBuilder t m, PostBuild t m, DomHasCallStack) => 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. (DomBuilder t m, PostBuild t m, DomHasCallStack) => 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
Expand All @@ -226,7 +227,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. (DomBuilder t m, PostBuild t m, DomHasCallStack) => 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)))
Expand Down Expand Up @@ -273,18 +274,18 @@ newtype Link t
= Link { _link_clicked :: Event t ()
}

linkClass :: DomBuilder t m => Text -> Text -> m (Link t)
linkClass :: (DomBuilder t m, DomHasCallStack) => Text -> Text -> m (Link t)
linkClass s c = do
(l,_) <- elAttr' "a" ("class" =: c) $ text s
return $ Link $ domEvent Click l

link :: DomBuilder t m => Text -> m (Link t)
link :: (DomBuilder t m, DomHasCallStack) => 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. (DomBuilder t m, DomHasCallStack) => Text -> m a -> m a
divClass = elClass "div"

dtdd :: forall t m a. DomBuilder t m => Text -> m a -> m a
dtdd :: forall t m a. (DomBuilder t m, DomHasCallStack) => Text -> m a -> m a
dtdd h w = do
el "dt" $ text h
el "dd" w
Expand All @@ -293,7 +294,7 @@ blank :: forall m. Monad m => m ()
blank = return ()

-- | A widget to display a table with static columns and dynamic rows.
tableDynAttr :: forall t m r k v. (Ord k, DomBuilder t m, MonadHold t m, PostBuild t m, MonadFix m)
tableDynAttr :: forall t m r k v. (Ord k, DomBuilder t m, MonadHold t m, PostBuild t m, MonadFix m, DomHasCallStack)
=> Text -- ^ Class applied to <table> element
-> [(Text, k -> Dynamic t r -> m v)] -- ^ Columns of (header, row key -> row value -> child widget)
-> Dynamic t (Map k r) -- ^ Map from row key to row value
Expand All @@ -311,7 +312,7 @@ tableDynAttr klass cols dRows rowAttrs = elAttr "div" (Map.singleton "style" "zo
-- | A widget to construct a tabbed view that shows only one of its child widgets at a time.
-- Creates a header bar containing a <ul> with one <li> per child; clicking a <li> displays
-- the corresponding child and hides all others.
tabDisplay :: forall t m k. (MonadFix m, DomBuilder t m, MonadHold t m, PostBuild t m, Ord k)
tabDisplay :: forall t m k. (MonadFix m, DomBuilder t m, MonadHold t m, PostBuild t m, Ord k, DomHasCallStack)
=> Text -- ^ Class applied to <ul> element
-> Text -- ^ Class applied to currently active <li> element
-> Map k (Text, m ()) -- ^ Map from (arbitrary) key to (tab label, child widget)
Expand Down
Loading

0 comments on commit f26d424

Please sign in to comment.