@@ -0,0 +1,188 @@
1+{-# LANGUAGE CPP #-}
2+{-# LANGUAGE FlexibleInstances #-}
3+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
4+{-# LANGUAGE OverloadedStrings #-}
5+{-# LANGUAGE MultiParamTypeClasses #-}
6+{-# LANGUAGE RankNTypes #-}
7+{-# LANGUAGE RecursiveDo #-}
8+{-# LANGUAGE ScopedTypeVariables #-}
9+{-# LANGUAGE TypeFamilies #-}
10+module Reflex.Dom.Modals.Base
11+ ( ModalsT (..)
12+ , ModalLayerConfig (..)
13+ , withModalLayer
14+ )where
15+
16+import Control.Lens hiding (element)
17+import Control.Monad.Fix
18+import Control.Monad.Primitive
19+import Control.Monad.Ref
20+import Control.Monad.Trans
21+import Data.Coerce
22+import Data.Default
23+import Data.Dependent.Map (DMap, DSum (..), GCompare)
24+import qualified Data.Dependent.Map as DMap
25+import Data.Functor.Compose
26+import Data.Proxy
27+import Data.Semigroup
28+import Data.Text (Text)
29+import qualified Data.Text as T
30+import Foreign.JavaScript.TH
31+import Language.Javascript.JSaddle (MonadJSM)
32+
33+import Data.Functor.Misc
34+import Reflex
35+import Reflex.Dom.Builder.Class
36+import Reflex.Dom.Builder.Immediate
37+import Reflex.Dom.Class
38+import Reflex.Dom.Modals.Class
39+import Reflex.Host.Class
40+
41+instance (Reflex t, PrimMonad m) => ModalOpener t (ModalsT t m) where
42+ requestingModal = ModalsT . requesting . fmap Compose
43+
44+newtype ModalsT t m a = ModalsT { unModalsT :: RequesterT t (Compose (ModalsT t m) (Event t)) Maybe m a }
45+ deriving (Functor, Applicative, Monad, MonadIO, MonadFix)
46+
47+instance Wrapped (ModalsT t m a) where
48+ type Unwrapped (ModalsT t m a) = RequesterT t (Compose (ModalsT t m) (Event t)) Maybe m a
49+ _Wrapped' = iso coerce coerce
50+
51+instance ModalsT t m a ~ x => Rewrapped (ModalsT t m a) x
52+
53+instance MonadTrans (ModalsT t) where
54+ lift = ModalsT . lift
55+
56+instance (Reflex t, PostBuild t m) => PostBuild t (ModalsT t m) where
57+ getPostBuild = view _Unwrapped getPostBuild
58+
59+instance MonadSample t m => MonadSample t (ModalsT t m) where
60+ {-# INLINABLE sample #-}
61+ sample = lift . sample
62+
63+instance MonadHold t m => MonadHold t (ModalsT t m) where
64+ {-# INLINABLE hold #-}
65+ hold v0 = lift . hold v0
66+ {-# INLINABLE holdDyn #-}
67+ holdDyn v0 = lift . holdDyn v0
68+ {-# INLINABLE holdIncremental #-}
69+ holdIncremental v0 = lift . holdIncremental v0
70+
71+instance PerformEvent t m => PerformEvent t (ModalsT t m) where
72+ type Performable (ModalsT t m) = Performable m
73+ {-# INLINABLE performEvent_ #-}
74+ performEvent_ = lift . performEvent_
75+ {-# INLINABLE performEvent #-}
76+ performEvent = lift . performEvent
77+
78+instance (ReflexHost t, MonadReflexCreateTrigger t m) => MonadReflexCreateTrigger t (ModalsT t m) where
79+ {-# INLINABLE newEventWithTrigger #-}
80+ newEventWithTrigger = ModalsT . lift . newEventWithTrigger
81+ {-# INLINABLE newFanEventWithTrigger #-}
82+ newFanEventWithTrigger f = ModalsT $ lift $ newFanEventWithTrigger f
83+
84+instance TriggerEvent t m => TriggerEvent t (ModalsT t m) where
85+ {-# INLINABLE newTriggerEvent #-}
86+ newTriggerEvent = lift newTriggerEvent
87+ {-# INLINABLE newTriggerEventWithOnComplete #-}
88+ newTriggerEventWithOnComplete = lift newTriggerEventWithOnComplete
89+ newEventWithLazyTriggerWithOnComplete = lift . newEventWithLazyTriggerWithOnComplete
90+
91+instance MonadRef m => MonadRef (ModalsT t m) where
92+ type Ref (ModalsT t m) = Ref m
93+ {-# INLINABLE newRef #-}
94+ newRef = lift . newRef
95+ {-# INLINABLE readRef #-}
96+ readRef = lift . readRef
97+ {-# INLINABLE writeRef #-}
98+ writeRef r = lift . writeRef r
99+
100+instance MonadAtomicRef m => MonadAtomicRef (ModalsT t m) where
101+ {-# INLINABLE atomicModifyRef #-}
102+ atomicModifyRef r = lift . atomicModifyRef r
103+
104+instance (MonadAdjust t m, MonadHold t m) => MonadAdjust t (ModalsT t m) where
105+ runWithReplace a0 a' = ModalsT $ runWithReplace (unModalsT a0) (fmapCheap unModalsT a')
106+ traverseDMapWithKeyWithAdjust f dm0 dm' = ModalsT $ traverseDMapWithKeyWithAdjust (coerce f) dm0 dm'
107+ traverseDMapWithKeyWithAdjustWithMove f dm0 dm' = ModalsT $ traverseDMapWithKeyWithAdjustWithMove (coerce f) dm0 dm'
108+
109+instance (DomBuilder t m, PerformEvent t m, MonadFix m, MonadHold t m) => DomBuilder t (ModalsT t m) where
110+ type DomBuilderSpace (ModalsT t m) = DomBuilderSpace m
111+ element = coerce (element :: Text -> ElementConfig er t (DomBuilderSpace m) -> Unwrapped (ModalsT t m a) -> Unwrapped (ModalsT t m (Element er (DomBuilderSpace m) t, a)))
112+ inputElement = coerce (inputElement :: InputElementConfig er t (DomBuilderSpace m) -> Unwrapped (ModalsT t m (InputElement er (DomBuilderSpace m) t)))
113+ textAreaElement = coerce (textAreaElement :: TextAreaElementConfig er t (DomBuilderSpace m) -> Unwrapped (ModalsT t m (TextAreaElement er (DomBuilderSpace m) t)))
114+ selectElement = coerce (selectElement :: SelectElementConfig er t (DomBuilderSpace m) -> Unwrapped (ModalsT t m a) -> Unwrapped (ModalsT t m (SelectElement er (DomBuilderSpace m) t, a)))
115+ wrapRawElement e = (view _Unwrapped :: forall a. Unwrapped (ModalsT t m a) -> ModalsT t m a) . wrapRawElement e
116+
117+instance HasDocument m => HasDocument (ModalsT t m)
118+instance HasJSContext m => HasJSContext (ModalsT t m) where
119+ type JSContextPhantom (ModalsT t m) = JSContextPhantom m
120+ askJSContext = ModalsT askJSContext
121+#ifndef ghcjs_HOST_OS
122+instance MonadJSM m => MonadJSM (ModalsT t m)
123+#endif
124+
125+data ModalLayerConfig t m = ModalLayerConfig
126+ { _modalLayerConfig_backdropElementConfig :: ElementConfig EventResult t (DomBuilderSpace m)
127+ , _modalLayerConfig_bodyElementConfig :: ElementConfig EventResult t (DomBuilderSpace m)
128+ }
129+
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"
139+ ]))
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")
143+ }
144+
145+withModalLayer :: forall t m a. (Reflex t, MonadFix m, DomBuilder t m, MonadHold t m)
146+ => ModalLayerConfig t m
147+ -> ModalsT t m a
148+ -> m a
149+withModalLayer cfg (ModalsT a) = do
150+ rec (result, requests) <- do
151+ runRequesterT a modalDone
152+ modalDone <- modalInner requests cfg
153+ return result
154+
155+modalInner :: forall t m k. (GCompare k, MonadHold t m, MonadFix m, DomBuilder t m)
156+ => Event t (DMap k (Compose (ModalsT t m) (Event t)))
157+ -> ModalLayerConfig t m
158+ -> m (Event t (DMap k Maybe))
159+modalInner rqs' cfg = do
160+ rec let rqs = fmap toInsertionsDMap rqs'
161+ dones = fmap toDeletionsDMap modalDone
162+ (m0, mpatch) <- traverseDMapWithKeyWithAdjust (\_ v -> Compose <$> modalBody cfg v) DMap.empty (rqs <> dones)
163+ modal <- fmap (merge . mapKeyValuePairsMonotonic wrapArgs) . incrementalToDynamic <$> holdIncremental m0 mpatch
164+ let modalDone = fmap (mapKeyValuePairsMonotonic unwrapArgs) $ switch $ current modal
165+ return modalDone
166+ where
167+ wrapArgs (k :=> v) = WrapArg k :=> getCompose v
168+ unwrapArgs :: DSum (WrapArg Maybe k) Identity -> DSum k Maybe
169+ unwrapArgs (WrapArg k :=> Identity v) = k :=> v
170+ toInsertionsDMap :: DMap k v -> PatchDMap k v
171+ toInsertionsDMap = coerce . DMap.map (ComposeMaybe . Just)
172+ toDeletionsDMap :: forall k' v v'. DMap k' v -> PatchDMap k' v'
173+ toDeletionsDMap = coerce . DMap.map (\(_ :: v a) -> ComposeMaybe (Nothing :: Maybe (v' a)))
174+
175+modalBody :: forall t m a. (MonadHold t m, MonadFix m, DomBuilder t m)
176+ => ModalLayerConfig t m
177+ -> Compose (ModalsT t m) (Event t) a
178+ -> m (Event t (Maybe a))
179+modalBody cfg v = do
180+ (overlay, complete) <- element "div" (_modalLayerConfig_backdropElementConfig cfg) $ do
181+ fmap snd $ element "div" (_modalLayerConfig_bodyElementConfig cfg) $ do
182+ rec (rsps, rqs') <- runRequesterT (unModalsT (getCompose v)) innerDone
183+ innerDone <- modalInner rqs' cfg
184+ return rsps
185+ return $ leftmost
186+ [ Just <$> complete
187+ , Nothing <$ domEvent Click overlay
188+ ]