Merge branch 'master' into type-nats
authorIavor S. Diatchki <iavor.diatchki@gmail.com>
Thu, 29 Dec 2011 22:36:08 +0000 (14:36 -0800)
committerIavor S. Diatchki <iavor.diatchki@gmail.com>
Thu, 29 Dec 2011 22:36:08 +0000 (14:36 -0800)
257 files changed:
.darcs-boring [deleted file]
Control/Arrow.hs
Control/Concurrent.hs
Control/Exception/Base.hs
Control/Monad/Group.hs
Control/Monad/Instances.hs
Control/Monad/ST.hs
Control/Monad/ST/Imp.hs
Control/Monad/ST/Lazy.hs
Control/Monad/ST/Lazy/Imp.hs
Control/Monad/ST/Lazy/Unsafe.hs
Control/Monad/ST/Strict.hs
Control/Monad/ST/Unsafe.hs
Control/Monad/Zip.hs
Data/Bits.hs
Data/Bool.hs
Data/Char.hs
Data/Complex.hs
Data/Data.hs
Data/Dynamic.hs
Data/Eq.hs
Data/Fixed.hs
Data/Foldable.hs
Data/Function.hs
Data/Functor.hs
Data/HashTable.hs
Data/IORef.hs
Data/Int.hs
Data/Ix.hs
Data/List.hs
Data/Maybe.hs
Data/Monoid.hs
Data/Ord.hs
Data/Ratio.hs
Data/STRef.hs
Data/STRef/Lazy.hs
Data/STRef/Strict.hs
Data/String.hs
Data/Traversable.hs
Data/Tuple.hs
Data/Typeable.hs
Data/Typeable.hs-boot
Data/Typeable/Internal.hs [new file with mode: 0644]
Data/Typeable/Internal.hs-boot [new file with mode: 0644]
Data/Word.hs
Debug/Trace.hs
Foreign.hs
Foreign/C.hs
Foreign/C/Error.hs
Foreign/C/String.hs
Foreign/C/Types.hs
Foreign/ForeignPtr.hs
Foreign/ForeignPtr/Imp.hs
Foreign/ForeignPtr/Unsafe.hs
Foreign/Marshal.hs
Foreign/Marshal/Alloc.hs
Foreign/Marshal/Array.hs
Foreign/Marshal/Error.hs
Foreign/Marshal/Pool.hs
Foreign/Marshal/Unsafe.hs
Foreign/Marshal/Utils.hs
Foreign/Ptr.hs
Foreign/StablePtr.hs
Foreign/Storable.hs
GHC/Arr.lhs
GHC/Base.lhs
GHC/Classes.hs [deleted file]
GHC/Conc.lhs
GHC/Conc/IO.hs
GHC/Conc/Sync.lhs
GHC/Conc/Windows.hs
GHC/ConsoleHandler.hs
GHC/Constants.hs
GHC/Desugar.hs
GHC/Enum.lhs
GHC/Environment.hs
GHC/Event.hs
GHC/Event/Array.hs
GHC/Event/Clock.hsc
GHC/Event/Control.hs
GHC/Event/EPoll.hsc
GHC/Event/IntMap.hs
GHC/Event/Internal.hs
GHC/Event/KQueue.hsc
GHC/Event/Manager.hs
GHC/Event/PSQ.hs
GHC/Event/Poll.hsc
GHC/Event/Thread.hs
GHC/Event/Unique.hs
GHC/Exception.lhs
GHC/Exts.hs [changed mode: 0644->0755]
GHC/Fingerprint.hs [new file with mode: 0644]
GHC/Fingerprint.hs-boot [new file with mode: 0644]
GHC/Fingerprint/Type.hs [new file with mode: 0644]
GHC/Float.lhs
GHC/Float/ConversionUtils.hs
GHC/Float/RealFracMethods.hs
GHC/Foreign.hs
GHC/ForeignPtr.hs
GHC/Handle.hs
GHC/IO.hs
GHC/IO.hs-boot
GHC/IO/Buffer.hs
GHC/IO/BufferedIO.hs
GHC/IO/Device.hs
GHC/IO/Encoding.hs
GHC/IO/Encoding.hs-boot
GHC/IO/Encoding/CodePage.hs
GHC/IO/Encoding/Failure.hs
GHC/IO/Encoding/Iconv.hs
GHC/IO/Encoding/Latin1.hs
GHC/IO/Encoding/Types.hs
GHC/IO/Encoding/UTF16.hs
GHC/IO/Encoding/UTF32.hs
GHC/IO/Encoding/UTF8.hs
GHC/IO/Exception.hs
GHC/IO/Exception.hs-boot
GHC/IO/FD.hs
GHC/IO/Handle.hs
GHC/IO/Handle.hs-boot
GHC/IO/Handle/FD.hs
GHC/IO/Handle/FD.hs-boot
GHC/IO/Handle/Internals.hs
GHC/IO/Handle/Text.hs
GHC/IO/Handle/Types.hs
GHC/IO/IOMode.hs
GHC/IOArray.hs
GHC/IOBase.hs
GHC/IORef.hs
GHC/Int.hs
GHC/List.lhs
GHC/MVar.hs
GHC/Num.lhs
GHC/PArr.hs
GHC/Pack.lhs
GHC/Ptr.lhs
GHC/Real.lhs
GHC/ST.lhs
GHC/STRef.lhs
GHC/Show.lhs
GHC/Stable.lhs
GHC/Stack.hsc [new file with mode: 0644]
GHC/Stats.hsc [new file with mode: 0644]
GHC/TopHandler.lhs
GHC/Unicode.hs
GHC/Unicode.hs-boot
GHC/Weak.lhs
GHC/Windows.hs
GHC/Word.hs
Numeric.hs
System/CPUTime.hsc
System/Console/GetOpt.hs
System/Environment.hs
System/Exit.hs
System/IO.hs
System/IO/Error.hs
System/IO/Unsafe.hs
System/Info.hs
System/Mem.hs
System/Mem/StableName.hs
System/Mem/Weak.hs
System/Posix/Internals.hs
System/Posix/Internals.hs-boot
System/Posix/Types.hs
System/Timeout.hs
Text/ParserCombinators/ReadP.hs
Text/ParserCombinators/ReadPrec.hs
Text/Printf.hs
Text/Read.hs
Text/Read/Lex.hs
Text/Show.hs
Text/Show/Functions.hs
Unsafe/Coerce.hs
base.cabal
cbits/md5.c [new file with mode: 0644]
cbits/primFloat.c
configure.ac
include/CTypes.h
include/HsBase.h
include/md5.h [new file with mode: 0644]
tests/CPUTime001.hs [new file with mode: 0644]
tests/CPUTime001.stdout [new file with mode: 0644]
tests/Numeric/Makefile [new file with mode: 0644]
tests/Numeric/all.T [new file with mode: 0644]
tests/Numeric/num001.hs [new file with mode: 0644]
tests/Numeric/num001.stdout [new file with mode: 0644]
tests/Numeric/num002.hs [new file with mode: 0644]
tests/Numeric/num002.stdout [new file with mode: 0644]
tests/Numeric/num002.stdout-alpha-dec-osf3 [new file with mode: 0644]
tests/Numeric/num002.stdout-mips-sgi-irix [new file with mode: 0644]
tests/Numeric/num002.stdout-ws-64 [new file with mode: 0644]
tests/Numeric/num002.stdout-x86_64-unknown-openbsd [new file with mode: 0644]
tests/Numeric/num003.hs [new file with mode: 0644]
tests/Numeric/num003.stdout [new file with mode: 0644]
tests/Numeric/num003.stdout-alpha-dec-osf3 [new file with mode: 0644]
tests/Numeric/num003.stdout-mips-sgi-irix [new file with mode: 0644]
tests/Numeric/num003.stdout-ws-64 [new file with mode: 0644]
tests/Numeric/num003.stdout-x86_64-unknown-openbsd [new file with mode: 0644]
tests/Numeric/num004.hs [new file with mode: 0644]
tests/Numeric/num004.stdout [new file with mode: 0644]
tests/Numeric/num004.stdout-alpha-dec-osf3 [new file with mode: 0644]
tests/Numeric/num004.stdout-mips-sgi-irix [new file with mode: 0644]
tests/Numeric/num004.stdout-ws-64 [new file with mode: 0644]
tests/Numeric/num004.stdout-x86_64-unknown-openbsd [new file with mode: 0644]
tests/Numeric/num005.hs [new file with mode: 0644]
tests/Numeric/num005.stdout [new file with mode: 0644]
tests/Numeric/num005.stdout-alpha-dec-osf3 [new file with mode: 0644]
tests/Numeric/num005.stdout-mips-sgi-irix [new file with mode: 0644]
tests/Numeric/num005.stdout-ws-64 [new file with mode: 0644]
tests/Numeric/num005.stdout-x86_64-unknown-openbsd [new file with mode: 0644]
tests/Numeric/num006.hs [new file with mode: 0644]
tests/Numeric/num006.stdout [new file with mode: 0644]
tests/Numeric/num007.hs [new file with mode: 0644]
tests/Numeric/num007.stdout [new file with mode: 0644]
tests/Numeric/num008.hs [new file with mode: 0644]
tests/Numeric/num008.stdout [new file with mode: 0644]
tests/Numeric/num009.hs [new file with mode: 0644]
tests/Numeric/num009.stdout [new file with mode: 0644]
tests/Numeric/num010.hs [new file with mode: 0644]
tests/Numeric/num010.stdout [new file with mode: 0644]
tests/System/Makefile [new file with mode: 0644]
tests/System/all.T [new file with mode: 0644]
tests/System/exitWith001.hs [new file with mode: 0644]
tests/System/exitWith001.stdout [new file with mode: 0644]
tests/System/getArgs001.hs [new file with mode: 0644]
tests/System/getArgs001.stdout [new file with mode: 0644]
tests/System/getEnv001.hs [new file with mode: 0644]
tests/System/getEnv001.stdout [new file with mode: 0644]
tests/System/system001.hs [new file with mode: 0644]
tests/System/system001.stdout [new file with mode: 0644]
tests/all.T
tests/assert.hs [new file with mode: 0644]
tests/assert.stderr [new file with mode: 0644]
tests/data-fixed-show-read.hs [new file with mode: 0644]
tests/data-fixed-show-read.stdout [new file with mode: 0644]
tests/genericNegative001.hs [new file with mode: 0644]
tests/genericNegative001.stdout [new file with mode: 0644]
tests/hash001.hs [new file with mode: 0644]
tests/ioref001.hs [new file with mode: 0644]
tests/ioref001.stdout [new file with mode: 0644]
tests/ix001.hs [new file with mode: 0644]
tests/ix001.stdout [new file with mode: 0644]
tests/lexNum.hs [new file with mode: 0644]
tests/lexNum.stdout [new file with mode: 0644]
tests/quotOverflow.hs [new file with mode: 0644]
tests/quotOverflow.stdout [new file with mode: 0644]
tests/readLitChar.hs [new file with mode: 0644]
tests/readLitChar.stdout [new file with mode: 0644]
tests/showDouble.hs [new file with mode: 0644]
tests/showDouble.stdout [new file with mode: 0644]
tests/take001.hs [new file with mode: 0644]
tests/take001.stdout [new file with mode: 0644]
tests/unicode001.hs [new file with mode: 0644]
tests/unicode001.stdout [new file with mode: 0644]
tests/unicode001.stdout-hugs [new file with mode: 0644]
tests/unicode002.hs [new file with mode: 0644]
tests/unicode002.stdout [new file with mode: 0644]

diff --git a/.darcs-boring b/.darcs-boring
deleted file mode 100644 (file)
index 288894b..0000000
+++ /dev/null
@@ -1,12 +0,0 @@
-^dist(/|$)
-^setup(/|$)
-^GNUmakefile$
-^Makefile.local$
-^.depend(.bak)?$
-^autom4te.cache(/|$)
-^config.log$
-^config.status$
-^configure$
-^include/HsBaseConfig.h$
-^include/HsBaseConfig.h.in$
-^include/HsBaseConfig.h.in~$
index 012a75a..8915f09 100644 (file)
@@ -6,17 +6,16 @@
 -- License     :  BSD-style (see the LICENSE file in the distribution)
 --
 -- Maintainer  :  libraries@haskell.org
--- Stability   :  experimental
+-- Stability   :  provisional
 -- Portability :  portable
 --
 -- Basic arrow definitions, based on
---      /Generalising Monads to Arrows/, by John Hughes,
---      /Science of Computer Programming/ 37, pp67-111, May 2000.
+--  * /Generalising Monads to Arrows/, by John Hughes,
+--    /Science of Computer Programming/ 37, pp67-111, May 2000.
 -- plus a couple of definitions ('returnA' and 'loop') from
---      /A New Notation for Arrows/, by Ross Paterson, in /ICFP 2001/,
---      Firenze, Italy, pp229-240.
--- See these papers for the equations these combinators are expected to
--- satisfy.  These papers and more information on arrows can be found at
+--  * /A New Notation for Arrows/, by Ross Paterson, in /ICFP 2001/,
+--    Firenze, Italy, pp229-240.
+-- These papers and more information on arrows can be found at
 -- <http://www.haskell.org/arrows/>.
 
 module Control.Arrow (
@@ -54,10 +53,28 @@ infixr 1 ^<<, <<^
 
 -- | The basic arrow class.
 --
---   Minimal complete definition: 'arr' and 'first'.
+-- Minimal complete definition: 'arr' and 'first', satisfying the laws
 --
---   The other combinators have sensible default definitions,
---   which may be overridden for efficiency.
+--  * @'arr' id = 'id'@
+--
+--  * @'arr' (f >>> g) = 'arr' f >>> 'arr' g@
+--
+--  * @'first' ('arr' f) = 'arr' ('first' f)@
+--
+--  * @'first' (f >>> g) = 'first' f >>> 'first' g@
+--
+--  * @'first' f >>> 'arr' 'fst' = 'arr' 'fst' >>> f@
+--
+--  * @'first' f >>> 'arr' ('id' *** g) = 'arr' ('id' *** g) >>> 'first' f@
+--
+--  * @'first' ('first' f) >>> 'arr' 'assoc' = 'arr' 'assoc' >>> 'first' f@
+--
+-- where
+--
+-- > assoc ((a,b),c) = (a,(b,c))
+--
+-- The other combinators have sensible default definitions,
+-- which may be overridden for efficiency.
 
 class Category a => Arrow a where
 
@@ -122,7 +139,6 @@ instance Arrow (->) where
     (***) f g ~(x,y) = (f x, g y)
 
 -- | Kleisli arrows of a monad.
-
 newtype Kleisli m a b = Kleisli { runKleisli :: a -> m b }
 
 instance Monad m => Category (Kleisli m) where
@@ -135,7 +151,6 @@ instance Monad m => Arrow (Kleisli m) where
     second (Kleisli f) = Kleisli (\ ~(d,b) -> f b >>= \c -> return (d,c))
 
 -- | The identity arrow, which plays the role of 'return' in arrow notation.
-
 returnA :: Arrow a => a b b
 returnA = arr id
 
@@ -161,16 +176,36 @@ class Arrow a => ArrowZero a where
 instance MonadPlus m => ArrowZero (Kleisli m) where
     zeroArrow = Kleisli (\_ -> mzero)
 
+-- | A monoid on arrows.
 class ArrowZero a => ArrowPlus a where
+    -- | An associative operation with identity 'zeroArrow'.
     (<+>) :: a b c -> a b c -> a b c
 
 instance MonadPlus m => ArrowPlus (Kleisli m) where
     Kleisli f <+> Kleisli g = Kleisli (\x -> f x `mplus` g x)
 
 -- | Choice, for arrows that support it.  This class underlies the
---   @if@ and @case@ constructs in arrow notation.
---   Any instance must define 'left'.  The other combinators have sensible
---   default definitions, which may be overridden for efficiency.
+-- @if@ and @case@ constructs in arrow notation.
+-- Minimal complete definition: 'left', satisfying the laws
+--
+--  * @'left' ('arr' f) = 'arr' ('left' f)@
+--
+--  * @'left' (f >>> g) = 'left' f >>> 'left' g@
+--
+--  * @'left' f >>> 'arr' 'Left' = 'arr' 'Left' >>> f@
+--
+--  * @'left' f >>> 'arr' ('id' +++ g) = 'arr' ('id' +++ g) >>> 'left' f@
+--
+--  * @'left' ('left' f) >>> 'arr' 'assocsum' = 'arr' 'assocsum' >>> 'left' f@
+--
+-- where
+--
+-- > assocsum (Left (Left x)) = Left x
+-- > assocsum (Left (Right y)) = Right (Left y)
+-- > assocsum (Right z) = Right (Right z)
+--
+-- The other combinators have sensible default definitions, which may
+-- be overridden for efficiency.
 
 class Arrow a => ArrowChoice a where
 
@@ -237,6 +272,15 @@ instance Monad m => ArrowChoice (Kleisli m) where
     Kleisli f ||| Kleisli g = Kleisli (either f g)
 
 -- | Some arrows allow application of arrow inputs to other inputs.
+-- Instances should satisfy the following laws:
+--
+--  * @'first' ('arr' (\\x -> 'arr' (\\y -> (x,y)))) >>> 'app' = 'id'@
+--
+--  * @'first' ('arr' (g >>>)) >>> 'app' = 'second' g >>> 'app'@
+--
+--  * @'first' ('arr' (>>> h)) >>> 'app' = 'app' >>> h@
+--
+-- Such arrows are equivalent to monads (see 'ArrowMonad').
 
 class Arrow a => ArrowApply a where
     app :: a (a b c, b) c
@@ -264,16 +308,43 @@ leftApp :: ArrowApply a => a b c -> a (Either b d) (Either c d)
 leftApp f = arr ((\b -> (arr (\() -> b) >>> f >>> arr Left, ())) |||
              (\d -> (arr (\() -> d) >>> arr Right, ()))) >>> app
 
--- | The 'loop' operator expresses computations in which an output value is
---   fed back as input, even though the computation occurs only once.
---   It underlies the @rec@ value recursion construct in arrow notation.
-
+-- | The 'loop' operator expresses computations in which an output value
+-- is fed back as input, although the computation occurs only once.
+-- It underlies the @rec@ value recursion construct in arrow notation.
+-- 'loop' should satisfy the following laws:
+--
+-- [/extension/]
+--      @'loop' ('arr' f) = 'arr' (\\ b -> 'fst' ('fix' (\\ (c,d) -> f (b,d))))@
+--
+-- [/left tightening/]
+--      @'loop' ('first' h >>> f) = h >>> 'loop' f@
+--
+-- [/right tightening/]
+--      @'loop' (f >>> 'first' h) = 'loop' f >>> h@
+--
+-- [/sliding/]
+--      @'loop' (f >>> 'arr' ('id' *** k)) = 'loop' ('arr' ('id' *** k) >>> f)@
+--
+-- [/vanishing/]
+--      @'loop' ('loop' f) = 'loop' ('arr' unassoc >>> f >>> 'arr' assoc)@
+--
+-- [/superposing/]
+--      @'second' ('loop' f) = 'loop' ('arr' assoc >>> 'second' f >>> 'arr' unassoc)@
+--
+-- where
+--
+-- > assoc ((a,b),c) = (a,(b,c))
+-- > unassoc (a,(b,c)) = ((a,b),c)
+--
 class Arrow a => ArrowLoop a where
     loop :: a (b,d) (c,d) -> a b c
 
 instance ArrowLoop (->) where
     loop f b = let (c,d) = f (b,d) in c
 
+-- | Beware that for many monads (those for which the '>>=' operation
+-- is strict) this instance will /not/ satisfy the right-tightening law
+-- required by the 'ArrowLoop' class.
 instance MonadFix m => ArrowLoop (Kleisli m) where
     loop (Kleisli f) = Kleisli (liftM fst . mfix . f')
       where f' x y = f (x, snd y)
index 04e0a8f..8f35069 100644 (file)
@@ -124,7 +124,7 @@ import GHC.Base
 
 import System.Posix.Types ( Fd )
 import Foreign.StablePtr
-import Foreign.C.Types  ( CInt )
+import Foreign.C.Types
 import Control.Monad    ( when )
 
 #ifdef mingw32_HOST_OS
@@ -559,7 +559,8 @@ foreign import ccall safe "fdReady"
       threads doing I\/O operations don't block the whole runtime,
       whereas on Unix systems all the currently blocked I\/O requests
       are managed by a single thread (the /IO manager thread/) using
-      @select@.
+      a mechanism such as @epoll@ or @kqueue@, depending on what is
+      provided by the host operating system.
 
       The runtime will run a Haskell thread using any of the available
       worker OS threads.  If you need control over which particular OS
index 8a0f7b0..e64656f 100644 (file)
@@ -358,8 +358,8 @@ blocked  = return False
 --
 -- Note that we have to give a type signature to @e@, or the program
 -- will not typecheck as the type is ambiguous. While it is possible
--- to catch exceptions of any type, see the previous section \"Catching all
--- exceptions\" for an explanation of the problems with doing so.
+-- to catch exceptions of any type, see the section \"Catching all
+-- exceptions\" (in "Control.Exception") for an explanation of the problems with doing so.
 --
 -- For catching exceptions in pure (non-'IO') expressions, see the
 -- function 'evaluate'.
index 3516562..a3c36a2 100644 (file)
@@ -1,4 +1,5 @@
 {-# LANGUAGE Trustworthy #-}
+
 -----------------------------------------------------------------------------
 -- |
 -- Module      :  Control.Monad.Group
@@ -32,3 +33,4 @@ class Monad m => MonadGroup m t where
 instance Ord t => MonadGroup [] t where
     mgroupWith = groupWith
 #endif
+
index 0cc1c53..3849e3b 100644 (file)
@@ -2,6 +2,7 @@
 {-# OPTIONS_NHC98 --prelude #-}
 -- This module deliberately declares orphan instances:
 {-# OPTIONS_GHC -fno-warn-orphans #-}
+
 -----------------------------------------------------------------------------
 -- |
 -- Module      :  Control.Monad.Instances
@@ -37,3 +38,4 @@ instance Monad (Either e) where
         return = Right
         Left  l >>= _ = Left l
         Right r >>= k = k r
+
index 0508b6e..ca0ceb2 100644 (file)
@@ -1,7 +1,4 @@
-{-# LANGUAGE CPP, SafeImports #-}
-#if sh_SAFE_DEFAULT
-{-# LANGUAGE Safe #-}
-#endif
+{-# LANGUAGE Unsafe #-}
 
 -----------------------------------------------------------------------------
 -- |
 -----------------------------------------------------------------------------
 
 module Control.Monad.ST (
-          module Control.Monad.ST.Safe
-#if !sh_SAFE_DEFAULT
+        -- * The 'ST' Monad
+        ST,             -- abstract, instance of Functor, Monad, Typeable.
+        runST,          -- :: (forall s. ST s a) -> a
+        fixST,          -- :: (a -> ST s a) -> ST s a
+
+        -- * Converting 'ST' to 'IO'
+        RealWorld,              -- abstract
+        stToIO,                 -- :: ST RealWorld a -> IO a
+
         -- * Unsafe Functions
-        , unsafeInterleaveST
-        , unsafeIOToST
-        , unsafeSTToIO
-#endif
+        unsafeInterleaveST,
+        unsafeIOToST,
+        unsafeSTToIO
     ) where
 
-import safe Control.Monad.ST.Safe
-
-#if !sh_SAFE_DEFAULT
+import Control.Monad.ST.Safe
 import qualified Control.Monad.ST.Unsafe as U
 
 {-# DEPRECATED unsafeInterleaveST, unsafeIOToST, unsafeSTToIO
@@ -49,5 +50,4 @@ unsafeIOToST = U.unsafeIOToST
 {-# INLINE unsafeSTToIO #-}
 unsafeSTToIO :: ST s a -> IO a
 unsafeSTToIO = U.unsafeSTToIO
-#endif
 
index ca768b4..8095ae2 100644 (file)
@@ -1,3 +1,4 @@
+{-# LANGUAGE Unsafe #-}
 {-# LANGUAGE CPP #-}
 {-# OPTIONS_HADDOCK hide #-}
 
index d1ec5b9..400addd 100644 (file)
@@ -1,7 +1,4 @@
-{-# LANGUAGE CPP, SafeImports #-}
-#if sh_SAFE_DEFAULT
-{-# LANGUAGE Safe #-}
-#endif
+{-# LANGUAGE Unsafe #-}
 
 -----------------------------------------------------------------------------
 -- |
 -----------------------------------------------------------------------------
 
 module Control.Monad.ST.Lazy (
-          module Control.Monad.ST.Lazy.Safe
-#if !sh_SAFE_DEFAULT
+        -- * The 'ST' monad
+        ST,
+        runST,
+        fixST,
+
+        -- * Converting between strict and lazy 'ST'
+        strictToLazyST, lazyToStrictST,
+
+        -- * Converting 'ST' To 'IO'
+        RealWorld,
+        stToIO,
+
         -- * Unsafe Functions
-        , unsafeInterleaveST
-        , unsafeIOToST
-#endif
+        unsafeInterleaveST,
+        unsafeIOToST
     ) where
 
-import safe Control.Monad.ST.Lazy.Safe
-#if !sh_SAFE_DEFAULT
+import Control.Monad.ST.Lazy.Safe
 import qualified Control.Monad.ST.Lazy.Unsafe as U
 
 {-# DEPRECATED unsafeInterleaveST, unsafeIOToST
@@ -43,5 +48,4 @@ unsafeInterleaveST = U.unsafeInterleaveST
 {-# INLINE unsafeIOToST #-}
 unsafeIOToST :: IO a -> ST s a
 unsafeIOToST = U.unsafeIOToST
-#endif
 
index 82c4974..280723c 100644 (file)
@@ -1,3 +1,4 @@
+{-# LANGUAGE Unsafe #-}
 {-# LANGUAGE CPP, MagicHash, UnboxedTuples, Rank2Types #-}
 {-# OPTIONS_HADDOCK hide #-}
 
@@ -159,4 +160,3 @@ unsafeInterleaveST = strictToLazyST . ST.unsafeInterleaveST . lazyToStrictST
 unsafeIOToST :: IO a -> ST s a
 unsafeIOToST = strictToLazyST . ST.unsafeIOToST
 
-
index 1ccdbbf..4a1b8c7 100644 (file)
@@ -1,3 +1,5 @@
+{-# LANGUAGE Unsafe #-}
+
 -----------------------------------------------------------------------------
 -- |
 -- Module      :  Control.Monad.ST.Lazy.Unsafe
index 1b63034..4e474d9 100644 (file)
@@ -1,7 +1,3 @@
-{-# LANGUAGE CPP #-}
-#if sh_SAFE_DEFAULT
-{-# LANGUAGE Safe #-}
-#endif
 -----------------------------------------------------------------------------
 -- |
 -- Module      :  Control.Monad.ST.Strict
@@ -20,9 +16,5 @@ module Control.Monad.ST.Strict (
         module Control.Monad.ST
   ) where
 
-#if sh_SAFE_DEFAULT
-import safe Control.Monad.ST
-#else
 import Control.Monad.ST
-#endif
 
index 1a224d0..9fa4b73 100644 (file)
@@ -1,3 +1,5 @@
+{-# LANGUAGE Unsafe #-}
+
 -----------------------------------------------------------------------------
 -- |
 -- Module      :  Control.Monad.ST.Unsafe
index 8c431bd..824e373 100644 (file)
@@ -1,8 +1,10 @@
 {-# LANGUAGE Safe #-}
+
 -----------------------------------------------------------------------------
 -- |
 -- Module      :  Control.Monad.Zip
 -- Copyright   :  (c) Nils Schweinsberg 2011,
+--                (c) George Giorgidze 2011
 --                (c) University Tuebingen 2011
 -- License     :  BSD-style (see the file libraries/base/LICENSE)
 -- Maintainer  :  libraries@haskell.org
@@ -40,8 +42,14 @@ class Monad m => MonadZip m where
     mzipWith :: (a -> b -> c) -> m a -> m b -> m c
     mzipWith f ma mb = liftM (uncurry f) (mzip ma mb)
 
+    munzip :: m (a,b) -> (m a, m b)
+    munzip mab = (liftM fst mab, liftM snd mab)
+    -- munzip is a member of the class because sometimes
+    -- you can implement it more efficiently than the
+    -- above default code.  See Trac #4370 comment by giorgidze
+
 instance MonadZip [] where
-    mzip = zip
+    mzip     = zip
+    mzipWith = zipWith
+    munzip   = unzip
 
-munzip :: MonadZip m => m (a,b) -> (m a, m b)
-munzip mab = (liftM fst mab, liftM snd mab)
index 35006f4..c81c96f 100644 (file)
@@ -33,7 +33,9 @@ module Data.Bits (
     bitSize,           -- :: a -> Int
     isSigned,          -- :: a -> Bool
     shiftL, shiftR,    -- :: a -> Int -> a
-    rotateL, rotateR   -- :: a -> Int -> a
+    unsafeShiftL, unsafeShiftR,  -- :: a -> Int -> a
+    rotateL, rotateR,  -- :: a -> Int -> a
+    popCount           -- :: a -> Int
   )
 
   -- instance Bits Int
@@ -72,7 +74,7 @@ Minimal complete definition: '.&.', '.|.', 'xor', 'complement',
 ('shift' or ('shiftL' and 'shiftR')), ('rotate' or ('rotateL' and 'rotateR')),
 'bitSize' and 'isSigned'.
 -}
-class Num a => Bits a where
+class (Eq a, Num a) => Bits a where
     -- | Bitwise \"and\"
     (.&.) :: a -> a -> a
 
@@ -174,8 +176,19 @@ class Num a => Bits a where
     {-# INLINE shiftL #-}
     x `shiftL`  i = x `shift`  i
 
-    {-| Shift the first argument right by the specified number of bits
-        (which must be non-negative).
+    {-| Shift the argument left by the specified number of bits.  The
+        result is undefined for negative shift amounts and shift amounts
+        greater or equal to the 'bitSize'.
+
+        Defaults to 'shiftL' unless defined explicitly by an instance. -}
+    unsafeShiftL            :: a -> Int -> a
+    {-# INLINE unsafeShiftL #-}
+    x `unsafeShiftL` i = x `shiftL` i
+
+    {-| Shift the first argument right by the specified number of bits. The
+        result is undefined for negative shift amounts and shift amounts
+        greater or equal to the 'bitSize'.
+
         Right shifts perform sign extension on signed number types;
         i.e. they fill the top bits with 1 if the @x@ is negative
         and with 0 otherwise.
@@ -187,6 +200,18 @@ class Num a => Bits a where
     {-# INLINE shiftR #-}
     x `shiftR`  i = x `shift`  (-i)
 
+    {-| Shift the first argument right by the specified number of bits, which
+        must be non-negative an smaller than the number of bits in the type.
+
+        Right shifts perform sign extension on signed number types;
+        i.e. they fill the top bits with 1 if the @x@ is negative
+        and with 0 otherwise.
+
+        Defaults to 'shiftR' unless defined explicitly by an instance. -}
+    unsafeShiftR            :: a -> Int -> a
+    {-# INLINE unsafeShiftR #-}
+    x `unsafeShiftR` i = x `shiftR` i
+
     {-| Rotate the argument left by the specified number of bits
         (which must be non-negative).
 
@@ -207,6 +232,17 @@ class Num a => Bits a where
     {-# INLINE rotateR #-}
     x `rotateR` i = x `rotate` (-i)
 
+    {-| Return the number of set bits in the argument.  This number is
+        known as the population count or the Hamming weight. -}
+    popCount          :: a -> Int
+    popCount = go 0
+      where
+        go !c 0 = c
+        go c w = go (c+1) (w .&. w - 1)  -- clear the least significant bit set
+    {- This implementation is intentionally naive.  Instances are
+       expected to override it with something optimized for their
+       size. -}
+
 instance Bits Int where
     {-# INLINE shift #-}
 
@@ -222,6 +258,10 @@ instance Bits Int where
     (I# x#) `shift` (I# i#)
         | i# >=# 0#        = I# (x# `iShiftL#` i#)
         | otherwise        = I# (x# `iShiftRA#` negateInt# i#)
+    (I# x#) `shiftL` (I# i#) = I# (x# `iShiftL#` i#)
+    (I# x#) `unsafeShiftL` (I# i#) = I# (x# `uncheckedIShiftL#` i#)
+    (I# x#) `shiftR` (I# i#) = I# (x# `iShiftRA#` i#)
+    (I# x#) `unsafeShiftR` (I# i#) = I# (x# `uncheckedIShiftRA#` i#)
 
     {-# INLINE rotate #-}      -- See Note [Constant folding for rotate]
     (I# x#) `rotate` (I# i#) =
@@ -233,6 +273,8 @@ instance Bits Int where
         !wsib = WORD_SIZE_IN_BITS#   {- work around preprocessor problem (??) -}
     bitSize  _             = WORD_SIZE_IN_BITS
 
+    popCount (I# x#) = I# (word2Int# (popCnt# (int2Word# x#)))
+
 #else /* !__GLASGOW_HASKELL__ */
 
 #ifdef __HUGS__
@@ -364,5 +406,4 @@ own to enable constant folding; for example 'shift':
            10000000 -> ww_sOb
          }
 -} 
-     
 
index 8d80ec8..1f53177 100644 (file)
@@ -39,3 +39,4 @@ import Prelude
   , otherwise
   )
 #endif
+
index f45f369..c19e8af 100644 (file)
@@ -50,8 +50,6 @@ module Data.Char
     , showLitChar       -- :: Char -> ShowS
     , lexLitChar        -- :: ReadS String
     , readLitChar       -- :: ReadS Char 
-
-     -- Implementation checked wrt. Haskell 98 lib report, 1/99.
     ) where
 
 #ifdef __GLASGOW_HASKELL__
@@ -209,3 +207,4 @@ isSeparator c = case generalCategory c of
 toTitle :: Char -> Char
 toTitle = toUpper
 #endif
+
index b456055..1e32bd7 100644 (file)
@@ -42,8 +42,6 @@ module Data.Complex
         --  (RealFloat a) => Num        (Complex a)
         --  (RealFloat a) => Fractional (Complex a)
         --  (RealFloat a) => Floating   (Complex a)
-        -- 
-        -- Implementation checked wrt. Haskell 98 lib report, 1/99.
 
         )  where
 
@@ -205,3 +203,4 @@ instance  (RealFloat a) => Floating (Complex a) where
     asinh z        =  log (z + sqrt (1+z*z))
     acosh z        =  log (z + (z+1) * sqrt ((z-1)/(z+1)))
     atanh z        =  0.5 * log ((1.0+z) / (1.0-z))
+
index d9cab7a..cd40167 100644 (file)
@@ -1,3 +1,4 @@
+{-# LANGUAGE Trustworthy #-}
 {-# LANGUAGE CPP, Rank2Types, ScopedTypeVariables #-}
 
 -----------------------------------------------------------------------------
@@ -22,7 +23,6 @@
 -- For more information, please visit the new
 -- SYB wiki: <http://www.cs.uu.nl/wiki/bin/view/GenericProgramming/SYB>.
 --
---
 -----------------------------------------------------------------------------
 
 module Data.Data (
@@ -587,7 +587,7 @@ repConstr dt cr =
         (IntRep,    IntConstr i)      -> mkIntConstr dt i
         (FloatRep,  FloatConstr f)    -> mkRealConstr dt f
         (CharRep,   CharConstr c)     -> mkCharConstr dt c
-        _ -> error "repConstr"
+        _ -> error "Data.Data.repConstr"
 
 
 
@@ -625,7 +625,7 @@ mkConstr dt str fields fix =
 dataTypeConstrs :: DataType -> [Constr]
 dataTypeConstrs dt = case datarep dt of
                         (AlgRep cons) -> cons
-                        _ -> error "dataTypeConstrs"
+                        _ -> error "Data.Data.dataTypeConstrs"
 
 
 -- | Gets the field labels of a constructor.  The list of labels
@@ -698,21 +698,21 @@ isAlgType dt = case datarep dt of
 indexConstr :: DataType -> ConIndex -> Constr
 indexConstr dt idx = case datarep dt of
                         (AlgRep cs) -> cs !! (idx-1)
-                        _           -> error "indexConstr"
+                        _           -> error "Data.Data.indexConstr"
 
 
 -- | Gets the index of a constructor (algebraic datatypes only)
 constrIndex :: Constr -> ConIndex
 constrIndex con = case constrRep con of
                     (AlgConstr idx) -> idx
-                    _ -> error "constrIndex"
+                    _ -> error "Data.Data.constrIndex"
 
 
 -- | Gets the maximum constructor index of an algebraic datatype
 maxConstrIndex :: DataType -> ConIndex
 maxConstrIndex dt = case dataTypeRep dt of
                         AlgRep cs -> length cs
-                        _            -> error "maxConstrIndex"
+                        _            -> error "Data.Data.maxConstrIndex"
 
 
 
@@ -757,8 +757,8 @@ mkPrimCon dt str cr = Constr
                         { datatype  = dt
                         , conrep    = cr
                         , constring = str
-                        , confields = error "constrFields"
-                        , confixity = error "constrFixity"
+                        , confields = error "Data.Data.confields"
+                        , confixity = error "Data.Data.confixity"
                         }
 
 -- | This function is now deprecated. Please use 'mkIntegralConstr' instead.
@@ -766,20 +766,20 @@ mkPrimCon dt str cr = Constr
 mkIntConstr :: DataType -> Integer -> Constr
 mkIntConstr = mkIntegralConstr
 
-mkIntegralConstr :: (Integral a) => DataType -> a -> Constr
+mkIntegralConstr :: (Integral a, Show a) => DataType -> a -> Constr
 mkIntegralConstr dt i = case datarep dt of
                   IntRep -> mkPrimCon dt (show i) (IntConstr (toInteger  i))
-                  _ -> error "mkIntegralConstr"
+                  _ -> error "Data.Data.mkIntegralConstr"
 
 -- | This function is now deprecated. Please use 'mkRealConstr' instead.
 {-# DEPRECATED mkFloatConstr "Use mkRealConstr instead" #-}
 mkFloatConstr :: DataType -> Double -> Constr
 mkFloatConstr dt = mkRealConstr dt . toRational
 
-mkRealConstr :: (Real a) => DataType -> a -> Constr
+mkRealConstr :: (Real a, Show a) => DataType -> a -> Constr
 mkRealConstr dt f = case datarep dt of
                     FloatRep -> mkPrimCon dt (show f) (FloatConstr (toRational f))
-                    _ -> error "mkRealConstr"
+                    _ -> error "Data.Data.mkRealConstr"
 
 -- | This function is now deprecated. Please use 'mkCharConstr' instead.
 {-# DEPRECATED mkStringConstr "Use mkCharConstr instead" #-}
@@ -788,14 +788,14 @@ mkStringConstr dt str =
   case datarep dt of
     CharRep -> case str of
       [c] -> mkPrimCon dt (show c) (CharConstr c)
-      _ -> error "mkStringConstr: input String must contain a single character"
-    _ -> error "mkStringConstr"
+      _ -> error "Data.Data.mkStringConstr: input String must contain a single character"
+    _ -> error "Data.Data.mkStringConstr"
 
 -- | Makes a constructor for 'Char'.
 mkCharConstr :: DataType -> Char -> Constr
 mkCharConstr dt c = case datarep dt of
                    CharRep -> mkPrimCon dt (show c) (CharConstr c)
-                   _ -> error "mkCharConstr"
+                   _ -> error "Data.Data.mkCharConstr"
 
 
 ------------------------------------------------------------------------------
@@ -880,7 +880,7 @@ instance Data Bool where
   gunfold _ z c  = case constrIndex c of
                      1 -> z False
                      2 -> z True
-                     _ -> error "gunfold"
+                     _ -> error "Data.Data.gunfold(Bool)"
   dataTypeOf _ = boolDataType
 
 
@@ -893,7 +893,7 @@ instance Data Char where
   toConstr x = mkCharConstr charType x
   gunfold _ z c = case constrRep c of
                     (CharConstr x) -> z x
-                    _ -> error "gunfold"
+                    _ -> error "Data.Data.gunfold(Char)"
   dataTypeOf _ = charType
 
 
@@ -906,7 +906,7 @@ instance Data Float where
   toConstr = mkRealConstr floatType
   gunfold _ z c = case constrRep c of
                     (FloatConstr x) -> z (realToFrac x)
-                    _ -> error "gunfold"
+                    _ -> error "Data.Data.gunfold(Float)"
   dataTypeOf _ = floatType
 
 
@@ -919,7 +919,7 @@ instance Data Double where
   toConstr = mkRealConstr doubleType
   gunfold _ z c = case constrRep c of
                     (FloatConstr x) -> z (realToFrac x)
-                    _ -> error "gunfold"
+                    _ -> error "Data.Data.gunfold(Double)"
   dataTypeOf _ = doubleType
 
 
@@ -932,7 +932,7 @@ instance Data Int where
   toConstr x = mkIntConstr intType (fromIntegral x)
   gunfold _ z c = case constrRep c of
                     (IntConstr x) -> z (fromIntegral x)
-                    _ -> error "gunfold"
+                    _ -> error "Data.Data.gunfold(Int)"
   dataTypeOf _ = intType
 
 
@@ -945,7 +945,7 @@ instance Data Integer where
   toConstr = mkIntConstr integerType
   gunfold _ z c = case constrRep c of
                     (IntConstr x) -> z x
-                    _ -> error "gunfold"
+                    _ -> error "Data.Data.gunfold(Integer)"
   dataTypeOf _ = integerType
 
 
@@ -958,7 +958,7 @@ instance Data Int8 where
   toConstr x = mkIntConstr int8Type (fromIntegral x)
   gunfold _ z c = case constrRep c of
                     (IntConstr x) -> z (fromIntegral x)
-                    _ -> error "gunfold"
+                    _ -> error "Data.Data.gunfold(Int8)"
   dataTypeOf _ = int8Type
 
 
@@ -971,7 +971,7 @@ instance Data Int16 where
   toConstr x = mkIntConstr int16Type (fromIntegral x)
   gunfold _ z c = case constrRep c of
                     (IntConstr x) -> z (fromIntegral x)
-                    _ -> error "gunfold"
+                    _ -> error "Data.Data.gunfold(Int16)"
   dataTypeOf _ = int16Type
 
 
@@ -984,7 +984,7 @@ instance Data Int32 where
   toConstr x = mkIntConstr int32Type (fromIntegral x)
   gunfold _ z c = case constrRep c of
                     (IntConstr x) -> z (fromIntegral x)
-                    _ -> error "gunfold"
+                    _ -> error "Data.Data.gunfold(Int32)"
   dataTypeOf _ = int32Type
 
 
@@ -997,7 +997,7 @@ instance Data Int64 where
   toConstr x = mkIntConstr int64Type (fromIntegral x)
   gunfold _ z c = case constrRep c of
                     (IntConstr x) -> z (fromIntegral x)
-                    _ -> error "gunfold"
+                    _ -> error "Data.Data.gunfold(Int64)"
   dataTypeOf _ = int64Type
 
 
@@ -1010,7 +1010,7 @@ instance Data Word where
   toConstr x = mkIntConstr wordType (fromIntegral x)
   gunfold _ z c = case constrRep c of
                     (IntConstr x) -> z (fromIntegral x)
-                    _ -> error "gunfold"
+                    _ -> error "Data.Data.gunfold(Word)"
   dataTypeOf _ = wordType
 
 
@@ -1023,7 +1023,7 @@ instance Data Word8 where
   toConstr x = mkIntConstr word8Type (fromIntegral x)
   gunfold _ z c = case constrRep c of
                     (IntConstr x) -> z (fromIntegral x)
-                    _ -> error "gunfold"
+                    _ -> error "Data.Data.gunfold(Word8)"
   dataTypeOf _ = word8Type
 
 
@@ -1036,7 +1036,7 @@ instance Data Word16 where
   toConstr x = mkIntConstr word16Type (fromIntegral x)
   gunfold _ z c = case constrRep c of
                     (IntConstr x) -> z (fromIntegral x)
-                    _ -> error "gunfold"
+                    _ -> error "Data.Data.gunfold(Word16)"
   dataTypeOf _ = word16Type
 
 
@@ -1049,7 +1049,7 @@ instance Data Word32 where
   toConstr x = mkIntConstr word32Type (fromIntegral x)
   gunfold _ z c = case constrRep c of
                     (IntConstr x) -> z (fromIntegral x)
-                    _ -> error "gunfold"
+                    _ -> error "Data.Data.gunfold(Word32)"
   dataTypeOf _ = word32Type
 
 
@@ -1062,7 +1062,7 @@ instance Data Word64 where
   toConstr x = mkIntConstr word64Type (fromIntegral x)
   gunfold _ z c = case constrRep c of
                     (IntConstr x) -> z (fromIntegral x)
-                    _ -> error "gunfold"
+                    _ -> error "Data.Data.gunfold(Word64)"
   dataTypeOf _ = word64Type
 
 
@@ -1078,7 +1078,7 @@ instance (Data a, Integral a) => Data (Ratio a) where
   gfoldl k z (a :% b) = z (:%) `k` a `k` b
   toConstr _ = ratioConstr
   gunfold k z c | constrIndex c == 1 = k (k (z (:%)))
-  gunfold _ _ _ = error "gunfold"
+  gunfold _ _ _ = error "Data.Data.gunfold(Ratio)"
   dataTypeOf _  = ratioDataType
 
 
@@ -1100,7 +1100,7 @@ instance Data a => Data [a] where
   gunfold k z c = case constrIndex c of
                     1 -> z []
                     2 -> k (k (z (:)))
-                    _ -> error "gunfold"
+                    _ -> error "Data.Data.gunfold(List)"
   dataTypeOf _ = listDataType
   dataCast1 f  = gcast1 f
 
@@ -1134,7 +1134,7 @@ instance Data a => Data (Maybe a) where
   gunfold k z c = case constrIndex c of
                     1 -> z Nothing
                     2 -> k (z Just)
-                    _ -> error "gunfold"
+                    _ -> error "Data.Data.gunfold(Maybe)"
   dataTypeOf _ = maybeDataType
   dataCast1 f  = gcast1 f
 
@@ -1162,7 +1162,7 @@ instance Data Ordering where
                     1 -> z LT
                     2 -> z EQ
                     3 -> z GT
-                    _ -> error "gunfold"
+                    _ -> error "Data.Data.gunfold(Ordering)"
   dataTypeOf _ = orderingDataType
 
 
@@ -1185,7 +1185,7 @@ instance (Data a, Data b) => Data (Either a b) where
   gunfold k z c = case constrIndex c of
                     1 -> k (z Left)
                     2 -> k (z Right)
-                    _ -> error "gunfold"
+                    _ -> error "Data.Data.gunfold(Either)"
   dataTypeOf _ = eitherDataType
   dataCast2 f  = gcast2 f
 
@@ -1201,7 +1201,7 @@ tuple0DataType = mkDataType "Prelude.()" [tuple0Constr]
 instance Data () where
   toConstr ()   = tuple0Constr
   gunfold _ z c | constrIndex c == 1 = z ()
-  gunfold _ _ _ = error "gunfold"
+  gunfold _ _ _ = error "Data.Data.gunfold(unit)"
   dataTypeOf _  = tuple0DataType
 
 
@@ -1217,7 +1217,7 @@ instance (Data a, Data b) => Data (a,b) where
   gfoldl f z (a,b) = z (,) `f` a `f` b
   toConstr (_,_) = tuple2Constr
   gunfold k z c | constrIndex c == 1 = k (k (z (,)))
-  gunfold _ _ _ = error "gunfold"
+  gunfold _ _ _ = error "Data.Data.gunfold(tup2)"
   dataTypeOf _  = tuple2DataType
   dataCast2 f   = gcast2 f
 
@@ -1234,7 +1234,7 @@ instance (Data a, Data b, Data c) => Data (a,b,c) where
   gfoldl f z (a,b,c) = z (,,) `f` a `f` b `f` c
   toConstr (_,_,_) = tuple3Constr
   gunfold k z c | constrIndex c == 1 = k (k (k (z (,,))))
-  gunfold _ _ _ = error "gunfold"
+  gunfold _ _ _ = error "Data.Data.gunfold(tup3)"
   dataTypeOf _  = tuple3DataType
 
 
@@ -1252,7 +1252,7 @@ instance (Data a, Data b, Data c, Data d)
   toConstr (_,_,_,_) = tuple4Constr
   gunfold k z c = case constrIndex c of
                     1 -> k (k (k (k (z (,,,)))))
-                    _ -> error "gunfold"
+                    _ -> error "Data.Data.gunfold(tup4)"
   dataTypeOf _ = tuple4DataType
 
 
@@ -1270,7 +1270,7 @@ instance (Data a, Data b, Data c, Data d, Data e)
   toConstr (_,_,_,_,_) = tuple5Constr
   gunfold k z c = case constrIndex c of
                     1 -> k (k (k (k (k (z (,,,,))))))
-                    _ -> error "gunfold"
+                    _ -> error "Data.Data.gunfold(tup5)"
   dataTypeOf _ = tuple5DataType
 
 
@@ -1288,7 +1288,7 @@ instance (Data a, Data b, Data c, Data d, Data e, Data f)
   toConstr (_,_,_,_,_,_) = tuple6Constr
   gunfold k z c = case constrIndex c of
                     1 -> k (k (k (k (k (k (z (,,,,,)))))))
-                    _ -> error "gunfold"
+                    _ -> error "Data.Data.gunfold(tup6)"
   dataTypeOf _ = tuple6DataType
 
 
@@ -1307,23 +1307,23 @@ instance (Data a, Data b, Data c, Data d, Data e, Data f, Data g)
   toConstr  (_,_,_,_,_,_,_) = tuple7Constr
   gunfold k z c = case constrIndex c of
                     1 -> k (k (k (k (k (k (k (z (,,,,,,))))))))
-                    _ -> error "gunfold"
+                    _ -> error "Data.Data.gunfold(tup7)"
   dataTypeOf _ = tuple7DataType
 
 
 ------------------------------------------------------------------------------
 
 instance Typeable a => Data (Ptr a) where
-  toConstr _   = error "toConstr"
-  gunfold _ _  = error "gunfold"
+  toConstr _   = error "Data.Data.toConstr(Ptr)"
+  gunfold _ _  = error "Data.Data.gunfold(Ptr)"
   dataTypeOf _ = mkNoRepType "GHC.Ptr.Ptr"
 
 
 ------------------------------------------------------------------------------
 
 instance Typeable a => Data (ForeignPtr a) where
-  toConstr _   = error "toConstr"
-  gunfold _ _  = error "gunfold"
+  toConstr _   = error "Data.Data.toConstr(ForeignPtr)"
+  gunfold _ _  = error "Data.Data.gunfold(ForeignPtr)"
   dataTypeOf _ = mkNoRepType "GHC.ForeignPtr.ForeignPtr"
 
 
@@ -1333,7 +1333,7 @@ instance Typeable a => Data (ForeignPtr a) where
 instance (Typeable a, Data b, Ix a) => Data (Array a b)
  where
   gfoldl f z a = z (listArray (bounds a)) `f` (elems a)
-  toConstr _   = error "toConstr"
-  gunfold _ _  = error "gunfold"
+  toConstr _   = error "Data.Data.toConstr(Array)"
+  gunfold _ _  = error "Data.Data.gunfold(Array)"
   dataTypeOf _ = mkNoRepType "Data.Array.Array"
 
index df64c38..11501b8 100644 (file)
@@ -1,3 +1,4 @@
+{-# LANGUAGE Trustworthy #-}
 {-# LANGUAGE CPP, NoImplicitPrelude #-}
 #ifdef __GLASGOW_HASKELL__
 {-# LANGUAGE DeriveDataTypeable, StandaloneDeriving #-}
@@ -167,3 +168,4 @@ dynApp f x = case dynApply f x of
 
 dynTypeRep :: Dynamic -> TypeRep
 dynTypeRep (Dynamic tr _) = tr 
+
index 9386d60..0c45c78 100644 (file)
@@ -22,3 +22,4 @@ module Data.Eq (
 #if __GLASGOW_HASKELL__
 import GHC.Base
 #endif
+
index b1d7113..81e7c03 100644 (file)
@@ -1,10 +1,10 @@
 {-# LANGUAGE Trustworthy #-}
 {-# LANGUAGE CPP #-}
 {-# OPTIONS -Wall -fno-warn-unused-binds #-}
-
 #ifndef __NHC__
 {-# LANGUAGE DeriveDataTypeable #-}
 #endif
+
 -----------------------------------------------------------------------------
 -- |
 -- Module      :  Data.Fixed
@@ -246,3 +246,4 @@ instance HasResolution E12 where
     resolution _ = 1000000000000
 -- | resolution of 10^-12 = .000000000001
 type Pico = Fixed E12
+
index a925fca..01ef297 100644 (file)
@@ -18,6 +18,8 @@
 -- functor.  To avoid ambiguity, either import those modules hiding
 -- these names or qualify uses of these function names with an alias
 -- for this module.
+--
+-----------------------------------------------------------------------------
 
 module Data.Foldable (
     -- * Folds
@@ -320,3 +322,4 @@ notElem x = not . elem x
 -- 'Nothing' if there is no such element.
 find :: Foldable t => (a -> Bool) -> t a -> Maybe a
 find p = listToMaybe . concatMap (\ x -> if p x then [x] else [])
+
index ef6d9cf..54eabbb 100644 (file)
@@ -1,4 +1,5 @@
 {-# LANGUAGE Safe #-}
+
 -----------------------------------------------------------------------------
 -- |
 -- Module      :  Data.Function
@@ -10,6 +11,8 @@
 -- Portability :  portable
 --
 -- Simple combinators working solely on and with functions.
+--
+-----------------------------------------------------------------------------
 
 module Data.Function
   ( -- * "Prelude" re-exports
@@ -82,3 +85,4 @@ fix f = let x = f x in x
 
 on :: (b -> b -> c) -> (a -> b) -> a -> a -> c
 (.*.) `on` f = \x y -> f x .*. f y
+
index 2369cdb..416768e 100644 (file)
@@ -33,3 +33,4 @@ infixl 4 <$>
 -- | An infix synonym for 'fmap'.
 (<$>) :: Functor f => (a -> b) -> f a -> f b
 (<$>) = fmap
+
index 9fe7899..b594863 100644 (file)
@@ -531,3 +531,4 @@ longestChain = mapReduce id (maximumBy lengthCmp)
         lengthCmp []   []    = EQ
         lengthCmp []   _     = LT
         lengthCmp _    []    = GT
+
index 13eb9c9..1a3ddfd 100644 (file)
@@ -138,3 +138,4 @@ atomicModifyIORef r f =
   'IORef' operations.
 
 -}
+
index 1ff37bd..084bb0e 100644 (file)
@@ -65,3 +65,4 @@ import NHC.SizedTypes (Int8, Int16, Int32, Int64)       -- instances of Bits
   count to the width of the type, for example @1 \<\< 32
   == 1@ in some C implementations.
 -}
+
index f1edf00..4af5db3 100644 (file)
@@ -16,6 +16,7 @@
 -- (see the array package).
 -- 
 -----------------------------------------------------------------------------
+
 module Data.Ix
     (
     -- * The 'Ix' class
@@ -36,8 +37,6 @@ module Data.Ix
     --  (Ix a, Ix b) => Ix (a, b)
     --  ...
 
-    -- Implementation checked wrt. Haskell 98 lib report, 1/99.
-
     -- * Deriving Instances of 'Ix'
     -- | Derived instance declarations for the class 'Ix' are only possible
     -- for enumerations (i.e. datatypes having only nullary constructors)
index 4f76c83..55e3dd2 100644 (file)
@@ -95,6 +95,7 @@ module Data.List
 
    , takeWhile         -- :: (a -> Bool) -> [a] -> [a]
    , dropWhile         -- :: (a -> Bool) -> [a] -> [a]
+   , dropWhileEnd      -- :: (a -> Bool) -> [a] -> [a]
    , span              -- :: (a -> Bool) -> [a] -> ([a], [a])
    , break             -- :: (a -> Bool) -> [a] -> ([a], [a])
 
@@ -228,6 +229,16 @@ infix 5 \\ -- comment to fool cpp
 -- -----------------------------------------------------------------------------
 -- List functions
 
+-- | The 'dropWhileEnd' function drops the largest suffix of a list
+-- in which the given predicate holds for all elements.  For example:
+--
+-- > dropWhileEnd isSpace "foo\n" == "foo"
+-- > dropWhileEnd isSpace "foo bar" == "foo bar"
+-- > dropWhileEnd isSpace ("foo\n" ++ undefined) == "foo" ++ undefined
+
+dropWhileEnd :: (a -> Bool) -> [a] -> [a]
+dropWhileEnd p = foldr (\x xs -> if p x && null xs then [] else x : xs) []
+
 -- | The 'stripPrefix' function drops the given prefix from a list.
 -- It returns 'Nothing' if the list did not start with the prefix
 -- given, or 'Just' the list after the prefix, if it does.
@@ -1105,3 +1116,4 @@ errorEmptyList fun =
   error ("Prelude." ++ fun ++ ": empty list")
 
 #endif /* !__GLASGOW_HASKELL__ */
+
index a405bb4..1350402 100644 (file)
@@ -149,3 +149,4 @@ mapMaybe f (x:xs) =
   Just r  -> r:rs
 
 #endif /* else not __NHC__ */
+
index beac4f7..228e254 100644 (file)
@@ -14,6 +14,7 @@
 --
 -- A class for monoids (types with an associative binary operation that
 -- has an identity) with various general-purpose instances.
+--
 -----------------------------------------------------------------------------
 
 module Data.Monoid (
@@ -276,3 +277,4 @@ prop_mconcatLast x =
         where listLastToMaybe [] = Nothing
               listLastToMaybe lst = Just (last lst)
 -- -}
+
index 250e797..8180df2 100644 (file)
@@ -34,3 +34,4 @@ import GHC.Base
 -- >   ... sortBy (comparing fst) ...
 comparing :: (Ord a) => (b -> a) -> b -> b -> Ordering
 comparing p x y = compare (p x) (p y)
+
index 766fe41..d3d29c8 100644 (file)
@@ -95,3 +95,4 @@ approxRational rat eps  =  simplest (rat-eps) (rat+eps)
                                            n''        =  numerator nd''
                                            d''        =  denominator nd''
 #endif
+
index 851a20f..c628bb6 100644 (file)
@@ -42,3 +42,4 @@ INSTANCE_TYPEABLE2(STRef,stRefTc,"STRef")
 -- |Mutate the contents of an 'STRef'
 modifySTRef :: STRef s a -> (a -> a) -> ST s ()
 modifySTRef ref f = writeSTRef ref . f =<< readSTRef ref
+
index ccc1905..7c9a74e 100644 (file)
@@ -1,4 +1,5 @@
 {-# LANGUAGE Safe #-}
+
 -----------------------------------------------------------------------------
 -- |
 -- Module      :  Data.STRef.Lazy
@@ -12,6 +13,7 @@
 -- Mutable references in the lazy ST monad.
 --
 -----------------------------------------------------------------------------
+
 module Data.STRef.Lazy (
         -- * STRefs
         ST.STRef,       -- abstract, instance Eq
@@ -30,7 +32,8 @@ readSTRef   :: ST.STRef s a -> ST s a
 writeSTRef  :: ST.STRef s a -> a -> ST s ()
 modifySTRef :: ST.STRef s a -> (a -> a) -> ST s ()
 
-newSTRef   = strictToLazyST . ST.newSTRef
-readSTRef  = strictToLazyST . ST.readSTRef
-writeSTRef r a = strictToLazyST (ST.writeSTRef r a)
+newSTRef        = strictToLazyST . ST.newSTRef
+readSTRef       = strictToLazyST . ST.readSTRef
+writeSTRef  r a = strictToLazyST (ST.writeSTRef r a)
 modifySTRef r f = strictToLazyST (ST.modifySTRef r f)
+
index 202df73..ead6683 100644 (file)
@@ -1,4 +1,5 @@
 {-# LANGUAGE Safe #-}
+
 -----------------------------------------------------------------------------
 -- |
 -- Module      :  Data.STRef.Strict
@@ -18,3 +19,4 @@ module Data.STRef.Strict (
   ) where
 
 import Data.STRef
+
index 27d61d5..0124f13 100644 (file)
@@ -41,3 +41,4 @@ class IsString a where
 instance IsString [Char] where
     fromString xs = xs
 #endif
+
index 96ea010..75356ec 100644 (file)
@@ -29,6 +29,8 @@
 -- functions of the same names from lists to any 'Traversable' functor.
 -- To avoid ambiguity, either import the "Prelude" hiding these names
 -- or qualify uses of these function names with an alias for this module.
+--
+-----------------------------------------------------------------------------
 
 module Data.Traversable (
     Traversable(..),
@@ -194,3 +196,4 @@ instance Functor Id where
 instance Applicative Id where
     pure = Id
     Id f <*> Id x = Id (f x)
+
index 5b5d32f..30f93c5 100644 (file)
@@ -2,6 +2,7 @@
 {-# LANGUAGE CPP, NoImplicitPrelude #-}
 {-# OPTIONS_GHC -fno-warn-unused-imports #-}
 -- XXX -fno-warn-unused-imports needed for the GHC.Tuple import below. Sigh.
+
 -----------------------------------------------------------------------------
 -- |
 -- Module      :  Data.Tuple
@@ -45,7 +46,7 @@ module Data.Tuple
 
 import GHC.Base
 -- We need to depend on GHC.Base so that
--- a) so that we get GHC.Classes, GHC.Ordering, GHC.Types
+-- a) so that we get GHC.Classes, GHC.Types
 
 -- b) so that GHC.Base.inline is available, which is used
 --    when expanding instance declarations
@@ -80,10 +81,6 @@ import Prelude
   )
 #endif
 
-#ifdef __GLASGOW_HASKELL__
-import GHC.Unit ()
-#endif
-
 default ()              -- Double isn't available yet
 
 -- ---------------------------------------------------------------------------
index 8180790..16c24c9 100644 (file)
@@ -1,3 +1,4 @@
+{-# LANGUAGE Trustworthy #-}
 {-# LANGUAGE CPP
            , NoImplicitPrelude
            , OverlappingInstances
@@ -6,9 +7,6 @@
            , FlexibleInstances
   #-}
 {-# OPTIONS_GHC -funbox-strict-fields #-}
-#ifdef __GLASGOW_HASKELL__
-{-# LANGUAGE DeriveDataTypeable, StandaloneDeriving #-}
-#endif
 
 -- The -XOverlappingInstances flag allows the user to over-ride
 -- the instances for Typeable given here.  In particular, we provide an instance
@@ -49,11 +47,17 @@ module Data.Typeable
 
         -- * Type representations
         TypeRep,        -- abstract, instance of: Eq, Show, Typeable
-        TyCon,          -- abstract, instance of: Eq, Show, Typeable
         showsTypeRep,
 
+        TyCon,          -- abstract, instance of: Eq, Show, Typeable
+        tyConString,    -- :: TyCon   -> String
+        tyConPackage,   -- :: TyCon   -> String
+        tyConModule,    -- :: TyCon   -> String
+        tyConName,      -- :: TyCon   -> String
+
         -- * Construction of type representations
         mkTyCon,        -- :: String  -> TyCon
+        mkTyCon3,       -- :: String  -> String -> String -> TyCon
         mkTyConApp,     -- :: TyCon   -> [TypeRep] -> TypeRep
         mkAppTy,        -- :: TypeRep -> TypeRep   -> TypeRep
         mkFunTy,        -- :: TypeRep -> TypeRep   -> TypeRep
@@ -63,8 +67,8 @@ module Data.Typeable
         funResultTy,    -- :: TypeRep -> TypeRep   -> Maybe TypeRep
         typeRepTyCon,   -- :: TypeRep -> TyCon
         typeRepArgs,    -- :: TypeRep -> [TypeRep]
-        tyConString,    -- :: TyCon   -> String
-        typeRepKey,     -- :: TypeRep -> IO Int
+        typeRepKey,     -- :: TypeRep -> IO TypeRepKey
+        TypeRepKey,     -- abstract, instance of Eq, Ord
 
         -- * The other Typeable classes
         -- | /Note:/ The general instances are provided for GHC only.
@@ -91,35 +95,21 @@ module Data.Typeable
 
   ) where
 
-import qualified Data.HashTable as HT
-import Data.Maybe
-import Data.Int
-import Data.Word
-import Data.List( foldl, intersperse )
+import Data.Typeable.Internal hiding (mkTyCon)
+
 import Unsafe.Coerce
+import Data.Maybe
 
 #ifdef __GLASGOW_HASKELL__
 import GHC.Base
-import GHC.Show         (Show(..), ShowS,
-                         shows, showString, showChar, showParen)
 import GHC.Err          (undefined)
-import GHC.Num          (Integer, (+))
-import GHC.Real         ( rem, Ratio )
-import GHC.IORef        (IORef,newIORef)
-import GHC.IO           (mask_, unsafePerformIO)
 
--- These imports are so we can define Typeable instances
--- It'd be better to give Typeable instances in the modules themselves
--- but they all have to be compiled before Typeable
-import GHC.IOArray
-import GHC.MVar
-import GHC.ST           ( ST )
-import GHC.STRef        ( STRef )
-import GHC.Ptr          ( Ptr, FunPtr )
-import GHC.Stable       ( StablePtr, newStablePtr, freeStablePtr,
-                          deRefStablePtr, castStablePtrToPtr,
-                          castPtrToStablePtr )
-import GHC.Arr          ( Array, STArray )
+import GHC.Fingerprint.Type
+import {-# SOURCE #-} GHC.Fingerprint
+   -- loop: GHC.Fingerprint -> Foreign.Ptr -> Data.Typeable
+   -- Better to break the loop here, because we want non-SOURCE imports
+   -- of Data.Typeable as much as possible so we can optimise the derived
+   -- instances.
 
 #endif
 
@@ -145,42 +135,14 @@ import Array    ( Array )
 
 #include "Typeable.h"
 
-#ifndef __HUGS__
-
--------------------------------------------------------------
---
---              Type representations
+{-# DEPRECATED typeRepKey "TypeRep itself is now an instance of Ord" #-}
+-- | (DEPRECATED) Returns a unique key associated with a 'TypeRep'.
+-- This function is deprecated because 'TypeRep' itself is now an
+-- instance of 'Ord', so mappings can be made directly with 'TypeRep'
+-- as the key.
 --
--------------------------------------------------------------
-
--- | A concrete representation of a (monomorphic) type.  'TypeRep'
--- supports reasonably efficient equality.
-data TypeRep = TypeRep !Key TyCon [TypeRep] 
-
--- Compare keys for equality
-instance Eq TypeRep where
-  (TypeRep k1 _ _) == (TypeRep k2 _ _) = k1 == k2
-
--- | An abstract representation of a type constructor.  'TyCon' objects can
--- be built using 'mkTyCon'.
-data TyCon = TyCon !Key String
-
-instance Eq TyCon where
-  (TyCon t1 _) == (TyCon t2 _) = t1 == t2
-#endif
-
--- | Returns a unique integer associated with a 'TypeRep'.  This can
--- be used for making a mapping with TypeReps
--- as the keys, for example.  It is guaranteed that @t1 == t2@ if and only if
--- @typeRepKey t1 == typeRepKey t2@.
---
--- It is in the 'IO' monad because the actual value of the key may
--- vary from run to run of the program.  You should only rely on
--- the equality property, not any actual key value.  The relative ordering
--- of keys has no meaning either.
---
-typeRepKey :: TypeRep -> IO Int
-typeRepKey (TypeRep (Key i) _ _) = return i
+typeRepKey :: TypeRep -> IO TypeRepKey
+typeRepKey (TypeRep f _ _) = return (TypeRepKey f)
 
         -- 
         -- let fTy = mkTyCon "Foo" in show (mkTyConApp (mkTyCon ",,")
@@ -193,340 +155,16 @@ typeRepKey (TypeRep (Key i) _ _) = return i
         -- sequence of commas, e.g., (mkTyCon ",,,,") returns
         -- the 5-tuple tycon.
 
------------------ Construction --------------------
-
--- | Applies a type constructor to a sequence of types
-mkTyConApp  :: TyCon -> [TypeRep] -> TypeRep
-mkTyConApp tc@(TyCon tc_k _) args 
-  = TypeRep (appKeys tc_k arg_ks) tc args
-  where
-    arg_ks = [k | TypeRep k _ _ <- args]
-
--- | A special case of 'mkTyConApp', which applies the function 
--- type constructor to a pair of types.
-mkFunTy  :: TypeRep -> TypeRep -> TypeRep
-mkFunTy f a = mkTyConApp funTc [f,a]
-
--- | Splits a type constructor application
-splitTyConApp :: TypeRep -> (TyCon,[TypeRep])
-splitTyConApp (TypeRep _ tc trs) = (tc,trs)
+newtype TypeRepKey = TypeRepKey Fingerprint
+  deriving (Eq,Ord)
 
--- | Applies a type to a function type.  Returns: @'Just' u@ if the
--- first argument represents a function of type @t -> u@ and the
--- second argument represents a function of type @t@.  Otherwise,
--- returns 'Nothing'.
-funResultTy :: TypeRep -> TypeRep -> Maybe TypeRep
-funResultTy trFun trArg
-  = case splitTyConApp trFun of
-      (tc, [t1,t2]) | tc == funTc && t1 == trArg -> Just t2
-      _ -> Nothing
+----------------- Construction ---------------------
 
--- | Adds a TypeRep argument to a TypeRep.
-mkAppTy :: TypeRep -> TypeRep -> TypeRep
-mkAppTy (TypeRep tr_k tc trs) arg_tr
-  = let (TypeRep arg_k _ _) = arg_tr
-     in  TypeRep (appKey tr_k arg_k) tc (trs++[arg_tr])
-
--- If we enforce the restriction that there is only one
--- @TyCon@ for a type & it is shared among all its uses,
--- we can map them onto Ints very simply. The benefit is,
--- of course, that @TyCon@s can then be compared efficiently.
-
--- Provided the implementor of other @Typeable@ instances
--- takes care of making all the @TyCon@s CAFs (toplevel constants),
--- this will work. 
-
--- If this constraint does turn out to be a sore thumb, changing
--- the Eq instance for TyCons is trivial.
-
--- | Builds a 'TyCon' object representing a type constructor.  An
--- implementation of "Data.Typeable" should ensure that the following holds:
---
--- >  mkTyCon "a" == mkTyCon "a"
---
-
-mkTyCon :: String       -- ^ the name of the type constructor (should be unique
-                        -- in the program, so it might be wise to use the
-                        -- fully qualified name).
+{-# DEPRECATED mkTyCon "either derive Typeable, or use mkTyCon3 instead" #-}
+-- | Backwards-compatible API
+mkTyCon :: String       -- ^ unique string
         -> TyCon        -- ^ A unique 'TyCon' object
-mkTyCon str = TyCon (mkTyConKey str) str
-
------------------ Observation ---------------------
-
--- | Observe the type constructor of a type representation
-typeRepTyCon :: TypeRep -> TyCon
-typeRepTyCon (TypeRep _ tc _) = tc
-
--- | Observe the argument types of a type representation
-typeRepArgs :: TypeRep -> [TypeRep]
-typeRepArgs (TypeRep _ _ args) = args
-
--- | Observe string encoding of a type representation
-tyConString :: TyCon   -> String
-tyConString  (TyCon _ str) = str
-
------------------ Showing TypeReps --------------------
-
-instance Show TypeRep where
-  showsPrec p (TypeRep _ tycon tys) =
-    case tys of
-      [] -> showsPrec p tycon
-      [x]   | tycon == listTc -> showChar '[' . shows x . showChar ']'
-      [a,r] | tycon == funTc  -> showParen (p > 8) $
-                                 showsPrec 9 a .
-                                 showString " -> " .
-                                 showsPrec 8 r
-      xs | isTupleTyCon tycon -> showTuple xs
-         | otherwise         ->
-            showParen (p > 9) $
-            showsPrec p tycon . 
-            showChar ' '      . 
-            showArgs tys
-
-showsTypeRep :: TypeRep -> ShowS
-showsTypeRep = shows
-
-instance Show TyCon where
-  showsPrec _ (TyCon _ s) = showString s
-
-isTupleTyCon :: TyCon -> Bool
-isTupleTyCon (TyCon _ ('(':',':_)) = True
-isTupleTyCon _                     = False
-
--- Some (Show.TypeRep) helpers:
-
-showArgs :: Show a => [a] -> ShowS
-showArgs [] = id
-showArgs [a] = showsPrec 10 a
-showArgs (a:as) = showsPrec 10 a . showString " " . showArgs as 
-
-showTuple :: [TypeRep] -> ShowS
-showTuple args = showChar '('
-               . (foldr (.) id $ intersperse (showChar ',') 
-                               $ map (showsPrec 10) args)
-               . showChar ')'
-
--------------------------------------------------------------
---
---      The Typeable class and friends
---
--------------------------------------------------------------
-
-{- Note [Memoising typeOf]
-~~~~~~~~~~~~~~~~~~~~~~~~~~
-IMPORTANT: we don't want to recalculate the type-rep once per
-call to the dummy argument.  This is what went wrong in Trac #3245
-So we help GHC by manually keeping the 'rep' *outside* the value 
-lambda, thus
-    
-    typeOfDefault :: forall t a. (Typeable1 t, Typeable a) => t a -> TypeRep
-    typeOfDefault = \_ -> rep
-      where
-        rep = typeOf1 (undefined :: t a) `mkAppTy` 
-              typeOf  (undefined :: a)
-
-Notice the crucial use of scoped type variables here!
--}
-
--- | The class 'Typeable' allows a concrete representation of a type to
--- be calculated.
-class Typeable a where
-  typeOf :: a -> TypeRep
-  -- ^ Takes a value of type @a@ and returns a concrete representation
-  -- of that type.  The /value/ of the argument should be ignored by
-  -- any instance of 'Typeable', so that it is safe to pass 'undefined' as
-  -- the argument.
-
--- | Variant for unary type constructors
-class Typeable1 t where
-  typeOf1 :: t a -> TypeRep
-
-#ifdef __GLASGOW_HASKELL__
--- | For defining a 'Typeable' instance from any 'Typeable1' instance.
-typeOfDefault :: forall t a. (Typeable1 t, Typeable a) => t a -> TypeRep
-typeOfDefault = \_ -> rep
- where
-   rep = typeOf1 (undefined :: t a) `mkAppTy` 
-         typeOf  (undefined :: a)
-   -- Note [Memoising typeOf]
-#else
--- | For defining a 'Typeable' instance from any 'Typeable1' instance.
-typeOfDefault :: (Typeable1 t, Typeable a) => t a -> TypeRep
-typeOfDefault x = typeOf1 x `mkAppTy` typeOf (argType x)
- where
-   argType :: t a -> a
-   argType = undefined
-#endif
-
--- | Variant for binary type constructors
-class Typeable2 t where
-  typeOf2 :: t a b -> TypeRep
-
-#ifdef __GLASGOW_HASKELL__
--- | For defining a 'Typeable1' instance from any 'Typeable2' instance.
-typeOf1Default :: forall t a b. (Typeable2 t, Typeable a) => t a b -> TypeRep
-typeOf1Default = \_ -> rep 
- where
-   rep = typeOf2 (undefined :: t a b) `mkAppTy` 
-         typeOf  (undefined :: a)
-   -- Note [Memoising typeOf]
-#else
--- | For defining a 'Typeable1' instance from any 'Typeable2' instance.
-typeOf1Default :: (Typeable2 t, Typeable a) => t a b -> TypeRep
-typeOf1Default x = typeOf2 x `mkAppTy` typeOf (argType x)
- where
-   argType :: t a b -> a
-   argType = undefined
-#endif
-
--- | Variant for 3-ary type constructors
-class Typeable3 t where
-  typeOf3 :: t a b c -> TypeRep
-
-#ifdef __GLASGOW_HASKELL__
--- | For defining a 'Typeable2' instance from any 'Typeable3' instance.
-typeOf2Default :: forall t a b c. (Typeable3 t, Typeable a) => t a b c -> TypeRep
-typeOf2Default = \_ -> rep 
- where
-   rep = typeOf3 (undefined :: t a b c) `mkAppTy` 
-         typeOf  (undefined :: a)
-   -- Note [Memoising typeOf]
-#else
--- | For defining a 'Typeable2' instance from any 'Typeable3' instance.
-typeOf2Default :: (Typeable3 t, Typeable a) => t a b c -> TypeRep
-typeOf2Default x = typeOf3 x `mkAppTy` typeOf (argType x)
- where
-   argType :: t a b c -> a
-   argType = undefined
-#endif
-
--- | Variant for 4-ary type constructors
-class Typeable4 t where
-  typeOf4 :: t a b c d -> TypeRep
-
-#ifdef __GLASGOW_HASKELL__
--- | For defining a 'Typeable3' instance from any 'Typeable4' instance.
-typeOf3Default :: forall t a b c d. (Typeable4 t, Typeable a) => t a b c d -> TypeRep
-typeOf3Default = \_ -> rep
- where
-   rep = typeOf4 (undefined :: t a b c d) `mkAppTy` 
-         typeOf  (undefined :: a)
-   -- Note [Memoising typeOf]
-#else
--- | For defining a 'Typeable3' instance from any 'Typeable4' instance.
-typeOf3Default :: (Typeable4 t, Typeable a) => t a b c d -> TypeRep
-typeOf3Default x = typeOf4 x `mkAppTy` typeOf (argType x)
- where
-   argType :: t a b c d -> a
-   argType = undefined
-#endif
-   
--- | Variant for 5-ary type constructors
-class Typeable5 t where
-  typeOf5 :: t a b c d e -> TypeRep
-
-#ifdef __GLASGOW_HASKELL__
--- | For defining a 'Typeable4' instance from any 'Typeable5' instance.
-typeOf4Default :: forall t a b c d e. (Typeable5 t, Typeable a) => t a b c d e -> TypeRep
-typeOf4Default = \_ -> rep 
- where
-   rep = typeOf5 (undefined :: t a b c d e) `mkAppTy` 
-         typeOf  (undefined :: a)
-   -- Note [Memoising typeOf]
-#else
--- | For defining a 'Typeable4' instance from any 'Typeable5' instance.
-typeOf4Default :: (Typeable5 t, Typeable a) => t a b c d e -> TypeRep
-typeOf4Default x = typeOf5 x `mkAppTy` typeOf (argType x)
- where
-   argType :: t a b c d e -> a
-   argType = undefined
-#endif
-
--- | Variant for 6-ary type constructors
-class Typeable6 t where
-  typeOf6 :: t a b c d e f -> TypeRep
-
-#ifdef __GLASGOW_HASKELL__
--- | For defining a 'Typeable5' instance from any 'Typeable6' instance.
-typeOf5Default :: forall t a b c d e f. (Typeable6 t, Typeable a) => t a b c d e f -> TypeRep
-typeOf5Default = \_ -> rep
- where
-   rep = typeOf6 (undefined :: t a b c d e f) `mkAppTy` 
-         typeOf  (undefined :: a)
-   -- Note [Memoising typeOf]
-#else
--- | For defining a 'Typeable5' instance from any 'Typeable6' instance.
-typeOf5Default :: (Typeable6 t, Typeable a) => t a b c d e f -> TypeRep
-typeOf5Default x = typeOf6 x `mkAppTy` typeOf (argType x)
- where
-   argType :: t a b c d e f -> a
-   argType = undefined
-#endif
-
--- | Variant for 7-ary type constructors
-class Typeable7 t where
-  typeOf7 :: t a b c d e f g -> TypeRep
-
-#ifdef __GLASGOW_HASKELL__
--- | For defining a 'Typeable6' instance from any 'Typeable7' instance.
-typeOf6Default :: forall t a b c d e f g. (Typeable7 t, Typeable a) => t a b c d e f g -> TypeRep
-typeOf6Default = \_ -> rep
- where
-   rep = typeOf7 (undefined :: t a b c d e f g) `mkAppTy` 
-         typeOf  (undefined :: a)
-   -- Note [Memoising typeOf]
-#else
--- | For defining a 'Typeable6' instance from any 'Typeable7' instance.
-typeOf6Default :: (Typeable7 t, Typeable a) => t a b c d e f g -> TypeRep
-typeOf6Default x = typeOf7 x `mkAppTy` typeOf (argType x)
- where
-   argType :: t a b c d e f g -> a
-   argType = undefined
-#endif
-
-#ifdef __GLASGOW_HASKELL__
--- Given a @Typeable@/n/ instance for an /n/-ary type constructor,
--- define the instances for partial applications.
--- Programmers using non-GHC implementations must do this manually
--- for each type constructor.
--- (The INSTANCE_TYPEABLE/n/ macros in Typeable.h include this.)
-
--- | One Typeable instance for all Typeable1 instances
-instance (Typeable1 s, Typeable a)
-       => Typeable (s a) where
-  typeOf = typeOfDefault
-
--- | One Typeable1 instance for all Typeable2 instances
-instance (Typeable2 s, Typeable a)
-       => Typeable1 (s a) where
-  typeOf1 = typeOf1Default
-
--- | One Typeable2 instance for all Typeable3 instances
-instance (Typeable3 s, Typeable a)
-       => Typeable2 (s a) where
-  typeOf2 = typeOf2Default
-
--- | One Typeable3 instance for all Typeable4 instances
-instance (Typeable4 s, Typeable a)
-       => Typeable3 (s a) where
-  typeOf3 = typeOf3Default
-
--- | One Typeable4 instance for all Typeable5 instances
-instance (Typeable5 s, Typeable a)
-       => Typeable4 (s a) where
-  typeOf4 = typeOf4Default
-
--- | One Typeable5 instance for all Typeable6 instances
-instance (Typeable6 s, Typeable a)
-       => Typeable5 (s a) where
-  typeOf5 = typeOf5Default
-
--- | One Typeable6 instance for all Typeable7 instances
-instance (Typeable7 s, Typeable a)
-       => Typeable6 (s a) where
-  typeOf6 = typeOf6Default
-
-#endif /* __GLASGOW_HASKELL__ */
+mkTyCon name = TyCon (fingerprintString name) "" "" name
 
 -------------------------------------------------------------
 --
@@ -572,203 +210,3 @@ gcast2 x = r
   getArg :: c x -> x 
   getArg = undefined
 
--------------------------------------------------------------
---
---      Instances of the Typeable classes for Prelude types
---
--------------------------------------------------------------
-
-INSTANCE_TYPEABLE0((),unitTc,"()")
-INSTANCE_TYPEABLE1([],listTc,"[]")
-#if defined(__GLASGOW_HASKELL__)
-listTc :: TyCon
-listTc = typeRepTyCon (typeOf [()])
-#endif
-INSTANCE_TYPEABLE1(Maybe,maybeTc,"Maybe")
-INSTANCE_TYPEABLE1(Ratio,ratioTc,"Ratio")
-#if defined(__GLASGOW_HASKELL__)
-{-
-TODO: Deriving this instance fails with:
-libraries/base/Data/Typeable.hs:589:1:
-    Can't make a derived instance of `Typeable2 (->)':
-      The last argument of the instance must be a data or newtype application
-    In the stand-alone deriving instance for `Typeable2 (->)'
--}
-instance Typeable2 (->) where { typeOf2 _ = mkTyConApp funTc [] }
-funTc :: TyCon
-funTc = mkTyCon "->"
-#else
-INSTANCE_TYPEABLE2((->),funTc,"->")
-#endif
-INSTANCE_TYPEABLE1(IO,ioTc,"IO")
-
-#if defined(__GLASGOW_HASKELL__) || defined(__HUGS__)
--- Types defined in GHC.MVar
-INSTANCE_TYPEABLE1(MVar,mvarTc,"MVar" )
-#endif
-
-INSTANCE_TYPEABLE2(Array,arrayTc,"Array")
-INSTANCE_TYPEABLE2(IOArray,iOArrayTc,"IOArray")
-
-#ifdef __GLASGOW_HASKELL__
--- Hugs has these too, but their Typeable<n> instances are defined
--- elsewhere to keep this module within Haskell 98.
--- This is important because every invocation of runhugs or ffihugs
--- uses this module via Data.Dynamic.
-INSTANCE_TYPEABLE2(ST,stTc,"ST")
-INSTANCE_TYPEABLE2(STRef,stRefTc,"STRef")
-INSTANCE_TYPEABLE3(STArray,sTArrayTc,"STArray")
-#endif
-
-#ifndef __NHC__
-INSTANCE_TYPEABLE2((,),pairTc,"(,)")
-INSTANCE_TYPEABLE3((,,),tup3Tc,"(,,)")
-INSTANCE_TYPEABLE4((,,,),tup4Tc,"(,,,)")
-INSTANCE_TYPEABLE5((,,,,),tup5Tc,"(,,,,)")
-INSTANCE_TYPEABLE6((,,,,,),tup6Tc,"(,,,,,)")
-INSTANCE_TYPEABLE7((,,,,,,),tup7Tc,"(,,,,,,)")
-#endif /* __NHC__ */
-
-INSTANCE_TYPEABLE1(Ptr,ptrTc,"Ptr")
-INSTANCE_TYPEABLE1(FunPtr,funPtrTc,"FunPtr")
-#ifndef __GLASGOW_HASKELL__
-INSTANCE_TYPEABLE1(ForeignPtr,foreignPtrTc,"ForeignPtr")
-#endif
-INSTANCE_TYPEABLE1(StablePtr,stablePtrTc,"StablePtr")
-INSTANCE_TYPEABLE1(IORef,iORefTc,"IORef")
-
--------------------------------------------------------
---
--- Generate Typeable instances for standard datatypes
---
--------------------------------------------------------
-
-INSTANCE_TYPEABLE0(Bool,boolTc,"Bool")
-INSTANCE_TYPEABLE0(Char,charTc,"Char")
-INSTANCE_TYPEABLE0(Float,floatTc,"Float")
-INSTANCE_TYPEABLE0(Double,doubleTc,"Double")
-INSTANCE_TYPEABLE0(Int,intTc,"Int")
-#ifndef __NHC__
-INSTANCE_TYPEABLE0(Word,wordTc,"Word" )
-#endif
-INSTANCE_TYPEABLE0(Integer,integerTc,"Integer")
-INSTANCE_TYPEABLE0(Ordering,orderingTc,"Ordering")
-#ifndef __GLASGOW_HASKELL__
-INSTANCE_TYPEABLE0(Handle,handleTc,"Handle")
-#endif
-
-INSTANCE_TYPEABLE0(Int8,int8Tc,"Int8")
-INSTANCE_TYPEABLE0(Int16,int16Tc,"Int16")
-INSTANCE_TYPEABLE0(Int32,int32Tc,"Int32")
-INSTANCE_TYPEABLE0(Int64,int64Tc,"Int64")
-
-INSTANCE_TYPEABLE0(Word8,word8Tc,"Word8" )
-INSTANCE_TYPEABLE0(Word16,word16Tc,"Word16")
-INSTANCE_TYPEABLE0(Word32,word32Tc,"Word32")
-INSTANCE_TYPEABLE0(Word64,word64Tc,"Word64")
-
-INSTANCE_TYPEABLE0(TyCon,tyconTc,"TyCon")
-INSTANCE_TYPEABLE0(TypeRep,typeRepTc,"TypeRep")
-
-#ifdef __GLASGOW_HASKELL__
-{-
-TODO: This can't be derived currently:
-libraries/base/Data/Typeable.hs:674:1:
-    Can't make a derived instance of `Typeable RealWorld':
-      The last argument of the instance must be a data or newtype application
-    In the stand-alone deriving instance for `Typeable RealWorld'
--}
-realWorldTc :: TyCon; \
-realWorldTc = mkTyCon "GHC.Base.RealWorld"; \
-instance Typeable RealWorld where { typeOf _ = mkTyConApp realWorldTc [] }
-
-#endif
-
----------------------------------------------
---
---              Internals 
---
----------------------------------------------
-
-#ifndef __HUGS__
-newtype Key = Key Int deriving( Eq )
-#endif
-
-data KeyPr = KeyPr !Key !Key deriving( Eq )
-
-hashKP :: KeyPr -> Int32
-hashKP (KeyPr (Key k1) (Key k2)) = (HT.hashInt k1 + HT.hashInt k2) `rem` HT.prime
-
-data Cache = Cache { next_key :: !(IORef Key),  -- Not used by GHC (calls genSym instead)
-                     tc_tbl   :: !(HT.HashTable String Key),
-                     ap_tbl   :: !(HT.HashTable KeyPr Key) }
-
-{-# NOINLINE cache #-}
-#ifdef __GLASGOW_HASKELL__
-foreign import ccall unsafe "RtsTypeable.h getOrSetTypeableStore"
-    getOrSetTypeableStore :: Ptr a -> IO (Ptr a)
-#endif
-
-cache :: Cache
-cache = unsafePerformIO $ do
-                empty_tc_tbl <- HT.new (==) HT.hashString
-                empty_ap_tbl <- HT.new (==) hashKP
-                key_loc      <- newIORef (Key 1) 
-                let ret = Cache {       next_key = key_loc,
-                                        tc_tbl = empty_tc_tbl, 
-                                        ap_tbl = empty_ap_tbl }
-#ifdef __GLASGOW_HASKELL__
-                mask_ $ do
-                        stable_ref <- newStablePtr ret
-                        let ref = castStablePtrToPtr stable_ref
-                        ref2 <- getOrSetTypeableStore ref
-                        if ref==ref2
-                                then deRefStablePtr stable_ref
-                                else do
-                                        freeStablePtr stable_ref
-                                        deRefStablePtr
-                                                (castPtrToStablePtr ref2)
-#else
-                return ret
-#endif
-
-newKey :: IORef Key -> IO Key
-#ifdef __GLASGOW_HASKELL__
-newKey _ = do i <- genSym; return (Key i)
-#else
-newKey kloc = do { k@(Key i) <- readIORef kloc ;
-                   writeIORef kloc (Key (i+1)) ;
-                   return k }
-#endif
-
-#ifdef __GLASGOW_HASKELL__
-foreign import ccall unsafe "genSymZh"
-  genSym :: IO Int
-#endif
-
-mkTyConKey :: String -> Key
-mkTyConKey str 
-  = unsafePerformIO $ do
-        let Cache {next_key = kloc, tc_tbl = tbl} = cache
-        mb_k <- HT.lookup tbl str
-        case mb_k of
-          Just k  -> return k
-          Nothing -> do { k <- newKey kloc ;
-                          HT.insert tbl str k ;
-                          return k }
-
-appKey :: Key -> Key -> Key
-appKey k1 k2
-  = unsafePerformIO $ do
-        let Cache {next_key = kloc, ap_tbl = tbl} = cache
-        mb_k <- HT.lookup tbl kpr
-        case mb_k of
-          Just k  -> return k
-          Nothing -> do { k <- newKey kloc ;
-                          HT.insert tbl kpr k ;
-                          return k }
-  where
-    kpr = KeyPr k1 k2
-
-appKeys :: Key -> [Key] -> Key
-appKeys k ks = foldl appKey k ks
index da6142e..976c707 100644 (file)
@@ -1,18 +1,10 @@
+{-# LANGUAGE Trustworthy #-}
 {-# LANGUAGE NoImplicitPrelude #-}
 
-module Data.Typeable where
+module Data.Typeable (Typeable, mkTyConApp, cast) where
 
 import Data.Maybe
-import GHC.Base
-
-data TypeRep
-data TyCon
-
-mkTyCon      :: String -> TyCon
-mkTyConApp   :: TyCon -> [TypeRep] -> TypeRep
+import {-# SOURCE #-} Data.Typeable.Internal
 
 cast :: (Typeable a, Typeable b) => a -> Maybe b
 
-class Typeable a where
-  typeOf :: a -> TypeRep
-
diff --git a/Data/Typeable/Internal.hs b/Data/Typeable/Internal.hs
new file mode 100644 (file)
index 0000000..b5916e1
--- /dev/null
@@ -0,0 +1,570 @@
+{-# LANGUAGE Unsafe #-}
+
+-----------------------------------------------------------------------------
+-- |
+-- Module      :  Data.Typeable.Internal
+-- Copyright   :  (c) The University of Glasgow, CWI 2001--2011
+-- License     :  BSD-style (see the file libraries/base/LICENSE)
+-- 
+-- The representations of the types TyCon and TypeRep, and the
+-- function mkTyCon which is used by derived instances of Typeable to
+-- construct a TyCon.
+--
+-----------------------------------------------------------------------------
+
+{-# LANGUAGE CPP
+           , NoImplicitPrelude
+           , OverlappingInstances
+           , ScopedTypeVariables
+           , FlexibleInstances
+           , MagicHash #-}
+#ifdef __GLASGOW_HASKELL__
+{-# LANGUAGE DeriveDataTypeable, StandaloneDeriving #-}
+#endif
+
+module Data.Typeable.Internal (
+    TypeRep(..),
+    TyCon(..),
+    mkTyCon,
+    mkTyCon3,
+    mkTyConApp,
+    mkAppTy,
+    typeRepTyCon,
+    typeOfDefault,
+    typeOf1Default,
+    typeOf2Default,
+    typeOf3Default,
+    typeOf4Default,
+    typeOf5Default,
+    typeOf6Default,
+    Typeable(..),
+    Typeable1(..),
+    Typeable2(..),
+    Typeable3(..),
+    Typeable4(..),
+    Typeable5(..),
+    Typeable6(..),
+    Typeable7(..),
+    mkFunTy,
+    splitTyConApp,
+    funResultTy,
+    typeRepArgs,
+    showsTypeRep,
+    tyConString,
+#if defined(__GLASGOW_HASKELL__)
+    listTc, funTc
+#endif
+  ) where
+
+import GHC.Base
+import GHC.Word
+import GHC.Show
+import GHC.Err          (undefined)
+import Data.Maybe
+import Data.List
+import GHC.Num
+import GHC.Real
+import GHC.IORef
+import GHC.IOArray
+import GHC.MVar
+import GHC.ST           ( ST )
+import GHC.STRef        ( STRef )
+import GHC.Ptr          ( Ptr, FunPtr )
+import GHC.Stable
+import GHC.Arr          ( Array, STArray )
+import Data.Int
+
+import GHC.Fingerprint.Type
+import {-# SOURCE #-} GHC.Fingerprint
+   -- loop: GHC.Fingerprint -> Foreign.Ptr -> Data.Typeable
+   -- Better to break the loop here, because we want non-SOURCE imports
+   -- of Data.Typeable as much as possible so we can optimise the derived
+   -- instances.
+
+-- | A concrete representation of a (monomorphic) type.  'TypeRep'
+-- supports reasonably efficient equality.
+data TypeRep = TypeRep {-# UNPACK #-} !Fingerprint TyCon [TypeRep]
+
+-- Compare keys for equality
+instance Eq TypeRep where
+  (TypeRep k1 _ _) == (TypeRep k2 _ _) = k1 == k2
+
+instance Ord TypeRep where
+  (TypeRep k1 _ _) <= (TypeRep k2 _ _) = k1 <= k2
+
+-- | An abstract representation of a type constructor.  'TyCon' objects can
+-- be built using 'mkTyCon'.
+data TyCon = TyCon {
+   tyConHash    :: {-# UNPACK #-} !Fingerprint,
+   tyConPackage :: String,
+   tyConModule  :: String,
+   tyConName    :: String
+ }
+
+instance Eq TyCon where
+  (TyCon t1 _ _ _) == (TyCon t2 _ _ _) = t1 == t2
+
+instance Ord TyCon where
+  (TyCon k1 _ _ _) <= (TyCon k2 _ _ _) = k1 <= k2
+
+----------------- Construction --------------------
+
+#include "MachDeps.h"
+
+-- mkTyCon is an internal function to make it easier for GHC to
+-- generate derived instances.  GHC precomputes the MD5 hash for the
+-- TyCon and passes it as two separate 64-bit values to mkTyCon.  The
+-- TyCon for a derived Typeable instance will end up being statically
+-- allocated.
+
+#if WORD_SIZE_IN_BITS < 64
+mkTyCon :: Word64# -> Word64# -> String -> String -> String -> TyCon
+#else
+mkTyCon :: Word#   -> Word#   -> String -> String -> String -> TyCon
+#endif
+mkTyCon high# low# pkg modl name
+  = TyCon (Fingerprint (W64# high#) (W64# low#)) pkg modl name
+
+-- | Applies a type constructor to a sequence of types
+mkTyConApp  :: TyCon -> [TypeRep] -> TypeRep
+mkTyConApp tc@(TyCon tc_k _ _ _) []
+  = TypeRep tc_k tc [] -- optimisation: all derived Typeable instances
+                       -- end up here, and it helps generate smaller
+                       -- code for derived Typeable.
+mkTyConApp tc@(TyCon tc_k _ _ _) args
+  = TypeRep (fingerprintFingerprints (tc_k : arg_ks)) tc args
+  where
+    arg_ks = [k | TypeRep k _ _ <- args]
+
+-- | A special case of 'mkTyConApp', which applies the function 
+-- type constructor to a pair of types.
+mkFunTy  :: TypeRep -> TypeRep -> TypeRep
+mkFunTy f a = mkTyConApp funTc [f,a]
+
+-- | Splits a type constructor application
+splitTyConApp :: TypeRep -> (TyCon,[TypeRep])
+splitTyConApp (TypeRep _ tc trs) = (tc,trs)
+
+-- | Applies a type to a function type.  Returns: @'Just' u@ if the
+-- first argument represents a function of type @t -> u@ and the
+-- second argument represents a function of type @t@.  Otherwise,
+-- returns 'Nothing'.
+funResultTy :: TypeRep -> TypeRep -> Maybe TypeRep
+funResultTy trFun trArg
+  = case splitTyConApp trFun of
+      (tc, [t1,t2]) | tc == funTc && t1 == trArg -> Just t2
+      _ -> Nothing
+
+-- | Adds a TypeRep argument to a TypeRep.
+mkAppTy :: TypeRep -> TypeRep -> TypeRep
+mkAppTy (TypeRep tr_k tc trs) arg_tr
+  = let (TypeRep arg_k _ _) = arg_tr
+     in  TypeRep (fingerprintFingerprints [tr_k,arg_k]) tc (trs++[arg_tr])
+
+-- | Builds a 'TyCon' object representing a type constructor.  An
+-- implementation of "Data.Typeable" should ensure that the following holds:
+--
+-- >  A==A' ^ B==B' ^ C==C' ==> mkTyCon A B C == mkTyCon A' B' C'
+--
+
+--
+mkTyCon3 :: String       -- ^ package name
+         -> String       -- ^ module name
+         -> String       -- ^ the name of the type constructor
+         -> TyCon        -- ^ A unique 'TyCon' object
+mkTyCon3 pkg modl name =
+  TyCon (fingerprintString (unwords [pkg, modl, name])) pkg modl name
+
+----------------- Observation ---------------------
+
+-- | Observe the type constructor of a type representation
+typeRepTyCon :: TypeRep -> TyCon
+typeRepTyCon (TypeRep _ tc _) = tc
+
+-- | Observe the argument types of a type representation
+typeRepArgs :: TypeRep -> [TypeRep]
+typeRepArgs (TypeRep _ _ args) = args
+
+-- | Observe string encoding of a type representation
+{-# DEPRECATED tyConString "renamed to tyConName; tyConModule and tyConPackage are also available." #-}
+tyConString :: TyCon   -> String
+tyConString = tyConName
+
+-------------------------------------------------------------
+--
+--      The Typeable class and friends
+--
+-------------------------------------------------------------
+
+{- Note [Memoising typeOf]
+~~~~~~~~~~~~~~~~~~~~~~~~~~
+IMPORTANT: we don't want to recalculate the type-rep once per
+call to the dummy argument.  This is what went wrong in Trac #3245
+So we help GHC by manually keeping the 'rep' *outside* the value 
+lambda, thus
+    
+    typeOfDefault :: forall t a. (Typeable1 t, Typeable a) => t a -> TypeRep
+    typeOfDefault = \_ -> rep
+      where
+        rep = typeOf1 (undefined :: t a) `mkAppTy` 
+              typeOf  (undefined :: a)
+
+Notice the crucial use of scoped type variables here!
+-}
+
+-- | The class 'Typeable' allows a concrete representation of a type to
+-- be calculated.
+class Typeable a where
+  typeOf :: a -> TypeRep
+  -- ^ Takes a value of type @a@ and returns a concrete representation
+  -- of that type.  The /value/ of the argument should be ignored by
+  -- any instance of 'Typeable', so that it is safe to pass 'undefined' as
+  -- the argument.
+
+-- | Variant for unary type constructors
+class Typeable1 t where
+  typeOf1 :: t a -> TypeRep
+
+#ifdef __GLASGOW_HASKELL__
+-- | For defining a 'Typeable' instance from any 'Typeable1' instance.
+typeOfDefault :: forall t a. (Typeable1 t, Typeable a) => t a -> TypeRep
+typeOfDefault = \_ -> rep
+ where
+   rep = typeOf1 (undefined :: t a) `mkAppTy` 
+         typeOf  (undefined :: a)
+   -- Note [Memoising typeOf]
+#else
+-- | For defining a 'Typeable' instance from any 'Typeable1' instance.
+typeOfDefault :: (Typeable1 t, Typeable a) => t a -> TypeRep
+typeOfDefault x = typeOf1 x `mkAppTy` typeOf (argType x)
+ where
+   argType :: t a -> a
+   argType = undefined
+#endif
+
+-- | Variant for binary type constructors
+class Typeable2 t where
+  typeOf2 :: t a b -> TypeRep
+
+#ifdef __GLASGOW_HASKELL__
+-- | For defining a 'Typeable1' instance from any 'Typeable2' instance.
+typeOf1Default :: forall t a b. (Typeable2 t, Typeable a) => t a b -> TypeRep
+typeOf1Default = \_ -> rep 
+ where
+   rep = typeOf2 (undefined :: t a b) `mkAppTy` 
+         typeOf  (undefined :: a)
+   -- Note [Memoising typeOf]
+#else
+-- | For defining a 'Typeable1' instance from any 'Typeable2' instance.
+typeOf1Default :: (Typeable2 t, Typeable a) => t a b -> TypeRep
+typeOf1Default x = typeOf2 x `mkAppTy` typeOf (argType x)
+ where
+   argType :: t a b -> a
+   argType = undefined
+#endif
+
+-- | Variant for 3-ary type constructors
+class Typeable3 t where
+  typeOf3 :: t a b c -> TypeRep
+
+#ifdef __GLASGOW_HASKELL__
+-- | For defining a 'Typeable2' instance from any 'Typeable3' instance.
+typeOf2Default :: forall t a b c. (Typeable3 t, Typeable a) => t a b c -> TypeRep
+typeOf2Default = \_ -> rep 
+ where
+   rep = typeOf3 (undefined :: t a b c) `mkAppTy` 
+         typeOf  (undefined :: a)
+   -- Note [Memoising typeOf]
+#else
+-- | For defining a 'Typeable2' instance from any 'Typeable3' instance.
+typeOf2Default :: (Typeable3 t, Typeable a) => t a b c -> TypeRep
+typeOf2Default x = typeOf3 x `mkAppTy` typeOf (argType x)
+ where
+   argType :: t a b c -> a
+   argType = undefined
+#endif
+
+-- | Variant for 4-ary type constructors
+class Typeable4 t where
+  typeOf4 :: t a b c d -> TypeRep
+
+#ifdef __GLASGOW_HASKELL__
+-- | For defining a 'Typeable3' instance from any 'Typeable4' instance.
+typeOf3Default :: forall t a b c d. (Typeable4 t, Typeable a) => t a b c d -> TypeRep
+typeOf3Default = \_ -> rep
+ where
+   rep = typeOf4 (undefined :: t a b c d) `mkAppTy` 
+         typeOf  (undefined :: a)
+   -- Note [Memoising typeOf]
+#else
+-- | For defining a 'Typeable3' instance from any 'Typeable4' instance.
+typeOf3Default :: (Typeable4 t, Typeable a) => t a b c d -> TypeRep
+typeOf3Default x = typeOf4 x `mkAppTy` typeOf (argType x)
+ where
+   argType :: t a b c d -> a
+   argType = undefined
+#endif
+   
+-- | Variant for 5-ary type constructors
+class Typeable5 t where
+  typeOf5 :: t a b c d e -> TypeRep
+
+#ifdef __GLASGOW_HASKELL__
+-- | For defining a 'Typeable4' instance from any 'Typeable5' instance.
+typeOf4Default :: forall t a b c d e. (Typeable5 t, Typeable a) => t a b c d e -> TypeRep
+typeOf4Default = \_ -> rep 
+ where
+   rep = typeOf5 (undefined :: t a b c d e) `mkAppTy` 
+         typeOf  (undefined :: a)
+   -- Note [Memoising typeOf]
+#else
+-- | For defining a 'Typeable4' instance from any 'Typeable5' instance.
+typeOf4Default :: (Typeable5 t, Typeable a) => t a b c d e -> TypeRep
+typeOf4Default x = typeOf5 x `mkAppTy` typeOf (argType x)
+ where
+   argType :: t a b c d e -> a
+   argType = undefined
+#endif
+
+-- | Variant for 6-ary type constructors
+class Typeable6 t where
+  typeOf6 :: t a b c d e f -> TypeRep
+
+#ifdef __GLASGOW_HASKELL__
+-- | For defining a 'Typeable5' instance from any 'Typeable6' instance.
+typeOf5Default :: forall t a b c d e f. (Typeable6 t, Typeable a) => t a b c d e f -> TypeRep
+typeOf5Default = \_ -> rep
+ where
+   rep = typeOf6 (undefined :: t a b c d e f) `mkAppTy` 
+         typeOf  (undefined :: a)
+   -- Note [Memoising typeOf]
+#else
+-- | For defining a 'Typeable5' instance from any 'Typeable6' instance.
+typeOf5Default :: (Typeable6 t, Typeable a) => t a b c d e f -> TypeRep
+typeOf5Default x = typeOf6 x `mkAppTy` typeOf (argType x)
+ where
+   argType :: t a b c d e f -> a
+   argType = undefined
+#endif
+
+-- | Variant for 7-ary type constructors
+class Typeable7 t where
+  typeOf7 :: t a b c d e f g -> TypeRep
+
+#ifdef __GLASGOW_HASKELL__
+-- | For defining a 'Typeable6' instance from any 'Typeable7' instance.
+typeOf6Default :: forall t a b c d e f g. (Typeable7 t, Typeable a) => t a b c d e f g -> TypeRep
+typeOf6Default = \_ -> rep
+ where
+   rep = typeOf7 (undefined :: t a b c d e f g) `mkAppTy` 
+         typeOf  (undefined :: a)
+   -- Note [Memoising typeOf]
+#else
+-- | For defining a 'Typeable6' instance from any 'Typeable7' instance.
+typeOf6Default :: (Typeable7 t, Typeable a) => t a b c d e f g -> TypeRep
+typeOf6Default x = typeOf7 x `mkAppTy` typeOf (argType x)
+ where
+   argType :: t a b c d e f g -> a
+   argType = undefined
+#endif
+
+#ifdef __GLASGOW_HASKELL__
+-- Given a @Typeable@/n/ instance for an /n/-ary type constructor,
+-- define the instances for partial applications.
+-- Programmers using non-GHC implementations must do this manually
+-- for each type constructor.
+-- (The INSTANCE_TYPEABLE/n/ macros in Typeable.h include this.)
+
+-- | One Typeable instance for all Typeable1 instances
+instance (Typeable1 s, Typeable a)
+       => Typeable (s a) where
+  typeOf = typeOfDefault
+
+-- | One Typeable1 instance for all Typeable2 instances
+instance (Typeable2 s, Typeable a)
+       => Typeable1 (s a) where
+  typeOf1 = typeOf1Default
+
+-- | One Typeable2 instance for all Typeable3 instances
+instance (Typeable3 s, Typeable a)
+       => Typeable2 (s a) where
+  typeOf2 = typeOf2Default
+
+-- | One Typeable3 instance for all Typeable4 instances
+instance (Typeable4 s, Typeable a)
+       => Typeable3 (s a) where
+  typeOf3 = typeOf3Default
+
+-- | One Typeable4 instance for all Typeable5 instances
+instance (Typeable5 s, Typeable a)
+       => Typeable4 (s a) where
+  typeOf4 = typeOf4Default
+
+-- | One Typeable5 instance for all Typeable6 instances
+instance (Typeable6 s, Typeable a)
+       => Typeable5 (s a) where
+  typeOf5 = typeOf5Default
+
+-- | One Typeable6 instance for all Typeable7 instances
+instance (Typeable7 s, Typeable a)
+       => Typeable6 (s a) where
+  typeOf6 = typeOf6Default
+
+#endif /* __GLASGOW_HASKELL__ */
+
+----------------- Showing TypeReps --------------------
+
+instance Show TypeRep where
+  showsPrec p (TypeRep _ tycon tys) =
+    case tys of
+      [] -> showsPrec p tycon
+      [x]   | tycon == listTc -> showChar '[' . shows x . showChar ']'
+      [a,r] | tycon == funTc  -> showParen (p > 8) $
+                                 showsPrec 9 a .
+                                 showString " -> " .
+                                 showsPrec 8 r
+      xs | isTupleTyCon tycon -> showTuple xs
+         | otherwise         ->
+            showParen (p > 9) $
+            showsPrec p tycon . 
+            showChar ' '      . 
+            showArgs tys
+
+showsTypeRep :: TypeRep -> ShowS
+showsTypeRep = shows
+
+instance Show TyCon where
+  showsPrec _ t = showString (tyConName t)
+
+isTupleTyCon :: TyCon -> Bool
+isTupleTyCon (TyCon _ _ _ ('(':',':_)) = True
+isTupleTyCon _                         = False
+
+-- Some (Show.TypeRep) helpers:
+
+showArgs :: Show a => [a] -> ShowS
+showArgs [] = id
+showArgs [a] = showsPrec 10 a
+showArgs (a:as) = showsPrec 10 a . showString " " . showArgs as 
+
+showTuple :: [TypeRep] -> ShowS
+showTuple args = showChar '('
+               . (foldr (.) id $ intersperse (showChar ',') 
+                               $ map (showsPrec 10) args)
+               . showChar ')'
+
+#if defined(__GLASGOW_HASKELL__)
+listTc :: TyCon
+listTc = typeRepTyCon (typeOf [()])
+
+funTc :: TyCon
+funTc = mkTyCon3 "ghc-prim" "GHC.Types" "->"
+#endif
+
+-------------------------------------------------------------
+--
+--      Instances of the Typeable classes for Prelude types
+--
+-------------------------------------------------------------
+
+#include "Typeable.h"
+
+INSTANCE_TYPEABLE0((),unitTc,"()")
+INSTANCE_TYPEABLE1([],listTc,"[]")
+INSTANCE_TYPEABLE1(Maybe,maybeTc,"Maybe")
+INSTANCE_TYPEABLE1(Ratio,ratioTc,"Ratio")
+#if defined(__GLASGOW_HASKELL__)
+{-
+TODO: Deriving this instance fails with:
+libraries/base/Data/Typeable.hs:589:1:
+    Can't make a derived instance of `Typeable2 (->)':
+      The last argument of the instance must be a data or newtype application
+    In the stand-alone deriving instance for `Typeable2 (->)'
+-}
+instance Typeable2 (->) where { typeOf2 _ = mkTyConApp funTc [] }
+#else
+INSTANCE_TYPEABLE2((->),funTc,"->")
+#endif
+INSTANCE_TYPEABLE1(IO,ioTc,"IO")
+
+#if defined(__GLASGOW_HASKELL__) || defined(__HUGS__)
+-- Types defined in GHC.MVar
+INSTANCE_TYPEABLE1(MVar,mvarTc,"MVar" )
+#endif
+
+INSTANCE_TYPEABLE2(Array,arrayTc,"Array")
+INSTANCE_TYPEABLE2(IOArray,iOArrayTc,"IOArray")
+
+#ifdef __GLASGOW_HASKELL__
+-- Hugs has these too, but their Typeable<n> instances are defined
+-- elsewhere to keep this module within Haskell 98.
+-- This is important because every invocation of runhugs or ffihugs
+-- uses this module via Data.Dynamic.
+INSTANCE_TYPEABLE2(ST,stTc,"ST")
+INSTANCE_TYPEABLE2(STRef,stRefTc,"STRef")
+INSTANCE_TYPEABLE3(STArray,sTArrayTc,"STArray")
+#endif
+
+#ifndef __NHC__
+INSTANCE_TYPEABLE2((,),pairTc,"(,)")
+INSTANCE_TYPEABLE3((,,),tup3Tc,"(,,)")
+INSTANCE_TYPEABLE4((,,,),tup4Tc,"(,,,)")
+INSTANCE_TYPEABLE5((,,,,),tup5Tc,"(,,,,)")
+INSTANCE_TYPEABLE6((,,,,,),tup6Tc,"(,,,,,)")
+INSTANCE_TYPEABLE7((,,,,,,),tup7Tc,"(,,,,,,)")
+#endif /* __NHC__ */
+
+INSTANCE_TYPEABLE1(Ptr,ptrTc,"Ptr")
+INSTANCE_TYPEABLE1(FunPtr,funPtrTc,"FunPtr")
+#ifndef __GLASGOW_HASKELL__
+INSTANCE_TYPEABLE1(ForeignPtr,foreignPtrTc,"ForeignPtr")
+#endif
+INSTANCE_TYPEABLE1(StablePtr,stablePtrTc,"StablePtr")
+INSTANCE_TYPEABLE1(IORef,iORefTc,"IORef")
+
+-------------------------------------------------------
+--
+-- Generate Typeable instances for standard datatypes
+--
+-------------------------------------------------------
+
+INSTANCE_TYPEABLE0(Bool,boolTc,"Bool")
+INSTANCE_TYPEABLE0(Char,charTc,"Char")
+INSTANCE_TYPEABLE0(Float,floatTc,"Float")
+INSTANCE_TYPEABLE0(Double,doubleTc,"Double")
+INSTANCE_TYPEABLE0(Int,intTc,"Int")
+#ifndef __NHC__
+INSTANCE_TYPEABLE0(Word,wordTc,"Word" )
+#endif
+INSTANCE_TYPEABLE0(Integer,integerTc,"Integer")
+INSTANCE_TYPEABLE0(Ordering,orderingTc,"Ordering")
+#ifndef __GLASGOW_HASKELL__
+INSTANCE_TYPEABLE0(Handle,handleTc,"Handle")
+#endif
+
+INSTANCE_TYPEABLE0(Int8,int8Tc,"Int8")
+INSTANCE_TYPEABLE0(Int16,int16Tc,"Int16")
+INSTANCE_TYPEABLE0(Int32,int32Tc,"Int32")
+INSTANCE_TYPEABLE0(Int64,int64Tc,"Int64")
+
+INSTANCE_TYPEABLE0(Word8,word8Tc,"Word8" )
+INSTANCE_TYPEABLE0(Word16,word16Tc,"Word16")
+INSTANCE_TYPEABLE0(Word32,word32Tc,"Word32")
+INSTANCE_TYPEABLE0(Word64,word64Tc,"Word64")
+
+INSTANCE_TYPEABLE0(TyCon,tyconTc,"TyCon")
+INSTANCE_TYPEABLE0(TypeRep,typeRepTc,"TypeRep")
+
+#ifdef __GLASGOW_HASKELL__
+{-
+TODO: This can't be derived currently:
+libraries/base/Data/Typeable.hs:674:1:
+    Can't make a derived instance of `Typeable RealWorld':
+      The last argument of the instance must be a data or newtype application
+    In the stand-alone deriving instance for `Typeable RealWorld'
+-}
+realWorldTc :: TyCon; \
+realWorldTc = mkTyCon3 "ghc-prim" "GHC.Types" "RealWorld"; \
+instance Typeable RealWorld where { typeOf _ = mkTyConApp realWorldTc [] }
+
+#endif
diff --git a/Data/Typeable/Internal.hs-boot b/Data/Typeable/Internal.hs-boot
new file mode 100644 (file)
index 0000000..c83c77e
--- /dev/null
@@ -0,0 +1,28 @@
+{-# LANGUAGE Unsafe #-}
+{-# LANGUAGE CPP, NoImplicitPrelude, MagicHash #-}
+
+module Data.Typeable.Internal (
+    Typeable(typeOf),
+    TypeRep,
+    TyCon,
+    mkTyCon,
+    mkTyConApp
+  ) where
+
+import GHC.Base
+
+data TypeRep
+data TyCon
+
+#include "MachDeps.h"
+
+#if WORD_SIZE_IN_BITS < 64
+mkTyCon :: Word64# -> Word64# -> String -> String -> String -> TyCon
+#else
+mkTyCon :: Word#   -> Word#   -> String -> String -> String -> TyCon
+#endif
+
+mkTyConApp   :: TyCon -> [TypeRep] -> TypeRep
+
+class Typeable a where
+  typeOf :: a -> TypeRep
index 1540999..84a4d07 100644 (file)
@@ -68,3 +68,4 @@ type Word = Word32
   truncate the shift count to the width of the type, for example @1 \<\<
   32 == 1@ in some C implementations. 
 -}
+
index ebacb6c..4400c6c 100644 (file)
@@ -1,4 +1,5 @@
-{-# LANGUAGE CPP, ForeignFunctionInterface #-}
+{-# LANGUAGE Unsafe #-}
+{-# LANGUAGE CPP, ForeignFunctionInterface, MagicHash, UnboxedTuples #-}
 
 -----------------------------------------------------------------------------
 -- |
 -- Stability   :  provisional
 -- Portability :  portable
 --
--- The 'trace' function.
+-- Functions for tracing and monitoring execution.
+--
+-- These can be useful for investigating bugs or performance problems.
+-- They should /not/ be used in production code.
 --
 -----------------------------------------------------------------------------
 
 module Debug.Trace (
         -- * Tracing
-        putTraceMsg,      -- :: String -> IO ()
+        -- $tracing
         trace,            -- :: String -> a -> a
-        traceShow
+        traceShow,
+        traceStack,
+        traceIO,          -- :: String -> IO ()
+        putTraceMsg,
+
+        -- * Eventlog tracing
+        -- $eventlog_tracing
+        traceEvent,
+        traceEventIO,
   ) where
 
 import Prelude
 import System.IO.Unsafe
+import Control.Monad
 
 #ifdef __GLASGOW_HASKELL__
 import Foreign.C.String
+import GHC.Base
+import qualified GHC.Foreign
+import GHC.IO.Encoding
+import GHC.Ptr
+import GHC.Stack
 #else
 import System.IO (hPutStrLn,stderr)
 #endif
 
--- | 'putTraceMsg' function outputs the trace message from IO monad.
--- Usually the output stream is 'System.IO.stderr' but if the function is called
--- from Windows GUI application then the output will be directed to the Windows
--- debug console.
-putTraceMsg :: String -> IO ()
-putTraceMsg msg = do
+-- $tracing
+--
+-- The 'trace', 'traceShow' and 'traceIO' functions print messages to an output
+-- stream. They are intended for \"printf debugging\", that is: tracing the flow
+-- of execution and printing interesting values.
+
+-- The usual output stream is 'System.IO.stderr'. For Windows GUI applications
+-- (that have no stderr) the output is directed to the Windows debug console.
+-- Some implementations of these functions may decorate the string that\'s
+-- output to indicate that you\'re tracing.
+
+-- | The 'traceIO' function outputs the trace message from the IO monad.
+-- This sequences the output with respect to other IO actions.
+--
+traceIO :: String -> IO ()
+traceIO msg = do
 #ifndef __GLASGOW_HASKELL__
     hPutStrLn stderr msg
 #else
@@ -49,24 +77,105 @@ foreign import ccall unsafe "HsBase.h debugBelch2"
    debugBelch :: CString -> CString -> IO ()
 #endif
 
+
+-- | Deprecated. Use 'traceIO'.
+putTraceMsg :: String -> IO ()
+putTraceMsg = traceIO
+{-# DEPRECATED putTraceMsg "Use Debug.Trace.traceIO" #-}
+
+
 {-# NOINLINE trace #-}
 {-|
-When called, 'trace' outputs the string in its first argument, before 
-returning the second argument as its result. The 'trace' function is not 
-referentially transparent, and should only be used for debugging, or for 
-monitoring execution. Some implementations of 'trace' may decorate the string 
-that\'s output to indicate that you\'re tracing. The function is implemented on
-top of 'putTraceMsg'.
+The 'trace' function outputs the trace message given as its first argument,
+before returning the second argument as its result.
+
+For example, this returns the value of @f x@ but first outputs the message.
+
+> trace ("calling f with x = " ++ show x) (f x)
+
+The 'trace' function should /only/ be used for debugging, or for monitoring
+execution. The function is not referentially transparent: its type indicates
+that it is a pure function but it has the side effect of outputting the
+trace message.
 -}
 trace :: String -> a -> a
 trace string expr = unsafePerformIO $ do
-    putTraceMsg string
+    traceIO string
     return expr
 
 {-|
 Like 'trace', but uses 'show' on the argument to convert it to a 'String'.
 
-> traceShow = trace . show
+This makes it convenient for printing the values of interesting variables or
+expressions inside a function. For example here we print the value of the
+variables @x@ and @z@:
+
+> f x y =
+>     traceShow (x, z) $ result
+>   where
+>     z = ...
+>     ...
 -}
 traceShow :: (Show a) => a -> b -> b
 traceShow = trace . show
+
+
+-- $eventlog_tracing
+--
+-- Eventlog tracing is a performance profiling system. These functions emit
+-- extra events into the eventlog. In combination with eventlog profiling
+-- tools these functions can be used for monitoring execution and
+-- investigating performance problems.
+--
+-- Currently only GHC provides eventlog profiling, see the GHC user guide for
+-- details on how to use it. These function exists for other Haskell
+-- implementations but no events are emitted. Note that the string message is
+-- always evaluated, whether or not profiling is available or enabled.
+
+{-# NOINLINE traceEvent #-}
+-- | The 'traceEvent' function behaves like 'trace' with the difference that
+-- the message is emitted to the eventlog, if eventlog profiling is available
+-- and enabled at runtime.
+--
+-- It is suitable for use in pure code. In an IO context use 'traceEventIO'
+-- instead.
+--
+-- Note that when using GHC's SMP runtime, it is possible (but rare) to get
+-- duplicate events emitted if two CPUs simultaneously evaluate the same thunk
+-- that uses 'traceEvent'.
+--
+traceEvent :: String -> a -> a
+traceEvent msg expr = unsafeDupablePerformIO $ do
+    traceEventIO msg
+    return expr
+
+-- | The 'traceEventIO' function emits a message to the eventlog, if eventlog
+-- profiling is available and enabled at runtime.
+--
+-- Compared to 'traceEvent', 'traceEventIO' sequences the event with respect to
+-- other IO actions.
+--
+traceEventIO :: String -> IO ()
+#ifdef __GLASGOW_HASKELL__
+traceEventIO msg =
+  GHC.Foreign.withCString utf8 msg $ \(Ptr p) -> IO $ \s ->
+    case traceEvent# p s of s' -> (# s', () #)
+#else
+traceEventIO msg = (return $! length msg) >> return ()
+#endif
+
+-- | like 'trace', but additionally prints a call stack if one is
+-- available.
+--
+-- In the current GHC implementation, the call stack is only
+-- availble if the program was compiled with @-prof@; otherwise
+-- 'traceStack' behaves exactly like 'trace'.  Entries in the call
+-- stack correspond to @SCC@ annotations, so it is a good idea to use
+-- @-fprof-auto@ or @-fprof-auto-calls@ to add SCC annotations automatically.
+--
+traceStack :: String -> a -> a
+traceStack str expr = unsafePerformIO $ do
+   traceIO str
+   stack <- currentCallStack
+   when (not (null stack)) $ traceIO (renderStack stack)
+   return expr
index e6280b6..caad104 100644 (file)
@@ -1,6 +1,4 @@
-#if sh_SAFE_DEFAULT
-{-# LANGUAGE Trustworthy #-}
-#endif
+{-# LANGUAGE Unsafe #-}
 {-# LANGUAGE NoImplicitPrelude #-}
 
 -----------------------------------------------------------------------------
@@ -28,7 +26,6 @@ module Foreign
         , module Foreign.Storable
         , module Foreign.Marshal
 
-#if !sh_SAFE_DEFAULT
         -- * Unsafe Functions
 
         -- | 'unsafePerformIO' is exported here for backwards
@@ -36,7 +33,6 @@ module Foreign
         -- the FFI, use 'unsafeLocalState'.  For other uses, see
         -- 'System.IO.Unsafe.unsafePerformIO'.
         , unsafePerformIO
-#endif
         ) where
 
 import Data.Bits
@@ -48,14 +44,12 @@ import Foreign.StablePtr
 import Foreign.Storable
 import Foreign.Marshal
 
-#if !sh_SAFE_DEFAULT
 import GHC.IO (IO)
-import qualified System.IO.Unsafe (unsafePerformIO)
+import qualified GHC.IO (unsafePerformIO)
 
 {-# DEPRECATED unsafePerformIO "Use System.IO.Unsafe.unsafePerformIO instead; This function will be removed in the next release" #-}
 
 {-# INLINE unsafePerformIO #-}
 unsafePerformIO :: IO a -> a
-unsafePerformIO = System.IO.Unsafe.unsafePerformIO
-#endif
+unsafePerformIO = GHC.IO.unsafePerformIO
 
index 2e925cc..83ab6b8 100644 (file)
@@ -24,3 +24,4 @@ module Foreign.C
 import Foreign.C.Types
 import Foreign.C.String
 import Foreign.C.Error
+
index 6d3ef80..020f08e 100644 (file)
@@ -401,34 +401,36 @@ throwErrnoIfRetryMayBlock_ pred loc f on_block
 -- | Throw an 'IOError' corresponding to the current value of 'getErrno'
 -- if the 'IO' action returns a result of @-1@.
 --
-throwErrnoIfMinus1 :: Num a => String -> IO a -> IO a
+throwErrnoIfMinus1 :: (Eq a, Num a) => String -> IO a -> IO a
 throwErrnoIfMinus1  = throwErrnoIf (== -1)
 
 -- | as 'throwErrnoIfMinus1', but discards the result.
 --
-throwErrnoIfMinus1_ :: Num a => String -> IO a -> IO ()
+throwErrnoIfMinus1_ :: (Eq a, Num a) => String -> IO a -> IO ()
 throwErrnoIfMinus1_  = throwErrnoIf_ (== -1)
 
 -- | Throw an 'IOError' corresponding to the current value of 'getErrno'
 -- if the 'IO' action returns a result of @-1@, but retries in case of
 -- an interrupted operation.
 --
-throwErrnoIfMinus1Retry :: Num a => String -> IO a -> IO a
+throwErrnoIfMinus1Retry :: (Eq a, Num a) => String -> IO a -> IO a
 throwErrnoIfMinus1Retry  = throwErrnoIfRetry (== -1)
 
 -- | as 'throwErrnoIfMinus1', but discards the result.
 --
-throwErrnoIfMinus1Retry_ :: Num a => String -> IO a -> IO ()
+throwErrnoIfMinus1Retry_ :: (Eq a, Num a) => String -> IO a -> IO ()
 throwErrnoIfMinus1Retry_  = throwErrnoIfRetry_ (== -1)
 
 -- | as 'throwErrnoIfMinus1Retry', but checks for operations that would block.
 --
-throwErrnoIfMinus1RetryMayBlock :: Num a => String -> IO a -> IO b -> IO a
+throwErrnoIfMinus1RetryMayBlock :: (Eq a, Num a)
+                                => String -> IO a -> IO b -> IO a
 throwErrnoIfMinus1RetryMayBlock  = throwErrnoIfRetryMayBlock (== -1)
 
 -- | as 'throwErrnoIfMinus1RetryMayBlock', but discards the result.
 --
-throwErrnoIfMinus1RetryMayBlock_ :: Num a => String -> IO a -> IO b -> IO ()
+throwErrnoIfMinus1RetryMayBlock_ :: (Eq a, Num a)
+                                 => String -> IO a -> IO b -> IO ()
 throwErrnoIfMinus1RetryMayBlock_  = throwErrnoIfRetryMayBlock_ (== -1)
 
 -- | Throw an 'IOError' corresponding to the current value of 'getErrno'
@@ -481,13 +483,13 @@ throwErrnoPathIfNull  = throwErrnoPathIf (== nullPtr)
 -- | as 'throwErrnoIfMinus1', but exceptions include the given path when
 --   appropriate.
 --
-throwErrnoPathIfMinus1 :: Num a => String -> FilePath -> IO a -> IO a
+throwErrnoPathIfMinus1 :: (Eq a, Num a) => String -> FilePath -> IO a -> IO a
 throwErrnoPathIfMinus1 = throwErrnoPathIf (== -1)
 
 -- | as 'throwErrnoIfMinus1_', but exceptions include the given path when
 --   appropriate.
 --
-throwErrnoPathIfMinus1_ :: Num a => String -> FilePath -> IO a -> IO ()
+throwErrnoPathIfMinus1_ :: (Eq a, Num a) => String -> FilePath -> IO a -> IO ()
 throwErrnoPathIfMinus1_  = throwErrnoPathIf_ (== -1)
 
 -- conversion of an "errno" value into IO error
@@ -614,3 +616,4 @@ errnoToIOError loc errno maybeHdl maybeName = unsafePerformIO $ do
 #endif
 
 foreign import ccall unsafe "string.h" strerror :: Errno -> IO (Ptr CChar)
+
index f369916..47ce2b2 100644 (file)
@@ -147,7 +147,7 @@ peekCString    :: CString -> IO String
 #ifndef __GLASGOW_HASKELL__
 peekCString = peekCAString
 #else
-peekCString = GHC.peekCString foreignEncoding
+peekCString s = getForeignEncoding >>= flip GHC.peekCString s
 #endif
 
 -- | Marshal a C string with explicit length into a Haskell string.
@@ -156,7 +156,7 @@ peekCStringLen           :: CStringLen -> IO String
 #ifndef __GLASGOW_HASKELL__
 peekCStringLen = peekCAStringLen
 #else
-peekCStringLen = GHC.peekCStringLen foreignEncoding
+peekCStringLen s = getForeignEncoding >>= flip GHC.peekCStringLen s
 #endif
 
 -- | Marshal a Haskell string into a NUL terminated C string.
@@ -171,7 +171,7 @@ newCString :: String -> IO CString
 #ifndef __GLASGOW_HASKELL__
 newCString = newCAString
 #else
-newCString = GHC.newCString foreignEncoding
+newCString s = getForeignEncoding >>= flip GHC.newCString s
 #endif
 
 -- | Marshal a Haskell string into a C string (ie, character array) with
@@ -185,7 +185,7 @@ newCStringLen     :: String -> IO CStringLen
 #ifndef __GLASGOW_HASKELL__
 newCStringLen = newCAStringLen
 #else
-newCStringLen = GHC.newCStringLen foreignEncoding
+newCStringLen s = getForeignEncoding >>= flip GHC.newCStringLen s
 #endif
 
 -- | Marshal a Haskell string into a NUL terminated C string using temporary
@@ -201,7 +201,7 @@ withCString :: String -> (CString -> IO a) -> IO a
 #ifndef __GLASGOW_HASKELL__
 withCString = withCAString
 #else
-withCString = GHC.withCString foreignEncoding
+withCString s f = getForeignEncoding >>= \enc -> GHC.withCString enc s f
 #endif
 
 -- | Marshal a Haskell string into a C string (ie, character array)
@@ -215,7 +215,7 @@ withCStringLen         :: String -> (CStringLen -> IO a) -> IO a
 #ifndef __GLASGOW_HASKELL__
 withCStringLen = withCAStringLen
 #else
-withCStringLen = GHC.withCStringLen foreignEncoding
+withCStringLen s f = getForeignEncoding >>= \enc -> GHC.withCStringLen enc s f
 #endif
 
 
@@ -230,7 +230,7 @@ charIsRepresentable c = return (ord c < 256)
 -- -- | Determines whether a character can be accurately encoded in a 'CString'.
 -- -- Unrepresentable characters are converted to '?' or their nearest visual equivalent.
 charIsRepresentable :: Char -> IO Bool
-charIsRepresentable = GHC.charIsRepresentable foreignEncoding
+charIsRepresentable c = getForeignEncoding >>= flip GHC.charIsRepresentable c
 #endif
 
 -- single byte characters
@@ -484,10 +484,9 @@ newCWStringLen str  = newArrayLen (charsToCWchars str)
 withCWString :: String -> (CWString -> IO a) -> IO a
 withCWString  = withArray0 wNUL . charsToCWchars
 
--- | Marshal a Haskell string into a NUL terminated C wide string using
--- temporary storage.
---
--- * the Haskell string may /not/ contain any NUL characters
+-- | Marshal a Haskell string into a C wide string (i.e. wide
+-- character array) in temporary storage, with explicit length
+-- information.
 --
 -- * the memory is freed when the subcomputation terminates (either
 --   normally or via an exception), so the pointer to the temporary
@@ -542,3 +541,4 @@ castCharToCWchar :: Char -> CWchar
 castCharToCWchar ch = fromIntegral (ord ch)
 
 #endif /* !mingw32_HOST_OS */
+
index c571049..9da95a9 100644 (file)
@@ -27,7 +27,6 @@
 
 module Foreign.C.Types
         ( -- * Representations of C types
-#ifndef __NHC__
           -- $ctypes
 
           -- ** Integral types
@@ -37,20 +36,19 @@ module Foreign.C.Types
           -- 'Prelude.Show', 'Prelude.Enum', 'Typeable', 'Storable',
           -- 'Prelude.Bounded', 'Prelude.Real', 'Prelude.Integral' and
           -- 'Bits'.
-          CChar,  CSChar,  CUChar
-        , CShort, CUShort, CInt,   CUInt
-        , CLong,  CULong
-        , CPtrdiff, CSize, CWchar, CSigAtomic
-        , CLLong, CULLong
-        , CIntPtr, CUIntPtr
-        , CIntMax, CUIntMax
+          CChar(..),    CSChar(..),   CUChar(..)
+        , CShort(..),   CUShort(..),  CInt(..),      CUInt(..)
+        , CLong(..),    CULong(..)
+        , CPtrdiff(..), CSize(..),    CWchar(..),    CSigAtomic(..)
+        , CLLong(..),   CULLong(..)
+        , CIntPtr(..),  CUIntPtr(..), CIntMax(..),   CUIntMax(..)
 
           -- ** Numeric types
           -- | These types are are represented as @newtype@s of basic
           -- foreign types, and are instances of
           -- 'Prelude.Eq', 'Prelude.Ord', 'Prelude.Num', 'Prelude.Read',
           -- 'Prelude.Show', 'Prelude.Enum', 'Typeable' and 'Storable'.
-        , CClock,   CTime, CUSeconds, CSUSeconds
+        , CClock(..),   CTime(..),    CUSeconds(..), CSUSeconds(..)
 
         -- extracted from CTime, because we don't want this comment in
         -- the Haskell 2010 report:
@@ -67,21 +65,10 @@ module Foreign.C.Types
           -- 'Prelude.Show', 'Prelude.Enum', 'Typeable', 'Storable',
           -- 'Prelude.Real', 'Prelude.Fractional', 'Prelude.Floating',
           -- 'Prelude.RealFrac' and 'Prelude.RealFloat'.
-        , CFloat,  CDouble
+        , CFloat(..),   CDouble(..)
 -- GHC doesn't support CLDouble yet
 #ifndef __GLASGOW_HASKELL__
-        , CLDouble
-#endif
-#else
-          -- Exported non-abstractly in nhc98 to fix an interface file problem.
-          CChar(..),    CSChar(..),   CUChar(..)
-        , CShort(..),   CUShort(..),  CInt(..),      CUInt(..)
-        , CLong(..),    CULong(..)
-        , CPtrdiff(..), CSize(..),    CWchar(..),    CSigAtomic(..)
-        , CLLong(..),   CULLong(..)
-        , CClock(..),   CTime(..),    CUSeconds(..), CSUSeconds(..)
-        , CFloat(..),   CDouble(..),  CLDouble(..)
-        , CIntPtr(..),  CUIntPtr(..), CIntMax(..),   CUIntMax(..)
+        , CLDouble(..)
 #endif
           -- ** Other types
 
@@ -96,6 +83,8 @@ import Data.Bits        ( Bits(..) )
 import Data.Int         ( Int8,  Int16,  Int32,  Int64  )
 import Data.Word        ( Word8, Word16, Word32, Word64 )
 import {-# SOURCE #-} Data.Typeable
+  -- loop: Data.Typeable -> Data.List -> Data.Char -> GHC.Unicode
+  --            -> Foreign.C.Type
 
 #ifdef __GLASGOW_HASKELL__
 import GHC.Base
@@ -318,7 +307,8 @@ instance Bits T where { \
   complementBit (T x) n = T (complementBit x n) ; \
   testBit       (T x) n = testBit x n ; \
   bitSize       (T x)   = bitSize x ; \
-  isSigned      (T x)   = isSigned x }
+  isSigned      (T x)   = isSigned x ; \
+  popCount      (T x)   = popCount x }
 
 INSTANCE_BITS(CChar)
 INSTANCE_BITS(CSChar)
@@ -341,3 +331,4 @@ INSTANCE_BITS(CIntMax)
 INSTANCE_BITS(CUIntMax)
 
 #endif
+
index 0199fe7..5288ce7 100644 (file)
@@ -1,7 +1,5 @@
-{-# LANGUAGE SafeImports, CPP, NoImplicitPrelude #-}
-#if sh_SAFE_DEFAULT
-{-# LANGUAGE Trustworthy #-}
-#endif
+{-# LANGUAGE Unsafe #-}
+{-# LANGUAGE CPP, NoImplicitPrelude #-}
 {-# OPTIONS_HADDOCK hide #-}
 
 -----------------------------------------------------------------------------
 -----------------------------------------------------------------------------
 
 module Foreign.ForeignPtr ( 
-          module Foreign.ForeignPtr.Safe
-#if !sh_SAFE_DEFAULT
+        -- * Finalised data pointers
+          ForeignPtr
+        , FinalizerPtr
+#if defined(__HUGS__) || defined(__GLASGOW_HASKELL__)
+        , FinalizerEnvPtr
+#endif
+        -- ** Basic operations
+        , newForeignPtr
+        , newForeignPtr_
+        , addForeignPtrFinalizer
+#if defined(__HUGS__) || defined(__GLASGOW_HASKELL__)
+        , newForeignPtrEnv
+        , addForeignPtrFinalizerEnv
+#endif
+        , withForeignPtr
+
+#ifdef __GLASGOW_HASKELL__
+        , finalizeForeignPtr
+#endif
+
+        -- ** Low-level operations
+        , touchForeignPtr
+        , castForeignPtr
+
+        -- ** Allocating managed memory
+        , mallocForeignPtr
+        , mallocForeignPtrBytes
+        , mallocForeignPtrArray
+        , mallocForeignPtrArray0
         -- ** Unsafe low-level operations
         , unsafeForeignPtrToPtr
-#endif
     ) where
 
-import safe Foreign.ForeignPtr.Safe
+import Foreign.ForeignPtr.Safe
 
-#if !sh_SAFE_DEFAULT
 import Foreign.Ptr ( Ptr )
 import qualified Foreign.ForeignPtr.Unsafe as U
 
@@ -38,5 +61,4 @@ import qualified Foreign.ForeignPtr.Unsafe as U
 {-# INLINE unsafeForeignPtrToPtr #-}
 unsafeForeignPtrToPtr :: ForeignPtr a -> Ptr a
 unsafeForeignPtrToPtr = U.unsafeForeignPtrToPtr
-#endif
 
index 6ce615f..336f032 100644 (file)
@@ -1,3 +1,4 @@
+{-# LANGUAGE Unsafe #-}
 {-# LANGUAGE CPP, NoImplicitPrelude #-}
 {-# OPTIONS_HADDOCK hide #-}
 
@@ -178,3 +179,4 @@ mallocForeignPtrArray  = doMalloc undefined
 -- the block of memory was allocated by 'Foreign.Marshal.Alloc.malloc'.
 mallocForeignPtrArray0      :: Storable a => Int -> IO (ForeignPtr a)
 mallocForeignPtrArray0 size  = mallocForeignPtrArray (size + 1)
+
index 8980ab9..7cc9a25 100644 (file)
@@ -1,4 +1,4 @@
-{-# LANGUAGE Trustworthy #-}
+{-# LANGUAGE Unsafe #-}
 {-# LANGUAGE CPP, NoImplicitPrelude #-}
 
 -----------------------------------------------------------------------------
index 438dc2f..cb0ef41 100644 (file)
@@ -1,3 +1,4 @@
+{-# LANGUAGE Unsafe #-}
 {-# LANGUAGE CPP, NoImplicitPrelude #-}
 
 -----------------------------------------------------------------------------
 
 module Foreign.Marshal
         (
-         -- | The module "Foreign.Marshal" re-exports the other modules in the
+         -- | The module "Foreign.Marshal" re-exports the safe content in the
          -- @Foreign.Marshal@ hierarchy:
-          module Foreign.Marshal.Alloc
-        , module Foreign.Marshal.Array
-        , module Foreign.Marshal.Error
-        , module Foreign.Marshal.Pool
-        , module Foreign.Marshal.Utils
+          module Foreign.Marshal.Safe
          -- | and provides one function:
         , unsafeLocalState
         ) where
 
-import Foreign.Marshal.Alloc
-import Foreign.Marshal.Array
-import Foreign.Marshal.Error
-import Foreign.Marshal.Pool
-import Foreign.Marshal.Utils
+import Foreign.Marshal.Safe
 
 #ifdef __GLASGOW_HASKELL__
 import GHC.IO
index 74db164..515af4a 100644 (file)
@@ -62,7 +62,7 @@ module Foreign.Marshal.Alloc (
 ) where
 
 import Data.Maybe
-import Foreign.C.Types          ( CSize )
+import Foreign.C.Types          ( CSize(..) )
 import Foreign.Storable         ( Storable(sizeOf,alignment) )
 
 #ifndef __GLASGOW_HASKELL__
@@ -245,3 +245,4 @@ foreign import ccall unsafe "stdlib.h free"    _free    :: Ptr a -> IO ()
 -- used as a finalizer (cf 'Foreign.ForeignPtr.ForeignPtr') for storage
 -- allocated with 'malloc', 'mallocBytes', 'realloc' or 'reallocBytes'.
 foreign import ccall unsafe "stdlib.h &free" finalizerFree :: FinalizerPtr a
+
index e284ec4..04825aa 100644 (file)
@@ -277,3 +277,4 @@ advancePtr  = doAdvance undefined
   where
     doAdvance             :: Storable a' => a' -> Ptr a' -> Int -> Ptr a'
     doAdvance dummy ptr i  = ptr `plusPtr` (i * sizeOf dummy)
+
index 9e3ad3b..5fe9a7e 100644 (file)
@@ -83,3 +83,4 @@ throwIfNull  = throwIf (== nullPtr) . const
 --
 void     :: IO a -> IO ()
 void act  = act >> return ()
+
index 8ca160d..6953c0b 100644 (file)
@@ -209,3 +209,4 @@ pooledNewArray0 pool marker vals = do
    ptr <- pooledMallocArray0 pool (length vals)
    pokeArray0 marker ptr vals
    return ptr
+
index 1fa0e3a..ee05fd4 100644 (file)
@@ -1,4 +1,4 @@
-{-# LANGUAGE Trustworthy #-}
+{-# LANGUAGE Unsafe #-}
 {-# LANGUAGE CPP, NoImplicitPrelude #-}
 
 -----------------------------------------------------------------------------
@@ -45,5 +45,5 @@ It is expected that this operation will be
 replaced in a future revision of Haskell.
 -}
 unsafeLocalState :: IO a -> a
-unsafeLocalState = unsafePerformIO
+unsafeLocalState = unsafeDupablePerformIO
 
index d3ab1fd..c9e1fd6 100644 (file)
@@ -51,7 +51,7 @@ module Foreign.Marshal.Utils (
 import Data.Maybe
 import Foreign.Ptr              ( Ptr, nullPtr )
 import Foreign.Storable         ( Storable(poke) )
-import Foreign.C.Types          ( CSize )
+import Foreign.C.Types          ( CSize(..) )
 import Foreign.Marshal.Alloc    ( malloc, alloca )
 
 #ifdef __GLASGOW_HASKELL__
@@ -108,7 +108,7 @@ fromBool True   = 1
 
 -- |Convert a Boolean in numeric representation to a Haskell value
 --
-toBool :: Num a => a -> Bool
+toBool :: (Eq a, Num a) => a -> Bool
 toBool  = (/= 0)
 
 
@@ -178,3 +178,4 @@ moveBytes dest src size  = do _ <- memmove dest src (fromIntegral size)
 --
 foreign import ccall unsafe "string.h" memcpy  :: Ptr a -> Ptr a -> CSize -> IO (Ptr a)
 foreign import ccall unsafe "string.h" memmove :: Ptr a -> Ptr a -> CSize -> IO (Ptr a)
+
index d6588f5..56a3692 100644 (file)
@@ -162,3 +162,4 @@ foreign import ccall unsafe "__hscore_from_intptr"
 
 # endif /* !__GLASGOW_HASKELL__ */
 #endif /* !__NHC_ */
+
index 68b2056..d0b6625 100644 (file)
@@ -61,3 +61,4 @@ import NHC.FFI
 -- guarantee provided is that if they are passed back to Haskell land, the
 -- function 'deRefStablePtr' will be able to reconstruct the
 -- Haskell value referred to by the stable pointer.
+
index 482b5d9..9ba6bb9 100644 (file)
@@ -1,5 +1,8 @@
 {-# LANGUAGE Trustworthy #-}
 {-# LANGUAGE CPP, NoImplicitPrelude, ScopedTypeVariables #-}
+#ifdef __GLASGOW_HASKELL__
+{-# LANGUAGE BangPatterns #-}
+#endif
 
 -----------------------------------------------------------------------------
 -- |
@@ -51,6 +54,9 @@ import GHC.Word
 import GHC.Ptr
 import GHC.Err
 import GHC.Base
+import GHC.Fingerprint.Type
+import Data.Bits
+import GHC.Real
 #else
 import Data.Int
 import Data.Word
@@ -244,3 +250,38 @@ STORABLE(Int64,SIZEOF_INT64,ALIGNMENT_INT64,
          readInt64OffPtr,writeInt64OffPtr)
 
 #endif
+
+-- XXX: here to avoid orphan instance in GHC.Fingerprint
+#ifdef __GLASGOW_HASKELL__
+instance Storable Fingerprint where
+  sizeOf _ = 16
+  alignment _ = 8
+  peek = peekFingerprint
+  poke = pokeFingerprint
+
+-- peek/poke in fixed BIG-endian 128-bit format
+peekFingerprint :: Ptr Fingerprint -> IO Fingerprint
+peekFingerprint p0 = do
+      let peekW64 :: Ptr Word8 -> Int -> Word64 -> IO Word64
+          peekW64 _  0  !i = return i
+          peekW64 !p !n !i = do
+                w8 <- peek p
+                peekW64 (p `plusPtr` 1) (n-1) 
+                    ((i `shiftL` 8) .|. fromIntegral w8)
+
+      high <- peekW64 (castPtr p0) 8 0
+      low  <- peekW64 (castPtr p0 `plusPtr` 8) 8 0
+      return (Fingerprint high low)
+
+pokeFingerprint :: Ptr Fingerprint -> Fingerprint -> IO ()
+pokeFingerprint p0 (Fingerprint high low) = do
+      let pokeW64 :: Ptr Word8 -> Int -> Word64 -> IO ()
+          pokeW64 _ 0  _  = return ()
+          pokeW64 p !n !i = do
+                pokeElemOff p (n-1) (fromIntegral i)
+                pokeW64 p (n-1) (i `shiftR` 8)
+
+      pokeW64 (castPtr p0) 8 high
+      pokeW64 (castPtr p0 `plusPtr` 8) 8 low
+#endif
+
index 9ef2090..0b3d918 100644 (file)
@@ -1,4 +1,5 @@
 \begin{code}
+{-# LANGUAGE Unsafe #-}
 {-# LANGUAGE NoImplicitPrelude, NoBangPatterns, MagicHash, UnboxedTuples #-}
 {-# OPTIONS_GHC -funbox-strict-fields #-}
 {-# OPTIONS_HADDOCK hide #-}
index f4181eb..e062a36 100644 (file)
@@ -62,6 +62,7 @@ GHC.Float       Classes: Floating, RealFloat
 Other Prelude modules are much easier with fewer complex dependencies.
 
 \begin{code}
+{-# LANGUAGE Unsafe #-}
 {-# LANGUAGE CPP
            , NoImplicitPrelude
            , BangPatterns
@@ -98,9 +99,6 @@ module GHC.Base
         module GHC.Base,
         module GHC.Classes,
         module GHC.CString,
-        -- module GHC.Generics,        -- JPM: We no longer export GHC.Generics
-                                      -- by default to avoid name clashes
-        module GHC.Ordering,
         module GHC.Types,
         module GHC.Prim,        -- Re-export GHC.Prim and GHC.Err, to avoid lots
         module GHC.Err          -- of people having to import it explicitly
@@ -110,19 +108,19 @@ module GHC.Base
 import GHC.Types
 import GHC.Classes
 import GHC.CString
--- JPM: Since we don't export it, we don't need to import GHC.Generics
--- import GHC.Generics
-import GHC.Ordering
 import GHC.Prim
 import {-# SOURCE #-} GHC.Show
 import {-# SOURCE #-} GHC.Err
 import {-# SOURCE #-} GHC.IO (failIO)
 
--- These two are not strictly speaking required by this module, but they are
--- implicit dependencies whenever () or tuples are mentioned, so adding them
--- as imports here helps to get the dependencies right in the new build system.
+-- This is not strictly speaking required by this module, but is an
+-- implicit dependency whenever () or tuples are mentioned, so adding it
+-- as an import here helps to get the dependencies right in the new
+-- build system.
 import GHC.Tuple ()
-import GHC.Unit ()
+-- Likewise we need Integer when deriving things like Eq instances, and
+-- this is a convenient place to force it to be built
+import GHC.Integer ()
 
 infixr 9  .
 infixr 5  ++
diff --git a/GHC/Classes.hs b/GHC/Classes.hs
deleted file mode 100644 (file)
index 071905c..0000000
+++ /dev/null
@@ -1,297 +0,0 @@
-{-# LANGUAGE Trustworthy #-}
-{-# LANGUAGE NoImplicitPrelude, MagicHash, StandaloneDeriving #-}
-{-# OPTIONS_GHC -fno-warn-unused-imports #-}
--- XXX -fno-warn-unused-imports needed for the GHC.Tuple import below. Sigh.
-{-# OPTIONS_HADDOCK hide #-}
------------------------------------------------------------------------------
--- |
--- Module      :  GHC.Classes
--- Copyright   :  (c) The University of Glasgow, 1992-2002
--- License     :  see libraries/base/LICENSE
---
--- Maintainer  :  cvs-ghc@haskell.org
--- Stability   :  internal
--- Portability :  non-portable (GHC extensions)
---
--- Basic classes.
---
------------------------------------------------------------------------------
-
-module GHC.Classes where
-
-import GHC.Integer
--- GHC.Magic is used in some derived instances
-import GHC.Magic ()
-import GHC.Ordering
-import GHC.Prim
-import GHC.Tuple
-import GHC.Types
-import GHC.Unit
--- For defining instances for the generic deriving mechanism
-import GHC.Generics (Arity(..), Associativity(..), Fixity(..))
-
-
-infix  4  ==, /=, <, <=, >=, >
-infixr 3  &&
-infixr 2  ||
-
-default ()              -- Double isn't available yet
-
--- | The 'Eq' class defines equality ('==') and inequality ('/=').
--- All the basic datatypes exported by the "Prelude" are instances of 'Eq',
--- and 'Eq' may be derived for any datatype whose constituents are also
--- instances of 'Eq'.
---
--- Minimal complete definition: either '==' or '/='.
---
-class  Eq a  where
-    (==), (/=)           :: a -> a -> Bool
-
-    {-# INLINE (/=) #-}
-    {-# INLINE (==) #-}
-    x /= y               = not (x == y)
-    x == y               = not (x /= y)
-
-deriving instance Eq ()
-deriving instance (Eq  a, Eq  b) => Eq  (a, b)
-deriving instance (Eq  a, Eq  b, Eq  c) => Eq  (a, b, c)
-deriving instance (Eq  a, Eq  b, Eq  c, Eq  d) => Eq  (a, b, c, d)
-deriving instance (Eq  a, Eq  b, Eq  c, Eq  d, Eq  e) => Eq  (a, b, c, d, e)
-deriving instance (Eq a, Eq b, Eq c, Eq d, Eq e, Eq f)
-               => Eq (a, b, c, d, e, f)
-deriving instance (Eq a, Eq b, Eq c, Eq d, Eq e, Eq f, Eq g)
-               => Eq (a, b, c, d, e, f, g)
-deriving instance (Eq a, Eq b, Eq c, Eq d, Eq e, Eq f, Eq g,
-                   Eq h)
-               => Eq (a, b, c, d, e, f, g, h)
-deriving instance (Eq a, Eq b, Eq c, Eq d, Eq e, Eq f, Eq g,
-                   Eq h, Eq i)
-               => Eq (a, b, c, d, e, f, g, h, i)
-deriving instance (Eq a, Eq b, Eq c, Eq d, Eq e, Eq f, Eq g,
-                   Eq h, Eq i, Eq j)
-               => Eq (a, b, c, d, e, f, g, h, i, j)
-deriving instance (Eq a, Eq b, Eq c, Eq d, Eq e, Eq f, Eq g,
-                   Eq h, Eq i, Eq j, Eq k)
-               => Eq (a, b, c, d, e, f, g, h, i, j, k)
-deriving instance (Eq a, Eq b, Eq c, Eq d, Eq e, Eq f, Eq g,
-                   Eq h, Eq i, Eq j, Eq k, Eq l)
-               => Eq (a, b, c, d, e, f, g, h, i, j, k, l)
-deriving instance (Eq a, Eq b, Eq c, Eq d, Eq e, Eq f, Eq g,
-                   Eq h, Eq i, Eq j, Eq k, Eq l, Eq m)
-               => Eq (a, b, c, d, e, f, g, h, i, j, k, l, m)
-deriving instance (Eq a, Eq b, Eq c, Eq d, Eq e, Eq f, Eq g,
-                   Eq h, Eq i, Eq j, Eq k, Eq l, Eq m, Eq n)
-               => Eq (a, b, c, d, e, f, g, h, i, j, k, l, m, n)
-deriving instance (Eq a, Eq b, Eq c, Eq d, Eq e, Eq f, Eq g,
-                   Eq h, Eq i, Eq j, Eq k, Eq l, Eq m, Eq n, Eq o)
-               => Eq (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o)
-
-instance (Eq a) => Eq [a] where
-    {-# SPECIALISE instance Eq [Char] #-}
-    []     == []     = True
-    (x:xs) == (y:ys) = x == y && xs == ys
-    _xs    == _ys    = False
-
-deriving instance Eq Bool
-deriving instance Eq Ordering
-
-instance Eq Char where
-    (C# c1) == (C# c2) = c1 `eqChar#` c2
-    (C# c1) /= (C# c2) = c1 `neChar#` c2
-
-instance  Eq Integer  where
-    (==) = eqInteger
-    (/=) = neqInteger
-
-instance Eq Float where
-    (F# x) == (F# y) = x `eqFloat#` y
-
-instance Eq Double where
-    (D# x) == (D# y) = x ==## y
-
-instance Eq Int where
-    (==) = eqInt
-    (/=) = neInt
-
-{-# INLINE eqInt #-}
-{-# INLINE neInt #-}
-eqInt, neInt :: Int -> Int -> Bool
-(I# x) `eqInt` (I# y) = x ==# y
-(I# x) `neInt` (I# y) = x /=# y
-
--- | The 'Ord' class is used for totally ordered datatypes.
---
--- Instances of 'Ord' can be derived for any user-defined
--- datatype whose constituent types are in 'Ord'.  The declared order
--- of the constructors in the data declaration determines the ordering
--- in derived 'Ord' instances.  The 'Ordering' datatype allows a single
--- comparison to determine the precise ordering of two objects.
---
--- Minimal complete definition: either 'compare' or '<='.
--- Using 'compare' can be more efficient for complex types.
---
-class  (Eq a) => Ord a  where
-    compare              :: a -> a -> Ordering
-    (<), (<=), (>), (>=) :: a -> a -> Bool
-    max, min             :: a -> a -> a
-
-    compare x y = if x == y then EQ
-                  -- NB: must be '<=' not '<' to validate the
-                  -- above claim about the minimal things that
-                  -- can be defined for an instance of Ord:
-                  else if x <= y then LT
-                  else GT
-
-    x <  y = case compare x y of { LT -> True;  _ -> False }
-    x <= y = case compare x y of { GT -> False; _ -> True }
-    x >  y = case compare x y of { GT -> True;  _ -> False }
-    x >= y = case compare x y of { LT -> False; _ -> True }
-
-        -- These two default methods use '<=' rather than 'compare'
-        -- because the latter is often more expensive
-    max x y = if x <= y then y else x
-    min x y = if x <= y then x else y
-
-deriving instance Ord ()
-deriving instance (Ord a, Ord b) => Ord (a, b)
-deriving instance (Ord a, Ord b, Ord c) => Ord (a, b, c)
-deriving instance (Ord a, Ord b, Ord c, Ord d) => Ord (a, b, c, d)
-deriving instance (Ord a, Ord b, Ord c, Ord d, Ord e) => Ord (a, b, c, d, e)
-deriving instance (Ord a, Ord b, Ord c, Ord d, Ord e, Ord f)
-               => Ord (a, b, c, d, e, f)
-deriving instance (Ord a, Ord b, Ord c, Ord d, Ord e, Ord f, Ord g)
-               => Ord (a, b, c, d, e, f, g)
-deriving instance (Ord a, Ord b, Ord c, Ord d, Ord e, Ord f, Ord g,
-                   Ord h)
-               => Ord (a, b, c, d, e, f, g, h)
-deriving instance (Ord a, Ord b, Ord c, Ord d, Ord e, Ord f, Ord g,
-                   Ord h, Ord i)
-               => Ord (a, b, c, d, e, f, g, h, i)
-deriving instance (Ord a, Ord b, Ord c, Ord d, Ord e, Ord f, Ord g,
-                   Ord h, Ord i, Ord j)
-               => Ord (a, b, c, d, e, f, g, h, i, j)
-deriving instance (Ord a, Ord b, Ord c, Ord d, Ord e, Ord f, Ord g,
-                   Ord h, Ord i, Ord j, Ord k)
-               => Ord (a, b, c, d, e, f, g, h, i, j, k)
-deriving instance (Ord a, Ord b, Ord c, Ord d, Ord e, Ord f, Ord g,
-                   Ord h, Ord i, Ord j, Ord k, Ord l)
-               => Ord (a, b, c, d, e, f, g, h, i, j, k, l)
-deriving instance (Ord a, Ord b, Ord c, Ord d, Ord e, Ord f, Ord g,
-                   Ord h, Ord i, Ord j, Ord k, Ord l, Ord m)
-               => Ord (a, b, c, d, e, f, g, h, i, j, k, l, m)
-deriving instance (Ord a, Ord b, Ord c, Ord d, Ord e, Ord f, Ord g,
-                   Ord h, Ord i, Ord j, Ord k, Ord l, Ord m, Ord n)
-               => Ord (a, b, c, d, e, f, g, h, i, j, k, l, m, n)
-deriving instance (Ord a, Ord b, Ord c, Ord d, Ord e, Ord f, Ord g,
-                   Ord h, Ord i, Ord j, Ord k, Ord l, Ord m, Ord n, Ord o)
-               => Ord (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o)
-
-instance (Ord a) => Ord [a] where
-    {-# SPECIALISE instance Ord [Char] #-}
-    compare []     []     = EQ
-    compare []     (_:_)  = LT
-    compare (_:_)  []     = GT
-    compare (x:xs) (y:ys) = case compare x y of
-                                EQ    -> compare xs ys
-                                other -> other
-
-deriving instance Ord Bool
-deriving instance Ord Ordering
-
--- We don't use deriving for Ord Char, because for Ord the derived
--- instance defines only compare, which takes two primops.  Then
--- '>' uses compare, and therefore takes two primops instead of one.
-instance Ord Char where
-    (C# c1) >  (C# c2) = c1 `gtChar#` c2
-    (C# c1) >= (C# c2) = c1 `geChar#` c2
-    (C# c1) <= (C# c2) = c1 `leChar#` c2
-    (C# c1) <  (C# c2) = c1 `ltChar#` c2
-
-instance Ord Integer where
-    (<=) = leInteger
-    (>)  = gtInteger
-    (<)  = ltInteger
-    (>=) = geInteger
-    compare = compareInteger
-
-instance Ord Float where
-    (F# x) `compare` (F# y)
-        = if      x `ltFloat#` y then LT
-          else if x `eqFloat#` y then EQ
-          else                        GT
-
-    (F# x) <  (F# y) = x `ltFloat#`  y
-    (F# x) <= (F# y) = x `leFloat#`  y
-    (F# x) >= (F# y) = x `geFloat#`  y
-    (F# x) >  (F# y) = x `gtFloat#`  y
-
-instance Ord Double where
-    (D# x) `compare` (D# y)
-        = if      x <##  y then LT
-          else if x ==## y then EQ
-          else                  GT
-
-    (D# x) <  (D# y) = x <##  y
-    (D# x) <= (D# y) = x <=## y
-    (D# x) >= (D# y) = x >=## y
-    (D# x) >  (D# y) = x >##  y
-
-instance Ord Int where
-    compare = compareInt
-    (<)     = ltInt
-    (<=)    = leInt
-    (>=)    = geInt
-    (>)     = gtInt
-
-{-# INLINE gtInt #-}
-{-# INLINE geInt #-}
-{-# INLINE ltInt #-}
-{-# INLINE leInt #-}
-gtInt, geInt, ltInt, leInt :: Int -> Int -> Bool
-(I# x) `gtInt` (I# y) = x >#  y
-(I# x) `geInt` (I# y) = x >=# y
-(I# x) `ltInt` (I# y) = x <#  y
-(I# x) `leInt` (I# y) = x <=# y
-
-compareInt :: Int -> Int -> Ordering
-(I# x#) `compareInt` (I# y#) = compareInt# x# y#
-
-compareInt# :: Int# -> Int# -> Ordering
-compareInt# x# y#
-    | x# <#  y# = LT
-    | x# ==# y# = EQ
-    | True      = GT
-
--- OK, so they're technically not part of a class...:
-
--- Boolean functions
-
--- | Boolean \"and\"
-(&&)                    :: Bool -> Bool -> Bool
-True  && x              =  x
-False && _              =  False
-
--- | Boolean \"or\"
-(||)                    :: Bool -> Bool -> Bool
-True  || _              =  True
-False || x              =  x
-
--- | Boolean \"not\"
-not                     :: Bool -> Bool
-not True                =  False
-not False               =  True
-
-
-------------------------------------------------------------------------
--- Generic deriving
-------------------------------------------------------------------------
-
--- We need instances for some basic datatypes, but some of those use Int,
--- so we have to put the instances here
-deriving instance Eq Arity
-deriving instance Eq Associativity
-deriving instance Eq Fixity
-
-deriving instance Ord Arity
-deriving instance Ord Associativity
-deriving instance Ord Fixity
index de96b2c..a6ee11a 100644 (file)
@@ -1,4 +1,5 @@
 \begin{code}
+{-# LANGUAGE Unsafe #-}
 {-# LANGUAGE CPP, NoImplicitPrelude #-}
 {-# OPTIONS_GHC -fno-warn-missing-signatures #-}
 {-# OPTIONS_HADDOCK not-home #-}
@@ -38,6 +39,8 @@ module GHC.Conc
         , forkOnWithUnmask
         , numCapabilities -- :: Int
         , getNumCapabilities -- :: IO Int
+        , setNumCapabilities -- :: Int -> IO ()
+        , getNumProcessors   -- :: IO Int
         , numSparks       -- :: IO Int
         , childHandler  -- :: Exception -> IO ()
         , myThreadId    -- :: IO ThreadId
index 83a8a1c..64a479e 100644 (file)
@@ -1,3 +1,4 @@
+{-# LANGUAGE Trustworthy #-}
 {-# LANGUAGE CPP
            , NoImplicitPrelude
            , MagicHash
index f16ee3f..aa0ae07 100644 (file)
@@ -1,4 +1,5 @@
 \begin{code}
+{-# LANGUAGE Unsafe #-}
 {-# LANGUAGE CPP
            , NoImplicitPrelude
            , BangPatterns
@@ -48,6 +49,8 @@ module GHC.Conc.Sync
         , forkOnWithUnmask
         , numCapabilities -- :: Int
         , getNumCapabilities -- :: IO Int
+        , setNumCapabilities -- :: Int -> IO ()
+        , getNumProcessors   -- :: IO Int
         , numSparks      -- :: IO Int
         , childHandler  -- :: Exception -> IO ()
         , myThreadId    -- :: IO ThreadId
@@ -186,13 +189,13 @@ thread.
 The new thread will be a lightweight thread; if you want to use a foreign
 library that uses thread-local storage, use 'Control.Concurrent.forkOS' instead.
 
-GHC note: the new thread inherits the /masked/ state of the parent 
+GHC note: the new thread inherits the /masked/ state of the parent
 (see 'Control.Exception.mask').
 
 The newly created thread has an exception handler that discards the
 exceptions 'BlockedIndefinitelyOnMVar', 'BlockedIndefinitelyOnSTM', and
 'ThreadKilled', and passes all other exceptions to the uncaught
-exception handler (see 'setUncaughtExceptionHandler').
+exception handler.
 -}
 forkIO :: IO () -> IO ThreadId
 forkIO action = IO $ \ s ->
@@ -269,7 +272,7 @@ forkOnWithUnmask cpu io = forkOn cpu (io unsafeUnmask)
 -- Haskell threads that can run truly simultaneously at any given
 -- time, and is typically set to the number of physical processor cores on
 -- the machine.
--- 
+--
 -- Strictly speaking it is better to use 'getNumCapabilities', because
 -- the number of capabilities might vary at runtime.
 --
@@ -278,27 +281,38 @@ numCapabilities = unsafePerformIO $ getNumCapabilities
 
 {- |
 Returns the number of Haskell threads that can run truly
-simultaneously (on separate physical processors) at any given time.
-The number passed to `forkOn` is interpreted modulo this
-value.
-
-An implementation in which Haskell threads are mapped directly to
-OS threads might return the number of physical processor cores in
-the machine, and 'forkOn' would be implemented using the OS's
-affinity facilities.  An implementation that schedules Haskell
-threads onto a smaller number of OS threads (like GHC) would return
-the number of such OS threads that can be running simultaneously.
-
-GHC notes: this returns the number passed as the argument to the
-@+RTS -N@ flag.  In current implementations, the value is fixed
-when the program starts and never changes, but it is possible that
-in the future the number of capabilities might vary at runtime.
+simultaneously (on separate physical processors) at any given time.  To change
+this value, use 'setNumCapabilities'.
 -}
 getNumCapabilities :: IO Int
 getNumCapabilities = do
    n <- peek n_capabilities
    return (fromIntegral n)
 
+{- |
+Set the number of Haskell threads that can run truly simultaneously
+(on separate physical processors) at any given time.  The number
+passed to `forkOn` is interpreted modulo this value.  The initial
+value is given by the @+RTS -N@ runtime flag.
+
+This is also the number of threads that will participate in parallel
+garbage collection.  It is strongly recommended that the number of
+capabilities is not set larger than the number of physical processor
+cores, and it may often be beneficial to leave one or more cores free
+to avoid contention with other processes in the machine.
+-}
+setNumCapabilities :: Int -> IO ()
+setNumCapabilities i = c_setNumCapabilities (fromIntegral i)
+
+foreign import ccall safe "setNumCapabilities"
+  c_setNumCapabilities :: CUInt -> IO ()
+
+getNumProcessors :: IO Int
+getNumProcessors = fmap fromIntegral c_getNumberOfProcessors
+
+foreign import ccall unsafe "getNumberOfProcessors"
+  c_getNumberOfProcessors :: IO CUInt
+
 -- | Returns the number of sparks currently in the local spark pool
 numSparks :: IO Int
 numSparks = IO $ \s -> case numSparks# s of (# s', n #) -> (# s', I# n #)
@@ -654,7 +668,7 @@ alwaysSucceeds i = do ( i >> retry ) `orElse` ( return () )
 -- False or raising an exception are both treated as invariant failures.
 always :: STM Bool -> STM ()
 always i = alwaysSucceeds ( do v <- i
-                               if (v) then return () else ( error "Transacional invariant violation" ) )
+                               if (v) then return () else ( error "Transactional invariant violation" ) )
 
 -- |Shared memory locations that support atomic memory transactions.
 data TVar a = TVar (TVar# RealWorld a)
index fecbb20..6ea147c 100644 (file)
@@ -1,3 +1,4 @@
+{-# LANGUAGE Trustworthy #-}
 {-# LANGUAGE NoImplicitPrelude, MagicHash, UnboxedTuples, ForeignFunctionInterface,
              DeriveDataTypeable #-}
 {-# OPTIONS_GHC -fno-warn-missing-signatures #-}
@@ -277,7 +278,7 @@ start_console_handler r =
                     return ()
      Nothing -> return ()
 
-toWin32ConsoleEvent :: Num a => a -> Maybe ConsoleEvent
+toWin32ConsoleEvent :: (Eq a, Num a) => a -> Maybe ConsoleEvent
 toWin32ConsoleEvent ev =
    case ev of
        0 {- CTRL_C_EVENT-}        -> Just ControlC
@@ -323,3 +324,4 @@ foreign import ccall unsafe "sendIOManagerEvent" -- in the RTS (ThrIOManager.c)
 
 foreign import stdcall "WaitForSingleObject"
    c_WaitForSingleObject :: HANDLE -> DWORD -> IO DWORD
+
index a72b2b2..95810d6 100644 (file)
@@ -29,6 +29,13 @@ module GHC.ConsoleHandler
 
 {-
 #include "rts/Signals.h"
+
+Note: this #include is inside a Haskell comment
+      but it brings into scope some #defines
+      that are used by CPP below (eg STG_SIG_DFL).
+      Having it in a comment means that there's no
+      danger that C-like crap will be misunderstood
+      by GHC
 -}
 
 import Foreign
@@ -41,11 +48,6 @@ import GHC.Conc
 import Control.Concurrent.MVar
 import Data.Typeable
 
-#ifdef mingw32_HOST_OS
-import Data.Maybe
-import GHC.Base
-#endif
-
 data Handler
  = Default
  | Ignore
index 99abba5..ca63184 100644 (file)
@@ -9,3 +9,4 @@ import Prelude
 #include "../../../compiler/stage1/ghc_boot_platform.h"
 
 #include "../../../includes/HaskellConstants.hs"
+
index 3d1d740..6a5562f 100644 (file)
@@ -41,3 +41,4 @@ data AnnotationWrapper = forall a. (Data a) => AnnotationWrapper a
 
 toAnnotationWrapper :: (Data a) => a -> AnnotationWrapper
 toAnnotationWrapper what = AnnotationWrapper what
+
index abcc624..b3491f2 100644 (file)
@@ -2,6 +2,7 @@
 {-# LANGUAGE Trustworthy #-}
 {-# LANGUAGE NoImplicitPrelude, BangPatterns, MagicHash #-}
 {-# OPTIONS_HADDOCK hide #-}
+
 -----------------------------------------------------------------------------
 -- |
 -- Module      :  GHC.Enum
 module GHC.Enum(
         Bounded(..), Enum(..),
         boundedEnumFrom, boundedEnumFromThen,
+        toEnumError, fromEnumError, succError, predError,
 
         -- Instances for Bounded and Enum: (), Char, Int
 
    ) where
 
 import GHC.Base
+import GHC.Integer
+import GHC.Num
+import GHC.Show
 import Data.Tuple       ()              -- for dependencies
 default ()              -- Double isn't available yet
 \end{code}
@@ -121,6 +126,38 @@ boundedEnumFromThen n1 n2
     i_n2 = fromEnum n2
 \end{code}
 
+\begin{code}
+------------------------------------------------------------------------
+-- Helper functions
+------------------------------------------------------------------------
+
+{-# NOINLINE toEnumError #-}
+toEnumError :: (Show a) => String -> Int -> (a,a) -> b
+toEnumError inst_ty i bnds =
+    error $ "Enum.toEnum{" ++ inst_ty ++ "}: tag (" ++
+            show i ++
+            ") is outside of bounds " ++
+            show bnds
+
+{-# NOINLINE fromEnumError #-}
+fromEnumError :: (Show a) => String -> a -> b
+fromEnumError inst_ty x =
+    error $ "Enum.fromEnum{" ++ inst_ty ++ "}: value (" ++
+            show x ++
+            ") is outside of Int's bounds " ++
+            show (minBound::Int, maxBound::Int)
+
+{-# NOINLINE succError #-}
+succError :: String -> a
+succError inst_ty =
+    error $ "Enum.succ{" ++ inst_ty ++ "}: tried to take `succ' of maxBound"
+
+{-# NOINLINE predError #-}
+predError :: String -> a
+predError inst_ty =
+    error $ "Enum.pred{" ++ inst_ty ++ "}: tried to take `pred' of minBound"
+\end{code}
+
 
 %*********************************************************
 %*                                                      *
@@ -585,3 +622,78 @@ efdtIntDnFB c n x1 x2 y    -- Be careful about underflow!
                in I# x1 `c` go_dn x2
 \end{code}
 
+
+%*********************************************************
+%*                                                      *
+\subsection{The @Integer@ instance for @Enum@}
+%*                                                      *
+%*********************************************************
+
+\begin{code}
+instance  Enum Integer  where
+    succ x               = x + 1
+    pred x               = x - 1
+    toEnum (I# n)        = smallInteger n
+    fromEnum n           = I# (integerToInt n)
+
+    {-# INLINE enumFrom #-}
+    {-# INLINE enumFromThen #-}
+    {-# INLINE enumFromTo #-}
+    {-# INLINE enumFromThenTo #-}
+    enumFrom x             = enumDeltaInteger  x 1
+    enumFromThen x y       = enumDeltaInteger  x (y-x)
+    enumFromTo x lim       = enumDeltaToInteger x 1     lim
+    enumFromThenTo x y lim = enumDeltaToInteger x (y-x) lim
+
+{-# RULES
+"enumDeltaInteger"      [~1] forall x y.  enumDeltaInteger x y     = build (\c _ -> enumDeltaIntegerFB c x y)
+"efdtInteger"           [~1] forall x y l.enumDeltaToInteger x y l = build (\c n -> enumDeltaToIntegerFB c n x y l)
+"enumDeltaInteger"      [1] enumDeltaIntegerFB   (:)    = enumDeltaInteger
+"enumDeltaToInteger"    [1] enumDeltaToIntegerFB (:) [] = enumDeltaToInteger
+ #-}
+
+enumDeltaIntegerFB :: (Integer -> b -> b) -> Integer -> Integer -> b
+enumDeltaIntegerFB c x d = x `seq` (x `c` enumDeltaIntegerFB c (x+d) d)
+
+enumDeltaInteger :: Integer -> Integer -> [Integer]
+enumDeltaInteger x d = x `seq` (x : enumDeltaInteger (x+d) d)
+-- strict accumulator, so
+--     head (drop 1000000 [1 .. ]
+-- works
+
+{-# NOINLINE [0] enumDeltaToIntegerFB #-}
+-- Don't inline this until RULE "enumDeltaToInteger" has had a chance to fire
+enumDeltaToIntegerFB :: (Integer -> a -> a) -> a
+                     -> Integer -> Integer -> Integer -> a
+enumDeltaToIntegerFB c n x delta lim
+  | delta >= 0 = up_fb c n x delta lim
+  | otherwise  = dn_fb c n x delta lim
+
+enumDeltaToInteger :: Integer -> Integer -> Integer -> [Integer]
+enumDeltaToInteger x delta lim
+  | delta >= 0 = up_list x delta lim
+  | otherwise  = dn_list x delta lim
+
+up_fb :: (Integer -> a -> a) -> a -> Integer -> Integer -> Integer -> a
+up_fb c n x0 delta lim = go (x0 :: Integer)
+                      where
+                        go x | x > lim   = n
+                             | otherwise = x `c` go (x+delta)
+dn_fb :: (Integer -> a -> a) -> a -> Integer -> Integer -> Integer -> a
+dn_fb c n x0 delta lim = go (x0 :: Integer)
+                      where
+                        go x | x < lim   = n
+                             | otherwise = x `c` go (x+delta)
+
+up_list :: Integer -> Integer -> Integer -> [Integer]
+up_list x0 delta lim = go (x0 :: Integer)
+                    where
+                        go x | x > lim   = []
+                             | otherwise = x : go (x+delta)
+dn_list :: Integer -> Integer -> Integer -> [Integer]
+dn_list x0 delta lim = go (x0 :: Integer)
+                    where
+                        go x | x < lim   = []
+                             | otherwise = x : go (x+delta)
+\end{code}
+
index 57c0a90..3f15161 100644 (file)
@@ -45,7 +45,8 @@ getFullArgs =
    getFullProgArgv p_argc p_argv
    p    <- fromIntegral `liftM` peek p_argc
    argv <- peek p_argv
-   peekArray (p - 1) (advancePtr argv 1) >>= mapM (GHC.peekCString fileSystemEncoding)
+   enc <- getFileSystemEncoding
+   peekArray (p - 1) (advancePtr argv 1) >>= mapM (GHC.peekCString enc)
 
 foreign import ccall unsafe "getFullProgArgv"
     getFullProgArgv :: Ptr CInt -> Ptr (Ptr CString) -> IO ()
index 850e036..fd421dd 100644 (file)
@@ -1,8 +1,13 @@
 {-# LANGUAGE Trustworthy #-}
+
+-- ----------------------------------------------------------------------------
 -- | This module provides scalable event notification for file
 -- descriptors and timeouts.
 --
 -- This module should be considered GHC internal.
+--
+-- ----------------------------------------------------------------------------
+
 module GHC.Event
     ( -- * Types
       EventManager
@@ -40,3 +45,4 @@ module GHC.Event
 
 import GHC.Event.Manager
 import GHC.Event.Thread (getSystemEventManager)
+
index 464bbf4..5b811ef 100644 (file)
@@ -1,3 +1,4 @@
+{-# LANGUAGE Trustworthy #-}
 {-# LANGUAGE BangPatterns, CPP, ForeignFunctionInterface, NoImplicitPrelude #-}
 
 module GHC.Event.Array
@@ -27,7 +28,7 @@ import Control.Monad hiding (forM_)
 import Data.Bits ((.|.), shiftR)
 import Data.IORef (IORef, atomicModifyIORef, newIORef, readIORef, writeIORef)
 import Data.Maybe
-import Foreign.C.Types (CSize)
+import Foreign.C.Types (CSize(..))
 import Foreign.ForeignPtr (ForeignPtr, withForeignPtr)
 import Foreign.Ptr (Ptr, nullPtr, plusPtr)
 import Foreign.Storable (Storable(..))
@@ -311,3 +312,4 @@ foreign import ccall unsafe "string.h memcpy"
 
 foreign import ccall unsafe "string.h memmove"
     memmove :: Ptr a -> Ptr a -> CSize -> IO (Ptr a)
+
index 998794b..4a538f4 100644 (file)
@@ -1,4 +1,5 @@
-{-# LANGUAGE NoImplicitPrelude, BangPatterns, ForeignFunctionInterface #-}
+{-# LANGUAGE Trustworthy #-}
+{-# LANGUAGE NoImplicitPrelude, BangPatterns, ForeignFunctionInterface, CApiFFI #-}
 
 module GHC.Event.Clock (getCurrentTime) where
 
@@ -6,7 +7,7 @@ module GHC.Event.Clock (getCurrentTime) where
 
 import Foreign (Ptr, Storable(..), nullPtr, with)
 import Foreign.C.Error (throwErrnoIfMinus1_)
-import Foreign.C.Types (CInt, CLong, CTime, CSUSeconds)
+import Foreign.C.Types
 import GHC.Base
 import GHC.Err
 import GHC.Num
@@ -44,5 +45,6 @@ instance Storable CTimeval where
         #{poke struct timeval, tv_sec} ptr (sec tv)
         #{poke struct timeval, tv_usec} ptr (usec tv)
 
-foreign import ccall unsafe "sys/time.h gettimeofday" gettimeofday
+foreign import capi unsafe "HsBase.h gettimeofday" gettimeofday
     :: Ptr CTimeval -> Ptr () -> IO CInt
+
index bd58ae2..ab0636b 100644 (file)
@@ -1,3 +1,4 @@
+{-# LANGUAGE Unsafe #-}
 {-# LANGUAGE CPP
            , ForeignFunctionInterface
            , NoImplicitPrelude
@@ -35,7 +36,7 @@ import GHC.Real (fromIntegral)
 import GHC.Show (Show)
 import GHC.Word (Word8)
 import Foreign.C.Error (throwErrnoIfMinus1_)
-import Foreign.C.Types (CInt, CSize)
+import Foreign.C.Types (CInt(..), CSize(..))
 import Foreign.ForeignPtr (mallocForeignPtrBytes, withForeignPtr)
 import Foreign.Marshal (alloca, allocaBytes)
 import Foreign.Marshal.Array (allocaArray)
@@ -212,3 +213,4 @@ foreign import ccall "setIOManagerControlFd"
 
 foreign import ccall "setIOManagerWakeupFd"
    c_setIOManagerWakeupFd :: CInt -> IO ()
+
index 1cfd202..dafb68f 100644 (file)
@@ -1,3 +1,4 @@
+{-# LANGUAGE Trustworthy #-}
 {-# LANGUAGE CPP
            , ForeignFunctionInterface
            , GeneralizedNewtypeDeriving
@@ -5,8 +6,9 @@
            , BangPatterns
   #-}
 
---
--- | A binding to the epoll I/O event notification facility
+-----------------------------------------------------------------------------
+-- |
+-- A binding to the epoll I/O event notification facility
 --
 -- epoll is a variant of poll that can be used either as an edge-triggered or
 -- a level-triggered interface and scales well to large numbers of watched file
@@ -14,6 +16,8 @@
 --
 -- epoll decouples monitor an fd from the process of registering it.
 --
+-----------------------------------------------------------------------------
+
 module GHC.Event.EPoll
     (
       new
@@ -41,7 +45,7 @@ import Data.Bits (Bits, (.|.), (.&.))
 import Data.Monoid (Monoid(..))
 import Data.Word (Word32)
 import Foreign.C.Error (throwErrnoIfMinus1, throwErrnoIfMinus1_)
-import Foreign.C.Types (CInt)
+import Foreign.C.Types (CInt(..))
 import Foreign.Marshal.Utils (with)
 import Foreign.Ptr (Ptr)
 import Foreign.Storable (Storable(..))
@@ -204,3 +208,4 @@ foreign import ccall safe "sys/epoll.h epoll_wait"
     c_epoll_wait :: CInt -> Ptr Event -> CInt -> CInt -> IO CInt
 
 #endif /* defined(HAVE_EPOLL) */
+
index e324026..eee0cc5 100644 (file)
@@ -1,3 +1,4 @@
+{-# LANGUAGE Trustworthy #-}
 {-# LANGUAGE CPP, MagicHash, NoImplicitPrelude #-}
 
 -----------------------------------------------------------------------------
@@ -38,6 +39,7 @@
 -- This means that the operation can become linear in the number of
 -- elements with a maximum of /W/ -- the number of bits in an 'Int'
 -- (32 or 64).
+--
 -----------------------------------------------------------------------------
 
 module GHC.Event.IntMap
@@ -373,3 +375,4 @@ highestBitMask x0
         x4 -> case (x4 .|. shiftRL x4 16) of
          x5 -> case (x5 .|. shiftRL x5 32) of   -- for 64 bit platforms
           x6 -> (x6 `xor` (shiftRL x6 1))
+
index b5d7c0f..e529e83 100644 (file)
@@ -1,3 +1,4 @@
+{-# LANGUAGE Unsafe #-}
 {-# LANGUAGE ExistentialQuantification, NoImplicitPrelude #-}
 
 module GHC.Event.Internal
@@ -129,7 +130,7 @@ delete (Backend bState _ _ bDelete) = bDelete bState
 -- 'getErrno' is not 'eINTR'.  If the result value is -1 and
 -- 'getErrno' returns 'eINTR' 0 is returned.  Otherwise the result
 -- value is returned.
-throwErrnoIfMinus1NoRetry :: Num a => String -> IO a -> IO a
+throwErrnoIfMinus1NoRetry :: (Eq a, Num a) => String -> IO a -> IO a
 throwErrnoIfMinus1NoRetry loc f = do
     res <- f
     if res == -1
index 19c7adf..68aade3 100644 (file)
@@ -1,3 +1,4 @@
+{-# LANGUAGE Trustworthy #-}
 {-# LANGUAGE CPP
            , ForeignFunctionInterface
            , GeneralizedNewtypeDeriving
@@ -31,7 +32,7 @@ import Control.Monad (when, unless)
 import Data.Bits (Bits(..))
 import Data.Word (Word16, Word32)
 import Foreign.C.Error (throwErrnoIfMinus1)
-import Foreign.C.Types (CInt, CLong, CTime)
+import Foreign.C.Types
 import Foreign.Marshal.Alloc (alloca)
 import Foreign.Ptr (Ptr, nullPtr)
 import Foreign.Storable (Storable(..))
@@ -49,9 +50,6 @@ import qualified GHC.Event.Array as A
 #if defined(HAVE_KEVENT64)
 import Data.Int (Int64)
 import Data.Word (Word64)
-import Foreign.C.Types (CUInt)
-#else
-import Foreign.C.Types (CIntPtr, CUIntPtr)
 #endif
 
 #include <sys/types.h>
@@ -301,3 +299,4 @@ foreign import ccall safe "kevent"
 #endif
 
 #endif /* defined(HAVE_KQUEUE) */
+
index 055d0c7..089532c 100644 (file)
@@ -1,3 +1,4 @@
+{-# LANGUAGE Trustworthy #-}
 {-# LANGUAGE BangPatterns
            , CPP
            , ExistentialQuantification
index 8c285bf..853958b 100644 (file)
@@ -1,3 +1,4 @@
+{-# LANGUAGE Trustworthy #-}
 {-# LANGUAGE BangPatterns, NoImplicitPrelude #-}
 
 -- Copyright (c) 2008, Ralf Hinze
@@ -481,3 +482,4 @@ seqToList (Sequ x) = x []
 
 instance Show a => Show (Sequ a) where
     showsPrec d a = showsPrec d (seqToList a)
+
index e34b47e..e62296b 100644 (file)
@@ -1,3 +1,4 @@
+{-# LANGUAGE Trustworthy #-}
 {-# LANGUAGE CPP
            , ForeignFunctionInterface
            , GeneralizedNewtypeDeriving
@@ -30,7 +31,7 @@ import Control.Monad ((=<<), liftM, liftM2, unless)
 import Data.Bits (Bits, (.|.), (.&.))
 import Data.Maybe (Maybe(..))
 import Data.Monoid (Monoid(..))
-import Foreign.C.Types (CInt, CShort, CULong)
+import Foreign.C.Types (CInt(..), CShort(..), CULong(..))
 import Foreign.Ptr (Ptr)
 import Foreign.Storable (Storable(..))
 import GHC.Base
index 42bf541..2643950 100644 (file)
@@ -1,3 +1,4 @@
+{-# LANGUAGE Trustworthy #-}
 {-# LANGUAGE BangPatterns, ForeignFunctionInterface, NoImplicitPrelude #-}
 
 module GHC.Event.Thread
index 66b799c..9137450 100644 (file)
@@ -1,3 +1,4 @@
+{-# LANGUAGE Trustworthy #-}
 {-# LANGUAGE BangPatterns, GeneralizedNewtypeDeriving, NoImplicitPrelude #-}
 module GHC.Event.Unique
     (
@@ -38,3 +39,4 @@ newUnique (US ref) = atomically $ do
   writeTVar ref u'
   return $ Unique u'
 {-# INLINE newUnique #-}
+
index ec4f893..74f8fea 100644 (file)
@@ -6,6 +6,7 @@
            , DeriveDataTypeable
   #-}
 {-# OPTIONS_HADDOCK hide #-}
+
 -----------------------------------------------------------------------------
 -- |
 -- Module      :  GHC.Exception
@@ -25,6 +26,7 @@ module GHC.Exception where
 
 import Data.Maybe
 import {-# SOURCE #-} Data.Typeable (Typeable, cast)
+   -- loop: Data.Typeable -> GHC.Err -> GHC.Exception
 import GHC.Base
 import GHC.Show
 \end{code}
@@ -62,7 +64,7 @@ in this case. You can now throw and catch @ThisException@ and
 @ThatException@ as exceptions:
 
 @
-*Main> throw ThisException `catch` \e -> putStrLn (\"Caught \" ++ show (e :: MyException))
+*Main> throw ThisException \`catch\` \\e -> putStrLn (\"Caught \" ++ show (e :: MyException))
 Caught ThisException
 @
 
old mode 100644 (file)
new mode 100755 (executable)
index 67b4a97..0bf8f7f
@@ -1,3 +1,4 @@
+{-# LANGUAGE Unsafe #-}
 {-# LANGUAGE MagicHash, UnboxedTuples, DeriveDataTypeable #-}
 
 -----------------------------------------------------------------------------
@@ -49,8 +50,13 @@ module GHC.Exts
         traceEvent,
 
         -- * SpecConstr annotations
-        SpecConstrAnnotation(..)
+        SpecConstrAnnotation(..),
 
+        -- * The call stack
+        currentCallStack,
+
+        -- * The Constraint kind
+        Constraint
        ) where
 
 import Prelude
@@ -61,10 +67,11 @@ import GHC.Magic
 import GHC.Word
 import GHC.Int
 import GHC.Ptr
+import GHC.Stack
 import Data.String
 import Data.List
-import Foreign.C
 import Data.Data
+import qualified Debug.Trace
 
 -- XXX This should really be in Data.Tuple, where the definitions are
 maxTupleSize :: Int
@@ -112,10 +119,8 @@ groupByFB c n eq xs0 = groupByFBCore xs0
 -- tracing
 
 traceEvent :: String -> IO ()
-traceEvent msg = do
-  withCString msg $ \(Ptr p) -> IO $ \s ->
-    case traceEvent# p s of s' -> (# s', () #)
-
+traceEvent = Debug.Trace.traceEventIO
+{-# DEPRECATED traceEvent "Use Debug.Trace.traceEvent or Debug.Trace.traceEventIO" #-}
 
 
 {- **********************************************************************
diff --git a/GHC/Fingerprint.hs b/GHC/Fingerprint.hs
new file mode 100644 (file)
index 0000000..d1b3831
--- /dev/null
@@ -0,0 +1,78 @@
+{-# LANGUAGE Trustworthy #-}
+{-# LANGUAGE NoImplicitPrelude
+           , BangPatterns
+           , ForeignFunctionInterface
+           , EmptyDataDecls
+  #-}
+
+-- ----------------------------------------------------------------------------
+-- 
+--  (c) The University of Glasgow 2006
+--
+-- Fingerprints for recompilation checking and ABI versioning, and
+-- implementing fast comparison of Typeable.
+--
+-- ----------------------------------------------------------------------------
+
+module GHC.Fingerprint (
+        Fingerprint(..), fingerprint0, 
+        fingerprintData,
+        fingerprintString,
+        fingerprintFingerprints
+   ) where
+
+import GHC.IO
+import GHC.Base
+import GHC.Num
+import GHC.List
+import GHC.Real
+import Foreign
+import Foreign.C
+
+import GHC.Fingerprint.Type
+
+-- for SIZEOF_STRUCT_MD5CONTEXT:
+#include "HsBaseConfig.h"
+
+-- XXX instance Storable Fingerprint
+-- defined in Foreign.Storable to avoid orphan instance
+
+fingerprint0 :: Fingerprint
+fingerprint0 = Fingerprint 0 0
+
+fingerprintFingerprints :: [Fingerprint] -> Fingerprint
+fingerprintFingerprints fs = unsafeDupablePerformIO $
+  withArrayLen fs $ \len p -> do
+    fingerprintData (castPtr p) (len * sizeOf (head fs))
+
+fingerprintData :: Ptr Word8 -> Int -> IO Fingerprint
+fingerprintData buf len = do
+  allocaBytes SIZEOF_STRUCT_MD5CONTEXT $ \pctxt -> do
+    c_MD5Init pctxt
+    c_MD5Update pctxt buf (fromIntegral len)
+    allocaBytes 16 $ \pdigest -> do
+      c_MD5Final pdigest pctxt
+      peek (castPtr pdigest :: Ptr Fingerprint)
+
+-- This is duplicated in compiler/utils/Fingerprint.hsc
+fingerprintString :: String -> Fingerprint
+fingerprintString str = unsafeDupablePerformIO $
+  withArrayLen word8s $ \len p ->
+     fingerprintData p len
+    where word8s = concatMap f str
+          f c = let w32 :: Word32
+                    w32 = fromIntegral (ord c)
+                in [fromIntegral (w32 `shiftR` 24),
+                    fromIntegral (w32 `shiftR` 16),
+                    fromIntegral (w32 `shiftR` 8),
+                    fromIntegral w32]
+
+data MD5Context
+
+foreign import ccall unsafe "MD5Init"
+   c_MD5Init   :: Ptr MD5Context -> IO ()
+foreign import ccall unsafe "MD5Update"
+   c_MD5Update :: Ptr MD5Context -> Ptr Word8 -> CInt -> IO ()
+foreign import ccall unsafe "MD5Final"
+   c_MD5Final  :: Ptr Word8 -> Ptr MD5Context -> IO ()
+
diff --git a/GHC/Fingerprint.hs-boot b/GHC/Fingerprint.hs-boot
new file mode 100644 (file)
index 0000000..36833b8
--- /dev/null
@@ -0,0 +1,13 @@
+{-# LANGUAGE Unsafe #-}
+{-# LANGUAGE NoImplicitPrelude #-}
+module GHC.Fingerprint (
+        fingerprintString,
+        fingerprintFingerprints
+  ) where
+
+import GHC.Base
+import GHC.Fingerprint.Type
+
+fingerprintFingerprints :: [Fingerprint] -> Fingerprint
+fingerprintString :: String -> Fingerprint
+
diff --git a/GHC/Fingerprint/Type.hs b/GHC/Fingerprint/Type.hs
new file mode 100644 (file)
index 0000000..91d7250
--- /dev/null
@@ -0,0 +1,21 @@
+{-# LANGUAGE Trustworthy #-}
+{-# LANGUAGE NoImplicitPrelude #-}
+-- ----------------------------------------------------------------------------
+-- 
+--  (c) The University of Glasgow 2006
+--
+-- Fingerprints for recompilation checking and ABI versioning, and
+-- implementing fast comparison of Typeable.
+--
+-- ----------------------------------------------------------------------------
+
+module GHC.Fingerprint.Type (Fingerprint(..)) where
+
+import GHC.Base
+import GHC.Word
+
+-- Using 128-bit MD5 fingerprints for now.
+
+data Fingerprint = Fingerprint {-# UNPACK #-} !Word64 {-# UNPACK #-} !Word64
+  deriving (Eq, Ord)
+
index fa31751..68eed2c 100644 (file)
@@ -102,15 +102,33 @@ class  (RealFrac a, Floating a) => RealFloat a  where
     -- appropriately scaled exponent (an 'Int').  If @'decodeFloat' x@
     -- yields @(m,n)@, then @x@ is equal in value to @m*b^^n@, where @b@
     -- is the floating-point radix, and furthermore, either @m@ and @n@
-    -- are both zero or else @b^(d-1) <= m < b^d@, where @d@ is the value
-    -- of @'floatDigits' x@.  In particular, @'decodeFloat' 0 = (0,0)@.
+    -- are both zero or else @b^(d-1) <= 'abs' m < b^d@, where @d@ is
+    -- the value of @'floatDigits' x@.
+    -- In particular, @'decodeFloat' 0 = (0,0)@. If the type
+    -- contains a negative zero, also @'decodeFloat' (-0.0) = (0,0)@.
+    -- /The result of/ @'decodeFloat' x@ /is unspecified if either of/
+    -- @'isNaN' x@ /or/ @'isInfinite' x@ /is/ 'True'.
     decodeFloat         :: a -> (Integer,Int)
-    -- | 'encodeFloat' performs the inverse of 'decodeFloat'
+    -- | 'encodeFloat' performs the inverse of 'decodeFloat' in the
+    -- sense that for finite @x@ with the exception of @-0.0@,
+    -- @'uncurry' 'encodeFloat' ('decodeFloat' x) = x@.
+    -- @'encodeFloat' m n@ is one of the two closest representable
+    -- floating-point numbers to @m*b^^n@ (or @&#177;Infinity@ if overflow
+    -- occurs); usually the closer, but if @m@ contains too many bits,
+    -- the result may be rounded in the wrong direction.
     encodeFloat         :: Integer -> Int -> a
-    -- | the second component of 'decodeFloat'.
+    -- | 'exponent' corresponds to the second component of 'decodeFloat'.
+    -- @'exponent' 0 = 0@ and for finite nonzero @x@,
+    -- @'exponent' x = snd ('decodeFloat' x) + 'floatDigits' x@.
+    -- If @x@ is a finite floating-point number, it is equal in value to
+    -- @'significand' x * b ^^ 'exponent' x@, where @b@ is the
+    -- floating-point radix.
+    -- The behaviour is unspecified on infinite or @NaN@ values.
     exponent            :: a -> Int
-    -- | the first component of 'decodeFloat', scaled to lie in the open
-    -- interval (@-1@,@1@)
+    -- | The first component of 'decodeFloat', scaled to lie in the open
+    -- interval (@-1@,@1@), either @0.0@ or of absolute value @>= 1\/b@,
+    -- where @b@ is the floating-point radix.
+    -- The behaviour is unspecified on infinite or @NaN@ values.
     significand         :: a -> a
     -- | multiplies a floating-point number by an integer power of the radix
     scaleFloat          :: Int -> a -> a
@@ -143,7 +161,10 @@ class  (RealFrac a, Floating a) => RealFloat a  where
     significand x       =  encodeFloat m (negate (floatDigits x))
                            where (m,_) = decodeFloat x
 
-    scaleFloat k x      =  encodeFloat m (n + clamp b k)
+    scaleFloat 0 x      =  x
+    scaleFloat k x
+      | isFix           =  x
+      | otherwise       =  encodeFloat m (n + clamp b k)
                            where (m,n) = decodeFloat x
                                  (l,h) = floatRange x
                                  d     = floatDigits x
@@ -156,6 +177,7 @@ class  (RealFrac a, Floating a) => RealFloat a  where
                                  -- for smaller than l - d.
                                  -- Add a little extra to keep clear
                                  -- from the boundary cases.
+                                 isFix = x == 0 || isNaN x || isInfinite x
 
     atan2 y x
       | x > 0            =  atan (y/x)
@@ -313,9 +335,13 @@ instance  RealFloat Float  where
     significand x       = case decodeFloat x of
                             (m,_) -> encodeFloat m (negate (floatDigits x))
 
-    scaleFloat k x      = case decodeFloat x of
+    scaleFloat 0 x      = x
+    scaleFloat k x
+      | isFix           = x
+      | otherwise       = case decodeFloat x of
                             (m,n) -> encodeFloat m (n + clamp bf k)
                         where bf = FLT_MAX_EXP - (FLT_MIN_EXP) + 4*FLT_MANT_DIG
+                              isFix = x == 0 || isFloatFinite x == 0
 
     isNaN x          = 0 /= isFloatNaN x
     isInfinite x     = 0 /= isFloatInfinite x
@@ -354,12 +380,12 @@ instance  Real Double  where
     toRational (D# x#)  =
         case decodeDoubleInteger x# of
           (# m, e# #)
-            | e# >=# 0#                                         ->
+            | e# >=# 0#                                     ->
                 shiftLInteger m e# :% 1
-            | (int2Word# (toInt# m) `and#` 1##) `eqWord#` 0##   ->
+            | (integerToWord m `and#` 1##) `eqWord#` 0##    ->
                 case elimZerosInteger m (negateInt# e#) of
                     (# n, d# #) ->  n :% shiftLInteger 1 d#
-            | otherwise                                         ->
+            | otherwise                                     ->
                 m :% shiftLInteger 1 (negateInt# e#)
 
 instance  Fractional Double  where
@@ -464,9 +490,13 @@ instance  RealFloat Double  where
     significand x       = case decodeFloat x of
                             (m,_) -> encodeFloat m (negate (floatDigits x))
 
-    scaleFloat k x      = case decodeFloat x of
+    scaleFloat 0 x      = x
+    scaleFloat k x
+      | isFix           = x
+      | otherwise       = case decodeFloat x of
                             (m,n) -> encodeFloat m (n + clamp bd k)
                         where bd = DBL_MAX_EXP - (DBL_MIN_EXP) + 4*DBL_MANT_DIG
+                              isFix = x == 0 || isDoubleFinite x == 0
 
     isNaN x             = 0 /= isDoubleNaN x
     isInfinite x        = 0 /= isDoubleInfinite x
@@ -819,21 +849,17 @@ fromRat' x = r
         p = floatDigits r
         (minExp0, _) = floatRange r
         minExp = minExp0 - p            -- the real minimum exponent
-        xMin   = toRational (expt b (p-1))
         xMax   = toRational (expt b p)
         p0 = (integerLogBase b (numerator x) - integerLogBase b (denominator x) - p) `max` minExp
-        f = if p0 < 0 then 1 % expt b (-p0) else expt b p0 % 1
-        (x', p') = scaleRat (toRational b) minExp xMin xMax p0 (x / f)
+        -- if x = n/d and ln = integerLogBase b n, ld = integerLogBase b d,
+        -- then b^(ln-ld-1) < x < b^(ln-ld+1)
+        f = if p0 < 0 then 1 :% expt b (-p0) else expt b p0 :% 1
+        x0 = x / f
+        -- if ln - ld >= minExp0, then b^(p-1) < x0 < b^(p+1), so there's at most
+        -- one scaling step needed, otherwise, x0 < b^p and no scaling is needed
+        (x', p') = if x0 >= xMax then (x0 / toRational b, p0+1) else (x0, p0)
         r = encodeFloat (round x') p'
 
--- Scale x until xMin <= x < xMax, or p (the exponent) <= minExp.
-scaleRat :: Rational -> Int -> Rational -> Rational -> Int -> Rational -> (Rational, Int)
-scaleRat b minExp xMin xMax p x
- | p <= minExp = (x, p)
- | x >= xMax   = scaleRat b minExp xMin xMax (p+1) (x/b)
- | x < xMin    = scaleRat b minExp xMin xMax (p-1) (x*b)
- | otherwise   = (x, p)
-
 -- Exponentiation with a cache for the most common numbers.
 minExpt, maxExpt :: Int
 minExpt = 0
@@ -882,22 +908,24 @@ these brings a huge speedup since we need only shift and add instead
 of division.
 
 The below is an adaption of fromRat' for the conversion to
-Float or Double exploiting the know floatRadix and avoiding
+Float or Double exploiting the known floatRadix and avoiding
 divisions as much as possible.
 
 \begin{code}
 {-# SPECIALISE fromRat'' :: Int -> Int -> Integer -> Integer -> Float,
                             Int -> Int -> Integer -> Integer -> Double #-}
 fromRat'' :: RealFloat a => Int -> Int -> Integer -> Integer -> a
+-- Invariant: n and d strictly positive
 fromRat'' minEx@(I# me#) mantDigs@(I# md#) n d =
     case integerLog2IsPowerOf2# d of
       (# ld#, pw# #)
         | pw# ==# 0# ->
           case integerLog2# n of
-            ln# | ln# ># (ld# +# me#) ->
+            ln# | ln# >=# (ld# +# me# -# 1#) ->
+                  -- this means n/d >= 2^(minEx-1), i.e. we are guaranteed to get
+                  -- a normalised number, round to mantDigs bits
                   if ln# <# md#
-                    then encodeFloat (n `shiftL` (I# (md# -# 1# -# ln#)))
-                                        (I# (ln# +# 1# -# ld# -# md#))
+                    then encodeFloat n (I# (negateInt# ld#))
                     else let n'  = n `shiftR` (I# (ln# +# 1# -# md#))
                              n'' = case roundingMode# n (ln# -# md#) of
                                     0# -> n'
@@ -907,15 +935,13 @@ fromRat'' minEx@(I# me#) mantDigs@(I# md#) n d =
                                             _ -> n' + 1
                          in encodeFloat n'' (I# (ln# -# ld# +# 1# -# md#))
                 | otherwise ->
+                  -- n/d < 2^(minEx-1), a denorm or rounded to 2^(minEx-1)
+                  -- the exponent for encoding is always minEx-mantDigs
+                  -- so we must shift right by (minEx-mantDigs) - (-ld)
                   case ld# +# (me# -# md#) of
-                    ld'# | ld'# ># (ln# +# 1#)  -> encodeFloat 0 0
-                         | ld'# ==# (ln# +# 1#) ->
-                           case integerLog2IsPowerOf2# n of
-                            (# _, 0# #) -> encodeFloat 0 0
-                            (# _, _ #)  -> encodeFloat 1 (minEx - mantDigs)
-                         | ld'# <=# 0#  ->
+                    ld'# | ld'# <=# 0#  -> -- we would shift left, so we don't shift
                            encodeFloat n (I# ((me# -# md#) -# ld'#))
-                         | otherwise    ->
+                         | ld'# <=# ln#  ->
                            let n' = n `shiftR` (I# ld'#)
                            in case roundingMode# n (ld'# -# 1#) of
                                 0# -> encodeFloat n' (minEx - mantDigs)
@@ -923,20 +949,28 @@ fromRat'' minEx@(I# me#) mantDigs@(I# md#) n d =
                                         then encodeFloat n' (minEx-mantDigs)
                                         else encodeFloat (n' + 1) (minEx-mantDigs)
                                 _  -> encodeFloat (n' + 1) (minEx-mantDigs)
+                         | ld'# ># (ln# +# 1#)  -> encodeFloat 0 0 -- result of shift < 0.5
+                         | otherwise ->  -- first bit of n shifted to 0.5 place
+                           case integerLog2IsPowerOf2# n of
+                            (# _, 0# #) -> encodeFloat 0 0  -- round to even
+                            (# _, _ #)  -> encodeFloat 1 (minEx - mantDigs)
         | otherwise ->
           let ln = I# (integerLog2# n)
               ld = I# ld#
+              -- 2^(ln-ld-1) < n/d < 2^(ln-ld+1)
               p0 = max minEx (ln - ld)
               (n', d')
                 | p0 < mantDigs = (n `shiftL` (mantDigs - p0), d)
                 | p0 == mantDigs = (n, d)
                 | otherwise     = (n, d `shiftL` (p0 - mantDigs))
+              -- if ln-ld < minEx, then n'/d' < 2^mantDigs, else
+              -- 2^(mantDigs-1) < n'/d' < 2^(mantDigs+1) and we
+              -- may need one scaling step
               scale p a b
-                | p <= minEx-mantDigs = (p,a,b)
-                | a < (b `shiftL` (mantDigs-1)) = (p-1, a `shiftL` 1, b)
                 | (b `shiftL` mantDigs) <= a = (p+1, a, b `shiftL` 1)
                 | otherwise = (p, a, b)
               (p', n'', d'') = scale (p0-mantDigs) n' d'
+              -- n''/d'' < 2^mantDigs and p' == minEx-mantDigs or n''/d'' >= 2^(mantDigs-1)
               rdq = case n'' `quotRem` d'' of
                      (q,r) -> case compare (r `shiftL` 1) d'' of
                                 LT -> q
@@ -1046,12 +1080,13 @@ foreign import ccall unsafe "isFloatNaN" isFloatNaN :: Float -> Int
 foreign import ccall unsafe "isFloatInfinite" isFloatInfinite :: Float -> Int
 foreign import ccall unsafe "isFloatDenormalized" isFloatDenormalized :: Float -> Int
 foreign import ccall unsafe "isFloatNegativeZero" isFloatNegativeZero :: Float -> Int
-
+foreign import ccall unsafe "isFloatFinite" isFloatFinite :: Float -> Int
 
 foreign import ccall unsafe "isDoubleNaN" isDoubleNaN :: Double -> Int
 foreign import ccall unsafe "isDoubleInfinite" isDoubleInfinite :: Double -> Int
 foreign import ccall unsafe "isDoubleDenormalized" isDoubleDenormalized :: Double -> Int
 foreign import ccall unsafe "isDoubleNegativeZero" isDoubleNegativeZero :: Double -> Int
+foreign import ccall unsafe "isDoubleFinite" isDoubleFinite :: Double -> Int
 \end{code}
 
 %*********************************************************
index 1d849f1..ec2233c 100644 (file)
@@ -2,6 +2,7 @@
 {-# LANGUAGE CPP, MagicHash, UnboxedTuples, NoImplicitPrelude #-}
 {-# OPTIONS_GHC -O2 #-}
 {-# OPTIONS_HADDOCK hide #-}
+
 -----------------------------------------------------------------------------
 -- |
 -- Module      :  GHC.Float.ConversionUtils
@@ -46,7 +47,7 @@ elim64# n e =
 
 #else
 
-#define TO64    toInt#
+#define TO64    integerToInt
 
 -- Double mantissae fit it Int#
 elim64# :: Int# -> Int# -> (# Integer, Int# #)
@@ -95,3 +96,4 @@ zeroCountArr =
                                 (# _, ba #) -> ba
     in case mkArr realWorld# of
         b -> BA b
+
index 7967957..57ec1e8 100644 (file)
@@ -2,6 +2,7 @@
 {-# LANGUAGE CPP, MagicHash, UnboxedTuples, ForeignFunctionInterface,
     NoImplicitPrelude #-}
 {-# OPTIONS_HADDOCK hide #-}
+
 -----------------------------------------------------------------------------
 -- |
 -- Module      :  GHC.Float.RealFracMethods
@@ -71,7 +72,7 @@ import GHC.IntWord64
 
 #else
 
-#define TO64 toInt#
+#define TO64 integerToInt
 #define FROM64 smallInteger
 #define MINUS64 ( -# )
 #define NEGATE64 negateInt#
@@ -340,3 +341,4 @@ foreign import ccall unsafe "rintDouble"
 
 foreign import ccall unsafe "rintFloat"
     c_rintFloat :: Float -> Float
+
index 12d7888..4eef2eb 100644 (file)
@@ -3,7 +3,7 @@
 
 -----------------------------------------------------------------------------
 -- |
--- Module      :  GHC.IO.Encoding
+-- Module      :  GHC.Foreign
 -- Copyright   :  (c) The University of Glasgow, 2008-2011
 -- License     :  see libraries/base/LICENSE
 -- 
@@ -63,7 +63,6 @@ import GHC.Base
 import GHC.IO
 import GHC.IO.Exception
 import GHC.IO.Buffer
-import GHC.IO.Encoding.Failure (surrogatifyRoundtripCharacter, desurrogatifyRoundtripCharacter)
 import GHC.IO.Encoding.Types
 
 
@@ -173,7 +172,7 @@ peekEncodedCString (TextEncoding { mkTextDecoder = mk_decoder }) (p, sz_bytes)
             if isEmptyBuffer from'
              then
               -- No input remaining: @why@ will be InputUnderflow, but we don't care
-              fmap (map desurrogatifyRoundtripCharacter) $ withBuffer to' $ peekArray (bufferElems to')
+              withBuffer to' $ peekArray (bufferElems to')
              else do
               -- Input remaining: what went wrong?
               putDebugMsg ("peekEncodedCString: " ++ show iteration ++ " " ++ show why)
@@ -183,7 +182,7 @@ peekEncodedCString (TextEncoding { mkTextDecoder = mk_decoder }) (p, sz_bytes)
               putDebugMsg ("peekEncodedCString: from " ++ summaryBuffer from ++ " " ++ summaryBuffer from' ++ " " ++ summaryBuffer from'')
               putDebugMsg ("peekEncodedCString: to " ++ summaryBuffer to ++ " " ++ summaryBuffer to' ++ " " ++ summaryBuffer to'')
               to_chars <- withBuffer to'' $ peekArray (bufferElems to'')
-              fmap (map desurrogatifyRoundtripCharacter to_chars++) $ go (iteration + 1) from''
+              fmap (to_chars++) $ go (iteration + 1) from''
 
       go (0 :: Int) from0
 
@@ -194,7 +193,7 @@ withEncodedCString :: TextEncoding         -- ^ Encoding of CString to create
                    -> (CStringLen -> IO a) -- ^ Worker that can safely use the allocated memory
                    -> IO a
 withEncodedCString (TextEncoding { mkTextEncoder = mk_encoder }) null_terminate s act
-  = bracket mk_encoder close $ \encoder -> withArrayLen (map surrogatifyRoundtripCharacter s) $ \sz p -> do
+  = bracket mk_encoder close $ \encoder -> withArrayLen s $ \sz p -> do
       from <- fmap (\fp -> bufferAdd sz (emptyBuffer fp sz ReadBuffer)) $ newForeignPtr_ p
 
       let go iteration to_sz_bytes = do
@@ -214,7 +213,7 @@ newEncodedCString :: TextEncoding  -- ^ Encoding of CString to create
                   -> String        -- ^ String to encode
                   -> IO CStringLen
 newEncodedCString (TextEncoding { mkTextEncoder = mk_encoder }) null_terminate s
-  = bracket mk_encoder close $ \encoder -> withArrayLen (map surrogatifyRoundtripCharacter s) $ \sz p -> do
+  = bracket mk_encoder close $ \encoder -> withArrayLen s $ \sz p -> do
       from <- fmap (\fp -> bufferAdd sz (emptyBuffer fp sz ReadBuffer)) $ newForeignPtr_ p
 
       let go iteration to_p to_sz_bytes = do
@@ -255,3 +254,4 @@ tryFillBufferAndCall encoder null_terminate from0 to_p to_sz_bytes act = do
               InputUnderflow  -> recover encoder from' to' >>= go (iteration + 1) -- These conditions are equally bad
               InvalidSequence -> recover encoder from' to' >>= go (iteration + 1) -- since the input was truncated/invalid
               OutputUnderflow -> return Nothing -- Oops, out of buffer during decoding: ask the caller for more
+
index dbf6c2c..f55491b 100644 (file)
@@ -1,3 +1,4 @@
+{-# LANGUAGE Unsafe #-}
 {-# LANGUAGE CPP
            , NoImplicitPrelude
            , BangPatterns
index 8cc81f8..bb744a0 100644 (file)
@@ -1,5 +1,6 @@
 {-# LANGUAGE Trustworthy #-}
 {-# OPTIONS_HADDOCK hide #-}
+
 -----------------------------------------------------------------------------
 -- |
 -- Module      :  GHC.Handle
@@ -15,7 +16,6 @@
 -----------------------------------------------------------------------------
 
 -- #hide
-
 module GHC.Handle {-# DEPRECATED "use GHC.IO.Handle instead" #-} (
   withHandle, withHandle', withHandle_,
   wantWritableHandle, wantReadableHandle, wantSeekableHandle,
index 99dc093..f30f768 100644 (file)
--- a/GHC/IO.hs
+++ b/GHC/IO.hs
@@ -1,3 +1,4 @@
+{-# LANGUAGE Unsafe #-}
 {-# LANGUAGE NoImplicitPrelude
            , BangPatterns
            , RankNTypes
@@ -6,6 +7,7 @@
   #-}
 {-# OPTIONS_GHC -funbox-strict-fields #-}
 {-# OPTIONS_HADDOCK hide #-}
+
 -----------------------------------------------------------------------------
 -- |
 -- Module      :  GHC.IO
@@ -164,9 +166,9 @@ unsafePerformIO :: IO a -> a
 unsafePerformIO m = unsafeDupablePerformIO (noDuplicate >> m)
 
 {-| 
-This version of 'unsafePerformIO' is slightly more efficient,
+This version of 'unsafePerformIO' is more efficient
 because it omits the check that the IO is only being performed by a
-single thread.  Hence, when you write 'unsafeDupablePerformIO',
+single thread.  Hence, when you use 'unsafeDupablePerformIO',
 there is a possibility that the IO action may be performed multiple
 times (on a multiprocessor), and you should therefore ensure that
 it gives the same results each time.
@@ -381,7 +383,7 @@ onException io what = io `catchException` \e -> do _ <- what
 -- with exceptions masked, you can be sure that the library call will not be
 -- able to unmask exceptions again.  If you are writing library code and need
 -- to use asynchronous exceptions, the only way is to create a new thread;
--- see 'Control.Concurrent.forkIOUnmasked'.
+-- see 'Control.Concurrent.forkIOWithUnmask'.
 --
 -- Asynchronous exceptions may still be received while in the masked
 -- state if the masked thread /blocks/ in certain ways; see
@@ -469,4 +471,5 @@ a `finally` sequel =
 -- >   evaluate x = (return $! x) >>= return
 --
 evaluate :: a -> IO a
-evaluate a = IO $ \s -> let !va = a in (# s, va #) -- NB. see #2273
+evaluate a = IO $ \s -> seq# a s -- NB. see #2273, #5129
+
index 8bd5265..fb0dd96 100644 (file)
@@ -1,3 +1,4 @@
+{-# LANGUAGE Unsafe #-}
 {-# LANGUAGE NoImplicitPrelude #-}
 
 module GHC.IO where
@@ -5,3 +6,4 @@ module GHC.IO where
 import GHC.Types
 
 failIO :: [Char] -> IO a
+
index 456b1e1..8f677f0 100644 (file)
@@ -288,3 +288,4 @@ checkBuffer buf@Buffer{ bufState = state, bufL=r, bufR=w, bufSize=size } = do
 check :: Buffer a -> Bool -> IO ()
 check _   True  = return ()
 check buf False = error ("buffer invariant violation: " ++ summaryBuffer buf)
+
index 7690fc7..ef78d90 100644 (file)
@@ -124,3 +124,4 @@ writeBufNonBlocking dev bbuf = do
   res <- withBuffer bbuf $ \ptr ->
             IODevice.writeNonBlocking dev (ptr `plusPtr` bufL bbuf) bytes
   return (res, bufferAdjustL res bbuf)
+
index 903c041..f3f330b 100644 (file)
@@ -176,3 +176,4 @@ data SeekMode
   | SeekFromEnd         -- ^ the position of @hdl@ is set to offset @i@
                         -- from the end of the file.
     deriving (Eq, Ord, Ix, Enum, Read, Show)
+
index 6a97775..bd54182 100644 (file)
@@ -22,7 +22,9 @@ module GHC.IO.Encoding (
         utf8, utf8_bom,
         utf16, utf16le, utf16be,
         utf32, utf32le, utf32be, 
-        localeEncoding, fileSystemEncoding, foreignEncoding,
+        initLocaleEncoding,
+        getLocaleEncoding, getFileSystemEncoding, getForeignEncoding,
+        setLocaleEncoding, setFileSystemEncoding, setForeignEncoding,
         char8,
         mkTextEncoding,
     ) where
@@ -32,9 +34,8 @@ import GHC.IO.Exception
 import GHC.IO.Buffer
 import GHC.IO.Encoding.Failure
 import GHC.IO.Encoding.Types
-import GHC.Word
 #if !defined(mingw32_HOST_OS)
-import qualified GHC.IO.Encoding.Iconv  as Iconv
+import qualified GHC.IO.Encoding.Iconv as Iconv
 #else
 import qualified GHC.IO.Encoding.CodePage as CodePage
 import Text.Read (reads)
@@ -43,9 +44,13 @@ import qualified GHC.IO.Encoding.Latin1 as Latin1
 import qualified GHC.IO.Encoding.UTF8   as UTF8
 import qualified GHC.IO.Encoding.UTF16  as UTF16
 import qualified GHC.IO.Encoding.UTF32  as UTF32
+import GHC.Word
 
+import Data.IORef
+import Data.Char (toUpper)
 import Data.List
 import Data.Maybe
+import System.IO.Unsafe (unsafePerformIO)
 
 -- -----------------------------------------------------------------------------
 
@@ -98,7 +103,7 @@ utf32be  :: TextEncoding
 utf32be = UTF32.utf32be
 
 -- | The Unicode encoding of the current locale
-localeEncoding :: TextEncoding
+getLocaleEncoding :: IO TextEncoding
 
 -- | The Unicode encoding of the current locale, but allowing arbitrary
 -- undecodable bytes to be round-tripped through it.
@@ -109,21 +114,43 @@ localeEncoding :: TextEncoding
 -- On Windows, this encoding *should not* be used if possible because
 -- the use of code pages is deprecated: Strings should be retrieved
 -- via the "wide" W-family of UTF-16 APIs instead
-fileSystemEncoding :: TextEncoding
+getFileSystemEncoding :: IO TextEncoding
 
 -- | The Unicode encoding of the current locale, but where undecodable
 -- bytes are replaced with their closest visual match. Used for
 -- the 'CString' marshalling functions in "Foreign.C.String"
-foreignEncoding :: TextEncoding
+getForeignEncoding :: IO TextEncoding
+
+setLocaleEncoding, setFileSystemEncoding, setForeignEncoding :: TextEncoding -> IO ()
+(getLocaleEncoding, setLocaleEncoding)         = mkGlobal initLocaleEncoding
+(getFileSystemEncoding, setFileSystemEncoding) = mkGlobal initFileSystemEncoding
+(getForeignEncoding, setForeignEncoding)       = mkGlobal initForeignEncoding
+
+mkGlobal :: a -> (IO a, a -> IO ())
+mkGlobal x = unsafePerformIO $ do
+    x_ref <- newIORef x
+    return (readIORef x_ref, writeIORef x_ref)
+
+initLocaleEncoding, initFileSystemEncoding, initForeignEncoding :: TextEncoding
 
 #if !defined(mingw32_HOST_OS)
-localeEncoding = Iconv.localeEncoding
-fileSystemEncoding = Iconv.mkLocaleEncoding RoundtripFailure
-foreignEncoding = Iconv.mkLocaleEncoding IgnoreCodingFailure
+-- It is rather important that we don't just call Iconv.mkIconvEncoding here
+-- because some iconvs (in particular GNU iconv) will brokenly UTF-8 encode
+-- lone surrogates without complaint.
+--
+-- By going through our Haskell implementations of those encodings, we are
+-- guaranteed to catch such errors.
+--
+-- FIXME: this is not a complete solution because if the locale encoding is one
+-- which we don't have a Haskell-side decoder for, iconv might still ignore the
+-- lone surrogate in the input.
+initLocaleEncoding     = unsafePerformIO $ mkTextEncoding' ErrorOnCodingFailure Iconv.localeEncodingName
+initFileSystemEncoding = unsafePerformIO $ mkTextEncoding' RoundtripFailure     Iconv.localeEncodingName
+initForeignEncoding    = unsafePerformIO $ mkTextEncoding' IgnoreCodingFailure  Iconv.localeEncodingName
 #else
-localeEncoding = CodePage.localeEncoding
-fileSystemEncoding = CodePage.mkLocaleEncoding RoundtripFailure
-foreignEncoding = CodePage.mkLocaleEncoding IgnoreCodingFailure
+initLocaleEncoding     = CodePage.localeEncoding
+initFileSystemEncoding = CodePage.mkLocaleEncoding RoundtripFailure
+initForeignEncoding    = CodePage.mkLocaleEncoding IgnoreCodingFailure
 #endif
 
 -- | An encoding in which Unicode code points are translated to bytes
@@ -131,7 +158,7 @@ foreignEncoding = CodePage.mkLocaleEncoding IgnoreCodingFailure
 -- translated directly into the equivalent code point.
 --
 -- This encoding never fails in either direction.  However, encoding
--- discards informaiton, so encode followed by decode is not the
+-- discards information, so encode followed by decode is not the
 -- identity.
 char8 :: TextEncoding
 char8 = Latin1.latin1
@@ -164,21 +191,8 @@ char8 = Latin1.latin1
 --
 mkTextEncoding :: String -> IO TextEncoding
 mkTextEncoding e = case mb_coding_failure_mode of
-  Nothing -> unknown_encoding
-  Just cfm -> case enc of
-    "UTF-8"    -> return $ UTF8.mkUTF8 cfm
-    "UTF-16"   -> return $ UTF16.mkUTF16 cfm
-    "UTF-16LE" -> return $ UTF16.mkUTF16le cfm
-    "UTF-16BE" -> return $ UTF16.mkUTF16be cfm
-    "UTF-32"   -> return $ UTF32.mkUTF32 cfm
-    "UTF-32LE" -> return $ UTF32.mkUTF32le cfm
-    "UTF-32BE" -> return $ UTF32.mkUTF32be cfm
-#if defined(mingw32_HOST_OS)
-    'C':'P':n | [(cp,"")] <- reads n -> return $ CodePage.mkCodePageEncoding cfm cp
-    _ -> unknown_encoding
-#else
-    _ -> Iconv.mkIconvEncoding cfm enc
-#endif
+    Nothing -> unknownEncodingErr e
+    Just cfm -> mkTextEncoding' cfm enc
   where
     -- The only problem with actually documenting //IGNORE and //TRANSLIT as
     -- supported suffixes is that they are not necessarily supported with non-GNU iconv
@@ -189,9 +203,22 @@ mkTextEncoding e = case mb_coding_failure_mode of
         "//TRANSLIT"  -> Just TransliterateCodingFailure
         "//ROUNDTRIP" -> Just RoundtripFailure
         _             -> Nothing
-    
-    unknown_encoding = ioException (IOError Nothing NoSuchThing "mkTextEncoding"
-                                            ("unknown encoding:" ++ e)  Nothing Nothing)
+
+mkTextEncoding' :: CodingFailureMode -> String -> IO TextEncoding
+mkTextEncoding' cfm enc = case [toUpper c | c <- enc, c /= '-'] of
+    "UTF8"    -> return $ UTF8.mkUTF8 cfm
+    "UTF16"   -> return $ UTF16.mkUTF16 cfm
+    "UTF16LE" -> return $ UTF16.mkUTF16le cfm
+    "UTF16BE" -> return $ UTF16.mkUTF16be cfm
+    "UTF32"   -> return $ UTF32.mkUTF32 cfm
+    "UTF32LE" -> return $ UTF32.mkUTF32le cfm
+    "UTF32BE" -> return $ UTF32.mkUTF32be cfm
+#if defined(mingw32_HOST_OS)
+    'C':'P':n | [(cp,"")] <- reads n -> return $ CodePage.mkCodePageEncoding cfm cp
+    _ -> unknownEncodingErr (enc ++ codingFailureModeSuffix cfm)
+#else
+    _ -> Iconv.mkIconvEncoding cfm enc
+#endif
 
 latin1_encode :: CharBuffer -> Buffer Word8 -> IO (CharBuffer, Buffer Word8)
 latin1_encode input output = fmap (\(_why,input',output') -> (input',output')) $ Latin1.latin1_encode input output -- unchecked, used for char8
@@ -200,3 +227,7 @@ latin1_encode input output = fmap (\(_why,input',output') -> (input',output')) $
 latin1_decode :: Buffer Word8 -> CharBuffer -> IO (Buffer Word8, CharBuffer)
 latin1_decode input output = fmap (\(_why,input',output') -> (input',output')) $ Latin1.latin1_decode input output
 --latin1_decode = unsafePerformIO $ do mkTextDecoder Iconv.latin1 >>= return.encode
+
+unknownEncodingErr :: String -> IO a    
+unknownEncodingErr e = ioException (IOError Nothing NoSuchThing "mkTextEncoding"
+                                            ("unknown encoding:" ++ e)  Nothing Nothing)
index 48c7825..ea32431 100644 (file)
@@ -1,7 +1,10 @@
 {-# LANGUAGE Trustworthy #-}
 {-# LANGUAGE NoImplicitPrelude #-}
+
 module GHC.IO.Encoding where
 
+import GHC.IO (IO)
 import GHC.IO.Encoding.Types
 
-localeEncoding, fileSystemEncoding, foreignEncoding :: TextEncoding
+getLocaleEncoding, getFileSystemEncoding, getForeignEncoding :: IO TextEncoding
+
index 724b8ae..0af89d7 100644 (file)
@@ -1,6 +1,7 @@
 {-# LANGUAGE Trustworthy #-}
 {-# LANGUAGE CPP, BangPatterns, ForeignFunctionInterface, NoImplicitPrelude,
              NondecreasingIndentation, MagicHash #-}
+
 module GHC.IO.Encoding.CodePage(
 #if !defined(mingw32_HOST_OS)
  ) where
@@ -168,3 +169,4 @@ indexChar :: ConvArray Char -> Int -> Char
 indexChar (ConvArray p) (I# i) = C# (chr# (indexInt16OffAddr# p i))
 
 #endif
+
index 08e084d..862de1f 100644 (file)
@@ -1,5 +1,6 @@
 {-# LANGUAGE Trustworthy #-}
 {-# LANGUAGE NoImplicitPrelude, PatternGuards #-}
+
 -----------------------------------------------------------------------------
 -- |
 -- Module      :  GHC.IO.Encoding.Failure
@@ -17,7 +18,6 @@
 module GHC.IO.Encoding.Failure (
     CodingFailureMode(..), codingFailureModeSuffix,
     isSurrogate,
-    surrogatifyRoundtripCharacter, desurrogatifyRoundtripCharacter,
     recoverDecode, recoverEncode
   ) where
 
@@ -35,33 +35,62 @@ import GHC.Real ( fromIntegral )
 
 import Data.Maybe
 
--- | The 'CodingFailureMode' is used to construct 'TextEncoding's, and specifies
--- how they handle illegal sequences.
-data CodingFailureMode = ErrorOnCodingFailure         -- ^ Throw an error when an illegal sequence is encountered
-                       | IgnoreCodingFailure          -- ^ Attempt to ignore and recover if an illegal sequence is encountered
-                       | TransliterateCodingFailure   -- ^ Replace with the closest visual match upon an illegal sequence
-                       | RoundtripFailure             -- ^ Use the private-use escape mechanism to attempt to allow illegal sequences to be roundtripped.
-                       deriving (Show)                -- This will only work properly for those encodings which are strict supersets of ASCII in the sense
-                                                      -- that valid ASCII data is also valid in that encoding. This is not true for e.g. UTF-16, because
-                                                      -- ASCII characters must be padded to two bytes to retain their meaning.
+
+-- | The 'CodingFailureMode' is used to construct 'TextEncoding's, and
+-- specifies how they handle illegal sequences.
+data CodingFailureMode
+  = ErrorOnCodingFailure
+       -- ^ Throw an error when an illegal sequence is encountered
+  | IgnoreCodingFailure
+       -- ^ Attempt to ignore and recover if an illegal sequence is
+       -- encountered
+  | TransliterateCodingFailure
+       -- ^ Replace with the closest visual match upon an illegal
+       -- sequence
+  | RoundtripFailure
+       -- ^ Use the private-use escape mechanism to attempt to allow
+       -- illegal sequences to be roundtripped.
+  deriving (Show)
+       -- This will only work properly for those encodings which are
+       -- strict supersets of ASCII in the sense that valid ASCII data
+       -- is also valid in that encoding. This is not true for
+       -- e.g. UTF-16, because ASCII characters must be padded to two
+       -- bytes to retain their meaning.
 
 -- Note [Roundtripping]
 -- ~~~~~~~~~~~~~~~~~~~~
 --
--- Roundtripping is based on the ideas of PEP383. However, unlike PEP383 we do not wish to use lone surrogate codepoints
--- to escape undecodable bytes, because that may confuse Unicode processing software written in Haskell. Instead, we use
--- the range of private-use characters from 0xEF80 to 0xEFFF designated for "encoding hacks" by the ConScript Unicode Registery.
+-- Roundtripping is based on the ideas of PEP383.
+--
+-- We used to use the range of private-use characters from 0xEF80 to
+-- 0xEFFF designated for "encoding hacks" by the ConScript Unicode Registery
+-- to encode these characters.
+--
+-- However, people didn't like this because it means we don't get
+-- guaranteed roundtripping for byte sequences that look like a UTF-8
+-- encoded codepoint 0xEFxx.
 --
--- This introduces a technical problem when it comes to encoding back to bytes using iconv. The iconv code will not fail when
--- it tries to encode a private-use character (as it would if trying to encode a surrogate), which means that we won't get a
--- chance to replace it with the byte we originally escaped.
+-- So now like PEP383 we use lone surrogate codepoints 0xDCxx to escape
+-- undecodable bytes, even though that may confuse Unicode processing
+-- software written in Haskell. This guarantees roundtripping because
+-- unicode input that includes lone surrogate codepoints is invalid by
+-- definition.
 --
--- To work around this, when filling the buffer to be encoded (in writeBlocks/withEncodedCString/newEncodedCString), we replace
--- the private-use characters with lone surrogates again! Likewise, when reading from a buffer (unpack/unpack_nl/peekEncodedCString)
--- we have to do the inverse process.
+-- When we used private-use characters there was a technical problem when it
+-- came to encoding back to bytes using iconv. The iconv code will not fail when
+-- it tries to encode a private-use character (as it would if trying to encode
+-- a surrogate), which means that we won't get a chance to replace it
+-- with the byte we originally escaped.
 --
--- The user of String should never see these lone surrogates, but it ensures that iconv will throw an error when encountering them.
--- We use lone surrogates in the range 0xDC00 to 0xDCFF for this purpose.
+-- To work around this, when filling the buffer to be encoded (in
+-- writeBlocks/withEncodedCString/newEncodedCString), we replaced the
+-- private-use characters with lone surrogates again! Likewise, when
+-- reading from a buffer (unpack/unpack_nl/peekEncodedCString) we have
+-- to do the inverse process.
+--
+-- The user of String would never see these lone surrogates, but it
+-- ensures that iconv will throw an error when encountering them.  We
+-- use lone surrogates in the range 0xDC00 to 0xDCFF for this purpose.
 
 codingFailureModeSuffix :: CodingFailureMode -> String
 codingFailureModeSuffix ErrorOnCodingFailure       = ""
@@ -69,56 +98,53 @@ codingFailureModeSuffix IgnoreCodingFailure        = "//IGNORE"
 codingFailureModeSuffix TransliterateCodingFailure = "//TRANSLIT"
 codingFailureModeSuffix RoundtripFailure           = "//ROUNDTRIP"
 
--- | In transliterate mode, we use this character when decoding unknown bytes.
+-- | In transliterate mode, we use this character when decoding
+-- unknown bytes.
 --
--- This is the defined Unicode replacement character: <http://www.fileformat.info/info/unicode/char/0fffd/index.htm>
+-- This is the defined Unicode replacement character:
+-- <http://www.fileformat.info/info/unicode/char/0fffd/index.htm>
 unrepresentableChar :: Char
 unrepresentableChar = '\xFFFD'
 
--- | Some characters are actually "surrogate" codepoints defined for use in UTF-16. We need to signal an
--- invalid character if we detect them when encoding a sequence of 'Char's into 'Word8's because they won't
--- give valid Unicode.
+-- It is extraordinarily important that this series of
+-- predicates/transformers gets inlined, because they tend to be used
+-- in inner loops related to text encoding. In particular,
+-- surrogatifyRoundtripCharacter must be inlined (see #5536)
+
+-- | Some characters are actually "surrogate" codepoints defined for
+-- use in UTF-16. We need to signal an invalid character if we detect
+-- them when encoding a sequence of 'Char's into 'Word8's because they
+-- won't give valid Unicode.
 --
--- We may also need to signal an invalid character if we detect them when encoding a sequence of 'Char's into 'Word8's
--- because the 'RoundtripFailure' mode creates these to round-trip bytes through our internal UTF-16 encoding.
+-- We may also need to signal an invalid character if we detect them
+-- when encoding a sequence of 'Char's into 'Word8's because the
+-- 'RoundtripFailure' mode creates these to round-trip bytes through
+-- our internal UTF-16 encoding.
+{-# INLINE isSurrogate #-}
 isSurrogate :: Char -> Bool
-isSurrogate c = (0xD800 <= x && x <= 0xDBFF) || (0xDC00 <= x && x <= 0xDFFF)
+isSurrogate c = (0xD800 <= x && x <= 0xDBFF)
+             || (0xDC00 <= x && x <= 0xDFFF)
   where x = ord c
 
--- | We use some private-use characters for roundtripping unknown bytes through a String
-isRoundtripEscapeChar :: Char -> Bool
-isRoundtripEscapeChar c = 0xEF00 <= x && x < 0xF000
-  where x = ord c
-
--- | We use some surrogate characters for roundtripping unknown bytes through a String
-isRoundtripEscapeSurrogateChar :: Char -> Bool
-isRoundtripEscapeSurrogateChar c = 0xDC00 <= x && x < 0xDD00
-  where x = ord c
-
--- Private use characters (in Strings) --> lone surrogates (in Buffer CharBufElem)
-surrogatifyRoundtripCharacter :: Char -> Char
-surrogatifyRoundtripCharacter c | isRoundtripEscapeChar c = chr (ord c - 0xEF00 + 0xDC00)
-                                | otherwise               = c
-
--- Lone surrogates (in Buffer CharBufElem) --> private use characters (in Strings)
-desurrogatifyRoundtripCharacter :: Char -> Char
-desurrogatifyRoundtripCharacter c | isRoundtripEscapeSurrogateChar c = chr (ord c - 0xDC00 + 0xEF00)
-                                  | otherwise                        = c
-
 -- Bytes (in Buffer Word8) --> lone surrogates (in Buffer CharBufElem)
+{-# INLINE escapeToRoundtripCharacterSurrogate #-}
 escapeToRoundtripCharacterSurrogate :: Word8 -> Char
 escapeToRoundtripCharacterSurrogate b
-  | b < 128   = chr (fromIntegral b) -- Disallow 'smuggling' of ASCII bytes. For roundtripping to work, this assumes encoding is ASCII-superset.
+  | b < 128   = chr (fromIntegral b)
+      -- Disallow 'smuggling' of ASCII bytes. For roundtripping to
+      -- work, this assumes encoding is ASCII-superset.
   | otherwise = chr (0xDC00 + fromIntegral b)
 
 -- Lone surrogates (in Buffer CharBufElem) --> bytes (in Buffer Word8)
+{-# INLINE unescapeRoundtripCharacterSurrogate #-}
 unescapeRoundtripCharacterSurrogate :: Char -> Maybe Word8
 unescapeRoundtripCharacterSurrogate c
     | 0xDC80 <= x && x < 0xDD00 = Just (fromIntegral x) -- Discard high byte
     | otherwise                 = Nothing
   where x = ord c
 
-recoverDecode :: CodingFailureMode -> Buffer Word8 -> Buffer Char -> IO (Buffer Word8, Buffer Char)
+recoverDecode :: CodingFailureMode -> Buffer Word8 -> Buffer Char
+              -> IO (Buffer Word8, Buffer Char)
 recoverDecode cfm input@Buffer{  bufRaw=iraw, bufL=ir, bufR=_  }
                   output@Buffer{ bufRaw=oraw, bufL=_,  bufR=ow } = do
  --puts $ "recoverDecode " ++ show ir
@@ -133,7 +159,8 @@ recoverDecode cfm input@Buffer{  bufRaw=iraw, bufL=ir, bufR=_  }
       ow' <- writeCharBuf oraw ow (escapeToRoundtripCharacterSurrogate b)
       return (input { bufL=ir+1 }, output { bufR=ow' })
 
-recoverEncode :: CodingFailureMode -> Buffer Char -> Buffer Word8 -> IO (Buffer Char, Buffer Word8)
+recoverEncode :: CodingFailureMode -> Buffer Char -> Buffer Word8
+              -> IO (Buffer Char, Buffer Word8)
 recoverEncode cfm input@Buffer{  bufRaw=iraw, bufL=ir, bufR=_  }
                   output@Buffer{ bufRaw=oraw, bufL=_,  bufR=ow } = do
   (c,ir') <- readCharBuf iraw ir
@@ -144,18 +171,20 @@ recoverEncode cfm input@Buffer{  bufRaw=iraw, bufL=ir, bufR=_  }
         if c == '?'
          then return (input { bufL=ir' }, output)
          else do
-          -- XXX: evil hack! To implement transliteration, we just poke an
-          -- ASCII ? into the input buffer and tell the caller to try and decode
-          -- again. This is *probably* safe given current uses of TextEncoding.
+          -- XXX: evil hack! To implement transliteration, we just
+          -- poke an ASCII ? into the input buffer and tell the caller
+          -- to try and decode again. This is *probably* safe given
+          -- current uses of TextEncoding.
           --
-          -- The "if" test above ensures we skip if the encoding fails to deal with
-          -- the ?, though this should never happen in practice as all encodings are
-          -- in fact capable of reperesenting all ASCII characters.
+          -- The "if" test above ensures we skip if the encoding fails
+          -- to deal with the ?, though this should never happen in
+          -- practice as all encodings are in fact capable of
+          -- reperesenting all ASCII characters.
           _ir' <- writeCharBuf iraw ir '?'
           return (input, output)
         
-        -- This implementation does not work because e.g. UTF-16 requires 2 bytes to
-        -- encode a simple ASCII value
+        -- This implementation does not work because e.g. UTF-16
+        -- requires 2 bytes to encode a simple ASCII value
         --writeWord8Buf oraw ow unrepresentableByte
         --return (input { bufL=ir' }, output { bufR=ow+1 })
     RoundtripFailure | Just x <- unescapeRoundtripCharacterSurrogate c -> do
@@ -172,3 +201,4 @@ ioe_encodingError :: IO a
 ioe_encodingError = ioException
     (IOError Nothing InvalidArgument "recoverEncode"
         "invalid character" Nothing Nothing)
+
index f8dfb88..50cdccb 100644 (file)
@@ -23,7 +23,7 @@
 module GHC.IO.Encoding.Iconv (
 #if !defined(mingw32_HOST_OS)
    iconvEncoding, mkIconvEncoding,
-   localeEncoding, mkLocaleEncoding
+   localeEncodingName
 #endif
  ) where
 
@@ -65,12 +65,6 @@ localeEncodingName = unsafePerformIO $ do
    cstr <- c_localeEncoding
    peekCAString cstr -- Assume charset names are ASCII
 
-localeEncoding :: TextEncoding
-localeEncoding = mkLocaleEncoding ErrorOnCodingFailure
-
-mkLocaleEncoding :: CodingFailureMode -> TextEncoding
-mkLocaleEncoding cfm = unsafePerformIO $ mkIconvEncoding cfm localeEncodingName
-
 -- We hope iconv_t is a storable type.  It should be, since it has at least the
 -- value -1, which is a possible return value from iconv_open.
 type IConv = CLong -- ToDo: (#type iconv_t)
@@ -190,3 +184,4 @@ iconvRecode iconv_t
               throwErrno "iconvRecoder"
 
 #endif /* !mingw32_HOST_OS */
+
index 0e3de39..aba66ad 100644 (file)
@@ -150,3 +150,4 @@ latin1_checked_encode
            invalid = done InvalidSequence ir ow
     in
     loop ir0 ow0
+
index df6ce2f..6147d01 100644 (file)
@@ -61,8 +61,9 @@ data BufferCodec from to state = BufferCodec {
    --
    -- Progress will usually be made by skipping the first element of the @from@
    -- buffer. This function should only be called if you are certain that you
-   -- wish to do this skipping, and if the @to@ buffer has at least one element
-   -- of free space.
+   -- wish to do this skipping and if the @to@ buffer has at least one element
+   -- of free space. Because this function deals with decoding failure, it assumes
+   -- that the from buffer has at least one element.
    --
    -- @recover@ may raise an exception rather than skipping anything.
    --
@@ -130,3 +131,4 @@ data CodingProgress = InputUnderflow  -- ^ Stopped because the input contains in
                                       -- to output at least one encoded ASCII character, but the input contains
                                       -- an invalid or unrepresentable sequence
                     deriving (Eq, Show)
+
index af3cae0..ca231ca 100644 (file)
@@ -355,3 +355,4 @@ validate2       ::  Word16 -> Word16 -> Bool
 validate2 x1 x2 = x1 >= 0xD800 && x1 <= 0xDBFF &&
                   x2 >= 0xDC00 && x2 <= 0xDFFF
 {-# INLINE validate2 #-}
+
index 815f36c..ce3aa52 100644 (file)
@@ -331,3 +331,4 @@ validate    :: Char -> Bool
 validate c = (x1 >= 0x0 && x1 < 0xD800) || (x1 > 0xDFFF && x1 <= 0x10FFFF)
    where x1 = ord c
 {-# INLINE validate #-}
+
index df3e67b..0d82113 100644 (file)
@@ -357,3 +357,4 @@ validate4 x1 x2 x3 x4 = validate4_1 ||
                   between x2 0x80 0x8F &&
                   between x3 0x80 0xBF &&
                   between x4 0x80 0xBF
+
index e3482cb..3f386ce 100644 (file)
@@ -2,6 +2,7 @@
 {-# LANGUAGE NoImplicitPrelude, DeriveDataTypeable, MagicHash #-}
 {-# OPTIONS_GHC -funbox-strict-fields #-}
 {-# OPTIONS_HADDOCK hide #-}
+
 -----------------------------------------------------------------------------
 -- |
 -- Module      :  GHC.IO.Exception
@@ -303,9 +304,12 @@ instance Show IOException where
          "" -> id
          _  -> showString " (" . showString s . showString ")")
 
+-- Note the use of "lazy". This means that
+--     assert False (throw e)
+-- will throw the assertion failure rather than e. See trac #5561.
 assertError :: Addr# -> Bool -> a -> a
 assertError str predicate v
-  | predicate = v
+  | predicate = lazy v
   | otherwise = throw (AssertionFailed (untangle str "Assertion failed"))
 
 unsupportedOperation :: IOError
@@ -336,3 +340,4 @@ untangle coded message
           _         -> (loc, "")
         }
     not_bar c = c /= '|'
+
index fa3abe7..3506c1e 100644 (file)
@@ -1,5 +1,6 @@
 {-# LANGUAGE Trustworthy #-}
 {-# LANGUAGE NoImplicitPrelude #-}
+
 module GHC.IO.Exception where
 
 import GHC.Base
@@ -11,3 +12,4 @@ instance Exception IOException
 type IOError = IOException
 userError :: String  -> IOError
 unsupportedOperation :: IOError
+
index 282c215..9422ddf 100644 (file)
@@ -1,3 +1,4 @@
+{-# LANGUAGE Trustworthy #-}
 {-# LANGUAGE CPP
            , NoImplicitPrelude
            , BangPatterns
@@ -663,3 +664,4 @@ foreign import ccall unsafe "lockFile"
 foreign import ccall unsafe "unlockFile"
   unlockFile :: CInt -> IO CInt
 #endif
+
index cb6f650..6219670 100644 (file)
@@ -562,8 +562,8 @@ hSetBinaryMode handle bin =
          flushCharBuffer h_
          closeTextCodecs h_
 
-         let mb_te | bin       = Nothing
-                   | otherwise = Just localeEncoding
+         mb_te <- if bin then return Nothing
+                         else fmap Just getLocaleEncoding
 
          openTextEncoding mb_te haType $ \ mb_encoder mb_decoder -> do
 
@@ -639,7 +639,7 @@ dupHandle_ :: (IODevice dev, BufferedIO dev, Typeable dev) => dev
            -> IO Handle
 dupHandle_ new_dev filepath other_side h_@Handle__{..} mb_finalizer = do
    -- XXX wrong!
-  let mb_codec = if isJust haEncoder then Just localeEncoding else Nothing
+  mb_codec <- if isJust haEncoder then fmap Just getLocaleEncoding else return Nothing
   mkHandle new_dev filepath haType True{-buffered-} mb_codec
       NewlineMode { inputNL = haInputNL, outputNL = haOutputNL }
       mb_finalizer other_side
@@ -741,3 +741,4 @@ showHandle' filepath is_duplex h =
       where
        def :: Int 
        def = bufSize buf
+
index 935bf5e..02cd1bf 100644 (file)
@@ -7,3 +7,4 @@ import GHC.IO
 import GHC.IO.Handle.Types
 
 hFlush :: Handle -> IO ()
+
index 31f90ea..48381c1 100644 (file)
@@ -52,7 +52,8 @@ stdin :: Handle
 stdin = unsafePerformIO $ do
    -- ToDo: acquire lock
    setBinaryMode FD.stdin
-   mkHandle FD.stdin "<stdin>" ReadHandle True (Just localeEncoding)
+   enc <- getLocaleEncoding
+   mkHandle FD.stdin "<stdin>" ReadHandle True (Just enc)
                 nativeNewlineMode{-translate newlines-}
                 (Just stdHandleFinalizer) Nothing
 
@@ -62,7 +63,8 @@ stdout :: Handle
 stdout = unsafePerformIO $ do
    -- ToDo: acquire lock
    setBinaryMode FD.stdout
-   mkHandle FD.stdout "<stdout>" WriteHandle True (Just localeEncoding)
+   enc <- getLocaleEncoding
+   mkHandle FD.stdout "<stdout>" WriteHandle True (Just enc)
                 nativeNewlineMode{-translate newlines-}
                 (Just stdHandleFinalizer) Nothing
 
@@ -72,8 +74,9 @@ stderr :: Handle
 stderr = unsafePerformIO $ do
     -- ToDo: acquire lock
    setBinaryMode FD.stderr
+   enc <- getLocaleEncoding
    mkHandle FD.stderr "<stderr>" WriteHandle False{-stderr is unbuffered-} 
-                (Just localeEncoding)
+                (Just enc)
                 nativeNewlineMode{-translate newlines-}
                 (Just stdHandleFinalizer) Nothing
 
@@ -90,7 +93,7 @@ stdHandleFinalizer fp m = do
 -- translation that the CRT IO library does.
 setBinaryMode :: FD.FD -> IO ()
 #ifdef mingw32_HOST_OS
-setBinaryMode fd = do _ <- setmode (fdFD fd) True
+setBinaryMode fd = do _ <- setmode (FD.fdFD fd) True
                       return ()
 #else
 setBinaryMode _ = return ()
@@ -179,7 +182,7 @@ openFile' filepath iomode binary non_blocking = do
   -- first open the file to get an FD
   (fd, fd_type) <- FD.openFile filepath iomode non_blocking
 
-  let mb_codec = if binary then Nothing else Just localeEncoding
+  mb_codec <- if binary then return Nothing else fmap Just getLocaleEncoding
 
   -- then use it to make a Handle
   mkHandleFromFD fd fd_type filepath iomode
@@ -253,8 +256,8 @@ fdToHandle' fdint mb_type is_socket filepath iomode binary = do
   (fd,fd_type) <- FD.mkFD fdint iomode mb_stat
                        is_socket
                        is_socket
-  mkHandleFromFD fd fd_type filepath iomode is_socket
-                       (if binary then Nothing else Just localeEncoding)
+  enc <- if binary then return Nothing else fmap Just getLocaleEncoding
+  mkHandleFromFD fd fd_type filepath iomode is_socket enc
 
 
 -- | Turn an existing file descriptor into a Handle.  This is used by
index fb8ee97..b592a05 100644 (file)
@@ -1,8 +1,10 @@
 {-# LANGUAGE Trustworthy #-}
 {-# LANGUAGE NoImplicitPrelude #-}
+
 module GHC.IO.Handle.FD where
 
 import GHC.IO.Handle.Types
 
 -- used in GHC.Conc, which is below GHC.IO.Handle.FD
 stdout :: Handle
+
index 7e619c4..b77de47 100644 (file)
@@ -320,7 +320,7 @@ checkSeekableHandle act handle_@Handle__{haDevice=dev} =
 
 ioe_closedHandle, ioe_EOF,
   ioe_notReadable, ioe_notWritable, ioe_cannotFlushNotSeekable,
-  ioe_notSeekable, ioe_invalidCharacter :: IO a
+  ioe_notSeekable :: IO a
 
 ioe_closedHandle = ioException
    (IOError Nothing IllegalOperation ""
@@ -340,9 +340,6 @@ ioe_cannotFlushNotSeekable = ioException
    (IOError Nothing IllegalOperation ""
       "cannot flush the read buffer: underlying device is not seekable"
         Nothing Nothing)
-ioe_invalidCharacter = ioException
-   (IOError Nothing InvalidArgument ""
-        ("invalid byte sequence for this encoding") Nothing Nothing)
 
 ioe_finalizedHandle :: FilePath -> Handle__
 ioe_finalizedHandle fp = throw
@@ -369,9 +366,6 @@ ioe_bufsiz n = ioException
 -- FIXME: it is possible that Handle code using the haDecoder/haEncoder fields
 -- could be made clearer by using the 'encode' interface directly. I have not
 -- looked into this.
---
--- FIXME: we should use recover to deal with EOF, rather than always throwing an
--- IOException (ioe_invalidCharacter).
 
 streamEncode :: BufferCodec from to state
              -> Buffer from -> Buffer to
@@ -846,36 +840,46 @@ readTextDevice h_@Handle__{..} cbuf = do
 -- we have an incomplete byte sequence at the end of the buffer: try to
 -- read more bytes.
 readTextDevice' :: Handle__ -> Buffer Word8 -> CharBuffer -> IO CharBuffer
-readTextDevice' h_@Handle__{..} bbuf0 cbuf = do
+readTextDevice' h_@Handle__{..} bbuf0 cbuf0 = do
   --
   -- copy the partial sequence to the beginning of the buffer, so we have
   -- room to read more bytes.
   bbuf1 <- slideContents bbuf0
 
-  bbuf2 <- do (r,bbuf2) <- Buffered.fillReadBuffer haDevice bbuf1
-              if r == 0 
-                 then ioe_invalidCharacter
-                 else return bbuf2
-
-  debugIO ("readTextDevice' after reading: bbuf=" ++ summaryBuffer bbuf2)
-
-  (bbuf3,cbuf') <- 
-      case haDecoder of
-          Nothing      -> do
-               writeIORef haLastDecode (error "codec_state", bbuf2)
-               latin1_decode bbuf2 cbuf
-          Just decoder -> do
-               state <- getState decoder
-               writeIORef haLastDecode (state, bbuf2)
-               (streamEncode decoder) bbuf2 cbuf
-
-  debugIO ("readTextDevice' after decoding: cbuf=" ++ summaryBuffer cbuf' ++ 
-        " bbuf=" ++ summaryBuffer bbuf3)
-
-  writeIORef haByteBuffer bbuf3
-  if bufR cbuf == bufR cbuf'
-     then readTextDevice' h_ bbuf3 cbuf'
-     else return cbuf'
+  -- readTextDevice only calls us if we got some bytes but not some characters.
+  -- This can't occur if haDecoder is Nothing because latin1_decode accepts all bytes.
+  let Just decoder = haDecoder
+  
+  (r,bbuf2) <- Buffered.fillReadBuffer haDevice bbuf1
+  if r == 0
+   then do
+     (bbuf3, cbuf1) <- recover decoder bbuf2 cbuf0
+     writeIORef haByteBuffer bbuf3
+     -- We should recursively invoke readTextDevice after recovery,
+     -- if recovery did not add at least one new character to the buffer:
+     --  1. If we were using IgnoreCodingFailure it might be the case that
+     --     cbuf1 is the same length as cbuf0 and we need to raise ioe_EOF
+     --  2. If we were using TransliterateCodingFailure we might have *mutated*
+     --     the byte buffer without changing the pointers into either buffer.
+     --     We need to try and decode it again - it might just go through this time.
+     if bufR cbuf1 == bufR cbuf0
+      then readTextDevice h_ cbuf1
+      else return cbuf1
+   else do
+    debugIO ("readTextDevice' after reading: bbuf=" ++ summaryBuffer bbuf2)
+  
+    (bbuf3,cbuf1) <- do
+       state <- getState decoder
+       writeIORef haLastDecode (state, bbuf2)
+       (streamEncode decoder) bbuf2 cbuf0
+  
+    debugIO ("readTextDevice' after decoding: cbuf=" ++ summaryBuffer cbuf1 ++ 
+          " bbuf=" ++ summaryBuffer bbuf3)
+  
+    writeIORef haByteBuffer bbuf3
+    if bufR cbuf0 == bufR cbuf1
+       then readTextDevice' h_ bbuf3 cbuf1
+       else return cbuf1
 
 -- Read characters into the provided buffer.  Do not block;
 -- return zero characters instead.  Raises an exception on end-of-file.
@@ -908,3 +912,4 @@ decodeByteBuf h_@Handle__{..} cbuf = do
 
   writeIORef haByteBuffer bbuf2
   return cbuf'
+
index 7b390cd..280cebd 100644 (file)
@@ -39,7 +39,6 @@ import GHC.IO.FD
 import GHC.IO.Buffer
 import qualified GHC.IO.BufferedIO as Buffered
 import GHC.IO.Exception
-import GHC.IO.Encoding.Failure (surrogatifyRoundtripCharacter, desurrogatifyRoundtripCharacter)
 import GHC.Exception
 import GHC.IO.Handle.Types
 import GHC.IO.Handle.Internals
@@ -273,6 +272,9 @@ unpack !buf !r !w acc0
         unpackRB acc !i
          | i < r  = return acc
          | otherwise = do
+              -- Here, we are rather careful to only put an *evaluated* character
+              -- in the output string. Due to pointer tagging, this allows the consumer
+              -- to avoid ping-ponging between the actual consumer code and the thunk code
 #ifdef CHARBUF_UTF16
               -- reverse-order decoding of UTF-16
               c2 <- peekElemOff pbuf i
@@ -281,10 +283,11 @@ unpack !buf !r !w acc0
                  else do c1 <- peekElemOff pbuf (i-1)
                          let c = (fromIntegral c1 - 0xd800) * 0x400 +
                                  (fromIntegral c2 - 0xdc00) + 0x10000
-                         unpackRB (desurrogatifyRoundtripCharacter (unsafeChr c) : acc) (i-2)
+                         case desurrogatifyRoundtripCharacter (unsafeChr c) of
+                           { C# c# -> unpackRB (C# c# : acc) (i-2) }
 #else
               c <- peekElemOff pbuf i
-              unpackRB (desurrogatifyRoundtripCharacter c:acc) (i-1)
+              unpackRB (c : acc) (i-1)
 #endif
      in
      unpackRB acc0 (w-1)
@@ -307,7 +310,7 @@ unpack_nl !buf !r !w acc0
                             then unpackRB ('\n':acc) (i-2)
                             else unpackRB ('\n':acc) (i-1)
                  else do
-                         unpackRB (desurrogatifyRoundtripCharacter c:acc) (i-1)
+                         unpackRB (c : acc) (i-1)
      in do
      c <- peekElemOff pbuf (w-1)
      if (c == '\r')
@@ -321,6 +324,24 @@ unpack_nl !buf !r !w acc0
                 str <- unpackRB acc0 (w-1)
                 return (str, w)
 
+-- Note [#5536]
+--
+-- We originally had
+--
+--    let c' = desurrogatifyRoundtripCharacter c in
+--    c' `seq` unpackRB (c':acc) (i-1)
+--
+-- but this resulted in Core like
+--
+--    case (case x <# y of True -> C# e1; False -> C# e2) of c
+--      C# _ -> unpackRB (c:acc) (i-1)
+--
+-- which compiles into a continuation for the outer case, with each
+-- branch of the inner case building a C# and then jumping to the
+-- continuation.  We'd rather not have this extra jump, which makes
+-- quite a difference to performance (see #5536) It turns out that
+-- matching on the C# directly causes GHC to do the case-of-case,
+-- giving much straighter code.
 
 -- -----------------------------------------------------------------------------
 -- hGetContents
@@ -587,7 +608,7 @@ writeBlocks hdl line_buffered add_nl nl
            else do
                shoveString n' cs rest
      | otherwise = do
-        n' <- writeCharBuf raw n (surrogatifyRoundtripCharacter c)
+        n' <- writeCharBuf raw n c
         shoveString n' cs rest
   in
   shoveString 0 s (if add_nl then "\n" else "")
@@ -985,3 +1006,4 @@ illegalBufferSize handle fn sz =
                             InvalidArgument  fn
                             ("illegal buffer size " ++ showsPrec 9 sz [])
                             Nothing Nothing)
+
index 40c557a..ec8f453 100644 (file)
@@ -428,3 +428,4 @@ instance Show Handle where
 
 showHandle :: FilePath -> String -> String
 showHandle file = showString "{handle: " . showString file . showString "}"
+
index b649ac1..42cc9f3 100644 (file)
@@ -1,6 +1,7 @@
 {-# LANGUAGE Trustworthy #-}
 {-# LANGUAGE NoImplicitPrelude #-}
 {-# OPTIONS_HADDOCK hide #-}
+
 -----------------------------------------------------------------------------
 -- |
 -- Module      :  GHC.IO.IOMode
@@ -26,3 +27,4 @@ import GHC.Enum
 -- | See 'System.IO.openFile'
 data IOMode      =  ReadMode | WriteMode | AppendMode | ReadWriteMode
                     deriving (Eq, Ord, Ix, Enum, Read, Show)
+
index 0b43c8b..800b596 100644 (file)
@@ -1,6 +1,8 @@
+{-# LANGUAGE Unsafe #-}
 {-# LANGUAGE NoImplicitPrelude #-}
 {-# OPTIONS_GHC -funbox-strict-fields #-}
 {-# OPTIONS_HADDOCK hide #-}
+
 -----------------------------------------------------------------------------
 -- |
 -- Module      :  GHC.IOArray
index 4177b07..60fb943 100644 (file)
@@ -1,3 +1,4 @@
+{-# LANGUAGE Unsafe #-}
 {-# LANGUAGE DeriveDataTypeable #-}
 {-# OPTIONS_HADDOCK hide #-}
 
@@ -6,7 +7,7 @@
 -- Module      :  GHC.IOBase
 -- Copyright   :  (c) The University of Glasgow 1994-2009
 -- License     :  see libraries/base/LICENSE
--- 
+--
 -- Maintainer  :  cvs-ghc@haskell.org
 -- Stability   :  internal
 -- Portability :  non-portable (GHC Extensions)
@@ -15,9 +16,8 @@
 --
 -----------------------------------------------------------------------------
 
-
 module GHC.IOBase {-# DEPRECATED "use GHC.IO instead" #-} (
-    IO(..), unIO, failIO, liftIO, bindIO, thenIO, returnIO, 
+    IO(..), unIO, failIO, liftIO, bindIO, thenIO, returnIO,
     unsafePerformIO, unsafeInterleaveIO,
     unsafeDupablePerformIO, unsafeDupableInterleaveIO,
     noDuplicate,
@@ -26,23 +26,23 @@ module GHC.IOBase {-# DEPRECATED "use GHC.IO instead" #-} (
     stToIO, ioToST, unsafeIOToST, unsafeSTToIO,
 
         -- References
-    IORef(..), newIORef, readIORef, writeIORef, 
+    IORef(..), newIORef, readIORef, writeIORef,
     IOArray(..), newIOArray, readIOArray, writeIOArray, unsafeReadIOArray, unsafeWriteIOArray,
     MVar(..),
 
         -- Handles, file descriptors,
-    FilePath,  
-    Handle(..), Handle__(..), HandleType(..), IOMode(..), FD, 
+    FilePath,
+    Handle(..), Handle__(..), HandleType(..), IOMode(..), FD,
     isReadableHandleType, isWritableHandleType, isReadWriteHandleType, showHandle,
 
         -- Buffers
-    -- Buffer(..), RawBuffer, BufferState(..), 
+    -- Buffer(..), RawBuffer, BufferState(..),
     BufferList(..), BufferMode(..),
-    --bufferIsWritable, bufferEmpty, bufferFull, 
+    --bufferIsWritable, bufferEmpty, bufferFull,
 
         -- Exceptions
     Exception(..), ArithException(..), AsyncException(..), ArrayException(..),
-    stackOverflow, heapOverflow, ioException, 
+    stackOverflow, heapOverflow, ioException,
     IOError, IOException(..), IOErrorType(..), ioError, userError,
     ExitCode(..),
     throwIO, block, unblock, blocked, catchAny, catchException,
@@ -62,7 +62,6 @@ import GHC.IOArray
 import GHC.IORef
 import GHC.MVar
 import Foreign.C.Types
-import GHC.Show
 import Data.Typeable
 
 type FD = CInt
@@ -91,3 +90,4 @@ instance Show BlockedIndefinitely where
 
 blockedIndefinitely :: SomeException -- for the RTS
 blockedIndefinitely = toException BlockedIndefinitely
+
index 6efb77f..a0ed082 100644 (file)
@@ -1,3 +1,4 @@
+{-# LANGUAGE Unsafe #-}
 {-# LANGUAGE NoImplicitPrelude, MagicHash #-}
 {-# OPTIONS_GHC -funbox-strict-fields #-}
 {-# OPTIONS_HADDOCK hide #-}
@@ -15,6 +16,7 @@
 -- The IORef type
 --
 -----------------------------------------------------------------------------
+
 module GHC.IORef (
         IORef(..),
         newIORef, readIORef, writeIORef, atomicModifyIORef
index b80bd1a..b11cf26 100644 (file)
@@ -1,13 +1,14 @@
 {-# LANGUAGE Trustworthy #-}
-{-# LANGUAGE CPP, NoImplicitPrelude, BangPatterns, MagicHash, 
+{-# LANGUAGE CPP, NoImplicitPrelude, BangPatterns, MagicHash,
              StandaloneDeriving #-}
 {-# OPTIONS_HADDOCK hide #-}
+
 -----------------------------------------------------------------------------
 -- |
 -- Module      :  GHC.Int
 -- Copyright   :  (c) The University of Glasgow 1997-2002
 -- License     :  see libraries/base/LICENSE
--- 
+--
 -- Maintainer  :  cvs-ghc@haskell.org
 -- Stability   :  internal
 -- Portability :  non-portable (GHC Extensions)
@@ -26,9 +27,6 @@ module GHC.Int (
 
 import Data.Bits
 
-#if WORD_SIZE_IN_BITS < 32
-import GHC.IntWord32
-#endif
 #if WORD_SIZE_IN_BITS < 64
 import GHC.IntWord64
 #endif
@@ -68,7 +66,7 @@ instance Num Int8 where
     signum x | x > 0       = 1
     signum 0               = 0
     signum _               = -1
-    fromInteger i          = I8# (narrow8Int# (toInt# i))
+    fromInteger i          = I8# (narrow8Int# (integerToInt i))
 
 instance Real Int8 where
     toRational x = toInteger x % 1
@@ -93,26 +91,26 @@ instance Integral Int8 where
         | y == 0                     = divZeroError
         | y == (-1) && x == minBound = overflowError -- Note [Order of tests]
         | otherwise                  = I8# (narrow8Int# (x# `quotInt#` y#))
-    rem     x@(I8# x#) y@(I8# y#)
+    rem     (I8# x#) y@(I8# y#)
         | y == 0                     = divZeroError
-        | y == (-1) && x == minBound = overflowError -- Note [Order of tests]
         | otherwise                  = I8# (narrow8Int# (x# `remInt#` y#))
     div     x@(I8# x#) y@(I8# y#)
         | y == 0                     = divZeroError
         | y == (-1) && x == minBound = overflowError -- Note [Order of tests]
         | otherwise                  = I8# (narrow8Int# (x# `divInt#` y#))
-    mod     x@(I8# x#) y@(I8# y#)
+    mod       (I8# x#) y@(I8# y#)
         | y == 0                     = divZeroError
-        | y == (-1) && x == minBound = overflowError -- Note [Order of tests]
         | otherwise                  = I8# (narrow8Int# (x# `modInt#` y#))
     quotRem x@(I8# x#) y@(I8# y#)
         | y == 0                     = divZeroError
-        | y == (-1) && x == minBound = overflowError -- Note [Order of tests]
+          -- Note [Order of tests]
+        | y == (-1) && x == minBound = (overflowError, 0)
         | otherwise                  = (I8# (narrow8Int# (x# `quotInt#` y#)),
                                        I8# (narrow8Int# (x# `remInt#` y#)))
     divMod  x@(I8# x#) y@(I8# y#)
         | y == 0                     = divZeroError
-        | y == (-1) && x == minBound = overflowError -- Note [Order of tests]
+          -- Note [Order of tests]
+        | y == (-1) && x == minBound = (overflowError, 0)
         | otherwise                  = (I8# (narrow8Int# (x# `divInt#` y#)),
                                        I8# (narrow8Int# (x# `modInt#` y#)))
     toInteger (I8# x#)               = smallInteger x#
@@ -139,8 +137,12 @@ instance Bits Int8 where
     (I8# x#) `shift` (I# i#)
         | i# >=# 0#           = I8# (narrow8Int# (x# `iShiftL#` i#))
         | otherwise           = I8# (x# `iShiftRA#` negateInt# i#)
+    (I8# x#) `shiftL` (I# i#) = I8# (narrow8Int# (x# `iShiftL#` i#))
+    (I8# x#) `unsafeShiftL` (I# i#) = I8# (narrow8Int# (x# `uncheckedIShiftL#` i#))
+    (I8# x#) `shiftR` (I# i#) = I8# (x# `iShiftRA#` i#)
+    (I8# x#) `unsafeShiftR` (I# i#) = I8# (x# `uncheckedIShiftRA#` i#)
     (I8# x#) `rotate` (I# i#)
-        | i'# ==# 0# 
+        | i'# ==# 0#
         = I8# x#
         | otherwise
         = I8# (narrow8Int# (word2Int# ((x'# `uncheckedShiftL#` i'#) `or#`
@@ -150,6 +152,7 @@ instance Bits Int8 where
         !i'# = word2Int# (int2Word# i# `and#` int2Word# 7#)
     bitSize  _                = 8
     isSigned _                = True
+    popCount (I8# x#)         = I# (word2Int# (popCnt8# (int2Word# x#)))
 
 {-# RULES
 "fromIntegral/Int8->Int8" fromIntegral = id :: Int8 -> Int8
@@ -210,7 +213,7 @@ instance Num Int16 where
     signum x | x > 0       = 1
     signum 0               = 0
     signum _               = -1
-    fromInteger i          = I16# (narrow16Int# (toInt# i))
+    fromInteger i          = I16# (narrow16Int# (integerToInt i))
 
 instance Real Int16 where
     toRational x = toInteger x % 1
@@ -235,26 +238,26 @@ instance Integral Int16 where
         | y == 0                     = divZeroError
         | y == (-1) && x == minBound = overflowError -- Note [Order of tests]
         | otherwise                  = I16# (narrow16Int# (x# `quotInt#` y#))
-    rem     x@(I16# x#) y@(I16# y#)
+    rem       (I16# x#) y@(I16# y#)
         | y == 0                     = divZeroError
-        | y == (-1) && x == minBound = overflowError -- Note [Order of tests]
         | otherwise                  = I16# (narrow16Int# (x# `remInt#` y#))
     div     x@(I16# x#) y@(I16# y#)
         | y == 0                     = divZeroError
         | y == (-1) && x == minBound = overflowError -- Note [Order of tests]
         | otherwise                  = I16# (narrow16Int# (x# `divInt#` y#))
-    mod     x@(I16# x#) y@(I16# y#)
+    mod       (I16# x#) y@(I16# y#)
         | y == 0                     = divZeroError
-        | y == (-1) && x == minBound = overflowError -- Note [Order of tests]
         | otherwise                  = I16# (narrow16Int# (x# `modInt#` y#))
     quotRem x@(I16# x#) y@(I16# y#)
         | y == 0                     = divZeroError
-        | y == (-1) && x == minBound = overflowError -- Note [Order of tests]
+          -- Note [Order of tests]
+        | y == (-1) && x == minBound = (overflowError, 0)
         | otherwise                  = (I16# (narrow16Int# (x# `quotInt#` y#)),
                                         I16# (narrow16Int# (x# `remInt#` y#)))
     divMod  x@(I16# x#) y@(I16# y#)
         | y == 0                     = divZeroError
-        | y == (-1) && x == minBound = overflowError -- Note [Order of tests]
+          -- Note [Order of tests]
+        | y == (-1) && x == minBound = (overflowError, 0)
         | otherwise                  = (I16# (narrow16Int# (x# `divInt#` y#)),
                                         I16# (narrow16Int# (x# `modInt#` y#)))
     toInteger (I16# x#)              = smallInteger x#
@@ -281,8