diff options
Diffstat (limited to 'libraries')
-rw-r--r-- | libraries/base/Data/Bits.hs | 68 | ||||
-rw-r--r-- | libraries/base/Data/Data.hs | 1 | ||||
-rw-r--r-- | libraries/base/GHC/Arr.hs | 9 | ||||
-rw-r--r-- | libraries/base/GHC/Base.hs | 28 | ||||
-rw-r--r-- | libraries/base/GHC/Base.hs-boot | 5 | ||||
-rw-r--r-- | libraries/base/GHC/Enum.hs | 73 | ||||
-rw-r--r-- | libraries/base/GHC/Err.hs | 4 | ||||
-rw-r--r-- | libraries/base/GHC/Exception.hs | 161 | ||||
-rw-r--r-- | libraries/base/GHC/Exception.hs-boot | 16 | ||||
-rw-r--r-- | libraries/base/GHC/Exception/Type.hs | 183 | ||||
-rw-r--r-- | libraries/base/GHC/Exception/Type.hs-boot | 16 | ||||
-rw-r--r-- | libraries/base/GHC/Int.hs | 30 | ||||
-rw-r--r-- | libraries/base/GHC/Maybe.hs | 31 | ||||
-rw-r--r-- | libraries/base/GHC/Natural.hs | 764 | ||||
-rw-r--r-- | libraries/base/GHC/Num.hs | 43 | ||||
-rw-r--r-- | libraries/base/GHC/Read.hs | 14 | ||||
-rw-r--r-- | libraries/base/GHC/Real.hs | 69 | ||||
-rw-r--r-- | libraries/base/GHC/Show.hs | 7 | ||||
-rw-r--r-- | libraries/base/GHC/Stack/Types.hs | 1 | ||||
-rw-r--r-- | libraries/base/GHC/Word.hs | 30 | ||||
-rw-r--r-- | libraries/base/Unsafe/Coerce.hs | 1 | ||||
-rw-r--r-- | libraries/base/base.cabal | 2 | ||||
-rw-r--r-- | libraries/template-haskell/Language/Haskell/TH/Syntax.hs | 4 |
23 files changed, 947 insertions, 613 deletions
diff --git a/libraries/base/Data/Bits.hs b/libraries/base/Data/Bits.hs index 1fc388040c..60edf78dea 100644 --- a/libraries/base/Data/Bits.hs +++ b/libraries/base/Data/Bits.hs @@ -536,6 +536,74 @@ instance Bits Integer where bitSize _ = errorWithoutStackTrace "Data.Bits.bitSize(Integer)" isSigned _ = True +#if defined(MIN_VERSION_integer_gmp) +-- | @since 4.8.0 +instance Bits Natural where + (.&.) = andNatural + (.|.) = orNatural + xor = xorNatural + complement _ = errorWithoutStackTrace + "Bits.complement: Natural complement undefined" + shift x i + | i >= 0 = shiftLNatural x i + | otherwise = shiftRNatural x (negate i) + testBit x i = testBitNatural x i + zeroBits = wordToNaturalBase 0## + clearBit x i = x `xor` (bit i .&. x) + + bit (I# i#) = bitNatural i# + popCount x = popCountNatural x + + rotate x i = shift x i -- since an Natural never wraps around + + bitSizeMaybe _ = Nothing + bitSize _ = errorWithoutStackTrace "Data.Bits.bitSize(Natural)" + isSigned _ = False +#else +-- | @since 4.8.0.0 +instance Bits Natural where + Natural n .&. Natural m = Natural (n .&. m) + {-# INLINE (.&.) #-} + Natural n .|. Natural m = Natural (n .|. m) + {-# INLINE (.|.) #-} + xor (Natural n) (Natural m) = Natural (xor n m) + {-# INLINE xor #-} + complement _ = errorWithoutStackTrace "Bits.complement: Natural complement undefined" + {-# INLINE complement #-} + shift (Natural n) = Natural . shift n + {-# INLINE shift #-} + rotate (Natural n) = Natural . rotate n + {-# INLINE rotate #-} + bit = Natural . bit + {-# INLINE bit #-} + setBit (Natural n) = Natural . setBit n + {-# INLINE setBit #-} + clearBit (Natural n) = Natural . clearBit n + {-# INLINE clearBit #-} + complementBit (Natural n) = Natural . complementBit n + {-# INLINE complementBit #-} + testBit (Natural n) = testBit n + {-# INLINE testBit #-} + bitSizeMaybe _ = Nothing + {-# INLINE bitSizeMaybe #-} + bitSize = errorWithoutStackTrace "Natural: bitSize" + {-# INLINE bitSize #-} + isSigned _ = False + {-# INLINE isSigned #-} + shiftL (Natural n) = Natural . shiftL n + {-# INLINE shiftL #-} + shiftR (Natural n) = Natural . shiftR n + {-# INLINE shiftR #-} + rotateL (Natural n) = Natural . rotateL n + {-# INLINE rotateL #-} + rotateR (Natural n) = Natural . rotateR n + {-# INLINE rotateR #-} + popCount (Natural n) = popCount n + {-# INLINE popCount #-} + zeroBits = Natural 0 + +#endif + ----------------------------------------------------------------------------- -- | Attempt to convert an 'Integral' type @a@ to an 'Integral' type @b@ using diff --git a/libraries/base/Data/Data.hs b/libraries/base/Data/Data.hs index 8154433044..194df08003 100644 --- a/libraries/base/Data/Data.hs +++ b/libraries/base/Data/Data.hs @@ -126,7 +126,6 @@ import Data.Version( Version(..) ) import GHC.Base hiding (Any, IntRep, FloatRep) import GHC.List import GHC.Num -import GHC.Natural import GHC.Read import GHC.Show import Text.Read( reads ) diff --git a/libraries/base/GHC/Arr.hs b/libraries/base/GHC/Arr.hs index 8dbda6f7cf..af16355bc1 100644 --- a/libraries/base/GHC/Arr.hs +++ b/libraries/base/GHC/Arr.hs @@ -240,6 +240,15 @@ instance Ix Integer where inRange (m,n) i = m <= i && i <= n ---------------------------------------------------------------------- +-- | @since 4.8.0.0 +instance Ix Natural where + range (m,n) = [m..n] + inRange (m,n) i = m <= i && i <= n + unsafeIndex (m,_) i = fromIntegral (i-m) + index b i | inRange b i = unsafeIndex b i + | otherwise = indexError b i "Natural" + +---------------------------------------------------------------------- -- | @since 2.01 instance Ix Bool where -- as derived {-# INLINE range #-} diff --git a/libraries/base/GHC/Base.hs b/libraries/base/GHC/Base.hs index b8f984c440..4953a7d58c 100644 --- a/libraries/base/GHC/Base.hs +++ b/libraries/base/GHC/Base.hs @@ -117,7 +117,8 @@ module GHC.Base module GHC.Types, module GHC.Prim, -- Re-export GHC.Prim and [boot] GHC.Err, -- to avoid lots of people having to - module GHC.Err -- import it explicitly + module GHC.Err, -- import it explicitly + module GHC.Maybe ) where @@ -127,10 +128,12 @@ import GHC.CString import GHC.Magic import GHC.Prim import GHC.Err +import GHC.Maybe import {-# SOURCE #-} GHC.IO (failIO,mplusIO) -import GHC.Tuple () -- Note [Depend on GHC.Tuple] -import GHC.Integer () -- Note [Depend on GHC.Integer] +import GHC.Tuple () -- Note [Depend on GHC.Tuple] +import GHC.Integer () -- Note [Depend on GHC.Integer] +import GHC.Natural () -- Note [Depend on GHC.Natural] -- for 'class Semigroup' import {-# SOURCE #-} GHC.Real (Integral) @@ -182,6 +185,10 @@ Similarly, tuple syntax (or ()) creates an implicit dependency on GHC.Tuple, so we use the same rule as for Integer --- see Note [Depend on GHC.Integer] --- to explain this to the build system. We make GHC.Base depend on GHC.Tuple, and everything else depends on GHC.Base or Prelude. + +Note [Depend on GHC.Natural] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +Similar to GHC.Integer. -} #if 0 @@ -202,21 +209,6 @@ build = errorWithoutStackTrace "urk" foldr = errorWithoutStackTrace "urk" #endif --- | The 'Maybe' type encapsulates an optional value. A value of type --- @'Maybe' a@ either contains a value of type @a@ (represented as @'Just' a@), --- or it is empty (represented as 'Nothing'). Using 'Maybe' is a good way to --- deal with errors or exceptional cases without resorting to drastic --- measures such as 'error'. --- --- The 'Maybe' type is also a monad. It is a simple kind of error --- monad, where all errors are represented by 'Nothing'. A richer --- error monad can be built using the 'Data.Either.Either' type. --- -data Maybe a = Nothing | Just a - deriving ( Eq -- ^ @since 2.01 - , Ord -- ^ @since 2.01 - ) - infixr 6 <> -- | The class of semigroups (types with an associative binary operation). diff --git a/libraries/base/GHC/Base.hs-boot b/libraries/base/GHC/Base.hs-boot index ca85b49147..64e6365525 100644 --- a/libraries/base/GHC/Base.hs-boot +++ b/libraries/base/GHC/Base.hs-boot @@ -1,10 +1,9 @@ {-# LANGUAGE NoImplicitPrelude #-} -module GHC.Base where +module GHC.Base (Maybe, Semigroup, Monoid) where +import GHC.Maybe (Maybe) import GHC.Types () class Semigroup a class Monoid a - -data Maybe a = Nothing | Just a diff --git a/libraries/base/GHC/Enum.hs b/libraries/base/GHC/Enum.hs index feb45854d2..234ccb3ba2 100644 --- a/libraries/base/GHC/Enum.hs +++ b/libraries/base/GHC/Enum.hs @@ -877,6 +877,79 @@ dn_list x0 delta lim = go (x0 :: Integer) go x | x < lim = [] | otherwise = x : go (x+delta) +------------------------------------------------------------------------ +-- Natural +------------------------------------------------------------------------ + +#if defined(MIN_VERSION_integer_gmp) +-- | @since 4.8.0.0 +instance Enum Natural where + succ n = n `plusNatural` wordToNaturalBase 1## + pred n = n `minusNatural` wordToNaturalBase 1## + + toEnum = intToNatural + + fromEnum (NatS# w) + | i >= 0 = i + | otherwise = errorWithoutStackTrace "fromEnum: out of Int range" + where + i = I# (word2Int# w) + fromEnum n = fromEnum (naturalToInteger n) + + enumFrom x = enumDeltaNatural x (wordToNaturalBase 1##) + enumFromThen x y + | x <= y = enumDeltaNatural x (y-x) + | otherwise = enumNegDeltaToNatural x (x-y) (wordToNaturalBase 0##) + + enumFromTo x lim = enumDeltaToNatural x (wordToNaturalBase 1##) lim + enumFromThenTo x y lim + | x <= y = enumDeltaToNatural x (y-x) lim + | otherwise = enumNegDeltaToNatural x (x-y) lim + +-- Helpers for 'Enum Natural'; TODO: optimise & make fusion work + +enumDeltaNatural :: Natural -> Natural -> [Natural] +enumDeltaNatural !x d = x : enumDeltaNatural (x+d) d + +enumDeltaToNatural :: Natural -> Natural -> Natural -> [Natural] +enumDeltaToNatural x0 delta lim = go x0 + where + go x | x > lim = [] + | otherwise = x : go (x+delta) + +enumNegDeltaToNatural :: Natural -> Natural -> Natural -> [Natural] +enumNegDeltaToNatural x0 ndelta lim = go x0 + where + go x | x < lim = [] + | x >= ndelta = x : go (x-ndelta) + | otherwise = [x] + +#else + +-- | @since 4.8.0.0 +instance Enum Natural where + pred (Natural 0) = errorWithoutStackTrace "Natural.pred: 0" + pred (Natural n) = Natural (pred n) + {-# INLINE pred #-} + succ (Natural n) = Natural (succ n) + {-# INLINE succ #-} + fromEnum (Natural n) = fromEnum n + {-# INLINE fromEnum #-} + toEnum n | n < 0 = errorWithoutStackTrace "Natural.toEnum: negative" + | otherwise = Natural (toEnum n) + {-# INLINE toEnum #-} + + enumFrom = coerce (enumFrom :: Integer -> [Integer]) + enumFromThen x y + | x <= y = coerce (enumFromThen :: Integer -> Integer -> [Integer]) x y + | otherwise = enumFromThenTo x y (wordToNaturalBase 0##) + + enumFromTo = coerce (enumFromTo :: Integer -> Integer -> [Integer]) + enumFromThenTo + = coerce (enumFromThenTo :: Integer -> Integer -> Integer -> [Integer]) + +#endif + -- Instances from GHC.Types -- | @since 4.10.0.0 diff --git a/libraries/base/GHC/Err.hs b/libraries/base/GHC/Err.hs index a48fb10a86..1f1ad903ae 100644 --- a/libraries/base/GHC/Err.hs +++ b/libraries/base/GHC/Err.hs @@ -27,8 +27,8 @@ import GHC.CString () import GHC.Types (Char, RuntimeRep) import GHC.Stack.Types import GHC.Prim -import GHC.Integer () -- Make sure Integer is compiled first - -- because GHC depends on it in a wired-in way +import GHC.Integer () -- Make sure Integer and Natural are compiled first +import GHC.Natural () -- because GHC depends on it in a wired-in way -- so the build system doesn't see the dependency import {-# SOURCE #-} GHC.Exception ( errorCallWithCallStackException diff --git a/libraries/base/GHC/Exception.hs b/libraries/base/GHC/Exception.hs index f966b3fd5e..3b32e230e8 100644 --- a/libraries/base/GHC/Exception.hs +++ b/libraries/base/GHC/Exception.hs @@ -23,21 +23,17 @@ ----------------------------------------------------------------------------- module GHC.Exception - ( Exception(..) -- Class + ( module GHC.Exception.Type , throw - , SomeException(..), ErrorCall(..,ErrorCall), ArithException(..) - , divZeroException, overflowException, ratioZeroDenomException - , underflowException - , errorCallException, errorCallWithCallStackException + , ErrorCall(..,ErrorCall) + , errorCallException + , errorCallWithCallStackException -- re-export CallStack and SrcLoc from GHC.Types , CallStack, fromCallSiteList, getCallStack, prettyCallStack , prettyCallStackLines, showCCSStack , SrcLoc(..), prettySrcLoc ) where -import Data.Maybe -import Data.Typeable (Typeable, cast) - -- loop: Data.Typeable -> GHC.Err -> GHC.Exception import GHC.Base import GHC.Show import GHC.Stack.Types @@ -45,124 +41,7 @@ import GHC.OldList import GHC.Prim import GHC.IO.Unsafe import {-# SOURCE #-} GHC.Stack.CCS - -{- | -The @SomeException@ type is the root of the exception type hierarchy. -When an exception of type @e@ is thrown, behind the scenes it is -encapsulated in a @SomeException@. --} -data SomeException = forall e . Exception e => SomeException e - --- | @since 3.0 -instance Show SomeException where - showsPrec p (SomeException e) = showsPrec p e - -{- | -Any type that you wish to throw or catch as an exception must be an -instance of the @Exception@ class. The simplest case is a new exception -type directly below the root: - -> data MyException = ThisException | ThatException -> deriving Show -> -> instance Exception MyException - -The default method definitions in the @Exception@ class do what we need -in this case. You can now throw and catch @ThisException@ and -@ThatException@ as exceptions: - -@ -*Main> throw ThisException \`catch\` \\e -> putStrLn (\"Caught \" ++ show (e :: MyException)) -Caught ThisException -@ - -In more complicated examples, you may wish to define a whole hierarchy -of exceptions: - -> --------------------------------------------------------------------- -> -- Make the root exception type for all the exceptions in a compiler -> -> data SomeCompilerException = forall e . Exception e => SomeCompilerException e -> -> instance Show SomeCompilerException where -> show (SomeCompilerException e) = show e -> -> instance Exception SomeCompilerException -> -> compilerExceptionToException :: Exception e => e -> SomeException -> compilerExceptionToException = toException . SomeCompilerException -> -> compilerExceptionFromException :: Exception e => SomeException -> Maybe e -> compilerExceptionFromException x = do -> SomeCompilerException a <- fromException x -> cast a -> -> --------------------------------------------------------------------- -> -- Make a subhierarchy for exceptions in the frontend of the compiler -> -> data SomeFrontendException = forall e . Exception e => SomeFrontendException e -> -> instance Show SomeFrontendException where -> show (SomeFrontendException e) = show e -> -> instance Exception SomeFrontendException where -> toException = compilerExceptionToException -> fromException = compilerExceptionFromException -> -> frontendExceptionToException :: Exception e => e -> SomeException -> frontendExceptionToException = toException . SomeFrontendException -> -> frontendExceptionFromException :: Exception e => SomeException -> Maybe e -> frontendExceptionFromException x = do -> SomeFrontendException a <- fromException x -> cast a -> -> --------------------------------------------------------------------- -> -- Make an exception type for a particular frontend compiler exception -> -> data MismatchedParentheses = MismatchedParentheses -> deriving Show -> -> instance Exception MismatchedParentheses where -> toException = frontendExceptionToException -> fromException = frontendExceptionFromException - -We can now catch a @MismatchedParentheses@ exception as -@MismatchedParentheses@, @SomeFrontendException@ or -@SomeCompilerException@, but not other types, e.g. @IOException@: - -@ -*Main> throw MismatchedParentheses \`catch\` \\e -> putStrLn (\"Caught \" ++ show (e :: MismatchedParentheses)) -Caught MismatchedParentheses -*Main> throw MismatchedParentheses \`catch\` \\e -> putStrLn (\"Caught \" ++ show (e :: SomeFrontendException)) -Caught MismatchedParentheses -*Main> throw MismatchedParentheses \`catch\` \\e -> putStrLn (\"Caught \" ++ show (e :: SomeCompilerException)) -Caught MismatchedParentheses -*Main> throw MismatchedParentheses \`catch\` \\e -> putStrLn (\"Caught \" ++ show (e :: IOException)) -*** Exception: MismatchedParentheses -@ - --} -class (Typeable e, Show e) => Exception e where - toException :: e -> SomeException - fromException :: SomeException -> Maybe e - - toException = SomeException - fromException (SomeException e) = cast e - - -- | Render this exception value in a human-friendly manner. - -- - -- Default implementation: @'show'@. - -- - -- @since 4.8.0.0 - displayException :: e -> String - displayException = show - --- | @since 3.0 -instance Exception SomeException where - toException se = se - fromException = Just - displayException (SomeException e) = displayException e +import GHC.Exception.Type -- | Throw an exception. Exceptions may be thrown from purely -- functional code, but may only be caught within the 'IO' monad. @@ -236,33 +115,3 @@ prettyCallStackLines cs = case getCallStack cs of : map ((" " ++) . prettyCallSite) stk where prettyCallSite (f, loc) = f ++ ", called at " ++ prettySrcLoc loc - --- |Arithmetic exceptions. -data ArithException - = Overflow - | Underflow - | LossOfPrecision - | DivideByZero - | Denormal - | RatioZeroDenominator -- ^ @since 4.6.0.0 - deriving ( Eq -- ^ @since 3.0 - , Ord -- ^ @since 3.0 - ) - -divZeroException, overflowException, ratioZeroDenomException, underflowException :: SomeException -divZeroException = toException DivideByZero -overflowException = toException Overflow -ratioZeroDenomException = toException RatioZeroDenominator -underflowException = toException Underflow - --- | @since 4.0.0.0 -instance Exception ArithException - --- | @since 4.0.0.0 -instance Show ArithException where - showsPrec _ Overflow = showString "arithmetic overflow" - showsPrec _ Underflow = showString "arithmetic underflow" - showsPrec _ LossOfPrecision = showString "loss of precision" - showsPrec _ DivideByZero = showString "divide by zero" - showsPrec _ Denormal = showString "denormal" - showsPrec _ RatioZeroDenominator = showString "Ratio has zero denominator" diff --git a/libraries/base/GHC/Exception.hs-boot b/libraries/base/GHC/Exception.hs-boot index d539dd4962..4507b20790 100644 --- a/libraries/base/GHC/Exception.hs-boot +++ b/libraries/base/GHC/Exception.hs-boot @@ -24,17 +24,15 @@ well-behaved, non-bottom values. The clients use 'raise#' to get a visibly-bottom value. -} -module GHC.Exception ( SomeException, errorCallException, - errorCallWithCallStackException, - divZeroException, overflowException, ratioZeroDenomException, - underflowException - ) where +module GHC.Exception + ( module GHC.Exception.Type + , errorCallException + , errorCallWithCallStackException + ) where + +import {-# SOURCE #-} GHC.Exception.Type import GHC.Types ( Char ) import GHC.Stack.Types ( CallStack ) -data SomeException -divZeroException, overflowException, ratioZeroDenomException :: SomeException -underflowException :: SomeException - errorCallException :: [Char] -> SomeException errorCallWithCallStackException :: [Char] -> CallStack -> SomeException diff --git a/libraries/base/GHC/Exception/Type.hs b/libraries/base/GHC/Exception/Type.hs new file mode 100644 index 0000000000..6c3eb49ff9 --- /dev/null +++ b/libraries/base/GHC/Exception/Type.hs @@ -0,0 +1,183 @@ +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE NoImplicitPrelude + , ExistentialQuantification + , MagicHash + , RecordWildCards + , PatternSynonyms + #-} +{-# OPTIONS_HADDOCK hide #-} + +----------------------------------------------------------------------------- +-- | +-- Module : GHC.Exception.Type +-- Copyright : (c) The University of Glasgow, 1998-2002 +-- License : see libraries/base/LICENSE +-- +-- Maintainer : cvs-ghc@haskell.org +-- Stability : internal +-- Portability : non-portable (GHC extensions) +-- +-- Exceptions and exception-handling functions. +-- +----------------------------------------------------------------------------- + +module GHC.Exception.Type + ( Exception(..) -- Class + , SomeException(..), ArithException(..) + , divZeroException, overflowException, ratioZeroDenomException + , underflowException + ) where + +import Data.Maybe +import Data.Typeable (Typeable, cast) + -- loop: Data.Typeable -> GHC.Err -> GHC.Exception +import GHC.Base +import GHC.Show + +{- | +The @SomeException@ type is the root of the exception type hierarchy. +When an exception of type @e@ is thrown, behind the scenes it is +encapsulated in a @SomeException@. +-} +data SomeException = forall e . Exception e => SomeException e + +-- | @since 3.0 +instance Show SomeException where + showsPrec p (SomeException e) = showsPrec p e + +{- | +Any type that you wish to throw or catch as an exception must be an +instance of the @Exception@ class. The simplest case is a new exception +type directly below the root: + +> data MyException = ThisException | ThatException +> deriving Show +> +> instance Exception MyException + +The default method definitions in the @Exception@ class do what we need +in this case. You can now throw and catch @ThisException@ and +@ThatException@ as exceptions: + +@ +*Main> throw ThisException \`catch\` \\e -> putStrLn (\"Caught \" ++ show (e :: MyException)) +Caught ThisException +@ + +In more complicated examples, you may wish to define a whole hierarchy +of exceptions: + +> --------------------------------------------------------------------- +> -- Make the root exception type for all the exceptions in a compiler +> +> data SomeCompilerException = forall e . Exception e => SomeCompilerException e +> +> instance Show SomeCompilerException where +> show (SomeCompilerException e) = show e +> +> instance Exception SomeCompilerException +> +> compilerExceptionToException :: Exception e => e -> SomeException +> compilerExceptionToException = toException . SomeCompilerException +> +> compilerExceptionFromException :: Exception e => SomeException -> Maybe e +> compilerExceptionFromException x = do +> SomeCompilerException a <- fromException x +> cast a +> +> --------------------------------------------------------------------- +> -- Make a subhierarchy for exceptions in the frontend of the compiler +> +> data SomeFrontendException = forall e . Exception e => SomeFrontendException e +> +> instance Show SomeFrontendException where +> show (SomeFrontendException e) = show e +> +> instance Exception SomeFrontendException where +> toException = compilerExceptionToException +> fromException = compilerExceptionFromException +> +> frontendExceptionToException :: Exception e => e -> SomeException +> frontendExceptionToException = toException . SomeFrontendException +> +> frontendExceptionFromException :: Exception e => SomeException -> Maybe e +> frontendExceptionFromException x = do +> SomeFrontendException a <- fromException x +> cast a +> +> --------------------------------------------------------------------- +> -- Make an exception type for a particular frontend compiler exception +> +> data MismatchedParentheses = MismatchedParentheses +> deriving Show +> +> instance Exception MismatchedParentheses where +> toException = frontendExceptionToException +> fromException = frontendExceptionFromException + +We can now catch a @MismatchedParentheses@ exception as +@MismatchedParentheses@, @SomeFrontendException@ or +@SomeCompilerException@, but not other types, e.g. @IOException@: + +@ +*Main> throw MismatchedParentheses \`catch\` \\e -> putStrLn (\"Caught \" ++ show (e :: MismatchedParentheses)) +Caught MismatchedParentheses +*Main> throw MismatchedParentheses \`catch\` \\e -> putStrLn (\"Caught \" ++ show (e :: SomeFrontendException)) +Caught MismatchedParentheses +*Main> throw MismatchedParentheses \`catch\` \\e -> putStrLn (\"Caught \" ++ show (e :: SomeCompilerException)) +Caught MismatchedParentheses +*Main> throw MismatchedParentheses \`catch\` \\e -> putStrLn (\"Caught \" ++ show (e :: IOException)) +*** Exception: MismatchedParentheses +@ + +-} +class (Typeable e, Show e) => Exception e where + toException :: e -> SomeException + fromException :: SomeException -> Maybe e + + toException = SomeException + fromException (SomeException e) = cast e + + -- | Render this exception value in a human-friendly manner. + -- + -- Default implementation: @'show'@. + -- + -- @since 4.8.0.0 + displayException :: e -> String + displayException = show + +-- | @since 3.0 +instance Exception SomeException where + toException se = se + fromException = Just + displayException (SomeException e) = displayException e + +-- |Arithmetic exceptions. +data ArithException + = Overflow + | Underflow + | LossOfPrecision + | DivideByZero + | Denormal + | RatioZeroDenominator -- ^ @since 4.6.0.0 + deriving ( Eq -- ^ @since 3.0 + , Ord -- ^ @since 3.0 + ) + +divZeroException, overflowException, ratioZeroDenomException, underflowException :: SomeException +divZeroException = toException DivideByZero +overflowException = toException Overflow +ratioZeroDenomException = toException RatioZeroDenominator +underflowException = toException Underflow + +-- | @since 4.0.0.0 +instance Exception ArithException + +-- | @since 4.0.0.0 +instance Show ArithException where + showsPrec _ Overflow = showString "arithmetic overflow" + showsPrec _ Underflow = showString "arithmetic underflow" + showsPrec _ LossOfPrecision = showString "loss of precision" + showsPrec _ DivideByZero = showString "divide by zero" + showsPrec _ Denormal = showString "denormal" + showsPrec _ RatioZeroDenominator = showString "Ratio has zero denominator" diff --git a/libraries/base/GHC/Exception/Type.hs-boot b/libraries/base/GHC/Exception/Type.hs-boot new file mode 100644 index 0000000000..1b4f0c0d81 --- /dev/null +++ b/libraries/base/GHC/Exception/Type.hs-boot @@ -0,0 +1,16 @@ +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE NoImplicitPrelude #-} + +module GHC.Exception.Type + ( SomeException + , divZeroException + , overflowException + , ratioZeroDenomException + , underflowException + ) where + +import GHC.Types () + +data SomeException +divZeroException, overflowException, + ratioZeroDenomException, underflowException :: SomeException diff --git a/libraries/base/GHC/Int.hs b/libraries/base/GHC/Int.hs index ad2a872c39..9bc161105d 100644 --- a/libraries/base/GHC/Int.hs +++ b/libraries/base/GHC/Int.hs @@ -1082,6 +1082,36 @@ instance Ix Int64 where unsafeIndex (m,_) i = fromIntegral i - fromIntegral m inRange (m,n) i = m <= i && i <= n +------------------------------------------------------------------------------- + +{-# RULES +"fromIntegral/Natural->Int8" + fromIntegral = (fromIntegral :: Int -> Int8) . naturalToInt +"fromIntegral/Natural->Int16" + fromIntegral = (fromIntegral :: Int -> Int16) . naturalToInt +"fromIntegral/Natural->Int32" + fromIntegral = (fromIntegral :: Int -> Int32) . naturalToInt + #-} + +{-# RULES +"fromIntegral/Int8->Natural" + fromIntegral = intToNatural . (fromIntegral :: Int8 -> Int) +"fromIntegral/Int16->Natural" + fromIntegral = intToNatural . (fromIntegral :: Int16 -> Int) +"fromIntegral/Int32->Natural" + fromIntegral = intToNatural . (fromIntegral :: Int32 -> Int) + #-} + +#if WORD_SIZE_IN_BITS == 64 +-- these RULES are valid for Word==Word64 & Int==Int64 +{-# RULES +"fromIntegral/Natural->Int64" + fromIntegral = (fromIntegral :: Int -> Int64) . naturalToInt +"fromIntegral/Int64->Natural" + fromIntegral = intToNatural . (fromIntegral :: Int64 -> Int) + #-} +#endif + {- Note [Order of tests] ~~~~~~~~~~~~~~~~~~~~~~~~~ diff --git a/libraries/base/GHC/Maybe.hs b/libraries/base/GHC/Maybe.hs new file mode 100644 index 0000000000..9fcf8b717d --- /dev/null +++ b/libraries/base/GHC/Maybe.hs @@ -0,0 +1,31 @@ +{-# LANGUAGE NoImplicitPrelude #-} + +-- | Maybe type +module GHC.Maybe + ( Maybe (..) + ) +where + +import GHC.Integer () -- for build order +import GHC.Classes + +default () + +------------------------------------------------------------------------------- +-- Maybe type +------------------------------------------------------------------------------- + +-- | The 'Maybe' type encapsulates an optional value. A value of type +-- @'Maybe' a@ either contains a value of type @a@ (represented as @'Just' a@), +-- or it is empty (represented as 'Nothing'). Using 'Maybe' is a good way to +-- deal with errors or exceptional cases without resorting to drastic +-- measures such as 'error'. +-- +-- The 'Maybe' type is also a monad. It is a simple kind of error +-- monad, where all errors are represented by 'Nothing'. A richer +-- error monad can be built using the 'Data.Either.Either' type. +-- +data Maybe a = Nothing | Just a + deriving ( Eq -- ^ @since 2.01 + , Ord -- ^ @since 2.01 + ) diff --git a/libraries/base/GHC/Natural.hs b/libraries/base/GHC/Natural.hs index 32cf2d2579..db8d8b883b 100644 --- a/libraries/base/GHC/Natural.hs +++ b/libraries/base/GHC/Natural.hs @@ -1,12 +1,8 @@ +{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MagicHash #-} -{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE UnboxedTuples #-} -{-# LANGUAGE Unsafe #-} - -{-# OPTIONS_HADDOCK not-home #-} ----------------------------------------------------------------------------- -- | @@ -34,38 +30,76 @@ module GHC.Natural -- (i.e. which constructors are available) depends on the -- 'Integer' backend used! Natural(..) + , mkNatural , isValidNatural + -- * Arithmetic + , plusNatural + , minusNatural + , minusNaturalMaybe + , timesNatural + , negateNatural + , signumNatural + , quotRemNatural + , quotNatural + , remNatural +#if defined(MIN_VERSION_integer_gmp) + , gcdNatural + , lcmNatural +#endif + -- * Bits + , andNatural + , orNatural + , xorNatural + , bitNatural + , testBitNatural +#if defined(MIN_VERSION_integer_gmp) + , popCountNatural +#endif + , shiftLNatural + , shiftRNatural -- * Conversions + , naturalToInteger + , naturalToWord + , naturalToInt , naturalFromInteger , wordToNatural + , intToNatural , naturalToWordMaybe - -- * Checked subtraction - , minusNaturalMaybe + , wordToNatural# + , wordToNaturalBase -- * Modular arithmetic , powModNatural ) where #include "MachDeps.h" -import GHC.Arr -import GHC.Base -import {-# SOURCE #-} GHC.Exception (underflowException) +import GHC.Classes +import GHC.Maybe +import GHC.Types +import GHC.Prim +import {-# SOURCE #-} GHC.Exception.Type (underflowException, divZeroException) #if defined(MIN_VERSION_integer_gmp) import GHC.Integer.GMP.Internals -import Data.Word -import Data.Int +#else +import GHC.Integer #endif -import GHC.Num -import GHC.Real -import GHC.Read -import GHC.Show -import GHC.Enum -import GHC.List - -import Data.Bits default () +-- Most high-level operations need to be marked `NOINLINE` as +-- otherwise GHC doesn't recognize them and fails to apply constant +-- folding to `Natural`-typed expression. +-- +-- To this end, the CPP hack below allows to write the pseudo-pragma +-- +-- {-# CONSTANT_FOLDED plusNatural #-} +-- +-- which is simply expanded into a +-- +-- {-# NOINLINE plusNatural #-} +-- +#define CONSTANT_FOLDED NOINLINE + ------------------------------------------------------------------------------- -- Arithmetic underflow ------------------------------------------------------------------------------- @@ -77,6 +111,10 @@ default () underflowError :: a underflowError = raise# underflowException +{-# NOINLINE divZeroError #-} +divZeroError :: a +divZeroError = raise# divZeroException + ------------------------------------------------------------------------------- -- Natural type ------------------------------------------------------------------------------- @@ -117,107 +155,32 @@ data Natural = NatS# GmpLimb# -- ^ in @[0, maxBound::Word]@ isValidNatural :: Natural -> Bool isValidNatural (NatS# _) = True isValidNatural (NatJ# bn) = isTrue# (isValidBigNat# bn) - && I# (sizeofBigNat# bn) > 0 - -{-# RULES -"fromIntegral/Natural->Natural" fromIntegral = id :: Natural -> Natural -"fromIntegral/Natural->Integer" fromIntegral = toInteger :: Natural->Integer -"fromIntegral/Natural->Word" fromIntegral = naturalToWord -"fromIntegral/Natural->Word8" - fromIntegral = (fromIntegral :: Word -> Word8) . naturalToWord -"fromIntegral/Natural->Word16" - fromIntegral = (fromIntegral :: Word -> Word16) . naturalToWord -"fromIntegral/Natural->Word32" - fromIntegral = (fromIntegral :: Word -> Word32) . naturalToWord -"fromIntegral/Natural->Int8" - fromIntegral = (fromIntegral :: Int -> Int8) . naturalToInt -"fromIntegral/Natural->Int16" - fromIntegral = (fromIntegral :: Int -> Int16) . naturalToInt -"fromIntegral/Natural->Int32" - fromIntegral = (fromIntegral :: Int -> Int32) . naturalToInt - #-} - -{-# RULES -"fromIntegral/Word->Natural" fromIntegral = wordToNatural -"fromIntegral/Word8->Natural" - fromIntegral = wordToNatural . (fromIntegral :: Word8 -> Word) -"fromIntegral/Word16->Natural" - fromIntegral = wordToNatural . (fromIntegral :: Word16 -> Word) -"fromIntegral/Word32->Natural" - fromIntegral = wordToNatural . (fromIntegral :: Word32 -> Word) -"fromIntegral/Int->Natural" fromIntegral = intToNatural -"fromIntegral/Int8->Natural" - fromIntegral = intToNatural . (fromIntegral :: Int8 -> Int) -"fromIntegral/Int16->Natural" - fromIntegral = intToNatural . (fromIntegral :: Int16 -> Int) -"fromIntegral/Int32->Natural" - fromIntegral = intToNatural . (fromIntegral :: Int32 -> Int) - #-} - -#if WORD_SIZE_IN_BITS == 64 --- these RULES are valid for Word==Word64 & Int==Int64 -{-# RULES -"fromIntegral/Natural->Word64" - fromIntegral = (fromIntegral :: Word -> Word64) . naturalToWord -"fromIntegral/Natural->Int64" - fromIntegral = (fromIntegral :: Int -> Int64) . naturalToInt -"fromIntegral/Word64->Natural" - fromIntegral = wordToNatural . (fromIntegral :: Word64 -> Word) -"fromIntegral/Int64->Natural" - fromIntegral = intToNatural . (fromIntegral :: Int64 -> Int) - #-} -#endif - --- | @since 4.8.0.0 -instance Show Natural where - showsPrec p (NatS# w#) = showsPrec p (W# w#) - showsPrec p (NatJ# bn) = showsPrec p (Jp# bn) - --- | @since 4.8.0.0 -instance Read Natural where - readsPrec d = map (\(n, s) -> (fromInteger n, s)) - . filter ((>= 0) . (\(x,_)->x)) . readsPrec d - --- | @since 4.8.0.0 -instance Num Natural where - fromInteger = naturalFromInteger + && isTrue# (sizeofBigNat# bn ># 0#) - (+) = plusNatural - (*) = timesNatural - (-) = minusNatural +signumNatural :: Natural -> Natural +signumNatural (NatS# 0##) = NatS# 0## +signumNatural _ = NatS# 1## +{-# CONSTANT_FOLDED signumNatural #-} - abs = id - - signum (NatS# 0##) = NatS# 0## - signum _ = NatS# 1## - - negate (NatS# 0##) = NatS# 0## - negate _ = underflowError +negateNatural :: Natural -> Natural +negateNatural (NatS# 0##) = NatS# 0## +negateNatural _ = underflowError +{-# CONSTANT_FOLDED negateNatural #-} -- | @since 4.10.0.0 naturalFromInteger :: Integer -> Natural -naturalFromInteger (S# i#) | I# i# >= 0 = NatS# (int2Word# i#) -naturalFromInteger (Jp# bn) = bigNatToNatural bn -naturalFromInteger _ = underflowError -{-# INLINE naturalFromInteger #-} - --- | @since 4.8.0.0 -instance Real Natural where - toRational (NatS# w) = toRational (W# w) - toRational (NatJ# bn) = toRational (Jp# bn) - -#if OPTIMISE_INTEGER_GCD_LCM -{-# RULES -"gcd/Natural->Natural->Natural" gcd = gcdNatural -"lcm/Natural->Natural->Natural" lcm = lcmNatural - #-} +naturalFromInteger (S# i#) + | isTrue# (i# >=# 0#) = NatS# (int2Word# i#) +naturalFromInteger (Jp# bn) = bigNatToNatural bn +naturalFromInteger _ = underflowError +{-# CONSTANT_FOLDED naturalFromInteger #-} -- | Compute greatest common divisor. gcdNatural :: Natural -> Natural -> Natural gcdNatural (NatS# 0##) y = y gcdNatural x (NatS# 0##) = x -gcdNatural (NatS# 1##) _ = (NatS# 1##) -gcdNatural _ (NatS# 1##) = (NatS# 1##) +gcdNatural (NatS# 1##) _ = NatS# 1## +gcdNatural _ (NatS# 1##) = NatS# 1## gcdNatural (NatJ# x) (NatJ# y) = bigNatToNatural (gcdBigNat x y) gcdNatural (NatJ# x) (NatS# y) = NatS# (gcdBigNatWord x y) gcdNatural (NatS# x) (NatJ# y) = NatS# (gcdBigNatWord y x) @@ -225,162 +188,107 @@ gcdNatural (NatS# x) (NatS# y) = NatS# (gcdWord x y) -- | compute least common multiplier. lcmNatural :: Natural -> Natural -> Natural -lcmNatural (NatS# 0##) _ = (NatS# 0##) -lcmNatural _ (NatS# 0##) = (NatS# 0##) +lcmNatural (NatS# 0##) _ = NatS# 0## +lcmNatural _ (NatS# 0##) = NatS# 0## lcmNatural (NatS# 1##) y = y lcmNatural x (NatS# 1##) = x -lcmNatural x y = (x `quot` (gcdNatural x y)) * y - -#endif - --- | @since 4.8.0.0 -instance Enum Natural where - succ n = n `plusNatural` NatS# 1## - pred n = n `minusNatural` NatS# 1## - - toEnum = intToNatural - - fromEnum (NatS# w) | i >= 0 = i - where - i = fromIntegral (W# w) - fromEnum _ = errorWithoutStackTrace "fromEnum: out of Int range" - - enumFrom x = enumDeltaNatural x (NatS# 1##) - enumFromThen x y - | x <= y = enumDeltaNatural x (y-x) - | otherwise = enumNegDeltaToNatural x (x-y) (NatS# 0##) - - enumFromTo x lim = enumDeltaToNatural x (NatS# 1##) lim - enumFromThenTo x y lim - | x <= y = enumDeltaToNatural x (y-x) lim - | otherwise = enumNegDeltaToNatural x (x-y) lim - ----------------------------------------------------------------------------- --- Helpers for 'Enum Natural'; TODO: optimise & make fusion work - -enumDeltaNatural :: Natural -> Natural -> [Natural] -enumDeltaNatural !x d = x : enumDeltaNatural (x+d) d - -enumDeltaToNatural :: Natural -> Natural -> Natural -> [Natural] -enumDeltaToNatural x0 delta lim = go x0 - where - go x | x > lim = [] - | otherwise = x : go (x+delta) - -enumNegDeltaToNatural :: Natural -> Natural -> Natural -> [Natural] -enumNegDeltaToNatural x0 ndelta lim = go x0 - where - go x | x < lim = [] - | x >= ndelta = x : go (x-ndelta) - | otherwise = [x] +lcmNatural x y = (x `quotNatural` (gcdNatural x y)) `timesNatural` y ---------------------------------------------------------------------------- --- | @since 4.8.0.0 -instance Integral Natural where - toInteger (NatS# w) = wordToInteger w - toInteger (NatJ# bn) = Jp# bn - - divMod = quotRem - div = quot - mod = rem - - quotRem _ (NatS# 0##) = divZeroError - quotRem n (NatS# 1##) = (n,NatS# 0##) - quotRem n@(NatS# _) (NatJ# _) = (NatS# 0##, n) - quotRem (NatS# n) (NatS# d) = case quotRem (W# n) (W# d) of - (q,r) -> (wordToNatural q, wordToNatural r) - quotRem (NatJ# n) (NatS# d) = case quotRemBigNatWord n d of - (# q,r #) -> (bigNatToNatural q, NatS# r) - quotRem (NatJ# n) (NatJ# d) = case quotRemBigNat n d of - (# q,r #) -> (bigNatToNatural q, bigNatToNatural r) - - quot _ (NatS# 0##) = divZeroError - quot n (NatS# 1##) = n - quot (NatS# _) (NatJ# _) = NatS# 0## - quot (NatS# n) (NatS# d) = wordToNatural (quot (W# n) (W# d)) - quot (NatJ# n) (NatS# d) = bigNatToNatural (quotBigNatWord n d) - quot (NatJ# n) (NatJ# d) = bigNatToNatural (quotBigNat n d) - - rem _ (NatS# 0##) = divZeroError - rem _ (NatS# 1##) = NatS# 0## - rem n@(NatS# _) (NatJ# _) = n - rem (NatS# n) (NatS# d) = wordToNatural (rem (W# n) (W# d)) - rem (NatJ# n) (NatS# d) = NatS# (remBigNatWord n d) - rem (NatJ# n) (NatJ# d) = bigNatToNatural (remBigNat n d) - --- | @since 4.8.0.0 -instance Ix Natural where - range (m,n) = [m..n] - inRange (m,n) i = m <= i && i <= n - unsafeIndex (m,_) i = fromIntegral (i-m) - index b i | inRange b i = unsafeIndex b i - | otherwise = indexError b i "Natural" - - --- | @since 4.8.0.0 -instance Bits Natural where - NatS# n .&. NatS# m = wordToNatural (W# n .&. W# m) - NatS# n .&. NatJ# m = wordToNatural (W# n .&. W# (bigNatToWord m)) - NatJ# n .&. NatS# m = wordToNatural (W# (bigNatToWord n) .&. W# m) - NatJ# n .&. NatJ# m = bigNatToNatural (andBigNat n m) - - NatS# n .|. NatS# m = wordToNatural (W# n .|. W# m) - NatS# n .|. NatJ# m = NatJ# (orBigNat (wordToBigNat n) m) - NatJ# n .|. NatS# m = NatJ# (orBigNat n (wordToBigNat m)) - NatJ# n .|. NatJ# m = NatJ# (orBigNat n m) - - NatS# n `xor` NatS# m = wordToNatural (W# n `xor` W# m) - NatS# n `xor` NatJ# m = NatJ# (xorBigNat (wordToBigNat n) m) - NatJ# n `xor` NatS# m = NatJ# (xorBigNat n (wordToBigNat m)) - NatJ# n `xor` NatJ# m = bigNatToNatural (xorBigNat n m) - - complement _ = errorWithoutStackTrace "Bits.complement: Natural complement undefined" - - bitSizeMaybe _ = Nothing - bitSize = errorWithoutStackTrace "Natural: bitSize" - isSigned _ = False - - bit i@(I# i#) | i < finiteBitSize (0::Word) = wordToNatural (bit i) - | otherwise = NatJ# (bitBigNat i#) - - testBit (NatS# w) i = testBit (W# w) i - testBit (NatJ# bn) (I# i#) = testBitBigNat bn i# - - clearBit n@(NatS# w#) i - | i < finiteBitSize (0::Word) = let !(W# w2#) = clearBit (W# w#) i in NatS# w2# - | otherwise = n - clearBit (NatJ# bn) (I# i#) = bigNatToNatural (clearBitBigNat bn i#) - - setBit (NatS# w#) i@(I# i#) - | i < finiteBitSize (0::Word) = let !(W# w2#) = setBit (W# w#) i in NatS# w2# - | otherwise = bigNatToNatural (setBitBigNat (wordToBigNat w#) i#) - setBit (NatJ# bn) (I# i#) = bigNatToNatural (setBitBigNat bn i#) - - complementBit (NatS# w#) i@(I# i#) - | i < finiteBitSize (0::Word) = let !(W# w2#) = complementBit (W# w#) i in NatS# w2# - | otherwise = bigNatToNatural (setBitBigNat (wordToBigNat w#) i#) - complementBit (NatJ# bn) (I# i#) = bigNatToNatural (complementBitBigNat bn i#) - - shiftL n 0 = n - shiftL (NatS# 0##) _ = NatS# 0## - shiftL (NatS# 1##) i = bit i - shiftL (NatS# w) (I# i#) - = bigNatToNatural $ shiftLBigNat (wordToBigNat w) i# - shiftL (NatJ# bn) (I# i#) - = bigNatToNatural $ shiftLBigNat bn i# - - shiftR n 0 = n - shiftR (NatS# w) i = wordToNatural $ shiftR (W# w) i - shiftR (NatJ# bn) (I# i#) = bigNatToNatural (shiftRBigNat bn i#) - - rotateL = shiftL - rotateR = shiftR - - popCount (NatS# w) = popCount (W# w) - popCount (NatJ# bn) = I# (popCountBigNat bn) - - zeroBits = NatS# 0## +quotRemNatural :: Natural -> Natural -> (Natural, Natural) +quotRemNatural _ (NatS# 0##) = divZeroError +quotRemNatural n (NatS# 1##) = (n,NatS# 0##) +quotRemNatural n@(NatS# _) (NatJ# _) = (NatS# 0##, n) +quotRemNatural (NatS# n) (NatS# d) = case quotRemWord# n d of + (# q, r #) -> (NatS# q, NatS# r) +quotRemNatural (NatJ# n) (NatS# d) = case quotRemBigNatWord n d of + (# q, r #) -> (bigNatToNatural q, NatS# r) +quotRemNatural (NatJ# n) (NatJ# d) = case quotRemBigNat n d of + (# q, r #) -> (bigNatToNatural q, bigNatToNatural r) +{-# CONSTANT_FOLDED quotRemNatural #-} + +quotNatural :: Natural -> Natural -> Natural +quotNatural _ (NatS# 0##) = divZeroError +quotNatural n (NatS# 1##) = n +quotNatural (NatS# _) (NatJ# _) = NatS# 0## +quotNatural (NatS# n) (NatS# d) = NatS# (quotWord# n d) +quotNatural (NatJ# n) (NatS# d) = bigNatToNatural (quotBigNatWord n d) +quotNatural (NatJ# n) (NatJ# d) = bigNatToNatural (quotBigNat n d) +{-# CONSTANT_FOLDED quotNatural #-} + +remNatural :: Natural -> Natural -> Natural +remNatural _ (NatS# 0##) = divZeroError +remNatural _ (NatS# 1##) = NatS# 0## +remNatural n@(NatS# _) (NatJ# _) = n +remNatural (NatS# n) (NatS# d) = NatS# (remWord# n d) +remNatural (NatJ# n) (NatS# d) = NatS# (remBigNatWord n d) +remNatural (NatJ# n) (NatJ# d) = bigNatToNatural (remBigNat n d) +{-# CONSTANT_FOLDED remNatural #-} + +-- | @since 4.X.0.0 +naturalToInteger :: Natural -> Integer +naturalToInteger (NatS# w) = wordToInteger w +naturalToInteger (NatJ# bn) = Jp# bn +{-# CONSTANT_FOLDED naturalToInteger #-} + +andNatural :: Natural -> Natural -> Natural +andNatural (NatS# n) (NatS# m) = NatS# (n `and#` m) +andNatural (NatS# n) (NatJ# m) = NatS# (n `and#` bigNatToWord m) +andNatural (NatJ# n) (NatS# m) = NatS# (bigNatToWord n `and#` m) +andNatural (NatJ# n) (NatJ# m) = bigNatToNatural (andBigNat n m) +{-# CONSTANT_FOLDED andNatural #-} + +orNatural :: Natural -> Natural -> Natural +orNatural (NatS# n) (NatS# m) = NatS# (n `or#` m) +orNatural (NatS# n) (NatJ# m) = NatJ# (orBigNat (wordToBigNat n) m) +orNatural (NatJ# n) (NatS# m) = NatJ# (orBigNat n (wordToBigNat m)) +orNatural (NatJ# n) (NatJ# m) = NatJ# (orBigNat n m) +{-# CONSTANT_FOLDED orNatural #-} + +xorNatural :: Natural -> Natural -> Natural +xorNatural (NatS# n) (NatS# m) = NatS# (n `xor#` m) +xorNatural (NatS# n) (NatJ# m) = NatJ# (xorBigNat (wordToBigNat n) m) +xorNatural (NatJ# n) (NatS# m) = NatJ# (xorBigNat n (wordToBigNat m)) +xorNatural (NatJ# n) (NatJ# m) = bigNatToNatural (xorBigNat n m) +{-# CONSTANT_FOLDED xorNatural #-} + +bitNatural :: Int# -> Natural +bitNatural i# + | isTrue# (i# <# WORD_SIZE_IN_BITS#) = NatS# (1## `uncheckedShiftL#` i#) + | True = NatJ# (bitBigNat i#) +{-# CONSTANT_FOLDED bitNatural #-} + +testBitNatural :: Natural -> Int -> Bool +testBitNatural (NatS# w) (I# i#) + | isTrue# (i# <# WORD_SIZE_IN_BITS#) = + isTrue# ((w `and#` (1## `uncheckedShiftL#` i#)) `neWord#` 0##) + | True = False +testBitNatural (NatJ# bn) (I# i#) = testBitBigNat bn i# +{-# CONSTANT_FOLDED testBitNatural #-} + +popCountNatural :: Natural -> Int +popCountNatural (NatS# w) = I# (word2Int# (popCnt# w)) +popCountNatural (NatJ# bn) = I# (popCountBigNat bn) +{-# CONSTANT_FOLDED popCountNatural #-} + +shiftLNatural :: Natural -> Int -> Natural +shiftLNatural n (I# 0#) = n +shiftLNatural (NatS# 0##) _ = NatS# 0## +shiftLNatural (NatS# 1##) (I# i#) = bitNatural i# +shiftLNatural (NatS# w) (I# i#) + = bigNatToNatural (shiftLBigNat (wordToBigNat w) i#) +shiftLNatural (NatJ# bn) (I# i#) + = bigNatToNatural (shiftLBigNat bn i#) +{-# CONSTANT_FOLDED shiftLNatural #-} + +shiftRNatural :: Natural -> Int -> Natural +shiftRNatural n (I# 0#) = n +shiftRNatural (NatS# w) (I# i#) + | isTrue# (i# >=# WORD_SIZE_IN_BITS#) = NatS# 0## + | True = NatS# (w `uncheckedShiftRL#` i#) +shiftRNatural (NatJ# bn) (I# i#) = bigNatToNatural (shiftRBigNat bn i#) +{-# CONSTANT_FOLDED shiftRNatural #-} ---------------------------------------------------------------------------- @@ -395,6 +303,7 @@ plusNatural (NatS# x) (NatS# y) plusNatural (NatS# x) (NatJ# y) = NatJ# (plusBigNatWord y x) plusNatural (NatJ# x) (NatS# y) = NatJ# (plusBigNatWord x y) plusNatural (NatJ# x) (NatJ# y) = NatJ# (plusBigNat x y) +{-# CONSTANT_FOLDED plusNatural #-} -- | 'Natural' multiplication timesNatural :: Natural -> Natural -> Natural @@ -405,10 +314,11 @@ timesNatural (NatS# 1##) y = y timesNatural (NatS# x) (NatS# y) = case timesWord2# x y of (# 0##, 0## #) -> NatS# 0## (# 0##, xy #) -> NatS# xy - (# h , l #) -> NatJ# $ wordToBigNat2 h l -timesNatural (NatS# x) (NatJ# y) = NatJ# $ timesBigNatWord y x -timesNatural (NatJ# x) (NatS# y) = NatJ# $ timesBigNatWord x y -timesNatural (NatJ# x) (NatJ# y) = NatJ# $ timesBigNat x y + (# h , l #) -> NatJ# (wordToBigNat2 h l) +timesNatural (NatS# x) (NatJ# y) = NatJ# (timesBigNatWord y x) +timesNatural (NatJ# x) (NatS# y) = NatJ# (timesBigNatWord x y) +timesNatural (NatJ# x) (NatJ# y) = NatJ# (timesBigNat x y) +{-# CONSTANT_FOLDED timesNatural #-} -- | 'Natural' subtraction. May @'throw' 'Underflow'@. minusNatural :: Natural -> Natural -> Natural @@ -418,9 +328,10 @@ minusNatural (NatS# x) (NatS# y) = case subWordC# x y of _ -> underflowError minusNatural (NatS# _) (NatJ# _) = underflowError minusNatural (NatJ# x) (NatS# y) - = bigNatToNatural $ minusBigNatWord x y + = bigNatToNatural (minusBigNatWord x y) minusNatural (NatJ# x) (NatJ# y) - = bigNatToNatural $ minusBigNat x y + = bigNatToNatural (minusBigNat x y) +{-# CONSTANT_FOLDED minusNatural #-} -- | 'Natural' subtraction. Returns 'Nothing's for non-positive results. -- @@ -430,13 +341,12 @@ minusNaturalMaybe x (NatS# 0##) = Just x minusNaturalMaybe (NatS# x) (NatS# y) = case subWordC# x y of (# l, 0# #) -> Just (NatS# l) _ -> Nothing - where minusNaturalMaybe (NatS# _) (NatJ# _) = Nothing minusNaturalMaybe (NatJ# x) (NatS# y) - = Just $ bigNatToNatural $ minusBigNatWord x y + = Just (bigNatToNatural (minusBigNatWord x y)) minusNaturalMaybe (NatJ# x) (NatJ# y) | isTrue# (isNullBigNat# res) = Nothing - | otherwise = Just (bigNatToNatural res) + | True = Just (bigNatToNatural res) where res = minusBigNat x y @@ -446,18 +356,12 @@ bigNatToNatural :: BigNat -> Natural bigNatToNatural bn | isTrue# (sizeofBigNat# bn ==# 1#) = NatS# (bigNatToWord bn) | isTrue# (isNullBigNat# bn) = underflowError - | otherwise = NatJ# bn + | True = NatJ# bn naturalToBigNat :: Natural -> BigNat naturalToBigNat (NatS# w#) = wordToBigNat w# naturalToBigNat (NatJ# bn) = bn --- | Convert 'Int' to 'Natural'. --- Throws 'Underflow' when passed a negative 'Int'. -intToNatural :: Int -> Natural -intToNatural i | i<0 = underflowError -intToNatural (I# i#) = NatS# (int2Word# i#) - naturalToWord :: Natural -> Word naturalToWord (NatS# w#) = W# w# naturalToWord (NatJ# bn) = W# (bigNatToWord bn) @@ -466,6 +370,23 @@ naturalToInt :: Natural -> Int naturalToInt (NatS# w#) = I# (word2Int# w#) naturalToInt (NatJ# bn) = I# (bigNatToInt bn) +---------------------------------------------------------------------------- + +-- | Convert a Word# into a Natural +-- +-- Built-in rule ensures that applications of this function to literal Word# are +-- lifted into Natural literals. +wordToNatural# :: Word# -> Natural +wordToNatural# w# = NatS# w# +{-# CONSTANT_FOLDED wordToNatural# #-} + +-- | Convert a Word# into a Natural +-- +-- In base we can't use wordToNatural# as built-in rules transform some of them +-- into Natural literals. Use this function instead. +wordToNaturalBase :: Word# -> Natural +wordToNaturalBase w# = NatS# w# + #else /* !defined(MIN_VERSION_integer_gmp) */ ---------------------------------------------------------------------------- -- Use wrapped 'Integer' as fallback; taken from Edward Kmett's nats package @@ -477,156 +398,141 @@ naturalToInt (NatJ# bn) = I# (bigNatToInt bn) -- -- @since 4.8.0.0 newtype Natural = Natural Integer -- ^ __Invariant__: non-negative 'Integer' - deriving (Eq,Ord,Ix) + deriving (Eq,Ord) + -- | Test whether all internal invariants are satisfied by 'Natural' value -- -- This operation is mostly useful for test-suites and/or code which --- constructs 'Integer' values directly. +-- constructs 'Natural' values directly. -- -- @since 4.8.0.0 isValidNatural :: Natural -> Bool -isValidNatural (Natural i) = i >= 0 - --- | @since 4.8.0.0 -instance Read Natural where - readsPrec d = map (\(n, s) -> (Natural n, s)) - . filter ((>= 0) . (\(x,_)->x)) . readsPrec d - --- | @since 4.8.0.0 -instance Show Natural where - showsPrec d (Natural i) = showsPrec d i - --- | @since 4.8.0.0 -instance Num Natural where - Natural n + Natural m = Natural (n + m) - {-# INLINE (+) #-} - Natural n * Natural m = Natural (n * m) - {-# INLINE (*) #-} - Natural n - Natural m | result < 0 = underflowError - | otherwise = Natural result - where result = n - m - {-# INLINE (-) #-} - abs (Natural n) = Natural n - {-# INLINE abs #-} - signum (Natural n) = Natural (signum n) - {-# INLINE signum #-} - fromInteger = naturalFromInteger - {-# INLINE fromInteger #-} +isValidNatural (Natural i) = i >= wordToInteger 0## + +-- | Convert a Word# into a Natural +-- +-- Built-in rule ensures that applications of this function to literal Word# are +-- lifted into Natural literals. +wordToNatural# :: Word# -> Natural +wordToNatural# w## = Natural (wordToInteger w##) +{-# CONSTANT_FOLDED wordToNatural# #-} + +-- | Convert a Word# into a Natural +-- +-- In base we can't use wordToNatural# as built-in rules transform some of them +-- into Natural literals. Use this function instead. +wordToNaturalBase :: Word# -> Natural +wordToNaturalBase w## = Natural (wordToInteger w##) -- | @since 4.10.0.0 naturalFromInteger :: Integer -> Natural naturalFromInteger n - | n >= 0 = Natural n - | otherwise = underflowError + | n >= wordToInteger 0## = Natural n + | True = underflowError {-# INLINE naturalFromInteger #-} -- | 'Natural' subtraction. Returns 'Nothing's for non-positive results. -- -- @since 4.8.0.0 minusNaturalMaybe :: Natural -> Natural -> Maybe Natural -minusNaturalMaybe x y - | x >= y = Just (x - y) - | otherwise = Nothing - --- | @since 4.8.0.0 -instance Bits Natural where - Natural n .&. Natural m = Natural (n .&. m) - {-# INLINE (.&.) #-} - Natural n .|. Natural m = Natural (n .|. m) - {-# INLINE (.|.) #-} - xor (Natural n) (Natural m) = Natural (xor n m) - {-# INLINE xor #-} - complement _ = errorWithoutStackTrace "Bits.complement: Natural complement undefined" - {-# INLINE complement #-} - shift (Natural n) = Natural . shift n - {-# INLINE shift #-} - rotate (Natural n) = Natural . rotate n - {-# INLINE rotate #-} - bit = Natural . bit - {-# INLINE bit #-} - setBit (Natural n) = Natural . setBit n - {-# INLINE setBit #-} - clearBit (Natural n) = Natural . clearBit n - {-# INLINE clearBit #-} - complementBit (Natural n) = Natural . complementBit n - {-# INLINE complementBit #-} - testBit (Natural n) = testBit n - {-# INLINE testBit #-} - bitSizeMaybe _ = Nothing - {-# INLINE bitSizeMaybe #-} - bitSize = errorWithoutStackTrace "Natural: bitSize" - {-# INLINE bitSize #-} - isSigned _ = False - {-# INLINE isSigned #-} - shiftL (Natural n) = Natural . shiftL n - {-# INLINE shiftL #-} - shiftR (Natural n) = Natural . shiftR n - {-# INLINE shiftR #-} - rotateL (Natural n) = Natural . rotateL n - {-# INLINE rotateL #-} - rotateR (Natural n) = Natural . rotateR n - {-# INLINE rotateR #-} - popCount (Natural n) = popCount n - {-# INLINE popCount #-} - zeroBits = Natural 0 - --- | @since 4.8.0.0 -instance Real Natural where - toRational (Natural a) = toRational a - {-# INLINE toRational #-} - --- | @since 4.8.0.0 -instance Enum Natural where - pred (Natural 0) = errorWithoutStackTrace "Natural.pred: 0" - pred (Natural n) = Natural (pred n) - {-# INLINE pred #-} - succ (Natural n) = Natural (succ n) - {-# INLINE succ #-} - fromEnum (Natural n) = fromEnum n - {-# INLINE fromEnum #-} - toEnum n | n < 0 = errorWithoutStackTrace "Natural.toEnum: negative" - | otherwise = Natural (toEnum n) - {-# INLINE toEnum #-} - - enumFrom = coerce (enumFrom :: Integer -> [Integer]) - enumFromThen x y - | x <= y = coerce (enumFromThen :: Integer -> Integer -> [Integer]) x y - | otherwise = enumFromThenTo x y 0 - - enumFromTo = coerce (enumFromTo :: Integer -> Integer -> [Integer]) - enumFromThenTo - = coerce (enumFromThenTo :: Integer -> Integer -> Integer -> [Integer]) - --- | @since 4.8.0.0 -instance Integral Natural where - quot (Natural a) (Natural b) = Natural (quot a b) - {-# INLINE quot #-} - rem (Natural a) (Natural b) = Natural (rem a b) - {-# INLINE rem #-} - div (Natural a) (Natural b) = Natural (div a b) - {-# INLINE div #-} - mod (Natural a) (Natural b) = Natural (mod a b) - {-# INLINE mod #-} - divMod (Natural a) (Natural b) = (Natural q, Natural r) - where (q,r) = divMod a b - {-# INLINE divMod #-} - quotRem (Natural a) (Natural b) = (Natural q, Natural r) - where (q,r) = quotRem a b - {-# INLINE quotRem #-} - toInteger (Natural a) = a - {-# INLINE toInteger #-} +minusNaturalMaybe (Natural x) (Natural y) + | x >= y = Just (Natural (x `minusInteger` y)) + | True = Nothing + +shiftLNatural :: Natural -> Int -> Natural +shiftLNatural (Natural n) (I# i) = Natural (n `shiftLInteger` i) +{-# CONSTANT_FOLDED shiftLNatural #-} + +shiftRNatural :: Natural -> Int -> Natural +shiftRNatural (Natural n) (I# i) = Natural (n `shiftRInteger` i) +{-# CONSTANT_FOLDED shiftRNatural #-} + +plusNatural :: Natural -> Natural -> Natural +plusNatural (Natural x) (Natural y) = Natural (x `plusInteger` y) +{-# CONSTANT_FOLDED plusNatural #-} + +minusNatural :: Natural -> Natural -> Natural +minusNatural (Natural x) (Natural y) = Natural (x `minusInteger` y) +{-# CONSTANT_FOLDED minusNatural #-} + +timesNatural :: Natural -> Natural -> Natural +timesNatural (Natural x) (Natural y) = Natural (x `timesInteger` y) +{-# CONSTANT_FOLDED timesNatural #-} + +orNatural :: Natural -> Natural -> Natural +orNatural (Natural x) (Natural y) = Natural (x `orInteger` y) +{-# CONSTANT_FOLDED orNatural #-} + +xorNatural :: Natural -> Natural -> Natural +xorNatural (Natural x) (Natural y) = Natural (x `xorInteger` y) +{-# CONSTANT_FOLDED xorNatural #-} + +andNatural :: Natural -> Natural -> Natural +andNatural (Natural x) (Natural y) = Natural (x `andInteger` y) +{-# CONSTANT_FOLDED andNatural #-} + +naturalToInt :: Natural -> Int +naturalToInt (Natural i) = I# (integerToInt i) + +naturalToWord :: Natural -> Word +naturalToWord (Natural i) = W# (integerToWord i) + +naturalToInteger :: Natural -> Integer +naturalToInteger (Natural i) = i +{-# CONSTANT_FOLDED naturalToInteger #-} + +testBitNatural :: Natural -> Int -> Bool +testBitNatural (Natural n) (I# i) = testBitInteger n i +{-# CONSTANT_FOLDED testBitNatural #-} + +bitNatural :: Int# -> Natural +bitNatural i# + | isTrue# (i# <# WORD_SIZE_IN_BITS#) = wordToNaturalBase (1## `uncheckedShiftL#` i#) + | True = Natural (1 `shiftLInteger` i#) +{-# CONSTANT_FOLDED bitNatural #-} + +quotNatural :: Natural -> Natural -> Natural +quotNatural n@(Natural x) (Natural y) + | y == wordToInteger 0## = divZeroError + | y == wordToInteger 1## = n + | True = Natural (x `quotInteger` y) +{-# CONSTANT_FOLDED quotNatural #-} + +remNatural :: Natural -> Natural -> Natural +remNatural (Natural x) (Natural y) + | y == wordToInteger 0## = divZeroError + | y == wordToInteger 1## = wordToNaturalBase 0## + | True = Natural (x `remInteger` y) +{-# CONSTANT_FOLDED remNatural #-} + +quotRemNatural :: Natural -> Natural -> (Natural, Natural) +quotRemNatural n@(Natural x) (Natural y) + | y == wordToInteger 0## = divZeroError + | y == wordToInteger 1## = (n,wordToNaturalBase 0##) + | True = case quotRemInteger x y of + (# k, r #) -> (Natural k, Natural r) +{-# CONSTANT_FOLDED quotRemNatural #-} + +signumNatural :: Natural -> Natural +signumNatural (Natural x) + | x == wordToInteger 0## = wordToNaturalBase 0## + | True = wordToNaturalBase 1## +{-# CONSTANT_FOLDED signumNatural #-} + +negateNatural :: Natural -> Natural +negateNatural (Natural x) + | x == wordToInteger 0## = wordToNaturalBase 0## + | True = underflowError +{-# CONSTANT_FOLDED negateNatural #-} + #endif -- | Construct 'Natural' from 'Word' value. -- -- @since 4.8.0.0 wordToNatural :: Word -> Natural -#if defined(MIN_VERSION_integer_gmp) -wordToNatural (W# w#) = NatS# w# -#else -wordToNatural w = Natural (fromIntegral w) -#endif +wordToNatural (W# w#) = wordToNatural# w# -- | Try downcasting 'Natural' to 'Word' value. -- Returns 'Nothing' if value doesn't fit in 'Word'. @@ -638,10 +544,10 @@ naturalToWordMaybe (NatS# w#) = Just (W# w#) naturalToWordMaybe (NatJ# _) = Nothing #else naturalToWordMaybe (Natural i) - | i <= maxw = Just (fromIntegral i) - | otherwise = Nothing + | i < maxw = Just (W# (integerToWord i)) + | True = Nothing where - maxw = toInteger (maxBound :: Word) + maxw = 1 `shiftLInteger` WORD_SIZE_IN_BITS# #endif -- | \"@'powModNatural' /b/ /e/ /m/@\" computes base @/b/@ raised to @@ -662,18 +568,38 @@ powModNatural b e (NatJ# m) = bigNatToNatural (powModBigNat (naturalToBigNat b) (naturalToBigNat e) m) #else -- Portable reference fallback implementation -powModNatural _ _ 0 = divZeroError -powModNatural _ _ 1 = 0 -powModNatural _ 0 _ = 1 -powModNatural 0 _ _ = 0 -powModNatural 1 _ _ = 1 -powModNatural b0 e0 m = go b0 e0 1 +powModNatural (Natural b0) (Natural e0) (Natural m) + | m == wordToInteger 0## = divZeroError + | m == wordToInteger 1## = wordToNaturalBase 0## + | e0 == wordToInteger 0## = wordToNaturalBase 1## + | b0 == wordToInteger 0## = wordToNaturalBase 0## + | b0 == wordToInteger 1## = wordToNaturalBase 1## + | True = go b0 e0 (wordToInteger 1##) where go !b e !r - | odd e = go b' e' (r*b `mod` m) - | e == 0 = r - | otherwise = go b' e' r + | e `testBitInteger` 0# = go b' e' ((r `timesInteger` b) `modInteger` m) + | e == wordToInteger 0## = naturalFromInteger r + | True = go b' e' r where - b' = b*b `mod` m - e' = e `unsafeShiftR` 1 -- slightly faster than "e `div` 2" + b' = (b `timesInteger` b) `modInteger` m + e' = e `shiftRInteger` 1# -- slightly faster than "e `div` 2" #endif + + +-- | Construct 'Natural' value from list of 'Word's. +-- +-- This function is used by GHC for constructing 'Natural' literals. +mkNatural :: [Word] -- ^ value expressed in 32 bit chunks, least + -- significant first + -> Natural +mkNatural [] = wordToNaturalBase 0## +mkNatural (W# i : is') = wordToNaturalBase (i `and#` 0xffffffff##) `orNatural` + shiftLNatural (mkNatural is') 31 +{-# CONSTANT_FOLDED mkNatural #-} + +-- | Convert 'Int' to 'Natural'. +-- Throws 'Underflow' when passed a negative 'Int'. +intToNatural :: Int -> Natural +intToNatural (I# i#) + | isTrue# (i# <# 0#) = underflowError + | True = wordToNaturalBase (int2Word# i#) diff --git a/libraries/base/GHC/Num.hs b/libraries/base/GHC/Num.hs index fd98c19f20..795e74a4af 100644 --- a/libraries/base/GHC/Num.hs +++ b/libraries/base/GHC/Num.hs @@ -1,5 +1,5 @@ {-# LANGUAGE Trustworthy #-} -{-# LANGUAGE NoImplicitPrelude, MagicHash, UnboxedTuples #-} +{-# LANGUAGE CPP, NoImplicitPrelude, MagicHash, UnboxedTuples #-} {-# OPTIONS_HADDOCK hide #-} ----------------------------------------------------------------------------- @@ -16,10 +16,17 @@ -- ----------------------------------------------------------------------------- -module GHC.Num (module GHC.Num, module GHC.Integer) where + +module GHC.Num (module GHC.Num, module GHC.Integer, module GHC.Natural) where + +#include "MachDeps.h" import GHC.Base import GHC.Integer +import GHC.Natural +#if !defined(MIN_VERSION_integer_gmp) +import {-# SOURCE #-} GHC.Exception.Type (underflowException) +#endif infixl 7 * infixl 6 +, - @@ -100,3 +107,35 @@ instance Num Integer where abs = absInteger signum = signumInteger + +#if defined(MIN_VERSION_integer_gmp) +-- | @since 4.8.0.0 +instance Num Natural where + (+) = plusNatural + (-) = minusNatural + (*) = timesNatural + negate = negateNatural + fromInteger = naturalFromInteger + + abs = id + signum = signumNatural + +#else +-- | @since 4.8.0.0 +instance Num Natural where + Natural n + Natural m = Natural (n + m) + {-# INLINE (+) #-} + Natural n * Natural m = Natural (n * m) + {-# INLINE (*) #-} + Natural n - Natural m + | m > n = raise# underflowException + | otherwise = Natural (n - m) + {-# INLINE (-) #-} + abs (Natural n) = Natural n + {-# INLINE abs #-} + signum (Natural n) = Natural (signum n) + {-# INLINE signum #-} + fromInteger = naturalFromInteger + {-# INLINE fromInteger #-} + +#endif diff --git a/libraries/base/GHC/Read.hs b/libraries/base/GHC/Read.hs index f7870a2df1..ef9d8df2e5 100644 --- a/libraries/base/GHC/Read.hs +++ b/libraries/base/GHC/Read.hs @@ -72,6 +72,7 @@ import GHC.Show import GHC.Base import GHC.Arr import GHC.Word +import GHC.List (filter) -- | @'readParen' 'True' p@ parses what @p@ parses, but surrounded with @@ -616,6 +617,19 @@ instance Read Integer where readListPrec = readListPrecDefault readList = readListDefault + +#if defined(MIN_VERSION_integer_gmp) +-- | @since 4.8.0.0 +instance Read Natural where + readsPrec d = map (\(n, s) -> (fromInteger n, s)) + . filter ((>= 0) . (\(x,_)->x)) . readsPrec d +#else +-- | @since 4.8.0.0 +instance Read Natural where + readsPrec d = map (\(n, s) -> (Natural n, s)) + . filter ((>= 0) . (\(x,_)->x)) . readsPrec d +#endif + -- | @since 2.01 instance Read Float where readPrec = readNumber convertFrac diff --git a/libraries/base/GHC/Real.hs b/libraries/base/GHC/Real.hs index 7f2ecd0dc5..f88666af40 100644 --- a/libraries/base/GHC/Real.hs +++ b/libraries/base/GHC/Real.hs @@ -20,12 +20,16 @@ module GHC.Real where +#include "MachDeps.h" + import GHC.Base import GHC.Num import GHC.List import GHC.Enum import GHC.Show -import {-# SOURCE #-} GHC.Exception( divZeroException, overflowException, ratioZeroDenomException ) +import {-# SOURCE #-} GHC.Exception( divZeroException, overflowException + , underflowException + , ratioZeroDenomException ) #if defined(OPTIMISE_INTEGER_GCD_LCM) # if defined(MIN_VERSION_integer_gmp) @@ -61,6 +65,11 @@ ratioZeroDenominatorError = raise# ratioZeroDenomException overflowError :: a overflowError = raise# overflowException +{-# NOINLINE underflowError #-} +underflowError :: a +underflowError = raise# underflowException + + -------------------------------------------------------------- -- The Ratio and Rational types -------------------------------------------------------------- @@ -376,6 +385,18 @@ instance Integral Word where instance Real Integer where toRational x = x :% 1 +#if defined(MIN_VERSION_integer_gmp) +-- | @since 4.8.0.0 +instance Real Natural where + toRational (NatS# w) = toRational (W# w) + toRational (NatJ# bn) = toRational (Jp# bn) +#else +-- | @since 4.8.0.0 +instance Real Natural where + toRational (Natural a) = toRational a + {-# INLINE toRational #-} +#endif + -- Note [Integer division constant folding] -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -- @@ -418,6 +439,39 @@ instance Integral Integer where n `quotRem` d = case n `quotRemInteger` d of (# q, r #) -> (q, r) +#if defined(MIN_VERSION_integer_gmp) +-- | @since 4.8.0.0 +instance Integral Natural where + toInteger = naturalToInteger + + divMod = quotRemNatural + div = quotNatural + mod = remNatural + + quotRem = quotRemNatural + quot = quotNatural + rem = remNatural +#else +-- | @since 4.8.0.0 +instance Integral Natural where + quot (Natural a) (Natural b) = Natural (quot a b) + {-# INLINE quot #-} + rem (Natural a) (Natural b) = Natural (rem a b) + {-# INLINE rem #-} + div (Natural a) (Natural b) = Natural (div a b) + {-# INLINE div #-} + mod (Natural a) (Natural b) = Natural (mod a b) + {-# INLINE mod #-} + divMod (Natural a) (Natural b) = (Natural q, Natural r) + where (q,r) = divMod a b + {-# INLINE divMod #-} + quotRem (Natural a) (Natural b) = (Natural q, Natural r) + where (q,r) = quotRem a b + {-# INLINE quotRem #-} + toInteger (Natural a) = a + {-# INLINE toInteger #-} +#endif + -------------------------------------------------------------- -- Instances for @Ratio@ -------------------------------------------------------------- @@ -506,6 +560,17 @@ fromIntegral = fromInteger . toInteger "fromIntegral/Word->Word" fromIntegral = id :: Word -> Word #-} +{-# RULES +"fromIntegral/Natural->Natural" fromIntegral = id :: Natural -> Natural +"fromIntegral/Natural->Integer" fromIntegral = toInteger :: Natural->Integer +"fromIntegral/Natural->Word" fromIntegral = naturalToWord + #-} + +{-# RULES +"fromIntegral/Word->Natural" fromIntegral = wordToNatural +"fromIntegral/Int->Natural" fromIntegral = intToNatural + #-} + -- | general coercion to fractional types realToFrac :: (Real a, Fractional b) => a -> b {-# NOINLINE [1] realToFrac #-} @@ -698,6 +763,8 @@ lcm x y = abs ((x `quot` (gcd x y)) * y) "gcd/Int->Int->Int" gcd = gcdInt' "gcd/Integer->Integer->Integer" gcd = gcdInteger "lcm/Integer->Integer->Integer" lcm = lcmInteger +"gcd/Natural->Natural->Natural" gcd = gcdNatural +"lcm/Natural->Natural->Natural" lcm = lcmNatural #-} gcdInt' :: Int -> Int -> Int diff --git a/libraries/base/GHC/Show.hs b/libraries/base/GHC/Show.hs index 798dff9891..a41bf81cb3 100644 --- a/libraries/base/GHC/Show.hs +++ b/libraries/base/GHC/Show.hs @@ -479,6 +479,13 @@ instance Show Integer where | otherwise = integerToString n r showList = showList__ (showsPrec 0) +-- | @since 4.8.0.0 +instance Show Natural where +#if defined(MIN_VERSION_integer_gmp) + showsPrec p (NatS# w#) = showsPrec p (W# w#) +#endif + showsPrec p i = showsPrec p (naturalToInteger i) + -- Divide and conquer implementation of string conversion integerToString :: Integer -> String -> String integerToString n0 cs0 diff --git a/libraries/base/GHC/Stack/Types.hs b/libraries/base/GHC/Stack/Types.hs index d40342c9de..4c8a106ae5 100644 --- a/libraries/base/GHC/Stack/Types.hs +++ b/libraries/base/GHC/Stack/Types.hs @@ -53,6 +53,7 @@ import GHC.Types (Char, Int) -- Make implicit dependency known to build system import GHC.Tuple () import GHC.Integer () +import GHC.Natural () ---------------------------------------------------------------------- -- Explicit call-stacks built via ImplicitParams diff --git a/libraries/base/GHC/Word.hs b/libraries/base/GHC/Word.hs index 1df9d14693..18cc4dbcc4 100644 --- a/libraries/base/GHC/Word.hs +++ b/libraries/base/GHC/Word.hs @@ -972,3 +972,33 @@ byteSwap64 (W64# w#) = W64# (byteSwap64# w#) byteSwap64 :: Word64 -> Word64 byteSwap64 (W64# w#) = W64# (byteSwap# w#) #endif + +------------------------------------------------------------------------------- + +{-# RULES +"fromIntegral/Natural->Word8" + fromIntegral = (fromIntegral :: Word -> Word8) . naturalToWord +"fromIntegral/Natural->Word16" + fromIntegral = (fromIntegral :: Word -> Word16) . naturalToWord +"fromIntegral/Natural->Word32" + fromIntegral = (fromIntegral :: Word -> Word32) . naturalToWord + #-} + +{-# RULES +"fromIntegral/Word8->Natural" + fromIntegral = wordToNatural . (fromIntegral :: Word8 -> Word) +"fromIntegral/Word16->Natural" + fromIntegral = wordToNatural . (fromIntegral :: Word16 -> Word) +"fromIntegral/Word32->Natural" + fromIntegral = wordToNatural . (fromIntegral :: Word32 -> Word) + #-} + +#if WORD_SIZE_IN_BITS == 64 +-- these RULES are valid for Word==Word64 +{-# RULES +"fromIntegral/Natural->Word64" + fromIntegral = (fromIntegral :: Word -> Word64) . naturalToWord +"fromIntegral/Word64->Natural" + fromIntegral = wordToNatural . (fromIntegral :: Word64 -> Word) + #-} +#endif diff --git a/libraries/base/Unsafe/Coerce.hs b/libraries/base/Unsafe/Coerce.hs index df1c109e0e..d9a7977e43 100644 --- a/libraries/base/Unsafe/Coerce.hs +++ b/libraries/base/Unsafe/Coerce.hs @@ -32,6 +32,7 @@ module Unsafe.Coerce (unsafeCoerce) where import GHC.Integer () -- for build ordering +import GHC.Natural () -- for build ordering import GHC.Prim (unsafeCoerce#) local_id :: a -> a diff --git a/libraries/base/base.cabal b/libraries/base/base.cabal index 1d439be322..dbeec3388d 100644 --- a/libraries/base/base.cabal +++ b/libraries/base/base.cabal @@ -219,6 +219,7 @@ Library GHC.Environment GHC.Err GHC.Exception + GHC.Exception.Type GHC.ExecutionStack GHC.ExecutionStack.Internal GHC.Exts @@ -258,6 +259,7 @@ Library GHC.IORef GHC.Int GHC.List + GHC.Maybe GHC.MVar GHC.Natural GHC.Num diff --git a/libraries/template-haskell/Language/Haskell/TH/Syntax.hs b/libraries/template-haskell/Language/Haskell/TH/Syntax.hs index 95ece50bcc..eb517a9247 100644 --- a/libraries/template-haskell/Language/Haskell/TH/Syntax.hs +++ b/libraries/template-haskell/Language/Haskell/TH/Syntax.hs @@ -731,8 +731,8 @@ trueName = mkNameG DataName "ghc-prim" "GHC.Types" "True" falseName = mkNameG DataName "ghc-prim" "GHC.Types" "False" nothingName, justName :: Name -nothingName = mkNameG DataName "base" "GHC.Base" "Nothing" -justName = mkNameG DataName "base" "GHC.Base" "Just" +nothingName = mkNameG DataName "base" "GHC.Maybe" "Nothing" +justName = mkNameG DataName "base" "GHC.Maybe" "Just" leftName, rightName :: Name leftName = mkNameG DataName "base" "Data.Either" "Left" |