@@ -0,0 +1,139 @@
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 where
11+
12+import Control.Lens hiding (element)
13+import Control.Monad.Fix
14+import Control.Monad.Primitive
15+import Control.Monad.Ref
16+import Control.Monad.Trans
17+import Data.Coerce
18+import Data.Default
19+import Data.Dependent.Map (DMap, DSum (..), GCompare)
20+import qualified Data.Dependent.Map as DMap
21+import Data.Functor.Compose
22+import Data.Proxy
23+import Data.Text (Text)
24+import Foreign.JavaScript.TH
25+import Language.Javascript.JSaddle (JSM, MonadJSM)
26+
27+import Reflex
28+import Reflex.Dom.Builder.Class
29+import Reflex.Dom.Builder.Immediate
30+import Reflex.Dom.Class
31+import Reflex.Dom.Modals.Class
32+import Reflex.Dom.Widget.Basic
33+import Reflex.Host.Class
34+
35+instance (Reflex t, PrimMonad m) => ModalOpener t (ModalsT t m) where
36+ requestingModal = ModalsT . requesting . fmap Compose
37+
38+newtype ModalsT t m a = ModalsT { unModalsT :: RequesterT t (Compose (ModalsT t m) (Event t)) Maybe m a }
39+ deriving (Functor, Applicative, Monad, MonadIO, MonadFix)
40+
41+instance Wrapped (ModalsT t m a) where
42+ type Unwrapped (ModalsT t m a) = RequesterT t (Compose (ModalsT t m) (Event t)) Maybe m a
43+ _Wrapped' = iso coerce coerce
44+
45+instance ModalsT t m a ~ x => Rewrapped (ModalsT t m a) x
46+
47+instance MonadTrans (ModalsT t) where
48+ lift = ModalsT . lift
49+
50+instance (Reflex t, PostBuild t m) => PostBuild t (ModalsT t m) where
51+ getPostBuild = view _Unwrapped getPostBuild
52+
53+instance MonadSample t m => MonadSample t (ModalsT t m) where
54+ {-# INLINABLE sample #-}
55+ sample = lift . sample
56+
57+instance MonadHold t m => MonadHold t (ModalsT t m) where
58+ {-# INLINABLE hold #-}
59+ hold v0 = lift . hold v0
60+ {-# INLINABLE holdDyn #-}
61+ holdDyn v0 = lift . holdDyn v0
62+ {-# INLINABLE holdIncremental #-}
63+ holdIncremental v0 = lift . holdIncremental v0
64+
65+instance PerformEvent t m => PerformEvent t (ModalsT t m) where
66+ type Performable (ModalsT t m) = Performable m
67+ {-# INLINABLE performEvent_ #-}
68+ performEvent_ = lift . performEvent_
69+ {-# INLINABLE performEvent #-}
70+ performEvent = lift . performEvent
71+
72+instance (ReflexHost t, MonadReflexCreateTrigger t m) => MonadReflexCreateTrigger t (ModalsT t m) where
73+ {-# INLINABLE newEventWithTrigger #-}
74+ newEventWithTrigger = ModalsT . lift . newEventWithTrigger
75+ {-# INLINABLE newFanEventWithTrigger #-}
76+ newFanEventWithTrigger f = ModalsT $ lift $ newFanEventWithTrigger f
77+
78+instance TriggerEvent t m => TriggerEvent t (ModalsT t m) where
79+ {-# INLINABLE newTriggerEvent #-}
80+ newTriggerEvent = lift newTriggerEvent
81+ {-# INLINABLE newTriggerEventWithOnComplete #-}
82+ newTriggerEventWithOnComplete = lift newTriggerEventWithOnComplete
83+ newEventWithLazyTriggerWithOnComplete = lift . newEventWithLazyTriggerWithOnComplete
84+
85+instance MonadRef m => MonadRef (ModalsT t m) where
86+ type Ref (ModalsT t m) = Ref m
87+ {-# INLINABLE newRef #-}
88+ newRef = lift . newRef
89+ {-# INLINABLE readRef #-}
90+ readRef = lift . readRef
91+ {-# INLINABLE writeRef #-}
92+ writeRef r = lift . writeRef r
93+
94+instance MonadAtomicRef m => MonadAtomicRef (ModalsT t m) where
95+ {-# INLINABLE atomicModifyRef #-}
96+ atomicModifyRef r = lift . atomicModifyRef r
97+
98+instance (MonadAdjust t m, MonadHold t m) => MonadAdjust t (ModalsT t m) where
99+ runWithReplace = coerce runWithReplace -- coerce (runWithReplace :: Unwrapped (ModalsT t m a) -> Event t (Unwrapped (ModalsT t m b)) -> Unwrapped (ModalsT t m (a, Event t b)))
100+ traverseDMapWithKeyWithAdjust f dm0 dm' = ModalsT $ traverseDMapWithKeyWithAdjust (coerce f) dm0 dm'
101+ traverseDMapWithKeyWithAdjustWithMove f dm0 dm' = ModalsT $ traverseDMapWithKeyWithAdjustWithMove (coerce f) dm0 dm'
102+
103+instance (DomBuilder t m, PerformEvent t m, MonadFix m, MonadHold t m) => DomBuilder t (ModalsT t m) where
104+ type DomBuilderSpace (ModalsT t m) = DomBuilderSpace m
105+ element = coerce (element :: Text -> ElementConfig er t (DomBuilderSpace m) -> Unwrapped (ModalsT t m a) -> Unwrapped (ModalsT t m (Element er (DomBuilderSpace m) t, a)))
106+ inputElement = coerce (inputElement :: InputElementConfig er t (DomBuilderSpace m) -> Unwrapped (ModalsT t m (InputElement er (DomBuilderSpace m) t)))
107+ textAreaElement = coerce (textAreaElement :: TextAreaElementConfig er t (DomBuilderSpace m) -> Unwrapped (ModalsT t m (TextAreaElement er (DomBuilderSpace m) t)))
108+ selectElement = coerce (selectElement :: SelectElementConfig er t (DomBuilderSpace m) -> Unwrapped (ModalsT t m a) -> Unwrapped (ModalsT t m (SelectElement er (DomBuilderSpace m) t, a)))
109+ wrapRawElement e = (view _Unwrapped :: forall a. Unwrapped (ModalsT t m a) -> ModalsT t m a) . wrapRawElement e
110+
111+instance HasDocument m => HasDocument (ModalsT t m)
112+instance HasJSContext m => HasJSContext (ModalsT t m) where
113+ type JSContextPhantom (ModalsT t m) = JSContextPhantom m
114+ askJSContext = ModalsT askJSContext
115+#ifndef ghcjs_HOST_OS
116+instance MonadJSM m => MonadJSM (ModalsT t m)
117+#endif
118+
119+withModalLayerClass :: forall t m a. (Reflex t, MonadFix m, DomBuilder t m, MonadHold t m) => Text -> ModalsT t m a -> m a
120+withModalLayerClass c (ModalsT a) = elAttr "div" ("class" =: c) $ do
121+ rec (result, requests) <- do
122+ runRequesterT a modalDone
123+ let newModal = ffor requests $ \rs -> case DMap.minViewWithKey rs of
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