aboutsummaryrefslogtreecommitdiff
path: root/client/src/Component/Modal.hs
blob: d7943a97650fa3532f2b19253b2fcfc510df94cb (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
module Component.Modal
  ( ModalIn(..)
  , ModalOut(..)
  , modal
  ) where

import           Control.Monad     (void)
import qualified Data.Map          as M
import qualified Data.Map.Lazy     as LM
import           Data.Text         (Text)
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.Dom          as Dom

data ModalIn t m a = ModalIn
  { _modalIn_show    :: Event t ()
  , _modalIn_hide    :: Event t ()
  , _modalIn_content :: m a
  }

data ModalOut t a = ModalOut
  { _modalOut_content :: a
  , _modalOut_hide    :: Event t ()
  }

modal :: forall t m a. MonadWidget t m => ModalIn t m a -> m (ModalOut t a)
modal modalIn = do
  rec
    let showEvent = R.leftmost
          [ True <$ _modalIn_show modalIn
          , False <$ _modalIn_hide modalIn
          , False <$ curtainClick
          ]

    showModal <- R.holdDyn False showEvent

    (elem, (curtainClick, content)) <-
      R.buildElement "div" (getAttributes <$> showModal) $ do
        (curtain, _) <- R.elAttr' "div" (M.singleton "class" "modalCurtain") $ R.blank
        cont <- R.divClass "modalContent" $ _modalIn_content modalIn
        return (R.domEvent R.Click curtain, cont)

  performShowEffects showEvent elem

  return $ ModalOut
    { _modalOut_content = content
    , _modalOut_hide = curtainClick
    }

getAttributes :: Bool -> LM.Map Text Text
getAttributes show =
  M.fromList $
    [ ("style", if show then "display:block" else "display:none")
    , ("class", "modal")
    ]

performShowEffects
  :: forall t m a. MonadWidget t m
  => Event t Bool
  -> Element.Element
  -> m ()
performShowEffects showEvent elem = do
  body <- Dom.getBody

  let showEffects =
        flip fmap showEvent (\show -> do
          if show then
            do
              Node.appendChild body elem
              Element.setClassName body ("modal" :: JSString)
          else
            do
              Node.removeChild body elem
              Element.setClassName body ("" :: JSString)
        )

  R.performEvent_ $ void `fmap` showEffects