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