git.iko.soy/reflex-dom
on efaaa52 help sign in
reflex-dom/src/Reflex/Dom/Widget/Resize.hs
83 lines 4.3 kB history raw
1{-# LANGUAGE FlexibleContexts #-}
2{-# LANGUAGE MultiParamTypeClasses #-}
3{-# LANGUAGE OverloadedStrings #-}
4{-# LANGUAGE RecursiveDo #-}
5{-# LANGUAGE TypeFamilies #-}
6module Reflex.Dom.Widget.Resize where
8import Reflex.Class
9import Reflex.Dom.Builder.Class
10import Reflex.Dom.Builder.Immediate
11import Reflex.Dom.Class
12import Reflex.Dom.Widget.Basic
13import Reflex.PerformEvent.Class
14import Reflex.PostBuild.Class
15import Reflex.TriggerEvent.Class
17import Control.Monad
18import Control.Monad.Fix
19import Control.Monad.IO.Class
20import Data.Map (Map)
21import qualified Data.Map as Map
22import Data.Monoid
23import Data.Text (Text)
24import qualified Data.Text as T
25import GHCJS.DOM.Element hiding (reset)
26import GHCJS.DOM.EventM (on)
28-- | A widget that wraps the given widget in a div and fires an event when resized.
29-- Adapted from github.com/marcj/css-element-queries
30resizeDetector :: (DomBuilder t m, PostBuild t m, TriggerEvent t m, PerformEvent t m, MonadHold t m, DomBuilderSpace m ~ GhcjsDomSpace, MonadIO (Performable m), MonadFix m) => m a -> m (Event t (), a)
31resizeDetector = resizeDetectorWithStyle ""
33resizeDetectorWithStyle :: (DomBuilder t m, PostBuild t m, TriggerEvent t m, PerformEvent t m, MonadHold t m, DomBuilderSpace m ~ GhcjsDomSpace, MonadIO (Performable m), MonadFix m)
34 => Text -- ^ A css style string. Warning: It should not contain the "position" style attribute.
35 -> m a -- ^ The embedded widget
36 -> m (Event t (), a) -- ^ An 'Event' that fires on resize, and the result of the embedded widget
37resizeDetectorWithStyle styleString = resizeDetectorWithAttrs ("style" =: styleString)
39resizeDetectorWithAttrs :: (DomBuilder t m, PostBuild t m, TriggerEvent t m, PerformEvent t m, MonadHold t m, DomBuilderSpace m ~ GhcjsDomSpace, MonadIO (Performable m), MonadFix m)
40 => Map Text Text -- ^ A map of attributes. Warning: It should not modify the "position" style attribute.
41 -> m a -- ^ The embedded widget
42 -> m (Event t (), a) -- ^ An 'Event' that fires on resize, and the result of the embedded widget
43resizeDetectorWithAttrs attrs w = do
44 let childStyle = "position: absolute; left: 0; top: 0;"
45 containerAttrs = "style" =: "position: absolute; left: 0; top: 0; right: 0; bottom: 0; overflow: scroll; z-index: -1; visibility: hidden;"
46 (parent, (expand, expandChild, shrink, w')) <- elAttr' "div" (Map.unionWith (<>) attrs ("style" =: "position: relative;")) $ do
47 w' <- w
48 elAttr "div" containerAttrs $ do
49 (expand, (expandChild, _)) <- elAttr' "div" containerAttrs $ elAttr' "div" ("style" =: childStyle) $ return ()
50 (shrink, _) <- elAttr' "div" containerAttrs $ elAttr "div" ("style" =: (childStyle <> "width: 200%; height: 200%;")) $ return ()
51 return (expand, expandChild, shrink, w')
52 let reset = do
53 let e = _element_raw expand
54 s = _element_raw shrink
55 eow <- getOffsetWidth e
56 eoh <- getOffsetHeight e
57 let ecw = eow + 10
58 ech = eoh + 10
59 setAttribute (_element_raw expandChild) ("style" :: Text) (childStyle <> "width: " <> T.pack (show ecw) <> "px;" <> "height: " <> T.pack (show ech) <> "px;")
60 esw <- getScrollWidth e
61 setScrollLeft e esw
62 esh <- getScrollHeight e
63 setScrollTop e esh
64 ssw <- getScrollWidth s
65 setScrollLeft s ssw
66 ssh <- getScrollHeight s
67 setScrollTop s ssh
68 lastWidth <- getOffsetWidth (_element_raw parent)
69 lastHeight <- getOffsetHeight (_element_raw parent)
70 return (Just lastWidth, Just lastHeight)
71 resetIfChanged ds = do
72 pow <- getOffsetWidth (_element_raw parent)
73 poh <- getOffsetHeight (_element_raw parent)
74 if ds == (Just pow, Just poh)
75 then return Nothing
76 else fmap Just reset
77 pb <- getPostBuild
78 expandScroll <- wrapDomEvent (_element_raw expand) (`on` scroll) $ return ()
79 shrinkScroll <- wrapDomEvent (_element_raw shrink) (`on` scroll) $ return ()
80 size0 <- performEvent $ fmap (const $ liftIO reset) pb
81 rec resize <- performEventAsync $ fmap (\d cb -> liftIO $ cb =<< resetIfChanged d) $ tag (current dimensions) $ leftmost [expandScroll, shrinkScroll]
82 dimensions <- holdDyn (Nothing, Nothing) $ leftmost [ size0, fmapMaybe id resize ]
83 return (fmapMaybe void resize, w')