import GHC.IO
import GHC.IO.Handle
import GHC.IO.Handle.Types
import System.IO
import Control.Concurrent.MVar
import Data.Typeable
import qualified GHC.IO.FD as FD

main = do
   h <- openFile "tmp" WriteMode
   hDuplicateTo h stdout

   fdh <- getfd h
   fdstdout <- getfd stdout
   hPutStrLn stderr ("h: " ++ show (fdh /= fdstdout) ++ "\nstdout: " ++ show fdstdout)

   hClose h
   putStrLn "bla"

getfd h@(FileHandle _ mvar) = do
  withMVar mvar $ \h__@Handle__{haDevice=dev} ->
   case cast dev of
     Just fd -> return (FD.fdFD fd)
     Nothing -> error "getfd"


import System.IO

-- !!! test hFileSize

main = do
    h  <- openFile "hFileSize001.hs" ReadMode
    sz <- hFileSize h
    print sz


-- !!! Testing IO.hFileSize
module Main(main) where

import Control.Monad
import System.Directory ( removeFile, doesFileExist )
import System.IO
import System.IO.Error

main = do
  sz <- hFileSize stdin `catchIOError` (\ _ -> return (-1))
  print sz
  let fn = "hFileSize002.out"
  f <- doesFileExist fn
  when f (removeFile fn)
  hdl <- openFile fn WriteMode
  hPutStr hdl "file_size"
   -- with default buffering
  sz <- hFileSize hdl
  print sz

  hSetBuffering hdl NoBuffering
  hPutStr hdl "file_size"
   -- with no buffering
  sz <- hFileSize hdl
  print sz
  hSetBuffering hdl LineBuffering
  hPutStr hdl "file_size"
   -- with line buffering
  sz <- hFileSize hdl
  print sz
  hSetBuffering hdl (BlockBuffering (Just 4))
   -- with block buffering
  hPutStr hdl "file_size"
  sz <- hFileSize hdl
  print sz
  hClose hdl


-- !!! Flushing
module Main(main) where

import Control.Monad
import System.Directory ( removeFile, doesFileExist )
import System.IO
import System.IO.Error

main = do
  hFlush stdin `catchIOError` \ _ -> putStrLn "No can do - flushing read-only handles isn't legal"
  putStr "Hello,"
  hFlush stdout
  putStr "Hello - "
  hFlush stderr
  hdl <- openFile "hFlush001.hs" ReadMode
  hFlush hdl `catchIOError` \ _ -> putStrLn "No can do - flushing read-only handles isn't legal"
  hClose hdl
  remove
  hdl <- openFile "hFlush001.out" WriteMode
  hFlush hdl
  hClose hdl
  remove
  hdl <- openFile "hFlush001.out" AppendMode
  hFlush hdl
  hClose hdl
  remove
  hdl <- openFile "hFlush001.out" ReadWriteMode
  hFlush hdl
  hClose hdl
 where remove = do
         f <- doesFileExist "hFlush001.out"
         when f (removeFile "hFlush001.out")


-- !!! Testing hGetBuf(NonBlocking), hPutBuf(NonBlocking)

import System.Posix
import System.IO
import Control.Concurrent
import Foreign
import Foreign.C
import System.Exit
import Control.Exception
import Control.Monad

main = do
  -- test should run quickly, but arrange to kill it if it hangs for any reason:
  main_t <- myThreadId
  forkIO $ do
        threadDelay 10000000
        throwTo main_t (ErrorCall "killed")

  zipWithM_ ($)
          [ f rbuf wbuf
            | f <- [hGetBufTest, hGetBufNBTest, hGetBufSomeTest],
              rbuf <- [buf1,buf2,buf3],
              wbuf <- [buf1,buf2,buf3]
            ]
          [1..]

msg = "hello!"
msg_length = length msg

buf1 = NoBuffering
buf2 = BlockBuffering (Just 5)
buf3 = BlockBuffering (Just 10)

-- chosen to be larger than buf2 & smaller than buf3, so that we exercise
-- all code paths:
read_size = 8 :: Int

-- ----------------------------------------------------------------------------

-- hGetBuf/hPutBuf:
--   - test that it always reads all the data that is available
--     (with buffer size <, =, > message size).
--   - test that at the EOF, it returns a short read.
--   - the writing end is using hPutBuf, with various buffer sizes, and
--     doing an hFlush at the end of each write.

hGetBufTest rbuf wbuf n = do
  (read,write) <- createPipe
  hread <- fdToHandle read
  hwrite <- fdToHandle write
  m1 <- newEmptyMVar
  m2 <- newEmptyMVar
  finished <- newEmptyMVar
  hSetBuffering hread rbuf
  hSetBuffering hwrite wbuf
  forkIO (readProc m1 m2 finished hread)
  writeProc m1 m2 hwrite
  takeMVar finished
  putStrLn ("test " ++ show n ++ " OK")

readProc :: MVar () -> MVar () -> MVar () -> Handle -> IO ()
readProc m1 m2 finished h = do
  buf <- mallocBytes 20
  let
    loop 0 = return ()
    loop n = do putMVar m2 (); takeMVar m1
                r <- hGetBuf h buf msg_length
                if (r /= msg_length)
                        then do hPutStr stderr ("error: " ++ show r)
                                exitFailure
                        else do s <- peekCStringLen (buf,r)
                                hPutStr stdout (show n ++ " ")
                                loop (n-1)
  loop 100
  hPutStr stdout "\n"
  putMVar m2 (); takeMVar m1
  r <- hGetBuf h buf read_size -- EOF, should get short read
  s <- peekCStringLen (buf,r)
  putStrLn ("got " ++ show r ++  ": " ++ s)
  r <- hGetBuf h buf read_size -- EOF, should get zero-length read
  s <- peekCStringLen (buf,r)
  putStrLn ("got " ++ show r ++  ": " ++ s)
  hClose h
  putMVar finished ()

writeProc :: MVar () -> MVar () -> Handle -> IO ()
writeProc m1 m2 h = do
  let
    loop 0 = return ()
    loop n =
        withCStringLen msg  $ \ (s,len) -> do
          takeMVar m2
          hPutBuf h s len
          hFlush h
          putMVar m1 ()
          loop (n-1)

  loop 100
  takeMVar m2
  withCString "end" $ \s -> do
    hPutBuf h s 3
    putMVar m1 ()
  hClose h

-- -----------------------------------------------------------------------------
-- hGetBufNonBlocking:

hGetBufNBTest rbuf wbuf n = do
  (read,write) <- createPipe
  hread <- fdToHandle read
  hwrite <- fdToHandle write
  m1 <- newEmptyMVar
  m2 <- newEmptyMVar
  finished <- newEmptyMVar
  hSetBuffering hread rbuf
  hSetBuffering hwrite wbuf
  forkIO (readProcNB m1 m2 finished hread)
  writeProcNB m1 m2 hwrite
  takeMVar finished
  putStrLn ("test " ++ show n ++ " OK")

readProcNB :: MVar () -> MVar () -> MVar () -> Handle -> IO ()
readProcNB m1 m2 finished h = do
  buf <- mallocBytes 20

  -- first, test that we can do a non-blocking read:
  r <- hGetBufNonBlocking h buf read_size
  s <- peekCStringLen (buf,r)
  putStrLn ("got " ++ show r ++  ": " ++ s)

  let
    loop 0 = return ()
    loop n = do putMVar m2 (); takeMVar m1
                r <- hGetBufNonBlocking h buf read_size
                if (r /= msg_length)
                        then do hPutStr stderr ("error: " ++ show r)
                                exitFailure
                        else do s <- peekCStringLen (buf,r)
                                hPutStr stdout (show n ++ " ")
                                loop (n-1)
  loop 100
  hPutStr stdout "\n"
  putMVar m2 (); takeMVar m1
  r <- hGetBufNonBlocking h buf read_size -- EOF, should get short read
  s <- peekCStringLen (buf,r)
  putStrLn ("got " ++ show r ++  ": " ++ s)
  r <- hGetBufNonBlocking h buf read_size -- EOF, should get zero-length read
  s <- peekCStringLen (buf,r)
  putStrLn ("got " ++ show r ++  ": " ++ s)
  hClose h
  putMVar finished ()

writeProcNB :: MVar () -> MVar () -> Handle -> IO ()
writeProcNB m1 m2 h = do
  let
    loop 0 = return ()
    loop n =
        withCStringLen msg  $ \ (s,len) -> do
          takeMVar m2
          hPutBufNonBlocking h s len
          hFlush h
          putMVar m1 ()
          loop (n-1)

  loop 100
  takeMVar m2
  withCString "end" $ \s -> do
    hPutBuf h s 3
    hFlush h
    putMVar m1 ()
  hClose h

-- -----------------------------------------------------------------------------
-- hGetBufSome:

hGetBufSomeTest rbuf wbuf n = do
  (read,write) <- createPipe
  hread <- fdToHandle read
  hwrite <- fdToHandle write
  m1 <- newEmptyMVar
  m2 <- newEmptyMVar
  finished <- newEmptyMVar
  hSetBuffering hread rbuf
  hSetBuffering hwrite wbuf
  forkIO (readProcSome m1 m2 finished hread)
  writeProcNB m1 m2 hwrite
  takeMVar finished
  putStrLn ("test " ++ show n ++ " OK")

readProcSome :: MVar () -> MVar () -> MVar () -> Handle -> IO ()
readProcSome m1 m2 finished h = do
  buf <- mallocBytes 20

  let
    loop 0 = return ()
    loop n = do putMVar m2 (); takeMVar m1
                r <- hGetBufSome h buf read_size
                if (r /= msg_length)
                        then do hPutStr stderr ("error: " ++ show r)
                                exitFailure
                        else do s <- peekCStringLen (buf,r)
                                hPutStr stdout (show n ++ " ")
                                loop (n-1)
  loop 100
  hPutStr stdout "\n"
  putMVar m2 (); takeMVar m1
  r <- hGetBufSome h buf read_size -- EOF, should get short read
  s <- peekCStringLen (buf,r)
  putStrLn ("got " ++ show r ++  ": " ++ s)
  r <- hGetBufSome h buf read_size -- EOF, should get zero-length read
  s <- peekCStringLen (buf,r)
  putStrLn ("got " ++ show r ++  ": " ++ s)
  hClose h
  putMVar finished ()


import System.IO

main =
    sequence (map hIsOpen [stdin, stdout, stderr]) >>= \ opens ->
    print opens >>
    sequence (map hIsClosed [stdin, stdout, stderr]) >>= \ closeds ->
    print closeds >>
    sequence (map hIsReadable [stdin, stdout, stderr]) >>= \ readables ->
    print readables >>
    sequence (map hIsWritable [stdin, stdout, stderr]) >>= \ writables ->
    print writables >>
    sequence (map hIsBlockBuffered [stdin, stdout, stderr]) >>= \ buffereds ->
    print buffereds >>
    sequence (map hIsLineBuffered [stdin, stdout, stderr]) >>= \ buffereds ->
    print buffereds >>
    sequence (map hIsNotBuffered [stdin, stdout, stderr]) >>= \ buffereds ->
    print buffereds
  where
    hIsBlockBuffered h = hGetBuffering h >>= \ b -> return $ case b of { BlockBuffering _ -> True; _ -> False }
    hIsLineBuffered  h = hGetBuffering h >>= \ b -> return $ case b of { LineBuffering -> True; _ -> False }
    hIsNotBuffered   h = hGetBuffering h >>= \ b -> return $ case b of { NoBuffering -> True; _ -> False }


import System.IO

main = do
 hSetBuffering stdout NoBuffering
 putStr   "Enter an integer: "
 x1 <- readLine
 putStr   "Enter another integer: "
 x2 <- readLine
 putStr  ("Their sum is " ++ show (read x1 + read x2 :: Int) ++ "\n")

 where readLine = do
           eof <- isEOF
           if eof then return [] else do
           c <- getChar
           if c `elem` ['\n','\r']
                then return []
                else do cs <- readLine
                        return (c:cs)


-- !!! testing hGetLine

import System.IO

-- one version of 'cat'
main = do
  let loop h = do b <- hIsEOF h
                  if b then return ()
                       else do l <- hGetLine h; putStrLn l; loop h
  loop stdin

  h <- openFile "hGetLine001.hs" ReadMode

  hSetBinaryMode stdout True

  hSetBuffering h NoBuffering
  loop h

  hSeek h AbsoluteSeek 0
  hSetBuffering h LineBuffering
  loop h

  hSeek h AbsoluteSeek 0
  hSetBuffering h (BlockBuffering (Just 83))
  loop h


-- !!! testing hGetLine on a file without a final '\n'.

-- According to the Haskell 98 report, getLine should discard a line without a
-- closing newline character (see implementation of getLine).
--
-- However, we don't believe that this is the right behaviour.

import System.IO
import System.IO.Error

main = catchIOError loop (\e -> print e)

loop = do
  hSetBuffering stdin LineBuffering
  l <- hGetLine stdin
  putStrLn l
  loop


import System.IO

main = f stdin
  where f h = do p <- hIsEOF h
                 if p then putStrLn "done"
                      else do l <- hGetLine h
                              putStrLn l
                              f h


-- !!! Test file positioning

module Main(main) where

import Control.Monad
import System.Directory (removeFile, doesFileExist)
import System.IO
import System.IO.Error

main = do
  hIn <- openFile "hGetPosn001.in" ReadMode
  f <- doesFileExist "hGetPosn001.out"
  when f (removeFile "hGetPosn001.out")
  hOut <- openFile "hGetPosn001.out" ReadWriteMode
  bof <- hGetPosn hIn
  putStrLn (show bof)  -- you can show HandlePosns
  copy hIn hOut
  hSetPosn bof
  copy hIn hOut
  hSeek hOut AbsoluteSeek 0
  stuff <- hGetContents hOut
  putStr stuff

copy :: Handle -> Handle -> IO ()
copy hIn hOut =
    tryIOError (hGetChar hIn) >>=
    either (\ err -> if isEOFError err then return () else error "copy")
           ( \ x -> hPutChar hOut x >> copy hIn hOut)


-- !!! hIsEOF (on stdout)

import System.IO ( hIsEOF, stdout )
import System.IO.Error

main = do
  flg <- hIsEOF stdout `catchIOError` \ _ -> putStrLn "hIsEOF failed" >> return False
  print flg


-- !!! test hIsEOF in various buffering situations

import System.IO

main = do
  h <- openFile "hIsEOF002.hs" ReadMode
  hSetBuffering h NoBuffering
  hSeek h SeekFromEnd 0
  hIsEOF h >>= print
  hSeek h SeekFromEnd (-1)
  hIsEOF h >>= print
  hGetChar h >>= print

  hSetBuffering h LineBuffering
  hSeek h SeekFromEnd 0
  hIsEOF h >>= print
  hSeek h SeekFromEnd (-1)
  hIsEOF h >>= print
  hGetChar h >>= print

  hSetBuffering h (BlockBuffering (Just 1))
  hSeek h SeekFromEnd 0
  hIsEOF h >>= print
  hSeek h SeekFromEnd (-1)
  hIsEOF h >>= print
  hGetChar h >>= print

  hSetBuffering h (BlockBuffering Nothing)
  hSeek h SeekFromEnd 0
  hIsEOF h >>= print
  hSeek h SeekFromEnd (-1)
  hIsEOF h >>= print
  hGetChar h >>= print
  hClose h

  h <- openFile "hIsEOF002.out" WriteMode
  hPutStrLn h "hello, world"
  hClose h

  h <- openFile "hIsEOF002.out" ReadWriteMode
  hSetBuffering h NoBuffering
  hSeek h SeekFromEnd 0
  hIsEOF h >>= print
  hPutChar h 'x'
  hIsEOF h >>= print
  hSeek h SeekFromEnd (-1)
  hIsEOF h >>= print
  hGetChar h >>= print


-- !!! hReady test

 -- hReady should throw and EOF exception at the end of a file. Trac #1063.

import System.IO
import System.IO.Error

main = do
 h <- openFile "hReady001.hs" ReadMode
 hReady h >>= print
 hSeek h SeekFromEnd 0
 (hReady h >> return ()) `catchIOError` print


-- test for bug #4078
import System.IO
import Control.Concurrent
import System.Exit

main = do
  m <- newEmptyMVar
  forkIO $ do threadDelay 500000; putMVar m Nothing
  forkIO $ do hReady stdin >>= putMVar m . Just
  takeMVar m >>= print


-- !!! Test seeking

import System.IO

main = do
    h  <- openFile "hSeek001.in" ReadMode
    True <- hIsSeekable h
    hSeek h SeekFromEnd (-1)
    z <- hGetChar h
    putStr (z:"\n")
    hSeek h SeekFromEnd (-3)
    x <- hGetChar h
    putStr (x:"\n")
    hSeek h RelativeSeek (-2)
    w <- hGetChar h
    putStr (w:"\n")
    hSeek h RelativeSeek 2
    z <- hGetChar h
    putStr (z:"\n")
    hSeek h AbsoluteSeek (0)
    a <- hGetChar h
    putStr (a:"\n")
    hSeek h AbsoluteSeek (10)
    k <- hGetChar h
    putStr (k:"\n")
    hSeek h AbsoluteSeek (25)
    z <- hGetChar h
    putStr (z:"\n")
    hClose h


-- !!! Testing EOF (and the clearing of it)

module Main(main) where

import System.IO
import System.Directory ( removeFile )

main :: IO ()
main = do
   hdl <- openFile "hSeek002.hs" ReadMode
   flg <- hIsEOF hdl
   print flg
   hSeek hdl SeekFromEnd 0
   flg <- hIsEOF hdl
   print flg
   hSeek hdl SeekFromEnd (-1)
   flg <- hIsEOF hdl
   print flg
   hGetChar hdl
   flg <- hIsEOF hdl
   print flg
   hSeek hdl SeekFromEnd (-1)
   flg <- hIsEOF hdl
   print flg
   hClose hdl


-- !!! file positions (hGetPosn and hSetPosn)

module Main(main) where

import System.IO
import Control.Monad ( sequence )

testPosns :: Handle -> BufferMode -> IO ()
testPosns hdl bmo = do
   hSetBuffering hdl bmo
   putStrLn ("Testing positioning with buffer mode set to: " ++ show bmo)
   testPositioning hdl

bmo_ls = [NoBuffering, LineBuffering, BlockBuffering Nothing,
          BlockBuffering (Just 511),BlockBuffering (Just 3), BlockBuffering (Just 11)]

main = do
  hdl  <- openFile "hSeek003.hs" ReadMode
  sequence (zipWith testPosns (repeat hdl) bmo_ls)
  hClose hdl

testPositioning hdl = do
  hSeek hdl AbsoluteSeek 0  -- go to the beginning of the file again.
  ps   <- getFilePosns 10 hdl
  hSeek hdl AbsoluteSeek 0
  putStr "First ten chars: "
  ls   <- hGetChars 10 hdl
  putStrLn ls
    -- go to the end
  hSeek hdl SeekFromEnd 0
  ls   <- sequence (map (\ p -> hSetPosn p >> hGetChar hdl) ps)
  putStr "First ten chars: "
  putStrLn ls

    -- position ourselves in the middle.
  sz <- hFileSize hdl
  hSeek hdl AbsoluteSeek (sz `div` 2)
  ls   <- sequence (map (\ p -> hSetPosn p >> hGetChar hdl) ps)
  putStr "First ten chars: "
  putStrLn ls

hGetChars :: Int -> Handle -> IO String
hGetChars n h = sequence (replicate n (hGetChar h))

getFilePosns :: Int -> Handle -> IO [HandlePosn]
getFilePosns 0 h = return []
getFilePosns x h = do
   p <- hGetPosn h
   hGetChar h
   ps <- getFilePosns (x-1) h
   return (p:ps)


-- !!! can't seek an AppendMode handle

import System.IO
import System.IO.Error

main = do
  h <- openFile "hSeek004.out" AppendMode
  tryIOError (hSeek h AbsoluteSeek 0) >>= print


import System.IO

main =
    hSetBuffering stdin NoBuffering     >>
    hSetBuffering stdout NoBuffering    >>
    interact id


-- !!! Reconfiguring the buffering of a handle
module Main(main) where

import System.IO
import System.IO.Error

queryBuffering :: String -> Handle -> IO ()
queryBuffering handle_nm handle = do
  bufm  <- hGetBuffering handle
  putStrLn ("Buffering for " ++ handle_nm ++ " is: " ++ show bufm)

main = do
  queryBuffering "stdin" stdin
  queryBuffering "stdout" stdout
  queryBuffering "stderr" stderr

   -- twiddling the setting for stdin.
  hSetBuffering stdin NoBuffering
  queryBuffering "stdin" stdin
  hSetBuffering stdin LineBuffering
  queryBuffering "stdin" stdin
  hSetBuffering stdin (BlockBuffering (Just 2))
  queryBuffering "stdin" stdin
  hSetBuffering stdin (BlockBuffering Nothing)
  queryBuffering "stdin" stdin
  let bmo = BlockBuffering (Just (-3))
  hSetBuffering stdin bmo `catchIOError` \ _ -> putStrLn ("Caught illegal op: hSetBuffering stdin " ++ showParen True (showsPrec 9 bmo) [])

  putChar '\n'

   -- twiddling the buffering for stdout
  hPutStr stdout "Hello stdout 1"
  hSetBuffering stdout NoBuffering
  queryBuffering "stdout" stdout
  hPutStr stdout "Hello stdout 2"
  hSetBuffering stdout LineBuffering
  queryBuffering "stdout" stdout
  hPutStr stdout "Hello stdout 3"
  hSetBuffering stdout (BlockBuffering (Just 2))
  queryBuffering "stdout" stdout
  hPutStr stdout "Hello stdout 4"
  hSetBuffering stdout (BlockBuffering Nothing)
  queryBuffering "stdout" stdout
  hPutStr stdout "Hello stdout 5"
  let bmo = BlockBuffering (Just (-3))
  hSetBuffering stdout bmo `catchIOError` \ _ -> putStrLn ("Caught illegal op: hSetBuffering stdout " ++ showParen True (showsPrec 9 bmo) [])

  putChar '\n'

   -- twiddling the buffering for stderr
  hPutStr stderr "Hello stderr 1"
  hSetBuffering stderr NoBuffering
  queryBuffering "stderr" stderr
  hPutStr stderr "Hello stderr 2"
  hSetBuffering stderr LineBuffering
  queryBuffering "stderr" stderr
  hPutStr stderr "Hello stderr 3"
  hSetBuffering stderr (BlockBuffering (Just 2))
  queryBuffering "stderr" stderr
  hPutStr stderr "Hello stderr 4"
  hSetBuffering stderr (BlockBuffering Nothing)
  queryBuffering "stderr" stderr
  hPutStr stderr "Hello stderr 5"
  let bmo = BlockBuffering (Just (-3))
  hSetBuffering stderr bmo `catchIOError` \ _ -> putStrLn ("Caught illegal op: hSetBuffering stderr " ++ showParen True (showsPrec 9 bmo) [])

  ls  <- hGetContents stdin
  ls' <- putLine ls
  hSetBuffering stdin NoBuffering
  putLine ls'
  return ()

putLine :: String -> IO String
putLine [] = return []
putLine (x:xs) = do
   putChar x
   case x of
     '\n' -> return xs
     _    -> putLine xs


-- test for #2678
module Main (main) where

import System.IO

main :: IO ()
main = do hSetBuffering stdin NoBuffering
          hLookAhead stdin >>= print
          hSetBuffering stdin LineBuffering
          getContents >>= print


import System.IO
import GHC.IO.Handle
import GHC.IO.Encoding
import System.Environment

-- Test switching encodings
-- The test file is built by the Makefile

main = do
  [file] <- getArgs
  test file NoBuffering
  test file (BlockBuffering Nothing)
  test file (BlockBuffering (Just 5))

test file buf = do
  hSetEncoding stdout utf8
  h <- openBinaryFile file ReadMode
  hSetBuffering stdout buf
  putStrLn "no encoding:"
  getUntilX h
  hSetEncoding h utf8
  putStrLn "UTF8:"
  getUntilX h
  hSetEncoding h utf16le
  putStrLn "UTF16LE:"
  getUntilX h
  hSetEncoding h utf16be
  putStrLn "UTF16BE:"
  getUntilX h
  hSetEncoding h utf16
  putStrLn "UTF16:"
  getUntilX h
  hSetEncoding h utf32
  putStrLn "UTF32:"
  getUntilX h
  hSetEncoding h utf32le
  putStrLn "UTF32LE:"
  getUntilX h
  hSetEncoding h utf32be
  putStrLn "UTF32BE:"
  getUntilX h
  hSetEncoding h utf8_bom
  putStrLn "UTF8-BOM:"
  getUntilX h
  hIsEOF h >>= print

getUntilX h = do
  c <- hGetChar h
  if c == 'X' then return () else do putChar c; getUntilX h


-- test for #4066

import System.IO

import GHC.IO.FD as FD (stdout)
import GHC.IO.Handle.FD as FD (fdToHandle)
import GHC.IO.Handle ( mkDuplexHandle )

main = do
  h <- mkDuplexHandle FD.stdout "stdout" Nothing noNewlineTranslation
  hSetEncoding h utf8
  hPutStrLn h "Ã¶"
  hClose h


-- !!! test ioeGetErrorString

import System.IO
import System.IO.Error
import Data.Maybe

main = do
  h <- openFile "ioeGetErrorString001.hs" ReadMode
  hSeek h SeekFromEnd 0
  (hGetChar h >> return ()) `catchIOError`
        \e -> if isEOFError e
                then print (ioeGetErrorString e)
                else putStrLn "failed."


-- !!! test ioeGetFileName

import System.IO
import System.IO.Error

main = do
  h <- openFile "ioeGetFileName001.hs" ReadMode
  hSeek h SeekFromEnd 0
  (hGetChar h >> return ()) `catchIOError`
        \e -> if isEOFError e
                then print (ioeGetFileName e)
                else putStrLn "failed."


-- !!! test ioeGetHandle

import System.IO
import System.IO.Error
import Data.Maybe

main = do
  h <- openFile "ioeGetHandle001.hs" ReadMode
  hSeek h SeekFromEnd 0
  (hGetChar h >> return ()) `catchIOError`
        \e -> if isEOFError e && fromJust (ioeGetHandle e) == h
                then putStrLn "ok."
                else putStrLn "failed."


import System.IO.Error

-- test for a bug in GHC <= 4.08.2: handles were being left locked after
-- being shown in an error message.
main = do
  getContents
  catchIOError getChar (\e -> print e >> return 'x')
  catchIOError getChar (\e -> print e >> return 'x')


-- !!! IOErrors should have Eq defined

import System.IO

main = print (userError "urk" == userError "urk")


import System.IO

main = isEOF >>= print


import System.IO

import Data.Char          (toUpper)
import System.Directory   (removeFile, doesFileExist)
import System.Environment (getArgs)

main   =  do
  [f1,f2] <- getArgs
  h1 <- openFile f1 ReadMode
  f <- doesFileExist f2
  if f then removeFile f2 else return ()
  h2 <- openFile f2 WriteMode
  copyFile h1 h2
  hClose h1
  hClose h2

copyFile h1 h2 = do
  eof <- hIsEOF h1
  if eof
        then return ()
        else do
  c <- hGetChar h1
  c <- hPutChar h2 (toUpper c)
  copyFile h1 h2


import System.IO
import GHC.IO.Handle
import Control.Monad
import Data.List

newlines = ["\n","\r","\r\n","\n\r","\n\n","\r\r"]

-- make sure the file ends in '\r': that's a tricky case for CRLF
-- conversion, because the IO library has to check whether there's a
-- following \n before returning the \r.
content = concat [ show i ++ t | (i,t) <- zip [1..100] (cycle newlines) ]

filename = "newline001.out"

fromCRLF [] = []
fromCRLF ('\r':'\n':cs) = '\n' : fromCRLF cs
fromCRLF (c:cs) = c : fromCRLF cs

toCRLF [] = []
toCRLF ('\n':cs) = '\r':'\n': toCRLF cs
toCRLF (c:cs) = c : toCRLF cs

main = do
  h <- openBinaryFile filename WriteMode
  hPutStr h content
  hClose h
  testinput NoBuffering
  testinput LineBuffering
  testinput (BlockBuffering Nothing)
  testinput (BlockBuffering (Just 3))
  testinput (BlockBuffering (Just 7))
  testinput (BlockBuffering (Just 16))
  testoutput NoBuffering
  testoutput LineBuffering
  testoutput (BlockBuffering Nothing)
  testoutput (BlockBuffering (Just 3))
  testoutput (BlockBuffering (Just 7))
  testoutput (BlockBuffering (Just 16))

testinput b = do
  h <- openFile filename ReadMode
  hSetBuffering h b
  hSetNewlineMode h noNewlineTranslation
  str <- hGetContents h
  check "in1" b str content
  hClose h

  h <- openFile filename ReadMode
  hSetBuffering h b
  hSetNewlineMode h noNewlineTranslation
  str <- read_chars h
  check "in2" b str content
  hClose h

  h <- openFile filename ReadMode
  hSetBuffering h b
  hSetNewlineMode h noNewlineTranslation
  str <- read_lines h
  check "in3" b str content
  hClose h

  h <- openFile filename ReadMode
  hSetBuffering h b
  hSetNewlineMode h NewlineMode{ inputNL=CRLF, outputNL=LF }
  str <- hGetContents h
  check "in4" b str (fromCRLF content)
  hClose h

  h <- openFile filename ReadMode
  hSetBuffering h b
  hSetNewlineMode h NewlineMode{ inputNL=CRLF, outputNL=LF }
  str <- read_chars  h
  check "in5" b str (fromCRLF content)
  hClose h

  h <- openFile filename ReadMode
  hSetBuffering h b
  hSetNewlineMode h NewlineMode{ inputNL=CRLF, outputNL=LF }
  str <- read_lines  h
  check "in6" b str (fromCRLF content)
  hClose h

testoutput b = do
  h <- openFile filename WriteMode
  hSetBuffering h b
  hSetNewlineMode h NewlineMode{ inputNL=LF, outputNL=CRLF }
  hPutStr h content
  hClose h
  h <- openBinaryFile filename ReadMode
  str <- hGetContents h
  check "out1" b (toCRLF content) str
  hClose h

  h <- openFile filename WriteMode
  hSetBuffering h b
  hSetNewlineMode h NewlineMode{ inputNL=LF, outputNL=CRLF }
  mapM_ (hPutChar h) content
  hClose h
  h <- openBinaryFile filename ReadMode
  str <- hGetContents h
  check "out2" b (toCRLF content) str
  hClose h

check s b str1 str2 = do
  when (str1 /= str2) $ error ("failed: " ++ s ++ ", " ++ show b ++ '\n':show str1 ++ '\n':show str2)

read_chars :: Handle -> IO String
read_chars h = loop h ""
  where loop h acc = do
          b <- hIsEOF h
          if b then return (reverse acc) else do
          c <- hGetChar h
          loop h (c:acc)

read_lines :: Handle -> IO String
read_lines h = loop h []
  where loop h acc = do
          b <- hIsEOF h
          if b then return (intercalate "\n" (reverse acc)) else do
          l <- hGetLine h
          loop h (l : acc)


-- !!! test that a file opened in ReadMode can't be written to

import System.IO
import System.IO.Error

main = do
  hIn <- openFile "openFile001.hs" ReadMode
  hPutStr hIn "test" `catchIOError` \ err ->
      if isIllegalOperation err
        then putStrLn "ok."
        else error "Oh dear\n"


import Data.Char
import System.IO

-- !!! Open a non-existent file for reading (should fail)

main = openFile "nonexistent" ReadMode


import System.Directory
import System.IO
import System.IO.Error

-- !!! Open a directory (should fail)

main = do
  let dir = "openFile003Dir"
  createDirectoryIfMissing False dir
  r <- tryIOError (openFile dir ReadMode)
  print r
  r <- tryIOError (openFile dir WriteMode)
  print r
  r <- tryIOError (openFile dir AppendMode)
  print r
  r <- tryIOError (openFile dir ReadWriteMode)
  print r


-- !!! Open a non-existent file for writing

import Control.Monad
import Data.Char
import System.Directory
import System.IO

file = "openFile004.out"

main = do
  b <- doesFileExist file
  when b (removeFile file)

  h <- openFile file WriteMode
  hPutStr h "hello world\n"
  hClose h

  h <- openFile file ReadMode
  let loop = do
        b <- hIsEOF h
        if b then return ()
             else do c <- hGetChar h; putChar c; loop
  loop


-- !!! test multiple-reader single-writer locking semantics

import System.IO
import System.IO.Error

file1 = "openFile005.out1"
file2 = "openFile005.out2"

main = do
  putStrLn "two writes (should fail)"
  h <- openFile file1 WriteMode
  tryIOError (openFile file1 WriteMode) >>= print
  hClose h

  putStrLn "write and an append (should fail)"
  h <- openFile file1 WriteMode
  tryIOError (openFile file1 AppendMode) >>= print
  hClose h

  putStrLn "read/write and a write (should fail)"
  h <- openFile file1 ReadWriteMode
  tryIOError (openFile file1 WriteMode) >>= print
  hClose h

  putStrLn "read and a read/write (should fail)"
  h <- openFile file1 ReadMode
  tryIOError (openFile file1 ReadWriteMode) >>= print
  hClose h

  putStrLn "write and a read (should fail)"
  h <- openFile file1 WriteMode
  tryIOError (openFile file1 ReadMode) >>= print
  hClose h

  putStrLn "two writes, different files (silly, but should succeed)"
  h1 <- openFile file1 WriteMode
  h2 <- openFile file2 WriteMode
  hClose h1
  hClose h2

  putStrLn "two reads, should succeed"
  h1 <- openFile file1 ReadMode
  h2 <- openFile file1 ReadMode
  hClose h1
  hClose h2


-- !!! opening a file in WriteMode better truncate it

import System.IO

main = do
  h <- openFile "openFile006.out" AppendMode
  hPutStr h "hello, world"
  size <- hFileSize h
  print size
  hClose h

  h <- openFile "openFile006.out" WriteMode
  size <- hFileSize h
  print size


-- !!! check that we don't truncate files if the open fails

import Control.Monad
import System.IO
import System.IO.Error

tmp = "openFile007.out"

main = do
  h <- openFile tmp WriteMode
  hPutStrLn h "hello, world"

  -- second open in write mode better fail, but better not truncate the file
  tryIOError (openFile tmp WriteMode) >>= print

  hClose h
  s <- readFile tmp -- make sure our "hello, world" is still there
  putStr s


import System.IO
import System.Cmd
import System.FilePath
import Text.Printf
import System.Directory
import Control.Monad

testdir = "openFile008_testdir"

-- Test repeated opening/closing of 1000 files.  This is useful for guaging
-- the performance of open/close and file locking.
main = do
  system ("rm -rf " ++ testdir)
  createDirectory testdir
  let filenames = [testdir </> printf "file%03d" (n::Int) | n <- [1..1000]]

  forM_ [1..50] $ \_ -> do
    hs <- mapM (\f -> openFile f WriteMode) filenames
    mapM_ hClose hs

  mapM_ removeFile filenames
  removeDirectory testdir


module Main where

import System.IO
import Control.Exception
import System.Directory

main = bracket
          (openTempFile "." "test.txt")
          (\(f,_) -> removeFile f)
          (\(f,h) -> do hPutStrLn h $ "\xa9" -- Copyright symbol
                        hClose h
                        s <- readFile f
                        if (s /= "\xa9\n") then error ("failed: " ++ s) else return ())


-- !!! Testing output on stdout

-- stdout is buffered, so test if its buffer
-- is flushed upon program termination.

main = putStr "Hello, world\n"


-- !!! readFile test

import System.IO
import System.IO.Error

source   = "readFile001.hs"
filename = "readFile001.out"

main = do
  s <- readFile source
  h <- openFile filename WriteMode
  hPutStrLn h s
  hClose h
  s <- readFile filename

  -- This open should fail, because the readFile hasn't been forced
  -- and the file is therefore still locked.
  tryIOError (openFile filename WriteMode) >>= print

  putStrLn s

  -- should be able to open it for writing now, because we've forced the
  -- whole file.
  h <- openFile filename WriteMode

  print h


-- !!! RW files

module Main(main) where

import System.IO
import System.Directory ( removeFile, doesFileExist )
import Control.Monad

main = do
  f <- doesFileExist "readwrite001.inout"
  when f (removeFile "readwrite001.inout")
  hdl <- openFile "readwrite001.inout" ReadWriteMode
  hSetBuffering hdl LineBuffering
  hPutStr hdl "as"
  hSeek hdl AbsoluteSeek 0
  ch <- hGetChar hdl
  print ch
  hPutStr hdl "ase"
  hSeek hdl AbsoluteSeek 0
  putChar '\n'
  ls <- hGetContents hdl
  putStrLn ls


-- !!! Testing RW handles

import System.IO
import System.IO.Error
import System.Directory (removeFile, doesFileExist)
import Control.Monad
import System.Cmd

-- This test is weird, full marks to whoever dreamt it up!

main :: IO ()
main = do
   let username = "readwrite002.inout"
   f <- doesFileExist username
   when f (removeFile username)
   cd <- openFile username ReadWriteMode

   -- binary mode needed, otherwise newline translation gives
   -- unpredictable results.
   hSetBinaryMode cd True

-- Leva buffering on to make things more interesting:
--   hSetBuffering stdin NoBuffering
--   hSetBuffering stdout NoBuffering
--   hSetBuffering cd NoBuffering
   hPutStr cd speakString
   hSeek cd AbsoluteSeek 0
   speak cd  `catchIOError` \ err -> if isEOFError err then putStrLn "\nCaught EOF" else ioError err
   hSeek cd AbsoluteSeek 0
   hSetBuffering cd LineBuffering
   speak cd  `catchIOError` \ err -> if isEOFError err then putStrLn "\nCaught EOF" else ioError err
   return ()
   hSeek cd AbsoluteSeek 0
   hSetBuffering cd (BlockBuffering Nothing)
   speak cd  `catchIOError` \ err -> if isEOFError err then putStrLn "\nCaught EOF" else ioError err

speakString = "##############################\n"

speak cd = do
     (do
        ready <- hReady cd
        if ready then
           hGetChar cd >>= putChar
         else
           return ()
        ready <- hReady stdin
        if ready then (do { ch <- getChar; hPutChar cd ch})
         else return ())
     speak cd


import System.IO

file = "readwrite003.txt"

main = do
  writeFile file "ab\ncd\nef\ngh"
  h <- openFile file ReadWriteMode
  hGetLine h
  hPutStrLn h "yz"
  hClose h
  h <- openBinaryFile file ReadMode
  hSetNewlineMode stdout noNewlineTranslation
  hGetContents h >>= putStr


{-

Before running this, check that /tmp/test does not exist and
contain something important. Then do:

 $ touch /tmp/test

If you do:

 $ runhaskell Test.hs

it will work. If you do:

 $ runhaskell Test.hs fail

it will fail every time with:

Test.hs: writeFile: /tmp/test: openFile: resource busy (file is locked)

-}

import Control.Monad
import System.Directory
import System.IO
import System.IO.Error
import System.Environment
-- Used by test2:
-- import System.Posix.IO

fp = "T2122-test"

main :: IO ()
main = do
   writeFile fp "test"
   test True

-- fails everytime when causeFailure is True in GHCi, with runhaskell,
-- or when compiled.
test :: Bool -> IO ()
test causeFailure =
    do h1 <- openFile fp ReadMode `catchIOError` (\e -> error ("openFile 1: " ++ show e))
       when causeFailure $ do
         h2 <- openFile fp ReadMode `catchIOError` (\e -> error ("openFile 2: " ++ show e))
         hClose h2
       hClose h1
       removeFile fp
       writeFile fp (show [1..100]) `catchIOError` (\e -> error ("writeFile: " ++ show e))

{-
-- this version never fails (except in GHCi, if test has previously failed).
-- probably because openFd does not try to lock the file
test2 :: Bool -> IO ()
test2 causeFailure =
    do fd1 <- openFd fp ReadOnly defaultFileFlags `catchIOError` (\e -> error ("openFile 1: " ++ show e))
       when causeFailure $ do
         fd2 <- openFd fp ReadOnly defaultFileFlags `catchIOError` (\e -> error ("openFile 2: " ++ show e))
         closeFd fd2
       closeFd fd1
       removeFile fp
       writeFile fp (show [1..100]) `catchIOError` (\e -> error ("writeFile: " ++ show e))
-}

{-
-- fails sometimes when run repeated in GHCi, but seems fine with
-- runhaskell or compiled
test3 :: IO ()
test3 =
    do h1 <- openFile fp ReadMode `catchIOError` (\e -> error ("openFile 1: " ++ show e))
       h2 <- openFile fp ReadMode `catchIOError` (\e -> error ("openFile 2: " ++ show e))
       removeFile fp
       writeFile fp (show [1..100]) `catchIOError` (\e -> error ("writeFile: " ++ show e))
       print =<< hGetContents h1
       print =<< hGetContents h2
       hClose h2
       hClose h1
-}


{-# LANGUAGE OverloadedStrings, DeriveDataTypeable #-}
module Main (main) where

import Control.Applicative
import Control.Concurrent.MVar
import Control.Monad

import Data.ByteString (ByteString)
import qualified Data.ByteString as B
import qualified Data.ByteString.Char8
import Data.ByteString.Char8()
import Data.ByteString.Unsafe as B
import Data.ByteString.Internal (memcpy)
import Data.Typeable (Typeable)
import Data.Word

import Foreign

import GHC.IO.Buffer
import GHC.IO.BufferedIO
import GHC.IO.Device
import GHC.IO.Handle

import System.IO

-- | Create a seakable read-handle from a bytestring
bsHandle :: ByteString -> FilePath -> IO Handle
bsHandle bs fp
    = newBsDevice bs >>= \dev ->
      mkFileHandle dev fp ReadMode Nothing noNewlineTranslation

data BSIODevice
    = BSIODevice
       ByteString
       (MVar Int) -- Position

newBsDevice :: ByteString -> IO BSIODevice
newBsDevice bs = BSIODevice bs <$> newMVar 0

remaining :: BSIODevice -> IO Int
remaining (BSIODevice bs mPos)
    = do
  let bsLen = B.length bs
  withMVar mPos $ \pos -> return (bsLen - pos)

sizeBS :: BSIODevice -> Int
sizeBS (BSIODevice bs _) = B.length bs

seekBS :: BSIODevice -> SeekMode -> Int -> IO ()
seekBS dev AbsoluteSeek pos
    | pos < 0 = error "Cannot seek to a negative position!"
    | pos > sizeBS dev = error "Cannot seek past end of handle!"
    | otherwise = case dev of
                    BSIODevice _ mPos
                        -> modifyMVar_ mPos $ \_ -> return pos
seekBS dev SeekFromEnd pos = seekBS dev AbsoluteSeek (sizeBS dev - pos)
seekBS dev RelativeSeek pos
    = case dev of
        BSIODevice _bs mPos
            -> modifyMVar_ mPos $ \curPos ->
               let newPos = curPos + pos
               in if newPos < 0 || newPos > sizeBS dev
                  then error "Cannot seek outside of handle!"
                  else return newPos

tellBS :: BSIODevice -> IO Int
tellBS (BSIODevice _ mPos) = readMVar mPos

dupBS :: BSIODevice -> IO BSIODevice
dupBS (BSIODevice bs mPos) = BSIODevice bs <$> (readMVar mPos >>= newMVar)

readBS :: BSIODevice -> Ptr Word8 -> Int -> IO Int
readBS dev@(BSIODevice bs mPos) buff amount
    = do
  rem <- remaining dev
  if amount > rem
   then readBS dev buff rem
   else B.unsafeUseAsCString bs $ \ptr ->
       do
         memcpy buff (castPtr ptr) (fromIntegral amount)
         modifyMVar_ mPos (return . (+amount))
         return amount

instance BufferedIO BSIODevice where
    newBuffer dev buffState = newByteBuffer (sizeBS dev) buffState
    fillReadBuffer dev buff = readBuf dev buff
    fillReadBuffer0 dev buff
        = do
      (amount, buff') <- fillReadBuffer dev buff
      return (if amount == 0 then Nothing else Just amount, buff')

instance RawIO BSIODevice where
    read = readBS
    readNonBlocking dev buff n = Just `liftM` readBS dev buff n

instance IODevice BSIODevice where
    ready _ True _ = return False -- read only
    ready _ False _ = return True -- always ready

    close _ = return ()
    isTerminal _ = return False
    isSeekable _ = return True
    seek dev seekMode pos = seekBS dev seekMode (fromIntegral pos)
    tell dev = fromIntegral <$> tellBS dev
    getSize dev = return $ fromIntegral $ sizeBS dev
    setEcho _ _ = error "Not a terminal device"
    getEcho _ = error "Not a terminal device"
    setRaw _ _ = error "Raw mode not supported"
    devType _ = return RegularFile
    dup = dupBS
    dup2 _ _ = error "Dup2 not supported"

main = bsHandle "test" "<fake file>" >>= Data.ByteString.Char8.hGetContents >>= print


import System.IO
import GHC.IO.Handle
import GHC.IO.FD as FD

main = do
  writeFile "T4808.test" "This is some test data"
  (fd, _) <- FD.openFile "T4808.test" ReadWriteMode False
  hdl <- mkDuplexHandle fd "T4808.test" Nothing nativeNewlineMode
  hClose hdl
  (fd2, _) <- FD.openFile "T4808.test" ReadWriteMode False
  print (fdFD fd == fdFD fd2) -- should be True
  hGetLine hdl >>= print -- should fail with an exception


import Debug.Trace

main = trace "æˆ‘çˆ±æˆ‘çš„ç”µè„‘" $ return ()


module Main where
import Foreign.Marshal.Alloc
import System.IO

main = do
  h <- openBinaryFile "T4895.hs" ReadMode
  allocaBytes 10 $ \ptr -> hGetBuf h ptr 10
  some <- allocaBytes 10 $ \ptr -> hGetBufSome h ptr 10
  print some


import qualified Data.ByteString as BS
import System.IO
import GHC.Foreign
import Control.Exception
import Data.Word

decode :: TextEncoding -> BS.ByteString -> IO (Either SomeException String)
decode enc bs = try $ BS.useAsCStringLen bs $ peekCStringLen enc

main :: IO ()
main = mapM_ go [ ["01111111"] -- (just fits into 1 byte)
                , ["11000010", "10000000"] -- (just large enough for 2 bytes)
                , ["11000001", "10111111"] -- (overlong: only 7 bits, so should fit into 1 byte)
                , ["11011111", "10111111"] -- (just fits into 2 bytes)
                , ["11100000", "10100000", "10000000"] -- (just large enough for 3 bytes)
                , ["11100000", "10011111", "10111111"] -- (overlong: only 11 bits, so should fit into 2 bytes)
                , ["11101111", "10111111", "10111111"] -- (just fits into 3 bytes)
                , ["11110000", "10010000", "10000000", "10000000"] -- (just large enough for 4 bytes)
                , ["11110000", "10001111", "10111111", "10111111"] -- (overlong: only 16 bits, so should fit into 3 bytes)
                , ["11110100", "10001111", "10111111", "10111111"] -- (largest allowed codepoint)
                , ["11110111", "10111111", "10111111", "10111111"] -- (just fits into 4 bytes but disallowed by RFC3629)
                ]
  where go xs = decode utf8 (BS.pack (map toByte xs)) >>= either (\_ -> putStrLn "Error") print

toByte :: String -> Word8
toByte [] = 0
toByte ('1':xs) = (2 ^ length xs) + toByte xs
toByte ('0':xs) = toByte xs


module Main(main) where

import Numeric
import Data.Ratio

main = print ((fromRat (132874 % 23849))::Double)


-- Testing showInt, lightly.

module Main(main) where

import Numeric

showSignedInt :: Integral a => a -> String
showSignedInt x = showSigned (showInt) 0 x ""

main =
  do
   putStrLn (showInt (343023920121::Integer) [])
   putStrLn (showInt (3430239::Int) [])
   putStrLn (showInt (1212 :: Int) [])
   putStrLn (showSignedInt (591125662431 `div` (517::Int)))
   -- showInt just works over naturals, wrap it up inside
   -- a use of Numeric.showSigned to show negative nums.
   putStrLn (showSignedInt (-111::Int))
   putStrLn (showInt (232189458241::Integer) [])


-- Testing readInt, lightly.
--
module Main(main) where

import Numeric
import Data.Char

main =
  let
   rd :: ReadS Integer
   rd = readSigned (readInt 10 (isDigit) (digitToInt))
  in
  do
   print (rd (show (343023920121::Integer)))
   print (rd (show (3430239::Int)))
   print (rd (show (1212 :: Int)))
   print (rd (show (591125662431 `div` (517::Int))))
   print (rd (show (-111::Int)))
   print (rd (show (232189458241::Integer)))


-- Exercising Numeric.readSigned a bit
--
module Main(main) where

import Numeric
import Data.Char

main =
  let
   rd :: ReadS Integer
   rd = readSigned (readInt 10 (isDigit) (digitToInt))
  in
  do
   print (rd (show (343023920121::Integer)))
   print (rd (show (3430239::Int)))
   print (rd (show (-0 :: Int)))
   print (rd (show (591125662431 `div` (517::Int))))
   print (rd (show (-111::Int)))
   print (rd (show (232189458241::Integer)))


-- Exercising Numeric.readSigned a bit
--
module Main(main) where

import Numeric

main =
  let
   ls = ["3489348394032498320438240938403","0","-1","1","34323","2L","012","0x23","3243ab"]
   present str f ls =
    sequence (map (\ v -> putStr ('\n':str ++
                                  ' ': v   ++
                                  " = "    ++
                                  (show (f v)))) ls)
  in
  do
   present "(readDec::ReadS Integer)" (readDec::ReadS Integer) ls
   present "(readDec::ReadS Int)"     (readDec::ReadS Int) ls
   present "(readOct::ReadS Integer)" (readOct::ReadS Integer) ls
   present "(readOct::ReadS Int)"     (readOct::ReadS Int) ls
   present "(readHex::ReadS Integer)" (readHex::ReadS Integer) ls
   present "(readHex::ReadS Int)"     (readHex::ReadS Int) ls
   putStrLn ""


-- Exercising the showing of positive numbers at various bases.
--
module Main(main) where

import Numeric
import Data.Char

--showDec :: Integral a => a -> ShowS
showDec = showInt

{-
--showBinary :: Integral a => a -> ShowS
showBinary n r =
 showString "0b" $
 showIntAtBase 2 (toChr) n r
 where toChr d = chr (ord '0' + fromIntegral d)
-}

main =
 do
  print (map (\ x -> showOct x []) [1..32])
  print (map (\ x -> showDec x []) [1..32])
  print (map (\ x -> showHex x []) [1..32])
--  print (map (\ x -> showBinary x []) [1..32])
  putStrLn (showOct (241324784::Int) [])
  putStrLn (showDec (241324784::Int) [])
  putStrLn (showHex (241324784::Int) [])
---  putStrLn (showBinary (241324784::Int) [])


-- Exercising the reading of positive numbers at various bases.
--
module Main(main) where

import Numeric

main =
 do
  putStrLn (show (readOct "00000111"))
  putStrLn (show (readDec "00000111"))
  putStrLn (show (readHex "00000111"))
  putStrLn (show (readOct "-24"))
  putStrLn (show (readDec "-24"))
  putStrLn (show (readHex "-24"))
  putStrLn (show ((readOct ::ReadS Integer) "3248784372843778438743"))
  putStrLn (show ((readDec ::ReadS Integer) "3248784372843778438743"))
  putStrLn (show ((readHex ::ReadS Integer) "3248784372843778438743"))


-- showing/reading floats
--
module Main(main) where

import Numeric

main = do
  let dbls   =  map (shEFloat (Just 7)) doubles
             ++ map (shEFloat (Just 0)) doubles
             ++ map (shEFloat Nothing)  doubles
             ++ map (shFFloat (Just 7)) doubles
             ++ map (shFFloat (Just 0)) doubles
             ++ map (shFFloat Nothing)  doubles
             ++ map (shGFloat (Just 7)) doubles
             ++ map (shGFloat (Just 0)) doubles
             ++ map (shGFloat Nothing)  doubles

      flts   =  map (shEFloat (Just 7)) floats
             ++ map (shEFloat (Just 0)) floats
             ++ map (shEFloat Nothing)  floats
             ++ map (shFFloat (Just 7)) floats
             ++ map (shFFloat (Just 0)) floats
             ++ map (shFFloat Nothing)  floats
             ++ map (shGFloat (Just 7)) floats
             ++ map (shGFloat (Just 0)) floats
             ++ map (shGFloat Nothing)  floats

  putStrLn (unlines dbls)
  putStrLn (unlines flts)
  print (map read dbls :: [Double])
  print (map read flts :: [Double])

shEFloat p f = showEFloat p f ""
shFFloat p f = showFFloat p f ""
shGFloat p f = showGFloat p f ""

doubles :: [ Double ]
doubles = [ 0.0
          , 420
          ,  42
          ,   4.2
          ,   0.42
          ,   0.042
          , 1.82173691287639817263897126389712638972163
          , 1.82173691287639817263897126389712638972163e-300
          ]

floats :: [ Float ]
floats = [ 0.0
          , 420
          ,  42
          ,   4.2
          ,   0.42
          ,   0.042
          , 1.82173691287639817263897126389712638972163
          , 1.82173691287639817263897126389712638972163e-300
          ]


-- trac #2059
--
-- Note that this test fails miserably when compiled to use X87 floating point.
-- For instance, in the case of (sin 1e20) the X86 FSIN instruction doesn't even
-- get the sign right on my machine.

module Main(main) where

import Control.Monad
import Foreign.C

main = do let d = [0, pi, pi/2, pi/3, 1e10, 1e20] :: [Double]
              f = [0, pi, pi/2, pi/3, 1e10, 1e20] :: [Float]
          mapM_ (test "sind" sind sin) d
          mapM_ (test "sinf" sinf sin) f
          mapM_ (test "cosd" cosd cos) d
          mapM_ (test "cosf" cosf cos) f
          mapM_ (test "tand" tand tan) d
          mapM_ (test "tanf" tanf tan) f
          -- added to test #13629
          mapM_ (test "sqrtd" sqrtd sqrt) f
          mapM_ (test "sqrtf" sqrtf sqrt) f
          putStrLn "Done"

test :: (RealFloat a, Floating a, RealFloat b, Floating b, Show b)
     => String -> (a -> a) -> (b -> b) -> b -> IO ()
test s f g x = do let y = realToFrac (f (realToFrac x))
                      z = g x
                  unless (y == z) $ do
                      putStrLn ("uh oh! " ++ s ++ ' ':show x)
                      print y
                      print z
                      print $ decodeFloat y
                      print $ decodeFloat z

foreign import ccall "math.h sin"  sind :: CDouble -> CDouble
foreign import ccall "math.h sinf" sinf :: CFloat  -> CFloat

foreign import ccall "math.h cos"  cosd :: CDouble -> CDouble
foreign import ccall "math.h cosf" cosf :: CFloat  -> CFloat

foreign import ccall "math.h tan"  tand :: CDouble -> CDouble
foreign import ccall "math.h tanf" tanf :: CFloat  -> CFloat

foreign import ccall "math.h sqrt"  sqrtd :: CDouble -> CDouble
foreign import ccall "math.h sqrtf" sqrtf :: CFloat  -> CFloat


main = do
    print (sqrt (-7 :: Double))
    print (sqrt (-7 :: Float))


import System.Exit (exitWith, ExitCode(..))

main = exitWith (ExitFailure 42)


import System.Environment (getProgName, getArgs)

main = do argv0 <- getProgName
          putStr argv0
          argv <- getArgs
          mapM_ (\ x -> putChar ' ' >> putStr x) argv
          putChar '\n'


import System.Environment (getEnv)
import System.IO.Error (catchIOError, isDoesNotExistError)

main :: IO ()
main = do
    term <- getEnv "PATH"
    putStrLn "Got $PATH"
    fish <- getEnv "One fish, two fish, red fish, blue fish" `catchIOError` getEnv_except
    putStrLn fish

getEnv_except :: IOError -> IO String
getEnv_except ioe
 | isDoesNotExistError ioe = return ""
 | otherwise               = ioError ioe


-- Not run on mingw, because of /dev/null use

import System.Cmd (system)
import System.Exit (ExitCode(..), exitWith)

main = do ec <- system "cat dog 1>/dev/null 2>&1"
          case ec of
              ExitSuccess ->
                  do putStr "What?!?\n"
                     ioError (userError "dog succeeded")
              ExitFailure _ ->
                  do ec <- system "cat system001.hs 2>/dev/null"
                     case ec of
                         ExitSuccess ->
                             exitWith ExitSuccess
                         ExitFailure _ ->
                             do putStr "What?!?\n"
                                ioError (userError "cat failed")


import Control.Monad (when)
import Data.Maybe (isJust)
import System.Environment (lookupEnv)

main :: IO ()
main = do
    term <- lookupEnv "PATH"
    when (isJust term) $ putStrLn "Got PATH"
    fish <- lookupEnv "One fish, two fish, red fish, blue fish"
    print fish


-- test for escaping Timeout exceptions, see #7719

import System.Timeout
import Control.Monad
import Control.Concurrent

t d = timeout d $ timeout d $ timeout d $ timeout d $ timeout d $ timeout (10^9) $ threadDelay 100

main = forM_ [1..20] $ \_ -> forM_ [1..40] t


import Text.Printf

main = do
   printf "%.*f\n" (2::Int) ((1/3) :: Double)
   -- (expected: "0.33")

   printf "%.3s\n" "foobar"
   -- (expected: "foo")

   printf "%10.5d\n" (4::Int)
   -- (expected: "     00004")


{-# LANGUAGE Safe #-}
{-# LANGUAGE GADTs #-}

-----------------------------------------------------------------------------
-- |
-- Module      :  Text.Printf
-- Copyright   :  (c) Lennart Augustsson and Bart Massey 2013
-- License     :  BSD-style (see the file LICENSE in this distribution)
--
-- Maintainer  :  Bart Massey <bart@cs.pdx.edu>
-- Stability   :  provisional
-- Portability :  portable
--
-- A C @printf(3)@-like formatter. This version has been
-- extended by Bart Massey as per the recommendations of
-- John Meacham and Simon Marlow
-- <http://comments.gmane.org/gmane.comp.lang.haskell.libraries/4726>
-- to support extensible formatting for new datatypes.  It
-- has also been extended to support almost all C
-- @printf(3)@ syntax.
-----------------------------------------------------------------------------

module Text.Printf(
-- * Printing Functions
   printf, hPrintf,
-- * Extending To New Types
--
-- | This 'printf' can be extended to format types
-- other than those provided for by default. This
-- is done by instantiating 'PrintfArg' and providing
-- a 'formatArg' for the type. It is possible to
-- provide a 'parseFormat' to process type-specific
-- modifiers, but the default instance is usually
-- the best choice.
--
-- For example:
--
-- > instance PrintfArg () where
-- >   formatArg x fmt | fmtChar (vFmt 'U' fmt) == 'U' =
-- >     formatString "()" (fmt { fmtChar = 's', fmtPrecision = Nothing })
-- >   formatArg _ fmt = errorBadFormat $ fmtChar fmt
-- >
-- > main :: IO ()
-- > main = printf "[%-3.1U]\n" ()
--
-- prints \"@[() ]@\". Note the use of 'formatString' to
-- take care of field formatting specifications in a convenient
-- way.
   PrintfArg(..),
   FieldFormatter,
   FieldFormat(..),
   FormatAdjustment(..), FormatSign(..),
   vFmt,
-- ** Handling Type-specific Modifiers
--
-- | In the unlikely case that modifier characters of
-- some kind are desirable for a user-provided type,
-- a 'ModifierParser' can be provided to process these
-- characters. The resulting modifiers will appear in
-- the 'FieldFormat' for use by the type-specific formatter.
   ModifierParser, FormatParse(..),
-- ** Standard Formatters
--
-- | These formatters for standard types are provided for
-- convenience in writting new type-specific formatters:
-- a common pattern is to throw to 'formatString' or
-- 'formatInteger' to do most of the format handling for
-- a new type.
   formatString, formatChar, formatInt,
   formatInteger, formatRealFloat,
-- ** Raising Errors
--
-- | These functions are used internally to raise various
-- errors, and are exported for use by new type-specific
-- formatters.
  errorBadFormat, errorShortFormat, errorMissingArgument,
  errorBadArgument,
  perror,
-- * Implementation Internals
-- | These types are needed for implementing processing
-- variable numbers of arguments to 'printf' and 'hPrintf'.
-- Their implementation is intentionally not visible from
-- this module. If you attempt to pass an argument of a type
-- which is not an instance of the appropriate class to
-- 'printf' or 'hPrintf', then the compiler will report it
-- as a missing instance of 'PrintfArg'.  (All 'PrintfArg'
-- instances are 'PrintfType' instances.)
  PrintfType, HPrintfType,
-- | This class is needed as a Haskell98 compatibility
-- workaround for the lack of FlexibleInstances.
  IsChar(..)
) where

import Data.Char
import Data.Int
import Data.List
import Data.Word
import Numeric
import Numeric.Natural
import System.IO

-------------------

-- | Format a variable number of arguments with the C-style formatting string.
--
-- >>> printf "%s, %d, %.4f" "hello" 123 pi
-- hello, 123, 3.1416
--
-- The return value is either 'String' or @('IO' a)@ (which
-- should be @('IO' ())@, but Haskell's type system
-- makes this hard).
--
-- The format string consists of ordinary characters and
-- /conversion specifications/, which specify how to format
-- one of the arguments to 'printf' in the output string. A
-- format specification is introduced by the @%@ character;
-- this character can be self-escaped into the format string
-- using @%%@. A format specification ends with a
-- /format character/ that provides the primary information about
-- how to format the value. The rest of the conversion
-- specification is optional.  In order, one may have flag
-- characters, a width specifier, a precision specifier, and
-- type-specific modifier characters.
--
-- Unlike C @printf(3)@, the formatting of this 'printf'
-- is driven by the argument type; formatting is type specific. The
-- types formatted by 'printf' \"out of the box\" are:
--
--   * 'Integral' types, including 'Char'
--
--   * 'String'
--
--   * 'RealFloat' types
--
-- 'printf' is also extensible to support other types: see below.
--
-- A conversion specification begins with the
-- character @%@, followed by zero or more of the following flags:
--
-- > -      left adjust (default is right adjust)
-- > +      always use a sign (+ or -) for signed conversions
-- > space  leading space for positive numbers in signed conversions
-- > 0      pad with zeros rather than spaces
-- > #      use an \"alternate form\": see below
--
-- When both flags are given, @-@ overrides @0@ and @+@ overrides space.
-- A negative width specifier in a @*@ conversion is treated as
-- positive but implies the left adjust flag.
--
-- The \"alternate form\" for unsigned radix conversions is
-- as in C @printf(3)@:
--
-- > %o           prefix with a leading 0 if needed
-- > %x           prefix with a leading 0x if nonzero
-- > %X           prefix with a leading 0X if nonzero
-- > %b           prefix with a leading 0b if nonzero
-- > %[eEfFgG]    ensure that the number contains a decimal point
--
-- Any flags are followed optionally by a field width:
--
-- > num    field width
-- > *      as num, but taken from argument list
--
-- The field width is a minimum, not a maximum: it will be
-- expanded as needed to avoid mutilating a value.
--
-- Any field width is followed optionally by a precision:
--
-- > .num   precision
-- > .      same as .0
-- > .*     as num, but taken from argument list
--
-- Negative precision is taken as 0. The meaning of the
-- precision depends on the conversion type.
--
-- > Integral    minimum number of digits to show
-- > RealFloat   number of digits after the decimal point
-- > String      maximum number of characters
--
-- The precision for Integral types is accomplished by zero-padding.
-- If both precision and zero-pad are given for an Integral field,
-- the zero-pad is ignored.
--
-- Any precision is followed optionally for Integral types
-- by a width modifier; the only use of this modifier being
-- to set the implicit size of the operand for conversion of
-- a negative operand to unsigned:
--
-- > hh     Int8
-- > h      Int16
-- > l      Int32
-- > ll     Int64
-- > L      Int64
--
-- The specification ends with a format character:
--
-- > c      character               Integral
-- > d      decimal                 Integral
-- > o      octal                   Integral
-- > x      hexadecimal             Integral
-- > X      hexadecimal             Integral
-- > b      binary                  Integral
-- > u      unsigned decimal        Integral
-- > f      floating point          RealFloat
-- > F      floating point          RealFloat
-- > g      general format float    RealFloat
-- > G      general format float    RealFloat
-- > e      exponent format float   RealFloat
-- > E      exponent format float   RealFloat
-- > s      string                  String
-- > v      default format          any type
--
-- The \"%v\" specifier is provided for all built-in types,
-- and should be provided for user-defined type formatters
-- as well. It picks a \"best\" representation for the given
-- type. For the built-in types the \"%v\" specifier is
-- converted as follows:
--
-- > c      Char
-- > u      other unsigned Integral
-- > d      other signed Integral
-- > g      RealFloat
-- > s      String
--
-- Mismatch between the argument types and the format
-- string, as well as any other syntactic or semantic errors
-- in the format string, will cause an exception to be
-- thrown at runtime.
--
-- Note that the formatting for 'RealFloat' types is
-- currently a bit different from that of C @printf(3)@,
-- conforming instead to 'Numeric.showEFloat',
-- 'Numeric.showFFloat' and 'Numeric.showGFloat' (and their
-- alternate versions 'Numeric.showFFloatAlt' and
-- 'Numeric.showGFloatAlt'). This is hard to fix: the fixed
-- versions would format in a backward-incompatible way.
-- In any case the Haskell behavior is generally more
-- sensible than the C behavior.  A brief summary of some
-- key differences:
--
-- * Haskell 'printf' never uses the default \"6-digit\" precision
--   used by C printf.
--
-- * Haskell 'printf' treats the \"precision\" specifier as
--   indicating the number of digits after the decimal point.
--
-- * Haskell 'printf' prints the exponent of e-format
--   numbers without a gratuitous plus sign, and with the
--   minimum possible number of digits.
--
-- * Haskell 'printf' will place a zero after a decimal point when
--   possible.
printf :: (PrintfType r) => String -> r
printf fmts = spr fmts []

-- | Similar to 'printf', except that output is via the specified
-- 'Handle'.  The return type is restricted to @('IO' a)@.
hPrintf :: (HPrintfType r) => Handle -> String -> r
hPrintf hdl fmts = hspr hdl fmts []

-- |The 'PrintfType' class provides the variable argument magic for
-- 'printf'.  Its implementation is intentionally not visible from
-- this module. If you attempt to pass an argument of a type which
-- is not an instance of this class to 'printf' or 'hPrintf', then
-- the compiler will report it as a missing instance of 'PrintfArg'.
class PrintfType t where
    spr :: String -> [UPrintf] -> t

-- | The 'HPrintfType' class provides the variable argument magic for
-- 'hPrintf'.  Its implementation is intentionally not visible from
-- this module.
class HPrintfType t where
    hspr :: Handle -> String -> [UPrintf] -> t

{- not allowed in Haskell 2010
instance PrintfType String where
    spr fmt args = uprintf fmt (reverse args)
-}
-- | @since 2.01
instance (IsChar c) => PrintfType [c] where
    spr fmts args = map fromChar (uprintf fmts (reverse args))

-- Note that this should really be (IO ()), but GHC's
-- type system won't readily let us say that without
-- bringing the GADTs. So we go conditional for these defs.

-- | @since 4.7.0.0
instance (a ~ ()) => PrintfType (IO a) where
    spr fmts args =
        putStr $ map fromChar $ uprintf fmts $ reverse args

-- | @since 4.7.0.0
instance (a ~ ()) => HPrintfType (IO a) where
    hspr hdl fmts args = do
        hPutStr hdl (uprintf fmts (reverse args))

-- | @since 2.01
instance (PrintfArg a, PrintfType r) => PrintfType (a -> r) where
    spr fmts args = \ a -> spr fmts
                             ((parseFormat a, formatArg a) : args)

-- | @since 2.01
instance (PrintfArg a, HPrintfType r) => HPrintfType (a -> r) where
    hspr hdl fmts args = \ a -> hspr hdl fmts
                                  ((parseFormat a, formatArg a) : args)

-- | Typeclass of 'printf'-formattable values. The 'formatArg' method
-- takes a value and a field format descriptor and either fails due
-- to a bad descriptor or produces a 'ShowS' as the result. The
-- default 'parseFormat' expects no modifiers: this is the normal
-- case. Minimal instance: 'formatArg'.
class PrintfArg a where
    -- | @since 4.7.0.0
    formatArg :: a -> FieldFormatter
    -- | @since 4.7.0.0
    parseFormat :: a -> ModifierParser
    parseFormat _ (c : cs) = FormatParse "" c cs
    parseFormat _ "" = errorShortFormat

-- | @since 2.01
instance PrintfArg Char where
    formatArg = formatChar
    parseFormat _ cf = parseIntFormat (undefined :: Int) cf

-- | @since 2.01
instance (IsChar c) => PrintfArg [c] where
    formatArg = formatString

-- | @since 2.01
instance PrintfArg Int where
    formatArg = formatInt
    parseFormat = parseIntFormat

-- | @since 2.01
instance PrintfArg Int8 where
    formatArg = formatInt
    parseFormat = parseIntFormat

-- | @since 2.01
instance PrintfArg Int16 where
    formatArg = formatInt
    parseFormat = parseIntFormat

-- | @since 2.01
instance PrintfArg Int32 where
    formatArg = formatInt
    parseFormat = parseIntFormat

-- | @since 2.01
instance PrintfArg Int64 where
    formatArg = formatInt
    parseFormat = parseIntFormat

-- | @since 2.01
instance PrintfArg Word where
    formatArg = formatInt
    parseFormat = parseIntFormat

-- | @since 2.01
instance PrintfArg Word8 where
    formatArg = formatInt
    parseFormat = parseIntFormat

-- | @since 2.01
instance PrintfArg Word16 where
    formatArg = formatInt
    parseFormat = parseIntFormat

-- | @since 2.01
instance PrintfArg Word32 where
    formatArg = formatInt
    parseFormat = parseIntFormat

-- | @since 2.01
instance PrintfArg Word64 where
    formatArg = formatInt
    parseFormat = parseIntFormat

-- | @since 2.01
instance PrintfArg Integer where
    formatArg = formatInteger
    parseFormat = parseIntFormat

-- | @since 4.8.0.0
instance PrintfArg Natural where
    formatArg = formatInteger . toInteger
    parseFormat = parseIntFormat

-- | @since 2.01
instance PrintfArg Float where
    formatArg = formatRealFloat

-- | @since 2.01
instance PrintfArg Double where
    formatArg = formatRealFloat

-- | This class, with only the one instance, is used as
-- a workaround for the fact that 'String', as a concrete
-- type, is not allowable as a typeclass instance. 'IsChar'
-- is exported for backward-compatibility.
class IsChar c where
    -- | @since 4.7.0.0
    toChar :: c -> Char
    -- | @since 4.7.0.0
    fromChar :: Char -> c

-- | @since 2.01
instance IsChar Char where
    toChar c = c
    fromChar c = c

-------------------

-- | Whether to left-adjust or zero-pad a field. These are
-- mutually exclusive, with 'LeftAdjust' taking precedence.
--
-- @since 4.7.0.0
data FormatAdjustment = LeftAdjust | ZeroPad

-- | How to handle the sign of a numeric field.  These are
-- mutually exclusive, with 'SignPlus' taking precedence.
--
-- @since 4.7.0.0
data FormatSign = SignPlus | SignSpace

-- | Description of field formatting for 'formatArg'. See UNIX @printf(3)@
-- for a description of how field formatting works.
--
-- @since 4.7.0.0
data FieldFormat = FieldFormat {
  fmtWidth :: Maybe Int,       -- ^ Total width of the field.
  fmtPrecision :: Maybe Int,   -- ^ Secondary field width specifier.
  fmtAdjust :: Maybe FormatAdjustment,  -- ^ Kind of filling or padding
                                        --   to be done.
  fmtSign :: Maybe FormatSign, -- ^ Whether to insist on a
                               -- plus sign for positive
                               -- numbers.
  fmtAlternate :: Bool,        -- ^ Indicates an "alternate
                               -- format".  See @printf(3)@
                               -- for the details, which
                               -- vary by argument spec.
  fmtModifiers :: String,      -- ^ Characters that appeared
                               -- immediately to the left of
                               -- 'fmtChar' in the format
                               -- and were accepted by the
                               -- type's 'parseFormat'.
                               -- Normally the empty string.
  fmtChar :: Char              -- ^ The format character
                               -- 'printf' was invoked
                               -- with. 'formatArg' should
                               -- fail unless this character
                               -- matches the type. It is
                               -- normal to handle many
                               -- different format
                               -- characters for a single
                               -- type.
  }

-- | The \"format parser\" walks over argument-type-specific
-- modifier characters to find the primary format character.
-- This is the type of its result.
--
-- @since 4.7.0.0
data FormatParse = FormatParse {
  fpModifiers :: String,   -- ^ Any modifiers found.
  fpChar :: Char,          -- ^ Primary format character.
  fpRest :: String         -- ^ Rest of the format string.
  }

-- Contains the "modifier letters" that can precede an
-- integer type.
intModifierMap :: [(String, Integer)]
intModifierMap = [
  ("hh", toInteger (minBound :: Int8)),
  ("h", toInteger (minBound :: Int16)),
  ("l", toInteger (minBound :: Int32)),
  ("ll", toInteger (minBound :: Int64)),
  ("L", toInteger (minBound :: Int64)) ]

parseIntFormat :: a -> String -> FormatParse
parseIntFormat _ s =
  case foldr matchPrefix Nothing intModifierMap of
    Just m -> m
    Nothing ->
      case s of
        c : cs -> FormatParse "" c cs
        "" -> errorShortFormat
  where
    matchPrefix (p, _) m@(Just (FormatParse p0 _ _))
      | length p0 >= length p = m
      | otherwise = case getFormat p of
          Nothing -> m
          Just fp -> Just fp
    matchPrefix (p, _) Nothing =
      getFormat p
    getFormat p =
      stripPrefix p s >>= fp
      where
        fp (c : cs) = Just $ FormatParse p c cs
        fp "" = errorShortFormat

-- | This is the type of a field formatter reified over its
-- argument.
--
-- @since 4.7.0.0
type FieldFormatter = FieldFormat -> ShowS

-- | Type of a function that will parse modifier characters
-- from the format string.
--
-- @since 4.7.0.0
type ModifierParser = String -> FormatParse

-- | Substitute a \'v\' format character with the given
-- default format character in the 'FieldFormat'. A
-- convenience for user-implemented types, which should
-- support \"%v\".
--
-- @since 4.7.0.0
vFmt :: Char -> FieldFormat -> FieldFormat
vFmt c ufmt@(FieldFormat {fmtChar = 'v'}) = ufmt {fmtChar = c}
vFmt _ ufmt = ufmt

-- | Formatter for 'Char' values.
--
-- @since 4.7.0.0
formatChar :: Char -> FieldFormatter
formatChar x ufmt =
  formatIntegral (Just 0) (toInteger $ ord x) $ vFmt 'c' ufmt

-- | Formatter for 'String' values.
--
-- @since 4.7.0.0
formatString :: IsChar a => [a] -> FieldFormatter
formatString x ufmt =
  case fmtChar $ vFmt 's' ufmt of
    's' -> map toChar . (adjust ufmt ("", ts) ++)
           where
             ts = map toChar $ trunc $ fmtPrecision ufmt
               where
                 trunc Nothing = x
                 trunc (Just n) = take n x
    c   -> errorBadFormat c

-- Possibly apply the int modifiers to get a new
-- int width for conversion.
fixupMods :: FieldFormat -> Maybe Integer -> Maybe Integer
fixupMods ufmt m =
  let mods = fmtModifiers ufmt in
  case mods of
    "" -> m
    _ -> case lookup mods intModifierMap of
      Just m0 -> Just m0
      Nothing -> perror "unknown format modifier"

-- | Formatter for 'Int' values.
--
-- @since 4.7.0.0
formatInt :: (Integral a, Bounded a) => a -> FieldFormatter
formatInt x ufmt =
  let lb = toInteger $ minBound `asTypeOf` x
      m = fixupMods ufmt (Just lb)
      ufmt' = case lb of
        0 -> vFmt 'u' ufmt
        _ -> ufmt
  in
  formatIntegral m (toInteger x) ufmt'

-- | Formatter for 'Integer' values.
--
-- @since 4.7.0.0
formatInteger :: Integer -> FieldFormatter
formatInteger x ufmt =
  let m = fixupMods ufmt Nothing in
  formatIntegral m x ufmt

-- All formatting for integral types is handled
-- consistently.  The only difference is between Integer and
-- bounded types; this difference is handled by the 'm'
-- argument containing the lower bound.
formatIntegral :: Maybe Integer -> Integer -> FieldFormatter
formatIntegral m x ufmt0 =
  let prec = fmtPrecision ufmt0 in
  case fmtChar ufmt of
    'd' -> (adjustSigned ufmt (fmti prec x) ++)
    'i' -> (adjustSigned ufmt (fmti prec x) ++)
    'x' -> (adjust ufmt (fmtu 16 (alt "0x" x) prec m x) ++)
    'X' -> (adjust ufmt (upcase $ fmtu 16 (alt "0X" x) prec m x) ++)
    'b' -> (adjust ufmt (fmtu 2 (alt "0b" x) prec m x) ++)
    'o' -> (adjust ufmt (fmtu 8 (alt "0" x) prec m x) ++)
    'u' -> (adjust ufmt (fmtu 10 Nothing prec m x) ++)
    'c' | x >= fromIntegral (ord (minBound :: Char)) &&
          x <= fromIntegral (ord (maxBound :: Char)) &&
          fmtPrecision ufmt == Nothing &&
          fmtModifiers ufmt == "" ->
            formatString [chr $ fromIntegral x] (ufmt { fmtChar = 's' })
    'c' -> perror "illegal char conversion"
    c   -> errorBadFormat c
  where
    ufmt = vFmt 'd' $ case ufmt0 of
      FieldFormat { fmtPrecision = Just _, fmtAdjust = Just ZeroPad } ->
        ufmt0 { fmtAdjust = Nothing }
      _ -> ufmt0
    alt _ 0 = Nothing
    alt p _ = case fmtAlternate ufmt of
      True -> Just p
      False -> Nothing
    upcase (s1, s2) = (s1, map toUpper s2)

-- | Formatter for 'RealFloat' values.
--
-- @since 4.7.0.0
formatRealFloat :: RealFloat a => a -> FieldFormatter
formatRealFloat x ufmt =
  let c = fmtChar $ vFmt 'g' ufmt
      prec = fmtPrecision ufmt
      alt = fmtAlternate ufmt
  in
   case c of
     'e' -> (adjustSigned ufmt (dfmt c prec alt x) ++)
     'E' -> (adjustSigned ufmt (dfmt c prec alt x) ++)
     'f' -> (adjustSigned ufmt (dfmt c prec alt x) ++)
     'F' -> (adjustSigned ufmt (dfmt c prec alt x) ++)
     'g' -> (adjustSigned ufmt (dfmt c prec alt x) ++)
     'G' -> (adjustSigned ufmt (dfmt c prec alt x) ++)
     _   -> errorBadFormat c

-- This is the type carried around for arguments in
-- the varargs code.
type UPrintf = (ModifierParser, FieldFormatter)

-- Given a format string and a list of formatting functions
-- (the actual argument value having already been baked into
-- each of these functions before delivery), return the
-- actual formatted text string.
uprintf :: String -> [UPrintf] -> String
uprintf s us = uprintfs s us ""

-- This function does the actual work, producing a ShowS
-- instead of a string, for future expansion and for
-- misguided efficiency.
uprintfs :: String -> [UPrintf] -> ShowS
uprintfs ""       []       = id
uprintfs ""       (_:_)    = errorShortFormat
uprintfs ('%':'%':cs) us   = ('%' :) . uprintfs cs us
uprintfs ('%':_)  []       = errorMissingArgument
uprintfs ('%':cs) us@(_:_) = fmt cs us
uprintfs (c:cs)   us       = (c :) . uprintfs cs us

-- Given a suffix of the format string starting just after
-- the percent sign, and the list of remaining unprocessed
-- arguments in the form described above, format the portion
-- of the output described by this field description, and
-- then continue with 'uprintfs'.
fmt :: String -> [UPrintf] -> ShowS
fmt cs0 us0 =
  case getSpecs False False Nothing False cs0 us0 of
    (_, _, []) -> errorMissingArgument
    (ufmt, cs, (_, u) : us) -> u ufmt . uprintfs cs us

-- Given field formatting information, and a tuple
-- consisting of a prefix (for example, a minus sign) that
-- is supposed to go before the argument value and a string
-- representing the value, return the properly padded and
-- formatted result.
adjust :: FieldFormat -> (String, String) -> String
adjust ufmt (pre, str) =
  let naturalWidth = length pre + length str
      zero = case fmtAdjust ufmt of
        Just ZeroPad -> True
        _ -> False
      left = case fmtAdjust ufmt of
        Just LeftAdjust -> True
        _ -> False
      fill = case fmtWidth ufmt of
        Just width | naturalWidth < width ->
          let fillchar = if zero then '0' else ' ' in
          replicate (width - naturalWidth) fillchar
        _ -> ""
  in
   if left
   then pre ++ str ++ fill
   else if zero
        then pre ++ fill ++ str
        else fill ++ pre ++ str

-- For positive numbers with an explicit sign field ("+" or
-- " "), adjust accordingly.
adjustSigned :: FieldFormat -> (String, String) -> String
adjustSigned ufmt@(FieldFormat {fmtSign = Just SignPlus}) ("", str) =
  adjust ufmt ("+", str)
adjustSigned ufmt@(FieldFormat {fmtSign = Just SignSpace}) ("", str) =
  adjust ufmt (" ", str)
adjustSigned ufmt ps =
  adjust ufmt ps

-- Format a signed integer in the "default" fashion.
-- This will be subjected to adjust subsequently.
fmti :: Maybe Int -> Integer -> (String, String)
fmti prec i
  | i < 0 = ("-", integral_prec prec (show (-i)))
  | otherwise = ("", integral_prec prec (show i))

-- Format an unsigned integer in the "default" fashion.
-- This will be subjected to adjust subsequently.  The 'b'
-- argument is the base, the 'pre' argument is the prefix,
-- and the '(Just m)' argument is the implicit lower-bound
-- size of the operand for conversion from signed to
-- unsigned. Thus, this function will refuse to convert an
-- unbounded negative integer to an unsigned string.
fmtu :: Integer -> Maybe String -> Maybe Int -> Maybe Integer -> Integer
     -> (String, String)
fmtu b (Just pre) prec m i =
  let ("", s) = fmtu b Nothing prec m i in
  case pre of
    "0" -> case s of
      '0' : _ -> ("", s)
      _ -> (pre, s)
    _ -> (pre, s)
fmtu b Nothing prec0 m0 i0 =
  case fmtu' prec0 m0 i0 of
    Just s -> ("", s)
    Nothing -> errorBadArgument
  where
    fmtu' :: Maybe Int -> Maybe Integer -> Integer -> Maybe String
    fmtu' prec (Just m) i | i < 0 =
      fmtu' prec Nothing (-2 * m + i)
    fmtu' (Just prec) _ i | i >= 0 =
      fmap (integral_prec (Just prec)) $ fmtu' Nothing Nothing i
    fmtu' Nothing _ i | i >= 0 =
      Just $ showIntAtBase b intToDigit i ""
    fmtu' _ _ _ = Nothing

-- This is used by 'fmtu' and 'fmti' to zero-pad an
-- int-string to a required precision.
integral_prec :: Maybe Int -> String -> String
integral_prec Nothing integral = integral
integral_prec (Just 0) "0" = ""
integral_prec (Just prec) integral =
  replicate (prec - length integral) '0' ++ integral

stoi :: String -> (Int, String)
stoi cs =
  let (as, cs') = span isDigit cs in
  case as of
    "" -> (0, cs')
    _ -> (read as, cs')

-- Figure out the FormatAdjustment, given:
--   width, precision, left-adjust, zero-fill
adjustment :: Maybe Int -> Maybe a -> Bool -> Bool
           -> Maybe FormatAdjustment
adjustment w p l z =
  case w of
    Just n | n < 0 -> adjl p True z
    _ -> adjl p l z
  where
    adjl _ True _ = Just LeftAdjust
    adjl _ False True = Just ZeroPad
    adjl _ _ _ = Nothing

-- Parse the various format controls to get a format specification.
getSpecs :: Bool -> Bool -> Maybe FormatSign -> Bool -> String -> [UPrintf]
         -> (FieldFormat, String, [UPrintf])
getSpecs _ z s a ('-' : cs0) us = getSpecs True z s a cs0 us
getSpecs l z _ a ('+' : cs0) us = getSpecs l z (Just SignPlus) a cs0 us
getSpecs l z s a (' ' : cs0) us =
  getSpecs l z ss a cs0 us
  where
    ss = case s of
      Just SignPlus -> Just SignPlus
      _ -> Just SignSpace
getSpecs l _ s a ('0' : cs0) us = getSpecs l True s a cs0 us
getSpecs l z s _ ('#' : cs0) us = getSpecs l z s True cs0 us
getSpecs l z s a ('*' : cs0) us =
  let (us', n) = getStar us
      ((p, cs''), us'') = case cs0 of
        '.':'*':r ->
          let (us''', p') = getStar us' in ((Just p', r), us''')
        '.':r ->
          let (p', r') = stoi r in ((Just p', r'), us')
        _ ->
          ((Nothing, cs0), us')
      FormatParse ms c cs =
        case us'' of
          (ufmt, _) : _ -> ufmt cs''
          [] -> errorMissingArgument
  in
   (FieldFormat {
       fmtWidth = Just (abs n),
       fmtPrecision = p,
       fmtAdjust = adjustment (Just n) p l z,
       fmtSign = s,
       fmtAlternate = a,
       fmtModifiers = ms,
       fmtChar = c}, cs, us'')
getSpecs l z s a ('.' : cs0) us =
  let ((p, cs'), us') = case cs0 of
        '*':cs'' -> let (us'', p') = getStar us in ((p', cs''), us'')
        _ ->        (stoi cs0, us)
      FormatParse ms c cs =
        case us' of
          (ufmt, _) : _ -> ufmt cs'
          [] -> errorMissingArgument
  in
   (FieldFormat {
       fmtWidth = Nothing,
       fmtPrecision = Just p,
       fmtAdjust = adjustment Nothing (Just p) l z,
       fmtSign = s,
       fmtAlternate = a,
       fmtModifiers = ms,
       fmtChar = c}, cs, us')
getSpecs l z s a cs0@(c0 : _) us | isDigit c0 =
  let (n, cs') = stoi cs0
      ((p, cs''), us') = case cs' of
        '.' : '*' : r ->
          let (us'', p') = getStar us in ((Just p', r), us'')
        '.' : r ->
          let (p', r') = stoi r in ((Just p', r'), us)
        _ ->
          ((Nothing, cs'), us)
      FormatParse ms c cs =
        case us' of
          (ufmt, _) : _ -> ufmt cs''
          [] -> errorMissingArgument
  in
   (FieldFormat {
       fmtWidth = Just (abs n),
       fmtPrecision = p,
       fmtAdjust = adjustment (Just n) p l z,
       fmtSign = s,
       fmtAlternate = a,
       fmtModifiers = ms,
       fmtChar = c}, cs, us')
getSpecs l z s a cs0@(_ : _) us =
  let FormatParse ms c cs =
        case us of
          (ufmt, _) : _ -> ufmt cs0
          [] -> errorMissingArgument
  in
   (FieldFormat {
       fmtWidth = Nothing,
       fmtPrecision = Nothing,
       fmtAdjust = adjustment Nothing Nothing l z,
       fmtSign = s,
       fmtAlternate = a,
       fmtModifiers = ms,
       fmtChar = c}, cs, us)
getSpecs _ _ _ _ ""       _  =
  errorShortFormat

-- Process a star argument in a format specification.
getStar :: [UPrintf] -> ([UPrintf], Int)
getStar us =
  let ufmt = FieldFormat {
        fmtWidth = Nothing,
        fmtPrecision = Nothing,
        fmtAdjust = Nothing,
        fmtSign = Nothing,
        fmtAlternate = False,
        fmtModifiers = "",
        fmtChar = 'd' } in
  case us of
    [] -> errorMissingArgument
    (_, nu) : us' -> (us', read (nu ufmt ""))

-- Format a RealFloat value.
dfmt :: (RealFloat a) => Char -> Maybe Int -> Bool -> a -> (String, String)
dfmt c p a d =
  let caseConvert = if isUpper c then map toUpper else id
      showFunction = case toLower c of
        'e' -> showEFloat
        'f' -> if a then showFFloatAlt else showFFloat
        'g' -> if a then showGFloatAlt else showGFloat
        _   -> perror "internal error: impossible dfmt"
      result = caseConvert $ showFunction p d ""
  in
   case result of
     '-' : cs -> ("-", cs)
     cs       -> ("" , cs)

-- | Raises an 'error' with a printf-specific prefix on the
-- message string.
--
-- @since 4.7.0.0
perror :: String -> a
perror s = errorWithoutStackTrace $ "printf: " ++ s

-- | Calls 'perror' to indicate an unknown format letter for
-- a given type.
--
-- @since 4.7.0.0
errorBadFormat :: Char -> a
errorBadFormat c = perror $ "bad formatting char " ++ show c

errorShortFormat, errorMissingArgument, errorBadArgument :: a
-- | Calls 'perror' to indicate that the format string ended
-- early.
--
-- @since 4.7.0.0
errorShortFormat = perror "formatting string ended prematurely"
-- | Calls 'perror' to indicate that there is a missing
-- argument in the argument list.
--
-- @since 4.7.0.0
errorMissingArgument = perror "argument list ended prematurely"
-- | Calls 'perror' to indicate that there is a type
-- error or similar in the given argument.
--
-- @since 4.7.0.0
errorBadArgument = perror "bad argument"


{-# LANGUAGE Trustworthy #-}
{-# LANGUAGE NoImplicitPrelude #-}

-----------------------------------------------------------------------------
-- |
-- Module      :  Text.Read
-- Copyright   :  (c) The University of Glasgow 2001
-- License     :  BSD-style (see the file libraries/base/LICENSE)
--
-- Maintainer  :  libraries@haskell.org
-- Stability   :  provisional
-- Portability :  non-portable (uses Text.ParserCombinators.ReadP)
--
-- Converting strings to values.
--
-- The "Text.Read" library is the canonical library to import for
-- 'Read'-class facilities.  For GHC only, it offers an extended and much
-- improved 'Read' class, which constitutes a proposed alternative to the
-- Haskell 2010 'Read'.  In particular, writing parsers is easier, and
-- the parsers are much more efficient.
--
-----------------------------------------------------------------------------

module Text.Read (
   -- * The 'Read' class
   Read(..),
   ReadS,

   -- * Haskell 2010 functions
   reads,
   read,
   readParen,
   lex,

   -- * New parsing functions
   module Text.ParserCombinators.ReadPrec,
   L.Lexeme(..),
   lexP,
   parens,
   readListDefault,
   readListPrecDefault,
   readEither,
   readMaybe

 ) where

import GHC.Base
import GHC.Read
import Data.Either
import Text.ParserCombinators.ReadP as P
import Text.ParserCombinators.ReadPrec
import qualified Text.Read.Lex as L

------------------------------------------------------------------------
-- utility functions

-- | equivalent to 'readsPrec' with a precedence of 0.
reads :: Read a => ReadS a
reads = readsPrec minPrec

-- | Parse a string using the 'Read' instance.
-- Succeeds if there is exactly one valid result.
-- A 'Left' value indicates a parse error.
--
-- >>> readEither "123" :: Either String Int
-- Right 123
--
-- >>> readEither "hello" :: Either String Int
-- Left "Prelude.read: no parse"
--
-- @since 4.6.0.0
readEither :: Read a => String -> Either String a
readEither s =
  case [ x | (x,"") <- readPrec_to_S read' minPrec s ] of
    [x] -> Right x
    []  -> Left "Prelude.read: no parse"
    _   -> Left "Prelude.read: ambiguous parse"
 where
  read' =
    do x <- readPrec
       lift P.skipSpaces
       return x

-- | Parse a string using the 'Read' instance.
-- Succeeds if there is exactly one valid result.
--
-- >>> readMaybe "123" :: Maybe Int
-- Just 123
--
-- >>> readMaybe "hello" :: Maybe Int
-- Nothing
--
-- @since 4.6.0.0
readMaybe :: Read a => String -> Maybe a
readMaybe s = case readEither s of
                Left _  -> Nothing
                Right a -> Just a

-- | The 'read' function reads input from a string, which must be
-- completely consumed by the input process. 'read' fails with an 'error' if the
-- parse is unsuccessful, and it is therefore discouraged from being used in
-- real applications. Use 'readMaybe' or 'readEither' for safe alternatives.
--
-- >>> read "123" :: Int
-- 123
--
-- >>> read "hello" :: Int
-- *** Exception: Prelude.read: no parse
read :: Read a => String -> a
read s = either errorWithoutStackTrace id (readEither s)


{-# LANGUAGE Safe #-}
{-# LANGUAGE NoImplicitPrelude #-}

-----------------------------------------------------------------------------
-- |
-- Module      :  Text.Show
-- Copyright   :  (c) The University of Glasgow 2001
-- License     :  BSD-style (see the file libraries/base/LICENSE)
--
-- Maintainer  :  libraries@haskell.org
-- Stability   :  provisional
-- Portability :  portable
--
-- Converting values to readable strings:
-- the 'Show' class and associated functions.
--
-----------------------------------------------------------------------------

module Text.Show (
   ShowS,
   Show(showsPrec, show, showList),
   shows,
   showChar,
   showString,
   showParen,
   showListWith,
 ) where

import GHC.Show

-- | Show a list (using square brackets and commas), given a function
-- for showing elements.
showListWith :: (a -> ShowS) -> [a] -> ShowS
showListWith = showList__