1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
|
module Component.Modal
( Input(..)
, Content
, view
) where
import Control.Monad (void)
import qualified Data.Map as M
import qualified Data.Map.Lazy as LM
import Data.Text (Text)
import qualified Data.Text as T
import Data.Time.Clock (NominalDiffTime)
import qualified GHCJS.DOM.Element as Element
import qualified GHCJS.DOM.Node as Node
import JSDOM.Types (JSString)
import Reflex.Dom (Dynamic, Event, MonadWidget)
import qualified Reflex.Dom as R
import qualified Reflex.Dom.Class as R
import qualified Util.Reflex as ReflexUtil
-- Content = CurtainClickEvent -> (CancelEvent, ConfirmEvent)
type Content t m a = Event t () -> m (Event t (), Event t a)
data Input t m a = Input
{ _input_show :: Event t ()
, _input_content :: Content t m a
}
view :: forall t m a. MonadWidget t m => Input t m a -> m (Event t a)
view input = do
rec
let show = Show <$ (_input_show input)
startHiding =
R.attachWithMaybe
(\a _ -> if a then Just StartHiding else Nothing)
(R.current canBeHidden)
(R.leftmost [ hide, curtainClick ])
canBeHidden <-
R.holdDyn True $ R.leftmost
[ False <$ startHiding
, True <$ endHiding
]
endHiding <-
R.delay (0.2 :: NominalDiffTime) (EndHiding <$ startHiding)
let action =
R.leftmost [ show, startHiding, endHiding ]
modalClass <-
R.holdDyn "" (fmap getModalClass action)
(elem, dyn) <-
R.buildElement "div" (getAttributes <$> modalClass) $
ReflexUtil.visibleIfEvent
(isVisible <$> action)
(R.blank >> return (R.never, R.never, R.never))
(do
(curtain, _) <- R.elAttr' "div" (M.singleton "class" "g-Modal__Curtain") $ R.blank
let curtainClick = R.domEvent R.Click curtain
(hide, content) <- R.divClass "g-Modal__Content" (_input_content input curtainClick)
return (curtainClick, hide, content))
performShowEffects action elem
let curtainClick = R.switchDyn $ (\(a, _, _) -> a) <$> dyn
let hide = R.switchDyn $ (\(_, b, _) -> b) <$> dyn
let content = R.switchDyn $ (\(_, _, c) -> c) <$> dyn
return content
getAttributes :: Text -> LM.Map Text Text
getAttributes modalClass =
M.singleton "class" $
T.intercalate " " [ "g-Modal", modalClass]
performShowEffects
:: forall t m a. MonadWidget t m
=> Event t Action
-> Element.Element
-> m ()
performShowEffects showEvent elem = do
body <- ReflexUtil.getBody
let showEffects =
flip fmap showEvent (\case
Show -> do
Node.appendChild body elem
Element.setClassName body ("g-Body--Modal" :: JSString)
StartHiding ->
return ()
EndHiding -> do
Node.removeChild body elem
Element.setClassName body ("" :: JSString)
)
R.performEvent_ $ void `fmap` showEffects
data Action
= Show
| StartHiding
| EndHiding
getModalClass :: Action -> Text
getModalClass Show = "g-Modal--Show"
getModalClass StartHiding = "g-Modal--Hiding"
getModalClass _ = ""
isVisible :: Action -> Bool
isVisible Show = True
isVisible StartHiding = True
isVisible EndHiding = False
|
