foreign-var (empty) → 0

raw patch · 7 files changed

+347/−0 lines, 7 filesdep +basedep +stmdep +transformerssetup-changed

Dependencies added: base, stm, transformers

Files

.travis.yml +60/−0
CHANGELOG.markdown +3/−0
LICENSE +26/−0
README.markdown +15/−0
Setup.hs +2/−0
foreign-var.cabal +32/−0
src/Foreign/Var.hs +209/−0

+ .travis.yml view

@@ -0,0 +1,60 @@+# NB: don't set `language: haskell` here++# See also https://github.com/hvr/multi-ghc-travis for more information+env:+ # we have to use CABALVER=1.16 for GHC<7.6 as well, as there's+ # no package for earlier cabal versions in the PPA+ - GHCVER=7.4.2 CABALVER=1.16+ - GHCVER=7.6.3 CABALVER=1.16+ - 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.20++# 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++# 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:+      - "\x0313foreign-var\x03/\x0306%{branch}\x03 \x0314%{commit}\x03 %{build_url} %{message}"

+ CHANGELOG.markdown view

@@ -0,0 +1,3 @@+0+-+* Initialized repository based on code from `Quine.StateVar` in [quine](http://github.com/ekmett/quine).

+ LICENSE view

@@ -0,0 +1,26 @@+Copyright 2014-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 @@+foreign-var+===========++[![Build Status](https://secure.travis-ci.org/ekmett/foreign-var.png?branch=master)](http://travis-ci.org/ekmett/foreign-var)++This package provides an API for working with bits of state, usually foreign, which require mutation to change.++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.hs view

@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain

+ foreign-var.cabal view

@@ -0,0 +1,32 @@+name:          foreign-var+category:      FFI, Mutable State+version:       0+license:       BSD3+cabal-version: >= 1.10+license-file:  LICENSE+author:        Edward A. Kmett+maintainer:    Edward A. Kmett <ekmett@gmail.com>+stability:     provisional+homepage:      http://github.com/ekmett/foreign-var/+bug-reports:   http://github.com/ekmett/foreign-var/issues+copyright:     Copyright (C) 2014-2015 Edward A. Kmett+synopsis:      Encapsulating mutatable state in external libraries+description:   Encapsulating mutatable state in external libraries+build-type:    Simple+extra-source-files: .travis.yml README.markdown CHANGELOG.markdown++source-repository head+  type: git+  location: git://github.com/ekmett/foreign-var.git++library+  default-language: Haskell2010+  hs-source-dirs: src+  ghc-options: -Wall++  exposed-modules: Foreign.Var++  build-depends:+    base         >= 4   && < 5,+    stm          >= 2.0 && < 2.5,+    transformers >= 0.2 && < 0.5

+ src/Foreign/Var.hs view

@@ -0,0 +1,209 @@+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE DefaultSignatures #-}+{-# LANGUAGE TypeFamilies #-}+--------------------------------------------------------------------+-- |+-- Copyright :  (c) 2014-2015 Edward Kmett+-- License   :  BSD2+-- Maintainer:  Edward Kmett <ekmett@gmail.com>+-- Stability :  experimental+-- Portability: non-portable+--+--------------------------------------------------------------------+module Foreign.Var+  (+  -- * Variables+    Var(..)+  , newVar+  , mapVar+  , SettableVar(SettableVar)+  , GettableVar+  -- * Classes+  , HasSetter(($=)), ($=!)+  , HasUpdate(($~), ($~!))+  , HasGetter(get)+  ) where++import Control.Concurrent.STM+import Control.Monad.IO.Class+import Data.Functor+import Data.IORef+import Data.Typeable+import Foreign.Ptr+import Foreign.Storable+--import Data.Void+--import Data.Functor.Contravariant+--import Data.Functor.Contravariant.Divisible++--------------------------------------------------------------------+-- * Var+--------------------------------------------------------------------++-- | This data type represents a piece of mutable, imperative state+-- with possible side-effects. These tend to encapsulate all sorts+-- tricky behavior in external libraries, and may well throw+-- exceptions.+--+-- Inhabitants __should__ satsify the following properties.+--+-- In the absence of concurrent mutation from other threads or a+-- thrown exception:+--+-- @+-- do x <- 'getVar' v; 'setVar' v y; 'setVar' v x+-- @+--+-- should restore the previous state.+--+-- Ideally, in the absence of thrown exceptions:+--+-- @+-- 'setVar' v a >> 'getVar' v+-- @+--+-- should return @a@, regardless of @a@. In practice some 'Var's only+-- permit a very limited range of value assignments, and do not report failure.+--+-- The result of 'updateVar' should also be compatible with the result of getting+-- and setting separately, however, it may be more efficient or have better+-- atomicity properties in a concurrent setting.+data Var a = Var+  { getVar :: IO a                  -- ^ Used by 'get'+  , updateVar  :: (a -> a) -> IO () -- ^ Used by @('$~')@+  , updateVar' :: (a -> a) -> IO () -- ^ Used by @('$~!')@+  , setVar :: a -> IO ()            -- ^ Used by @('$=')@+  } deriving Typeable++-- | Build a 'Var' form a getter and a setter.+newVar :: (IO a)       -- ^ getter+       -> (a -> IO ()) -- ^ setter+       -> Var a+newVar g s = Var g u u' s where+  u f = do+    a <- g+    s (f a)+  u' f = do+    a <- g+    s $! f a++-- | Change the type of a 'Var'+mapVar :: (b -> a) -> (a -> b) -> Var a -> Var b+mapVar ba ab (Var ga ua ua' sa) = Var (ab <$> ga) (\bb -> ua (ba . bb . ab)) (\bb -> ua' (ba . bb . ab)) (sa . ba)+{-# INLINE mapVar #-}++newtype SettableVar a = SettableVar (a -> IO ())+  deriving Typeable++{-+instance Contravariant SettableVar where+  contramap f (SettableVar k) = SettableVar (k . f)+  {-# INLINE contramap #-}++instance Divisible SettableVar where+  divide k (SettableVar l) (SettableVar r) = SettableVar $ \ a -> case k a of+    (b, c) -> l b >> r c+  conquer = SettableVar $ \_ -> return ()++instance Decidable SettableVar where+  lose k = SettableVar (absurd . k)+  choose k (SettableVar l) (SettableVar r) = SettableVar $ \ a -> case k a of+    Left b -> l b+    Right c -> r c+-}++type GettableVar = IO++--------------------------------------------------------------------+-- * HasSetter+--------------------------------------------------------------------++infixr 2 $=, $=!++class HasSetter t a | t -> a where+  ($=) :: MonadIO m => t -> a -> m ()++($=!) :: (HasSetter t a, MonadIO m) => t -> a -> m ()+p $=! a = (p $=) $! a+{-# INLINE ($=!) #-}++instance HasSetter (SettableVar a) a where+  SettableVar f $= a = liftIO (f a)+  {-# INLINE ($=) #-}++instance HasSetter (Var a) a where+  Var _ _ _ s $= a = liftIO $ s a++instance Storable a => HasSetter (Ptr a) a where+  p $= a = liftIO $ poke p a+  {-# INLINE ($=) #-}++instance HasSetter (IORef a) a where+  p $= a = liftIO $ writeIORef p a+  {-# INLINE ($=) #-}++instance HasSetter (TVar a) a where+  p $= a = liftIO $ atomically $ writeTVar p a++--------------------------------------------------------------------+-- * HasUpdate+--------------------------------------------------------------------++infixr 2 $~, $~!++class HasSetter t a => HasUpdate t a b | t -> a b where+  ($~) :: MonadIO m => t -> (a -> b) -> m ()+  default ($~) :: (MonadIO m, a ~ b, HasGetter t a, HasSetter t a) => t -> (a -> b) -> m ()+  r $~ f = liftIO $ do+    a <- get r+    r $= f a+  ($~!) :: MonadIO m => t -> (a -> b) -> m ()+  default ($~!) :: (MonadIO m, a ~ b, HasGetter t a, HasSetter t a) => t -> (a -> b) -> m ()+  r $~! f = liftIO $ do+    a <- get r+    r $=! f a++instance HasUpdate (Var a) a a where+  Var _ u _ _ $~  f = liftIO $ u f+  Var _ _ v _ $~! f = liftIO $ v f++instance Storable a => HasUpdate (Ptr a) a a++instance HasUpdate (IORef a) a a where+  r $~ f  = liftIO $ atomicModifyIORef r $ \a -> (f a,())+  r $~! f = liftIO $ atomicModifyIORef' r $ \a -> (f a,())++instance HasUpdate (TVar a) a a where+  r $~ f = liftIO $ atomically $ do+    a <- readTVar r+    writeTVar r (f a)+  r $~! f = liftIO $ atomically $ do+    a <- readTVar r+    writeTVar r $! f a++--------------------------------------------------------------------+-- * HasGetter+--------------------------------------------------------------------++class HasGetter t a | t -> a where+  get :: MonadIO m => t -> m a++instance HasGetter (Var a) a where+  get (Var g _ _ _) = liftIO g++instance HasGetter (TVar a) a where+  get = liftIO . atomically . readTVar++instance HasGetter (IO a) a where+  get = liftIO++instance HasGetter (STM a) a where+  get = liftIO . atomically++instance Storable a => HasGetter (Ptr a) a where+  get = liftIO . peek++instance HasGetter (IORef a) a where+  get = liftIO . readIORef