+++ /dev/null
-`%
-% (c) The GRASP/AQUA Project, Glasgow University, 1995
-%
-% Last Modified: Fri Jul 21 12:08:19 1995
-% Darren J Moffat <moffatd@dcs.gla.ac.uk>
-\section[BSD]{Misc BSD bindings}
-
-
-\begin{code}
-module BSD (
-
- HostName(..),
- ProtocolName(..),
- ServiceName(..),
- PortNumber(..),
- ProtocolEntry(..),
- ServiceEntry(..),
- HostEntry(..),
--- SelectData(..),
-
- getHostName, -- :: IO String
--- select, -- :: SelectData -> IO (Maybe SelectData)
-
- getServiceByName, -- :: ServiceName -> IO ServiceEntry
- getServicePortNumber, -- :: ServiceName -> IO PortNumber
- getServiceEntry, -- :: IO ServiceEntry
- setServiceEntry, -- :: Bool -> IO ()
- endServiceEntry, -- :: IO ()
-
- getProtocolByName, -- :: ProtocolName -> IO ProtocolEntry
- getProtocolByNumber, -- :: ProtocolNumber -> IO ProtcolEntry
- getProtocolNumber, -- :: ProtocolName -> ProtocolNumber
- getProtocolEntry, -- :: IO ProtocolEntry
- setProtocolEntry, -- :: Bool -> IO ()
- endProtocolEntry, -- :: IO ()
-
- getHostByName, -- :: HostName -> IO HostEntry
- getHostByAddr, -- :: Family -> HostAddress -> IO HostEntry
- getHostEntry, -- :: IO HostEntry
- setHostEntry, -- :: Bool -> IO ()
- endHostEntry, -- :: IO ()
-
- -- make interface self-sufficient:
- Family
-) where
-
-import LibPosixUtil
-import SocketPrim
-import PreludePrimIO
-import PreludeGlaMisc
-import PreludeGlaST
-\end{code}
-
-
-%***************************************************************************
-%* *
-\subsection[BSD-DBTypes]{Service, Protocol \& Host Database Types}
-%* *
-%***************************************************************************
-
-\begin{code}
-
-type HostName = String
-type ProtocolName = String
-type ProtocolNumber = Int
-type ServiceName = String
-type PortNumber = Int
-data ProtocolEntry = ProtocolEntry
- ProtocolName -- Official Name
- [ProtocolName] -- Set of Aliases
- Int -- Protocol Number
-
-data ServiceEntry = ServiceEntry
- ServiceName -- Official Name
- [ServiceName] -- Set of Aliases
- PortNumber -- Port Number
- ProtocolName -- Protocol
-
-data HostEntry = HostEntry
- HostName -- Official Name
- [HostName] -- Set of Aliases
- Family -- Host Type (currently AF_INET)
- [HostAddress] -- Set of Network Addresses
-\end{code}
-
-
-
-%***************************************************************************
-%* *
-\subsection[LibSocket-DBAccess]{Service, Protocol Host Database Access}
-%* *
-%***************************************************************************
-
-
-
-Calling $getServiceByName$ for a given service and protocol returns the
-systems service entry. This should be used to find the port numbers
-for standard protocols such as smtp and FTP. The remaining three
-functions should be used for browsing the service database
-sequentially.
-
-Calling $setServiceEntry$ with $True$ indicates that the service
-database should be left open between calls to $getServiceEntry$. To
-close the database a call to $endServiceEntry$ is required. This
-database file is usually stored in the file /etc/services.
-
-
-\begin{code}
-getServiceByName :: ServiceName -> -- Service Name
- ProtocolName -> -- Protocol Name
- IO ServiceEntry -- Service Entry
-getServiceByName name proto =
- _ccall_ getservbyname name proto `thenPrimIO` \ ptr ->
- if ptr == ``NULL'' then
- failWith (NoSuchThing "no such service entry")
- else
- unpackServiceEntry ptr `thenPrimIO` \ servent ->
- return servent
-
-getServiceByPort :: PortNumber ->
- ProtocolName ->
- IO ServiceEntry
-getServiceByPort port proto =
- _ccall_ getservbyport port proto `thenPrimIO` \ ptr ->
- if ptr == ``NULL'' then
- failWith (NoSuchThing "no such service entry")
- else
- unpackServiceEntry ptr `thenPrimIO` \ servent ->
- return servent
-
-getServicePortNumber :: ServiceName -> IO PortNumber
-getServicePortNumber name =
- getServiceByName name "tcp" >>= \ (ServiceEntry _ _ port _) ->
- return port
-
-getServiceEntry :: IO ServiceEntry
-getServiceEntry =
- _ccall_ getservent `thenPrimIO` \ ptr ->
- if ptr == ``NULL'' then
- failWith (NoSuchThing "no such service entry")
- else
- unpackServiceEntry ptr `thenPrimIO` \ servent ->
- return servent
-
-setServiceEntry :: Bool -> IO ()
-setServiceEntry True = primIOToIO (_ccall_ setservent 1)
-setServiceEntry False = primIOToIO (_ccall_ setservent 0)
-
-endServiceEntry :: IO ()
-endServiceEntry = primIOToIO (_ccall_ endservent)
-
-\end{code}
-
-The following relate directly to the corresponding UNIX C calls for
-returning the protocol entries. The protocol entry is represented by
-the Haskell type type ProtocolEntry = (String, [String], Int).
-
-As for $setServiceEntry$ above, calling $setProtocolEntry$.
-determines whether or not the protocol database file, usually
-/etc/protocols, is to be kept open between calls of
-$getProtocolEntry$.
-
-\begin{code}
-getProtocolByName :: ProtocolName -> -- Protocol Name
- IO ProtocolEntry -- Protocol Entry
-getProtocolByName name =
- _ccall_ getprotobyname name `thenPrimIO` \ ptr ->
- if ptr == ``NULL'' then
- failWith (NoSuchThing "no such protocol entry")
- else
- unpackProtocolEntry ptr `thenPrimIO` \ protoent ->
- return protoent
-
-getProtocolByNumber :: PortNumber -> -- Protocol Number
- IO ProtocolEntry -- Protocol Entry
-getProtocolByNumber num =
- _ccall_ getprotobynumber num `thenPrimIO` \ ptr ->
- if ptr == ``NULL'' then
- failWith (NoSuchThing "no such protocol entry")
- else
- unpackProtocolEntry ptr `thenPrimIO` \ protoent ->
- return protoent
-
-getProtocolNumber :: ProtocolName -> IO ProtocolNumber
-getProtocolNumber proto =
- getProtocolByName proto >>= \ (ProtocolEntry _ _ num) ->
- return num
-
-getProtocolEntry :: IO ProtocolEntry -- Next Protocol Entry from DB
-getProtocolEntry =
- _ccall_ getprotoent `thenPrimIO` \ ptr ->
- if ptr == ``NULL'' then
- failWith (NoSuchThing "no such protocol entry")
- else
- unpackProtocolEntry ptr `thenPrimIO` \ protoent ->
- return protoent
-
-setProtocolEntry :: Bool -> IO () -- Keep DB Open ?
-setProtocolEntry True = primIOToIO (_ccall_ setprotoent 1)
-setProtocolEntry False = primIOToIO (_ccall_ setprotoent 0)
-
-endProtocolEntry :: IO ()
-endProtocolEntry = primIOToIO (_ccall_ endprotoent)
-
-\end{code}
-
-
-
-
-\begin{code}
-getHostByName :: HostName -> IO HostEntry
-getHostByName name =
- _ccall_ gethostbyname name `thenPrimIO` \ ptr ->
- if ptr == ``NULL'' then
- failWith (NoSuchThing "no such host entry")
- else
- unpackHostEntry ptr `thenPrimIO` \ hostent ->
- return hostent
-
-getHostByAddr :: Family -> HostAddress -> IO HostEntry
-getHostByAddr family addr =
- _casm_ ``%r = gethostbyaddr (%0, sizeof(%0), %1);''
- addr (packFamily family) `thenPrimIO` \ ptr ->
- if ptr == ``NULL'' then
- failWith (NoSuchThing "no such host entry")
- else
- unpackHostEntry ptr `thenPrimIO` \ hostent ->
- return hostent
-
-getHostEntry :: IO HostEntry
-getHostEntry =
- _ccall_ gethostent `thenPrimIO` \ ptr ->
- if ptr == ``NULL'' then
- failWith (NoSuchThing "no such host entry")
- else
- unpackHostEntry ptr `thenPrimIO` \ hostent ->
- return hostent
-
-setHostEntry :: Bool -> IO ()
-setHostEntry True = primIOToIO (_ccall_ sethostent 1)
-setHostEntry False = primIOToIO (_ccall_ sethostent 0)
-
-endHostEntry :: IO ()
-endHostEntry = primIOToIO (_ccall_ endprotoent)
-\end{code}
-
-
-%***************************************************************************
-%* *
-\subsection[BSD-Misc]{Miscellaneous Functions}
-%* *
-%***************************************************************************
-
-
-The $select$ call is is used to make the process sleep until at least
-one of the given handles, is ready for reading, writing or has had an
-exception condition raised against it. The handles which are ready are
-returned in $SelectData$.
-
-Select will also return after the given timeout, which is given in
-nanoseconds, has expired. In this case $Nothing$ is returned.
-
-There is no provision of checking the amount of time remaining since
-the $select$ system call does not make this information available on
-all systems. Some always return a zero timeout where others return
-the time remaining.
-
-Possible return values from select are then:
-\begin{itemize}
-\item ([Handle], [Handle], [Handle], Nothing)
-\item Nothing
-\end{itemize}
-
-\begin{code}
-{-
-type SelectData = ([Handle], -- Read Handles
- [Handle], -- Write Handles
- [Handle], -- Exception Handles
- Maybe Integer) -- Timeout
-select :: SelectData -> IO (Maybe SelectData)
--}
-\end{code}
-
-
-Calling $getHostName$ returns the standard host name for the current
-processor, as set at boot time.
-
-\begin{code}
-
-getHostName :: IO HostName
-getHostName =
- newCharArray (0,256) `thenPrimIO` \ ptr ->
- _casm_ ``%r = gethostname(%0, 256);'' ptr `seqPrimIO`
- mutByteArr2Addr ptr `thenPrimIO` \ ptr' ->
- if ptr' == ``NULL'' then
- fail "getHostName: unable to determine hostname"
- else
- return (_unpackPS (_packCString ptr'))
-\end{code}
-
-
-
-\begin{verbatim}
- struct servent {
- char *s_name; /* official name of service */
- char **s_aliases; /* alias list */
- int s_port; /* port service resides at */
- char *s_proto; /* protocol to use */
- };
-
- The members of this structure are:
- s_name The official name of the service.
- s_aliases A zero terminated list of alternate
- names for the service.
- s_port The port number at which the ser-
- vice resides. Port numbers are
- returned in network short byte
- order.
- s_proto The name of the protocol to use
- when contacting the service.
-\end{verbatim}
-
-\begin{code}
-unpackServiceEntry :: _Addr -> PrimIO ServiceEntry
-unpackServiceEntry ptr =
- _casm_ ``%r = ((struct servent*)%0)->s_name;'' ptr
- `thenPrimIO` \ str ->
- strcpy str `thenPrimIO` \ name ->
- _casm_ ``%r = ((struct servent*)%0)->s_aliases;'' ptr
- `thenPrimIO` \ alias ->
- unvectorize alias 0 `thenStrictlyST` \ aliases ->
- _casm_ ``%r = ((struct servent*)%0)->s_port;'' ptr
- `thenPrimIO` \ port ->
- _casm_ ``%r = ((struct servent*)%0)->s_proto;'' ptr
- `thenPrimIO` \ str ->
- strcpy str `thenPrimIO` \ proto ->
-
- returnPrimIO (ServiceEntry name aliases port proto)
-
--------------------------------------------------------------------------------
-
-unpackProtocolEntry :: _Addr -> PrimIO ProtocolEntry
-unpackProtocolEntry ptr =
- _casm_ ``%r = ((struct protoent*)%0)->p_name;'' ptr
- `thenPrimIO` \ str ->
- strcpy str `thenPrimIO` \ name ->
- _casm_ ``%r = ((struct protoent*)%0)->p_aliases;'' ptr
- `thenPrimIO` \ alias ->
- unvectorize alias 0 `thenStrictlyST` \ aliases ->
- _casm_ ``%r = ((struct protoent*)%0)->p_proto;'' ptr
- `thenPrimIO` \ proto ->
-
- returnPrimIO (ProtocolEntry name aliases proto)
-
-
--------------------------------------------------------------------------------
-
-unpackHostEntry :: _Addr -> PrimIO HostEntry
-unpackHostEntry ptr =
- _casm_ ``%r = ((struct hostent*)%0)->h_name;'' ptr
- `thenPrimIO` \ str ->
- strcpy str `thenPrimIO` \ name ->
- _casm_ ``%r = ((struct hostent*)%0)->h_aliases;'' ptr
- `thenPrimIO` \ alias ->
- unvectorize alias 0 `thenStrictlyST` \ aliases ->
-{- _casm_ ``%r = ((struct hostent*)%0)->h_addr_list;'' ptr
- `thenPrimIO` \ addrs ->
- unvectorizeHostAddrs addrs 0 `thenStrictlyST` \ addrList ->
--} unvectorizeHostAddrs ptr 0 `thenStrictlyST` \ addrList ->
- returnPrimIO (HostEntry name aliases AF_INET addrList)
-
--------------------------------------------------------------------------------
-
-unvectorizeHostAddrs :: _Addr -> Int -> PrimIO [_Word]
-unvectorizeHostAddrs ptr n
- | str == ``NULL'' = returnPrimIO []
- | otherwise =
- _casm_ ``{ u_long tmp;
- if ((((struct hostent*)%0)->h_addr_list[(int)%1]) == NULL)
- tmp=(W_)0;
- else
- tmp = (W_)ntohl(((struct in_addr *)(((struct hostent*)%0)->h_addr_list[(int)%1]))->s_addr);
- %r=(W_)tmp;} ''
- ptr n `thenPrimIO` \ x ->
- unvectorizeHostAddrs ptr (n+1) `thenPrimIO` \ xs ->
- returnPrimIO (x : xs)
- where str = indexAddrOffAddr ptr n
-
-{-
-unvectorizeHostAddrs :: _Addr -> Int -> PrimIO [_Word]
-unvectorizeHostAddrs ptr n
- | str == ``NULL'' = returnPrimIO []
- | otherwise =
- _casm_ ``%r = (W_)ntohl(((struct hostent*)%0)->h_addr_list[(int)%1]);''
- ptr n `thenPrimIO` \ x ->
- unvectorizeHostAddrs ptr (n+1) `thenPrimIO` \ xs ->
- returnPrimIO (x : xs)
- where str = indexAddrOffAddr ptr n
--}
--------------------------------------------------------------------------------
-
-mutByteArr2Addr :: _MutableByteArray _RealWorld Int -> PrimIO _Addr
-mutByteArr2Addr arr = _casm_ `` %r=(void *)%0; '' arr
-
-
-\end{code}
+++ /dev/null
-%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
-%
-\section[Bags]{@Bag@: an unordered collection with duplicates}
-
-\begin{code}
-module Bag (
- Bag, -- abstract type
-
- emptyBag, unitBag, unionBags, unionManyBags,
-#if ! defined(COMPILING_GHC)
- elemBag,
-#endif
- filterBag, partitionBag,
- isEmptyBag, snocBag, listToBag, bagToList
- ) where
-
-#if defined(COMPILING_GHC)
-import Id ( Id )
-import Outputable
-import Pretty
-import Util
-#endif
-
-data Bag a
- = EmptyBag
- | UnitBag a
- | TwoBags (Bag a) (Bag a) -- The ADT guarantees that at least
- -- one branch is non-empty.
- | ListOfBags [Bag a] -- The list is non-empty
-
-emptyBag = EmptyBag
-unitBag = UnitBag
-
-#if ! defined(COMPILING_GHC)
--- not used in GHC
-elemBag :: Eq a => a -> Bag a -> Bool
-elemBag x EmptyBag = False
-elemBag x (UnitBag y) = x==y
-elemBag x (TwoBags b1 b2) = x `elemBag` b1 || x `elemBag` b2
-elemBag x (ListOfBags bs) = any (x `elemBag`) bs
-#endif
-
-unionManyBags [] = EmptyBag
-unionManyBags xs = ListOfBags xs
-
--- This one is a bit stricter! The bag will get completely evaluated.
-
-
-unionBags EmptyBag b = b
-unionBags b EmptyBag = b
-unionBags b1 b2 = TwoBags b1 b2
-
-snocBag :: Bag a -> a -> Bag a
-snocBag bag elt = bag `unionBags` (unitBag elt)
-
-isEmptyBag EmptyBag = True
-isEmptyBag (TwoBags b1 b2) = isEmptyBag b1 && isEmptyBag b2 -- Paranoid, but safe
-isEmptyBag (ListOfBags bs) = all isEmptyBag bs
-isEmptyBag other = False
-
-filterBag :: (a -> Bool) -> Bag a -> Bag a
-filterBag pred EmptyBag = EmptyBag
-filterBag pred b@(UnitBag val) = if pred val then b else EmptyBag
-filterBag pred (TwoBags b1 b2) = sat1 `unionBags` sat2
- where
- sat1 = filterBag pred b1
- sat2 = filterBag pred b2
-filterBag pred (ListOfBags bs) = ListOfBags sats
- where
- sats = [filterBag pred b | b <- bs]
-
-
-partitionBag :: (a -> Bool) -> Bag a -> (Bag a {- Satisfy predictate -},
- Bag a {- Don't -})
-partitionBag pred EmptyBag = (EmptyBag, EmptyBag)
-partitionBag pred b@(UnitBag val) = if pred val then (b, EmptyBag) else (EmptyBag, b)
-partitionBag pred (TwoBags b1 b2) = (sat1 `unionBags` sat2, fail1 `unionBags` fail2)
- where
- (sat1,fail1) = partitionBag pred b1
- (sat2,fail2) = partitionBag pred b2
-partitionBag pred (ListOfBags bs) = (ListOfBags sats, ListOfBags fails)
- where
- (sats, fails) = unzip [partitionBag pred b | b <- bs]
-
-
-listToBag :: [a] -> Bag a
-listToBag lst = foldr TwoBags EmptyBag (map UnitBag lst)
-
-bagToList :: Bag a -> [a]
-bagToList b = b_to_l b []
- where
- -- (b_to_l b xs) flattens b and puts xs on the end.
- b_to_l EmptyBag xs = xs
- b_to_l (UnitBag x) xs = x:xs
- b_to_l (TwoBags b1 b2) xs = b_to_l b1 (b_to_l b2 xs)
- b_to_l (ListOfBags bs) xs = foldr b_to_l xs bs
-\end{code}
-
-\begin{code}
-#if defined(COMPILING_GHC)
-
-instance (Outputable a) => Outputable (Bag a) where
- ppr sty EmptyBag = ppStr "emptyBag"
- ppr sty (UnitBag a) = ppr sty a
- ppr sty (TwoBags b1 b2) = ppCat [ppr sty b1, pp'SP, ppr sty b2]
- ppr sty (ListOfBags bs) = ppCat [ppLbrack, interpp'SP sty bs, ppRbrack]
-
-#endif {- COMPILING_GHC -}
-\end{code}
+++ /dev/null
-%
-% (c) The GRASP Project, Glasgow University, 1994-1995
-%
-\section[BitSet]{An implementation of very small sets}
-
-Bit sets are a fast implementation of sets of integers ranging from 0
-to one less than the number of bits in a machine word (typically 31).
-If any element exceeds the maximum value for a particular machine
-architecture, the results of these operations are undefined. You have
-been warned. If you put any safety checks in this code, I will have
-to kill you.
-
-Note: the Yale Haskell implementation won't provide a full 32 bits.
-However, if you can handle the performance loss, you could change to
-Integer and get virtually unlimited sets.
-
-\begin{code}
-
-module BitSet (
- BitSet, -- abstract type
- mkBS, listBS, emptyBS, singletonBS,
- unionBS, minusBS
-#if ! defined(COMPILING_GHC)
- , elementBS, intersectBS, isEmptyBS
-#endif
- ) where
-
-#ifdef __GLASGOW_HASKELL__
--- nothing to import
-#elif defined(__YALE_HASKELL__)
-{-hide import from mkdependHS-}
-import
- LogOpPrims
-#else
-{-hide import from mkdependHS-}
-import
- Word
-#endif
-
-#ifdef __GLASGOW_HASKELL__
-
-data BitSet = MkBS Word#
-
-emptyBS :: BitSet
-emptyBS = MkBS (int2Word# 0#)
-
-mkBS :: [Int] -> BitSet
-mkBS xs = foldr (unionBS . singletonBS) emptyBS xs
-
-singletonBS :: Int -> BitSet
-singletonBS x = case x of
- I# i# -> MkBS ((int2Word# 1#) `shiftL#` i#)
-
-unionBS :: BitSet -> BitSet -> BitSet
-unionBS (MkBS x#) (MkBS y#) = MkBS (x# `or#` y#)
-
-minusBS :: BitSet -> BitSet -> BitSet
-minusBS (MkBS x#) (MkBS y#) = MkBS (x# `and#` (not# y#))
-
-#if ! defined(COMPILING_GHC)
--- not used in GHC
-isEmptyBS :: BitSet -> Bool
-isEmptyBS (MkBS s#) =
- case word2Int# s# of
- 0# -> True
- _ -> False
-
-intersectBS :: BitSet -> BitSet -> BitSet
-intersectBS (MkBS x#) (MkBS y#) = MkBS (x# `and#` y#)
-
-elementBS :: Int -> BitSet -> Bool
-elementBS x (MkBS s#) = case x of
- I# i# -> case word2Int# (((int2Word# 1#) `shiftL#` i#) `and#` s#) of
- 0# -> False
- _ -> True
-#endif
-
-listBS :: BitSet -> [Int]
-listBS s = listify s 0
- where listify (MkBS s#) n =
- case word2Int# s# of
- 0# -> []
- _ -> let s' = (MkBS (s# `shiftr` 1#))
- more = listify s' (n + 1)
- in case word2Int# (s# `and#` (int2Word# 1#)) of
- 0# -> more
- _ -> n : more
-# if __GLASGOW_HASKELL__ >= 23
- shiftr x y = shiftRL# x y
-# else
- shiftr x y = shiftR# x y
-# endif
-
-#elif defined(__YALE_HASKELL__)
-
-data BitSet = MkBS Int
-
-emptyBS :: BitSet
-emptyBS = MkBS 0
-
-mkBS :: [Int] -> BitSet
-mkBS xs = foldr (unionBS . singletonBS) emptyBS xs
-
-singletonBS :: Int -> BitSet
-singletonBS x = MkBS (1 `ashInt` x)
-
-unionBS :: BitSet -> BitSet -> BitSet
-unionBS (MkBS x) (MkBS y) = MkBS (x `logiorInt` y)
-
-#if ! defined(COMPILING_GHC)
--- not used in GHC
-isEmptyBS :: BitSet -> Bool
-isEmptyBS (MkBS s) =
- case s of
- 0 -> True
- _ -> False
-
-intersectBS :: BitSet -> BitSet -> BitSet
-intersectBS (MkBS x) (MkBS y) = MkBS (x `logandInt` y)
-
-elementBS :: Int -> BitSet -> Bool
-elementBS x (MkBS s) =
- case logbitpInt x s of
- 0 -> False
- _ -> True
-#endif
-
-minusBS :: BitSet -> BitSet -> BitSet
-minusBS (MkBS x) (MkBS y) = MkBS (x `logandc2Int` y)
-
--- rewritten to avoid right shifts (which would give nonsense on negative
--- values.
-listBS :: BitSet -> [Int]
-listBS (MkBS s) = listify s 0 1
- where listify s n m =
- case s of
- 0 -> []
- _ -> let n' = n+1; m' = m+m in
- case logbitpInt s m of
- 0 -> listify s n' m'
- _ -> n : listify (s `logandc2Int` m) n' m'
-
-#else /* HBC, perhaps? */
-
-data BitSet = MkBS Word
-
-emptyBS :: BitSet
-emptyBS = MkBS 0
-
-mkBS :: [Int] -> BitSet
-mkBS xs = foldr (unionBS . singletonBS) emptyBS xs
-
-singletonBS :: Int -> BitSet
-singletonBS x = MkBS (1 `bitLsh` x)
-
-unionBS :: BitSet -> BitSet -> BitSet
-unionBS (MkBS x) (MkBS y) = MkBS (x `bitOr` y)
-
-#if ! defined(COMPILING_GHC)
--- not used in GHC
-isEmptyBS :: BitSet -> Bool
-isEmptyBS (MkBS s) =
- case s of
- 0 -> True
- _ -> False
-
-intersectBS :: BitSet -> BitSet -> BitSet
-intersectBS (MkBS x) (MkBS y) = MkBS (x `bitAnd` y)
-
-elementBS :: Int -> BitSet -> Bool
-elementBS x (MkBS s) =
- case (1 `bitLsh` x) `bitAnd` s of
- 0 -> False
- _ -> True
-#endif
-
-minusBS :: BitSet -> BitSet -> BitSet
-minusBS (MkBS x) (MkBS y) = MkBS (x `bitAnd` (bitCompl y))
-
-listBS :: BitSet -> [Int]
-listBS (MkBS s) = listify s 0
- where listify s n =
- case s of
- 0 -> []
- _ -> let s' = s `bitRsh` 1
- more = listify s' (n + 1)
- in case (s `bitAnd` 1) of
- 0 -> more
- _ -> n : more
-
-#endif
-
-\end{code}
-
-
-
-
+++ /dev/null
-`%
-% (c) The GRASP/AQUA Project, Glasgow University, 1995
-%
-% Last Modified: Wed Jul 19 13:12:10 1995
-% Darren J Moffat <moffatd@dcs.gla.ac.uk>
-%
-% Generated from: @(#)errno.h 2.14 90/01/23 SMI; from UCB 4.1 82/12/28
-\section[CError]{Interface to C Error Codes}
-
-\begin{code}
-module CError (
- CErrorCode(..),
-
- errorCodeToStr, -- :: CErrorCode -> String
- getCErrorCode, -- :: PrimIO CErrorCode
- setCErrorCode -- :: CErrorCode -> PrimIO ()
-
-) where
-
-import PreludeGlaST
-\end{code}
-
-import PreludeGlaMisc
-import LibSystem
-\begin{code}
-data CErrorCode =
- NOERROR -- Added as dummy value since deriving Ix starts at 0
- | EPERM -- Not owner
- | ENOENT -- No such file or directory
- | ESRCH -- No such process
- | EINTR -- Interrupted system call
- | EIO -- I/O error
- | ENXIO -- No such device or address
- | E2BIG -- Arg list too long
- | ENOEXEC -- Exec format error
- | EBADF -- Bad file number
- | ECHILD -- No children
- | EAGAIN -- No more processes
- | ENOMEM -- Not enough core
- | EACCES -- Permission denied
- | EFAULT -- Bad address
- | ENOTBLK -- Block device required
- | EBUSY -- Mount device busy
- | EEXIST -- File exists
- | EXDEV -- Cross-device link
- | ENODEV -- No such device
- | ENOTDIR -- Not a directory*/
- | EISDIR -- Is a directory
- | EINVAL -- Invalid argument
- | ENFILE -- File table overflow
- | EMFILE -- Too many open files
- | ENOTTY -- Not a typewriter
- | ETXTBSY -- Text file busy
- | EFBIG -- File too large
- | ENOSPC -- No space left on device
- | ESPIPE -- Illegal seek
- | EROFS -- Read-only file system
- | EMLINK -- Too many links
- | EPIPE -- Broken pipe
-
--- math software
- | EDOM -- Argument too large
- | ERANGE -- Result too large
-
--- non-blocking and interrupt i/o
- | EWOULDBLOCK -- Operation would block
- | EINPROGRESS -- Operation now in progress
- | EALREADY -- Operation already in progress
--- ipc/network software
-
--- argument errors
- | ENOTSOCK -- Socket operation on non-socket
- | EDESTADDRREQ -- Destination address required
- | EMSGSIZE -- Message too long
- | EPROTOTYPE -- Protocol wrong type for socket
- | ENOPROTOOPT -- Protocol not available
- | EPROTONOSUPPOR -- Protocol not supported
- | ESOCKTNOSUPPORT -- Socket type not supported
- | EOPNOTSUPP -- Operation not supported on socket
- | EPFNOSUPPORT -- Protocol family not supported
- | EAFNOSUPPORT -- Address family not supported by protocol family
- | EADDRINUSE -- Address already in use
- | EADDRNOTAVAIL -- Can't assign requested address
--- operational errors
- | ENETDOWN -- Network is down
- | ENETUNREACH -- Network is unreachable
- | ENETRESET -- Network dropped connection on reset
- | ECONNABORTED -- Software caused connection abort
- | ECONNRESET -- Connection reset by peer
- | ENOBUFS -- No buffer space available
- | EISCONN -- Socket is already connected
- | ENOTCONN -- Socket is not connected
- | ESHUTDOWN -- Can't send after socket shutdown
- | ETOOMANYREFS -- Too many references: can't splice
- | ETIMEDOUT -- Connection timed out
- | ECONNREFUSED -- Connection refused
-
- | ELOOP -- Too many levels of symbolic links
- | ENAMETOOLONG -- File name too long
-
--- should be rearranged
- | EHOSTDOWN -- Host is down
- | EHOSTUNREACH -- No route to host
- | ENOTEMPTY -- Directory not empty
-
--- quotas & mush
- | EPROCLIM -- Too many processes
- | EUSERS -- Too many users
- | EDQUOT -- Disc quota exceeded
-
--- Network File System
- | ESTALE -- Stale NFS file handle
- | EREMOTE -- Too many levels of remote in path
-
--- streams
- | ENOSTR -- Device is not a stream
- | ETIME -- Timer expired
- | ENOSR -- Out of streams resources
- | ENOMSG -- No message of desired type
- | EBADMSG -- Trying to read unreadable message
-
--- SystemV IPC
- | EIDRM -- Identifier removed
-
--- SystemV Record Locking
- | EDEADLK -- Deadlock condition.
- | ENOLCK -- No record locks available.
-
--- RFS
- | ENONET -- Machine is not on the network
- | ERREMOTE -- Object is remote
- | ENOLINK -- the link has been severed
- | EADV -- advertise error
- | ESRMNT -- srmount error
- | ECOMM -- Communication error on send
- | EPROTO -- Protocol error
- | EMULTIHOP -- multihop attempted
- | EDOTDOT -- Cross mount point (not an error)
- | EREMCHG -- Remote address changed
--- POSIX
- | ENOSYS -- function not implemented
-
- deriving (Eq,Ord,Ix,Text)
-
-
-errorCodeToStr :: CErrorCode -> String
-errorCodeToStr NOERROR = ""
-errorCodeToStr EPERM = "Not owner"
-errorCodeToStr ENOENT = "No such file or directory"
-errorCodeToStr ESRCH = "No such process"
-errorCodeToStr EINTR = "Interrupted system call"
-errorCodeToStr EIO = "I/O error"
-errorCodeToStr ENXIO = "No such device or address"
-errorCodeToStr E2BIG = "Arg list too long"
-errorCodeToStr ENOEXEC = "Exec format error"
-errorCodeToStr EBADF = "Bad file number"
-errorCodeToStr ECHILD = "No children"
-errorCodeToStr EAGAIN = "No more processes"
-errorCodeToStr ENOMEM = "Not enough core"
-errorCodeToStr EACCES = "Permission denied"
-errorCodeToStr EFAULT = "Bad address"
-errorCodeToStr ENOTBLK = "Block device required"
-errorCodeToStr EBUSY = "Mount device busy"
-errorCodeToStr EEXIST = "File exists"
-errorCodeToStr EXDEV = "Cross-device link"
-errorCodeToStr ENODEV = "No such device"
-errorCodeToStr ENOTDIR = "Not a directory"
-errorCodeToStr EISDIR = "Is a directory"
-errorCodeToStr EINVAL = "Invalid argument"
-errorCodeToStr ENFILE = "File table overflow"
-errorCodeToStr EMFILE = "Too many open files"
-errorCodeToStr ENOTTY = "Not a typewriter"
-errorCodeToStr ETXTBSY = "Text file busy"
-errorCodeToStr EFBIG = "File too large"
-errorCodeToStr ENOSPC = "No space left on device"
-errorCodeToStr ESPIPE = "Illegal seek"
-errorCodeToStr EROFS = "Read-only file system"
-errorCodeToStr EMLINK = "Too many links"
-errorCodeToStr EPIPE = "Broken pipe"
-
--- math software
-errorCodeToStr EDOM = "Argument too large"
-errorCodeToStr ERANGE = "Result too large"
-
--- non-blocking and interrupt i/o"
-errorCodeToStr EWOULDBLOCK = "Operation would block"
-errorCodeToStr EINPROGRESS = "Operation now in progress"
-errorCodeToStr EALREADY = "Operation already in progress"
--- ipc/network software
-
--- argument errors
-errorCodeToStr ENOTSOCK = "Socket operation on non-socket"
-errorCodeToStr EDESTADDRREQ = "Destination address required"
-errorCodeToStr EMSGSIZE = "Message too long"
-errorCodeToStr EPROTOTYPE = "Protocol wrong type for socket"
-errorCodeToStr ENOPROTOOPT = "Protocol not available"
-errorCodeToStr EPROTONOSUPPOR = "Protocol not supported"
-errorCodeToStr ESOCKTNOSUPPORT = "Socket type not supported"
-errorCodeToStr EOPNOTSUPP = "Operation not supported on socket"
-errorCodeToStr EPFNOSUPPORT = "Protocol family not supported"
-errorCodeToStr EAFNOSUPPORT = "Address family not supported by protocol family"
-errorCodeToStr EADDRINUSE = "Address already in use"
-errorCodeToStr EADDRNOTAVAIL = "Can't assign requested address"
-
--- operational errors
-errorCodeToStr ENETDOWN = "Network is down"
-errorCodeToStr ENETUNREACH = "Network is unreachable"
-errorCodeToStr ENETRESET = "Network dropped connection on reset"
-errorCodeToStr ECONNABORTED = "Software caused connection abort"
-errorCodeToStr ECONNRESET = "Connection reset by peer"
-errorCodeToStr ENOBUFS = "No buffer space available"
-errorCodeToStr EISCONN = "Socket is already connected"
-errorCodeToStr ENOTCONN = "Socket is not connected"
-errorCodeToStr ESHUTDOWN = "Can't send after socket shutdown"
-errorCodeToStr ETOOMANYREFS = "Too many references: can't splice"
-errorCodeToStr ETIMEDOUT = "Connection timed out"
-errorCodeToStr ECONNREFUSED = "Connection refused"
-
-errorCodeToStr ELOOP = "Too many levels of symbolic links"
-errorCodeToStr ENAMETOOLONG = "File name too long"
-
--- should be rearranged
-errorCodeToStr EHOSTDOWN = "Host is down"
-errorCodeToStr EHOSTUNREACH = "No route to host"
-errorCodeToStr ENOTEMPTY = "Directory not empty"
-
--- quotas & mush
-errorCodeToStr EPROCLIM = "Too many processes"
-errorCodeToStr EUSERS = "Too many users"
-errorCodeToStr EDQUOT = "Disc quota exceeded"
-
--- Network File System
-errorCodeToStr ESTALE = "Stale NFS file handle"
-errorCodeToStr EREMOTE = "Too many levels of remote in path"
-
--- streams
-errorCodeToStr ENOSTR = "Device is not a stream"
-errorCodeToStr ETIME = "Timer expired"
-errorCodeToStr ENOSR = "Out of streams resources"
-errorCodeToStr ENOMSG = "No message of desired type"
-errorCodeToStr EBADMSG = "Trying to read unreadable message"
-
--- SystemV IPC
-errorCodeToStr EIDRM = "Identifier removed"
-
--- SystemV Record Locking
-errorCodeToStr EDEADLK = "Deadlock condition."
-errorCodeToStr ENOLCK = "No record locks available."
-
--- RFS
-errorCodeToStr ENONET = "Machine is not on the network"
-errorCodeToStr ERREMOTE = "Object is remote"
-errorCodeToStr ENOLINK = "the link has been severed"
-errorCodeToStr EADV = "advertise error"
-errorCodeToStr ESRMNT = "srmount error"
-errorCodeToStr ECOMM = "Communication error on send"
-errorCodeToStr EPROTO = "Protocol error"
-errorCodeToStr EMULTIHOP = "multihop attempted"
-errorCodeToStr EDOTDOT = "Cross mount point (not an error)"
-errorCodeToStr EREMCHG = "Remote address changed"
-
--- POSIX
-errorCodeToStr ENOSYS = "function not implemented"
-
-unpackCErrorCode :: Int -> CErrorCode
-unpackCErrorCode e = (range (NOERROR, ENOSYS))!!e
-
-packCErrorCode :: CErrorCode -> Int
-packCErrorCode e = index (NOERROR, ENOSYS) e
-
-
-getCErrorCode :: PrimIO CErrorCode
-getCErrorCode =
- _casm_ ``%r = errno;'' `thenPrimIO` \ errno ->
- returnPrimIO (unpackCErrorCode errno)
-
-
-setCErrorCode :: CErrorCode -> PrimIO ()
-setCErrorCode ecode =
- _casm_ ``errno = %0;'' (packCErrorCode ecode) `thenPrimIO` \ () ->
- returnPrimIO ()
-
-
-\end{code}
-
+++ /dev/null
-%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
-%
-\section[CharSeq]{Characters sequences: the @CSeq@ type}
-
-\begin{code}
-#if defined(COMPILING_GHC)
-# include "HsVersions.h"
-#else
-# define FAST_STRING String
-# define FAST_INT Int
-# define ILIT(x) (x)
-# define IBOX(x) (x)
-# define _GE_ >=
-# define _ADD_ +
-# define _SUB_ -
-# define FAST_BOOL Bool
-# define _TRUE_ True
-# define _FALSE_ False
-#endif
-
-module CharSeq (
- CSeq,
- cNil, cAppend, cIndent, cNL, cStr, cPStr, cCh, cInt,
-#if ! defined(COMPILING_GHC)
- cLength,
- cShows,
-#endif
- cShow
-
-#if defined(COMPILING_GHC) && __GLASGOW_HASKELL__ >= 22
- , cAppendFile
- ) where
-
-#if __GLASGOW_HASKELL__ < 26
-import PreludePrimIO
-#endif
-import PreludeGlaST
-
-#else
- ) where
-#endif
-\end{code}
-
-%************************************************
-%* *
- \subsection{The interface}
-%* *
-%************************************************
-
-\begin{code}
-cShow :: CSeq -> [Char]
-
-#if ! defined(COMPILING_GHC)
--- not used in GHC
-cShows :: CSeq -> ShowS
-cLength :: CSeq -> Int
-#endif
-
-cNil :: CSeq
-cAppend :: CSeq -> CSeq -> CSeq
-cIndent :: Int -> CSeq -> CSeq
-cNL :: CSeq
-cStr :: [Char] -> CSeq
-cPStr :: FAST_STRING -> CSeq
-cCh :: Char -> CSeq
-cInt :: Int -> CSeq
-
-#if defined(COMPILING_GHC) && __GLASGOW_HASKELL__ >= 22
-
-# if __GLASGOW_HASKELL__ < 23
-# define _FILE _Addr
-# endif
-
-cAppendFile :: _FILE -> CSeq -> PrimIO ()
-#endif
-\end{code}
-
-%************************************************
-%* *
- \subsection{The representation}
-%* *
-%************************************************
-
-\begin{code}
-data CSeq
- = CNil
- | CAppend CSeq CSeq
- | CIndent Int CSeq
- | CNewline -- Move to start of next line, unless we're
- -- already at the start of a line.
- | CStr [Char]
- | CCh Char
- | CInt Int -- equiv to "CStr (show the_int)"
-#if defined(COMPILING_GHC) && __GLASGOW_HASKELL__ >= 23
- | CPStr _PackedString
-#endif
-\end{code}
-
-The construction functions do pattern matching, to ensure that
-redundant CNils are eliminated. This is bound to have some effect on
-evaluation order, but quite what I don't know.
-
-\begin{code}
-cNil = CNil
-\end{code}
-
-The following special cases were eating our lunch! They make the whole
-thing too strict. A classic strictness bug!
-\begin{code}
--- cAppend CNil cs2 = cs2
--- cAppend cs1 CNil = cs1
-
-cAppend cs1 cs2 = CAppend cs1 cs2
-
-cIndent n cs = CIndent n cs
-
-cNL = CNewline
-cStr = CStr
-cCh = CCh
-cInt = CInt
-
-#if defined(COMPILING_GHC) && __GLASGOW_HASKELL__ >= 23
-cPStr = CPStr
-#else
-cPStr = CStr
-#endif
-
-cShow seq = flatten ILIT(0) _TRUE_ seq []
-
-#if ! defined(COMPILING_GHC)
-cShows seq rest = cShow seq ++ rest
-cLength seq = length (cShow seq) -- *not* the best way to do this!
-#endif
-
-#if defined(COMPILING_GHC) && __GLASGOW_HASKELL__ >= 22
-cAppendFile file_star seq
- = flattenIO file_star seq
-#endif
-\end{code}
-
-This code is {\em hammered}. We are not above doing sleazy
-non-standard things. (WDP 94/10)
-
-\begin{code}
-data WorkItem = WI FAST_INT CSeq -- indentation, and sequence
-
-flatten :: FAST_INT -- Indentation
- -> FAST_BOOL -- True => just had a newline
- -> CSeq -- Current seq to flatten
- -> [WorkItem] -- Work list with indentation
- -> String
-
-flatten n nlp CNil seqs = flattenS nlp seqs
-
-flatten n nlp (CAppend seq1 seq2) seqs = flatten n nlp seq1 ((WI n seq2) : seqs)
-flatten n nlp (CIndent IBOX(n2) seq) seqs = flatten (n2 _ADD_ n) nlp seq seqs
-
-flatten n _FALSE_ CNewline seqs = '\n' : flattenS _TRUE_ seqs
-flatten n _TRUE_ CNewline seqs = flattenS _TRUE_ seqs -- Already at start of line
-
-flatten n _FALSE_ (CStr s) seqs = s ++ flattenS _FALSE_ seqs
-flatten n _FALSE_ (CCh c) seqs = c : flattenS _FALSE_ seqs
-flatten n _FALSE_ (CInt i) seqs = show i ++ flattenS _FALSE_ seqs
-#if defined(COMPILING_GHC) && __GLASGOW_HASKELL__ >= 23
-flatten n _FALSE_ (CPStr s) seqs = _unpackPS s ++ flattenS _FALSE_ seqs
-#endif
-
-flatten n _TRUE_ (CStr s) seqs = mkIndent n (s ++ flattenS _FALSE_ seqs)
-flatten n _TRUE_ (CCh c) seqs = mkIndent n (c : flattenS _FALSE_ seqs)
-flatten n _TRUE_ (CInt i) seqs = mkIndent n (show i ++ flattenS _FALSE_ seqs)
-#if defined(COMPILING_GHC) && __GLASGOW_HASKELL__ >= 23
-flatten n _TRUE_ (CPStr s) seqs = mkIndent n (_unpackPS s ++ flattenS _FALSE_ seqs)
-#endif
-\end{code}
-
-\begin{code}
-flattenS :: FAST_BOOL -> [WorkItem] -> String
-flattenS nlp [] = ""
-flattenS nlp ((WI col seq):seqs) = flatten col nlp seq seqs
-\end{code}
-
-\begin{code}
-mkIndent :: FAST_INT -> String -> String
-mkIndent ILIT(0) s = s
-mkIndent n s
- = if (n _GE_ ILIT(8))
- then '\t' : mkIndent (n _SUB_ ILIT(8)) s
- else ' ' : mkIndent (n _SUB_ ILIT(1)) s
- -- Hmm.. a little Unix-y.
-\end{code}
-
-Now the I/O version.
-This code is massively {\em hammered}.
-It {\em ignores} indentation.
-
-\begin{code}
-#if defined(COMPILING_GHC) && __GLASGOW_HASKELL__ >= 22
-
-flattenIO :: _FILE -- file we are writing to
- -> CSeq -- Seq to print
- -> PrimIO ()
-
-flattenIO file sq
-# if __GLASGOW_HASKELL__ >= 23
- | file == ``NULL'' = error "panic:flattenIO" -- really just to force eval :-)
- | otherwise
-# endif
- = flat sq
- where
- flat CNil = BSCC("flatCNil") returnPrimIO () ESCC
-
- flat (CIndent n2 seq) = BSCC("flatCIndent") flat seq ESCC
-
- flat (CAppend seq1 seq2)
- = BSCC("flatCAppend")
- flat seq1 `seqPrimIO` flat seq2
- ESCC
-
- flat CNewline = BSCC("flatCNL") _ccall_ stg_putc '\n' file ESCC
-
- flat (CCh c) = BSCC("flatCCh") _ccall_ stg_putc c file ESCC
-
- flat (CInt i) = BSCC("flatCInt") _ccall_ fprintf file percent_d i ESCC
-
- flat (CStr s) = BSCC("flatCStr") put_str s ESCC
-
-# if defined(COMPILING_GHC) && __GLASGOW_HASKELL__ >= 23
- flat (CPStr s) = BSCC("flatCPStr") put_pstr s ESCC
-# endif
-
- -----
- put_str, put_str2 :: String -> PrimIO ()
-
- put_str str
- = --put_str2 ``stderr'' (str ++ "\n") `seqPrimIO`
- put_str2 str
-
- put_str2 [] = BSCC("putNil") returnPrimIO () ESCC
-
- put_str2 (c1@(C# _) : c2@(C# _) : c3@(C# _) : c4@(C# _) : cs)
- = BSCC("put4")
- _ccall_ stg_putc c1 file `seqPrimIO`
- _ccall_ stg_putc c2 file `seqPrimIO`
- _ccall_ stg_putc c3 file `seqPrimIO`
- _ccall_ stg_putc c4 file `seqPrimIO`
- put_str2 cs -- efficiency hack? who knows... (WDP 94/10)
- ESCC
-
- put_str2 (c1@(C# _) : c2@(C# _) : c3@(C# _) : cs)
- = BSCC("put3")
- _ccall_ stg_putc c1 file `seqPrimIO`
- _ccall_ stg_putc c2 file `seqPrimIO`
- _ccall_ stg_putc c3 file `seqPrimIO`
- put_str2 cs -- efficiency hack? who knows... (WDP 94/10)
- ESCC
-
- put_str2 (c1@(C# _) : c2@(C# _) : cs)
- = BSCC("put2")
- _ccall_ stg_putc c1 file `seqPrimIO`
- _ccall_ stg_putc c2 file `seqPrimIO`
- put_str2 cs -- efficiency hack? who knows... (WDP 94/10)
- ESCC
-
- put_str2 (c1@(C# _) : cs)
- = BSCC("put1")
- _ccall_ stg_putc c1 file `seqPrimIO`
- put_str2 cs -- efficiency hack? who knows... (WDP 94/10)
- ESCC
-
-# if __GLASGOW_HASKELL__ >= 23
- put_pstr ps = _putPS file ps
-# endif
-
-# if __GLASGOW_HASKELL__ >= 23
-percent_d = _psToByteArray SLIT("%d")
-# else
-percent_d = "%d"
-# endif
-
-#endif {- __GLASGOW_HASKELL__ >= 22 -}
-\end{code}
+++ /dev/null
-%
-% (c) The AQUA Project, Glasgow University, 1994-1995
-%
-\section[FiniteMap]{An implementation of finite maps}
-
-``Finite maps'' are the heart of the compiler's
-lookup-tables/environments and its implementation of sets. Important
-stuff!
-
-This code is derived from that in the paper:
-\begin{display}
- S Adams
- "Efficient sets: a balancing act"
- Journal of functional programming 3(4) Oct 1993, pp553-562
-\end{display}
-
-The code is SPECIALIZEd to various highly-desirable types (e.g., Id)
-near the end (only \tr{#ifdef COMPILING_GHC}).
-
-\begin{code}
-#if defined(COMPILING_GHC)
-#include "HsVersions.h"
-#define IF_NOT_GHC(a) {--}
-#else
-#define ASSERT(e) {--}
-#define IF_NOT_GHC(a) a
-#define COMMA ,
-#endif
-
-#if defined(COMPILING_GHC) && defined(DEBUG_FINITEMAPS)/* NB NB NB */
-#define OUTPUTABLE_key , Outputable key
-#else
-#define OUTPUTABLE_key {--}
-#endif
-
-module FiniteMap (
- FiniteMap, -- abstract type
-
- emptyFM, singletonFM, listToFM,
-
- addToFM, addListToFM,
- IF_NOT_GHC(addToFM_C COMMA)
- addListToFM_C,
- IF_NOT_GHC(delFromFM COMMA)
- delListFromFM,
-
- plusFM, plusFM_C,
- IF_NOT_GHC(intersectFM COMMA intersectFM_C COMMA)
- minusFM, -- exported for GHCI only
-
- IF_NOT_GHC(mapFM COMMA foldFM COMMA filterFM COMMA)
-
- IF_NOT_GHC(sizeFM COMMA)
- isEmptyFM, elemFM, lookupFM, lookupWithDefaultFM,
-
- fmToList, keysFM, eltsFM{-used in GHCI-}
-
-#if defined(COMPILING_GHC)
- , FiniteSet(..), emptySet, mkSet, isEmptySet
- , elementOf, setToList, union, minusSet{-exported for GHCI-}
-#endif
-
- -- To make it self-sufficient
-#if __HASKELL1__ < 3
- , Maybe
-#endif
- ) where
-
-import Maybes
-
-#if defined(COMPILING_GHC)
-import AbsUniType
-import Pretty
-import Outputable
-import Util
-import CLabelInfo ( CLabel ) -- for specialising
-#if ! OMIT_NATIVE_CODEGEN
-import AsmRegAlloc ( Reg ) -- ditto
-#define IF_NCG(a) a
-#else
-#define IF_NCG(a) {--}
-#endif
-#endif
-
--- SIGH: but we use unboxed "sizes"...
-#if __GLASGOW_HASKELL__
-#define IF_GHC(a,b) a
-#else /* not GHC */
-#define IF_GHC(a,b) b
-#endif /* not GHC */
-\end{code}
-
-
-%************************************************************************
-%* *
-\subsection{The signature of the module}
-%* *
-%************************************************************************
-
-\begin{code}
--- BUILDING
-emptyFM :: FiniteMap key elt
-singletonFM :: key -> elt -> FiniteMap key elt
-listToFM :: (Ord key OUTPUTABLE_key) => [(key,elt)] -> FiniteMap key elt
- -- In the case of duplicates, the last is taken
-
--- ADDING AND DELETING
- -- Throws away any previous binding
- -- In the list case, the items are added starting with the
- -- first one in the list
-addToFM :: (Ord key OUTPUTABLE_key) => FiniteMap key elt -> key -> elt -> FiniteMap key elt
-addListToFM :: (Ord key OUTPUTABLE_key) => FiniteMap key elt -> [(key,elt)] -> FiniteMap key elt
-
- -- Combines with previous binding
-addToFM_C :: (Ord key OUTPUTABLE_key) => (elt -> elt -> elt)
- -> FiniteMap key elt -> key -> elt
- -> FiniteMap key elt
-addListToFM_C :: (Ord key OUTPUTABLE_key) => (elt -> elt -> elt)
- -> FiniteMap key elt -> [(key,elt)]
- -> FiniteMap key elt
-
- -- Deletion doesn't complain if you try to delete something
- -- which isn't there
-delFromFM :: (Ord key OUTPUTABLE_key) => FiniteMap key elt -> key -> FiniteMap key elt
-delListFromFM :: (Ord key OUTPUTABLE_key) => FiniteMap key elt -> [key] -> FiniteMap key elt
-
--- COMBINING
- -- Bindings in right argument shadow those in the left
-plusFM :: (Ord key OUTPUTABLE_key) => FiniteMap key elt -> FiniteMap key elt
- -> FiniteMap key elt
-
- -- Combines bindings for the same thing with the given function
-plusFM_C :: (Ord key OUTPUTABLE_key) => (elt -> elt -> elt)
- -> FiniteMap key elt -> FiniteMap key elt -> FiniteMap key elt
-
-minusFM :: (Ord key OUTPUTABLE_key) => FiniteMap key elt -> FiniteMap key elt -> FiniteMap key elt
- -- (minusFM a1 a2) deletes from a1 any bindings which are bound in a2
-
-intersectFM :: (Ord key OUTPUTABLE_key) => FiniteMap key elt -> FiniteMap key elt -> FiniteMap key elt
-intersectFM_C :: (Ord key OUTPUTABLE_key) => (elt -> elt -> elt)
- -> FiniteMap key elt -> FiniteMap key elt -> FiniteMap key elt
-
--- MAPPING, FOLDING, FILTERING
-foldFM :: (key -> elt -> a -> a) -> a -> FiniteMap key elt -> a
-mapFM :: (key -> elt1 -> elt2) -> FiniteMap key elt1 -> FiniteMap key elt2
-filterFM :: (Ord key OUTPUTABLE_key) => (key -> elt -> Bool)
- -> FiniteMap key elt -> FiniteMap key elt
-
--- INTERROGATING
-sizeFM :: FiniteMap key elt -> Int
-isEmptyFM :: FiniteMap key elt -> Bool
-
-elemFM :: (Ord key OUTPUTABLE_key) => key -> FiniteMap key elt -> Bool
-lookupFM :: (Ord key OUTPUTABLE_key) => FiniteMap key elt -> key -> Maybe elt
-lookupWithDefaultFM
- :: (Ord key OUTPUTABLE_key) => FiniteMap key elt -> elt -> key -> elt
- -- lookupWithDefaultFM supplies a "default" elt
- -- to return for an unmapped key
-
--- LISTIFYING
-fmToList :: FiniteMap key elt -> [(key,elt)]
-keysFM :: FiniteMap key elt -> [key]
-eltsFM :: FiniteMap key elt -> [elt]
-\end{code}
-
-%************************************************************************
-%* *
-\subsection{The @FiniteMap@ data type, and building of same}
-%* *
-%************************************************************************
-
-Invariants about @FiniteMap@:
-\begin{enumerate}
-\item
-all keys in a FiniteMap are distinct
-\item
-all keys in left subtree are $<$ key in Branch and
-all keys in right subtree are $>$ key in Branch
-\item
-size field of a Branch gives number of Branch nodes in the tree
-\item
-size of left subtree is differs from size of right subtree by a
-factor of at most \tr{sIZE_RATIO}
-\end{enumerate}
-
-\begin{code}
-data FiniteMap key elt
- = EmptyFM
- | Branch key elt -- Key and elt stored here
- IF_GHC(Int#,Int{-STRICT-}) -- Size >= 1
- (FiniteMap key elt) -- Children
- (FiniteMap key elt)
-\end{code}
-
-\begin{code}
-emptyFM = EmptyFM
-{-
-emptyFM
- = Branch bottom bottom IF_GHC(0#,0) bottom bottom
- where
- bottom = panic "emptyFM"
--}
-
--- #define EmptyFM (Branch _ _ IF_GHC(0#,0) _ _)
-
-singletonFM key elt = Branch key elt IF_GHC(1#,1) emptyFM emptyFM
-
-listToFM key_elt_pairs = addListToFM emptyFM key_elt_pairs
-\end{code}
-
-%************************************************************************
-%* *
-\subsection{Adding to and deleting from @FiniteMaps@}
-%* *
-%************************************************************************
-
-\begin{code}
-addToFM fm key elt = addToFM_C (\ old new -> new) fm key elt
-
-addToFM_C combiner EmptyFM key elt = singletonFM key elt
-addToFM_C combiner (Branch key elt size fm_l fm_r) new_key new_elt
-#ifdef __GLASGOW_HASKELL__
- = case _tagCmp new_key key of
- _LT -> mkBalBranch key elt (addToFM_C combiner fm_l new_key new_elt) fm_r
- _GT -> mkBalBranch key elt fm_l (addToFM_C combiner fm_r new_key new_elt)
- _EQ -> Branch new_key (combiner elt new_elt) size fm_l fm_r
-#else
- | new_key < key = mkBalBranch key elt (addToFM_C combiner fm_l new_key new_elt) fm_r
- | new_key > key = mkBalBranch key elt fm_l (addToFM_C combiner fm_r new_key new_elt)
- | otherwise = Branch new_key (combiner elt new_elt) size fm_l fm_r
-#endif
-
-addListToFM fm key_elt_pairs = addListToFM_C (\ old new -> new) fm key_elt_pairs
-
-addListToFM_C combiner fm key_elt_pairs
- = foldl add fm key_elt_pairs -- foldl adds from the left
- where
- add fmap (key,elt) = addToFM_C combiner fmap key elt
-\end{code}
-
-\begin{code}
-delFromFM EmptyFM del_key = emptyFM
-delFromFM (Branch key elt size fm_l fm_r) del_key
-#ifdef __GLASGOW_HASKELL__
- = case _tagCmp del_key key of
- _GT -> mkBalBranch key elt fm_l (delFromFM fm_r del_key)
- _LT -> mkBalBranch key elt (delFromFM fm_l del_key) fm_r
- _EQ -> glueBal fm_l fm_r
-#else
- | del_key > key
- = mkBalBranch key elt fm_l (delFromFM fm_r del_key)
-
- | del_key < key
- = mkBalBranch key elt (delFromFM fm_l del_key) fm_r
-
- | key == del_key
- = glueBal fm_l fm_r
-#endif
-
-delListFromFM fm keys = foldl delFromFM fm keys
-\end{code}
-
-%************************************************************************
-%* *
-\subsection{Combining @FiniteMaps@}
-%* *
-%************************************************************************
-
-\begin{code}
-plusFM_C combiner EmptyFM fm2 = fm2
-plusFM_C combiner fm1 EmptyFM = fm1
-plusFM_C combiner fm1 (Branch split_key elt2 _ left right)
- = mkVBalBranch split_key new_elt
- (plusFM_C combiner lts left)
- (plusFM_C combiner gts right)
- where
- lts = splitLT fm1 split_key
- gts = splitGT fm1 split_key
- new_elt = case lookupFM fm1 split_key of
- Nothing -> elt2
- Just elt1 -> combiner elt1 elt2
-
--- It's worth doing plusFM specially, because we don't need
--- to do the lookup in fm1.
-
-plusFM EmptyFM fm2 = fm2
-plusFM fm1 EmptyFM = fm1
-plusFM fm1 (Branch split_key elt1 _ left right)
- = mkVBalBranch split_key elt1 (plusFM lts left) (plusFM gts right)
- where
- lts = splitLT fm1 split_key
- gts = splitGT fm1 split_key
-
-minusFM EmptyFM fm2 = emptyFM
-minusFM fm1 EmptyFM = fm1
-minusFM fm1 (Branch split_key elt _ left right)
- = glueVBal (minusFM lts left) (minusFM gts right)
- -- The two can be way different, so we need glueVBal
- where
- lts = splitLT fm1 split_key -- NB gt and lt, so the equal ones
- gts = splitGT fm1 split_key -- are not in either.
-
-intersectFM fm1 fm2 = intersectFM_C (\ left right -> right) fm1 fm2
-
-intersectFM_C combiner fm1 EmptyFM = emptyFM
-intersectFM_C combiner EmptyFM fm2 = emptyFM
-intersectFM_C combiner fm1 (Branch split_key elt2 _ left right)
-
- | maybeToBool maybe_elt1 -- split_elt *is* in intersection
- = mkVBalBranch split_key (combiner elt1 elt2) (intersectFM_C combiner lts left)
- (intersectFM_C combiner gts right)
-
- | otherwise -- split_elt is *not* in intersection
- = glueVBal (intersectFM_C combiner lts left) (intersectFM_C combiner gts right)
-
- where
- lts = splitLT fm1 split_key -- NB gt and lt, so the equal ones
- gts = splitGT fm1 split_key -- are not in either.
-
- maybe_elt1 = lookupFM fm1 split_key
- Just elt1 = maybe_elt1
-\end{code}
-
-%************************************************************************
-%* *
-\subsection{Mapping, folding, and filtering with @FiniteMaps@}
-%* *
-%************************************************************************
-
-\begin{code}
-foldFM k z EmptyFM = z
-foldFM k z (Branch key elt _ fm_l fm_r)
- = foldFM k (k key elt (foldFM k z fm_r)) fm_l
-
-mapFM f EmptyFM = emptyFM
-mapFM f (Branch key elt size fm_l fm_r)
- = Branch key (f key elt) size (mapFM f fm_l) (mapFM f fm_r)
-
-filterFM p EmptyFM = emptyFM
-filterFM p (Branch key elt _ fm_l fm_r)
- | p key elt -- Keep the item
- = mkVBalBranch key elt (filterFM p fm_l) (filterFM p fm_r)
-
- | otherwise -- Drop the item
- = glueVBal (filterFM p fm_l) (filterFM p fm_r)
-\end{code}
-
-%************************************************************************
-%* *
-\subsection{Interrogating @FiniteMaps@}
-%* *
-%************************************************************************
-
-\begin{code}
---{-# INLINE sizeFM #-}
-sizeFM EmptyFM = 0
-sizeFM (Branch _ _ size _ _) = IF_GHC(I# size, size)
-
-isEmptyFM fm = sizeFM fm == 0
-
-lookupFM EmptyFM key = Nothing
-lookupFM (Branch key elt _ fm_l fm_r) key_to_find
-#ifdef __GLASGOW_HASKELL__
- = case _tagCmp key_to_find key of
- _LT -> lookupFM fm_l key_to_find
- _GT -> lookupFM fm_r key_to_find
- _EQ -> Just elt
-#else
- | key_to_find < key = lookupFM fm_l key_to_find
- | key_to_find > key = lookupFM fm_r key_to_find
- | otherwise = Just elt
-#endif
-
-key `elemFM` fm
- = case (lookupFM fm key) of { Nothing -> False; Just elt -> True }
-
-lookupWithDefaultFM fm deflt key
- = case (lookupFM fm key) of { Nothing -> deflt; Just elt -> elt }
-\end{code}
-
-%************************************************************************
-%* *
-\subsection{Listifying @FiniteMaps@}
-%* *
-%************************************************************************
-
-\begin{code}
-fmToList fm = foldFM (\ key elt rest -> (key,elt) : rest) [] fm
-keysFM fm = foldFM (\ key elt rest -> key : rest) [] fm
-eltsFM fm = foldFM (\ key elt rest -> elt : rest) [] fm
-\end{code}
-
-
-%************************************************************************
-%* *
-\subsection{The implementation of balancing}
-%* *
-%************************************************************************
-
-%************************************************************************
-%* *
-\subsubsection{Basic construction of a @FiniteMap@}
-%* *
-%************************************************************************
-
-@mkBranch@ simply gets the size component right. This is the ONLY
-(non-trivial) place the Branch object is built, so the ASSERTion
-recursively checks consistency. (The trivial use of Branch is in
-@singletonFM@.)
-
-\begin{code}
-sIZE_RATIO :: Int
-sIZE_RATIO = 5
-
-mkBranch :: (Ord key OUTPUTABLE_key) -- Used for the assertion checking only
- => Int
- -> key -> elt
- -> FiniteMap key elt -> FiniteMap key elt
- -> FiniteMap key elt
-
-mkBranch which key elt fm_l fm_r
- = --ASSERT( left_ok && right_ok && balance_ok )
-#if defined(COMPILING_GHC) && defined(DEBUG_FINITEMAPS)
- if not ( left_ok && right_ok && balance_ok ) then
- pprPanic ("mkBranch:"++show which) (ppAboves [ppr PprDebug [left_ok, right_ok, balance_ok],
- ppr PprDebug key,
- ppr PprDebug fm_l,
- ppr PprDebug fm_r])
- else
-#endif
- let
- result = Branch key elt (unbox (1 + left_size + right_size)) fm_l fm_r
- in
--- if sizeFM result <= 8 then
- result
--- else
--- pprTrace ("mkBranch:"++(show which)) (ppr PprDebug result) (
--- result
--- )
- where
- left_ok = case fm_l of
- EmptyFM -> True
- Branch left_key _ _ _ _ -> let
- biggest_left_key = fst (findMax fm_l)
- in
- biggest_left_key < key
- right_ok = case fm_r of
- EmptyFM -> True
- Branch right_key _ _ _ _ -> let
- smallest_right_key = fst (findMin fm_r)
- in
- key < smallest_right_key
- balance_ok = True -- sigh
-{- LATER:
- balance_ok
- = -- Both subtrees have one or no elements...
- (left_size + right_size <= 1)
--- NO || left_size == 0 -- ???
--- NO || right_size == 0 -- ???
- -- ... or the number of elements in a subtree does not exceed
- -- sIZE_RATIO times the number of elements in the other subtree
- || (left_size * sIZE_RATIO >= right_size &&
- right_size * sIZE_RATIO >= left_size)
--}
-
- left_size = sizeFM fm_l
- right_size = sizeFM fm_r
-
-#ifdef __GLASGOW_HASKELL__
- unbox :: Int -> Int#
- unbox (I# size) = size
-#else
- unbox :: Int -> Int
- unbox x = x
-#endif
-\end{code}
-
-%************************************************************************
-%* *
-\subsubsection{{\em Balanced} construction of a @FiniteMap@}
-%* *
-%************************************************************************
-
-@mkBalBranch@ rebalances, assuming that the subtrees aren't too far
-out of whack.
-
-\begin{code}
-mkBalBranch :: (Ord key OUTPUTABLE_key)
- => key -> elt
- -> FiniteMap key elt -> FiniteMap key elt
- -> FiniteMap key elt
-
-mkBalBranch key elt fm_L fm_R
-
- | size_l + size_r < 2
- = mkBranch 1{-which-} key elt fm_L fm_R
-
- | size_r > sIZE_RATIO * size_l -- Right tree too big
- = case fm_R of
- Branch _ _ _ fm_rl fm_rr
- | sizeFM fm_rl < 2 * sizeFM fm_rr -> single_L fm_L fm_R
- | otherwise -> double_L fm_L fm_R
- -- Other case impossible
-
- | size_l > sIZE_RATIO * size_r -- Left tree too big
- = case fm_L of
- Branch _ _ _ fm_ll fm_lr
- | sizeFM fm_lr < 2 * sizeFM fm_ll -> single_R fm_L fm_R
- | otherwise -> double_R fm_L fm_R
- -- Other case impossible
-
- | otherwise -- No imbalance
- = mkBranch 2{-which-} key elt fm_L fm_R
-
- where
- size_l = sizeFM fm_L
- size_r = sizeFM fm_R
-
- single_L fm_l (Branch key_r elt_r _ fm_rl fm_rr)
- = mkBranch 3{-which-} key_r elt_r (mkBranch 4{-which-} key elt fm_l fm_rl) fm_rr
-
- double_L fm_l (Branch key_r elt_r _ (Branch key_rl elt_rl _ fm_rll fm_rlr) fm_rr)
- = mkBranch 5{-which-} key_rl elt_rl (mkBranch 6{-which-} key elt fm_l fm_rll)
- (mkBranch 7{-which-} key_r elt_r fm_rlr fm_rr)
-
- single_R (Branch key_l elt_l _ fm_ll fm_lr) fm_r
- = mkBranch 8{-which-} key_l elt_l fm_ll (mkBranch 9{-which-} key elt fm_lr fm_r)
-
- double_R (Branch key_l elt_l _ fm_ll (Branch key_lr elt_lr _ fm_lrl fm_lrr)) fm_r
- = mkBranch 10{-which-} key_lr elt_lr (mkBranch 11{-which-} key_l elt_l fm_ll fm_lrl)
- (mkBranch 12{-which-} key elt fm_lrr fm_r)
-\end{code}
-
-
-\begin{code}
-mkVBalBranch :: (Ord key OUTPUTABLE_key)
- => key -> elt
- -> FiniteMap key elt -> FiniteMap key elt
- -> FiniteMap key elt
-
--- Assert: in any call to (mkVBalBranch_C comb key elt l r),
--- (a) all keys in l are < all keys in r
--- (b) all keys in l are < key
--- (c) all keys in r are > key
-
-mkVBalBranch key elt EmptyFM fm_r = addToFM fm_r key elt
-mkVBalBranch key elt fm_l EmptyFM = addToFM fm_l key elt
-
-mkVBalBranch key elt fm_l@(Branch key_l elt_l _ fm_ll fm_lr)
- fm_r@(Branch key_r elt_r _ fm_rl fm_rr)
- | sIZE_RATIO * size_l < size_r
- = mkBalBranch key_r elt_r (mkVBalBranch key elt fm_l fm_rl) fm_rr
-
- | sIZE_RATIO * size_r < size_l
- = mkBalBranch key_l elt_l fm_ll (mkVBalBranch key elt fm_lr fm_r)
-
- | otherwise
- = mkBranch 13{-which-} key elt fm_l fm_r
-
- where
- size_l = sizeFM fm_l
- size_r = sizeFM fm_r
-\end{code}
-
-%************************************************************************
-%* *
-\subsubsection{Gluing two trees together}
-%* *
-%************************************************************************
-
-@glueBal@ assumes its two arguments aren't too far out of whack, just
-like @mkBalBranch@. But: all keys in first arg are $<$ all keys in
-second.
-
-\begin{code}
-glueBal :: (Ord key OUTPUTABLE_key)
- => FiniteMap key elt -> FiniteMap key elt
- -> FiniteMap key elt
-
-glueBal EmptyFM fm2 = fm2
-glueBal fm1 EmptyFM = fm1
-glueBal fm1 fm2
- -- The case analysis here (absent in Adams' program) is really to deal
- -- with the case where fm2 is a singleton. Then deleting the minimum means
- -- we pass an empty tree to mkBalBranch, which breaks its invariant.
- | sizeFM fm2 > sizeFM fm1
- = mkBalBranch mid_key2 mid_elt2 fm1 (deleteMin fm2)
-
- | otherwise
- = mkBalBranch mid_key1 mid_elt1 (deleteMax fm1) fm2
- where
- (mid_key1, mid_elt1) = findMax fm1
- (mid_key2, mid_elt2) = findMin fm2
-\end{code}
-
-@glueVBal@ copes with arguments which can be of any size.
-But: all keys in first arg are $<$ all keys in second.
-
-\begin{code}
-glueVBal :: (Ord key OUTPUTABLE_key)
- => FiniteMap key elt -> FiniteMap key elt
- -> FiniteMap key elt
-
-glueVBal EmptyFM fm2 = fm2
-glueVBal fm1 EmptyFM = fm1
-glueVBal fm_l@(Branch key_l elt_l _ fm_ll fm_lr)
- fm_r@(Branch key_r elt_r _ fm_rl fm_rr)
- | sIZE_RATIO * size_l < size_r
- = mkBalBranch key_r elt_r (glueVBal fm_l fm_rl) fm_rr
-
- | sIZE_RATIO * size_r < size_l
- = mkBalBranch key_l elt_l fm_ll (glueVBal fm_lr fm_r)
-
- | otherwise -- We now need the same two cases as in glueBal above.
- = glueBal fm_l fm_r
- where
- (mid_key_l,mid_elt_l) = findMax fm_l
- (mid_key_r,mid_elt_r) = findMin fm_r
- size_l = sizeFM fm_l
- size_r = sizeFM fm_r
-\end{code}
-
-%************************************************************************
-%* *
-\subsection{Local utilities}
-%* *
-%************************************************************************
-
-\begin{code}
-splitLT, splitGT :: (Ord key OUTPUTABLE_key) => FiniteMap key elt -> key -> FiniteMap key elt
-
--- splitLT fm split_key = fm restricted to keys < split_key
--- splitGE fm split_key = fm restricted to keys >= split_key (UNUSED)
--- splitGT fm split_key = fm restricted to keys > split_key
-
-splitLT EmptyFM split_key = emptyFM
-splitLT (Branch key elt _ fm_l fm_r) split_key
-#ifdef __GLASGOW_HASKELL__
- = case _tagCmp split_key key of
- _LT -> splitLT fm_l split_key
- _GT -> mkVBalBranch key elt fm_l (splitLT fm_r split_key)
- _EQ -> fm_l
-#else
- | split_key < key = splitLT fm_l split_key
- | split_key > key = mkVBalBranch key elt fm_l (splitLT fm_r split_key)
- | otherwise = fm_l
-#endif
-
-{- UNUSED:
-splitGE EmptyFM split_key = emptyFM
-splitGE (Branch key elt _ fm_l fm_r) split_key
-#ifdef __GLASGOW_HASKELL__
- = case _tagCmp split_key key of
- _GT -> splitGE fm_r split_key
- _LT -> mkVBalBranch key elt (splitGE fm_l split_key) fm_r
- _EQ -> mkVBalBranch key elt emptyFM fm_r
-#else
- | split_key > key = splitGE fm_r split_key
- | split_key < key = mkVBalBranch key elt (splitGE fm_l split_key) fm_r
- | otherwise = mkVBalBranch key elt emptyFM fm_r
-#endif
--}
-
-splitGT EmptyFM split_key = emptyFM
-splitGT (Branch key elt _ fm_l fm_r) split_key
-#ifdef __GLASGOW_HASKELL__
- = case _tagCmp split_key key of
- _GT -> splitGT fm_r split_key
- _LT -> mkVBalBranch key elt (splitGT fm_l split_key) fm_r
- _EQ -> fm_r
-#else
- | split_key > key = splitGT fm_r split_key
- | split_key < key = mkVBalBranch key elt (splitGT fm_l split_key) fm_r
- | otherwise = fm_r
-#endif
-
-findMin :: FiniteMap key elt -> (key,elt)
-findMin (Branch key elt _ EmptyFM _) = (key,elt)
-findMin (Branch key elt _ fm_l _) = findMin fm_l
-
-deleteMin :: (Ord key OUTPUTABLE_key) => FiniteMap key elt -> FiniteMap key elt
-deleteMin (Branch key elt _ EmptyFM fm_r) = fm_r
-deleteMin (Branch key elt _ fm_l fm_r) = mkBalBranch key elt (deleteMin fm_l) fm_r
-
-findMax :: FiniteMap key elt -> (key,elt)
-findMax (Branch key elt _ _ EmptyFM) = (key,elt)
-findMax (Branch key elt _ _ fm_r) = findMax fm_r
-
-deleteMax :: (Ord key OUTPUTABLE_key) => FiniteMap key elt -> FiniteMap key elt
-deleteMax (Branch key elt _ fm_l EmptyFM) = fm_l
-deleteMax (Branch key elt _ fm_l fm_r) = mkBalBranch key elt fm_l (deleteMax fm_r)
-\end{code}
-
-%************************************************************************
-%* *
-\subsection{Output-ery}
-%* *
-%************************************************************************
-
-\begin{code}
-#if defined(COMPILING_GHC)
-
-{- this is the real one actually...
-instance (Outputable key, Outputable elt) => Outputable (FiniteMap key elt) where
- ppr sty fm = ppr sty (fmToList fm)
--}
-
--- temp debugging (ToDo: rm)
-instance (Outputable key) => Outputable (FiniteMap key elt) where
- ppr sty fm = pprX sty fm
-
-pprX sty EmptyFM = ppChar '!'
-pprX sty (Branch key elt sz fm_l fm_r)
- = ppBesides [ppLparen, pprX sty fm_l, ppSP,
- ppr sty key, ppSP, ppInt (IF_GHC(I# sz, sz)), ppSP,
- pprX sty fm_r, ppRparen]
-#endif
-
-#if !defined(COMPILING_GHC)
-instance (Eq key, Eq elt) => Eq (FiniteMap key elt) where
- fm_1 == fm_2 = (sizeFM fm_1 == sizeFM fm_2) && -- quick test
- (fmToList fm_1 == fmToList fm_2)
-
-{- NO: not clear what The Right Thing to do is:
-instance (Ord key, Ord elt) => Ord (FiniteMap key elt) where
- fm_1 <= fm_2 = (sizeFM fm_1 <= sizeFM fm_2) && -- quick test
- (fmToList fm_1 <= fmToList fm_2)
--}
-#endif
-\end{code}
-
-%************************************************************************
-%* *
-\subsection{FiniteSets---a thin veneer}
-%* *
-%************************************************************************
-
-\begin{code}
-#if defined(COMPILING_GHC)
-
-type FiniteSet key = FiniteMap key ()
-emptySet :: FiniteSet key
-mkSet :: (Ord key OUTPUTABLE_key) => [key] -> FiniteSet key
-isEmptySet :: FiniteSet key -> Bool
-elementOf :: (Ord key OUTPUTABLE_key) => key -> FiniteSet key -> Bool
-minusSet :: (Ord key OUTPUTABLE_key) => FiniteSet key -> FiniteSet key -> FiniteSet key
-setToList :: FiniteSet key -> [key]
-union :: (Ord key OUTPUTABLE_key) => FiniteSet key -> FiniteSet key -> FiniteSet key
-
-emptySet = emptyFM
-mkSet xs = listToFM [ (x, ()) | x <- xs]
-isEmptySet = isEmptyFM
-elementOf = elemFM
-minusSet = minusFM
-setToList = keysFM
-union = plusFM
-
-#endif
-\end{code}
-
-%************************************************************************
-%* *
-\subsection{Efficiency pragmas for GHC}
-%* *
-%************************************************************************
-
-When the FiniteMap module is used in GHC, we specialise it for
-\tr{Uniques}, for dastardly efficiency reasons.
-
-\begin{code}
-#if defined(COMPILING_GHC) && __GLASGOW_HASKELL__
- -- the __GLASGOW_HASKELL__ chk avoids an hbc 0.999.7 bug
-
-{-# SPECIALIZE listToFM
- :: [(Int,elt)] -> FiniteMap Int elt,
- [(CLabel,elt)] -> FiniteMap CLabel elt,
- [(FAST_STRING,elt)] -> FiniteMap FAST_STRING elt,
- [((FAST_STRING,FAST_STRING),elt)] -> FiniteMap (FAST_STRING, FAST_STRING) elt
- IF_NCG(COMMA [(Reg COMMA elt)] -> FiniteMap Reg elt)
- #-}
-{-# SPECIALIZE addToFM
- :: FiniteMap Int elt -> Int -> elt -> FiniteMap Int elt,
- FiniteMap FAST_STRING elt -> FAST_STRING -> elt -> FiniteMap FAST_STRING elt,
- FiniteMap CLabel elt -> CLabel -> elt -> FiniteMap CLabel elt
- IF_NCG(COMMA FiniteMap Reg elt -> Reg -> elt -> FiniteMap Reg elt)
- #-}
-{-# SPECIALIZE addListToFM
- :: FiniteMap Int elt -> [(Int,elt)] -> FiniteMap Int elt,
- FiniteMap CLabel elt -> [(CLabel,elt)] -> FiniteMap CLabel elt
- IF_NCG(COMMA FiniteMap Reg elt -> [(Reg COMMA elt)] -> FiniteMap Reg elt)
- #-}
-{-NOT EXPORTED!! # SPECIALIZE addToFM_C
- :: (elt -> elt -> elt) -> FiniteMap Int elt -> Int -> elt -> FiniteMap Int elt,
- (elt -> elt -> elt) -> FiniteMap CLabel elt -> CLabel -> elt -> FiniteMap CLabel elt
- IF_NCG(COMMA (elt -> elt -> elt) -> FiniteMap Reg elt -> Reg -> elt -> FiniteMap Reg elt)
- #-}
-{-# SPECIALIZE addListToFM_C
- :: (elt -> elt -> elt) -> FiniteMap Int elt -> [(Int,elt)] -> FiniteMap Int elt,
- (elt -> elt -> elt) -> FiniteMap TyCon elt -> [(TyCon,elt)] -> FiniteMap TyCon elt,
- (elt -> elt -> elt) -> FiniteMap CLabel elt -> [(CLabel,elt)] -> FiniteMap CLabel elt
- IF_NCG(COMMA (elt -> elt -> elt) -> FiniteMap Reg elt -> [(Reg COMMA elt)] -> FiniteMap Reg elt)
- #-}
-{-NOT EXPORTED!!! # SPECIALIZE delFromFM
- :: FiniteMap Int elt -> Int -> FiniteMap Int elt,
- FiniteMap CLabel elt -> CLabel -> FiniteMap CLabel elt
- IF_NCG(COMMA FiniteMap Reg elt -> Reg -> FiniteMap Reg elt)
- #-}
-{-# SPECIALIZE delListFromFM
- :: FiniteMap Int elt -> [Int] -> FiniteMap Int elt,
- FiniteMap CLabel elt -> [CLabel] -> FiniteMap CLabel elt
- IF_NCG(COMMA FiniteMap Reg elt -> [Reg] -> FiniteMap Reg elt)
- #-}
-{-# SPECIALIZE elemFM
- :: FAST_STRING -> FiniteMap FAST_STRING elt -> Bool
- #-}
-{-not EXPORTED!!! # SPECIALIZE filterFM
- :: (Int -> elt -> Bool) -> FiniteMap Int elt -> FiniteMap Int elt,
- (CLabel -> elt -> Bool) -> FiniteMap CLabel elt -> FiniteMap CLabel elt
- IF_NCG(COMMA (Reg -> elt -> Bool) -> FiniteMap Reg elt -> FiniteMap Reg elt)
- #-}
-{-NOT EXPORTED!!! # SPECIALIZE intersectFM
- :: FiniteMap Int elt -> FiniteMap Int elt -> FiniteMap Int elt,
- FiniteMap CLabel elt -> FiniteMap CLabel elt -> FiniteMap CLabel elt
- IF_NCG(COMMA FiniteMap Reg elt -> FiniteMap Reg elt -> FiniteMap Reg elt)
- #-}
-{-not EXPORTED !!!# SPECIALIZE intersectFM_C
- :: (elt -> elt -> elt) -> FiniteMap Int elt -> FiniteMap Int elt -> FiniteMap Int elt,
- (elt -> elt -> elt) -> FiniteMap CLabel elt -> FiniteMap CLabel elt -> FiniteMap CLabel elt
- IF_NCG(COMMA (elt -> elt -> elt) -> FiniteMap Reg elt -> FiniteMap Reg elt -> FiniteMap Reg elt)
- #-}
-{-# SPECIALIZE lookupFM
- :: FiniteMap Int elt -> Int -> Maybe elt,
- FiniteMap CLabel elt -> CLabel -> Maybe elt,
- FiniteMap FAST_STRING elt -> FAST_STRING -> Maybe elt,
- FiniteMap (FAST_STRING,FAST_STRING) elt -> (FAST_STRING,FAST_STRING) -> Maybe elt
- IF_NCG(COMMA FiniteMap Reg elt -> Reg -> Maybe elt)
- #-}
-{-# SPECIALIZE lookupWithDefaultFM
- :: FiniteMap Int elt -> elt -> Int -> elt,
- FiniteMap CLabel elt -> elt -> CLabel -> elt
- IF_NCG(COMMA FiniteMap Reg elt -> elt -> Reg -> elt)
- #-}
-{-# SPECIALIZE minusFM
- :: FiniteMap Int elt -> FiniteMap Int elt -> FiniteMap Int elt,
- FiniteMap TyCon elt -> FiniteMap TyCon elt -> FiniteMap TyCon elt,
- FiniteMap FAST_STRING elt -> FiniteMap FAST_STRING elt -> FiniteMap FAST_STRING elt,
- FiniteMap CLabel elt -> FiniteMap CLabel elt -> FiniteMap CLabel elt
- IF_NCG(COMMA FiniteMap Reg elt -> FiniteMap Reg elt -> FiniteMap Reg elt)
- #-}
-{-# SPECIALIZE plusFM
- :: FiniteMap Int elt -> FiniteMap Int elt -> FiniteMap Int elt,
- FiniteMap TyCon elt -> FiniteMap TyCon elt -> FiniteMap TyCon elt,
- FiniteMap CLabel elt -> FiniteMap CLabel elt -> FiniteMap CLabel elt
- IF_NCG(COMMA FiniteMap Reg elt -> FiniteMap Reg elt -> FiniteMap Reg elt)
- #-}
-{-# SPECIALIZE plusFM_C
- :: (elt -> elt -> elt) -> FiniteMap Int elt -> FiniteMap Int elt -> FiniteMap Int elt,
- (elt -> elt -> elt) -> FiniteMap CLabel elt -> FiniteMap CLabel elt -> FiniteMap CLabel elt
- IF_NCG(COMMA (elt -> elt -> elt) -> FiniteMap Reg elt -> FiniteMap Reg elt -> FiniteMap Reg elt)
- #-}
-
-#endif {- compiling for GHC -}
-\end{code}
+++ /dev/null
-%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
-%
-\section[ListSetOps]{Set-like operations on lists}
-
-\begin{code}
-module ListSetOps (
- unionLists,
- intersectLists,
- minusList
-#if ! defined(COMPILING_GHC)
- , disjointLists, intersectingLists
-#endif
- ) where
-
-#if defined(COMPILING_GHC)
-import Util
-# ifdef USE_ATTACK_PRAGMAS
-import AbsUniType
-import Id ( Id )
-# endif
-#endif
-\end{code}
-
-\begin{code}
-unionLists :: (Eq a) => [a] -> [a] -> [a]
-unionLists [] [] = []
-unionLists [] b = b
-unionLists a [] = a
-unionLists (a:as) b
- | a `is_elem` b = unionLists as b
- | otherwise = a : unionLists as b
- where
-#if defined(COMPILING_GHC)
- is_elem = isIn "unionLists"
-#else
- is_elem = elem
-#endif
-
-intersectLists :: (Eq a) => [a] -> [a] -> [a]
-intersectLists [] [] = []
-intersectLists [] b = []
-intersectLists a [] = []
-intersectLists (a:as) b
- | a `is_elem` b = a : intersectLists as b
- | otherwise = intersectLists as b
- where
-#if defined(COMPILING_GHC)
- is_elem = isIn "intersectLists"
-#else
- is_elem = elem
-#endif
-\end{code}
-
-Everything in the first list that is not in the second list:
-\begin{code}
-minusList :: (Eq a) => [a] -> [a] -> [a]
-minusList xs ys = [ x | x <- xs, x `not_elem` ys]
- where
-#if defined(COMPILING_GHC)
- not_elem = isn'tIn "minusList"
-#else
- not_elem = notElem
-#endif
-\end{code}
-
-\begin{code}
-#if ! defined(COMPILING_GHC)
-
-disjointLists, intersectingLists :: Eq a => [a] -> [a] -> Bool
-
-disjointLists [] bs = True
-disjointLists (a:as) bs
- | a `elem` bs = False
- | otherwise = disjointLists as bs
-
-intersectingLists xs ys = not (disjointLists xs ys)
-#endif
-\end{code}
-
-\begin{code}
-#if defined(COMPILING_GHC)
-# ifdef USE_ATTACK_PRAGMAS
-
-{-# SPECIALIZE unionLists :: [TyVar] -> [TyVar] -> [TyVar] #-}
-{-# SPECIALIZE intersectLists :: [TyVar] -> [TyVar] -> [TyVar] #-}
-
-{-# SPECIALIZE minusList :: [TyVar] -> [TyVar] -> [TyVar],
- [Id] -> [Id] -> [Id],
- [Int] -> [Int] -> [Int]
- #-}
-
-# endif
-#endif
-\end{code}
+++ /dev/null
-\section[match]{PackedString functions for matching}
-
-This module provides regular expression matching and substitution
-at the PackedString level. It is built on top of the GNU Regex
-library modified to handle perl regular expression syntax.
-For a complete description of the perl syntax, do `man perlre`
-or have a gander in (Programming|Learning) Perl. Here's
-a short summary:
-
-^ matches the beginning of line
-$ matches end of line
-\b matches word boundary
-\B matches non-word boundary
-\w matches a word(alpha-numeric) character
-\W matches a non-word character
-\d matches a digit
-\D matches a non-digit
-\s matches whitespace
-\S matches non-whitespace
-\A matches beginning of buffer
-\Z matches end-of-buffer
-. matches any (bar newline in single-line mode)
-+ matches 1 or more times
-* matches 0 or more times
-? matches 0 or 1
-{n,m} matches >=n and <=m atoms
-{n,} matches at least n times
-{n} matches n times
-[..] matches any character member of char class.
-(..) if pattern inside parens match, then the ith group is bound
- to the matched string
-\digit matches whatever the ith group matched.
-
-Backslashed letters
-\n newline
-\r carriage return
-\t tab
-\f formfeed
-\v vertical tab
-\a alarm bell
-\e escape
-
-
-\begin{code}
-module MatchPS
-
- (
- matchPS,
- searchPS,
- substPS,
- replacePS,
-
- match2PS,
- search2PS,
-
- getMatchesNo,
- getMatchedGroup,
- getWholeMatch,
- getLastMatch,
- getAfterMatch,
-
- findPS,
- rfindPS,
- chopPS,
-
- matchPrefixPS,
-
- REmatch(..)
- ) where
-
-import PreludeGlaST
-
-import Regex
-
-import Core -- alas ...
-
-\end{code}
-
-_tailPS and _dropPS in PS.lhs are not to my liking, use
-these instead.
-
-\begin{code}
-
-_dropPS' x str = _substrPS str x (_lengthPS str)
-
-_tailPS' x
- = if _nullPS x then
- error "_tailPS []"
- else
- _substrPS x 1 (_lengthPS x)
-
-
-\end{code}
-
-\subsection[ps-matching]{PackedString matching}
-
-Posix matching, returning an array of the the intervals that
-the individual groups matched within the string.
-
-\begin{code}
-
-matchPS :: _PackedString -- reg. exp
- -> _PackedString -- string to match
- -> [Char] -- flags
- -> Maybe REmatch
-matchPS reg str flags
- = let
- insensitive = 'i' `elem` flags
- mode = 's' `elem` flags
- in
- unsafePerformPrimIO (
- re_compile_pattern reg mode insensitive `thenPrimIO` \ pat ->
- re_match pat str 0 True)
-
-
-match2PS :: _PackedString -- reg. exp
- -> _PackedString -- string1 to match
- -> _PackedString -- string2 to match
- -> [Char] -- flags
- -> Maybe REmatch
-match2PS reg str1 str2 flags
- = let
- insensitive = 'i' `elem` flags
- mode = 's' `elem` flags
- len1 = _lengthPS str1
- len2 = _lengthPS str2
- in
- unsafePerformPrimIO (
- re_compile_pattern reg mode insensitive `thenPrimIO` \ pat ->
- re_match2 pat str1 str2 0 (len1+len2) True)
-
-\end{code}
-
-PackedString front-end to searching with GNU Regex
-
-\begin{code}
-
-searchPS :: _PackedString -- reg. exp
- -> _PackedString -- string to match
- -> [Char] -- flags
- -> Maybe REmatch
-searchPS reg str flags
- = let
- insensitive = 'i' `elem` flags
- mode = 's' `elem` flags
- in
- unsafePerformPrimIO (
- re_compile_pattern reg mode insensitive `thenPrimIO` \ pat ->
- re_search pat str
- 0
- (_lengthPS str)
- True)
-
-
-
-search2PS :: _PackedString -- reg. exp
- -> _PackedString -- string to match
- -> _PackedString -- string to match
- -> [Char] -- flags
- -> Maybe REmatch
-search2PS reg str1 str2 flags
- = let
- insensitive = 'i' `elem` flags
- mode = 's' `elem` flags
- len1 = _lengthPS str1
- len2 = _lengthPS str2
- len = len1+len2
- in
- unsafePerformPrimIO (
- re_compile_pattern reg mode insensitive `thenPrimIO` \ pat ->
- re_search2 pat
- str1
- str2
- 0
- len
- len
- True)
-
-
-
-\end{code}
-
-@_substrPS s st end@ cuts out the chunk in \tr{s} between \tr{st} and \tr{end}, inclusive.
-The \tr{Regex} registers represent substrings by storing the start and the end point plus
-one( st==end => empty string) , so we use @chunkPS@ instead.
-
-
-\begin{code}
-
-_chunkPS :: _PackedString
- -> (Int,Int)
- -> _PackedString
-_chunkPS str (st,end)
- = if st==end then
- _nilPS
- else
- _substrPS str st (max 0 (end-1))
-
-\end{code}
-
-Perl-like match and substitute
-
-\begin{code}
-
-substPS :: _PackedString -- reg. exp
- -> _PackedString -- replacement
- -> [Char] -- flags
- -> _PackedString -- string
- -> _PackedString
-substPS rexp
- repl
- flags
- str
- = search str
- where
- global = 'g' `elem` flags
- case_insensitive = 'i' `elem` flags
- mode = 's' `elem` flags -- single-line mode
- pat = unsafePerformPrimIO (
- re_compile_pattern rexp mode case_insensitive)
-
- search str
- = let
- search_res
- = unsafePerformPrimIO (re_search pat str 0 (_lengthPS str) True)
- in
- case search_res of
- Nothing -> str
- Just matcher@(REmatch arr before match after lst) ->
- let
- (st,en) = match
- prefix = _chunkPS str before
- suffix
- = if global && (st /= en) then
- search (_dropPS' en str)
- else
- _chunkPS str after
- in
- _concatPS [prefix,
- replace matcher repl str,
- suffix]
-
-
-replace :: REmatch
- -> _PackedString
- -> _PackedString
- -> _PackedString
-replace (REmatch arr before@(_,b_end) match after lst)
- replacement
- str
- = _concatPS (reverse acc) -- ToDo: write a `reversed' version of concatPS
- where
- (_,b) = bounds arr
-
- acc = replace' [] replacement False
-
- single :: Char -> _PackedString
- single x = _consPS x _nilPS
-
- replace' :: [_PackedString]
- -> _PackedString
- -> Bool
- -> [_PackedString]
- replace' acc repl escaped
- = if (_nullPS repl) then
- acc
- else
- let
- x = _headPS repl
- x# = case x of { C# c -> c }
- xs = _tailPS' repl
- in
- case x# of
- '\\'# ->
- if escaped then
- replace' acc xs True
- else
- replace' ((single x):acc) xs (not escaped)
- '$'# ->
- if (not escaped) then
- let
- x' = _headPS xs
- xs' = _tailPS' xs
- ith_ival = arr!num
- (num,xs_num) = getNumber ((ord x') - ord '0') xs'
- in
- if (isDigit x') && (num<=b) then
- replace' ((_chunkPS str ith_ival):acc) xs_num escaped
- else if x' == '&' then
- replace' ((_chunkPS str match):acc) xs' escaped
- else if x' == '+' then
- replace' ((_chunkPS str lst):acc) xs' escaped
- else if x' == '`' then
- replace' ((_chunkPS str (0,b_end)):acc) xs' escaped
- else if x' == '\'' then
- replace' ((_chunkPS str after):acc) xs' escaped
- else -- ignore
- replace' acc xs escaped
- else
- replace' ((single x):acc) xs False
-
- _ -> if escaped then
- (case x# of
- 'n'# -> -- newline
- replace' ((single '\n'):acc)
- 'f'# -> -- formfeed
- replace' ((single '\f'):acc)
- 'r'# -> -- carriage return
- replace' ((single '\r'):acc)
- 't'# -> -- (horiz) tab
- replace' ((single '\t'):acc)
- 'v'# -> -- vertical tab
- replace' ((single '\v'):acc)
- 'a'# -> -- alarm bell
- replace' ((single '\a'):acc)
- 'e'# -> -- escape
- replace' ((single '\033'):acc)
- _ ->
- replace' ((single x):acc)) xs False
- else
- replace' ((single x):acc) xs False
-
-
-getNumber :: Int -> _PackedString -> (Int,_PackedString)
-getNumber acc ps
- = if _nullPS ps then
- (acc,ps)
- else
- let
- x = _headPS ps
- xs = _tailPS ps
- in
- if (isDigit x) then
- getNumber (acc*10+(ord x - ord '0')) xs
- else
- (acc,ps)
-
-\end{code}
-
-Just like substPS, but no prefix and suffix.
-
-\begin{code}
-
-replacePS :: _PackedString -- reg. exp
- -> _PackedString -- replacement
- -> [Char] -- flags
- -> _PackedString -- string
- -> _PackedString
-replacePS rexp
- repl
- flags
- str
- = search str
- where
- global = 'g' `elem` flags
- case_insensitive = 'i' `elem` flags
- mode = 's' `elem` flags -- single-line mode
- pat = unsafePerformPrimIO (
- re_compile_pattern rexp mode case_insensitive)
-
- search str
- = let
- search_res
- = unsafePerformPrimIO (re_search pat str 0 (_lengthPS str) True)
- in
- case search_res of
- Nothing -> str
- Just matcher@(REmatch arr before match after lst) ->
- replace matcher repl str
-
-\end{code}
-
-Picking matched groups out of string
-
-\begin{code}
-
-getMatchesNo :: REmatch
- -> Int
-getMatchesNo (REmatch arr _ _ _ _)
- = snd (bounds arr)
-
-getMatchedGroup :: REmatch
- -> Int
- -> _PackedString
- -> _PackedString
-getMatchedGroup (REmatch arr bef mtch after lst) nth str
- = let
- (1,grps) = bounds arr
- in
- if (nth >= 1) && (nth <= grps) then
- _chunkPS str (arr!nth)
- else
- error "getMatchedGroup: group out of range"
-
-getWholeMatch :: REmatch
- -> _PackedString
- -> _PackedString
-getWholeMatch (REmatch _ _ mtch _ _) str
- = _chunkPS str mtch
-
-getLastMatch :: REmatch
- -> _PackedString
- -> _PackedString
-getLastMatch (REmatch _ _ _ _ lst) str
- = _chunkPS str lst
-
-getAfterMatch :: REmatch
- -> _PackedString
- -> _PackedString
-getAfterMatch (REmatch _ _ _ aft _) str
- = _chunkPS str aft
-
-\end{code}
-
-
-More or less straight translation of a brute-force string matching
-function written in C. (Sedgewick ch. 18)
-
-This is intended to provide much the same facilities as index/rindex in perl.
-
-\begin{code}
-
-
-findPS :: _PackedString
- -> _PackedString
- -> Maybe Int
-findPS str substr
- = let
- m = _lengthPS substr
- n = _lengthPS str
-
- loop i j
- | j>=m || i>=n = if j==m then (Just (i-m)) else Nothing
- | otherwise
- = inner_loop i j
-
- inner_loop i j
- = if j<m && i<n && (_indexPS str i /= _indexPS substr j) then
- inner_loop (i-j+1) 0
- else
- loop (i+1) (j+1)
- in
- loop 0 0
-
-rfindPS :: _PackedString
- -> _PackedString
- -> Maybe Int
-rfindPS str substr
- = let
- m = _lengthPS substr - 1
- n = _lengthPS str - 1
-
- loop i j
- | j<0 || i<0 = if j<0 then (Just (i+1)) else Nothing
- | otherwise
- = inner_loop i j
-
- inner_loop i j
- = if j>=0 && i>=0 && (_indexPS str i /= _indexPS substr j) then
- inner_loop (i+(m-j)-1) m
- else
- loop (i-1) (j-1)
- in
- loop n m
-
-
-\end{code}
-
-\begin{code}
-
-chopPS :: _PackedString -> _PackedString
-chopPS str = if _nullPS str then
- _nilPS
- else
- _chunkPS str (0,_lengthPS str-1)
-
-\end{code}
-
-Tries to match as much as possible of strA starting from the beginning of strB
-(handy when matching fancy literals in parsers)
-
-\begin{code}
-matchPrefixPS :: _PackedString
- -> _PackedString
- -> Int
-matchPrefixPS pref str
- = matchPrefixPS' pref str 0
- where
- matchPrefixPS' pref str n
- = if (_nullPS pref) || (_nullPS str) then
- n
- else if (_headPS pref) == (_headPS str) then
- matchPrefixPS' (_tailPS pref) (_tailPS str) (n+1)
- else
- n
-
-\end{code}
+++ /dev/null
-%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
-%
-\section[Maybes]{The `Maybe' types and associated utility functions}
-
-\begin{code}
-#if defined(COMPILING_GHC)
-#include "HsVersions.h"
-#endif
-
-module Maybes (
- Maybe(..), MaybeErr(..),
-
- allMaybes, -- GHCI only
- assocMaybe,
- catMaybes,
- failMaB,
- failMaybe,
- firstJust,
- mapMaybe, -- GHCI only
- maybeToBool,
- mkLookupFun,
- returnMaB,
- returnMaybe, -- GHCI only
- thenMaB,
- thenMaybe -- GHCI only
-
-#if ! defined(COMPILING_GHC)
- , findJust
- , foldlMaybeErrs
- , listMaybeErrs
-#endif
- ) where
-
-#if defined(COMPILING_GHC)
-import AbsUniType
-import Id
-import IdInfo
-import Name
-import Outputable
-#if USE_ATTACK_PRAGMAS
-import Util
-#endif
-#endif
-\end{code}
-
-
-%************************************************************************
-%* *
-\subsection[Maybe type]{The @Maybe@ type}
-%* *
-%************************************************************************
-
-\begin{code}
-#if __HASKELL1__ < 3
-data Maybe a
- = Nothing
- | Just a
-#endif
-\end{code}
-
-\begin{code}
-maybeToBool :: Maybe a -> Bool
-maybeToBool Nothing = False
-maybeToBool (Just x) = True
-\end{code}
-
-@catMaybes@ takes a list of @Maybe@s and returns a list of
-the contents of all the @Just@s in it. @allMaybes@ collects
-a list of @Justs@ into a single @Just@, returning @Nothing@ if there
-are any @Nothings@.
-
-\begin{code}
-catMaybes :: [Maybe a] -> [a]
-catMaybes [] = []
-catMaybes (Nothing : xs) = catMaybes xs
-catMaybes (Just x : xs) = (x : catMaybes xs)
-
-allMaybes :: [Maybe a] -> Maybe [a]
-allMaybes [] = Just []
-allMaybes (Nothing : ms) = Nothing
-allMaybes (Just x : ms) = case (allMaybes ms) of
- Nothing -> Nothing
- Just xs -> Just (x:xs)
-\end{code}
-
-@firstJust@ takes a list of @Maybes@ and returns the
-first @Just@ if there is one, or @Nothing@ otherwise.
-
-\begin{code}
-firstJust :: [Maybe a] -> Maybe a
-firstJust [] = Nothing
-firstJust (Just x : ms) = Just x
-firstJust (Nothing : ms) = firstJust ms
-\end{code}
-
-\begin{code}
-findJust :: (a -> Maybe b) -> [a] -> Maybe b
-findJust f [] = Nothing
-findJust f (a:as) = case f a of
- Nothing -> findJust f as
- b -> b
-\end{code}
-
-@assocMaybe@ looks up in an assocation list, returning
-@Nothing@ if it fails.
-
-\begin{code}
-assocMaybe :: (Eq a) => [(a,b)] -> a -> Maybe b
-
-assocMaybe alist key
- = lookup alist
- where
- lookup [] = Nothing
- lookup ((tv,ty):rest) = if key == tv then Just ty else lookup rest
-
-#if defined(COMPILING_GHC)
-{-# SPECIALIZE assocMaybe
- :: [(String, b)] -> String -> Maybe b,
- [(Id, b)] -> Id -> Maybe b,
- [(Class, b)] -> Class -> Maybe b,
- [(Int, b)] -> Int -> Maybe b,
- [(Name, b)] -> Name -> Maybe b,
- [(TyVar, b)] -> TyVar -> Maybe b,
- [(TyVarTemplate, b)] -> TyVarTemplate -> Maybe b
- #-}
-#endif
-\end{code}
-
-@mkLookupFun alist s@ is a function which looks up
-@s@ in the association list @alist@, returning a Maybe type.
-
-\begin{code}
-mkLookupFun :: (key -> key -> Bool) -- Equality predicate
- -> [(key,val)] -- The assoc list
- -> key -- The key
- -> Maybe val -- The corresponding value
-
-mkLookupFun eq alist s
- = case [a | (s',a) <- alist, s' `eq` s] of
- [] -> Nothing
- (a:_) -> Just a
-\end{code}
-
-\begin{code}
-#if __HASKELL1__ < 3
-thenMaybe :: Maybe a -> (a -> Maybe b) -> Maybe b
-m `thenMaybe` k = case m of
- Nothing -> Nothing
- Just a -> k a
-#endif
-returnMaybe :: a -> Maybe a
-returnMaybe = Just
-
-failMaybe :: Maybe a
-failMaybe = Nothing
-
-mapMaybe :: (a -> Maybe b) -> [a] -> Maybe [b]
-mapMaybe f [] = returnMaybe []
-mapMaybe f (x:xs) = f x `thenMaybe` (\ x' ->
- mapMaybe f xs `thenMaybe` (\ xs' ->
- returnMaybe (x':xs') ))
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[MaybeErr type]{The @MaybeErr@ type}
-%* *
-%************************************************************************
-
-\begin{code}
-data MaybeErr val err = Succeeded val | Failed err
-\end{code}
-
-\begin{code}
-thenMaB :: MaybeErr val1 err -> (val1 -> MaybeErr val2 err) -> MaybeErr val2 err
-thenMaB m k
- = case m of
- Succeeded v -> k v
- Failed e -> Failed e
-
-returnMaB :: val -> MaybeErr val err
-returnMaB v = Succeeded v
-
-failMaB :: err -> MaybeErr val err
-failMaB e = Failed e
-\end{code}
-
-
-@listMaybeErrs@ takes a list of @MaybeErrs@ and, if they all succeed, returns
-a @Succeeded@ of a list of their values. If any fail, it returns a
-@Failed@ of the list of all the errors in the list.
-
-\begin{code}
-listMaybeErrs :: [MaybeErr val err] -> MaybeErr [val] [err]
-listMaybeErrs
- = foldr combine (Succeeded [])
- where
- combine (Succeeded v) (Succeeded vs) = Succeeded (v:vs)
- combine (Failed err) (Succeeded _) = Failed [err]
- combine (Succeeded v) (Failed errs) = Failed errs
- combine (Failed err) (Failed errs) = Failed (err:errs)
-\end{code}
-
-@foldlMaybeErrs@ works along a list, carrying an accumulator; it
-applies the given function to the accumulator and the next list item,
-accumulating any errors that occur.
-
-\begin{code}
-foldlMaybeErrs :: (acc -> input -> MaybeErr acc err)
- -> acc
- -> [input]
- -> MaybeErr acc [err]
-
-foldlMaybeErrs k accum ins = do_it [] accum ins
- where
- do_it [] acc [] = Succeeded acc
- do_it errs acc [] = Failed errs
- do_it errs acc (v:vs) = case (k acc v) of
- Succeeded acc' -> do_it errs acc' vs
- Failed err -> do_it (err:errs) acc vs
-\end{code}
+++ /dev/null
-%
-% (c) The GRASP/AQUA Project, Glasgow University, 1993-1994
-%
-\section[PackedString]{Packed strings}
-
-A non-weird/abstract interface to the wired-in @PackedString@ type.
-
-\begin{code}
-module PackedString (
- PackedString(..),
-
- packString, -- :: [Char] -> PackedString
- packCString, -- :: _Addr -> PackedString
- packCBytes, -- :: Int -> _Addr -> PackedString
-
- packStringST, -- :: [Char] -> _ST s PackedString
- packCBytesST, -- :: Int -> _Addr -> _ST s PackedString
- packBytesForC, -- :: [Char] -> _ByteArray Int
- packBytesForCST, -- :: [Char] -> _ST s (_ByteArray Int)
-
---NO: packStringForC,
- nilPS, -- :: PackedString
- consPS, -- :: Char -> PackedString -> PackedString
- byteArrayToPS, -- :: _ByteArray Int -> PackedString
- psToByteArray, -- :: PackedString -> _ByteArray Int
-
- unpackPS, -- :: PackedString -> [Char]
---NO: unpackPS#,
- putPS, -- :: _FILE -> PackedString -> PrimIO ()
- getPS, -- :: _FILE -> Int -> PrimIO PackedString
-
- {- alt. names for packString, unpackPS -}
- implode, -- :: [Char] -> PackedString
- explode, -- :: PackedString -> [Char]
-
- headPS, -- :: PackedString -> Char
- tailPS, -- :: PackedString -> PackedString
- nullPS, -- :: PackedString -> Bool
- appendPS, -- :: PackedString -> PackedString -> PackedString
- lengthPS, -- :: PackedString -> Int
- indexPS, -- :: PackedString -> Int -> Char
- mapPS, -- :: (Char -> Char) -> PackedString -> PackedString
- filterPS, -- :: (Char -> Bool) -> PackedString -> PackedString
- foldlPS, -- :: (a -> Char -> a) -> a -> PackedString -> a
- foldrPS, -- :: (Char -> a -> a) -> a -> PackedString -> a
- takePS, -- :: Int -> PackedString -> PackedString
- dropPS, -- :: Int -> PackedString -> PackedString
- splitAtPS, -- :: Int -> PackedString -> PackedString
- takeWhilePS, -- :: (Char -> Bool) -> PackedString -> PackedString
- dropWhilePS, -- :: (Char -> Bool) -> PackedString -> PackedString
- spanPS, -- :: (Char -> Bool) -> PackedString -> (PackedString, PackedString)
- breakPS, -- :: (Char -> Bool) -> PackedString -> (PackedString, PackedString)
- linesPS, -- :: PackedString -> [PackedString]
- wordsPS, -- :: PackedString -> [PackedString]
- reversePS, -- :: PackedString -> PackedString
- concatPS, -- :: [PackedString] -> PackedString
-
- substrPS, -- :: PackedString -> Int -> Int -> PackedString
-
- -- to make interface self-sufficient
- _PackedString, -- abstract!
- _FILE
- ) where
-
-import PS
-
-type PackedString = _PackedString
-
-packString = _packString
-packCString = _packCString
-
-packCBytes = _packCBytes
---packStringForC = _packStringForC
-nilPS = _nilPS
-consPS = _consPS
-byteArrayToPS = _byteArrayToPS
-psToByteArray = _psToByteArray
-
-packStringST = _packStringST
-packCBytesST = _packCBytesST
-packBytesForC = _packBytesForC
-packBytesForCST = _packBytesForCST
-
-unpackPS = _unpackPS
-putPS = _putPS
-getPS = _getPS
-
-implode = _packString -- alt. names
-explode = _unpackPS
-
-headPS = _headPS
-tailPS = _tailPS
-nullPS = _nullPS
-appendPS = _appendPS
-lengthPS = _lengthPS
-indexPS = _indexPS
-mapPS = _mapPS
-filterPS = _filterPS
-foldlPS = _foldlPS
-foldrPS = _foldrPS
-takePS = _takePS
-dropPS = _dropPS
-splitAtPS = _splitAtPS
-takeWhilePS = _takeWhilePS
-dropWhilePS = _dropWhilePS
-spanPS = _spanPS
-breakPS = _breakPS
-linesPS = _linesPS
-wordsPS = _wordsPS
-reversePS = _reversePS
-concatPS = _concatPS
-
-substrPS = _substrPS
-\end{code}
+++ /dev/null
-%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
-%
-\section[Pretty]{Pretty-printing data type}
-
-\begin{code}
-#if defined(COMPILING_GHC)
-# include "HsVersions.h"
-#else
-# define FAST_STRING String
-# define _LENGTH_ length
-#endif
-
-module Pretty (
- Pretty(..),
-
-#if defined(COMPILING_GHC)
- PprStyle(..),
- prettyToUn,
- codeStyle, -- UNUSED: stySwitch,
-#endif
- ppNil, ppStr, ppPStr, ppChar, ppInt, ppInteger,
- ppFloat, ppDouble,
-#if __GLASGOW_HASKELL__ >= 23
- -- may be able to *replace* ppDouble
- ppRational,
-#endif
- ppSP, pp'SP, ppLbrack, ppRbrack, ppLparen, ppRparen,
- ppSemi, ppComma, ppEquals,
-
- ppCat, ppBeside, ppBesides, ppAbove, ppAboves,
- ppNest, ppSep, ppHang, ppInterleave, ppIntersperse,
- ppShow,
-#if defined(COMPILING_GHC) && __GLASGOW_HASKELL__ >= 22
- ppAppendFile,
-#endif
-
- -- abstract type, to complete the interface...
- PrettyRep(..), CSeq, Delay
-#if defined(COMPILING_GHC)
- , GlobalSwitch, Unpretty(..)
-#endif
- ) where
-
-import CharSeq
-#if defined(COMPILING_GHC)
-import Unpretty ( Unpretty(..) )
-import CmdLineOpts ( GlobalSwitch )
-#endif
-\end{code}
-
-Based on John Hughes's pretty-printing library. For now, that code
-and notes for it are in files \tr{pp-rjmh*} (ToDo: rm).
-
-%************************************************
-%* *
- \subsection{The interface}
-%* *
-%************************************************
-
-\begin{code}
-ppNil :: Pretty
-ppSP, pp'SP, ppLbrack, ppRbrack, ppLparen, ppRparen, ppSemi, ppComma, ppEquals :: Pretty
-
-ppStr :: [Char] -> Pretty
-ppPStr :: FAST_STRING -> Pretty
-ppChar :: Char -> Pretty
-ppInt :: Int -> Pretty
-ppInteger :: Integer -> Pretty
-ppDouble :: Double -> Pretty
-ppFloat :: Float -> Pretty
-#if __GLASGOW_HASKELL__ >= 23
-ppRational :: Rational -> Pretty
-#endif
-
-ppBeside :: Pretty -> Pretty -> Pretty
-ppBesides :: [Pretty] -> Pretty
-ppBesideSP :: Pretty -> Pretty -> Pretty
-ppCat :: [Pretty] -> Pretty -- i.e., ppBesidesSP
-
-ppAbove :: Pretty -> Pretty -> Pretty
-ppAboves :: [Pretty] -> Pretty
-
-ppInterleave :: Pretty -> [Pretty] -> Pretty
-ppIntersperse :: Pretty -> [Pretty] -> Pretty -- no spaces between, no ppSep
-ppSep :: [Pretty] -> Pretty
-ppHang :: Pretty -> Int -> Pretty -> Pretty
-ppNest :: Int -> Pretty -> Pretty
-
-ppShow :: Int -> Pretty -> [Char]
-
-#if defined(COMPILING_GHC) && __GLASGOW_HASKELL__ >= 22
-# if __GLASGOW_HASKELL__ < 23
-# define _FILE _Addr
-# endif
-ppAppendFile :: _FILE -> Int -> Pretty -> PrimIO ()
-#endif
-\end{code}
-
-%************************************************
-%* *
- \subsection{The representation}
-%* *
-%************************************************
-
-\begin{code}
-type Pretty = Int -- The width to print in
- -> Bool -- True => vertical context
- -> PrettyRep
-
-data PrettyRep
- = MkPrettyRep CSeq -- The text
- (Delay Int) -- No of chars in last line
- Bool -- True if empty object
- Bool -- Fits on a single line in specified width
-
-data Delay a = MkDelay a
-
-forceDel (MkDelay _) r = r
-
-forceBool True r = r
-forceBool False r = r
-
-forceInfo ll emp sl r = forceDel ll (forceBool emp (forceBool sl r))
-
-ppShow width p
- = case (p width False) of
- MkPrettyRep seq ll emp sl -> cShow seq
-
-#if defined(COMPILING_GHC) && __GLASGOW_HASKELL__ >= 22
-ppAppendFile f width p
- = case (p width False) of
- MkPrettyRep seq ll emp sl -> cAppendFile f seq
-#endif
-
-ppNil width is_vert = MkPrettyRep cNil (MkDelay 0) True (width >= 0)
- -- Doesn't fit if width < 0, otherwise, ppNil
- -- will make ppBesides always return True.
-
-ppStr s width is_vert = MkPrettyRep (cStr s) (MkDelay ls) False (width >= ls)
- where ls = length s
-ppPStr s width is_vert = MkPrettyRep (cPStr s) (MkDelay ls) False (width >= ls)
- where ls = _LENGTH_ s
-ppChar c width is_vert = MkPrettyRep (cCh c) (MkDelay 1) False (width >= 1)
-
-ppInt n width is_vert = MkPrettyRep (cStr s) (MkDelay ls) False (width >= ls)
- where s = show n; ls = length s
-
-ppInteger n = ppStr (show n)
-ppDouble n = ppStr (show n)
-ppFloat n = ppStr (show n)
-#if __GLASGOW_HASKELL__ >= 23
---ppRational n = ppStr (_showRational 30 n)
-ppRational n = ppStr (show (fromRationalX n)) -- _showRational 30 n)
-#endif
-
-ppSP = ppChar ' '
-pp'SP = ppStr ", "
-ppLbrack = ppChar '['
-ppRbrack = ppChar ']'
-ppLparen = ppChar '('
-ppRparen = ppChar ')'
-ppSemi = ppChar ';'
-ppComma = ppChar ','
-ppEquals = ppChar '='
-
-ppInterleave sep ps = ppSep (pi ps)
- where
- pi [] = []
- pi [x] = [x]
- pi (x:xs) = (ppBeside x sep) : pi xs
-\end{code}
-
-ToDo: this could be better: main pt is: no extra spaces in between.
-
-\begin{code}
-ppIntersperse sep ps = ppBesides (pi ps)
- where
- pi [] = []
- pi [x] = [x]
- pi (x:xs) = (ppBeside x sep) : pi xs
-\end{code}
-
-Laziness is important in @ppBeside@. If the first thing is not a
-single line it will return @False@ for the single-line boolean without
-laying out the second.
-
-\begin{code}
-ppBeside p1 p2 width is_vert
- = case (p1 width False) of
- MkPrettyRep seq1 (MkDelay ll1) emp1 sl1 ->
- MkPrettyRep (seq1 `cAppend` (cIndent ll1 seq2))
- (MkDelay (ll1 + ll2))
- (emp1 && emp2)
- ((width >= 0) && (sl1 && sl2))
- -- This sequence of (&&)'s ensures that ppBeside
- -- returns a False for sl as soon as possible.
- where -- NB: for case alt
- seq2 = forceInfo x_ll2 emp2 sl2 x_seq2
- MkDelay ll2 = x_ll2
- MkPrettyRep x_seq2 x_ll2 emp2 sl2 = p2 (width-ll1) False
- -- ToDo: if emp{1,2} then we really
- -- should be passing on "is_vert" to p{2,1}.
-
-ppBesides [] = ppNil
-ppBesides ps = foldr1 ppBeside ps
-\end{code}
-
-@ppBesideSP@ puts two things beside each other separated by a space.
-
-\begin{code}
-ppBesideSP p1 p2 width is_vert
- = case (p1 width False) of
- MkPrettyRep seq1 (MkDelay ll1) emp1 sl1 ->
- MkPrettyRep (seq1 `cAppend` (sp `cAppend` (cIndent li seq2)))
- (MkDelay (li + ll2))
- (emp1 && emp2)
- ((width >= wi) && (sl1 && sl2))
- where -- NB: for case alt
- seq2 = forceInfo x_ll2 emp2 sl2 x_seq2
- MkDelay ll2 = x_ll2
- MkPrettyRep x_seq2 x_ll2 emp2 sl2 = p2 (width-li) False
- li, wi :: Int
- li = if emp1 then 0 else ll1+1
- wi = if emp1 then 0 else 1
- sp = if emp1 || emp2 then cNil else (cCh ' ')
-\end{code}
-
-@ppCat@ is the name I (WDP) happen to have been using for @ppBesidesSP@.
-
-\begin{code}
-ppCat [] = ppNil
-ppCat ps = foldr1 ppBesideSP ps
-\end{code}
-
-\begin{code}
-ppAbove p1 p2 width is_vert
- = case (p1 width True) of
- MkPrettyRep seq1 (MkDelay ll1) emp1 sl1 ->
- MkPrettyRep (seq1 `cAppend` (nl `cAppend` seq2))
- (MkDelay ll2)
- -- ToDo: make ll depend on empties?
- (emp1 && emp2)
- False
- where -- NB: for case alt
- nl = if emp1 || emp2 then cNil else cNL
- seq2 = forceInfo x_ll2 emp2 sl2 x_seq2
- MkDelay ll2 = x_ll2 -- Don't "optimise" this away!
- MkPrettyRep x_seq2 x_ll2 emp2 sl2 = p2 width True
- -- ToDo: ditto about passing is_vert if empties
-
-ppAboves [] = ppNil
-ppAboves ps = foldr1 ppAbove ps
-\end{code}
-
-\begin{code}
-ppNest n p width False = p width False
-ppNest n p width True
- = case (p (width-n) True) of
- MkPrettyRep seq (MkDelay ll) emp sl ->
- MkPrettyRep (cIndent n seq) (MkDelay (ll+n)) emp sl
-\end{code}
-
-The length-check below \tr{(ll1+ll2+1) <= width} should really check for
-max widths not the width of the last line.
-
-\begin{code}
-ppHang p1 n p2 width is_vert -- This is a little bit stricter than it could
- -- be made with a little more effort.
- -- Eg the output always starts with seq1
- = case (p1 width False) of
- MkPrettyRep seq1 (MkDelay ll1) emp1 sl1 ->
- if emp1 then
- p2 width is_vert
- else
- if (ll1 <= n) || sl2 then -- very ppBesideSP'ish
- -- Hang it if p1 shorter than indent or if it doesn't fit
- MkPrettyRep (seq1 `cAppend` ((cCh ' ') `cAppend` (cIndent (ll1+1) seq2)))
- (MkDelay (ll1 + 1 + ll2))
- False
- (sl1 && sl2)
- else
- -- Nest it (pretty ppAbove-ish)
- MkPrettyRep (seq1 `cAppend` (cNL `cAppend` (cIndent n seq2')))
- (MkDelay ll2') -- ToDo: depend on empties
- False
- False
- where -- NB: for case alt
- seq2 = forceInfo x_ll2 emp2 sl2 x_seq2
- MkDelay ll2 = x_ll2
- MkPrettyRep x_seq2 x_ll2 emp2 sl2 = p2 (width-(ll1+1)) False
- -- ToDo: more "is_vert if empty" stuff
-
- seq2' = forceInfo x_ll2' emp2' sl2' x_seq2'
- MkDelay ll2' = x_ll2' -- Don't "optimise" this away!
- MkPrettyRep x_seq2' x_ll2' emp2' sl2' = p2 (width-n) False -- ToDo: True?
-\end{code}
-
-\begin{code}
-ppSep [] width is_vert = ppNil width is_vert
-ppSep [p] width is_vert = p width is_vert
-
--- CURRENT, but BAD. Quadratic behaviour on the perfectly reasonable
--- ppSep [a, ppSep[b, ppSep [c, ... ]]]
-
-ppSep ps width is_vert
- = case (ppCat ps width is_vert) of
- MkPrettyRep seq x_ll emp sl ->
- if sl then -- Fits on one line
- MkPrettyRep seq x_ll emp sl
- else
- ppAboves ps width is_vert -- Takes several lines
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[Outputable-print]{Pretty-printing stuff}
-%* *
-%************************************************************************
-
-ToDo: this is here for no-original-name reasons (mv?).
-
-There is no clearly definitive list of @PprStyles@; I suggest the
-following:
-
-\begin{code}
-#if defined(COMPILING_GHC)
- -- to the end of file
-
-data PprStyle
- = PprForUser -- Pretty-print in a way that will
- -- make sense to the ordinary user;
- -- must be very close to Haskell
- -- syntax, etc. ToDo: how diff is
- -- this from what pprInterface must
- -- do?
- | PprDebug -- Standard debugging output
- | PprShowAll -- Debugging output which leaves
- -- nothing to the imagination
- | PprInterface -- Interface generation
- (GlobalSwitch -> Bool) -- (we can look at cmd-line flags)
- | PprForC -- must print out C-acceptable names
- (GlobalSwitch -> Bool) -- (ditto)
- | PprUnfolding -- for non-interface intermodule info
- (GlobalSwitch -> Bool) -- the compiler writes/reads
- | PprForAsm -- must print out assembler-acceptable names
- (GlobalSwitch -> Bool) -- (ditto)
- Bool -- prefix CLabel with underscore?
- (String -> String) -- format AsmTempLabel
-\end{code}
-
-The following test decides whether or not we are actually generating
-code (either C or assembly).
-\begin{code}
-codeStyle :: PprStyle -> Bool
-codeStyle (PprForC _) = True
-codeStyle (PprForAsm _ _ _) = True
-codeStyle _ = False
-
-{- UNUSED:
-stySwitch :: PprStyle -> GlobalSwitch -> Bool
-stySwitch (PprInterface sw) = sw
-stySwitch (PprForC sw) = sw
-stySwitch (PprForAsm sw _ _) = sw
--}
-\end{code}
-
-Orthogonal to these printing styles are (possibly) some command-line
-flags that affect printing (often carried with the style). The most
-likely ones are variations on how much type info is shown.
-
-\begin{code}
-prettyToUn :: Pretty -> Unpretty
-
-prettyToUn p
- = case (p 999999{-totally bogus width-} False{-also invented-}) of
- MkPrettyRep seq ll emp sl -> seq
-
-#endif {-COMPILING_GHC-}
-\end{code}
-
------------------------------------
-\begin{code}
--- from Lennart
-fromRationalX :: (RealFloat a) => Rational -> a
-
-fromRationalX r =
- let
- h = ceiling (huge `asTypeOf` x)
- b = toInteger (floatRadix x)
- x = fromRat 0 r
- fromRat e0 r' =
- let d = denominator r'
- n = numerator r'
- in if d > h then
- let e = integerLogBase b (d `div` h) + 1
- in fromRat (e0-e) (n % (d `div` (b^e)))
- else if abs n > h then
- let e = integerLogBase b (abs n `div` h) + 1
- in fromRat (e0+e) ((n `div` (b^e)) % d)
- else
- scaleFloat e0 (fromRational r')
- in x
-
--- Compute the discrete log of i in base b.
--- Simplest way would be just divide i by b until it's smaller then b, but that would
--- be very slow! We are just slightly more clever.
-integerLogBase :: Integer -> Integer -> Int
-integerLogBase b i =
- if i < b then
- 0
- else
- -- Try squaring the base first to cut down the number of divisions.
- let l = 2 * integerLogBase (b*b) i
-
- doDiv :: Integer -> Int -> Int
- doDiv j k = if j < b then k else doDiv (j `div` b) (k+1)
- in
- doDiv (i `div` (b^l)) l
-
-
-------------
-
--- Compute smallest and largest floating point values.
-{-
-tiny :: (RealFloat a) => a
-tiny =
- let (l, _) = floatRange x
- x = encodeFloat 1 (l-1)
- in x
--}
-
-huge :: (RealFloat a) => a
-huge =
- let (_, u) = floatRange x
- d = floatDigits x
- x = encodeFloat (floatRadix x ^ d - 1) (u - d)
- in x
-\end{code}
+++ /dev/null
-%
-% (c) The GRASP/AQUA Project, Glasgow University, 1995
-%
-% Last Modified: Wed Jul 19 13:04:53 1995
-% Darren J Moffat <moffatd@dcs.gla.ac.uk>
-\section[Readline]{GNU Readline Library Bindings}
-
-This module attempts to provide a better line based editing facility
-for Haskell programmers by providing access to the GNU Readline
-library. Related to this are bindings for the GNU History library
-which can be found in History.
-
-
-\begin{code}
-module Readline (
- rlInitialize,
- readline, addHistory,
-
- rlBindKey, rlAddDefun,
- RlCallbackFunction(..),
-
- rlGetLineBuffer, rlSetLineBuffer,
- rlGetPoint, rlSetPoint,
- rlGetEnd, rlSetEnd,
- rlGetMark, rlSetMark,
- rlSetDone,
- rlPendingInput,
-
- rlPrompt, rlTerminalName, rlSetReadlineName, rlGetReadlineName
-
--- rlInStream, rlOutStream
-
--- rlStartupHook
-
-) where
-
-import PreludeGlaMisc
-import PreludeGlaST
-import LibSystem
-
-
---#include <readline/readline.h>
-
-type KeyCode = Int
-
-type RlCallbackFunction =
- (Int -> -- Numeric Argument
- KeyCode -> -- KeyCode of pressed Key
- IO Int)
-\end{code}
-
-%***************************************************************************
-%* *
-\subsection[Readline-Functions]{Main Readline Functions}
-%* *
-%***************************************************************************
-\begin{code}
-
-readline :: String -> -- Prompt String
- IO String -- Returned line
-readline prompt =
---ToDo: Get the "Live register in _casm_GC_ " bug fixed
--- this stops us passing the prompt string to readline directly :-(
--- _casm_GC_ ``%r = readline %0;'' prompt `thenPrimIO` \ litstr ->
-
- _casm_ ``rl_prompt_hack = (char*)realloc(rl_prompt_hack, %1);
- strcpy (rl_prompt_hack,%0);''
- prompt (length prompt) `thenPrimIO` \ () ->
- _casm_GC_ ``%r = readline (rl_prompt_hack);'' `thenPrimIO` \ litstr ->
- if (litstr == ``NULL'') then
- fail "Readline has read EOF"
- else (
- let str = _unpackPS (_packCString litstr) in
- _casm_ ``free %0;'' litstr `thenPrimIO` \ () ->
- return str
- )
-
-
-addHistory :: String -> -- String to enter in history
- IO ()
-addHistory str = primIOToIO (_ccall_ add_history str)
-
-
-rlBindKey :: KeyCode -> -- Key to Bind to
- RlCallbackFunction -> -- Function to exec on execution
- IO ()
-rlBindKey key cback =
- if (0 > key) || (key > 255) then
- fail "Invalid ASCII Key Code, must be in range 0.255"
- else
- addCbackEntry (key,cback) `seqPrimIO`
- _casm_ `` rl_bind_key((KeyCode)%0,&genericRlCback); ''
- key `thenPrimIO` \ () ->
- return ()
-
-\end{code}
-
-i.e. add the (KeyCode,RlCallbackFunction) key to the assoc. list and register
-the generic callback for this KeyCode.
-
-The entry point that $genericRlCback$ calls would then read the
-global variables $current\_i$ and $current\_kc$ and do a lookup:
-
-\begin{code}
-rlAddDefun :: String -> -- Function Name
- RlCallbackFunction -> -- Function to call
- KeyCode -> -- Key to bind to, or -1 for no bind
- IO ()
-rlAddDefun name cback key =
- if (0 > key) || (key > 255) then
- fail "Invalid ASCII Key Code, must be in range 0..255"
- else
- addCbackEntry (key, cback) `seqPrimIO`
- _casm_ ``rl_add_defun (%0, &genericRlCback, (KeyCode)%1);''
- name key `thenPrimIO` \ () ->
- return ()
-
-\end{code}
-
-
-The C function $genericRlCallback$ puts the callback arguments into
-global variables and enters the Haskell world through the
-$haskellRlEntry$ function. Before exiting, the Haskell function will
-deposit its result in the global varariable $rl\_return$.
-
-In the Haskell action that is invoked via $enterStablePtr$, a match
-between the Keycode in $current\_kc$ and the Haskell callback needs to
-be made. To essentially keep the same assoc. list of (KeyCode,cback
-function) as Readline does, we make use of yet another global variable
-$cbackList$:
-
-\begin{code}
-
-createCbackList :: [(KeyCode,RlCallbackFunction)] -> PrimIO ()
-createCbackList ls =
-#ifndef __PARALLEL_HASKELL__
- makeStablePtr ls `thenPrimIO` \ stable_ls ->
- _casm_ `` cbackList=(StgStablePtr)%0; '' stable_ls
-#else
- error "createCbackList: not available for Parallel Haskell"
-#endif
-
-getCbackList :: PrimIO [(KeyCode,RlCallbackFunction)]
-getCbackList =
-#ifndef __PARALLEL_HASKELL__
- _casm_ `` %r=(StgStablePtr)cbackList; '' `thenPrimIO` \ stable_ls ->
- deRefStablePtr stable_ls
-#else
- error "getCbackList: not available for Parallel Haskell"
-#endif
-
-setCbackList :: [(KeyCode,RlCallbackFunction)] -> PrimIO ()
-setCbackList ls =
-#ifndef __PARALLEL_HASKELL__
- _casm_ `` %r=(StgStablePtr)cbackList; '' `thenPrimIO` \ old_stable_ls ->
- freeStablePtr old_stable_ls `seqPrimIO`
- createCbackList ls
-#else
- error "setCbackList: not available for Parallel Haskell"
-#endif
-
-addCbackEntry :: (KeyCode,RlCallbackFunction) -> PrimIO ()
-addCbackEntry entry =
- getCbackList `thenPrimIO` \ ls ->
- setCbackList (entry:ls)
-
-\end{code}
-
-The above functions allows us to query and augment the assoc. list in
-Haskell.
-
-
-\begin{code}
-
-invokeRlCback :: PrimIO ()
-invokeRlCback =
- _casm_ `` %r=(KeyCode)current_kc; '' `thenPrimIO` \ kc ->
- _casm_ `` %r=(int)current_narg; '' `thenPrimIO` \ narg ->
- getCbackList `thenPrimIO` \ ls ->
- (case (dropWhile (\ (key,_) -> kc/=key) ls) of
- [] -> -- no match
- returnPrimIO (-1)
- ((_,cback):_) ->
- ioToPrimIO (cback narg kc)
- ) `thenPrimIO` \ ret_val ->
- _casm_ `` rl_return=(int)%0; '' ret_val `thenPrimIO` \ () ->
- returnPrimIO ()
-
-\end{code}
-
-Finally, we need to initialise this whole, ugly machinery:
-
-\begin{code}
-
-initRlCbacks :: PrimIO ()
-initRlCbacks =
-#ifndef __PARALLEL_HASKELL__
- createCbackList [] `seqPrimIO`
- makeStablePtr (invokeRlCback) `thenPrimIO` \ stable_f ->
- _casm_ `` haskellRlEntry=(StgStablePtr)%0; '' stable_f `thenPrimIO` \ () ->
- returnPrimIO ()
-#else
- error "initRlCbacks: not available for Parallel Haskell"
-#endif
-
-\end{code}
-
-
-%***************************************************************************
-%* *
-\subsection[Readline-Globals]{Global Readline Variables}
-%* *
-%***************************************************************************
-
-These are the global variables required by the readline lib. Need to
-find a way of making these read/write from the Haskell side. Should
-they be in the IO Monad, should they be Mutable Variables?
-
-\begin{code}
-
-rlGetLineBuffer :: IO String
-rlGetLineBuffer =
- _casm_ ``%r = rl_line_buffer;'' `thenPrimIO` \ litstr ->
- return (_unpackPS (_packCString litstr))
-
-rlSetLineBuffer :: String -> IO ()
-rlSetLineBuffer str = primIOToIO (_casm_ ``rl_line_buffer = %0;'' str)
-
-
-rlGetPoint :: IO Int
-rlGetPoint = primIOToIO (_casm_ ``%r = rl_point;'')
-
-rlSetPoint :: Int -> IO ()
-rlSetPoint point = primIOToIO (_casm_ ``rl_point = %0;'' point)
-
-rlGetEnd :: IO Int
-rlGetEnd = primIOToIO (_casm_ ``%r = rl_end;'')
-
-rlSetEnd :: Int -> IO ()
-rlSetEnd end = primIOToIO (_casm_ ``rl_end = %0;'' end)
-
-rlGetMark :: IO Int
-rlGetMark = primIOToIO (_casm_ ``%r = rl_mark;'')
-
-rlSetMark :: Int -> IO ()
-rlSetMark mark = primIOToIO (_casm_ ``rl_mark = %0;'' mark)
-
-rlSetDone :: Bool -> IO ()
-rlSetDone True = primIOToIO (_casm_ ``rl_done = %0;'' 1)
-rlSetDone False = primIOToIO (_casm_ ``rl_done = %0;'' 0)
-
-rlPendingInput :: KeyCode -> IO ()
-rlPendingInput key = primIOToIO (_casm_ ``rl_pending_input = %0;'' key)
-
-rlPrompt :: IO String
-rlPrompt =
- _casm_ ``%r = rl_readline_name;'' `thenPrimIO` \ litstr ->
- return (_unpackPS (_packCString litstr))
-
-rlTerminalName :: IO String
-rlTerminalName =
- _casm_ ``%r = rl_terminal_name;'' `thenPrimIO` \ litstr ->
- return (_unpackPS (_packCString litstr))
-
-
-rlGetReadlineName :: IO String
-rlGetReadlineName =
- _casm_ ``%r = rl_readline_name;'' `thenPrimIO` \ litstr ->
- return (_unpackPS (_packCString litstr))
-
-rlSetReadlineName :: String -> IO ()
-rlSetReadlineName str = primIOToIO (
- _casm_ ``rl_readline_name = %0;'' str)
-
-\end{code}
-
-\begin{verbatim}
---
--- The following two were taken from PreludeStdIO stdin/stdout
---
-rlInStream :: Handle
-rlInStream = unsafePerformPrimIO (
- newMVar `thenPrimIO` \ handle ->
- _ccall_ getLock (``rl_instream''::_Addr) 0 `thenPrimIO` \ rc ->
- (case rc of
- 0 -> putMVar handle _ClosedHandle
- 1 -> putMVar handle (_ReadHandle ``rl_instream'' Nothing False)
- _ -> _constructError `thenPrimIO` \ ioError ->
- putMVar handle (_ErrorHandle ioError)
- ) `seqPrimIO`
- returnPrimIO handle
- )
-
-
-rlOutStream :: Handle
-rlOutStream = unsafePerformPrimIO (
- newMVar `thenPrimIO` \ handle ->
- _ccall_ getLock (``rl_outstream''::_Addr) 1 `thenPrimIO` \ rc ->
- (case rc of
- 0 -> putMVar handle _ClosedHandle
- 1 -> putMVar handle (_WriteHandle ``rl_outstream'' Nothing False)
- _ -> _constructError `thenPrimIO` \ ioError ->
- putMVar handle (_ErrorHandle ioError)
- ) `seqPrimIO`
- returnPrimIO handle
- )
-
-\end{verbatim}
-
-
-\begin{code}
-
--- rlStartupHook :: RlCallBackFunction -> IO ()
-
-rlInitialize :: IO ()
-rlInitialize =
- getProgName >>= \ pname ->
- rlSetReadlineName pname >>
- _casm_ ``rl_prompt_hack = (char*)malloc(1);'' `thenPrimIO` \ () ->
- primIOToIO (initRlCbacks)
-
-\end{code}
-
-
-
+++ /dev/null
-\section[regex]{Haskell binding to the GNU regex library}
-
-What follows is a straightforward binding to the functions
-provided by the GNU regex library (the GNU group of functions with Perl
-like syntax)
-
-\begin{code}
-module Regex
-
- (
- PatBuffer(..),
- re_compile_pattern,
- re_match,
- re_search,
- re_match2,
- re_search2,
-
- REmatch(..)
-
- ) where
-
-import PreludeGlaST
-
-\end{code}
-
-First, the higher level matching structure that the functions herein return:
-
-\begin{code}
-
---
--- GroupBounds hold the interval where a group
--- matched inside a string, e.g.
---
--- matching "reg(exp)" "a regexp" returns the pair (5,7) for the
--- (exp) group. (_PackedString indices start from 0)
---
-
-type GroupBounds = (Int, Int)
-
-
-data REmatch
- = REmatch (Array Int GroupBounds) -- for $1, ... $n
- GroupBounds -- for $` (everything before match)
- GroupBounds -- for $& (entire matched string)
- GroupBounds -- for $' (everything after)
- GroupBounds -- for $+ (matched by last bracket)
- {- debugging deriving Text -}
-
-\end{code}
-
-Prior to any matching (or searching), the regular expression
-have to compiled into an internal form, the pattern buffer.
-Represent the pattern buffer as a Haskell heap object:
-
-\begin{code}
-
-
-data PatBuffer = PatBuffer# (MutableByteArray# _RealWorld)
-instance _CCallable PatBuffer
-instance _CReturnable PatBuffer
-
-createPatBuffer :: Bool
- -> PrimIO PatBuffer
-createPatBuffer insensitive
- = _casm_ `` %r = (int)sizeof(struct re_pattern_buffer); '' `thenPrimIO` \ sz ->
- newCharArray (0,sz) `thenPrimIO` \ (_MutableByteArray _ pbuf#) ->
- let
- pbuf = PatBuffer# pbuf#
- in
- (if insensitive then
- {-
- See comment re: fastmap below
- -}
- ((_casm_ `` %r = (char *)malloc(256*sizeof(char)); '')::PrimIO _Addr) `thenPrimIO` \ tmap ->
- {-
- Set up the translate table so that any lowercase
- char. gets mapped to an uppercase one. Beacuse quoting
- inside CAsmStrings is Problematic, we pass in the ordinal values
- of 'a','z' and 'A'
- -}
- _casm_ `` { int i;
-
- for(i=0; i<256; i++)
- ((char *)%0)[i] = (char)i;
- for(i=(int)%1;i <=(int)%2;i++)
- ((char *)%0)[i] = i - ((int)%1 - (int)%3);
- %r = 0; } '' tmap (ord 'a') (ord 'z') (ord 'A') `seqPrimIO`
- _casm_ `` { ((struct re_pattern_buffer *)%0)->translate = %1; %r = 0; } '' pbuf tmap
- else
- _casm_ `` { ((struct re_pattern_buffer *)%0)->translate = 0; %r = 0; } '' pbuf) `seqPrimIO`
- {-
- Use a fastmap to speed things up, would like to have the fastmap
- in the Haskell heap, but it will get GCed before we can say regexp,
- as the reference to it is buried inside a ByteArray :-(
- -}
- ((_casm_ `` %r = (char *)malloc(256*sizeof(char)); '')::PrimIO _Addr) `thenPrimIO` \ fmap ->
- _casm_ `` { ((struct re_pattern_buffer *)%0)->fastmap = %1; %r = 0; } '' pbuf fmap `seqPrimIO`
- {-
- We want the compiler of the pattern to alloc. memory
- for the pattern.
- -}
- _casm_ `` { ((struct re_pattern_buffer *)%0)->buffer = 0; %r = 0;} '' pbuf `seqPrimIO`
- _casm_ `` { ((struct re_pattern_buffer *)%0)->allocated = 0; %r = 0;} '' pbuf `seqPrimIO`
- returnPrimIO pbuf
-
-\end{code}
-
-@re_compile_pattern@ converts a regular expression into a pattern buffer,
-GNU style.
-
-Q: should we lift the syntax bits configuration up to the Haskell
-programmer level ?
-
-\begin{code}
-
-re_compile_pattern :: _PackedString
- -> Bool
- -> Bool
- -> PrimIO PatBuffer
-re_compile_pattern str single_line_mode insensitive
- = createPatBuffer insensitive `thenPrimIO` \ pbuf ->
- (if single_line_mode then -- match a multi-line buffer
- _casm_ `` %r = re_syntax_options = RE_PERL_SINGLELINE_SYNTAX; ''
- else
- _casm_ `` %r = re_syntax_options = RE_PERL_MULTILINE_SYNTAX; '') `seqPrimIO`
-
- _casm_ `` %r=(int)re_compile_pattern((char *)%0,
- (int)%1,
- (struct re_pattern_buffer *)%2); '' (_unpackPS str)
- (_lengthPS str)
- pbuf `thenPrimIO` \ err ->
- --
- -- No checking for how the compilation of the pattern went yet.
- --
- returnPrimIO pbuf
-
-\end{code}
-
-Got a match ?
-
-\begin{code}
-
-re_match :: PatBuffer
- -> _PackedString
- -> Int
- -> Bool
- -> PrimIO (Maybe REmatch)
-re_match pbuf
- str
- start
- reg
- = ((if reg then -- record result of match in registers
- _casm_ `` %r = (struct re_registers *)malloc(sizeof(struct re_registers *)); ''
- else
- _casm_ `` %r = (struct re_registers *)NULL; '')::PrimIO _Addr) `thenPrimIO` \ regs ->
- _casm_ `` %r=(int)re_match((struct re_pattern_buffer *)%0,
- (char *)%1,
- (int)%2,
- (int)%3,
- (struct re_registers *)%4); '' pbuf
- (_unpackPS str)
- (_lengthPS str)
- start
- regs `thenPrimIO` \ match_res ->
- if match_res == (-2) then
- error "re_match: Internal error"
- else if match_res < 0 then
- _casm_ `` { free((struct re_registers *)%0); %r = 0; } '' regs `seqPrimIO`
- returnPrimIO Nothing
- else
- build_re_match start (_lengthPS str) regs `thenPrimIO` \ arr ->
- _casm_ `` { free((struct re_registers *)%0); %r = 0; } '' regs `seqPrimIO`
- returnPrimIO (Just arr)
-
-\end{code}
-
-Matching on 2 strings is useful when you're dealing with multiple
-buffers, which is something that could prove useful for PackedStrings,
-as we don't want to stuff the contents of a file into one massive heap
-chunk, but load (smaller chunks) on demand.
-
-\begin{code}
-
-re_match2 :: PatBuffer
- -> _PackedString
- -> _PackedString
- -> Int
- -> Int
- -> Bool
- -> PrimIO (Maybe REmatch)
-re_match2 pbuf
- str1
- str2
- start
- stop
- reg
- = ((if reg then -- record result of match in registers
- _casm_ `` %r = (struct re_registers *)malloc(sizeof(struct re_registers *)); ''
- else
- _casm_ `` %r = (struct re_registers *)NULL; '')::PrimIO _Addr) `thenPrimIO` \ regs ->
- _casm_ `` %r=(int)re_match_2((struct re_pattern_buffer *)%0,
- (char *)%1,
- (int)%2,
- (char *)%3,
- (int)%4,
- (int)%5,
- (struct re_registers *)%6,
- (int)%7); '' pbuf
- (_unpackPS str1)
- (_lengthPS str1)
- (_unpackPS str2)
- (_lengthPS str2)
- start
- regs
- stop `thenPrimIO` \ match_res ->
- if match_res == (-2) then
- error "re_match2: Internal error"
- else if match_res < 0 then
- _casm_ `` { free((struct re_registers *)%0); %r = 0; } '' regs `seqPrimIO`
- returnPrimIO Nothing
- else
- build_re_match start stop regs `thenPrimIO` \ arr ->
- _casm_ `` { free((struct re_registers *)%0); %r = 0; } '' regs `seqPrimIO`
- returnPrimIO (Just arr)
-
-
-\end{code}
-
-Find all the matches in a string.
-
-\begin{code}
-
-re_search :: PatBuffer
- -> _PackedString
- -> Int
- -> Int
- -> Bool
- -> PrimIO (Maybe REmatch)
-re_search pbuf -- the compiled regexp
- str -- the string to search
- start -- start index
- range -- stop index
- reg -- record result of match in registers
- = (if reg then -- record result of match in registers
- _casm_ `` %r = (struct re_registers *)malloc(sizeof(struct re_registers *)); ''
- else
- _casm_ `` %r = (struct re_registers *)NULL; '') `thenPrimIO` \ regs ->
- _casm_ `` %r=(int)re_search((struct re_pattern_buffer *)%0,
- (char *)%1,
- (int)%2,
- (int)%3,
- (int)%4,
- (struct re_registers *)%5); '' pbuf
- (_unpackPS str)
- (_lengthPS str)
- start
- range
- regs `thenPrimIO` \ match_res ->
- if match_res== (-1) then
- _casm_ `` { free((struct re_registers *)%0); %r = 0; } '' regs `seqPrimIO`
- returnPrimIO Nothing
- else
- let
- (st,en) = if range > start then
- (start,range)
- else
- (range,start)
- in
- build_re_match st en regs `thenPrimIO` \ arr ->
- _casm_ `` { free((struct re_registers *)%0); %r = 0; } '' regs `seqPrimIO`
- returnPrimIO (Just arr)
-
-\end{code}
-
-Double buffer search
-
-\begin{code}
-
-re_search2 :: PatBuffer
- -> _PackedString
- -> _PackedString
- -> Int
- -> Int
- -> Int
- -> Bool
- -> PrimIO (Maybe REmatch)
-re_search2 pbuf
- str1
- str2
- start
- range
- stop
- reg
- = (if reg then -- record result of match in registers
- _casm_ `` %r = (struct re_registers *)malloc(sizeof(struct re_registers *)); ''
- else
- _casm_ `` %r = (struct re_registers *)NULL; '') `thenPrimIO` \ regs ->
- _casm_ `` %r=(int)re_search_2((struct re_pattern_buffer *)%0,
- (char *)%1,
- (int)%2,
- (char *)%3,
- (int)%4,
- (int)%5,
- (int)%6,
- (struct re_registers *)%7,
- (int)%8); '' pbuf
- (_unpackPS str1)
- (_lengthPS str1)
- (_unpackPS str2)
- (_lengthPS str2)
- start
- range
- regs
- stop `thenPrimIO` \ match_res ->
- if match_res== (-1) then
- _casm_ `` { free((struct re_registers *)%0); %r = 0; } '' regs `seqPrimIO`
- returnPrimIO Nothing
- else
- let
- (st,en) = if range > start then
- (start,range)
- else
- (range,start)
- in
- build_re_match st en regs `thenPrimIO` \ arr ->
- _casm_ `` { free((struct re_registers *)%0); %r = 0; } '' regs `seqPrimIO`
- returnPrimIO (Just arr)
-
-\end{code}
-
-\begin{code}
-
-build_re_match :: Int
- -> Int
- -> _Addr
- -> PrimIO REmatch
-build_re_match str_start
- str_end
- regs
- = _casm_ `` %r=(int)(*(struct re_registers *)%0).num_regs; '' regs `thenPrimIO` \ len ->
- match_reg_to_array regs len `thenPrimIO` \ (match_start,match_end,arr) ->
- let
- (1,x) = bounds arr
-
- bef = (str_start,match_start) -- $'
- aft = (match_end,str_end) -- $`
- lst = arr!x -- $+
- mtch = (match_start,match_end) -- $&
- in
- returnPrimIO (REmatch arr
- bef
- mtch
- aft
- lst)
- where
- match_reg_to_array regs len
- = trundleIO regs (0,[]) len `thenPrimIO` \ (no,ls) ->
- let
- (st,end,ls')
- = case ls of
- [] -> (0,0,[])
- [(a,b)] -> (a,b,ls)
- ((a,b):xs) -> (a,b,xs)
- in
- returnPrimIO
- (st,
- end,
- array (1,max 1 (no-1))
- [ i := x | (i,x) <- zip [1..] ls'])
-
- trundleIO :: _Addr
- -> (Int,[(Int,Int)])
- -> Int
- -> PrimIO (Int,[(Int,Int)])
- trundleIO regs (i,acc) len
- | i==len = returnPrimIO (i,reverse acc)
- | otherwise
- = _casm_ ``%r = (int)(((struct re_registers *)%0)->start)[(int)%1]; '' regs i `thenPrimIO` \ start ->
- _casm_ ``%r = (int)(((struct re_registers *)%0)->end)[(int)%1]; '' regs i `thenPrimIO` \ end ->
- let
- acc' = (start,end):acc
- in
- if (start == (-1)) && (end == (-1)) then
- returnPrimIO (i,reverse acc)
- else
- trundleIO regs (i+1,acc') len
-
-\end{code}
-
+++ /dev/null
-%
-% (c) The AQUA Project, Glasgow University, 1994-1995
-%
-\section[Set]{An implementation of sets}
-
-This new (94/04) implementation of sets sits squarely upon our
-implementation of @FiniteMaps@. The interface is (roughly?) as
-before.
-
-(95/08: This module is no longer part of the GHC compiler proper; it
-is a GHC library module only, now.)
-
-\begin{code}
-module Set (
- -- not a synonym so we can make it abstract
- Set,
-
- mkSet, setToList, emptySet, singletonSet,
- union, unionManySets, minusSet,
- elementOf, mapSet,
- intersect, isEmptySet,
- cardinality
-
- -- to make the interface self-sufficient
-#if defined(__GLASGOW_HASKELL__)
- , FiniteMap -- abstract
-
- -- for pragmas
- , keysFM, sizeFM
-#endif
- ) where
-
-import FiniteMap
-import Maybes ( maybeToBool
-#if __HASKELL1__ < 3
- , Maybe(..)
-#endif
- )
-\end{code}
-
-\begin{code}
--- This can't be a type synonym if you want to use constructor classes.
-data Set a = MkSet (FiniteMap a ()) {-# STRICT #-}
-
-emptySet :: Set a
-emptySet = MkSet emptyFM
-
-singletonSet :: a -> Set a
-singletonSet x = MkSet (singletonFM x ())
-
-setToList :: Set a -> [a]
-setToList (MkSet set) = keysFM set
-
-mkSet :: Ord a => [a] -> Set a
-mkSet xs = MkSet (listToFM [ (x, ()) | x <- xs])
-
-union :: Ord a => Set a -> Set a -> Set a
-union (MkSet set1) (MkSet set2) = MkSet (plusFM set1 set2)
-
-unionManySets :: Ord a => [Set a] -> Set a
-unionManySets ss = foldr union emptySet ss
-
-minusSet :: Ord a => Set a -> Set a -> Set a
-minusSet (MkSet set1) (MkSet set2) = MkSet (minusFM set1 set2)
-
-intersect :: Ord a => Set a -> Set a -> Set a
-intersect (MkSet set1) (MkSet set2) = MkSet (intersectFM set1 set2)
-
-elementOf :: Ord a => a -> Set a -> Bool
-elementOf x (MkSet set) = maybeToBool(lookupFM set x)
-
-isEmptySet :: Set a -> Bool
-isEmptySet (MkSet set) = sizeFM set == 0
-
-mapSet :: Ord a => (b -> a) -> Set b -> Set a
-mapSet f (MkSet set) = MkSet (listToFM [ (f key, ()) | key <- keysFM set ])
-
-cardinality :: Set a -> Int
-cardinality (MkSet set) = sizeFM set
-
--- fair enough...
-instance (Eq a) => Eq (Set a) where
- (MkSet set_1) == (MkSet set_2) = set_1 == set_2
-
--- but not so clear what the right thing to do is:
-{- NO:
-instance (Ord a) => Ord (Set a) where
- (MkSet set_1) <= (MkSet set_2) = set_1 <= set_2
--}
-\end{code}
+++ /dev/null
-%
-% (c) The GRASP/AQUA Project, Glasgow University, 1995
-%
-% Last Modified: Fri Jul 21 15:53:32 1995
-% Darren J Moffat <moffatd@dcs.gla.ac.uk>
-\section[Socket]{Haskell 1.3 Socket bindings}
-
-
-\begin{code}
-module Socket (
-
- PortID(..),
- Hostname(..),
-
- connectTo, -- :: Hostname -> PortID -> IO Handle
- listenOn, -- :: PortID -> IO Socket
-
- accept, -- :: Socket -> IO (Handle, HostName)
-
- sendTo, -- :: Hostname -> PortID -> String -> IO ()
- recvFrom, -- :: Hostname -> PortID -> IO String
-
- socketPort, -- :: Socket -> IO PortID
-
- -- make interface self-sufficient:
- Socket
-) where
-
-import BSD
-import SocketPrim renaming (accept to socketPrim_accept
- , socketPort to socketPort_prim
- )
-\end{code}
-
-%***************************************************************************
-%* *
-\subsection[Socket-Setup]{High Level ``Setup'' functions}
-%* *
-%***************************************************************************
-
-Calling $connectTo$ creates a client side socket which is
-connected to the given host and port. The Protocol and socket type is
-derived from the given port identifier. If a port number is given
-then the result is always an internet family $Stream$ socket.
-
-If the $PortID$ specifies a unix family socket and the $Hostname$
-differs from that returned by $getHostname$ then an error is
-raised. Alternatively an empty string may be given to $connectTo$
-signalling that the current hostname applies.
-
-\begin{code}
-data PortID =
- Service String -- Service Name eg "ftp"
- | PortNumber Int -- User defined Port Number
- | UnixSocket String -- Unix family socket in file system
-
-type Hostname = String
--- Maybe consider this alternative.
--- data Hostname = Name String | IP Int Int Int Int
-\end{code}
-
-If more control over the socket type is required then $socketPrim$
-should be used instead.
-
-\begin{code}
-connectTo :: Hostname -> -- Hostname
- PortID -> -- Port Identifier
- IO Handle -- Connected Socket
-
-connectTo hostname (Service serv) =
- getProtocolNumber "tcp" >>= \ proto ->
- socket AF_INET Stream proto >>= \ sock ->
- getServicePortNumber serv >>= \ port ->
- getHostByName hostname >>= \ (HostEntry _ _ _ haddrs) ->
- connect sock (SockAddrInet port (head haddrs)) >>
- socketToHandle sock >>= \ h ->
- hSetBuffering h NoBuffering >>
- return h
-connectTo hostname (PortNumber port) =
- getProtocolNumber "tcp" >>= \ proto ->
- socket AF_INET Stream proto >>= \ sock ->
- getHostByName hostname >>= \ (HostEntry _ _ _ haddrs) ->
- connect sock (SockAddrInet port (head haddrs)) >>
- socketToHandle sock
-connectTo _ (UnixSocket path) =
- socket AF_UNIX Datagram 0 >>= \ sock ->
- connect sock (SockAddrUnix path) >>
- socketToHandle sock
-\end{code}
-
-The dual to the $connectTo$ call. This creates the server side
-socket which has been bound to the specified port.
-
-\begin{code}
-listenOn :: PortID -> -- Port Identifier
- IO Socket -- Connected Socket
-
-listenOn (Service serv) =
- getProtocolNumber "tcp" >>= \ proto ->
- socket AF_INET Stream proto >>= \ sock ->
- getServicePortNumber serv >>= \ port ->
- bindSocket sock (SockAddrInet port iNADDR_ANY) >>
- listen sock maxListenQueue >>
- return sock
-listenOn (PortNumber port) =
- getProtocolNumber "tcp" >>= \ proto ->
- socket AF_INET Stream proto >>= \ sock ->
- bindSocket sock (SockAddrInet port iNADDR_ANY) >>
- listen sock maxListenQueue >>
- return sock
-listeOn (UnixSocket path) =
- socket AF_UNIX Datagram 0 >>= \ sock ->
- bindSocket sock (SockAddrUnix path) >>
- return sock
-\end{code}
-
-\begin{code}
-accept :: Socket -> -- Listening Socket
- IO (Handle, -- StdIO Handle for read/write
- HostName) -- HostName of Peer socket
-
-accept sock =
- socketPrim_accept sock >>= \ (sock', (SockAddrInet _ haddr)) ->
- getHostByAddr AF_INET haddr >>= \ (HostEntry peer _ _ _) ->
- socketToHandle sock >>= \ handle ->
- return (handle, peer)
-\end{code}
-
-Send and recived data from/to the given host and port number. These
-should normally only be used where the socket will not be required for
-further calls.
-
-Thse are wrappers around socket, bind, and listen.
-
-\begin{code}
-sendTo :: Hostname -> -- Hostname
- PortID-> -- Port Number
- String -> -- Message to send
- IO ()
-
-sendTo h p msg =
- connectTo h p >>= \ s ->
- hPutStr s msg >>
- hClose s
-
-recvFrom :: Hostname -> -- Hostname
- PortID-> -- Port Number
- IO String -- Received Data
-
-recvFrom host port =
- listenOn port >>= \ s ->
- let
- waiting =
- socketPrim_accept s >>= \ (s', (SockAddrInet _ haddr)) ->
- getHostByAddr AF_INET haddr >>= \ (HostEntry peer _ _ _) ->
- if peer /= host then
- sClose s' >>
- waiting
- else
- readSocketAll s' >>= \ msg ->
- sClose s' >>
- return msg
- in
- waiting >>= \ message ->
- sClose s >>
- return message
-\end{code}
-
-
-
-\begin{code}
-socketPort :: Socket -> IO PortID
-
-socketPort s =
- getSocketName s >>= \ sockaddr ->
- return (case sockaddr of
- SockAddrInet port _ ->
- (PortNumber port)
- SockAddrUnix path ->
- (UnixSocket path)
- )
-\end{code}
+++ /dev/null
-%
-% (c) The GRASP/AQUA Project, Glasgow University, 1995
-%
-% Last Modified: Fri Jul 21 15:14:43 1995
-% Darren J Moffat <moffatd@dcs.gla.ac.uk>
-\section[SocketPrim]{Low-level socket bindings}
-
-The @SocketPrim@ module is for when you want full control over the
-sockets, something like what you have in C (which is very messy).
-
-\begin{code}
-module SocketPrim (
-
- Socket,
- Family(..),
- SocketType(..),
- SockAddr(..),
- HostAddress(..),
-
- socket, -- :: Family -> SocketType -> Int -> IO Socket
- connect, -- :: Socket -> SockAddr -> IO ()
- bindSocket, -- :: Socket -> SockAddr -> IO ()
- listen, -- :: Socket -> Int -> IO ()
- accept, -- :: Socket -> IO (Socket, SockAddr)
- getPeerName, -- :: Socket -> IO SockAddr
- getSocketName, -- :: Socket -> IO SockAddr
-
- socketPort, -- :: Socket -> IO Int
-
- writeSocket, -- :: Socket -> String -> IO Int
- readSocket, -- :: Socket -> Int -> IO (String, Int)
- readSocketAll, -- :: Socket -> IO String
-
- socketToHandle, -- :: Socket -> IO Handle
-
--- Alternative read/write interface not yet implemented.
--- sendto -- :: Socket -> String -> SockAddr -> IO Int
--- recvfrm -- :: Socket -> Int -> SockAddr -> IO (String, Int)
--- sendmsg -- :: Socket -> Message -> MsgFlags -> IO Int
--- recvmsg -- :: Socket -> MsgFlags -> IO Message
-
- shutdown, -- :: Socket -> Int -> IO ()
- sClose, -- :: Socket -> IO ()
-
- inet_addr, -- :: String -> HostAddress
- inet_ntoa, -- :: HostAddress -> String
-
- sIsConnected, -- :: Socket -> IO Bool
- sIsBound, -- :: Socket -> IO Bool
- sIsListening, -- :: Socket -> IO Bool
- sIsReadable, -- :: Socket -> IO Bool
- sIsWritable, -- :: Socket -> IO Bool
-
-
--- Special Constants
-
- aNY_PORT,
- iNADDR_ANY,
--- sOL_SOCKET,
- sOMAXCONN,
- maxListenQueue,
-
-
--- The following are exported ONLY for use in the BSD module and
--- should not be used else where.
-
- packFamily, unpackFamily,
- packSocketType,
- packSockAddr, unpackSockAddr
-
-) where
-
-import CError
-import LibPosix
-import LibPosixUtil
-import PreludeGlaST
-import PreludePrimIO ( newEmptyMVar, putMVar, _MVar )
-import PreludeStdIO
-\end{code}
-
-
-%************************************************************************
-%* *
-\subsection[Socket-SocketTypes]{Socket Types}
-%* *
-%************************************************************************
-
-
-There are a few possible ways to do this. The first is convert the
-structs used in the C library into an equivalent Haskell type. An
-other possible implementation is to keep all the internals in the C
-code and use an Int\# and a status flag. The second method is used here
-since a lot of the C structures are not required to be manipulated.
-Originally the status was non mutable so we had to return a new socket
-each time we changed the status. This version now uses mutable
-variables to avoid the need to do this. The result is a cleaner
-interface and better security since the application programmer now
-can't circumvent the status information to perform invalid operations
-on sockets.
-
-
-\begin{code}
-data SocketStatus
- -- Returned Status Function called
- = NotConnected -- socket
- | Bound -- bindSocket
- | Listening -- listen
- | Connected -- connect/accept
- | Error String -- Any
- deriving (Eq, Text)
-
-data Socket
- = MkSocket
- Int -- File Descriptor Part
- Family
- SocketType
- Int -- Protocol Number
- (MutableVar _RealWorld SocketStatus) -- Status Flag
-\end{code}
-
-In C bind takes either a $struct sockaddr\_in$ or a $struct
-sockaddr\_un$ but these are always type cast to $struct sockaddr$. We
-attempt to emulate this and provide better type checking. Note that
-the socket family fields are redundant since this is caputured in the
-constructor names, it has thus be left out of the Haskell $SockAddr$
-data type.
-
-
-\begin{code}
-type HostAddress = _Word
-
-data SockAddr -- C Names
- = SockAddrUnix -- struct sockaddr_un
- String -- sun_path
-
- | SockAddrInet -- struct sockaddr_in
- Int -- sin_port
- HostAddress -- sin_addr
-
- deriving Eq
-\end{code}
-
-
-
-%************************************************************************
-%* *
-\subsection[Socket-Connections]{Connection Functions}
-%* *
-%************************************************************************
-
-
-In the following connection and binding primitives. The names of the
-equivalent C functions have been preserved where possible. It should
-be noted that some of these names used in the C library, bind in
-particular, have a different meaning to many Haskell programmers and
-have thus been renamed by appending the prefix Socket.
-
-Create an unconnected socket of the given family, type and protocol.
-The most common invocation of $socket$ is the following:
-\begin{verbatim}
- ...
- socket AF_INET Stream 6 >>= \ my_socket ->
- ...
-\end{verbatim}
-
-\begin{code}
-socket :: Family -> -- Family Name (usually AF_INET)
- SocketType -> -- Socket Type (usually Stream)
- Int -> -- Protocol Number (getProtocolByName to find value)
- IO Socket -- Unconnected Socket
-
-socket family stype protocol =
- _ccall_ socket (packFamily family) (packSocketType stype) protocol
- `thenPrimIO` \ s ->
- if s == -1 then
- getCErrorCode `thenPrimIO` \ errno ->
- (case errno of
- EACCES ->
- fail "socket: Permission Denied"
- EMFILE ->
- fail "socket: No more descriptiors available"
- ENFILE ->
- fail "socket: System file table is full"
- ENOBUFS ->
- fail "socket: Insufficient Buffer space to create socket"
- EPROTONOSUPPOR ->
- fail ("socket: Protocol " ++ show protocol ++
- " not supported for Family " ++ show family)
- EPROTOTYPE ->
- fail ("socket: Protocol " ++ show protocol ++
- " wrong type for socket")
- _ ->
- fail ("socket: " ++ (errorCodeToStr errno))
- )
- else
- newVar NotConnected `thenPrimIO` \ status ->
- return (MkSocket s family stype protocol status)
-\end{code}
-
-Given a port number this {\em binds} the socket to that port. This
-means that the programmer is only interested in data being sent to
-that port number. The $Family$ passed to $bindSocket$ must
-be the same as that passed to $socket$. If the special port
-number $aNY\_PORT$ is passed then the system assigns the next
-available use port.
-
-Port numbers for standard unix services can be found by calling
-$getServiceEntry$. These are traditionally port numbers below
-1000; although there are afew, namely NFS and IRC, which used higher
-numbered ports.
-
-The port number allocated to a socket bound by using $aNY\_PORT$ can be
-found by calling $port$
-
-\begin{code}
-bindSocket :: Socket -> -- Unconnected Socket
- SockAddr -> -- Address to Bind to
- IO ()
-
-bindSocket (MkSocket s family stype protocol status) addr =
- readVar status `thenST` \ currentStatus ->
- if currentStatus /= NotConnected then
- fail ("bindSocket: can't peform bind on socket in status " ++
- show currentStatus)
- else
- packSockAddr addr `thenPrimIO` \ addr' ->
- let (_,sz) = boundsOfByteArray addr' in
- _casm_ ``%r = bind(%0, (struct sockaddr*)%1, %2);''
- s addr' sz `thenPrimIO` \ result ->
- if result == -1 then
- getCErrorCode `thenPrimIO` \ errno ->
- (case errno of
- EACCES ->
- fail "bindSocket: The requested address is protected"
- EADDRINUSE ->
- fail "bindSocket: Address in use by another process"
- EADDRNOTAVAIL ->
- fail "bindSocket: Address not available"
- EBADF ->
- fail "bindSocket: invalid descriptor"
- EFAULT ->
- fail "bindSocket: name parameter not in vaild user address space"
- EINVAL ->
- fail "bindSocket: namelen invalid size for given family"
- ENOTSOCK ->
- fail "bindSocket: attempt to bind a non socket descriptor"
- _ ->
- fail ("bindSocket: " ++ (errorCodeToStr errno))
- )
- else
- writeVar status (Bound) `seqPrimIO`
- return ()
-\end{code}
-
-
-Make a connection to an already opened socket on a given machine and port.
-assumes that we have already called createSocket, othewise it will fail.
-
-This is the dual to $bindSocket$. The {\em server} process will
-usually bind to a port number, the {\em client} will then connect to
-the same port number. Port numbers of user applications are normally
-agreed in advance, otherwise we must rely on some hacky mechanism for telling
-the {\em otherside} what port number we have been allocated.
-
-\begin{code}
-connect :: Socket -> -- Unconnected Socket
- SockAddr -> -- Socket address stuff
- IO ()
-
-connect (MkSocket s family stype protocol status) addr =
- readVar status `thenST` \ currentStatus ->
- if currentStatus /= NotConnected then
- fail ("connect: can't peform connect on socket in status " ++
- show currentStatus)
- else
- packSockAddr addr `thenPrimIO` \ addr' ->
- let (_,sz) = boundsOfByteArray addr' in
- _casm_ ``%r = connect(%0,(struct sockaddr*)%1, %2);''
- s addr' sz `thenPrimIO` \ result ->
- if result == -1 then
- getCErrorCode `thenPrimIO` \ errno ->
- (case errno of
- EADDRINUSE ->
- fail "connect: address in use"
- EADDRNOTAVAIL ->
- fail "connect: address not available on remote machine"
- EAFNOSUPPORT ->
- fail "connect: invalid socket address family"
- EALREADY ->
- fail ("connect: socket in non-blocking and previous " ++
- "attempt to connect not yet complteted")
- EBADF ->
- fail "connect: socket in not a vaild descriptor"
- ECONNREFUSED ->
- fail "connect: connection refused by peer"
- EFAULT ->
- fail "connect: address parameter outside process address space"
- EINPROGRESS ->
- fail ("connect: socket is non-blocking and connection can " ++
- "not be completed imediately")
- EINTR ->
- fail "connect: connection interrupted before delivery signal"
- EINVAL ->
- fail ("connect: namlen not size of valid address for " ++
- "specified family")
- EISCONN ->
- fail "connect: socket is already connected"
- ENETUNREACH ->
- fail "connect: network unreachable"
- ENOTSOCK ->
- fail "connect: file descriptor passed instead of socket"
- ETIMEDOUT ->
- fail "connect: timed out without establishing connection"
- _ ->
- fail ("connect: " ++ (errorCodeToStr errno))
- )
- else
- writeVar status (Connected) `seqPrimIO`
- return ()
-
-\end{code}
-
-The programmer must call $listen$ to tell the system software
-that they are now interested in receiving data on this port. This
-must be called on the bound socket before any calls to read or write
-data are made.
-
-The programmer also gives a number which indicates the length of the
-incoming queue of unread messages for this socket. On most systems the
-maximum queue length is around 5. To remove a message from the queue
-for processing a call to $accept$ should be made.
-
-\begin{code}
-listen :: Socket -> -- Connected & Bound Socket
- Int -> -- Queue Length
- IO ()
-
-listen (MkSocket s family stype protocol status) backlog =
- readVar status `thenST` \ currentStatus ->
- if currentStatus /= Bound then
- fail ("listen: can't peform listen on socket in status " ++
- show currentStatus)
- else
- _ccall_ listen s backlog `thenPrimIO` \ result ->
- if result == -1 then
- getCErrorCode `thenPrimIO` \ errno ->
- (case errno of
- EBADF ->
- fail "listen: socket file descriptor invalid"
- ENOTSOCK ->
- fail "listen: file descriptor is not a socket"
- EOPNOTSUPP ->
- fail "listen: not supported fro this type of socket"
- _ ->
- fail ("listen: " ++ (errorCodeToStr errno))
- )
- else
- writeVar status (Listening) `seqPrimIO`
- return ()
-\end{code}
-
-A call to $accept$ only returns when data is available on the given
-socket, unless the socket has been set to non-blocking. It will
-return a new socket which should be used to read the incoming data and
-should then be closed. Using the socket returned by $accept$ allows
-incoming requests to be queued on the original socket.
-
-
-\begin{code}
-accept :: Socket -> -- Queue Socket
- IO (Socket, -- Readable Socket
- SockAddr) -- Peer details
-
-accept sock@(MkSocket s family stype protocol status) =
- readVar status `thenST` \ currentStatus ->
- sIsAcceptable sock >>= \ okay ->
- if not okay then
- fail ("accept: can't peform accept on socket in status " ++
- show currentStatus)
- else
- allocSockAddr family `thenPrimIO` \ (ptr, sz) ->
- _casm_ ``%r = accept(%0,(struct sockaddr*)%1, &%2);''
- s ptr sz `thenPrimIO` \ sock ->
- if sock == -1 then
- getCErrorCode `thenPrimIO` \ errno ->
- (case errno of
- EBADF ->
- fail "accept: descriptor is invalid"
- EFAULT ->
- fail "accept: addr is not in writeable part of address space"
- ENOTSOCK ->
- fail "accept: descriptor is not a socket"
- EOPNOTSUPP ->
- fail ("accept: socket not of type" ++ show stype)
- EWOULDBLOCK ->
- fail "accept: would block"
- _ ->
- fail ("accept: " ++ (errorCodeToStr errno))
- )
- else
- unpackSockAddr ptr `thenPrimIO` \ addr ->
- newVar Connected `thenPrimIO` \ status ->
- return ((MkSocket sock family stype protocol status), addr)
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[Socket-DataPass]{Data Passing Primitives}
-%* *
-%************************************************************************
-
-To allow Haskell to talk to C programs we need to beable to
-communicate interms of byte streams. $writeSocket$ and
-$readSocket$ should only be used for this purpose and not for
-communication between Haskell programs. Haskell programs should use
-the 1.3 IO hPutStr and associated machinery for communicating with
-each other.
-
-
-\begin{code}
-writeSocket :: Socket -> -- Connected Socket
- String -> -- Data to send
- IO Int -- Number of Bytes sent
-
-writeSocket (MkSocket s family stype protocol status) xs =
- readVar status `thenST` \ currentStatus ->
- if not ((currentStatus /= Connected) || (currentStatus /= Listening)) then
- fail ("writeSocket: can't peform write on socket in status " ++
- show currentStatus)
- else
- _ccall_ write s xs (length xs) `thenPrimIO` \ nbytes ->
- if nbytes == -1 then
- getCErrorCode `thenPrimIO` \ errno ->
- (case errno of
- EBADF ->
- fail "writeSocket: invalid file descriptor"
- EDQUOT ->
- fail "writeSocket: disk quota exhausted"
- EFAULT ->
- fail "writeSocket: data area outside address space"
- EFBIG ->
- fail "writeSocket: max file size limit exeeded"
- EINTR ->
- fail "writeSocket: interupt received before data written"
- EINVAL ->
- fail ("writeSocket: The stream is linked below a " ++
- "multiplexor. The fd pointer was negative")
- ENOSPC ->
- fail "writeSocket: no space left on device"
- ENXIO ->
- fail "writeSocket: hangup occured on stream"
- EPIPE ->
- fail "writeSocket: attempt to write to unopened pipe"
- ERANGE ->
- fail "writeSocket: to much data to write"
- EWOULDBLOCK ->
- fail "writeSocket: would block"
- EAGAIN ->
- fail "writeSocket: would block"
- _ ->
- fail ("writeSocket: " ++ (errorCodeToStr errno))
- )
- else
- return nbytes
-
-readSocket :: Socket -> -- Connected Socket
- Int -> -- Number of Bytes to Read
- IO (String, Int) -- (Data Read, Number of Bytes)
-
-readSocket (MkSocket s family stype protocol status) nbytes =
- readVar status `thenST` \ currentStatus ->
- if not ((currentStatus /= Connected) || (currentStatus /= Listening)) then
- fail ("readSocket: can't perform read on socket in status " ++
- show currentStatus)
- else
--- newCharArray (0, nbytes) `thenPrimIO` \ ptr \ ->
- _casm_ ``%r = (char*)malloc(1+sizeof(char)*%0);'' nbytes
- `thenPrimIO` \ buffer ->
- _ccall_ read s buffer nbytes `thenPrimIO` \ result ->
- if result == -1 then
- getCErrorCode `thenPrimIO` \ errno ->
- (case errno of
- EAGAIN ->
- fail "readSocket: no data to read (non-blocking)"
- EBADF ->
- fail "readSocket: invalid file descriptor"
- EBADMSG ->
- fail "readSocket: not a valid data message"
- EFAULT ->
- fail "readSocket: buffer outside allocated address space"
- EINTR ->
- fail "readSocket: interupted by signal before data"
- EINVAL ->
- fail ("readSocket: The stream is linked below a " ++
- "multiplexor. The file descriptor pointer was negative")
- EIO ->
- fail "readSocket: IO error"
- EISDIR ->
- fail "readSocket: descriptor is an NFS directory"
- EWOULDBLOCK ->
- fail "readSocket: would block"
- _ ->
- fail ("readSocket: " ++ (errorCodeToStr errno))
- )
- else
- return (_unpackPS (_packCString buffer), result)
-
-
-readSocketAll :: Socket -> IO String
-readSocketAll s =
- let
- loop xs =
- readSocket s 4096 >>= \ (str, nbytes) ->
- if nbytes /= 0 then
- loop (str ++ xs)
- else
- return xs
- in
- loop ""
-\end{code}
-
-The port number the given socket is currently connected to can be
-determined by calling $port$, is generally only useful when bind
-was given $aNY\_PORT$.
-
-\begin{code}
-socketPort :: Socket -> -- Connected & Bound Socket
- IO Int -- Port Number of Socket
-socketPort sock@(MkSocket s AF_INET stype protocol status) =
- getSocketName sock >>= \ (SockAddrInet port _) ->
- return port
-socketPort (MkSocket s family stype protocol status) =
- fail ("socketPort: not supported for Family " ++ show family)
-\end{code}
-
-Calling $getPeerName$ returns the address details of the machine,
-other than the local one, which is connected to the socket. This is
-used in programs such as FTP to determine where to send the returning
-data. The corresponding call to get the details of the local machine
-is $getSocketName$.
-
-\begin{code}
-getPeerName :: Socket -> IO SockAddr
-getPeerName (MkSocket s family stype protocol status) =
- allocSockAddr family `thenPrimIO` \ (ptr,sz) ->
- _casm_ ``%r = getpeername(%0,(struct sockaddr*)%1,&%2);''
- s ptr sz `thenPrimIO` \ result ->
- if result == -1 then
- getCErrorCode `thenPrimIO` \ errno ->
- fail ("getPeerName: " ++ (errorCodeToStr errno))
- else
- unpackSockAddr ptr `thenPrimIO` \ addr ->
- return addr
-
-getSocketName :: Socket -> IO SockAddr
-getSocketName (MkSocket s family stype protocol status) =
- allocSockAddr family `thenPrimIO` \ (ptr,sz) ->
- _casm_ ``%r = getsockname(%0,(struct sockaddr*)%1, &%2);''
- s ptr sz `thenPrimIO` \ result ->
- if result == -1 then
- getCErrorCode `thenPrimIO` \ errno ->
- fail ("getSocketName: " ++ (errorCodeToStr errno))
- else
- unpackSockAddr ptr `thenPrimIO` \ addr ->
- return addr
-\end{code}
-
-
-%************************************************************************
-%* *
-\subsection[Socket-Properties]{Socket Properties}
-%* *
-%************************************************************************
-
-\begin{code}
-{-
-data SocketOption =
- Debug
- | AcceptConnection
- | ReuseAddr
- | KeepAlive
- | DontRoute
- | Broadcast
- | UseLoopBack
- | Linger
- | OOBInline
- | SendBuffer
- | RecvBuffer
- | SendLowWater
- | RecvLowWater
- | SendTimeOut
- | RecvTimeOut
- | Error
- | Type
-
-sOL_SOCKET = ``SOL_SOCKET''
-
-setSocketOptions :: Socket ->
- Int -> -- Level
- SocketOption -> -- Option Name
- String -> -- Option Value
- IO ()
-
-getSocketOptons :: Socket ->
- Int -> -- Level
- SocketOption -> -- Option Name
- IO String -- Option Value
--}
-\end{code}
-
-A calling sequence table for the main functions is shown in the table below.
-
-\begin{figure}[h]
-\begin{center}
-\begin{tabular}{|l|c|c|c|c|c|c|c|}
-\hline
-{\bf A Call to} & socket & connect & bindSocket & listen & accept & read & write \\
-\hline
-{\bf Precedes} & & & & & & & \\
-\hline
-socket & & & & & & & \\
-\hline
-connect & + & & & & & & \\
-\hline
-bindSocket & + & & & & & & \\
-\hline
-listen & & & + & & & & \\
-\hline
-accept & & & & + & & & \\
-\hline
-read & & + & & + & + & + & + \\
-\hline
-write & & + & & + & + & + & + \\
-\hline
-\end{tabular}
-\caption{Sequence Table for Major functions of Socket}
-\label{tab:api-seq}
-\end{center}
-\end{figure}
-
-%************************************************************************
-%* *
-\subsection[Socket-OSDefs]{OS Dependent Definitions}
-%* *
-%************************************************************************
-
-
-The following Family and Socket Type declarations were manually derived
-from /usr/include/sys/socket.h on the appropriate machines.
-
-Maybe a configure script that could parse the socket.h file to produce
-the following declaration is required to make it ``portable'' rather than
-using the dreaded \#ifdefs.
-
-Presently only the following machine/os combinations are supported:
-
-\begin{itemize}
-\item Intelx86/Linux
-\item SPARC/SunOS
-\item SPARC/Solaris
-\item Alpha/OSF
-\end{itemize}
-
-\begin{code}
-unpackFamily :: Int -> Family
-packFamily :: Family -> Int
-
-packSocketType :: SocketType -> Int
-#ifdef sun
-
-data Family =
- AF_UNSPEC -- unspecified
- | AF_UNIX -- local to host (pipes, portals
- | AF_INET -- internetwork: UDP, TCP, etc
- | AF_IMPLINK -- arpanet imp addresses
- | AF_PUP -- pup protocols: e.g. BSP
- | AF_CHAOS -- mit CHAOS protocols
- | AF_NS -- XEROX NS protocols
- | AF_NBS -- nbs protocols
- | AF_ECMA -- european computer manufacturers
- | AF_DATAKIT -- datakit protocols
- | AF_CCITT -- CCITT protocols, X.25 etc
- | AF_SNA -- IBM SNA
- | AF_DECnet -- DECnet
- | AF_DLI -- Direct data link interface
- | AF_LAT -- LAT
- | AF_HYLINK -- NSC Hyperchannel
- | AF_APPLETALK -- Apple Talk
- | AF_NIT -- Network Interface Tap
- | AF_802 -- IEEE 80.2, also ISO 8802
- | AF_OSI -- umberella of all families used by OSI
- | AF_X25 -- CCITT X.25
- | AF_OSINET -- AFI
- | AF_GOSSIP -- US Government OSI
- | AF_IPX -- Novell Internet Protocol
- deriving (Eq, Ord, Ix, Text)
-
-packFamily = index (AF_UNSPEC, AF_IPX)
-unpackFamily family = (range (AF_UNSPEC, AF_IPX))!!family
-
-#endif
-
-#ifdef __alpha__
-
-data Family =
- AF_UNSPEC -- unspecified
- | AF_UNIX -- local to host (pipes, portals)
- | AF_INET -- internetwork: UDP, TCP, etc.
- | AF_IMPLINK -- arpanet imp addresses
- | AF_PUP -- pup protocols: e.g. BSP
- | AF_CHAOS -- mit CHAOS protocols
- | AF_NS -- XEROX NS protocols
- | AF_ISO -- ISO protocols
- | AF_ECMA -- european computer manufacturers
- | AF_DATAKIT -- datakit protocols
- | AF_CCITT -- CCITT protocols, X.25 etc
- | AF_SNA -- IBM SNA
- | AF_DECnet -- DECnet
- | AF_DLI -- DEC Direct data link interface
- | AF_LAT -- LAT
- | AF_HYLINK -- NSC Hyperchannel
- | AF_APPLETALK -- Apple Talk
- | AF_ROUTE -- Internal Routing Protocol
- | AF_LINK -- Link layer interface
- | Pseudo_AF_XTP -- eXpress Transfer Protocol (no AF)
- | AF_NETMAN -- DNA Network Management
- | AF_X25 -- X25 protocol
- | AF_CTF -- Common Trace Facility
- | AF_WAN -- Wide Area Network protocols
- deriving (Eq, Ord, Ix, Text)
-
-packFamily = index (AF_UNSPEC, AF_WAN)
-unpackFamily family = (range (AF_UNSPEC, AF_WAN))!!family
-#endif
-
-
-#ifdef linux
-data Family =
- AF_UNSPEC
- | AF_UNIX
- | AF_INET
- | AF_AX25
- | AF_IPX
- deriving (Eq, Ord, Ix, Text)
-
-packFamily = index (AF_UNSPEC, AF_IPX)
-unpackFamily family = (range (AF_UNSPEC, AF_IPX))!!family
-
-#endif
-
--- Alpha running OSF or a SPARC with SunOS, rather than Solaris.
-
-#if __alpha__ || (sun && !__svr4__)
-data SocketType =
- Stream
- | Datagram
- | Raw
- | RDM
- | SeqPacket
- deriving (Eq, Ord, Ix, Text)
-
-packSocketType stype = 1 + (index (Stream, SeqPacket) stype)
-#endif
-
--- This is a Sun running Solaris rather than SunOS
-
-#if sun && __svr4__
-data SocketType =
- Datagram
- | Stream
- | NC_TPI_COTS_ORD
- | Raw
- | RDM
- | SeqPacket
- deriving (Eq, Ord, Ix, Text)
-
-packSocketType stype = 1 + (index (Datagram, SeqPacket) stype)
-#endif
-
-
-#if linux
-data SocketType =
- Stream
- | Datagram
- | Raw
- | RDM
- | SeqPacket
- | Packet
- deriving (Eq, Ord, Ix, Text)
-
-packSocketType stype = 1 + (index (Stream, Packet) stype)
-#endif
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[Socket-Util]{Utility Functions}
-%* *
-%************************************************************************
-
-\begin{code}
-aNY_PORT = 0::Int
-iNADDR_ANY = ``INADDR_ANY''::_Word
-sOMAXCONN = ``SOMAXCONN''::Int
-maxListenQueue = sOMAXCONN
-
--------------------------------------------------------------------------------
-shutdown :: Socket -> Int -> IO ()
-shutdown (MkSocket s family stype protocol status) t =
- primIOToIO (_ccall_ shutdown s t)
-
--------------------------------------------------------------------------------
-
-sClose :: Socket -> IO ()
-sClose (MkSocket s family stype protocol status) =
- primIOToIO (_ccall_ close s)
-
--------------------------------------------------------------------------------
-
-inet_addr :: String -> HostAddress
-inet_addr ipstr = unsafePerformPrimIO (_ccall_ inet_addr ipstr)
-
--------------------------------------------------------------------------------
-
-inet_ntoa :: HostAddress -> String
-inet_ntoa haddr = unsafePerformPrimIO (
- _casm_ ``struct in_addr addr;
- addr.s_addr = htonl(%0);
- %r = inet_ntoa (addr);'' haddr `thenPrimIO` \ str ->
- returnPrimIO (_unpackPS (_packCString str)))
-
--------------------------------------------------------------------------------
-
-sIsConnected :: Socket -> IO Bool
-sIsConnected (MkSocket s family stype protocol status) =
- readVar status `thenST` \ value ->
- return (value == Connected)
-
--------------------------------------------------------------------------------
-
-sIsBound :: Socket -> IO Bool
-sIsBound (MkSocket s family stype protocol status) =
- readVar status `thenST` \ value ->
- return (value == Bound)
-
--------------------------------------------------------------------------------
-
-sIsListening :: Socket -> IO Bool
-sIsListening (MkSocket s family stype protocol status) =
- readVar status `thenST` \ value ->
- return (value == Listening)
-
--------------------------------------------------------------------------------
-
-sIsReadable :: Socket -> IO Bool
-sIsReadable (MkSocket s family stype protocol status) =
- readVar status `thenST` \ value ->
- return (value == Listening || value == Connected)
-
--------------------------------------------------------------------------------
-
-sIsWritable :: Socket -> IO Bool
-sIsWritable = sIsReadable
-
--------------------------------------------------------------------------------
-
-sIsAcceptable :: Socket -> IO Bool
-sIsAcceptable (MkSocket s AF_UNIX Stream protocol status) =
- readVar status `thenST` \ value ->
- return (value == Connected || value == Bound || value == Listening)
-sIsAcceptable (MkSocket s AF_UNIX _ protocol status) =
- return False
-sIsAcceptable (MkSocket s _ stype protocol status) =
- readVar status `thenST` \ value ->
- return (value == Connected || value == Listening)
-
--------------------------------------------------------------------------------
-
-{-
-sSetBlocking :: Socket -> Bool -> IO ()
-sIsBlocking :: Socket -> IO Bool
--}
-
--------------------------------------------------------------------------------
-
-allocSockAddr :: Family -> PrimIO (_MutableByteArray _RealWorld Int, Int)
-allocSockAddr AF_UNIX =
- newCharArray (0,``sizeof(struct sockaddr_un)'') `thenPrimIO` \ ptr ->
- let
- (_,sz) = boundsOfByteArray ptr
- in
- returnPrimIO (ptr, sz)
-allocSockAddr AF_INET =
- newCharArray (0,``sizeof(struct sockaddr_in)'') `thenPrimIO` \ ptr ->
- let
- (_,sz) = boundsOfByteArray ptr
- in
- returnPrimIO (ptr, sz)
-
--------------------------------------------------------------------------------
-
-unpackSockAddr :: _MutableByteArray _RealWorld Int -> PrimIO SockAddr
-unpackSockAddr arr =
- _casm_ ``%r = ((struct sockaddr*)%0)->sa_family;'' arr `thenPrimIO` \ fam ->
- case unpackFamily fam of
- AF_UNIX -> unpackSockAddrUnix arr
- AF_INET -> unpackSockAddrInet arr
-
--------------------------------------------------------------------------------
-
-unpackSockAddrUnix :: (_MutableByteArray _RealWorld Int) -> PrimIO SockAddr
-unpackSockAddrUnix ptr =
- _casm_ ``%r = ((struct sockaddr_un*)%0)->sun_path;'' ptr
- `thenPrimIO` \ str ->
- strcpy str `thenPrimIO` \ path ->
- returnPrimIO (SockAddrUnix path)
-
--------------------------------------------------------------------------------
-
-unpackSockAddrInet :: (_MutableByteArray _RealWorld Int) -> PrimIO SockAddr
-unpackSockAddrInet ptr =
- _casm_ ``%r = ntohs(((struct sockaddr_in*)%0)->sin_port);'' ptr
- `thenPrimIO` \ port ->
- _casm_ ``%r = ntohl(((struct sockaddr_in*)%0)->sin_addr.s_addr);'' ptr
- `thenPrimIO` \ address ->
- returnPrimIO (SockAddrInet port address)
-
--------------------------------------------------------------------------------
-
-
-packSockAddr :: SockAddr -> PrimIO (_MutableByteArray _RealWorld Int)
-packSockAddr (SockAddrUnix path) =
- allocSockAddr AF_UNIX `thenPrimIO` \ (ptr,_) ->
- _casm_ ``(((struct sockaddr_un *)%0)->sun_family) = AF_UNIX;''
- ptr `thenPrimIO` \ () ->
- _casm_ ``strcpy ((((struct sockaddr_un *)%0)->sun_path),%1);''
- ptr path `thenPrimIO` \ () ->
- returnPrimIO ptr
-
-packSockAddr (SockAddrInet port address) =
- allocSockAddr AF_INET `thenPrimIO` \ (ptr,_) ->
- _casm_ ``(((struct sockaddr_in *)%0)->sin_family) = AF_INET;''
- ptr `thenPrimIO` \ () ->
- _casm_ ``(((struct sockaddr_in *)%0)->sin_port) = htons((int)%1);''
- ptr port `thenPrimIO` \ () ->
- _casm_ ``(((struct sockaddr_in *)%0)->sin_addr.s_addr) = htonl(%1);''
- ptr address `thenPrimIO` \ () ->
- returnPrimIO ptr
-
--------------------------------------------------------------------------------
-
-socketToHandle :: Socket -> IO Handle
-socketToHandle (MkSocket s family stype protocol status) =
- _casm_ ``%r = fdopen (%0, "r+");'' s `thenPrimIO` \ ptr ->
- newEmptyMVar >>= \ handle ->
- putMVar handle (_SocketHandle ptr False) >>
- return handle
-
--------------------------------------------------------------------------------
-\end{code}
+++ /dev/null
-%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
-%
-\section[Util]{Highly random utility functions}
-
-\begin{code}
-#if defined(COMPILING_GHC)
-# include "HsVersions.h"
-# define IF_NOT_GHC(a) {--}
-#else
-# define panic error
-# define TAG_ _CMP_TAG
-# define LT_ _LT
-# define EQ_ _EQ
-# define GT_ _GT
-# define GT__ _
-# define tagCmp_ _tagCmp
-# define FAST_STRING String
-# define ASSERT(x) {-nothing-}
-# define IF_NOT_GHC(a) a
-# define COMMA ,
-#endif
-
-#ifndef __GLASGOW_HASKELL__
-# undef TAG_
-# undef LT_
-# undef EQ_
-# undef GT_
-# undef tagCmp_
-#endif
-
-module Util (
- -- Haskell-version support
-#ifndef __GLASGOW_HASKELL__
- tagCmp_,
- TAG_(..),
-#endif
- -- general list processing
- IF_NOT_GHC(forall COMMA exists COMMA)
- zipEqual, nOfThem, lengthExceeds, isSingleton,
-#if defined(COMPILING_GHC)
- isIn, isn'tIn,
-#endif
-
- -- association lists
- assoc,
-#ifdef USE_SEMANTIQUE_STRANAL
- clookup, clookrepl, elemIndex, (\\\),
-#endif
-
- -- duplicate handling
- hasNoDups, equivClasses, runs, removeDups,
-
- -- sorting
- IF_NOT_GHC(quicksort COMMA stableSortLt COMMA mergesort COMMA)
- sortLt,
- IF_NOT_GHC(mergeSort COMMA) naturalMergeSortLe, -- from Carsten
- IF_NOT_GHC(naturalMergeSort COMMA mergeSortLe COMMA)
-
- -- transitive closures
- transitiveClosure,
-
- -- accumulating
- mapAccumL, mapAccumR, mapAccumB,
-
- -- comparisons
- IF_NOT_GHC(cmpString COMMA)
-#ifdef USE_FAST_STRINGS
- cmpPString,
-#else
- substr,
-#endif
- -- pairs
- IF_NOT_GHC(cfst COMMA applyToPair COMMA applyToFst COMMA)
- IF_NOT_GHC(applyToSnd COMMA foldPair COMMA)
- unzipWith
-
- -- error handling
-#if defined(COMPILING_GHC)
- , panic, pprPanic, pprTrace
-# ifdef DEBUG
- , assertPanic
-# endif
-#endif {- COMPILING_GHC -}
-
- -- and to make the interface self-sufficient...
-#if __HASKELL1__ < 3
-# if defined(COMPILING_GHC)
- , Maybe(..){-.. for pragmas...-}, PrettyRep, Pretty(..)
-# else
- , Maybe
-# endif
-#endif
-
-#ifdef USE_ATTACK_PRAGMAS
- -- as more-or-less of a *HACK*, Util exports
- -- many types abstractly, so that pragmas will be
- -- able to see them (given that most modules
- -- import Util).
- ,
- AbstractC,
- ArgUsage,
- ArgUsageInfo,
- ArithSeqInfo,
- ArityInfo,
- Bag,
- BasicLit,
- Bind,
- BinderInfo,
- Binds,
- CAddrMode,
- CExprMacro,
- CLabel,
- CSeq,
- CStmtMacro,
- CcKind,
- Class,
- ClassDecl,
- ClassOp,
- ClassOpPragmas,
- ClassPragmas,
- ClosureInfo,
- ConDecl,
- CoreArg,
- CoreAtom,
- CoreBinding,
- CoreCaseAlternatives,
- CoreCaseDefault,
- CoreExpr,
- CostCentre,
- DataPragmas,
- DataTypeSig,
- DefaultDecl,
- DeforestInfo,
- Delay,
- Demand,
- DemandInfo,
- DuplicationDanger,
- EnclosingCcDetails,
- EndOfBlockInfo,
- ExportFlag,
- Expr,
- FBConsum,
- FBProd,
- FBType,
- FBTypeInfo,
- FiniteMap,
- FixityDecl,
- FormSummary,
- FullName,
- FunOrArg,
- GRHS,
- GRHSsAndBinds,
- GenPragmas,
- GlobalSwitch,
- HeapOffset,
- IE,
- Id,
- IdDetails,
- IdEnv(..), -- UGH
- IdInfo,
- IdVal,
- IfaceImportDecl,
- ImpStrictness,
- ImpUnfolding,
- ImportedInterface,
- InPat,
- InsideSCC,
- Inst,
- InstDecl,
- InstOrigin,
- InstTemplate,
- InstTy,
- InstancePragmas,
- Interface,
- IsDupdCC, IsCafCC,
- LambdaFormInfo,
- Literal,
- MagicId,
- MagicUnfoldingFun,
- Match,
- Module,
- MonoBinds,
- MonoType,
- Name,
- NamedThing(..), -- SIGH
- OptIdInfo(..), -- SIGH
- OrdList,
- Outputable(..), -- SIGH
- OverloadedLit,
- PolyType,
- PprStyle,
- PrimKind,
- PrimOp,
- ProtoName,
- Provenance,
- Qual,
- RegRelative,
- Renaming,
- ReturnInfo,
- SMRep,
- SMSpecRepKind,
- SMUpdateKind,
- Sequel,
- ShortName,
- Sig,
- SimplCount,
- SimplEnv,
- SimplifierSwitch,
- SpecEnv,
- SpecInfo,
- SpecialisedInstanceSig,
- SplitUniqSupply,
- SrcLoc,
- StableLoc,
- StandardFormInfo,
- StgAtom,
- StgBinderInfo,
- StgBinding,
- StgCaseAlternatives,
- StgCaseDefault,
- StgExpr,
- StgRhs,
- StrictnessInfo,
- StubFlag,
- SwitchResult,
- TickType,
- TyCon,
- TyDecl,
- TyVar,
- TyVarEnv(..),
- TyVarTemplate,
- TypePragmas,
- TypecheckedPat,
- UfCostCentre,
- UfId,
- UnfoldEnv,
- UnfoldItem,
- UnfoldConApp,
- UnfoldingCoreAlts,
- UnfoldingCoreAtom,
- UnfoldingCoreBinding,
- UnfoldingCoreDefault,
- UnfoldingCoreExpr,
- UnfoldingDetails,
- UnfoldingGuidance,
- UnfoldingPrimOp,
- UniType,
- UniqFM,
- Unique,
- UniqueSupply,
- UpdateFlag,
- UpdateInfo,
- VolatileLoc,
-
-#if ! OMIT_NATIVE_CODEGEN
- Reg,
- CodeSegment,
- RegLoc,
- StixReg,
- StixTree,
-#endif
-
- getIdUniType, typeOfBasicLit, typeOfPat,
- getIdKind, kindOfBasicLit,
- kindFromType,
-
- eqId, cmpId,
- eqName, cmpName,
- cmpProtoName, eqProtoName,
- cmpByLocalName, eqByLocalName,
- eqUnique, cmpUnique,
- showUnique,
-
- switchIsOn,
-
- ppNil, ppStr, ppInt, ppInteger, ppDouble,
-#if __GLASGOW_HASKELL__ >= 23
- ppRational, --- ???
-#endif
- cNil, cStr, cAppend, cCh, cShow,
-#if __GLASGOW_HASKELL__ >= 23
- cPStr,
-#endif
-
--- mkBlackHoleCLabel,
-
- emptyBag, snocBag,
- emptyFM,
---OLD: emptySet,
- nullSpecEnv,
-
- mkUnknownSrcLoc,
-
- pprCoreBinding, pprCoreExpr, pprTyCon, pprUniType,
-
- tagOf_PrimOp,
- pprPrimOp
-
-#endif {-USE_ATTACK_PRAGMAS-}
- ) where
-
-#if defined(COMPILING_GHC)
-IMPORT_Trace
-import Pretty
-#endif
-#if __HASKELL1__ < 3
-import Maybes ( Maybe(..) )
-#endif
-
-#if defined(COMPILING_GHC)
-import Id
-import IdInfo
-import Outputable
-
-# ifdef USE_ATTACK_PRAGMAS
-
-import AbsCSyn
-import AbsSyn
-import AbsUniType
-import Bag
-import BasicLit
-import BinderInfo
-import CLabelInfo
-import CgBindery
-import CgMonad
-import CharSeq
-import ClosureInfo
-import CmdLineOpts
-import CoreSyn
-import FiniteMap
-import HsCore
-import HsPragmas
-import Inst
-import InstEnv
-import Name
-import NameTypes
-import OrdList
-import PlainCore
-import PrimOps
-import ProtoName
-import CostCentre
-import SMRep
-import SimplEnv
-import SimplMonad
-import SplitUniq
-import SrcLoc
-import StgSyn
-import TyVarEnv
-import UniqFM
-import Unique
-
-# if ! OMIT_NATIVE_CODEGEN
-import AsmRegAlloc ( Reg )
-import MachDesc
-import Stix
-# endif
-
-# endif {-USE_ATTACK_PRAGMAS-}
-
-#endif
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[Utils-version-support]{Functions to help pre-1.2 versions of (non-Glasgow) Haskell}
-%* *
-%************************************************************************
-
-This is our own idea:
-\begin{code}
-#ifndef __GLASGOW_HASKELL__
-data TAG_ = LT_ | EQ_ | GT_
-
-tagCmp_ :: Ord a => a -> a -> TAG_
-tagCmp_ a b = if a == b then EQ_ else if a < b then LT_ else GT_
-#endif
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[Utils-lists]{General list processing}
-%* *
-%************************************************************************
-
-Quantifiers are not standard in Haskell. The following fill in the gap.
-
-\begin{code}
-forall :: (a -> Bool) -> [a] -> Bool
-forall pred [] = True
-forall pred (x:xs) = pred x && forall pred xs
-
-exists :: (a -> Bool) -> [a] -> Bool
-exists pred [] = False
-exists pred (x:xs) = pred x || exists pred xs
-\end{code}
-
-A paranoid @zip@ that checks the lists are of equal length.
-Alastair Reid thinks this should only happen if DEBUGging on;
-hey, why not?
-
-\begin{code}
-zipEqual :: [a] -> [b] -> [(a,b)]
-
-#ifndef DEBUG
-zipEqual a b = zip a b
-#else
-zipEqual [] [] = []
-zipEqual (a:as) (b:bs) = (a,b) : zipEqual as bs
-zipEqual as bs = panic "zipEqual: unequal lists"
-#endif
-\end{code}
-
-\begin{code}
-nOfThem :: Int -> a -> [a]
-nOfThem n thing = take n (repeat thing)
-
-lengthExceeds :: [a] -> Int -> Bool
-
-[] `lengthExceeds` n = 0 > n
-(x:xs) `lengthExceeds` n = (1 > n) || (xs `lengthExceeds` (n - 1))
-
-isSingleton :: [a] -> Bool
-
-isSingleton [x] = True
-isSingleton _ = False
-\end{code}
-
-Debugging/specialising versions of \tr{elem} and \tr{notElem}
-\begin{code}
-#if defined(COMPILING_GHC)
-isIn, isn'tIn :: (Eq a) => String -> a -> [a] -> Bool
-
-# ifndef DEBUG
-isIn msg x ys = elem__ x ys
-isn'tIn msg x ys = notElem__ x ys
-
---these are here to be SPECIALIZEd (automagically)
-elem__ _ [] = False
-elem__ x (y:ys) = x==y || elem__ x ys
-
-notElem__ x [] = True
-notElem__ x (y:ys) = x /= y && notElem__ x ys
-
-# else {- DEBUG -}
-isIn msg x ys
- = elem ILIT(0) x ys
- where
- elem i _ [] = False
- elem i x (y:ys)
- | i _GE_ ILIT(100) = panic ("Over-long elem in: " ++ msg)
- | otherwise = x == y || elem (i _ADD_ ILIT(1)) x ys
-
-isn'tIn msg x ys
- = notElem ILIT(0) x ys
- where
- notElem i x [] = True
- notElem i x (y:ys)
- | i _GE_ ILIT(100) = panic ("Over-long notElem in: " ++ msg)
- | otherwise = x /= y && notElem (i _ADD_ ILIT(1)) x ys
-
-# endif {- DEBUG -}
-
-# ifdef USE_ATTACK_PRAGMAS
-{-# SPECIALIZE isIn :: String -> BasicLit -> [BasicLit] -> Bool #-}
-{-# SPECIALIZE isIn :: String -> Class -> [Class] -> Bool #-}
-{-# SPECIALIZE isIn :: String -> Id -> [Id] -> Bool #-}
-{-# SPECIALIZE isIn :: String -> Int -> [Int] -> Bool #-}
-{-# SPECIALIZE isIn :: String -> MagicId -> [MagicId] -> Bool #-}
-{-# SPECIALIZE isIn :: String -> Name -> [Name] -> Bool #-}
-{-# SPECIALIZE isIn :: String -> TyCon -> [TyCon] -> Bool #-}
-{-# SPECIALIZE isIn :: String -> TyVar -> [TyVar] -> Bool #-}
-{-# SPECIALIZE isIn :: String -> TyVarTemplate -> [TyVarTemplate] -> Bool #-}
-{-# SPECIALIZE isIn :: String -> Unique -> [Unique] -> Bool #-}
-{-# SPECIALIZE isIn :: String -> _PackedString -> [_PackedString] -> Bool #-}
-{-# SPECIALIZE isn'tIn :: String -> (Id, Id) -> [(Id, Id)] -> Bool #-}
-{-# SPECIALIZE isn'tIn :: String -> Int -> [Int] -> Bool #-}
-{-# SPECIALIZE isn'tIn :: String -> Id -> [Id] -> Bool #-}
-{-# SPECIALIZE isn'tIn :: String -> MagicId -> [MagicId] -> Bool #-}
-{-# SPECIALIZE isn'tIn :: String -> TyCon -> [TyCon] -> Bool #-}
-{-# SPECIALIZE isn'tIn :: String -> TyVar -> [TyVar] -> Bool #-}
-{-# SPECIALIZE isn'tIn :: String -> TyVarTemplate -> [TyVarTemplate] -> Bool #-}
-# endif
-
-#endif {- COMPILING_GHC -}
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[Utils-assoc]{Association lists}
-%* *
-%************************************************************************
-
-See also @assocMaybe@ and @mkLookupFun@ in module @Maybes@.
-
-\begin{code}
-assoc :: (Eq a) => String -> [(a, b)] -> a -> b
-
-assoc crash_msg lst key
- = if (null res)
- then panic ("Failed in assoc: " ++ crash_msg)
- else head res
- where res = [ val | (key', val) <- lst, key == key']
-
-#if defined(COMPILING_GHC)
-# ifdef USE_ATTACK_PRAGMAS
-{-# SPECIALIZE assoc :: String -> [(Id, a)] -> Id -> a #-}
-{-# SPECIALIZE assoc :: String -> [(Class, a)] -> Class -> a #-}
-{-# SPECIALIZE assoc :: String -> [(Name, a)] -> Name -> a #-}
-{-# SPECIALIZE assoc :: String -> [(PrimKind, a)] -> PrimKind -> a #-}
-{-# SPECIALIZE assoc :: String -> [(String, a)] -> String -> a #-}
-{-# SPECIALIZE assoc :: String -> [(TyCon, a)] -> TyCon -> a #-}
-{-# SPECIALIZE assoc :: String -> [(TyVar, a)] -> TyVar -> a #-}
-{-# SPECIALIZE assoc :: String -> [(TyVarTemplate, a)] -> TyVarTemplate -> a #-}
-{-# SPECIALIZE assoc :: String -> [(UniType, a)] -> UniType -> a #-}
-{-# SPECIALIZE assoc :: String -> [(_PackedString, a)] -> _PackedString -> a #-}
-# endif
-#endif
-\end{code}
-
-Given a list of associations one wants to look for the most recent
-association for a given key. A couple of functions follow that cover
-the simple lookup, the lookup with a default value when the key not
-found, and two corresponding functions operating on unzipped lists
-of associations.
-
-\begin{code}
-#ifdef USE_SEMANTIQUE_STRANAL
-
-clookup :: (Eq a) => [a] -> [b] -> a -> b
-clookup = clookupElse (panic "clookup")
- where
- -- clookupElse :: (Eq a) => b -> [a] -> [b] -> a -> b
- clookupElse d [] [] a = d
- clookupElse d (x:xs) (y:ys) a
- | a==x = y
- | True = clookupElse d xs ys a
-#endif
-\end{code}
-
-The following routine given a curried environment replaces the entry
-labelled with a given name with a new value given. The new value is
-given in the form of a function that allows to transform the old entry.
-
-Assumption is that the list of labels contains the given one and that
-the two lists of the curried environment are of equal lengths.
-
-\begin{code}
-#ifdef USE_SEMANTIQUE_STRANAL
-clookrepl :: Eq a => [a] -> [b] -> a -> (b -> b) -> [b]
-clookrepl (a:as) (b:bs) x f
- = if x == a then (f b:bs) else (b:clookrepl as bs x f)
-#endif
-\end{code}
-
-The following returns the index of an element in a list.
-
-\begin{code}
-#ifdef USE_SEMANTIQUE_STRANAL
-
-elemIndex :: Eq a => [a] -> a -> Int
-elemIndex as x = indx as x 0
- where
- indx :: Eq a => [a] -> a -> Int -> Int
- indx (a:as) x n = if a==x then n else indx as x ((n+1)::Int)
-# if defined(COMPILING_GHC)
- indx [] x n = pprPanic "element not in list in elemIndex" ppNil
-# else
- indx [] x n = error "element not in list in elemIndex"
-# endif
-#endif
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[Utils-dups]{Duplicate-handling}
-%* *
-%************************************************************************
-
-List difference (non-associative). In the result of @xs \\\ ys@, the
-first occurrence of each element of ys in turn (if any) has been
-removed from xs. Thus, @(xs ++ ys) \\\ xs == ys@. This function is
-a copy of @\\@ from report 1.1 and is added to overshade the buggy
-version from the 1.0 version of Haskell.
-
-This routine can be removed after the compiler bootstraps itself and
-a proper @\\@ is can be applied.
-
-\begin{code}
-#ifdef USE_SEMANTIQUE_STRANAL
-(\\\) :: (Eq a) => [a] -> [a] -> [a]
-(\\\) = foldl del
- where
- [] `del` _ = []
- (x:xs) `del` y
- | x == y = xs
- | otherwise = x : xs `del` y
-#endif
-\end{code}
-
-\begin{code}
-hasNoDups :: (Eq a) => [a] -> Bool
-hasNoDups xs = f [] xs
- where
- f seen_so_far [] = True
- f seen_so_far (x:xs) = if x `is_elem` seen_so_far then
- False
- else
- f (x:seen_so_far) xs
-
-#if defined(COMPILING_GHC)
- is_elem = isIn "hasNoDups"
-#else
- is_elem = elem
-#endif
-#if defined(COMPILING_GHC)
-# ifdef USE_ATTACK_PRAGMAS
-{-# SPECIALIZE hasNoDups :: [TyVar] -> Bool #-}
-# endif
-#endif
-\end{code}
-
-\begin{code}
-equivClasses :: (a -> a -> TAG_) -- Comparison
- -> [a]
- -> [[a]]
-
-equivClasses cmp stuff@[] = []
-equivClasses cmp stuff@[item] = [stuff]
-equivClasses cmp items
- = runs eq (sortLt lt items)
- where
- eq a b = case cmp a b of { EQ_ -> True; _ -> False }
- lt a b = case cmp a b of { LT_ -> True; _ -> False }
-\end{code}
-
-The first cases in @equivClasses@ above are just to cut to the point
-more quickly...
-
-@runs@ groups a list into a list of lists, each sublist being a run of
-identical elements of the input list. It is passed a predicate @p@ which
-tells when two elements are equal.
-
-\begin{code}
-runs :: (a -> a -> Bool) -- Equality
- -> [a]
- -> [[a]]
-
-runs p [] = []
-runs p (x:xs) = case (span (p x) xs) of
- (first, rest) -> (x:first) : (runs p rest)
-\end{code}
-
-\begin{code}
-removeDups :: (a -> a -> TAG_) -- Comparison function
- -> [a]
- -> ([a], -- List with no duplicates
- [[a]]) -- List of duplicate groups. One representative from
- -- each group appears in the first result
-
-removeDups cmp [] = ([], [])
-removeDups cmp [x] = ([x],[])
-removeDups cmp xs
- = case (mapAccumR collect_dups [] (equivClasses cmp xs)) of { (dups, xs') ->
- (xs', dups) }
- where
- collect_dups dups_so_far [x] = (dups_so_far, x)
- collect_dups dups_so_far dups@(x:xs) = (dups:dups_so_far, x)
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[Utils-sorting]{Sorting}
-%* *
-%************************************************************************
-
-%************************************************************************
-%* *
-\subsubsection[Utils-quicksorting]{Quicksorts}
-%* *
-%************************************************************************
-
-\begin{code}
--- tail-recursive, etc., "quicker sort" [as per Meira thesis]
-quicksort :: (a -> a -> Bool) -- Less-than predicate
- -> [a] -- Input list
- -> [a] -- Result list in increasing order
-
-quicksort lt [] = []
-quicksort lt [x] = [x]
-quicksort lt (x:xs) = split x [] [] xs
- where
- split x lo hi [] = quicksort lt lo ++ (x : quicksort lt hi)
- split x lo hi (y:ys) | y `lt` x = split x (y:lo) hi ys
- | True = split x lo (y:hi) ys
-\end{code}
-
-Quicksort variant from Lennart's Haskell-library contribution. This
-is a {\em stable} sort.
-
-\begin{code}
-stableSortLt = sortLt -- synonym; when we want to highlight stable-ness
-
-sortLt :: (a -> a -> Bool) -- Less-than predicate
- -> [a] -- Input list
- -> [a] -- Result list
-
-sortLt lt l = qsort lt l []
-
--- qsort is stable and does not concatenate.
-qsort :: (a -> a -> Bool) -- Less-than predicate
- -> [a] -- xs, Input list
- -> [a] -- r, Concatenate this list to the sorted input list
- -> [a] -- Result = sort xs ++ r
-
-qsort lt [] r = r
-qsort lt [x] r = x:r
-qsort lt (x:xs) r = qpart lt x xs [] [] r
-
--- qpart partitions and sorts the sublists
--- rlt contains things less than x,
--- rge contains the ones greater than or equal to x.
--- Both have equal elements reversed with respect to the original list.
-
-qpart lt x [] rlt rge r =
- -- rlt and rge are in reverse order and must be sorted with an
- -- anti-stable sorting
- rqsort lt rlt (x : rqsort lt rge r)
-
-qpart lt x (y:ys) rlt rge r =
- if lt y x then
- -- y < x
- qpart lt x ys (y:rlt) rge r
- else
- -- y >= x
- qpart lt x ys rlt (y:rge) r
-
--- rqsort is as qsort but anti-stable, i.e. reverses equal elements
-rqsort lt [] r = r
-rqsort lt [x] r = x:r
-rqsort lt (x:xs) r = rqpart lt x xs [] [] r
-
-rqpart lt x [] rle rgt r =
- qsort lt rle (x : qsort lt rgt r)
-
-rqpart lt x (y:ys) rle rgt r =
- if lt x y then
- -- y > x
- rqpart lt x ys rle (y:rgt) r
- else
- -- y <= x
- rqpart lt x ys (y:rle) rgt r
-\end{code}
-
-%************************************************************************
-%* *
-\subsubsection[Utils-dull-mergesort]{A rather dull mergesort}
-%* *
-%************************************************************************
-
-\begin{code}
-mergesort :: (a -> a -> TAG_) -> [a] -> [a]
-
-mergesort cmp xs = merge_lists (split_into_runs [] xs)
- where
- a `le` b = case cmp a b of { LT_ -> True; EQ_ -> True; GT__ -> False }
- a `ge` b = case cmp a b of { LT_ -> False; EQ_ -> True; GT__ -> True }
-
- split_into_runs [] [] = []
- split_into_runs run [] = [run]
- split_into_runs [] (x:xs) = split_into_runs [x] xs
- split_into_runs [r] (x:xs) | x `ge` r = split_into_runs [r,x] xs
- split_into_runs rl@(r:rs) (x:xs) | x `le` r = split_into_runs (x:rl) xs
- | True = rl : (split_into_runs [x] xs)
-
- merge_lists [] = []
- merge_lists (x:xs) = merge x (merge_lists xs)
-
- merge [] ys = ys
- merge xs [] = xs
- merge xl@(x:xs) yl@(y:ys)
- = case cmp x y of
- EQ_ -> x : y : (merge xs ys)
- LT_ -> x : (merge xs yl)
- GT__ -> y : (merge xl ys)
-\end{code}
-
-%************************************************************************
-%* *
-\subsubsection[Utils-Carsten-mergesort]{A mergesort from Carsten}
-%* *
-%************************************************************************
-
-\begin{display}
-Date: Mon, 3 May 93 20:45:23 +0200
-From: Carsten Kehler Holst <kehler@cs.chalmers.se>
-To: partain@dcs.gla.ac.uk
-Subject: natural merge sort beats quick sort [ and it is prettier ]
-
-Here a piece of Haskell code that I'm rather fond of. See it as an
-attempt to get rid of the ridiculous quick-sort routine. group is
-quite useful by itself I think it was John's idea originally though I
-believe the lazy version is due to me [surprisingly complicated].
-gamma [used to be called] is called gamma because I got inspired by
-the Gamma calculus. It is not very close to the calculus but does
-behave less sequentially than both foldr and foldl. One could imagine a
-version of gamma that took a unit element as well thereby avoiding the
-problem with empty lists.
-
-I've tried this code against
-
- 1) insertion sort - as provided by haskell
- 2) the normal implementation of quick sort
- 3) a deforested version of quick sort due to Jan Sparud
- 4) a super-optimized-quick-sort of Lennart's
-
-If the list is partially sorted both merge sort and in particular
-natural merge sort wins. If the list is random [ average length of
-rising subsequences = approx 2 ] mergesort still wins and natural
-merge sort is marginally beaten by Lennart's soqs. The space
-consumption of merge sort is a bit worse than Lennart's quick sort
-approx a factor of 2. And a lot worse if Sparud's bug-fix [see his
-fpca article ] isn't used because of group.
-
-have fun
-Carsten
-\end{display}
-
-\begin{code}
-group :: (a -> a -> Bool) -> [a] -> [[a]]
-
-group p [] = [[]]
-group p (x:xs) =
- let ((h1:t1):tt1) = group p xs
- (t,tt) = if null xs then ([],[]) else
- if x `p` h1 then (h1:t1,tt1) else
- ([], (h1:t1):tt1)
- in ((x:t):tt)
-
-generalMerge :: (a -> a -> Bool) -> [a] -> [a] -> [a]
-generalMerge p xs [] = xs
-generalMerge p [] ys = ys
-generalMerge p (x:xs) (y:ys) | x `p` y = x : generalMerge p xs (y:ys)
- | otherwise = y : generalMerge p (x:xs) ys
-
--- gamma is now called balancedFold
-
-balancedFold :: (a -> a -> a) -> [a] -> a
-balancedFold f [] = error "can't reduce an empty list using balancedFold"
-balancedFold f [x] = x
-balancedFold f l = balancedFold f (balancedFold' f l)
-
-balancedFold' :: (a -> a -> a) -> [a] -> [a]
-balancedFold' f (x:y:xs) = f x y : balancedFold' f xs
-balancedFold' f xs = xs
-
-generalMergeSort p [] = []
-generalMergeSort p xs = (balancedFold (generalMerge p) . map (: [])) xs
-
-generalNaturalMergeSort p [] = []
-generalNaturalMergeSort p xs = (balancedFold (generalMerge p) . group p) xs
-
-mergeSort, naturalMergeSort :: Ord a => [a] -> [a]
-
-mergeSort = generalMergeSort (<=)
-naturalMergeSort = generalNaturalMergeSort (<=)
-
-mergeSortLe le = generalMergeSort le
-naturalMergeSortLe le = generalNaturalMergeSort le
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[Utils-transitive-closure]{Transitive closure}
-%* *
-%************************************************************************
-
-This algorithm for transitive closure is straightforward, albeit quadratic.
-
-\begin{code}
-transitiveClosure :: (a -> [a]) -- Successor function
- -> (a -> a -> Bool) -- Equality predicate
- -> [a]
- -> [a] -- The transitive closure
-
-transitiveClosure succ eq xs
- = do [] xs
- where
- do done [] = done
- do done (x:xs) | x `is_in` done = do done xs
- | otherwise = do (x:done) (succ x ++ xs)
-
- x `is_in` [] = False
- x `is_in` (y:ys) | eq x y = True
- | otherwise = x `is_in` ys
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[Utils-accum]{Accumulating}
-%* *
-%************************************************************************
-
-@mapAccumL@ behaves like a combination
-of @map@ and @foldl@;
-it applies a function to each element of a list, passing an accumulating
-parameter from left to right, and returning a final value of this
-accumulator together with the new list.
-
-\begin{code}
-mapAccumL :: (acc -> x -> (acc, y)) -- Function of elt of input list
- -- and accumulator, returning new
- -- accumulator and elt of result list
- -> acc -- Initial accumulator
- -> [x] -- Input list
- -> (acc, [y]) -- Final accumulator and result list
-
-mapAccumL f b [] = (b, [])
-mapAccumL f b (x:xs) = (b'', x':xs') where
- (b', x') = f b x
- (b'', xs') = mapAccumL f b' xs
-\end{code}
-
-@mapAccumR@ does the same, but working from right to left instead. Its type is
-the same as @mapAccumL@, though.
-
-\begin{code}
-mapAccumR :: (acc -> x -> (acc, y)) -- Function of elt of input list
- -- and accumulator, returning new
- -- accumulator and elt of result list
- -> acc -- Initial accumulator
- -> [x] -- Input list
- -> (acc, [y]) -- Final accumulator and result list
-
-mapAccumR f b [] = (b, [])
-mapAccumR f b (x:xs) = (b'', x':xs') where
- (b'', x') = f b' x
- (b', xs') = mapAccumR f b xs
-\end{code}
-
-Here is the bi-directional version, that works from both left and right.
-
-\begin{code}
-mapAccumB :: (accl -> accr -> x -> (accl, accr,y))
- -- Function of elt of input list
- -- and accumulator, returning new
- -- accumulator and elt of result list
- -> accl -- Initial accumulator from left
- -> accr -- Initial accumulator from right
- -> [x] -- Input list
- -> (accl, accr, [y]) -- Final accumulators and result list
-
-mapAccumB f a b [] = (a,b,[])
-mapAccumB f a b (x:xs) = (a'',b'',y:ys)
- where
- (a',b'',y) = f a b' x
- (a'',b',ys) = mapAccumB f a' b xs
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[Utils-comparison]{Comparisons}
-%* *
-%************************************************************************
-
-See also @tagCmp_@ near the versions-compatibility section.
-
-\begin{code}
-cmpString :: String -> String -> TAG_
-
-cmpString [] [] = EQ_
-cmpString (x:xs) (y:ys) = if x == y then cmpString xs ys
- else if x < y then LT_
- else GT_
-cmpString [] ys = LT_
-cmpString xs [] = GT_
-
-cmpString _ _ = case (panic "cmpString") of { s -> -- BUG avoidance: never get here
- cmpString s "" -- will never get here
- }
-\end{code}
-
-\begin{code}
-#ifdef USE_FAST_STRINGS
-cmpPString :: FAST_STRING -> FAST_STRING -> TAG_
-
-cmpPString x y
- = case (_tagCmp x y) of { _LT -> LT_ ; _EQ -> EQ_ ; _GT -> GT_ }
-#endif
-\end{code}
-
-\begin{code}
-#ifndef USE_FAST_STRINGS
-substr :: FAST_STRING -> Int -> Int -> FAST_STRING
-
-substr str beg end
- = ASSERT (beg >= 0 && beg <= end)
- take (end - beg + 1) (drop beg str)
-#endif
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[Utils-pairs]{Pairs}
-%* *
-%************************************************************************
-
-The following are curried versions of @fst@ and @snd@.
-
-\begin{code}
-cfst :: a -> b -> a -- stranal-sem only (Note)
-cfst x y = x
-\end{code}
-
-The following provide us higher order functions that, when applied
-to a function, operate on pairs.
-
-\begin{code}
-applyToPair :: ((a -> c),(b -> d)) -> (a,b) -> (c,d)
-applyToPair (f,g) (x,y) = (f x, g y)
-
-applyToFst :: (a -> c) -> (a,b)-> (c,b)
-applyToFst f (x,y) = (f x,y)
-
-applyToSnd :: (b -> d) -> (a,b) -> (a,d)
-applyToSnd f (x,y) = (x,f y)
-
-foldPair :: (a->a->a,b->b->b) -> (a,b) -> [(a,b)] -> (a,b)
-foldPair fg ab [] = ab
-foldPair fg@(f,g) ab ((a,b):abs) = (f a u,g b v)
- where (u,v) = foldPair fg ab abs
-\end{code}
-
-\begin{code}
-unzipWith :: (a -> b -> c) -> [(a, b)] -> [c]
-unzipWith f pairs = map ( \ (a, b) -> f a b ) pairs
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[Utils-errors]{Error handling}
-%* *
-%************************************************************************
-
-\begin{code}
-#if defined(COMPILING_GHC)
-panic x = error ("panic! (the `impossible' happened):\n\t"
- ++ x ++ "\n\n"
- ++ "Please report it as a compiler bug "
- ++ "to glasgow-haskell-bugs@dcs.glasgow.ac.uk.\n\n" )
-
-pprPanic heading pretty_msg = panic (heading++(ppShow 80 pretty_msg))
-
-pprTrace heading pretty_msg = trace (heading++(ppShow 80 pretty_msg))
-
-# ifdef DEBUG
-assertPanic :: String -> Int -> a
-assertPanic file line = panic ("ASSERT failed! file "++file++", line "++show line)
-# endif
-#endif {- COMPILING_GHC -}
-\end{code}
+++ /dev/null
-%
-% (c) The GRASP/AQUA Project, Glasgow University, 1993-1994
-%
-\section[ByteOps]{Convert to/from ``bytes''; to support @Native@ class}
-
-This mimics some code that comes with HBC.
-
-\begin{code}
-module ByteOps (
- longToBytes,
- intToBytes,
- shortToBytes,
- floatToBytes,
- doubleToBytes,
-
- bytesToLong,
- bytesToInt,
- bytesToShort,
- bytesToFloat,
- bytesToDouble
- ) where
-
-import Cls
-import Core
-import IInt
-import IFloat
-import IDouble
-import List ( (++), foldr )
-import Prel ( chr )
-import PS ( _PackedString, _unpackPS )
-import TyArray ( Array(..) )
-import TyComplex
-import PreludeGlaST
-import Text
-\end{code}
-
-\tr{xxxToBytes} prepends an \tr{xxx} to a byte stream.
-\tr{bytesToXxx} snaffles an \tr{xxx} from a byte stream,
-also returning the rest of the stream.
-\begin{code}
-type Bytes = [Char]
-
-longToBytes :: Int -> Bytes -> Bytes
-intToBytes :: Int -> Bytes -> Bytes
-shortToBytes :: Int -> Bytes -> Bytes
-floatToBytes :: Float -> Bytes -> Bytes
-doubleToBytes :: Double -> Bytes -> Bytes
-
-bytesToLong :: Bytes -> (Int, Bytes)
-bytesToInt :: Bytes -> (Int, Bytes)
-bytesToShort :: Bytes -> (Int, Bytes)
-bytesToFloat :: Bytes -> (Float, Bytes)
-bytesToDouble :: Bytes -> (Double, Bytes)
-\end{code}
-
-Here we go.
-\begin{code}
-#define XXXXToBytes(type,xxxx,xxxx__) \
-xxxx i stream \
- = let \
- long_bytes {- DANGEROUS! -} \
- = unsafePerformPrimIO ( \
- {- Allocate a wad of memory to put the "long"'s bytes. \
- Let's hope 32 bytes will be big enough. -} \
- newCharArray (0::Int, 31) `thenPrimIO` \ arr# -> \
- \
- {- Call out to C to do the dirty deed: -} \
- _casm_ ``%r = xxxx__ ((type)%0, (unsigned char *)%1);'' i arr# \
- `thenPrimIO` \ num_bytes -> \
- \
- unpack arr# 0 (num_bytes - 1) \
- ) \
- in \
- long_bytes ++ stream
-
-XXXXToBytes(long,longToBytes,long2bytes__)
-XXXXToBytes(int,intToBytes,int2bytes__)
-XXXXToBytes(short,shortToBytes,short2bytes__)
-XXXXToBytes(float,floatToBytes,float2bytes__)
-XXXXToBytes(double,doubleToBytes,double2bytes__)
-\end{code}
-
-\begin{code}
-unpack :: _MutableByteArray _RealWorld Int -> Int -> Int -> PrimIO [Char]
-
-unpack arr# curr last
- = if curr > last then
- returnPrimIO []
- else
- readCharArray arr# curr `thenPrimIO` \ ch ->
- unpack arr# (curr + 1) last `thenPrimIO` \ rest ->
- returnPrimIO (ch : rest)
-\end{code}
-
-Now we go the other way. The paranoia checking (absent) leaves
-something to be desired. Really have to be careful on
-funny-sized things like \tr{shorts}...
-\begin{code}
-#define bytesToXXXX(htype,xxxx,alloc,read,xxxx__) \
-xxxx stream \
- = unsafePerformPrimIO ( \
- {- slam (up to) 32 bytes [random] from the stream into an array -} \
- newCharArray (0::Int, 31) `thenPrimIO` \ arr# -> \
- pack arr# 0 31 stream `seqPrimIO` \
- \
- {- make a one-element array to hold the result: -} \
- alloc (0::Int, 0) `thenPrimIO` \ res# -> \
- \
- {- call the C to do the business: -} \
- _casm_ ``%r = xxxx__ ((P_)%0, (htype *) %1);'' arr# res# \
- `thenPrimIO` \ num_bytes -> \
- \
- {- read the result out of "res#": -} \
- read res# (0::Int) `thenPrimIO` \ i -> \
- \
- {- box the result and drop the number of bytes taken: -} \
- returnPrimIO (i, my_drop num_bytes stream) \
- )
-
-bytesToXXXX(I_,bytesToLong,newIntArray,readIntArray,bytes2long__)
-bytesToXXXX(I_,bytesToInt,newIntArray,readIntArray,bytes2int__)
-bytesToXXXX(I_,bytesToShort,newIntArray,readIntArray,bytes2short__)
-bytesToXXXX(StgFloat,bytesToFloat,newFloatArray,readFloatArray,bytes2float__)
-bytesToXXXX(StgDouble,bytesToDouble,newDoubleArray,readDoubleArray,bytes2double__)
-\end{code}
-
-\begin{code}
-pack :: _MutableByteArray _RealWorld Int -> Int -> Int -> [Char] -> PrimIO ()
-
-pack arr# curr last from_bytes
- = if curr > last then
- returnPrimIO ()
- else
- case from_bytes of
- [] -> writeCharArray arr# curr (chr 0)
-
- (from_byte : xs) ->
- writeCharArray arr# curr from_byte `seqPrimIO`
- pack arr# (curr + 1) last xs
-
--- more cavalier than usual; we know there will be enough bytes:
-
-my_drop :: Int -> [a] -> [a]
-
-my_drop 0 xs = xs
---my_drop _ [] = []
-my_drop m (_:xs) = my_drop (m - 1) xs
-\end{code}
+++ /dev/null
-/* this is a standalone Jmakefile; NOT part of ghc "make world" */
-
-LitStuffNeededHere(docs depend)
-InfoStuffNeededHere(docs)
-
-/* LIT2LATEX_OPTS=-tbird */
-
-LitDocRootTargetWithNamedOutput(lazyimp,lit,lazyimp-standalone)
+++ /dev/null
-This is the mainPrimIO that must be used for Haskell~1.2.
-
-\begin{code}
-module Main ( mainPrimIO ) where
-
-import PreludeMainIO_help -- for type of "Main.main"
-import PreludeDialogueIO ( requestToPrimIO )
-import TyIO
-import UTypes ( Bin )
-
-mainPrimIO :: PrimIO ()
-mainPrimIO s = case (requestToPrimIO main s) of
- ( (), s2@(S# _) ) -> ( (), s2 )
-\end{code}
-
-OLD COMMENT:
-
-Nota Bene! @mainIO@ is written as an explicit function, rather than
-by saying: @mainIO = requestToIO main@ so that the code generator
-recognises @mainIO@ as a {\em function} (hence HNF, hence not
-updatable), rather than a zero-arity CAF (hence updatable). If it is
-updated, then we have a mega-space leak, because the entire action
-(@requestToIO main@) is retained indefinitely.
-
-(This doesn't waste work because @mainIO@ is only used once.)
+++ /dev/null
-This is the mainPrimIO13 that must be used for Haskell~1.3.
-
-\begin{code}
-module Main ( mainPrimIO13 ) where
-
-import PreludeMain13_help -- for type of "Main.main"
-import Builtin ( error )
-import PreludeIO
-import UTypes ( Bin )
-
-import Cls
-import Core
-import IChar
-import IInt
-import IList
-import List ( (++) )
-import Prel ( (.), not )
-import PS ( _PackedString, _unpackPS )
-import Text
-import TyComplex
-import TyArray
-
-mainPrimIO13 :: PrimIO ()
-
-mainPrimIO13 s
- = case (main s) of { (result, s2@(S# _)) ->
- case result of
- Right () -> ( (), s2 )
- Left err -> error ("I/O error: "++showsPrec 0 err "\n")
- }
-\end{code}
-
-OLD COMMENT:
-
-Nota Bene! @mainIO@ is written as an explicit function, rather than
-by saying: @mainIO = requestToIO main@ so that the code generator
-recognises @mainIO@ as a {\em function} (hence HNF, hence not
-updatable), rather than a zero-arity CAF (hence updatable). If it is
-updated, then we have a mega-space leak, because the entire action
-(@requestToIO main@) is retained indefinitely.
-
-(This doesn't waste work because @mainIO@ is only used once.)
+++ /dev/null
-%
-% (c) The GRASP/AQUA Project, Glasgow University, 1993-1994
-%
-\section{The @Dialogue@ interface}
-
-\begin{code}
-module PreludeDialogueIO (
- requestToPrimIO, -- RTS uses this!
-
- processIORequest, -- used in PreludeGlaIO
- appendChan#, -- used elsewhere in prelude
- unpackArgv, -- ditto
- unpackProgName -- ditto
- ) where
-
-import PreludeGlaST -- for _ST stuff
-import PreludeGlaMisc -- for stable pointers
-import Cls
-import Core
-import IChar
-import IInt
-import IList
-import IO ( stdout, stdin )
-import List ( (++), reverse, foldr, foldl )
-import PS -- packed strings
-import Prel ( chr, flip )
-import Stdio ( fopen, fclose, fflush, _FILE )
-import Text
-import TyArray ( Array(..) )
-import TyComplex
-import TyIO
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[requestToIO]{Dialogue-to-IO}
-%* *
-%************************************************************************
-
-We would like to take existing Haskell programs, written with @main@
-of type @Dialogue@, and run them on our system. To do this, our
-system actually evaluates @mainPrimIO@ (rather than @main@ directly).
-@main@ has type @Dialogue@ then @mainPrimIO@ [separate module] is defined
-like this:
-\begin{verbatim}
-mainPrimIO :: PrimIO ()
-mainPrimIO s = case (requestToPrimIO main s) of
- ( (), s2) -> ( (), s2 )
-\end{verbatim}
-
-So, here's @requestToPrimIO@:
-\begin{code}
-requestToPrimIO :: Dialogue -> PrimIO ()
-
-requestToPrimIO dialogue
- = newVar (error "HELP! (Forgot to link with -fhaskell-1.3?)\n")
- `thenPrimIO` \ rsV ->
- unsafeInterleavePrimIO (readVar rsV) `thenPrimIO` \ rs ->
- run (dialogue rs) rsV
-
-run :: [Request] -> MutableVar _RealWorld [Response] -> PrimIO ()
-
-run [] v = returnPrimIO ()
-run (req:reqs) v
- = processIORequest req `thenPrimIO` \ r ->
- newVar (error "GlasgowIO:run:synch") `thenPrimIO` \ rsV ->
- unsafeInterleavePrimIO (readVar rsV) `thenPrimIO` \ rs ->
- writeVar v (r:rs) `seqPrimIO`
- run reqs rsV
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[processIORequest]{@processIORequest@}
-%* *
-%************************************************************************
-
-The guy that really does the business is @processIORequest@. We make
-this available to the intrepid user.
-
-\begin{code}
-processIORequest :: Request -> PrimIO Response
-
-processIORequest (ReadFile name)
- = fopen name "r" `thenPrimIO` \ file_star ->
- if (file_star == ``NULL'')
- then returnPrimIO (Failure (ReadError ("ReadFile: can't read: "++name)))
- -- ToDo: return SearchErrors when appropriate
-
- else readFile# file_star `thenPrimIO` \ str ->
- returnPrimIO (Str str)
-
-processIORequest (WriteFile name string)
- = fopen name "w" `thenPrimIO` \ file_star ->
- if (file_star == ``NULL'')
- then returnPrimIO (Failure (WriteError ("WriteFile: open failed: "++name)))
-
- else writeFile# file_star string `seqPrimIO`
- fclose file_star `thenPrimIO` \ status ->
- returnPrimIO (
- if status == 0
- then Success
- else Failure (WriteError ("WriteFile: closed failed: "++name))
- )
-
-processIORequest (AppendFile name string)
- = fopen name "a+"{-don't create-} `thenPrimIO` \ file_star ->
- if (file_star == ``NULL'')
- then returnPrimIO (Failure (WriteError ("AppendFile: open failed: "++name)))
-
- else writeFile# file_star string `seqPrimIO`
- fclose file_star `thenPrimIO` \ status ->
- returnPrimIO (
- if status == 0
- then Success
- else Failure (WriteError ("AppendFile: closed failed: "++name))
- )
-
-processIORequest (DeleteFile name)
- = _casm_ ``%r = (I_) unlink((char *) %0);'' name `thenPrimIO` \ status ->
- returnPrimIO (
- if (status == (0::Int)) then
- Success
- else if ( (``errno''::Int) == (``ENOENT''::Int) ) then
- Failure (SearchError ("DeleteFile: no such file: "++name))
- else
- Failure (WriteError ("DeleteFile: could not delete: "++name))
- )
-
-processIORequest (AppendChan chan str)
- = case chan of
- "stdout" ->
- appendChan# ``stdout'' str `seqPrimIO`
- fflush ``stdout'' `thenPrimIO` \ status ->
- returnPrimIO (
- if status == 0
- then Success
- else Failure (WriteError ("AppendChan: flush failed: " ++ chan))
- )
- "stderr" ->
- appendChan# ``stderr'' str `seqPrimIO`
- fflush ``stderr'' `thenPrimIO` \ status ->
- returnPrimIO (
- if status == 0
- then Success
- else Failure (WriteError ("AppendChan: flush failed: " ++ chan))
- )
- _ -> error "AppendChan: not implemented except for \"stdout\" and \"stderr\"\n"
-
-processIORequest (ReadChan chan)
- = case chan of
- "stdin" -> readChan# ``stdin'' `thenPrimIO` \ str ->
- returnPrimIO (Str str)
-
- _ -> error "ReadChan: not implemented except for \"stdin\"\n"
-
-processIORequest (Echo False) = returnPrimIO Success
-processIORequest (Echo True)
- = {- REMOVED: Can't be bothered. WDP: 95/04
- appendChan# ``stderr'' "Glasgow Haskell doesn't support \"Echo\" requests properly (yet)\n"
- `seqPrimIO` -} returnPrimIO Success
-
-processIORequest GetArgs
- = returnPrimIO (StrList (unpackArgv ``prog_argv'' (``prog_argc''::Int) ))
-
-processIORequest GetProgName
- = returnPrimIO (Str (unpackProgName ``prog_argv''))
-
-processIORequest (GetEnv name)
- = _casm_ ``%r = getenv((char *) %0);'' name `thenPrimIO` \ litstring ->
- returnPrimIO (
- if (eqAddr litstring ``NULL'') then
- Failure (SearchError ("GetEnv:"++name))
- else
- Str (_unpackPS (_packCString litstring)) -- cheaper than it looks
- )
- where
- eqAddr (A# a1) (A# a2) = eqAddr# a1 a2
-
-#ifndef __PARALLEL_HASKELL__
-
-processIORequest (SigAction n act)
- = (case act of
- SAIgnore -> _ccall_ stg_sig_ignore n (``NULL''::_Addr)
- SADefault -> _ccall_ stg_sig_default n (``NULL''::_Addr)
- SACatch dialogue ->
- let handler :: PrimIO ()
- handler s = case (requestToPrimIO dialogue s) of
- ( (), s2@(S# _) ) -> ( (), s2 )
- in
- makeStablePtr handler `thenPrimIO` \ sptr ->
- _ccall_ stg_sig_catch n sptr (``NULL''::_Addr))
- `thenPrimIO` \ osptr ->
- returnPrimIO (
- if osptr >= 0 then Success
- else Failure (OtherError ("SigAction:" ++ show n)))
-
-#endif {-!parallel-}
-
-processIORequest _
- = error "DialogueToIO.processIORequest: unimplemented I/O request (please report)\n"
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[DialogueIO]{Access to all @Dialogues@ in the IO world}
-%* *
-%************************************************************************
-
-This is Andy Gill's stuff to make all of @Dialogue@-style IO readily
-available in the monadic IO world.
-
-%************************************************************************
-%* *
-\subsection{Support bits for all of this}
-%* *
-%************************************************************************
-
-\begin{code}
--- like unpackCString ...
-
-type CHAR_STAR_STAR = _Addr -- this is all a HACK
-type CHAR_STAR = _Addr
-
-unpackArgv :: CHAR_STAR_STAR -> Int -> [String] -- argv[1 .. argc-1]
-unpackProgName :: CHAR_STAR_STAR -> String -- argv[0]
-
-unpackArgv argv argc = unpack 1
- where
- unpack :: Int -> [String]
- unpack n
- = if (n >= argc)
- then ([] :: [String])
- else case (indexAddrOffAddr argv n) of { item ->
- _unpackPS (_packCString item) : unpack (n + 1)
- }
-
-unpackProgName argv
- = case (indexAddrOffAddr argv 0) of { prog ->
- de_slash [] (_unpackPS (_packCString prog)) }
- where
- -- re-start accumulating at every '/'
- de_slash :: String -> String -> String
- de_slash acc [] = reverse acc
- de_slash acc ('/':xs) = de_slash [] xs
- de_slash acc (x:xs) = de_slash (x:acc) xs
-\end{code}
-
-Read and append a string from/on a given @FILE *@ stream. @appendChan#@
-and @readChan#@ are well-behaved lazy functions; @writeFile#@ and
-@readFile#@ (which ``know'' they are writing/reading disk files) are
-much stricter.
-
-\begin{code}
-appendChan#, writeFile# :: _FILE -> String -> PrimIO Bool
-
-appendChan# stream [] = returnPrimIO True
-
-appendChan# stream (c : cs)
- = _ccall_ stg_putc c stream `seqPrimIO` -- stg_putc expands to putc
- appendChan# stream cs -- (just does some casting stream)
-
------------
-writeFile# stream [] = returnPrimIO True
-
-writeFile# stream (c1@(C# _) : c2@(C# _) : c3@(C# _) : c4@(C# _)
- : c5@(C# _) : c6@(C# _) : c7@(C# _) : c8@(C# _)
- : c9@(C# _) : c10@(C# _): c11@(C# _): c12@(C# _)
- : c13@(C# _): c14@(C# _): c15@(C# _): c16@(C# _): cs)
- = _ccall_ stg_putc c1 stream `seqPrimIO`
- _ccall_ stg_putc c2 stream `seqPrimIO`
- _ccall_ stg_putc c3 stream `seqPrimIO`
- _ccall_ stg_putc c4 stream `seqPrimIO`
- _ccall_ stg_putc c5 stream `seqPrimIO`
- _ccall_ stg_putc c6 stream `seqPrimIO`
- _ccall_ stg_putc c7 stream `seqPrimIO`
- _ccall_ stg_putc c8 stream `seqPrimIO`
- _ccall_ stg_putc c9 stream `seqPrimIO`
- _ccall_ stg_putc c10 stream `seqPrimIO`
- _ccall_ stg_putc c11 stream `seqPrimIO`
- _ccall_ stg_putc c12 stream `seqPrimIO`
- _ccall_ stg_putc c13 stream `seqPrimIO`
- _ccall_ stg_putc c14 stream `seqPrimIO`
- _ccall_ stg_putc c15 stream `seqPrimIO`
- _ccall_ stg_putc c16 stream `seqPrimIO`
- writeFile# stream cs
-
-writeFile# stream (c : cs)
- = _ccall_ stg_putc c stream `seqPrimIO`
- writeFile# stream cs
-\end{code}
-
-@readChan#@ lazily reads the rest of some stream. Dodgy because two
-uses of.
-
-ToDo: return fclose status.
-
-\begin{code}
-readChan#, readFile# :: _FILE -> PrimIO String
-
-readChan# stream
- = let
- read_rest
- = _ccall_ stg_getc{-macro-} stream `thenPrimIO` \ ch ->
-
- if ch < 0 then -- SIGH: ch ==# ``EOF'' then
- returnPrimIO []
- else
- unsafeInterleavePrimIO read_rest `thenPrimIO` \ rest ->
- returnPrimIO (chr ch : rest)
- in
- unsafeInterleavePrimIO read_rest `thenPrimIO` \ contents ->
- returnPrimIO contents
-
-------------------
-readFile# stream
- = let
- read_rest
- = newCharArray (0::Int, 1023){-malloc!?-} `thenStrictlyST` \ arr# ->
- -- ToDo: lift newCharArray out of the loop!
-
- _ccall_ fread arr# (1::Int) (1024::Int) stream `thenPrimIO` \ num_read ->
-
- cvt arr# 0 (num_read - 1) `thenPrimIO` \ chars ->
-
- if num_read < 1024 then
- fclose stream `seqPrimIO`
- returnPrimIO chars
- else
- unsafeInterleavePrimIO read_rest `thenPrimIO` \ rest ->
- returnPrimIO (chars ++ rest)
- in
- unsafeInterleavePrimIO read_rest `thenPrimIO` \ contents ->
- returnPrimIO contents
- where
- cvt :: _MutableByteArray _RealWorld Int
- -> Int -> Int
- -> PrimIO [Char]
-
- cvt arr# idx last
- = if idx > last then
- returnPrimIO []
- else
- readCharArray arr# idx `thenPrimIO` \ ch ->
- cvt arr# (idx + 1) last `thenPrimIO` \ rest ->
- returnPrimIO (ch : rest)
-\end{code}
+++ /dev/null
-%
-% (c) The GRASP/AQUA Project, Glasgow University, 1993
-%
-\section[PreludeErrIO]{Wrapper for errorIO primitive}
-
-The boxified version of the @errorIO#@ primitive.
-
-\begin{code}
-module PreludeErrIO where
-
-errorIO :: PrimIO () -> a
-
-errorIO io
- = case (errorIO# io) of
- _ -> bottom
- where
- bottom = bottom -- Never evaluated
-\end{code}
+++ /dev/null
-%
-% (c) The GRASP/AQUA Project, Glasgow University, 1993-1994
-%
-\section[PreludeGlaMisc]{Miscellaneous Glasgow Stuff}
-
-\begin{code}
-module PreludeGlaMisc( PreludeGlaMisc.. {-, PreludePS..-} ) where
-
-import Cls
-import Core
-import IInt
-import List ( (++) )
-import PreludeGlaST
-import PS ( _PackedString, _unpackPS )
-import TyArray ( Array(..) )
-import TyComplex
-import Text
-\end{code}
-
-Note: the above used to say:
-
-\begin{pseudocode}
-module PreludeGlaMisc(
- _MallocPtr,
-
-#ifndef __PARALLEL_HASKELL__
- _StablePtr,
- makeStablePtr, deRefStablePtr, freeStablePtr,
-
- performGC
-#endif /* !__PARALLEL_HASKELL__ */
-
- ) where
-\end{pseudocode}
-
-But then the names @_MallocPtr@ and @_StablePtr@ get shoved out into
-the interface file and anyone importing it becomes unhappy about
-seeing a preludish name.
-
-They report:
-
-@
-Bad name on a datatype constructor (a Prelude name?): _MallocPtr
-@
-
-(This is horrid!)
-
-(Oh, btw, don't try not exporting them either - that just makes the
-info-tables, etc local to this module so that no-one can get at them.)
-
-
-
-
-
-The next two definitions must match those in
-@compiler/prelude/TysWiredIn.lhs@ exactly.
-
-\begin{code}
-#ifndef __PARALLEL_HASKELL__
-
--- ** MOVED TO prelude/TysBasic.hs **
--- data _MallocPtr = _MallocPtr MallocPtr#
--- data _StablePtr a = _StablePtr (StablePtr# a)
-
-\end{code}
-
-Nota Bene: it is important {\em not\/} to inline calls to
-@makeStablePtr#@ since the corresponding macro is very long and we'll
-get terrible code-bloat.
-
-\begin{code}
-makeStablePtr :: a -> PrimIO (_StablePtr a)
-deRefStablePtr :: _StablePtr a -> PrimIO a
-freeStablePtr :: _StablePtr a -> PrimIO ()
-
-eqMallocPtr :: _MallocPtr -> _MallocPtr -> Bool
-
-performGC :: PrimIO ()
-
-{-# INLINE deRefStablePtr #-}
-{-# INLINE freeStablePtr #-}
-{-# INLINE performGC #-}
-
-makeStablePtr f (S# rw1#) =
- case makeStablePtr# f rw1# of
- StateAndStablePtr# rw2# sp# -> (_StablePtr sp#, S# rw2#)
-
-deRefStablePtr (_StablePtr sp#) (S# rw1#) =
- case deRefStablePtr# sp# rw1# of
- StateAndPtr# rw2# a -> (a, S# rw2#)
-
-freeStablePtr sp = _ccall_ freeStablePointer sp
-
-eqMallocPtr mp1 mp2 = unsafePerformPrimIO (
- _ccall_ eqMallocPtr mp1 mp2
- )
- /= (0::Int)
-
-instance Eq _MallocPtr where
- p == q = eqMallocPtr p q
- p /= q = if eqMallocPtr p q then False else True
-
-performGC = _ccall_GC_ StgPerformGarbageCollection
-
-#endif /* !__PARALLEL_HASKELL__ */
-\end{code}
-
-Like they say: this is as good a place as any to put it:
-
-\begin{code}
-addr2Int :: _Addr -> Int
-addr2Int (A# a#) = I# (addr2Int# a#)
-
-int2Addr :: Int -> _Addr
-int2Addr (I# i#) = A# (int2Addr# i#)
-\end{code}
+++ /dev/null
-%
-% (c) The AQUA Project, Glasgow University, 1994-1996
-%
-\section[PreludeGlaST]{Basic ``state transformer'' monad, mutable arrays and variables}
-
-See state-interface.verb, from which this is taken directly.
-
-\begin{code}
-#include "../../includes/platform.h"
-#include "../../includes/GhcConstants.h"
-
-module PreludeGlaST (
- PreludeGlaST.. ,
- _MutableArray(..),
- _MutableByteArray(..),
- ST(..), -- it's a known GHC infelicity that synonyms must
- MutableVar(..), -- be listed separately.
-
- --!! because this interface is now the "everything state-transformer"ish
- --!! interface, here is all the PreludePrimIO stuff
-
- -- PrimIO(..): no, the compiler already knows about it
-
- fixPrimIO,
- listPrimIO,
- mapAndUnzipPrimIO,
- mapPrimIO,
- returnPrimIO,
- seqPrimIO,
- thenPrimIO,
- unsafePerformPrimIO,
- unsafeInterleavePrimIO,
- forkPrimIO,
-
- -- all the Stdio stuff (this is how you get to it)
- -- (well, why not?)
- fclose, fdopen, fflush, fopen, fread, freopen,
- fwrite, _FILE(..),
-
- -- backward compatibility -- don't use!
- readChanPrimIO,
- appendChanPrimIO,
- appendFilePrimIO,
- getArgsPrimIO,
-
- --!! end of PreludePrimIO
-
- _ByteArray(..), Array(..) -- reexport *unabstractly*
- ) where
-
-import PreludePrimIO (
- fixPrimIO,
- listPrimIO,
- mapAndUnzipPrimIO,
- mapPrimIO,
- returnPrimIO,
- seqPrimIO,
- thenPrimIO,
- unsafePerformPrimIO,
- unsafeInterleavePrimIO,
--- forkPrimIO,
- readChanPrimIO,
- appendChanPrimIO,
- appendFilePrimIO,
- getArgsPrimIO
- )
-import Stdio
-
-import Cls
-import Core
-import IInt
-import ITup2
-import List ( map, null, foldr, (++) )
-import PS ( _PackedString, _unpackPS )
-import TyArray ( Array(..), _ByteArray(..) )
-import TyComplex
-import Text
-
-infixr 9 `thenST`, `thenStrictlyST`, `seqST`, `seqStrictlyST`
-
-type IPr = (Int, Int)
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[PreludeGlaST-ST-monad]{The state-transformer proper}
-%* *
-%************************************************************************
-
-\begin{code}
---BUILT-IN: type _ST s a -- State transformer
-
-type ST s a = _ST s a -- so you don't need -fglasgow-exts
-
-{-# INLINE returnST #-}
-{-# INLINE returnStrictlyST #-}
-{-# INLINE thenStrictlyST #-}
-{-# INLINE seqStrictlyST #-}
-
-returnST :: a -> _ST s a
-returnST a s = (a, s)
-
-thenST :: _ST s a -> (a -> _ST s b) -> _ST s b
-thenST m k s = let (r,new_s) = m s
- in
- k r new_s
-
-seqST :: _ST s a -> _ST s b -> _ST s b
-seqST m1 m2 = m1 `thenST` (\ _ -> m2)
-
-
-{-# GENERATE_SPECS returnStrictlyST a #-}
-returnStrictlyST :: a -> _ST s a
-
-{-# GENERATE_SPECS thenStrictlyST a b #-}
-thenStrictlyST :: _ST s a -> (a -> _ST s b) -> _ST s b
-
-{-# GENERATE_SPECS seqStrictlyST a b #-}
-seqStrictlyST :: _ST s a -> _ST s b -> _ST s b
-
-
-returnStrictlyST a s@(S# _) = (a, s)
-
-thenStrictlyST m k s -- @(S# _) Omitted SLPJ [May95] no need to evaluate the state
- = case (m s) of { (r, new_s) ->
- k r new_s }
-
-seqStrictlyST m k s -- @(S# _) Omitted SLPJ [May95] no need to evaluate the state
- = case (m s) of { (_, new_s) ->
- k new_s }
-
-
--- BUILT-IN: _runST (see Builtin.hs)
-
-unsafeInterleaveST :: _ST s a -> _ST s a -- ToDo: put in state-interface.tex
-unsafeInterleaveST m s
- = let
- (r, new_s) = m s
- in
- (r, s)
-
-
-fixST :: (a -> _ST s a) -> _ST s a
-fixST k s = let ans = k r s
- (r,new_s) = ans
- in
- ans
-
-listST :: [_ST s a] -> _ST s [a]
-listST [] = returnST []
-listST (m:ms) = m `thenST` \ x ->
- listST ms `thenST` \ xs ->
- returnST (x:xs)
-
-mapST :: (a -> _ST s b) -> [a] -> _ST s [b]
-mapST f ms = listST (map f ms)
-
-mapAndUnzipST :: (a -> _ST s (b,c)) -> [a] -> _ST s ([b],[c])
-mapAndUnzipST f [] = returnST ([], [])
-mapAndUnzipST f (m:ms)
- = f m `thenST` \ ( r1, r2) ->
- mapAndUnzipST f ms `thenST` \ (rs1, rs2) ->
- returnST (r1:rs1, r2:rs2)
-
-forkST :: ST s a -> ST s a
-
-#ifndef __CONCURRENT_HASKELL__
-forkST x = x
-#else
-
-forkST action s
- = let
- (r, new_s) = action s
- in
- new_s `_fork_` (r, s)
- where
- _fork_ x y = case (fork# x) of { 0# -> parError#; _ -> y }
-
-#endif {- concurrent -}
-
-forkPrimIO :: PrimIO a -> PrimIO a
-forkPrimIO = forkST
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[PreludeGlaST-arrays]{Mutable arrays}
-%* *
-%************************************************************************
-
-Idle ADR question: What's the tradeoff here between flattening these
-datatypes into @_MutableArray ix ix (MutableArray# s elt)@ and using
-it as is? As I see it, the former uses slightly less heap and
-provides faster access to the individual parts of the bounds while the
-code used has the benefit of providing a ready-made @(lo, hi)@ pair as
-required by many array-related functions. Which wins? Is the
-difference significant (probably not).
-
-Idle AJG answer: When I looked at the outputted code (though it was 2
-years ago) it seems like you often needed the tuple, and we build
-it frequently. Now we've got the overloading specialiser things
-might be different, though.
-
-\begin{code}
-data _MutableArray s ix elt = _MutableArray (ix,ix) (MutableArray# s elt)
-data _MutableByteArray s ix = _MutableByteArray (ix,ix) (MutableByteArray# s)
-
-instance _CCallable (_MutableByteArray s ix)
-\end{code}
-
-\begin{code}
-newArray, _newArray
- :: Ix ix => (ix,ix) -> elt -> _ST s (_MutableArray s ix elt)
-newCharArray, newIntArray, newAddrArray, newFloatArray, newDoubleArray
- :: Ix ix => (ix,ix) -> _ST s (_MutableByteArray s ix)
-
-{-# SPECIALIZE _newArray :: IPr -> elt -> _ST s (_MutableArray s Int elt),
- (IPr,IPr) -> elt -> _ST s (_MutableArray s IPr elt)
- #-}
-{-# SPECIALIZE newCharArray :: IPr -> _ST s (_MutableByteArray s Int) #-}
-{-# SPECIALIZE newIntArray :: IPr -> _ST s (_MutableByteArray s Int) #-}
-{-# SPECIALIZE newAddrArray :: IPr -> _ST s (_MutableByteArray s Int) #-}
-{-# SPECIALIZE newFloatArray :: IPr -> _ST s (_MutableByteArray s Int) #-}
-{-# SPECIALIZE newDoubleArray :: IPr -> _ST s (_MutableByteArray s Int) #-}
-
-newArray = _newArray
-
-_newArray ixs@(ix_start, ix_end) init (S# s#)
- = let n# = case (if null (range ixs)
- then 0
- else (index ixs ix_end) + 1) of { I# x -> x }
- -- size is one bigger than index of last elem
- in
- case (newArray# n# init s#) of { StateAndMutableArray# s2# arr# ->
- (_MutableArray ixs arr#, S# s2#)}
-
-newCharArray ixs@(ix_start, ix_end) (S# s#)
- = let n# = case (if null (range ixs)
- then 0
- else ((index ixs ix_end) + 1)) of { I# x -> x }
- in
- case (newCharArray# n# s#) of { StateAndMutableByteArray# s2# barr# ->
- (_MutableByteArray ixs barr#, S# s2#)}
-
-newIntArray ixs@(ix_start, ix_end) (S# s#)
- = let n# = case (if null (range ixs)
- then 0
- else ((index ixs ix_end) + 1)) of { I# x -> x }
- in
- case (newIntArray# n# s#) of { StateAndMutableByteArray# s2# barr# ->
- (_MutableByteArray ixs barr#, S# s2#)}
-
-newAddrArray ixs@(ix_start, ix_end) (S# s#)
- = let n# = case (if null (range ixs)
- then 0
- else ((index ixs ix_end) + 1)) of { I# x -> x }
- in
- case (newAddrArray# n# s#) of { StateAndMutableByteArray# s2# barr# ->
- (_MutableByteArray ixs barr#, S# s2#)}
-
-newFloatArray ixs@(ix_start, ix_end) (S# s#)
- = let n# = case (if null (range ixs)
- then 0
- else ((index ixs ix_end) + 1)) of { I# x -> x }
- in
- case (newFloatArray# n# s#) of { StateAndMutableByteArray# s2# barr# ->
- (_MutableByteArray ixs barr#, S# s2#)}
-
-newDoubleArray ixs@(ix_start, ix_end) (S# s#)
- = let n# = case (if null (range ixs)
- then 0
- else ((index ixs ix_end) + 1)) of { I# x -> x }
- in
--- trace ("newDoubleArray:"++(show (I# n#))) (
- case (newDoubleArray# n# s#) of { StateAndMutableByteArray# s2# barr# ->
- (_MutableByteArray ixs barr#, S# s2#)}
--- )
-\end{code}
-
-\begin{code}
-boundsOfArray :: Ix ix => _MutableArray s ix elt -> (ix, ix)
-boundsOfByteArray :: Ix ix => _MutableByteArray s ix -> (ix, ix)
-
-{-# SPECIALIZE boundsOfArray :: _MutableArray s Int elt -> IPr #-}
-{-# SPECIALIZE boundsOfByteArray :: _MutableByteArray s Int -> IPr #-}
-
-boundsOfArray (_MutableArray ixs _) = ixs
-boundsOfByteArray (_MutableByteArray ixs _) = ixs
-\end{code}
-
-\begin{code}
-readArray :: Ix ix => _MutableArray s ix elt -> ix -> _ST s elt
-
-readCharArray :: Ix ix => _MutableByteArray s ix -> ix -> _ST s Char
-readIntArray :: Ix ix => _MutableByteArray s ix -> ix -> _ST s Int
-readAddrArray :: Ix ix => _MutableByteArray s ix -> ix -> _ST s _Addr
-readFloatArray :: Ix ix => _MutableByteArray s ix -> ix -> _ST s Float
-readDoubleArray :: Ix ix => _MutableByteArray s ix -> ix -> _ST s Double
-
-{-# SPECIALIZE readArray :: _MutableArray s Int elt -> Int -> _ST s elt,
- _MutableArray s IPr elt -> IPr -> _ST s elt
- #-}
-{-# SPECIALIZE readCharArray :: _MutableByteArray s Int -> Int -> _ST s Char #-}
-{-# SPECIALIZE readIntArray :: _MutableByteArray s Int -> Int -> _ST s Int #-}
-{-# SPECIALIZE readAddrArray :: _MutableByteArray s Int -> Int -> _ST s _Addr #-}
---NO:{-# SPECIALIZE readFloatArray :: _MutableByteArray s Int -> Int -> _ST s Float #-}
-{-# SPECIALIZE readDoubleArray :: _MutableByteArray s Int -> Int -> _ST s Double #-}
-
-readArray (_MutableArray ixs arr#) n (S# s#)
- = case (index ixs n) of { I# n# ->
- case readArray# arr# n# s# of { StateAndPtr# s2# r ->
- (r, S# s2#)}}
-
-readCharArray (_MutableByteArray ixs barr#) n (S# s#)
- = case (index ixs n) of { I# n# ->
- case readCharArray# barr# n# s# of { StateAndChar# s2# r# ->
- (C# r#, S# s2#)}}
-
-readIntArray (_MutableByteArray ixs barr#) n (S# s#)
- = case (index ixs n) of { I# n# ->
- case readIntArray# barr# n# s# of { StateAndInt# s2# r# ->
- (I# r#, S# s2#)}}
-
-readAddrArray (_MutableByteArray ixs barr#) n (S# s#)
- = case (index ixs n) of { I# n# ->
- case readAddrArray# barr# n# s# of { StateAndAddr# s2# r# ->
- (A# r#, S# s2#)}}
-
-readFloatArray (_MutableByteArray ixs barr#) n (S# s#)
- = case (index ixs n) of { I# n# ->
- case readFloatArray# barr# n# s# of { StateAndFloat# s2# r# ->
- (F# r#, S# s2#)}}
-
-readDoubleArray (_MutableByteArray ixs barr#) n (S# s#)
- = case (index ixs n) of { I# n# ->
--- trace ("readDoubleArray:"++(show (I# n#))) (
- case readDoubleArray# barr# n# s# of { StateAndDouble# s2# r# ->
- (D# r#, S# s2#)}}
-\end{code}
-
-Indexing of ordinary @Arrays@ is standard Haskell and isn't defined here.
-\begin{code}
-indexCharArray :: Ix ix => _ByteArray ix -> ix -> Char
-indexIntArray :: Ix ix => _ByteArray ix -> ix -> Int
-indexAddrArray :: Ix ix => _ByteArray ix -> ix -> _Addr
-indexFloatArray :: Ix ix => _ByteArray ix -> ix -> Float
-indexDoubleArray :: Ix ix => _ByteArray ix -> ix -> Double
-
-{-# SPECIALIZE indexCharArray :: _ByteArray Int -> Int -> Char #-}
-{-# SPECIALIZE indexIntArray :: _ByteArray Int -> Int -> Int #-}
-{-# SPECIALIZE indexAddrArray :: _ByteArray Int -> Int -> _Addr #-}
---NO:{-# SPECIALIZE indexFloatArray :: _ByteArray Int -> Int -> Float #-}
-{-# SPECIALIZE indexDoubleArray :: _ByteArray Int -> Int -> Double #-}
-
-indexCharArray (_ByteArray ixs barr#) n
- = case (index ixs n) of { I# n# ->
- case indexCharArray# barr# n# of { r# ->
- (C# r#)}}
-
-indexIntArray (_ByteArray ixs barr#) n
- = case (index ixs n) of { I# n# ->
- case indexIntArray# barr# n# of { r# ->
- (I# r#)}}
-
-indexAddrArray (_ByteArray ixs barr#) n
- = case (index ixs n) of { I# n# ->
- case indexAddrArray# barr# n# of { r# ->
- (A# r#)}}
-
-indexFloatArray (_ByteArray ixs barr#) n
- = case (index ixs n) of { I# n# ->
- case indexFloatArray# barr# n# of { r# ->
- (F# r#)}}
-
-indexDoubleArray (_ByteArray ixs barr#) n
- = case (index ixs n) of { I# n# ->
--- trace ("indexDoubleArray:"++(show (I# n#))) (
- case indexDoubleArray# barr# n# of { r# ->
- (D# r#)}}
-\end{code}
-
-Indexing off @_Addrs@ is similar, and therefore given here.
-\begin{code}
-indexCharOffAddr :: _Addr -> Int -> Char
-indexIntOffAddr :: _Addr -> Int -> Int
-indexAddrOffAddr :: _Addr -> Int -> _Addr
-indexFloatOffAddr :: _Addr -> Int -> Float
-indexDoubleOffAddr :: _Addr -> Int -> Double
-
-indexCharOffAddr (A# addr#) n
- = case n of { I# n# ->
- case indexCharOffAddr# addr# n# of { r# ->
- (C# r#)}}
-
-indexIntOffAddr (A# addr#) n
- = case n of { I# n# ->
- case indexIntOffAddr# addr# n# of { r# ->
- (I# r#)}}
-
-indexAddrOffAddr (A# addr#) n
- = case n of { I# n# ->
- case indexAddrOffAddr# addr# n# of { r# ->
- (A# r#)}}
-
-indexFloatOffAddr (A# addr#) n
- = case n of { I# n# ->
- case indexFloatOffAddr# addr# n# of { r# ->
- (F# r#)}}
-
-indexDoubleOffAddr (A# addr#) n
- = case n of { I# n# ->
- case indexDoubleOffAddr# addr# n# of { r# ->
- (D# r#)}}
-\end{code}
-
-\begin{code}
-writeArray :: Ix ix => _MutableArray s ix elt -> ix -> elt -> _ST s ()
-writeCharArray :: Ix ix => _MutableByteArray s ix -> ix -> Char -> _ST s ()
-writeIntArray :: Ix ix => _MutableByteArray s ix -> ix -> Int -> _ST s ()
-writeAddrArray :: Ix ix => _MutableByteArray s ix -> ix -> _Addr -> _ST s ()
-writeFloatArray :: Ix ix => _MutableByteArray s ix -> ix -> Float -> _ST s ()
-writeDoubleArray :: Ix ix => _MutableByteArray s ix -> ix -> Double -> _ST s ()
-
-{-# SPECIALIZE writeArray :: _MutableArray s Int elt -> Int -> elt -> _ST s (),
- _MutableArray s IPr elt -> IPr -> elt -> _ST s ()
- #-}
-{-# SPECIALIZE writeCharArray :: _MutableByteArray s Int -> Int -> Char -> _ST s () #-}
-{-# SPECIALIZE writeIntArray :: _MutableByteArray s Int -> Int -> Int -> _ST s () #-}
-{-# SPECIALIZE writeAddrArray :: _MutableByteArray s Int -> Int -> _Addr -> _ST s () #-}
---NO:{-# SPECIALIZE writeFloatArray :: _MutableByteArray s Int -> Int -> Float -> _ST s () #-}
-{-# SPECIALIZE writeDoubleArray :: _MutableByteArray s Int -> Int -> Double -> _ST s () #-}
-
-writeArray (_MutableArray ixs arr#) n ele (S# s#)
- = case index ixs n of { I# n# ->
- case writeArray# arr# n# ele s# of { s2# ->
- ((), S# s2#)}}
-
-writeCharArray (_MutableByteArray ixs barr#) n (C# ele) (S# s#)
- = case (index ixs n) of { I# n# ->
- case writeCharArray# barr# n# ele s# of { s2# ->
- ((), S# s2#)}}
-
-writeIntArray (_MutableByteArray ixs barr#) n (I# ele) (S# s#)
- = case (index ixs n) of { I# n# ->
- case writeIntArray# barr# n# ele s# of { s2# ->
- ((), S# s2#)}}
-
-writeAddrArray (_MutableByteArray ixs barr#) n (A# ele) (S# s#)
- = case (index ixs n) of { I# n# ->
- case writeAddrArray# barr# n# ele s# of { s2# ->
- ((), S# s2#)}}
-
-writeFloatArray (_MutableByteArray ixs barr#) n (F# ele) (S# s#)
- = case (index ixs n) of { I# n# ->
- case writeFloatArray# barr# n# ele s# of { s2# ->
- ((), S# s2#)}}
-
-writeDoubleArray (_MutableByteArray ixs barr#) n (D# ele) (S# s#)
- = case (index ixs n) of { I# n# ->
--- trace ("writeDoubleArray:"++(show (I# n#))) (
- case writeDoubleArray# barr# n# ele s# of { s2# ->
- ((), S# s2#)}}
-\end{code}
-
-\begin{code}
-freezeArray, _freezeArray :: Ix ix => _MutableArray s ix elt -> _ST s (Array ix elt)
-freezeCharArray :: Ix ix => _MutableByteArray s ix -> _ST s (_ByteArray ix)
-freezeIntArray :: Ix ix => _MutableByteArray s ix -> _ST s (_ByteArray ix)
-freezeAddrArray :: Ix ix => _MutableByteArray s ix -> _ST s (_ByteArray ix)
-freezeFloatArray :: Ix ix => _MutableByteArray s ix -> _ST s (_ByteArray ix)
-freezeDoubleArray :: Ix ix => _MutableByteArray s ix -> _ST s (_ByteArray ix)
-
-{-# SPECIALISE _freezeArray :: _MutableArray s Int elt -> _ST s (Array Int elt),
- _MutableArray s IPr elt -> _ST s (Array IPr elt)
- #-}
-{-# SPECIALISE freezeCharArray :: _MutableByteArray s Int -> _ST s (_ByteArray Int) #-}
-
-freezeArray = _freezeArray
-
-_freezeArray (_MutableArray ixs@(ix_start, ix_end) arr#) (S# s#)
- = let n# = case (if null (range ixs)
- then 0
- else (index ixs ix_end) + 1) of { I# x -> x }
- in
- case freeze arr# n# s# of { StateAndArray# s2# frozen# ->
- (_Array ixs frozen#, S# s2#)}
- where
- freeze :: MutableArray# s ele -- the thing
- -> Int# -- size of thing to be frozen
- -> State# s -- the Universe and everything
- -> StateAndArray# s ele
-
- freeze arr# n# s#
- = case newArray# n# init s# of { StateAndMutableArray# s2# newarr1# ->
- case copy 0# n# arr# newarr1# s2# of { StateAndMutableArray# s3# newarr2# ->
- unsafeFreezeArray# newarr2# s3#
- }}
- where
- init = error "freezeArr: element not copied"
-
- copy :: Int# -> Int#
- -> MutableArray# s ele -> MutableArray# s ele
- -> State# s
- -> StateAndMutableArray# s ele
-
- copy cur# end# from# to# s#
- | cur# ==# end#
- = StateAndMutableArray# s# to#
- | True
- = case readArray# from# cur# s# of { StateAndPtr# s1# ele ->
- case writeArray# to# cur# ele s1# of { s2# ->
- copy (cur# +# 1#) end# from# to# s2#
- }}
-
-freezeCharArray (_MutableByteArray ixs@(ix_start, ix_end) arr#) (S# s#)
- = let n# = case (if null (range ixs)
- then 0
- else ((index ixs ix_end) + 1)) of { I# x -> x }
- in
- case freeze arr# n# s# of { StateAndByteArray# s2# frozen# ->
- (_ByteArray ixs frozen#, S# s2#) }
- where
- freeze :: MutableByteArray# s -- the thing
- -> Int# -- size of thing to be frozen
- -> State# s -- the Universe and everything
- -> StateAndByteArray# s
-
- freeze arr# n# s#
- = case (newCharArray# n# s#) of { StateAndMutableByteArray# s2# newarr1# ->
- case copy 0# n# arr# newarr1# s2# of { StateAndMutableByteArray# s3# newarr2# ->
- unsafeFreezeByteArray# newarr2# s3#
- }}
- where
- copy :: Int# -> Int#
- -> MutableByteArray# s -> MutableByteArray# s
- -> State# s
- -> StateAndMutableByteArray# s
-
- copy cur# end# from# to# s#
- | cur# ==# end#
- = StateAndMutableByteArray# s# to#
- | True
- = case (readCharArray# from# cur# s#) of { StateAndChar# s1# ele ->
- case (writeCharArray# to# cur# ele s1#) of { s2# ->
- copy (cur# +# 1#) end# from# to# s2#
- }}
-
-freezeIntArray (_MutableByteArray ixs@(ix_start, ix_end) arr#) (S# s#)
- = let n# = case (if null (range ixs)
- then 0
- else ((index ixs ix_end) + 1)) of { I# x -> x }
- in
- case freeze arr# n# s# of { StateAndByteArray# s2# frozen# ->
- (_ByteArray ixs frozen#, S# s2#) }
- where
- freeze :: MutableByteArray# s -- the thing
- -> Int# -- size of thing to be frozen
- -> State# s -- the Universe and everything
- -> StateAndByteArray# s
-
- freeze arr# n# s#
- = case (newIntArray# n# s#) of { StateAndMutableByteArray# s2# newarr1# ->
- case copy 0# n# arr# newarr1# s2# of { StateAndMutableByteArray# s3# newarr2# ->
- unsafeFreezeByteArray# newarr2# s3#
- }}
- where
- copy :: Int# -> Int#
- -> MutableByteArray# s -> MutableByteArray# s
- -> State# s
- -> StateAndMutableByteArray# s
-
- copy cur# end# from# to# s#
- | cur# ==# end#
- = StateAndMutableByteArray# s# to#
- | True
- = case (readIntArray# from# cur# s#) of { StateAndInt# s1# ele ->
- case (writeIntArray# to# cur# ele s1#) of { s2# ->
- copy (cur# +# 1#) end# from# to# s2#
- }}
-
-freezeAddrArray (_MutableByteArray ixs@(ix_start, ix_end) arr#) (S# s#)
- = let n# = case (if null (range ixs)
- then 0
- else ((index ixs ix_end) + 1)) of { I# x -> x }
- in
- case freeze arr# n# s# of { StateAndByteArray# s2# frozen# ->
- (_ByteArray ixs frozen#, S# s2#) }
- where
- freeze :: MutableByteArray# s -- the thing
- -> Int# -- size of thing to be frozen
- -> State# s -- the Universe and everything
- -> StateAndByteArray# s
-
- freeze arr# n# s#
- = case (newAddrArray# n# s#) of { StateAndMutableByteArray# s2# newarr1# ->
- case copy 0# n# arr# newarr1# s2# of { StateAndMutableByteArray# s3# newarr2# ->
- unsafeFreezeByteArray# newarr2# s3#
- }}
- where
- copy :: Int# -> Int#
- -> MutableByteArray# s -> MutableByteArray# s
- -> State# s
- -> StateAndMutableByteArray# s
-
- copy cur# end# from# to# s#
- | cur# ==# end#
- = StateAndMutableByteArray# s# to#
- | True
- = case (readAddrArray# from# cur# s#) of { StateAndAddr# s1# ele ->
- case (writeAddrArray# to# cur# ele s1#) of { s2# ->
- copy (cur# +# 1#) end# from# to# s2#
- }}
-
-freezeFloatArray (_MutableByteArray ixs@(ix_start, ix_end) arr#) (S# s#)
- = let n# = case (if null (range ixs)
- then 0
- else ((index ixs ix_end) + 1)) of { I# x -> x }
- in
- case freeze arr# n# s# of { StateAndByteArray# s2# frozen# ->
- (_ByteArray ixs frozen#, S# s2#) }
- where
- freeze :: MutableByteArray# s -- the thing
- -> Int# -- size of thing to be frozen
- -> State# s -- the Universe and everything
- -> StateAndByteArray# s
-
- freeze arr# n# s#
- = case (newFloatArray# n# s#) of { StateAndMutableByteArray# s2# newarr1# ->
- case copy 0# n# arr# newarr1# s2# of { StateAndMutableByteArray# s3# newarr2# ->
- unsafeFreezeByteArray# newarr2# s3#
- }}
- where
- copy :: Int# -> Int#
- -> MutableByteArray# s -> MutableByteArray# s
- -> State# s
- -> StateAndMutableByteArray# s
-
- copy cur# end# from# to# s#
- | cur# ==# end#
- = StateAndMutableByteArray# s# to#
- | True
- = case (readFloatArray# from# cur# s#) of { StateAndFloat# s1# ele ->
- case (writeFloatArray# to# cur# ele s1#) of { s2# ->
- copy (cur# +# 1#) end# from# to# s2#
- }}
-
-freezeDoubleArray (_MutableByteArray ixs@(ix_start, ix_end) arr#) (S# s#)
- = let n# = case (if null (range ixs)
- then 0
- else ((index ixs ix_end) + 1)) of { I# x -> x }
- in
- case freeze arr# n# s# of { StateAndByteArray# s2# frozen# ->
- (_ByteArray ixs frozen#, S# s2#) }
- where
- freeze :: MutableByteArray# s -- the thing
- -> Int# -- size of thing to be frozen
- -> State# s -- the Universe and everything
- -> StateAndByteArray# s
-
- freeze arr# n# s#
- = case (newDoubleArray# n# s#) of { StateAndMutableByteArray# s2# newarr1# ->
- case copy 0# n# arr# newarr1# s2# of { StateAndMutableByteArray# s3# newarr2# ->
- unsafeFreezeByteArray# newarr2# s3#
- }}
- where
- copy :: Int# -> Int#
- -> MutableByteArray# s -> MutableByteArray# s
- -> State# s
- -> StateAndMutableByteArray# s
-
- copy cur# end# from# to# s#
- | cur# ==# end#
- = StateAndMutableByteArray# s# to#
- | True
- = case (readDoubleArray# from# cur# s#) of { StateAndDouble# s1# ele ->
- case (writeDoubleArray# to# cur# ele s1#) of { s2# ->
- copy (cur# +# 1#) end# from# to# s2#
- }}
-\end{code}
-
-\begin{code}
-unsafeFreezeArray :: Ix ix => _MutableArray s ix elt -> _ST s (Array ix elt)
-unsafeFreezeByteArray :: Ix ix => _MutableByteArray s ix -> _ST s (_ByteArray ix)
-
-{-# SPECIALIZE unsafeFreezeByteArray :: _MutableByteArray s Int -> _ST s (_ByteArray Int)
- #-}
-
-unsafeFreezeArray (_MutableArray ixs arr#) (S# s#)
- = case unsafeFreezeArray# arr# s# of { StateAndArray# s2# frozen# ->
- (_Array ixs frozen#, S# s2#) }
-
-unsafeFreezeByteArray (_MutableByteArray ixs arr#) (S# s#)
- = case unsafeFreezeByteArray# arr# s# of { StateAndByteArray# s2# frozen# ->
- (_ByteArray ixs frozen#, S# s2#) }
-\end{code}
-
-This takes a immutable array, and copies it into a mutable array, in a
-hurry.
-
-\begin{code}
-{-# SPECIALISE thawArray :: Array Int elt -> _ST s (_MutableArray s Int elt),
- Array IPr elt -> _ST s (_MutableArray s IPr elt)
- #-}
-
-thawArray (_Array ixs@(ix_start, ix_end) arr#) (S# s#)
- = let n# = case (if null (range ixs)
- then 0
- else (index ixs ix_end) + 1) of { I# x -> x }
- in
- case thaw arr# n# s# of { StateAndMutableArray# s2# thawed# ->
- (_MutableArray ixs thawed#, S# s2#)}
- where
- thaw :: Array# ele -- the thing
- -> Int# -- size of thing to be thawed
- -> State# s -- the Universe and everything
- -> StateAndMutableArray# s ele
-
- thaw arr# n# s#
- = case newArray# n# init s# of { StateAndMutableArray# s2# newarr1# ->
- copy 0# n# arr# newarr1# s2# }
- where
- init = error "thawArr: element not copied"
-
- copy :: Int# -> Int#
- -> Array# ele
- -> MutableArray# s ele
- -> State# s
- -> StateAndMutableArray# s ele
-
- copy cur# end# from# to# s#
- | cur# ==# end#
- = StateAndMutableArray# s# to#
- | True
- = case indexArray# from# cur# of { _Lift ele ->
- case writeArray# to# cur# ele s# of { s1# ->
- copy (cur# +# 1#) end# from# to# s1#
- }}
-\end{code}
-
-\begin{code}
-sameMutableArray :: _MutableArray s ix elt -> _MutableArray s ix elt -> Bool
-sameMutableByteArray :: _MutableByteArray s ix -> _MutableByteArray s ix -> Bool
-
-sameMutableArray (_MutableArray _ arr1#) (_MutableArray _ arr2#)
- = sameMutableArray# arr1# arr2#
-
-sameMutableByteArray (_MutableByteArray _ arr1#) (_MutableByteArray _ arr2#)
- = sameMutableByteArray# arr1# arr2#
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[PreludeGlaST-variables]{Variables}
-%* *
-%************************************************************************
-
-\begin{code}
-type MutableVar s a = _MutableArray s Int a
-\end{code}
-
-\begin{code}
-newVar :: a -> _ST s (MutableVar s a)
-readVar :: MutableVar s a -> _ST s a
-writeVar :: MutableVar s a -> a -> _ST s ()
-sameVar :: MutableVar s a -> MutableVar s a -> Bool
-
-{- MUCH GRATUITOUS INEFFICIENCY: WDP 95/09:
-
-newVar init s = newArray (0,0) init s
-readVar v s = readArray v 0 s
-writeVar v val s = writeArray v 0 val s
-sameVar v1 v2 = sameMutableArray v1 v2
--}
-
-newVar init (S# s#)
- = case (newArray# 1# init s#) of { StateAndMutableArray# s2# arr# ->
- (_MutableArray vAR_IXS arr#, S# s2#) }
- where
- vAR_IXS = error "Shouldn't access `bounds' of a MutableVar\n"
-
-readVar (_MutableArray _ var#) (S# s#)
- = case readArray# var# 0# s# of { StateAndPtr# s2# r ->
- (r, S# s2#) }
-
-writeVar (_MutableArray _ var#) val (S# s#)
- = case writeArray# var# 0# val s# of { s2# ->
- ((), S# s2#) }
-
-sameVar (_MutableArray _ var1#) (_MutableArray _ var2#)
- = sameMutableArray# var1# var2#
-\end{code}
+++ /dev/null
-%
-% (c) The AQUA Project, Glasgow University, 1994-1995
-%
-\section[PrimIO]{@PrimIO@ monad}
-
-This sits on top of the state-transformer monad. See
-state-interface.verb.
-
-We follow the Haskell~1.3 I/O proposal nomenclature.
-
-\begin{code}
-module PreludePrimIO (
- -- PrimIO(..): no, the compiler already knows about it
-
- fixPrimIO,
- listPrimIO,
- mapAndUnzipPrimIO,
- mapPrimIO,
- returnPrimIO,
- seqPrimIO,
- thenPrimIO,
- unsafePerformPrimIO,
- unsafeInterleavePrimIO,
--- forkPrimIO,
-
- -- all the Stdio stuff (this is how you get to it)
- -- (well, why not?)
- fclose, fdopen, fflush, fopen, fread, freopen,
- fwrite, _FILE(..),
-
- -- IVars and MVars come from here, too
- _IVar, _MVar, -- abstract
- IVar(..), MVar(..), -- for convenience
- newEmptyMVar, takeMVar, putMVar, newMVar, readMVar, swapMVar,
- newIVar, readIVar, writeIVar,
-
- threadWait, threadDelay,
-
- -- backward compatibility -- don't use!
- readChanPrimIO,
- appendChanPrimIO,
- appendFilePrimIO,
- getArgsPrimIO,
-
- -- make interface self-sufficient
- fixST, unsafeInterleaveST
- ) where
-
-import PreludeGlaST
-import TyArray ( Array(..) )
-import Cls
-import Core
-import List ( (++), map )
-import PreludeDialogueIO ( processIORequest )
-import PS ( _PackedString, _unpackPS )
-import TyComplex
-import TyIO
-import Stdio
-
-import PreludeMonadicIO ( IO(..), Either(..), return, (>>=), (>>) )
-import PreludeIOError ( IOError13 )
-
-infixr 1 `thenPrimIO`, `seqPrimIO`
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[IO-monad]{The @IO@ monad}
-%* *
-%************************************************************************
-
-\begin{code}
-type PrimIO a = _ST _RealWorld a
-\end{code}
-
-The usual business:
-\begin{code}
-{-# GENERATE_SPECS returnPrimIO a #-}
-returnPrimIO :: a -> PrimIO a
-
-{-# GENERATE_SPECS thenPrimIO b #-}
-thenPrimIO :: PrimIO a -> (a -> PrimIO b) -> PrimIO b
-
-{-# GENERATE_SPECS seqPrimIO b #-}
-seqPrimIO :: PrimIO a -> PrimIO b -> PrimIO b
-
-fixPrimIO :: (a -> PrimIO a) -> PrimIO a
-listPrimIO :: [PrimIO a] -> PrimIO [a]
-mapPrimIO :: (a -> PrimIO b) -> [a] -> PrimIO [b]
-mapAndUnzipPrimIO :: (a -> PrimIO (b,c)) -> [a] -> PrimIO ([b],[c])
-
-{-# INLINE returnPrimIO #-}
-{-# INLINE thenPrimIO #-}
-{-# INLINE seqPrimIO #-}
-
-returnPrimIO x s = returnStrictlyST x s
-thenPrimIO m k s = thenStrictlyST m k s
-seqPrimIO m k s = seqStrictlyST m k s
-
-fixPrimIO = fixST
-
-listPrimIO [] = returnPrimIO []
-listPrimIO (m:ms) = m `thenPrimIO` \ x ->
- listPrimIO ms `thenPrimIO` \xs ->
- returnPrimIO (x:xs)
-
--- An earlier definition of listPrimIO in terms of foldrPrimIO
--- was just wrong (it did the operations in the wrong order)
--- so I deleted foldrPrimIO and defined listPrimIO directly.
--- SLPJ Feb 95
-
-mapPrimIO f ms = listPrimIO (map f ms)
-
-mapAndUnzipPrimIO f [] = returnPrimIO ([], [])
-mapAndUnzipPrimIO f (m:ms)
- = f m `thenPrimIO` \ ( r1, r2) ->
- mapAndUnzipPrimIO f ms `thenPrimIO` \ (rs1, rs2) ->
- returnPrimIO (r1:rs1, r2:rs2)
-\end{code}
-
-\begin{code}
-{-# GENERATE_SPECS unsafePerformPrimIO a #-}
-unsafePerformPrimIO :: PrimIO a -> a
-
-unsafeInterleavePrimIO :: PrimIO a -> PrimIO a
-
-unsafePerformPrimIO k = case (k (S# realWorld#)) of (r, _) -> r
-
-unsafeInterleavePrimIO m s = unsafeInterleaveST m s
-\end{code}
-
-Transitional: for pre-1.3 systems: Don't use them!
-\begin{code}
-readChanPrimIO :: String -> PrimIO String
-appendChanPrimIO :: String -> String -> PrimIO ()
-appendFilePrimIO :: String -> String -> PrimIO ()
-getArgsPrimIO :: PrimIO [String]
-
-readChanPrimIO c = processIORequestString ( ReadChan c )
-appendChanPrimIO c s = processIORequestUnit ( AppendChan c s )
-appendFilePrimIO f s = processIORequestUnit ( AppendFile f s )
-getArgsPrimIO = processIORequestStrList ( GetArgs )
-
-processIORequestUnit :: Request -> PrimIO ()
-processIORequestString :: Request -> PrimIO String
-processIORequestStrList :: Request -> PrimIO [String]
-
-processIORequestUnit req
- = processIORequest req `thenPrimIO` \ resp ->
- case resp of
- Success -> returnPrimIO ()
- Failure ioerr -> error (ioErrMsg ioerr)
- _ -> error "funny Response, expected a Success"
-
-processIORequestString req
- = processIORequest req `thenPrimIO` \ resp ->
- case resp of
- Str str -> returnPrimIO str
- Failure ioerr -> error (ioErrMsg ioerr)
- _ -> error "funny Response, expected a String"
-
-processIORequestStrList req
- = processIORequest req `thenPrimIO` \ resp ->
- case resp of
- StrList strl -> returnPrimIO strl
- Failure ioerr -> error (ioErrMsg ioerr)
- _ -> error "funny Response, expected a [String]"
-
-ioErrMsg :: IOError -> String
-ioErrMsg (ReadError s) = "Read Error: " ++ s
-ioErrMsg (WriteError s) = "Write Error: " ++ s
-ioErrMsg (FormatError s) = "Format Error: " ++ s
-ioErrMsg (SearchError s) = "Search Error: " ++ s
-ioErrMsg (OtherError s) = "Other Error: " ++ s
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[PreludeGlaST-mvars]{M-Structures}
-%* *
-%************************************************************************
-
-M-Vars are rendezvous points for concurrent threads. They begin
-empty, and any attempt to read an empty M-Var blocks. When an M-Var
-is written, a single blocked thread may be freed. Reading an M-Var
-toggles its state from full back to empty. Therefore, any value
-written to an M-Var may only be read once. Multiple reads and writes
-are allowed, but there must be at least one read between any two
-writes.
-
-\begin{code}
-data _MVar a = _MVar (SynchVar# _RealWorld a)
-type MVar a = _MVar a
-\end{code}
-
-\begin{code}
-newEmptyMVar :: IO (_MVar a)
-
-newEmptyMVar (S# s#) =
- case newSynchVar# s# of
- StateAndSynchVar# s2# svar# -> (Right (_MVar svar#), S# s2#)
-
-takeMVar :: _MVar a -> IO a
-
-takeMVar (_MVar mvar#) (S# s#) =
- case takeMVar# mvar# s# of
- StateAndPtr# s2# r -> (Right r, S# s2#)
-
-putMVar :: _MVar a -> a -> IO ()
-
-putMVar (_MVar mvar#) x (S# s#) =
- case putMVar# mvar# x s# of
- s2# -> (Right (), S# s2#)
-
-newMVar :: a -> IO (_MVar a)
-
-newMVar value =
- newEmptyMVar >>= \ mvar ->
- putMVar mvar value >>
- return mvar
-
-readMVar :: _MVar a -> IO a
-
-readMVar mvar =
- takeMVar mvar >>= \ value ->
- putMVar mvar value >>
- return value
-
-swapMVar :: _MVar a -> a -> IO a
-
-swapMVar mvar new =
- takeMVar mvar >>= \ old ->
- putMVar mvar new >>
- return old
-
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[PreludeGlaST-ivars]{I-Structures}
-%* *
-%************************************************************************
-
-I-Vars are write-once variables. They start out empty, and any threads that
-attempt to read them will block until they are filled. Once they are written,
-any blocked threads are freed, and additional reads are permitted. Attempting
-to write a value to a full I-Var results in a runtime error.
-
-\begin{code}
-data _IVar a = _IVar (SynchVar# _RealWorld a)
-type IVar a = _IVar a
-\end{code}
-
-\begin{code}
-newIVar :: IO (_IVar a)
-
-newIVar (S# s#) =
- case newSynchVar# s# of
- StateAndSynchVar# s2# svar# -> (Right (_IVar svar#), S# s2#)
-
-readIVar :: _IVar a -> IO a
-
-readIVar (_IVar ivar#) (S# s#) =
- case readIVar# ivar# s# of
- StateAndPtr# s2# r -> (Right r, S# s2#)
-
-writeIVar :: _IVar a -> a -> IO ()
-
-writeIVar (_IVar ivar#) x (S# s#) =
- case writeIVar# ivar# x s# of
- s2# -> (Right (), S# s2#)
-
-\end{code}
-
-
-%************************************************************************
-%* *
-\subsection{Thread Wait Functions}
-%* *
-%************************************************************************
-
-@threadDelay@ delays rescheduling of a thread until the indicated
-number of microseconds have elapsed. Generally, the microseconds are
-counted by the context switch timer, which ticks in virtual time;
-however, when there are no runnable threads, we don't accumulate any
-virtual time, so we start ticking in real time. (The granularity is
-the effective resolution of the context switch timer, so it is
-affected by the RTS -C option.)
-
-@threadWait@ delays rescheduling of a thread until input on the
-specified file descriptor is available for reading (just like select).
-
-\begin{code}
-threadDelay, threadWait :: Int -> IO ()
-
-threadDelay (I# x#) (S# s#) =
- case delay# x# s# of
- s2# -> (Right (), S# s2#)
-
-threadWait (I# x#) (S# s#) =
- case wait# x# s# of
- s2# -> (Right (), S# s2#)
-\end{code}
+++ /dev/null
-%
-% (c) The AQUA Project, Glasgow University, 1993-1994
-%
-\section[Stdio]{Wrappers for C standard-IO library}
-
-\begin{code}
-module Stdio where
-
-import Cls
-import Core
-import IInt
-import IList
-import List ( (++), foldr )
-import PS -- ( _PackedString )
-import TyArray
-import PreludeGlaST
-import Text
-import TyComplex
-
-data _FILE = _FILE Addr#
-instance _CCallable _FILE
-instance _CReturnable _FILE
-
-instance Eq _FILE where
- (_FILE a) == (_FILE b) = a `eqAddr#` b
- (_FILE a) /= (_FILE b) = if a `eqAddr#` b then False else True
-
-type FILE_DESCRIPTOR = Int
-
-fopen :: String -- as w/ C fopen, name
- -> String -- type of open (as w/ C)
- -> PrimIO _FILE -- FILE* returned; will be ``NULL''
- -- if things go wrong...
-
--- similarly...
-freopen :: String -> String -> _FILE -> PrimIO _FILE
-fdopen :: FILE_DESCRIPTOR -> String -> PrimIO _FILE
-
-fopen name descr
- = _casm_ ``%r = (A_) fopen((char *) %0, (char *) %1);'' name descr
-
-freopen name descr file
- = _casm_ ``%r = (A_) freopen((char *) %0, (char *) %1, (FILE *) %2);''
- name descr file
-
-fdopen fd descr
- = _casm_ ``%r = (A_) fdopen((int) %0, (char *) %1);'' fd descr
-
----------------------------------------------------------------
-fclose, fflush :: _FILE -> PrimIO Int
-
-fclose file
- = _casm_ ``%r = fclose((FILE *) %0);'' file
-
-fflush file
- = _casm_ ``%r = fflush((FILE *) %0);'' file
-
-fread :: Int -> Int -> _FILE -> PrimIO (Int, _ByteArray Int)
-
-fread size nitems file
- = let
- barr_end = size * nitems - 1
- in
- newCharArray (0::Int, barr_end){-malloc!?-} `thenStrictlyST` \ barr ->
-
- _ccall_ fread barr size nitems file `thenPrimIO` \ num_read ->
-
- unsafeFreezeByteArray barr `thenStrictlyST` \ frozen ->
-
- returnPrimIO (num_read, frozen)
-
-fwrite :: _ByteArray Int -> Int -> Int -> _FILE -> PrimIO Int
-
-fwrite barr size nitems file
- = _ccall_ fwrite barr size nitems file `thenPrimIO` \ num_written ->
- returnPrimIO num_written
-
---fgetc :: _FILE -> B Char
---fputc :: Char -> _FILE -> B Char
-
--- ===============================================================
-{- LATER
-
--- in Haskell, these are just synonyms for getc and putc
-
-gets :: B [Char]
-fgets :: C_FILE -> Int -> B [Char]
-puts :: [Char] -> B Bool -- ??? ToDo: better error indicator
-fputs :: [Char] -> C_FILE -> B Bool
-
--- getw, putw omitted
-
-feof :: C_FILE -> B Int -- ToDo: Bool?
-ferror :: C_FILE -> B Int -- ToDo: something else?
-fileno :: C_FILE -> B Int
-clearerr :: C_FILE -> B ()
-
-popen :: [Char] -> [Char] -> B C_FILE
-pclose :: C_FILE -> B Int -- exit status
-
-tmpfile :: B C_FILE -- B (Maybe C_FILE) ???
-tmpnam :: [Char] -> B [Char]
-tempnam :: [Char] -> [Char] -> B [Char]
-
-lseek :: C_FileDes -> C_off_t -> Int -> B C_off_t
-
-ctermid :: B [Char]
-cuserid :: B [Char]
-
--- nothing yet:
--- printf
--- fprintf
--- sprintf
--- scanf
--- fscanf
--}
-\end{code}
+++ /dev/null
-\documentstyle[literate]{article}
-\title{Lazy Imperative Programming}
-\begin{document}
-By John Launchbury, though he may not know it.
-
-This code describes {\em sequences}, which are independent state-based
-computations, typically involving (primitive) arrays.
-
-It also includes the basic code for Glasgow I/O, which is similar.
-
-The ``layers'' here are:
-\begin{description}
-\item[Bottom:]
-``World'' types; basic state-transformer monad.
-
-\item[Seq/IO PrimOps:]
-The true-blue primitives wired into the compiler.
-
-\item[Seq (incl arrays...) and IO monads:]
-Built on the above.
-
-\item[Variables:]
-Built on Seq.
-
-\item[PackedStrings:]
-Built on Seq.
-
-\item[DialogueIO:]
-Built on IO.
-
-\item[MainIO:]
-Built on DialogueIO.
-\end{description}
-
-%-----------------------------------------------------
-% "World" types and odd types for returning
-% several primitive things
-\input{PreludeWorld.lhs}
-\input{SemiPrelude.lhs}
-
-%-----------------------------------------------------
-% State transformer monad
-\input{PreludeST.lhs}
-
-%-----------------------------------------------------
-% basic Glasgow IO
-\input{PreludeGlaInOut.lhs}
-\input{PreludeGlaIO.lhs}
-
-%-----------------------------------------------------
-% Seq/array stuff
-\input{PreludeGlaArr.lhs}
-\input{PreludeGlaArray.lhs}
-
-%-----------------------------------------------------
-% Variables
-\input{PreludeVars.lhs}
-
-%-----------------------------------------------------
-% PackedString
-\input{PackedString.lhs}
-
-%-----------------------------------------------------
-% DialogueIO
-\input{PreludeDialogueIO.lhs}
-
-%-----------------------------------------------------
-% MainIO
-\input{MainIO.lhs}
-\end{document}
+++ /dev/null
-%
-% (c) The GRASP/AQUA Project, Glasgow University, 1995
-%
-\section[LibCPUTime]{Haskell 1.3 CPU Time Library}
-
-\begin{code}
-module LibCPUTime where
-
-import PreludeGlaST
-
-getCPUTime :: IO Integer
-getCPUTime =
- newIntArray (0,3) `thenPrimIO` \ marr ->
- unsafeFreezeByteArray marr `thenPrimIO` \ barr@(_ByteArray _ frozen#) ->
- _ccall_ getCPUTime barr `thenPrimIO` \ ptr ->
- if (ptr::_Addr) /= ``NULL'' then
- return (fromInt (I# (indexIntArray# frozen# 0#)) * 1000000000 +
- fromInt (I# (indexIntArray# frozen# 1#)) +
- fromInt (I# (indexIntArray# frozen# 2#)) * 1000000000 +
- fromInt (I# (indexIntArray# frozen# 3#)))
- else
- failWith (UnsupportedOperation "can't get CPU time")
-
-\end{code}
-
-Computation $getCPUTime$ returns the number of nanoseconds CPU time
-used by the current program. The precision of this result is
-implementation-dependent.
-
-
-
-
-
-
+++ /dev/null
-%
-% (c) The GRASP/AQUA Project, Glasgow University, 1995
-%
-\section[LibDirectory]{Haskell 1.3 Directory Operations}
-
-A directory contains a series of entries, each of which is a named
-reference to a file system object (file, directory etc.). Some
-entries may be hidden, inaccessible, or have some administrative
-function (e.g. "." or ".." under POSIX), but in this standard all such
-entries are considered to form part of the directory contents.
-Entries in sub-directories are not, however, considered to form part
-of the directory contents.
-
-Each file system object is referenced by a {\em path}. There is
-normally at least one absolute path to each file system object. In
-some operating systems, it may also be possible to have paths which
-are relative to the current directory.
-
-\begin{code}
-module LibDirectory where
-
-import PreludeIOError
-import PreludeGlaST
-import PS
-
-createDirectory :: FilePath -> IO ()
-createDirectory path =
- _ccall_ createDirectory path `thenPrimIO` \ rc ->
- if rc == 0 then
- return ()
- else
- _constructError `thenPrimIO` \ ioError ->
- failWith ioError
-\end{code}
-
-$createDirectory dir$ creates a new directory
-{\em dir} which is initially empty, or as near to empty as the
-operating system allows.
-
-The operation may fail with:
-\begin{itemize}
-\item $AlreadyExists$
-The operand refers to a directory that already exists.
-[$EEXIST$]
-\item $HardwareFault$
-A physical I/O error has occurred.
-[$EIO$]
-\item $InvalidArgument$
-The operand is not a valid directory name.
-[$ENAMETOOLONG$, $ELOOP$]
-\item $NoSuchThing$
-There is no path to the directory.
-[$ENOENT$, $ENOTDIR$]
-\item $PermissionDenied$
-The process has insufficient privileges to perform the operation.
-[$EROFS$, $EACCES$]
-\item $ResourceExhausted$
-Insufficient resources (virtual memory, process file descriptors,
-physical disk space, etc.) are available to perform the operation.
-[$EDQUOT$, $ENOSPC$, $ENOMEM$,
-$EMLINK$]
-\item $InappropriateType$
-The path refers to an existing non-directory object.
-[$EEXIST$]
-\end{itemize}
-
-
-\begin{code}
-removeDirectory :: FilePath -> IO ()
-removeDirectory path =
- _ccall_ removeDirectory path `thenPrimIO` \ rc ->
- if rc == 0 then
- return ()
- else
- _constructError `thenPrimIO` \ ioError ->
- failWith ioError
-\end{code}
-
-$removeDirectory dir$ removes an existing directory {\em dir}. The
-implementation may specify additional constraints which must be
-satisfied before a directory can be removed (e.g. the directory has to
-be empty, or may not be in use by other processes). It is not legal
-for an implementation to partially remove a directory unless the
-entire directory is removed. A conformant implementation need not
-support directory removal in all situations (e.g. removal of the root
-directory).
-
-The operation may fail with:
-\begin{itemize}
-\item $HardwareFault$
-A physical I/O error has occurred.
-[$EIO$]
-\item $InvalidArgument$
-The operand is not a valid directory name.
-[$ENAMETOOLONG$, $ELOOP$]
-\item $NoSuchThing$
-The directory does not exist.
-[$ENOENT$, $ENOTDIR$]
-\item $PermissionDenied$
-The process has insufficient privileges to perform the operation.
-[$EROFS$, $EACCES$, $EPERM$]
-\item $UnsatisfiedConstraints$
-Implementation-dependent constraints are not satisfied.
-[$EBUSY$, $ENOTEMPTY$, $EEXIST$]
-\item $UnsupportedOperation$
-The implementation does not support removal in this situation.
-[$EINVAL$]
-\item $InappropriateType$
-The operand refers to an existing non-directory object.
-[$ENOTDIR$]
-\end{itemize}
-
-
-\begin{code}
-removeFile :: FilePath -> IO ()
-removeFile path =
- _ccall_ removeFile path `thenPrimIO` \ rc ->
- if rc == 0 then
- return ()
- else
- _constructError `thenPrimIO` \ ioError ->
- failWith ioError
-
-\end{code}
-
-$removeFile file$ removes the directory entry for an existing file
-{\em file}, where {\em file} is not itself a directory. The
-implementation may specify additional constraints which must be
-satisfied before a file can be removed (e.g. the file may not be in
-use by other processes).
-
-The operation may fail with:
-\begin{itemize}
-\item $HardwareFault$
-A physical I/O error has occurred.
-[$EIO$]
-\item $InvalidArgument$
-The operand is not a valid file name.
-[$ENAMETOOLONG$, $ELOOP$]
-\item $NoSuchThing$
-The file does not exist.
-[$ENOENT$, $ENOTDIR$]
-\item $PermissionDenied$
-The process has insufficient privileges to perform the operation.
-[$EROFS$, $EACCES$, $EPERM$]
-\item $UnsatisfiedConstraints$
-Implementation-dependent constraints are not satisfied.
-[$EBUSY$]
-\item $InappropriateType$
-The operand refers to an existing directory.
-[$EPERM$, $EINVAL$]
-\end{itemize}
-
-
-\begin{code}
-renameDirectory :: FilePath -> FilePath -> IO ()
-renameDirectory opath npath =
- _ccall_ renameDirectory opath npath `thenPrimIO` \ rc ->
- if rc == 0 then
- return ()
- else
- _constructError `thenPrimIO` \ ioError ->
- failWith ioError
-\end{code}
-
-$renameDirectory old$ {\em new} changes the name of an existing
-directory from {\em old} to {\em new}. If the {\em new} directory
-already exists, it is atomically replaced by the {\em old} directory.
-If the {\em new} directory is neither the {\em old} directory nor an
-alias of the {\em old} directory, it is removed as if by
-$removeDirectory$. A conformant implementation need not support
-renaming directories in all situations (e.g. renaming to an existing
-directory, or across different physical devices), but the constraints
-must be documented.
-
-The operation may fail with:
-\begin{itemize}
-\item $HardwareFault$
-A physical I/O error has occurred.
-[$EIO$]
-\item $InvalidArgument$
-Either operand is not a valid directory name.
-[$ENAMETOOLONG$, $ELOOP$]
-\item $NoSuchThing$
-The original directory does not exist, or there is no path to the target.
-[$ENOENT$, $ENOTDIR$]
-\item $PermissionDenied$
-The process has insufficient privileges to perform the operation.
-[$EROFS$, $EACCES$, $EPERM$]
-\item $ResourceExhausted$
-Insufficient resources are available to perform the operation.
-[$EDQUOT$, $ENOSPC$, $ENOMEM$,
-$EMLINK$]
-\item $UnsatisfiedConstraints$
-Implementation-dependent constraints are not satisfied.
-[$EBUSY$, $ENOTEMPTY$, $EEXIST$]
-\item $UnsupportedOperation$
-The implementation does not support renaming in this situation.
-[$EINVAL$, $EXDEV$]
-\item $InappropriateType$
-Either path refers to an existing non-directory object.
-[$ENOTDIR$, $EISDIR$]
-\end{itemize}
-
-
-\begin{code}
-renameFile :: FilePath -> FilePath -> IO ()
-renameFile opath npath =
- _ccall_ renameFile opath npath `thenPrimIO` \ rc ->
- if rc == 0 then
- return ()
- else
- _constructError `thenPrimIO` \ ioError ->
- failWith ioError
-\end{code}
-
-$renameFile old$ {\em new} changes the name of an existing file system
-object from {\em old} to {\em new}. If the {\em new} object already
-exists, it is atomically replaced by the {\em old} object. Neither
-path may refer to an existing directory. A conformant implementation
-need not support renaming files in all situations (e.g. renaming
-across different physical devices), but the constraints must be
-documented.
-
-The operation may fail with:
-\begin{itemize}
-\item $HardwareFault$
-A physical I/O error has occurred.
-[$EIO$]
-\item $InvalidArgument$
-Either operand is not a valid file name.
-[$ENAMETOOLONG$, $ELOOP$]
-\item $NoSuchThing$
-The original file does not exist, or there is no path to the target.
-[$ENOENT$, $ENOTDIR$]
-\item $PermissionDenied$
-The process has insufficient privileges to perform the operation.
-[$EROFS$, $EACCES$, $EPERM$]
-\item $ResourceExhausted$
-Insufficient resources are available to perform the operation.
-[$EDQUOT$, $ENOSPC$, $ENOMEM$,
-$EMLINK$]
-\item $UnsatisfiedConstraints$
-Implementation-dependent constraints are not satisfied.
-[$EBUSY$]
-\item $UnsupportedOperation$
-The implementation does not support renaming in this situation.
-[$EXDEV$]
-\item $InappropriateType$
-Either path refers to an existing directory.
-[$ENOTDIR$, $EISDIR$, $EINVAL$,
-$EEXIST$, $ENOTEMPTY$]
-\end{itemize}
-
-
-\begin{code}
-getDirectoryContents :: FilePath -> IO [FilePath]
-getDirectoryContents path =
- _ccall_ getDirectoryContents path `thenPrimIO` \ ptr ->
- getEntries ptr 0 `thenPrimIO` \ entries ->
- _ccall_ free ptr `thenPrimIO` \ () ->
- return entries
- where
- getEntries :: _Addr -> Int -> PrimIO [FilePath]
- getEntries ptr n =
- _casm_ ``%r = ((char **)%0)[%1];'' ptr n `thenPrimIO` \ str ->
- if str == ``NULL'' then
- returnPrimIO []
- else
- _ccall_ strlen str `thenPrimIO` \ len ->
- _packCBytesST len str `thenStrictlyST` \ entry ->
- _ccall_ free str `thenPrimIO` \ () ->
- getEntries ptr (n+1) `thenPrimIO` \ entries ->
- returnPrimIO (_unpackPS entry : entries)
-
-\end{code}
-
-$getDirectoryContents dir$ returns a list of
-<i>all</i> entries in {\em dir}.
-
-The operation may fail with:
-\begin{itemize}
-\item $HardwareFault$
-A physical I/O error has occurred.
-[$EIO$]
-\item $InvalidArgument$
-The operand is not a valid directory name.
-[$ENAMETOOLONG$, $ELOOP$]
-\item $NoSuchThing$
-The directory does not exist.
-[$ENOENT$, $ENOTDIR$]
-\item $PermissionDenied$
-The process has insufficient privileges to perform the operation.
-[$EACCES$]
-\item $ResourceExhausted$
-Insufficient resources are available to perform the operation.
-[$EMFILE$, $ENFILE$]
-\item $InappropriateType$
-The path refers to an existing non-directory object.
-[$ENOTDIR$]
-\end{itemize}
-
-
-\begin{code}
-getCurrentDirectory :: IO FilePath
-getCurrentDirectory =
- _ccall_ getCurrentDirectory `thenPrimIO` \ str ->
- if str /= ``NULL'' then
- _ccall_ strlen str `thenPrimIO` \ len ->
- _packCBytesST len str `thenStrictlyST` \ pwd ->
- _ccall_ free str `thenPrimIO` \ () ->
- return (_unpackPS pwd)
- else
- _constructError `thenPrimIO` \ ioError ->
- failWith ioError
-\end{code}
-
-If the operating system has a notion of current directories,
-$getCurrentDirectory$ returns an absolute path to the
-current directory of the calling process.
-
-The operation may fail with:
-\begin{itemize}
-\item $HardwareFault$
-A physical I/O error has occurred.
-[$EIO$]
-\item $NoSuchThing$
-There is no path referring to the current directory.
-[$EPERM$, $ENOENT$, $ESTALE$...]
-\item $PermissionDenied$
-The process has insufficient privileges to perform the operation.
-[$EACCES$]
-\item $ResourceExhausted$
-Insufficient resources are available to perform the operation.
-\item $UnsupportedOperation$
-The operating system has no notion of current directory.
-\end{itemize}
-
-
-\begin{code}
-setCurrentDirectory :: FilePath -> IO ()
-setCurrentDirectory path =
- _ccall_ setCurrentDirectory path `thenPrimIO` \ rc ->
- if rc == 0 then
- return ()
- else
- _constructError `thenPrimIO` \ ioError ->
- failWith ioError
-\end{code}
-
-If the operating system has a notion of current directories,
-$setCurrentDirectory dir$ changes the current
-directory of the calling process to {\em dir}.
-
-The operation may fail with:
-\begin{itemize}
-\item $HardwareFault$
-A physical I/O error has occurred.
-[$EIO$]
-\item $InvalidArgument$
-The operand is not a valid directory name.
-[$ENAMETOOLONG$, $ELOOP$]
-\item $NoSuchThing$
-The directory does not exist.
-[$ENOENT$, $ENOTDIR$]
-\item $PermissionDenied$
-The process has insufficient privileges to perform the operation.
-[$EACCES$]
-\item $UnsupportedOperation$
-The operating system has no notion of current directory, or the
-current directory cannot be dynamically changed.
-\item $InappropriateType$
-The path refers to an existing non-directory object.
-[$ENOTDIR$]
-\end{itemize}
-
+++ /dev/null
-%
-% (c) The GRASP/AQUA Project, Glasgow University, 1995
-%
-\section[LibPosix]{Haskell 1.3 POSIX bindings}
-
-\begin{code}
-module LibPosix (
- LibPosixDB..,
- LibPosixErr..,
- LibPosixFiles..,
- LibPosixIO..,
- LibPosixProcEnv..,
- LibPosixProcPrim..,
- LibPosixTTY..,
-
- runProcess,
-
- ByteCount(..),
- Channel(..),
- ClockTick(..),
- EpochTime(..),
- FileOffset(..),
- GroupID(..),
- Limit(..),
- LinkCount(..),
- ProcessID(..),
- ProcessGroupID(..),
- UserID(..),
-
- ExitCode,
-
- -- make interface complete:
- setCurrentDirectory{-pragmas-}, getCurrentDirectory{-pragmas-}
-
- ) where
-
-import LibPosixDB
-import LibPosixErr
-import LibPosixFiles
-import LibPosixIO
-import LibPosixProcEnv
-import LibPosixProcPrim
-import LibPosixTTY
-import LibPosixUtil
-
--- runProcess is our candidate for the high-level OS-independent primitive
--- If accepted, it will be moved out of LibPosix into LibSystem.
-
-import LibDirectory ( setCurrentDirectory, getCurrentDirectory{-pragmas-} )
-
-import PreludeGlaST
-import PreludePrimIO ( takeMVar, putMVar, _MVar )
-import PreludeStdIO
-
-runProcess :: FilePath -- Command
- -> [String] -- Arguments
- -> Maybe [(String, String)] -- Environment
- -> Maybe FilePath -- Working directory
- -> Maybe Handle -- stdin
- -> Maybe Handle -- stdout
- -> Maybe Handle -- stderr
- -> IO ()
-runProcess path args env dir stdin stdout stderr =
- forkProcess >>= \ pid ->
- case pid of
- Nothing -> doTheBusiness
- Just x -> return ()
- where
- doTheBusiness :: IO ()
- doTheBusiness =
- maybeChangeWorkingDirectory >>
- maybeDup2 0 stdin >>
- maybeDup2 1 stdout >>
- maybeDup2 2 stderr >>
- executeFile path True args env >>
- syserr "runProcess"
-
- maybeChangeWorkingDirectory :: IO ()
- maybeChangeWorkingDirectory =
- case dir of
- Nothing -> return ()
- Just x -> setCurrentDirectory x
-
- maybeDup2 :: Int -> Maybe Handle -> IO ()
- maybeDup2 dest h =
- case h of Nothing -> return ()
- Just x -> handleFD x >>= \ src ->
- dupChannelTo src dest >>
- return ()
-
- handleFD :: Handle -> IO Channel
- handleFD handle =
- takeMVar handle >>= \ htype ->
- putMVar handle htype >>
- case htype of
- _ErrorHandle ioError -> failWith ioError
- _ClosedHandle -> failWith (IllegalOperation "handle is closed")
- _SemiClosedHandle _ _ -> failWith (IllegalOperation "handle is closed")
- other ->
- _casm_ ``%r = fileno((FILE *)%0);'' (_filePtr other)
- `thenPrimIO` \ fd ->
- return fd
-
-\end{code}
+++ /dev/null
-%
-% (c) The GRASP/AQUA Project, Glasgow University, 1995
-%
-\section[LibPosixDB]{Haskell 1.3 POSIX System Databases}
-
-\begin{code}
-module LibPosixDB (
- GroupEntry,
- UserEntry,
-
- getGroupEntryForID,
- getGroupEntryForName,
- getUserEntryForID,
- getUserEntryForName,
- groupID,
- groupMembers,
- groupName,
- homeDirectory,
- userGroupID,
- userID,
- userName,
- userShell
- ) where
-
-import PreludeGlaST
-import PS
-
-import LibPosixUtil
-
-data GroupEntry = GE String GroupID [String]
-
-groupName :: GroupEntry -> String
-groupName (GE name _ _) = name
-
-groupID :: GroupEntry -> GroupID
-groupID (GE _ gid _) = gid
-
-groupMembers :: GroupEntry -> [String]
-groupMembers (GE _ _ members) = members
-
-getGroupEntryForID :: GroupID -> IO GroupEntry
-getGroupEntryForID gid =
- _ccall_ getgrgid gid `thenPrimIO` \ ptr ->
- if ptr == ``NULL'' then
- failWith (NoSuchThing "no such group entry")
- else
- unpackGroupEntry ptr `thenPrimIO` \ group ->
- return group
-
-getGroupEntryForName :: String -> IO GroupEntry
-getGroupEntryForName name =
- _packBytesForCST name `thenStrictlyST` \ gname ->
- _ccall_ getgrnam gname `thenPrimIO` \ ptr ->
- if ptr == ``NULL'' then
- failWith (NoSuchThing "no such group entry")
- else
- unpackGroupEntry ptr `thenPrimIO` \ group ->
- return group
-
-data UserEntry = UE String UserID GroupID String String
-
-userName :: UserEntry -> String
-userName (UE name _ _ _ _) = name
-
-userID :: UserEntry -> UserID
-userID (UE _ uid _ _ _) = uid
-
-userGroupID :: UserEntry -> GroupID
-userGroupID (UE _ _ gid _ _) = gid
-
-homeDirectory :: UserEntry -> String
-homeDirectory (UE _ _ _ home _) = home
-
-userShell :: UserEntry -> String
-userShell (UE _ _ _ _ shell) = shell
-
-getUserEntryForID :: UserID -> IO UserEntry
-getUserEntryForID uid =
- _ccall_ getpwuid uid `thenPrimIO` \ ptr ->
- if ptr == ``NULL'' then
- failWith (NoSuchThing "no such user entry")
- else
- unpackUserEntry ptr `thenPrimIO` \ user ->
- return user
-
-getUserEntryForName :: String -> IO UserEntry
-getUserEntryForName name =
- _packBytesForCST name `thenStrictlyST` \ uname ->
- _ccall_ getpwnam uname `thenPrimIO` \ ptr ->
- if ptr == ``NULL'' then
- failWith (NoSuchThing "no such user entry")
- else
- unpackUserEntry ptr `thenPrimIO` \ user ->
- return user
-
-\end{code}
-
-Local utility functions
-
-\begin{code}
-
--- Copy the static structure returned by getgr* into a Haskell structure
-
-unpackGroupEntry :: _Addr -> PrimIO GroupEntry
-unpackGroupEntry ptr =
- _casm_ ``%r = ((struct group *)%0)->gr_name;'' ptr
- `thenPrimIO` \ str ->
- strcpy str `thenPrimIO` \ name ->
- _casm_ ``%r = ((struct group *)%0)->gr_gid;'' ptr
- `thenPrimIO` \ gid ->
- _casm_ ``%r = ((struct group *)%0)->gr_mem;'' ptr
- `thenPrimIO` \ mem ->
- unvectorize mem 0 `thenStrictlyST` \ members ->
- returnPrimIO (GE name gid members)
-
--- Copy the static structure returned by getpw* into a Haskell structure
-
-unpackUserEntry :: _Addr -> PrimIO UserEntry
-unpackUserEntry ptr =
- _casm_ ``%r = ((struct passwd *)%0)->pw_name;'' ptr
- `thenPrimIO` \ str ->
- strcpy str `thenPrimIO` \ name ->
- _casm_ ``%r = ((struct passwd *)%0)->pw_uid;'' ptr
- `thenPrimIO` \ uid ->
- _casm_ ``%r = ((struct passwd *)%0)->pw_gid;'' ptr
- `thenPrimIO` \ gid ->
- _casm_ ``%r = ((struct passwd *)%0)->pw_dir;'' ptr
- `thenPrimIO` \ str ->
- strcpy str `thenPrimIO` \ home ->
- _casm_ ``%r = ((struct passwd *)%0)->pw_shell;'' ptr
- `thenPrimIO` \ str ->
- strcpy str `thenPrimIO` \ shell ->
- returnPrimIO (UE name uid gid home shell)
-
-\end{code}
+++ /dev/null
-%
-% (c) The GRASP/AQUA Project, Glasgow University, 1995
-%
-\section[LibPosixErr]{Haskell 1.3 POSIX Error Codes}
-
-\begin{code}
-module LibPosixErr
-where
-
-import PreludeGlaST
-
-type ErrorCode = Int
-
-getErrorCode :: IO ErrorCode
-getErrorCode =
- _casm_ ``%r = errno;'' `thenPrimIO` \ errno ->
- return errno
-
-setErrorCode :: ErrorCode -> IO ()
-setErrorCode errno =
- _casm_ ``errno = %0;'' errno `thenPrimIO` \ () ->
- return ()
-
-noError :: ErrorCode
-noError = 0
-
-argumentListTooLong, e2BIG :: ErrorCode
-argumentListTooLong = ``E2BIG''
-e2BIG = ``E2BIG''
-
-badChannel, eBADF :: ErrorCode
-badChannel = ``EBADF''
-eBADF = ``EBADF''
-
-brokenPipe, ePIPE :: ErrorCode
-brokenPipe = ``EPIPE''
-ePIPE = ``EPIPE''
-
-directoryNotEmpty, eNOTEMPTY :: ErrorCode
-directoryNotEmpty = ``ENOTEMPTY''
-eNOTEMPTY = ``ENOTEMPTY''
-
-execFormatError, eNOEXEC :: ErrorCode
-execFormatError = ``ENOEXEC''
-eNOEXEC = ``ENOEXEC''
-
-fileAlreadyExists, eEXIST :: ErrorCode
-fileAlreadyExists = ``EEXIST''
-eEXIST = ``EEXIST''
-
-fileTooLarge, eFBIG :: ErrorCode
-fileTooLarge = ``EFBIG''
-eFBIG = ``EFBIG''
-
-filenameTooLong, eNAMETOOLONG :: ErrorCode
-filenameTooLong = ``ENAMETOOLONG''
-eNAMETOOLONG = ``ENAMETOOLONG''
-
-improperLink, eXDEV :: ErrorCode
-improperLink = ``EXDEV''
-eXDEV = ``EXDEV''
-
-inappropriateIOControlOperation, eNOTTY :: ErrorCode
-inappropriateIOControlOperation = ``ENOTTY''
-eNOTTY = ``ENOTTY''
-
-inputOutputError, eIO :: ErrorCode
-inputOutputError = ``EIO''
-eIO = ``EIO''
-
-interruptedOperation, eINTR :: ErrorCode
-interruptedOperation = ``EINTR''
-eINTR = ``EINTR''
-
-invalidArgument, eINVAL :: ErrorCode
-invalidArgument = ``EINVAL''
-eINVAL = ``EINVAL''
-
-invalidSeek, eSPIPE :: ErrorCode
-invalidSeek = ``ESPIPE''
-eSPIPE = ``ESPIPE''
-
-isADirectory, eISDIR :: ErrorCode
-isADirectory = ``EISDIR''
-eISDIR = ``EISDIR''
-
-noChildProcess, eCHILD :: ErrorCode
-noChildProcess = ``ECHILD''
-eCHILD = ``ECHILD''
-
-noLocksAvailable, eNOLCK :: ErrorCode
-noLocksAvailable = ``ENOLCK''
-eNOLCK = ``ENOLCK''
-
-noSpaceLeftOnDevice, eNOSPC :: ErrorCode
-noSpaceLeftOnDevice = ``ENOSPC''
-eNOSPC = ``ENOSPC''
-
-noSuchOperationOnDevice, eNODEV :: ErrorCode
-noSuchOperationOnDevice = ``ENODEV''
-eNODEV = ``ENODEV''
-
-noSuchDeviceOrAddress, eNXIO :: ErrorCode
-noSuchDeviceOrAddress = ``ENXIO''
-eNXIO = ``ENXIO''
-
-noSuchFileOrDirectory, eNOENT :: ErrorCode
-noSuchFileOrDirectory = ``ENOENT''
-eNOENT = ``ENOENT''
-
-noSuchProcess, eSRCH :: ErrorCode
-noSuchProcess = ``ESRCH''
-eSRCH = ``ESRCH''
-
-notADirectory, eNOTDIR :: ErrorCode
-notADirectory = ``ENOTDIR''
-eNOTDIR = ``ENOTDIR''
-
-notEnoughMemory, eNOMEM :: ErrorCode
-notEnoughMemory = ``ENOMEM''
-eNOMEM = ``ENOMEM''
-
-operationNotImplemented, eNOSYS :: ErrorCode
-operationNotImplemented = ``ENOSYS''
-eNOSYS = ``ENOSYS''
-
-operationNotPermitted, ePERM :: ErrorCode
-operationNotPermitted = ``EPERM''
-ePERM = ``EPERM''
-
-permissionDenied, eACCES :: ErrorCode
-permissionDenied = ``EACCES''
-eACCES = ``EACCES''
-
-readOnlyFileSystem, eROFS :: ErrorCode
-readOnlyFileSystem = ``EROFS''
-eROFS = ``EROFS''
-
-resourceBusy, eBUSY :: ErrorCode
-resourceBusy = ``EBUSY''
-eBUSY = ``EBUSY''
-
-resourceDeadlockAvoided, eDEADLK :: ErrorCode
-resourceDeadlockAvoided = ``EDEADLK''
-eDEADLK = ``EDEADLK''
-
-resourceTemporarilyUnavailable, eAGAIN :: ErrorCode
-resourceTemporarilyUnavailable = ``EAGAIN''
-eAGAIN = ``EAGAIN''
-
-tooManyLinks, eMLINK :: ErrorCode
-tooManyLinks = ``EMLINK''
-eMLINK = ``EMLINK''
-
-tooManyOpenFiles, eMFILE :: ErrorCode
-tooManyOpenFiles = ``EMFILE''
-eMFILE = ``EMFILE''
-
-tooManyOpenFilesInSystem, eNFILE :: ErrorCode
-tooManyOpenFilesInSystem = ``ENFILE''
-eNFILE = ``ENFILE''
-
-\end{code}
-
+++ /dev/null
-%
-% (c) The GRASP/AQUA Project, Glasgow University, 1995
-%
-\section[LibPosixFiles]{Haskell 1.3 POSIX File and Directory Operations}
-
-\begin{code}
-module LibPosixFiles (
- DeviceID(..),
- DirStream(..),
- FileID(..),
- FileMode(..),
- FileStatus(..),
- OpenMode(..),
- PathVar(..),
-
- accessModes,
- accessTime,
- changeWorkingDirectory, -- Too much like LibDirectory thing?
- closeDirStream,
- createDirectory, -- Too much like LibDirectory thing?
- createFile,
- createLink,
- createNamedPipe,
- deviceID,
- fileGroup,
- fileID,
- fileMode,
- fileOwner,
- fileSize,
- getChannelStatus,
- getChannelVar,
- getFileStatus,
- getPathVar,
- getWorkingDirectory, -- Too much like LibDirectory thing?
- groupExecuteMode,
- groupModes,
- groupReadMode,
- groupWriteMode,
- intersectFileModes,
- isBlockDevice,
- isCharacterDevice,
- isDirectory,
- isNamedPipe,
- isRegularFile,
- linkCount,
- modificationTime,
- nullFileMode,
- openDirStream,
- openChannel,
- otherExecuteMode,
- otherModes,
- otherReadMode,
- otherWriteMode,
- ownerExecuteMode,
- ownerModes,
- ownerReadMode,
- ownerWriteMode,
- queryAccess,
- queryFile,
- readDirStream,
- removeDirectory, -- Too much like LibDirectory thing
- removeLink,
- rename,
- rewindDirStream,
- setFileCreationMask,
- setFileTimes,
- setGroupIDMode,
- setOwnerAndGroup,
- setFileMode,
- setUserIDMode,
- stdError,
- stdFileMode,
- stdInput,
- stdOutput,
- statusChangeTime,
- touchFile,
- unionFileModes
- ) where
-
-import PreludeGlaST
-import PS
-
-import LibPosixErr
-import LibPosixUtil
-
-import LibDirectory ( removeDirectory, -- re-use its code
- getCurrentDirectory,
- setCurrentDirectory
- )
-
-type DirStream = _Addr
-
-openDirStream :: FilePath -> IO DirStream
-openDirStream name =
- _packBytesForCST name `thenStrictlyST` \ dir ->
- _ccall_ opendir dir `thenPrimIO` \ dirp ->
- if dirp /= ``NULL'' then
- return dirp
- else
- syserr "openDirStream"
-
-readDirStream :: DirStream -> IO String
-readDirStream dirp =
- setErrorCode noError >>
- _ccall_ readdir dirp `thenPrimIO` \ dirent ->
- if dirent /= (``NULL''::_Addr) then
- _casm_ ``%r = ((struct dirent *)%0)->d_name;'' dirent
- `thenPrimIO` \ str ->
- strcpy str `thenPrimIO` \ name ->
- return name
- else
- getErrorCode >>= \ errno ->
- if errno == noError then
- failWith EOF
- else
- syserr "readDirStream"
-
-rewindDirStream :: DirStream -> IO ()
-rewindDirStream dirp =
- _ccall_ rewinddir dirp `thenPrimIO` \ () ->
- return ()
-
-closeDirStream :: DirStream -> IO ()
-closeDirStream dirp =
- _ccall_ closedir dirp `thenPrimIO` \ rc ->
- if rc == 0 then
- return ()
- else
- syserr "closeDirStream"
-
-getWorkingDirectory :: IO FilePath
-getWorkingDirectory = getCurrentDirectory{-LibDirectory-}
-{- OLD:
- _ccall_ getCurrentDirectory `thenPrimIO` \ str ->
- if str /= ``NULL'' then
- strcpy str `thenPrimIO` \ pwd ->
- _ccall_ free str `thenPrimIO` \ () ->
- return pwd
- else
- syserr "getWorkingDirectory"
--}
-
-changeWorkingDirectory :: FilePath -> IO ()
-changeWorkingDirectory name = setCurrentDirectory{-LibDirectory-} name
-{- OLD:
- _packBytesForCST name `thenStrictlyST` \ dir ->
- _ccall_ chdir dir `thenPrimIO` \ rc ->
- if rc == 0 then
- return ()
- else
- syserr "changeWorkingDirectory"
--}
-
-type FileMode = _Word
-
-nullFileMode :: FileMode
-nullFileMode = ``0''
-
-ownerReadMode :: FileMode
-ownerReadMode = ``S_IRUSR''
-
-ownerWriteMode :: FileMode
-ownerWriteMode = ``S_IWUSR''
-
-ownerExecuteMode :: FileMode
-ownerExecuteMode = ``S_IXUSR''
-
-groupReadMode :: FileMode
-groupReadMode = ``S_IRGRP''
-
-groupWriteMode :: FileMode
-groupWriteMode = ``S_IWGRP''
-
-groupExecuteMode :: FileMode
-groupExecuteMode = ``S_IXGRP''
-
-otherReadMode :: FileMode
-otherReadMode = ``S_IROTH''
-
-otherWriteMode :: FileMode
-otherWriteMode = ``S_IWOTH''
-
-otherExecuteMode :: FileMode
-otherExecuteMode = ``S_IXOTH''
-
-setUserIDMode :: FileMode
-setUserIDMode = ``S_ISUID''
-
-setGroupIDMode :: FileMode
-setGroupIDMode = ``S_ISGID''
-
-stdFileMode :: FileMode
-stdFileMode = ``(S_IRUSR|S_IWUSR|S_IRGRP|S_IWGRP|S_IROTH|S_IWOTH)''
-
-ownerModes :: FileMode
-ownerModes = ``S_IRWXU''
-
-groupModes :: FileMode
-groupModes = ``S_IRWXG''
-
-otherModes :: FileMode
-otherModes = ``S_IRWXO''
-
-accessModes :: FileMode
-accessModes = ``(S_IRWXU|S_IRWXG|S_IRWXO)''
-
-unionFileModes :: FileMode -> FileMode -> FileMode
-unionFileModes (W# m1#) (W# m2#) = W# (m1# `or#` m2#)
-
-intersectFileModes :: FileMode -> FileMode -> FileMode
-intersectFileModes (W# m1#) (W# m2#) = W# (m1# `and#` m2#)
-
-stdInput :: Channel
-stdInput = 0
-
-stdOutput :: Channel
-stdOutput = 1
-
-stdError :: Channel
-stdError = 2
-
-data OpenMode = ReadOnly
- | WriteOnly
- | ReadWrite
-
-openChannel :: FilePath
- -> OpenMode
- -> Maybe FileMode -- Just x => O_CREAT, Nothing => must exist
- -> Bool -- O_APPEND
- -> Bool -- O_EXCL
- -> Bool -- O_NOCTTY
- -> Bool -- O_NONBLOCK
- -> Bool -- O_TRUNC
- -> IO Channel
-openChannel name how maybe_mode append excl noctty nonblock trunc =
- _packBytesForCST name `thenStrictlyST` \ file ->
- _ccall_ open file flags mode `thenPrimIO` \ fd ->
- if fd /= -1 then
- return fd
- else
- syserr "openChannel"
- where
- mode, creat :: FileMode
- mode = case maybe_mode of { Nothing -> ``0'' ; Just x -> x }
-
- creat = case maybe_mode of { Nothing -> ``0'' ; Just _ -> ``O_CREAT'' }
- creat# = case creat of { W# x -> x }
-
- flags = W# (creat# `or#` append# `or#` excl# `or#`
- noctty# `or#` nonblock# `or#` trunc# `or#` how#)
- how# = case (case how of { ReadOnly -> ``O_RDONLY'';WriteOnly -> ``O_WRONLY'';ReadWrite -> ``O_RDWR''}) of { W# x -> x }
- append# = case (if append then ``O_APPEND'' else ``0'') of { W# x -> x }
- excl# = case (if excl then ``O_EXCL'' else ``0'') of { W# x -> x }
- noctty# = case (if noctty then ``O_NOCTTY'' else ``0'') of { W# x -> x }
- nonblock# = case (if nonblock then ``O_NONBLOCK'' else ``0'') of { W# x -> x }
- trunc# = case (if trunc then ``O_TRUNC'' else ``0'') of { W# x -> x }
-
-createFile :: FilePath -> FileMode -> IO Channel
-createFile name mode =
- _packBytesForCST name `thenStrictlyST` \ file ->
- _ccall_ creat file mode `thenPrimIO` \ fd ->
- if fd /= -1 then
- return fd
- else
- syserr "createFile"
-
-setFileCreationMask :: FileMode -> IO FileMode
-setFileCreationMask mask =
- _ccall_ umask mask `thenPrimIO` \ omask ->
- return omask
-
-createLink :: FilePath -> FilePath -> IO ()
-createLink name1 name2 =
- _packBytesForCST name1 `thenStrictlyST` \ path1 ->
- _packBytesForCST name2 `thenStrictlyST` \ path2 ->
- _ccall_ link path1 path2 `thenPrimIO` \ rc ->
- if rc == 0 then
- return ()
- else
- syserr "createLink"
-
-createDirectory :: FilePath -> FileMode -> IO ()
-createDirectory name mode = -- NB: diff signature from LibDirectory one!
- _packBytesForCST name `thenStrictlyST` \ dir ->
- _ccall_ mkdir dir mode `thenPrimIO` \ rc ->
- if rc == 0 then
- return ()
- else
- syserr "createDirectory"
-
-createNamedPipe :: FilePath -> FileMode -> IO ()
-createNamedPipe name mode =
- _packBytesForCST name `thenStrictlyST` \ pipe ->
- _ccall_ mkfifo pipe mode `thenPrimIO` \ rc ->
- if rc == 0 then
- return ()
- else
- syserr "createNamedPipe"
-
-removeLink :: FilePath -> IO ()
-removeLink name =
- _packBytesForCST name `thenStrictlyST` \ path ->
- _ccall_ unlink path `thenPrimIO` \ rc ->
- if rc == 0 then
- return ()
- else
- syserr "removeLink"
-
-{- USE LibDirectory ONE:
-removeDirectory :: FilePath -> IO ()
-removeDirectory name =
- _packBytesForCST name `thenStrictlyST` \ dir ->
- _ccall_ rmdir dir `thenPrimIO` \ rc ->
- if rc == 0 then
- return ()
- else
- syserr "removeDirectory"
--}
-
-rename :: FilePath -> FilePath -> IO ()
-rename name1 name2 =
- _packBytesForCST name1 `thenStrictlyST` \ path1 ->
- _packBytesForCST name2 `thenStrictlyST` \ path2 ->
- _ccall_ rename path1 path2 `thenPrimIO` \ rc ->
- if rc == 0 then
- return ()
- else
- syserr "rename"
-
-type FileStatus = _ByteArray ()
-type FileID = Int
-type DeviceID = Int
-
-fileMode :: FileStatus -> FileMode
-fileMode stat = unsafePerformPrimIO (
- _casm_ ``%r = ((struct stat *)%0)->st_mode;'' stat
- `thenStrictlyST` \ mode ->
- returnPrimIO mode)
-
-fileID :: FileStatus -> FileID
-fileID stat = unsafePerformPrimIO (
- _casm_ ``%r = ((struct stat *)%0)->st_ino;'' stat
- `thenStrictlyST` \ ino ->
- returnPrimIO ino)
-
-deviceID :: FileStatus -> DeviceID
-deviceID stat = unsafePerformPrimIO (
- _casm_ ``%r = ((struct stat *)%0)->st_dev;'' stat
- `thenStrictlyST` \ dev ->
- returnPrimIO dev)
-
-linkCount :: FileStatus -> LinkCount
-linkCount stat = unsafePerformPrimIO (
- _casm_ ``%r = ((struct stat *)%0)->st_nlink;'' stat
- `thenStrictlyST` \ nlink ->
- returnPrimIO nlink)
-
-fileOwner :: FileStatus -> UserID
-fileOwner stat = unsafePerformPrimIO (
- _casm_ ``%r = ((struct stat *)%0)->st_uid;'' stat
- `thenStrictlyST` \ uid ->
- returnPrimIO uid)
-
-fileGroup :: FileStatus -> GroupID
-fileGroup stat = unsafePerformPrimIO (
- _casm_ ``%r = ((struct stat *)%0)->st_gid;'' stat
- `thenStrictlyST` \ gid ->
- returnPrimIO gid)
-
-fileSize :: FileStatus -> FileOffset
-fileSize stat = unsafePerformPrimIO (
- _casm_ ``%r = ((struct stat *)%0)->st_size;'' stat
- `thenStrictlyST` \ size ->
- returnPrimIO size)
-
-accessTime :: FileStatus -> EpochTime
-accessTime stat = unsafePerformPrimIO (
- _casm_ ``%r = ((struct stat *)%0)->st_atime;'' stat
- `thenStrictlyST` \ atime ->
- returnPrimIO atime)
-
-modificationTime :: FileStatus -> EpochTime
-modificationTime stat = unsafePerformPrimIO (
- _casm_ ``%r = ((struct stat *)%0)->st_mtime;'' stat
- `thenStrictlyST` \ mtime ->
- returnPrimIO mtime)
-
-statusChangeTime :: FileStatus -> EpochTime
-statusChangeTime stat = unsafePerformPrimIO (
- _casm_ ``%r = ((struct stat *)%0)->st_ctime;'' stat
- `thenStrictlyST` \ ctime ->
- returnPrimIO ctime)
-
-isDirectory :: FileStatus -> Bool
-isDirectory stat = unsafePerformPrimIO (
- _casm_ ``%r = S_ISDIR(((struct stat *)%0)->st_mode);'' stat
- `thenStrictlyST` \ rc ->
- returnPrimIO (rc /= 0))
-
-isCharacterDevice :: FileStatus -> Bool
-isCharacterDevice stat = unsafePerformPrimIO (
- _casm_ ``%r = S_ISCHR(((struct stat *)%0)->st_mode);'' stat
- `thenStrictlyST` \ rc ->
- returnPrimIO (rc /= 0))
-
-isBlockDevice :: FileStatus -> Bool
-isBlockDevice stat = unsafePerformPrimIO (
- _casm_ ``%r = S_ISBLK(((struct stat *)%0)->st_mode);'' stat
- `thenStrictlyST` \ rc ->
- returnPrimIO (rc /= 0))
-
-isRegularFile :: FileStatus -> Bool
-isRegularFile stat = unsafePerformPrimIO (
- _casm_ ``%r = S_ISREG(((struct stat *)%0)->st_mode);'' stat
- `thenStrictlyST` \ rc ->
- returnPrimIO (rc /= 0))
-
-isNamedPipe :: FileStatus -> Bool
-isNamedPipe stat = unsafePerformPrimIO (
- _casm_ ``%r = S_ISFIFO(((struct stat *)%0)->st_mode);'' stat
- `thenStrictlyST` \ rc ->
- returnPrimIO (rc /= 0))
-
-getFileStatus :: FilePath -> IO FileStatus
-getFileStatus name =
- _packBytesForCST name `thenStrictlyST` \ path ->
- allocChars ``sizeof(struct stat)'' `thenStrictlyST` \ bytes ->
- _casm_ ``%r = stat(%0,(struct stat *)%1);'' path bytes
- `thenPrimIO` \ rc ->
- if rc == 0 then
- freeze bytes `thenStrictlyST` \ stat ->
- return stat
- else
- syserr "getFileStatus"
-
-getChannelStatus :: Channel -> IO FileStatus
-getChannelStatus fd =
- allocChars ``sizeof(struct stat)'' `thenStrictlyST` \ bytes ->
- _casm_ ``%r = fstat(%0,(struct stat *)%1);'' fd bytes
- `thenPrimIO` \ rc ->
- if rc == 0 then
- freeze bytes `thenStrictlyST` \ stat ->
- return stat
- else
- syserr "getChannelStatus"
-
-queryAccess :: FilePath -> Bool -> Bool -> Bool -> IO Bool
-queryAccess name read write exec =
- _packBytesForCST name `thenStrictlyST` \ path ->
- _ccall_ access path flags `thenPrimIO` \ rc ->
- return (rc == 0)
- where
- flags = I# (word2Int# (read# `or#` write# `or#` exec#))
- read# = case (if read then ``R_OK'' else ``0'') of { W# x -> x }
- write# = case (if write then ``W_OK'' else ``0'') of { W# x -> x }
- exec# = case (if exec then ``X_OK'' else ``0'') of { W# x -> x }
-
-queryFile :: FilePath -> IO Bool
-queryFile name =
- _packBytesForCST name `thenStrictlyST` \ path ->
- _ccall_ access path (``F_OK''::Int) `thenPrimIO` \ rc ->
- return (rc == 0)
-
-setFileMode :: FilePath -> FileMode -> IO ()
-setFileMode name mode =
- _packBytesForCST name `thenStrictlyST` \ path ->
- _ccall_ chmod path mode `thenPrimIO` \ rc ->
- if rc == 0 then
- return ()
- else
- syserr "setFileMode"
-
-setOwnerAndGroup :: FilePath -> UserID -> GroupID -> IO ()
-setOwnerAndGroup name uid gid =
- _packBytesForCST name `thenStrictlyST` \ path ->
- _ccall_ chown path uid gid `thenPrimIO` \ rc ->
- if rc == 0 then
- return ()
- else
- syserr "setOwnerAndGroup"
-
-setFileTimes :: FilePath -> EpochTime -> EpochTime -> IO ()
-setFileTimes name atime mtime =
- _packBytesForCST name `thenStrictlyST` \ path ->
- _casm_ ``do {struct utimbuf ub; ub.actime = (time_t) %0; ub.modtime = (time_t) %1;
- %r = utime(%2, &ub);} while(0);'' atime mtime path
- `thenPrimIO` \ rc ->
- if rc == 0 then
- return ()
- else
- syserr "setFileTimes"
-
-touchFile :: FilePath -> IO ()
-touchFile name =
- _packBytesForCST name `thenStrictlyST` \ path ->
- _ccall_ utime path (``NULL''::_Addr) `thenPrimIO` \ rc ->
- if rc == 0 then
- return ()
- else
- syserr "touchFile"
-
-data PathVar = LinkLimit
- | InputLineLimit
- | InputQueueLimit
- | FileNameLimit
- | PathNameLimit
- | PipeBufferLimit
- | SetOwnerAndGroupIsRestricted
- | FileNamesAreNotTruncated
-
-getPathVar :: PathVar -> FilePath -> IO Limit
-getPathVar v name =
- case v of
- LinkLimit -> pathconf ``_PC_LINK_MAX''
- InputLineLimit -> pathconf ``_PC_MAX_CANON''
- InputQueueLimit -> pathconf ``_PC_MAX_INPUT''
- FileNameLimit -> pathconf ``_PC_NAME_MAX''
- PathNameLimit -> pathconf ``_PC_PATH_MAX''
- PipeBufferLimit -> pathconf ``_PC_PIPE_BUF''
- SetOwnerAndGroupIsRestricted -> pathconf ``_PC_CHOWN_RESTRICTED''
- FileNamesAreNotTruncated -> pathconf ``_PC_NO_TRUNC''
- where
- pathconf :: Int -> IO Limit
- pathconf n =
- _packBytesForCST name `thenStrictlyST` \ path ->
- _ccall_ pathconf path n `thenPrimIO` \ rc ->
- if rc /= -1 then
- return rc
- else
- getErrorCode >>= \ errno ->
- if errno == invalidArgument then
- failWith (NoSuchThing "no such path limit or option")
- else
- syserr "getPathVar"
-
-getChannelVar :: PathVar -> Channel -> IO Limit
-getChannelVar v fd =
- case v of
- LinkLimit -> fpathconf ``_PC_LINK_MAX''
- InputLineLimit -> fpathconf ``_PC_MAX_CANON''
- InputQueueLimit -> fpathconf ``_PC_MAX_INPUT''
- FileNameLimit -> fpathconf ``_PC_NAME_MAX''
- PathNameLimit -> fpathconf ``_PC_PATH_MAX''
- PipeBufferLimit -> fpathconf ``_PC_PIPE_BUF''
- SetOwnerAndGroupIsRestricted -> fpathconf ``_PC_CHOWN_RESTRICTED''
- FileNamesAreNotTruncated -> fpathconf ``_PC_NO_TRUNC''
- where
- fpathconf :: Int -> IO Limit
- fpathconf n =
- _ccall_ fpathconf fd n `thenPrimIO` \ rc ->
- if rc /= -1 then
- return rc
- else
- getErrorCode >>= \ errno ->
- if errno == invalidArgument then
- failWith (NoSuchThing "no such path limit or option")
- else
- syserr "getPathVar"
-
-\end{code}
+++ /dev/null
-%
-% (c) The GRASP/AQUA Project, Glasgow University, 1995
-%
-\section[LibPosixIO]{Haskell 1.3 POSIX Input/Output Primitives}
-
-\begin{code}
-module LibPosixIO (
- ChannelOption(..),
- FileLock(..),
- LockRequest(..),
-
- closeChannel,
- createPipe,
- dupChannel,
- dupChannelTo,
- getLock,
- queryChannelOption,
- readChannel,
- seekChannel,
- setChannelOption,
- setLock,
- waitToSetLock,
- writeChannel
- ) where
-
-import PreludeGlaST
-import PS
-
-import LibPosixUtil
-
-createPipe :: IO (Channel, Channel)
-createPipe =
- allocChars ``(2*sizeof(int))'' `thenStrictlyST` \ bytes ->
- _casm_ ``%r = pipe((int *)%0);'' bytes `thenPrimIO` \ rc ->
- if rc /= -1 then
- _casm_ ``%r = ((int *)%0)[0];'' bytes `thenPrimIO` \ wd ->
- _casm_ ``%r = ((int *)%0)[1];'' bytes `thenPrimIO` \ rd ->
- return (wd, rd)
- else
- syserr "createPipe"
-
-dupChannel :: Channel -> IO Channel
-dupChannel fd =
- _ccall_ dup fd `thenPrimIO` \ fd2 ->
- if fd2 /= -1 then
- return fd2
- else
- syserr "dupChannel"
-
-dupChannelTo :: Channel -> Channel -> IO ()
-dupChannelTo fd1 fd2 =
- _ccall_ dup2 fd1 fd2 `thenPrimIO` \ rc ->
- if rc /= -1 then
- return ()
- else
- syserr "dupChannelTo"
-
-closeChannel :: Channel -> IO ()
-closeChannel fd =
- _ccall_ close fd `thenPrimIO` \ rc ->
- if rc /= -1 then
- return ()
- else
- syserr "closeChannel"
-
-readChannel :: Channel -> ByteCount -> IO (String, ByteCount)
-readChannel fd 0 = return ("", 0)
-readChannel fd nbytes =
- allocChars nbytes `thenStrictlyST` \ bytes ->
- _ccall_ read fd bytes nbytes `thenPrimIO` \ rc ->
- case rc of
- -1 -> syserr "readChannel"
- 0 -> failWith EOF
- n | n == nbytes ->
- freeze bytes `thenStrictlyST` \ buf ->
- return (_unpackPS (_unsafeByteArrayToPS buf n), n)
- | otherwise ->
- -- Let go of the excessively long ByteArray# by copying to a shorter one.
- -- Maybe we need a new primitive, shrinkCharArray#?
- allocChars n `thenPrimIO` \ bytes' ->
- _casm_ ``do {I_ i; for(i = 0; i < %2; i++) ((B_)%0)[i] = ((B_)%1)[i];
- } while(0);'' bytes' bytes n `thenPrimIO` \ () ->
- freeze bytes' `thenStrictlyST` \ buf ->
- return (_unpackPS (_unsafeByteArrayToPS buf n), n)
-
-writeChannel :: Channel -> String -> IO ByteCount
-writeChannel fd str =
- _packBytesForCST str `thenPrimIO` \ buf ->
- _ccall_ write fd buf (length str) `thenPrimIO` \ rc ->
- if rc /= -1 then
- return rc
- else
- syserr "writeChannel"
-
-data ChannelOption = AppendOnWrite
- | CloseOnExec
- | NonBlockingRead
-
-queryChannelOption :: ChannelOption -> Channel -> IO Bool
-queryChannelOption CloseOnExec fd =
- _ccall_ fcntl fd (``F_GETFD''::Int) 0 `thenPrimIO` \ (I# flags#) ->
- if flags# /=# -1# then
- return ((int2Word# flags# `and#` fd_cloexec#) `neWord#` int2Word# 0#)
- else
- syserr "queryChannelOption"
- where
- fd_cloexec# = case (``FD_CLOEXEC'') of { W# x -> x }
-queryChannelOption other fd =
- _ccall_ fcntl fd (``F_GETFL''::Int) 0 `thenPrimIO` \ (I# flags#) ->
- if flags# >=# 0# then
- return ((int2Word# flags# `and#` opt#) `neWord#` int2Word# 0#)
- else
- syserr "queryChannelOption"
- where
- opt# = case (
- case other of
- AppendOnWrite -> ``O_APPEND''
- NonBlockingRead -> ``O_NONBLOCK'' ) of { W# x -> x }
-
-setChannelOption :: ChannelOption -> Bool -> Channel -> IO ()
-setChannelOption CloseOnExec val fd =
- _ccall_ fcntl fd (``F_GETFD''::Int) 0 `thenPrimIO` \ flags ->
- if flags /= -1 then
- (if val then
- _casm_ ``%r = fcntl(%0, F_SETFD, %1 | FD_CLOEXEC);'' fd flags
- else
- _casm_ ``%r = fcntl(%0, F_SETFD, %1 & ~FD_CLOEXEC);'' fd flags)
- `thenPrimIO` \ rc ->
- if rc /= -1 then
- return ()
- else
- fail
- else
- fail
- where
- fail = syserr "setChannelOption"
-setChannelOption other val fd =
- _ccall_ fcntl fd (``F_GETFL''::Int) 0 `thenPrimIO` \ flags ->
- if flags >= 0 then
- (if val then
- _casm_ ``%r = fcntl(%0, F_SETFL, %1 | %2);'' fd flags opt
- else
- _casm_ ``%r = fcntl(%0, F_SETFL, %1 & ~(%2));'' fd flags opt)
- `thenPrimIO` \ rc ->
- if rc /= -1 then
- return ()
- else
- fail
- else
- fail
- where
- fail = syserr "setChannelOption"
- opt =
- case other of
- AppendOnWrite -> (``O_APPEND''::_Word)
- NonBlockingRead -> (``O_NONBLOCK''::_Word)
-
-data LockRequest = ReadLock
- | WriteLock
- | Unlock
-
-type FileLock = (LockRequest, SeekMode, FileOffset, FileOffset)
-
-getLock :: Channel -> FileLock -> IO (Maybe (ProcessID, FileLock))
-getLock fd lock =
- lock2Bytes lock >>= \ flock ->
- _ccall_ fcntl fd (``F_GETLK''::Int) flock `thenPrimIO` \ rc ->
- if rc /= -1 then
- bytes2ProcessIDAndLock flock `thenPrimIO` \ result ->
- return (maybeResult result)
- else
- syserr "getLock"
- where
- maybeResult (_, (Unlock, _, _, _)) = Nothing
- maybeResult x = Just x
-
-setLock :: Channel -> FileLock -> IO ()
-setLock fd lock =
- lock2Bytes lock >>= \ flock ->
- _ccall_ fcntl fd (``F_SETLK''::Int) flock `thenPrimIO` \ rc ->
- if rc /= -1 then
- return ()
- else
- syserr "setLock"
-
-waitToSetLock :: Channel -> FileLock -> IO ()
-waitToSetLock fd lock =
- lock2Bytes lock >>= \ flock ->
- _ccall_ fcntl fd (``F_SETLKW''::Int) flock `thenPrimIO` \ rc ->
- if rc /= -1 then
- return ()
- else
- syserr "waitToSetLock"
-
-seekChannel :: Channel -> SeekMode -> FileOffset -> IO FileOffset
-seekChannel fd mode offset =
- _ccall_ lseek fd offset (mode2Int mode) `thenPrimIO` \ rc ->
- if rc /= -1 then
- return rc
- else
- syserr "seekChannel"
-
-\end{code}
-
-Local utility functions
-
-\begin{code}
-
--- Convert a Haskell SeekMode to an int
-
-mode2Int :: SeekMode -> Int
-mode2Int AbsoluteSeek = ``SEEK_SET''
-mode2Int RelativeSeek = ``SEEK_CUR''
-mode2Int SeekFromEnd = ``SEEK_END''
-
--- Convert a Haskell FileLock to an flock structure
-
-lock2Bytes :: FileLock -> IO (_MutableByteArray _RealWorld ())
-lock2Bytes (kind, mode, start, len) =
- allocChars ``sizeof(struct flock)'' `thenStrictlyST` \ bytes ->
- _casm_ ``do { struct flock *fl = (struct flock *)%0;
- fl->l_type = %1; fl->l_whence = %2; fl->l_start = %3; fl->l_len = %4;
- } while(0);'' bytes ltype (mode2Int mode) start len
- `thenPrimIO` \ () ->
- return bytes
- where
- ltype :: Int
- ltype = case kind of
- ReadLock -> ``F_RDLCK''
- WriteLock -> ``F_WRLCK''
- Unlock -> ``F_UNLCK''
-
-bytes2ProcessIDAndLock :: _MutableByteArray s () -> PrimIO (ProcessID, FileLock)
-bytes2ProcessIDAndLock bytes =
- _casm_ ``%r = ((struct flock *)%0)->l_type;'' bytes
- `thenPrimIO` \ ltype ->
- _casm_ ``%r = ((struct flock *)%0)->l_whence;'' bytes
- `thenPrimIO` \ lwhence ->
- _casm_ ``%r = ((struct flock *)%0)->l_start;'' bytes
- `thenPrimIO` \ lstart ->
- _casm_ ``%r = ((struct flock *)%0)->l_len;'' bytes
- `thenPrimIO` \ llen ->
- _casm_ ``%r = ((struct flock *)%0)->l_pid;'' bytes
- `thenPrimIO` \ lpid ->
- returnPrimIO (lpid, (kind ltype, mode lwhence, lstart, llen))
- where
- kind :: Int -> LockRequest
- kind x
- | x == ``F_RDLCK'' = ReadLock
- | x == ``F_WRLCK'' = WriteLock
- | x == ``F_UNLCK'' = Unlock
- mode :: Int -> SeekMode
- mode x
- | x == ``SEEK_SET'' = AbsoluteSeek
- | x == ``SEEK_CUR'' = RelativeSeek
- | x == ``SEEK_END'' = SeekFromEnd
-
-\end{code}
+++ /dev/null
-%
-% (c) The GRASP/AQUA Project, Glasgow University, 1995
-%
-\section[LibPosixProcEnv]{Haskell 1.3 POSIX Process Environment}
-
-\begin{code}
-module LibPosixProcEnv (
- ProcessTimes(..),
- SysVar(..),
- SystemID(..),
-
- childSystemTime,
- childUserTime,
- createProcessGroup,
- createSession,
- elapsedTime,
- epochTime,
- getControllingTerminalName,
- getEffectiveGroupID,
- getEffectiveUserID,
- getEffectiveUserName,
- getGroups,
- getLoginName,
- getParentProcessID,
- getProcessGroupID,
- getProcessID,
- getProcessTimes,
- getRealGroupID,
- getRealUserID,
- getSysVar,
- getSystemID,
- getTerminalName,
- joinProcessGroup,
- machine,
- nodeName,
- queryTerminal,
- release,
- setGroupID,
- setProcessGroupID,
- setUserID,
- systemName,
- systemTime,
- userTime,
- version
- ) where
-
-import PreludeGlaST
-import PS
-
-import LibPosixErr
-import LibPosixUtil
-
-getProcessID :: IO ProcessID
-getProcessID =
- _ccall_ getpid `thenPrimIO` \ pid ->
- return pid
-
-getParentProcessID :: IO ProcessID
-getParentProcessID =
- _ccall_ getppid `thenPrimIO` \ ppid ->
- return ppid
-
-getRealUserID :: IO UserID
-getRealUserID =
- _ccall_ getuid `thenPrimIO` \ uid ->
- return uid
-
-getEffectiveUserID :: IO UserID
-getEffectiveUserID =
- _ccall_ geteuid `thenPrimIO` \ euid ->
- return euid
-
-setUserID :: UserID -> IO ()
-setUserID uid =
- _ccall_ setuid uid `thenPrimIO` \ rc ->
- if rc == 0 then
- return ()
- else
- syserr "setUserID"
-
-getLoginName :: IO String
-getLoginName =
- _ccall_ getlogin `thenPrimIO` \ str ->
- if str == ``NULL'' then
- syserr "getLoginName"
- else
- strcpy str `thenPrimIO` \ name ->
- return name
-
-getRealGroupID :: IO GroupID
-getRealGroupID =
- _ccall_ getgid `thenPrimIO` \ gid ->
- return gid
-
-getEffectiveGroupID :: IO GroupID
-getEffectiveGroupID =
- _ccall_ getegid `thenPrimIO` \ egid ->
- return egid
-
-setGroupID :: GroupID -> IO ()
-setGroupID gid =
- _ccall_ setgid gid `thenPrimIO` \ rc ->
- if rc == 0 then
- return ()
- else
- syserr "setGroupID"
-
-getGroups :: IO [GroupID]
-getGroups =
- _ccall_ getgroups 0 (``NULL''::_Addr) `thenPrimIO` \ ngroups ->
- allocWords ngroups `thenStrictlyST` \ words ->
- _casm_ ``%r = getgroups(%0,(gid_t *)%1);'' ngroups words
- `thenPrimIO` \ ngroups ->
- if ngroups /= -1 then
- freeze words `thenStrictlyST` \ arr ->
- return (map (extract arr) [0..(ngroups-1)])
- else
- syserr "getGroups"
- where
- extract (_ByteArray _ barr#) (I# n#) =
- case indexIntArray# barr# n# of
- r# -> (I# r#)
-
-getEffectiveUserName :: IO String
-getEffectiveUserName =
- _ccall_ cuserid (``NULL''::_Addr) `thenPrimIO` \ str ->
- if str == ``NULL'' then
- syserr "getEffectiveUserName"
- else
- strcpy str `thenPrimIO` \ name ->
- return name
-
-getProcessGroupID :: IO ProcessGroupID
-getProcessGroupID =
- _ccall_ getpgrp `thenPrimIO` \ pgid ->
- return pgid
-
-createProcessGroup :: ProcessID -> IO ProcessGroupID
-createProcessGroup pid =
- _ccall_ setpgid pid 0 `thenPrimIO` \ pgid ->
- if pgid == 0 then
- return pgid
- else
- syserr "createProcessGroup"
-
-joinProcessGroup :: ProcessGroupID -> IO ()
-joinProcessGroup pgid =
- _ccall_ setpgid 0 pgid `thenPrimIO` \ rc ->
- if rc == 0 then
- return ()
- else
- syserr "setProcessGroupID"
-
-setProcessGroupID :: ProcessID -> ProcessGroupID -> IO ()
-setProcessGroupID pid pgid =
- _ccall_ setpgid pid pgid `thenPrimIO` \ rc ->
- if rc == 0 then
- return ()
- else
- syserr "setProcessGroupID"
-
-createSession :: IO ProcessGroupID
-createSession =
- _ccall_ setsid `thenPrimIO` \ pgid ->
- if pgid /= -1 then
- return pgid
- else
- syserr "createSession"
-
-type SystemID = _ByteArray ()
-
-systemName :: SystemID -> String
-systemName sid = unsafePerformPrimIO (
- _casm_ ``%r = ((struct utsname *)%0)->sysname;'' sid
- `thenPrimIO` \ str ->
- strcpy str `thenPrimIO` \ sysname ->
- returnPrimIO sysname)
-
-nodeName :: SystemID -> String
-nodeName sid = unsafePerformPrimIO (
- _casm_ ``%r = ((struct utsname *)%0)->nodename;'' sid
- `thenPrimIO` \ str ->
- strcpy str `thenPrimIO` \ nodename ->
- returnPrimIO nodename)
-
-release :: SystemID -> String
-release sid = unsafePerformPrimIO (
- _casm_ ``%r = ((struct utsname *)%0)->release;'' sid
- `thenPrimIO` \ str ->
- strcpy str `thenPrimIO` \ releaseStr ->
- returnPrimIO releaseStr)
-
-version :: SystemID -> String
-version sid = unsafePerformPrimIO (
- _casm_ ``%r = ((struct utsname *)%0)->version;'' sid
- `thenPrimIO` \ str ->
- strcpy str `thenPrimIO` \ versionStr ->
- returnPrimIO versionStr)
-
-machine :: SystemID -> String
-machine sid = unsafePerformPrimIO (
- _casm_ ``%r = ((struct utsname *)%0)->machine;'' sid
- `thenPrimIO` \ str ->
- strcpy str `thenPrimIO` \ machine ->
- returnPrimIO machine)
-
-getSystemID :: IO SystemID
-getSystemID =
- allocChars (``sizeof(struct utsname)''::Int) `thenStrictlyST` \ bytes ->
- _casm_ ``%r = uname((struct utsname *)%0);'' bytes
- `thenPrimIO` \ rc ->
- if rc /= -1 then
- freeze bytes `thenStrictlyST` \ sid ->
- return sid
- else
- syserr "getSystemID"
-
-epochTime :: IO EpochTime
-epochTime =
- _ccall_ time (``NULL''::_Addr) `thenPrimIO` \ secs ->
- if secs /= -1 then
- return secs
- else
- syserr "epochTime"
-
--- All times in clock ticks (see getClockTick)
-
-type ProcessTimes = (ClockTick, _ByteArray ())
-
-elapsedTime :: ProcessTimes -> ClockTick
-elapsedTime (realtime, _) = realtime
-
-userTime :: ProcessTimes -> ClockTick
-userTime (_, times) = unsafePerformPrimIO (
- _casm_ ``%r = ((struct tms *)%0)->tms_utime;'' times
- `thenStrictlyST` \ utime ->
- returnPrimIO utime)
-
-systemTime :: ProcessTimes -> ClockTick
-systemTime (_, times) = unsafePerformPrimIO (
- _casm_ ``%r = ((struct tms *)%0)->tms_stime;'' times
- `thenStrictlyST` \ stime ->
- returnPrimIO stime)
-
-childUserTime :: ProcessTimes -> ClockTick
-childUserTime (_, times) = unsafePerformPrimIO (
- _casm_ ``%r = ((struct tms *)%0)->tms_cutime;'' times
- `thenStrictlyST` \ cutime ->
- returnPrimIO cutime)
-
-childSystemTime :: ProcessTimes -> ClockTick
-childSystemTime (_, times) = unsafePerformPrimIO (
- _casm_ ``%r = ((struct tms *)%0)->tms_cstime;'' times
- `thenStrictlyST` \ cstime ->
- returnPrimIO cstime)
-
-getProcessTimes :: IO ProcessTimes
-getProcessTimes =
- allocChars (``sizeof(struct tms)''::Int) `thenStrictlyST` \ bytes ->
- _casm_ ``%r = times((struct tms *)%0);'' bytes `thenPrimIO` \ elapsed ->
- if elapsed /= -1 then
- freeze bytes `thenStrictlyST` \ times ->
- return (elapsed, times)
- else
- syserr "getProcessTimes"
-
-getControllingTerminalName :: IO FilePath
-getControllingTerminalName =
- _ccall_ ctermid (``NULL''::_Addr) `thenPrimIO` \ str ->
- if str == ``NULL'' then
- failWith (NoSuchThing "no controlling terminal")
- else
- strcpy str `thenPrimIO` \ name ->
- return name
-
-getTerminalName :: Channel -> IO FilePath
-getTerminalName fd =
- _ccall_ ttyname fd `thenPrimIO` \ str ->
- if str == ``NULL'' then
- try (queryTerminal fd) >>=
- either (\err -> syserr "getTerminalName")
- (\succ -> if succ then failWith (NoSuchThing "terminal name")
- else failWith (InappropriateType "not a terminal"))
- else
- strcpy str `thenPrimIO` \ name ->
- return name
-
-queryTerminal :: Channel -> IO Bool
-queryTerminal fd =
- _ccall_ isatty fd `thenPrimIO` \ rc ->
- case rc of
- -1 -> syserr "queryTerminal"
- 0 -> return False
- 1 -> return True
-
-data SysVar = ArgumentLimit
- | ChildLimit
- | ClockTick
- | GroupLimit
- | OpenFileLimit
- | PosixVersion
- | HasSavedIDs
- | HasJobControl
-
-getSysVar :: SysVar -> IO Limit
-getSysVar v =
- case v of
- ArgumentLimit -> sysconf ``_SC_ARG_MAX''
- ChildLimit -> sysconf ``_SC_CHILD_MAX''
- ClockTick -> sysconf ``_SC_CLK_TCK''
- GroupLimit -> sysconf ``_SC_NGROUPS_MAX''
- OpenFileLimit -> sysconf ``_SC_OPEN_MAX''
- PosixVersion -> sysconf ``_SC_VERSION''
- HasSavedIDs -> sysconf ``_SC_SAVED_IDS''
- HasJobControl -> sysconf ``_SC_JOB_CONTROL''
- where
- sysconf :: Int -> IO Limit
- sysconf n =
- _ccall_ sysconf n `thenPrimIO` \ rc ->
- if rc /= -1 then
- return rc
- else
- failWith (NoSuchThing "no such system limit or option")
-
-\end{code}
+++ /dev/null
-%
-% (c) The GRASP/AQUA Project, Glasgow University, 1995
-%
-\section[LibPosixProcPrim]{Haskell 1.3 POSIX Process Primitives}
-
-\begin{code}
-module LibPosixProcPrim (
- Handler(..),
- SignalSet(..),
- Signal(..),
- ProcessStatus(..),
-
- addSignal,
- awaitSignal,
- backgroundRead,
- backgroundWrite,
- blockSignals,
- continueProcess,
- deleteSignal,
- emptySignalSet,
- executeFile,
- exitImmediately,
- floatingPointException,
- forkProcess,
- fullSignalSet,
- getAnyProcessStatus,
- getEnvVar,
- getEnvironment,
- getGroupProcessStatus,
- getPendingSignals,
- getProcessStatus,
- getSignalMask,
- illegalInstruction,
- inSignalSet,
- installHandler,
- internalAbort,
- keyboardSignal,
- keyboardStop,
- keyboardTermination,
- killProcess,
- lostConnection,
- nullSignal,
- openEndedPipe,
- processStatusChanged,
- queryStoppedChildFlag,
- raiseSignal,
- realTimeAlarm,
- removeEnvVar,
- scheduleAlarm,
- segmentationViolation,
- setEnvVar,
- setEnvironment,
- setSignalMask,
- setStoppedChildFlag,
- sigABRT,
- sigALRM,
- sigCHLD,
- sigCONT,
- sigFPE,
- sigHUP,
- sigILL,
- sigINT,
- sigKILL,
- sigPIPE,
- sigProcMask,
- sigQUIT,
- sigSEGV,
- sigSTOP,
- sigSetSize,
- sigTERM,
- sigTSTP,
- sigTTIN,
- sigTTOU,
- sigUSR1,
- sigUSR2,
- signalProcess,
- signalProcessGroup,
- sleep,
- softwareStop,
- softwareTermination,
- unBlockSignals,
- userDefinedSignal1,
- userDefinedSignal2,
-
- ExitCode
-
- ) where
-
-import PreludeGlaMisc
-import PreludeGlaST
-import PreludeStdIO
-import PS
-
-import LibPosixErr
-import LibPosixUtil
-
-import LibSystem(ExitCode(..))
-import LibPosixProcEnv (getProcessID)
-
-forkProcess :: IO (Maybe ProcessID)
-forkProcess =
- _ccall_ fork `thenPrimIO` \ pid ->
- case pid of
- -1 -> syserr "forkProcess"
- 0 -> return Nothing
- _ -> return (Just pid)
-
-executeFile :: FilePath -- Command
- -> Bool -- Search PATH?
- -> [String] -- Arguments
- -> Maybe [(String, String)] -- Environment
- -> IO ()
-executeFile path search args Nothing =
- _packBytesForCST path `thenStrictlyST` \ prog ->
- vectorize (basename path:args) `thenPrimIO` \ argv ->
- (if search then
- _casm_ ``%r = execvp(%0,(char **)%1);'' prog argv
- else
- _casm_ ``%r = execv(%0,(char **)%1);'' prog argv
- ) `thenPrimIO` \ rc ->
- syserr "executeFile"
-
-executeFile path search args (Just env) =
- _packBytesForCST path `thenStrictlyST` \ prog ->
- vectorize (basename path:args) `thenPrimIO` \ argv ->
- vectorize (map (\ (name, val) -> name ++ ('=' : val)) env)
- `thenPrimIO` \ envp ->
- (if search then
- _casm_ ``%r = execvpe(%0,(char **)%1,(char **)%2);'' prog argv envp
- else
- _casm_ ``%r = execve(%0,(char **)%1,(char **)%2);'' prog argv envp
- ) `thenPrimIO` \ rc ->
- syserr "executeFile"
-
-data ProcessStatus = Exited ExitCode
- | Terminated Signal
- | Stopped Signal
-{- mattson -} deriving (Eq, Ord, Text)
-
-getProcessStatus :: Bool -> Bool -> ProcessID -> IO (Maybe ProcessStatus)
-getProcessStatus block stopped pid =
- allocWords 1 `thenPrimIO` \ wstat ->
- _casm_ ``%r = waitpid(%0, (int *)%1, %2);'' pid wstat (waitOptions block stopped)
- `thenPrimIO` \ pid ->
- case pid of
- -1 -> syserr "getProcessStatus"
- 0 -> return Nothing
- _ -> decipherWaitStatus wstat `thenPrimIO` \ ps ->
- return (Just ps)
-
-getGroupProcessStatus :: Bool
- -> Bool
- -> ProcessGroupID
- -> IO (Maybe (ProcessID, ProcessStatus))
-getGroupProcessStatus block stopped pgid =
- allocWords 1 `thenPrimIO` \ wstat ->
- _casm_ ``%r = waitpid(%0, (int *)%1, %2);'' (-pgid) wstat (waitOptions block stopped)
- `thenPrimIO` \ pid ->
- case pid of
- -1 -> syserr "getGroupProcessStatus"
- 0 -> return Nothing
- _ -> decipherWaitStatus wstat `thenPrimIO` \ ps ->
- return (Just (pid, ps))
-
-getAnyProcessStatus :: Bool -> Bool -> IO (Maybe (ProcessID, ProcessStatus))
-getAnyProcessStatus block stopped =
- getGroupProcessStatus block stopped 1 `handle`
- \ err -> syserr "getAnyProcessStatus"
-
-exitImmediately :: ExitCode -> IO ()
-exitImmediately exitcode =
- _ccall_ _exit (exitcode2Int exitcode) `thenPrimIO` \ () ->
- syserr "exitImmediately"
- where
- exitcode2Int ExitSuccess = 0
- exitcode2Int (ExitFailure n) = n
-
-getEnvironment :: IO [(String, String)]
-getEnvironment =
- unvectorize ``environ'' 0 `thenPrimIO` \ env ->
- return (map (split "") env)
- where
- split :: String -> String -> (String, String)
- split x ('=' : xs) = (reverse x, xs)
- split x (c:cs) = split (c:x) cs
-
-setEnvironment :: [(String, String)] -> IO ()
-setEnvironment pairs =
- vectorize (map (\ (var,val) -> var ++ ('=' : val)) pairs)
- `thenPrimIO` \ env ->
- _casm_ ``%r = setenviron((char **)%0);'' env `thenPrimIO` \ rc ->
- if rc == 0 then
- return ()
- else
- syserr "setEnvironment"
-
-getEnvVar :: String -> IO String
-getEnvVar name =
- _packBytesForCST name `thenStrictlyST` \ str ->
- _ccall_ getenv str `thenPrimIO` \ str ->
- if str == ``NULL'' then
- failWith (NoSuchThing "no such environment variable")
- else
- strcpy str `thenPrimIO` \ env ->
- return env
-
-setEnvVar :: String -> String -> IO ()
-setEnvVar name value =
- _packBytesForCST (name ++ ('=' : value)) `thenStrictlyST` \ str ->
- _ccall_ setenv str `thenPrimIO` \ rc ->
- if rc == 0 then
- return ()
- else
- syserr "setEnvVar"
-
-removeEnvVar :: String -> IO ()
-removeEnvVar name =
- _packBytesForCST name `thenStrictlyST` \ str ->
- _ccall_ delenv str `thenPrimIO` \ rc ->
- if rc == 0 then
- return ()
- else
- syserr "removeEnvVar"
-
-type Signal = Int
-
-nullSignal :: Signal
-nullSignal = 0
-
-backgroundRead, sigTTIN :: Signal
-backgroundRead = ``SIGTTIN''
-sigTTIN = ``SIGTTIN''
-
-backgroundWrite, sigTTOU :: Signal
-backgroundWrite = ``SIGTTOU''
-sigTTOU = ``SIGTTOU''
-
-continueProcess, sigCONT :: Signal
-continueProcess = ``SIGCONT''
-sigCONT = ``SIGCONT''
-
-floatingPointException, sigFPE :: Signal
-floatingPointException = ``SIGFPE''
-sigFPE = ``SIGFPE''
-
-illegalInstruction, sigILL :: Signal
-illegalInstruction = ``SIGILL''
-sigILL = ``SIGILL''
-
-internalAbort, sigABRT ::Signal
-internalAbort = ``SIGABRT''
-sigABRT = ``SIGABRT''
-
-keyboardSignal, sigINT :: Signal
-keyboardSignal = ``SIGINT''
-sigINT = ``SIGINT''
-
-keyboardStop, sigTSTP :: Signal
-keyboardStop = ``SIGTSTP''
-sigTSTP = ``SIGTSTP''
-
-keyboardTermination, sigQUIT :: Signal
-keyboardTermination = ``SIGQUIT''
-sigQUIT = ``SIGQUIT''
-
-killProcess, sigKILL :: Signal
-killProcess = ``SIGKILL''
-sigKILL = ``SIGKILL''
-
-lostConnection, sigHUP :: Signal
-lostConnection = ``SIGHUP''
-sigHUP = ``SIGHUP''
-
-openEndedPipe, sigPIPE :: Signal
-openEndedPipe = ``SIGPIPE''
-sigPIPE = ``SIGPIPE''
-
-processStatusChanged, sigCHLD :: Signal
-processStatusChanged = ``SIGCHLD''
-sigCHLD = ``SIGCHLD''
-
-realTimeAlarm, sigALRM :: Signal
-realTimeAlarm = ``SIGALRM''
-sigALRM = ``SIGALRM''
-
-segmentationViolation, sigSEGV :: Signal
-segmentationViolation = ``SIGSEGV''
-sigSEGV = ``SIGSEGV''
-
-softwareStop, sigSTOP :: Signal
-softwareStop = ``SIGSTOP''
-sigSTOP = ``SIGSTOP''
-
-softwareTermination, sigTERM :: Signal
-softwareTermination = ``SIGTERM''
-sigTERM = ``SIGTERM''
-
-userDefinedSignal1, sigUSR1 :: Signal
-userDefinedSignal1 = ``SIGUSR1''
-sigUSR1 = ``SIGUSR1''
-
-userDefinedSignal2, sigUSR2 :: Signal
-userDefinedSignal2 = ``SIGUSR2''
-sigUSR2 = ``SIGUSR2''
-
-signalProcess :: Signal -> ProcessID -> IO ()
-signalProcess int pid =
- _ccall_ kill pid int `thenPrimIO` \ rc ->
- if rc == 0 then
- return ()
- else
- syserr "signalProcess"
-
-raiseSignal :: Signal -> IO ()
-raiseSignal int = getProcessID >>= signalProcess int
-
-signalProcessGroup :: Signal -> ProcessGroupID -> IO ()
-signalProcessGroup int pgid = signalProcess int (-pgid)
-
-setStoppedChildFlag :: Bool -> IO Bool
-setStoppedChildFlag b =
- _casm_ ``%r = nocldstop; nocldstop = %0;'' x `thenPrimIO` \ rc ->
- return (rc == 0)
- where
- x = case b of {True -> 0; False -> 1}
-
-queryStoppedChildFlag :: IO Bool
-queryStoppedChildFlag =
- _casm_ ``%r = nocldstop;'' `thenPrimIO` \ rc ->
- return (rc == 0)
-
-data Handler = Default
- | Ignore
- | Catch (IO ())
-
-type SignalSet = _ByteArray ()
-
-sigSetSize :: Int
-sigSetSize = ``sizeof(sigset_t)''
-
-emptySignalSet :: SignalSet
-emptySignalSet = unsafePerformPrimIO (
- allocChars sigSetSize `thenStrictlyST` \ bytes ->
- _casm_ ``(void) sigemptyset((sigset_t *)%0);'' bytes
- `thenPrimIO` \ () ->
- freeze bytes `thenStrictlyST` \ sigset ->
- returnPrimIO sigset
- )
-
-fullSignalSet :: SignalSet
-fullSignalSet = unsafePerformPrimIO (
- allocChars sigSetSize `thenStrictlyST` \ bytes ->
- _casm_ ``(void) sigfillset((sigset_t *)%0);'' bytes
- `thenPrimIO` \ () ->
- freeze bytes `thenStrictlyST` \ sigset ->
- returnPrimIO sigset
- )
-
-addSignal :: Signal -> SignalSet -> SignalSet
-addSignal int oldset = unsafePerformPrimIO (
- allocChars sigSetSize `thenStrictlyST` \ bytes ->
- _casm_ ``*(sigset_t *)%0 = *(sigset_t *)%1; (void) sigaddset((sigset_t *)%0, %2);''
- bytes oldset int `thenPrimIO` \ () ->
- freeze bytes `thenStrictlyST` \ newset ->
- returnPrimIO newset
- )
-
-inSignalSet :: Signal -> SignalSet -> Bool
-inSignalSet int sigset = unsafePerformPrimIO (
- _casm_ ``%r = sigismember((sigset_t *)%0, %1);'' sigset int
- `thenPrimIO` \ rc ->
- if rc == 1 then
- returnPrimIO True
- else
- returnPrimIO False
- )
-
-deleteSignal :: Signal -> SignalSet -> SignalSet
-deleteSignal int oldset = unsafePerformPrimIO (
- allocChars sigSetSize `thenStrictlyST` \ bytes ->
- _casm_ ``*(sigset_t *)%0 = *(sigset_t *)%1; (void) sigdelset((sigset_t *)%0, %2);''
- bytes oldset int `thenPrimIO` \ () ->
- freeze bytes `thenStrictlyST` \ newset ->
- returnPrimIO newset
- )
-
-installHandler :: Signal
- -> Handler
- -> Maybe SignalSet -- other signals to block
- -> IO Handler -- old handler
-
-#ifdef __PARALLEL_HASKELL__
-installHandler = error "installHandler: not available for Parallel Haskell"
-#else
-installHandler int handler maybe_mask = (
- case handler of
- Default -> _ccall_ stg_sig_ignore int mask
- Ignore -> _ccall_ stg_sig_default int mask
- Catch m ->
- makeStablePtr (wrap m) `thenPrimIO` \ sptr ->
- _ccall_ stg_sig_catch int sptr mask
- )
- `thenPrimIO` \ rc ->
- if rc >= 0 then
- _casm_ ``%r = (StgStablePtr) (%0);'' rc `thenPrimIO` \ osptr ->
- deRefStablePtr osptr `thenPrimIO` \ m ->
- return (Catch m)
- else if rc == ``STG_SIG_DFL'' then
- return Default
- else if rc == ``STG_SIG_IGN'' then
- return Ignore
- else
- syserr "installHandler"
- where
- mask = case maybe_mask of
- Nothing -> emptySignalSet
- Just x -> x
- wrap :: IO () -> PrimIO ()
- wrap m s =
- case (m s) of
- (result, s2@(S# _)) ->
- case result of
- Right () -> ( (), s2 )
- Left err -> error ("I/O error: "++shows err "\n")
-
-#endif {-!__PARALLEL_HASKELL__-}
-
-getSignalMask :: IO SignalSet
-getSignalMask =
- allocChars sigSetSize `thenStrictlyST` \ bytes ->
- _casm_ ``%r = sigprocmask(0, NULL, (sigset_t *)%0);'' bytes
- `thenPrimIO` \ rc ->
- if rc == 0 then
- freeze bytes `thenStrictlyST` \ sigset ->
- return sigset
- else
- syserr "getSignalMask"
-
-sigProcMask :: String -> Int -> SignalSet -> IO SignalSet
-sigProcMask name how sigset =
- allocChars sigSetSize `thenStrictlyST` \ bytes ->
- _casm_ ``%r = sigprocmask(%0, (sigset_t *)%1, (sigset_t *)%2);'' how sigset bytes
- `thenPrimIO` \ rc ->
- if rc == 0 then
- freeze bytes `thenStrictlyST` \ oldset ->
- return oldset
- else
- syserr name
-
-setSignalMask :: SignalSet -> IO SignalSet
-setSignalMask = sigProcMask "setSignalMask" ``SIG_SETMASK''
-
-blockSignals :: SignalSet -> IO SignalSet
-blockSignals = sigProcMask "blockSignals" ``SIG_BLOCK''
-
-unBlockSignals :: SignalSet -> IO SignalSet
-unBlockSignals = sigProcMask "unBlockSignals" ``SIG_UNBLOCK''
-
-getPendingSignals :: IO SignalSet
-getPendingSignals =
- allocChars sigSetSize `thenStrictlyST` \ bytes ->
- _casm_ ``%r = sigpending((sigset_t *)%0);'' bytes
- `thenPrimIO` \ rc ->
- if rc == 0 then
- freeze bytes `thenStrictlyST` \ sigset ->
- return sigset
- else
- syserr "getPendingSignals"
-
-awaitSignal :: Maybe SignalSet -> IO ()
-awaitSignal maybe_sigset =
- pause `thenPrimIO` \ () ->
- getErrorCode >>= \ err ->
- if err == interruptedOperation then
- return ()
- else
- syserr "awaitSignal"
- where
- pause :: PrimIO ()
- pause =
- case maybe_sigset of
- Nothing -> _casm_ ``(void) pause();''
- Just sigset -> _casm_ ``(void) sigsuspend((sigset_t *)%0);'' sigset
-
-scheduleAlarm :: Int -> IO Int
-scheduleAlarm (I# secs#) =
- _ccall_ alarm (W# (int2Word# secs#)) `thenPrimIO` \ (W# w#) ->
- return (I# (word2Int# w#))
-
-sleep :: Int -> IO ()
-sleep 0 = return ()
-sleep (I# secs#) =
- _ccall_ sleep (W# (int2Word# secs#)) `seqPrimIO`
- return ()
-
-\end{code}
-
-Local utility functions
-
-\begin{code}
-
--- Get the trailing component of a path
-
-basename :: String -> String
-basename "" = ""
-basename (c:cs)
- | c == '/' = basename cs
- | otherwise = c : basename cs
-
--- Convert wait options to appropriate set of flags
-
-waitOptions :: Bool -> Bool -> Int
--- block stopped
-waitOptions False False = ``WNOHANG''
-waitOptions False True = ``(WNOHANG|WUNTRACED)''
-waitOptions True False = 0
-waitOptions True True = ``WUNTRACED''
-
--- Turn a (ptr to a) wait status into a ProcessStatus
-
-decipherWaitStatus :: _MutableByteArray s x -> PrimIO ProcessStatus
-decipherWaitStatus wstat =
- _casm_ ``%r = WIFEXITED(*(int *)%0);'' wstat `thenPrimIO` \ exited ->
- if exited /= 0 then
- _casm_ ``%r = WEXITSTATUS(*(int *)%0);'' wstat
- `thenPrimIO` \ exitstatus ->
- if exitstatus == 0 then
- returnPrimIO (Exited ExitSuccess)
- else
- returnPrimIO (Exited (ExitFailure exitstatus))
- else
- _casm_ ``%r = WIFSIGNALED(*(int *)%0);'' wstat
- `thenPrimIO` \ signalled ->
- if signalled /= 0 then
- _casm_ ``%r = WTERMSIG(*(int *)%0);'' wstat
- `thenPrimIO` \ termsig ->
- returnPrimIO (Terminated termsig)
- else
- _casm_ ``%r = WSTOPSIG(*(int *)%0);'' wstat
- `thenPrimIO` \ stopsig ->
- returnPrimIO (Stopped stopsig)
-
-\end{code}
+++ /dev/null
-%
-% (c) The GRASP/AQUA Project, Glasgow University, 1995
-%
-\section[LibPosixTTY]{Haskell 1.3 POSIX Device-Specific Functions}
-
-\begin{code}
-module LibPosixTTY (
- BaudRate(..),
- ControlCharacter(..),
- FlowAction(..),
- QueueSelector(..),
- TerminalAttributes(..),
- TerminalMode(..),
- TerminalState(..),
- bitsPerByte,
- controlChar,
- controlFlow,
- discardData,
- drainOutput,
- getTerminalAttributes,
- getTerminalProcessGroupID,
- inputSpeed,
- inputTime,
- minInput,
- outputSpeed,
- sendBreak,
- setTerminalAttributes,
- setTerminalProcessGroupID,
- terminalMode,
- withBits,
- withCC,
- withInputSpeed,
- withMinInput,
- withMode,
- withOutputSpeed,
- withTime,
- withoutCC,
- withoutMode
- ) where
-
-import PreludeGlaST
-
-import LibPosixUtil
-
-type TerminalAttributes = _ByteArray ()
-
-data TerminalMode = InterruptOnBreak
- | MapCRtoLF
- | IgnoreBreak
- | IgnoreCR
- | IgnoreParityErrors
- | MapLFtoCR
- | CheckParity
- | StripHighBit
- | StartStopInput
- | StartStopOutput
- | MarkParityErrors
- | ProcessOutput
- | LocalMode
- | ReadEnable
- | TwoStopBits
- | HangupOnClose
- | EnableParity
- | OddParity
- | EnableEcho
- | EchoErase
- | EchoKill
- | EchoLF
- | ProcessInput
- | ExtendedFunctions
- | KeyboardInterrupts
- | NoFlushOnInterrupt
- | BackgroundWriteInterrupt
-
-withoutMode :: TerminalAttributes -> TerminalMode -> TerminalAttributes
-withoutMode termios InterruptOnBreak = clearInputFlag ``BRKINT'' termios
-withoutMode termios MapCRtoLF = clearInputFlag ``ICRNL'' termios
-withoutMode termios IgnoreBreak = clearInputFlag ``IGNBRK'' termios
-withoutMode termios IgnoreCR = clearInputFlag ``IGNCR'' termios
-withoutMode termios IgnoreParityErrors = clearInputFlag ``IGNPAR'' termios
-withoutMode termios MapLFtoCR = clearInputFlag ``INLCR'' termios
-withoutMode termios CheckParity = clearInputFlag ``INPCK'' termios
-withoutMode termios StripHighBit = clearInputFlag ``ISTRIP'' termios
-withoutMode termios StartStopInput = clearInputFlag ``IXOFF'' termios
-withoutMode termios StartStopOutput = clearInputFlag ``IXON'' termios
-withoutMode termios MarkParityErrors = clearInputFlag ``PARMRK'' termios
-withoutMode termios ProcessOutput = unsafePerformPrimIO (
- allocChars ``sizeof(struct termios)'' `thenStrictlyST` \ bytes ->
- _casm_ ``*(struct termios *)%0 = *(struct termios *)%1;
- ((struct termios *)%0)->c_oflag &= ~OPOST;'' bytes termios
- `thenPrimIO` \ () ->
- freeze bytes `thenStrictlyST` \ termios ->
- returnPrimIO termios)
-withoutMode termios LocalMode = clearControlFlag ``CLOCAL'' termios
-withoutMode termios ReadEnable = clearControlFlag ``CREAD'' termios
-withoutMode termios TwoStopBits = clearControlFlag ``CSTOPB'' termios
-withoutMode termios HangupOnClose = clearControlFlag ``HUPCL'' termios
-withoutMode termios EnableParity = clearControlFlag ``PARENB'' termios
-withoutMode termios OddParity = clearControlFlag ``PARODD'' termios
-withoutMode termios EnableEcho = clearLocalFlag ``ECHO'' termios
-withoutMode termios EchoErase = clearLocalFlag ``ECHOE'' termios
-withoutMode termios EchoKill = clearLocalFlag ``ECHOK'' termios
-withoutMode termios EchoLF = clearLocalFlag ``ECHONL'' termios
-withoutMode termios ProcessInput = clearLocalFlag ``ICANON'' termios
-withoutMode termios ExtendedFunctions = clearLocalFlag ``IEXTEN'' termios
-withoutMode termios KeyboardInterrupts = clearLocalFlag ``ISIG'' termios
-withoutMode termios NoFlushOnInterrupt = setLocalFlag ``NOFLSH'' termios
-withoutMode termios BackgroundWriteInterrupt = clearLocalFlag ``TOSTOP'' termios
-
-withMode :: TerminalAttributes -> TerminalMode -> TerminalAttributes
-withMode termios InterruptOnBreak = setInputFlag ``BRKINT'' termios
-withMode termios MapCRtoLF = setInputFlag ``ICRNL'' termios
-withMode termios IgnoreBreak = setInputFlag ``IGNBRK'' termios
-withMode termios IgnoreCR = setInputFlag ``IGNCR'' termios
-withMode termios IgnoreParityErrors = setInputFlag ``IGNPAR'' termios
-withMode termios MapLFtoCR = setInputFlag ``INLCR'' termios
-withMode termios CheckParity = setInputFlag ``INPCK'' termios
-withMode termios StripHighBit = setInputFlag ``ISTRIP'' termios
-withMode termios StartStopInput = setInputFlag ``IXOFF'' termios
-withMode termios StartStopOutput = setInputFlag ``IXON'' termios
-withMode termios MarkParityErrors = setInputFlag ``PARMRK'' termios
-withMode termios ProcessOutput = unsafePerformPrimIO (
- allocChars ``sizeof(struct termios)'' `thenStrictlyST` \ bytes ->
- _casm_ ``*(struct termios *)%0 = *(struct termios *)%1;
- ((struct termios *)%0)->c_oflag |= OPOST;'' bytes termios
- `thenPrimIO` \ () ->
- freeze bytes `thenStrictlyST` \ termios ->
- returnPrimIO termios)
-withMode termios LocalMode = setControlFlag ``CLOCAL'' termios
-withMode termios ReadEnable = setControlFlag ``CREAD'' termios
-withMode termios TwoStopBits = setControlFlag ``CSTOPB'' termios
-withMode termios HangupOnClose = setControlFlag ``HUPCL'' termios
-withMode termios EnableParity = setControlFlag ``PARENB'' termios
-withMode termios OddParity = setControlFlag ``PARODD'' termios
-withMode termios EnableEcho = setLocalFlag ``ECHO'' termios
-withMode termios EchoErase = setLocalFlag ``ECHOE'' termios
-withMode termios EchoKill = setLocalFlag ``ECHOK'' termios
-withMode termios EchoLF = setLocalFlag ``ECHONL'' termios
-withMode termios ProcessInput = setLocalFlag ``ICANON'' termios
-withMode termios ExtendedFunctions = setLocalFlag ``IEXTEN'' termios
-withMode termios KeyboardInterrupts = setLocalFlag ``ISIG'' termios
-withMode termios NoFlushOnInterrupt = clearLocalFlag ``NOFLSH'' termios
-withMode termios BackgroundWriteInterrupt = setLocalFlag ``TOSTOP'' termios
-
-terminalMode :: TerminalMode -> TerminalAttributes -> Bool
-terminalMode InterruptOnBreak = testInputFlag ``BRKINT''
-terminalMode MapCRtoLF = testInputFlag ``ICRNL''
-terminalMode IgnoreBreak = testInputFlag ``IGNBRK''
-terminalMode IgnoreCR = testInputFlag ``IGNCR''
-terminalMode IgnoreParityErrors = testInputFlag ``IGNPAR''
-terminalMode MapLFtoCR = testInputFlag ``INLCR''
-terminalMode CheckParity = testInputFlag ``INPCK''
-terminalMode StripHighBit = testInputFlag ``ISTRIP''
-terminalMode StartStopInput = testInputFlag ``IXOFF''
-terminalMode StartStopOutput = testInputFlag ``IXON''
-terminalMode MarkParityErrors = testInputFlag ``PARMRK''
-terminalMode ProcessOutput = \ termios -> unsafePerformPrimIO (
- _casm_ ``%r = ((struct termios *)%0)->c_oflag & OPOST;'' termios
- `thenPrimIO` \ (W# flags#) ->
- returnPrimIO (flags# `neWord#` int2Word# 0#))
-terminalMode LocalMode = testControlFlag ``CLOCAL''
-terminalMode ReadEnable = testControlFlag ``CREAD''
-terminalMode TwoStopBits = testControlFlag ``CSTOPB''
-terminalMode HangupOnClose = testControlFlag ``HUPCL''
-terminalMode EnableParity = testControlFlag ``PARENB''
-terminalMode OddParity = testControlFlag ``PARODD''
-terminalMode EnableEcho = testLocalFlag ``ECHO''
-terminalMode EchoErase = testLocalFlag ``ECHOE''
-terminalMode EchoKill = testLocalFlag ``ECHOK''
-terminalMode EchoLF = testLocalFlag ``ECHONL''
-terminalMode ProcessInput = testLocalFlag ``ICANON''
-terminalMode ExtendedFunctions = testLocalFlag ``IEXTEN''
-terminalMode KeyboardInterrupts = testLocalFlag ``ISIG''
-terminalMode NoFlushOnInterrupt = not . testLocalFlag ``NOFLSH''
-terminalMode BackgroundWriteInterrupt = testLocalFlag ``TOSTOP''
-
-bitsPerByte :: TerminalAttributes -> Int
-bitsPerByte termios = unsafePerformPrimIO (
- _casm_ ``%r = ((struct termios *)%0)->c_cflag & CSIZE;'' termios
- `thenPrimIO` \ w ->
- returnPrimIO (word2Bits w))
- where
- word2Bits :: _Word -> Int
- word2Bits x =
- if x == ``CS5'' then 5
- else if x == ``CS6'' then 6
- else if x == ``CS7'' then 7
- else if x == ``CS8'' then 8
- else 0
-
-withBits :: TerminalAttributes -> Int -> TerminalAttributes
-withBits termios bits = unsafePerformPrimIO (
- allocChars ``sizeof(struct termios)'' `thenStrictlyST` \ bytes ->
- _casm_ ``*(struct termios *)%0 = *(struct termios *)%1;
- ((struct termios *)%0)->c_cflag =
- (((struct termios *)%1)->c_cflag & ~CSIZE) | %2;''
- bytes termios (mask bits) `thenPrimIO` \ () ->
- freeze bytes `thenStrictlyST` \ termios ->
- returnPrimIO termios)
- where
- mask :: Int -> _Word
- mask 5 = ``CS5''
- mask 6 = ``CS6''
- mask 7 = ``CS7''
- mask 8 = ``CS8''
- mask _ = error "withBits bit value out of range [5..8]"
-
-data ControlCharacter = EndOfFile
- | EndOfLine
- | Erase
- | Interrupt
- | Kill
- | Quit
- | Suspend
- | Start
- | Stop
-
-controlChar :: TerminalAttributes -> ControlCharacter -> Maybe Char
-controlChar termios cc = unsafePerformPrimIO (
- _casm_ ``%r = ((struct termios *)%0)->c_cc[%1];'' termios (cc2Word cc)
- `thenPrimIO` \ val ->
- if val == ``_POSIX_VDISABLE'' then
- returnPrimIO Nothing
- else
- returnPrimIO (Just (chr val)))
-
-withCC :: TerminalAttributes
- -> (ControlCharacter, Char)
- -> TerminalAttributes
-withCC termios (cc, c) = unsafePerformPrimIO (
- allocChars ``sizeof(struct termios)'' `thenStrictlyST` \ bytes ->
- _casm_ ``*(struct termios *)%0 = *(struct termios *)%1;
- ((struct termios *)%0)->c_cc[%2] = %3;''
- bytes termios (cc2Word cc) c `thenPrimIO` \ () ->
- freeze bytes `thenStrictlyST` \ termios ->
- returnPrimIO termios)
-
-withoutCC :: TerminalAttributes
- -> ControlCharacter
- -> TerminalAttributes
-withoutCC termios cc = unsafePerformPrimIO (
- allocChars ``sizeof(struct termios)'' `thenStrictlyST` \ bytes ->
- _casm_ ``*(struct termios *)%0 = *(struct termios *)%1;
- ((struct termios *)%0)->c_cc[%2] = _POSIX_VDISABLE;''
- bytes termios (cc2Word cc) `thenPrimIO` \ () ->
- freeze bytes `thenStrictlyST` \ termios ->
- returnPrimIO termios)
-
-inputTime :: TerminalAttributes -> Int
-inputTime termios = unsafePerformPrimIO (
- _casm_ ``%r = ((struct termios *)%0)->c_cc[VTIME];'' termios
- `thenPrimIO` \ count ->
- returnPrimIO count)
-
-withTime :: TerminalAttributes -> Int -> TerminalAttributes
-withTime termios time = unsafePerformPrimIO (
- allocChars ``sizeof(struct termios)'' `thenStrictlyST` \ bytes ->
- _casm_ ``*(struct termios *)%0 = *(struct termios *)%1;
- ((struct termios *)%0)->c_cc[VTIME] = %2;'' bytes termios time
- `thenPrimIO` \ () ->
- freeze bytes `thenStrictlyST` \ termios ->
- returnPrimIO termios)
-
-minInput :: TerminalAttributes -> Int
-minInput termios = unsafePerformPrimIO (
- _casm_ ``%r = ((struct termios *)%0)->c_cc[VMIN];'' termios
- `thenPrimIO` \ count ->
- returnPrimIO count)
-
-withMinInput :: TerminalAttributes -> Int -> TerminalAttributes
-withMinInput termios count = unsafePerformPrimIO (
- allocChars ``sizeof(struct termios)'' `thenStrictlyST` \ bytes ->
- _casm_ ``*(struct termios *)%0 = *(struct termios *)%1;
- ((struct termios *)%0)->c_cc[VMIN] = %2;'' bytes termios count
- `thenPrimIO` \ () ->
- freeze bytes `thenStrictlyST` \ termios ->
- returnPrimIO termios)
-
-data BaudRate = B0
- | B50
- | B75
- | B110
- | B134
- | B150
- | B200
- | B300
- | B600
- | B1200
- | B1800
- | B2400
- | B4800
- | B9600
- | B19200
- | B38400
-
-inputSpeed :: TerminalAttributes -> BaudRate
-inputSpeed termios = unsafePerformPrimIO (
- _casm_ ``%r = cfgetispeed((struct termios *)%0);'' termios
- `thenPrimIO` \ w ->
- returnPrimIO (word2Baud w))
-
-withInputSpeed :: TerminalAttributes -> BaudRate -> TerminalAttributes
-withInputSpeed termios br = unsafePerformPrimIO (
- allocChars ``sizeof(struct termios)'' `thenStrictlyST` \ bytes ->
- _casm_ ``*(struct termios *)%0 = *(struct termios *)%1;
- cfsetispeed((struct termios *)%0, %2);'' bytes termios (baud2Word br)
- `thenPrimIO` \ () ->
- freeze bytes `thenStrictlyST` \ termios ->
- returnPrimIO termios)
-
-outputSpeed :: TerminalAttributes -> BaudRate
-outputSpeed termios = unsafePerformPrimIO (
- _casm_ ``%r = cfgetospeed((struct termios *)%0);'' termios
- `thenPrimIO` \ w ->
- returnPrimIO (word2Baud w))
-
-withOutputSpeed :: TerminalAttributes -> BaudRate -> TerminalAttributes
-withOutputSpeed termios br = unsafePerformPrimIO (
- allocChars ``sizeof(struct termios)'' `thenStrictlyST` \ bytes ->
- _casm_ ``*(struct termios *)%0 = *(struct termios *)%1;
- cfsetospeed((struct termios *)%0, %2);'' bytes termios (baud2Word br)
- `thenPrimIO` \ () ->
- freeze bytes `thenStrictlyST` \ termios ->
- returnPrimIO termios)
-
-getTerminalAttributes :: Channel -> IO TerminalAttributes
-getTerminalAttributes fd =
- allocChars ``sizeof(struct termios)'' `thenStrictlyST` \ bytes ->
- _casm_ ``%r = tcgetattr(%0,(struct termios *)%1);'' fd bytes
- `thenPrimIO` \ rc ->
- if rc /= -1 then
- freeze bytes `thenStrictlyST` \ termios ->
- return termios
- else
- syserr "getTerminalAttributes"
-
-data TerminalState = Immediately
- | WhenDrained
- | WhenFlushed
-
-setTerminalAttributes :: Channel
- -> TerminalAttributes
- -> TerminalState
- -> IO ()
-setTerminalAttributes fd termios state =
- _casm_ ``%r = tcsetattr(%0,%1,(struct termios *)%2);'' fd (state2Int state) termios
- `thenPrimIO` \ rc ->
- if rc /= -1 then
- return ()
- else
- syserr "setTerminalAttributes"
- where
- state2Int :: TerminalState -> Int
- state2Int Immediately = ``TCSANOW''
- state2Int WhenDrained = ``TCSADRAIN''
- state2Int WhenFlushed = ``TCSAFLUSH''
-
-sendBreak :: Channel -> Int -> IO ()
-sendBreak fd duration =
- _ccall_ tcsendbreak fd duration `thenPrimIO` \ rc ->
- if rc == 0 then
- return ()
- else
- syserr "sendBreak"
-
-drainOutput :: Channel -> IO ()
-drainOutput fd =
- _ccall_ tcdrain fd `thenPrimIO` \ rc ->
- if rc == 0 then
- return ()
- else
- syserr "drainOutput"
-
-data QueueSelector = InputQueue
- | OutputQueue
- | BothQueues
-
-discardData :: Channel -> QueueSelector -> IO ()
-discardData fd queue =
- _ccall_ tcflush fd (queue2Int queue) `thenPrimIO` \ rc ->
- if rc /= -1 then
- return ()
- else
- syserr "discardData"
- where
- queue2Int :: QueueSelector -> Int
- queue2Int InputQueue = ``TCIFLUSH''
- queue2Int OutputQueue = ``TCOFLUSH''
- queue2Int BothQueues = ``TCIOFLUSH''
-
-data FlowAction = SuspendOutput
- | RestartOutput
- | TransmitStop
- | TransmitStart
-
-controlFlow :: Channel -> FlowAction -> IO ()
-controlFlow fd action =
- _ccall_ tcflow fd (action2Int action) `thenPrimIO` \ rc ->
- if rc /= -1 then
- return ()
- else
- syserr "controlFlow"
- where
- action2Int :: FlowAction -> Int
- action2Int SuspendOutput = ``TCOOFF''
- action2Int RestartOutput = ``TCOON''
- action2Int TransmitStop = ``TCIOFF''
- action2Int TransmitStart = ``TCION''
-
-getTerminalProcessGroupID :: Channel -> IO ProcessGroupID
-getTerminalProcessGroupID fd =
- _ccall_ tcgetpgrp fd `thenPrimIO` \ pgid ->
- if pgid /= -1 then
- return pgid
- else
- syserr "getTerminalProcessGroupID"
-
-setTerminalProcessGroupID :: Channel -> ProcessGroupID -> IO ()
-setTerminalProcessGroupID fd pgid =
- _ccall_ tcsetpgrp fd pgid `thenPrimIO` \ rc ->
- if rc == 0 then
- return ()
- else
- syserr "setTerminalProcessGroupID"
-
-\end{code}
-
-Local utility functions
-
-\begin{code}
-
--- Convert Haskell ControlCharacter to Int
-
-cc2Word :: ControlCharacter -> _Word
-cc2Word EndOfFile = ``VEOF''
-cc2Word EndOfLine = ``VEOL''
-cc2Word Erase = ``VERASE''
-cc2Word Interrupt = ``VINTR''
-cc2Word Kill = ``VKILL''
-cc2Word Quit = ``VQUIT''
-cc2Word Suspend = ``VSUSP''
-cc2Word Start = ``VSTART''
-cc2Word Stop = ``VSTOP''
-
--- Convert Haskell BaudRate to unsigned integral type (_Word)
-
-baud2Word :: BaudRate -> _Word
-baud2Word B0 = ``B0''
-baud2Word B50 = ``B50''
-baud2Word B75 = ``B75''
-baud2Word B110 = ``B110''
-baud2Word B134 = ``B134''
-baud2Word B150 = ``B150''
-baud2Word B200 = ``B200''
-baud2Word B300 = ``B300''
-baud2Word B600 = ``B600''
-baud2Word B1200 = ``B1200''
-baud2Word B1800 = ``B1800''
-baud2Word B2400 = ``B2400''
-baud2Word B4800 = ``B4800''
-baud2Word B9600 = ``B9600''
-baud2Word B19200 = ``B19200''
-baud2Word B38400 = ``B38400''
-
--- And convert a word back to a baud rate
--- We really need some cpp macros here.
-
-word2Baud :: _Word -> BaudRate
-word2Baud x =
- if x == ``B0'' then B0
- else if x == ``B50'' then B50
- else if x == ``B75'' then B75
- else if x == ``B110'' then B110
- else if x == ``B134'' then B134
- else if x == ``B150'' then B150
- else if x == ``B200'' then B200
- else if x == ``B300'' then B300
- else if x == ``B600'' then B600
- else if x == ``B1200'' then B1200
- else if x == ``B1800'' then B1800
- else if x == ``B2400'' then B2400
- else if x == ``B4800'' then B4800
- else if x == ``B9600'' then B9600
- else if x == ``B19200'' then B19200
- else if x == ``B38400'' then B38400
- else error "unknown baud rate"
-
--- Clear termios i_flag
-
-clearInputFlag :: _Word -> TerminalAttributes -> TerminalAttributes
-clearInputFlag flag termios = unsafePerformPrimIO (
- allocChars ``sizeof(struct termios)'' `thenStrictlyST` \ bytes ->
- _casm_ ``*(struct termios *)%0 = *(struct termios *)%1;
- ((struct termios *)%0)->c_iflag &= ~%2;'' bytes termios flag
- `thenPrimIO` \ () ->
- freeze bytes `thenStrictlyST` \ termios ->
- returnPrimIO termios)
-
--- Set termios i_flag
-
-setInputFlag :: _Word -> TerminalAttributes -> TerminalAttributes
-setInputFlag flag termios = unsafePerformPrimIO (
- allocChars ``sizeof(struct termios)'' `thenStrictlyST` \ bytes ->
- _casm_ ``*(struct termios *)%0 = *(struct termios *)%1;
- ((struct termios *)%0)->c_iflag |= %2;'' bytes termios flag
- `thenPrimIO` \ () ->
- freeze bytes `thenStrictlyST` \ termios ->
- returnPrimIO termios)
-
--- Examine termios i_flag
-
-testInputFlag :: _Word -> TerminalAttributes -> Bool
-testInputFlag flag termios = unsafePerformPrimIO (
- _casm_ ``%r = ((struct termios *)%0)->c_iflag & %1;'' termios flag
- `thenPrimIO` \ (W# flags#) ->
- returnPrimIO (flags# `neWord#` int2Word# 0#))
-
--- Clear termios c_flag
-
-clearControlFlag :: _Word -> TerminalAttributes -> TerminalAttributes
-clearControlFlag flag termios = unsafePerformPrimIO (
- allocChars ``sizeof(struct termios)'' `thenStrictlyST` \ bytes ->
- _casm_ ``*(struct termios *)%0 = *(struct termios *)%1;
- ((struct termios *)%0)->c_cflag &= ~%2;'' bytes termios flag
- `thenPrimIO` \ () ->
- freeze bytes `thenStrictlyST` \ termios ->
- returnPrimIO termios)
-
--- Set termios c_flag
-
-setControlFlag :: _Word -> TerminalAttributes -> TerminalAttributes
-setControlFlag flag termios = unsafePerformPrimIO (
- allocChars ``sizeof(struct termios)'' `thenStrictlyST` \ bytes ->
- _casm_ ``*(struct termios *)%0 = *(struct termios *)%1;
- ((struct termios *)%0)->c_cflag |= %2;'' bytes termios flag
- `thenPrimIO` \ () ->
- freeze bytes `thenStrictlyST` \ termios ->
- returnPrimIO termios)
-
--- Examine termios c_flag
-
-testControlFlag :: _Word -> TerminalAttributes -> Bool
-testControlFlag flag termios = unsafePerformPrimIO (
- _casm_ ``%r = ((struct termios *)%0)->c_cflag & %1;'' termios flag
- `thenPrimIO` \ (W# flags#) ->
- returnPrimIO (flags# `neWord#` int2Word# 0#))
-
--- Clear termios l_flag
-
-clearLocalFlag :: _Word -> TerminalAttributes -> TerminalAttributes
-clearLocalFlag flag termios = unsafePerformPrimIO (
- allocChars ``sizeof(struct termios)'' `thenStrictlyST` \ bytes ->
- _casm_ ``*(struct termios *)%0 = *(struct termios *)%1;
- ((struct termios *)%0)->c_lflag &= ~%2;'' bytes termios flag
- `thenPrimIO` \ () ->
- freeze bytes `thenStrictlyST` \ termios ->
- returnPrimIO termios)
-
--- Set termios l_flag
-
-setLocalFlag :: _Word -> TerminalAttributes -> TerminalAttributes
-setLocalFlag flag termios = unsafePerformPrimIO (
- allocChars ``sizeof(struct termios)'' `thenStrictlyST` \ bytes ->
- _casm_ ``*(struct termios *)%0 = *(struct termios *)%1;
- ((struct termios *)%0)->c_lflag |= %2;'' bytes termios flag
- `thenPrimIO` \ () ->
- freeze bytes `thenStrictlyST` \ termios ->
- returnPrimIO termios)
-
--- Examine termios l_flag
-
-testLocalFlag :: _Word -> TerminalAttributes -> Bool
-testLocalFlag flag termios = unsafePerformPrimIO (
- _casm_ ``%r = ((struct termios *)%0)->c_iflag & %1;'' termios flag
- `thenPrimIO` \ (W# flags#) ->
- returnPrimIO (flags# `neWord#` int2Word# 0#))
-
-\end{code}
+++ /dev/null
-%
-% (c) The GRASP/AQUA Project, Glasgow University, 1995
-%
-\section[LibPosixUtil]{Haskell 1.3 POSIX utilities}
-
-\begin{code}
-
-module LibPosixUtil (
- LibPosixUtil..,
-
- _ByteArray,
- _MutableByteArray,
- _ST(..)
-
- ) where
-
-import PreludeGlaST
-import PS
-
-\end{code}
-
-First, all of the major Posix data types, to avoid any recursive dependencies
-
-\begin{code}
-
-type ByteCount = Int
-type Channel = Int
-type ClockTick = Int
-type EpochTime = Int
-type FileOffset = Int
-type GroupID = Int
-type Limit = Int
-type LinkCount = Int
-type ProcessID = Int
-type ProcessGroupID = ProcessID
-type UserID = Int
-
-\end{code}
-
-Now some local fucntions that shouldn't go outside this library.
-
-\begin{code}
-
--- Fail with a SystemError. Normally, we do not try to re-interpret POSIX
--- error numbers, so most routines in this file will only fail with SystemError.
--- The only exceptions are (1) those routines where failure of some kind may be
--- considered ``normal''...e.g. getpwnam() for a non-existent user, or (2) those
--- routines which do not set errno.
-
-syserr :: String -> IO a
-syserr = failWith . SystemError
-
--- Allocate a mutable array of characters with no indices.
-
-allocChars :: Int -> _ST s (_MutableByteArray s ())
-allocChars (I# size#) (S# s#) =
- case newCharArray# size# s# of
- StateAndMutableByteArray# s2# barr# -> (_MutableByteArray bot barr#, S# s2#)
- where
- bot = error "allocChars{LibPosix}"
-
--- Allocate a mutable array of words with no indices
-
-allocWords :: Int -> _ST s (_MutableByteArray s ())
-allocWords (I# size#) (S# s#) =
- case newIntArray# size# s# of
- StateAndMutableByteArray# s2# barr# -> (_MutableByteArray bot barr#, S# s2#)
- where
- bot = error "allocWords{LibPosix}"
-
--- Freeze these index-free mutable arrays
-
-freeze :: _MutableByteArray s () -> _ST s (_ByteArray ())
-freeze (_MutableByteArray ixs arr#) (S# s#) =
- case unsafeFreezeByteArray# arr# s# of
- StateAndByteArray# s2# frozen# -> (_ByteArray ixs frozen#, S# s2#)
-
--- Copy a null-terminated string from outside the heap to
--- Haskellized nonsense inside the heap
-
-strcpy :: _Addr -> PrimIO String
-strcpy str
- | str == ``NULL'' = returnPrimIO ""
- | otherwise =
- _ccall_ strlen str `thenPrimIO` \ len ->
- _packCBytesST len str `thenStrictlyST` \ ps ->
- returnPrimIO (_unpackPS ps)
-
--- Turn a string list into a NULL-terminated vector of null-terminated strings
--- No indices...I hate indices. Death to Ix.
-
-vectorize :: [String] -> PrimIO (_ByteArray ())
-vectorize xs =
- allocWords (len+1) `thenStrictlyST` \ arr ->
- fill arr 0 xs `thenPrimIO` \ () ->
- freeze arr `thenStrictlyST` \ frozen ->
- returnPrimIO frozen
-
- where
- len :: Int
- len = length xs
-
- fill :: _MutableByteArray _RealWorld () -> Int -> [String] -> PrimIO ()
- fill arr n [] =
- _casm_ ``((PP_)%0)[%1] = NULL;'' arr n
- fill arr n (x:xs) =
- _packBytesForCST x `thenStrictlyST` \ barr ->
- _casm_ ``((PP_)%0)[%1] = (P_)%2;'' arr n barr
- `thenPrimIO` \ () ->
- fill arr (n+1) xs
-
--- Turn a NULL-terminated vector of null-terminated strings into a string list
-
-unvectorize :: _Addr -> Int -> PrimIO [String]
-unvectorize ptr n
- | str == ``NULL'' = returnPrimIO []
- | otherwise =
- strcpy str `thenPrimIO` \ x ->
- unvectorize ptr (n+1) `thenPrimIO` \ xs ->
- returnPrimIO (x : xs)
- where str = indexAddrOffAddr ptr n
-
-\end{code}
+++ /dev/null
-%
-% (c) The GRASP/AQUA Project, Glasgow University, 1995
-%
-\section[LibSystem]{Haskell 1.3 System Interaction}
-
-\begin{code}
-module LibSystem where
-
-import PreludeGlaST
-import PreludeIOError
-import PreludeDialogueIO ( unpackArgv, unpackProgName )
-
-data ExitCode = ExitSuccess
- | ExitFailure Int
-{- mattson -} deriving (Eq, Ord, Text)
-
-\end{code}
-
-The $ExitCode$ type defines the exit codes that a program
-can return. $ExitSuccess$ indicates successful termination;
-and $ExitFailure code$ indicates program failure
-with value {\em code}. The exact interpretation of {\em code}
-is operating-system dependent. In particular, some values of
-{\em code} may be prohibited (e.g. 0 on a POSIX-compliant system).
-
-\begin{code}
-getArgs :: IO [String]
-getArgs = return (unpackArgv ``prog_argv'' (``prog_argc''::Int))
-\end{code}
-
-Computation $getArgs$ returns a list of the program's command
-line arguments (not including the program name).
-
-\begin{code}
-getProgName :: IO String
-getProgName = return (unpackProgName ``prog_argv'')
-\end{code}
-
-Computation $getProgName$ returns the name of the program
-as it was invoked.
-
-\begin{code}
-getEnv :: String -> IO String
-getEnv name =
- _ccall_ getenv name `thenPrimIO` \ litstring ->
- if litstring /= ``NULL'' then
- return (_unpackPS (_packCString litstring)) -- cheaper than it looks
- else
- failWith (NoSuchThing ("environment variable: " ++ name))
-\end{code}
-
-Computation $getEnv var$ returns the value
-of the environment variable {\em var}.
-
-This computation may fail with
-\begin{itemize}
-\item $NoSuchThing$
-The environment variable does not exist.
-\end{itemize}
-
-\begin{code}
-system :: String -> IO ExitCode
-system "" = failWith (InvalidArgument "null command")
-system cmd =
- _ccall_ systemCmd cmd `thenPrimIO` \ status ->
- case status of
- 0 -> return ExitSuccess
- -1 -> _constructError `thenPrimIO` \ ioError ->
- failWith ioError
- n -> return (ExitFailure n)
-\end{code}
-
-Computation $system cmd$ returns the exit code
-produced when the operating system processes the command {\em cmd}.
-
-This computation may fail with
-\begin{itemize}
-\item $PermissionDenied$
-The process has insufficient privileges to perform the operation.
-\item $ResourceExhausted$
-Insufficient resources are available to perform the operation.
-\item $UnsupportedOperation$
-The implementation does not support system calls.
-\end{itemize}
-
-\begin{code}
-exitWith :: ExitCode -> IO a
-exitWith ExitSuccess =
- _ccall_ EXIT (0::Int) `thenPrimIO` \ () ->
- failWith (OtherError13 "exit should not return")
-
-exitWith (ExitFailure n)
- | n == 0 = failWith (InvalidArgument "ExitFailure 0")
- | otherwise =
- _ccall_ EXIT n `thenPrimIO` \ () ->
- failWith (OtherError13 "exit should not return")
-\end{code}
-
-Computation $exitWith code$ terminates the
-program, returning {\em code} to the program's caller.
-Before it terminates, any open or semi-closed handles are first closed.
-
-
+++ /dev/null
-%
-% (c) The GRASP/AQUA Project, Glasgow University, 1995
-%
-\section[LibTime]{Haskell 1.3 Time of Day Library}
-
-The {\em LibTime} library provides the functionality of "time.h",
-adapted to the Haskell environment. It includes timezone information,
-as in System V, and follows RFC 1129 in its use of Coordinated
-Universal Time (UTC).
-
-\begin{code}
-module LibTime (
- CalendarTime(..),
- ClockTime,
- TimeDiff(..),
- addToClockTime,
- diffClockTimes,
- getClockTime,
- toCalendarTime,
- toUTCTime,
- toClockTime
- ) where
-
-import PreludeIOError
-import PreludeGlaST
-import PS
-import LibPosixUtil (allocWords, allocChars)
-
-\end{code}
-
-$ClockTime$ is an abstract type, used for the internal clock time.
-Clock times may be compared, converted to strings, or converted to an
-external calendar time $CalendarTime$.
-
-\begin{code}
-data ClockTime = TOD Integer Integer
- deriving (Eq, Ord)
-\end{code}
-
-When a $ClockTime$ is shown, it is converted to a string of the form
-$"Mon Nov 28 21:45:41 GMT 1994"$.
-
-For now, we are restricted to roughly:
-Fri Dec 13 20:45:52 1901 through Tue Jan 19 03:14:07 2038, because
-we use the C library routines based on 32 bit integers.
-
-\begin{code}
-instance Text ClockTime where
- showsPrec p (TOD sec@(J# a# s# d#) nsec) =
- showString (unsafePerformPrimIO (
- allocChars 32 `thenPrimIO` \ buf ->
- _ccall_ showTime (I# s#) (_ByteArray (error "ClockTime.show") d#) buf
- `thenPrimIO` \ str ->
- _ccall_ strlen str `thenPrimIO` \ len ->
- _packCBytesST len str `thenStrictlyST` \ ps ->
- returnPrimIO (_unpackPS ps)))
-
- showList = _showList (showsPrec 0)
-\end{code}
-
-
-$CalendarTime$ is a user-readable and manipulable
-representation of the internal $ClockTime$ type. The
-numeric fields have the following ranges.
-
-\begin{verbatim}
-Value Range Comments
------ ----- --------
-
-year -maxInt .. maxInt [Pre-Gregorian dates are inaccurate]
-mon 0 .. 11 [Jan = 0, Dec = 11]
-day 1 .. 31
-hour 0 .. 23
-min 0 .. 59
-sec 0 .. 61 [Allows for two leap seconds]
-picosec 0 .. (10^12)-1 [This could be over-precise?]
-wday 0 .. 6 [Sunday = 0, Saturday = 6]
-yday 0 .. 365 [364 in non-Leap years]
-tz -43200 .. 43200 [Variation from UTC in seconds]
-\end{verbatim}
-
-The {\em tzname} field is the name of the time zone. The {\em isdst}
-field indicates whether Daylight Savings Time would be in effect.
-
-\begin{code}
--- year mon day hour min sec picosec wday yday tzname tz isdst
-data CalendarTime =
- CalendarTime Int Int Int Int Int Int Integer Int Int String Int Bool
-\end{code}
-
-The $TimeDiff$ type records the difference between two clock times in
-a user-readable way.
-
-\begin{code}
--- year mon day hour min sec picosec
-data TimeDiff = TimeDiff Int Int Int Int Int Int Integer
- deriving (Eq,Ord)
-\end{code}
-
-$getClockTime$ returns the current time in its internal representation.
-
-\begin{code}
-getClockTime :: IO ClockTime
-getClockTime =
- malloc1 `thenStrictlyST` \ i1 ->
- malloc1 `thenStrictlyST` \ i2 ->
- _ccall_ getClockTime i1 i2 `thenPrimIO` \ rc ->
- if rc == 0 then
- cvtUnsigned i1 `thenStrictlyST` \ sec ->
- cvtUnsigned i2 `thenStrictlyST` \ nsec ->
- return (TOD sec (nsec * 1000))
- else
- _constructError `thenPrimIO` \ ioError ->
- failWith ioError
- where
- malloc1 (S# s#) =
- case newIntArray# 1# s# of
- StateAndMutableByteArray# s2# barr# -> (_MutableByteArray bot barr#, S# s2#)
- bot = error "getClockTime"
-
- -- The C routine fills in an unsigned word. We don't have `unsigned2Integer#,'
- -- so we freeze the data bits and use them for an MP_INT structure. Note that
- -- zero is still handled specially, although (J# 1# 1# (ptr to 0#)) is probably
- -- acceptable to gmp.
-
- cvtUnsigned (_MutableByteArray _ arr#) (S# s#) =
- case readIntArray# arr# 0# s# of
- StateAndInt# s2# r# ->
- if r# ==# 0# then
- (0, S# s2#)
- else
- case unsafeFreezeByteArray# arr# s2# of
- StateAndByteArray# s3# frozen# -> (J# 1# 1# frozen#, S# s3#)
-
-\end{code}
-
-$addToClockTime$ {\em d} {\em t} adds a time difference {\em d} and a
-clock time {\em t} to yield a new clock time. The difference {\em d}
-may be either positive or negative. $diffClockTimes$ {\em t1} {\em
-t2} returns the difference between two clock times {\em t1} and {\em
-t2} as a $TimeDiff$.
-
-
-\begin{code}
-addToClockTime :: TimeDiff -> ClockTime -> ClockTime
-addToClockTime _ _ = error "addToClockTime unimplemented"
-
-diffClockTimes :: ClockTime -> ClockTime -> TimeDiff
-diffClockTimes _ _ = error "diffClockTimes unimplemented"
-\end{code}
-
-$toCalendarTime$ {\em t} converts {\em t} to a local time, modified by
-the current timezone and daylight savings time settings. $toUTCTime$
-{\em t} converts {\em t} into UTC time. $toClockTime$ {\em l}
-converts {\em l} into the corresponding internal $ClockTime$. The
-{\em wday}, {\em yday}, {\em tzname}, and {\em isdst} fields are
-ignored.
-
-\begin{code}
-toCalendarTime :: ClockTime -> CalendarTime
-toCalendarTime (TOD sec@(J# a# s# d#) psec) = unsafePerformPrimIO (
- allocWords (``sizeof(struct tm)''::Int) `thenPrimIO` \ res ->
- allocChars 32 `thenPrimIO` \ zoneNm ->
- _casm_ ``SETZONE((struct tm *)%0,(char *)%1); '' res zoneNm `thenPrimIO` \ () ->
- _ccall_ toLocalTime (I# s#) (_ByteArray (error "toCalendarTime") d#) res
- `thenPrimIO` \ tm ->
- if tm == (``NULL''::_Addr) then
- error "toCalendarTime{LibTime}: out of range"
- else
- _casm_ ``%r = ((struct tm *)%0)->tm_sec;'' tm
- `thenPrimIO` \ sec ->
- _casm_ ``%r = ((struct tm *)%0)->tm_min;'' tm
- `thenPrimIO` \ min ->
- _casm_ ``%r = ((struct tm *)%0)->tm_hour;'' tm
- `thenPrimIO` \ hour ->
- _casm_ ``%r = ((struct tm *)%0)->tm_mday;'' tm
- `thenPrimIO` \ mday ->
- _casm_ ``%r = ((struct tm *)%0)->tm_mon;'' tm
- `thenPrimIO` \ mon ->
- _casm_ ``%r = ((struct tm *)%0)->tm_year;'' tm
- `thenPrimIO` \ year ->
- _casm_ ``%r = ((struct tm *)%0)->tm_wday;'' tm
- `thenPrimIO` \ wday ->
- _casm_ ``%r = ((struct tm *)%0)->tm_yday;'' tm
- `thenPrimIO` \ yday ->
- _casm_ ``%r = ((struct tm *)%0)->tm_isdst;'' tm
- `thenPrimIO` \ isdst ->
- _ccall_ ZONE tm `thenPrimIO` \ zone ->
- _ccall_ GMTOFF tm `thenPrimIO` \ tz ->
- _ccall_ strlen zone `thenPrimIO` \ len ->
- _packCBytesST len zone `thenStrictlyST` \ tzname ->
- returnPrimIO (CalendarTime (1900+year) mon mday hour min sec psec
- wday yday (_unpackPS tzname) tz (isdst /= 0))
- )
-
-toUTCTime :: ClockTime -> CalendarTime
-toUTCTime (TOD sec@(J# a# s# d#) psec) = unsafePerformPrimIO (
- allocWords (``sizeof(struct tm)''::Int) `thenPrimIO` \ res ->
- allocChars 32 `thenPrimIO` \ zoneNm ->
- _casm_ ``SETZONE((struct tm *)%0,(char *)%1); '' res zoneNm `thenPrimIO` \ () ->
- _ccall_ toUTCTime (I# s#) (_ByteArray (error "toCalendarTime") d#) res
- `thenPrimIO` \ tm ->
- if tm == (``NULL''::_Addr) then
- error "toUTCTime{LibTime}: out of range"
- else
- _casm_ ``%r = ((struct tm *)%0)->tm_sec;'' tm
- `thenPrimIO` \ sec ->
- _casm_ ``%r = ((struct tm *)%0)->tm_min;'' tm
- `thenPrimIO` \ min ->
- _casm_ ``%r = ((struct tm *)%0)->tm_hour;'' tm
- `thenPrimIO` \ hour ->
- _casm_ ``%r = ((struct tm *)%0)->tm_mday;'' tm
- `thenPrimIO` \ mday ->
- _casm_ ``%r = ((struct tm *)%0)->tm_mon;'' tm
- `thenPrimIO` \ mon ->
- _casm_ ``%r = ((struct tm *)%0)->tm_year;'' tm
- `thenPrimIO` \ year ->
- _casm_ ``%r = ((struct tm *)%0)->tm_wday;'' tm
- `thenPrimIO` \ wday ->
- _casm_ ``%r = ((struct tm *)%0)->tm_yday;'' tm
- `thenPrimIO` \ yday ->
- returnPrimIO (CalendarTime (1900+year) mon mday hour min sec psec
- wday yday "UTC" 0 False)
- )
-
-toClockTime :: CalendarTime -> ClockTime
-toClockTime (CalendarTime year mon mday hour min sec psec wday yday tzname tz isdst) =
- if psec < 0 || psec > 999999999999 then
- error "toClockTime{LibTime}: picoseconds out of range"
- else if tz < -43200 || tz > 43200 then
- error "toClockTime{LibTime}: timezone offset out of range"
- else
- unsafePerformPrimIO (
- allocWords (``sizeof(time_t)'') `thenPrimIO` \ res ->
- _ccall_ toClockSec year mon mday hour min sec tz res
- `thenPrimIO` \ ptr@(A# ptr#) ->
- if ptr /= ``NULL'' then
- returnPrimIO (TOD (int2Integer# (indexIntOffAddr# ptr# 0#)) psec)
- else
- error "toClockTime{LibTime}: can't perform conversion"
- )
-\end{code}
-
+++ /dev/null
-module Algebra where
-infixl 6 +. , -.
-infixl 7 *. , /.
-
---
--- (x::A)->B is dependant functions
--- (x = y) A is equality in type A
---
-
--- For simplicity we may require decidable equality on the elements.
-class {-(Eq a) =>-} SemiGroup a where
- (+.) :: a->a->a
--- assocAdd :: (x::a)->(y::a)->(z::a)->
--- ((a+.b)+.c = a+.(b+.c)) a
-
-class (SemiGroup a) => Monoid a where
- zero :: a
--- leftZero :: (x::a) -> (zero +. x = x) a
-
-class (Monoid a) => Group a where
- neg :: a->a
- (-.) :: a->a->a
- x -. y = x +. neg y
--- leftNeg :: (x::a) -> (neg x +. x = zero) a
-
-class (Group a) => AbelianGroup a
--- commAdd :: (x::a)->(y::a)-> (x+.y = y+.x) a
-
-class (AbelianGroup a) => Ring a where
- (*.) :: a->a->a
--- assocMul :: (x::a)->(y::a)->(z::a)->
--- ((a*.b)*.c = a*.(b*.c)) a
--- distrRingL :: (x::a)->(y::a)->(z::a)->
--- (x*.(y+.z) = x*.y +. x*.z)
--- distrRingR :: (x::a)->(y::a)->(z::a)->
--- ((y+.z)*.x = y*.x +. z*.x)
-
-class (Ring a) => UnityRing a where
- one :: a
--- leftOne :: (x::a)->(one *. x = x) a
--- rightOne :: (x::a)->(x *. one = x) a
-
-class (Ring a) => CommutativeRing a
--- commMul :: (x::a)->(y::a)-> (x*.y = y*.x) a
-
-class (CommutativeRing a, UnityRing a) => IntegralDomain a
--- noZeroDiv :: (x::a)->(y::a)-> ( (x*.y = zero) a -> Either ((x=zero) a) ((y=zero) a) )
-
-class (UnityRing a) => DivisionRing a where
- inv :: a->a
- (/.) :: a->a->a
- x /. y = x *. inv y
--- leftinv :: (x::a) -> (inv x *. x = one) a
-
-class (DivisionRing a, CommutativeRing a) => Field a
-
--- Every finite integral domain is a field.
-
--- Unique Factorization Domain
-class (IntegralDomain a) => UFD a
--- every non-zero element has a unique factorization
-
--- Principal Ideal Domain
-class (IntegralDomain a) => PID a
--- every ideal is a principal ideal
-
----------------------------------------------------
-
--- [a] --
-instance SemiGroup [a] where
- (+.) = (++)
-instance Monoid [a] where
- zero = []
-
--- Bool --
-instance SemiGroup Bool where
- (+.) = (||)
-instance Monoid Bool where
- zero = False
-instance Group Bool where
- neg = not
-instance AbelianGroup Bool
-instance Ring Bool where
- (*.) = (&&)
-instance CommutativeRing Bool
-instance UnityRing Bool where
- one = True
-instance DivisionRing Bool where
- inv x = x
-
--- Int --
-instance SemiGroup Int where
- (+.) = (+)
-instance Monoid Int where
- zero = 0
-instance Group Int where
- neg = negate
-instance AbelianGroup Int
-instance Ring Int where
- (*.) = (*)
-instance CommutativeRing Int
-instance UnityRing Int where
- one = 1
-
--- Integer --
-instance SemiGroup Integer where
- (+.) = (+)
-instance Monoid Integer where
- zero = 0
-instance Group Integer where
- neg = negate
-instance AbelianGroup Integer
-instance Ring Integer where
- (*.) = (*)
-instance CommutativeRing Integer
-instance UnityRing Integer where
- one = 1
-instance IntegralDomain Integer
-
--- Q --
--- A new data tupe is needed to do the instance declarations
-data Q = Q Rational {-#STRICT#-} deriving (Eq, Ord)
-instance Text Q where
-#if defined(__HBC__)
- -- not standard
- showsType _ = showString "Q"
-#endif
- showsPrec n (Q p) = showsPrec n p
-instance SemiGroup Q where
- Q a +. Q b = Q (a+b)
-instance Monoid Q where
- zero = Q 0
-instance Group Q where
- neg (Q a) = Q (-a)
-instance AbelianGroup Q
-instance Ring Q where
- Q a *. Q b = Q (a*b)
-instance CommutativeRing Q
-instance UnityRing Q where
- one = Q 1
-instance IntegralDomain Q
-instance DivisionRing Q where
- inv (Q x) = Q (recip x)
-instance Field Q
-
+++ /dev/null
-module Hash where
---
--- Hash a value. Hashing produces an Int of
--- unspecified range.
---
-
-class Hashable a where
- hash :: a -> Int
-
-instance Hashable Char where
- hash x = ord x
-
-instance Hashable Int where
- hash x = x
-
-instance Hashable Integer where
- hash x = fromInteger x
-
-instance Hashable Float where
- hash x = truncate x
-
-instance Hashable Double where
- hash x = truncate x
-
-instance Hashable Bin where
- hash x = 0
-
-#if defined(__HBC__)
-instance Hashable File where
- hash x = 0
-#endif
-
-instance Hashable () where
- hash x = 0
-
-instance Hashable (a -> b) where
- hash x = 0
-
-instance Hashable a => Hashable [a] where
- hash l = f l 0
- where f :: (Hashable a) => [a] -> Int -> Int
- f [] r = r
- f (c:cs) r = f cs (3*r + hash c)
-
-{-# SPECIALISE instance Hashable [Char] #-}
-
-instance (Hashable a, Hashable b) => Hashable (a,b) where
- hash (a,b) = hash a + 3 * hash b
-
-instance (Hashable a, Hashable b, Hashable c) => Hashable (a,b,c) where
- hash (a,b,c) = hash a + 3 * hash b + 5 * hash c
-
-instance (Hashable a, Hashable b, Hashable c, Hashable d) => Hashable (a,b,c,d) where
- hash (a,b,c,d) = hash a + 3 * hash b + 5 * hash c + 7 * hash d
-
-instance (Hashable a, Hashable b, Hashable c, Hashable d, Hashable e) => Hashable (a,b,c,d,e) where
- hash (a,b,c,d,e) = hash a + 3 * hash b + 5 * hash c + 7 * hash d + 9 * hash e
-
-instance Hashable Bool where
- hash False = 0
- hash True = 1
-
-instance (Integral a, Hashable a) => Hashable (Ratio a) where
- hash x = hash (denominator x) + hash (numerator x)
-
-instance (RealFloat a, Hashable a) => Hashable (Complex a) where
- hash (x :+ y) = hash x + hash y
-
-#if __HASKELL1__ < 3
-instance (Hashable a, Hashable b) => Hashable (Assoc a b) where
- hash (x := y) = hash x + hash y
-#endif
-
-instance (Ix a) => Hashable (Array a b) where
- hash x = 0 -- !!!
-
-#if __HASKELL1__ < 3
-instance Hashable Request where
- hash x = 0 -- !!
-
-instance Hashable Response where
- hash x = 0 -- !!
-
-instance Hashable IOError where
- hash x = 0 -- !!
-#endif
-
-
-hashToMax maxhash x =
- let h = hash x
- in if h < 0 then
- if -h < 0 then 0
- else (-h) `rem` maxhash
- else h `rem` maxhash
+++ /dev/null
-#if __HASKELL1__ < 3
-module ListUtil(assoc, concatMap, unfoldr, mapAccuml, union, intersection, chopList, assocDef, lookup, Maybe..,
- rept, tails, groupEq, group, readListLazily, nubEq, elemEq) where
-import {-flummox mkdependHS-}
- Maybe
-#else
-module ListUtil(assoc, concatMap, unfoldr, mapAccuml, union, intersection, chopList, assocDef, lookup, -- Maybe..,
- rept, tails, groupEq, group, readListLazily, nubEq, elemEq) where
---import Maybe
-#endif
-
--- Lookup an item in an association list. Apply a function to it if it is found, otherwise return a default value.
-assoc :: (Eq c) => (a -> b) -> b -> [(c, a)] -> c -> b
-assoc f d [] x = d
-assoc f d ((x',y):xys) x | x' == x = f y
- | otherwise = assoc f d xys x
-
--- Map and concatename results.
-concatMap :: (a -> [b]) -> [a] -> [b]
-concatMap f [] = []
-concatMap f (x:xs) =
- case f x of
- [] -> concatMap f xs
- ys -> ys ++ concatMap f xs
-
--- Repeatedly extract (and transform) values until a predicate hold. Return the list of values.
-unfoldr :: (a -> (b, a)) -> (a -> Bool) -> a -> [b]
-unfoldr f p x | p x = []
- | otherwise = y:unfoldr f p x'
- where (y, x') = f x
-
--- Map, but plumb a state through the map operation.
-mapAccuml :: (a -> b -> (a, c)) -> a -> [b] -> (a, [c])
-mapAccuml f s [] = (s, [])
-mapAccuml f s (x:xs) = (s'', y:ys)
- where (s', y) = f s x
- (s'', ys) = mapAccuml f s' xs
-
--- Union of sets as lists.
-union :: (Eq a) => [a] -> [a] -> [a]
-union xs ys = xs ++ (ys \\ xs)
-
--- Intersection of sets as lists.
-intersection :: (Eq a) => [a] -> [a] -> [a]
-intersection xs ys = [x | x<-xs, x `elem` ys]
-
---- Functions derived from those above
-
-chopList :: ([a] -> (b, [a])) -> [a] -> [b]
-chopList f l = unfoldr f null l
-
-assocDef :: (Eq a) => [(a, b)] -> b -> a -> b
---assocDef l d x = assoc id d l x
-assocDef [] d _ = d
-assocDef ((x,y):xys) d x' = if x == x' then y else assocDef xys d x'
-
-lookup :: (Eq a) => [(a, b)] -> a -> Maybe b
---lookup l x = assoc Just Nothing l x
-lookup [] _ = Nothing
-lookup ((x,y):xys) x' = if x == x' then Just y else lookup xys x'
-
--- Repeat an element n times
-rept :: (Integral a) => a -> b -> [b]
-rept n x = irept (fromIntegral n) x
- where irept :: Int -> a -> [a]
- irept n x = if n <= 0 then [] else x : irept (n-1) x
-
--- Take all the tails
-tails :: [a] -> [[a]]
-tails [] = []
-tails xxs@(_:xs) = xxs : tails xs
-
--- group list elements according to an equality predicate
-groupEq :: (a->a->Bool) -> [a] -> [[a]]
-groupEq eq xs = chopList f xs
- where f xs@(x:_) = span (eq x) xs
-
-group :: (Eq a) => [a] -> [[a]]
-group xs = groupEq (==) xs
-
--- Read a list lazily (in contrast with reads which requires
--- to see the ']' before returning the list.
-readListLazily :: (Text a) => String -> [a]
-readListLazily cs =
- case lex cs of
- [("[",cs)] -> readl' cs
- _ -> error "No leading '['"
- where readl' cs =
- case reads cs of
- [(x,cs)] -> x : readl cs
- [] -> error "No parse for list element"
- _ -> error "Ambigous parse for list element"
- readl cs =
- case lex cs of
- [("]",_)] -> []
- [(",",cs)] -> readl' cs
- _ -> error "No ',' or ']'"
-
-nubEq :: (a->a->Bool) -> [a] -> [a]
-nubEq eq l = nub' l []
- where nub' [] _ = []
- nub' (x:xs) l = if elemEq eq x l then nub' xs l else x : nub' xs (x:l)
-
-elemEq :: (a->a->Bool) -> a -> [a] -> Bool
-elemEq eq _ [] = False
-elemEq eq x (y:ys) = eq x y || elemEq eq x ys
-
-mapFst f xys = [(f x, y) | (x, y) <- xys]
-mapSnd f xys = [(x, f y) | (x, y) <- xys]
+++ /dev/null
-module Miranda(cjustify, lay, layn, limit, ljustify, merge, rep, rjustify, spaces,
- {-force,seq,-}sort) where
---import UnsafeDirty
-import QSort
-
-cjustify :: Int -> String -> String
-cjustify n s = spaces l ++ s ++ spaces r
- where
- m = n - length s
- l = m `div` 2
- r = m - l
-
-{-
-index :: [a] -> [Int]
-index xs = f xs 0
- where f [] n = []
- f (_:xs) n = n : f xs (n+1)
--}
-
-lay :: [String] -> String
-lay = concat . map (++"\n")
-
-layn :: [String] -> String
-layn = concat . zipWith f [1..]
- where
- f :: Int -> String -> String
- f n x = rjustify 4 (show n) ++ ") " ++ x ++ "\n"
-
-limit :: (Eq a) => [a] -> a
-limit (x:y:ys) | x == y = x
- | otherwise = limit (y:ys)
-limit _ = error "Miranda.limit: bad use"
-
-ljustify :: Int -> String -> String
-ljustify n s = s ++ spaces (n - length s)
-
-merge :: (Ord a) => [a] -> [a] -> [a]
-merge [] ys = ys
-merge xs [] = xs
-merge xxs@(x:xs) yys@(y:ys) | x <= y = x : merge xs yys
- | otherwise = y : merge xxs ys
-
-rep :: Int -> b -> [b]
-rep n x = take n (repeat x)
-
-rjustify :: Int -> String -> String
-rjustify n s = spaces (n - length s) ++ s
-
-spaces :: Int -> String
-spaces 0 = ""
-spaces n = ' ' : spaces (n-1)
-
--------------
-
-arctan x = atan x
-code c = ord c
-converse f a b = flip f a b
-decode n = chr n
-digit c = isDigit c
-e :: (Floating a) => a
-e = exp 1
-entier x = floor x
-filemode f = error "Miranda.filemode"
---getenv
-hd xs = head xs
-hugenum :: (Floating a) => a
-hugenum = error "hugenum" --!!!
-integer x = x == truncate x
-letter c = isAlpha c
-map2 f xs ys = zipWith f xs ys
---max
-max2 x y = max x y
-member xs x = x `elem` xs
---min
-min2 x y = min x y
-mkset xs = nub xs
-neg x = negate x
-numval :: (Num a) => String -> a
-numval cs = read cs
-postfix xs x = xs ++ [x]
---read
-scan f z l = scanl f z l
---shownum !!!
---showfloat !!!
---showscaled !!!
-tinynum :: (Floating a) => a
-tinynum = error "tinynum"
-undef = error "undefined"
-zip2 xs ys = zip xs ys
---zip
+++ /dev/null
-module NameSupply(NameSupply, initialNameSupply, splitNameSupply, getName, listNameSupply, Name(..)
-#if defined(__YALE_HASKELL__)
- , Symbol
-#endif
- ) where
-
-#if defined(__YALE_HASKELL__)
-import Symbol
-type Name = Symbol
-
-#else
-# if defined(__GLASGOW_HASKELL__)
-import PreludeGlaST
-type Name = Int
-
-# else
-import LMLgensym
-type Name = Int
-# endif
-#endif
-
-data NameSupply = NameSupply Name NameSupply NameSupply
-
-splitNameSupply :: NameSupply -> (NameSupply,NameSupply)
-getName :: NameSupply -> Name
-listNameSupply :: NameSupply -> [NameSupply]
-
-#if defined(__YALE_HASKELL__)
-initialNameSupply :: IO NameSupply
-#else
-initialNameSupply :: NameSupply
-#endif
-
-#if defined(__GLASGOW_HASKELL__)
-initialNameSupply = unsafePerformPrimIO mk_supply# -- GHC-specific
- where
- mk_supply#
- = unsafeInterleavePrimIO (_ccall_ genSymZh)
- `thenPrimIO` \ u ->
- unsafeInterleavePrimIO mk_supply# `thenPrimIO` \ s1 ->
- unsafeInterleavePrimIO mk_supply# `thenPrimIO` \ s2 ->
- returnPrimIO (NameSupply u s1 s2)
-#endif
-
-#if defined(__YALE_HASKELL__)
-initialNameSupply :: IO NameSupply
-initialNameSupply
- = let
- mk_supply =
- unsafeInterleaveIO (genSymbol "NameSupply") >>= \ sym ->
- unsafeInterleaveIO mk_supply >>= \ supply1 ->
- unsafeInterleaveIO mk_supply >>= \ supply2 ->
- return (NameSupply sym supply1 supply2)
- in
- mk_supply
-#endif
-
-#if defined(__HBC__)
-initialNameSupply = gen ()
- where gen n = NameSupply (__gensym n) (gen n) (gen n)
-#endif
-
-splitNameSupply (NameSupply _ s1 s2) = (s1, s2)
-
-getName (NameSupply k _ _) = k
-
-listNameSupply (NameSupply _ s1 s2) = s1 : listNameSupply s2
+++ /dev/null
-#if defined(__YALE_HASKELL__)
--- Native.hs -- native data conversions and I/O
---
--- author : Sandra Loosemore
--- date : 07 Jun 1994
---
---
--- Unlike in the original hbc version of this library, a Byte is a completely
--- abstract data type and not a character. You can't read and write Bytes
--- to ordinary text files; you must use the operations defined here on
--- Native files.
--- It's guaranteed to be more efficient to read and write objects directly
--- to a file than to do the conversion to a Byte stream and read/write
--- the Byte stream.
-#endif
-
-module Native(
- Native(..), Bytes(..),
- shortIntToBytes, bytesToShortInt,
- longIntToBytes, bytesToLongInt,
- showB, readB
-#if __HASKELL1__ < 3
- , Maybe..
-#endif
-#if defined(__YALE_HASKELL__)
- , openInputByteFile, openOutputByteFile, closeByteFile
- , readBFile, readBytesFromByteFile
- , shortIntToByteFile, bytesToShortIntIO
- , ByteFile
- , Byte
-#endif
- ) where
-
-#if __HASKELL1__ < 3
-import {-flummox mkdependHS-}
- Maybe
-#endif
-
-#if defined(__YALE_HASKELL__)
-import NativePrims
-
--- these data types are completely opaque on the Haskell side.
-
-data Byte = Byte
-data ByteFile = ByteFile
-type Bytes = [Byte]
-
-instance Text(Byte) where
- showsPrec _ _ = showString "Byte"
-
-instance Text(ByteFile) where
- showsPrec _ _ = showString "ByteFile"
-
--- Byte file primitives
-
-openInputByteFile :: String -> IO (ByteFile)
-openOutputByteFile :: String -> IO (ByteFile)
-closeByteFile :: ByteFile -> IO ()
-
-openInputByteFile = primOpenInputByteFile
-openOutputByteFile = primOpenOutputByteFile
-closeByteFile = primCloseByteFile
-#endif {- YALE-}
-
-#if defined(__GLASGOW_HASKELL__)
-import ByteOps -- partain
-type Bytes = [Char]
-#endif
-
-#if defined(__HBC__)
-import LMLbyteops
-type Bytes = [Char]
-#endif
-
--- Here are the basic operations defined on the class.
-
-class Native a where
-
- -- these are primitives
- showBytes :: a -> Bytes -> Bytes -- convert to bytes
- readBytes :: Bytes -> Maybe (a, Bytes) -- get an item and the rest
-#if defined(__YALE_HASKELL__)
- showByteFile :: a -> ByteFile -> IO ()
- readByteFile :: ByteFile -> IO a
-#endif
-
- -- these are derived
- listShowBytes :: [a] -> Bytes -> Bytes -- convert a list to bytes
- listReadBytes :: Int -> Bytes -> Maybe ([a], Bytes) -- get n items and the rest
-#if defined(__YALE_HASKELL__)
- listShowByteFile :: [a] -> ByteFile -> IO ()
- listReadByteFile :: Int -> ByteFile -> IO [a]
-#endif
-
- -- here are defaults for the derived methods.
-
- listShowBytes [] bs = bs
- listShowBytes (x:xs) bs = showBytes x (listShowBytes xs bs)
-
- listReadBytes 0 bs = Just ([], bs)
- listReadBytes n bs =
- case readBytes bs of
- Nothing -> Nothing
- Just (x,bs') ->
- case listReadBytes (n-1) bs' of
- Nothing -> Nothing
- Just (xs,bs'') -> Just (x:xs, bs'')
-
-#if defined(__YALE_HASKELL__)
- listShowByteFile l f =
- foldr (\ head tail -> (showByteFile head f) >> tail)
- (return ())
- l
-
- listReadByteFile 0 f =
- return []
- listReadByteFile n f =
- readByteFile f >>= \ h ->
- listReadByteFile (n - 1) f >>= \ t ->
- return (h:t)
-#endif
-
-#if ! defined(__YALE_HASKELL__)
--- Some utilities that Yale doesn't use
-hasNElems :: Int -> [a] -> Bool
-hasNElems 0 _ = True
-hasNElems 1 (_:_) = True -- speedup
-hasNElems 2 (_:_:_) = True -- speedup
-hasNElems 3 (_:_:_:_) = True -- speedup
-hasNElems 4 (_:_:_:_:_) = True -- speedup
-hasNElems _ [] = False
-hasNElems n (_:xs) = hasNElems (n-1) xs
-
-lenLong = length (longToBytes 0 [])
-lenInt = length (intToBytes 0 [])
-lenShort = length (shortToBytes 0 [])
-lenFloat = length (floatToBytes 0 [])
-lenDouble = length (doubleToBytes 0 [])
-#endif
-
--- Basic instances, defined as primitives
-
-instance Native Char where
-#if defined(__YALE_HASKELL__)
- showBytes = primCharShowBytes
- readBytes = primCharReadBytes
- showByteFile = primCharShowByteFile
- readByteFile = primCharReadByteFile
-#else
- showBytes c bs = c:bs
- readBytes [] = Nothing
- readBytes (c:cs) = Just (c,cs)
- listReadBytes n bs = f n bs []
- where f 0 bs cs = Just (reverse cs, bs)
- f _ [] _ = Nothing
- f n (b:bs) cs = f (n-1::Int) bs (b:cs)
-#endif
-
-instance Native Int where
-#if defined(__YALE_HASKELL__)
- showBytes = primIntShowBytes
- readBytes = primIntReadBytes
- showByteFile = primIntShowByteFile
- readByteFile = primIntReadByteFile
-#else
- showBytes i bs = intToBytes i bs
- readBytes bs = if hasNElems lenInt bs then Just (bytesToInt bs) else Nothing
-#endif
-
-instance Native Float where
-#if defined(__YALE_HASKELL__)
- showBytes = primFloatShowBytes
- readBytes = primFloatReadBytes
- showByteFile = primFloatShowByteFile
- readByteFile = primFloatReadByteFile
-#else
- showBytes i bs = floatToBytes i bs
- readBytes bs = if hasNElems lenFloat bs then Just (bytesToFloat bs) else Nothing
-#endif
-
-instance Native Double where
-#if defined(__YALE_HASKELL__)
- showBytes = primDoubleShowBytes
- readBytes = primDoubleReadBytes
- showByteFile = primDoubleShowByteFile
- readByteFile = primDoubleReadByteFile
-#else
- showBytes i bs = doubleToBytes i bs
- readBytes bs = if hasNElems lenDouble bs then Just (bytesToDouble bs) else Nothing
-#endif
-
-instance Native Bool where
-#if defined(__YALE_HASKELL__)
- showBytes = primBoolShowBytes
- readBytes = primBoolReadBytes
- showByteFile = primBoolShowByteFile
- readByteFile = primBoolReadByteFile
-#else
- showBytes b bs = if b then '\x01':bs else '\x00':bs
- readBytes [] = Nothing
- readBytes (c:cs) = Just(c/='\x00', cs)
-#endif
-
-#if defined(__YALE_HASKELL__)
--- Byte instances, so you can write Bytes to a ByteFile
-
-instance Native Byte where
- showBytes = (:)
- readBytes l =
- case l of
- [] -> Nothing
- h:t -> Just(h,t)
- showByteFile = primByteShowByteFile
- readByteFile = primByteReadByteFile
-#endif
-
--- A pair is stored as two consecutive items.
-instance (Native a, Native b) => Native (a,b) where
- showBytes (a,b) = showBytes a . showBytes b
- readBytes bs = readBytes bs `thenMaybe` \(a,bs') ->
- readBytes bs' `thenMaybe` \(b,bs'') ->
- Just ((a,b), bs'')
-#if defined(__YALE_HASKELL__)
- showByteFile (a,b) f = (showByteFile a f) >> (showByteFile b f)
-
- readByteFile f =
- readByteFile f >>= \ a ->
- readByteFile f >>= \ b ->
- return (a,b)
-#endif
-
--- A triple is stored as three consectutive items.
-instance (Native a, Native b, Native c) => Native (a,b,c) where
- showBytes (a,b,c) = showBytes a . showBytes b . showBytes c
- readBytes bs = readBytes bs `thenMaybe` \(a,bs') ->
- readBytes bs' `thenMaybe` \(b,bs'') ->
- readBytes bs'' `thenMaybe` \(c,bs''') ->
- Just ((a,b,c), bs''')
-#if defined(__YALE_HASKELL__)
- showByteFile (a,b,c) f =
- (showByteFile a f) >>
- (showByteFile b f) >>
- (showByteFile c f)
-
- readByteFile f =
- readByteFile f >>= \ a ->
- readByteFile f >>= \ b ->
- readByteFile f >>= \ c ->
- return (a,b,c)
-#endif
-
--- A list is stored with an Int with the number of items followed by the items.
-instance (Native a) => Native [a] where
- showBytes xs bs = showBytes (length xs) (f xs) where f [] = bs
- f (x:xs) = showBytes x (f xs)
- readBytes bs = readBytes bs `thenMaybe` \(n,bs') ->
- listReadBytes n bs' `thenMaybe` \(xs, bs'') ->
- Just (xs, bs'')
-#if defined(__YALE_HASKELL__)
- showByteFile l f = (showByteFile (length l) f) >> (listShowByteFile l f)
- readByteFile f = readByteFile f >>= \ n -> listReadByteFile n f
-#endif
-
--- A Maybe is stored as a Boolean possibly followed by a value
-instance (Native a) => Native (Maybe a) where
-#if !defined(__YALE_HASKELL__)
- showBytes Nothing = ('\x00' :)
- showBytes (Just x) = ('\x01' :) . showBytes x
- readBytes ('\x00':bs) = Just (Nothing, bs)
- readBytes ('\x01':bs) = readBytes bs `thenMaybe` \(a,bs') ->
- Just (Just a, bs')
- readBytes _ = Nothing
-#else
- showBytes (Just a) = showBytes True . showBytes a
- showBytes Nothing = showBytes False
- readBytes bs =
- readBytes bs `thenMaybe` \ (isJust, bs') ->
- if isJust then
- readBytes bs' `thenMaybe` \ (a, bs'') ->
- Just (Just a, bs'')
- else
- Just (Nothing, bs')
-
- showByteFile (Just a) f = showByteFile True f >> showByteFile a f
- showByteFile Nothing f = showByteFile False f
- readByteFile f =
- readByteFile f >>= \ isJust ->
- if isJust then
- readByteFile f >>= \ a ->
- return (Just a)
- else
- return Nothing
-#endif
-
-instance (Native a, Ix a, Native b) => Native (Array a b) where
- showBytes a = showBytes (bounds a) . showBytes (elems a)
- readBytes bs = readBytes bs `thenMaybe` \(b, bs')->
- readBytes bs' `thenMaybe` \(xs, bs'')->
- Just (listArray b xs, bs'')
-
-shortIntToBytes :: Int -> Bytes -> Bytes
-bytesToShortInt :: Bytes -> Maybe (Int, Bytes)
-longIntToBytes :: Int -> Bytes -> Bytes
-bytesToLongInt :: Bytes -> Maybe (Int, Bytes)
-#if defined(__YALE_HASKELL__)
-shortIntToByteFile :: Int -> ByteFile -> IO ()
-bytesToShortIntIO :: ByteFile -> IO Int
-#endif
-
-#if defined(__YALE_HASKELL__)
--- These functions are like the primIntxx but use a "short" rather than
--- "int" representation.
-shortIntToBytes = primShortShowBytes
-bytesToShortInt = primShortReadBytes
-shortIntToByteFile = primShortShowByteFile
-bytesToShortIntIO = primShortReadByteFile
-
-#else {-! YALE-}
-
-shortIntToBytes s bs = shortToBytes s bs
-
-bytesToShortInt bs = if hasNElems lenShort bs then Just (bytesToShort bs) else Nothing
-
-longIntToBytes s bs = longToBytes s bs
-
-bytesToLongInt bs = if hasNElems lenLong bs then Just (bytesToLong bs) else Nothing
-
-#endif {-! YALE-}
-
-showB :: (Native a) => a -> Bytes
-showB x = showBytes x []
-
-readB :: (Native a) => Bytes -> a
-readB bs =
- case readBytes bs of
- Just (x,[]) -> x
- Just (_,_) -> error "Native.readB data too long"
- Nothing -> error "Native.readB data too short"
-
-#if defined(__YALE_HASKELL__)
-readBFile :: String -> IO(Bytes)
-readBFile name =
- openInputByteFile name >>= \ f ->
- readBytesFromByteFile f
-
-readBytesFromByteFile :: ByteFile -> IO(Bytes)
-readBytesFromByteFile f =
- try
- (primByteReadByteFile f >>= \ h ->
- readBytesFromByteFile f >>= \ t ->
- return (h:t))
- onEOF
- where
- onEOF EOF = closeByteFile f >> return []
- onEOF err = closeByteFile f >> failwith err
-#endif
+++ /dev/null
-module Number(Number, isInteger) where
-data Number = I Integer | F Double
-
-toF (I i) = fromInteger i
-toF (F f) = f
-
-toI (I i) = i
-toI (F f) = round f
-
--- slow!!
-toN x | fromInteger i == x = I i where i = truncate x
-toN x = F x
-
-isInteger (I i) = True
-isInteger (F x) = fromInteger (truncate x) == x
-
-instance Eq Number where
- I x == I y = x == y
- x == y = toF x == toF y
-
-instance Ord Number where
- I x <= I y = x <= y
- x <= y = toF x <= toF y
-
-instance Text Number where
- showsPrec p (I i) = showsPrec p i
--- showsPrec p (F f) | fromInteger i == f = showsPrec p i where i = truncate f
- showsPrec p (F f) =
- let s = reverse (show f)
- s' = if 'e' `notElem` s then dropWhile (=='0') (tail s) else s
- s'' = if head s' == '.' then tail s' else s'
- in showString (reverse s'')
- readsPrec p s = [(I i, s) | (i, s)<-readsPrec p s] ++
- [(F i, s) | (i, s)<-readsPrec p s]
-
-#if defined(__HBC__)
- showsType _ = showString "Number"
-#endif
-
-instance Num Number where
- I x + I y = I (x+y)
- x + y = toN (toF x + toF y)
- I x - I y = I (x-y)
- x - y = toN (toF x - toF y)
- I x * I y = I (x*y)
- x * y = toN (toF x * toF y)
- negate (I x) = I (-x)
- negate (F x) = F (-x)
- abs x = if x <= 0 then -x else x
- signum x = if x <= 0 then if x==0 then 0 else -1 else 1
- fromInteger i = I i
-
-instance Ix Number where
- range (x, y) = [I i | i<-[toI x .. toI y]]
- index (x, y) i = fromInteger (toI i - toI x)
- inRange (x, y) i = toI x <= toI i && toI i <= toI y
-
-instance Integral Number where
- quotRem (I x) (I y) = case quotRem x y of (q,r) -> (I q, I r)
- quotRem x y = let q = truncate (x' / y')
- x' = toF x
- y' = toF y
- in (I q, toN (x' - fromInteger q * y'))
- toInteger (I i) = i
- toInteger (F f) = round f
-
-instance Enum Number where
- enumFrom (I i) = [I x | x<-[i..]]
- enumFrom (F i) = [F x | x<-[i..]]
- enumFromThen (I i) (I j) = [I x | x<-[i,j..]]
- enumFromThen i j = [F x | x<-[toF i,toF j..]]
-
-instance Real Number where
- toRational (I i) = i % 1
- toRational (F f) = toRational f
-
-instance Fractional Number where
- I x / I y | r == 0 = I q where (q,r) = quotRem x y
- x / y = toN (toF x / toF y)
- fromRational r | denominator r == 0 = I (numerator r)
- fromRational r = toN (fromRational r)
-
-instance RealFrac Number where
- properFraction (I i) = (fromInteger i, I 0)
- properFraction (F f) = let (i,x) = properFraction f in (i, toN x)
- truncate (I i) = fromInteger i
- truncate (F f) = truncate f
- round (I i) = fromInteger i
- round (F f) = round f
- ceiling (I i) = fromInteger i
- ceiling (F f) = ceiling f
- floor (I i) = fromInteger i
- floor (F f) = floor f
-
-instance RealFloat Number where
- floatRadix x = floatRadix (toF x)
- floatDigits x = floatDigits (toF x)
- floatRange x = floatRange (toF x)
- decodeFloat x = decodeFloat (toF x)
- encodeFloat m e = toN (encodeFloat m e)
- exponent x = exponent (toF x)
- significand x = toN (significand (toF x))
- scaleFloat n x = toN (scaleFloat n (toF x))
-
-instance Floating Number where
- pi = F pi
- exp = toN . exp . toF
- log = toN . log . toF
- sqrt = toN . sqrt . toF
- x ** y = toN (toF x ** toF y)
- logBase x y = toN (logBase (toF x) (toF y))
- sin = toN . sin . toF
- cos = toN . cos . toF
- tan = toN . tan . toF
- asin = toN . asin . toF
- acos = toN . acos . toF
- atan = toN . atan . toF
- sinh = toN . sinh . toF
- cosh = toN . cosh . toF
- tanh = toN . tanh . toF
- asinh = toN . asinh . toF
- acosh = toN . acosh . toF
- atanh = toN . atanh . toF
-
+++ /dev/null
-module Parse(
- Parser(..), (+.+), (..+), (+..), (|||), (>>>), (||!), (|!!), (.>),
- into, lit, litp, many, many1, succeed, sepBy, count, sepBy1, testp, token, recover,
- ParseResult, parse, sParse, simpleParse,
-#if __HASKELL1__ < 3
- (>>), fail
-#else
- act, failP
-#endif
- ) where
-
---import Trace
-#if __HASKELL1__ < 3
-import {-flummox mkdependHS-}
- Maybe
-import
- Either renaming (Left to Wrong)
-#else
-#define Wrong Left
-#endif
-#if defined(__HBC__)
-import UnsafeDirty(seq)
-#endif
-
-infixr 8 +.+ , ..+ , +..
-#if __HASKELL1__ < 3
-infix 6 >> , `act` , >>>, `into` , .>
-#else
-infix 6 `act` , >>>, `into` , .>
-#endif
-infixr 4 ||| , ||! , |!!
-
-#if !defined(__HBC__)
-seq x y = y --partain: a substitute
-#endif
-
-type ErrMsg = String
-
-data FailAt a
- = FailAt Int{-#STRICT#-} [ErrMsg] a -- token pos, list of acceptable tokens, rest of tokens
- deriving (Text)
-data ParseResult a b
- = Many [(b, Int, a)] (FailAt a) -- parse succeeded with many (>1) parses)
- | One b Int{-#STRICT#-} a (FailAt a){-#STRICT#-} -- parse succeeded with one parse
- | None Bool{-#STRICT#-} (FailAt a){-#STRICT#-} -- parse failed. The Bool indicates hard fail
- deriving (Text)
-
-type Parser a b = a -> Int -> ParseResult a b
-
-noFail = FailAt (-1) [] (error "noFail") -- indicates no failure yet
-
-updFail f (None w f') = None w (bestFailAt f f')
-updFail f (One c n as f') = One c n as (bestFailAt f f')
-updFail f (Many cas f') = let r = bestFailAt f f' in seq r (Many cas r)
-
-bestFailAt f@(FailAt i a t) f'@(FailAt j a' _) =
- if i > j then
- f
- else if j > i then
- f'
- else if i == -1 then
- noFail --FailAt (-1) [] []
- else
- FailAt i (a ++ a') t
-
--- Alternative
-(|||) :: Parser a b -> Parser a b -> Parser a b
-p ||| q = \as n ->
- case (p as n, q as n) of
- (pr@(None True _), _ ) -> pr
- (pr@(None _ f), qr ) -> updFail f qr
- ( One b k as f , qr ) -> Many ((b,k,as) : l') (bestFailAt f f') where (l',f') = lf qr
- ( Many l f , qr ) -> Many ( l++l') (bestFailAt f f') where (l',f') = lf qr
- where lf (Many l f) = (l, f)
- lf (One b k as f) = ([(b,k,as)], f)
- lf (None _ f) = ([], f)
-
--- Alternative, but with committed choice
-(||!) :: Parser a b -> Parser a b -> Parser a b
-p ||! q = \as n ->
- case (p as n, q as n) of
- (pr@(None True _), _ ) -> pr
- ( None _ f , qr ) -> updFail f qr
- (pr , _ ) -> pr
-
-process f [] [] = seq f (None False f)
-process f [(b,k,as)] [] = seq f (One b k as f)
-process f rs [] = seq f (Many rs f)
-process f rs (w@(None True _):_) = seq f w
-process f rs (None False f':rws) = process (bestFailAt f f') rs rws
-process f rs (One b k as f':rws) = process (bestFailAt f f') (rs++[(b,k,as)]) rws
-process f rs (Many rs' f' :rws) = process (bestFailAt f f') (rs++rs') rws
-
-doMany g cas f = Many [ (g c, n, as) | (c,n,as) <- cas] f
-
--- Sequence
-(+.+) :: Parser a b -> Parser a c -> Parser a (b,c)
-p +.+ q =
- \as n->
- case p as n of
- None w f -> None w f
- One b n' as' f ->
- case q as' n' of
- None w f' -> None w (bestFailAt f f')
- One c n'' as'' f' -> One (b,c) n'' as'' (bestFailAt f f')
- Many cas f' -> doMany (\x->(b,x)) cas (bestFailAt f f')
- Many bas f ->
- let rss = [ case q as' n' of { None w f -> None w f;
- One c n'' as'' f' -> One (b,c) n'' as'' f';
- Many cas f' -> doMany (\x->(b,x)) cas f' }
- | (b,n',as') <- bas ]
- in process f [] rss
-
--- Sequence, throw away first part
-(..+) :: Parser a b -> Parser a c -> Parser a c
-p ..+ q = -- p +.+ q `act` snd
- \as n->
- case p as n of
- None w f -> None w f
- One _ n' as' f -> updFail f (q as' n')
- Many bas f -> process f [] [ q as' n' | (_,n',as') <- bas ]
-
--- Sequence, throw away second part
-(+..) :: Parser a b -> Parser a c -> Parser a b
-p +.. q = -- p +.+ q `act` fst
- \as n->
- case p as n of
- None w f -> None w f
- One b n' as' f ->
- case q as' n' of
- None w f' -> None w (bestFailAt f f')
- One _ n'' as'' f' -> One b n'' as'' (bestFailAt f f')
- Many cas f' -> doMany (const b) cas (bestFailAt f f')
- Many bas f ->
- let rss = [ case q as' n' of { None w f -> None w f;
- One _ n'' as'' f' -> One b n'' as'' f';
- Many cas f' -> doMany (const b) cas f' }
- | (b,n',as') <- bas ]
- in process f [] rss
-
--- Return a fixed value
-(.>) :: Parser a b -> c -> Parser a c
-p .> v =
- \as n->
- case p as n of
- None w f -> None w f
- One _ n' as' f' -> One v n' as' f'
- Many bas f -> doMany (const v) bas f
-
--- Action
-#if __HASKELL1__ < 3
-act = (>>)
-(>>) :: Parser a b -> (b->c) -> Parser a c
-p >> f = \as n->
- case p as n of
- None w f -> None w f
- One b n as' ff -> One (f b) n as' ff
- Many bas ff -> doMany f bas ff
-#else
-act :: Parser a b -> (b->c) -> Parser a c
-p `act` f = \as n->
- case p as n of
- None w f -> None w f
- One b n as' ff -> One (f b) n as' ff
- Many bas ff -> doMany f bas ff
-#endif
-
--- Action on two items
-(>>>) :: Parser a (b,c) -> (b->c->d) -> Parser a d
-p >>> f = \as n->
- case p as n of
- None w ff -> None w ff
- One (b,c) n as' ff -> One (f b c) n as' ff
- Many bas ff -> doMany (\ (x,y)->f x y) bas ff
-
--- Use value
-into :: Parser a b -> (b -> Parser a c) -> Parser a c
-p `into` fq = \as n ->
- case p as n of
- None w f -> None w f
- One b n' as' f -> updFail f (fq b as' n')
- Many bas f -> process f [] [ fq b as' n' | (b,n',as') <- bas ]
-
--- Succeeds with a value
-succeed :: b -> Parser a b
-succeed v = \as n -> One v n as noFail
-
--- Always fails.
-#if __HASKELL1__ < 3
-fail :: ErrMsg -> Parser a b
-fail s = \as n -> None False (FailAt n [s] as)
-#else
-failP :: ErrMsg -> Parser a b
-failP s = \as n -> None False (FailAt n [s] as)
-#endif
-
--- Fail completely if parsing proceeds a bit and then fails
-mustAll :: Parser a b -> Parser a b
-mustAll p = \as n->
- case p as n of
- None False f@(FailAt x _ _) | x/=n -> None True f
- r -> r
-
--- If first alternative gives partial parse it's a failure
-p |!! q = mustAll p ||! q
-
--- Kleene star
-many :: Parser a b -> Parser a [b]
-many p = p `into` (\v-> many p `act` (v:))
- ||! succeed []
-
-many1 :: Parser a b -> Parser a [b]
-many1 p = p `into` (\v-> many p `act` (v:))
-
--- Parse an exact number of items
-count :: Parser a b -> Int -> Parser a [b]
-count p 0 = succeed []
-count p k = p +.+ count p (k-1) >>> (:)
-
--- Non-empty sequence of items separated by something
-sepBy1 :: Parser a b -> Parser a c -> Parser a [b]
-p `sepBy1` q = p `into` (\v-> many (q ..+ p) `act` (v:)) -- p +.+ many (q ..+ p) >>> (:) is slower
-
--- Sequence of items separated by something
-sepBy :: Parser a b -> Parser a c -> Parser a [b]
-p `sepBy` q = p `sepBy1` q
- ||! succeed []
-
--- Recognize a literal token
-lit :: (Eq a, Text a) => a -> Parser [a] a
-lit x = \as n ->
- case as of
- a:as' | a==x -> One a (n+1) as' noFail
- _ -> None False (FailAt n [show x] as)
-
--- Recognize a token with a predicate
-litp :: ErrMsg -> (a->Bool) -> Parser [a] a
-litp s p = \as n->
- case as of
- a:as' | p a -> One a (n+1) as' noFail
- _ -> None False (FailAt n [s] as)
-
--- Generic token recognizer
-token :: (a -> Either ErrMsg (b,a)) -> Parser a b
-token f = \as n->
- case f as of
- Wrong s -> None False (FailAt n [s] as)
- Right (b, as') -> One b (n+1) as' noFail
-
--- Test a semantic value
-testp :: String -> (b->Bool) -> Parser a b -> Parser a b
-testp s tst p = \ as n ->
- case p as n of
- None w f -> None w f
- o@(One b _ _ _) -> if tst b then o else None False (FailAt n [s] as)
- Many bas f ->
- case [ r | r@(b, _, _) <- bas, tst b] of
- [] -> None False (FailAt n [s] as)
- [(x,y,z)] -> One x y z f
- rs -> Many rs f
-
--- Try error recovery.
-recover :: Parser a b -> ([ErrMsg] -> a -> Maybe (a, b)) -> Parser a b
-recover p f = \ as n ->
- case p as n of
- r@(None _ fa@(FailAt n ss ts)) ->
- case f ss ts of
- Nothing -> r
- Just (a, b) -> One b (n+1) a fa
- r -> r
-
--- Parse, and check if it was ok.
-parse :: Parser a b -> a -> Either ([ErrMsg],a) [(b, a)]
-parse p as =
- case p as 0 of
- None w (FailAt _ ss ts) -> Wrong (ss,ts)
- One b _ ts _ -> Right [(b,ts)]
- Many bas _ -> Right [(b,ts) | (b,_,ts) <- bas ]
-
-sParse :: (Text a) => Parser [a] b -> [a] -> Either String b
-sParse p as =
- case parse p as of
- Wrong (ss,ts) -> Wrong ("Parse failed at token "++pshow ts++", expected "++unwords ss++"\n")
- where pshow [] = "<EOF>"
- pshow (t:_) = show t
- Right ((b,[]):_) -> Right b
- Right ((_,t:_):_) -> Wrong ("Parse failed at token "++show t++", expected <EOF>\n")
-
-simpleParse :: (Text a) => Parser [a] b -> [a] -> b
-simpleParse p as =
- case sParse p as of
- Wrong msg -> error msg
- Right x -> x
+++ /dev/null
-module Pretty(text, separate, cseparate, nest, pretty, (~.), (^.), IText(..), Context(..)) where
-
-infixr 8 ~.
-infixr 8 ^.
-
-type IText = Context -> [String]
-type Context = (Bool,Int,Int,Int)
--- Bool laying out in vertical context
--- Int character left on the line before margin is reached
--- Int maximum preferred number of significant characters on a line
--- Int number of characters on last line, excluding leading blanks
-
-text :: String -> IText
-text s (v,w,m,m') = [s]
-
-getContext t (v,w,m,m') =
- let tn = last t
- indent = length tn
- sig = if length t == 1
- then m' + indent
- else length (dropWhile (==' ') tn)
- in (False,w-indent,m,sig)
-
-(~.) :: IText -> IText -> IText
-d1 ~. d2 = \ c@(v,w,m,m') ->
- let t = d1 (False,w,m,m')
- cx@(_,w',_,_) = getContext t c
- indent = w-w'
- tn = last t
- (l:ls) = d2 cx
- in init t ++
- [tn ++ l] ++
- map (space indent++) ls
-
-space :: Int -> String
-space n = [' ' | i<-[1..n]]
-
-(^.) :: IText -> IText -> IText
-d1 ^. d2 = \ (v,w,m,m') -> d1 (True,w,m,m') ++ d2 (True,w,m,0)
-
-separate :: [IText] -> IText
-separate [] _ = [""]
-separate ds c@(v,w,m,m') =
- let hor = joinText (text " ") ds
- ver = foldr1 (^.) ds
- t = hor c
- in if lengthLe t 1 && lengthLe (head t) ((w `min` (m-m')) `max` 0)
- then t
- else ver c
-
--- Try to put as many things as possible on each line.
--- Inefficient!
-cseparate :: [IText] -> IText
-cseparate [] _ = [""]
-cseparate ds c@(v,w,m,m') =
- let csep r a (d:ds) =
- let t = joinText (text " ") (a ++ [d]) c
- in if lengthLe t 1 then
- if lengthLe (head t) ((w `min` (m-m')) `max` 0) then
- csep r (a ++ [d]) ds
- else
- csep (r++adda a) [d] ds
- else
- csep (r ++ adda a ++ [d]) [] ds
- csep r a [] = r ++ adda a
- adda [] = []
- adda a = [joinText (text " ") a]
- in foldr1 (^.) (csep [] [] ds) c
-
-joinText t ds = foldr1 (\d1 d2 -> d1 ~. t ~. d2) ds
-
--- Check if the length of a list is less than n, without evaluating it completely.
-lengthLe :: [a] -> Int -> Bool
-lengthLe [] n = n >= 0
-lengthLe (_:_) 0 = False
-lengthLe (_:xs) n = lengthLe xs (n-1)
-
-nest :: Int -> IText -> IText
-nest n d (v,w,m,m') =
- if v then
- map (space n++) (d (v,w-n,m,if m'==0 then 0 else m'+n))
- else
- d (v,w,m,m')
-
-pretty :: Int->Int->IText->String
-pretty w m d = unlines (d (False,w,m,0))
+++ /dev/null
---
--- A C printf like formatter.
--- Conversion specs:
--- - left adjust
--- num field width
--- * as num, but taken from argument list
--- . separates width from precision
--- Formatting characters:
--- c Char, Int, Integer
--- d Char, Int, Integer
--- o Char, Int, Integer
--- x Char, Int, Integer
--- u Char, Int, Integer
--- f Float, Double
--- g Float, Double
--- e Float, Double
--- s String
---
-module Printf(UPrintf(..), printf) where
-
-#if defined(__HBC__)
-import LMLfmtf
-#endif
-
-#if defined(__YALE_HASKELL__)
-import PrintfPrims
-#endif
-
-#if defined(__GLASGOW_HASKELL__)
-import PreludeGlaST
-import TyArray ( _ByteArray(..) )
-#endif
-
-data UPrintf = UChar Char | UString String | UInt Int | UInteger Integer | UFloat Float | UDouble Double
-
-printf :: String -> [UPrintf] -> String
-printf "" [] = ""
-printf "" (_:_) = fmterr
-printf ('%':'%':cs) us = '%':printf cs us
-printf ('%':_) [] = argerr
-printf ('%':cs) us@(_:_) = fmt cs us
-printf (c:cs) us = c:printf cs us
-
-fmt :: String -> [UPrintf] -> String
-fmt cs us =
- let (width, prec, ladj, zero, cs', us') = getSpecs False False cs us
- adjust (pre, str) =
- let lstr = length str
- lpre = length pre
- fill = if lstr+lpre < width then take (width-(lstr+lpre)) (repeat (if zero then '0' else ' ')) else ""
- in if ladj then pre ++ str ++ fill else if zero then pre ++ fill ++ str else fill ++ pre ++ str
- in
- case cs' of
- [] -> fmterr
- c:cs'' ->
- case us' of
- [] -> argerr
- u:us'' ->
- (case c of
- 'c' -> adjust ("", [chr (toint u)])
- 'd' -> adjust (fmti u)
- 'x' -> adjust ("", fmtu 16 u)
- 'o' -> adjust ("", fmtu 8 u)
- 'u' -> adjust ("", fmtu 10 u)
-#if defined __YALE_HASKELL__
- 'e' -> adjust (fmte prec (todbl u))
- 'f' -> adjust (fmtf prec (todbl u))
- 'g' -> adjust (fmtg prec (todbl u))
-#else
- 'e' -> adjust (dfmt c prec (todbl u))
- 'f' -> adjust (dfmt c prec (todbl u))
- 'g' -> adjust (dfmt c prec (todbl u))
-#endif
- 's' -> adjust ("", tostr u)
- c -> perror ("bad formatting char " ++ [c])
- ) ++ printf cs'' us''
-
-fmti (UInt i) = if i < 0 then
- if i == -i then fmti (UInteger (toInteger i)) else ("-", itos (-i))
- else
- ("", itos i)
-fmti (UInteger i) = if i < 0 then ("-", itos (-i)) else ("", itos i)
-fmti (UChar c) = fmti (UInt (ord c))
-fmti u = baderr
-
-fmtu b (UInt i) = if i < 0 then
- if i == -i then itosb b (maxi - toInteger (i+1) - 1) else itosb b (maxi - toInteger (-i))
- else
- itosb b (toInteger i)
-fmtu b (UInteger i) = itosb b i
-fmtu b (UChar c) = itosb b (toInteger (ord c))
-fmtu b u = baderr
-
-maxi :: Integer
-maxi = (toInteger maxInt + 1) * 2
-
-toint (UInt i) = i
-toint (UInteger i) = toInt i
-toint (UChar c) = ord c
-toint u = baderr
-
-tostr (UString s) = s
-tostr u = baderr
-
-todbl (UDouble d) = d
-#if defined(__GLASGOW_HASKELL__)
-todbl (UFloat (F# f)) = D# (float2Double# f) -- What a great system(TM) !
-#else
-todbl (UFloat f) = fromRational (toRational f)
-#endif
-todbl u = baderr
-
-itos n =
- if n < 10 then
- [chr (ord '0' + toInt n)]
- else
- let (q, r) = quotRem n 10 in
- itos q ++ [chr (ord '0' + toInt r)]
-
-chars :: Array Int Char
-#if __HASKELL1__ < 3
-chars = array (0,15) (zipWith (:=) [0..] "0123456789abcdef")
-#else
-chars = array (0,15) (zipWith (\x y -> (x,y)) [0..] "0123456789abcdef")
-#endif
-
-itosb :: Integer -> Integer -> String
-itosb b n =
- if n < b then
- [chars ! fromInteger n]
- else
- let (q, r) = quotRem n b in
- itosb b q ++ [chars ! fromInteger r]
-
-stoi :: Int -> String -> (Int, String)
-stoi a (c:cs) | isDigit c = stoi (a*10 + ord c - ord '0') cs
-stoi a cs = (a, cs)
-
-getSpecs :: Bool -> Bool -> String -> [UPrintf] -> (Int, Int, Bool, Bool, String, [UPrintf])
-getSpecs l z ('-':cs) us = getSpecs True z cs us
-getSpecs l z ('0':cs) us = getSpecs l True cs us
-getSpecs l z ('*':cs) us =
- case us of
- [] -> argerr
- nu : us' ->
- let n = toint nu
- (p, cs'', us'') =
- case cs of
- '.':'*':r -> case us' of { [] -> argerr; pu:us'' -> (toint pu, r, us'') }
- '.':r -> let (n, cs') = stoi 0 r in (n, cs', us')
- _ -> (-1, cs, us')
- in (n, p, l, z, cs'', us'')
-getSpecs l z cs@(c:_) us | isDigit c =
- let (n, cs') = stoi 0 cs
- (p, cs'') = case cs' of
- '.':r -> stoi 0 r
- _ -> (-1, cs')
- in (n, p, l, z, cs'', us)
-getSpecs l z cs us = (0, -1, l, z, cs, us)
-
-#if !defined(__YALE_HASKELL__)
-dfmt :: Char -> Int -> Double -> (String, String)
-#endif
-
-#if defined(__GLASGOW_HASKELL__)
-dfmt c{-e,f, or g-} prec d
- = unsafePerformPrimIO (
- newCharArray (0 :: Int, 511){-pathetic malloc-} `thenStrictlyST` \ sprintf_here ->
- let
- sprintf_fmt = "%1" ++ (if prec < 0 then "" else '.':itos prec) ++ [c]
- in
- _ccall_ sprintf sprintf_here sprintf_fmt d `seqPrimIO`
- freezeCharArray sprintf_here `thenST` \ (_ByteArray _ arr#) ->
- let
- unpack :: Int# -> [Char]
- unpack nh = case (ord# (indexCharArray# arr# nh)) of
- 0# -> []
- ch -> case (nh +# 1#) of
- mh -> C# (chr# ch) : unpack mh
- in
- returnPrimIO (
- case (indexCharArray# arr# 0#) of
- '-'# -> ("-", unpack 1#)
- _ -> ("" , unpack 0#)
- )
- )
-#endif
-
-#if defined(__HBC__)
-dfmt c p d =
- case fmtf ("1" ++ (if p < 0 then "" else '.':itos p) ++ [c]) d of
- '-':cs -> ("-", cs)
- cs -> ("" , cs)
-#endif
-
-#if defined(__YALE_HASKELL__)
-fmte p d =
- case (primFmte p d) of
- '-':cs -> ("-",cs)
- cs -> ("",cs)
-fmtf p d =
- case (primFmtf p d) of
- '-':cs -> ("-",cs)
- cs -> ("",cs)
-fmtg p d =
- case (primFmtg p d) of
- '-':cs -> ("-",cs)
- cs -> ("",cs)
-#endif
-
-perror s = error ("Printf.printf: "++s)
-fmterr = perror "formatting string ended prematurely"
-argerr = perror "argument list ended prematurely"
-baderr = perror "bad argument"
-
-#if defined(__YALE_HASKELL__)
--- This is needed because standard Haskell does not have toInt
-
-toInt :: Integral a => a -> Int
-toInt x = fromIntegral x
-#endif
+++ /dev/null
-{-
- This module implements a sort function using a variation on
- quicksort. It is stable, uses no concatenation and compares
- only with <=.
-
- sortLe sorts with a given predicate
- sort uses the <= method
-
- Author: Lennart Augustsson
--}
-
-module QSort(sortLe, sort) where
-sortLe :: (a -> a -> Bool) -> [a] -> [a]
-sortLe le l = qsort le l []
-
-sort :: (Ord a) => [a] -> [a]
-sort l = qsort (<=) l []
-
--- qsort is stable and does not concatenate.
-qsort le [] r = r
-qsort le [x] r = x:r
-qsort le (x:xs) r = qpart le x xs [] [] r
-
--- qpart partitions and sorts the sublists
-qpart le x [] rlt rge r =
- -- rlt and rge are in reverse order and must be sorted with an
- -- anti-stable sorting
- rqsort le rlt (x:rqsort le rge r)
-qpart le x (y:ys) rlt rge r =
- if le x y then
- qpart le x ys rlt (y:rge) r
- else
- qpart le x ys (y:rlt) rge r
-
--- rqsort is as qsort but anti-stable, i.e. reverses equal elements
-rqsort le [] r = r
-rqsort le [x] r = x:r
-rqsort le (x:xs) r = rqpart le x xs [] [] r
-
-rqpart le x [] rle rgt r =
- qsort le rle (x:qsort le rgt r)
-rqpart le x (y:ys) rle rgt r =
- if le y x then
- rqpart le x ys (y:rle) rgt r
- else
- rqpart le x ys rle (y:rgt) r
-
+++ /dev/null
-{-
- This module implements a (good) random number generator.
-
- The June 1988 (v31 #6) issue of the Communications of the ACM has an
- article by Pierre L'Ecuyer called, "Efficient and Portable Combined
- Random Number Generators". Here is the Portable Combined Generator of
- L'Ecuyer for 32-bit computers. It has a period of roughly 2.30584e18.
-
- Transliterator: Lennart Augustsson
--}
-
-module Random(randomInts, randomDoubles, normalRandomDoubles) where
--- Use seeds s1 in 1..2147483562 and s2 in 1..2147483398 to generate
--- an infinite list of random Ints.
-randomInts :: Int -> Int -> [Int]
-randomInts s1 s2 =
- if 1 <= s1 && s1 <= 2147483562 then
- if 1 <= s2 && s2 <= 2147483398 then
- rands s1 s2
- else
- error "randomInts: Bad second seed."
- else
- error "randomInts: Bad first seed."
-
-rands :: Int -> Int -> [Int]
-rands s1 s2 = z' : rands s1'' s2''
- where z' = if z < 1 then z + 2147483562 else z
- z = s1'' - s2''
-
- k = s1 `quot` 53668
- s1' = 40014 * (s1 - k * 53668) - k * 12211
- s1'' = if s1' < 0 then s1' + 2147483563 else s1'
-
- k' = s2 `quot` 52774
- s2' = 40692 * (s2 - k' * 52774) - k' * 3791
- s2'' = if s2' < 0 then s2' + 2147483399 else s2'
-
--- Same values for s1 and s2 as above, generates an infinite
--- list of Doubles uniformly distibuted in (0,1).
-randomDoubles :: Int -> Int -> [Double]
-randomDoubles s1 s2 = map (\x -> fromIntegral x * 4.6566130638969828e-10) (randomInts s1 s2)
-
--- The normal distribution stuff is stolen from Tim Lambert's
--- M*****a version
-
--- normalRandomDoubles is given two seeds and returns an infinite list of random
--- normal variates with mean 0 and variance 1. (Box Muller method see
--- "Art of Computer Programming Vol 2")
-normalRandomDoubles :: Int -> Int -> [Double]
-normalRandomDoubles s1 s2 = boxMuller (map (\x->2*x-1) (randomDoubles s1 s2))
-
--- boxMuller takes a stream of uniform random numbers on [-1,1] and
--- returns a stream of normally distributed random numbers.
-boxMuller :: [Double] -> [Double]
-boxMuller (x1:x2:xs) | r <= 1 = x1*m : x2*m : rest
- | otherwise = rest
- where r = x1*x1 + x2*x2
- m = sqrt(-2*log r/r)
- rest = boxMuller xs
+++ /dev/null
--- A very simple, but useful, lexical analyser.
-module SimpleLex(simpleLex) where
-
-oper = "!#$%&*+./<=>?@\\^|:~-"
--- self-delim ()[]{},;`'"_
-isalunum c = isAlphanum c || c == '_'
-
-simpleLex :: String -> [String]
-simpleLex "" = []
-simpleLex (' ' :cs) = simpleLex cs -- ignore white space
-simpleLex ('\t':cs) = simpleLex cs
-simpleLex ('\n':cs) = simpleLex cs
-simpleLex ('-':cs@(c:_)) | isDigit c = -- negative numbers
- let (t:ts) = simpleLex cs
- in ('-':t) : ts
-simpleLex (c:cs) | isDigit c = -- numbers (with optional .)
- let (nn, cs') = span isDigit cs
- in case cs' of
- '.':cs'' -> let (d,r) = span isDigit cs''
- in (c:nn++'.':d) : simpleLex r
- _ -> (c:nn) : simpleLex cs'
-simpleLex (c:cs) | isAlpha c = -- identifiers
- let (nn, cs') = span isalunum cs in (c:nn) : simpleLex cs'
-simpleLex (c:cs) | c `elem` oper = -- operator
- let (nn, cs') = span (`elem` oper) cs in (c:nn) : simpleLex cs'
-simpleLex (c:cs) = [c] : simpleLex cs -- self delimiting chars
+++ /dev/null
-module Time(Time(..), dblToTime, timeToDbl, timeToString) where
--- year mon day hour min sec ... wday
-data Time = Time Int Int Int Int Int Int Double Int deriving (Eq, Ord, Text)
-
-isleap :: Int -> Bool
-isleap n = n `rem` 4 == 0 -- good enough for the UNIX time span
-
-daysin :: Int -> Int
-daysin n = if isleap n then 366 else 365
-
-monthlen :: Array (Bool, Int) Int
-#if __HASKELL1__ < 3
-monthlen = array ((False, 1), (True, 12)) (zipWith3 (\ a b c -> (a,b):=c) (repeat False) [1..] [31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31] ++
- zipWith3 (\ a b c -> (a,b):=c) (repeat True) [1..] [31, 29, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31])
-#else
-monthlen = array ((False, 1), (True, 12)) (zipWith3 (\ a b c -> ((a,b),c)) (repeat False) [1..] [31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31] ++
- zipWith3 (\ a b c -> ((a,b),c)) (repeat True) [1..] [31, 29, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31])
-#endif
-
-dblToTime :: Double -> Time
-dblToTime d =
- let t = truncate d :: Int
- (days, rem) = t `quotRem` (60*60*24)
- (hour, rem') = rem `quotRem` (60*60)
- (min, sec) = rem' `quotRem` 60
- wday = (days+3) `mod` 7
- (year, days')= until (\ (y, d) -> d < daysin y) (\ (y, d) -> (y+1, d - daysin y)) (1970, days)
- (mon, day) = until (\ (m, d) -> d < monthlen!(isleap year, m)) (\ (m, d) -> (m+1, d - monthlen!(isleap year, m))) (1, days')
- in Time year mon (day+1) hour min sec (d - fromInt t) wday
-
-timeToDbl :: Time -> Double
-timeToDbl (Time year mon day hour min sec sdec _) =
- let year' = year - 1970
- days = year' * 365 + (year'+1) `div` 4 +
- sum [monthlen!(isleap year, m) | m<-[1..mon-1]] + day - 1
- secs = ((days*24 + hour) * 60 + min) * 60 + sec
- in fromInt secs + sdec
-
-show2 :: Int -> String
-show2 x = [chr (x `quot` 10 + ord '0'), chr (x `rem` 10 + ord '0')]
-
-weekdays = ["Mon","Tue","Wed","Thu","Fri","Sat","Sun"]
-
-timeToString :: Time -> String
-timeToString (Time year mon day hour min sec sdec wday) =
- show year ++ "-" ++ show2 mon ++ "-" ++ show2 day ++ " " ++
- show2 hour ++ ":" ++ show2 min ++ ":" ++ show2 sec ++
- tail (take 5 (show sdec)) ++ " " ++ weekdays!!wday
-
-#if defined(__YALE_HASKELL__)
--- For those of you who don't have fromInt
-fromInt = fromInteger . toInteger
-#endif
+++ /dev/null
-module Trace where
-trace x y = _trace x y
+++ /dev/null
--- mimic "hbc_library" module, Word.
--- [seriously non-std Haskell here]
---
-module Word (
- Bits(..), -- class
- Byte, Short, Word, -- data types: abstract
- byteToInt, shortToInt, wordToInt,
- wordToShorts, wordToBytes, bytesToString
- ) where
-
-infixl 8 `bitLsh`, `bitRsh`
-infixl 7 `bitAnd`
-infixl 6 `bitXor`
-infixl 5 `bitOr`
-
-class Bits a where
- bitAnd, bitOr, bitXor :: a -> a -> a
- bitCompl :: a -> a
- bitRsh, bitLsh :: a -> Int -> a
- bitSwap :: a -> a
- bit0 :: a
- bitSize :: a -> Int
-
-------------------------------------------------------------------
-data Word = Word Word# deriving (Eq, Ord)
-
-instance Bits Word where
- bitAnd (Word x) (Word y) = case and# x y of z -> Word z
- bitOr (Word x) (Word y) = case or# x y of z -> Word z
- bitXor (Word x) (Word y) = error "later..." -- Word (XOR x y)
- bitCompl (Word x) = case not# x of x' -> Word x'
- bitLsh (Word x) (I# y) = case shiftL# x y of z -> Word z
- bitRsh (Word x) (I# y) = case shiftRL# x y of z -> Word z
- bitSwap (Word x) = --Word (OR (LSH x 16) (AND (RSH x 16) 65535))
- case shiftL# x 16# of { a# ->
- case shiftRL# x 16# of { b# ->
- case and# b# (i2w 65535#) of { c# ->
- case or# a# c# of { r# ->
- Word r# }}}}
- bit0 = Word (i2w 1#)
- bitSize (Word _) = 32
-
-w2i x = word2Int# x
-i2w x = int2Word# x
-
-instance Num Word where
- Word x + Word y = case plusInt# (w2i x) (w2i y) of z -> Word (i2w z)
- Word x - Word y = case minusInt# (w2i x) (w2i y) of z -> Word (i2w z)
- Word x * Word y = case timesInt# (w2i x) (w2i y) of z -> Word (i2w z)
- negate (Word x) = case negateInt# (w2i x) of z -> Word (i2w z)
- fromInteger (J# a# s# d#)
- = case integer2Int# a# s# d# of { z# ->
- Word (i2w z#) }
- fromInt (I# x) = Word (i2w x)
-
-instance Text Word where
- showsPrec _ (Word w) =
- let i = toInteger (I# (w2i w)) + (if geWord# w (i2w 0#) then 0 else 2*(toInteger maxInt + 1))
- in showString (conv 8 i)
-
-conv :: Int -> Integer -> String
-conv 0 _ = ""
-conv n i = conv (n-1) q ++ ["0123456789ABCDEF"!!r] where (q, r) = quotRem i 16
-
-------------------------------------------------------------------
-data Short = Short Word# deriving (Eq, Ord)
-
-sHORTMASK x = and# x (i2w 65535#)
-
-instance Bits Short where
- bitAnd (Short x) (Short y) = case and# x y of z -> Short z
- bitOr (Short x) (Short y) = case or# x y of z -> Short z
- bitXor (Short x) (Short y) = error "later..." -- Short (XOR x y)
- bitCompl (Short x) = case not# x of x' -> Short (sHORTMASK x')
- bitLsh (Short x) (I# y) = case shiftL# x y of z -> Short (sHORTMASK z)
- bitRsh (Short x) (I# y) = case shiftRL# x y of z -> Short z
- bitSwap (Short x) = --Short (SHORTMASK(OR (LSH x 8) (AND (RSH x 8) 255)))
- case shiftL# x 8# of { a# ->
- case shiftRL# x 8# of { b# ->
- case and# b# (i2w 255#) of { c# ->
- case or# a# c# of { r# ->
- Short (sHORTMASK r#) }}}}
- bit0 = Short (i2w 1#)
- bitSize (Short _) = 16
-
-instance Num Short where
- Short x + Short y = case plusInt# (w2i x) (w2i y) of z -> Short (sHORTMASK (i2w z))
- Short x - Short y = case minusInt# (w2i x) (w2i y) of z -> Short (sHORTMASK (i2w z))
- Short x * Short y = case timesInt# (w2i x) (w2i y) of z -> Short (sHORTMASK (i2w z))
- negate (Short x) = case negateInt# (w2i x) of z -> Short (sHORTMASK (i2w z))
- fromInteger (J# a# s# d#)
- = case integer2Int# a# s# d# of { z# ->
- Short (sHORTMASK (i2w z#)) }
- fromInt (I# x) = Short (sHORTMASK (i2w x))
-
-instance Text Short where
- showsPrec _ (Short w) =
- let i = toInteger (I# (w2i w))
- in showString (conv 4 i)
--- showsType _ = showString "Short"
-
-------------------------------------------------------------------
-data Byte = Byte Word# deriving (Eq, Ord)
-
-bYTEMASK x = and# x (i2w 255#)
-
-instance Bits Byte where
- bitAnd (Byte x) (Byte y) = case and# x y of z -> Byte z
- bitOr (Byte x) (Byte y) = case or# x y of z -> Byte z
- bitXor (Byte x) (Byte y) = error "later..." -- Byte (XOR x y)
- bitCompl (Byte x) = case not# x of x' -> Byte (bYTEMASK x')
- bitLsh (Byte x) (I# y) = case shiftL# x y of z -> Byte (bYTEMASK z)
- bitRsh (Byte x) (I# y) = case shiftRL# x y of z -> Byte z
- bitSwap (Byte x) = --Byte (BYTEMASK(OR (LSH x 4) (AND (RSH x 8) 15)))
- case shiftL# x 4# of { a# ->
- case shiftRL# x 8# of { b# ->
- case and# b# (i2w 15#) of { c# ->
- case or# a# c# of { r# ->
- Byte (bYTEMASK r#) }}}}
- bit0 = Byte (i2w 1#)
- bitSize (Byte _) = 8
-
-instance Num Byte where
- Byte x + Byte y = case plusInt# (w2i x) (w2i y) of z -> Byte (bYTEMASK (i2w z))
- Byte x - Byte y = case minusInt# (w2i x) (w2i y) of z -> Byte (bYTEMASK (i2w z))
- Byte x * Byte y = case timesInt# (w2i x) (w2i y) of z -> Byte (bYTEMASK (i2w z))
- negate (Byte x) = case negateInt# (w2i x) of z -> Byte (bYTEMASK (i2w z))
- fromInteger (J# a# s# d#)
- = case integer2Int# a# s# d# of { z# ->
- Byte (bYTEMASK (i2w z#)) }
- fromInt (I# x) = Byte (bYTEMASK (i2w x))
-
-instance Text Byte where
- showsPrec _ (Byte w) =
- let i = toInteger (I# (w2i w))
- in showString (conv 2 i)
--- showsType _ = showString "Byte"
-
-------------------------------------------------------------------
-wordToShorts (Word w) = [Short (sHORTMASK(shiftRL# w 16#)), Short (sHORTMASK(w))]
-wordToBytes (Word w) = [Byte (bYTEMASK(shiftRL# w 24#)), Byte (bYTEMASK(shiftRL# w 16#)), Byte (bYTEMASK(shiftRL# w 8#)), Byte (bYTEMASK(w))]
-
-bytesToString :: [Byte] -> String
-bytesToString bs = map (\ (Byte b) -> chr (I# (w2i b))) bs
-
-stringToBytes :: String -> [Byte]
-stringToBytes cs = map (\c -> Byte (case ord c of {I# i -> bYTEMASK (i2w i)})) cs
-
-wordToInt :: Word -> Int
-wordToInt (Word w) = I# (w2i w)
-
-shortToInt :: Short -> Int
-shortToInt (Short w) = I# (w2i w)
-
-byteToInt :: Byte -> Int
-byteToInt (Byte w) = I# (w2i w)
projects / ghc-hetmet.git / commitdiff