%
% (c) The AQUA Project, Glasgow University, 1994-1996
%
-
\section[ArrBase]{Module @ArrBase@}
+Array implementation, @ArrBase@ exports the basic array
+types and operations.
+
\begin{code}
{-# OPTIONS -fno-implicit-prelude #-}
-module ArrBase where
+module ArrBase where
import {-# SOURCE #-} IOBase ( error )
import Ix
data Ix ix => ByteArray ix = ByteArray (ix,ix) ByteArray#
data Ix ix => MutableArray s ix elt = MutableArray (ix,ix) (MutableArray# s elt)
data Ix ix => MutableByteArray s ix = MutableByteArray (ix,ix) (MutableByteArray# s)
+
+-- A one-element mutable array:
+type MutableVar s a = MutableArray s Int a
\end{code}
fill_it_in :: Ix ix => MutableArray s ix elt -> [(ix, elt)] -> ST s ()
fill_it_in arr lst
- = foldr fill_one_in (returnStrictlyST ()) lst
+ = foldr fill_one_in (returnST ()) lst
where -- **** STRICT **** (but that's OK...)
fill_one_in (i, v) rst
- = writeArray arr i v `seqStrictlyST` rst
+ = writeArray arr i v `seqST` rst
-----------------------------------------------------------------------
-- these also go better with magic: (//), accum, accumArray
old_array // ivs
= runST (
-- copy the old array:
- thawArray old_array `thenStrictlyST` \ arr ->
+ thawArray old_array `thenST` \ arr ->
-- now write the new elements into the new array:
- fill_it_in arr ivs `seqStrictlyST`
+ fill_it_in arr ivs `seqST`
freezeArray arr
)
where
-- zap_with_f: reads an elem out first, then uses "f" on that and the new value
zap_with_f f arr lst
- = foldr zap_one (returnStrictlyST ()) lst
+ = foldr zap_one (returnST ()) lst
where
zap_one (i, new_v) rst
- = readArray arr i `thenStrictlyST` \ old_v ->
- writeArray arr i (f old_v new_v) `seqStrictlyST`
+ = readArray arr i `thenST` \ old_v ->
+ writeArray arr i (f old_v new_v) `seqST`
rst
accum f old_array ivs
= runST (
-- copy the old array:
- thawArray old_array `thenStrictlyST` \ arr ->
+ thawArray old_array `thenST` \ arr ->
-- now zap the elements in question with "f":
zap_with_f f arr ivs >>
copy cur# end# from# to# s#
| cur# ==# end#
= StateAndMutableArray# s# to#
- | True
+ | otherwise
= case readArray# from# cur# s# of { StateAndPtr# s1# ele ->
case writeArray# to# cur# ele s1# of { s2# ->
copy (cur# +# 1#) end# from# to# s2#
copy cur# end# from# to# s#
| cur# ==# end#
= StateAndMutableByteArray# s# to#
- | True
+ | otherwise
= case (readCharArray# from# cur# s#) of { StateAndChar# s1# ele ->
case (writeCharArray# to# cur# ele s1#) of { s2# ->
copy (cur# +# 1#) end# from# to# s2#
copy cur# end# from# to# s#
| cur# ==# end#
= StateAndMutableByteArray# s# to#
- | True
+ | otherwise
= case (readIntArray# from# cur# s#) of { StateAndInt# s1# ele ->
case (writeIntArray# to# cur# ele s1#) of { s2# ->
copy (cur# +# 1#) end# from# to# s2#
copy cur# end# from# to# s#
| cur# ==# end#
= StateAndMutableByteArray# s# to#
- | True
+ | otherwise
= case (readAddrArray# from# cur# s#) of { StateAndAddr# s1# ele ->
case (writeAddrArray# to# cur# ele s1#) of { s2# ->
copy (cur# +# 1#) end# from# to# s2#
copy cur# end# from# to# s#
| cur# ==# end#
= StateAndMutableByteArray# s# to#
- | True
+ | otherwise
= case (readFloatArray# from# cur# s#) of { StateAndFloat# s1# ele ->
case (writeFloatArray# to# cur# ele s1#) of { s2# ->
copy (cur# +# 1#) end# from# to# s2#
copy cur# end# from# to# s#
| cur# ==# end#
= StateAndMutableByteArray# s# to#
- | True
+ | otherwise
= case (readDoubleArray# from# cur# s#) of { StateAndDouble# s1# ele ->
case (writeDoubleArray# to# cur# ele s1#) of { s2# ->
copy (cur# +# 1#) end# from# to# s2#
copy cur# end# from# to# s#
| cur# ==# end#
= StateAndMutableArray# s# to#
- | True
+ | otherwise
= case indexArray# from# cur# of { Lift ele ->
case writeArray# to# cur# ele s# of { s1# ->
copy (cur# +# 1#) end# from# to# s1#
Basic concurrency stuff
\begin{code}
+{-# OPTIONS -fno-implicit-prelude #-}
module ConcBase(
-- Forking and suchlike
ST, forkST,
MVar, newMVar, newEmptyMVar, takeMVar, putMVar, readMVar, swapMVar
) where
-import Prelude
+import PrelBase
import STBase ( PrimIO(..), ST(..), State(..), StateAndPtr#(..) )
-import IOBase ( IO(..) )
+import IOBase ( IO(..), MVar(..) )
import GHCerr ( parError )
import PrelBase ( Int(..) )
import GHC ( fork#, delay#, waitRead#, waitWrite#,
SynchVar#, newSynchVar#, takeMVar#, putMVar#,
- State#, RealWorld
+ State#, RealWorld, par#
)
infixr 0 `par`, `fork`
writes.
\begin{code}
-data MVar a = MVar (SynchVar# RealWorld a)
+--Defined in IOBase to avoid cycle: data MVar a = MVar (SynchVar# RealWorld a)
newEmptyMVar :: IO (MVar a)
->
Void
- void
+-- void CAF is defined in PrelBase
-- I/O primitives
RealWorld
fork#
delay#
-
+ seq#
+ par#
+ parGlobal#
+ parLocal#
+ parAt#
+ parAtForNow#
+
SynchVar#
newSynchVar#
takeMVar#
MutableByteArray#
sameMutableArray#
+ sameMutableByteArray#
newArray#
newCharArray#
indexDoubleArray#
indexAddrArray#
- indexOffAddr#
- indexCharOffAddr#
- indexIntOffAddr#
- indexFloatOffAddr#
- indexDoubleOffAddr#
- indexAddrOffAddr#
+-- indexOffAddr#
+indexCharOffAddr#
+indexIntOffAddr#
+indexFloatOffAddr#
+indexDoubleOffAddr#
+indexAddrOffAddr#
writeArray#
writeCharArray#
with what the typechecker figures out.
\begin{code}
+{-# OPTIONS -fno-implicit-prelude #-}
module GHCerr where
-import Prelude
+--import Prelude
+import PrelBase
+import PrelList ( span )
import IOBase
---------------------------------------------------------------
--{-# GENERATE_SPECS build a #-}
--build :: ((a -> [a] -> [a]) -> [a] -> [a]) -> [a]
--build g = g (:) []
+\end{code}
----------------------------------------------------------------
--- Used for compiler-generated error message;
--- encoding saves bytes of string junk.
+Used for compiler-generated error message;
+encoding saves bytes of string junk.
+\begin{code}
absentErr, parError :: a
+
+absentErr = error "Oops! The program has entered an `absent' argument!\n"
+parError = error "Oops! Entered GHCerr.parError (a GHC bug -- please report it!)\n"
+\end{code}
+
+\begin{code}
irrefutPatError
, noDefaultMethodError
, noExplicitMethodError
, recConError
, recUpdError :: String -> a
-absentErr = error "Oops! The program has entered an `absent' argument!\n"
-parError = error "Oops! Entered GHCerr.parError (a GHC bug -- please report it!)\n"
-
noDefaultMethodError s = error ("noDefaultMethodError:"++s)
noExplicitMethodError s = error ("No default method for class operation "++s)
+irrefutPatError s = error (untangle s "Irrefutable pattern failed for pattern")
+nonExhaustiveGuardsError s = error (untangle s "Non-exhaustive guards in")
+patError s = error (untangle s "Non-exhaustive patterns in")
+recConError s = error (untangle s "Missing field in record construction:")
+recUpdError s = error (untangle s "Record to doesn't contain field(s) to be updated")
+\end{code}
+
-irrefutPatError s = patError__ (untangle s "irrefutable pattern")
-nonExhaustiveGuardsError s = patError__ (untangle s "non-exhaustive guards")
-patError s = patError__ (untangle s "pattern-matching")
+(untangle coded message) expects "coded" to be of the form
-patError__ = error__ (\ x -> _ccall_ PatErrorHdrHook x)
+ "location|details"
-recConError s = error (untangle s "record constructor")
-recUpdError s = error (untangle s "record update")
+It prints
-untangle coded in_str
- = "In " ++ in_str
- ++ (if null msg then "" else (": " ++ msg))
- ++ "; at " ++ file
- ++ ", line " ++ line
+ location message details
+
+\begin{code}
+untangle coded message
+ = location
+ ++ ": "
+ ++ message
+ ++ details
++ "\n"
where
- (file,line,msg)
- = case (span not_bar coded) of { (f, (_:rest)) ->
- case (span not_bar rest) of { (l, (_:m)) ->
- (f,l,m) }}
+ (location, details)
+ = case (span not_bar coded) of { (location, rest) ->
+ case rest of
+ ('|':details) -> (location, ' ' : details)
+ _ -> (location, "")
+ }
not_bar c = c /= '|'
\end{code}
+
+-- This local variant of "error" calls PatErrorHdrHook instead of ErrorHdrHook,
+-- but the former does exactly the same as the latter, so I nuked it.
+-- SLPJ Jan 97
+-- patError__ = error__ (\ x -> _ccall_ PatErrorHdrHook x)
+
import Foreign
import PackedString ( unpackCString )
import PrelBase
+import PrelRead
import GHC
+import ArrBase ( ByteArray(..), MutableVar(..) )
infixr 1 `thenIO_Prim`
\end{code}
map f x = x >>= (return . f)
instance Monad IO where
-{- No inlining for now... until we can inline some of the
- imports, like $, these functions are pretty big.
{-# INLINE return #-}
{-# INLINE (>>) #-}
{-# INLINE (>>=) #-}
--}
m >> k = m >>= \ _ -> k
return x = IO $ ST $ \ s@(S# _) -> (Right x, s)
fail err = IO $ ST $ \ s -> (Left err, s)
userError :: String -> IOError
-userError str = UserError str
+userError str = IOError Nothing UserError str
catch :: IO a -> (IOError -> IO a) -> IO a
catch (IO (ST m)) k = IO $ ST $ \ s ->
%* *
%*********************************************************
+A value @IOError@ encode errors occurred in the @IO@ monad.
+An @IOError@ records a more specific error type, a descriptive
+string and maybe the handle that was used when the error was
+flagged.
+
\begin{code}
-data IOError
- = AlreadyExists String
- | HardwareFault String
- | IllegalOperation String
- | InappropriateType String
- | Interrupted String
- | InvalidArgument String
- | NoSuchThing String
- | OtherError String
- | PermissionDenied String
- | ProtocolError String
- | ResourceBusy String
- | ResourceExhausted String
- | ResourceVanished String
- | SystemError String
- | TimeExpired String
- | UnsatisfiedConstraints String
- | UnsupportedOperation String
- | UserError String
- | EOF
+data IOError
+ = IOError
+ (Maybe Handle) -- the handle used by the action flagging the
+ -- the error.
+ IOErrorType -- what it was.
+ String -- error type specific information.
instance Eq IOError where
- -- I don't know what the (pointless) idea is here,
- -- presumably just compare them by their tags (WDP)
- a == b = tag a == tag b
- where
- tag (AlreadyExists _) = (1::Int)
- tag (HardwareFault _) = 2
- tag (IllegalOperation _) = 3
- tag (InappropriateType _) = 4
- tag (Interrupted _) = 5
- tag (InvalidArgument _) = 6
- tag (NoSuchThing _) = 7
- tag (OtherError _) = 8
- tag (PermissionDenied _) = 9
- tag (ProtocolError _) = 10
- tag (ResourceBusy _) = 11
- tag (ResourceExhausted _) = 12
- tag (ResourceVanished _) = 13
- tag (SystemError _) = 14
- tag (TimeExpired _) = 15
- tag (UnsatisfiedConstraints _) = 16
- tag (UnsupportedOperation _) = 17
- tag (UserError _) = 18
- tag EOF = 19
+ (IOError h1 e1 str1) == (IOError h2 e2 str2) =
+ e1==e2 && str1==str2 && h1==h2
+
+data IOErrorType
+ = AlreadyExists | HardwareFault
+ | IllegalOperation | InappropriateType
+ | Interrupted | InvalidArgument
+ | NoSuchThing | OtherError
+ | PermissionDenied | ProtocolError
+ | ResourceBusy | ResourceExhausted
+ | ResourceVanished | SystemError
+ | TimeExpired | UnsatisfiedConstraints
+ | UnsupportedOperation | UserError
+ | EOF
+ deriving (Eq, Show)
+
\end{code}
-Predicates on IOError; almost no effort made on these so far...
+Predicates on IOError; little effort made on these so far...
\begin{code}
-isAlreadyExistsError (AlreadyExists _) = True
-isAlreadyExistsError _ = False
+isAlreadyExistsError (IOError _ AlreadyExists _) = True
+isAlreadyExistsError _ = False
+
+isAlreadyInUseError (IOError _ ResourceBusy _) = True
+isAlreadyInUseError _ = False
-isAlreadyInUseError (ResourceBusy _) = True
-isAlreadyInUseError _ = False
+isFullError (IOError _ ResourceExhausted _) = True
+isFullError _ = False
-isFullError (ResourceExhausted _) = True
-isFullError _ = False
+isEOFError (IOError _ EOF _) = True
+isEOFError _ = True
-isEOFError EOF = True
-isEOFError _ = True
+isIllegalOperation (IOError _ IllegalOperation _) = True
+isIllegalOperation _ = False
-isIllegalOperation (IllegalOperation _) = True
-isIllegalOperation _ = False
+isPermissionError (IOError _ PermissionDenied _) = True
+isPermissionError _ = False
-isPermissionError (PermissionDenied _) = True
-isPermissionError _ = False
+isDoesNotExistError (IOError _ NoSuchThing _) = True
+isDoesNotExistError _ = False
-isUserError (UserError s) = Just s
-isUserError _ = Nothing
+isUserError (IOError _ UserError s) = Just s
+isUserError _ = Nothing
\end{code}
Showing @IOError@s
\begin{code}
instance Show IOError where
- showsPrec p (AlreadyExists s) = show2 "AlreadyExists: " s
- showsPrec p (HardwareFault s) = show2 "HardwareFault: " s
- showsPrec p (IllegalOperation s) = show2 "IllegalOperation: " s
- showsPrec p (InappropriateType s) = show2 "InappropriateType: " s
- showsPrec p (Interrupted s) = show2 "Interrupted: " s
- showsPrec p (InvalidArgument s) = show2 "InvalidArgument: " s
- showsPrec p (NoSuchThing s) = show2 "NoSuchThing: " s
- showsPrec p (OtherError s) = show2 "OtherError: " s
- showsPrec p (PermissionDenied s) = show2 "PermissionDenied: " s
- showsPrec p (ProtocolError s) = show2 "ProtocolError: " s
- showsPrec p (ResourceBusy s) = show2 "ResourceBusy: " s
- showsPrec p (ResourceExhausted s) = show2 "ResourceExhausted: " s
- showsPrec p (ResourceVanished s) = show2 "ResourceVanished: " s
- showsPrec p (SystemError s) = show2 "SystemError: " s
- showsPrec p (TimeExpired s) = show2 "TimeExpired: " s
- showsPrec p (UnsatisfiedConstraints s) = show2 "UnsatisfiedConstraints: " s
- showsPrec p (UnsupportedOperation s)= show2 "UnsupportedOperation: " s
- showsPrec p (UserError s) = showString s
- showsPrec p EOF = showString "EOF"
-
-show2 x y = showString x . showString y
+ showsPrec p (IOError _ UserError s) rs =
+ showString s rs
+ showsPrec p (IOError _ EOF _) rs =
+ showsPrec p EOF rs
+ showsPrec p (IOError _ iot s) rs =
+ showsPrec p
+ iot
+ (case s of {
+ "" -> rs;
+ _ -> showString ": " $
+ showString s rs})
-{-
+\end{code}
The @String@ part of an @IOError@ is platform-dependent. However, to
provide a uniform mechanism for distinguishing among errors within
explicitly mentioned in the standard, any descriptive string may be
used.
- SOF 4/96 - added argument to indicate function that flagged error
--}
-constructErrorAndFail :: String -> IO a
-constructError :: String -> PrimIO IOError
+\begin{change}
+SOF & 4/96 & added argument to indicate function that flagged error
+\end{change}
+% Hmm..does these envs work?!...SOF
+\begin{code}
+constructErrorAndFail :: String -> IO a
constructErrorAndFail call_site
= stToIO (constructError call_site) >>= \ io_error ->
fail io_error
-constructError call_site
- = _casm_ ``%r = ghc_errtype;'' >>= \ (I# errtype#) ->
- _casm_ ``%r = ghc_errstr;'' >>= \ str ->
- let
- msg = call_site ++ ':' : ' ' : unpackCString str
- in
- return (case errtype# of
- ERR_ALREADYEXISTS# -> AlreadyExists msg
- ERR_HARDWAREFAULT# -> HardwareFault msg
- ERR_ILLEGALOPERATION# -> IllegalOperation msg
- ERR_INAPPROPRIATETYPE# -> InappropriateType msg
- ERR_INTERRUPTED# -> Interrupted msg
- ERR_INVALIDARGUMENT# -> InvalidArgument msg
- ERR_NOSUCHTHING# -> NoSuchThing msg
- ERR_OTHERERROR# -> OtherError msg
- ERR_PERMISSIONDENIED# -> PermissionDenied msg
- ERR_PROTOCOLERROR# -> ProtocolError msg
- ERR_RESOURCEBUSY# -> ResourceBusy msg
- ERR_RESOURCEEXHAUSTED# -> ResourceExhausted msg
- ERR_RESOURCEVANISHED# -> ResourceVanished msg
- ERR_SYSTEMERROR# -> SystemError msg
- ERR_TIMEEXPIRED# -> TimeExpired msg
- ERR_UNSATISFIEDCONSTRAINTS# -> UnsatisfiedConstraints msg
- ERR_UNSUPPORTEDOPERATION# -> UnsupportedOperation msg
- ERR_EOF# -> EOF
- _ -> OtherError "bad error construct"
- )
\end{code}
+This doesn't seem to be documented/spelled out anywhere,
+so here goes: (SOF)
+
+The implementation of the IO prelude uses various C stubs
+to do the actual interaction with the OS. The bandwidth
+\tr{C<->Haskell} is somewhat limited, so the general strategy
+for flaggging any errors (apart from possibly using the
+return code of the external call), is to set the @ghc_errtype@
+to a value that is one of the \tr{#define}s in @includes/error.h@.
+@ghc_errstr@ holds a character string providing error-specific
+information.
+
+\begin{code}
+constructError :: String -> PrimIO IOError
+constructError call_site =
+ _casm_ ``%r = ghc_errtype;'' >>= \ (I# errtype#) ->
+ _casm_ ``%r = ghc_errstr;'' >>= \ str ->
+ let
+ iot =
+ case errtype# of
+ ERR_ALREADYEXISTS# -> AlreadyExists
+ ERR_HARDWAREFAULT# -> HardwareFault
+ ERR_ILLEGALOPERATION# -> IllegalOperation
+ ERR_INAPPROPRIATETYPE# -> InappropriateType
+ ERR_INTERRUPTED# -> Interrupted
+ ERR_INVALIDARGUMENT# -> InvalidArgument
+ ERR_NOSUCHTHING# -> NoSuchThing
+ ERR_OTHERERROR# -> OtherError
+ ERR_PERMISSIONDENIED# -> PermissionDenied
+ ERR_PROTOCOLERROR# -> ProtocolError
+ ERR_RESOURCEBUSY# -> ResourceBusy
+ ERR_RESOURCEEXHAUSTED# -> ResourceExhausted
+ ERR_RESOURCEVANISHED# -> ResourceVanished
+ ERR_SYSTEMERROR# -> SystemError
+ ERR_TIMEEXPIRED# -> TimeExpired
+ ERR_UNSATISFIEDCONSTRAINTS# -> UnsatisfiedConstraints
+ ERR_UNSUPPORTEDOPERATION# -> UnsupportedOperation
+ ERR_EOF# -> EOF
+ _ -> OtherError
+
+ msg =
+ case iot of
+ EOF -> ""
+ OtherError -> "bad error construct"
+ _ -> call_site ++ ':' : ' ' : unpackCString str
+ in
+ return (IOError Nothing iot msg)
+\end{code}
+%*********************************************************
+%* *
+\subsection{Types @Handle@, @Handle__@}
+%* *
+%*********************************************************
+
+The type for @Handle@ is defined rather than in @IOHandle@
+module, as the @IOError@ type uses it..all operations over
+a handles reside in @IOHandle@.
+
+\begin{code}
+
+{-
+ Sigh, the MVar ops in ConcBase depend on IO, the IO
+ representation here depend on MVars for handles (when
+ compiling a concurrent way). Break the cycle by having
+ the definition of MVars go here:
+
+-}
+data MVar a = MVar (SynchVar# RealWorld a)
+
+#if defined(__CONCURRENT_HASKELL__)
+type Handle = MVar Handle__
+#else
+type Handle = MutableVar RealWorld Handle__
+#endif
+
+data Handle__
+ = ErrorHandle IOError
+ | ClosedHandle
+ | SemiClosedHandle ForeignObj (Addr, Int)
+ | ReadHandle ForeignObj (Maybe BufferMode) Bool
+ | WriteHandle ForeignObj (Maybe BufferMode) Bool
+ | AppendHandle ForeignObj (Maybe BufferMode) Bool
+ | ReadWriteHandle ForeignObj (Maybe BufferMode) Bool
+
+-- Standard Instances as defined by the Report..
+
+instance Eq Handle {-partain:????-}
+instance Show Handle where {showsPrec p h = showString "<<Handle>>"}
+
+\end{code}
+
+%*********************************************************
+%* *
+\subsection[BufferMode]{Buffering modes}
+%* *
+%*********************************************************
+
+Three kinds of buffering are supported: line-buffering,
+block-buffering or no-buffering. These modes have the following
+effects. For output, items are written out from the internal
+buffer according to the buffer mode:
+
+\begin{itemize}
+\item[line-buffering] the entire output buffer is written
+out whenever a newline is output, the output buffer overflows,
+a flush is issued, or the handle is closed.
+
+\item[block-buffering] the entire output buffer is written out whenever
+it overflows, a flush is issued, or the handle
+is closed.
+
+\item[no-buffering] output is written immediately, and never stored
+in the output buffer.
+\end{itemize}
+
+The output buffer is emptied as soon as it has been written out.
+
+Similarly, input occurs according to the buffer mode for handle {\em hdl}.
+\begin{itemize}
+\item[line-buffering] when the input buffer for {\em hdl} is not empty,
+the next item is obtained from the buffer;
+otherwise, when the input buffer is empty,
+characters up to and including the next newline
+character are read into the buffer. No characters
+are available until the newline character is
+available.
+\item[block-buffering] when the input buffer for {\em hdl} becomes empty,
+the next block of data is read into this buffer.
+\item[no-buffering] the next input item is read and returned.
+\end{itemize}
+For most implementations, physical files will normally be block-buffered
+and terminals will normally be line-buffered.
+
+\begin{code}
+data BufferMode
+ = NoBuffering | LineBuffering | BlockBuffering (Maybe Int)
+ deriving (Eq, Ord, Read, Show)
+\end{code}
\begin{code}
#include "error.h"
-{-# OPTIONS -fno-implicit-prelude #-}
+{-# OPTIONS -fno-implicit-prelude -#include "cbits/stgio.h" #-}
module IOHandle where
import PrelTup
import PrelBase
import GHC
-
+import Foreign ( makeForeignObj )
+import PrelList (span)
+#if defined(__CONCURRENT_HASKELL__)
+import ConcBase
+#endif
\end{code}
%* *
%*********************************************************
+The @Handle@ and @Handle__@ types are defined in @IOBase@.
+
\begin{code}
type FilePath = String
-#if defined(__CONCURRENT_HASKELL__)
-type Handle = MVar Handle__
+{-# INLINE newHandle #-}
+{-# INLINE readHandle #-}
+{-# INLINE writeHandle #-}
+newHandle :: Handle__ -> IO Handle
+readHandle :: Handle -> IO Handle__
+writeHandle :: Handle -> Handle__ -> IO ()
+#if defined(__CONCURRENT_HASKELL__)
newHandle = newMVar
readHandle = takeMVar
writeHandle = putMVar
-
-#else
-type Handle = MutableVar RealWorld Handle__
-
+#else
newHandle v = stToIO (newVar v)
readHandle h = stToIO (readVar h)
writeHandle h v = stToIO (writeVar h v)
+#endif
-#endif {- __CONCURRENT_HASKELL__ -}
-
-data Handle__
- = ErrorHandle IOError
- | ClosedHandle
- | SemiClosedHandle Addr (Addr, Int)
- | ReadHandle Addr (Maybe BufferMode) Bool
- | WriteHandle Addr (Maybe BufferMode) Bool
- | AppendHandle Addr (Maybe BufferMode) Bool
- | ReadWriteHandle Addr (Maybe BufferMode) Bool
-
-instance Eq Handle{-partain:????-}
-
-{-# INLINE newHandle #-}
-{-# INLINE readHandle #-}
-{-# INLINE writeHandle #-}
-
-newHandle :: Handle__ -> IO Handle
-readHandle :: Handle -> IO Handle__
-writeHandle :: Handle -> Handle__ -> IO ()
\end{code}
%*********************************************************
%*********************************************************
\begin{code}
-filePtr :: Handle__ -> Addr
+filePtr :: Handle__ -> ForeignObj
filePtr (SemiClosedHandle fp _) = fp
filePtr (ReadHandle fp _ _) = fp
filePtr (WriteHandle fp _ _) = fp
_ccall_ getLock (``stdin''::Addr) 0 >>= \ rc ->
(case rc of
0 -> new_handle ClosedHandle
- 1 -> new_handle (ReadHandle ``stdin'' Nothing False)
+ 1 -> makeForeignObj (``stdin''::Addr) (``&freeStdChannel''::Addr) >>= \ fp ->
+ new_handle (ReadHandle fp Nothing False)
_ -> constructError "stdin" >>= \ ioError ->
new_handle (ErrorHandle ioError)
) >>= \ handle ->
_ccall_ getLock (``stdout''::Addr) 1 >>= \ rc ->
(case rc of
0 -> new_handle ClosedHandle
- 1 -> new_handle (WriteHandle ``stdout'' Nothing False)
+ 1 -> makeForeignObj (``stdout''::Addr) (``&freeStdChannel''::Addr) >>= \ fp ->
+ new_handle (WriteHandle fp Nothing False)
_ -> constructError "stdout" >>= \ ioError ->
new_handle (ErrorHandle ioError)
) >>= \ handle ->
_ccall_ getLock (``stderr''::Addr) 1 >>= \ rc ->
(case rc of
0 -> new_handle ClosedHandle
- 1 -> new_handle (WriteHandle ``stderr'' (Just NoBuffering) False)
+ 1 -> makeForeignObj (``stderr''::Addr) (``&freeStdChannel''::Addr) >>= \ fp ->
+ new_handle (WriteHandle fp (Just NoBuffering) False)
_ -> constructError "stderr" >>= \ ioError ->
new_handle (ErrorHandle ioError)
) >>= \ handle ->
openFile :: FilePath -> IOMode -> IO Handle
openFile f m =
- stToIO (_ccall_ openFile f m') >>= \ ptr ->
+ stToIO (_ccall_ openFile f m') >>= \ ptr ->
if ptr /= ``NULL'' then
- newHandle (htype ptr Nothing False)
+ stToIO (makeForeignObj ptr ((``&freeFile'')::Addr)) >>= \ fp ->
+ newHandle (htype fp Nothing False)
else
- stToIO (constructError "openFile") >>= \ ioError ->
+ stToIO (constructError "openFile") >>= \ ioError@(IOError hn iot msg) ->
let
improved_error -- a HACK, I guess
- = case ioError of
- AlreadyExists msg -> AlreadyExists (msg ++ ": " ++ f)
- NoSuchThing msg -> NoSuchThing (msg ++ ": " ++ f)
- PermissionDenied msg -> PermissionDenied (msg ++ ": " ++ f)
- _ -> ioError
+ = case iot of
+ AlreadyExists -> IOError hn AlreadyExists (msg ++ ": " ++ f)
+ NoSuchThing -> IOError hn NoSuchThing (msg ++ ": " ++ f)
+ PermissionDenied -> IOError hn PermissionDenied (msg ++ ": " ++ f)
+ _ -> ioError
in
fail improved_error
where
ErrorHandle ioError ->
fail ioError
ClosedHandle ->
- fail (IllegalOperation "handle is closed")
+ ioe_closedHandle handle
SemiClosedHandle fp (buf,_) ->
(if buf /= ``NULL'' then
_ccall_ free buf
else
returnPrimIO ()) `thenIO_Prim` \ () ->
- if fp /= ``NULL'' then
- _ccall_ closeFile fp `thenIO_Prim` \ rc ->
- if rc == 0 then
+ _casm_ `` %r = (char *)%0; '' fp `thenIO_Prim` \ fp_a ->
+ if fp_a /= (``NULL''::Addr) then -- Under what condition can this be NULL?
+ _ccall_ closeFile fp `thenIO_Prim` \ rc ->
+ {- We explicitly close a file object so that we can be told
+ if there were any errors. Note that after @hClose@
+ has been performed, the ForeignObj embedded in the Handle
+ is still lying around in the heap, so care is taken
+ to avoid closing the file object when the ForeignObj
+ is finalised. (see freeFile()) -}
+ if rc == 0 then
return ()
- else
+ else
constructErrorAndFail "hClose"
- else
- return ()
+
+ else
+ return ()
other ->
_ccall_ closeFile (filePtr other) `thenIO_Prim` \ rc ->
if rc == 0 then
fail ioError
ClosedHandle ->
writeHandle handle htype >>
- fail (IllegalOperation "handle is closed")
+ ioe_closedHandle handle
SemiClosedHandle _ _ ->
writeHandle handle htype >>
- fail (IllegalOperation "handle is closed")
+ ioe_closedHandle handle
other ->
-- HACK! We build a unique MP_INT of the right shape to hold
-- a single unsigned word, and we let the C routine change the data bits
fail ioError
ClosedHandle ->
writeHandle handle htype >>
- fail (IllegalOperation "handle is closed")
+ ioe_closedHandle handle
SemiClosedHandle _ _ ->
writeHandle handle htype >>
- fail (IllegalOperation "handle is closed")
+ ioe_closedHandle handle
WriteHandle _ _ _ ->
writeHandle handle htype >>
- fail (IllegalOperation "handle is not open for reading")
+ fail (IOError (Just handle) IllegalOperation "handle is not open for reading")
AppendHandle _ _ _ ->
writeHandle handle htype >>
- fail (IllegalOperation "handle is not open for reading")
+ fail (IOError (Just handle) IllegalOperation "handle is not open for reading")
other ->
_ccall_ fileEOF (filePtr other) `thenIO_Prim` \ rc ->
writeHandle handle (markHandle htype) >>
%*********************************************************
Three kinds of buffering are supported: line-buffering,
-block-buffering or no-buffering. These modes have the following effects.
-For output, items are written out from the internal buffer
-according to the buffer mode:
-\begin{itemize}
-\item[line-buffering] the entire output buffer is written
-out whenever a newline is output, the output buffer overflows,
-a flush is issued, or the handle is closed.
-
-\item[block-buffering] the entire output buffer is written out whenever
-it overflows, a flush is issued, or the handle
-is closed.
-
-\item[no-buffering] output is written immediately, and never stored
-in the output buffer.
-\end{itemize}
-
-The output buffer is emptied as soon as it has been written out.
-
-Similarly, input occurs according to the buffer mode for handle {\em hdl}.
-\begin{itemize}
-\item[line-buffering] when the input buffer for {\em hdl} is not empty,
-the next item is obtained from the buffer;
-otherwise, when the input buffer is empty,
-characters up to and including the next newline
-character are read into the buffer. No characters
-are available until the newline character is
-available.
-\item[block-buffering] when the input buffer for {\em hdl} becomes empty,
-the next block of data is read into this buffer.
-\item[no-buffering] the next input item is read and returned.
-\end{itemize}
-For most implementations, physical files will normally be block-buffered
-and terminals will normally be line-buffered.
-
-\begin{code}
-data BufferMode = NoBuffering | LineBuffering | BlockBuffering (Maybe Int)
- deriving (Eq, Ord, Read, Show)
-\end{code}
+block-buffering or no-buffering. See @IOBase@ for definition
+and further explanation of what the type represent.
-Computation $hSetBuffering hdl mode$ sets the mode of buffering for
+Computation @hSetBuffering hdl mode@ sets the mode of buffering for
handle {\em hdl} on subsequent reads and writes.
\begin{itemize}
\item
-If {\em mode} is $LineBuffering$, line-buffering should be
+If {\em mode} is @LineBuffering@, line-buffering should be
enabled if possible.
\item
-If {\em mode} is $BlockBuffering$ {\em size}, then block-buffering
+If {\em mode} is @BlockBuffering@ {\em size}, then block-buffering
should be enabled if possible. The size of the buffer is {\em n} items
-if {\em size} is $Just${\em n} and is otherwise implementation-dependent.
+if {\em size} is @Just@~{\em n} and is otherwise implementation-dependent.
\item
-If {\em mode} is $NoBuffering$, then buffering is disabled if possible.
+If {\em mode} is @NoBuffering@, then buffering is disabled if possible.
\end{itemize}
-If the buffer mode is changed from $BlockBuffering$ or $LineBuffering$
-to $NoBuffering$, then any items in the output buffer are written to
+If the buffer mode is changed from @BlockBuffering@ or @LineBuffering@
+to @NoBuffering@, then any items in the output buffer are written to
the device, and any items in the input buffer are discarded. The
default buffering mode when a handle is opened is
implementation-dependent and may depend on the object which is
hSetBuffering handle mode =
case mode of
(BlockBuffering (Just n))
- | n <= 0 -> fail (InvalidArgument "illegal buffer size")
+ | n <= 0 -> fail (IOError (Just handle) InvalidArgument "illegal buffer size")
other ->
readHandle handle >>= \ htype ->
if isMarked htype then
writeHandle handle htype >>
- fail (UnsupportedOperation "can't set buffering for a dirty handle")
+ fail (IOError (Just handle)
+ UnsupportedOperation
+ "can't set buffering for a dirty handle")
else
case htype of
ErrorHandle ioError ->
fail ioError
ClosedHandle ->
writeHandle handle htype >>
- fail (IllegalOperation "handle is closed")
+ ioe_closedHandle handle
SemiClosedHandle _ _ ->
writeHandle handle htype >>
- fail (IllegalOperation "handle is closed")
+ ioe_closedHandle handle
other ->
_ccall_ setBuffering (filePtr other) bsize
`thenIO_Prim` \ rc ->
BlockBuffering Nothing -> -2
BlockBuffering (Just n) -> n
- hcon :: Handle__ -> (Addr -> (Maybe BufferMode) -> Bool -> Handle__)
+ hcon :: Handle__ -> (ForeignObj -> (Maybe BufferMode) -> Bool -> Handle__)
hcon (ReadHandle _ _ _) = ReadHandle
hcon (WriteHandle _ _ _) = WriteHandle
hcon (AppendHandle _ _ _) = AppendHandle
fail ioError
ClosedHandle ->
writeHandle handle htype >>
- fail (IllegalOperation "handle is closed")
+ ioe_closedHandle handle
SemiClosedHandle _ _ ->
writeHandle handle htype >>
- fail (IllegalOperation "handle is closed")
+ ioe_closedHandle handle
other ->
_ccall_ flushFile (filePtr other) `thenIO_Prim` \ rc ->
writeHandle handle (markHandle htype) >>
fail ioError
ClosedHandle ->
writeHandle handle htype >>
- fail (IllegalOperation "handle is closed")
+ ioe_closedHandle handle
SemiClosedHandle _ _ ->
writeHandle handle htype >>
- fail (IllegalOperation "handle is closed")
+ ioe_closedHandle handle
other ->
_ccall_ getFilePosn (filePtr other) `thenIO_Prim` \ posn ->
writeHandle handle htype >>
fail ioError
ClosedHandle ->
writeHandle handle htype >>
- fail (IllegalOperation "handle is closed")
+ ioe_closedHandle handle
SemiClosedHandle _ _ ->
writeHandle handle htype >>
- fail (IllegalOperation "handle is closed")
+ ioe_closedHandle handle
AppendHandle _ _ _ ->
writeHandle handle htype >>
- fail (IllegalOperation "handle is not seekable")
+ fail (IOError (Just handle) IllegalOperation "handle is not seekable")
other ->
_ccall_ setFilePosn (filePtr other) posn `thenIO_Prim` \ rc ->
writeHandle handle (markHandle htype) >>
fail ioError
ClosedHandle ->
writeHandle handle htype >>
- fail (IllegalOperation "handle is closed")
+ ioe_closedHandle handle
SemiClosedHandle _ _ ->
writeHandle handle htype >>
- fail (IllegalOperation "handle is closed")
+ ioe_closedHandle handle
AppendHandle _ _ _ ->
writeHandle handle htype >>
- fail (IllegalOperation "handle is not seekable")
+ fail (IOError (Just handle) IllegalOperation "handle is not seekable")
other ->
_ccall_ seekFile (filePtr other) whence (I# s#) (ByteArray (0,0) d#)
`thenIO_Prim` \ rc ->
fail ioError
ClosedHandle ->
writeHandle handle htype >>
- fail (IllegalOperation "handle is closed")
+ ioe_closedHandle handle
SemiClosedHandle _ _ ->
writeHandle handle htype >>
- fail (IllegalOperation "handle is closed")
+ ioe_closedHandle handle
other ->
writeHandle handle htype >>
return (isReadable other)
fail ioError
ClosedHandle ->
writeHandle handle htype >>
- fail (IllegalOperation "handle is closed")
+ ioe_closedHandle handle
SemiClosedHandle _ _ ->
writeHandle handle htype >>
- fail (IllegalOperation "handle is closed")
+ ioe_closedHandle handle
other ->
writeHandle handle htype >>
return (isWritable other)
fail ioError
ClosedHandle ->
writeHandle handle htype >>
- fail (IllegalOperation "handle is closed")
+ ioe_closedHandle handle
SemiClosedHandle _ _ ->
writeHandle handle htype >>
- fail (IllegalOperation "handle is closed")
+ ioe_closedHandle handle
other ->
getBufferMode other `thenIO_Prim` \ other ->
case bufferMode other of
fail ioError
ClosedHandle ->
writeHandle handle htype >>
- fail (IllegalOperation "handle is closed")
+ ioe_closedHandle handle
SemiClosedHandle _ _ ->
writeHandle handle htype >>
- fail (IllegalOperation "handle is closed")
+ ioe_closedHandle handle
other ->
getBufferMode other `thenIO_Prim` \ other ->
case bufferMode other of
fail ioError
ClosedHandle ->
writeHandle handle htype >>
- fail (IllegalOperation "handle is closed")
+ ioe_closedHandle handle
SemiClosedHandle _ _ ->
writeHandle handle htype >>
- fail (IllegalOperation "handle is closed")
+ ioe_closedHandle handle
other ->
getBufferMode other `thenIO_Prim` \ other ->
case bufferMode other of
constructErrorAndFail "hIsNotBuffered"
hGetBuffering :: Handle -> IO BufferMode
-hGetBuffering hndl =
- readHandle hndl >>= \ htype ->
+hGetBuffering handle =
+ readHandle handle >>= \ htype ->
case htype of
ErrorHandle ioError ->
- writeHandle hndl htype >>
+ writeHandle handle htype >>
fail ioError
ClosedHandle ->
- writeHandle hndl htype >>
- fail (IllegalOperation "handle is closed")
+ writeHandle handle htype >>
+ ioe_closedHandle handle
SemiClosedHandle _ _ ->
- writeHandle hndl htype >>
- fail (IllegalOperation "handle is closed")
+ writeHandle handle htype >>
+ ioe_closedHandle handle
other ->
getBufferMode other `thenIO_Prim` \ other ->
case bufferMode other of
Just v ->
- writeHandle hndl other >>
+ writeHandle handle other >>
return v
Nothing ->
constructErrorAndFail "hGetBuffering"
fail ioError
ClosedHandle ->
writeHandle handle htype >>
- fail (IllegalOperation "handle is closed")
+ ioe_closedHandle handle
SemiClosedHandle _ _ ->
writeHandle handle htype >>
- fail (IllegalOperation "handle is closed")
+ ioe_closedHandle handle
AppendHandle _ _ _ ->
writeHandle handle htype >>
return False
\begin{code}
ioeGetFileName :: IOError -> Maybe FilePath
+ioeGetErrorString :: IOError -> String
ioeGetHandle :: IOError -> Maybe Handle
+ioeGetHandle (IOError h _ _) = h
+ioeGetErrorString (IOError _ iot str) =
+ case iot of
+ EOF -> "end of file"
+ _ -> str
+
+ioeGetFileName (IOError _ _ str) =
+ case span (/=':') str of
+ (fs,[]) -> Nothing
+ (fs,_) -> Just fs
-ioeGetHandle _ = Nothing -- a stub, essentially
-ioeGetFileName _ = Nothing -- a stub, essentially
\end{code}
+Internal function for creating an @IOError@ representing the
+access of a closed file.
+
+\begin{code}
+
+ioe_closedHandle :: Handle -> IO a
+ioe_closedHandle h = fail (IOError (Just h) IllegalOperation "handle is closed")
+
+\end{code}
_exports_
Main main ;
_declarations_
-1 main :: IOBase.IO PrelBase.();;
+1 main _:_ IOBase.IO PrelBase.();;
\begin{code}
{-# OPTIONS -fno-implicit-prelude #-}
-module PrelBase where
+module PrelBase(
+ module PrelBase,
+ module GHC -- Re-export GHC, to avoid lots of people having
+ -- to import it explicitly
+ ) where
import {-# SOURCE #-} IOBase ( error )
import GHC
showsPrec :: Int -> a -> ShowS
showList :: [a] -> ShowS
- showList [] = showString "[]"
- showList (x:xs)
- = showChar '[' . shows x . showl xs
- where showl [] = showChar ']'
- showl (x:xs) = showString ", " . shows x . showl xs
+ showList ls = showList__ (showsPrec 0) ls
\end{code}
%*********************************************************
instance (Eq a) => Eq [a] where
[] == [] = True
(x:xs) == (y:ys) = x == y && xs == ys
- [] == ys = False
- xs == [] = False
+ xs == ys = False
xs /= ys = if (xs == ys) then False else True
instance (Ord a) => Ord [a] where
instance Monad [] where
m >>= k = foldr ((++) . k) [] m
+ m >> k = foldr ((++) . (\ _ -> k)) [] m
return x = [x]
instance MonadZero [] where
instance (Show a) => Show [a] where
showsPrec p = showList
- showList = showList__ (showsPrec 0)
+ showList ls = showList__ (showsPrec 0) ls
\end{code}
\end{code}
The type @Void@ is built in, but it needs a @Show@ instance.
\begin{code}
+void :: Void
+void = error "You tried to evaluate void"
+
instance Show Void where
showsPrec p f = showString "<<void>>"
- showList = showList__ (showsPrec 0)
+ showList ls = showList__ (showsPrec 0) ls
\end{code}
(&&), (||) :: Bool -> Bool -> Bool
True && x = x
-False && _ = False
-True || _ = True
+False && x = False
+True || x = True
False || x = x
not :: Bool -> Bool
\begin{code}
data Maybe a = Nothing | Just a deriving (Eq, Ord, Show {- Read -})
+maybe :: b -> (a -> b) -> Maybe a -> b
+maybe n f Nothing = n
+maybe n f (Just x) = f x
+
instance Functor Maybe where
map f Nothing = Nothing
map f (Just a) = Just (f a)
instance Monad Maybe where
(Just x) >>= k = k x
Nothing >>= k = Nothing
+
+ (Just x) >> k = k
+ Nothing >> k = Nothing
+
return = Just
instance MonadZero Maybe where
\begin{code}
data () = () --easier to do explicitly: deriving (Eq, Ord, Enum, Show, Bounded)
-- (avoids weird-named functions, e.g., con2tag_()#
-
instance Eq () where
() == () = True
() /= () = False
instance Show () where
showsPrec p () = showString "()"
+ showList ls = showList__ (showsPrec 0) ls
\end{code}
%*********************************************************
instance Enum Char where
toEnum (I# i) | i >=# 0# && i <=# 255# = C# (chr# i)
- | otherwise = error "Prelude.Enum.Char.toEnum:out of range"
+ | otherwise = error ("Prelude.Enum.Char.toEnum:out of range: " ++ show (I# i))
fromEnum (C# c) = I# (ord# c)
enumFrom (C# c) = eftt (ord# c) 1# 255#
enumFromThen (C# c1) (C# c2) = eftt (ord# c1) (ord# c2 -# ord# c1) 255#
+ enumFromTo (C# c1) (C# c2) = eftt (ord# c1) 1# (ord# c2)
enumFromThenTo (C# c1) (C# c2) (C# c3) = eftt (ord# c1) (ord# c2 -# ord# c1) (ord# c3)
eftt :: Int# -> Int# -> Int# -> [Char]
\begin{code}
-isAscii, isControl, isPrint, isSpace, isUpper,
+isAscii, isLatin1, isControl, isPrint, isSpace, isUpper,
isLower, isAlpha, isDigit, isOctDigit, isHexDigit, isAlphanum :: Char -> Bool
isAscii c = fromEnum c < 128
+isLatin1 c = c <= '\xff'
isControl c = c < ' ' || c >= '\DEL' && c <= '\x9f'
isPrint c = not (isControl c)
isLower c = c >= 'a' && c <= 'z' ||
c >= '\xDF' && c <= '\xF6' ||
c >= '\xF8' && c <= '\xFF'
-isAlpha c = isUpper c || isLower c
+isAlpha c = isLower c || isUpper c
isDigit c = c >= '0' && c <= '9'
isOctDigit c = c >= '0' && c <= '7'
isHexDigit c = isDigit c || c >= 'A' && c <= 'F' ||
c >= 'a' && c <= 'f'
isAlphanum c = isAlpha c || isDigit c
--- These almost work for ISO-Latin-1 (except for =DF <-> =FF)
+-- Case-changing operations
toUpper, toLower :: Char -> Char
-toUpper c | isLower c = toEnum (fromEnum c - fromEnum 'a'
- + fromEnum 'A')
- | otherwise = c
+toUpper c | isLower c && c /= '\xDF' && c /= '\xFF'
+ = toEnum (fromEnum c - fromEnum 'a' + fromEnum 'A')
+ | otherwise = c
toLower c | isUpper c = toEnum (fromEnum c - fromEnum 'A'
+ fromEnum 'a')
data Int = I# Int#
instance Eq Int where
- (I# x) == (I# y) = x ==# y
+ (==) x y = x `eqInt` y
+ (/=) x y = x `neInt` y
instance Ord Int where
- (I# x) `compare` (I# y) | x <# y = LT
- | x ==# y = EQ
- | otherwise = GT
-
- (I# x) < (I# y) = x <# y
- (I# x) <= (I# y) = x <=# y
- (I# x) >= (I# y) = x >=# y
- (I# x) > (I# y) = x ># y
+ compare x y = compareInt x y
+ (<) x y = ltInt x y
+ (<=) x y = leInt x y
+ (>=) x y = geInt x y
+ (>) x y = gtInt x y
+ max x y = case (compareInt x y) of { LT -> y ; EQ -> x ; GT -> x }
+ min x y = case (compareInt x y) of { LT -> x ; EQ -> x ; GT -> y }
+(I# x) `compareInt` (I# y) | x <# y = LT
+ | x ==# y = EQ
+ | otherwise = GT
instance Enum Int where
toEnum x = x
enumFromThenTo n m p = takeWhile (if m >= n then (<= p) else (>= p))
(enumFromThen n m)
+
instance Bounded Int where
minBound = negate 2147483647 -- **********************
maxBound = 2147483647 -- **********************
instance Show Int where
showsPrec p n = showSignedInt p n
- showList = showList__ (showsPrec 0)
+ showList ls = showList__ (showsPrec 0) ls
\end{code}
\begin{code}
instance Show (a -> b) where
showsPrec p f = showString "<<function>>"
- showList = showList__ (showsPrec 0)
+ showList ls = showList__ (showsPrec 0) ls
+
-- identity function
id :: a -> a
\begin{code}
data Addr = A# Addr# deriving (Eq, Ord) -- Glasgow extension
data Word = W# Word# deriving (Eq, Ord) -- Glasgow extension
+data ForeignObj = ForeignObj ForeignObj# -- another one
data Lift a = Lift a
{-# GENERATE_SPECS data a :: Lift a #-}
used in the case of partial applications, etc.
\begin{code}
+{-# INLINE eqInt #-}
+{-# INLINE neInt #-}
+
plusInt (I# x) (I# y) = I# (x +# y)
minusInt(I# x) (I# y) = I# (x -# y)
timesInt(I# x) (I# y) = I# (x *# y)
import {-# SOURCE #-} IOBase ( error )
import PrelList
import PrelBase
+import ArrBase ( Array, array, (!) )
+import Ix ( Ix(..) )
import GHC
infixr 8 ^, ^^, **
showsPrec x = showSignedInteger x
showList = showList__ (showsPrec 0)
+instance Ix Integer where
+ range (m,n) = [m..n]
+ index b@(m,n) i
+ | inRange b i = fromInteger (i - m)
+ | otherwise = error "Integer.index: Index out of range."
+ inRange (m,n) i = m <= i && i <= n
+
integer_0, integer_1, integer_2, integer_m1 :: Integer
-integer_0 = 0; integer_1 = 1; integer_2 = 2; integer_m1 = -1
+integer_0 = int2Integer# 0#
+integer_1 = int2Integer# 1#
+integer_2 = int2Integer# 2#
+integer_m1 = int2Integer# (negateInt# 1#)
\end{code}
(F# x) < (F# y) = x `ltFloat#` y
(F# x) <= (F# y) = x `leFloat#` y
(F# x) >= (F# y) = x `geFloat#` y
- (F# x) > (F# y) = x `geFloat#` y
+ (F# x) > (F# y) = x `gtFloat#` y
instance Num Float where
(+) x y = plusFloat x y
%*********************************************************
\begin{code}
-data (Integral a) => Ratio a = a :% a deriving (Eq)
+data (Integral a) => Ratio a = !a :% !a deriving (Eq)
type Rational = Ratio Integer
\end{code}
numerator, denominator :: (Integral a) => Ratio a -> a
approxRational :: (RealFrac a) => a -> a -> Rational
+\end{code}
+
+\tr{reduce} is a subsidiary function used only in this module .
+It normalises a ratio by dividing both numerator and denominator by
+their greatest common divisor.
+\begin{code}
reduce _ 0 = error "{Ratio.%}: zero denominator"
reduce x y = (x `quot` d) :% (y `quot` d)
where d = gcd x y
+\end{code}
+\begin{code}
x % y = reduce (x * signum y) (abs y)
numerator (x:%y) = x
(shows x . showString " % " . shows y)
\end{code}
-{-
-[In response to a request by simonpj, Joe Fasel writes:]
+[In response to a request for documentation of how fromRational works,
+Joe Fasel writes:] A quite reasonable request! This code was added to
+the Prelude just before the 1.2 release, when Lennart, working with an
+early version of hbi, noticed that (read . show) was not the identity
+for floating-point numbers. (There was a one-bit error about half the
+time.) The original version of the conversion function was in fact
+simply a floating-point divide, as you suggest above. The new version
+is, I grant you, somewhat denser.
-A quite reasonable request! This code was added to the Prelude just
-before the 1.2 release, when Lennart, working with an early version
-of hbi, noticed that (read . show) was not the identity for
-floating-point numbers. (There was a one-bit error about half the time.)
-The original version of the conversion function was in fact simply
-a floating-point divide, as you suggest above. The new version is,
-I grant you, somewhat denser.
+Unfortunately, Joe's code doesn't work! Here's an example:
-How's this?
+main = putStr (shows (1.82173691287639817263897126389712638972163e-300::Double) "\n")
-Joe
--}
+This program prints
+ 0.0000000000000000
+instead of
+ 1.8217369128763981e-300
-\begin{code}
+Lennart's code follows, and it works...
+
+\begin{pseudocode}
{-# GENERATE_SPECS fromRational__ a{Double#,Double} #-}
fromRational__ :: (RealFloat a) => Rational -> a
fromRational__ x = x'
(s,e) = decodeFloat (fromInteger (numerator x) `asTypeOf` x'
/ fromInteger (denominator x))
-\end{code}
+\end{pseudocode}
+Now, here's Lennart's code.
+
+\begin{code}
+fromRational__ :: (RealFloat a) => Rational -> a
+fromRational__ x =
+ if x == 0 then encodeFloat 0 0 -- Handle exceptional cases
+ else if x < 0 then - fromRat' (-x) -- first.
+ else fromRat' x
+
+-- Conversion process:
+-- Scale the rational number by the RealFloat base until
+-- it lies in the range of the mantissa (as used by decodeFloat/encodeFloat).
+-- Then round the rational to an Integer and encode it with the exponent
+-- that we got from the scaling.
+-- To speed up the scaling process we compute the log2 of the number to get
+-- a first guess of the exponent.
+
+fromRat' :: (RealFloat a) => Rational -> a
+fromRat' x = r
+ where b = floatRadix r
+ p = floatDigits r
+ (minExp0, _) = floatRange r
+ minExp = minExp0 - p -- the real minimum exponent
+ xMin = toRational (expt b (p-1))
+ xMax = toRational (expt b p)
+ p0 = (integerLogBase b (numerator x) - integerLogBase b (denominator x) - p) `max` minExp
+ f = if p0 < 0 then 1 % expt b (-p0) else expt b p0 % 1
+ (x', p') = scaleRat (toRational b) minExp xMin xMax p0 (x / f)
+ r = encodeFloat (round x') p'
+
+-- Scale x until xMin <= x < xMax, or p (the exponent) <= minExp.
+scaleRat :: Rational -> Int -> Rational -> Rational -> Int -> Rational -> (Rational, Int)
+scaleRat b minExp xMin xMax p x =
+ if p <= minExp then
+ (x, p)
+ else if x >= xMax then
+ scaleRat b minExp xMin xMax (p+1) (x/b)
+ else if x < xMin then
+ scaleRat b minExp xMin xMax (p-1) (x*b)
+ else
+ (x, p)
+
+-- Exponentiation with a cache for the most common numbers.
+minExpt = 0::Int
+maxExpt = 1100::Int
+expt :: Integer -> Int -> Integer
+expt base n =
+ if base == 2 && n >= minExpt && n <= maxExpt then
+ expts!n
+ else
+ base^n
+expts :: Array Int Integer
+expts = array (minExpt,maxExpt) [(n,2^n) | n <- [minExpt .. maxExpt]]
+
+-- Compute the (floor of the) 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 i l = if i < b then l else doDiv (i `div` b) (l+1)
+ in doDiv (i `div` (b^l)) l
+\end{code}
%*********************************************************
%* *
isSym c = c `elem` "!@#$%&*+./<=>?\\^|:-~"
isIdChar c = isAlphanum c || c `elem` "_'"
- lexFracExp ('.':s) = [('.':ds++e,u) | (ds,t) <- lexDigits s,
- (e,u) <- lexExp t]
- lexFracExp s = [("",s)]
+ lexFracExp ('.':c:cs) | isDigit c
+ = [('.':ds++e,u) | (ds,t) <- lexDigits (c:cs),
+ (e,u) <- lexExp t]
+ lexFracExp s = [("",s)]
lexExp (e:s) | e `elem` "eE"
= [(e:c:ds,u) | (c:t) <- [s], c `elem` "+-",
thenST = (>>=)
seqST = (>>)
--- not sure whether to 1.3-ize these or what...
-{-# INLINE returnStrictlyST #-}
-{-# INLINE thenStrictlyST #-}
-{-# INLINE seqStrictlyST #-}
-
-{-# 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 = ST $ \ s@(S# _) -> (a, s)
-
-thenStrictlyST (ST m) k = ST $ \ s -> -- @(S# _) Omitted SLPJ [May95] no need to evaluate the state
- case (m s) of { (r, new_s) ->
- case (k r) of { ST k2 ->
- (k2 new_s) }}
-
-seqStrictlyST (ST m) (ST k) = ST $ \ 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 (ST m) = ST $ \ s ->
let
projects / ghc-hetmet.git / commitdiff