reflex-dom-contrib 0.2 → 0.3
raw patch · 8 files changed
+317/−28 lines, 8 filesdep +randomdep +transformersdep ~aesondep ~http-typesdep ~lens
Dependencies added: random, transformers
Dependency ranges changed: aeson, http-types, lens, reflex-dom
Files
- reflex-dom-contrib.cabal +11/−6
- src/Reflex/Contrib/Interfaces.hs +2/−20
- src/Reflex/Dom/Contrib/Time.hs +120/−0
- src/Reflex/Dom/Contrib/Utils.hs +18/−0
- src/Reflex/Dom/Contrib/Widgets/BoundedList.hs +2/−1
- src/Reflex/Dom/Contrib/Widgets/Common.hs +0/−1
- src/Reflex/Dom/Contrib/Widgets/Modal.hs +107/−0
- src/Reflex/Dom/Contrib/Widgets/Svg.hs +57/−0
reflex-dom-contrib.cabal view
@@ -1,5 +1,5 @@ name: reflex-dom-contrib-version: 0.2+version: 0.3 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@@ -32,6 +32,7 @@ Reflex.Contrib.Utils Reflex.Dom.Contrib.KeyEvent Reflex.Dom.Contrib.Pagination+ Reflex.Dom.Contrib.Time Reflex.Dom.Contrib.Utils Reflex.Dom.Contrib.Xhr Reflex.Dom.Contrib.Widgets.BoundedList@@ -39,25 +40,29 @@ 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.10,+ aeson >= 0.8 && < 0.11, base >= 4.6 && < 4.9, bifunctors >= 4.0 && < 5.1, bytestring >= 0.10 && < 0.11, containers >= 0.5 && < 0.6, data-default >= 0.5 && < 0.6, ghcjs-dom >= 0.1 && < 0.2,- http-types >= 0.8 && < 0.9,- lens >= 4.9 && < 4.13,+ 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.1 && < 0.3,+ reflex-dom >= 0.2 && < 0.3, safe >= 0.3 && < 0.4, string-conv >= 0.1 && < 0.2, text >= 1.2 && < 1.3,- time >= 1.5 && < 1.6+ time >= 1.5 && < 1.6,+ transformers >= 0.4 && < 0.5 if impl(ghcjs) build-depends:
src/Reflex/Contrib/Interfaces.hs view
@@ -4,7 +4,6 @@ {-# LANGUAGE MultiWayIf #-} {-# LANGUAGE NoMonomorphismRestriction #-} {-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE RankNTypes #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE RecursiveDo #-} {-# LANGUAGE ScopedTypeVariables #-}@@ -18,16 +17,15 @@ , rlist2rmap , toReflexMap , rmDeleteFunc- , selectViewListWithKey ) where ------------------------------------------------------------------------------+import Control.Monad.Fix import Data.Map (Map) import qualified Data.Map as M import Data.Set (Set) import qualified Data.Set as S import Reflex-import Reflex.Dom ------------------------------------------------------------------------------ @@ -74,7 +72,7 @@ ------------------------------------------------------------------------------ -- | Converts a ReflexList to a Dynamic list. toReflexMap- :: (MonadWidget t m, Eq a)+ :: (Reflex t, MonadFix m, MonadHold t m, Eq a) => ReflexList t a -> (ReflexMap t Int a -> m (Dynamic t (Map Int a))) -> m (Dynamic t [a])@@ -89,21 +87,5 @@ -- a map. rmDeleteFunc :: Ord k => Set k -> Map k v -> Map k v rmDeleteFunc s m = foldr M.delete m (S.toList s)------------------------------------------------------------------------------------ | A generalized version of the one in reflex-dom.-selectViewListWithKey- :: forall t m k v a. (MonadWidget t m, Ord k)- => Dynamic t k- -> Dynamic t (Map k v)- -> (k -> Dynamic t v -> Dynamic t Bool -> m a)- -> m (Dynamic t (Map k a))-selectViewListWithKey selection vals mkChild = do- let selectionDemux = demux selection- listWithKey vals $ \k v -> do- selected <- getDemuxed selectionDemux k- mkChild k v selected-
+ src/Reflex/Dom/Contrib/Time.hs view
@@ -0,0 +1,120 @@+{-# LANGUAGE DeriveDataTypeable, ScopedTypeVariables, TypeFamilies #-}++module Reflex.Dom.Contrib.Time (+ poissonLossyFrom+ , poissonLossy+ , inhomogeneousPoissonFrom+ , inhomogeneousPoisson+ ) where++import Reflex+import Reflex.Dom.Class+import Reflex.Dom.Time++import Control.Concurrent+import Control.Monad+import Control.Monad.IO.Class+import Data.Time.Clock+import System.Random+++-- | Send events with Poisson timing with the given basis and rate+-- Each occurence of the resulting event will contain the index of+-- the current interval, with 0 representing the basis time+poissonLossyFrom+ :: (RandomGen g, MonadWidget t m)+ => g+ -> Double+ -- ^ Poisson event rate (Hz)+ -> UTCTime+ -- ^ Baseline time for events+ -> Event t a+ -- ^ Event that starts a tick generation thread. Usually you want this to+ -- be something like the result of getPostBuild that only fires once. But+ -- there could be uses for starting multiple timer threads.+ -- Start sending events in response to the event parameter.+ -> m (Event t TickInfo)+poissonLossyFrom rnd rate t0 t =+ inhomogeneousPoissonFrom rnd (current $ constDyn rate) rate t0 t+++-- | Send events with Poisson timing with the given basis and rate+-- Each occurence of the resulting event will contain the index of+-- the current interval, with 0 representing the basis time.+-- Automatically begin sending events when the DOM is built+poissonLossy+ :: (RandomGen g, MonadWidget t m)+ => g+ -> Double+ -- ^ Poisson event rate (Hz)+ -> UTCTime+ -- ^ Baseline time for events+ -> m (Event t TickInfo)+poissonLossy rnd rate t0 = poissonLossyFrom rnd rate t0 =<< getPostBuild++-- | Send events with inhomogeneous Poisson timing with the given basis+-- and variable rate. Provide a maxRate that you expect to support.+inhomogeneousPoissonFrom+ :: (RandomGen g, MonadWidget t m)+ => g+ -> Behavior t Double+ -> Double+ -> UTCTime+ -> Event t a+ -> m (Event t TickInfo)+inhomogeneousPoissonFrom rnd rate maxRate t0 e = do++ -- Create a thread for producing homogeneous poisson events+ -- along with random Doubles (usage of Double's explained below)+ ticksWithRateRand <- performEventAsync $+ fmap callAtNextInterval e++ -- Filter homogeneous events according to associated+ -- random values and the current rate parameter+ return $ attachWithMaybe filterFun rate ticksWithRateRand++ where++ -- Inhomogeneous poisson processes are built from faster+ -- homogeneous ones by randomly dropping events from the+ -- fast process. For each fast homogeneous event, choose+ -- a uniform random sample from (0, rMax). If the+ -- inhomogeneous rate at this moment is greater than the+ -- random sample, then keep this event, otherwise drop it+ filterFun :: Double -> (TickInfo, Double) -> Maybe TickInfo+ filterFun r (tInfo, p)+ | r >= p = Just tInfo+ | otherwise = Nothing++ callAtNextInterval _ cb = void $ liftIO $ forkIO $ go t0 rnd cb 0++ go tTargetLast lastGen cb lastN = do+ t <- getCurrentTime++ -- Generate random numbers for this poisson interval (u)+ -- and sample-retention likelihood (p)+ let (u, nextGen) = randomR (0,1) lastGen+ (p :: Double, nextGen') = randomR (0,maxRate) nextGen++ -- Inter-event interval is drawn from exponential+ -- distribution accourding to u+ let dt = realToFrac $ -1 * log(u)/maxRate :: NominalDiffTime+ nEvents = lastN + 1+ alreadyElapsed = diffUTCTime t tTargetLast+ tTarget = addUTCTime dt tTargetLast+ thisDelay = realToFrac $ diffUTCTime tTarget t :: Double+ threadDelay $ ceiling $ thisDelay * 1000000+ void $ cb $ (TickInfo t nEvents alreadyElapsed, p)+ go tTarget nextGen' cb nEvents++-- | Send events with inhomogeneous Poisson timing with the given basis+-- and variable rate. Provide a maxRate that you expect to support+inhomogeneousPoisson+ :: (RandomGen g, MonadWidget t m)+ => g+ -> Behavior t Double+ -> Double+ -> UTCTime+ -> m (Event t TickInfo)+inhomogeneousPoisson rnd rate maxRate t0 =+ inhomogeneousPoissonFrom rnd rate maxRate t0 =<< getPostBuild
src/Reflex/Dom/Contrib/Utils.hs view
@@ -1,6 +1,7 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE ForeignFunctionInterface #-} {-# LANGUAGE JavaScriptFFI #-}+{-# LANGUAGE RankNTypes #-} {-| @@ -19,11 +20,13 @@ , widgetHoldHelper , putDebugLn , putDebugLnE+ , listWithKeyAndSelection ) where ------------------------------------------------------------------------------ import Control.Monad import Control.Monad.Reader+import Data.Map (Map) import GHCJS.DOM.Types hiding (Event) #ifdef ghcjs_HOST_OS import GHCJS.Foreign@@ -138,4 +141,19 @@ putDebugLnE :: MonadWidget t m => Event t a -> (a -> String) -> m () putDebugLnE e mkStr = do performEvent_ (liftIO . putStrLn . mkStr <$> e)+++------------------------------------------------------------------------------+-- | A generalized version of the one in reflex-dom.+listWithKeyAndSelection+ :: forall t m k v a. (MonadWidget t m, Ord k)+ => Dynamic t k+ -> Dynamic t (Map k v)+ -> (k -> Dynamic t v -> Dynamic t Bool -> m a)+ -> m (Dynamic t (Map k a))+listWithKeyAndSelection selection vals mkChild = do+ let selectionDemux = demux selection+ listWithKey vals $ \k v -> do+ selected <- getDemuxed selectionDemux k+ mkChild k v selected
src/Reflex/Dom/Contrib/Widgets/BoundedList.hs view
@@ -32,6 +32,7 @@ ------------------------------------------------------------------------------ import Reflex.Contrib.Interfaces import Reflex.Contrib.Utils+import Reflex.Dom.Contrib.Utils ------------------------------------------------------------------------------ @@ -118,7 +119,7 @@ boundedInsert itemLimit <$> attachDynWith (\c (k,v) -> (c, (k, (k,v)))) counter (fmapMaybe id $ updated curItem)- selectViewListWithKey curSelected activeItems wrapSingle+ listWithKeyAndSelection curSelected activeItems wrapSingle where --wrapSingle :: k -> Dynamic t (BornAt, (k,v)) -> Dynamic t Bool -> m a wrapSingle k v b = do
src/Reflex/Dom/Contrib/Widgets/Common.hs view
@@ -24,7 +24,6 @@ module Reflex.Dom.Contrib.Widgets.Common where -import Debug.Trace ------------------------------------------------------------------------------ import Control.Lens import Control.Monad
+ src/Reflex/Dom/Contrib/Widgets/Modal.hs view
@@ -0,0 +1,107 @@+{-# 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.Either+import Data.Map (Map)+import Data.Monoid+import Reflex+import Reflex.Contrib.Utils+import Reflex.Dom+import Reflex.Dom.Contrib.Utils+------------------------------------------------------------------------------+++------------------------------------------------------------------------------+-- | When the hiding strategy is RemoveFromDOM, the widget adds and removes+-- the modal markup from the DOM when the modal is opened and closed. For+-- @DisplayNone@ and @VisibilityInvisible@ the modal markup is always kept in+-- the DOM and visibility is controlled by setting the style to @display:none@+-- or @visibility:invisible@ respectively. @DisplayNone@ causes the elements+-- to be completely 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@ gets around this limitation.+data HidingStrategy = DisplayNone+ | VisibilityInvisible+ | RemoveFromDOM+ deriving (Eq,Show,Ord,Enum,Bounded)+++data ModalConfig = ModalConfig+ { modalHidingStrategy :: HidingStrategy+ , modalAttributes :: Map String String+ -- ^ Attributes to put on the modal's outermost div+ }+++------------------------------------------------------------------------------+modal+ :: MonadWidget t m+ => ModalConfig+ -> Event t Bool+ -- ^ Event to open and/or close the model+ -> m (Event t 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 (Event t a)+modal cfg showm body = do+ rec let visE = leftmost [showm, False <$ closem]+ (resE, closem) <- case modalHidingStrategy cfg of+ RemoveFromDOM -> do+ res <- widgetHoldHelper removeFromDOMWrapper False visE+ a <- extractEvent fst res+ b <- extractEvent snd res+ return (a,b)+ _ -> go =<< holdDyn False visE+ return resE+ where+ removeFromDOMWrapper False = return (never, never)+ removeFromDOMWrapper True = go $ constDyn True+ go vis = do+ attrs <- mapDyn (\b -> modalAttributes cfg <> visibility b) vis+ elDynAttr "div" attrs body++ visibility True = "style" =: "display:block;"+ visibility False =+ case modalHidingStrategy cfg of+ VisibilityInvisible -> "style" =: "visibility:hidden; display:block;"+ DisplayNone -> "style" =: "display:none;"+ RemoveFromDOM -> mempty+++------------------------------------------------------------------------------+-- | 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)++
+ src/Reflex/Dom/Contrib/Widgets/Svg.hs view
@@ -0,0 +1,57 @@+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE MultiWayIf #-}+{-# LANGUAGE NoMonomorphismRestriction #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE RecursiveDo #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}++{-|++Convenience functions for generating SVG from reflex.++-}++module Reflex.Dom.Contrib.Widgets.Svg where++------------------------------------------------------------------------------+import Data.Map (Map)+import qualified Data.Map as Map+import Reflex+import Reflex.Dom+------------------------------------------------------------------------------++{-# INLINABLE svgDynAttr' #-}+svgDynAttr' :: forall t m a. MonadWidget t m => String -> Dynamic t (Map String String) -> m a -> m (El t, a)+svgDynAttr' = elDynAttrNS' (Just "http://www.w3.org/2000/svg")++{-# INLINABLE svgDynAttr #-}+svgDynAttr :: forall t m a. MonadWidget t m => String -> Dynamic t (Map String String) -> m a -> m a+svgDynAttr elementTag attrs child = snd <$> svgDynAttr' elementTag attrs child++{-# INLINABLE svgAttr' #-}+svgAttr' :: forall t m a. MonadWidget t m => String -> Map String String -> m a -> m (El t, a)+svgAttr' elementTag attrs child = svgDynAttr' elementTag (constDyn attrs) child++{-# INLINABLE svgAttr #-}+svgAttr :: forall t m a. MonadWidget t m => String -> Map String String -> m a -> m a+svgAttr elementTag attrs child = svgDynAttr elementTag (constDyn attrs) child++{-# INLINABLE svg' #-}+svg' :: forall t m a. MonadWidget t m => String -> m a -> m (El t, a)+svg' elementTag child = svgAttr' elementTag (Map.empty :: AttributeMap) child++{-# INLINABLE svg #-}+svg :: forall t m a. MonadWidget t m => String -> m a -> m a+svg elementTag child = svgAttr elementTag Map.empty child++svgClass :: forall t m a. MonadWidget t m => String -> String -> m a -> m a+svgClass elementTag c child = svgAttr elementTag ("class" =: c) child+