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

-----------------------------------------------------------------------------
-- |
-- Module      :  System.IO.Error
-- Copyright   :  (c) The University of Glasgow 2001
-- License     :  BSD-style (see the file libraries/base/LICENSE)
--
-- Maintainer  :  libraries@haskell.org
-- Stability   :  provisional
-- Portability :  portable
--
-- Standard IO Errors.
--
-----------------------------------------------------------------------------

module System.IO.Error (

    -- * I\/O errors
    IOError,

    userError,

    mkIOError,

    annotateIOError,

    -- ** Classifying I\/O errors
    isAlreadyExistsError,
    isDoesNotExistError,
    isAlreadyInUseError,
    isFullError,
    isEOFError,
    isIllegalOperation,
    isPermissionError,
    isUserError,

    -- ** Attributes of I\/O errors
    ioeGetErrorType,
    ioeGetLocation,
    ioeGetErrorString,
    ioeGetHandle,
    ioeGetFileName,

    ioeSetErrorType,
    ioeSetErrorString,
    ioeSetLocation,
    ioeSetHandle,
    ioeSetFileName,

    -- * Types of I\/O error
    IOErrorType,                -- abstract

    alreadyExistsErrorType,
    doesNotExistErrorType,
    alreadyInUseErrorType,
    fullErrorType,
    eofErrorType,
    illegalOperationErrorType,
    permissionErrorType,
    userErrorType,

    -- ** 'IOErrorType' predicates
    isAlreadyExistsErrorType,
    isDoesNotExistErrorType,
    isAlreadyInUseErrorType,
    isFullErrorType,
    isEOFErrorType,
    isIllegalOperationErrorType,
    isPermissionErrorType,
    isUserErrorType,

    -- * Throwing and catching I\/O errors

    ioError,

    catchIOError,
    tryIOError,

    modifyIOError,
  ) where

import Control.Exception.Base

import Data.Either
import Data.Maybe

import GHC.Base
import GHC.IO
import GHC.IO.Exception
import GHC.IO.Handle.Types
import Text.Show

-- | The construct 'tryIOError' @comp@ exposes IO errors which occur within a
-- computation, and which are not fully handled.
--
-- Non-I\/O exceptions are not caught by this variant; to catch all
-- exceptions, use 'Control.Exception.try' from "Control.Exception".
--
-- @since 4.4.0.0
tryIOError     :: IO a -> IO (Either IOError a)
tryIOError f   =  catch (do r <- f
                            return (Right r))
                        (return . Left)

-- -----------------------------------------------------------------------------
-- Constructing an IOError

-- | Construct an 'IOError' of the given type where the second argument
-- describes the error location and the third and fourth argument
-- contain the file handle and file path of the file involved in the
-- error if applicable.
mkIOError :: IOErrorType -> String -> Maybe Handle -> Maybe FilePath -> IOError
mkIOError t location maybe_hdl maybe_filename =
               IOError{ ioe_type = t,
                        ioe_location = location,
                        ioe_description = "",
                        ioe_errno = Nothing,
                        ioe_handle = maybe_hdl,
                        ioe_filename = maybe_filename
                        }

-- -----------------------------------------------------------------------------
-- IOErrorType

-- | An error indicating that an 'IO' operation failed because
-- one of its arguments already exists.
isAlreadyExistsError :: IOError -> Bool
isAlreadyExistsError = isAlreadyExistsErrorType    . ioeGetErrorType

-- | An error indicating that an 'IO' operation failed because
-- one of its arguments does not exist.
isDoesNotExistError :: IOError -> Bool
isDoesNotExistError  = isDoesNotExistErrorType     . ioeGetErrorType

-- | An error indicating that an 'IO' operation failed because
-- one of its arguments is a single-use resource, which is already
-- being used (for example, opening the same file twice for writing
-- might give this error).
isAlreadyInUseError :: IOError -> Bool
isAlreadyInUseError  = isAlreadyInUseErrorType     . ioeGetErrorType

-- | An error indicating that an 'IO' operation failed because
-- the device is full.
isFullError         :: IOError -> Bool
isFullError          = isFullErrorType             . ioeGetErrorType

-- | An error indicating that an 'IO' operation failed because
-- the end of file has been reached.
isEOFError          :: IOError -> Bool
isEOFError           = isEOFErrorType              . ioeGetErrorType

-- | An error indicating that an 'IO' operation failed because
-- the operation was not possible.
-- Any computation which returns an 'IO' result may fail with
-- 'isIllegalOperation'.  In some cases, an implementation will not be
-- able to distinguish between the possible error causes.  In this case
-- it should fail with 'isIllegalOperation'.
isIllegalOperation  :: IOError -> Bool
isIllegalOperation   = isIllegalOperationErrorType . ioeGetErrorType

-- | An error indicating that an 'IO' operation failed because
-- the user does not have sufficient operating system privilege
-- to perform that operation.
isPermissionError   :: IOError -> Bool
isPermissionError    = isPermissionErrorType       . ioeGetErrorType

-- | A programmer-defined error value constructed using 'userError'.
isUserError         :: IOError -> Bool
isUserError          = isUserErrorType             . ioeGetErrorType

-- -----------------------------------------------------------------------------
-- IOErrorTypes

-- | I\/O error where the operation failed because one of its arguments
-- already exists.
alreadyExistsErrorType   :: IOErrorType
alreadyExistsErrorType    = AlreadyExists

-- | I\/O error where the operation failed because one of its arguments
-- does not exist.
doesNotExistErrorType    :: IOErrorType
doesNotExistErrorType     = NoSuchThing

-- | I\/O error where the operation failed because one of its arguments
-- is a single-use resource, which is already being used.
alreadyInUseErrorType    :: IOErrorType
alreadyInUseErrorType     = ResourceBusy

-- | I\/O error where the operation failed because the device is full.
fullErrorType            :: IOErrorType
fullErrorType             = ResourceExhausted

-- | I\/O error where the operation failed because the end of file has
-- been reached.
eofErrorType             :: IOErrorType
eofErrorType              = EOF

-- | I\/O error where the operation is not possible.
illegalOperationErrorType :: IOErrorType
illegalOperationErrorType = IllegalOperation

-- | I\/O error where the operation failed because the user does not
-- have sufficient operating system privilege to perform that operation.
permissionErrorType      :: IOErrorType
permissionErrorType       = PermissionDenied

-- | I\/O error that is programmer-defined.
userErrorType            :: IOErrorType
userErrorType             = UserError

-- -----------------------------------------------------------------------------
-- IOErrorType predicates

-- | I\/O error where the operation failed because one of its arguments
-- already exists.
isAlreadyExistsErrorType :: IOErrorType -> Bool
isAlreadyExistsErrorType AlreadyExists = True
isAlreadyExistsErrorType _ = False

-- | I\/O error where the operation failed because one of its arguments
-- does not exist.
isDoesNotExistErrorType :: IOErrorType -> Bool
isDoesNotExistErrorType NoSuchThing = True
isDoesNotExistErrorType _ = False

-- | I\/O error where the operation failed because one of its arguments
-- is a single-use resource, which is already being used.
isAlreadyInUseErrorType :: IOErrorType -> Bool
isAlreadyInUseErrorType ResourceBusy = True
isAlreadyInUseErrorType _ = False

-- | I\/O error where the operation failed because the device is full.
isFullErrorType :: IOErrorType -> Bool
isFullErrorType ResourceExhausted = True
isFullErrorType _ = False

-- | I\/O error where the operation failed because the end of file has
-- been reached.
isEOFErrorType :: IOErrorType -> Bool
isEOFErrorType EOF = True
isEOFErrorType _ = False

-- | I\/O error where the operation is not possible.
isIllegalOperationErrorType :: IOErrorType -> Bool
isIllegalOperationErrorType IllegalOperation = True
isIllegalOperationErrorType _ = False

-- | I\/O error where the operation failed because the user does not
-- have sufficient operating system privilege to perform that operation.
isPermissionErrorType :: IOErrorType -> Bool
isPermissionErrorType PermissionDenied = True
isPermissionErrorType _ = False

-- | I\/O error that is programmer-defined.
isUserErrorType :: IOErrorType -> Bool
isUserErrorType UserError = True
isUserErrorType _ = False

-- -----------------------------------------------------------------------------
-- Miscellaneous

ioeGetErrorType       :: IOError -> IOErrorType
ioeGetErrorString     :: IOError -> String
ioeGetLocation        :: IOError -> String
ioeGetHandle          :: IOError -> Maybe Handle
ioeGetFileName        :: IOError -> Maybe FilePath

ioeGetErrorType ioe = ioe_type ioe

ioeGetErrorString ioe
   | isUserErrorType (ioe_type ioe) = ioe_description ioe
   | otherwise                      = show (ioe_type ioe)

ioeGetLocation ioe = ioe_location ioe

ioeGetHandle ioe = ioe_handle ioe

ioeGetFileName ioe = ioe_filename ioe

ioeSetErrorType   :: IOError -> IOErrorType -> IOError
ioeSetErrorString :: IOError -> String      -> IOError
ioeSetLocation    :: IOError -> String      -> IOError
ioeSetHandle      :: IOError -> Handle      -> IOError
ioeSetFileName    :: IOError -> FilePath    -> IOError

ioeSetErrorType   ioe errtype  = ioe{ ioe_type = errtype }
ioeSetErrorString ioe str      = ioe{ ioe_description = str }
ioeSetLocation    ioe str      = ioe{ ioe_location = str }
ioeSetHandle      ioe hdl      = ioe{ ioe_handle = Just hdl }
ioeSetFileName    ioe filename = ioe{ ioe_filename = Just filename }

-- | Catch any 'IOError' that occurs in the computation and throw a
-- modified version.
modifyIOError :: (IOError -> IOError) -> IO a -> IO a
modifyIOError f io = catch io (\e -> ioError (f e))

-- -----------------------------------------------------------------------------
-- annotating an IOError

-- | Adds a location description and maybe a file path and file handle
-- to an 'IOError'.  If any of the file handle or file path is not given
-- the corresponding value in the 'IOError' remains unaltered.
annotateIOError :: IOError
              -> String
              -> Maybe Handle
              -> Maybe FilePath
              -> IOError
annotateIOError ioe loc hdl path =
  ioe{ ioe_handle = hdl `mplus` ioe_handle ioe,
       ioe_location = loc, ioe_filename = path `mplus` ioe_filename ioe }

-- | The 'catchIOError' function establishes a handler that receives any
-- 'IOError' raised in the action protected by 'catchIOError'.
-- An 'IOError' is caught by
-- the most recent handler established by one of the exception handling
-- functions.  These handlers are
-- not selective: all 'IOError's are caught.  Exception propagation
-- must be explicitly provided in a handler by re-raising any unwanted
-- exceptions.  For example, in
--
-- > f = catchIOError g (\e -> if IO.isEOFError e then return [] else ioError e)
--
-- the function @f@ returns @[]@ when an end-of-file exception
-- (cf. 'System.IO.Error.isEOFError') occurs in @g@; otherwise, the
-- exception is propagated to the next outer handler.
--
-- When an exception propagates outside the main program, the Haskell
-- system prints the associated 'IOError' value and exits the program.
--
-- Non-I\/O exceptions are not caught by this variant; to catch all
-- exceptions, use 'Control.Exception.catch' from "Control.Exception".
--
-- @since 4.4.0.0
catchIOError :: IO a -> (IOError -> IO a) -> IO a
catchIOError = catch


{-# LANGUAGE Unsafe #-}
{-# LANGUAGE NoImplicitPrelude #-}

-----------------------------------------------------------------------------
-- |
-- Module      :  System.IO.Unsafe
-- Copyright   :  (c) The University of Glasgow 2001
-- License     :  BSD-style (see the file libraries/base/LICENSE)
--
-- Maintainer  :  libraries@haskell.org
-- Stability   :  provisional
-- Portability :  portable
--
-- \"Unsafe\" IO operations.
--
-----------------------------------------------------------------------------

module System.IO.Unsafe (
   -- * Unsafe 'System.IO.IO' operations
   unsafePerformIO,
   unsafeDupablePerformIO,
   unsafeInterleaveIO,
   unsafeFixIO,
  ) where

import GHC.Base
import GHC.IO
import GHC.IORef
import GHC.Exception
import Control.Exception

-- | A slightly faster version of `System.IO.fixIO` that may not be
-- safe to use with multiple threads.  The unsafety arises when used
-- like this:
--
-- >  unsafeFixIO $ \r -> do
-- >     forkIO (print r)
-- >     return (...)
--
-- In this case, the child thread will receive a @NonTermination@
-- exception instead of waiting for the value of @r@ to be computed.
--
-- @since 4.5.0.0
unsafeFixIO :: (a -> IO a) -> IO a
unsafeFixIO k = do
  ref <- newIORef (throw NonTermination)
  ans <- unsafeDupableInterleaveIO (readIORef ref)
  result <- k ans
  writeIORef ref result
  return result


{-# LANGUAGE Safe #-}

-----------------------------------------------------------------------------
-- |
-- Module      :  System.Mem.StableName
-- Copyright   :  (c) The University of Glasgow 2001
-- License     :  BSD-style (see the file libraries/base/LICENSE)
--
-- Maintainer  :  libraries@haskell.org
-- Stability   :  experimental
-- Portability :  non-portable
--
-- Stable names are a way of performing fast (O(1)), not-quite-exact
-- comparison between objects.
--
-- Stable names solve the following problem: suppose you want to build
-- a hash table with Haskell objects as keys, but you want to use
-- pointer equality for comparison; maybe because the keys are large
-- and hashing would be slow, or perhaps because the keys are infinite
-- in size.  We can\'t build a hash table using the address of the
-- object as the key, because objects get moved around by the garbage
-- collector, meaning a re-hash would be necessary after every garbage
-- collection.
--
-------------------------------------------------------------------------------

module System.Mem.StableName (
  -- * Stable Names
  StableName,
  makeStableName,
  hashStableName,
  eqStableName
  ) where

import GHC.StableName


{-# LANGUAGE Trustworthy #-}

-----------------------------------------------------------------------------
-- |
-- Module      :  System.Mem.Weak
-- Copyright   :  (c) The University of Glasgow 2001
-- License     :  BSD-style (see the file libraries/base/LICENSE)
--
-- Maintainer  :  libraries@haskell.org
-- Stability   :  experimental
-- Portability :  non-portable
--
-- In general terms, a weak pointer is a reference to an object that is
-- not followed by the garbage collector - that is, the existence of a
-- weak pointer to an object has no effect on the lifetime of that
-- object.  A weak pointer can be de-referenced to find out
-- whether the object it refers to is still alive or not, and if so
-- to return the object itself.
--
-- Weak pointers are particularly useful for caches and memo tables.
-- To build a memo table, you build a data structure
-- mapping from the function argument (the key) to its result (the
-- value).  When you apply the function to a new argument you first
-- check whether the key\/value pair is already in the memo table.
-- The key point is that the memo table itself should not keep the
-- key and value alive.  So the table should contain a weak pointer
-- to the key, not an ordinary pointer.  The pointer to the value must
-- not be weak, because the only reference to the value might indeed be
-- from the memo table.
--
-- So it looks as if the memo table will keep all its values
-- alive for ever.  One way to solve this is to purge the table
-- occasionally, by deleting entries whose keys have died.
--
-- The weak pointers in this library
-- support another approach, called /finalization/.
-- When the key referred to by a weak pointer dies, the storage manager
-- arranges to run a programmer-specified finalizer.  In the case of memo
-- tables, for example, the finalizer could remove the key\/value pair
-- from the memo table.
--
-- Another difficulty with the memo table is that the value of a
-- key\/value pair might itself contain a pointer to the key.
-- So the memo table keeps the value alive, which keeps the key alive,
-- even though there may be no other references to the key so both should
-- die.  The weak pointers in this library provide a slight
-- generalisation of the basic weak-pointer idea, in which each
-- weak pointer actually contains both a key and a value.
--
-----------------------------------------------------------------------------

module System.Mem.Weak (
        -- * The @Weak@ type
        Weak,                   -- abstract

        -- * The general interface
        mkWeak,
        deRefWeak,
        finalize,

        -- * Specialised versions
        mkWeakPtr,
        addFinalizer,
        mkWeakPair,
        -- replaceFinaliser

        -- * A precise semantics

        -- $precise

        -- * Implementation notes

        -- $notes
   ) where

import GHC.Weak

-- | A specialised version of 'mkWeak', where the key and the value are
-- the same object:
--
-- > mkWeakPtr key finalizer = mkWeak key key finalizer
--
mkWeakPtr :: k -> Maybe (IO ()) -> IO (Weak k)
mkWeakPtr key finalizer = mkWeak key key finalizer

{-|
  A specialised version of 'mkWeakPtr', where the 'Weak' object
  returned is simply thrown away (however the finalizer will be
  remembered by the garbage collector, and will still be run
  when the key becomes unreachable).

  Note: adding a finalizer to a 'Foreign.ForeignPtr.ForeignPtr' using
  'addFinalizer' won't work; use the specialised version
  'Foreign.ForeignPtr.addForeignPtrFinalizer' instead.  For discussion
  see the 'Weak' type.
.
-}
addFinalizer :: key -> IO () -> IO ()
addFinalizer key finalizer = do
   _ <- mkWeakPtr key (Just finalizer) -- throw it away
   return ()

-- | A specialised version of 'mkWeak' where the value is actually a pair
-- of the key and value passed to 'mkWeakPair':
--
-- > mkWeakPair key val finalizer = mkWeak key (key,val) finalizer
--
-- The advantage of this is that the key can be retrieved by 'deRefWeak'
-- in addition to the value.
mkWeakPair :: k -> v -> Maybe (IO ()) -> IO (Weak (k,v))
mkWeakPair key val finalizer = mkWeak key (key,val) finalizer

{- $precise

The above informal specification is fine for simple situations, but
matters can get complicated.  In particular, it needs to be clear
exactly when a key dies, so that any weak pointers that refer to it
can be finalized.  Suppose, for example, the value of one weak pointer
refers to the key of another...does that keep the key alive?

The behaviour is simply this:

 *  If a weak pointer (object) refers to an /unreachable/
    key, it may be finalized.

 *  Finalization means (a) arrange that subsequent calls
    to 'deRefWeak' return 'Nothing'; and (b) run the finalizer.

This behaviour depends on what it means for a key to be reachable.
Informally, something is reachable if it can be reached by following
ordinary pointers from the root set, but not following weak pointers.
We define reachability more precisely as follows.

A heap object is /reachable/ if:

 * It is a member of the /root set/.

 * It is directly pointed to by a reachable object, other than
   a weak pointer object.

 * It is a weak pointer object whose key is reachable.

 * It is the value or finalizer of a weak pointer object whose key is reachable.
-}

{- $notes

A finalizer is not always called after its weak pointer\'s object becomes
unreachable. There are two situations that can cause this:

 * If the object becomes unreachable right before the program exits,
   then GC may not be performed. Finalizers run during GC, so finalizers
   associated with the object do not run if GC does not happen.

 * If a finalizer throws an exception, subsequent finalizers that had
   been queued to run after it do not get run. This behavior may change
   in a future release. See issue <https://ghc.haskell.org/trac/ghc/ticket/13167 13167>
   on the issue tracker. Writing a finalizer that throws exceptions is
   discouraged.

Other than these two caveats, users can always expect that a finalizer
will be run after its weak pointer\'s object becomes unreachable. However,
the second caveat means that users need to trust that all of their
transitive dependencies do not throw exceptions in finalizers, since
any finalizers can end up queued together.

-}


{-# LANGUAGE Trustworthy #-}
{-# LANGUAGE CPP, NoImplicitPrelude, CApiFFI #-}
{-# OPTIONS_HADDOCK not-home #-}

-----------------------------------------------------------------------------
-- |
-- Module      :  System.Posix.Internals
-- Copyright   :  (c) The University of Glasgow, 1992-2002
-- License     :  see libraries/base/LICENSE
--
-- Maintainer  :  cvs-ghc@haskell.org
-- Stability   :  internal
-- Portability :  non-portable (requires POSIX)
--
-- POSIX support layer for the standard libraries.
-- This library is built on *every* platform, including Win32.
--
-- Non-posix compliant in order to support the following features:
--      * S_ISSOCK (no sockets in POSIX)
--
-----------------------------------------------------------------------------

module System.Posix.Internals where

#include "HsBaseConfig.h"

import System.Posix.Types

import Foreign
import Foreign.C

-- import Data.Bits
import Data.Maybe

#if !defined(HTYPE_TCFLAG_T)
import System.IO.Error
#endif

import GHC.Base
import GHC.Num
import GHC.Real
import GHC.IO
import GHC.IO.IOMode
import GHC.IO.Exception
import GHC.IO.Device
#if !defined(mingw32_HOST_OS)
import {-# SOURCE #-} GHC.IO.Encoding (getFileSystemEncoding)
import qualified GHC.Foreign as GHC
#endif

-- ---------------------------------------------------------------------------
-- Debugging the base package

puts :: String -> IO ()
puts s = withCAStringLen (s ++ "\n") $ \(p, len) -> do
            -- In reality should be withCString, but assume ASCII to avoid loop
            -- if this is called by GHC.Foreign
           _ <- c_write 1 (castPtr p) (fromIntegral len)
           return ()

-- ---------------------------------------------------------------------------
-- Types

data {-# CTYPE "struct flock" #-} CFLock
data {-# CTYPE "struct group" #-} CGroup
data {-# CTYPE "struct lconv" #-} CLconv
data {-# CTYPE "struct passwd" #-} CPasswd
data {-# CTYPE "struct sigaction" #-} CSigaction
data {-# CTYPE "sigset_t" #-} CSigset
data {-# CTYPE "struct stat" #-}  CStat
data {-# CTYPE "struct termios" #-} CTermios
data {-# CTYPE "struct tm" #-} CTm
data {-# CTYPE "struct tms" #-} CTms
data {-# CTYPE "struct utimbuf" #-} CUtimbuf
data {-# CTYPE "struct utsname" #-} CUtsname

type FD = CInt

-- ---------------------------------------------------------------------------
-- stat()-related stuff

fdFileSize :: FD -> IO Integer
fdFileSize fd =
  allocaBytes sizeof_stat $ \ p_stat -> do
    throwErrnoIfMinus1Retry_ "fileSize" $
        c_fstat fd p_stat
    c_mode <- st_mode p_stat :: IO CMode
    if not (s_isreg c_mode)
        then return (-1)
        else do
      c_size <- st_size p_stat
      return (fromIntegral c_size)

fileType :: FilePath -> IO IODeviceType
fileType file =
  allocaBytes sizeof_stat $ \ p_stat -> do
  withFilePath file $ \p_file -> do
    throwErrnoIfMinus1Retry_ "fileType" $
      c_stat p_file p_stat
    statGetType p_stat

-- NOTE: On Win32 platforms, this will only work with file descriptors
-- referring to file handles. i.e., it'll fail for socket FDs.
fdStat :: FD -> IO (IODeviceType, CDev, CIno)
fdStat fd =
  allocaBytes sizeof_stat $ \ p_stat -> do
    throwErrnoIfMinus1Retry_ "fdType" $
        c_fstat fd p_stat
    ty <- statGetType p_stat
    dev <- st_dev p_stat
    ino <- st_ino p_stat
    return (ty,dev,ino)

fdType :: FD -> IO IODeviceType
fdType fd = do (ty,_,_) <- fdStat fd; return ty

statGetType :: Ptr CStat -> IO IODeviceType
statGetType p_stat = do
  c_mode <- st_mode p_stat :: IO CMode
  case () of
      _ | s_isdir c_mode        -> return Directory
        | s_isfifo c_mode || s_issock c_mode || s_ischr  c_mode
                                -> return Stream
        | s_isreg c_mode        -> return RegularFile
         -- Q: map char devices to RawDevice too?
        | s_isblk c_mode        -> return RawDevice
        | otherwise             -> ioError ioe_unknownfiletype

ioe_unknownfiletype :: IOException
ioe_unknownfiletype = IOError Nothing UnsupportedOperation "fdType"
                        "unknown file type"
                        Nothing
                        Nothing

fdGetMode :: FD -> IO IOMode
#if defined(mingw32_HOST_OS)
fdGetMode _ = do
    -- We don't have a way of finding out which flags are set on FDs
    -- on Windows, so make a handle that thinks that anything goes.
    let flags = o_RDWR
#else
fdGetMode fd = do
    flags <- throwErrnoIfMinus1Retry "fdGetMode"
                (c_fcntl_read fd const_f_getfl)
#endif
    let
       wH  = (flags .&. o_WRONLY) /= 0
       aH  = (flags .&. o_APPEND) /= 0
       rwH = (flags .&. o_RDWR) /= 0

       mode
         | wH && aH  = AppendMode
         | wH        = WriteMode
         | rwH       = ReadWriteMode
         | otherwise = ReadMode

    return mode

#if defined(mingw32_HOST_OS)
withFilePath :: FilePath -> (CWString -> IO a) -> IO a
withFilePath = withCWString

newFilePath :: FilePath -> IO CWString
newFilePath = newCWString

peekFilePath :: CWString -> IO FilePath
peekFilePath = peekCWString
#else

withFilePath :: FilePath -> (CString -> IO a) -> IO a
newFilePath :: FilePath -> IO CString
peekFilePath :: CString -> IO FilePath
peekFilePathLen :: CStringLen -> IO FilePath

withFilePath fp f = getFileSystemEncoding >>= \enc -> GHC.withCString enc fp f
newFilePath fp = getFileSystemEncoding >>= \enc -> GHC.newCString enc fp
peekFilePath fp = getFileSystemEncoding >>= \enc -> GHC.peekCString enc fp
peekFilePathLen fp = getFileSystemEncoding >>= \enc -> GHC.peekCStringLen enc fp

#endif

-- ---------------------------------------------------------------------------
-- Terminal-related stuff

#if defined(HTYPE_TCFLAG_T)

setEcho :: FD -> Bool -> IO ()
setEcho fd on = do
  tcSetAttr fd $ \ p_tios -> do
    lflag <- c_lflag p_tios :: IO CTcflag
    let new_lflag
         | on        = lflag .|. fromIntegral const_echo
         | otherwise = lflag .&. complement (fromIntegral const_echo)
    poke_c_lflag p_tios (new_lflag :: CTcflag)

getEcho :: FD -> IO Bool
getEcho fd = do
  tcSetAttr fd $ \ p_tios -> do
    lflag <- c_lflag p_tios :: IO CTcflag
    return ((lflag .&. fromIntegral const_echo) /= 0)

setCooked :: FD -> Bool -> IO ()
setCooked fd cooked =
  tcSetAttr fd $ \ p_tios -> do

    -- turn on/off ICANON
    lflag <- c_lflag p_tios :: IO CTcflag
    let new_lflag | cooked    = lflag .|. (fromIntegral const_icanon)
                  | otherwise = lflag .&. complement (fromIntegral const_icanon)
    poke_c_lflag p_tios (new_lflag :: CTcflag)

    -- set VMIN & VTIME to 1/0 respectively
    when (not cooked) $ do
            c_cc <- ptr_c_cc p_tios
            let vmin  = (c_cc `plusPtr` (fromIntegral const_vmin))  :: Ptr Word8
                vtime = (c_cc `plusPtr` (fromIntegral const_vtime)) :: Ptr Word8
            poke vmin  1
            poke vtime 0

tcSetAttr :: FD -> (Ptr CTermios -> IO a) -> IO a
tcSetAttr fd fun = do
     allocaBytes sizeof_termios  $ \p_tios -> do
        throwErrnoIfMinus1Retry_ "tcSetAttr"
           (c_tcgetattr fd p_tios)

        -- Save a copy of termios, if this is a standard file descriptor.
        -- These terminal settings are restored in hs_exit().
        when (fd <= 2) $ do
          p <- get_saved_termios fd
          when (p == nullPtr) $ do
             saved_tios <- mallocBytes sizeof_termios
             copyBytes saved_tios p_tios sizeof_termios
             set_saved_termios fd saved_tios

        -- tcsetattr() when invoked by a background process causes the process
        -- to be sent SIGTTOU regardless of whether the process has TOSTOP set
        -- in its terminal flags (try it...).  This function provides a
        -- wrapper which temporarily blocks SIGTTOU around the call, making it
        -- transparent.
        allocaBytes sizeof_sigset_t $ \ p_sigset -> do
          allocaBytes sizeof_sigset_t $ \ p_old_sigset -> do
             throwErrnoIfMinus1_ "sigemptyset" $
                 c_sigemptyset p_sigset
             throwErrnoIfMinus1_ "sigaddset" $
                 c_sigaddset   p_sigset const_sigttou
             throwErrnoIfMinus1_ "sigprocmask" $
                 c_sigprocmask const_sig_block p_sigset p_old_sigset
             r <- fun p_tios  -- do the business
             throwErrnoIfMinus1Retry_ "tcSetAttr" $
                 c_tcsetattr fd const_tcsanow p_tios
             throwErrnoIfMinus1_ "sigprocmask" $
                 c_sigprocmask const_sig_setmask p_old_sigset nullPtr
             return r

foreign import ccall unsafe "HsBase.h __hscore_get_saved_termios"
   get_saved_termios :: CInt -> IO (Ptr CTermios)

foreign import ccall unsafe "HsBase.h __hscore_set_saved_termios"
   set_saved_termios :: CInt -> (Ptr CTermios) -> IO ()

#else

-- 'raw' mode for Win32 means turn off 'line input' (=> buffering and
-- character translation for the console.) The Win32 API for doing
-- this is GetConsoleMode(), which also requires echoing to be disabled
-- when turning off 'line input' processing. Notice that turning off
-- 'line input' implies enter/return is reported as '\r' (and it won't
-- report that character until another character is input..odd.) This
-- latter feature doesn't sit too well with IO actions like IO.hGetLine..
-- consider yourself warned.
setCooked :: FD -> Bool -> IO ()
setCooked fd cooked = do
  x <- set_console_buffering fd (if cooked then 1 else 0)
  if (x /= 0)
   then ioError (ioe_unk_error "setCooked" "failed to set buffering")
   else return ()

ioe_unk_error :: String -> String -> IOException
ioe_unk_error loc msg
 = ioeSetErrorString (mkIOError OtherError loc Nothing Nothing) msg

-- Note: echoing goes hand in hand with enabling 'line input' / raw-ness
-- for Win32 consoles, hence setEcho ends up being the inverse of setCooked.
setEcho :: FD -> Bool -> IO ()
setEcho fd on = do
  x <- set_console_echo fd (if on then 1 else 0)
  if (x /= 0)
   then ioError (ioe_unk_error "setEcho" "failed to set echoing")
   else return ()

getEcho :: FD -> IO Bool
getEcho fd = do
  r <- get_console_echo fd
  if (r == (-1))
   then ioError (ioe_unk_error "getEcho" "failed to get echoing")
   else return (r == 1)

foreign import ccall unsafe "consUtils.h set_console_buffering__"
   set_console_buffering :: CInt -> CInt -> IO CInt

foreign import ccall unsafe "consUtils.h set_console_echo__"
   set_console_echo :: CInt -> CInt -> IO CInt

foreign import ccall unsafe "consUtils.h get_console_echo__"
   get_console_echo :: CInt -> IO CInt

foreign import ccall unsafe "consUtils.h is_console__"
   is_console :: CInt -> IO CInt

#endif

-- ---------------------------------------------------------------------------
-- Turning on non-blocking for a file descriptor

setNonBlockingFD :: FD -> Bool -> IO ()
#if !defined(mingw32_HOST_OS)
setNonBlockingFD fd set = do
  flags <- throwErrnoIfMinus1Retry "setNonBlockingFD"
                 (c_fcntl_read fd const_f_getfl)
  let flags' | set       = flags .|. o_NONBLOCK
             | otherwise = flags .&. complement o_NONBLOCK
  when (flags /= flags') $ do
    -- An error when setting O_NONBLOCK isn't fatal: on some systems
    -- there are certain file handles on which this will fail (eg. /dev/null
    -- on FreeBSD) so we throw away the return code from fcntl_write.
    _ <- c_fcntl_write fd const_f_setfl (fromIntegral flags')
    return ()
#else

-- bogus defns for win32
setNonBlockingFD _ _ = return ()

#endif

-- -----------------------------------------------------------------------------
-- Set close-on-exec for a file descriptor

#if !defined(mingw32_HOST_OS)
setCloseOnExec :: FD -> IO ()
setCloseOnExec fd = do
  throwErrnoIfMinus1_ "setCloseOnExec" $
    c_fcntl_write fd const_f_setfd const_fd_cloexec
#endif

-- -----------------------------------------------------------------------------
-- foreign imports

#if !defined(mingw32_HOST_OS)
type CFilePath = CString
#else
type CFilePath = CWString
#endif

foreign import ccall unsafe "HsBase.h __hscore_open"
   c_open :: CFilePath -> CInt -> CMode -> IO CInt

foreign import ccall safe "HsBase.h __hscore_open"
   c_safe_open :: CFilePath -> CInt -> CMode -> IO CInt

foreign import ccall unsafe "HsBase.h __hscore_fstat"
   c_fstat :: CInt -> Ptr CStat -> IO CInt

foreign import ccall unsafe "HsBase.h __hscore_lstat"
   lstat :: CFilePath -> Ptr CStat -> IO CInt

{- Note: Win32 POSIX functions
Functions that are not part of the POSIX standards were
at some point deprecated by Microsoft. This deprecation
was performed by renaming the functions according to the
C++ ABI Section 17.6.4.3.2b. This was done to free up the
namespace of normal Windows programs since Windows isn't
POSIX compliant anyway.

These were working before since the RTS was re-exporting
these symbols under the undeprecated names. This is no longer
being done. See #11223

See https://msdn.microsoft.com/en-us/library/ms235384.aspx
for more.

However since we can't hope to get people to support Windows
packages we should support the deprecated names. See #12497
-}
foreign import capi unsafe "unistd.h lseek"
   c_lseek :: CInt -> COff -> CInt -> IO COff

foreign import ccall unsafe "HsBase.h access"
   c_access :: CString -> CInt -> IO CInt

foreign import ccall unsafe "HsBase.h chmod"
   c_chmod :: CString -> CMode -> IO CInt

foreign import ccall unsafe "HsBase.h close"
   c_close :: CInt -> IO CInt

foreign import ccall unsafe "HsBase.h creat"
   c_creat :: CString -> CMode -> IO CInt

foreign import ccall unsafe "HsBase.h dup"
   c_dup :: CInt -> IO CInt

foreign import ccall unsafe "HsBase.h dup2"
   c_dup2 :: CInt -> CInt -> IO CInt

foreign import ccall unsafe "HsBase.h isatty"
   c_isatty :: CInt -> IO CInt

#if defined(mingw32_HOST_OS)
-- See Note: Windows types
foreign import capi unsafe "HsBase.h _read"
   c_read :: CInt -> Ptr Word8 -> CUInt -> IO CInt

-- See Note: Windows types
foreign import capi safe "HsBase.h _read"
   c_safe_read :: CInt -> Ptr Word8 -> CUInt -> IO CInt

foreign import ccall unsafe "HsBase.h _umask"
   c_umask :: CMode -> IO CMode

-- See Note: Windows types
foreign import capi unsafe "HsBase.h _write"
   c_write :: CInt -> Ptr Word8 -> CUInt -> IO CInt

-- See Note: Windows types
foreign import capi safe "HsBase.h _write"
   c_safe_write :: CInt -> Ptr Word8 -> CUInt -> IO CInt

foreign import ccall unsafe "HsBase.h _pipe"
   c_pipe :: Ptr CInt -> IO CInt
#else
-- We use CAPI as on some OSs (eg. Linux) this is wrapped by a macro
-- which redirects to the 64-bit-off_t versions when large file
-- support is enabled.

-- See Note: Windows types
foreign import capi unsafe "HsBase.h read"
   c_read :: CInt -> Ptr Word8 -> CSize -> IO CSsize

-- See Note: Windows types
foreign import capi safe "HsBase.h read"
   c_safe_read :: CInt -> Ptr Word8 -> CSize -> IO CSsize

foreign import ccall unsafe "HsBase.h umask"
   c_umask :: CMode -> IO CMode

-- See Note: Windows types
foreign import capi unsafe "HsBase.h write"
   c_write :: CInt -> Ptr Word8 -> CSize -> IO CSsize

-- See Note: Windows types
foreign import capi safe "HsBase.h write"
   c_safe_write :: CInt -> Ptr Word8 -> CSize -> IO CSsize

foreign import ccall unsafe "HsBase.h pipe"
   c_pipe :: Ptr CInt -> IO CInt
#endif

foreign import ccall unsafe "HsBase.h unlink"
   c_unlink :: CString -> IO CInt

foreign import capi unsafe "HsBase.h utime"
   c_utime :: CString -> Ptr CUtimbuf -> IO CInt

foreign import ccall unsafe "HsBase.h getpid"
   c_getpid :: IO CPid

foreign import ccall unsafe "HsBase.h __hscore_stat"
   c_stat :: CFilePath -> Ptr CStat -> IO CInt

foreign import ccall unsafe "HsBase.h __hscore_ftruncate"
   c_ftruncate :: CInt -> COff -> IO CInt

#if !defined(mingw32_HOST_OS)
foreign import capi unsafe "HsBase.h fcntl"
   c_fcntl_read  :: CInt -> CInt -> IO CInt

foreign import capi unsafe "HsBase.h fcntl"
   c_fcntl_write :: CInt -> CInt -> CLong -> IO CInt

foreign import capi unsafe "HsBase.h fcntl"
   c_fcntl_lock  :: CInt -> CInt -> Ptr CFLock -> IO CInt

foreign import ccall unsafe "HsBase.h fork"
   c_fork :: IO CPid

foreign import ccall unsafe "HsBase.h link"
   c_link :: CString -> CString -> IO CInt

-- capi is required at least on Android
foreign import capi unsafe "HsBase.h mkfifo"
   c_mkfifo :: CString -> CMode -> IO CInt

foreign import capi unsafe "signal.h sigemptyset"
   c_sigemptyset :: Ptr CSigset -> IO CInt

foreign import capi unsafe "signal.h sigaddset"
   c_sigaddset :: Ptr CSigset -> CInt -> IO CInt

foreign import capi unsafe "signal.h sigprocmask"
   c_sigprocmask :: CInt -> Ptr CSigset -> Ptr CSigset -> IO CInt

-- capi is required at least on Android
foreign import capi unsafe "HsBase.h tcgetattr"
   c_tcgetattr :: CInt -> Ptr CTermios -> IO CInt

-- capi is required at least on Android
foreign import capi unsafe "HsBase.h tcsetattr"
   c_tcsetattr :: CInt -> CInt -> Ptr CTermios -> IO CInt

foreign import ccall unsafe "HsBase.h waitpid"
   c_waitpid :: CPid -> Ptr CInt -> CInt -> IO CPid
#endif

-- POSIX flags only:
foreign import ccall unsafe "HsBase.h __hscore_o_rdonly" o_RDONLY :: CInt
foreign import ccall unsafe "HsBase.h __hscore_o_wronly" o_WRONLY :: CInt
foreign import ccall unsafe "HsBase.h __hscore_o_rdwr"   o_RDWR   :: CInt
foreign import ccall unsafe "HsBase.h __hscore_o_append" o_APPEND :: CInt
foreign import ccall unsafe "HsBase.h __hscore_o_creat"  o_CREAT  :: CInt
foreign import ccall unsafe "HsBase.h __hscore_o_excl"   o_EXCL   :: CInt
foreign import ccall unsafe "HsBase.h __hscore_o_trunc"  o_TRUNC  :: CInt

-- non-POSIX flags.
foreign import ccall unsafe "HsBase.h __hscore_o_noctty"   o_NOCTTY   :: CInt
foreign import ccall unsafe "HsBase.h __hscore_o_nonblock" o_NONBLOCK :: CInt
foreign import ccall unsafe "HsBase.h __hscore_o_binary"   o_BINARY   :: CInt

foreign import capi unsafe "sys/stat.h S_ISREG"  c_s_isreg  :: CMode -> CInt
foreign import capi unsafe "sys/stat.h S_ISCHR"  c_s_ischr  :: CMode -> CInt
foreign import capi unsafe "sys/stat.h S_ISBLK"  c_s_isblk  :: CMode -> CInt
foreign import capi unsafe "sys/stat.h S_ISDIR"  c_s_isdir  :: CMode -> CInt
foreign import capi unsafe "sys/stat.h S_ISFIFO" c_s_isfifo :: CMode -> CInt

s_isreg  :: CMode -> Bool
s_isreg cm = c_s_isreg cm /= 0
s_ischr  :: CMode -> Bool
s_ischr cm = c_s_ischr cm /= 0
s_isblk  :: CMode -> Bool
s_isblk cm = c_s_isblk cm /= 0
s_isdir  :: CMode -> Bool
s_isdir cm = c_s_isdir cm /= 0
s_isfifo :: CMode -> Bool
s_isfifo cm = c_s_isfifo cm /= 0

foreign import ccall unsafe "HsBase.h __hscore_sizeof_stat" sizeof_stat :: Int
foreign import ccall unsafe "HsBase.h __hscore_st_mtime" st_mtime :: Ptr CStat -> IO CTime
#if defined(mingw32_HOST_OS)
foreign import ccall unsafe "HsBase.h __hscore_st_size" st_size :: Ptr CStat -> IO Int64
#else
foreign import ccall unsafe "HsBase.h __hscore_st_size" st_size :: Ptr CStat -> IO COff
#endif
foreign import ccall unsafe "HsBase.h __hscore_st_mode" st_mode :: Ptr CStat -> IO CMode
foreign import ccall unsafe "HsBase.h __hscore_st_dev" st_dev :: Ptr CStat -> IO CDev
foreign import ccall unsafe "HsBase.h __hscore_st_ino" st_ino :: Ptr CStat -> IO CIno

foreign import ccall unsafe "HsBase.h __hscore_echo"         const_echo :: CInt
foreign import ccall unsafe "HsBase.h __hscore_tcsanow"      const_tcsanow :: CInt
foreign import ccall unsafe "HsBase.h __hscore_icanon"       const_icanon :: CInt
foreign import ccall unsafe "HsBase.h __hscore_vmin"         const_vmin   :: CInt
foreign import ccall unsafe "HsBase.h __hscore_vtime"        const_vtime  :: CInt
foreign import ccall unsafe "HsBase.h __hscore_sigttou"      const_sigttou :: CInt
foreign import ccall unsafe "HsBase.h __hscore_sig_block"    const_sig_block :: CInt
foreign import ccall unsafe "HsBase.h __hscore_sig_setmask"  const_sig_setmask :: CInt
foreign import ccall unsafe "HsBase.h __hscore_f_getfl"      const_f_getfl :: CInt
foreign import ccall unsafe "HsBase.h __hscore_f_setfl"      const_f_setfl :: CInt
foreign import ccall unsafe "HsBase.h __hscore_f_setfd"      const_f_setfd :: CInt
foreign import ccall unsafe "HsBase.h __hscore_fd_cloexec"   const_fd_cloexec :: CLong

#if defined(HTYPE_TCFLAG_T)
foreign import ccall unsafe "HsBase.h __hscore_sizeof_termios"  sizeof_termios :: Int
foreign import ccall unsafe "HsBase.h __hscore_sizeof_sigset_t" sizeof_sigset_t :: Int

foreign import ccall unsafe "HsBase.h __hscore_lflag" c_lflag :: Ptr CTermios -> IO CTcflag
foreign import ccall unsafe "HsBase.h __hscore_poke_lflag" poke_c_lflag :: Ptr CTermios -> CTcflag -> IO ()
foreign import ccall unsafe "HsBase.h __hscore_ptr_c_cc" ptr_c_cc  :: Ptr CTermios -> IO (Ptr Word8)
#endif

s_issock :: CMode -> Bool
#if !defined(mingw32_HOST_OS)
s_issock cmode = c_s_issock cmode /= 0
foreign import capi unsafe "sys/stat.h S_ISSOCK" c_s_issock :: CMode -> CInt
#else
s_issock _ = False
#endif

foreign import ccall unsafe "__hscore_bufsiz"  dEFAULT_BUFFER_SIZE :: Int
foreign import capi  unsafe "stdio.h value SEEK_CUR" sEEK_CUR :: CInt
foreign import capi  unsafe "stdio.h value SEEK_SET" sEEK_SET :: CInt
foreign import capi  unsafe "stdio.h value SEEK_END" sEEK_END :: CInt

{-
Note: Windows types

Windows' _read and _write have types that differ from POSIX. They take an
unsigned int for lengh and return a signed int where POSIX uses size_t and
ssize_t. Those are different on x86_64 and equivalent on x86. We import them
with the types in Microsoft's documentation which means that c_read,
c_safe_read, c_write and c_safe_write have different Haskell types depending on
the OS.
-}


{-# LANGUAGE CPP #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MagicHash #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE Trustworthy #-}

-----------------------------------------------------------------------------
-- |
-- Module      :  System.Posix.Types
-- Copyright   :  (c) The University of Glasgow 2002
-- License     :  BSD-style (see the file libraries/base/LICENSE)
--
-- Maintainer  :  libraries@haskell.org
-- Stability   :  provisional
-- Portability :  non-portable (requires POSIX)
--
-- POSIX data types: Haskell equivalents of the types defined by the
-- @\<sys\/types.h>@ C header on a POSIX system.
--
-----------------------------------------------------------------------------
#include "HsBaseConfig.h"

module System.Posix.Types (

  -- * POSIX data types

  -- ** Platform differences
  -- | This module contains platform specific information about types.
  --   __/As such the types presented on this page reflect the platform
  --   on which the documentation was generated and may not coincide with
  --   the types on your platform./__
#if defined(HTYPE_DEV_T)
  CDev(..),
#endif
#if defined(HTYPE_INO_T)
  CIno(..),
#endif
#if defined(HTYPE_MODE_T)
  CMode(..),
#endif
#if defined(HTYPE_OFF_T)
  COff(..),
#endif
#if defined(HTYPE_PID_T)
  CPid(..),
#endif
#if defined(HTYPE_SSIZE_T)
  CSsize(..),
#endif

#if defined(HTYPE_GID_T)
  CGid(..),
#endif
#if defined(HTYPE_NLINK_T)
  CNlink(..),
#endif
#if defined(HTYPE_UID_T)
  CUid(..),
#endif
#if defined(HTYPE_CC_T)
  CCc(..),
#endif
#if defined(HTYPE_SPEED_T)
  CSpeed(..),
#endif
#if defined(HTYPE_TCFLAG_T)
  CTcflag(..),
#endif
#if defined(HTYPE_RLIM_T)
  CRLim(..),
#endif
#if defined(HTYPE_BLKSIZE_T)
  CBlkSize(..),
#endif
#if defined(HTYPE_BLKCNT_T)
  CBlkCnt(..),
#endif
#if defined(HTYPE_CLOCKID_T)
  CClockId(..),
#endif
#if defined(HTYPE_FSBLKCNT_T)
  CFsBlkCnt(..),
#endif
#if defined(HTYPE_FSFILCNT_T)
  CFsFilCnt(..),
#endif
#if defined(HTYPE_ID_T)
  CId(..),
#endif
#if defined(HTYPE_KEY_T)
  CKey(..),
#endif
#if defined(HTYPE_TIMER_T)
  CTimer(..),
#endif

  Fd(..),

  -- See Note [Exporting constructors of marshallable foreign types]
  -- in Foreign.Ptr for why the constructors for these newtypes are
  -- exported.

#if defined(HTYPE_NLINK_T)
  LinkCount,
#endif
#if defined(HTYPE_UID_T)
  UserID,
#endif
#if defined(HTYPE_GID_T)
  GroupID,
#endif

  ByteCount,
  ClockTick,
  EpochTime,
  FileOffset,
  ProcessID,
  ProcessGroupID,
  DeviceID,
  FileID,
  FileMode,
  Limit
 ) where

import Foreign
import Foreign.C
-- import Data.Bits

import GHC.Base
import GHC.Enum
import GHC.Num
import GHC.Real
-- import GHC.Prim
import GHC.Read
import GHC.Show

#include "CTypes.h"

#if defined(HTYPE_DEV_T)
INTEGRAL_TYPE(CDev,HTYPE_DEV_T)
#endif
#if defined(HTYPE_INO_T)
INTEGRAL_TYPE(CIno,HTYPE_INO_T)
#endif
#if defined(HTYPE_MODE_T)
INTEGRAL_TYPE_WITH_CTYPE(CMode,mode_t,HTYPE_MODE_T)
#endif
#if defined(HTYPE_OFF_T)
INTEGRAL_TYPE(COff,HTYPE_OFF_T)
#endif
#if defined(HTYPE_PID_T)
INTEGRAL_TYPE(CPid,HTYPE_PID_T)
#endif

#if defined(HTYPE_SSIZE_T)
INTEGRAL_TYPE(CSsize,HTYPE_SSIZE_T)
#endif

#if defined(HTYPE_GID_T)
INTEGRAL_TYPE(CGid,HTYPE_GID_T)
#endif
#if defined(HTYPE_NLINK_T)
INTEGRAL_TYPE(CNlink,HTYPE_NLINK_T)
#endif

#if defined(HTYPE_UID_T)
INTEGRAL_TYPE(CUid,HTYPE_UID_T)
#endif
#if defined(HTYPE_CC_T)
ARITHMETIC_TYPE(CCc,HTYPE_CC_T)
#endif
#if defined(HTYPE_SPEED_T)
ARITHMETIC_TYPE(CSpeed,HTYPE_SPEED_T)
#endif
#if defined(HTYPE_TCFLAG_T)
INTEGRAL_TYPE(CTcflag,HTYPE_TCFLAG_T)
#endif
#if defined(HTYPE_RLIM_T)
INTEGRAL_TYPE(CRLim,HTYPE_RLIM_T)
#endif

#if defined(HTYPE_BLKSIZE_T)
-- | @since 4.10.0.0
INTEGRAL_TYPE_WITH_CTYPE(CBlkSize,blksize_t,HTYPE_BLKSIZE_T)
#endif
#if defined(HTYPE_BLKCNT_T)
-- | @since 4.10.0.0
INTEGRAL_TYPE_WITH_CTYPE(CBlkCnt,blkcnt_t,HTYPE_BLKCNT_T)
#endif
#if defined(HTYPE_CLOCKID_T)
-- | @since 4.10.0.0
INTEGRAL_TYPE_WITH_CTYPE(CClockId,clockid_t,HTYPE_CLOCKID_T)
#endif
#if defined(HTYPE_FSBLKCNT_T)
-- | @since 4.10.0.0
INTEGRAL_TYPE_WITH_CTYPE(CFsBlkCnt,fsblkcnt_t,HTYPE_FSBLKCNT_T)
#endif
#if defined(HTYPE_FSFILCNT_T)
-- | @since 4.10.0.0
INTEGRAL_TYPE_WITH_CTYPE(CFsFilCnt,fsfilcnt_t,HTYPE_FSFILCNT_T)
#endif
#if defined(HTYPE_ID_T)
-- | @since 4.10.0.0
INTEGRAL_TYPE_WITH_CTYPE(CId,id_t,HTYPE_ID_T)
#endif
#if defined(HTYPE_KEY_T)
-- | @since 4.10.0.0
INTEGRAL_TYPE_WITH_CTYPE(CKey,key_t,HTYPE_KEY_T)
#endif
#if defined(HTYPE_TIMER_T)
-- | @since 4.10.0.0
OPAQUE_TYPE_WITH_CTYPE(CTimer,timer_t,HTYPE_TIMER_T)
#endif

-- Make an Fd type rather than using CInt everywhere
INTEGRAL_TYPE(Fd,CInt)

-- nicer names, and backwards compatibility with POSIX library:
#if defined(HTYPE_NLINK_T)
type LinkCount      = CNlink
#endif
#if defined(HTYPE_UID_T)
type UserID         = CUid
#endif
#if defined(HTYPE_GID_T)
type GroupID        = CGid
#endif

type ByteCount      = CSize
type ClockTick      = CClock
type EpochTime      = CTime
type DeviceID       = CDev
type FileID         = CIno
type FileMode       = CMode
type ProcessID      = CPid
type FileOffset     = COff
type ProcessGroupID = CPid
type Limit          = CLong


-- !!! Testing that Show for Addr is OK..
module Main(main) where

import Foreign.Ptr

main :: IO ()
main = do
  print (nullPtr `plusPtr` maxBound)
  print (nullPtr `plusPtr` minBound)


import Control.Exception

-- We want to get the assertion failure, not the overflow exception.
-- trac #5561.

main :: IO ()
main = let e1 i = throw Overflow
       in assert False (e1 5)


{-# LANGUAGE ConstraintKinds, GADTs, RankNTypes #-}
{-# LANGUAGE TypeOperators, KindSignatures #-}
module CatEntail where
import Prelude hiding (id, (.))
import Data.Kind
import Control.Category

-- One dictionary to rule them all.
data Dict :: Constraint -> Type where
  Dict :: ctx => Dict ctx

-- Entailment.
-- Note the kind 'Constraint -> Constraint -> *'
newtype (|-) a b = Sub (a => Dict b)

(\\) :: a => (b => r) -> (a |- b) -> r
r \\ Sub Dict = r

reflexive :: a |- a
reflexive = Sub Dict

transitive :: (b |- c) -> (a |- b) -> a |- c
transitive f g = Sub $ Dict \\ f \\ g

instance Category (|-) where
  id  = reflexive
  (.) = transitive


{-# LANGUAGE PolyKinds, DataKinds, KindSignatures #-}
{-# LANGUAGE MultiParamTypeClasses, TypeFamilies #-}
module CatPairs where

import Prelude hiding (id, (.))
import Data.Kind (Type)
import Control.Monad ((>=>))
import Control.Category

-- Categories over pairs of types.
-- Taken from Twan van Laarhoven:
--   http://twanvl.nl/blog/haskell/categories-over-pairs-of-types

type family Fst (xy :: (Type, Type)) :: Type
type family Snd (xy :: (Type, Type)) :: Type
type instance Fst '(x,y) = x
type instance Snd '(x,y) = y

-- Ceci n'est pas une pipe
data Pipe i o u m r = Pipe { runPipe :: Either i u -> m (Either o r) }

(>+>) :: Monad m
      => Pipe io1 io2 ur1 m ur2
      -> Pipe io2 io3 ur2 m ur3
      -> Pipe io1 io3 ur1 m ur3
(>+>) (Pipe f) (Pipe g) = Pipe (f >=> g)

idP :: Monad m => Pipe i i r m r
idP = Pipe return

newtype WrapPipe m iu or = WrapPipe
    { unWrapPipe :: Pipe (Fst iu) (Fst or) (Snd iu) m (Snd or) }

instance Monad m => Category (WrapPipe m) where
  id    = WrapPipe idP
  x . y = WrapPipe (unWrapPipe y >+> unWrapPipe x)


-- !!! Testing the behaviour of Char.lexLitChar a little..

-- [March 2003]  We now allow \X and \O as escapes although the
-- spec only permits \x and \o.  Seems more consistent.

module Main where

import Data.Char

lex' str = do
  putStr ("lex " ++ str ++ " = ")
  print (lex str)

hexes = do
  lex' "'\\X00'"
  lex' "'\\x0f2'"
  lex' "'\\xf2'"
  lex' "'\\xf2t'"
  lex' "'\\X24'"
  lex' "'\\x24b'"
  lex' "'\\Xa4b'"
  lex' "'\\xa4bg'"

octs = do
  lex' "'\\o00'"
  lex' "'\\o05'"
  lex' "'\\o50'"
  lex' "'\\o72'"
  lex' "'\\o82'"
  lex' "'\\O24'"
  lex' "'\\O000024'"
  lex' "'\\024b'"
  lex' "'\\o14b'"
  lex' "'\\0a4bg'"

main = do
  hexes
  octs


-- !!! tests for large character values in literals
import Data.Char
main = do
  print (ord '\xffff')
  print (ord '\o7777')
  print (ord '\65535')
  print (map ord "\xffff\o7777\65535")


-- !!! Test getCPUTime

import System.CPUTime
import System.IO

main :: IO ()
main = do
    t28 <- timeFib 28
    t29 <- timeFib 29
    t30 <- timeFib 30
    print (t28 <= t29, t29 <= t30)

timeFib :: Integer -> IO Integer
timeFib n = do
    start <- getCPUTime
    print (nfib n)
    end <- getCPUTime
    return (end - start)

nfib :: Integer -> Integer
nfib n
  | n <= 1 = 1
  | otherwise = (n1 + n2 + 1)
  where
    n1 = nfib (n-1)
    n2 = nfib (n-2)


import Control.Monad
import Foreign.C.String

test_strings = ["Hello World", replicate 10000 'a']

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

main = do
    -- Try roundtripping some ASCII strings through the locale encoding
    forM test_strings $ \try_str -> do
        got_str <- withCString try_str peekCString
        got_str `assertEqual` try_str

    -- Try roundtripping some ASCII strings with lengths through the locale encoding
    forM test_strings $ \try_str -> do
        got_str <- withCStringLen try_str peekCStringLen
        got_str `assertEqual` try_str


module Main (main) where

import Data.Fixed

data B7

instance HasResolution B7 where
  resolution _ = 128

main :: IO ()
main = do doit 38.001
          doit 38.009
          doit 38.01
          doit 38.09
          print (read "38" :: Centi)
          doit (-38.001)
          doit (-38.009)
          doit (-38.01)
          doit (-38.09)
          print (read "-38" :: Centi)
          print (read "0.008" :: Fixed B7)
          print (read "-0.008" :: Fixed B7)
          print $ show (Just (-1 :: Milli))
          print $ show (Just (1 :: Milli))
          print ((read $ show (Just (-1 :: Deci))) :: Maybe Deci)
          print ((read $ show (Just (1 :: Deci))) :: Maybe Deci)

doit :: Centi -> IO ()
doit c = do let s = show c
                r = read s :: Centi
            putStrLn s
            print r


-- !!! Dynamic library regression tests
module Main(main) where

import Data.Dynamic

main :: IO ()
main = do
   test   "toDyn"   toDyn_list
   testIO "fromDyn" fromDyn_test

toDyn_list :: [Dynamic]
toDyn_list =
    [ toDyn (1::Int)
    , toDyn ('a')
    , toDyn False
    , toDyn ((-1.0)::Float)
    , toDyn (0.0::Double)
    , toDyn (1394::Integer)
    , toDyn (print "hello")
    , toDyn toDyn_list
    , toDyn ([]::[Int])
    , toDyn (Nothing  :: Maybe Int)
    , toDyn ((Just 2) :: Maybe Int)
    , toDyn ((Just 2) :: Maybe Int)
    , toDyn ((Left 3) :: Either Int Bool)
    , toDyn ((Right 3) :: Either Char Int)
    , toDyn ()
    , toDyn LT
    , toDyn ((),2::Int)
    , toDyn ((),2::Int,'a')
    , toDyn ((),2::Int,'a',1.0::Double)
    , toDyn ((),2::Int,'a',1.0::Double,Nothing::Maybe Bool)
    , toDyn ((+) :: Int -> Int -> Int)
    , toDyn ((+) :: Integer -> Integer -> Integer)
    , toDyn ((++) :: [Char] -> [Char] -> [Char])
    ]

-- Testing the conversion from Dynamic values:
fromDyn_test :: IO ()
fromDyn_test = do
   print (fromDyn (toDyn (1::Int)) (0::Int))
   print (fromDyn (toDyn ('a'::Char)) (0::Int))
   print (fromDyn (toDyn 'a') 'b')
   print (fromDyn (toDyn (1::Float)) (0::Float))
   print (fromDyn (toDyn (2::Float)) (0::Int))
   print (fromDyn (toDyn (3::Double)) (0::Double))
   print (fromDyn (toDyn (4::Double)) (0::Int))
   print (fromDyn (toDyn (5::Integer)) (0::Integer))
   print (fromDyn (toDyn (6::Integer)) False)
   print (fromDyn (toDyn [1,3,5::Integer]) ([]::[Integer]))
   print (fromDyn (toDyn (Just True)) (Nothing::Maybe Bool))
   print (fromDyn (toDyn (Left True::Either Bool Bool)) (Right False :: Either Bool Bool))
   print (fromDyn (toDyn LT) GT)
   print (fromDyn (toDyn ((+1)::Int->Int)) False)
   print ((fromDyn (toDyn ((+1)::Int->Int)) ((+2)::Int->Int)) 3)
   print ((fromDyn (toDyn ((++)::[Int]->[Int]->[Int])) ((undefined)::[Int]->[Int]->[Int])) [1] [2])

-- Misc test utilities:
test :: Show a => String -> [a] -> IO ()
test str ls = do
  putStrLn ("*** Testing: " ++ str ++ " ***")
  putStrLn (showListLn ls)

testIO :: String -> IO () -> IO ()
testIO str tst = do
  putStrLn ("*** Testing: " ++ str ++ " ***")
  tst

-- showListLn presents a list in a diff-friendly format.
-- showListLn [a1,..an]
--  =>
--      [ a1
--      , a2
--      ..
--      , an
--      ]
--
showListLn :: Show a => [a] -> String
showListLn [] = ""
showListLn ls = '[' : ' ' : go ls
 where
   go    [x] = show x ++ "\n]"
   go (x:xs) = show x ++ '\n':',':' ':go xs

{-
test8 = toDyn (mkAppTy listTc)
test9 :: Float
test9 = fromDyn test8 0

printf :: String -> [Dynamic] -> IO ()
printf str args = putStr (decode str args)
 where
  decode [] [] = []
  decode ('%':'n':cs) (d:ds) =
    (\ v -> show v++decode cs ds) (fromDyn  d (0::Int))
  decode ('%':'c':cs) (d:ds) =
    (\ v -> show v++decode cs ds) (fromDyn  d ('\0'))
  decode ('%':'b':cs) (d:ds) =
    (\ v -> show v++decode cs ds) (fromDyn  d (False::Bool))
  decode (x:xs) ds = x:decode xs ds

test10 :: IO ()
test10 = printf "%n = %c, that much is %b\n" [toDyn (3::Int),toDyn 'a', toDyn False]

-}


{-# LANGUAGE CPP #-}

-- !!! Testing Typeable instances
module Main(main) where

import Data.Dynamic
#if MIN_VERSION_base(4,10,0)
import Data.Typeable (TyCon, TypeRep, typeOf)
#endif
import Data.Array
import Data.Array.MArray
import Data.Array.ST
import Data.Array.IO
import Data.Array.Unboxed
import Data.Complex
import Data.Int
import Data.Word
import Data.IORef
import System.IO
import Control.Monad.ST
import System.Mem.StableName
import System.Mem.Weak
import Foreign.StablePtr
import Control.Exception
import Foreign.C.Types

main :: IO ()
main = do
   print (typeOf (undefined :: [()]))
   print (typeOf (undefined :: ()))
   print (typeOf (undefined :: ((),())))
   print (typeOf (undefined :: ((),(),())))
   print (typeOf (undefined :: ((),(),(),())))
   print (typeOf (undefined :: ((),(),(),(),())))
   print (typeOf (undefined :: (() -> ())))
   print (typeOf (undefined :: (Array () ())))
   print (typeOf (undefined :: Bool))
   print (typeOf (undefined :: Char))
   print (typeOf (undefined :: (Complex ())))
   print (typeOf (undefined :: Double))
   print (typeOf (undefined :: (Either () ())))
   print (typeOf (undefined :: Float))
   print (typeOf (undefined :: Handle))
   print (typeOf (undefined :: Int))
   print (typeOf (undefined :: Integer))
   print (typeOf (undefined :: IO ()))
   print (typeOf (undefined :: (Maybe ())))
   print (typeOf (undefined :: Ordering))

   print (typeOf (undefined :: Dynamic))
   print (typeOf (undefined :: (IORef ())))
   print (typeOf (undefined :: Int8))
   print (typeOf (undefined :: Int16))
   print (typeOf (undefined :: Int32))
   print (typeOf (undefined :: Int64))
   print (typeOf (undefined :: (ST () ())))
   print (typeOf (undefined :: (StableName ())))
   print (typeOf (undefined :: (StablePtr ())))
   print (typeOf (undefined :: TyCon))
   print (typeOf (undefined :: TypeRep))
   print (typeOf (undefined :: Word8))
   print (typeOf (undefined :: Word16))
   print (typeOf (undefined :: Word32))
   print (typeOf (undefined :: Word64))

   print (typeOf (undefined :: ArithException))
   print (typeOf (undefined :: AsyncException))
   print (typeOf (undefined :: (IOArray () ())))
   print (typeOf (undefined :: (IOUArray () ())))
   print (typeOf (undefined :: (STArray () () ())))
   print (typeOf (undefined :: (STUArray () () ())))
   print (typeOf (undefined :: (StableName ())))
   print (typeOf (undefined :: (StablePtr ())))
   print (typeOf (undefined :: (UArray () ())))
   print (typeOf (undefined :: (Weak ())))

   print (typeOf (undefined :: CChar))
   print (typeOf (undefined :: CSChar))
   print (typeOf (undefined :: CUChar))
   print (typeOf (undefined :: CShort))
   print (typeOf (undefined :: CUShort))
   print (typeOf (undefined :: CInt))
   print (typeOf (undefined :: CUInt))
   print (typeOf (undefined :: CLong))
   print (typeOf (undefined :: CULong))
   print (typeOf (undefined :: CLLong))
   print (typeOf (undefined :: CULLong))
   print (typeOf (undefined :: CFloat))
   print (typeOf (undefined :: CDouble))

   print (typeOf (undefined :: CPtrdiff))
   print (typeOf (undefined :: CSize))
   print (typeOf (undefined :: CWchar))
   print (typeOf (undefined :: CSigAtomic))
   print (typeOf (undefined :: CClock))
   print (typeOf (undefined :: CTime))


module Main where

-- Test generation of large TypeReps
-- (can be used as a benchmark)

import Data.Typeable

f :: Typeable a => Int -> a -> TypeRep
f 0 a = typeOf a
f n a = f (n-1) [a]

main = print (f 50000 () == f 50001 ())


module Main where

import Data.Typeable
import GHC.Fingerprint
import Text.Printf

f :: Typeable a => Int -> a -> [TypeRep]
f 0 a = []
f n a = typeOf a : f (n-1) [a]

-- pointwise compare 1000x1001 TypeReps, there should be exactly 1000 equalities
-- (can be used as a benchmark)
main = print $ length [ t1 | t1 <- f 1000 (), t2 <- f 1001 (), t1 == t2 ]

{-
 DEBUGGING code to help find bugs in the TypeRep implementation when
 this test fails:

 where
   g (x:xs) (y:ys)
     | x == y = g xs ys
     | otherwise = do
         print x
         case x of
           TypeRep f1 (TyCon f2 _ _ _) [TypeRep f3 _ _] ->
              printf "f1: %s\nf2: %s\nf3: %s\n" (show_fp f1) (show_fp f2) (show_fp f3)
         case y of
           TypeRep f1 (TyCon f2 _ _ _) [TypeRep f3 _ _] ->
              printf "f1: %s\nf2: %s\nf3: %s\n" (show_fp f1) (show_fp f2) (show_fp f3)
   g _ _ = return ()

   show_fp :: Fingerprint -> String
   show_fp (Fingerprint h l) =
       printf "%x %x" h l
-}


module Main where

import Data.Typeable

f :: Typeable a => Int -> a -> [TypeRep]
f 0 a = []
f n a = typeOf a : f (n-1) [a]

-- pointwise compare 1000x1000 different TypeReps, there should be no equalities
-- (can be used as a benchmark)

main = print $ length [ t1 | t1 <- replicate 1000 (f 10 ()),
                             t2 <- replicate 1000 (f 10 'a'),
                             t1 == t2 ]


module Main(main) where

import System.IO
import Data.Char

main = do
  isT <- hIsTerminalDevice stdin
  flg <- if not isT then return False else hGetEcho stdin
  print flg
  if not isT then hSetEcho stdin False else return ()
  hSetBuffering stdin NoBuffering
  interact (map toUpper)


-- !!! Testing the Prelude's Enum instances.
{-# OPTIONS_GHC -F -pgmF ./enum_processor.bat #-}
-- The processor is a non-CPP-based equivalent of
-- #define printTest(x) (do{ putStr ( "    " ++ "x" ++ " = " ) ; print (x) })
-- which is not portable to clang

module Main(main) where

import Control.Exception
import Data.Char
import Data.Ratio

main = do
   -- Enum Int
  putStrLn "Testing Enum Int: "
  testEnumInt
   -- Enum Integer
  putStrLn "Testing Enum Integer: "
  testEnumInteger
   -- Enum Char
  putStrLn "Testing Enum Char: "
  testEnumChar
   -- Enum ()
  putStrLn "Testing Enum (): "
  testEnumUnit
   -- Enum Ordering
  putStrLn "Testing Enum Ordering (derived): "
  testEnumOrdering
   -- Enum Bool
  putStrLn "Testing Enum Bool: "
  testEnumBool
   -- Enum Rational
  putStrLn "Testing Enum Rational: "
  testEnumRational
   -- Enum (Ratio Int)
  putStrLn "Testing Enum (Ratio Int): "
  testEnumRatioInt

{-
  Here's the properties that's supposed to
  hold for arithmetic sequences over Int:

   - [e1..]    = [e1, (e1+1), (e1+2), ..., maxBound]

   - [e1,e2..] = [e1, (e1+i), (e1+2*i), ... upper]
                 where
                  i = e2 - e1
                  upper
                   | i >  0 = maxBound
                   | i <  0 = minBound
                   | i == 0 = maxBound -- this really shouldn't matter (I feel.)
   - [e1..e3] = [e1, (e1+i), (e1+2*i),..e3]
                where
                 i
                  | e3 >= e1 = 1
                  | e3 <  e1 = (-1)

   - [e1,e2..e3] = res
                   where
                    i = e2 - e1

                    res
                     | i >= 0 && e3 <  e1 = []
                     | i <  0 && e3 >= e1 = []  -- (*)
                     | otherwise          = [e1, (e1+i), (e1 + 2*i), .. e3]

   Note:
     (*) - I think this instead should be (i < 0 && e3 > e1), since, as is,

            [x,(x+1) ..x] = [x]
            [x,(x-1) ..x] = []

           which does not look right, symmetrically speaking.

   The same properties hold for other Prelude types that
   are instances of Enum as well as being Bounded.

   For non-Bounded types (e.g., Float and Double), the properties are similar,
   except that the boundary tests become slightly different, i.e., when an
   element becomes greater than (e3 + i/2) (or less than (e3 + i/2) for negative
   i.)

  Q - does [(x::Double)..] have an upper bound? (ditto for Float.)

  OK - on with the regression testing.
-}

testEnumInt :: IO ()
testEnumInt = do
     -- succ
  printTest ((succ (0::Int)))
  printTest ((succ (minBound::Int)))
  mayBomb   (printTest ((succ (maxBound::Int))))

     -- pred
  printTest (pred (1::Int))
  printTest (pred (maxBound::Int))
  mayBomb   (printTest (pred (minBound::Int)))

     -- toEnum
  printTest ((map (toEnum::Int->Int) [1,minBound,maxBound]))

     -- fromEnum
  printTest ((map fromEnum [(1::Int),minBound,maxBound]))

     -- [x..] aka enumFrom
  printTest ((take 7 [(1::Int)..]))
  printTest ((take 7 [((maxBound::Int)-5)..])) -- just in case it doesn't catch the upper bound..

     -- [x,y..] aka enumFromThen
  printTest ((take 7 [(1::Int),2..]))
  printTest ((take 7 [(1::Int),7..]))
  printTest ((take 7 [(1::Int),1..]))
  printTest ((take 7 [(1::Int),0..]))
  printTest ((take 7 [(5::Int),2..]))
  let x = (minBound::Int) + 1
  printTest ((take 7 [x, x-1 ..]))
  let x = (minBound::Int) + 5
  printTest ((take 7 [x, x-1 ..]))
  let x = (maxBound::Int) - 5
  printTest ((take 7 [x, (x+1) ..]))

        -- Test overflow conditions
  printTest (([minBound::Int,1..]))
  printTest (([minBound::Int,0..]))
  printTest (([minBound::Int,-1..]))
  printTest (([maxBound::Int,1..]))
  printTest (([maxBound::Int,0..]))
  printTest (([maxBound::Int,-1..]))

     -- [x..y] aka enumFromTo
  printTest ((take 7 ([(1::Int) .. 5])))
  printTest ((take 4 ([(1::Int) .. 1])))
  printTest ((take 7 ([(1::Int) .. 0])))
  printTest ((take 7 ([(5::Int) .. 0])))
  printTest ((take 7 ([(maxBound-(5::Int)) .. maxBound])))
  printTest ((take 7 ([(minBound+(5::Int)) .. minBound])))

     -- [x,y..z] aka enumFromThenTo
  printTest ((take 7 [(5::Int),4..1]))
  printTest ((take 7 [(5::Int),3..1]))
  printTest ((take 7 [(5::Int),3..2]))
  printTest ((take 7 [(1::Int),2..1]))
  printTest ((take 7 [(2::Int),1..2]))
  printTest ((take 7 [(2::Int),1..1]))
  printTest ((take 7 [(2::Int),3..1]))

        -- Test overflow conditions
  printTest (([minBound, 1..maxBound::Int]))
  printTest (([minBound, 0..maxBound::Int]))
  printTest (([minBound,-1..maxBound::Int]))
  printTest (([minBound,-1..maxBound-1::Int]))
  printTest (([minBound,-1..maxBound-2::Int]))

  printTest (([maxBound, 1..minBound::Int]))
  printTest (([maxBound, 0..minBound::Int]))
  printTest (([maxBound, 0..minBound+1::Int]))
  printTest (([maxBound, 0..minBound+2::Int]))
  printTest (([maxBound,-1..minBound::Int]))

  let x = (maxBound::Int) - 4
  printTest ((take 7 [x,(x+1)..maxBound]))
  let x = (minBound::Int) + 5
  printTest ((take 7 [x,(x-1)..minBound]))

testEnumChar :: IO ()
testEnumChar = do
     -- succ
  printTest ((succ 'a'))
  printTest ((succ (minBound::Char)))
  mayBomb (printTest ((succ (maxBound::Char))))

     -- pred
  printTest ((pred 'b'))
  printTest (pred (maxBound::Char))
  mayBomb (printTest (pred (minBound::Char)))

     -- toEnum
  printTest ((map (toEnum::Int->Char) [123,ord (minBound::Char), ord(maxBound::Char)]))
  mayBomb (printTest ((toEnum::Int->Char) (minBound::Int)))

     -- fromEnum
  printTest ((map fromEnum ['X',minBound,maxBound]))

     -- [x..] aka enumFrom
  -- printTest ((take 7 ['\NUL' .. ]))
  do{ putStr ( "    " ++ "(take 7 ['\\NUL' .. ])" ++ " = " ) ; print (take 7 ['\NUL' .. ]) }
  -- printTest ((take 7 ['\250' .. ]))
  do{ putStr ( "    " ++ "(take 7 ['\\250' .. ])" ++ " = " ) ; print (take 7 ['\250' .. ]) }

     -- [x,y..] aka enumFromThen
  printTest ((take 7 ['a','b'..]))
  printTest ((take 7 ['a','e'..]))
  printTest ((take 7 ['a','a'..]))
  printTest ((take 7 ['z','y'..]))
  printTest ((take 7 ['z','v'..]))
  let x = '\1'
  -- printTest ((take 7 ['\1', '\0' ..]))
  do{ putStr ( "    " ++ "(take 7 ['\\1', '\\0' ..])" ++ " = " ) ; print (take 7 ['\1', '\0' ..]) }
  let x = '\5'
  -- printTest ((take 7 ['\5', '\4' ..]))
  do{ putStr ( "    " ++ "(take 7 ['\\5', '\\4' ..])" ++ " = " ) ; print (take 7 ['\5', '\4' ..]) }
  let x = (maxBound::Int) - 5
  -- printTest ((take 7 ['\250', '\251' ..]))
  do{ putStr ( "    " ++ "(take 7 ['\\250', '\\251' ..])" ++ " = " ) ; print (take 7 ['\250', '\251' ..]) }

     -- [x..y] aka enumFromTo
  printTest ((take 7 (['a' .. 'e'])))
  printTest ((take 4 (['a' .. 'a'])))
  printTest ((take 7 (['b' .. 'a'])))
  printTest ((take 7 (['e' .. 'a'])))
  -- printTest ((take 7 (['\250' .. '\255'])))
  do{ putStr ( "    " ++ "(take 7 (['\\250' .. '\\255']))" ++ " = " ) ; print (take 7 (['\250' .. '\255'])) }
  -- printTest ((take 7 (['\5' .. '\0'])))
  do{ putStr ( "    " ++ "(take 7 (['\\5' .. '\\0']))" ++ " = " ) ; print (take 7 (['\5' .. '\0'])) }

     -- [x,y..z] aka enumFromThenTo
  printTest ((take 7 ['f','e' .. 'b']))
  printTest ((take 7 ['g','e' .. 'b']))
  printTest ((take 7 ['g','d' .. 'c']))
  printTest ((take 7 ['b','c' .. 'b']))
  printTest ((take 7 ['c','b' .. 'c']))
  printTest ((take 7 ['c','b' .. 'b']))
  printTest ((take 7 ['c','d' .. 'b']))
  -- printTest ((take 7 ['\251', '\252' .. maxBound]))
  do{ putStr ( "    " ++ "(take 7 ['\\251', '\\252' .. maxBound])" ++ " = " ) ; print (take 7 ['\251', '\252' .. maxBound]) }
  -- printTest ((take 7 ['\5', '\4' .. minBound]))
  do{ putStr ( "    " ++ "(take 7 ['\\5', '\\4' .. minBound])" ++ " = " ) ; print (take 7 ['\5', '\4' .. minBound]) }

testEnumUnit :: IO ()
testEnumUnit = do
   -- succ:
  mayBomb (printTest ((succ ())))
  mayBomb (printTest ((succ (minBound::()))))
  mayBomb (printTest ((succ (maxBound::()))))

   -- pred:
  mayBomb (printTest ((pred ())))
  mayBomb (printTest ((pred (minBound::()))))
  mayBomb (printTest ((pred (maxBound::()))))

   -- toEnum:
  printTest ((toEnum 0)::())
  mayBomb   (printTest ((toEnum 1)::()))

   -- fromEnum:
  printTest ((fromEnum ()))

   -- enumFrom:
  printTest ((take 7 [()..]))

   -- enumFromThen:
  printTest ((take 7 [(),()..]))

   -- enumFromTo
  printTest ((take 7 [()..()]))

   -- enumFromThenTo
  printTest ((take 7 [(),()..()]))

testEnumOrdering :: IO ()
testEnumOrdering = do
   -- succ:
  printTest ((succ LT))
  printTest ((succ (minBound::Ordering)))
  mayBomb (printTest ((succ (maxBound::Ordering))))

   -- pred:
  printTest ((pred GT))
  printTest ((pred (maxBound::Ordering)))
  mayBomb (printTest ((pred (minBound::Ordering))))

   -- toEnum:
  printTest ((toEnum 0)::Ordering)
  mayBomb   (printTest ((toEnum 5)::Ordering))

   -- fromEnum:
  printTest ((fromEnum LT))
  printTest ((fromEnum EQ))
  printTest ((fromEnum GT))

   -- enumFrom:
  printTest (([LT ..]))
  printTest (([EQ ..]))
  printTest (([GT ..]))

   -- enumFromThen:
  printTest (([LT,EQ ..]))
  printTest (([EQ,GT ..]))
  printTest (([EQ,LT ..]))
  printTest (([LT,GT ..]))
  printTest (([GT,LT ..]))
  printTest (take 7 (([GT,GT ..])))
  printTest (take 7 (([LT,LT ..])))

   -- enumFromTo
  printTest (([LT .. GT]))
  printTest (([LT .. EQ]))
  printTest (([LT .. LT]))
  printTest (([GT .. LT]))
  printTest (([GT .. EQ]))
  printTest (([GT .. GT]))

   -- enumFromThenTo
  printTest (([LT,EQ .. GT]))
  printTest (([GT,EQ .. LT]))
  printTest (([GT,EQ .. EQ]))
  printTest (([GT,EQ .. GT]))
  printTest (([GT,EQ .. LT]))
  printTest (([LT,EQ .. LT]))
  printTest (([LT,EQ .. GT]))
  printTest (take 7 (([LT,LT .. GT])))
  printTest (take 7 (([GT,GT .. LT])))

testEnumBool :: IO ()
testEnumBool = do
   -- succ:
  printTest ((succ False))
  printTest ((succ (minBound::Bool)))
  mayBomb (printTest ((succ (maxBound::Bool))))

   -- pred:
  printTest ((pred True))
  printTest ((pred (maxBound::Bool)))
  mayBomb (printTest ((pred (minBound::Bool))))

   -- toEnum:
  printTest ((toEnum 0)::Bool)
  mayBomb   (printTest ((toEnum 5)::Bool))

   -- fromEnum:
  printTest ((fromEnum False))
  printTest ((fromEnum True))

   -- enumFrom:
  printTest (([False ..]))
  printTest (([True ..]))

   -- enumFromThen:
  printTest (([False,True ..]))
  printTest (([True,False ..]))
  printTest ((take 7 ([False,False ..])))
  printTest ((take 7 ([True,True ..])))

   -- enumFromTo
  printTest (([False .. True]))
  printTest (([True .. False]))

   -- enumFromThenTo
  printTest (take 7 ([False,False .. False]))
  printTest (take 7 ([False,False .. True]))
  printTest (take 7 ([False,True .. False]))
  printTest (take 7 ([False,True .. True]))
  printTest (take 7 ([True,False .. False]))
  printTest (take 7 ([True,False .. True]))
  printTest (take 7 ([True,True .. False]))
  printTest (take 7 ([True,True .. True]))

testEnumInteger :: IO ()
testEnumInteger = do
     -- succ
  printTest ((succ (0::Integer)))
  printTest ((succ ((-1)::Integer)))

     -- pred
  printTest (pred (1::Integer))
  printTest (pred (0::Integer))

     -- toEnum
  printTest ((map (toEnum::Int->Integer) [1,minBound,maxBound]))

     -- fromEnum
  printTest ((map fromEnum [(1::Integer),42,45]))

     -- [x..] aka enumFrom
  printTest ((take 7 [(1::Integer)..]))
  printTest ((take 7 [(-5::Integer)..]))

     -- [x,y..] aka enumFromThen
  printTest ((take 7 [(1::Integer),2..]))
  printTest ((take 7 [(1::Integer),7..]))
  printTest ((take 7 [(1::Integer),1..]))
  printTest ((take 7 [(1::Integer),0..]))
  printTest ((take 7 [(5::Integer),2..]))

     -- [x..y] aka enumFromTo
  printTest ((take 7 ([(1::Integer) .. 5])))
  printTest ((take 4 ([(1::Integer) .. 1])))
  printTest ((take 7 ([(1::Integer) .. 0])))
  printTest ((take 7 ([(5::Integer) .. 0])))

     -- [x,y..z] aka enumFromThenTo
  printTest ((take 7 [(5::Integer),4..1]))
  printTest ((take 7 [(5::Integer),3..1]))
  printTest ((take 7 [(5::Integer),3..2]))
  printTest ((take 7 [(1::Integer),2..1]))
  printTest ((take 7 [(2::Integer),1..2]))
  printTest ((take 7 [(2::Integer),1..1]))
  printTest ((take 7 [(2::Integer),3..1]))

testEnumRational :: IO ()
testEnumRational = do
     -- succ
  printTest ((succ (0::Rational)))
  printTest ((succ ((-1)::Rational)))

     -- pred
  printTest (pred (1::Rational))
  printTest (pred (0::Rational))

     -- toEnum
  printTest ((map (toEnum::Int->Rational) [1,minBound,maxBound]))

     -- fromEnum
  printTest ((map fromEnum [(1::Rational),42,45]))

     -- [x..] aka enumFrom
  printTest ((take 7 [(1::Rational)..]))
  printTest ((take 7 [(-5::Rational)..]))

     -- [x,y..] aka enumFromThen
  printTest ((take 7 [(1::Rational),2..]))
  printTest ((take 7 [(1::Rational),7..]))
  printTest ((take 7 [(1::Rational),1..]))
  printTest ((take 7 [(1::Rational),0..]))
  printTest ((take 7 [(5::Rational),2..]))

     -- [x..y] aka enumFromTo
  printTest ((take 7 ([(1::Rational) .. 5])))
  printTest ((take 4 ([(1::Rational) .. 1])))
  printTest ((take 7 ([(1::Rational) .. 0])))
  printTest ((take 7 ([(5::Rational) .. 0])))

     -- [x,y..z] aka enumFromThenTo
  printTest ((take 7 [(5::Rational),4..1]))
  printTest ((take 7 [(5::Rational),3..1]))
  printTest ((take 7 [(5::Rational),3..2]))
  printTest ((take 7 [(1::Rational),2..1]))
  printTest ((take 7 [(2::Rational),1..2]))
  printTest ((take 7 [(2::Rational),1..1]))
  printTest ((take 7 [(2::Rational),3..1]))

testEnumRatioInt :: IO ()
testEnumRatioInt = do
     -- succ
  printTest ((succ (0::Ratio Int)))
  printTest ((succ ((-1)::Ratio Int)))

     -- pred
  printTest (pred (1::Ratio Int))
  printTest (pred (0::Ratio Int))

     -- toEnum
  printTest ((map (toEnum::Int->Ratio Int) [1,minBound,maxBound]))

     -- fromEnum
  printTest ((map fromEnum [(1::Ratio Int),42,45]))

     -- [x..] aka enumFrom
  printTest ((take 7 [(1::Ratio Int)..]))
  printTest ((take 7 [(-5::Ratio Int)..]))
  printTest ((take 7 [((toEnum ((maxBound::Int)-5))::Ratio Int)..]))

     -- [x,y..] aka enumFromThen
  printTest ((take 7 [(1::Ratio Int),2..]))
  printTest ((take 7 [(1::Ratio Int),7..]))
  printTest ((take 7 [(1::Ratio Int),1..]))
  printTest ((take 7 [(1::Ratio Int),0..]))
  printTest ((take 7 [(5::Ratio Int),2..]))
  let x = (toEnum ((minBound::Int) + 1))::Ratio Int
  printTest ((take 7 [x, x-1 ..]))
  let x = (toEnum ((minBound::Int) + 5))::Ratio Int
  printTest ((take 7 [x, x-1 ..]))
  let x = (toEnum ((maxBound::Int) - 5))::Ratio Int
  printTest ((take 7 [x, (x+1) ..]))

     -- [x..y] aka enumFromTo
  printTest ((take 7 ([(1::Ratio Int) .. 5])))
  printTest ((take 4 ([(1::Ratio Int) .. 1])))
  printTest ((take 7 ([(1::Ratio Int) .. 0])))
  printTest ((take 7 ([(5::Ratio Int) .. 0])))
  let x = (toEnum (maxBound - (5::Int))) :: Ratio Int
  let y = (toEnum (maxBound::Int)) :: Ratio Int
  printTest ((take 7 ([x..y])))
  let x = (toEnum (minBound + (5::Int))) :: Ratio Int
  let y = (toEnum (minBound::Int)) :: Ratio Int
  printTest ((take 7 ([x..y])))

     -- [x,y..z] aka enumFromThenTo
  printTest ((take 7 [(5::Ratio Int),4..1]))
  printTest ((take 7 [(5::Ratio Int),3..1]))
  printTest ((take 7 [(5::Ratio Int),3..2]))
  printTest ((take 7 [(1::Ratio Int),2..1]))
  printTest ((take 7 [(2::Ratio Int),1..2]))
  printTest ((take 7 [(2::Ratio Int),1..1]))
  printTest ((take 7 [(2::Ratio Int),3..1]))

  let x = (toEnum ((maxBound::Int) - 4)) :: Ratio Int
  let y = (toEnum (maxBound::Int)) :: Ratio Int
  printTest ((take 7 [x,(x+1)..y]))
  let x = (toEnum ((minBound::Int) + 5)) :: Ratio Int
  let y = (toEnum (minBound::Int)) :: Ratio Int
  printTest ((take 7 [x,(x-1)..y]))

--
--
--  Utils
--
--

mayBomb x = catch x (\(ErrorCall e) -> putStrLn ("error " ++ show e))
   `catch` (\e -> putStrLn ("Fail: " ++ show (e :: SomeException)))

test :: Show a => String -> String -> a -> IO ()
test test_nm expected val = do
   putStr test_nm
   if expected == got then
      putStrLn ": SUCCEEDED"
    else do
      putStr   ": FAILED"
      putStrLn ("( expected: " ++ show expected ++ " , got: " ++ show got ++ " )")
  where
   got = show val


-- !!! Testing the Int Enum instances.
{-# OPTIONS_GHC -F -pgmF ./enum_processor.bat #-}
-- The processor is a non-CPP-based equivalent of
-- #define printTest(x) (do{ putStr ( "    " ++ "x" ++ " = " ) ; print (x) })
-- which is not portable to clang

module Main(main) where

import Control.Exception
import Data.Int

main = do
  putStrLn "Testing Enum Int8:"
  testEnumInt8
  putStrLn "Testing Enum Int16:"
  testEnumInt16
  putStrLn "Testing Enum Int32:"
  testEnumInt32
  putStrLn "Testing Enum Int64:"
  testEnumInt64

testEnumInt8 :: IO ()
testEnumInt8 = do
     -- succ
  printTest ((succ (0::Int8)))
  printTest ((succ (minBound::Int8)))
  mayBomb   (printTest ((succ (maxBound::Int8))))

     -- pred
  printTest (pred (1::Int8))
  printTest (pred (maxBound::Int8))
  mayBomb   (printTest (pred (minBound::Int8)))

     -- toEnum
  printTest ((map (toEnum::Int->Int8) [1, fromIntegral (minBound::Int8), fromIntegral (maxBound::Int8)]))
  mayBomb   (printTest ((toEnum (maxBound::Int))::Int8))

     -- fromEnum
  printTest ((map fromEnum [(1::Int8),minBound,maxBound]))

     -- [x..] aka enumFrom
  printTest ((take 7 [(1::Int8)..]))
  printTest ((take 7 [((maxBound::Int8)-5)..])) -- just in case it doesn't catch the upper bound..

     -- [x,y..] aka enumFromThen
  printTest ((take 7 [(1::Int8),2..]))
  printTest ((take 7 [(1::Int8),7..]))
  printTest ((take 7 [(1::Int8),1..]))
  printTest ((take 7 [(1::Int8),0..]))
  printTest ((take 7 [(5::Int8),2..]))
  let x = (minBound::Int8) + 1
  printTest ((take 7 [x, x-1 ..]))
  let x = (minBound::Int8) + 5
  printTest ((take 7 [x, x-1 ..]))
  let x = (maxBound::Int8) - 5
  printTest ((take 7 [x, (x+1) ..]))

     -- [x..y] aka enumFromTo
  printTest ((take 7 ([(1::Int8) .. 5])))
  printTest ((take 4 ([(1::Int8) .. 1])))
  printTest ((take 7 ([(1::Int8) .. 0])))
  printTest ((take 7 ([(5::Int8) .. 0])))
  printTest ((take 7 ([(maxBound-(5::Int8)) .. maxBound])))
  printTest ((take 7 ([(minBound+(5::Int8)) .. minBound])))

     -- [x,y..z] aka enumFromThenTo
  printTest ((take 7 [(5::Int8),4..1]))
  printTest ((take 7 [(5::Int8),3..1]))
  printTest ((take 7 [(5::Int8),3..2]))
  printTest ((take 7 [(1::Int8),2..1]))
  printTest ((take 7 [(2::Int8),1..2]))
  printTest ((take 7 [(2::Int8),1..1]))
  printTest ((take 7 [(2::Int8),3..1]))

  let x = (maxBound::Int8) - 4
  printTest ((take 7 [x,(x+1)..maxBound]))
  let x = (minBound::Int8) + 5
  printTest ((take 7 [x,(x-1)..minBound]))

testEnumInt16 :: IO ()
testEnumInt16 = do
     -- succ
  printTest ((succ (0::Int16)))
  printTest ((succ (minBound::Int16)))
  mayBomb   (printTest ((succ (maxBound::Int16))))

     -- pred
  printTest (pred (1::Int16))
  printTest (pred (maxBound::Int16))
  mayBomb   (printTest (pred (minBound::Int16)))

     -- toEnum
  printTest ((map (toEnum::Int->Int16) [1, fromIntegral (minBound::Int16), fromIntegral (maxBound::Int16)]))
  mayBomb   (printTest ((toEnum (maxBound::Int))::Int16))

     -- fromEnum
  printTest ((map fromEnum [(1::Int16),minBound,maxBound]))

     -- [x..] aka enumFrom
  printTest ((take 7 [(1::Int16)..]))
  printTest ((take 7 [((maxBound::Int16)-5)..])) -- just in case it doesn't catch the upper bound..

     -- [x,y..] aka enumFromThen
  printTest ((take 7 [(1::Int16),2..]))
  printTest ((take 7 [(1::Int16),7..]))
  printTest ((take 7 [(1::Int16),1..]))
  printTest ((take 7 [(1::Int16),0..]))
  printTest ((take 7 [(5::Int16),2..]))
  let x = (minBound::Int16) + 1
  printTest ((take 7 [x, x-1 ..]))
  let x = (minBound::Int16) + 5
  printTest ((take 7 [x, x-1 ..]))
  let x = (maxBound::Int16) - 5
  printTest ((take 7 [x, (x+1) ..]))

     -- [x..y] aka enumFromTo
  printTest ((take 7 ([(1::Int16) .. 5])))
  printTest ((take 4 ([(1::Int16) .. 1])))
  printTest ((take 7 ([(1::Int16) .. 0])))
  printTest ((take 7 ([(5::Int16) .. 0])))
  printTest ((take 7 ([(maxBound-(5::Int16)) .. maxBound])))
  printTest ((take 7 ([(minBound+(5::Int16)) .. minBound])))

     -- [x,y..z] aka enumFromThenTo
  printTest ((take 7 [(5::Int16),4..1]))
  printTest ((take 7 [(5::Int16),3..1]))
  printTest ((take 7 [(5::Int16),3..2]))
  printTest ((take 7 [(1::Int16),2..1]))
  printTest ((take 7 [(2::Int16),1..2]))
  printTest ((take 7 [(2::Int16),1..1]))
  printTest ((take 7 [(2::Int16),3..1]))

  let x = (maxBound::Int16) - 4
  printTest ((take 7 [x,(x+1)..maxBound]))
  let x = (minBound::Int16) + 5
  printTest ((take 7 [x,(x-1)..minBound]))

testEnumInt32 :: IO ()
testEnumInt32 = do
     -- succ
  printTest ((succ (0::Int32)))
  printTest ((succ (minBound::Int32)))
  mayBomb   (printTest ((succ (maxBound::Int32))))

     -- pred
  printTest (pred (1::Int32))
  printTest (pred (maxBound::Int32))
  mayBomb   (printTest (pred (minBound::Int32)))

     -- toEnum
  printTest ((map (toEnum::Int->Int32) [1, fromIntegral (minBound::Int32), fromIntegral (maxBound::Int32)]))
  mayBomb   (printTest ((toEnum (maxBound::Int))::Int32))

     -- fromEnum
  printTest ((map fromEnum [(1::Int32),minBound,maxBound]))

     -- [x..] aka enumFrom
  printTest ((take 7 [(1::Int32)..]))
  printTest ((take 7 [((maxBound::Int32)-5)..])) -- just in case it doesn't catch the upper bound..

     -- [x,y..] aka enumFromThen
  printTest ((take 7 [(1::Int32),2..]))
  printTest ((take 7 [(1::Int32),7..]))
  printTest ((take 7 [(1::Int32),1..]))
  printTest ((take 7 [(1::Int32),0..]))
  printTest ((take 7 [(5::Int32),2..]))
  let x = (minBound::Int32) + 1
  printTest ((take 7 [x, x-1 ..]))
  let x = (minBound::Int32) + 5
  printTest ((take 7 [x, x-1 ..]))
  let x = (maxBound::Int32) - 5
  printTest ((take 7 [x, (x+1) ..]))

     -- [x..y] aka enumFromTo
  printTest ((take 7 ([(1::Int32) .. 5])))
  printTest ((take 4 ([(1::Int32) .. 1])))
  printTest ((take 7 ([(1::Int32) .. 0])))
  printTest ((take 7 ([(5::Int32) .. 0])))
  printTest ((take 7 ([(maxBound-(5::Int32)) .. maxBound])))
  printTest ((take 7 ([(minBound+(5::Int32)) .. minBound])))

     -- [x,y..z] aka enumFromThenTo
  printTest ((take 7 [(5::Int32),4..1]))
  printTest ((take 7 [(5::Int32),3..1]))
  printTest ((take 7 [(5::Int32),3..2]))
  printTest ((take 7 [(1::Int32),2..1]))
  printTest ((take 7 [(2::Int32),1..2]))
  printTest ((take 7 [(2::Int32),1..1]))
  printTest ((take 7 [(2::Int32),3..1]))

  let x = (maxBound::Int32) - 4
  printTest ((take 7 [x,(x+1)..maxBound]))
  let x = (minBound::Int32) + 5
  printTest ((take 7 [x,(x-1)..minBound]))

testEnumInt64 :: IO ()
testEnumInt64 = do
     -- succ
  printTest ((succ (0::Int64)))
  printTest ((succ (minBound::Int64)))
  mayBomb   (printTest ((succ (maxBound::Int64))))

     -- pred
  printTest (pred (1::Int64))
  printTest (pred (maxBound::Int64))
  mayBomb   (printTest (pred (minBound::Int64)))

     -- toEnum
  mayBomb   (printTest ((map (toEnum::Int->Int64) [1, fromIntegral (minBound::Int64), fromIntegral (maxBound::Int64)])))
  mayBomb   (printTest ((toEnum (maxBound::Int))::Int64))

     -- fromEnum
  printTest ((map fromEnum [(1::Int64),fromIntegral (minBound::Int) ,fromIntegral (maxBound::Int)]))
  mayBomb   (printTest (fromEnum (maxBound::Int64)))

     -- [x..] aka enumFrom
  printTest ((take 7 [(1::Int64)..]))
  printTest ((take 7 [((maxBound::Int64)-5)..])) -- just in case it doesn't catch the upper bound..

     -- [x,y..] aka enumFromThen
  printTest ((take 7 [(1::Int64),2..]))
  printTest ((take 7 [(1::Int64),7..]))
  printTest ((take 7 [(1::Int64),1..]))
  printTest ((take 7 [(1::Int64),0..]))
  printTest ((take 7 [(5::Int64),2..]))
  let x = (minBound::Int64) + 1
  printTest ((take 7 [x, x-1 ..]))
  let x = (minBound::Int64) + 5
  printTest ((take 7 [x, x-1 ..]))
  let x = (maxBound::Int64) - 5
  printTest ((take 7 [x, (x+1) ..]))

     -- [x..y] aka enumFromTo
  printTest ((take 7 ([(1::Int64) .. 5])))
  printTest ((take 4 ([(1::Int64) .. 1])))
  printTest ((take 7 ([(1::Int64) .. 0])))
  printTest ((take 7 ([(5::Int64) .. 0])))
  printTest ((take 7 ([(maxBound-(5::Int64)) .. maxBound])))
  printTest ((take 7 ([(minBound+(5::Int64)) .. minBound])))

     -- [x,y..z] aka enumFromThenTo
  printTest ((take 7 [(5::Int64),4..1]))
  printTest ((take 7 [(5::Int64),3..1]))
  printTest ((take 7 [(5::Int64),3..2]))
  printTest ((take 7 [(1::Int64),2..1]))
  printTest ((take 7 [(2::Int64),1..2]))
  printTest ((take 7 [(2::Int64),1..1]))
  printTest ((take 7 [(2::Int64),3..1]))

  let x = (maxBound::Int64) - 4
  printTest ((take 7 [x,(x+1)..maxBound]))
  let x = (minBound::Int64) + 5
  printTest ((take 7 [x,(x-1)..minBound]))

--
--
--  Utils
--
--

mayBomb x = catch x (\(ErrorCall e) -> putStrLn ("error " ++ show e))
  `catch` (\e -> putStrLn ("Fail: " ++ show (e :: SomeException)))


-- !!! Testing the Word Enum instances.
{-# OPTIONS_GHC -F -pgmF ./enum_processor.bat #-}
-- The processor is a non-CPP-based equivalent of
-- #define printTest(x) (do{ putStr ( "    " ++ "x" ++ " = " ) ; print (x) })
-- which is not portable to clang

module Main(main) where

import Control.Exception
import Data.Word
import Data.Int

main = do
  putStrLn "Testing Enum Word8:"
  testEnumWord8
  putStrLn "Testing Enum Word16:"
  testEnumWord16
  putStrLn "Testing Enum Word32:"
  testEnumWord32
  putStrLn "Testing Enum Word64:"
  testEnumWord64

testEnumWord8 :: IO ()
testEnumWord8 = do
     -- succ
  printTest ((succ (0::Word8)))
  printTest ((succ (minBound::Word8)))
  mayBomb   (printTest ((succ (maxBound::Word8))))

     -- pred
  printTest (pred (1::Word8))
  printTest (pred (maxBound::Word8))
  mayBomb   (printTest (pred (minBound::Word8)))

     -- toEnum
  printTest ((map (toEnum::Int->Word8) [1, fromIntegral (minBound::Word8)::Int, fromIntegral (maxBound::Word8)::Int]))
  mayBomb   (printTest ((toEnum (maxBound::Int))::Word8))

     -- fromEnum
  printTest ((map fromEnum [(1::Word8),minBound,maxBound]))

     -- [x..] aka enumFrom
  printTest ((take 7 [(1::Word8)..]))
  printTest ((take 7 [((maxBound::Word8)-5)..])) -- just in case it doesn't catch the upper bound..

     -- [x,y..] aka enumFromThen
  printTest ((take 7 [(1::Word8),2..]))
  printTest ((take 7 [(1::Word8),7..]))
  printTest ((take 7 [(1::Word8),1..]))
  printTest ((take 7 [(1::Word8),0..]))
  printTest ((take 7 [(5::Word8),2..]))
  let x = (minBound::Word8) + 1
  printTest ((take 7 [x, x-1 ..]))
  let x = (minBound::Word8) + 5
  printTest ((take 7 [x, x-1 ..]))
  let x = (maxBound::Word8) - 5
  printTest ((take 7 [x, (x+1) ..]))

     -- [x..y] aka enumFromTo
  printTest ((take 7 ([(1::Word8) .. 5])))
  printTest ((take 4 ([(1::Word8) .. 1])))
  printTest ((take 7 ([(1::Word8) .. 0])))
  printTest ((take 7 ([(5::Word8) .. 0])))
  printTest ((take 7 ([(maxBound-(5::Word8)) .. maxBound])))
  printTest ((take 7 ([(minBound+(5::Word8)) .. minBound])))

     -- [x,y..z] aka enumFromThenTo
  printTest ((take 7 [(5::Word8),4..1]))
  printTest ((take 7 [(5::Word8),3..1]))
  printTest ((take 7 [(5::Word8),3..2]))
  printTest ((take 7 [(1::Word8),2..1]))
  printTest ((take 7 [(2::Word8),1..2]))
  printTest ((take 7 [(2::Word8),1..1]))
  printTest ((take 7 [(2::Word8),3..1]))

  let x = (maxBound::Word8) - 4
  printTest ((take 7 [x,(x+1)..maxBound]))
  let x = (minBound::Word8) + 5
  printTest ((take 7 [x,(x-1)..minBound]))

testEnumWord16 :: IO ()
testEnumWord16 = do
     -- succ
  printTest ((succ (0::Word16)))
  printTest ((succ (minBound::Word16)))
  mayBomb   (printTest ((succ (maxBound::Word16))))

     -- pred
  printTest (pred (1::Word16))
  printTest (pred (maxBound::Word16))
  mayBomb   (printTest (pred (minBound::Word16)))

     -- toEnum
  printTest ((map (toEnum::Int->Word16) [1, fromIntegral (minBound::Word16)::Int, fromIntegral (maxBound::Word16)::Int]))
  mayBomb   (printTest ((toEnum (maxBound::Int))::Word16))

     -- fromEnum
  printTest ((map fromEnum [(1::Word16),minBound,maxBound]))

     -- [x..] aka enumFrom
  printTest ((take 7 [(1::Word16)..]))
  printTest ((take 7 [((maxBound::Word16)-5)..])) -- just in case it doesn't catch the upper bound..

     -- [x,y..] aka enumFromThen
  printTest ((take 7 [(1::Word16),2..]))
  printTest ((take 7 [(1::Word16),7..]))
  printTest ((take 7 [(1::Word16),1..]))
  printTest ((take 7 [(1::Word16),0..]))
  printTest ((take 7 [(5::Word16),2..]))
  let x = (minBound::Word16) + 1
  printTest ((take 7 [x, x-1 ..]))
  let x = (minBound::Word16) + 5
  printTest ((take 7 [x, x-1 ..]))
  let x = (maxBound::Word16) - 5
  printTest ((take 7 [x, (x+1) ..]))

     -- [x..y] aka enumFromTo
  printTest ((take 7 ([(1::Word16) .. 5])))
  printTest ((take 4 ([(1::Word16) .. 1])))
  printTest ((take 7 ([(1::Word16) .. 0])))
  printTest ((take 7 ([(5::Word16) .. 0])))
  printTest ((take 7 ([(maxBound-(5::Word16)) .. maxBound])))
  printTest ((take 7 ([(minBound+(5::Word16)) .. minBound])))

     -- [x,y..z] aka enumFromThenTo
  printTest ((take 7 [(5::Word16),4..1]))
  printTest ((take 7 [(5::Word16),3..1]))
  printTest ((take 7 [(5::Word16),3..2]))
  printTest ((take 7 [(1::Word16),2..1]))
  printTest ((take 7 [(2::Word16),1..2]))
  printTest ((take 7 [(2::Word16),1..1]))
  printTest ((take 7 [(2::Word16),3..1]))

  let x = (maxBound::Word16) - 4
  printTest ((take 7 [x,(x+1)..maxBound]))
  let x = (minBound::Word16) + 5
  printTest ((take 7 [x,(x-1)..minBound]))

testEnumWord32 :: IO ()
testEnumWord32 = do
     -- succ
  printTest ((succ (0::Word32)))
  printTest ((succ (minBound::Word32)))
  mayBomb   (printTest ((succ (maxBound::Word32))))

     -- pred
  printTest (pred (1::Word32))
  printTest (pred (maxBound::Word32))
  mayBomb   (printTest (pred (minBound::Word32)))

     -- toEnum
  printTest ((map (toEnum::Int->Word32) [1, fromIntegral (minBound::Word32)::Int, fromIntegral (maxBound::Int32)::Int]))
  mayBomb   (printTest ((toEnum (maxBound::Int))::Word32))

     -- fromEnum
  printTest ((map fromEnum [(1::Word32),minBound,fromIntegral (maxBound::Int)]))
  mayBomb   (printTest (fromEnum (maxBound::Word32)))

     -- [x..] aka enumFrom
  printTest ((take 7 [(1::Word32)..]))
  printTest ((take 7 [((maxBound::Word32)-5)..])) -- just in case it doesn't catch the upper bound..

     -- [x,y..] aka enumFromThen
  printTest ((take 7 [(1::Word32),2..]))
  printTest ((take 7 [(1::Word32),7..]))
  printTest ((take 7 [(1::Word32),1..]))
  printTest ((take 7 [(1::Word32),0..]))
  printTest ((take 7 [(5::Word32),2..]))
  let x = (minBound::Word32) + 1
  printTest ((take 7 [x, x-1 ..]))
  let x = (minBound::Word32) + 5
  printTest ((take 7 [x, x-1 ..]))
  let x = (maxBound::Word32) - 5
  printTest ((take 7 [x, (x+1) ..]))

     -- [x..y] aka enumFromTo
  printTest ((take 7 ([(1::Word32) .. 5])))
  printTest ((take 4 ([(1::Word32) .. 1])))
  printTest ((take 7 ([(1::Word32) .. 0])))
  printTest ((take 7 ([(5::Word32) .. 0])))
  printTest ((take 7 ([(maxBound-(5::Word32)) .. maxBound])))
  printTest ((take 7 ([(minBound+(5::Word32)) .. minBound])))

     -- [x,y..z] aka enumFromThenTo
  printTest ((take 7 [(5::Word32),4..1]))
  printTest ((take 7 [(5::Word32),3..1]))
  printTest ((take 7 [(5::Word32),3..2]))
  printTest ((take 7 [(1::Word32),2..1]))
  printTest ((take 7 [(2::Word32),1..2]))
  printTest ((take 7 [(2::Word32),1..1]))
  printTest ((take 7 [(2::Word32),3..1]))

  let x = (maxBound::Word32) - 4
  printTest ((take 7 [x,(x+1)..maxBound]))
  let x = (minBound::Word32) + 5
  printTest ((take 7 [x,(x-1)..minBound]))

testEnumWord64 :: IO ()
testEnumWord64 = do
     -- succ
  printTest ((succ (0::Word64)))
  printTest ((succ (minBound::Word64)))
  mayBomb   (printTest ((succ (maxBound::Word64))))

     -- pred
  printTest (pred (1::Word64))
  printTest (pred (maxBound::Word64))
  mayBomb   (printTest (pred (minBound::Word64)))

     -- toEnum
  mayBomb   (printTest ((map (toEnum::Int->Word64) [1, fromIntegral (minBound::Word64)::Int, maxBound::Int])))
  mayBomb   (printTest ((toEnum (maxBound::Int))::Word64))

     -- fromEnum
  printTest ((map fromEnum [(1::Word64),minBound,fromIntegral (maxBound::Int)]))
  mayBomb   (printTest (fromEnum (maxBound::Word64)))

     -- [x..] aka enumFrom
  printTest ((take 7 [(1::Word64)..]))
  printTest ((take 7 [((maxBound::Word64)-5)..])) -- just in case it doesn't catch the upper bound..

     -- [x,y..] aka enumFromThen
  printTest ((take 7 [(1::Word64),2..]))
  printTest ((take 7 [(1::Word64),7..]))
  printTest ((take 7 [(1::Word64),1..]))
  printTest ((take 7 [(1::Word64),0..]))
  printTest ((take 7 [(5::Word64),2..]))
  let x = (minBound::Word64) + 1
  printTest ((take 7 [x, x-1 ..]))
  let x = (minBound::Word64) + 5
  printTest ((take 7 [x, x-1 ..]))
  let x = (maxBound::Word64) - 5
  printTest ((take 7 [x, (x+1) ..]))

     -- [x..y] aka enumFromTo
  printTest ((take 7 ([(1::Word64) .. 5])))
  printTest ((take 4 ([(1::Word64) .. 1])))
  printTest ((take 7 ([(1::Word64) .. 0])))
  printTest ((take 7 ([(5::Word64) .. 0])))
  printTest ((take 7 ([(maxBound-(5::Word64)) .. maxBound])))
  printTest ((take 7 ([(minBound+(5::Word64)) .. minBound])))

     -- [x,y..z] aka enumFromThenTo
  printTest ((take 7 [(5::Word64),4..1]))
  printTest ((take 7 [(5::Word64),3..1]))
  printTest ((take 7 [(5::Word64),3..2]))
  printTest ((take 7 [(1::Word64),2..1]))
  printTest ((take 7 [(2::Word64),1..2]))
  printTest ((take 7 [(2::Word64),1..1]))
  printTest ((take 7 [(2::Word64),3..1]))

  let x = (maxBound::Word64) - 4
  printTest ((take 7 [x,(x+1)..maxBound]))
  let x = (minBound::Word64) + 5
  printTest ((take 7 [x,(x-1)..minBound]))

--
--
--  Utils
--
--

mayBomb x = catch x (\(ErrorCall e) -> putStrLn ("error " ++ show e))
  `catch` (\e -> putStrLn ("Fail: " ++ show (e :: SomeException)))


{-# LANGUAGE ScopedTypeVariables #-}
import Control.Exception

-- enumFrom on basic numeric types should be strict
-- (possibly a bug in the Haskell Report: it specifies that
-- these ops should be strict in the section on Enum, but the
-- sample code in the Prelude doesn't agree, at least for
-- Float and Double).

main = do
  catch (evaluate [error "" :: Int ..] >> return ())     (\(e::SomeException) -> putStrLn "ok1")
  catch (evaluate [error "" :: Integer ..] >> return ()) (\(e::SomeException) -> putStrLn "ok2")
  catch (evaluate [error "" :: Float ..] >> return ())   (\(e::SomeException) -> putStrLn "ok3")
  catch (evaluate [error "" :: Double ..] >> return ())  (\(e::SomeException) -> putStrLn "ok4")


main :: IO ()
main = print (succ (1.0e20 :: Double))


import Data.Ratio
main = print [ 1, 4%(3::Int) .. 1 ]


module Main where

import Control.Exception
import System.IO.Error

main = do
  ioTest
  errorTest
  noMethodTest
  patMatchTest
  guardTest

ioTest :: IO ()
ioTest = catchJust (\e -> if isUserError e then Just () else Nothing)
                   (ioError (userError "wibble"))
                   (\() -> putStrLn "user exception caught")

errorTest :: IO ()
errorTest = do r <- try (evaluate (1 + error "call to 'error'"))
               case r of
                   Left (ErrorCall _) -> putStrLn "error call caught"
                   Right _            -> error "help!"

instance (Show a, Eq a) => Num (Maybe a) where {}

noMethodTest :: IO ()
noMethodTest = do r <- try (evaluate (Just () + Just ()))
                  case r of
                      Left (NoMethodError err) -> putStrLn "no method error"
                      Right _                  -> error "help!"

patMatchTest :: IO ()
patMatchTest = catch (case test1 [1..10] of () -> return ())
  (\ex -> case ex of
          PatternMatchFail err -> putStr err
          _                    -> error "help!")

test1 [] = ()

guardTest = catch (case test2 of () -> return ())
                  (\ex -> case ex of
                          PatternMatchFail err -> putStr err
                          _                    -> error "help!")

test2 | all (==0) [1] = ()


module Main where

import qualified Control.Exception as Exception
import System.IO.Error (mkIOError, catchIOError)
import Data.IORef

safeCatch :: IO () -> IO ()
safeCatch f = Exception.catch f
                  ((\_ -> return ()) :: Exception.SomeException -> IO ())

type Thrower = IO Bool

type Catcher = IO Bool -> IO () -> IO ()

checkCatch :: Catcher -> Thrower -> IO Bool
checkCatch catcher thrower = do
    ref <- newIORef False
    safeCatch (catcher thrower (writeIORef ref True))
    readIORef ref

data Named a = MkNamed String a

checkNamedCatch :: Named Catcher -> Named Thrower -> IO ()
checkNamedCatch (MkNamed cname catcher) (MkNamed tname thrower) = do
    didCatch <- checkCatch catcher thrower
    putStrLn (cname ++ (if didCatch then " CAUGHT " else " MISSED ") ++ tname)

checkNamedCatches :: [Named Catcher] -> [Named Thrower] -> IO ()
checkNamedCatches []     _      = return ()
checkNamedCatches _      []     = return ()
checkNamedCatches [c]    (t:tr) = do checkNamedCatch c t
                                     checkNamedCatches [c] tr
checkNamedCatches (c:cr) ts     = do checkNamedCatches [c] ts
                                     checkNamedCatches cr ts

-- throwers

returnThrower :: Named Thrower
returnThrower = MkNamed "return" (return True)

returnUndefinedThrower :: Named Thrower
returnUndefinedThrower = MkNamed "return undefined" (return undefined)

returnErrorThrower :: Named Thrower
returnErrorThrower = MkNamed "return error" (return (error "some error"))

undefinedThrower :: Named Thrower
undefinedThrower = MkNamed "undefined" undefined

failThrower :: Named Thrower
failThrower = MkNamed "fail" (fail "some failure")

errorThrower :: Named Thrower
errorThrower = MkNamed "error" (error "some error")

throwThrower :: Named Thrower
throwThrower = MkNamed "Exception.throw"
 (Exception.throw (Exception.ErrorCall "throw error"))

ioErrorErrorCallThrower :: Named Thrower
ioErrorErrorCallThrower = MkNamed "ioError ErrorCall"
 (Exception.throwIO (Exception.ErrorCall "throw error"))

ioErrorIOExceptionThrower :: Named Thrower
ioErrorIOExceptionThrower = MkNamed "ioError IOException"
 (Exception.throwIO (mkIOError undefined undefined undefined undefined))

returnThrowThrower :: Named Thrower
returnThrowThrower = MkNamed "return Exception.throw"
 (return (Exception.throw (Exception.ErrorCall "throw error")))

-- catchers

bindCatcher :: Named Catcher
bindCatcher = MkNamed ">>" (>>)

preludeCatchCatcher :: Named Catcher
preludeCatchCatcher = MkNamed "Prelude.catch"
 (\f cc -> catchIOError (f >> (return ())) (const cc))

ceCatchCatcher :: Named Catcher
ceCatchCatcher = MkNamed "Exception.catch"
 (\f cc -> Exception.catch (f >> (return ())) (const cc :: Exception.SomeException -> IO ()))

finallyCatcher :: Named Catcher
finallyCatcher = MkNamed "Exception.finally"
 (\f cc -> Exception.finally (f >> (return ())) cc)

main = checkNamedCatches
        [bindCatcher,preludeCatchCatcher,ceCatchCatcher,finallyCatcher]
        [returnThrower,returnUndefinedThrower,returnThrowThrower,returnErrorThrower,failThrower,
        errorThrower,throwThrower,ioErrorErrorCallThrower,ioErrorIOExceptionThrower,undefinedThrower]


{-# OPTIONS_GHC -Wall -Werror #-}

module Main where

import Data.Fixed

nums :: Fractional a => [a]
nums = [0,7,7.1,7.01,7.9,7.09,5 + 7,3.2 - 7.8,5.75 * (-2)]

main :: IO ()
main = do mapM_ putStrLn $ doit (nums :: [Micro])
          mapM_ putStrLn $ doit (nums :: [Pico])

doit :: HasResolution a => [Fixed a] -> [String]
doit xs = [ showFun (signFun x)
          | showFun <- [show, showFixed True]
          , signFun <- [id, negate]
          , x <- xs ]