diff --git a/Data/IORef/Strict.hs b/Data/IORef/Strict.hs new file mode 100644 --- /dev/null +++ b/Data/IORef/Strict.hs @@ -0,0 +1,68 @@ +-------------------------------------------------------------------- +-- | +-- Module : Data.IORef.Strict +-- Copyright : (c) Nicolas Pouillard 2009 +-- License : BSD3 +-- +-- Maintainer : Nicolas Pouillard +-- Stability : provisional +-- +-- Mutable references of strict values in the 'SIO' monad. +-- +-- The type of references remains the same as in the 'IO' monad +-- and is just re-exported here. +-------------------------------------------------------------------- + +module Data.IORef.Strict + (IORef + ,newIORef + ,readIORef + ,writeIORef + ,modifyIORef + ,atomicModifyIORef + ,mkWeakIORef + ) +where + +import qualified System.IO.Strict.Internals as SIO +import System.IO.Strict.Internals (SIO(..)) +import System.Mem.Weak (Weak) +import qualified Data.IORef as IO +import Data.IORef (IORef) +import Control.Parallel.Strategies (NFData(..)) + +-- | Build a new 'IORef', but force the value before storing it. +newIORef :: NFData sa => sa -> SIO (IORef sa) +newIORef value = rnf value `seq` SIO (IO.newIORef value) + +-- | Read the value of an 'IORef' +readIORef :: IORef a -> SIO a +readIORef = SIO . IO.readIORef + +-- | Deeply force a value and write it into an 'IORef' +writeIORef :: NFData sa => IORef sa -> sa -> SIO () +writeIORef ref value = rnf value `seq` SIO $ IO.writeIORef ref value + +-- | Mutate the contents of an 'IORef' +modifyIORef :: NFData sa => IORef sa -> (sa -> sa) -> SIO () +modifyIORef ref f = readIORef ref >>= writeIORef ref . f + +-- | Atomically modifies the contents of an 'IORef'. +-- +-- This function is useful for using 'IORef' in a safe way in a multithreaded program. +-- If you only have one 'IORef', then using 'atomicModifyIORef' to access and modify +-- it will prevent race conditions. +-- +-- Extending the atomicity to multiple 'IORef's is problematic, so it is recommended that +-- if you need to do anything more complicated then using "Control.Concurrent.MVar.MVar" +-- instead is a good idea. +atomicModifyIORef :: (NFData sa, NFData sb) => IORef sa -> (sa -> (sa, sb)) -> SIO sb +atomicModifyIORef ref f = SIO $ do x <- IO.atomicModifyIORef ref (rnf' . f) + rnf x `seq` return x + -- since the result of 'f' is a pair which has to forced + where rnf' x = rnf x `seq` x + +-- | Make a 'Weak' pointer to an 'IORef' +mkWeakIORef :: IORef a -> SIO () -> SIO (Weak (IORef a)) +mkWeakIORef ref (SIO finalizer) = SIO $ IO.mkWeakIORef ref finalizer + diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,28 @@ +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. + +3. Neither the name of the author nor the names of his contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + +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. diff --git a/Setup.lhs b/Setup.lhs new file mode 100644 --- /dev/null +++ b/Setup.lhs @@ -0,0 +1,3 @@ +#!/usr/bin/env runhaskell +> import Distribution.Simple +> main = defaultMain diff --git a/System/IO/Strict.hs b/System/IO/Strict.hs new file mode 100644 --- /dev/null +++ b/System/IO/Strict.hs @@ -0,0 +1,253 @@ +-------------------------------------------------------------------- +-- | +-- Module : System.IO.Strict +-- Copyright : (c) Nicolas Pouillard 2009 +-- License : BSD3 +-- +-- Maintainer : Nicolas Pouillard +-- Stability : provisional +-- +-- This module wraps the functions of the "System.IO" module at a different type namely 'SIO'. +-- +-- The purpose of this module is to export only strict /IO/ functions, by strict +-- we mean strict in the result. The arguments of these functions may only by partially forced, +-- but when the function returns, the arguments can no longer be forced by the function. +-- When the type of the value to be forced is polymorphic, a 'NFData' constraint is added +-- since we (internally) use 'rnf' to force the value. Then we rely on the behavior +-- of 'NFData' instances to provide the fact that any lazy argument passed to a 'SIO' function +-- will not leak-out after the call. +-- +-- These functions do not necessarily use their arguments completely but they do not hold +-- or return any value that could depend on these arguments. If the original functions +-- from "System.IO" module were already strict, then this module just provides them +-- at another type. +-- Some functions from the original module are famously lazy like the 'getContents' like +-- functions: in this module their results are deeply forced. +-- +-- In Haskell, monad operations ('return' and '>>=') have to be lazy. Therefore the 'SIO' +-- monad is not completely strict (i.e. pure values can still be lazy). So in this module we +-- expose the 'return'' function that forces the given value before putting it into the monad. +-- +-- Since this module uses the same names as "System.IO", it is designed to be imported /qualified/. +-- +-- @ +-- import System.IO.Strict (SIO) +-- import qualified System.IO.Strict as SIO +-- @ +-------------------------------------------------------------------- +module System.IO.Strict +( + -- * Types + SIO, + run, + return', + + -- * Functions stricter than there "System.IO" counterparts + getContents, -- :: SIO String + hGetContents, -- :: Handle -> SIO String + readFile, -- :: FilePath -> SIO String + read, -- :: (NFData sa, Read sa) => String -> SIO sa + readLn, -- :: (NFData sa, Read sa) => SIO sa + fix, -- :: NFData sa => (sa -> SIO sa) -> SIO sa + withBinaryFile, -- :: NFData sr => FilePath -> IOMode -> (Handle -> SIO sr) -> SIO sr + withFile, -- :: NFData sr => FilePath -> IOMode -> (Handle -> SIO sr) -> SIO sr + + -- * Functions as strict as there "System.IO" counterparts + appendFile, -- :: FilePath -> String -> SIO () + getChar, -- :: SIO Char + getLine, -- :: SIO String + hPrint, -- :: (Show a) => Handle -> a -> SIO () + hPutStrLn, -- :: Handle -> String -> SIO () + hReady, -- :: Handle -> SIO Bool + interact, -- :: (String -> String) -> SIO () + openBinaryTempFile, -- :: FilePath -> String -> SIO (FilePath, Handle) + openTempFile, -- :: FilePath -> String -> SIO (FilePath, Handle) + print, -- :: (Show a) => a -> SIO () + putChar, -- :: Char -> SIO () + putStr, -- :: String -> SIO () + putStrLn, -- :: String -> SIO () + writeFile, -- :: FilePath -> String -> SIO () + hClose, -- :: Handle -> SIO () + hFileSize, -- :: Handle -> SIO Integer + hFlush, -- :: Handle -> SIO () + hGetBuf, -- :: Handle -> Ptr a -> Int -> SIO Int + hGetBufNonBlocking, -- :: Handle -> Ptr a -> Int -> SIO Int + hGetBuffering, -- :: Handle -> SIO BufferMode + hGetChar, -- :: Handle -> SIO Char + hGetEcho, -- :: Handle -> SIO Bool + hGetLine, -- :: Handle -> SIO String + hGetPosn, -- :: Handle -> SIO HandlePosn + hIsClosed, -- :: Handle -> SIO Bool + hIsEOF, -- :: Handle -> SIO Bool + hIsOpen, -- :: Handle -> SIO Bool + hIsReadable, -- :: Handle -> SIO Bool + hIsSeekable, -- :: Handle -> SIO Bool + hIsTerminalDevice, -- :: Handle -> SIO Bool + hIsWritable, -- :: Handle -> SIO Bool + hLookAhead, -- :: Handle -> SIO Char + hPutBuf, -- :: Handle -> Ptr a -> Int -> SIO () + hPutBufNonBlocking, -- :: Handle -> Ptr a -> Int -> SIO Int + hPutChar, -- :: Handle -> Char -> SIO () + hPutStr, -- :: Handle -> String -> SIO () + hSeek, -- :: Handle -> SeekMode -> Integer -> SIO () + hSetBinaryMode, -- :: Handle -> Bool -> SIO () + hSetBuffering, -- :: Handle -> BufferMode -> SIO () + hSetEcho, -- :: Handle -> Bool -> SIO () + hSetFileSize, -- :: Handle -> Integer -> SIO () + hSetPosn, -- :: HandlePosn -> SIO () + hShow, -- :: Handle -> SIO String + hTell, -- :: Handle -> SIO Integer + hWaitForInput, -- :: Handle -> Int -> SIO Bool + isEOF, -- :: SIO Bool + openBinaryFile, -- :: FilePath -> IOMode -> SIO Handle + openFile, -- :: FilePath -> IOMode -> SIO Handle + stderr, -- :: Handle + stdin, -- :: Handle + stdout -- :: Handle +) +where + +import Prelude (Bool, Int, Integer, String, Char, FilePath, Read, Show, (.), seq) +import Control.Parallel.Strategies (NFData(..)) +import System.IO (IOMode, Handle, BufferMode, HandlePosn, SeekMode) +import GHC.Ptr (Ptr) +import System.IO.Strict.Internals +import qualified System.IO.Strict.Internals as SIO +import qualified System.IO as IO + +-- | Note that 'getContents' is stricter than its counterpart in "System.IO". +getContents :: SIO String +getContents = wrap0' IO.getContents + +-- | Note that 'hGetContents' is stricter than its counterpart in "System.IO". +hGetContents :: Handle -> SIO String +hGetContents = wrap1' IO.hGetContents + +-- | Note that 'withBinaryFile' is stricter than its counterpart in "System.IO". +withBinaryFile :: NFData sr => FilePath -> IOMode -> (Handle -> SIO sr) -> SIO sr +withBinaryFile fp mode kont = wrap0' (IO.withBinaryFile fp mode (SIO.run . kont)) + +-- | Note that 'withFile' is stricter than its counterpart in "System.IO". +withFile :: NFData sr => FilePath -> IOMode -> (Handle -> SIO sr) -> SIO sr +withFile fp mode kont = wrap0' (IO.withFile fp mode (SIO.run . kont)) + +-- | Note that 'fix' is stricter than its counterpart in "System.IO". +fix :: NFData sa => (sa -> SIO sa) -> SIO sa +fix kont = wrap0' (IO.fixIO (SIO.run . kont)) + +-- | Note that 'readFile' is stricter than its counterpart in "System.IO". +readFile :: FilePath -> SIO String +readFile = wrap1' IO.readFile + +-- | Note that 'read' is stricter than its counterpart in "System.IO". +read :: (NFData sa, Read sa) => String -> SIO sa +read = wrap1' IO.readIO + +-- | Note that 'readLn' is stricter than its counterpart in "System.IO". +readLn :: (NFData sa, Read sa) => SIO sa +readLn = wrap0' IO.readLn + +getChar :: SIO Char +getChar = wrap0 IO.getChar + +appendFile :: FilePath -> String -> SIO () +appendFile = wrap2 IO.appendFile + +getLine :: SIO String +getLine = wrap0 IO.getLine +hPrint :: (Show a) => Handle -> a -> SIO () +hPrint = wrap2 IO.hPrint +hPutStrLn :: Handle -> String -> SIO () +hPutStrLn = wrap2 IO.hPutStrLn +hReady :: Handle -> SIO Bool +hReady = wrap1 IO.hReady +interact :: (String -> String) -> SIO () +interact = wrap1 IO.interact +openBinaryTempFile :: FilePath -> String -> SIO (FilePath, Handle) +openBinaryTempFile = wrap2 IO.openBinaryTempFile +openTempFile :: FilePath -> String -> SIO (FilePath, Handle) +openTempFile = wrap2 IO.openTempFile +print :: (Show a) => a -> SIO () +print = wrap1 IO.print +putChar :: Char -> SIO () +putChar = wrap1 IO.putChar +putStr :: String -> SIO () +putStr = wrap1 IO.putStr +putStrLn :: String -> SIO () +putStrLn = wrap1 IO.putStrLn +writeFile :: FilePath -> String -> SIO () +writeFile = wrap2 IO.writeFile +hClose :: Handle -> SIO () +hClose = wrap1 IO.hClose +hFileSize :: Handle -> SIO Integer +hFileSize = wrap1 IO.hFileSize +hFlush :: Handle -> SIO () +hFlush = wrap1 IO.hFlush +hGetBuf :: Handle -> Ptr a -> Int -> SIO Int +hGetBuf = wrap3 IO.hGetBuf +hGetBufNonBlocking :: Handle -> Ptr a -> Int -> SIO Int +hGetBufNonBlocking = wrap3 IO.hGetBufNonBlocking +hGetBuffering :: Handle -> SIO BufferMode +hGetBuffering = wrap1 IO.hGetBuffering +hGetChar :: Handle -> SIO Char +hGetChar = wrap1 IO.hGetChar +hGetEcho :: Handle -> SIO Bool +hGetEcho = wrap1 IO.hGetEcho +hGetLine :: Handle -> SIO String +hGetLine = wrap1 IO.hGetLine +hGetPosn :: Handle -> SIO HandlePosn +hGetPosn = wrap1 IO.hGetPosn +hIsClosed :: Handle -> SIO Bool +hIsClosed = wrap1 IO.hIsClosed +hIsEOF :: Handle -> SIO Bool +hIsEOF = wrap1 IO.hIsEOF +hIsOpen :: Handle -> SIO Bool +hIsOpen = wrap1 IO.hIsOpen +hIsReadable :: Handle -> SIO Bool +hIsReadable = wrap1 IO.hIsReadable +hIsSeekable :: Handle -> SIO Bool +hIsSeekable = wrap1 IO.hIsSeekable +hIsTerminalDevice :: Handle -> SIO Bool +hIsTerminalDevice = wrap1 IO.hIsTerminalDevice +hIsWritable :: Handle -> SIO Bool +hIsWritable = wrap1 IO.hIsWritable +hLookAhead :: Handle -> SIO Char +hLookAhead = wrap1 IO.hLookAhead +hPutBuf :: Handle -> Ptr a -> Int -> SIO () +hPutBuf = wrap3 IO.hPutBuf +hPutBufNonBlocking :: Handle -> Ptr a -> Int -> SIO Int +hPutBufNonBlocking = wrap3 IO.hPutBufNonBlocking +hPutChar :: Handle -> Char -> SIO () +hPutChar = wrap2 IO.hPutChar +hPutStr :: Handle -> String -> SIO () +hPutStr = wrap2 IO.hPutStr +hSeek :: Handle -> SeekMode -> Integer -> SIO () +hSeek = wrap3 IO.hSeek +hSetBinaryMode :: Handle -> Bool -> SIO () +hSetBinaryMode = wrap2 IO.hSetBinaryMode +hSetBuffering :: Handle -> BufferMode -> SIO () +hSetBuffering = wrap2 IO.hSetBuffering +hSetEcho :: Handle -> Bool -> SIO () +hSetEcho = wrap2 IO.hSetEcho +hSetFileSize :: Handle -> Integer -> SIO () +hSetFileSize = wrap2 IO.hSetFileSize +hSetPosn :: HandlePosn -> SIO () +hSetPosn = wrap1 IO.hSetPosn +hShow :: Handle -> SIO String +hShow = wrap1 IO.hShow +hTell :: Handle -> SIO Integer +hTell = wrap1 IO.hTell +hWaitForInput :: Handle -> Int -> SIO Bool +hWaitForInput = wrap2 IO.hWaitForInput +isEOF :: SIO Bool +isEOF = wrap0 IO.isEOF +openBinaryFile :: FilePath -> IOMode -> SIO Handle +openBinaryFile = wrap2 IO.openBinaryFile +openFile :: FilePath -> IOMode -> SIO Handle +openFile = wrap2 IO.openFile +stderr :: Handle +stderr = IO.stderr +stdin :: Handle +stdin = IO.stdin +stdout :: Handle +stdout = IO.stdout diff --git a/System/IO/Strict/Internals.hs b/System/IO/Strict/Internals.hs new file mode 100644 --- /dev/null +++ b/System/IO/Strict/Internals.hs @@ -0,0 +1,100 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +-------------------------------------------------------------------- +-- | +-- Module : System.IO.Strict.Internals +-- Copyright : (c) Nicolas Pouillard 2009 +-- License : BSD3 +-- +-- Maintainer : Nicolas Pouillard +-- Stability : provisional +-- +-- This module exports the internals of "System.IO.Strict" so that other packages can extend the +-- 'SIO' monad. This module has to be used with great care: by lifting a lazy +-- function or a function that let leaks its lazy arguments, one breaks the only purpose +-- of the "System.IO.Strict" module. +-------------------------------------------------------------------- + +module System.IO.Strict.Internals +( + -- * Types + SIO(..), + + -- * Running the 'SIO' monad + run, + + -- * A stricter 'return' + return', + + -- * Wrapping functions + wrap0, -- :: IO a -> SIO a + wrap0', -- :: NFData sa => IO sa -> SIO sa + wrap1, -- :: (a -> IO b) -> a -> SIO b + wrap1', -- :: NFData sb => (a -> IO sb) -> a -> SIO sb + wrap2, -- :: (a -> b -> IO c) -> a -> b -> SIO c + wrap2', -- :: NFData sc => (a -> b -> IO sc) -> a -> b -> SIO sc + wrap3, -- :: (a -> b -> c -> IO d) -> a -> b -> c -> SIO d + wrap3', -- :: NFData sd => (a -> b -> c -> IO sd) -> a -> b -> c -> SIO sd +) +where + +import Prelude ((.), seq) +import Control.Parallel.Strategies (NFData(..)) +import Control.Monad +import Control.Monad.Fix +-- import Control.Monad.Error +import Control.Applicative +import System.IO (IO) +import qualified System.IO as IO + +newtype SIO a = SIO { rawRun :: IO a } + deriving (Functor, Applicative, Monad, MonadFix {-, MonadPlus, MonadError IOError-}) -- Not MonadIO !!!! + +-- | 'run' allows to return to the wider world of 'IO's. +run :: NFData sa => SIO sa -> IO sa +run mx = rawRun mx >>= return' +{-# INLINE run #-} + +-- | A stricter version of 'return', that works for every monad. +return' :: (Monad m, NFData sa) => sa -> m sa +return' x = rnf x `seq` return x +{-# INLINE return' #-} + +-- | Wraps a strict /IO/ computation without arguments. +wrap0 :: IO a -> SIO a +wrap0 = SIO +{-# INLINE wrap0 #-} + +-- | Wraps a lazy /IO/ computation without arguments and forces its contents. +wrap0' :: NFData sa => IO sa -> SIO sa +wrap0' mx = SIO (do x <- mx; rnf x `seq` return x) +{-# INLINE wrap0' #-} + +-- | Wraps a strict /IO/ computation with a single argument. +wrap1 :: (a -> IO b) -> a -> SIO b +wrap1 = (wrap0 .) +{-# INLINE wrap1 #-} + +-- | Wraps a lazy /IO/ computation with a single argument and forces its contents. +wrap1' :: NFData sb => (a -> IO sb) -> a -> SIO sb +wrap1' = (wrap0' .) +{-# INLINE wrap1' #-} + +-- | Wraps a strict /IO/ computation with two arguments. +wrap2 :: (a -> b -> IO c) -> a -> b -> SIO c +wrap2 = (wrap1 .) +{-# INLINE wrap2 #-} + +-- | Wraps a strict /IO/ computation with two arguments and forces its contents. +wrap2' :: NFData sc => (a -> b -> IO sc) -> a -> b -> SIO sc +wrap2' = (wrap1' .) +{-# INLINE wrap2' #-} + +-- | Wraps a strict /IO/ computation with two arguments. +wrap3 :: (a -> b -> c -> IO d) -> a -> b -> c -> SIO d +wrap3 = (wrap2 .) +{-# INLINE wrap3 #-} + +-- | Wraps a strict /IO/ computation with two arguments and forces its contents. +wrap3' :: NFData sd => (a -> b -> c -> IO sd) -> a -> b -> c -> SIO sd +wrap3' = (wrap2' .) +{-# INLINE wrap3' #-} diff --git a/strict-io.cabal b/strict-io.cabal new file mode 100644 --- /dev/null +++ b/strict-io.cabal @@ -0,0 +1,32 @@ +name: strict-io +cabal-Version: >=1.6 +version: 0.1 +license: BSD3 +license-File: LICENSE +copyright: (c) Nicolas Pouillard +author: Nicolas Pouillard +maintainer: Nicolas Pouillard +category: System +synopsis: A library wrapping standard IO modules to provide strict IO. +description: This library is a thin layer on top standard IO modules like System.IO + that re-expose these functions under a different type, namely SIO. +stability: Provisional +build-type: Simple + +library + build-depends: base>=3.0, parallel, extensible-exceptions + exposed-modules: System.IO.Strict + System.IO.Strict.Internals + Data.IORef.Strict + -- TODO Control.Exception.Strict + ghc-options: -Wall -O2 + +source-repository head + type: darcs + location: http://patch-tag.com/publicrepos/strict-io + +source-repository this + type: darcs + location: http://patch-tag.com/publicrepos/strict-io + tag: 0.1 +