From b287d1d7082f03a18e302e0ea58c97b56422ae7b Mon Sep 17 00:00:00 2001 From: andy Date: Thu, 6 Apr 2000 00:01:27 +0000 Subject: [PATCH] [project @ 2000-04-06 00:01:26 by andy] Changing PrimPrel to PrelPrim. --- ghc/interpreter/connect.h | 8 +- ghc/interpreter/hugs.c | 8 +- ghc/interpreter/input.c | 8 +- ghc/interpreter/lib/Makefile | 4 +- ghc/interpreter/link.c | 18 +- ghc/interpreter/static.c | 6 +- ghc/interpreter/storage.c | 6 +- ghc/interpreter/type.c | 6 +- ghc/lib/hugs/PrelPrim.hs | 2375 ++++++++++++++++++++++++++++++++++++++++++ ghc/lib/hugs/Prelude.hs | 2 +- 10 files changed, 2407 insertions(+), 34 deletions(-) create mode 100644 ghc/lib/hugs/PrelPrim.hs diff --git a/ghc/interpreter/connect.h b/ghc/interpreter/connect.h index 9f2c36b..55ef3d6 100644 --- a/ghc/interpreter/connect.h +++ b/ghc/interpreter/connect.h @@ -9,8 +9,8 @@ * included in the distribution. * * $RCSfile: connect.h,v $ - * $Revision: 1.36 $ - * $Date: 2000/04/04 17:35:04 $ + * $Revision: 1.37 $ + * $Date: 2000/04/06 00:01:26 $ * ------------------------------------------------------------------------*/ /* -------------------------------------------------------------------------- @@ -18,7 +18,7 @@ * Texts, Names, Instances, Classes, Types, Kinds and Modules * ------------------------------------------------------------------------*/ -extern Text textPrimPrel; +extern Text textPrelPrim; extern Text textPrelude; extern Text textNum; /* used to process default decls */ extern Text textCcall; /* used to process foreign import */ @@ -221,7 +221,7 @@ extern Type typeST; extern Type typeIO; extern Type typeException; -extern Module modulePrimPrel; +extern Module modulePrelPrim; extern Module modulePrelude; extern Kind starToStar; /* Type -> Type */ diff --git a/ghc/interpreter/hugs.c b/ghc/interpreter/hugs.c index 461b253..8a0b745 100644 --- a/ghc/interpreter/hugs.c +++ b/ghc/interpreter/hugs.c @@ -9,8 +9,8 @@ * included in the distribution. * * $RCSfile: hugs.c,v $ - * $Revision: 1.60 $ - * $Date: 2000/04/05 16:57:18 $ + * $Revision: 1.61 $ + * $Date: 2000/04/06 00:01:26 $ * ------------------------------------------------------------------------*/ #include @@ -948,9 +948,8 @@ static void mgFromList ( List /* of CONID */ modgList ) usesT = cons(textOf(hd(u)),usesT); /* artificially give all modules a dependency on Prelude */ - if (mT != textPrelude && mT != textPrimPrel) + if (mT != textPrelude && mT != textPrelPrim) usesT = cons(textPrelude,usesT); - adjList = cons(pair(mT,usesT),adjList); } @@ -1174,7 +1173,6 @@ static Module parseModuleOrInterface ( ConId mc, Cell modeRequest ) internal("parseModuleOrInterface"); } - /* Actually do the parsing. */ if (useSource) { module(mod).srcExt = findText(sExt); diff --git a/ghc/interpreter/input.c b/ghc/interpreter/input.c index 99c8ae9..555659a 100644 --- a/ghc/interpreter/input.c +++ b/ghc/interpreter/input.c @@ -9,8 +9,8 @@ * included in the distribution. * * $RCSfile: input.c,v $ - * $Revision: 1.25 $ - * $Date: 2000/04/04 01:07:49 $ + * $Revision: 1.26 $ + * $Date: 2000/04/06 00:01:26 $ * ------------------------------------------------------------------------*/ #include "hugsbasictypes.h" @@ -151,7 +151,7 @@ Text textCcall; /* ccall */ Text textStdcall; /* stdcall */ Text textNum; /* Num */ -Text textPrimPrel; /* PrimPrel */ +Text textPrelPrim; /* PrelPrim */ Text textPrelude; /* Prelude */ Text textPlus; /* (+) */ @@ -1700,7 +1700,7 @@ Int what; { textBang = findText("!"); textDot = findText("."); textImplies = findText("=>"); - textPrimPrel = findText("PrimPrel"); + textPrelPrim = findText("PrelPrim"); textPrelude = findText("Prelude"); textNum = findText("Num"); textModule = findText("module"); diff --git a/ghc/interpreter/lib/Makefile b/ghc/interpreter/lib/Makefile index d77ebf0..da8120c 100644 --- a/ghc/interpreter/lib/Makefile +++ b/ghc/interpreter/lib/Makefile @@ -1,11 +1,11 @@ # -------------------------------------------------------------------------- # -# $Id: Makefile,v 1.10 2000/04/04 18:27:46 andy Exp $ +# $Id: Makefile,v 1.11 2000/04/06 00:01:27 andy Exp $ # -------------------------------------------------------------------------- # TOP = ../.. include $(TOP)/mk/boilerplate.mk -PRELUDE = Prelude.hs PrimPrel.hs +PRELUDE = Prelude.hs PrelPrim.hs STD_LIBS = Array.lhs Char.lhs Complex.lhs CPUTime.lhs \ Directory.lhs IO.lhs Ix.lhs List.lhs Locale.lhs \ diff --git a/ghc/interpreter/link.c b/ghc/interpreter/link.c index 8027770..e65dccb 100644 --- a/ghc/interpreter/link.c +++ b/ghc/interpreter/link.c @@ -9,8 +9,8 @@ * included in the distribution. * * $RCSfile: link.c,v $ - * $Revision: 1.56 $ - * $Date: 2000/04/04 15:41:56 $ + * $Revision: 1.57 $ + * $Date: 2000/04/06 00:01:26 $ * ------------------------------------------------------------------------*/ #include "hugsbasictypes.h" @@ -188,7 +188,7 @@ Name namePlus; Name nameMult; Name nameMFail; Type typeOrdering; -Module modulePrimPrel; +Module modulePrelPrim; Module modulePrelude; Name nameMap; Name nameMinus; @@ -299,7 +299,7 @@ Void linkPreludeTC(void) { /* Hook to tycons and classes in */ if (combined) { setCurrModule(modulePrelude); } else { - setCurrModule(modulePrimPrel); + setCurrModule(modulePrelPrim); } typeChar = linkTycon("Char"); @@ -412,7 +412,7 @@ Void linkPreludeCM(void) { /* Hook to cfuns and mfuns in */ if (combined) { setCurrModule(modulePrelude); } else { - setCurrModule(modulePrimPrel); + setCurrModule(modulePrelPrim); } /* constructors */ @@ -459,7 +459,7 @@ Void linkPrimNames ( void ) { /* Hook to names defined in Prelude */ if (combined) { setCurrModule(modulePrelude); } else { - setCurrModule(modulePrimPrel); + setCurrModule(modulePrelPrim); } /* primops */ @@ -703,14 +703,14 @@ assert(nonNull(namePMFail)); } else { fixupRTStoPreludeRefs(NULL); - modulePrimPrel = findFakeModule(textPrimPrel); + modulePrelPrim = findFakeModule(textPrelPrim); modulePrelude = findFakeModule(textPrelude); - setCurrModule(modulePrimPrel); + setCurrModule(modulePrelPrim); for (i=0; i)"), pair(STAR,pair(STAR,STAR)), diff --git a/ghc/interpreter/static.c b/ghc/interpreter/static.c index 0c99493..3dc5133 100644 --- a/ghc/interpreter/static.c +++ b/ghc/interpreter/static.c @@ -9,8 +9,8 @@ * included in the distribution. * * $RCSfile: static.c,v $ - * $Revision: 1.37 $ - * $Date: 2000/04/05 14:14:51 $ + * $Revision: 1.38 $ + * $Date: 2000/04/06 00:01:27 $ * ------------------------------------------------------------------------*/ #include "hugsbasictypes.h" @@ -5031,7 +5031,7 @@ Void checkDefns ( Module thisModule ) { /* Top level static analysis */ mapProc(checkQualImport, module(thisModule).qualImports); mapProc(checkUnqualImport,unqualImports); /* Add "import Prelude" if there`s no explicit import */ - if (modName == textPrimPrel || modName == textPrelude) { + if (modName == textPrelPrim || modName == textPrelude) { /* Nothing. */ } else if (isNull(cellAssoc(modulePrelude,unqualImports)) && isNull(cellRevAssoc(modulePrelude,module(thisModule).qualImports))) { diff --git a/ghc/interpreter/storage.c b/ghc/interpreter/storage.c index cdb519b..e82660a 100644 --- a/ghc/interpreter/storage.c +++ b/ghc/interpreter/storage.c @@ -9,8 +9,8 @@ * included in the distribution. * * $RCSfile: storage.c,v $ - * $Revision: 1.63 $ - * $Date: 2000/04/05 16:57:18 $ + * $Revision: 1.64 $ + * $Date: 2000/04/06 00:01:27 $ * ------------------------------------------------------------------------*/ #include "hugsbasictypes.h" @@ -1049,7 +1049,7 @@ Tycon addTupleTycon ( Int n ) if (combined) m = findFakeModule(findText(n==0 ? "PrelBase" : "PrelTup")); else - m = findModule(findText("PrimPrel")); + m = findModule(findText("PrelPrim")); setCurrModule(m); k = STAR; diff --git a/ghc/interpreter/type.c b/ghc/interpreter/type.c index c137513..063e469 100644 --- a/ghc/interpreter/type.c +++ b/ghc/interpreter/type.c @@ -9,8 +9,8 @@ * included in the distribution. * * $RCSfile: type.c,v $ - * $Revision: 1.32 $ - * $Date: 2000/04/04 01:07:49 $ + * $Revision: 1.33 $ + * $Date: 2000/04/06 00:01:27 $ * ------------------------------------------------------------------------*/ #include "hugsbasictypes.h" @@ -2853,7 +2853,7 @@ Int what; { } else { dummyVar = inventVar(); - setCurrModule(modulePrimPrel); + setCurrModule(modulePrelPrim); starToStar = simpleKind(1); diff --git a/ghc/lib/hugs/PrelPrim.hs b/ghc/lib/hugs/PrelPrim.hs new file mode 100644 index 0000000..8c15cc2 --- /dev/null +++ b/ghc/lib/hugs/PrelPrim.hs @@ -0,0 +1,2375 @@ +{---------------------------------------------------------------------------- +__ __ __ __ ____ ___ _______________________________________________ +|| || || || || || ||__ 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 PrelPrim ( +-- 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. + + , AsyncException(..) + , ArithException(..) + , Dynamic(..) + , Exception(..) + , IORef + , PrimArray + , PrimMutableArray + , RealWorld + , ST + , STRef + , TyCon(..) + , TypeRep(..) + , assert + , copy_String_to_cstring + , ioToST + , ioToST + , newIORef + , newSTRef + , nh_close + , nh_errno + , nh_exitwith + , nh_filesize + , nh_flush + , nh_free + , nh_getCPUprec + , nh_getCPUtime + , nh_getPID + , nh_iseof + , nh_open + , nh_read + , nh_stderr + , nh_stdin + , nh_stdout + , nh_system + , nh_write + , nullAddr + , prelCleanupAfterRunAction + , primGetEnv + , primGetRawArgs + , primIndexArray + , primIntToChar + , primNewArray + , primReadArray + , primReallyUnsafePtrEquality + , primSizeArray + , primSizeMutableArray + , primUnsafeCoerce + , primUnsafeFreezeArray + , primWriteArray + , primWriteCharOffAddr + , readIORef + , readSTRef + , runST + , stToIO + , throw + , unST + , unsafeInterleaveIO + , unsafeInterleaveST + , unsafePerformIO + , unsafePerformIO + , writeIORef + , writeSTRef + , catchException + ) 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 [] = [] +map f (x:xs) = f x : map f xs + + +filter :: (a -> Bool) -> [a] -> [a] +filter p [] = [] +filter p (x:xs) = if p x then x : filter p xs else filter p xs + + +concat :: [[a]] -> [a] +concat [] = [] +concat (xs:xss) = xs ++ concat xss + +length :: [a] -> Int +length = foldl' (\n _ -> n + 1) 0 + +(!!) :: [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 ("error: " ++ 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 "<>" + +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 "" + +assert :: Bool -> a -> a +assert _ a = a + diff --git a/ghc/lib/hugs/Prelude.hs b/ghc/lib/hugs/Prelude.hs index d8ed39f..a9c71f8 100644 --- a/ghc/lib/hugs/Prelude.hs +++ b/ghc/lib/hugs/Prelude.hs @@ -88,5 +88,5 @@ module Prelude ( -- Now we have the extra (non standard) thing. ) where -import PrimPrel +import PrelPrim -- 1.7.10.4