aboutsummaryrefslogtreecommitdiff
path: root/client/src/Component/Modal.hs
blob: 96c26796a067217a82b7a814fa0a5ea7a55f03d8 (plain)
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