From 91b75eee348643e1265ffdccc8fdc2940054a2c9 Mon Sep 17 00:00:00 2001
From: Vladislav
Last thing we need to run the site is this auxiliary function \
\mkUrlHashRef \
- \that creates a Inside the \
- \Router \
- \module there is a definition of type Here Another importants definitions are these two functions:\
- \DynRef JSString
— dynamic value containing current \
+ \that creates a DynRef Text
— dynamic value containing current \
\hash-string from the browser. When parsed to Dynamic Route
\
\and then mapped with (<&>)
operator to \
\Dynamic (Html ())
the dyn
function can be used to \
@@ -82,7 +85,7 @@ countriesListPage :: CountriesListQ -> Html ()
countriesListPage q = div_ [class_ "CountriesList"] do
searchQueryRef <- newRef q
form_ do
- onOptions "submit" (ListenerOpts True True True) \_event -> do
+ on @"submit" do
newRoute <- toUrl . CountriesListR . (\s -> s{page = 1}) <$> readRef searchQueryRef
pushUrl newRoute
div_ [style_ "display:flex;"] do
@@ -90,8 +93,7 @@ countriesListPage q = div_ [class_ "CountriesList"] do
[ type_ "text" , placeholder_ "Search countries by title", autofocus_ True
] do
dynValue $ fromMaybe "" . (.search) <$> fromRef searchQueryRef
- on "input" $ decodeEvent valueDecoder $
- modifyRef searchQueryRef . (\v s -> s{search = v}) . Just
+ on @"input" $ modifyRef searchQueryRef . (\v s -> s{search = v}) . Just
button_ [type_ "submit"] "Search"
table_ do
thead_ $ tr_ do
@@ -102,7 +104,7 @@ countriesListPage q = div_ [class_ "CountriesList"] do
thSort SortByPopulation "Population"
tbody_ do
for_ pageResults \(n, country) -> tr_ do
- td_ do text (JSS.pack (show @Int n))
+ td_ do text (Text.pack (show @Int n))
td_ do
a_ [href_ (mkMapLink country.code)] do
for_ country.flag_icon
@@ -110,14 +112,14 @@ countriesListPage q = div_ [class_ "CountriesList"] do
text country.title
td_ do text country.region
td_ do text country.subregion
- td_ do text (JSS.pack (show country.population))
+ td_ do text (Text.pack (show country.population))
center_ do
for_ (paginate total q.page itemsPerPage) \case
Nothing ->
button_ [disabled_ True] "..."
Just p -> a_
[ href_ (toUrl (CountriesListR q {page = p}))] $
- button_ [disabled_ (q.page == p)] $ text $ JSS.pack $ show p
+ button_ [disabled_ (q.page == p)] $ text $ Text.pack $ show p
dl_ do
dt_ "Country"
dd_ $ unsafeHtml "The word country comes from text "▲"
(sortVal, Desc) | sortVal == sortBy -> text "▼"
otherwise -> text ""
- on_ "click" do pushUrl $ toUrl . CountriesListR . toggleSortBy sortBy $ q
+ on @"click" do pushUrl $ toUrl . CountriesListR . toggleSortBy sortBy $ q
toggleSortBy sortBy q
| q.sort_by == sortBy = q {sort_dir = flipDir q.sort_dir}
@@ -156,7 +158,7 @@ countriesListPage q = div_ [class_ "CountriesList"] do
$ countries
countryFilter country = case q.search of
Just needle ->
- JSS.isInfixOf (JSS.toLower needle) (JSS.toLower country.title)
+ Text.isInfixOf (Text.toLower needle) (Text.toLower country.title)
Nothing -> True
countrySortBy = case q.sort_by of
SortByTitle -> Left . (.title)
@@ -167,7 +169,7 @@ countriesListPage q = div_ [class_ "CountriesList"] do
Asc -> Left . countrySortBy
Desc -> Right . Down . countrySortBy
itemsPerPage = 40
- mkMapLink = toUrl . CountriesMapR . CountriesMapQ . Just . JSS.toLower
+ mkMapLink = toUrl . CountriesMapR . CountriesMapQ . Just . Text.toLower
countriesMapPage :: CountriesMapQ -> Html ()
countriesMapPage q =
@@ -176,11 +178,13 @@ countriesMapPage q =
unsafeHtml countriesMap
figcaption_ "political map of the planet Earth"
centerEl <- asks html_current_element
- liftIO $ js_selectCountry centerEl $ maybeToNullable $
- fmap JSS.toJSValPure q.selected
- on "click" \event -> do
- mcode <- fmap JSS.fromJSValPure . nullableToMaybe <$>
- liftIO (js_svgClickGetCountryCode event)
+ liftIO do
+ msel <- mapM toJSVal q.selected
+ js_selectCountry centerEl $ maybeToNullable msel
+ on @ClickWithEvent \event -> do
+ mcode <- liftIO (js_svgClickGetCountryCode event)
+ & (fmap nullableToMaybe)
+ & mapM fromJSVal
mapM_ (pushUrl . toUrl . CountriesMapR . CountriesMapQ . Just) mcode
paginate
@@ -202,3 +206,14 @@ paginate totalItems curPage limit
(pageQuot, pageRem) = totalItems `divMod` limit
totalPages = if pageRem == 0 then pageQuot else pageQuot + 1
maxLinks = 10
+
+
+data ClickWithEvent
+
+instance IsEventName ClickWithEvent where
+ type EventListenerCb ClickWithEvent = JSVal -> Step ()
+ addEventListenerArgs = AddEventListenerArgs
+ { event_name = "dblclick"
+ , listener_options = defaultEventListenerOptions
+ , mk_callback = \k j -> k j
+ }
diff --git a/examples/simple-routing/Router.hs b/examples/simple-routing/Router.hs
index 0335e5c..050ceeb 100644
--- a/examples/simple-routing/Router.hs
+++ b/examples/simple-routing/Router.hs
@@ -7,12 +7,15 @@ import Data.Maybe
import Data.Function
import GHC.Generics
import Text.Read
+import Data.Text (Text)
+import Data.Text qualified as Text
import Wasm.Compat.Prim
import Wasm.Compat.Marshal
+import Data.Char qualified as C
data UrlParts = Url
- { partsPath :: [JSString] -- ^ Path segments
- , partsQuery :: [(JSString, JSString)] -- ^ GET parameters
+ { partsPath :: [Text] -- ^ Path segments
+ , partsQuery :: [(Text, Text)] -- ^ GET parameters
} deriving (Eq, Show, Generic)
data Route
@@ -22,14 +25,14 @@ data Route
deriving (Eq, Show, Generic)
data CountriesListQ = CountriesListQ
- { search :: Maybe JSString
+ { search :: Maybe Text
, page :: Int
, sort_by :: CountrySortBy
, sort_dir :: SortDir
} deriving (Eq, Show, Generic)
data CountriesMapQ = CountriesMapQ
- { selected :: Maybe JSString
+ { selected :: Maybe Text
} deriving (Eq, Show, Generic)
data SortDir = Asc | Desc
@@ -68,7 +71,7 @@ parseRoute = \case
Just "region" -> SortByRegion
Just "subregion" -> SortBySubregion
_ -> defaultCountriesListQ.sort_by
- parseIntQuery = readMaybe . fromJSString
+ parseIntQuery = readMaybe . Text.unpack
printRoute :: Route -> UrlParts
printRoute = \case
@@ -94,7 +97,7 @@ printRoute = \case
SortByRegion -> "region"
SortBySubregion -> "subregion") .
mfilter (/=defaultCountriesListQ.sort_by) . Just
- toIntQuery = JSS.pack . show
+ toIntQuery = Text.pack . show
defaultCountriesListQ :: CountriesListQ
defaultCountriesListQ = CountriesListQ
@@ -109,39 +112,74 @@ defaultCountriesMapQ = CountriesMapQ
{ selected = Nothing
}
-toUrl :: Route -> JSString
-toUrl = ("#"<>) . partsToText . printRoute
+toUrl :: Route -> Text
+toUrl = ("#"<>) . printUrlParts . printRoute
-fromUrl :: JSString -> Maybe Route
+fromUrl :: Text -> Maybe Route
fromUrl url = url
- & JSS.stripPrefix "#"
+ & Text.stripPrefix "#"
& fromMaybe url
- & textToParts
+ & parseUrlParts
& parseRoute
-partsToText :: UrlParts -> JSString
-partsToText (Url s q) = JSS.intercalate "?" (segments : query)
+printUrlParts :: UrlParts -> Text
+printUrlParts (Url s q) = Text.intercalate "?" (segments : query)
where
segments =
- JSS.intercalate "/" $ fmap JSS.encodeURIComponent s
+ Text.intercalate "/" $ fmap encodeURIComponent s
query = q
- & fmap (bimap JSS.encodeURIComponent JSS.encodeURIComponent)
+ & fmap (bimap encodeURIComponent encodeURIComponent)
& fmap (\(k, v) -> k <> "=" <> v)
- & List.filter (not . JSS.null)
- & JSS.intercalate "&"
- & List.filter (not . JSS.null) . (:[])
+ & List.filter (not . Text.null)
+ & Text.intercalate "&"
+ & List.filter (not . Text.null) . (:[])
-textToParts :: JSString -> UrlParts
-textToParts t = Url segments query
+parseUrlParts :: Text -> UrlParts
+parseUrlParts t = Url segments query
where
(segmentsStr, queryStr) = breakOn1 "?" t
segments = segmentsStr
- & JSS.splitOn "/"
- & List.filter (not . JSS.null)
- & fmap JSS.decodeURIComponent
+ & Text.splitOn "/"
+ & List.filter (not . Text.null)
+ & fmap decodeURIComponent
query = queryStr
- & JSS.splitOn "&"
- & List.filter (not . JSS.null)
- & fmap (breakOn1 "=" . JSS.decodeURIComponent)
+ & Text.splitOn "&"
+ & List.filter (not . Text.null)
+ & fmap (breakOn1 "=" . decodeURIComponent)
breakOn1 s t =
- let (a, b) = JSS.breakOn s t in (a, JSS.drop 1 b)
+ let (a, b) = Text.breakOn s t in (a, Text.drop 1 b)
+
+encodeURIComponent :: Text -> Text
+encodeURIComponent =
+ Text.pack . concatMap encodeChar . Text.unpack
+ where
+ encodeChar c
+ | C.isAlphaNum c = [c]
+ | c == ' ' = "+"
+ | otherwise = '%' : showHex (C.ord c) ""
+ showHex :: Int -> String -> String
+ showHex n acc
+ | n < 16 = intToDigit n : acc
+ | otherwise = let (q,r) = n `divMod` 16 in showHex q (intToDigit r : acc)
+ intToDigit :: Int -> Char
+ intToDigit n
+ | 0 <= n && n <= 9 = toEnum (fromEnum '0' + n)
+ | 10 <= n && n <= 15 = toEnum (fromEnum 'a' + n - 10)
+ | otherwise = error "intToDigit: not a digit"
+
+decodeURIComponent :: Text -> Text
+decodeURIComponent =
+ Text.pack . decode . Text.unpack
+ where
+ decode [] = []
+ decode ('%':x1:x2:xs)
+ | C.isHexDigit x1 && C.isHexDigit x2 =
+ C.chr (16 * digitToInt x1 + digitToInt x2) : decode xs
+ decode ('+':xs) = ' ' : decode xs
+ decode (x:xs) = x : decode xs
+ digitToInt :: Char -> Int
+ digitToInt c
+ | '0' <= c && c <= '9' = fromEnum c - fromEnum '0'
+ | 'a' <= c && c <= 'f' = fromEnum c - fromEnum 'a' + 10
+ | 'A' <= c && c <= 'F' = fromEnum c - fromEnum 'A' + 10
+ | otherwise = error "digitToInt: not a digit"
diff --git a/htmlt.cabal b/htmlt.cabal
index aa4d6b0..06fc6c4 100644
--- a/htmlt.cabal
+++ b/htmlt.cabal
@@ -133,25 +133,26 @@ executable htmlt-todomvc
if !flag(examples)
buildable: False
--- executable htmlt-simple-routing
--- import: htmlt-common
--- main-is: simple-routing.hs
--- hs-source-dirs: ./examples/simple-routing
--- ghc-options:
--- -no-hs-main -optl-mexec-model=reactor
--- -optl-Wl,--export=hs_init,--export=wasm_main
--- other-modules:
--- Assets
--- Router
--- Pages
--- Utils
--- build-depends:
--- base,
--- bytestring,
--- mtl,
--- htmlt,
--- if !flag(examples)
--- buildable: False
+executable htmlt-simple-routing
+ import: htmlt-common
+ main-is: simple-routing.hs
+ hs-source-dirs: ./examples/simple-routing
+ ghc-options:
+ -no-hs-main -optl-mexec-model=reactor
+ -optl-Wl,--export=hs_init,--export=wasm_main
+ other-modules:
+ Assets
+ Router
+ Pages
+ Utils
+ build-depends:
+ base,
+ bytestring,
+ mtl,
+ htmlt,
+ text,
+ if !flag(examples)
+ buildable: False
-- executable htmlt-benchmarks
-- import: htmlt-common
diff --git a/shell.nix b/shell.nix
index 8b5272f..ffda97a 100644
--- a/shell.nix
+++ b/shell.nix
@@ -1 +1 @@
-(import ./default.nix {}).shell.javascript
+(import ./default.nix {}).shell.x86_64
diff --git a/src/HtmlT/DOM.hs b/src/HtmlT/DOM.hs
index 90d9354..e1feb11 100644
--- a/src/HtmlT/DOM.hs
+++ b/src/HtmlT/DOM.hs
@@ -4,7 +4,10 @@ Functions and definitions to manipulate and query the DOM tree
{-# OPTIONS_GHC -fno-warn-orphans #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE ForeignFunctionInterface #-}
+
+#if defined(wasm32_HOST_ARCH)
{-# LANGUAGE JavaScriptFFI #-}
+#endif
module HtmlT.DOM where
import Control.Monad
@@ -12,7 +15,7 @@ import Control.Monad.Reader
import Control.Monad.Trans.Maybe
import Data.Coerce
import GHC.Exts as Exts
-import GHC.Generics
+import GHC.Generics hiding (R)
import Unsafe.Coerce
import Wasm.Compat.Prim
import Wasm.Compat.Marshal
@@ -39,7 +42,7 @@ on k = addEventListener (addEventListenerArgs @eventName) k
data AddEventListenerArgs callback = AddEventListenerArgs
{ event_name :: Text
, listener_options :: EventListenerOptions
- , mk_callback :: callback -> JSVal -> Step ()
+ , mk_callback :: callback -> JSVal -> R ()
} deriving (Generic)
addEventListener :: AddEventListenerArgs callback -> callback -> Html ()
@@ -56,7 +59,7 @@ addEventListenerTarget
-> callback
-> m ()
addEventListenerTarget target args k = do
- cb <- liftIO $ js_dynExport1 $ dynStep . args.mk_callback k
+ cb <- liftIO $ js_dynExport1 $ trampoline . args.mk_callback k
jEventName <- liftIO $ toJSVal args.event_name
-- jscb <- withopts hscb
liftIO $ js_addEventListener target jEventName cb
@@ -71,63 +74,63 @@ class IsEventName eventName where
addEventListenerArgs :: AddEventListenerArgs (EventListenerCb eventName)
instance IsEventName "click" where
- type EventListenerCb "click" = Step ()
+ type EventListenerCb "click" = R ()
addEventListenerArgs = pointerEventArgs "click"
instance IsEventName "mousedown" where
- type EventListenerCb "mousedown" = Step ()
+ type EventListenerCb "mousedown" = R ()
addEventListenerArgs = pointerEventArgs "mousedown"
instance IsEventName "mouseup" where
- type EventListenerCb "mouseup" = Step ()
+ type EventListenerCb "mouseup" = R ()
addEventListenerArgs = pointerEventArgs "mouseup"
instance IsEventName "dblclick" where
- type EventListenerCb "dblclick" = Step ()
+ type EventListenerCb "dblclick" = R ()
addEventListenerArgs = pointerEventArgs "dblclick"
instance IsEventName "submit" where
- type EventListenerCb "submit" = Step ()
+ type EventListenerCb "submit" = R ()
addEventListenerArgs = submitEventArgs
instance IsEventName "input" where
- type EventListenerCb "input" = Text -> Step ()
+ type EventListenerCb "input" = Text -> R ()
addEventListenerArgs = inputEventArgs
instance IsEventName "keydown" where
- type EventListenerCb "keydown" = Int -> Step ()
+ type EventListenerCb "keydown" = Int -> R ()
addEventListenerArgs = keyboardEventArgs "keydown"
instance IsEventName "keyup" where
- type EventListenerCb "keyup" = Int -> Step ()
+ type EventListenerCb "keyup" = Int -> R ()
addEventListenerArgs = keyboardEventArgs "keyup"
instance IsEventName "focus" where
- type EventListenerCb "focus" = Step ()
+ type EventListenerCb "focus" = R ()
addEventListenerArgs = pointerEventArgs "focus"
instance IsEventName "blur" where
- type EventListenerCb "blur" = Step ()
+ type EventListenerCb "blur" = R ()
addEventListenerArgs = pointerEventArgs "blur"
instance IsEventName "input/blur" where
- type EventListenerCb "input/blur" = Text -> Step ()
+ type EventListenerCb "input/blur" = Text -> R ()
addEventListenerArgs = inputEventArgs {event_name = "blur"}
instance IsEventName "input/focus" where
- type EventListenerCb "input/focus" = Text -> Step ()
+ type EventListenerCb "input/focus" = Text -> R ()
addEventListenerArgs = inputEventArgs {event_name = "focus"}
instance IsEventName "checkbox/change" where
- type EventListenerCb "checkbox/change" = Bool -> Step ()
+ type EventListenerCb "checkbox/change" = Bool -> R ()
addEventListenerArgs = checkboxChangeEventArgs
instance IsEventName "select/change" where
- type EventListenerCb "select/change" = Text -> Step ()
+ type EventListenerCb "select/change" = Text -> R ()
addEventListenerArgs = selectChangeEventArgs
-- https://developer.mozilla.org/en-US/docs/Web/API/Element/click_event
-pointerEventArgs :: Text -> AddEventListenerArgs (Step ())
+pointerEventArgs :: Text -> AddEventListenerArgs (R ())
pointerEventArgs event_name = AddEventListenerArgs
{ event_name
, listener_options = defaultEventListenerOptions
@@ -135,7 +138,7 @@ pointerEventArgs event_name = AddEventListenerArgs
}
-- https://developer.mozilla.org/en-US/docs/Web/API/HTMLFormElement/submit_event
-submitEventArgs :: AddEventListenerArgs (Step ())
+submitEventArgs :: AddEventListenerArgs (R ())
submitEventArgs = AddEventListenerArgs
{ event_name = "submit"
, listener_options = defaultSubmitOptions
@@ -145,7 +148,7 @@ submitEventArgs = AddEventListenerArgs
defaultSubmitOptions = EventListenerOptions True True
-- https://developer.mozilla.org/en-US/docs/Web/API/HTMLElement/input_event
-inputEventArgs :: AddEventListenerArgs (Text -> Step ())
+inputEventArgs :: AddEventListenerArgs (Text -> R ())
inputEventArgs = AddEventListenerArgs
{ event_name = "input"
, listener_options = defaultEventListenerOptions
@@ -157,7 +160,7 @@ inputEventArgs = AddEventListenerArgs
-- https://developer.mozilla.org/en-US/docs/Web/API/Element/keydown_event
-- https://developer.mozilla.org/en-US/docs/Web/API/Element/keyup_event
-keyboardEventArgs :: Text -> AddEventListenerArgs (Int -> Step ())
+keyboardEventArgs :: Text -> AddEventListenerArgs (Int -> R ())
keyboardEventArgs event_name = AddEventListenerArgs
{ event_name
, listener_options = defaultEventListenerOptions
@@ -170,7 +173,7 @@ keyboardEventArgs event_name = AddEventListenerArgs
-- https://developer.mozilla.org/en-US/docs/Web/API/Element/blur_event
-- https://developer.mozilla.org/en-US/docs/Web/API/Element/focusin_event
-- https://developer.mozilla.org/en-US/docs/Web/API/Element/focusout_event
-focusEventArgs :: Text -> AddEventListenerArgs (Step ())
+focusEventArgs :: Text -> AddEventListenerArgs (R ())
focusEventArgs event_name = AddEventListenerArgs
{ event_name
, listener_options = defaultEventListenerOptions
@@ -178,7 +181,7 @@ focusEventArgs event_name = AddEventListenerArgs
}
-- https://developer.mozilla.org/en-US/docs/Web/API/HTMLElement/change_event
-checkboxChangeEventArgs :: AddEventListenerArgs (Bool -> Step ())
+checkboxChangeEventArgs :: AddEventListenerArgs (Bool -> R ())
checkboxChangeEventArgs = AddEventListenerArgs
{ event_name = "change"
, listener_options = defaultEventListenerOptions
@@ -189,7 +192,7 @@ checkboxChangeEventArgs = AddEventListenerArgs
}
-- https://developer.mozilla.org/en-US/docs/Web/API/HTMLElement/change_event
-selectChangeEventArgs :: AddEventListenerArgs (Text -> Step ())
+selectChangeEventArgs :: AddEventListenerArgs (Text -> R ())
selectChangeEventArgs = AddEventListenerArgs
{ event_name = "change"
, listener_options = defaultEventListenerOptions
@@ -219,7 +222,7 @@ data Location = Location
} deriving stock (Show, Eq, Generic)
-- https://developer.mozilla.org/en-US/docs/Web/API/Window/popstate_event
-popstateEventArgs :: AddEventListenerArgs (Location -> Step ())
+popstateEventArgs :: AddEventListenerArgs (Location -> R ())
popstateEventArgs = AddEventListenerArgs
{ event_name = "popstate"
, listener_options = defaultEventListenerOptions
diff --git a/src/HtmlT/Event.hs b/src/HtmlT/Event.hs
index 2d70fc9..c755080 100644
--- a/src/HtmlT/Event.hs
+++ b/src/HtmlT/Event.hs
@@ -25,146 +25,220 @@ import Data.Set qualified as Set
import Data.Tuple
import GHC.Exts
import GHC.Fingerprint
-import GHC.Generics
+import GHC.Generics hiding (R)
import Unsafe.Coerce
+import Data.List qualified as List
+
+data ReactiveEnv = ReactiveEnv
+ { scope :: ReactiveScope
+ , reactive_state_ref :: IORef ReactiveState
+ } deriving (Generic)
+
+data ReactiveState = ReactiveState
+ { subscriptions :: Map EventId [(ReactiveScope, Any -> R ())]
+ , scopes :: Map ReactiveScope ReactiveNode
+ , transaction_queue :: Map EventId (R ())
+ , id_supply :: Int
+ -- ^ Id supply for EventId and ReactiveScope
+ } deriving (Generic)
+
+newtype EventId = EventId { unEventId :: Int }
+ deriving newtype (Eq, Ord, Show, Num, Enum)
+
+newtype ReactiveScope = ReactiveScope { unReactiveScope :: Int }
+ deriving newtype (Show, Num, Ord, Eq)
-- | Represents a stream of event occurrences of type @a@. Its actual
-- representation is simply a function that subscribes to the event
-newtype Event a = Event
- { unEvent :: ReactiveEnv -> Callback a -> IO ()
- }
+newtype Event a = Event { subscribe :: (a -> R ()) -> R () }
+
+instance Functor Event where
+ fmap f (Event s) = Event \k -> s . (. f) $ k
-- | Contains a value that is subject to change over time. Provides
-- operations for reading the current value ('readDyn') and
-- subscribing to its future changes ('updates').
data Dynamic a = Dynamic
- { dynamic_read :: IO a
+ { sample :: IO a
-- ^ Read current value. Use public alias 'readDyn' instead
- , dynamic_updates :: Event a
+ , updates :: Event a
-- ^ Event that fires when the value changes. Use public alias
-- 'updates' instead
} deriving stock Generic
+instance Functor Dynamic where
+ fmap f (Dynamic s u) = Dynamic (fmap f s) (fmap f u)
+
+instance Applicative Dynamic where
+ pure = constDyn
+ (<*>) = dynamicSplat
+
+dynamicSplat :: Dynamic (a -> b) -> Dynamic a -> Dynamic b
+dynamicSplat df da =
+ let
+ updates = Event \k -> mdo
+ let
+ fire newF newA = defer queueId do
+ f <- liftIO $ maybe (readDyn df) pure newF
+ a <- liftIO $ maybe (readDyn da) pure newA
+ k (f a)
+ df.updates.subscribe \f -> fire (Just f) Nothing
+ da.updates.subscribe \a -> fire Nothing (Just a)
+ queueId <- EventId <$> reactive (const nextIntId)
+ return ()
+ sample = liftA2 ($) df.sample da.sample
+ in
+ Dynamic {sample, updates}
+
-- | A mutable variable that allows for subscription to new values. It
-- shares a similar API to 'IORef' (see 'readRef', 'writeRef',
-- 'modifyRef')
data DynRef a = DynRef
- { dynref_dynamic :: Dynamic a
+ { dynamic :: Dynamic a
-- ^ Holds the current value and an event that notifies about value
-- modifications
- , dynref_modifier :: Modifier a
+ , modifier :: Modifier a
-- ^ Funtion to update the value
} deriving stock Generic
-- | Function that updates the value inside the 'DynRef'
+-- 'Bool' argument controls whether the modification should
+-- trigger an update event. It's possible to update the 'DynRef'
+-- without notifying the subscribers for optimization purposes, in
+-- cases when you know that all changes already been reflected in
+-- the DOM
newtype Modifier a = Modifier
- { unModifier :: forall r. Bool -> (a -> (a, r)) -> Step r
- -- ^ 'Bool' argument controls whether the modification should
- -- trigger an update event. It's possible to update the 'DynRef'
- -- without notifying the subscribers for optimization purposes, in
- -- cases when you know that all changes already been reflected in
- -- the DOM
+ { unModifier :: forall r. Bool -> (a -> (a, r)) -> R r
}
--- | State inside 'Step'
-newtype TransactState = TransactState
- { unTransactState :: Map QueueId (Step ())
- } deriving newtype (Semigroup, Monoid)
+-- | Minimal implementation for 'HasReactiveEnv'
+newtype ReactiveT m a = ReactiveT
+ { unReactiveT :: ReaderT ReactiveScope (StateT ReactiveState m) a
+ }
+ deriving newtype (
+ Functor, Applicative, Monad, MonadIO, MonadFix, MonadCatch, MonadThrow,
+ MonadMask, MonadState ReactiveState, MonadReader ReactiveScope
+ )
--- | Evaluation of effects triggered by an event firing
-newtype Step a = Step { unStep :: StateT TransactState IO a }
- deriving newtype
- ( Functor, Applicative, Monad, MonadIO, MonadState TransactState, MonadFix
- , MonadCatch, MonadThrow, MonadMask
- )
+newtype ReactivT m a = ReactivT
+ { unReactivT :: ReaderT ReactiveEnv m a
+ }
+ deriving newtype (
+ Functor, Applicative, Monad, MonadIO, MonadFix, MonadCatch, MonadThrow,
+ MonadMask, MonadReader ReactiveEnv
+ )
--- | Represents the environment necessary for "reactive" operations,
--- such as creating a new 'Event', subscribing to an event etc
-data ReactiveEnv = ReactiveEnv
- { renv_subscriptions :: IORef (Map QueueId [(QueueId, Callback Any)])
- -- ^ Keeps track of subscriptions
- , renv_finalizers :: IORef (Map FinalizerKey FinalizerValue)
- -- ^ Keeps track of finalizers. These finalizers will be activated
- -- shortly before the current part of the application is terminated.
- , renv_id_generator :: IORef QueueId
- -- ^ Maintains the next value to be used for generating 'QueueId'
- } deriving Generic
+type Callback a = a -> R ()
--- | Minimal implementation for 'HasReactiveEnv'
-newtype ReactiveT m a = ReactiveT
- { unReactiveT :: ReaderT ReactiveEnv m a
- } deriving newtype
- ( Functor, Applicative, Monad, MonadIO, MonadFix, MonadCatch, MonadThrow
- , MonadMask
- )
-
--- | Identifies a computation inside 'TransactState'. The integer
--- value within 'QueueId' dictates the execution order in a reactive
--- transaction (with higher values executing later). It is also
--- utilized to prioritize events derived from other events, ensuring
--- they are processed after the source events. This is basically the
--- mechanism that prevents double-firing of Dynamics constructed
--- using, for instance, the Applicative instance.
-newtype QueueId = QueueId {unQueueId :: Int}
- deriving newtype (Eq, Show, Ord, Num, Enum, Bounded)
-
-data FinalizerKey
- = FinalizerEventId QueueId
- | FinalizerQueueId QueueId
- | FinalizerFingerprintId Fingerprint
- deriving (Eq, Ord, Generic)
-
-data FinalizerValue
- = SubscriptionSet (Set QueueId)
- | CustomFinalizer (IO ())
- deriving Generic
-
-class HasReactiveEnv m where askReactiveEnv :: m ReactiveEnv
-
-type MonadReactive m = (HasReactiveEnv m, MonadIO m)
+type R = ReactiveT IO
-type Lens' s a = forall f. Functor f => (a -> f a) -> s -> f s
+type Subscriptions = Map EventId [(ReactiveScope, Any -> R ())]
-type Callback a = a -> Step ()
+type Finalizers = Map ReactiveScope ReactiveNode
-type Trigger a = a -> Step ()
+data ReactiveNode = ReactiveNode
+ { nodes :: [ReactiveScope]
+ , parent :: Maybe ReactiveScope
+ , finalizers :: [R ()]
+ } deriving stock Generic
--- | Create new empty 'ReactiveEnv'
-newReactiveEnv :: MonadIO m => m ReactiveEnv
-newReactiveEnv = liftIO do
- renv_finalizers <- newIORef Map.empty
- renv_subscriptions <- newIORef Map.empty
- renv_id_generator <- newIORef $ QueueId 0
- return ReactiveEnv {..}
+freeScope :: ReactiveScope -> R ()
+freeScope rscope = do
+ mRemovedNode <- state $ swap . freeScopeFn rscope
+ forM_ mRemovedNode \n -> do
+ sequence_ n.finalizers
+ forM_ n.nodes freeScope
--- | Create new event and a function to supply values to that event
---
--- > (event, push) <- newEvent @String
--- > push "New Value" -- event fires with given value
-newEvent :: forall a m. MonadReactive m => m (Event a, Trigger a)
-newEvent = do
- renv <- askReactiveEnv
- eventId <- liftIO (nextQueueId renv)
- let event = Event $ unsafeSubscribe eventId
- return (event, unsafeTrigger eventId renv)
-
--- | Create a new 'DynRef' using given initial value
---
--- > showRef <- newRef False
--- > dynStep $ writeRef showRef True -- this triggers update event for showRef
-newRef :: forall a m. MonadReactive m => a -> m (DynRef a)
+freeScopeFn :: ReactiveScope -> ReactiveState -> (ReactiveState, Maybe ReactiveNode)
+freeScopeFn rscope s =
+ let
+ (mRemovedNode, scopes0) = Map.alterF (,Nothing) rscope $ s.scopes
+ removedParent = mRemovedNode >>= (.parent)
+ subscriptions = unsubscribe s.subscriptions
+ scopes = maybe scopes0 (unlinkParentScope scopes0) removedParent
+ in
+ ((s::ReactiveState) { subscriptions, scopes }, mRemovedNode)
+ where
+ unsubscribe :: Subscriptions -> Subscriptions
+ unsubscribe s =
+ let
+ removeCollectEmpty a k b =
+ let c = filterSubscriptions b
+ in (if List.null c then k:a else a, c)
+ (emptyKeys, s1) = Map.mapAccumWithKey removeCollectEmpty [] s
+ in
+ List.foldl' (flip Map.delete) s1 emptyKeys
+
+ unlinkParentScope :: Finalizers -> ReactiveScope -> Finalizers
+ unlinkParentScope f r =
+ Map.alter (fmap (\n -> n { nodes = List.filter (/=rscope) n.nodes })) r f
+
+ filterSubscriptions [] = []
+ filterSubscriptions ((s, c):xs) | s == rscope = xs
+ | otherwise = (s, c) : filterSubscriptions xs
+
+unsafeSubscribeFn :: EventId -> (a -> R ()) -> ReactiveScope -> ReactiveState -> ReactiveState
+unsafeSubscribeFn eid k rs s =
+ let
+ insertSubscription (Just xs) = Just $ (rs, k . unsafeCoerce):xs
+ insertSubscription Nothing = Just [(rs, k . unsafeCoerce)]
+ in
+ s {subscriptions = Map.alter insertSubscription eid s.subscriptions }
+
+unsafeSubscribe :: EventId -> (a -> R ()) -> R ()
+unsafeSubscribe eid k = ask >>= \rs -> modify (unsafeSubscribeFn eid k rs)
+
+installFinalizer :: R () -> ReactiveScope -> ReactiveState -> ReactiveState
+installFinalizer fin rs s =
+ let
+ insertFin (Just n) = Just $ n { finalizers = fin : n.finalizers}
+ insertFin Nothing = Nothing
+ in
+ s {scopes = Map.alter insertFin rs s.scopes }
+
+unsafeTrigger :: EventId -> a -> R ()
+unsafeTrigger eid a = defer eid do
+ callbacks <- gets $ fromMaybe [] .
+ Map.lookup eid . (.subscriptions)
+ forM_ callbacks $ ($ unsafeCoerce @_ @Any a) . snd
+
+newReactiveScopeFn :: ReactiveScope -> ReactiveState -> (ReactiveScope, ReactiveState)
+newReactiveScopeFn parent s0 =
+ let
+ (s1, intId) = nextIntId s0
+ rscope = ReactiveScope intId
+ scopes = Map.insert rscope (ReactiveNode [] (Just parent) []) s1.scopes
+ in
+ (rscope, s1 {scopes})
+
+-- | Defers a computation (typically an event firing) until the end of
+-- the current reactive transaction. This allows for the avoidance of
+-- double firing of events constructed from multiple other events.
+defer :: EventId -> R () -> R ()
+defer k act = modify \s -> s {transaction_queue = Map.insert k act s.transaction_queue}
+
+newEvent :: R (Event a, a -> R ())
+newEvent = state \s0 ->
+ let
+ (s1, eventId) = nextIntId s0
+ event = Event $ unsafeSubscribe $ EventId eventId
+ trig = unsafeTrigger $ EventId eventId
+ in
+ ((event, trig), s1)
+
+newRef :: a -> R (DynRef a)
newRef initial = do
- ref <- liftIO $ newIORef initial
+ ioRef <- liftIO $ newIORef initial
(event, push) <- newEvent
let
- modify = Modifier \u f -> do
- (new, result) <- liftIO $ atomicModifyIORef' ref \old ->
+ modifier = Modifier \u f -> do
+ (new, result) <- liftIO $ atomicModifyIORef' ioRef \old ->
let (new, result) = f old in
(new, (new, result))
when u $ push new
return result
- dynamic = Dynamic (readIORef ref) event
- return $ DynRef dynamic modify
+ dynamic = Dynamic (readIORef ioRef) event
+ return DynRef {dynamic, modifier}
-- | Create a Dynamic that never changes its value
constDyn :: a -> Dynamic a
@@ -172,15 +246,15 @@ constDyn a = Dynamic (pure a) never
-- | Event that will never fire
never :: Event a
-never = Event \_ _ -> return ()
+never = Event \ _ -> return ()
-- | Write new value into a 'DynRef'
--
--- > ref <- newRef "Initial value"
--- > transactionWrite ref "New value"
+-- > ref <- newRef "Initial dynamic"
+-- > transactionWrite ref "New dynamic"
-- > readRef ref
--- "New value"
-writeRef :: DynRef a -> a -> Step ()
+-- "New dynamic"
+writeRef :: DynRef a -> a -> R ()
writeRef ref a = modifyRef ref (const a)
-- | Read the current value held by given 'DynRef'
@@ -189,59 +263,37 @@ writeRef ref a = modifyRef ref (const a)
-- > readRef ref
-- "Hello there!"
readRef :: MonadIO m => DynRef a -> m a
-readRef = readDyn . dynref_dynamic
+readRef = readDyn . (.dynamic)
-- | Update a 'DynRef' by applying given function to the current value
--
-- > ref <- newRef [1..3]
-- > modifyRef ref $ fmap (*2)
-- [2, 4, 6]
-modifyRef :: DynRef a -> (a -> a) -> Step ()
+modifyRef :: DynRef a -> (a -> a) -> R ()
modifyRef (DynRef _ (Modifier mod)) f = mod True $ (,()) . f
-- | Update a 'DynRef' with first field of the tuple and return back
-- the second field. The name is intended to be similar to
-- 'atomicModifyIORef' but there are no atomicity guarantees
-- whatsoever
-atomicModifyRef :: DynRef a -> (a -> (a, r)) -> Step r
+atomicModifyRef :: DynRef a -> (a -> (a, r)) -> R r
atomicModifyRef (DynRef _ (Modifier mod)) f = mod True f
-- | Extract a 'Dynamic' out of 'DynRef'
fromRef :: DynRef a -> Dynamic a
-fromRef = dynref_dynamic
+fromRef = (.dynamic)
--- | Read the value held by a 'Dynamic'
+-- | Read the dynamic held by a 'Dynamic'
readDyn :: MonadIO m => Dynamic a -> m a
-readDyn = liftIO . dynamic_read
-
--- | Extract the updates Event from a 'Dynamic'
-updates :: Dynamic a -> Event a
-updates = dynamic_updates
-
--- | Attach a listener to the event and return an action to detach the
--- listener
-subscribe :: MonadReactive m => Event a -> Callback a -> m ()
-subscribe (Event s) k = do
- re <- askReactiveEnv
- liftIO $ s re k
+readDyn = liftIO . (.sample)
-- | Executes an action currently held inside the 'Dynamic' and every
--- time the value changes.
-performDyn :: MonadReactive m => Dynamic (Step ()) -> m ()
+-- time the dynamic changes.
+performDyn :: Dynamic (R ()) -> R ()
performDyn d = do
- liftIO $ dynamic_read d >>= dynStep
- subscribe (dynamic_updates d) id
-
--- | Apply a lens to the value inside 'DynRef'
-lensMap :: forall s a. Lens' s a -> DynRef s -> DynRef a
-lensMap l (DynRef sdyn (Modifier smod)) =
- DynRef adyn (Modifier amod)
- where
- adyn = Dynamic
- (fmap (getConst . l Const) $ dynamic_read sdyn)
- (fmap (getConst . l Const) $ dynamic_updates sdyn)
- amod :: forall r. Bool -> (a -> (a, r)) -> Step r
- amod u f = smod u $ swap . l (swap . f)
+ join $ liftIO d.sample
+ d.updates.subscribe id
-- | Return a 'Dynamic' for which updates only fire when the value
-- actually changes according to Eq instance
@@ -249,91 +301,83 @@ holdUniqDyn :: Eq a => Dynamic a -> Dynamic a
holdUniqDyn = holdUniqDynBy (==)
{-# INLINE holdUniqDyn #-}
+-- TODO: The name could be mesleading because it works differently
+-- compare to the holdUniqDynBy function in reflex. Unlike the
+-- original this version will perform comparisons equal to
+-- @number_of_updates × number_of_subscriptions@ as opposed to once
+-- per update in reflex (I could be wrong in my understanding of
+-- 'holdUniqDynBy' in Reflex)
-- | Same as 'holdUniqDyn' but accepts arbitrary equality test
-- function
holdUniqDynBy :: (a -> a -> Bool) -> Dynamic a -> Dynamic a
-holdUniqDynBy equalFn Dynamic{..} = Dynamic dynamic_read
- (Event \e k -> do
- old <- liftIO dynamic_read
- oldRef <- liftIO (newIORef old)
- unEvent dynamic_updates e \new -> do
- old <- liftIO $ atomicModifyIORef' oldRef (new,)
- unless (old `equalFn` new) $ k new
- )
-
--- | Execute the gives finalizers
-applyFinalizer :: ReactiveEnv -> Map FinalizerKey FinalizerValue -> IO ()
-applyFinalizer ReactiveEnv{renv_subscriptions} finalizers = do
- forM_ (Map.toList finalizers) \(k, v) -> case (k, v) of
- (FinalizerEventId e, SubscriptionSet s) ->
- modifyIORef' renv_subscriptions $
- flip Map.alter e $ mfilter (not . Prelude.null) . Just . deleteSubs s . fromMaybe []
- (_, CustomFinalizer io) ->
- io
- (_, _) ->
- return ()
- where
- deleteSubs _ss [] = []
- deleteSubs ss ((s, c):xs)
- | Set.member s ss = xs
- | otherwise = (s, c) : deleteSubs ss xs
+holdUniqDynBy equalFn da =
+ let
+ updates = Event \k -> do
+ old <- liftIO da.sample
+ oldRef <- liftIO $ newIORef old
+ da.updates.subscribe \new -> do
+ old <- liftIO $ atomicModifyIORef' oldRef (new,)
+ unless (old `equalFn` new) $ k new
+ in
+ Dynamic {sample = da.sample, updates}
+
+-- | Produce a new Dynamic by applying a function to both the source
+-- (Dynamic a) and previous value of itself
+foldDynMaybe :: (a -> b -> Maybe b) -> b -> Dynamic a -> R (Dynamic b)
+foldDynMaybe f initB dynA = do
+ initA <- liftIO dynA.sample
+ refB <- newRef $ fromMaybe initB $ f initA initB
+ dynA.updates.subscribe \newA -> do
+ oldB <- liftIO refB.dynamic.sample
+ forM_ (f newA oldB) $ writeRef refB
+ return refB.dynamic
+
+nextIntId :: ReactiveState -> (ReactiveState, Int)
+nextIntId s = (s {id_supply = succ s.id_supply}, s.id_supply)
-- | Alternative version if 'fmap' where given function will only be
-- called once every time 'Dynamic a' value changes, whereas in 'fmap'
-- it would be called once for each subscription per change event. As
-- a general guideline, if the function @f! is inexpensive, choose
-- @fmap f@. Otherwise, consider using @mapDyn f@.
-mapDyn
- :: MonadReactive m
- => (a -> b)
- -> Dynamic a
- -> m (Dynamic b)
-mapDyn fun adyn = do
- initialA <- liftIO $ dynamic_read adyn
+mapDyn :: (a -> b) -> Dynamic a -> R (Dynamic b)
+mapDyn fun da = do
+ initialA <- liftIO $ da.sample
latestA <- liftIO $ newIORef initialA
latestB <- liftIO $ newIORef (fun initialA)
- renv <- askReactiveEnv
- eventId <- liftIO (nextQueueId renv)
+ eventId <- EventId <$> reactive (const nextIntId)
let
- updates = Event $ unsafeSubscribe eventId
+ updates = Event (unsafeSubscribe eventId)
fire = defer eventId do
newB <- liftIO $ fun <$> readIORef latestA
liftIO $ writeIORef latestB newB
- unsafeTrigger eventId renv newB
- dynamic_updates adyn `subscribe` \newA -> do
+ unsafeTrigger eventId newB
+ da.updates.subscribe \newA -> do
liftIO $ writeIORef latestA newA
defer eventId fire
return $ Dynamic (readIORef latestB) updates
--- | Works same way as 'mapDyn' but applies to two dynamics
-mapDyn2
- :: MonadReactive m
- => (a -> b -> c)
- -> Dynamic a
- -> Dynamic b
- -> m (Dynamic c)
-mapDyn2 f adyn bdyn = do
- unsafeMapDynN g [unsafeCoerce adyn, unsafeCoerce bdyn]
- where
- g [a, b] = return $ f (unsafeCoerce a) (unsafeCoerce b)
- g _ = error "mapDyn2: impossible happend!"
-
--- | I hope three arguments will be enough for most cases if more
--- needed it's easy to define this function in the application code
--- with any required arity
-mapDyn3
- :: MonadReactive m
- => (a -> b -> c -> d)
- -> Dynamic a
- -> Dynamic b
- -> Dynamic c
- -> m (Dynamic d)
-mapDyn3 f adyn bdyn cdyn = do
- unsafeMapDynN g
- [unsafeCoerce adyn, unsafeCoerce bdyn, unsafeCoerce cdyn]
- where
- g [a, b, c] = return $ f (unsafeCoerce a) (unsafeCoerce b) (unsafeCoerce c)
- g _ = error "mapDyn3: impossible happend!"
+mapDyn2 :: (a -> b -> c) -> Dynamic a -> Dynamic b -> R (Dynamic c)
+mapDyn2 fun da db = do
+ initialA <- liftIO $ da.sample
+ initialB <- liftIO $ db.sample
+ latestA <- liftIO $ newIORef initialA
+ latestB <- liftIO $ newIORef initialB
+ latestC <- liftIO $ newIORef (fun initialA initialB)
+ eventId <- EventId <$> reactive (const nextIntId)
+ let
+ updates = Event (unsafeSubscribe eventId)
+ fire = defer eventId do
+ newC <- liftIO $ fun <$> (readIORef latestA) <*> (readIORef latestB)
+ liftIO $ writeIORef latestC newC
+ unsafeTrigger eventId newC
+ da.updates.subscribe \newA -> do
+ liftIO $ writeIORef latestA newA
+ defer eventId fire
+ db.updates.subscribe \newB -> do
+ liftIO $ writeIORef latestB newB
+ defer eventId fire
+ return $ Dynamic (readIORef latestC) updates
-- | Takes a list of Dynamics and a function to generate the
-- output. The positions of elements in the list of [Any] received by
@@ -342,125 +386,75 @@ mapDyn3 f adyn bdyn cdyn = do
-- function will fire at most once per transaction, and only if any of
-- the input Dynamics change their values.
unsafeMapDynN
- :: MonadReactive m
- => ([Any] -> IO a)
+ :: ([Any] -> IO a)
-- ^ Construct the output value, from list of input values from
-- corresponding positions of given Dynamics
-> [Dynamic Any]
-- ^ List of input Dynamics
- -> m (Dynamic a)
+ -> R (Dynamic a)
unsafeMapDynN fun dyns = do
- renv <- askReactiveEnv
- -- TODO: Try if list of IORefs is better than IORef of list
- initialInputs <- liftIO $ mapM dynamic_read dyns
+ initialInputs <- liftIO $ mapM (.sample) dyns
initialOutput <- liftIO $ fun initialInputs
latestInputsRef <- liftIO $ newIORef initialInputs
latestOutputRef <- liftIO $ newIORef initialOutput
- eventId <- liftIO (nextQueueId renv)
+ eventId <- EventId <$> reactive (const nextIntId)
let
fire = defer eventId do
newOutput <- liftIO $ fun =<< readIORef latestInputsRef
liftIO $ writeIORef latestOutputRef newOutput
- unsafeTrigger eventId renv newOutput
- updates = Event $ unsafeSubscribe eventId
+ unsafeTrigger eventId newOutput
+ updates = Event (unsafeSubscribe eventId)
updateList _ _ [] = []
updateList 0 a (_:xs) = a:xs
updateList n a (x:xs) = x : updateList (pred n) a xs
forM_ (zip [0..] dyns) \(i::Int, adyn) -> do
- dynamic_updates adyn `subscribe` \newVal -> do
+ adyn.updates.subscribe \newVal -> do
liftIO $ modifyIORef latestInputsRef $ updateList i newVal
defer eventId fire
return $ Dynamic (readIORef latestOutputRef) updates
--- | Read and increment 'renv_id_generator'
-nextQueueId :: ReactiveEnv -> IO QueueId
-nextQueueId ReactiveEnv{renv_id_generator} =
- atomicModifyIORef' renv_id_generator \eid -> (succ eid, eid)
-
--- | Defers a computation (typically an event firing) until the end of
--- the current reactive transaction. This allows for the avoidance of
--- double firing of events constructed from multiple other events.
-defer :: QueueId -> Step () -> Step ()
-defer k act =
- Step $ modify \(TransactState s) -> TransactState (Map.insert k act s)
-
--- | Run a reactive transaction.
-dynStep :: MonadIO m => Step a -> m a
-dynStep act = liftIO $ loop (TransactState Map.empty) act where
- loop :: TransactState -> Step a -> IO a
- loop rs (Step act) = do
- (r, newRs) <- runStateT act rs
- case popQueue newRs of
- (Just newAct, newerRs) -> r <$ loop newerRs newAct
- (Nothing, _newerRs) -> return r
- popQueue intact@(TransactState m) = case Map.minViewWithKey m of
- Just ((_, act), rest) -> (Just act, TransactState rest)
- Nothing -> (Nothing, intact)
-
-runReactiveT :: ReactiveT m a -> ReactiveEnv -> m a
-runReactiveT r = runReaderT (unReactiveT r)
-
-execReactiveT :: ReactiveEnv -> ReactiveT m a -> m a
-execReactiveT = flip runReactiveT
-
-unsafeSubscribe :: QueueId -> ReactiveEnv -> Callback a -> IO ()
-unsafeSubscribe eventId e@ReactiveEnv{renv_subscriptions, renv_finalizers} k = do
- subsId <- nextQueueId e
- let
- newCancel = (subsId, k . unsafeCoerce)
- f (SubscriptionSet s1) (SubscriptionSet s2) = SubscriptionSet (s1 <> s2)
- -- Unreacheable because FinalizerEventId always should map into
- -- SubscriptionSet
- f _ s = s
- modifyIORef' renv_subscriptions $
- flip Map.alter eventId $ Just . (newCancel :) . fromMaybe []
- modifyIORef' renv_finalizers $ Map.insertWith f (FinalizerEventId eventId)
- (SubscriptionSet (Set.singleton subsId))
-
-unsafeTrigger :: QueueId -> ReactiveEnv -> a -> Step ()
-unsafeTrigger eventId ReactiveEnv{..} a = defer eventId do
- subscriptions <- liftIO $ readIORef renv_subscriptions
- let callbacks = fromMaybe [] $ Map.lookup eventId subscriptions
- for_ callbacks $ ($ unsafeCoerce @_ @Any a) . snd
-
-instance Functor Event where
- fmap f (Event s) = Event \e k -> s e . (. f) $ k
+reactive :: (ReactiveScope -> ReactiveState -> (ReactiveState, a)) -> R a
+reactive f = ReactiveT $ ReaderT \rs -> StateT $ pure . swap . f rs
--- | Please be aware that in cases where both events fire during the
--- same 'Step,' the one having a higher 'EventId' will win, which is
--- very hard to predict, use with caution.
-instance Semigroup a => Semigroup (Event a) where
- (<>) (Event e1) (Event e2) = Event \e k -> mdo
- e1 e (defer eventId . k)
- e2 e (defer eventId . k)
- eventId <- nextQueueId e
- return ()
+reactive_ :: (ReactiveScope -> ReactiveState -> ReactiveState) -> R ()
+reactive_ f = ReactiveT $ ReaderT \rs -> StateT $ pure . ((),) . f rs
-instance Semigroup a => Monoid (Event a) where
- mempty = never
-
-instance Functor Dynamic where
- fmap f (Dynamic s u) = Dynamic (fmap f s) (fmap f u)
+type Lens' s a = forall f. Functor f => (a -> f a) -> s -> f s
-instance Applicative Dynamic where
- pure = constDyn
- (<*>) df da =
- let
- updatesEvent = Event \e k -> mdo
- let
- fire newF newA = defer eventId do
- f <- liftIO $ maybe (readDyn df) pure newF
- a <- liftIO $ maybe (readDyn da) pure newA
- k (f a)
- unEvent (updates df) e \f -> fire (Just f) Nothing
- unEvent (updates da) e \a -> fire Nothing (Just a)
- eventId <- nextQueueId e
- return ()
- in
- Dynamic
- { dynamic_read = liftA2 ($) (dynamic_read df) (dynamic_read da)
- , dynamic_updates = updatesEvent
- }
-
-instance Applicative m => HasReactiveEnv (ReactiveT m) where
- askReactiveEnv = ReactiveT $ ReaderT pure
+-- | Apply a lens to the value inside 'DynRef'
+lensMap :: forall s a. Lens' s a -> DynRef s -> DynRef a
+lensMap l s =
+ let
+ dynamic = Dynamic
+ (fmap (getConst . l Const) s.dynamic.sample)
+ (fmap (getConst . l Const) s.dynamic.updates)
+ modifier = Modifier \u f ->
+ unModifier s.modifier u $ swap . l (swap . f)
+ in
+ DynRef {dynamic, modifier}
+
+-- | Loop until transaction_queue is empty
+trampoline :: R a -> R a
+trampoline act = loop0 act where
+ loop0 :: R a -> R a
+ loop0 act = do
+ r <- act
+ loop1 =<< gets (.transaction_queue)
+ return r
+ loop1 :: Map EventId (R ()) -> R ()
+ loop1 q =
+ case Map.minViewWithKey q of
+ Nothing -> return ()
+ Just ((_, newAct), newQueue) -> do
+ modify \s -> s {transaction_queue = newQueue}
+ newAct
+ loop1 =<< gets (.transaction_queue)
+
+execReactiveT :: ReactiveScope -> ReactiveState -> ReactiveT m a -> m (a, ReactiveState)
+execReactiveT scope state = flip runStateT state . flip runReaderT scope . unReactiveT
+
+class MonadReactive m where
+ reactiv :: (ReactiveScope -> ReactiveState -> (ReactiveState, a)) -> m a
+
+reactiv_ :: MonadReactive m => (ReactiveScope -> ReactiveState -> ReactiveState) -> m ()
+reactiv_ f = reactiv (\r s -> (,()) $ f r s)
diff --git a/src/HtmlT/Types.hs b/src/HtmlT/Types.hs
index d53e64c..f3feab6 100644
--- a/src/HtmlT/Types.hs
+++ b/src/HtmlT/Types.hs
@@ -24,12 +24,10 @@ data HtmlEnv = HtmlEnv
, html_content_boundary :: Maybe ContentBoundary
-- ^ Boundary defined by parent scope where new content should be
-- attached, when Nothing whole parent element is available
- , html_reactive_env :: ReactiveEnv
- -- ^ Needed to implement 'HasReactiveEnv'
} deriving Generic
-- | Most applications will only need HtmlT IO, hence this shortcut
-type Html = HtmlT IO
+type Html = HtmlT (ReactiveT IO)
-- | A newtype over JSVal which is an instance of Node
-- https://developer.mozilla.org/en-US/docs/Web/API/Node
@@ -71,6 +69,3 @@ instance (Semigroup a, Applicative m) => Semigroup (HtmlT m a) where
instance (Monoid a, Applicative m) => Monoid (HtmlT m a) where
mempty = HtmlT $ ReaderT \_ -> pure mempty
-
-instance Monad m => HasReactiveEnv (HtmlT m) where
- askReactiveEnv = asks html_reactive_env
diff --git a/src/Wasm/Compat/Marshal.hs b/src/Wasm/Compat/Marshal.hs
index 6909f3b..5010b72 100644
--- a/src/Wasm/Compat/Marshal.hs
+++ b/src/Wasm/Compat/Marshal.hs
@@ -1,9 +1,11 @@
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE ForeignFunctionInterface #-}
-{-# LANGUAGE JavaScriptFFI #-}
{-# LANGUAGE MagicHash #-}
{-# LANGUAGE UnboxedTuples #-}
+#if defined(wasm32_HOST_ARCH)
+{-# LANGUAGE JavaScriptFFI #-}
+#endif
module Wasm.Compat.Marshal where
import Control.Monad
@@ -160,7 +162,7 @@ js_arrayPush :: JSVal -> JSVal -> IO () = undefined
js_arrayLength :: JSVal -> IO Int = undefined
js_arrayIndex :: JSVal -> Int -> IO JSVal = undefined
js_decodeUtf8 :: Ptr Word8 -> Int -> IO JSString = undefined
-js_encodeUtf8 :: JSString -> Ptr Word8 -> Int -> IO () = undefined
+js_encodeUtf8 :: JSString -> Ptr Word8 -> Int -> IO Int = undefined
js_stringLength :: JSString -> IO Int = undefined
#else
From ba63efc852e879f8d2ddf3d1b5c3178c9b08fe3f Mon Sep 17 00:00:00 2001
From: Vladislav How routing works
\
- \Route
:" <> highlightHaskell "\
- \data Route\n\
- \ = HomeR -- matches root route\n\
- \ | CountriesMapR CountriesMapQ -- example: #map?selected=ru\n\
- \ | CountriesListR CountriesListQ -- example: #list?page=3"
- <> "
\
- \Route
defines the list of webpages in the site. \
- \Constructor parameters (like CountriesMapQ
) indicate \
- \that this page takes some information from the URL string encoded in GET \
- \parameters or URL segments. By convention route contructors have suffix \
- \-R
and constructor parameters has suffix -Q
" <> highlightHaskell "\
- \parseRoute :: UrlParts -> Maybe Route\n\
- \parseRoute = \\case\n\
- \ Url [] [] -> Just HomeR\n\
- \ Url [\"map\"] q\n\
- \ | selected <- List.lookup \"selected\" q\n\
- \ -> Just $ CountriesMapR CountriesMapQ{selected}\n\
- \ Url [\"list\"] q\n\
- \ | search <- List.lookup \"search\" q\n\
- \ , page <- parsePage $ List.lookup \"page\" q\n\
- \ , sort_dir <- parseSortDir $ List.lookup \"sort_dir\" q\n\
- \ , sort_by <- parseSortBy $ List.lookup \"sort_by\" q\n\
- \ -> Just $ CountriesListR CountriesListQ{search, page, sort_dir, sort_by}"
- <> "
" <> highlightHaskell "\
- \printRoute :: Route -> UrlParts\n\
- \printRoute = \\case\n\
- \ HomeR -> Url [] []\n\
- \ CountriesMapR q -> Url [\"map\"] $ catMaybes\n\
- \ [ (\"selected\",) <$> q.selected ]\n\
- \ CountriesListR q -> Url [\"list\"] $ catMaybes\n\
- \ [ (\"search\",) <$> mfilter (/=\"\") q.search\n\
- \ , (\"page\",) <$> printPage q.page\n\
- \ , (\"sort_dir\",) <$> printSortDir q.sort_dir\n\
- \ , (\"sort_by\",) <$> printSortBy q.sort_by\n\
- \ ]"
- <> "
\
- \With help of haskell guarded pattern-match syntax it's easy to convert a \
- \URL in form of UrlParts
to a structured datatype like \
- \Route
and other way around. The type Route
and \
- \these two functions conclude the portable part of the routing mechanism. \
- \They can and should be shared with backend code to construct correct URLs \
- \and implement backend part of HTML5-style routing.
Last thing we need to run the site is this auxiliary function \
- \mkUrlHashRef \
- \that creates a DynRef Text
— dynamic value containing current \
- \hash-string from the browser. When parsed to Dynamic Route
\
- \and then mapped with (<&>)
operator to \
- \Dynamic (Html ())
the dyn
function can be used to \
- \attach the contents of dynamic pages to the application.\
- \
" <> highlightHaskell "\ - \dyn $ routeDyn <&> \\case\n\ - \ HomeR -> homePage\n\ - \ CountriesMapR q -> countriesMapPage q\n\ - \ CountriesListR q -> countriesListPage q" - <> "" - -countriesListPage :: CountriesListQ -> Html () -countriesListPage q = div_ [class_ "CountriesList"] do - searchQueryRef <- newRef q - form_ do - on @"submit" do - newRoute <- toUrl . CountriesListR . (\s -> s{page = 1}) <$> readRef searchQueryRef - pushUrl newRoute - div_ [style_ "display:flex;"] do - input_ - [ type_ "text" , placeholder_ "Search countries by title", autofocus_ True - ] do - dynValue $ fromMaybe "" . (.search) <$> fromRef searchQueryRef - on @"input" $ modifyRef searchQueryRef . (\v s -> s{search = v}) . Just - button_ [type_ "submit"] "Search" - table_ do - thead_ $ tr_ do - th_ "" - thSort SortByTitle "Country Name" - thSort SortByRegion "Region" - thSort SortBySubregion "Subregion" - thSort SortByPopulation "Population" - tbody_ do - for_ pageResults \(n, country) -> tr_ do - td_ do text (Text.pack (show @Int n)) - td_ do - a_ [href_ (mkMapLink country.code)] do - for_ country.flag_icon - (img_ . (>> style_ "display:inline; margin-right: 6px"). src_) - text country.title - td_ do text country.region - td_ do text country.subregion - td_ do text (Text.pack (show country.population)) - center_ do - for_ (paginate total q.page itemsPerPage) \case - Nothing -> - button_ [disabled_ True] "..." - Just p -> a_ - [ href_ (toUrl (CountriesListR q {page = p}))] $ - button_ [disabled_ (q.page == p)] $ text $ Text.pack $ show p - dl_ do - dt_ "Country" - dd_ $ unsafeHtml "The word country comes from \ - \Old French contrée, which derives from \ - \Vulgar Latin (terra) contrata (\"(land) lying \ - \opposite\"; \"(land) spread before\"), derived from contra \ - \(\"against, opposite\"). It most likely entered the English language \ - \after the Franco-Norman invasion\ - \ during the 11th century." - where - thSort sortBy title = th_ [style_ "cursor: pointer"] do - text title - case (q.sort_by, q.sort_dir) of - (sortVal, Asc) | sortVal == sortBy -> text "▲" - (sortVal, Desc) | sortVal == sortBy -> text "▼" - otherwise -> text "" - on @"click" do pushUrl $ toUrl . CountriesListR . toggleSortBy sortBy $ q - - toggleSortBy sortBy q - | q.sort_by == sortBy = q {sort_dir = flipDir q.sort_dir} - | otherwise = q {sort_by = sortBy, sort_dir = Asc} - where - flipDir = \case Asc -> Desc; Desc -> Asc - - offset = pred q.page * itemsPerPage - total = Prelude.length countryResults - pageResults = Prelude.zip [offset + 1..] - . Prelude.take itemsPerPage - . Prelude.drop offset - $ countryResults - countryResults = List.sortOn countrySortDir - . Prelude.filter countryFilter - $ countries - countryFilter country = case q.search of - Just needle -> - Text.isInfixOf (Text.toLower needle) (Text.toLower country.title) - Nothing -> True - countrySortBy = case q.sort_by of - SortByTitle -> Left . (.title) - SortByRegion -> Right . Left . (.region) - SortBySubregion -> Right . Right . Left . (.subregion) - SortByPopulation -> Right . Right . Right . (.population) - countrySortDir = case q.sort_dir of - Asc -> Left . countrySortBy - Desc -> Right . Down . countrySortBy - itemsPerPage = 40 - mkMapLink = toUrl . CountriesMapR . CountriesMapQ . Just . Text.toLower - -countriesMapPage :: CountriesMapQ -> Html () -countriesMapPage q = - div_ [class_ "CountriesMap"] $ - figure_ $ center_ do - unsafeHtml countriesMap - figcaption_ "political map of the planet Earth" - centerEl <- asks html_current_element - liftIO do - msel <- mapM toJSVal q.selected - js_selectCountry centerEl $ maybeToNullable msel - on @ClickWithEvent \event -> do - mcode <- liftIO (js_svgClickGetCountryCode event) - & (fmap nullableToMaybe) - & mapM fromJSVal - mapM_ (pushUrl . toUrl . CountriesMapR . CountriesMapQ . Just) mcode - -paginate - :: Int -- ^ Total number of items - -> Int -- ^ Current page - -> Int -- ^ Items per page - -> [Maybe Int] -- ^ List of page links, Nothing stands for ellipsis -paginate totalItems curPage limit - | totalPages <= maxLinks = - fmap Just [1..totalPages] - | curPage <= 7 = - fmap Just [1..8] <> [Nothing, Just totalPages] - | curPage >= totalPages - 6 = - [Just 1, Nothing] <> fmap Just [(totalPages - 8)..totalPages] - | otherwise = - [Just 1, Nothing] <> fmap Just [(curPage - 2)..(curPage + 3)] - <> [Nothing, Just totalPages] - where - (pageQuot, pageRem) = totalItems `divMod` limit - totalPages = if pageRem == 0 then pageQuot else pageQuot + 1 - maxLinks = 10 - - -data ClickWithEvent - -instance IsEventName ClickWithEvent where - type EventListenerCb ClickWithEvent = JSVal -> Step () - addEventListenerArgs = AddEventListenerArgs - { event_name = "dblclick" - , listener_options = defaultEventListenerOptions - , mk_callback = \k j -> k j - } diff --git a/examples/simple-routing/Router.hs b/examples/simple-routing/Router.hs deleted file mode 100644 index 050ceeb..0000000 --- a/examples/simple-routing/Router.hs +++ /dev/null @@ -1,185 +0,0 @@ -module Router where - -import Control.Monad -import Data.Bifunctor -import Data.List qualified as List -import Data.Maybe -import Data.Function -import GHC.Generics -import Text.Read -import Data.Text (Text) -import Data.Text qualified as Text -import Wasm.Compat.Prim -import Wasm.Compat.Marshal -import Data.Char qualified as C - -data UrlParts = Url - { partsPath :: [Text] -- ^ Path segments - , partsQuery :: [(Text, Text)] -- ^ GET parameters - } deriving (Eq, Show, Generic) - -data Route - = HomeR - | CountriesMapR CountriesMapQ - | CountriesListR CountriesListQ - deriving (Eq, Show, Generic) - -data CountriesListQ = CountriesListQ - { search :: Maybe Text - , page :: Int - , sort_by :: CountrySortBy - , sort_dir :: SortDir - } deriving (Eq, Show, Generic) - -data CountriesMapQ = CountriesMapQ - { selected :: Maybe Text - } deriving (Eq, Show, Generic) - -data SortDir = Asc | Desc - deriving (Eq, Show, Generic) - -data CountrySortBy - = SortByTitle - | SortByPopulation - | SortByRegion - | SortBySubregion - deriving (Eq, Show, Generic) - -parseRoute :: UrlParts -> Maybe Route -parseRoute = \case - Url [] [] -> Just HomeR - Url ["map"] q - | selected <- List.lookup "selected" q - -> Just $ CountriesMapR CountriesMapQ{selected} - Url ["list"] q - | search <- List.lookup "search" q - , page <- parsePage $ List.lookup "page" q - , sort_dir <- parseSortDir $ List.lookup "sort_dir" q - , sort_by <- parseSortBy $ List.lookup "sort_by" q - -> Just $ CountriesListR CountriesListQ{search, page, sort_dir, sort_by} - _ -> Nothing - where - parsePage = fromMaybe defaultCountriesListQ.page - . (parseIntQuery =<<) - parseSortDir = \case - Just "asc" -> Asc - Just "desc" -> Desc - _ -> defaultCountriesListQ.sort_dir - parseSortBy = \case - Just "title" -> SortByTitle - Just "population" -> SortByPopulation - Just "region" -> SortByRegion - Just "subregion" -> SortBySubregion - _ -> defaultCountriesListQ.sort_by - parseIntQuery = readMaybe . Text.unpack - -printRoute :: Route -> UrlParts -printRoute = \case - HomeR -> Url [] [] - CountriesMapR q -> Url ["map"] $ catMaybes - [ ("selected",) <$> q.selected ] - CountriesListR q -> Url ["list"] $ catMaybes - [ ("search",) <$> mfilter (/="") q.search - , ("page",) <$> printPage q.page - , ("sort_dir",) <$> printSortDir q.sort_dir - , ("sort_by",) <$> printSortBy q.sort_by - ] - where - printPage = fmap toIntQuery . - mfilter (/=defaultCountriesListQ.page) . Just - printSortDir = fmap (\case - Asc -> "asc" - Desc -> "desc") . - mfilter (/=defaultCountriesListQ.sort_dir) . Just - printSortBy = fmap (\case - SortByTitle -> "title" - SortByPopulation -> "population" - SortByRegion -> "region" - SortBySubregion -> "subregion") . - mfilter (/=defaultCountriesListQ.sort_by) . Just - toIntQuery = Text.pack . show - -defaultCountriesListQ :: CountriesListQ -defaultCountriesListQ = CountriesListQ - { search = Nothing - , page = 1 - , sort_by = SortByPopulation - , sort_dir = Desc - } - -defaultCountriesMapQ :: CountriesMapQ -defaultCountriesMapQ = CountriesMapQ - { selected = Nothing - } - -toUrl :: Route -> Text -toUrl = ("#"<>) . printUrlParts . printRoute - -fromUrl :: Text -> Maybe Route -fromUrl url = url - & Text.stripPrefix "#" - & fromMaybe url - & parseUrlParts - & parseRoute - -printUrlParts :: UrlParts -> Text -printUrlParts (Url s q) = Text.intercalate "?" (segments : query) - where - segments = - Text.intercalate "/" $ fmap encodeURIComponent s - query = q - & fmap (bimap encodeURIComponent encodeURIComponent) - & fmap (\(k, v) -> k <> "=" <> v) - & List.filter (not . Text.null) - & Text.intercalate "&" - & List.filter (not . Text.null) . (:[]) - -parseUrlParts :: Text -> UrlParts -parseUrlParts t = Url segments query - where - (segmentsStr, queryStr) = breakOn1 "?" t - segments = segmentsStr - & Text.splitOn "/" - & List.filter (not . Text.null) - & fmap decodeURIComponent - query = queryStr - & Text.splitOn "&" - & List.filter (not . Text.null) - & fmap (breakOn1 "=" . decodeURIComponent) - breakOn1 s t = - let (a, b) = Text.breakOn s t in (a, Text.drop 1 b) - -encodeURIComponent :: Text -> Text -encodeURIComponent = - Text.pack . concatMap encodeChar . Text.unpack - where - encodeChar c - | C.isAlphaNum c = [c] - | c == ' ' = "+" - | otherwise = '%' : showHex (C.ord c) "" - showHex :: Int -> String -> String - showHex n acc - | n < 16 = intToDigit n : acc - | otherwise = let (q,r) = n `divMod` 16 in showHex q (intToDigit r : acc) - intToDigit :: Int -> Char - intToDigit n - | 0 <= n && n <= 9 = toEnum (fromEnum '0' + n) - | 10 <= n && n <= 15 = toEnum (fromEnum 'a' + n - 10) - | otherwise = error "intToDigit: not a digit" - -decodeURIComponent :: Text -> Text -decodeURIComponent = - Text.pack . decode . Text.unpack - where - decode [] = [] - decode ('%':x1:x2:xs) - | C.isHexDigit x1 && C.isHexDigit x2 = - C.chr (16 * digitToInt x1 + digitToInt x2) : decode xs - decode ('+':xs) = ' ' : decode xs - decode (x:xs) = x : decode xs - digitToInt :: Char -> Int - digitToInt c - | '0' <= c && c <= '9' = fromEnum c - fromEnum '0' - | 'a' <= c && c <= 'f' = fromEnum c - fromEnum 'a' + 10 - | 'A' <= c && c <= 'F' = fromEnum c - fromEnum 'A' + 10 - | otherwise = error "digitToInt: not a digit" diff --git a/examples/simple-routing/Utils.hs b/examples/simple-routing/Utils.hs deleted file mode 100644 index 9b997b7..0000000 --- a/examples/simple-routing/Utils.hs +++ /dev/null @@ -1,82 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE ForeignFunctionInterface #-} -{-# LANGUAGE JavaScriptFFI #-} -module Utils where - -import Control.Monad.IO.Class -import Data.Coerce -import HtmlT -import Wasm.Compat.Prim -import Wasm.Compat.Marshal -import Unsafe.Coerce - -mkUrlHashRef :: MonadReactive m => m (DynRef JSString) -mkUrlHashRef = do - initial <- liftIO js_readUrlHash - routeRef <- newRef initial - win <- getCurrentWindow - popStateCb <- liftIO $ js_dynExport1 \_ -> - js_readUrlHash >>= dynStep . writeRef routeRef - liftIO $ js_addEventListener win ((\(JSString j) -> j) $ toJSString "onpopstate") popStateCb - return routeRef - -pushUrl :: MonadIO m => JSString -> m () -pushUrl url = liftIO $ js_pushHref url - -highlightHaskell :: JSString -> JSString -highlightHaskell = js_highlightHaskell - -insertScript :: JSString -> IO () -insertScript = js_insertScript - -#if defined(wasm32_HOST_ARCH) -foreign import javascript unsafe - "(function(el, code){\ - if (!code) return;\ - var svgGroup = el.querySelector('#' + code); if (!svgGroup) return;\ - var svgPaths = svgGroup instanceof SVGPathElement ? [svgGroup] : svgGroup.querySelectorAll('path');\ - for (var i = 0; i < svgPaths.length; i++) {\ - svgPaths[i].classList.add('selected');\ - }\ - svgGroup.parentElement.appendChild(svgGroup);\ - })($1,$2)" - js_selectCountry :: DOMElement -> Nullable JSVal -> IO () - -foreign import javascript unsafe - "(function(event){\ - var iter = event.target;\ - for(;;){\ - if (!iter || !iter.parentNode) break;\ - /*