git.iko.soy/reflex-dom
on develop help sign in
Support simultaneous modal requests
296825aDan Haraj
reflex-dom-core/src/Reflex/Dom/Modals/Base.hs+61−19
compare with develop
unifiedsplit
@@ -7,7 +7,10 @@
7{-# LANGUAGE RecursiveDo #-}
7{-# LANGUAGE RecursiveDo #-}
8{-# LANGUAGE ScopedTypeVariables #-}
8{-# LANGUAGE ScopedTypeVariables #-}
9{-# LANGUAGE TypeFamilies #-}
9{-# LANGUAGE TypeFamilies #-}
10−module Reflex.Dom.Modals.Base where
10+module Reflex.Dom.Modals.Base
11+ ( ModalsT (..)
12+ , withModalLayerClass
13+ )where
11
14
12import Control.Lens hiding (element)
15import Control.Lens hiding (element)
13import Control.Monad.Fix
16import Control.Monad.Fix
@@ -20,10 +23,13 @@ import Data.Dependent.Map (DMap, DSum (..), GCompare)
20import qualified Data.Dependent.Map as DMap
23import qualified Data.Dependent.Map as DMap
21import Data.Functor.Compose
24import Data.Functor.Compose
22import Data.Proxy
25import Data.Proxy
26+import Data.Semigroup
23import Data.Text (Text)
27import Data.Text (Text)
28+import qualified Data.Text as T
24import Foreign.JavaScript.TH
29import Foreign.JavaScript.TH
25−import Language.Javascript.JSaddle (JSM, MonadJSM)
30+import Language.Javascript.JSaddle (MonadJSM)
26
31
32+import Data.Functor.Misc
27import Reflex
33import Reflex
28import Reflex.Dom.Builder.Class
34import Reflex.Dom.Builder.Class
29import Reflex.Dom.Builder.Immediate
35import Reflex.Dom.Builder.Immediate
@@ -116,24 +122,60 @@ instance HasJSContext m => HasJSContext (ModalsT t m) where
116instance MonadJSM m => MonadJSM (ModalsT t m)
122instance MonadJSM m => MonadJSM (ModalsT t m)
117#endif
123#endif
118
124
119−withModalLayerClass :: forall t m a. (Reflex t, MonadFix m, DomBuilder t m, MonadHold t m) => Text -> ModalsT t m a -> m a
125+withModalLayerClass :: forall t m a. (Reflex t, MonadFix m, DomBuilder t m, MonadHold t m)
126+ => Text
127+ -> ModalsT t m a
128+ -> m a
120withModalLayerClass c (ModalsT a) = elAttr "div" ("class" =: c) $ do
129withModalLayerClass c (ModalsT a) = elAttr "div" ("class" =: c) $ do
121 rec (result, requests) <- do
130 rec (result, requests) <- do
122 runRequesterT a modalDone
131 runRequesterT a modalDone
123− let newModal = ffor requests $ \rs -> case DMap.minViewWithKey rs of
132+ modalDone <- modalInner requests
124− Nothing -> return never -- This should never happen
125− Just (k :=> v, _) -> do
126− (overlay, complete) <- elAttr' "div" ("style" =: "position:absolute;left:0;right:0;top:0;bottom:0;background-color:rgba(0,0,0,0.1);display:flex;justify-content:center;align-items:center") $ do --TODO: implement a stack rather than throwing away
127− let f = GhcjsEventFilter $ \_ -> return (stopPropagation, return Nothing)
128− cfg = (def :: ElementConfig EventResult t (DomBuilderSpace m))
129− & elementConfig_eventSpec %~ addEventSpecFlags (Proxy :: Proxy (DomBuilderSpace m)) Click (\_ -> stopPropagation)
130− & initialAttributes .~ ("style" =: "background-color:white;opacity:1;padding:1em")
131− fmap snd $ element "div" cfg $ do
132− fst <$> runRequesterT (unModalsT (getCompose v)) never --TODO: Don't ignore modal requests from the modal
133− return $ leftmost
134− [ DMap.singleton k . Just <$> complete
135− , DMap.singleton k Nothing <$ domEvent Click overlay
136− ]
137− modal <- widgetHold (return never) $ leftmost [newModal, return never <$ modalDone]
138− let modalDone = switch $ current modal
139 return result
133 return result
134+
135+modalInner :: 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)))
137+ -> m (Event t (DMap k Maybe))
138+modalInner rqs' = do
139+ rec let rqs = fmap toInsertionsDMap rqs'
140+ dones = fmap toDeletionsDMap modalDone
141+ (m0, mpatch) <- traverseDMapWithKeyWithAdjust (\k v -> Compose <$> modalBody k v) DMap.empty (rqs <> dones)
142+ modal <- fmap (merge . mapKeyValuePairsMonotonic wrapArgs) . incrementalToDynamic <$> holdIncremental m0 mpatch
143+ let modalDone = fmap (mapKeyValuePairsMonotonic unwrapArgs) $ switch $ current modal
144+ return modalDone
145+ where
146+ wrapArgs (k :=> v) = WrapArg k :=> getCompose v
147+ unwrapArgs :: DSum (WrapArg Maybe k) Identity -> DSum k Maybe
148+ unwrapArgs (WrapArg k :=> Identity v) = k :=> v
149+ toInsertionsDMap :: DMap k v -> PatchDMap k v
150+ toInsertionsDMap = coerce . DMap.map (ComposeMaybe . Just)
151+ toDeletionsDMap :: forall k' v v'. DMap k' v -> PatchDMap k' v'
152+ toDeletionsDMap = coerce . DMap.map (\(_ :: v a) -> ComposeMaybe (Nothing :: Maybe (v' a)))
153+
154+modalBody :: forall t m k a. (MonadHold t m, MonadFix m, DomBuilder t m)
155+ => k a
156+ -> Compose (ModalsT t m) (Event t) a
157+ -> m (Event t (Maybe a))
158+modalBody _ 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"
164+ ]
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
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
175+ rec (rsps, rqs') <- runRequesterT (unModalsT (getCompose v)) innerDone
176+ innerDone <- modalInner rqs'
177+ return rsps
178+ return $ leftmost
179+ [ Just <$> complete
180+ , Nothing <$ domEvent Click overlay
181+ ]