Copy tests from GHC testsuite; part of #1161.
[packages/base.git] / tests / IO / T4144.hs
1 {-# LANGUAGE OverloadedStrings, DeriveDataTypeable #-}
2 module Main (main) where
3
4 import Control.Applicative
5 import Control.Concurrent.MVar
6 import Control.Monad
7
8 import Data.ByteString (ByteString)
9 import qualified Data.ByteString as B
10 import qualified Data.ByteString.Char8
11 import Data.ByteString.Char8()
12 import Data.ByteString.Unsafe as B
13 import Data.ByteString.Internal (memcpy)
14 import Data.Typeable (Typeable)
15 import Data.Word
16
17 import Foreign
18
19 import GHC.IO.Buffer
20 import GHC.IO.BufferedIO
21 import GHC.IO.Device
22 import GHC.IO.Handle
23
24 import System.IO
25
26 -- | Create a seakable read-handle from a bytestring
27 bsHandle :: ByteString -> FilePath -> IO Handle
28 bsHandle bs fp
29 = newBsDevice bs >>= \dev ->
30 mkFileHandle dev fp ReadMode Nothing noNewlineTranslation
31
32 data BSIODevice
33 = BSIODevice
34 ByteString
35 (MVar Int) -- Position
36 deriving Typeable
37
38 newBsDevice :: ByteString -> IO BSIODevice
39 newBsDevice bs = BSIODevice bs <$> newMVar 0
40
41 remaining :: BSIODevice -> IO Int
42 remaining (BSIODevice bs mPos)
43 = do
44 let bsLen = B.length bs
45 withMVar mPos $ \pos -> return (bsLen - pos)
46
47 sizeBS :: BSIODevice -> Int
48 sizeBS (BSIODevice bs _) = B.length bs
49
50 seekBS :: BSIODevice -> SeekMode -> Int -> IO ()
51 seekBS dev AbsoluteSeek pos
52 | pos < 0 = error "Cannot seek to a negative position!"
53 | pos > sizeBS dev = error "Cannot seek past end of handle!"
54 | otherwise = case dev of
55 BSIODevice _ mPos
56 -> modifyMVar_ mPos $ \_ -> return pos
57 seekBS dev SeekFromEnd pos = seekBS dev AbsoluteSeek (sizeBS dev - pos)
58 seekBS dev RelativeSeek pos
59 = case dev of
60 BSIODevice _bs mPos
61 -> modifyMVar_ mPos $ \curPos ->
62 let newPos = curPos + pos
63 in if newPos < 0 || newPos > sizeBS dev
64 then error "Cannot seek outside of handle!"
65 else return newPos
66
67 tellBS :: BSIODevice -> IO Int
68 tellBS (BSIODevice _ mPos) = readMVar mPos
69
70 dupBS :: BSIODevice -> IO BSIODevice
71 dupBS (BSIODevice bs mPos) = BSIODevice bs <$> (readMVar mPos >>= newMVar)
72
73 readBS :: BSIODevice -> Ptr Word8 -> Int -> IO Int
74 readBS dev@(BSIODevice bs mPos) buff amount
75 = do
76 rem <- remaining dev
77 if amount > rem
78 then readBS dev buff rem
79 else B.unsafeUseAsCString bs $ \ptr ->
80 do
81 memcpy buff (castPtr ptr) (fromIntegral amount)
82 modifyMVar_ mPos (return . (+amount))
83 return amount
84
85 instance BufferedIO BSIODevice where
86 newBuffer dev buffState = newByteBuffer (sizeBS dev) buffState
87 fillReadBuffer dev buff = readBuf dev buff
88 fillReadBuffer0 dev buff
89 = do
90 (amount, buff') <- fillReadBuffer dev buff
91 return (if amount == 0 then Nothing else Just amount, buff')
92
93 instance RawIO BSIODevice where
94 read = readBS
95 readNonBlocking dev buff n = Just `liftM` readBS dev buff n
96
97 instance IODevice BSIODevice where
98 ready _ True _ = return False -- read only
99 ready _ False _ = return True -- always ready
100
101 close _ = return ()
102 isTerminal _ = return False
103 isSeekable _ = return True
104 seek dev seekMode pos = seekBS dev seekMode (fromIntegral pos)
105 tell dev = fromIntegral <$> tellBS dev
106 getSize dev = return $ fromIntegral $ sizeBS dev
107 setEcho _ _ = error "Not a terminal device"
108 getEcho _ = error "Not a terminal device"
109 setRaw _ _ = error "Raw mode not supported"
110 devType _ = return RegularFile
111 dup = dupBS
112 dup2 _ _ = error "Dup2 not supported"
113
114
115 main = bsHandle "test" "<fake file>" >>= Data.ByteString.Char8.hGetContents >>= print