Commit 8d87b5bf authored by Simon Peyton Jones's avatar Simon Peyton Jones
Browse files

Re-jig SOURCE imports

* Do not have have an hs-boot file for Data.Typeable
* Instead make all the loops go through
     GHC.Err (just a couple of magic functions)
     GHC.Exception (some non-exceptional functions)

The main idea is
  a) don't involve classes in the hs-boot world
  b) loop through error cases where performance doesn't matter
  c) be careful not to SOURCE import things that are bottom,
     unless MkCore knows about them in eRROR_IDS, so that we
     see their strictness
parent f3c261bc
......@@ -97,7 +97,6 @@ import Data.Maybe
#ifdef __GLASGOW_HASKELL__
import GHC.Base
import GHC.Err (undefined)
import GHC.Fingerprint.Type
import GHC.Fingerprint
......
......@@ -83,9 +83,7 @@ import Data.Typeable.Internal hiding (mkTyCon)
import Unsafe.Coerce
import Data.Maybe
import GHC.Base
import GHC.Err (undefined)
-------------------------------------------------------------
--
......@@ -100,14 +98,12 @@ cast x = if typeRep (Proxy :: Proxy a) == typeRep (Proxy :: Proxy b)
else Nothing
-- | A flexible variation parameterised in a type constructor
gcast :: (Typeable (a :: *), Typeable b) => c a -> Maybe (c b)
gcast :: forall a b c. (Typeable (a :: *), Typeable b) => c a -> Maybe (c b)
gcast x = r
where
r = if typeRep (getArg x) == typeRep (getArg (fromJust r))
r = if typeRep (Proxy :: Proxy a) == typeRep (Proxy :: Proxy b)
then Just $ unsafeCoerce x
else Nothing
getArg :: c x -> Proxy x
getArg = undefined
-- | Cast for * -> *
gcast1 :: forall c t t' a. (Typeable (t :: * -> *), Typeable t')
......
{-# LANGUAGE Trustworthy #-}
{-# LANGUAGE NoImplicitPrelude #-}
module Data.Typeable (Typeable, mkTyConApp, cast) where
import Data.Maybe
import {-# SOURCE #-} Data.Typeable.Internal
cast :: (Typeable a, Typeable b) => a -> Maybe b
......@@ -50,18 +50,17 @@ import GHC.Base
import GHC.Word
import GHC.Show
import Data.Maybe
import Data.List
import GHC.Num
import GHC.Real
import GHC.IORef
import GHC.IOArray
import GHC.MVar
-- 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.Stable
import GHC.Arr ( Array, STArray )
import Data.Int
-- import Data.Int
import GHC.Fingerprint.Type
import {-# SOURCE #-} GHC.Fingerprint
......@@ -165,7 +164,7 @@ mkTyCon3 :: String -- ^ package 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
TyCon (fingerprintString (pkg ++ (' ':modl) ++ (' ':name))) pkg modl name
----------------- Observation ---------------------
......@@ -249,7 +248,7 @@ instance Show TypeRep where
showParen (p > 9) $
showsPrec p tycon .
showChar ' ' .
showArgs tys
showArgs (showChar ' ') tys
showsTypeRep :: TypeRep -> ShowS
showsTypeRep = shows
......@@ -263,15 +262,14 @@ 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
showArgs :: Show a => ShowS -> [a] -> ShowS
showArgs _ [] = id
showArgs _ [a] = showsPrec 10 a
showArgs sep (a:as) = showsPrec 10 a . sep . showArgs sep as
showTuple :: [TypeRep] -> ShowS
showTuple args = showChar '('
. (foldr (.) id $ intersperse (showChar ',')
$ map (showsPrec 10) args)
. showArgs (showChar ',') args
. showChar ')'
listTc :: TyCon
......@@ -297,11 +295,11 @@ INSTANCE_TYPEABLE1(IO,ioTc,"IO")
#if defined(__GLASGOW_HASKELL__) || defined(__HUGS__)
-- Types defined in GHC.MVar
INSTANCE_TYPEABLE1(MVar,mvarTc,"MVar" )
{- INSTANCE_TYPEABLE1(MVar,mvarTc,"MVar" ) -}
#endif
INSTANCE_TYPEABLE2(Array,arrayTc,"Array")
INSTANCE_TYPEABLE2(IOArray,iOArrayTc,"IOArray")
{- INSTANCE_TYPEABLE2(IOArray,iOArrayTc,"IOArray") -}
#ifdef __GLASGOW_HASKELL__
-- Hugs has these too, but their Typeable<n> instances are defined
......@@ -325,8 +323,10 @@ INSTANCE_TYPEABLE1(FunPtr,funPtrTc,"FunPtr")
#ifndef __GLASGOW_HASKELL__
INSTANCE_TYPEABLE1(ForeignPtr,foreignPtrTc,"ForeignPtr")
#endif
{-
INSTANCE_TYPEABLE1(StablePtr,stablePtrTc,"StablePtr")
INSTANCE_TYPEABLE1(IORef,iORefTc,"IORef")
INSTANCE_TYPEABLE1(IORef,iORefTc,"IORef")
-}
-------------------------------------------------------
--
......@@ -346,10 +346,12 @@ INSTANCE_TYPEABLE0(Ordering,orderingTc,"Ordering")
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")
......
......@@ -80,9 +80,7 @@ import Foreign.Storable
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
import Data.Typeable
#ifdef __GLASGOW_HASKELL__
import GHC.Base
......
......@@ -64,7 +64,6 @@ import Foreign.Storable ( Storable(sizeOf) )
#ifdef __GLASGOW_HASKELL__
import GHC.Base
import GHC.Num
import GHC.Err ( undefined )
import GHC.ForeignPtr
#endif
......
......@@ -74,7 +74,6 @@ import Foreign.ForeignPtr ( FinalizerPtr )
import GHC.IO.Exception
import GHC.Real
import GHC.Ptr
import GHC.Err
import GHC.Base
#else
import Control.Exception.Base ( bracket )
......
......@@ -72,7 +72,6 @@ import Foreign.Marshal.Utils (copyBytes, moveBytes)
#ifdef __GLASGOW_HASKELL__
import GHC.Num
import GHC.List
import GHC.Err
import GHC.Base
#else
import Control.Monad (zipWithM_)
......
......@@ -46,7 +46,7 @@ import GHC.Num
import GHC.Int
import GHC.Word
import GHC.Ptr
import GHC.Err
import GHC.Exception
import GHC.Base
import GHC.Fingerprint.Type
import Data.Bits
......
......@@ -47,7 +47,7 @@ import GHC.Num
import GHC.ST
import GHC.Base
import GHC.List
import GHC.Real
import GHC.Real( fromIntegral )
import GHC.Show
infixl 9 !, //
......@@ -185,7 +185,7 @@ can do better, so we override the default method for index.
-- Abstract these errors from the relevant index functions so that
-- the guts of the function will be small enough to inline.
{-# NOINLINE indexError #-}
{- # NOINLINE indexError #-}
indexError :: Show a => (a,a) -> a -> String -> b
indexError rng i tp
= error (showString "Ix{" . showString tp . showString "}.index: Index " .
......
......@@ -101,8 +101,8 @@ module GHC.Base
module GHC.CString,
module GHC.Magic,
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
module GHC.Prim, -- Re-export GHC.Prim and [boot] GHC.Err, to avoid lots
module GHC.Err -- of people having to import it explicitly
)
where
......@@ -111,7 +111,7 @@ import GHC.Classes
import GHC.CString
import GHC.Magic
import GHC.Prim
import {-# SOURCE #-} GHC.Err
import GHC.Err
import {-# SOURCE #-} GHC.IO (failIO)
-- This is not strictly speaking required by this module, but is an
......
\begin{code}
{-# LANGUAGE Trustworthy #-}
{-# LANGUAGE CPP, NoImplicitPrelude #-}
{-# LANGUAGE CPP, NoImplicitPrelude, MagicHash #-}
{-# OPTIONS_HADDOCK hide #-}
-----------------------------------------------------------------------------
......@@ -23,20 +23,10 @@
-----------------------------------------------------------------------------
-- #hide
module GHC.Err
(
absentErr
, divZeroError
, ratioZeroDenominatorError
, overflowError
, error
, undefined
) where
module GHC.Err( absentErr, error, undefined ) where
import GHC.Types
import GHC.Exception
import GHC.Prim
import {-# SOURCE #-} GHC.Exception( errorCallException )
\end{code}
%*********************************************************
......@@ -48,7 +38,7 @@ import GHC.Exception
\begin{code}
-- | 'error' stops execution and displays an error message.
error :: [Char] -> a
error s = throw (ErrorCall s)
error s = raise# (errorCallException s)
-- | A special case of 'error'.
-- It is expected that compilers will recognize this and insert error
......@@ -70,25 +60,6 @@ encoding saves bytes of string junk.
\begin{code}
absentErr :: a
absentErr = error "Oops! The program has entered an `absent' argument!\n"
\end{code}
Divide by zero and arithmetic overflow.
We put them here because they are needed relatively early
in the libraries before the Exception type has been defined yet.
\begin{code}
{-# NOINLINE divZeroError #-}
divZeroError :: a
divZeroError = throw DivideByZero
{-# NOINLINE ratioZeroDenominatorError #-}
ratioZeroDenominatorError :: a
ratioZeroDenominatorError = throw RatioZeroDenominator
{-# NOINLINE overflowError #-}
overflowError :: a
overflowError = throw Overflow
\end{code}
......@@ -6,17 +6,17 @@
-- Ghc.Err.hs-boot
---------------------------------------------------------------------------
module GHC.Err( error ) where
module GHC.Err ( error, undefined ) where
import GHC.Types( Char )
-- The type signature for 'error' is a gross hack.
-- First, we can't give an accurate type for error, because it mentions
-- The type signature for 'error'/'undefined' is a gross hack:
-- we can't give an accurate type for error, because it mentions
-- an open type variable.
-- Second, we can't even say error :: [Char] -> a, because Char is defined
-- in GHC.Base, and that would make Err.lhs-boot mutually recursive
-- with GHC.Base.
-- Fortunately it doesn't matter what type we give here because the
-- compiler will use its wired-in version. But we have
-- to mention 'error' so that it gets exported from this .hi-boot
-- file.
error :: a
error :: [Char] -> a
undefined :: a
\end{code}
......@@ -33,7 +33,6 @@ import Foreign.ForeignPtr (ForeignPtr, withForeignPtr)
import Foreign.Ptr (Ptr, nullPtr, plusPtr)
import Foreign.Storable (Storable(..))
import GHC.Base
import GHC.Err (undefined)
import GHC.ForeignPtr (mallocPlainForeignPtrBytes, newForeignPtr_)
import GHC.Num (Num(..))
import GHC.Real (fromIntegral)
......
......@@ -52,7 +52,6 @@ import Foreign.Marshal.Utils (with)
import Foreign.Ptr (Ptr)
import Foreign.Storable (Storable(..))
import GHC.Base
import GHC.Err (undefined)
import GHC.Num (Num(..))
import GHC.Real (ceiling, fromIntegral)
import GHC.Show (Show)
......
......@@ -37,7 +37,6 @@ import Foreign.Ptr (Ptr)
import Foreign.Storable (Storable(..))
import GHC.Base
import GHC.Conc.Sync (withMVar)
import GHC.Err (undefined)
import GHC.Num (Num(..))
import GHC.Real (ceiling, fromIntegral)
import GHC.Show (Show)
......
......@@ -22,10 +22,16 @@
-----------------------------------------------------------------------------
-- #hide
module GHC.Exception where
module GHC.Exception
( Exception(..) -- Class
, throw
, SomeException(..), ErrorCall(..), ArithException(..)
, divZeroException, overflowException, ratioZeroDenomException
, errorCallException
) where
import Data.Maybe
import {-# SOURCE #-} Data.Typeable (Typeable, cast)
import Data.Typeable (Typeable, cast)
-- loop: Data.Typeable -> GHC.Err -> GHC.Exception
import GHC.Base
import GHC.Show
......@@ -173,6 +179,9 @@ instance Exception ErrorCall
instance Show ErrorCall where
showsPrec _ (ErrorCall err) = showString err
errorCallException :: String -> SomeException
errorCallException s = toException (ErrorCall s)
-----
-- |Arithmetic exceptions.
......@@ -185,6 +194,11 @@ data ArithException
| RatioZeroDenominator
deriving (Eq, Ord, Typeable)
divZeroException, overflowException, ratioZeroDenomException :: SomeException
divZeroException = toException DivideByZero
overflowException = toException Overflow
ratioZeroDenomException = toException RatioZeroDenominator
instance Exception ArithException
instance Show ArithException where
......@@ -194,5 +208,4 @@ instance Show ArithException where
showsPrec _ DivideByZero = showString "divide by zero"
showsPrec _ Denormal = showString "denormal"
showsPrec _ RatioZeroDenominator = showString "Ratio has zero denominator"
\end{code}
\begin{code}
{-# LANGUAGE Trustworthy #-}
{-# LANGUAGE NoImplicitPrelude #-}
---------------------------------------------------------------------------
-- Ghc.Exception.hs-boot
---------------------------------------------------------------------------
module GHC.Exception ( SomeException, errorCallException,
divZeroException, overflowException, ratioZeroDenomException
) where
import GHC.Types( Char )
-- These exports are nice, well-behaved, non-bottom values
data SomeException
divZeroException, overflowException, ratioZeroDenomException :: SomeException
errorCallException :: [Char] -> SomeException
\end{code}
......@@ -56,7 +56,6 @@ import GHC.Base
import GHC.IORef
import GHC.STRef ( STRef(..) )
import GHC.Ptr ( Ptr(..), FunPtr(..) )
import GHC.Err
#include "Typeable.h"
......
{-# LANGUAGE Unsafe #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE NoImplicitPrelude, DeriveDataTypeable #-}
{-# OPTIONS_GHC -funbox-strict-fields #-}
{-# OPTIONS_HADDOCK hide #-}
......@@ -27,6 +27,7 @@ module GHC.IOArray (
import GHC.Base
import GHC.IO
import GHC.Arr
import Data.Typeable.Internal
-- ---------------------------------------------------------------------------
-- | An 'IOArray' is a mutable, boxed, non-strict array in the 'IO' monad.
......@@ -38,7 +39,7 @@ import GHC.Arr
--
--
newtype IOArray i e = IOArray (STArray RealWorld i e)
newtype IOArray i e = IOArray (STArray RealWorld i e) deriving( Typeable )
-- explicit instance because Haddock can't figure out a derived one
instance Eq (IOArray i e) where
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment