{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE CPP #-}
module Main where
import Prelude hiding (foldr, foldl, foldl', foldr1, foldl1, length, null, sum,
                       product, all, any, and, or)
import Data.Foldable
import Control.Exception
import Data.Array
import Data.Foldable
import Data.Typeable
import Data.Either
import Control.Applicative
import Control.DeepSeq
#if __GLASGOW_HASKELL__ < 709
import qualified Data.List as L
#else
import qualified GHC.List as L
#endif

data BadElementException = BadFirst | BadLast deriving (Show, Eq)
instance Exception BadElementException

newtype ForceDefault f a = ForceDefault (f a)
instance Foldable f => Foldable (ForceDefault f) where
  foldMap f (ForceDefault c) = foldMap f c

goodLists, badFronts, badBacks :: [[Integer]]
goodLists = [[0..n] | n <- [(-1)..5]]
badFronts = map (throw BadFirst :) goodLists
badBacks  = map (++ [throw BadLast]) goodLists
doubleBads = map (\l -> throw BadFirst : l ++ [throw BadLast]) goodLists
lists =
        goodLists
        ++ badFronts
        ++ badBacks
        ++ doubleBads

makeArray xs = array (1::Int, length xs) (zip [1..] xs)

arrays = map makeArray lists
goodArrays = map makeArray goodLists

strictCons x y = x + 10*y
rightLazyCons x y = x
leftLazyCons x y = y

conses :: [Integer -> Integer -> Integer]
conses = [(+), strictCons, rightLazyCons, leftLazyCons]

runOneRight :: forall f . Foldable f =>
                             (forall a b . (a -> b -> b) -> b -> f a -> b) ->
                             (Integer -> Integer -> Integer) -> f Integer ->
                             IO (Either BadElementException Integer)
runOneRight fol f container = try (evaluate (fol f 12 container))

runOne1 :: forall f . Foldable f => (forall a . (a -> a -> a) -> f a -> a) ->
                              (Integer -> Integer -> Integer) -> f Integer ->
                              IO (Either BadElementException Integer)
runOne1 fol f container = try (evaluate (fol f container))

runOneLeft :: forall f . Foldable f =>
                             (forall a b . (b -> a -> b) -> b -> f a -> b) ->
                              (Integer -> Integer -> Integer) -> f Integer ->
                              IO (Either BadElementException Integer)
runOneLeft fol f container = try (evaluate (fol f 13 container))

runWithAllRight :: forall f . Foldable f =>
                          (forall a b . (a -> b -> b) -> b -> f a -> b) ->
                          [f Integer] -> IO [Either BadElementException Integer]
runWithAllRight fol containers =
       mapM (uncurry (runOneRight fol)) [(f,c) | f <- conses, c <- containers]

runWithAll1 :: forall f . Foldable f =>
                        (forall a . (a -> a -> a) -> f a -> a) ->
                        [f Integer] -> IO [Either BadElementException Integer]
runWithAll1 fol containers =
          mapM (uncurry (runOne1 fol)) [(f,c) | f <- conses, c <- containers]

runWithAllLeft :: forall f . Foldable f =>
                          (forall a b . (b -> a -> b) -> b -> f a -> b) ->
                          [f Integer] -> IO [Either BadElementException Integer]
runWithAllLeft fol containers = mapM (uncurry (runOneLeft fol))
                              [(f,c) | f <- map flip conses, c <- containers]

testWithAllRight :: forall f . Foldable f =>
                 (forall a b . (a -> b -> b) -> b -> f a -> b) ->
                  (forall a b . (a -> b -> b) -> b -> ForceDefault f a -> b) ->
                   [f Integer] -> IO Bool
testWithAllRight fol1 fol2 containers = (==) <$>
       runWithAllRight fol1 containers <*>
           runWithAllRight fol2 (map ForceDefault containers)

testWithAllLeft :: forall f . Foldable f =>
                   (forall a b . (b -> a -> b) -> b -> f a -> b) ->
                   (forall a b . (b -> a -> b) -> b -> ForceDefault f a -> b) ->
                       [f Integer] -> IO Bool
testWithAllLeft fol1 fol2 containers = (==) <$>
      runWithAllLeft fol1 containers <*>
         runWithAllLeft fol2 (map ForceDefault containers)

testWithAll1 :: forall f . Foldable f =>
                        (forall a . (a -> a -> a) -> f a -> a) ->
                        (forall a . (a -> a -> a) -> ForceDefault f a -> a) ->
                                               [f Integer] -> IO Bool
testWithAll1 fol1 fol2 containers =
  (==) <$> runWithAll1 fol1 containers
            <*> runWithAll1 fol2 (map ForceDefault containers)

checkup f g cs = map f cs == map g (map ForceDefault cs)

main = do
         testWithAllRight foldr foldr arrays >>= print
         testWithAllRight foldr' foldr' arrays >>= print
         testWithAllLeft foldl foldl arrays >>= print
         testWithAllLeft foldl' foldl' arrays >>= print
         testWithAll1 foldl1 foldl1 (filter (not . null) arrays) >>= print
         testWithAll1 foldr1 foldr1 (filter (not . null) arrays) >>= print
         -- we won't bother with the fancy laziness tests for the rest
         print $ checkup length length goodArrays
         print $ checkup sum sum goodArrays
         print $ checkup product product goodArrays
         print $ checkup maximum maximum $ filter (not . null) goodArrays
         print $ checkup minimum minimum $ filter (not . null) goodArrays
         print $ checkup toList toList goodArrays
         print $ checkup null null arrays


module Main where

-- Trac #15559: Add HasCallStack to fromJust

import Data.Maybe ( fromJust )

main :: IO ()
main = do
  _ <- fromJust Nothing `seq` return ()
  putStrLn "Should see a stacktrace instead of this"


-- Test infix operators of 'Functor'

import Data.Functor

main :: IO ()
main = do
        testInfixFmap
        testFlippedInfixFmap
        testInfixReplace
        testFlippedInfixReplace

testInfixFmap :: IO ()
testInfixFmap = do
        print "<$> tests:"
        print $ (+ 1) <$> Just 2 -- => Just 3
        print (((+ 1) <$> Right 3) :: Either Int Int) -- => Right 4
        print $ (+ 1) <$> [1, 2, 3] -- => [2,3,4]

testFlippedInfixFmap :: IO ()
testFlippedInfixFmap = do
        print "<&> tests:"
        print $ Just 2 <&> (+ 1) -- => Just 3
        print ((Right 3 <&> (+ 1)) :: Either Int Int) -- => Right 4
        print $ [1, 2, 3] <&> (+ 1) -- => [2,3,4]

testInfixReplace :: IO ()
testInfixReplace = do
        print "<$ tests:"
        print $ 42 <$ Just 1 -- => Just 42
        print ((42 <$ Right 1) :: Either Int Int) -- => Right 42
        print $ 42 <$ [1, 2, 3] -- => [42,42,42]

testFlippedInfixReplace :: IO ()
testFlippedInfixReplace = do
        print "$> tests:"
        print $ Just 1 $> 42 -- => Just 42
        print ((Right 1 $> 42) :: Either Int Int) -- => Right 42
        print $ [1, 2, 3] $> 42 -- => [42,42,42]


-- Test for http://ghc.haskell.org/trac/ghc/ticket/2533
import System.Environment
import Data.List
main = do
 (n:_) <- getArgs
 print (genericTake (read n) "none taken")
 print (genericDrop (read n) "none dropped")
 print (genericSplitAt (read n) "none split")


import System.IO
import Foreign
import Foreign.C

main = do test True; test False

test blocking = do
  h <- openBinaryFile "hGetBuf002.hs" ReadMode

  let sz = 42
      loop = do
         b <- allocaBytes sz $ \ptr -> do
                r <- (if blocking then hGetBuf else hGetBufNonBlocking) h ptr sz
                if (r == 0)
                   then return True
                   else do s <- peekCStringLen (ptr,r)
                           putStr s
                           return False
         if b then return () else loop -- tail call

  loop


import System.IO
import Foreign
import Foreign.C
import Control.Monad

main = do test True; test False

test blocking = do
  h <- openBinaryFile "hGetBuf003.hs" ReadMode

  let sz = 42
      loop = do
         -- mix ordinary char buffering with hGetBuf
         eof <- hIsEOF h
         when (not eof) $ hGetChar h >>= putChar
         b <- allocaBytes sz $ \ptr -> do
                r <- (if blocking then hGetBuf else hGetBufNonBlocking) h ptr sz
                if (r == 0)
                   then return True
                   else do s <- peekCStringLen (ptr,r)
                           putStr s
                           return False
         if b then return () else loop -- tail call

  loop


import System.IO
import Foreign
import Foreign.C

main = do
  hSetBinaryMode stdout True
  withCStringLen "hello world\n" $ \(ptr,len) -> hPutBuf stdout ptr len


import System.IO
import Foreign
import Foreign.C

-- !!! this test failed to write anything in GHC 5.00.2
main = do
  h <- openBinaryFile "hPutBuf002.out" ReadWriteMode
  withCStringLen "hello world\n" $ \(ptr,len) -> hPutBuf h ptr len
  hFileSize h >>= print


-- !!! Testing hGetPosn and hSetPosn
module Main(main) where

import System.IO

getPosnAndPrint h = do
  x <- hTell h
  v <- hGetChar h
  putStrLn ("At position: " ++ show x ++ ", found: " ++ show v)
  return x

recordDoAndRepos h a = do
  x <- getPosnAndPrint h
  a
  hSeek h AbsoluteSeek x
  getPosnAndPrint h
  return ()

recordDoAndRepos2 h a = do
  x <- getPosnAndPrint h
  a
  hSeek h AbsoluteSeek x
  getPosnAndPrint h
  return ()

recordDoAndRepos3 h a = do
  x <- getPosnAndPrint h
  a
  hSeek h SeekFromEnd (negate (x + 1))
  getPosnAndPrint h
  return ()

file = "hTell001.hs"

main :: IO ()
main = do
  h  <- openBinaryFile file ReadMode
  recordDoAndRepos h $
   recordDoAndRepos h $
    recordDoAndRepos h $
     recordDoAndRepos h $
      recordDoAndRepos h $
       putStrLn ""
  hClose h
  putStrLn "\nUsing hSeek/AbsoluteSeek: "
  h  <- openBinaryFile file ReadMode
  recordDoAndRepos2 h $
   recordDoAndRepos2 h $
    recordDoAndRepos2 h $
     recordDoAndRepos2 h $
      recordDoAndRepos2 h $
       putStrLn ""

  hClose h
  putStrLn "\nUsing hSeek/SeekFromEnd: "
  putStrLn "(Don't worry if you're seeing differing numbers here, it might be down to '\\n' vs '\\r\\n')"
  h  <- openBinaryFile file ReadMode
  recordDoAndRepos3 h $
   recordDoAndRepos3 h $
    recordDoAndRepos3 h $
     recordDoAndRepos3 h $
      recordDoAndRepos3 h $
       putStrLn ""


-- !!! Testing hSeek
module Main(main) where

import System.Directory
import System.IO

main :: IO ()
main = do
  h <- openFile "tst-seek" WriteMode
  hSetEncoding h utf8 -- hSeek/hTell work with Unicode streams
  hPutStr h "test string1"
   -- seek to EOF should be cool..
  hSeek h SeekFromEnd 0
  hPutStr h "test string2"
   -- seek past EOF should now also be cool..
  hSeek h SeekFromEnd 3
  hPutStr h "test string3"
  hSeek h AbsoluteSeek 13
  hPutStr h "test string4"
  x <- hTell h
  print x
  hSeek h AbsoluteSeek 30
  x1 <- hTell h
  hPutStr h "äººé–“è™«" -- we should be able to output Unicode too
  x2 <- hTell h
  print (x2 - x1)
  hPutStr h "filler"
  hClose h
  h <- openFile "tst-seek" ReadMode
  hSetEncoding h utf8
  str <- hGetContents h
  putStrLn str
  removeFile "tst-seek"


import Control.Concurrent
import Control.Monad
import GHC.Clock
import System.IO
import System.Posix.IO
import System.Timeout

main :: IO ()
main = do
    (readPipe, _) <- createPipe
    readPipeHandle <- fdToHandle readPipe
    let nanoSecondsPerSecond = 1000 * 1000 * 1000
    let milliSecondsPerSecond = 1000
    let timeToSpend = 1
    let timeToSpendNano = timeToSpend * nanoSecondsPerSecond
    let timeToSpendMilli = timeToSpend * milliSecondsPerSecond
    start <- getMonotonicTimeNSec
    b <- hWaitForInput readPipeHandle timeToSpendMilli
    end <- getMonotonicTimeNSec
    let timeSpentNano = fromIntegral $ end - start
    let delta = timeSpentNano - timeToSpendNano
    -- We can never wait for a shorter amount of time than specified
    putStrLn $ "delta >= 0: " ++ show (delta > 0)


import Control.Concurrent
import Control.Monad
import Foreign.C
import GHC.Clock
import GHC.IO.Device
import GHC.IO.Handle.FD
import System.IO
import System.Posix.IO
import System.Posix.Types
import System.Timeout

main :: IO ()
main = do
    socketHandle <- makeTestSocketHandle
    let nanoSecondsPerSecond = 1000 * 1000 * 1000
    let milliSecondsPerSecond = 1000
    let timeToSpend = 1
    let timeToSpendNano = timeToSpend * nanoSecondsPerSecond
    let timeToSpendMilli = timeToSpend * milliSecondsPerSecond
    start <- getMonotonicTimeNSec
    b <- hWaitForInput socketHandle timeToSpendMilli
    end <- getMonotonicTimeNSec
    let timeSpentNano = fromIntegral $ end - start
    let delta = timeSpentNano - timeToSpendNano
    -- We can never wait for a shorter amount of time than specified
    putStrLn $ "delta >= 0: " ++ show (delta >= 0)

foreign import ccall unsafe "socket" c_socket ::
               CInt -> CInt -> CInt -> IO CInt

makeTestSocketHandle :: IO Handle
makeTestSocketHandle = do
    sockNum <-
        c_socket
            1 -- PF_LOCAL
            2 -- SOCK_DGRAM
            0
    let fd = fromIntegral sockNum :: Fd
    h <-
        fdToHandle'
            (fromIntegral fd)
            (Just GHC.IO.Device.Stream)
            True
            "testsocket"
            ReadMode
            True
    hSetBuffering h NoBuffering
    pure h


{-# LANGUAGE CPP #-}

import Control.Concurrent
import Control.Monad
import GHC.Clock
import System.Environment
import System.Exit
import System.IO
import System.Process
import System.Timeout

-- IMPORTANT: Re-run this test _manually_ on windows if/when you change
-- the code in `libraries/base/cbits/inputReady.c` that mentions
-- `FILE_TYPE_CHAR`. Only when you run the code manually, in cmd.exe
-- or PowerShell, does this code path get activated.
-- Running this code in mintty does not count.
main :: IO ()
main = do
    args <- getArgs
    case args of
        [] -> do
            let cp =
                    (shell
                         ((if isLinuxHost
                               then ("./" ++)
                               else id)
                              "hWaitForInput-accurate-stdin --read-from-stdin"))
                        {std_in = CreatePipe}
            (_, _, _, ph) <- createProcess cp
            waitForProcess ph >>= exitWith
        ("--read-from-stdin":_) -> do
            let nanoSecondsPerSecond = 1000 * 1000 * 1000
            let milliSecondsPerSecond = 1000
            let timeToSpend = 1
            let timeToSpendNano = timeToSpend * nanoSecondsPerSecond
            let timeToSpendMilli = timeToSpend * milliSecondsPerSecond
            start <- getMonotonicTimeNSec
            b <- hWaitForInput stdin timeToSpendMilli
            end <- getMonotonicTimeNSec
            let timeSpentNano = fromIntegral $ end - start
            let delta = timeSpentNano - timeToSpendNano
            -- We can never wait for a shorter amount of time than specified
            putStrLn $ "delta >= 0: " ++ show (delta >= 0)
        _ -> error "should not happen."

isLinuxHost :: Bool
#if defined(mingw32_HOST_OS)
isLinuxHost = False
#else
isLinuxHost = True
#endif


{-# LANGUAGE RankNTypes #-}
module Main (main) where

import Data.List

-- A simple implementation of inits that should be obviously correct.
{-# NOINLINE initsR #-}
initsR :: [a] -> [[a]]
initsR = map reverse . scanl (flip (:)) []

-- The inits implementation added in 7.10 uses a queue rotated around
-- powers of 2, starting the rotation only at size 255, so we want to check
-- around powers of 2 and around the switch.
ranges :: [Int]
ranges = [0..20] ++ [252..259] ++ [508..515]

simple :: (forall a . [a] -> [[a]]) -> [[[Int]]]
simple impl = [impl [1..n] | n <- ranges]

-- We want inits (xs ++ undefined) = inits xs ++ undefined
laziness :: Bool
laziness = [take (n+1) (inits $ [1..n] ++ undefined) | n <- ranges]
              == simple inits

main :: IO ()
main | simple initsR /= simple inits = error "inits failed simple test"
     | not laziness = error "inits failed laziness test"
     | otherwise = return ()


module Main where

import Data.IORef

loop r 0 = return ()
loop r c = loop r (c-1) >> writeIORef r 42

main = newIORef 0 >>= \r -> loop r 1000000 >> putStrLn "done"


module Main (main) where
import Data.List

needles = ["","1","2","12","123","1234"]
haystacks = ["","a","ab","abc","1","2","3","a1","1a",
             "23","123","a123","ab123","abc123"]

main :: IO()
main = mapM_ print $ [needle `isSuffixOf` haystack
                       | needle <- needles, haystack <- haystacks]


import Data.Ix
import Data.Int

main = print (index (minBound::Int16,maxBound) maxBound)


import Data.STRef.Lazy
import Control.Monad.ST.Lazy as L
import Control.Monad.ST.Strict as S
import qualified Data.STRef as S
import Data.Function (fix)
import System.IO (hPutStrLn, stderr)
import Debug.Trace (trace)

-- The following implements `fix` using lazy `ST`. It is based on code
-- by Oleg Kiselyov (source: http://okmij.org/ftp/Haskell/Fix.hs) which is
-- in the public domain according to the main page (http://okmij.org/ftp/).

fact :: (Int -> Int) -> Int -> Int
fact self 0 = 1
fact self n = n * self (pred n)

-- Test liftM style (Oleg's original style)
fix1 :: (a -> a) -> a
fix1 f = L.runST $ do
  wrap <- newSTRef (error "black hole")
  let aux = readSTRef wrap >>= (\x -> x >>= pure . f)
  writeSTRef wrap aux
  aux

-- Test fmap style
fix2 :: (a -> a) -> a
fix2 f = L.runST $ do
  wrap <- newSTRef (error "black hole")
  let aux = readSTRef wrap >>= \x -> f <$> x
  writeSTRef wrap aux
  aux

-- The following examples are by Albert Y. C. Lai, and included (under the
-- GHC license) with his permission:
-- https://mail.haskell.org/pipermail/haskell-cafe/2017-January/126182.html

example1 :: [Int]
example1 = L.runST go where
  go = do
    v <- strictToLazyST (S.newSTRef 0)
    fix (\loop -> do
            n <- strictToLazyST (do n <- S.readSTRef v
                                    S.writeSTRef v (n+1)
                                    return n
                                )
            ns <- loop
            return (n : ns))

example2 :: [Int]
example2 = L.runST main where
  main = do
    v <- strictToLazyST (S.newSTRef 0)
    sequence (repeat (strictToLazyST (do n <- S.readSTRef v
                                         S.writeSTRef v (n+1)
                                         return n
                                     )))

example3 :: L.ST s [Integer]
example3 = do
    r <- newSTRef 0
    let loop = do
            x <- readSTRef r
            writeSTRef r $ x + 1
            xs <- loop
            writeSTRef r $ x + 2
            return $ x : xs
    loop

example4 :: L.ST s [Integer]
example4 = do
    r <- newSTRef 0
    let loop = do
            x <- readSTRef r
            writeSTRef r $ x + 1
            xs <- loop
            error "this line is dead code"
            return $ x : xs
    loop

star n s = trace ("<" ++ s ++ show n ++ ">") (return ())

-- Albert called this "Sprinkle sprinkle little stars, how
-- I wonder when you are"
example5 :: L.ST s [Integer]
example5 = do
    star 0 "init begin"
    r <- newSTRef 0
    star 0 "init end"
    let loop n = do
            star n "A"
            x <- readSTRef r
            star n "B"
            writeSTRef r $ x + 1
            star n "C"
            xs <- loop (n+1)
            star n "D"
            writeSTRef r $ x + 2
            star n "E"
            return $ x : xs
    loop 0

main :: IO ()
main = do
  print $ fix1 fact 5
  print $ fix2 fact 6
  print $ take 5 example1
  print $ take 5 example2
  print $ take 10 (L.runST example3)
  print $ take 10 (L.runST example4)
  hPutStrLn stderr $ show (take 5 (L.runST example5))


module Main (main) where

import Data.List

main :: IO ()
main = do print (genericLength [1..10000000] :: Int)
          print (genericLength [1..10000000] :: Integer)


module Main where

import Text.ParserCombinators.ReadP
import qualified Text.Read.Lex

testStrings
 = [    "0x3y",
        "0X3abx",
        "0o39y",
        "0O334z",

        "NaN",
        "NaNx",
        "Infinity",
        "Infinityx",

        "Wibble Foo",
        "Wibble8_+",

        "34yy",
        "34.4x",
        "034.4x",
        "31.45e-6y",
        "49.2v",
        "049.2v",
        "35e-3x",
        "035e-3x",
        "35e+3y",
        "83.3e-22",
        "083.3e-22"
   ]

main = mapM test testStrings

test s = do print s
            print (lex s)
            print (readP_to_S Text.Read.Lex.lex s)
            putStrLn ""


{-# LANGUAGE CPP #-}
module Main where

import Data.List
import Control.Exception

-- This module briefly tests all the functions in PrelList and a few
-- from List.

-- ToDo: test strictness properties.

main = do

  -- head
  print (head [1,2,3,4], head "a")
  catch (print (head [] :: String)) (\(ErrorCall _) -> putStr "head []\n")

  -- tail
  print (tail [1,2,3,4], tail "a")
  catch (print (tail [] :: String)) (\(ErrorCall _) -> putStr "tail []\n")

  -- init
  print (init [1,2,3,4], init "a")
  catch (print (init [] :: String)) (\(ErrorCall _) -> putStr "init []\n")

  -- last
  print (last [1,2,3,4], last "a")
  catch (print (last [] :: String)) (\(ErrorCall _) -> putStr "last []\n")

  -- null
  print [null [], null "abc"]

  -- length
  print (length [1..10])

  -- foldl
  print (foldl  (+) 1 [1..10])

  -- foldl1
  print (foldl1 (+) [1..10])
  catch (print (foldl1 (+) [] :: Int)) (\(ErrorCall _) -> putStr "foldl1 []\n")

  -- scanl
  print (scanl  (+) 1 [1..10])

  -- scanl1
  print (scanl1 (+) [1..10])
  print (scanl1 (+) [] :: [Int])

  -- foldr1
  print (foldr1 (+) [1..10])
  catch (print (foldr1 (+) [] :: Int)) (\(ErrorCall _) -> putStr "foldr1 []\n")

  -- scanr
  print (scanr  (+) 1 [1..10])

  -- scanr1
  print (scanr1 (+) [1..10])
  print (scanr1 (+) [] :: [Int])

  -- iterate
  print (take 10 (cycle (take 4 (iterate (+1) 1))))

  -- take
  print (take 4 (repeat "x"), take 0 (repeat "x"), take 5 [1..4])
  catch (print (take (-1) [1..10])) (\(ErrorCall _) -> putStr "take (-1)\n")

  -- replicate
  print [replicate 2 "abc", replicate 0 "abc", replicate 3 []]

  -- drop
  print [drop 5 [1..10], drop 0 [1..10], drop 5 [1..4]]
  catch (print (drop (-1) [1..10])) (\(ErrorCall _) -> putStr "drop (-1)\n")

  -- splitAt
  print [splitAt 5 [1..10], splitAt 5 [1..4]]
  catch (print (splitAt (-1) [1..10])) (\(ErrorCall _) -> putStr "splitAt (-1)\n")

  -- scan
  print (span (<5) [1..10])

  -- break
  print (break (<5) [1..10])

  -- reverse
  print [reverse [1..10], reverse []]

  -- and
  print [and [], and [True], and [False]]

  -- or
  print [or [], or [True], or [False]]

  -- elem
  print [elem 5 [1..10], elem 0 [1..10], elem 1 []]

  -- notElem
  print [notElem 5 [1..10], notElem 0 [1..10], notElem 1 []]

  -- lookkup
  print (lookup 4 (zip [1..10] (reverse [1..10])))

  -- sum
  print [sum [1..10], sum []]

  -- product
  print [product [1..10], product []]

  -- maximum
  print (maximum [1..10])
  catch (print (maximum [] :: Int)) (\(ErrorCall _) -> putStr "maximum []\n")

  -- minimum
  print (minimum [1..10])
  catch (print (minimum [] :: Int)) (\(ErrorCall _) -> putStr "minimum []\n")

  -- concatMap
  print (concatMap (:[]) [(1::Int)..10])

  -- zip
  print [zip [1] [2], zip [1] [], zip [] [2], zip [1..5] [2..6]]

  -- zip3
  print (zip3 [1,2] [3,4] [5,6])

  -- zipWith
  print [zipWith (+) [1,2] [3,4], zipWith (+) [1] [], zipWith (+) [] []]

  -- unzip
  print [unzip [(1,2),(3,4)], unzip []]

  -- unzip3
  print [unzip3 [(1,2,3),(3,4,5)], unzip3 []]

  -- unlines
  print (unlines (lines "a\nb\nc\n"), lines "", unlines [])

  -- words
  print (unwords (words "a b c d"),   words "", unwords [])

  -- deleteBy
  print [deleteBy (==) 1 [0,1,1,2,3,4],
         deleteBy (==) (error "deleteBy") []]

  -- delete
  print [delete 1 [0,1,1,2,3,4],
         delete (error "delete") []]

  -- (\\)
  print [ [0,1,1,2,3,4] \\ [3,2,1],
          [1,2,3,4] \\ [],
          [] \\ [error "\\\\"] ]


-- !!! Test that List.sortBy is stable.

import Data.List

main = print (sortBy (\(a,b) (a',b')->compare a a')
                ([1,1,1,1,1,1,1,1,1,1]`zip`[1..10]))


-- !!! Test that length doesn't give a stack overflow

module Main (main) where

main :: IO ()
main = print $ length $ filter odd [0 .. 9999999]


module Main(main) where

import Memo1

testMemo = do
   let keys = [ [1..n] | n <- [1..1000] ]
       keys2 = [ [n,n-1..1] | n <- [1..1000] ]
       mlength = memo length
   putStr (show (map mlength (keys ++ keys ++ keys2 ++ keys2)))
   putStr (show (mlength [1..100000]))

-- mlength will memoize itself over each element of 'keys', returning
-- the memoized result the second time around.  Then we move onto
-- keys2, and while we're doing this the first lot of memo table
-- entries can be purged.  Finally, we do a large computation
-- (length [1..10000]) to allow time for the memo table to be fully
-- purged.

main = testMemo


module Main where

import Memo2              ( memo )
import Data.List          ( genericLength, genericReplicate )
import System.Environment ( getArgs )

main :: IO ()
main = do (arg:_) <- getArgs
          mapM_ printTriple [ (i,fib i,mfib i) | i <- [10..read arg] ]
  where printTriple (i,fi,mfi) = do print i
                                    print fi
                                    print mfi
                                    putStrLn ""

-- There is not much point in memoising Integers, so we use unary "numbers" instead
mfib :: Integer -> Integer
mfib = genericLength . mfib' . flip genericReplicate ()

mfib' :: [()] -> [()]
mfib' = memo ufib

ufib :: [()] -> [()]
ufib []              = [()]
ufib [()]            = [()]
ufib (():n1@(():n2)) = mfib' n1 ++ mfib' n2

fib :: Integer -> Integer
fib 0 = 1
fib 1 = 1
fib n = fib (n-1) + fib (n-2)


% $Id: Memo.lhs,v 1.1 2005/12/16 10:46:05 simonmar Exp $
%
% (c) The GHC Team, 1999
%
% Hashing memo tables.

\begin{code}

module Memo1
        ( memo          -- :: (a -> b) -> a -> b
        , memoSized     -- :: Int -> (a -> b) -> a -> b
        )
        where

import System.Mem.StableName    ( StableName, makeStableName, hashStableName )
import System.Mem.Weak          ( Weak, mkWeakPtr, mkWeak, deRefWeak, finalize )
import Data.Array.IO            ( IOArray, newArray, readArray, writeArray )
import System.IO.Unsafe         ( unsafePerformIO )
import Control.Concurrent.MVar  ( MVar, newMVar, putMVar, takeMVar )
\end{code}

-----------------------------------------------------------------------------
Memo table representation.

The representation is this: a fixed-size hash table where each bucket
is a list of table entries, of the form (key,value).

The key in this case is (StableName key), and we use hashStableName to
hash it.

It's important that we can garbage collect old entries in the table
when the key is no longer reachable in the heap.  Hence the value part
of each table entry is (Weak val), where the weak pointer "key" is the
key for our memo table, and 'val' is the value of this memo table
entry.  When the key becomes unreachable, a finalizer will fire and
remove this entry from the hash bucket, and further attempts to
dereference the weak pointer will return Nothing.  References from
'val' to the key are ignored (see the semantics of weak pointers in
the documentation).

\begin{code}
type MemoTable key val
        = MVar (
            Int,        -- current table size
            IOArray Int [MemoEntry key val]   -- hash table
           )

-- a memo table entry: compile with -funbox-strict-fields to eliminate
-- the boxes around the StableName and Weak fields.
data MemoEntry key val = MemoEntry !(StableName key) !(Weak val)
\end{code}

We use an MVar to the hash table, so that several threads may safely
access it concurrently.  This includes the finalization threads that
remove entries from the table.

ToDo: Can efficiency be improved at all?

\begin{code}
memo :: (a -> b) -> a -> b
memo f = memoSized default_table_size f

default_table_size = 1001

-- Our memo functions are *strict*.  Lazy memo functions tend to be
-- less useful because it is less likely you'll get a memo table hit
-- for a thunk.  This change was made to match Hugs's Memo
-- implementation, and as the result of feedback from Conal Elliot
-- <conal@microsoft.com>.

memoSized :: Int -> (a -> b) -> a -> b
memoSized size f = strict (lazyMemoSized size f)

strict = ($!)

lazyMemoSized :: Int -> (a -> b) -> a -> b
lazyMemoSized size f =
   let (table,weak) = unsafePerformIO (
                do { tbl <- newArray (0,size) []
                   ; mvar <- newMVar (size,tbl)
                   ; weak <- mkWeakPtr mvar (Just (table_finalizer tbl size))
                   ; return (mvar,weak)
                   })
   in  memo' f table weak

table_finalizer :: IOArray Int [MemoEntry key val] -> Int -> IO ()
table_finalizer table size =
   sequence_ [ finalizeBucket i | i <- [0..size] ]
 where
   finalizeBucket i = do
      bucket <- readArray table i
      sequence_ [ finalize w | MemoEntry _ w <- bucket ]

memo' :: (a -> b) -> MemoTable a b -> Weak (MemoTable a b) -> a -> b
memo' f ref weak_ref = \k -> unsafePerformIO $ do
   stable_key <- makeStableName k
   (size, table) <- takeMVar ref
   let hash_key = hashStableName stable_key `mod` size
   bucket <- readArray table hash_key
   lkp <- lookupSN stable_key bucket

   case lkp of
     Just result -> do
        putMVar ref (size,table)
        return result
     Nothing -> do
        let result = f k
        weak <- mkWeak k result (Just (finalizer hash_key stable_key weak_ref))
        writeArray table hash_key (MemoEntry stable_key weak : bucket)
        putMVar ref (size,table)
        return result

finalizer :: Int -> StableName a -> Weak (MemoTable a b) -> IO ()
finalizer hash_key stable_key weak_ref =
  do r <- deRefWeak weak_ref
     case r of
        Nothing -> return ()
        Just mvar -> do
                (size,table) <- takeMVar mvar
                bucket <- readArray table hash_key
                let new_bucket = [ e | e@(MemoEntry sn weak) <- bucket,
                                       sn /= stable_key ]
                writeArray table hash_key new_bucket
                putMVar mvar (size,table)

lookupSN :: StableName key -> [MemoEntry key val] -> IO (Maybe val)
lookupSN sn [] = sn `seq` return Nothing -- make it strict in sn
lookupSN sn (MemoEntry sn' weak : xs)
   | sn == sn'  = do maybe_item <- deRefWeak weak
                     case maybe_item of
                        Nothing -> error ("dead weak pair: " ++
                                                show (hashStableName sn))
                        Just v  -> return (Just v)
   | otherwise  = lookupSN sn xs
\end{code}


% $Id: Memo.lhs,v 1.1 2005/12/16 10:46:05 simonmar Exp $
%
% (c) The GHC Team, 1999
%
% Hashing memo tables.

\begin{code}

module Memo2
        ( memo          -- :: (a -> b) -> a -> b
        , memoSized     -- :: Int -> (a -> b) -> a -> b
        )
        where

import System.Mem.StableName    ( StableName, makeStableName, hashStableName )
import System.Mem.Weak          ( Weak, mkWeakPtr, mkWeak, deRefWeak, finalize )
import Data.Array.IO            ( IOArray, newArray, readArray, writeArray )
import System.IO.Unsafe         ( unsafePerformIO )
import Control.Concurrent.MVar  ( MVar, newMVar, putMVar, takeMVar )
\end{code}

-----------------------------------------------------------------------------
Memo table representation.

The representation is this: a fixed-size hash table where each bucket
is a list of table entries, of the form (key,value).

The key in this case is (StableName key), and we use hashStableName to
hash it.

It's important that we can garbage collect old entries in the table
when the key is no longer reachable in the heap.  Hence the value part
of each table entry is (Weak val), where the weak pointer "key" is the
key for our memo table, and 'val' is the value of this memo table
entry.  When the key becomes unreachable, a finalizer will fire and
remove this entry from the hash bucket, and further attempts to
dereference the weak pointer will return Nothing.  References from
'val' to the key are ignored (see the semantics of weak pointers in
the documentation).

\begin{code}
type MemoTable key val
        = MVar (
            Int,        -- current table size
            IOArray Int [MemoEntry key val]   -- hash table
           )

-- a memo table entry: compile with -funbox-strict-fields to eliminate
-- the boxes around the StableName and Weak fields.
data MemoEntry key val = MemoEntry !(StableName key) !(Weak val)
\end{code}

We use an MVar to the hash table, so that several threads may safely
access it concurrently.  This includes the finalization threads that
remove entries from the table.

ToDo: Can efficiency be improved at all?

\begin{code}
memo :: (a -> b) -> a -> b
memo f = memoSized default_table_size f

default_table_size = 1001

-- Our memo functions are *strict*.  Lazy memo functions tend to be
-- less useful because it is less likely you'll get a memo table hit
-- for a thunk.  This change was made to match Hugs's Memo
-- implementation, and as the result of feedback from Conal Elliot
-- <conal@microsoft.com>.

memoSized :: Int -> (a -> b) -> a -> b
memoSized size f = strict (lazyMemoSized size f)

strict = ($!)

lazyMemoSized :: Int -> (a -> b) -> a -> b
lazyMemoSized size f =
   let (table,weak) = unsafePerformIO (
                do { tbl <- newArray (0,size) []
                   ; mvar <- newMVar (size,tbl)
                   ; weak <- mkWeakPtr mvar (Just (table_finalizer tbl size))
                   ; return (mvar,weak)
                   })
   in  memo' f table weak

table_finalizer :: IOArray Int [MemoEntry key val] -> Int -> IO ()
table_finalizer table size =
   sequence_ [ finalizeBucket i | i <- [0..size] ]
 where
   finalizeBucket i = do
      bucket <- readArray table i
      sequence_ [ finalize w | MemoEntry _ w <- bucket ]

memo' :: (a -> b) -> MemoTable a b -> Weak (MemoTable a b) -> a -> b
memo' f ref weak_ref = \k -> unsafePerformIO $ do
   stable_key <- makeStableName k
   (size, table) <- takeMVar ref
   let hash_key = hashStableName stable_key `mod` size
   bucket <- readArray table hash_key
   lkp <- lookupSN stable_key bucket

   case lkp of
     Just result -> do
        putMVar ref (size,table)
        return result
     Nothing -> do
        let result = f k
        weak <- mkWeak k result (Just (finalizer hash_key stable_key weak_ref))
        writeArray table hash_key (MemoEntry stable_key weak : bucket)
        putMVar ref (size,table)
        return result

finalizer :: Int -> StableName a -> Weak (MemoTable a b) -> IO ()
finalizer hash_key stable_key weak_ref =
  do r <- deRefWeak weak_ref
     case r of
        Nothing -> return ()
        Just mvar -> do
                (size,table) <- takeMVar mvar
                bucket <- readArray table hash_key
                let new_bucket = [ e | e@(MemoEntry sn weak) <- bucket,
                                       sn /= stable_key ]
                writeArray table hash_key new_bucket
                putMVar mvar (size,table)

lookupSN :: StableName key -> [MemoEntry key val] -> IO (Maybe val)
lookupSN sn [] = sn `seq` return Nothing -- make it strict in sn
lookupSN sn (MemoEntry sn' weak : xs)
   | sn == sn'  = do maybe_item <- deRefWeak weak
                     case maybe_item of
                        Nothing -> error ("dead weak pair: " ++
                                                show (hashStableName sn))
                        Just v  -> return (Just v)
   | otherwise  = lookupSN sn xs
\end{code}


-- !!! test System.Mem.performGC

import System.Mem

main = performGC


import Control.Concurrent.QSem as OldQ

import Control.Concurrent.Chan
import Control.Concurrent (forkIO, threadDelay, killThread, yield)
import Control.Concurrent.MVar
import Control.Exception
import Control.Monad

new = newQSem
wait = waitQSem
signal = signalQSem

--------
-- dummy test-framework

type Assertion = IO ()

x @?= y = when (x /= y) $ error (show x ++ " /= " ++ show y)

testCase :: String -> IO () -> IO ()
testCase n io = putStrLn ("test " ++ n) >> io

defaultMain = sequence
------

main = defaultMain tests

tests = [
    testCase "sem1" sem1,
    testCase "sem2" sem2,
    testCase "sem_kill" sem_kill,
    testCase "sem_fifo" sem_fifo,
    testCase "sem_bracket" sem_bracket
 ]

sem1 :: Assertion
sem1 = do
  q <- new 0
  signal q
  wait q

sem2 :: Assertion
sem2 = do
  q <- new 0
  signal q
  signal q
  wait q
  wait q

sem_fifo :: Assertion
sem_fifo = do
  c <- newChan
  q <- new 0
  t1 <- forkIO $ do wait q; writeChan c 'a'
  threadDelay 10000
  t2 <- forkIO $ do wait q; writeChan c 'b'
  threadDelay 10000
  t3 <- forkIO $ do wait q; writeChan c 'c'
  threadDelay 10000
  signal q
  a <- readChan c
  signal q
  b <- readChan c
  signal q
  c <- readChan c
  [a,b,c] @?= "abc"

sem_kill :: Assertion
sem_kill  = do
  q <- new 0
  t <- forkIO $ do wait q
  threadDelay 100000
  killThread t
  m <- newEmptyMVar
  t <- forkIO $ do wait q; putMVar m ()
  signal q
  takeMVar m

sem_bracket :: Assertion
sem_bracket = do
  q <- new 1
  ts <- forM [1..100000] $ \n -> do
     forkIO $ do bracket_ (wait q) (signal q) (return ())
  mapM_ killThread ts
  wait q


import Control.Concurrent
import Control.Exception
import Control.Monad
import Data.List

new = newQSemN
wait = waitQSemN
signal = signalQSemN

--------
-- dummy test-framework

type Assertion = IO ()

x @?= y = when (x /= y) $ error (show x ++ " /= " ++ show y)

testCase :: String -> IO () -> IO ()
testCase n io = putStrLn ("test " ++ n) >> io

defaultMain = sequence
------

main = defaultMain tests

tests = [
    testCase "semn" semn,
    testCase "semn2" semn2,
    testCase "semn3" semn3,
    testCase "semn_kill" semn_kill,
    testCase "semn_bracket" sem_bracket
 ]

semn :: Assertion
semn = do
  c <- newEmptyMVar
  q <- new 0
  t1 <- forkIO $ do wait q 1;  putMVar c 'a'
  threadDelay 10000
  t2 <- forkIO $ do wait q 2;  putMVar c 'b'
  threadDelay 10000
  t3 <- forkIO $ do wait q 3;  putMVar c 'c'
  threadDelay 10000
  signal q 1
  a <-  takeMVar c
  signal q 2
  b <-  takeMVar c
  signal q 3
  c <-  takeMVar c
  [a,b,c] @?= "abc"

semn2 :: Assertion
semn2 = do
  c <- newEmptyMVar
  q <- new 0
  t1 <- forkIO $ do wait q 1; putMVar c 'a'
  threadDelay 10000
  t2 <- forkIO $ do wait q 2; putMVar c 'b'
  threadDelay 10000
  t3 <- forkIO $ do wait q 3; putMVar c 'c'
  threadDelay 10000
  signal q 6
  a <-  takeMVar c
  b <-  takeMVar c
  c <-  takeMVar c
  sort [a,b,c] @?= "abc"

semn3 :: Assertion
semn3 = do
  c <- newEmptyMVar
  q <- new 0
  t1 <- forkIO $ do wait q 1; putMVar c 'a'
  threadDelay 10000
  t2 <- forkIO $ do wait q 2; putMVar c 'b'
  threadDelay 10000
  t3 <- forkIO $ do wait q 3; putMVar c 'c'
  threadDelay 10000
  signal q 3
  a <-  takeMVar c
  b <-  takeMVar c
  threadDelay 10000
  sort [a,b] @?= "ab"
  d <-  isEmptyMVar c
  d @?= True
  signal q 1
  threadDelay 10000
  d <-  isEmptyMVar c
  d @?= True
  signal q 2
  x <-  takeMVar c
  x @?= 'c'

semn_kill :: Assertion
semn_kill  = do
  q <- new 0
  t <- forkIO $ do wait q 1
  threadDelay 10000
  killThread t
  m <- newEmptyMVar
  t <- forkIO $ do wait q 1; putMVar m ()
  signal q 1
  takeMVar m

sem_bracket :: Assertion
sem_bracket = do
  q <- new 1
  ts <- forM [1..100000] $ \n -> do
     forkIO $ do bracket_ (wait q 1) (signal q 1) (return ())
  mapM_ killThread ts
  wait q 1


import Control.Exception as E

import Data.Int

main :: IO ()
main = do putStrLn "Int8"
          mapM_ p =<< (f :: IO [Either Int8 String])
          putStrLn "Int16"
          mapM_ p =<< (f :: IO [Either Int16 String])
          putStrLn "Int32"
          mapM_ p =<< (f :: IO [Either Int32 String])
          putStrLn "Int64"
          mapM_ p =<< (f :: IO [Either Int64 String])
          putStrLn "Int"
          mapM_ p =<< (f :: IO [Either Int String])
    where p (Left x) = print x
          p (Right e) = putStrLn e

f :: (Integral a, Bounded a) => IO [Either a String]
f = sequence [ g (minBound `div` (-1)),
               g (minBound `mod` (-1)),
               g (case minBound `divMod` (-1) of (x, _) -> x),
               g (case minBound `divMod` (-1) of (_, x) -> x),
               g (minBound `quot` (-1)),
               g (minBound `rem` (-1)),
               g (case minBound `quotRem` (-1) of (x, _) -> x),
               g (case minBound `quotRem` (-1) of (_, x) -> x) ]
    where g x = do x' <- evaluate x
                   return (Left x')
                `E.catch`
                   \e -> return (Right (show (e :: SomeException)))


module Main(main) where

import System.Random

tstRnd rng = checkRange rng (genRnd 50 rng)

genRnd n rng = take n (randomRs rng (mkStdGen 2))

checkRange (lo,hi) = all pred
  where
   pred
    | lo <= hi  = \ x -> x >= lo && x <= hi
    | otherwise = \ x -> x >= hi && x <= lo

main :: IO ()
main = do
  print (tstRnd (1,5::Double))
  print (tstRnd (1,5::Int))
  print (tstRnd (10,54::Integer))
  print (tstRnd ((-6),2::Int))
  print (tstRnd (2,(-6)::Int))


import Data.Ratio

-- !!! Test that (%) has the right fixity
main = print (2^3%5)


main :: IO ()
main = do f "Infinity"
          f "-Infinity"
          f "  -  Infinity  "
          f "NaN"
          f "-NaN"
          f "  -  NaN  "

f :: String -> IO ()
f str = print (reads str :: [(Double, String)])


import Numeric

main :: IO ()
main = putStrLn $ showFloat (read "" :: Float) ""


main :: IO ()
main = do f "100e12"
          f "00123.456"

f :: String -> IO ()
f str = print (reads str :: [(Integer, String)])


module Main (main)
where

import Data.Char (digitToInt, lexLitChar, readLitChar)

main :: IO ()
main =
    do putStrLn (show $ readLitChar "A")
       putStrLn (show $ readLitChar "'A'")
       putStrLn (show $ lexLitChar "A")
       putStrLn (show $ lexLitChar "'A'")
       putStrLn (show $ lexLitChar "\\243\\&1")
       putStrLn (show $ lexLitChar "a\\&1")
       putStrLn (show $ lexLitChar "a\\&\\&1")
       putStrLn (show $ lexLitChar "a\\&\\&")


-- Test the classic "\SOH" ambiguity

module Main(main) where

main = do { print soh ; print (length (fst (head soh))) ;
            print so  ; print (length (fst (head so))) }
     where
        so, soh :: [(String,String)]
        soh = reads "\"\\SOH\"" -- Should read \SOH
        so  = reads "\"\\SOx\"" -- Should read \SO followed by x


-- !!! Testing Show on Maybes and Eithers
module Main(main) where

x :: Maybe ()
x = Nothing

main :: IO ()
main = do
  print x
  print (Just ())
  print ((Just (Just ())) :: Maybe (Maybe ()))
  print (Just x)
  print ((Left 'a')  :: Either Char Int)
  print ((Right 'b') :: Either Int Char)
  print ((Right x)   :: Either Int (Maybe ()))
  print ((Right (Just  'c')) :: Either Int (Maybe Char))
  print ((Right (Right 'd')) :: Either Int (Either Char Char))
  print ((Right (Left  'e')) :: Either Int (Either Char Int))
  print ((Left 'f') :: Either Char Int)
  print ((Left x) :: Either (Maybe ()) Char)
  print ((Left (Just  'g')) :: Either (Maybe Char) ())
  print ((Left (Right 'h')) :: Either (Either Int Char) Char)
  print ((Left (Right 'i')) :: Either (Either Int Char) ())


module Main (main) where

main :: IO ()
main = do let xs = [p0, p01, p3, p31, n0, n01, n3, n31, pinf, ninf, nan]
          mapM_ print xs
          mapM_ (print . Just) xs

p0 :: Double
p0 = 0

p01 :: Double
p01 = 0.1

p3 :: Double
p3 = 3

p31 :: Double
p31 = 3.1

n0 :: Double
n0 = -0

n01 :: Double
n01 = -0.1

n3 :: Double
n3 = -3

n31 :: Double
n31 = -3.1

pinf :: Double
pinf = 1 / 0

ninf :: Double
ninf = - 1 / 0

nan :: Double
nan = 0 / 0


module Main where

import Foreign

-- simple test for building/dereferencing stable ptrs

main
  = do  l <- mapM newStablePtr [1..100000]
        sum <- stable_sum l
        print sum

stable_sum :: [StablePtr Integer] -> IO Integer
stable_sum [] = return 0
stable_sum (x:xs)
  = do  x'  <- deRefStablePtr x
        freeStablePtr x
        xs' <- stable_sum xs
        return (x' + xs')


module Main where

import Control.Monad
import System.Mem.StableName
import Control.Exception

main = do
  mapM_ evaluate list
  stable_list1 <- mapM makeStableName list
  stable_list2 <- mapM makeStableName list
  unless (stable_list1 == stable_list2) $ do
    let l1 = map hashStableName stable_list1
    let l2 = map hashStableName stable_list2
    print $ zip l1 l2

list = [1..10000] :: [Integer]


import Foreign.StablePtr

-- compile without optimisation.
-- run with +RTS -D256 to see the stable pointer being garbage collected.

main = do
  let xs = [ 1 .. 50000 ]
  let ys = [ 1 .. 60000 ]
  s1 <- newStablePtr xs
  print (sum xs)
  freeStablePtr s1
  print (sum ys)


-- !!! triggered a temporary bug in freeStablePtr around 20020424

module Main where
import Foreign.StablePtr (newStablePtr, freeStablePtr)

data Foo = A | B | C | D

main :: IO ()
main = do aSPtr <- newStablePtr A
          bSPtr <- newStablePtr B
          cSPtr <- newStablePtr C
          cSPtr' <- newStablePtr C
          freeStablePtr aSPtr
          freeStablePtr bSPtr
          freeStablePtr cSPtr
          freeStablePtr cSPtr'
          aSPtr <- newStablePtr A
          bSPtr <- newStablePtr B
          cSPtr <- newStablePtr C
          dSPtr <- newStablePtr D
          print "Hello World"


import Control.Concurrent
import Control.Exception

main :: IO ()
main = do
    mask $ \unmask -> mask $ \restore ->
      unmask $ restore $ getMaskingState >>= print
    uninterruptibleMask $ \unmask -> uninterruptibleMask $ \restore ->
      unmask $ restore $ getMaskingState >>= print

    mv <- newEmptyMVar
    mask_ $ -- start with exceptions masked
      mask $ \restore -> forkIOWithUnmask $ \unmask -> unmask $
        restore $ getMaskingState >>= print >> putMVar mv ()
    takeMVar mv
    uninterruptibleMask_ $ -- start with exceptions uninterruptibly masked
      uninterruptibleMask $ \restore -> forkIOWithUnmask $ \unmask -> unmask $
        restore $ getMaskingState >>= print >> putMVar mv ()
    takeMVar mv


import Data.Char

main :: IO ()
main = do
    print $ isMark '\768'
    print $ isAlphaNum '\768'
    print $ (isAlpha '\768', isNumber '\768')


{-# LANGUAGE DataKinds #-}
module Main (main) where

import Data.Typeable
import GHC.Types

main :: IO ()
main = do
  print (typeOf (Proxy :: Proxy 'Just))
  print (typeOf (Proxy :: Proxy (TYPE 'LiftedRep)))
  print (typeOf (Proxy :: Proxy (TYPE 'UnliftedRep)))


import Control.Exception

-- Ensure that catch catches exceptions thrown during the evaluation of the
-- action-to-be-executed. This should output "it failed".
main :: IO ()
main = catch (error "uh oh") handler

handler :: SomeException -> IO ()
handler _ = putStrLn "it failed"


-- Written by Bertram Felgenhauer
--
-- https://ghc.haskell.org/trac/ghc/ticket/11760#comment:14
--
-- Compile with -threaded -with-rtsopts=-N2

{-# LANGUAGE BangPatterns #-}
import Control.Concurrent
import Control.Monad
import Control.Monad.ST.Lazy
import Control.Exception
import Data.STRef
import Data.IORef
import Control.Concurrent.MVar
import Data.List

-- evil ST action that tries to synchronize (by busy waiting on the
-- shared STRef) with a concurrent evaluation
evil :: ST s [Int]
evil = do
    r <- strictToLazyST $ newSTRef 0
    replicateM 100 $ do
        i <- strictToLazyST $ readSTRef r
        let !j = i + 1
        strictToLazyST $ writeSTRef r j
        let go 0 = return ()
            go n = do
                i' <- strictToLazyST $ readSTRef r
                when (j == i') $ go (n-1)
        go 100
        return j

main = do
    let res = runST evil
    s0 <- newIORef (map pred (0 : res))
    s1 <- newIORef (map pred (1 : res))
    m0 <- newMVar ()
    m1 <- newMVar ()
    forkIO $ do
        putMVar m0 ()
        readIORef s0 >>= evaluate . foldl' (+) 0
        putMVar m0 ()
    forkIO $ do
        putMVar m1 ()
        readIORef s1 >>= evaluate . foldl' (+) 0
        putMVar m1 ()
    threadDelay 10000
    replicateM 3 $ takeMVar m0 >> takeMVar m1
    v0 <- tail <$> readIORef s0
    v1 <- tail <$> readIORef s1
    print (v0 == v1)


import System.Environment.Blank

main = do
  let envVar = "AN_ENVIRONMENT_VARIABLE"

  valueBeforeSettingVariable <- getEnv envVar
  print valueBeforeSettingVariable -- Nothing

  valueWithDefaultBeforeSetting <- getEnvDefault envVar "DEFAULT"
  print valueWithDefaultBeforeSetting -- "DEFAULT"

  setEnv envVar "" False

  valueAfterSettingVariable <- getEnv envVar
  print valueAfterSettingVariable -- Just ""

  valueWithDefaultAfterSetting <- getEnvDefault envVar "DEFAULT"
  print valueWithDefaultAfterSetting -- ""

  valueFromGetEnvironment <- lookup envVar <$> getEnvironment
  print valueFromGetEnvironment -- Just ""

  setEnv envVar "NO_OVERRIDE" False

  valueAfterSettingWithExistingValueAndOverrideFalse <- getEnv envVar
  print valueAfterSettingWithExistingValueAndOverrideFalse -- Just ""

  setEnv envVar "OVERRIDE" True

  valueAfterSettingWithExistingValueAndOverrideTrue <- getEnv envVar
  print valueAfterSettingWithExistingValueAndOverrideTrue -- Just "OVERRIDE"

  unsetEnv envVar

  valueAfterUnsettingVariable <- getEnv envVar
  print valueAfterUnsettingVariable -- Nothing


import GHC.Conc
import GHC.IO
import GHC.IO.FD as FD
import System.Posix.IO
import System.Posix.Types

main = do
  (rfd,wfd) <- createPipe
  (waitread, unregister) <- threadWaitReadSTM rfd
  unregister
  result0 <- atomically $ (fmap (const False) waitread) `orElse` return True
  print result0
  fdWrite wfd "test"
  threadDelay 20000
  result1 <- atomically $ (fmap (const False) waitread) `orElse` return True
  print result1
  (waitread1, _) <- threadWaitReadSTM rfd
  threadDelay 20000
  result2 <- atomically $ (fmap (const True) waitread1) `orElse` return False
  print result2


module Main where

import Data.Proxy

main :: IO ()
main = print (read "Thing Proxy" :: Thing (Proxy Int))

data Thing a = Thing a
  deriving (Read,Show)


{-# LANGUAGE TypeApplications #-}
import Data.Ord

main :: IO ()
main = do
  print ((<) 10 20)
  print ((<) @(Down _) 10 20)


import Data.IORef
import Control.Monad
import Control.Exception
import Control.Concurrent.MVar
import System.Mem

main :: IO ()
main = do
  run
  run
  run
  run
  m <- newEmptyMVar
  quit m
  performMajorGC
  takeMVar m

run :: IO ()
run = do
  ref <- newIORef ()
  void $ mkWeakIORef ref $ do
    putStr "."
    throwIO $ ErrorCall "failed"

quit :: MVar () -> IO ()
quit m = do
  ref <- newIORef ()
  void $ mkWeakIORef ref $ do
    putMVar m ()


-- To test with GHC before liftA2 was added to the Applicative
-- class, remove the definition of liftA2 here, and import
-- liftA2 separately from Control.Applicative.
{-# LANGUAGE DeriveTraversable, GADTs, DataKinds,
    DeriveFunctor, StandaloneDeriving #-}

module Main where
import Control.Applicative (Applicative (..))
import Data.Monoid (Sum (..))
import qualified Data.Array as A

data Tree a = Leaf a a | Node (Tree a) (Tree a)
  deriving (Functor, Foldable, Traversable)

buildTree :: Int -> a -> Tree a
buildTree 0 a = Leaf a a
buildTree n a =
  let subtree = buildTree (n - 1) a
  in Node subtree subtree

data Nat = Z | S Nat

data Vec n a where
  Nil :: Vec 'Z a
  Cons :: a -> !(Vec n a) -> Vec ('S n) a

deriving instance Functor (Vec n)
deriving instance Foldable (Vec n)
deriving instance Show a => Show (Vec n a)

class Pure n where
  pure' :: a -> Vec n a
instance Pure 'Z where
  pure' _ = Nil
instance Pure n => Pure ('S n) where
  pure' a = Cons a (pure' a)

instance Pure n => Applicative (Vec n) where
  pure = pure'
  (<*>) = apVec
  liftA2 = liftA2Vec

apVec :: Vec n (a -> b) -> Vec n a -> Vec n b
apVec Nil Nil = Nil
apVec (Cons f fs) (Cons x xs) = f x `Cons` apVec fs xs

liftA2Vec :: (a -> b -> c) -> Vec n a -> Vec n b -> Vec n c
liftA2Vec _ Nil Nil = Nil
liftA2Vec f (Cons x xs) (Cons y ys) = f x y `Cons` liftA2Vec f xs ys

data SomeVec a where
  SomeVec :: Pure n => Vec n a -> SomeVec a

replicateVec :: Int -> a -> SomeVec a
replicateVec 0 _ = SomeVec Nil
replicateVec n a =
  case replicateVec (n - 1) a of
    SomeVec v -> SomeVec (a `Cons` v)

ones :: SomeVec Int
ones = replicateVec 6000 (1 :: Int)

theTree :: Tree ()
theTree = buildTree 7 ()

blah :: SomeVec (Tree Int)
blah = case ones of
         SomeVec v -> SomeVec $ traverse (const v) theTree

main = case blah of
         SomeVec v -> print $ getSum $ foldMap (foldMap Sum) v


import System.Posix.Files
import System.IO
import System.Timeout

main :: IO ()
main = do
    createNamedPipe "test" accessModes
    h <- openFile "test" ReadMode
    hWaitForInput h (5 * 1000)
    return ()


import GHC.ResponseFile

assertEqual :: (Eq a, Show a) => a -> a -> IO ()
assertEqual x y = if x == y
                  then return ()
                  else error $ "assertEqual: " ++ show x ++ " /= " ++ show y

-- Migrated from Haddock.

-- The first two elements are
--   1) a list of 'args' to encode and
--   2) a single string of the encoded args
-- The 3rd element is just a description for the tests.
testStrs :: [(([String], String), String)]
testStrs =
  [ ((["a simple command line"],
      "a\\ simple\\ command\\ line\n"),
     "the white-space, end with newline")

  , ((["arg 'foo' is single quoted"],
      "arg\\ \\'foo\\'\\ is\\ single\\ quoted\n"),
     "the single quotes as well")

  , ((["arg \"bar\" is double quoted"],
      "arg\\ \\\"bar\\\"\\ is\\ double\\ quoted\n"),
     "the double quotes as well" )

  , ((["arg \"foo bar\" has embedded whitespace"],
      "arg\\ \\\"foo\\ bar\\\"\\ has\\ embedded\\ whitespace\n"),
     "the quote-embedded whitespace")

  , ((["arg 'Jack said \\'hi\\'' has single quotes"],
      "arg\\ \\'Jack\\ said\\ \\\\\\'hi\\\\\\'\\'\\ has\\ single\\ quotes\n"),
     "the escaped single quotes")

  , ((["arg 'Jack said \\\"hi\\\"' has double quotes"],
      "arg\\ \\'Jack\\ said\\ \\\\\\\"hi\\\\\\\"\\'\\ has\\ double\\ quotes\n"),
     "the escaped double quotes")

  , ((["arg 'Jack said\\r\\n\\t \\\"hi\\\"' has other whitespace"],
      "arg\\ \\'Jack\\ said\\\\r\\\\n\\\\t\\ \\\\\\\"hi\\\\\\\"\\'\\ has\\ \
           \other\\ whitespace\n"),
     "the other whitespace")

  , (([ "--prologue=.\\dist\\.\\haddock-prologue3239114604.txt"
      , "--title=HaddockNewline-0.1.0.0: This has a\n\
        \newline yo."
      , "-BC:\\Program Files\\Haskell Platform\\lib"],
      "--prologue=.\\\\dist\\\\.\\\\haddock-prologue3239114604.txt\n\
      \--title=HaddockNewline-0.1.0.0:\\ This\\ has\\ a\\\n\
      \newline\\ yo.\n\
      \-BC:\\\\Program\\ Files\\\\Haskell\\ Platform\\\\lib\n"),
     "an actual haddock response file snippet with embedded newlines")
  ]

main :: IO ()
main = do
  -- Test escapeArgs
  mapM_ (\((ss1,s2),des) -> escapeArgs ss1 `assertEqual` s2) testStrs

  -- Test unescapeArgs
  mapM_ (\((ss1,s2),des) -> unescapeArgs s2 `assertEqual` ss1) testStrs

  -- Given unescaped quotes, it should pass-through,
  -- without escaping everything inside

  (filter (not . null) $
   unescapeArgs "this\\ is\\ 'not escape\\d \"inside\"'\\ yo\n")
   `assertEqual`
   ["this is not escaped \"inside\" yo"]

  (filter (not . null) $
   unescapeArgs "this\\ is\\ \"not escape\\d 'inside'\"\\ yo\n")
   `assertEqual`
   ["this is not escaped 'inside' yo"]


import Data.Ratio

main = do
  print (approxRational (0 % 1 :: Ratio Int) (1 % 10)) -- 0%1, correct
  print (approxRational (0 % 1 :: Ratio Word) (1 % 10)) -- 1%1, incorrect


import Control.Monad.ST.Strict
import Control.Monad.Fix
import Data.STRef

foo :: ST s Int
foo = do
  ref <- newSTRef True
  mfix $ \res -> do
    x <- readSTRef ref
    if x
      then do
        writeSTRef ref False
        return $! (res + 5)
      else return 10

main :: IO ()
main = print $ runST foo


module Main where

import qualified Data.List as L

-- USE_REPORT_PRELUDE versions of nub and nubBy, copied from
-- libraries/base/Data/OldList.hs.
nub                     :: (Eq a) => [a] -> [a]
nub                     =  nubBy (==)

nubBy                   :: (a -> a -> Bool) -> [a] -> [a]
nubBy eq []             =  []
nubBy eq (x:xs)         =  x : nubBy eq (filter (\ y -> not (eq x y)) xs)

data Asymmetric = A | B deriving Show

instance Eq Asymmetric where
  A == _ = True
  B == _ = False

main :: IO()
main = do
  print $ L.nub [A,B]
  print $ L.nubBy (<) [1,2]
  -- The implementation from Data.List and the one from the Prelude defined in
  -- the Haskell 98 report should have the same behavior.
  print $ L.nub [A,B] == nub [A,B]
  print $ L.nubBy (<) [1,2] == nubBy (<) [1,2]


import Data.List

-- this should evaluate in constant space
main :: IO ()
main = print $ iterate' (+1) 1 !! 100000000


{-# LANGUAGE GeneralizedNewtypeDeriving #-}

import Control.Monad
import Control.Monad.Fix
import Data.IORef
import Prelude hiding (until)

data Phase a = Ready a | Updated a a

delay :: IO Int               -- ^ the signal to delay
      -> IO (IO (), IO (), IO Int)   -- ^ the delayed signal
delay s = do
  ref <- newIORef (Ready 0)
  let
      upd = do v <- readIORef ref
               case v of
                 Ready x -> do putStrLn "upd: Ready"; x' <- s; putStrLn (show x'); writeIORef ref (Updated x' x)
                 _       -> return ()

      fin = do v <- readIORef ref
               case v of
                 Updated x _ -> do putStrLn "fin: Updated"; writeIORef ref $! Ready x
                 _           -> error "Signal not updated!"

      sig = do v <- readIORef ref
               case v of
                 Ready x     -> do putStrLn "sig: Ready"; return x
                 Updated _ x -> do putStrLn "sig: Updated"; return x

  return (upd,fin,sig)

main = do
    (upd,fin,_) <- mfix $ \ ~(_,_,sig) -> delay (fmap (1+) sig)
    upd
    fin
    upd


module Main where

import Data.Typeable

unitToUnit_a = typeOf (\() -> ())
unitToUnit_b = mkFunTy (typeOf ()) (typeOf ())

main = print (unitToUnit_a == unitToUnit_b)


import Text.Printf
main = printf "%*sx\n" (-(3::Int)) "hi"


import Control.Monad;
import Control.Concurrent

main :: IO ()
main = replicateM_ 1000000 (forkIO (threadDelay 1))


import Control.Concurrent
import System.Posix.IO

main = do
  putStrLn "hello"
  fd <- openFd "/dev/random" ReadOnly Nothing defaultFileFlags
  threadWaitRead fd
  putStrLn "goodbye"


import Control.Concurrent.MVar
import Control.Exception

main = do
  mv <- newMVar 'x'
  e <- try (modifyMVar mv $ \_ -> return undefined)
  let _ = e :: Either SomeException ()
  withMVar mv print -- should not hang


import Control.Concurrent

main :: IO ()
main = threadDelay maxBound


import Control.Concurrent
import System.IO
import System.Timeout

main :: IO ()
main = do
    forkIO $ do
        threadDelay (5 * 1000000)
        -- The timeout should terminate before we ever make it here
        putStrLn "t=5 seconds: we shouldn't be here"

    timeout (1 * 1000000) $ do
        hWaitForInput stdin (10 * 1000)
        putStrLn "we shouldn't be here"

    return ()


module Main where

main :: IO()
main = print $ length [1..(2^(20::Int)::Integer)]


{-# LANGUAGE DataKinds #-}

module T9111 where

import Data.Typeable

a = typeRep (Proxy :: Proxy 'True)
b = typeRep (Proxy :: Proxy Typeable)
c = typeRep (Proxy :: Proxy (~))
d = typeRep (Proxy :: Proxy 'Left)


import Debug.Trace
main = trace "333\0UUUU" $ return ()


-- Tests Data.Bits.FiniteBits(count{Leading,Trailing}Zeros)` -- c.f. T9340.hs

import Control.Monad
import Data.Bits
import Data.Int
import Data.Typeable
import Data.Word
import Numeric (showHex)

-- Reference Implementations

-- count trailing zeros
ctzRI :: FiniteBits a => a -> Word
ctzRI x = fromIntegral $ go 0
  where
    go i | i >= w      = i
         | testBit x i = i
         | otherwise   = go (i+1)

    w = finiteBitSize x

-- count leading zeros
clzRI :: FiniteBits a => a -> Word
clzRI x = fromIntegral $ (w-1) - go (w-1)
  where
    go i | i < 0       = i -- no bit set
         | testBit x i = i
         | otherwise   = go (i-1)

    w = finiteBitSize x

-- Test Driver
main :: IO ()
main = do
    forM_ testpats $ \w64 -> do
        checkCLZ (fromIntegral w64 :: Word)
        checkCLZ (fromIntegral w64 :: Word8)
        checkCLZ (fromIntegral w64 :: Word16)
        checkCLZ (fromIntegral w64 :: Word32)
        checkCLZ (fromIntegral w64 :: Word64)

        checkCLZ (fromIntegral w64 :: Int)
        checkCLZ (fromIntegral w64 :: Int8)
        checkCLZ (fromIntegral w64 :: Int16)
        checkCLZ (fromIntegral w64 :: Int32)
        checkCLZ (fromIntegral w64 :: Int64)

        checkCTZ (fromIntegral w64 :: Word)
        checkCTZ (fromIntegral w64 :: Word8)
        checkCTZ (fromIntegral w64 :: Word16)
        checkCTZ (fromIntegral w64 :: Word32)
        checkCTZ (fromIntegral w64 :: Word64)

        checkCTZ (fromIntegral w64 :: Int)
        checkCTZ (fromIntegral w64 :: Int8)
        checkCTZ (fromIntegral w64 :: Int16)
        checkCTZ (fromIntegral w64 :: Int32)
        checkCTZ (fromIntegral w64 :: Int64)

    putStrLn $ concat ["tested ", show (length testpats), " patterns"]

  where
    -- try to construct some interesting patterns
    testpats :: [Word64]
    testpats = [ bit i - 1 | i <- [0..63] ] ++
               [ complement (bit i - 1) | i <- [0..63] ] ++
               [ bit i .|. bit j | i <- [0..63], j <- [0..i] ]

    -- Compare impl-under-test with reference-impl
    checkCLZ :: (Typeable a, Show a, Integral a, FiniteBits a) => a -> IO ()
    checkCLZ v = unless (vri == viut) $ do
        putStrLn $ concat [ "FAILED: clz (0x", showHex v " :: ", tyName
                          , ") ==> (RI=", show vri, " vs. IUT=", show viut, ")"
                          ]
      where
        tyName = show (typeOf v)
        vri    = clzRI v
        viut   = fromIntegral (countLeadingZeros v)

    -- Compare impl-under-test with reference-impl
    checkCTZ :: (Typeable a, Show a, Integral a, FiniteBits a) => a -> IO ()
    checkCTZ v = unless (vri == viut) $ do
        putStrLn $ concat [ "FAILED: ctz (0x", showHex v " :: ", tyName
                          , ") ==> (RI=", show vri, " vs. IUT=", show viut, ")"
                          ]
      where
        tyName = show (typeOf v)
        vri    = ctzRI v
        viut   = fromIntegral (countTrailingZeros v)


module XPrelude (module X) where

import Control.Monad    as X
import Data.Foldable    as X
import Data.List        as X
import Data.Monoid      as X
import Data.Traversable as X
import Prelude          as X


{-# LANGUAGE BangPatterns #-}

module Main where
--import qualified Data.Vector.Storable as V
import Foreign
import Data.Ratio
import Data.Complex

complexZI :: Complex Int
complexZI = 1 :+ 1

ratio23 :: Ratio Int
ratio23 =  1 % 1

putter :: Storable a => a -> Ptr a -> IO a
putter v !ptr = do poke ptr v ; peek ptr

main =
  do
      !vComplex <- alloca (putter complexZI)
      !vRatio <- alloca (putter ratio23)
      if vComplex  == complexZI &&  vRatio  == ratio23
        then putStrLn "success"
        else putStrLn "uh oh, something is wrong with storable"


import Data.IORef

foo :: Int -> Bool
foo n = all (<10000000) [1..n]

bar :: Int -> Bool
bar n = and $ map (<10000000) [1..n]

main :: IO ()
main = do
  ref <- newIORef 1000000
  val <- readIORef ref
  print $ foo val
  print $ bar val


-- Test for bug #1219, F/B rule for take was too strict
import System.Environment
main = do
 (n:_) <- getArgs
 print (map (const 'x') (take (read n) (undefined:undefined)))


import Control.Exception
import Data.List
import System.FilePath
import System.Directory
import System.IO

-- Checks that openTempFile returns filenames with the right structure
main :: IO ()
main = do
 fp0 <- otf ".no_prefix.hs"
 print (".hs"        `isSuffixOf` fp0)
 print (".no_prefix" `isPrefixOf` takeFileName fp0)

 fp1 <- otf "no_suffix"
 print (not ('.' `elem` fp1))
 print ("no_suffix" `isPrefixOf` takeFileName fp1)

 fp2 <- otf "one_suffix.hs"
 print (".hs"        `isSuffixOf` fp2)
 print ("one_suffix" `isPrefixOf` takeFileName fp2)

 fp3 <- otf "two_suffixes.hs.blah"
 print (".blah"           `isSuffixOf` fp3)
 print ("two_suffixes.hs" `isPrefixOf` takeFileName fp3)

otf :: FilePath -> IO FilePath
otf fp = do putStrLn fp
            bracket (openTempFile "." fp)
                    (\(fp', h) -> do hClose h
                                     removeFile fp')
                    (\(fp', _) -> case fp' of
                                  '.' : '/'  : fp'' -> return fp''
                                  '.' : '\\' : fp'' -> return fp''
                                  _                 -> return fp')


{-      Bug report 28 May 99

When compiled with ghc-4.02, everything's fine, it outputs "Value 7" as
expected. But compiled with ghc-pre-4.03 it yields this error message.

   Fail: Prelude.read: no parse
-}

module Main where

data Msg = Value Int | Inc   deriving (Show, Read)

main = do let v = read "Value 7"::Msg
          print v


import System.Posix.Process
import System.Posix.Signals
import Control.Exception
import Control.Concurrent

-- Test that a simulated ^C sends an async UserInterrupt
-- exception to the main thread.

main = handle userInterrupt $ do
  us <- getProcessID
  signalProcess sigINT us
  threadDelay 1000000
  putStrLn "Fail: never received  exception"

userInterrupt UserInterrupt = putStrLn "Success: caught UserInterrupt"
userInterrupt e             = putStrLn "Fail: caught unexpected exception"


import Control.Exception
import Control.Concurrent

-- Test that a UserInterrupt exception that propagates to the top level
-- causes the process to terminate by killing itself with SIGINT

main = throwIO UserInterrupt


import System.Posix.Signals
import System.Exit
import Data.Bits

-- Test that a ExitFailure representing SIGTERM causes
-- the process to terminate by killing itself with SIGTERM

main = exitWith (ExitFailure (fromIntegral (-sigTERM)))


import Control.Exception

-- test that the out-of-band data in an ErrorCall exception is printed

main = throw (ErrorCallWithLocation "error" "out-of-band")


import System.IO
import Debug.Trace

main = do
   hPutStr stderr
        (trace (trace (trace (trace (trace (trace (trace
          "one" "fish") "two") "fish") "red") "fish") "blue") "fish")
   hPutStr stdout
        (trace (trace (trace (trace (trace (trace (trace
          "ONE" "FISH") "TWO") "FISH") "RED") "FISH") "BLUE") "FISH")


-- Test instances for tuples up to 15
-- For Read, Show, Eq, Ord, Bounded

module Main where

data T = A | B | C | D | E | F | G | H | I | J | K | L | M | N | O
       deriving( Eq, Ord, Show, Read, Bounded )

t15 = (A,B,C,D,E,F,G,H,I,J,K,L,M,N,O)
t14 = (A,B,C,D,E,F,G,H,I,J,K,L,M,N)
t13 = (A,B,C,D,E,F,G,H,I,J,K,L,M)
t12 = (A,B,C,D,E,F,G,H,I,J,K,L)
t11 = (A,B,C,D,E,F,G,H,I,J,K)
t10 = (A,B,C,D,E,F,G,H,I,J)
t9  = (A,B,C,D,E,F,G,H,I)
t8  = (A,B,C,D,E,F,G,H)
t7  = (A,B,C,D,E,F,G)
t6  = (A,B,C,D,E,F)
t5  = (A,B,C,D,E)
t4  = (A,B,C,D)
t3  = (A,B,C)
t2  = (A,B)
t0  = ()

big = (t0,t2,t3,t4,t5,t6,t7,t8,t9,t10,t11,t12,t13,t14,t15)

main = do print big
          print (read (show big) `asTypeOf` big)
          print (big == big)
          print (big < big)
          print (big > big)
          print (minBound `asTypeOf` big)
          print (maxBound `asTypeOf` big)


-- !!! Tests the various character classifications for a selection of Unicode
-- characters.

module Main where

import Data.Char

main = do
  putStrLn ("            " ++ concat (map (++" ") strs))
  mapM putStrLn (map do_char chars)
 where
  do_char char = s ++ (take (12-length s) (repeat ' ')) ++ concat (map f bs)
    where
          s = show char
          bs = map ($char) functions
          f True  = "X     "
          f False = "      "

strs = ["upper","lower","alpha","alnum","digit","print","space","cntrl"]

functions = [isUpper,isLower,isAlpha,isAlphaNum,isDigit,isPrint,isSpace,isControl]

chars = [backspace,tab,space,zero,lower_a,upper_a,delete,
        right_pointing_double_angle_quotation_mark,
        greek_capital_letter_alpha,
        bengali_digit_zero,
        en_space,
        gothic_letter_ahsa,
        monospaced_digit_zero
        ]

backspace             = '\x08'
tab                   = '\t'
space                 = ' '
zero                  = '0'
lower_a               = 'a'
upper_a               = 'A'
delete                = '\x7f'
right_pointing_double_angle_quotation_mark = '\xBB'
latin_small_letter_i_with_caron = '\x1D0'
combining_acute_accent = '\x301'
greek_capital_letter_alpha = '\x0391'
bengali_digit_zero    = '\x09E6'
en_space              = '\x2002'
gothic_letter_ahsa    = '\x10330'
monospaced_digit_zero = '\x1D7F6'


module Main where

import Data.Char
import Numeric

header = "Code C P S U L A D"

preds = [
  isControl,
  isPrint,
  isSpace,
  isUpper,
  isLower,
  isAlpha,
  isDigit]

prtBool :: Bool -> String

prtBool True  = "T "
prtBool False = "F "

showCode :: Char -> Int -> String

showCode c w = code ++ pad
  where
    code = show (ord c)
    l = length code
    spaces = map anytospace [1..]
    anytospace _ = ' '
    pad  | l >= w = ""
         | otherwise = take (w - l) spaces

charCode :: Char -> String

rapply a b = b a

charCode c = (showCode c 5) ++ (foldr1 (++) $ map prtBool $ map (rapply c) preds)

main = do
    putStrLn header
    mapM (putStrLn . charCode) [ (chr 0) .. (chr 6553) ]


import Foreign
import System.Mem.Weak

kill:: Ptr a -> IO ()
kill a = do
    w <- mkWeakPtr a Nothing
    addFinalizer a $
        deRefWeak w >> return ()

main:: IO ()
main = sequence_ . take 10000 . repeat $
    mallocBytes 100 >>= kill >> return ()


import Test.QuickCheck
import System.IO.Unsafe
import Control.Concurrent.Chan
import Control.Concurrent
import Control.Monad

data Action = NewChan | ReadChan | WriteChan Int | IsEmptyChan | ReturnInt Int
            | ReturnBool Bool
  deriving (Eq,Show)

main = do
  t <- myThreadId
  forkIO (threadDelay 1000000 >> killThread t)
        -- just in case we deadlock
  testChan

testChan :: IO ()
testChan = do
  quickCheck prop_NewIs_NewRet
  quickCheck prop_NewWriteIs_NewRet
  quickCheck prop_NewWriteRead_NewRet

prop_NewIs_NewRet =
  [NewChan,IsEmptyChan] =^ [NewChan,ReturnBool True]

prop_NewWriteIs_NewRet n =
  [NewChan,WriteChan n,IsEmptyChan] =^ [NewChan,WriteChan n,ReturnBool False]

prop_NewWriteRead_NewRet n =
  [NewChan,WriteChan n,ReadChan] =^ [NewChan,ReturnInt n]

perform :: [Action] -> IO ([Bool],[Int])
perform [] = return ([],[])

perform (a:as) =
  case a of
    ReturnInt v  -> liftM (\(b,l) -> (b,v:l)) (perform as)
    ReturnBool v -> liftM (\(b,l) -> (v:b,l)) (perform as)
    NewChan      -> newChan >>= \chan -> perform' chan as
    _            -> error $ "Please use NewChan as first action"

perform' :: Chan Int -> [Action] -> IO ([Bool],[Int])
perform' _ [] = return ([],[])

perform' chan (a:as) =
  case a of
    ReturnInt v  -> liftM (\(b,l) -> (b,v:l)) (perform' chan as)
    ReturnBool v -> liftM (\(b,l) -> (v:b,l)) (perform' chan as)
    ReadChan     -> liftM2 (\v (b,l) -> (b,v:l)) (readChan chan)
                                (perform' chan as)
    WriteChan n  -> writeChan chan n >> perform' chan as
    IsEmptyChan  -> liftM2 (\v (b,l) -> (v:b,l)) (isEmptyChan chan)
                                (perform' chan as)
    _                -> error $ "If you want to use " ++ show a
                                ++ " please use the =^ operator"

actions :: Gen [Action]
actions =
  liftM (NewChan:) (actions' 0)

actions' :: Int -> Gen [Action]
actions' contents =
  oneof ([return [],
          liftM (IsEmptyChan:) (actions' contents),
          liftM2 (:) (liftM WriteChan arbitrary) (actions' (contents+1))]
          ++
          if contents==0
             then []
             else [liftM (ReadChan:) (actions' (contents-1))])

(=^) :: [Action] -> [Action] -> Property
c =^ c' =
  forAll (actions' (delta 0 c))
         (\suff -> observe c suff == observe c' suff)
  where observe x suff = unsafePerformIO (perform (x++suff))

(^=^) :: [Action] -> [Action] -> Property
c ^=^ c' =
  forAll actions
         (\pref -> forAll (actions' (delta 0 (pref++c)))
                          (\suff -> observe c pref suff ==
                                      observe c' pref suff))
  where observe x pref suff = unsafePerformIO (perform (pref++x++suff))

delta :: Int -> [Action] -> Int
delta i [] = i

delta i (ReturnInt _:as) = delta i as

delta i (ReturnBool _:as) = delta i as

delta _ (NewChan:as) = delta 0 as

delta i (WriteChan _:as) = delta (i+1) as

delta i (ReadChan:as) = delta (if i==0
                                  then error "read on empty Chan"
                                  else i-1) as

delta i (IsEmptyChan:as) = delta i as


import Control.Concurrent
import Control.Exception
import Control.Monad
import System.IO
import System.Environment

-- test for deadlocks
main = do
  hSetBuffering stdout NoBuffering
  [n] <- getArgs
  replicateM_ (read n) $ do
         chan <- newChan
         wid <- forkIO $ forever $ writeChan chan (5::Int)
         rid <- forkIO $ forever $ void $ readChan chan
         threadDelay 1000
         throwTo rid ThreadKilled
         putStr "."
         readChan chan
         throwTo wid ThreadKilled


import Control.Concurrent
import Control.Exception
import Control.Monad
import System.IO
import System.Environment

-- test for deadlocks
main = do
  hSetBuffering stdout NoBuffering
  [n] <- getArgs
  replicateM_ (read n) $ do
         chan <- newChan
         wid <- forkIO $ forever $ writeChan chan (5::Int)
         threadDelay 3000
         throwTo wid ThreadKilled
         putStr "."
         writeChan chan (3::Int)


import Test.QuickCheck
import System.IO.Unsafe
import Control.Concurrent.MVar
import Control.Concurrent
import Control.Monad

data Action = NewEmptyMVar | NewMVar Int | TakeMVar | ReadMVar | PutMVar Int
            | SwapMVar Int | IsEmptyMVar | ReturnInt Int | ReturnBool Bool
  deriving (Eq,Show)

main = do
  t <- myThreadId
  forkIO (threadDelay 1000000 >> killThread t)
        -- just in case we deadlock
  testMVar

testMVar :: IO ()
testMVar = do
  quickCheck prop_NewEIs_NewERet
  quickCheck prop_NewIs_NewRet
  quickCheck prop_NewTake_NewRet
  quickCheck prop_NewEPutTake_NewERet
  quickCheck prop_NewRead_NewRet
  quickCheck prop_NewSwap_New

prop_NewEIs_NewERet =
  [NewEmptyMVar,IsEmptyMVar] =^ [NewEmptyMVar,ReturnBool True]

prop_NewIs_NewRet n =
  [NewMVar n,IsEmptyMVar] =^ [NewMVar n,ReturnBool False]

prop_NewTake_NewRet n =
  [NewMVar n,TakeMVar] =^ [NewEmptyMVar,ReturnInt n]

prop_NewEPutTake_NewERet n =
  [NewEmptyMVar,PutMVar n,TakeMVar] =^
    [NewEmptyMVar,ReturnInt n]

prop_NewRead_NewRet n =
  [NewMVar n,ReadMVar] =^ [NewMVar n,ReturnInt n]

prop_NewSwap_New m n =
  [NewMVar m,SwapMVar n] =^ [NewMVar n]

perform :: [Action] -> IO ([Bool],[Int])
perform [] = return ([],[])

perform (a:as) =
  case a of
    ReturnInt v  -> liftM (\(b,l) -> (b,v:l)) (perform as)
    ReturnBool v -> liftM (\(b,l) -> (v:b,l)) (perform as)
    NewEmptyMVar -> newEmptyMVar >>= \mv -> perform' mv as
    NewMVar n    -> newMVar n >>= \mv -> perform' mv as
    _            -> error $ "Please use NewMVar or NewEmptyMVar as first "
                            ++ "action"

perform' :: MVar Int -> [Action] -> IO ([Bool],[Int])
perform' _ [] = return ([],[])

perform' mv (a:as) =
  case a of
    ReturnInt v  -> liftM (\(b,l) -> (b,v:l)) (perform' mv as)
    ReturnBool v -> liftM (\(b,l) -> (v:b,l)) (perform' mv as)
    TakeMVar     -> liftM2 (\v (b,l) -> (b,v:l)) (takeMVar mv)
                                (perform' mv as)
    ReadMVar     -> liftM2 (\v (b,l) -> (b,v:l)) (readMVar mv)
                                (perform' mv as)
    PutMVar n    -> putMVar mv n >> perform' mv as
    SwapMVar n   -> swapMVar mv n >> perform' mv as
    IsEmptyMVar  -> liftM2 (\v (b,l) -> (v:b,l)) (isEmptyMVar mv)
                                (perform' mv as)
    _            -> error $ "If you want to use " ++ show a
                            ++ " please use the =^ operator"

actions :: Gen [Action]
actions = do
  oneof [liftM (NewEmptyMVar:) (actions' True),
         liftM2 (:) (liftM NewMVar arbitrary) (actions' False)]

actions' :: Bool -> Gen [Action]
actions' empty =
  oneof ([return [],
          liftM (IsEmptyMVar:) (actions' empty)] ++
          if empty
             then [liftM2 (:) (liftM PutMVar arbitrary) (actions' False)]
             else []
          ++
          if empty
             then []
             else [liftM (TakeMVar:) (actions' True)]
          ++
          if empty
             then []
             else [liftM (ReadMVar:) (actions' False)]
          ++
          if empty
             then []
             else [liftM2 (:) (liftM SwapMVar arbitrary) (actions' False)]   )

(=^) :: [Action] -> [Action] -> Property
c =^ c' =
  forAll (actions' (delta True c))
         (\suff -> observe c suff == observe c' suff)
  where observe x suff = unsafePerformIO (perform (x++suff))

(^=^) :: [Action] -> [Action] -> Property
c ^=^ c' =
  forAll actions
         (\pref -> forAll (actions' (delta True (pref++c)))
                          (\suff -> observe c pref suff ==
                                      observe c' pref suff))
  where observe x pref suff = unsafePerformIO (perform (pref++x++suff))

delta :: Bool -> [Action] -> Bool
delta b [] = b

delta b (ReturnInt _:as) = delta b as

delta b (ReturnBool _:as) = delta b as

delta _ (NewEmptyMVar:as) = delta True as

delta _ (NewMVar _:as) = delta False as

delta b (TakeMVar:as) = delta (if b
                                  then error "take on empty MVar"
                                  else True) as

delta b (ReadMVar:as) = delta (if b
                                  then error "read on empty MVar"
                                  else False) as

delta _ (PutMVar _:as) = delta False as

delta b (SwapMVar _:as) = delta (if b
                                  then error "swap on empty MVar"
                                  else False) as

delta b (IsEmptyMVar:as) = delta b as


-- Test that threadDelay actually sleeps for (at least) as long as we
-- ask it

module Main (main) where

import Control.Concurrent
import Control.Monad
import Data.Time

main :: IO ()
main = mapM_ delay (0 : take 7 (iterate (*5) 100))

delay :: Int -> IO ()
delay n = do
  tS <- getCurrentTime
  threadDelay n
  tE <- getCurrentTime

  let req = fromIntegral n * 10 ^ (6 :: Int)
      obs = floor (diffUTCTime tE tS * 10 ^ (12 :: Int))
      diff = obs - req
      diff' :: Double
      diff' = fromIntegral diff /  10 ^ (12 :: Int)

  when (obs < req) $ print (tS, tE, req, obs, diff, diff')


import Control.Concurrent

main = do
  forkIO $ do threadDelay  100000; putStrLn "child"
  getLine
  putStrLn "parent"


import System.Process
import System.IO
import Control.Concurrent

main = do
  (hin,hout,herr,ph) <- runInteractiveProcess "cat" [] Nothing Nothing
  forkIO $ do threadDelay 100000
              putStrLn "child"
              hFlush stdout
              hPutStrLn hin "msg"
              hFlush hin
  putStrLn "parent1"
  hGetLine hout >>= putStrLn
  putStrLn "parent2"


-- test for trac #629. We need to keep track of how many readers
-- there are rather than closing the first read handle causing the
-- lock to be released.

import System.IO
import System.IO.Error

file = "countReaders001.txt"

main = do
  writeFile file "foo"

  h1 <- openFile file ReadMode
  h2 <- openFile file ReadMode
  hClose h1
  tryIOError (openFile file AppendMode) >>= print


import Control.Monad
import System.IO
import System.IO.Error
import GHC.IO.Encoding (utf8)
import GHC.IO.Handle (hSetEncoding)

testfiles = ["decodingerror001.in1", "decodingerror001.in2"]

main = mapM_ alltests testfiles

alltests file = mapM (test file)  [NoBuffering,
                                   LineBuffering,
                                   BlockBuffering Nothing,
                                   BlockBuffering (Just 9),
                                   BlockBuffering (Just 23) ]

test file bufmode = do
  h <- openFile file ReadMode
  hSetEncoding h utf8
  hSetBuffering h bufmode
  e <- tryIOError $ forever $ hGetChar h >>= putChar
  print (e :: Either IOError ())


import Control.Monad
import System.IO
import System.IO.Error
import GHC.IO.Handle (hSetEncoding)

main = do
  -- Explicitly set stdout encoding so that the UTF8//ROUNDTRIP
  -- test is always able to write the surrogate byte out without error.
  enc <- mkTextEncoding "UTF-8//ROUNDTRIP"
  hSetEncoding stdout enc
  alltests "decodingerror002.in"

alltests file = mapM (test file)  ["UTF-8",
                                   "UTF-8//IGNORE",
                                   "UTF-8//TRANSLIT",
                                   "UTF-8//ROUNDTRIP"]

test file enc_name = do
  h <- openFile file ReadMode
  enc <- mkTextEncoding enc_name
  hSetEncoding h enc
  e <- tryIOError $ forever $ hGetChar h >>= putChar
  print (e :: Either IOError ())


import Control.Monad
import System.IO
import GHC.IO.Encoding
import GHC.IO.Handle
import Data.Bits
import Data.Word
import Data.Char
import System.FilePath
import System.Exit

file = "encoding001"

encodings = [(utf8,     "utf8"),
             (utf8_bom, "utf8_bom"),
             (utf16,    "utf16"),
             (utf16le,  "utf16le"),
             (utf16be,  "utf16be"),
             (utf32,    "utf32"),
             (utf32le,  "utf32le"),
             (utf32be,  "utf32be")]

main = do
  -- make a UTF-32BE file
  h <- openBinaryFile (file <.> "utf32be") WriteMode
  let expand32 :: Word32 -> [Char]
      expand32 x = [
          chr (fromIntegral (x `shiftR` 24) .&. 0xff),
          chr (fromIntegral (x `shiftR` 16) .&. 0xff),
          chr (fromIntegral (x `shiftR` 8)  .&. 0xff),
          chr (fromIntegral x .&. 0xff) ]
  hPutStr h (concatMap expand32 [ 0, 32 .. 0xD7ff ])
  hPutStr h (concatMap expand32 [ 0xE000, 0xE000+32 .. 0x10FFFF ])
  hClose h

  -- convert the UTF-32BE file into each other encoding
  forM_ encodings $ \(enc,name) -> do
     when (name /=  "utf32be") $ do
       hin <- openFile (file <.> "utf32be") ReadMode
       hSetEncoding hin utf32be
       hout <- openFile (file <.> name) WriteMode
       hSetEncoding hout enc
       hGetContents hin >>= hPutStr hout
       hClose hin
       hClose hout

  forM_ [ (from,to) | from <- encodings, to <- encodings, snd from /= snd to ]
      $ \((fromenc,fromname),(toenc,toname)) -> do
     hin <- openFile (file <.> fromname) ReadMode
     hSetEncoding hin fromenc
     hout <- openFile (file <.> toname <.> fromname) WriteMode
     hSetEncoding hout toenc
     hGetContents hin >>= hPutStr hout
     hClose hin
     hClose hout

     h1 <- openBinaryFile (file <.> toname) ReadMode
     h2 <- openBinaryFile (file <.> toname <.> fromname) ReadMode
     str1 <- hGetContents h1
     str2 <- hGetContents h2
     when (str1 /= str2) $ do
       putStrLn (file <.> toname ++ " and " ++ file <.> toname <.> fromname ++ " differ")
       exitWith (ExitFailure 1)
     hClose h1
     hClose h2


import Control.Monad

import System.IO
import Control.Exception

import Foreign.Marshal.Array
import Foreign.Ptr

import GHC.Foreign
import GHC.IO.Encoding (TextEncoding, mkTextEncoding)

import Data.Char
import Data.Word

decode :: TextEncoding -> [Word8] -> IO String
decode enc xs = withArrayLen xs (\sz p -> peekCStringLen enc (castPtr p, sz)) `catch` \e -> return (show (e :: IOException))

encode :: TextEncoding -> String -> IO [Word8]
encode enc cs = withCStringLen enc cs (\(p, sz) -> peekArray sz (castPtr p)) `catch` \e -> return (const [] (e :: IOException))

asc :: Char -> Word8
asc = fromIntegral . ord

families = [ ([asc 'H', asc 'i', 0xED, 0xB2, 0x80, asc '!'],
              ["UTF-8",    "UTF-8//IGNORE",    "UTF-8//TRANSLIT",    "UTF-8//ROUNDTRIP"])
           , ([asc 'H', 0, asc 'i', 0, 0xFF, 0xDF, 0xFF, 0xDF, asc '!', 0],
              ["UTF-16LE", "UTF-16LE//IGNORE", "UTF-16LE//TRANSLIT", "UTF-16LE//ROUNDTRIP"])
           , ([0, asc 'H', 0, asc 'i', 0xDF, 0xFF, 0xDF, 0xFF, 0, asc '!'],
              ["UTF-16BE", "UTF-16BE//IGNORE", "UTF-16BE//TRANSLIT", "UTF-16BE//ROUNDTRIP"])
           , ([asc 'H', 0, 0, 0, asc 'i', 0, 0, 0, 0xED, 0xB2, 0x80, 0, asc '!', 0, 0, 0],
              ["UTF-32LE", "UTF-32LE//IGNORE", "UTF-32LE//TRANSLIT", "UTF-32LE//ROUNDTRIP"])
           , ([0, 0, 0, asc 'H', 0, 0, 0, asc 'i', 0, 0x80, 0xB2, 0xED, 0, 0, 0, asc '!'],
              ["UTF-32BE", "UTF-32BE//IGNORE", "UTF-32BE//TRANSLIT", "UTF-32BE//ROUNDTRIP"])
           ]

main = do
  surrogate_enc <- mkTextEncoding "UTF-8//ROUNDTRIP"

  -- Test that invalid input is correctly roundtripped as surrogates
  -- This only works for the UTF-8 UTF since it is the only UTF which
  -- is an ASCII superset.
  putStrLn $ "== UTF-8: roundtripping"
  let invalid_bytes = [asc 'H', asc 'i', 0xED, 0xB2, 0x80, asc '!']
  surrogates <- decode surrogate_enc invalid_bytes
  invalid_bytes' <- encode surrogate_enc surrogates
  print invalid_bytes
  print surrogates
  print invalid_bytes'
  print (invalid_bytes == invalid_bytes')
  putStrLn ""

  forM families $ \(invalid_bytes, enc_names) -> do
    encs <- mapM mkTextEncoding enc_names
    let name = head enc_names

    -- How we deal with decoding errors in the various modes:
    putStrLn $ "== " ++ name ++ ": decoding"
    forM encs $ \enc -> decode enc invalid_bytes >>= print

    -- How about encoding errors, particularly those from embedded surrogates?
    putStrLn $ "== " ++ name ++ ": encoding"
    forM encs $ \enc -> encode enc "Hi\xDC80!" >>= print

    putStrLn ""


import System.IO
import System.Directory
import Data.Char

tempFile = "temp"

create :: IO ()
create = do
    h <- openFile tempFile WriteMode
    hSetEncoding h latin1
    hPutStr h [chr 128]
    hClose h

main :: IO ()
main = do
    create

    utf8Ignore <- mkTextEncoding "UTF8//IGNORE"
    h <- openFile tempFile ReadMode
    hSetEncoding h utf8Ignore
    hGetContents h >>= putStrLn

    removeFile tempFile


import System.IO
import System.Directory
import Data.Char
import System.Process
import Control.Monad
import qualified Data.ByteString as BS
import System.Environment
import System.Exit
import System.FilePath
import Data.Maybe
import qualified Data.Map as M
import GHC.Foreign
import Control.Exception

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

encode :: TextEncoding -> String -> IO (Either SomeException BS.ByteString)
encode enc cs = try $ withCStringLen enc cs $ BS.packCStringLen

decodeEncode :: TextEncoding -> BS.ByteString -> IO (Either SomeException BS.ByteString)
decodeEncode enc bs = decode enc bs `bind` encode enc

encodedecode :: TextEncoding -> String -> IO (Either SomeException String)
encodedecode enc bs = encode enc bs `bind` decode enc

bind mx fxmy = do
    ei_e_cs <- mx
    case ei_e_cs of
        Left e   -> return (Left e)
        Right cs -> fxmy cs

main :: IO ()
main = forM_ [ ("CP936",  2, "CP936",      Just "CP936-UTF8")  -- Representative (roundtrippable) DBCS
             , ("CP1251", 1, "CP1251",     Just "CP1251-UTF8") -- Representative SBCS
             , ("UTF-8",  4, "CP936-UTF8", Nothing)            -- Sanity check
             ] $ \(enc_name, max_byte_length, file, mb_utf8_file) -> do
    putStrLn $ "== " ++ enc_name

    let fp = "encoded-data" </> file <.> "txt"
    enc <- mkTextEncoding enc_name
    bs <- BS.readFile fp

    -- In a DBCS you should never fail to encode truncated input for two consecutive truncation points,
    -- assuming that the input file is actually error free:
    testTruncations enc max_byte_length bs

    -- Should be able to roundtrip arbitrary rubbish, as long as we use the right encoding
    roundtrip_enc <- mkTextEncoding (enc_name ++ "//ROUNDTRIP")
    testRoundtripping roundtrip_enc bs

    -- Just check that we actually decode to the right thing, for good measure
    case mb_utf8_file of
      Nothing -> return ()
      Just utf8_file -> do
        utf8_bs <- BS.readFile ("encoded-data" </> utf8_file <.> "txt")
        Right expected <- decode utf8 utf8_bs
        Right actual   <- decode enc  bs
        unless (expected == actual) $ do
            putStrLn (bsDiff 0 actual expected)

forTruncations :: BS.ByteString -> (BS.ByteString -> IO a) -> IO [a]
forTruncations bs f = forSplits bs $ \before _ -> f before

forSplits :: BS.ByteString -> (BS.ByteString -> BS.ByteString -> IO a) -> IO [a]
forSplits bs f = forM [(800 * block) + ix | block <- [0..len `div` 800], ix <- [0..100]] $ \i -> uncurry f (BS.splitAt i bs)
    where len = BS.length bs

testTruncations :: TextEncoding -> Int -> BS.ByteString -> IO ()
testTruncations enc max_byte_length bs = do
    failures <- fmap catMaybes $ forTruncations bs $ testTruncation enc

    let failure_map = M.fromList failures
    forM_ failures $ \(i, e) -> do
        let js = [i+1..i+(max_byte_length - 1)]
        case sequence (map (`M.lookup` failure_map) js) of
            Nothing -> return ()
            Just es -> putStrLn ("Failed on consecutive truncated byte indexes " ++ show (i:js) ++ " (" ++ show (e:es) ++ ")")

testTruncation :: TextEncoding -> BS.ByteString -> IO (Maybe (Int, SomeException))
testTruncation enc expected = do
        --putStr (show i ++ ": ") >> hFlush stdout
        ei_e_actual <- decodeEncode enc expected
        case ei_e_actual of
            Left  e      -> return (Just (BS.length expected, e))
            Right actual | expected /= actual -> error $ "Mismatch on success when truncating at byte index " ++ show (BS.length expected)
                         | otherwise          -> return Nothing

testRoundtripping :: TextEncoding -> BS.ByteString -> IO ()
testRoundtripping roundtrip_enc bs = void $ forSplits bs $ \before after -> do
    let expected = before `BS.append` (fromIntegral (BS.length before `mod` 256) `BS.cons` after)
    Right actual <- decodeEncode roundtrip_enc expected
    when (actual /= expected) $ do
        let i_str = show (BS.length before)
        putStrLn $ "Failed to roundtrip given mutant byte at index " ++ i_str ++ " (" ++ bsDiff 0 (BS.unpack actual) (BS.unpack expected) ++ ")"
        -- Possibly useful for debugging porpoises:
        --BS.writeFile (i_str ++ ".expected") expected
        --BS.writeFile (i_str ++ ".actual")   actual

bsDiff :: (Show a, Eq a) => Int -> [a] -> [a] -> String
bsDiff _ [] [] = error "bsDiff"
bsDiff _ [] bs = "actual " ++ show (length bs) ++ " elements shorter than expected"
bsDiff _ as [] = "expected " ++ show (length as) ++ " elements shorter than actual"
bsDiff i (a:as) (b:bs) | a == b    = bsDiff (i + 1) as bs
                       | otherwise = show a ++ " /= " ++ show b ++ " at index " ++ show i


import Control.Monad
import Data.Word (Word8)
import Foreign.Ptr
import Foreign.Marshal.Array
import GHC.Foreign (peekCStringLen, withCStringLen)
import GHC.IO.Encoding.Failure (CodingFailureMode(..))
import qualified GHC.IO.Encoding.Latin1 as Latin1
import System.IO
import System.IO.Error

-- Tests for single-byte encodings that map directly to Unicode
-- (module GHC.IO.Encoding.Latin1)

eitherToMaybe :: Either a b -> Maybe b
eitherToMaybe (Left _) = Nothing
eitherToMaybe (Right b) = Just b

decode :: TextEncoding -> [Word8] -> IO (Maybe String)
decode enc xs = fmap eitherToMaybe . tryIOError $ withArrayLen xs (\sz p -> peekCStringLen enc (castPtr p, sz))

encode :: TextEncoding -> String -> IO (Maybe [Word8])
encode enc cs = fmap eitherToMaybe . tryIOError $ withCStringLen enc cs (\(p, sz) -> peekArray sz (castPtr p))

testIO :: (Eq a, Show a) => IO a -> a -> IO ()
testIO action expected = do
  result <- action
  when (result /= expected) $
    putStrLn $ "Test failed: expected " ++ show expected ++ ", but got " ++ show result

-- Test char8-like encodings
test_char8 :: TextEncoding -> IO ()
test_char8 enc = do
  testIO (decode enc [0..0xff]) $ Just ['\0'..'\xff']

  testIO (encode enc ['\0'..'\x200']) $ Just ([0..0xff] ++ [0..0xff] ++ [0])

-- Test latin1-like encodings
test_latin1 :: CodingFailureMode -> TextEncoding -> IO ()
test_latin1 cfm enc = do
  testIO (decode enc [0..0xff]) $ Just ['\0'..'\xff']

  testIO (encode enc ['\0'..'\xff']) $ Just [0..0xff]
  testIO (encode enc "\xfe\xff\x100\x101\x100\xff\xfe") $ case cfm of
    ErrorOnCodingFailure -> Nothing
    IgnoreCodingFailure -> Just [0xfe,0xff,0xff,0xfe]
    TransliterateCodingFailure -> Just [0xfe,0xff,0x3f,0x3f,0x3f,0xff,0xfe]
    -- N.B. The argument "latin1//TRANSLIT" to mkTextEncoding does not
    -- correspond to "latin1//TRANSLIT" in iconv! Instead GHC asks iconv
    -- to encode to "latin1" and uses its own "evil hack" to insert '?'
    -- (ASCII 0x3f) in place of failures. See GHC.IO.Encoding.recoverEncode.
    --
    -- U+0100 is LATIN CAPITAL LETTER A WITH MACRON, which iconv would
    -- transliterate to 'A' (ASCII 0x41). Similarly iconv would
    -- transliterate U+0101 LATIN SMALL LETTER A WITH MACRON to 'a'
    -- (ASCII 0x61).
    RoundtripFailure -> Nothing

test_ascii :: CodingFailureMode -> TextEncoding -> IO ()
test_ascii cfm enc = do
  testIO (decode enc [0..0x7f]) $ Just ['\0'..'\x7f']
  testIO (decode enc [0x7e,0x7f,0x80,0x81,0x80,0x7f,0x7e]) $ case cfm of
    ErrorOnCodingFailure -> Nothing
    IgnoreCodingFailure -> Just "\x7e\x7f\x7f\x7e"
    TransliterateCodingFailure -> Just "\x7e\x7f\xfffd\xfffd\xfffd\x7f\x7e"
    -- Another GHC special: decode invalid input to the Char U+FFFD
    -- REPLACEMENT CHARACTER.
    RoundtripFailure -> Just "\x7e\x7f\xdc80\xdc81\xdc80\x7f\x7e"
    -- GHC's PEP383-style String-encoding of invalid input,
    -- see Note [Roundtripping]

  testIO (encode enc ['\0'..'\x7f']) $ Just [0..0x7f]
  testIO (encode enc "\x7e\x7f\x80\x81\x80\x7f\xe9") $ case cfm of
    ErrorOnCodingFailure -> Nothing
    IgnoreCodingFailure -> Just [0x7e,0x7f,0x7f]
    TransliterateCodingFailure -> Just [0x7e,0x7f,0x3f,0x3f,0x3f,0x7f,0x3f]
    -- See comment in test_latin1. iconv -t ASCII//TRANSLIT would encode
    -- U+00E9 LATIN SMALL LETTER E WITH ACUTE as 'e' (ASCII 0x65).
    RoundtripFailure -> Nothing

  -- Test roundtripping for good measure
  case cfm of
    RoundtripFailure -> do
      Just s <- decode enc [0..0xff]
      testIO (encode enc s) $ Just [0..0xff]
    _ -> return ()

main = do
  putStrLn "char8 tests"
  test_char8 char8              -- char8 never fails in either direction

  -- These use GHC's own implementation
  putStrLn "Latin1.ascii tests"
  test_ascii ErrorOnCodingFailure (Latin1.ascii)
  test_ascii IgnoreCodingFailure (Latin1.mkAscii IgnoreCodingFailure)
  test_ascii TransliterateCodingFailure (Latin1.mkAscii TransliterateCodingFailure)
  test_ascii RoundtripFailure (Latin1.mkAscii RoundtripFailure)

  putStrLn "Latin1.latin1_checked tests"
  test_latin1 ErrorOnCodingFailure (Latin1.latin1_checked)
  test_latin1 IgnoreCodingFailure (Latin1.mkLatin1_checked IgnoreCodingFailure)
  test_latin1 TransliterateCodingFailure (Latin1.mkLatin1_checked TransliterateCodingFailure)
  test_latin1 RoundtripFailure (Latin1.mkLatin1_checked RoundtripFailure)

  -- These use iconv (normally, unless it is broken)
  putStrLn "mkTextEncoding ASCII tests"
  test_ascii ErrorOnCodingFailure =<< mkTextEncoding "ASCII"
  test_ascii IgnoreCodingFailure =<< mkTextEncoding "ASCII//IGNORE"
  test_ascii TransliterateCodingFailure =<< mkTextEncoding "ASCII//TRANSLIT"
  test_ascii RoundtripFailure =<< mkTextEncoding "ASCII//ROUNDTRIP"

  putStrLn "mkTextEncoding latin1 tests"
  test_latin1 ErrorOnCodingFailure =<< mkTextEncoding "latin1"
  test_latin1 IgnoreCodingFailure =<< mkTextEncoding "latin1//IGNORE"
  test_latin1 TransliterateCodingFailure =<< mkTextEncoding "latin1//TRANSLIT"
  test_latin1 RoundtripFailure =<< mkTextEncoding "latin1//ROUNDTRIP"


import System.IO
import System.IO.Error
import Text.Printf
import Control.Monad

main = do
  hSetEncoding stdout latin1
  forM [NoBuffering,
        LineBuffering,
        BlockBuffering Nothing,
        BlockBuffering (Just 3),
        BlockBuffering (Just 9),
        BlockBuffering (Just 32)] $ \b -> do
     hSetBuffering stdout b
     checkedPutStr "test 1\n"
     checkedPutStr "Ä›\n" -- nothing gets written
     checkedPutStr "test 2\n"
     checkedPutStr "HÎllo\n" -- we should write at least the 'H'
     checkedPutStr "test 3\n"
     checkedPutStr "Hello Î±Î²Î³\n" -- we should write at least the "Hello "

checkedPutStr str = do
  r <- tryIOError $ putStr str
  case r of
    Right _ -> return ()
    Left  e -> printf "Caught %s while trying to write %s\n"
                  (show e) (show str)


import System.Environment

main = do
    var0 <- getEnv "GHC_TEST"
    putStrLn var0
    -- The length proves that we actually decoded it properly, not just read it
    -- in as latin1 or something (#3308, #3307)
    putStrLn ("Test 1: " ++ show (length var0))

    [arg0] <- getArgs
    putStrLn arg0
    putStrLn ("Test 2: " ++ show (length arg0))

    [arg1] <- withArgs ["ä½ å¥½!"] getArgs
    putStrLn arg1
    putStrLn ("Test 3: " ++ show (length arg1))

    args2 <- withArgs ["a", "b"] getArgs
    print args2
    putStrLn ("Test 4: " ++ show (length args2))


--- !!! test for bug in handle finalization fixed in
--- !!!  1.60      +1 -2      fptools/ghc/lib/std/PrelHandle.lhs
--- !!!  1.15      +4 -10     fptools/ghc/lib/std/PrelIO.lhs

module Main (main) where

import System.IO

doTest :: IO ()
doTest = do
  sd <- openFile "finalization001.hs" ReadMode
  result <- hGetContents sd
  slurp result
  hClose sd
  if "" `elem` lines (filter (/= '\r') result)
   then
    putStrLn "ok"
   else
    putStrLn "fail"

slurp :: String -> IO ()
slurp [] = return ()
slurp (x:xs) = x `seq` slurp xs

main :: IO ()
main = sequence_ (take 200 (repeat doTest))


import System.IO
import System.IO.Error

main = do
  h <- openFile "hClose001.tmp" WriteMode
  hPutStr h "junk"
  hClose h
  hPutStr h "junk" `catchIOError` \ err -> if isIllegalOperation err then putStr "Okay\n" else error "Not okay\n"


import System.IO
import Control.Exception

import qualified GHC.IO.Device as IODevice
import GHC.IO.Handle
import GHC.IO.Handle.Internals
import GHC.IO.Handle.Types
import System.Posix.Internals

main = do
  h <- openFile "hClose002.tmp" WriteMode
        -- close the FD without telling the IO library:
  naughtyClose h
        -- first hClose will raise an exception, but close the
        -- Handle anyway:
  showPossibleException (hClose h)
        -- second hClose should success (Handle is already closed)
  showPossibleException (hClose h)
        -- this should succeed (checking that the lock on the file has
        -- been released:
  h <- openFile "hClose002.tmp" ReadMode
  showPossibleException (hClose h)
  showPossibleException (hClose h)

showPossibleException :: IO () -> IO ()
showPossibleException f = do e <- try f
                             print (e :: Either SomeException ())

naughtyClose h =
  withHandle_ "naughtyClose" h $ \ Handle__{haDevice=dev} -> do
     IODevice.close dev


-- Test for #3128, file descriptor leak when hClose fails

import System.IO
import Control.Exception
import Data.Char

import System.Posix
import qualified GHC.IO.Device as IODevice
import GHC.IO.Handle
import GHC.IO.Handle.Internals
import GHC.IO.Handle.Types
import System.Posix.Internals

main = do
  (read,write) <- createPipe
  hread <- fdToHandle read
  hwrite <- fdToHandle write

        -- close the FD without telling the IO library:
  showPossibleException (hClose hread)
  hIsOpen hread >>= print

        -- put some data in the Handle's write buffer:
  hPutStr hwrite "testing"
        -- now try to close the Handle:
  showPossibleException (hClose hwrite)
  hIsOpen hwrite >>= print

showPossibleException :: IO () -> IO ()
showPossibleException f = do
  e <- try f
  putStrLn (sanitise (show (e :: Either SomeException ())))
 where
  -- we don't care which file descriptor it is
  sanitise [] = []
  sanitise (x:xs) = if isDigit x then ('X':(sanitise' xs)) else (x:(sanitise xs))
  sanitise' [] = []
  sanitise' (x:xs) = if isDigit x then (sanitise' xs) else (x:(sanitise xs))

naughtyClose h =
  withHandle_ "naughtyClose" h $ \ Handle__{haDevice=dev} -> do
     IODevice.close dev