[Pkg-haskell-commits] [SCM] haskell-testpack branch, master, updated. debian/1.0.2-1-4-gb0d6b36
John Goerzen
jgoerzen at complete.org
Fri Apr 23 15:18:06 UTC 2010
The following commit has been merged in the master branch:
commit 25f18d4344427b662591beadbcd2ff634b311661
Author: John Goerzen <jgoerzen at complete.org>
Date: Sun Dec 3 10:11:18 2006 +0100
Removed packages that are to be removed according to TransitionPlanning
diff --git a/MissingH/Path/FilePath.hs b/MissingH/Path/FilePath.hs
deleted file mode 100644
index 61820bf..0000000
--- a/MissingH/Path/FilePath.hs
+++ /dev/null
@@ -1,421 +0,0 @@
-module System.Path.FilePath
- ( -- * File path
- FilePath
- , splitFileName
- , splitFileExt
- , splitFilePath
- , joinFileName
- , joinFileExt
- , joinPaths
- , changeFileExt
- , isRootedPath
- , isAbsolutePath
- , dropAbsolutePrefix
- , breakFilePath
- , dropPrefix
-
- , pathParents
- , commonParent
-
- -- * Search path
- , parseSearchPath
- , mkSearchPath
-
- -- * Separators
- , isPathSeparator
- , pathSeparator
- , searchPathSeparator
-
- -- * Filename extensions
- , exeExtension
- , objExtension
- , dllExtension
- ) where
-
-import Data.List(intersperse)
-
---------------------------------------------------------------
--- * FilePath
---------------------------------------------------------------
-
--- | Split the path into directory and file name
---
--- Examples:
---
--- \[Posix\]
---
--- > splitFileName "/" == ("/", ".")
--- > splitFileName "/foo/bar.ext" == ("/foo", "bar.ext")
--- > splitFileName "bar.ext" == (".", "bar.ext")
--- > splitFileName "/foo/." == ("/foo", ".")
--- > splitFileName "/foo/.." == ("/foo", "..")
---
--- \[Windows\]
---
--- > splitFileName "\\" == ("\\", "")
--- > splitFileName "c:\\foo\\bar.ext" == ("c:\\foo", "bar.ext")
--- > splitFileName "bar.ext" == (".", "bar.ext")
--- > splitFileName "c:\\foo\\." == ("c:\\foo", ".")
--- > splitFileName "c:\\foo\\.." == ("c:\\foo", "..")
---
--- The first case in the Windows examples returns an empty file name.
--- This is a special case because the \"\\\\\" path doesn\'t refer to
--- an object (file or directory) which resides within a directory.
-splitFileName :: FilePath -> (String, String)
-#ifdef mingw32_HOST_OS
-splitFileName p = (reverse (path2++drive), reverse fname)
- where
- (path,drive) = case p of
- (c:':':p) -> (reverse p,[':',c])
- _ -> (reverse p,"")
- (fname,path1) = break isPathSeparator path
- path2 = case path1 of
- [] -> "."
- [_] -> path1 -- don't remove the trailing slash if
- -- there is only one character
- (c:path) | isPathSeparator c -> path
- _ -> path1
-#else
-splitFileName p = (reverse path1, reverse fname1)
- where
- (fname,path) = break isPathSeparator (reverse p)
- path1 = case path of
- "" -> "."
- _ -> case dropWhile isPathSeparator path of
- "" -> [pathSeparator]
- p -> p
- fname1 = case fname of
- "" -> "."
- _ -> fname
-#endif
-
--- | Split the path into file name and extension. If the file doesn\'t have extension,
--- the function will return empty string. The extension doesn\'t include a leading period.
---
--- Examples:
---
--- > splitFileExt "foo.ext" == ("foo", "ext")
--- > splitFileExt "foo" == ("foo", "")
--- > splitFileExt "." == (".", "")
--- > splitFileExt ".." == ("..", "")
--- > splitFileExt "foo.bar."== ("foo.bar.", "")
-splitFileExt :: FilePath -> (String, String)
-splitFileExt p =
- case break (== '.') fname of
- (suf@(_:_),_:pre) -> (reverse (pre++path), reverse suf)
- _ -> (p, [])
- where
- (fname,path) = break isPathSeparator (reverse p)
-
--- | Split the path into directory, file name and extension.
--- The function is an optimized version of the following equation:
---
--- > splitFilePath path = (dir,name,ext)
--- > where
--- > (dir,basename) = splitFileName path
--- > (name,ext) = splitFileExt basename
-splitFilePath :: FilePath -> (String, String, String)
-splitFilePath path = case break (== '.') (reverse basename) of
- (name_r, "") -> (dir, reverse name_r, "")
- (ext_r, _:name_r) -> (dir, reverse name_r, reverse ext_r)
- where
- (dir, basename) = splitFileName path
-
--- | The 'joinFileName' function is the opposite of 'splitFileName'.
--- It joins directory and file names to form a complete file path.
---
--- The general rule is:
---
--- > dir `joinFileName` basename == path
--- > where
--- > (dir,basename) = splitFileName path
---
--- There might be an exceptions to the rule but in any case the
--- reconstructed path will refer to the same object (file or directory).
--- An example exception is that on Windows some slashes might be converted
--- to backslashes.
-joinFileName :: String -> String -> FilePath
-joinFileName "" fname = fname
-joinFileName "." fname = fname
-joinFileName dir "" = dir
-joinFileName dir fname
- | isPathSeparator (last dir) = dir++fname
- | otherwise = dir++pathSeparator:fname
-
--- | The 'joinFileExt' function is the opposite of 'splitFileExt'.
--- It joins a file name and an extension to form a complete file path.
---
--- The general rule is:
---
--- > filename `joinFileExt` ext == path
--- > where
--- > (filename,ext) = splitFileExt path
-joinFileExt :: String -> String -> FilePath
-joinFileExt path "" = path
-joinFileExt path ext = path ++ '.':ext
-
--- | Given a directory path \"dir\" and a file\/directory path \"rel\",
--- returns a merged path \"full\" with the property that
--- (cd dir; do_something_with rel) is equivalent to
--- (do_something_with full). If the \"rel\" path is an absolute path
--- then the returned path is equal to \"rel\"
-joinPaths :: FilePath -> FilePath -> FilePath
-joinPaths path1 path2
- | isRootedPath path2 = path2
- | otherwise =
-#ifdef mingw32_HOST_OS
- case path2 of
- d:':':path2' | take 2 path1 == [d,':'] -> path1 `joinFileName` path2'
- | otherwise -> path2
- _ -> path1 `joinFileName` path2
-#else
- path1 `joinFileName` path2
-#endif
-
--- | Changes the extension of a file path.
-changeFileExt :: FilePath -- ^ The path information to modify.
- -> String -- ^ The new extension (without a leading period).
- -- Specify an empty string to remove an existing
- -- extension from path.
- -> FilePath -- ^ A string containing the modified path information.
-changeFileExt path ext = joinFileExt name ext
- where
- (name,_) = splitFileExt path
-
--- | On Unix and Macintosh the 'isRootedPath' function is a synonym to 'isAbsolutePath'.
--- The difference is important only on Windows. The rooted path must start from the root
--- directory but may not include the drive letter while the absolute path always includes
--- the drive letter and the full file path.
-isRootedPath :: FilePath -> Bool
-isRootedPath (c:_) | isPathSeparator c = True
-#ifdef mingw32_HOST_OS
-isRootedPath (_:':':c:_) | isPathSeparator c = True -- path with drive letter
-#endif
-isRootedPath _ = False
-
--- | Returns 'True' if this path\'s meaning is independent of any OS
--- \"working directory\", or 'False' if it isn\'t.
-isAbsolutePath :: FilePath -> Bool
-#ifdef mingw32_HOST_OS
-isAbsolutePath (_:':':c:_) | isPathSeparator c = True
-#else
-isAbsolutePath (c:_) | isPathSeparator c = True
-#endif
-isAbsolutePath _ = False
-
--- | If the function is applied to an absolute path then it returns a local path droping
--- the absolute prefix in the path. Under Windows the prefix is \"\\\", \"c:\" or \"c:\\\". Under
--- Unix the prefix is always \"\/\".
-dropAbsolutePrefix :: FilePath -> FilePath
-dropAbsolutePrefix (c:cs) | isPathSeparator c = cs
-#ifdef mingw32_HOST_OS
-dropAbsolutePrefix (_:':':c:cs) | isPathSeparator c = cs -- path with drive letter
-dropAbsolutePrefix (_:':':cs) = cs
-#endif
-dropAbsolutePrefix cs = cs
-
--- | Split the path into a list of strings constituting the filepath
---
--- > breakFilePath "/usr/bin/ls" == ["/","usr","bin","ls"]
-breakFilePath :: FilePath -> [String]
-breakFilePath = worker []
- where worker ac path
- | less == path = less:ac
- | otherwise = worker (current:ac) less
- where (less,current) = splitFileName path
-
--- | Drops a specified prefix from a filepath.
---
--- > stripPrefix "." "Src/Test.hs" == "Src/Test.hs"
--- > stripPrefix "Src" "Src/Test.hs" == "Test.hs"
-dropPrefix :: FilePath -> FilePath -> FilePath
-dropPrefix prefix path
- = worker (breakFilePath prefix) (breakFilePath path)
- where worker (x:xs) (y:ys)
- | x == y = worker xs ys
- worker _ ys = foldr1 joinPaths ys
--- | Gets this path and all its parents.
--- The function is useful in case if you want to create
--- some file but you aren\'t sure whether all directories
--- in the path exist or if you want to search upward for some file.
---
--- Some examples:
---
--- \[Posix\]
---
--- > pathParents "/" == ["/"]
--- > pathParents "/dir1" == ["/", "/dir1"]
--- > pathParents "/dir1/dir2" == ["/", "/dir1", "/dir1/dir2"]
--- > pathParents "dir1" == [".", "dir1"]
--- > pathParents "dir1/dir2" == [".", "dir1", "dir1/dir2"]
---
--- \[Windows\]
---
--- > pathParents "c:" == ["c:."]
--- > pathParents "c:\\" == ["c:\\"]
--- > pathParents "c:\\dir1" == ["c:\\", "c:\\dir1"]
--- > pathParents "c:\\dir1\\dir2" == ["c:\\", "c:\\dir1", "c:\\dir1\\dir2"]
--- > pathParents "c:dir1" == ["c:.","c:dir1"]
--- > pathParents "dir1\\dir2" == [".", "dir1", "dir1\\dir2"]
---
--- Note that if the file is relative then the current directory (\".\")
--- will be explicitly listed.
-pathParents :: FilePath -> [FilePath]
-pathParents p =
- root'' : map ((++) root') (dropEmptyPath $ inits path')
- where
-#ifdef mingw32_HOST_OS
- (root,path) = case break (== ':') p of
- (path, "") -> ("",path)
- (root,_:path) -> (root++":",path)
-#else
- (root,path) = ("",p)
-#endif
- (root',root'',path') = case path of
- (c:path) | isPathSeparator c -> (root++[pathSeparator],root++[pathSeparator],path)
- _ -> (root ,root++"." ,path)
-
- dropEmptyPath ("":paths) = paths
- dropEmptyPath paths = paths
-
- inits :: String -> [String]
- inits [] = [""]
- inits cs =
- case pre of
- "." -> inits suf
- ".." -> map (joinFileName pre) (dropEmptyPath $ inits suf)
- _ -> "" : map (joinFileName pre) (inits suf)
- where
- (pre,suf) = case break isPathSeparator cs of
- (pre,"") -> (pre, "")
- (pre,_:suf) -> (pre,suf)
-
--- | Given a list of file paths, returns the longest common parent.
-commonParent :: [FilePath] -> Maybe FilePath
-commonParent [] = Nothing
-commonParent paths@(p:ps) =
- case common Nothing "" p ps of
-#ifdef mingw32_HOST_OS
- Nothing | all (not . isAbsolutePath) paths ->
- let
- getDrive (d:':':_) ds
- | not (d `elem` ds) = d:ds
- getDrive _ ds = ds
- in
- case foldr getDrive [] paths of
- [] -> Just "."
- [d] -> Just [d,':']
- _ -> Nothing
-#else
- Nothing | all (not . isAbsolutePath) paths -> Just "."
-#endif
- mb_path -> mb_path
- where
- common i acc [] ps = checkSep i acc ps
- common i acc (c:cs) ps
- | isPathSeparator c = removeSep i acc cs [] ps
- | otherwise = removeChar i acc c cs [] ps
-
- checkSep i acc [] = Just (reverse acc)
- checkSep i acc ([]:ps) = Just (reverse acc)
- checkSep i acc ((c1:p):ps)
- | isPathSeparator c1 = checkSep i acc ps
- checkSep i acc ps = i
-
- removeSep i acc cs pacc [] =
- common (Just (reverse (pathSeparator:acc))) (pathSeparator:acc) cs pacc
- removeSep i acc cs pacc ([] :ps) = Just (reverse acc)
- removeSep i acc cs pacc ((c1:p):ps)
- | isPathSeparator c1 = removeSep i acc cs (p:pacc) ps
- removeSep i acc cs pacc ps = i
-
- removeChar i acc c cs pacc [] = common i (c:acc) cs pacc
- removeChar i acc c cs pacc ([] :ps) = i
- removeChar i acc c cs pacc ((c1:p):ps)
- | c == c1 = removeChar i acc c cs (p:pacc) ps
- removeChar i acc c cs pacc ps = i
-
---------------------------------------------------------------
--- * Search path
---------------------------------------------------------------
-
--- | The function splits the given string to substrings
--- using the 'searchPathSeparator'.
-parseSearchPath :: String -> [FilePath]
-parseSearchPath path = split searchPathSeparator path
- where
- split :: Char -> String -> [String]
- split c s =
- case rest of
- [] -> [chunk]
- _:rest' -> chunk : split c rest'
- where
- (chunk, rest) = break (==c) s
-
--- | The function concatenates the given paths to form a
--- single string where the paths are separated with 'searchPathSeparator'.
-mkSearchPath :: [FilePath] -> String
-mkSearchPath paths = concat (intersperse [searchPathSeparator] paths)
-
-
---------------------------------------------------------------
--- * Separators
---------------------------------------------------------------
-
--- | Checks whether the character is a valid path separator for the host
--- platform. The valid character is a 'pathSeparator' but since the Windows
--- operating system also accepts a slash (\"\/\") since DOS 2, the function
--- checks for it on this platform, too.
-isPathSeparator :: Char -> Bool
-isPathSeparator ch =
-#ifdef mingw32_HOST_OS
- ch == '/' || ch == '\\'
-#else
- ch == '/'
-#endif
-
--- | Provides a platform-specific character used to separate directory levels in
--- a path string that reflects a hierarchical file system organization. The
--- separator is a slash (@\"\/\"@) on Unix and Macintosh, and a backslash
--- (@\"\\\"@) on the Windows operating system.
-pathSeparator :: Char
-#ifdef mingw32_HOST_OS
-pathSeparator = '\\'
-#else
-pathSeparator = '/'
-#endif
-
--- | A platform-specific character used to separate search path strings in
--- environment variables. The separator is a colon (\":\") on Unix and Macintosh,
--- and a semicolon (\";\") on the Windows operating system.
-searchPathSeparator :: Char
-#ifdef mingw32_HOST_OS
-searchPathSeparator = ';'
-#else
-searchPathSeparator = ':'
-#endif
-
--- ToDo: This should be determined via autoconf (AC_EXEEXT)
--- | Extension for executable files
--- (typically @\"\"@ on Unix and @\"exe\"@ on Windows or OS\/2)
-exeExtension :: String
-#ifdef mingw32_HOST_OS
-exeExtension = "exe"
-#else
-exeExtension = ""
-#endif
-
--- ToDo: This should be determined via autoconf (AC_OBJEXT)
--- | Extension for object files. For GHC and NHC the extension is @\"o\"@.
--- Hugs uses either @\"o\"@ or @\"obj\"@ depending on the used C compiler.
-objExtension :: String
-objExtension = "o"
-
--- | Extension for dynamically linked (or shared) libraries
--- (typically @\"so\"@ on Unix and @\"dll\"@ on Windows)
-dllExtension :: String
-#ifdef mingw32_HOST_OS
-dllExtension = "dll"
-#else
-dllExtension = "so"
-#endif
diff --git a/MissingH/Threads/Child.hs b/MissingH/Threads/Child.hs
deleted file mode 100644
index d425f6f..0000000
--- a/MissingH/Threads/Child.hs
+++ /dev/null
@@ -1,108 +0,0 @@
-{- |
- Module : MissingH.Threads.Child
- Copyright : (c) 2005-02-10 by Peter Simons
- License : GPL2
-
- Maintainer : simons at cryp.to
- Stability : provisional
- Portability : Haskell 2-pre
-
- "Control.Concurrent"'s 'forkIO' is as low-level as it
- gets: once you have forked an 'IO' thread, it is
- basically /gone/; all @forkIO@ returns is @()@. If you
- need more sophisticated control, you have to do it
- yourself. This is what this library does.
--}
-
-module MissingH.Threads.Child
- ( Child(..) -- = Child ThreadId (MVar a)
- , mkChild -- :: Monoid a => ThreadId -> MVar a -> IO a -> IO ()
- , spawn -- :: Monoid a => IO a -> IO (Child a)
- , wait -- :: Child a -> IO a
- , send -- :: Child a -> Exception -> IO ()
- , kill -- :: Child a -> IO ()
- , par -- :: Monoid a => IO a -> IO a -> IO a
- )
- where
-
-import Prelude hiding ( catch )
-import Control.Exception
-import Control.Concurrent
-import Control.Monad
-import Data.Monoid
-
--- |A @Child@ is a cutely named data type which contains the
--- 'ThreadId' of a forked computation and an 'MVar' into
--- which the computation will put its return value once it
--- has terminated. Thus, you can wait for your children to
--- terminate by getting the value from that 'MVar'. Another
--- property of children is that uncaught exceptions in them
--- will be propagated to your thread. So either you 'catch'
--- them, or a failure in any however deeply nested child
--- will go right up to @main at .
-
-data Child a = Child ThreadId (MVar a)
-
--- |Wrap an 'IO' computation so that (1) uncaught exceptions
--- are re-thrown to the given 'ThreadId', and that (2) it
--- will put the @a@ it returns into the 'MVar'. The value
--- has to be a 'Monoid' because in case of (1) the wrapper
--- still needs /some/ value to put into that 'MVar', so it
--- uses 'mempty'. Popular monoids are @()@ and @[]@.
-
-mkChild :: (Monoid a) => ThreadId -> MVar a -> IO a -> IO ()
-mkChild parent mv f = catch (f >>= sync) h `finally` sync mempty
- where
- sync x = tryPutMVar mv x >> return ()
- h (AsyncException ThreadKilled) = return ()
- h e = throwTo parent e
-
--- |Start an 'IO' computation with the properties described
--- above.
-
-spawn :: (Monoid a) => IO a -> IO (Child a)
-spawn f = do
- self <- myThreadId
- sync <- newEmptyMVar
- pid <- forkIO (mkChild self sync f)
- return (Child pid sync)
-
--- |Get the value returned by a \"child process\"; may be
--- 'mempty'. But in case it is, you have just received an
--- asynchronous 'Exception' anyway, so you have other things
--- to do. The function does not return until the child has
--- terminated. If /your/ thread receives an exception while
--- it waits for the child, the child will be terminated
--- before 'wait' returns. So once 'wait' returns, the child
--- is guaranteed to be gone, one way or another.
-
-wait :: Child a -> IO a
-wait (Child pid sync) = readMVar sync `finally` killThread pid
-
--- |A fancy wrapper for 'throwTo'.
-
-send :: Child a -> Exception -> IO ()
-send (Child pid _) = throwTo pid
-
--- |Wraps 'killThread'.
-
-kill :: Child a -> IO ()
-kill (Child pid _) = killThread pid
-
--- |Run both computations with 'spawn' and return the value
--- of the child which terminates /first/. Both children are
--- guaranteed to be gone when 'par' returns. Exceptions in
--- either child are propagated. So if either child fails,
--- 'par' fails.
-
-par :: (Monoid a) => IO a -> IO a -> IO a
-par f g = do
- self <- myThreadId
- sync <- newEmptyMVar
- bracket
- (forkIO (mkChild self sync f))
- (killThread)
- (\_ -> bracket
- (forkIO (mkChild self sync g))
- (killThread)
- (\_ -> takeMVar sync))
diff --git a/MissingH/Threads/Timeout.hs b/MissingH/Threads/Timeout.hs
deleted file mode 100644
index d4279e8..0000000
--- a/MissingH/Threads/Timeout.hs
+++ /dev/null
@@ -1,41 +0,0 @@
-{- |
- Module : MissingH.Threads.Timeout
- Copyright : (c) 2005-02-10 by Peter Simons
- License : GPL2
-
- Maintainer : simons at cryp.to
- Stability : provisional
- Portability : Haskell 2-pre
-
- Timeout support for 'IO' computations.
--}
-
-module MissingH.Threads.Timeout
- ( Timeout -- = Int
- , timeout -- :: Timeout -> IO a -> IO (Maybe a)
- )
- where
-
-import MissingH.Threads.Child ( par )
-import Control.Concurrent ( threadDelay )
-
--- |Timeouts are given in microseconds (@1\/10^6@ seconds).
--- Negative values generally mean \"wait indefinitely\".
--- Make sure you don't exceed @maxBound :: Int@ when
--- specifying large timeouts!
-
-type Timeout = Int
-
--- |Wrap an 'IO' computation to timeout and return 'Nothing'
--- after @n@ microseconds, otherwise @'Just' a@ is returned.
-
-timeout :: Timeout -> IO a -> IO (Maybe a)
-timeout n f
- | n < 0 = fmap Just f
- | n == 0 = return Nothing
- | otherwise = do -- a => [a]
- r <- par (threadDelay n >> return []) (fmap return f)
- case r of [] -> return Nothing
- (a:_) -> return (Just a)
- -- We do this so that @a@ doesn't have
- -- to be a monoid.
diff --git a/src/System/IO/BlockIO.hs b/src/System/IO/BlockIO.hs
deleted file mode 100644
index d26d672..0000000
--- a/src/System/IO/BlockIO.hs
+++ /dev/null
@@ -1,175 +0,0 @@
-{-# OPTIONS -fglasgow-exts #-}
-{- |
- Module : System.IO.BlockIO
- Copyright : (c) 2005-02-10 by Peter Simons
- License : GPL2
-
- Maintainer : simons at cryp.to
- Stability : provisional
- Portability : Haskell 2-pre
-
- 'runLoop' drives a 'BlockHandler' with data read from the
- input stream until 'hIsEOF' ensues. Everything else has
- to be done by the callback; runLoop just does the I\/O.
- But it does it /fast/.
--}
-
-module System.IO.BlockIO where
-
-import Prelude hiding ( catch, rem )
-import Control.Exception
-import Control.Monad.State
-import Data.List
-import Data.Typeable
-import System.IO
-import System.IO.Error hiding ( catch )
-import Foreign hiding ( new )
-import MissingH.Threads.Timeout
-
--- * Static Buffer I\/O
-
-type ReadHandle = Handle
-type WriteHandle = Handle
-
-type ByteCount = Word16
-type Capacity = Word16
-data Buffer = Buf !Capacity !(Ptr Word8) !ByteCount
- deriving (Eq, Show, Typeable)
-
--- |Run the given computation with an initialized, empty
--- 'Buffer'. The buffer is gone when the computation
--- returns.
-
-withBuffer :: Capacity -> (Buffer -> IO a) -> IO a
-withBuffer 0 = fail "BlockIO.withBuffer with size 0 doesn't make sense"
-withBuffer n = bracket cons dest
- where
- cons = mallocArray (fromIntegral n) >>= \p -> return (Buf n p 0)
- dest = \(Buf _ p _) -> free p
-
--- |Drop the first @n <= size@ octets from the buffer.
-
-flush :: ByteCount -> Buffer -> IO Buffer
-flush 0 buf = return buf
-flush n (Buf cap ptr len) = assert (n <= len) $ do
- let ptr' = ptr `plusPtr` (fromIntegral n)
- len' = (fromIntegral len) - (fromIntegral n)
- when (len' > 0) (copyArray ptr ptr' len')
- return (Buf cap ptr (fromIntegral len'))
-
--- |If there is space, read and append more octets; then
--- return the modified buffer. In case of 'hIsEOF',
--- 'Nothing' is returned. If the buffer is full already,
--- 'throwDyn' a 'BufferOverflow' exception. When the timeout
--- exceeds, 'ReadTimeout' is thrown.
-
-slurp :: Timeout -> ReadHandle -> Buffer -> IO (Maybe Buffer)
-slurp to h b@(Buf cap ptr len) = do
- when (cap <= len) (throwDyn (BufferOverflow h b))
- timeout to (handleEOF wrap) >>=
- maybe (throwDyn (ReadTimeout to h b)) return
- where
- wrap = do let ptr' = ptr `plusPtr` (fromIntegral len)
- n = cap - len
- rc <- hGetBufNonBlocking h ptr' (fromIntegral n)
- if rc > 0
- then return (Buf cap ptr (len + (fromIntegral rc)))
- else hWaitForInput h (-1) >> wrap
-
--- * BlockHandler and I\/O Driver
-
--- |A callback function suitable for use with 'runLoop'
--- takes a buffer and a state, then returns a modified
--- buffer and a modified state. Usually the callback will
--- use 'slurp' to remove data it has processed already.
-
-type BlockHandler st = Buffer -> st -> IO (Buffer, st)
-
--- |Our main I\/O driver.
-
-runLoopNB
- :: (st -> Timeout) -- ^ user state provides timeout
- -> (Exception -> st -> IO st) -- ^ user provides I\/O error handler
- -> ReadHandle -- ^ the input source
- -> Capacity -- ^ I\/O buffer size
- -> BlockHandler st -- ^ callback
- -> st -- ^ initial callback state
- -> IO st -- ^ return final callback state
-runLoopNB mkTO errH hIn cap f initST = withBuffer cap (flip ioloop $ initST)
- where
- ioloop buf st = buf `seq` st `seq`
- handle (\e -> errH e st) $ do
- rc <- slurp (mkTO st) hIn buf
- case rc of
- Nothing -> return st
- Just buf' -> f buf' st >>= uncurry ioloop
-
--- |A variant which won't time out and will just 'throw' all
--- exceptions.
-
-runLoop :: ReadHandle -> Capacity -> BlockHandler st -> st -> IO st
-runLoop = runLoopNB (const (-1)) (\e _ -> throw e)
-
--- * Handler Combinators
-
--- |Signal how many bytes have been consumed from the
--- /front/ of the list; these octets will be dropped.
-
-type StreamHandler st = [Word8] -> st -> IO (ByteCount, st)
-
-handleStream :: StreamHandler st -> BlockHandler st
-handleStream f buf@(Buf _ ptr len) st = do
- (i, st') <- peekArray (fromIntegral len) ptr >>= (flip f) st
- buf' <- flush i buf
- return (buf', st')
-
--- * I\/O Exceptions
-
--- |Thrown by 'slurp'.
-
-data BufferOverflow = BufferOverflow ReadHandle Buffer
- deriving (Show, Typeable)
-
--- |Thrown by 'slurp'.
-
-data ReadTimeout = ReadTimeout Timeout ReadHandle Buffer
- deriving (Show, Typeable)
-
-
--- * Internal Helper Functions
-
--- |Return 'Nothing' if the given computation throws an
--- 'isEOFError' exception. Used by 'slurp'.
-
-handleEOF :: IO a -> IO (Maybe a)
-handleEOF f =
- catchJust ioErrors
- (fmap Just f)
- (\e -> if isEOFError e then return Nothing else ioError e)
-
--- |Our version of C's @strstr(3)@.
-
-strstr :: [Word8] -> [Word8] -> Maybe Int
-strstr tok = strstr' 0
- where
- strstr' _ [] = Nothing
- strstr' pos ls@(_:xs)
- | tok `isPrefixOf` ls = Just (pos + length tok)
- | otherwise = strstr' (pos + 1) xs
-
--- |Split a list by some delimiter. Will soon be provided by
--- "Data.List".
-
-splitList :: Eq a => [a] -> [a] -> [[a]]
-splitList d' l' =
- unfoldr (\x -> (null x) ? (Nothing, Just $ nextToken d' [] (snd $ splitAt (length d') x))) (d'++l')
- where nextToken _ r [] = (r, [])
- nextToken d r l@(h:t) | (d `isPrefixOf` l) = (r, l)
- | otherwise = nextToken d (r++[h]) t
-
--- |Shorthand for if-then-else. Will soon by provided by
--- "Data.Bool".
-
-(?) :: Bool -> (a,a) -> a
-(?) True (x,_) = x
-(?) False (_,x) = x
--
haskell-testpack
More information about the Pkg-haskell-commits
mailing list