[Pkg-haskell-commits] [SCM] haskell-testpack branch, master, updated. debian/1.0.2-1-4-gb0d6b36

[John Goerzen]

The following commit has been merged in the master branch:
commit 90b018bc36f71bb7f3e1f197608620e41e43a159
Author: John Goerzen <jgoerzen at complete.org>
Date:   Thu Dec 16 03:12:52 2004 +0100

    Checkpointing
    
    Keywords:
    
    
    (jgoerzen at complete.org--projects/missingh--head--0.7--patch-73)

diff --git a/ChangeLog b/ChangeLog
index 300e5c0..b98a6d5 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -2,6 +2,18 @@
 # arch-tag: automatic-ChangeLog--jgoerzen at complete.org--projects/missingh--head--0.7
 #
 
+2004-12-15 20:12:52 GMT	John Goerzen <jgoerzen at complete.org>	patch-73
+
+    Summary:
+      Checkpointing
+    Revision:
+      missingh--head--0.7--patch-73
+
+
+    modified files:
+     ChangeLog libsrc/MissingH/HVIO.hs
+
+
 2004-12-15 19:42:43 GMT	John Goerzen <jgoerzen at complete.org>	patch-72
 
     Summary:
diff --git a/libsrc/MissingH/HVIO.hs b/libsrc/MissingH/HVIO.hs
index f6cb040..26b7a20 100644
--- a/libsrc/MissingH/HVIO.hs
+++ b/libsrc/MissingH/HVIO.hs
@@ -147,6 +147,10 @@ class (HVIOGeneric a) => HVIOWriter a where
     vPutStrLn :: a -> String -> IO ()
     -- | Write a string representation of the argument, plus a newline.
     vPrint :: Show b => a -> b -> IO ()
+    -- | Flush any output buffers.
+    -- Note: implementations should assure that a vFlush is performed
+    -- on file close, if necessary to ensure all data sent is written.
+    vFlush :: a -> IO ()
 
     vPutStr _ [] = return ()
     vPutStr h (x:xs) = do vPutChar h x
@@ -155,6 +159,8 @@ class (HVIOGeneric a) => HVIOWriter a where
     vPutStrLn h s = vPutStr h (s ++ "\n")
 
     vPrint h s = vPutStrLn h (show s)
+                 
+    vFlush _ = return ()
 
 {- | Seekable items.  Implementators must provide all functions.
 
@@ -189,6 +195,7 @@ instance HVIOWriter Handle where
     vPutStr = hPutStr
     vPutStrLn = hPutStrLn
     vPrint = hPrint
+    vFlush = hFlush
 
 instance HVIOSeeker Handle where
     vSeek = hSeek
@@ -206,7 +213,7 @@ vioc_get :: VIOCloseSupport a -> IO a
 vioc_get x = readIORef x >>= return . snd
 
 vioc_close :: VIOCloseSupport a -> IO ()
-vioc_close x = modifyIORef x (\ _ -> (False, undefined))
+vioc_close x = modifyIORef x (\ (_, dat) -> (False, dat))
 
 vioc_set :: VIOCloseSupport a -> a -> IO ()
 vioc_set x newdat = modifyIORef x (\ (stat, _) -> (stat, newdat))
@@ -250,3 +257,47 @@ instance HVIOReader StreamReader where
                         vClose h
                         return c
 
+----------------------------------------------------------------------
+-- Pipes
+----------------------------------------------------------------------
+
+-- newPipe :: (PipeReader, PipeWriter)
+
+data PipeBit = PipeBit Char 
+             | PipeEOF
+               deriving (Eq, Show)
+
+newtype PipeReader = PipeReader (VIOCloseSupport (MVar PipeBit))
+newtype PipeWriter = PipeWriter (VIOCloseSupport (MVar PipeBit))
+
+prv (PipeReader x) = x
+
+instance Show PipeReader where
+    show x = "<PipeReader>"
+
+instance HVIOGeneric PipeReader where
+    vClose = vioc_close . prv
+    vIsOpen = vioc_isopen . prv
+    vIsEOF h = do mv <- vioc_get (prv h)
+                  dat <- readMVar mv
+                  return (dat == PipeEOF)
+
+pr_getc h = do mv <- vioc_get (prv h)
+               takeMVar mv
+
+instance HVIOReader PipeReader where
+    vGetChar h = do vTestEOF h
+                    c <- pr_getc h
+                    case c of 
+                        PipeBit x -> return x
+                        -- vTestEOF should eliminate this case
+                        _ -> fail "Internal error in HVIOReader vGetChar"
+    vGetContents h = 
+        let loop = do c <- pr_getc h
+                      case c of
+                          PipeEOF -> return []
+                          PipeBit x -> do next <- loop
+                                          return (x : next)
+        in do vTestEOF h
+              loop
+                        

-- 
haskell-testpack