--- /dev/null
+%
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
+%
+\section[Demand]{@Demand@: the amount of demand on a value}
+
+\begin{code}
+#include "HsVersions.h"
+
+module Demand where
+
+import PprStyle ( PprStyle )
+import Outputable
+import Pretty ( SYN_IE(Pretty), PrettyRep, ppStr )
+import Util ( panic )
+\end{code}
+
+
+%************************************************************************
+%* *
+\subsection{The @Demand@ data type}
+%* *
+%************************************************************************
+
+\begin{code}
+data Demand
+ = WwLazy -- Argument is lazy as far as we know
+ MaybeAbsent -- (does not imply worker's existence [etc]).
+ -- If MaybeAbsent == True, then it is
+ -- *definitely* lazy. (NB: Absence implies
+ -- a worker...)
+
+ | WwStrict -- Argument is strict but that's all we know
+ -- (does not imply worker's existence or any
+ -- calling-convention magic)
+
+ | WwUnpack -- Argument is strict & a single-constructor
+ [Demand] -- type; its constituent parts (whose StrictInfos
+ -- are in the list) should be passed
+ -- as arguments to the worker.
+
+ | WwPrim -- Argument is of primitive type, therefore
+ -- strict; doesn't imply existence of a worker;
+ -- argument should be passed as is to worker.
+
+ | WwEnum -- Argument is strict & an enumeration type;
+ -- an Int# representing the tag (start counting
+ -- at zero) should be passed to the worker.
+ deriving (Eq, Ord)
+ -- we need Eq/Ord to cross-chk update infos in interfaces
+
+type MaybeAbsent = Bool -- True <=> not even used
+
+-- versions that don't worry about Absence:
+wwLazy = WwLazy False
+wwStrict = WwStrict
+wwUnpack xs = WwUnpack xs
+wwPrim = WwPrim
+wwEnum = WwEnum
+\end{code}
+
+
+%************************************************************************
+%* *
+\subsection{Functions over @Demand@}
+%* *
+%************************************************************************
+
+\begin{code}
+isStrict :: Demand -> Bool
+
+isStrict WwStrict = True
+isStrict (WwUnpack _) = True
+isStrict WwPrim = True
+isStrict WwEnum = True
+isStrict _ = False
+\end{code}
+
+
+%************************************************************************
+%* *
+\subsection{Instances}
+%* *
+%************************************************************************
+
+\begin{code}
+#ifdef REALLY_HASKELL_1_3
+instance Read Demand where
+#else
+instance Text Demand where
+#endif
+ readList str = read_em [{-acc-}] str
+ where
+ read_em acc ('L' : xs) = read_em (WwLazy False : acc) xs
+ read_em acc ('A' : xs) = read_em (WwLazy True : acc) xs
+ read_em acc ('S' : xs) = read_em (WwStrict : acc) xs
+ read_em acc ('P' : xs) = read_em (WwPrim : acc) xs
+ read_em acc ('E' : xs) = read_em (WwEnum : acc) xs
+
+ read_em acc (')' : xs) = [(reverse acc, xs)]
+ read_em acc ( 'U' : '(' : xs)
+ = case (read_em [] xs) of
+ [(stuff, rest)] -> read_em (WwUnpack stuff : acc) rest
+ _ -> panic ("Text.Demand:"++str++"::"++xs)
+
+ read_em acc rest = [(reverse acc, rest)]
+
+#ifdef REALLY_HASKELL_1_3
+instance Show Demand where
+#endif
+ showList wrap_args rest = foldr show1 rest wrap_args
+ where
+ show1 (WwLazy False) rest = 'L' : rest
+ show1 (WwLazy True) rest = 'A' : rest
+ show1 WwStrict rest = 'S' : rest
+ show1 WwPrim rest = 'P' : rest
+ show1 WwEnum rest = 'E' : rest
+ show1 (WwUnpack args) rest = "U(" ++ showList args (')' : rest)
+
+instance Outputable Demand where
+ ppr sty si = ppStr (showList [si] "")
+\end{code}
+
+
+
--- /dev/null
+%
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1994
+%
+\section[Constants]{Info about this compilation}
+
+!!!!! THIS CODE MUST AGREE WITH SMinterface.h !!!!!!
+
+*** This SHOULD BE the only module that is CPP'd with "stgdefs.h" stuff.
+
+\begin{code}
+#include "HsVersions.h"
+
+module Constants (
+ uNFOLDING_USE_THRESHOLD,
+ uNFOLDING_CREATION_THRESHOLD,
+-- uNFOLDING_OVERRIDE_THRESHOLD,
+ iNTERFACE_UNFOLD_THRESHOLD,
+ lIBERATE_CASE_THRESHOLD,
+ uNFOLDING_CHEAP_OP_COST,
+ uNFOLDING_DEAR_OP_COST,
+ uNFOLDING_NOREP_LIT_COST,
+ uNFOLDING_CON_DISCOUNT_WEIGHT,
+
+ mAX_SPEC_ALL_PTRS,
+ mAX_SPEC_ALL_NONPTRS,
+ mAX_SPEC_MIXED_FIELDS,
+ mAX_SPEC_SELECTEE_SIZE,
+
+ tARGET_MIN_INT, tARGET_MAX_INT,
+
+ mIN_UPD_SIZE,
+ mIN_SIZE_NonUpdHeapObject,
+ mIN_SIZE_NonUpdStaticHeapObject,
+
+ mAX_FAMILY_SIZE_FOR_VEC_RETURNS,
+
+ sTD_UF_SIZE, cON_UF_SIZE,
+ sCC_STD_UF_SIZE, sCC_CON_UF_SIZE,
+ uF_RET,
+ uF_SUB,
+ uF_SUA,
+ uF_UPDATEE,
+ uF_COST_CENTRE,
+
+ mAX_Vanilla_REG,
+ mAX_Float_REG,
+ mAX_Double_REG,
+
+ mIN_BIG_TUPLE_SIZE,
+
+ mIN_MP_INT_SIZE,
+ mP_STRUCT_SIZE,
+
+ oTHER_TAG, iND_TAG, -- semi-tagging stuff
+
+ lIVENESS_R1,
+ lIVENESS_R2,
+ lIVENESS_R3,
+ lIVENESS_R4,
+ lIVENESS_R5,
+ lIVENESS_R6,
+ lIVENESS_R7,
+ lIVENESS_R8,
+
+ mAX_INTLIKE, mIN_INTLIKE,
+
+
+ spARelToInt,
+ spBRelToInt
+ ) where
+
+-- This magical #include brings in all the everybody-knows-these magic
+-- constants unfortunately, we need to be *explicit* about which one
+-- we want; if we just hope a -I... will get the right one, we could
+-- be in trouble.
+
+#include "../../includes/GhcConstants.h"
+
+CHK_Ubiq() -- debugging consistency check
+
+import Util
+\end{code}
+
+All pretty arbitrary:
+\begin{code}
+uNFOLDING_USE_THRESHOLD = ( 3 :: Int)
+uNFOLDING_CREATION_THRESHOLD = (30 :: Int)
+iNTERFACE_UNFOLD_THRESHOLD = (30 :: Int)
+lIBERATE_CASE_THRESHOLD = (10 :: Int)
+-- uNFOLDING_OVERRIDE_THRESHOLD = ( 8 :: Int)
+
+uNFOLDING_CHEAP_OP_COST = ( 1 :: Int)
+uNFOLDING_DEAR_OP_COST = ( 4 :: Int)
+uNFOLDING_NOREP_LIT_COST = ( 4 :: Int)
+uNFOLDING_CON_DISCOUNT_WEIGHT = ( 1 :: Int)
+\end{code}
+
+\begin{code}
+mAX_SPEC_ALL_PTRS = (MAX_SPEC_ALL_PTRS :: Int)
+mAX_SPEC_ALL_NONPTRS = (MAX_SPEC_ALL_NONPTRS :: Int)
+mAX_SPEC_MIXED_FIELDS = (MAX_SPEC_OTHER_SIZE :: Int)
+mAX_SPEC_SELECTEE_SIZE = (MAX_SPEC_SELECTEE_SIZE :: Int)
+
+-- closure sizes: these do NOT include the header
+mIN_UPD_SIZE = (MIN_UPD_SIZE::Int)
+mIN_SIZE_NonUpdHeapObject = (MIN_NONUPD_SIZE::Int)
+mIN_SIZE_NonUpdStaticHeapObject = (0::Int)
+\end{code}
+
+A completely random number:
+\begin{code}
+mIN_BIG_TUPLE_SIZE = (16::Int)
+\end{code}
+
+Sizes of gmp objects:
+\begin{code}
+mIN_MP_INT_SIZE = (MIN_MP_INT_SIZE :: Int)
+mP_STRUCT_SIZE = (MP_STRUCT_SIZE :: Int)
+\end{code}
+
+\begin{code}
+tARGET_MIN_INT, tARGET_MAX_INT :: Integer
+tARGET_MIN_INT = -536870912
+tARGET_MAX_INT = 536870912
+\end{code}
+
+Constants for semi-tagging; the tags associated with the data
+constructors will start at 0 and go up.
+\begin{code}
+oTHER_TAG = (INFO_OTHER_TAG :: Integer) -- (-1) unevaluated, probably
+iND_TAG = (INFO_IND_TAG :: Integer) -- (-2) NOT USED, REALLY
+\end{code}
+
+Stuff for liveness masks:
+\begin{code}
+lIVENESS_R1 = (LIVENESS_R1 :: Int)
+lIVENESS_R2 = (LIVENESS_R2 :: Int)
+lIVENESS_R3 = (LIVENESS_R3 :: Int)
+lIVENESS_R4 = (LIVENESS_R4 :: Int)
+lIVENESS_R5 = (LIVENESS_R5 :: Int)
+lIVENESS_R6 = (LIVENESS_R6 :: Int)
+lIVENESS_R7 = (LIVENESS_R7 :: Int)
+lIVENESS_R8 = (LIVENESS_R8 :: Int)
+\end{code}
+
+\begin{code}
+mIN_INTLIKE, mAX_INTLIKE :: Integer -- Only used to compare with (MachInt Integer)
+mIN_INTLIKE = MIN_INTLIKE
+mAX_INTLIKE = MAX_INTLIKE
+\end{code}
+
+\begin{code}
+-- THESE ARE DIRECTION SENSITIVE!
+spARelToInt :: Int{-VirtualSpAOffset-} -> Int{-VirtualSpAOffset-} -> Int
+spBRelToInt :: Int{-VirtualSpBOffset-} -> Int{-VirtualSpBOffset-} -> Int
+
+spARelToInt spA off = spA - off -- equiv to: AREL(spA - off)
+spBRelToInt spB off = off - spB -- equiv to: BREL(spB - off)
+\end{code}
+
+A section of code-generator-related MAGIC CONSTANTS.
+\begin{code}
+mAX_FAMILY_SIZE_FOR_VEC_RETURNS = (MAX_VECTORED_RTN::Int) -- pretty arbitrary
+-- If you change this, you may need to change runtimes/standard/Update.lhc
+
+-- The update frame sizes
+sTD_UF_SIZE = (NOSCC_STD_UF_SIZE::Int)
+cON_UF_SIZE = (NOSCC_CON_UF_SIZE::Int)
+
+-- Same again, with profiling
+sCC_STD_UF_SIZE = (SCC_STD_UF_SIZE::Int)
+sCC_CON_UF_SIZE = (SCC_CON_UF_SIZE::Int)
+
+-- Offsets in an update frame. They don't change with profiling!
+uF_RET = (UF_RET::Int)
+uF_SUB = (UF_SUB::Int)
+uF_SUA = (UF_SUA::Int)
+uF_UPDATEE = (UF_UPDATEE::Int)
+uF_COST_CENTRE = (UF_COST_CENTRE::Int)
+\end{code}
+
+\begin{code}
+mAX_Vanilla_REG = (MAX_VANILLA_REG :: Int)
+mAX_Float_REG = (MAX_FLOAT_REG :: Int)
+mAX_Double_REG = (MAX_DOUBLE_REG :: Int)
+\end{code}
--- /dev/null
+%
+% (c) The AQUA Project, Glasgow University, 1994-1996
+%
+\section[StdIdInfo]{Standard unfoldings}
+
+This module contains definitions for the IdInfo for things that
+have a standard form, namely:
+
+ * data constructors
+ * record selectors
+ * method and superclass selectors
+ * primitive operations
+
+\begin{code}
+#include "HsVersions.h"
+
+module StdIdInfo (
+ addStandardIdInfo
+ ) where
+
+IMP_Ubiq()
+
+import Type
+import CoreSyn
+import Literal
+import CoreUnfold ( mkUnfolding )
+import TysWiredIn ( tupleCon )
+import Id ( GenId, mkTemplateLocals, idType,
+ dataConStrictMarks, dataConFieldLabels, dataConArgTys,
+ recordSelectorFieldLabel, dataConSig,
+ StrictnessMark(..),
+ isDataCon, isMethodSelId_maybe, isSuperDictSelId_maybe,
+ isRecordSelector, isPrimitiveId_maybe,
+ addIdUnfolding, addIdArity
+ )
+import IdInfo ( ArityInfo, exactArity )
+import Class ( GenClass, GenClassOp, classSig, classOpLocalType )
+import TyCon ( isNewTyCon )
+import FieldLabel ( FieldLabel )
+import PrelVals ( pAT_ERROR_ID )
+import Maybes
+import PprStyle ( PprStyle(..) )
+import Pretty
+import Util ( assertPanic, pprTrace,
+ assoc
+ )
+\end{code}
+
+
+%************************************************************************
+%* *
+\subsection{Data constructors}
+%* *
+%************************************************************************
+
+We're going to build a constructor that looks like:
+
+ data (Data a, C b) => T a b = T1 !a !Int b
+
+ T1 = /\ a b ->
+ \d1::Data a, d2::C b ->
+ \p q r -> case p of { p ->
+ case q of { q ->
+ Con T1 [a,b] [p,q,r]}}
+
+Notice that
+
+* d2 is thrown away --- a context in a data decl is used to make sure
+ one *could* construct dictionaries at the site the constructor
+ is used, but the dictionary isn't actually used.
+
+* We have to check that we can construct Data dictionaries for
+ the types a and Int. Once we've done that we can throw d1 away too.
+
+* We use (case p of ...) to evaluate p, rather than "seq" because
+ all that matters is that the arguments are evaluated. "seq" is
+ very careful to preserve evaluation order, which we don't need
+ to be here.
+
+\begin{code}
+addStandardIdInfo :: Id -> Id
+
+addStandardIdInfo con_id
+
+ | isDataCon con_id
+ = con_id `addIdUnfolding` unfolding
+ `addIdArity` exactArity (length locals)
+ where
+ unfolding = mkUnfolding True {- Always inline constructors -} con_rhs
+
+ (tyvars,theta,arg_tys,tycon) = dataConSig con_id
+ dict_tys = [mkDictTy clas ty | (clas,ty) <- theta]
+ n_dicts = length dict_tys
+ result_ty = applyTyCon tycon (mkTyVarTys tyvars)
+
+ locals = mkTemplateLocals (dict_tys ++ arg_tys)
+ data_args = drop n_dicts locals
+ (data_arg1:_) = data_args -- Used for newtype only
+ strict_marks = dataConStrictMarks con_id
+ strict_args = [arg | (arg,MarkedStrict) <- data_args `zip` strict_marks]
+ -- NB: we can't call mkTemplateLocals twice, because it
+ -- always starts from the same unique.
+
+ con_app | isNewTyCon tycon
+ = ASSERT( length arg_tys == 1)
+ Coerce (CoerceIn con_id) result_ty (Var data_arg1)
+ | otherwise
+ = Con con_id (map TyArg (mkTyVarTys tyvars) ++ map VarArg data_args)
+
+ con_rhs = mkTyLam tyvars $
+ mkValLam locals $
+ foldr mk_case con_app strict_args
+
+ mk_case arg body | isUnboxedType (idType arg)
+ = body -- "!" on unboxed arg does nothing
+ | otherwise
+ = Case (Var arg) (AlgAlts [] (BindDefault arg body))
+ -- This case shadows "arg" but that's fine
+\end{code}
+
+
+%************************************************************************
+%* *
+\subsection{Record selectors}
+%* *
+%************************************************************************
+
+We're going to build a record selector that looks like this:
+
+ data T a b c = T1 { ..., op :: a, ...}
+ | T2 { ..., op :: a, ...}
+ | T3
+
+ sel = /\ a b c -> \ d -> case d of
+ T1 ... x ... -> x
+ T2 ... x ... -> x
+ other -> error "..."
+
+\begin{code}
+addStandardIdInfo sel_id
+ | isRecordSelector sel_id
+ = ASSERT( null theta )
+ sel_id `addIdUnfolding` unfolding
+ `addIdArity` exactArity 1
+ -- ToDo: consider adding further IdInfo
+ where
+ unfolding = mkUnfolding False {- Don't inline every selector -} sel_rhs
+
+ (tyvars, theta, tau) = splitSigmaTy (idType sel_id)
+ field_lbl = recordSelectorFieldLabel sel_id
+ (data_ty,rhs_ty) = expectJust "StdIdInfoRec" (getFunTy_maybe tau)
+ -- tau is of form (T a b c -> field-type)
+ (tycon, _, data_cons) = getAppDataTyCon data_ty
+ tyvar_tys = mkTyVarTys tyvars
+
+ [data_id] = mkTemplateLocals [data_ty]
+ sel_rhs = mkTyLam tyvars $
+ mkValLam [data_id] $
+ Case (Var data_id) (AlgAlts (catMaybes (map mk_maybe_alt data_cons))
+ (BindDefault data_id error_expr))
+ mk_maybe_alt data_con
+ = case maybe_the_arg_id of
+ Nothing -> Nothing
+ Just the_arg_id -> Just (data_con, arg_ids, Var the_arg_id)
+ where
+ arg_ids = mkTemplateLocals (dataConArgTys data_con tyvar_tys)
+ -- The first one will shadow data_id, but who cares
+ field_lbls = dataConFieldLabels data_con
+ maybe_the_arg_id = assocMaybe (field_lbls `zip` arg_ids) field_lbl
+
+ error_expr = mkApp (Var pAT_ERROR_ID) [] [rhs_ty] [LitArg msg_lit]
+ full_msg = ppShow 80 (ppSep [ppStr "No match in record selector", ppr PprForUser sel_id])
+ msg_lit = NoRepStr (_PK_ full_msg)
+\end{code}
+
+
+%************************************************************************
+%* *
+\subsection{Super selectors}
+%* *
+%************************************************************************
+
+\begin{code}
+addStandardIdInfo sel_id
+ | maybeToBool maybe_sc_sel_id
+ = sel_id `addIdUnfolding` unfolding
+ -- The always-inline thing means we don't need any other IdInfo
+ where
+ maybe_sc_sel_id = isSuperDictSelId_maybe sel_id
+ Just (cls, the_sc) = maybe_sc_sel_id
+
+ unfolding = mkUnfolding True {- Always inline selectors -} rhs
+ rhs = mk_dict_selector [tyvar] dict_id arg_ids the_arg_id
+
+ (tyvar, scs, ops) = classSig cls
+ tyvar_ty = mkTyVarTy tyvar
+ [dict_id] = mkTemplateLocals [mkDictTy cls tyvar_ty]
+ arg_ids = mkTemplateLocals ([mkDictTy sc tyvar_ty | sc <- scs] ++
+ map classOpLocalType ops)
+ the_arg_id = assoc "StdIdInfoSC" (scs `zip` arg_ids) the_sc
+
+addStandardIdInfo sel_id
+ | maybeToBool maybe_meth_sel_id
+ = sel_id `addIdUnfolding` unfolding
+ -- The always-inline thing means we don't need any other IdInfo
+ where
+ maybe_meth_sel_id = isMethodSelId_maybe sel_id
+ Just (cls, the_op) = maybe_meth_sel_id
+
+ unfolding = mkUnfolding True {- Always inline selectors -} rhs
+ rhs = mk_dict_selector [tyvar] dict_id arg_ids the_arg_id
+
+ (tyvar, scs, ops) = classSig cls
+ n_scs = length scs
+ tyvar_ty = mkTyVarTy tyvar
+ [dict_id] = mkTemplateLocals [mkDictTy cls tyvar_ty]
+ arg_ids = mkTemplateLocals ([mkDictTy sc tyvar_ty | sc <- scs] ++
+ map classOpLocalType ops)
+
+ the_arg_id = assoc "StdIdInfoMeth" (ops `zip` (drop n_scs arg_ids)) the_op
+\end{code}
+
+
+%************************************************************************
+%* *
+\subsection{Primitive operations
+%* *
+%************************************************************************
+
+
+\begin{code}
+addStandardIdInfo prim_id
+ | maybeToBool maybe_prim_id
+ = prim_id `addIdUnfolding` unfolding
+ where
+ maybe_prim_id = isPrimitiveId_maybe prim_id
+ Just prim_op = maybe_prim_id
+
+ unfolding = mkUnfolding True {- Always inline PrimOps -} rhs
+
+ (tyvars, tau) = splitForAllTy (idType prim_id)
+ (arg_tys, _) = splitFunTy tau
+
+ args = mkTemplateLocals arg_tys
+ rhs = mkLam tyvars args $
+ Prim prim_op
+ ([TyArg (mkTyVarTy tv) | tv <- tyvars] ++
+ [VarArg v | v <- args])
+\end{code}
+
+
+%************************************************************************
+%* *
+\subsection{Catch-all}
+%* *
+%************************************************************************
+
+\begin{code}
+addStandardIdInfo id
+ = pprTrace "addStandardIdInfo missing:" (ppr PprDebug id) id
+\end{code}
+
+
+%************************************************************************
+%* *
+\subsection{Dictionary selector help function
+%* *
+%************************************************************************
+
+Selecting a field for a dictionary. If there is just one field, then
+there's nothing to do.
+
+\begin{code}
+mk_dict_selector tyvars dict_id [arg_id] the_arg_id
+ = mkLam tyvars [dict_id] (Var dict_id)
+
+mk_dict_selector tyvars dict_id arg_ids the_arg_id
+ = mkLam tyvars [dict_id] $
+ Case (Var dict_id) (AlgAlts [(tup_con, arg_ids, Var the_arg_id)] NoDefault)
+ where
+ tup_con = tupleCon (length arg_ids)
+\end{code}
--- /dev/null
+%
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
+%
+\section[Lexical analysis]{Lexical analysis}
+
+\begin{code}
+#include "HsVersions.h"
+
+module Lex (
+
+ isLexCon, isLexVar, isLexId, isLexSym,
+ isLexConId, isLexConSym, isLexVarId, isLexVarSym,
+ mkTupNameStr,
+
+ -- Monad for parser
+ IfaceToken(..), lexIface, SYN_IE(IfM), thenIf, returnIf, happyError
+
+ ) where
+
+
+IMPORT_1_3(Char(isDigit, isAlpha, isAlphanum, isUpper))
+
+import Demand ( Demand {- instance Read -} )
+import FiniteMap ( FiniteMap, listToFM, lookupFM )
+import Maybes ( Maybe(..), MaybeErr(..) )
+import Pretty
+import CharSeq ( CSeq )
+import ErrUtils ( Error(..) )
+import Outputable ( Outputable(..) )
+import PprStyle ( PprStyle(..) )
+import Util ( nOfThem, panic )
+
+\end{code}
+
+%************************************************************************
+%* *
+\subsection{Lexical categories}
+%* *
+%************************************************************************
+
+These functions test strings to see if they fit the lexical categories
+defined in the Haskell report. Normally applied as in e.g. @isCon
+(getLocalName foo)@.
+
+\begin{code}
+isLexCon, isLexVar, isLexId, isLexSym, isLexConId, isLexConSym,
+ isLexVarId, isLexVarSym :: FAST_STRING -> Bool
+
+isLexCon cs = isLexConId cs || isLexConSym cs
+isLexVar cs = isLexVarId cs || isLexVarSym cs
+
+isLexId cs = isLexConId cs || isLexVarId cs
+isLexSym cs = isLexConSym cs || isLexVarSym cs
+
+-------------
+
+isLexConId cs
+ | _NULL_ cs = False
+ | cs == SLIT("[]") = True
+ | c == '(' = True -- (), (,), (,,), ...
+ | otherwise = isUpper c || isUpperISO c
+ where
+ c = _HEAD_ cs
+
+isLexVarId cs
+ | _NULL_ cs = False
+ | otherwise = isLower c || isLowerISO c
+ where
+ c = _HEAD_ cs
+
+isLexConSym cs
+ | _NULL_ cs = False
+ | otherwise = c == ':'
+ || cs == SLIT("->")
+ where
+ c = _HEAD_ cs
+
+isLexVarSym cs
+ | _NULL_ cs = False
+ | otherwise = isSymbolASCII c
+ || isSymbolISO c
+ where
+ c = _HEAD_ cs
+
+-------------
+isSymbolASCII c = c `elem` "!#$%&*+./<=>?@\\^|~-"
+isSymbolISO c = ord c `elem` (0xd7 : 0xf7 : [0xa1 .. 0xbf])
+isUpperISO c = 0xc0 <= oc && oc <= 0xde && oc /= 0xd7 where oc = ord c
+isLowerISO c = 0xdf <= oc && oc <= 0xff && oc /= 0xf7 where oc = ord c
+\end{code}
+
+
+%************************************************************************
+%* *
+\subsection{Tuple strings -- ugh!}
+%* *
+%************************************************************************
+
+\begin{code}
+mkTupNameStr 0 = SLIT("()")
+mkTupNameStr 1 = panic "Name.mkTupNameStr: 1 ???"
+mkTupNameStr 2 = _PK_ "(,)" -- not strictly necessary
+mkTupNameStr 3 = _PK_ "(,,)" -- ditto
+mkTupNameStr 4 = _PK_ "(,,,)" -- ditto
+mkTupNameStr n = _PK_ ("(" ++ nOfThem (n-1) ',' ++ ")")
+\end{code}
+
+
+
+%************************************************************************
+%* *
+\subsection{Data types}
+%* *
+%************************************************************************
+
+\begin{code}
+data IfaceToken
+ = ITinterface -- keywords
+ | ITusages
+ | ITversions
+ | ITexports
+ | ITinstance_modules
+ | ITinstances
+ | ITfixities
+ | ITdeclarations
+ | ITpragmas
+ | ITdata
+ | ITtype
+ | ITnewtype
+ | ITderiving
+ | ITclass
+ | ITwhere
+ | ITinstance
+ | ITinfixl
+ | ITinfixr
+ | ITinfix
+ | ITforall
+ | ITbang -- magic symbols
+ | ITvbar
+ | ITdcolon
+ | ITcomma
+ | ITdarrow
+ | ITdotdot
+ | ITequal
+ | ITocurly
+ | ITdccurly
+ | ITdocurly
+ | ITobrack
+ | IToparen
+ | ITrarrow
+ | ITccurly
+ | ITcbrack
+ | ITcparen
+ | ITsemi
+ | ITinteger Integer -- numbers and names
+ | ITvarid FAST_STRING
+ | ITconid FAST_STRING
+ | ITvarsym FAST_STRING
+ | ITconsym FAST_STRING
+ | ITqvarid (FAST_STRING,FAST_STRING)
+ | ITqconid (FAST_STRING,FAST_STRING)
+ | ITqvarsym (FAST_STRING,FAST_STRING)
+ | ITqconsym (FAST_STRING,FAST_STRING)
+
+ -- Stuff for reading unfoldings
+ | ITarity | ITstrict | ITunfold
+ | ITdemand [Demand] | ITbottom
+ | ITlam | ITbiglam | ITcase | ITlet | ITletrec | ITin | ITof
+ | ITcoerce_in | ITcoerce_out
+ | ITchar Char | ITstring FAST_STRING
+ deriving Text -- debugging
+\end{code}
+
+%************************************************************************
+%* *
+\subsection{The lexical analyser}
+%* *
+%************************************************************************
+
+\begin{code}
+lexIface :: String -> [IfaceToken]
+
+lexIface input
+ = _scc_ "Lexer"
+ case input of
+ [] -> []
+
+ -- whitespace and comments
+ ' ' : cs -> lexIface cs
+ '\t' : cs -> lexIface cs
+ '\n' : cs -> lexIface cs
+ '-' : '-' : cs -> lex_comment cs
+
+-- Leave out nested comments for now; danger of finding { and - juxtaposed by mistake?
+-- '{' : '-' : cs -> lex_nested_comment 1{-one seen-} cs
+
+ '(' : '.' : '.' : ')' : cs -> ITdotdot : lexIface cs
+ '{' : cs -> ITocurly : lexIface cs
+ '}' : cs -> ITccurly : lexIface cs
+ '(' : ',' : cs -> lex_tuple Nothing cs
+ '(' : ')' : cs -> ITconid SLIT("()") : lexIface cs
+ '(' : cs -> IToparen : lexIface cs
+ ')' : cs -> ITcparen : lexIface cs
+ '[' : ']' : cs -> ITconid SLIT("[]") : lexIface cs
+ '[' : cs -> ITobrack : lexIface cs
+ ']' : cs -> ITcbrack : lexIface cs
+ ',' : cs -> ITcomma : lexIface cs
+ ':' : ':' : cs -> ITdcolon : lexIface cs
+ ';' : cs -> ITsemi : lexIface cs
+ '\"' : cs -> case read input of
+ ((str, rest) : _) -> ITstring (_PK_ (str::String)) : lexIface rest
+ '\'' : cs -> case read input of
+ ((ch, rest) : _) -> ITchar ch : lexIface rest
+
+ '_' : 'S' : '_' : cs -> ITstrict : lex_demand cs
+ '_' : cs -> lex_keyword cs
+
+ c : cs | isDigit c -> lex_num input
+ | otherwise -> lex_id input
+
+ other -> error ("lexing:"++other)
+ where
+ lex_comment str
+ = case (span ((/=) '\n') str) of { (junk, rest) ->
+ lexIface rest }
+
+ ------------------
+ lex_demand (c:cs) | isSpace c = lex_demand cs
+ | otherwise = case readList (c:cs) of
+ ((demand,rest) : _) -> ITdemand demand : lexIface rest
+ -----------
+ lex_num str
+ = case (span isDigit str) of { (num, rest) ->
+ ITinteger (read num) : lexIface rest }
+
+ ------------
+ lex_keyword str
+ = case (span is_kwd_mod_char str) of { (kw, rest) ->
+ case (lookupFM ifaceKeywordsFM kw) of
+ Nothing -> panic ("lex_keyword:"++str)
+ Just xx -> xx : lexIface rest
+ }
+
+ is_kwd_mod_char '_' = True
+ is_kwd_mod_char c = isAlphanum c
+
+ -----------
+ lex_tuple module_dot orig_cs = go 2 orig_cs
+ where
+ go n (',':cs) = go (n+1) cs
+ go n (')':cs) = end_lex_id module_dot (ITconid (mkTupNameStr n)) cs
+ go n other = panic ("lex_tuple" ++ orig_cs)
+
+ -- NB: ':' isn't valid inside an identifier, only at the start.
+ -- otherwise we get confused by a::t!
+ is_id_char c = isAlphanum c || c `elem` "_'!#$%&*+./<=>?@\\^|-~" -- ToDo: add ISOgraphic
+
+ lex_id cs = go [] cs
+ where
+ go xs (f :cs) | is_kwd_mod_char f = go (f : xs) cs
+ go xs ('.':cs) | not (null xs) = lex_id2 (Just (_PK_ (reverse xs))) [] cs
+ go xs cs = lex_id2 Nothing xs cs
+
+ -- Dealt with the Module.part
+ lex_id2 module_dot [] ('[': ']': cs) = end_lex_id module_dot (ITconid SLIT("[]")) cs
+ lex_id2 module_dot [] ('(': ')': cs) = end_lex_id module_dot (ITconid SLIT("()")) cs
+ lex_id2 module_dot [] ('(': ',': cs) = lex_tuple module_dot cs
+ lex_id2 module_dot [] (':' : cs) = lex_id3 module_dot [':'] cs
+ lex_id2 module_dot xs cs = lex_id3 module_dot xs cs
+
+ -- Dealt with [], (), : special cases
+ lex_id3 module_dot xs (f:cs) | is_id_char f = lex_id3 module_dot (f : xs) cs
+
+ lex_id3 Nothing xs rest = case lookupFM haskellKeywordsFM rxs of
+ Just kwd_token -> kwd_token : lexIface rest
+ other -> (mk_var_token rxs) : lexIface rest
+ where
+ rxs = reverse xs
+
+ lex_id3 (Just m) xs rest = end_lex_id (Just m) (mk_var_token (reverse xs)) rest
+
+ mk_var_token xs@(f:_) | isUpper f || isUpperISO f = ITconid n
+ | f == ':' = ITconsym n
+ | isAlpha f = ITvarid n
+ | otherwise = ITvarsym n
+ where
+ n = _PK_ xs
+
+ end_lex_id (Just m) (ITconid n) cs = ITqconid (m,n) : lexIface cs
+ end_lex_id (Just m) (ITvarid n) cs = ITqvarid (m,n) : lexIface cs
+ end_lex_id (Just m) (ITconsym n) cs = ITqconsym (m,n): lexIface cs
+ end_lex_id (Just m) (ITvarsym n) cs = ITqvarsym (m,n): lexIface cs
+ end_lex_id (Just m) ITbang cs = ITqvarsym (m,SLIT("!")) : lexIface cs
+ end_lex_id (Just m) token cs = panic ("end_lex_id:" ++ show token)
+ end_lex_id Nothing token cs = token : lexIface cs
+
+ ------------
+ ifaceKeywordsFM :: FiniteMap String IfaceToken
+ ifaceKeywordsFM = listToFM [
+ ("interface_", ITinterface)
+ ,("usages_", ITusages)
+ ,("versions_", ITversions)
+ ,("exports_", ITexports)
+ ,("instance_modules_", ITinstance_modules)
+ ,("instances_", ITinstances)
+ ,("fixities_", ITfixities)
+ ,("declarations_", ITdeclarations)
+ ,("pragmas_", ITpragmas)
+ ,("forall_", ITforall)
+ ,("U_", ITunfold)
+ ,("A_", ITarity)
+ ,("coerce_in_", ITcoerce_in)
+ ,("coerce_out_", ITcoerce_out)
+ ,("A_", ITarity)
+ ,("A_", ITarity)
+ ,("!_", ITbottom)
+
+ ]
+
+ haskellKeywordsFM = listToFM [
+ ("data", ITdata)
+ ,("type", ITtype)
+ ,("newtype", ITnewtype)
+ ,("class", ITclass)
+ ,("where", ITwhere)
+ ,("instance", ITinstance)
+ ,("infixl", ITinfixl)
+ ,("infixr", ITinfixr)
+ ,("infix", ITinfix)
+ ,("case", ITcase)
+ ,("of", ITof)
+ ,("in", ITin)
+ ,("let", ITlet)
+ ,("letrec", ITletrec)
+ ,("deriving", ITderiving)
+
+ ,("->", ITrarrow)
+ ,("\\", ITlam)
+ ,("/\\", ITbiglam)
+ ,("|", ITvbar)
+ ,("!", ITbang)
+ ,("=>", ITdarrow)
+ ,("=", ITequal)
+ ]
+\end{code}
+
+
+%************************************************************************
+%* *
+\subsection{Other utility functions
+%* *
+%************************************************************************
+
+\begin{code}
+type IfM a = MaybeErr a Error
+
+returnIf :: a -> IfM a
+thenIf :: IfM a -> (a -> IfM b) -> IfM b
+happyError :: Int -> [IfaceToken] -> IfM a
+
+returnIf a = Succeeded a
+
+thenIf (Succeeded a) k = k a
+thenIf (Failed err) _ = Failed err
+
+happyError ln toks = Failed (ifaceParseErr ln toks)
+
+-----------------------------------------------------------------
+
+ifaceParseErr ln toks sty
+ = ppCat [ppPStr SLIT("Interface-file parse error: line"), ppInt ln, ppStr "toks=", ppStr (show (take 10 toks))]
+\end{code}
--- /dev/null
+This loop-breaking module is used solely to braek the loops caused by
+SPECIALIZE pragmas.
+
+\begin{code}
+interface SpecLoop where
+
+import RdrHsSyn ( RdrName )
+import Name ( Name, OrigName, OccName )
+import TyVar ( GenTyVar )
+import TyCon ( TyCon )
+import Class ( GenClass, GenClassOp )
+import Id ( GenId )
+import Unique ( Unique )
+import UniqFM ( Uniquable(..) )
+import MachRegs ( Reg )
+import CLabel ( CLabel )
+
+data RdrName
+data GenClass a b
+data GenClassOp a
+data GenId a -- NB: fails the optimisation criterion
+data GenTyVar a -- NB: fails the optimisation criterion
+data Name
+data OrigName
+data OccName
+data TyCon
+data Unique
+data Reg
+data CLabel
+
+
+class Uniquable a where
+ uniqueOf :: a -> Unique
+
+-- SPECIALIZing in FiniteMap
+instance Eq Reg
+instance Eq CLabel
+instance Eq OccName
+instance Eq RdrName
+instance Eq OrigName
+instance Eq (GenId a)
+instance Eq TyCon
+instance Eq (GenClass a b)
+instance Eq Unique
+instance Eq Name
+
+instance Ord Reg
+instance Ord CLabel
+instance Ord OccName
+instance Ord RdrName
+instance Ord OrigName
+instance Ord (GenId a)
+instance Ord TyCon
+instance Ord (GenClass a b)
+instance Ord Unique
+instance Ord Name
+
+-- SPECIALIZing in UniqFM, UniqSet
+instance Uniquable OrigName
+instance Uniquable (GenId a)
+instance Uniquable TyCon
+instance Uniquable (GenClass a b)
+instance Uniquable Unique
+instance Uniquable Name
+
+-- SPECIALIZing in Name
+\end{code}
-{-
%
% (c) The GRASP/AQUA Project, Glasgow University, 1995
%
Standard, unbounded channel abstraction.
\begin{code}
--}
module Channel
(
{- abstract type defined -}
) where
-import GHCbase
-{-
+import IOBase ( IO(..) ) -- Suspicious!
+import ConcBase
+import STBase
\end{code}
A channel is represented by two @MVar@s keeping track of the two ends
are used to handle consumers trying to read from an empty channel.
\begin{code}
--}
data Chan a
= Chan (MVar (Stream a))
data ChItem a = ChItem a (Stream a)
-{-
\end{code}
See the Concurrent Haskell paper for a diagram explaining the
these two @MVar@s with an empty @MVar@.
\begin{code}
--}
newChan :: IO (Chan a)
newChan
newMVar hole >>= \ write ->
return (Chan read write)
-{-
\end{code}
To put an element on a channel, a new hole at the write end is created.
new hole.
\begin{code}
--}
putChan :: Chan a -> a -> IO ()
putChan (Chan read write) val
putMVar read new_rend >>
return ()
-{-
\end{code}
Operators for interfacing with functional streams.
\begin{code}
--}
getChanContents :: Chan a -> IO [a]
getChanContents ch
-------------
putList2Chan :: Chan a -> [a] -> IO ()
putList2Chan ch ls = sequence (map (putChan ch) ls)
+
+\end{code}
-{-
%
% (c) The GRASP/AQUA Project, Glasgow University, 1995
%
Haskell paper (available from @ftp://ftp.dcs.gla.ac.uk/pub/glasgow-fp/drafts@)
\begin{code}
--}
module ChannelVar
(
{- abstract -}
) where
-import GHCbase
-{-
+import ConcBase
\end{code}
@MVars@ provide the basic mechanisms for synchronising access to a shared
a consumer to remove the previous value before it can deposit a new one in the @CVar@.
\begin{code}
--}
data CVar a
= CVar (MVar a) -- prod -> cons
= takeMVar datum >>= \ val ->
putMVar ack () >>
return val
+\end{code}
-{-
%
-% (c) The AQUA Project, Glasgow University, 1995
+% (c) The AQUA Project, Glasgow University, 1994-1996
%
+
\section[Concurrent]{Concurrent Haskell constructs}
A common interface to a collection of useful concurrency abstractions.
\tr{ftp.dcs.gla.ac.uk/pub/glasgow-fp/drafts}.) plus a couple of
others. See the paper and the individual files containing the module
definitions for explanation on what they do.
--}
+\begin{code}
module Concurrent (
- forkIO,
- par, seq, fork, -- re-exported from GHCbase
-
- -- waiting on file descriptor I/O
- threadWaitRead, threadWaitWrite,
-
- -- wait for timeout
- threadDelay,
-
module ChannelVar,
module Channel,
module Semaphore,
module Merge,
module SampleVar,
-
- -- IVars and MVars come from here, too
- IVar, MVar,
- newEmptyMVar, takeMVar, putMVar, newMVar, readMVar, swapMVar,
- newIVar, readIVar, writeIVar
-
+ module ConcBase
) where
import Parallel
import Semaphore
import Merge
import SampleVar
-
-import GHCbase
-
-forkIO :: IO () -> IO ()
-
-forkIO (IO (ST action)) = IO $ ST $ \ s ->
- let
- (_, new_s) = action s
- in
- new_s `fork` (Right (), s)
+import ConcBase
+\end{code}
-{-
%
% (c) The GRASP/AQUA Project, Glasgow University, 1995
%
IO monad.
\begin{code}
--}
module Merge
(
import Semaphore
-import GHCbase
-import GHCio ( stThen )
-import Concurrent ( forkIO )
max_buff_size = 1
mapIO f xs = accumulate (map f xs)
#endif {- __CONCURRENT_HASKELL__ -}
+\end{code}
-{-
%
% (c) The GRASP/AQUA Project, Glasgow University, 1995-1996
%
\section[Parallel]{Parallel Constructs}
--}
+\begin{code}
module Parallel (par, seq -- re-exported
#if defined(__GRANSIM__)
, parGlobal, parLocal, parAt, parAtForNow
#endif
) where
-import GHCbase ( par, seq )
-import GHCerr ( parError )
+import ConcBase ( par )
#if defined(__GRANSIM__)
#endif
-- Maybe parIO and the like could be added here later.
+\end{code}
-{-
%
% (c) The GRASP/AQUA Project, Glasgow University, 1995
%
\item Writing to a filled @SampleVar@ overwrites the current value.
(different from @putMVar@ on full @MVar@.)
\end{itemize}
--}
+\begin{code}
module SampleVar
(
SampleVar, --:: type _ =
) where
-import GHCbase
+import ConcBase
+
type SampleVar a
= MVar (Int, -- 1 == full
_ ->
putMVar val v >>
putMVar svar (min 1 (readers+1), val)
+\end{code}
-{-
%
% (c) The GRASP/AQUA Project, Glasgow University, 1995
%
General/quantity semaphores
--}
+\begin{code}
module Semaphore
(
{- abstract -}
) where
-import GHCbase
+import ConcBase
+\end{code}
-{-
General semaphores are also implemented readily in terms of shared
@MVar@s, only have to catch the case when the semaphore is tried
waited on when it is empty (==0). Implement this in the same way as
shared variables are implemented - maintaining a list of @MVar@s
representing threads currently waiting. The counter is a shared
variable, ensuring the mutual exclusion on its access.
--}
+\begin{code}
data QSem = QSem (MVar (Int, [MVar ()]))
newQSem :: Int -> IO QSem
else
free avail blocked >>= \ (avail',blocked') ->
return (avail',(req,block):blocked')
+\end{code}
--- /dev/null
+%
+% (c) The AQUA Project, Glasgow University, 1994-1996
+%
+
+\section[ArrBase]{Module @ArrBase@}
+
+\begin{code}
+module ArrBase where
+
+import Prelude ()
+import IOBase ( error ) {-# SOURCE #-}
+import Ix
+import PrelList
+import STBase
+import PrelBase
+import GHC
+
+infixl 9 !, //
+\end{code}
+
+\begin{code}
+{-# GENERATE_SPECS array a{~,Int,IPr} b{} #-}
+array :: (Ix a) => (a,a) -> [(a,b)] -> Array a b
+
+{-# GENERATE_SPECS (!) a{~,Int,IPr} b{} #-}
+(!) :: (Ix a) => Array a b -> a -> b
+
+bounds :: (Ix a) => Array a b -> (a,a)
+
+{-# GENERATE_SPECS (//) a{~,Int,IPr} b{} #-}
+(//) :: (Ix a) => Array a b -> [(a,b)] -> Array a b
+
+{-# GENERATE_SPECS accum a{~,Int,IPr} b{} c{} #-}
+accum :: (Ix a) => (b -> c -> b) -> Array a b -> [(a,c)] -> Array a b
+
+{-# GENERATE_SPECS accumArray a{~,Int,IPr} b{} c{} #-}
+accumArray :: (Ix a) => (b -> c -> b) -> b -> (a,a) -> [(a,c)] -> Array a b
+\end{code}
+
+
+%*********************************************************
+%* *
+\subsection{The @Array@ types}
+%* *
+%*********************************************************
+
+\begin{code}
+type IPr = (Int, Int)
+
+data Ix ix => Array ix elt = Array (ix,ix) (Array# elt)
+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)
+\end{code}
+
+
+%*********************************************************
+%* *
+\subsection{Operations on immutable arrays}
+%* *
+%*********************************************************
+
+"array", "!" and "bounds" are basic; the rest can be defined in terms of them
+
+\begin{code}
+bounds (Array b _) = b
+
+(Array bounds arr#) ! i
+ = let n# = case (index bounds i) of { I# x -> x } -- index fails if out of range
+ in
+ case (indexArray# arr# n#) of
+ Lift v -> v
+
+#ifdef USE_FOLDR_BUILD
+{-# INLINE array #-}
+#endif
+array ixs@(ix_start, ix_end) ivs =
+ runST ( ST $ \ s ->
+ case (newArray ixs arrEleBottom) of { ST new_array_thing ->
+ case (new_array_thing s) of { (arr@(MutableArray _ arr#),s) ->
+ let
+ fill_one_in (S# s#) (i, v)
+ = case index ixs i of { I# n# ->
+ case writeArray# arr# n# v s# of { s2# ->
+ S# s2# }}
+ in
+ case (foldl fill_one_in s ivs) of { s@(S# _) ->
+ case (freezeArray arr) of { ST freeze_array_thing ->
+ freeze_array_thing s }}}})
+
+arrEleBottom = error "(Array.!): undefined array element"
+
+fill_it_in :: Ix ix => MutableArray s ix elt -> [(ix, elt)] -> ST s ()
+fill_it_in arr lst
+ = foldr fill_one_in (returnStrictlyST ()) lst
+ where -- **** STRICT **** (but that's OK...)
+ fill_one_in (i, v) rst
+ = writeArray arr i v `seqStrictlyST` rst
+
+-----------------------------------------------------------------------
+-- these also go better with magic: (//), accum, accumArray
+
+old_array // ivs
+ = runST (
+ -- copy the old array:
+ thawArray old_array `thenStrictlyST` \ arr ->
+ -- now write the new elements into the new array:
+ fill_it_in arr ivs `seqStrictlyST`
+ freezeArray arr
+ )
+ where
+ bottom = error "(Array.//): error in copying old array\n"
+
+zap_with_f :: Ix ix => (elt -> elt2 -> elt) -> MutableArray s ix elt -> [(ix,elt2)] -> ST s ()
+-- 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
+ where
+ zap_one (i, new_v) rst
+ = readArray arr i `thenStrictlyST` \ old_v ->
+ writeArray arr i (f old_v new_v) `seqStrictlyST`
+ rst
+
+accum f old_array ivs
+ = runST (
+ -- copy the old array:
+ thawArray old_array `thenStrictlyST` \ arr ->
+
+ -- now zap the elements in question with "f":
+ zap_with_f f arr ivs >>
+ freezeArray arr
+ )
+ where
+ bottom = error "Array.accum: error in copying old array\n"
+
+accumArray f zero ixs ivs
+ = runST (
+ newArray ixs zero >>= \ arr# ->
+ zap_with_f f arr# ivs >>
+ freezeArray arr#
+ )
+\end{code}
+
+
+%*********************************************************
+%* *
+\subsection{Operations on 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}
+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 ixs@(ix_start, ix_end) init = ST $ \ (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) = ST $ \ (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) = ST $ \ (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) = ST $ \ (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) = ST $ \ (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) = ST $ \ (S# s#) ->
+ let n# = case (if null (range ixs)
+ then 0
+ else ((index ixs ix_end) + 1)) of { I# x -> x }
+ in
+ case (newDoubleArray# n# s#) of { StateAndMutableByteArray# s2# barr# ->
+ (MutableByteArray ixs barr#, S# s2#)}
+
+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
+
+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 = ST $ \ (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 = ST $ \ (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 = ST $ \ (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 = ST $ \ (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 = ST $ \ (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 = ST $ \ (S# s#) ->
+ case (index ixs n) of { I# n# ->
+ case readDoubleArray# barr# n# s# of { StateAndDouble# s2# r# ->
+ (D# r#, S# s2#)}}
+
+--Indexing of ordinary @Arrays@ is standard Haskell and isn't defined here.
+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# ->
+ case indexDoubleArray# barr# n# of { r# ->
+ (D# r#)}}
+
+--Indexing off @Addrs@ is similar, and therefore given here.
+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#)}}
+
+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 = ST $ \ (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) = ST $ \ (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) = ST $ \ (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) = ST $ \ (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) = ST $ \ (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) = ST $ \ (S# s#) ->
+ case (index ixs n) of { I# n# ->
+ case writeDoubleArray# barr# n# ele s# of { s2# ->
+ ((), S# s2#)}}
+\end{code}
+
+
+%*********************************************************
+%* *
+\subsection{Moving between mutable and immutable}
+%* *
+%*********************************************************
+
+\begin{code}
+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 (MutableArray ixs@(ix_start, ix_end) arr#) = ST $ \ (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 "freezeArray: 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#) = ST $ \ (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#) = ST $ \ (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#) = ST $ \ (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#) = ST $ \ (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#) = ST $ \ (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#
+ }}
+
+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#) = ST $ \ (S# s#) ->
+ case unsafeFreezeArray# arr# s# of { StateAndArray# s2# frozen# ->
+ (Array ixs frozen#, S# s2#) }
+
+unsafeFreezeByteArray (MutableByteArray ixs arr#) = ST $ \ (S# s#) ->
+ case unsafeFreezeByteArray# arr# s# of { StateAndByteArray# s2# frozen# ->
+ (ByteArray ixs frozen#, S# s2#) }
+
+
+--This takes a immutable array, and copies it into a mutable array, in a
+--hurry.
+
+{-# SPECIALISE thawArray :: Array Int elt -> ST s (MutableArray s Int elt),
+ Array IPr elt -> ST s (MutableArray s IPr elt)
+ #-}
+
+thawArray :: Ix ix => Array ix elt -> ST s (MutableArray s ix elt)
+thawArray (Array ixs@(ix_start, ix_end) arr#) = ST $ \ (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 "thawArray: 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}
+
+%*********************************************************
+%* *
+\subsection{Ghastly return types}
+%* *
+%*********************************************************
+
+\begin{code}
+data StateAndArray# s elt = StateAndArray# (State# s) (Array# elt)
+data StateAndMutableArray# s elt = StateAndMutableArray# (State# s) (MutableArray# s elt)
+data StateAndByteArray# s = StateAndByteArray# (State# s) ByteArray#
+data StateAndMutableByteArray# s = StateAndMutableByteArray# (State# s) (MutableByteArray# s)
+\end{code}
--- /dev/null
+%
+% (c) The AQUA Project, Glasgow University, 1994-1996
+%
+
+\section[ConcBase]{Module @ConcBase@}
+
+Basic concurrency stuff
+
+\begin{code}
+module ConcBase(
+ -- Forking and suchlike
+ ST, forkST,
+ PrimIO, forkPrimIO,
+ IO, forkIO,
+ par, fork,
+ threadDelay, threadWaitRead, threadWaitWrite,
+
+ -- MVars
+ MVar, newMVar, newEmptyMVar, takeMVar, putMVar, readMVar, swapMVar
+ ) where
+
+import STBase ( PrimIO(..), ST(..), State(..), StateAndPtr#(..) )
+import IOBase ( IO(..) )
+import GHCerr ( parError )
+import PrelBase ( Int(..) )
+import GHC ( fork#, delay#, waitRead#, waitWrite#,
+ SynchVar#, newSynchVar#, takeMVar#, putMVar#,
+ State#, RealWorld
+ )
+
+infixr 0 `par`, `fork`
+\end{code}
+
+
+
+%************************************************************************
+%* *
+\subsection{@par@, and @fork@}
+%* *
+%************************************************************************
+
+\begin{code}
+forkST :: ST s a -> ST s a
+
+forkST (ST action) = ST $ \ s ->
+ let
+ (r, new_s) = action s
+ in
+ new_s `fork__` (r, s)
+ where
+ fork__ x y = case (fork# x) of { 0# -> parError; _ -> y }
+
+forkPrimIO :: PrimIO a -> PrimIO a
+forkPrimIO = forkST
+
+forkIO :: IO () -> IO ()
+forkIO (IO (ST action)) = IO $ ST $ \ s ->
+ let
+ (_, new_s) = action s
+ in
+ new_s `fork` (Right (), s)
+
+par, fork :: Eval a => a -> b -> b
+
+{-# INLINE par #-}
+{-# INLINE fork #-}
+
+#ifdef __CONCURRENT_HASKELL__
+par x y = case (par# x) of { 0# -> parError; _ -> y }
+fork x y = case (fork# x) of { 0# -> parError; _ -> y }
+#else
+par x y = y
+fork x y = y
+#endif
+\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)
+
+newEmptyMVar :: IO (MVar a)
+
+newEmptyMVar = IO $ ST $ \ (S# s#) ->
+ case newSynchVar# s# of
+ StateAndSynchVar# s2# svar# -> (Right (MVar svar#), S# s2#)
+
+takeMVar :: MVar a -> IO a
+
+takeMVar (MVar mvar#) = IO $ ST $ \ (S# s#) ->
+ case takeMVar# mvar# s# of
+ StateAndPtr# s2# r -> (Right r, S# s2#)
+
+putMVar :: MVar a -> a -> IO ()
+
+putMVar (MVar mvar#) x = IO $ ST $ \ (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{Thread waiting}
+%* *
+%************************************************************************
+
+@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, threadWaitRead, threadWaitWrite :: Int -> IO ()
+
+threadDelay (I# x#) = IO $ ST $ \ (S# s#) ->
+ case delay# x# s# of
+ s2# -> (Right (), S# s2#)
+
+threadWaitRead (I# x#) = IO $ ST $ \ (S# s#) ->
+ case waitRead# x# s# of
+ s2# -> (Right (), S# s2#)
+
+threadWaitWrite (I# x#) = IO $ ST $ \ (S# s#) ->
+ case waitWrite# x# s# of
+ s2# -> (Right (), S# s2#)
+\end{code}
+
+%*********************************************************
+%* *
+\subsection{Ghastly return types}
+%* *
+%*********************************************************
+
+\begin{code}
+data StateAndSynchVar# s elt = StateAndSynchVar# (State# s) (SynchVar# s elt)
+\end{code}
--- /dev/null
+%
+% (c) The AQUA Project, Glasgow University, 1994-1996
+%
+
+\section[GHCerr]{Module @GHCerr@}
+
+The GHCerr module defines the code for the wired-in error functions,
+which have a special type in the compiler (with "open tyvars").
+
+We cannot define these functions in a module where they might be used
+(e.g., GHCbase), because the magical wired-in type will get confused
+with what the typechecker figures out.
+
+\begin{code}
+module GHCerr where
+
+import IOBase
+
+---------------------------------------------------------------
+-- HACK: Magic unfoldings not implemented for unboxed lists
+-- Need to define a "build" to avoid undefined symbol
+-- in this module to avoid .hi proliferation.
+
+build = error "GHCbase.build"
+augment = error "GHCbase.augment"
+--{-# GENERATE_SPECS build a #-}
+--build :: ((a -> [a] -> [a]) -> [a] -> [a]) -> [a]
+--build g = g (:) []
+
+
+---------------------------------------------------------------
+-- Used for compiler-generated error message;
+-- encoding saves bytes of string junk.
+
+absentErr, parError :: a
+irrefutPatError
+ , noDefaultMethodError
+ , noExplicitMethodError
+ , nonExhaustiveGuardsError
+ , patError
+ , 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 = patError__ (untangle s "irrefutable pattern")
+nonExhaustiveGuardsError s = patError__ (untangle s "non-exhaustive guards")
+patError s = patError__ (untangle s "pattern-matching")
+
+patError__ = error__ (\ x -> _ccall_ PatErrorHdrHook x)
+
+recConError s = error (untangle s "record constructor")
+recUpdError s = error (untangle s "record update")
+
+untangle coded in_str
+ = "In " ++ in_str
+ ++ (if null msg then "" else (": " ++ msg))
+ ++ "; at " ++ file
+ ++ ", line " ++ line
+ ++ "\n"
+ where
+ (file,line,msg)
+ = case (span not_bar coded) of { (f, (_:rest)) ->
+ case (span not_bar rest) of { (l, (_:m)) ->
+ (f,l,m) }}
+ not_bar c = c /= '|'
+\end{code}
--- /dev/null
+\section[GHCmain]{Module @GHCmain@}
+
+This is the mainPrimIO that must be used for Haskell~1.3.
+
+\begin{code}
+module GHCmain( mainPrimIO ) where
+
+import Prelude
+import qualified Main -- for type of "Main.main"
+import IOBase
+import STBase
+\end{code}
+
+\begin{code}
+mainPrimIO = ST $ \ s ->
+ case Main.main of { IO (ST main_guts) ->
+ case main_guts 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 AQUA Project, Glasgow University, 1994-1996
+%
+
+\section[IOBase]{Module @IOBase@}
+
+Definitions for the @IO@ monad and its friends. Everything is exported
+concretely; the @IO@ module itself exports abstractly.
+
+\begin{code}
+#include "error.h"
+
+module IOBase where
+
+import Prelude ()
+import STBase
+import PrelTup
+import Foreign
+import PackedString ( unpackCString )
+import PrelBase
+import GHC
+
+infixr 1 `thenIO_Prim`
+\end{code}
+
+%*********************************************************
+%* *
+\subsection{The @IO@ monad}
+%* *
+%*********************************************************
+
+\begin{code}
+newtype IO a = IO (PrimIO (Either IOError a))
+
+instance Functor IO where
+ 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)
+
+ (IO (ST m)) >>= k
+ = IO $ ST $ \ s ->
+ let (r, new_s) = m s in
+ case r of
+ Left err -> (Left err, new_s)
+ Right x -> case (k x) of { IO (ST k2) ->
+ k2 new_s }
+
+fixIO :: (a -> IO a) -> IO a
+ -- not required but worth having around
+
+fixIO k = IO $ ST $ \ s ->
+ let
+ (IO (ST k_loop)) = k loop
+ result = k_loop s
+ (Right loop, _) = result
+ in
+ result
+
+fail :: IOError -> IO a
+fail err = IO $ ST $ \ s -> (Left err, s)
+
+userError :: String -> IOError
+userError str = UserError str
+
+catch :: IO a -> (IOError -> IO a) -> IO a
+catch (IO (ST m)) k = IO $ ST $ \ s ->
+ case (m s) of { (r, new_s) ->
+ case r of
+ Right _ -> (r, new_s)
+ Left err -> case (k err) of { IO (ST k_err) ->
+ (k_err new_s) }}
+
+instance Show (IO a) where
+ showsPrec p f = showString "<<IO action>>"
+ showList = showList__ (showsPrec 0)
+\end{code}
+
+%*********************************************************
+%* *
+\subsection{Coercions to @ST@ and @PrimIO@}
+%* *
+%*********************************************************
+
+\begin{code}
+stToIO :: ST RealWorld a -> IO a
+primIOToIO :: PrimIO a -> IO a
+ioToST :: IO a -> ST RealWorld a
+ioToPrimIO :: IO a -> PrimIO a
+
+primIOToIO = stToIO -- for backwards compatibility
+ioToPrimIO = ioToST
+
+stToIO (ST m) = IO $ ST $ \ s ->
+ case (m s) of { (r, new_s) ->
+ (Right r, new_s) }
+
+ioToST (IO (ST io)) = ST $ \ s ->
+ case (io s) of { (r, new_s) ->
+ case r of
+ Right a -> (a, new_s)
+ Left e -> error ("I/O Error (ioToST): " ++ showsPrec 0 e "\n")
+ }
+\end{code}
+
+@thenIO_Prim@ is a useful little number for doing _ccall_s in IO-land:
+
+\begin{code}
+thenIO_Prim :: PrimIO a -> (a -> IO b) -> IO b
+{-# INLINE thenIO_Prim #-}
+
+thenIO_Prim (ST m) k = IO $ ST $ \ s ->
+ case (m s) of { (m_res, new_s) ->
+ case (k m_res) of { (IO (ST k_m_res)) ->
+ k_m_res new_s }}
+\end{code}
+
+
+%*********************************************************
+%* *
+\subsection{Error/trace-ish functions}
+%* *
+%*********************************************************
+
+\begin{code}
+errorIO :: PrimIO () -> a
+
+errorIO (ST io)
+ = case (errorIO# io) of
+ _ -> bottom
+ where
+ bottom = bottom -- Never evaluated
+
+-- error stops execution and displays an error message
+error :: String -> a
+error s = error__ ( \ x -> _ccall_ ErrorHdrHook x ) s
+
+error__ :: (Addr{-FILE *-} -> PrimIO ()) -> String -> a
+
+error__ msg_hdr s
+#ifdef __PARALLEL_HASKELL__
+ = errorIO (msg_hdr sTDERR{-msg hdr-} >>
+ _ccall_ fflush sTDERR >>
+ fputs sTDERR s >>
+ _ccall_ fflush sTDERR >>
+ _ccall_ stg_exit (1::Int)
+ )
+#else
+ = errorIO (msg_hdr sTDERR{-msg hdr-} >>
+ _ccall_ fflush sTDERR >>
+ fputs sTDERR s >>
+ _ccall_ fflush sTDERR >>
+ _ccall_ getErrorHandler >>= \ errorHandler ->
+ if errorHandler == (-1::Int) then
+ _ccall_ stg_exit (1::Int)
+ else
+ _casm_ ``%r = (StgStablePtr)(%0);'' errorHandler
+ >>= \ osptr ->
+ _ccall_ decrementErrorCount >>= \ () ->
+ deRefStablePtr osptr >>= \ oact ->
+ oact
+ )
+#endif {- !parallel -}
+ where
+ sTDERR = (``stderr'' :: Addr)
+\end{code}
+
+\begin{code}
+{-# GENERATE_SPECS _trace a #-}
+trace :: String -> a -> a
+
+trace string expr
+ = unsafePerformPrimIO (
+ ((_ccall_ PreTraceHook sTDERR{-msg-}):: PrimIO ()) >>
+ fputs sTDERR string >>
+ ((_ccall_ PostTraceHook sTDERR{-msg-}):: PrimIO ()) >>
+ returnPrimIO expr )
+ where
+ sTDERR = (``stderr'' :: Addr)
+\end{code}
+
+
+%*********************************************************
+%* *
+\subsection{Utility functions}
+%* *
+%*********************************************************
+
+The construct $try comp$ exposes errors which occur within a
+computation, and which are not fully handled. It always succeeds.
+This one didn't make it into the 1.3 defn
+
+\begin{code}
+tryIO :: IO a -> IO (Either IOError a)
+tryIO p = catch (p >>= (return . Right)) (return . Left)
+\end{code}
+
+I'm not sure why this little function is here...
+
+\begin{code}
+fputs :: Addr{-FILE*-} -> String -> PrimIO Bool
+
+fputs stream [] = return True
+
+fputs stream (c : cs)
+ = _ccall_ stg_putc c stream >> -- stg_putc expands to putc
+ fputs stream cs -- (just does some casting stream)
+\end{code}
+
+
+%*********************************************************
+%* *
+\subsection{Type @IOError@}
+%* *
+%*********************************************************
+
+\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
+
+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
+\end{code}
+
+Predicates on IOError; almost no effort made on these so far...
+
+\begin{code}
+
+isAlreadyExistsError (AlreadyExists _) = True
+isAlreadyExistsError _ = False
+
+isAlreadyInUseError (ResourceBusy _) = True
+isAlreadyInUseError _ = False
+
+isFullError (ResourceExhausted _) = True
+isFullError _ = False
+
+isEOFError EOF = True
+isEOFError _ = True
+
+isIllegalOperation (IllegalOperation _) = True
+isIllegalOperation _ = False
+
+isPermissionError (PermissionDenied _) = True
+isPermissionError _ = False
+
+isUserError (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
+
+{-
+
+The @String@ part of an @IOError@ is platform-dependent. However, to
+provide a uniform mechanism for distinguishing among errors within
+these broad categories, each platform-specific standard shall specify
+the exact strings to be used for particular errors. For errors not
+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
+
+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}
+
+
--- /dev/null
+%
+% (c) The AQUA Project, Glasgow University, 1994-1996
+%
+
+\section[IOHandle]{Module @IOHandle@}
+
+This module defines Haskell {\em handles} and the basic operations
+which are supported for them.
+
+\begin{code}
+#include "error.h"
+
+module IOHandle where
+
+import Prelude ()
+import ST
+import STBase
+import ArrBase ( ByteArray(..) )
+import PrelRead ( Read )
+import Ix
+import IOBase
+import PrelTup
+import PrelBase
+import GHC
+
+\end{code}
+
+
+%*********************************************************
+%* *
+\subsection{Types @FilePath@, @Handle@, @Handle__@}
+%* *
+%*********************************************************
+
+\begin{code}
+type FilePath = String
+
+#if defined(__CONCURRENT_HASKELL__)
+type Handle = MVar Handle__
+
+newHandle = newMVar
+readHandle = takeMVar
+writeHandle = putMVar
+
+#else
+type Handle = MutableVar RealWorld Handle__
+
+newHandle v = stToIO (newVar v)
+readHandle h = stToIO (readVar h)
+writeHandle h v = stToIO (writeVar h v)
+
+#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}
+
+%*********************************************************
+%* *
+\subsection{Functions}
+%* *
+%*********************************************************
+
+\begin{code}
+filePtr :: Handle__ -> Addr
+filePtr (SemiClosedHandle fp _) = fp
+filePtr (ReadHandle fp _ _) = fp
+filePtr (WriteHandle fp _ _) = fp
+filePtr (AppendHandle fp _ _) = fp
+filePtr (ReadWriteHandle fp _ _) = fp
+
+bufferMode :: Handle__ -> Maybe BufferMode
+bufferMode (ReadHandle _ m _) = m
+bufferMode (WriteHandle _ m _) = m
+bufferMode (AppendHandle _ m _) = m
+bufferMode (ReadWriteHandle _ m _) = m
+
+markHandle :: Handle__ -> Handle__
+markHandle h@(ReadHandle fp m b)
+ | b = h
+ | otherwise = ReadHandle fp m True
+markHandle h@(WriteHandle fp m b)
+ | b = h
+ | otherwise = WriteHandle fp m True
+markHandle h@(AppendHandle fp m b)
+ | b = h
+ | otherwise = AppendHandle fp m True
+markHandle h@(ReadWriteHandle fp m b)
+ | b = h
+ | otherwise = ReadWriteHandle fp m True
+\end{code}
+
+-------------------------------------------
+
+%*********************************************************
+%* *
+\subsection[StdHandles]{Standard handles}
+%* *
+%*********************************************************
+
+Three handles are allocated during program initialisation. The first
+two manage input or output from the Haskell program's standard input
+or output channel respectively. The third manages output to the
+standard error channel. These handles are initially open.
+
+\begin{code}
+stdin, stdout, stderr :: Handle
+
+stdin = unsafePerformPrimIO (
+ _ccall_ getLock (``stdin''::Addr) 0 >>= \ rc ->
+ (case rc of
+ 0 -> new_handle ClosedHandle
+ 1 -> new_handle (ReadHandle ``stdin'' Nothing False)
+ _ -> constructError "stdin" >>= \ ioError ->
+ new_handle (ErrorHandle ioError)
+ ) >>= \ handle ->
+ returnPrimIO handle
+ )
+ where
+ new_handle x = ioToST (newHandle x)
+
+stdout = unsafePerformPrimIO (
+ _ccall_ getLock (``stdout''::Addr) 1 >>= \ rc ->
+ (case rc of
+ 0 -> new_handle ClosedHandle
+ 1 -> new_handle (WriteHandle ``stdout'' Nothing False)
+ _ -> constructError "stdout" >>= \ ioError ->
+ new_handle (ErrorHandle ioError)
+ ) >>= \ handle ->
+ returnPrimIO handle
+ )
+ where
+ new_handle x = ioToST (newHandle x)
+
+stderr = unsafePerformPrimIO (
+ _ccall_ getLock (``stderr''::Addr) 1 >>= \ rc ->
+ (case rc of
+ 0 -> new_handle ClosedHandle
+ 1 -> new_handle (WriteHandle ``stderr'' (Just NoBuffering) False)
+ _ -> constructError "stderr" >>= \ ioError ->
+ new_handle (ErrorHandle ioError)
+ ) >>= \ handle ->
+ returnPrimIO handle
+ )
+ where
+ new_handle x = ioToST (newHandle x)
+\end{code}
+
+%*********************************************************
+%* *
+\subsection[OpeningClosing]{Opening and Closing Files}
+%* *
+%*********************************************************
+
+\begin{code}
+data IOMode = ReadMode | WriteMode | AppendMode | ReadWriteMode
+ deriving (Eq, Ord, Ix, Enum, Read, Show)
+
+openFile :: FilePath -> IOMode -> IO Handle
+
+openFile f m =
+ stToIO (_ccall_ openFile f m') >>= \ ptr ->
+ if ptr /= ``NULL'' then
+ newHandle (htype ptr Nothing False)
+ else
+ stToIO (constructError "openFile") >>= \ ioError ->
+ 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
+ in
+ fail improved_error
+ where
+ m' = case m of
+ ReadMode -> "r"
+ WriteMode -> "w"
+ AppendMode -> "a"
+ ReadWriteMode -> "r+"
+
+ htype = case m of
+ ReadMode -> ReadHandle
+ WriteMode -> WriteHandle
+ AppendMode -> AppendHandle
+ ReadWriteMode -> ReadWriteHandle
+\end{code}
+
+Computation $openFile file mode$ allocates and returns a new, open
+handle to manage the file {\em file}. It manages input if {\em mode}
+is $ReadMode$, output if {\em mode} is $WriteMode$ or $AppendMode$,
+and both input and output if mode is $ReadWriteMode$.
+
+If the file does not exist and it is opened for output, it should be
+created as a new file. If {\em mode} is $WriteMode$ and the file
+already exists, then it should be truncated to zero length. The
+handle is positioned at the end of the file if {\em mode} is
+$AppendMode$, and otherwise at the beginning (in which case its
+internal position is 0).
+
+Implementations should enforce, locally to the Haskell process,
+multiple-reader single-writer locking on files, which is to say that
+there may either be many handles on the same file which manage input,
+or just one handle on the file which manages output. If any open or
+semi-closed handle is managing a file for output, no new handle can be
+allocated for that file. If any open or semi-closed handle is
+managing a file for input, new handles can only be allocated if they
+do not manage output.
+
+Two files are the same if they have the same absolute name. An
+implementation is free to impose stricter conditions.
+
+\begin{code}
+hClose :: Handle -> IO ()
+
+hClose handle =
+ readHandle handle >>= \ htype ->
+ writeHandle handle ClosedHandle >>
+ case htype of
+ ErrorHandle ioError ->
+ fail ioError
+ ClosedHandle ->
+ fail (IllegalOperation "handle is closed")
+ 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
+ return ()
+ else
+ constructErrorAndFail "hClose"
+ else
+ return ()
+ other ->
+ _ccall_ closeFile (filePtr other) `thenIO_Prim` \ rc ->
+ if rc == 0 then
+ return ()
+ else
+ constructErrorAndFail "hClose"
+\end{code}
+
+Computation $hClose hdl$ makes handle {\em hdl} closed. Before the
+computation finishes, any items buffered for output and not already
+sent to the operating system are flushed as for $flush$.
+
+%*********************************************************
+%* *
+\subsection[EOF]{Detecting the End of Input}
+%* *
+%*********************************************************
+
+
+For a handle {\em hdl} which attached to a physical file, $hFileSize
+hdl$ returns the size of {\em hdl} in terms of the number of items
+which can be read from {\em hdl}.
+
+\begin{code}
+hFileSize :: Handle -> IO Integer
+hFileSize handle =
+ readHandle handle >>= \ htype ->
+ case htype of
+ ErrorHandle ioError ->
+ writeHandle handle htype >>
+ fail ioError
+ ClosedHandle ->
+ writeHandle handle htype >>
+ fail (IllegalOperation "handle is closed")
+ SemiClosedHandle _ _ ->
+ writeHandle handle htype >>
+ fail (IllegalOperation "handle is closed")
+ 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
+ _casm_ ``%r = 1;'' `thenIO_Prim` \ (I# hack#) ->
+ case int2Integer# hack# of
+ result@(J# _ _ d#) ->
+ let
+ bogus_bounds = (error "fileSize"::(Int,Int))
+ in
+ _ccall_ fileSize (filePtr other) (ByteArray bogus_bounds d#)
+ `thenIO_Prim` \ rc ->
+ writeHandle handle htype >>
+ if rc == 0 then
+ return result
+ else
+ constructErrorAndFail "hFileSize"
+\end{code}
+
+For a readable handle {\em hdl}, computation $hIsEOF hdl$ returns
+$True$ if no further input can be taken from {\em hdl} or for a
+physical file, if the current I/O position is equal to the length of
+the file. Otherwise, it returns $False$.
+
+\begin{code}
+hIsEOF :: Handle -> IO Bool
+hIsEOF handle =
+ readHandle handle >>= \ htype ->
+ case htype of
+ ErrorHandle ioError ->
+ writeHandle handle htype >>
+ fail ioError
+ ClosedHandle ->
+ writeHandle handle htype >>
+ fail (IllegalOperation "handle is closed")
+ SemiClosedHandle _ _ ->
+ writeHandle handle htype >>
+ fail (IllegalOperation "handle is closed")
+ WriteHandle _ _ _ ->
+ writeHandle handle htype >>
+ fail (IllegalOperation "handle is not open for reading")
+ AppendHandle _ _ _ ->
+ writeHandle handle htype >>
+ fail (IllegalOperation "handle is not open for reading")
+ other ->
+ _ccall_ fileEOF (filePtr other) `thenIO_Prim` \ rc ->
+ writeHandle handle (markHandle htype) >>
+ case rc of
+ 0 -> return False
+ 1 -> return True
+ _ -> constructErrorAndFail "hIsEOF"
+
+isEOF :: IO Bool
+isEOF = hIsEOF stdin
+\end{code}
+
+%*********************************************************
+%* *
+\subsection[Buffering]{Buffering Operations}
+%* *
+%*********************************************************
+
+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}
+
+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
+enabled if possible.
+\item
+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.
+\item
+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
+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
+attached to that handle.
+
+\begin{code}
+hSetBuffering :: Handle -> BufferMode -> IO ()
+
+hSetBuffering handle mode =
+ case mode of
+ (BlockBuffering (Just n))
+ | n <= 0 -> fail (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")
+ else
+ case htype of
+ ErrorHandle ioError ->
+ writeHandle handle htype >>
+ fail ioError
+ ClosedHandle ->
+ writeHandle handle htype >>
+ fail (IllegalOperation "handle is closed")
+ SemiClosedHandle _ _ ->
+ writeHandle handle htype >>
+ fail (IllegalOperation "handle is closed")
+ other ->
+ _ccall_ setBuffering (filePtr other) bsize
+ `thenIO_Prim` \ rc ->
+ if rc == 0 then
+ writeHandle handle ((hcon other) (filePtr other) (Just mode) True)
+ >>
+ return ()
+ else
+ writeHandle handle htype >>
+ constructErrorAndFail "hSetBuffering"
+
+ where
+ isMarked :: Handle__ -> Bool
+ isMarked (ReadHandle fp m b) = b
+ isMarked (WriteHandle fp m b) = b
+ isMarked (AppendHandle fp m b) = b
+ isMarked (ReadWriteHandle fp m b) = b
+
+ bsize :: Int
+ bsize = case mode of
+ NoBuffering -> 0
+ LineBuffering -> -1
+ BlockBuffering Nothing -> -2
+ BlockBuffering (Just n) -> n
+
+ hcon :: Handle__ -> (Addr -> (Maybe BufferMode) -> Bool -> Handle__)
+ hcon (ReadHandle _ _ _) = ReadHandle
+ hcon (WriteHandle _ _ _) = WriteHandle
+ hcon (AppendHandle _ _ _) = AppendHandle
+ hcon (ReadWriteHandle _ _ _) = ReadWriteHandle
+\end{code}
+
+Computation $flush hdl$ causes any items buffered for output in handle
+{\em hdl} to be sent immediately to the operating system.
+
+\begin{code}
+hFlush :: Handle -> IO ()
+hFlush handle =
+ readHandle handle >>= \ htype ->
+ case htype of
+ ErrorHandle ioError ->
+ writeHandle handle htype >>
+ fail ioError
+ ClosedHandle ->
+ writeHandle handle htype >>
+ fail (IllegalOperation "handle is closed")
+ SemiClosedHandle _ _ ->
+ writeHandle handle htype >>
+ fail (IllegalOperation "handle is closed")
+ other ->
+ _ccall_ flushFile (filePtr other) `thenIO_Prim` \ rc ->
+ writeHandle handle (markHandle htype) >>
+ if rc == 0 then
+ return ()
+ else
+ constructErrorAndFail "hFlush"
+\end{code}
+
+
+%*********************************************************
+%* *
+\subsection[Seeking]{Repositioning Handles}
+%* *
+%*********************************************************
+
+\begin{code}
+data HandlePosn = HandlePosn Handle Int
+
+instance Eq HandlePosn{-partain-}
+
+data SeekMode = AbsoluteSeek | RelativeSeek | SeekFromEnd
+ deriving (Eq, Ord, Ix, Enum, Read, Show)
+\end{code}
+
+Computation $hGetPosn hdl$ returns the current I/O
+position of {\em hdl} as an abstract position. Computation
+$hSetPosn p$ sets the position of {\em hdl}
+to a previously obtained position {\em p}.
+
+\begin{code}
+hGetPosn :: Handle -> IO HandlePosn
+hGetPosn handle =
+ readHandle handle >>= \ htype ->
+ case htype of
+ ErrorHandle ioError ->
+ writeHandle handle htype >>
+ fail ioError
+ ClosedHandle ->
+ writeHandle handle htype >>
+ fail (IllegalOperation "handle is closed")
+ SemiClosedHandle _ _ ->
+ writeHandle handle htype >>
+ fail (IllegalOperation "handle is closed")
+ other ->
+ _ccall_ getFilePosn (filePtr other) `thenIO_Prim` \ posn ->
+ writeHandle handle htype >>
+ if posn /= -1 then
+ return (HandlePosn handle posn)
+ else
+ constructErrorAndFail "hGetPosn"
+
+hSetPosn :: HandlePosn -> IO ()
+hSetPosn (HandlePosn handle posn) =
+ readHandle handle >>= \ htype ->
+ case htype of
+ ErrorHandle ioError ->
+ writeHandle handle htype >>
+ fail ioError
+ ClosedHandle ->
+ writeHandle handle htype >>
+ fail (IllegalOperation "handle is closed")
+ SemiClosedHandle _ _ ->
+ writeHandle handle htype >>
+ fail (IllegalOperation "handle is closed")
+ AppendHandle _ _ _ ->
+ writeHandle handle htype >>
+ fail (IllegalOperation "handle is not seekable")
+ other ->
+ _ccall_ setFilePosn (filePtr other) posn `thenIO_Prim` \ rc ->
+ writeHandle handle (markHandle htype) >>
+ if rc == 0 then
+ return ()
+ else
+ constructErrorAndFail "hSetPosn"
+\end{code}
+
+Computation $hSeek hdl mode i$ sets the position of handle
+{\em hdl} depending on $mode$. If {\em mode} is
+\begin{itemize}
+\item[{\bf AbsoluteSeek}] The position of {\em hdl} is set to {\em i}.
+\item[{\bf RelativeSeek}] The position of {\em hdl} is set to offset {\em i} from
+the current position.
+\item[{\bf SeekToEnd}] The position of {\em hdl} is set to offset {\em i} from
+the end of the file.
+\item[{\bf SeekFromBeginning}] The position of {\em hdl} is set to offset {\em i} from
+the beginning of the file.
+\end{itemize}
+
+Some handles may not be seekable $hIsSeekable$, or only support a
+subset of the possible positioning operations (e.g. it may only be
+possible to seek to the end of a tape, or to a positive offset from
+the beginning or current position).
+
+It is not possible to set a negative I/O position, or for a physical
+file, an I/O position beyond the current end-of-file.
+
+\begin{code}
+hSeek :: Handle -> SeekMode -> Integer -> IO ()
+hSeek handle mode offset@(J# _ s# d#) =
+ readHandle handle >>= \ htype ->
+ case htype of
+ ErrorHandle ioError ->
+ writeHandle handle htype >>
+ fail ioError
+ ClosedHandle ->
+ writeHandle handle htype >>
+ fail (IllegalOperation "handle is closed")
+ SemiClosedHandle _ _ ->
+ writeHandle handle htype >>
+ fail (IllegalOperation "handle is closed")
+ AppendHandle _ _ _ ->
+ writeHandle handle htype >>
+ fail (IllegalOperation "handle is not seekable")
+ other ->
+ _ccall_ seekFile (filePtr other) whence (I# s#) (ByteArray (0,0) d#)
+ `thenIO_Prim` \ rc ->
+ writeHandle handle (markHandle htype) >>
+ if rc == 0 then
+ return ()
+ else
+ constructErrorAndFail "hSeek"
+ where
+ whence :: Int
+ whence = case mode of
+ AbsoluteSeek -> ``SEEK_SET''
+ RelativeSeek -> ``SEEK_CUR''
+ SeekFromEnd -> ``SEEK_END''
+\end{code}
+
+%*********************************************************
+%* *
+\subsection[Query]{Handle Properties}
+%* *
+%*********************************************************
+
+A number of operations return information about the properties of a
+handle. Each of these operations returns $True$ if the
+handle has the specified property, and $False$
+otherwise.
+
+Computation $hIsBlockBuffered hdl$ returns $( False, Nothing )$ if
+{\em hdl} is not block-buffered. Otherwise it returns
+$( True, size )$, where {\em size} is $Nothing$ for default buffering, and
+$( Just n )$ for block-buffering of {\em n} bytes.
+
+\begin{code}
+hIsOpen :: Handle -> IO Bool
+hIsOpen handle =
+ readHandle handle >>= \ htype ->
+ case htype of
+ ErrorHandle ioError ->
+ writeHandle handle htype >>
+ fail ioError
+ ClosedHandle ->
+ writeHandle handle htype >>
+ return False
+ SemiClosedHandle _ _ ->
+ writeHandle handle htype >>
+ return False
+ other ->
+ writeHandle handle htype >>
+ return True
+
+hIsClosed :: Handle -> IO Bool
+hIsClosed handle =
+ readHandle handle >>= \ htype ->
+ case htype of
+ ErrorHandle ioError ->
+ writeHandle handle htype >>
+ fail ioError
+ ClosedHandle ->
+ writeHandle handle htype >>
+ return True
+ other ->
+ writeHandle handle htype >>
+ return False
+
+hIsReadable :: Handle -> IO Bool
+hIsReadable handle =
+ readHandle handle >>= \ htype ->
+ case htype of
+ ErrorHandle ioError ->
+ writeHandle handle htype >>
+ fail ioError
+ ClosedHandle ->
+ writeHandle handle htype >>
+ fail (IllegalOperation "handle is closed")
+ SemiClosedHandle _ _ ->
+ writeHandle handle htype >>
+ fail (IllegalOperation "handle is closed")
+ other ->
+ writeHandle handle htype >>
+ return (isReadable other)
+ where
+ isReadable (ReadHandle _ _ _) = True
+ isReadable (ReadWriteHandle _ _ _) = True
+ isReadable _ = False
+
+hIsWritable :: Handle -> IO Bool
+hIsWritable handle =
+ readHandle handle >>= \ htype ->
+ case htype of
+ ErrorHandle ioError ->
+ writeHandle handle htype >>
+ fail ioError
+ ClosedHandle ->
+ writeHandle handle htype >>
+ fail (IllegalOperation "handle is closed")
+ SemiClosedHandle _ _ ->
+ writeHandle handle htype >>
+ fail (IllegalOperation "handle is closed")
+ other ->
+ writeHandle handle htype >>
+ return (isWritable other)
+ where
+ isWritable (AppendHandle _ _ _) = True
+ isWritable (WriteHandle _ _ _) = True
+ isWritable (ReadWriteHandle _ _ _) = True
+ isWritable _ = False
+
+getBufferMode :: Handle__ -> PrimIO Handle__
+getBufferMode htype =
+ case bufferMode htype of
+ Just x -> returnPrimIO htype
+ Nothing ->
+ _ccall_ getBufferMode (filePtr htype) `thenPrimIO` \ rc ->
+ let
+ mode =
+ case rc of
+ 0 -> Just NoBuffering
+ -1 -> Just LineBuffering
+ -2 -> Just (BlockBuffering Nothing)
+ -3 -> Nothing
+ n -> Just (BlockBuffering (Just n))
+ in
+ returnPrimIO (case htype of
+ ReadHandle fp _ b -> ReadHandle fp mode b
+ WriteHandle fp _ b -> WriteHandle fp mode b
+ AppendHandle fp _ b -> AppendHandle fp mode b
+ ReadWriteHandle fp _ b -> ReadWriteHandle fp mode b)
+
+hIsBlockBuffered :: Handle -> IO (Bool,Maybe Int)
+hIsBlockBuffered handle =
+ readHandle handle >>= \ htype ->
+ case htype of
+ ErrorHandle ioError ->
+ writeHandle handle htype >>
+ fail ioError
+ ClosedHandle ->
+ writeHandle handle htype >>
+ fail (IllegalOperation "handle is closed")
+ SemiClosedHandle _ _ ->
+ writeHandle handle htype >>
+ fail (IllegalOperation "handle is closed")
+ other ->
+ getBufferMode other `thenIO_Prim` \ other ->
+ case bufferMode other of
+ Just (BlockBuffering size) ->
+ writeHandle handle other >>
+ return (True, size)
+ Just _ ->
+ writeHandle handle other >>
+ return (False, Nothing)
+ Nothing ->
+ constructErrorAndFail "hIsBlockBuffered"
+
+hIsLineBuffered :: Handle -> IO Bool
+hIsLineBuffered handle =
+ readHandle handle >>= \ htype ->
+ case htype of
+ ErrorHandle ioError ->
+ writeHandle handle htype >>
+ fail ioError
+ ClosedHandle ->
+ writeHandle handle htype >>
+ fail (IllegalOperation "handle is closed")
+ SemiClosedHandle _ _ ->
+ writeHandle handle htype >>
+ fail (IllegalOperation "handle is closed")
+ other ->
+ getBufferMode other `thenIO_Prim` \ other ->
+ case bufferMode other of
+ Just LineBuffering ->
+ writeHandle handle other >>
+ return True
+ Just _ ->
+ writeHandle handle other >>
+ return False
+ Nothing ->
+ constructErrorAndFail "hIsLineBuffered"
+
+hIsNotBuffered :: Handle -> IO Bool
+hIsNotBuffered handle =
+ readHandle handle >>= \ htype ->
+ case htype of
+ ErrorHandle ioError ->
+ writeHandle handle htype >>
+ fail ioError
+ ClosedHandle ->
+ writeHandle handle htype >>
+ fail (IllegalOperation "handle is closed")
+ SemiClosedHandle _ _ ->
+ writeHandle handle htype >>
+ fail (IllegalOperation "handle is closed")
+ other ->
+ getBufferMode other `thenIO_Prim` \ other ->
+ case bufferMode other of
+ Just NoBuffering ->
+ writeHandle handle other >>
+ return True
+ Just _ ->
+ writeHandle handle other >>
+ return False
+ Nothing ->
+ constructErrorAndFail "hIsNotBuffered"
+
+hGetBuffering :: Handle -> IO BufferMode
+hGetBuffering hndl =
+ readHandle hndl >>= \ htype ->
+ case htype of
+ ErrorHandle ioError ->
+ writeHandle hndl htype >>
+ fail ioError
+ ClosedHandle ->
+ writeHandle hndl htype >>
+ fail (IllegalOperation "handle is closed")
+ SemiClosedHandle _ _ ->
+ writeHandle hndl htype >>
+ fail (IllegalOperation "handle is closed")
+ other ->
+ getBufferMode other `thenIO_Prim` \ other ->
+ case bufferMode other of
+ Just v ->
+ writeHandle hndl other >>
+ return v
+ Nothing ->
+ constructErrorAndFail "hGetBuffering"
+
+hIsSeekable :: Handle -> IO Bool
+hIsSeekable handle =
+ readHandle handle >>= \ htype ->
+ case htype of
+ ErrorHandle ioError ->
+ writeHandle handle htype >>
+ fail ioError
+ ClosedHandle ->
+ writeHandle handle htype >>
+ fail (IllegalOperation "handle is closed")
+ SemiClosedHandle _ _ ->
+ writeHandle handle htype >>
+ fail (IllegalOperation "handle is closed")
+ AppendHandle _ _ _ ->
+ writeHandle handle htype >>
+ return False
+ other ->
+ _ccall_ seekFileP (filePtr other) `thenIO_Prim` \ rc ->
+ writeHandle handle htype >>
+ case rc of
+ 0 -> return False
+ 1 -> return True
+ _ -> constructErrorAndFail "hIsSeekable"
+\end{code}
+
+
+%*********************************************************
+%* *
+\subsection{Miscellaneous}
+%* *
+%*********************************************************
+
+These two functions are meant to get things out of @IOErrors@. They don't!
+
+\begin{code}
+ioeGetFileName :: IOError -> Maybe FilePath
+ioeGetHandle :: IOError -> Maybe Handle
+
+
+ioeGetHandle _ = Nothing -- a stub, essentially
+ioeGetFileName _ = Nothing -- a stub, essentially
+\end{code}
+
--- /dev/null
+%
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
+%
+\section[PrelBase]{Module @PrelBase@}
+
+
+\begin{code}
+module PrelBase where
+
+import Prelude ()
+import IOBase ( error ) {-# SOURCE #-}
+import GHC
+
+infixr 9 ., !!
+infixl 7 *, /
+infixl 6 +, -
+infixr 5 ++, :
+infix 4 ==, /=, <, <=, >=, >
+infixr 3 &&
+infixr 2 ||
+infixr 1 >>, >>=
+infixr 0 $
+\end{code}
+
+%*********************************************************
+%* *
+\subsection{Standard classes @Eq@, @Ord@, @Bounded@, @Eval@}
+%* *
+%*********************************************************
+
+\begin{code}
+class Eq a where
+ (==), (/=) :: a -> a -> Bool
+
+ x /= y = not (x == y)
+
+class (Eq a) => Ord a where
+ compare :: a -> a -> Ordering
+ (<), (<=), (>=), (>):: a -> a -> Bool
+ max, min :: a -> a -> a
+
+-- An instance of Ord should define either compare or <=
+-- Using compare can be more efficient for complex types.
+ compare x y
+ | x == y = EQ
+ | x <= y = LT
+ | otherwise = GT
+
+ x <= y = compare x y /= GT
+ x < y = compare x y == LT
+ x >= y = compare x y /= LT
+ x > y = compare x y == GT
+ max x y = case (compare x y) of { LT -> y ; EQ -> x ; GT -> x }
+ min x y = case (compare x y) of { LT -> x ; EQ -> x ; GT -> y }
+
+class Bounded a where
+ minBound, maxBound :: a
+
+class Eval a
+\end{code}
+
+%*********************************************************
+%* *
+\subsection{Monadic classes @Functor@, @Monad@, @MonadZero@, @MonadPlus@}
+%* *
+%*********************************************************
+
+\begin{code}
+class Functor f where
+ map :: (a -> b) -> f a -> f b
+
+class Monad m where
+ (>>=) :: m a -> (a -> m b) -> m b
+ (>>) :: m a -> m b -> m b
+ return :: a -> m a
+
+ m >> k = m >>= \_ -> k
+
+class (Monad m) => MonadZero m where
+ zero :: m a
+
+class (MonadZero m) => MonadPlus m where
+ (++) :: m a -> m a -> m a
+\end{code}
+
+
+%*********************************************************
+%* *
+\subsection{Classes @Num@ and @Enum@}
+%* *
+%*********************************************************
+
+\begin{code}
+class (Ord a) => Enum a where
+ toEnum :: Int -> a
+ fromEnum :: a -> Int
+ enumFrom :: a -> [a] -- [n..]
+ enumFromThen :: a -> a -> [a] -- [n,n'..]
+ enumFromTo :: a -> a -> [a] -- [n..m]
+ enumFromThenTo :: a -> a -> a -> [a] -- [n,n'..m]
+
+ enumFromTo n m = takeWhile (<= m) (enumFrom n)
+ enumFromThenTo n n' m
+ = takeWhile (if n' >= n then (<= m) else (>= m))
+ (enumFromThen n n')
+
+class (Eq a, Show a, Eval a) => Num a where
+ (+), (-), (*) :: a -> a -> a
+ negate :: a -> a
+ abs, signum :: a -> a
+ fromInteger :: Integer -> a
+ fromInt :: Int -> a -- partain: Glasgow extension
+
+ x - y = x + negate y
+ fromInt (I# i#) = fromInteger (int2Integer# i#)
+ -- Go via the standard class-op if the
+ -- non-standard one ain't provided
+\end{code}
+
+\begin{code}
+succ, pred :: Enum a => a -> a
+succ = toEnum . (+1) . fromEnum
+pred = toEnum . (subtract 1) . fromEnum
+
+chr = (toEnum :: Int -> Char)
+ord = (fromEnum :: Char -> Int)
+
+ord_0 :: Num a => a
+ord_0 = fromInt (ord '0')
+
+{-# GENERATE_SPECS subtract a{Int#,Double#,Int,Double,Complex(Double#),Complex(Double)} #-}
+subtract :: (Num a) => a -> a -> a
+subtract x y = y - x
+\end{code}
+
+
+%*********************************************************
+%* *
+\subsection{The @Show@ class}
+%* *
+%*********************************************************
+
+\begin{code}
+type ShowS = String -> String
+
+class Show a where
+ 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
+\end{code}
+
+%*********************************************************
+%* *
+\subsection{The list type}
+%* *
+%*********************************************************
+
+\begin{code}
+data [] a = [] | a : [a] -- do explicitly: deriving (Eq, Ord)
+ -- to avoid weird names like con2tag_[]#
+
+instance (Eq a) => Eq [a] where
+ [] == [] = True
+ (x:xs) == (y:ys) = x == y && xs == ys
+ [] == ys = False
+ xs == [] = False
+ xs /= ys = if (xs == ys) then False else True
+
+instance (Ord a) => Ord [a] where
+ a < b = case compare a b of { LT -> True; EQ -> False; GT -> False }
+ a <= b = case compare a b of { LT -> True; EQ -> True; GT -> False }
+ a >= b = case compare a b of { LT -> False; EQ -> True; GT -> True }
+ a > b = case compare a b of { LT -> False; EQ -> False; GT -> True }
+
+ max a b = case compare a b of { LT -> b; EQ -> a; GT -> a }
+ min a b = case compare a b of { LT -> a; EQ -> a; GT -> b }
+
+ compare [] [] = EQ
+ compare (x:xs) [] = GT
+ compare [] (y:ys) = LT
+ compare (x:xs) (y:ys) = case compare x y of
+ LT -> LT
+ GT -> GT
+ EQ -> compare xs ys
+
+instance Functor [] where
+ map f [] = []
+ map f (x:xs) = f x : map f xs
+
+instance Monad [] where
+ m >>= k = foldr ((++) . k) [] m
+ return x = [x]
+
+instance MonadZero [] where
+ zero = []
+
+instance MonadPlus [] where
+ xs ++ ys = foldr (:) ys xs
+
+instance (Show a) => Show [a] where
+ showsPrec p = showList
+ showList = showList__ (showsPrec 0)
+\end{code}
+
+\end{code}
+
+A few list functions that appear here because they are used here.
+The rest of the prelude list functions are in PrelList.
+
+\begin{code}
+foldr :: (a -> b -> b) -> b -> [a] -> b
+foldr f z [] = z
+foldr f z (x:xs) = f x (foldr f z xs)
+
+-- takeWhile, applied to a predicate p and a list xs, returns the longest
+-- prefix (possibly empty) of xs of elements that satisfy p. dropWhile p xs
+-- returns the remaining suffix. Span p xs is equivalent to
+-- (takeWhile p xs, dropWhile p xs), while break p uses the negation of p.
+
+takeWhile :: (a -> Bool) -> [a] -> [a]
+takeWhile p [] = []
+takeWhile p (x:xs)
+ | p x = x : takeWhile p xs
+ | otherwise = []
+
+dropWhile :: (a -> Bool) -> [a] -> [a]
+dropWhile p [] = []
+dropWhile p xs@(x:xs')
+ | p x = dropWhile p xs'
+ | otherwise = xs
+
+-- List index (subscript) operator, 0-origin
+(!!) :: [a] -> Int -> a
+(x:_) !! 0 = x
+(_:xs) !! n | n > 0 = xs !! (n-1)
+(_:_) !! _ = error "PreludeList.!!: negative index"
+[] !! _ = error "PreludeList.!!: index too large"
+\end{code}
+
+
+%*********************************************************
+%* *
+\subsection{Type @Void@}
+%* *
+%*********************************************************
+
+The type @Void@ is built in, but it needs a @Show@ instance.
+
+\begin{code}
+instance Show Void where
+ showsPrec p f = showString "<<void>>"
+ showList = showList__ (showsPrec 0)
+\end{code}
+
+
+%*********************************************************
+%* *
+\subsection{Type @Bool@}
+%* *
+%*********************************************************
+
+\begin{code}
+data Bool = False | True deriving (Eq, Ord, Enum, Bounded, Show {- Read -})
+
+-- Boolean functions
+
+(&&), (||) :: Bool -> Bool -> Bool
+True && x = x
+False && _ = False
+True || _ = True
+False || x = x
+
+not :: Bool -> Bool
+not True = False
+not False = True
+
+otherwise :: Bool
+otherwise = True
+\end{code}
+
+
+%*********************************************************
+%* *
+\subsection{Type @Maybe@}
+%* *
+%*********************************************************
+
+\begin{code}
+data Maybe a = Nothing | Just a deriving (Eq, Ord, Show {- Read -})
+
+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
+ return = Just
+
+instance MonadZero Maybe where
+ zero = Nothing
+
+instance MonadPlus Maybe where
+ Nothing ++ ys = ys
+ xs ++ ys = xs
+\end{code}
+
+
+%*********************************************************
+%* *
+\subsection{The @()@ type}
+%* *
+%*********************************************************
+
+The Unit type is here because virtually any program needs it (whereas
+some programs may get away without consulting PrelTup). Furthermore,
+the renamer currently *always* asks for () to be in scope, so that
+ccalls can use () as their default type; so when compiling PrelBase we
+need (). (We could arrange suck in () only if -fglasgow-exts, but putting
+it here seems more direct.
+
+\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 Ord () where
+ () <= () = True
+ () < () = False
+ () >= () = True
+ () > () = False
+ max () () = ()
+ min () () = ()
+ compare () () = EQ
+
+instance Enum () where
+ toEnum 0 = ()
+ toEnum _ = error "Prelude.Enum.().toEnum: argument not 0"
+ fromEnum () = 0
+ enumFrom () = [()]
+ enumFromThen () () = [()]
+ enumFromTo () () = [()]
+ enumFromThenTo () () () = [()]
+
+instance Bounded () where
+ minBound = ()
+ maxBound = ()
+
+instance Show () where
+ showsPrec p () = showString "()"
+\end{code}
+
+%*********************************************************
+%* *
+\subsection{Type @Either@}
+%* *
+%*********************************************************
+
+\begin{code}
+data Either a b = Left a | Right b deriving (Eq, Ord, Show {- Read -} )
+
+either :: (a -> c) -> (b -> c) -> Either a b -> c
+either f g (Left x) = f x
+either f g (Right y) = g y
+\end{code}
+
+
+%*********************************************************
+%* *
+\subsection{Type @Ordering@}
+%* *
+%*********************************************************
+
+\begin{code}
+data Ordering = LT | EQ | GT deriving (Eq, Ord, Enum, Bounded, Show {- Read -})
+\end{code}
+
+
+%*********************************************************
+%* *
+\subsection{Type @Char@ and @String@}
+%* *
+%*********************************************************
+
+\begin{code}
+type String = [Char]
+
+data Char = C# Char# deriving (Eq, Ord)
+
+instance Enum Char where
+ toEnum (I# i) | i >=# 0# && i <=# 255# = C# (chr# i)
+ | otherwise = error "Prelude.Enum.Char.toEnum:out of range"
+ 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#
+ enumFromThenTo (C# c1) (C# c2) (C# c3) = eftt (ord# c1) (ord# c2 -# ord# c1) (ord# c3)
+
+eftt :: Int# -> Int# -> Int# -> [Char]
+eftt now step limit
+ = go now
+ where
+ go now | now ># limit = []
+ | otherwise = C# (chr# now) : go (now +# step)
+
+instance Bounded Char where
+ minBound = '\0'
+ maxBound = '\255'
+
+instance Show Char where
+ showsPrec p '\'' = showString "'\\''"
+ showsPrec p c = showChar '\'' . showLitChar c . showChar '\''
+
+ showList cs = showChar '"' . showl cs
+ where showl "" = showChar '"'
+ showl ('"':cs) = showString "\\\"" . showl cs
+ showl (c:cs) = showLitChar c . showl cs
+\end{code}
+
+
+\begin{code}
+isAscii, isControl, isPrint, isSpace, isUpper,
+ isLower, isAlpha, isDigit, isOctDigit, isHexDigit, isAlphanum :: Char -> Bool
+isAscii c = fromEnum c < 128
+isControl c = c < ' ' || c >= '\DEL' && c <= '\x9f'
+isPrint c = not (isControl c)
+
+-- isSpace includes non-breaking space
+-- Done with explicit equalities both for efficiency, and to avoid a tiresome
+-- recursion with PrelList elem
+isSpace c = c == ' ' ||
+ c == '\t' ||
+ c == '\n' ||
+ c == '\r' ||
+ c == '\f' ||
+ c == '\v' ||
+ c == '\xa0'
+
+-- The upper case ISO characters have the multiplication sign dumped
+-- randomly in the middle of the range. Go figure.
+isUpper c = c >= 'A' && c <= 'Z' ||
+ c >= '\xC0' && c <= '\xD6' ||
+ c >= '\xD8' && c <= '\xDE'
+-- The lower case ISO characters have the division sign dumped
+-- randomly in the middle of the range. Go figure.
+isLower c = c >= 'a' && c <= 'z' ||
+ c >= '\xDF' && c <= '\xF6' ||
+ c >= '\xF8' && c <= '\xFF'
+isAlpha c = isUpper c || isLower 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)
+
+toUpper, toLower :: Char -> Char
+toUpper c | isLower c = toEnum (fromEnum c - fromEnum 'a'
+ + fromEnum 'A')
+ | otherwise = c
+
+toLower c | isUpper c = toEnum (fromEnum c - fromEnum 'A'
+ + fromEnum 'a')
+ | otherwise = c
+
+asciiTab = -- Using an array drags in the array module. listArray ('\NUL', ' ')
+ ["NUL", "SOH", "STX", "ETX", "EOT", "ENQ", "ACK", "BEL",
+ "BS", "HT", "LF", "VT", "FF", "CR", "SO", "SI",
+ "DLE", "DC1", "DC2", "DC3", "DC4", "NAK", "SYN", "ETB",
+ "CAN", "EM", "SUB", "ESC", "FS", "GS", "RS", "US",
+ "SP"]
+\end{code}
+
+%*********************************************************
+%* *
+\subsection{Type @Int@}
+%* *
+%*********************************************************
+
+\begin{code}
+data Int = I# Int# deriving (Eq,Ord)
+
+instance Enum Int where
+ toEnum x = x
+ fromEnum x = x
+#ifndef USE_FOLDR_BUILD
+ enumFrom x = x : enumFrom (x `plusInt` 1)
+ enumFromTo n m = takeWhile (<= m) (enumFrom n)
+#else
+ {-# INLINE enumFrom #-}
+ {-# INLINE enumFromTo #-}
+ enumFrom x = build (\ c _ ->
+ let g x = x `c` g (x `plusInt` 1) in g x)
+ enumFromTo x y = build (\ c n ->
+ let g x = if x <= y then x `c` g (x `plusInt` 1) else n in g x)
+#endif
+ enumFromThen m n = en' m (n `minusInt` m)
+ where en' m n = m : en' (m `plusInt` n) n
+ 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 Num Int where
+ (+) x y = plusInt x y
+ (-) x y = minusInt x y
+ negate x = negateInt x
+ (*) x y = timesInt x y
+ abs n = if n `geInt` 0 then n else (negateInt n)
+
+ signum n | n `ltInt` 0 = negateInt 1
+ | n `eqInt` 0 = 0
+ | otherwise = 1
+
+ fromInteger (J# a# s# d#)
+ = case (integer2Int# a# s# d#) of { i# -> I# i# }
+
+ fromInt n = n
+
+instance Show Int where
+ showsPrec p n = showSignedInt p n
+ showList = showList__ (showsPrec 0)
+\end{code}
+
+
+%*********************************************************
+%* *
+\subsection{Type @Integer@, @Float@, @Double@}
+%* *
+%*********************************************************
+
+Just the type declarations. If we don't actually use any @Integers@ we'd
+rather not link the @Integer@ module at all; and the default-decl stuff
+in the renamer tends to slurp in @Double@ regardless.
+
+\begin{code}
+data Float = F# Float# deriving (Eq, Ord)
+data Double = D# Double# deriving (Eq, Ord)
+data Integer = J# Int# Int# ByteArray#
+\end{code}
+
+
+%*********************************************************
+%* *
+\subsection{The function type}
+%* *
+%*********************************************************
+
+\begin{code}
+instance Show (a -> b) where
+ showsPrec p f = showString "<<function>>"
+ showList = showList__ (showsPrec 0)
+
+-- identity function
+id :: a -> a
+id x = x
+
+-- constant function
+const :: a -> b -> a
+const x _ = x
+
+-- function composition
+{-# INLINE (.) #-}
+{-# GENERATE_SPECS (.) a b c #-}
+(.) :: (b -> c) -> (a -> b) -> a -> c
+f . g = \ x -> f (g x)
+
+-- flip f takes its (first) two arguments in the reverse order of f.
+flip :: (a -> b -> c) -> b -> a -> c
+flip f x y = f y x
+
+-- right-associating infix application operator (useful in continuation-
+-- passing style)
+($) :: (a -> b) -> a -> b
+f $ x = f x
+
+-- until p f yields the result of applying f until p holds.
+until :: (a -> Bool) -> (a -> a) -> a -> a
+until p f x | p x = x
+ | otherwise = until p f (f x)
+
+-- asTypeOf is a type-restricted version of const. It is usually used
+-- as an infix operator, and its typing forces its first argument
+-- (which is usually overloaded) to have the same type as the second.
+asTypeOf :: a -> a -> a
+asTypeOf = const
+\end{code}
+
+
+%*********************************************************
+%* *
+\subsection{Miscellaneous}
+%* *
+%*********************************************************
+
+
+\begin{code}
+data Addr = A# Addr# deriving (Eq, Ord) -- Glasgow extension
+data Word = W# Word# deriving (Eq, Ord) -- Glasgow extension
+
+data Lift a = Lift a
+{-# GENERATE_SPECS data a :: Lift a #-}
+\end{code}
+
+
+
+
+%*********************************************************
+%* *
+\subsection{Support code for @Show@}
+%* *
+%*********************************************************
+
+\begin{code}
+shows :: (Show a) => a -> ShowS
+shows = showsPrec 0
+
+show :: (Show a) => a -> String
+show x = shows x ""
+
+showChar :: Char -> ShowS
+showChar = (:)
+
+showString :: String -> ShowS
+showString = (++)
+
+showParen :: Bool -> ShowS -> ShowS
+showParen b p = if b then showChar '(' . p . showChar ')' else p
+
+{-# GENERATE_SPECS showList__ a #-}
+showList__ :: (a -> ShowS) -> [a] -> ShowS
+
+showList__ showx [] = showString "[]"
+showList__ showx (x:xs) = showChar '[' . showx x . showl xs
+ where
+ showl [] = showChar ']'
+ showl (x:xs) = showString ", " . showx x . showl xs
+
+showSpace :: ShowS
+showSpace = {-showChar ' '-} \ xs -> ' ' : xs
+\end{code}
+
+Code specific for characters
+
+\begin{code}
+showLitChar :: Char -> ShowS
+showLitChar c | c > '\DEL' = showChar '\\' . protectEsc isDigit (shows (ord c))
+showLitChar '\DEL' = showString "\\DEL"
+showLitChar '\\' = showString "\\\\"
+showLitChar c | c >= ' ' = showChar c
+showLitChar '\a' = showString "\\a"
+showLitChar '\b' = showString "\\b"
+showLitChar '\f' = showString "\\f"
+showLitChar '\n' = showString "\\n"
+showLitChar '\r' = showString "\\r"
+showLitChar '\t' = showString "\\t"
+showLitChar '\v' = showString "\\v"
+showLitChar '\SO' = protectEsc (== 'H') (showString "\\SO")
+showLitChar c = showString ('\\' : asciiTab!!ord c)
+
+protectEsc p f = f . cont
+ where cont s@(c:_) | p c = "\\&" ++ s
+ cont s = s
+\end{code}
+
+Code specific for Ints.
+
+\begin{code}
+showSignedInt :: Int -> Int -> ShowS
+showSignedInt p (I# n) r
+ = -- from HBC version; support code follows
+ if n <# 0# && p > 6 then '(':itos n++(')':r) else itos n ++ r
+
+itos :: Int# -> String
+itos n =
+ if n <# 0# then
+ if negateInt# n <# 0# then
+ -- n is minInt, a difficult number
+ itos (n `quotInt#` 10#) ++ itos' (negateInt# (n `remInt#` 10#)) []
+ else
+ '-':itos' (negateInt# n) []
+ else
+ itos' n []
+ where
+ itos' :: Int# -> String -> String
+ itos' n cs =
+ if n <# 10# then
+ C# (chr# (n +# ord# '0'#)) : cs
+ else
+ itos' (n `quotInt#` 10#) (C# (chr# (n `remInt#` 10# +# ord# '0'#)) : cs)
+\end{code}
+
+%*********************************************************
+%* *
+\subsection{Numeric primops}
+%* *
+%*********************************************************
+
+Definitions of the boxed PrimOps; these will be
+used in the case of partial applications, etc.
+
+\begin{code}
+plusInt (I# x) (I# y) = I# (x +# y)
+minusInt(I# x) (I# y) = I# (x -# y)
+timesInt(I# x) (I# y) = I# (x *# y)
+quotInt (I# x) (I# y) = I# (quotInt# x y)
+remInt (I# x) (I# y) = I# (remInt# x y)
+negateInt (I# x) = I# (negateInt# x)
+gtInt (I# x) (I# y) = x ># y
+geInt (I# x) (I# y) = x >=# y
+eqInt (I# x) (I# y) = x ==# y
+neInt (I# x) (I# y) = x /=# y
+ltInt (I# x) (I# y) = x <# y
+leInt (I# x) (I# y) = x <=# y
+\end{code}
--- /dev/null
+%
+% (c) The AQUA Project, Glasgow University, 1994-1996
+%
+
+\section[PrelIO]{Module @PrelIO@}
+
+Input/output functions mandated by the standard Prelude.
+
+\begin{code}
+module PrelIO (
+ IO, FilePath, IOError,
+ fail, userError, catch,
+ putChar, putStr, putStrLn, print,
+ getChar, getLine, getContents, interact,
+ readFile, writeFile, appendFile, readIO, readLn
+ ) where
+
+import Prelude ()
+import IO
+import IOHandle
+import IOBase
+import PrelBase
+import PrelRead
+
+\end{code}
+
+\begin{code}
+putChar :: Char -> IO ()
+putChar c = hPutChar stdout c
+
+putStr :: String -> IO ()
+putStr s = hPutStr stdout s
+
+putStrLn :: String -> IO ()
+putStrLn s = do putStr s
+ putChar '\n'
+
+print :: Show a => a -> IO ()
+print x = putStrLn (show x)
+
+getChar :: IO Char
+getChar = hGetChar stdin
+
+getLine :: IO String
+getLine = do c <- getChar
+ if c == '\n' then return "" else
+ do s <- getLine
+ return (c:s)
+
+getContents :: IO String
+getContents = hGetContents stdin
+
+interact :: (String -> String) -> IO ()
+interact f = do s <- getContents
+ putStr (f s)
+
+readFile :: FilePath -> IO String
+readFile name = openFile name ReadMode >>= hGetContents
+
+writeFile :: FilePath -> String -> IO ()
+writeFile name str
+ = openFile name WriteMode >>= \hdl -> hPutStr hdl str >> hClose hdl
+
+appendFile :: FilePath -> String -> IO ()
+appendFile name str
+ = openFile name AppendMode >>= \hdl -> hPutStr hdl str >> hClose hdl
+
+readIO :: Read a => String -> IO a
+ -- raises an exception instead of an error
+readIO s = case [x | (x,t) <- reads s, ("","") <- lex t] of
+ [x] -> return x
+ [] -> fail (userError "PreludeIO.readIO: no parse")
+ _ -> fail (userError
+ "PreludeIO.readIO: ambiguous parse")
+
+readLn :: Read a => IO a
+readLn = do l <- getLine
+ r <- readIO l
+ return r
+\end{code}
--- /dev/null
+%
+% (c) The AQUA Project, Glasgow University, 1994-1996
+%
+
+\section[PrelList]{Module @PrelList@}
+
+The List data type and its operations
+
+\begin{code}
+module PrelList (
+ [] (..),
+
+ head, last, tail, init, null, length, (!!),
+ foldl, foldl1, scanl, scanl1, foldr, foldr1, scanr, scanr1,
+ iterate, repeat, replicate, cycle,
+ take, drop, splitAt, takeWhile, dropWhile, span, break,
+ lines, words, unlines, unwords, reverse, and, or,
+ any, all, elem, notElem, lookup,
+ sum, product, maximum, minimum, concatMap,
+ zip, zip3, zipWith, zipWith3, unzip, unzip3
+ ) where
+
+import Prelude ()
+import IOBase ( error ) {-# SOURCE #-}
+import PrelTup
+import PrelBase
+
+infix 4 `elem`, `notElem`
+\end{code}
+
+%*********************************************************
+%* *
+\subsection{List-manipulation functions}
+%* *
+%*********************************************************
+
+\begin{code}
+-- head and tail extract the first element and remaining elements,
+-- respectively, of a list, which must be non-empty. last and init
+-- are the dual functions working from the end of a finite list,
+-- rather than the beginning.
+
+head :: [a] -> a
+head (x:_) = x
+head [] = error "PreludeList.head: empty list"
+
+last :: [a] -> a
+last [x] = x
+last (_:xs) = last xs
+last [] = error "PreludeList.last: empty list"
+
+tail :: [a] -> [a]
+tail (_:xs) = xs
+tail [] = error "PreludeList.tail: empty list"
+
+init :: [a] -> [a]
+init [x] = []
+init (x:xs) = x : init xs
+init [] = error "PreludeList.init: empty list"
+
+null :: [a] -> Bool
+null [] = True
+null (_:_) = False
+
+-- length returns the length of a finite list as an Int; it is an instance
+-- of the more general genericLength, the result type of which may be
+-- any kind of number.
+length :: [a] -> Int
+length [] = 0
+length (_:l) = 1 + length l
+
+-- foldl, applied to a binary operator, a starting value (typically the
+-- left-identity of the operator), and a list, reduces the list using
+-- the binary operator, from left to right:
+-- foldl f z [x1, x2, ..., xn] == (...((z `f` x1) `f` x2) `f`...) `f` xn
+-- foldl1 is a variant that has no starting value argument, and thus must
+-- be applied to non-empty lists. scanl is similar to foldl, but returns
+-- a list of successive reduced values from the left:
+-- scanl f z [x1, x2, ...] == [z, z `f` x1, (z `f` x1) `f` x2, ...]
+-- Note that last (scanl f z xs) == foldl f z xs.
+-- scanl1 is similar, again without the starting element:
+-- scanl1 f [x1, x2, ...] == [x1, x1 `f` x2, ...]
+
+foldl :: (a -> b -> a) -> a -> [b] -> a
+foldl f z [] = z
+foldl f z (x:xs) = foldl f (f z x) xs
+
+foldl1 :: (a -> a -> a) -> [a] -> a
+foldl1 f (x:xs) = foldl f x xs
+foldl1 _ [] = error "PreludeList.foldl1: empty list"
+
+scanl :: (a -> b -> a) -> a -> [b] -> [a]
+scanl f q xs = q : (case xs of
+ [] -> []
+ x:xs -> scanl f (f q x) xs)
+
+scanl1 :: (a -> a -> a) -> [a] -> [a]
+scanl1 f (x:xs) = scanl f x xs
+scanl1 _ [] = error "PreludeList.scanl1: empty list"
+
+-- foldr, foldr1, scanr, and scanr1 are the right-to-left duals of the
+-- above functions.
+
+foldr1 :: (a -> a -> a) -> [a] -> a
+foldr1 f [x] = x
+foldr1 f (x:xs) = f x (foldr1 f xs)
+foldr1 _ [] = error "PreludeList.foldr1: empty list"
+
+scanr :: (a -> b -> b) -> b -> [a] -> [b]
+scanr f q0 [] = [q0]
+scanr f q0 (x:xs) = f x q : qs
+ where qs@(q:_) = scanr f q0 xs
+
+scanr1 :: (a -> a -> a) -> [a] -> [a]
+scanr1 f [x] = [x]
+scanr1 f (x:xs) = f x q : qs
+ where qs@(q:_) = scanr1 f xs
+scanr1 _ [] = error "PreludeList.scanr1: empty list"
+
+-- iterate f x returns an infinite list of repeated applications of f to x:
+-- iterate f x == [x, f x, f (f x), ...]
+iterate :: (a -> a) -> a -> [a]
+iterate f x = x : iterate f (f x)
+
+-- repeat x is an infinite list, with x the value of every element.
+repeat :: a -> [a]
+repeat x = xs where xs = x:xs
+
+-- replicate n x is a list of length n with x the value of every element
+replicate :: Int -> a -> [a]
+replicate n x = take n (repeat x)
+
+-- cycle ties a finite list into a circular one, or equivalently,
+-- the infinite repetition of the original list. It is the identity
+-- on infinite lists.
+
+cycle :: [a] -> [a]
+cycle xs = xs' where xs' = xs ++ xs'
+
+-- take n, applied to a list xs, returns the prefix of xs of length n,
+-- or xs itself if n > length xs. drop n xs returns the suffix of xs
+-- after the first n elements, or [] if n > length xs. splitAt n xs
+-- is equivalent to (take n xs, drop n xs).
+
+take :: Int -> [a] -> [a]
+take 0 _ = []
+take _ [] = []
+take n (x:xs) | n > 0 = x : take (n-1) xs
+take _ _ = error "PreludeList.take: negative argument"
+
+drop :: Int -> [a] -> [a]
+drop 0 xs = xs
+drop _ [] = []
+drop n (_:xs) | n > 0 = drop (n-1) xs
+drop _ _ = error "PreludeList.drop: negative argument"
+
+splitAt :: Int -> [a] -> ([a],[a])
+splitAt 0 xs = ([],xs)
+splitAt _ [] = ([],[])
+splitAt n (x:xs) | n > 0 = (x:xs',xs'') where (xs',xs'') = splitAt (n-1) xs
+splitAt _ _ = error "PreludeList.splitAt: negative argument"
+
+span, break :: (a -> Bool) -> [a] -> ([a],[a])
+span p [] = ([],[])
+span p xs@(x:xs')
+ | p x = let (ys,zs) = span p xs' in (x:ys,zs)
+ | otherwise = ([],xs)
+break p = span (not . p)
+
+-- reverse xs returns the elements of xs in reverse order. xs must be finite.
+reverse :: [a] -> [a]
+reverse = foldl (flip (:)) []
+
+-- and returns the conjunction of a Boolean list. For the result to be
+-- True, the list must be finite; False, however, results from a False
+-- value at a finite index of a finite or infinite list. or is the
+-- disjunctive dual of and.
+and, or :: [Bool] -> Bool
+and = foldr (&&) True
+or = foldr (||) False
+
+-- Applied to a predicate and a list, any determines if any element
+-- of the list satisfies the predicate. Similarly, for all.
+any, all :: (a -> Bool) -> [a] -> Bool
+any p = or . map p
+all p = and . map p
+
+-- elem is the list membership predicate, usually written in infix form,
+-- e.g., x `elem` xs. notElem is the negation.
+elem, notElem :: (Eq a) => a -> [a] -> Bool
+elem x = any (== x)
+notElem x = all (not . (/= x))
+
+-- lookup key assocs looks up a key in an association list.
+lookup :: (Eq a) => a -> [(a,b)] -> Maybe b
+lookup key [] = Nothing
+lookup key ((x,y):xys)
+ | key == x = Just y
+ | otherwise = lookup key xys
+
+-- sum and product compute the sum or product of a finite list of numbers.
+sum, product :: (Num a) => [a] -> a
+sum = foldl (+) 0
+product = foldl (*) 1
+
+-- maximum and minimum return the maximum or minimum value from a list,
+-- which must be non-empty, finite, and of an ordered type.
+maximum, minimum :: (Ord a) => [a] -> a
+maximum [] = error "PreludeList.maximum: empty list"
+maximum xs = foldl1 max xs
+
+minimum [] = error "PreludeList.minimum: empty list"
+minimum xs = foldl1 min xs
+
+concatMap :: (a -> [b]) -> [a] -> [b]
+concatMap f = foldr ((++) . f) []
+\end{code}
+
+
+%*********************************************************
+%* *
+\subsection{The zip family}
+%* *
+%*********************************************************
+
+zip takes two lists and returns a list of corresponding pairs. If one
+input list is short, excess elements of the longer list are discarded.
+zip3 takes three lists and returns a list of triples. Zips for larger
+tuples are in the List library
+
+\begin{code}
+zip :: [a] -> [b] -> [(a,b)]
+zip = zipWith (,)
+
+zip3 :: [a] -> [b] -> [c] -> [(a,b,c)]
+zip3 = zipWith3 (,,)
+
+-- The zipWith family generalises the zip family by zipping with the
+-- function given as the first argument, instead of a tupling function.
+-- For example, zipWith (+) is applied to two lists to produce the list
+-- of corresponding sums.
+
+zipWith :: (a->b->c) -> [a]->[b]->[c]
+zipWith z (a:as) (b:bs) = z a b : zipWith z as bs
+zipWith _ _ _ = []
+
+zipWith3 :: (a->b->c->d) -> [a]->[b]->[c]->[d]
+zipWith3 z (a:as) (b:bs) (c:cs)
+ = z a b c : zipWith3 z as bs cs
+zipWith3 _ _ _ _ = []
+
+
+-- unzip transforms a list of pairs into a pair of lists.
+
+unzip :: [(a,b)] -> ([a],[b])
+unzip = foldr (\(a,b) ~(as,bs) -> (a:as,b:bs)) ([],[])
+
+unzip3 :: [(a,b,c)] -> ([a],[b],[c])
+unzip3 = foldr (\(a,b,c) ~(as,bs,cs) -> (a:as,b:bs,c:cs))
+ ([],[],[])
+\end{code}
+
+%*********************************************************
+%* *
+\subsection{Functions on strings}
+%* *
+%*********************************************************
+
+lines breaks a string up into a list of strings at newline characters.
+The resulting strings do not contain newlines. Similary, words
+breaks a string up into a list of words, which were delimited by
+white space. unlines and unwords are the inverse operations.
+unlines joins lines with terminating newlines, and unwords joins
+words with separating spaces.
+
+\begin{code}
+lines :: String -> [String]
+lines "" = []
+lines s = let (l, s') = break (== '\n') s
+ in l : case s' of
+ [] -> []
+ (_:s'') -> lines s''
+
+words :: String -> [String]
+words s = case dropWhile {-partain:Char.-}isSpace s of
+ "" -> []
+ s' -> w : words s''
+ where (w, s'') =
+ break {-partain:Char.-}isSpace s'
+
+unlines :: [String] -> String
+unlines = concatMap (++ "\n")
+
+unwords :: [String] -> String
+unwords [] = ""
+unwords ws = foldr1 (\w s -> w ++ ' ':s) ws
+\end{code}
--- /dev/null
+%
+% (c) The AQUA Project, Glasgow University, 1994-1996
+%
+
+\section[PrelNum]{Module @PrelNum@}
+
+Numeric part of the prelude.
+
+It's rather big!
+
+\begin{code}
+{-# OPTIONS -H20m #-}
+#include "../includes/ieee-flpt.h"
+\end{code}
+
+\begin{code}
+module PrelNum where
+
+import Prelude ()
+import IOBase ( error ) {-# SOURCE #-}
+import PrelList
+import PrelBase
+import GHC
+
+infixr 8 ^, ^^, **
+infixl 7 %, `quot`, `rem`, `div`, `mod`
+\end{code}
+
+
+%*********************************************************
+%* *
+\subsection{Standard numeric classes}
+%* *
+%*********************************************************
+
+\begin{code}
+class (Num a, Ord a) => Real a where
+ toRational :: a -> Rational
+
+class (Real a, Enum a) => Integral a where
+ quot, rem, div, mod :: a -> a -> a
+ quotRem, divMod :: a -> a -> (a,a)
+ toInteger :: a -> Integer
+ toInt :: a -> Int -- partain: Glasgow extension
+
+ n `quot` d = q where (q,r) = quotRem n d
+ n `rem` d = r where (q,r) = quotRem n d
+ n `div` d = q where (q,r) = divMod n d
+ n `mod` d = r where (q,r) = divMod n d
+ divMod n d = if signum r == negate (signum d) then (q-1, r+d) else qr
+ where qr@(q,r) = quotRem n d
+
+class (Num a) => Fractional a where
+ (/) :: a -> a -> a
+ recip :: a -> a
+ fromRational :: Rational -> a
+
+ recip x = 1 / x
+
+class (Fractional a) => Floating a where
+ pi :: a
+ exp, log, sqrt :: a -> a
+ (**), logBase :: a -> a -> a
+ sin, cos, tan :: a -> a
+ asin, acos, atan :: a -> a
+ sinh, cosh, tanh :: a -> a
+ asinh, acosh, atanh :: a -> a
+
+ x ** y = exp (log x * y)
+ logBase x y = log y / log x
+ sqrt x = x ** 0.5
+ tan x = sin x / cos x
+ tanh x = sinh x / cosh x
+
+class (Real a, Fractional a) => RealFrac a where
+ properFraction :: (Integral b) => a -> (b,a)
+ truncate, round :: (Integral b) => a -> b
+ ceiling, floor :: (Integral b) => a -> b
+
+ truncate x = m where (m,_) = properFraction x
+
+ round x = let (n,r) = properFraction x
+ m = if r < 0 then n - 1 else n + 1
+ in case signum (abs r - 0.5) of
+ -1 -> n
+ 0 -> if even n then n else m
+ 1 -> m
+
+ ceiling x = if r > 0 then n + 1 else n
+ where (n,r) = properFraction x
+
+ floor x = if r < 0 then n - 1 else n
+ where (n,r) = properFraction x
+
+class (RealFrac a, Floating a) => RealFloat a where
+ floatRadix :: a -> Integer
+ floatDigits :: a -> Int
+ floatRange :: a -> (Int,Int)
+ decodeFloat :: a -> (Integer,Int)
+ encodeFloat :: Integer -> Int -> a
+ exponent :: a -> Int
+ significand :: a -> a
+ scaleFloat :: Int -> a -> a
+ isNaN, isInfinite, isDenormalized, isNegativeZero, isIEEE
+ :: a -> Bool
+
+ exponent x = if m == 0 then 0 else n + floatDigits x
+ where (m,n) = decodeFloat x
+
+ significand x = encodeFloat m (negate (floatDigits x))
+ where (m,_) = decodeFloat x
+
+ scaleFloat k x = encodeFloat m (n+k)
+ where (m,n) = decodeFloat x
+\end{code}
+
+%*********************************************************
+%* *
+\subsection{Overloaded numeric functions}
+%* *
+%*********************************************************
+
+\begin{code}
+even, odd :: (Integral a) => a -> Bool
+even n = n `rem` 2 == 0
+odd = not . even
+
+{-# GENERATE_SPECS gcd a{Int#,Int,Integer} #-}
+gcd :: (Integral a) => a -> a -> a
+gcd 0 0 = error "Prelude.gcd: gcd 0 0 is undefined"
+gcd x y = gcd' (abs x) (abs y)
+ where gcd' x 0 = x
+ gcd' x y = gcd' y (x `rem` y)
+
+{-# GENERATE_SPECS lcm a{Int#,Int,Integer} #-}
+lcm :: (Integral a) => a -> a -> a
+lcm _ 0 = 0
+lcm 0 _ = 0
+lcm x y = abs ((x `quot` (gcd x y)) * y)
+
+(^) :: (Num a, Integral b) => a -> b -> a
+x ^ 0 = 1
+x ^ n | n > 0 = f x (n-1) x
+ where f _ 0 y = y
+ f x n y = g x n where
+ g x n | even n = g (x*x) (n `quot` 2)
+ | otherwise = f x (n-1) (x*y)
+_ ^ _ = error "Prelude.^: negative exponent"
+
+(^^) :: (Fractional a, Integral b) => a -> b -> a
+x ^^ n = if n >= 0 then x^n else recip (x^(negate n))
+
+fromIntegral :: (Integral a, Num b) => a -> b
+fromIntegral = fromInteger . toInteger
+
+fromRealFrac :: (RealFrac a, Fractional b) => a -> b
+fromRealFrac = fromRational . toRational
+
+atan2 :: (RealFloat a) => a -> a -> a
+atan2 y x = case (signum y, signum x) of
+ ( 0, 1) -> 0
+ ( 1, 0) -> pi/2
+ ( 0,-1) -> pi
+ (-1, 0) -> (negate pi)/2
+ ( _, 1) -> atan (y/x)
+ ( _,-1) -> atan (y/x) + pi
+ ( 0, 0) -> error "Prelude.atan2: atan2 of origin"
+\end{code}
+
+
+%*********************************************************
+%* *
+\subsection{Instances for @Int@}
+%* *
+%*********************************************************
+
+\begin{code}
+instance Real Int where
+ toRational x = toInteger x % 1
+
+instance Integral Int where
+ a@(I# _) `quotRem` b@(I# _) = (a `quotInt` b, a `remInt` b)
+ -- OK, so I made it a little stricter. Shoot me. (WDP 94/10)
+
+ -- following chks for zero divisor are non-standard (WDP)
+ a `quot` b = if b /= 0
+ then a `quotInt` b
+ else error "Integral.Int.quot{PreludeCore}: divide by 0\n"
+ a `rem` b = if b /= 0
+ then a `remInt` b
+ else error "Integral.Int.rem{PreludeCore}: divide by 0\n"
+
+ x `div` y = if x > 0 && y < 0 then quotInt (x-y-1) y
+ else if x < 0 && y > 0 then quotInt (x-y+1) y
+ else quotInt x y
+ x `mod` y = if x > 0 && y < 0 || x < 0 && y > 0 then
+ if r/=0 then r+y else 0
+ else
+ r
+ where r = remInt x y
+
+ divMod x@(I# _) y@(I# _) = (x `div` y, x `mod` y)
+ -- Stricter. Sorry if you don't like it. (WDP 94/10)
+
+--OLD: even x = eqInt (x `mod` 2) 0
+--OLD: odd x = neInt (x `mod` 2) 0
+
+ toInteger (I# n#) = int2Integer# n# -- give back a full-blown Integer
+ toInt x = x
+
+\end{code}
+
+
+%*********************************************************
+%* *
+\subsection{Type @Integer@}
+%* *
+%*********************************************************
+
+These types are used to return from integer primops
+
+\begin{code}
+data Return2GMPs = Return2GMPs Int# Int# ByteArray# Int# Int# ByteArray#
+data ReturnIntAndGMP = ReturnIntAndGMP Int# Int# Int# ByteArray#
+\end{code}
+
+Instances
+
+\begin{code}
+instance Eq Integer where
+ (J# a1 s1 d1) == (J# a2 s2 d2)
+ = (cmpInteger# a1 s1 d1 a2 s2 d2) ==# 0#
+
+ (J# a1 s1 d1) /= (J# a2 s2 d2)
+ = (cmpInteger# a1 s1 d1 a2 s2 d2) /=# 0#
+
+instance Ord Integer where
+ (J# a1 s1 d1) <= (J# a2 s2 d2)
+ = (cmpInteger# a1 s1 d1 a2 s2 d2) <=# 0#
+
+ (J# a1 s1 d1) < (J# a2 s2 d2)
+ = (cmpInteger# a1 s1 d1 a2 s2 d2) <# 0#
+
+ (J# a1 s1 d1) >= (J# a2 s2 d2)
+ = (cmpInteger# a1 s1 d1 a2 s2 d2) >=# 0#
+
+ (J# a1 s1 d1) > (J# a2 s2 d2)
+ = (cmpInteger# a1 s1 d1 a2 s2 d2) ># 0#
+
+ x@(J# a1 s1 d1) `max` y@(J# a2 s2 d2)
+ = if ((cmpInteger# a1 s1 d1 a2 s2 d2) ># 0#) then x else y
+
+ x@(J# a1 s1 d1) `min` y@(J# a2 s2 d2)
+ = if ((cmpInteger# a1 s1 d1 a2 s2 d2) <# 0#) then x else y
+
+ compare (J# a1 s1 d1) (J# a2 s2 d2)
+ = case cmpInteger# a1 s1 d1 a2 s2 d2 of { res# ->
+ if res# <# 0# then LT else
+ if res# ># 0# then GT else EQ
+ }
+
+instance Num Integer where
+ (+) (J# a1 s1 d1) (J# a2 s2 d2)
+ = plusInteger# a1 s1 d1 a2 s2 d2
+
+ (-) (J# a1 s1 d1) (J# a2 s2 d2)
+ = minusInteger# a1 s1 d1 a2 s2 d2
+
+ negate (J# a s d) = negateInteger# a s d
+
+ (*) (J# a1 s1 d1) (J# a2 s2 d2)
+ = timesInteger# a1 s1 d1 a2 s2 d2
+
+ -- ORIG: abs n = if n >= 0 then n else -n
+
+ abs n@(J# a1 s1 d1)
+ = case 0 of { J# a2 s2 d2 ->
+ if (cmpInteger# a1 s1 d1 a2 s2 d2) >=# 0#
+ then n
+ else negateInteger# a1 s1 d1
+ }
+
+ signum n@(J# a1 s1 d1)
+ = case 0 of { J# a2 s2 d2 ->
+ let
+ cmp = cmpInteger# a1 s1 d1 a2 s2 d2
+ in
+ if cmp ># 0# then 1
+ else if cmp ==# 0# then 0
+ else (negate 1)
+ }
+
+ fromInteger x = x
+
+ fromInt (I# n#) = int2Integer# n# -- gives back a full-blown Integer
+
+instance Real Integer where
+ toRational x = x % 1
+
+instance Integral Integer where
+ quotRem (J# a1 s1 d1) (J# a2 s2 d2)
+ = case (quotRemInteger# a1 s1 d1 a2 s2 d2) of
+ Return2GMPs a3 s3 d3 a4 s4 d4
+ -> (J# a3 s3 d3, J# a4 s4 d4)
+
+{- USING THE UNDERLYING "GMP" CODE IS DUBIOUS FOR NOW:
+
+ divMod (J# a1 s1 d1) (J# a2 s2 d2)
+ = case (divModInteger# a1 s1 d1 a2 s2 d2) of
+ Return2GMPs a3 s3 d3 a4 s4 d4
+ -> (J# a3 s3 d3, J# a4 s4 d4)
+-}
+ toInteger n = n
+ toInt (J# a s d) = case (integer2Int# a s d) of { n# -> I# n# }
+
+ -- the rest are identical to the report default methods;
+ -- you get slightly better code if you let the compiler
+ -- see them right here:
+ n `quot` d = q where (q,r) = quotRem n d
+ n `rem` d = r where (q,r) = quotRem n d
+ n `div` d = q where (q,r) = divMod n d
+ n `mod` d = r where (q,r) = divMod n d
+
+ divMod n d = case (quotRem n d) of { qr@(q,r) ->
+ if signum r == negate (signum d) then (q - 1, r+d) else qr }
+ -- Case-ified by WDP 94/10
+
+instance Enum Integer where
+ enumFrom n = n : enumFrom (n + 1)
+ enumFromThen m n = en' m (n - m)
+ where en' m n = m : en' (m + n) n
+ enumFromTo n m = takeWhile (<= m) (enumFrom n)
+ enumFromThenTo n m p = takeWhile (if m >= n then (<= p) else (>= p))
+ (enumFromThen n m)
+
+instance Show Integer where
+ showsPrec x = showSignedInteger x
+ showList = showList__ (showsPrec 0)
+
+integer_0, integer_1, integer_2, integer_m1 :: Integer
+integer_0 = 0; integer_1 = 1; integer_2 = 2; integer_m1 = -1
+\end{code}
+
+
+%*********************************************************
+%* *
+\subsection{Type @Float@}
+%* *
+%*********************************************************
+
+\begin{code}
+instance Num Float where
+ (+) x y = plusFloat x y
+ (-) x y = minusFloat x y
+ negate x = negateFloat x
+ (*) x y = timesFloat x y
+ abs x | x >= 0.0 = x
+ | otherwise = negateFloat x
+ signum x | x == 0.0 = 0
+ | x > 0.0 = 1
+ | otherwise = negate 1
+ fromInteger n = encodeFloat n 0
+ fromInt i = int2Float i
+
+instance Real Float where
+ toRational x = (m%1)*(b%1)^^n
+ where (m,n) = decodeFloat x
+ b = floatRadix x
+
+instance Fractional Float where
+ (/) x y = divideFloat x y
+ fromRational x = fromRational__ x
+ recip x = 1.0 / x
+
+instance Floating Float where
+ pi = 3.141592653589793238
+ exp x = expFloat x
+ log x = logFloat x
+ sqrt x = sqrtFloat x
+ sin x = sinFloat x
+ cos x = cosFloat x
+ tan x = tanFloat x
+ asin x = asinFloat x
+ acos x = acosFloat x
+ atan x = atanFloat x
+ sinh x = sinhFloat x
+ cosh x = coshFloat x
+ tanh x = tanhFloat x
+ (**) x y = powerFloat x y
+ logBase x y = log y / log x
+
+ asinh x = log (x + sqrt (1.0+x*x))
+ acosh x = log (x + (x+1.0) * sqrt ((x-1.0)/(x+1.0)))
+ atanh x = log ((x+1.0) / sqrt (1.0-x*x))
+
+instance RealFrac Float where
+
+ {-# SPECIALIZE properFraction :: Float -> (Int, Float) #-}
+ {-# SPECIALIZE truncate :: Float -> Int #-}
+ {-# SPECIALIZE round :: Float -> Int #-}
+ {-# SPECIALIZE ceiling :: Float -> Int #-}
+ {-# SPECIALIZE floor :: Float -> Int #-}
+
+ {-# SPECIALIZE properFraction :: Float -> (Integer, Float) #-}
+ {-# SPECIALIZE truncate :: Float -> Integer #-}
+ {-# SPECIALIZE round :: Float -> Integer #-}
+ {-# SPECIALIZE ceiling :: Float -> Integer #-}
+ {-# SPECIALIZE floor :: Float -> Integer #-}
+
+ properFraction x
+ = case (decodeFloat x) of { (m,n) ->
+ let b = floatRadix x in
+ if n >= 0 then
+ (fromInteger m * fromInteger b ^ n, 0.0)
+ else
+ case (quotRem m (b^(negate n))) of { (w,r) ->
+ (fromInteger w, encodeFloat r n)
+ }
+ }
+
+ truncate x = case properFraction x of
+ (n,_) -> n
+
+ round x = case properFraction x of
+ (n,r) -> let
+ m = if r < 0.0 then n - 1 else n + 1
+ half_down = abs r - 0.5
+ in
+ case (compare half_down 0.0) of
+ LT -> n
+ EQ -> if even n then n else m
+ GT -> m
+
+ ceiling x = case properFraction x of
+ (n,r) -> if r > 0.0 then n + 1 else n
+
+ floor x = case properFraction x of
+ (n,r) -> if r < 0.0 then n - 1 else n
+
+instance RealFloat Float where
+ floatRadix _ = FLT_RADIX -- from float.h
+ floatDigits _ = FLT_MANT_DIG -- ditto
+ floatRange _ = (FLT_MIN_EXP, FLT_MAX_EXP) -- ditto
+
+ decodeFloat (F# f#)
+ = case decodeFloat# f# of
+ ReturnIntAndGMP exp# a# s# d# ->
+ (J# a# s# d#, I# exp#)
+
+ encodeFloat (J# a# s# d#) (I# e#)
+ = case encodeFloat# a# s# d# e# of { flt# -> F# flt# }
+
+ exponent x = case decodeFloat x of
+ (m,n) -> if m == 0 then 0 else n + floatDigits x
+
+ significand x = case decodeFloat x of
+ (m,_) -> encodeFloat m (negate (floatDigits x))
+
+ scaleFloat k x = case decodeFloat x of
+ (m,n) -> encodeFloat m (n+k)
+
+instance Show Float where
+ showsPrec x = showSigned showFloat x
+ showList = showList__ (showsPrec 0)
+\end{code}
+
+%*********************************************************
+%* *
+\subsection{Type @Double@}
+%* *
+%*********************************************************
+
+\begin{code}
+instance Num Double where
+ (+) x y = plusDouble x y
+ (-) x y = minusDouble x y
+ negate x = negateDouble x
+ (*) x y = timesDouble x y
+ abs x | x >= 0.0 = x
+ | otherwise = negateDouble x
+ signum x | x == 0.0 = 0
+ | x > 0.0 = 1
+ | otherwise = negate 1
+ fromInteger n = encodeFloat n 0
+ fromInt (I# n#) = case (int2Double# n#) of { d# -> D# d# }
+
+instance Real Double where
+ toRational x = (m%1)*(b%1)^^n
+ where (m,n) = decodeFloat x
+ b = floatRadix x
+
+instance Fractional Double where
+ (/) x y = divideDouble x y
+ fromRational x = fromRational__ x
+ recip x = 1.0 / x
+
+instance Floating Double where
+ pi = 3.141592653589793238
+ exp x = expDouble x
+ log x = logDouble x
+ sqrt x = sqrtDouble x
+ sin x = sinDouble x
+ cos x = cosDouble x
+ tan x = tanDouble x
+ asin x = asinDouble x
+ acos x = acosDouble x
+ atan x = atanDouble x
+ sinh x = sinhDouble x
+ cosh x = coshDouble x
+ tanh x = tanhDouble x
+ (**) x y = powerDouble x y
+ logBase x y = log y / log x
+
+ asinh x = log (x + sqrt (1.0+x*x))
+ acosh x = log (x + (x+1.0) * sqrt ((x-1.0)/(x+1.0)))
+ atanh x = log ((x+1.0) / sqrt (1.0-x*x))
+
+instance RealFrac Double where
+
+ {-# SPECIALIZE properFraction :: Double -> (Int, Double) #-}
+ {-# SPECIALIZE truncate :: Double -> Int #-}
+ {-# SPECIALIZE round :: Double -> Int #-}
+ {-# SPECIALIZE ceiling :: Double -> Int #-}
+ {-# SPECIALIZE floor :: Double -> Int #-}
+
+ {-# SPECIALIZE properFraction :: Double -> (Integer, Double) #-}
+ {-# SPECIALIZE truncate :: Double -> Integer #-}
+ {-# SPECIALIZE round :: Double -> Integer #-}
+ {-# SPECIALIZE ceiling :: Double -> Integer #-}
+ {-# SPECIALIZE floor :: Double -> Integer #-}
+
+#if defined(__UNBOXED_INSTANCES__)
+ {-# SPECIALIZE properFraction :: Double -> (Int#, Double) #-}
+ {-# SPECIALIZE truncate :: Double -> Int# #-}
+ {-# SPECIALIZE round :: Double -> Int# #-}
+ {-# SPECIALIZE ceiling :: Double -> Int# #-}
+ {-# SPECIALIZE floor :: Double -> Int# #-}
+#endif
+
+ properFraction x
+ = case (decodeFloat x) of { (m,n) ->
+ let b = floatRadix x in
+ if n >= 0 then
+ (fromInteger m * fromInteger b ^ n, 0.0)
+ else
+ case (quotRem m (b^(negate n))) of { (w,r) ->
+ (fromInteger w, encodeFloat r n)
+ }
+ }
+
+ truncate x = case properFraction x of
+ (n,_) -> n
+
+ round x = case properFraction x of
+ (n,r) -> let
+ m = if r < 0.0 then n - 1 else n + 1
+ half_down = abs r - 0.5
+ in
+ case (compare half_down 0.0) of
+ LT -> n
+ EQ -> if even n then n else m
+ GT -> m
+
+ ceiling x = case properFraction x of
+ (n,r) -> if r > 0.0 then n + 1 else n
+
+ floor x = case properFraction x of
+ (n,r) -> if r < 0.0 then n - 1 else n
+
+instance RealFloat Double where
+ floatRadix _ = FLT_RADIX -- from float.h
+ floatDigits _ = DBL_MANT_DIG -- ditto
+ floatRange _ = (DBL_MIN_EXP, DBL_MAX_EXP) -- ditto
+
+ decodeFloat (D# d#)
+ = case decodeDouble# d# of
+ ReturnIntAndGMP exp# a# s# d# ->
+ (J# a# s# d#, I# exp#)
+
+ encodeFloat (J# a# s# d#) (I# e#)
+ = case encodeDouble# a# s# d# e# of { dbl# -> D# dbl# }
+
+ exponent x = case decodeFloat x of
+ (m,n) -> if m == 0 then 0 else n + floatDigits x
+
+ significand x = case decodeFloat x of
+ (m,_) -> encodeFloat m (negate (floatDigits x))
+
+ scaleFloat k x = case decodeFloat x of
+ (m,n) -> encodeFloat m (n+k)
+
+instance Show Double where
+ showsPrec x = showSigned showFloat x
+ showList = showList__ (showsPrec 0)
+\end{code}
+
+
+%*********************************************************
+%* *
+\subsection{Common code for @Float@ and @Double@}
+%* *
+%*********************************************************
+
+The Enum instances for Floats and Doubles are slightly unusual.
+The `toEnum' function truncates numbers to Int. The definitions
+of enumFrom and enumFromThen allow floats to be used in arithmetic
+series: [0,0.1 .. 1.0]. However, roundoff errors make these somewhat
+dubious. This example may have either 10 or 11 elements, depending on
+how 0.1 is represented.
+
+\begin{code}
+instance Enum Float where
+ toEnum = fromIntegral
+ fromEnum = fromInteger . truncate -- may overflow
+ enumFrom = numericEnumFrom
+ enumFromThen = numericEnumFromThen
+
+instance Enum Double where
+ toEnum = fromIntegral
+ fromEnum = fromInteger . truncate -- may overflow
+ enumFrom = numericEnumFrom
+ enumFromThen = numericEnumFromThen
+
+numericEnumFrom :: (Real a) => a -> [a]
+numericEnumFromThen :: (Real a) => a -> a -> [a]
+numericEnumFrom = iterate (+1)
+numericEnumFromThen n m = iterate (+(m-n)) n
+\end{code}
+
+
+%*********************************************************
+%* *
+\subsection{The @Ratio@ and @Rational@ types}
+%* *
+%*********************************************************
+
+\begin{code}
+data (Integral a) => Ratio a = a :% a deriving (Eq)
+type Rational = Ratio Integer
+\end{code}
+
+\begin{code}
+(%) :: (Integral a) => a -> a -> Ratio a
+numerator, denominator :: (Integral a) => Ratio a -> a
+approxRational :: (RealFrac a) => a -> a -> Rational
+
+
+reduce _ 0 = error "{Ratio.%}: zero denominator"
+reduce x y = (x `quot` d) :% (y `quot` d)
+ where d = gcd x y
+
+x % y = reduce (x * signum y) (abs y)
+
+numerator (x:%y) = x
+
+denominator (x:%y) = y
+\end{code}
+
+
+@approxRational@, applied to two real fractional numbers x and epsilon,
+returns the simplest rational number within epsilon of x. A rational
+number n%d in reduced form is said to be simpler than another n'%d' if
+abs n <= abs n' && d <= d'. Any real interval contains a unique
+simplest rational; here, for simplicity, we assume a closed rational
+interval. If such an interval includes at least one whole number, then
+the simplest rational is the absolutely least whole number. Otherwise,
+the bounds are of the form q%1 + r%d and q%1 + r'%d', where abs r < d
+and abs r' < d', and the simplest rational is q%1 + the reciprocal of
+the simplest rational between d'%r' and d%r.
+
+\begin{code}
+approxRational x eps = simplest (x-eps) (x+eps)
+ where simplest x y | y < x = simplest y x
+ | x == y = xr
+ | x > 0 = simplest' n d n' d'
+ | y < 0 = - simplest' (-n') d' (-n) d
+ | otherwise = 0 :% 1
+ where xr@(n:%d) = toRational x
+ (n':%d') = toRational y
+
+ simplest' n d n' d' -- assumes 0 < n%d < n'%d'
+ | r == 0 = q :% 1
+ | q /= q' = (q+1) :% 1
+ | otherwise = (q*n''+d'') :% n''
+ where (q,r) = quotRem n d
+ (q',r') = quotRem n' d'
+ (n'':%d'') = simplest' d' r' d r
+\end{code}
+
+
+\begin{code}
+instance (Integral a) => Ord (Ratio a) where
+ (x:%y) <= (x':%y') = x * y' <= x' * y
+ (x:%y) < (x':%y') = x * y' < x' * y
+
+instance (Integral a) => Num (Ratio a) where
+ (x:%y) + (x':%y') = reduce (x*y' + x'*y) (y*y')
+ (x:%y) * (x':%y') = reduce (x * x') (y * y')
+ negate (x:%y) = (-x) :% y
+ abs (x:%y) = abs x :% y
+ signum (x:%y) = signum x :% 1
+ fromInteger x = fromInteger x :% 1
+
+instance (Integral a) => Real (Ratio a) where
+ toRational (x:%y) = toInteger x :% toInteger y
+
+instance (Integral a) => Fractional (Ratio a) where
+ (x:%y) / (x':%y') = (x*y') % (y*x')
+ recip (x:%y) = if x < 0 then (-y) :% (-x) else y :% x
+ fromRational (x:%y) = fromInteger x :% fromInteger y
+
+instance (Integral a) => RealFrac (Ratio a) where
+ properFraction (x:%y) = (fromIntegral q, r:%y)
+ where (q,r) = quotRem x y
+
+instance (Integral a) => Enum (Ratio a) where
+ enumFrom = iterate ((+)1)
+ enumFromThen n m = iterate ((+)(m-n)) n
+ toEnum n = fromIntegral n :% 1
+ fromEnum = fromInteger . truncate
+
+ratio_prec :: Int
+ratio_prec = 7
+
+instance (Integral a) => Show (Ratio a) where
+ showsPrec p (x:%y) = showParen (p > ratio_prec)
+ (shows x . showString " % " . shows y)
+\end{code}
+
+{-
+[In response to a request by simonpj, 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.
+
+How's this?
+
+Joe
+-}
+
+\begin{code}
+{-# GENERATE_SPECS fromRational__ a{Double#,Double} #-}
+fromRational__ :: (RealFloat a) => Rational -> a
+fromRational__ x = x'
+ where x' = f e
+
+-- If the exponent of the nearest floating-point number to x
+-- is e, then the significand is the integer nearest xb^(-e),
+-- where b is the floating-point radix. We start with a good
+-- guess for e, and if it is correct, the exponent of the
+-- floating-point number we construct will again be e. If
+-- not, one more iteration is needed.
+
+ f e = if e' == e then y else f e'
+ where y = encodeFloat (round (x * (1 % b)^^e)) e
+ (_,e') = decodeFloat y
+ b = floatRadix x'
+
+-- We obtain a trial exponent by doing a floating-point
+-- division of x's numerator by its denominator. The
+-- result of this division may not itself be the ultimate
+-- result, because of an accumulation of three rounding
+-- errors.
+
+ (s,e) = decodeFloat (fromInteger (numerator x) `asTypeOf` x'
+ / fromInteger (denominator x))
+\end{code}
+
+
+%*********************************************************
+%* *
+\subsection{Showing numbers}
+%* *
+%*********************************************************
+
+\begin{code}
+showInteger n r
+ = case quotRem n 10 of { (n', d) ->
+ case (chr (ord_0 + fromIntegral d)) of { C# c# -> -- stricter than necessary
+ let
+ r' = C# c# : r
+ in
+ if n' == 0 then r' else showInteger n' r'
+ }}
+
+showSigned :: (Real a) => (a -> ShowS) -> Int -> a -> ShowS
+showSigned showPos p x = if x < 0 then showParen (p > 6)
+ (showChar '-' . showPos (-x))
+ else showPos x
+
+showSignedInteger :: Int -> Integer -> ShowS
+showSignedInteger p n r
+ = -- from HBC version; support code follows
+ if n < 0 && p > 6 then '(':jtos n++(')':r) else jtos n ++ r
+
+jtos :: Integer -> String
+jtos n
+ = if n < 0 then
+ '-' : jtos' (-n) []
+ else
+ jtos' n []
+
+jtos' :: Integer -> String -> String
+jtos' n cs
+ = if n < 10 then
+ chr (fromInteger (n + ord_0)) : cs
+ else
+ jtos' (n `quot` 10) (chr (fromInteger (n `rem` 10 + ord_0)) : cs)
+\end{code}
+
+The functions showFloat below uses rational arithmetic
+to insure correct conversion between the floating-point radix and
+decimal. It is often possible to use a higher-precision floating-
+point type to obtain the same results.
+
+\begin{code}
+{-# GENERATE_SPECS showFloat a{Double#,Double} #-}
+showFloat:: (RealFloat a) => a -> ShowS
+showFloat x =
+ if x == 0 then showString ("0." ++ take (m-1) zeros)
+ else if e >= m-1 || e < 0 then showSci else showFix
+ where
+ showFix = showString whole . showChar '.' . showString frac
+ where (whole,frac) = splitAt (e+1) (show sig)
+ showSci = showChar d . showChar '.' . showString frac
+ . showChar 'e' . shows e
+ where (d:frac) = show sig
+ (m, sig, e) = if b == 10 then (w, s, n+w-1)
+ else (m', sig', e' )
+ m' = ceiling
+ ((fromInt w * log (fromInteger b)) / log 10 :: Double)
+ + 1
+ (sig', e') = if sig1 >= 10^m' then (round (t/10), e1+1)
+ else if sig1 < 10^(m'-1) then (round (t*10), e1-1)
+ else (sig1, e1 )
+ sig1 = round t
+ t = s%1 * (b%1)^^n * 10^^(m'-e1-1)
+ e1 = floor (logBase 10 x)
+ (s, n) = decodeFloat x
+ b = floatRadix x
+ w = floatDigits x
+
+zeros = repeat '0'
+\end{code}
+
+@showRational@ converts a Rational to a string that looks like a
+floating point number, but without converting to any floating type
+(because of the possible overflow).
+
+From/by Lennart, 94/09/26
+
+\begin{code}
+showRational :: Int -> Rational -> String
+showRational n r =
+ if r == 0 then
+ "0.0"
+ else
+ let (r', e) = normalize r
+ in prR n r' e
+
+startExpExp = 4 :: Int
+
+-- make sure 1 <= r < 10
+normalize :: Rational -> (Rational, Int)
+normalize r = if r < 1 then
+ case norm startExpExp (1 / r) 0 of (r', e) -> (10 / r', -e-1)
+ else
+ norm startExpExp r 0
+ where norm :: Int -> Rational -> Int -> (Rational, Int)
+ -- Invariant: r*10^e == original r
+ norm 0 r e = (r, e)
+ norm ee r e =
+ let n = 10^ee
+ tn = 10^n
+ in if r >= tn then norm ee (r/tn) (e+n) else norm (ee-1) r e
+
+drop0 "" = ""
+drop0 (c:cs) = c : reverse (dropWhile (=='0') (reverse cs))
+
+prR :: Int -> Rational -> Int -> String
+prR n r e | r < 1 = prR n (r*10) (e-1) -- final adjustment
+prR n r e | r >= 10 = prR n (r/10) (e+1)
+prR n r e0 =
+ let s = show ((round (r * 10^n))::Integer)
+ e = e0+1
+ in if e > 0 && e < 8 then
+ take e s ++ "." ++ drop0 (drop e s)
+ else if e <= 0 && e > -3 then
+ "0." ++ take (-e) (repeat '0') ++ drop0 s
+ else
+ head s : "."++ drop0 (tail s) ++ "e" ++ show e0
+\end{code}
+
+%*********************************************************
+%* *
+\subsection{Numeric primops}
+%* *
+%*********************************************************
+
+Definitions of the boxed PrimOps; these will be
+used in the case of partial applications, etc.
+
+\begin{code}
+plusFloat (F# x) (F# y) = F# (plusFloat# x y)
+minusFloat (F# x) (F# y) = F# (minusFloat# x y)
+timesFloat (F# x) (F# y) = F# (timesFloat# x y)
+divideFloat (F# x) (F# y) = F# (divideFloat# x y)
+negateFloat (F# x) = F# (negateFloat# x)
+
+gtFloat (F# x) (F# y) = gtFloat# x y
+geFloat (F# x) (F# y) = geFloat# x y
+eqFloat (F# x) (F# y) = eqFloat# x y
+neFloat (F# x) (F# y) = neFloat# x y
+ltFloat (F# x) (F# y) = ltFloat# x y
+leFloat (F# x) (F# y) = leFloat# x y
+
+float2Int (F# x) = I# (float2Int# x)
+int2Float (I# x) = F# (int2Float# x)
+
+expFloat (F# x) = F# (expFloat# x)
+logFloat (F# x) = F# (logFloat# x)
+sqrtFloat (F# x) = F# (sqrtFloat# x)
+sinFloat (F# x) = F# (sinFloat# x)
+cosFloat (F# x) = F# (cosFloat# x)
+tanFloat (F# x) = F# (tanFloat# x)
+asinFloat (F# x) = F# (asinFloat# x)
+acosFloat (F# x) = F# (acosFloat# x)
+atanFloat (F# x) = F# (atanFloat# x)
+sinhFloat (F# x) = F# (sinhFloat# x)
+coshFloat (F# x) = F# (coshFloat# x)
+tanhFloat (F# x) = F# (tanhFloat# x)
+
+powerFloat (F# x) (F# y) = F# (powerFloat# x y)
+
+-- definitions of the boxed PrimOps; these will be
+-- used in the case of partial applications, etc.
+
+plusDouble (D# x) (D# y) = D# (x +## y)
+minusDouble (D# x) (D# y) = D# (x -## y)
+timesDouble (D# x) (D# y) = D# (x *## y)
+divideDouble (D# x) (D# y) = D# (x /## y)
+negateDouble (D# x) = D# (negateDouble# x)
+
+gtDouble (D# x) (D# y) = x >## y
+geDouble (D# x) (D# y) = x >=## y
+eqDouble (D# x) (D# y) = x ==## y
+neDouble (D# x) (D# y) = x /=## y
+ltDouble (D# x) (D# y) = x <## y
+leDouble (D# x) (D# y) = x <=## y
+
+double2Int (D# x) = I# (double2Int# x)
+int2Double (I# x) = D# (int2Double# x)
+double2Float (D# x) = F# (double2Float# x)
+float2Double (F# x) = D# (float2Double# x)
+
+expDouble (D# x) = D# (expDouble# x)
+logDouble (D# x) = D# (logDouble# x)
+sqrtDouble (D# x) = D# (sqrtDouble# x)
+sinDouble (D# x) = D# (sinDouble# x)
+cosDouble (D# x) = D# (cosDouble# x)
+tanDouble (D# x) = D# (tanDouble# x)
+asinDouble (D# x) = D# (asinDouble# x)
+acosDouble (D# x) = D# (acosDouble# x)
+atanDouble (D# x) = D# (atanDouble# x)
+sinhDouble (D# x) = D# (sinhDouble# x)
+coshDouble (D# x) = D# (coshDouble# x)
+tanhDouble (D# x) = D# (tanhDouble# x)
+
+powerDouble (D# x) (D# y) = D# (x **## y)
+\end{code}
--- /dev/null
+%
+% (c) The AQUA Project, Glasgow University, 1994-1996
+%
+
+\section[PrelRead]{Module @Prelread@}
+
+The @Read@ class and many of its instances.
+
+\begin{code}
+module PrelRead where
+
+import Prelude ()
+import IOBase ( error ) {-# SOURCE #-}
+import PrelNum
+import PrelList
+import PrelTup
+import PrelBase
+\end{code}
+
+%*********************************************************
+%* *
+\subsection{The @Read@ class}
+%* *
+%*********************************************************
+
+\begin{code}
+type ReadS a = String -> [(a,String)]
+
+class Read a where
+ readsPrec :: Int -> ReadS a
+
+ readList :: ReadS [a]
+ readList = readList__ reads
+\end{code}
+
+%*********************************************************
+%* *
+\subsection{Instances of @Read@}
+%* *
+%*********************************************************
+
+\begin{code}
+instance Read Char where
+ readsPrec p = readParen False
+ (\r -> [(c,t) | ('\'':s,t)<- lex r,
+ (c,_) <- readLitChar s])
+
+ readList = readParen False (\r -> [(l,t) | ('"':s, t) <- lex r,
+ (l,_) <- readl s ])
+ where readl ('"':s) = [("",s)]
+ readl ('\\':'&':s) = readl s
+ readl s = [(c:cs,u) | (c ,t) <- readLitChar s,
+ (cs,u) <- readl t ]
+
+instance Read Bool where
+ readsPrec p = readParen False
+ (\r -> let lr = lex r
+ in
+ [(True, rest) | ("True", rest) <- lr] ++
+ [(False,rest) | ("False",rest) <- lr])
+
+
+instance Read Ordering where
+ readsPrec p = readParen False
+ (\r -> let lr = lex r
+ in
+ [(LT, rest) | ("LT", rest) <- lr] ++
+ [(EQ, rest) | ("EQ", rest) <- lr] ++
+ [(GT, rest) | ("GT", rest) <- lr])
+
+instance Read a => Read (Maybe a) where
+ readsPrec p = readParen False
+ (\r -> let lr = lex r
+ in
+ [(Nothing, rest) | ("Nothing", rest) <- lr] ++
+ [(Just x, rest2) | ("Just", rest1) <- lr,
+ (x, rest2) <- reads rest1])
+
+instance (Read a, Read b) => Read (Either a b) where
+ readsPrec p = readParen False
+ (\r -> let lr = lex r
+ in
+ [(Left x, rest2) | ("Left", rest1) <- lr,
+ (x, rest2) <- reads rest1] ++
+ [(Right x, rest2) | ("Right", rest1) <- lr,
+ (x, rest2) <- reads rest1])
+
+instance Read Int where
+ readsPrec p x = readSigned readDec x
+
+instance Read Integer where
+ readsPrec p x = readSigned readDec x
+
+instance Read Float where
+ readsPrec p x = readSigned readFloat x
+
+instance Read Double where
+ readsPrec p x = readSigned readFloat x
+
+instance (Integral a, Read a) => Read (Ratio a) where
+ readsPrec p = readParen (p > ratio_prec)
+ (\r -> [(x%y,u) | (x,s) <- reads r,
+ ("%",t) <- lex s,
+ (y,u) <- reads t ])
+
+instance (Read a) => Read [a] where
+ readsPrec p = readList
+
+instance Read () where
+ readsPrec p = readParen False
+ (\r -> [((),t) | ("(",s) <- lex r,
+ (")",t) <- lex s ] )
+
+instance (Read a, Read b) => Read (a,b) where
+ readsPrec p = readParen False
+ (\r -> [((x,y), w) | ("(",s) <- lex r,
+ (x,t) <- reads s,
+ (",",u) <- lex t,
+ (y,v) <- reads u,
+ (")",w) <- lex v ] )
+
+instance (Read a, Read b, Read c) => Read (a, b, c) where
+ readsPrec p = readParen False
+ (\a -> [((x,y,z), h) | ("(",b) <- lex a,
+ (x,c) <- readsPrec 0 b,
+ (",",d) <- lex c,
+ (y,e) <- readsPrec 0 d,
+ (",",f) <- lex e,
+ (z,g) <- readsPrec 0 f,
+ (")",h) <- lex g ] )
+
+instance (Read a, Read b, Read c, Read d) => Read (a, b, c, d) where
+ readsPrec p = readParen False
+ (\a -> [((w,x,y,z), j) | ("(",b) <- lex a,
+ (w,c) <- readsPrec 0 b,
+ (",",d) <- lex c,
+ (x,e) <- readsPrec 0 d,
+ (",",f) <- lex e,
+ (y,g) <- readsPrec 0 f,
+ (",",h) <- lex g,
+ (z,i) <- readsPrec 0 h,
+ (")",j) <- lex i ] )
+
+instance (Read a, Read b, Read c, Read d, Read e) => Read (a, b, c, d, e) where
+ readsPrec p = readParen False
+ (\a -> [((w,x,y,z,v), l) | ("(",b) <- lex a,
+ (w,c) <- readsPrec 0 b,
+ (",",d) <- lex c,
+ (x,e) <- readsPrec 0 d,
+ (",",f) <- lex e,
+ (y,g) <- readsPrec 0 f,
+ (",",h) <- lex g,
+ (z,i) <- readsPrec 0 h,
+ (",",j) <- lex i,
+ (v,k) <- readsPrec 0 j,
+ (")",l) <- lex k ] )
+\end{code}
+
+
+
+%*********************************************************
+%* *
+\subsection{Utility functions}
+%* *
+%*********************************************************
+
+\begin{code}
+reads :: (Read a) => ReadS a
+reads = readsPrec 0
+
+read :: (Read a) => String -> a
+read s = case [x | (x,t) <- reads s, ("","") <- lex t] of
+ [x] -> x
+ [] -> error "PreludeText.read: no parse"
+ _ -> error "PreludeText.read: ambiguous parse"
+
+readParen :: Bool -> ReadS a -> ReadS a
+readParen b g = if b then mandatory else optional
+ where optional r = g r ++ mandatory r
+ mandatory r = [(x,u) | ("(",s) <- lex r,
+ (x,t) <- optional s,
+ (")",u) <- lex t ]
+
+{-# GENERATE_SPECS readList__ a #-}
+readList__ :: ReadS a -> ReadS [a]
+
+readList__ readx
+ = readParen False (\r -> [pr | ("[",s) <- lex r, pr <- readl s])
+ where readl s = [([],t) | ("]",t) <- lex s] ++
+ [(x:xs,u) | (x,t) <- readx s,
+ (xs,u) <- readl2 t]
+ readl2 s = [([],t) | ("]",t) <- lex s] ++
+ [(x:xs,v) | (",",t) <- lex s,
+ (x,u) <- readx t,
+ (xs,v) <- readl2 u]
+\end{code}
+
+
+
+%*********************************************************
+%* *
+\subsection{Reading characters}
+%* *
+%*********************************************************
+
+\begin{code}
+readLitChar :: ReadS Char
+
+readLitChar ('\\':s) = readEsc s
+ where
+ readEsc ('a':s) = [('\a',s)]
+ readEsc ('b':s) = [('\b',s)]
+ readEsc ('f':s) = [('\f',s)]
+ readEsc ('n':s) = [('\n',s)]
+ readEsc ('r':s) = [('\r',s)]
+ readEsc ('t':s) = [('\t',s)]
+ readEsc ('v':s) = [('\v',s)]
+ readEsc ('\\':s) = [('\\',s)]
+ readEsc ('"':s) = [('"',s)]
+ readEsc ('\'':s) = [('\'',s)]
+ readEsc ('^':c:s) | c >= '@' && c <= '_'
+ = [(chr (ord c - ord '@'), s)]
+ readEsc s@(d:_) | isDigit d
+ = [(chr n, t) | (n,t) <- readDec s]
+ readEsc ('o':s) = [(chr n, t) | (n,t) <- readOct s]
+ readEsc ('x':s) = [(chr n, t) | (n,t) <- readHex s]
+ readEsc s@(c:_) | isUpper c
+ = let table = ('\DEL', "DEL") : zip ['\NUL'..] asciiTab
+ in case [(c,s') | (c, mne) <- table,
+ ([],s') <- [match mne s]]
+ of (pr:_) -> [pr]
+ [] -> []
+ readEsc _ = []
+readLitChar (c:s) = [(c,s)]
+
+match :: (Eq a) => [a] -> [a] -> ([a],[a])
+match (x:xs) (y:ys) | x == y = match xs ys
+match xs ys = (xs,ys)
+
+\end{code}
+
+
+%*********************************************************
+%* *
+\subsection{Reading numbers}
+%* *
+%*********************************************************
+
+\begin{code}
+{-# GENERATE_SPECS readDec a{Int#,Int,Integer} #-}
+readDec :: (Integral a) => ReadS a
+readDec = readInt 10 isDigit (\d -> ord d - ord_0)
+
+{-# GENERATE_SPECS readOct a{Int#,Int,Integer} #-}
+readOct :: (Integral a) => ReadS a
+readOct = readInt 8 isOctDigit (\d -> ord d - ord_0)
+
+{-# GENERATE_SPECS readHex a{Int#,Int,Integer} #-}
+readHex :: (Integral a) => ReadS a
+readHex = readInt 16 isHexDigit hex
+ where hex d = ord d - (if isDigit d then ord_0
+ else ord (if isUpper d then 'A' else 'a') - 10)
+
+{-# GENERATE_SPECS readInt a{Int#,Int,Integer} #-}
+readInt :: (Integral a) => a -> (Char -> Bool) -> (Char -> Int) -> ReadS a
+readInt radix isDig digToInt s =
+ [(foldl1 (\n d -> n * radix + d) (map (fromInt . digToInt) ds), r)
+ | (ds,r) <- nonnull isDig s ]
+
+{-# GENERATE_SPECS readSigned a{Int#,Double#,Int,Integer,Double} #-}
+readSigned :: (Real a) => ReadS a -> ReadS a
+readSigned readPos = readParen False read'
+ where read' r = read'' r ++
+ [(-x,t) | ("-",s) <- lex r,
+ (x,t) <- read'' s]
+ read'' r = [(n,s) | (str,s) <- lex r,
+ (n,"") <- readPos str]
+\end{code}
+
+The functions readFloat below uses rational arithmetic
+to insure correct conversion between the floating-point radix and
+decimal. It is often possible to use a higher-precision floating-
+point type to obtain the same results.
+
+\begin{code}
+{-# GENERATE_SPECS readFloat a{Double#,Double} #-}
+readFloat :: (RealFloat a) => ReadS a
+readFloat r = [(fromRational x, t) | (x, t) <- readRational r]
+
+readRational :: ReadS Rational -- NB: doesn't handle leading "-"
+
+readRational r
+ = [ ( (n%1)*10^^(k-d), t ) | (n,d,s) <- readFix r,
+ (k,t) <- readExp s]
+ where readFix r = [(read (ds++ds'), length ds', t)
+ | (ds,'.':s) <- lexDigits r,
+ (ds',t) <- lexDigits s ]
+
+ readExp (e:s) | e `elem` "eE" = readExp' s
+ readExp s = [(0,s)]
+
+ readExp' ('-':s) = [(-k,t) | (k,t) <- readDec s]
+ readExp' ('+':s) = readDec s
+ readExp' s = readDec s
+
+readRational__ :: String -> Rational -- we export this one (non-std)
+ -- NB: *does* handle a leading "-"
+readRational__ top_s
+ = case top_s of
+ '-' : xs -> - (read_me xs)
+ xs -> read_me xs
+ where
+ read_me s
+ = case [x | (x,t) <- readRational s, ("","") <- lex t] of
+ [x] -> x
+ [] -> error ("readRational__: no parse:" ++ top_s)
+ _ -> error ("readRational__: ambiguous parse:" ++ top_s)
+
+-- The number of decimal digits m below is chosen to guarantee
+-- read (show x) == x. See
+-- Matula, D. W. A formalization of floating-point numeric base
+-- conversion. IEEE Transactions on Computers C-19, 8 (1970 August),
+-- 681-692.
+\end{code}
+
+
+%*********************************************************
+%* *
+\subsection{Lexical analysis}
+%* *
+%*********************************************************
+
+This lexer is not completely faithful to the Haskell lexical syntax.
+Current limitations:
+ Qualified names are not handled properly
+ A `--' does not terminate a symbol
+ Octal and hexidecimal numerics are not recognized as a single token
+
+\begin{code}
+lex :: ReadS String
+
+lex "" = [("","")]
+lex (c:s) | isSpace c = lex (dropWhile isSpace s)
+lex ('\'':s) = [('\'':ch++"'", t) | (ch,'\'':t) <- lexLitChar s,
+ ch /= "'" ]
+lex ('"':s) = [('"':str, t) | (str,t) <- lexString s]
+ where
+ lexString ('"':s) = [("\"",s)]
+ lexString s = [(ch++str, u)
+ | (ch,t) <- lexStrItem s,
+ (str,u) <- lexString t ]
+
+ lexStrItem ('\\':'&':s) = [("\\&",s)]
+ lexStrItem ('\\':c:s) | isSpace c
+ = [("\\&",t) | '\\':t <- [dropWhile isSpace s]]
+ lexStrItem s = lexLitChar s
+
+lex (c:s) | isSingle c = [([c],s)]
+ | isSym c = [(c:sym,t) | (sym,t) <- [span isSym s]]
+ | isAlpha c = [(c:nam,t) | (nam,t) <- [span isIdChar s]]
+ | isDigit c = [(c:ds++fe,t) | (ds,s) <- [span isDigit s],
+ (fe,t) <- lexFracExp s ]
+ | otherwise = [] -- bad character
+ where
+ isSingle c = c `elem` ",;()[]{}_`"
+ 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)]
+
+ lexExp (e:s) | e `elem` "eE"
+ = [(e:c:ds,u) | (c:t) <- [s], c `elem` "+-",
+ (ds,u) <- lexDigits t] ++
+ [(e:ds,t) | (ds,t) <- lexDigits s]
+ lexExp s = [("",s)]
+
+lexDigits :: ReadS String
+lexDigits = nonnull isDigit
+
+nonnull :: (Char -> Bool) -> ReadS String
+nonnull p s = [(cs,t) | (cs@(_:_),t) <- [span p s]]
+
+lexLitChar :: ReadS String
+lexLitChar ('\\':s) = [('\\':esc, t) | (esc,t) <- lexEsc s]
+ where
+ lexEsc (c:s) | c `elem` "abfnrtv\\\"'" = [([c],s)]
+ lexEsc s@(d:_) | isDigit d = lexDigits s
+ lexEsc _ = []
+lexLitChar (c:s) = [([c],s)]
+lexLitChar "" = []
+\end{code}
+
+
--- /dev/null
+%
+% (c) The AQUA Project, Glasgow University, 1994-1996
+%
+
+\section[PrelTup]{Module @PrelTup@}
+
+This modules defines the typle data types.
+
+\begin{code}
+module PrelTup where
+
+import Prelude ()
+import IOBase ( error )
+import PrelBase
+\end{code}
+
+
+%*********************************************************
+%* *
+\subsection{Other tuple types}
+%* *
+%*********************************************************
+
+\begin{code}
+data (,) a b = (,) a b deriving (Eq, Ord, Bounded)
+data (,,) a b c = (,,) a b c deriving (Eq, Ord, Bounded)
+data (,,,) a b c d = (,,,) a b c d deriving (Eq, Ord, Bounded)
+data (,,,,) a b c d e = (,,,,) a b c d e deriving (Eq, Ord, Bounded)
+data (,,,,,) a b c d e f = (,,,,,) a b c d e f
+data (,,,,,,) a b c d e f g = (,,,,,,) a b c d e f g
+data (,,,,,,,) a b c d e f g h = (,,,,,,,) a b c d e f g h
+data (,,,,,,,,) a b c d e f g h i = (,,,,,,,,) a b c d e f g h i
+data (,,,,,,,,,) a b c d e f g h i j = (,,,,,,,,,) a b c d e f g h i j
+data (,,,,,,,,,,) a b c d e f g h i j k = (,,,,,,,,,,) a b c d e f g h i j k
+data (,,,,,,,,,,,) a b c d e f g h i j k l = (,,,,,,,,,,,) a b c d e f g h i j k l
+data (,,,,,,,,,,,,) a b c d e f g h i j k l m = (,,,,,,,,,,,,) a b c d e f g h i j k l m
+data (,,,,,,,,,,,,,) a b c d e f g h i j k l m n = (,,,,,,,,,,,,,) a b c d e f g h i j k l m n
+data (,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o = (,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o
+data (,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p = (,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p
+data (,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q
+ = (,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q
+data (,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r
+ = (,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r
+data (,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s
+ = (,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s
+data (,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t
+ = (,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t
+data (,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u
+ = (,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u
+data (,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v
+ = (,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v
+data (,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w
+ = (,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w
+data (,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x
+ = (,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x
+data (,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y
+ = (,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y
+data (,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z
+ = (,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z
+data (,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_
+ = (,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_
+data (,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_
+ = (,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_
+data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_
+ = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_
+data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_
+ = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_
+data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_
+ = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_
+data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_
+ = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_
+data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_
+ = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_
+data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_
+ = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_
+data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_
+ = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_
+data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_
+ = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_
+data (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_
+ = (,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,) a b c d e f g h i j k l m n o p q r s t u v w x y z a_ b_ c_ d_ e_ f_ g_ h_ i_ j_ k_
+ -- if you add more tuples, you need to change the compiler, too
+ -- (it has a wired-in number: 37)
+\end{code}
+
+@Show@ instances for just the first few.
+
+\begin{code}
+instance (Show a, Show b) => Show (a,b) where
+ showsPrec p (x,y) = showChar '(' . shows x . showString ", " .
+ shows y . showChar ')'
+ showList = showList__ (showsPrec 0)
+
+instance (Show a, Show b, Show c) => Show (a, b, c) where
+ showsPrec p (x,y,z) = showChar '(' . showsPrec 0 x . showString ", " .
+ showsPrec 0 y . showString ", " .
+ showsPrec 0 z . showChar ')'
+ showList = showList__ (showsPrec 0)
+
+instance (Show a, Show b, Show c, Show d) => Show (a, b, c, d) where
+ showsPrec p (w,x,y,z) = showChar '(' . showsPrec 0 w . showString ", " .
+ showsPrec 0 x . showString ", " .
+ showsPrec 0 y . showString ", " .
+ showsPrec 0 z . showChar ')'
+
+ showList = showList__ (showsPrec 0)
+
+instance (Show a, Show b, Show c, Show d, Show e) => Show (a, b, c, d, e) where
+ showsPrec p (v,w,x,y,z) = showChar '(' . showsPrec 0 v . showString ", " .
+ showsPrec 0 w . showString ", " .
+ showsPrec 0 x . showString ", " .
+ showsPrec 0 y . showString ", " .
+ showsPrec 0 z . showChar ')'
+ showList = showList__ (showsPrec 0)
+\end{code}
+
+
+%*********************************************************
+%* *
+\subsection{Standard functions over tuples}
+* *
+%*********************************************************
+
+\begin{code}
+fst :: (a,b) -> a
+fst (x,y) = x
+
+snd :: (a,b) -> b
+snd (x,y) = y
+
+-- curry converts an uncurried function to a curried function;
+-- uncurry converts a curried function to a function on pairs.
+curry :: ((a, b) -> c) -> a -> b -> c
+curry f x y = f (x, y)
+
+uncurry :: (a -> b -> c) -> ((a, b) -> c)
+uncurry f p = f (fst p) (snd p)
+\end{code}
+
--- /dev/null
+%
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
+%
+\section[STBase]{The @ST@ and @PrimIO@ monads}
+
+\begin{code}
+module STBase where
+
+import Prelude ()
+import Monad
+import PrelBase
+import GHC
+\end{code}
+
+%*********************************************************
+%* *
+\subsection{The @ST@ monad}
+%* *
+%*********************************************************
+
+The state-transformer monad proper. By default the monad is strict;
+too many people got bitten by space leaks when it was lazy.
+
+\begin{code}
+data State a = S# (State# a)
+newtype ST s a = ST (State s -> (a, State s))
+
+runST (ST m)
+ = case m (S# realWorld#) of
+ (r,_) -> r
+
+instance Monad (ST s) where
+ {-# INLINE return #-}
+ {-# INLINE (>>) #-}
+ {-# INLINE (>>=) #-}
+ return x = ST $ \ s@(S# _) -> (x, s)
+ m >> k = m >>= \ _ -> k
+
+ (ST m) >>= k
+ = ST $ \ s ->
+ case (m s) of {(r, new_s) ->
+ case (k r) of { ST k2 ->
+ (k2 new_s) }}
+
+{-# INLINE returnST #-}
+
+-- here for backward compatibility:
+returnST :: a -> ST s a
+thenST :: ST s a -> (a -> ST s b) -> ST s b
+seqST :: ST s a -> ST s b -> ST s b
+
+returnST = return
+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
+ (r, new_s) = m s
+ in
+ (r, s)
+
+fixST :: (a -> ST s a) -> ST s a
+fixST k = ST $ \ s ->
+ let (ST k_r) = k r
+ ans = k_r s
+ (r,new_s) = ans
+ in
+ ans
+
+-- more backward compatibility stuff:
+listST :: [ST s a] -> ST s [a]
+mapST :: (a -> ST s b) -> [a] -> ST s [b]
+mapAndUnzipST :: (a -> ST s (b,c)) -> [a] -> ST s ([b],[c])
+
+listST = accumulate
+mapST = mapM
+mapAndUnzipST = mapAndUnzipM
+
+\end{code}
+
+
+%*********************************************************
+%* *
+\subsection{The @PrimIO@ monad}
+%* *
+%*********************************************************
+
+\begin{code}
+type PrimIO a = ST RealWorld a
+
+fixPrimIO :: (a -> PrimIO a) -> PrimIO a
+fixPrimIO = fixST
+
+{-# GENERATE_SPECS unsafePerformPrimIO a #-}
+unsafePerformPrimIO :: PrimIO a -> a
+unsafeInterleavePrimIO :: PrimIO a -> PrimIO a
+
+unsafePerformPrimIO = runST
+unsafeInterleavePrimIO = unsafeInterleaveST
+
+-- the following functions are now there for backward compatibility mostly:
+
+{-# 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
+
+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 = return
+thenPrimIO = (>>=)
+seqPrimIO = (>>)
+listPrimIO = accumulate
+mapPrimIO = mapM
+mapAndUnzipPrimIO = mapAndUnzipM
+\end{code}
+
+
+%*********************************************************
+%* *
+\subsection{Ghastly return types}
+%* *
+%*********************************************************
+
+\begin{code}
+data StateAndPtr# s elt = StateAndPtr# (State# s) elt
+
+data StateAndChar# s = StateAndChar# (State# s) Char#
+data StateAndInt# s = StateAndInt# (State# s) Int#
+data StateAndWord# s = StateAndWord# (State# s) Word#
+data StateAndFloat# s = StateAndFloat# (State# s) Float#
+data StateAndDouble# s = StateAndDouble# (State# s) Double#
+data StateAndAddr# s = StateAndAddr# (State# s) Addr#
+\end{code}
--- /dev/null
+%
+% (c) The AQUA Project, Glasgow University, 1994-1996
+%
+
+\section[Foreign]{Module @Foreign@}
+
+\begin{code}
+module Foreign (
+ module Foreign,
+ Addr, Word
+ ) where
+
+import Prelude ()
+import STBase
+import ArrBase
+import PrelBase
+import GHC
+\end{code}
+
+
+%*********************************************************
+%* *
+\subsection{Classes @CCallable@ and @CReturnable@}
+%* *
+%*********************************************************
+
+\begin{code}
+class CCallable a
+class CReturnable a
+
+instance CCallable Char
+instance CReturnable Char
+
+instance CCallable Int
+instance CReturnable Int
+
+-- DsCCall knows how to pass strings...
+instance CCallable [Char]
+
+instance CCallable Float
+instance CReturnable Float
+
+instance CCallable Double
+instance CReturnable Double
+
+instance CCallable Addr
+instance CReturnable Addr
+
+instance CCallable Word
+instance CReturnable Word
+
+-- Is this right?
+instance CCallable (MutableByteArray s ix)
+
+instance CCallable (ByteArray ix)
+
+instance CReturnable () -- Why, exactly?
+\end{code}
+
+
+%*********************************************************
+%* *
+\subsection{Type @ForeignObj@ and its operations}
+%* *
+%*********************************************************
+
+\begin{code}
+data ForeignObj = ForeignObj ForeignObj#
+instance CCallable ForeignObj
+
+eqForeignObj :: ForeignObj -> ForeignObj -> Bool
+makeForeignObj :: Addr -> Addr -> PrimIO ForeignObj
+
+makeForeignObj (A# obj) (A# finaliser) = ST $ \ (S# s#) ->
+ case makeForeignObj# obj finaliser s# of
+ StateAndForeignObj# s1# fo# -> (ForeignObj fo#, S# s1#)
+
+eqForeignObj mp1 mp2
+ = unsafePerformPrimIO (_ccall_ eqForeignObj mp1 mp2) /= (0::Int)
+
+instance Eq ForeignObj where
+ p == q = eqForeignObj p q
+ p /= q = not (eqForeignObj p q)
+\end{code}
+
+
+%*********************************************************
+%* *
+\subsection{Type @StablePtr@ and its operations}
+%* *
+%*********************************************************
+
+\begin{code}
+#ifndef __PARALLEL_HASKELL__
+data StablePtr a = StablePtr (StablePtr# a)
+instance CCallable (StablePtr a)
+instance CReturnable (StablePtr a)
+
+-- 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.
+
+makeStablePtr :: a -> PrimIO (StablePtr a)
+deRefStablePtr :: StablePtr a -> PrimIO a
+freeStablePtr :: StablePtr a -> PrimIO ()
+performGC :: PrimIO ()
+
+{-# INLINE deRefStablePtr #-}
+{-# INLINE freeStablePtr #-}
+{-# INLINE performGC #-}
+
+makeStablePtr f = ST $ \ (S# rw1#) ->
+ case makeStablePtr# f rw1# of
+ StateAndStablePtr# rw2# sp# -> (StablePtr sp#, S# rw2#)
+
+deRefStablePtr (StablePtr sp#) = ST $ \ (S# rw1#) ->
+ case deRefStablePtr# sp# rw1# of
+ StateAndPtr# rw2# a -> (a, S# rw2#)
+
+freeStablePtr sp = _ccall_ freeStablePointer sp
+
+performGC = _ccall_GC_ StgPerformGarbageCollection
+
+#endif /* !__PARALLEL_HASKELL__ */
+\end{code}
+
+%*********************************************************
+%* *
+\subsection{Ghastly return types}
+%* *
+%*********************************************************
+
+\begin{code}
+#ifndef __PARALLEL_HASKELL__
+data StateAndStablePtr# s a = StateAndStablePtr# (State# s) (StablePtr# a)
+#endif
+data StateAndForeignObj# s = StateAndForeignObj# (State# s) ForeignObj#
+\end{code}
--- /dev/null
+%
+% (c) The GRASP/AQUA Project, Glasgow University, 1993-1996
+%
+\section{Packed strings}
+
+This sits on top of the sequencing/arrays world, notably @ByteArray#@s.
+
+Glorious hacking (all the hard work) by Bryan O'Sullivan.
+
+\begin{code}
+module PackedString (
+
+ packString, -- :: [Char] -> PackedString
+ packStringST, -- :: [Char] -> ST s PackedString
+ nilPS, -- :: PackedString
+ consPS, -- :: Char -> PackedString -> PackedString
+
+ byteArrayToPS, -- :: ByteArray Int -> PackedString
+ unsafeByteArrayToPS, -- :: ByteArray a -> Int -> PackedString
+ psToByteArray, -- :: PackedString -> ByteArray Int
+
+ unpackPS, -- :: PackedString -> [Char]
+{-LATER:
+ hPutPS, -- :: Handle -> PackedString -> IO ()
+ putPS, -- :: FILE -> PackedString -> PrimIO () -- ToDo: more sensible type
+ getPS, -- :: FILE -> Int -> PrimIO PackedString
+-}
+ headPS, -- :: PackedString -> Char
+ tailPS, -- :: PackedString -> PackedString
+ nullPS, -- :: PackedString -> Bool
+ appendPS, -- :: PackedString -> PackedString -> PackedString
+ lengthPS, -- :: PackedString -> Int
+ {- 0-origin indexing into the string -}
+ 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, 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
+ splitPS, -- :: Char -> PackedString -> [PackedString]
+ splitWithPS, -- :: (Char -> Bool) -> PackedString -> [PackedString]
+ joinPS, -- :: PackedString -> [PackedString] -> PackedString
+ concatPS, -- :: [PackedString] -> PackedString
+ elemPS, -- :: Char -> PackedString -> Bool
+
+ {-
+ Pluck out a piece of a PS start and end
+ chars you want; both 0-origin-specified
+ -}
+ substrPS, -- :: PackedString -> Int -> Int -> PackedString
+
+ comparePS,
+
+ -- Converting to C strings
+ packCString#,
+ unpackCString#, unpackCString2#, unpackAppendCString#, unpackFoldrCString#,
+ packCBytesST, unpackCString
+ ) where
+
+import Prelude ()
+import IOBase ( error ) {-# SOURCE #-}
+import Ix
+import PrelList
+import STBase
+import ArrBase
+import PrelBase
+import GHC
+\end{code}
+
+%************************************************************************
+%* *
+\subsection{@PackedString@ type declaration}
+%* *
+%************************************************************************
+
+\begin{code}
+data PackedString
+ = PS ByteArray# -- the bytes
+ Int# -- length (*not* including NUL at the end)
+ Bool -- True <=> contains a NUL
+ | CPS Addr# -- pointer to the (null-terminated) bytes in C land
+ Int# -- length, as per strlen
+ -- definitely doesn't contain a NUL
+
+instance Eq PackedString where
+ x == y = compare x y == EQ
+ x /= y = compare x y /= EQ
+
+instance Ord PackedString where
+ compare = comparePS
+ x <= y = compare x y /= GT
+ x < y = compare x y == LT
+ x >= y = compare x y /= LT
+ x > y = compare x y == GT
+ max x y = case (compare x y) of { LT -> y ; EQ -> x ; GT -> x }
+ min x y = case (compare x y) of { LT -> x ; EQ -> x ; GT -> y }
+
+--instance Read PackedString: ToDo
+
+instance Show PackedString where
+ showsPrec p ps r = showsPrec p (unpackPS ps) r
+ showList = showList__ (showsPrec 0)
+\end{code}
+
+
+%************************************************************************
+%* *
+\subsection{@PackedString@ instances}
+%* *
+%************************************************************************
+
+We try hard to make this go fast:
+\begin{code}
+comparePS :: PackedString -> PackedString -> Ordering
+
+comparePS (PS bs1 len1 has_null1) (PS bs2 len2 has_null2)
+ | not has_null1 && not has_null2
+ = unsafePerformPrimIO (
+ _ccall_ strcmp ba1 ba2 >>= \ (I# res) ->
+ return (
+ if res <# 0# then LT
+ else if res ==# 0# then EQ
+ else GT
+ ))
+ where
+ ba1 = ByteArray (0, I# (len1 -# 1#)) bs1
+ ba2 = ByteArray (0, I# (len2 -# 1#)) bs2
+
+comparePS (PS bs1 len1 has_null1) (CPS bs2 len2)
+ | not has_null1
+ = unsafePerformPrimIO (
+ _ccall_ strcmp ba1 ba2 >>= \ (I# res) ->
+ return (
+ if res <# 0# then LT
+ else if res ==# 0# then EQ
+ else GT
+ ))
+ where
+ ba1 = ByteArray (0, I# (len1 -# 1#)) bs1
+ ba2 = A# bs2
+
+comparePS (CPS bs1 len1) (CPS bs2 len2)
+ = unsafePerformPrimIO (
+ _ccall_ strcmp ba1 ba2 >>= \ (I# res) ->
+ return (
+ if res <# 0# then LT
+ else if res ==# 0# then EQ
+ else GT
+ ))
+ where
+ ba1 = A# bs1
+ ba2 = A# bs2
+
+comparePS a@(CPS _ _) b@(PS _ _ has_null2)
+ | not has_null2
+ = -- try them the other way 'round
+ case (comparePS b a) of { LT -> GT; EQ -> EQ; GT -> LT }
+
+comparePS ps1 ps2 -- slow catch-all case (esp for "has_null" True)
+ = looking_at 0#
+ where
+ end1 = lengthPS# ps1 -# 1#
+ end2 = lengthPS# ps2 -# 1#
+
+ looking_at char#
+ = if char# ># end1 then
+ if char# ># end2 then -- both strings ran out at once
+ EQ
+ else -- ps1 ran out before ps2
+ LT
+ else if char# ># end2 then
+ GT -- ps2 ran out before ps1
+ else
+ let
+ ch1 = indexPS# ps1 char#
+ ch2 = indexPS# ps2 char#
+ in
+ if ch1 `eqChar#` ch2 then
+ looking_at (char# +# 1#)
+ else if ch1 `ltChar#` ch2 then LT
+ else GT
+\end{code}
+
+
+%************************************************************************
+%* *
+\subsection{Constructor functions}
+%* *
+%************************************************************************
+
+Easy ones first. @packString@ requires getting some heap-bytes and
+scribbling stuff into them.
+
+\begin{code}
+nilPS :: PackedString
+nilPS = CPS ""# 0#
+
+consPS :: Char -> PackedString -> PackedString
+consPS c cs = packString (c : (unpackPS cs)) -- ToDo:better
+
+packString :: [Char] -> PackedString
+packString str = runST (packStringST str)
+
+packStringST :: [Char] -> ST s PackedString
+packStringST str =
+ let len = length str in
+ packNCharsST len str
+
+packNCharsST :: Int -> [Char] -> ST s PackedString
+packNCharsST len@(I# length#) str =
+ {-
+ allocate an array that will hold the string
+ (not forgetting the NUL byte at the end)
+ -}
+ new_ps_array (length# +# 1#) >>= \ ch_array ->
+ -- fill in packed string from "str"
+ fill_in ch_array 0# str >>
+ -- freeze the puppy:
+ freeze_ps_array ch_array >>= \ (ByteArray _ frozen#) ->
+ let has_null = byteArrayHasNUL# frozen# length# in
+ return (PS frozen# length# has_null)
+ where
+ fill_in :: MutableByteArray s Int -> Int# -> [Char] -> ST s ()
+ fill_in arr_in# idx [] =
+ write_ps_array arr_in# idx (chr# 0#) >>
+ return ()
+
+ fill_in arr_in# idx (C# c : cs) =
+ write_ps_array arr_in# idx c >>
+ fill_in arr_in# (idx +# 1#) cs
+
+byteArrayToPS :: ByteArray Int -> PackedString
+byteArrayToPS (ByteArray ixs@(_, ix_end) frozen#) =
+ let
+ n# =
+ case (
+ if null (range ixs)
+ then 0
+ else ((index ixs ix_end) + 1)
+ ) of { I# x -> x }
+ in
+ PS frozen# n# (byteArrayHasNUL# frozen# n#)
+
+unsafeByteArrayToPS :: ByteArray a -> Int -> PackedString
+unsafeByteArrayToPS (ByteArray _ frozen#) (I# n#)
+ = PS frozen# n# (byteArrayHasNUL# frozen# n#)
+
+psToByteArray :: PackedString -> ByteArray Int
+psToByteArray (PS bytes n has_null)
+ = ByteArray (0, I# (n -# 1#)) bytes
+
+psToByteArray (CPS addr len#)
+ = let
+ len = I# len#
+ byte_array_form = packCBytes len (A# addr)
+ in
+ case byte_array_form of { PS bytes _ _ ->
+ ByteArray (0, len - 1) bytes }
+\end{code}
+
+%************************************************************************
+%* *
+\subsection{Destructor functions (taking @PackedStrings@ apart)}
+%* *
+%************************************************************************
+
+\begin{code}
+-- OK, but this code gets *hammered*:
+-- unpackPS ps
+-- = [ indexPS ps n | n <- [ 0::Int .. lengthPS ps - 1 ] ]
+
+unpackPS :: PackedString -> [Char]
+unpackPS (PS bytes len has_null)
+ = unpack 0#
+ where
+ unpack nh
+ | nh >=# len = []
+ | otherwise = C# ch : unpack (nh +# 1#)
+ where
+ ch = indexCharArray# bytes nh
+
+unpackPS (CPS addr len)
+ = unpack 0#
+ where
+ unpack nh
+ | ch `eqChar#` '\0'# = []
+ | otherwise = C# ch : unpack (nh +# 1#)
+ where
+ ch = indexCharOffAddr# addr nh
+\end{code}
+
+Output a packed string via a handle:
+
+\begin{code}
+{- LATER:
+hPutPS :: Handle -> PackedString -> IO ()
+hPutPS handle ps =
+ let
+ len =
+ case ps of
+ PS _ len _ -> len
+ CPS _ len -> len
+ in
+ if len ==# 0# then
+ return ()
+ else
+ _readHandle handle >>= \ htype ->
+ case htype of
+ _ErrorHandle ioError ->
+ _writeHandle handle htype >>
+ failWith ioError
+ _ClosedHandle ->
+ _writeHandle handle htype >>
+ failWith (IllegalOperation "handle is closed")
+ _SemiClosedHandle _ _ ->
+ _writeHandle handle htype >>
+ failWith (IllegalOperation "handle is closed")
+ _ReadHandle _ _ _ ->
+ _writeHandle handle htype >>
+ failWith (IllegalOperation "handle is not open for writing")
+ other ->
+ _getBufferMode other >>= \ other ->
+ (case _bufferMode other of
+ Just LineBuffering ->
+ writeLines (_filePtr other)
+ Just (BlockBuffering (Just size)) ->
+ writeBlocks (_filePtr other) size
+ Just (BlockBuffering Nothing) ->
+ writeBlocks (_filePtr other) ``BUFSIZ''
+ _ -> -- Nothing is treated pessimistically as NoBuffering
+ writeChars (_filePtr other) 0#
+ ) >>= \ success ->
+ _writeHandle handle (_markHandle other) >>
+ if success then
+ return ()
+ else
+ _constructError "hPutStr" >>= \ ioError ->
+ failWith ioError
+
+ where
+ pslen = lengthPS# ps
+
+ writeLines :: Addr -> PrimIO Bool
+ writeLines = writeChunks ``BUFSIZ'' True
+
+ writeBlocks :: Addr -> Int -> PrimIO Bool
+ writeBlocks fp size = writeChunks size False fp
+
+ {-
+ The breaking up of output into lines along \n boundaries
+ works fine as long as there are newlines to split by.
+ Avoid the splitting up into lines altogether (doesn't work
+ for overly long lines like the stuff that showsPrec instances
+ normally return). Instead, we split them up into fixed size
+ chunks before blasting them off to the Real World.
+
+ Hacked to avoid multiple passes over the strings - unsightly, but
+ a whole lot quicker. -- SOF 3/96
+ -}
+
+ writeChunks :: Int -> Bool -> Addr -> PrimIO Bool
+ writeChunks (I# bufLen) chopOnNewLine fp =
+ newCharArray (0,I# bufLen) >>= \ arr@(MutableByteArray _ arr#) ->
+ let
+ shoveString :: Int# -> Int# -> PrimIO Bool
+ shoveString n i
+ | i ==# pslen = -- end of string
+ if n ==# 0# then
+ return True
+ else
+ _ccall_ writeFile arr fp (I# n) >>= \rc ->
+ return (rc==0)
+ | otherwise =
+ (\ (S# s#) ->
+ case writeCharArray# arr# n (indexPS# ps i) s# of
+ s1# ->
+ {- Flushing lines - should we bother? -}
+ (if n ==# bufLen then
+ _ccall_ writeFile arr fp (I# (n +# 1#)) >>= \rc ->
+ if rc == 0 then
+ shoveString 0# (i +# 1#)
+ else
+ return False
+ else
+ shoveString (n +# 1#) (i +# 1#)) (S# s1#))
+ in
+ shoveString 0# 0#
+
+ writeChars :: Addr -> Int# -> PrimIO Bool
+ writeChars fp i
+ | i ==# pslen = return True
+ | otherwise =
+ _ccall_ filePutc fp (ord (C# (indexPS# ps i))) >>= \ rc ->
+ if rc == 0 then
+ writeChars fp (i +# 1#)
+ else
+ return False
+
+---------------------------------------------
+
+putPS :: _FILE -> PackedString -> PrimIO ()
+putPS file ps@(PS bytes len has_null)
+ | len ==# 0#
+ = return ()
+ | otherwise
+ = let
+ byte_array = ByteArray (0, I# (len -# 1#)) bytes
+ in
+ _ccall_ fwrite byte_array (1::Int){-size-} (I# len) file
+ >>= \ (I# written) ->
+ if written ==# len then
+ return ()
+ else
+ error "putPS: fwrite failed!\n"
+
+putPS file (CPS addr len)
+ | len ==# 0#
+ = return ()
+ | otherwise
+ = _ccall_ fputs (A# addr) file >>= \ (I# _){-force type-} ->
+ return ()
+\end{code}
+
+The dual to @_putPS@, note that the size of the chunk specified
+is the upper bound of the size of the chunk returned.
+
+\begin{code}
+getPS :: _FILE -> Int -> PrimIO PackedString
+getPS file len@(I# len#)
+ | len# <=# 0# = return nilPS -- I'm being kind here.
+ | otherwise =
+ -- Allocate an array for system call to store its bytes into.
+ new_ps_array len# >>= \ ch_arr ->
+ freeze_ps_array ch_arr >>= \ (ByteArray _ frozen#) ->
+ let
+ byte_array = ByteArray (0, I# len#) frozen#
+ in
+ _ccall_ fread byte_array (1::Int) len file >>= \ (I# read#) ->
+ if read# ==# 0# then -- EOF or other error
+ error "getPS: EOF reached or other error"
+ else
+ {-
+ The system call may not return the number of
+ bytes requested. Instead of failing with an error
+ if the number of bytes read is less than requested,
+ a packed string containing the bytes we did manage
+ to snarf is returned.
+ -}
+ let
+ has_null = byteArrayHasNUL# frozen# read#
+ in
+ return (PS frozen# read# has_null)
+END LATER -}
+\end{code}
+
+%************************************************************************
+%* *
+\subsection{List-mimicking functions for @PackedStrings@}
+%* *
+%************************************************************************
+
+First, the basic functions that do look into the representation;
+@indexPS@ is the most important one.
+
+\begin{code}
+lengthPS :: PackedString -> Int
+lengthPS ps = I# (lengthPS# ps)
+
+{-# INLINE lengthPS# #-}
+
+lengthPS# (PS _ i _) = i
+lengthPS# (CPS _ i) = i
+
+{-# INLINE strlen# #-}
+
+strlen# :: Addr# -> Int
+strlen# a
+ = unsafePerformPrimIO (
+ _ccall_ strlen (A# a) >>= \ len@(I# _) ->
+ return len
+ )
+
+byteArrayHasNUL# :: ByteArray# -> Int#{-length-} -> Bool
+byteArrayHasNUL# bs len
+ = unsafePerformPrimIO (
+ _ccall_ byteArrayHasNUL__ ba (I# len) >>= \ (I# res) ->
+ return (
+ if res ==# 0# then False else True
+ ))
+ where
+ ba = ByteArray (0, I# (len -# 1#)) bs
+
+-----------------------
+
+indexPS :: PackedString -> Int -> Char
+indexPS ps (I# n) = C# (indexPS# ps n)
+
+{-# INLINE indexPS# #-}
+
+indexPS# (PS bs i _) n
+ = --ASSERT (n >=# 0# && n <# i) -- error checking: my eye! (WDP 94/10)
+ indexCharArray# bs n
+
+indexPS# (CPS a _) n
+ = indexCharOffAddr# a n
+\end{code}
+
+Now, the rest of the functions can be defined without digging
+around in the representation.
+
+\begin{code}
+headPS :: PackedString -> Char
+headPS ps
+ | nullPS ps = error "headPS: head []"
+ | otherwise = C# (indexPS# ps 0#)
+
+tailPS :: PackedString -> PackedString
+tailPS ps
+ | len <=# 0# = error "tailPS: tail []"
+ | len ==# 1# = nilPS
+ | otherwise = substrPS# ps 1# (len -# 1#)
+ where
+ len = lengthPS# ps
+
+nullPS :: PackedString -> Bool
+nullPS (PS _ i _) = i ==# 0#
+nullPS (CPS _ i) = i ==# 0#
+
+{- (ToDo: some non-lousy implementations...)
+
+ Old : _appendPS xs ys = packString (unpackPS xs ++ unpackPS ys)
+
+-}
+appendPS :: PackedString -> PackedString -> PackedString
+appendPS xs ys
+ | nullPS xs = ys
+ | nullPS ys = xs
+ | otherwise = concatPS [xs,ys]
+
+{- OLD: mapPS f xs = packString (map f (unpackPS xs)) -}
+
+mapPS :: (Char -> Char) -> PackedString -> PackedString {-or String?-}
+mapPS f xs =
+ if nullPS xs then
+ xs
+ else
+ runST (
+ new_ps_array (length +# 1#) >>= \ ps_arr ->
+ whizz ps_arr length 0# >>
+ freeze_ps_array ps_arr >>= \ (ByteArray _ frozen#) ->
+ let has_null = byteArrayHasNUL# frozen# length in
+ return (PS frozen# length has_null))
+ where
+ length = lengthPS# xs
+
+ whizz :: MutableByteArray s Int -> Int# -> Int# -> ST s ()
+ whizz arr# n i
+ | n ==# 0#
+ = write_ps_array arr# i (chr# 0#) >>
+ return ()
+ | otherwise
+ = let
+ ch = indexPS# xs i
+ in
+ write_ps_array arr# i (case f (C# ch) of { (C# x) -> x}) >>
+ whizz arr# (n -# 1#) (i +# 1#)
+
+filterPS :: (Char -> Bool) -> PackedString -> PackedString {-or String?-}
+filterPS pred ps =
+ if nullPS ps then
+ ps
+ else
+ {-
+ Filtering proceeds as follows:
+
+ * traverse the list, applying the pred. to each element,
+ remembering the positions where it was satisfied.
+
+ Encode these positions using a run-length encoding of the gaps
+ between the matching positions.
+
+ * Allocate a MutableByteArray in the heap big enough to hold
+ all the matched entries, and copy the elements that matched over.
+
+ A better solution that merges the scan© passes into one,
+ would be to copy the filtered elements over into a growable
+ buffer. No such operation currently supported over
+ MutableByteArrays (could of course use malloc&realloc)
+ But, this solution may in the case of repeated realloc's
+ be worse than the current solution.
+ -}
+ runST (
+ let
+ (rle,len_filtered) = filter_ps len# 0# 0# []
+ len_filtered# = case len_filtered of { I# x# -> x#}
+ in
+ if len# ==# len_filtered# then
+ {- not much filtering as everything passed through. -}
+ return ps
+ else if len_filtered# ==# 0# then
+ return nilPS
+ else
+ new_ps_array (len_filtered# +# 1#) >>= \ ps_arr ->
+ copy_arr ps_arr rle 0# 0# >>
+ freeze_ps_array ps_arr >>= \ (ByteArray _ frozen#) ->
+ let has_null = byteArrayHasNUL# frozen# len_filtered# in
+ return (PS frozen# len_filtered# has_null))
+ where
+ len# = lengthPS# ps
+
+ matchOffset :: Int# -> [Char] -> (Int,[Char])
+ matchOffset off [] = (I# off,[])
+ matchOffset off (C# c:cs) =
+ let
+ x = ord# c
+ off' = off +# x
+ in
+ if x==# 0# then -- escape code, add 255#
+ matchOffset off' cs
+ else
+ (I# off', cs)
+
+ copy_arr :: MutableByteArray s Int -> [Char] -> Int# -> Int# -> ST s ()
+ copy_arr arr# [_] _ _ = return ()
+ copy_arr arr# ls n i =
+ let
+ (x,ls') = matchOffset 0# ls
+ n' = n +# (case x of { (I# x#) -> x#}) -# 1#
+ ch = indexPS# ps n'
+ in
+ write_ps_array arr# i ch >>
+ copy_arr arr# ls' (n' +# 1#) (i +# 1#)
+
+ esc :: Int# -> Int# -> [Char] -> [Char]
+ esc v 0# ls = (C# (chr# v)):ls
+ esc v n ls = esc v (n -# 1#) (C# (chr# 0#):ls)
+
+ filter_ps :: Int# -> Int# -> Int# -> [Char] -> ([Char],Int)
+ filter_ps n hits run acc
+ | n <# 0# =
+ let
+ escs = run `quotInt#` 255#
+ v = run `remInt#` 255#
+ in
+ (esc (v +# 1#) escs acc, I# hits)
+ | otherwise
+ = let
+ ch = indexPS# ps n
+ n' = n -# 1#
+ in
+ if pred (C# ch) then
+ let
+ escs = run `quotInt#` 255#
+ v = run `remInt#` 255#
+ acc' = esc (v +# 1#) escs acc
+ in
+ filter_ps n' (hits +# 1#) 0# acc'
+ else
+ filter_ps n' hits (run +# 1#) acc
+
+
+foldlPS :: (a -> Char -> a) -> a -> PackedString -> a
+foldlPS f b ps
+ = if nullPS ps then
+ b
+ else
+ whizzLR b 0#
+ where
+ len = lengthPS# ps
+
+ --whizzLR :: a -> Int# -> a
+ whizzLR b idx
+ | idx ==# len = b
+ | otherwise = whizzLR (f b (C# (indexPS# ps idx))) (idx +# 1#)
+
+
+foldrPS :: (Char -> a -> a) -> a -> PackedString -> a
+foldrPS f b ps
+ = if nullPS ps then
+ b
+ else
+ whizzRL b len
+ where
+ len = lengthPS# ps
+
+ --whizzRL :: a -> Int# -> a
+ whizzRL b idx
+ | idx <# 0# = b
+ | otherwise = whizzRL (f (C# (indexPS# ps idx)) b) (idx -# 1#)
+
+takePS :: Int -> PackedString -> PackedString
+takePS (I# n) ps
+ | n ==# 0# = nilPS
+ | otherwise = substrPS# ps 0# (n -# 1#)
+
+dropPS :: Int -> PackedString -> PackedString
+dropPS (I# n) ps
+ | n ==# len = ps
+ | otherwise = substrPS# ps n (lengthPS# ps -# 1#)
+ where
+ len = lengthPS# ps
+
+splitAtPS :: Int -> PackedString -> (PackedString, PackedString)
+splitAtPS n ps = (takePS n ps, dropPS n ps)
+
+takeWhilePS :: (Char -> Bool) -> PackedString -> PackedString
+takeWhilePS pred ps
+ = let
+ break_pt = char_pos_that_dissatisfies
+ (\ c -> pred (C# c))
+ ps
+ (lengthPS# ps)
+ 0#
+ in
+ if break_pt ==# 0# then
+ nilPS
+ else
+ substrPS# ps 0# (break_pt -# 1#)
+
+dropWhilePS :: (Char -> Bool) -> PackedString -> PackedString
+dropWhilePS pred ps
+ = let
+ len = lengthPS# ps
+ break_pt = char_pos_that_dissatisfies
+ (\ c -> pred (C# c))
+ ps
+ len
+ 0#
+ in
+ if len ==# break_pt then
+ nilPS
+ else
+ substrPS# ps break_pt (len -# 1#)
+
+elemPS :: Char -> PackedString -> Bool
+elemPS (C# ch) ps
+ = let
+ len = lengthPS# ps
+ break_pt = first_char_pos_that_satisfies
+ (`eqChar#` ch)
+ ps
+ len
+ 0#
+ in
+ break_pt <# len
+
+char_pos_that_dissatisfies :: (Char# -> Bool) -> PackedString -> Int# -> Int# -> Int#
+
+char_pos_that_dissatisfies p ps len pos
+ | pos >=# len = pos -- end
+ | p (indexPS# ps pos) = -- predicate satisfied; keep going
+ char_pos_that_dissatisfies p ps len (pos +# 1#)
+ | otherwise = pos -- predicate not satisfied
+
+char_pos_that_dissatisfies p ps len pos -- dead code: HACK to avoid badly-typed error msg
+ = 0#
+
+first_char_pos_that_satisfies :: (Char# -> Bool) -> PackedString -> Int# -> Int# -> Int#
+first_char_pos_that_satisfies p ps len pos
+ | pos >=# len = pos -- end
+ | p (indexPS# ps pos) = pos -- got it!
+ | otherwise = first_char_pos_that_satisfies p ps len (pos +# 1#)
+
+-- ToDo: could certainly go quicker
+spanPS :: (Char -> Bool) -> PackedString -> (PackedString, PackedString)
+spanPS p ps = (takeWhilePS p ps, dropWhilePS p ps)
+
+breakPS :: (Char -> Bool) -> PackedString -> (PackedString, PackedString)
+breakPS p ps = spanPS (not . p) ps
+
+linesPS :: PackedString -> [PackedString]
+linesPS ps = splitPS '\n' ps
+
+wordsPS :: PackedString -> [PackedString]
+wordsPS ps = splitWithPS isSpace ps
+
+reversePS :: PackedString -> PackedString
+reversePS ps =
+ if nullPS ps then -- don't create stuff unnecessarily.
+ ps
+ else
+ runST (
+ new_ps_array (length +# 1#) >>= \ arr# -> -- incl NUL byte!
+ fill_in arr# (length -# 1#) 0# >>
+ freeze_ps_array arr# >>= \ (ByteArray _ frozen#) ->
+ let has_null = byteArrayHasNUL# frozen# length in
+ return (PS frozen# length has_null))
+ where
+ length = lengthPS# ps
+
+ fill_in :: MutableByteArray s Int -> Int# -> Int# -> ST s ()
+ fill_in arr_in# n i =
+ let
+ ch = indexPS# ps n
+ in
+ write_ps_array arr_in# i ch >>
+ if n ==# 0# then
+ write_ps_array arr_in# (i +# 1#) (chr# 0#) >>
+ return ()
+ else
+ fill_in arr_in# (n -# 1#) (i +# 1#)
+
+concatPS :: [PackedString] -> PackedString
+concatPS [] = nilPS
+concatPS pss
+ = let
+ tot_len# = case (foldr ((+) . lengthPS) 0 pss) of { I# x -> x }
+ tot_len = I# tot_len#
+ in
+ runST (
+ new_ps_array (tot_len# +# 1#) >>= \ arr# -> -- incl NUL byte!
+ packum arr# pss 0# >>
+ freeze_ps_array arr# >>= \ (ByteArray _ frozen#) ->
+
+ let has_null = byteArrayHasNUL# frozen# tot_len# in
+
+ return (PS frozen# tot_len# has_null)
+ )
+ where
+ packum :: MutableByteArray s Int -> [PackedString] -> Int# -> ST s ()
+
+ packum arr [] pos
+ = write_ps_array arr pos (chr# 0#) >>
+ return ()
+ packum arr (ps : pss) pos
+ = fill arr pos ps 0# (lengthPS# ps) >>= \ (I# next_pos) ->
+ packum arr pss next_pos
+
+ fill :: MutableByteArray s Int -> Int# -> PackedString -> Int# -> Int# -> ST s Int
+
+ fill arr arr_i ps ps_i ps_len
+ | ps_i ==# ps_len
+ = return (I# (arr_i +# ps_len))
+ | otherwise
+ = write_ps_array arr (arr_i +# ps_i) (indexPS# ps ps_i) >>
+ fill arr arr_i ps (ps_i +# 1#) ps_len
+
+------------------------------------------------------------
+joinPS :: PackedString -> [PackedString] -> PackedString
+joinPS filler pss = concatPS (splice pss)
+ where
+ splice [] = []
+ splice [x] = [x]
+ splice (x:y:xs) = x:filler:splice (y:xs)
+
+-- ToDo: the obvious generalisation
+{-
+ Some properties that hold:
+
+ * splitPS x ls = ls'
+ where False = any (map (x `elemPS`) ls')
+ False = any (map (nullPS) ls')
+
+ * all x's have been chopped out.
+ * no empty PackedStrings in returned list. A conseq.
+ of this is:
+ splitPS x nilPS = []
+
+
+ * joinPS (packString [x]) (_splitPS x ls) = ls
+
+-}
+
+splitPS :: Char -> PackedString -> [PackedString]
+splitPS (C# ch) = splitWithPS (\ (C# c) -> c `eqChar#` ch)
+
+splitWithPS :: (Char -> Bool) -> PackedString -> [PackedString]
+splitWithPS pred ps =
+ splitify 0#
+ where
+ len = lengthPS# ps
+
+ splitify n
+ | n >=# len = []
+ | otherwise =
+ let
+ break_pt =
+ first_char_pos_that_satisfies
+ (\ c -> pred (C# c))
+ ps
+ len
+ n
+ in
+ if break_pt ==# n then -- immediate match, no substring to cut out.
+ splitify (break_pt +# 1#)
+ else
+ substrPS# ps n (break_pt -# 1#): -- leave out the matching character
+ splitify (break_pt +# 1#)
+\end{code}
+
+%************************************************************************
+%* *
+\subsection{Local utility functions}
+%* *
+%************************************************************************
+
+The definition of @_substrPS@ is essentially:
+@take (end - begin + 1) (drop begin str)@.
+
+\begin{code}
+substrPS :: PackedString -> Int -> Int -> PackedString
+substrPS ps (I# begin) (I# end) = substrPS# ps begin end
+
+substrPS# ps s e
+ | s <# 0# || e <# s
+ = error "substrPS: bounds out of range"
+
+ | s >=# len || result_len# <=# 0#
+ = nilPS
+
+ | otherwise
+ = runST (
+ new_ps_array (result_len# +# 1#) >>= \ ch_arr -> -- incl NUL byte!
+ fill_in ch_arr 0# >>
+ freeze_ps_array ch_arr >>= \ (ByteArray _ frozen#) ->
+
+ let has_null = byteArrayHasNUL# frozen# result_len# in
+
+ return (PS frozen# result_len# has_null)
+ )
+ where
+ len = lengthPS# ps
+
+ result_len# = (if e <# len then (e +# 1#) else len) -# s
+ result_len = I# result_len#
+
+ -----------------------
+ fill_in :: MutableByteArray s Int -> Int# -> ST s ()
+
+ fill_in arr_in# idx
+ | idx ==# result_len#
+ = write_ps_array arr_in# idx (chr# 0#) >>
+ return ()
+ | otherwise
+ = let
+ ch = indexPS# ps (s +# idx)
+ in
+ write_ps_array arr_in# idx ch >>
+ fill_in arr_in# (idx +# 1#)
+\end{code}
+
+(Very :-) ``Specialised'' versions of some CharArray things...
+
+\begin{code}
+new_ps_array :: Int# -> ST s (MutableByteArray s Int)
+write_ps_array :: MutableByteArray s Int -> Int# -> Char# -> ST s ()
+freeze_ps_array :: MutableByteArray s Int -> ST s (ByteArray Int)
+
+new_ps_array size = ST $ \ (S# s) ->
+ case (newCharArray# size s) of { StateAndMutableByteArray# s2# barr# ->
+ (MutableByteArray bot barr#, S# s2#)}
+ where
+ bot = error "new_ps_array"
+
+write_ps_array (MutableByteArray _ barr#) n ch = ST $ \ (S# s#) ->
+ case writeCharArray# barr# n ch s# of { s2# ->
+ ((), S# s2#)}
+
+-- same as unsafeFreezeByteArray
+freeze_ps_array (MutableByteArray ixs arr#) = ST $ \ (S# s#) ->
+ case unsafeFreezeByteArray# arr# s# of { StateAndByteArray# s2# frozen# ->
+ (ByteArray ixs frozen#, S# s2#) }
+\end{code}
+
+
+%*********************************************************
+%* *
+\subsection{Packing and unpacking C strings}
+%* *
+%*********************************************************
+
+\begin{code}
+unpackCString :: Addr -> [Char]
+
+-- Calls to the next four are injected by the compiler itself,
+-- to deal with literal strings
+packCString# :: [Char] -> ByteArray#
+unpackCString# :: Addr# -> [Char]
+unpackCString2# :: Addr# -> Int -> [Char]
+unpackAppendCString# :: Addr# -> [Char] -> [Char]
+unpackFoldrCString# :: Addr# -> (Char -> a -> a) -> a -> a
+
+packCString# str = case (packString str) of { PS bytes _ _ -> bytes }
+
+unpackCString (A# addr) = unpackCString# addr
+
+unpackCString# addr
+ = unpack 0#
+ where
+ unpack nh
+ | ch `eqChar#` '\0'# = []
+ | True = C# ch : unpack (nh +# 1#)
+ where
+ ch = indexCharOffAddr# addr nh
+
+unpackCString2# addr len
+ -- This one is called by the compiler to unpack literal strings with NULs in them; rare.
+ = unpackPS (packCBytes len (A# addr))
+
+unpackAppendCString# addr rest
+ = unpack 0#
+ where
+ unpack nh
+ | ch `eqChar#` '\0'# = rest
+ | True = C# ch : unpack (nh +# 1#)
+ where
+ ch = indexCharOffAddr# addr nh
+
+unpackFoldrCString# addr f z
+ = unpack 0#
+ where
+ unpack nh
+ | ch `eqChar#` '\0'# = z
+ | True = C# ch `f` unpack (nh +# 1#)
+ where
+ ch = indexCharOffAddr# addr nh
+
+
+cStringToPS :: Addr -> PackedString
+cStringToPS (A# a#) = -- the easy one; we just believe the caller
+ CPS a# len
+ where
+ len = case (strlen# a#) of { I# x -> x }
+
+packBytesForC :: [Char] -> ByteArray Int
+packBytesForC str = psToByteArray (packString str)
+
+packBytesForCST :: [Char] -> ST s (ByteArray Int)
+packBytesForCST str =
+ packStringST str >>= \ (PS bytes n has_null) ->
+ --later? ASSERT(not has_null)
+ return (ByteArray (0, I# (n -# 1#)) bytes)
+
+packNBytesForCST :: Int -> [Char] -> ST s (ByteArray Int)
+packNBytesForCST len str =
+ packNCharsST len str >>= \ (PS bytes n has_null) ->
+ return (ByteArray (0, I# (n -# 1#)) bytes)
+
+packCBytes :: Int -> Addr -> PackedString
+packCBytes len addr = runST (packCBytesST len addr)
+
+packCBytesST :: Int -> Addr -> ST s PackedString
+packCBytesST len@(I# length#) (A# addr) =
+ {-
+ allocate an array that will hold the string
+ (not forgetting the NUL byte at the end)
+ -}
+ new_ps_array (length# +# 1#) >>= \ ch_array ->
+ -- fill in packed string from "addr"
+ fill_in ch_array 0# >>
+ -- freeze the puppy:
+ freeze_ps_array ch_array >>= \ (ByteArray _ frozen#) ->
+ let has_null = byteArrayHasNUL# frozen# length# in
+ return (PS frozen# length# has_null)
+ where
+ fill_in :: MutableByteArray s Int -> Int# -> ST s ()
+
+ fill_in arr_in# idx
+ | idx ==# length#
+ = write_ps_array arr_in# idx (chr# 0#) >>
+ return ()
+ | otherwise
+ = case (indexCharOffAddr# addr idx) of { ch ->
+ write_ps_array arr_in# idx ch >>
+ fill_in arr_in# (idx +# 1#) }
+\end{code}
+
+
--- /dev/null
+%
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
+%
+\section[module_ST]{The State Transformer Monad, @ST@}
+
+\begin{code}
+module ST where
+
+import Prelude ()
+import IOBase ( error ) -- [Source not needed]
+import ArrBase
+import STBase
+import PrelBase ( Int, Bool, ($), ()(..) )
+import GHC ( newArray#, readArray#, writeArray#, sameMutableArray# )
+\end{code}
+
+%*********************************************************
+%* *
+\subsection{Variables}
+%* *
+%*********************************************************
+
+\begin{code}
+type MutableVar s a = MutableArray s Int a
+
+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
+
+newVar init = ST $ \ (S# s#) ->
+ case (newArray# 1# init s#) of { StateAndMutableArray# s2# arr# ->
+ (MutableArray vAR_IXS arr#, S# s2#) }
+ where
+ vAR_IXS = error "newVar: Shouldn't access `bounds' of a MutableVar\n"
+
+readVar (MutableArray _ var#) = ST $ \ (S# s#) ->
+ case readArray# var# 0# s# of { StateAndPtr# s2# r ->
+ (r, S# s2#) }
+
+writeVar (MutableArray _ var#) val = ST $ \ (S# s#) ->
+ case writeArray# var# 0# val s# of { s2# ->
+ ((), S# s2#) }
+
+sameVar (MutableArray _ var1#) (MutableArray _ var2#)
+ = sameMutableArray# var1# var2#
+\end{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}
+
+++ /dev/null
-module Array (
- module Ix, -- export all of Ix
- Array, array, listArray, (!), bounds, indices, elems, assocs,
- accumArray, (//), accum, amap, ixmap ) where
-import Ix
-import List((\\))
-import GHCbase
-
--- Report note:
--- This module specifies the semantics of arrays only: it is not
--- intended as an efficient implementation.
-
-infixl 9 !, //
-
---Report:data (Ix a) => Array a b = MkArray (a,a) (a -> b) deriving ()
--- in GHCbase:
--- data Ix ix => Array ix elt = Array (ix, ix) (Array# elt)
-
---type IPr = (Int, Int)
-
-{-# GENERATE_SPECS array a{~,Int,IPr} b{} #-}
-array :: (Ix a) => (a,a) -> [(a,b)] -> Array a b
-
-{-# GENERATE_SPECS listArray a{~,Int,IPr} b{} #-}
-listArray :: (Ix a) => (a,a) -> [b] -> Array a b
-
-{-# GENERATE_SPECS (!) a{~,Int,IPr} b{} #-}
-(!) :: (Ix a) => Array a b -> a -> b
-
-bounds :: (Ix a) => Array a b -> (a,a)
-
-{-# GENERATE_SPECS indices a{~,Int,IPr} b{} #-}
-indices :: (Ix a) => Array a b -> [a]
-
-{-# GENERATE_SPECS elems a{~,Int,IPr} b{} #-}
-elems :: (Ix a) => Array a b -> [b]
-
-{-# GENERATE_SPECS assocs a{~,Int,IPr} b{} #-}
-assocs :: (Ix a) => Array a b -> [(a,b)]
-
-{-# GENERATE_SPECS (//) a{~,Int,IPr} b{} #-}
-(//) :: (Ix a) => Array a b -> [(a,b)] -> Array a b
-
-{-# GENERATE_SPECS accum a{~,Int,IPr} b{} c{} #-}
-accum :: (Ix a) => (b -> c -> b) -> Array a b -> [(a,c)] -> Array a b
-
-{-# GENERATE_SPECS accumArray a{~,Int,IPr} b{} c{} #-}
-accumArray :: (Ix a) => (b -> c -> b) -> b -> (a,a) -> [(a,c)] -> Array a b
-
-{-# GENERATE_SPECS amap a{~,Int,IPr} b{} c{} #-}
-amap :: (Ix a) => (b -> c) -> Array a b -> Array a c
-
-ixmap :: (Ix a, Ix b) => (a,a) -> (a -> b) -> Array b c -> Array a c
-
------------------------------------------------------------------------
-{- "array", "!" and "bounds" are basic;
- the rest can be defined in terms of them
--}
-
-bounds (Array b _) = b
-
-(Array bounds arr#) ! i
- = let n# = case (index bounds i) of { I# x -> x } -- index fails if out of range
- in
- case (indexArray# arr# n#) of
- Lift v -> v
-
-#ifdef USE_FOLDR_BUILD
-{-# INLINE array #-}
-#endif
-array ixs@(ix_start, ix_end) ivs =
- runST ( ST $ \ s ->
- case (newArray ixs arrEleBottom) of { ST new_array_thing ->
- case (new_array_thing s) of { (arr@(MutableArray _ arr#),s) ->
- let
- fill_one_in (S# s#) (i, v)
- = case index ixs i of { I# n# ->
- case writeArray# arr# n# v s# of { s2# ->
- S# s2# }}
- in
- case (foldl fill_one_in s ivs) of { s@(S# _) ->
- case (freezeArray arr) of { ST freeze_array_thing ->
- freeze_array_thing s }}}})
-
-arrEleBottom = error "(Array.!): undefined array element"
-
-fill_it_in :: Ix ix => MutableArray s ix elt -> [(ix, elt)] -> ST s ()
-fill_it_in arr lst
- = foldr fill_one_in (returnStrictlyST ()) lst
- where -- **** STRICT **** (but that's OK...)
- fill_one_in (i, v) rst
- = writeArray arr i v `seqStrictlyST` rst
-
------------------------------------------------------------------------
--- these also go better with magic: (//), accum, accumArray
-
-old_array // ivs
- = runST (
- -- copy the old array:
- thawArray old_array `thenStrictlyST` \ arr# ->
- -- now write the new elements into the new array:
- fill_it_in arr# ivs `seqStrictlyST`
- freezeArray arr#
- )
- where
- bottom = error "(Array.//): error in copying old array\n"
-
-zap_with_f :: Ix ix => (elt -> elt2 -> elt) -> MutableArray s ix elt -> [(ix,elt2)] -> ST s ()
--- 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
- where
- zap_one (i, new_v) rst
- = readArray arr i `thenStrictlyST` \ old_v ->
- writeArray arr i (f old_v new_v) `seqStrictlyST`
- rst
-
-accum f arr ivs
- = runST (
- -- copy the old array:
- newArray (bounds arr) bottom >>= \ arr# ->
- fill_it_in arr# (assocs arr) >>
-
- -- now zap the elements in question with "f":
- zap_with_f f arr# ivs >>
- freezeArray arr#
- )
- where
- bottom = error "Array.accum: error in copying old array\n"
-
-accumArray f zero ixs ivs
- = runST (
- newArray ixs zero >>= \ arr# ->
- zap_with_f f arr# ivs >>
- freezeArray arr#
- )
-
------------------------------------------------------------------------
-
-listArray b vs = array b (zipWith (\ a b -> (a,b)) (range b) vs)
-
-#ifdef USE_FOLDR_BUILD
-{-# INLINE indices #-}
-{-# INLINE elems #-}
-{-# INLINE assocs #-}
-#endif
-
-indices = range . bounds
-
-elems a = [a!i | i <- indices a]
-
-assocs a = [(i, a!i) | i <- indices a]
-
-amap f a = array b [(i, f (a!i)) | i <- range b]
- where b = bounds a
-
-ixmap b f a = array b [(i, a ! f i) | i <- range b]
--- /dev/null
+%
+% (c) The AQUA Project, Glasgow University, 1994-1996
+%
+
+\section[Array]{Module @Array@}
+
+\begin{code}
+module Array (
+ module Ix, -- export all of Ix
+ Array, -- Array type abstractly
+
+ array, listArray, (!), bounds, indices, elems, assocs,
+ accumArray, (//), accum, amap, ixmap
+ ) where
+
+import Prelude ()
+import Ix
+import PrelList
+import PrelRead
+import ArrBase -- Most of the hard work is done here
+import PrelBase
+
+infixl 9 !, //
+\end{code}
+
+
+
+%*********************************************************
+%* *
+\subsection{Definitions of array, !, bounds}
+%* *
+%*********************************************************
+
+\begin{code}
+
+#ifdef USE_FOLDR_BUILD
+{-# INLINE indices #-}
+{-# INLINE elems #-}
+{-# INLINE assocs #-}
+#endif
+
+{-# GENERATE_SPECS listArray a{~,Int,IPr} b{} #-}
+listArray :: (Ix a) => (a,a) -> [b] -> Array a b
+listArray b vs = array b (zipWith (\ a b -> (a,b)) (range b) vs)
+
+{-# GENERATE_SPECS indices a{~,Int,IPr} b{} #-}
+indices :: (Ix a) => Array a b -> [a]
+indices = range . bounds
+
+{-# GENERATE_SPECS elems a{~,Int,IPr} b{} #-}
+elems :: (Ix a) => Array a b -> [b]
+elems a = [a!i | i <- indices a]
+
+{-# GENERATE_SPECS assocs a{~,Int,IPr} b{} #-}
+assocs :: (Ix a) => Array a b -> [(a,b)]
+assocs a = [(i, a!i) | i <- indices a]
+
+{-# GENERATE_SPECS amap a{~,Int,IPr} b{} c{} #-}
+amap :: (Ix a) => (b -> c) -> Array a b -> Array a c
+amap f a = array b [(i, f (a!i)) | i <- range b]
+ where b = bounds a
+
+ixmap :: (Ix a, Ix b) => (a,a) -> (a -> b) -> Array b c -> Array a c
+ixmap b f a = array b [(i, a ! f i) | i <- range b]
+\end{code}
+
+
+%*********************************************************
+%* *
+\subsection{Instance declarations for Array type}
+%* *
+%*********************************************************
+
+\begin{code}
+instance (Ix a, Eq b) => Eq (Array a b) where
+ a == a' = assocs a == assocs a'
+ a /= a' = assocs a /= assocs a'
+
+instance (Ix a, Ord b) => Ord (Array a b) where
+ compare a b = compare (assocs a) (assocs b)
+
+instance (Ix a, Show a, Show b) => Show (Array a b) where
+ showsPrec p a = showParen (p > 9) (
+ showString "array " .
+ shows (bounds a) . showChar ' ' .
+ shows (assocs a) )
+ showList = showList__ (showsPrec 0)
+
+instance (Ix a, Read a, Read b) => Read (Array a b) where
+ readsPrec p = readParen (p > 9)
+ (\r -> [(array b as, u) | ("array",s) <- lex r,
+ (b,t) <- reads s,
+ (as,u) <- reads t ])
+ readList = readList__ (readsPrec 0)
+\end{code}
+++ /dev/null
-module Char (
- isAscii, isControl, isPrint, isSpace, isUpper, isLower,
- isAlpha, isDigit, isOctDigit, isHexDigit, isAlphanum, toUpper, toLower ) where
-
-isAscii, isControl, isPrint, isSpace, isUpper,
- isLower, isAlpha, isDigit, isOctDigit, isHexDigit, isAlphanum :: Char -> Bool
-isAscii c = fromEnum c < 128
-isControl c = c < ' ' || c >= '\DEL' && c <= '\x9f'
-isPrint c = not (isControl c)
--- This includes non-breaking space
-isSpace c = c `elem` " \t\n\r\f\v\xa0"
--- The upper case ISO characters have the multiplication sign dumped
--- randomly in the middle of the range. Go figure.
-isUpper c = c >= 'A' && c <= 'Z' ||
- c >= '\xC0' && c <= '\xD6' ||
- c >= '\xD8' && c <= '\xDE'
--- The lower case ISO characters have the division sign dumped
--- randomly in the middle of the range. Go figure.
-isLower c = c >= 'a' && c <= 'z' ||
- c >= '\xDF' && c <= '\xF6' ||
- c >= '\xF8' && c <= '\xFF'
-isAlpha c = isUpper c || isLower 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)
-
-toUpper, toLower :: Char -> Char
-toUpper c | isLower c = toEnum (fromEnum c - fromEnum 'a'
- + fromEnum 'A')
- | otherwise = c
-
-toLower c | isUpper c = toEnum (fromEnum c - fromEnum 'A'
- + fromEnum 'a')
- | otherwise = c
--- /dev/null
+%
+% (c) The AQUA Project, Glasgow University, 1994-1996
+%
+
+\section[Char]{Module @Char@}
+
+\begin{code}
+module Char (
+ isAscii, isControl, isPrint, isSpace, isUpper, isLower,
+ isAlpha, isDigit, isOctDigit, isHexDigit, isAlphanum, toUpper, toLower
+ ) where
+
+import Prelude ()
+import PrelBase
+\end{code}
+
+
+
+
+
+%
+% (c) The AQUA Project, Glasgow University, 1994-1996
+%
+
+\section[Complex]{Module @Complex@}
+
+\begin{code}
+module Complex (
+ Complex((:+)),
+
+ realPart, imagPart, conjugate, mkPolar,
+ cis, polar, magnitude, phase
+ ) where
-module Complex(Complex((:+)), realPart, imagPart, conjugate, mkPolar,
- cis, polar, magnitude, phase) where
infix 6 :+
+\end{code}
+
+%*********************************************************
+%* *
+\subsection{The @Complex@ type}
+%* *
+%*********************************************************
+\begin{code}
data (RealFloat a) => Complex a = !a :+ !a deriving (Eq,Read,Show)
+\end{code}
+
+%*********************************************************
+%* *
+\subsection{Functions over @Complex@}
+%* *
+%*********************************************************
+
+\begin{code}
realPart, imagPart :: (RealFloat a) => Complex a -> a
realPart (x:+y) = x
imagPart (x:+y) = y
mk = - k
phase (x:+y) = atan2 y x
+\end{code}
+
+%*********************************************************
+%* *
+\subsection{Instances of @Complex@}
+%* *
+%*********************************************************
-instance (RealFloat a) => Num (Complex a) where
+\begin{code}
+instance (RealFloat a) => Prelude.Num (Complex a) where
(x:+y) + (x':+y') = (x+x') :+ (y+y')
(x:+y) - (x':+y') = (x-x') :+ (y-y')
(x:+y) * (x':+y') = (x*x'-y*y') :+ (x*y'+y*x')
fromRational a = fromRational a :+ 0
-instance (RealFloat a) => Floating (Complex a) where
+instance (Prelude.RealFloat a) => Floating (Complex a) where
pi = pi :+ 0
exp (x:+y) = expx * cos y :+ expx * sin y
where expx = exp x
asinh z = log (z + sqrt (1+z*z))
acosh z = log (z + (z+1) * sqrt ((z-1)/(z+1)))
atanh z = log ((1+z) / sqrt (1-z*z))
+\end{code}
-{-
%
-% (c) The GRASP/AQUA Project, Glasgow University, 1995-1996
+% (c) The AQUA Project, Glasgow University, 1994-1996
%
-\section[LibDirectory]{Haskell 1.3 Directory Operations}
+
+\section[Directory]{Module @Directory@}
A directory contains a series of entries, each of which is a named
reference to a file system object (file, directory etc.). Some
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 Directory (
createDirectory, removeDirectory, removeFile,
renameDirectory, renameFile, getDirectoryContents,
- getCurrentDirectory, setCurrentDirectory ) where
+ getCurrentDirectory, setCurrentDirectory
+ ) where
-import GHCio
-import PreludeGlaST
-import GHCps ( packCBytesST, unpackPS )
+import Foreign
+import IOBase
+import STBase ( PrimIO )
+import PackedString ( packCBytesST, unpackPS )
+\end{code}
+%*********************************************************
+%* *
+\subsection{Signatures}
+%* *
+%*********************************************************
+
+\begin{code}
createDirectory :: FilePath -> IO ()
removeDirectory :: FilePath -> IO ()
removeFile :: FilePath -> IO ()
getDirectoryContents :: FilePath -> IO [FilePath]
getCurrentDirectory :: IO FilePath
setCurrentDirectory :: FilePath -> IO ()
+\end{code}
+
+
+%*********************************************************
+%* *
+\subsection{Signatures}
+%* *
+%*********************************************************
---------------------
-{-
$createDirectory dir$ creates a new directory
{\em dir} which is initially empty, or as near to empty as the
operating system allows.
The path refers to an existing non-directory object.
[$EEXIST$]
\end{itemize}
--}
+\begin{code}
createDirectory path =
- _ccall_ createDirectory path `stThen` \ rc ->
+ _ccall_ createDirectory path `thenIO_Prim` \ rc ->
if rc == 0 then
return ()
else
constructErrorAndFail "createDirectory"
+\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
The operand refers to an existing non-directory object.
[$ENOTDIR$]
\end{itemize}
--}
+
+\begin{code}
removeDirectory path =
- _ccall_ removeDirectory path `stThen` \ rc ->
+ _ccall_ removeDirectory path `thenIO_Prim` \ rc ->
if rc == 0 then
return ()
else
constructErrorAndFail "removeDirectory"
+\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
The operand refers to an existing directory.
[$EPERM$, $EINVAL$]
\end{itemize}
--}
+
+\begin{code}
removeFile path =
- _ccall_ removeFile path `stThen` \ rc ->
+ _ccall_ removeFile path `thenIO_Prim` \ rc ->
if rc == 0 then
return ()
else
constructErrorAndFail "removeFile"
+\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.
Either path refers to an existing non-directory object.
[$ENOTDIR$, $EISDIR$]
\end{itemize}
--}
+
+\begin{code}
renameDirectory opath npath =
- _ccall_ renameDirectory opath npath `stThen` \ rc ->
+ _ccall_ renameDirectory opath npath `thenIO_Prim` \ rc ->
if rc == 0 then
return ()
else
constructErrorAndFail "renameDirectory"
+\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
[$ENOTDIR$, $EISDIR$, $EINVAL$,
$EEXIST$, $ENOTEMPTY$]
\end{itemize}
--}
+
+\begin{code}
renameFile opath npath =
- _ccall_ renameFile opath npath `stThen` \ rc ->
+ _ccall_ renameFile opath npath `thenIO_Prim` \ rc ->
if rc == 0 then
return ()
else
constructErrorAndFail "renameFile"
+\end{code}
----------------------------
-{-
$getDirectoryContents dir$ returns a list of
<i>all</i> entries in {\em dir}.
The path refers to an existing non-directory object.
[$ENOTDIR$]
\end{itemize}
--}
+
+\begin{code}
getDirectoryContents path =
- _ccall_ getDirectoryContents path `stThen` \ ptr ->
+ _ccall_ getDirectoryContents path `thenIO_Prim` \ ptr ->
if ptr == ``NULL'' then
constructErrorAndFail "getDirectoryContents"
else
stToIO (getEntries ptr 0) >>= \ entries ->
- _ccall_ free ptr `stThen` \ () ->
+ _ccall_ free ptr `thenIO_Prim` \ () ->
return entries
where
getEntries :: Addr -> Int -> PrimIO [FilePath]
_ccall_ free str >>= \ () ->
getEntries ptr (n+1) >>= \ entries ->
return (unpackPS entry : entries)
+\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.
\item $UnsupportedOperation$
The operating system has no notion of current directory.
\end{itemize}
--}
+
+\begin{code}
getCurrentDirectory =
- _ccall_ getCurrentDirectory `stThen` \ str ->
+ _ccall_ getCurrentDirectory `thenIO_Prim` \ str ->
if str /= ``NULL'' then
- _ccall_ strlen str `stThen` \ len ->
+ _ccall_ strlen str `thenIO_Prim` \ len ->
stToIO (packCBytesST len str) >>= \ pwd ->
- _ccall_ free str `stThen` \ () ->
+ _ccall_ free str `thenIO_Prim` \ () ->
return (unpackPS pwd)
else
constructErrorAndFail "getCurrentDirectory"
+\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 path refers to an existing non-directory object.
[$ENOTDIR$]
\end{itemize}
--}
+
+\begin{code}
setCurrentDirectory path =
- _ccall_ setCurrentDirectory path `stThen` \ rc ->
+ _ccall_ setCurrentDirectory path `thenIO_Prim` \ rc ->
if rc == 0 then
return ()
else
constructErrorAndFail "setCurrentDirectory"
-
+\end{code}
+%
+% (c) The AQUA Project, Glasgow University, 1994-1996
+%
+
+\section[IO]{Module @IO@}
+
+\begin{code}
module IO (
Handle, HandlePosn,
+
IOMode(ReadMode,WriteMode,AppendMode,ReadWriteMode),
BufferMode(NoBuffering,LineBuffering,BlockBuffering),
SeekMode(AbsoluteSeek,RelativeSeek,SeekFromEnd),
- stdin, stdout, stderr, openFile, hClose, hFileSize, hIsEOF, isEOF,
+
+ stdin, stdout, stderr,
+ openFile, hClose, hFileSize, hIsEOF, isEOF,
hSetBuffering, hGetBuffering, hFlush, hGetPosn, hSetPosn, hSeek,
hIsOpen, hIsClosed, hIsReadable, hIsWritable, hIsSeekable, hReady,
hGetChar, hLookAhead, hGetContents, hPutChar, hPutStr, hPrint,
+
isAlreadyExistsError, isAlreadyInUseError, isFullError, isEOFError,
isIllegalOperation, isPermissionError, isUserError,
- ioeGetHandle, ioeGetFileName ) where
+ ioeGetHandle, ioeGetFileName
+ ) where
+import Prelude ()
import Ix
-import GHCio -- much of the real stuff is in here
-import GHCbase
-import GHCps ( nilPS, packCBytesST, unpackPS )
-
---GHCio:hClose :: Handle -> IO ()
---GHCio:hFileSize :: Handle -> IO Integer
---GHCio:hFlush :: Handle -> IO ()
---GHCio:hGetBuffering :: Handle -> IO BufferMode
+import STBase
+import IOBase
+import ArrBase ( MutableByteArray(..), newCharArray )
+import IOHandle -- much of the real stuff is in here
+import PackedString ( nilPS, packCBytesST, unpackPS )
+import PrelBase
+import GHC
+\end{code}
+
+%*********************************************************
+%* *
+\subsection{Signatures}
+%* *
+%*********************************************************
+
+\begin{code}
+--IOHandle:hClose :: Handle -> IO ()
+--IOHandle:hFileSize :: Handle -> IO Integer
+--IOHandle:hFlush :: Handle -> IO ()
+--IOHandle:hGetBuffering :: Handle -> IO BufferMode
hGetChar :: Handle -> IO Char
hGetContents :: Handle -> IO String
---GHCio:hGetPosn :: Handle -> IO HandlePosn
---GHCio:hIsClosed :: Handle -> IO Bool
---GHCio:hIsEOF :: Handle -> IO Bool
---GHCio:hIsOpen :: Handle -> IO Bool
---GHCio:hIsReadable :: Handle -> IO Bool
---GHCio:hIsSeekable :: Handle -> IO Bool
---GHCio:hIsWritable :: Handle -> IO Bool
+--IOHandle:hGetPosn :: Handle -> IO HandlePosn
+--IOHandle:hIsClosed :: Handle -> IO Bool
+--IOHandle:hIsEOF :: Handle -> IO Bool
+--IOHandle:hIsOpen :: Handle -> IO Bool
+--IOHandle:hIsReadable :: Handle -> IO Bool
+--IOHandle:hIsSeekable :: Handle -> IO Bool
+--IOHandle:hIsWritable :: Handle -> IO Bool
hLookAhead :: Handle -> IO Char
hPrint :: Show a => Handle -> a -> IO ()
hPutChar :: Handle -> Char -> IO ()
hPutStr :: Handle -> String -> IO ()
hReady :: Handle -> IO Bool
---GHCio:hSeek :: Handle -> SeekMode -> Integer -> IO ()
---GHCio:hSetBuffering :: Handle -> BufferMode -> IO ()
---GHCio:hSetPosn :: HandlePosn -> IO ()
-ioeGetFileName :: IOError -> Maybe FilePath
-ioeGetHandle :: IOError -> Maybe Handle
-isAlreadyExistsError :: IOError -> Bool
-isAlreadyInUseError :: IOError -> Bool
---GHCio:isEOF :: IO Bool
-isEOFError :: IOError -> Bool
-isFullError :: IOError -> Bool
-isIllegalOperation :: IOError -> Bool
-isPermissionError :: IOError -> Bool
-isUserError :: IOError -> Maybe String
---GHCio:openFile :: FilePath -> IOMode -> IO Handle
---GHCio:stdin, stdout, stderr :: Handle
-
----------------------------
--- Computation $hReady hdl$ indicates whether at least
--- one item is available for input from handle {\em hdl}.
-
+--IOHandle:hSeek :: Handle -> SeekMode -> Integer -> IO ()
+--IOHandle:hSetBuffering :: Handle -> BufferMode -> IO ()
+--IOHandle:hSetPosn :: HandlePosn -> IO ()
+-- ioeGetFileName :: IOError -> Maybe FilePath
+-- ioeGetHandle :: IOError -> Maybe Handle
+-- isAlreadyExistsError :: IOError -> Bool
+-- isAlreadyInUseError :: IOError -> Bool
+--IOHandle:isEOF :: IO Bool
+-- isEOFError :: IOError -> Bool
+-- isFullError :: IOError -> Bool
+-- isIllegalOperation :: IOError -> Bool
+-- isPermissionError :: IOError -> Bool
+-- isUserError :: IOError -> Maybe String
+--IOHandle:openFile :: FilePath -> IOMode -> IO Handle
+--IOHandle:stdin, stdout, stderr :: Handle
+\end{code}
+
+%*********************************************************
+%* *
+\subsection{Simple input operations}
+%* *
+%*********************************************************
+
+Computation $hReady hdl$ indicates whether at least
+one item is available for input from handle {\em hdl}.
+
+\begin{code}
--hReady :: Handle -> IO Bool
hReady handle =
readHandle handle >>= \ htype ->
writeHandle handle htype >>
fail (IllegalOperation "handle is not open for reading")
other ->
- _ccall_ inputReady (filePtr other) `stThen` \ rc ->
+ _ccall_ inputReady (filePtr other) `thenIO_Prim` \ rc ->
writeHandle handle (markHandle htype) >>
case rc of
0 -> return False
1 -> return True
_ -> constructErrorAndFail "hReady"
+\end{code}
----------------------------
---Computation $hGetChar hdl$ reads the next character from handle {\em
---hdl}, blocking until a character is available.
+Computation $hGetChar hdl$ reads the next character from handle
+{\em hdl}, blocking until a character is available.
+\begin{code}
--hGetChar :: Handle -> IO Char
hGetChar handle =
writeHandle handle htype >>
fail (IllegalOperation "handle is not open for reading")
other ->
- _ccall_ fileGetc (filePtr other) `stThen` \ intc ->
+ _ccall_ fileGetc (filePtr other) `thenIO_Prim` \ intc ->
writeHandle handle (markHandle htype) >>
if intc /= ``EOF'' then
return (chr intc)
else
constructErrorAndFail "hGetChar"
+\end{code}
--------------------------------
--- Computation $hLookahead hdl$ returns the next character from handle
---{\em hdl} without removing it from the input buffer, blocking until a
--- character is available.
+Computation $hLookahead hdl$ returns the next character from handle
+{\em hdl} without removing it from the input buffer, blocking until a
+character is available.
+\begin{code}
--hLookAhead :: Handle -> IO Char
hLookAhead handle =
writeHandle handle htype >>
fail (IllegalOperation "handle is not open for reading")
other ->
- _ccall_ fileLookAhead (filePtr other) `stThen` \ intc ->
+ _ccall_ fileLookAhead (filePtr other) `thenIO_Prim` \ intc ->
writeHandle handle (markHandle htype) >>
if intc /= ``EOF'' then
return (chr intc)
else
constructErrorAndFail "hLookAhead"
+\end{code}
+
+
+%*********************************************************
+%* *
+\subsection{Getting the entire contents of a handle}
+%* *
+%*********************************************************
------------------------------------
--- Computation $hGetContents hdl$ returns the list of characters
--- corresponding to the unread portion of the channel or file managed by
--- {\em hdl}, which is made semi-closed.
+Computation $hGetContents hdl$ returns the list of characters
+corresponding to the unread portion of the channel or file managed by
+{\em hdl}, which is made semi-closed.
+\begin{code}
--hGetContents :: Handle -> IO String
hGetContents handle =
writeHandle handle (SemiClosedHandle (filePtr other) buf_info)
>>
unsafeInterleavePrimIO (lazyReadLine handle)
- `stThen` \ contents ->
+ `thenIO_Prim` \ contents ->
return contents
Just (BlockBuffering size) ->
writeHandle handle (SemiClosedHandle (filePtr other) buf_info)
>>
unsafeInterleavePrimIO (lazyReadBlock handle)
- `stThen` \ contents ->
+ `thenIO_Prim` \ contents ->
return contents
_ -> -- Nothing is treated pessimistically as NoBuffering
writeHandle handle (SemiClosedHandle (filePtr other) (``NULL'', 0))
>>
unsafeInterleavePrimIO (lazyReadChar handle)
- `stThen` \ contents ->
+ `thenIO_Prim` \ contents ->
return contents
where
allocBuf :: Maybe Int -> IO (Addr, Int)
allocBuf msize =
- _ccall_ malloc size `stThen` \ buf ->
+ _ccall_ malloc size `thenIO_Prim` \ buf ->
if buf /= ``NULL'' then
return (buf, size)
else
case msize of
Just x -> x
Nothing -> ``BUFSIZ''
+\end{code}
-{-
- Note that someone may yank our handle out from under us, and then re-use
- the same FILE * for something else. Therefore, we have to re-examine the
- handle every time through.
--}
+Note that someone may yank our handle out from under us, and then re-use
+the same FILE * for something else. Therefore, we have to re-examine the
+handle every time through.
+\begin{code}
lazyReadBlock :: Handle -> PrimIO String
lazyReadLine :: Handle -> PrimIO String
lazyReadChar :: Handle -> PrimIO String
unsafeInterleavePrimIO (lazyReadChar handle)
>>= \ more ->
returnPrimIO (chr char : more)
+\end{code}
+
+
+%*********************************************************
+%* *
+\subsection{Simple output functions}
+%* *
+%*********************************************************
------------------------------------
--- Computation $hPutChar hdl c$ writes the character {\em c} to the file
--- or channel managed by {\em hdl}. Characters may be buffered if
--- buffering is enabled for {\em hdl}.
+Computation $hPutChar hdl c$ writes the character {\em c} to the file
+or channel managed by {\em hdl}. Characters may be buffered if
+buffering is enabled for {\em hdl}.
+\begin{code}
--hPutChar :: Handle -> Char -> IO ()
hPutChar handle c =
writeHandle handle htype >>
fail (IllegalOperation "handle is not open for writing")
other ->
- _ccall_ filePutc (filePtr other) (ord c) `stThen` \ rc ->
+ _ccall_ filePutc (filePtr other) (ord c) `thenIO_Prim` \ rc ->
writeHandle handle (markHandle htype) >>
if rc == 0 then
return ()
else
constructErrorAndFail "hPutChar"
+\end{code}
-------------------------------------
--- Computation $hPutStr hdl s$ writes the string {\em s} to the file or
--- channel managed by {\em hdl}.
+Computation $hPutStr hdl s$ writes the string {\em s} to the file or
+channel managed by {\em hdl}.
+\begin{code}
--hPutStr :: Handle -> String -> IO ()
hPutStr handle str =
writeHandle handle htype >>
fail (IllegalOperation "handle is not open for writing")
other ->
- getBufferMode other `stThen` \ other ->
+ getBufferMode other `thenIO_Prim` \ other ->
(case bufferMode other of
Just LineBuffering ->
writeLines (filePtr other) str
writeBlocks (filePtr other) ``BUFSIZ'' str
_ -> -- Nothing is treated pessimistically as NoBuffering
writeChars (filePtr other) str
- ) `stThen` \ success ->
+ ) `thenIO_Prim` \ success ->
writeHandle handle (markHandle other) >>
if success then
return ()
shoveString n ls =
case ls of
[] ->
- if n `eqInt#` 0# then
+ if n ==# 0# then
returnPrimIO True
else
_ccall_ writeFile arr fp (I# n) >>= \rc ->
write_char arr# n x >>
{- Flushing lines - should we bother? -}
- if n `eqInt#` bufLen {- || (chopOnNewLine && (x `eqChar#` '\n'#)) -} then
- _ccall_ writeFile arr fp (I# (n `plusInt#` 1#)) >>= \ rc ->
+ if n ==# bufLen {- || (chopOnNewLine && (x `eqChar#` '\n'#)) -} then
+ _ccall_ writeFile arr fp (I# (n +# 1#)) >>= \ rc ->
if rc == 0 then
shoveString 0# xs
else
return False
else
- shoveString (n `plusInt#` 1#) xs
+ shoveString (n +# 1#) xs
in
shoveString 0# s
writeChars fp cs
else
returnPrimIO False
+\end{code}
-------------------------------------------
--- Computation $hPrint hdl t$ writes the string representation of {\em
--- t} given by the $shows$ function to the file or channel managed by
--- {\em hdl}.
+Computation $hPrint hdl t$ writes the string representation of {\em t}
+given by the $shows$ function to the file or channel managed by {\em
+hdl}.
+\begin{code}
--hPrint :: Show a => Handle -> a -> IO ()
hPrint hdl = hPutStr hdl . show
-
-------------------------------------------
--- almost no effort made on these so far...
-
-isAlreadyExistsError (AlreadyExists _) = True
-isAlreadyExistsError _ = False
-
-isAlreadyInUseError (ResourceBusy _) = True
-isAlreadyInUseError _ = False
-
-isFullError (ResourceExhausted _) = True
-isFullError _ = False
-
-isEOFError EOF = True
-isEOFError _ = True
-
-isIllegalOperation (IllegalOperation _) = True
-isIllegalOperation _ = False
-
-isPermissionError (PermissionDenied _) = True
-isPermissionError _ = False
-
-isUserError (UserError s) = Just s
-isUserError _ = Nothing
-
-ioeGetHandle _ = Nothing -- a stub, essentially
-
-ioeGetFileName _ = Nothing -- a stub, essentially
+\end{code}
-module Ix ( Ix(range, index, inRange) ) where
-
+%
+% (c) The AQUA Project, Glasgow University, 1994-1996
+%
+
+\section[Ix]{Module @Ix@}
+
+\begin{code}
+module Ix (
+ Ix(range, index, inRange)
+ ) where
+
+import Prelude ()
+import IOBase ( error ) {-# SOURCE #-}
+import PrelNum
+import PrelTup
+import PrelBase
+\end{code}
+
+%*********************************************************
+%* *
+\subsection{The @Ix@ class}
+%* *
+%*********************************************************
+
+\begin{code}
class (Show a, Ord a) => Ix a where
range :: (a,a) -> [a]
index :: (a,a) -> a -> Int
inRange :: (a,a) -> a -> Bool
+\end{code}
+
+
+%*********************************************************
+%* *
+\subsection{Instances of @Ix@}
+%* *
+%*********************************************************
+\begin{code}
instance Ix Char where
range (c,c') = [c..c']
index b@(c,c') ci
inRange ((l1,l2,l3,l4,l5),(u1,u2,u3,u4,u5)) (i1,i2,i3,i4,i5) =
inRange (l1,u1) i1 && inRange (l2,u2) i2 &&
inRange (l3,u3) i3 && inRange (l4,u4) i4 && inRange (l5,u5) i5
+\end{code}
+%
+% (c) The AQUA Project, Glasgow University, 1994-1996
+%
+
+\section[List]{Module @Lhar@}
+
+\begin{code}
module List (
delete, deleteBy, (\\), deleteFirsts, deleteFirstsBy,
elemBy, notElemBy, lookupBy, maximumBy, minimumBy,
elemIndex, elemIndexBy, intersperse, group, groupBy,
mapAccumL, mapAccumR,
inits, tails, subsequences, permutations,
- union, intersect ) where
+ union, intersect
+ ) where
+
+import Prelude
+\end{code}
+%*********************************************************
+%* *
+\subsection{List functions}
+%* *
+%*********************************************************
+
+\begin{code}
-- delete x removes the first occurrence of x from its list argument.
delete :: (Eq a) => a -> [a] -> [a]
delete = deleteBy (==)
intersect :: (Eq a) => [a] -> [a] -> [a]
intersect xs ys = [x | x <- xs, x `elem` ys]
-
-
+\end{code}
+%
+% (c) The AQUA Project, Glasgow University, 1994-1996
+%
+
+\section[Maybe]{Module @Maybe@}
+
+\begin{code}
module Maybe(
+ Maybe(..),
the, exists, theExists, maybe, fromMaybe, listToMaybe, maybeToList,
- findMaybe, catMaybes, mapMaybe, joinMaybe, unfoldr ) where
+ findMaybe, catMaybes, mapMaybe, joinMaybe, unfoldr
+ ) where
+
+import Prelude ()
+import IOBase ( error )
+import Monad ( filter )
+import PrelList
+import PrelBase
+\end{code}
+
+
+%*********************************************************
+%* *
+\subsection{Functions}
+%* *
+%*********************************************************
+
+\begin{code}
+maybe :: b -> (a -> b) -> Maybe a -> b
+maybe n f Nothing = n
+maybe n f (Just x) = f x
exists :: Maybe a -> Bool
exists = maybe False (const True)
case f x of
Just (y,x') -> let (ys,x'') = unfoldr f x' in (y:ys,x'')
Nothing -> ([],x)
+\end{code}
+++ /dev/null
-module Monad (
- join, apply, (@@), mapAndUnzipL, mapAndUnzipR, accumulateL,
- accumulateR, zipWithL, zipWithR, sequenceL, sequenceR,
- mapL, mapR, map_, foldL, foldR, concatM, done, unless, when
- ) where
-
-join :: (Monad m) => m (m a) -> m a
-join x = x >>= id
-
-apply :: (Monad m) => (a -> m b) -> (m a -> m b)
-apply f x = x >>= f
-
-(@@) :: (Monad m) => (a -> m b) -> (c -> m a) -> (c -> m b)
-f @@ g = \ x -> g x >>= f
-
-mapAndUnzipL :: (Monad m) => (a -> m (b,c)) -> [a] -> m ([b], [c])
-mapAndUnzipL f xs = accumulateL (map f xs) >>= return . unzip
-
-mapAndUnzipR :: (Monad m) => (a -> m (b,c)) -> [a] -> m ([b], [c])
-mapAndUnzipR f xs = accumulateR (map f xs) >>= return . unzip
-
-accumulateL :: (Monad m) => [m a] -> m [a]
-accumulateL = accumulate
-
-accumulateR :: (Monad m) => [m a] -> m [a]
-accumulateR = foldr mcons (return [])
- where mcons p q = q >>= \ xs -> p >>= \ x -> return (x:xs)
-
-zipWithL :: (Monad m) => (a -> b -> m c) -> [a] -> [b] -> m [c]
-zipWithL f xs ys = accumulateL (zipWith f xs ys)
-
-zipWithR :: (Monad m) => (a -> b -> m c) -> [a] -> [b] -> m [c]
-zipWithR f xs ys = accumulateR (zipWith f xs ys)
-
-sequenceL :: (Monad m) => [m a] -> m ()
-sequenceL [] = return ()
-sequenceL (x:xs) = x >> sequenceL xs
-
-sequenceR :: (Monad m) => [m a] -> m ()
-sequenceR [] = return ()
-sequenceR (x:xs) = sequenceR xs >> x >> return ()
-
-mapL :: (Monad m) => (a -> m b) -> ([a] -> m [b])
-mapL f [] = return []
-mapL f (x:xs) = f x >>= \ y -> mapL f xs >>= \ ys -> return (y:ys)
-
-mapR :: (Monad m) => (a -> m b) -> ([a] -> m [b])
-mapR f [] = return []
-mapR f (x:xs) = mapR f xs >>= \ ys -> f x >>= \ y -> return (y:ys)
-
-map_ :: (Monad m) => (a -> m b) -> ([a] -> m ())
-map_ f [] = return ()
-map_ f (x:xs) = f x >> map_ f xs
-
-foldL :: (Monad m) => (a -> b -> m a) -> a -> [b] -> m a
-foldL f a [] = return a
-foldL f a (x:xs) = f a x >>= \fax -> foldL f fax xs
-
-foldR :: (Monad m) => (a -> b -> m b) -> b -> [a] -> m b
-foldR f a [] = return a
-foldR f a (x:xs) = foldR f a xs >>= \y -> f x y
-
-concatM :: MonadPlus m => [m a] -> m a
-concatM = foldr (++) zero
-
-done :: (Monad m) => m ()
-done = return ()
-
-unless :: (Monad m) => Bool -> m () -> m ()
-unless p s = if p then return () else s
-
-when :: (Monad m) => Bool -> m () -> m ()
-when p s = if p then s else return ()
--- /dev/null
+%
+% (c) The AQUA Project, Glasgow University, 1994-1996
+%
+
+\section[Monad]{Module @Monad@}
+
+\begin{code}
+module Monad (
+ Functor(..), Monad(..), MonadZero(..), MonadPlus(..),
+
+ -- Prelude monad functions
+ accumulate, sequence, mapM, mapM_, guard, filter, concat, applyM,
+
+ -- Other monad functions
+ join, mapAndUnzipM, zipWithM, foldM, when, unless, ap, unless, when,
+ liftM, liftM2, liftM3, liftM4, liftM5
+ ) where
+
+import Prelude ()
+import PrelList
+import PrelTup
+import PrelBase
+\end{code}
+
+%*********************************************************
+%* *
+\subsection{Functions mandated by the Prelude}
+%* *
+%*********************************************************
+
+\begin{code}
+accumulate :: Monad m => [m a] -> m [a]
+accumulate [] = return []
+accumulate (m:ms) = do { x <- m; xs <- accumulate ms; return (x:xs) }
+
+sequence :: Monad m => [m a] -> m ()
+sequence = foldr (>>) (return ())
+
+mapM :: Monad m => (a -> m b) -> [a] -> m [b]
+mapM f as = accumulate (map f as)
+
+mapM_ :: Monad m => (a -> m b) -> [a] -> m ()
+mapM_ f as = sequence (map f as)
+
+guard :: MonadZero m => Bool -> m ()
+guard p = if p then return () else zero
+
+-- This subsumes the list-based filter function.
+
+filter :: MonadZero m => (a -> Bool) -> m a -> m a
+filter p = applyM (\x -> if p x then return x else zero)
+
+-- This subsumes the list-based concat function.
+
+concat :: MonadPlus m => [m a] -> m a
+concat = foldr (++) zero
+
+applyM :: Monad m => (a -> m b) -> m a -> m b
+applyM f x = x >>= f
+\end{code}
+
+
+%*********************************************************
+%* *
+\subsection{Other monad functions}
+%* *
+%*********************************************************
+
+\begin{code}
+join :: (Monad m) => m (m a) -> m a
+join x = x >>= id
+
+mapAndUnzipM :: (Monad m) => (a -> m (b,c)) -> [a] -> m ([b], [c])
+mapAndUnzipM f xs = accumulate (map f xs) >>= return . unzip
+
+zipWithM :: (Monad m) => (a -> b -> m c) -> [a] -> [b] -> m [c]
+zipWithM f xs ys = accumulate (zipWith f xs ys)
+
+foldM :: (Monad m) => (a -> b -> m a) -> a -> [b] -> m a
+foldM f a [] = return a
+foldM f a (x:xs) = f a x >>= \fax -> foldM f fax xs
+
+unless :: (Monad m) => Bool -> m () -> m ()
+unless p s = if p then return () else s
+
+when :: (Monad m) => Bool -> m () -> m ()
+when p s = if p then s else return ()
+
+liftM :: (Monad m) => (a1 -> r) -> m a1 -> m r
+liftM2 :: (Monad m) => (a1 -> a2 -> r) -> m a1 -> m a2 -> m r
+liftM3 :: (Monad m) => (a1 -> a2 -> a3 -> r) -> m a1 -> m a2 -> m a3 -> m r
+liftM4 :: (Monad m) => (a1 -> a2 -> a3 -> a4 -> r) -> m a1 -> m a2 -> m a3 -> m a4 -> m r
+liftM5 :: (Monad m) => (a1 -> a2 -> a3 -> a4 -> a5 -> r) -> m a1 -> m a2 -> m a3 -> m a4 -> m a5 -> m r
+
+liftM f m1 = do { x1 <- m1; return (f x1) }
+liftM2 f m1 m2 = do { x1 <- m1; x2 <- m2; return (f x1 x2) }
+liftM3 f m1 m2 m3 = do { x1 <- m1; x2 <- m2; x3 <- m3; return (f x1 x2 x3) }
+liftM4 f m1 m2 m3 m4 = do { x1 <- m1; x2 <- m2; x3 <- m3; x4 <- m4; return (f x1 x2 x3 x4) }
+liftM5 f m1 m2 m3 m4 m5 = do { x1 <- m1; x2 <- m2; x3 <- m3; x4 <- m4; x5 <- m5; return (f x1 x2 x3 x4 x5) }
+
+ap :: (Monad m) => m (a->b) -> m a -> m b
+ap = liftM2 ($)
+
+\end{code}
--- /dev/null
+
+\begin{code}
+module Prelude (
+
+ -- Everything from these modules
+ module PrelList,
+ module PrelIO,
+ module PrelTup,
+
+ -- From PrelBase
+ Eq(..),
+ Ord(..), Ordering(..),
+ Bounded(..),
+ Enum(..), succ, pred,
+ Show(..), ShowS, shows, show, showChar, showString, showParen,
+ Num(..),
+ Eval(..), seq, strict,
+ Bool(..), (&&), (||), not, otherwise,
+ Char, String, Int, Integer, Float, Double,
+ Maybe(..),
+ Either(..), either,
+ ()(..), -- The unit type
+
+
+ id, const, (.), flip, ($), until, asTypeOf, undefined,
+
+ -- From IOBase
+ error,
+
+ -- From Monad
+ Functor(..), Monad(..), MonadZero(..), MonadPlus(..),
+ accumulate, sequence, mapM, mapM_, guard, filter, concat, applyM,
+
+ -- From Maybe
+ maybe,
+
+ -- From PrelRead
+ ReadS, Read(readsPrec, readList),
+ reads, read, lex, readParen,
+
+ -- From PrelShow
+
+ -- From PrelNum
+ Ratio, Rational,
+ (%), numerator, denominator, approxRational,
+
+ Num((+), (-), (*), negate, abs, signum, fromInteger),
+ Real(toRational),
+ Integral(quot, rem, div, mod, quotRem, divMod, toInteger, toInt{-partain-}),
+ Fractional((/), recip, fromRational),
+ Floating(pi, exp, log, sqrt, (**), logBase, sin, cos, tan,
+ asin, acos, atan, sinh, cosh, tanh, asinh, acosh, atanh),
+ RealFrac(properFraction, truncate, round, ceiling, floor),
+ RealFloat(floatRadix, floatDigits, floatRange, decodeFloat,
+ encodeFloat, exponent, significand, scaleFloat, isNaN,
+ isInfinite, isDenormalized, isIEEE, isNegativeZero),
+ subtract, even, odd, gcd, lcm, (^), (^^),
+ fromIntegral, fromRealFrac, atan2
+ ) where
+
+import PrelBase
+import PrelList
+import PrelIO
+import PrelRead
+import PrelNum
+import PrelTup
+import Monad
+import Maybe
+import IOBase ( error )
+
+-- These can't conveniently be defined in PrelBase because they use numbers,
+-- or I/O, so here's a convenient place to do them.
+
+strict :: Eval a => (a -> b) -> a -> b
+strict f x = x `seq` f x
+
+{-# INLINE seq #-}
+#ifdef __CONCURRENT_HASKELL__
+seq x y = case (seq# x) of { 0# -> parError; _ -> y }
+#else
+seq x y = y -- WRONG!
+#endif
+
+-- It is expected that compilers will recognize this and insert error
+-- messages which are more appropriate to the context in which undefined
+-- appears.
+
+undefined :: a
+undefined = error "Prelude.undefined"
+\end{code}
+
+
+
+++ /dev/null
--- Standard functions on rational numbers
-
-module Ratio (
- Ratio, Rational, (%), numerator, denominator, approxRational ) where
-
-infixl 7 %
---partain:infixl 7 :%
-
-prec = 7
-
-data (Integral a) => Ratio a = a :% a deriving (Eq)
-type Rational = Ratio Integer
-
-(%) :: (Integral a) => a -> a -> Ratio a
-numerator, denominator :: (Integral a) => Ratio a -> a
-approxRational :: (RealFrac a) => a -> a -> Rational
-
-
-reduce _ 0 = error "{Ratio.%}: zero denominator"
-reduce x y = (x `quot` d) :% (y `quot` d)
- where d = gcd x y
-
-x % y = reduce (x * signum y) (abs y)
-
-numerator (x:%y) = x
-
-denominator (x:%y) = y
-
-
-instance (Integral a) => Ord (Ratio a) where
- (x:%y) <= (x':%y') = x * y' <= x' * y
- (x:%y) < (x':%y') = x * y' < x' * y
-
-instance (Integral a) => Num (Ratio a) where
- (x:%y) + (x':%y') = reduce (x*y' + x'*y) (y*y')
- (x:%y) * (x':%y') = reduce (x * x') (y * y')
- negate (x:%y) = (-x) :% y
- abs (x:%y) = abs x :% y
- signum (x:%y) = signum x :% 1
- fromInteger x = fromInteger x :% 1
-
-instance (Integral a) => Real (Ratio a) where
- toRational (x:%y) = toInteger x :% toInteger y
-
-instance (Integral a) => Fractional (Ratio a) where
- (x:%y) / (x':%y') = (x*y') % (y*x')
- recip (x:%y) = if x < 0 then (-y) :% (-x) else y :% x
- fromRational (x:%y) = fromInteger x :% fromInteger y
-
-instance (Integral a) => RealFrac (Ratio a) where
- properFraction (x:%y) = (fromIntegral q, r:%y)
- where (q,r) = quotRem x y
-
-instance (Integral a) => Enum (Ratio a) where
- enumFrom = iterate ((+)1)
- enumFromThen n m = iterate ((+)(m-n)) n
- toEnum n = fromIntegral n :% 1
- fromEnum = fromInteger . truncate
-
-instance (Integral a, Read a) => Read (Ratio a) where
- readsPrec p = readParen (p > prec)
- (\r -> [(x%y,u) | (x,s) <- reads r,
- ("%",t) <- lex s,
- (y,u) <- reads t ])
-
-instance (Integral a) => Show (Ratio a) where
- showsPrec p (x:%y) = showParen (p > prec)
- (shows x . showString " % " . shows y)
-
-
--- approxRational, applied to two real fractional numbers x and epsilon,
--- returns the simplest rational number within epsilon of x. A rational
--- number n%d in reduced form is said to be simpler than another n'%d' if
--- abs n <= abs n' && d <= d'. Any real interval contains a unique
--- simplest rational; here, for simplicity, we assume a closed rational
--- interval. If such an interval includes at least one whole number, then
--- the simplest rational is the absolutely least whole number. Otherwise,
--- the bounds are of the form q%1 + r%d and q%1 + r'%d', where abs r < d
--- and abs r' < d', and the simplest rational is q%1 + the reciprocal of
--- the simplest rational between d'%r' and d%r.
-
-approxRational x eps = simplest (x-eps) (x+eps)
- where simplest x y | y < x = simplest y x
- | x == y = xr
- | x > 0 = simplest' n d n' d'
- | y < 0 = - simplest' (-n') d' (-n) d
- | otherwise = 0 :% 1
- where xr@(n:%d) = toRational x
- (n':%d') = toRational y
-
- simplest' n d n' d' -- assumes 0 < n%d < n'%d'
- | r == 0 = q :% 1
- | q /= q' = (q+1) :% 1
- | otherwise = (q*n''+d'') :% n''
- where (q,r) = quotRem n d
- (q',r') = quotRem n' d'
- (n'':%d'') = simplest' d' r' d r
--- /dev/null
+%
+% (c) The AQUA Project, Glasgow University, 1994-1996
+%
+
+\section[Ratio]{Module @Ratio@}
+
+Standard functions on rational numbers
+
+\begin{code}
+module Ratio (
+ Ratio, Rational, (%), numerator, denominator, approxRational
+ ) where
+
+import Prelude ()
+import PrelNum
+\end{code}
+
+
-{-
%
-% (c) The GRASP/AQUA Project, Glasgow University, 1995
+% (c) The AQUA Project, Glasgow University, 1994-1996
%
-\section[LibSystem]{Haskell 1.3 System Interaction}
--}
+
+\section[System]{Module @System@}
+
+\begin{code}
module System (
ExitCode(ExitSuccess,ExitFailure),
- getArgs, getProgName, getEnv, system, exitWith ) where
+ getArgs, getProgName, getEnv, system, exitWith
+ ) where
+
+import Foreign ( Addr )
+import IOBase ( IOError(..), thenIO_Prim, constructErrorAndFail )
+import ArrBase ( indexAddrOffAddr )
+import PackedString ( unpackCString )
+\end{code}
-import GHCio
-import GHCps ( unpackPS, packCString )
-import GHCbase ( indexAddrOffAddr, Addr )
+%*********************************************************
+%* *
+\subsection{The @ExitCode@ type}
+%* *
+%*********************************************************
-{-
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}
data ExitCode = ExitSuccess | ExitFailure Int
deriving (Eq, Ord, Read, Show)
+\end{code}
+
+%*********************************************************
+%* *
+\subsection{Other functions}
+%* *
+%*********************************************************
+
+\begin{code}
getArgs :: IO [String]
getProgName :: IO String
getEnv :: String -> IO String
system :: String -> IO ExitCode
exitWith :: ExitCode -> IO a
+\end{code}
-{-
Computation $getArgs$ returns a list of the program's command
line arguments (not including the program name).
--}
+
+\begin{code}
getArgs = return (unpackArgv ``prog_argv'' (``prog_argc''::Int))
+\end{code}
-{-
Computation $getProgName$ returns the name of the program
as it was invoked.
--}
+
+\begin{code}
getProgName = return (unpackProgName ``prog_argv'')
+\end{code}
-{-
Computation $getEnv var$ returns the value
of the environment variable {\em var}.
\item $NoSuchThing$
The environment variable does not exist.
\end{itemize}
--}
+
+\begin{code}
getEnv name =
- _ccall_ getenv name `stThen` \ litstring ->
+ _ccall_ getenv name `thenIO_Prim` \ litstring ->
if litstring /= ``NULL'' then
- return (unpackPS (packCString litstring)) -- cheaper than it looks
+ return (unpackCString litstring)
else
fail (NoSuchThing ("environment variable: " ++ name))
+\end{code}
-{-
Computation $system cmd$ returns the exit code
produced when the operating system processes the command {\em cmd}.
\item $UnsupportedOperation$
The implementation does not support system calls.
\end{itemize}
--}
+
+\begin{code}
system "" = fail (InvalidArgument "null command")
system cmd =
- _ccall_ systemCmd cmd `stThen` \ status ->
+ _ccall_ systemCmd cmd `thenIO_Prim` \ status ->
case status of
0 -> return ExitSuccess
-1 -> constructErrorAndFail "system"
n -> return (ExitFailure n)
-{-
+\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.
--}
+
+\begin{code}
exitWith ExitSuccess =
- _ccall_ EXIT (0::Int) `stThen` \ () ->
+ _ccall_ EXIT (0::Int) `thenIO_Prim` \ () ->
fail (OtherError "exit should not return")
exitWith (ExitFailure n)
| n == 0 = fail (InvalidArgument "ExitFailure 0")
| otherwise =
- _ccall_ EXIT n `stThen` \ () ->
+ _ccall_ EXIT n `thenIO_Prim` \ () ->
fail (OtherError "exit should not return")
+\end{code}
+
-------------------------------------------
--- like unpackCString ...
+%*********************************************************
+%* *
+\subsection{Local utilities}
+%* *
+%*********************************************************
+\begin{code}
type CHAR_STAR_STAR = Addr -- this is all a HACK
type CHAR_STAR = Addr
= if (n >= argc)
then ([] :: [String])
else case (indexAddrOffAddr argv n) of { item ->
- unpackPS (packCString item) : unpack (n + 1) }
+ unpackCString item : unpack (n + 1) }
unpackProgName argv
= case (indexAddrOffAddr argv 0) of { prog ->
- de_slash [] (unpackPS (packCString prog)) }
+ de_slash [] (unpackCString 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}
projects / ghc-hetmet.git / commitdiff