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