├── 0 ├── .gitignore ├── .travis.yml ├── CONTRIBUTING.md ├── ChangeLog.md ├── Dockerfile ├── LICENSE ├── README.md ├── Setup.hs ├── circle.yml ├── logo.png ├── src └── Transient │ ├── Backtrack.hs │ ├── Backtrackold.hs │ ├── Base.hs │ ├── EVars.hs │ ├── EVars.ioref.hs │ ├── EVars.old.hs │ ├── Indeterminism.hs │ ├── Internals.back.hs │ ├── Internals.back2.hs │ ├── Internals.cont.hs │ ├── Internals.cont2.hs │ ├── Internals.hs │ ├── Internals.stateio.hs │ ├── Logged.hs │ ├── Parse.hs │ └── Parse.new.hs ├── stack-ghcjs.yaml ├── stack.yaml ├── tests ├── Test.hs ├── Test2.hs ├── Test3.hs ├── TestSuite.hs ├── Testspark.hs ├── ghcjs-websockets.hs ├── labelthreads.hs ├── snippet ├── test5.hs ├── teststream.hs └── teststreamsocket.hs └── transient.cabal /0: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/transient-haskell/transient/301831888887fb199e9f9bfaba2502389e73bc93/0 -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | Demos/old-trash 2 | Demos/db 3 | Test 4 | errlog 5 | .tcachedata 6 | .cabal-sandbox 7 | cabal.sandbox* 8 | favicon 9 | IDE.session 10 | MFlow.lkshf 11 | notes.txt 12 | notes.lhs 13 | dist 14 | *.js* 15 | *.o 16 | *.hi 17 | .cabal-sandbox 18 | cabal.sanbox.config 19 | .stack* 20 | # emacs stuff 21 | *~ 22 | \#*\# 23 | /.emacs.desktop 24 | /.emacs.desktop.lock 25 | *.elc 26 | auto-save-list 27 | tramp 28 | .\#* 29 | 30 | # Org-mode 31 | .org-id-locations 32 | *_archive 33 | 34 | # flymake-mode 35 | *_flymake.* 36 | 37 | # eshell files 38 | /eshell/history 39 | /eshell/lastdir 40 | 41 | # elpa packages 42 | /elpa/ 43 | 44 | # vim stuff 45 | *.swp 46 | *.swo 47 | 48 | *.key 49 | _darcs 50 | darcs* 51 | -------------------------------------------------------------------------------- /.travis.yml: -------------------------------------------------------------------------------- 1 | # Use new container infrastructure to enable caching 2 | sudo: false 3 | 4 | # Choose a lightweight base image; we provide our own build tools. 5 | language: c 6 | 7 | # Caching so the next build will be fast too. 8 | cache: 9 | directories: 10 | - $HOME/.ghc 11 | - $HOME/.cabal 12 | - $HOME/.stack 13 | - $HOME/.ghcjs 14 | 15 | # The different configurations we want to test. We have BUILD=cabal which uses 16 | # cabal-install, and BUILD=stack which uses Stack. More documentation on each 17 | # of those below. 18 | # 19 | # We set the compiler values here to tell Travis to use a different 20 | # cache file per set of arguments. 21 | # 22 | # If you need to have different apt packages for each combination in the 23 | # matrix, you can use a line such as: 24 | # addons: {apt: {packages: [libfcgi-dev,libgmp-dev]}} 25 | matrix: 26 | include: 27 | # We grab the appropriate GHC and cabal-install versions from hvr's PPA. See: 28 | # https://github.com/hvr/multi-ghc-travis 29 | - env: BUILD=cabal GHCVER=8.0.1 CABALVER=1.24 30 | compiler: ": #GHC 8.0.1" 31 | addons: {apt: {packages: [cabal-install-1.24,ghc-8.0.1], sources: [hvr-ghc]}} 32 | - env: BUILD=cabal GHCVER=7.10.3 CABALVER=1.22 33 | compiler: ": #GHC 7.10.3" 34 | addons: {apt: {packages: [cabal-install-1.22,ghc-7.10.3], sources: [hvr-ghc]}} 35 | - env: BUILD=cabal GHCVER=7.10.2 CABALVER=1.22 36 | compiler: ": #GHC 7.10.2" 37 | addons: {apt: {packages: [cabal-install-1.22,ghc-7.10.2], sources: [hvr-ghc]}} 38 | 39 | # Build with the newest GHC and cabal-install. This is an accepted failure, 40 | # see below. 41 | - env: BUILD=cabal GHCVER=head CABALVER=head 42 | compiler: ": #GHC HEAD" 43 | addons: {apt: {packages: [cabal-install-head,ghc-head], sources: [hvr-ghc]}} 44 | 45 | # The Stack builds. We can pass in arbitrary Stack arguments via the ARGS 46 | # variable, such as using --stack-yaml to point to a different file. 47 | - env: BUILD=stack ARGS="--resolver lts-7" 48 | compiler: ": #stack 8.0.1 LTS 7" 49 | addons: {apt: {packages: [ghc-8.0.1], sources: [hvr-ghc]}} 50 | - env: BUILD=stack ARGS="--resolver lts-6" 51 | compiler: ": #stack 7.10.3 LTS 6" 52 | addons: {apt: {packages: [ghc-7.10.3], sources: [hvr-ghc]}} 53 | - env: BUILD=stack ARGS="--resolver lts-5" 54 | compiler: ": #stack 7.10.3 LTS 5" 55 | addons: {apt: {packages: [ghc-7.10.3], sources: [hvr-ghc]}} 56 | - env: BUILD=stack ARGS="--resolver lts-3" 57 | compiler: ": #stack 7.10.2 LTS 3" 58 | addons: {apt: {packages: [ghc-7.10.2], sources: [hvr-ghc]}} 59 | 60 | # Nightly builds are allowed to fail 61 | - env: BUILD=stack ARGS="--resolver nightly" 62 | compiler: ": #stack nightly" 63 | addons: {apt: {packages: [libgmp-dev]}} 64 | 65 | # GHCJS build via stack 66 | - env: BUILD=ghcjs ARGS="--stack-yaml=stack-ghcjs.yaml" 67 | compiler: ": #stack GHCJS" 68 | addons: {apt: {packages: [ghc-8.0.1], sources: [hvr-ghc]}} 69 | 70 | # Build on OS X in addition to Linux 71 | - env: BUILD=stack ARGS="--resolver lts-7" 72 | compiler: ": #stack 8.0.1 LTS 7 (OS X)" 73 | os: osx 74 | 75 | allow_failures: 76 | - env: BUILD=stack ARGS="--resolver lts-7" 77 | compiler: ": #stack 8.0.1 LTS 7 (OS X)" 78 | os: osx 79 | - env: BUILD=ghcjs ARGS="--stack-yaml=stack-ghcjs.yaml" 80 | - env: BUILD=cabal GHCVER=head CABALVER=head 81 | - env: BUILD=stack ARGS="--resolver nightly" 82 | 83 | before_install: 84 | # Using compiler above sets CC to an invalid value, so unset it 85 | - unset CC 86 | - export CASHER_TIME_OUT=600 87 | - if [ $BUILD = "ghcjs" ]; then nvm install 6; fi 88 | 89 | # We want to always allow newer versions of packages when building on GHC HEAD 90 | - CABALARGS="" 91 | - if [ "x$GHCVER" = "xhead" ]; then CABALARGS=--allow-newer; fi 92 | 93 | # Download and unpack the stack executable 94 | - export PATH=/opt/ghc/$GHCVER/bin:/opt/cabal/$CABALVER/bin:$HOME/.local/bin:$PATH 95 | - mkdir -p ~/.local/bin 96 | - | 97 | if [ `uname` = "Darwin" ] 98 | then 99 | curl --insecure -L https://www.stackage.org/stack/osx-x86_64 | tar xz --strip-components=1 --include '*/stack' -C ~/.local/bin 100 | else 101 | curl -L https://www.stackage.org/stack/linux-x86_64 | tar xz --wildcards --strip-components=1 -C ~/.local/bin '*/stack' 102 | fi 103 | 104 | install: 105 | - echo "$(ghc --version) [$(ghc --print-project-git-commit-id 2> /dev/null || echo '?')]" 106 | - if [ -f configure.ac ]; then autoreconf -i; fi 107 | - | 108 | case "$BUILD" in 109 | stack) 110 | stack --no-terminal --install-ghc $ARGS test --only-dependencies 111 | ;; 112 | cabal) 113 | cabal --version 114 | travis_retry cabal update 115 | cabal install --only-dependencies --enable-tests --enable-benchmarks --force-reinstalls --ghc-options=-O0 --reorder-goals --max-backjumps=-1 $CABALARGS 116 | ;; 117 | ghcjs) 118 | stack --no-terminal --install-ghc install hsc2hs 119 | stack --no-terminal setup $ARGS 120 | stack --no-terminal --install-ghc $ARGS test --only-dependencies 121 | ;; 122 | esac 123 | 124 | script: 125 | - | 126 | case "$BUILD" in 127 | cabal) 128 | cabal configure --enable-tests --enable-benchmarks -v2 --ghc-options="-O0 -Werror" 129 | cabal build 130 | cabal check || [ "$CABALVER" == "1.16" ] 131 | cabal test 132 | cabal sdist 133 | cabal copy 134 | SRC_TGZ=$(cabal info . | awk '{print $2;exit}').tar.gz && \ 135 | (cd dist && cabal install --force-reinstalls "$SRC_TGZ") 136 | ;; 137 | *) 138 | stack --no-terminal $ARGS test --haddock --no-haddock-deps 139 | ;; 140 | esac 141 | -------------------------------------------------------------------------------- /CONTRIBUTING.md: -------------------------------------------------------------------------------- 1 | # Contributing to Transient 2 | 3 | # Getting Started 4 | * Create a [GitHub](https://github.com) account if you do not already have one 5 | * Check if a ticket for your issue exists, if not create one 6 | * Make sure your ticket details the issue and the steps to reproduce the bug 7 | * If your ticket proposes a new feature for Transient, please provide an explanation of the feature, what problem it solves, and possible use cases 8 | * Fork the repository on GitHub 9 | 10 | # Changing Transient 11 | * Create a branch from `master` to work on your feature with a descriptive name 12 | * Make commits frequently with descriptive comments (detailed below) 13 | * Add tests to ensure proper functionality 14 | * Please do not submit until all tests are passed 15 | 16 | Commit messages should stick to the following format: `(issue number) issue name description` 17 | 18 | E.g: 19 | 20 | ``` 21 | Example issue 22 | Steps to recreate: 23 | - Put toast in oven 24 | - Turn oven off 25 | - ???? 26 | 27 | An issue would then here go into detail describing the issue, and perhaps even suggesting a fix 28 | ``` 29 | 30 | # Making Small Changes 31 | When changing things like documentation, it is not always necessary to create a ticket. Instead simply add the documentation, and send a PR with a message of the following form: 32 | 33 | ``` 34 | (doc) Added documentation to 35 | lacked proper documentation on how works. 36 | 37 | This commit adds documentation describing , and provides various examples. 38 | ``` 39 | 40 | # Submitting Changes 41 | * Push your changes to the branch in your fork of the repository 42 | * Submit a pull request 43 | * The Transient team will review your PR as quickly and provide feedback 44 | * After receiving feedback, either make the required changes, or your branch will be merged 45 | 46 | Thanks for contributing to Transient, happy hacking! 47 | -------------------------------------------------------------------------------- /ChangeLog.md: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/transient-haskell/transient/301831888887fb199e9f9bfaba2502389e73bc93/ChangeLog.md -------------------------------------------------------------------------------- /Dockerfile: -------------------------------------------------------------------------------- 1 | FROM agocorona/herokughcjs 2 | RUN git clone https://github.com/agocorona/transient transgit \ 3 | && cd transgit \ 4 | && git checkout ghcjs \ 5 | && cabal install 6 | 7 | RUN cd transgit && cabal install --ghcjs 8 | 9 | RUN git clone https://github.com/agocorona/ghcjs-perch \ 10 | && cd ghcjs-perch \ 11 | && cabal install \ 12 | && cabal install --ghcjs # 13 | 14 | RUN git clone https://github.com/agocorona/ghcjs-hplay \ 15 | && cd ghcjs-hplay \ 16 | && cabal install --ghcjs \ 17 | && cabal install 18 | 19 | ADD . /transient/ 20 | 21 | CMD cd /transient && chmod 777 buildrun.sh && ./buildrun.sh 22 | 23 | 24 | 25 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright © 2014-2016 Alberto G. Corona 2 | 3 | Permission is hereby granted, free of charge, to any person obtaining a copy of 4 | this software and associated documentation files (the "Software"), to deal in 5 | the Software without restriction, including without limitation the rights to 6 | use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of 7 | the Software, and to permit persons to whom the Software is furnished to do so, 8 | subject to the following conditions: 9 | 10 | The above copyright notice and this permission notice shall be included in all 11 | copies or substantial portions of the Software. 12 | 13 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 14 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS 15 | FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR 16 | COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER 17 | IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN 18 | CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | IMPORTANT NOTE: Transient is being translated to a new repo 2 | 3 | THIS REPO IS DEPRECATED 4 | 5 | Please, for the last version, go to: 6 | 7 | https://github.com/transient-haskell/transient-stack 8 | 9 | There is all the haskell packages, including distributed computing (transient-universe) and client-side web (axiom) 10 | 11 | ![Transient logo](https://github.com/transient-haskell/transient/raw/master/logo.png) 12 | ========= 13 | 14 | [![Hackage](https://img.shields.io/hackage/v/transient.svg)](http://hackage.haskell.org/package/transient) 15 | [![Stackage LTS](http://stackage.org/package/transient/badge/lts)](http://stackage.org/lts/package/transient) 16 | [![Stackage Nightly](http://stackage.org/package/transient/badge/nightly)](http://stackage.org/nightly/package/transient) 17 | [![Build Status](https://api.travis-ci.org/transient-haskell/transient.png?branch=master)](https://travis-ci.org/transient-haskell/transient) 18 | [![Gitter](https://badges.gitter.im/theam/haskell-do.svg)](https://gitter.im/Transient-Transient-Universe-HPlay/Lobby?utm_source=share-link&utm_medium=link&utm_campaign=share-link) 19 | 20 | [![Simple Haskell](http://simplehaskell.org/badges/badge.svg)](http://simplehaskell.org) 21 | [![Donate](https://www.paypalobjects.com/en_US/i/btn/btn_donate_LG.gif)](https://agocorona.github.io/donation.html) 22 | 23 | NOTE: distributed computing and web primitives Are in [transient-universe](https://github.com/transient-haskell/transient-universe) and [axiom](https://github.com/transient-haskell/axiom). Some examples at [transient-examples](https://github.com/transient-haskell/transient-examples) 24 | 25 | 26 | ## Some feedback on `transient`: 27 | 28 | 1. Rahul Muttineni @rahulmutt nov. 09 2016 03:40 Lead developper of ETA (the JVM Haskell compiler) 29 | 30 | *It's a bit mind bending in that it's like using a higher-level list monad, but it's very, very cool. For beginning Haskellers, what would be really useful is a visualisation of what happens when you do various distributed/parallel stuff.* **It's almost shocking how effortlessly you can run computations across threads/nodes.** 31 | 32 | *The cool part is the composability in the distributed setting. *You can make higher-order monadic functions that allow you to compose & reuse a long chain of distributed transactions via `wormhole` and `teleport`*. Another benefit is that the transaction becomes first class and* **you can see exactly what's going on in one place** *instead of distributing the logic across actors making the code equivalent to event callbacks, as you've stated.* 33 | 34 | https://gitter.im/Transient-Transient-Universe-HPlay/Lobby?at=58228caa35e6cf054773303b 35 | 36 | ## What is Transient? 37 | 38 | One of the dreams of software engineering is unrestricted composability. 39 | 40 | This may be put in these terms: 41 | 42 | let `ap1` and `ap2` two applications with arbitrary complexity, with all effects including multiple threads, asynchronous IO, indeterminism, events and perhaps, distributed computing. 43 | 44 | Then the combinations: 45 | 46 | - ap1 <|> ap2 -- Alternative expression 47 | - ap1 >>= \x -> ap2 -- monadic sequence 48 | - ap1 <> ap2 -- monoidal expression 49 | - (,) <$> ap1 <*> ap2 -- Applicative expression 50 | 51 | are possible if the types match, and generate new applications that are composable as well. 52 | 53 | Transient does exactly that. 54 | 55 | The operators `<$>` `<*>` and `<>` express concurrency, the operator `<|>` express parallelism and `>>=` for sequencing of threads, distributed processes or web widgets. So even in the presence of these effects and others, everything is composable. 56 | 57 | For this purpose transient is an extensible effects monad with all major effects and primitives for parallelism, events, asynchronous IO, early termination, non-determinism logging and distributed computing. Since it is possible to extend it with more effects without adding monad transformers, the composability is assured. 58 | 59 | Motivating example 60 | ================== 61 | This program, will stream "hello world" from N nodes if you enter "fire" in the console 62 | 63 | ```Haskell 64 | main= keep $ initNode $ inputNodes <|> distribStream 65 | 66 | distribStream= do 67 | local $ option "fire" "fire" 68 | r <- clustered . local . choose $ repeat "hello world" 69 | localIO $ print r 70 | ``` 71 | Read the tutorial to know how to compile and invoke it. 72 | 73 | This program will present a link in the browser and stream fibonnacci numbers to the browser when 74 | yo click it. (if you have Docker, you can run it straigh from the console; See [this](https://github.com/transient-haskell/axiom#how-to-install--run-fast) 75 | 76 | ```Haskell 77 | main= keep . initNode $ webFib 78 | 79 | webFib= onBrowser $ do 80 | local . render $ wlink () (h1 "hello fibonacci numbers") 81 | 82 | r <- atRemote $ do 83 | r <- local . threads 1 . choose $ take 10 fibs 84 | localIO $ print r 85 | localIO $ threadDelay 1000000 86 | return r 87 | 88 | local . render . rawHtml $ (h2 r) 89 | where 90 | fibs = 0 : 1 : zipWith (+) fibs (tail fibs) :: [Int] 91 | ``` 92 | 93 | This program combines both functionalities: 94 | 95 | ```haskell 96 | main= keep . initNode $ inputNodes <|> webFib <|> distribStream 97 | ``` 98 | 99 | Documentation 100 | ============= 101 | 102 | The [Wiki](https://github.com/agocorona/transient/wiki) is more user oriented 103 | 104 | My video sessions in [livecoding.tv](https://www.livecoding.tv/agocorona/videos/) not intended as tutorials or presentations, but show some of the latest features running. 105 | 106 | The articles are more technical: 107 | 108 | - [Philosophy, async, parallelism, thread control, events, Session state](https://www.schoolofhaskell.com/user/agocorona/EDSL-for-hard-working-IT-programmers) 109 | - [Backtracking and undoing IO transactions](https://www.schoolofhaskell.com/user/agocorona/the-hardworking-programmer-ii-practical-backtracking-to-undo-actions) 110 | - [Non-deterministic list like processing, multithreading](https://www.schoolofhaskell.com/user/agocorona/beautiful-parallel-non-determinism-transient-effects-iii) 111 | - [Distributed computing](https://www.schoolofhaskell.com/user/agocorona/moving-haskell-processes-between-nodes-transient-effects-iv) 112 | - [Publish-Subscribe variables](https://www.schoolofhaskell.com/user/agocorona/publish-subscribe-variables-transient-effects-v) 113 | - [Distributed streaming, map-reduce](https://www.schoolofhaskell.com/user/agocorona/estimation-of-using-distributed-computing-streaming-transient-effects-vi-1) 114 | 115 | These articles contain executable examples (not now, since the site no longer support the execution of haskell snippets). 116 | 117 | 118 | Plans 119 | ===== 120 | Once composability in the large is possible, there are a infinite quantity of ideas that may be realized. There are short term and long term goals. An status of development is regularly published in [![Gitter](https://badges.gitter.im/theam/haskell-do.svg)](https://gitter.im/Transient-Transient-Universe-HPlay/Lobby?utm_source=share-link&utm_medium=link&utm_campaign=share-link). 121 | 122 | Among the most crazy ones is the possibility of extending this framework to other languages and make them interoperable. treating whole packaged applications as components, and docking them as lego pieces in a new layer of the Operating system where the shell allows such kind of type safe docking. this composable docker allows all kinds of composability, while the current docker platform is just a form of degraded monoid that do not compute. 123 | 124 | Contribute: 125 | ========== 126 | Wanna contribute? Make sure that you've read our [contributor guidelines](https://github.com/transient-haskell/transient/blob/master/CONTRIBUTING.md). We'd like to hear from you and your ideas, get in touch with other contributors through: 127 | 128 | - [![Gitter](https://badges.gitter.im/theam/haskell-do.svg)](https://gitter.im/Transient-Transient-Universe-HPlay/Lobby?utm_source=share-link&utm_medium=link&utm_campaign=share-link) 129 | 130 | - [The issues page for transient](https://github.com/transient-haskell/transient/issues) 131 | - [The issues page for transient-universe](https://github.com/transient-haskell/transient-universe/issues) 132 | - [The issues page for axiom](https://github.com/transient-haskell/axiom/issues) 133 | 134 | Once you learn something interesting, you can [contribute to the wiki](https://github.com/transient-haskell/transient/wiki) 135 | 136 | [You can also donate](https://agocorona.github.io/donation.html) to the lead developer in order to make possible the dedication of more time to fullfil the potential advantages of true software composability across the whole stack. 137 | 138 | -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /circle.yml: -------------------------------------------------------------------------------- 1 | machine: 2 | environment: 3 | GHC: 8.0.1 4 | CABAL: 1.24 5 | NODE: 6.9.1 6 | ARGS: --stack-yaml stack-ghcjs.yaml 7 | PATH: $HOME/.local/bin:$PATH 8 | 9 | dependencies: 10 | cache_directories: 11 | - ~/.ghc 12 | - ~/.cabal 13 | - ~/.stack 14 | - ~/.ghcjs 15 | - ~/.local/bin 16 | pre: 17 | - cabal update 18 | - cabal install hsc2hs 19 | - mkdir -p ~/.local/bin 20 | - curl -L https://www.stackage.org/stack/linux-x86_64 \ 21 | | tar xz --wildcards --strip-components=1 -C ~/.local/bin '*/stack' 22 | - nvm install $NODE 23 | override: 24 | - stack --no-terminal setup $ARGS 25 | 26 | test: 27 | pre: 28 | - stack --no-terminal $ARGS test --only-dependencies 29 | override: 30 | - stack --no-terminal test $ARGS 31 | - stack --no-terminal haddock --no-haddock-deps $ARGS 32 | -------------------------------------------------------------------------------- /logo.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/transient-haskell/transient/301831888887fb199e9f9bfaba2502389e73bc93/logo.png -------------------------------------------------------------------------------- /src/Transient/Backtrack.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveDataTypeable #-} 2 | {-# LANGUAGE ExistentialQuantification #-} 3 | 4 | -- | Transient implements an event handling mechanism ("backtracking") which 5 | -- allows registration of one or more event handlers to be executed when an 6 | -- event occurs. This common underlying mechanism called is used to handle 7 | -- three different types of events: 8 | -- 9 | -- * User initiated actions to run undo and retry actions on failures 10 | -- * Finalization actions to run at the end of a task 11 | -- * Exception handlers to run when exceptions are raised 12 | -- 13 | -- Backtracking works seamlessly across thread boundaries. The freedom to put 14 | -- the undo, exception handling and finalization code where we want it allows 15 | -- us to write modular and composable code. 16 | -- 17 | -- Note that backtracking (undo, finalization or exception handling) does not 18 | -- change or automatically roll back the user defined state in any way. It only 19 | -- executes the user installed handlers. State changes are only caused via user 20 | -- defined actions. Any state changes done within the backtracking actions are 21 | -- accumulated on top of the user state as it was when backtracking started. 22 | -- This example prints the final state as "world". 23 | -- 24 | -- @ 25 | -- import Transient.Base (keep, setState, getState) 26 | -- import Transient.Backtrack (onUndo, undo) 27 | -- import Control.Monad.IO.Class (liftIO) 28 | -- 29 | -- main = keep $ do 30 | -- setState "hello" 31 | -- oldState <- getState 32 | -- 33 | -- liftIO (putStrLn "Register undo") \`onUndo` (do 34 | -- curState <- getState 35 | -- liftIO $ putStrLn $ "Final state: " ++ curState 36 | -- liftIO $ putStrLn $ "Old state: " ++ oldState) 37 | -- 38 | -- setState "world" >> undo >> return () 39 | -- @ 40 | -- 41 | -- See 42 | -- 43 | -- for more details. 44 | 45 | module Transient.Backtrack ( 46 | 47 | -- * Multi-track Undo 48 | -- $multitrack 49 | onBack, back, forward, backCut, 50 | 51 | -- * Default Track Undo 52 | -- $defaulttrack 53 | onUndo, undo, retry, undoCut, 54 | 55 | -- * Finalization Primitives 56 | -- $finalization 57 | onFinish, onFinish', finish, noFinish, initFinish 58 | ) where 59 | 60 | import Transient.Internals 61 | 62 | import Data.Typeable 63 | import Control.Applicative 64 | import Control.Monad.State 65 | import Unsafe.Coerce 66 | import System.Mem.StableName 67 | import Control.Exception 68 | import Control.Concurrent.STM hiding (retry) 69 | import Data.Maybe 70 | 71 | -- $defaulttrack 72 | -- 73 | -- A default undo track with the track id of type @()@ is provided. APIs for 74 | -- the default track are simpler as they do not require the track id argument. 75 | -- 76 | -- @ 77 | -- import Control.Concurrent (threadDelay) 78 | -- import Control.Monad.IO.Class (liftIO) 79 | -- import Transient.Base (keep) 80 | -- import Transient.Backtrack (onUndo, undo, retry) 81 | -- 82 | -- main = keep $ do 83 | -- step 1 >> tryAgain >> step 2 >> step 3 >> undo >> return () 84 | -- where 85 | -- step n = liftIO (putStrLn ("Do Step: " ++ show n)) 86 | -- \`onUndo` 87 | -- liftIO (putStrLn ("Undo Step: " ++ show n)) 88 | -- 89 | -- tryAgain = liftIO (putStrLn "Will retry on undo") 90 | -- \`onUndo` 91 | -- (retry >> liftIO (threadDelay 1000000 >> putStrLn "Retrying...")) 92 | -- @ 93 | 94 | -- $multitrack 95 | -- 96 | -- Transient allows you to pair an action with an undo action ('onBack'). As 97 | -- actions are executed the corresponding undo actions are saved. At any point 98 | -- an 'undo' can be triggered which executes all the undo actions registered 99 | -- till now in reverse order. At any point, an undo action can decide to resume 100 | -- forward execution by using 'forward'. 101 | -- 102 | -- Multiple independent undo tracks can be defined for different use cases. An 103 | -- undo track is identified by a user defined data type. The data type of each 104 | -- track must be distinct. 105 | -- 106 | -- @ 107 | -- import Control.Concurrent (threadDelay) 108 | -- import Control.Monad.IO.Class (liftIO) 109 | -- import Transient.Base (keep) 110 | -- import Transient.Backtrack (onBack, forward, back) 111 | -- 112 | -- data Track = Track String deriving Show 113 | -- 114 | -- main = keep $ do 115 | -- step 1 >> goForward >> step 2 >> step 3 >> back (Track \"Failed") >> return () 116 | -- where 117 | -- step n = liftIO (putStrLn $ "Execute Step: " ++ show n) 118 | -- \`onBack` 119 | -- \(Track r) -> liftIO (putStrLn $ show r ++ " Undo Step: " ++ show n) 120 | -- 121 | -- goForward = liftIO (putStrLn "Turning point") 122 | -- \`onBack` \(Track r) -> 123 | -- forward (Track r) 124 | -- >> (liftIO $ threadDelay 1000000 125 | -- >> putStrLn "Going forward...") 126 | -- @ 127 | 128 | -- $finalization 129 | -- 130 | -- Several finish handlers can be installed (using 'onFinish') that are called 131 | -- when the action is finalized using 'finish'. All the handlers installed 132 | -- until the last 'initFinish' are invoked in reverse order; thread boundaries 133 | -- do not matter. The following example prints "3" and then "2". 134 | -- 135 | -- @ 136 | -- import Control.Monad.IO.Class (liftIO) 137 | -- import Transient.Base (keep) 138 | -- import Transient.Backtrack (initFinish, onFinish, finish) 139 | -- 140 | -- main = keep $ do 141 | -- onFinish (\\_ -> liftIO $ putStrLn "1") 142 | -- initFinish 143 | -- onFinish (\\_ -> liftIO $ putStrLn "2") 144 | -- onFinish (\\_ -> liftIO $ putStrLn "3") 145 | -- finish Nothing 146 | -- return () 147 | -- @ 148 | 149 | -- 150 | --data Backtrack b= Show b =>Backtrack{backtracking :: Maybe b 151 | -- ,backStack :: [EventF] } 152 | -- deriving Typeable 153 | -- 154 | -- 155 | -- 156 | ---- | assures that backtracking will not go further back 157 | --backCut :: (Typeable reason, Show reason) => reason -> TransientIO () 158 | --backCut reason= Transient $ do 159 | -- delData $ Backtrack (Just reason) [] 160 | -- return $ Just () 161 | -- 162 | --undoCut :: TransientIO () 163 | --undoCut = backCut () 164 | -- 165 | ---- | the second parameter will be executed when backtracking 166 | --{-# NOINLINE onBack #-} 167 | --onBack :: (Typeable b, Show b) => TransientIO a -> ( b -> TransientIO a) -> TransientIO a 168 | --onBack ac bac= registerBack (typeof bac) $ Transient $ do 169 | -- Backtrack mreason _ <- getData `onNothing` backStateOf (typeof bac) 170 | -- runTrans $ case mreason of 171 | -- Nothing -> ac 172 | -- Just reason -> bac reason 173 | -- where 174 | -- typeof :: (b -> TransIO a) -> b 175 | -- typeof = undefined 176 | -- 177 | --onUndo :: TransientIO a -> TransientIO a -> TransientIO a 178 | --onUndo x y= onBack x (\() -> y) 179 | -- 180 | -- 181 | ---- | register an action that will be executed when backtracking 182 | --{-# NOINLINE registerUndo #-} 183 | --registerBack :: (Typeable b, Show b) => b -> TransientIO a -> TransientIO a 184 | --registerBack witness f = Transient $ do 185 | -- cont@(EventF _ _ x _ _ _ _ _ _ _ _) <- get -- !!> "backregister" 186 | -- 187 | -- md <- getData `asTypeOf` (Just <$> backStateOf witness) 188 | -- 189 | -- case md of 190 | -- Just (bss@(Backtrack b (bs@((EventF _ _ x' _ _ _ _ _ _ _ _):_)))) -> 191 | -- when (isNothing b) $ do 192 | -- addrx <- addr x 193 | -- addrx' <- addr x' -- to avoid duplicate backtracking points 194 | -- setData $ if addrx == addrx' then bss else Backtrack mwit (cont:bs) 195 | -- Nothing -> setData $ Backtrack mwit [cont] 196 | -- 197 | -- runTrans f 198 | -- where 199 | -- mwit= Nothing `asTypeOf` (Just witness) 200 | -- addr x = liftIO $ return . hashStableName =<< (makeStableName $! x) 201 | -- 202 | -- 203 | --registerUndo :: TransientIO a -> TransientIO a 204 | --registerUndo f= registerBack () f 205 | -- 206 | ---- | restart the flow forward from this point on 207 | --forward :: (Typeable b, Show b) => b -> TransIO () 208 | --forward reason= Transient $ do 209 | -- Backtrack _ stack <- getData `onNothing` (backStateOf reason) 210 | -- setData $ Backtrack(Nothing `asTypeOf` Just reason) stack 211 | -- return $ Just () 212 | -- 213 | --retry= forward () 214 | -- 215 | --noFinish= forward (FinishReason Nothing) 216 | -- 217 | ---- | execute backtracking. It execute the registered actions in reverse order. 218 | ---- 219 | ---- If the backtracking flag is changed the flow proceed forward from that point on. 220 | ---- 221 | ---- If the backtrack stack is finished or undoCut executed, `undo` will stop. 222 | --back :: (Typeable b, Show b) => b -> TransientIO a 223 | --back reason = Transient $ do 224 | -- bs <- getData `onNothing` backStateOf reason -- !!>"GOBACK" 225 | -- goBackt bs 226 | -- 227 | -- where 228 | -- 229 | -- goBackt (Backtrack _ [] )= return Nothing -- !!> "END" 230 | -- goBackt (Backtrack b (stack@(first : bs)) )= do 231 | -- (setData $ Backtrack (Just reason) stack) 232 | -- 233 | -- mr <- runClosure first -- !> "RUNCLOSURE" 234 | -- 235 | -- Backtrack back _ <- getData `onNothing` backStateOf reason 236 | -- -- !> "END RUNCLOSURE" 237 | -- case back of 238 | -- Nothing -> case mr of 239 | -- Nothing -> return empty -- !> "FORWARD END" 240 | -- Just x -> runContinuation first x -- !> "FORWARD EXEC" 241 | -- justreason -> goBackt $ Backtrack justreason bs -- !> ("BACK AGAIN",back) 242 | -- 243 | --backStateOf :: (Monad m, Show a, Typeable a) => a -> m (Backtrack a) 244 | --backStateOf reason= return $ Backtrack (Nothing `asTypeOf` (Just reason)) [] 245 | -- 246 | --undo :: TransIO a 247 | --undo= back () 248 | -- 249 | -------- finalization 250 | -- 251 | --newtype FinishReason= FinishReason (Maybe SomeException) deriving (Typeable, Show) 252 | -- 253 | ---- | initialize the event variable for finalization. 254 | ---- all the following computations in different threads will share it 255 | ---- it also isolate this event from other branches that may have his own finish variable 256 | --initFinish= backCut (FinishReason Nothing) 257 | -- 258 | ---- | set a computation to be called when the finish event happens 259 | --onFinish :: ((Maybe SomeException) ->TransIO ()) -> TransIO () 260 | --onFinish f= onFinish' (return ()) f 261 | -- 262 | -- 263 | ---- | set a computation to be called when the finish event happens this only apply for 264 | --onFinish' ::TransIO a ->((Maybe SomeException) ->TransIO a) -> TransIO a 265 | --onFinish' proc f= proc `onBack` \(FinishReason reason) -> 266 | -- f reason 267 | -- 268 | -- 269 | ---- | trigger the event, so this closes all the resources 270 | --finish :: Maybe SomeException -> TransIO a 271 | --finish reason= back (FinishReason reason) 272 | -- 273 | -- 274 | ---- | kill all the processes generated by the parameter when finish event occurs 275 | --killOnFinish comp= do 276 | -- chs <- liftIO $ newTVarIO [] 277 | -- onFinish $ const $ liftIO $ killChildren chs -- !> "killOnFinish event" 278 | -- r <- comp 279 | -- modify $ \ s -> s{children= chs} 280 | -- return r 281 | -- 282 | ---- | trigger finish when the stream of data ends 283 | --checkFinalize v= 284 | -- case v of 285 | -- SDone -> finish Nothing >> stop 286 | -- SLast x -> return x 287 | -- SError e -> liftIO ( print e) >> finish Nothing >> stop 288 | -- SMore x -> return x 289 | -------------------------------------------------------------------------------- /src/Transient/Backtrackold.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveDataTypeable #-} 2 | {-# LANGUAGE ExistentialQuantification #-} 3 | 4 | -- | 5 | 6 | module Transient.Backtrack (onUndo, undo, retry, undoCut,registerUndo, 7 | 8 | -- * generalized versions of backtracking with an extra parameter that gives the reason for going back 9 | -- different kinds of backtracking with different reasons can be managed in the same program 10 | onBack, back, forward, backCut,registerBack, 11 | 12 | -- * finalization primitives 13 | finish, onFinish, onFinish' ,initFinish , noFinish, killOnFinish ,checkFinalize , FinishReason 14 | ) where 15 | 16 | import Transient.Base 17 | import Transient.Internals((!>),EventF(..),killChildren,onNothing,runClosure,runContinuation) 18 | import Data.Typeable 19 | import Control.Applicative 20 | import Control.Monad.State 21 | import Unsafe.Coerce 22 | import System.Mem.StableName 23 | import Control.Exception 24 | import Control.Concurrent.STM hiding (retry) 25 | 26 | data Backtrack b= Show b =>Backtrack{backtracking :: Bool 27 | ,backStack :: [EventF] 28 | ,backReason :: b} 29 | deriving Typeable 30 | 31 | -- | assures that backtracking will not go further back 32 | backCut :: (Typeable reason, Show reason) => reason -> TransientIO () 33 | backCut reason= Transient $ do 34 | delData $ Backtrack False [] reason 35 | return $ Just () 36 | 37 | undoCut :: TransientIO () 38 | undoCut = backCut () 39 | 40 | -- | the second parameter will be executed when backtracking 41 | {-# NOINLINE onBack #-} 42 | onBack :: (Typeable b, Show b) => TransientIO a -> b -> TransientIO a -> TransientIO a 43 | onBack ac reason bac= registerBack reason $ Transient $ do 44 | liftIO $ print "onback" 45 | Backtrack back _ reas <- getData `onNothing` backStateOf reason !> typeOf reason 46 | return () !> ("ONBACK REASON",back,reas) 47 | runTrans $ if back then bac else ac 48 | 49 | onUndo :: TransientIO a -> TransientIO a -> TransientIO a 50 | onUndo x y= onBack x () y 51 | 52 | 53 | -- | register an action that will be executed when backtracking 54 | {-# NOINLINE registerUndo #-} 55 | registerBack :: (Typeable b, Show b) => b -> TransientIO a -> TransientIO a 56 | registerBack reason f = Transient $ do 57 | cont@(EventF _ _ x _ _ _ _ _ _ _ _) <- get -- !!> "backregister" 58 | 59 | md <- getData `asTypeOf` (Just <$> backStateOf reason) 60 | 61 | ss <- case md of 62 | Just (bss@(Backtrack b (bs@((EventF _ _ x' _ _ _ _ _ _ _ _):_))_)) -> do 63 | addrx <- addr x 64 | addrx' <- addr x' -- to avoid duplicate backtracking points 65 | return $ if addrx == addrx' then bss else Backtrack b (cont:bs) reason 66 | Nothing -> return $ Backtrack False [cont] reason 67 | setData ss 68 | runTrans f 69 | where 70 | addr x = liftIO $ return . hashStableName =<< (makeStableName $! x) 71 | 72 | 73 | registerUndo :: TransientIO a -> TransientIO a 74 | registerUndo f= registerBack () f 75 | 76 | -- | restart the flow forward from this point on 77 | forward :: (Typeable b, Show b) => b -> TransIO () 78 | forward reason= Transient $ do 79 | Backtrack _ stack _<- getData `onNothing` return (Backtrack False [] reason) 80 | setData $ Backtrack False stack reason 81 | return $ Just () 82 | 83 | retry= forward () 84 | 85 | noFinish= forward (FinishReason Nothing) 86 | 87 | -- | execute backtracking. It execute the registered actions in reverse order. 88 | -- 89 | -- If the backtracking flag is changed the flow proceed forward from that point on. 90 | -- 91 | --If the backtrack stack is finished or undoCut executed, `undo` will stop. 92 | back :: (Typeable b, Show b) => b -> TransientIO a 93 | back reason = Transient $ do 94 | bs <- getData `onNothing` backStateOf reason -- !!>"GOBACK" 95 | goBackt bs 96 | 97 | where 98 | 99 | goBackt (Backtrack _ [] _)= return Nothing -- !!> "END" 100 | goBackt (Backtrack b (stack@(first : bs)) _)= do 101 | setData $ Backtrack True stack reason !> ("REASOOOOOOOOOOOOOON", reason) 102 | setData reason 103 | mr <- runClosure first !> "RUNCLOSURE" 104 | 105 | Backtrack back _ r <- getData `onNothing` backStateOf reason 106 | -- !!>"END RUNCLOSURE" 107 | case back of 108 | True -> goBackt $ Backtrack True bs reason -- !!> "BACK AGAIN" 109 | False -> case mr of 110 | Nothing -> return empty -- !!> "FORWARD END" 111 | Just x -> runContinuation first x -- !!> "FORWARD EXEC" 112 | 113 | backStateOf :: (Monad m, Show a, Typeable a) => a -> m (Backtrack a) 114 | backStateOf reason= return $ Backtrack False [] reason 115 | 116 | undo :: TransIO a 117 | undo= back () 118 | 119 | ------ finalization 120 | 121 | newtype FinishReason= FinishReason (Maybe SomeException) deriving (Typeable, Show) 122 | 123 | -- | initialize the event variable for finalization. 124 | -- all the following computations in different threads will share it 125 | -- it also isolate this event from other branches that may have his own finish variable 126 | initFinish= backCut (FinishReason Nothing) 127 | 128 | -- | set a computation to be called when the finish event happens 129 | onFinish :: ((Maybe SomeException) ->TransIO ()) -> TransIO () 130 | onFinish f= onFinish' (return ()) f 131 | 132 | 133 | -- | set a computation to be called when the finish event happens this only apply for 134 | onFinish' ::TransIO a ->((Maybe SomeException) ->TransIO a) -> TransIO a 135 | onFinish' proc f= proc `onBack` (FinishReason Nothing) $ do 136 | Backtrack back _ (FinishReason reason) <- getData `onNothing` backStateOf (FinishReason Nothing) 137 | FinishReason reason <- getData `onNothing` return (FinishReason Nothing) 138 | f reason !> ("ONFINISH", reason) 139 | !> "onfinish" 140 | 141 | -- | trigger the event, so this closes all the resources 142 | finish :: Maybe SomeException -> TransIO a 143 | finish reason= back (FinishReason reason) 144 | 145 | 146 | -- | kill all the processes generated by the parameter when finish event occurs 147 | killOnFinish comp= do 148 | chs <- liftIO $ newTVarIO [] 149 | onFinish $ const $ liftIO $ killChildren chs -- !> "killOnFinish event" 150 | r <- comp 151 | modify $ \ s -> s{children= chs} 152 | return r 153 | 154 | -- | trigger finish when the stream of data ends 155 | checkFinalize v= 156 | case v of 157 | SDone -> finish Nothing >> stop 158 | SLast x -> return x 159 | SError e -> liftIO ( print e) >> finish Nothing >> stop 160 | SMore x -> return x 161 | -------------------------------------------------------------------------------- /src/Transient/Base.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ScopedTypeVariables #-} 2 | ----------------------------------------------------------------------------- 3 | -- 4 | -- Module : Base 5 | -- Copyright : 6 | -- License : MIT 7 | -- 8 | -- Maintainer : agocorona@gmail.com 9 | -- Stability : 10 | -- Portability : 11 | -- 12 | -- | Transient provides high level concurrency allowing you to do concurrent 13 | -- processing without requiring any knowledge of threads or synchronization. 14 | -- From the programmer's perspective, the programming model is single threaded. 15 | -- Concurrent tasks are created and composed seamlessly resulting in highly 16 | -- modular and composable concurrent programs. Transient has diverse 17 | -- applications from simple concurrent applications to massively parallel and 18 | -- distributed map-reduce problems. If you are considering Apache Spark or 19 | -- Cloud Haskell then transient might be a simpler yet better solution for you 20 | -- (see 21 | -- ). 22 | -- Transient makes it easy to write composable event driven reactive UI 23 | -- applications. For example, 24 | -- is a transient based unified client and server side framework that provides 25 | -- a better programming model and composability compared to frameworks like 26 | -- ReactJS. 27 | -- 28 | -- = Overview 29 | -- 30 | -- The 'TransientIO' monad allows you to: 31 | -- 32 | -- * Split a problem into concurrent task sets 33 | -- * Compose concurrent task sets using non-determinism 34 | -- * Collect and combine results of concurrent tasks 35 | -- 36 | -- You can think of 'TransientIO' as a concurrent list transformer monad with 37 | -- many other features added on top e.g. backtracking, logging and recovery to 38 | -- move computations across machines for distributed processing. 39 | -- 40 | -- == Non-determinism 41 | -- 42 | -- In its non-concurrent form, the 'TransientIO' monad behaves exactly like a 43 | -- . 44 | -- It is like a list whose elements are generated using IO effects. It composes 45 | -- in the same way as a list monad. Let's see an example: 46 | -- 47 | -- @ 48 | -- import Control.Concurrent (threadDelay) 49 | -- import Control.Monad.IO.Class (liftIO) 50 | -- import System.Random (randomIO) 51 | -- import Transient.Base (keep, threads, waitEvents) 52 | -- 53 | -- main = keep $ threads 0 $ do 54 | -- x <- waitEvents (randomIO :: IO Int) 55 | -- liftIO $ threadDelay 1000000 56 | -- liftIO $ putStrLn $ show x 57 | -- @ 58 | -- 59 | -- 'keep' runs the 'TransientIO' monad. The 'threads' primitive limits the 60 | -- number of threads to force non-concurrent operation. The 'waitEvents' 61 | -- primitive generates values (list elements) in a loop using the 'randomIO' IO 62 | -- action. The above code behaves like a list monad as if we are drawing 63 | -- elements from a list generated by 'waitEvents'. The sequence of actions 64 | -- following 'waitEvents' is executed for each element of the list. We see a 65 | -- random value printed on the screen every second. As you can see this 66 | -- behavior is identical to a list transformer monad. 67 | -- 68 | -- == Concurrency 69 | -- 70 | -- 'TransientIO' monad is a concurrent list transformer i.e. each element of 71 | -- the generated list can be processed concurrently. In the previous example 72 | -- if we change the number of threads to 10 we can see concurrency in action: 73 | -- 74 | -- @ 75 | -- ... 76 | -- main = keep $ threads 10 $ do 77 | -- ... 78 | -- @ 79 | -- 80 | -- Now each element of the list is processed concurrently in a separate thread, 81 | -- up to 10 threads are used. Therefore we see 10 results printed every second 82 | -- instead of 1 in the previous version. 83 | -- 84 | -- In the above examples the list elements are generated using a synchronous IO 85 | -- action. These elements can also be asynchronous events, for example an 86 | -- interactive user input. In transient, the elements of the list are known as 87 | -- tasks. The tasks terminology is general and intuitive in the context of 88 | -- transient as tasks can be triggered by asynchronous events and multiple of 89 | -- them can run simultaneously in an unordered fashion. 90 | -- 91 | -- == Composing Tasks 92 | -- 93 | -- The type @TransientIO a@ represents a /task set/ with each task in 94 | -- the set returning a value of type @a@. A task set could be /finite/ or 95 | -- /infinite/; multiple tasks could run simultaneously. The absence of a task, 96 | -- a void task set or failure is denoted by a special value 'empty' in an 97 | -- 'Alternative' composition, or the 'stop' primitive in a monadic composition. 98 | -- In the transient programming model the programmer thinks in terms of tasks 99 | -- and composes tasks. Whether the tasks run synchronously or concurrently does 100 | -- not matter; concurrency is hidden from the programmer for the most part. In 101 | -- the previous example the code written for a single threaded list transformer 102 | -- works concurrently as well. 103 | -- 104 | -- We have already seen that the 'Monad' instance provides a way to compose the 105 | -- tasks in a sequential, non-deterministic and concurrent manner. When a void 106 | -- task set is encountered, the monad stops processing any further computations 107 | -- as we have nothing to do. The following example does not generate any 108 | -- output after "stop here": 109 | -- 110 | -- @ 111 | -- main = keep $ threads 0 $ do 112 | -- x <- waitEvents (randomIO :: IO Int) 113 | -- liftIO $ threadDelay 1000000 114 | -- liftIO $ putStrLn $ "stop here" 115 | -- stop 116 | -- liftIO $ putStrLn $ show x 117 | -- @ 118 | -- 119 | -- When a task creation primitive creates a task concurrently in a new thread 120 | -- (e.g. 'waitEvents'), it returns a void task set in the current thread 121 | -- making it stop further processing. However, processing resumes from the same 122 | -- point onwards with the same state in the new task threads as and when they 123 | -- are created; as if the current thread along with its state has branched into 124 | -- multiple threads, one for each new task. In the following example you can 125 | -- see that the thread id changes after the 'waitEvents' call: 126 | -- 127 | -- @ 128 | -- main = keep $ threads 1 $ do 129 | -- mainThread <- liftIO myThreadId 130 | -- liftIO $ putStrLn $ "Main thread: " ++ show mainThread 131 | -- x <- waitEvents (randomIO :: IO Int) 132 | -- 133 | -- liftIO $ threadDelay 1000000 134 | -- evThread <- liftIO myThreadId 135 | -- liftIO $ putStrLn $ "Event thread: " ++ show evThread 136 | -- @ 137 | -- 138 | -- Note that if we use @threads 0@ then the new task thread is the same as the 139 | -- main thread because 'waitEvents' falls back to synchronous non-concurrent 140 | -- mode, and therefore returns a non void task set. 141 | -- 142 | -- In an 'Alternative' composition, when a computation results in 'empty' 143 | -- the next alternative is tried. When a task creation primitive creates a 144 | -- concurrent task, it returns 'empty' allowing tasks to run concurrently when 145 | -- composed with the '<|>' combinator. The following example combines two 146 | -- single concurrent tasks generated by 'async': 147 | -- 148 | -- @ 149 | -- main = keep $ do 150 | -- x <- event 1 \<|\> event 2 151 | -- liftIO $ putStrLn $ show x 152 | -- where event n = async (return n :: IO Int) 153 | -- @ 154 | -- 155 | -- Note that availability of threads can impact the behavior of an application. 156 | -- An infinite task set generator (e.g. 'waitEvents' or 'sample') running 157 | -- synchronously (due to lack of threads) can block all other computations in 158 | -- an 'Alternative' composition. The following example does not trigger the 159 | -- 'async' task unless we increase the number of threads to make 'waitEvents' 160 | -- asynchronous: 161 | -- 162 | -- @ 163 | -- main = keep $ threads 0 $ do 164 | -- x <- waitEvents (randomIO :: IO Int) \<|\> async (return 0 :: IO Int) 165 | -- liftIO $ threadDelay 1000000 166 | -- liftIO $ putStrLn $ show x 167 | -- @ 168 | -- 169 | -- == Parallel Map Reduce 170 | -- 171 | -- The following example uses 'choose' to send the items in a list to parallel 172 | -- tasks for squaring and then folds the results of those tasks using 'collect'. 173 | -- 174 | -- @ 175 | -- import Control.Monad.IO.Class (liftIO) 176 | -- import Data.List (sum) 177 | -- import Transient.Base (keep) 178 | -- import Transient.Indeterminism (choose, collect) 179 | -- 180 | -- main = keep $ do 181 | -- collect 100 squares >>= liftIO . putStrLn . show . sum 182 | -- where 183 | -- squares = do 184 | -- x <- choose [1..100] 185 | -- return (x * x) 186 | -- @ 187 | -- 188 | -- == State Isolation 189 | -- 190 | -- State is inherited but never shared. A transient application is written as 191 | -- a composition of task sets. New concurrent tasks can be triggered from 192 | -- inside a task. A new task inherits the state of the monad at the point 193 | -- where it got started. However, the state of a task is always completely 194 | -- isolated from other tasks irrespective of whether it is started in a new 195 | -- thread or not. The state is referentially transparent i.e. any changes to 196 | -- the state creates a new copy of the state. Therefore a programmer does not 197 | -- have to worry about synchronization or unintended side effects. 198 | -- 199 | -- The monad starts with an empty state. At any point you can add ('setData'), 200 | -- retrieve ('getSData') or delete ('delData') a data item to or from the 201 | -- current state. Creation of a task /branches/ the computation, inheriting 202 | -- the previous state, and collapsing (e.g. 'collect') discards the state of 203 | -- the tasks being collapsed. If you want to use the state in the results you 204 | -- will have to pass it as part of the results of the tasks. 205 | -- 206 | -- = Reactive Applications 207 | -- 208 | -- A popular model to handle asynchronous events in imperative languages is the 209 | -- callback model. The control flow of the program is driven by events and 210 | -- callbacks; callbacks are event handlers that are hooked into the event 211 | -- generation code and are invoked every time an event happens. This model 212 | -- makes the overall control flow hard to understand resulting into a "callback 213 | -- hell" because the logic is distributed across various isolated callback 214 | -- handlers, and many different event threads work on the same global state. 215 | -- 216 | -- Transient provides a better programming model for reactive applications. In 217 | -- contrast to the callback model, transient transparently moves the relevant 218 | -- state to the respective event threads and composes the results to arrive at 219 | -- the new state. The programmer is not aware of the threads, there is no 220 | -- shared state to worry about, and a seamless sequential flow enabling easy 221 | -- reasoning and composable application components. 222 | -- is a client and server 223 | -- side web UI and reactive application framework built using the transient 224 | -- programming model. 225 | -- 226 | -- = Further Reading 227 | -- 228 | -- * 229 | -- * 230 | -- 231 | ----------------------------------------------------------------------------- 232 | 233 | module Transient.Base( 234 | -- * The Monad 235 | TransIO, TransientIO 236 | 237 | -- * Task Composition Operators 238 | , (**>), (<**), (<***) 239 | 240 | -- * Running the monad 241 | ,keep, keep', stop, exit 242 | 243 | -- * Asynchronous console IO 244 | ,option, input,input' 245 | 246 | -- * Task Creation 247 | -- $taskgen 248 | , StreamData(..) 249 | ,parallel, async, waitEvents, sample, spawn, react, abduce 250 | 251 | -- * State management 252 | ,setData, getSData, getData, delData, modifyData, modifyData', try, setState, getState, delState, getRState,setRState, modifyState 253 | ,labelState, findState, killState 254 | 255 | -- * Thread management 256 | , threads,addThreads, freeThreads, hookedThreads,oneThread, killChilds 257 | 258 | -- * Exceptions 259 | -- $exceptions 260 | 261 | ,onException, onException', cutExceptions, continue, catcht, throwt 262 | 263 | -- * Utilities 264 | ,genId, Loggable 265 | ) 266 | 267 | where 268 | 269 | 270 | import Transient.Internals 271 | 272 | -- $taskgen 273 | -- 274 | -- These primitives are used to create asynchronous and concurrent tasks from 275 | -- an IO action. 276 | -- 277 | 278 | -- $exceptions 279 | -- 280 | -- Exception handlers are implemented using the backtracking mechanism. 281 | -- (see 'Transient.Backtrack.back'). Several exception handlers can be 282 | -- installed using 'onException'; handlers are run in reverse order when an 283 | -- exception is raised. The following example prints "3" and then "2". 284 | -- 285 | -- @ 286 | -- {-\# LANGUAGE ScopedTypeVariables #-} 287 | -- import Transient.Base (keep, onException, cutExceptions) 288 | -- import Control.Monad.IO.Class (liftIO) 289 | -- import Control.Exception (ErrorCall) 290 | -- 291 | -- main = keep $ do 292 | -- onException $ \\(e:: ErrorCall) -> liftIO $ putStrLn "1" 293 | -- cutExceptions 294 | -- onException $ \\(e:: ErrorCall) -> liftIO $ putStrLn "2" 295 | -- onException $ \\(e:: ErrorCall) -> liftIO $ putStrLn "3" 296 | -- liftIO $ error "Raised ErrorCall exception" >> return () 297 | -- @ 298 | -------------------------------------------------------------------------------- /src/Transient/EVars.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveDataTypeable #-} 2 | module Transient.EVars where 3 | 4 | import Transient.Internals 5 | import Data.Typeable 6 | 7 | import Control.Applicative 8 | import Control.Concurrent.STM 9 | import Control.Monad.State 10 | 11 | 12 | 13 | 14 | 15 | data EVar a= EVar (TChan (StreamData a)) deriving Typeable 16 | 17 | 18 | -- | creates an EVar. 19 | -- 20 | -- Evars are event vars. `writeEVar` trigger the execution of all the continuations associated to the `readEVar` of this variable 21 | -- (the code that is after them). 22 | -- 23 | -- It is like the publish-subscribe pattern but without inversion of control, since a readEVar can be inserted at any place in the 24 | -- Transient flow. 25 | -- 26 | -- EVars are created upstream and can be used to communicate two sub-threads of the monad. Following the Transient philosophy they 27 | -- do not block his own thread if used with alternative operators, unlike the IORefs and TVars. And unlike STM vars, that are composable, 28 | -- they wait for their respective events, while TVars execute the whole expression when any variable is modified. 29 | -- 30 | -- The execution continues after the writeEVar when all subscribers have been executed. 31 | -- 32 | -- Now the continuations are executed in parallel. 33 | -- 34 | -- see https://www.fpcomplete.com/user/agocorona/publish-subscribe-variables-transient-effects-v 35 | -- 36 | 37 | newEVar :: TransIO (EVar a) 38 | newEVar = Transient $ do 39 | ref <-liftIO newBroadcastTChanIO 40 | return . Just $ EVar ref 41 | 42 | -- | delete al the subscriptions for an evar. 43 | cleanEVar :: EVar a -> TransIO () 44 | cleanEVar (EVar ref1)= liftIO $ atomically $ writeTChan ref1 SDone 45 | 46 | 47 | -- | read the EVar. It only succeed when the EVar is being updated 48 | -- The continuation gets registered to be executed whenever the variable is updated. 49 | -- 50 | -- if readEVar is re-executed in any kind of loop, since each continuation is different, this will register 51 | -- again. The effect is that the continuation will be executed multiple times 52 | -- To avoid multiple registrations, use `cleanEVar` 53 | readEVar :: EVar a -> TransIO a 54 | readEVar (EVar ref1)= do 55 | tchan <- liftIO . atomically $ dupTChan ref1 56 | r <- parallel $ atomically $ readTChan tchan 57 | case r of 58 | SDone -> empty 59 | SMore x -> return x 60 | SLast x -> return x 61 | SError e -> empty 62 | -- error $ "readEVar: "++ show e 63 | 64 | -- | update the EVar and execute all readEVar blocks with "last in-first out" priority 65 | -- 66 | writeEVar :: EVar a -> a -> TransIO () 67 | writeEVar (EVar ref1) x= liftIO $ atomically $ do 68 | writeTChan ref1 $ SMore x 69 | 70 | 71 | -- | write the EVar and drop all the `readEVar` handlers. 72 | -- 73 | -- It is like a combination of `writeEVar` and `cleanEVar` 74 | lastWriteEVar (EVar ref1) x= liftIO $ atomically $ do 75 | writeTChan ref1 $ SLast x 76 | 77 | 78 | 79 | -------------------------------------------------------------------------------- /src/Transient/EVars.ioref.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveDataTypeable #-} 2 | module Transient.EVars where 3 | 4 | import Transient.Base 5 | import qualified Data.Map as M 6 | import Data.Typeable 7 | 8 | import Control.Concurrent 9 | import Control.Applicative 10 | import Control.Concurrent.MVar 11 | import Data.IORef 12 | import Control.Monad.State 13 | import Data.List(nub) 14 | 15 | newtype EVars= EVars (IORef (M.Map Int [EventF])) deriving Typeable 16 | 17 | data EVar a= EVar Int (IORef [a]) deriving Typeable 18 | 19 | 20 | -- | creates an EVar. 21 | -- 22 | -- Evars are event vars. `writeEVar` trigger the execution of all the continuations associated to the `readEVar` of this variable 23 | -- (the code that is after them) as stack: the most recent reads are executed first. 24 | -- 25 | -- It is like the publish-subscribe pattern but without inversion of control, since a readEVar can be inserted at any place in the 26 | -- Transient flow. 27 | -- 28 | -- EVars are created upstream and can be used to communicate two sub-threads of the monad. Following the Transient philosophy they 29 | -- do not block his own thread if used with alternative operators, unlike the IORefs and TVars. And unlike STM vars, that are composable, 30 | -- they wait for their respective events, while TVars execute the whole expression when any variable is modified. 31 | -- 32 | -- The execution continues after the writeEVar when all subscribers have been executed. 33 | -- 34 | -- see https://www.fpcomplete.com/user/agocorona/publish-subscribe-variables-transient-effects-v 35 | -- 36 | 37 | newEVar :: TransientIO (EVar a) 38 | newEVar = Transient $ do 39 | getData `onNothing` do -- initialize EVars 40 | ref <- liftIO $ newIORef M.empty 41 | setData $ EVars ref 42 | return (EVars ref) 43 | id <- genId 44 | 45 | ref <-liftIO $ newIORef [] 46 | return . Just $ EVar id ref 47 | 48 | -- | delete al the subscriptions for an evar. 49 | delEVar :: EVar a -> TransIO () 50 | delEVar (EVar id _)= Transient $ do 51 | EVars ref <- getData `onNothing` error "No Events context" 52 | map <- liftIO $ readIORef ref 53 | liftIO $ writeIORef ref $ M.delete id map 54 | return $ Just () 55 | 56 | -- | read the EVar. It only succeed when the EVar is being updated 57 | -- The continuation gets registered to be executed whenever the variable is updated. 58 | -- if readEVar is in any kind of loop, since each continuation is different, this will register 59 | -- again the continuation. The effect is that the continuation will be executed multiple times 60 | -- To avoid multiple registrations, use `unsubscribe` 61 | readEVar :: EVar a -> TransIO a 62 | readEVar (EVar id ref1)= Transient $ do 63 | mr <- liftIO $ readIORef ref1 !> "READEVAR" 64 | case mr of 65 | (c:_) -> do return $ Just c !> "being executed" 66 | [] -> do 67 | cont <- get !> "SETTING THE EVAR" 68 | EVars ref <- getData `onNothing` error "No EVars context" 69 | map <- liftIO $ readIORef ref 70 | let Just conts= M.lookup id map <|> Just [] 71 | liftIO $ writeIORef ref $ M.insert id (cont:conts) map 72 | return Nothing 73 | 74 | -- | update the EVar and execute all readEVar blocks with "last in-first out" priority 75 | writeEVar (EVar id ref1) x= Transient $ do 76 | EVars revars <- getData `onNothing` error "No Events context" 77 | liftIO $ do 78 | (atomicModifyIORef' ref1 $ \xs -> (xs ++[x],())) -- !> "writeEVar" 79 | loop revars 80 | return $ Just () 81 | where 82 | loop revars= do 83 | map <- readIORef revars 84 | let Just conts = M.lookup id map <|> Just [] 85 | len= length conts 86 | runCont' len id revars 87 | rs <- (atomicModifyIORef' ref1 $ \xs -> (tail xs,tail xs)) !> "finish executing" 88 | if not $ null rs then loop revars else return $ Just () 89 | 90 | 91 | 92 | 93 | runCont' 0 _ _ = return () 94 | runCont' n id revars= do 95 | map <- liftIO $ readIORef revars !> "runCont'" 96 | let Just conts= M.lookup id map <|> Just [] 97 | let current= head conts 98 | nexts= tail conts 99 | -- let env = mfData current 100 | -- modify $ \s-> s{mfData= env} -- !> ("registered:", length conts) 101 | -- runCont current !> "Run continuation event handler" 102 | runStateT (runCont current) current !> "before" 103 | map' <- liftIO $ readIORef revars !> "after" 104 | let Just conts'= M.lookup id map' <|> Just [] 105 | if (length conts /= length conts') -- to avoid infinite loops due to re-registrations 106 | then error "read of an EVar more than one time without using unsubscribe. Probably in code called repeatedly" 107 | else liftIO $ writeIORef revars $ M.insert id (nexts ++ [current]) map 108 | runCont' (n - 1) id revars 109 | 110 | -- | unsuscribe the last `readEVar` executed for this EVar 111 | unsubscribe (EVar id _)= Transient $ do 112 | EVars revars <- getData `onNothing` error "No Events context" 113 | map <- liftIO $ readIORef revars 114 | let Just conts = M.lookup id map <|> Just [] 115 | liftIO $ writeIORef revars $ M.insert id (tail conts) map 116 | 117 | return $ Just () 118 | 119 | 120 | -------------------------------------------------------------------------------- /src/Transient/EVars.old.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveDataTypeable #-} 2 | module Transient.EVars where 3 | 4 | import Transient.Base 5 | import Transient.Internals(runTransState,onNothing, EventF(..), killChildren) 6 | import qualified Data.Map as M 7 | import Data.Typeable 8 | 9 | import Control.Concurrent 10 | import Control.Applicative 11 | import Control.Concurrent.STM 12 | import Control.Monad.IO.Class 13 | import Control.Exception(SomeException) 14 | 15 | import Data.List(nub) 16 | import Control.Monad.State 17 | 18 | 19 | 20 | data EVar a= EVar Int (TVar (Int,Int)) (TChan (StreamData a)) deriving Typeable 21 | 22 | 23 | -- | creates an EVar. 24 | -- 25 | -- Evars are event vars. `writeEVar` trigger the execution of all the continuations associated to the `readEVar` of this variable 26 | -- (the code that is after them). 27 | -- 28 | -- It is like the publish-subscribe pattern but without inversion of control, since a readEVar can be inserted at any place in the 29 | -- Transient flow. 30 | -- 31 | -- EVars are created upstream and can be used to communicate two sub-threads of the monad. Following the Transient philosophy they 32 | -- do not block his own thread if used with alternative operators, unlike the IORefs and TVars. And unlike STM vars, that are composable, 33 | -- they wait for their respective events, while TVars execute the whole expression when any variable is modified. 34 | -- 35 | -- The execution continues after the writeEVar when all subscribers have been executed. 36 | -- 37 | -- Now the continuations are executed in parallel. 38 | -- 39 | -- see https://www.fpcomplete.com/user/agocorona/publish-subscribe-variables-transient-effects-v 40 | -- 41 | 42 | newEVar :: TransIO (EVar a) 43 | newEVar = Transient $ do 44 | id <- genId 45 | rn <- liftIO $ newTVarIO (0,0) 46 | ref <-liftIO newTChanIO 47 | return . Just $ EVar id rn ref 48 | 49 | -- | delete al the subscriptions for an evar. 50 | cleanEVar :: EVar a -> TransIO () 51 | cleanEVar (EVar id rn ref1)= liftIO $ atomically $ do 52 | writeTChan ref1 SDone 53 | writeTVar rn (0,0) 54 | 55 | -- | read the EVar. It only succeed when the EVar is being updated 56 | -- The continuation gets registered to be executed whenever the variable is updated. 57 | -- 58 | -- if readEVar is re-executed in any kind of loop, since each continuation is different, this will register 59 | -- again. The effect is that the continuation will be executed multiple times 60 | -- To avoid multiple registrations, use `cleanEVar` 61 | readEVar (EVar id rn ref1)= freeThreads $ do 62 | liftIO $ atomically $ readTVar rn >>= \(n,n') -> writeTVar rn $ (n+1,n'+1) 63 | r <- parallel $ atomically $ do 64 | r <- peekTChan ref1 65 | ---- return () !> "peekTChan executed" 66 | (n,n') <- readTVar rn -- !> "readtvar rn" 67 | -- return () !> ("rn",n) 68 | if n'> 1 then do 69 | writeTVar rn (n,n'-1) 70 | return r 71 | else do 72 | readTChan ref1 73 | writeTVar rn (n,n) 74 | return r 75 | 76 | case r of 77 | SDone -> empty 78 | SMore x -> return x 79 | SLast x -> return x 80 | SError e -> liftIO $ do 81 | atomically $ readTVar rn >>= \(n,n') -> writeTVar rn $ (n-1,n'-1) 82 | myThreadId >>= killThread 83 | error $ "readEVar: "++ show e 84 | 85 | -- | update the EVar and execute all readEVar blocks with "last in-first out" priority 86 | -- 87 | writeEVar (EVar id rn ref1) x= liftIO $ atomically $ do 88 | writeTChan ref1 $ SMore x 89 | 90 | 91 | -- | write the EVar and drop all the `readEVar` handlers. 92 | -- 93 | -- It is like a combination of `writeEVar` and `cleanEVar` 94 | lastWriteEVar (EVar id rn ref1) x= liftIO $ atomically $ do 95 | writeTChan ref1 $ SLast x 96 | 97 | 98 | -- Finalization 99 | 100 | 101 | type FinishReason= Maybe SomeException 102 | 103 | 104 | 105 | data Finish= Finish (EVar FinishReason) deriving Typeable 106 | 107 | -- | initialize the event variable for finalization. 108 | -- all the following computations in different threads will share it 109 | -- it also isolate this event from other branches that may have his own finish variable 110 | initFinish :: TransIO Finish 111 | initFinish= do 112 | fin <- newEVar 113 | let f = Finish fin 114 | setData f 115 | return f 116 | 117 | -- | set a computation to be called when the finish event happens 118 | onFinish :: (FinishReason ->TransIO ()) -> TransIO () 119 | onFinish close= do 120 | Finish finish <- getSData <|> initFinish 121 | e <- readEVar finish 122 | close e -- !!> "CLOSE" 123 | stop 124 | <|> 125 | return () 126 | 127 | 128 | 129 | -- | trigger the event, so this closes all the resources 130 | finish :: FinishReason -> TransIO () 131 | finish e= do 132 | liftIO $ putStr "finish: " >> print e 133 | Finish finish <- getSData <|> initFinish 134 | lastWriteEVar finish e 135 | 136 | -- | deregister all the finalization actions. 137 | -- A initFinish is needed to register actions again 138 | unFinish= do 139 | Finish fin <- getSData 140 | cleanEVar fin -- !!> "DELEVAR" 141 | <|> return () -- !!> "NOT DELEVAR" 142 | 143 | 144 | -- | kill all the processes generated by the parameter when finish event occurs 145 | killOnFinish comp= do 146 | 147 | chs <- liftIO $ newTVarIO [] 148 | onFinish $ const $ liftIO $ killChildren chs -- !> "killOnFinish event" 149 | r <- comp 150 | modify $ \ s -> s{children= chs} 151 | return r 152 | 153 | -- | trigger finish when the stream data return SDone 154 | checkFinalize v= 155 | case v of 156 | SDone -> finish Nothing >> stop 157 | SLast x -> return x 158 | SError e -> liftIO ( print e) >> finish Nothing >> stop 159 | SMore x -> return x 160 | 161 | -------------------------------------------------------------------------------- /src/Transient/Indeterminism.hs: -------------------------------------------------------------------------------- 1 | ----------------------------------------------------------------------------- 2 | -- 3 | -- Module : Transient.Indeterminism 4 | -- Copyright : 5 | -- License : MIT 6 | -- 7 | -- Maintainer : agocorona@gmail.com 8 | -- Stability : 9 | -- Portability : 10 | -- 11 | -- | see 12 | -- 13 | ----------------------------------------------------------------------------- 14 | {-# LANGUAGE ScopedTypeVariables, CPP #-} 15 | module Transient.Indeterminism ( 16 | choose, choose', chooseStream, collect, collect', group, groupByTime, burst 17 | ) where 18 | 19 | import Transient.Internals hiding (retry) 20 | 21 | import Data.IORef 22 | import Control.Applicative 23 | import Data.Monoid 24 | import Control.Concurrent 25 | import Data.Typeable 26 | import Control.Monad.State 27 | import GHC.Conc 28 | import Data.Time.Clock 29 | import Control.Exception 30 | 31 | 32 | 33 | 34 | -- | Converts a list of pure values into a transient task set. You can use the 35 | -- 'threads' primitive to control the parallelism. 36 | -- 37 | choose :: [a] -> TransIO a 38 | choose []= empty 39 | choose xs = chooseStream xs >>= checkFinalize 40 | 41 | -- | transmit the end of stream 42 | chooseStream :: [a] -> TransIO (StreamData a) 43 | chooseStream []= empty 44 | chooseStream xs = do 45 | evs <- liftIO $ newIORef xs 46 | parallel $ do 47 | es <- atomicModifyIORef evs $ \es -> let tes= tail es in (tes,es) 48 | case es of 49 | [x] -> x `seq` return $ SLast x 50 | x:_ -> x `seq` return $ SMore x 51 | 52 | 53 | -- | Same as 'choose', slower in some cases 54 | -- 55 | choose' :: [a] -> TransIO a 56 | choose' xs = foldl (<|>) empty $ map (async . return) xs 57 | 58 | 59 | -- | Collect the results of a task set in groups of @n@ elements. 60 | -- 61 | group :: Int -> TransIO a -> TransIO [a] 62 | group num proc = do 63 | v <- liftIO $ newIORef (0,[]) 64 | x <- proc 65 | 66 | mn <- liftIO $ atomicModifyIORef v $ \(n,xs) -> 67 | let n'=n +1 68 | in if n'== num 69 | 70 | then ((0,[]), Just $ x:xs) 71 | else ((n', x:xs),Nothing) 72 | case mn of 73 | Nothing -> stop 74 | Just xs -> return xs 75 | 76 | -- | Collect the results of a task set, grouping all results received within 77 | -- every time interval specified by the first parameter as `diffUTCTime`. 78 | -- 79 | 80 | {- 81 | groupByTime1 time proc = do 82 | t <- liftIO getCurrentTime 83 | 84 | v <- liftIO $ newIORef (0,t,[]) 85 | 86 | x <- proc 87 | t' <- liftIO getCurrentTime 88 | mn <- liftIO $ atomicModifyIORef v $ \(n,t,xs) -> let n'=n +1 89 | in 90 | if diffUTCTime t' t < fromIntegral time 91 | then ((n',t, x:xs),Nothing) 92 | else ((0 ,t',[]), Just $ x:xs) 93 | case mn of 94 | Nothing -> stop 95 | Just xs -> return xs 96 | -} 97 | 98 | -- | Collect the results of the first @n@ tasks. Synchronizes concurrent tasks 99 | -- to collect the results safely and kills all the non-free threads before 100 | -- returning the results. Results are returned in the thread where 'collect' 101 | -- is called. 102 | -- 103 | collect :: Int -> TransIO a -> TransIO [a] 104 | collect n = collect' n 0 105 | 106 | -- | Like 'collect' but with a timeout. When the timeout is zero it behaves 107 | -- exactly like 'collect'. If the timeout (second parameter) is non-zero, 108 | -- collection stops after the timeout and the results collected till now are 109 | -- returned. 110 | -- 111 | collect' :: Int -> Int -> TransIO a -> TransIO [a] 112 | collect' n t search= do 113 | 114 | 115 | rv <- liftIO $ newEmptyMVar -- !> "NEWMVAR" 116 | 117 | results <- liftIO $ newIORef (0,[]) 118 | 119 | let worker = do 120 | r <- abduce >> search 121 | liftIO $ putMVar rv $ Just r 122 | stop 123 | 124 | timer= do 125 | when (t > 0) $ do 126 | addThreads 1 127 | async $ threadDelay t >> putMVar rv Nothing 128 | empty 129 | 130 | monitor= liftIO loop 131 | 132 | where 133 | loop = do 134 | mr <- takeMVar rv 135 | 136 | (n',rs) <- readIORef results 137 | case mr of 138 | Nothing -> return rs 139 | Just r -> do 140 | let n''= n' + 1 141 | let rs'= r:rs 142 | writeIORef results (n'',rs') 143 | 144 | t' <- getCurrentTime 145 | if (n > 0 && n'' >= n) 146 | then return (rs') 147 | else loop 148 | `catch` \(e :: BlockedIndefinitelyOnMVar) -> 149 | readIORef results >>= return . snd 150 | 151 | 152 | oneThread $ timer <|> worker <|> monitor 153 | 154 | 155 | -- | insert `SDone` response every time there is a timeout since the last response 156 | 157 | burst :: Int -> TransIO a -> TransIO (StreamData a) 158 | burst timeout comp= do 159 | r <- oneThread comp 160 | return (SMore r) <|> (async (threadDelay timeout) >> return SDone) 161 | 162 | groupByTime :: Monoid a => Int -> TransIO a -> TransIO a 163 | groupByTime timeout comp= do 164 | v <- liftIO $ newIORef mempty 165 | gather v <|> run v 166 | where 167 | run v = do 168 | x <- comp 169 | liftIO $ atomicModifyIORef v $ \xs -> (xs <> x,()) 170 | empty 171 | 172 | gather v= waitEvents $ do 173 | threadDelay timeout 174 | atomicModifyIORef v $ \xs -> (mempty , xs) 175 | 176 | 177 | 178 | -------------------------------------------------------------------------------- /src/Transient/Internals.cont.hs: -------------------------------------------------------------------------------- 1 | ----------------------------------------------------------------------------- 2 | -- 3 | -- Module : Base 4 | -- Copyright : 5 | -- License : MIT 6 | -- 7 | -- Maintainer : agocorona@gmail.com 8 | -- Stability : 9 | -- Portability : 10 | -- 11 | -- | See http://github.com/agocorona/transient 12 | -- Everything in this module is exported in order to allow extensibility. 13 | ----------------------------------------------------------------------------- 14 | {-# LANGUAGE ScopedTypeVariables #-} 15 | {-# LANGUAGE ExistentialQuantification #-} 16 | {-# LANGUAGE FlexibleContexts #-} 17 | {-# LANGUAGE FlexibleInstances #-} 18 | {-# LANGUAGE MultiParamTypeClasses #-} 19 | {-# LANGUAGE DeriveDataTypeable #-} 20 | {-# LANGUAGE UndecidableInstances #-} 21 | {-# LANGUAGE Rank2Types #-} 22 | {-# LANGUAGE RecordWildCards #-} 23 | {-# LANGUAGE CPP #-} 24 | {-# LANGUAGE InstanceSigs #-} 25 | {-# LANGUAGE ConstraintKinds #-} 26 | 27 | module Transient.Internals where 28 | 29 | import Control.Applicative 30 | import Control.Monad.State 31 | import Data.Dynamic 32 | import qualified Data.Map as M 33 | import System.IO.Unsafe 34 | import Unsafe.Coerce 35 | import Control.Exception hiding (try,onException) 36 | import qualified Control.Exception (try) 37 | import Control.Concurrent 38 | import GHC.Conc(unsafeIOToSTM) 39 | import Control.Concurrent.STM hiding (retry) 40 | import qualified Control.Concurrent.STM as STM (retry) 41 | import System.Mem.StableName 42 | import Data.Maybe 43 | 44 | import Data.List 45 | import Data.IORef 46 | import System.Environment 47 | import System.IO 48 | 49 | import qualified Data.ByteString.Char8 as BS 50 | import Data.Atomics 51 | 52 | #ifdef DEBUG 53 | 54 | import Data.Monoid 55 | import Debug.Trace 56 | import System.Exit 57 | 58 | {-# INLINE (!>) #-} 59 | (!>) :: Show a => b -> a -> b 60 | (!>) x y = trace (show y) x 61 | infixr 0 !> 62 | 63 | #else 64 | 65 | {-# INLINE (!>) #-} 66 | (!>) :: a -> b -> a 67 | (!>) = const 68 | 69 | 70 | #endif 71 | 72 | type SData= () 73 | 74 | data LifeCycle = Alive | Parent | Listener | Dead 75 | deriving (Eq, Show) 76 | 77 | -- | EventF describes the context of a TransientIO computation: 78 | data EventF = EventF 79 | { mfData :: M.Map TypeRep SData 80 | -- ^ State data accessed with get or put operations 81 | 82 | , mfSequence :: Int 83 | , threadId :: ThreadId 84 | , freeTh :: Bool 85 | -- ^ When 'True', threads are not killed using kill primitives 86 | 87 | , parent :: Maybe EventF 88 | -- ^ The parent of this thread 89 | 90 | , children :: MVar [EventF] 91 | -- ^ Forked child threads, used only when 'freeTh' is 'False' 92 | 93 | , maxThread :: Maybe (IORef Int) 94 | -- ^ Maximum number of threads that are allowed to be created 95 | 96 | , labelth :: IORef (LifeCycle, BS.ByteString) 97 | -- ^ Label the thread with its lifecycle state and a label string 98 | } deriving Typeable 99 | 100 | newtype Transient r a = Transient { runTransT :: (Maybe a -> StateIO (Maybe r)) -> StateIO (Maybe r) } 101 | 102 | type StateIO = StateT EventF IO 103 | 104 | type TransIO a= Transient a a 105 | 106 | type TransientIO a= TransIO a 107 | 108 | --type Transient r a= Transient r a 109 | 110 | 111 | instance Monad (Transient r) where 112 | return = pure 113 | m >>= k = Transient $ \c -> runTransT m (\a -> runTransT (mayb k a) c) 114 | where 115 | mayb k (Just x)= k x 116 | mayb _ Nothing = empty 117 | 118 | instance MonadState EventF (Transient r ) where 119 | get= liftt get -- where lift m = Transient ((Just <$> m) >>=) 120 | put= liftt . put -- where lift m = Transient ((Just <$> m) >>=) 121 | 122 | -- instance MonadTrans (Transient r) where 123 | liftt m = Transient ((Just <$> m) >>=) 124 | 125 | instance MonadIO (Transient r ) where 126 | liftIO = liftt . liftIO 127 | 128 | callCC :: ((a -> Transient r b) -> Transient r a) -> Transient r a 129 | callCC f = Transient $ \ c -> runTransT (f (\ x -> Transient $ \ _ -> c $ Just x)) c 130 | 131 | instance Functor (Transient r ) where 132 | fmap f m = Transient $ \c -> runTransT m $ \ mx-> 133 | case mx of 134 | Just x -> c $ Just $ f x 135 | Nothing -> return Nothing 136 | 137 | instance Monoid a => Monoid (Transient r a) where 138 | mappend x y = mappend <$> x <*> y 139 | mempty = return mempty 140 | 141 | instance Applicative (Transient r ) where 142 | pure a = Transient ($ Just a) 143 | -- f <*> v = Transient $ \ k -> runTransT f $ \ g -> runTransT v (k . g) 144 | f <*> v = do 145 | r1 <- liftIO $ newIORef Nothing 146 | r2 <- liftIO $ newIORef Nothing 147 | fparallel r1 r2 <|> vparallel r1 r2 148 | where 149 | 150 | fparallel r1 r2= Transient $ \k -> do 151 | runTransT f $ \mg -> do 152 | liftIO $ writeIORef r1 mg !> "f write r1" 153 | case mg of 154 | Nothing -> return Nothing 155 | Just g -> do 156 | mt <- liftIO $ readIORef r2 !> "f read r2" 157 | case mt of 158 | Nothing -> return Nothing 159 | Just t -> k . Just $ g t 160 | 161 | vparallel r1 r2= Transient $ \k -> do 162 | runTransT v $ \mt -> do 163 | liftIO $ writeIORef r2 mt !> "v write r2" 164 | mg <- liftIO $ readIORef r1 !> "v read r2" 165 | case mg of 166 | Nothing -> return Nothing 167 | Just g -> do 168 | case mt of 169 | Nothing -> return Nothing 170 | Just t -> k . Just $ g t 171 | 172 | 173 | instance Alternative (Transient r ) where 174 | empty= Transient ( $ Nothing) 175 | f <|> g= Transient $ \ k ->do 176 | mr <- runTransT f k 177 | case mr of 178 | Nothing -> runTransT g k 179 | justr -> return justr 180 | 181 | 182 | 183 | 184 | emptyEventF :: ThreadId -> IORef (LifeCycle, BS.ByteString) -> MVar [EventF] -> EventF 185 | emptyEventF th label childs = 186 | EventF { mfData = mempty 187 | , mfSequence = 0 188 | , threadId = th 189 | , freeTh = False 190 | , parent = Nothing 191 | , children = childs 192 | , maxThread = Nothing 193 | , labelth = label } 194 | 195 | -- | Run a transient computation with a default initial state 196 | runTransient :: TransIO a -> IO (Maybe a, EventF) 197 | -- runTransient :: Transient r (StateT EventF IO) r -> IO (Maybe r, EventF) 198 | runTransient t = do 199 | th <- myThreadId 200 | label <- newIORef $ (Alive, BS.pack "top") 201 | childs <- newMVar [] 202 | runTransState (emptyEventF th label childs) t 203 | 204 | runTransState :: EventF -> TransIO a -> IO (Maybe a, EventF) 205 | runTransState st t= runStateT (runTrans t) st 206 | 207 | runTrans :: TransIO a -> StateIO (Maybe a) 208 | runTrans t= ((flip runTransT) (return . id)) t 209 | 210 | noTrans :: StateIO a -> TransIO a 211 | noTrans x= Transient $ const $ x >>= return . Just 212 | 213 | readWithErr :: (Typeable a, Read a) => String -> IO [(a, String)] 214 | readWithErr line = 215 | (v `seq` return [(v, left)]) 216 | `catch` (\(e :: SomeException) -> 217 | error $ "read error trying to read type: \"" ++ show (typeOf v) 218 | ++ "\" in: " ++ " <" ++ show line ++ "> ") 219 | where [(v, left)] = readsPrec 0 line 220 | 221 | readsPrec' _ = unsafePerformIO . readWithErr 222 | 223 | -- | Constraint type synonym for a value that can be logged. 224 | type Loggable a = (Show a, Read a, Typeable a) 225 | 226 | -- | Dynamic serializable data for logging. 227 | data IDynamic = 228 | IDyns String 229 | | forall a. Loggable a => IDynamic a 230 | 231 | instance Show IDynamic where 232 | show (IDynamic x) = show (show x) 233 | show (IDyns s) = show s 234 | 235 | instance Read IDynamic where 236 | readsPrec n str = map (\(x,s) -> (IDyns x,s)) $ readsPrec' n str 237 | 238 | type Recover = Bool 239 | type CurrentPointer = [LogElem] 240 | type LogEntries = [LogElem] 241 | 242 | data LogElem = Wait | Exec | Var IDynamic 243 | deriving (Read, Show) 244 | 245 | data Log = Log Recover CurrentPointer LogEntries 246 | deriving (Typeable, Show) 247 | 248 | data RemoteStatus = WasRemote | WasParallel | NoRemote 249 | deriving (Typeable, Eq, Show) 250 | 251 | -- | A synonym of 'empty' that can be used in a monadic expression. It stops 252 | -- the computation, which allows the next computation in an 'Alternative' 253 | -- ('<|>') composition to run. 254 | stop :: Alternative m => m stopped 255 | stop = empty 256 | 257 | --instance (Num a,Eq a,Fractional a) =>Fractional (Transient r a)where 258 | -- mf / mg = (/) <$> mf <*> mg 259 | -- fromRational (x:%y) = fromInteger x % fromInteger y 260 | 261 | 262 | instance (Num a, Eq a) => Num (Transient r a) where 263 | fromInteger = return . fromInteger 264 | mf + mg = (+) <$> mf <*> mg 265 | mf * mg = (*) <$> mf <*> mg 266 | negate f = f >>= return . negate 267 | abs f = f >>= return . abs 268 | signum f = f >>= return . signum 269 | 270 | class AdditionalOperators m where 271 | 272 | -- | Run @m a@ discarding its result before running @m b@. 273 | (**>) :: m a -> m b -> m b 274 | 275 | -- | Run @m b@ discarding its result, after the whole task set @m a@ is 276 | -- done. 277 | (<**) :: m a -> m b -> m a 278 | 279 | atEnd' :: m a -> m b -> m a 280 | atEnd' = (<**) 281 | 282 | -- | Run @m b@ discarding its result, once after each task in @m a@, and 283 | -- once again after the whole task set is done. 284 | (<***) :: m a -> m b -> m a 285 | 286 | atEnd :: m a -> m b -> m a 287 | atEnd = (<***) 288 | 289 | instance AdditionalOperators (Transient r ) where 290 | 291 | -- (**>) :: Transient r a -> Transient r b -> Transient r b 292 | (**>) f g = 293 | Transient $ \k -> runTransT f $ \x -> runTransT g k 294 | 295 | -- (<***) :: Transient r a -> Transient r b -> Transient r a 296 | (<***) f g = 297 | Transient $ \k -> runTransT f $ \mx -> do 298 | case mx of 299 | Nothing -> return Nothing 300 | _ -> runTransT g (const $ return Nothing) >> k mx 301 | 302 | -- (<**) :: Transient r a -> Transient r b -> Transient r a 303 | (<**) f g = 304 | Transient $ \k -> runTransT f $ \mx -> do 305 | case mx of 306 | Nothing -> return Nothing 307 | _ -> runTransT g (const $ return Nothing) >> k mx 308 | 309 | infixr 1 <***, <**, **> 310 | 311 | 312 | 313 | 314 | -- * Threads 315 | 316 | waitQSemB sem = atomicModifyIORefCAS sem $ \n -> 317 | if n > 0 then(n - 1, True) else (n, False) 318 | signalQSemB sem = atomicModifyIORefCAS sem $ \n -> (n + 1, ()) 319 | 320 | -- | Sets the maximum number of threads that can be created for the given task 321 | -- set. When set to 0, new tasks start synchronously in the current thread. 322 | -- New threads are created by 'parallel', and APIs that use parallel. 323 | threads :: Int -> Transient r a -> Transient r a 324 | threads n process = do 325 | msem <- gets maxThread 326 | sem <- liftIO $ newIORef n 327 | modify $ \s -> s { maxThread = Just sem } 328 | r <- process <** (modify $ \s -> s { maxThread = msem }) -- restore it 329 | return r 330 | 331 | -- | Terminate all the child threads in the given task set and continue 332 | -- execution in the current thread. Useful to reap the children when a task is 333 | -- done. 334 | -- 335 | oneThread :: Transient r a -> Transient r a 336 | oneThread comp = do 337 | st <- get 338 | chs <- liftIO $ newMVar [] 339 | label <- liftIO $ newIORef (Alive, BS.pack "oneThread") 340 | let st' = st { parent = Just st 341 | , children = chs 342 | , labelth = label } 343 | liftIO $ hangThread st st' 344 | put st' 345 | x <- comp 346 | th <- liftIO myThreadId 347 | -- !> ("FATHER:", threadId st) 348 | chs <- liftIO $ readMVar chs -- children st' 349 | liftIO $ mapM_ (killChildren1 th) chs 350 | return x 351 | where killChildren1 :: ThreadId -> EventF -> IO () 352 | killChildren1 th state = do 353 | ths' <- modifyMVar (children state) $ \ths -> do 354 | let (inn, ths')= partition (\st -> threadId st == th) ths 355 | return (inn, ths') 356 | mapM_ (killChildren1 th) ths' 357 | mapM_ (killThread . threadId) ths' 358 | -- !> ("KILLEVENT1 ", map threadId ths' ) 359 | 360 | -- | Add a label to the current passing threads so it can be printed by debugging calls like `showThreads` 361 | labelState :: (MonadIO m,MonadState EventF m) => String -> m () 362 | labelState l = do 363 | st <- get 364 | liftIO $ atomicModifyIORefCAS (labelth st) $ \(status,_) -> ((status, BS.pack l), ()) 365 | 366 | printBlock :: MVar () 367 | printBlock = unsafePerformIO $ newMVar () 368 | 369 | -- | Show the tree of threads hanging from the state. 370 | showThreads :: MonadIO m => EventF -> m () 371 | showThreads st = liftIO $ withMVar printBlock $ const $ do 372 | mythread <- myThreadId 373 | 374 | putStrLn "---------Threads-----------" 375 | let showTree n ch = do 376 | liftIO $ do 377 | putStr $ take n $ repeat ' ' 378 | (state, label) <- readIORef $ labelth ch 379 | if BS.null label 380 | then putStr . show $ threadId ch 381 | else do BS.putStr label; putStr . drop 8 . show $ threadId ch 382 | when (state == Dead) $ putStr " dead" 383 | putStrLn $ if mythread == threadId ch then " <--" else "" 384 | chs <- readMVar $ children ch 385 | mapM_ (showTree $ n + 2) $ reverse chs 386 | showTree 0 st 387 | 388 | -- | Return the state of the thread that initiated the transient computation 389 | topState :: Transient r EventF 390 | topState = do 391 | st <- get 392 | return $ toplevel st 393 | where toplevel st = case parent st of 394 | Nothing -> st 395 | Just p -> toplevel p 396 | 397 | -- | Return the state variable of the type desired with which a thread, identified by his number in the treee was initiated 398 | showState :: (Typeable a, MonadIO m, Alternative m) => String -> EventF -> m (Maybe a) 399 | showState th top = resp 400 | where resp = do 401 | let thstring = drop 9 . show $ threadId top 402 | if thstring == th 403 | then getstate top 404 | else do 405 | sts <- liftIO $ readMVar $ children top 406 | foldl (<|>) empty $ map (showState th) sts 407 | getstate st = 408 | case M.lookup (typeOf $ typeResp resp) $ mfData st of 409 | Just x -> return . Just $ unsafeCoerce x 410 | Nothing -> return Nothing 411 | typeResp :: m (Maybe x) -> x 412 | typeResp = undefined 413 | 414 | -- | Add n threads to the limit of threads. If there is no limit, the limit is set. 415 | addThreads' :: Int -> TransIO () 416 | addThreads' n= noTrans $ do 417 | msem <- gets maxThread 418 | case msem of 419 | Just sem -> liftIO $ modifyIORef sem $ \n' -> n + n' 420 | Nothing -> do 421 | sem <- liftIO (newIORef n) 422 | modify $ \ s -> s { maxThread = Just sem } 423 | 424 | -- | Ensure that at least n threads are available for the current task set. 425 | addThreads :: Int -> TransIO () 426 | addThreads n = noTrans $ do 427 | msem <- gets maxThread 428 | case msem of 429 | Nothing -> return () 430 | Just sem -> liftIO $ modifyIORef sem $ \n' -> if n' > n then n' else n 431 | 432 | --getNonUsedThreads :: Transient r (Maybe Int) 433 | --getNonUsedThreads= Transient $ do 434 | -- msem <- gets maxThread 435 | -- case msem of 436 | -- Just sem -> liftIO $ Just <$> readIORef sem 437 | -- Nothing -> return Nothing 438 | 439 | -- | Disable tracking and therefore the ability to terminate the child threads. 440 | -- By default, child threads are terminated automatically when the parent 441 | -- thread dies, or they can be terminated using the kill primitives. Disabling 442 | -- it may improve performance a bit, however, all threads must be well-behaved 443 | -- to exit on their own to avoid a leak. 444 | freeThreads :: Transient r a -> Transient r a 445 | freeThreads process = do 446 | st <- get 447 | put st { freeTh = True } 448 | r <- process 449 | modify $ \s -> s { freeTh = freeTh st } 450 | return r 451 | 452 | -- | Enable tracking and therefore the ability to terminate the child threads. 453 | -- This is the default but can be used to re-enable tracking if it was 454 | -- previously disabled with 'freeThreads'. 455 | hookedThreads :: Transient r a -> Transient r a 456 | hookedThreads process = do 457 | st <- get 458 | put st {freeTh = False} 459 | r <- process 460 | modify $ \st -> st { freeTh = freeTh st } 461 | return r 462 | 463 | -- | Kill all the child threads of the current thread. 464 | -- killChilds :: Transient r () 465 | killChilds :: TransIO () 466 | killChilds = noTrans $ do 467 | cont <- get 468 | liftIO $ do 469 | killChildren $ children cont 470 | writeIORef (labelth cont) (Alive, mempty) 471 | -- !> (threadId cont,"relabeled") 472 | return () 473 | 474 | -- | Kill the current thread and the childs. 475 | killBranch :: TransIO () 476 | killBranch = noTrans $ do 477 | st <- get 478 | liftIO $ killBranch' st 479 | 480 | -- | Kill the childs and the thread of an state 481 | killBranch' :: EventF -> IO () 482 | killBranch' cont = do 483 | killChildren $ children cont 484 | let thisth = threadId cont 485 | mparent = parent cont 486 | when (isJust mparent) $ 487 | modifyMVar_ (children $ fromJust mparent) $ \sts -> 488 | return $ filter (\st -> threadId st /= thisth) sts 489 | killThread $ thisth 490 | 491 | -- * Extensible State: Session Data Management 492 | 493 | -- | Same as 'getSData' but with a more general type. If the data is found, a 494 | -- 'Just' value is returned. Otherwise, a 'Nothing' value is returned. 495 | getData :: (MonadState EventF m, Typeable a) => m (Maybe a) 496 | getData = resp 497 | where resp = do 498 | list <- gets mfData 499 | case M.lookup (typeOf $ typeResp resp) list of 500 | Just x -> return . Just $ unsafeCoerce x 501 | Nothing -> return Nothing 502 | typeResp :: m (Maybe x) -> x 503 | typeResp = undefined 504 | 505 | -- | Retrieve a previously stored data item of the given data type from the 506 | -- monad state. The data type to retrieve is implicitly determined from the 507 | -- requested type context. 508 | -- If the data item is not found, an 'empty' value (a void event) is returned. 509 | -- Remember that an empty value stops the monad computation. If you want to 510 | -- print an error message or a default value in that case, you can use an 511 | -- 'Alternative' composition. For example: 512 | -- 513 | -- > getSData <|> error "no data" 514 | -- > getInt = getSData <|> return (0 :: Int) 515 | getSData :: (Typeable r, Typeable a) => Transient r a 516 | getSData = Transient $ const getData 517 | 518 | 519 | -- | Same as `getSData` 520 | getState :: Typeable a => TransIO a 521 | getState = getSData 522 | 523 | -- | 'setData' stores a data item in the monad state which can be retrieved 524 | -- later using 'getData' or 'getSData'. Stored data items are keyed by their 525 | -- data type, and therefore only one item of a given type can be stored. A 526 | -- newtype wrapper can be used to distinguish two data items of the same type. 527 | -- 528 | -- @ 529 | -- import Control.Monad.IO.Class (liftIO) 530 | -- import Transient.Base 531 | -- import Data.Typeable 532 | -- 533 | -- data Person = Person 534 | -- { name :: String 535 | -- , age :: Int 536 | -- } deriving Typeable 537 | -- 538 | -- main = keep $ do 539 | -- setData $ Person "Alberto" 55 540 | -- Person name age <- getSData 541 | -- liftIO $ print (name, age) 542 | -- @ 543 | setData :: (MonadState EventF m, Typeable a) => a -> m () 544 | setData x = modify $ \st -> st { mfData = M.insert t (unsafeCoerce x) (mfData st) } 545 | where t = typeOf x 546 | 547 | -- | Accepts a function that takes the current value of the stored data type 548 | -- and returns the modified value. If the function returns 'Nothing' the value 549 | -- is deleted otherwise updated. 550 | modifyData :: (MonadState EventF m, Typeable a) => (Maybe a -> Maybe a) -> m () 551 | modifyData f = modify $ \st -> st { mfData = M.alter alterf t (mfData st) } 552 | where typeResp :: (Maybe a -> b) -> a 553 | typeResp = undefined 554 | t = typeOf (typeResp f) 555 | alterf mx = unsafeCoerce $ f x' 556 | where x' = case mx of 557 | Just x -> Just $ unsafeCoerce x 558 | Nothing -> Nothing 559 | 560 | -- | Same as modifyData 561 | modifyState :: (MonadState EventF m, Typeable a) => (Maybe a -> Maybe a) -> m () 562 | modifyState = modifyData 563 | 564 | -- | Same as 'setData' 565 | setState :: (MonadState EventF m, Typeable a) => a -> m () 566 | setState = setData 567 | 568 | -- | Delete the data item of the given type from the monad state. 569 | delData :: (MonadState EventF m, Typeable a) => a -> m () 570 | delData x = modify $ \st -> st { mfData = M.delete (typeOf x) (mfData st) } 571 | 572 | -- | Same as 'delData' 573 | delState :: (MonadState EventF m, Typeable a) => a -> m () 574 | delState = delData 575 | 576 | 577 | -- STRefs for the Transient monad 578 | 579 | newtype Ref a = Ref (IORef a) 580 | 581 | -- | mutable state reference that can be updated (similar to STRef in the state monad) 582 | -- 583 | -- Initialized the first time it is set. 584 | setRState:: Typeable a => a -> Transient (Ref a) () 585 | setRState x= do 586 | Ref ref <- getSData 587 | liftIO $ atomicModifyIORefCAS ref $ const (x,()) 588 | <|> do 589 | ref <- liftIO (newIORef x) 590 | setData $ Ref ref 591 | 592 | 593 | getRState :: Typeable a => Transient (Ref a) a 594 | getRState= do 595 | Ref ref <- getSData 596 | liftIO $ readIORef ref 597 | 598 | delRState x= delState (undefined `asTypeOf` ref x) 599 | where ref :: a -> IORef a 600 | ref= undefined 601 | 602 | -- | Run an action, if it does not succeed, undo any state changes 603 | -- that it might have caused and allow aternative actions to run with the original state 604 | try :: Transient r a -> Transient r a 605 | try mx = do 606 | sd <- gets mfData 607 | mx <|> (modify (\s -> s { mfData = sd }) >> empty) 608 | 609 | -- | Executes the computation and reset the state either if it fails or not. 610 | sandbox :: Transient r a -> Transient r a 611 | sandbox mx = do 612 | sd <- gets mfData 613 | mx <*** modify (\s ->s { mfData = sd}) 614 | 615 | -- | Generator of identifiers that are unique within the current monadic 616 | -- sequence They are not unique in the whole program. 617 | genId :: MonadState EventF m => m Int 618 | genId = do 619 | st <- get 620 | let n = mfSequence st 621 | put st { mfSequence = n + 1 } 622 | return n 623 | 624 | getPrevId :: MonadState EventF m => m Int 625 | getPrevId = gets mfSequence 626 | 627 | instance Read SomeException where 628 | readsPrec n str = [(SomeException $ ErrorCall s, r)] 629 | where [(s , r)] = read str 630 | 631 | -- | 'StreamData' represents a task in a task stream being generated. 632 | data StreamData a = 633 | SMore a -- ^ More tasks to come 634 | | SLast a -- ^ This is the last task 635 | | SDone -- ^ No more tasks, we are done 636 | | SError SomeException -- ^ An error occurred 637 | deriving (Typeable, Show,Read) 638 | 639 | -- | An task stream generator that produces an infinite stream of tasks by 640 | -- running an IO computation in a loop. A task is triggered carrying the output 641 | -- of the computation. See 'parallel' for notes on the return value. 642 | -- waitEvents :: IO a -> Transient r a 643 | waitEvents io = do 644 | mr <- parallel (SMore <$> io) 645 | case mr of 646 | SMore x -> return x 647 | SError e -> back e 648 | 649 | -- | Run an IO computation asynchronously and generate a single task carrying 650 | -- the result of the computation when it completes. See 'parallel' for notes on 651 | -- the return value. 652 | -- async :: IO a -> Transient r a 653 | async io = do 654 | mr <- parallel (SLast <$> io) 655 | case mr of 656 | SLast x -> return x 657 | SError e -> back e 658 | 659 | -- | Force an async computation to run synchronously. It can be useful in an 660 | -- 'Alternative' composition to run the alternative only after finishing a 661 | -- computation. Note that in Applicatives it might result in an undesired 662 | -- serialization. 663 | sync :: Transient r a -> Transient r a 664 | sync x = do 665 | setData WasRemote 666 | r <- x 667 | delData WasRemote 668 | return r 669 | 670 | -- | @spawn = freeThreads . waitEvents@ 671 | spawn :: IO a -> Transient r a 672 | spawn = freeThreads . waitEvents 673 | 674 | -- | An task stream generator that produces an infinite stream of tasks by 675 | -- running an IO computation periodically at the specified time interval. The 676 | -- task carries the result of the computation. A new task is generated only if 677 | -- the output of the computation is different from the previous one. See 678 | -- 'parallel' for notes on the return value. 679 | -- sample :: Eq a => IO a -> Int -> Transient r a 680 | sample action interval = do 681 | v <- liftIO action 682 | prev <- liftIO $ newIORef v 683 | waitEvents (loop action prev) <|> async (return v) 684 | where loop action prev = loop' 685 | where loop' = do 686 | threadDelay interval 687 | v <- action 688 | v' <- readIORef prev 689 | if v /= v' then writeIORef prev v >> return v else loop' 690 | 691 | 692 | 693 | -- | Run an IO action one or more times to generate a stream of tasks. The IO 694 | -- action returns a 'StreamData'. When it returns an 'SMore' or 'SLast' a new 695 | -- task is triggered with the result value. If the return value is 'SMore', the 696 | -- action is run again to generate the next task, otherwise task creation 697 | -- stops. 698 | -- 699 | -- Unless the maximum number of threads (set with 'threads') has been reached, 700 | -- the task is generated in a new thread and the current thread returns a void 701 | -- task. 702 | --parallel :: IO (StreamData b) -> Transient r StateIO (StreamData b) 703 | parallel ioaction = callCC $ \ret -> do 704 | cont <- get 705 | -- !> "PARALLEL" 706 | 707 | liftIO $ atomicModifyIORefCAS (labelth cont) $ \(_, lab) -> ((Parent, lab), ()) 708 | liftIO $ loop cont ret ioaction 709 | was <- getData `onNothing` return NoRemote 710 | when (was /= WasRemote) $ setData WasParallel 711 | -- th <- liftIO myThreadId 712 | -- return () !> ("finish",th) 713 | empty 714 | 715 | -- | Execute the IO action and the continuation 716 | -- loop :: EventF ->(StreamData a -> Transient r (StreamData a)) -> IO (StreamData t) -> IO () 717 | loop parentc ret rec = forkMaybe parentc $ \cont -> do 718 | -- Execute the IO computation and then the closure-continuation 719 | liftIO $ atomicModifyIORefCAS (labelth cont) $ const ((Listener,BS.pack "wait"),()) 720 | let loop'= do 721 | mdat <- rec `catch` \(e :: SomeException) -> return $ SError e 722 | case mdat of 723 | se@(SError _) -> setworker cont >> iocont se cont 724 | SDone -> setworker cont >> iocont SDone cont 725 | last@(SLast _) -> setworker cont >> iocont last cont 726 | 727 | more@(SMore _) -> do 728 | forkMaybe cont $ iocont more 729 | loop' 730 | 731 | where 732 | setworker cont= liftIO $ atomicModifyIORefCAS (labelth cont) $ const ((Alive,BS.pack "work"),()) 733 | 734 | iocont dat cont = do 735 | runTransState cont (ret dat ) 736 | return () 737 | 738 | 739 | 740 | loop' 741 | return () 742 | where 743 | {-# INLINABLE forkMaybe #-} 744 | forkMaybe parent proc = do 745 | case maxThread parent of 746 | Nothing -> forkIt parent proc 747 | Just sem -> do 748 | dofork <- waitQSemB sem 749 | if dofork then forkIt parent proc else proc parent 750 | 751 | 752 | forkIt parent proc= do 753 | chs <- liftIO $ newMVar [] 754 | 755 | label <- newIORef (Alive, BS.pack "work") 756 | let cont = parent{parent=Just parent,children= chs, labelth= label} 757 | 758 | forkFinally1 (do 759 | th <- myThreadId 760 | let cont'= cont{threadId=th} 761 | when(not $ freeTh parent )$ hangThread parent cont' 762 | -- !> ("thread created: ",th,"in",threadId parent ) 763 | 764 | proc cont') 765 | $ \me -> do 766 | 767 | case me of 768 | Left e -> exceptBack cont e >> return () 769 | 770 | 771 | 772 | _ -> do 773 | case maxThread cont of 774 | Just sem -> signalQSemB sem -- !> "freed thread" 775 | Nothing -> return () 776 | when(not $ freeTh parent ) $ do -- if was not a free thread 777 | 778 | th <- myThreadId 779 | (can,label) <- atomicModifyIORefCAS (labelth cont) $ \(l@(status,label)) -> 780 | ((if status== Alive then Dead else status, label),l) 781 | 782 | 783 | when (can/= Parent ) $ free th parent 784 | return () 785 | 786 | 787 | forkFinally1 :: IO a -> (Either SomeException a -> IO ()) -> IO ThreadId 788 | forkFinally1 action and_then = 789 | mask $ \restore -> forkIO $ Control.Exception.try (restore action) >>= and_then 790 | 791 | free th env= do 792 | -- return () !> ("freeing",th,"in",threadId env) 793 | let sibling= children env 794 | 795 | (sbs',found) <- modifyMVar sibling $ \sbs -> do 796 | let (sbs', found) = drop [] th sbs 797 | return (sbs',(sbs',found)) 798 | 799 | 800 | 801 | if found 802 | then do 803 | 804 | -- !> ("new list for",threadId env,map threadId sbs') 805 | (typ,_) <- readIORef $ labelth env 806 | if (null sbs' && typ /= Listener && isJust (parent env)) 807 | -- free the parent 808 | then free (threadId env) ( fromJust $ parent env) 809 | else return () 810 | 811 | -- return env 812 | else return () -- putMVar sibling sbs 813 | -- !> (th,"orphan") 814 | 815 | where 816 | drop processed th []= (processed,False) 817 | drop processed th (ev:evts)| th == threadId ev= (processed ++ evts, True) 818 | | otherwise= drop (ev:processed) th evts 819 | 820 | 821 | 822 | hangThread parentProc child = do 823 | 824 | let headpths= children parentProc 825 | 826 | modifyMVar_ headpths $ \ths -> return (child:ths) 827 | -- ths <- takeMVar headpths 828 | -- putMVar headpths (child:ths) 829 | 830 | 831 | -- !> ("hang", threadId child, threadId parentProc,map threadId ths,unsafePerformIO $ readIORef $ labelth parentProc) 832 | 833 | -- | kill all the child threads associated with the continuation context 834 | killChildren childs = do 835 | 836 | 837 | ths <- modifyMVar childs $ \ths -> return ([],ths) 838 | -- ths <- takeMVar childs 839 | -- putMVar childs [] 840 | 841 | mapM_ (killChildren . children) ths 842 | 843 | 844 | mapM_ (killThread . threadId) ths -- !> ("KILL", map threadId ths ) 845 | 846 | 847 | 848 | 849 | 850 | -- | Make a transient task generator from an asynchronous callback handler. 851 | -- 852 | -- The first parameter is a callback. The second parameter is a value to be 853 | -- returned to the callback; if the callback expects no return value it 854 | -- can just be a @return ()@. The callback expects a setter function taking the 855 | -- @eventdata@ as an argument and returning a value to the callback; this 856 | -- function is supplied by 'react'. 857 | -- 858 | -- Callbacks from foreign code can be wrapped into such a handler and hooked 859 | -- into the transient monad using 'react'. Every time the callback is called it 860 | -- generates a new task for the transient monad. 861 | -- 862 | 863 | react 864 | :: ((eventdata -> IO response) -> IO ()) 865 | -> IO response 866 | -> Transient r eventdata 867 | react setHandler iob= callCC $ \ret -> do 868 | st <- get 869 | liftIO $ setHandler $ \x -> (runTransState st $ ret x) >> iob 870 | empty 871 | 872 | -- | Runs a computation asynchronously without generating any events. Returns 873 | -- 'empty' in an 'Alternative' composition. 874 | 875 | abduce = async $ return () 876 | 877 | 878 | 879 | -- * non-blocking keyboard input 880 | 881 | getLineRef= unsafePerformIO $ newTVarIO Nothing 882 | 883 | 884 | roption= unsafePerformIO $ newMVar [] 885 | 886 | -- | Waits on stdin in a loop and triggers a new task every time the input data 887 | -- matches the first parameter. The value contained by the task is the matched 888 | -- value i.e. the first argument itself. The second parameter is a label for 889 | -- the option. The label is displayed on the console when the option is 890 | -- activated. 891 | -- 892 | -- Note that if two independent invocations of 'option' are expecting the same 893 | -- input, only one of them gets it and triggers a task. It cannot be 894 | -- predicted which one gets it. 895 | -- 896 | option :: (Typeable b, Show b, Read b, Eq b) => 897 | b -> String -> Transient r b 898 | option ret message= do 899 | let sret= show ret 900 | liftIO $ putStrLn $ "Enter " ++ sret ++ "\tto: " ++ message 901 | liftIO $ modifyMVar_ roption $ \msgs-> return $ sret:msgs 902 | unsafeCoerce $ waitEvents $ getLine' (==ret) 903 | liftIO $ putStr "\noption: " >> putStrLn (show ret) 904 | return ret 905 | 906 | 907 | -- | Waits on stdin and triggers a task when a console input matches the 908 | -- predicate specified in the first argument. The second parameter is a string 909 | -- to be displayed on the console before waiting. 910 | -- 911 | --input :: (Typeable a, Read a,Show a) => (a -> Bool) -> String -> Transient r StateIO a 912 | input cond prompt= input' Nothing cond prompt 913 | 914 | --input' :: (Typeable a, Read a,Show a) => Maybe a -> (a -> Bool) 915 | -- -> String -> Transient r StateIO a 916 | input' mv cond prompt= Transient . const $ liftIO $do 917 | putStr prompt >> hFlush stdout 918 | atomically $ do 919 | mr <- readTVar getLineRef 920 | case mr of 921 | Nothing -> STM.retry 922 | Just r -> 923 | case reads2 r of 924 | (s,_):_ -> if cond s !> show (cond s) 925 | then do 926 | unsafeIOToSTM $ print s 927 | writeTVar getLineRef Nothing !>"match" 928 | return $ Just s 929 | 930 | else return mv 931 | _ -> return mv !> "return " 932 | 933 | where 934 | reads2 s= x where 935 | x= if typeOf(typeOfr x) == typeOf "" 936 | then unsafeCoerce[(s,"")] 937 | else unsafePerformIO $ return (reads s) `catch` \(e :: SomeException) -> (return []) 938 | 939 | typeOfr :: [(a,String)] -> a 940 | typeOfr = undefined 941 | 942 | -- | Non blocking `getLine` with a validator 943 | getLine' :: (Typeable a,Read a) => (a -> Bool) -> IO a 944 | getLine' cond= do 945 | atomically $ do 946 | mr <- readTVar getLineRef 947 | case mr of 948 | Nothing -> STM.retry 949 | Just r -> 950 | case reads1 r of -- !> ("received " ++ show r ++ show (unsafePerformIO myThreadId)) of 951 | (s,_):_ -> if cond s -- !> show (cond s) 952 | then do 953 | writeTVar getLineRef Nothing -- !>"match" 954 | return s 955 | 956 | else STM.retry 957 | _ -> STM.retry 958 | 959 | reads1 s=x where 960 | x= if typeOf(typeOfr x) == typeOf "" then unsafeCoerce[(s,"")] else readsPrec' 0 s 961 | typeOfr :: [(a,String)] -> a 962 | typeOfr = undefined 963 | 964 | 965 | inputLoop :: IO () 966 | inputLoop= do 967 | r <- getLine 968 | -- XXX hoping that the previous value has been consumed by now. 969 | -- otherwise its just lost by overwriting. 970 | atomically $ writeTVar getLineRef Nothing 971 | processLine r 972 | inputLoop 973 | 974 | processLine r= do 975 | 976 | let rs = breakSlash [] r 977 | 978 | -- XXX this blocks forever if an input is not consumed by any consumer. 979 | -- e.g. try this "xxx/xxx" on the stdin 980 | liftIO $ mapM_ (\ r -> 981 | atomically $ do 982 | -- threadDelay 1000000 983 | t <- readTVar getLineRef 984 | when (isJust t) STM.retry 985 | writeTVar getLineRef $ Just r ) rs 986 | 987 | 988 | where 989 | breakSlash :: [String] -> String -> [String] 990 | breakSlash [] ""= [""] 991 | breakSlash s ""= s 992 | breakSlash res ('\"':s)= 993 | let (r,rest) = span(/= '\"') s 994 | in breakSlash (res++[r]) $ tail1 rest 995 | 996 | breakSlash res s= 997 | let (r,rest) = span(\x -> x /= '/' && x /= ' ') s 998 | in breakSlash (res++[r]) $ tail1 rest 999 | 1000 | tail1 []=[] 1001 | tail1 x= tail x 1002 | 1003 | 1004 | 1005 | 1006 | -- | Wait for the execution of `exit` and return the result or the exhaustion of thread activity 1007 | 1008 | stay rexit= takeMVar rexit 1009 | `catch` \(e :: BlockedIndefinitelyOnMVar) -> return Nothing 1010 | 1011 | newtype Exit a= Exit a deriving Typeable 1012 | 1013 | -- | Runs the transient computation in a child thread and keeps the main thread 1014 | -- running until all the user threads exit or some thread invokes 'exit'. 1015 | -- 1016 | -- The main thread provides facilities to accept keyboard input in a 1017 | -- non-blocking but line-oriented manner. The program reads the standard input 1018 | -- and feeds it to all the async input consumers (e.g. 'option' and 'input'). 1019 | -- All async input consumers contend for each line entered on the standard 1020 | -- input and try to read it atomically. When a consumer consumes the input 1021 | -- others do not get to see it, otherwise it is left in the buffer for others 1022 | -- to consume. If nobody consumes the input, it is discarded. 1023 | -- 1024 | -- A @/@ in the input line is treated as a newline. 1025 | -- 1026 | -- When using asynchronous input, regular synchronous IO APIs like getLine 1027 | -- cannot be used as they will contend for the standard input along with the 1028 | -- asynchronous input thread. Instead you can use the asynchronous input APIs 1029 | -- provided by transient. 1030 | -- 1031 | -- A built-in interactive command handler also reads the stdin asynchronously. 1032 | -- All available commands handled by the command handler are displayed when the 1033 | -- program is run. The following commands are available: 1034 | -- 1035 | -- 1. @ps@: show threads 1036 | -- 2. @log@: inspect the log of a thread 1037 | -- 3. @end@, @exit@: terminate the program 1038 | -- 1039 | -- An input not handled by the command handler can be handled by the program. 1040 | -- 1041 | -- The program's command line is scanned for @-p@ or @--path@ command line 1042 | -- options. The arguments to these options are injected into the async input 1043 | -- channel as keyboard input to the program. Each line of input is separated by 1044 | -- a @/@. For example: 1045 | -- 1046 | -- > foo -p ps/end 1047 | -- 1048 | keep :: Typeable a => Transient r a -> IO (Maybe a) 1049 | keep mx = do 1050 | 1051 | liftIO $ hSetBuffering stdout LineBuffering 1052 | rexit <- newEmptyMVar 1053 | forkIO $ do 1054 | -- liftIO $ putMVar rexit $ Right Nothing 1055 | runTransient $ do 1056 | st <- get 1057 | setData $ Exit rexit 1058 | do abduce 1059 | labelState "input" 1060 | liftIO inputLoop 1061 | 1062 | 1063 | 1064 | 1065 | <|> do 1066 | option "ps" "show threads" 1067 | liftIO $ showThreads st 1068 | 1069 | <|> do 1070 | option "log" "inspect the log of a thread" 1071 | th <- input (const True) "thread number>" 1072 | ml <- liftIO $ showState th st 1073 | liftIO $ print $ fmap (\(Log _ _ log) -> reverse log) ml 1074 | 1075 | <|> do 1076 | option "end" "exit" 1077 | killChilds 1078 | liftIO $ putMVar rexit Nothing 1079 | 1080 | <|> unsafeCoerce mx 1081 | return () 1082 | threadDelay 10000 1083 | execCommandLine 1084 | stay rexit 1085 | 1086 | where 1087 | type1 :: Transient r a -> Either String (Maybe a) 1088 | type1= undefined 1089 | 1090 | -- | Same as `keep` but does not read from the standard input, and therefore 1091 | -- the async input APIs ('option' and 'input') cannot be used in the monad. 1092 | -- However, keyboard input can still be passed via command line arguments as 1093 | -- described in 'keep'. Useful for debugging or for creating background tasks, 1094 | -- as well as to embed the Transient monad inside another computation. It 1095 | -- returns either the value returned by `exit`. or Nothing, when there are no 1096 | -- more threads running 1097 | -- 1098 | keep' :: Typeable a => TransIO a -> IO (Maybe a) 1099 | keep' mx = do 1100 | liftIO $ hSetBuffering stdout LineBuffering 1101 | rexit <- newEmptyMVar 1102 | forkIO $ do 1103 | runTransient $ do 1104 | setData $ Exit rexit 1105 | mx 1106 | 1107 | return () 1108 | threadDelay 10000 1109 | forkIO $ execCommandLine 1110 | stay rexit 1111 | 1112 | 1113 | execCommandLine= do 1114 | args <- getArgs 1115 | let mindex = findIndex (\o -> o == "-p" || o == "--path" ) args 1116 | when (isJust mindex) $ do 1117 | let i= fromJust mindex +1 1118 | when (length args >= i) $ do 1119 | let path= args !! i 1120 | putStr "Executing: " >> print path 1121 | processLine path 1122 | 1123 | -- | Exit the main thread, and thus all the Transient threads (and the 1124 | -- application if there is no more code) 1125 | -- exit :: Typeable a => a -> Transient r a 1126 | exit x= do 1127 | Exit rexit <- getSData <|> error "exit: not the type expected" `asTypeOf` type1 x 1128 | liftIO $ putMVar rexit $ Just x 1129 | stop 1130 | where 1131 | type1 :: a -> Transient r (Exit (MVar (Maybe a))) 1132 | type1= undefined 1133 | 1134 | 1135 | 1136 | -- | If the first parameter is 'Nothing' return the second parameter otherwise 1137 | -- return the first parameter.. 1138 | onNothing :: Monad m => m (Maybe b) -> m b -> m b 1139 | onNothing iox iox'= do 1140 | mx <- iox 1141 | case mx of 1142 | Just x -> return x 1143 | Nothing -> iox' 1144 | 1145 | 1146 | 1147 | 1148 | 1149 | ----------------------------------backtracking ------------------------ 1150 | 1151 | 1152 | data Backtrack b= forall a r c. Backtrack{backtracking :: Maybe b 1153 | ,backStack :: [(b ->Transient r c,c -> Transient r a)] } 1154 | deriving Typeable 1155 | 1156 | 1157 | 1158 | -- | Delete all the undo actions registered till now for the given track id. 1159 | -- backCut :: (Typeable b, Show b) => b -> Transient r () 1160 | backCut reason= 1161 | delData $ Backtrack (Just reason) [] 1162 | 1163 | -- | 'backCut' for the default track; equivalent to @backCut ()@. 1164 | undoCut :: Transient r () 1165 | undoCut = backCut () 1166 | 1167 | -- | Run the action in the first parameter and register the second parameter as 1168 | -- the undo action. On undo ('back') the second parameter is called with the 1169 | -- undo track id as argument. 1170 | -- 1171 | {-# NOINLINE onBack #-} 1172 | onBack :: (Typeable b, Show b) => Transient r a -> ( b -> Transient r a) -> Transient r a 1173 | onBack ac back = do 1174 | -- Backtrack mreason _ <- getData `onNothing` backStateOf (typeof bac) !> "HANDLER1" 1175 | -- r <-ac 1176 | -- case mreason !> ("mreason",mreason) of 1177 | -- Nothing -> ac 1178 | -- Just reason -> bac reason 1179 | registerBack ac back 1180 | 1181 | where 1182 | 1183 | typeof :: (b -> Transient r a) -> b 1184 | typeof = undefined 1185 | 1186 | -- | 'onBack' for the default track; equivalent to @onBack ()@. 1187 | onUndo :: Transient r a -> Transient r a -> Transient r a 1188 | onUndo x y= onBack x (\() -> y) 1189 | 1190 | 1191 | 1192 | -- | Register an undo action to be executed when backtracking. The first 1193 | -- parameter is a "witness" whose data type is used to uniquely identify this 1194 | -- backtracking action. The value of the witness parameter is not used. 1195 | -- 1196 | --{-# NOINLINE registerUndo #-} 1197 | -- registerBack :: (Typeable a, Show a) => (a -> Transient r a) -> a -> Transient r a 1198 | registerBack ac back = callCC $ \k -> do 1199 | md <- getData `asTypeOf` (Just <$> (backStateOf $ typeof back)) !> "HANDLER" 1200 | case md of 1201 | Just (bss@(Backtrack b (bs@((back',_):_)))) -> 1202 | -- when (isNothing b) $ do 1203 | -- addrx <- addr back' 1204 | -- addrx' <- addr back -- to avoid duplicate backtracking points 1205 | -- when (addrx /= addrx') $ do return () !> "ADD"; setData $ Backtrack mwit ( (back, k): unsafeCoerce bs) 1206 | setData $ Backtrack b ( (back, k): unsafeCoerce bs) 1207 | Just (Backtrack b []) -> setData $ Backtrack b [(back , k)] 1208 | Nothing -> do 1209 | setData $ Backtrack mwit [ (back , k)] -- !> "NOTHING" 1210 | ac 1211 | 1212 | where 1213 | 1214 | 1215 | typeof :: (b -> Transient r a) -> b 1216 | typeof = undefined 1217 | mwit= Nothing `asTypeOf` (Just $ typeof back) 1218 | addr x = liftIO $ return . hashStableName =<< (makeStableName $! x) 1219 | 1220 | 1221 | -- registerUndo :: Transient r a -> Transient r a 1222 | -- registerUndo f= registerBack () f 1223 | 1224 | -- XXX Should we enforce retry of the same track which is being undone? If the 1225 | -- user specifies a different track would it make sense? 1226 | -- 1227 | -- | For a given undo track id, stop executing more backtracking actions and 1228 | -- resume normal execution in the forward direction. Used inside an undo 1229 | -- action. 1230 | -- 1231 | forward :: (Typeable b, Show b) => b -> Transient r () 1232 | forward reason= do 1233 | Backtrack _ stack <- getData `onNothing` (backStateOf reason) 1234 | setData $ Backtrack(Nothing `asTypeOf` Just reason) stack 1235 | 1236 | 1237 | -- | To be used with `undo´ 1238 | retry= forward () 1239 | 1240 | 1241 | -- | Start the undo process for the given undo track id. Performs all the undo 1242 | -- actions registered till now in reverse order. An undo action can use 1243 | -- 'forward' to stop the undo process and resume forward execution. If there 1244 | -- are no more undo actions registered execution stops and a 'stop' action is 1245 | -- returned. 1246 | -- 1247 | back :: (Typeable b, Show b) => b -> Transient r a 1248 | back reason = do 1249 | Backtrack _ cs <- getData `onNothing` backStateOf reason 1250 | let bs= Backtrack (Just reason) cs 1251 | setData bs 1252 | goBackt bs 1253 | !>"GOBACK" 1254 | 1255 | where 1256 | 1257 | goBackt (Backtrack _ [] )= empty !> "END" 1258 | goBackt (Backtrack Nothing _ )= error "goback: no reason" 1259 | 1260 | goBackt (Backtrack (Just reason) ((handler,cont) : bs))= do 1261 | 1262 | -- setData $ Backtrack (Just reason) $ tail stack 1263 | -- unsafeCoerce $ first reason !> "GOBACK2" 1264 | x <- unsafeCoerce handler reason -- !> ("RUNCLOSURE",length stack) 1265 | 1266 | Backtrack mreason _ <- getData `onNothing` backStateOf reason 1267 | -- setData $ Backtrack mreason bs 1268 | -- -- !> "END RUNCLOSURE" 1269 | 1270 | -- case mr of 1271 | -- Nothing -> return empty -- !> "END EXECUTION" 1272 | case mreason of 1273 | Nothing -> do 1274 | --setData $ Backtrack Nothing bs 1275 | unsafeCoerce $ cont x !> "FORWARD EXEC" 1276 | justreason -> do 1277 | setData $ Backtrack justreason bs 1278 | goBackt $ Backtrack justreason bs !> ("BACK AGAIN") 1279 | empty 1280 | 1281 | backStateOf :: (Monad m, Show a, Typeable a) => a -> m (Backtrack a) 1282 | backStateOf reason= return $ Backtrack (Nothing `asTypeOf` (Just reason)) [] 1283 | 1284 | 1285 | -- | 'back' for the default undo track; equivalent to @back ()@. 1286 | -- 1287 | undo :: Transient r a 1288 | undo= back () 1289 | 1290 | 1291 | ------ finalization 1292 | 1293 | newtype Finish= Finish String deriving Show 1294 | 1295 | instance Exception Finish 1296 | 1297 | -- newtype FinishReason= FinishReason (Maybe SomeException) deriving (Typeable, Show) 1298 | 1299 | -- | Clear all finish actions registered till now. 1300 | -- initFinish= backCut (FinishReason Nothing) 1301 | 1302 | -- | Register an action that to be run when 'finish' is called. 'onFinish' can 1303 | -- be used multiple times to register multiple actions. Actions are run in 1304 | -- reverse order. Used in infix style. 1305 | -- 1306 | onFinish :: (Finish ->TransIO ()) -> TransIO () 1307 | onFinish f= onException' (return ()) f 1308 | 1309 | 1310 | -- | Run the action specified in the first parameter and register the second 1311 | -- parameter as a finish action to be run when 'finish' is called. Used in 1312 | -- infix style. 1313 | -- 1314 | onFinish' ::TransIO a ->(Finish ->TransIO a) -> TransIO a 1315 | onFinish' proc f= proc `onException'` f 1316 | 1317 | 1318 | -- | Execute all the finalization actions registered up to the last 1319 | -- 'initFinish', in reverse order and continue the execution. Either an exception or 'Nothing' can be 1320 | initFinish = cutExceptions 1321 | -- passed to 'finish'. The argument passed is made available in the 'onFinish' 1322 | -- actions invoked. 1323 | -- 1324 | finish :: String -> Transient r () 1325 | finish reason= (throwt $ Finish reason) <|> return() 1326 | 1327 | 1328 | noFinish= forward $ Finish "" 1329 | 1330 | -- | trigger finish when the stream of data ends 1331 | checkFinalize v= 1332 | case v of 1333 | SDone -> stop 1334 | SLast x -> return x 1335 | SError e -> throwt e 1336 | SMore x -> return x 1337 | 1338 | ------ exceptions --- 1339 | -- 1340 | -- | Install an exception handler. Handlers are executed in reverse (i.e. last in, first out) order when such exception happens in the 1341 | -- continuation. Note that multiple handlers can be installed for the same exception type. 1342 | -- 1343 | -- The semantic is thus very different than the one of `Control.Exception.Base.onException` 1344 | onException :: Exception e => (e -> TransIO ()) -> TransIO () 1345 | onException exc= return () `onException'` exc 1346 | 1347 | 1348 | onException' :: Exception e => TransIO a -> (e -> TransIO a) -> TransIO a 1349 | onException' mx f= onAnyException mx $ \e -> 1350 | case fromException e of 1351 | Nothing -> return $ error "do nothing,this should not be evaluated" 1352 | Just e' -> f e' 1353 | where 1354 | --onAnyException :: Transient r a -> (SomeException ->Transient r a) -> Transient r a 1355 | onAnyException mx f= ioexp `onBack` f 1356 | where 1357 | ioexp = callCC $ \cont -> do 1358 | st <- get 1359 | ioexp' $ runTransState st (mx >>=cont ) `catch` exceptBack st 1360 | 1361 | ioexp' mx= do 1362 | (mx,st') <- liftIO mx 1363 | put st' 1364 | case mx of 1365 | Nothing -> empty 1366 | Just x -> return x 1367 | 1368 | exceptBack st = \(e ::SomeException) -> do -- recursive catch itself 1369 | return () !> "CATCHHHHHHHHHHHHH" 1370 | runTransState st (back e ) 1371 | `catch` exceptBack st 1372 | 1373 | 1374 | 1375 | 1376 | -- | Delete all the exception handlers registered till now. 1377 | cutExceptions :: Transient r () 1378 | cutExceptions= backCut (undefined :: SomeException) 1379 | 1380 | -- | Use it inside an exception handler. it stop executing any further exception 1381 | -- handlers and resume normal execution from this point on. 1382 | continue :: Transient r () 1383 | continue = forward (undefined :: SomeException) !> "CONTINUE" 1384 | 1385 | -- | catch an exception in a Transient block 1386 | -- 1387 | -- The semantic is the same than `catch` but the computation and the exception handler can be multirhreaded 1388 | -- catcht1 mx exc= mx' `onBack` exc 1389 | -- where 1390 | -- mx'= Transient $ const $do 1391 | -- st <- get 1392 | -- (mx, st) <- liftIO $ runTransState st mx `catch` exceptBack st 1393 | -- put st 1394 | -- return mx 1395 | 1396 | 1397 | catcht :: Exception e => TransIO a -> (e -> TransIO a) -> TransIO a 1398 | catcht mx exc= do 1399 | rpassed <- liftIO $ newIORef False 1400 | sandbox $ do 1401 | delData $ Backtrack (Just (undefined :: SomeException)) [] 1402 | 1403 | r <- onException' mx $ \e -> do 1404 | passed <- liftIO $ readIORef rpassed 1405 | if not passed then unsafeCoerce continue >> exc e else empty 1406 | liftIO $ writeIORef rpassed True 1407 | return r 1408 | 1409 | where 1410 | sandbox :: Transient r a -> Transient r a 1411 | sandbox mx= do 1412 | exState <- getData `onNothing` backStateOf (undefined :: SomeException) 1413 | mx <*** setState exState 1414 | 1415 | -- | throw an exception in the Transient monad 1416 | throwt :: Exception e => e -> Transient r a 1417 | throwt= back . toException 1418 | 1419 | 1420 | -------------------------------------------------------------------------------- /src/Transient/Logged.hs: -------------------------------------------------------------------------------- 1 | ----------------------------------------------------------------------------- 2 | -- 3 | -- Module : Transient.Logged 4 | -- Copyright : 5 | -- License : MIT 6 | -- 7 | -- Maintainer : agocorona@gmail.com 8 | -- Stability : 9 | -- Portability : 10 | -- 11 | -- | The 'logged' primitive is used to save the results of the subcomputations 12 | -- of a transient computation (including all its threads) in a log buffer. At 13 | -- any point, a 'suspend' or 'checkpoint' can be used to save the accumulated 14 | -- log on a persistent storage. A 'restore' reads the saved logs and resumes 15 | -- the computation from the saved checkpoint. On resumption, the saved results 16 | -- are used for the computations which have already been performed. The log 17 | -- contains purely application level state, and is therefore independent of the 18 | -- underlying machine architecture. The saved logs can be sent across the wire 19 | -- to another machine and the computation can then be resumed on that machine. 20 | -- We can also save the log to gather diagnostic information. 21 | -- 22 | -- The following example illustrates the APIs. In its first run 'suspend' saves 23 | -- the state in a directory named @logs@ and exits, in the second run it 24 | -- resumes from that point and then stops at the 'checkpoint', in the third run 25 | -- it resumes from the checkpoint and then finishes. 26 | -- 27 | -- @ 28 | -- main= keep $ restore $ do 29 | -- r <- logged $ choose [1..10 :: Int] 30 | -- logged $ liftIO $ print (\"A",r) 31 | -- suspend () 32 | -- logged $ liftIO $ print (\"B",r) 33 | -- checkpoint 34 | -- liftIO $ print (\"C",r) 35 | -- @ 36 | ----------------------------------------------------------------------------- 37 | {-# LANGUAGE CPP, ExistentialQuantification, FlexibleInstances, ScopedTypeVariables, UndecidableInstances #-} 38 | module Transient.Logged( 39 | Loggable, logged, received, param, 40 | 41 | #ifndef ghcjs_HOST_OS 42 | suspend, checkpoint, rerun, restore, 43 | #endif 44 | 45 | -- * low level 46 | fromIDyn,maybeFromIDyn,toIDyn 47 | ) where 48 | 49 | import Data.Typeable 50 | import Unsafe.Coerce 51 | import Transient.Base 52 | 53 | import Transient.Indeterminism(choose) 54 | import Transient.Internals -- (onNothing,reads1,IDynamic(..),Log(..),LogElem(..),RemoteStatus(..),StateIO) 55 | import Control.Applicative 56 | import Control.Monad.State 57 | import System.Directory 58 | import Control.Exception 59 | import Control.Monad 60 | import Control.Concurrent.MVar 61 | import qualified Data.ByteString.Lazy.Char8 as BS 62 | import qualified Data.ByteString.Char8 as BSS 63 | 64 | #ifndef ghcjs_HOST_OS 65 | import System.Random 66 | 67 | 68 | -- | Reads the saved logs from the @logs@ subdirectory of the current 69 | -- directory, restores the state of the computation from the logs, and runs the 70 | -- computation. The log files are maintained. 71 | -- It could be used for the initial configuration of a program. 72 | rerun :: String -> TransIO a -> TransIO a 73 | rerun path proc = do 74 | liftIO $ do 75 | r <- doesDirectoryExist path 76 | when (not r) $ createDirectory path 77 | setCurrentDirectory path 78 | restore' proc False 79 | 80 | 81 | 82 | logs= "logs/" 83 | 84 | -- | Reads the saved logs from the @logs@ subdirectory of the current 85 | -- directory, restores the state of the computation from the logs, and runs the 86 | -- computation. The log files are removed after the state has been restored. 87 | -- 88 | restore :: TransIO a -> TransIO a 89 | restore proc= restore' proc True 90 | 91 | restore' proc delete= do 92 | liftIO $ createDirectory logs `catch` (\(e :: SomeException) -> return ()) 93 | list <- liftIO $ getDirectoryContents logs 94 | `catch` (\(e::SomeException) -> return []) 95 | if null list || length list== 2 then proc else do 96 | 97 | let list'= filter ((/=) '.' . head) list 98 | file <- choose list' 99 | 100 | logstr <- liftIO $ readFile (logs++file) 101 | let log= length logstr `seq` read' logstr 102 | 103 | log `seq` setData (Log True (reverse log) log 0) 104 | when delete $ liftIO $ remove $ logs ++ file 105 | proc 106 | where 107 | read'= fst . head . reads1 108 | 109 | remove f= removeFile f `catch` (\(e::SomeException) -> remove f) 110 | 111 | 112 | 113 | -- | Saves the logged state of the current computation that has been 114 | -- accumulated using 'logged', and then 'exit's using the passed parameter as 115 | -- the exit code. Note that all the computations before a 'suspend' must be 116 | -- 'logged' to have a consistent log state. The logs are saved in the @logs@ 117 | -- subdirectory of the current directory. Each thread's log is saved in a 118 | -- separate file. 119 | -- 120 | suspend :: Typeable a => a -> TransIO a 121 | suspend x= do 122 | Log recovery _ log _ <- getData `onNothing` return (Log False [] [] 0) 123 | if recovery then return x else do 124 | logAll log 125 | exit x 126 | 127 | -- | Saves the accumulated logs of the current computation, like 'suspend', but 128 | -- does not exit. 129 | checkpoint :: TransIO () 130 | checkpoint = do 131 | Log recovery _ log _ <- getData `onNothing` return (Log False [] [] 0) 132 | if recovery then return () else logAll log 133 | 134 | 135 | logAll log= liftIO $do 136 | newlogfile <- (logs ++) <$> replicateM 7 (randomRIO ('a','z')) 137 | logsExist <- doesDirectoryExist logs 138 | when (not logsExist) $ createDirectory logs 139 | writeFile newlogfile $ show log 140 | -- :: TransIO () 141 | #else 142 | rerun :: TransIO a -> TransIO a 143 | rerun = const empty 144 | 145 | suspend :: TransIO () 146 | suspend= empty 147 | 148 | checkpoint :: TransIO () 149 | checkpoint= empty 150 | 151 | restore :: TransIO a -> TransIO a 152 | restore= const empty 153 | #endif 154 | 155 | maybeFromIDyn :: Loggable a => IDynamic -> Maybe a 156 | maybeFromIDyn (IDynamic x)= r 157 | where 158 | r= if typeOf (Just x) == typeOf r then Just $ unsafeCoerce x else Nothing 159 | 160 | maybeFromIDyn (IDyns s) = case reads s of 161 | [] -> Nothing 162 | [(x,"")] -> Just x 163 | 164 | fromIDyn :: Loggable a => IDynamic -> a 165 | fromIDyn (IDynamic x)=r where r= unsafeCoerce x -- !> "coerce" ++ " to type "++ show (typeOf r) 166 | 167 | fromIDyn (IDyns s)=r `seq`r where r= read' s -- !> "read " ++ s ++ " to type "++ show (typeOf r) 168 | 169 | 170 | 171 | toIDyn x= IDynamic x 172 | 173 | 174 | 175 | -- | Run the computation, write its result in a log in the parent computation 176 | -- and return the result. If the log already contains the result of this 177 | -- computation ('restore'd from previous saved state) then that result is used 178 | -- instead of running the computation again. 179 | -- 180 | -- 'logged' can be used for computations inside a 'logged' computation. Once 181 | -- the parent computation is finished its internal (subcomputation) logs are 182 | -- discarded. 183 | -- 184 | logged :: Loggable a => TransIO a -> TransIO a 185 | logged mx = Transient $ do 186 | Log recover rs full hash <- getData `onNothing` return ( Log False [][] 0) 187 | runTrans $ 188 | case (recover ,rs) of -- !> ("logged enter",recover,rs,reverse full) of 189 | (True, Var x: rs') -> do 190 | return () -- !> ("Var:", x) 191 | setData $ Log True rs' full (hash+ 10000000) 192 | return $ fromIDyn x 193 | 194 | 195 | (True, Exec:rs') -> do 196 | setData $ Log True rs' full (hash + 1000) 197 | mx -- !> "Exec" 198 | 199 | (True, Wait:rs') -> do 200 | setData $ Log True rs' full (hash + 100000) 201 | setData WasParallel 202 | empty -- !> "Wait" 203 | 204 | _ -> do 205 | 206 | setData $ Log False (Exec : rs) (Exec: full) (hash + 1000) -- !> ("setLog False", Exec:rs) 207 | 208 | r <- mx <** do setData $ Log False (Wait: rs) (Wait: full) (hash+ 100000) 209 | -- when p1 <|> p2, to avoid the re-execution of p1 at the 210 | -- recovery when p1 is asynchronous or return empty 211 | 212 | Log recoverAfter lognew _ _ <- getData `onNothing` return ( Log False [][] 0) 213 | let add= Var (toIDyn r): full 214 | if recoverAfter && (not $ null lognew) -- !> ("recoverAfter", recoverAfter) 215 | then do 216 | setData WasParallel 217 | (setData $ Log True lognew (reverse lognew ++ add) (hash + 10000000) ) 218 | -- !> ("recover", reverse add,lognew) 219 | else if recoverAfter && (null lognew) then do 220 | -- showClosure 221 | setData $ Log False [] add (hash + 10000000) -- !> ("recover2",reverse add) 222 | else do 223 | -- showClosure 224 | (setData $ Log False (Var (toIDyn r):rs) add (hash +10000000)) -- !> ("restore", reverse $ (Var (toIDyn r):rs)) 225 | 226 | return r 227 | 228 | 229 | 230 | 231 | -------- parsing the log for API's 232 | 233 | received :: Loggable a => a -> TransIO () 234 | received n=Transient $ do 235 | 236 | Log recover rs full hash <- getData `onNothing` return ( Log False [][] 0) 237 | 238 | 239 | case rs of 240 | [] -> return Nothing 241 | Var (IDyns s):t -> if s == show1 n 242 | then do 243 | return() !> "valid" 244 | setData $ Log recover t full hash 245 | return $ Just () 246 | else return Nothing 247 | _ -> return Nothing 248 | where 249 | show1 x= if typeOf x == typeOf "" then unsafeCoerce x 250 | else if typeOf x== typeOf (undefined :: BS.ByteString) then unsafeCoerce x 251 | else if typeOf x== typeOf (undefined :: BSS.ByteString) then unsafeCoerce x 252 | else show x 253 | 254 | param :: Loggable a => TransIO a 255 | param= res where 256 | res= Transient $ do 257 | 258 | Log recover rs full hash<- getData `onNothing` return ( Log False [][] 0) 259 | return () !> ("PARAM",rs) 260 | case rs of 261 | 262 | [] -> return Nothing 263 | Var (IDynamic v):t ->do 264 | 265 | setData $ Log recover t full hash 266 | return $ cast v 267 | Var (IDyns s):t -> do 268 | return () !> ("IDyn",s) 269 | let mr = reads1 s `asTypeOf` type1 res 270 | case mr of 271 | [] -> return Nothing 272 | 273 | (v,r):_ -> do 274 | 275 | setData $ Log recover t full hash 276 | return $ Just v 277 | _ -> return Nothing 278 | 279 | where 280 | 281 | 282 | reads1 s=x where 283 | x= if typeOf(typeOfr x) == typeOf "" then unsafeCoerce[(s,"")] else reads s 284 | typeOfr :: [(a,String)] -> a 285 | typeOfr = undefined 286 | type1 :: TransIO a -> [(a,String)] 287 | type1= error "type1: typelevel" 288 | -------------------------------------------------------------------------------- /src/Transient/Parse.hs: -------------------------------------------------------------------------------- 1 | {-#LANGUAGE FlexibleContexts, ExistentialQuantification, ScopedTypeVariables, OverloadedStrings, TypeSynonymInstances, FlexibleInstances #-} 2 | module Transient.Parse where 3 | import Transient.Internals 4 | import Transient.Indeterminism 5 | import Data.String 6 | import Data.Typeable 7 | import Control.Applicative 8 | import Data.Char 9 | import Data.Monoid 10 | 11 | import System.IO.Unsafe 12 | import Control.Monad 13 | import Control.Monad.State 14 | -- import Control.Exception (throw,IOException) 15 | import Control.Concurrent.MVar 16 | 17 | 18 | import qualified Data.ByteString.Lazy.Char8 as BS 19 | 20 | -- | set a stream of strings to be parsed 21 | setParseStream :: IO (StreamData BS.ByteString) -> TransIO () 22 | setParseStream iox= do delData NoRemote; setState $ ParseContext iox "" 23 | 24 | 25 | -- | set a string to be parsed 26 | setParseString :: BS.ByteString -> TransIO () 27 | setParseString x = do delData NoRemote; setState $ ParseContext (return SDone) x 28 | 29 | 30 | withParseString :: BS.ByteString -> TransIO a -> TransIO a 31 | withParseString x parse= do 32 | p@(ParseContext c str) <- getState <|> return(ParseContext (return SDone) mempty) 33 | setParseString x 34 | r <- parse 35 | setState (ParseContext c (str :: BS.ByteString)) 36 | return r 37 | 38 | -- | The parse context contains either the string to be parsed or a computation that gives an stream of 39 | -- strings or both. First, the string is parsed. If it is empty, the stream is pulled for more. 40 | data ParseContext str = IsString str => ParseContext (IO (StreamData str)) str deriving Typeable 41 | 42 | 43 | -- | succeed if read the string given as parameter 44 | string :: BS.ByteString -> TransIO BS.ByteString 45 | string s= withData $ \str -> do 46 | let len= BS.length s 47 | ret@(s',_) = BS.splitAt len str 48 | 49 | if s == s' -- !> ("parse string looked, found",s,s') 50 | 51 | then return ret 52 | else empty -- !> "STRING EMPTY" 53 | 54 | -- | fast search for a token 55 | tDropUntilToken token= withData $ \str -> 56 | if BS.null str then empty else drop2 str 57 | where 58 | drop2 str= 59 | if token `BS.isPrefixOf` str !> (BS.take 2 str) 60 | then return ((),BS.drop (BS.length token) str) 61 | else if not $ BS.null str then drop2 $ BS.tail str else empty 62 | 63 | tTakeUntilToken :: BS.ByteString -> TransIO BS.ByteString 64 | tTakeUntilToken token= withData $ \str -> takeit mempty str 65 | where 66 | takeit :: BS.ByteString -> BS.ByteString -> TransIO ( BS.ByteString, BS.ByteString) 67 | takeit res str= 68 | if BS.null str then return (res,str) else 69 | if token `BS.isPrefixOf` str 70 | then return (res !> ("tTakeUntilString",res),BS.drop (BS.length token) str) 71 | else if not $ BS.null str then takeit ( BS.snoc res (BS.head str)) $ BS.tail str else empty 72 | 73 | -- | read an Integer 74 | integer :: TransIO Integer 75 | integer= do 76 | s <- tTakeWhile isNumber 77 | if BS.null s then empty else return $ stoi 0 s 78 | :: TransIO Integer 79 | 80 | where 81 | stoi :: Integer -> BS.ByteString -> Integer 82 | stoi x s| BS.null s = x 83 | | otherwise= stoi (x *10 + fromIntegral(ord (BS.head s) - ord '0')) (BS.tail s) 84 | 85 | 86 | 87 | -- | read an Int 88 | int :: TransIO Int 89 | int= do 90 | s <- tTakeWhile' isNumber 91 | if BS.null s then empty else return $ stoi 0 s 92 | 93 | where 94 | stoi :: Int -> BS.ByteString -> Int 95 | stoi x s| BS.null s = x 96 | | otherwise= stoi (x *10 + (ord (BS.head s) - ord '0')) (BS.tail s) 97 | 98 | 99 | -- | read many results with a parser (at least one) until a `end` parser succeed. 100 | 101 | 102 | 103 | manyTill :: TransIO a -> TransIO b -> TransIO [a] 104 | manyTill= chainManyTill (:) 105 | 106 | chainManyTill op p end= op <$> p <*> scan 107 | where 108 | scan = do{ end; return mempty } 109 | <|> 110 | do{ x <- p; xs <- scan; return (x `op` xs) } 111 | 112 | between open close p 113 | = do{ open; x <- p; close; return x } 114 | 115 | symbol = string 116 | 117 | parens p = between (symbol "(") (symbol ")") p !> "parens " 118 | braces p = between (symbol "{") (symbol "}") p !> "braces " 119 | angles p = between (symbol "<") (symbol ">") p !> "angles " 120 | brackets p = between (symbol "[") (symbol "]") p !> "brackets " 121 | 122 | semi = symbol ";" !> "semi" 123 | comma = symbol "," !> "comma" 124 | dot = symbol "." !> "dot" 125 | colon = symbol ":" !> "colon" 126 | 127 | 128 | 129 | sepBy p sep = sepBy1 p sep <|> return [] 130 | 131 | 132 | sepBy1 = chainSepBy1 (:) 133 | 134 | 135 | chainSepBy chain p sep= chainSepBy1 chain p sep <|> return mempty 136 | 137 | -- take a byteString of elements separated by a separator and apply the desired operator to the parsed results 138 | chainSepBy1 139 | :: (Monad m, Monoid b, Alternative m) => 140 | (a -> b -> b) -> m a -> m x -> m b 141 | chainSepBy1 chain p sep= do{ x <- p 142 | ; xs <- chainMany chain (sep >> p) 143 | ; return (x `chain` xs) 144 | } 145 | !> "chainSepBy " 146 | 147 | chainMany chain v= (chain <$> v <*> chainMany chain v) <|> return mempty 148 | 149 | commaSep p = sepBy p comma 150 | semiSep p = sepBy p semi 151 | 152 | commaSep1 p = sepBy1 p comma 153 | semiSep1 p = sepBy1 p semi 154 | 155 | dropSpaces= withData $ \str -> return( (),BS.dropWhile isSpace str) 156 | 157 | dropTillEndOfLine= withData $ \str -> return ((),BS.dropWhile ( /= '\n') str) !> "dropTillEndOfLine" 158 | 159 | 160 | --manyTill anyChar (tChar '\n' <|> (isDonep >> return ' ') ) 161 | 162 | parseString= do 163 | dropSpaces 164 | tTakeWhile (not . isSpace) 165 | 166 | -- | take characters while they meet the condition 167 | tTakeWhile :: (Char -> Bool) -> TransIO BS.ByteString 168 | tTakeWhile cond= -- parse (BS.span cond) 169 | withData $ \s -> let (h,t)= BS.span cond s in if BS.null h then empty else return (h,t) !> ("tTakeWhile",h) 170 | 171 | 172 | -- | take characters while they meet the condition and drop the next character 173 | tTakeWhile' :: (Char -> Bool) -> TransIO BS.ByteString 174 | tTakeWhile' cond= withData $ \s -> do 175 | let (h,t)= BS.span cond s 176 | return () !> ("takewhile'",h,t) 177 | if BS.null h then empty else return (h, if BS.null t then t else BS.tail t) 178 | 179 | 180 | just1 f x= let (h,t)= f x in (Just h,t) 181 | 182 | -- | take n characters 183 | tTake n= withData $ \s -> return $ BS.splitAt n s -- !> ("tTake",n,BS.take n s) 184 | 185 | -- | drop n characters 186 | tDrop n= withData $ \s -> return $ ((),BS.drop n s) 187 | 188 | -- | read a char 189 | anyChar= withData $ \s -> if BS.null s then empty else return (BS.head s,BS.tail s) -- !> ("anyChar",s) 190 | 191 | -- | verify that the next character is the one expected 192 | tChar c= withData $ \s -> if BS.null s || BS.head s /= c then empty else return (BS.head s,BS.tail s) !> ("tChar", BS.head s) 193 | -- anyChar >>= \x -> if x == c then return c else empty !> ("tChar",x) 194 | 195 | 196 | 197 | 198 | -- | bring the lazy byteString state to a parser 199 | -- and actualize the byteString state with the result 200 | -- The tuple that the parser should return should be : (what it returns, what should remain to be parsed) 201 | withData :: (BS.ByteString -> TransIO (a,BS.ByteString)) -> TransIO a 202 | withData parser= Transient $ do 203 | ParseContext readMore s <- getData `onNothing` error "parser: no context" 204 | 205 | let loop = unsafeInterleaveIO $ do 206 | mr <- readMore 207 | 208 | return () !> ("readMore",mr) 209 | case mr of 210 | SMore r -> (r <>) `liftM` loop 211 | SLast r -> return r 212 | SDone -> return mempty -- !> "withData SDONE" 213 | str <- liftIO $ (s <> ) `liftM` loop -- liftIO $ return r <> loop works in GHC 8.5 on 214 | --if str == mempty then return Nothing else do 215 | mr <- runTrans $ parser str 216 | case mr of 217 | Nothing -> return Nothing -- !> "NOTHING" 218 | Just (v,str') -> do 219 | setData $ ParseContext readMore str' 220 | return $ Just v 221 | 222 | 223 | 224 | -- | bring the data of the parse context as a lazy byteString 225 | giveData= (noTrans $ do 226 | ParseContext readMore s <- getData `onNothing` error "parser: no context" 227 | :: StateIO (ParseContext BS.ByteString) -- change to strict BS 228 | 229 | let loop = unsafeInterleaveIO $ do 230 | mr <- readMore 231 | case mr of 232 | SMore r -> (r <>) `liftM` loop 233 | SLast r -> (r <>) `liftM` loop 234 | SDone -> return mempty 235 | liftIO $ (s <> ) `liftM` loop) 236 | 237 | -- | True if the stream has finished 238 | isDone :: TransIO Bool 239 | isDone= noTrans $ do 240 | return () !> "isDone" 241 | ParseContext readMore s <- getData `onNothing` error "parser: no context" 242 | :: StateIO (ParseContext BS.ByteString) -- change to strict BS 243 | if not $ BS.null s then return False else do 244 | mr <- liftIO readMore 245 | case mr of 246 | SMore r -> do setData $ ParseContext readMore r ; return False 247 | SLast r -> do setData $ ParseContext readMore r ; return False 248 | SDone -> return True 249 | 250 | 251 | 252 | 253 | 254 | 255 | -- infixl 0 |- 256 | 257 | -- | Chain two parsers. The motivation is to parse a chunked HTTP response which contains 258 | -- JSON messages. 259 | -- 260 | -- If the REST response is infinite and contains JSON messages, I have to chain the 261 | -- dechunk parser with the JSON decoder of aeson, to produce a stream of aeson messages. 262 | -- Since the boundaries of chunks and JSON messages do not match, it is not possible to add a 263 | -- `decode` to the monadic pipeline. Since the stream is potentially infinite and/or the 264 | -- messages may arrive at any time, I can not wait until all the input finish before decoding 265 | -- the messages. 266 | -- 267 | -- I need to generate a ByteString stream with the first parser, which is the input for 268 | -- the second parser. 269 | -- 270 | -- The first parser wait until the second consume the previous chunk, so it is pull-based. 271 | -- 272 | -- many parsing stages can be chained with this operator. 273 | -- 274 | -- The output is nondeterministic: it can return 0, 1 or more results 275 | -- 276 | -- example: https://t.co/fmx1uE2SUd 277 | (|-) :: TransIO (StreamData BS.ByteString) -> TransIO b -> TransIO b 278 | p |- q = do 279 | v <- liftIO $ newEmptyMVar 280 | initp v <|> initq v 281 | 282 | where 283 | initq v= do 284 | --abduce 285 | setParseStream (takeMVar v >>= \v -> (return v !> ("!- operator return",v))) -- each time the parser need more data, takes the var 286 | q 287 | 288 | initp v= abduce >> repeatIt 289 | where 290 | repeatIt= (do r <- p; liftIO (putMVar v r !> "putMVar") ; empty) <|> repeatIt 291 | 292 | -------------------------------------------------------------------------------- /src/Transient/Parse.new.hs: -------------------------------------------------------------------------------- 1 | {-#LANGUAGE FlexibleContexts, ExistentialQuantification, ScopedTypeVariables, OverloadedStrings, TypeSynonymInstances, FlexibleInstances #-} 2 | module Transient.Parse where 3 | import Transient.Internals 4 | import Transient.Indeterminism 5 | import Data.String 6 | import Data.Typeable 7 | import Control.Applicative 8 | import Data.Char 9 | import Data.Monoid 10 | import System.IO.Unsafe 11 | import Control.Monad 12 | import Control.Monad.State 13 | -- import Control.Exception (throw,IOException) 14 | import Control.Concurrent.MVar 15 | 16 | 17 | import qualified Data.ByteString.Lazy.Char8 as BS 18 | 19 | -- | set a stream of strings to be parsed 20 | setParseStream :: IO (StreamData BS.ByteString) -> TransIO () 21 | setParseStream iox= setState $ ParseContext iox "" 22 | 23 | -- | set a string to be parsed 24 | setParseString :: BS.ByteString -> TransIO () 25 | setParseString x = do delData NoRemote; setState $ ParseContext (return SDone) x 26 | 27 | withParseString :: BS.ByteString -> TransIO a -> TransIO a 28 | withParseString x parse= do 29 | p@(ParseContext c str) <- getState <|> return(ParseContext (return SDone) mempty) 30 | setParseString x 31 | r <- parse 32 | setState (ParseContext c (str :: BS.ByteString)) 33 | return r 34 | 35 | -- | The parse context contains either the string to be parsed or a computation that gives an stream of 36 | -- strings or both. First, the string is parsed. If it is empty, the stream is pulled for more. 37 | data ParseContext str = IsString str => ParseContext (IO (StreamData str)) str deriving Typeable 38 | 39 | 40 | -- | succeed if read the string given as parameter 41 | string :: BS.ByteString -> TransIO BS.ByteString 42 | string s=withData $ \str -> do 43 | let len= BS.length s 44 | ret@(s',_) = BS.splitAt len str 45 | if s == s' !> (s,s') 46 | then return ret 47 | else empty !> "STRING EMPTY" 48 | 49 | -- | fast search for a token 50 | tDropUntilToken token= withData $ \str -> 51 | if BS.null str then empty else drop2 str 52 | where 53 | drop2 str= 54 | if token `BS.isPrefixOf` str !> (BS.take 2 str) 55 | then return ((),BS.drop (BS.length token) str) 56 | else if not $ BS.null str then drop2 $ BS.tail str else empty 57 | 58 | tTakeUntilToken :: BS.ByteString -> TransIO BS.ByteString 59 | tTakeUntilToken token= withData $ \str -> takeit mempty str 60 | where 61 | takeit :: BS.ByteString -> BS.ByteString -> TransIO ( BS.ByteString, BS.ByteString) 62 | takeit res str= 63 | if BS.null str then return (res,str) else 64 | if token `BS.isPrefixOf` str 65 | then return (res !> ("tTakeUntilString",res),BS.drop (BS.length token) str) 66 | else if not $ BS.null str then takeit ( BS.snoc res (BS.head str)) $ BS.tail str else empty 67 | 68 | -- | read an Integer 69 | integer :: TransIO Integer 70 | integer= do 71 | s <- tTakeWhile isNumber 72 | if BS.null s then empty else return $ stoi 0 s 73 | :: TransIO Integer 74 | 75 | where 76 | stoi :: Integer -> BS.ByteString -> Integer 77 | stoi x s| BS.null s = x 78 | | otherwise= stoi (x *10 + fromIntegral(ord (BS.head s) - ord '0')) (BS.tail s) 79 | 80 | 81 | 82 | -- | read an Int 83 | int :: TransIO Int 84 | int= do 85 | s <- tTakeWhile' isNumber 86 | if BS.null s then empty else return $ stoi 0 s 87 | 88 | where 89 | stoi :: Int -> BS.ByteString -> Int 90 | stoi x s| BS.null s = x 91 | | otherwise= stoi (x *10 + (ord (BS.head s) - ord '0')) (BS.tail s) 92 | 93 | 94 | -- | read many results with a parser (at least one) until a `end` parser succeed. 95 | 96 | 97 | 98 | manyTill :: TransIO a -> TransIO b -> TransIO [a] 99 | manyTill= chainManyTill (:) 100 | 101 | chainManyTill op p end= op <$> p <*> scan 102 | where 103 | scan = do{ end; return mempty } 104 | <|> 105 | do{x <- p; xs <- scan; return (x `op` xs) } 106 | 107 | between open close p 108 | = do{ open; x <- p; close; return x } 109 | 110 | symbol x= do string x 111 | 112 | parens p = between (symbol "(") (symbol ")") p !> "parens " 113 | braces p = between (symbol "{") (symbol "}") p !> "braces " 114 | angles p = between (symbol "<") (symbol ">") p !> "angles " 115 | brackets p = between (symbol "[") (symbol "]") p !> "brackets " 116 | 117 | semi = symbol ";" !> "semi" 118 | comma = symbol "," !> "comma" 119 | dot = symbol "." !> "dot" 120 | colon = symbol ":" !> "colon" 121 | 122 | 123 | 124 | sepBy p sep = sepBy1 p sep <|> return [] 125 | 126 | 127 | sepBy1 = chainSepBy1 (:) 128 | 129 | 130 | chainSepBy chain p sep= chainSepBy1 chain p sep <|> return mempty 131 | 132 | -- take a byteString of elements separated by a separator and apply the desired operator to the parsed results 133 | chainSepBy1 134 | :: (Monad m, Monoid b, Alternative m) => 135 | (a -> b -> b) -> m a -> m x -> m b 136 | chainSepBy1 chain p sep= do{ x <- p 137 | ; xs <- chainMany chain (sep >> p) 138 | ; return (x `chain` xs) 139 | } 140 | !> "chainSepBy " 141 | 142 | chainMany chain v= (chain <$> v <*> chainMany chain v) <|> return mempty 143 | 144 | commaSep p = sepBy p comma 145 | semiSep p = sepBy p semi 146 | 147 | commaSep1 p = sepBy1 p comma 148 | semiSep1 p = sepBy1 p semi 149 | 150 | -- drop any character that match `Data.Char.isSpace` 151 | dropSpaces= withData $ \str -> return( (),BS.dropWhile isSpace str) 152 | 153 | -- drop spaces until end of line. If detect an end of string it fails 154 | dropSpacesNoEOL= withData $ \str -> 155 | let str'= BS.dropWhile (\c -> isSpace c && c /= '\n') str 156 | in if BS.null str' 157 | then empty 158 | else if BS.head str' == '\n' then empty else return ((),str') 159 | 160 | 161 | dropTillEndOfLine= withData $ \str -> return ((),BS.dropWhile ( /= '\n') str) 162 | 163 | -- manyTill anyChar (tChar '\n' <|> (isDonep >> return ' ') ) 164 | 165 | parseString= do 166 | dropSpaces 167 | s <- tTakeWhile (not . isSpace) 168 | if BS.null s then empty else return s 169 | 170 | -- | take characters while they meet the condition 171 | tTakeWhile :: (Char -> Bool) -> TransIO BS.ByteString 172 | tTakeWhile cond= 173 | withData $ \s -> return $ BS.span cond s -- $ let r@(h,t)= (BS.span cond s !> ("tTakeWhile",h)) in r 174 | 175 | 176 | -- | take characters while they meet the condition and drop the next character 177 | tTakeWhile' :: (Char -> Bool) -> TransIO BS.ByteString 178 | tTakeWhile' cond= withData $ \s -> 179 | let (h,t)= BS.span cond s 180 | in return (h, if BS.null t then t else BS.tail t) !> ("tTakeWhile'",h) 181 | 182 | 183 | just1 f x= let (h,t)= f x in (Just h,t) 184 | 185 | -- | take n characters 186 | tTake n= withData $ \s -> return $ BS.splitAt n s !> ("tTake",n) 187 | 188 | -- | drop n characters 189 | tDrop n= withData $ \s -> return $ ((),BS.drop n s) 190 | 191 | -- | read a char 192 | anyChar= withData $ \s -> if BS.null s then empty else return (BS.head s,BS.tail s) -- !> ("anyChar",s) 193 | 194 | -- | verify that the next character is the one expected 195 | tChar c= withData $ \s -> if BS.null s || BS.head s /= c then empty else return (BS.head s,BS.tail s) !> ("tChar", BS.head s) 196 | -- anyChar >>= \x -> if x == c then return c else empty !> ("tChar",x) 197 | 198 | -- | parse an IP address 199 | parseIP= do 200 | dropSpaces 201 | i1 <- byteInt 202 | tChar '.' 203 | i2 <- byteInt 204 | tChar '.' 205 | i3 <- byteInt 206 | tChar '.' 207 | i4 <- byteInt 208 | return $ i1 ++ ('.':i2) ++ ( '.':i3)++ ('.':i4) 209 | 210 | where 211 | byteInt= do 212 | i <- integer 213 | 214 | if i < 0 || i > 255 then empty 215 | else return $ show i 216 | 217 | 218 | -- | bring the data of a parse context as a lazy byteString to a parser 219 | -- and actualize the parse context with the result 220 | withData :: (BS.ByteString -> TransIO (a,BS.ByteString)) -> TransIO a 221 | withData parser= Transient $ do 222 | ParseContext readMore s <- getData `onNothing` error "parser: no context" 223 | 224 | let loop = unsafeInterleaveIO $ do 225 | mr <- readMore 226 | -- return () !> ("readMore",mr) 227 | case mr of 228 | SMore r -> (r <>) `liftM` loop 229 | SLast r -> return r 230 | SDone -> return mempty 231 | str <- liftIO $ (s <> ) `liftM` loop 232 | if str == mempty then return Nothing else do 233 | mr <- runTrans $ parser str 234 | case mr of 235 | Nothing -> return Nothing -- !> "NOTHING" 236 | Just (v,str') -> do 237 | setData $ ParseContext readMore str' 238 | return $ Just v 239 | 240 | 241 | 242 | -- | bring the data of the parse context as a lazy byteString 243 | giveData= (noTrans $ do 244 | ParseContext readMore s <- getData `onNothing` error "parser: no context" 245 | :: StateIO (ParseContext BS.ByteString) -- change to strict BS 246 | 247 | let loop = unsafeInterleaveIO $ do 248 | mr <- readMore 249 | case mr of 250 | SMore r -> (r <>) `liftM` loop 251 | SLast r -> (r <>) `liftM` loop 252 | SDone -> return mempty 253 | liftIO $ (s <> ) `liftM` loop) 254 | 255 | -- | True if the stream has finished 256 | isDone :: TransIO Bool 257 | isDone= withData $ \s -> return $ if s==mempty then (True,s) else (False,s) 258 | 259 | -- | return true if the stream finished. else fails 260 | isDonep= isDone >>= \r -> if r== True then return True else empty 261 | 262 | isDone1= noTrans $ do 263 | return () !> "isDone" 264 | ParseContext readMore s <- getData `onNothing` error "parser: no context" 265 | :: StateIO (ParseContext BS.ByteString) -- change to strict BS 266 | mr <- if not $ BS.null s then return $ SMore s else liftIO readMore 267 | 268 | case mr of 269 | SMore r -> do setData $ ParseContext readMore r ; return False 270 | SLast r -> do setData $ ParseContext readMore r ; return False 271 | SDone -> return True 272 | 273 | 274 | 275 | 276 | isDonep1= noTrans $ do 277 | return () !> "isDone" 278 | ParseContext readMore s <- getData `onNothing` error "parser: no context" 279 | :: StateIO (ParseContext BS.ByteString) -- change to strict BS 280 | if BS.null s then return $ Just True else do 281 | mr <- liftIO readMore 282 | case mr of 283 | SMore r -> do setData $ ParseContext readMore r ; return Nothing 284 | SLast r -> do setData $ ParseContext readMore r ; return Nothing 285 | SDone -> return Nothing 286 | 287 | -- infixl 0 |- 288 | 289 | -- | Chain two parsers. The motivation is to parse a chunked HTTP response which contains 290 | -- JSON messages. 291 | -- 292 | -- If the REST response is infinite and contains JSON messages, I have to chain the 293 | -- dechunk parser with the JSON decoder of aeson, to produce a stream of aeson messages. 294 | -- Since the boundaries of chunks and JSON messages do not match, it is not possible to add a 295 | -- `decode` to the monadic pipeline. Since the stream is potentially infinite and/or the 296 | -- messages may arrive at any time, I can not wait until all the input finish before decoding 297 | -- the messages. 298 | -- 299 | -- I need to generate a ByteString stream with the first parser, which is the input for 300 | -- the second parser. 301 | -- 302 | -- The first parser wait until the second consume the previous chunk, so it is pull-based. 303 | -- 304 | -- many parsing stages can be chained with this operator. 305 | -- 306 | -- The output is nondeterministic: it can return 0, 1 or more results 307 | -- 308 | -- example: https://t.co/fmx1uE2SUd 309 | (|-) :: TransIO (StreamData BS.ByteString) -> TransIO b -> TransIO b 310 | p |- q = do 311 | v <- liftIO $ newEmptyMVar 312 | initp v <|> initq v 313 | 314 | where 315 | initq v= do 316 | -- abduce 317 | setParseStream (takeMVar v) -- each time the parser need more data, takes the var 318 | q !> "init q" 319 | 320 | initp v= abduce >> repeatIt 321 | where 322 | repeatIt= (do r <- p; liftIO (putMVar v r !> "putMVar") ; empty) <|> repeatIt 323 | 324 | -------------------------------------------------------------------------------- /stack-ghcjs.yaml: -------------------------------------------------------------------------------- 1 | resolver: lts-7.7 2 | packages: 3 | - '.' 4 | extra-deps: [] 5 | flags: {} 6 | extra-package-dbs: [] 7 | 8 | compiler: ghcjs-0.2.1.9007007_ghc-8.0.1 9 | compiler-check: match-exact 10 | setup-info: 11 | ghcjs: 12 | source: 13 | ghcjs-0.2.1.9007007_ghc-8.0.1: 14 | url: http://ghcjs.tolysz.org/ghc-8.0-2016-11-03-lts-7.7-9007007.tar.gz 15 | sha1: ce169f85f1c49ad613ae77fc494d5565452ff59a 16 | allow-newer: true 17 | -------------------------------------------------------------------------------- /stack.yaml: -------------------------------------------------------------------------------- 1 | resolver: lts-7.7 2 | packages: 3 | - '.' 4 | extra-deps: [] 5 | flags: {} 6 | extra-package-dbs: [] 7 | pvp-bounds: both 8 | -------------------------------------------------------------------------------- /tests/Test.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP, ScopedTypeVariables, DeriveDataTypeable, RebindableSyntax #-} 2 | 3 | import qualified Prelude as Pr(return) 4 | import Prelude hiding ((>>=),(>>),return) 5 | import Transient.TypeLevel.Effects 6 | import Transient.TypeLevel.Base 7 | import Transient.TypeLevel.EVars 8 | import Transient.TypeLevel.Indeterminism 9 | 10 | import Transient.Logged 11 | import Data.Typeable 12 | import Control.Applicative 13 | import Data.Monoid 14 | 15 | import Data.Typeable 16 | import Data.IORef 17 | import Control.Concurrent (threadDelay) 18 | 19 | import System.Directory 20 | import System.IO 21 | import System.Random 22 | import Control.Exception 23 | import Control.Concurrent.MVar 24 | import Control.Concurrent 25 | 26 | import Data.String 27 | 28 | 29 | 30 | main= keep $ do 31 | r <- async $ Pr.return "hola" 32 | x <- waitEvents $ Pr.return $ "hello" 33 | liftIO $ print (r,x) 34 | 35 | {- 36 | main2= keep $ do 37 | v <- newEmptyMVar 38 | forkIO $ doasync >>= writeMVar v 39 | r <- readMVar v 40 | return r 41 | 42 | future <- async doasync 43 | r <- wait future 44 | 45 | r <- async doasync <|> async doasync2 46 | 47 | 48 | main1= keep $ do 49 | 50 | oneThread $ return () 51 | 52 | 53 | (async (threadDelay 1000) >> labelState (fromString "abduce") ) <|> return () -- ( topState >>= showThreads >>return ()) 54 | abduce 55 | labelState $ fromString "hello" 56 | topState >>= showThreads 57 | -} 58 | -------------------------------------------------------------------------------- /tests/Test2.hs: -------------------------------------------------------------------------------- 1 | -- 2 | -- The Computer Language Benchmarks Game 3 | -- http://benchmarksgame.alioth.debian.org/ 4 | -- 5 | -- Contributed by Don Stewart 6 | -- Parallelized by Louis Wasserman 7 | {-#LANGUAGE BangPatterns #-} 8 | 9 | import System.Environment 10 | import Control.Monad 11 | import System.Mem 12 | import Data.Bits 13 | import Text.Printf 14 | 15 | 16 | -- 17 | -- an artificially strict tree. 18 | -- 19 | -- normally you would ensure the branches are lazy, but this benchmark 20 | -- requires strict allocation. 21 | -- 22 | data Tree = Nil | Node !Int !Tree !Tree 23 | 24 | minN = 4 25 | 26 | io s n t = printf "%s of depth %d\t check: %d\n" s n t 27 | 28 | main = do 29 | n <- getArgs >>= readIO . head 30 | let maxN = max (minN + 2) n 31 | stretchN = maxN + 1 32 | -- stretch memory tree 33 | let c = {-# SCC "stretch" #-} check (make 0 stretchN) 34 | io "stretch tree" stretchN c 35 | 36 | -- allocate a long lived tree 37 | let !long = make 0 maxN 38 | 39 | -- allocate, walk, and deallocate many bottom-up binary trees 40 | let vs = depth minN maxN 41 | mapM_ (\((m,d,i)) -> io (show m ++ "\t trees") d i) vs 42 | 43 | -- confirm the the long-lived binary tree still exists 44 | io "long lived tree" maxN (check long) 45 | 46 | -- generate many trees 47 | depth :: Int -> Int -> [(Int,Int,Int)] 48 | depth d m 49 | | d <= m = let 50 | s = sumT d n 0 51 | rest = depth (d+2) m 52 | in s `par` ((2*n,d,s) : rest) 53 | | otherwise = [] 54 | where n = bit (m - d + minN) 55 | 56 | -- allocate and check lots of trees 57 | sumT :: Int -> Int -> Int -> Int 58 | sumT d 0 t = t 59 | sumT d i t = a `par` b `par` sumT d (i-1) ans 60 | where a = check (make i d) 61 | b = check (make (-i) d) 62 | ans = a + b + t 63 | 64 | check = check' True 0 65 | 66 | -- traverse the tree, counting up the nodes 67 | check' :: Bool -> Int -> Tree -> Int 68 | check' !b !z Nil = z 69 | check' b z (Node i l r) = check' (not b) (check' b (if b then z+i else z-i) l) r 70 | 71 | -- build a tree 72 | make :: Int -> Int -> Tree 73 | make i 0 = Node i Nil Nil 74 | make i d = Node i (make (i2-1) d2) (make i2 d2) 75 | where i2 = 2*i; d2 = d-1-- 76 | -------------------------------------------------------------------------------- /tests/Test3.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import Control.Monad 4 | import Control.Monad.IO.Class 5 | import System.Environment 6 | import System.IO 7 | import Transient.Base 8 | import Transient.Indeterminism 9 | import Transient.Logged 10 | import Transient.Move 11 | import Transient.Stream.Resource 12 | import Control.Applicative 13 | import System.Info 14 | import Control.Concurrent 15 | 16 | main = do 17 | 18 | let nodes= [createNode "localhost" 2020, createNode "192.168.99.100" 2020] 19 | args <- getArgs 20 | let [localnode, remote]= if length args > 0 then nodes 21 | else reverse nodes 22 | 23 | 24 | runCloud' $ do 25 | onAll $ addNodes nodes 26 | listen localnode <|> return () 27 | hello <|> helloworld <|> stream localnode 28 | 29 | hello= do 30 | local $ option "hello" "each computer say hello" 31 | 32 | r <- clustered $ do 33 | node <- getMyNode 34 | onAll . liftIO . print $ "hello " ++ os 35 | return ("hello from",os,arch, nodeHost node) 36 | 37 | lliftIO $ print r 38 | 39 | helloworld= do 40 | local $ option "helloword" "both computers compose \"hello world\"" 41 | r <- mclustered $ return $ if os== "linux" then "hello " else "world" 42 | lliftIO $ print r 43 | 44 | 45 | stream remoteHost= do 46 | local $ option "stream" "stream from the Linux node to windows" 47 | let fibs= 0 : 1 : zipWith (+) fibs (tail fibs) :: [Int] -- fibonacci numbers 48 | 49 | r <- runAt remoteHost $ local $ do 50 | r <- threads 1 $ choose $ take 10 fibs 51 | liftIO $ putStr os >> print r 52 | liftIO $ threadDelay 1000000 53 | return r 54 | lliftIO $ print r 55 | -------------------------------------------------------------------------------- /tests/TestSuite.hs: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env ./execthirdline.sh 2 | -- development 3 | -- set -e && docker run -it -v /c/Users/magocoal/OneDrive/Haskell/devel:/devel agocorona/transient:05-02-2017 bash -c "runghc -j2 -isrc -i/devel/transient/src /devel/transient/tests/$1 $2 $3 $4" 4 | 5 | -- compile and run within a docker image 6 | -- set -e && executable=`basename -s .hs ${1}` && docker run -it -v $(pwd):/work agocorona/transient:05-02-2017 bash -c "ghc /work/${1} && /work/${executable} ${2} ${3}" 7 | 8 | 9 | import qualified Prelude as Pr(return) 10 | import Prelude hiding ((>>=),(>>),return) 11 | 12 | import Transient.Base 13 | import Transient.EVars 14 | import Transient.Indeterminism 15 | 16 | import System.Exit 17 | import Data.Monoid 18 | import Control.Applicative 19 | import Control.Monad.State 20 | import System.Random 21 | import Control.Concurrent 22 | import Control.Exception.Base 23 | import Data.List 24 | 25 | 26 | --instance Monoid Int where 27 | -- mempty = 0 28 | -- mappend = (+) 29 | 30 | main= do 31 | keep' $ do 32 | let -- genElem :: a -> TransIO a 33 | genElem x= do 34 | isasync <- liftIO randomIO 35 | delay <- liftIO $ randomRIO (1, 1000) 36 | liftIO $ threadDelay delay 37 | if isasync then async $ return x else return x 38 | 39 | liftIO $ putStrLn "--Testing thread control + Monoid + Applicative + async + indetermism---" 40 | 41 | collect 100 $ do 42 | i <- threads 0 $ choose [1..100] 43 | nelems <- liftIO $ randomRIO (1, 10) -- :: TransIO Int 44 | nthreads <- liftIO $ randomRIO (1,nelems) 45 | r <- threads nthreads $ foldr (+) 0 $ map genElem [1..nelems] 46 | assert (r == sum[1..nelems]) $ return () 47 | 48 | liftIO $ putStrLn "--------------checking parallel execution, Alternative, events --------" 49 | ev <- newEVar 50 | r <- collect 3 $ readEVar ev <|> ((choose [1..3] >>= writeEVar ev) >> stop) 51 | assert (sort r== [1,2,3]) $ return () 52 | 53 | liftIO $ print "SUCCESS" 54 | exit () 55 | 56 | exitSuccess 57 | -------------------------------------------------------------------------------- /tests/Testspark.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ScopedTypeVariables, DeriveDataTypeable #-} 2 | module Main where 3 | import Transient.Base 4 | import Transient.Stream.Resource 5 | import Data.Char 6 | import Control.Monad.IO.Class 7 | 8 | main= keep . threads 0 $ do 9 | chunk <- sourceFile "../transient.cabal" 10 | liftIO $ print chunk 11 | return $ map toUpper chunk 12 | `sinkFile` "outfile" 13 | 14 | -------------------------------------------------------------------------------- /tests/ghcjs-websockets.hs: -------------------------------------------------------------------------------- 1 | 2 | {-# LANGUAGE ForeignFunctionInterface, JavaScriptFFI, DeriveDataTypeable, 3 | UnboxedTuples, GHCForeignImportPrim, UnliftedFFITypes, 4 | MagicHash, OverloadedStrings 5 | #-} 6 | import JavaScript.Web.WebSocket 7 | import JavaScript.Web.MessageEvent 8 | import Data.JSString (JSString) 9 | 10 | 11 | 12 | main :: IO () 13 | main = do 14 | wsloc <- wslocation 15 | print wsloc 16 | ws <- connect WebSocketRequest 17 | { url = wsloc -- "ws://localhost:2000" 18 | , protocols = ["chat"] 19 | , onClose = Just $ const $ return() -- Maybe (CloseEvent -> IO ()) -- ^ called when the connection closes (at most once) 20 | , onMessage = Just recMessage -- Maybe (MessageEvent -> IO ()) -- ^ called for each message 21 | } 22 | print "CONEXION REALIZADA" 23 | send "HELLOHELLOHELLOHELLOHELLOHELLO" ws 24 | 25 | recMessage e= -- print "SOMething HAS BEEN RECEIVED" 26 | do 27 | let d = getData e 28 | case d of 29 | StringData str -> putStrLn "RECEIVED " >> print str 30 | BlobData blob -> error " blob" 31 | ArrayBufferData arrBuffer -> error "arrBuffer" 32 | 33 | 34 | foreign import javascript unsafe 35 | "var loc = window.location, new_uri;\ 36 | \if (loc.protocol === \"https:\") {\ 37 | \ new_uri = \"wss:\";\ 38 | \} else {\ 39 | \ new_uri = \"ws:\";\ 40 | \}\ 41 | \new_uri += \"//\" + loc.host;\ 42 | \new_uri += loc.pathname;\ 43 | \$r = new_uri" 44 | wslocation :: IO JSString 45 | 46 | 47 | 48 | -------------------------------------------------------------------------------- /tests/labelthreads.hs: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | main2 = keep' $ do 6 | top <- topState 7 | r <- group 9 $ do 8 | x <- choose [1,2,3] 9 | labelState "async1" 10 | 11 | showThreads top 12 | liftIO $ threadDelay 1000000 13 | liftIO $ print x 14 | 15 | y <- choose ['a','b','c'] 16 | labelState "async2" 17 | showThreads top 18 | -- liftIO $ threadDelay 3000000 19 | id <- liftIO myThreadId 20 | liftIO $ print (x,y,id) 21 | liftIO $ print r 22 | -- liftIO $ threadDelay 1000000 23 | showThreads top 24 | 25 | 26 | 27 | main3= keep $ do 28 | top <- topState 29 | -- oneThread $ option "main" "to kill previous spawned processes and return to the main menu" <|> return "" 30 | -- liftIO $ putStrLn "MAIN MENU" 31 | showThreads top 32 | oneThread op1 33 | st <- getCont 34 | onFinish $ const $ do 35 | 36 | liftIO $ killChildren $ children st 37 | 38 | option "3" "3" 39 | liftIO $ print 3 40 | finish Nothing 41 | return () 42 | 43 | where 44 | op1= do 45 | 46 | option "1" "1" 47 | labelState "1" 48 | liftIO $ print 1 49 | op2= do 50 | 51 | option "2" "2" 52 | labelState "2" 53 | liftIO $ print 2 54 | 55 | -------------------------------------------------------------------------------- /tests/snippet: -------------------------------------------------------------------------------- 1 | :l tests/Test3.hs 2 | :l examples\Atm.hs 3 | :l examples\webapp.hs 4 | :set -i../ghcjs-hplay/src -i../ghcjs-perch/src 5 | :l examples\DistrbDataSets.hs 6 | :l examples\MainSamples.hs 7 | :l ..\..\stuff\skynet\skynetTrans.hs 8 | 9 | :step main 10 | 11 | 12 | -------------------------------------------------------------------------------- /tests/test5.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ScopedTypeVariables #-} 2 | module Main where 3 | 4 | import Transient.Move 5 | import Transient.Move.Utils 6 | import Transient.Logged 7 | import Transient.Base 8 | import Transient.Indeterminism 9 | import Transient.EVars 10 | import Network 11 | import Control.Applicative 12 | 13 | import Control.Monad.IO.Class 14 | import System.Environment 15 | import System.IO.Unsafe 16 | import Data.Monoid 17 | import System.IO 18 | import Control.Monad 19 | import Data.Maybe 20 | import Control.Exception hiding (onException) 21 | import Data.Typeable 22 | import Data.IORef 23 | import Data.List((\\)) 24 | 25 | 26 | 27 | 28 | 29 | 30 | -- to be executed with two or more nodes 31 | main = keep $ do 32 | r <- collect 0 $ liftIO $ print "hello" 33 | liftIO $ print r -------------------------------------------------------------------------------- /tests/teststream.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RecordWildCards, ScopedTypeVariables #-} 2 | 3 | module Main where 4 | 5 | import Network 6 | import qualified Network.Socket as NS 7 | import qualified Network.BSD as BSD 8 | 9 | 10 | import System.IO hiding (hPutBufNonBlocking) 11 | import Control.Concurrent 12 | import Control.Monad 13 | import Control.Exception 14 | import Control.Monad.IO.Class 15 | import qualified Data.ByteString.Char8 as BS 16 | import Foreign.Ptr 17 | import Foreign.Storable 18 | import Data.ByteString.Internal 19 | import Foreign.ForeignPtr.Safe 20 | 21 | import GHC.IO.Handle.Types 22 | import GHC.IO.Handle.Internals 23 | import GHC.IO.Buffer 24 | import GHC.IO.BufferedIO as Buffered 25 | import GHC.IO.Device as RawIO 26 | import GHC.IO.FD 27 | import GHC.Word 28 | import Data.IORef 29 | import Data.Typeable 30 | import System.IO.Unsafe 31 | import Data.Monoid 32 | 33 | main = do 34 | 35 | let port= PortNumber 2000 36 | 37 | forkIO $ listen' port 38 | h <- connectTo' "localhost" port 39 | liftIO $ hSetBuffering h $ BlockBuffering Nothing 40 | loop h 0 41 | getChar 42 | where 43 | loop h x = hPutStrLn' h (show x) >> loop h (x +1) 44 | 45 | hPutStrLn' h str= do 46 | let bs@(PS ps s l) = BS.pack $ str ++ "\n" 47 | n <- withForeignPtr ps $ \p-> hPutBufNonBlocking h (p `plusPtr` s) l 48 | when( n < l) $ do 49 | print (n,l) 50 | print "BUFFER FULLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLL" 51 | hFlush h 52 | print "AFTER BUFFER FLUSHHHH" 53 | withForeignPtr ps $ \p -> hPutBuf h ( p `plusPtr` (n * sizeOf 'x' ) ) (l - n) 54 | print "AFTER HPUTBUF" 55 | return () 56 | 57 | connectTo' hostname (PortNumber port) = do 58 | proto <- BSD.getProtocolNumber "tcp" 59 | bracketOnError 60 | (NS.socket NS.AF_INET NS.Stream proto) 61 | (sClose) -- only done if there's an error 62 | (\sock -> do 63 | NS.setSocketOption sock NS.SendBuffer 300 64 | he <- BSD.getHostByName hostname 65 | NS.connect sock (NS.SockAddrInet port (BSD.hostAddress he)) 66 | 67 | NS.socketToHandle sock ReadWriteMode 68 | ) 69 | 70 | hPutBufNonBlocking handle ptr count 71 | | count == 0 = return 0 72 | | count < 0 = error "negative chunk size" 73 | | otherwise = 74 | wantWritableHandle "hPutBuf" handle $ 75 | \ h_@Handle__{..} -> bufWriteNonBlocking h_ (castPtr ptr) count False 76 | 77 | 78 | 79 | bufWriteNonBlocking :: Handle__-> Ptr Word8 -> Int -> Bool -> IO Int 80 | bufWriteNonBlocking h_@Handle__{..} ptr count can_block = 81 | seq count $ do -- strictness hack 82 | old_buf@Buffer{ bufR=w, bufSize=size } <- readIORef haByteBuffer 83 | -- print (size,w, count) 84 | old_buf'@Buffer{ bufR=w', bufSize = size' } <- 85 | if size - w <= count 86 | then do 87 | (written,old_buf') <- Buffered.flushWriteBuffer0 haDevice old_buf 88 | writeIORef haByteBuffer old_buf' 89 | print (size , written,w, count) 90 | print (bufSize old_buf', bufR old_buf') 91 | return old_buf' 92 | else return old_buf 93 | 94 | let count'= if size' - w' > count then count else size' - w' 95 | writeChunkNonBlocking h_ (castPtr ptr) count' 96 | writeIORef haByteBuffer old_buf'{ bufR = w' + count' } 97 | 98 | return count' 99 | 100 | 101 | 102 | writeChunkNonBlocking h_@Handle__{..} ptr bytes 103 | | Just fd <- cast haDevice = RawIO.writeNonBlocking (fd::FD) ptr bytes 104 | | otherwise = error "Todo: hPutBuf" 105 | 106 | 107 | 108 | 109 | listen' port = do 110 | sock <- withSocketsDo $ listenOn port 111 | (h,host,port1) <- accept sock 112 | hSetBuffering h $ BlockBuffering Nothing 113 | repeatRead h 114 | where 115 | repeatRead h= do 116 | forkIO $ doit h 117 | return() 118 | where 119 | doit h= do 120 | s <- hGetLine h 121 | -- print s 122 | --threadDelay 10 123 | doit h 124 | 125 | 126 | 127 | 128 | -------------------------------------------------------------------------------- /tests/teststreamsocket.hs: -------------------------------------------------------------------------------- 1 | test.hs{-# LANGUAGE RecordWildCards, ScopedTypeVariables #-} 2 | 3 | module Main where 4 | 5 | import Network 6 | import qualified Network.Socket as NS hiding (send, sendTo, recv, recvFrom) 7 | import Network.Socket.ByteString 8 | import qualified Network.BSD as BSD 9 | 10 | 11 | import System.IO hiding (hPutBufNonBlocking) 12 | import Control.Concurrent 13 | import Control.Monad 14 | import Control.Exception 15 | import Control.Monad.IO.Class 16 | import qualified Data.ByteString.Char8 as BS 17 | import Foreign.Ptr 18 | import Foreign.Storable 19 | import Data.ByteString.Internal 20 | import Foreign.ForeignPtr.Safe 21 | 22 | 23 | 24 | main = do 25 | 26 | 27 | let host= "localhost"; port= 2000 28 | forkIO $ listen' $ PortNumber port 29 | proto <- BSD.getProtocolNumber "tcp" 30 | bracketOnError 31 | (NS.socket NS.AF_INET NS.Stream proto) 32 | (sClose) -- only done if there's an error 33 | (\sock -> do 34 | NS.setSocketOption sock NS.RecvBuffer 3000 35 | he <- BSD.getHostByName "localhost" 36 | NS.connect sock (NS.SockAddrInet port (BSD.hostAddress he)) 37 | loop sock 0 38 | getChar) 39 | where 40 | loop sock x = do 41 | 42 | let msg = BS.pack $ show x ++ "\n" 43 | let l = BS.length msg 44 | n <- send sock msg 45 | when (n < l) $ do 46 | print $ "CONGESTION "++ show (l-n) 47 | sendAll sock $ BS.drop n msg 48 | 49 | loop sock (x +1) 50 | 51 | 52 | 53 | 54 | 55 | 56 | listen' port = do 57 | sock <- listenOn port 58 | (h,host,port1) <- accept sock 59 | hSetBuffering h $ BlockBuffering Nothing 60 | repeatRead h 61 | where 62 | repeatRead h= do 63 | forkIO $ doit h 64 | return() 65 | where 66 | doit h= do 67 | s <- hGetLine h 68 | print s 69 | threadDelay 1000000 70 | doit h 71 | 72 | 73 | 74 | 75 | -------------------------------------------------------------------------------- /transient.cabal: -------------------------------------------------------------------------------- 1 | name: transient 2 | version: 0.6.4 3 | author: Alberto G. Corona 4 | extra-source-files: 5 | ChangeLog.md README.md 6 | maintainer: agocorona@gmail.com 7 | cabal-version: >=1.10 8 | build-type: Simple 9 | license: MIT 10 | license-file: LICENSE 11 | homepage: https://github.com/transient-haskell/transient 12 | bug-reports: https://github.com/transient-haskell/transient/issues 13 | synopsis: composing programs with multithreading, events and distributed computing 14 | description: See 15 | Distributed primitives are in the transient-universe package. Web primitives are in the axiom package. 16 | category: Control, Concurrency 17 | data-dir: "" 18 | 19 | flag debug 20 | description: Enable debugging outputs 21 | default: False 22 | manual: True 23 | 24 | library 25 | -- Note: `stack sdist/upload` will add missing bounds (via "pvp-bounds: both") in `build-depends` 26 | -- support GHC 7.10.3 and later; lower bounds below denote GHC 7.10.3's bundled versions 27 | build-depends: base >= 4.8.0 && < 5 28 | , containers >= 0.5.6 29 | , transformers >= 0.4.2 30 | , time >= 1.5 31 | , directory >= 1.2.2 32 | , bytestring >= 0.10.6 33 | , type-level-sets 34 | 35 | -- libraries not bundled w/ GHC 36 | , mtl 37 | , stm 38 | , random 39 | , primitive < 0.6.4 40 | 41 | 42 | exposed-modules: Transient.Backtrack 43 | Transient.Base 44 | Transient.EVars 45 | Transient.Indeterminism 46 | Transient.Internals 47 | Transient.Logged 48 | Transient.Parse 49 | 50 | 51 | 52 | exposed: True 53 | buildable: True 54 | default-language: Haskell2010 55 | hs-source-dirs: src . 56 | 57 | ghc-options: -O -threaded -rtsopts 58 | 59 | if flag(debug) 60 | cpp-options: -DDEBUG 61 | 62 | source-repository head 63 | type: git 64 | location: https://github.com/agocorona/transient 65 | 66 | test-suite test-transient 67 | 68 | if !impl(ghcjs >=0.1) 69 | build-depends: 70 | base >= 4.8.1 && < 5 71 | , containers >= 0.5.6 72 | , transformers >= 0.4.2 73 | , time >= 1.5 74 | , directory >= 1.2.2 75 | , bytestring >= 0.10.6 76 | 77 | -- libraries not bundled w/ GHC 78 | , mtl 79 | , stm 80 | , random 81 | 82 | 83 | type: exitcode-stdio-1.0 84 | main-is: TestSuite.hs 85 | build-depends: 86 | base >4 87 | default-language: Haskell2010 88 | hs-source-dirs: tests src . 89 | ghc-options: -threaded -rtsopts 90 | --------------------------------------------------------------------------------