@@ -1,18 +1,36 @@
11{-# LANGUAGE ConstraintKinds #-}
22{-# LANGUAGE FlexibleContexts #-}
3+{-# LANGUAGE FlexibleInstances #-}
4+{-# LANGUAGE MultiParamTypeClasses #-}
35{-# LANGUAGE TypeFamilies #-}
4−module Reflex.Dom.Old where
6+{-# LANGUAGE UndecidableInstances #-}
7+module Reflex.Dom.Old
8+ ( MonadWidget
9+ , El
10+ , _el_element
11+ , addVoidAction
12+ , AttributeMap
13+ , Attributes (..)
14+ ) where
515
16+import Control.Arrow ((***))
17+import Control.Lens ((&), (.~))
618import Control.Monad.Exception
719import Control.Monad.Fix
820import Control.Monad.IO.Class
921import Control.Monad.Ref
22+import Data.Default
23+import Data.Map (Map)
24+import qualified Data.Map as Map
25+import qualified Data.Text as T
1026import Foreign.JavaScript.TH
27+import qualified GHCJS.DOM.Element as DOM
1128import Reflex
1229import Reflex.Dom.Builder.Class
1330import Reflex.Dom.Builder.Immediate
1431import Reflex.Dom.PerformEvent.Class
1532import Reflex.Dom.PostBuild.Class
33+import Reflex.Dom.Widget.Basic
1634import Reflex.Host.Class
1735
1836--TODO: HasDocument is still not accounted for
@@ -44,3 +62,32 @@ type El = Element EventResult GhcjsDomSpace
4462
4563_el_element :: El t -> RawElement GhcjsDomSpace
4664_el_element = _element_raw
65+
66+addVoidAction :: MonadWidget t m => Event t (WidgetHost m ()) -> m ()
67+addVoidAction = performEvent_
68+
69+type AttributeMap = Map String String
70+
71+class Attributes m attrs where
72+ buildElement :: String -> attrs -> m a -> m (DOM.Element, a)
73+
74+instance MonadWidget t m => Attributes m (Map String String) where
75+ buildElement elementTag attrs child = buildElementInternal elementTag child =<< addStaticAttributes attrs def
76+
77+addStaticAttributes :: Applicative m => Map String String -> ElementConfig er t m -> m (ElementConfig er t m)
78+addStaticAttributes attrs cfg = do
79+ let initialAttrs = Map.fromList $ fmap (((,) Nothing . T.pack) *** T.pack) $ Map.toList attrs
80+ pure $ cfg & elementConfig_initialAttributes .~ initialAttrs
81+
82+instance MonadWidget t m => Attributes m (Dynamic t (Map String String)) where
83+ buildElement elementTag attrs child = buildElementInternal elementTag child =<< addDynamicAttributes attrs def
84+
85+addDynamicAttributes :: PostBuild t m => Dynamic t (Map String String) -> ElementConfig er t m -> m (ElementConfig er t m)
86+addDynamicAttributes attrs cfg = do
87+ modifyAttrs <- dynamicAttributesToModifyAttributes $ fmap (Map.fromList . fmap (T.pack *** T.pack) . Map.toList) attrs
88+ return $ cfg & elementConfig_modifyAttributes .~ modifyAttrs
89+
90+buildElementInternal :: MonadWidget t m => String -> m a -> ElementConfig en t m -> m (DOM.Element, a)
91+buildElementInternal elementTag child cfg = do
92+ (e, result) <- element (T.pack elementTag) cfg child
93+ return (_element_raw e, result)