diff --git a/ChangeLog.md b/ChangeLog.md new file mode 100644 --- /dev/null +++ b/ChangeLog.md @@ -0,0 +1,84 @@ +# Revision history for reflex-dom + +## 0.6.3.4 + +* Fix WASM related issues + +## 0.6.3.3 + +* Support GHC 9.12 + +## 0.6.3.2-r1 + +* Require reflex-dom-core >= 0.8.1.0 + +## 0.6.3.2 + +* Build with GHC 9.10 + +## 0.6.3.1-r1 + +* Require reflex-dom-core >= 0.8.1.0 + +## 0.6.3.1 + +* Don't depend on webkit2gtk on android + +## 0.6.3.0 + +* Use android-activity 0.2 +* Fix bug in android back button handler + +## 0.6.2.0 + +* [#452](https://github.com/reflex-frp/reflex-dom/pull/452) Allow file access on newer android, following usage recommended by the [official docs](https://developer.android.com/reference/androidx/webkit/WebViewAssetLoader) +* [#453](https://github.com/reflex-frp/reflex-dom/pull/453) History management for android + +## 0.6.1.1-r1 + +* Loosen reflex-dom-core version bounds to allow reflex-dom-core 0.7.* + +## 0.6.1.1 + +* Compile with -fPIC + +## 0.6.1.0-r1 + +* Loosen reflex-dom-core version bounds + +## 0.6.1.0 + +* Update for new dependent-map and dependent-sum (after the "some" package split) + +## 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 + permissions on demand by default. See + https://developer.android.com/reference/android/webkit/WebChromeClient.html#onGeolocationPermissionsShowPrompt(java.lang.String,%20android.webkit.GeolocationPermissions.Callback) + for details. + + * Add `< 0.7` upper bound for reflex + +## 0.5.2 + +* The default jsaddle backend on macOS when built from nix + is now jsaddle-wkwebview, matching the behaviour of cabal + builds. + +## 0.5 + +* Re-export new hydration widget "mainWidget" functions. + +* The use-warp flag now properly takes precedence on macOS. diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,4 +1,4 @@ -Copyright (c) 2015, Obsidian Systems LLC +Copyright (c) 2020, Obsidian Systems LLC All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: diff --git a/benchmark.hs b/benchmark.hs new file mode 100644 --- /dev/null +++ b/benchmark.hs @@ -0,0 +1,190 @@ +{-# LANGUAGE RecursiveDo #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE Rank2Types #-} +{-# OPTIONS_GHC -ddump-simpl -ddump-rules -ddump-spec -ddump-to-file -dsuppress-coercions -dsuppress-idinfo #-} +module Main (main) where + +import Control.Monad.State +import Data.Monoid +import Data.Text (Text) +import qualified Data.Text as T +import Reflex.Dom +import System.Random +import qualified Data.Map as Map +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 +import Data.IORef +import GHCJS.DOM.Types (JSM) +import qualified Data.Some as Some +import Data.Functor.Constant +import Data.IntMap.Strict (IntMap) +import qualified Data.IntMap.Strict as IntMap +import Data.FastMutableIntMap + +import qualified GHCJS.DOM.Element as DOM +import qualified GHCJS.DOM.Types as DOM + +--{- +main :: IO () +main = mainWidget' $ do + create1000 <- button "Create 1,000 rows" + let row k _ = el "li" $ text $ T.pack $ show k + el "ul" $ traverseIntMapWithKeyWithAdjust row IntMap.empty $ PatchIntMap (IntMap.fromDistinctAscList [(x, Just ()) | x <- [1 :: Int .. 1000]]) <$ create1000 + return () +--} + + +{- +main :: IO () +main = do + mainWidget' $ do + create1000 <- button "Create 1,000 rows" + partialUpdate <- button "Update every 10th row" + elClass "table" "table table-hover table-striped test-data" $ el "tbody" $ do + --runWithReplace blank $ forM_ [1..1000] row <$ create1000 + rec let u = leftmost + [ PatchIntMap (IntMap.fromDistinctAscList [(x, Just ()) | x <- [1..1000]]) <$ create1000 + , PatchIntMap (IntMap.fromDistinctAscList [(x, Just ()) | x <- [1, 11..1000]]) <$ partialUpdate + , PatchIntMap <$> deletes + ] + (_, deletes) <- runEventWriterT $ traverseIntMapWithKeyWithAdjust (\k _ -> row k) mempty u + return () + +row :: MonadWidget t m => Int -> EventWriterT t (IntMap (Maybe ())) m () +row rowNum = el "tr" $ do + elClass "td" "col-md-1" $ text $ T.pack $ show rowNum + (sel, _) <- elClass' "td" "col-md-4" $ el "a" $ text "asdf" + (del, _) <- elClass' "td" "col-md-1" deleteButton + tellEvent $ IntMap.singleton rowNum Nothing <$ domEvent Click del + elClass "td" "col-md-6" blank + +deleteButton :: MonadWidget t m => m () +deleteButton = el "a" $ elAttr "span" ("aria-hidden" =: "true" <> "class" =: "glyphicon glyphicon-remove") $ text "X" + +--} + +-- +{- +type RNG = StdGen +type Entropy = Int +type RowPosition = Int +type RowNumber = Int +data Row = Row { pos :: RowPosition, num :: RowNumber , txt :: Text } deriving (Eq, Show) +type Table = Map RowPosition Row +data Model = Model { rng :: RNG, table :: Table, nextNum :: RowNumber, selected :: Maybe Row } deriving Show + +{- Widgets -} + +titleW :: MonadWidget t m => m () +titleW = text "Reflex-Dom" + +headW :: MonadWidget t m => m () +headW = do + el "title" titleW + elAttr "link" ("href" =: "/css/currentStyle.css" <> "rel" =: "stylesheet") blank + +bodyW :: MonadWidget t m => Entropy -> m () +bodyW seed = divClass "main" $ divClass "container" $ mdo + let initial = Model { rng = mkStdGen seed, table = empty, nextNum = 1, selected = Nothing } + dynModel <- foldDyn ($) initial $ mergeWith (.) $ rowEvents : buttonEvents + + buttonEvents :: [Event t (Model -> Model)] <- divClass "jumbotron" $ divClass "row" $ do + divClass "col-md-6" $ el "h1" titleW + divClass "col-md-6" $ divClass "row" $ sequence [ + buttonW "run" "Create 1,000 rows" $ createRows 1000, + buttonW "runlots" "Create 10,000 rows" $ createRows 10000, + buttonW "add" "Append 1,000 rows" $ appendRows 1000, + buttonW "update" "Update every 10th row" $ updateRows (\p -> mod p 10 == 0) (<> " !!!"), + buttonW "clear" "Clear" $ clearRows, + buttonW "swaprows" "Swap Rows" $ swapRows (4, 9) + ] + + rowEvents' <- tableW dynModel + let rowEvents = foldl (.) id <$> rowEvents' + + blank + +buttonW :: MonadWidget t m => Text -> Text -> a -> m (Event t a) +buttonW id txt val = divClass "col-sm-6 smallpad" $ buttonW' ("class" =: "btn btn-primary btn-block" <> "id" =: id) + where + buttonW' attrs = do + (b, _) <- elAttr' "button" attrs $ text txt + pure $ val <$ domEvent Click b + +tableW :: MonadWidget t m => Dynamic t Model -> m (Event t (Map RowPosition (Model -> Model))) +tableW dynM = + elClass "table" "table table-hover table-striped test-data" + $ el "tbody" + $ listViewWithKey (table <$> dynM) (\_ dynRow -> rowW (selectedIs <$> dynM <*> dynRow) dynRow) + where + selectedIs m r = selected m == Just r + +rowW :: MonadWidget t m => Dynamic t Bool -> Dynamic t Row -> m (Event t (Model -> Model)) +rowW dynSelected dynRow = elDynClass "tr" trClass $ + do + elClass "td" "col-md-1". dynText $ pack . show . num <$> dynRow + (sel, _) <- elClass' "td" "col-md-4". el "a" . dynText $ txt <$> dynRow + (del, _) <- elClass' "td" "col-md-1" deleteW + elClass "td" "col-md-6" blank + pure $ mergeWith (.) $ zipWith tagClick [selectRow, deleteRow] [sel, del] + where + trClass = (\b -> if b then "danger" else "") <$> dynSelected + tagClick f el = (tag . current) (f <$> dynRow) (domEvent Click el) + + +{- Domain logic -} + +clearRows :: Model -> Model +clearRows (Model {..}) = Model { table = empty, .. } + +updateRows :: (RowPosition -> Bool) -> (Text -> Text) -> Model -> Model +updateRows p f (Model {..}) = Model { table = (update <$> targets) <> table, .. } + where + targets = filterWithKey (const . p) table + update = \(Row{..}) -> Row { txt = f txt, ..} + +swapRows :: (RowPosition, RowPosition) -> Model -> Model +swapRows (a,b) (Model {..}) = Model { table = (a =: val b) <> (b =: val a) <> table, .. } + where val = (table !) + +selectRow, deleteRow :: Row -> Model -> Model +selectRow r m = m { selected = Just r } +deleteRow r (Model {..}) = Model { table = shifted table, .. } + where + shifted = fromList . zipWith update [0..] . elems . delete (pos r) + update p (Row{..}) = (p, Row { pos = p, .. }) + +createRows, appendRows :: Int -> Model -> Model +createRows = newRows False +appendRows = newRows True + +newRows :: Bool -> Int -> Model -> Model +newRows keepOld count (Model {..}) = Model { rng = rng', table = table', nextNum = nextNum', .. } + where + nextPos = if keepOld then length table else 0 + rowsST = sequence (rowST <$ [0..count-1]) + (rows, (nextPos', nextNum', rng')) = runState rowsST (nextPos, nextNum, rng) + combine = if keepOld then (<>) else \_ new -> new + table' = fromList . zip [0..] $ combine (elems table) rows + +rowST :: State (RowPosition, RowNumber, RNG) Row +rowST = state (\(p,n,g) -> let (e, g') = next g in (Row {pos = p, num = n, txt = randomName e}, (p+1,n+1,g'))) + +randomName :: Entropy -> Text +randomName e = intercalate " " $ (!!% e) <$> [adjectives, colours, nouns] + where xs !!% n = xs !! mod n (length xs) + +adjectives,colours,nouns :: [Text] +adjectives = ["pretty", "large", "big", "small", "tall", "short", "long", "handsome", "plain", "quaint", "clean", "elegant", "easy", "angry", "crazy", "helpful", "mushy", "odd", "unsightly", "adorable", "important", "inexpensive", "cheap", "expensive", "fancy"] +colours = ["red", "yellow", "blue", "green", "pink", "brown", "purple", "brown", "white", "black", "orange"] +nouns = ["table", "chair", "house", "bbq", "desk", "car", "pony", "cookie", "sandwich", "burger", "pizza", "mouse", "keyboard"] + +-} diff --git a/benchmarks/krausest.hs b/benchmarks/krausest.hs new file mode 100644 --- /dev/null +++ b/benchmarks/krausest.hs @@ -0,0 +1,222 @@ +{-# LANGUAGE RecursiveDo #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE FlexibleContexts #-} +{-# OPTIONS_GHC -fmax-simplifier-iterations=5 -ddump-simpl -ddump-to-file -dsuppress-coercions -dsuppress-idinfo #-} +import Control.Monad.State +import Data.Monoid +import Data.IntMap (IntMap, assocs, elems, empty, fromList, size, singleton) +import Data.Text (Text) +import qualified Data.Text as T +import Data.Vector (Vector) +import qualified Data.Vector as Vector +import Reflex.Dom +import Data.FastMutableIntMap +import System.Random + +type RNG = StdGen +type Entropy = Int +type RowNumber = Int +type RowIndex = Int +data Row = Row { num :: RowNumber, txt :: Text, selected :: Bool } deriving (Eq, Show) +type Table = IntMap Row +data Model = Model { rng :: RNG, nextNum :: RowNumber, selection :: Maybe Row } deriving Show +type TableDiff = PatchIntMap Row + +main :: IO () +main = do + seed <- randomIO + mainWidgetWithHead' (\_ -> headW, \_ -> bodyW seed) + +titleW :: DomBuilder t m => m () +titleW = text "Reflex-dom keyed" + +headW :: DomBuilder t m => m () +headW = do + el "title" titleW + elAttr "link" ("href" =: "/css/currentStyle.css" <> "rel" =: "stylesheet") blank + +bodyW :: forall t m. (MonadFix m, MonadHold t m, DomBuilder t m) => Entropy -> m () +bodyW seed = divClass "main" $ divClass "container" $ mdo + buttonEvents <- divClass "jumbotron" $ divClass "row" $ do + divClass "col-md-6" $ el "h1" titleW + divClass "col-md-6" $ divClass "row" $ sequence + [ buttonW "run" "Create 1,000 rows" $ resetRows 1000 + , buttonW "runlots" "Create 10,000 rows" $ resetRows 10000 + , buttonW "add" "Append 1,000 rows" $ appendRows 1000 + , buttonW "update" "Update every 10th row" $ updateRows (\i -> mod i 10 == 0) (<> " !!!") + , buttonW "clear" "Clear" $ clearRows + , buttonW "swaprows" "Swap Rows" $ swapRows (1, 998) + ] + + let initial = Model { rng = mkStdGen seed, nextNum = 1, selection = Nothing } + let events = leftmost $ fmap (foldl1 sequenceSteps) rowEvents : buttonEvents + + rowEvents <- tableW dynMT + + dynMT <- mapAccum_ step (initial, empty) events + + elAttr "span" ("class" =: "preloadicon glyphicon glyphicon-remove" <> "aria-hidden" =: "true") blank + + blank + +type Step = (Model, Table) -> (Model, TableDiff) + +sequenceSteps :: Step -> Step -> Step +sequenceSteps a b (m, t) = + let (ma, tda) = a (m, t) + ta = applyAlways tda t + (mb, tdb) = b (ma, ta) + in (mb, tdb <> tda) + +step :: (Model, Table) -> Step -> ((Model, Table), TableDiff) +step (m, t) f = ((m', t'), dt) + where + (m', dt) = f (m, t) + t' = applyAlways dt t + +buttonW :: DomBuilder t m => Text -> Text -> a -> m (Event t a) +buttonW id txt val = divClass "col-sm-6 smallpad" $ buttonW' ("class" =: "btn btn-primary btn-block" <> "id" =: id) + where + buttonW' attrs = do + (b, _) <- elAttr' "button" attrs $ text txt + pure $ val <$ domEvent Click b + +tableW :: (MonadHold t m, DomBuilder t m) => Event t TableDiff -> m (Event t (IntMap Step)) +tableW diff = do + elClass "table" "table table-hover table-striped test-data" $ do + el "tbody" $ do + (v0, v') <- traverseIntMapWithKeyWithAdjust (\_ -> rowW) empty diff + rowEvents <- holdIncremental v0 v' + return $ mergeIntIncremental rowEvents + +rowW :: DomBuilder t m => Row -> m (Event t Step) +rowW row = elClass "tr" (if selected row then "danger" else "") $ + do + elClass "td" "col-md-1" $ do + text $ T.pack $ show $ num row + (sel, _) <- elClass' "td" "col-md-4". el "a" . text $ txt row + (del, _) <- elClass' "td" "col-md-1" deleteW + elClass "td" "col-md-6" blank + pure . leftmost $ zipWith tagClick [selectRow, deleteRow] [sel, del] + where + tagClick f el = f row <$ (domEvent Click el) + +deleteW :: DomBuilder t m => m () +deleteW = el "a" $ elAttr "span" ("aria-hidden" =: "true" <> "class" =: "glyphicon glyphicon-remove") blank + + +{- Domain logic -} +clearRows :: (Model, Table) -> (Model, TableDiff) +clearRows (m, t) = (m { selection = Nothing }, PatchIntMap $ Nothing <$ t) + +updateRows :: (RowIndex -> Bool) -> (Text -> Text) -> (Model, Table) -> (Model, TableDiff) +updateRows p f (m, t) = (m, PatchIntMap $ Just . update <$> targets) + where + targets = fromList . filterByIndex p . assocs $ t + update = \r -> r { txt = f $ txt r } + +filterByIndex :: (Int -> Bool) -> [a] -> [a] +filterByIndex p = map snd . filter (\(i, _) -> p i) . zip [0..] + +swapRows :: (RowIndex, RowIndex) -> (Model, Table) -> (Model, TableDiff) +swapRows (a, b) (m, t) = (m, PatchIntMap $ if max a b < length t then swap else empty) + where + swap = point a b <> point b a + point x y = singleton (fst (val x)) $ Just $ snd $ val y + val = (assocs t !!) + +selectRow :: Row -> (Model, Table) -> (Model, TableDiff) +selectRow r (m, t) = (m { selection = Just r}, PatchIntMap $ dr <> ds) + where + dr = sel True r + ds = maybe empty (sel False) $ selection m + sel b r' = singleton (num r') $ Just r' { selected = b } + +deleteRow :: Row -> (Model, Table) -> (Model, TableDiff) +deleteRow r (m, t) = (m { selection = mfilter (/= r) (selection m) }, PatchIntMap $ singleton (num r) Nothing) + +resetRows :: Int -> (Model, Table) -> (Model, TableDiff) +resetRows n (m, t) = (m'', dt <> dt') + where + (m', dt ) = addRows n (m, t) + (m'', dt') = clearRows (m', t) + +appendRows :: Int -> (Model, Table) -> (Model, TableDiff) +appendRows n (m, t) = addRows n (m, t) + +addRows :: Int -> (Model, Table) -> (Model, TableDiff) +addRows count (m, t) = (m { rng = rng', nextNum = nextNum' }, PatchIntMap diff) + where + rowsST = sequence (rowST <$ [0..count-1]) + (rows, (nextNum', rng')) = runState rowsST (nextNum m, rng m) + diff = fromList . fmap (\r -> (num r, Just r)) $ rows + +rowST :: State (RowNumber, RNG) Row +rowST = state (\(n, g) -> let (e, g') = next g in (Row {num = n, txt = randomName e, selected = False}, (n+1, g'))) + +randomName :: Entropy -> Text +randomName e = T.intercalate " " $ (`modIndex` e) <$> [adjectives, colours, nouns] + +-- | Index into a Vector, modulo its length +-- +-- WARNING: The vector must have length >= 1, and the index must be >= 0. +modIndex :: Vector a -> Int -> a +modIndex v n = Vector.unsafeIndex v $ n `mod` Vector.length v + +adjectives, colours, nouns :: Vector Text +adjectives = Vector.fromList + [ "pretty" + , "large" + , "big" + , "small" + , "tall" + , "short" + , "long" + , "handsome" + , "plain" + , "quaint" + , "clean" + , "elegant" + , "easy" + , "angry" + , "crazy" + , "helpful" + , "mushy" + , "odd" + , "unsightly" + , "adorable" + , "important" + , "inexpensive" + , "cheap" + , "expensive" + , "fancy" + ] +colours = Vector.fromList + [ "red" + , "yellow" + , "blue" + , "green" + , "pink" + , "brown" + , "purple" + , "brown" + , "white" + , "black" + , "orange" + ] +nouns = Vector.fromList + [ "table" + , "chair" + , "house" + , "bbq" + , "desk" + , "car" + , "pony" + , "cookie" + , "sandwich" + , "burger" + , "pizza" + , "mouse" + , "keyboard" + ] diff --git a/cbits/MainWidget.c b/cbits/MainWidget.c new file mode 100644 --- /dev/null +++ b/cbits/MainWidget.c @@ -0,0 +1,123 @@ +#include +#include +#include +#include +#include +#include "MainWidget.h" + +jobject Reflex_Dom_Android_MainWidget_start(jobject activity, const char *url, const JSaddleCallbacks *jsaddleCallbacks) { + assert(activity); + assert(url); + + JNIEnv *env; + jint attachResult = (*HaskellActivity_jvm)->AttachCurrentThread(HaskellActivity_jvm, &env, NULL); + assert(attachResult == JNI_OK); + + jclass cls = (*env)->FindClass(env, "org/reflexfrp/reflexdom/MainWidget"); + assert(cls); + jmethodID startMainWidget = (*env)->GetStaticMethodID(env, cls, "startMainWidget", "(Lsystems/obsidian/HaskellActivity;Ljava/lang/String;JLjava/lang/String;)Ljava/lang/Object;"); + assert(startMainWidget); + + jstring jurl = (*env)->NewStringUTF(env, url); + assert(jurl); + jstring initialJS = (*env)->NewStringUTF(env, jsaddleCallbacks->jsaddleJsData); + jobject result = (*env)->CallStaticObjectMethod(env, cls, startMainWidget, activity, jurl, (jlong)jsaddleCallbacks, initialJS); + (*env)->DeleteLocalRef(env, initialJS); + if((*env)->ExceptionOccurred(env)) { + __android_log_write(ANDROID_LOG_DEBUG, "MainWidget", "startMainWidget exception"); + (*env)->ExceptionDescribe(env); + } + return (*env)->NewGlobalRef(env, result); +} + +void Reflex_Dom_Android_MainWidget_runJS(jobject jsExecutor, const char* js, size_t js_len) { + JNIEnv *env; + jint attachResult = (*HaskellActivity_jvm)->AttachCurrentThread(HaskellActivity_jvm, &env, NULL); + assert (attachResult == JNI_OK); + + (*env)->PushLocalFrame(env, 5); + + //TODO: Don't search for this method every time + jclass cls = (*env)->GetObjectClass(env, jsExecutor); + assert(cls); + jmethodID evaluateJavascript = (*env)->GetMethodID(env, cls, "evaluateJavascript", "([B)V"); + assert(evaluateJavascript); + jbyteArray js_str = (*env)->NewByteArray(env, js_len); + (*env)->SetByteArrayRegion(env, js_str, 0, js_len, (const jbyte*)js); + (*env)->CallVoidMethod(env, jsExecutor, evaluateJavascript, js_str, 0); + if((*env)->ExceptionOccurred(env)) { + __android_log_write(ANDROID_LOG_DEBUG, "MainWidget", "runJS exception"); + (*env)->ExceptionDescribe(env); + } + + (*env)->PopLocalFrame(env, 0); +} + +void Reflex_Dom_Android_MainWidget_back(jobject jsExecutor) { + JNIEnv *env; + jint attachResult = (*HaskellActivity_jvm)->AttachCurrentThread(HaskellActivity_jvm, &env, NULL); + assert (attachResult == JNI_OK); + + (*env)->PushLocalFrame(env, 5); + + //TODO: Don't search for this method every time + jclass cls = (*env)->GetObjectClass(env, jsExecutor); + assert(cls); + jmethodID evaluateJavascript = (*env)->GetMethodID(env, cls, "goBack", "()V"); + assert(evaluateJavascript); + (*env)->CallVoidMethod(env, jsExecutor, evaluateJavascript); + + (*env)->PopLocalFrame(env, 0); +} + +void Reflex_Dom_Android_MainWidget_clearHistory(jobject jsExecutor) { + JNIEnv *env; + jint attachResult = (*HaskellActivity_jvm)->AttachCurrentThread(HaskellActivity_jvm, &env, NULL); + assert (attachResult == JNI_OK); + + (*env)->PushLocalFrame(env, 5); + + //TODO: Don't search for this method every time + jclass cls = (*env)->GetObjectClass(env, jsExecutor); + assert(cls); + jmethodID evaluateJavascript = (*env)->GetMethodID(env, cls, "clearHistory", "()V"); + assert(evaluateJavascript); + (*env)->CallVoidMethod(env, jsExecutor, evaluateJavascript); + + (*env)->PopLocalFrame(env, 0); +} + +JNIEXPORT void JNICALL Java_org_reflexfrp_reflexdom_MainWidget_00024JSaddleCallbacks_startProcessing (JNIEnv *env, jobject thisObj, jlong callbacksLong) { + const JSaddleCallbacks *callbacks = (const JSaddleCallbacks *)callbacksLong; + (*(callbacks->jsaddleStart))(); + return; +} + +JNIEXPORT void JNICALL Java_org_reflexfrp_reflexdom_MainWidget_00024JSaddleCallbacks_processMessage (JNIEnv *env, jobject thisObj, jlong callbacksLong, jbyteArray msg) { + const JSaddleCallbacks *callbacks = (const JSaddleCallbacks *)callbacksLong; + + jbyte *msg_str = (*env)->GetByteArrayElements(env, msg, NULL); + jsize msg_str_len = (*env)->GetArrayLength(env, msg); + (*(callbacks->jsaddleResult))(msg_str, msg_str_len); + (*env)->ReleaseByteArrayElements(env, msg, msg_str, JNI_ABORT); + return; +} + +JNIEXPORT jbyteArray JNICALL Java_org_reflexfrp_reflexdom_MainWidget_00024JSaddleCallbacks_processSyncMessage (JNIEnv *env, jobject thisObj, jlong callbacksLong, jbyteArray msg) { + const JSaddleCallbacks *callbacks = (const JSaddleCallbacks *)callbacksLong; + + char const *next_str; + size_t next_str_len; + + jbyte *msg_str = (*env)->GetByteArrayElements(env, msg, NULL); + jsize msg_str_len = (*env)->GetArrayLength(env, msg); + (*(callbacks->jsaddleSyncResult))(msg_str, msg_str_len, &next_str, &next_str_len); + (*env)->ReleaseByteArrayElements(env, msg, msg_str, JNI_ABORT); + + jbyteArray next_jstr = (*env)->NewByteArray(env, next_str_len); + (*env)->SetByteArrayRegion(env, next_jstr, 0, next_str_len, next_str); + + free(next_str); + + return next_jstr; +} diff --git a/cbits/include/MainWidget.h b/cbits/include/MainWidget.h new file mode 100644 --- /dev/null +++ b/cbits/include/MainWidget.h @@ -0,0 +1,13 @@ +#ifndef MAINWIDGET_H_INCLUDED +#define MAINWIDGET_H_INCLUDED + +#include + +typedef struct JSaddleCallbacks { + void (* jsaddleStart) (); + void (* jsaddleResult) (const char *, size_t); + void (* jsaddleSyncResult) (const char *, size_t, const char**, size_t*); + char * jsaddleJsData; +} JSaddleCallbacks; + +#endif diff --git a/examples/sortableList.hs b/examples/sortableList.hs new file mode 100644 --- /dev/null +++ b/examples/sortableList.hs @@ -0,0 +1,84 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecursiveDo #-} +{-# LANGUAGE ScopedTypeVariables #-} +import Control.Lens +import Control.Monad.Fix +import Control.Monad.IO.Class +import Data.List +import Data.Map (Map) +import qualified Data.Map as Map +import Data.Ord +import Data.Patch.MapWithMove +import qualified Data.Text as T +import Data.Time.Clock +import Reflex.Dom +import System.Random + +#if defined(wasm32_HOST_ARCH) +foreign export javascript "hs_start" main :: IO () +#endif + +main :: IO () +main = mainWidget $ do + let f _ (a, b, c) = el "tr" $ do + mapM_ (el "td" . text . T.pack . show) [a, b, c] + _ <- el "td" $ inputElement def + return () + let numKeys = 1000 :: Int + keys = take numKeys [0 :: Int ..] + values :: [(Int, Int, Int)] + values = zip3 (randoms (mkStdGen 0)) (randoms (mkStdGen 1)) (randoms (mkStdGen 2)) + testMap = Map.fromList $ zip keys values + resortButtons = el "div" $ leftmost <$> sequence + [ (comparing (view _1) <$) <$> button "A ASC" + , (flip (comparing (view _1)) <$) <$> button "A DESC" + , (comparing (view _2) <$) <$> button "B ASC" + , (flip (comparing (view _2)) <$) <$> button "B DESC" + , (comparing (view _3) <$) <$> button "C ASC" + , (flip (comparing (view _3)) <$) <$> button "C DESC" + ] + el "h1" $ text "Improved list sorting" + el "p" $ text $ "This app shows a table of " <> T.pack (show numKeys) <> " rows, and allows you to re-sort by columns a, b, and c, which are full of pseudorandom numbers. Each row also includes an element with internal state (a textbox) to demonstrate that the state is preserved, only when using the new way." + el "h3" $ text "Re-sort the list the OLD way (by redrawing everything)" + resortSlow <- resortButtons + displayRedrawTime resortSlow + el "h3" $ text "Re-sort the list the NEW way (by reordering existing elements)" + resort <- resortButtons + displayRedrawTime resort + el "hr" blank + el "table" $ do + el "tr" $ do + el "th" $ text "A" + el "th" $ text "B" + el "th" $ text "C" + el "th" $ text "Stateful Element (textbox)" + simpleSortableList f testMap resort resortSlow + return () + +displayRedrawTime :: (DomBuilder t m, MonadHold t m, PostBuild t m, PerformEvent t m, TriggerEvent t m, MonadIO (Performable m)) => Event t a -> m () +displayRedrawTime e = do + et1 <- performEvent $ liftIO getCurrentTime <$ e + et1' <- delay 0 et1 + diff <- performEvent $ ffor et1' $ \t1 -> do + t2 <- liftIO getCurrentTime + return $ t2 `diffUTCTime` t1 + text "Time: " + dynText =<< holdDyn "not yet run" (T.pack . show <$> diff) + +simpleSortableList :: forall t m k v. (MonadHold t m, MonadFix m, Adjustable t m, Ord k) => (k -> v -> m ()) -> Map k v -> Event t (v -> v -> Ordering) -> Event t (v -> v -> Ordering) -> m () +simpleSortableList f m0 resortFunc resortSlowFunc = do + rec let resortPatchFast = attachWith (flip patchThatSortsMapWith) (currentIncremental m) resortFunc + redrawPatch :: Map k v -> (v -> v -> Ordering) -> PatchMapWithMove k v + redrawPatch d cmp = patchMapWithMoveInsertAll $ Map.fromList $ zip (Map.keys d) (sortBy cmp $ Map.elems d) + resortPatchSlow = attachWith redrawPatch (currentIncremental m) resortSlowFunc + resortPatch = leftmost + [ resortPatchFast + , resortPatchSlow + ] + m <- holdIncremental m0 resortPatch + _ <- mapMapWithAdjustWithMove f m0 resortPatch + return () diff --git a/java/org/reflexfrp/reflexdom/MainWidget.java b/java/org/reflexfrp/reflexdom/MainWidget.java new file mode 100644 --- /dev/null +++ b/java/org/reflexfrp/reflexdom/MainWidget.java @@ -0,0 +1,204 @@ +package org.reflexfrp.reflexdom; + +import android.annotation.TargetApi; +import android.net.Uri; +import android.os.Build; +import android.os.Handler; +import android.util.Log; +import android.view.ViewGroup.LayoutParams; +import android.view.Window; +import android.webkit.CookieManager; +import android.webkit.GeolocationPermissions; +import android.webkit.JavascriptInterface; +import android.webkit.MimeTypeMap; +import android.webkit.PermissionRequest; +import android.webkit.WebChromeClient; +import android.webkit.WebResourceRequest; +import android.webkit.WebResourceResponse; +import android.webkit.WebSettings; +import android.webkit.WebView; +import android.webkit.WebViewClient; +import android.graphics.Bitmap; +import java.io.IOException; +import java.io.InputStream; +import android.content.Intent; +import android.content.ActivityNotFoundException; +import java.util.concurrent.atomic.AtomicBoolean; + +import java.nio.charset.StandardCharsets; + +import systems.obsidian.HaskellActivity; + +public class MainWidget { + private static Object startMainWidget(final HaskellActivity a, String url, long jsaddleCallbacks, final String initialJS) { + CookieManager.setAcceptFileSchemeCookies(true); //TODO: Can we do this just for our own WebView? + + // Remove title and notification bars + a.requestWindowFeature(Window.FEATURE_NO_TITLE); + + final WebView wv = new WebView(a); + wv.setLayoutParams(new LayoutParams(LayoutParams.MATCH_PARENT, LayoutParams.MATCH_PARENT)); + a.setContentView(wv); + final WebSettings ws = wv.getSettings(); + ws.setJavaScriptEnabled(true); + ws.setDomStorageEnabled(true); + wv.setWebContentsDebuggingEnabled(true); + // allow video to play without user interaction + wv.getSettings().setMediaPlaybackRequiresUserGesture(false); + final AtomicBoolean jsaddleLoaded = new AtomicBoolean(false); + + wv.setWebViewClient(new WebViewClient() { + @Override + public void onPageFinished(WebView _view, String _url) { + Log.i("reflex", "onPageFinished"); + boolean alreadyLoaded = jsaddleLoaded.getAndSet(true); + if(!alreadyLoaded) { + Log.i("reflex", "loading jsaddle"); + wv.evaluateJavascript(initialJS, null); + } + } + + // Re-route / to /android_asset + @Override + public WebResourceResponse shouldInterceptRequest (WebView view, WebResourceRequest request) { + Uri uri = request.getUrl(); + Log.i("reflex", uri.toString()); + if(!uri.getScheme().equals("file") && !uri.getEncodedAuthority().equals("appassets.androidplatform.net")) + return null; + + String path = uri.getPath(); + path = getAssetPath(path); + + String mimeType = getMimeType(uri.toString()); + String encoding = ""; + + try { + InputStream data = a.getApplicationContext().getAssets().open(path); + return new WebResourceResponse(mimeType, encoding, data); + } + catch (IOException e) { + Log.i("reflex", "Opening resource failed, Webview will handle the request .."); + e.printStackTrace(); + } + + return null; + } + + @Override + public boolean shouldOverrideUrlLoading(WebView view, String url) { + if( url != null && !url.startsWith("http://appassets.androidplatform.net") && !url.startsWith("https://appassets.androidplatform.net") && !url.startsWith("file://")) { + try { + view.getContext().startActivity(new Intent(Intent.ACTION_VIEW, Uri.parse(url))); + } + catch(ActivityNotFoundException e) { + Log.e("reflex", "Starting activity for intent '" + url + "' failed!"); + } + return true; + } else { + return false; + } + } + }); + + wv.setWebChromeClient(new WebChromeClient() { + // Need to accept permissions to use the camera and audio + @Override + public void onPermissionRequest(final PermissionRequest request) { + if(request.getOrigin().toString().startsWith("file://")) { + a.requestWebViewPermissions(request); + } + else { + a.runOnUiThread(new Runnable() { + @TargetApi(Build.VERSION_CODES.LOLLIPOP) + @Override + public void run() { + request.deny(); + } + }); + } + } + + @Override + public Bitmap getDefaultVideoPoster() { + return Bitmap.createBitmap(10, 10, Bitmap.Config.ARGB_8888); + } + + @Override + public void onGeolocationPermissionsShowPrompt(String origin, GeolocationPermissions.Callback callback) { + callback.invoke(origin, true, false); + } + }); + + wv.addJavascriptInterface(new JSaddleCallbacks(jsaddleCallbacks), "jsaddle"); + + wv.loadUrl(url); + + final Handler hnd = new Handler(); + return new Object() { + public final void evaluateJavascript(final byte[] js) { + final String jsStr = new String(js, StandardCharsets.UTF_8); + hnd.post(new Runnable() { + @Override + public void run() { + wv.evaluateJavascript(jsStr, null); + } + }); + } + public final void goBack() { + hnd.post(new Runnable() { + @Override + public void run() { + if(wv.canGoBack()) { + wv.goBack(); + } + } + }); + } + }; + } + + private static String getMimeType(String url) { + String type = ""; + String extension = MimeTypeMap.getFileExtensionFromUrl(url); + if (extension != null) { + type = MimeTypeMap.getSingleton().getMimeTypeFromExtension(extension); + } + return type; + } + + /** Get the path of an asset. Strips leading / and leading /android_asset/ */ + private static String getAssetPath(String path) { + path = path.startsWith("/android_asset") ? path.substring("/android_asset".length()) : path; + path = path.startsWith("/") ? path.substring(1) : path; + return path; + } + + private static class JSaddleCallbacks { + private final long callbacks; + private native void startProcessing(long callbacks); + private native void processMessage(long callbacks, byte[] msg); + private native byte[] processSyncMessage(long callbacks, byte[] msg); + + public JSaddleCallbacks(long _callbacks) { + callbacks = _callbacks; + } + + @JavascriptInterface + public boolean postReady() { + startProcessing(callbacks); + return true; + } + + @JavascriptInterface + public boolean postMessage(final String msg) { + processMessage(callbacks, msg.getBytes(StandardCharsets.UTF_8)); + return true; + } + + @JavascriptInterface + public String syncMessage(final String msg) { + return new String(processSyncMessage(callbacks, msg.getBytes(StandardCharsets.UTF_8)), + StandardCharsets.UTF_8); + } + } +} diff --git a/reflex-dom.cabal b/reflex-dom.cabal --- a/reflex-dom.cabal +++ b/reflex-dom.cabal @@ -1,7 +1,20 @@ +cabal-version: 1.24 Name: reflex-dom -Version: 0.3 +Version: 0.6.3.4 Synopsis: Functional Reactive Web Apps with Reflex -Description: Reflex-DOM is a Functional Reactive web framework based on the Reflex FRP engine +Description: + Web applications without callbacks or side-effects. + Reflex-DOM brings the power of functional reactive programming (FRP) to the web. + Build HTML and other Document Object Model (DOM) data with a pure functional interface. + . + Reflex-DOM is a Functional Reactive web framework based on the Reflex FRP engine: . + . + 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: . License: BSD3 License-file: LICENSE Author: Ryan Trinkle @@ -9,81 +22,188 @@ 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/Reflex/Dom/Internal/Foreign.hs - src-ghc/Reflex/Dom/Xhr/Foreign.hs - src-ghc/Reflex/Dom/WebSocket/Foreign.hs - src-ghcjs/Reflex/Dom/Internal/Foreign.hs - src-ghcjs/Reflex/Dom/Xhr/Foreign.hs - src-ghcjs/Reflex/Dom/WebSocket/Foreign.hs - src/Reflex/Dom/Xhr/ResponseType.hs - src/Reflex/Dom/Xhr/Exception.hs +extra-source-files: + java/org/reflexfrp/reflexdom/MainWidget.java + ChangeLog.md +flag use-warp + description: Use jsaddle-warp server + default: False + manual: True + +flag webkit2gtk + description: Use WebKit2 version of WebKitGTK. + default: True + +flag use-reflex-optimizer + description: Use the GHC plugin Reflex.Optimizer on some of the modules in the package. This is still experimental. + default: False + manual: True + +flag expose-all-unfoldings + description: Build the library with -fexpose-all-unfoldings which can help client code specialize better + default: False + manual: True + +flag build-examples + description: Build the executables in ./examples + default: False + manual: True + library hs-source-dirs: src - build-depends: - base >= 4.7 && < 4.9, - reflex == 0.4.*, - dependent-sum == 0.3.*, - dependent-map == 0.2.*, - semigroups >= 0.16 && < 0.19, - mtl >= 2.1 && < 2.3, - containers == 0.5.*, - these >= 0.4 && < 0.7, - ref-tf == 0.4.*, - ghcjs-dom >= 0.2.1 && < 0.3, - transformers == 0.3.* || == 0.4.*, - lens >= 4.7 && < 4.14, - safe == 0.3.*, - text == 1.2.*, - bytestring == 0.10.*, - data-default == 0.5.*, - aeson >= 0.8 && < 0.11, - time == 1.4.* || == 1.5.*, - exception-transformers == 0.4.*, - directory == 1.2.*, - dependent-sum-template >= 0.0.0.4 && < 0.1, - bifunctors >= 4.2 && < 6 - - if impl(ghcjs) - hs-source-dirs: src-ghcjs - build-depends: - ghcjs-base - else - hs-source-dirs: src-ghc + if os(android) + hs-source-dirs: src-android + other-modules: Reflex.Dom.Android.MainWidget build-depends: - glib == 0.13.*, - gtk3 >= 0.13.0 && < 0.15, - webkitgtk3 == 0.14.*, - webkitgtk3-javascriptcore == 0.13.*, - raw-strings-qq - if !os(windows) - build-depends: unix == 2.7.* + aeson >= 1.4 && < 2.3, + android-activity == 0.2.*, + data-default >= 0.7 && < 0.9, + 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.22, + bytestring >= 0.10 && < 0.13, + reflex >= 0.8 && < 1, + reflex-dom-core >= 0.8.1.0 && <0.9, + text >= 1.2 && < 2.2 + if !impl(ghcjs) + if flag(use-warp) + build-depends: + 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 && < 0.9, + jsaddle >= 0.9.6 && < 0.10, + jsaddle-wkwebview >= 0.9.6 && < 0.10 + else + if arch(wasm32) + build-depends: + jsaddle >= 0.9.6 && < 0.10, + jsaddle-wasm >= 0.1 && < 0.2 + else + if flag(webkit2gtk) && !os(android) + build-depends: + jsaddle-webkit2gtk >= 0.9.6 && < 0.10 exposed-modules: Reflex.Dom - Reflex.Dom.Class Reflex.Dom.Internal - Reflex.Dom.Time - Reflex.Dom.WebSocket - Reflex.Dom.Widget - Reflex.Dom.Widget.Basic - Reflex.Dom.Widget.Input - Reflex.Dom.Widget.Lazy - Reflex.Dom.Widget.Resize - Reflex.Dom.Xhr - Reflex.Dom.Location - other-modules: - Reflex.Dom.Internal.Foreign - Reflex.Dom.WebSocket.Foreign - Reflex.Dom.Xhr.Foreign - Reflex.Dom.Xhr.ResponseType - Reflex.Dom.Xhr.Exception + Reflex.Dom.Location.Platform + reexported-modules: + 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 + , Reflex.Dom.Class + , 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 -fPIC + cc-options: -fPIC + if flag(expose-all-unfoldings) + ghc-options: -fexpose-all-unfoldings + if flag(use-reflex-optimizer) + ghc-options: -fplugin=Reflex.Optimizer + default-language: Haskell2010 - other-extensions: TemplateHaskell - ghc-options: -Wall -fwarn-tabs -funbox-strict-fields -O2 -ferror-spans +executable sortableList + build-depends: base + , containers + , dependent-map + , lens + , mtl + , patch + , random + , reflex + , reflex-dom + , text + , time + , transformers + hs-source-dirs: examples + main-is: sortableList.hs + ghc-options: -Wall -fwarn-tabs -funbox-strict-fields -O2 -ferror-spans -fspecialise-aggressively + if !flag(build-examples) + buildable: False + if flag(expose-all-unfoldings) + ghc-options: -fexpose-all-unfoldings + if flag(use-reflex-optimizer) + ghc-options: -fplugin=Reflex.Optimizer + default-language: Haskell2010 + if arch(wasm32) + ghc-options: -no-hs-main -optl-mexec-model=reactor "-optl-Wl,--export=hs_start" +executable benchmark + 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 + if !impl(ghcjs) + buildable: False + default-language: Haskell2010 + +executable krausest + 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 + if impl(ghcjs) + ghcjs-options: -dedupe + cpp-options: -DGHCJS_BROWSER -DGHCJS_GC_INTERVAL=60000 + else + buildable: False + default-language: Haskell2010 + source-repository head type: git - location: https://github.com/ryantrinkle/reflex + location: https://github.com/reflex-frp/reflex-dom + subdir: reflex-dom diff --git a/src-android/Reflex/Dom/Android/MainWidget.hsc b/src-android/Reflex/Dom/Android/MainWidget.hsc new file mode 100644 --- /dev/null +++ b/src-android/Reflex/Dom/Android/MainWidget.hsc @@ -0,0 +1,135 @@ +{-# LANGUAGE ForeignFunctionInterface #-} +{-# LANGUAGE OverloadedStrings #-} +module Reflex.Dom.Android.MainWidget + ( startMainWidget + , goBack + , JSExecutor(..) + , withGlobalJSExecutor + ) where + +import Android.HaskellActivity +import Control.Concurrent +import Control.Monad +import Control.Monad.IO.Class +import Data.Aeson +import Data.ByteString (ByteString) +import qualified Data.ByteString as BS +import qualified Data.ByteString.Lazy as LBS +import qualified Data.ByteString.Unsafe as BSU +import Data.IORef +import Data.Monoid +import Foreign.C.String +import Foreign.C.Types +import Foreign.Marshal.Utils +import Foreign.Marshal.Array +import Foreign.Ptr +import Foreign.Storable +import Language.Javascript.JSaddle (JSM) +import Language.Javascript.JSaddle.Run (runJavaScript) +import Language.Javascript.JSaddle.Run.Files (initState, runBatch, ghcjsHelpers) +import System.IO.Unsafe + +#include "MainWidget.h" + +startMainWidget :: HaskellActivity -> ByteString -> JSM () -> IO () +startMainWidget a url jsm = do + --TODO: Find a way to eventually release this + executorRef <- newIORef $ error "startMainWidget: executor not created yet" + let go batch = do + executor <- readIORef executorRef + BSU.unsafeUseAsCStringLen (LBS.toStrict $ "runJSaddleBatch(" <> encode batch <> ");") $ \(cstr, len) -> do + runJS executor cstr (fromIntegral len) + (processResult, processSyncResult, start) <- runJavaScript go jsm + callbacks <- new <=< jsaddleCallbacksToPtrs $ JSaddleCallbacks + { _jsaddleCallbacks_jsaddleStart = void $ forkIO start + , _jsaddleCallbacks_jsaddleResult = \s -> do + case decode $ LBS.fromStrict s of + Nothing -> error $ "jsaddle message decode failed: " <> show s + Just r -> processResult r + , _jsaddleCallbacks_jsaddleSyncResult = \s -> do + case decode $ LBS.fromStrict s of + Nothing -> error $ "jsaddle message decode failed: " <> show s + Just r -> LBS.toStrict . encode <$> processSyncResult r + , _jsaddleCallbacks_jsaddleJsData = LBS.toStrict $ ghcjsHelpers <> "\ + \runJSaddleBatch = (function() {\n\ + \ " <> initState <> "\n\ + \ return function(batch) {\n\ + \ " <> runBatch (\a -> "jsaddle.postMessage(JSON.stringify(" <> a <> "));") + (Just (\a -> "JSON.parse(jsaddle.syncMessage(JSON.stringify(" <> a <> ")))")) <> "\ + \ };\n\ + \})();\n\ + \jsaddle.postReady();\n" + } + BS.useAsCString url $ \curl -> do + executor <- startMainWidget_ a curl callbacks + writeIORef executorRef executor + writeIORef globalJSExecutor $ Just executor + +newtype JSExecutor = JSExecutor { unJSExecutor :: Ptr JSExecutor } + +-- Ugh. But not doing this is also unfortunate for being able to clear the history so that the "back" list is good. +globalJSExecutor :: IORef (Maybe JSExecutor) +globalJSExecutor = unsafePerformIO $ newIORef Nothing + +withGlobalJSExecutor :: MonadIO m => (JSExecutor -> IO ()) -> m () +withGlobalJSExecutor f = liftIO $ do + executor <- readIORef globalJSExecutor + case executor of + Just e -> f e + _ -> pure () + +foreign import ccall safe "Reflex_Dom_Android_MainWidget_start" startMainWidget_ :: HaskellActivity -> CString -> Ptr JSaddleCallbacksPtrs -> IO JSExecutor + +foreign import ccall safe "Reflex_Dom_Android_MainWidget_runJS" runJS :: JSExecutor -> CString -> CSize -> IO () +foreign import ccall safe "Reflex_Dom_Android_MainWidget_back" goBack :: JSExecutor -> IO () + +data JSaddleCallbacks = JSaddleCallbacks + { _jsaddleCallbacks_jsaddleStart :: IO () + , _jsaddleCallbacks_jsaddleResult :: ByteString -> IO () + , _jsaddleCallbacks_jsaddleSyncResult :: ByteString -> IO ByteString + , _jsaddleCallbacks_jsaddleJsData :: ByteString + } + +data JSaddleCallbacksPtrs = JSaddleCallbacksPtrs + { _jsaddleCallbacksPtrs_jsaddleStart :: !(FunPtr (IO ())) + , _jsaddleCallbacksPtrs_jsaddleResult :: !(FunPtr (CString -> CSize -> IO ())) + , _jsaddleCallbacksPtrs_jsaddleSyncResult :: !(FunPtr (CString -> CSize -> Ptr CString -> Ptr CSize -> IO ())) + , _jsaddleCallbacksPtrs_jsaddleJsData :: !CString + } + +foreign import ccall "wrapper" wrapIO :: IO () -> IO (FunPtr (IO ())) +foreign import ccall "wrapper" wrapCStringCSizeIO :: (CString -> CSize -> IO ()) -> IO (FunPtr (CString -> CSize -> IO ())) +foreign import ccall "wrapper" wrapCStringCSizeCStringCSizeIO :: (CString -> CSize -> Ptr CString -> Ptr CSize -> IO ()) -> IO (FunPtr (CString -> CSize -> Ptr CString -> Ptr CSize -> IO ())) + +newCStringFromByteString :: ByteString -> IO (CString, CSize) +newCStringFromByteString bs = BSU.unsafeUseAsCStringLen bs $ \(src, len) -> do + dest <- mallocArray0 len + copyArray dest src len + poke (advancePtr dest len) 0 + return (dest, fromIntegral len) + +jsaddleCallbacksToPtrs :: JSaddleCallbacks -> IO JSaddleCallbacksPtrs +jsaddleCallbacksToPtrs jc = JSaddleCallbacksPtrs + <$> wrapIO (_jsaddleCallbacks_jsaddleStart jc) + <*> wrapCStringCSizeIO (\cstr len -> _jsaddleCallbacks_jsaddleResult jc =<< BS.packCStringLen (cstr, fromIntegral len)) + <*> wrapCStringCSizeCStringCSizeIO (\cstr len result resultLen -> do + inStr <- BS.packCStringLen (cstr, fromIntegral len) + outStr <- _jsaddleCallbacks_jsaddleSyncResult jc inStr + (outStrBytes, outStrLen) <- newCStringFromByteString outStr + poke result outStrBytes + poke resultLen outStrLen) + <*> (fst <$> newCStringFromByteString (_jsaddleCallbacks_jsaddleJsData jc)) + +instance Storable JSaddleCallbacksPtrs where + sizeOf _ = #{size JSaddleCallbacks} + alignment _ = #{alignment JSaddleCallbacks} + poke p jc = do + #{poke JSaddleCallbacks, jsaddleStart} p $ _jsaddleCallbacksPtrs_jsaddleStart jc + #{poke JSaddleCallbacks, jsaddleResult} p $ _jsaddleCallbacksPtrs_jsaddleResult jc + #{poke JSaddleCallbacks, jsaddleSyncResult} p $ _jsaddleCallbacksPtrs_jsaddleSyncResult jc + #{poke JSaddleCallbacks, jsaddleJsData} p $ _jsaddleCallbacksPtrs_jsaddleJsData jc + peek p = JSaddleCallbacksPtrs + <$> #{peek JSaddleCallbacks, jsaddleStart} p + <*> #{peek JSaddleCallbacks, jsaddleResult} p + <*> #{peek JSaddleCallbacks, jsaddleSyncResult} p + <*> #{peek JSaddleCallbacks, jsaddleJsData} p diff --git a/src-ghc/Reflex/Dom/Internal/Foreign.hs b/src-ghc/Reflex/Dom/Internal/Foreign.hs deleted file mode 100644 --- a/src-ghc/Reflex/Dom/Internal/Foreign.hs +++ /dev/null @@ -1,163 +0,0 @@ -{-# LANGUAGE CPP, ForeignFunctionInterface, ScopedTypeVariables, LambdaCase #-} -module Reflex.Dom.Internal.Foreign where - -import Control.Concurrent -import Control.Exception (bracket) -import Control.Lens hiding (set) -import Control.Monad -import Control.Monad.State.Strict hiding (mapM, mapM_, forM, forM_, sequence, sequence_, get) -import Data.ByteString (ByteString) -import Data.List -import Foreign.Marshal hiding (void) -import Foreign.Ptr -import GHCJS.DOM hiding (runWebGUI) -import GHCJS.DOM.Navigator -import GHCJS.DOM.Window -import Graphics.UI.Gtk hiding (Widget) -import Graphics.UI.Gtk.WebKit.JavaScriptCore.JSBase -import Graphics.UI.Gtk.WebKit.JavaScriptCore.JSObjectRef -import Graphics.UI.Gtk.WebKit.JavaScriptCore.JSStringRef -import Graphics.UI.Gtk.WebKit.JavaScriptCore.JSValueRef -import Graphics.UI.Gtk.WebKit.JavaScriptCore.WebFrame -import Graphics.UI.Gtk.WebKit.Types hiding (Event, Widget) -import Graphics.UI.Gtk.WebKit.WebFrame -import Graphics.UI.Gtk.WebKit.WebInspector -import Graphics.UI.Gtk.WebKit.WebSettings -import Graphics.UI.Gtk.WebKit.WebView -import System.Directory -import System.Glib.FFI hiding (void) -import qualified Data.ByteString as BS - -#ifndef mingw32_HOST_OS -import System.Posix.Signals -#endif - -quitWebView :: WebView -> IO () -quitWebView wv = postGUIAsync $ do w <- widgetGetToplevel wv - widgetDestroy w - -installQuitHandler :: WebView -> IO () -#ifdef mingw32_HOST_OS -installQuitHandler wv = return () -- TODO: Maybe figure something out here for Windows users. -#else -installQuitHandler wv = installHandler keyboardSignal (Catch (quitWebView wv)) Nothing >> return () -#endif - -makeDefaultWebView :: String -> (WebView -> IO ()) -> IO () -makeDefaultWebView userAgentKey main = do - _ <- initGUI - window <- windowNew - _ <- timeoutAddFull (yield >> return True) priorityHigh 10 - windowSetDefaultSize window 900 600 - windowSetPosition window WinPosCenter - scrollWin <- scrolledWindowNew Nothing Nothing - webView <- webViewNew - settings <- webViewGetWebSettings webView - userAgent <- settings `get` webSettingsUserAgent - settings `set` [ webSettingsUserAgent := userAgent ++ " " ++ userAgentKey - , webSettingsEnableUniversalAccessFromFileUris := True - , webSettingsEnableDeveloperExtras := True - ] - webViewSetWebSettings webView settings - window `containerAdd` scrollWin - scrollWin `containerAdd` webView - _ <- on window objectDestroy . liftIO $ mainQuit - widgetShowAll window - _ <- webView `on` loadFinished $ \_ -> do - main webView --TODO: Should probably only do this once - inspector <- webViewGetInspector webView - _ <- inspector `on` inspectWebView $ \_ -> do - inspectorWindow <- windowNew - windowSetDefaultSize inspectorWindow 900 600 - inspectorScrollWin <- scrolledWindowNew Nothing Nothing - inspectorWebView <- webViewNew - inspectorWindow `containerAdd` inspectorScrollWin - inspectorScrollWin `containerAdd` inspectorWebView - widgetShowAll inspectorWindow - return inspectorWebView - wf <- webViewGetMainFrame webView - pwd <- getCurrentDirectory - webFrameLoadString wf "" Nothing $ "file://" ++ pwd ++ "/" - installQuitHandler webView - mainGUI - -runWebGUI :: (WebView -> IO ()) -> IO () -runWebGUI = runWebGUI' "GHCJS" - -runWebGUI' :: String -> (WebView -> IO ()) -> IO () -runWebGUI' userAgentKey main = do - -- Are we in a java script inside some kind of browser - mbWindow <- currentWindow - case mbWindow of - Just window -> do - -- Check if we are running in javascript inside the the native version - Just n <- getNavigator window - agent <- getUserAgent n - unless ((" " ++ userAgentKey) `isSuffixOf` agent) $ main (castToWebView window) - Nothing -> do - makeDefaultWebView userAgentKey main - -foreign import ccall "wrapper" - wrapper :: JSObjectCallAsFunctionCallback' -> IO JSObjectCallAsFunctionCallback - -toJSObject :: JSContextRef -> [Ptr OpaqueJSValue] -> IO JSObjectRef -toJSObject ctx args = do - o <- jsobjectmake ctx nullPtr nullPtr - iforM_ args $ \n a -> do - prop <- jsstringcreatewithutf8cstring $ show n - jsobjectsetproperty ctx o prop a 1 nullPtr - return o - -fromJSStringMaybe :: JSContextRef -> JSValueRef -> IO (Maybe String) -fromJSStringMaybe c t = do - isNull <- jsvalueisnull c t - case isNull of - True -> return Nothing - False -> do - j <- jsvaluetostringcopy c t nullPtr - l <- jsstringgetmaximumutf8cstringsize j - s <- allocaBytes (fromIntegral l) $ \ps -> do - _ <- jsstringgetutf8cstring'_ j ps (fromIntegral l) - peekCString ps - return $ Just s - -getLocationHost :: WebView -> IO String -getLocationHost wv = withWebViewContext wv $ \c -> do - script <- jsstringcreatewithutf8cstring "location.host" - lh <- jsevaluatescript c script nullPtr nullPtr 1 nullPtr - lh' <- fromJSStringMaybe c lh - return $ maybe "" id lh' - -getLocationProtocol :: WebView -> IO String -getLocationProtocol wv = withWebViewContext wv $ \c -> do - script <- jsstringcreatewithutf8cstring "location.protocol" - lp <- jsevaluatescript c script nullPtr nullPtr 1 nullPtr - lp' <- fromJSStringMaybe c lp - return $ maybe "" id lp' - -bsToArrayBuffer :: JSContextRef -> ByteString -> IO JSValueRef -bsToArrayBuffer c bs = do - elems <- forM (BS.unpack bs) $ \x -> jsvaluemakenumber c $ fromIntegral x - let numElems = length elems - bracket (mallocArray numElems) free $ \elemsArr -> do - pokeArray elemsArr elems - a <- jsobjectmakearray c (fromIntegral numElems) elemsArr nullPtr - newUint8Array <- jsstringcreatewithutf8cstring "new Uint8Array(this)" - jsevaluatescript c newUint8Array a nullPtr 1 nullPtr - -bsFromArrayBuffer :: JSContextRef -> JSValueRef -> IO ByteString -bsFromArrayBuffer c a = do - let getIntegral = fmap round . (\x -> jsvaluetonumber c x nullPtr) - getByteLength <- jsstringcreatewithutf8cstring "this.byteLength" - byteLength <- getIntegral =<< jsevaluatescript c getByteLength a nullPtr 1 nullPtr - toUint8Array <- jsstringcreatewithutf8cstring "new Uint8Array(this)" - uint8Array <- jsevaluatescript c toUint8Array a nullPtr 1 nullPtr - getIx <- jsstringcreatewithutf8cstring "this[0][this[1]]" - let arrayLookup i = do - i' <- jsvaluemakenumber c (fromIntegral i) - args <- toJSObject c [uint8Array, i'] - getIntegral =<< jsevaluatescript c getIx args nullPtr 1 nullPtr - fmap BS.pack $ forM [0..byteLength-1] arrayLookup - -withWebViewContext :: WebView -> (JSContextRef -> IO a) -> IO a -withWebViewContext wv f = f =<< webFrameGetGlobalContext =<< webViewGetMainFrame wv diff --git a/src-ghc/Reflex/Dom/WebSocket/Foreign.hs b/src-ghc/Reflex/Dom/WebSocket/Foreign.hs deleted file mode 100644 --- a/src-ghc/Reflex/Dom/WebSocket/Foreign.hs +++ /dev/null @@ -1,70 +0,0 @@ -{-# LANGUAGE ForeignFunctionInterface, JavaScriptFFI, CPP, TemplateHaskell, NoMonomorphismRestriction, EmptyDataDecls, RankNTypes, GADTs, RecursiveDo, ScopedTypeVariables, FlexibleInstances, MultiParamTypeClasses, TypeFamilies, FlexibleContexts, DeriveDataTypeable, GeneralizedNewtypeDeriving, StandaloneDeriving, ConstraintKinds, UndecidableInstances, PolyKinds, AllowAmbiguousTypes #-} - -module Reflex.Dom.WebSocket.Foreign where - -import Prelude hiding (div, span, mapM, mapM_, concat, concatMap, all, sequence) - -import Control.Exception -import Control.Monad.State -import Data.ByteString (ByteString) -import Data.Text.Encoding -import Foreign.Marshal hiding (void) -import Foreign.Ptr -import Foreign.Storable -import Graphics.UI.Gtk.WebKit.JavaScriptCore.JSBase -import Graphics.UI.Gtk.WebKit.JavaScriptCore.JSObjectRef -import Graphics.UI.Gtk.WebKit.JavaScriptCore.JSStringRef -import Graphics.UI.Gtk.WebKit.JavaScriptCore.JSValueRef -import Graphics.UI.Gtk.WebKit.WebView -import qualified Data.ByteString as BS -import qualified Data.Text as T - -import Reflex.Dom.Internal.Foreign - -data JSWebSocket = JSWebSocket { wsValue :: JSValueRef - , wsContext :: JSContextRef - } - -newWebSocket :: WebView -> String -> (ByteString -> IO ()) -> IO () -> IO () -> IO JSWebSocket -newWebSocket wv url onMessage onOpen onClose = withWebViewContext wv $ \c -> do - url' <- jsvaluemakestring c =<< jsstringcreatewithutf8cstring url - newWSArgs <- toJSObject c [url'] - newWS <- jsstringcreatewithutf8cstring "(function(that) { var ws = new WebSocket(that[0]); ws['binaryType'] = 'arraybuffer'; return ws; })(this)" - ws <- jsevaluatescript c newWS newWSArgs nullPtr 1 nullPtr - onMessage' <- wrapper $ \_ _ _ _ args _ -> do - e <- peekElemOff args 0 - dataProp <- jsstringcreatewithutf8cstring "data" - msg <- jsobjectgetproperty c e dataProp nullPtr - msg' <- fromJSStringMaybe c msg - case msg' of - Nothing -> return () - Just m -> onMessage $ encodeUtf8 $ T.pack m - jsvaluemakeundefined c - onMessageCb <- jsobjectmakefunctionwithcallback c nullPtr onMessage' - onOpen' <- wrapper $ \_ _ _ _ _ _ -> do - onOpen - jsvaluemakeundefined c - onOpenCb <- jsobjectmakefunctionwithcallback c nullPtr onOpen' - onClose' <- wrapper $ \_ _ _ _ _ _ -> do - onClose - jsvaluemakeundefined c - onCloseCb <- jsobjectmakefunctionwithcallback c nullPtr onClose' - o <- toJSObject c [ws, onMessageCb, onOpenCb, onCloseCb] - addCbs <- jsstringcreatewithutf8cstring "this[0]['onmessage'] = this[1]; this[0]['onopen'] = this[2]; this[0]['onclose'] = this[3];" - _ <- jsevaluatescript c addCbs o nullPtr 1 nullPtr - return $ JSWebSocket ws c - -webSocketSend :: JSWebSocket -> ByteString -> IO () -webSocketSend (JSWebSocket ws c) bs = do - elems <- forM (BS.unpack bs) $ \x -> jsvaluemakenumber c $ fromIntegral x - let numElems = length elems - bs' <- bracket (mallocArray numElems) free $ \elemsArr -> do - pokeArray elemsArr elems - a <- jsobjectmakearray c (fromIntegral numElems) elemsArr nullPtr - newUint8Array <- jsstringcreatewithutf8cstring "new Uint8Array(this)" - jsevaluatescript c newUint8Array a nullPtr 1 nullPtr - send <- jsstringcreatewithutf8cstring "this[0]['send'](String['fromCharCode']['apply'](null, this[1]))" - sendArgs <- toJSObject c [ws, bs'] - _ <- jsevaluatescript c send sendArgs nullPtr 1 nullPtr - return () - diff --git a/src-ghc/Reflex/Dom/Xhr/Foreign.hs b/src-ghc/Reflex/Dom/Xhr/Foreign.hs deleted file mode 100644 --- a/src-ghc/Reflex/Dom/Xhr/Foreign.hs +++ /dev/null @@ -1,206 +0,0 @@ -{-# LANGUAGE QuasiQuotes, ForeignFunctionInterface #-} - -module Reflex.Dom.Xhr.Foreign where - -import Control.Monad -import qualified Data.Text as T -import Data.Text (Text) -import System.Glib.FFI -import Graphics.UI.Gtk.WebKit.WebView -import Graphics.UI.Gtk.WebKit.JavaScriptCore.JSBase -import Graphics.UI.Gtk.WebKit.JavaScriptCore.JSObjectRef -import Graphics.UI.Gtk.WebKit.JavaScriptCore.JSStringRef -import Graphics.UI.Gtk.WebKit.JavaScriptCore.JSValueRef -import Reflex.Dom.Xhr.ResponseType -import Reflex.Dom.Xhr.Exception -import Control.Concurrent.MVar -import Control.Exception.Base -import Graphics.UI.Gtk.WebKit.Types hiding (Text) - -import Reflex.Dom.Internal.Foreign - -import Text.RawString.QQ - -data XMLHttpRequest - = XMLHttpRequest { xhrValue :: JSValueRef - , xhrContext :: JSContextRef - } - deriving (Eq, Ord) - -stringToJSValue :: JSContextRef -> String -> IO JSValueRef -stringToJSValue ctx s = jsvaluemakestring ctx =<< jsstringcreatewithutf8cstring s - -fromResponseType :: XhrResponseType -> String -fromResponseType XhrResponseType_Default = "" -fromResponseType XhrResponseType_ArrayBuffer = "arraybuffer" -fromResponseType XhrResponseType_Blob = "blob" -fromResponseType XhrResponseType_Text = "text" - -toResponseType :: String -> Maybe XhrResponseType -toResponseType "" = Just XhrResponseType_Default -toResponseType "arraybuffer" = Just XhrResponseType_ArrayBuffer -toResponseType "blob" = Just XhrResponseType_Blob -toResponseType "text" = Just XhrResponseType_Text -toResponseType _ = Nothing - -xmlHttpRequestNew :: WebView -> IO XMLHttpRequest -xmlHttpRequestNew wv = withWebViewContext wv $ \jsContext -> do - xhrScript <- jsstringcreatewithutf8cstring "new XMLHttpRequest()" - xhr' <- jsevaluatescript jsContext xhrScript nullPtr nullPtr 1 nullPtr - jsvalueprotect jsContext xhr' - return $ XMLHttpRequest xhr' jsContext - -xmlHttpRequestOpen :: XMLHttpRequest -> String -> String -> Bool -> String -> String -> IO () -xmlHttpRequestOpen xhr method url async user password = do - let c = xhrContext xhr - method' <- stringToJSValue c method - url' <- stringToJSValue c url - async' <- jsvaluemakeboolean (xhrContext xhr) async - user' <- stringToJSValue c user - password' <- stringToJSValue c password - o <- toJSObject c [xhrValue xhr, method', url', async', user', password'] - script <- jsstringcreatewithutf8cstring "this[0].open(this[1], this[2], this[3], this[4], this[5])" - _ <- jsevaluatescript c script o nullPtr 1 nullPtr - return () - -xmlHttpRequestOnreadystatechange :: XMLHttpRequest -> IO () -> IO () -xmlHttpRequestOnreadystatechange xhr userCallback = do - let c = xhrContext xhr - fp <- wrapper $ \_ _ _ _ _ _ -> do - userCallback - jsvaluemakeundefined c - cb <- jsobjectmakefunctionwithcallback c nullPtr fp - o <- toJSObject c [xhrValue xhr, cb] - script <- jsstringcreatewithutf8cstring "this[0].onreadystatechange=this[1]" - _ <- jsevaluatescript c script o nullPtr 1 nullPtr - return () - -xmlHttpRequestGetReadyState :: XMLHttpRequest -> IO Word -xmlHttpRequestGetReadyState xhr = do - let c = xhrContext xhr - script <- jsstringcreatewithutf8cstring "this.readyState" - rs <- jsevaluatescript c script (xhrValue xhr) nullPtr 1 nullPtr - d <- jsvaluetonumber c rs nullPtr - return $ truncate d - -xmlHttpRequestGetResponseType :: XMLHttpRequest -> IO (Maybe XhrResponseType) -xmlHttpRequestGetResponseType xhr = do - script <- jsstringcreatewithutf8cstring "this.responseType" - rt <- jsevaluatescript (xhrContext xhr) script (xhrValue xhr) nullPtr 1 nullPtr - ms <- fromJSStringMaybe (xhrContext xhr) rt - return $ join $ fmap toResponseType ms - -xmlHttpRequestGetResponse :: XMLHttpRequest -> IO (Maybe XhrResponseBody) -xmlHttpRequestGetResponse xhr = do - let c = xhrContext xhr - mrt <- xmlHttpRequestGetResponseType xhr - script <- jsstringcreatewithutf8cstring "this.response" - t <- jsevaluatescript c script (xhrValue xhr) nullPtr 1 nullPtr - isNull <- jsvalueisnull c t - case isNull of - True -> return Nothing - False -> case mrt of - Just XhrResponseType_ArrayBuffer -> Just . XhrResponseBody_ArrayBuffer <$> bsFromArrayBuffer c t - Just XhrResponseType_Blob -> Just . XhrResponseBody_Blob . Blob . castForeignPtr <$> newForeignPtr_ t - Just XhrResponseType_Default -> fmap (XhrResponseBody_Default . T.pack) <$> fromJSStringMaybe c t - Just XhrResponseType_Text -> fmap (XhrResponseBody_Text . T.pack) <$> fromJSStringMaybe c t - _ -> return Nothing - -xmlHttpRequestGetResponseText :: XMLHttpRequest -> IO (Maybe Text) -xmlHttpRequestGetResponseText xhr = do - let c = xhrContext xhr - script <- jsstringcreatewithutf8cstring "this.responseText" - t <- jsevaluatescript c script (xhrValue xhr) nullPtr 1 nullPtr - fmap (fmap T.pack) $ fromJSStringMaybe c t - -xmlHttpRequestSend :: XMLHttpRequest -> Maybe String -> IO () -xmlHttpRequestSend xhr payload = do - let c = xhrContext xhr - result <- newEmptyMVar - let wrapper' x = wrapper $ \_ _ _ _ _ _ -> putMVar result x >> jsvaluemakeundefined c - bracket (wrapper' $ Just XhrException_Aborted) freeHaskellFunPtr $ \a -> do - onAbort <- jsobjectmakefunctionwithcallback c nullPtr a - bracket (wrapper' $ Just XhrException_Error) freeHaskellFunPtr $ \e -> do - onError <- jsobjectmakefunctionwithcallback c nullPtr e - bracket (wrapper' Nothing) freeHaskellFunPtr $ \l -> do - onLoad <- jsobjectmakefunctionwithcallback c nullPtr l - (o,s) <- case payload of - Nothing -> do - d <- jsvaluemakeundefined c - o <- toJSObject c [xhrValue xhr, d, onError, onAbort, onLoad] - s <- jsstringcreatewithutf8cstring send - return (o,s) - Just payload' -> do - d <- stringToJSValue c payload' - o <- toJSObject c [xhrValue xhr, d, onError, onAbort, onLoad] - s <- jsstringcreatewithutf8cstring send - return (o,s) - _ <- jsevaluatescript c s o nullPtr 1 nullPtr - takeMVar result >>= mapM_ throwIO - where - send = [r| - (function (xhr, d, onError, onAbort, onLoad) { - var clear; - var error = function () { - clear(); onError(); - }; - var abort = function () { - clear(); onAbort(); - }; - var load = function () { - clear(); onLoad(); - }; - clear = function () { - xhr.removeEventListener('error', error); - xhr.removeEventListener('abort', abort); - xhr.removeEventListener('load', load); - } - xhr.addEventListener('error', error); - xhr.addEventListener('abort', abort); - xhr.addEventListener('load', load); - if(d) { - xhr.send(d); - } else { - xhr.send(); - } - })(this[0], this[1], this[2], this[3], this[4]) - |] - -xmlHttpRequestSetRequestHeader :: XMLHttpRequest -> String -> String -> IO () -xmlHttpRequestSetRequestHeader xhr header value = do - let c = xhrContext xhr - header' <- stringToJSValue c header - value' <- stringToJSValue c value - o <- toJSObject c [xhrValue xhr, header', value'] - script <- jsstringcreatewithutf8cstring "this[0].setRequestHeader(this[1], this[2])" - _ <- jsevaluatescript c script o nullPtr 1 nullPtr - return () - -xmlHttpRequestSetResponseType :: XMLHttpRequest -> String -> IO () -xmlHttpRequestSetResponseType xhr t = do - let c = xhrContext xhr - t' <- stringToJSValue c t - o <- toJSObject c [xhrValue xhr, t'] - script <- jsstringcreatewithutf8cstring "this[0].responseType = this[1]" - _ <- jsevaluatescript c script o nullPtr 1 nullPtr - return () - -xmlHttpRequestGetStatus :: XMLHttpRequest -> IO Word -xmlHttpRequestGetStatus xhr = do - let c = xhrContext xhr - script <- jsstringcreatewithutf8cstring "this.status" - s <- jsevaluatescript c script (xhrValue xhr) nullPtr 1 nullPtr - d <- jsvaluetonumber c s nullPtr - return $ truncate d - -xmlHttpRequestGetStatusText :: XMLHttpRequest -> IO Text -xmlHttpRequestGetStatusText xhr = do - let c = xhrContext xhr - script <- jsstringcreatewithutf8cstring "this.statusText" - t <- jsevaluatescript c script (xhrValue xhr) nullPtr 1 nullPtr - j <- jsvaluetostringcopy c t nullPtr - l <- jsstringgetmaximumutf8cstringsize j - s <- allocaBytes (fromIntegral l) $ \ps -> do - _ <- jsstringgetutf8cstring'_ j ps (fromIntegral l) - peekCString ps - return $ T.pack s diff --git a/src-ghcjs/Reflex/Dom/Internal/Foreign.hs b/src-ghcjs/Reflex/Dom/Internal/Foreign.hs deleted file mode 100644 --- a/src-ghcjs/Reflex/Dom/Internal/Foreign.hs +++ /dev/null @@ -1,43 +0,0 @@ -{-# LANGUAGE ForeignFunctionInterface, JavaScriptFFI #-} -module Reflex.Dom.Internal.Foreign ( module Reflex.Dom.Internal.Foreign - , runWebGUI - ) where - -import Control.Monad -import Data.ByteString (ByteString) -import Foreign -import Foreign.C -import GHCJS.DOM -import GHCJS.DOM.Types -import GHCJS.Types -import JavaScript.TypedArray.ArrayBuffer as JS -import qualified Data.ByteString as BS -import qualified GHCJS.Buffer as JS -import qualified GHCJS.Marshal.Pure as JS - -quitWebView :: WebView -> IO () -quitWebView = error "quitWebView: unimplemented in GHCJS" - -foreign import javascript unsafe "location['host']" getLocationHost_ :: IO JSString - -getLocationHost :: FromJSString r => a -> IO r -getLocationHost _ = liftM fromJSString getLocationHost_ - -foreign import javascript unsafe "location['protocol']" getLocationProtocol_ :: IO JSString - -getLocationProtocol :: FromJSString r => a -> IO r -getLocationProtocol _ = liftM fromJSString getLocationProtocol_ - -withWebViewContext :: a -> (a -> IO b) -> IO b -withWebViewContext a f = f a - -foreign import javascript safe "new DataView($3,$1,$2)" js_dataView :: Int -> Int -> JSVal -> JSVal - -foreign import javascript unsafe "new Uint8Array($1_1['buf'], $1_2, $2)['buffer']" extractByteArray :: Ptr CChar -> Int -> IO JSVal - -bsToArrayBuffer :: a -> ByteString -> IO JSVal -bsToArrayBuffer _ bs = BS.useAsCString bs $ \cStr -> do - extractByteArray cStr $ BS.length bs - -bsFromArrayBuffer :: a -> JSVal -> IO ByteString -bsFromArrayBuffer _ ab = liftM (JS.toByteString 0 Nothing . JS.createFromArrayBuffer) $ JS.unsafeFreeze $ JS.pFromJSVal ab diff --git a/src-ghcjs/Reflex/Dom/WebSocket/Foreign.hs b/src-ghcjs/Reflex/Dom/WebSocket/Foreign.hs deleted file mode 100644 --- a/src-ghcjs/Reflex/Dom/WebSocket/Foreign.hs +++ /dev/null @@ -1,44 +0,0 @@ -{-# LANGUAGE ForeignFunctionInterface, JavaScriptFFI, CPP #-} - -module Reflex.Dom.WebSocket.Foreign where - -import Prelude hiding (div, span, mapM, mapM_, concat, concatMap, all, sequence) - -import Data.ByteString (ByteString) -import qualified Data.ByteString as BS -import GHCJS.Types -import GHCJS.DOM.WebSocket (message, open, closeEvent) -import qualified GHCJS.DOM.WebSocket as GD -import GHCJS.DOM.MessageEvent -import GHCJS.DOM.EventM (on) -import GHCJS.DOM.Types -import Control.Monad.IO.Class -import Control.Monad.Reader -import GHCJS.Buffer -import JavaScript.TypedArray.ArrayBuffer as JS -import GHCJS.Marshal.Pure - -data JSWebSocket = JSWebSocket { unWebSocket :: WebSocket } - -newWebSocket :: a -> String -> (ByteString -> IO ()) -> IO () -> IO () -> IO JSWebSocket -newWebSocket _ url onMessage onOpen onClose = do - ws <- GD.newWebSocket url (Just [] :: Maybe [String]) - _ <- on ws open $ liftIO onOpen - GD.setBinaryType ws "arraybuffer" - _ <- on ws message $ do - e <- ask - d <- getData e - ab <- liftIO $ unsafeFreeze $ pFromJSVal d - liftIO $ onMessage $ toByteString 0 Nothing $ createFromArrayBuffer ab - _ <- on ws closeEvent $ liftIO onClose - return $ JSWebSocket ws - -webSocketSend :: JSWebSocket -> ByteString -> IO () -webSocketSend (JSWebSocket ws) bs = do - let (b, off, len) = fromByteString bs - ab <- ArrayBuffer <$> if BS.length bs == 0 --TODO: remove this logic when https://github.com/ghcjs/ghcjs-base/issues/49 is fixed - then jsval . getArrayBuffer <$> create 0 - else return $ js_dataView off len $ jsval $ getArrayBuffer b - GD.send ws $ Just ab - -foreign import javascript safe "new DataView($3,$1,$2)" js_dataView :: Int -> Int -> JSVal -> JSVal diff --git a/src-ghcjs/Reflex/Dom/Xhr/Foreign.hs b/src-ghcjs/Reflex/Dom/Xhr/Foreign.hs deleted file mode 100644 --- a/src-ghcjs/Reflex/Dom/Xhr/Foreign.hs +++ /dev/null @@ -1,151 +0,0 @@ -{-# LANGUAGE ForeignFunctionInterface, JavaScriptFFI, OverloadedStrings #-} - -module Reflex.Dom.Xhr.Foreign ( - XMLHttpRequest - , XMLHttpRequestResponseType(..) - , module Reflex.Dom.Xhr.Foreign -) where - -import Prelude hiding (error) -import Data.Text (Text) -import GHCJS.DOM.Types hiding (Text) -import GHCJS.DOM -import GHCJS.DOM.Enums -import GHCJS.DOM.XMLHttpRequest -import Data.Maybe (fromMaybe) -import GHCJS.DOM.EventTarget (dispatchEvent) -import GHCJS.DOM.EventM (EventM, on) -import Reflex.Dom.Internal.Foreign -import Reflex.Dom.Xhr.Exception -import Reflex.Dom.Xhr.ResponseType -import Control.Exception (catch, throwIO) - -prepareWebView :: WebView -> IO () -prepareWebView _ = return () - -xmlHttpRequestNew :: a -> IO XMLHttpRequest -xmlHttpRequestNew _ = newXMLHttpRequest - -xmlHttpRequestOpen :: - (ToJSString method, ToJSString url, ToJSString user, ToJSString password) => - XMLHttpRequest -> method -> url -> Bool -> user -> password -> IO () -xmlHttpRequestOpen = open - -convertException :: XHRError -> XhrException -convertException e = case e of - XHRError -> XhrException_Error - XHRAborted -> XhrException_Aborted - --- This used to be a non blocking call, but now it uses an interruptible ffi -xmlHttpRequestSend :: ToJSString payload => XMLHttpRequest -> Maybe payload -> IO () -xmlHttpRequestSend self p = (maybe (send self) (sendString self) p) `catch` (throwIO . convertException) - -xmlHttpRequestSetRequestHeader :: (ToJSString header, ToJSString value) - => XMLHttpRequest -> header -> value -> IO () -xmlHttpRequestSetRequestHeader = setRequestHeader - -xmlHttpRequestAbort :: XMLHttpRequest -> IO () -xmlHttpRequestAbort = abort - -xmlHttpRequestGetAllResponseHeaders :: XMLHttpRequest -> IO Text -xmlHttpRequestGetAllResponseHeaders self = fromMaybe "" <$> getAllResponseHeaders self - -xmlHttpRequestGetResponseHeader :: (ToJSString header) - => XMLHttpRequest -> header -> IO Text -xmlHttpRequestGetResponseHeader self header = fromMaybe "" <$> getResponseHeader self header - -xmlHttpRequestOverrideMimeType :: ToJSString override => XMLHttpRequest -> override -> IO () -xmlHttpRequestOverrideMimeType = overrideMimeType - -xmlHttpRequestDispatchEvent :: IsEvent evt => XMLHttpRequest -> Maybe evt -> IO Bool -xmlHttpRequestDispatchEvent = dispatchEvent - -xmlHttpRequestOnabort :: XMLHttpRequest -> EventM XMLHttpRequest XMLHttpRequestProgressEvent () -> IO (IO ()) -xmlHttpRequestOnabort = (`on` abortEvent) - -xmlHttpRequestOnerror :: XMLHttpRequest -> EventM XMLHttpRequest XMLHttpRequestProgressEvent () -> IO (IO ()) -xmlHttpRequestOnerror = (`on` error) - -xmlHttpRequestOnload :: XMLHttpRequest -> EventM XMLHttpRequest XMLHttpRequestProgressEvent () -> IO (IO ()) -xmlHttpRequestOnload = (`on` load) - -xmlHttpRequestOnloadend :: XMLHttpRequest -> EventM XMLHttpRequest ProgressEvent () -> IO (IO ()) -xmlHttpRequestOnloadend = (`on` loadEnd) - -xmlHttpRequestOnloadstart :: XMLHttpRequest -> EventM XMLHttpRequest ProgressEvent () -> IO (IO ()) -xmlHttpRequestOnloadstart = (`on` loadStart) - -xmlHttpRequestOnprogress :: XMLHttpRequest -> EventM XMLHttpRequest XMLHttpRequestProgressEvent () -> IO (IO ()) -xmlHttpRequestOnprogress = (`on` progress) - -xmlHttpRequestOntimeout :: XMLHttpRequest -> EventM XMLHttpRequest ProgressEvent () -> IO (IO ()) -xmlHttpRequestOntimeout = (`on` timeout) - -xmlHttpRequestOnreadystatechange :: XMLHttpRequest -> EventM XMLHttpRequest Event () -> IO (IO ()) -xmlHttpRequestOnreadystatechange = (`on` readyStateChange) - -xmlHttpRequestSetTimeout :: XMLHttpRequest -> Word -> IO () -xmlHttpRequestSetTimeout = setTimeout - -xmlHttpRequestGetTimeout :: XMLHttpRequest -> IO Word -xmlHttpRequestGetTimeout = getTimeout - -xmlHttpRequestGetReadyState :: XMLHttpRequest -> IO Word -xmlHttpRequestGetReadyState = getReadyState - -xmlHttpRequestSetWithCredentials :: XMLHttpRequest -> Bool -> IO () -xmlHttpRequestSetWithCredentials = setWithCredentials - -xmlHttpRequestGetWithCredentials :: XMLHttpRequest -> IO Bool -xmlHttpRequestGetWithCredentials = getWithCredentials - -xmlHttpRequestGetUpload :: XMLHttpRequest -> IO (Maybe XMLHttpRequestUpload) -xmlHttpRequestGetUpload = getUpload - -xmlHttpRequestGetResponseText :: FromJSString result => XMLHttpRequest -> IO (Maybe result) -xmlHttpRequestGetResponseText = getResponseText - -xmlHttpRequestGetResponseXML :: XMLHttpRequest -> IO (Maybe Document) -xmlHttpRequestGetResponseXML = getResponseXML - -xmlHttpRequestSetResponseType :: XMLHttpRequest -> XMLHttpRequestResponseType -> IO () -xmlHttpRequestSetResponseType = setResponseType - -fromResponseType :: XhrResponseType -> XMLHttpRequestResponseType -fromResponseType XhrResponseType_Default = XMLHttpRequestResponseType -fromResponseType XhrResponseType_ArrayBuffer = XMLHttpRequestResponseTypeArraybuffer -fromResponseType XhrResponseType_Blob = XMLHttpRequestResponseTypeBlob -fromResponseType XhrResponseType_Text = XMLHttpRequestResponseTypeText - -toResponseType :: XMLHttpRequestResponseType -> Maybe XhrResponseType -toResponseType XMLHttpRequestResponseType = Just XhrResponseType_Default -toResponseType XMLHttpRequestResponseTypeArraybuffer = Just XhrResponseType_ArrayBuffer -toResponseType XMLHttpRequestResponseTypeBlob = Just XhrResponseType_Blob -toResponseType XMLHttpRequestResponseTypeText = Just XhrResponseType_Text -toResponseType _ = Nothing - -xmlHttpRequestGetResponseType :: XMLHttpRequest -> IO (Maybe XhrResponseType) -xmlHttpRequestGetResponseType = fmap toResponseType . getResponseType - -xmlHttpRequestGetStatus :: XMLHttpRequest -> IO Word -xmlHttpRequestGetStatus = getStatus - -xmlHttpRequestGetStatusText :: FromJSString result => XMLHttpRequest -> IO result -xmlHttpRequestGetStatusText = getStatusText - -xmlHttpRequestGetResponseURL :: FromJSString result => XMLHttpRequest -> IO result -xmlHttpRequestGetResponseURL = getResponseURL - -xmlHttpRequestGetResponse :: XMLHttpRequest -> IO (Maybe XhrResponseBody) -xmlHttpRequestGetResponse xhr = do - mr <- getResponse xhr - rt <- xmlHttpRequestGetResponseType xhr - case rt of - Just XhrResponseType_Blob -> return $ fmap (XhrResponseBody_Blob . castToBlob) mr - Just XhrResponseType_Text -> fmap (Just . XhrResponseBody_Text) $ xmlHttpRequestGetStatusText xhr - Just XhrResponseType_Default -> fmap (Just . XhrResponseBody_Text) $ xmlHttpRequestGetStatusText xhr - Just XhrResponseType_ArrayBuffer -> case (fmap unGObject mr) of - Nothing -> return Nothing - Just ptr -> fmap (Just . XhrResponseBody_ArrayBuffer) $ bsFromArrayBuffer ptr ptr - _ -> return Nothing - diff --git a/src/Reflex/Dom.hs b/src/Reflex/Dom.hs --- a/src/Reflex/Dom.hs +++ b/src/Reflex/Dom.hs @@ -1,18 +1,11 @@ -module Reflex.Dom ( module Reflex - , module Reflex.Dom.Class - , module Reflex.Dom.Internal - , module Reflex.Dom.Widget - , module Reflex.Dom.Xhr - , module Reflex.Dom.Time - , module Reflex.Dom.WebSocket - , module Reflex.Dom.Location - ) where +-- Disable haddocks on this module due to a bug on haddocks when selectively +-- reexporting on ghc > 8.2. +-- https://github.com/haskell/haddock/issues/979 +{-# OPTIONS_HADDOCK hide, prune, ignore-exports #-} +module Reflex.Dom (module X) where -import Reflex -import Reflex.Dom.Class -import Reflex.Dom.Internal -import Reflex.Dom.Widget -import Reflex.Dom.Xhr -import Reflex.Dom.Time -import Reflex.Dom.WebSocket -import Reflex.Dom.Location +import Foreign.JavaScript.Orphans () +import Reflex.Dom.Core as X hiding (mainWidget, mainWidgetInElementById, mainWidgetWithCss, + mainWidgetWithHead, mainWidgetWithHead', runApp', + mainHydrationWidgetWithHead, mainHydrationWidgetWithHead') +import Reflex.Dom.Internal as X diff --git a/src/Reflex/Dom/Class.hs b/src/Reflex/Dom/Class.hs deleted file mode 100644 --- a/src/Reflex/Dom/Class.hs +++ /dev/null @@ -1,459 +0,0 @@ -{-# LANGUAGE TypeFamilies, FlexibleContexts, FlexibleInstances, MultiParamTypeClasses, RankNTypes, GADTs, ScopedTypeVariables, FunctionalDependencies, RecursiveDo, UndecidableInstances, GeneralizedNewtypeDeriving, StandaloneDeriving, EmptyDataDecls, NoMonomorphismRestriction, TemplateHaskell, PolyKinds, TypeOperators, DeriveFunctor, LambdaCase, CPP, ForeignFunctionInterface, DeriveDataTypeable, ConstraintKinds #-} -module Reflex.Dom.Class where - -import Prelude hiding (mapM, mapM_, sequence, concat) - -import Reflex -import Reflex.Host.Class - -import Control.Monad.Identity hiding (mapM, mapM_, forM, forM_, sequence) -import Data.Map (Map) -import qualified Data.Map as Map -import Data.Foldable -import Control.Monad.Ref -import Control.Monad.Reader hiding (mapM, mapM_, forM, forM_, sequence) -import Control.Monad.State hiding (mapM, mapM_, forM, forM_, sequence) -import Data.Dependent.Sum (DSum (..)) -import GHCJS.DOM.Types hiding (Event) -import GHCJS.DOM (WebView) -import Control.Monad.Exception - --- | Alias for Data.Map.singleton -(=:) :: k -> a -> Map k a -(=:) = Map.singleton - -keycodeEnter :: Int -keycodeEnter = 13 - -keycodeEscape :: Int -keycodeEscape = 27 - -class ( Reflex t, MonadHold t m, MonadIO m, MonadAsyncException m, Functor m, MonadReflexCreateTrigger t m - , HasDocument m, HasWebView m, HasWebView (WidgetHost m), HasWebView (GuiAction m) - , MonadIO (WidgetHost m), MonadAsyncException (WidgetHost m), MonadIO (GuiAction m), MonadAsyncException (GuiAction m), Functor (WidgetHost m), MonadSample t (WidgetHost m) - , HasPostGui t (GuiAction m) (WidgetHost m), HasPostGui t (GuiAction m) m, HasPostGui t (GuiAction m) (GuiAction m) - , MonadRef m, MonadRef (WidgetHost m) - , Ref m ~ Ref IO, Ref (WidgetHost m) ~ Ref IO --TODO: Eliminate this reliance on IO - , MonadFix m - ) => MonadWidget t m | m -> t where - type WidgetHost m :: * -> * - type GuiAction m :: * -> * - askParent :: m Node - subWidget :: Node -> m a -> m a - subWidgetWithVoidActions :: Node -> m a -> m (a, Event t (WidgetHost m ())) - liftWidgetHost :: WidgetHost m a -> m a --TODO: Is this a good idea? - schedulePostBuild :: WidgetHost m () -> m () - addVoidAction :: Event t (WidgetHost m ()) -> m () - getRunWidget :: IsNode n => m (n -> m a -> WidgetHost m (a, WidgetHost m (), Event t (WidgetHost m ()))) - -class Monad m => HasDocument m where - askDocument :: m HTMLDocument - -instance HasDocument m => HasDocument (ReaderT r m) where - askDocument = lift askDocument - -instance HasDocument m => HasDocument (StateT r m) where - askDocument = lift askDocument - -class Monad m => HasWebView m where - askWebView :: m WebView - -instance HasWebView m => HasWebView (ReaderT r m) where - askWebView = lift askWebView - -instance HasWebView m => HasWebView (StateT r m) where - askWebView = lift askWebView - -newtype Restore m = Restore { restore :: forall a. m a -> IO a } - -class Monad m => MonadIORestore m where - askRestore :: m (Restore m) - -instance MonadIORestore m => MonadIORestore (ReaderT r m) where - askRestore = do - r <- ask - parentRestore <- lift askRestore - return $ Restore $ \a -> restore parentRestore $ runReaderT a r - -class (MonadRef h, Ref h ~ Ref m, MonadRef m) => HasPostGui t h m | m -> t h where - askPostGui :: m (h () -> IO ()) - askRunWithActions :: m ([DSum (EventTrigger t) Identity] -> h ()) - -runFrameWithTriggerRef :: (HasPostGui t h m, MonadRef m, MonadIO m) => Ref m (Maybe (EventTrigger t a)) -> a -> m () -runFrameWithTriggerRef r a = do - postGui <- askPostGui - runWithActions <- askRunWithActions - liftIO . postGui $ mapM_ (\t -> runWithActions [t :=> Identity a]) =<< readRef r - -instance HasPostGui t h m => HasPostGui t h (ReaderT r m) where - askPostGui = lift askPostGui - askRunWithActions = lift askRunWithActions - -instance MonadWidget t m => MonadWidget t (ReaderT r m) where - type WidgetHost (ReaderT r m) = WidgetHost m - type GuiAction (ReaderT r m) = GuiAction m - askParent = lift askParent - subWidget n w = do - r <- ask - lift $ subWidget n $ runReaderT w r - subWidgetWithVoidActions n w = do - r <- ask - lift $ subWidgetWithVoidActions n $ runReaderT w r - liftWidgetHost = lift . liftWidgetHost - schedulePostBuild = lift . schedulePostBuild - addVoidAction = lift . addVoidAction - getRunWidget = do - r <- ask - runWidget <- lift getRunWidget - return $ \rootElement w -> do - (a, postBuild, voidActions) <- runWidget rootElement $ runReaderT w r - return (a, postBuild, voidActions) - -performEvent_ :: MonadWidget t m => Event t (WidgetHost m ()) -> m () -performEvent_ = addVoidAction - -performEvent :: (MonadWidget t m, Ref m ~ Ref IO) => Event t (WidgetHost m a) -> m (Event t a) -performEvent e = do - (eResult, reResultTrigger) <- newEventWithTriggerRef - addVoidAction $ ffor e $ \o -> do - result <- o - runFrameWithTriggerRef reResultTrigger result - return eResult - -performEventAsync :: forall t m a. MonadWidget t m => Event t ((a -> IO ()) -> WidgetHost m ()) -> m (Event t a) -performEventAsync e = do - (eResult, reResultTrigger) <- newEventWithTriggerRef - addVoidAction $ ffor e $ \o -> do - postGui <- askPostGui - runWithActions <- askRunWithActions - o $ \a -> postGui $ mapM_ (\t -> runWithActions [t :=> Identity a]) =<< readRef reResultTrigger - return eResult - -getPostBuild :: MonadWidget t m => m (Event t ()) -getPostBuild = do - (e, trigger) <- newEventWithTriggerRef - schedulePostBuild $ runFrameWithTriggerRef trigger () - return e - --------------------------------------------------------------------------------- --------------------------------------------------------------------------------- -{- - -class HasRunFrame t m | m -> t where - askRunFrame :: m (DMap (EventTrigger t) -> IO ()) - -type MonadWidget t h m = (MonadWidget' t h m, MonadWidget' t h (WidgetEventM m)) - ---TODO: Remove Spider hardcoding -class (t ~ Spider, Reflex t, MonadHold t m, ReflexHost t, HasRunFrame t h, MonadReflexHost t h, MonadIO h, MonadRef h, Ref h ~ IORef, MonadFix h, HasDocument h, MonadSample t (WidgetEventM m), WidgetEventM m ~ WidgetEventM (WidgetEventM m), MonadFix m) => MonadWidget' t h m | m -> t h where - - type WidgetEventM m :: * -> * - -- | Warning: dAttributes should not contain "id" attributes - elDynAttr' :: String -> Dynamic t (Map String String) -> m a -> m (El t, a) - performEvent :: Event t (h a) -> m (Event t a) - performEvent_ :: Event t (h ()) -> m () - getEInit :: m (Event t ()) - putEChildren :: Event t [Node] -> m () - dyn :: Dynamic t (WidgetEventM m a) -> m (Event t a) --TODO: Should probably return Dynamic t a - listWithKey :: (Ord k, Show k) => Dynamic t (Map k v) -> (k -> Dynamic t v -> WidgetEventM m v') -> m (Dynamic t (Map k v')) - text :: String -> m () - dynText :: Dynamic t String -> m () - -{-# INLINABLE performEventAsync #-} -performEventAsync :: forall t h m a. (MonadWidget t h m) => Event t ((a -> IO ()) -> h ()) -> m (Event t a) -performEventAsync eAction = do - let setup mAction = do - (eResult, reResultTrigger) <- newEventWithTriggerRef - runFrame <- askRunFrame - let runAction a = a $ \x -> readRef reResultTrigger >>= mapM_ (\eResultTrigger -> runFrame $ DMap.singleton eResultTrigger x) - maybe (return ()) runAction mAction - return (eResult, runAction) - eSetup <- performEvent . fmap (setup . (^?here)) . align eAction =<< getEInit - dRunAction <- holdDyn Nothing $ fmap (Just . snd) eSetup - performEvent_ $ attachDynWith (\mRunAction a -> maybe (return ()) ($ a) mRunAction) dRunAction eAction -- Note: this will never fire while eInit is firing, but that situation should be handled in setup; this relies on all the results from the first performEvent being fired simultaneously; otherwise, an eAction could potentially sneak in between setup being sent to performEvent and the result coming back - switchPromptly never (fmap fst eSetup) - -data TextInput t - = TextInput { _textInput_value :: Dynamic t String - , _textInput_keypress :: Event t Int - , _textInput_keydown :: Event t Int - , _textInput_keyup :: Event t Int - , _textInput_hasFocus :: Dynamic t Bool - , _textInput_element :: Dynamic t (Maybe HTMLInputElement) - } - -textInputGetEnter :: Reflex t => TextInput t -> Event t () -textInputGetEnter i = fmapMaybe (\n -> if n == keycodeEnter then Just () else Nothing) $ _textInput_keypress i - -setElementAttributes :: IsElement self => self -> Map String String -> IO () -setElementAttributes e attrs = do - oldAttrs <- maybe (return Set.empty) namedNodeMapGetNames =<< elementGetAttributes e - forM_ (Set.toList $ oldAttrs `Set.difference` Map.keysSet attrs) $ elementRemoveAttribute e - iforM_ attrs $ elementSetAttribute e - -wrapDomEvent :: (HasRunFrame t h, MonadIO m, MonadReflexHost t h, MonadIO h) => e -> (e -> m () -> IO (IO ())) -> m a -> h (Event t a) -wrapDomEvent self elementOnevent getValue = do - runFrame <- askRunFrame - e <- newEventWithTrigger $ \et -> do - unsubscribe <- {-# SCC "a" #-} liftIO $ {-# SCC "b" #-} elementOnevent self $ {-# SCC "c" #-} do - v <- {-# SCC "d" #-} getValue - liftIO $ runFrame $ DMap.singleton et v - return $ liftIO $ do - {-# SCC "e" #-} unsubscribe - return $! {-# SCC "f" #-} e - -{-# INLINABLE input #-} -input' :: MonadWidget t h m => String -> Event t String -> Dynamic t (Map String String) -> m (TextInput t) -input' inputType eSetValue dAttrs = do - dEffectiveAttrs <- mapDyn (Map.insert "type" inputType) dAttrs - let mkSelf (initialValue, initialAttrs) = do - doc <- askDocument - Just e <- liftIO $ liftM (fmap castToHTMLInputElement) $ documentCreateElement doc "input" - liftIO $ htmlInputElementSetValue e initialValue - iforM_ initialAttrs $ \attr value -> liftIO $ elementSetAttribute e attr value - eChange <- wrapDomEvent e elementOninput $ liftIO $ htmlInputElementGetValue e - runFrame <- askRunFrame - eChangeFocus <- newEventWithTrigger $ \eChangeFocusTrigger -> do - unsubscribeOnblur <- liftIO $ elementOnblur e $ liftIO $ do - runFrame $ DMap.singleton eChangeFocusTrigger False - unsubscribeOnfocus <- liftIO $ elementOnfocus e $ liftIO $ do - runFrame $ DMap.singleton eChangeFocusTrigger True - return $ liftIO $ unsubscribeOnblur >> unsubscribeOnfocus - eKeypress <- wrapDomEvent e elementOnkeypress $ liftIO . uiEventGetKeyCode =<< event - eKeydown <- wrapDomEvent e elementOnkeydown $ liftIO . uiEventGetKeyCode =<< event - eKeyup <- wrapDomEvent e elementOnkeyup $ liftIO . uiEventGetKeyCode =<< event - return (e, eChange, eKeypress, eKeydown, eKeyup, eChangeFocus) - dInitialValue <- holdDyn "" eSetValue - dInitial <- combineDyn (,) dInitialValue dEffectiveAttrs - eCreated <- performEvent . fmap mkSelf . tagDyn dInitial =<< getEInit - dMyElement <- holdDyn Nothing $ fmap (Just . (^. _1)) eCreated - performEvent_ . updated =<< combineDyn (maybe (const $ return ()) $ \e attrs -> liftIO $ setElementAttributes e attrs) dMyElement dEffectiveAttrs - putEChildren $ fmap ((:[]) . toNode . (^. _1)) eCreated - performEvent_ $ fmapMaybe (fmap $ \(e,v) -> liftIO $ htmlInputElementSetValue e v) $ attachWith (\e v -> case e of - Nothing -> Nothing - Just e' -> Just (e',v)) (current dMyElement) eSetValue - eChange <- liftM switch $ hold never $ fmap (^. _2) eCreated - dFocus <- holdDyn False . switch =<< hold never (fmap (^. _6) eCreated) --TODO: Check that 'False' is always the correct starting value - i.e.: an element will always receive an 'onfocus' event, even if it gets focus immediately - dValue <- holdDyn "" $ leftmost [eSetValue, eChange] - eKeypress <- liftM switch $ hold never $ fmap (^. _3) eCreated - eKeydown <- liftM switch $ hold never $ fmap (^. _4) eCreated - eKeyup <- liftM switch $ hold never $ fmap (^. _5) eCreated - return $ TextInput dValue eKeypress eKeydown eKeyup dFocus dMyElement - -input :: MonadWidget t h m => String -> Map String String -> m (TextInput t) -input t as = input' t never (constDyn as) - -data TextArea t - = TextArea { _textArea_value :: Dynamic t String - , _textArea_element :: Dynamic t (Maybe HTMLTextAreaElement) - } - -textArea' :: MonadWidget t h m => Event t String -> Dynamic t (Map String String) -> m (TextArea t) -textArea' eSetValue dAttrs = do - let mkSelf (initialValue, initialAttrs) = do - doc <- askDocument - Just e <- liftIO $ liftM (fmap castToHTMLTextAreaElement) $ documentCreateElement doc "textarea" - liftIO $ htmlTextAreaElementSetValue e initialValue - iforM_ initialAttrs $ \attr value -> liftIO $ elementSetAttribute e attr value - eChange <- wrapDomEvent e elementOninput $ liftIO $ htmlTextAreaElementGetValue e - return (e, eChange) - dInitialValue <- holdDyn "" eSetValue - dInitial <- combineDyn (,) dInitialValue dAttrs - eCreated <- performEvent . fmap mkSelf . tagDyn dInitial =<< getEInit - dMyElement <- holdDyn Nothing $ fmap (Just . fst) eCreated - --performEvent . updated =<< combineDyn (maybe (const $ return ()) $ \e attrs -> liftIO $ setElementAttributes e attrs) dMyElement dAttrs - putEChildren $ fmap ((:[]) . toNode . fst) eCreated - performEvent_ $ fmapMaybe (fmap $ \(e,v) -> liftIO $ htmlTextAreaElementSetValue e v) $ attachWith (\e v -> case e of - Nothing -> Nothing - Just e' -> Just (e',v)) (current dMyElement) eSetValue - eChange <- liftM switch $ hold never $ fmap snd eCreated - dValue <- holdDyn "" $ leftmost [eSetValue, eChange] - return $ TextArea dValue dMyElement - - -data Checkbox t - = Checkbox { _checkbox_checked :: Dynamic t Bool - } - -checkbox :: MonadWidget t h m => Bool -> Map String String -> m (Checkbox t) -checkbox checked attrs = do - let mkSelf = do - doc <- askDocument - Just e <- liftIO $ liftM (fmap castToHTMLInputElement) $ documentCreateElement doc "input" - liftIO $ elementSetAttribute e "type" "checkbox" - iforM_ attrs $ \attr value -> liftIO $ elementSetAttribute e attr value - if checked == True then liftIO $ elementSetAttribute e "checked" "true" else return () - eChange <- wrapDomEvent e elementOnclick $ liftIO $ htmlInputElementGetChecked e - return ([toNode e], eChange) - eCreated <- performEvent . fmap (const mkSelf) =<< getEInit - putEChildren $ fmap (^. _1) eCreated - eChange <- liftM switch $ hold never $ fmap (^. _2) eCreated - dValue <- holdDyn checked eChange - return $ Checkbox dValue - -checkboxView :: MonadWidget t h m => Dynamic t (Map String String) -> Dynamic t Bool -> m (Event t ()) -checkboxView dAttrs dValue = do - dEffectiveAttrs <- mapDyn (Map.insert "type" "checkbox") dAttrs - let mkSelf (initialValue, initialAttrs) = do - doc <- askDocument - Just e <- liftIO $ liftM (fmap castToHTMLInputElement) $ documentCreateElement doc "input" - iforM_ initialAttrs $ \attr value -> liftIO $ elementSetAttribute e attr value - liftIO $ htmlInputElementSetChecked e initialValue - eClicked <- wrapDomEvent e elementOnclick preventDefault - return (e, eClicked) - dInitial <- combineDyn (,) dValue dEffectiveAttrs - eCreated <- performEvent . fmap mkSelf . tagDyn dInitial =<< getEInit - putEChildren $ fmap ((:[]) . toNode . (^. _1)) eCreated - dElement <- holdDyn Nothing $ fmap (Just . (^. _1)) eCreated - performEvent_ . updated =<< combineDyn (\me a -> forM_ me $ \e -> liftIO $ setElementAttributes e a) dElement dEffectiveAttrs - performEvent_ . updated =<< combineDyn (\v me -> maybe (return ()) (\e -> liftIO $ htmlInputElementSetChecked e v) me) dValue dElement - liftM switch $ hold never $ fmap (^. _2) eCreated - -{-# INLINABLE textInput #-} -textInput :: MonadWidget t h m => m (TextInput t) -textInput = input "text" $ Map.singleton "class" "form-control" - -data Dropdown t k - = Dropdown { _dropdown_value :: Dynamic t k - } - -setInnerText :: (HasDocument m, IsHTMLElement self, MonadIO m) => self -> String -> m (Maybe Node) -setInnerText e s = do - liftIO $ htmlElementSetInnerHTML e "" - doc <- askDocument - t <- liftIO $ documentCreateTextNode doc s - liftIO $ nodeAppendChild e t - ---TODO: Retain set value when allowed values changes -{-# INLINABLE dropdown #-} -dropdown :: forall t h m k. (MonadWidget t h m, Show k, Read k) => Dynamic t (Map k String) -> m (Dropdown t (Maybe k)) -dropdown dOptions = do - let triggerChange (e, reChangeTrigger) runFrame = do - v <- htmlSelectElementGetValue e - readRef reChangeTrigger >>= mapM_ (\eChangeTrigger -> runFrame $ DMap.singleton eChangeTrigger $ readMay v) - let mkSelf = do - doc <- askDocument - Just e <- liftIO $ liftM (fmap castToHTMLSelectElement) $ documentCreateElement doc "select" - liftIO $ elementSetAttribute e "class" "form-control" - runFrame <- askRunFrame - reChangeTrigger <- newRef Nothing - eChange <- newEventWithTrigger $ \eChangeTrigger -> do - writeRef reChangeTrigger $ Just eChangeTrigger - unsubscribe <- liftIO $ elementOnchange e $ liftIO $ triggerChange (e, reChangeTrigger) runFrame - return $ do - writeRef reChangeTrigger Nothing - liftIO unsubscribe - return ((e, reChangeTrigger), eChange) - eCreated <- performEvent . fmap (const mkSelf) =<< getEInit - dState <- holdDyn Nothing $ fmap (Just . (^. _1)) eCreated - putEChildren $ fmap ((:[]) . toNode . fst . (^. _1)) eCreated - let updateOptions :: Map k String -> Maybe (HTMLSelectElement, Ref h (Maybe (EventTrigger t (Maybe k)))) -> h () - updateOptions options = maybe (return ()) $ \myState@(selectElement, _) -> do - doc <- askDocument - liftIO $ htmlElementSetInnerHTML selectElement "" - iforM_ options $ \k optionText -> do - Just optionElement <- liftIO $ liftM (fmap castToHTMLOptionElement) $ documentCreateElement doc "option" - liftIO $ elementSetAttribute optionElement "value" $ show k - _ <- setInnerText optionElement optionText - liftIO $ nodeAppendChild selectElement $ Just optionElement - runFrame <- askRunFrame - liftIO $ triggerChange myState runFrame - performEvent_ . updated =<< combineDyn updateOptions dOptions dState - eChange <- liftM switch $ hold never $ fmap (^. _2) eCreated - dValue <- holdDyn Nothing eChange - return $ Dropdown dValue - -data Link t - = Link { _link_clicked :: Event t () - } - -linkClassWithExtraSetup :: MonadWidget t h m => (HTMLElement -> h ()) -> String -> String -> m (Link t) -linkClassWithExtraSetup extraSetup s c = do - let mkSelf = do - doc <- askDocument - Just e <- liftIO $ liftM (fmap castToHTMLElement) $ documentCreateElement doc "a" - _ <- setInnerText e s - liftIO $ elementSetAttribute e "class" c - eClicked <- wrapDomEvent e elementOnclick $ return () - extraSetup e - return ([toNode e], eClicked) - eCreated <- performEvent . fmap (const mkSelf) =<< getEInit - putEChildren $ fmap (^. _1) eCreated - eClicked <- liftM switch $ hold never $ fmap (^. _2) eCreated - return $ Link eClicked - -{-# INLINABLE linkClass #-} -linkClass :: MonadWidget t h m => String -> String -> m (Link t) -linkClass = linkClassWithExtraSetup $ const $ return () - -{-# INLINABLE link #-} -link :: MonadWidget t h m => String -> m (Link t) -link s = linkClass s "" - -{-# INLINABLE button #-} -button :: MonadWidget t h m => String -> m (Link t) -button s = linkClass s "btn btn-primary" - -{-# INLINABLE elAttr #-} -elAttr :: forall t h m a. MonadWidget t h m => String -> Map String String -> m a -> m a -elAttr elementTag attrs child = liftM snd $ elAttr' elementTag attrs child - -{-# INLINABLE el' #-} -el' :: forall t h m a. MonadWidget t h m => String -> m a -> m (El t, a) -el' elementTag child = elAttr' elementTag Map.empty child - -{-# INLINABLE elAttr' #-} -elAttr' :: forall t h m a. MonadWidget t h m => String -> Map String String -> m a -> m (El t, a) -elAttr' elementTag attrs child = do - dAttributes <- holdDyn attrs never - elDynAttr' elementTag dAttributes child - -{-# INLINABLE elDynAttr #-} -elDynAttr :: forall t h m a. MonadWidget t h m => String -> Dynamic t (Map String String) -> m a -> m a -elDynAttr elementTag dAttributes child = liftM snd $ elDynAttr' elementTag dAttributes child - -{-# INLINABLE el #-} -el :: forall t h m a. MonadWidget t h m => String -> m a -> m a -el elementTag child = elAttr elementTag Map.empty child - -newtype Workflow t m a = Workflow { unWorkflow :: m (a, Event t (Workflow t m a)) } - -workflowView :: forall t h m a. MonadWidget t h m => Workflow t (WidgetEventM m) a -> m (Event t a) -workflowView w0 = do - rec eResult <- dyn =<< mapDyn unWorkflow =<< holdDyn w0 eReplace - eReplace <- liftM switch $ hold never $ fmap snd eResult - eResult `seq` eReplace `seq` return () - return $ fmap fst eResult - -insertNext :: (Ord k, Enum k) => v -> Map k v -> Map k v -insertNext v m = - let k = case Map.maxViewWithKey m of - Nothing -> toEnum 0 - Just ((k0, _), _) -> succ k0 - in Map.insert k v m - -{-# INLINABLE oldList #-} -oldList :: (MonadWidget t h m, MonadWidget t h (WidgetEventM m), Ord k, Show k) => Dynamic t (Map k (WidgetEventM m v')) -> m (Dynamic t (Map k ())) -oldList dm = el "ul" $ list dm (\dv -> el "li" (dyn dv) >> return ()) - -{-# INLINABLE list #-} -list :: forall t m h k v v'. (MonadWidget t h m, Ord k, Show k) => Dynamic t (Map k v) -> (Dynamic t v -> WidgetEventM m v') -> m (Dynamic t (Map k v')) -list dm mkChild = listWithKey dm (\_ dv -> mkChild dv) - -instance MonadWidget' t h m => MonadWidget' t h (ReaderT r m) where - type WidgetEventM (ReaderT r m) = ReaderT r (WidgetEventM m) - elDynAttr' tag dAttrs = mapReaderT (elDynAttr' tag dAttrs) - performEvent = lift . performEvent - performEvent_ = lift . performEvent_ - getEInit = lift getEInit - putEChildren = lift . putEChildren - dyn d = do - r <- ask - lift $ dyn =<< mapDyn (flip runReaderT r) d - listWithKey d w = do - r <- ask - lift $ listWithKey d $ \k dv -> runReaderT (w k dv) r - text = lift . text - dynText = lift . dynText - --} diff --git a/src/Reflex/Dom/Internal.hs b/src/Reflex/Dom/Internal.hs --- a/src/Reflex/Dom/Internal.hs +++ b/src/Reflex/Dom/Internal.hs @@ -1,272 +1,133 @@ -{-# LANGUAGE TypeFamilies, FlexibleContexts, FlexibleInstances, MultiParamTypeClasses, RankNTypes, GADTs, ScopedTypeVariables, FunctionalDependencies, RecursiveDo, UndecidableInstances, GeneralizedNewtypeDeriving, StandaloneDeriving, EmptyDataDecls, NoMonomorphismRestriction, TypeOperators, DeriveDataTypeable, PackageImports, TemplateHaskell, LambdaCase, ConstraintKinds, CPP #-} -module Reflex.Dom.Internal where - -import Prelude hiding (mapM, mapM_, concat, sequence, sequence_) - -import Reflex.Dom.Internal.Foreign -import Reflex.Dom.Class +{-# LANGUAGE CPP #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TypeFamilies #-} +module Reflex.Dom.Internal + ( module Main + , run + , mainWidget + , mainWidgetWithHead, mainWidgetWithCss, mainWidgetWithHead', mainWidgetInElementById, runApp' + , mainHydrationWidgetWithHead, mainHydrationWidgetWithHead' + ) where -import GHCJS.DOM hiding (runWebGUI) -import GHCJS.DOM.Types hiding (Widget, unWidget, Event) -import GHCJS.DOM.Node -import GHCJS.DOM.Element -import GHCJS.DOM.Document -import Reflex.Class -import Reflex.Host.Class -import Reflex.Spider (Spider, SpiderHost (..)) -import Control.Lens -import Control.Monad hiding (mapM, mapM_, forM, forM_, sequence, sequence_) -import Control.Monad.Reader hiding (mapM, mapM_, forM, forM_, sequence, sequence_) -import Control.Monad.Ref -import Control.Monad.State.Strict hiding (mapM, mapM_, forM, forM_, sequence, sequence_, get) -import Control.Monad.Exception -import Control.Concurrent -import Control.Applicative import Data.ByteString (ByteString) -import Data.Dependent.Sum (DSum (..)) -import Data.Foldable -import Data.Traversable -import qualified Data.Text as T -import Data.Text.Encoding -import Data.Monoid ((<>)) - -data GuiEnv t h - = GuiEnv { _guiEnvDocument :: !HTMLDocument - , _guiEnvPostGui :: !(h () -> IO ()) - , _guiEnvRunWithActions :: !([DSum (EventTrigger t) Identity] -> h ()) - , _guiEnvWebView :: !WebView - } - ---TODO: Poorly named -newtype Gui t h m a = Gui { unGui :: ReaderT (GuiEnv t h) m a } deriving (Functor, Applicative, Monad, MonadIO, MonadFix, MonadException, MonadAsyncException) - -runGui :: Gui t h m a -> GuiEnv t h -> m a -runGui (Gui g) env = runReaderT g env - -instance MonadTrans (Gui t h) where - lift = Gui . lift - -instance MonadRef m => MonadRef (Gui t h m) where - type Ref (Gui t h m) = Ref m - newRef = lift . newRef - readRef = lift . readRef - writeRef r = lift . writeRef r - -instance MonadAtomicRef m => MonadAtomicRef (Gui t h m) where - atomicModifyRef r f = lift $ atomicModifyRef r f - -instance MonadSample t m => MonadSample t (Gui t h m) where - sample b = lift $ sample b - -instance MonadHold t m => MonadHold t (Gui t h m) where - hold a0 e = lift $ hold a0 e - -instance (Reflex t, MonadReflexCreateTrigger t m) => MonadReflexCreateTrigger t (Gui t h m) where - newEventWithTrigger = lift . newEventWithTrigger - newFanEventWithTrigger f = lift $ newFanEventWithTrigger f - -data WidgetEnv - = WidgetEnv { _widgetEnvParent :: !Node - } - -data WidgetState t m - = WidgetState { _widgetStatePostBuild :: !(m ()) - , _widgetStateVoidActions :: ![Event t (m ())] --TODO: Would it help to make this a strict list? - } - -liftM concat $ mapM makeLenses - [ ''WidgetEnv - , ''WidgetState - , ''GuiEnv - ] - -instance Monad m => HasDocument (Gui t h m) where - askDocument = Gui $ view guiEnvDocument - -instance HasDocument m => HasDocument (Widget t m) where - askDocument = lift askDocument - -instance Monad m => HasWebView (Gui t h m) where - askWebView = Gui $ view guiEnvWebView - -instance MonadIORestore m => MonadIORestore (Gui t h m) where - askRestore = Gui $ do - r <- askRestore - return $ Restore $ restore r . unGui - -instance HasWebView m => HasWebView (Widget t m) where - askWebView = lift askWebView - -instance (MonadRef h, Ref h ~ Ref m, MonadRef m) => HasPostGui t h (Gui t h m) where - askPostGui = Gui $ view guiEnvPostGui - askRunWithActions = Gui $ view guiEnvRunWithActions - -instance HasPostGui t h m => HasPostGui t h (Widget t m) where - askPostGui = lift askPostGui - askRunWithActions = lift askRunWithActions - -type WidgetInternal t m a = ReaderT WidgetEnv (StateT (WidgetState t m) m) a - -instance MonadTrans (Widget t) where - lift = Widget . lift . lift - -newtype Widget t m a = Widget { unWidget :: WidgetInternal t m a } deriving (Functor, Applicative, Monad, MonadFix, MonadIO, MonadException, MonadAsyncException) - -instance MonadSample t m => MonadSample t (Widget t m) where - sample b = lift $ sample b - -instance MonadHold t m => MonadHold t (Widget t m) where - hold v0 e = lift $ hold v0 e - --- Need to build FRP circuit first, then elements - -- Can't read from FRP until the whole thing is built ---TODO: Use JSString when in JS - -instance MonadRef m => MonadRef (Widget t m) where - type Ref (Widget t m) = Ref m - newRef = lift . newRef - readRef = lift . readRef - writeRef r = lift . writeRef r - -instance MonadAtomicRef m => MonadAtomicRef (Widget t m) where - atomicModifyRef r f = lift $ atomicModifyRef r f - -instance MonadReflexCreateTrigger t m => MonadReflexCreateTrigger t (Widget t m) where - newEventWithTrigger = lift . newEventWithTrigger - newFanEventWithTrigger f = lift $ newFanEventWithTrigger f - -instance ( MonadRef m, Ref m ~ Ref IO, MonadRef h, Ref h ~ Ref IO --TODO: Shouldn't need to be IO - , MonadIO m, MonadAsyncException m, MonadIO h, MonadAsyncException h, Functor m - , ReflexHost t, MonadReflexCreateTrigger t m, MonadSample t m, MonadHold t m - , MonadFix m, HasWebView h, HasPostGui t h h - ) => MonadWidget t (Widget t (Gui t h m)) where - type WidgetHost (Widget t (Gui t h m)) = Gui t h m - type GuiAction (Widget t (Gui t h m)) = h - askParent = Widget $ view widgetEnvParent - --TODO: Use types to separate cohorts of possibly-recursive events/behaviors - -- | Schedule an action to occur after the current cohort has been built; this is necessary because Behaviors built in the current cohort may not be read until after it is complete - --schedulePostBuild :: Monad m => m () -> WidgetInternal t m () - liftWidgetHost = Widget . lift . lift - schedulePostBuild a = Widget $ widgetStatePostBuild %= (a>>) --TODO: Can this >> be made strict? - - --addVoidAction :: Monad m => Event t (m ()) -> WidgetInternal t m () - addVoidAction a = Widget $ widgetStateVoidActions %= (a:) - subWidget n child = Widget $ local (widgetEnvParent .~ toNode n) $ unWidget child - subWidgetWithVoidActions n child = Widget $ do - oldActions <- use widgetStateVoidActions - widgetStateVoidActions .= [] - result <- local (widgetEnvParent .~ toNode n) $ unWidget child - actions <- use widgetStateVoidActions - widgetStateVoidActions .= oldActions - return (result, mergeWith (>>) actions) --- runWidget :: (Monad m, IsNode n, Reflex t) => n -> Widget t m a -> m (a, Event t (m ())) - getRunWidget = return runWidget - -getQuitWidget :: MonadWidget t m => m (WidgetHost m ()) -getQuitWidget = return $ do wv <- askWebView - liftIO $ quitWebView wv - -runWidget :: (Monad m, Reflex t, IsNode n) => n -> Widget t (Gui t h m) a -> WidgetHost (Widget t (Gui t h m)) (a, WidgetHost (Widget t (Gui t h m)) (), Event t (WidgetHost (Widget t (Gui t h m)) ())) -runWidget rootElement w = do - (result, WidgetState postBuild voidActions) <- runStateT (runReaderT (unWidget w) (WidgetEnv $ toNode rootElement)) (WidgetState (return ()) []) - let voidAction = mergeWith (>>) voidActions - return (result, postBuild, voidAction) +import Data.Text (Text) +import Reflex.Dom.Main as Main hiding + (mainWidget, mainWidgetWithHead, mainWidgetWithCss, + mainWidgetWithHead', mainWidgetInElementById, runApp', + mainHydrationWidgetWithHead, mainHydrationWidgetWithHead') +import qualified Reflex.Dom.Main as Main + (mainWidget, mainWidgetWithHead, mainWidgetWithCss, + mainWidgetWithHead', mainWidgetInElementById, runApp', + mainHydrationWidgetWithHead, mainHydrationWidgetWithHead') -holdOnStartup :: MonadWidget t m => a -> WidgetHost m a -> m (Behavior t a) -holdOnStartup a0 ma = do - (startupDone, startupDoneTriggerRef) <- newEventWithTriggerRef - schedulePostBuild $ do - a <- ma - runFrameWithTriggerRef startupDoneTriggerRef a - hold a0 startupDone +#if defined(ghcjs_HOST_OS) +run :: a -> a +run = id +#elif defined(MIN_VERSION_jsaddle_warp) +import Language.Javascript.JSaddle (JSM) +import qualified Language.Javascript.JSaddle.Warp as JW +import System.Environment (lookupEnv) -mainWidget :: Widget Spider (Gui Spider (WithWebView SpiderHost) (HostFrame Spider)) () -> IO () -mainWidget w = runWebGUI $ \webView -> do - Just doc <- liftM (fmap castToHTMLDocument) $ webViewGetDomDocument webView - Just body <- getBody doc - attachWidget body webView w +run :: JSM () -> IO() +run jsm = do + port <- maybe 3003 read <$> lookupEnv "JSADDLE_WARP_PORT" + putStrLn $ "Running jsaddle-warp server on port " <> show port + JW.run port jsm -mainWidgetWithHead :: Widget Spider (Gui Spider (WithWebView SpiderHost) (HostFrame Spider)) () -> Widget Spider (Gui Spider (WithWebView SpiderHost) (HostFrame Spider)) () -> IO () -mainWidgetWithHead h b = runWebGUI $ \webView -> do - Just doc <- liftM (fmap castToHTMLDocument) $ webViewGetDomDocument webView - Just headElement <- liftM (fmap castToHTMLElement) $ getHead doc - attachWidget headElement webView h - Just body <- getBody doc - attachWidget body webView b +#elif defined(MIN_VERSION_jsaddle_wkwebview) +#if defined(ios_HOST_OS) +import Data.Default +import Data.Monoid ((<>)) +import Language.Javascript.JSaddle (JSM) +import Language.Javascript.JSaddle.WKWebView (run', mainBundleResourcePath) +import Language.Javascript.JSaddle.WKWebView.Internal (jsaddleMainHTMLWithBaseURL) -mainWidgetWithCss :: ByteString -> Widget Spider (Gui Spider (WithWebView SpiderHost) (HostFrame Spider)) () -> IO () -mainWidgetWithCss css w = runWebGUI $ \webView -> do - Just doc <- liftM (fmap castToHTMLDocument) $ webViewGetDomDocument webView - Just headElement <- liftM (fmap castToHTMLElement) $ getHead doc - setInnerHTML headElement . Just $ "" --TODO: Fix this - Just body <- getBody doc - attachWidget body webView w +-- TODO: upstream to jsaddle-wkwebview +run :: JSM () -> IO () +run jsm = do + let indexHtml = "" + baseUrl <- mainBundleResourcePath >>= \case + Nothing -> do + putStrLn "Reflex.Dom.run: unable to find main bundle resource path. Assets may not load properly." + return "" + Just p -> return $ "file://" <> p <> "/index.html" + run' def $ jsaddleMainHTMLWithBaseURL indexHtml baseUrl jsm -newtype WithWebView m a = WithWebView { unWithWebView :: ReaderT WebView m a } deriving (Functor, Applicative, Monad, MonadIO, MonadFix, MonadException, MonadAsyncException) +#else +import Language.Javascript.JSaddle.WKWebView (run) +#endif +#elif defined(ANDROID) +import Android.HaskellActivity +import Control.Monad +import Control.Monad.IO.Class (liftIO, MonadIO) +import Control.Concurrent +import Language.Javascript.JSaddle (JSM) +import Data.Default +import Data.IORef +import Data.Maybe +import Data.String +import Reflex.Dom.Android.MainWidget +import System.IO +import System.IO.Unsafe +import Language.Javascript.JSaddle (JSM, eval) -instance (Monad m) => HasWebView (WithWebView m) where - askWebView = WithWebView ask +run :: JSM () -> IO () +run jsm = do + hSetBuffering stdout LineBuffering + hSetBuffering stderr LineBuffering + continueWithCallbacks $ def + { _activityCallbacks_onCreate = \_ -> do + a <- getHaskellActivity + let startPage = fromString "https://appassets.androidplatform.net/index.html" + startMainWidget a startPage jsm + , _activityCallbacks_onBackPressed = triggerBackButton + } + forever $ threadDelay 1000000000 -instance HasPostGui t h m => HasPostGui t (WithWebView h) (WithWebView m) where - askPostGui = do - postGui <- lift askPostGui - webView <- askWebView - return $ \h -> postGui $ runWithWebView h webView - askRunWithActions = do - runWithActions <- lift askRunWithActions - return $ lift . runWithActions +triggerBackButton :: MonadIO m => m () +triggerBackButton = withGlobalJSExecutor goBack -instance HasPostGui Spider SpiderHost SpiderHost where - askPostGui = return $ \h -> liftIO $ runSpiderHost h - askRunWithActions = return fireEvents +#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 -instance MonadTrans WithWebView where - lift = WithWebView . lift +#else +import Language.Javascript.JSaddle.WebKitGTK (run) -instance MonadRef m => MonadRef (WithWebView m) where - type Ref (WithWebView m) = Ref m - newRef = lift . newRef - readRef = lift . readRef - writeRef r = lift . writeRef r +#endif -instance MonadAtomicRef m => MonadAtomicRef (WithWebView m) where - atomicModifyRef r = lift . atomicModifyRef r +mainWidget :: (forall x. Widget x ()) -> IO () +mainWidget w = run $ Main.mainWidget w +{-# INLINE mainWidget #-} -instance MonadReflexCreateTrigger t m => MonadReflexCreateTrigger t (WithWebView m) where - newEventWithTrigger = lift . newEventWithTrigger - newFanEventWithTrigger f = lift $ newFanEventWithTrigger f +mainWidgetWithHead :: (forall x. Widget x ()) -> (forall x. Widget x ()) -> IO () +mainWidgetWithHead h b = run $ Main.mainWidgetWithHead h b +{-# INLINE mainWidgetWithHead #-} -instance MonadSubscribeEvent t m => MonadSubscribeEvent t (WithWebView m) where - subscribeEvent = lift . subscribeEvent +mainWidgetWithCss :: ByteString -> (forall x. Widget x ()) -> IO () +mainWidgetWithCss css w = run $ Main.mainWidgetWithCss css w +{-# INLINE mainWidgetWithCss #-} -instance MonadReflexHost t m => MonadReflexHost t (WithWebView m) where - type ReadPhase (WithWebView m) = ReadPhase m - fireEventsAndRead dm a = lift $ fireEventsAndRead dm a - runHostFrame = lift . runHostFrame +mainWidgetWithHead' :: (a -> Widget () b, b -> Widget () a) -> IO () +mainWidgetWithHead' w = run $ Main.mainWidgetWithHead' w +{-# INLINE mainWidgetWithHead' #-} -runWithWebView :: WithWebView m a -> WebView -> m a -runWithWebView = runReaderT . unWithWebView +mainWidgetInElementById :: Text -> (forall x. Widget x ()) -> IO () +mainWidgetInElementById eid w = run $ Main.mainWidgetInElementById eid w +{-# INLINE mainWidgetInElementById #-} -attachWidget :: (IsHTMLElement e) => e -> WebView -> Widget Spider (Gui Spider (WithWebView SpiderHost) (HostFrame Spider)) a -> IO a -attachWidget rootElement wv w = runSpiderHost $ flip runWithWebView wv $ do --TODO: It seems to re-run this handler if the URL changes, even if it's only the fragment - Just doc <- liftM (fmap castToHTMLDocument) $ getOwnerDocument rootElement - frames <- liftIO newChan - rec let guiEnv = GuiEnv doc (writeChan frames . runSpiderHost . flip runWithWebView wv) runWithActions wv :: GuiEnv Spider (WithWebView SpiderHost) - runWithActions dm = do - voidActionNeeded <- fireEventsAndRead dm $ do - sequence =<< readEvent voidActionHandle - runHostFrame $ runGui (sequence_ voidActionNeeded) guiEnv - Just df <- createDocumentFragment doc - (result, voidAction) <- runHostFrame $ flip runGui guiEnv $ do - (r, postBuild, va) <- runWidget df w - postBuild -- This probably shouldn't be run inside the frame; we need to make sure we don't run a frame inside of a frame - return (r, va) - setInnerHTML rootElement $ Just "" - _ <- appendChild rootElement $ Just df - voidActionHandle <- subscribeEvent voidAction --TODO: Should be unnecessary - --postGUISync seems to leak memory on GHC (unknown on GHCJS) - _ <- liftIO $ forkIO $ forever $ postGUISync =<< readChan frames -- postGUISync is necessary to prevent segfaults in GTK, which is not thread-safe - return result +runApp' :: (forall x. AppInput DomTimeline -> Widget x (AppOutput DomTimeline)) -> IO () +runApp' app = run $ Main.runApp' app +{-# INLINE runApp' #-} ---type MonadWidget t h m = (t ~ Spider, h ~ Gui Spider SpiderHost (HostFrame Spider), m ~ Widget t h, Monad h, MonadHold t h, HasDocument h, MonadSample t h, MonadRef h, MonadIO h, Functor (Event t), Functor h, Reflex t) -- Locking down these types seems to help a little in GHCJS, but not really in GHC +mainHydrationWidgetWithHead :: (forall x. HydrationWidget x ()) -> (forall x. HydrationWidget x ()) -> IO () +mainHydrationWidgetWithHead h b = run $ Main.mainHydrationWidgetWithHead h b +{-# INLINE mainHydrationWidgetWithHead #-} +mainHydrationWidgetWithHead' :: HydrationWidget () () -> HydrationWidget () () -> IO () +mainHydrationWidgetWithHead' h b = run $ Main.mainHydrationWidgetWithHead' h b +{-# INLINE mainHydrationWidgetWithHead' #-} diff --git a/src/Reflex/Dom/Location.hs b/src/Reflex/Dom/Location.hs deleted file mode 100644 --- a/src/Reflex/Dom/Location.hs +++ /dev/null @@ -1,3 +0,0 @@ -module Reflex.Dom.Location (getLocationHost, getLocationProtocol) where - -import Reflex.Dom.Internal.Foreign diff --git a/src/Reflex/Dom/Location/Platform.hs b/src/Reflex/Dom/Location/Platform.hs new file mode 100644 --- /dev/null +++ b/src/Reflex/Dom/Location/Platform.hs @@ -0,0 +1,20 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleContexts #-} +#if defined(ANDROID) +module Reflex.Dom.Location.Platform where + +import Reflex +import Control.Monad.IO.Class +import Reflex.Dom.Android.MainWidget + +popHistoryState + :: (PerformEvent t m, MonadIO (Performable m)) + => Event t () + -> m () +popHistoryState evt = performEvent_ $ withGlobalJSExecutor goBack <$ evt +#else +module Reflex.Dom.Location.Platform (Reflex.Dom.Location.popHistoryState) where +import qualified Reflex.Dom.Location + +#endif + diff --git a/src/Reflex/Dom/Time.hs b/src/Reflex/Dom/Time.hs deleted file mode 100644 --- a/src/Reflex/Dom/Time.hs +++ /dev/null @@ -1,73 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable, ScopedTypeVariables #-} -module Reflex.Dom.Time where - -import Reflex -import Reflex.Dom.Class - -import Control.Concurrent -import Control.Monad -import Control.Monad.IO.Class -import Data.Fixed -import Data.Time.Clock -import Data.Typeable - -data TickInfo - = TickInfo { _tickInfo_lastUTC :: UTCTime - -- ^ UTC time immediately after the last tick. - , _tickInfo_n :: Integer - -- ^ Number of time periods since t0 - , _tickInfo_alreadyElapsed :: NominalDiffTime - -- ^ Amount of time already elapsed in the current tick period. - } - deriving (Eq, Ord, Typeable) - --- | Special case of tickLossyFrom that uses the post-build event to start the --- tick thread. -tickLossy :: MonadWidget t m => NominalDiffTime -> UTCTime -> m (Event t TickInfo) -tickLossy dt t0 = tickLossyFrom dt t0 =<< getPostBuild - --- | Send events over time with the given basis time and interval --- If the system starts running behind, occurrences will be dropped rather than buffered --- Each occurrence of the resulting event will contain the index of the current interval, with 0 representing the basis time -tickLossyFrom - :: MonadWidget t m - => NominalDiffTime - -> UTCTime - -> Event t a - -- ^ Event that starts a tick generation thread. Usually you want this to - -- be something like the result of getPostBuild that only fires once. But - -- there could be uses for starting multiple timer threads. - -> m (Event t TickInfo) -tickLossyFrom dt t0 e = performEventAsync $ fmap callAtNextInterval e - where callAtNextInterval _ cb = void $ liftIO $ forkIO $ forever $ do - tick <- getCurrentTick dt t0 - threadDelay $ ceiling $ (dt - _tickInfo_alreadyElapsed tick) * 1000000 - cb tick - -clockLossy :: MonadWidget t m => NominalDiffTime -> UTCTime -> m (Dynamic t TickInfo) -clockLossy dt t0 = do - initial <- liftIO $ getCurrentTick dt t0 - e <- tickLossy dt t0 - holdDyn initial e - -getCurrentTick :: NominalDiffTime -> UTCTime -> IO TickInfo -getCurrentTick dt t0 = do - t <- getCurrentTime - let offset = t `diffUTCTime` t0 - (n, alreadyElapsed) = offset `divMod'` dt - return $ TickInfo t n alreadyElapsed - --- | Delay an Event's occurrences by a given amount in seconds. -delay :: MonadWidget t m => NominalDiffTime -> Event t a -> m (Event t a) -delay dt e = performEventAsync $ ffor e $ \a cb -> liftIO $ void $ forkIO $ do - threadDelay $ ceiling $ dt * 1000000 - cb a - --- | Block occurrences of an Event until the given number of seconds elapses without --- the Event firing, at which point the last occurrence of the Event will fire. -debounce :: MonadWidget t m => NominalDiffTime -> Event t a -> m (Event t a) -debounce dt e = do - n :: Dynamic t Integer <- count e - let tagged = attachDynWith (,) n e - delayed <- delay dt tagged - return $ attachWithMaybe (\n' (t, v) -> if n' == t then Just v else Nothing) (current n) delayed diff --git a/src/Reflex/Dom/WebSocket.hs b/src/Reflex/Dom/WebSocket.hs deleted file mode 100644 --- a/src/Reflex/Dom/WebSocket.hs +++ /dev/null @@ -1,68 +0,0 @@ -{-# LANGUAGE ForeignFunctionInterface, JavaScriptFFI, CPP, TemplateHaskell, NoMonomorphismRestriction, EmptyDataDecls, RankNTypes, GADTs, RecursiveDo, ScopedTypeVariables, FlexibleInstances, MultiParamTypeClasses, TypeFamilies, FlexibleContexts, DeriveDataTypeable, GeneralizedNewtypeDeriving, StandaloneDeriving, ConstraintKinds, UndecidableInstances, PolyKinds, AllowAmbiguousTypes #-} - -module Reflex.Dom.WebSocket where - -import Prelude hiding (div, span, mapM, mapM_, concat, concatMap, all, sequence) - -import Reflex -import Reflex.Host.Class -import Reflex.Dom.Class -import Reflex.Dom.WebSocket.Foreign - -import Control.Concurrent -import Control.Lens -import Control.Monad hiding (forM, forM_, mapM, mapM_, sequence) -import Control.Monad.IO.Class -import Control.Monad.Ref -import Control.Monad.State -import Data.ByteString (ByteString) -import Data.Default -import Data.Dependent.Map (DSum (..)) -import Data.IORef - -data WebSocketConfig t - = WebSocketConfig { _webSocketConfig_send :: Event t [ByteString] - } - -instance Reflex t => Default (WebSocketConfig t) where - def = WebSocketConfig never - -data WebSocket t - = WebSocket { _webSocket_recv :: Event t ByteString - , _webSocket_open :: Event t () - } - -webSocket :: forall t m. (HasWebView m, MonadWidget t m) => String -> WebSocketConfig t -> m (WebSocket t) -webSocket url config = do - wv <- askWebView - postGui <- askPostGui - runWithActions <- askRunWithActions - (eRecv, eRecvTriggerRef) <- newEventWithTriggerRef - currentSocketRef <- liftIO $ newIORef Nothing - --TODO: Disconnect if value no longer needed - (eOpen, eOpenTriggerRef) <- newEventWithTriggerRef - let onMessage :: ByteString -> IO () - onMessage m = postGui $ do - mt <- readRef eRecvTriggerRef - forM_ mt $ \t -> runWithActions [t :=> Identity m] - onOpen = postGui $ do - mt <- readRef eOpenTriggerRef - forM_ mt $ \t -> runWithActions [t :=> Identity ()] - start = do - ws <- liftIO $ newWebSocket wv url onMessage onOpen $ do - void $ forkIO $ do --TODO: Is the fork necessary, or do event handlers run in their own threads automatically? - liftIO $ writeIORef currentSocketRef Nothing - liftIO $ threadDelay 1000000 - start - liftIO $ writeIORef currentSocketRef $ Just ws - return () - schedulePostBuild $ liftIO start - performEvent_ $ ffor (_webSocketConfig_send config) $ \payloads -> forM_ payloads $ \payload -> do - mws <- liftIO $ readIORef currentSocketRef - case mws of - Nothing -> return () -- Discard --TODO: should we do something better here? probably buffer it, since we handle reconnection logic; how do we verify that the server has received things? - Just ws -> do - liftIO $ webSocketSend ws payload - return $ WebSocket eRecv eOpen - -makeLensesWith (lensRules & simpleLenses .~ True) ''WebSocketConfig diff --git a/src/Reflex/Dom/Widget.hs b/src/Reflex/Dom/Widget.hs deleted file mode 100644 --- a/src/Reflex/Dom/Widget.hs +++ /dev/null @@ -1,10 +0,0 @@ -module Reflex.Dom.Widget ( module Reflex.Dom.Widget.Basic - , module Reflex.Dom.Widget.Input - , module Reflex.Dom.Widget.Lazy - , module Reflex.Dom.Widget.Resize - ) where - -import Reflex.Dom.Widget.Basic -import Reflex.Dom.Widget.Input -import Reflex.Dom.Widget.Lazy -import Reflex.Dom.Widget.Resize diff --git a/src/Reflex/Dom/Widget/Basic.hs b/src/Reflex/Dom/Widget/Basic.hs deleted file mode 100644 --- a/src/Reflex/Dom/Widget/Basic.hs +++ /dev/null @@ -1,907 +0,0 @@ -{-# LANGUAGE ScopedTypeVariables, LambdaCase, ConstraintKinds, TypeFamilies, FlexibleContexts, MultiParamTypeClasses, FlexibleInstances, RecursiveDo, GADTs, DataKinds, RankNTypes, TemplateHaskell #-} - -module Reflex.Dom.Widget.Basic where - -import Reflex.Dom.Class -import Reflex.Dom.Internal.Foreign () - -import Prelude hiding (mapM, mapM_, sequence, sequence_) -import Reflex -import Reflex.Host.Class -import Data.Functor.Misc -import Data.Map (Map) -import qualified Data.Map as Map -import Data.Set (Set) -import qualified Data.Set as Set -import Data.Dependent.Sum (DSum (..)) -import Data.Foldable -import Data.Traversable -import Control.Monad.Trans -import Control.Monad.Reader hiding (mapM, mapM_, forM, forM_, sequence, sequence_) -import Control.Monad.State hiding (state, mapM, mapM_, forM, forM_, sequence, sequence_) -import GHCJS.DOM.Node -import GHCJS.DOM.UIEvent -import GHCJS.DOM.EventM (on, event, EventM, stopPropagation) -import GHCJS.DOM.Document -import GHCJS.DOM.Element as E -import GHCJS.DOM.Types hiding (Event) -import qualified GHCJS.DOM.Types as DOM (Event) -import GHCJS.DOM.NamedNodeMap as NNM -import Control.Lens hiding (element, children) -import Data.These -import Data.Align -import Data.Maybe -import Data.GADT.Compare.TH -import Data.Bitraversable -import GHCJS.DOM.MouseEvent -import Data.IORef -import Data.Default - -type AttributeMap = Map String String - -data ElConfig attrs - = ElConfig { _elConfig_namespace :: Maybe String - , _elConfig_attributes :: attrs - } - -makeLenses ''ElConfig - -instance (attrs ~ Map String String) => Default (ElConfig attrs) where - def = ElConfig { _elConfig_namespace = Nothing - , _elConfig_attributes = Map.empty - } - -data El t - = El { _el_element :: Element - , _el_events :: EventSelector t (WrapArg EventResult EventName) - } - -class Attributes m a where - addAttributes :: IsElement e => a -> e -> m () - -instance MonadIO m => Attributes m AttributeMap where - addAttributes curAttrs e = imapM_ (setAttribute e) curAttrs - -instance MonadWidget t m => Attributes m (Dynamic t AttributeMap) where - addAttributes attrs e = do - schedulePostBuild $ do - curAttrs <- sample $ current attrs - imapM_ (setAttribute e) curAttrs - addVoidAction $ flip fmap (updated attrs) $ \newAttrs -> liftIO $ do - oldAttrs <- maybe (return Set.empty) namedNodeMapGetNames =<< getAttributes e - forM_ (Set.toList $ oldAttrs `Set.difference` Map.keysSet newAttrs) $ removeAttribute e - imapM_ (setAttribute e) newAttrs --TODO: avoid re-setting unchanged attributes; possibly do the compare using Align in haskell - -buildEmptyElementNS :: (MonadWidget t m, Attributes m attrs) => Maybe String -> String -> attrs -> m Element -buildEmptyElementNS mns elementTag attrs = do - doc <- askDocument - p <- askParent - Just e <- liftIO $ case mns of - Nothing -> createElement doc (Just elementTag) - Just ns -> createElementNS doc (Just ns) (Just elementTag) - addAttributes attrs e - _ <- appendChild p $ Just e - return $ castToElement e - -buildEmptyElement :: (MonadWidget t m, Attributes m attrs) => String -> attrs -> m Element -buildEmptyElement = buildEmptyElementNS Nothing - --- We need to decide what type of attrs we've got statically, because it will often be a recursively defined value, in which case inspecting it will lead to a cycle -buildElementNS :: (MonadWidget t m, Attributes m attrs) => Maybe String -> String -> attrs -> m a -> m (Element, a) -buildElementNS mns elementTag attrs child = do - e <- buildEmptyElementNS mns elementTag attrs - result <- subWidget (toNode e) child - return (e, result) - -buildElement :: (MonadWidget t m, Attributes m attrs) => String -> attrs -> m a -> m (Element, a) -buildElement = buildElementNS Nothing - -namedNodeMapGetNames :: NamedNodeMap -> IO (Set String) -namedNodeMapGetNames self = do - l <- NNM.getLength self - let locations = if l == 0 then [] else [0..l-1] -- Can't use 0..l-1 if l is 0 because l is unsigned and will wrap around - liftM (Set.fromList . catMaybes) $ forM locations $ \i -> do - Just n <- NNM.item self i - getNodeName n - -text :: MonadWidget t m => String -> m () -text = void . text' - ---TODO: Wrap the result -text' :: MonadWidget t m => String -> m Text -text' s = do - doc <- askDocument - p <- askParent - Just n <- createTextNode doc s - _ <- appendChild p $ Just n - return n - -dynText :: MonadWidget t m => Dynamic t String -> m () -dynText s = do - n <- text' "" - schedulePostBuild $ do - curS <- sample $ current s - setNodeValue n $ Just curS - addVoidAction $ fmap (setNodeValue n . Just) $ updated s - -display :: (MonadWidget t m, Show a) => Dynamic t a -> m () -display a = dynText =<< mapDyn show a - ---TODO: Should this be renamed to 'widgetView' for consistency with 'widgetHold'? --- | Given a Dynamic of widget-creating actions, create a widget that is recreated whenever the Dynamic updates. --- The returned Event of widget results occurs when the Dynamic does. --- Note: Often, the type 'a' is an Event, in which case the return value is an Event-of-Events that would typically be flattened. -dyn :: MonadWidget t m => Dynamic t (m a) -> m (Event t a) -dyn child = do - postBuild <- getPostBuild - let newChild = leftmost [updated child, tag (current child) postBuild] - liftM snd $ widgetHoldInternal (return ()) newChild - --- | Given an initial widget and an Event of widget-creating actions, create a widget that is recreated whenever the Event fires. --- The returned Dynamic of widget results occurs when the Event does. --- Note: Often, the type 'a' is an Event, in which case the return value is a Dynamic-of-Events that would typically be flattened. -widgetHold :: MonadWidget t m => m a -> Event t (m a) -> m (Dynamic t a) -widgetHold child0 newChild = do - (result0, newResult) <- widgetHoldInternal child0 newChild - holdDyn result0 newResult - -widgetHoldInternal :: MonadWidget t m => m a -> Event t (m b) -> m (a, Event t b) -widgetHoldInternal child0 newChild = do - startPlaceholder <- text' "" - (result0, childVoidAction0) <- do - p <- askParent - subWidgetWithVoidActions p child0 - endPlaceholder <- text' "" - (newChildBuilt, newChildBuiltTriggerRef) <- newEventWithTriggerRef - performEvent_ $ fmap (const $ return ()) newChildBuilt --TODO: Get rid of this hack - childVoidAction <- hold childVoidAction0 $ fmap snd newChildBuilt - addVoidAction $ switch childVoidAction --TODO: Should this be a switchPromptly? - doc <- askDocument - runWidget <- getRunWidget - addVoidAction $ ffor newChild $ \c -> do - Just df <- createDocumentFragment doc - (result, postBuild, voidActions) <- runWidget df c - runFrameWithTriggerRef newChildBuiltTriggerRef (result, voidActions) - postBuild - liftIO $ deleteBetweenExclusive startPlaceholder endPlaceholder - mp' <- getParentNode endPlaceholder - forM_ mp' $ \p' -> insertBefore p' (Just df) (Just endPlaceholder) - return () - return (result0, fmap fst newChildBuilt) - -diffMapNoEq :: (Ord k) => Map k v -> Map k v -> Map k (Maybe v) -diffMapNoEq olds news = flip Map.mapMaybe (align olds news) $ \case - This _ -> Just Nothing - These _ new -> Just $ Just new - That new -> Just $ Just new - -applyMap :: Ord k => Map k v -> Map k (Maybe v) -> Map k v -applyMap olds diffs = flip Map.mapMaybe (align olds diffs) $ \case - This old -> Just old - These _ new -> new - That new -> new - ---TODO: Something better than Dynamic t (Map k v) - we want something where the Events carry diffs, not the whole value -listWithKey :: forall t k v m a. (Ord k, MonadWidget t m) => Dynamic t (Map k v) -> (k -> Dynamic t v -> m a) -> m (Dynamic t (Map k a)) -listWithKey vals mkChild = do - postBuild <- getPostBuild - rec sentVals :: Dynamic t (Map k v) <- foldDyn (flip applyMap) Map.empty changeVals - let changeVals :: Event t (Map k (Maybe v)) - changeVals = attachWith diffMapNoEq (current sentVals) $ leftmost - [ updated vals - , tag (current vals) postBuild - ] - listWithKeyShallowDiff Map.empty changeVals $ \k v0 dv -> do - mkChild k =<< holdDyn v0 dv - -{-# DEPRECATED listWithKey' "listWithKey' has been renamed to listWithKeyShallowDiff; also, its behavior has changed to fix a bug where children were always rebuilt (never updated)" #-} -listWithKey' :: (Ord k, MonadWidget t m) => Map k v -> Event t (Map k (Maybe v)) -> (k -> v -> Event t v -> m a) -> m (Dynamic t (Map k a)) -listWithKey' = listWithKeyShallowDiff - --- | Display the given map of items (in key order) using the builder function provided, and update it with the given event. 'Nothing' update entries will delete the corresponding children, and 'Just' entries will create them if they do not exist or send an update event to them if they do. -listWithKeyShallowDiff :: (Ord k, MonadWidget t m) => Map k v -> Event t (Map k (Maybe v)) -> (k -> v -> Event t v -> m a) -> m (Dynamic t (Map k a)) -listWithKeyShallowDiff initialVals valsChanged mkChild = do - let childValChangedSelector = fanMap $ fmap (Map.mapMaybe id) valsChanged - sentVals <- foldDyn (flip applyMap) Map.empty $ fmap (fmap (fmap (\_ -> ()))) valsChanged - let relevantDiff diff _ = case diff of - Nothing -> Just Nothing -- Even if we let a Nothing through when the element doesn't already exist, this doesn't cause a problem because it is ignored - Just _ -> Nothing -- We don't want to let spurious re-creations of items through - listHoldWithKey initialVals (attachWith (flip (Map.differenceWith relevantDiff)) (current sentVals) valsChanged) $ \k v -> - mkChild k v $ Reflex.select childValChangedSelector $ Const2 k - --- | Display the given map of items using the builder function provided, and update it with the given event. 'Nothing' entries will delete the corresponding children, and 'Just' entries will create or replace them. Since child events do not take any signal arguments, they are always rebuilt. To update a child without rebuilding, either embed signals in the map's values, or refer to them directly in the builder function. -listHoldWithKey :: (Ord k, MonadWidget t m) => Map k v -> Event t (Map k (Maybe v)) -> (k -> v -> m a) -> m (Dynamic t (Map k a)) -listHoldWithKey initialVals valsChanged mkChild = do - doc <- askDocument - endPlaceholder <- text' "" - (newChildren, newChildrenTriggerRef) <- newEventWithTriggerRef --- performEvent_ $ fmap (const $ return ()) newChildren --TODO: Get rid of this hack - runWidget <- getRunWidget - let buildChild df k v = runWidget df $ wrapChild k v - wrapChild k v = do - childStart <- text' "" - result <- mkChild k v - childEnd <- text' "" - return (result, (childStart, childEnd)) - Just dfOrig <- createDocumentFragment doc - initialState <- iforM initialVals $ \k v -> subWidgetWithVoidActions (toNode dfOrig) $ wrapChild k v --Note: we have to use subWidgetWithVoidActions rather than runWidget here, because running post-build actions during build can cause not-yet-constructed values to be read - stateRef <- liftIO $ newIORef initialState - children <- holdDyn initialState newChildren - addVoidAction $ switch $ fmap (mergeWith (>>) . map snd . Map.elems) $ current children - mpOrig <- getParentNode endPlaceholder - forM_ mpOrig $ \pOrig -> insertBefore pOrig (Just dfOrig) (Just endPlaceholder) - addVoidAction $ flip fmap valsChanged $ \newVals -> do - curState <- liftIO $ readIORef stateRef - --TODO: Should we remove the parent from the DOM first to avoid reflows? - (newState, postBuild) <- flip runStateT (return ()) $ liftM (Map.mapMaybe id) $ iforM (align curState newVals) $ \k -> \case - These ((_, (start, end)), _) Nothing -> do -- Deleting child - liftIO $ deleteBetweenInclusive start end - return Nothing - These ((_, (start, end)), _) (Just v) -> do -- Replacing existing child - liftIO $ deleteBetweenExclusive start end - Just df <- createDocumentFragment doc - (childResult, childPostBuild, childVoidAction) <- lift $ buildChild df k v - let s = (childResult, childVoidAction) - modify (>>childPostBuild) - mp <- getParentNode end - forM_ mp $ \p -> insertBefore p (Just df) (Just end) - return $ Just s - That Nothing -> return Nothing -- Deleting non-existent child - That (Just v) -> do -- Creating new child - Just df <- createDocumentFragment doc - (childResult, childPostBuild, childVoidAction) <- lift $ buildChild df k v - let s = (childResult, childVoidAction) - modify (>>childPostBuild) - let placeholder = case Map.lookupGT k curState of - Nothing -> endPlaceholder - Just (_, ((_, (start, _)), _)) -> start - mp <- getParentNode placeholder - forM_ mp $ \p -> insertBefore p (Just df) (Just placeholder) - return $ Just s - This state -> do -- No change - return $ Just state - liftIO $ writeIORef stateRef newState - runFrameWithTriggerRef newChildrenTriggerRef newState - postBuild - mapDyn (fmap (fst . fst)) children - ---TODO: Something better than Dynamic t (Map k v) - we want something where the Events carry diffs, not the whole value --- | Create a dynamically-changing set of Event-valued widgets. --- This is like listWithKey, specialized for widgets returning (Event t a). listWithKey would return 'Dynamic t (Map k (Event t a))' in this scenario, but listViewWithKey flattens this to 'Event t (Map k a)' via 'switch'. -listViewWithKey :: (Ord k, MonadWidget t m) => Dynamic t (Map k v) -> (k -> Dynamic t v -> m (Event t a)) -> m (Event t (Map k a)) -listViewWithKey vals mkChild = liftM (switch . fmap mergeMap) $ listViewWithKey' vals mkChild - -listViewWithKey' :: (Ord k, MonadWidget t m) => Dynamic t (Map k v) -> (k -> Dynamic t v -> m a) -> m (Behavior t (Map k a)) -listViewWithKey' vals mkChild = liftM current $ listWithKey vals mkChild - --- | Create a dynamically-changing set of widgets, one of which is selected at any time. -selectViewListWithKey :: forall t m k v a. (MonadWidget t m, Ord k) - => Dynamic t k -- ^ Current selection key - -> Dynamic t (Map k v) -- ^ Dynamic key/value map - -> (k -> Dynamic t v -> Dynamic t Bool -> m (Event t a)) -- ^ Function to create a widget for a given key from Dynamic value and Dynamic Bool indicating if this widget is currently selected - -> m (Event t (k, a)) -- ^ Event that fires when any child's return Event fires. Contains key of an arbitrary firing widget. -selectViewListWithKey selection vals mkChild = do - let selectionDemux = demux selection -- For good performance, this value must be shared across all children - selectChild <- listWithKey vals $ \k v -> do - selected <- getDemuxed selectionDemux k - selectSelf <- mkChild k v selected - return $ fmap ((,) k) selectSelf - liftM switchPromptlyDyn $ mapDyn (leftmost . Map.elems) selectChild - -selectViewListWithKey_ :: forall t m k v a. (MonadWidget t m, Ord k) - => Dynamic t k -- ^ Current selection key - -> Dynamic t (Map k v) -- ^ Dynamic key/value map - -> (k -> Dynamic t v -> Dynamic t Bool -> m (Event t a)) -- ^ Function to create a widget for a given key from Dynamic value and Dynamic Bool indicating if this widget is currently selected - -> m (Event t k) -- ^ Event that fires when any child's return Event fires. Contains key of an arbitrary firing widget. -selectViewListWithKey_ selection vals mkChild = liftM (fmap fst) $ selectViewListWithKey selection vals mkChild - --------------------------------------------------------------------------------- --- Basic DOM manipulation helpers --------------------------------------------------------------------------------- - --- | s and e must both be children of the same node and s must precede e -deleteBetweenExclusive :: (IsNode start, IsNode end) => start -> end -> IO () -deleteBetweenExclusive s e = do - mCurrentParent <- getParentNode e -- May be different than it was at initial construction, e.g., because the parent may have dumped us in from a DocumentFragment - case mCurrentParent of - Nothing -> return () --TODO: Is this the right behavior? - Just currentParent -> do - let go = do - Just x <- getPreviousSibling e -- This can't be Nothing because we should hit 's' first - when (toNode s /= toNode x) $ do - _ <- removeChild currentParent $ Just x - go - go - --- | s and e must both be children of the same node and s must precede e -deleteBetweenInclusive :: (IsNode start, IsNode end) => start -> end -> IO () -deleteBetweenInclusive s e = do - mCurrentParent <- getParentNode e -- May be different than it was at initial construction, e.g., because the parent may have dumped us in from a DocumentFragment - case mCurrentParent of - Nothing -> return () --TODO: Is this the right behavior? - Just currentParent -> do - let go = do - Just x <- getPreviousSibling e -- This can't be Nothing because we should hit 's' first - _ <- removeChild currentParent $ Just x - when (toNode s /= toNode x) go - go - _ <- removeChild currentParent $ Just e - return () - -nodeClear :: IsNode self => self -> IO () -nodeClear n = do - mfc <- getFirstChild n - case mfc of - Nothing -> return () - Just fc -> do - _ <- removeChild n $ Just fc - nodeClear n - --------------------------------------------------------------------------------- --- Adapters --------------------------------------------------------------------------------- - -wrapDomEvent :: (Functor (Event t), MonadIO m, MonadSample t m, MonadReflexCreateTrigger t m, Reflex t, HasPostGui t h m) => e -> (e -> EventM e event () -> IO (IO ())) -> EventM e event a -> m (Event t a) -wrapDomEvent element elementOnevent getValue = wrapDomEventMaybe element elementOnevent $ liftM Just getValue - -wrapDomEventMaybe :: (Functor (Event t), MonadIO m, MonadSample t m, MonadReflexCreateTrigger t m, Reflex t, HasPostGui t h m) => e -> (e -> EventM e event () -> IO (IO ())) -> EventM e event (Maybe a) -> m (Event t a) -wrapDomEventMaybe element elementOnevent getValue = do - postGui <- askPostGui - runWithActions <- askRunWithActions - e <- newEventWithTrigger $ \et -> do - unsubscribe <- {-# SCC "a" #-} liftIO $ {-# SCC "b" #-} elementOnevent element $ {-# SCC "c" #-} do - mv <- {-# SCC "d" #-} getValue - forM_ mv $ \v -> liftIO $ postGui $ runWithActions [et :=> Identity v] - return $ liftIO $ do - {-# SCC "e" #-} unsubscribe - return $! {-# SCC "f" #-} e - -data EventTag - = AbortTag - | BlurTag - | ChangeTag - | ClickTag - | ContextmenuTag - | DblclickTag - | DragTag - | DragendTag - | DragenterTag - | DragleaveTag - | DragoverTag - | DragstartTag - | DropTag - | ErrorTag - | FocusTag - | InputTag - | InvalidTag - | KeydownTag - | KeypressTag - | KeyupTag - | LoadTag - | MousedownTag - | MouseenterTag - | MouseleaveTag - | MousemoveTag - | MouseoutTag - | MouseoverTag - | MouseupTag - | MousewheelTag - | ScrollTag - | SelectTag - | SubmitTag - | WheelTag - | BeforecutTag - | CutTag - | BeforecopyTag - | CopyTag - | BeforepasteTag - | PasteTag - | ResetTag - | SearchTag - | SelectstartTag - | TouchstartTag - | TouchmoveTag - | TouchendTag - | TouchcancelTag - -data EventName :: EventTag -> * where - Abort :: EventName 'AbortTag - Blur :: EventName 'BlurTag - Change :: EventName 'ChangeTag - Click :: EventName 'ClickTag - Contextmenu :: EventName 'ContextmenuTag - Dblclick :: EventName 'DblclickTag - Drag :: EventName 'DragTag - Dragend :: EventName 'DragendTag - Dragenter :: EventName 'DragenterTag - Dragleave :: EventName 'DragleaveTag - Dragover :: EventName 'DragoverTag - Dragstart :: EventName 'DragstartTag - Drop :: EventName 'DropTag - Error :: EventName 'ErrorTag - Focus :: EventName 'FocusTag - Input :: EventName 'InputTag - Invalid :: EventName 'InvalidTag - Keydown :: EventName 'KeydownTag - Keypress :: EventName 'KeypressTag - Keyup :: EventName 'KeyupTag - Load :: EventName 'LoadTag - Mousedown :: EventName 'MousedownTag - Mouseenter :: EventName 'MouseenterTag - Mouseleave :: EventName 'MouseleaveTag - Mousemove :: EventName 'MousemoveTag - Mouseout :: EventName 'MouseoutTag - Mouseover :: EventName 'MouseoverTag - Mouseup :: EventName 'MouseupTag - Mousewheel :: EventName 'MousewheelTag - Scroll :: EventName 'ScrollTag - Select :: EventName 'SelectTag - Submit :: EventName 'SubmitTag - Wheel :: EventName 'WheelTag - Beforecut :: EventName 'BeforecutTag - Cut :: EventName 'CutTag - Beforecopy :: EventName 'BeforecopyTag - Copy :: EventName 'CopyTag - Beforepaste :: EventName 'BeforepasteTag - Paste :: EventName 'PasteTag - Reset :: EventName 'ResetTag - Search :: EventName 'SearchTag - Selectstart :: EventName 'SelectstartTag - Touchstart :: EventName 'TouchstartTag - Touchmove :: EventName 'TouchmoveTag - Touchend :: EventName 'TouchendTag - Touchcancel :: EventName 'TouchcancelTag - -type family EventType en where - EventType 'AbortTag = UIEvent - EventType 'BlurTag = FocusEvent - EventType 'ChangeTag = DOM.Event - EventType 'ClickTag = MouseEvent - EventType 'ContextmenuTag = MouseEvent - EventType 'DblclickTag = MouseEvent - EventType 'DragTag = MouseEvent - EventType 'DragendTag = MouseEvent - EventType 'DragenterTag = MouseEvent - EventType 'DragleaveTag = MouseEvent - EventType 'DragoverTag = MouseEvent - EventType 'DragstartTag = MouseEvent - EventType 'DropTag = MouseEvent - EventType 'ErrorTag = UIEvent - EventType 'FocusTag = FocusEvent - EventType 'InputTag = DOM.Event - EventType 'InvalidTag = DOM.Event - EventType 'KeydownTag = KeyboardEvent - EventType 'KeypressTag = KeyboardEvent - EventType 'KeyupTag = KeyboardEvent - EventType 'LoadTag = UIEvent - EventType 'MousedownTag = MouseEvent - EventType 'MouseenterTag = MouseEvent - EventType 'MouseleaveTag = MouseEvent - EventType 'MousemoveTag = MouseEvent - EventType 'MouseoutTag = MouseEvent - EventType 'MouseoverTag = MouseEvent - EventType 'MouseupTag = MouseEvent - EventType 'MousewheelTag = MouseEvent - EventType 'ScrollTag = UIEvent - EventType 'SelectTag = UIEvent - EventType 'SubmitTag = DOM.Event - EventType 'WheelTag = WheelEvent - EventType 'BeforecutTag = DOM.Event - EventType 'CutTag = DOM.Event - EventType 'BeforecopyTag = DOM.Event - EventType 'CopyTag = DOM.Event - EventType 'BeforepasteTag = DOM.Event - EventType 'PasteTag = DOM.Event - EventType 'ResetTag = DOM.Event - EventType 'SearchTag = DOM.Event - EventType 'SelectstartTag = DOM.Event - EventType 'TouchstartTag = TouchEvent - EventType 'TouchmoveTag = TouchEvent - EventType 'TouchendTag = TouchEvent - EventType 'TouchcancelTag = TouchEvent - -onEventName :: IsElement e => EventName en -> e -> EventM e (EventType en) () -> IO (IO ()) -onEventName en e = case en of - Abort -> on e E.abort - Blur -> on e E.blurEvent - Change -> on e E.change - Click -> on e E.click - Contextmenu -> on e E.contextMenu - Dblclick -> on e E.dblClick - Drag -> on e E.drag - Dragend -> on e E.dragEnd - Dragenter -> on e E.dragEnter - Dragleave -> on e E.dragLeave - Dragover -> on e E.dragOver - Dragstart -> on e E.dragStart - Drop -> on e E.drop - Error -> on e E.error - Focus -> on e E.focusEvent - Input -> on e E.input - Invalid -> on e E.invalid - Keydown -> on e E.keyDown - Keypress -> on e E.keyPress - Keyup -> on e E.keyUp - Load -> on e E.load - Mousedown -> on e E.mouseDown - Mouseenter -> on e E.mouseEnter - Mouseleave -> on e E.mouseLeave - Mousemove -> on e E.mouseMove - Mouseout -> on e E.mouseOut - Mouseover -> on e E.mouseOver - Mouseup -> on e E.mouseUp - Mousewheel -> on e E.mouseWheel - Scroll -> on e E.scroll - Select -> on e E.select - Submit -> on e E.submit - Wheel -> on e E.wheel - Beforecut -> on e E.beforeCut - Cut -> on e E.cut - Beforecopy -> on e E.beforeCopy - Copy -> on e E.copy - Beforepaste -> on e E.beforePaste - Paste -> on e E.paste - Reset -> on e E.reset - Search -> on e E.search - Selectstart -> on e E.selectStart - Touchstart -> on e E.touchStart - Touchmove -> on e E.touchMove - Touchend -> on e E.touchEnd - Touchcancel -> on e E.touchCancel - -newtype EventResult en = EventResult { unEventResult :: EventResultType en } - -type family EventResultType (en :: EventTag) :: * where - EventResultType 'ClickTag = () - EventResultType 'DblclickTag = () - EventResultType 'KeypressTag = Int - EventResultType 'KeydownTag = Int - EventResultType 'KeyupTag = Int - EventResultType 'ScrollTag = Int - EventResultType 'MousemoveTag = (Int, Int) - EventResultType 'MousedownTag = (Int, Int) - EventResultType 'MouseupTag = (Int, Int) - EventResultType 'MouseenterTag = () - EventResultType 'MouseleaveTag = () - EventResultType 'FocusTag = () - EventResultType 'BlurTag = () - EventResultType 'ChangeTag = () - EventResultType 'DragTag = () - EventResultType 'DragendTag = () - EventResultType 'DragenterTag = () - EventResultType 'DragleaveTag = () - EventResultType 'DragoverTag = () - EventResultType 'DragstartTag = () - EventResultType 'DropTag = () - EventResultType 'AbortTag = () - EventResultType 'ContextmenuTag = () - EventResultType 'ErrorTag = () - EventResultType 'InputTag = () - EventResultType 'InvalidTag = () - EventResultType 'LoadTag = () - EventResultType 'MouseoutTag = () - EventResultType 'MouseoverTag = () - EventResultType 'SelectTag = () - EventResultType 'SubmitTag = () - EventResultType 'BeforecutTag = () - EventResultType 'CutTag = () - EventResultType 'BeforecopyTag = () - EventResultType 'CopyTag = () - EventResultType 'BeforepasteTag = () - EventResultType 'PasteTag = () - EventResultType 'ResetTag = () - EventResultType 'SearchTag = () - EventResultType 'SelectstartTag = () - EventResultType 'TouchstartTag = () - EventResultType 'TouchmoveTag = () - EventResultType 'TouchendTag = () - EventResultType 'TouchcancelTag = () - EventResultType 'MousewheelTag = () - EventResultType 'WheelTag = () - -wrapDomEventsMaybe :: (Functor (Event t), IsElement e, MonadIO m, MonadSample t m, MonadReflexCreateTrigger t m, Reflex t, HasPostGui t h m) => e -> (forall en. EventName en -> EventM e (EventType en) (Maybe (f en))) -> m (EventSelector t (WrapArg f EventName)) -wrapDomEventsMaybe element handlers = do - postGui <- askPostGui - runWithActions <- askRunWithActions - e <- newFanEventWithTrigger $ \(WrapArg en) et -> do - unsubscribe <- onEventName en element $ do - mv <- handlers en - forM_ mv $ \v -> liftIO $ postGui $ runWithActions [et :=> Identity v] - return $ liftIO $ do - unsubscribe - return $! e - -getKeyEvent :: EventM e KeyboardEvent Int -getKeyEvent = do - e <- event - which <- getWhich e - if which /= 0 then return which else do - charCode <- getCharCode e - if charCode /= 0 then return charCode else - getKeyCode e - -getMouseEventCoords :: EventM e MouseEvent (Int, Int) -getMouseEventCoords = do - e <- event - bisequence (getX e, getY e) - -defaultDomEventHandler :: IsElement e => e -> EventName en -> EventM e (EventType en) (Maybe (EventResult en)) -defaultDomEventHandler e evt = liftM (Just . EventResult) $ case evt of - Click -> return () - Dblclick -> return () - Keypress -> getKeyEvent - Scroll -> getScrollTop e - Keydown -> getKeyEvent - Keyup -> getKeyEvent - Mousemove -> getMouseEventCoords - Mouseup -> getMouseEventCoords - Mousedown -> getMouseEventCoords - Mouseenter -> return () - Mouseleave -> return () - Focus -> return () - Blur -> return () - Change -> return () - Drag -> return () - Dragend -> return () - Dragenter -> return () - Dragleave -> return () - Dragover -> return () - Dragstart -> return () - Drop -> return () - Abort -> return () - Contextmenu -> return () - Error -> return () - Input -> return () - Invalid -> return () - Load -> return () - Mouseout -> return () - Mouseover -> return () - Select -> return () - Submit -> return () - Beforecut -> return () - Cut -> return () - Beforecopy -> return () - Copy -> return () - Beforepaste -> return () - Paste -> return () - Reset -> return () - Search -> return () - Selectstart -> return () - Touchstart -> return () - Touchmove -> return () - Touchend -> return () - Touchcancel -> return () - Mousewheel -> return () - Wheel -> return () - -wrapElement :: forall t h m. (Functor (Event t), MonadIO m, MonadSample t m, MonadReflexCreateTrigger t m, Reflex t, HasPostGui t h m) => (forall en. Element -> EventName en -> EventM Element (EventType en) (Maybe (EventResult en))) -> Element -> m (El t) -wrapElement eh e = do - es <- wrapDomEventsMaybe e $ eh e - return $ El e es - -{-# INLINABLE elStopPropagationNS #-} -elStopPropagationNS :: (MonadWidget t m, IsEvent (EventType en)) => Maybe String -> String -> EventName en -> m a -> m a -elStopPropagationNS mns elementTag evt child = do - (e, result) <- buildElementNS mns elementTag (Map.empty :: Map String String) child - _ <- liftIO $ onEventName evt e stopPropagation - return result - -{-# INLINABLE elWith #-} -elWith :: (MonadWidget t m, Attributes m attrs) => String -> ElConfig attrs -> m a -> m a -elWith elementTag cfg child = do - (_, result) <- buildElementNS (cfg ^. namespace) elementTag (cfg ^. attributes) child - return result - -{-# INLINABLE elWith' #-} -elWith' :: (MonadWidget t m, Attributes m attrs) => String -> ElConfig attrs -> m a -> m (El t, a) -elWith' elementTag cfg child = do - (e, result) <- buildElementNS (cfg ^. namespace) elementTag (cfg ^. attributes) child - e' <- wrapElement defaultDomEventHandler e - return (e', result) - -{-# INLINABLE emptyElWith #-} -emptyElWith :: (MonadWidget t m, Attributes m attrs) => String -> ElConfig attrs -> m () -emptyElWith elementTag cfg = do - _ <- buildEmptyElementNS (cfg ^. namespace) elementTag (cfg ^. attributes) - return () - -{-# INLINABLE emptyElWith' #-} -emptyElWith' :: (MonadWidget t m, Attributes m attrs) => String -> ElConfig attrs -> m (El t) -emptyElWith' elementTag cfg = do - wrapElement defaultDomEventHandler =<< buildEmptyElementNS (cfg ^. namespace) elementTag (cfg ^. attributes) - -{-# INLINABLE elDynAttrNS' #-} -elDynAttrNS' :: forall t m a. MonadWidget t m => Maybe String -> String -> Dynamic t (Map String String) -> m a -> m (El t, a) -elDynAttrNS' mns elementTag attrs = elWith' elementTag $ - def & namespace .~ mns - & elConfig_attributes .~ attrs - -{-# INLINABLE elDynAttr' #-} -elDynAttr' :: forall t m a. MonadWidget t m => String -> Dynamic t (Map String String) -> m a -> m (El t, a) -elDynAttr' elementTag attrs = elWith' elementTag $ def & elConfig_attributes .~ attrs - -{-# INLINABLE elAttr #-} -elAttr :: forall t m a. MonadWidget t m => String -> Map String String -> m a -> m a -elAttr elementTag attrs = elWith elementTag $ def & attributes .~ attrs - -{-# INLINABLE el' #-} -el' :: forall t m a. MonadWidget t m => String -> m a -> m (El t, a) -el' elementTag = elWith' elementTag def - -{-# INLINABLE elAttr' #-} -elAttr' :: forall t m a. MonadWidget t m => String -> Map String String -> m a -> m (El t, a) -elAttr' elementTag attrs = elWith' elementTag $ def & attributes .~ attrs - -{-# INLINABLE elDynAttr #-} -elDynAttr :: forall t m a. MonadWidget t m => String -> Dynamic t (Map String String) -> m a -> m a -elDynAttr elementTag attrs = elWith elementTag $ def & elConfig_attributes .~ attrs - -{-# INLINABLE el #-} -el :: forall t m a. MonadWidget t m => String -> m a -> m a -el elementTag = elWith elementTag def - -elClass :: forall t m a. MonadWidget t m => String -> String -> m a -> m a -elClass elementTag c = elWith elementTag $ def & attributes .~ "class" =: c - --------------------------------------------------------------------------------- --- Copied and pasted from Reflex.Widget.Class --------------------------------------------------------------------------------- - --- | Create a dynamically-changing set of widgets from a Dynamic key/value map. --- Unlike the 'withKey' variants, the child widgets are insensitive to which key they're associated with. -list :: (MonadWidget t m, Ord k) => Dynamic t (Map k v) -> (Dynamic t v -> m a) -> m (Dynamic t (Map k a)) -list dm mkChild = listWithKey dm (\_ dv -> mkChild dv) - --- | Create a dynamically-changing set of widgets from a Dynamic list. -simpleList :: MonadWidget t m => Dynamic t [v] -> (Dynamic t v -> m a) -> m (Dynamic t [a]) -simpleList xs mkChild = mapDyn (map snd . Map.toList) =<< flip list mkChild =<< mapDyn (Map.fromList . zip [(1::Int)..]) xs - -elDynHtml' :: MonadWidget t m => String -> Dynamic t String -> m (El t) -elDynHtml' elementTag html = do - e <- buildEmptyElement elementTag (Map.empty :: Map String String) - schedulePostBuild $ setInnerHTML e . Just =<< sample (current html) - addVoidAction $ fmap (setInnerHTML e . Just) $ updated html - wrapElement defaultDomEventHandler e - -elDynHtmlAttr' :: MonadWidget t m => String -> Map String String -> Dynamic t String -> m (El t) -elDynHtmlAttr' elementTag attrs html = do - e <- buildEmptyElement elementTag attrs - schedulePostBuild $ setInnerHTML e . Just =<< sample (current html) - addVoidAction $ fmap (setInnerHTML e . Just) $ updated html - wrapElement defaultDomEventHandler e - -data Link t - = Link { _link_clicked :: Event t () - } - -class HasAttributes a where - type Attrs a :: * - attributes :: Lens' a (Attrs a) - -instance HasAttributes (ElConfig attrs) where - type Attrs (ElConfig attrs) = attrs - attributes = elConfig_attributes - -class HasNamespace a where - namespace :: Lens' a (Maybe String) - -instance HasNamespace (ElConfig attrs) where - namespace = elConfig_namespace - -class HasDomEvent t a where - domEvent :: EventName en -> a -> Event t (EventResultType en) - -instance Reflex t => HasDomEvent t (El t) where - domEvent en e = fmap unEventResult $ Reflex.select (_el_events e) (WrapArg en) - -linkClass :: MonadWidget t m => String -> String -> m (Link t) -linkClass s c = do - (l,_) <- elAttr' "a" ("class" =: c) $ text s - return $ Link $ domEvent Click l - -link :: MonadWidget t m => String -> m (Link t) -link s = linkClass s "" - -button :: MonadWidget t m => String -> m (Event t ()) -button s = do - (e, _) <- elAttr' "button" (Map.singleton "type" "button") $ text s - return $ domEvent Click e - -newtype Workflow t m a = Workflow { unWorkflow :: m (a, Event t (Workflow t m a)) } - -workflow :: forall t m a. MonadWidget t m => Workflow t m a -> m (Dynamic t a) -workflow w0 = do - rec eResult <- widgetHold (unWorkflow w0) $ fmap unWorkflow $ switch $ fmap snd $ current eResult - mapDyn fst eResult - -workflowView :: forall t m a. MonadWidget t m => Workflow t m a -> m (Event t a) -workflowView w0 = do - rec eResult <- dyn =<< mapDyn unWorkflow =<< holdDyn w0 eReplace - eReplace <- liftM switch $ hold never $ fmap snd eResult - return $ fmap fst eResult - -mapWorkflow :: (MonadWidget t m) => (a -> b) -> Workflow t m a -> Workflow t m b -mapWorkflow f (Workflow x) = Workflow (fmap (\(v,e) -> (f v, fmap (mapWorkflow f) e)) x) - -divClass :: forall t m a. MonadWidget t m => String -> m a -> m a -divClass = elClass "div" - -dtdd :: forall t m a. MonadWidget t m => String -> m a -> m a -dtdd h w = do - el "dt" $ text h - el "dd" $ w - -blank :: forall t m. MonadWidget t m => m () -blank = return () - --- | A widget to display a table with static columns and dynamic rows. -tableDynAttr :: forall t m r k v. (MonadWidget t m, Show k, Ord k) - => String -- ^ Class applied to element - -> [(String, k -> Dynamic t r -> m v)] -- ^ Columns of (header, row key -> row value -> child widget) - -> Dynamic t (Map k r) -- ^ Map from row key to row value - -> (k -> m (Dynamic t (Map String String))) -- ^ Function to compute element attributes from row key - -> m (Dynamic t (Map k (El t, [v]))) -- ^ Map from row key to (El, list of widget return values) -tableDynAttr klass cols dRows rowAttrs = elAttr "div" (Map.singleton "style" "zoom: 1; overflow: auto; background: white;") $ do - elAttr "table" (Map.singleton "class" klass) $ do - el "thead" $ el "tr" $ do - mapM_ (\(h, _) -> el "th" $ text h) cols - el "tbody" $ do - listWithKey dRows (\k r -> do - dAttrs <- rowAttrs k - elDynAttr' "tr" dAttrs $ mapM (\x -> el "td" $ snd x k r) cols) - ---TODO preselect a tab on open --- | A widget to construct a tabbed view that shows only one of its child widgets at a time. --- Creates a header bar containing a
    with one
  • per child; clicking a
  • displays --- the corresponding child and hides all others. -tabDisplay :: forall t m k. (MonadFix m, MonadWidget t m, Show k, Ord k) - => String -- ^ Class applied to
      element - -> String -- ^ Class applied to currently active
    • element - -> Map k (String, m ()) -- ^ Map from (arbitrary) key to (tab label, child widget) - -> m () -tabDisplay ulClass activeClass tabItems = do - rec dCurrentTab <- holdDyn Nothing (updated dTabClicks) - dTabClicks :: Dynamic t (Maybe k) <- elAttr "ul" (Map.singleton "class" ulClass) $ do - tabClicksList :: [Event t k] <- (liftM Map.elems) $ imapM (\k (s,_) -> headerBarLink s k =<< mapDyn (== (Just k)) dCurrentTab) tabItems - let eTabClicks :: Event t k = leftmost tabClicksList - holdDyn Nothing $ fmap Just eTabClicks :: m (Dynamic t (Maybe k)) - divClass "" $ do - let dTabs :: Dynamic t (Map k (String, m ())) = constDyn tabItems - _ <- listWithKey dTabs (\k dTab -> do - dAttrs <- mapDyn (\sel -> do - let t1 = listToMaybe $ Map.keys tabItems - if sel == Just k || (sel == Nothing && t1 == Just k) then Map.empty else Map.singleton "style" "display:none;") dCurrentTab - elDynAttr "div" dAttrs $ dyn =<< mapDyn snd dTab) - return () - where - headerBarLink :: (MonadWidget t m, Ord k) => String -> k -> Dynamic t Bool -> m (Event t k) - headerBarLink x k dBool = do - dAttributes <- mapDyn (\b -> if b then Map.singleton "class" activeClass else Map.empty) dBool - elDynAttr "li" dAttributes $ do - a <- link x - return $ fmap (const k) (_link_clicked a) - --- | Place an element into the DOM and wrap it with Reflex event handlers. Note: undefined behavior may result if the element is placed multiple times, removed from the DOM after being placed, or in other situations. Don't use this unless you understand the internals of MonadWidget. -unsafePlaceElement :: MonadWidget t m => Element -> m (El t) -unsafePlaceElement e = do - p <- askParent - _ <- appendChild p $ Just e - wrapElement defaultDomEventHandler e - -deriveGEq ''EventName -deriveGCompare ''EventName - --------------------------------------------------------------------------------- --- Deprecated functions - -{-# DEPRECATED _el_clicked "Use `domEvent Click` instead" #-} -_el_clicked :: Reflex t => El t -> Event t () -_el_clicked = domEvent Click - -{-# DEPRECATED _el_keypress "Use `domEvent Keypress` instead" #-} -_el_keypress :: Reflex t => El t -> Event t Int -_el_keypress = domEvent Keypress - -{-# DEPRECATED _el_scrolled "Use `domEvent Scroll` instead" #-} -_el_scrolled :: Reflex t => El t -> Event t Int -_el_scrolled = domEvent Scroll diff --git a/src/Reflex/Dom/Widget/Input.hs b/src/Reflex/Dom/Widget/Input.hs deleted file mode 100644 --- a/src/Reflex/Dom/Widget/Input.hs +++ /dev/null @@ -1,322 +0,0 @@ -{-# LANGUAGE ConstraintKinds, TypeFamilies, FlexibleContexts, DataKinds, GADTs, ScopedTypeVariables, FlexibleInstances, RecursiveDo, TemplateHaskell #-} -module Reflex.Dom.Widget.Input (module Reflex.Dom.Widget.Input, def, (&), (.~)) where - -import Prelude - -import Reflex.Dom.Class -import Reflex.Dom.Widget.Basic - -import Reflex -import Reflex.Host.Class -import GHCJS.DOM.HTMLInputElement as Input -import GHCJS.DOM.HTMLTextAreaElement as TextArea -import GHCJS.DOM.Element hiding (error) -import GHCJS.DOM.HTMLSelectElement as Select -import GHCJS.DOM.EventM -import GHCJS.DOM.File -import qualified GHCJS.DOM.FileList as FileList -import Data.Monoid -import Data.Map as Map -import Control.Lens -import Control.Monad hiding (forM_) -import Control.Monad.IO.Class -import Data.Default -import Data.Maybe -import Safe -import Data.Dependent.Sum (DSum (..)) - -data TextInput t - = TextInput { _textInput_value :: Dynamic t String - , _textInput_input :: Event t String - , _textInput_keypress :: Event t Int - , _textInput_keydown :: Event t Int - , _textInput_keyup :: Event t Int - , _textInput_hasFocus :: Dynamic t Bool - , _textInput_element :: HTMLInputElement - } - -data TextInputConfig t - = TextInputConfig { _textInputConfig_inputType :: String - , _textInputConfig_initialValue :: String - , _textInputConfig_setValue :: Event t String - , _textInputConfig_attributes :: Dynamic t (Map String String) - } - -instance Reflex t => Default (TextInputConfig t) where - def = TextInputConfig { _textInputConfig_inputType = "text" - , _textInputConfig_initialValue = "" - , _textInputConfig_setValue = never - , _textInputConfig_attributes = constDyn mempty - } - --- | Create an input whose value is a string. By default, the "type" attribute is set to "text", but it can be changed using the _textInputConfig_inputType field. Note that only types for which the value is always a string will work - types whose value may be null will not work properly with this widget. -textInput :: MonadWidget t m => TextInputConfig t -> m (TextInput t) -textInput (TextInputConfig inputType initial eSetValue dAttrs) = do - e <- liftM castToHTMLInputElement $ buildEmptyElement "input" =<< mapDyn (Map.insert "type" inputType) dAttrs - Input.setValue e $ Just initial - performEvent_ $ fmap (Input.setValue e . Just) eSetValue - eChange <- wrapDomEvent e (`on` input) $ fromMaybe "" <$> Input.getValue e - postGui <- askPostGui - runWithActions <- askRunWithActions - eChangeFocus <- newEventWithTrigger $ \eChangeFocusTrigger -> do - unsubscribeOnblur <- on e blurEvent $ liftIO $ do - postGui $ runWithActions [eChangeFocusTrigger :=> Identity False] - unsubscribeOnfocus <- on e focusEvent $ liftIO $ do - postGui $ runWithActions [eChangeFocusTrigger :=> Identity True] - return $ liftIO $ unsubscribeOnblur >> unsubscribeOnfocus - dFocus <- holdDyn False eChangeFocus - eKeypress <- wrapDomEvent e (`on` keyPress) getKeyEvent - eKeydown <- wrapDomEvent e (`on` keyDown) getKeyEvent - eKeyup <- wrapDomEvent e (`on` keyUp) getKeyEvent - dValue <- holdDyn initial $ leftmost [eSetValue, eChange] - return $ TextInput dValue eChange eKeypress eKeydown eKeyup dFocus e - -textInputGetEnter :: Reflex t => TextInput t -> Event t () -textInputGetEnter i = fmapMaybe (\n -> if n == keycodeEnter then Just () else Nothing) $ _textInput_keypress i - -data TextAreaConfig t - = TextAreaConfig { _textAreaConfig_initialValue :: String - , _textAreaConfig_setValue :: Event t String - , _textAreaConfig_attributes :: Dynamic t (Map String String) - } - -instance Reflex t => Default (TextAreaConfig t) where - def = TextAreaConfig { _textAreaConfig_initialValue = "" - , _textAreaConfig_setValue = never - , _textAreaConfig_attributes = constDyn mempty - } - -data TextArea t - = TextArea { _textArea_value :: Dynamic t String - , _textArea_input :: Event t String - , _textArea_element :: HTMLTextAreaElement - , _textArea_hasFocus :: Dynamic t Bool - , _textArea_keypress :: Event t Int - } - -textArea :: MonadWidget t m => TextAreaConfig t -> m (TextArea t) -textArea (TextAreaConfig initial eSet attrs) = do - e <- liftM castToHTMLTextAreaElement $ buildEmptyElement "textarea" attrs - TextArea.setValue e $ Just initial - postGui <- askPostGui - runWithActions <- askRunWithActions - eChangeFocus <- newEventWithTrigger $ \eChangeFocusTrigger -> do - unsubscribeOnblur <- on e blurEvent $ liftIO $ do - postGui $ runWithActions [eChangeFocusTrigger :=> Identity False] - unsubscribeOnfocus <- on e focusEvent $ liftIO $ do - postGui $ runWithActions [eChangeFocusTrigger :=> Identity True] - return $ liftIO $ unsubscribeOnblur >> unsubscribeOnfocus - performEvent_ $ fmap (TextArea.setValue e . Just) eSet - f <- holdDyn False eChangeFocus - ev <- wrapDomEvent e (`on` input) $ fromMaybe "" <$> TextArea.getValue e - v <- holdDyn initial $ leftmost [eSet, ev] - eKeypress <- wrapDomEvent e (`on` keyPress) getKeyEvent - return $ TextArea v ev e f eKeypress - -data CheckboxConfig t - = CheckboxConfig { _checkboxConfig_setValue :: Event t Bool - , _checkboxConfig_attributes :: Dynamic t (Map String String) - } - -instance Reflex t => Default (CheckboxConfig t) where - def = CheckboxConfig { _checkboxConfig_setValue = never - , _checkboxConfig_attributes = constDyn mempty - } - -data Checkbox t - = Checkbox { _checkbox_value :: Dynamic t Bool - , _checkbox_change :: Event t Bool - } - ---TODO: Make attributes possibly dynamic --- | Create an editable checkbox --- Note: if the "type" or "checked" attributes are provided as attributes, they will be ignored -checkbox :: MonadWidget t m => Bool -> CheckboxConfig t -> m (Checkbox t) -checkbox checked config = do - attrs <- mapDyn (\c -> Map.insert "type" "checkbox" $ (if checked then Map.insert "checked" "checked" else Map.delete "checked") c) (_checkboxConfig_attributes config) - e <- liftM castToHTMLInputElement $ buildEmptyElement "input" attrs - eClick <- wrapDomEvent e (`on` click) $ Input.getChecked e - performEvent_ $ fmap (\v -> Input.setChecked e $! v) $ _checkboxConfig_setValue config - dValue <- holdDyn checked $ leftmost [_checkboxConfig_setValue config, eClick] - return $ Checkbox dValue eClick - -checkboxView :: MonadWidget t m => Dynamic t (Map String String) -> Dynamic t Bool -> m (Event t Bool) -checkboxView dAttrs dValue = do - e <- liftM castToHTMLInputElement $ buildEmptyElement "input" =<< mapDyn (Map.insert "type" "checkbox") dAttrs - eClicked <- wrapDomEvent e (`on` click) $ do - preventDefault - Input.getChecked e - schedulePostBuild $ do - v <- sample $ current dValue - when v $ Input.setChecked e True - performEvent_ $ fmap (\v -> Input.setChecked e $! v) $ updated dValue - return eClicked - -data FileInput t - = FileInput { _fileInput_value :: Dynamic t [File] - , _fileInput_element :: HTMLInputElement - } - -data FileInputConfig t - = FileInputConfig { _fileInputConfig_attributes :: Dynamic t (Map String String) - } - -instance Reflex t => Default (FileInputConfig t) where - def = FileInputConfig { _fileInputConfig_attributes = constDyn mempty - } - -fileInput :: MonadWidget t m => FileInputConfig t -> m (FileInput t) -fileInput (FileInputConfig dAttrs) = do - e <- liftM castToHTMLInputElement $ buildEmptyElement "input" =<< mapDyn (Map.insert "type" "file") dAttrs - eChange <- wrapDomEvent e (flip on change) $ do - Just files <- getFiles e - len <- FileList.getLength files - mapM (liftM (fromMaybe (error "fileInput: fileListItem returned null")) . FileList.item files) $ init [0..len] - dValue <- holdDyn [] eChange - return $ FileInput dValue e - -data Dropdown t k - = Dropdown { _dropdown_value :: Dynamic t k - , _dropdown_change :: Event t k - } - -data DropdownConfig t k - = DropdownConfig { _dropdownConfig_setValue :: Event t k - , _dropdownConfig_attributes :: Dynamic t (Map String String) - } - -instance (Reflex t, Ord k, Show k, Read k) => Default (DropdownConfig t k) where - def = DropdownConfig { _dropdownConfig_setValue = never - , _dropdownConfig_attributes = constDyn mempty - } - ---TODO: We should allow the user to specify an ordering instead of relying on the ordering of the Map ---TODO: Get rid of Show k and Read k by indexing the possible values ourselves --- | Create a dropdown box --- The first argument gives the initial value of the dropdown; if it is not present in the map of options provided, it will be added with an empty string as its text -dropdown :: forall k t m. (MonadWidget t m, Ord k, Show k, Read k) => k -> Dynamic t (Map k String) -> DropdownConfig t k -> m (Dropdown t k) -dropdown k0 options (DropdownConfig setK attrs) = do - (eRaw, _) <- elDynAttr' "select" attrs $ do - optionsWithDefault <- mapDyn (`Map.union` (k0 =: "")) options - listWithKey optionsWithDefault $ \k v -> do - elAttr "option" ("value" =: show k <> if k == k0 then "selected" =: "selected" else mempty) $ dynText v - let e = castToHTMLSelectElement $ _el_element eRaw - performEvent_ $ fmap (Select.setValue e . Just . show) setK - eChange <- wrapDomEvent e (`on` change) $ do - kStr <- fromMaybe "" <$> Select.getValue e - return $ readMay kStr - let readKey opts mk = fromMaybe k0 $ do - k <- mk - guard $ Map.member k opts - return k - dValue <- combineDyn readKey options =<< holdDyn (Just k0) (leftmost [eChange, fmap Just setK]) - return $ Dropdown dValue (attachDynWith readKey options eChange) - -liftM concat $ mapM makeLenses - [ ''TextAreaConfig - , ''TextArea - , ''TextInputConfig - , ''TextInput - , ''DropdownConfig - , ''Dropdown - , ''CheckboxConfig - , ''Checkbox - ] - -instance HasAttributes (TextAreaConfig t) where - type Attrs (TextAreaConfig t) = Dynamic t (Map String String) - attributes = textAreaConfig_attributes - -instance HasAttributes (TextInputConfig t) where - type Attrs (TextInputConfig t) = Dynamic t (Map String String) - attributes = textInputConfig_attributes - -instance HasAttributes (DropdownConfig t k) where - type Attrs (DropdownConfig t k) = Dynamic t (Map String String) - attributes = dropdownConfig_attributes - -instance HasAttributes (CheckboxConfig t) where - type Attrs (CheckboxConfig t) = Dynamic t (Map String String) - attributes = checkboxConfig_attributes - -class HasSetValue a where - type SetValue a :: * - setValue :: Lens' a (SetValue a) - -instance HasSetValue (TextAreaConfig t) where - type SetValue (TextAreaConfig t) = Event t String - setValue = textAreaConfig_setValue - -instance HasSetValue (TextInputConfig t) where - type SetValue (TextInputConfig t) = Event t String - setValue = textInputConfig_setValue - -instance HasSetValue (DropdownConfig t k) where - type SetValue (DropdownConfig t k) = Event t k - setValue = dropdownConfig_setValue - -instance HasSetValue (CheckboxConfig t) where - type SetValue (CheckboxConfig t) = Event t Bool - setValue = checkboxConfig_setValue - -class HasValue a where - type Value a :: * - value :: a -> Value a - -instance HasValue (TextArea t) where - type Value (TextArea t) = Dynamic t String - value = _textArea_value - -instance HasValue (TextInput t) where - type Value (TextInput t) = Dynamic t String - value = _textInput_value - -instance HasValue (FileInput t) where - type Value (FileInput t) = Dynamic t [File] - value = _fileInput_value - -instance HasValue (Dropdown t k) where - type Value (Dropdown t k) = Dynamic t k - value = _dropdown_value - -instance HasValue (Checkbox t) where - type Value (Checkbox t) = Dynamic t Bool - value = _checkbox_value - -{- -type family Controller sm t a where - Controller Edit t a = (a, Event t a) -- Initial value and setter - Controller View t a = Dynamic t a -- Value (always) - -type family Output sm t a where - Output Edit t a = Dynamic t a -- Value (always) - Output View t a = Event t a -- Requested changes - -data CheckboxConfig sm t - = CheckboxConfig { _checkbox_input :: Controller sm t Bool - , _checkbox_attributes :: Attributes - } - -instance Reflex t => Default (CheckboxConfig Edit t) where - def = CheckboxConfig (False, never) mempty - -data Checkbox sm t - = Checkbox { _checkbox_output :: Output sm t Bool - } - -data StateMode = Edit | View - ---TODO: There must be a more generic way to get this witness and allow us to case on the type-level StateMode -data StateModeWitness (sm :: StateMode) where - EditWitness :: StateModeWitness Edit - ViewWitness :: StateModeWitness View - -class HasStateModeWitness (sm :: StateMode) where - stateModeWitness :: StateModeWitness sm - -instance HasStateModeWitness Edit where - stateModeWitness = EditWitness - -instance HasStateModeWitness View where - stateModeWitness = ViewWitness --} diff --git a/src/Reflex/Dom/Widget/Lazy.hs b/src/Reflex/Dom/Widget/Lazy.hs deleted file mode 100644 --- a/src/Reflex/Dom/Widget/Lazy.hs +++ /dev/null @@ -1,139 +0,0 @@ -{-# LANGUAGE RecursiveDo, ScopedTypeVariables #-} - -module Reflex.Dom.Widget.Lazy where - -import Reflex -import Reflex.Dom.Class -import Reflex.Dom.Widget.Basic - -import Control.Monad -import Control.Monad.IO.Class -import Data.Fixed -import Data.Monoid -import qualified Data.Map as Map -import Data.Map (Map) -import GHCJS.DOM.Element -import Data.Maybe -import Data.Int - --- |A list view for long lists. Creates a scrollable element and only renders child row elements near the current scroll position. -virtualListWithSelection :: forall t m k v. (MonadWidget t m, Ord k) - => Dynamic t Int -- ^ The height of the visible region in pixels - -> Int -- ^ The height of each row in pixels - -> Dynamic t Int -- ^ The total number of items - -> Int -- ^ The index of the row to scroll to on initialization - -> Event t Int -- ^ An 'Event' containing a row index. Used to scroll to the given index. - -> String -- ^ The element tag for the list - -> Dynamic t (Map String String) -- ^ The attributes of the list - -> String -- ^ The element tag for a row - -> Dynamic t (Map String String) -- ^ The attributes of each row - -> (k -> Dynamic t (Maybe v) -> Dynamic t Bool -> m ()) -- ^ The row child element builder - -> Dynamic t (Map k v) -- ^ The 'Map' of items - -> (Int -> k) -- ^ Index to Key function, used to determine position of Map elements - -> m (Dynamic t (Int, Int), Event t k) -- ^ A tuple containing: a 'Dynamic' of the index (based on the current scroll position) and number of items currently being rendered, and an 'Event' of the selected key -virtualListWithSelection heightPx rowPx maxIndex i0 setI listTag listAttrs rowTag rowAttrs itemBuilder items indexToKey = do - totalHeightStyle <- mapDyn (toHeightStyle . (*) rowPx) maxIndex - containerStyle <- mapDyn toContainer heightPx - viewportStyle <- mapDyn toViewport heightPx - rec (container, sel) <- elDynAttr "div" containerStyle $ elDynAttr' "div" viewportStyle $ do - currentTop <- mapDyn (listWrapperStyle . fst) window - (_, lis) <- elDynAttr "div" totalHeightStyle $ tagWrapper listTag listAttrs currentTop $ selectViewListWithKey_ selected itemsInWindow $ \k v s -> do - (li,_) <- tagWrapper rowTag rowAttrs (constDyn $ toHeightStyle rowPx) $ itemBuilder k v s - return $ fmap (const k) (domEvent Click li) - return lis - selected <- holdDyn (indexToKey i0) sel - pb <- getPostBuild - scrollPosition <- holdDyn 0 $ leftmost [ domEvent Scroll container - , fmap (const (i0 * rowPx)) pb - ] - window <- combineDyn (\h -> findWindow h rowPx) heightPx scrollPosition - itemsInWindow <- combineDyn (\(_,(idx,num)) is -> Map.fromList $ map (\i -> let ix = indexToKey i in (ix, Map.lookup ix is)) [idx .. idx + num]) window items - postBuild <- getPostBuild - performEvent_ $ fmap (\i -> liftIO $ setScrollTop (_el_element container) (i * rowPx)) $ leftmost [setI, fmap (const i0) postBuild] - indexAndLength <- mapDyn snd window - return (indexAndLength, sel) - where - toStyleAttr m = "style" =: (Map.foldWithKey (\k v s -> k <> ":" <> v <> ";" <> s) "" m) - toViewport h = toStyleAttr $ "overflow" =: "auto" <> "position" =: "absolute" <> - "left" =: "0" <> "right" =: "0" <> "height" =: (show h <> "px") - toContainer h = toStyleAttr $ "position" =: "relative" <> "height" =: (show h <> "px") - listWrapperStyle t = toStyleAttr $ "position" =: "relative" <> - "top" =: (show t <> "px") - toHeightStyle h = toStyleAttr ("height" =: (show h <> "px") <> "overflow" =: "hidden") - tagWrapper elTag attrs attrsOverride c = do - attrs' <- combineDyn Map.union attrsOverride attrs - elDynAttr' elTag attrs' c - findWindow windowSize sizeIncrement startingPosition = - let (startingIndex, topOffsetPx) = startingPosition `divMod'` sizeIncrement - topPx = startingPosition - topOffsetPx - numItems = windowSize `div` sizeIncrement + 1 - preItems = min startingIndex numItems - in (topPx - preItems * sizeIncrement, (startingIndex - preItems, preItems + numItems * 2)) - -virtualList :: forall t m k v a. (MonadWidget t m, Ord k) - => Dynamic t Int -- ^ A 'Dynamic' of the visible region's height in pixels - -> Int -- ^ The fixed height of each row in pixels - -> Dynamic t Int -- ^ A 'Dynamic' of the total number of items - -> Int -- ^ The index of the row to scroll to on initialization - -> Event t Int -- ^ An 'Event' containing a row index. Used to scroll to the given index. - -> (k -> Int) -- ^ Key to Index function, used to position items. - -> Map k v -- ^ The initial 'Map' of items - -> Event t (Map k (Maybe v)) -- ^ The update 'Event'. Nothing values are removed from the list and Just values are added or updated. - -> (k -> v -> Event t v -> m a) -- ^ The row child element builder. - -> m (Dynamic t (Int, Int), Dynamic t (Map k a)) -- ^ A tuple containing: a 'Dynamic' of the index (based on the current scroll position) and number of items currently being rendered, and the 'Dynamic' list result -virtualList heightPx rowPx maxIndex i0 setI keyToIndex items0 itemsUpdate itemBuilder = do - virtualH <- mapDyn (mkVirtualHeight . (*) rowPx) maxIndex - containerStyle <- mapDyn mkContainer heightPx - viewportStyle <- mapDyn mkViewport heightPx - pb <- getPostBuild - rec (viewport, result) <- elDynAttr "div" containerStyle $ elDynAttr' "div" viewportStyle $ elDynAttr "div" virtualH $ - listWithKeyShallowDiff items0 itemsUpdate $ \k v e -> elAttr "div" (mkRow k) $ itemBuilder k v e - scrollPosition <- holdDyn 0 $ leftmost [ domEvent Scroll viewport - , fmap (const (i0 * rowPx)) pb - ] - window <- combineDyn (\h -> findWindow h rowPx) heightPx scrollPosition - performEvent_ $ fmap (\i -> liftIO $ setScrollTop (_el_element viewport) (i * rowPx)) $ leftmost [setI, fmap (const i0) pb] - return (nubDyn window, result) - where - toStyleAttr m = "style" =: (Map.foldWithKey (\k v s -> k <> ":" <> v <> ";" <> s) "" m) - mkViewport h = toStyleAttr $ "overflow" =: "auto" <> "position" =: "absolute" <> - "left" =: "0" <> "right" =: "0" <> "height" =: (show h <> "px") - mkContainer h = toStyleAttr $ "position" =: "relative" <> "height" =: (show h <> "px") - mkVirtualHeight h = let h' = h * rowPx - in toStyleAttr $ "height" =: (show h <> "px") <> - "overflow" =: "hidden" <> - "position" =: "relative" - mkRow k = toStyleAttr $ "height" =: (show rowPx <> "px") <> - "top" =: ((<>"px") $ show $ keyToIndex k * rowPx) <> - "position" =: "absolute" <> - "width" =: "100%" - findWindow windowSize sizeIncrement startingPosition = - let (startingIndex, topOffsetPx) = startingPosition `divMod'` sizeIncrement - numItems = (windowSize + sizeIncrement - 1) `div` sizeIncrement - in (startingIndex, numItems) - -virtualListBuffered - :: (Ord k, MonadWidget t m) - => Int - -> Dynamic t Int - -> Int - -> Dynamic t Int - -> Int - -> Event t Int - -> (k -> Int) - -> Map k v - -> Event t (Map k (Maybe v)) - -> (k -> v -> Event t v -> m a) - -> m (Event t (Int, Int), Dynamic t (Map k a)) -virtualListBuffered buffer heightPx rowPx maxIndex i0 setI keyToIndex items0 itemsUpdate itemBuilder = do - (win, m) <- virtualList heightPx rowPx maxIndex i0 setI keyToIndex items0 itemsUpdate itemBuilder - pb <- getPostBuild - let extendWin o l = (max 0 (o - l * (buffer-1) `div` 2), l * buffer) - rec let winHitEdge = fmapMaybe id $ attachWith (\(oldOffset, oldLimit) (winOffset, winLimit) -> - if winOffset > oldOffset && winOffset + winLimit < oldOffset + oldLimit - then Nothing - else Just (extendWin winOffset winLimit)) (current winBuffered) (updated win) - winBuffered <- holdDyn (0, 0) $ leftmost [ winHitEdge - , fmap (uncurry extendWin) $ tagDyn win pb - ] - return (updated winBuffered, m) diff --git a/src/Reflex/Dom/Widget/Resize.hs b/src/Reflex/Dom/Widget/Resize.hs deleted file mode 100644 --- a/src/Reflex/Dom/Widget/Resize.hs +++ /dev/null @@ -1,63 +0,0 @@ -{-# LANGUAGE RecursiveDo #-} -module Reflex.Dom.Widget.Resize where - -import Reflex -import Reflex.Dom.Class -import Reflex.Dom.Widget.Basic - -import Control.Monad -import Control.Monad.IO.Class -import Data.Monoid -import GHCJS.DOM.Element hiding (reset) -import GHCJS.DOM.EventM (on) - --- | A widget that wraps the given widget in a div and fires an event when resized. --- Adapted from github.com/marcj/css-element-queries -resizeDetector :: MonadWidget t m => m a -> m (Event t (), a) -resizeDetector = resizeDetectorWithStyle "" - -resizeDetectorWithStyle :: MonadWidget t m - => String -- ^ 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 -resizeDetectorWithStyle styleString 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;" - (parent, (expand, expandChild, shrink, w')) <- elAttr' "div" ("style" =: ("position: relative;" <> styleString)) $ do - w' <- w - elAttr "div" containerAttrs $ do - (expand, (expandChild, _)) <- elAttr' "div" containerAttrs $ elAttr' "div" ("style" =: childStyle) $ return () - (shrink, _) <- elAttr' "div" containerAttrs $ elAttr "div" ("style" =: (childStyle <> "width: 200%; height: 200%;")) $ return () - return (expand, expandChild, shrink, w') - let reset = do - let e = _el_element expand - s = _el_element shrink - eow <- getOffsetWidth e - eoh <- getOffsetHeight e - let ecw = eow + 10 - ech = eoh + 10 - setAttribute (_el_element expandChild) "style" (childStyle <> "width: " <> show ecw <> "px;" <> "height: " <> show ech <> "px;") - esw <- getScrollWidth e - setScrollLeft e esw - esh <- getScrollHeight e - setScrollTop e esh - ssw <- getScrollWidth s - setScrollLeft s ssw - ssh <- getScrollHeight s - setScrollTop s ssh - lastWidth <- getOffsetWidth (_el_element parent) - lastHeight <- getOffsetHeight (_el_element parent) - return (Just lastWidth, Just lastHeight) - resetIfChanged ds = do - pow <- getOffsetWidth (_el_element parent) - poh <- getOffsetHeight (_el_element parent) - if ds == (Just pow, Just poh) - then return Nothing - else liftM Just reset - pb <- getPostBuild - expandScroll <- wrapDomEvent (_el_element expand) (`on` scroll) $ return () - shrinkScroll <- wrapDomEvent (_el_element shrink) (`on` scroll) $ return () - size0 <- performEvent $ fmap (const $ liftIO reset) pb - rec resize <- performEventAsync $ fmap (\d cb -> liftIO $ cb =<< resetIfChanged d) $ tag (current dimensions) $ leftmost [expandScroll, shrinkScroll] - dimensions <- holdDyn (Nothing, Nothing) $ leftmost [ size0, fmapMaybe id resize ] - return (fmap (const ()) $ fmapMaybe id resize, w') diff --git a/src/Reflex/Dom/Xhr.hs b/src/Reflex/Dom/Xhr.hs deleted file mode 100644 --- a/src/Reflex/Dom/Xhr.hs +++ /dev/null @@ -1,229 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} - -module Reflex.Dom.Xhr - ( XMLHttpRequest - , XhrRequest(..) - , XhrRequestConfig(..) - , XhrResponse(..) - , XhrResponseBody(..) - , XhrResponseType(..) - , XhrException(..) - , _xhrResponse_body - , xhrResponse_body - , xhrRequest - , newXMLHttpRequest - , newXMLHttpRequestWithError - , performRequestAsync - , performRequestAsyncWithError - , performRequestsAsync - , performRequestsAsyncWithError - , getAndDecode - , postJson - , getMay - , decodeText - , decodeXhrResponse - , xmlHttpRequestGetReadyState - , xmlHttpRequestGetResponseText - , xmlHttpRequestGetStatus - , xmlHttpRequestGetStatusText - , xmlHttpRequestNew - , xmlHttpRequestOnreadystatechange - , xmlHttpRequestOpen - , xmlHttpRequestSend - , xmlHttpRequestSetRequestHeader - , xmlHttpRequestSetResponseType - ) -where - -import Control.Concurrent -import Control.Exception (catch) -import Control.Lens -import Control.Monad hiding (forM) -import Control.Monad.IO.Class -import Data.Aeson -import Data.Aeson.Encode -import qualified Data.Text.Lazy as LT -import qualified Data.Text.Lazy.Builder as B -import qualified Data.ByteString.Lazy as BL -import Data.Default -import Data.Map (Map) -import qualified Data.Map as Map -import Data.Maybe -import Data.Text (Text) -import Data.Text.Encoding -import Data.Traversable -import Reflex -import Reflex.Dom.Class -import Reflex.Dom.Xhr.Exception -import Reflex.Dom.Xhr.Foreign -import Reflex.Dom.Xhr.ResponseType -import Data.Typeable - -data XhrRequest - = XhrRequest { _xhrRequest_method :: String - , _xhrRequest_url :: String - , _xhrRequest_config :: XhrRequestConfig - } - deriving (Show, Read, Eq, Ord, Typeable) - -data XhrRequestConfig - = XhrRequestConfig { _xhrRequestConfig_headers :: Map String String - , _xhrRequestConfig_user :: Maybe String - , _xhrRequestConfig_password :: Maybe String - , _xhrRequestConfig_responseType :: Maybe XhrResponseType - , _xhrRequestConfig_sendData :: Maybe String - } - deriving (Show, Read, Eq, Ord, Typeable) - -data XhrResponse - = XhrResponse { _xhrResponse_status :: Word - , _xhrResponse_statusText :: Text - , _xhrResponse_response :: Maybe XhrResponseBody - , _xhrResponse_responseText :: Maybe Text - } - deriving (Typeable) - -{-# DEPRECATED _xhrResponse_body "Use _xhrResponse_response or _xhrResponse_responseText instead." #-} -_xhrResponse_body :: XhrResponse -> Maybe Text -_xhrResponse_body = _xhrResponse_responseText - -{-# DEPRECATED xhrResponse_body "Use xhrResponse_response or xhrResponse_responseText instead." #-} -xhrResponse_body :: Lens XhrResponse XhrResponse (Maybe Text) (Maybe Text) -xhrResponse_body = lens _xhrResponse_responseText (\r t -> r { _xhrResponse_responseText = t }) - -instance Default XhrRequestConfig where - def = XhrRequestConfig { _xhrRequestConfig_headers = Map.empty - , _xhrRequestConfig_user = Nothing - , _xhrRequestConfig_password = Nothing - , _xhrRequestConfig_responseType = Nothing - , _xhrRequestConfig_sendData = Nothing - } - --- | Construct a request object from method, URL, and config record. -xhrRequest :: String -> String -> XhrRequestConfig -> XhrRequest -xhrRequest = XhrRequest - --- | Make a new asyncronous XHR request. This does not block (it forks), --- and returns an XHR object immediately (which you can use to abort --- the XHR connection), and will pass an exception ('XhrException') to the --- continuation if the connection cannot be made (or is aborted). -newXMLHttpRequestWithError - :: (HasWebView m, MonadIO m, HasPostGui t h m) - => XhrRequest - -- ^ The request to make. - -> (Either XhrException XhrResponse -> h ()) - -- ^ A continuation to be called once a response comes back, or in - -- case of error. - -> m XMLHttpRequest - -- ^ The XHR request, which could for example be aborted. -newXMLHttpRequestWithError req cb = do - wv <- askWebView - postGui <- askPostGui - xhr <- liftIO $ xmlHttpRequestNew wv - void $ liftIO $ forkIO $ flip catch (postGui . cb . Left) $ void $ do - let c = _xhrRequest_config req - rt = _xhrRequestConfig_responseType c - xmlHttpRequestOpen - xhr - (_xhrRequest_method req) - (_xhrRequest_url req) - True - (fromMaybe "" $ _xhrRequestConfig_user c) - (fromMaybe "" $ _xhrRequestConfig_password c) - iforM_ (_xhrRequestConfig_headers c) $ xmlHttpRequestSetRequestHeader xhr - maybe (return ()) (xmlHttpRequestSetResponseType xhr . fromResponseType) rt - _ <- xmlHttpRequestOnreadystatechange xhr $ do - readyState <- liftIO $ xmlHttpRequestGetReadyState xhr - status <- liftIO $ xmlHttpRequestGetStatus xhr - statusText <- liftIO $ xmlHttpRequestGetStatusText xhr - if readyState == 4 - then do - t <- if rt == Just XhrResponseType_Text || rt == Nothing - then liftIO $ xmlHttpRequestGetResponseText xhr - else return Nothing - r <- liftIO $ xmlHttpRequestGetResponse xhr - _ <- liftIO $ postGui $ cb $ Right $ - XhrResponse { _xhrResponse_status = status - , _xhrResponse_statusText = statusText - , _xhrResponse_response = r - , _xhrResponse_responseText = t - } - return () - else return () - _ <- xmlHttpRequestSend xhr (_xhrRequestConfig_sendData c) - return () - return xhr - -newXMLHttpRequest :: (HasWebView m, MonadIO m, HasPostGui t h m) => XhrRequest -> (XhrResponse -> h ()) -> m XMLHttpRequest -newXMLHttpRequest req cb = newXMLHttpRequestWithError req $ mapM_ cb - --- | Given Event of requests, issue them when the Event fires. --- Returns Event of corresponding responses. --- --- The request is processed asynchronously, therefore handling does --- not block or cause a delay while creating the connection. -performRequestAsyncWithError - :: MonadWidget t m - => Event t XhrRequest -> m (Event t (Either XhrException XhrResponse)) -performRequestAsyncWithError = performRequestAsync' newXMLHttpRequestWithError - -performRequestAsync :: MonadWidget t m => Event t XhrRequest -> m (Event t XhrResponse) -performRequestAsync = performRequestAsync' newXMLHttpRequest - -performRequestAsync' :: (MonadWidget t m, MonadIO h) => (XhrRequest -> (a -> h ()) -> WidgetHost m XMLHttpRequest) -> Event t XhrRequest -> m (Event t a) -performRequestAsync' newXhr req = performEventAsync $ ffor req $ \r cb -> void $ newXhr r $ liftIO . cb - --- | Issues a collection of requests when the supplied Event fires. --- When ALL requests from a given firing complete, the results are --- collected and returned via the return Event. --- --- The requests are processed asynchronously, therefore handling does --- not block or cause a delay while creating the connection. --- --- Order of request execution and completion is not guaranteed, but --- order of creation and the collection result is preserved. -performRequestsAsyncWithError - :: (Traversable f, MonadWidget t m) - => Event t (f XhrRequest) -> m (Event t (f (Either XhrException XhrResponse))) -performRequestsAsyncWithError = performRequestsAsync' newXMLHttpRequestWithError - - -performRequestsAsync :: (Traversable f, MonadWidget t m) => Event t (f XhrRequest) -> m (Event t (f XhrResponse)) -performRequestsAsync = performRequestsAsync' newXMLHttpRequest - -performRequestsAsync' :: (MonadWidget t m, MonadIO h, Traversable f) => (XhrRequest -> (a -> h ()) -> WidgetHost m XMLHttpRequest) -> Event t (f XhrRequest) -> m (Event t (f a)) -performRequestsAsync' newXhr req = performEventAsync $ ffor req $ \rs cb -> do - resps <- forM rs $ \r -> do - resp <- liftIO newEmptyMVar - _ <- newXhr r $ liftIO . putMVar resp - return resp - _ <- liftIO $ forkIO $ cb =<< forM resps takeMVar - return () - --- | Simplified interface to "GET" URLs and return decoded results. -getAndDecode :: (FromJSON a, MonadWidget t m) => Event t String -> m (Event t (Maybe a)) -getAndDecode url = do - r <- performRequestAsync $ fmap (\x -> XhrRequest "GET" x def) url - return $ fmap decodeXhrResponse r - --- | Create a "POST" request from an URL and thing with a JSON representation -postJson :: (ToJSON a) => String -> a -> XhrRequest -postJson url a = - XhrRequest "POST" url $ def { _xhrRequestConfig_headers = headerUrlEnc - , _xhrRequestConfig_sendData = Just body - } - where headerUrlEnc = "Content-type" =: "application/json" - body = LT.unpack $ B.toLazyText $ encodeToTextBuilder $ toJSON a - -getMay :: MonadWidget t m => (Event t a -> m (Event t b)) -> Event t (Maybe a) -> m (Event t (Maybe b)) -getMay f e = do - e' <- f (fmapMaybe id e) - return $ leftmost [fmap Just e', fmapMaybe (maybe (Just Nothing) (const Nothing)) e] - -decodeText :: FromJSON a => Text -> Maybe a -decodeText = decode . BL.fromStrict . encodeUtf8 - --- | Convenience function to decode JSON-encoded responses. -decodeXhrResponse :: FromJSON a => XhrResponse -> Maybe a -decodeXhrResponse = join . fmap decodeText . _xhrResponse_responseText - diff --git a/src/Reflex/Dom/Xhr/Exception.hs b/src/Reflex/Dom/Xhr/Exception.hs deleted file mode 100644 --- a/src/Reflex/Dom/Xhr/Exception.hs +++ /dev/null @@ -1,12 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} - -module Reflex.Dom.Xhr.Exception where - -import Data.Typeable -import Control.Exception (Exception(..)) - -data XhrException = XhrException_Error - | XhrException_Aborted - deriving (Show, Read, Eq, Ord, Typeable) - -instance Exception XhrException diff --git a/src/Reflex/Dom/Xhr/ResponseType.hs b/src/Reflex/Dom/Xhr/ResponseType.hs deleted file mode 100644 --- a/src/Reflex/Dom/Xhr/ResponseType.hs +++ /dev/null @@ -1,21 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} - -module Reflex.Dom.Xhr.ResponseType where - -import Data.Typeable -import Data.Text (Text) -import GHCJS.DOM.Blob (Blob) -import Data.ByteString (ByteString) - -data XhrResponseType = XhrResponseType_Default - | XhrResponseType_ArrayBuffer - | XhrResponseType_Blob - | XhrResponseType_Text - deriving (Show, Read, Eq, Ord, Typeable) - -data XhrResponseBody = XhrResponseBody_Default Text - | XhrResponseBody_Text Text - | XhrResponseBody_Blob Blob - | XhrResponseBody_ArrayBuffer ByteString - deriving (Eq) -