reflex-dom-contrib 0.4 → 0.4.1
raw patch · 9 files changed
+381/−150 lines, 9 filesdep +ghcjs-primdep ~bifunctorsdep ~ghcjs-basedep ~ghcjs-dom
Dependencies added: ghcjs-prim
Dependency ranges changed: bifunctors, ghcjs-base, ghcjs-dom, reflex, reflex-dom
Files
- reflex-dom-contrib.cabal +11/−8
- src/Reflex/Dom/Contrib/Geoposition.hs +60/−0
- src/Reflex/Dom/Contrib/KeyEvent.hs +6/−6
- src/Reflex/Dom/Contrib/Router.hs +97/−0
- src/Reflex/Dom/Contrib/Utils.hs +17/−6
- src/Reflex/Dom/Contrib/Widgets/ButtonGroup.hs +188/−0
- src/Reflex/Dom/Contrib/Widgets/Common.hs +1/−1
- src/Reflex/Dom/Contrib/Widgets/EditInPlace.hs +1/−1
- src/Reflex/Dom/Contrib/Widgets/Modal.hs +0/−128
reflex-dom-contrib.cabal view
@@ -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
+ src/Reflex/Dom/Contrib/Geoposition.hs view
@@ -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 ()
src/Reflex/Dom/Contrib/KeyEvent.hs view
@@ -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
+ src/Reflex/Dom/Contrib/Router.hs view
@@ -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
src/Reflex/Dom/Contrib/Utils.hs view
@@ -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
+ src/Reflex/Dom/Contrib/Widgets/ButtonGroup.hs view
@@ -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 <http://v4-alpha.getbootstrap.com/components/button-group/ button group>+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)
src/Reflex/Dom/Contrib/Widgets/Common.hs view
@@ -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
src/Reflex/Dom/Contrib/Widgets/EditInPlace.hs view
@@ -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)
− src/Reflex/Dom/Contrib/Widgets/Modal.hs
@@ -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)--