Control-Monad-ST2 (empty) → 0.1.0.1

raw patch · 6 files changed

+488/−0 lines, 6 filesdep +QuickCheckdep +SafeSemaphoredep +arraysetup-changed

Dependencies added: QuickCheck, SafeSemaphore, array, base, mtl, test-framework, test-framework-hunit, test-framework-quickcheck2

Files

Control-Monad-ST2.cabal +54/−0
LICENSE +30/−0
README.txt +14/−0
Setup.hs +4/−0
src/Control/Monad/ST2.hs +273/−0
tests/Main.hs +113/−0

+ Control-Monad-ST2.cabal view

@@ -0,0 +1,54 @@+-- Copyright 2013 Kevin Backhouse.++name:                Control-Monad-ST2+version:             0.1.0.1+synopsis:            A variation on the ST monad with two type parameters.+description:         The ST2 monad is like the ST monad, but with+                     finer-grained control over access to mutable+                     state. The phantom type parameters r and w are+                     used to track the read and write dependencies of+                     the computation. If a computation of type ST2 r w a+                     is polymorphic in w then it does not write any+                     external state. If it is also polymorphic in r+                     then it does not read any external state.++homepage:            https://github.com/kevinbackhouse/Control-Monad-ST2+license:             BSD3+license-file:        LICENSE+author:              Kevin Backhouse+maintainer:          Kevin.Backhouse@gmail.com+copyright:           Kevin Backhouse, 2013+category:            Control+build-type:          Simple+cabal-version:       >=1.8+Extra-source-files:  README.txt+tested-with:         GHC==7.6.2++source-repository this+  type:      git+  location:  https://github.com/kevinbackhouse/Control-Monad-ST2.git+  tag:       Version-0.1.0.1++library+  exposed-modules:   Control.Monad.ST2+  hs-source-dirs:    src+  build-depends:     base >= 4.5 && < 5,+                     array, SafeSemaphore, QuickCheck+  ghc-options:       -Wall+  extensions:        Safe RankNTypes ExistentialQuantification+                     DeriveFunctor++test-suite Main+  type:              exitcode-stdio-1.0+  x-uses-tf:         true+  build-depends:     base >= 4.5 && < 5,+                     array, SafeSemaphore, QuickCheck,+                     mtl,+                     test-framework,+                     test-framework-quickcheck2,+                     test-framework-hunit+  ghc-options:       -Wall+  extensions:        RankNTypes ExistentialQuantification+                     DeriveFunctor+  hs-source-dirs:    src, src/Control, src/Control/Monad, tests+  main-is:           Main.hs

+ LICENSE view

@@ -0,0 +1,30 @@+Copyright (c) 2013, Kevin Backhouse++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * 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.++    * Neither the name of Kevin Backhouse nor the names of other+      contributors may be used to endorse or promote products derived+      from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"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 COPYRIGHT+OWNER 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.txt view

@@ -0,0 +1,14 @@+Control.Monad.ST2+=================++The Control.Monad.ST2 monad is like the Control.Monad.ST monad, but+with finer-grained control over access to mutable state. The phantom+type parameters r and w are used to track the read and write+dependencies of the computation. If a computation of type ST2 r w a is+polymorphic in w then it does not write any external state. If it is+also polymorphic in r then it does not read any external state.++Change log+----------++0.1.0.0 - First version

+ Setup.hs view

@@ -0,0 +1,4 @@+-- Copyright 2013 Kevin Backhouse.++import Distribution.Simple+main = defaultMain

+ src/Control/Monad/ST2.hs view

@@ -0,0 +1,273 @@+-- Copyright 2013 Kevin Backhouse.++{-|+  The 'ST2' monad is like the 'Control.Monad.ST.ST' monad, but with+  finer-grained control over access to mutable state. The phantom type+  parameters @r@ and @w@ are used to track the read and write+  dependencies of the computation. If a computation of type @'ST2' r w+  a@ is polymorphic in w then it does not write any external state. If+  it is also polymorphic in @r@ then it does not read any external+  state.  Operations which modify state, such as 'writeST2Ref', are+  considered to read external state as well as write it, so it is+  impossible for a computation of type @'ST2' r w a@ to be polymorphic+  in @r@ but not in @w@. This means that the @r@ type parameter+  behaves exactly like the @s@ type parameter on the+  'Control.Monad.ST.ST' monad, but the @w@ type parameter provides+  extra information which is not available in the 'Control.Monad.ST.ST'+  monad.++  Like the 'Control.Monad.ST.ST' monad, the 'ST2' monad allows mutable+  references and arrays to be created, read, and written within a+  computation.  Provided that the mutable state does not escape, it+  does not affect the type signature of the top-level computation.+-}++module Control.Monad.ST2+  ( -- * ST2 Monad+    ST2+  , pureST2, PureST2(..)+  , readOnlyST2, ReadOnlyST2(..)+  , ioToST2, st2ToIO++    -- * ST2 References+  , ST2Ref+  , newST2Ref, readST2Ref, writeST2Ref, modifyST2Ref+  , importST2Ref, exportST2Ref++    -- * ST2 Arrays+  , ST2Array+  , newST2Array, newST2Array_+  , readST2Array, writeST2Array+  , boundsST2Array+  , importST2Array, exportST2Array++    -- * ST2 Read-only Arrays+  , ST2RArray+  , mkST2RArray+  , readST2RArray++    -- * Parallelism+  , parallelST2+  )+where++import Control.Exception ( assert, bracket_ )+import Control.Concurrent ( forkIO )+import qualified Control.Concurrent.SSem as S+import Data.Array.IO.Safe+import Data.IORef++-- | The 'ST2' monad is a newtype of 'IO'. The type parameters @r@ and+-- @w@ are phantom type parameters which are used to track the read+-- and write dependencies of the computation.+newtype ST2 r w a+  = ST2 { unwrapST2 :: IO a }+    deriving Functor++instance Monad (ST2 r w) where+  return x = ST2 $ return x++  (ST2 m) >>= f =+    ST2 $+    do x <- m+       unwrapST2 (f x)++  fail msg = ST2 $ fail msg++-- | This function checks that the sub-computation is polymorphic in+-- both type parameters. This means that the sub-computation does not+-- read or write any state from the enclosing context.+pureST2 :: (forall r w. ST2 r w a) -> ST2 r' w' a+pureST2 m = m++-- | This function checks that the sub-computation is polymorphic in+-- the @w@ type parameter. This means that the sub-computation does+-- not write any state from the enclosing context (but read-only+-- operations are permitted).+readOnlyST2 :: (forall w. ST2 r w a) -> ST2 r w' a+readOnlyST2 m = m++-- | 'runPureST2' is semantically equivalent to pureST2, but uses a+-- newtype to package the @forall@. Sometimes this packaging is+-- convenient when passing a value of type 'PureST2' as an argument+-- because it avoids the need for a nested @forall@ in the type+-- signature.+newtype PureST2 a+  = PureST2 { runPureST2 :: forall r w. ST2 r w a }++-- | 'runReadOnlyST2' is semantically equivalent to readOnlyST2, but+-- uses a newtype to package the @forall@. Sometimes this packaging is+-- convenient when passing a value of type 'ReadOnlyST2' as an+-- argument because it avoids the need for a nested @forall@ in the+-- type signature.+newtype ReadOnlyST2 r a+  = ReadOnlyST2 { runReadOnlyST2 :: forall w. ST2 r w a }++-- | 'IO' computations can be converted to 'ST2' computations, but+-- only with a monomorphic type signature.+ioToST2 :: IO a -> ST2 () () a+ioToST2 m = ST2 m++-- | 'ST2' computations can be converted to 'IO' computations, but+-- only with a monomorphic type signature.+st2ToIO :: ST2 () () a -> IO a+st2ToIO (ST2 m) = m++-- | Mutable reference. 'ST2Ref' is actually just a newtype of an+-- 'IORef', but the @r@ and @w@ type parameters allow the read and+-- write dependencies to be tracked by the type system.+newtype ST2Ref r w a+  = ST2Ref (IORef a)++-- | Create a new reference. The @r@ and @w@ type parameters of the+-- reference are unified with the 'ST2' monad to indicate that new+-- state is created in the enclosing context.+{-# INLINE newST2Ref #-}+newST2Ref :: a -> ST2 r w (ST2Ref r w a)+newST2Ref x =+  ST2 $+  do r <- newIORef x+     return (ST2Ref r)++-- | Read a reference. The @w@ type parameter of the reference is not+-- unified with the 'ST2' monad to indicate that this access is+-- read-only.+{-# INLINE readST2Ref #-}+readST2Ref :: ST2Ref r w a -> ST2 r w' a+readST2Ref (ST2Ref r) =+  ST2 $ readIORef r++-- | Write to a reference. The @w@ type parameter of the reference is+-- unified with the 'ST2' monad to indicate that state is written in+-- the enclosing context.+{-# INLINE writeST2Ref #-}+writeST2Ref :: ST2Ref r w a -> a -> ST2 r w ()+writeST2Ref (ST2Ref r) x =+  ST2 $ writeIORef r x++-- | Modify a reference.+{-# INLINE modifyST2Ref #-}+modifyST2Ref :: ST2Ref r w a -> (a -> a) -> ST2 r w ()+modifyST2Ref (ST2Ref r) f =+  ST2 $ modifyIORef r f++-- | Convert an IORef to an ST2Ref.+{-# INLINE importST2Ref #-}+importST2Ref :: IORef a -> ST2Ref () () a+importST2Ref r = ST2Ref r++-- | Convert an ST2Ref to an IORef.+{-# INLINE exportST2Ref #-}+exportST2Ref :: ST2Ref () () a -> IORef a+exportST2Ref (ST2Ref r) = r++-- | Mutable array. 'ST2Array' is actually just a newtype of an+-- 'IOArray', but the @r@ and @w@ type parameters allow the read and+-- write dependencies to be tracked by the type system.+newtype ST2Array r w i a+  = ST2Array (IOArray i a)++-- | Create an array with an initial value.+{-# INLINE newST2Array #-}+newST2Array :: Ix i => (i,i) -> a -> ST2 r w (ST2Array r w i a)+newST2Array bnds x =+  ST2 $+  do xs <- newArray bnds x+     return (ST2Array xs)++-- | Create an uninitialised array.+{-# INLINE newST2Array_ #-}+newST2Array_ :: Ix i => (i,i) -> ST2 r w (ST2Array r w i a)+newST2Array_ bnds =+  ST2 $+  do xs <- newArray_ bnds+     return (ST2Array xs)++-- | Read an index of the array. The @w@ type parameter of the+-- reference is not unified with the 'ST2' monad to indicate that this+-- access is read-only.+{-# INLINE readST2Array #-}+readST2Array :: Ix i => ST2Array r w i a -> i -> ST2 r w' a+readST2Array (ST2Array xs) i =+  ST2 $ readArray xs i++-- | Write an index of the array. The @w@ type parameter of the array+-- is unified with the 'ST2' monad to indicate that state is written+-- in the enclosing context.+{-# INLINE writeST2Array #-}+writeST2Array :: Ix i => ST2Array r w i a -> i -> a -> ST2 r w ()+writeST2Array (ST2Array xs) i a =+  ST2 $ writeArray xs i a++-- | Read the size of the array. Neither type parameter is unified with+-- the 'ST2' monad because the array itself is not accessed.+-- (Conceptually, an 'ST2Array' is a pair, consisting of the size+-- information and the array. This function only accesses the size+-- information, which is immutable.)+{-# INLINE boundsST2Array #-}+boundsST2Array :: Ix i => ST2Array r w i a -> ST2 r' w' (i,i)+boundsST2Array (ST2Array xs) =+  ST2 $ getBounds xs++-- | Convert an IOArray to an ST2Array.+{-# INLINE importST2Array #-}+importST2Array :: IOArray i a -> ST2Array () () i a+importST2Array r = ST2Array r++-- | Convert an ST2Array to an IOArray.+{-# INLINE exportST2Array #-}+exportST2Array :: ST2Array () () i a -> IOArray i a+exportST2Array (ST2Array r) = r++-- | Read-only array. Existential quantification is used to hide the+-- @w@ type parameter. This means that it can escape a 'ReadOnlyST2'+-- context, and can be read in the enclosing context. However, it is+-- impossible for anyone to write to the array outside of the+-- 'ReadOnlyST2' context in which the array was created.+data ST2RArray r i a+  = forall w. ST2RArray !(ST2Array r w i a)++-- | Create a read-only array. It is important to note that this+-- function does not make the original 'ST2Array' immutable. It merely+-- creates a read-only reference to the original array. However, the+-- 'ST2RArray' can be returned through a 'readOnlyST2' or+-- 'ReadOnlyST2' context and the typing rules ensure that the original+-- 'ST2Array' cannot be modified outside of the 'ReadOnlyST2' context+-- in which it was created. In other words, the original 'ST2Array'+-- can continue to be modified after the 'ST2RArray' is created, but+-- only until the 'ST2RArray' is returned through a 'ReadOnlyST2'+-- context.+{-# INLINE mkST2RArray #-}+mkST2RArray :: ST2Array r w i a -> ST2RArray r i a+mkST2RArray xs =+  ST2RArray xs++-- | Read an index of the read-only array.+{-# INLINE readST2RArray #-}+readST2RArray :: Ix i => ST2RArray r i a -> i -> ST2 r w a+readST2RArray (ST2RArray xs) i =+  readST2Array xs i+++----------------------------------------------------------------------+------------------------------ Threads -------------------------------+----------------------------------------------------------------------++-- | Spawn one thread for each index in the range and wait for all the+-- threads to finish. Each thread is parameterised by its index, which+-- is an element of the range.+parallelST2 :: Ix i => (i,i) -> (i -> ST2 r w ()) -> ST2 r w ()+parallelST2 bnds f =+  let n = rangeSize bnds in+  assert (n > 0) $+  ST2 $+  -- If n == 1 then there is no need to use forkIO.+  if n == 1+     then unwrapST2 (f (fst bnds))+     else do s <- S.new 0+             sequence_+               [ forkIO $+                 bracket_ (return ()) (S.signal s) (unwrapST2 (f i))+               | i <- range bnds+               ]+             S.waitN s n

+ tests/Main.hs view

@@ -0,0 +1,113 @@+-- Copyright 2013 Kevin Backhouse.++module Main where++import Control.Monad.ST2+import Control.Monad.State.Strict+import Control.Monad.Writer.Strict+import Data.Bits++import Test.Framework as TF ( defaultMain, testGroup, Test )+import Test.Framework.Providers.QuickCheck2 ( testProperty )+import Test.QuickCheck as QC+import Test.QuickCheck.Property ( morallyDubiousIOProperty )++-- | 'TestST2' is a trivial wrapper around 'PureST2'. Its only purpose+-- is to define a 'QC.Testable' instance for 'PureST2'.+newtype TestST2 a+  = TestST2 (PureST2 a)++instance QC.Testable a => QC.Testable (TestST2 a) where+  property (TestST2 (PureST2 m)) = morallyDubiousIOProperty (st2ToIO m)++main :: IO ()+main = defaultMain tests++tests :: [TF.Test]+tests =+  [ testGroup "Control.Monad.ST2"+      [ testProperty "CreateWriteRead" prop_CreateWriteRead+      , testProperty "ST2RArray" prop_ST2RArray+      , testProperty "parallelST2" prop_parallelST2+      ]+  ]++-- | This property creates an array, initialises its elements, then+-- reads the elements to check that it worked correctly.+prop_CreateWriteRead :: Int -> TestST2 Bool+prop_CreateWriteRead n0 =+  let n = n0 `mod` 0x100 in+  let ks = [0 .. n-1] in+  TestST2 $ PureST2 $+  do xs <- newST2Array_ (0,n-1)+     sequence_+       [ writeST2Array xs k k+       | k <- ks+       ]+     ks' <- mapM (readST2Array xs) ks+     return (ks == ks')++-- | This property is a demonstration of how a read-only array can be+-- returned through 'readOnlyST2'. The type checker rejects this code if+-- prop_ST2RArray_helper returns an 'ST2Array' rather than an+-- 'ST2RArray'.+prop_ST2RArray :: Int -> TestST2 Bool+prop_ST2RArray n0 =+  let n = n0 `mod` 0x100 in+  let ks = [0 .. n-1] in+  TestST2 $ PureST2 $+  do xs <- readOnlyST2 (prop_ST2RArray_helper n)+     ks' <- mapM (readST2RArray xs) ks+     return (ks == ks')++prop_ST2RArray_helper :: Int -> ST2 r w (ST2RArray r Int Int)+prop_ST2RArray_helper n =+   do xs <- newST2Array_ (0,n-1)+      sequence_+        [ writeST2Array xs i i+        | i <- [0 .. n-1]+        ]+      return (mkST2RArray xs)++prop_parallelST2 :: Int -> TestST2 Bool+prop_parallelST2 k0 =+  let nShift = 12 in+  let k = k0 `mod` (nShift+1) in+  let n = (1 :: Int) `shiftL` nShift in+  TestST2 $ PureST2 $+  do let bnds = (0,n-1)+     xs <- newST2Array_ bnds+     let n' = n `shiftR` k+     let bnds' = (0,n'-1)++     -- Initialise the array, using multiple threads.+     parallelST2 bnds' $ \i ->+       sequence_+         [ let j' = (i `shiftL` k) .|. j in+           writeST2Array xs j' j'+         | j <- [0 .. (1 `shiftL` k) - 1]+         ]++     -- Compute sub-totals, using multiple threads.+     ys <- newST2Array_ bnds'+     parallelST2 bnds' $ \i ->+       do Sum total <-+            execWriterT $+            sequence_+              [ do x <- lift $ readST2Array xs ((i `shiftL` k) .|. j)+                   tell (Sum x)+              | j <- [0 .. (1 `shiftL` k) - 1]+              ]+          writeST2Array ys i total++     -- Sum the sub-totals.+     Sum total <-+       execWriterT $+       sequence_+         [ do y <- lift $ readST2Array ys i+              tell (Sum y)+         | i <- [0 .. n' - 1]+         ]++     -- Check the answer.+     return (total == (n * (n-1)) `div` 2)