{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecursiveDo #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
module Reflex.Dom.Widget.Resize where

import Reflex.Class
import Reflex.Time
import Reflex.Dom.Builder.Class
import Reflex.Dom.Builder.Immediate
import Reflex.Dom.Class
import Reflex.Dom.Widget.Basic
import Reflex.PerformEvent.Class
import Reflex.PostBuild.Class
import Reflex.TriggerEvent.Class

import Control.Monad.Fix
import Control.Monad.IO.Class
import Data.Map (Map)
import qualified Data.Map as Map
import Data.Text (Text)
import qualified Data.Text as T
import GHCJS.DOM.Element
import GHCJS.DOM.EventM (on)
import qualified GHCJS.DOM.GlobalEventHandlers as Events (scroll)
import GHCJS.DOM.Types (MonadJSM, liftJSM, uncheckedCastTo, HTMLElement(..))
import GHCJS.DOM.HTMLElement (getOffsetWidth, getOffsetHeight)
import qualified GHCJS.DOM.Types as DOM

-- | A widget that wraps the given widget in a div and fires an event when resized.
--   Adapted from @github.com\/marcj\/css-element-queries@
--
-- This function can cause strange scrollbars to appear in some circumstances.
-- These can be hidden with pseudo selectors, for example, in webkit browsers:
-- .wrapper *::-webkit-scrollbar { width: 0px; background: transparent; }
resizeDetector :: (MonadJSM m, DomBuilder t m, PostBuild t m, TriggerEvent t m, PerformEvent t m, MonadHold t m, DomBuilderSpace m ~ GhcjsDomSpace, MonadJSM (Performable m), MonadFix m) => m a -> m (Event t (Maybe Double, Maybe Double), a)
resizeDetector :: forall (m :: * -> *) t a.
(MonadJSM m, DomBuilder t m, PostBuild t m, TriggerEvent t m,
 PerformEvent t m, MonadHold t m, DomBuilderSpace m ~ GhcjsDomSpace,
 MonadJSM (Performable m), MonadFix m) =>
m a -> m (Event t (Maybe Double, Maybe Double), a)
resizeDetector = Text -> m a -> m (Event t (Maybe Double, Maybe Double), a)
forall (m :: * -> *) t a.
(MonadJSM m, DomBuilder t m, PostBuild t m, TriggerEvent t m,
 PerformEvent t m, MonadHold t m, DomBuilderSpace m ~ GhcjsDomSpace,
 MonadJSM (Performable m), MonadFix m) =>
Text -> m a -> m (Event t (Maybe Double, Maybe Double), a)
resizeDetectorWithStyle Text
""

resizeDetectorWithStyle :: (MonadJSM m, DomBuilder t m, PostBuild t m, TriggerEvent t m, PerformEvent t m, MonadHold t m, DomBuilderSpace m ~ GhcjsDomSpace, MonadJSM (Performable m), MonadFix m)
  => Text -- ^ A css style string. Warning: It should not contain the "position" style attribute.
  -> m a -- ^ The embedded widget
  -> m (Event t (Maybe Double, Maybe Double), a) -- ^ An 'Event' that fires on resize, and the result of the embedded widget
resizeDetectorWithStyle :: forall (m :: * -> *) t a.
(MonadJSM m, DomBuilder t m, PostBuild t m, TriggerEvent t m,
 PerformEvent t m, MonadHold t m, DomBuilderSpace m ~ GhcjsDomSpace,
 MonadJSM (Performable m), MonadFix m) =>
Text -> m a -> m (Event t (Maybe Double, Maybe Double), a)
resizeDetectorWithStyle Text
styleString = Map Text Text -> m a -> m (Event t (Maybe Double, Maybe Double), a)
forall (m :: * -> *) t a.
(MonadJSM m, DomBuilder t m, PostBuild t m, TriggerEvent t m,
 PerformEvent t m, MonadHold t m, DomBuilderSpace m ~ GhcjsDomSpace,
 MonadJSM (Performable m), MonadFix m) =>
Map Text Text -> m a -> m (Event t (Maybe Double, Maybe Double), a)
resizeDetectorWithAttrs (Text
Index (Map Text Text)
"style" Index (Map Text Text) -> IxValue (Map Text Text) -> Map Text Text
forall m. (At m, Monoid m) => Index m -> IxValue m -> m
=: Text
IxValue (Map Text Text)
styleString)

resizeDetectorWithAttrs :: (MonadJSM m, DomBuilder t m, PostBuild t m, TriggerEvent t m, PerformEvent t m, MonadHold t m, DomBuilderSpace m ~ GhcjsDomSpace, MonadJSM (Performable m), MonadFix m)
  => Map Text Text -- ^ A map of attributes. Warning: It should not modify the "position" style attribute.
  -> m a -- ^ The embedded widget
  -> m (Event t (Maybe Double, Maybe Double), a) -- ^ An 'Event' that fires on resize, and the result of the embedded widget
resizeDetectorWithAttrs :: forall (m :: * -> *) t a.
(MonadJSM m, DomBuilder t m, PostBuild t m, TriggerEvent t m,
 PerformEvent t m, MonadHold t m, DomBuilderSpace m ~ GhcjsDomSpace,
 MonadJSM (Performable m), MonadFix m) =>
Map Text Text -> m a -> m (Event t (Maybe Double, Maybe Double), a)
resizeDetectorWithAttrs Map Text Text
attrs m a
w = do
  let childStyle :: Text
childStyle = Text
"position: absolute; left: 0; top: 0;"
      containerAttrs :: Map Text Text
containerAttrs = Index (Map Text Text)
"style" Index (Map Text Text) -> IxValue (Map Text Text) -> Map Text Text
forall m. (At m, Monoid m) => Index m -> IxValue m -> m
=: IxValue (Map Text Text)
"position: absolute; left: 0; top: 0; right: 0; bottom: 0; overflow: scroll; z-index: -1; visibility: hidden;"
  (parent, (expand, expandChild, shrink, w')) <- Text
-> Map Text Text
-> m (Element EventResult GhcjsDomSpace t,
      Element EventResult GhcjsDomSpace t,
      Element EventResult GhcjsDomSpace t, a)
-> m (Element EventResult (DomBuilderSpace m) t,
      (Element EventResult GhcjsDomSpace t,
       Element EventResult GhcjsDomSpace t,
       Element EventResult GhcjsDomSpace t, a))
forall t (m :: * -> *) a.
DomBuilder t m =>
Text
-> Map Text Text
-> m a
-> m (Element EventResult (DomBuilderSpace m) t, a)
elAttr' Text
"div" ((Text -> Text -> Text)
-> Map Text Text -> Map Text Text -> Map Text Text
forall k a. Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a
Map.unionWith Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
(<>) Map Text Text
attrs (Text
Index (Map Text Text)
"style" Index (Map Text Text) -> IxValue (Map Text Text) -> Map Text Text
forall m. (At m, Monoid m) => Index m -> IxValue m -> m
=: Text
IxValue (Map Text Text)
"position: relative;")) (m (Element EventResult GhcjsDomSpace t,
    Element EventResult GhcjsDomSpace t,
    Element EventResult GhcjsDomSpace t, a)
 -> m (Element EventResult (DomBuilderSpace m) t,
       (Element EventResult GhcjsDomSpace t,
        Element EventResult GhcjsDomSpace t,
        Element EventResult GhcjsDomSpace t, a)))
-> m (Element EventResult GhcjsDomSpace t,
      Element EventResult GhcjsDomSpace t,
      Element EventResult GhcjsDomSpace t, a)
-> m (Element EventResult (DomBuilderSpace m) t,
      (Element EventResult GhcjsDomSpace t,
       Element EventResult GhcjsDomSpace t,
       Element EventResult GhcjsDomSpace t, a))
forall a b. (a -> b) -> a -> b
$ do
    w' <- m a
w
    elAttr "div" containerAttrs $ do
      (expand, (expandChild, _)) <- elAttr' "div" containerAttrs $ elAttr' "div" ("style" =: childStyle) $ return ()
      (shrink, _) <- elAttr' "div" containerAttrs $ elAttr "div" ("style" =: (childStyle <> "width: 200%; height: 200%;")) $ return ()
      return (expand, expandChild, shrink, w')
  let p = (JSVal -> HTMLElement) -> Element -> HTMLElement
forall obj obj'.
(Coercible obj JSVal, IsGObject obj') =>
(JSVal -> obj') -> obj -> obj'
uncheckedCastTo JSVal -> HTMLElement
HTMLElement (Element -> HTMLElement) -> Element -> HTMLElement
forall a b. (a -> b) -> a -> b
$ Element EventResult GhcjsDomSpace t -> RawElement GhcjsDomSpace
forall {k1} {k2} (er :: EventTag -> *) (d :: k1) (t :: k2).
Element er d t -> RawElement d
_element_raw Element EventResult GhcjsDomSpace t
parent
      reset = do
        let e :: HTMLElement
e = (JSVal -> HTMLElement) -> Element -> HTMLElement
forall obj obj'.
(Coercible obj JSVal, IsGObject obj') =>
(JSVal -> obj') -> obj -> obj'
uncheckedCastTo JSVal -> HTMLElement
HTMLElement (Element -> HTMLElement) -> Element -> HTMLElement
forall a b. (a -> b) -> a -> b
$ Element EventResult GhcjsDomSpace t -> RawElement GhcjsDomSpace
forall {k1} {k2} (er :: EventTag -> *) (d :: k1) (t :: k2).
Element er d t -> RawElement d
_element_raw Element EventResult GhcjsDomSpace t
expand
            s :: RawElement GhcjsDomSpace
s = Element EventResult GhcjsDomSpace t -> RawElement GhcjsDomSpace
forall {k1} {k2} (er :: EventTag -> *) (d :: k1) (t :: k2).
Element er d t -> RawElement d
_element_raw Element EventResult GhcjsDomSpace t
shrink
        eow <- HTMLElement -> JSM Double
forall (m :: * -> *) self.
(MonadDOM m, IsHTMLElement self) =>
self -> m Double
getOffsetWidth HTMLElement
e
        eoh <- getOffsetHeight e
        let ecw = Double
eow Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
10
            ech = Double
eoh Double -> Double -> Double
forall a. Num a => a -> a -> a
+ Double
10
        setAttribute (_element_raw expandChild) ("style" :: Text) (childStyle <> "width: " <> T.pack (show ecw) <> "px;" <> "height: " <> T.pack (show ech) <> "px;")
        esw <- getScrollWidth e
        setScrollLeft e esw
        esh <- getScrollHeight e
        setScrollTop e esh
        ssw <- getScrollWidth s
        setScrollLeft s ssw
        ssh <- getScrollHeight s
        setScrollTop s ssh
        lastWidth <- getOffsetWidth p
        lastHeight <- getOffsetHeight p
        return (Just lastWidth, Just lastHeight)
      resetIfChanged (Maybe Double, Maybe Double)
ds = do
        pow <- HTMLElement -> JSM Double
forall (m :: * -> *) self.
(MonadDOM m, IsHTMLElement self) =>
self -> m Double
getOffsetWidth HTMLElement
p
        poh <- getOffsetHeight p
        if ds == (Just pow, Just poh)
          then return Nothing
          else fmap Just reset
  pb <- delay 0 =<< getPostBuild
  expandScroll <- wrapDomEvent (DOM.uncheckedCastTo DOM.HTMLElement $ _element_raw expand) (`on` Events.scroll) $ return ()
  shrinkScroll <- wrapDomEvent (DOM.uncheckedCastTo DOM.HTMLElement $ _element_raw shrink) (`on` Events.scroll) $ return ()
  size0 <- performEvent $ fmap (const $ liftJSM reset) pb
  rec resize <- performEventAsync $ fmap (\(Maybe Double, Maybe Double)
d Maybe (Maybe Double, Maybe Double) -> IO ()
cb -> (IO () -> Performable m ()
forall a. IO a -> Performable m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Performable m ())
-> (Maybe (Maybe Double, Maybe Double) -> IO ())
-> Maybe (Maybe Double, Maybe Double)
-> Performable m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe (Maybe Double, Maybe Double) -> IO ()
cb) (Maybe (Maybe Double, Maybe Double) -> Performable m ())
-> Performable m (Maybe (Maybe Double, Maybe Double))
-> Performable m ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< JSM (Maybe (Maybe Double, Maybe Double))
-> Performable m (Maybe (Maybe Double, Maybe Double))
forall (m :: * -> *) a. MonadJSM m => JSM a -> m a
liftJSM ((Maybe Double, Maybe Double)
-> JSM (Maybe (Maybe Double, Maybe Double))
resetIfChanged (Maybe Double, Maybe Double)
d)) $ tag (current dimensions) $ leftmost [expandScroll, shrinkScroll]
      dimensions <- holdDyn (Nothing, Nothing) $ leftmost [ size0, fmapMaybe id resize ]
  return (updated dimensions, w')