@@ -21,7 +21,7 @@ import Control.Monad.Reader hiding (mapM, mapM_, forM, forM_, sequence, sequence
2121import Control.Monad.State hiding (state, mapM, mapM_, forM, forM_, sequence, sequence_)
2222import GHCJS.DOM.Node
2323import GHCJS.DOM.UIEvent
24−import GHCJS.DOM.EventM (event, EventM)
24+import GHCJS.DOM.EventM (event, EventM, stopPropagation)
2525import GHCJS.DOM.Document
2626import GHCJS.DOM.Element
2727import GHCJS.DOM.HTMLElement
@@ -35,11 +35,24 @@ import Data.GADT.Compare.TH
3535import Data.Bitraversable
3636import GHCJS.DOM.MouseEvent
3737import Data.IORef
38+import Data.Default
3839
3940type AttributeMap = Map String String
4041
42+data ElConfig attrs
43+ = ElConfig { _elConfig_namespace :: Maybe String
44+ , _elConfig_attributes :: attrs
45+ }
46+
47+makeLenses ''ElConfig
48+
49+instance (attrs ~ Map String String) => Default (ElConfig attrs) where
50+ def = ElConfig { _elConfig_namespace = Nothing
51+ , _elConfig_attributes = Map.empty
52+ }
53+
4154data El t
42− = El { _el_element :: HTMLElement
55+ = El { _el_element :: Element
4356 , _el_events :: EventSelector t (WrapArg EventResult EventName)
4457 }
4558
@@ -59,22 +72,30 @@ instance MonadWidget t m => Attributes m (Dynamic t AttributeMap) where
5972 forM_ (Set.toList $ oldAttrs `Set.difference` Map.keysSet newAttrs) $ elementRemoveAttribute e
6073 imapM_ (elementSetAttribute e) newAttrs --TODO: avoid re-setting unchanged attributes; possibly do the compare using Align in haskell
6174
62−buildEmptyElement :: (MonadWidget t m, Attributes m attrs) => String -> attrs -> m HTMLElement
63−buildEmptyElement elementTag attrs = do
75+buildEmptyElementNS :: (MonadWidget t m, Attributes m attrs) => Maybe String -> String -> attrs -> m Element
76+buildEmptyElementNS mns elementTag attrs = do
6477 doc <- askDocument
6578 p <- askParent
66− Just e <- liftIO $ documentCreateElement doc elementTag
79+ Just e <- liftIO $ case mns of
80+ Nothing -> documentCreateElement doc elementTag
81+ Just ns -> documentCreateElementNS doc ns elementTag
6782 addAttributes attrs e
6883 _ <- liftIO $ nodeAppendChild p $ Just e
69− return $ castToHTMLElement e
84+ return $ castToElement e
85+
86+buildEmptyElement :: (MonadWidget t m, Attributes m attrs) => String -> attrs -> m Element
87+buildEmptyElement = buildEmptyElementNS Nothing
7088
7189-- We need to decide what type of attrs we've got statically, because it will often be a recursively defined value, in which case inspecting it will lead to a cycle
72−buildElement :: (MonadWidget t m, Attributes m attrs) => String -> attrs -> m a -> m (HTMLElement, a)
73−buildElement elementTag attrs child = do
74− e <- buildEmptyElement elementTag attrs
90+buildElementNS :: (MonadWidget t m, Attributes m attrs) => Maybe String -> String -> attrs -> m a -> m (Element, a)
91+buildElementNS mns elementTag attrs child = do
92+ e <- buildEmptyElementNS mns elementTag attrs
7593 result <- subWidget (toNode e) child
7694 return (e, result)
7795
96+buildElement :: (MonadWidget t m, Attributes m attrs) => String -> attrs -> m a -> m (Element, a)
97+buildElement = buildElementNS Nothing
98+
7899namedNodeMapGetNames :: IsNamedNodeMap self => self -> IO (Set String)
79100namedNodeMapGetNames self = do
80101 l <- namedNodeMapGetLength self
@@ -564,7 +585,7 @@ getKeyEvent = do
564585getMouseEventCoords :: EventM MouseEvent e (Int, Int)
565586getMouseEventCoords = do
566587 e <- event
567− liftIO $ bisequence (mouseEventGetX e, mouseEventGetY e)
588+ liftIO $ bisequence (mouseEventGetClientX e, mouseEventGetClientY e)
568589
569590defaultDomEventHandler :: IsElement e => e -> EventName en -> EventM (EventType en) e (Maybe (EventResult en))
570591defaultDomEventHandler e evt = liftM (Just . EventResult) $ case evt of
@@ -590,46 +611,74 @@ defaultDomEventHandler e evt = liftM (Just . EventResult) $ case evt of
590611 Dragstart -> return ()
591612 Drop -> return ()
592613
593−wrapElement :: forall t h m. (Functor (Event t), MonadIO m, MonadSample t m, MonadReflexCreateTrigger t m, Reflex t, HasPostGui t h m) => HTMLElement -> m (El t)
594−wrapElement e = do
595− es <- wrapDomEventsMaybe e $ defaultDomEventHandler e
614+wrapElement :: forall t h m. (Functor (Event t), MonadIO m, MonadSample t m, MonadReflexCreateTrigger t m, Reflex t, HasPostGui t h m) => (forall en. Element -> EventName en -> EventM (EventType en) Element (Maybe (EventResult en))) -> Element -> m (El t)
615+wrapElement eh e = do
616+ es <- wrapDomEventsMaybe e $ eh e
596617 return $ El e es
597618
598−elDynAttr' :: forall t m a. MonadWidget t m => String -> Dynamic t (Map String String) -> m a -> m (El t, a)
599−elDynAttr' elementTag attrs child = do
600− (e, result) <- buildElement elementTag attrs child
601− e' <- wrapElement e
619+{-# INLINABLE elStopPropagationNS #-}
620+elStopPropagationNS :: (MonadWidget t m, IsEvent (EventType en)) => Maybe String -> String -> EventName en -> m a -> m a
621+elStopPropagationNS mns elementTag evt child = do
622+ (e, result) <- buildElementNS mns elementTag (Map.empty :: Map String String) child
623+ liftIO $ onEventName evt e stopPropagation
624+ return result
625+
626+{-# INLINABLE elWith #-}
627+elWith :: (MonadWidget t m, Attributes m attrs) => String -> ElConfig attrs -> m a -> m a
628+elWith elementTag cfg child = do
629+ (_, result) <- buildElementNS (cfg ^. namespace) elementTag (cfg ^. attributes) child
630+ return result
631+
632+{-# INLINABLE elWith' #-}
633+elWith' :: (MonadWidget t m, Attributes m attrs) => String -> ElConfig attrs -> m a -> m (El t, a)
634+elWith' elementTag cfg child = do
635+ (e, result) <- buildElementNS (cfg ^. namespace) elementTag (cfg ^. attributes) child
636+ e' <- wrapElement defaultDomEventHandler e
602637 return (e', result)
603638
639+{-# INLINABLE emptyElWith #-}
640+emptyElWith :: (MonadWidget t m, Attributes m attrs) => String -> ElConfig attrs -> m ()
641+emptyElWith elementTag cfg = do
642+ _ <- buildEmptyElementNS (cfg ^. namespace) elementTag (cfg ^. attributes)
643+ return ()
644+
645+{-# INLINABLE emptyElWith' #-}
646+emptyElWith' :: (MonadWidget t m, Attributes m attrs) => String -> ElConfig attrs -> m (El t)
647+emptyElWith' elementTag cfg = do
648+ wrapElement defaultDomEventHandler =<< buildEmptyElementNS (cfg ^. namespace) elementTag (cfg ^. attributes)
649+
650+{-# INLINABLE elDynAttrNS' #-}
651+elDynAttrNS' :: forall t m a. MonadWidget t m => Maybe String -> String -> Dynamic t (Map String String) -> m a -> m (El t, a)
652+elDynAttrNS' mns elementTag attrs = elWith' elementTag $
653+ def & namespace .~ mns
654+ & attributes .~ attrs
655+
656+{-# INLINABLE elDynAttr' #-}
657+elDynAttr' :: forall t m a. MonadWidget t m => String -> Dynamic t (Map String String) -> m a -> m (El t, a)
658+elDynAttr' elementTag attrs = elWith' elementTag $ def & attributes .~ attrs
659+
604660{-# INLINABLE elAttr #-}
605661elAttr :: forall t m a. MonadWidget t m => String -> Map String String -> m a -> m a
606−elAttr elementTag attrs child = do
607− (_, result) <- buildElement elementTag attrs child
608− return result
662+elAttr elementTag attrs = elWith elementTag $ def & attributes .~ attrs
609663
610664{-# INLINABLE el' #-}
611665el' :: forall t m a. MonadWidget t m => String -> m a -> m (El t, a)
612−el' elementTag child = elAttr' elementTag (Map.empty :: AttributeMap) child
666+el' elementTag = elWith' elementTag def
613667
614668{-# INLINABLE elAttr' #-}
615669elAttr' :: forall t m a. MonadWidget t m => String -> Map String String -> m a -> m (El t, a)
616−elAttr' elementTag attrs child = do
617− (e, result) <- buildElement elementTag attrs child
618− e' <- wrapElement e
619− return (e', result)
670+elAttr' elementTag attrs = elWith' elementTag $ def & attributes .~ attrs
620671
621672{-# INLINABLE elDynAttr #-}
622673elDynAttr :: forall t m a. MonadWidget t m => String -> Dynamic t (Map String String) -> m a -> m a
623−elDynAttr elementTag attrs child = do
624− (_, result) <- buildElement elementTag attrs child
625− return result
674+elDynAttr elementTag attrs = elWith elementTag $ def & attributes .~ attrs
626675
627676{-# INLINABLE el #-}
628677el :: forall t m a. MonadWidget t m => String -> m a -> m a
629−el elementTag child = elAttr elementTag Map.empty child
678+el elementTag = elWith elementTag def
630679
631680elClass :: forall t m a. MonadWidget t m => String -> String -> m a -> m a
632−elClass elementTag c child = elAttr elementTag ("class" =: c) child
681+elClass elementTag c = elWith elementTag $ def & attributes .~ "class" =: c
633682
634683--------------------------------------------------------------------------------
635684-- Copied and pasted from Reflex.Widget.Class
@@ -647,22 +696,36 @@ simpleList xs mkChild = mapDyn (map snd . Map.toList) =<< flip list mkChild =<<
647696elDynHtml' :: MonadWidget t m => String -> Dynamic t String -> m (El t)
648697elDynHtml' elementTag html = do
649698 e <- buildEmptyElement elementTag (Map.empty :: Map String String)
650− schedulePostBuild $ liftIO . htmlElementSetInnerHTML e =<< sample (current html)
651− addVoidAction $ fmap (liftIO . htmlElementSetInnerHTML e) $ updated html
652− wrapElement e
699+ let h = castToHTMLElement e
700+ schedulePostBuild $ liftIO . htmlElementSetInnerHTML h =<< sample (current html)
701+ addVoidAction $ fmap (liftIO . htmlElementSetInnerHTML h) $ updated html
702+ wrapElement defaultDomEventHandler e
653703
654704elDynHtmlAttr' :: MonadWidget t m => String -> Map String String -> Dynamic t String -> m (El t)
655705elDynHtmlAttr' elementTag attrs html = do
656706 e <- buildEmptyElement elementTag attrs
657− schedulePostBuild $ liftIO . htmlElementSetInnerHTML e =<< sample (current html)
658− addVoidAction $ fmap (liftIO . htmlElementSetInnerHTML e) $ updated html
659− wrapElement e
707+ let h = castToHTMLElement e
708+ schedulePostBuild $ liftIO . htmlElementSetInnerHTML h =<< sample (current html)
709+ addVoidAction $ fmap (liftIO . htmlElementSetInnerHTML h) $ updated html
710+ wrapElement defaultDomEventHandler e
660711
661712data Link t
662713 = Link { _link_clicked :: Event t ()
663714 }
664715
665−class HasDomEvent t a | a -> t where
716+class HasAttributes s t a b | s -> a, t -> b, s b -> t, t a -> s where
717+ attributes :: Lens s t a b
718+
719+instance HasAttributes (ElConfig attrs) (ElConfig attrs') attrs attrs' where
720+ attributes = elConfig_attributes
721+
722+class HasNamespace a where
723+ namespace :: Lens' a (Maybe String)
724+
725+instance HasNamespace (ElConfig attrs) where
726+ namespace = elConfig_namespace
727+
728+class HasDomEvent t a where
666729 domEvent :: EventName en -> a -> Event t (EventResultType en)
667730
668731instance Reflex t => HasDomEvent t (El t) where
@@ -753,11 +816,11 @@ tabDisplay ulClass activeClass tabItems = do
753816 return $ fmap (const k) (_link_clicked a)
754817
755818-- | Place an element into the DOM and wrap it with Reflex event handlers. Note: undefined behavior may result if the element is placed multiple times, removed from the DOM after being placed, or in other situations. Don't use this unless you understand the internals of MonadWidget.
756−unsafePlaceElement :: MonadWidget t m => HTMLElement -> m (El t)
819+unsafePlaceElement :: MonadWidget t m => Element -> m (El t)
757820unsafePlaceElement e = do
758821 p <- askParent
759822 _ <- liftIO $ nodeAppendChild p $ Just e
760− wrapElement e
823+ wrapElement defaultDomEventHandler e
761824
762825deriveGEq ''EventName
763826deriveGCompare ''EventName