Adding in support for split Hugs Prelude.
There are now two preludes.
(1) PrimPrel - the Prelude defintions, and the extra magic datatypes.
(2) Prelude - the external interface for Prelude.
* included in the distribution.
*
* $RCSfile: connect.h,v $
- * $Revision: 1.33 $
- * $Date: 2000/03/24 14:32:03 $
+ * $Revision: 1.34 $
+ * $Date: 2000/04/04 01:07:49 $
* ------------------------------------------------------------------------*/
/* --------------------------------------------------------------------------
* Texts, Names, Instances, Classes, Types, Kinds and Modules
* ------------------------------------------------------------------------*/
+extern Text textPrimPrel;
extern Text textPrelude;
extern Text textNum; /* used to process default decls */
extern Text textCcall; /* used to process foreign import */
extern Type typeIO;
extern Type typeException;
-
+extern Module modulePrimPrel;
extern Module modulePrelude;
-
extern Kind starToStar; /* Type -> Type */
* included in the distribution.
*
* $RCSfile: hugs.c,v $
- * $Revision: 1.52 $
- * $Date: 2000/03/31 04:13:27 $
+ * $Revision: 1.53 $
+ * $Date: 2000/04/04 01:07:49 $
* ------------------------------------------------------------------------*/
#include <setjmp.h>
for (u = module(mod).uses; nonNull(u); u=tl(u))
usesT = cons(textOf(hd(u)),usesT);
/* artifically give all modules a dependency on Prelude */
- if (mT != textPrelude)
+#if 0
+ if (mT != textPrelude && mT != textPrimPrel)
usesT = cons(textPrelude,usesT);
+#endif
adjList = cons(pair(mT,usesT),adjList);
}
achieveTargetModules();
ok = elemMG(conPrelude) && elemMG(conPrelHugs);
} else {
- conPrelude = mkCon(findText("Prelude"));
- targetModules = singleton(conPrelude);
+ conPrelude = mkCon(findText("PrimPrel"));
+ conPrelHugs = mkCon(findText("Prelude"));
+ targetModules = doubleton(conPrelude,conPrelHugs);
achieveTargetModules();
ok = elemMG(conPrelude);
}
module(evalMod).tycons = module(currentModule).tycons;
module(evalMod).classes = module(currentModule).classes;
module(evalMod).qualImports
- = singleton(pair(mkCon(textPrelude),modulePrelude));
+ = singleton(pair(mkCon(textPrelude),modulePrimPrel)); /* AJG Back to Prelude */
return evalMod;
}
* included in the distribution.
*
* $RCSfile: input.c,v $
- * $Revision: 1.24 $
- * $Date: 2000/03/24 14:32:03 $
+ * $Revision: 1.25 $
+ * $Date: 2000/04/04 01:07:49 $
* ------------------------------------------------------------------------*/
#include "hugsbasictypes.h"
Text textStdcall; /* stdcall */
Text textNum; /* Num */
+Text textPrimPrel; /* PrimPrel */
Text textPrelude; /* Prelude */
Text textPlus; /* (+) */
textBang = findText("!");
textDot = findText(".");
textImplies = findText("=>");
+ textPrimPrel = findText("PrimPrel");
textPrelude = findText("Prelude");
textNum = findText("Num");
textModule = findText("module");
# -------------------------------------------------------------------------- #
-# $Id: Makefile,v 1.8 2000/03/20 04:26:23 andy Exp $
+# $Id: Makefile,v 1.9 2000/04/04 01:07:50 andy Exp $
# -------------------------------------------------------------------------- #
TOP = ../..
include $(TOP)/mk/boilerplate.mk
-PRELUDE = Prelude.hs
+PRELUDE = Prelude.hs PrimPrel.hs
STD_LIBS = Array.lhs Char.lhs Complex.lhs CPUTime.lhs \
Directory.lhs IO.lhs Ix.lhs List.lhs Locale.lhs \
* included in the distribution.
*
* $RCSfile: link.c,v $
- * $Revision: 1.54 $
- * $Date: 2000/03/23 14:54:21 $
+ * $Revision: 1.55 $
+ * $Date: 2000/04/04 01:07:49 $
* ------------------------------------------------------------------------*/
#include "hugsbasictypes.h"
Name nameMult;
Name nameMFail;
Type typeOrdering;
+Module modulePrimPrel;
Module modulePrelude;
Name nameMap;
Name nameMinus;
-
/* --------------------------------------------------------------------------
* Frequently used type skeletons:
* ------------------------------------------------------------------------*/
if (!initialised) {
Int i;
initialised = TRUE;
- setCurrModule(modulePrelude);
+ if (combined) {
+ setCurrModule(modulePrelude);
+ } else {
+ setCurrModule(modulePrimPrel);
+ }
typeChar = linkTycon("Char");
typeInt = linkTycon("Int");
Int i;
initialised = TRUE;
- setCurrModule(modulePrelude);
+ if (combined) {
+ setCurrModule(modulePrelude);
+ } else {
+ setCurrModule(modulePrimPrel);
+ }
/* constructors */
nameFalse = linkName("False");
if (!initialised) {
initialised = TRUE;
- setCurrModule(modulePrelude);
+ if (combined) {
+ setCurrModule(modulePrelude);
+ } else {
+ setCurrModule(modulePrimPrel);
+ }
/* primops */
nameMkIO = linkName("hugsprimMkIO");
Module modulePrelBase = findModule(findText("PrelBase"));
assert(nonNull(modulePrelBase));
/* fprintf(stderr, "linkControl(POSTPREL)\n"); */
- setCurrModule(modulePrelude);
+ setCurrModule(modulePrelude);
linkPreludeTC();
linkPreludeCM();
linkPrimNames();
name(nm).mod = findModule(findText("PrelErr"));
name(nm).text = findText("error");
setCurrModule(modulePrelude);
- module(modulePrelude).exports
+ module(modulePrimPrel).exports
= cons ( nm, module(modulePrelude).exports );
/* The GHC prelude doesn't seem to export Addr. Add it to the
// = addWiredInBoxingTycon("PrelConc","ThreadId","ThreadId#"
// ,1,0,THREADID_REP);
- setCurrModule(modulePrelude);
+ setCurrModule(modulePrimPrel);
typeArrow = addPrimTycon(findText("(->)"),
pair(STAR,pair(STAR,STAR)),
} else {
fixupRTStoPreludeRefs(NULL);
- modulePrelude = //newModule(textPrelude);
- findFakeModule(textPrelude);
- setCurrModule(modulePrelude);
+ modulePrimPrel = findFakeModule(textPrimPrel);
+ modulePrelude = findFakeModule(textPrelude);
+ setCurrModule(modulePrimPrel);
for (i=0; i<NUM_TUPLES; ++i) {
if (i != 1) addTupleTycon(i);
}
- setCurrModule(modulePrelude);
+ setCurrModule(modulePrimPrel);
typeArrow = addPrimTycon(findText("(->)"),
pair(STAR,pair(STAR,STAR)),
* included in the distribution.
*
* $RCSfile: static.c,v $
- * $Revision: 1.33 $
- * $Date: 2000/03/31 04:13:27 $
+ * $Revision: 1.34 $
+ * $Date: 2000/04/04 01:07:49 $
* ------------------------------------------------------------------------*/
#include "hugsbasictypes.h"
mapProc(checkQualImport, module(thisModule).qualImports);
mapProc(checkUnqualImport,unqualImports);
/* Add "import Prelude" if there`s no explicit import */
- if (thisModule!=modulePrelude
- && isNull(cellAssoc(modulePrelude,unqualImports))
- && isNull(cellRevAssoc(modulePrelude,module(thisModule).qualImports))) {
- unqualImports = cons(pair(modulePrelude,DOTDOT),unqualImports);
+#if 0
+ if (thisModule==modulePrelude || thisModule == modulePrelude2) {
+ /* Nothing. */
+ } else if (isNull(cellAssoc(modulePrelude,unqualImports))
+ && isNull(cellRevAssoc(modulePrelude,module(thisModule).qualImports))) {
+ unqualImports = cons(pair(modulePrelude,DOTDOT),unqualImports);
} else {
- /* Every module (including the Prelude) implicitly contains
- * "import qualified Prelude"
- */
- module(thisModule).qualImports
- =cons(pair(mkCon(textPrelude),modulePrelude),
- module(thisModule).qualImports);
+ /* Every module (including the Prelude) implicitly contains
+ * "import qualified Prelude"
+ */
+ module(thisModule).qualImports
+ =cons(pair(mkCon(textPrelude),modulePrelude),
+ module(thisModule).qualImports);
}
+#endif
mapProc(checkImportList, unqualImports);
/* Note: there's a lot of side-effecting going on here, so
* included in the distribution.
*
* $RCSfile: storage.c,v $
- * $Revision: 1.58 $
- * $Date: 2000/04/03 23:43:13 $
+ * $Revision: 1.59 $
+ * $Date: 2000/04/04 01:07:49 $
* ------------------------------------------------------------------------*/
#include "hugsbasictypes.h"
if (combined)
m = findFakeModule(findText(n==0 ? "PrelBase" : "PrelTup")); else
- m = findModule(findText("Prelude"));
+ m = findModule(findText("PrimPrel"));
setCurrModule(m);
k = STAR;
Module m; {
Int i;
assert(isModule(m));
- /* fprintf(stderr, "SET CURR MODULE %s %d\n", textToStr(module(m).text),m);*/
+ /* fprintf(stderr, "SET CURR MODULE %s %d\n", textToStr(module(m).text),m); */
{List t;
for (t = module(m).names; nonNull(t); t=tl(t))
assert(isName(hd(t)));
* included in the distribution.
*
* $RCSfile: type.c,v $
- * $Revision: 1.31 $
- * $Date: 2000/03/23 14:54:21 $
+ * $Revision: 1.32 $
+ * $Date: 2000/04/04 01:07:49 $
* ------------------------------------------------------------------------*/
#include "hugsbasictypes.h"
} else {
dummyVar = inventVar();
- setCurrModule(modulePrelude);
+ setCurrModule(modulePrimPrel);
starToStar = simpleKind(1);
-{----------------------------------------------------------------------------
-__ __ __ __ ____ ___ _______________________________________________
-|| || || || || || ||__ Hugs 98: The Nottingham and Yale Haskell system
-||___|| ||__|| ||__|| __|| Copyright (c) 1994-1999
-||---|| ___|| World Wide Web: http://haskell.org/hugs
-|| || Report bugs to: hugs-bugs@haskell.org
-|| || Version: STG Hugs _______________________________________________
-
- This is the Hugs 98 Standard Prelude, based very closely on the Standard
- Prelude for Haskell 98.
-
+{-
WARNING: This file is an integral part of the Hugs source code. Changes to
the definitions in this file without corresponding modifications in other
parts of the program may cause the interpreter to fail unexpectedly. Under
normal circumstances, you should not attempt to modify this file in any way!
-
------------------------------------------------------------------------------
- Hugs 98 is Copyright (c) Mark P Jones, Alastair Reid and the Yale Haskell
- Group 1994-99, and is distributed as Open Source software under the
- Artistic License; see the file "Artistic" that is included in the
- distribution for details.
----------------------------------------------------------------------------}
module Prelude (
fst, snd, curry, uncurry, id, const, (.), flip, ($), until,
asTypeOf, error, undefined,
seq, ($!)
-
+ -- Now we have the extra (non standard) thing.
) where
--- Standard value bindings {Prelude} ----------------------------------------
-
-infixr 9 .
-infixl 9 !!
-infixr 8 ^, ^^, **
-infixl 7 *, /, `quot`, `rem`, `div`, `mod`, :%, %
-infixl 6 +, -
---infixr 5 : -- this fixity declaration is hard-wired into Hugs
-infixr 5 ++
-infix 4 ==, /=, <, <=, >=, >, `elem`, `notElem`
-infixr 3 &&
-infixr 2 ||
-infixl 1 >>, >>=
-infixr 1 =<<
-infixr 0 $, $!, `seq`
-
--- Equality and Ordered classes ---------------------------------------------
-
-class Eq a where
- (==), (/=) :: a -> a -> Bool
-
- -- Minimal complete definition: (==) or (/=)
- x == y = not (x/=y)
- x /= y = not (x==y)
-
-class (Eq a) => Ord a where
- compare :: a -> a -> Ordering
- (<), (<=), (>=), (>) :: a -> a -> Bool
- max, min :: a -> a -> a
-
- -- Minimal complete definition: (<=) or compare
- -- 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 | x >= y = x
- | otherwise = y
- min x y | x <= y = x
- | otherwise = y
-
-class Bounded a where
- minBound, maxBound :: a
- -- Minimal complete definition: All
-
--- Numeric classes ----------------------------------------------------------
-
-class (Eq a, Show a) => Num a where
- (+), (-), (*) :: a -> a -> a
- negate :: a -> a
- abs, signum :: a -> a
- fromInteger :: Integer -> a
- fromInt :: Int -> a
-
- -- Minimal complete definition: All, except negate or (-)
- x - y = x + negate y
- fromInt = fromIntegral
- negate x = 0 - x
-
-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)
- even, odd :: a -> Bool
- toInteger :: a -> Integer
- toInt :: a -> Int
-
- -- Minimal complete definition: quotRem and toInteger
- 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 == - signum d then (q-1, r+d) else qr
- where qr@(q,r) = quotRem n d
- even n = n `rem` 2 == 0
- odd = not . even
- toInt = toInt . toInteger
-
-class (Num a) => Fractional a where
- (/) :: a -> a -> a
- recip :: a -> a
- fromRational :: Rational -> a
-
- -- Minimal complete definition: fromRational and ((/) or recip)
- recip x = 1 / x
- x / y = x * recip y
-
-fromDouble :: Fractional a => Double -> a
-fromDouble n = fromRational (toRational n)
-
-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
-
- -- Minimal complete definition: pi, exp, log, sin, cos, sinh, cosh,
- -- asinh, acosh, atanh
- x ** y = exp (log x * y)
- logBase x y = log y / log x
- sqrt x = x ** 0.5
- tan x = sin x / cos x
- sinh x = (exp x - exp (-x)) / 2
- cosh x = (exp x + exp (-x)) / 2
- tanh x = sinh x / cosh x
- asinh x = log (x + sqrt (x*x + 1))
- acosh x = log (x + sqrt (x*x - 1))
- atanh x = (log (1 + x) - log (1 - x)) / 2
-
-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
-
- -- Minimal complete definition: properFraction
- 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
- atan2 :: a -> a -> a
-
- -- Minimal complete definition: All, except exponent, signficand,
- -- scaleFloat, atan2
- exponent x = if m==0 then 0 else n + floatDigits x
- where (m,n) = decodeFloat x
- significand x = encodeFloat m (- floatDigits x)
- where (m,_) = decodeFloat x
- scaleFloat k x = encodeFloat m (n+k)
- where (m,n) = decodeFloat x
- atan2 y x
- | x>0 = atan (y/x)
- | x==0 && y>0 = pi/2
- | x<0 && y>0 = pi + atan (y/x)
- | (x<=0 && y<0) ||
- (x<0 && isNegativeZero y) ||
- (isNegativeZero x && isNegativeZero y)
- = - atan2 (-y) x
- | y==0 && (x<0 || isNegativeZero x)
- = pi -- must be after the previous test on zero y
- | x==0 && y==0 = y -- must be after the other double zero tests
- | otherwise = x + y -- x or y is a NaN, return a NaN (via +)
-
--- Numeric functions --------------------------------------------------------
-
-subtract :: Num a => a -> a -> a
-subtract = flip (-)
-
-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)
-
-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^(-n))
-
-fromIntegral :: (Integral a, Num b) => a -> b
-fromIntegral = fromInteger . toInteger
-
-realToFrac :: (Real a, Fractional b) => a -> b
-realToFrac = fromRational . toRational
-
--- Index and Enumeration classes --------------------------------------------
-
-class (Ord a) => Ix a where
- range :: (a,a) -> [a]
- index :: (a,a) -> a -> Int
- inRange :: (a,a) -> a -> Bool
- rangeSize :: (a,a) -> Int
-
- rangeSize r@(l,u)
- | l > u = 0
- | otherwise = index r u + 1
-
-class Enum a where
- succ, pred :: a -> a
- toEnum :: Int -> a
- fromEnum :: a -> Int
- enumFrom :: a -> [a] -- [n..]
- enumFromThen :: a -> a -> [a] -- [n,m..]
- enumFromTo :: a -> a -> [a] -- [n..m]
- enumFromThenTo :: a -> a -> a -> [a] -- [n,n'..m]
-
- -- Minimal complete definition: toEnum, fromEnum
- succ = toEnum . (1+) . fromEnum
- pred = toEnum . subtract 1 . fromEnum
- enumFrom x = map toEnum [ fromEnum x .. ]
- enumFromTo x y = map toEnum [ fromEnum x .. fromEnum y ]
- enumFromThen x y = map toEnum [ fromEnum x, fromEnum y .. ]
- enumFromThenTo x y z = map toEnum [ fromEnum x, fromEnum y .. fromEnum z ]
-
--- Read and Show classes ------------------------------------------------------
-
-type ReadS a = String -> [(a,String)]
-type ShowS = String -> String
-
-class Read a where
- readsPrec :: Int -> ReadS a
- readList :: ReadS [a]
-
- -- Minimal complete definition: readsPrec
- readList = readParen False (\r -> [pr | ("[",s) <- lex r,
- pr <- readl s ])
- where readl s = [([],t) | ("]",t) <- lex s] ++
- [(x:xs,u) | (x,t) <- reads s,
- (xs,u) <- readl' t]
- readl' s = [([],t) | ("]",t) <- lex s] ++
- [(x:xs,v) | (",",t) <- lex s,
- (x,u) <- reads t,
- (xs,v) <- readl' u]
-
-class Show a where
- show :: a -> String
- showsPrec :: Int -> a -> ShowS
- showList :: [a] -> ShowS
-
- -- Minimal complete definition: show or showsPrec
- show x = showsPrec 0 x ""
- showsPrec _ x s = show x ++ s
- showList [] = showString "[]"
- showList (x:xs) = showChar '[' . shows x . showl xs
- where showl [] = showChar ']'
- showl (x:xs) = showChar ',' . shows x . showl xs
-
--- Monad classes ------------------------------------------------------------
-
-class Functor f where
- fmap :: (a -> b) -> (f a -> f b)
-
-class Monad m where
- return :: a -> m a
- (>>=) :: m a -> (a -> m b) -> m b
- (>>) :: m a -> m b -> m b
- fail :: String -> m a
-
- -- Minimal complete definition: (>>=), return
- p >> q = p >>= \ _ -> q
- fail s = error s
-
-sequence :: Monad m => [m a] -> m [a]
-sequence [] = return []
-sequence (c:cs) = do x <- c
- xs <- sequence cs
- return (x:xs)
-
-sequence_ :: Monad m => [m a] -> m ()
-sequence_ = foldr (>>) (return ())
-
-mapM :: Monad m => (a -> m b) -> [a] -> m [b]
-mapM f = sequence . map f
-
-mapM_ :: Monad m => (a -> m b) -> [a] -> m ()
-mapM_ f = sequence_ . map f
-
-(=<<) :: Monad m => (a -> m b) -> m a -> m b
-f =<< x = x >>= f
-
--- Evaluation and strictness ------------------------------------------------
-
-seq :: a -> b -> b
-seq x y = primSeq x y
-
-($!) :: (a -> b) -> a -> b
-f $! x = x `primSeq` f x
-
--- Trivial type -------------------------------------------------------------
-
--- data () = () deriving (Eq, Ord, Ix, Enum, Read, Show, Bounded)
-
-instance Eq () where
- () == () = True
-
-instance Ord () where
- compare () () = EQ
-
-instance Ix () where
- range ((),()) = [()]
- index ((),()) () = 0
- inRange ((),()) () = True
-
-instance Enum () where
- toEnum 0 = ()
- fromEnum () = 0
- enumFrom () = [()]
- enumFromThen () () = [()]
-
-instance Read () where
- readsPrec p = readParen False (\r -> [((),t) | ("(",s) <- lex r,
- (")",t) <- lex s ])
-
-instance Show () where
- showsPrec p () = showString "()"
-
-instance Bounded () where
- minBound = ()
- maxBound = ()
-
--- Boolean type -------------------------------------------------------------
-
-data Bool = False | True
- deriving (Eq, Ord, Ix, Enum, Read, Show, Bounded)
-
-(&&), (||) :: Bool -> Bool -> Bool
-False && x = False
-True && x = x
-False || x = x
-True || x = True
-
-not :: Bool -> Bool
-not True = False
-not False = True
-
-otherwise :: Bool
-otherwise = True
-
--- Character type -----------------------------------------------------------
-
-data Char -- builtin datatype of ISO Latin characters
-type String = [Char] -- strings are lists of characters
-
-instance Eq Char where (==) = primEqChar
-instance Ord Char where (<=) = primLeChar
-
-instance Enum Char where
- toEnum = primIntToChar
- fromEnum = primCharToInt
- enumFrom c = map toEnum [fromEnum c .. fromEnum (maxBound::Char)]
- enumFromThen c d = map toEnum [fromEnum c, fromEnum d .. fromEnum (lastChar::Char)]
- where lastChar = if d < c then minBound else maxBound
-
-instance Ix Char where
- range (c,c') = [c..c']
- index b@(c,c') ci
- | inRange b ci = fromEnum ci - fromEnum c
- | otherwise = error "Ix.index: Index out of range."
- inRange (c,c') ci = fromEnum c <= i && i <= fromEnum c'
- where i = fromEnum ci
-
-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 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
-
-instance Bounded Char where
- minBound = '\0'
- maxBound = '\255'
-
-isAscii, isControl, isPrint, isSpace :: Char -> Bool
-isUpper, isLower, isAlpha, isDigit, isAlphaNum :: Char -> Bool
-
-isAscii c = fromEnum c < 128
-isControl c = c < ' ' || c == '\DEL'
-isPrint c = c >= ' ' && c <= '~'
-isSpace c = c == ' ' || c == '\t' || c == '\n' ||
- c == '\r' || c == '\f' || c == '\v'
-isUpper c = c >= 'A' && c <= 'Z'
-isLower c = c >= 'a' && c <= 'z'
-isAlpha c = isUpper c || isLower c
-isDigit c = c >= '0' && c <= '9'
-isAlphaNum c = isAlpha c || isDigit c
-
--- Digit conversion operations
-digitToInt :: Char -> Int
-digitToInt c
- | isDigit c = fromEnum c - fromEnum '0'
- | c >= 'a' && c <= 'f' = fromEnum c - fromEnum 'a' + 10
- | c >= 'A' && c <= 'F' = fromEnum c - fromEnum 'A' + 10
- | otherwise = error "Char.digitToInt: not a digit"
-
-intToDigit :: Int -> Char
-intToDigit i
- | i >= 0 && i <= 9 = toEnum (fromEnum '0' + i)
- | i >= 10 && i <= 15 = toEnum (fromEnum 'a' + i - 10)
- | otherwise = error "Char.intToDigit: not a digit"
-
-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
-
-ord :: Char -> Int
-ord = fromEnum
-
-chr :: Int -> Char
-chr = toEnum
-
--- Maybe type ---------------------------------------------------------------
-
-data Maybe a = Nothing | Just a
- deriving (Eq, Ord, Read, Show)
-
-maybe :: b -> (a -> b) -> Maybe a -> b
-maybe n f Nothing = n
-maybe n f (Just x) = f x
-
-instance Functor Maybe where
- fmap f Nothing = Nothing
- fmap f (Just x) = Just (f x)
-
-instance Monad Maybe where
- Just x >>= k = k x
- Nothing >>= k = Nothing
- return = Just
- fail s = Nothing
-
--- Either type --------------------------------------------------------------
-
-data Either a b = Left a | Right b
- deriving (Eq, Ord, Read, Show)
-
-either :: (a -> c) -> (b -> c) -> Either a b -> c
-either l r (Left x) = l x
-either l r (Right y) = r y
-
--- Ordering type ------------------------------------------------------------
-
-data Ordering = LT | EQ | GT
- deriving (Eq, Ord, Ix, Enum, Read, Show, Bounded)
-
--- Lists --------------------------------------------------------------------
-
---data [a] = [] | a : [a] deriving (Eq, Ord)
-
-instance Eq a => Eq [a] where
- [] == [] = True
- (x:xs) == (y:ys) = x==y && xs==ys
- _ == _ = False
-
-instance Ord a => Ord [a] where
- compare [] (_:_) = LT
- compare [] [] = EQ
- compare (_:_) [] = GT
- compare (x:xs) (y:ys) = hugsprimCompAux x y (compare xs ys)
-
-instance Functor [] where
- fmap = map
-
-instance Monad [ ] where
- (x:xs) >>= f = f x ++ (xs >>= f)
- [] >>= f = []
- return x = [x]
- fail s = []
-
-instance Read a => Read [a] where
- readsPrec p = readList
-
-instance Show a => Show [a] where
- showsPrec p = showList
-
--- Tuples -------------------------------------------------------------------
-
--- data (a,b) = (a,b) deriving (Eq, Ord, Ix, Read, Show)
--- etc..
-
--- Standard Integral types --------------------------------------------------
-
-data Int -- builtin datatype of fixed size integers
-data Integer -- builtin datatype of arbitrary size integers
-
-instance Eq Integer where
- (==) x y = primCompareInteger x y == 0
-
-instance Ord Integer where
- compare x y = case primCompareInteger x y of
- -1 -> LT
- 0 -> EQ
- 1 -> GT
-
-instance Eq Int where
- (==) = primEqInt
- (/=) = primNeInt
-
-instance Ord Int where
- (<) = primLtInt
- (<=) = primLeInt
- (>=) = primGeInt
- (>) = primGtInt
-
-instance Num Int where
- (+) = primPlusInt
- (-) = primMinusInt
- negate = primNegateInt
- (*) = primTimesInt
- abs = absReal
- signum = signumReal
- fromInteger = primIntegerToInt
- fromInt x = x
-
-instance Bounded Int where
- minBound = primMinInt
- maxBound = primMaxInt
-
-instance Num Integer where
- (+) = primPlusInteger
- (-) = primMinusInteger
- negate = primNegateInteger
- (*) = primTimesInteger
- abs = absReal
- signum = signumReal
- fromInteger x = x
- fromInt = primIntToInteger
-
-absReal x | x >= 0 = x
- | otherwise = -x
-
-signumReal x | x == 0 = 0
- | x > 0 = 1
- | otherwise = -1
-
-instance Real Int where
- toRational x = toInteger x % 1
-
-instance Real Integer where
- toRational x = x % 1
-
-instance Integral Int where
- quotRem = primQuotRemInt
- toInteger = primIntToInteger
- toInt x = x
-
-instance Integral Integer where
- quotRem = primQuotRemInteger
- toInteger = id
- toInt = primIntegerToInt
-
-instance Ix Int where
- range (m,n) = [m..n]
- index b@(m,n) i
- | inRange b i = i - m
- | otherwise = error "index: Index out of range"
- inRange (m,n) i = m <= i && i <= n
-
-instance Ix Integer where
- range (m,n) = [m..n]
- index b@(m,n) i
- | inRange b i = fromInteger (i - m)
- | otherwise = error "index: Index out of range"
- inRange (m,n) i = m <= i && i <= n
-
-instance Enum Int where
- toEnum = id
- fromEnum = id
- enumFrom = numericEnumFrom
- enumFromTo = numericEnumFromTo
- enumFromThen = numericEnumFromThen
- enumFromThenTo = numericEnumFromThenTo
-
-instance Enum Integer where
- toEnum = primIntToInteger
- fromEnum = primIntegerToInt
- enumFrom = numericEnumFrom
- enumFromTo = numericEnumFromTo
- enumFromThen = numericEnumFromThen
- enumFromThenTo = numericEnumFromThenTo
-
-numericEnumFrom :: Real a => a -> [a]
-numericEnumFromThen :: Real a => a -> a -> [a]
-numericEnumFromTo :: Real a => a -> a -> [a]
-numericEnumFromThenTo :: Real a => a -> a -> a -> [a]
-numericEnumFrom n = n : (numericEnumFrom $! (n+1))
-numericEnumFromThen n m = iterate ((m-n)+) n
-numericEnumFromTo n m = takeWhile (<= m) (numericEnumFrom n)
-numericEnumFromThenTo n n' m = takeWhile p (numericEnumFromThen n n')
- where p | n' >= n = (<= m)
- | otherwise = (>= m)
-
-instance Read Int where
- readsPrec p = readSigned readDec
-
-instance Show Int where
- showsPrec p n
- | n == minBound = showSigned showInt p (toInteger n)
- | otherwise = showSigned showInt p n
-
-instance Read Integer where
- readsPrec p = readSigned readDec
-
-instance Show Integer where
- showsPrec = showSigned showInt
-
-
--- Standard Floating types --------------------------------------------------
-
-data Float -- builtin datatype of single precision floating point numbers
-data Double -- builtin datatype of double precision floating point numbers
-
-instance Eq Float where
- (==) = primEqFloat
- (/=) = primNeFloat
-
-instance Ord Float where
- (<) = primLtFloat
- (<=) = primLeFloat
- (>=) = primGeFloat
- (>) = primGtFloat
-
-instance Num Float where
- (+) = primPlusFloat
- (-) = primMinusFloat
- negate = primNegateFloat
- (*) = primTimesFloat
- abs = absReal
- signum = signumReal
- fromInteger = primIntegerToFloat
- fromInt = primIntToFloat
-
-
-
-instance Eq Double where
- (==) = primEqDouble
- (/=) = primNeDouble
-
-instance Ord Double where
- (<) = primLtDouble
- (<=) = primLeDouble
- (>=) = primGeDouble
- (>) = primGtDouble
-
-instance Num Double where
- (+) = primPlusDouble
- (-) = primMinusDouble
- negate = primNegateDouble
- (*) = primTimesDouble
- abs = absReal
- signum = signumReal
- fromInteger = primIntegerToDouble
- fromInt = primIntToDouble
-
-
-
-instance Real Float where
- toRational = floatToRational
-
-instance Real Double where
- toRational = doubleToRational
-
--- Calls to these functions are optimised when passed as arguments to
--- fromRational.
-floatToRational :: Float -> Rational
-doubleToRational :: Double -> Rational
-floatToRational x = realFloatToRational x
-doubleToRational x = realFloatToRational x
-
-realFloatToRational x = (m%1)*(b%1)^^n
- where (m,n) = decodeFloat x
- b = floatRadix x
-
-instance Fractional Float where
- (/) = primDivideFloat
- fromRational = rationalToRealFloat
-
-instance Fractional Double where
- (/) = primDivideDouble
- fromRational = rationalToRealFloat
-
-rationalToRealFloat x = x'
- where x' = f e
- f e = if e' == e then y else f e'
- where y = encodeFloat (round (x * (1%b)^^e)) e
- (_,e') = decodeFloat y
- (_,e) = decodeFloat (fromInteger (numerator x) `asTypeOf` x'
- / fromInteger (denominator x))
- b = floatRadix x'
-
-instance Floating Float where
- pi = 3.14159265358979323846
- exp = primExpFloat
- log = primLogFloat
- sqrt = primSqrtFloat
- sin = primSinFloat
- cos = primCosFloat
- tan = primTanFloat
- asin = primAsinFloat
- acos = primAcosFloat
- atan = primAtanFloat
-
-instance Floating Double where
- pi = 3.14159265358979323846
- exp = primExpDouble
- log = primLogDouble
- sqrt = primSqrtDouble
- sin = primSinDouble
- cos = primCosDouble
- tan = primTanDouble
- asin = primAsinDouble
- acos = primAcosDouble
- atan = primAtanDouble
-
-instance RealFrac Float where
- properFraction = floatProperFraction
-
-instance RealFrac Double where
- properFraction = floatProperFraction
-
-floatProperFraction x
- | n >= 0 = (fromInteger m * fromInteger b ^ n, 0)
- | otherwise = (fromInteger w, encodeFloat r n)
- where (m,n) = decodeFloat x
- b = floatRadix x
- (w,r) = quotRem m (b^(-n))
-
-instance RealFloat Float where
- floatRadix _ = toInteger primRadixFloat
- floatDigits _ = primDigitsFloat
- floatRange _ = (primMinExpFloat,primMaxExpFloat)
- encodeFloat = primEncodeFloatZ
- decodeFloat = primDecodeFloatZ
- isNaN = primIsNaNFloat
- isInfinite = primIsInfiniteFloat
- isDenormalized= primIsDenormalizedFloat
- isNegativeZero= primIsNegativeZeroFloat
- isIEEE = const primIsIEEEFloat
-
-instance RealFloat Double where
- floatRadix _ = toInteger primRadixDouble
- floatDigits _ = primDigitsDouble
- floatRange _ = (primMinExpDouble,primMaxExpDouble)
- encodeFloat = primEncodeDoubleZ
- decodeFloat = primDecodeDoubleZ
- isNaN = primIsNaNDouble
- isInfinite = primIsInfiniteDouble
- isDenormalized= primIsDenormalizedDouble
- isNegativeZero= primIsNegativeZeroDouble
- isIEEE = const primIsIEEEDouble
-
-instance Enum Float where
- toEnum = primIntToFloat
- fromEnum = truncate
- enumFrom = numericEnumFrom
- enumFromThen = numericEnumFromThen
- enumFromTo n m = numericEnumFromTo n (m+1/2)
- enumFromThenTo n n' m = numericEnumFromThenTo n n' (m + (n'-n)/2)
-
-instance Enum Double where
- toEnum = primIntToDouble
- fromEnum = truncate
- enumFrom = numericEnumFrom
- enumFromThen = numericEnumFromThen
- enumFromTo n m = numericEnumFromTo n (m+1/2)
- enumFromThenTo n n' m = numericEnumFromThenTo n n' (m + (n'-n)/2)
-
-instance Read Float where
- readsPrec p = readSigned readFloat
-
-instance Show Float where
- showsPrec p = showSigned showFloat p
-
-instance Read Double where
- readsPrec p = readSigned readFloat
-
-instance Show Double where
- showsPrec p = showSigned showFloat p
-
-
--- Some standard functions --------------------------------------------------
-
-fst :: (a,b) -> a
-fst (x,_) = x
-
-snd :: (a,b) -> b
-snd (_,y) = y
-
-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)
-
-id :: a -> a
-id x = x
-
-const :: a -> b -> a
-const k _ = k
-
-(.) :: (b -> c) -> (a -> b) -> (a -> c)
-(f . g) x = f (g x)
-
-flip :: (a -> b -> c) -> b -> a -> c
-flip f x y = f y x
-
-($) :: (a -> b) -> a -> b
-f $ x = f x
-
-until :: (a -> Bool) -> (a -> a) -> a -> a
-until p f x = if p x then x else until p f (f x)
-
-asTypeOf :: a -> a -> a
-asTypeOf = const
-
-error :: String -> a
-error msg = primRaise (ErrorCall msg)
-
-undefined :: a
-undefined | False = undefined
-
--- Standard functions on rational numbers {PreludeRatio} --------------------
-
-data Integral a => Ratio a = a :% a deriving (Eq)
-type Rational = Ratio Integer
-
-(%) :: Integral a => a -> a -> Ratio a
-x % y = reduce (x * signum y) (abs y)
-
-reduce :: Integral a => a -> a -> Ratio a
-reduce x y | y == 0 = error "Ratio.%: zero denominator"
- | otherwise = (x `quot` d) :% (y `quot` d)
- where d = gcd x y
-
-numerator, denominator :: Integral a => Ratio a -> a
-numerator (x :% y) = x
-denominator (x :% y) = y
-
-instance Integral a => Ord (Ratio a) where
- compare (x:%y) (x':%y') = compare (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) = negate x :% y
- abs (x :% y) = abs x :% y
- signum (x :% y) = signum x :% 1
- fromInteger x = fromInteger x :% 1
- fromInt = intToRatio
-
--- Hugs optimises code of the form fromRational (intToRatio x)
-intToRatio :: Integral a => Int -> Ratio a
-intToRatio x = fromInt 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
-
--- Hugs optimises code of the form fromRational (doubleToRatio x)
-doubleToRatio :: Integral a => Double -> Ratio a
-doubleToRatio x
- | n>=0 = (fromInteger m * fromInteger b ^ n) % 1
- | otherwise = fromInteger m % (fromInteger b ^ (-n))
- where (m,n) = decodeFloat x
- b = floatRadix x
-
-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
- toEnum = fromInt
- fromEnum = truncate
- enumFrom = numericEnumFrom
- enumFromThen = numericEnumFromThen
-
-instance (Read a, Integral a) => Read (Ratio a) where
- readsPrec p = readParen (p > 7)
- (\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 > 7)
- (shows x . showString " % " . shows y)
-
-approxRational :: RealFrac a => a -> a -> Rational
-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
-
--- Standard list functions {PreludeList} ------------------------------------
-
-head :: [a] -> a
-head (x:_) = x
-
-last :: [a] -> a
-last [x] = x
-last (_:xs) = last xs
-
-tail :: [a] -> [a]
-tail (_:xs) = xs
-
-init :: [a] -> [a]
-init [x] = []
-init (x:xs) = x : init xs
-
-null :: [a] -> Bool
-null [] = True
-null (_:_) = False
-
-(++) :: [a] -> [a] -> [a]
-[] ++ ys = ys
-(x:xs) ++ ys = x : (xs ++ ys)
-
-map :: (a -> b) -> [a] -> [b]
---map f xs = [ f x | x <- xs ]
-map f [] = []
-map f (x:xs) = f x : map f xs
-
-
-filter :: (a -> Bool) -> [a] -> [a]
---filter p xs = [ x | x <- xs, p x ]
-filter p [] = []
-filter p (x:xs) = if p x then x : filter p xs else filter p xs
-
-
-concat :: [[a]] -> [a]
---concat = foldr (++) []
-concat [] = []
-concat (xs:xss) = xs ++ concat xss
-
-length :: [a] -> Int
---length = foldl' (\n _ -> n + 1) 0
-length [] = 0
-length (x:xs) = let n = length xs in primSeq n (1+n)
-
-(!!) :: [b] -> Int -> b
-(x:_) !! 0 = x
-(_:xs) !! n | n>0 = xs !! (n-1)
-(_:_) !! _ = error "Prelude.!!: negative index"
-[] !! _ = error "Prelude.!!: index too large"
-
-foldl :: (a -> b -> a) -> a -> [b] -> a
-foldl f z [] = z
-foldl f z (x:xs) = foldl f (f z x) xs
-
-foldl' :: (a -> b -> a) -> a -> [b] -> a
-foldl' f a [] = a
-foldl' f a (x:xs) = (foldl' f $! f a x) xs
-
-foldl1 :: (a -> a -> a) -> [a] -> a
-foldl1 f (x:xs) = foldl f x xs
-
-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
-
-foldr :: (a -> b -> b) -> b -> [a] -> b
-foldr f z [] = z
-foldr f z (x:xs) = f x (foldr f z xs)
-
-foldr1 :: (a -> a -> a) -> [a] -> a
-foldr1 f [x] = x
-foldr1 f (x:xs) = f x (foldr1 f xs)
-
-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
-
-iterate :: (a -> a) -> a -> [a]
-iterate f x = x : iterate f (f x)
-
-repeat :: a -> [a]
-repeat x = xs where xs = x:xs
-
-replicate :: Int -> a -> [a]
-replicate n x = take n (repeat x)
-
-cycle :: [a] -> [a]
-cycle [] = error "Prelude.cycle: empty list"
-cycle xs = xs' where xs'=xs++xs'
-
-take :: Int -> [a] -> [a]
-take 0 _ = []
-take _ [] = []
-take n (x:xs) | n>0 = x : take (n-1) xs
-take _ _ = error "Prelude.take: negative argument"
-
-drop :: Int -> [a] -> [a]
-drop 0 xs = xs
-drop _ [] = []
-drop n (_:xs) | n>0 = drop (n-1) xs
-drop _ _ = error "Prelude.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 "Prelude.splitAt: negative argument"
-
-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
-
-span, break :: (a -> Bool) -> [a] -> ([a],[a])
-span p [] = ([],[])
-span p xs@(x:xs')
- | p x = (x:ys, zs)
- | otherwise = ([],xs)
- where (ys,zs) = span p xs'
-break p = span (not . p)
-
-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 isSpace s of
- "" -> []
- s' -> w : words s''
- where (w,s'') = break isSpace s'
-
-unlines :: [String] -> String
-unlines = concatMap (\l -> l ++ "\n")
-
-unwords :: [String] -> String
-unwords [] = []
-unwords ws = foldr1 (\w s -> w ++ ' ':s) ws
-
-reverse :: [a] -> [a]
---reverse = foldl (flip (:)) []
-reverse xs = ri [] xs
- where ri acc [] = acc
- ri acc (x:xs) = ri (x:acc) xs
-
-and, or :: [Bool] -> Bool
---and = foldr (&&) True
---or = foldr (||) False
-and [] = True
-and (x:xs) = if x then and xs else x
-or [] = False
-or (x:xs) = if x then x else or xs
-
-any, all :: (a -> Bool) -> [a] -> Bool
---any p = or . map p
---all p = and . map p
-any p [] = False
-any p (x:xs) = if p x then True else any p xs
-all p [] = True
-all p (x:xs) = if p x then all p xs else False
-
-elem, notElem :: Eq a => a -> [a] -> Bool
---elem = any . (==)
---notElem = all . (/=)
-elem x [] = False
-elem x (y:ys) = if x==y then True else elem x ys
-notElem x [] = True
-notElem x (y:ys) = if x==y then False else notElem x ys
-
-lookup :: Eq a => a -> [(a,b)] -> Maybe b
-lookup k [] = Nothing
-lookup k ((x,y):xys)
- | k==x = Just y
- | otherwise = lookup k xys
-
-sum, product :: Num a => [a] -> a
-sum = foldl' (+) 0
-product = foldl' (*) 1
-
-maximum, minimum :: Ord a => [a] -> a
-maximum = foldl1 max
-minimum = foldl1 min
-
-concatMap :: (a -> [b]) -> [a] -> [b]
-concatMap f = concat . map f
-
-zip :: [a] -> [b] -> [(a,b)]
-zip = zipWith (\a b -> (a,b))
-
-zip3 :: [a] -> [b] -> [c] -> [(a,b,c)]
-zip3 = zipWith3 (\a b c -> (a,b,c))
-
-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 :: [(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))
- ([],[],[])
-
--- PreludeText ----------------------------------------------------------------
-
-reads :: Read a => ReadS a
-reads = readsPrec 0
-
-shows :: Show a => a -> ShowS
-shows = showsPrec 0
-
-read :: Read a => String -> a
-read s = case [x | (x,t) <- reads s, ("","") <- lex t] of
- [x] -> x
- [] -> error "Prelude.read: no parse"
- _ -> error "Prelude.read: ambiguous parse"
-
-showChar :: Char -> ShowS
-showChar = (:)
-
-showString :: String -> ShowS
-showString = (++)
-
-showParen :: Bool -> ShowS -> ShowS
-showParen b p = if b then showChar '(' . p . showChar ')' else p
-
-hugsprimShowField :: Show a => String -> a -> ShowS
-hugsprimShowField m v = showString m . showChar '=' . shows v
-
-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 ]
-
-
-hugsprimReadField :: Read a => String -> ReadS a
-hugsprimReadField m s0 = [ r | (t, s1) <- lex s0, t == m,
- ("=",s2) <- lex s1,
- r <- reads s2 ]
-
-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 ('^':c:s) | c >= '@' && c <= '_' = [(['^',c],s)]
- lexEsc s@(d:_) | isDigit d = lexDigits s
- lexEsc s@(c:_) | isUpper c
- = let table = ('\DEL',"DEL") : asciiTab
- in case [(mne,s') | (c, mne) <- table,
- ([],s') <- [lexmatch mne s]]
- of (pr:_) -> [pr]
- [] -> []
- lexEsc _ = []
-lexLitChar (c:s) = [([c],s)]
-lexLitChar "" = []
-
-isOctDigit c = c >= '0' && c <= '7'
-isHexDigit c = isDigit c || c >= 'A' && c <= 'F'
- || c >= 'a' && c <= 'f'
-
-lexmatch :: (Eq a) => [a] -> [a] -> ([a],[a])
-lexmatch (x:xs) (y:ys) | x == y = lexmatch xs ys
-lexmatch xs ys = (xs,ys)
-
-asciiTab = zip ['\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"]
-
-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 <= '_'
- = [(toEnum (fromEnum c - fromEnum '@'), s)]
- readEsc s@(d:_) | isDigit d
- = [(toEnum n, t) | (n,t) <- readDec s]
- readEsc ('o':s) = [(toEnum n, t) | (n,t) <- readOct s]
- readEsc ('x':s) = [(toEnum n, t) | (n,t) <- readHex s]
- readEsc s@(c:_) | isUpper c
- = let table = ('\DEL',"DEL") : asciiTab
- in case [(c,s') | (c, mne) <- table,
- ([],s') <- [lexmatch mne s]]
- of (pr:_) -> [pr]
- [] -> []
- readEsc _ = []
-readLitChar (c:s) = [(c,s)]
-
-showLitChar :: Char -> ShowS
-showLitChar c | c > '\DEL' = showChar '\\' .
- protectEsc isDigit (shows (fromEnum 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 ('\\' : snd (asciiTab!!fromEnum c))
-
-protectEsc p f = f . cont
- where cont s@(c:_) | p c = "\\&" ++ s
- cont s = s
-
--- Unsigned readers for various bases
-readDec, readOct, readHex :: Integral a => ReadS a
-readDec = readInt 10 isDigit (\d -> fromEnum d - fromEnum '0')
-readOct = readInt 8 isOctDigit (\d -> fromEnum d - fromEnum '0')
-readHex = readInt 16 isHexDigit hex
- where hex d = fromEnum d -
- (if isDigit d
- then fromEnum '0'
- else fromEnum (if isUpper d then 'A' else 'a') - 10)
-
--- readInt reads a string of digits using an arbitrary base.
--- Leading minus signs must be handled elsewhere.
-
-readInt :: Integral a => a -> (Char -> Bool) -> (Char -> Int) -> ReadS a
-readInt radix isDig digToInt s =
- [(foldl1 (\n d -> n * radix + d) (map (fromIntegral . digToInt) ds), r)
- | (ds,r) <- nonnull isDig s ]
-
--- showInt is used for positive numbers only
-showInt :: Integral a => a -> ShowS
-showInt n r
- | n < 0
- = error "Numeric.showInt: can't show negative numbers"
- | otherwise
-{-
- = let (n',d) = quotRem n 10
- r' = toEnum (fromEnum '0' + fromIntegral d) : r
- in if n' == 0 then r' else showInt n' r'
--}
- = case quotRem n 10 of { (n',d) ->
- let r' = toEnum (fromEnum '0' + fromIntegral d) : r
- in if n' == 0 then r' else showInt n' r'
- }
-
-
-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]
-
-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
-
-readFloat :: RealFloat a => ReadS a
-readFloat r = [(fromRational ((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) <- lexFrac s ]
-
- lexFrac ('.':s) = lexDigits s
- lexFrac s = [("",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
-
-
--- Hooks for primitives: -----------------------------------------------------
--- Do not mess with these!
-
-hugsprimCompAux :: Ord a => a -> a -> Ordering -> Ordering
-hugsprimCompAux x y o = case compare x y of EQ -> o; LT -> LT; GT -> GT
-
-hugsprimEqChar :: Char -> Char -> Bool
-hugsprimEqChar c1 c2 = primEqChar c1 c2
-
-hugsprimPmInt :: Num a => Int -> a -> Bool
-hugsprimPmInt n x = fromInt n == x
-
-hugsprimPmInteger :: Num a => Integer -> a -> Bool
-hugsprimPmInteger n x = fromInteger n == x
-
-hugsprimPmDouble :: Fractional a => Double -> a -> Bool
-hugsprimPmDouble n x = fromDouble n == x
-
--- ToDo: make the message more informative.
-hugsprimPmFail :: a
-hugsprimPmFail = error "Pattern Match Failure"
-
--- used in desugaring Foreign functions
--- Note: hugsprimMkIO is used as a wrapper to translate a Hugs-created
--- bit of code of type RealWorld -> (a,RealWorld) into a proper IO value.
--- What follows is the version for standalone mode. ghc/lib/std/PrelHugs.lhs
--- contains a version used in combined mode. That version takes care of
--- switching between the GHC and Hugs IO representations, which are different.
-hugsprimMkIO :: (RealWorld -> (a,RealWorld)) -> IO a
-hugsprimMkIO = IO
-
-hugsprimCreateAdjThunk :: (a -> b) -> String -> Char -> IO Addr
-hugsprimCreateAdjThunk fun typestr callconv
- = do sp <- makeStablePtr fun
- p <- copy_String_to_cstring typestr -- is never freed
- a <- primCreateAdjThunkARCH sp p callconv
- return a
-
--- The following primitives are only needed if (n+k) patterns are enabled:
-hugsprimPmSub :: Integral a => Int -> a -> a
-hugsprimPmSub n x = x - fromInt n
-
-hugsprimPmFromInteger :: Integral a => Integer -> a
-hugsprimPmFromInteger = fromIntegral
-
-hugsprimPmSubtract :: Integral a => a -> a -> a
-hugsprimPmSubtract x y = x - y
-
-hugsprimPmLe :: Integral a => a -> a -> Bool
-hugsprimPmLe x y = x <= y
-
--- Unpack strings generated by the Hugs code generator.
--- Strings can contain \0 provided they're coded right.
---
--- ToDo: change this (and Hugs code generator) to use ByteArrays
-
-hugsprimUnpackString :: Addr -> String
-hugsprimUnpackString a = unpack 0
- where
- -- The following decoding is based on evalString in the old machine.c
- unpack i
- | c == '\0' = []
- | c == '\\' = if '\\' == primIndexCharOffAddr a (i+1)
- then '\\' : unpack (i+2)
- else '\0' : unpack (i+2)
- | otherwise = c : unpack (i+1)
- where
- c = primIndexCharOffAddr a i
-
-
--- Monadic I/O: --------------------------------------------------------------
-
-type FilePath = String
-
---data IOError = ...
---instance Eq IOError ...
---instance Show IOError ...
-
-data IOError = IOError String
-instance Show IOError where
- showsPrec _ (IOError s) = showString ("I/O error: " ++ s)
-
-ioError :: IOError -> IO a
-ioError e@(IOError _) = primRaise (IOException e)
-
-userError :: String -> IOError
-userError s = primRaise (ErrorCall s)
-
-throw :: Exception -> a
-throw exception = primRaise exception
-
-catchException :: IO a -> (Exception -> IO a) -> IO a
-catchException m k = IO (\s -> unIO m s `primCatch` \ err -> unIO (k err) s)
-
-catch :: IO a -> (IOError -> IO a) -> IO a
-catch m k = catchException m handler
- where handler (IOException err) = k err
- handler other = throw other
-
-putChar :: Char -> IO ()
-putChar c = nh_stdout >>= \h -> nh_write h c
-
-putStr :: String -> IO ()
-putStr s = nh_stdout >>= \h ->
- let loop [] = nh_flush h
- loop (c:cs) = nh_write h c >> loop cs
- in loop s
-
-putStrLn :: String -> IO ()
-putStrLn s = do { putStr s; putChar '\n' }
-
-print :: Show a => a -> IO ()
-print = putStrLn . show
-
-getChar :: IO Char
-getChar = nh_stdin >>= \h ->
- nh_read h >>= \ci ->
- return (primIntToChar ci)
-
-getLine :: IO String
-getLine = do c <- getChar
- if c=='\n' then return ""
- else do cs <- getLine
- return (c:cs)
-
-getContents :: IO String
-getContents = nh_stdin >>= \h -> readfromhandle h
-
-interact :: (String -> String) -> IO ()
-interact f = getContents >>= (putStr . f)
-
-readFile :: FilePath -> IO String
-readFile fname
- = copy_String_to_cstring fname >>= \ptr ->
- nh_open ptr 0 >>= \h ->
- nh_free ptr >>
- nh_errno >>= \errno ->
- if (isNullAddr h || errno /= 0)
- then (ioError.IOError) ("readFile: can't open file " ++ fname)
- else readfromhandle h
-
-writeFile :: FilePath -> String -> IO ()
-writeFile fname contents
- = copy_String_to_cstring fname >>= \ptr ->
- nh_open ptr 1 >>= \h ->
- nh_free ptr >>
- nh_errno >>= \errno ->
- if (isNullAddr h || errno /= 0)
- then (ioError.IOError) ("writeFile: can't create file " ++ fname)
- else writetohandle fname h contents
-
-appendFile :: FilePath -> String -> IO ()
-appendFile fname contents
- = copy_String_to_cstring fname >>= \ptr ->
- nh_open ptr 2 >>= \h ->
- nh_free ptr >>
- nh_errno >>= \errno ->
- if (isNullAddr h || errno /= 0)
- then (ioError.IOError) ("appendFile: can't open file " ++ fname)
- else writetohandle fname h contents
-
-
--- raises an exception instead of an error
-readIO :: Read a => String -> IO a
-readIO s = case [x | (x,t) <- reads s, ("","") <- lex t] of
- [x] -> return x
- [] -> ioError (userError "PreludeIO.readIO: no parse")
- _ -> ioError (userError
- "PreludeIO.readIO: ambiguous parse")
-
-readLn :: Read a => IO a
-readLn = do l <- getLine
- r <- readIO l
- return r
-
-
--- End of Hugs standard prelude ----------------------------------------------
-data Exception
- = IOException IOError -- IO exceptions (from 'ioError')
- | ArithException ArithException -- Arithmetic exceptions
- | ErrorCall String -- Calls to 'error'
- | NoMethodError String -- A non-existent method was invoked
- | PatternMatchFail String -- A pattern match failed
- | NonExhaustiveGuards String -- A guard match failed
- | RecSelError String -- Selecting a non-existent field
- | RecConError String -- Field missing in record construction
- | RecUpdError String -- Record doesn't contain updated field
- | AssertionFailed String -- Assertions
- | DynException Dynamic -- Dynamic exceptions
- | AsyncException AsyncException -- Externally generated errors
- | PutFullMVar -- Put on a full MVar
- | NonTermination
-
-data ArithException
- = Overflow
- | Underflow
- | LossOfPrecision
- | DivideByZero
- | Denormal
- deriving (Eq, Ord)
-
-data AsyncException
- = StackOverflow
- | HeapOverflow
- | ThreadKilled
- deriving (Eq, Ord)
-
-stackOverflow, heapOverflow :: Exception -- for the RTS
-stackOverflow = AsyncException StackOverflow
-heapOverflow = AsyncException HeapOverflow
-
-instance Show ArithException where
- showsPrec _ Overflow = showString "arithmetic overflow"
- showsPrec _ Underflow = showString "arithmetic underflow"
- showsPrec _ LossOfPrecision = showString "loss of precision"
- showsPrec _ DivideByZero = showString "divide by zero"
- showsPrec _ Denormal = showString "denormal"
-
-instance Show AsyncException where
- showsPrec _ StackOverflow = showString "stack overflow"
- showsPrec _ HeapOverflow = showString "heap overflow"
- showsPrec _ ThreadKilled = showString "thread killed"
-
-instance Show Exception where
- showsPrec _ (IOException err) = shows err
- showsPrec _ (ArithException err) = shows err
- showsPrec _ (ErrorCall err) = showString err
- showsPrec _ (NoMethodError err) = showString err
- showsPrec _ (PatternMatchFail err) = showString err
- showsPrec _ (NonExhaustiveGuards err) = showString err
- showsPrec _ (RecSelError err) = showString err
- showsPrec _ (RecConError err) = showString err
- showsPrec _ (RecUpdError err) = showString err
- showsPrec _ (AssertionFailed err) = showString err
- showsPrec _ (AsyncException e) = shows e
- showsPrec _ (DynException _err) = showString "unknown exception"
- showsPrec _ (PutFullMVar) = showString "putMVar: full MVar"
- showsPrec _ (NonTermination) = showString "<<loop>>"
-
-data Dynamic = Dynamic TypeRep Obj
-
-data Obj = Obj -- dummy type to hold the dynamically typed value.
-data TypeRep
- = App TyCon [TypeRep]
- | Fun TypeRep TypeRep
- deriving ( Eq )
-
-data TyCon = TyCon Int String
-
-instance Eq TyCon where
- (TyCon t1 _) == (TyCon t2 _) = t1 == t2
-
-data IOResult = IOResult deriving (Show)
-
-type FILE_STAR = Addr -- FILE *
-
-foreign import "nHandle" "nh_stdin" nh_stdin :: IO FILE_STAR
-foreign import "nHandle" "nh_stdout" nh_stdout :: IO FILE_STAR
-foreign import "nHandle" "nh_stderr" nh_stderr :: IO FILE_STAR
-foreign import "nHandle" "nh_write" nh_write :: FILE_STAR -> Char -> IO ()
-foreign import "nHandle" "nh_read" nh_read :: FILE_STAR -> IO Int
-foreign import "nHandle" "nh_open" nh_open :: Addr -> Int -> IO FILE_STAR
-foreign import "nHandle" "nh_flush" nh_flush :: FILE_STAR -> IO ()
-foreign import "nHandle" "nh_close" nh_close :: FILE_STAR -> IO ()
-foreign import "nHandle" "nh_errno" nh_errno :: IO Int
-
-foreign import "nHandle" "nh_malloc" nh_malloc :: Int -> IO Addr
-foreign import "nHandle" "nh_free" nh_free :: Addr -> IO ()
-foreign import "nHandle" "nh_store" nh_store :: Addr -> Char -> IO ()
-foreign import "nHandle" "nh_load" nh_load :: Addr -> IO Char
-foreign import "nHandle" "nh_getenv" nh_getenv :: Addr -> IO Addr
-foreign import "nHandle" "nh_filesize" nh_filesize :: FILE_STAR -> IO Int
-foreign import "nHandle" "nh_iseof" nh_iseof :: FILE_STAR -> IO Int
-foreign import "nHandle" "nh_system" nh_system :: Addr -> IO Int
-foreign import "nHandle" "nh_exitwith" nh_exitwith :: Int -> IO ()
-foreign import "nHandle" "nh_getPID" nh_getPID :: IO Int
-
-foreign import "nHandle" "nh_getCPUtime" nh_getCPUtime :: IO Double
-foreign import "nHandle" "nh_getCPUprec" nh_getCPUprec :: IO Double
-
-copy_String_to_cstring :: String -> IO Addr
-copy_String_to_cstring s
- = nh_malloc (1 + length s) >>= \ptr0 ->
- let loop ptr [] = nh_store ptr (chr 0) >> return ptr0
- loop ptr (c:cs) = nh_store ptr c >> loop (incAddr ptr) cs
- in
- if isNullAddr ptr0
- then error "copy_String_to_cstring: malloc failed"
- else loop ptr0 s
-
-copy_cstring_to_String :: Addr -> IO String
-copy_cstring_to_String ptr
- = nh_load ptr >>= \ci ->
- if ci == '\0'
- then return []
- else copy_cstring_to_String (incAddr ptr) >>= \cs ->
- return (ci : cs)
-
-readfromhandle :: FILE_STAR -> IO String
-readfromhandle h
- = unsafeInterleaveIO (
- nh_read h >>= \ci ->
- if ci == -1 {-EOF-} then return "" else
- readfromhandle h >>= \restOfFile -> return ((primIntToChar ci) : restOfFile)
- )
-
-writetohandle :: String -> FILE_STAR -> String -> IO ()
-writetohandle fname h []
- = nh_close h >>
- nh_errno >>= \errno ->
- if errno == 0
- then return ()
- else error ( "writeFile/appendFile: error closing file " ++ fname)
-writetohandle fname h (c:cs)
- = nh_write h c >> writetohandle fname h cs
-
-primGetRawArgs :: IO [String]
-primGetRawArgs
- = primGetArgc >>= \argc ->
- sequence (map get_one_arg [0 .. argc-1])
- where
- get_one_arg :: Int -> IO String
- get_one_arg argno
- = primGetArgv argno >>= \a ->
- copy_cstring_to_String a
-
-primGetEnv :: String -> IO String
-primGetEnv v
- = copy_String_to_cstring v >>= \ptr ->
- nh_getenv ptr >>= \ptr2 ->
- nh_free ptr >>
- if isNullAddr ptr2
- then ioError (IOError "getEnv failed")
- else
- copy_cstring_to_String ptr2 >>= \result ->
- return result
-
-
-------------------------------------------------------------------------------
--- ST ------------------------------------------------------------------------
-------------------------------------------------------------------------------
-
-newtype ST s a = ST (s -> (a,s))
-unST :: ST s a -> s -> (a,s)
-unST (ST a) = a
-mkST :: (s -> (a,s)) -> ST s a
-mkST = ST
-data RealWorld
-
-runST :: (__forall s . ST s a) -> a
-runST m = fst (unST m alpha)
- where
- alpha = error "runST: entered the RealWorld"
-
-instance Functor (ST s) where
- fmap f x = x >>= (return . f)
-
-instance Monad (ST s) where
- m >> k = ST (\s -> case unST m s of { (a,s') -> unST k s' })
- return x = ST (\s -> (x,s))
- m >>= k = ST (\s -> case unST m s of { (a,s') -> unST (k a) s' })
-
-unsafeInterleaveST :: ST s a -> ST s a
-unsafeInterleaveST m = ST (\ s -> (fst (unST m s), s))
-
-------------------------------------------------------------------------------
--- IO ------------------------------------------------------------------------
-------------------------------------------------------------------------------
-
-newtype IO a = IO (RealWorld -> (a,RealWorld))
-unIO (IO a) = a
-
-stToIO :: ST RealWorld a -> IO a
-stToIO (ST fn) = IO fn
-
-ioToST :: IO a -> ST RealWorld a
-ioToST (IO fn) = ST fn
-
-unsafePerformIO :: IO a -> a
-unsafePerformIO m = fst (unIO m theWorld)
- where
- theWorld :: RealWorld
- theWorld = error "unsafePerformIO: entered the RealWorld"
-
-instance Functor IO where
- fmap f x = x >>= (return . f)
-
-instance Monad IO where
- m >> k = IO (\s -> case unIO m s of { (a,s') -> unIO k s' })
- return x = IO (\s -> (x,s))
- m >>= k = IO (\s -> case unIO m s of { (a,s') -> unIO (k a) s' })
-
--- Library IO has a global variable which accumulates Handles
--- as they are opened. We keep here a second global variable
--- into which a cleanup action may be specified. When evaluation
--- finishes, either normally or as a result of System.exitWith,
--- this cleanup action is run, closing all known-about Handles.
--- Doing it like this means the Prelude does not have to know
--- anything about the grotty details of the Handle implementation.
-prelCleanupAfterRunAction :: IORef (Maybe (IO ()))
-prelCleanupAfterRunAction = unsafePerformIO (newIORef Nothing)
-
--- used when Hugs invokes top level function
-hugsprimRunIO_toplevel :: IO a -> ()
-hugsprimRunIO_toplevel m
- = protect 5 (fst (unIO composite_action realWorld))
- where
- composite_action
- = do writeIORef prelCleanupAfterRunAction Nothing
- m
- cleanup_handles <- readIORef prelCleanupAfterRunAction
- case cleanup_handles of
- Nothing -> return ()
- Just xx -> xx
-
- realWorld = error "primRunIO: entered the RealWorld"
- protect :: Int -> () -> ()
- protect 0 comp
- = comp
- protect n comp
- = primCatch (protect (n-1) comp)
- (\e -> fst (unIO (putStr (show e ++ "\n")) realWorld))
-
-unsafeInterleaveIO :: IO a -> IO a
-unsafeInterleaveIO m = IO (\ s -> (fst (unIO m s), s))
-
-------------------------------------------------------------------------------
--- Word, Addr, StablePtr, Prim*Array -----------------------------------------
-------------------------------------------------------------------------------
-
-data Addr
-
-nullAddr = primIntToAddr 0
-incAddr a = primIntToAddr (1 + primAddrToInt a)
-isNullAddr a = 0 == primAddrToInt a
-
-instance Eq Addr where
- (==) = primEqAddr
- (/=) = primNeAddr
-
-instance Ord Addr where
- (<) = primLtAddr
- (<=) = primLeAddr
- (>=) = primGeAddr
- (>) = primGtAddr
-
-data Word
-
-instance Eq Word where
- (==) = primEqWord
- (/=) = primNeWord
-
-instance Ord Word where
- (<) = primLtWord
- (<=) = primLeWord
- (>=) = primGeWord
- (>) = primGtWord
-
-data StablePtr a
-
-makeStablePtr :: a -> IO (StablePtr a)
-makeStablePtr = primMakeStablePtr
-deRefStablePtr :: StablePtr a -> IO a
-deRefStablePtr = primDeRefStablePtr
-freeStablePtr :: StablePtr a -> IO ()
-freeStablePtr = primFreeStablePtr
-
-
-data PrimArray a -- immutable arrays with Int indices
-data PrimByteArray
-
-data STRef s a -- mutable variables
-data PrimMutableArray s a -- mutable arrays with Int indices
-data PrimMutableByteArray s
-
-newSTRef :: a -> ST s (STRef s a)
-newSTRef = primNewRef
-readSTRef :: STRef s a -> ST s a
-readSTRef = primReadRef
-writeSTRef :: STRef s a -> a -> ST s ()
-writeSTRef = primWriteRef
-
-newtype IORef a = IORef (STRef RealWorld a)
-newIORef :: a -> IO (IORef a)
-newIORef a = stToIO (primNewRef a >>= \ ref ->return (IORef ref))
-readIORef :: IORef a -> IO a
-readIORef (IORef ref) = stToIO (primReadRef ref)
-writeIORef :: IORef a -> a -> IO ()
-writeIORef (IORef ref) a = stToIO (primWriteRef ref a)
-
-
-------------------------------------------------------------------------------
--- ThreadId, MVar, concurrency stuff -----------------------------------------
-------------------------------------------------------------------------------
-
-data MVar a
-
-newEmptyMVar :: IO (MVar a)
-newEmptyMVar = primNewEmptyMVar
-
-putMVar :: MVar a -> a -> IO ()
-putMVar = primPutMVar
-
-takeMVar :: MVar a -> IO a
-takeMVar m
- = IO (\world -> primTakeMVar m cont world)
- where
- -- cont :: a -> RealWorld -> (a,RealWorld)
- -- where 'a' is as in the top-level signature
- cont x world = (x,world)
-
- -- the type of the handwritten BCO (threesome) primTakeMVar is
- -- primTakeMVar :: MVar a
- -- -> (a -> RealWorld -> (a,RealWorld))
- -- -> RealWorld
- -- -> (a,RealWorld)
- --
- -- primTakeMVar behaves like this:
- --
- -- primTakeMVar (MVar# m#) cont world
- -- = primTakeMVar_wrk m# cont world
- --
- -- primTakeMVar_wrk m# cont world
- -- = cont (takeMVar# m#) world
- --
- -- primTakeMVar_wrk has the special property that it is
- -- restartable by the scheduler, should the MVar be empty.
-
-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
-
-isEmptyMVar var = error "isEmptyMVar is not (yet) implemented in Hugs"
-
-instance Eq (MVar a) where
- m1 == m2 = primSameMVar m1 m2
-
-data ThreadId
-
-instance Eq ThreadId where
- tid1 == tid2 = primCmpThreadIds tid1 tid2 == 0
-
-instance Ord ThreadId where
- compare tid1 tid2
- = let r = primCmpThreadIds tid1 tid2
- in if r < 0 then LT else if r > 0 then GT else EQ
-
-
-forkIO :: IO a -> IO ThreadId
--- Simple version; doesn't catch exceptions in computation
--- forkIO computation
--- = primForkIO (unsafePerformIO computation)
-
-forkIO computation
- = primForkIO (
- primCatch
- (unIO computation realWorld `primSeq` ())
- (\e -> trace_quiet ("forkIO: uncaught exception: " ++ show e) ())
- )
- where
- realWorld = error "primForkIO: entered the RealWorld"
-
-trace_quiet s x
- = (unsafePerformIO (putStr (s ++ "\n"))) `seq` x
-
-
--- Foreign ------------------------------------------------------------------
-
-data ForeignObj
-
--- showFloat ------------------------------------------------------------------
-
-showEFloat :: (RealFloat a) => Maybe Int -> a -> ShowS
-showFFloat :: (RealFloat a) => Maybe Int -> a -> ShowS
-showGFloat :: (RealFloat a) => Maybe Int -> a -> ShowS
-showFloat :: (RealFloat a) => a -> ShowS
-
-showEFloat d x = showString (formatRealFloat FFExponent d x)
-showFFloat d x = showString (formatRealFloat FFFixed d x)
-showGFloat d x = showString (formatRealFloat FFGeneric d x)
-showFloat = showGFloat Nothing
-
--- These are the format types. This type is not exported.
-
-data FFFormat = FFExponent | FFFixed | FFGeneric
-
-formatRealFloat :: (RealFloat a) => FFFormat -> Maybe Int -> a -> String
-formatRealFloat fmt decs x = s
- where base = 10
- s = if isNaN x then
- "NaN"
- else if isInfinite x then
- if x < 0 then "-Infinity" else "Infinity"
- else if x < 0 || isNegativeZero x then
- '-' : doFmt fmt (floatToDigits (toInteger base) (-x))
- else
- doFmt fmt (floatToDigits (toInteger base) x)
- doFmt fmt (is, e) =
- let ds = map intToDigit is
- in case fmt of
- FFGeneric ->
- doFmt (if e < 0 || e > 7 then FFExponent else FFFixed)
- (is, e)
- FFExponent ->
- case decs of
- Nothing ->
- case ds of
- ['0'] -> "0.0e0"
- [d] -> d : ".0e" ++ show (e-1)
- d:ds -> d : '.' : ds ++ 'e':show (e-1)
- Just dec ->
- let dec' = max dec 1 in
- case is of
- [0] -> '0':'.':take dec' (repeat '0') ++ "e0"
- _ ->
- let (ei, is') = roundTo base (dec'+1) is
- d:ds = map intToDigit
- (if ei > 0 then init is' else is')
- in d:'.':ds ++ "e" ++ show (e-1+ei)
- FFFixed ->
- case decs of
- Nothing ->
- let f 0 s ds = mk0 s ++ "." ++ mk0 ds
- f n s "" = f (n-1) (s++"0") ""
- f n s (d:ds) = f (n-1) (s++[d]) ds
- mk0 "" = "0"
- mk0 s = s
- in f e "" ds
- Just dec ->
- let dec' = max dec 0 in
- if e >= 0 then
- let (ei, is') = roundTo base (dec' + e) is
- (ls, rs) = splitAt (e+ei) (map intToDigit is')
- in (if null ls then "0" else ls) ++
- (if null rs then "" else '.' : rs)
- else
- let (ei, is') = roundTo base dec'
- (replicate (-e) 0 ++ is)
- d : ds = map intToDigit
- (if ei > 0 then is' else 0:is')
- in d : '.' : ds
-
-roundTo :: Int -> Int -> [Int] -> (Int, [Int])
-roundTo base d is = case f d is of
- (0, is) -> (0, is)
- (1, is) -> (1, 1 : is)
- where b2 = base `div` 2
- f n [] = (0, replicate n 0)
- f 0 (i:_) = (if i >= b2 then 1 else 0, [])
- f d (i:is) =
- let (c, ds) = f (d-1) is
- i' = c + i
- in if i' == base then (1, 0:ds) else (0, i':ds)
-
--- Based on "Printing Floating-Point Numbers Quickly and Accurately"
--- by R.G. Burger and R. K. Dybvig, in PLDI 96.
--- This version uses a much slower logarithm estimator. It should be improved.
-
--- This function returns a list of digits (Ints in [0..base-1]) and an
--- exponent.
-
-floatToDigits :: (RealFloat a) => Integer -> a -> ([Int], Int)
-
-floatToDigits _ 0 = ([0], 0)
-floatToDigits base x =
- let (f0, e0) = decodeFloat x
- (minExp0, _) = floatRange x
- p = floatDigits x
- b = floatRadix x
- minExp = minExp0 - p -- the real minimum exponent
- -- Haskell requires that f be adjusted so denormalized numbers
- -- will have an impossibly low exponent. Adjust for this.
- (f, e) = let n = minExp - e0
- in if n > 0 then (f0 `div` (b^n), e0+n) else (f0, e0)
-
- (r, s, mUp, mDn) =
- if e >= 0 then
- let be = b^e in
- if f == b^(p-1) then
- (f*be*b*2, 2*b, be*b, b)
- else
- (f*be*2, 2, be, be)
- else
- if e > minExp && f == b^(p-1) then
- (f*b*2, b^(-e+1)*2, b, 1)
- else
- (f*2, b^(-e)*2, 1, 1)
- k =
- let k0 =
- if b == 2 && base == 10 then
- -- logBase 10 2 is slightly bigger than 3/10 so
- -- the following will err on the low side. Ignoring
- -- the fraction will make it err even more.
- -- Haskell promises that p-1 <= logBase b f < p.
- (p - 1 + e0) * 3 `div` 10
- else
- ceiling ((log (fromInteger (f+1)) +
- fromInt e * log (fromInteger b)) /
- log (fromInteger base))
- fixup n =
- if n >= 0 then
- if r + mUp <= expt base n * s then n else fixup (n+1)
- else
- if expt base (-n) * (r + mUp) <= s then n
- else fixup (n+1)
- in fixup k0
-
- gen ds rn sN mUpN mDnN =
- let (dn, rn') = (rn * base) `divMod` sN
- mUpN' = mUpN * base
- mDnN' = mDnN * base
- in case (rn' < mDnN', rn' + mUpN' > sN) of
- (True, False) -> dn : ds
- (False, True) -> dn+1 : ds
- (True, True) -> if rn' * 2 < sN then dn : ds else dn+1 : ds
- (False, False) -> gen (dn:ds) rn' sN mUpN' mDnN'
- rds =
- if k >= 0 then
- gen [] r (s * expt base k) mUp mDn
- else
- let bk = expt base (-k)
- in gen [] (r * bk) s (mUp * bk) (mDn * bk)
- in (map toInt (reverse rds), k)
-
-
--- Exponentiation with a cache for the most common numbers.
-minExpt = 0::Int
-maxExpt = 1100::Int
-expt :: Integer -> Int -> Integer
-expt base n =
- if base == 2 && n >= minExpt && n <= maxExpt then
- expts !! (n-minExpt)
- else
- base^n
-
-expts :: [Integer]
-expts = [2^n | n <- [minExpt .. maxExpt]]
-
-
-irrefutPatError
- , noMethodBindingError
- , nonExhaustiveGuardsError
- , patError
- , recSelError
- , recConError
- , recUpdError :: String -> a
-
-noMethodBindingError s = throw (NoMethodError (untangle s "No instance nor default method for class operation"))
-irrefutPatError s = throw (PatternMatchFail (untangle s "Irrefutable pattern failed for pattern"))
-nonExhaustiveGuardsError s = throw (NonExhaustiveGuards (untangle s "Non-exhaustive guards in"))
-patError s = throw (PatternMatchFail (untangle s "Non-exhaustive patterns in"))
-recSelError s = throw (RecSelError (untangle s "Missing field in record selection"))
-recConError s = throw (RecConError (untangle s "Missing field in record construction"))
-recUpdError s = throw (RecUpdError (untangle s "Record doesn't contain field(s) to be updated"))
-
-
-tangleMessage :: String -> Int -> String
-tangleMessage "" line = show line
-tangleMessage str line = str ++ show line
-
-assertError :: String -> Bool -> a -> a
-assertError str pred v
- | pred = v
- | otherwise = throw (AssertionFailed (untangle str "Assertion failed"))
-
-{-
-(untangle coded message) expects "coded" to be of the form
-
- "location|details"
-
-It prints
-
- location message details
--}
-
-untangle :: String -> String -> String
-untangle coded message
- = location
- ++ ": "
- ++ message
- ++ details
- ++ "\n"
- where
- (location, details)
- = case (span not_bar coded) of { (loc, rest) ->
- case rest of
- ('|':det) -> (loc, ' ' : det)
- _ -> (loc, "")
- }
- not_bar c = c /= '|'
-
--- By default, we ignore asserts, but optionally, Hugs translates
--- assert ==> assertError "<location info>"
-
-assert :: Bool -> a -> a
-assert _ a = a
+import PrimPrel
--- /dev/null
+{----------------------------------------------------------------------------
+__ __ __ __ ____ ___ _______________________________________________
+|| || || || || || ||__ Hugs 98: The Nottingham and Yale Haskell system
+||___|| ||__|| ||__|| __|| Copyright (c) 1994-1999
+||---|| ___|| World Wide Web: http://haskell.org/hugs
+|| || Report bugs to: hugs-bugs@haskell.org
+|| || Version: STG Hugs _______________________________________________
+
+ This is the Hugs 98 Standard Prelude, based very closely on the Standard
+ Prelude for Haskell 98.
+
+ WARNING: This file is an integral part of the Hugs source code. Changes to
+ the definitions in this file without corresponding modifications in other
+ parts of the program may cause the interpreter to fail unexpectedly. Under
+ normal circumstances, you should not attempt to modify this file in any way!
+
+-----------------------------------------------------------------------------
+ Hugs 98 is Copyright (c) Mark P Jones, Alastair Reid and the Yale Haskell
+ Group 1994-99, and is distributed as Open Source software under the
+ Artistic License; see the file "Artistic" that is included in the
+ distribution for details.
+----------------------------------------------------------------------------}
+
+module PrimPrel (
+-- module PreludeList,
+ map, (++), concat, filter,
+ 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,
+-- module PreludeText,
+ ReadS, ShowS,
+ Read(readsPrec, readList),
+ Show(show, showsPrec, showList),
+ reads, shows, read, lex,
+ showChar, showString, readParen, showParen,
+-- module PreludeIO,
+ FilePath, IOError, ioError, userError, catch,
+ putChar, putStr, putStrLn, print,
+ getChar, getLine, getContents, interact,
+ readFile, writeFile, appendFile, readIO, readLn,
+-- module Ix,
+ Ix(range, index, inRange, rangeSize),
+-- module Char,
+ isAscii, isControl, isPrint, isSpace, isUpper, isLower,
+ isAlpha, isDigit, isOctDigit, isHexDigit, isAlphaNum,
+ digitToInt, intToDigit,
+ toUpper, toLower,
+ ord, chr,
+ readLitChar, showLitChar, lexLitChar,
+-- module Numeric
+ showSigned, showInt,
+ readSigned, readInt,
+ readDec, readOct, readHex, readSigned,
+ readFloat, lexDigits,
+-- module Ratio,
+ Ratio, Rational, (%), numerator, denominator, approxRational,
+-- Non-standard exports
+ IO, IOResult(..), Addr, StablePtr,
+ makeStablePtr, freeStablePtr, deRefStablePtr,
+
+ Bool(False, True),
+ Maybe(Nothing, Just),
+ Either(Left, Right),
+ Ordering(LT, EQ, GT),
+ Char, String, Int, Integer, Float, Double, IO,
+-- List type: []((:), [])
+ (:),
+-- Tuple types: (,), (,,), etc.
+-- Trivial type: ()
+-- Functions: (->)
+ Rec, EmptyRec, EmptyRow, -- non-standard, should only be exported if TREX
+ Eq((==), (/=)),
+ Ord(compare, (<), (<=), (>=), (>), max, min),
+ Enum(succ, pred, toEnum, fromEnum, enumFrom, enumFromThen,
+ enumFromTo, enumFromThenTo),
+ Bounded(minBound, maxBound),
+-- Num((+), (-), (*), negate, abs, signum, fromInteger),
+ Num((+), (-), (*), negate, abs, signum, fromInteger, fromInt),
+ Real(toRational),
+-- Integral(quot, rem, div, mod, quotRem, divMod, toInteger),
+ Integral(quot, rem, div, mod, quotRem, divMod, even, odd, toInteger, toInt),
+ Fractional((/), recip, fromRational), fromDouble,
+ 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),
+ Monad((>>=), (>>), return, fail),
+ Functor(fmap),
+ mapM, mapM_, sequence, sequence_, (=<<),
+ maybe, either,
+ (&&), (||), not, otherwise,
+ subtract, even, odd, gcd, lcm, (^), (^^),
+ fromIntegral, realToFrac, atan2,
+ fst, snd, curry, uncurry, id, const, (.), flip, ($), until,
+ asTypeOf, error, undefined,
+ seq, ($!)
+ -- Now we have the extra (non standard) thing.
+ ) where
+
+-- Standard value bindings {Prelude} ----------------------------------------
+
+infixr 9 .
+infixl 9 !!
+infixr 8 ^, ^^, **
+infixl 7 *, /, `quot`, `rem`, `div`, `mod`, :%, %
+infixl 6 +, -
+--infixr 5 : -- this fixity declaration is hard-wired into Hugs
+infixr 5 ++
+infix 4 ==, /=, <, <=, >=, >, `elem`, `notElem`
+infixr 3 &&
+infixr 2 ||
+infixl 1 >>, >>=
+infixr 1 =<<
+infixr 0 $, $!, `seq`
+
+-- Equality and Ordered classes ---------------------------------------------
+
+class Eq a where
+ (==), (/=) :: a -> a -> Bool
+
+ -- Minimal complete definition: (==) or (/=)
+ x == y = not (x/=y)
+ x /= y = not (x==y)
+
+class (Eq a) => Ord a where
+ compare :: a -> a -> Ordering
+ (<), (<=), (>=), (>) :: a -> a -> Bool
+ max, min :: a -> a -> a
+
+ -- Minimal complete definition: (<=) or compare
+ -- 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 | x >= y = x
+ | otherwise = y
+ min x y | x <= y = x
+ | otherwise = y
+
+class Bounded a where
+ minBound, maxBound :: a
+ -- Minimal complete definition: All
+
+-- Numeric classes ----------------------------------------------------------
+
+class (Eq a, Show a) => Num a where
+ (+), (-), (*) :: a -> a -> a
+ negate :: a -> a
+ abs, signum :: a -> a
+ fromInteger :: Integer -> a
+ fromInt :: Int -> a
+
+ -- Minimal complete definition: All, except negate or (-)
+ x - y = x + negate y
+ fromInt = fromIntegral
+ negate x = 0 - x
+
+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)
+ even, odd :: a -> Bool
+ toInteger :: a -> Integer
+ toInt :: a -> Int
+
+ -- Minimal complete definition: quotRem and toInteger
+ 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 == - signum d then (q-1, r+d) else qr
+ where qr@(q,r) = quotRem n d
+ even n = n `rem` 2 == 0
+ odd = not . even
+ toInt = toInt . toInteger
+
+class (Num a) => Fractional a where
+ (/) :: a -> a -> a
+ recip :: a -> a
+ fromRational :: Rational -> a
+
+ -- Minimal complete definition: fromRational and ((/) or recip)
+ recip x = 1 / x
+ x / y = x * recip y
+
+fromDouble :: Fractional a => Double -> a
+fromDouble n = fromRational (toRational n)
+
+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
+
+ -- Minimal complete definition: pi, exp, log, sin, cos, sinh, cosh,
+ -- asinh, acosh, atanh
+ x ** y = exp (log x * y)
+ logBase x y = log y / log x
+ sqrt x = x ** 0.5
+ tan x = sin x / cos x
+ sinh x = (exp x - exp (-x)) / 2
+ cosh x = (exp x + exp (-x)) / 2
+ tanh x = sinh x / cosh x
+ asinh x = log (x + sqrt (x*x + 1))
+ acosh x = log (x + sqrt (x*x - 1))
+ atanh x = (log (1 + x) - log (1 - x)) / 2
+
+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
+
+ -- Minimal complete definition: properFraction
+ 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
+ atan2 :: a -> a -> a
+
+ -- Minimal complete definition: All, except exponent, signficand,
+ -- scaleFloat, atan2
+ exponent x = if m==0 then 0 else n + floatDigits x
+ where (m,n) = decodeFloat x
+ significand x = encodeFloat m (- floatDigits x)
+ where (m,_) = decodeFloat x
+ scaleFloat k x = encodeFloat m (n+k)
+ where (m,n) = decodeFloat x
+ atan2 y x
+ | x>0 = atan (y/x)
+ | x==0 && y>0 = pi/2
+ | x<0 && y>0 = pi + atan (y/x)
+ | (x<=0 && y<0) ||
+ (x<0 && isNegativeZero y) ||
+ (isNegativeZero x && isNegativeZero y)
+ = - atan2 (-y) x
+ | y==0 && (x<0 || isNegativeZero x)
+ = pi -- must be after the previous test on zero y
+ | x==0 && y==0 = y -- must be after the other double zero tests
+ | otherwise = x + y -- x or y is a NaN, return a NaN (via +)
+
+-- Numeric functions --------------------------------------------------------
+
+subtract :: Num a => a -> a -> a
+subtract = flip (-)
+
+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)
+
+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^(-n))
+
+fromIntegral :: (Integral a, Num b) => a -> b
+fromIntegral = fromInteger . toInteger
+
+realToFrac :: (Real a, Fractional b) => a -> b
+realToFrac = fromRational . toRational
+
+-- Index and Enumeration classes --------------------------------------------
+
+class (Ord a) => Ix a where
+ range :: (a,a) -> [a]
+ index :: (a,a) -> a -> Int
+ inRange :: (a,a) -> a -> Bool
+ rangeSize :: (a,a) -> Int
+
+ rangeSize r@(l,u)
+ | l > u = 0
+ | otherwise = index r u + 1
+
+class Enum a where
+ succ, pred :: a -> a
+ toEnum :: Int -> a
+ fromEnum :: a -> Int
+ enumFrom :: a -> [a] -- [n..]
+ enumFromThen :: a -> a -> [a] -- [n,m..]
+ enumFromTo :: a -> a -> [a] -- [n..m]
+ enumFromThenTo :: a -> a -> a -> [a] -- [n,n'..m]
+
+ -- Minimal complete definition: toEnum, fromEnum
+ succ = toEnum . (1+) . fromEnum
+ pred = toEnum . subtract 1 . fromEnum
+ enumFrom x = map toEnum [ fromEnum x .. ]
+ enumFromTo x y = map toEnum [ fromEnum x .. fromEnum y ]
+ enumFromThen x y = map toEnum [ fromEnum x, fromEnum y .. ]
+ enumFromThenTo x y z = map toEnum [ fromEnum x, fromEnum y .. fromEnum z ]
+
+-- Read and Show classes ------------------------------------------------------
+
+type ReadS a = String -> [(a,String)]
+type ShowS = String -> String
+
+class Read a where
+ readsPrec :: Int -> ReadS a
+ readList :: ReadS [a]
+
+ -- Minimal complete definition: readsPrec
+ readList = readParen False (\r -> [pr | ("[",s) <- lex r,
+ pr <- readl s ])
+ where readl s = [([],t) | ("]",t) <- lex s] ++
+ [(x:xs,u) | (x,t) <- reads s,
+ (xs,u) <- readl' t]
+ readl' s = [([],t) | ("]",t) <- lex s] ++
+ [(x:xs,v) | (",",t) <- lex s,
+ (x,u) <- reads t,
+ (xs,v) <- readl' u]
+
+class Show a where
+ show :: a -> String
+ showsPrec :: Int -> a -> ShowS
+ showList :: [a] -> ShowS
+
+ -- Minimal complete definition: show or showsPrec
+ show x = showsPrec 0 x ""
+ showsPrec _ x s = show x ++ s
+ showList [] = showString "[]"
+ showList (x:xs) = showChar '[' . shows x . showl xs
+ where showl [] = showChar ']'
+ showl (x:xs) = showChar ',' . shows x . showl xs
+
+-- Monad classes ------------------------------------------------------------
+
+class Functor f where
+ fmap :: (a -> b) -> (f a -> f b)
+
+class Monad m where
+ return :: a -> m a
+ (>>=) :: m a -> (a -> m b) -> m b
+ (>>) :: m a -> m b -> m b
+ fail :: String -> m a
+
+ -- Minimal complete definition: (>>=), return
+ p >> q = p >>= \ _ -> q
+ fail s = error s
+
+sequence :: Monad m => [m a] -> m [a]
+sequence [] = return []
+sequence (c:cs) = do x <- c
+ xs <- sequence cs
+ return (x:xs)
+
+sequence_ :: Monad m => [m a] -> m ()
+sequence_ = foldr (>>) (return ())
+
+mapM :: Monad m => (a -> m b) -> [a] -> m [b]
+mapM f = sequence . map f
+
+mapM_ :: Monad m => (a -> m b) -> [a] -> m ()
+mapM_ f = sequence_ . map f
+
+(=<<) :: Monad m => (a -> m b) -> m a -> m b
+f =<< x = x >>= f
+
+-- Evaluation and strictness ------------------------------------------------
+
+seq :: a -> b -> b
+seq x y = primSeq x y
+
+($!) :: (a -> b) -> a -> b
+f $! x = x `primSeq` f x
+
+-- Trivial type -------------------------------------------------------------
+
+-- data () = () deriving (Eq, Ord, Ix, Enum, Read, Show, Bounded)
+
+instance Eq () where
+ () == () = True
+
+instance Ord () where
+ compare () () = EQ
+
+instance Ix () where
+ range ((),()) = [()]
+ index ((),()) () = 0
+ inRange ((),()) () = True
+
+instance Enum () where
+ toEnum 0 = ()
+ fromEnum () = 0
+ enumFrom () = [()]
+ enumFromThen () () = [()]
+
+instance Read () where
+ readsPrec p = readParen False (\r -> [((),t) | ("(",s) <- lex r,
+ (")",t) <- lex s ])
+
+instance Show () where
+ showsPrec p () = showString "()"
+
+instance Bounded () where
+ minBound = ()
+ maxBound = ()
+
+-- Boolean type -------------------------------------------------------------
+
+data Bool = False | True
+ deriving (Eq, Ord, Ix, Enum, Read, Show, Bounded)
+
+(&&), (||) :: Bool -> Bool -> Bool
+False && x = False
+True && x = x
+False || x = x
+True || x = True
+
+not :: Bool -> Bool
+not True = False
+not False = True
+
+otherwise :: Bool
+otherwise = True
+
+-- Character type -----------------------------------------------------------
+
+data Char -- builtin datatype of ISO Latin characters
+type String = [Char] -- strings are lists of characters
+
+instance Eq Char where (==) = primEqChar
+instance Ord Char where (<=) = primLeChar
+
+instance Enum Char where
+ toEnum = primIntToChar
+ fromEnum = primCharToInt
+ enumFrom c = map toEnum [fromEnum c .. fromEnum (maxBound::Char)]
+ enumFromThen c d = map toEnum [fromEnum c, fromEnum d .. fromEnum (lastChar::Char)]
+ where lastChar = if d < c then minBound else maxBound
+
+instance Ix Char where
+ range (c,c') = [c..c']
+ index b@(c,c') ci
+ | inRange b ci = fromEnum ci - fromEnum c
+ | otherwise = error "Ix.index: Index out of range."
+ inRange (c,c') ci = fromEnum c <= i && i <= fromEnum c'
+ where i = fromEnum ci
+
+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 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
+
+instance Bounded Char where
+ minBound = '\0'
+ maxBound = '\255'
+
+isAscii, isControl, isPrint, isSpace :: Char -> Bool
+isUpper, isLower, isAlpha, isDigit, isAlphaNum :: Char -> Bool
+
+isAscii c = fromEnum c < 128
+isControl c = c < ' ' || c == '\DEL'
+isPrint c = c >= ' ' && c <= '~'
+isSpace c = c == ' ' || c == '\t' || c == '\n' ||
+ c == '\r' || c == '\f' || c == '\v'
+isUpper c = c >= 'A' && c <= 'Z'
+isLower c = c >= 'a' && c <= 'z'
+isAlpha c = isUpper c || isLower c
+isDigit c = c >= '0' && c <= '9'
+isAlphaNum c = isAlpha c || isDigit c
+
+-- Digit conversion operations
+digitToInt :: Char -> Int
+digitToInt c
+ | isDigit c = fromEnum c - fromEnum '0'
+ | c >= 'a' && c <= 'f' = fromEnum c - fromEnum 'a' + 10
+ | c >= 'A' && c <= 'F' = fromEnum c - fromEnum 'A' + 10
+ | otherwise = error "Char.digitToInt: not a digit"
+
+intToDigit :: Int -> Char
+intToDigit i
+ | i >= 0 && i <= 9 = toEnum (fromEnum '0' + i)
+ | i >= 10 && i <= 15 = toEnum (fromEnum 'a' + i - 10)
+ | otherwise = error "Char.intToDigit: not a digit"
+
+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
+
+ord :: Char -> Int
+ord = fromEnum
+
+chr :: Int -> Char
+chr = toEnum
+
+-- Maybe type ---------------------------------------------------------------
+
+data Maybe a = Nothing | Just a
+ deriving (Eq, Ord, Read, Show)
+
+maybe :: b -> (a -> b) -> Maybe a -> b
+maybe n f Nothing = n
+maybe n f (Just x) = f x
+
+instance Functor Maybe where
+ fmap f Nothing = Nothing
+ fmap f (Just x) = Just (f x)
+
+instance Monad Maybe where
+ Just x >>= k = k x
+ Nothing >>= k = Nothing
+ return = Just
+ fail s = Nothing
+
+-- Either type --------------------------------------------------------------
+
+data Either a b = Left a | Right b
+ deriving (Eq, Ord, Read, Show)
+
+either :: (a -> c) -> (b -> c) -> Either a b -> c
+either l r (Left x) = l x
+either l r (Right y) = r y
+
+-- Ordering type ------------------------------------------------------------
+
+data Ordering = LT | EQ | GT
+ deriving (Eq, Ord, Ix, Enum, Read, Show, Bounded)
+
+-- Lists --------------------------------------------------------------------
+
+--data [a] = [] | a : [a] deriving (Eq, Ord)
+
+instance Eq a => Eq [a] where
+ [] == [] = True
+ (x:xs) == (y:ys) = x==y && xs==ys
+ _ == _ = False
+
+instance Ord a => Ord [a] where
+ compare [] (_:_) = LT
+ compare [] [] = EQ
+ compare (_:_) [] = GT
+ compare (x:xs) (y:ys) = hugsprimCompAux x y (compare xs ys)
+
+instance Functor [] where
+ fmap = map
+
+instance Monad [ ] where
+ (x:xs) >>= f = f x ++ (xs >>= f)
+ [] >>= f = []
+ return x = [x]
+ fail s = []
+
+instance Read a => Read [a] where
+ readsPrec p = readList
+
+instance Show a => Show [a] where
+ showsPrec p = showList
+
+-- Tuples -------------------------------------------------------------------
+
+-- data (a,b) = (a,b) deriving (Eq, Ord, Ix, Read, Show)
+-- etc..
+
+-- Standard Integral types --------------------------------------------------
+
+data Int -- builtin datatype of fixed size integers
+data Integer -- builtin datatype of arbitrary size integers
+
+instance Eq Integer where
+ (==) x y = primCompareInteger x y == 0
+
+instance Ord Integer where
+ compare x y = case primCompareInteger x y of
+ -1 -> LT
+ 0 -> EQ
+ 1 -> GT
+
+instance Eq Int where
+ (==) = primEqInt
+ (/=) = primNeInt
+
+instance Ord Int where
+ (<) = primLtInt
+ (<=) = primLeInt
+ (>=) = primGeInt
+ (>) = primGtInt
+
+instance Num Int where
+ (+) = primPlusInt
+ (-) = primMinusInt
+ negate = primNegateInt
+ (*) = primTimesInt
+ abs = absReal
+ signum = signumReal
+ fromInteger = primIntegerToInt
+ fromInt x = x
+
+instance Bounded Int where
+ minBound = primMinInt
+ maxBound = primMaxInt
+
+instance Num Integer where
+ (+) = primPlusInteger
+ (-) = primMinusInteger
+ negate = primNegateInteger
+ (*) = primTimesInteger
+ abs = absReal
+ signum = signumReal
+ fromInteger x = x
+ fromInt = primIntToInteger
+
+absReal x | x >= 0 = x
+ | otherwise = -x
+
+signumReal x | x == 0 = 0
+ | x > 0 = 1
+ | otherwise = -1
+
+instance Real Int where
+ toRational x = toInteger x % 1
+
+instance Real Integer where
+ toRational x = x % 1
+
+instance Integral Int where
+ quotRem = primQuotRemInt
+ toInteger = primIntToInteger
+ toInt x = x
+
+instance Integral Integer where
+ quotRem = primQuotRemInteger
+ toInteger = id
+ toInt = primIntegerToInt
+
+instance Ix Int where
+ range (m,n) = [m..n]
+ index b@(m,n) i
+ | inRange b i = i - m
+ | otherwise = error "index: Index out of range"
+ inRange (m,n) i = m <= i && i <= n
+
+instance Ix Integer where
+ range (m,n) = [m..n]
+ index b@(m,n) i
+ | inRange b i = fromInteger (i - m)
+ | otherwise = error "index: Index out of range"
+ inRange (m,n) i = m <= i && i <= n
+
+instance Enum Int where
+ toEnum = id
+ fromEnum = id
+ enumFrom = numericEnumFrom
+ enumFromTo = numericEnumFromTo
+ enumFromThen = numericEnumFromThen
+ enumFromThenTo = numericEnumFromThenTo
+
+instance Enum Integer where
+ toEnum = primIntToInteger
+ fromEnum = primIntegerToInt
+ enumFrom = numericEnumFrom
+ enumFromTo = numericEnumFromTo
+ enumFromThen = numericEnumFromThen
+ enumFromThenTo = numericEnumFromThenTo
+
+numericEnumFrom :: Real a => a -> [a]
+numericEnumFromThen :: Real a => a -> a -> [a]
+numericEnumFromTo :: Real a => a -> a -> [a]
+numericEnumFromThenTo :: Real a => a -> a -> a -> [a]
+numericEnumFrom n = n : (numericEnumFrom $! (n+1))
+numericEnumFromThen n m = iterate ((m-n)+) n
+numericEnumFromTo n m = takeWhile (<= m) (numericEnumFrom n)
+numericEnumFromThenTo n n' m = takeWhile p (numericEnumFromThen n n')
+ where p | n' >= n = (<= m)
+ | otherwise = (>= m)
+
+instance Read Int where
+ readsPrec p = readSigned readDec
+
+instance Show Int where
+ showsPrec p n
+ | n == minBound = showSigned showInt p (toInteger n)
+ | otherwise = showSigned showInt p n
+
+instance Read Integer where
+ readsPrec p = readSigned readDec
+
+instance Show Integer where
+ showsPrec = showSigned showInt
+
+
+-- Standard Floating types --------------------------------------------------
+
+data Float -- builtin datatype of single precision floating point numbers
+data Double -- builtin datatype of double precision floating point numbers
+
+instance Eq Float where
+ (==) = primEqFloat
+ (/=) = primNeFloat
+
+instance Ord Float where
+ (<) = primLtFloat
+ (<=) = primLeFloat
+ (>=) = primGeFloat
+ (>) = primGtFloat
+
+instance Num Float where
+ (+) = primPlusFloat
+ (-) = primMinusFloat
+ negate = primNegateFloat
+ (*) = primTimesFloat
+ abs = absReal
+ signum = signumReal
+ fromInteger = primIntegerToFloat
+ fromInt = primIntToFloat
+
+
+
+instance Eq Double where
+ (==) = primEqDouble
+ (/=) = primNeDouble
+
+instance Ord Double where
+ (<) = primLtDouble
+ (<=) = primLeDouble
+ (>=) = primGeDouble
+ (>) = primGtDouble
+
+instance Num Double where
+ (+) = primPlusDouble
+ (-) = primMinusDouble
+ negate = primNegateDouble
+ (*) = primTimesDouble
+ abs = absReal
+ signum = signumReal
+ fromInteger = primIntegerToDouble
+ fromInt = primIntToDouble
+
+
+
+instance Real Float where
+ toRational = floatToRational
+
+instance Real Double where
+ toRational = doubleToRational
+
+-- Calls to these functions are optimised when passed as arguments to
+-- fromRational.
+floatToRational :: Float -> Rational
+doubleToRational :: Double -> Rational
+floatToRational x = realFloatToRational x
+doubleToRational x = realFloatToRational x
+
+realFloatToRational x = (m%1)*(b%1)^^n
+ where (m,n) = decodeFloat x
+ b = floatRadix x
+
+instance Fractional Float where
+ (/) = primDivideFloat
+ fromRational = rationalToRealFloat
+
+instance Fractional Double where
+ (/) = primDivideDouble
+ fromRational = rationalToRealFloat
+
+rationalToRealFloat x = x'
+ where x' = f e
+ f e = if e' == e then y else f e'
+ where y = encodeFloat (round (x * (1%b)^^e)) e
+ (_,e') = decodeFloat y
+ (_,e) = decodeFloat (fromInteger (numerator x) `asTypeOf` x'
+ / fromInteger (denominator x))
+ b = floatRadix x'
+
+instance Floating Float where
+ pi = 3.14159265358979323846
+ exp = primExpFloat
+ log = primLogFloat
+ sqrt = primSqrtFloat
+ sin = primSinFloat
+ cos = primCosFloat
+ tan = primTanFloat
+ asin = primAsinFloat
+ acos = primAcosFloat
+ atan = primAtanFloat
+
+instance Floating Double where
+ pi = 3.14159265358979323846
+ exp = primExpDouble
+ log = primLogDouble
+ sqrt = primSqrtDouble
+ sin = primSinDouble
+ cos = primCosDouble
+ tan = primTanDouble
+ asin = primAsinDouble
+ acos = primAcosDouble
+ atan = primAtanDouble
+
+instance RealFrac Float where
+ properFraction = floatProperFraction
+
+instance RealFrac Double where
+ properFraction = floatProperFraction
+
+floatProperFraction x
+ | n >= 0 = (fromInteger m * fromInteger b ^ n, 0)
+ | otherwise = (fromInteger w, encodeFloat r n)
+ where (m,n) = decodeFloat x
+ b = floatRadix x
+ (w,r) = quotRem m (b^(-n))
+
+instance RealFloat Float where
+ floatRadix _ = toInteger primRadixFloat
+ floatDigits _ = primDigitsFloat
+ floatRange _ = (primMinExpFloat,primMaxExpFloat)
+ encodeFloat = primEncodeFloatZ
+ decodeFloat = primDecodeFloatZ
+ isNaN = primIsNaNFloat
+ isInfinite = primIsInfiniteFloat
+ isDenormalized= primIsDenormalizedFloat
+ isNegativeZero= primIsNegativeZeroFloat
+ isIEEE = const primIsIEEEFloat
+
+instance RealFloat Double where
+ floatRadix _ = toInteger primRadixDouble
+ floatDigits _ = primDigitsDouble
+ floatRange _ = (primMinExpDouble,primMaxExpDouble)
+ encodeFloat = primEncodeDoubleZ
+ decodeFloat = primDecodeDoubleZ
+ isNaN = primIsNaNDouble
+ isInfinite = primIsInfiniteDouble
+ isDenormalized= primIsDenormalizedDouble
+ isNegativeZero= primIsNegativeZeroDouble
+ isIEEE = const primIsIEEEDouble
+
+instance Enum Float where
+ toEnum = primIntToFloat
+ fromEnum = truncate
+ enumFrom = numericEnumFrom
+ enumFromThen = numericEnumFromThen
+ enumFromTo n m = numericEnumFromTo n (m+1/2)
+ enumFromThenTo n n' m = numericEnumFromThenTo n n' (m + (n'-n)/2)
+
+instance Enum Double where
+ toEnum = primIntToDouble
+ fromEnum = truncate
+ enumFrom = numericEnumFrom
+ enumFromThen = numericEnumFromThen
+ enumFromTo n m = numericEnumFromTo n (m+1/2)
+ enumFromThenTo n n' m = numericEnumFromThenTo n n' (m + (n'-n)/2)
+
+instance Read Float where
+ readsPrec p = readSigned readFloat
+
+instance Show Float where
+ showsPrec p = showSigned showFloat p
+
+instance Read Double where
+ readsPrec p = readSigned readFloat
+
+instance Show Double where
+ showsPrec p = showSigned showFloat p
+
+
+-- Some standard functions --------------------------------------------------
+
+fst :: (a,b) -> a
+fst (x,_) = x
+
+snd :: (a,b) -> b
+snd (_,y) = y
+
+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)
+
+id :: a -> a
+id x = x
+
+const :: a -> b -> a
+const k _ = k
+
+(.) :: (b -> c) -> (a -> b) -> (a -> c)
+(f . g) x = f (g x)
+
+flip :: (a -> b -> c) -> b -> a -> c
+flip f x y = f y x
+
+($) :: (a -> b) -> a -> b
+f $ x = f x
+
+until :: (a -> Bool) -> (a -> a) -> a -> a
+until p f x = if p x then x else until p f (f x)
+
+asTypeOf :: a -> a -> a
+asTypeOf = const
+
+error :: String -> a
+error msg = primRaise (ErrorCall msg)
+
+undefined :: a
+undefined | False = undefined
+
+-- Standard functions on rational numbers {PreludeRatio} --------------------
+
+data Integral a => Ratio a = a :% a deriving (Eq)
+type Rational = Ratio Integer
+
+(%) :: Integral a => a -> a -> Ratio a
+x % y = reduce (x * signum y) (abs y)
+
+reduce :: Integral a => a -> a -> Ratio a
+reduce x y | y == 0 = error "Ratio.%: zero denominator"
+ | otherwise = (x `quot` d) :% (y `quot` d)
+ where d = gcd x y
+
+numerator, denominator :: Integral a => Ratio a -> a
+numerator (x :% y) = x
+denominator (x :% y) = y
+
+instance Integral a => Ord (Ratio a) where
+ compare (x:%y) (x':%y') = compare (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) = negate x :% y
+ abs (x :% y) = abs x :% y
+ signum (x :% y) = signum x :% 1
+ fromInteger x = fromInteger x :% 1
+ fromInt = intToRatio
+
+-- Hugs optimises code of the form fromRational (intToRatio x)
+intToRatio :: Integral a => Int -> Ratio a
+intToRatio x = fromInt 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
+
+-- Hugs optimises code of the form fromRational (doubleToRatio x)
+doubleToRatio :: Integral a => Double -> Ratio a
+doubleToRatio x
+ | n>=0 = (fromInteger m * fromInteger b ^ n) % 1
+ | otherwise = fromInteger m % (fromInteger b ^ (-n))
+ where (m,n) = decodeFloat x
+ b = floatRadix x
+
+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
+ toEnum = fromInt
+ fromEnum = truncate
+ enumFrom = numericEnumFrom
+ enumFromThen = numericEnumFromThen
+
+instance (Read a, Integral a) => Read (Ratio a) where
+ readsPrec p = readParen (p > 7)
+ (\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 > 7)
+ (shows x . showString " % " . shows y)
+
+approxRational :: RealFrac a => a -> a -> Rational
+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
+
+-- Standard list functions {PreludeList} ------------------------------------
+
+head :: [a] -> a
+head (x:_) = x
+
+last :: [a] -> a
+last [x] = x
+last (_:xs) = last xs
+
+tail :: [a] -> [a]
+tail (_:xs) = xs
+
+init :: [a] -> [a]
+init [x] = []
+init (x:xs) = x : init xs
+
+null :: [a] -> Bool
+null [] = True
+null (_:_) = False
+
+(++) :: [a] -> [a] -> [a]
+[] ++ ys = ys
+(x:xs) ++ ys = x : (xs ++ ys)
+
+map :: (a -> b) -> [a] -> [b]
+--map f xs = [ f x | x <- xs ]
+map f [] = []
+map f (x:xs) = f x : map f xs
+
+
+filter :: (a -> Bool) -> [a] -> [a]
+--filter p xs = [ x | x <- xs, p x ]
+filter p [] = []
+filter p (x:xs) = if p x then x : filter p xs else filter p xs
+
+
+concat :: [[a]] -> [a]
+--concat = foldr (++) []
+concat [] = []
+concat (xs:xss) = xs ++ concat xss
+
+length :: [a] -> Int
+--length = foldl' (\n _ -> n + 1) 0
+length [] = 0
+length (x:xs) = let n = length xs in primSeq n (1+n)
+
+(!!) :: [b] -> Int -> b
+(x:_) !! 0 = x
+(_:xs) !! n | n>0 = xs !! (n-1)
+(_:_) !! _ = error "Prelude.!!: negative index"
+[] !! _ = error "Prelude.!!: index too large"
+
+foldl :: (a -> b -> a) -> a -> [b] -> a
+foldl f z [] = z
+foldl f z (x:xs) = foldl f (f z x) xs
+
+foldl' :: (a -> b -> a) -> a -> [b] -> a
+foldl' f a [] = a
+foldl' f a (x:xs) = (foldl' f $! f a x) xs
+
+foldl1 :: (a -> a -> a) -> [a] -> a
+foldl1 f (x:xs) = foldl f x xs
+
+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
+
+foldr :: (a -> b -> b) -> b -> [a] -> b
+foldr f z [] = z
+foldr f z (x:xs) = f x (foldr f z xs)
+
+foldr1 :: (a -> a -> a) -> [a] -> a
+foldr1 f [x] = x
+foldr1 f (x:xs) = f x (foldr1 f xs)
+
+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
+
+iterate :: (a -> a) -> a -> [a]
+iterate f x = x : iterate f (f x)
+
+repeat :: a -> [a]
+repeat x = xs where xs = x:xs
+
+replicate :: Int -> a -> [a]
+replicate n x = take n (repeat x)
+
+cycle :: [a] -> [a]
+cycle [] = error "Prelude.cycle: empty list"
+cycle xs = xs' where xs'=xs++xs'
+
+take :: Int -> [a] -> [a]
+take 0 _ = []
+take _ [] = []
+take n (x:xs) | n>0 = x : take (n-1) xs
+take _ _ = error "Prelude.take: negative argument"
+
+drop :: Int -> [a] -> [a]
+drop 0 xs = xs
+drop _ [] = []
+drop n (_:xs) | n>0 = drop (n-1) xs
+drop _ _ = error "Prelude.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 "Prelude.splitAt: negative argument"
+
+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
+
+span, break :: (a -> Bool) -> [a] -> ([a],[a])
+span p [] = ([],[])
+span p xs@(x:xs')
+ | p x = (x:ys, zs)
+ | otherwise = ([],xs)
+ where (ys,zs) = span p xs'
+break p = span (not . p)
+
+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 isSpace s of
+ "" -> []
+ s' -> w : words s''
+ where (w,s'') = break isSpace s'
+
+unlines :: [String] -> String
+unlines = concatMap (\l -> l ++ "\n")
+
+unwords :: [String] -> String
+unwords [] = []
+unwords ws = foldr1 (\w s -> w ++ ' ':s) ws
+
+reverse :: [a] -> [a]
+--reverse = foldl (flip (:)) []
+reverse xs = ri [] xs
+ where ri acc [] = acc
+ ri acc (x:xs) = ri (x:acc) xs
+
+and, or :: [Bool] -> Bool
+--and = foldr (&&) True
+--or = foldr (||) False
+and [] = True
+and (x:xs) = if x then and xs else x
+or [] = False
+or (x:xs) = if x then x else or xs
+
+any, all :: (a -> Bool) -> [a] -> Bool
+--any p = or . map p
+--all p = and . map p
+any p [] = False
+any p (x:xs) = if p x then True else any p xs
+all p [] = True
+all p (x:xs) = if p x then all p xs else False
+
+elem, notElem :: Eq a => a -> [a] -> Bool
+--elem = any . (==)
+--notElem = all . (/=)
+elem x [] = False
+elem x (y:ys) = if x==y then True else elem x ys
+notElem x [] = True
+notElem x (y:ys) = if x==y then False else notElem x ys
+
+lookup :: Eq a => a -> [(a,b)] -> Maybe b
+lookup k [] = Nothing
+lookup k ((x,y):xys)
+ | k==x = Just y
+ | otherwise = lookup k xys
+
+sum, product :: Num a => [a] -> a
+sum = foldl' (+) 0
+product = foldl' (*) 1
+
+maximum, minimum :: Ord a => [a] -> a
+maximum = foldl1 max
+minimum = foldl1 min
+
+concatMap :: (a -> [b]) -> [a] -> [b]
+concatMap f = concat . map f
+
+zip :: [a] -> [b] -> [(a,b)]
+zip = zipWith (\a b -> (a,b))
+
+zip3 :: [a] -> [b] -> [c] -> [(a,b,c)]
+zip3 = zipWith3 (\a b c -> (a,b,c))
+
+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 :: [(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))
+ ([],[],[])
+
+-- PreludeText ----------------------------------------------------------------
+
+reads :: Read a => ReadS a
+reads = readsPrec 0
+
+shows :: Show a => a -> ShowS
+shows = showsPrec 0
+
+read :: Read a => String -> a
+read s = case [x | (x,t) <- reads s, ("","") <- lex t] of
+ [x] -> x
+ [] -> error "Prelude.read: no parse"
+ _ -> error "Prelude.read: ambiguous parse"
+
+showChar :: Char -> ShowS
+showChar = (:)
+
+showString :: String -> ShowS
+showString = (++)
+
+showParen :: Bool -> ShowS -> ShowS
+showParen b p = if b then showChar '(' . p . showChar ')' else p
+
+hugsprimShowField :: Show a => String -> a -> ShowS
+hugsprimShowField m v = showString m . showChar '=' . shows v
+
+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 ]
+
+
+hugsprimReadField :: Read a => String -> ReadS a
+hugsprimReadField m s0 = [ r | (t, s1) <- lex s0, t == m,
+ ("=",s2) <- lex s1,
+ r <- reads s2 ]
+
+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 ('^':c:s) | c >= '@' && c <= '_' = [(['^',c],s)]
+ lexEsc s@(d:_) | isDigit d = lexDigits s
+ lexEsc s@(c:_) | isUpper c
+ = let table = ('\DEL',"DEL") : asciiTab
+ in case [(mne,s') | (c, mne) <- table,
+ ([],s') <- [lexmatch mne s]]
+ of (pr:_) -> [pr]
+ [] -> []
+ lexEsc _ = []
+lexLitChar (c:s) = [([c],s)]
+lexLitChar "" = []
+
+isOctDigit c = c >= '0' && c <= '7'
+isHexDigit c = isDigit c || c >= 'A' && c <= 'F'
+ || c >= 'a' && c <= 'f'
+
+lexmatch :: (Eq a) => [a] -> [a] -> ([a],[a])
+lexmatch (x:xs) (y:ys) | x == y = lexmatch xs ys
+lexmatch xs ys = (xs,ys)
+
+asciiTab = zip ['\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"]
+
+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 <= '_'
+ = [(toEnum (fromEnum c - fromEnum '@'), s)]
+ readEsc s@(d:_) | isDigit d
+ = [(toEnum n, t) | (n,t) <- readDec s]
+ readEsc ('o':s) = [(toEnum n, t) | (n,t) <- readOct s]
+ readEsc ('x':s) = [(toEnum n, t) | (n,t) <- readHex s]
+ readEsc s@(c:_) | isUpper c
+ = let table = ('\DEL',"DEL") : asciiTab
+ in case [(c,s') | (c, mne) <- table,
+ ([],s') <- [lexmatch mne s]]
+ of (pr:_) -> [pr]
+ [] -> []
+ readEsc _ = []
+readLitChar (c:s) = [(c,s)]
+
+showLitChar :: Char -> ShowS
+showLitChar c | c > '\DEL' = showChar '\\' .
+ protectEsc isDigit (shows (fromEnum 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 ('\\' : snd (asciiTab!!fromEnum c))
+
+protectEsc p f = f . cont
+ where cont s@(c:_) | p c = "\\&" ++ s
+ cont s = s
+
+-- Unsigned readers for various bases
+readDec, readOct, readHex :: Integral a => ReadS a
+readDec = readInt 10 isDigit (\d -> fromEnum d - fromEnum '0')
+readOct = readInt 8 isOctDigit (\d -> fromEnum d - fromEnum '0')
+readHex = readInt 16 isHexDigit hex
+ where hex d = fromEnum d -
+ (if isDigit d
+ then fromEnum '0'
+ else fromEnum (if isUpper d then 'A' else 'a') - 10)
+
+-- readInt reads a string of digits using an arbitrary base.
+-- Leading minus signs must be handled elsewhere.
+
+readInt :: Integral a => a -> (Char -> Bool) -> (Char -> Int) -> ReadS a
+readInt radix isDig digToInt s =
+ [(foldl1 (\n d -> n * radix + d) (map (fromIntegral . digToInt) ds), r)
+ | (ds,r) <- nonnull isDig s ]
+
+-- showInt is used for positive numbers only
+showInt :: Integral a => a -> ShowS
+showInt n r
+ | n < 0
+ = error "Numeric.showInt: can't show negative numbers"
+ | otherwise
+{-
+ = let (n',d) = quotRem n 10
+ r' = toEnum (fromEnum '0' + fromIntegral d) : r
+ in if n' == 0 then r' else showInt n' r'
+-}
+ = case quotRem n 10 of { (n',d) ->
+ let r' = toEnum (fromEnum '0' + fromIntegral d) : r
+ in if n' == 0 then r' else showInt n' r'
+ }
+
+
+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]
+
+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
+
+readFloat :: RealFloat a => ReadS a
+readFloat r = [(fromRational ((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) <- lexFrac s ]
+
+ lexFrac ('.':s) = lexDigits s
+ lexFrac s = [("",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
+
+
+-- Hooks for primitives: -----------------------------------------------------
+-- Do not mess with these!
+
+hugsprimCompAux :: Ord a => a -> a -> Ordering -> Ordering
+hugsprimCompAux x y o = case compare x y of EQ -> o; LT -> LT; GT -> GT
+
+hugsprimEqChar :: Char -> Char -> Bool
+hugsprimEqChar c1 c2 = primEqChar c1 c2
+
+hugsprimPmInt :: Num a => Int -> a -> Bool
+hugsprimPmInt n x = fromInt n == x
+
+hugsprimPmInteger :: Num a => Integer -> a -> Bool
+hugsprimPmInteger n x = fromInteger n == x
+
+hugsprimPmDouble :: Fractional a => Double -> a -> Bool
+hugsprimPmDouble n x = fromDouble n == x
+
+-- ToDo: make the message more informative.
+hugsprimPmFail :: a
+hugsprimPmFail = error "Pattern Match Failure"
+
+-- used in desugaring Foreign functions
+-- Note: hugsprimMkIO is used as a wrapper to translate a Hugs-created
+-- bit of code of type RealWorld -> (a,RealWorld) into a proper IO value.
+-- What follows is the version for standalone mode. ghc/lib/std/PrelHugs.lhs
+-- contains a version used in combined mode. That version takes care of
+-- switching between the GHC and Hugs IO representations, which are different.
+hugsprimMkIO :: (RealWorld -> (a,RealWorld)) -> IO a
+hugsprimMkIO = IO
+
+hugsprimCreateAdjThunk :: (a -> b) -> String -> Char -> IO Addr
+hugsprimCreateAdjThunk fun typestr callconv
+ = do sp <- makeStablePtr fun
+ p <- copy_String_to_cstring typestr -- is never freed
+ a <- primCreateAdjThunkARCH sp p callconv
+ return a
+
+-- The following primitives are only needed if (n+k) patterns are enabled:
+hugsprimPmSub :: Integral a => Int -> a -> a
+hugsprimPmSub n x = x - fromInt n
+
+hugsprimPmFromInteger :: Integral a => Integer -> a
+hugsprimPmFromInteger = fromIntegral
+
+hugsprimPmSubtract :: Integral a => a -> a -> a
+hugsprimPmSubtract x y = x - y
+
+hugsprimPmLe :: Integral a => a -> a -> Bool
+hugsprimPmLe x y = x <= y
+
+-- Unpack strings generated by the Hugs code generator.
+-- Strings can contain \0 provided they're coded right.
+--
+-- ToDo: change this (and Hugs code generator) to use ByteArrays
+
+hugsprimUnpackString :: Addr -> String
+hugsprimUnpackString a = unpack 0
+ where
+ -- The following decoding is based on evalString in the old machine.c
+ unpack i
+ | c == '\0' = []
+ | c == '\\' = if '\\' == primIndexCharOffAddr a (i+1)
+ then '\\' : unpack (i+2)
+ else '\0' : unpack (i+2)
+ | otherwise = c : unpack (i+1)
+ where
+ c = primIndexCharOffAddr a i
+
+
+-- Monadic I/O: --------------------------------------------------------------
+
+type FilePath = String
+
+--data IOError = ...
+--instance Eq IOError ...
+--instance Show IOError ...
+
+data IOError = IOError String
+instance Show IOError where
+ showsPrec _ (IOError s) = showString ("I/O error: " ++ s)
+
+ioError :: IOError -> IO a
+ioError e@(IOError _) = primRaise (IOException e)
+
+userError :: String -> IOError
+userError s = primRaise (ErrorCall s)
+
+throw :: Exception -> a
+throw exception = primRaise exception
+
+catchException :: IO a -> (Exception -> IO a) -> IO a
+catchException m k = IO (\s -> unIO m s `primCatch` \ err -> unIO (k err) s)
+
+catch :: IO a -> (IOError -> IO a) -> IO a
+catch m k = catchException m handler
+ where handler (IOException err) = k err
+ handler other = throw other
+
+putChar :: Char -> IO ()
+putChar c = nh_stdout >>= \h -> nh_write h c
+
+putStr :: String -> IO ()
+putStr s = nh_stdout >>= \h ->
+ let loop [] = nh_flush h
+ loop (c:cs) = nh_write h c >> loop cs
+ in loop s
+
+putStrLn :: String -> IO ()
+putStrLn s = do { putStr s; putChar '\n' }
+
+print :: Show a => a -> IO ()
+print = putStrLn . show
+
+getChar :: IO Char
+getChar = nh_stdin >>= \h ->
+ nh_read h >>= \ci ->
+ return (primIntToChar ci)
+
+getLine :: IO String
+getLine = do c <- getChar
+ if c=='\n' then return ""
+ else do cs <- getLine
+ return (c:cs)
+
+getContents :: IO String
+getContents = nh_stdin >>= \h -> readfromhandle h
+
+interact :: (String -> String) -> IO ()
+interact f = getContents >>= (putStr . f)
+
+readFile :: FilePath -> IO String
+readFile fname
+ = copy_String_to_cstring fname >>= \ptr ->
+ nh_open ptr 0 >>= \h ->
+ nh_free ptr >>
+ nh_errno >>= \errno ->
+ if (isNullAddr h || errno /= 0)
+ then (ioError.IOError) ("readFile: can't open file " ++ fname)
+ else readfromhandle h
+
+writeFile :: FilePath -> String -> IO ()
+writeFile fname contents
+ = copy_String_to_cstring fname >>= \ptr ->
+ nh_open ptr 1 >>= \h ->
+ nh_free ptr >>
+ nh_errno >>= \errno ->
+ if (isNullAddr h || errno /= 0)
+ then (ioError.IOError) ("writeFile: can't create file " ++ fname)
+ else writetohandle fname h contents
+
+appendFile :: FilePath -> String -> IO ()
+appendFile fname contents
+ = copy_String_to_cstring fname >>= \ptr ->
+ nh_open ptr 2 >>= \h ->
+ nh_free ptr >>
+ nh_errno >>= \errno ->
+ if (isNullAddr h || errno /= 0)
+ then (ioError.IOError) ("appendFile: can't open file " ++ fname)
+ else writetohandle fname h contents
+
+
+-- raises an exception instead of an error
+readIO :: Read a => String -> IO a
+readIO s = case [x | (x,t) <- reads s, ("","") <- lex t] of
+ [x] -> return x
+ [] -> ioError (userError "PreludeIO.readIO: no parse")
+ _ -> ioError (userError
+ "PreludeIO.readIO: ambiguous parse")
+
+readLn :: Read a => IO a
+readLn = do l <- getLine
+ r <- readIO l
+ return r
+
+
+-- End of Hugs standard prelude ----------------------------------------------
+data Exception
+ = IOException IOError -- IO exceptions (from 'ioError')
+ | ArithException ArithException -- Arithmetic exceptions
+ | ErrorCall String -- Calls to 'error'
+ | NoMethodError String -- A non-existent method was invoked
+ | PatternMatchFail String -- A pattern match failed
+ | NonExhaustiveGuards String -- A guard match failed
+ | RecSelError String -- Selecting a non-existent field
+ | RecConError String -- Field missing in record construction
+ | RecUpdError String -- Record doesn't contain updated field
+ | AssertionFailed String -- Assertions
+ | DynException Dynamic -- Dynamic exceptions
+ | AsyncException AsyncException -- Externally generated errors
+ | PutFullMVar -- Put on a full MVar
+ | NonTermination
+
+data ArithException
+ = Overflow
+ | Underflow
+ | LossOfPrecision
+ | DivideByZero
+ | Denormal
+ deriving (Eq, Ord)
+
+data AsyncException
+ = StackOverflow
+ | HeapOverflow
+ | ThreadKilled
+ deriving (Eq, Ord)
+
+stackOverflow, heapOverflow :: Exception -- for the RTS
+stackOverflow = AsyncException StackOverflow
+heapOverflow = AsyncException HeapOverflow
+
+instance Show ArithException where
+ showsPrec _ Overflow = showString "arithmetic overflow"
+ showsPrec _ Underflow = showString "arithmetic underflow"
+ showsPrec _ LossOfPrecision = showString "loss of precision"
+ showsPrec _ DivideByZero = showString "divide by zero"
+ showsPrec _ Denormal = showString "denormal"
+
+instance Show AsyncException where
+ showsPrec _ StackOverflow = showString "stack overflow"
+ showsPrec _ HeapOverflow = showString "heap overflow"
+ showsPrec _ ThreadKilled = showString "thread killed"
+
+instance Show Exception where
+ showsPrec _ (IOException err) = shows err
+ showsPrec _ (ArithException err) = shows err
+ showsPrec _ (ErrorCall err) = showString err
+ showsPrec _ (NoMethodError err) = showString err
+ showsPrec _ (PatternMatchFail err) = showString err
+ showsPrec _ (NonExhaustiveGuards err) = showString err
+ showsPrec _ (RecSelError err) = showString err
+ showsPrec _ (RecConError err) = showString err
+ showsPrec _ (RecUpdError err) = showString err
+ showsPrec _ (AssertionFailed err) = showString err
+ showsPrec _ (AsyncException e) = shows e
+ showsPrec _ (DynException _err) = showString "unknown exception"
+ showsPrec _ (PutFullMVar) = showString "putMVar: full MVar"
+ showsPrec _ (NonTermination) = showString "<<loop>>"
+
+data Dynamic = Dynamic TypeRep Obj
+
+data Obj = Obj -- dummy type to hold the dynamically typed value.
+data TypeRep
+ = App TyCon [TypeRep]
+ | Fun TypeRep TypeRep
+ deriving ( Eq )
+
+data TyCon = TyCon Int String
+
+instance Eq TyCon where
+ (TyCon t1 _) == (TyCon t2 _) = t1 == t2
+
+data IOResult = IOResult deriving (Show)
+
+type FILE_STAR = Addr -- FILE *
+
+foreign import "nHandle" "nh_stdin" nh_stdin :: IO FILE_STAR
+foreign import "nHandle" "nh_stdout" nh_stdout :: IO FILE_STAR
+foreign import "nHandle" "nh_stderr" nh_stderr :: IO FILE_STAR
+foreign import "nHandle" "nh_write" nh_write :: FILE_STAR -> Char -> IO ()
+foreign import "nHandle" "nh_read" nh_read :: FILE_STAR -> IO Int
+foreign import "nHandle" "nh_open" nh_open :: Addr -> Int -> IO FILE_STAR
+foreign import "nHandle" "nh_flush" nh_flush :: FILE_STAR -> IO ()
+foreign import "nHandle" "nh_close" nh_close :: FILE_STAR -> IO ()
+foreign import "nHandle" "nh_errno" nh_errno :: IO Int
+
+foreign import "nHandle" "nh_malloc" nh_malloc :: Int -> IO Addr
+foreign import "nHandle" "nh_free" nh_free :: Addr -> IO ()
+foreign import "nHandle" "nh_store" nh_store :: Addr -> Char -> IO ()
+foreign import "nHandle" "nh_load" nh_load :: Addr -> IO Char
+foreign import "nHandle" "nh_getenv" nh_getenv :: Addr -> IO Addr
+foreign import "nHandle" "nh_filesize" nh_filesize :: FILE_STAR -> IO Int
+foreign import "nHandle" "nh_iseof" nh_iseof :: FILE_STAR -> IO Int
+foreign import "nHandle" "nh_system" nh_system :: Addr -> IO Int
+foreign import "nHandle" "nh_exitwith" nh_exitwith :: Int -> IO ()
+foreign import "nHandle" "nh_getPID" nh_getPID :: IO Int
+
+foreign import "nHandle" "nh_getCPUtime" nh_getCPUtime :: IO Double
+foreign import "nHandle" "nh_getCPUprec" nh_getCPUprec :: IO Double
+
+copy_String_to_cstring :: String -> IO Addr
+copy_String_to_cstring s
+ = nh_malloc (1 + length s) >>= \ptr0 ->
+ let loop ptr [] = nh_store ptr (chr 0) >> return ptr0
+ loop ptr (c:cs) = nh_store ptr c >> loop (incAddr ptr) cs
+ in
+ if isNullAddr ptr0
+ then error "copy_String_to_cstring: malloc failed"
+ else loop ptr0 s
+
+copy_cstring_to_String :: Addr -> IO String
+copy_cstring_to_String ptr
+ = nh_load ptr >>= \ci ->
+ if ci == '\0'
+ then return []
+ else copy_cstring_to_String (incAddr ptr) >>= \cs ->
+ return (ci : cs)
+
+readfromhandle :: FILE_STAR -> IO String
+readfromhandle h
+ = unsafeInterleaveIO (
+ nh_read h >>= \ci ->
+ if ci == -1 {-EOF-} then return "" else
+ readfromhandle h >>= \restOfFile -> return ((primIntToChar ci) : restOfFile)
+ )
+
+writetohandle :: String -> FILE_STAR -> String -> IO ()
+writetohandle fname h []
+ = nh_close h >>
+ nh_errno >>= \errno ->
+ if errno == 0
+ then return ()
+ else error ( "writeFile/appendFile: error closing file " ++ fname)
+writetohandle fname h (c:cs)
+ = nh_write h c >> writetohandle fname h cs
+
+primGetRawArgs :: IO [String]
+primGetRawArgs
+ = primGetArgc >>= \argc ->
+ sequence (map get_one_arg [0 .. argc-1])
+ where
+ get_one_arg :: Int -> IO String
+ get_one_arg argno
+ = primGetArgv argno >>= \a ->
+ copy_cstring_to_String a
+
+primGetEnv :: String -> IO String
+primGetEnv v
+ = copy_String_to_cstring v >>= \ptr ->
+ nh_getenv ptr >>= \ptr2 ->
+ nh_free ptr >>
+ if isNullAddr ptr2
+ then ioError (IOError "getEnv failed")
+ else
+ copy_cstring_to_String ptr2 >>= \result ->
+ return result
+
+
+------------------------------------------------------------------------------
+-- ST ------------------------------------------------------------------------
+------------------------------------------------------------------------------
+
+newtype ST s a = ST (s -> (a,s))
+unST :: ST s a -> s -> (a,s)
+unST (ST a) = a
+mkST :: (s -> (a,s)) -> ST s a
+mkST = ST
+data RealWorld
+
+runST :: (__forall s . ST s a) -> a
+runST m = fst (unST m alpha)
+ where
+ alpha = error "runST: entered the RealWorld"
+
+instance Functor (ST s) where
+ fmap f x = x >>= (return . f)
+
+instance Monad (ST s) where
+ m >> k = ST (\s -> case unST m s of { (a,s') -> unST k s' })
+ return x = ST (\s -> (x,s))
+ m >>= k = ST (\s -> case unST m s of { (a,s') -> unST (k a) s' })
+
+unsafeInterleaveST :: ST s a -> ST s a
+unsafeInterleaveST m = ST (\ s -> (fst (unST m s), s))
+
+------------------------------------------------------------------------------
+-- IO ------------------------------------------------------------------------
+------------------------------------------------------------------------------
+
+newtype IO a = IO (RealWorld -> (a,RealWorld))
+unIO (IO a) = a
+
+stToIO :: ST RealWorld a -> IO a
+stToIO (ST fn) = IO fn
+
+ioToST :: IO a -> ST RealWorld a
+ioToST (IO fn) = ST fn
+
+unsafePerformIO :: IO a -> a
+unsafePerformIO m = fst (unIO m theWorld)
+ where
+ theWorld :: RealWorld
+ theWorld = error "unsafePerformIO: entered the RealWorld"
+
+instance Functor IO where
+ fmap f x = x >>= (return . f)
+
+instance Monad IO where
+ m >> k = IO (\s -> case unIO m s of { (a,s') -> unIO k s' })
+ return x = IO (\s -> (x,s))
+ m >>= k = IO (\s -> case unIO m s of { (a,s') -> unIO (k a) s' })
+
+-- Library IO has a global variable which accumulates Handles
+-- as they are opened. We keep here a second global variable
+-- into which a cleanup action may be specified. When evaluation
+-- finishes, either normally or as a result of System.exitWith,
+-- this cleanup action is run, closing all known-about Handles.
+-- Doing it like this means the Prelude does not have to know
+-- anything about the grotty details of the Handle implementation.
+prelCleanupAfterRunAction :: IORef (Maybe (IO ()))
+prelCleanupAfterRunAction = unsafePerformIO (newIORef Nothing)
+
+-- used when Hugs invokes top level function
+hugsprimRunIO_toplevel :: IO a -> ()
+hugsprimRunIO_toplevel m
+ = protect 5 (fst (unIO composite_action realWorld))
+ where
+ composite_action
+ = do writeIORef prelCleanupAfterRunAction Nothing
+ m
+ cleanup_handles <- readIORef prelCleanupAfterRunAction
+ case cleanup_handles of
+ Nothing -> return ()
+ Just xx -> xx
+
+ realWorld = error "primRunIO: entered the RealWorld"
+ protect :: Int -> () -> ()
+ protect 0 comp
+ = comp
+ protect n comp
+ = primCatch (protect (n-1) comp)
+ (\e -> fst (unIO (putStr (show e ++ "\n")) realWorld))
+
+unsafeInterleaveIO :: IO a -> IO a
+unsafeInterleaveIO m = IO (\ s -> (fst (unIO m s), s))
+
+------------------------------------------------------------------------------
+-- Word, Addr, StablePtr, Prim*Array -----------------------------------------
+------------------------------------------------------------------------------
+
+data Addr
+
+nullAddr = primIntToAddr 0
+incAddr a = primIntToAddr (1 + primAddrToInt a)
+isNullAddr a = 0 == primAddrToInt a
+
+instance Eq Addr where
+ (==) = primEqAddr
+ (/=) = primNeAddr
+
+instance Ord Addr where
+ (<) = primLtAddr
+ (<=) = primLeAddr
+ (>=) = primGeAddr
+ (>) = primGtAddr
+
+data Word
+
+instance Eq Word where
+ (==) = primEqWord
+ (/=) = primNeWord
+
+instance Ord Word where
+ (<) = primLtWord
+ (<=) = primLeWord
+ (>=) = primGeWord
+ (>) = primGtWord
+
+data StablePtr a
+
+makeStablePtr :: a -> IO (StablePtr a)
+makeStablePtr = primMakeStablePtr
+deRefStablePtr :: StablePtr a -> IO a
+deRefStablePtr = primDeRefStablePtr
+freeStablePtr :: StablePtr a -> IO ()
+freeStablePtr = primFreeStablePtr
+
+
+data PrimArray a -- immutable arrays with Int indices
+data PrimByteArray
+
+data STRef s a -- mutable variables
+data PrimMutableArray s a -- mutable arrays with Int indices
+data PrimMutableByteArray s
+
+newSTRef :: a -> ST s (STRef s a)
+newSTRef = primNewRef
+readSTRef :: STRef s a -> ST s a
+readSTRef = primReadRef
+writeSTRef :: STRef s a -> a -> ST s ()
+writeSTRef = primWriteRef
+
+newtype IORef a = IORef (STRef RealWorld a)
+newIORef :: a -> IO (IORef a)
+newIORef a = stToIO (primNewRef a >>= \ ref ->return (IORef ref))
+readIORef :: IORef a -> IO a
+readIORef (IORef ref) = stToIO (primReadRef ref)
+writeIORef :: IORef a -> a -> IO ()
+writeIORef (IORef ref) a = stToIO (primWriteRef ref a)
+
+
+------------------------------------------------------------------------------
+-- ThreadId, MVar, concurrency stuff -----------------------------------------
+------------------------------------------------------------------------------
+
+data MVar a
+
+newEmptyMVar :: IO (MVar a)
+newEmptyMVar = primNewEmptyMVar
+
+putMVar :: MVar a -> a -> IO ()
+putMVar = primPutMVar
+
+takeMVar :: MVar a -> IO a
+takeMVar m
+ = IO (\world -> primTakeMVar m cont world)
+ where
+ -- cont :: a -> RealWorld -> (a,RealWorld)
+ -- where 'a' is as in the top-level signature
+ cont x world = (x,world)
+
+ -- the type of the handwritten BCO (threesome) primTakeMVar is
+ -- primTakeMVar :: MVar a
+ -- -> (a -> RealWorld -> (a,RealWorld))
+ -- -> RealWorld
+ -- -> (a,RealWorld)
+ --
+ -- primTakeMVar behaves like this:
+ --
+ -- primTakeMVar (MVar# m#) cont world
+ -- = primTakeMVar_wrk m# cont world
+ --
+ -- primTakeMVar_wrk m# cont world
+ -- = cont (takeMVar# m#) world
+ --
+ -- primTakeMVar_wrk has the special property that it is
+ -- restartable by the scheduler, should the MVar be empty.
+
+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
+
+isEmptyMVar var = error "isEmptyMVar is not (yet) implemented in Hugs"
+
+instance Eq (MVar a) where
+ m1 == m2 = primSameMVar m1 m2
+
+data ThreadId
+
+instance Eq ThreadId where
+ tid1 == tid2 = primCmpThreadIds tid1 tid2 == 0
+
+instance Ord ThreadId where
+ compare tid1 tid2
+ = let r = primCmpThreadIds tid1 tid2
+ in if r < 0 then LT else if r > 0 then GT else EQ
+
+
+forkIO :: IO a -> IO ThreadId
+-- Simple version; doesn't catch exceptions in computation
+-- forkIO computation
+-- = primForkIO (unsafePerformIO computation)
+
+forkIO computation
+ = primForkIO (
+ primCatch
+ (unIO computation realWorld `primSeq` ())
+ (\e -> trace_quiet ("forkIO: uncaught exception: " ++ show e) ())
+ )
+ where
+ realWorld = error "primForkIO: entered the RealWorld"
+
+trace_quiet s x
+ = (unsafePerformIO (putStr (s ++ "\n"))) `seq` x
+
+
+-- Foreign ------------------------------------------------------------------
+
+data ForeignObj
+
+-- showFloat ------------------------------------------------------------------
+
+showEFloat :: (RealFloat a) => Maybe Int -> a -> ShowS
+showFFloat :: (RealFloat a) => Maybe Int -> a -> ShowS
+showGFloat :: (RealFloat a) => Maybe Int -> a -> ShowS
+showFloat :: (RealFloat a) => a -> ShowS
+
+showEFloat d x = showString (formatRealFloat FFExponent d x)
+showFFloat d x = showString (formatRealFloat FFFixed d x)
+showGFloat d x = showString (formatRealFloat FFGeneric d x)
+showFloat = showGFloat Nothing
+
+-- These are the format types. This type is not exported.
+
+data FFFormat = FFExponent | FFFixed | FFGeneric
+
+formatRealFloat :: (RealFloat a) => FFFormat -> Maybe Int -> a -> String
+formatRealFloat fmt decs x = s
+ where base = 10
+ s = if isNaN x then
+ "NaN"
+ else if isInfinite x then
+ if x < 0 then "-Infinity" else "Infinity"
+ else if x < 0 || isNegativeZero x then
+ '-' : doFmt fmt (floatToDigits (toInteger base) (-x))
+ else
+ doFmt fmt (floatToDigits (toInteger base) x)
+ doFmt fmt (is, e) =
+ let ds = map intToDigit is
+ in case fmt of
+ FFGeneric ->
+ doFmt (if e < 0 || e > 7 then FFExponent else FFFixed)
+ (is, e)
+ FFExponent ->
+ case decs of
+ Nothing ->
+ case ds of
+ ['0'] -> "0.0e0"
+ [d] -> d : ".0e" ++ show (e-1)
+ d:ds -> d : '.' : ds ++ 'e':show (e-1)
+ Just dec ->
+ let dec' = max dec 1 in
+ case is of
+ [0] -> '0':'.':take dec' (repeat '0') ++ "e0"
+ _ ->
+ let (ei, is') = roundTo base (dec'+1) is
+ d:ds = map intToDigit
+ (if ei > 0 then init is' else is')
+ in d:'.':ds ++ "e" ++ show (e-1+ei)
+ FFFixed ->
+ case decs of
+ Nothing ->
+ let f 0 s ds = mk0 s ++ "." ++ mk0 ds
+ f n s "" = f (n-1) (s++"0") ""
+ f n s (d:ds) = f (n-1) (s++[d]) ds
+ mk0 "" = "0"
+ mk0 s = s
+ in f e "" ds
+ Just dec ->
+ let dec' = max dec 0 in
+ if e >= 0 then
+ let (ei, is') = roundTo base (dec' + e) is
+ (ls, rs) = splitAt (e+ei) (map intToDigit is')
+ in (if null ls then "0" else ls) ++
+ (if null rs then "" else '.' : rs)
+ else
+ let (ei, is') = roundTo base dec'
+ (replicate (-e) 0 ++ is)
+ d : ds = map intToDigit
+ (if ei > 0 then is' else 0:is')
+ in d : '.' : ds
+
+roundTo :: Int -> Int -> [Int] -> (Int, [Int])
+roundTo base d is = case f d is of
+ (0, is) -> (0, is)
+ (1, is) -> (1, 1 : is)
+ where b2 = base `div` 2
+ f n [] = (0, replicate n 0)
+ f 0 (i:_) = (if i >= b2 then 1 else 0, [])
+ f d (i:is) =
+ let (c, ds) = f (d-1) is
+ i' = c + i
+ in if i' == base then (1, 0:ds) else (0, i':ds)
+
+-- Based on "Printing Floating-Point Numbers Quickly and Accurately"
+-- by R.G. Burger and R. K. Dybvig, in PLDI 96.
+-- This version uses a much slower logarithm estimator. It should be improved.
+
+-- This function returns a list of digits (Ints in [0..base-1]) and an
+-- exponent.
+
+floatToDigits :: (RealFloat a) => Integer -> a -> ([Int], Int)
+
+floatToDigits _ 0 = ([0], 0)
+floatToDigits base x =
+ let (f0, e0) = decodeFloat x
+ (minExp0, _) = floatRange x
+ p = floatDigits x
+ b = floatRadix x
+ minExp = minExp0 - p -- the real minimum exponent
+ -- Haskell requires that f be adjusted so denormalized numbers
+ -- will have an impossibly low exponent. Adjust for this.
+ (f, e) = let n = minExp - e0
+ in if n > 0 then (f0 `div` (b^n), e0+n) else (f0, e0)
+
+ (r, s, mUp, mDn) =
+ if e >= 0 then
+ let be = b^e in
+ if f == b^(p-1) then
+ (f*be*b*2, 2*b, be*b, b)
+ else
+ (f*be*2, 2, be, be)
+ else
+ if e > minExp && f == b^(p-1) then
+ (f*b*2, b^(-e+1)*2, b, 1)
+ else
+ (f*2, b^(-e)*2, 1, 1)
+ k =
+ let k0 =
+ if b == 2 && base == 10 then
+ -- logBase 10 2 is slightly bigger than 3/10 so
+ -- the following will err on the low side. Ignoring
+ -- the fraction will make it err even more.
+ -- Haskell promises that p-1 <= logBase b f < p.
+ (p - 1 + e0) * 3 `div` 10
+ else
+ ceiling ((log (fromInteger (f+1)) +
+ fromInt e * log (fromInteger b)) /
+ log (fromInteger base))
+ fixup n =
+ if n >= 0 then
+ if r + mUp <= expt base n * s then n else fixup (n+1)
+ else
+ if expt base (-n) * (r + mUp) <= s then n
+ else fixup (n+1)
+ in fixup k0
+
+ gen ds rn sN mUpN mDnN =
+ let (dn, rn') = (rn * base) `divMod` sN
+ mUpN' = mUpN * base
+ mDnN' = mDnN * base
+ in case (rn' < mDnN', rn' + mUpN' > sN) of
+ (True, False) -> dn : ds
+ (False, True) -> dn+1 : ds
+ (True, True) -> if rn' * 2 < sN then dn : ds else dn+1 : ds
+ (False, False) -> gen (dn:ds) rn' sN mUpN' mDnN'
+ rds =
+ if k >= 0 then
+ gen [] r (s * expt base k) mUp mDn
+ else
+ let bk = expt base (-k)
+ in gen [] (r * bk) s (mUp * bk) (mDn * bk)
+ in (map toInt (reverse rds), k)
+
+
+-- Exponentiation with a cache for the most common numbers.
+minExpt = 0::Int
+maxExpt = 1100::Int
+expt :: Integer -> Int -> Integer
+expt base n =
+ if base == 2 && n >= minExpt && n <= maxExpt then
+ expts !! (n-minExpt)
+ else
+ base^n
+
+expts :: [Integer]
+expts = [2^n | n <- [minExpt .. maxExpt]]
+
+
+irrefutPatError
+ , noMethodBindingError
+ , nonExhaustiveGuardsError
+ , patError
+ , recSelError
+ , recConError
+ , recUpdError :: String -> a
+
+noMethodBindingError s = throw (NoMethodError (untangle s "No instance nor default method for class operation"))
+irrefutPatError s = throw (PatternMatchFail (untangle s "Irrefutable pattern failed for pattern"))
+nonExhaustiveGuardsError s = throw (NonExhaustiveGuards (untangle s "Non-exhaustive guards in"))
+patError s = throw (PatternMatchFail (untangle s "Non-exhaustive patterns in"))
+recSelError s = throw (RecSelError (untangle s "Missing field in record selection"))
+recConError s = throw (RecConError (untangle s "Missing field in record construction"))
+recUpdError s = throw (RecUpdError (untangle s "Record doesn't contain field(s) to be updated"))
+
+
+tangleMessage :: String -> Int -> String
+tangleMessage "" line = show line
+tangleMessage str line = str ++ show line
+
+assertError :: String -> Bool -> a -> a
+assertError str pred v
+ | pred = v
+ | otherwise = throw (AssertionFailed (untangle str "Assertion failed"))
+
+{-
+(untangle coded message) expects "coded" to be of the form
+
+ "location|details"
+
+It prints
+
+ location message details
+-}
+
+untangle :: String -> String -> String
+untangle coded message
+ = location
+ ++ ": "
+ ++ message
+ ++ details
+ ++ "\n"
+ where
+ (location, details)
+ = case (span not_bar coded) of { (loc, rest) ->
+ case rest of
+ ('|':det) -> (loc, ' ' : det)
+ _ -> (loc, "")
+ }
+ not_bar c = c /= '|'
+
+-- By default, we ignore asserts, but optionally, Hugs translates
+-- assert ==> assertError "<location info>"
+
+assert :: Bool -> a -> a
+assert _ a = a
+
projects / ghc-hetmet.git / commitdiff