mirror of
https://github.com/ilyakooo0/reflex-dom.git
synced 2024-09-11 06:35:30 +03:00
Merge branch 'develop' into MonadAtomicRef-UnrunnableT
This commit is contained in:
Elliot Cameron
GitHub
commit
8b2215431b
1
cabal.project
Normal file
1
cabal.project
Normal file
@ -0,0 +1 @@
|
||||
packages: reflex-dom-core, reflex-dom
|
||||
@ -1,7 +1,7 @@
|
||||
{
|
||||
"owner": "reflex-frp",
|
||||
"repo": "reflex-platform",
|
||||
"branch": "develop",
|
||||
"rev": "e7b76dd552a10916c7d8702c11292dac4f4299ea",
|
||||
"sha256": "0s1183arrwldcs50qhzgnv94v24n9bgq6dfq64wp0a3q2nzyvgwh"
|
||||
"branch": "master",
|
||||
"rev": "510b990d0b11f0626afbec5fe8575b5b2395391b",
|
||||
"sha256": "09cmahsbxr0963wq171c7j139iyzz49hramr4v9nsf684wcwkngv"
|
||||
}
|
||||
|
||||
@ -1,44 +1,75 @@
|
||||
# Revision history for reflex-dom-core
|
||||
|
||||
## 0.6.0.0
|
||||
|
||||
* ([#375](https://github.com/reflex-frp/reflex-dom/pull/375)) **(Breaking change)** Expose resized dimensions from `resizeDetector`, `resizeDetectorWithStyle`, and `resizeDetectorWithAttrs` from `Reflex.Dom.Widget.Resize`.
|
||||
* ([#374](https://github.com/reflex-frp/reflex-dom/pull/374)) **(Breaking change)** Provide text clipboard data as value of `Paste` event.
|
||||
* ([#348](https://github.com/reflex-frp/reflex-dom/pull/348)) **(Breaking change)** Make XHR response headers case insensitive by changing `_xhrResponse_headers :: Map Text Text` to `_xhrResponse_headers :: Map (CI Text) Text`.
|
||||
* ([#225](https://github.com/reflex-frp/reflex-dom/pull/225)) **(Breaking change)** Add a functional dependency to `HasDomEvent`.
|
||||
* ([#342](https://github.com/reflex-frp/reflex-dom/issues/342)) **(Breaking change)** The mouse wheel event is now a `WheelEventResult` rather than `()`. This provides information about the wheel's motion beyond the fact that it merely moved.
|
||||
* ([#353](https://github.com/reflex-frp/reflex-dom/pull/353)) Support GHC 8.8.
|
||||
* ([#358](https://github.com/reflex-frp/reflex-dom/pull/358)) Fix attribute support for explicitly namespaced elements.
|
||||
* ([#363](https://github.com/reflex-frp/reflex-dom/pull/363)) Remove deprecation warnings for the following widgets in
|
||||
`Reflex.Dom.Widget.Basic`:
|
||||
* `Link`
|
||||
* `button`
|
||||
* `dtdd`
|
||||
* `linkClass`
|
||||
* `link`
|
||||
* `tabDisplay`
|
||||
* `tableDynAttr`
|
||||
* ([#361](https://github.com/reflex-frp/reflex-dom/pull/361)) Fix bug in hydration causing the JavaScript to crash when dealing with unexpected HTML.
|
||||
* ([#310](https://github.com/reflex-frp/reflex-dom/issues/310)) Fix the static rendering of which dropdown value is selected.
|
||||
* ([#364](https://github.com/reflex-frp/reflex-dom/pull/364)) Export attributes used for controlling hydration at the element level:
|
||||
* "data-ssr" is now available as `Reflex.Dom.Builder.Immediate.hydratableAttribute`.
|
||||
* "data-hydration-skip" is now available as `Reflex.Dom.Builder.Immediate.skipHydrationAttribute`.
|
||||
* ([#366](https://github.com/reflex-frp/reflex-dom/pull/366)) Bump bounds for `reflex` to include 0.7.
|
||||
|
||||
## 0.5.3
|
||||
|
||||
* Deprecate a number of old inflexible widget helpers in `Reflex.Dom.Widget.Basic`:
|
||||
|
||||
* `Link`
|
||||
* `button`
|
||||
* `dtdd`
|
||||
* `linkClass`
|
||||
* `link`
|
||||
* `tabDisplay`
|
||||
* `tableDynAttr`
|
||||
* `Link`
|
||||
* `button`
|
||||
* `dtdd`
|
||||
* `linkClass`
|
||||
* `link`
|
||||
* `tabDisplay`
|
||||
* `tableDynAttr`
|
||||
|
||||
And in `Reflex.Dom.Widget.Input`:
|
||||
|
||||
* `TextInput`
|
||||
* `TextAreaConfig`
|
||||
* `CheckboxConfig`
|
||||
* `FileInput`
|
||||
|
||||
* Add `< 0.7` upper bound for reflex
|
||||
* `TextInput`
|
||||
* `TextAreaConfig`
|
||||
* `CheckboxConfig`
|
||||
* `FileInput`
|
||||
* Add `< 0.7` upper bound for `reflex`.
|
||||
|
||||
## 0.5.2
|
||||
|
||||
* Update to use new dependent-sum/map packages and drop dependency on `*Tag` classes (e.g., `ShowTag`).
|
||||
|
||||
* Update version bounds of base, containers, and stm
|
||||
|
||||
* Update to use the newly split `these`/`semialign` packages. To use the pre-split `these` package, set the `split-these` flag to false.
|
||||
|
||||
* Reintroduce "data-ssr": elements without this attribute are skipped during
|
||||
hydration.
|
||||
|
||||
* Fix an issue in the hydration tests that prevented the test from finding the chromium executable
|
||||
|
||||
* Relax constraints on `dyn` and `widgetHold` to match the ones in `networkView` and `networkHold` respectively
|
||||
|
||||
* Fix prerender for RequesterT so that it doesn't accidentally discard a request that is made at the same moment as getPostBuild's Event fires
|
||||
|
||||
## 0.5.1
|
||||
|
||||
* Added support for marking elements with a "data-skip-hydration" attribute, which will cause hydration to ignore and skip over them.
|
||||
|
||||
* Removed "data-ssr" attributes from statically rendered output.
|
||||
|
||||
## 0.5
|
||||
|
||||
* Add HydrationDomBuilderT to support hydration of statically rendered DOM nodes. See the note at the top of Reflex.Dom.Builder.Immediate.
|
||||
|
||||
* As a result of the hydration changes, the Prerender class has changed, the type of `prerender` has changed and it is now a class method.
|
||||
|
||||
* Add the Reflex.Dom.Xhr.FormData module to make posting formdata over xhr more convenient.
|
||||
|
||||
@ -1,7 +1,14 @@
|
||||
cabal-version: 1.24
|
||||
Name: reflex-dom-core
|
||||
Version: 0.5.3
|
||||
Version: 0.6.0.0
|
||||
Synopsis: Functional Reactive Web Apps with Reflex
|
||||
Description: Reflex-DOM is a Functional Reactive web framework based on the Reflex FRP engine
|
||||
Description:
|
||||
Reflex-DOM is a Functional Reactive web framework based on the Reflex FRP engine: <https://reflex-frp.org/>.
|
||||
.
|
||||
The @reflex-dom@ package is a small wrapper around the @reflex-dom-core@ package. It pulls in the
|
||||
correct set of dependencies for each target platform (GHCJS, WebKitGTK, WASM, mobile, etc.).
|
||||
Libraries should depend on @reflex-dom-core@ and executables will usually depend on @reflex-dom@.
|
||||
All of @reflex-dom-core@'s modules are re-exported by @reflex-dom@.
|
||||
License: BSD3
|
||||
License-file: LICENSE
|
||||
Author: Ryan Trinkle
|
||||
@ -9,7 +16,6 @@ Maintainer: ryan.trinkle@gmail.com
|
||||
Stability: Experimental
|
||||
Category: FRP, Web, GUI, HTML, Javascript, Reactive, Reactivity, User Interfaces, User-interface
|
||||
Build-type: Simple
|
||||
Cabal-version: >=1.9.2
|
||||
-- Deal with https://github.com/haskell/cabal/issues/2544 / https://github.com/haskell/cabal/issues/367
|
||||
extra-source-files: src-ghc/Foreign/JavaScript/Internal/Utils.hs
|
||||
src-ghcjs/Foreign/JavaScript/Internal/Utils.hs
|
||||
@ -48,11 +54,12 @@ library
|
||||
hs-source-dirs: src
|
||||
build-depends:
|
||||
aeson >= 0.8 && < 1.5,
|
||||
base >= 4.7 && < 4.13,
|
||||
base >= 4.7 && < 4.14,
|
||||
bifunctors >= 4.2 && < 6,
|
||||
bimap >= 0.3 && < 0.4,
|
||||
blaze-builder,
|
||||
blaze-builder >= 0.4.1 && < 0.5,
|
||||
bytestring == 0.10.*,
|
||||
case-insensitive < 1.3,
|
||||
containers >= 0.6 && < 0.7,
|
||||
constraints >= 0.9 && < 0.12,
|
||||
contravariant >= 1.4 && < 1.6,
|
||||
@ -69,11 +76,11 @@ library
|
||||
lens >= 4.7 && < 5,
|
||||
monad-control >= 1.0.1 && < 1.1,
|
||||
mtl >= 2.1 && < 2.3,
|
||||
primitive >= 0.5 && < 0.7,
|
||||
random,
|
||||
primitive >= 0.5 && < 0.8,
|
||||
random >= 1.1 && < 1.2,
|
||||
ref-tf == 0.4.*,
|
||||
reflex >= 0.6.2 && < 0.7,
|
||||
semigroups >= 0.16 && < 0.19,
|
||||
reflex >= 0.6.2 && < 0.8,
|
||||
semigroups >= 0.16 && < 0.20,
|
||||
stm >= 2.4 && < 2.6,
|
||||
text == 1.2.*,
|
||||
transformers >= 0.3 && < 0.6,
|
||||
@ -84,7 +91,7 @@ library
|
||||
hs-source-dirs: src-ghcjs
|
||||
build-depends:
|
||||
ghcjs-base,
|
||||
hashable == 1.2.*
|
||||
hashable >= 1.2 && < 1.4
|
||||
else
|
||||
hs-source-dirs: src-ghc
|
||||
if !os(windows)
|
||||
@ -92,7 +99,7 @@ library
|
||||
|
||||
if flag(split-these)
|
||||
build-depends:
|
||||
semialign >= 1 && < 1.1,
|
||||
semialign >= 1 && < 1.2,
|
||||
these >= 1 && < 1.1
|
||||
else
|
||||
build-depends:
|
||||
@ -132,6 +139,7 @@ library
|
||||
Reflex.Dom.Xhr.ResponseType
|
||||
Reflex.Dom.Xhr.Exception
|
||||
|
||||
default-language: Haskell98
|
||||
ghc-options: -Wall -fwarn-tabs -funbox-strict-fields -O2 -ferror-spans -fspecialise-aggressively
|
||||
ghc-prof-options: -fprof-auto
|
||||
|
||||
@ -146,26 +154,24 @@ library
|
||||
|
||||
if flag(use-template-haskell)
|
||||
build-depends:
|
||||
dependent-sum >= 0.6,
|
||||
dependent-sum-template >= 0.1 && < 0.2,
|
||||
template-haskell
|
||||
template-haskell >= 2.12.0 && < 2.16
|
||||
other-extensions: TemplateHaskell
|
||||
cpp-options: -DUSE_TEMPLATE_HASKELL
|
||||
other-modules:
|
||||
Reflex.Dom.Builder.Class.TH
|
||||
else
|
||||
build-depends:
|
||||
dependent-sum == 0.6.*
|
||||
|
||||
test-suite hlint
|
||||
build-depends: base, hlint
|
||||
hs-source-dirs: test
|
||||
main-is: hlint.hs
|
||||
type: exitcode-stdio-1.0
|
||||
default-language: Haskell98
|
||||
|
||||
test-suite hydration
|
||||
build-depends: base
|
||||
, aeson
|
||||
, async
|
||||
, bytestring
|
||||
, chrome-test-utils
|
||||
, constraints
|
||||
@ -207,6 +213,7 @@ test-suite hydration
|
||||
ghc-prof-options: -fprof-auto -optP-DPROFILING
|
||||
main-is: hydration.hs
|
||||
type: exitcode-stdio-1.0
|
||||
default-language: Haskell98
|
||||
if !os(linux) || !arch(x86_64) || flag(profile-reflex)
|
||||
buildable: False
|
||||
|
||||
@ -226,6 +233,7 @@ test-suite gc
|
||||
ghc-prof-options: -fprof-auto -optP-DPROFILING
|
||||
main-is: gc.hs
|
||||
type: exitcode-stdio-1.0
|
||||
default-language: Haskell98
|
||||
if !os(linux) || !arch(x86_64)
|
||||
buildable: False
|
||||
|
||||
|
||||
@ -638,7 +638,7 @@ instance (DomBuilder t m, MonadFix m, MonadHold t m, Group q, Query q, Additive
|
||||
|
||||
-- * Convenience functions
|
||||
|
||||
class HasDomEvent t target eventName where
|
||||
class HasDomEvent t target eventName | target -> t where
|
||||
type DomEventType target eventName :: *
|
||||
domEvent :: EventName eventName -> target -> Event t (DomEventType target eventName)
|
||||
|
||||
|
||||
@ -14,6 +14,7 @@ import Data.GADT.Compare.TH
|
||||
import Data.GADT.Compare
|
||||
(GOrdering(..), (:~:)(..), GEq(..), GCompare(..))
|
||||
#endif
|
||||
import Data.Text (Text)
|
||||
|
||||
data EventTag
|
||||
= AbortTag
|
||||
@ -151,7 +152,7 @@ type family EventResultType (en :: EventTag) :: * where
|
||||
EventResultType 'BeforecopyTag = ()
|
||||
EventResultType 'CopyTag = ()
|
||||
EventResultType 'BeforepasteTag = ()
|
||||
EventResultType 'PasteTag = ()
|
||||
EventResultType 'PasteTag = Maybe Text
|
||||
EventResultType 'ResetTag = ()
|
||||
EventResultType 'SearchTag = ()
|
||||
EventResultType 'SelectstartTag = ()
|
||||
@ -159,7 +160,17 @@ type family EventResultType (en :: EventTag) :: * where
|
||||
EventResultType 'TouchmoveTag = TouchEventResult
|
||||
EventResultType 'TouchendTag = TouchEventResult
|
||||
EventResultType 'TouchcancelTag = TouchEventResult
|
||||
EventResultType 'WheelTag = ()
|
||||
EventResultType 'WheelTag = WheelEventResult
|
||||
|
||||
data DeltaMode = DeltaPixel | DeltaLine | DeltaPage
|
||||
deriving (Show, Read, Eq, Ord, Bounded, Enum)
|
||||
|
||||
data WheelEventResult = WheelEventResult
|
||||
{ _wheelEventResult_deltaX :: Double
|
||||
, _wheelEventResult_deltaY :: Double
|
||||
, _wheelEventResult_deltaZ :: Double
|
||||
, _wheelEventResult_deltaMode :: DeltaMode
|
||||
} deriving (Show, Read, Eq, Ord)
|
||||
|
||||
data TouchEventResult = TouchEventResult
|
||||
{ _touchEventResult_altKey :: Bool
|
||||
|
||||
@ -21,10 +21,10 @@ import GHCJS.DOM.Types (MonadJSM (..))
|
||||
#endif
|
||||
import Reflex
|
||||
import Reflex.Dom.Builder.Class
|
||||
import Reflex.Dom.Builder.Immediate (HasDocument (..))
|
||||
import Reflex.Dom.Builder.Immediate (HasDocument (..), hydratableAttribute)
|
||||
import Reflex.Host.Class
|
||||
|
||||
-- | A DomBuilder transformer that adds "data-ssr" to all elements such that the
|
||||
-- | A DomBuilder transformer that adds an attribute to all elements such that the
|
||||
-- hydration builder knows which bits of DOM were added by us, and which were
|
||||
-- added by external scripts.
|
||||
newtype HydratableT m a = HydratableT { runHydratableT :: m a } deriving (Functor, Applicative, Monad, MonadAtomicRef, MonadFix, MonadIO)
|
||||
@ -62,8 +62,8 @@ instance PrimMonad m => PrimMonad (HydratableT m) where
|
||||
|
||||
makeHydratable :: Reflex t => ElementConfig er t m -> ElementConfig er t m
|
||||
makeHydratable cfg = cfg
|
||||
{ _elementConfig_initialAttributes = Map.insert "data-ssr" "" $ _elementConfig_initialAttributes cfg
|
||||
, _elementConfig_modifyAttributes = fmap (Map.delete "data-ssr") <$> _elementConfig_modifyAttributes cfg
|
||||
{ _elementConfig_initialAttributes = Map.insert hydratableAttribute "" $ _elementConfig_initialAttributes cfg
|
||||
, _elementConfig_modifyAttributes = fmap (Map.delete hydratableAttribute) <$> _elementConfig_modifyAttributes cfg
|
||||
}
|
||||
|
||||
instance PostBuild t m => PostBuild t (HydratableT m) where
|
||||
|
||||
@ -107,6 +107,9 @@ module Reflex.Dom.Builder.Immediate
|
||||
, WindowConfig (..)
|
||||
, Window (..)
|
||||
, wrapWindow
|
||||
-- * Attributes for controlling hydration
|
||||
, hydratableAttribute
|
||||
, skipHydrationAttribute
|
||||
-- * Internal
|
||||
, traverseDMapWithKeyWithAdjust'
|
||||
, hoistTraverseWithKeyWithAdjust
|
||||
@ -137,11 +140,13 @@ import Data.IntMap.Strict (IntMap)
|
||||
import Data.Maybe
|
||||
import Data.Monoid ((<>))
|
||||
import Data.Some (Some(..))
|
||||
import Data.String (IsString)
|
||||
import Data.Text (Text)
|
||||
import Foreign.JavaScript.Internal.Utils
|
||||
import Foreign.JavaScript.TH
|
||||
import GHCJS.DOM.ClipboardEvent as ClipboardEvent
|
||||
import GHCJS.DOM.Document (Document, createDocumentFragment, createElement, createElementNS, createTextNode, createComment)
|
||||
import GHCJS.DOM.Element (getScrollTop, removeAttribute, removeAttributeNS, setAttribute, setAttributeNS, hasAttribute, hasAttributeNS)
|
||||
import GHCJS.DOM.Element (getScrollTop, removeAttribute, removeAttributeNS, setAttribute, setAttributeNS, hasAttribute)
|
||||
import GHCJS.DOM.EventM (EventM, event, on)
|
||||
import GHCJS.DOM.KeyboardEvent as KeyboardEvent
|
||||
import GHCJS.DOM.MouseEvent
|
||||
@ -175,6 +180,7 @@ import qualified Data.IntMap.Strict as IntMap
|
||||
import qualified Data.Map as Map
|
||||
import qualified Data.Text as T
|
||||
import qualified GHCJS.DOM as DOM
|
||||
import qualified GHCJS.DOM.DataTransfer as DataTransfer
|
||||
import qualified GHCJS.DOM.DocumentAndElementEventHandlers as Events
|
||||
import qualified GHCJS.DOM.DocumentOrShadowRoot as Document
|
||||
import qualified GHCJS.DOM.Element as Element
|
||||
@ -192,6 +198,7 @@ import qualified GHCJS.DOM.TouchEvent as TouchEvent
|
||||
import qualified GHCJS.DOM.TouchList as TouchList
|
||||
import qualified GHCJS.DOM.Types as DOM
|
||||
import qualified GHCJS.DOM.Window as Window
|
||||
import qualified GHCJS.DOM.WheelEvent as WheelEvent
|
||||
import qualified Reflex.Patch.DMap as PatchDMap
|
||||
import qualified Reflex.Patch.DMapWithMove as PatchDMapWithMove
|
||||
import qualified Reflex.Patch.MapWithMove as PatchMapWithMove
|
||||
@ -318,8 +325,7 @@ addHydrationStepWithSetup :: (Adjustable t m, MonadIO m) => m a -> (a -> Hydrati
|
||||
addHydrationStepWithSetup setup f = getHydrationMode >>= \case
|
||||
HydrationMode_Immediate -> pure ()
|
||||
HydrationMode_Hydrating -> do
|
||||
switchover <- HydrationDomBuilderT $ asks _hydrationDomBuilderEnv_switchover
|
||||
(s, _) <- lift $ runWithReplace setup $ return () <$ switchover
|
||||
s <- lift setup
|
||||
addHydrationStep (f s)
|
||||
|
||||
-- | Add a hydration step
|
||||
@ -743,6 +749,14 @@ elementInternal elementTag cfg child = getHydrationMode >>= \case
|
||||
-> HydrationDomBuilderT HydrationDomSpace DomTimeline HydrationM (Element er HydrationDomSpace DomTimeline, a)
|
||||
#-}
|
||||
|
||||
-- | An attribute which causes hydration to skip over an element completely.
|
||||
skipHydrationAttribute :: IsString s => s
|
||||
skipHydrationAttribute = "data-hydration-skip"
|
||||
|
||||
-- | An attribute which signals that an element should be hydrated.
|
||||
hydratableAttribute :: IsString s => s
|
||||
hydratableAttribute = "data-ssr"
|
||||
|
||||
{-# INLINE hydrateElement #-}
|
||||
hydrateElement
|
||||
:: forall er t m a. (MonadJSM m, Reflex t, MonadReflexCreateTrigger t m, MonadFix m)
|
||||
@ -764,18 +778,15 @@ hydrateElement elementTag cfg child = do
|
||||
}
|
||||
result <- HydrationDomBuilderT $ lift $ runReaderT (unHydrationDomBuilderT child) env'
|
||||
wrapResult <- liftIO newEmptyMVar
|
||||
let skipAttr = "data-hydration-skip" :: DOM.JSString
|
||||
ssrAttr = "data-ssr" :: DOM.JSString
|
||||
let -- Determine if we should skip an element. We currently skip elements for
|
||||
-- two reasons:
|
||||
-- 1) it was not produced by a static builder which supports hydration
|
||||
-- 2) it is explicitly marked to be skipped
|
||||
shouldSkip :: DOM.Element -> HydrationRunnerT t m Bool
|
||||
shouldSkip e = case cfg ^. namespace of
|
||||
Nothing -> do
|
||||
skip <- hasAttribute e skipAttr
|
||||
ssr <- hasAttribute e ssrAttr
|
||||
pure $ skip || not ssr
|
||||
Just ns -> do
|
||||
skip <- hasAttributeNS e (Just ns) skipAttr
|
||||
ssr <- hasAttributeNS e (Just ns) ssrAttr
|
||||
pure $ skip || not ssr
|
||||
shouldSkip e = do
|
||||
skip <- hasAttribute e (skipHydrationAttribute :: DOM.JSString)
|
||||
hydratable <- hasAttribute e (hydratableAttribute :: DOM.JSString)
|
||||
pure $ skip || not hydratable
|
||||
childDom <- liftIO $ readIORef childDelayedRef
|
||||
let rawCfg = extractRawElementConfig cfg
|
||||
doc <- askDocument
|
||||
@ -791,7 +802,7 @@ hydrateElement elementTag cfg child = do
|
||||
Just node -> DOM.castTo DOM.Element node >>= \case
|
||||
Nothing -> go (Just node) -- this node is not an element, skip
|
||||
Just e -> shouldSkip e >>= \case
|
||||
True -> go (Just node) -- this element is explicitly marked for being skipped by hydration
|
||||
True -> go (Just node) -- this element should be skipped by hydration
|
||||
False -> do
|
||||
t <- Element.getTagName e
|
||||
-- TODO: check attributes?
|
||||
@ -1277,8 +1288,8 @@ hydrateComment doc t mSetContents = do
|
||||
skipToAndReplaceComment
|
||||
:: (MonadJSM m, Reflex t, MonadFix m, Adjustable t m, MonadHold t m, RawDocument (DomBuilderSpace (HydrationDomBuilderT s t m)) ~ Document)
|
||||
=> Text
|
||||
-> IORef Text
|
||||
-> HydrationDomBuilderT s t m (HydrationRunnerT t m (), IORef DOM.Text, IORef Text)
|
||||
-> IORef (Maybe Text)
|
||||
-> HydrationDomBuilderT s t m (HydrationRunnerT t m (), IORef DOM.Text, IORef (Maybe Text))
|
||||
skipToAndReplaceComment prefix key0Ref = getHydrationMode >>= \case
|
||||
HydrationMode_Immediate -> do
|
||||
-- If we're in immediate mode, we don't try to replace an existing comment,
|
||||
@ -1286,43 +1297,50 @@ skipToAndReplaceComment prefix key0Ref = getHydrationMode >>= \case
|
||||
t <- textNodeImmediate $ TextNodeConfig ("" :: Text) Nothing
|
||||
append $ toNode t
|
||||
textNodeRef <- liftIO $ newIORef t
|
||||
keyRef <- liftIO $ newIORef ""
|
||||
keyRef <- liftIO $ newIORef Nothing
|
||||
pure (pure (), textNodeRef, keyRef)
|
||||
HydrationMode_Hydrating -> do
|
||||
doc <- askDocument
|
||||
textNodeRef <- liftIO $ newIORef $ error "textNodeRef not yet initialized"
|
||||
keyRef <- liftIO $ newIORef $ error "keyRef not yet initialized"
|
||||
let go key0 mLastNode = do
|
||||
parent <- askParent
|
||||
node <- maybe (Node.getFirstChildUnchecked parent) Node.getNextSiblingUnchecked mLastNode
|
||||
DOM.castTo DOM.Comment node >>= \case
|
||||
let
|
||||
go Nothing _ = do
|
||||
tn <- createTextNode doc ("" :: Text)
|
||||
insertAfterPreviousNode tn
|
||||
HydrationRunnerT $ modify' $ \s -> s { _hydrationState_failed = True }
|
||||
pure (tn, Nothing)
|
||||
go (Just key0) mLastNode = do
|
||||
parent <- askParent
|
||||
maybe (Node.getFirstChild parent) Node.getNextSibling mLastNode >>= \case
|
||||
Nothing -> go Nothing Nothing
|
||||
Just node -> DOM.castTo DOM.Comment node >>= \case
|
||||
Just comment -> do
|
||||
commentText <- Node.getTextContentUnchecked comment
|
||||
case T.stripPrefix (prefix <> key0) commentText of
|
||||
commentText <- fromMaybe (error "Cannot get text content of comment node") <$> Node.getTextContent comment
|
||||
case T.stripPrefix (prefix <> key0) commentText of -- 'key0' may be @""@ in which case we're just finding the actual key; TODO: Don't be clever.
|
||||
Just key -> do
|
||||
-- Replace the comment with an (invisible) text node
|
||||
tn <- createTextNode doc ("" :: Text)
|
||||
Node.replaceChild_ parent tn comment
|
||||
pure (tn, key)
|
||||
pure (tn, Just key)
|
||||
Nothing -> do
|
||||
go key0 (Just node)
|
||||
go (Just key0) (Just node)
|
||||
Nothing -> do
|
||||
go key0 (Just node)
|
||||
switchComment = do
|
||||
key0 <- liftIO $ readIORef key0Ref
|
||||
(tn, key) <- go key0 =<< getPreviousNode
|
||||
setPreviousNode $ Just $ toNode tn
|
||||
liftIO $ do
|
||||
writeIORef textNodeRef tn
|
||||
writeIORef keyRef key
|
||||
go (Just key0) (Just node)
|
||||
switchComment = do
|
||||
key0 <- liftIO $ readIORef key0Ref
|
||||
(tn, key) <- go key0 =<< getPreviousNode
|
||||
setPreviousNode $ Just $ toNode tn
|
||||
liftIO $ do
|
||||
writeIORef textNodeRef tn
|
||||
writeIORef keyRef key
|
||||
pure (switchComment, textNodeRef, keyRef)
|
||||
|
||||
{-# INLINABLE skipToReplaceStart #-}
|
||||
skipToReplaceStart :: (MonadJSM m, Reflex t, MonadFix m, Adjustable t m, MonadHold t m, RawDocument (DomBuilderSpace (HydrationDomBuilderT s t m)) ~ Document) => HydrationDomBuilderT s t m (HydrationRunnerT t m (), IORef DOM.Text, IORef Text)
|
||||
skipToReplaceStart = skipToAndReplaceComment "replace-start" =<< liftIO (newIORef "")
|
||||
skipToReplaceStart :: (MonadJSM m, Reflex t, MonadFix m, Adjustable t m, MonadHold t m, RawDocument (DomBuilderSpace (HydrationDomBuilderT s t m)) ~ Document) => HydrationDomBuilderT s t m (HydrationRunnerT t m (), IORef DOM.Text, IORef (Maybe Text))
|
||||
skipToReplaceStart = skipToAndReplaceComment "replace-start" =<< liftIO (newIORef $ Just "") -- TODO: Don't rely on clever usage @""@ to make this work.
|
||||
|
||||
{-# INLINABLE skipToReplaceEnd #-}
|
||||
skipToReplaceEnd :: (MonadJSM m, Reflex t, MonadFix m, Adjustable t m, MonadHold t m, RawDocument (DomBuilderSpace (HydrationDomBuilderT s t m)) ~ Document) => IORef Text -> HydrationDomBuilderT s t m (HydrationRunnerT t m (), IORef DOM.Text)
|
||||
skipToReplaceEnd :: (MonadJSM m, Reflex t, MonadFix m, Adjustable t m, MonadHold t m, RawDocument (DomBuilderSpace (HydrationDomBuilderT s t m)) ~ Document) => IORef (Maybe Text) -> HydrationDomBuilderT s t m (HydrationRunnerT t m (), IORef DOM.Text)
|
||||
skipToReplaceEnd key = fmap (\(m,e,_) -> (m,e)) $ skipToAndReplaceComment "replace-end" key
|
||||
|
||||
instance SupportsHydrationDomBuilder t m => NotReady t (HydrationDomBuilderT s t m) where
|
||||
@ -2239,7 +2257,7 @@ defaultDomEventHandler e evt = fmap (Just . EventResult) $ case evt of
|
||||
Beforecopy -> return ()
|
||||
Copy -> return ()
|
||||
Beforepaste -> return ()
|
||||
Paste -> return ()
|
||||
Paste -> getPasteData
|
||||
Reset -> return ()
|
||||
Search -> return ()
|
||||
Selectstart -> return ()
|
||||
@ -2248,7 +2266,7 @@ defaultDomEventHandler e evt = fmap (Just . EventResult) $ case evt of
|
||||
Touchend -> getTouchEvent
|
||||
Touchcancel -> getTouchEvent
|
||||
Mousewheel -> return ()
|
||||
Wheel -> return ()
|
||||
Wheel -> getWheelEvent
|
||||
|
||||
{-# INLINABLE defaultDomWindowEventHandler #-}
|
||||
defaultDomWindowEventHandler :: DOM.Window -> EventName en -> EventM DOM.Window (EventType en) (Maybe (EventResult en))
|
||||
@ -2289,7 +2307,7 @@ defaultDomWindowEventHandler w evt = fmap (Just . EventResult) $ case evt of
|
||||
Beforecopy -> return ()
|
||||
Copy -> return ()
|
||||
Beforepaste -> return ()
|
||||
Paste -> return ()
|
||||
Paste -> getPasteData
|
||||
Reset -> return ()
|
||||
Search -> return ()
|
||||
Selectstart -> return ()
|
||||
@ -2298,7 +2316,7 @@ defaultDomWindowEventHandler w evt = fmap (Just . EventResult) $ case evt of
|
||||
Touchend -> getTouchEvent
|
||||
Touchcancel -> getTouchEvent
|
||||
Mousewheel -> return ()
|
||||
Wheel -> return ()
|
||||
Wheel -> getWheelEvent
|
||||
|
||||
{-# INLINABLE withIsEvent #-}
|
||||
withIsEvent :: EventName en -> (IsEvent (EventType en) => r) -> r
|
||||
@ -2566,6 +2584,15 @@ getMouseEventCoords = do
|
||||
e <- event
|
||||
bisequence (getClientX e, getClientY e)
|
||||
|
||||
{-# INLINABLE getPasteData #-}
|
||||
getPasteData :: EventM e ClipboardEvent (Maybe Text)
|
||||
getPasteData = do
|
||||
e <- event
|
||||
mdt <- ClipboardEvent.getClipboardData e
|
||||
case mdt of
|
||||
Nothing -> return Nothing
|
||||
Just dt -> Just <$> DataTransfer.getData dt ("text" :: Text)
|
||||
|
||||
{-# INLINABLE getTouchEvent #-}
|
||||
getTouchEvent :: EventM e TouchEvent TouchEventResult
|
||||
getTouchEvent = do
|
||||
@ -2607,6 +2634,26 @@ getTouchEvent = do
|
||||
, _touchEventResult_touches = touches
|
||||
}
|
||||
|
||||
{-# INLINABLE getWheelEvent #-}
|
||||
getWheelEvent :: EventM e WheelEvent WheelEventResult
|
||||
getWheelEvent = do
|
||||
e <- event
|
||||
dx :: Double <- WheelEvent.getDeltaX e
|
||||
dy :: Double <- WheelEvent.getDeltaY e
|
||||
dz :: Double <- WheelEvent.getDeltaZ e
|
||||
deltaMode :: Word <- WheelEvent.getDeltaMode e
|
||||
return $ WheelEventResult
|
||||
{ _wheelEventResult_deltaX = dx
|
||||
, _wheelEventResult_deltaY = dy
|
||||
, _wheelEventResult_deltaZ = dz
|
||||
, _wheelEventResult_deltaMode = case deltaMode of
|
||||
0 -> DeltaPixel
|
||||
1 -> DeltaLine
|
||||
2 -> DeltaPage
|
||||
-- See https://developer.mozilla.org/en-US/docs/Web/API/WheelEvent/deltaMode
|
||||
_ -> error "getWheelEvent: impossible encoding"
|
||||
}
|
||||
|
||||
instance MonadSample t m => MonadSample t (HydrationDomBuilderT s t m) where
|
||||
{-# INLINABLE sample #-}
|
||||
sample = lift . sample
|
||||
|
||||
@ -55,7 +55,6 @@ import Reflex.PerformEvent.Class
|
||||
import Reflex.PostBuild.Base
|
||||
import Reflex.PostBuild.Class
|
||||
import Reflex.TriggerEvent.Class
|
||||
import System.Random (randomRIO)
|
||||
|
||||
data StaticDomBuilderEnv t = StaticDomBuilderEnv
|
||||
{ _staticDomBuilderEnv_shouldEscape :: Bool
|
||||
@ -64,6 +63,7 @@ data StaticDomBuilderEnv t = StaticDomBuilderEnv
|
||||
-- We use this to add a "selected" attribute to the appropriate "option" child element.
|
||||
-- This is not yet a perfect simulation of what the browser does, but it is much closer than doing nothing.
|
||||
-- TODO: Handle edge cases, e.g. setting to a value for which there is no option, then adding that option dynamically afterwards.
|
||||
, _staticDomBuilderEnv_nextRunWithReplaceKey :: IORef Int
|
||||
}
|
||||
|
||||
newtype StaticDomBuilderT t m a = StaticDomBuilderT
|
||||
@ -164,7 +164,7 @@ instance (SupportsStaticDomBuilder t m, Monad m) => HasDocument (StaticDomBuilde
|
||||
instance (Reflex t, Adjustable t m, MonadHold t m, SupportsStaticDomBuilder t m) => Adjustable t (StaticDomBuilderT t m) where
|
||||
runWithReplace a0 a' = do
|
||||
e <- StaticDomBuilderT ask
|
||||
key <- replaceStart
|
||||
key <- replaceStart e
|
||||
(result0, result') <- lift $ runWithReplace (runStaticDomBuilderT a0 e) (flip runStaticDomBuilderT e <$> a')
|
||||
o <- hold (snd result0) $ fmapCheap snd result'
|
||||
StaticDomBuilderT $ modify $ (:) $ join o
|
||||
@ -174,10 +174,9 @@ instance (Reflex t, Adjustable t m, MonadHold t m, SupportsStaticDomBuilder t m)
|
||||
traverseDMapWithKeyWithAdjust = hoistDMapWithKeyWithAdjust traverseDMapWithKeyWithAdjust mapPatchDMap
|
||||
traverseDMapWithKeyWithAdjustWithMove = hoistDMapWithKeyWithAdjust traverseDMapWithKeyWithAdjustWithMove mapPatchDMapWithMove
|
||||
|
||||
-- TODO remove this?
|
||||
replaceStart :: (DomBuilder t m, MonadIO m) => m Text
|
||||
replaceStart = do
|
||||
str <- liftIO $ replicateM 8 $ randomRIO ('a', 'z')
|
||||
replaceStart :: (DomBuilder t m, MonadIO m) => StaticDomBuilderEnv t -> m Text
|
||||
replaceStart env = do
|
||||
str <- show <$> liftIO (atomicModifyRef (_staticDomBuilderEnv_nextRunWithReplaceKey env) $ \k -> (succ k, k))
|
||||
let key = "-" <> T.pack str
|
||||
_ <- commentNode $ def { _commentNodeConfig_initialContents = "replace-start" <> key }
|
||||
pure key
|
||||
@ -287,7 +286,8 @@ instance SupportsStaticDomBuilder t m => DomBuilder t (StaticDomBuilderT t m) wh
|
||||
es <- newFanEventWithTrigger $ \_ _ -> return (return ())
|
||||
StaticDomBuilderT $ do
|
||||
let shouldEscape = elementTag `Set.notMember` noEscapeElements
|
||||
(result, innerHtml) <- lift $ lift $ runStaticDomBuilderT child $ StaticDomBuilderEnv shouldEscape Nothing
|
||||
nextRunWithReplaceKey <- asks _staticDomBuilderEnv_nextRunWithReplaceKey
|
||||
(result, innerHtml) <- lift $ lift $ runStaticDomBuilderT child $ StaticDomBuilderEnv shouldEscape Nothing nextRunWithReplaceKey
|
||||
attrs0 <- foldDyn applyMap (cfg ^. initialAttributes) (cfg ^. modifyAttributes)
|
||||
selectValue <- asks _staticDomBuilderEnv_selectValue
|
||||
let addSelectedAttr attrs sel = case Map.lookup "value" attrs of
|
||||
@ -341,7 +341,9 @@ instance SupportsStaticDomBuilder t m => DomBuilder t (StaticDomBuilderT t m) wh
|
||||
selectElement cfg child = do
|
||||
v <- holdDyn (cfg ^. selectElementConfig_initialValue) (cfg ^. selectElementConfig_setValue)
|
||||
(e, result) <- element "select" (_selectElementConfig_elementConfig cfg) $ do
|
||||
(a, innerHtml) <- StaticDomBuilderT $ lift $ lift $ runStaticDomBuilderT child $ StaticDomBuilderEnv False $ Just (current v)
|
||||
(a, innerHtml) <- StaticDomBuilderT $ do
|
||||
nextRunWithReplaceKey <- asks _staticDomBuilderEnv_nextRunWithReplaceKey
|
||||
lift $ lift $ runStaticDomBuilderT child $ StaticDomBuilderEnv False (Just $ current v) nextRunWithReplaceKey
|
||||
StaticDomBuilderT $ lift $ modify $ (:) innerHtml
|
||||
return a
|
||||
let wrapped = SelectElement
|
||||
@ -363,7 +365,8 @@ renderStatic :: StaticWidget x a -> IO (a, ByteString)
|
||||
renderStatic w = do
|
||||
runDomHost $ do
|
||||
(postBuild, postBuildTriggerRef) <- newEventWithTriggerRef
|
||||
let env0 = StaticDomBuilderEnv True Nothing
|
||||
nextRunWithReplaceKey <- newRef 0
|
||||
let env0 = StaticDomBuilderEnv True Nothing nextRunWithReplaceKey
|
||||
((res, bs), FireCommand fire) <- hostPerformEventT $ runStaticDomBuilderT (runPostBuildT w postBuild) env0
|
||||
mPostBuildTrigger <- readRef postBuildTriggerRef
|
||||
forM_ mPostBuildTrigger $ \postBuildTrigger -> fire [postBuildTrigger :=> Identity ()] $ return ()
|
||||
|
||||
@ -4,8 +4,7 @@ module Reflex.Dom.Class ( module Reflex.Dom.Class
|
||||
, module Web.KeyCode
|
||||
) where
|
||||
|
||||
import Data.Map (Map)
|
||||
import qualified Data.Map as Map
|
||||
import Control.Lens
|
||||
import Reflex.Class
|
||||
import Web.KeyCode
|
||||
|
||||
@ -13,11 +12,9 @@ import Foreign.JavaScript.TH
|
||||
import Reflex.PerformEvent.Class
|
||||
import Reflex.PostBuild.Class
|
||||
|
||||
import Prelude hiding (concat, mapM, mapM_, sequence)
|
||||
|
||||
-- | Alias for Data.Map.singleton
|
||||
(=:) :: k -> a -> Map k a
|
||||
(=:) = Map.singleton
|
||||
-- | Previously an alias for 'Data.Map.singleton', but now generalised to 'At'
|
||||
(=:) :: (At m, Monoid m) => Index m -> IxValue m -> m
|
||||
k =: a = at k ?~ a $ mempty
|
||||
infixr 7 =: -- Ought to bind tighter than <>, which is infixr 6
|
||||
|
||||
{-# DEPRECATED keycodeEnter "Instead of `x == keycodeEnter`, use `keyCodeLookup x == Enter`" #-}
|
||||
|
||||
@ -138,7 +138,6 @@ dynComment t = do
|
||||
display :: (PostBuild t m, DomBuilder t m, Show a) => Dynamic t a -> m ()
|
||||
display = dynText . fmap (T.pack . show)
|
||||
|
||||
{-# DEPRECATED button "Use 'elAttr'' in combination with 'domEvent' instead" #-}
|
||||
button :: DomBuilder t m => Text -> m (Event t ())
|
||||
button t = do
|
||||
(e, _) <- element "button" def $ text t
|
||||
@ -272,25 +271,21 @@ dynamicAttributesToModifyAttributesWithInitial attrs0 d = do
|
||||
return $ if Map.null p then Nothing else Just p
|
||||
return modificationsNeeded
|
||||
|
||||
{-# DEPRECATED Link "Will be removed when 'linkClass' and 'link' are removed. Follow those functions' deprecation instructions." #-}
|
||||
newtype Link t
|
||||
= Link { _link_clicked :: Event t ()
|
||||
}
|
||||
|
||||
{-# DEPRECATED linkClass "Use 'elAttr'' in combination with 'domEvent' for just clicks. Use 'routeLink' for Obelisk navigation" #-}
|
||||
linkClass :: DomBuilder t m => Text -> Text -> m (Link t)
|
||||
linkClass s c = do
|
||||
(l,_) <- elAttr' "a" ("class" =: c) $ text s
|
||||
return $ Link $ domEvent Click l
|
||||
|
||||
{-# DEPRECATED link "Use 'elAttr'' in combination with 'domEvent' for just clicks. Use 'routeLink' for Obelisk navigation" #-}
|
||||
link :: DomBuilder t m => Text -> m (Link t)
|
||||
link s = linkClass s ""
|
||||
|
||||
divClass :: forall t m a. DomBuilder t m => Text -> m a -> m a
|
||||
divClass = elClass "div"
|
||||
|
||||
{-# DEPRECATED dtdd "Use an application specific widget generating function" #-}
|
||||
dtdd :: forall t m a. DomBuilder t m => Text -> m a -> m a
|
||||
dtdd h w = do
|
||||
el "dt" $ text h
|
||||
@ -301,7 +296,6 @@ blank = return ()
|
||||
|
||||
-- TODO: Move to an example project.
|
||||
-- | A widget to display a table with static columns and dynamic rows.
|
||||
{-# DEPRECATED tableDynAttr "Use an application specific widget generating function" #-}
|
||||
tableDynAttr :: forall t m r k v. (Ord k, DomBuilder t m, MonadHold t m, PostBuild t m, MonadFix m)
|
||||
=> Text -- ^ Class applied to <table> element
|
||||
-> [(Text, k -> Dynamic t r -> m v)] -- ^ Columns of (header, row key -> row value -> child widget)
|
||||
@ -321,7 +315,6 @@ tableDynAttr klass cols dRows rowAttrs = elAttr "div" (Map.singleton "style" "zo
|
||||
-- | A widget to construct a tabbed view that shows only one of its child widgets at a time.
|
||||
-- Creates a header bar containing a <ul> with one <li> per child; clicking a <li> displays
|
||||
-- the corresponding child and hides all others.
|
||||
{-# DEPRECATED tabDisplay "Use an application specific widget generating function" #-}
|
||||
tabDisplay :: forall t m k. (MonadFix m, DomBuilder t m, MonadHold t m, PostBuild t m, Ord k)
|
||||
=> Text -- ^ Class applied to <ul> element
|
||||
-> Text -- ^ Class applied to currently active <li> element
|
||||
|
||||
@ -437,9 +437,12 @@ dropdown k0 options (DropdownConfig setK attrs) = do
|
||||
let xs = fmap (\(ix, (k, v)) -> ((ix, k), ((ix, k), v))) $ zip [0::Int ..] $ Map.toList os
|
||||
in (Map.fromList $ map snd xs, Bimap.fromList $ map fst xs)
|
||||
modifyAttrs <- dynamicAttributesToModifyAttributes attrs
|
||||
postBuild <- getPostBuild
|
||||
let setSelection = attachPromptlyDynWithMaybe (flip Bimap.lookupR) ixKeys $
|
||||
leftmost [setK, k0 <$ postBuild]
|
||||
let cfg = def
|
||||
& selectElementConfig_elementConfig . elementConfig_modifyAttributes .~ fmap mapKeysToAttributeName modifyAttrs
|
||||
& selectElementConfig_setValue .~ fmap (T.pack . show) (attachPromptlyDynWithMaybe (flip Bimap.lookupR) ixKeys setK)
|
||||
& selectElementConfig_setValue .~ fmap (T.pack . show) setSelection
|
||||
(eRaw, _) <- selectElement cfg $ listWithKey indexedOptions $ \(ix, k) v -> do
|
||||
let optionAttrs = fmap (\dk -> "value" =: T.pack (show ix) <> if dk == k then "selected" =: "selected" else mempty) defaultKey
|
||||
elDynAttr "option" optionAttrs $ dynText v
|
||||
|
||||
@ -37,19 +37,19 @@ import qualified GHCJS.DOM.Types as DOM
|
||||
-- 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 (), a)
|
||||
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 = resizeDetectorWithStyle ""
|
||||
|
||||
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 (), a) -- ^ An 'Event' that fires on resize, and the result of 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 styleString = resizeDetectorWithAttrs ("style" =: 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 (), a) -- ^ An 'Event' that fires on resize, and the result of 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 attrs w = do
|
||||
let childStyle = "position: absolute; left: 0; top: 0;"
|
||||
containerAttrs = "style" =: "position: absolute; left: 0; top: 0; right: 0; bottom: 0; overflow: scroll; z-index: -1; visibility: hidden;"
|
||||
@ -91,4 +91,4 @@ resizeDetectorWithAttrs attrs w = do
|
||||
size0 <- performEvent $ fmap (const $ liftJSM reset) pb
|
||||
rec resize <- performEventAsync $ fmap (\d cb -> (liftIO . cb) =<< liftJSM (resetIfChanged d)) $ tag (current dimensions) $ leftmost [expandScroll, shrinkScroll]
|
||||
dimensions <- holdDyn (Nothing, Nothing) $ leftmost [ size0, fmapMaybe id resize ]
|
||||
return (fmapMaybe void resize, w')
|
||||
return (updated dimensions, w')
|
||||
|
||||
@ -159,6 +159,8 @@ import Data.Aeson.Text
|
||||
import Data.Aeson.Encode
|
||||
#endif
|
||||
import qualified Data.ByteString.Lazy as BL
|
||||
import Data.CaseInsensitive (CI)
|
||||
import qualified Data.CaseInsensitive as CI
|
||||
import Data.Default
|
||||
import qualified Data.List as L
|
||||
import Data.Map (Map)
|
||||
@ -198,12 +200,12 @@ data XhrResponse
|
||||
, _xhrResponse_statusText :: Text
|
||||
, _xhrResponse_response :: Maybe XhrResponseBody
|
||||
, _xhrResponse_responseText :: Maybe Text
|
||||
, _xhrResponse_headers :: Map Text Text
|
||||
, _xhrResponse_headers :: Map (CI Text) Text
|
||||
}
|
||||
deriving (Typeable)
|
||||
|
||||
data XhrResponseHeaders =
|
||||
OnlyHeaders (Set.Set Text) -- ^ Parse a subset of headers from the XHR Response
|
||||
OnlyHeaders (Set.Set (CI Text)) -- ^ Parse a subset of headers from the XHR Response
|
||||
| AllHeaders -- ^ Parse all headers from the XHR Response
|
||||
deriving (Show, Read, Eq, Ord, Typeable)
|
||||
|
||||
@ -275,7 +277,7 @@ newXMLHttpRequestWithError req cb = do
|
||||
AllHeaders -> parseAllHeadersString <$>
|
||||
xmlHttpRequestGetAllResponseHeaders xhr
|
||||
OnlyHeaders xs -> traverse (xmlHttpRequestGetResponseHeader xhr)
|
||||
(Map.fromSet id xs)
|
||||
(Map.fromSet CI.original xs)
|
||||
_ <- liftJSM $ cb $ Right
|
||||
XhrResponse { _xhrResponse_status = status
|
||||
, _xhrResponse_statusText = statusText
|
||||
@ -288,10 +290,10 @@ newXMLHttpRequestWithError req cb = do
|
||||
return ()
|
||||
return xhr
|
||||
|
||||
parseAllHeadersString :: Text -> Map Text Text
|
||||
parseAllHeadersString :: Text -> Map (CI Text) Text
|
||||
parseAllHeadersString s = Map.fromList $ fmap (stripBoth . T.span (/=':')) $
|
||||
L.dropWhileEnd T.null $ T.splitOn (T.pack "\r\n") s
|
||||
where stripBoth (txt1, txt2) = (T.strip txt1, T.strip $ T.drop 1 txt2)
|
||||
where stripBoth (txt1, txt2) = (CI.mk $ T.strip txt1, T.strip $ T.drop 1 txt2)
|
||||
|
||||
newXMLHttpRequest :: (HasJSContext m, MonadJSM m, IsXhrPayload a) => XhrRequest a -> (XhrResponse -> JSM ()) -> m XMLHttpRequest
|
||||
newXMLHttpRequest req cb = newXMLHttpRequestWithError req $ mapM_ cb
|
||||
@ -444,7 +446,7 @@ xhrResponse_responseText :: Lens' XhrResponse (Maybe Text)
|
||||
xhrResponse_responseText f (XhrResponse x1 x2 x3 x4 x5) = (\y -> XhrResponse x1 x2 x3 y x5) <$> f x4
|
||||
{-# INLINE xhrResponse_responseText #-}
|
||||
|
||||
xhrResponse_headers :: Lens' XhrResponse (Map Text Text)
|
||||
xhrResponse_headers :: Lens' XhrResponse (Map (CI Text) Text)
|
||||
xhrResponse_headers f (XhrResponse x1 x2 x3 x4 x5) = (\y -> XhrResponse x1 x2 x3 x4 y) <$> f x5
|
||||
{-# INLINE xhrResponse_headers #-}
|
||||
|
||||
|
||||
@ -1,13 +1,9 @@
|
||||
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
||||
{-# LANGUAGE BangPatterns #-}
|
||||
{-# LANGUAGE StandaloneDeriving #-}
|
||||
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
|
||||
{-# LANGUAGE UndecidableInstances #-}
|
||||
{-# LANGUAGE ConstraintKinds #-}
|
||||
{-# LANGUAGE CPP #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE GADTs #-}
|
||||
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
@ -15,13 +11,19 @@
|
||||
{-# LANGUAGE RankNTypes #-}
|
||||
{-# LANGUAGE RecursiveDo #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE StandaloneDeriving #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
{-# LANGUAGE TupleSections #-}
|
||||
{-# LANGUAGE TypeApplications #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
{-# LANGUAGE UndecidableInstances #-}
|
||||
|
||||
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
||||
|
||||
import Prelude hiding (fail)
|
||||
import Control.Concurrent
|
||||
import qualified Control.Concurrent.Async as Async
|
||||
import Control.Lens.Operators
|
||||
import Control.Monad hiding (fail)
|
||||
import Control.Monad.Catch
|
||||
import Control.Monad.Fail
|
||||
@ -31,12 +33,13 @@ import Control.Monad.Ref
|
||||
import Data.Constraint.Extras
|
||||
import Data.Constraint.Extras.TH
|
||||
import Data.Dependent.Map (DMap)
|
||||
import Data.Dependent.Sum (DSum(..), (==>), EqTag(..), ShowTag(..))
|
||||
import Data.Dependent.Sum (DSum(..), (==>))
|
||||
import Data.Functor.Identity
|
||||
import Data.Functor.Misc
|
||||
import Data.GADT.Compare.TH
|
||||
import Data.GADT.Show.TH
|
||||
import Data.IORef (IORef)
|
||||
import Data.List (sort)
|
||||
import Data.Maybe
|
||||
import Data.Proxy
|
||||
import Data.Text (Text)
|
||||
@ -47,6 +50,7 @@ import Network.Socket
|
||||
import Network.Wai
|
||||
import Network.WebSockets
|
||||
import Reflex.Dom.Core
|
||||
import Reflex.Dom.Widget.Input (dropdown)
|
||||
import Reflex.Patch.DMapWithMove
|
||||
import System.Directory
|
||||
import System.Environment
|
||||
@ -55,14 +59,13 @@ import System.IO.Silently
|
||||
import System.IO.Temp
|
||||
import System.Process
|
||||
import System.Which (staticWhich)
|
||||
import qualified Test.HUnit as HUnit (assertEqual, assertFailure)
|
||||
import qualified Test.HUnit as HUnit
|
||||
import qualified Test.Hspec as H
|
||||
import qualified Test.Hspec.Core.Spec as H
|
||||
import Test.Hspec (xit)
|
||||
import Test.Hspec.WebDriver hiding (runWD, click, uploadFile, WD)
|
||||
import qualified Test.Hspec.WebDriver as WD
|
||||
import Test.WebDriver (WD(..))
|
||||
import Test.WebDriver.Exceptions (ServerError(..))
|
||||
|
||||
import qualified Data.ByteString.Lazy as LBS
|
||||
import qualified Data.Dependent.Map as DMap
|
||||
@ -78,6 +81,9 @@ import qualified Test.WebDriver.Capabilities as WD
|
||||
import Test.Util.ChromeFlags
|
||||
import Test.Util.UnshareNetwork
|
||||
|
||||
-- ORPHAN: https://github.com/kallisti-dev/hs-webdriver/pull/167
|
||||
deriving instance MonadMask WD
|
||||
|
||||
chromium :: FilePath
|
||||
chromium = $(staticWhich "chromium")
|
||||
|
||||
@ -93,11 +99,14 @@ instance MonadRef WD where
|
||||
writeRef r = WD . writeRef r
|
||||
|
||||
assertEqual :: (MonadIO m, Eq a, Show a) => String -> a -> a -> m ()
|
||||
assertEqual a b = liftIO . HUnit.assertEqual a b
|
||||
assertEqual msg a b = liftIO $ HUnit.assertEqual msg a b
|
||||
|
||||
assertFailure :: MonadIO m => String -> m ()
|
||||
assertFailure = liftIO . HUnit.assertFailure
|
||||
|
||||
assertBool :: (MonadIO m) => String -> Bool -> m ()
|
||||
assertBool msg bool = liftIO $ HUnit.assertBool msg bool
|
||||
|
||||
chromeConfig :: Text -> [Text] -> WD.WDConfig
|
||||
chromeConfig fp flags = WD.useBrowser (WD.chrome { WD.chromeBinary = Just $ T.unpack fp, WD.chromeOptions = T.unpack <$> flags }) WD.defaultConfig
|
||||
|
||||
@ -770,6 +779,15 @@ tests withDebugging wdConfig caps _selenium = do
|
||||
prerender_ (pure ()) (liftIO $ trigger "Client")
|
||||
textNode $ TextNodeConfig "Initial" $ Just e
|
||||
|
||||
describe "namespaces" $ session' $ do
|
||||
it "dyn can be nested in namespaced widget" $ runWD $ do
|
||||
testWidget (pure ()) (checkTextInTag "svg" "one") $ do
|
||||
let svgRootCfg = def
|
||||
& (elementConfig_namespace ?~ "http://www.w3.org/2000/svg")
|
||||
& (elementConfig_initialAttributes .~ ("width" =: "100%" <> "height" =: "100%" <> "viewBox" =: "0 0 1536 2048"))
|
||||
void $ element "svg" svgRootCfg $ do
|
||||
dyn_ $ text "one" <$ pure ()
|
||||
|
||||
describe "runWithReplace" $ session' $ do
|
||||
it "works" $ runWD $ do
|
||||
replaceChan :: Chan Text <- liftIO newChan
|
||||
@ -914,6 +932,58 @@ tests withDebugging wdConfig caps _selenium = do
|
||||
, el "span" . text <$> replace
|
||||
]
|
||||
|
||||
let checkInnerHtml t x = findElemWithRetry (WD.ByTag t) >>= (`attr` "innerHTML") >>= (`shouldBe` Just x)
|
||||
it "removes bracketing comments" $ runWD $ do
|
||||
replaceChan :: Chan () <- liftIO newChan
|
||||
let
|
||||
preSwitchover = checkInnerHtml "div" "before|<!--replace-start-0-->inner1<!--replace-end-0-->|after"
|
||||
check () = do
|
||||
liftIO $ writeChan replaceChan () -- trigger creation of p tag
|
||||
_ <- findElemWithRetry $ WD.ByTag "p" -- wait till p tag is created
|
||||
checkInnerHtml "div" "before|<p>inner2</p>|after"
|
||||
testWidget' preSwitchover check $ do
|
||||
replace <- triggerEventWithChan replaceChan
|
||||
el "div" $ do
|
||||
text "before|"
|
||||
_ <- runWithReplace (text "inner1") $ el "p" (text "inner2") <$ replace
|
||||
text "|after"
|
||||
it "ignores extra ending bracketing comment" $ runWD $ do
|
||||
replaceChan :: Chan () <- liftIO newChan
|
||||
let
|
||||
preSwitchover = checkInnerHtml "div" "before|<!--replace-start-0-->inner1<!--replace-end-0--><!--replace-end-0-->|after"
|
||||
check () = do
|
||||
liftIO $ writeChan replaceChan () -- trigger creation of p tag
|
||||
_ <- findElemWithRetry $ WD.ByTag "p" -- wait till p tag is created
|
||||
checkInnerHtml "div" "before|inner2|after"
|
||||
testWidget' preSwitchover check $ do
|
||||
replace <- triggerEventWithChan replaceChan
|
||||
el "div" $ do
|
||||
text "before|"
|
||||
_ <- runWithReplace (text "inner1" *> comment "replace-end-0") $ text "inner2" <$ replace
|
||||
text "|after"
|
||||
void $ runWithReplace blank $ el "p" blank <$ replace -- Signal tag for end of test
|
||||
it "ignores missing ending bracketing comments" $ runWD $ do
|
||||
replaceChan :: Chan () <- liftIO newChan
|
||||
let
|
||||
preSwitchover = do
|
||||
checkInnerHtml "div" "before|<!--replace-start-0-->inner1<!--replace-end-0-->|after"
|
||||
divEl <- findElemWithRetry (WD.ByTag "div")
|
||||
let wrongHtml = "<!--replace-start-0-->inner1"
|
||||
actualHtml :: String <- WD.executeJS
|
||||
[WD.JSArg divEl, WD.JSArg wrongHtml]
|
||||
"arguments[0].innerHTML = arguments[1]; return arguments[0].innerHTML"
|
||||
actualHtml `shouldBe` wrongHtml
|
||||
check () = do
|
||||
liftIO $ writeChan replaceChan () -- trigger creation of p tag
|
||||
_ <- findElemWithRetry $ WD.ByTag "p" -- wait till p tag is created
|
||||
checkInnerHtml "div" "before|<p>inner2</p>|after"
|
||||
testWidget' preSwitchover check $ do
|
||||
replace <- triggerEventWithChan replaceChan
|
||||
el "div" $ do
|
||||
text "before|"
|
||||
_ <- runWithReplace (text "inner1") $ el "p" (text "inner2") <$ replace
|
||||
text "|after"
|
||||
|
||||
describe "traverseDMapWithKeyWithAdjust" $ session' $ do
|
||||
let widget :: DomBuilder t m => DKey a -> Identity a -> m (Identity a)
|
||||
widget k (Identity v) = elAttr "li" ("id" =: textKey k) $ do
|
||||
@ -1230,6 +1300,29 @@ tests withDebugging wdConfig caps _selenium = do
|
||||
el "ol" $ text "inner"
|
||||
text "after"
|
||||
|
||||
-- TODO: This test presupposes the exact set of labels that "dropdown" places in the "value" fields to distinguish options.
|
||||
-- This dependence on internal implementation details is undesirable in a test case, but seems fairly tricky to avoid.
|
||||
-- It seems expedient for the time being to expect this test case to be updated, should those implementation details ever change.
|
||||
describe "dropdown" $ session' $ do
|
||||
let doTest expectedOpts (initialValue :: Text) = do
|
||||
let doCheck = do
|
||||
es <- findElemsWithRetry $ WD.ByTag "option"
|
||||
opts <- mapM fetchElement es
|
||||
assertEqual "missing/extra/incorrect option element(s)" expectedOpts (sort opts)
|
||||
testWidget doCheck doCheck $ do
|
||||
void $ dropdown initialValue (constDyn (("aa" :: Text) =: "aaa" <> "bb" =: "bbb")) def
|
||||
fetchElement e = do
|
||||
val <- WD.attr e "value"
|
||||
sel <- WD.attr e "selected"
|
||||
return (fromMaybe "" val, isJust sel)
|
||||
-- The "aa" test case is important, but a good test implementation probably needs to avoid selenium, because HTML parsers will insert a "selected" attribute on the first "option" tag if no selected attributes are present; thus as written, this erroneously succeeds on the old implementation (but properly implemented, should fail)
|
||||
-- Thus, it would appear that we do actually need a HTML5 or maybe XML parser for this test suite.
|
||||
xit "statically renders initial values (on aa)" $ runWD $ do
|
||||
doTest [("0",True),("1",False)] "aa"
|
||||
-- These tests are currently marked "pending" (by using "xit" instead of "it") because this test has a high chance of non-deterministically failing, which is a problem elsewhere in this test suite as well
|
||||
xit "statically renders initial values (on bb)" $ runWD $ do
|
||||
doTest [("0",False),("1",True)] "bb"
|
||||
|
||||
data Selenium = Selenium
|
||||
{ _selenium_portNumber :: PortNumber
|
||||
, _selenium_stopServer :: IO ()
|
||||
@ -1297,6 +1390,9 @@ checkTextInId i expected = do
|
||||
findElemWithRetry :: Selector -> WD WD.Element
|
||||
findElemWithRetry = withRetry . WD.findElem
|
||||
|
||||
findElemsWithRetry :: Selector -> WD [WD.Element]
|
||||
findElemsWithRetry = withRetry . WD.findElems
|
||||
|
||||
getBody :: WD WD.Element
|
||||
getBody = WD.findElem $ WD.ByTag "body"
|
||||
|
||||
@ -1305,8 +1401,8 @@ withRetry a = wait 300
|
||||
where wait :: Int -> WD a
|
||||
wait 0 = a
|
||||
wait n = try a >>= \case
|
||||
Left (_ :: SomeException) -> do
|
||||
liftIO $ threadDelay 100000
|
||||
Left (e :: SomeException) -> do
|
||||
liftIO $ putStrLn ("(retrying due to " <> show e <> ")") *> threadDelay 100000
|
||||
wait $ n - 1
|
||||
Right v -> return v
|
||||
|
||||
@ -1388,23 +1484,26 @@ testWidgetDebug' withDebugging beforeJS afterSwitchover bodyWidget = do
|
||||
]
|
||||
-- hSilence to get rid of ConnectionClosed logs
|
||||
silenceIfDebug = if withDebugging then id else hSilence [stderr]
|
||||
jsaddleWarp = forkIO $ silenceIfDebug $ Warp.runSettings settings application
|
||||
jsaddleTid <- liftIO jsaddleWarp
|
||||
putStrLnDebug "taking waitJSaddle"
|
||||
liftIO $ takeMVar waitJSaddle
|
||||
putStrLnDebug "opening page"
|
||||
WD.openPage $ "http://localhost:" <> show jsaddlePort
|
||||
putStrLnDebug "running beforeJS"
|
||||
a <- beforeJS
|
||||
putStrLnDebug "putting waitBeforeJS"
|
||||
liftIO $ putMVar waitBeforeJS ()
|
||||
putStrLnDebug "taking waitUntilSwitchover"
|
||||
liftIO $ takeMVar waitUntilSwitchover
|
||||
putStrLnDebug "running afterSwitchover"
|
||||
b <- afterSwitchover a
|
||||
putStrLnDebug "killing jsaddle thread"
|
||||
liftIO $ killThread jsaddleTid
|
||||
return b
|
||||
jsaddleWarp = silenceIfDebug $ Warp.runSettings settings application
|
||||
withAsync' jsaddleWarp $ do
|
||||
putStrLnDebug "taking waitJSaddle"
|
||||
liftIO $ takeMVar waitJSaddle
|
||||
putStrLnDebug "opening page"
|
||||
WD.openPage $ "http://localhost:" <> show jsaddlePort
|
||||
putStrLnDebug "running beforeJS"
|
||||
a <- beforeJS
|
||||
putStrLnDebug "putting waitBeforeJS"
|
||||
liftIO $ putMVar waitBeforeJS ()
|
||||
putStrLnDebug "taking waitUntilSwitchover"
|
||||
liftIO $ takeMVar waitUntilSwitchover
|
||||
putStrLnDebug "running afterSwitchover"
|
||||
afterSwitchover a
|
||||
|
||||
withAsync' :: (MonadIO m, MonadMask m) => IO a -> m b -> m b
|
||||
withAsync' f g = bracket
|
||||
(liftIO $ Async.async f)
|
||||
(liftIO . Async.uninterruptibleCancel)
|
||||
(const g)
|
||||
|
||||
data Key2 a where
|
||||
Key2_Int :: Int -> Key2 Int
|
||||
|
||||
@ -1,5 +1,17 @@
|
||||
# Revision history for reflex-dom
|
||||
|
||||
## 0.6.0.0
|
||||
|
||||
* ([#379](https://github.com/reflex-frp/reflex-dom/pull/379)) Re-export all modules from `reflex-dom-core`. The newly re-exported modules are:
|
||||
* `Foreign.JavaScript.Utils`
|
||||
* `Reflex.Dom.Builder.Hydratable`
|
||||
* `Reflex.Dom.Modals.Class`
|
||||
* `Reflex.Dom.Prerender`
|
||||
* `Reflex.Dom.Time`
|
||||
* `Reflex.Dom.WebSocket.Query`
|
||||
* `Reflex.Dom.Xhr.FormData`
|
||||
* ([#366](https://github.com/reflex-frp/reflex-dom/pull/366)) Bump bounds for `reflex` to include 0.7.
|
||||
|
||||
## 0.5.3
|
||||
|
||||
* On Android, enable prompting the user for geolocation
|
||||
@ -18,4 +30,5 @@
|
||||
## 0.5
|
||||
|
||||
* Re-export new hydration widget "mainWidget" functions.
|
||||
|
||||
* The use-warp flag now properly takes precedence on macOS.
|
||||
|
||||
@ -15,8 +15,9 @@ import qualified Data.Text as T
|
||||
import Reflex.Dom
|
||||
import System.Random
|
||||
import qualified Data.Map as Map
|
||||
import Data.Dependent.Map (DMap (..), DSum (..))
|
||||
import Data.Dependent.Map (DMap (..))
|
||||
import qualified Data.Dependent.Map as DMap
|
||||
import Data.Dependent.Sum (DSum (..))
|
||||
import Data.Functor.Misc
|
||||
import Data.Functor.Identity
|
||||
import Data.Functor.Compose
|
||||
|
||||
@ -1,10 +1,16 @@
|
||||
cabal-version: 1.24
|
||||
Name: reflex-dom
|
||||
Version: 0.5.3
|
||||
Version: 0.6.0.0
|
||||
Synopsis: Functional Reactive Web Apps with Reflex
|
||||
Description:
|
||||
Reflex-DOM is a Functional Reactive web framework based on the Reflex FRP engine.
|
||||
Reflex-DOM is a Functional Reactive web framework based on the Reflex FRP engine: <https://reflex-frp.org/>.
|
||||
.
|
||||
For hackage documentation, please see: <https://hackage.haskell.org/package/reflex-dom-core>.
|
||||
The @reflex-dom@ package is a small wrapper around the @reflex-dom-core@ package. It pulls in the
|
||||
correct set of dependencies for each target platform (GHCJS, WebKitGTK, WASM, mobile, etc.).
|
||||
Libraries should depend on @reflex-dom-core@ and executables will usually depend on @reflex-dom@.
|
||||
All of @reflex-dom-core@'s modules are re-exported by @reflex-dom@.
|
||||
.
|
||||
For Hackage documentation, please see: <https://hackage.haskell.org/package/reflex-dom-core>.
|
||||
License: BSD3
|
||||
License-file: LICENSE
|
||||
Author: Ryan Trinkle
|
||||
@ -12,7 +18,6 @@ Maintainer: ryan.trinkle@gmail.com
|
||||
Stability: Experimental
|
||||
Category: FRP, Web, GUI, HTML, Javascript, Reactive, Reactivity, User Interfaces, User-interface
|
||||
Build-type: Simple
|
||||
cabal-version: >=1.24
|
||||
extra-source-files:
|
||||
java/org/reflexfrp/reflexdom/MainWidget.java
|
||||
ChangeLog.md
|
||||
@ -41,55 +46,67 @@ flag build-examples
|
||||
default: False
|
||||
manual: True
|
||||
|
||||
flag wasm32
|
||||
description: Build for wasm32 architecture
|
||||
default: False
|
||||
manual: True
|
||||
|
||||
library
|
||||
hs-source-dirs: src
|
||||
if os(android)
|
||||
hs-source-dirs: src-android
|
||||
other-modules: Reflex.Dom.Android.MainWidget
|
||||
build-depends:
|
||||
aeson,
|
||||
aeson >= 1.4 && < 1.5,
|
||||
android-activity == 0.1.*,
|
||||
data-default == 0.7.*,
|
||||
jsaddle
|
||||
jsaddle >= 0.9.6 && < 0.10
|
||||
c-sources: cbits/MainWidget.c
|
||||
include-dirs: cbits/include
|
||||
install-includes: MainWidget.h
|
||||
cpp-options: -DANDROID
|
||||
build-tools: hsc2hs
|
||||
build-depends:
|
||||
base >= 4.7 && < 4.13,
|
||||
base >= 4.7 && < 4.14,
|
||||
bytestring == 0.10.*,
|
||||
reflex >= 0.6.2 && < 0.7,
|
||||
reflex-dom-core >=0.5.2 && < 0.6,
|
||||
reflex >= 0.6.2 && < 0.8,
|
||||
reflex-dom-core == 0.6.0.0,
|
||||
text == 1.2.*
|
||||
if !impl(ghcjs)
|
||||
if flag(use-warp) && (os(linux) || os(osx))
|
||||
build-depends:
|
||||
jsaddle,
|
||||
jsaddle-warp
|
||||
jsaddle >= 0.9.6 && < 0.10,
|
||||
jsaddle-warp >= 0.9.6 && < 0.10
|
||||
else
|
||||
if os(osx) || os(ios)
|
||||
build-depends:
|
||||
data-default == 0.7.*,
|
||||
jsaddle,
|
||||
jsaddle-wkwebview
|
||||
jsaddle >= 0.9.6 && < 0.10,
|
||||
jsaddle-wkwebview >= 0.9.6 && < 0.10
|
||||
else
|
||||
if flag(webkit2gtk)
|
||||
if flag(wasm32)
|
||||
build-depends:
|
||||
jsaddle-webkit2gtk
|
||||
jsaddle >= 0.9.6 && < 0.10,
|
||||
jsaddle-wasm >= 0.1 && < 0.2
|
||||
else
|
||||
if !os(android)
|
||||
if flag(webkit2gtk)
|
||||
build-depends:
|
||||
jsaddle-webkit2gtk
|
||||
jsaddle-webkit2gtk >= 0.9.6 && < 0.10
|
||||
else
|
||||
if !os(android)
|
||||
build-depends:
|
||||
jsaddle-webkit2gtk >= 0.9.6 && < 0.10
|
||||
|
||||
exposed-modules:
|
||||
Reflex.Dom
|
||||
Reflex.Dom.Internal
|
||||
reexported-modules:
|
||||
Foreign.JavaScript.TH
|
||||
, Foreign.JavaScript.Orphans
|
||||
Foreign.JavaScript.Orphans
|
||||
, Foreign.JavaScript.TH
|
||||
, Foreign.JavaScript.Utils
|
||||
, Reflex.Dom.Builder.Class
|
||||
, Reflex.Dom.Builder.Class.Events
|
||||
, Reflex.Dom.Builder.Hydratable
|
||||
, Reflex.Dom.Builder.Immediate
|
||||
, Reflex.Dom.Builder.InputDisabled
|
||||
, Reflex.Dom.Builder.Static
|
||||
@ -97,14 +114,19 @@ library
|
||||
, Reflex.Dom.Core
|
||||
, Reflex.Dom.Location
|
||||
, Reflex.Dom.Main
|
||||
, Reflex.Dom.Modals.Class
|
||||
, Reflex.Dom.Old
|
||||
, Reflex.Dom.Prerender
|
||||
, Reflex.Dom.Time
|
||||
, Reflex.Dom.WebSocket
|
||||
, Reflex.Dom.WebSocket.Query
|
||||
, Reflex.Dom.Widget
|
||||
, Reflex.Dom.Widget.Basic
|
||||
, Reflex.Dom.Widget.Input
|
||||
, Reflex.Dom.Widget.Lazy
|
||||
, Reflex.Dom.Widget.Resize
|
||||
, Reflex.Dom.Xhr
|
||||
, Reflex.Dom.Xhr.FormData
|
||||
ghc-options: -Wall -fwarn-tabs -funbox-strict-fields -O2 -ferror-spans
|
||||
if flag(expose-all-unfoldings)
|
||||
ghc-options: -fexpose-all-unfoldings
|
||||
@ -136,7 +158,19 @@ executable sortableList
|
||||
default-language: Haskell2010
|
||||
|
||||
executable benchmark
|
||||
build-depends: base, reflex, reflex-dom, text, prim-uniq, dependent-map, containers, transformers, mtl, ghcjs-dom, ghc-prim, random, dependent-sum
|
||||
build-depends: base
|
||||
, containers
|
||||
, dependent-map
|
||||
, dependent-sum
|
||||
, ghc-prim
|
||||
, ghcjs-dom
|
||||
, mtl
|
||||
, prim-uniq
|
||||
, random
|
||||
, reflex
|
||||
, reflex-dom
|
||||
, text
|
||||
, transformers
|
||||
hs-source-dirs: .
|
||||
main-is: benchmark.hs
|
||||
ghc-options: -O2 -fspecialise-aggressively
|
||||
@ -145,7 +179,20 @@ executable benchmark
|
||||
default-language: Haskell2010
|
||||
|
||||
executable krausest
|
||||
build-depends: base, reflex, reflex-dom, text, prim-uniq, dependent-map, containers, transformers, mtl, ghcjs-dom, ghc-prim, random, dependent-sum, vector
|
||||
build-depends: base
|
||||
, containers
|
||||
, dependent-map
|
||||
, dependent-sum
|
||||
, ghc-prim
|
||||
, ghcjs-dom
|
||||
, mtl
|
||||
, prim-uniq
|
||||
, random
|
||||
, reflex
|
||||
, reflex-dom
|
||||
, text
|
||||
, transformers
|
||||
, vector
|
||||
hs-source-dirs: benchmarks
|
||||
main-is: krausest.hs
|
||||
ghc-options: -O2 -fspecialise-aggressively
|
||||
|
||||
@ -80,6 +80,11 @@ run jsm = do
|
||||
startMainWidget a startPage jsm
|
||||
}
|
||||
forever $ threadDelay 1000000000
|
||||
#elif defined(wasm32_HOST_ARCH)
|
||||
import qualified Language.Javascript.JSaddle.Wasm as Wasm (run)
|
||||
import Language.Javascript.JSaddle (JSM)
|
||||
run :: JSM () -> IO ()
|
||||
run = Wasm.run 0
|
||||
#else
|
||||
import Language.Javascript.JSaddle.WebKitGTK (run)
|
||||
#endif
|
||||
|
||||
17
release.nix
17
release.nix
@ -1,12 +1,14 @@
|
||||
{ reflex-platform-fun ? import ./dep/reflex-platform
|
||||
, supportedSystems ? ["x86_64-linux" "x86_64-darwin"]
|
||||
}:
|
||||
|
||||
let
|
||||
native-reflex-platform = reflex-platform-fun {};
|
||||
inherit (native-reflex-platform.nixpkgs) lib;
|
||||
systems = ["x86_64-linux" "x86_64-darwin"];
|
||||
|
||||
perPlatform = lib.genAttrs systems (system: let
|
||||
tests = system: import ./test { pkgs = (reflex-platform-fun { inherit system; }).nixpkgs; };
|
||||
|
||||
perPlatform = lib.genAttrs supportedSystems (system: let
|
||||
reflex-platform = reflex-platform-fun { inherit system; };
|
||||
compilers = [
|
||||
"ghc"
|
||||
@ -25,15 +27,22 @@ let
|
||||
(self: super: {
|
||||
_dep = super._dep // {
|
||||
reflex-dom = builtins.filterSource (path: type: !(builtins.elem (baseNameOf path) [
|
||||
"release.nix"
|
||||
".git"
|
||||
"dist"
|
||||
"dist-newstyle"
|
||||
]) && !(builtins.elem path [
|
||||
./CONTRIBUTING.md
|
||||
./FAQ.md
|
||||
./Quickref.md
|
||||
./README.md
|
||||
./release.nix
|
||||
./test
|
||||
])) ./.;
|
||||
};
|
||||
})
|
||||
];
|
||||
};
|
||||
all = {
|
||||
all = tests system // {
|
||||
inherit (reflex-platform.${ghc})
|
||||
reflex-dom-core
|
||||
reflex-dom
|
||||
|
||||
10
test/default.nix
Normal file
10
test/default.nix
Normal file
@ -0,0 +1,10 @@
|
||||
{ pkgs ? (import ../dep/reflex-platform {}).nixpkgs }:
|
||||
{
|
||||
test-reflex-dom-reexports = pkgs.runCommand "test-reflex-dom-reexports" {} (
|
||||
let
|
||||
ghc = pkgs.haskellPackages.ghcWithPackages (p: [p.Cabal]);
|
||||
in ''
|
||||
${ghc}/bin/runhaskell ${./reflex-dom-reexports.hs} ${../reflex-dom/reflex-dom.cabal} ${../reflex-dom-core/reflex-dom-core.cabal}
|
||||
touch "$out"
|
||||
'');
|
||||
}
|
||||
72
test/reflex-dom-reexports.hs
Normal file
72
test/reflex-dom-reexports.hs
Normal file
@ -0,0 +1,72 @@
|
||||
-- This tests that reflex-dom re-exports all of reflex-dom-core's modules.
|
||||
-- Without this test they easily drift.
|
||||
module Main where
|
||||
|
||||
import Control.Monad (when)
|
||||
import Data.List (intercalate)
|
||||
import Data.Maybe (fromMaybe, isNothing, mapMaybe)
|
||||
import qualified Data.Set as Set
|
||||
import Distribution.Types.PackageName (mkPackageName)
|
||||
import Distribution.Compiler (CompilerFlavor (GHC))
|
||||
import Distribution.ModuleName (ModuleName, components)
|
||||
import Distribution.PackageDescription.Parsec (parseGenericPackageDescription)
|
||||
import qualified Distribution.Parsec.Common as Dist
|
||||
import Distribution.Parsec.ParseResult (runParseResult)
|
||||
import qualified Distribution.System as Dist
|
||||
import Distribution.Types.BuildInfo (buildable, defaultExtensions, defaultLanguage, hsSourceDirs, options)
|
||||
import Distribution.Types.CondTree (simplifyCondTree)
|
||||
import Distribution.Types.GenericPackageDescription (ConfVar (Arch, Impl, OS), condLibrary)
|
||||
import Distribution.Types.Library (exposedModules, libBuildInfo, reexportedModules)
|
||||
import Distribution.Types.ModuleReexport (ModuleReexport, moduleReexportOriginalName, moduleReexportOriginalPackage)
|
||||
import Distribution.Utils.Generic (toUTF8BS, readUTF8File)
|
||||
import System.Environment (getArgs)
|
||||
import qualified System.Info
|
||||
|
||||
main :: IO ()
|
||||
main = do
|
||||
[reflexDomFile, reflexDomCoreFile] <- getArgs
|
||||
(_, reflexDomReexports) <- parseCabalExports reflexDomFile
|
||||
(reflexDomCoreExports', _) <- parseCabalExports reflexDomCoreFile
|
||||
|
||||
let
|
||||
reflexDomCoreExports = Set.fromList reflexDomCoreExports'
|
||||
reflexDomCorePackageName = mkPackageName "reflex-dom-core"
|
||||
reflexDomReexportsFromCore
|
||||
= Set.fromList
|
||||
$ mapMaybe (\x -> if let origPackage = moduleReexportOriginalPackage x
|
||||
in isNothing origPackage || origPackage == Just reflexDomCorePackageName
|
||||
then Just $ moduleReexportOriginalName x
|
||||
else Nothing
|
||||
)
|
||||
reflexDomReexports
|
||||
|
||||
when (reflexDomCoreExports /= reflexDomReexportsFromCore) $ do
|
||||
error $ intercalate "\n\t"
|
||||
$ "reflex-dom does not re-export the following modules from reflex-dom-core:"
|
||||
: map
|
||||
(intercalate "." . components)
|
||||
(Set.toAscList $ reflexDomCoreExports `Set.difference` reflexDomReexportsFromCore)
|
||||
|
||||
putStrLn "Test passed."
|
||||
|
||||
parseCabalExports :: FilePath -> IO ([ModuleName], [ModuleReexport])
|
||||
parseCabalExports file = do
|
||||
contents <- readUTF8File file
|
||||
let
|
||||
(warnings, result) = runParseResult $ parseGenericPackageDescription $ toUTF8BS contents
|
||||
osConfVar = case System.Info.os of
|
||||
"linux" -> Just Dist.Linux
|
||||
"darwin" -> Just Dist.OSX
|
||||
_ -> error "Unrecognized System.Info.os"
|
||||
archConfVar = Just Dist.X86_64
|
||||
evalConfVar v = Right $ case v of
|
||||
OS osVar -> Just osVar == osConfVar
|
||||
Arch archVar -> Just archVar == archConfVar
|
||||
Impl GHC _ -> True
|
||||
_ -> False
|
||||
pure $ case condLibrary <$> result of
|
||||
Right (Just condLib) ->
|
||||
let (_, lib) = simplifyCondTree evalConfVar condLib
|
||||
in (exposedModules lib, reexportedModules lib)
|
||||
Right Nothing -> error $ "Haskell package has no library component: " <> file
|
||||
Left (_, errors) -> error $ "Failed to parse " <> file <> ":\n" <> unlines (map show errors)
|
||||
Loading…
Reference in New Issue
Block a user