promises (empty) → 0

raw patch · 8 files changed

+361/−0 lines, 8 filesdep +basedep +monad-stsetup-changed

Dependencies added: base, monad-st

Files

.gitignore +17/−0
.travis.yml +56/−0
CHANGELOG.markdown +3/−0
LICENSE +26/−0
README.markdown +15/−0
Setup.lhs +7/−0
promises.cabal +38/−0
src/Data/Promise.hs +199/−0

+ .gitignore view

@@ -0,0 +1,17 @@+dist/+.hsenv/+docs+wiki+TAGS+tags+wip+.DS_Store+.*.swp+.*.swo+*.o+*.hi+*~+*#+.cabal-sandbox/+cabal.sandbox.config+codex.tags

+ .travis.yml view

@@ -0,0 +1,56 @@+# NB: don't set `language: haskell` here++# See also https://github.com/hvr/multi-ghc-travis for more information+env:+ - GHCVER=7.8.4 CABALVER=1.18+ - GHCVER=7.10.1 CABALVER=1.22+ - GHCVER=head CABALVER=1.22++matrix:+  allow_failures:+   - env: GHCVER=head CABALVER=1.22++# Note: the distinction between `before_install` and `install` is not+#       important.+before_install:+ - travis_retry sudo add-apt-repository -y ppa:hvr/ghc+ - travis_retry sudo apt-get update+ - travis_retry sudo apt-get install cabal-install-$CABALVER ghc-$GHCVER+ - export PATH=/opt/ghc/$GHCVER/bin:/opt/cabal/$CABALVER/bin:$PATH+ - cabal --version++install:+ - travis_retry cabal update+ - cabal install --only-dependencies --force++# Here starts the actual work to be performed for the package under+# test; any command which exits with a non-zero exit code causes the+# build to fail.+script:+ # -v2 provides useful information for debugging+ - cabal configure -v2++ # this builds all libraries and executables+ # (including tests/benchmarks)+ - cabal build++ # tests that a source-distribution can be generated+ - cabal sdist++ # check that the generated source-distribution can be built & installed+ - export SRC_TGZ=$(cabal info . | awk '{print $2 ".tar.gz";exit}') ;+   cd dist/;+   if [ -f "$SRC_TGZ" ]; then+      cabal install --force-reinstalls "$SRC_TGZ";+   else+      echo "expected '$SRC_TGZ' not found";+      exit 1;+   fi++notifications:+  irc:+    channels:+      - "irc.freenode.org#haskell-lens"+    skip_join: true+    template:+      - "\x0313promises\x03/\x0306%{branch}\x03 \x0314%{commit}\x03 %{build_url} %{message}"

+ CHANGELOG.markdown view

@@ -0,0 +1,3 @@+## 0++* Repository initialized

+ LICENSE view

@@ -0,0 +1,26 @@+Copyright 2015 Edward Kmett++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions+are met:++1. Redistributions of source code must retain the above copyright+   notice, this list of conditions and the following disclaimer.++2. Redistributions in binary form must reproduce the above copyright+   notice, this list of conditions and the following disclaimer in the+   documentation and/or other materials provided with the distribution.++THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND ANY EXPRESS OR+IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED+WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE+DISCLAIMED.  IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR+ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL+DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS+OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)+HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,+STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN+ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE+POSSIBILITY OF SUCH DAMAGE.

+ README.markdown view

@@ -0,0 +1,15 @@+promises+========++[![Build Status](https://secure.travis-ci.org/ekmett/promises.png?branch=master)](http://travis-ci.org/ekmett/promises)++Lazy demand-driven promises++Contact Information+-------------------++Contributions and bug reports are welcome!++Please feel free to contact me through github or on the #haskell IRC channel on irc.freenode.net.++-Edward Kmett

+ Setup.lhs view

@@ -0,0 +1,7 @@+#!/usr/bin/runhaskell+> module Main (main) where++> import Distribution.Simple++> main :: IO ()+> main = defaultMain

+ promises.cabal view

@@ -0,0 +1,38 @@+name:          promises+category:      Lazy, Concurrent+version:       0+license:       BSD3+cabal-version: >= 1.10+license-file:  LICENSE+author:        Edward A. Kmett+maintainer:    Edward A. Kmett <ekmett@gmail.com>+stability:     experimental+homepage:      http://github.com/ekmett/promises/+bug-reports:   http://github.com/ekmett/promises/issues+copyright:     Copyright (C) 2015 Edward A. Kmett+build-type:    Simple+tested-with:   GHC == 7.8.4, GHC == 7.10.1, GHC == 7.11.20150615+synopsis:      Lazy demand-driven promises+description:   Lazy demand-driven promises++extra-source-files:+  .travis.yml+  .gitignore+  README.markdown+  CHANGELOG.markdown++source-repository head+  type: git+  location: git://github.com/ekmett/promises.git++library+  default-language: Haskell2010+  ghc-options: -Wall+  hs-source-dirs: src++  exposed-modules:+    Data.Promise++  build-depends:+    base     >= 4.7   && < 5,+    monad-st >= 0.2.4 && < 1

+ src/Data/Promise.hs view

@@ -0,0 +1,199 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE RoleAnnotations #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE Trustworthy #-}+{-# OPTIONS_GHC -fno-cse -fno-full-laziness #-}++-----------------------------------------------------------------------------+-- |+-- Copyright   :  (C) 2015 Edward Kmett+-- License     :  BSD-style (see the file LICENSE)+-- Maintainer  :  Edward Kmett <ekmett@gmail.com>+-- Stability   :  experimental+-- Portability :  non-portable+--+-- Lazy demand-driven promises.+--+-----------------------------------------------------------------------------++module Data.Promise+  ( Lazy, runLazy, runLazy_+  , Promise(..)+  , promise, promise_+  , (!=)+  , demand+  , BrokenPromise(..)+  ) where++#if __GLASGOW_HASKELL__ < 710+import Control.Applicative+#endif+import Control.Concurrent.MVar+import Control.Exception+import Control.Monad (ap)+import Control.Monad.Fix+import Control.Monad.ST.Class+import Control.Monad.ST.Unsafe+import Data.Typeable+import System.IO.Unsafe+import Unsafe.Coerce+++-- | Thrown when the answer for an unfulfillable promise is demanded.+data BrokenPromise = BrokenPromise deriving (Show, Typeable)+instance Exception BrokenPromise++--------------------------------------------------------------------------------+-- * Internals+--------------------------------------------------------------------------------++meq :: MVar a -> MVar b -> Bool+meq a b = a == unsafeCoerce b++data K s a where+  Pure      :: a -> K s a+  Fulfilled :: MVar x -> IO (K s a) -> K s a++instance Functor (K s) where+  fmap f (Pure a) = Pure (f a)+  fmap f (Fulfilled m k) = Fulfilled m (fmap (fmap f) k)++pump :: a -> IO (K s x) -> MVar a -> IO (Maybe (IO (K s x)))+pump d m v = m >>= \case+  Pure _ -> return Nothing+  Fulfilled u n+    | meq u v   -> return (Just n)+    | otherwise -> pump d n v++drive :: a -> MVar (Maybe (IO (K s x))) -> MVar a -> a+drive d mv v = unsafePerformIO $ tryTakeMVar v >>= \case+  Just a -> return a -- if we're satisfied give the answer+  Nothing -> takeMVar mv >>= \case -- grab the lock on this computation+    Nothing -> do -- it has nothing left to do, so we fail to the default answer+      putMVar mv Nothing+      return d+    Just k -> tryTakeMVar v >>= \case -- ok, check to make sure we haven't been satisfied in the meantime+      Just a -> do+        putMVar mv (Just k) -- if so, restore the continuation, and return the answer+        return a+      Nothing -> do+        mk <- pump d k v+        putMVar mv mk+        case mk of+          Nothing -> return d+          Just _  -> takeMVar v+{-# NOINLINE drive #-}++--------------------------------------------------------------------------------+-- * Demand driven computations+--------------------------------------------------------------------------------++-- | A lazy, demand-driven calculation that can create and fulfill promises.+newtype Lazy s a = Lazy { getLazy :: forall x. MVar (Maybe (IO (K s x))) -> IO (K s a) }+  deriving Typeable++type role Lazy nominal representational++instance Functor (Lazy s) where+  fmap f (Lazy m) = Lazy $ \mv -> fmap go (m mv) where+    go (Pure a)        = Pure (f a)+    go (Fulfilled v k) = Fulfilled v (fmap (fmap f) k)++instance Applicative (Lazy s) where+  pure = return+  (<*>) = ap++instance Monad (Lazy s) where+  return a = Lazy $ \_ -> return $ Pure a+  m >>= f = Lazy $ \mv -> let+      go (Pure a) = getLazy (f a) mv+      go (Fulfilled v k) = return $ Fulfilled v (k >>= go)+    in getLazy m mv >>= go++instance MonadST (Lazy s) where+  type World (Lazy s) = s+  liftST m = Lazy $ \_ -> Pure <$> unsafeSTToIO m++instance MonadFix (Lazy s) where+  mfix f = do+    a <- promise_+    r <- f (demand a)+    a != r+    return r++--------------------------------------------------------------------------------+-- * Promises, Promises+--------------------------------------------------------------------------------++-- | A lazy I-Var.+data Promise s a where+  Promise :: MVar a -> a -> Promise s a+  deriving Typeable++-- | Demand the result of a promise.+demand :: Promise s a -> a+demand (Promise _ a) = a++-- | Promise that by the end of the computation we'll provide a "real" answer, or we'll fall back and give you this answer+promise :: a -> Lazy s (Promise s a)+promise d = Lazy $ \mv -> do+  v <- newEmptyMVar+  return $ Pure $ Promise v (drive d mv v)++-- | Create an empty promise. If you observe the demanded answer of this promise then either by the end of the current lazy+-- computation we'll provide a "real" answer, or you'll get an error.+--+-- @+-- 'promise_' ≡ 'promise' ('throw' 'BrokenPromise')+-- @+promise_ :: Lazy s (Promise s a)+promise_ = promise $ throw BrokenPromise++infixl 0 !=++-- | Fulfill a promise. Each promise should only be fulfilled once.+--+-- >>> runLazy_ $ \p -> p != "good"+-- "good"+--+-- >>> runLazy_ $ \p -> do q <- promise_; p != "yay! " ++ demand q; q != "it works."+-- "yay! it works."+--+-- >>> runLazy_ $ \p -> return ()+-- *** Exception: BrokenPromise+--+-- >>> runLazy (\p -> return ()) "default"+-- "default"+--+(!=) :: Promise s a -> a -> Lazy s ()+Promise v _ != a = Lazy $ \ _ -> do+  putMVar v a+  return $ Fulfilled v $ return (Pure ())++--------------------------------------------------------------------------------+-- * Running It All+--------------------------------------------------------------------------------++-- | Run a lazy computation. The final answer is given in the form of a promise to be fulfilled.+-- If the promises is unfulfilled then an user supplied default value will be returned.+runLazy :: (forall s. Promise s a -> Lazy s b) -> a -> a+runLazy f d = unsafePerformIO $ do+  mv <- newEmptyMVar+  v <- newEmptyMVar+  let iv = Promise v (drive d mv v)+  putMVar mv (Just (getLazy (f iv) mv))+  return $ demand iv+{-# NOINLINE runLazy #-}++-- | Run a lazy computation. The final answer is given in the form of a promise to be fulfilled.+-- If the promises is unfulfilled then an 'BrokenPromise' will be thrown.+--+-- @+-- 'runLazy_' k ≡ 'runLazy' k ('throw' 'BrokenPromise')+-- @+runLazy_ :: (forall s. Promise s a -> Lazy s b) -> a+runLazy_ k = runLazy k $ throw BrokenPromise