Commit 43ece172 authored by Herbert Valerio Riedel's avatar Herbert Valerio Riedel 🕺

Remove Hugs98 specific code

For rationale. see
 http://permalink.gmane.org/gmane.comp.lang.haskell.ghc.devel/2349Signed-off-by: Herbert Valerio Riedel's avatarHerbert Valerio Riedel <hvr@gnu.org>
parent 907cd8c3
......@@ -138,19 +138,11 @@ import Data.Maybe (Maybe(..))
#endif
#endif
#ifdef __HUGS__
import Hugs.ConcBase
#endif
import Control.Concurrent.MVar
import Control.Concurrent.Chan
import Control.Concurrent.QSem
import Control.Concurrent.QSemN
#ifdef __HUGS__
type ThreadId = ()
#endif
{- $conc_intro
The concurrency extension for Haskell is described in the paper
......@@ -201,8 +193,6 @@ all other Haskell threads in the system, although I\/O operations will
not. With the @-threaded@ option, only foreign calls with the @unsafe@
attribute will block all other threads.
Using Hugs, all I\/O operations and foreign calls will block all other
Haskell threads.
-}
-- | fork a thread and call the supplied function when the thread is about
......
......@@ -141,19 +141,11 @@ module Control.Concurrent.MVar
, modifyMVar
, modifyMVarMasked_
, modifyMVarMasked
#ifndef __HUGS__
, tryReadMVar
, mkWeakMVar
, addMVarFinalizer
#endif
) where
#ifdef __HUGS__
import Hugs.ConcBase ( MVar, newEmptyMVar, newMVar, takeMVar, putMVar,
tryTakeMVar, tryPutMVar, isEmptyMVar,
)
#endif
#ifdef __GLASGOW_HASKELL__
import GHC.MVar ( MVar(..), newEmptyMVar, newMVar, takeMVar, putMVar,
tryTakeMVar, tryPutMVar, isEmptyMVar, readMVar,
......
......@@ -34,11 +34,7 @@
module Control.Exception (
-- * The Exception type
#ifdef __HUGS__
SomeException,
#else
SomeException(..),
#endif
Exception(..), -- class
IOException, -- instance Eq, Ord, Show, Typeable, Exception
ArithException(..), -- instance Eq, Ord, Show, Typeable, Exception
......@@ -48,7 +44,7 @@ module Control.Exception (
AsyncException(..), -- instance Eq, Ord, Show, Typeable, Exception
asyncExceptionToException, asyncExceptionFromException,
#if __GLASGOW_HASKELL__ || __HUGS__
#if __GLASGOW_HASKELL__
NonTermination(..),
NestedAtomically(..),
#endif
......
......@@ -23,11 +23,7 @@
module Control.Exception.Base (
-- * The Exception type
#ifdef __HUGS__
SomeException,
#else
SomeException(..),
#endif
Exception(..),
IOException,
ArithException(..),
......@@ -36,7 +32,7 @@ module Control.Exception.Base (
SomeAsyncException(..), AsyncException(..),
asyncExceptionToException, asyncExceptionFromException,
#if __GLASGOW_HASKELL__ || __HUGS__
#ifdef __GLASGOW_HASKELL__
NonTermination(..),
NestedAtomically(..),
#endif
......@@ -121,117 +117,10 @@ import GHC.Show
import GHC.Conc.Sync
#endif
#ifdef __HUGS__
import Prelude hiding (catch)
import Hugs.Prelude (ExitCode(..))
import Hugs.IOExts (unsafePerformIO)
import Hugs.Exception (SomeException(DynamicException, IOException,
ArithException, ArrayException, ExitException),
evaluate, IOException, ArithException, ArrayException)
import qualified Hugs.Exception
#endif
import Data.Dynamic
import Data.Either
import Data.Maybe
#ifdef __HUGS__
class (Typeable e, Show e) => Exception e where
toException :: e -> SomeException
fromException :: SomeException -> Maybe e
toException e = DynamicException (toDyn e) (flip showsPrec e)
fromException (DynamicException dyn _) = fromDynamic dyn
fromException _ = Nothing
INSTANCE_TYPEABLE0(SomeException,someExceptionTc,"SomeException")
INSTANCE_TYPEABLE0(IOException,iOExceptionTc,"IOException")
INSTANCE_TYPEABLE0(ArithException,arithExceptionTc,"ArithException")
INSTANCE_TYPEABLE0(ArrayException,arrayExceptionTc,"ArrayException")
INSTANCE_TYPEABLE0(ExitCode,exitCodeTc,"ExitCode")
INSTANCE_TYPEABLE0(ErrorCall,errorCallTc,"ErrorCall")
INSTANCE_TYPEABLE0(AssertionFailed,assertionFailedTc,"AssertionFailed")
INSTANCE_TYPEABLE0(AsyncException,asyncExceptionTc,"AsyncException")
INSTANCE_TYPEABLE0(BlockedIndefinitelyOnMVar,blockedIndefinitelyOnMVarTc,"BlockedIndefinitelyOnMVar")
INSTANCE_TYPEABLE0(BlockedIndefinitelyOnSTM,blockedIndefinitelyOnSTM,"BlockedIndefinitelyOnSTM")
INSTANCE_TYPEABLE0(Deadlock,deadlockTc,"Deadlock")
instance Exception SomeException where
toException se = se
fromException = Just
instance Exception IOException where
toException = IOException
fromException (IOException e) = Just e
fromException _ = Nothing
instance Exception ArrayException where
toException = ArrayException
fromException (ArrayException e) = Just e
fromException _ = Nothing
instance Exception ArithException where
toException = ArithException
fromException (ArithException e) = Just e
fromException _ = Nothing
instance Exception ExitCode where
toException = ExitException
fromException (ExitException e) = Just e
fromException _ = Nothing
data ErrorCall = ErrorCall String
instance Show ErrorCall where
showsPrec _ (ErrorCall err) = showString err
instance Exception ErrorCall where
toException (ErrorCall s) = Hugs.Exception.ErrorCall s
fromException (Hugs.Exception.ErrorCall s) = Just (ErrorCall s)
fromException _ = Nothing
data BlockedIndefinitelyOnMVar = BlockedIndefinitelyOnMVar
data BlockedIndefinitelyOnSTM = BlockedIndefinitelyOnSTM
data Deadlock = Deadlock
data AssertionFailed = AssertionFailed String
data AsyncException
= StackOverflow
| HeapOverflow
| ThreadKilled
| UserInterrupt
deriving (Eq, Ord)
instance Show BlockedIndefinitelyOnMVar where
showsPrec _ BlockedIndefinitelyOnMVar = showString "thread blocked indefinitely"
instance Show BlockedIndefinitely where
showsPrec _ BlockedIndefinitely = showString "thread blocked indefinitely"
instance Show Deadlock where
showsPrec _ Deadlock = showString "<<deadlock>>"
instance Show AssertionFailed where
showsPrec _ (AssertionFailed err) = showString err
instance Show AsyncException where
showsPrec _ StackOverflow = showString "stack overflow"
showsPrec _ HeapOverflow = showString "heap overflow"
showsPrec _ ThreadKilled = showString "thread killed"
showsPrec _ UserInterrupt = showString "user interrupt"
instance Exception BlockedOnDeadMVar
instance Exception BlockedIndefinitely
instance Exception Deadlock
instance Exception AssertionFailed
instance Exception AsyncException
throw :: Exception e => e -> a
throw e = Hugs.Exception.throw (toException e)
throwIO :: Exception e => e -> IO a
throwIO e = Hugs.Exception.throwIO (toException e)
#endif
-----------------------------------------------------------------------------
-- Catching exceptions
......@@ -274,11 +163,6 @@ catch :: Exception e
-> IO a
#if __GLASGOW_HASKELL__
catch = catchException
#elif __HUGS__
catch m h = Hugs.Exception.catchException m h'
where h' e = case fromException e of
Just e' -> h e'
Nothing -> throwIO e
#endif
-- | The function 'catchJust' is like 'catch', but it takes an extra
......@@ -433,7 +317,7 @@ assert False _ = throw (AssertionFailed "")
-----
#if __GLASGOW_HASKELL__ || __HUGS__
#if __GLASGOW_HASKELL__
-- |A pattern match failed. The @String@ gives information about the
-- source location of the pattern.
data PatternMatchFail = PatternMatchFail String
......@@ -442,14 +326,7 @@ INSTANCE_TYPEABLE0(PatternMatchFail,patternMatchFailTc,"PatternMatchFail")
instance Show PatternMatchFail where
showsPrec _ (PatternMatchFail err) = showString err
#ifdef __HUGS__
instance Exception PatternMatchFail where
toException (PatternMatchFail err) = Hugs.Exception.PatternMatchFail err
fromException (Hugs.Exception.PatternMatchFail err) = Just (PatternMatchFail err)
fromException _ = Nothing
#else
instance Exception PatternMatchFail
#endif
-----
......@@ -464,14 +341,7 @@ INSTANCE_TYPEABLE0(RecSelError,recSelErrorTc,"RecSelError")
instance Show RecSelError where
showsPrec _ (RecSelError err) = showString err
#ifdef __HUGS__
instance Exception RecSelError where
toException (RecSelError err) = Hugs.Exception.RecSelError err
fromException (Hugs.Exception.RecSelError err) = Just (RecSelError err)
fromException _ = Nothing
#else
instance Exception RecSelError
#endif
-----
......@@ -484,14 +354,7 @@ INSTANCE_TYPEABLE0(RecConError,recConErrorTc,"RecConError")
instance Show RecConError where
showsPrec _ (RecConError err) = showString err
#ifdef __HUGS__
instance Exception RecConError where
toException (RecConError err) = Hugs.Exception.RecConError err
fromException (Hugs.Exception.RecConError err) = Just (RecConError err)
fromException _ = Nothing
#else
instance Exception RecConError
#endif
-----
......@@ -506,14 +369,7 @@ INSTANCE_TYPEABLE0(RecUpdError,recUpdErrorTc,"RecUpdError")
instance Show RecUpdError where
showsPrec _ (RecUpdError err) = showString err
#ifdef __HUGS__
instance Exception RecUpdError where
toException (RecUpdError err) = Hugs.Exception.RecUpdError err
fromException (Hugs.Exception.RecUpdError err) = Just (RecUpdError err)
fromException _ = Nothing
#else
instance Exception RecUpdError
#endif
-----
......@@ -526,14 +382,7 @@ INSTANCE_TYPEABLE0(NoMethodError,noMethodErrorTc,"NoMethodError")
instance Show NoMethodError where
showsPrec _ (NoMethodError err) = showString err
#ifdef __HUGS__
instance Exception NoMethodError where
toException (NoMethodError err) = Hugs.Exception.NoMethodError err
fromException (Hugs.Exception.NoMethodError err) = Just (NoMethodError err)
fromException _ = Nothing
#else
instance Exception NoMethodError
#endif
-----
......@@ -547,14 +396,7 @@ INSTANCE_TYPEABLE0(NonTermination,nonTerminationTc,"NonTermination")
instance Show NonTermination where
showsPrec _ NonTermination = showString "<<loop>>"
#ifdef __HUGS__
instance Exception NonTermination where
toException NonTermination = Hugs.Exception.NonTermination
fromException Hugs.Exception.NonTermination = Just NonTermination
fromException _ = Nothing
#else
instance Exception NonTermination
#endif
-----
......@@ -570,7 +412,7 @@ instance Exception NestedAtomically
-----
#endif /* __GLASGOW_HASKELL__ || __HUGS__ */
#endif /* __GLASGOW_HASKELL__ */
#ifdef __GLASGOW_HASKELL__
recSelError, recConError, irrefutPatError, runtimeError,
......
......@@ -26,14 +26,10 @@ module Control.Monad.Fix (
import Prelude
import System.IO
import Data.Function (fix)
#ifdef __HUGS__
import Hugs.Prelude (MonadFix(mfix))
#endif
#if defined(__GLASGOW_HASKELL__)
import GHC.ST
#endif
#ifndef __HUGS__
-- | Monads having fixed points with a \'knot-tying\' semantics.
-- Instances of 'MonadFix' should satisfy the following laws:
--
......@@ -58,7 +54,6 @@ class (Monad m) => MonadFix m where
-- output fed back as the input. Hence @f@ should not be strict,
-- for then @'mfix' f@ would diverge.
mfix :: (a -> m a) -> m a
#endif /* !__HUGS__ */
-- Instances of MonadFix for Prelude monads
......
......@@ -45,22 +45,6 @@ import Control.Monad.Fix
import GHC.ST ( ST, runST, fixST, unsafeInterleaveST )
import GHC.Base ( RealWorld )
import GHC.IO ( stToIO, unsafeIOToST, unsafeSTToIO )
#elif defined(__HUGS__)
import Data.Typeable
import Hugs.ST
import qualified Hugs.LazyST as LazyST
#endif
#if defined(__HUGS__)
INSTANCE_TYPEABLE2(ST,sTTc,"ST")
INSTANCE_TYPEABLE0(RealWorld,realWorldTc,"RealWorld")
fixST :: (a -> ST s a) -> ST s a
fixST f = LazyST.lazyToStrictST (LazyST.fixST (LazyST.strictToLazyST . f))
unsafeInterleaveST :: ST s a -> ST s a
unsafeInterleaveST =
LazyST.lazyToStrictST . LazyST.unsafeInterleaveST . LazyST.strictToLazyST
#endif
#if !defined(__GLASGOW_HASKELL__)
......
......@@ -49,10 +49,6 @@ import qualified GHC.ST as GHC.ST
import GHC.Base
#endif
#ifdef __HUGS__
import Hugs.LazyST
#endif
#ifdef __GLASGOW_HASKELL__
-- | The lazy state-transformer monad.
-- A computation of type @'ST' s a@ transforms an internal state indexed
......
......@@ -49,7 +49,7 @@ module Data.Bits (
-- See library document for details on the semantics of the
-- individual operations.
#if defined(__GLASGOW_HASKELL__) || defined(__HUGS__)
#ifdef __GLASGOW_HASKELL__
#include "MachDeps.h"
#endif
......@@ -60,10 +60,6 @@ import GHC.Num
import GHC.Base
#endif
#ifdef __HUGS__
import Hugs.Bits
#endif
infixl 8 `shift`, `rotate`, `shiftL`, `shiftR`, `rotateL`, `rotateR`
infixl 7 .&.
infixl 6 `xor`
......@@ -322,17 +318,6 @@ instance Bits Int where
popCount = popCountDefault
#ifdef __HUGS__
(.&.) = primAndInt
(.|.) = primOrInt
xor = primXorInt
complement = primComplementInt
shift = primShiftInt
bit = primBitInt
testBit = primTestInt
bitSize _ = SIZEOF_HSINT*8
#endif
x `rotate` i
| i<0 && x<0 = let left = i+bitSize x in
((x `shift` i) .&. complement ((-1) `shift` left))
......
......@@ -64,11 +64,6 @@ import GHC.Num
import GHC.Enum
#endif
#ifdef __HUGS__
import Hugs.Prelude (Ix)
import Hugs.Char
#endif
-- | Convert a single digit 'Char' to the corresponding 'Int'.
-- This function fails unless its argument satisfies 'isHexDigit',
-- but recognises both upper and lower-case hexadecimal digits
......@@ -127,9 +122,6 @@ generalCategory :: Char -> GeneralCategory
#if defined(__GLASGOW_HASKELL__)
generalCategory c = toEnum $ fromIntegral $ wgencat $ fromIntegral $ ord c
#endif
#ifdef __HUGS__
generalCategory c = toEnum (primUniGenCat c)
#endif
-- derived character classifiers
......
......@@ -43,10 +43,6 @@ import Data.Typeable
import Data.Data (Data)
#endif
#ifdef __HUGS__
import Hugs.Prelude(Num(fromInt), Fractional(fromDouble))
#endif
infix 6 :+
-- -----------------------------------------------------------------------------
......@@ -135,9 +131,6 @@ instance (RealFloat a) => Num (Complex a) where
signum (0:+0) = 0
signum z@(x:+y) = x/r :+ y/r where r = magnitude z
fromInteger n = fromInteger n :+ 0
#ifdef __HUGS__
fromInt n = fromInt n :+ 0
#endif
instance (RealFloat a) => Fractional (Complex a) where
{-# SPECIALISE instance Fractional (Complex Float) #-}
......@@ -149,9 +142,6 @@ instance (RealFloat a) => Fractional (Complex a) where
d = x'*x'' + y'*y''
fromRational a = fromRational a :+ 0
#ifdef __HUGS__
fromDouble a = fromDouble a :+ 0
#endif
instance (RealFloat a) => Floating (Complex a) where
{-# SPECIALISE instance Floating (Complex Float) #-}
......
......@@ -126,9 +126,6 @@ import GHC.ForeignPtr -- So we can give Data instance for ForeignPtr
--import GHC.Conc -- So we can give Data instance for MVar & Co.
import GHC.Arr -- So we can give Data instance for Array
#else
# ifdef __HUGS__
import Hugs.Prelude( Ratio(..) )
# endif
import Foreign.Ptr
import Foreign.ForeignPtr
import Data.Array
......
......@@ -55,13 +55,6 @@ import GHC.Show
import GHC.Exception
#endif
#ifdef __HUGS__
import Hugs.Prelude
import Hugs.IO
import Hugs.IORef
import Hugs.IOExts
#endif
#include "Typeable.h"
-------------------------------------------------------------
......@@ -80,9 +73,7 @@ import Hugs.IOExts
'Show'ing a value of type 'Dynamic' returns a pretty-printed representation
of the object\'s type; useful for debugging.
-}
#ifndef __HUGS__
data Dynamic = Dynamic TypeRep Obj
#endif
INSTANCE_TYPEABLE0(Dynamic,dynamicTc,"Dynamic")
......@@ -107,7 +98,7 @@ type Obj = Any
-- when evaluating it, and this will go wrong if the object is really a
-- function. Using Any forces GHC to use
-- a fallback convention for evaluating it that works for all types.
#elif !defined(__HUGS__)
#else
data Obj = Obj
#endif
......
......@@ -71,12 +71,7 @@ import Data.Proxy
#ifdef __GLASGOW_HASKELL__
import GHC.Exts (build)
#endif
#if defined(__GLASGOW_HASKELL__)
import GHC.Arr
#elif defined(__HUGS__)
import Hugs.Array
#endif
-- | Data structures that can be folded.
......
......@@ -37,10 +37,6 @@ module Data.IORef
) where
#ifdef __HUGS__
import Hugs.IORef
#endif
#ifdef __GLASGOW_HASKELL__
import GHC.Base
import GHC.STRef
......@@ -102,14 +98,8 @@ modifyIORef' ref f = do
-- Use 'atomicModifyIORef'' or 'atomicWriteIORef' to avoid this problem.
--
atomicModifyIORef :: IORef a -> (a -> (a,b)) -> IO b
#if defined(__GLASGOW_HASKELL__)
#ifdef __GLASGOW_HASKELL__
atomicModifyIORef = GHC.IORef.atomicModifyIORef
#elif defined(__HUGS__)
atomicModifyIORef = plainModifyIORef -- Hugs has no preemption
where plainModifyIORef r f = do
a <- readIORef r
case f a of (a',b) -> writeIORef r a' >> return b
#endif
-- | Strict version of 'atomicModifyIORef'. This forces both the value stored
......
......@@ -31,10 +31,6 @@ import GHC.Base ( Int )
import GHC.Int ( Int8, Int16, Int32, Int64 )
#endif
#ifdef __HUGS__
import Hugs.Int ( Int8, Int16, Int32, Int64 )
#endif
{- $notes
* All arithmetic is performed modulo 2^n, where @n@ is the number of
......
......@@ -67,8 +67,3 @@ module Data.Ix
#ifdef __GLASGOW_HASKELL__
import GHC.Arr
#endif
#ifdef __HUGS__
import Hugs.Prelude( Ix(..) )
#endif
......@@ -35,7 +35,6 @@ module Data.Maybe
import GHC.Base
#endif
#ifndef __HUGS__
-- ---------------------------------------------------------------------------
-- The Maybe type, and instances
......@@ -76,7 +75,6 @@ instance Monad Maybe where
maybe :: b -> (a -> b) -> Maybe a -> b
maybe n _ Nothing = n
maybe _ f (Just x) = f x
#endif /* __HUGS__ */
-- | The 'isJust' function returns 'True' iff its argument is of the
-- form @Just _@.
......
......@@ -103,17 +103,6 @@ import GHC.Fingerprint
#endif
#ifdef __HUGS__