[project @ 2000-09-07 09:10:07 by simonpj]

[ghc-hetmet.git] / ghc / lib / std / PrelBase.lhs

diff --git a/ghc/lib/std/PrelBase.lhs b/ghc/lib/std/PrelBase.lhs
index 7f2a8a9..315469d 100644 (file)
--- a/ghc/lib/std/PrelBase.lhs
+++ b/ghc/lib/std/PrelBase.lhs
@@ -1,5 +1,7 @@
+% -----------------------------------------------------------------------------
+% $Id: PrelBase.lhs,v 1.37 2000/09/07 09:10:07 simonpj Exp $
 %
-% (c) The GRAP/AQUA Project, Glasgow University, 1992-1996
+% (c) The University of Glasgow, 1992-2000
 %
 \section[PrelBase]{Module @PrelBase@}
 
@@ -76,16 +78,15 @@ Other Prelude modules are much easier with fewer complex dependencies.
 module PrelBase
        (
        module PrelBase,
-       module PrelGHC          -- Re-export PrelGHC, to avoid lots of people 
-                               -- having to import it explicitly
+       module PrelGHC,         -- Re-export PrelGHC, PrelErr & PrelNum, to avoid lots
+       module PrelErr,         -- of people having to import it explicitly
+       module PrelNum
   ) 
        where
 
-import {-# SOURCE #-} PrelErr ( error )
-import {-# SOURCE #-} PrelNum ( addr2Integer )
-  -- Otherwise the system import of addr2Integer looks for PrelNum.hi
-
 import PrelGHC
+import {-# SOURCE #-} PrelErr
+import {-# SOURCE #-} PrelNum
 
 infixr 9  .
 infixr 5  ++, :
@@ -107,14 +108,14 @@ default ()                -- Double isn't available yet
 %*********************************************************
 
 \begin{code}
-{-             
+{-
 data  Bool  =  False | True
 data Ordering = LT | EQ | GT 
 data Char = C# Char#
 type  String = [Char]
 data Int = I# Int#
 data  ()  =  ()
--- data [] a = MkNil
+data [] a = MkNil
 
 not True = False
 (&&) True True = True
@@ -123,14 +124,14 @@ otherwise = True
 build = error "urk"
 foldr = error "urk"
 
-unpackCString#  :: Addr# -> [Char]
-unpackFoldrCString#  :: Addr# -> (Char  -> a -> a) -> a -> a 
+unpackCString# :: Addr# -> [Char]
+unpackFoldrCString# :: Addr# -> (Char  -> a -> a) -> a -> a 
 unpackAppendCString# :: Addr# -> [Char] -> [Char]
-unpackNBytes#      :: Addr# -> Int#   -> [Char]
-unpackNBytes# a b = error "urk"
+unpackCStringUtf8# :: Addr# -> [Char]
 unpackCString# a = error "urk"
 unpackFoldrCString# a = error "urk"
 unpackAppendCString# a = error "urk"
+unpackCStringUtf8# a = error "urk"
 -}
 \end{code}
 
@@ -184,7 +185,7 @@ class  (Eq a) => Ord a  where
 
 \begin{code}
 class  Functor f  where
-    fmap         :: (a -> b) -> f a -> f b
+    fmap        :: (a -> b) -> f a -> f b
 
 class  Monad m  where
     (>>=)       :: m a -> (a -> m b) -> m b
@@ -194,7 +195,6 @@ class  Monad m  where
 
     m >> k      =  m >>= \_ -> k
     fail s      = error s
-
 \end{code}
 
 
@@ -439,7 +439,11 @@ instance Ord Char where
   (C# c1) <  (C# c2) = c1 `ltChar#` c2
 
 chr :: Int -> Char
-chr (I# i) | i >=# 0# && i <=# 255# = C# (chr# i)
+chr (I# i) | i >=# 0#
+#if INT_SIZE_IN_BYTES > 4
+             && i <=# 0x7FFFFFFF#
+#endif
+             = C# (chr# i)
           | otherwise = error ("Prelude.chr: bad argument")
 
 unsafeChr :: Int -> Char
@@ -449,6 +453,20 @@ ord :: Char -> Int
 ord (C# c) =  I# (ord# c)
 \end{code}
 
+String equality is used when desugaring pattern-matches against strings.
+It's worth making it fast, and providing a rule to use the fast version
+where possible.
+
+\begin{code}
+eqString :: String -> String -> Bool
+eqString []            []            = True
+eqString (C# c1 : cs1) (C# c2 : cs2) = c1 `eqChar#` c2 && cs1 `eqString` cs2
+eqString _            _             = False
+
+{-# RULES
+"eqString"  (==) = eqString
+  #-}  
+\end{code}
 
 %*********************************************************
 %*                                                     *
@@ -622,10 +640,10 @@ This code is needed for virtually all programs, since it's used for
 unpacking the strings of error messages.
 
 \begin{code}
-unpackCString#  :: Addr# -> [Char]
+unpackCString# :: Addr# -> [Char]
 unpackCString# a = unpackCStringList# a
 
-unpackCStringList#  :: Addr# -> [Char]
+unpackCStringList# :: Addr# -> [Char]
 unpackCStringList# addr 
   = unpack 0#
   where
@@ -645,7 +663,7 @@ unpackAppendCString# addr rest
       where
        ch = indexCharOffAddr# addr nh
 
-unpackFoldrCString#  :: Addr# -> (Char  -> a -> a) -> a -> a 
+unpackFoldrCString# :: Addr# -> (Char  -> a -> a) -> a -> a 
 unpackFoldrCString# addr f z 
   = unpack 0#
   where
@@ -655,11 +673,43 @@ unpackFoldrCString# addr f z
       where
        ch = indexCharOffAddr# addr nh
 
-unpackNBytes#      :: Addr# -> Int#   -> [Char]
-  -- This one is called by the compiler to unpack literal 
-  -- strings with NULs in them; rare. It's strict!
-  -- We don't try to do list deforestation for this one
+unpackCStringUtf8# :: Addr# -> [Char]
+unpackCStringUtf8# addr 
+  = unpack 0#
+  where
+    unpack nh
+      | ch `eqChar#` '\0'# = []
+      | ch `leChar#` '\x7F'# = C# ch : unpack (nh +# 1#)
+      | ch `leChar#` '\xDF'# = C# (chr# ((ord# ch                                  `iShiftL#`  6#) +#
+                                         (ord# (indexCharOffAddr# addr (nh +# 1#))) -# 0x3080#))
+                               : unpack (nh +# 2#)
+      | ch `leChar#` '\xEF'# = C# (chr# ((ord# ch                                  `iShiftL#` 12#) +#
+                                         (ord# (indexCharOffAddr# addr (nh +# 1#)) `iShiftL#`  6#) +#
+                                         (ord# (indexCharOffAddr# addr (nh +# 2#))) -# 0xE2080#))
+                               : unpack (nh +# 3#)
+      | ch `leChar#` '\xF7'# = C# (chr# ((ord# ch                                  `iShiftL#` 18#) +#
+                                         (ord# (indexCharOffAddr# addr (nh +# 1#)) `iShiftL#` 12#) +#
+                                         (ord# (indexCharOffAddr# addr (nh +# 2#)) `iShiftL#`  6#) +#
+                                         (ord# (indexCharOffAddr# addr (nh +# 3#))) -# 0x3C82080#))
+                               : unpack (nh +# 4#)
+      | ch `leChar#` '\xFB'# = C# (chr# ((ord# ch -# 0xF8#                         `iShiftL#` 24#) +#
+                                         (ord# (indexCharOffAddr# addr (nh +# 1#)) `iShiftL#` 18#) +#
+                                         (ord# (indexCharOffAddr# addr (nh +# 2#)) `iShiftL#` 12#) +#
+                                         (ord# (indexCharOffAddr# addr (nh +# 3#)) `iShiftL#`  6#) +#
+                                         (ord# (indexCharOffAddr# addr (nh +# 4#))) -# 0x2082080#))
+                               : unpack (nh +# 5#)
+      | otherwise           = C# (chr# (((ord# ch -# 0xFC#)                        `iShiftL#` 30#) +#
+                                        ((ord# (indexCharOffAddr# addr (nh +# 1#)) -# 0x80#)
+                                                                                   `iShiftL#` 24#) +#
+                                         (ord# (indexCharOffAddr# addr (nh +# 2#)) `iShiftL#` 18#) +#
+                                         (ord# (indexCharOffAddr# addr (nh +# 3#)) `iShiftL#` 12#) +#
+                                         (ord# (indexCharOffAddr# addr (nh +# 4#)) `iShiftL#`  6#) +#
+                                         (ord# (indexCharOffAddr# addr (nh +# 5#))) -# 0x2082080#))
+                               : unpack (nh +# 6#)
+      where
+       ch = indexCharOffAddr# addr nh
 
+unpackNBytes# :: Addr# -> Int# -> [Char]
 unpackNBytes# _addr 0#   = []
 unpackNBytes#  addr len# = unpack [] (len# -# 1#)
     where
@@ -678,5 +728,4 @@ unpackNBytes#  addr len# = unpack [] (len# -# 1#)
 --     unpackFoldr "foo" c (unpackFoldr "baz" c n)  =  unpackFoldr "foobaz" c n
 
   #-}
-
 \end{code}