diff --git a/reflex-dom-contrib.cabal b/reflex-dom-contrib.cabal --- a/reflex-dom-contrib.cabal +++ b/reflex-dom-contrib.cabal @@ -1,5 +1,5 @@ name: reflex-dom-contrib -version: 0.4 +version: 0.4.1 synopsis: A playground for experimenting with infrastructure and common code for reflex applications description: This library is intended to be a public playground for developing infrastructure, higher level APIs, and widget @@ -27,37 +27,39 @@ library hs-source-dirs: src - exposed-modules: + exposed-modules: Reflex.Contrib.Interfaces Reflex.Contrib.Utils + Reflex.Dom.Contrib.Geoposition Reflex.Dom.Contrib.KeyEvent Reflex.Dom.Contrib.Pagination + Reflex.Dom.Contrib.Router Reflex.Dom.Contrib.Time Reflex.Dom.Contrib.Utils Reflex.Dom.Contrib.Xhr Reflex.Dom.Contrib.Widgets.BoundedList + Reflex.Dom.Contrib.Widgets.ButtonGroup Reflex.Dom.Contrib.Widgets.CheckboxList Reflex.Dom.Contrib.Widgets.Common Reflex.Dom.Contrib.Widgets.DynTabs Reflex.Dom.Contrib.Widgets.EditInPlace - Reflex.Dom.Contrib.Widgets.Modal Reflex.Dom.Contrib.Widgets.Svg build-depends: aeson >= 0.8 && < 0.11, base >= 4.6 && < 4.9, - bifunctors >= 4.0 && < 5.2, + bifunctors >= 4.0 && < 5.3, bytestring >= 0.10 && < 0.11, containers >= 0.5 && < 0.6, data-default >= 0.5 && < 0.6, - ghcjs-dom >= 0.1 && < 0.3, + ghcjs-dom >= 0.2 && < 0.3, http-types >= 0.8 && < 0.10, lens >= 4.9 && < 4.14, mtl >= 2.0 && < 2.3, random >= 1.0 && < 1.2, readable >= 0.3 && < 0.4, - reflex >= 0.2 && < 0.4, - reflex-dom >= 0.2 && < 0.3, + reflex >= 0.2 && < 0.5, + reflex-dom >= 0.2 && < 0.4, safe >= 0.3 && < 0.4, string-conv >= 0.1 && < 0.2, text >= 1.2 && < 1.3, @@ -66,7 +68,8 @@ if impl(ghcjs) build-depends: - ghcjs-base >= 0.1 && < 0.2 + ghcjs-base >= 0.2 && < 0.3, + ghcjs-prim >= 0.1 && < 0.2 default-language: Haskell2010 diff --git a/src/Reflex/Dom/Contrib/Geoposition.hs b/src/Reflex/Dom/Contrib/Geoposition.hs new file mode 100644 --- /dev/null +++ b/src/Reflex/Dom/Contrib/Geoposition.hs @@ -0,0 +1,60 @@ +module Reflex.Dom.Contrib.Geoposition where + +import Control.Concurrent (forkIO) +import Control.Exception (catch, throwIO) +import Control.Monad.IO.Class (liftIO) + +import Reflex (Event) +import Reflex.Dom (MonadWidget) +import Reflex.Dom.Class (performEventAsync) + +import GHCJS.DOM (currentWindow) +import GHCJS.DOM.PositionError (PositionException(..), PositionErrorCode(..)) +import qualified GHCJS.DOM.Coordinates as Coord +import GHCJS.DOM.Geolocation (getCurrentPosition) +import GHCJS.DOM.Geoposition (getCoords) +import GHCJS.DOM.Navigator (getGeolocation) +import GHCJS.DOM.Window (getNavigator) + + +defaultPosException :: PositionException +defaultPosException = PositionException PositionUnavailable "Failed to get geolocation" + +data GeopositionInfo = GeopositionInfo + { geoLatitude :: Double + , geoLongitude :: Double + , geoAltitudeMeters :: Maybe Double + , geoAccuracyMeters :: Double + , geoAltitudeAccuracyMeters :: Maybe Double + , geoHeadingDegrees :: Maybe Double + , geoSpeedMetersPerSec :: Maybe Double + } deriving (Show, Eq) + +getGeopositionInfo :: IO (Either PositionException GeopositionInfo) +getGeopositionInfo = (Right <$> getInfo) `catch` (pure . Left) + where + getInfo = do + window <- currentWindow >>= orBombOut + nav <- getNavigator window >>= orBombOut + geoloc <- getGeolocation nav >>= orBombOut + geopos <- getCurrentPosition geoloc Nothing + coord <- getCoords geopos >>= orBombOut + GeopositionInfo + <$> Coord.getLatitude coord + <*> Coord.getLongitude coord + <*> Coord.getAltitude coord + <*> Coord.getAccuracy coord + <*> Coord.getAltitudeAccuracy coord + <*> Coord.getHeading coord + <*> Coord.getSpeed coord + + orBombOut = maybe (throwIO defaultPosException) pure + +attachGeoposition :: MonadWidget t m => Event t a -> m (Event t (Either PositionException GeopositionInfo, a)) +attachGeoposition event = performEventAsync (fetchInfoAsync <$> event) + where + fetchInfoAsync a callback = liftIO $ do + _ <- forkIO $ do + info <- getGeopositionInfo + callback (info, a) + pure () diff --git a/src/Reflex/Dom/Contrib/KeyEvent.hs b/src/Reflex/Dom/Contrib/KeyEvent.hs --- a/src/Reflex/Dom/Contrib/KeyEvent.hs +++ b/src/Reflex/Dom/Contrib/KeyEvent.hs @@ -19,7 +19,7 @@ ------------------------------------------------------------------------------ import Control.Monad.Reader import Data.Char -import GHCJS.DOM.EventM (event) +import GHCJS.DOM.EventM (event, EventM) import GHCJS.DOM.Types hiding (Event) #ifdef ghcjs_HOST_OS import GHCJS.Types @@ -60,20 +60,20 @@ ------------------------------------------------------------------------------ -getKeyEvent :: ReaderT (t, UIEvent) IO KeyEvent +getKeyEvent :: EventM e KeyboardEvent KeyEvent #ifdef ghcjs_HOST_OS getKeyEvent = do e <- event code <- Reflex.Dom.getKeyEvent liftIO $ KeyEvent <$> pure code - <*> js_uiEventGetCtrlKey (unUIEvent e) - <*> js_uiEventGetShiftKey (unUIEvent e) + <*> js_uiEventGetCtrlKey (unKeyboardEvent e) + <*> js_uiEventGetShiftKey (unKeyboardEvent e) foreign import javascript unsafe "$1['ctrlKey']" - js_uiEventGetCtrlKey :: JSRef UIEvent -> IO Bool + js_uiEventGetCtrlKey :: JSVal -> IO Bool foreign import javascript unsafe "$1['shiftKey']" - js_uiEventGetShiftKey :: JSRef UIEvent -> IO Bool + js_uiEventGetShiftKey :: JSVal -> IO Bool #else getKeyEvent = error "getKeyEvent: can only be used with GHCJS" #endif diff --git a/src/Reflex/Dom/Contrib/Router.hs b/src/Reflex/Dom/Contrib/Router.hs new file mode 100644 --- /dev/null +++ b/src/Reflex/Dom/Contrib/Router.hs @@ -0,0 +1,97 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ForeignFunctionInterface #-} +{-# LANGUAGE JavaScriptFFI #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecursiveDo #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} + +module Reflex.Dom.Contrib.Router where + +------------------------------------------------------------------------------ +import Control.Monad +import Control.Monad.Trans +import GHCJS.DOM +import GHCJS.DOM.Document +import GHCJS.DOM.Types (unWindow) +import GHCJS.DOM.Window +import GHCJS.DOM.HTMLDocument +#ifdef ghcjs_HOST_OS +import GHCJS.Foreign.Callback +import GHCJS.Types +import GHCJS.Prim +#endif +import Prelude hiding (mapM, mapM_, all, sequence) +import Reflex.Dom +import Reflex.Dom.Contrib.Utils +------------------------------------------------------------------------------ + + +------------------------------------------------------------------------------ +setUrl + :: MonadWidget t m + => Event t String + -> m () +setUrl e = do + performEvent_ $ ffor e $ \url -> liftIO $ do + windowHistoryPushState url + + +------------------------------------------------------------------------------ +getWindowLocation :: Window -> IO String +#ifdef ghcjs_HOST_OS +getWindowLocation w = do + liftM fromJSString $ js_windowLocationPathname (unWindow w) + +foreign import javascript unsafe + "$1['location']['pathname']" + js_windowLocationPathname :: JSVal -> IO JSVal +#else +getWindowLocation = + error "getWindowLocation: only works in GHCJS" +#endif + + +------------------------------------------------------------------------------ +setupHistoryHandler :: Window -> (String -> IO ()) -> IO () +#ifdef ghcjs_HOST_OS +setupHistoryHandler w cb = do + cbRef <- syncCallback1 ThrowWouldBlock (cb . fromJSString) + js_setupHistoryHandler (unWindow w) cbRef + +foreign import javascript unsafe + "$1.onpopstate = function(event) { $2($1['location']['pathname']); }" + js_setupHistoryHandler :: JSVal -> Callback (JSVal -> IO ()) -> IO () +#else +setupHistoryHandler = + error "setupHistoryHandler: only works in GHCJS" +#endif + + +------------------------------------------------------------------------------ +-- | Handles routing for a site. The argument to this function is a widget +-- function with the effective type signature `String -> m (Event t String)`. +-- The String parameter is the initial value of the window location pathname. +-- The return value is an event that updates the window location. +--routeSite +-- :: (forall t m a. (MonadWidget t m) => (String -> m (Event t String))) +-- -> IO () +routeSite siteFunc = runWebGUI $ \webView -> do + w <- waitUntilJust currentWindow + path <- getWindowLocation w + --setupHistoryHandler w (\arg -> putStrLn $ "ghcjs history handling! " ++ arg) + --wrapDomEvent w domWindowOnpopstate myGetEvent + doc <- waitUntilJust $ liftM (fmap castToHTMLDocument) $ + webViewGetDomDocument webView + body <- waitUntilJust $ getBody doc + attachWidget body webView $ do + changes <- siteFunc path + setUrl changes + return () + +--myGetEvent = do +-- e <- event +-- liftIO $ uiEventGetView e diff --git a/src/Reflex/Dom/Contrib/Utils.hs b/src/Reflex/Dom/Contrib/Utils.hs --- a/src/Reflex/Dom/Contrib/Utils.hs +++ b/src/Reflex/Dom/Contrib/Utils.hs @@ -21,16 +21,16 @@ , putDebugLn , putDebugLnE , listWithKeyAndSelection + , waitUntilJust ) where ------------------------------------------------------------------------------ +import Control.Concurrent import Control.Monad import Control.Monad.Reader import Data.Map (Map) import GHCJS.DOM.Types hiding (Event) #ifdef ghcjs_HOST_OS -import GHCJS.Foreign -import GHCJS.Marshal import GHCJS.Types #endif import Reflex @@ -78,15 +78,14 @@ -- | Gets the current path of the DOM Window (i.e., the contents of the -- address bar after the host, beginning with a "/"). -- https://developer.mozilla.org/en-US/docs/Web/API/Location -getWindowLocationPath :: DOMWindow -> IO String +getWindowLocationPath :: Window -> IO String #ifdef ghcjs_HOST_OS getWindowLocationPath w = do - jw <- toJSRef w - liftM fromJSString $ js_windowLocationPath jw + liftM fromJSString $ js_windowLocationPath $ unWindow w foreign import javascript unsafe "$1['location']['pathname']" - js_windowLocationPath :: JSRef DOMWindow -> IO JSString + js_windowLocationPath :: JSVal -> IO JSString #else getWindowLocationPath = error "getWindowLocationPath: can only be used with GHCJS" #endif @@ -157,3 +156,15 @@ selected <- getDemuxed selectionDemux k mkChild k v selected + +------------------------------------------------------------------------------ +-- | Simple utility function to robustly get things like the current window, +-- DOM document, document body, etc. +waitUntilJust :: IO (Maybe a) -> IO a +waitUntilJust a = do + mx <- a + case mx of + Just x -> return x + Nothing -> do + threadDelay 10000 + waitUntilJust a diff --git a/src/Reflex/Dom/Contrib/Widgets/ButtonGroup.hs b/src/Reflex/Dom/Contrib/Widgets/ButtonGroup.hs new file mode 100644 --- /dev/null +++ b/src/Reflex/Dom/Contrib/Widgets/ButtonGroup.hs @@ -0,0 +1,188 @@ +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE RecursiveDo #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Reflex.Dom.Contrib.Widgets.ButtonGroup ( + radioGroup, + bootstrapButtonGroup, + buttonGroup +) where + +------------------------------------------------------------------------------ +import Control.Monad (liftM) +import Control.Monad.IO.Class (liftIO) +import Data.Bool (bool) +import qualified Data.Map as Map +import Data.Maybe (fromMaybe, listToMaybe) +import Data.Monoid ((<>)) +import GHCJS.DOM.HTMLInputElement (castToHTMLInputElement, + setChecked) +import Reflex.Dom ((=:), EventName(Blur, Click, Focus, + Keydown, Keypress, Keyup), + Event, Dynamic, holdDyn, MonadWidget, + attachWith, combineDyn, current, demux, + domEvent, dynText, getPostBuild, el, + elDynAttr', forDyn, getDemuxed, + joinDynThroughMap, leftmost, listWithKey, + mapDyn, never, switchPromptlyDyn, qDyn, + unqDyn, updated) +import Reflex.Dom.Class (performEvent) +import Reflex.Dom.Widget.Basic (_el_element) +------------------------------------------------------------------------------ +import Reflex.Dom.Contrib.Widgets.Common +------------------------------------------------------------------------------ + + +------------------------------------------------------------------------------ +-- | A general container for collecting drawable buttons into a group with +-- one selection, under the HtmlWidget interface +buttonGroup + :: forall t m a.(MonadWidget t m, Eq a, Show a) + => String + -- ^ Html tag name for the container (normally @"div"@ or @"table"@) + -> (Maybe Int -> Dynamic t a -> Dynamic t Bool -> m (Event t (), Dynamic t Bool)) + -- ^ WidgetMonadic action for rendering a single button, returning click events and focus state + -> Dynamic t (Map.Map Int a) + -- ^ Mapping from indices (used for layout order) to result elements + -> GWidget t m (Maybe a) + -- ^ Returning a GWidget (function from 'WidgetConfig' to 'HtmlWidget') +buttonGroup htmlTag drawDynBtn dynButtons (WidgetConfig wcSet wcInit wcAttrs) = do + + (parent, child) <- elDynAttr' htmlTag wcAttrs $ mdo + + pb <- getPostBuild + + let externSet = attachWith revLookup (current dynButtons) wcSet + initSet = attachWith revLookup (current dynButtons) (wcInit <$ pb) + internSet = leftmost [initSet, clickSelEvents] + internalV = attachWith (\m k -> k >>= flip Map.lookup m) + (current dynButtons) + internSet + + dynK <- holdDyn Nothing $ leftmost [internSet, externSet] + + dynButtons' <- mapDyn (Map.mapKeys Just) dynButtons + + (clickSelEvents, hasFocus) <- selectViewListWithKey_' dynK dynButtons' drawDynBtn + + dynSelV <- combineDyn (\k m -> k >>= flip Map.lookup m) dynK dynButtons + + return (HtmlWidget dynSelV internalV never never never hasFocus) + + let keyp = Keypress `domEvent` parent + keyu = Keyup `domEvent` parent + keyd = Keydown `domEvent` parent + return $ child { _hwidget_keypress = keyp + , _hwidget_keyup = keyu + , _hwidget_keydown = keyd } + + +------------------------------------------------------------------------------ +-- | Modified selectViewListWithKey from Reflex.Dom.Widget.Basic, +-- This one also passes back a 'Dynamic t Bool' indicating that at least +-- one child element is in focus +selectViewListWithKey_' :: forall t m k v a. (MonadWidget t m, Ord k) + => Dynamic t k + -> Dynamic t (Map.Map k v) + -> (k -> Dynamic t v + -> Dynamic t Bool + -> m (Event t a, Dynamic t Bool)) + -> m (Event t k, Dynamic t Bool) +selectViewListWithKey_' selection vals mkChild = do + let selectionDemux = demux selection -- For good performance, this value must be shared across all children + + selectChildAndFocus <- listWithKey vals $ \k v -> do + selected <- getDemuxed selectionDemux k + (selectSelf, selfFocus) <- mkChild k v selected + return $ (fmap (const k) selectSelf, selfFocus) + + selectChild <- mapDyn (Map.map fst) selectChildAndFocus + selEvents <- liftM switchPromptlyDyn $ mapDyn (leftmost . Map.elems) selectChild + focusMap <- joinDynThroughMap <$> mapDyn (Map.map snd) selectChildAndFocus + dynFocused <- mapDyn (any id) focusMap + + return (selEvents, dynFocused) + + +------------------------------------------------------------------------------ +-- | Helper function finding a value's first key in a map +revLookup :: Eq a => Map.Map Int a -> Maybe a -> Maybe Int +revLookup _ Nothing = Nothing +revLookup m (Just v) = listToMaybe . Map.keys $ Map.filter (== v) m + + +------------------------------------------------------------------------------ +-- | Produce a bootstrap +bootstrapButtonGroup :: forall t m a.(MonadWidget t m, Eq a, Show a) + => Dynamic t [(a,String)] + -- ^ Selectable values and their string labels + -> GWidget t m (Maybe a) + -- ^ Button group in a 'GWidget' interface (function from 'WidgetConfig' to 'HtmlWidget' ) +bootstrapButtonGroup dynEntryList cfg = do + btns :: Dynamic t (Map.Map Int a) <- forDyn dynEntryList $ \pairs -> + Map.fromList (zip [1..] (Prelude.map fst pairs)) + + divAttrs <- forDyn (_widgetConfig_attributes cfg) $ \attrs -> + attrs <> "class" =: "btn-group" + <> "role" =: "group" + <> "aria-label" =: "..." + + buttonGroup "div" handleOne btns + (WidgetConfig {_widgetConfig_attributes = divAttrs + ,_widgetConfig_setValue = _widgetConfig_setValue cfg + ,_widgetConfig_initialValue = _widgetConfig_initialValue cfg + }) + + where + + handleOne _ dynV dynChecked = do + txt <- combineDyn (\v m -> fromMaybe "" $ Prelude.lookup v m) + dynV dynEntryList + btnAttrs <- forDyn dynChecked $ \b -> + "type" =: "button" + <> "class" =: ("btn btn-default" <> bool "" " active" b) + (b,_) <- elDynAttr' "button" btnAttrs $ dynText txt + f <- holdDyn False $ leftmost [ False <$ (Blur `domEvent` b) + , True <$ (Focus `domEvent` b)] + return (Click `domEvent` b, f) + + + +------------------------------------------------------------------------------ +-- | A group of radio buttons in a table layout +radioGroup :: forall t m a.(MonadWidget t m, Eq a, Show a) + => Dynamic t String + -- ^ The name for the button group (different groups should be given different names) + -> Dynamic t [(a,String)] + -- ^ Selectable values and their string labels + -> GWidget t m (Maybe a) + -- ^ Radio group in a 'GWidget' interface (function from 'WidgetConfig' to 'HtmlWidget' ) +radioGroup dynName dynEntryList cfg = do + btns <- forDyn dynEntryList $ \pairs -> + Map.fromList (zip [1..] (map fst pairs)) + + buttonGroup "table" handleOne btns cfg + + where + + handleOne _ dynV dynChecked = do + + el "tr" $ do + txt <- combineDyn (\v m -> fromMaybe "" $ Prelude.lookup v m) + dynV dynEntryList + btnAttrs <- $(qDyn [| "type" =: "radio" + <> "name" =: $(unqDyn [|dynName|]) + <> bool mempty ("checked" =: "checked") + $(unqDyn [|dynChecked|]) + |]) + (b,_) <- el "td" $ elDynAttr' "input" btnAttrs $ return () + f <- holdDyn False $ leftmost [ False <$ (Blur `domEvent` b) + , True <$ (Focus `domEvent` b)] + el "td" $ dynText txt + let e = castToHTMLInputElement $ _el_element b + _ <- performEvent $ (liftIO . setChecked e) <$> updated dynChecked + return (Click `domEvent` b, f) diff --git a/src/Reflex/Dom/Contrib/Widgets/Common.hs b/src/Reflex/Dom/Contrib/Widgets/Common.hs --- a/src/Reflex/Dom/Contrib/Widgets/Common.hs +++ b/src/Reflex/Dom/Contrib/Widgets/Common.hs @@ -35,7 +35,7 @@ import Data.Readable import Data.String.Conv import Data.Time -import GHCJS.DOM.HTMLInputElement +import GHCJS.DOM.HTMLInputElement hiding (setValue) import Reflex import Reflex.Dom import Safe diff --git a/src/Reflex/Dom/Contrib/Widgets/EditInPlace.hs b/src/Reflex/Dom/Contrib/Widgets/EditInPlace.hs --- a/src/Reflex/Dom/Contrib/Widgets/EditInPlace.hs +++ b/src/Reflex/Dom/Contrib/Widgets/EditInPlace.hs @@ -109,7 +109,7 @@ (e,w) <- htmlTextInput' "text" $ def & widgetConfig_setValue .~ tagDyn name pb performEvent_ $ ffor pb $ \_ -> do - liftIO $ elementFocus e + liftIO $ focus e let acceptEvent = leftmost [ () <$ ffilter (==13) (_hwidget_keypress w) , () <$ ffilter not (updated $ _hwidget_hasFocus w) diff --git a/src/Reflex/Dom/Contrib/Widgets/Modal.hs b/src/Reflex/Dom/Contrib/Widgets/Modal.hs deleted file mode 100644 --- a/src/Reflex/Dom/Contrib/Widgets/Modal.hs +++ /dev/null @@ -1,128 +0,0 @@ -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE MultiWayIf #-} -{-# LANGUAGE NoMonomorphismRestriction #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE RecursiveDo #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE TypeFamilies #-} - -module Reflex.Dom.Contrib.Widgets.Modal where - ------------------------------------------------------------------------------- -import Data.Bifunctor -import Data.Either -import Data.Map (Map) -import Data.Monoid -import Reflex -import Reflex.Contrib.Utils -import Reflex.Dom -import Reflex.Dom.Contrib.Utils ------------------------------------------------------------------------------- - - ------------------------------------------------------------------------------- --- | The hiding strategies DisplayNone and VisibilityInvisible control --- visibility by setting the style to @display:none@ or @visibility:invisible@ --- respectively. @DisplayNone@ causes the elements to remain in the DOM but --- be taken out of the document flow. This means that widgets in the modal --- will only be able to get things like height when the modal is visible. --- Using @VisibilityInvisible@ makes height information available even when --- modal is not visible. -data HidingStrategy = DisplayNone - | VisibilityInvisible - deriving (Eq,Show,Ord,Enum,Bounded) - - -data ModalConfig = ModalConfig - { modalAttributes :: Map String String - -- ^ Attributes to put on the modal's outermost div - } - - ------------------------------------------------------------------------------- --- | Implements a modal that stays in the DOM but is hidden with either --- visibility:hidden or display:none when not displayed. -hidingModal - :: MonadWidget t m - => HidingStrategy - -> ModalConfig - -> Event t Bool - -- ^ Event to open and/or close the model - -> m (a, Event t ()) - -- ^ Widget rendering the body of the modal. Returns an event with a - -- success value and an event triggering the close of the modal. - -> m a -hidingModal strategy cfg showm body = do - rec let visE = leftmost [showm, False <$ closem] - (resE, closem) <- go =<< holdDyn False visE - return resE - where - go vis = do - attrs <- mapDyn (\b -> modalAttributes cfg <> visibility b) vis - elDynAttr "div" attrs body - - visibility True = "style" =: "display:block;" - visibility False = - case strategy of - VisibilityInvisible -> "style" =: "visibility:hidden; display:block;" - DisplayNone -> "style" =: "display:none;" - - ------------------------------------------------------------------------------- --- | Implements a modal that is removed from the DOM when not displayed. This --- involves a widgetHold and therefore this widget uses a different signature --- than hidingModal that makes the value inside the event available to the --- function constructing the modal. -removingModal - :: MonadWidget t m - => ModalConfig - -> Event t a - -- ^ Event to open the model - -> (a -> m (b, Event t ())) - -- ^ Widget rendering the body of the modal. Returns an event with a - -- success value and an event triggering the close of the modal. - -> m (Dynamic t (Maybe b)) -removingModal cfg showm body = do - rec let visE = leftmost [Just <$> showm, Nothing <$ closem] - (resE, closem) <- do - res <- widgetHoldHelper removeFromDOMWrapper Nothing visE - a <- mapDyn fst res - b <- extractEvent snd res - return (a,b) - return resE - where - removeFromDOMWrapper Nothing = return (Nothing, never) - removeFromDOMWrapper (Just a) = - elAttr "div" (modalAttributes cfg) $ - first Just <$> body a - - ------------------------------------------------------------------------------- --- | Template for a modal with a header, body, and footer where the header has --- a close icon and the footer has a cancel and save button. -mkModalBody - :: MonadWidget t m - => m (Event t ()) - -- ^ A header widget returning an event that closes the modal. - -> (Dynamic t (Either e a) -> m (Event t (), Event t ())) - -- ^ Footer widget that takes the current state of the body and returns - -- a pair of a cancel event and an ok event. - -> m (Dynamic t (Either e a)) - -> m (Event t (Either e a), Event t ()) -mkModalBody header footer body = do - divClass "modal-dialog" $ divClass "modal-content" $ do - dismiss <- header - bodyRes <- divClass "modal-body" body - (cancel, ok) <- footer bodyRes - let resE1 = tagDyn bodyRes ok - let closem1 = leftmost - [dismiss, cancel, () <$ ffilter isRight resE1] - return (resE1, closem1) - -