src/Reflex/Dom/Old.hs · reflex-dom

git.iko.soy/reflex-dom

on efaaa52 help sign in

reflex-dom/src/Reflex/Dom/Old.hs

267 lines 10 kB history raw

1{-# LANGUAGE ConstraintKinds #-}

2{-# LANGUAGE ExplicitForAll #-}

3{-# LANGUAGE FlexibleContexts #-}

4{-# LANGUAGE FlexibleInstances #-}

5{-# LANGUAGE MultiParamTypeClasses #-}

6{-# LANGUAGE Rank2Types #-}

7{-# LANGUAGE ScopedTypeVariables #-}

8{-# LANGUAGE TemplateHaskell #-}

9{-# LANGUAGE TypeFamilies #-}

10{-# LANGUAGE UndecidableInstances #-}

11module Reflex.Dom.Old

12 ( MonadWidget

13 , El

14 , ElConfig (..)

15 , elConfig_namespace

16 , elConfig_attributes

17 , _el_clicked

18 , _el_element

19 , _el_events

20 , addVoidAction

21 , AttributeMap

22 , Attributes (..)

23 , buildElement

24 , buildElementNS

25 , buildEmptyElement

26 , buildEmptyElementNS

27 , elDynHtml'

28 , elDynHtmlAttr'

29 , elStopPropagationNS

30 , elWith

31 , elWith'

32 , emptyElWith

33 , emptyElWith'

34 , getQuitWidget

35 , namedNodeMapGetNames

36 , nodeClear

37 , onEventName

38 , schedulePostBuild

39 , text'

40 , unsafePlaceElement

41 , WidgetHost

42 , wrapElement

43 ) where

45import Control.Arrow (first)

46import Control.Lens (makeLenses, (%~), (&), (.~), (^.))

47import Control.Monad

48import Control.Monad.Fix

49import Control.Monad.IO.Class

50import Control.Monad.Reader

51import Control.Monad.Ref

52import Data.Default

53import Data.Dependent.Map as DMap

54import Data.Functor.Misc

55import Data.Map (Map)

56import qualified Data.Map as Map

57import Data.Maybe

58import Data.Set (Set)

59import qualified Data.Set as Set

60import Data.Text

61import Foreign.JavaScript.TH

62import qualified GHCJS.DOM.Element as Element

63import GHCJS.DOM.EventM (EventM)

64import GHCJS.DOM.NamedNodeMap as NNM

65import GHCJS.DOM.Node (getFirstChild, getNodeName, removeChild)

66import GHCJS.DOM.Types (IsElement, IsNode)

67import qualified GHCJS.DOM.Types as DOM

68import Reflex.Class

69import Reflex.Dom.Builder.Class

70import Reflex.Dom.Builder.Immediate

71import Reflex.Dom.Internal.Foreign

72import Reflex.Dom.Widget.Basic

73import Reflex.Host.Class

74import Reflex.PerformEvent.Class

75import Reflex.PostBuild.Class

76import Reflex.TriggerEvent.Class

78data ElConfig attrs = ElConfig

79 { _elConfig_namespace :: Maybe Text

80 , _elConfig_attributes :: attrs

81 }

83instance attrs ~ Map Text Text => Default (ElConfig attrs) where

84 def = ElConfig

85 { _elConfig_namespace = Nothing

86 , _elConfig_attributes = mempty

87 }

89makeLenses ''ElConfig

91--TODO: HasDocument is still not accounted for

92type MonadWidgetConstraints t m =

93 ( DomBuilder t m

94 , DomBuilderSpace m ~ GhcjsDomSpace

95 , MonadFix m

96 , MonadHold t m

97 , MonadSample t (Performable m)

98 , MonadReflexCreateTrigger t m

99 , PostBuild t m

100 , PerformEvent t m

101 , MonadIO m

102 , MonadIO (Performable m)

103 , TriggerEvent t m

104 , HasWebView m

105 , HasWebView (Performable m)

106 , MonadRef m

107 , Ref m ~ Ref IO

108 , MonadRef (Performable m)

109 , Ref (Performable m) ~ Ref IO

110 )

111

112class MonadWidgetConstraints t m => MonadWidget t m

113instance MonadWidgetConstraints t m => MonadWidget t m

114

115type WidgetHost m = Performable m

116

117type El = Element EventResult GhcjsDomSpace

118

119addVoidAction :: MonadWidget t m => Event t (WidgetHost m ()) -> m ()

120addVoidAction = performEvent_

121

122type AttributeMap = Map Text Text

123

124buildElement :: (MonadWidget t m, Attributes m attrs t) => Text -> attrs -> m a -> m (RawElement (DomBuilderSpace m), a)

125buildElement = buildElementNS Nothing

126

127buildEmptyElement :: (MonadWidget t m, Attributes m attrs t) => Text -> attrs -> m (RawElement (DomBuilderSpace m))

128buildEmptyElement elementTag attrs = fst <$> buildElementNS Nothing elementTag attrs blank

129

130buildEmptyElementNS :: (MonadWidget t m, Attributes m attrs t) => Maybe Text -> Text -> attrs -> m (RawElement (DomBuilderSpace m))

131buildEmptyElementNS ns elementTag attrs = fst <$> buildElementNS ns elementTag attrs blank

132

133buildElementNS :: (MonadWidget t m, Attributes m attrs t) => Maybe Text -> Text -> attrs -> m a -> m (RawElement (DomBuilderSpace m), a)

134buildElementNS ns elementTag attrs child = first _element_raw <$> buildElementInternal ns elementTag attrs child

135

136class Attributes m attrs t where

137 buildElementInternal :: MonadWidget t m => Maybe Text -> Text -> attrs -> m a -> m (Element EventResult (DomBuilderSpace m) t, a)

138

139instance Attributes m (Map Text Text) t where

140 buildElementInternal ns elementTag attrs child = do

141 let cfg = def & elementConfig_namespace .~ ns

142 buildElementCommon elementTag child =<< addStaticAttributes attrs cfg

143

144addStaticAttributes :: Applicative m => Map Text Text -> ElementConfig er t m -> m (ElementConfig er t m)

145addStaticAttributes attrs cfg = do

146 let initialAttrs = Map.fromList $ first (AttributeName Nothing) <$> Map.toList attrs

147 pure $ cfg & elementConfig_initialAttributes .~ initialAttrs

148

149instance PostBuild t m => Attributes m (Dynamic t (Map Text Text)) t where

150 buildElementInternal ns elementTag attrs child = do

151 let cfg = def & elementConfig_namespace .~ ns

152 buildElementCommon elementTag child =<< addDynamicAttributes attrs cfg

153

154addDynamicAttributes :: PostBuild t m => Dynamic t (Map Text Text) -> ElementConfig er t m -> m (ElementConfig er t m)

155addDynamicAttributes attrs cfg = do

156 modifyAttrs <- dynamicAttributesToModifyAttributes attrs

157 return $ cfg & elementConfig_modifyAttributes .~ fmap mapKeysToAttributeName modifyAttrs

158

159buildElementCommon :: MonadWidget t m => Text -> m a -> ElementConfig er t m -> m (Element er (DomBuilderSpace m) t, a)

160buildElementCommon elementTag child cfg = element elementTag cfg child

161

162onEventName :: IsElement e => EventName en -> e -> EventM e (EventType en) () -> IO (IO ())

163onEventName = elementOnEventName

164

165schedulePostBuild :: (PostBuild t m, PerformEvent t m) => WidgetHost m () -> m ()

166schedulePostBuild w = do

167 postBuild <- getPostBuild

168 performEvent_ $ w <$ postBuild

169

170text' :: MonadWidget t m => Text -> m DOM.Text

171text' s = _textNode_raw <$> textNode (def & textNodeConfig_initialContents .~ s)

172

173instance HasAttributes (ElConfig attrs) where

174 type Attrs (ElConfig attrs) = attrs

175 attributes = elConfig_attributes

176

177instance HasNamespace (ElConfig attrs) where

178 namespace = elConfig_namespace

179

180elWith :: (MonadWidget t m, Attributes m attrs t) => Text -> ElConfig attrs -> m a -> m a

181elWith elementTag cfg child = snd <$> elWith' elementTag cfg child

182

183elWith' :: (MonadWidget t m, Attributes m attrs t) => Text -> ElConfig attrs -> m a -> m (Element EventResult (DomBuilderSpace m) t, a)

184elWith' elementTag cfg = buildElementInternal (cfg ^. namespace) elementTag $ cfg ^. attributes

185

186emptyElWith :: (MonadWidget t m, Attributes m attrs t) => Text -> ElConfig attrs -> m ()

187emptyElWith elementTag cfg = void $ emptyElWith' elementTag cfg

188

189emptyElWith' :: (MonadWidget t m, Attributes m attrs t) => Text -> ElConfig attrs -> m (Element EventResult (DomBuilderSpace m) t)

190emptyElWith' elementTag cfg = fmap fst $ elWith' elementTag cfg $ return ()

191

192{-# DEPRECATED _el_clicked "Use 'domEvent Click' instead" #-}

193_el_clicked :: Reflex t => Element EventResult d t -> Event t ()

194_el_clicked = domEvent Click

195

196{-# DEPRECATED _el_element "Use '_element_raw' instead" #-}

197_el_element :: El t -> RawElement GhcjsDomSpace

198_el_element = _element_raw

199

200{-# DEPRECATED _el_events "Use '_element_events' instead; or, if possible, use 'domEvent' instead to retrieve a particular event" #-}

201_el_events :: Element er d t -> EventSelector t (WrapArg er EventName)

202_el_events = _element_events

203

204{-# DEPRECATED _el_keypress "Use 'domEvent Keypress' instead" #-}

205_el_keypress :: Reflex t => El t -> Event t Int

206_el_keypress = domEvent Keypress

207

208{-# DEPRECATED _el_scrolled "Use 'domEvent Scroll' instead" #-}

209_el_scrolled :: Reflex t => El t -> Event t Int

210_el_scrolled = domEvent Scroll

211

212wrapElement :: forall t m. MonadWidget t m => (forall en. DOM.Element -> EventName en -> EventM DOM.Element (EventType en) (Maybe (EventResult en))) -> DOM.Element -> m (El t)

213wrapElement eh e = do

214 let h :: (EventName en, GhcjsDomEvent en) -> IO (Maybe (EventResult en))

215 h (en, GhcjsDomEvent evt) = runReaderT (eh e en) evt

216 wrapRawElement e $ (def :: RawElementConfig EventResult t m)

217 { _rawElementConfig_eventSpec = def

218 { _ghcjsEventSpec_handler = h

219 }

220 }

221

222unsafePlaceElement :: MonadWidget t m => DOM.Element -> m (Element EventResult (DomBuilderSpace m) t)

223unsafePlaceElement e = do

224 placeRawElement e

225 wrapRawElement e def

226

227namedNodeMapGetNames :: DOM.NamedNodeMap -> IO (Set Text)

228namedNodeMapGetNames self = do

229 l <- NNM.getLength self

230 let locations = if l == 0 then [] else [0..l-1] -- Can't use 0..l-1 if l is 0 because l is unsigned and will wrap around

231 fmap (Set.fromList . catMaybes) $ forM locations $ \i -> do

232 Just n <- NNM.item self i

233 getNodeName n

234

235nodeClear :: IsNode self => self -> IO ()

236nodeClear n = do

237 mfc <- getFirstChild n

238 case mfc of

239 Nothing -> return ()

240 Just fc -> do

241 _ <- removeChild n $ Just fc

242 nodeClear n

243

244getQuitWidget :: MonadWidget t m => m (WidgetHost m ())

245getQuitWidget = return $ do

246 WebViewSingleton wv <- askWebView

247 liftIO $ quitWebView wv

248

249elStopPropagationNS :: forall t m en a. (MonadWidget t m) => Maybe Text -> Text -> EventName en -> m a -> m a

250elStopPropagationNS ns elementTag en child = do

251 let f = GhcjsEventFilter $ \_ -> do

252 return (stopPropagation, return Nothing)

253 cfg = (def :: ElementConfig EventResult t m)

254 & namespace .~ ns

255 & elementConfig_eventSpec . ghcjsEventSpec_filters %~ DMap.insert en f

256 snd <$> element elementTag cfg child

257

258elDynHtmlAttr' :: MonadWidget t m => Text -> Map Text Text -> Dynamic t Text -> m (Element EventResult GhcjsDomSpace t)

259elDynHtmlAttr' elementTag attrs html = do

260 let cfg = def & initialAttributes .~ Map.mapKeys (AttributeName Nothing) attrs

261 (e, _) <- element elementTag cfg $ return ()

262 postBuild <- getPostBuild

263 performEvent_ $ Element.setInnerHTML (_element_raw e) . Just <$> leftmost [updated html, tag (current html) postBuild]

264 return e

265

266elDynHtml' :: MonadWidget t m => Text -> Dynamic t Text -> m (Element EventResult GhcjsDomSpace t)

267elDynHtml' elementTag = elDynHtmlAttr' elementTag mempty