-- | A class for categories.
-- id and (.) must form a monoid.
class Category cat where
- -- | the identity morphism
- id :: cat a a
+ -- | the identity morphism
+ id :: cat a a
- -- | morphism composition
- (.) :: cat b c -> cat a b -> cat a c
+ -- | morphism composition
+ (.) :: cat b c -> cat a b -> cat a c
{-# RULES
-"identity/left" forall p .
- id . p = p
-"identity/right" forall p .
- p . id = p
-"association" forall p q r .
- (p . q) . r = p . (q . r)
+"identity/left" forall p .
+ id . p = p
+"identity/right" forall p .
+ p . id = p
+"association" forall p q r .
+ (p . q) . r = p . (q . r)
#-}
instance Category (->) where
- id = Prelude.id
+ id = Prelude.id
#ifndef __HADDOCK__
-- Haddock 1.x cannot parse this:
- (.) = (Prelude..)
+ (.) = (Prelude..)
#endif
-- | Right-to-left composition
import Prelude
instance Functor ((->) r) where
- fmap = (.)
+ fmap = (.)
instance Monad ((->) r) where
- return = const
- f >>= k = \ r -> k (f r) r
+ return = const
+ f >>= k = \ r -> k (f r) r
instance Functor ((,) a) where
- fmap f (x,y) = (x, f y)
+ fmap f (x,y) = (x, f y)
instance Functor (Either a) where
- fmap _ (Left x) = Left x
- fmap f (Right y) = Right (f y)
+ fmap _ (Left x) = Left x
+ fmap f (Right y) = Right (f y)
module Foreign.C
( module Foreign.C.Types
- , module Foreign.C.String
- , module Foreign.C.Error
+ , module Foreign.C.String
+ , module Foreign.C.Error
) where
import Foreign.C.Types
where
loop s i = do
xval <- peekElemOff cp i
- let val = castCCharToChar xval
- val `seq` if i <= 0 then return (val:s) else loop (val:s) (i-1)
+ let val = castCCharToChar xval
+ val `seq` if i <= 0 then return (val:s) else loop (val:s) (i-1)
#endif
-- | Marshal a C string with explicit length into a Haskell string.
where
loop acc i = do
xval <- peekElemOff cp i
- let val = castCCharToChar xval
- -- blow away the coercion ASAP.
- if (val `seq` (i == 0))
- then return (val:acc)
- else loop (val:acc) (i-1)
+ let val = castCCharToChar xval
+ -- blow away the coercion ASAP.
+ if (val `seq` (i == 0))
+ then return (val:acc)
+ else loop (val:acc) (i-1)
#endif
-- | Marshal a Haskell string into a NUL terminated C string.
newCAString str = do
ptr <- mallocArray0 (length str)
let
- go [] n = pokeElemOff ptr n nUL
- go (c:cs) n = do pokeElemOff ptr n (castCharToCChar c); go cs (n+1)
+ go [] n = pokeElemOff ptr n nUL
+ go (c:cs) n = do pokeElemOff ptr n (castCharToCChar c); go cs (n+1)
go str 0
return ptr
#endif
newCAStringLen str = do
ptr <- mallocArray0 len
let
- go [] n = n `seq` return () -- make it strict in n
- go (c:cs) n = do pokeElemOff ptr n (castCharToCChar c); go cs (n+1)
+ go [] n = n `seq` return () -- make it strict in n
+ go (c:cs) n = do pokeElemOff ptr n (castCharToCChar c); go cs (n+1)
go str 0
return (ptr, len)
where
withCAString str f =
allocaArray0 (length str) $ \ptr ->
let
- go [] n = pokeElemOff ptr n nUL
- go (c:cs) n = do pokeElemOff ptr n (castCharToCChar c); go cs (n+1)
+ go [] n = pokeElemOff ptr n nUL
+ go (c:cs) n = do pokeElemOff ptr n (castCharToCChar c); go cs (n+1)
in do
go str 0
f ptr
withCAStringLen str f =
allocaArray len $ \ptr ->
let
- go [] n = n `seq` return () -- make it strict in n
- go (c:cs) n = do pokeElemOff ptr n (castCharToCChar c); go cs (n+1)
+ go [] n = n `seq` return () -- make it strict in n
+ go (c:cs) n = do pokeElemOff ptr n (castCharToCChar c); go cs (n+1)
in do
go str 0
f (ptr,len)
) where
import Control.Monad
-import Foreign.Ptr (Ptr, plusPtr)
-import Foreign.Storable (Storable(sizeOf,peekElemOff,pokeElemOff))
+import Foreign.Ptr (Ptr, plusPtr)
+import Foreign.Storable (Storable(sizeOf,peekElemOff,pokeElemOff))
import Foreign.Marshal.Alloc (mallocBytes, allocaBytes, reallocBytes)
import Foreign.Marshal.Utils (copyBytes, moveBytes)
#else
pokeArray ptr vals = go vals 0#
where go [] n# = return ()
- go (val:vals) n# = do pokeElemOff ptr (I# n#) val; go vals (n# +# 1#)
+ go (val:vals) n# = do pokeElemOff ptr (I# n#) val; go vals (n# +# 1#)
#endif
-- |Write the list elements consecutive into memory and terminate them with the
#else
pokeArray0 marker ptr vals = go vals 0#
where go [] n# = pokeElemOff ptr (I# n#) marker
- go (val:vals) n# = do pokeElemOff ptr (I# n#) val; go vals (n# +# 1#)
+ go (val:vals) n# = do pokeElemOff ptr (I# n#) val; go vals (n# +# 1#)
#endif
-- ** Marshalling of Boolean values (non-zero corresponds to 'True')
--
fromBool, -- :: Num a => Bool -> a
- toBool, -- :: Num a => a -> Bool
+ toBool, -- :: Num a => a -> Bool
-- ** Marshalling of Maybe values
--
maybeNew, -- :: ( a -> IO (Ptr a))
- -- -> (Maybe a -> IO (Ptr a))
+ -- -> (Maybe a -> IO (Ptr a))
maybeWith, -- :: ( a -> (Ptr b -> IO c) -> IO c)
- -- -> (Maybe a -> (Ptr b -> IO c) -> IO c)
+ -- -> (Maybe a -> (Ptr b -> IO c) -> IO c)
maybePeek, -- :: (Ptr a -> IO b )
- -- -> (Ptr a -> IO (Maybe b))
+ -- -> (Ptr a -> IO (Maybe b))
-- ** Marshalling lists of storable objects
--
) where
import Data.Maybe
-import Foreign.Ptr ( Ptr, nullPtr )
-import Foreign.Storable ( Storable(poke) )
-import Foreign.C.Types ( CSize )
-import Foreign.Marshal.Alloc ( malloc, alloca )
+import Foreign.Ptr ( Ptr, nullPtr )
+import Foreign.Storable ( Storable(poke) )
+import Foreign.C.Types ( CSize )
+import Foreign.Marshal.Alloc ( malloc, alloca )
#ifdef __GLASGOW_HASKELL__
import GHC.IOBase
-import GHC.Real ( fromIntegral )
+import GHC.Real ( fromIntegral )
import GHC.Num
import GHC.Base
#endif
#ifdef __NHC__
-import Foreign.C.Types ( CInt(..) )
+import Foreign.C.Types ( CInt(..) )
#endif
-- combined allocation and marshalling
-- * the 'nullPtr' is used to represent 'Nothing'
--
maybeNew :: ( a -> IO (Ptr a))
- -> (Maybe a -> IO (Ptr a))
+ -> (Maybe a -> IO (Ptr a))
maybeNew = maybe (return nullPtr)
-- |Converts a @withXXX@ combinator into one marshalling a value wrapped
-- into a 'Maybe', using 'nullPtr' to represent 'Nothing'.
--
maybeWith :: ( a -> (Ptr b -> IO c) -> IO c)
- -> (Maybe a -> (Ptr b -> IO c) -> IO c)
+ -> (Maybe a -> (Ptr b -> IO c) -> IO c)
maybeWith = maybe ($ nullPtr)
-- |Convert a peek combinator into a one returning 'Nothing' if applied to a
--
maybePeek :: (Ptr a -> IO b) -> Ptr a -> IO (Maybe b)
maybePeek peek ptr | ptr == nullPtr = return Nothing
- | otherwise = do a <- peek ptr; return (Just a)
+ | otherwise = do a <- peek ptr; return (Just a)
-- marshalling lists of storable objects
-- marshalled objects
--
withMany :: (a -> (b -> res) -> res) -- withXXX combinator for one object
- -> [a] -- storable objects
- -> ([b] -> res) -- action on list of marshalled obj.s
- -> res
+ -> [a] -- storable objects
+ -> ([b] -> res) -- action on list of marshalled obj.s
+ -> res
withMany _ [] f = f []
withMany withFoo (x:xs) f = withFoo x $ \x' ->
- withMany withFoo xs (\xs' -> f (x':xs'))
+ withMany withFoo xs (\xs' -> f (x':xs'))
-- Haskellish interface to memcpy and memmove
module Foreign.StablePtr
( -- * Stable references to Haskell values
- StablePtr -- abstract
+ StablePtr -- abstract
, newStablePtr -- :: a -> IO (StablePtr a)
, deRefStablePtr -- :: StablePtr a -> IO a
, freeStablePtr -- :: StablePtr a -> IO ()
, castStablePtrToPtr -- :: StablePtr a -> Ptr ()
, castPtrToStablePtr -- :: Ptr () -> StablePtr a
- , -- ** The C-side interface
+ , -- ** The C-side interface
- -- $cinterface
+ -- $cinterface
) where
#ifdef __GLASGOW_HASKELL__
module System.IO.Error (
-- * I\/O errors
- IOError, -- = IOException
+ IOError, -- = IOException
- userError, -- :: String -> IOError
+ userError, -- :: String -> IOError
#ifndef __NHC__
- mkIOError, -- :: IOErrorType -> String -> Maybe Handle
- -- -> Maybe FilePath -> IOError
+ mkIOError, -- :: IOErrorType -> String -> Maybe Handle
+ -- -> Maybe FilePath -> IOError
- annotateIOError, -- :: IOError -> String -> Maybe Handle
- -- -> Maybe FilePath -> IOError
+ annotateIOError, -- :: IOError -> String -> Maybe Handle
+ -- -> Maybe FilePath -> IOError
#endif
-- ** Classifying I\/O errors
- isAlreadyExistsError, -- :: IOError -> Bool
+ isAlreadyExistsError, -- :: IOError -> Bool
isDoesNotExistError,
isAlreadyInUseError,
isFullError,
-- ** Attributes of I\/O errors
#ifndef __NHC__
- ioeGetErrorType, -- :: IOError -> IOErrorType
- ioeGetLocation, -- :: IOError -> String
+ ioeGetErrorType, -- :: IOError -> IOErrorType
+ ioeGetLocation, -- :: IOError -> String
#endif
- ioeGetErrorString, -- :: IOError -> String
- ioeGetHandle, -- :: IOError -> Maybe Handle
- ioeGetFileName, -- :: IOError -> Maybe FilePath
+ ioeGetErrorString, -- :: IOError -> String
+ ioeGetHandle, -- :: IOError -> Maybe Handle
+ ioeGetFileName, -- :: IOError -> Maybe FilePath
#ifndef __NHC__
- ioeSetErrorType, -- :: IOError -> IOErrorType -> IOError
- ioeSetErrorString, -- :: IOError -> String -> IOError
- ioeSetLocation, -- :: IOError -> String -> IOError
- ioeSetHandle, -- :: IOError -> Handle -> IOError
- ioeSetFileName, -- :: IOError -> FilePath -> IOError
+ ioeSetErrorType, -- :: IOError -> IOErrorType -> IOError
+ ioeSetErrorString, -- :: IOError -> String -> IOError
+ ioeSetLocation, -- :: IOError -> String -> IOError
+ ioeSetHandle, -- :: IOError -> Handle -> IOError
+ ioeSetFileName, -- :: IOError -> FilePath -> IOError
#endif
-- * Types of I\/O error
- IOErrorType, -- abstract
+ IOErrorType, -- abstract
- alreadyExistsErrorType, -- :: IOErrorType
+ alreadyExistsErrorType, -- :: IOErrorType
doesNotExistErrorType,
alreadyInUseErrorType,
fullErrorType,
userErrorType,
-- ** 'IOErrorType' predicates
- isAlreadyExistsErrorType, -- :: IOErrorType -> Bool
+ isAlreadyExistsErrorType, -- :: IOErrorType -> Bool
isDoesNotExistErrorType,
isAlreadyInUseErrorType,
isFullErrorType,
-- * Throwing and catching I\/O errors
- ioError, -- :: IOError -> IO a
+ ioError, -- :: IOError -> IO a
- catch, -- :: IO a -> (IOError -> IO a) -> IO a
- try, -- :: IO a -> IO (Either IOError a)
+ catch, -- :: IO a -> (IOError -> IO a) -> IO a
+ try, -- :: IO a -> IO (Either IOError a)
#ifndef __NHC__
- modifyIOError, -- :: (IOError -> IOError) -> IO a -> IO a
+ modifyIOError, -- :: (IOError -> IOError) -> IO a -> IO a
#endif
) where
, try
, ioError
, userError
- , isAlreadyExistsError -- :: IOError -> Bool
+ , isAlreadyExistsError -- :: IOError -> Bool
, isDoesNotExistError
, isAlreadyInUseError
, isFullError
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_handle = maybe_hdl,
- ioe_filename = maybe_filename
- }
+ ioe_location = location,
+ ioe_description = "",
+ ioe_handle = maybe_hdl,
+ ioe_filename = maybe_filename
+ }
#ifdef __NHC__
mkIOError EOF location maybe_hdl maybe_filename =
EOFError location (fromJust maybe_hdl)
#ifdef __NHC__
data IOErrorType = AlreadyExists | NoSuchThing | ResourceBusy
- | ResourceExhausted | EOF | IllegalOperation
- | PermissionDenied | UserError
+ | ResourceExhausted | EOF | IllegalOperation
+ | PermissionDenied | UserError
#endif
-- | I\/O error where the operation failed because one of its arguments
permissionErrorType = PermissionDenied
-- | I\/O error that is programmer-defined.
-userErrorType :: IOErrorType
-userErrorType = UserError
+userErrorType :: IOErrorType
+userErrorType = UserError
-- -----------------------------------------------------------------------------
-- IOErrorType predicates
-- Miscellaneous
#if defined(__GLASGOW_HASKELL__) || defined(__HUGS__)
-ioeGetErrorType :: IOError -> IOErrorType
+ioeGetErrorType :: IOError -> IOErrorType
ioeGetErrorString :: IOError -> String
ioeGetLocation :: IOError -> String
ioeGetHandle :: IOError -> Maybe Handle
module System.IO.Unsafe (
-- * Unsafe 'System.IO.IO' operations
- unsafePerformIO, -- :: IO a -> a
- unsafeInterleaveIO, -- :: IO a -> IO a
+ unsafePerformIO, -- :: IO a -> a
+ unsafeInterleaveIO, -- :: IO a -> IO a
) where
#ifdef __GLASGOW_HASKELL__
-- 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)
+-- * S_ISSOCK (no sockets in POSIX)
--
-----------------------------------------------------------------------------
type CSigset = ()
type CStat = ()
type CTermios = ()
-type CTm = ()
-type CTms = ()
+type CTm = ()
+type CTms = ()
type CUtimbuf = ()
type CUtsname = ()
fdFileSize fd =
allocaBytes sizeof_stat $ \ p_stat -> do
throwErrnoIfMinus1Retry "fileSize" $
- c_fstat fd p_stat
+ c_fstat fd p_stat
c_mode <- st_mode p_stat :: IO CMode
if not (s_isreg c_mode)
- then return (-1)
- else do
+ then return (-1)
+ else do
c_size <- st_size p_stat
return (fromIntegral c_size)
data FDType = Directory | Stream | RegularFile | RawDevice
- deriving (Eq)
+ deriving (Eq)
fileType :: FilePath -> IO FDType
fileType file =
fdStat fd =
allocaBytes sizeof_stat $ \ p_stat -> do
throwErrnoIfMinus1Retry "fdType" $
- c_fstat fd p_stat
+ c_fstat fd p_stat
ty <- statGetType p_stat
dev <- st_dev p_stat
ino <- st_ino p_stat
statGetType p_stat = do
c_mode <- st_mode p_stat :: IO CMode
case () of
- _ | s_isdir c_mode -> return Directory
+ _ | 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
+ -> 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 = IOError Nothing UnsupportedOperation "fdType"
- "unknown file type" Nothing
+ "unknown file type" Nothing
#if __GLASGOW_HASKELL__ && (defined(mingw32_HOST_OS) || defined(__MINGW32__))
closeFd :: Bool -> CInt -> IO CInt
let flags = o_RDWR
#else
flags <- throwErrnoIfMinus1Retry "fdGetMode"
- (c_fcntl_read fd const_f_getfl)
+ (c_fcntl_read fd const_f_getfl)
#endif
let
wH = (flags .&. o_WRONLY) /= 0
rwH = (flags .&. o_RDWR) /= 0
mode
- | wH && aH = AppendMode
- | wH = WriteMode
- | rwH = ReadWriteMode
- | otherwise = ReadMode
-
+ | wH && aH = AppendMode
+ | wH = WriteMode
+ | rwH = ReadWriteMode
+ | otherwise = ReadMode
+
return mode
-- ---------------------------------------------------------------------------
tcSetAttr fd $ \ p_tios -> do
c_lflag <- c_lflag p_tios :: IO CTcflag
let new_c_lflag
- | on = c_lflag .|. fromIntegral const_echo
- | otherwise = c_lflag .&. complement (fromIntegral const_echo)
+ | on = c_lflag .|. fromIntegral const_echo
+ | otherwise = c_lflag .&. complement (fromIntegral const_echo)
poke_c_lflag p_tios (new_c_lflag :: CTcflag)
getEcho :: FD -> IO Bool
-- turn on/off ICANON
c_lflag <- c_lflag p_tios :: IO CTcflag
let new_c_lflag | cooked = c_lflag .|. (fromIntegral const_icanon)
- | otherwise = c_lflag .&. complement (fromIntegral const_icanon)
+ | otherwise = c_lflag .&. complement (fromIntegral const_icanon)
poke_c_lflag p_tios (new_c_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
+ 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)
+ throwErrnoIfMinus1Retry "tcSetAttr"
+ (c_tcgetattr fd p_tios)
#ifdef __GLASGOW_HASKELL__
- -- 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
+ -- 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
#endif
- -- 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
- c_sigemptyset p_sigset
- c_sigaddset p_sigset const_sigttou
- 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
- c_sigprocmask const_sig_setmask p_old_sigset nullPtr
- return r
+ -- 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
+ c_sigemptyset p_sigset
+ c_sigaddset p_sigset const_sigttou
+ 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
+ c_sigprocmask const_sig_setmask p_old_sigset nullPtr
+ return r
#ifdef __GLASGOW_HASKELL__
foreign import ccall unsafe "HsBase.h __hscore_get_saved_termios"
setNonBlockingFD fd = do
flags <- throwErrnoIfMinus1Retry "setNonBlockingFD"
- (c_fcntl_read fd const_f_getfl)
+ (c_fcntl_read fd const_f_getfl)
-- 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.
foreign import ccall unsafe "dirUtils.h __hscore_renameFile"
c_rename :: CString -> CString -> IO CInt
-
+
foreign import ccall unsafe "HsBase.h rewinddir"
c_rewinddir :: Ptr CDir -> IO ()
type ProcessID = CPid
type FileOffset = COff
type ProcessGroupID = CPid
-type Limit = CLong
+type Limit = CLong
projects / ghc-base.git / commitdiff