Copy tests from GHC testsuite; part of #1161.
[packages/base.git] / tests / IO / encoding001.hs
1 import Control.Monad
2 import System.IO
3 import GHC.IO.Encoding
4 import GHC.IO.Handle
5 import Data.Bits
6 import Data.Word
7 import Data.Char
8 import System.FilePath
9 import System.Exit
10
11 file = "encoding001"
12
13 encodings = [(utf8, "utf8"),
14 (utf8_bom, "utf8_bom"),
15 (utf16, "utf16"),
16 (utf16le, "utf16le"),
17 (utf16be, "utf16be"),
18 (utf32, "utf32"),
19 (utf32le, "utf32le"),
20 (utf32be, "utf32be")]
21
22 main = do
23 -- make a UTF-32BE file
24 h <- openBinaryFile (file <.> "utf32be") WriteMode
25 let expand32 :: Word32 -> [Char]
26 expand32 x = [
27 chr (fromIntegral (x `shiftR` 24) .&. 0xff),
28 chr (fromIntegral (x `shiftR` 16) .&. 0xff),
29 chr (fromIntegral (x `shiftR` 8) .&. 0xff),
30 chr (fromIntegral x .&. 0xff) ]
31 hPutStr h (concatMap expand32 [ 0, 32 .. 0xD7ff ])
32 -- We avoid the private-use characters at 0xEF00..0xEFFF
33 -- that reserved for GHC's PEP383 roundtripping implementation.
34 --
35 -- The reason is that currently normal text containing those
36 -- characters will be mangled, even if we aren't using an encoding
37 -- created using //ROUNDTRIP.
38 hPutStr h (concatMap expand32 [ 0xE000, 0xE000+32 .. 0xEEFF ])
39 hPutStr h (concatMap expand32 [ 0xF000, 0xF000+32 .. 0x10FFFF ])
40 hClose h
41
42 -- convert the UTF-32BE file into each other encoding
43 forM_ encodings $ \(enc,name) -> do
44 when (name /= "utf32be") $ do
45 hin <- openFile (file <.> "utf32be") ReadMode
46 hSetEncoding hin utf32be
47 hout <- openFile (file <.> name) WriteMode
48 hSetEncoding hout enc
49 hGetContents hin >>= hPutStr hout
50 hClose hin
51 hClose hout
52
53 forM_ [ (from,to) | from <- encodings, to <- encodings, snd from /= snd to ]
54 $ \((fromenc,fromname),(toenc,toname)) -> do
55 hin <- openFile (file <.> fromname) ReadMode
56 hSetEncoding hin fromenc
57 hout <- openFile (file <.> toname <.> fromname) WriteMode
58 hSetEncoding hout toenc
59 hGetContents hin >>= hPutStr hout
60 hClose hin
61 hClose hout
62
63 h1 <- openBinaryFile (file <.> toname) ReadMode
64 h2 <- openBinaryFile (file <.> toname <.> fromname) ReadMode
65 str1 <- hGetContents h1
66 str2 <- hGetContents h2
67 when (str1 /= str2) $ do
68 putStrLn (file <.> toname ++ " and " ++ file <.> toname <.> fromname ++ " differ")
69 exitWith (ExitFailure 1)
70 hClose h1
71 hClose h2