Commit 25d1eafe authored by ian@well-typed.com's avatar ian@well-typed.com

Remove nhc98-specific files and content

parent ab1d58b7
...@@ -50,21 +50,12 @@ import Prelude hiding (id,(.)) ...@@ -50,21 +50,12 @@ import Prelude hiding (id,(.))
import Control.Category import Control.Category
import Control.Arrow import Control.Arrow
import Control.Monad (liftM, ap, MonadPlus(..)) import Control.Monad (liftM, ap, MonadPlus(..))
#ifndef __NHC__
import Control.Monad.ST.Safe (ST) import Control.Monad.ST.Safe (ST)
import qualified Control.Monad.ST.Lazy.Safe as Lazy (ST) import qualified Control.Monad.ST.Lazy.Safe as Lazy (ST)
#endif
import Data.Functor ((<$>), (<$)) import Data.Functor ((<$>), (<$))
import Data.Monoid (Monoid(..)) import Data.Monoid (Monoid(..))
import Text.ParserCombinators.ReadP import Text.ParserCombinators.ReadP (ReadP)
#ifndef __NHC__
(ReadP)
#else
(ReadPN)
#define ReadP (ReadPN b)
#endif
import Text.ParserCombinators.ReadPrec (ReadPrec) import Text.ParserCombinators.ReadPrec (ReadPrec)
#ifdef __GLASGOW_HASKELL__ #ifdef __GLASGOW_HASKELL__
...@@ -181,7 +172,6 @@ instance Applicative IO where ...@@ -181,7 +172,6 @@ instance Applicative IO where
pure = return pure = return
(<*>) = ap (<*>) = ap
#ifndef __NHC__
instance Applicative (ST s) where instance Applicative (ST s) where
pure = return pure = return
(<*>) = ap (<*>) = ap
...@@ -189,7 +179,6 @@ instance Applicative (ST s) where ...@@ -189,7 +179,6 @@ instance Applicative (ST s) where
instance Applicative (Lazy.ST s) where instance Applicative (Lazy.ST s) where
pure = return pure = return
(<*>) = ap (<*>) = ap
#endif
#ifdef __GLASGOW_HASKELL__ #ifdef __GLASGOW_HASKELL__
instance Applicative STM where instance Applicative STM where
......
...@@ -52,9 +52,6 @@ module Control.Exception ( ...@@ -52,9 +52,6 @@ module Control.Exception (
NonTermination(..), NonTermination(..),
NestedAtomically(..), NestedAtomically(..),
#endif #endif
#ifdef __NHC__
System.ExitCode(), -- instance Exception
#endif
BlockedIndefinitelyOnMVar(..), BlockedIndefinitelyOnMVar(..),
BlockedIndefinitelyOnSTM(..), BlockedIndefinitelyOnSTM(..),
...@@ -111,14 +108,12 @@ module Control.Exception ( ...@@ -111,14 +108,12 @@ module Control.Exception (
-- asynchronous exceptions during a critical region. -- asynchronous exceptions during a critical region.
mask, mask,
#ifndef __NHC__
mask_, mask_,
uninterruptibleMask, uninterruptibleMask,
uninterruptibleMask_, uninterruptibleMask_,
MaskingState(..), MaskingState(..),
getMaskingState, getMaskingState,
allowInterrupt, allowInterrupt,
#endif
-- ** (deprecated) Asynchronous exception control -- ** (deprecated) Asynchronous exception control
...@@ -159,10 +154,6 @@ import Data.Maybe ...@@ -159,10 +154,6 @@ import Data.Maybe
import Prelude hiding (catch) import Prelude hiding (catch)
#endif #endif
#ifdef __NHC__
import System (ExitCode())
#endif
-- | You need this when using 'catches'. -- | You need this when using 'catches'.
data Handler a = forall e . Exception e => Handler (e -> IO a) data Handler a = forall e . Exception e => Handler (e -> IO a)
......
...@@ -84,13 +84,11 @@ module Control.Exception.Base ( ...@@ -84,13 +84,11 @@ module Control.Exception.Base (
-- ** Asynchronous exception control -- ** Asynchronous exception control
mask, mask,
#ifndef __NHC__
mask_, mask_,
uninterruptibleMask, uninterruptibleMask,
uninterruptibleMask_, uninterruptibleMask_,
MaskingState(..), MaskingState(..),
getMaskingState, getMaskingState,
#endif
-- ** (deprecated) Asynchronous exception control -- ** (deprecated) Asynchronous exception control
...@@ -143,99 +141,6 @@ import Data.Dynamic ...@@ -143,99 +141,6 @@ import Data.Dynamic
import Data.Either import Data.Either
import Data.Maybe import Data.Maybe
#ifdef __NHC__
import qualified IO as H'98 (catch)
import IO (bracket,ioError)
import DIOError -- defn of IOError type
import System (ExitCode())
import System.IO.Unsafe (unsafePerformIO)
import Unsafe.Coerce (unsafeCoerce)
-- minimum needed for nhc98 to pretend it has Exceptions
{-
data Exception = IOException IOException
| ArithException ArithException
| ArrayException ArrayException
| AsyncException AsyncException
| ExitException ExitCode
deriving Show
-}
class ({-Typeable e,-} Show e) => Exception e where
toException :: e -> SomeException
fromException :: SomeException -> Maybe e
data SomeException = forall e . Exception e => SomeException e
INSTANCE_TYPEABLE0(SomeException,someExceptionTc,"SomeException")
instance Show SomeException where
showsPrec p (SomeException e) = showsPrec p e
instance Exception SomeException where
toException se = se
fromException = Just
type IOException = IOError
instance Exception IOError where
toException = SomeException
fromException (SomeException e) = Just (unsafeCoerce e)
instance Exception ExitCode where
toException = SomeException
fromException (SomeException e) = Just (unsafeCoerce e)
data ArithException
data ArrayException
data AsyncException
data AssertionFailed
data PatternMatchFail
data NoMethodError
data Deadlock
data BlockedIndefinitelyOnMVar
data BlockedIndefinitelyOnSTM
data ErrorCall
data RecConError
data RecSelError
data RecUpdError
instance Show ArithException
instance Show ArrayException
instance Show AsyncException
instance Show AssertionFailed
instance Show PatternMatchFail
instance Show NoMethodError
instance Show Deadlock
instance Show BlockedIndefinitelyOnMVar
instance Show BlockedIndefinitelyOnSTM
instance Show ErrorCall
instance Show RecConError
instance Show RecSelError
instance Show RecUpdError
catch :: Exception e
=> IO a -- ^ The computation to run
-> (e -> IO a) -- ^ Handler to invoke if an exception is raised
-> IO a
catch io h = H'98.catch io (h . fromJust . fromException . toException)
throwIO :: Exception e => e -> IO a
throwIO = ioError . fromJust . fromException . toException
throw :: Exception e => e -> a
throw = unsafePerformIO . throwIO
evaluate :: a -> IO a
evaluate x = x `seq` return x
assert :: Bool -> a -> a
assert True x = x
assert False _ = throw (toException (UserError "" "Assertion failed"))
mask :: ((IO a-> IO a) -> IO a) -> IO a
mask action = action restore
where restore act = act
#endif
#ifdef __HUGS__ #ifdef __HUGS__
class (Typeable e, Show e) => Exception e where class (Typeable e, Show e) => Exception e where
toException :: e -> SomeException toException :: e -> SomeException
...@@ -380,7 +285,6 @@ blocked = return False ...@@ -380,7 +285,6 @@ blocked = return False
-- might get a the opposite behaviour. This is ok, because 'catch' is an -- might get a the opposite behaviour. This is ok, because 'catch' is an
-- 'IO' computation. -- 'IO' computation.
-- --
#ifndef __NHC__
catch :: Exception e catch :: Exception e
=> IO a -- ^ The computation to run => IO a -- ^ The computation to run
-> (e -> IO a) -- ^ Handler to invoke if an exception is raised -> (e -> IO a) -- ^ Handler to invoke if an exception is raised
...@@ -393,7 +297,6 @@ catch m h = Hugs.Exception.catchException m h' ...@@ -393,7 +297,6 @@ catch m h = Hugs.Exception.catchException m h'
Just e' -> h e' Just e' -> h e'
Nothing -> throwIO e Nothing -> throwIO e
#endif #endif
#endif
-- | The function 'catchJust' is like 'catch', but it takes an extra -- | The function 'catchJust' is like 'catch', but it takes an extra
-- argument which is an /exception predicate/, a function which -- argument which is an /exception predicate/, a function which
...@@ -497,7 +400,6 @@ onException io what = io `catch` \e -> do _ <- what ...@@ -497,7 +400,6 @@ onException io what = io `catch` \e -> do _ <- what
-- --
-- > withFile name mode = bracket (openFile name mode) hClose -- > withFile name mode = bracket (openFile name mode) hClose
-- --
#ifndef __NHC__
bracket bracket
:: IO a -- ^ computation to run first (\"acquire resource\") :: IO a -- ^ computation to run first (\"acquire resource\")
-> (a -> IO b) -- ^ computation to run last (\"release resource\") -> (a -> IO b) -- ^ computation to run last (\"release resource\")
...@@ -509,7 +411,6 @@ bracket before after thing = ...@@ -509,7 +411,6 @@ bracket before after thing =
r <- restore (thing a) `onException` after a r <- restore (thing a) `onException` after a
_ <- after a _ <- after a
return r return r
#endif
-- | A specialised variant of 'bracket' with just a computation to run -- | A specialised variant of 'bracket' with just a computation to run
-- afterward. -- afterward.
...@@ -541,7 +442,7 @@ bracketOnError before after thing = ...@@ -541,7 +442,7 @@ bracketOnError before after thing =
a <- before a <- before
restore (thing a) `onException` after a restore (thing a) `onException` after a
#if !(__GLASGOW_HASKELL__ || __NHC__) #if !__GLASGOW_HASKELL__
assert :: Bool -> a -> a assert :: Bool -> a -> a
assert True x = x assert True x = x
assert False _ = throw (AssertionFailed "") assert False _ = throw (AssertionFailed "")
......
{-# LANGUAGE Safe #-} {-# LANGUAGE Safe #-}
{-# OPTIONS_NHC98 --prelude #-}
----------------------------------------------------------------------------- -----------------------------------------------------------------------------
-- | -- |
......
...@@ -331,17 +331,7 @@ instance Bits Int where ...@@ -331,17 +331,7 @@ instance Bits Int where
bit = primBitInt bit = primBitInt
testBit = primTestInt testBit = primTestInt
bitSize _ = SIZEOF_HSINT*8 bitSize _ = SIZEOF_HSINT*8
#elif defined(__NHC__) #endif
(.&.) = nhc_primIntAnd
(.|.) = nhc_primIntOr
xor = nhc_primIntXor
complement = nhc_primIntCompl
shiftL = nhc_primIntLsh
shiftR = nhc_primIntRsh
bit = bitDefault
testBit = testBitDefault
bitSize _ = 32
#endif /* __NHC__ */
x `rotate` i x `rotate` i
| i<0 && x<0 = let left = i+bitSize x in | i<0 && x<0 = let left = i+bitSize x in
...@@ -358,15 +348,6 @@ instance Bits Int where ...@@ -358,15 +348,6 @@ instance Bits Int where
instance FiniteBits Int where instance FiniteBits Int where
finiteBitSize _ = WORD_SIZE_IN_BITS finiteBitSize _ = WORD_SIZE_IN_BITS
#ifdef __NHC__
foreign import ccall nhc_primIntAnd :: Int -> Int -> Int
foreign import ccall nhc_primIntOr :: Int -> Int -> Int
foreign import ccall nhc_primIntXor :: Int -> Int -> Int
foreign import ccall nhc_primIntLsh :: Int -> Int -> Int
foreign import ccall nhc_primIntRsh :: Int -> Int -> Int
foreign import ccall nhc_primIntCompl :: Int -> Int
#endif /* __NHC__ */
#if defined(__GLASGOW_HASKELL__) #if defined(__GLASGOW_HASKELL__)
instance Bits Word where instance Bits Word where
{-# INLINE shift #-} {-# INLINE shift #-}
......
...@@ -29,14 +29,3 @@ module Data.Bool ( ...@@ -29,14 +29,3 @@ module Data.Bool (
import GHC.Base import GHC.Base
#endif #endif
#ifdef __NHC__
import Prelude
import Prelude
( Bool(..)
, (&&)
, (||)
, not
, otherwise
)
#endif
...@@ -69,15 +69,6 @@ import Hugs.Prelude (Ix) ...@@ -69,15 +69,6 @@ import Hugs.Prelude (Ix)
import Hugs.Char import Hugs.Char
#endif #endif
#ifdef __NHC__
import Prelude
import Prelude(Char,String)
import Char
import Ix
import NHC.FFI (CInt)
foreign import ccall unsafe "WCsubst.h u_gencat" wgencat :: CInt -> CInt
#endif
-- | Convert a single digit 'Char' to the corresponding 'Int'. -- | Convert a single digit 'Char' to the corresponding 'Int'.
-- This function fails unless its argument satisfies 'isHexDigit', -- This function fails unless its argument satisfies 'isHexDigit',
-- but recognises both upper and lower-case hexadecimal digits -- but recognises both upper and lower-case hexadecimal digits
...@@ -133,7 +124,7 @@ data GeneralCategory ...@@ -133,7 +124,7 @@ data GeneralCategory
-- | The Unicode general category of the character. -- | The Unicode general category of the character.
generalCategory :: Char -> GeneralCategory generalCategory :: Char -> GeneralCategory
#if defined(__GLASGOW_HASKELL__) || defined(__NHC__) #if defined(__GLASGOW_HASKELL__)
generalCategory c = toEnum $ fromIntegral $ wgencat $ fromIntegral $ ord c generalCategory c = toEnum $ fromIntegral $ wgencat $ fromIntegral $ ord c
#endif #endif
#ifdef __HUGS__ #ifdef __HUGS__
...@@ -203,9 +194,3 @@ isSeparator c = case generalCategory c of ...@@ -203,9 +194,3 @@ isSeparator c = case generalCategory c of
ParagraphSeparator -> True ParagraphSeparator -> True
_ -> False _ -> False
#ifdef __NHC__
-- dummy implementation
toTitle :: Char -> Char
toTitle = toUpper
#endif
...@@ -62,10 +62,6 @@ import Hugs.IORef ...@@ -62,10 +62,6 @@ import Hugs.IORef
import Hugs.IOExts import Hugs.IOExts
#endif #endif
#ifdef __NHC__
import NHC.IOExtras (IORef,newIORef,readIORef,writeIORef,unsafePerformIO)
#endif
#include "Typeable.h" #include "Typeable.h"
------------------------------------------------------------- -------------------------------------------------------------
......
{-# LANGUAGE Trustworthy #-} {-# LANGUAGE Trustworthy #-}
{-# LANGUAGE CPP, ScopedTypeVariables, PatternGuards #-} {-# LANGUAGE CPP, ScopedTypeVariables, PatternGuards #-}
{-# OPTIONS -Wall -fno-warn-unused-binds #-} {-# OPTIONS -Wall -fno-warn-unused-binds #-}
#ifndef __NHC__
{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveDataTypeable #-}
#endif
----------------------------------------------------------------------------- -----------------------------------------------------------------------------
-- | -- |
...@@ -40,17 +38,13 @@ module Data.Fixed ...@@ -40,17 +38,13 @@ module Data.Fixed
) where ) where
import Prelude -- necessary to get dependencies right import Prelude -- necessary to get dependencies right
#ifndef __NHC__
import Data.Typeable import Data.Typeable
import Data.Data import Data.Data
#endif
import GHC.Read import GHC.Read
import Text.ParserCombinators.ReadPrec import Text.ParserCombinators.ReadPrec
import Text.Read.Lex import Text.Read.Lex
#ifndef __NHC__
default () -- avoid any defaulting shenanigans default () -- avoid any defaulting shenanigans
#endif
-- | generalisation of 'div' to any instance of Real -- | generalisation of 'div' to any instance of Real
div' :: (Real a,Integral b) => a -> a -> b div' :: (Real a,Integral b) => a -> a -> b
...@@ -68,13 +62,8 @@ mod' n d = n - (fromInteger f) * d where ...@@ -68,13 +62,8 @@ mod' n d = n - (fromInteger f) * d where
-- | The type parameter should be an instance of 'HasResolution'. -- | The type parameter should be an instance of 'HasResolution'.
newtype Fixed a = MkFixed Integer newtype Fixed a = MkFixed Integer
#ifndef __NHC__
deriving (Eq,Ord,Typeable) deriving (Eq,Ord,Typeable)
#else
deriving (Eq,Ord)
#endif
#ifndef __NHC__
-- We do this because the automatically derived Data instance requires (Data a) context. -- We do this because the automatically derived Data instance requires (Data a) context.
-- Our manual instance has the more general (Typeable a) context. -- Our manual instance has the more general (Typeable a) context.
tyFixed :: DataType tyFixed :: DataType
...@@ -86,7 +75,6 @@ instance (Typeable a) => Data (Fixed a) where ...@@ -86,7 +75,6 @@ instance (Typeable a) => Data (Fixed a) where
gunfold k z _ = k (z MkFixed) gunfold k z _ = k (z MkFixed)
dataTypeOf _ = tyFixed dataTypeOf _ = tyFixed
toConstr _ = conMkFixed toConstr _ = conMkFixed
#endif
class HasResolution a where class HasResolution a where
resolution :: p a -> Integer resolution :: p a -> Integer
...@@ -176,63 +164,49 @@ convertFixed (Number n) ...@@ -176,63 +164,49 @@ convertFixed (Number n)
convertFixed _ = pfail convertFixed _ = pfail
data E0 = E0 data E0 = E0
#ifndef __NHC__
deriving (Typeable) deriving (Typeable)
#endif
instance HasResolution E0 where instance HasResolution E0 where
resolution _ = 1 resolution _ = 1
-- | resolution of 1, this works the same as Integer -- | resolution of 1, this works the same as Integer
type Uni = Fixed E0 type Uni = Fixed E0
data E1 = E1 data E1 = E1
#ifndef __NHC__
deriving (Typeable) deriving (Typeable)
#endif
instance HasResolution E1 where instance HasResolution E1 where
resolution _ = 10 resolution _ = 10
-- | resolution of 10^-1 = .1 -- | resolution of 10^-1 = .1
type Deci = Fixed E1 type Deci = Fixed E1
data E2 = E2 data E2 = E2
#ifndef __NHC__
deriving (Typeable) deriving (Typeable)
#endif
instance HasResolution E2 where instance HasResolution E2 where
resolution _ = 100 resolution _ = 100
-- | resolution of 10^-2 = .01, useful for many monetary currencies -- | resolution of 10^-2 = .01, useful for many monetary currencies
type Centi = Fixed E2 type Centi = Fixed E2
data E3 = E3 data E3 = E3
#ifndef __NHC__
deriving (Typeable) deriving (Typeable)
#endif
instance HasResolution E3 where instance HasResolution E3 where
resolution _ = 1000 resolution _ = 1000
-- | resolution of 10^-3 = .001 -- | resolution of 10^-3 = .001
type Milli = Fixed E3 type Milli = Fixed E3
data E6 = E6 data E6 = E6
#ifndef __NHC__
deriving (Typeable) deriving (Typeable)
#endif
instance HasResolution E6 where instance HasResolution E6 where
resolution _ = 1000000 resolution _ = 1000000
-- | resolution of 10^-6 = .000001 -- | resolution of 10^-6 = .000001
type Micro = Fixed E6 type Micro = Fixed E6
data E9 = E9 data E9 = E9
#ifndef __NHC__
deriving (Typeable) deriving (Typeable)
#endif
instance HasResolution E9 where instance HasResolution E9 where
resolution _ = 1000000000 resolution _ = 1000000000
-- | resolution of 10^-9 = .000000001 -- | resolution of 10^-9 = .000000001
type Nano = Fixed E9 type Nano = Fixed E9