Commit 588c08d7 authored by Iavor S. Diatchki's avatar Iavor S. Diatchki
Browse files

Merge branch 'master' into type-nats

parents 30c0c022 5c1c24f8
......@@ -40,10 +40,7 @@ class Category cat where
instance Category (->) where
id = Prelude.id
#ifndef __HADDOCK__
-- Haddock 1.x cannot parse this:
(.) = (Prelude..)
#endif
-- | Right-to-left composition
(<<<) :: Category cat => cat b c -> cat a b -> cat a c
......
......@@ -40,6 +40,7 @@ import Prelude
import System.IO.Unsafe ( unsafeInterleaveIO )
import Control.Concurrent.MVar
import Control.Exception (mask_)
import Data.Typeable
#include "Typeable.h"
......@@ -51,7 +52,7 @@ import Data.Typeable
-- |'Chan' is an abstract type representing an unbounded FIFO channel.
data Chan a
= Chan (MVar (Stream a))
(MVar (Stream a))
(MVar (Stream a)) -- Invariant: the Stream a is always an empty MVar
deriving Eq
INSTANCE_TYPEABLE1(Chan,chanTc,"Chan")
......@@ -83,9 +84,20 @@ newChan = do
writeChan :: Chan a -> a -> IO ()
writeChan (Chan _ writeVar) val = do
new_hole <- newEmptyMVar
modifyMVar_ writeVar $ \old_hole -> do
mask_ $ do
old_hole <- takeMVar writeVar
putMVar old_hole (ChItem val new_hole)
return new_hole
putMVar writeVar new_hole
-- The reason we don't simply do this:
--
-- modifyMVar_ writeVar $ \old_hole -> do
-- putMVar old_hole (ChItem val new_hole)
-- return new_hole
--
-- is because if an asynchronous exception is received after the 'putMVar'
-- completes and before modifyMVar_ installs the new value, it will set the
-- Chan's write end to a filled hole.
-- |Read the next value from the 'Chan'.
readChan :: Chan a -> IO a
......
......@@ -35,9 +35,7 @@ module Control.Monad.ST.Imp (
unsafeSTToIO -- :: ST s a -> IO a
) where
#if defined(__GLASGOW_HASKELL__)
import Control.Monad.Fix ()
#else
#if !defined(__GLASGOW_HASKELL__)
import Control.Monad.Fix
#endif
......
This diff is collapsed.
......@@ -75,7 +75,9 @@ The 'Bits' class defines bitwise operations over integral types.
Minimal complete definition: '.&.', '.|.', 'xor', 'complement',
('shift' or ('shiftL' and 'shiftR')), ('rotate' or ('rotateL' and 'rotateR')),
'bitSize' and 'isSigned'.
'bitSize', 'isSigned', 'testBit', 'bit', and 'popCount'. The latter three can
be implemented using `testBitDefault', 'bitDefault, and 'popCountDefault', if
@a@ is also an instance of 'Num'.
-}
class Eq a => Bits a where
-- | Bitwise \"and\"
......@@ -257,7 +259,8 @@ popCountDefault :: (Bits a, Num a) => a -> Int
popCountDefault = go 0
where
go !c 0 = c
go c w = go (c+1) (w .&. w - 1) -- clear the least significant
go c w = go (c+1) (w .&. (w - 1)) -- clear the least significant
{-# INLINABLE popCountDefault #-}
instance Bits Int where
{-# INLINE shift #-}
......
......@@ -55,6 +55,7 @@ module Data.Char
#ifdef __GLASGOW_HASKELL__
import GHC.Base
import GHC.Arr (Ix)
import GHC.Char
import GHC.Real (fromIntegral)
import GHC.Show
import GHC.Read (Read, readLitChar, lexLitChar)
......
......@@ -235,14 +235,7 @@ instance Monoid a => Monoid (Maybe a) where
-- | Maybe monoid returning the leftmost non-Nothing value.
newtype First a = First { getFirst :: Maybe a }
#ifndef __HADDOCK__
deriving (Eq, Ord, Read, Show)
#else /* __HADDOCK__ */
instance Eq a => Eq (First a)
instance Ord a => Ord (First a)
instance Read a => Read (First a)
instance Show a => Show (First a)
#endif
instance Monoid (First a) where
mempty = First Nothing
......@@ -251,14 +244,7 @@ instance Monoid (First a) where
-- | Maybe monoid returning the rightmost non-Nothing value.
newtype Last a = Last { getLast :: Maybe a }
#ifndef __HADDOCK__
deriving (Eq, Ord, Read, Show)
#else /* __HADDOCK__ */
instance Eq a => Eq (Last a)
instance Ord a => Ord (Last a)
instance Read a => Read (Last a)
instance Show a => Show (Last a)
#endif
instance Monoid (Last a) where
mempty = Last Nothing
......
......@@ -110,6 +110,7 @@ import Data.Word
#ifdef __GLASGOW_HASKELL__
import Control.Monad
import GHC.Char
import GHC.List
import GHC.Real
import GHC.Num
......
......@@ -47,7 +47,6 @@ import Control.Monad ( liftM )
#ifdef __GLASGOW_HASKELL__
import GHC.Storable
import GHC.Stable ( StablePtr )
import GHC.IO() -- Instance Monad IO
import GHC.Num
import GHC.Int
import GHC.Word
......
......@@ -109,7 +109,6 @@ import GHC.Types
import GHC.Classes
import GHC.CString
import GHC.Prim
import {-# SOURCE #-} GHC.Show
import {-# SOURCE #-} GHC.Err
import {-# SOURCE #-} GHC.IO (failIO)
......@@ -458,13 +457,6 @@ type String = [Char]
"x# `ltChar#` x#" forall x#. x# `ltChar#` x# = False
#-}
-- | The 'Prelude.toEnum' method restricted to the type 'Data.Char.Char'.
chr :: Int -> Char
chr i@(I# i#)
| int2Word# i# `leWord#` int2Word# 0x10FFFF# = C# (chr# i#)
| otherwise
= error ("Prelude.chr: bad argument: " ++ showSignedInt (I# 9#) i "")
unsafeChr :: Int -> Char
unsafeChr (I# i#) = C# (chr# i#)
......@@ -707,6 +699,23 @@ plusInt, minusInt, timesInt, quotInt, remInt, divInt, modInt :: Int -> Int -> In
(I# x) `divInt` (I# y) = I# (x `divInt#` y)
(I# x) `modInt` (I# y) = I# (x `modInt#` y)
quotRemInt :: Int -> Int -> (Int, Int)
(I# x) `quotRemInt` (I# y) = case x `quotRemInt#` y of
(# q, r #) ->
(I# q, I# r)
divModInt :: Int -> Int -> (Int, Int)
(I# x) `divModInt` (I# y) = case x `divModInt#` y of
(# q, r #) -> (I# q, I# r)
divModInt# :: Int# -> Int# -> (# Int#, Int# #)
x# `divModInt#` y#
| (x# ># 0#) && (y# <# 0#) = case (x# -# 1#) `quotRemInt#` y# of
(# q, r #) -> (# q -# 1#, r +# y# +# 1# #)
| (x# <# 0#) && (y# ># 0#) = case (x# +# 1#) `quotRemInt#` y# of
(# q, r #) -> (# q -# 1#, r +# y# -# 1# #)
| otherwise = x# `quotRemInt#` y#
{-# RULES
"x# +# 0#" forall x#. x# +# 0# = x#
"0# +# x#" forall x#. 0# +# x# = x#
......
{-# LANGUAGE NoImplicitPrelude, MagicHash #-}
module GHC.Char (chr) where
import GHC.Base
import GHC.Show
-- | The 'Prelude.toEnum' method restricted to the type 'Data.Char.Char'.
chr :: Int -> Char
chr i@(I# i#)
| int2Word# i# `leWord#` int2Word# 0x10FFFF# = C# (chr# i#)
| otherwise
= error ("Prelude.chr: bad argument: " ++ showSignedInt (I# 9#) i "")
......@@ -27,9 +27,7 @@ import Control.Category ((.))
import Data.Data (Data)
-- A version of Control.Category.>>> overloaded on Arrow
#ifndef __HADDOCK__
(>>>) :: forall arr. Arrow arr => forall a b c. arr a b -> arr b c -> arr a c
#endif
-- NB: the type of this function is the "shape" that GHC expects
-- in tcInstClassOp. So don't put all the foralls at the front!
-- Yes, this is a bit grotesque, but heck it works and the whole
......
......@@ -28,10 +28,10 @@ module GHC.Enum(
) where
import GHC.Base
import GHC.Char
import GHC.Integer
import GHC.Num
import GHC.Show
import Data.Tuple () -- for dependencies
default () -- Double isn't available yet
\end{code}
......
......@@ -34,10 +34,8 @@ module GHC.Err
, undefined -- :: a
) where
#ifndef __HADDOCK__
import GHC.Types
import GHC.Exception
#endif
\end{code}
%*********************************************************
......
......@@ -26,6 +26,7 @@ import GHC.IO.Buffer
import GHC.IO.Exception
import GHC.Base
import GHC.Char
import GHC.Word
import GHC.Show
import GHC.Num
......
{-# LANGUAGE Trustworthy #-}
{-# LANGUAGE CPP, NoImplicitPrelude, BangPatterns, MagicHash,
{-# LANGUAGE CPP, NoImplicitPrelude, BangPatterns, MagicHash, UnboxedTuples,
StandaloneDeriving #-}
{-# OPTIONS_HADDOCK hide #-}
......@@ -50,7 +50,7 @@ import GHC.Float () -- for RealFrac methods
-- Int8 is represented in the same way as Int. Operations may assume
-- and must ensure that it holds only values from its logical range.
data Int8 = I8# Int# deriving (Eq, Ord)
data {-# CTYPE "HsInt8" #-} Int8 = I8# Int# deriving (Eq, Ord)
-- ^ 8-bit signed integer type
instance Show Int8 where
......@@ -105,14 +105,18 @@ instance Integral Int8 where
| y == 0 = divZeroError
-- Note [Order of tests]
| y == (-1) && x == minBound = (overflowError, 0)
| otherwise = (I8# (narrow8Int# (x# `quotInt#` y#)),
I8# (narrow8Int# (x# `remInt#` y#)))
| otherwise = case x# `quotRemInt#` y# of
(# q, r #) ->
(I8# (narrow8Int# q),
I8# (narrow8Int# r))
divMod x@(I8# x#) y@(I8# y#)
| y == 0 = divZeroError
-- Note [Order of tests]
| y == (-1) && x == minBound = (overflowError, 0)
| otherwise = (I8# (narrow8Int# (x# `divInt#` y#)),
I8# (narrow8Int# (x# `modInt#` y#)))
| otherwise = case x# `divModInt#` y# of
(# d, m #) ->
(I8# (narrow8Int# d),
I8# (narrow8Int# m))
toInteger (I8# x#) = smallInteger x#
instance Bounded Int8 where
......@@ -201,7 +205,7 @@ instance Bits Int8 where
-- Int16 is represented in the same way as Int. Operations may assume
-- and must ensure that it holds only values from its logical range.
data Int16 = I16# Int# deriving (Eq, Ord)
data {-# CTYPE "HsInt16" #-} Int16 = I16# Int# deriving (Eq, Ord)
-- ^ 16-bit signed integer type
instance Show Int16 where
......@@ -256,14 +260,18 @@ instance Integral Int16 where
| y == 0 = divZeroError
-- Note [Order of tests]
| y == (-1) && x == minBound = (overflowError, 0)
| otherwise = (I16# (narrow16Int# (x# `quotInt#` y#)),
I16# (narrow16Int# (x# `remInt#` y#)))
| otherwise = case x# `quotRemInt#` y# of
(# q, r #) ->
(I16# (narrow16Int# q),
I16# (narrow16Int# r))
divMod x@(I16# x#) y@(I16# y#)
| y == 0 = divZeroError
-- Note [Order of tests]
| y == (-1) && x == minBound = (overflowError, 0)
| otherwise = (I16# (narrow16Int# (x# `divInt#` y#)),
I16# (narrow16Int# (x# `modInt#` y#)))
| otherwise = case x# `divModInt#` y# of
(# d, m #) ->
(I16# (narrow16Int# d),
I16# (narrow16Int# m))
toInteger (I16# x#) = smallInteger x#
instance Bounded Int16 where
......@@ -357,7 +365,7 @@ instance Bits Int16 where
-- from its logical range.
#endif
data Int32 = I32# Int# deriving (Eq, Ord)
data {-# CTYPE "HsInt32" #-} Int32 = I32# Int# deriving (Eq, Ord)
-- ^ 32-bit signed integer type
instance Show Int32 where
......@@ -421,14 +429,18 @@ instance Integral Int32 where
| y == 0 = divZeroError
-- Note [Order of tests]
| y == (-1) && x == minBound = (overflowError, 0)
| otherwise = (I32# (narrow32Int# (x# `quotInt#` y#)),
I32# (narrow32Int# (x# `remInt#` y#)))
| otherwise = case x# `quotRemInt#` y# of
(# q, r #) ->
(I32# (narrow32Int# q),
I32# (narrow32Int# r))
divMod x@(I32# x#) y@(I32# y#)
| y == 0 = divZeroError
-- Note [Order of tests]
| y == (-1) && x == minBound = (overflowError, 0)
| otherwise = (I32# (narrow32Int# (x# `divInt#` y#)),
I32# (narrow32Int# (x# `modInt#` y#)))
| otherwise = case x# `divModInt#` y# of
(# d, m #) ->
(I32# (narrow32Int# d),
I32# (narrow32Int# m))
toInteger (I32# x#) = smallInteger x#
instance Read Int32 where
......@@ -524,7 +536,7 @@ instance Ix Int32 where
#if WORD_SIZE_IN_BITS < 64
data Int64 = I64# Int64#
data {-# CTYPE "HsInt64" #-} Int64 = I64# Int64#
-- ^ 64-bit signed integer type
instance Eq Int64 where
......@@ -690,7 +702,7 @@ a `iShiftRA64#` b | b >=# 64# = if a `ltInt64#` (intToInt64# 0#)
-- Operations may assume and must ensure that it holds only values
-- from its logical range.
data Int64 = I64# Int# deriving (Eq, Ord)
data {-# CTYPE "HsInt64" #-} Int64 = I64# Int# deriving (Eq, Ord)
-- ^ 64-bit signed integer type
instance Show Int64 where
......@@ -747,12 +759,16 @@ instance Integral Int64 where
| y == 0 = divZeroError
-- Note [Order of tests]
| y == (-1) && x == minBound = (overflowError, 0)
| otherwise = (I64# (x# `quotInt#` y#), I64# (x# `remInt#` y#))
| otherwise = case x# `quotRemInt#` y# of
(# q, r #) ->
(I64# q, I64# r)
divMod x@(I64# x#) y@(I64# y#)
| y == 0 = divZeroError
-- Note [Order of tests]
| y == (-1) && x == minBound = (overflowError, 0)
| otherwise = (I64# (x# `divInt#` y#), I64# (x# `modInt#` y#))
| otherwise = case x# `divModInt#` y# of
(# d, m #) ->
(I64# d, I64# m)
toInteger (I64# x#) = smallInteger x#
instance Read Int64 where
......
......@@ -31,7 +31,6 @@ module GHC.MVar (
) where
import GHC.Base
import GHC.IO () -- instance Monad IO
import Data.Maybe
data MVar a = MVar (MVar# RealWorld a)
......
......@@ -95,14 +95,6 @@ instance Num Int where
{-# INLINE fromInteger #-} -- Just to be sure!
fromInteger i = I# (integerToInt i)
quotRemInt :: Int -> Int -> (Int, Int)
quotRemInt a@(I# _) b@(I# _) = (a `quotInt` b, a `remInt` b)
-- OK, so I made it a little stricter. Shoot me. (WDP 94/10)
divModInt :: Int -> Int -> (Int, Int)
divModInt x@(I# _) y@(I# _) = (x `divInt` y, x `modInt` y)
-- Stricter. Sorry if you don't like it. (WDP 94/10)
\end{code}
%*********************************************************
......
\begin{code}
{-# LANGUAGE Trustworthy #-}
{-# LANGUAGE CPP, NoImplicitPrelude, StandaloneDeriving #-}
{-# LANGUAGE CPP, NoImplicitPrelude, StandaloneDeriving, PatternGuards,
ScopedTypeVariables #-}
{-# OPTIONS_HADDOCK hide #-}
-----------------------------------------------------------------------------
......@@ -64,14 +65,13 @@ import Text.ParserCombinators.ReadPrec
import Data.Maybe
#ifndef __HADDOCK__
import {-# SOURCE #-} GHC.Unicode ( isDigit )
#endif
import GHC.Num
import GHC.Real
import GHC.Float ()
import GHC.Float
import GHC.Show
import GHC.Base
import GHC.Err
import GHC.Arr
-- For defining instances for the generic deriving mechanism
import GHC.Generics (Arity(..), Associativity(..), Fixity(..))
......@@ -470,13 +470,18 @@ readNumber convert =
convertInt :: Num a => L.Lexeme -> ReadPrec a
convertInt (L.Int i) = return (fromInteger i)
convertInt _ = pfail
convertFrac :: Fractional a => L.Lexeme -> ReadPrec a
convertFrac (L.Int i) = return (fromInteger i)
convertFrac (L.Rat r) = return (fromRational r)
convertFrac _ = pfail
convertInt (L.Number n)
| Just i <- L.numberToInteger n = return (fromInteger i)
convertInt _ = pfail
convertFrac :: forall a . RealFloat a => L.Lexeme -> ReadPrec a
convertFrac (L.Ident "NaN") = return (0 / 0)
convertFrac (L.Ident "Infinity") = return (1 / 0)
convertFrac (L.Number n) = let resRange = floatRange (undefined :: a)
in case L.numberToRangedRational resRange n of
Nothing -> return (1 / 0)
Just rat -> return $ fromRational rat
convertFrac _ = pfail
instance Read Int where
readPrec = readNumber convertInt
......
......@@ -434,16 +434,20 @@ itos n# cs
let !(I# minInt#) = minInt in
if n# ==# minInt#
-- negateInt# minInt overflows, so we can't do that:
then '-' : itos' (negateInt# (n# `quotInt#` 10#))
(itos' (negateInt# (n# `remInt#` 10#)) cs)
then '-' : (case n# `quotRemInt#` 10# of
(# q, r #) ->
itos' (negateInt# q) (itos' (negateInt# r) cs))
else '-' : itos' (negateInt# n#) cs
| otherwise = itos' n# cs
where
itos' :: Int# -> String -> String
itos' x# cs'
| x# <# 10# = C# (chr# (ord# '0'# +# x#)) : cs'
| otherwise = case chr# (ord# '0'# +# (x# `remInt#` 10#)) of { c# ->
itos' (x# `quotInt#` 10#) (C# c# : cs') }
| otherwise = case x# `quotRemInt#` 10# of
(# q, r #) ->
case chr# (ord# '0'# +# r) of
c# ->
itos' q (C# c# : cs')
\end{code}
Instances for types of the generic deriving mechanism.
......
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