From d9f7ec13d4accda7ce12b80446d96e69725de5cd Mon Sep 17 00:00:00 2001 From: Heinrich Apfelmus Date: Tue, 7 Nov 2023 15:46:56 +0100 Subject: [PATCH 1/5] Use Github workflow by Jonathan Knowles --- .github/workflows/build-haskell.yml | 107 ++++++++++++ .github/workflows/haskell-ci.yml | 243 ---------------------------- 2 files changed, 107 insertions(+), 243 deletions(-) create mode 100644 .github/workflows/build-haskell.yml delete mode 100644 .github/workflows/haskell-ci.yml diff --git a/.github/workflows/build-haskell.yml b/.github/workflows/build-haskell.yml new file mode 100644 index 0000000..9e25234 --- /dev/null +++ b/.github/workflows/build-haskell.yml @@ -0,0 +1,107 @@ +name: Build cabal project +on: + workflow_dispatch: + pull_request: + types: + - synchronize + - opened + - reopened + merge_group: + push: + branches: + - main + schedule: + # Run once per day (at UTC 18:00) to maintain cache: + - cron: 0 18 * * * +jobs: + build: + name: ${{ matrix.os }}-ghc-${{ matrix.ghc }} + runs-on: ${{ matrix.os }} + continue-on-error: ${{ matrix.allow-failure }} + env: + cabal-build-dir: b + strategy: + matrix: + allow-failure: + - false + os: + - ubuntu-latest + cabal: + - 3.8.1.0 + ghc: + - 8.0.2 + - 8.2.2 + - 8.4.4 + - 8.6.5 + - 8.8.4 + - 8.10.7 + - 9.2.8 + - 9.4.7 + - 9.6.3 + include: + - ghc: 9.8.1 + os: ubuntu-latest + cabal: 3.8.1.0 + allow-failure: true + steps: + - name: Checkout + uses: actions/checkout@v3 + + - name: Environment + uses: haskell-actions/setup@v2 + id: setup-haskell-cabal + with: + ghc-version: ${{ matrix.ghc }} + cabal-version: ${{ matrix.cabal }} + + - name: Configure + run: > + cabal configure + --builddir=${{ env.cabal-build-dir }} + --enable-tests + --enable-benchmarks + --enable-documentation + --test-show-details=direct + --write-ghc-environment-files=always + + - name: Freeze + run: > + cabal freeze + --builddir=${{ env.cabal-build-dir }} + + - name: Cache + uses: actions/cache@v3 + env: + hash: ${{ hashFiles('cabal.project.freeze') }} + with: + key: ${{ matrix.os }}-ghc-${{ matrix.ghc }}-${{ env.hash }} + restore-keys: | + ${{ matrix.os }}-ghc-${{ matrix.ghc }}- + path: | + ${{ steps.setup-haskell-cabal.outputs.cabal-store }} + ${{ env.cabal-build-dir }} + + - name: Dependencies + run: > + cabal build all + --builddir=${{ env.cabal-build-dir }} + --only-dependencies + + - name: Build + run: > + cabal build all + --builddir=${{ env.cabal-build-dir }} + --enable-tests + --enable-benchmarks + --ghc-options=-Wall + + - name: Test + run: > + cabal test all + --builddir=${{ env.cabal-build-dir }} + + - name: Benchmark + run: > + cabal bench all + --builddir=${{ env.cabal-build-dir }} + || true diff --git a/.github/workflows/haskell-ci.yml b/.github/workflows/haskell-ci.yml deleted file mode 100644 index 19565ec..0000000 --- a/.github/workflows/haskell-ci.yml +++ /dev/null @@ -1,243 +0,0 @@ -# This GitHub workflow config has been generated by a script via -# -# haskell-ci '--ghcup-jobs-jobs=>= 8' '--branches=master' 'github' 'threepenny-gui.cabal' -# -# To regenerate the script (for example after adjusting tested-with) run -# -# haskell-ci regenerate -# -# For more information, see https://github.com/haskell-CI/haskell-ci -# -# version: 0.15.20220808 -# -# REGENDATA ("0.15.20220808",["--ghcup-jobs-jobs=>= 8","--branches=master","github","threepenny-gui.cabal"]) -# -name: Haskell-CI -on: - push: - branches: - - master - pull_request: - branches: - - master -jobs: - linux: - name: Haskell-CI - Linux - ${{ matrix.compiler }} - runs-on: ubuntu-20.04 - timeout-minutes: - 60 - container: - image: buildpack-deps:bionic - continue-on-error: ${{ matrix.allow-failure }} - strategy: - matrix: - include: - - compiler: ghc-9.4.1 - compilerKind: ghc - compilerVersion: 9.4.1 - setup-method: ghcup - allow-failure: false - - compiler: ghc-9.2.4 - compilerKind: ghc - compilerVersion: 9.2.4 - setup-method: ghcup - allow-failure: false - - compiler: ghc-8.10.7 - compilerKind: ghc - compilerVersion: 8.10.7 - setup-method: ghcup - allow-failure: false - - compiler: ghc-8.8.4 - compilerKind: ghc - compilerVersion: 8.8.4 - setup-method: ghcup - allow-failure: false - - compiler: ghc-8.6.5 - compilerKind: ghc - compilerVersion: 8.6.5 - setup-method: ghcup - allow-failure: false - - compiler: ghc-8.4.4 - compilerKind: ghc - compilerVersion: 8.4.4 - setup-method: ghcup - allow-failure: false - - compiler: ghc-8.2.2 - compilerKind: ghc - compilerVersion: 8.2.2 - setup-method: ghcup - allow-failure: false - - compiler: ghc-8.0.2 - compilerKind: ghc - compilerVersion: 8.0.2 - setup-method: ghcup - allow-failure: false - - compiler: ghc-7.10.3 - compilerKind: ghc - compilerVersion: 7.10.3 - setup-method: hvr-ppa - allow-failure: false - fail-fast: false - steps: - - name: apt - run: | - apt-get update - apt-get install -y --no-install-recommends gnupg ca-certificates dirmngr curl git software-properties-common libtinfo5 libnuma-dev - if [ "${{ matrix.setup-method }}" = ghcup ]; then - mkdir -p "$HOME/.ghcup/bin" - curl -sL https://downloads.haskell.org/ghcup/0.1.18.0/x86_64-linux-ghcup-0.1.18.0 > "$HOME/.ghcup/bin/ghcup" - chmod a+x "$HOME/.ghcup/bin/ghcup" - "$HOME/.ghcup/bin/ghcup" install ghc "$HCVER" || (cat "$HOME"/.ghcup/logs/*.* && false) - "$HOME/.ghcup/bin/ghcup" install cabal 3.6.2.0 || (cat "$HOME"/.ghcup/logs/*.* && false) - else - apt-add-repository -y 'ppa:hvr/ghc' - apt-get update - apt-get install -y "$HCNAME" - mkdir -p "$HOME/.ghcup/bin" - curl -sL https://downloads.haskell.org/ghcup/0.1.18.0/x86_64-linux-ghcup-0.1.18.0 > "$HOME/.ghcup/bin/ghcup" - chmod a+x "$HOME/.ghcup/bin/ghcup" - "$HOME/.ghcup/bin/ghcup" install cabal 3.6.2.0 || (cat "$HOME"/.ghcup/logs/*.* && false) - fi - env: - HCKIND: ${{ matrix.compilerKind }} - HCNAME: ${{ matrix.compiler }} - HCVER: ${{ matrix.compilerVersion }} - - name: Set PATH and environment variables - run: | - echo "$HOME/.cabal/bin" >> $GITHUB_PATH - echo "LANG=C.UTF-8" >> "$GITHUB_ENV" - echo "CABAL_DIR=$HOME/.cabal" >> "$GITHUB_ENV" - echo "CABAL_CONFIG=$HOME/.cabal/config" >> "$GITHUB_ENV" - HCDIR=/opt/$HCKIND/$HCVER - if [ "${{ matrix.setup-method }}" = ghcup ]; then - HC=$HOME/.ghcup/bin/$HCKIND-$HCVER - echo "HC=$HC" >> "$GITHUB_ENV" - echo "HCPKG=$HOME/.ghcup/bin/$HCKIND-pkg-$HCVER" >> "$GITHUB_ENV" - echo "HADDOCK=$HOME/.ghcup/bin/haddock-$HCVER" >> "$GITHUB_ENV" - echo "CABAL=$HOME/.ghcup/bin/cabal-3.6.2.0 -vnormal+nowrap" >> "$GITHUB_ENV" - else - HC=$HCDIR/bin/$HCKIND - echo "HC=$HC" >> "$GITHUB_ENV" - echo "HCPKG=$HCDIR/bin/$HCKIND-pkg" >> "$GITHUB_ENV" - echo "HADDOCK=$HCDIR/bin/haddock" >> "$GITHUB_ENV" - echo "CABAL=$HOME/.ghcup/bin/cabal-3.6.2.0 -vnormal+nowrap" >> "$GITHUB_ENV" - fi - - HCNUMVER=$(${HC} --numeric-version|perl -ne '/^(\d+)\.(\d+)\.(\d+)(\.(\d+))?$/; print(10000 * $1 + 100 * $2 + ($3 == 0 ? $5 != 1 : $3))') - echo "HCNUMVER=$HCNUMVER" >> "$GITHUB_ENV" - echo "ARG_TESTS=--enable-tests" >> "$GITHUB_ENV" - echo "ARG_BENCH=--enable-benchmarks" >> "$GITHUB_ENV" - echo "HEADHACKAGE=false" >> "$GITHUB_ENV" - echo "ARG_COMPILER=--$HCKIND --with-compiler=$HC" >> "$GITHUB_ENV" - echo "GHCJSARITH=0" >> "$GITHUB_ENV" - env: - HCKIND: ${{ matrix.compilerKind }} - HCNAME: ${{ matrix.compiler }} - HCVER: ${{ matrix.compilerVersion }} - - name: env - run: | - env - - name: write cabal config - run: | - mkdir -p $CABAL_DIR - cat >> $CABAL_CONFIG <> $CABAL_CONFIG < cabal-plan.xz - echo 'de73600b1836d3f55e32d80385acc055fd97f60eaa0ab68a755302685f5d81bc cabal-plan.xz' | sha256sum -c - - xz -d < cabal-plan.xz > $HOME/.cabal/bin/cabal-plan - rm -f cabal-plan.xz - chmod a+x $HOME/.cabal/bin/cabal-plan - cabal-plan --version - - name: checkout - uses: actions/checkout@v2 - with: - path: source - - name: initial cabal.project for sdist - run: | - touch cabal.project - echo "packages: $GITHUB_WORKSPACE/source/." >> cabal.project - cat cabal.project - - name: sdist - run: | - mkdir -p sdist - $CABAL sdist all --output-dir $GITHUB_WORKSPACE/sdist - - name: unpack - run: | - mkdir -p unpacked - find sdist -maxdepth 1 -type f -name '*.tar.gz' -exec tar -C $GITHUB_WORKSPACE/unpacked -xzvf {} \; - - name: generate cabal.project - run: | - PKGDIR_threepenny_gui="$(find "$GITHUB_WORKSPACE/unpacked" -maxdepth 1 -type d -regex '.*/threepenny-gui-[0-9.]*')" - echo "PKGDIR_threepenny_gui=${PKGDIR_threepenny_gui}" >> "$GITHUB_ENV" - rm -f cabal.project cabal.project.local - touch cabal.project - touch cabal.project.local - echo "packages: ${PKGDIR_threepenny_gui}" >> cabal.project - if [ $((HCNUMVER >= 80200)) -ne 0 ] ; then echo "package threepenny-gui" >> cabal.project ; fi - if [ $((HCNUMVER >= 80200)) -ne 0 ] ; then echo " ghc-options: -Werror=missing-methods" >> cabal.project ; fi - cat >> cabal.project <> cabal.project.local - cat cabal.project - cat cabal.project.local - - name: dump install plan - run: | - $CABAL v2-build $ARG_COMPILER $ARG_TESTS $ARG_BENCH --dry-run all - cabal-plan - - name: cache - uses: actions/cache@v2 - with: - key: ${{ runner.os }}-${{ matrix.compiler }}-${{ github.sha }} - path: ~/.cabal/store - restore-keys: ${{ runner.os }}-${{ matrix.compiler }}- - - name: install dependencies - run: | - $CABAL v2-build $ARG_COMPILER --disable-tests --disable-benchmarks --dependencies-only -j2 all - $CABAL v2-build $ARG_COMPILER $ARG_TESTS $ARG_BENCH --dependencies-only -j2 all - - name: build w/o tests - run: | - $CABAL v2-build $ARG_COMPILER --disable-tests --disable-benchmarks all - - name: build - run: | - $CABAL v2-build $ARG_COMPILER $ARG_TESTS $ARG_BENCH all --write-ghc-environment-files=always - - name: cabal check - run: | - cd ${PKGDIR_threepenny_gui} || false - ${CABAL} -vnormal check - - name: haddock - run: | - $CABAL v2-haddock --haddock-all $ARG_COMPILER --with-haddock $HADDOCK $ARG_TESTS $ARG_BENCH all - - name: unconstrained build - run: | - rm -f cabal.project.local - $CABAL v2-build $ARG_COMPILER --disable-tests --disable-benchmarks all From dde96fa5fb042cbee4500042a60aa4bc1a5d8a10 Mon Sep 17 00:00:00 2001 From: Heinrich Apfelmus Date: Tue, 7 Nov 2023 15:10:27 +0100 Subject: [PATCH 2/5] Tested-with: Add GHC 9.6.3 and 9.8.1, remove GHC 7.10.3 --- threepenny-gui.cabal | 13 +++++++------ 1 file changed, 7 insertions(+), 6 deletions(-) diff --git a/threepenny-gui.cabal b/threepenny-gui.cabal index a575832..6388461 100644 --- a/threepenny-gui.cabal +++ b/threepenny-gui.cabal @@ -1,5 +1,5 @@ Name: threepenny-gui -Version: 0.9.4.0 +Version: 0.9.5.0 Synopsis: GUI framework that uses the web browser as a display. Description: Threepenny-GUI is a GUI framework that uses the web browser as a display. @@ -28,15 +28,16 @@ bug-reports: https://github.com/HeinrichApfelmus/threepenny-gui/issues Category: Web, GUI Build-type: Simple Cabal-version: >=1.10 -Tested-With: GHC == 7.10.3 - ,GHC == 8.0.2 +Tested-With: GHC == 8.0.2 ,GHC == 8.2.2 ,GHC == 8.4.4 ,GHC == 8.6.5 ,GHC == 8.8.4 ,GHC == 8.10.7 - ,GHC == 9.2.4 - ,GHC == 9.4.1 + ,GHC == 9.2.8 + ,GHC == 9.4.7 + ,GHC == 9.6.3 + ,GHC == 9.8.1 Extra-Source-Files: CHANGELOG.md ,README.md @@ -111,7 +112,7 @@ Library if flag(rebug) cpp-options: -DREBUG ghc-options: -O2 - build-depends: base >= 4.8 && < 4.19 + build-depends: base >= 4.8 && < 4.20 ,aeson (>= 0.7 && < 0.10) || == 0.11.* || (>= 1.0 && < 2.2) ,async >= 2.0 && < 2.3 ,bytestring >= 0.9.2 && < 0.12 From b9ac9b625f7bd1a3abc34e61d983915958fdaaef Mon Sep 17 00:00:00 2001 From: Heinrich Apfelmus Date: Tue, 7 Nov 2023 15:14:15 +0100 Subject: [PATCH 3/5] Allow aeson-2.2, template-haskell-2.20, bytestring-0.12 --- threepenny-gui.cabal | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/threepenny-gui.cabal b/threepenny-gui.cabal index 6388461..6108ce7 100644 --- a/threepenny-gui.cabal +++ b/threepenny-gui.cabal @@ -113,9 +113,9 @@ Library cpp-options: -DREBUG ghc-options: -O2 build-depends: base >= 4.8 && < 4.20 - ,aeson (>= 0.7 && < 0.10) || == 0.11.* || (>= 1.0 && < 2.2) + ,aeson (>= 0.7 && < 0.10) || == 0.11.* || (>= 1.0 && < 2.3) ,async >= 2.0 && < 2.3 - ,bytestring >= 0.9.2 && < 0.12 + ,bytestring >= 0.9.2 && < 0.13 ,containers >= 0.4.2 && < 0.7 ,data-default >= 0.5.0 && < 0.8 ,deepseq >= 1.3.0 && < 1.5 @@ -127,7 +127,7 @@ Library ,snap-server >= 0.9.0 && < 1.2 ,snap-core >= 0.9.0 && < 1.1 ,stm >= 2.2 && < 2.6 - ,template-haskell >= 2.7.0 && < 2.20 + ,template-haskell >= 2.7.0 && < 2.21 ,text >= 0.11 && < 2.1 ,transformers >= 0.3.0 && < 0.7 ,unordered-containers == 0.2.* From dcb437290628f1b4bcafd8da0cb305aa7d0906f7 Mon Sep 17 00:00:00 2001 From: Heinrich Apfelmus Date: Wed, 8 Nov 2023 15:48:05 +0100 Subject: [PATCH 4/5] Allow template-haskell-2.21, deepseq-1.5, text-2.1 --- threepenny-gui.cabal | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/threepenny-gui.cabal b/threepenny-gui.cabal index 6108ce7..886a708 100644 --- a/threepenny-gui.cabal +++ b/threepenny-gui.cabal @@ -118,7 +118,7 @@ Library ,bytestring >= 0.9.2 && < 0.13 ,containers >= 0.4.2 && < 0.7 ,data-default >= 0.5.0 && < 0.8 - ,deepseq >= 1.3.0 && < 1.5 + ,deepseq >= 1.3.0 && < 1.6 ,exceptions >= 0.6 && < 0.11 ,filepath >= 1.3.0 && < 1.5.0 ,file-embed >= 0.0.10 && < 0.1 @@ -127,8 +127,8 @@ Library ,snap-server >= 0.9.0 && < 1.2 ,snap-core >= 0.9.0 && < 1.1 ,stm >= 2.2 && < 2.6 - ,template-haskell >= 2.7.0 && < 2.21 - ,text >= 0.11 && < 2.1 + ,template-haskell >= 2.7.0 && < 2.22 + ,text >= 0.11 && < 2.2 ,transformers >= 0.3.0 && < 0.7 ,unordered-containers == 0.2.* ,websockets (>= 0.8 && < 0.12.5) || (> 0.12.5.0 && < 0.13) From cb7683d57fe142d406fb835967e6003e11a18c69 Mon Sep 17 00:00:00 2001 From: Heinrich Apfelmus Date: Wed, 8 Nov 2023 15:11:03 +0100 Subject: [PATCH 5/5] Fix some warnings on GHC 9.6.3 --- src/Foreign/JavaScript.hs | 7 +-- src/Foreign/JavaScript/CallBuffer.hs | 10 ++-- src/Foreign/JavaScript/EventLoop.hs | 23 ++++----- src/Foreign/JavaScript/Include.hs | 4 +- src/Foreign/JavaScript/Marshal.hs | 2 +- src/Foreign/JavaScript/Server.hs | 14 +++--- src/Foreign/RemotePtr.hs | 20 ++++---- src/Graphics/UI/Threepenny/Attributes.hs | 7 +-- src/Graphics/UI/Threepenny/Canvas.hs | 9 ++-- src/Graphics/UI/Threepenny/Core.hs | 50 ++++++++++---------- src/Graphics/UI/Threepenny/DragNDrop.hs | 1 + src/Graphics/UI/Threepenny/Elements.hs | 2 +- src/Graphics/UI/Threepenny/Events.hs | 2 + src/Graphics/UI/Threepenny/Internal.hs | 7 ++- src/Graphics/UI/Threepenny/JQuery.hs | 3 -- src/Graphics/UI/Threepenny/SVG/Attributes.hs | 1 + src/Graphics/UI/Threepenny/SVG/Elements.hs | 1 + src/Graphics/UI/Threepenny/Timer.hs | 4 +- src/Graphics/UI/Threepenny/Widgets.hs | 6 ++- src/Reactive/Threepenny.hs | 19 ++++---- src/Reactive/Threepenny/Memo.hs | 1 + src/Reactive/Threepenny/PulseLatch.hs | 15 +++--- 22 files changed, 104 insertions(+), 104 deletions(-) diff --git a/src/Foreign/JavaScript.hs b/src/Foreign/JavaScript.hs index df56873..94a9c5d 100644 --- a/src/Foreign/JavaScript.hs +++ b/src/Foreign/JavaScript.hs @@ -31,9 +31,6 @@ module Foreign.JavaScript ( debug, timestamp, ) where -import Control.Concurrent.STM as STM -import Control.Monad (unless) -import qualified Data.Aeson as JSON import Foreign.JavaScript.CallBuffer import Foreign.JavaScript.EventLoop import Foreign.JavaScript.Marshal @@ -49,12 +46,12 @@ serve :: Config -- ^ Configuration options. -> (Window -> IO ()) -- ^ Initialization whenever a client connects. -> IO () -serve config init = httpComm config $ eventLoop $ \w -> do +serve config initialize = httpComm config $ eventLoop $ \w -> do setCallBufferMode w (jsCallBufferMode config) runFunction w $ ffi "connection.setReloadOnDisconnect(%1)" $ jsWindowReloadOnDisconnect config flushCallBuffer w -- make sure that all `runEval` commands are executed - init w + initialize w flushCallBuffer w -- make sure that all `runEval` commands are executed {----------------------------------------------------------------------------- diff --git a/src/Foreign/JavaScript/CallBuffer.hs b/src/Foreign/JavaScript/CallBuffer.hs index 96738a5..f7e4aa1 100644 --- a/src/Foreign/JavaScript/CallBuffer.hs +++ b/src/Foreign/JavaScript/CallBuffer.hs @@ -17,7 +17,7 @@ setCallBufferMode w new = -- | Get the call buffering mode for the given browser window. getCallBufferMode :: Window -> IO CallBufferMode -getCallBufferMode w@Window{..} = atomically $ readTVar wCallBufferMode +getCallBufferMode Window{..} = atomically $ readTVar wCallBufferMode -- | Flush the call buffer, -- i.e. send all outstanding JavaScript to the client in one single message. @@ -26,7 +26,7 @@ flushCallBuffer w = flushCallBufferWithAtomic w $ return () -- | Flush the call buffer, and atomically perform an additional action flushCallBufferWithAtomic :: Window -> STM a -> IO a -flushCallBufferWithAtomic w@Window{..} action = do +flushCallBufferWithAtomic Window{..} action = do -- by taking the call buffer, we ensure that no further code -- is added to the buffer while we execute the current buffer's code. code' <- atomically $ takeTMVar wCallBuffer @@ -39,7 +39,7 @@ flushCallBufferWithAtomic w@Window{..} action = do -- | Schedule a piece of JavaScript code to be run with `runEval`, -- depending on the buffering mode bufferRunEval :: Window -> String -> IO () -bufferRunEval w@Window{..} code = do +bufferRunEval Window{..} code = do action <- atomically $ do mode <- readTVar wCallBufferMode case mode of @@ -50,5 +50,5 @@ bufferRunEval w@Window{..} code = do putTMVar wCallBuffer (msg . (\s -> ";" ++ code ++ s)) return Nothing case action of - Nothing -> return () - Just code -> runEval code + Nothing -> return () + Just code1 -> runEval code1 diff --git a/src/Foreign/JavaScript/EventLoop.hs b/src/Foreign/JavaScript/EventLoop.hs index 2ca86b4..9c99925 100644 --- a/src/Foreign/JavaScript/EventLoop.hs +++ b/src/Foreign/JavaScript/EventLoop.hs @@ -6,7 +6,6 @@ module Foreign.JavaScript.EventLoop ( newHandler, fromJSStablePtr, newJSObjectFromCoupon ) where -import Control.Applicative import Control.Concurrent import Control.Concurrent.Async import Control.Concurrent.STM as STM @@ -15,10 +14,7 @@ import Control.Exception as E import Control.Monad import qualified Data.Aeson as JSON import qualified Data.ByteString.Char8 as BS -import Data.IORef -import qualified Data.Map as Map import qualified Data.Text as T -import qualified System.Mem import Foreign.RemotePtr as Foreign import Foreign.JavaScript.CallBuffer @@ -35,11 +31,12 @@ rebug = return () Event Loop ------------------------------------------------------------------------------} -- | Handle a single event -handleEvent w@(Window{..}) (name, args) = do +handleEvent :: Window -> (Coupon, JSON.Value) -> IO () +handleEvent Window{..} (name, args) = do mhandler <- Foreign.lookup name wEventHandlers case mhandler of Nothing -> return () - Just f -> withRemotePtr f (\_ f -> f args) + Just f -> withRemotePtr f (\_ g -> g args) type Result = Either String JSON.Value @@ -47,7 +44,7 @@ type Result = Either String JSON.Value -- | Event loop for a browser window. -- Supports concurrent invocations of `runEval` and `callEval`. eventLoop :: (Window -> IO void) -> EventLoop -eventLoop init server info comm = void $ do +eventLoop initialize server info comm = void $ do -- To support concurrent FFI calls, we need three threads. -- A fourth thread supports -- @@ -112,12 +109,12 @@ eventLoop init server info comm = void $ do -- Send FFI calls to client and collect results let handleCalls = forever $ do - ref <- atomically $ do - (ref, msg) <- readTQueue calls + mref <- atomically $ do + (mref, msg) <- readTQueue calls writeServer comm msg - return ref + return mref atomically $ - case ref of + case mref of Just ref -> do result <- readTQueue results putTMVar ref result @@ -155,7 +152,7 @@ eventLoop init server info comm = void $ do withAsync multiplexer $ \_ -> withAsync handleCalls $ \_ -> withAsync (flushCallBufferPeriodically w) $ \_ -> - E.finally (init w >> handleEvents) $ do + E.finally (initialize w >> handleEvents) $ do putStrLn "Foreign.JavaScript: Browser window disconnected." -- close communication channel if still necessary commClose comm @@ -175,7 +172,7 @@ flushCallBufferPeriodically w = ------------------------------------------------------------------------------} -- | Turn a Haskell function into an event handler. newHandler :: Window -> ([JSON.Value] -> IO ()) -> IO HsEvent -newHandler w@(Window{..}) handler = do +newHandler Window{..} handler = do coupon <- newCoupon wEventHandlers newRemotePtr coupon (handler . parseArgs) wEventHandlers where diff --git a/src/Foreign/JavaScript/Include.hs b/src/Foreign/JavaScript/Include.hs index f92aa05..7904a1c 100644 --- a/src/Foreign/JavaScript/Include.hs +++ b/src/Foreign/JavaScript/Include.hs @@ -8,8 +8,8 @@ import System.IO include :: FilePath -> Q Exp include path = do - path <- makeRelativeToProject path - LitE . StringL <$> runIO (readFileUTF8 path) + relativePath <- makeRelativeToProject path + LitE . StringL <$> runIO (readFileUTF8 relativePath) readFileUTF8 :: FilePath -> IO String readFileUTF8 path = do diff --git a/src/Foreign/JavaScript/Marshal.hs b/src/Foreign/JavaScript/Marshal.hs index 5de48db..081b8af 100644 --- a/src/Foreign/JavaScript/Marshal.hs +++ b/src/Foreign/JavaScript/Marshal.hs @@ -19,7 +19,6 @@ import qualified Data.Aeson.Encode as JSON (encodeToTextBuilder) #else import qualified Data.Aeson.Text as JSON (encodeToTextBuilder) #endif -import qualified Data.Aeson.Types as JSON import Data.Functor ((<$>)) import Data.List (intercalate) import qualified Data.Text as T @@ -48,6 +47,7 @@ class ToJS a where ys <- mapM render xs jsCode $ "[" ++ intercalate "," (map unJSCode ys) ++ "]" +jsCode :: String -> IO JSCode jsCode = return . JSCode instance ToJS Float where render = render . JSON.toJSON diff --git a/src/Foreign/JavaScript/Server.hs b/src/Foreign/JavaScript/Server.hs index baac4d1..0abb74b 100644 --- a/src/Foreign/JavaScript/Server.hs +++ b/src/Foreign/JavaScript/Server.hs @@ -15,17 +15,16 @@ import Data.ByteString (ByteString) import qualified Data.ByteString.Char8 as BS import qualified Data.ByteString.Lazy.Char8 as LBS import qualified Data.Map as M -import Data.Text +import Data.Text (Text) import qualified Safe as Safe import System.Environment import System.FilePath -- import web libraries -import Data.Aeson ((.=)) import qualified Data.Aeson as JSON import qualified Network.WebSockets as WS import qualified Network.WebSockets.Snap as WS -import Snap.Core as Snap +import Snap.Core as Snap hiding (path, dir) import qualified Snap.Http.Server as Snap import Snap.Util.FileServe @@ -114,15 +113,15 @@ communicationFromWebSocket request = do let commClose = atomically $ STM.writeTVar commOpen False -- read/write data until an exception occurs or the channel is no longer open - forkFinally (sendData `race_` readData `race_` sentry) $ \_ -> void $ do + _ <- forkFinally (sendData `race_` readData `race_` sentry) $ \_ -> void $ do -- close the communication channel explicitly if that didn't happen yet commClose -- attempt to close websocket if still necessary/possible -- ignore any exceptions that may happen if it's already closed - let all :: E.SomeException -> Maybe () - all _ = Just () - E.tryJust all $ WS.sendClose connection $ LBS.pack "close" + let allExceptions :: E.SomeException -> Maybe () + allExceptions _ = Just () + E.tryJust allExceptions $ WS.sendClose connection $ LBS.pack "close" return $ Comm {..} @@ -155,6 +154,7 @@ routeResources server customHTML staticDir = Nothing -> logError "Foreign.JavaScript: Cannot use jsCustomHTML file without jsStatic" Nothing -> writeTextMime defaultHtmlFile "text/html" +writeTextMime :: MonadSnap m => Text -> ByteString -> m () writeTextMime text mime = do modifyResponse (setHeader "Content-type" mime) writeText text diff --git a/src/Foreign/RemotePtr.hs b/src/Foreign/RemotePtr.hs index 9a67fe9..5dcd728 100644 --- a/src/Foreign/RemotePtr.hs +++ b/src/Foreign/RemotePtr.hs @@ -17,15 +17,12 @@ module Foreign.RemotePtr ( import Prelude hiding (lookup) import Control.Monad -import Control.Concurrent import qualified Data.Text as T import qualified Data.HashMap.Strict as Map import Data.Functor import Data.IORef -import System.IO.Unsafe (unsafePerformIO) import System.Mem.Weak hiding (addFinalizer) -import qualified System.Mem.Weak as Weak import qualified GHC.Base as GHC import qualified GHC.Weak as GHC @@ -42,14 +39,14 @@ atomicModifyIORef' = atomicModifyIORef mkWeakIORefValue :: IORef a -> value -> IO () -> IO (Weak value) #if CABAL #if MIN_VERSION_base(4,9,0) -mkWeakIORefValue r@(GHC.IORef (GHC.STRef r#)) v (GHC.IO f) = GHC.IO $ \s -> +mkWeakIORefValue (GHC.IORef (GHC.STRef r#)) v (GHC.IO f) = GHC.IO $ \s -> case GHC.mkWeak# r# v f s of (# s1, w #) -> (# s1, GHC.Weak w #) #else -mkWeakIORefValue r@(GHC.IORef (GHC.STRef r#)) v f = GHC.IO $ \s -> +mkWeakIORefValue (GHC.IORef (GHC.STRef r#)) v f = GHC.IO $ \s -> case GHC.mkWeak# r# v f s of (# s1, w #) -> (# s1, GHC.Weak w #) #endif #else -mkWeakIORefValue r@(GHC.IORef (GHC.STRef r#)) v (GHC.IO f) = GHC.IO $ \s -> +mkWeakIORefValue (GHC.IORef (GHC.STRef r#)) v (GHC.IO f) = GHC.IO $ \s -> case GHC.mkWeak# r# v f s of (# s1, w #) -> (# s1, GHC.Weak w #) #endif @@ -133,8 +130,9 @@ newRemotePtr coupon value Vendor{..} = do let self = undefined ptr <- newIORef RemoteData{..} - let finalize = atomicModifyIORef' coupons $ \m -> (Map.delete coupon m, ()) - w <- mkWeakIORef ptr finalize + let doFinalize = + atomicModifyIORef' coupons $ \m -> (Map.delete coupon m, ()) + w <- mkWeakIORef ptr doFinalize atomicModifyIORef' coupons $ \m -> (Map.insert coupon w m, ()) atomicModifyIORef' ptr $ \itemdata -> (itemdata { self = w }, ()) return ptr @@ -148,10 +146,10 @@ newRemotePtr coupon value Vendor{..} = do -- will not be garbage collected -- and its 'Coupon' can be successfully redeemed at the 'Vendor'. withRemotePtr :: RemotePtr a -> (Coupon -> a -> IO b) -> IO b -withRemotePtr ptr f = do - RemoteData{..} <- readIORef ptr +withRemotePtr ptr0 f = do + RemoteData{..} <- readIORef ptr0 b <- f coupon value - touch ptr + touch ptr0 return b where -- make sure that the pointer is alive at this point in the code diff --git a/src/Graphics/UI/Threepenny/Attributes.hs b/src/Graphics/UI/Threepenny/Attributes.hs index 804da1a..e84d29c 100644 --- a/src/Graphics/UI/Threepenny/Attributes.hs +++ b/src/Graphics/UI/Threepenny/Attributes.hs @@ -1,3 +1,4 @@ +{-# OPTIONS_GHC -Wno-missing-signatures #-} module Graphics.UI.Threepenny.Attributes ( -- * Synopsis -- | Element attributes. @@ -50,13 +51,13 @@ selection = fromJQueryProp "selectedIndex" from (JSON.toJSON . maybe (-1) id) http://hackage.haskell.org/package/html ------------------------------------------------------------------------------} strAttr :: String -> WriteAttr Element String -strAttr name = mkWriteAttr (set' (attr name)) +strAttr attrname = mkWriteAttr (set' (attr attrname)) intAttr :: String -> WriteAttr Element Int -intAttr name = mkWriteAttr (set' (attr name) . show) +intAttr attrname = mkWriteAttr (set' (attr attrname) . show) emptyAttr :: String -> WriteAttr Element Bool -emptyAttr name = mkWriteAttr (set' (attr name) . f) +emptyAttr attrname = mkWriteAttr (set' (attr attrname) . f) where f True = "1" f False = "0" diff --git a/src/Graphics/UI/Threepenny/Canvas.hs b/src/Graphics/UI/Threepenny/Canvas.hs index 8aafcfd..9ddfc98 100644 --- a/src/Graphics/UI/Threepenny/Canvas.hs +++ b/src/Graphics/UI/Threepenny/Canvas.hs @@ -20,7 +20,6 @@ import Data.List(intercalate) import Numeric (showHex) import Graphics.UI.Threepenny.Core -import qualified Data.Aeson as JSON {----------------------------------------------------------------------------- Canvas @@ -240,8 +239,8 @@ stroke = runFunction . ffi "%1.getContext('2d').stroke()" -- The 'textAlign' attributes determines the position of the text -- relative to the point. fillText :: String -> Point -> Canvas -> UI () -fillText text (x,y) canvas = - runFunction $ ffi "%1.getContext('2d').fillText(%2, %3, %4)" canvas text x y +fillText t (x,y) canvas = + runFunction $ ffi "%1.getContext('2d').fillText(%2, %3, %4)" canvas t x y -- | Render the outline of a text at a certain point on the canvas. -- @@ -250,8 +249,8 @@ fillText text (x,y) canvas = -- The 'textAlign' attributes determines the position of the text -- relative to the point. strokeText :: String -> Point -> Canvas -> UI () -strokeText text (x,y) canvas = - runFunction $ ffi "%1.getContext('2d').strokeText(%2, %3, %4)" canvas text x y +strokeText t (x,y) canvas = + runFunction $ ffi "%1.getContext('2d').strokeText(%2, %3, %4)" canvas t x y {----------------------------------------------------------------------------- helper functions diff --git a/src/Graphics/UI/Threepenny/Core.hs b/src/Graphics/UI/Threepenny/Core.hs index 392a0c9..8329a6a 100644 --- a/src/Graphics/UI/Threepenny/Core.hs +++ b/src/Graphics/UI/Threepenny/Core.hs @@ -175,17 +175,19 @@ getElementById :: Window -- ^ Browser window -> String -- ^ The ID string. -> UI (Maybe Element) -- ^ Element (if any) with given ID. -getElementById _ id = - E.handle (\(e :: JS.JavaScriptException) -> return Nothing) $ - fmap Just . fromJSObject =<< callFunction (ffi "document.getElementById(%1)" id) +getElementById _ ident = + E.handle (\(_ :: JS.JavaScriptException) -> return Nothing) $ + fmap Just . fromJSObject + =<< callFunction (ffi "document.getElementById(%1)" ident) -- | Get a list of elements by particular class. getElementsByClassName :: Window -- ^ Browser window -> String -- ^ The class string. -> UI [Element] -- ^ Elements with given class. -getElementsByClassName window s = - mapM fromJSObject =<< callFunction (ffi "document.getElementsByClassName(%1)" s) +getElementsByClassName _ s = + mapM fromJSObject + =<< callFunction (ffi "document.getElementsByClassName(%1)" s) {----------------------------------------------------------------------------- Layout @@ -222,9 +224,9 @@ grid mrows = do rows0 <- mapM (sequence) mrows rows <- forM rows0 $ \row0 -> do - row <- forM row0 $ \entry -> + row1 <- forM row0 $ \entry -> wrap "table-cell" [entry] - wrap "table-row" row + wrap "table-row" row1 wrap "table" rows where @@ -306,9 +308,9 @@ instance Functor (ReadWriteAttr x i) where -- | Map input and output type of an attribute. bimapAttr :: (i' -> i) -> (o -> o') -> ReadWriteAttr x i o -> ReadWriteAttr x i' o' -bimapAttr from to attr = attr - { get' = fmap to . get' attr - , set' = \i' -> set' attr (from i') +bimapAttr from to attribute = attribute + { get' = fmap to . get' attribute + , set' = \i' -> set' attribute (from i') } -- | Set value of an attribute in the 'UI' monad. @@ -321,47 +323,47 @@ set attr i mx = do { x <- mx; set' attr i x; return x; } -- Note: For reasons of efficiency, the attribute is only -- updated when the value changes. sink :: ReadWriteAttr x i o -> Behavior i -> UI x -> UI x -sink attr bi mx = do +sink attribute bi mx = do x <- mx window <- askWindow liftIOLater $ do - i <- currentValue bi - runUI window $ set' attr i x - Reactive.onChange bi $ \i -> runUI window $ set' attr i x + i0 <- currentValue bi + runUI window $ set' attribute i0 x + Reactive.onChange bi $ \i -> runUI window $ set' attribute i x return x -- | Get attribute value. get :: ReadWriteAttr x i o -> x -> UI o -get attr = get' attr +get attribute = get' attribute -- | Build an attribute from a getter and a setter. mkReadWriteAttr :: (x -> UI o) -- ^ Getter. -> (i -> x -> UI ()) -- ^ Setter. -> ReadWriteAttr x i o -mkReadWriteAttr get set = ReadWriteAttr { get' = get, set' = set } +mkReadWriteAttr geti seto = ReadWriteAttr { get' = geti, set' = seto } -- | Build attribute from a getter. mkReadAttr :: (x -> UI o) -> ReadAttr x o -mkReadAttr get = mkReadWriteAttr get (\_ _ -> return ()) +mkReadAttr geti = mkReadWriteAttr geti (\_ _ -> return ()) -- | Build attribute from a setter. mkWriteAttr :: (i -> x -> UI ()) -> WriteAttr x i -mkWriteAttr set = mkReadWriteAttr (\_ -> return ()) set +mkWriteAttr seto = mkReadWriteAttr (\_ -> return ()) seto -- | Turn a jQuery property @.prop()@ into an attribute. fromJQueryProp :: String -> (JSON.Value -> a) -> (a -> JSON.Value) -> Attr Element a -fromJQueryProp name from to = mkReadWriteAttr get set +fromJQueryProp name from to = mkReadWriteAttr geti seto where - set v el = runFunction $ ffi "$(%1).prop(%2,%3)" el name (to v) - get el = fmap from $ callFunction $ ffi "$(%1).prop(%2)" el name + seto v el = runFunction $ ffi "$(%1).prop(%2,%3)" el name (to v) + geti el = fmap from $ callFunction $ ffi "$(%1).prop(%2)" el name -- | Turn a JavaScript object property @.prop = ...@ into an attribute. fromObjectProperty :: (FromJS a, ToJS a) => String -> Attr Element a -fromObjectProperty name = mkReadWriteAttr get set +fromObjectProperty name = mkReadWriteAttr geti seto where - set v el = runFunction $ ffi ("%1." ++ name ++ " = %2") el v - get el = callFunction $ ffi ("%1." ++ name) el + seto v el = runFunction $ ffi ("%1." ++ name ++ " = %2") el v + geti el = callFunction $ ffi ("%1." ++ name) el {----------------------------------------------------------------------------- Widget class diff --git a/src/Graphics/UI/Threepenny/DragNDrop.hs b/src/Graphics/UI/Threepenny/DragNDrop.hs index 7b3c1a6..a168a3f 100644 --- a/src/Graphics/UI/Threepenny/DragNDrop.hs +++ b/src/Graphics/UI/Threepenny/DragNDrop.hs @@ -70,6 +70,7 @@ droppable = mkWriteAttr enable -- Change this to 'Maybe String' instead. type DragData = String +withDragData :: Event EventData -> Event String withDragData = fmap (extract . unsafeFromJSON) where extract [s] = s diff --git a/src/Graphics/UI/Threepenny/Elements.hs b/src/Graphics/UI/Threepenny/Elements.hs index 37b1989..9a5ce97 100644 --- a/src/Graphics/UI/Threepenny/Elements.hs +++ b/src/Graphics/UI/Threepenny/Elements.hs @@ -1,3 +1,4 @@ +{-# OPTIONS_GHC -Wno-missing-signatures #-} -- | Predefined DOM elements, for convenience. module Graphics.UI.Threepenny.Elements ( -- * Combinations and utilities @@ -22,7 +23,6 @@ module Graphics.UI.Threepenny.Elements ( ) where import Control.Monad -import Control.Monad.Trans.Reader import Graphics.UI.Threepenny.Core import Prelude hiding (div, map, span) diff --git a/src/Graphics/UI/Threepenny/Events.hs b/src/Graphics/UI/Threepenny/Events.hs index d2fdd8d..0c60530 100644 --- a/src/Graphics/UI/Threepenny/Events.hs +++ b/src/Graphics/UI/Threepenny/Events.hs @@ -18,6 +18,7 @@ module Graphics.UI.Threepenny.Events ( import Graphics.UI.Threepenny.Attributes import Graphics.UI.Threepenny.Core +silence :: Event a -> Event () silence = fmap (const ()) {----------------------------------------------------------------------------- @@ -27,6 +28,7 @@ silence = fmap (const ()) valueChange :: Element -> Event String valueChange el = unsafeMapUI el (const $ get value el) (domEvent "keydown" el) +unsafeMapUI :: Element -> (t -> UI b) -> Event t -> Event b unsafeMapUI el f = unsafeMapIO (\a -> getWindow el >>= \w -> runUI w (f a)) -- | Event that occurs when the /user/ changes the selection of a @