@@ -9,7 +9,8 @@
9{-# LANGUAGE TypeFamilies #-}
9{-# LANGUAGE TypeFamilies #-}
10module Reflex.Dom.Modals.Base
10module Reflex.Dom.Modals.Base
11 ( ModalsT (..)
11 ( ModalsT (..)
12− , withModalLayerClass
12+ , ModalLayerConfig (..)
15import Control.Lens hiding (element)
16import Control.Lens hiding (element)
@@ -35,7 +36,6 @@ import Reflex.Dom.Builder.Class
35import Reflex.Dom.Builder.Immediate
36import Reflex.Dom.Builder.Immediate
36import Reflex.Dom.Class
37import Reflex.Dom.Class
37import Reflex.Dom.Modals.Class
38import Reflex.Dom.Modals.Class
38−import Reflex.Dom.Widget.Basic
39import Reflex.Host.Class
39import Reflex.Host.Class
41instance (Reflex t, PrimMonad m) => ModalOpener t (ModalsT t m) where
41instance (Reflex t, PrimMonad m) => ModalOpener t (ModalsT t m) where
@@ -122,23 +122,44 @@ instance HasJSContext m => HasJSContext (ModalsT t m) where
122instance MonadJSM m => MonadJSM (ModalsT t m)
122instance MonadJSM m => MonadJSM (ModalsT t m)
125+data ModalLayerConfig t m = ModalLayerConfig
126+ { _modalLayerConfig_backdropElementConfig :: ElementConfig EventResult t (DomBuilderSpace m)
127+ , _modalLayerConfig_bodyElementConfig :: ElementConfig EventResult t (DomBuilderSpace m)
130+instance (DomBuilder t m) => Default (ModalLayerConfig t m) where
131+ def = ModalLayerConfig
132+ { _modalLayerConfig_backdropElementConfig = (def :: ElementConfig EventResult t (DomBuilderSpace m))
133+ & elementConfig_eventSpec %~ addEventSpecFlags (Proxy :: Proxy (DomBuilderSpace m)) Click (const stopPropagation)
134+ & initialAttributes .~ ("style" =: (T.intercalate ";"
135+ [ "position:absolute"
136+ , "left:0", "right:0", "top:0", "bottom:0"
137+ , "background-color:rgba(0,0,0,0.1)"
138+ , "display:flex", "justify-content:center", "align-items:center"
140+ , _modalLayerConfig_bodyElementConfig = (def :: ElementConfig EventResult t (DomBuilderSpace m))
141+ & elementConfig_eventSpec %~ addEventSpecFlags (Proxy :: Proxy (DomBuilderSpace m)) Click (const stopPropagation)
142+ & initialAttributes .~ ("style" =: "background-color:white;opacity:1;padding:1em")
125−withModalLayerClass :: forall t m a. (Reflex t, MonadFix m, DomBuilder t m, MonadHold t m)
145+withModalLayer :: forall t m a. (Reflex t, MonadFix m, DomBuilder t m, MonadHold t m)
126− => Text
146+ => ModalLayerConfig t m
127− -> ModalsT t m a
147+ -> ModalsT t m a
129−withModalLayerClass c (ModalsT a) = elAttr "div" ("class" =: c) $ do
149+withModalLayer cfg (ModalsT a) = do
130 rec (result, requests) <- do
150 rec (result, requests) <- do
131 runRequesterT a modalDone
151 runRequesterT a modalDone
132− modalDone <- modalInner requests
152+ modalDone <- modalInner requests cfg
133 return result
153 return result
135modalInner :: forall t m k. (GCompare k, MonadHold t m, MonadFix m, DomBuilder t m)
155modalInner :: forall t m k. (GCompare k, MonadHold t m, MonadFix m, DomBuilder t m)
136 => Event t (DMap k (Compose (ModalsT t m) (Event t)))
156 => Event t (DMap k (Compose (ModalsT t m) (Event t)))
157+ -> ModalLayerConfig t m
137 -> m (Event t (DMap k Maybe))
158 -> m (Event t (DMap k Maybe))
138−modalInner rqs' = do
159+modalInner rqs' cfg = do
139 rec let rqs = fmap toInsertionsDMap rqs'
160 rec let rqs = fmap toInsertionsDMap rqs'
140 dones = fmap toDeletionsDMap modalDone
161 dones = fmap toDeletionsDMap modalDone
141− (m0, mpatch) <- traverseDMapWithKeyWithAdjust (\k v -> Compose <$> modalBody k v) DMap.empty (rqs <> dones)
162+ (m0, mpatch) <- traverseDMapWithKeyWithAdjust (\_ v -> Compose <$> modalBody cfg v) DMap.empty (rqs <> dones)
142 modal <- fmap (merge . mapKeyValuePairsMonotonic wrapArgs) . incrementalToDynamic <$> holdIncremental m0 mpatch
163 modal <- fmap (merge . mapKeyValuePairsMonotonic wrapArgs) . incrementalToDynamic <$> holdIncremental m0 mpatch
143 let modalDone = fmap (mapKeyValuePairsMonotonic unwrapArgs) $ switch $ current modal
164 let modalDone = fmap (mapKeyValuePairsMonotonic unwrapArgs) $ switch $ current modal
144 return modalDone
165 return modalDone
@@ -151,29 +172,15 @@ modalInner rqs' = do
151 toDeletionsDMap :: forall k' v v'. DMap k' v -> PatchDMap k' v'
172 toDeletionsDMap :: forall k' v v'. DMap k' v -> PatchDMap k' v'
152 toDeletionsDMap = coerce . DMap.map (\(_ :: v a) -> ComposeMaybe (Nothing :: Maybe (v' a)))
173 toDeletionsDMap = coerce . DMap.map (\(_ :: v a) -> ComposeMaybe (Nothing :: Maybe (v' a)))
154−modalBody :: forall t m k a. (MonadHold t m, MonadFix m, DomBuilder t m)
175+modalBody :: forall t m a. (MonadHold t m, MonadFix m, DomBuilder t m)
155− => k a
176+ => ModalLayerConfig t m
156 -> Compose (ModalsT t m) (Event t) a
177 -> Compose (ModalsT t m) (Event t) a
157 -> m (Event t (Maybe a))
178 -> m (Event t (Maybe a))
158−modalBody _ v = do
179+modalBody cfg v = do
159− let style = T.intercalate ";"
160− [ "position:absolute"
161− , "left:0", "right:0", "top:0", "bottom:0"
162− , "background-color:rgba(0,0,0,0.1)"
163− , "display:flex", "justify-content:center", "align-items:center"
165− backdropConfig = (def :: ElementConfig EventResult t (DomBuilderSpace m))
166− & elementConfig_eventSpec %~ addEventSpecFlags (Proxy :: Proxy (DomBuilderSpace m)) Click
167− (\_ -> stopPropagation)
168− & initialAttributes .~ ("style" =: style)
169− (overlay, complete) <- element "div" backdropConfig $ do
180+ (overlay, complete) <- element "div" (_modalLayerConfig_backdropElementConfig cfg) $ do
170− let bodyCfg = (def :: ElementConfig EventResult t (DomBuilderSpace m))
171− & elementConfig_eventSpec %~ addEventSpecFlags (Proxy :: Proxy (DomBuilderSpace m)) Click
172− (\_ -> stopPropagation)
173− & initialAttributes .~ ("style" =: "background-color:white;opacity:1;padding:1em")
174− fmap snd $ element "div" bodyCfg $ do
181+ fmap snd $ element "div" (_modalLayerConfig_bodyElementConfig cfg) $ do
175 rec (rsps, rqs') <- runRequesterT (unModalsT (getCompose v)) innerDone
182 rec (rsps, rqs') <- runRequesterT (unModalsT (getCompose v)) innerDone
176− innerDone <- modalInner rqs'
183+ innerDone <- modalInner rqs' cfg
177 return rsps
184 return rsps
178 return $ leftmost
185 return $ leftmost
179 [ Just <$> complete
186 [ Just <$> complete