Built-in Natural literals in Core
authorSylvain Henry <hsyl20@gmail.com>
Fri, 15 Jun 2018 20:23:53 +0000 (16:23 -0400)
committerBen Gamari <ben@smart-cactus.org>
Fri, 15 Jun 2018 20:23:54 +0000 (16:23 -0400)
Add support for built-in Natural literals in Core.

- Replace MachInt,MachWord, LitInteger, etc. with a single LitNumber
  constructor with a LitNumType field
- Support built-in Natural literals
- Add desugar warning for negative literals
- Move Maybe(..) from GHC.Base to GHC.Maybe for module dependency
  reasons

This patch introduces only a few rules for Natural literals (compared
to Integer's rules). Factorization of the built-in rules for numeric
literals will be done in another patch as this one is already big to
review.

Test Plan:
  validate
  test build with integer-simple

Reviewers: hvr, bgamari, goldfire, Bodigrim, simonmar

Reviewed By: bgamari

Subscribers: phadej, simonpj, RyanGlScott, carter, hsyl20, rwbarton,
thomie

GHC Trac Issues: #14170, #14465

Differential Revision: https://phabricator.haskell.org/D4212

80 files changed:
compiler/basicTypes/Literal.hs
compiler/codeGen/StgCmmCon.hs
compiler/codeGen/StgCmmUtils.hs
compiler/coreSyn/CorePrep.hs
compiler/coreSyn/CoreUnfold.hs
compiler/coreSyn/CoreUtils.hs
compiler/coreSyn/MkCore.hs
compiler/deSugar/MatchLit.hs
compiler/ghci/ByteCodeAsm.hs
compiler/ghci/ByteCodeGen.hs
compiler/iface/TcIface.hs
compiler/main/TidyPgm.hs
compiler/prelude/PrelNames.hs
compiler/prelude/PrelRules.hs
compiler/prelude/TysWiredIn.hs
compiler/simplStg/UnariseStg.hs
compiler/stgSyn/CoreToStg.hs
libraries/base/Data/Bits.hs
libraries/base/Data/Data.hs
libraries/base/GHC/Arr.hs
libraries/base/GHC/Base.hs
libraries/base/GHC/Base.hs-boot
libraries/base/GHC/Enum.hs
libraries/base/GHC/Err.hs
libraries/base/GHC/Exception.hs
libraries/base/GHC/Exception.hs-boot
libraries/base/GHC/Exception/Type.hs [new file with mode: 0644]
libraries/base/GHC/Exception/Type.hs-boot [new file with mode: 0644]
libraries/base/GHC/Int.hs
libraries/base/GHC/Maybe.hs [new file with mode: 0644]
libraries/base/GHC/Natural.hs
libraries/base/GHC/Num.hs
libraries/base/GHC/Read.hs
libraries/base/GHC/Real.hs
libraries/base/GHC/Show.hs
libraries/base/GHC/Stack/Types.hs
libraries/base/GHC/Word.hs
libraries/base/Unsafe/Coerce.hs
libraries/base/base.cabal
libraries/template-haskell/Language/Haskell/TH/Syntax.hs
testsuite/tests/ado/T13242a.stderr
testsuite/tests/generics/GenDerivOutput.stderr
testsuite/tests/generics/GenDerivOutput1_0.stderr
testsuite/tests/generics/GenDerivOutput1_1.stderr
testsuite/tests/generics/T10604/T10604_deriving.stderr
testsuite/tests/ghci.debugger/scripts/break006.stderr
testsuite/tests/ghci.debugger/scripts/print019.stderr
testsuite/tests/ghci/scripts/Defer02.stderr
testsuite/tests/ghci/scripts/T10963.stderr
testsuite/tests/ghci/scripts/T4175.stdout
testsuite/tests/indexed-types/should_fail/T12522a.stderr
testsuite/tests/numeric/should_compile/Makefile
testsuite/tests/numeric/should_compile/T14170.hs [new file with mode: 0644]
testsuite/tests/numeric/should_compile/T14170.stdout [new file with mode: 0644]
testsuite/tests/numeric/should_compile/T14465.hs [new file with mode: 0644]
testsuite/tests/numeric/should_compile/T14465.stderr [new file with mode: 0644]
testsuite/tests/numeric/should_compile/T14465.stdout [new file with mode: 0644]
testsuite/tests/numeric/should_compile/all.T
testsuite/tests/overloadedlists/should_fail/overloadedlistsfail01.stderr
testsuite/tests/partial-sigs/should_fail/T10999.stderr
testsuite/tests/plugins/plugins09.stdout
testsuite/tests/plugins/plugins11.stdout
testsuite/tests/simplCore/should_compile/spec-inline.stderr
testsuite/tests/th/ClosedFam1TH.stderr
testsuite/tests/th/T14060.stdout
testsuite/tests/th/T4135.stderr
testsuite/tests/th/T5037.stderr
testsuite/tests/th/T8953.stderr
testsuite/tests/th/TH_RichKinds2.stderr
testsuite/tests/th/TH_reifyDecl2.stderr
testsuite/tests/th/TH_repGuard.stderr
testsuite/tests/typecheck/should_compile/T14273.stderr
testsuite/tests/typecheck/should_compile/holes2.stderr
testsuite/tests/typecheck/should_compile/valid_hole_fits.stderr
testsuite/tests/typecheck/should_fail/T14884.stderr
testsuite/tests/typecheck/should_fail/T5095.stderr
testsuite/tests/typecheck/should_fail/tcfail008.stderr
testsuite/tests/typecheck/should_fail/tcfail072.stderr
testsuite/tests/typecheck/should_fail/tcfail133.stderr
testsuite/tests/typecheck/should_fail/tcfail182.stderr

index 0392a98..21f4a92 100644 (file)
@@ -5,12 +5,13 @@
 \section[Literal]{@Literal@: Machine literals (unboxed, of course)}
 -}
 
-{-# LANGUAGE CPP, DeriveDataTypeable #-}
+{-# LANGUAGE CPP, DeriveDataTypeable, ScopedTypeVariables #-}
 
 module Literal
         (
         -- * Main data type
           Literal(..)           -- Exported to ParseIface
+        , LitNumType(..)
 
         -- ** Creating Literals
         , mkMachInt, mkMachIntWrap, mkMachIntWrapC
@@ -19,12 +20,15 @@ module Literal
         , mkMachWord64, mkMachWord64Wrap
         , mkMachFloat, mkMachDouble
         , mkMachChar, mkMachString
-        , mkLitInteger
+        , mkLitInteger, mkLitNatural
+        , mkLitNumber, mkLitNumberWrap
 
         -- ** Operations on Literals
         , literalType
         , absentLiteralOf
         , pprLiteral
+        , litNumIsSigned
+        , litNumCheckRange
 
         -- ** Predicates on Literals and their contents
         , litIsDupable, litIsTrivial, litIsLifted
@@ -35,6 +39,7 @@ module Literal
 
         -- ** Coercions
         , word2IntLit, int2WordLit
+        , narrowLit
         , narrow8IntLit, narrow16IntLit, narrow32IntLit
         , narrow8WordLit, narrow16WordLit, narrow32WordLit
         , char2IntLit, int2CharLit
@@ -66,6 +71,7 @@ import Data.Word
 import Data.Char
 import Data.Maybe ( isJust )
 import Data.Data ( Data )
+import Data.Proxy
 import Numeric ( fromRat )
 
 {-
@@ -95,6 +101,10 @@ data Literal
         -- First the primitive guys
     MachChar    Char            -- ^ @Char#@ - at least 31 bits. Create with 'mkMachChar'
 
+  | LitNumber !LitNumType !Integer Type
+      --  ^ Any numeric literal that can be
+      -- internally represented with an Integer
+
   | MachStr     ByteString      -- ^ A string-literal: stored and emitted
                                 -- UTF-8 encoded, we'll arrange to decode it
                                 -- at runtime.  Also emitted with a @'\0'@
@@ -104,11 +114,6 @@ data Literal
                                 -- that can be represented as a Literal. Create
                                 -- with 'nullAddrLit'
 
-  | MachInt     Integer         -- ^ @Int#@ - according to target machine
-  | MachInt64   Integer         -- ^ @Int64#@ - exactly 64 bits
-  | MachWord    Integer         -- ^ @Word#@ - according to target machine
-  | MachWord64  Integer         -- ^ @Word64#@ - exactly 64 bits
-
   | MachFloat   Rational        -- ^ @Float#@. Create with 'mkMachFloat'
   | MachDouble  Rational        -- ^ @Double#@. Create with 'mkMachDouble'
 
@@ -123,11 +128,28 @@ data Literal
                 --    the label expects. Only applicable with
                 --    @stdcall@ labels. @Just x@ => @\<x\>@ will
                 --    be appended to label name when emitting assembly.
-
-  | LitInteger Integer Type --  ^ Integer literals
-                            -- See Note [Integer literals]
   deriving Data
 
+-- | Numeric literal type
+data LitNumType
+  = LitNumInteger -- ^ @Integer@ (see Note [Integer literals])
+  | LitNumNatural -- ^ @Natural@ (see Note [Natural literals])
+  | LitNumInt     -- ^ @Int#@ - according to target machine
+  | LitNumInt64   -- ^ @Int64#@ - exactly 64 bits
+  | LitNumWord    -- ^ @Word#@ - according to target machine
+  | LitNumWord64  -- ^ @Word64#@ - exactly 64 bits
+  deriving (Data,Enum,Eq,Ord)
+
+-- | Indicate if a numeric literal type supports negative numbers
+litNumIsSigned :: LitNumType -> Bool
+litNumIsSigned nt = case nt of
+  LitNumInteger -> True
+  LitNumNatural -> False
+  LitNumInt     -> True
+  LitNumInt64   -> True
+  LitNumWord    -> False
+  LitNumWord64  -> False
+
 {-
 Note [Integer literals]
 ~~~~~~~~~~~~~~~~~~~~~~~
@@ -146,26 +168,33 @@ below), we don't have convenient access to the mkInteger Id.  So we
 just use an error thunk, and fill in the real Id when we do tcIfaceLit
 in TcIface.
 
+Note [Natural literals]
+~~~~~~~~~~~~~~~~~~~~~~~
+Similar to Integer literals.
 
-Binary instance
 -}
 
+instance Binary LitNumType where
+   put_ bh numTyp = putByte bh (fromIntegral (fromEnum numTyp))
+   get bh = do
+      h <- getByte bh
+      return (toEnum (fromIntegral h))
+
 instance Binary Literal where
     put_ bh (MachChar aa)     = do putByte bh 0; put_ bh aa
     put_ bh (MachStr ab)      = do putByte bh 1; put_ bh ab
     put_ bh (MachNullAddr)    = do putByte bh 2
-    put_ bh (MachInt ad)      = do putByte bh 3; put_ bh ad
-    put_ bh (MachInt64 ae)    = do putByte bh 4; put_ bh ae
-    put_ bh (MachWord af)     = do putByte bh 5; put_ bh af
-    put_ bh (MachWord64 ag)   = do putByte bh 6; put_ bh ag
-    put_ bh (MachFloat ah)    = do putByte bh 7; put_ bh ah
-    put_ bh (MachDouble ai)   = do putByte bh 8; put_ bh ai
+    put_ bh (MachFloat ah)    = do putByte bh 3; put_ bh ah
+    put_ bh (MachDouble ai)   = do putByte bh 4; put_ bh ai
     put_ bh (MachLabel aj mb fod)
-        = do putByte bh 9
+        = do putByte bh 5
              put_ bh aj
              put_ bh mb
              put_ bh fod
-    put_ bh (LitInteger i _) = do putByte bh 10; put_ bh i
+    put_ bh (LitNumber nt i _)
+        = do putByte bh 6
+             put_ bh nt
+             put_ bh i
     get bh = do
             h <- getByte bh
             case h of
@@ -178,32 +207,31 @@ instance Binary Literal where
               2 -> do
                     return (MachNullAddr)
               3 -> do
-                    ad <- get bh
-                    return (MachInt ad)
-              4 -> do
-                    ae <- get bh
-                    return (MachInt64 ae)
-              5 -> do
-                    af <- get bh
-                    return (MachWord af)
-              6 -> do
-                    ag <- get bh
-                    return (MachWord64 ag)
-              7 -> do
                     ah <- get bh
                     return (MachFloat ah)
-              8 -> do
+              4 -> do
                     ai <- get bh
                     return (MachDouble ai)
-              9 -> do
+              5 -> do
                     aj <- get bh
                     mb <- get bh
                     fod <- get bh
                     return (MachLabel aj mb fod)
               _ -> do
-                    i <- get bh
-                    -- See Note [Integer literals]
-                    return $ mkLitInteger i (panic "Evaluated the place holder for mkInteger")
+                    nt <- get bh
+                    i  <- get bh
+                    let t = case nt of
+                            LitNumInt     -> intPrimTy
+                            LitNumInt64   -> int64PrimTy
+                            LitNumWord    -> wordPrimTy
+                            LitNumWord64  -> word64PrimTy
+                            -- See Note [Integer literals]
+                            LitNumInteger ->
+                              panic "Evaluated the place holder for mkInteger"
+                            -- and Note [Natural literals]
+                            LitNumNatural ->
+                              panic "Evaluated the place holder for mkNatural"
+                    return (LitNumber nt i t)
 
 instance Outputable Literal where
     ppr lit = pprLiteral (\d -> d) lit
@@ -242,79 +270,116 @@ doesn't yield a warning. Instead we simply squash the value into the *target*
 Int/Word range.
 -}
 
+-- | Wrap a literal number according to its type
+wrapLitNumber :: DynFlags -> Literal -> Literal
+wrapLitNumber dflags v@(LitNumber nt i t) = case nt of
+  LitNumInt -> case platformWordSize (targetPlatform dflags) of
+    4 -> LitNumber nt (toInteger (fromIntegral i :: Int32)) t
+    8 -> LitNumber nt (toInteger (fromIntegral i :: Int64)) t
+    w -> panic ("wrapLitNumber: Unknown platformWordSize: " ++ show w)
+  LitNumWord -> case platformWordSize (targetPlatform dflags) of
+    4 -> LitNumber nt (toInteger (fromIntegral i :: Word32)) t
+    8 -> LitNumber nt (toInteger (fromIntegral i :: Word64)) t
+    w -> panic ("wrapLitNumber: Unknown platformWordSize: " ++ show w)
+  LitNumInt64   -> LitNumber nt (toInteger (fromIntegral i :: Int64)) t
+  LitNumWord64  -> LitNumber nt (toInteger (fromIntegral i :: Word64)) t
+  LitNumInteger -> v
+  LitNumNatural -> v
+wrapLitNumber _ x = x
+
+-- | Create a numeric 'Literal' of the given type
+mkLitNumberWrap :: DynFlags -> LitNumType -> Integer -> Type -> Literal
+mkLitNumberWrap dflags nt i t = wrapLitNumber dflags (LitNumber nt i t)
+
+-- | Check that a given number is in the range of a numeric literal
+litNumCheckRange :: DynFlags -> LitNumType -> Integer -> Bool
+litNumCheckRange dflags nt i = case nt of
+     LitNumInt     -> inIntRange dflags i
+     LitNumWord    -> inWordRange dflags i
+     LitNumInt64   -> inInt64Range i
+     LitNumWord64  -> inWord64Range i
+     LitNumNatural -> i >= 0
+     LitNumInteger -> True
+
+-- | Create a numeric 'Literal' of the given type
+mkLitNumber :: DynFlags -> LitNumType -> Integer -> Type -> Literal
+mkLitNumber dflags nt i t =
+  ASSERT2(litNumCheckRange dflags nt i, integer i)
+  (LitNumber nt i t)
+
 -- | Creates a 'Literal' of type @Int#@
 mkMachInt :: DynFlags -> Integer -> Literal
 mkMachInt dflags x   = ASSERT2( inIntRange dflags x,  integer x )
-                       MachInt x
-
-wrapInt :: DynFlags -> Integer -> Integer
-wrapInt dflags i
- = case platformWordSize (targetPlatform dflags) of
-   4 -> toInteger (fromIntegral i :: Int32)
-   8 -> toInteger (fromIntegral i :: Int64)
-   w -> panic ("toIntRange: Unknown platformWordSize: " ++ show w)
+                       (mkMachIntUnchecked x)
 
 -- | Creates a 'Literal' of type @Int#@.
 --   If the argument is out of the (target-dependent) range, it is wrapped.
 --   See Note [Word/Int underflow/overflow]
 mkMachIntWrap :: DynFlags -> Integer -> Literal
-mkMachIntWrap dflags i = MachInt (wrapInt dflags i)
+mkMachIntWrap dflags i = wrapLitNumber dflags $ mkMachIntUnchecked i
+
+-- | Creates a 'Literal' of type @Int#@ without checking its range.
+mkMachIntUnchecked :: Integer -> Literal
+mkMachIntUnchecked i = LitNumber LitNumInt i intPrimTy
 
 -- | Creates a 'Literal' of type @Int#@, as well as a 'Bool'ean flag indicating
 --   overflow. That is, if the argument is out of the (target-dependent) range
 --   the argument is wrapped and the overflow flag will be set.
 --   See Note [Word/Int underflow/overflow]
 mkMachIntWrapC :: DynFlags -> Integer -> (Literal, Bool)
-mkMachIntWrapC dflags i = (MachInt i', i /= i')
+mkMachIntWrapC dflags i = (n, i /= i')
   where
-    i' = wrapInt dflags i
+    n@(LitNumber _ i' _) = mkMachIntWrap dflags i
 
 -- | Creates a 'Literal' of type @Word#@
 mkMachWord :: DynFlags -> Integer -> Literal
 mkMachWord dflags x   = ASSERT2( inWordRange dflags x, integer x )
-                        MachWord x
-
-wrapWord :: DynFlags -> Integer -> Integer
-wrapWord dflags i
- = case platformWordSize (targetPlatform dflags) of
-   4 -> toInteger (fromIntegral i :: Word32)
-   8 -> toInteger (fromIntegral i :: Word64)
-   w -> panic ("toWordRange: Unknown platformWordSize: " ++ show w)
+                        (mkMachWordUnchecked x)
 
 -- | Creates a 'Literal' of type @Word#@.
 --   If the argument is out of the (target-dependent) range, it is wrapped.
 --   See Note [Word/Int underflow/overflow]
 mkMachWordWrap :: DynFlags -> Integer -> Literal
-mkMachWordWrap dflags i = MachWord (wrapWord dflags i)
+mkMachWordWrap dflags i = wrapLitNumber dflags $ mkMachWordUnchecked i
+
+-- | Creates a 'Literal' of type @Word#@ without checking its range.
+mkMachWordUnchecked :: Integer -> Literal
+mkMachWordUnchecked i = LitNumber LitNumWord i wordPrimTy
 
 -- | Creates a 'Literal' of type @Word#@, as well as a 'Bool'ean flag indicating
 --   carry. That is, if the argument is out of the (target-dependent) range
 --   the argument is wrapped and the carry flag will be set.
 --   See Note [Word/Int underflow/overflow]
 mkMachWordWrapC :: DynFlags -> Integer -> (Literal, Bool)
-mkMachWordWrapC dflags i = (MachWord i', i /= i')
+mkMachWordWrapC dflags i = (n, i /= i')
   where
-    i' = wrapWord dflags i
+    n@(LitNumber _ i' _) = mkMachWordWrap dflags i
 
 -- | Creates a 'Literal' of type @Int64#@
 mkMachInt64 :: Integer -> Literal
-mkMachInt64  x = ASSERT2( inInt64Range x, integer x )
-                 MachInt64 x
+mkMachInt64  x = ASSERT2( inInt64Range x, integer x ) (mkMachInt64Unchecked x)
 
 -- | Creates a 'Literal' of type @Int64#@.
 --   If the argument is out of the range, it is wrapped.
-mkMachInt64Wrap :: Integer -> Literal
-mkMachInt64Wrap  i = MachInt64 (toInteger (fromIntegral i :: Int64))
+mkMachInt64Wrap :: DynFlags -> Integer -> Literal
+mkMachInt64Wrap dflags i = wrapLitNumber dflags $ mkMachInt64Unchecked i
+
+-- | Creates a 'Literal' of type @Int64#@ without checking its range.
+mkMachInt64Unchecked :: Integer -> Literal
+mkMachInt64Unchecked i = LitNumber LitNumInt64 i int64PrimTy
 
 -- | Creates a 'Literal' of type @Word64#@
 mkMachWord64 :: Integer -> Literal
-mkMachWord64 x = ASSERT2( inWord64Range x, integer x )
-                 MachWord64 x
+mkMachWord64 x = ASSERT2( inWord64Range x, integer x ) (mkMachWord64Unchecked x)
 
 -- | Creates a 'Literal' of type @Word64#@.
 --   If the argument is out of the range, it is wrapped.
-mkMachWord64Wrap :: Integer -> Literal
-mkMachWord64Wrap i = MachWord64 (toInteger (fromIntegral i :: Word64))
+mkMachWord64Wrap :: DynFlags -> Integer -> Literal
+mkMachWord64Wrap dflags i = wrapLitNumber dflags $ mkMachWord64Unchecked i
+
+-- | Creates a 'Literal' of type @Word64#@ without checking its range.
+mkMachWord64Unchecked :: Integer -> Literal
+mkMachWord64Unchecked i = LitNumber LitNumWord64 i word64PrimTy
 
 -- | Creates a 'Literal' of type @Float#@
 mkMachFloat :: Rational -> Literal
@@ -335,12 +400,19 @@ mkMachString :: String -> Literal
 mkMachString s = MachStr (fastStringToByteString $ mkFastString s)
 
 mkLitInteger :: Integer -> Type -> Literal
-mkLitInteger = LitInteger
+mkLitInteger x ty = LitNumber LitNumInteger x ty
+
+mkLitNatural :: Integer -> Type -> Literal
+mkLitNatural x ty = ASSERT2( inNaturalRange x,  integer x )
+                    (LitNumber LitNumNatural x ty)
 
 inIntRange, inWordRange :: DynFlags -> Integer -> Bool
 inIntRange  dflags x = x >= tARGET_MIN_INT dflags && x <= tARGET_MAX_INT dflags
 inWordRange dflags x = x >= 0                     && x <= tARGET_MAX_WORD dflags
 
+inNaturalRange :: Integer -> Bool
+inNaturalRange x = x >= 0
+
 inInt64Range, inWord64Range :: Integer -> Bool
 inInt64Range x  = x >= toInteger (minBound :: Int64) &&
                   x <= toInteger (maxBound :: Int64)
@@ -352,49 +424,39 @@ inCharRange c =  c >= '\0' && c <= chr tARGET_MAX_CHAR
 
 -- | Tests whether the literal represents a zero of whatever type it is
 isZeroLit :: Literal -> Bool
-isZeroLit (MachInt    0) = True
-isZeroLit (MachInt64  0) = True
-isZeroLit (MachWord   0) = True
-isZeroLit (MachWord64 0) = True
-isZeroLit (MachFloat  0) = True
-isZeroLit (MachDouble 0) = True
-isZeroLit _              = False
+isZeroLit (LitNumber _ 0 _) = True
+isZeroLit (MachFloat  0)    = True
+isZeroLit (MachDouble 0)    = True
+isZeroLit _                 = False
 
 -- | Returns the 'Integer' contained in the 'Literal', for when that makes
--- sense, i.e. for 'Char', 'Int', 'Word' and 'LitInteger'.
+-- sense, i.e. for 'Char', 'Int', 'Word', 'LitInteger' and 'LitNatural'.
 litValue  :: Literal -> Integer
 litValue l = case isLitValue_maybe l of
    Just x  -> x
    Nothing -> pprPanic "litValue" (ppr l)
 
 -- | Returns the 'Integer' contained in the 'Literal', for when that makes
--- sense, i.e. for 'Char', 'Int', 'Word' and 'LitInteger'.
+-- sense, i.e. for 'Char' and numbers.
 isLitValue_maybe  :: Literal -> Maybe Integer
-isLitValue_maybe (MachChar   c)   = Just $ toInteger $ ord c
-isLitValue_maybe (MachInt    i)   = Just i
-isLitValue_maybe (MachInt64  i)   = Just i
-isLitValue_maybe (MachWord   i)   = Just i
-isLitValue_maybe (MachWord64 i)   = Just i
-isLitValue_maybe (LitInteger i _) = Just i
-isLitValue_maybe _                = Nothing
+isLitValue_maybe (MachChar   c)    = Just $ toInteger $ ord c
+isLitValue_maybe (LitNumber _ i _) = Just i
+isLitValue_maybe _                 = Nothing
 
 -- | Apply a function to the 'Integer' contained in the 'Literal', for when that
--- makes sense, e.g. for 'Char', 'Int', 'Word' and 'LitInteger'. For
--- fixed-size integral literals, the result will be wrapped in
--- accordance with the semantics of the target type.
+-- makes sense, e.g. for 'Char' and numbers.
+-- For fixed-size integral literals, the result will be wrapped in accordance
+-- with the semantics of the target type.
 -- See Note [Word/Int underflow/overflow]
 mapLitValue  :: DynFlags -> (Integer -> Integer) -> Literal -> Literal
-mapLitValue _      f (MachChar   c)   = mkMachChar (fchar c)
+mapLitValue _      f (MachChar   c)     = mkMachChar (fchar c)
    where fchar = chr . fromInteger . f . toInteger . ord
-mapLitValue dflags f (MachInt    i)   = mkMachIntWrap dflags (f i)
-mapLitValue _      f (MachInt64  i)   = mkMachInt64Wrap (f i)
-mapLitValue dflags f (MachWord   i)   = mkMachWordWrap dflags (f i)
-mapLitValue _      f (MachWord64 i)   = mkMachWord64Wrap (f i)
-mapLitValue _      f (LitInteger i t) = mkLitInteger (f i) t
-mapLitValue _      _ l                = pprPanic "mapLitValue" (ppr l)
+mapLitValue dflags f (LitNumber nt i t) = wrapLitNumber dflags
+                                                        (LitNumber nt (f i) t)
+mapLitValue _      _ l                  = pprPanic "mapLitValue" (ppr l)
 
 -- | Indicate if the `Literal` contains an 'Integer' value, e.g. 'Char',
--- 'Int', 'Word' and 'LitInteger'.
+-- 'Int', 'Word', 'LitInteger' and 'LitNatural'.
 isLitValue  :: Literal -> Bool
 isLitValue = isJust . isLitValue_maybe
 
@@ -411,43 +473,42 @@ narrow8IntLit, narrow16IntLit, narrow32IntLit,
   :: Literal -> Literal
 
 word2IntLit, int2WordLit :: DynFlags -> Literal -> Literal
-word2IntLit dflags (MachWord w)
-  | w > tARGET_MAX_INT dflags = MachInt (w - tARGET_MAX_WORD dflags - 1)
-  | otherwise                 = MachInt w
+word2IntLit dflags (LitNumber LitNumWord w _)
+  | w > tARGET_MAX_INT dflags = mkMachInt dflags (w - tARGET_MAX_WORD dflags - 1)
+  | otherwise                 = mkMachInt dflags w
 word2IntLit _ l = pprPanic "word2IntLit" (ppr l)
 
-int2WordLit dflags (MachInt i)
-  | i < 0     = MachWord (1 + tARGET_MAX_WORD dflags + i)      -- (-1)  --->  tARGET_MAX_WORD
-  | otherwise = MachWord i
+int2WordLit dflags (LitNumber LitNumInt i _)
+  | i < 0     = mkMachWord dflags (1 + tARGET_MAX_WORD dflags + i)      -- (-1)  --->  tARGET_MAX_WORD
+  | otherwise = mkMachWord dflags i
 int2WordLit _ l = pprPanic "int2WordLit" (ppr l)
 
-narrow8IntLit    (MachInt  i) = MachInt  (toInteger (fromInteger i :: Int8))
-narrow8IntLit    l            = pprPanic "narrow8IntLit" (ppr l)
-narrow16IntLit   (MachInt  i) = MachInt  (toInteger (fromInteger i :: Int16))
-narrow16IntLit   l            = pprPanic "narrow16IntLit" (ppr l)
-narrow32IntLit   (MachInt  i) = MachInt  (toInteger (fromInteger i :: Int32))
-narrow32IntLit   l            = pprPanic "narrow32IntLit" (ppr l)
-narrow8WordLit   (MachWord w) = MachWord (toInteger (fromInteger w :: Word8))
-narrow8WordLit   l            = pprPanic "narrow8WordLit" (ppr l)
-narrow16WordLit  (MachWord w) = MachWord (toInteger (fromInteger w :: Word16))
-narrow16WordLit  l            = pprPanic "narrow16WordLit" (ppr l)
-narrow32WordLit  (MachWord w) = MachWord (toInteger (fromInteger w :: Word32))
-narrow32WordLit  l            = pprPanic "narrow32WordLit" (ppr l)
-
-char2IntLit (MachChar c) = MachInt  (toInteger (ord c))
+-- | Narrow a literal number (unchecked result range)
+narrowLit :: forall a. Integral a => Proxy a -> Literal -> Literal
+narrowLit _ (LitNumber nt i t) = LitNumber nt (toInteger (fromInteger i :: a)) t
+narrowLit _ l                  = pprPanic "narrowLit" (ppr l)
+
+narrow8IntLit   = narrowLit (Proxy :: Proxy Int8)
+narrow16IntLit  = narrowLit (Proxy :: Proxy Int16)
+narrow32IntLit  = narrowLit (Proxy :: Proxy Int32)
+narrow8WordLit  = narrowLit (Proxy :: Proxy Word8)
+narrow16WordLit = narrowLit (Proxy :: Proxy Word16)
+narrow32WordLit = narrowLit (Proxy :: Proxy Word32)
+
+char2IntLit (MachChar c) = mkMachIntUnchecked (toInteger (ord c))
 char2IntLit l            = pprPanic "char2IntLit" (ppr l)
-int2CharLit (MachInt  i) = MachChar (chr (fromInteger i))
-int2CharLit l            = pprPanic "int2CharLit" (ppr l)
+int2CharLit (LitNumber _ i _) = MachChar (chr (fromInteger i))
+int2CharLit l                 = pprPanic "int2CharLit" (ppr l)
 
-float2IntLit (MachFloat f) = MachInt   (truncate    f)
+float2IntLit (MachFloat f) = mkMachIntUnchecked (truncate f)
 float2IntLit l             = pprPanic "float2IntLit" (ppr l)
-int2FloatLit (MachInt   i) = MachFloat (fromInteger i)
-int2FloatLit l             = pprPanic "int2FloatLit" (ppr l)
+int2FloatLit (LitNumber _ i _) = MachFloat (fromInteger i)
+int2FloatLit l                 = pprPanic "int2FloatLit" (ppr l)
 
-double2IntLit (MachDouble f) = MachInt    (truncate    f)
+double2IntLit (MachDouble f) = mkMachIntUnchecked (truncate f)
 double2IntLit l              = pprPanic "double2IntLit" (ppr l)
-int2DoubleLit (MachInt    i) = MachDouble (fromInteger i)
-int2DoubleLit l              = pprPanic "int2DoubleLit" (ppr l)
+int2DoubleLit (LitNumber _ i _) = MachDouble (fromInteger i)
+int2DoubleLit l                 = pprPanic "int2DoubleLit" (ppr l)
 
 float2DoubleLit (MachFloat  f) = MachDouble f
 float2DoubleLit l              = pprPanic "float2DoubleLit" (ppr l)
@@ -498,24 +559,41 @@ nullAddrLit = MachNullAddr
 litIsTrivial :: Literal -> Bool
 --      c.f. CoreUtils.exprIsTrivial
 litIsTrivial (MachStr _)      = False
-litIsTrivial (LitInteger {})  = False
+litIsTrivial (LitNumber nt _ _) = case nt of
+  LitNumInteger -> False
+  LitNumNatural -> False
+  LitNumInt     -> True
+  LitNumInt64   -> True
+  LitNumWord    -> True
+  LitNumWord64  -> True
 litIsTrivial _                = True
 
 -- | True if code space does not go bad if we duplicate this literal
--- Currently we treat it just like 'litIsTrivial'
 litIsDupable :: DynFlags -> Literal -> Bool
 --      c.f. CoreUtils.exprIsDupable
 litIsDupable _      (MachStr _)      = False
-litIsDupable dflags (LitInteger i _) = inIntRange dflags i
+litIsDupable dflags (LitNumber nt i _) = case nt of
+  LitNumInteger -> inIntRange dflags i
+  LitNumNatural -> inIntRange dflags i
+  LitNumInt     -> True
+  LitNumInt64   -> True
+  LitNumWord    -> True
+  LitNumWord64  -> True
 litIsDupable _      _                = True
 
 litFitsInChar :: Literal -> Bool
-litFitsInChar (MachInt i) = i >= toInteger (ord minBound)
-                         && i <= toInteger (ord maxBound)
-litFitsInChar _           = False
+litFitsInChar (LitNumber _ i _) = i >= toInteger (ord minBound)
+                               && i <= toInteger (ord maxBound)
+litFitsInChar _                 = False
 
 litIsLifted :: Literal -> Bool
-litIsLifted (LitInteger {}) = True
+litIsLifted (LitNumber nt _ _) = case nt of
+  LitNumInteger -> True
+  LitNumNatural -> True
+  LitNumInt     -> False
+  LitNumInt64   -> False
+  LitNumWord    -> False
+  LitNumWord64  -> False
 litIsLifted _               = False
 
 {-
@@ -525,17 +603,13 @@ litIsLifted _               = False
 
 -- | Find the Haskell 'Type' the literal occupies
 literalType :: Literal -> Type
-literalType MachNullAddr    = addrPrimTy
-literalType (MachChar _)    = charPrimTy
-literalType (MachStr  _)    = addrPrimTy
-literalType (MachInt  _)    = intPrimTy
-literalType (MachWord  _)   = wordPrimTy
-literalType (MachInt64  _)  = int64PrimTy
-literalType (MachWord64  _) = word64PrimTy
-literalType (MachFloat _)   = floatPrimTy
-literalType (MachDouble _)  = doublePrimTy
+literalType MachNullAddr      = addrPrimTy
+literalType (MachChar _)      = charPrimTy
+literalType (MachStr  _)      = addrPrimTy
+literalType (MachFloat _)     = floatPrimTy
+literalType (MachDouble _)    = doublePrimTy
 literalType (MachLabel _ _ _) = addrPrimTy
-literalType (LitInteger _ t) = t
+literalType (LitNumber _ _ t) = t
 
 absentLiteralOf :: TyCon -> Maybe Literal
 -- Return a literal of the appropriate primitive
@@ -545,12 +619,13 @@ absentLiteralOf tc = lookupUFM absent_lits (tyConName tc)
 absent_lits :: UniqFM Literal
 absent_lits = listToUFM [ (addrPrimTyConKey,    MachNullAddr)
                         , (charPrimTyConKey,    MachChar 'x')
-                        , (intPrimTyConKey,     MachInt 0)
-                        , (int64PrimTyConKey,   MachInt64 0)
+                        , (intPrimTyConKey,     mkMachIntUnchecked 0)
+                        , (int64PrimTyConKey,   mkMachInt64Unchecked 0)
+                        , (wordPrimTyConKey,    mkMachWordUnchecked 0)
+                        , (word64PrimTyConKey,  mkMachWord64Unchecked 0)
                         , (floatPrimTyConKey,   MachFloat 0)
                         , (doublePrimTyConKey,  MachDouble 0)
-                        , (wordPrimTyConKey,    MachWord 0)
-                        , (word64PrimTyConKey,  MachWord64 0) ]
+                        ]
 
 {-
         Comparison
@@ -558,32 +633,27 @@ absent_lits = listToUFM [ (addrPrimTyConKey,    MachNullAddr)
 -}
 
 cmpLit :: Literal -> Literal -> Ordering
-cmpLit (MachChar      a)   (MachChar       b)   = a `compare` b
-cmpLit (MachStr       a)   (MachStr        b)   = a `compare` b
-cmpLit (MachNullAddr)      (MachNullAddr)       = EQ
-cmpLit (MachInt       a)   (MachInt        b)   = a `compare` b
-cmpLit (MachWord      a)   (MachWord       b)   = a `compare` b
-cmpLit (MachInt64     a)   (MachInt64      b)   = a `compare` b
-cmpLit (MachWord64    a)   (MachWord64     b)   = a `compare` b
-cmpLit (MachFloat     a)   (MachFloat      b)   = a `compare` b
-cmpLit (MachDouble    a)   (MachDouble     b)   = a `compare` b
+cmpLit (MachChar      a)     (MachChar       b)     = a `compare` b
+cmpLit (MachStr       a)     (MachStr        b)     = a `compare` b
+cmpLit (MachNullAddr)        (MachNullAddr)         = EQ
+cmpLit (MachFloat     a)     (MachFloat      b)     = a `compare` b
+cmpLit (MachDouble    a)     (MachDouble     b)     = a `compare` b
 cmpLit (MachLabel     a _ _) (MachLabel      b _ _) = a `compare` b
-cmpLit (LitInteger    a _) (LitInteger     b _) = a `compare` b
-cmpLit lit1                lit2                 | litTag lit1 < litTag lit2 = LT
-                                                | otherwise                 = GT
+cmpLit (LitNumber nt1 a _)   (LitNumber nt2  b _)
+  | nt1 == nt2 = a   `compare` b
+  | otherwise  = nt1 `compare` nt2
+cmpLit lit1 lit2
+  | litTag lit1 < litTag lit2 = LT
+  | otherwise                 = GT
 
 litTag :: Literal -> Int
 litTag (MachChar      _)   = 1
 litTag (MachStr       _)   = 2
 litTag (MachNullAddr)      = 3
-litTag (MachInt       _)   = 4
-litTag (MachWord      _)   = 5
-litTag (MachInt64     _)   = 6
-litTag (MachWord64    _)   = 7
-litTag (MachFloat     _)   = 8
-litTag (MachDouble    _)   = 9
-litTag (MachLabel _ _ _)   = 10
-litTag (LitInteger  {})    = 11
+litTag (MachFloat     _)   = 4
+litTag (MachDouble    _)   = 5
+litTag (MachLabel _ _ _)   = 6
+litTag (LitNumber  {})     = 7
 
 {-
         Printing
@@ -595,13 +665,16 @@ pprLiteral :: (SDoc -> SDoc) -> Literal -> SDoc
 pprLiteral _       (MachChar c)     = pprPrimChar c
 pprLiteral _       (MachStr s)      = pprHsBytes s
 pprLiteral _       (MachNullAddr)   = text "__NULL"
-pprLiteral _       (MachInt i)      = pprPrimInt i
-pprLiteral _       (MachInt64 i)    = pprPrimInt64 i
-pprLiteral _       (MachWord w)     = pprPrimWord w
-pprLiteral _       (MachWord64 w)   = pprPrimWord64 w
 pprLiteral _       (MachFloat f)    = float (fromRat f) <> primFloatSuffix
 pprLiteral _       (MachDouble d)   = double (fromRat d) <> primDoubleSuffix
-pprLiteral add_par (LitInteger i _) = pprIntegerVal add_par i
+pprLiteral add_par (LitNumber nt i _)
+   = case nt of
+       LitNumInteger -> pprIntegerVal add_par i
+       LitNumNatural -> pprIntegerVal add_par i
+       LitNumInt     -> pprPrimInt i
+       LitNumInt64   -> pprPrimInt64 i
+       LitNumWord    -> pprPrimWord i
+       LitNumWord64  -> pprPrimWord64 i
 pprLiteral add_par (MachLabel l mb fod) = add_par (text "__label" <+> b <+> ppr fod)
     where b = case mb of
               Nothing -> pprHsString l
index 8dadb4e..f2287e0 100644 (file)
@@ -198,7 +198,7 @@ because they don't support cross package data references well.
 buildDynCon' dflags platform binder _ _cc con [arg]
   | maybeIntLikeCon con
   , platformOS platform /= OSMinGW32 || not (positionIndependent dflags)
-  , NonVoid (StgLitArg (MachInt val)) <- arg
+  , NonVoid (StgLitArg (LitNumber LitNumInt val _)) <- arg
   , val <= fromIntegral (mAX_INTLIKE dflags) -- Comparisons at type Integer!
   , val >= fromIntegral (mIN_INTLIKE dflags) -- ...ditto...
   = do  { let intlike_lbl   = mkCmmClosureLabel rtsUnitId (fsLit "stg_INTLIKE")
index 94013f5..99fa550 100644 (file)
@@ -94,10 +94,10 @@ cgLit other_lit   = do dflags <- getDynFlags
 mkSimpleLit :: DynFlags -> Literal -> CmmLit
 mkSimpleLit dflags (MachChar   c)    = CmmInt (fromIntegral (ord c)) (wordWidth dflags)
 mkSimpleLit dflags MachNullAddr      = zeroCLit dflags
-mkSimpleLit dflags (MachInt i)       = CmmInt i (wordWidth dflags)
-mkSimpleLit _      (MachInt64 i)     = CmmInt i W64
-mkSimpleLit dflags (MachWord i)      = CmmInt i (wordWidth dflags)
-mkSimpleLit _      (MachWord64 i)    = CmmInt i W64
+mkSimpleLit dflags (LitNumber LitNumInt i _)    = CmmInt i (wordWidth dflags)
+mkSimpleLit _      (LitNumber LitNumInt64 i _)  = CmmInt i W64
+mkSimpleLit dflags (LitNumber LitNumWord i _)   = CmmInt i (wordWidth dflags)
+mkSimpleLit _      (LitNumber LitNumWord64 i _) = CmmInt i W64
 mkSimpleLit _      (MachFloat r)     = CmmFloat r W32
 mkSimpleLit _      (MachDouble r)    = CmmFloat r W64
 mkSimpleLit _      (MachLabel fs ms fod)
@@ -529,8 +529,7 @@ emitCmmLitSwitch scrut  branches deflt = do
 
     -- We find the necessary type information in the literals in the branches
     let signed = case head branches of
-                    (MachInt _, _) ->   True
-                    (MachInt64 _, _) -> True
+                    (LitNumber nt _ _, _) -> litNumIsSigned nt
                     _ -> False
 
     let range | signed    = (tARGET_MIN_INT dflags, tARGET_MAX_INT dflags)
index 7530179..9c2954d 100644 (file)
@@ -8,8 +8,9 @@ Core pass to saturate constructors and PrimOps
 {-# LANGUAGE BangPatterns, CPP, MultiWayIf #-}
 
 module CorePrep (
-      corePrepPgm, corePrepExpr, cvtLitInteger,
-      lookupMkIntegerName, lookupIntegerSDataConName
+      corePrepPgm, corePrepExpr, cvtLitInteger, cvtLitNatural,
+      lookupMkIntegerName, lookupIntegerSDataConName,
+      lookupMkNaturalName, lookupNaturalSDataConName
   ) where
 
 #include "HsVersions.h"
@@ -122,11 +123,13 @@ The goal of this pass is to prepare for code generation.
     special case where we use the S# constructor for Integers that
     are in the range of Int.
 
-11. Uphold tick consistency while doing this: We move ticks out of
+11. Same for LitNatural.
+
+12. Uphold tick consistency while doing this: We move ticks out of
     (non-type) applications where we can, and make sure that we
     annotate according to scoping rules when floating.
 
-12. Collect cost centres (including cost centres in unfoldings) if we're in
+13. Collect cost centres (including cost centres in unfoldings) if we're in
     profiling mode. We have to do this here beucase we won't have unfoldings
     after this pass (see `zapUnfolding` and Note [Drop unfoldings and rules].
 
@@ -608,9 +611,12 @@ cpeRhsE :: CorePrepEnv -> CoreExpr -> UniqSM (Floats, CpeRhs)
 
 cpeRhsE _env expr@(Type {})      = return (emptyFloats, expr)
 cpeRhsE _env expr@(Coercion {})  = return (emptyFloats, expr)
-cpeRhsE env (Lit (LitInteger i _))
+cpeRhsE env (Lit (LitNumber LitNumInteger i _))
     = cpeRhsE env (cvtLitInteger (cpe_dynFlags env) (getMkIntegerId env)
                    (cpe_integerSDataCon env) i)
+cpeRhsE env (Lit (LitNumber LitNumNatural i _))
+    = cpeRhsE env (cvtLitNatural (cpe_dynFlags env) (getMkNaturalId env)
+                   (cpe_naturalSDataCon env) i)
 cpeRhsE _env expr@(Lit {}) = return (emptyFloats, expr)
 cpeRhsE env expr@(Var {})  = cpeApp env expr
 cpeRhsE env expr@(App {}) = cpeApp env expr
@@ -693,6 +699,24 @@ cvtLitInteger dflags mk_integer _ i
         bits = 31
         mask = 2 ^ bits - 1
 
+cvtLitNatural :: DynFlags -> Id -> Maybe DataCon -> Integer -> CoreExpr
+-- Here we convert a literal Natural to the low-level
+-- representation.
+-- See Note [Natural literals] in Literal
+cvtLitNatural dflags _ (Just sdatacon) i
+  | inWordRange dflags i -- Special case for small naturals
+    = mkConApp sdatacon [Lit (mkMachWord dflags i)]
+
+cvtLitNatural dflags mk_natural _ i
+    = mkApps (Var mk_natural) [words]
+  where words = mkListExpr wordTy (f i)
+        f 0 = []
+        f x = let low  = x .&. mask
+                  high = x `shiftR` bits
+              in mkConApp wordDataCon [Lit (mkMachWord dflags low)] : f high
+        bits = 32
+        mask = 2 ^ bits - 1
+
 -- ---------------------------------------------------------------------------
 --              CpeBody: produces a result satisfying CpeBody
 -- ---------------------------------------------------------------------------
@@ -1388,8 +1412,8 @@ canFloatFromNoCaf platform (Floats ok_to_spec fs) rhs
     -- the new binding is static. However it can't mention
     -- any non-static things or it would *already* be Caffy
     rhs_ok = rhsIsStatic platform (\_ -> False)
-                         (\i -> pprPanic "rhsIsStatic" (integer i))
-                         -- Integer literals should not show up
+                         (\_nt i -> pprPanic "rhsIsStatic" (integer i))
+                         -- Integer or Natural literals should not show up
 
 wantFloatNested :: RecFlag -> Demand -> Bool -> Floats -> CpeRhs -> Bool
 wantFloatNested is_rec dmd is_unlifted floats rhs
@@ -1498,7 +1522,9 @@ data CorePrepEnv
         --      see Note [lazyId magic], Note [Inlining in CorePrep]
         --      and Note [CorePrep inlines trivial CoreExpr not Id] (#12076)
         , cpe_mkIntegerId     :: Id
+        , cpe_mkNaturalId     :: Id
         , cpe_integerSDataCon :: Maybe DataCon
+        , cpe_naturalSDataCon :: Maybe DataCon
     }
 
 lookupMkIntegerName :: DynFlags -> HscEnv -> IO Id
@@ -1506,13 +1532,24 @@ lookupMkIntegerName dflags hsc_env
     = guardIntegerUse dflags $ liftM tyThingId $
       lookupGlobal hsc_env mkIntegerName
 
+lookupMkNaturalName :: DynFlags -> HscEnv -> IO Id
+lookupMkNaturalName dflags hsc_env
+    = guardNaturalUse dflags $ liftM tyThingId $
+      lookupGlobal hsc_env mkNaturalName
+
 lookupIntegerSDataConName :: DynFlags -> HscEnv -> IO (Maybe DataCon)
 lookupIntegerSDataConName dflags hsc_env = case cIntegerLibraryType of
     IntegerGMP -> guardIntegerUse dflags $ liftM (Just . tyThingDataCon) $
                   lookupGlobal hsc_env integerSDataConName
     IntegerSimple -> return Nothing
 
--- | Helper for 'lookupMkIntegerName' and 'lookupIntegerSDataConName'
+lookupNaturalSDataConName :: DynFlags -> HscEnv -> IO (Maybe DataCon)
+lookupNaturalSDataConName dflags hsc_env = case cIntegerLibraryType of
+    IntegerGMP -> guardNaturalUse dflags $ liftM (Just . tyThingDataCon) $
+                  lookupGlobal hsc_env naturalSDataConName
+    IntegerSimple -> return Nothing
+
+-- | Helper for 'lookupMkIntegerName', 'lookupIntegerSDataConName'
 guardIntegerUse :: DynFlags -> IO a -> IO a
 guardIntegerUse dflags act
   | thisPackage dflags == primUnitId
@@ -1521,15 +1558,33 @@ guardIntegerUse dflags act
   = return $ panic "Can't use Integer in integer-*"
   | otherwise = act
 
+-- | Helper for 'lookupMkNaturalName', 'lookupNaturalSDataConName'
+--
+-- Just like we can't use Integer literals in `integer-*`, we can't use Natural
+-- literals in `base`. If we do, we get interface loading error for GHC.Natural.
+guardNaturalUse :: DynFlags -> IO a -> IO a
+guardNaturalUse dflags act
+  | thisPackage dflags == primUnitId
+  = return $ panic "Can't use Natural in ghc-prim"
+  | thisPackage dflags == integerUnitId
+  = return $ panic "Can't use Natural in integer-*"
+  | thisPackage dflags == baseUnitId
+  = return $ panic "Can't use Natural in base"
+  | otherwise = act
+
 mkInitialCorePrepEnv :: DynFlags -> HscEnv -> IO CorePrepEnv
 mkInitialCorePrepEnv dflags hsc_env
     = do mkIntegerId <- lookupMkIntegerName dflags hsc_env
+         mkNaturalId <- lookupMkNaturalName dflags hsc_env
          integerSDataCon <- lookupIntegerSDataConName dflags hsc_env
+         naturalSDataCon <- lookupNaturalSDataConName dflags hsc_env
          return $ CPE {
                       cpe_dynFlags = dflags,
                       cpe_env = emptyVarEnv,
                       cpe_mkIntegerId = mkIntegerId,
-                      cpe_integerSDataCon = integerSDataCon
+                      cpe_mkNaturalId = mkNaturalId,
+                      cpe_integerSDataCon = integerSDataCon,
+                      cpe_naturalSDataCon = naturalSDataCon
                   }
 
 extendCorePrepEnv :: CorePrepEnv -> Id -> Id -> CorePrepEnv
@@ -1554,6 +1609,9 @@ lookupCorePrepEnv cpe id
 getMkIntegerId :: CorePrepEnv -> Id
 getMkIntegerId = cpe_mkIntegerId
 
+getMkNaturalId :: CorePrepEnv -> Id
+getMkNaturalId = cpe_mkNaturalId
+
 ------------------------------------------------------------------------------
 -- Cloning binders
 -- ---------------------------------------------------------------------------
index 3d26d3c..7bd512d 100644 (file)
@@ -701,7 +701,8 @@ sizeExpr dflags bOMB_OUT_SIZE top_args expr
 -- | Finds a nominal size of a string literal.
 litSize :: Literal -> Int
 -- Used by CoreUnfold.sizeExpr
-litSize (LitInteger {}) = 100   -- Note [Size of literal integers]
+litSize (LitNumber LitNumInteger _ _) = 100   -- Note [Size of literal integers]
+litSize (LitNumber LitNumNatural _ _) = 100
 litSize (MachStr str)   = 10 + 10 * ((BS.length str + 3) `div` 4)
         -- If size could be 0 then @f "x"@ might be too small
         -- [Sept03: make literal strings a bit bigger to avoid fruitless
index 88e1f71..8f4f84b 100644 (file)
@@ -2409,12 +2409,13 @@ and 'execute' it rather than allocating it statically.
 -- | This function is called only on *top-level* right-hand sides.
 -- Returns @True@ if the RHS can be allocated statically in the output,
 -- with no thunks involved at all.
-rhsIsStatic :: Platform
-            -> (Name -> Bool)         -- Which names are dynamic
-            -> (Integer -> CoreExpr)  -- Desugaring for integer literals (disgusting)
-                                      -- C.f. Note [Disgusting computation of CafRefs]
-                                      --      in TidyPgm
-            -> CoreExpr -> Bool
+rhsIsStatic
+   :: Platform
+   -> (Name -> Bool)         -- Which names are dynamic
+   -> (LitNumType -> Integer -> Maybe CoreExpr)
+      -- Desugaring for some literals (disgusting)
+      -- C.f. Note [Disgusting computation of CafRefs] in TidyPgm
+   -> CoreExpr -> Bool
 -- It's called (i) in TidyPgm.hasCafRefs to decide if the rhs is, or
 -- refers to, CAFs; (ii) in CoreToStg to decide whether to put an
 -- update flag on it and (iii) in DsExpr to decide how to expand
@@ -2469,7 +2470,7 @@ rhsIsStatic :: Platform
 --
 --    c) don't look through unfolding of f in (f x).
 
-rhsIsStatic platform is_dynamic_name cvt_integer rhs = is_static False rhs
+rhsIsStatic platform is_dynamic_name cvt_literal rhs = is_static False rhs
   where
   is_static :: Bool     -- True <=> in a constructor argument; must be atomic
             -> CoreExpr -> Bool
@@ -2479,7 +2480,9 @@ rhsIsStatic platform is_dynamic_name cvt_integer rhs = is_static False rhs
                                               && is_static in_arg e
   is_static in_arg (Cast e _)             = is_static in_arg e
   is_static _      (Coercion {})          = True   -- Behaves just like a literal
-  is_static in_arg (Lit (LitInteger i _)) = is_static in_arg (cvt_integer i)
+  is_static in_arg (Lit (LitNumber nt i _)) = case cvt_literal nt i of
+    Just e  -> is_static in_arg e
+    Nothing -> True
   is_static _      (Lit (MachLabel {}))   = False
   is_static _      (Lit _)                = True
         -- A MachLabel (foreign import "&foo") in an argument
index aad6d14..ef9da21 100644 (file)
@@ -260,13 +260,9 @@ mkIntegerExpr i = do t <- lookupTyCon integerTyConName
                      return (Lit (mkLitInteger i (mkTyConTy t)))
 
 -- | Create a 'CoreExpr' which will evaluate to the given @Natural@
---
--- TODO: should we add LitNatural to Core?
-mkNaturalExpr  :: MonadThings m => Integer -> m CoreExpr  -- Result :: Natural
-mkNaturalExpr i = do iExpr <- mkIntegerExpr i
-                     fiExpr <- lookupId naturalFromIntegerName
-                     return (mkCoreApps (Var fiExpr) [iExpr])
-
+mkNaturalExpr  :: MonadThings m => Integer -> m CoreExpr
+mkNaturalExpr i = do t <- lookupTyCon naturalTyConName
+                     return (Lit (mkLitNatural i (mkTyConTy t)))
 
 -- | Create a 'CoreExpr' which will evaluate to the given @Float@
 mkFloatExpr :: Float -> CoreExpr
index d715439..ca7ef0a 100644 (file)
@@ -77,32 +77,32 @@ See also below where we look for @DictApps@ for \tr{plusInt}, etc.
 -}
 
 dsLit :: HsLit GhcRn -> DsM CoreExpr
-dsLit (HsStringPrim _ s) = return (Lit (MachStr s))
-dsLit (HsCharPrim   _ c) = return (Lit (MachChar c))
-dsLit (HsIntPrim    _ i) = return (Lit (MachInt i))
-dsLit (HsWordPrim   _ w) = return (Lit (MachWord w))
-dsLit (HsInt64Prim  _ i) = return (Lit (MachInt64 i))
-dsLit (HsWord64Prim _ w) = return (Lit (MachWord64 w))
-dsLit (HsFloatPrim  _ f) = return (Lit (MachFloat (fl_value f)))
-dsLit (HsDoublePrim _ d) = return (Lit (MachDouble (fl_value d)))
-dsLit (HsChar _ c)       = return (mkCharExpr c)
-dsLit (HsString _ str)   = mkStringExprFS str
-dsLit (HsInteger _ i _)  = mkIntegerExpr i
-dsLit (HsInt _ i)        = do dflags <- getDynFlags
-                              return (mkIntExpr dflags (il_value i))
-
-dsLit (HsRat _ (FL _ _ val) ty) = do
-  num   <- mkIntegerExpr (numerator val)
-  denom <- mkIntegerExpr (denominator val)
-  return (mkCoreConApps ratio_data_con [Type integer_ty, num, denom])
-  where
-    (ratio_data_con, integer_ty)
-        = case tcSplitTyConApp ty of
-                (tycon, [i_ty]) -> ASSERT(isIntegerTy i_ty && tycon `hasKey` ratioTyConKey)
-                                   (head (tyConDataCons tycon), i_ty)
-                x -> pprPanic "dsLit" (ppr x)
-
-dsLit (XLit x)  = pprPanic "dsLit" (ppr x)
+dsLit l = do
+  dflags <- getDynFlags
+  case l of
+    HsStringPrim _ s -> return (Lit (MachStr s))
+    HsCharPrim   _ c -> return (Lit (MachChar c))
+    HsIntPrim    _ i -> return (Lit (mkMachIntWrap dflags i))
+    HsWordPrim   _ w -> return (Lit (mkMachWordWrap dflags w))
+    HsInt64Prim  _ i -> return (Lit (mkMachInt64Wrap dflags i))
+    HsWord64Prim _ w -> return (Lit (mkMachWord64Wrap dflags w))
+    HsFloatPrim  _ f -> return (Lit (MachFloat (fl_value f)))
+    HsDoublePrim _ d -> return (Lit (MachDouble (fl_value d)))
+    HsChar _ c       -> return (mkCharExpr c)
+    HsString _ str   -> mkStringExprFS str
+    HsInteger _ i _  -> mkIntegerExpr i
+    HsInt _ i        -> return (mkIntExpr dflags (il_value i))
+    XLit x           -> pprPanic "dsLit" (ppr x)
+    HsRat _ (FL _ _ val) ty -> do
+      num   <- mkIntegerExpr (numerator val)
+      denom <- mkIntegerExpr (denominator val)
+      return (mkCoreConApps ratio_data_con [Type integer_ty, num, denom])
+      where
+        (ratio_data_con, integer_ty)
+            = case tcSplitTyConApp ty of
+                    (tycon, [i_ty]) -> ASSERT(isIntegerTy i_ty && tycon `hasKey` ratioTyConKey)
+                                       (head (tyConDataCons tycon), i_ty)
+                    x -> pprPanic "dsLit" (ppr x)
 
 dsOverLit :: HsOverLit GhcTc -> DsM CoreExpr
 dsOverLit lit = do { dflags <- getDynFlags
@@ -161,20 +161,30 @@ warnAboutOverflowedLiterals :: DynFlags -> HsOverLit GhcTc -> DsM ()
 warnAboutOverflowedLiterals dflags lit
  | wopt Opt_WarnOverflowedLiterals dflags
  , Just (i, tc) <- getIntegralLit lit
-  = if      tc == intTyConName    then check i tc (Proxy :: Proxy Int)
-    else if tc == int8TyConName   then check i tc (Proxy :: Proxy Int8)
-    else if tc == int16TyConName  then check i tc (Proxy :: Proxy Int16)
-    else if tc == int32TyConName  then check i tc (Proxy :: Proxy Int32)
-    else if tc == int64TyConName  then check i tc (Proxy :: Proxy Int64)
-    else if tc == wordTyConName   then check i tc (Proxy :: Proxy Word)
-    else if tc == word8TyConName  then check i tc (Proxy :: Proxy Word8)
-    else if tc == word16TyConName then check i tc (Proxy :: Proxy Word16)
-    else if tc == word32TyConName then check i tc (Proxy :: Proxy Word32)
-    else if tc == word64TyConName then check i tc (Proxy :: Proxy Word64)
+  = if      tc == intTyConName     then check i tc (Proxy :: Proxy Int)
+    else if tc == int8TyConName    then check i tc (Proxy :: Proxy Int8)
+    else if tc == int16TyConName   then check i tc (Proxy :: Proxy Int16)
+    else if tc == int32TyConName   then check i tc (Proxy :: Proxy Int32)
+    else if tc == int64TyConName   then check i tc (Proxy :: Proxy Int64)
+    else if tc == wordTyConName    then check i tc (Proxy :: Proxy Word)
+    else if tc == word8TyConName   then check i tc (Proxy :: Proxy Word8)
+    else if tc == word16TyConName  then check i tc (Proxy :: Proxy Word16)
+    else if tc == word32TyConName  then check i tc (Proxy :: Proxy Word32)
+    else if tc == word64TyConName  then check i tc (Proxy :: Proxy Word64)
+    else if tc == naturalTyConName then checkPositive i tc
     else return ()
 
   | otherwise = return ()
   where
+    checkPositive :: Integer -> Name -> DsM ()
+    checkPositive i tc
+      = when (i < 0) $ do
+        warnDs (Reason Opt_WarnOverflowedLiterals)
+               (vcat [ text "Literal" <+> integer i
+                       <+> text "is negative but" <+> ppr tc
+                       <+> ptext (sLit "only supports positive numbers")
+                     ])
+
     check :: forall a. (Bounded a, Integral a) => Integer -> Name -> Proxy a -> DsM ()
     check i tc _proxy
       = when (i < minB || i > maxB) $ do
@@ -389,8 +399,8 @@ hsLitKey :: DynFlags -> HsLit GhcTc -> Literal
 -- HsLit does not.
 hsLitKey dflags (HsIntPrim    _ i) = mkMachIntWrap  dflags i
 hsLitKey dflags (HsWordPrim   _ w) = mkMachWordWrap dflags w
-hsLitKey _      (HsInt64Prim  _ i) = mkMachInt64Wrap       i
-hsLitKey _      (HsWord64Prim _ w) = mkMachWord64Wrap      w
+hsLitKey dflags (HsInt64Prim  _ i) = mkMachInt64Wrap  dflags i
+hsLitKey dflags (HsWord64Prim _ w) = mkMachWord64Wrap dflags w
 hsLitKey _      (HsCharPrim   _ c) = mkMachChar            c
 hsLitKey _      (HsFloatPrim  _ f) = mkMachFloat           (fl_value f)
 hsLitKey _      (HsDoublePrim _ d) = mkMachDouble          (fl_value d)
index 920bc4a..f7cea3b 100644 (file)
@@ -444,17 +444,19 @@ assembleI dflags i = case i of
      -- On Windows, stdcall labels have a suffix indicating the no. of
      -- arg words, e.g. foo@8.  testcase: ffi012(ghci)
     literal (MachLabel fs _ _) = litlabel fs
-    literal (MachWord w)       = int (fromIntegral w)
-    literal (MachInt j)        = int (fromIntegral j)
     literal MachNullAddr       = int 0
     literal (MachFloat r)      = float (fromRational r)
     literal (MachDouble r)     = double (fromRational r)
     literal (MachChar c)       = int (ord c)
-    literal (MachInt64 ii)     = int64 (fromIntegral ii)
-    literal (MachWord64 ii)    = int64 (fromIntegral ii)
     literal (MachStr bs)       = lit [BCONPtrStr bs]
        -- MachStr requires a zero-terminator when emitted
-    literal LitInteger{}       = panic "ByteCodeAsm.literal: LitInteger"
+    literal (LitNumber nt i _) = case nt of
+      LitNumInt     -> int (fromIntegral i)
+      LitNumWord    -> int (fromIntegral i)
+      LitNumInt64   -> int64 (fromIntegral i)
+      LitNumWord64  -> int64 (fromIntegral i)
+      LitNumInteger -> panic "ByteCodeAsm.literal: LitNumInteger"
+      LitNumNatural -> panic "ByteCodeAsm.literal: LitNumNatural"
 
     litlabel fs = lit [BCONPtrLbl fs]
     addr (RemotePtr a) = words [fromIntegral a]
index 74168ac..022fe89 100644 (file)
@@ -996,8 +996,8 @@ doCase d s p (_,scrut) bndr alts is_unboxed_tuple
            | otherwise
            = DiscrP (fromIntegral (dataConTag dc - fIRST_TAG))
         my_discr (LitAlt l, _, _)
-           = case l of MachInt i     -> DiscrI (fromInteger i)
-                       MachWord w    -> DiscrW (fromInteger w)
+           = case l of LitNumber LitNumInt i  _  -> DiscrI (fromInteger i)
+                       LitNumber LitNumWord w _  -> DiscrW (fromInteger w)
                        MachFloat r   -> DiscrF (fromRational r)
                        MachDouble r  -> DiscrD (fromRational r)
                        MachChar i    -> DiscrI (ord i)
@@ -1233,7 +1233,7 @@ generateCCall d0 s p (CCallSpec target cconv safety) fn args_r_to_l
          push_r =
              if returns_void
                 then nilOL
-                else unitOL (PUSH_UBX (mkDummyLiteral r_rep) (trunc16W r_sizeW))
+                else unitOL (PUSH_UBX (mkDummyLiteral dflags r_rep) (trunc16W r_sizeW))
 
          -- generate the marshalling code we're going to call
 
@@ -1297,16 +1297,16 @@ primRepToFFIType dflags r
 
 -- Make a dummy literal, to be used as a placeholder for FFI return
 -- values on the stack.
-mkDummyLiteral :: PrimRep -> Literal
-mkDummyLiteral pr
+mkDummyLiteral :: DynFlags -> PrimRep -> Literal
+mkDummyLiteral dflags pr
    = case pr of
-        IntRep    -> MachInt 0
-        WordRep   -> MachWord 0
+        IntRep    -> mkMachInt dflags 0
+        WordRep   -> mkMachWord dflags 0
+        Int64Rep  -> mkMachInt64 0
+        Word64Rep -> mkMachWord64 0
         AddrRep   -> MachNullAddr
         DoubleRep -> MachDouble 0
         FloatRep  -> MachFloat 0
-        Int64Rep  -> MachInt64 0
-        Word64Rep -> MachWord64 0
         _         -> pprPanic "mkDummyLiteral" (ppr pr)
 
 
@@ -1505,11 +1505,11 @@ pushAtom d p (AnnVar var)
 
    | otherwise  -- var must be a global variable
    = do topStrings <- getTopStrings
+        dflags <- getDynFlags
         case lookupVarEnv topStrings var of
-            Just ptr -> pushAtom d p $ AnnLit $ MachWord $ fromIntegral $
-              ptrToWordPtr $ fromRemotePtr ptr
+            Just ptr -> pushAtom d p $ AnnLit $ mkMachWord dflags $
+              fromIntegral $ ptrToWordPtr $ fromRemotePtr ptr
             Nothing -> do
-                dflags <- getDynFlags
                 let sz = idSizeCon dflags var
                 MASSERT( sz == wordSize dflags )
                 return (unitOL (PUSH_G (getName var)), sz)
@@ -1524,19 +1524,21 @@ pushAtom _ _ (AnnLit lit) = do
 
      case lit of
         MachLabel _ _ _ -> code N
-        MachWord _    -> code N
-        MachInt _     -> code N
-        MachWord64 _  -> code L
-        MachInt64 _   -> code L
         MachFloat _   -> code F
         MachDouble _  -> code D
         MachChar _    -> code N
         MachNullAddr  -> code N
         MachStr _     -> code N
-        -- No LitInteger's should be left by the time this is called.
-        -- CorePrep should have converted them all to a real core
-        -- representation.
-        LitInteger {} -> panic "pushAtom: LitInteger"
+        LitNumber nt _ _ -> case nt of
+          LitNumInt     -> code N
+          LitNumWord    -> code N
+          LitNumInt64   -> code L
+          LitNumWord64  -> code L
+          -- No LitInteger's or LitNatural's should be left by the time this is
+          -- called. CorePrep should have converted them all to a real core
+          -- representation.
+          LitNumInteger -> panic "pushAtom: LitInteger"
+          LitNumNatural -> panic "pushAtom: LitNatural"
 
 pushAtom _ _ expr
    = pprPanic "ByteCodeGen.pushAtom"
index 9d04bf2..bffda71 100644 (file)
@@ -1367,9 +1367,15 @@ tcIfaceLit :: Literal -> IfL Literal
 -- Integer literals deserialise to (LitInteger i <error thunk>)
 -- so tcIfaceLit just fills in the type.
 -- See Note [Integer literals] in Literal
-tcIfaceLit (LitInteger i _)
+tcIfaceLit (LitNumber LitNumInteger i _)
   = do t <- tcIfaceTyConByName integerTyConName
        return (mkLitInteger i (mkTyConTy t))
+-- Natural literals deserialise to (LitNatural i <error thunk>)
+-- so tcIfaceLit just fills in the type.
+-- See Note [Natural literals] in Literal
+tcIfaceLit (LitNumber LitNumNatural i _)
+  = do t <- tcIfaceTyConByName naturalTyConName
+       return (mkLitNatural i (mkTyConTy t))
 tcIfaceLit lit = return lit
 
 -------------------------
index 1728bc0..f98e65e 100644 (file)
@@ -1093,9 +1093,14 @@ tidyTopBinds :: HscEnv
 
 tidyTopBinds hsc_env this_mod unfold_env init_occ_env binds
   = do mkIntegerId <- lookupMkIntegerName dflags hsc_env
+       mkNaturalId <- lookupMkNaturalName dflags hsc_env
        integerSDataCon <- lookupIntegerSDataConName dflags hsc_env
-       let cvt_integer = cvtLitInteger dflags mkIntegerId integerSDataCon
-           result      = tidy cvt_integer init_env binds
+       naturalSDataCon <- lookupNaturalSDataConName dflags hsc_env
+       let cvt_literal nt i = case nt of
+             LitNumInteger -> Just (cvtLitInteger dflags mkIntegerId integerSDataCon i)
+             LitNumNatural -> Just (cvtLitNatural dflags mkNaturalId naturalSDataCon i)
+             _             -> Nothing
+           result      = tidy cvt_literal init_env binds
        seqBinds (snd result) `seq` return result
        -- This seqBinds avoids a spike in space usage (see #13564)
   where
@@ -1104,34 +1109,35 @@ tidyTopBinds hsc_env this_mod unfold_env init_occ_env binds
     init_env = (init_occ_env, emptyVarEnv)
 
     tidy _           env []     = (env, [])
-    tidy cvt_integer env (b:bs)
-        = let (env1, b')  = tidyTopBind dflags this_mod
-                                        cvt_integer unfold_env env b
-              (env2, bs') = tidy cvt_integer env1 bs
+    tidy cvt_literal env (b:bs)
+        = let (env1, b')  = tidyTopBind dflags this_mod cvt_literal unfold_env
+                                        env b
+              (env2, bs') = tidy cvt_literal env1 bs
           in  (env2, b':bs')
 
 ------------------------
 tidyTopBind  :: DynFlags
              -> Module
-             -> (Integer -> CoreExpr)
+             -> (LitNumType -> Integer -> Maybe CoreExpr)
              -> UnfoldEnv
              -> TidyEnv
              -> CoreBind
              -> (TidyEnv, CoreBind)
 
-tidyTopBind dflags this_mod cvt_integer unfold_env
+tidyTopBind dflags this_mod cvt_literal unfold_env
             (occ_env,subst1) (NonRec bndr rhs)
   = (tidy_env2,  NonRec bndr' rhs')
   where
     Just (name',show_unfold) = lookupVarEnv unfold_env bndr
-    caf_info      = hasCafRefs dflags this_mod (subst1, cvt_integer)
+    caf_info      = hasCafRefs dflags this_mod
+                               (subst1, cvt_literal)
                                (idArity bndr) rhs
     (bndr', rhs') = tidyTopPair dflags show_unfold tidy_env2 caf_info name'
                                 (bndr, rhs)
     subst2        = extendVarEnv subst1 bndr bndr'
     tidy_env2     = (occ_env, subst2)
 
-tidyTopBind dflags this_mod cvt_integer unfold_env
+tidyTopBind dflags this_mod cvt_literal unfold_env
             (occ_env, subst1) (Rec prs)
   = (tidy_env2, Rec prs')
   where
@@ -1150,7 +1156,7 @@ tidyTopBind dflags this_mod cvt_integer unfold_env
         -- the group may refer indirectly to a CAF (because then, they all do).
     caf_info
         | or [ mayHaveCafRefs (hasCafRefs dflags this_mod
-                                          (subst1, cvt_integer)
+                                          (subst1, cvt_literal)
                                           (idArity bndr) rhs)
              | (bndr,rhs) <- prs ] = MayHaveCafRefs
         | otherwise                = NoCafRefs
@@ -1296,25 +1302,28 @@ We compute hasCafRefs here, because IdInfo is supposed to be finalised
 after TidyPgm.  But CorePrep does some transformations that affect CAF-hood.
 So we have to *predict* the result here, which is revolting.
 
-In particular CorePrep expands Integer literals.  So in the prediction code
-here we resort to applying the same expansion (cvt_integer). Ugh!
+In particular CorePrep expands Integer and Natural literals. So in the
+prediction code here we resort to applying the same expansion (cvt_literal).
+Ugh!
 -}
 
-type CafRefEnv = (VarEnv Id, Integer -> CoreExpr)
+type CafRefEnv = (VarEnv Id, LitNumType -> Integer -> Maybe CoreExpr)
   -- The env finds the Caf-ness of the Id
-  -- The Integer -> CoreExpr is the desugaring function for Integer literals
+  -- The LitNumType -> Integer -> CoreExpr is the desugaring functions for
+  -- Integer and Natural literals
   -- See Note [Disgusting computation of CafRefs]
 
 hasCafRefs :: DynFlags -> Module
            -> CafRefEnv -> Arity -> CoreExpr
            -> CafInfo
-hasCafRefs dflags this_mod p@(_,cvt_integer) arity expr
+hasCafRefs dflags this_mod (subst, cvt_literal) arity expr
   | is_caf || mentions_cafs = MayHaveCafRefs
   | otherwise               = NoCafRefs
  where
-  mentions_cafs   = cafRefsE expr
+  mentions_cafs   = cafRefsE expr
   is_dynamic_name = isDllName dflags this_mod
-  is_caf = not (arity > 0 || rhsIsStatic (targetPlatform dflags) is_dynamic_name cvt_integer expr)
+  is_caf = not (arity > 0 || rhsIsStatic (targetPlatform dflags) is_dynamic_name
+                                         cvt_literal expr)
 
   -- NB. we pass in the arity of the expression, which is expected
   -- to be calculated by exprArity.  This is because exprArity
@@ -1322,34 +1331,36 @@ hasCafRefs dflags this_mod p@(_,cvt_integer) arity expr
   -- CorePrep later on, and we don't want to duplicate that
   -- knowledge in rhsIsStatic below.
 
-cafRefsE :: CafRefEnv -> Expr a -> Bool
-cafRefsE p (Var id)            = cafRefsV p id
-cafRefsE p (Lit lit)           = cafRefsL p lit
-cafRefsE p (App f a)           = cafRefsE p f || cafRefsE p a
-cafRefsE p (Lam _ e)           = cafRefsE p e
-cafRefsE p (Let b e)           = cafRefsEs p (rhssOfBind b) || cafRefsE p e
-cafRefsE p (Case e _ _ alts)   = cafRefsE p e || cafRefsEs p (rhssOfAlts alts)
-cafRefsE p (Tick _n e)         = cafRefsE p e
-cafRefsE p (Cast e _co)        = cafRefsE p e
-cafRefsE _ (Type _)            = False
-cafRefsE _ (Coercion _)        = False
-
-cafRefsEs :: CafRefEnv -> [Expr a] -> Bool
-cafRefsEs _ []     = False
-cafRefsEs p (e:es) = cafRefsE p e || cafRefsEs p es
-
-cafRefsL :: CafRefEnv -> Literal -> Bool
--- Don't forget that mk_integer id might have Caf refs!
--- We first need to convert the Integer into its final form, to
--- see whether mkInteger is used.
-cafRefsL p@(_, cvt_integer) (LitInteger i _) = cafRefsE p (cvt_integer i)
-cafRefsL _                  _                = False
-
-cafRefsV :: CafRefEnv -> Id -> Bool
-cafRefsV (subst, _) id
-  | not (isLocalId id)                = mayHaveCafRefs (idCafInfo id)
-  | Just id' <- lookupVarEnv subst id = mayHaveCafRefs (idCafInfo id')
-  | otherwise                         = False
+  cafRefsE :: Expr a -> Bool
+  cafRefsE (Var id)            = cafRefsV id
+  cafRefsE (Lit lit)           = cafRefsL lit
+  cafRefsE (App f a)           = cafRefsE f || cafRefsE a
+  cafRefsE (Lam _ e)           = cafRefsE e
+  cafRefsE (Let b e)           = cafRefsEs (rhssOfBind b) || cafRefsE e
+  cafRefsE (Case e _ _ alts)   = cafRefsE e || cafRefsEs (rhssOfAlts alts)
+  cafRefsE (Tick _n e)         = cafRefsE e
+  cafRefsE (Cast e _co)        = cafRefsE e
+  cafRefsE (Type _)            = False
+  cafRefsE (Coercion _)        = False
+
+  cafRefsEs :: [Expr a] -> Bool
+  cafRefsEs []     = False
+  cafRefsEs (e:es) = cafRefsE e || cafRefsEs es
+
+  cafRefsL :: Literal -> Bool
+  -- Don't forget that mk_integer id might have Caf refs!
+  -- We first need to convert the Integer into its final form, to
+  -- see whether mkInteger is used. Same for LitNatural.
+  cafRefsL (LitNumber nt i _) = case cvt_literal nt i of
+    Just e  -> cafRefsE e
+    Nothing -> False
+  cafRefsL _                = False
+
+  cafRefsV :: Id -> Bool
+  cafRefsV id
+    | not (isLocalId id)                = mayHaveCafRefs (idCafInfo id)
+    | Just id' <- lookupVarEnv subst id = mayHaveCafRefs (idCafInfo id')
+    | otherwise                         = False
 
 
 {-
index 5ed67d5..d971a8b 100644 (file)
@@ -358,7 +358,9 @@ basicKnownKeyNames
 
         -- Natural
         naturalTyConName,
-        naturalFromIntegerName,
+        naturalFromIntegerName, naturalToIntegerName,
+        plusNaturalName, minusNaturalName, timesNaturalName, mkNaturalName,
+        wordToNaturalName,
 
         -- Float/Double
         rationalToFloatName,
@@ -435,7 +437,7 @@ basicKnownKeyNames
         , eqTyConName
 
     ] ++ case cIntegerLibraryType of
-           IntegerGMP    -> [integerSDataConName]
+           IntegerGMP    -> [integerSDataConName,naturalSDataConName]
            IntegerSimple -> []
 
 genericTyConNames :: [Name]
@@ -473,8 +475,8 @@ pRELUDE         = mkBaseModule_ pRELUDE_NAME
 
 gHC_PRIM, gHC_TYPES, gHC_GENERICS, gHC_MAGIC,
     gHC_CLASSES, gHC_BASE, gHC_ENUM, gHC_GHCI, gHC_CSTRING,
-    gHC_SHOW, gHC_READ, gHC_NUM, gHC_INTEGER_TYPE, gHC_NATURAL, gHC_LIST,
-    gHC_TUPLE, dATA_TUPLE, dATA_EITHER, dATA_STRING,
+    gHC_SHOW, gHC_READ, gHC_NUM, gHC_MAYBE, gHC_INTEGER_TYPE, gHC_NATURAL,
+    gHC_LIST, gHC_TUPLE, dATA_TUPLE, dATA_EITHER, dATA_STRING,
     dATA_FOLDABLE, dATA_TRAVERSABLE,
     gHC_CONC, gHC_IO, gHC_IO_Exception,
     gHC_ST, gHC_ARR, gHC_STABLE, gHC_PTR, gHC_ERR, gHC_REAL,
@@ -497,6 +499,7 @@ gHC_GHCI        = mkBaseModule (fsLit "GHC.GHCi")
 gHC_SHOW        = mkBaseModule (fsLit "GHC.Show")
 gHC_READ        = mkBaseModule (fsLit "GHC.Read")
 gHC_NUM         = mkBaseModule (fsLit "GHC.Num")
+gHC_MAYBE       = mkBaseModule (fsLit "GHC.Maybe")
 gHC_INTEGER_TYPE= mkIntegerModule (fsLit "GHC.Integer.Type")
 gHC_NATURAL     = mkBaseModule (fsLit "GHC.Natural")
 gHC_LIST        = mkBaseModule (fsLit "GHC.List")
@@ -1121,7 +1124,7 @@ integerTyConName, mkIntegerName, integerSDataConName,
     andIntegerName, orIntegerName, xorIntegerName, complementIntegerName,
     shiftLIntegerName, shiftRIntegerName, bitIntegerName :: Name
 integerTyConName      = tcQual  gHC_INTEGER_TYPE (fsLit "Integer")           integerTyConKey
-integerSDataConName   = dcQual gHC_INTEGER_TYPE (fsLit n)                   integerSDataConKey
+integerSDataConName   = dcQual gHC_INTEGER_TYPE (fsLit n)                    integerSDataConKey
   where n = case cIntegerLibraryType of
             IntegerGMP    -> "S#"
             IntegerSimple -> panic "integerSDataConName evaluated for integer-simple"
@@ -1169,12 +1172,25 @@ shiftRIntegerName     = varQual gHC_INTEGER_TYPE (fsLit "shiftRInteger")     shi
 bitIntegerName        = varQual gHC_INTEGER_TYPE (fsLit "bitInteger")        bitIntegerIdKey
 
 -- GHC.Natural types
-naturalTyConName :: Name
+naturalTyConName, naturalSDataConName :: Name
 naturalTyConName     = tcQual gHC_NATURAL (fsLit "Natural") naturalTyConKey
+naturalSDataConName  = dcQual gHC_NATURAL (fsLit n)         naturalSDataConKey
+  where n = case cIntegerLibraryType of
+            IntegerGMP    -> "NatS#"
+            IntegerSimple -> panic "naturalSDataConName evaluated for integer-simple"
 
 naturalFromIntegerName :: Name
 naturalFromIntegerName = varQual gHC_NATURAL (fsLit "naturalFromInteger") naturalFromIntegerIdKey
 
+naturalToIntegerName, plusNaturalName, minusNaturalName, timesNaturalName,
+   mkNaturalName, wordToNaturalName :: Name
+naturalToIntegerName  = varQual gHC_NATURAL (fsLit "naturalToInteger")  naturalToIntegerIdKey
+plusNaturalName       = varQual gHC_NATURAL (fsLit "plusNatural")       plusNaturalIdKey
+minusNaturalName      = varQual gHC_NATURAL (fsLit "minusNatural")      minusNaturalIdKey
+timesNaturalName      = varQual gHC_NATURAL (fsLit "timesNatural")      timesNaturalIdKey
+mkNaturalName         = varQual gHC_NATURAL (fsLit "mkNatural")         mkNaturalIdKey
+wordToNaturalName     = varQual gHC_NATURAL (fsLit "wordToNatural#")    wordToNaturalIdKey
+
 -- GHC.Real types and classes
 rationalTyConName, ratioTyConName, ratioDataConName, realClassName,
     integralClassName, realFracClassName, fractionalClassName,
@@ -2388,8 +2404,17 @@ makeStaticKey :: Unique
 makeStaticKey = mkPreludeMiscIdUnique 561
 
 -- Natural
-naturalFromIntegerIdKey :: Unique
+naturalFromIntegerIdKey, naturalToIntegerIdKey, plusNaturalIdKey,
+   minusNaturalIdKey, timesNaturalIdKey, mkNaturalIdKey,
+   naturalSDataConKey, wordToNaturalIdKey :: Unique
 naturalFromIntegerIdKey = mkPreludeMiscIdUnique 562
+naturalToIntegerIdKey   = mkPreludeMiscIdUnique 563
+plusNaturalIdKey        = mkPreludeMiscIdUnique 564
+minusNaturalIdKey       = mkPreludeMiscIdUnique 565
+timesNaturalIdKey       = mkPreludeMiscIdUnique 566
+mkNaturalIdKey          = mkPreludeMiscIdUnique 567
+naturalSDataConKey      = mkPreludeMiscIdUnique 568
+wordToNaturalIdKey      = mkPreludeMiscIdUnique 569
 
 {-
 ************************************************************************
index 84e4173..369ba4c 100644 (file)
@@ -371,12 +371,11 @@ cmpOp dflags cmp = go
 
     -- These compares are at different types
     go (MachChar i1)   (MachChar i2)   = done (i1 `cmp` i2)
-    go (MachInt i1)    (MachInt i2)    = done (i1 `cmp` i2)
-    go (MachInt64 i1)  (MachInt64 i2)  = done (i1 `cmp` i2)
-    go (MachWord i1)   (MachWord i2)   = done (i1 `cmp` i2)
-    go (MachWord64 i1) (MachWord64 i2) = done (i1 `cmp` i2)
     go (MachFloat i1)  (MachFloat i2)  = done (i1 `cmp` i2)
     go (MachDouble i1) (MachDouble i2) = done (i1 `cmp` i2)
+    go (LitNumber nt1 i1 _) (LitNumber nt2 i2 _)
+      | nt1 /= nt2 = Nothing
+      | otherwise  = done (i1 `cmp` i2)
     go _               _               = Nothing
 
 --------------------------
@@ -386,12 +385,13 @@ negOp _      (MachFloat 0.0)  = Nothing  -- can't represent -0.0 as a Rational
 negOp dflags (MachFloat f)    = Just (mkFloatVal dflags (-f))
 negOp _      (MachDouble 0.0) = Nothing
 negOp dflags (MachDouble d)   = Just (mkDoubleVal dflags (-d))
-negOp dflags (MachInt i)      = intResult dflags (-i)
+negOp dflags (LitNumber nt i t)
+   | litNumIsSigned nt = Just (Lit (mkLitNumberWrap dflags nt (-i) t))
 negOp _      _                = Nothing
 
 complementOp :: DynFlags -> Literal -> Maybe CoreExpr  -- Binary complement
-complementOp dflags (MachWord i) = wordResult dflags (complement i)
-complementOp dflags (MachInt i)  = intResult  dflags (complement i)
+complementOp dflags (LitNumber nt i t) =
+   Just (Lit (mkLitNumberWrap dflags nt (complement i) t))
 complementOp _      _            = Nothing
 
 --------------------------
@@ -403,7 +403,7 @@ intOp2 = intOp2' . const
 intOp2' :: (Integral a, Integral b)
         => (DynFlags -> a -> b -> Integer)
         -> DynFlags -> Literal -> Literal -> Maybe CoreExpr
-intOp2' op dflags (MachInt i1) (MachInt i2) =
+intOp2' op dflags (LitNumber LitNumInt i1 _) (LitNumber LitNumInt i2 _) =
   let o = op dflags
   in  intResult dflags (fromInteger i1 `o` fromInteger i2)
 intOp2' _  _      _            _            = Nothing  -- Could find LitLit
@@ -411,7 +411,7 @@ intOp2' _  _      _            _            = Nothing  -- Could find LitLit
 intOpC2 :: (Integral a, Integral b)
         => (a -> b -> Integer)
         -> DynFlags -> Literal -> Literal -> Maybe CoreExpr
-intOpC2 op dflags (MachInt i1) (MachInt i2) = do
+intOpC2 op dflags (LitNumber LitNumInt i1 _) (LitNumber LitNumInt i2 _) = do
   intCResult dflags (fromInteger i1 `op` fromInteger i2)
 intOpC2 _  _      _            _            = Nothing  -- Could find LitLit
 
@@ -438,14 +438,14 @@ retLitNoC l = do dflags <- getDynFlags
 wordOp2 :: (Integral a, Integral b)
         => (a -> b -> Integer)
         -> DynFlags -> Literal -> Literal -> Maybe CoreExpr
-wordOp2 op dflags (MachWord w1) (MachWord w2)
+wordOp2 op dflags (LitNumber LitNumWord w1 _) (LitNumber LitNumWord w2 _)
     = wordResult dflags (fromInteger w1 `op` fromInteger w2)
 wordOp2 _ _ _ _ = Nothing  -- Could find LitLit
 
 wordOpC2 :: (Integral a, Integral b)
         => (a -> b -> Integer)
         -> DynFlags -> Literal -> Literal -> Maybe CoreExpr
-wordOpC2 op dflags (MachWord w1) (MachWord w2) =
+wordOpC2 op dflags (LitNumber LitNumWord w1 _) (LitNumber LitNumWord w2 _) =
   wordCResult dflags (fromInteger w1 `op` fromInteger w2)
 wordOpC2 _ _ _ _ = Nothing  -- Could find LitLit
 
@@ -454,7 +454,7 @@ shiftRule :: (DynFlags -> Integer -> Int -> Integer) -> RuleM CoreExpr
 -- See Note [Guarding against silly shifts]
 shiftRule shift_op
   = do { dflags <- getDynFlags
-       ; [e1, Lit (MachInt shift_len)] <- getArgs
+       ; [e1, Lit (LitNumber LitNumInt shift_len _)] <- getArgs
        ; case e1 of
            _ | shift_len == 0
              -> return e1
@@ -463,13 +463,10 @@ shiftRule shift_op
                                         ("Bad shift length" ++ show shift_len))
 
            -- Do the shift at type Integer, but shift length is Int
-           Lit (MachInt x)
+           Lit (LitNumber nt x t)
              -> let op = shift_op dflags
-                in  liftMaybe $ intResult dflags (x `op` fromInteger shift_len)
-
-           Lit (MachWord x)
-             -> let op = shift_op dflags
-                in  liftMaybe $ wordResult dflags (x `op` fromInteger shift_len)
+                    y  = x `op` fromInteger shift_len
+                in  liftMaybe $ Just (Lit (mkLitNumberWrap dflags nt y t))
 
            _ -> mzero }
 
@@ -560,20 +557,26 @@ mkRuleFn dflags Le _ (Lit lit) | isMaxBound dflags lit = Just $ trueValInt  dfla
 mkRuleFn _ _ _ _                                       = Nothing
 
 isMinBound :: DynFlags -> Literal -> Bool
-isMinBound _      (MachChar c)   = c == minBound
-isMinBound dflags (MachInt i)    = i == tARGET_MIN_INT dflags
-isMinBound _      (MachInt64 i)  = i == toInteger (minBound :: Int64)
-isMinBound _      (MachWord i)   = i == 0
-isMinBound _      (MachWord64 i) = i == 0
-isMinBound _      _              = False
+isMinBound _      (MachChar c)       = c == minBound
+isMinBound dflags (LitNumber nt i _) = case nt of
+   LitNumInt     -> i == tARGET_MIN_INT dflags
+   LitNumInt64   -> i == toInteger (minBound :: Int64)
+   LitNumWord    -> i == 0
+   LitNumWord64  -> i == 0
+   LitNumNatural -> i == 0
+   LitNumInteger -> False
+isMinBound _      _                  = False
 
 isMaxBound :: DynFlags -> Literal -> Bool
-isMaxBound _      (MachChar c)   = c == maxBound
-isMaxBound dflags (MachInt i)    = i == tARGET_MAX_INT dflags
-isMaxBound _      (MachInt64 i)  = i == toInteger (maxBound :: Int64)
-isMaxBound dflags (MachWord i)   = i == tARGET_MAX_WORD dflags
-isMaxBound _      (MachWord64 i) = i == toInteger (maxBound :: Word64)
-isMaxBound _      _              = False
+isMaxBound _      (MachChar c)       = c == maxBound
+isMaxBound dflags (LitNumber nt i _) = case nt of
+   LitNumInt     -> i == tARGET_MAX_INT dflags
+   LitNumInt64   -> i == toInteger (maxBound :: Int64)
+   LitNumWord    -> i == tARGET_MAX_WORD dflags
+   LitNumWord64  -> i == toInteger (maxBound :: Word64)
+   LitNumNatural -> False
+   LitNumInteger -> False
+isMaxBound _      _                  = False
 
 -- | Create an Int literal expression while ensuring the given Integer is in the
 -- target Int range
@@ -961,7 +964,7 @@ tagToEnumRule :: RuleM CoreExpr
 -- If     data T a = A | B | C
 -- then   tag2Enum# (T ty) 2# -->  B ty
 tagToEnumRule = do
-  [Type ty, Lit (MachInt i)] <- getArgs
+  [Type ty, Lit (LitNumber LitNumInt i _)] <- getArgs
   case splitTyConApp_maybe ty of
     Just (tycon, tc_args) | isEnumerationTyCon tycon -> do
       let tag = fromInteger i
@@ -1135,7 +1138,7 @@ builtinRules
         [ nonZeroLit 1 >> binaryLit (intOp2 div)
         , leftZero zeroi
         , do
-          [arg, Lit (MachInt d)] <- getArgs
+          [arg, Lit (LitNumber LitNumInt d _)] <- getArgs
           Just n <- return $ exactLog2 d
           dflags <- getDynFlags
           return $ Var (mkPrimOpId ISraOp) `App` arg `App` mkIntVal dflags n
@@ -1144,7 +1147,7 @@ builtinRules
         [ nonZeroLit 1 >> binaryLit (intOp2 mod)
         , leftZero zeroi
         , do
-          [arg, Lit (MachInt d)] <- getArgs
+          [arg, Lit (LitNumber LitNumInt d _)] <- getArgs
           Just _ <- return $ exactLog2 d
           dflags <- getDynFlags
           return $ Var (mkPrimOpId AndIOp)
@@ -1152,6 +1155,7 @@ builtinRules
         ]
      ]
  ++ builtinIntegerRules
+ ++ builtinNaturalRules
 {-# NOINLINE builtinRules #-}
 -- there is no benefit to inlining these yet, despite this, GHC produces
 -- unfoldings for this regardless since the floated list entries look small.
@@ -1268,6 +1272,31 @@ builtinIntegerRules =
            = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 2,
                            ru_try = match_rationalTo mkLit }
 
+builtinNaturalRules :: [CoreRule]
+builtinNaturalRules =
+ [rule_binop              "plusNatural"        plusNaturalName         (+)
+ ,rule_partial_binop      "minusNatural"       minusNaturalName        (\a b -> if a >= b then Just (a - b) else Nothing)
+ ,rule_binop              "timesNatural"       timesNaturalName        (*)
+ ,rule_NaturalFromInteger "naturalFromInteger" naturalFromIntegerName
+ ,rule_NaturalToInteger   "naturalToInteger"   naturalToIntegerName
+ ,rule_WordToNatural      "wordToNatural"      wordToNaturalName
+ ]
+    where rule_binop str name op
+           = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 2,
+                           ru_try = match_Natural_binop op }
+          rule_partial_binop str name op
+           = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 2,
+                           ru_try = match_Natural_partial_binop op }
+          rule_NaturalToInteger str name
+           = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 1,
+                           ru_try = match_NaturalToInteger }
+          rule_NaturalFromInteger str name
+           = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 1,
+                           ru_try = match_NaturalFromInteger }
+          rule_WordToNatural str name
+           = BuiltinRule { ru_name = fsLit str, ru_fn = name, ru_nargs = 1,
+                           ru_try = match_WordToNatural }
+
 ---------------------------------------------------
 -- The rule is this:
 --      unpackFoldrCString# "foo" c (unpackFoldrCString# "baz" c n)
@@ -1359,34 +1388,65 @@ match_IntToInteger = match_IntToInteger_unop id
 
 match_WordToInteger :: RuleFun
 match_WordToInteger _ id_unf id [xl]
-  | Just (MachWord x) <- exprIsLiteral_maybe id_unf xl
+  | Just (LitNumber LitNumWord x _) <- exprIsLiteral_maybe id_unf xl
   = case splitFunTy_maybe (idType id) of
     Just (_, integerTy) ->
-        Just (Lit (LitInteger x integerTy))
+        Just (Lit (mkLitInteger x integerTy))
     _ ->
         panic "match_WordToInteger: Id has the wrong type"
 match_WordToInteger _ _ _ _ = Nothing
 
 match_Int64ToInteger :: RuleFun
 match_Int64ToInteger _ id_unf id [xl]
-  | Just (MachInt64 x) <- exprIsLiteral_maybe id_unf xl
+  | Just (LitNumber LitNumInt64 x _) <- exprIsLiteral_maybe id_unf xl
   = case splitFunTy_maybe (idType id) of
     Just (_, integerTy) ->
-        Just (Lit (LitInteger x integerTy))
+        Just (Lit (mkLitInteger x integerTy))
     _ ->
         panic "match_Int64ToInteger: Id has the wrong type"
 match_Int64ToInteger _ _ _ _ = Nothing
 
 match_Word64ToInteger :: RuleFun
 match_Word64ToInteger _ id_unf id [xl]
-  | Just (MachWord64 x) <- exprIsLiteral_maybe id_unf xl
+  | Just (LitNumber LitNumWord64 x _) <- exprIsLiteral_maybe id_unf xl
   = case splitFunTy_maybe (idType id) of
     Just (_, integerTy) ->
-        Just (Lit (LitInteger x integerTy))
+        Just (Lit (mkLitInteger x integerTy))
     _ ->
         panic "match_Word64ToInteger: Id has the wrong type"
 match_Word64ToInteger _ _ _ _ = Nothing
 
+match_NaturalToInteger :: RuleFun
+match_NaturalToInteger _ id_unf id [xl]
+  | Just (LitNumber LitNumNatural x _) <- exprIsLiteral_maybe id_unf xl
+  = case splitFunTy_maybe (idType id) of
+    Just (_, naturalTy) ->
+        Just (Lit (LitNumber LitNumInteger x naturalTy))
+    _ ->
+        panic "match_NaturalToInteger: Id has the wrong type"
+match_NaturalToInteger _ _ _ _ = Nothing
+
+match_NaturalFromInteger :: RuleFun
+match_NaturalFromInteger _ id_unf id [xl]
+  | Just (LitNumber LitNumInteger x _) <- exprIsLiteral_maybe id_unf xl
+  , x >= 0
+  = case splitFunTy_maybe (idType id) of
+    Just (_, naturalTy) ->
+        Just (Lit (LitNumber LitNumNatural x naturalTy))
+    _ ->
+        panic "match_NaturalFromInteger: Id has the wrong type"
+match_NaturalFromInteger _ _ _ _ = Nothing
+
+match_WordToNatural :: RuleFun
+match_WordToNatural _ id_unf id [xl]
+  | Just (LitNumber LitNumWord x _) <- exprIsLiteral_maybe id_unf xl
+  = case splitFunTy_maybe (idType id) of
+    Just (_, naturalTy) ->
+        Just (Lit (LitNumber LitNumNatural x naturalTy))
+    _ ->
+        panic "match_WordToNatural: Id has the wrong type"
+match_WordToNatural _ _ _ _ = Nothing
+
 -------------------------------------------------
 {- Note [Rewriting bitInteger]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -1397,7 +1457,7 @@ constant-folding (see Trac #8832). The bitInteger rule above provides constant f
 specifically for this function.
 
 There is, however, a bit of trickiness here when it comes to ranges. While the
-AST encodes all integers (even MachInts) as Integers, `bit` expects the bit
+AST encodes all integers as Integers, `bit` expects the bit
 index to be given as an Int. Hence we coerce to an Int in the rule definition.
 This will behave a bit funny for constants larger than the word size, but the user
 should expect some funniness given that they will have at very least ignored a
@@ -1407,7 +1467,7 @@ warning in this case.
 match_bitInteger :: RuleFun
 -- Just for GHC.Integer.Type.bitInteger :: Int# -> Integer
 match_bitInteger dflags id_unf fn [arg]
-  | Just (MachInt x) <- exprIsLiteral_maybe id_unf arg
+  | Just (LitNumber LitNumInt x _) <- exprIsLiteral_maybe id_unf arg
   , x >= 0
   , x <= (wordSizeInBits dflags - 1)
     -- Make sure x is small enough to yield a decently small iteger
@@ -1417,7 +1477,7 @@ match_bitInteger dflags id_unf fn [arg]
   , let x_int = fromIntegral x :: Int
   = case splitFunTy_maybe (idType fn) of
     Just (_, integerTy)
-      -> Just (Lit (LitInteger (bit x_int) integerTy))
+      -> Just (Lit (LitNumber LitNumInteger (bit x_int) integerTy))
     _ -> panic "match_IntToInteger_unop: Id has the wrong type"
 
 match_bitInteger _ _ _ _ = Nothing
@@ -1428,71 +1488,86 @@ match_Integer_convert :: Num a
                       => (DynFlags -> a -> Expr CoreBndr)
                       -> RuleFun
 match_Integer_convert convert dflags id_unf _ [xl]
-  | Just (LitInteger x _) <- exprIsLiteral_maybe id_unf xl
+  | Just (LitNumber LitNumInteger x _) <- exprIsLiteral_maybe id_unf xl
   = Just (convert dflags (fromInteger x))
 match_Integer_convert _ _ _ _ _ = Nothing
 
 match_Integer_unop :: (Integer -> Integer) -> RuleFun
 match_Integer_unop unop _ id_unf _ [xl]
-  | Just (LitInteger x i) <- exprIsLiteral_maybe id_unf xl
-  = Just (Lit (LitInteger (unop x) i))
+  | Just (LitNumber LitNumInteger x i) <- exprIsLiteral_maybe id_unf xl
+  = Just (Lit (LitNumber LitNumInteger (unop x) i))
 match_Integer_unop _ _ _ _ _ = Nothing
 
 match_IntToInteger_unop :: (Integer -> Integer) -> RuleFun
 match_IntToInteger_unop unop _ id_unf fn [xl]
-  | Just (MachInt x) <- exprIsLiteral_maybe id_unf xl
+  | Just (LitNumber LitNumInt x _) <- exprIsLiteral_maybe id_unf xl
   = case splitFunTy_maybe (idType fn) of
     Just (_, integerTy) ->
-        Just (Lit (LitInteger (unop x) integerTy))
+        Just (Lit (LitNumber LitNumInteger (unop x) integerTy))
     _ ->
         panic "match_IntToInteger_unop: Id has the wrong type"
 match_IntToInteger_unop _ _ _ _ _ = Nothing
 
 match_Integer_binop :: (Integer -> Integer -> Integer) -> RuleFun
 match_Integer_binop binop _ id_unf _ [xl,yl]
-  | Just (LitInteger x i) <- exprIsLiteral_maybe id_unf xl
-  , Just (LitInteger y _) <- exprIsLiteral_maybe id_unf yl
-  = Just (Lit (LitInteger (x `binop` y) i))
+  | Just (LitNumber LitNumInteger x i) <- exprIsLiteral_maybe id_unf xl
+  , Just (LitNumber LitNumInteger y _) <- exprIsLiteral_maybe id_unf yl
+  = Just (Lit (mkLitInteger (x `binop` y) i))
 match_Integer_binop _ _ _ _ _ = Nothing
 
+match_Natural_binop :: (Integer -> Integer -> Integer) -> RuleFun
+match_Natural_binop binop _ id_unf _ [xl,yl]
+  | Just (LitNumber LitNumNatural x i) <- exprIsLiteral_maybe id_unf xl
+  , Just (LitNumber LitNumNatural y _) <- exprIsLiteral_maybe id_unf yl
+  = Just (Lit (mkLitNatural (x `binop` y) i))
+match_Natural_binop _ _ _ _ _ = Nothing
+
+match_Natural_partial_binop :: (Integer -> Integer -> Maybe Integer) -> RuleFun
+match_Natural_partial_binop binop _ id_unf _ [xl,yl]
+  | Just (LitNumber LitNumNatural x i) <- exprIsLiteral_maybe id_unf xl
+  , Just (LitNumber LitNumNatural y _) <- exprIsLiteral_maybe id_unf yl
+  , Just z <- x `binop` y
+  = Just (Lit (mkLitNatural z i))
+match_Natural_partial_binop _ _ _ _ _ = Nothing
+
 -- This helper is used for the quotRem and divMod functions
 match_Integer_divop_both
    :: (Integer -> Integer -> (Integer, Integer)) -> RuleFun
 match_Integer_divop_both divop _ id_unf _ [xl,yl]
-  | Just (LitInteger x t) <- exprIsLiteral_maybe id_unf xl
-  , Just (LitInteger y _) <- exprIsLiteral_maybe id_unf yl
+  | Just (LitNumber LitNumInteger x t) <- exprIsLiteral_maybe id_unf xl
+  , Just (LitNumber LitNumInteger y _) <- exprIsLiteral_maybe id_unf yl
   , y /= 0
   , (r,s) <- x `divop` y
-  = Just $ mkCoreUbxTup [t,t] [Lit (LitInteger r t), Lit (LitInteger s t)]
+  = Just $ mkCoreUbxTup [t,t] [Lit (mkLitInteger r t), Lit (mkLitInteger s t)]
 match_Integer_divop_both _ _ _ _ _ = Nothing
 
 -- This helper is used for the quot and rem functions
 match_Integer_divop_one :: (Integer -> Integer -> Integer) -> RuleFun
 match_Integer_divop_one divop _ id_unf _ [xl,yl]
-  | Just (LitInteger x i) <- exprIsLiteral_maybe id_unf xl
-  , Just (LitInteger y _) <- exprIsLiteral_maybe id_unf yl
+  | Just (LitNumber LitNumInteger x i) <- exprIsLiteral_maybe id_unf xl
+  , Just (LitNumber LitNumInteger y _) <- exprIsLiteral_maybe id_unf yl
   , y /= 0
-  = Just (Lit (LitInteger (x `divop` y) i))
+  = Just (Lit (mkLitInteger (x `divop` y) i))
 match_Integer_divop_one _ _ _ _ _ = Nothing
 
 match_Integer_Int_binop :: (Integer -> Int -> Integer) -> RuleFun
 match_Integer_Int_binop binop _ id_unf _ [xl,yl]
-  | Just (LitInteger x i) <- exprIsLiteral_maybe id_unf xl
-  , Just (MachInt y)      <- exprIsLiteral_maybe id_unf yl
-  = Just (Lit (LitInteger (x `binop` fromIntegral y) i))
+  | Just (LitNumber LitNumInteger x i) <- exprIsLiteral_maybe id_unf xl
+  , Just (LitNumber LitNumInt y _)     <- exprIsLiteral_maybe id_unf yl
+  = Just (Lit (mkLitInteger (x `binop` fromIntegral y) i))
 match_Integer_Int_binop _ _ _ _ _ = Nothing
 
 match_Integer_binop_Prim :: (Integer -> Integer -> Bool) -> RuleFun
 match_Integer_binop_Prim binop dflags id_unf _ [xl, yl]
-  | Just (LitInteger x _) <- exprIsLiteral_maybe id_unf xl
-  , Just (LitInteger y _) <- exprIsLiteral_maybe id_unf yl
+  | Just (LitNumber LitNumInteger x _) <- exprIsLiteral_maybe id_unf xl
+  , Just (LitNumber LitNumInteger y _) <- exprIsLiteral_maybe id_unf yl
   = Just (if x `binop` y then trueValInt dflags else falseValInt dflags)
 match_Integer_binop_Prim _ _ _ _ _ = Nothing
 
 match_Integer_binop_Ordering :: (Integer -> Integer -> Ordering) -> RuleFun
 match_Integer_binop_Ordering binop _ id_unf _ [xl, yl]
-  | Just (LitInteger x _) <- exprIsLiteral_maybe id_unf xl
-  , Just (LitInteger y _) <- exprIsLiteral_maybe id_unf yl
+  | Just (LitNumber LitNumInteger x _) <- exprIsLiteral_maybe id_unf xl
+  , Just (LitNumber LitNumInteger y _) <- exprIsLiteral_maybe id_unf yl
   = Just $ case x `binop` y of
              LT -> ltVal
              EQ -> eqVal
@@ -1503,8 +1578,8 @@ match_Integer_Int_encodeFloat :: RealFloat a
                               => (a -> Expr CoreBndr)
                               -> RuleFun
 match_Integer_Int_encodeFloat mkLit _ id_unf _ [xl,yl]
-  | Just (LitInteger x _) <- exprIsLiteral_maybe id_unf xl
-  , Just (MachInt y)      <- exprIsLiteral_maybe id_unf yl
+  | Just (LitNumber LitNumInteger x _) <- exprIsLiteral_maybe id_unf xl
+  , Just (LitNumber LitNumInt y _)     <- exprIsLiteral_maybe id_unf yl
   = Just (mkLit $ encodeFloat x (fromInteger y))
 match_Integer_Int_encodeFloat _ _ _ _ _ = Nothing
 
@@ -1522,14 +1597,14 @@ match_rationalTo :: RealFloat a
                  => (a -> Expr CoreBndr)
                  -> RuleFun
 match_rationalTo mkLit _ id_unf _ [xl, yl]
-  | Just (LitInteger x _) <- exprIsLiteral_maybe id_unf xl
-  , Just (LitInteger y _) <- exprIsLiteral_maybe id_unf yl
+  | Just (LitNumber LitNumInteger x _) <- exprIsLiteral_maybe id_unf xl
+  , Just (LitNumber LitNumInteger y _) <- exprIsLiteral_maybe id_unf yl
   , y /= 0
   = Just (mkLit (fromRational (x % y)))
 match_rationalTo _ _ _ _ _ = Nothing
 
 match_decodeDouble :: RuleFun
-match_decodeDouble _ id_unf fn [xl]
+match_decodeDouble dflags id_unf fn [xl]
   | Just (MachDouble x) <- exprIsLiteral_maybe id_unf xl
   = case splitFunTy_maybe (idType fn) of
     Just (_, res)
@@ -1537,8 +1612,8 @@ match_decodeDouble _ id_unf fn [xl]
       -> case decodeFloat (fromRational x :: Double) of
            (y, z) ->
              Just $ mkCoreUbxTup [integerTy, intHashTy]
-                                 [Lit (LitInteger y integerTy),
-                                  Lit (MachInt (toInteger z))]
+                                 [Lit (mkLitInteger y integerTy),
+                                  Lit (mkMachInt dflags (toInteger z))]
     _ ->
         pprPanic "match_decodeDouble: Id has the wrong type"
           (ppr fn <+> dcolon <+> ppr (idType fn))
@@ -1670,7 +1745,8 @@ tx_con_tte dflags (DataAlt dc)  -- See Note [caseRules for tagToEnum]
 
 tx_con_dtt :: Type -> AltCon -> AltCon
 tx_con_dtt _  DEFAULT              = DEFAULT
-tx_con_dtt ty (LitAlt (MachInt i)) = DataAlt (get_con ty (fromInteger i))
+tx_con_dtt ty (LitAlt (LitNumber LitNumInt i _))
+   = DataAlt (get_con ty (fromInteger i))
 tx_con_dtt _  alt                  = pprPanic "caseRules" (ppr alt)
 
 get_con :: Type -> ConTagZ -> DataCon
@@ -1711,7 +1787,7 @@ We don't want to get this!
       DEFAULT -> e1
       DEFAULT -> e2
 
-Instead, we deal with turning one branch into DEAFULT in SimplUtils
+Instead, we deal with turning one branch into DEFAULT in SimplUtils
 (add_default in mkCase3).
 
 Note [caseRules for dataToTag]
index 1156d81..b96581e 100644 (file)
@@ -271,11 +271,11 @@ nilDataConName    = mkWiredInDataConName BuiltInSyntax gHC_TYPES (fsLit "[]") ni
 consDataConName   = mkWiredInDataConName BuiltInSyntax gHC_TYPES (fsLit ":") consDataConKey consDataCon
 
 maybeTyConName, nothingDataConName, justDataConName :: Name
-maybeTyConName     = mkWiredInTyConName   UserSyntax gHC_BASE (fsLit "Maybe")
+maybeTyConName     = mkWiredInTyConName   UserSyntax gHC_MAYBE (fsLit "Maybe")
                                           maybeTyConKey maybeTyCon
-nothingDataConName = mkWiredInDataConName UserSyntax gHC_BASE (fsLit "Nothing")
+nothingDataConName = mkWiredInDataConName UserSyntax gHC_MAYBE (fsLit "Nothing")
                                           nothingDataConKey nothingDataCon
-justDataConName    = mkWiredInDataConName UserSyntax gHC_BASE (fsLit "Just")
+justDataConName    = mkWiredInDataConName UserSyntax gHC_MAYBE (fsLit "Just")
                                           justDataConKey justDataCon
 
 wordTyConName, wordDataConName, word8TyConName, word8DataConName :: Name
index bcf699b..5c271c2 100644 (file)
@@ -203,7 +203,7 @@ import CoreSyn
 import DataCon
 import FastString (FastString, mkFastString)
 import Id
-import Literal (Literal (..), literalType)
+import Literal
 import MkCore (aBSENT_SUM_FIELD_ERROR_ID)
 import MkId (voidPrimId, voidArgId)
 import MonadUtils (mapAccumLM)
@@ -211,7 +211,7 @@ import Outputable
 import RepType
 import StgSyn
 import Type
-import TysPrim (intPrimTy)
+import TysPrim (intPrimTy,wordPrimTy,word64PrimTy)
 import TysWiredIn
 import UniqSupply
 import Util
@@ -478,7 +478,7 @@ unariseSumAlt rho _ (DEFAULT, _, e)
 unariseSumAlt rho args (DataAlt sumCon, bs, e)
   = do let rho' = mapSumIdBinders bs args rho
        e' <- unariseExpr rho' e
-       return ( LitAlt (MachInt (fromIntegral (dataConTag sumCon))), [], e' )
+       return ( LitAlt (LitNumber LitNumInt (fromIntegral (dataConTag sumCon)) intPrimTy), [], e' )
 
 unariseSumAlt _ scrt alt
   = pprPanic "unariseSumAlt" (ppr scrt $$ ppr alt)
@@ -564,7 +564,7 @@ mkUbxSum dc ty_args args0
       tag = dataConTag dc
 
       layout'  = layoutUbxSum sum_slots (mapMaybe (typeSlotTy . stgArgType) args0)
-      tag_arg  = StgLitArg (MachInt (fromIntegral tag))
+      tag_arg  = StgLitArg (LitNumber LitNumInt (fromIntegral tag) intPrimTy)
       arg_idxs = IM.fromList (zipEqual "mkUbxSum" layout' args0)
 
       mkTupArgs :: Int -> [SlotTy] -> IM.IntMap StgArg -> [StgArg]
@@ -579,8 +579,8 @@ mkUbxSum dc ty_args args0
       slotRubbishArg :: SlotTy -> StgArg
       slotRubbishArg PtrSlot    = StgVarArg aBSENT_SUM_FIELD_ERROR_ID
                          -- See Note [aBSENT_SUM_FIELD_ERROR_ID] in MkCore
-      slotRubbishArg WordSlot   = StgLitArg (MachWord 0)
-      slotRubbishArg Word64Slot = StgLitArg (MachWord64 0)
+      slotRubbishArg WordSlot   = StgLitArg (LitNumber LitNumWord 0 wordPrimTy)
+      slotRubbishArg Word64Slot = StgLitArg (LitNumber LitNumWord64 0 word64PrimTy)
       slotRubbishArg FloatSlot  = StgLitArg (MachFloat 0)
       slotRubbishArg DoubleSlot = StgLitArg (MachDouble 0)
     in
index e2ed395..fdd8d5b 100644 (file)
@@ -390,9 +390,10 @@ coreToStgExpr
 -- on these components, but it in turn is not scrutinised as the basis for any
 -- decisions.  Hence no black holes.
 
--- No LitInteger's should be left by the time this is called. CorePrep
--- should have converted them all to a real core representation.
-coreToStgExpr (Lit (LitInteger {})) = panic "coreToStgExpr: LitInteger"
+-- No LitInteger's or LitNatural's should be left by the time this is called.
+-- CorePrep should have converted them all to a real core representation.
+coreToStgExpr (Lit (LitNumber LitNumInteger _ _)) = panic "coreToStgExpr: LitInteger"
+coreToStgExpr (Lit (LitNumber LitNumNatural _ _)) = panic "coreToStgExpr: LitNatural"
 coreToStgExpr (Lit l)      = return (StgLit l, emptyFVInfo)
 coreToStgExpr (Var v)      = coreToStgApp Nothing v               [] []
 coreToStgExpr (Coercion _) = coreToStgApp Nothing coercionTokenId [] []
index 1fc3880..60edf78 100644 (file)
@@ -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
index 8154433..194df08 100644 (file)
@@ -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 )
index 8dbda6f..af16355 100644 (file)
@@ -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 #-}
index b8f984c..4953a7d 100644 (file)
@@ -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).
index ca85b49..64e6365 100644 (file)
@@ -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
index feb4585..234ccb3 100644 (file)
@@ -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
index a48fb10..1f1ad90 100644 (file)
@@ -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
index f966b3f..3b32e23 100644 (file)
 -----------------------------------------------------------------------------
 
 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"
index d539dd4..4507b20 100644 (file)
@@ -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 (file)
index 0000000..6c3eb49
--- /dev/null
@@ -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 (file)
index 0000000..1b4f0c0
--- /dev/null
@@ -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
index ad2a872..9bc1611 100644 (file)
@@ -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 (file)
index 0000000..9fcf8b7
--- /dev/null
@@ -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
+           )
index 32cf2d2..db8d8b8 100644 (file)
@@ -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#)
index fd98c19..795e74a 100644 (file)
@@ -1,5 +1,5 @@
 {-# LANGUAGE Trustworthy #-}
-{-# LANGUAGE NoImplicitPrelude, MagicHash, UnboxedTuples #-}
+{-# LANGUAGE CPP, NoImplicitPrelude, MagicHash, UnboxedTuples #-}
 {-# OPTIONS_HADDOCK hide #-}
 
 -----------------------------------------------------------------------------
 --
 -----------------------------------------------------------------------------
 
-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
index f7870a2..ef9d8df 100644 (file)
@@ -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
index 7f2ecd0..f88666a 100644 (file)
 
 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
index 798dff9..a41bf81 100644 (file)
@@ -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
index d40342c..4c8a106 100644 (file)
@@ -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
index 1df9d14..18cc4db 100644 (file)
@@ -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
index df1c109..d9a7977 100644 (file)
@@ -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
index 1d439be..dbeec33 100644 (file)
@@ -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
index 95ece50..eb517a9 100644 (file)
@@ -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"
index e03f471..a8e6495 100644 (file)
@@ -28,8 +28,8 @@ T13242a.hs:13:11: error:
         instance Eq Ordering -- Defined in ‘GHC.Classes’
         instance Eq Integer
           -- Defined in ‘integer-gmp-1.0.2.0:GHC.Integer.Type’
-        instance Eq a => Eq (Maybe a) -- Defined in ‘GHC.Base
-        ...plus 22 others
+        instance Eq () -- Defined in ‘GHC.Classes
+        ...plus 21 others
         ...plus six instances involving out-of-scope types
         (use -fprint-potential-instances to see them all)
     • In a stmt of a 'do' block: return (x == x)
index d531e91..9c008e0 100644 (file)
@@ -116,7 +116,7 @@ Derived type family instances:
                                                                            'GHC.Types.True)
                                                                         (GHC.Generics.S1
                                                                            ('GHC.Generics.MetaSel
-                                                                              ('GHC.Base.Just
+                                                                              ('GHC.Maybe.Just
                                                                                  "element")
                                                                               'GHC.Generics.NoSourceUnpackedness
                                                                               'GHC.Generics.NoSourceStrictness
@@ -124,7 +124,7 @@ Derived type family instances:
                                                                            (GHC.Generics.Rec0 a)
                                                                          GHC.Generics.:*: GHC.Generics.S1
                                                                                             ('GHC.Generics.MetaSel
-                                                                                               ('GHC.Base.Just
+                                                                                               ('GHC.Maybe.Just
                                                                                                   "rest")
                                                                                                'GHC.Generics.NoSourceUnpackedness
                                                                                                'GHC.Generics.NoSourceStrictness
@@ -146,7 +146,7 @@ Derived type family instances:
                                                                         'GHC.Types.True)
                                                                      (GHC.Generics.S1
                                                                         ('GHC.Generics.MetaSel
-                                                                           ('GHC.Base.Just
+                                                                           ('GHC.Maybe.Just
                                                                               "element")
                                                                            'GHC.Generics.NoSourceUnpackedness
                                                                            'GHC.Generics.NoSourceStrictness
@@ -154,7 +154,7 @@ Derived type family instances:
                                                                         GHC.Generics.Par1
                                                                       GHC.Generics.:*: GHC.Generics.S1
                                                                                          ('GHC.Generics.MetaSel
-                                                                                            ('GHC.Base.Just
+                                                                                            ('GHC.Maybe.Just
                                                                                                "rest")
                                                                                             'GHC.Generics.NoSourceUnpackedness
                                                                                             'GHC.Generics.NoSourceStrictness
@@ -180,14 +180,14 @@ Derived type family instances:
                                                                            'GHC.Types.False)
                                                                         (GHC.Generics.S1
                                                                            ('GHC.Generics.MetaSel
-                                                                              'GHC.Base.Nothing
+                                                                              'GHC.Maybe.Nothing
                                                                               'GHC.Generics.NoSourceUnpackedness
                                                                               'GHC.Generics.NoSourceStrictness
                                                                               'GHC.Generics.DecidedLazy)
                                                                            (GHC.Generics.Rec0 a)
                                                                          GHC.Generics.:*: GHC.Generics.S1
                                                                                             ('GHC.Generics.MetaSel
-                                                                                               'GHC.Base.Nothing
+                                                                                               'GHC.Maybe.Nothing
                                                                                                'GHC.Generics.NoSourceUnpackedness
                                                                                                'GHC.Generics.NoSourceStrictness
                                                                                                'GHC.Generics.DecidedLazy)
@@ -211,14 +211,14 @@ Derived type family instances:
                                                                         'GHC.Types.False)
                                                                      (GHC.Generics.S1
                                                                         ('GHC.Generics.MetaSel
-                                                                           'GHC.Base.Nothing
+                                                                           'GHC.Maybe.Nothing
                                                                            'GHC.Generics.NoSourceUnpackedness
                                                                            'GHC.Generics.NoSourceStrictness
                                                                            'GHC.Generics.DecidedLazy)
                                                                         GHC.Generics.Par1
                                                                       GHC.Generics.:*: GHC.Generics.S1
                                                                                          ('GHC.Generics.MetaSel
-                                                                                            'GHC.Base.Nothing
+                                                                                            'GHC.Maybe.Nothing
                                                                                             'GHC.Generics.NoSourceUnpackedness
                                                                                             'GHC.Generics.NoSourceStrictness
                                                                                             'GHC.Generics.DecidedLazy)
index bf9cf15..6090499 100644 (file)
@@ -43,7 +43,7 @@ Derived type family instances:
                                                                            'GHC.Types.True)
                                                                         (GHC.Generics.S1
                                                                            ('GHC.Generics.MetaSel
-                                                                              ('GHC.Base.Just
+                                                                              ('GHC.Maybe.Just
                                                                                  "element")
                                                                               'GHC.Generics.NoSourceUnpackedness
                                                                               'GHC.Generics.NoSourceStrictness
@@ -51,7 +51,7 @@ Derived type family instances:
                                                                            GHC.Generics.Par1
                                                                          GHC.Generics.:*: GHC.Generics.S1
                                                                                             ('GHC.Generics.MetaSel
-                                                                                               ('GHC.Base.Just
+                                                                                               ('GHC.Maybe.Just
                                                                                                   "rest")
                                                                                                'GHC.Generics.NoSourceUnpackedness
                                                                                                'GHC.Generics.NoSourceStrictness
index 5f4e7e2..139d7ed 100644 (file)
@@ -178,14 +178,14 @@ Derived type family instances:
                                                                    'GHC.Types.True)
                                                                 (GHC.Generics.S1
                                                                    ('GHC.Generics.MetaSel
-                                                                      ('GHC.Base.Just "d11d")
+                                                                      ('GHC.Maybe.Just "d11d")
                                                                       'GHC.Generics.NoSourceUnpackedness
                                                                       'GHC.Generics.NoSourceStrictness
                                                                       'GHC.Generics.DecidedLazy)
                                                                    GHC.Generics.Par1
                                                                  GHC.Generics.:*: GHC.Generics.S1
                                                                                     ('GHC.Generics.MetaSel
-                                                                                       ('GHC.Base.Just
+                                                                                       ('GHC.Maybe.Just
                                                                                           "d12d")
                                                                                        'GHC.Generics.NoSourceUnpackedness
                                                                                        'GHC.Generics.NoSourceStrictness
@@ -206,14 +206,14 @@ Derived type family instances:
                                                                       'GHC.Types.True)
                                                                    (GHC.Generics.S1
                                                                       ('GHC.Generics.MetaSel
-                                                                         ('GHC.Base.Just "d11d")
+                                                                         ('GHC.Maybe.Just "d11d")
                                                                          'GHC.Generics.NoSourceUnpackedness
                                                                          'GHC.Generics.NoSourceStrictness
                                                                          'GHC.Generics.DecidedLazy)
                                                                       (GHC.Generics.Rec0 a)
                                                                     GHC.Generics.:*: GHC.Generics.S1
                                                                                        ('GHC.Generics.MetaSel
-                                                                                          ('GHC.Base.Just
+                                                                                          ('GHC.Maybe.Just
                                                                                              "d12d")
                                                                                           'GHC.Generics.NoSourceUnpackedness
                                                                                           'GHC.Generics.NoSourceStrictness
@@ -235,14 +235,14 @@ Derived type family instances:
                                                                       'GHC.Types.True)
                                                                    (GHC.Generics.S1
                                                                       ('GHC.Generics.MetaSel
-                                                                         ('GHC.Base.Just "d11c")
+                                                                         ('GHC.Maybe.Just "d11c")
                                                                          'GHC.Generics.NoSourceUnpackedness
                                                                          'GHC.Generics.NoSourceStrictness
                                                                          'GHC.Generics.DecidedLazy)
                                                                       (GHC.Generics.Rec0 a)
                                                                     GHC.Generics.:*: GHC.Generics.S1
                                                                                        ('GHC.Generics.MetaSel
-                                                                                          ('GHC.Base.Just
+                                                                                          ('GHC.Maybe.Just
                                                                                              "d12c")
                                                                                           'GHC.Generics.NoSourceUnpackedness
                                                                                           'GHC.Generics.NoSourceStrictness
@@ -264,14 +264,14 @@ Derived type family instances:
                                                                    'GHC.Types.True)
                                                                 (GHC.Generics.S1
                                                                    ('GHC.Generics.MetaSel
-                                                                      ('GHC.Base.Just "d11b")
+                                                                      ('GHC.Maybe.Just "d11b")
                                                                       'GHC.Generics.NoSourceUnpackedness
                                                                       'GHC.Generics.NoSourceStrictness
                                                                       'GHC.Generics.DecidedLazy)
                                                                    GHC.Generics.Par1
                                                                  GHC.Generics.:*: GHC.Generics.S1
                                                                                     ('GHC.Generics.MetaSel
-                                                                                       ('GHC.Base.Just
+                                                                                       ('GHC.Maybe.Just
                                                                                           "d12b")
                                                                                        'GHC.Generics.NoSourceUnpackedness
                                                                                        'GHC.Generics.NoSourceStrictness
@@ -292,14 +292,14 @@ Derived type family instances:
                                                                       'GHC.Types.True)
                                                                    (GHC.Generics.S1
                                                                       ('GHC.Generics.MetaSel
-                                                                         ('GHC.Base.Just "d11a")
+                                                                         ('GHC.Maybe.Just "d11a")
                                                                          'GHC.Generics.NoSourceUnpackedness
                                                                          'GHC.Generics.NoSourceStrictness
                                                                          'GHC.Generics.DecidedLazy)
                                                                       (GHC.Generics.Rec0 a)
                                                                     GHC.Generics.:*: GHC.Generics.S1
                                                                                        ('GHC.Generics.MetaSel
-                                                                                          ('GHC.Base.Just
+                                                                                          ('GHC.Maybe.Just
                                                                                              "d12a")
                                                                                           'GHC.Generics.NoSourceUnpackedness
                                                                                           'GHC.Generics.NoSourceStrictness
@@ -321,14 +321,14 @@ Derived type family instances:
                                                                    'GHC.Types.True)
                                                                 (GHC.Generics.S1
                                                                    ('GHC.Generics.MetaSel
-                                                                      ('GHC.Base.Just "d11a")
+                                                                      ('GHC.Maybe.Just "d11a")
                                                                       'GHC.Generics.NoSourceUnpackedness
                                                                       'GHC.Generics.NoSourceStrictness
                                                                       'GHC.Generics.DecidedLazy)
                                                                    GHC.Generics.Par1
                                                                  GHC.Generics.:*: GHC.Generics.S1
                                                                                     ('GHC.Generics.MetaSel
-                                                                                       ('GHC.Base.Just
+                                                                                       ('GHC.Maybe.Just
                                                                                           "d12a")
                                                                                        'GHC.Generics.NoSourceUnpackedness
                                                                                        'GHC.Generics.NoSourceStrictness
@@ -349,14 +349,14 @@ Derived type family instances:
                                                                       'GHC.Types.True)
                                                                    (GHC.Generics.S1
                                                                       ('GHC.Generics.MetaSel
-                                                                         ('GHC.Base.Just "d11b")
+                                                                         ('GHC.Maybe.Just "d11b")
                                                                          'GHC.Generics.NoSourceUnpackedness
                                                                          'GHC.Generics.NoSourceStrictness
                                                                          'GHC.Generics.DecidedLazy)
                                                                       (GHC.Generics.Rec0 a)
                                                                     GHC.Generics.:*: GHC.Generics.S1
                                                                                        ('GHC.Generics.MetaSel
-                                                                                          ('GHC.Base.Just
+                                                                                          ('GHC.Maybe.Just
                                                                                              "d12b")
                                                                                           'GHC.Generics.NoSourceUnpackedness
                                                                                           'GHC.Generics.NoSourceStrictness
@@ -378,14 +378,14 @@ Derived type family instances:
                                                                    'GHC.Types.True)
                                                                 (GHC.Generics.S1
                                                                    ('GHC.Generics.MetaSel
-                                                                      ('GHC.Base.Just "d11c")
+                                                                      ('GHC.Maybe.Just "d11c")
                                                                       'GHC.Generics.NoSourceUnpackedness
                                                                       'GHC.Generics.NoSourceStrictness
                                                                       'GHC.Generics.DecidedLazy)
                                                                    GHC.Generics.Par1
                                                                  GHC.Generics.:*: GHC.Generics.S1
                                                                                     ('GHC.Generics.MetaSel
-                                                                                       ('GHC.Base.Just
+                                                                                       ('GHC.Maybe.Just
                                                                                           "d12c")
                                                                                        'GHC.Generics.NoSourceUnpackedness
                                                                                        'GHC.Generics.NoSourceStrictness
index 20417e3..cb9ea36 100644 (file)
@@ -232,7 +232,7 @@ Derived type family instances:
                                                         (GHC.Generics.S1
                                                            *
                                                            ('GHC.Generics.MetaSel
-                                                              ('GHC.Base.Nothing GHC.Types.Symbol)
+                                                              ('GHC.Maybe.Nothing GHC.Types.Symbol)
                                                               'GHC.Generics.NoSourceUnpackedness
                                                               'GHC.Generics.NoSourceStrictness
                                                               'GHC.Generics.DecidedLazy)
@@ -251,7 +251,7 @@ Derived type family instances:
                                               (GHC.Generics.S1
                                                  (* -> *)
                                                  ('GHC.Generics.MetaSel
-                                                    ('GHC.Base.Nothing GHC.Types.Symbol)
+                                                    ('GHC.Maybe.Nothing GHC.Types.Symbol)
                                                     'GHC.Generics.NoSourceUnpackedness
                                                     'GHC.Generics.NoSourceStrictness
                                                     'GHC.Generics.DecidedLazy)
@@ -273,7 +273,7 @@ Derived type family instances:
                                                            (GHC.Generics.S1
                                                               *
                                                               ('GHC.Generics.MetaSel
-                                                                 ('GHC.Base.Nothing
+                                                                 ('GHC.Maybe.Nothing
                                                                     GHC.Types.Symbol)
                                                                  'GHC.Generics.NoSourceUnpackedness
                                                                  'GHC.Generics.NoSourceStrictness
@@ -301,7 +301,7 @@ Derived type family instances:
                                                    (GHC.Generics.S1
                                                       (k -> *)
                                                       ('GHC.Generics.MetaSel
-                                                         ('GHC.Base.Nothing GHC.Types.Symbol)
+                                                         ('GHC.Maybe.Nothing GHC.Types.Symbol)
                                                          'GHC.Generics.NoSourceUnpackedness
                                                          'GHC.Generics.NoSourceStrictness
                                                          'GHC.Generics.DecidedLazy)
@@ -333,7 +333,8 @@ Derived type family instances:
                                                           (GHC.Generics.S1
                                                              *
                                                              ('GHC.Generics.MetaSel
-                                                                ('GHC.Base.Nothing GHC.Types.Symbol)
+                                                                ('GHC.Maybe.Nothing
+                                                                   GHC.Types.Symbol)
                                                                 'GHC.Generics.NoSourceUnpackedness
                                                                 'GHC.Generics.NoSourceStrictness
                                                                 'GHC.Generics.DecidedLazy)
@@ -342,7 +343,8 @@ Derived type family instances:
                                                           (GHC.Generics.S1
                                                              *
                                                              ('GHC.Generics.MetaSel
-                                                                ('GHC.Base.Nothing GHC.Types.Symbol)
+                                                                ('GHC.Maybe.Nothing
+                                                                   GHC.Types.Symbol)
                                                                 'GHC.Generics.NoSourceUnpackedness
                                                                 'GHC.Generics.NoSourceStrictness
                                                                 'GHC.Generics.DecidedLazy)
@@ -359,7 +361,8 @@ Derived type family instances:
                                                           (GHC.Generics.S1
                                                              *
                                                              ('GHC.Generics.MetaSel
-                                                                ('GHC.Base.Nothing GHC.Types.Symbol)
+                                                                ('GHC.Maybe.Nothing
+                                                                   GHC.Types.Symbol)
                                                                 'GHC.Generics.NoSourceUnpackedness
                                                                 'GHC.Generics.NoSourceStrictness
                                                                 'GHC.Generics.DecidedLazy)
@@ -368,7 +371,8 @@ Derived type family instances:
                                                           (GHC.Generics.S1
                                                              *
                                                              ('GHC.Generics.MetaSel
-                                                                ('GHC.Base.Nothing GHC.Types.Symbol)
+                                                                ('GHC.Maybe.Nothing
+                                                                   GHC.Types.Symbol)
                                                                 'GHC.Generics.NoSourceUnpackedness
                                                                 'GHC.Generics.NoSourceStrictness
                                                                 'GHC.Generics.DecidedLazy)
@@ -395,7 +399,8 @@ Derived type family instances:
                                                           (GHC.Generics.S1
                                                              k
                                                              ('GHC.Generics.MetaSel
-                                                                ('GHC.Base.Nothing GHC.Types.Symbol)
+                                                                ('GHC.Maybe.Nothing
+                                                                   GHC.Types.Symbol)
                                                                 'GHC.Generics.NoSourceUnpackedness
                                                                 'GHC.Generics.NoSourceStrictness
                                                                 'GHC.Generics.DecidedLazy)
@@ -404,7 +409,8 @@ Derived type family instances:
                                                           (GHC.Generics.S1
                                                              k
                                                              ('GHC.Generics.MetaSel
-                                                                ('GHC.Base.Nothing GHC.Types.Symbol)
+                                                                ('GHC.Maybe.Nothing
+                                                                   GHC.Types.Symbol)
                                                                 'GHC.Generics.NoSourceUnpackedness
                                                                 'GHC.Generics.NoSourceStrictness
                                                                 'GHC.Generics.DecidedLazy)
@@ -421,7 +427,8 @@ Derived type family instances:
                                                           (GHC.Generics.S1
                                                              k
                                                              ('GHC.Generics.MetaSel
-                                                                ('GHC.Base.Nothing GHC.Types.Symbol)
+                                                                ('GHC.Maybe.Nothing
+                                                                   GHC.Types.Symbol)
                                                                 'GHC.Generics.NoSourceUnpackedness
                                                                 'GHC.Generics.NoSourceStrictness
                                                                 'GHC.Generics.DecidedLazy)
@@ -430,7 +437,8 @@ Derived type family instances:
                                                           (GHC.Generics.S1
                                                              k
                                                              ('GHC.Generics.MetaSel
-                                                                ('GHC.Base.Nothing GHC.Types.Symbol)
+                                                                ('GHC.Maybe.Nothing
+                                                                   GHC.Types.Symbol)
                                                                 'GHC.Generics.NoSourceUnpackedness
                                                                 'GHC.Generics.NoSourceStrictness
                                                                 'GHC.Generics.DecidedLazy)
@@ -454,7 +462,7 @@ Derived type family instances:
                                                               (GHC.Generics.S1
                                                                  *
                                                                  ('GHC.Generics.MetaSel
-                                                                    ('GHC.Base.Nothing
+                                                                    ('GHC.Maybe.Nothing
                                                                        GHC.Types.Symbol)
                                                                     'GHC.Generics.NoSourceUnpackedness
                                                                     'GHC.Generics.NoSourceStrictness
@@ -469,7 +477,7 @@ Derived type family instances:
                                                               (GHC.Generics.S1
                                                                  *
                                                                  ('GHC.Generics.MetaSel
-                                                                    ('GHC.Base.Nothing
+                                                                    ('GHC.Maybe.Nothing
                                                                        GHC.Types.Symbol)
                                                                     'GHC.Generics.NoSourceUnpackedness
                                                                     'GHC.Generics.NoSourceStrictness
@@ -494,7 +502,7 @@ Derived type family instances:
                                                              (GHC.Generics.S1
                                                                 *
                                                                 ('GHC.Generics.MetaSel
-                                                                   ('GHC.Base.Nothing
+                                                                   ('GHC.Maybe.Nothing
                                                                       GHC.Types.Symbol)
                                                                    'GHC.Generics.NoSourceUnpackedness
                                                                    'GHC.Generics.NoSourceStrictness
@@ -509,7 +517,7 @@ Derived type family instances:
                                                              (GHC.Generics.S1
                                                                 *
                                                                 ('GHC.Generics.MetaSel
-                                                                   ('GHC.Base.Nothing
+                                                                   ('GHC.Maybe.Nothing
                                                                       GHC.Types.Symbol)
                                                                    'GHC.Generics.NoSourceUnpackedness
                                                                    'GHC.Generics.NoSourceStrictness
index a9429d9..4622cb5 100644 (file)
@@ -9,7 +9,7 @@
         instance Show Integer -- Defined in ‘GHC.Show’
         instance Show a => Show (Maybe a) -- Defined in ‘GHC.Show’
         ...plus 22 others
-        ...plus 17 instances involving out-of-scope types
+        ...plus 18 instances involving out-of-scope types
         (use -fprint-potential-instances to see them all)
     • In a stmt of an interactive GHCi command: print it
 
@@ -23,6 +23,6 @@
         instance Show Integer -- Defined in ‘GHC.Show’
         instance Show a => Show (Maybe a) -- Defined in ‘GHC.Show’
         ...plus 22 others
-        ...plus 17 instances involving out-of-scope types
+        ...plus 18 instances involving out-of-scope types
         (use -fprint-potential-instances to see them all)
     • In a stmt of an interactive GHCi command: print it
index 70432f5..5815080 100644 (file)
@@ -9,6 +9,6 @@
         instance Show TyCon -- Defined in ‘GHC.Show’
         instance Show Integer -- Defined in ‘GHC.Show’
         ...plus 29 others
-        ...plus 18 instances involving out-of-scope types
+        ...plus 19 instances involving out-of-scope types
         (use -fprint-potential-instances to see them all)
     • In a stmt of an interactive GHCi command: print it
index 18c9cbb..e76727e 100644 (file)
@@ -79,6 +79,7 @@ Defer01.hs:43:10: warning: [-Wdeferred-type-errors (in -Wdefault)]
         instance Num Double -- Defined in ‘GHC.Float’
         instance Num Float -- Defined in ‘GHC.Float’
         ...plus two others
+        ...plus one instance involving out-of-scope types
         (use -fprint-potential-instances to see them all)
     • In the first argument of ‘myOp’, namely ‘23’
       In the expression: myOp 23
index 3f90dd8..de0b094 100644 (file)
@@ -8,5 +8,5 @@
       instance Num Double -- Defined in ‘GHC.Float’
       instance Num Float -- Defined in ‘GHC.Float’
       ...plus two others
-      ...plus six instances involving out-of-scope types
+      ...plus 7 instances involving out-of-scope types
       (use -fprint-potential-instances to see them all)
index c7421b5..75d6c27 100644 (file)
@@ -29,13 +29,13 @@ instance Bounded () -- Defined in ‘GHC.Enum’
 type instance D () () = Bool   -- Defined at T4175.hs:22:10
 type instance D Int () = String        -- Defined at T4175.hs:19:10
 data instance B () = MkB       -- Defined at T4175.hs:13:15
-data Maybe a = Nothing | Just a        -- Defined in ‘GHC.Base’
+data Maybe a = Nothing | Just a        -- Defined in ‘GHC.Maybe’
 instance Applicative Maybe -- Defined in ‘GHC.Base’
-instance Eq a => Eq (Maybe a) -- Defined in ‘GHC.Base’
+instance Eq a => Eq (Maybe a) -- Defined in ‘GHC.Maybe’
 instance Functor Maybe -- Defined in ‘GHC.Base’
 instance Monad Maybe -- Defined in ‘GHC.Base’
 instance Semigroup a => Monoid (Maybe a) -- Defined in ‘GHC.Base’
-instance Ord a => Ord (Maybe a) -- Defined in ‘GHC.Base’
+instance Ord a => Ord (Maybe a) -- Defined in ‘GHC.Maybe’
 instance Semigroup a => Semigroup (Maybe a)
   -- Defined in ‘GHC.Base’
 instance Show a => Show (Maybe a) -- Defined in ‘GHC.Show’
index 44e60d2..d3e3b66 100644 (file)
@@ -11,7 +11,7 @@ T12522a.hs:22:26: error:
         instance Show Integer -- Defined in ‘GHC.Show’
         instance Show a => Show (Maybe a) -- Defined in ‘GHC.Show’
         ...plus 22 others
-        ...plus 11 instances involving out-of-scope types
+        ...plus 12 instances involving out-of-scope types
         (use -fprint-potential-instances to see them all)
     • In the first argument of ‘(++)’, namely ‘show n’
       In the second argument of ‘($)’, namely ‘show n ++ s’
index 34dbe5a..522e703 100644 (file)
@@ -5,3 +5,11 @@ include $(TOP)/mk/test.mk
 T7116:
        $(RM) -f T7116.o T7116.hi
        '$(TEST_HC)' $(TEST_HC_OPTS) -O2 -c -ddump-simpl -dsuppress-uniques T7116.hs
+
+T14170:
+       $(RM) -f T14170.o T14170.hi
+       '$(TEST_HC)' $(TEST_HC_OPTS) -O2 -c -ddump-simpl -dsuppress-uniques T14170.hs
+
+T14465:
+       $(RM) -f T14465.o T14465.hi
+       '$(TEST_HC)' $(TEST_HC_OPTS) -O2 -c -ddump-simpl -dsuppress-uniques T14465.hs
diff --git a/testsuite/tests/numeric/should_compile/T14170.hs b/testsuite/tests/numeric/should_compile/T14170.hs
new file mode 100644 (file)
index 0000000..b7e854d
--- /dev/null
@@ -0,0 +1,12 @@
+{-# LANGUAGE TypeApplications      #-}
+{-# LANGUAGE TypeInType            #-}
+
+module NatVal where
+
+import Data.Proxy
+import GHC.TypeLits
+
+-- test that Nat type literals are statically converted into Integer literals
+
+foo :: Integer
+foo = natVal $ Proxy @0
diff --git a/testsuite/tests/numeric/should_compile/T14170.stdout b/testsuite/tests/numeric/should_compile/T14170.stdout
new file mode 100644 (file)
index 0000000..46a8621
--- /dev/null
@@ -0,0 +1,59 @@
+
+==================== Tidy Core ====================
+Result size of Tidy Core
+  = {terms: 16, types: 6, coercions: 0, joins: 0/0}
+
+-- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0}
+NatVal.$trModule4 :: GHC.Prim.Addr#
+[GblId,
+ Caf=NoCafRefs,
+ Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
+         WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 20 0}]
+NatVal.$trModule4 = "main"#
+
+-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0}
+NatVal.$trModule3 :: GHC.Types.TrName
+[GblId,
+ Caf=NoCafRefs,
+ Str=m1,
+ Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
+         WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 20}]
+NatVal.$trModule3 = GHC.Types.TrNameS NatVal.$trModule4
+
+-- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0}
+NatVal.$trModule2 :: GHC.Prim.Addr#
+[GblId,
+ Caf=NoCafRefs,
+ Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
+         WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 30 0}]
+NatVal.$trModule2 = "NatVal"#
+
+-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0}
+NatVal.$trModule1 :: GHC.Types.TrName
+[GblId,
+ Caf=NoCafRefs,
+ Str=m1,
+ Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
+         WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 20}]
+NatVal.$trModule1 = GHC.Types.TrNameS NatVal.$trModule2
+
+-- RHS size: {terms: 3, types: 0, coercions: 0, joins: 0/0}
+NatVal.$trModule :: GHC.Types.Module
+[GblId,
+ Caf=NoCafRefs,
+ Str=m,
+ Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
+         WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 30}]
+NatVal.$trModule
+  = GHC.Types.Module NatVal.$trModule3 NatVal.$trModule1
+
+-- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0}
+foo :: Integer
+[GblId,
+ Caf=NoCafRefs,
+ Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
+         WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 100 0}]
+foo = 0
+
+
+
diff --git a/testsuite/tests/numeric/should_compile/T14465.hs b/testsuite/tests/numeric/should_compile/T14465.hs
new file mode 100644 (file)
index 0000000..314aa89
--- /dev/null
@@ -0,0 +1,26 @@
+{-# LANGUAGE TypeApplications      #-}
+{-# LANGUAGE TypeInType            #-}
+
+module M where
+
+import Numeric.Natural
+import GHC.Natural
+
+-- test Natural literals
+one :: Natural
+one = fromInteger 1
+
+plusOne :: Natural -> Natural
+plusOne n = n + 1
+
+-- a built-in rule should convert this unfolding into a Natural literal in Core
+ten :: Natural
+ten = wordToNatural 10
+
+-- test basic constant folding for Natural
+twoTimesTwo :: Natural
+twoTimesTwo = 2 * 2
+
+-- test the overflow warning
+minusOne :: Natural
+minusOne = -1
diff --git a/testsuite/tests/numeric/should_compile/T14465.stderr b/testsuite/tests/numeric/should_compile/T14465.stderr
new file mode 100644 (file)
index 0000000..c21e4a0
--- /dev/null
@@ -0,0 +1,3 @@
+
+T14465.hs:26:13: warning: [-Woverflowed-literals (in -Wdefault)]
+    Literal -1 is negative but Natural only supports positive numbers
diff --git a/testsuite/tests/numeric/should_compile/T14465.stdout b/testsuite/tests/numeric/should_compile/T14465.stdout
new file mode 100644 (file)
index 0000000..32cf356
--- /dev/null
@@ -0,0 +1,104 @@
+
+==================== Tidy Core ====================
+Result size of Tidy Core
+  = {terms: 34, types: 14, coercions: 0, joins: 0/0}
+
+-- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0}
+ten :: Natural
+[GblId,
+ Caf=NoCafRefs,
+ Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
+         WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 100 0}]
+ten = 10
+
+-- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0}
+M.$trModule4 :: GHC.Prim.Addr#
+[GblId,
+ Caf=NoCafRefs,
+ Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
+         WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 20 0}]
+M.$trModule4 = "main"#
+
+-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0}
+M.$trModule3 :: GHC.Types.TrName
+[GblId,
+ Caf=NoCafRefs,
+ Str=m1,
+ Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
+         WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 20}]
+M.$trModule3 = GHC.Types.TrNameS M.$trModule4
+
+-- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0}
+M.$trModule2 :: GHC.Prim.Addr#
+[GblId,
+ Caf=NoCafRefs,
+ Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
+         WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 20 0}]
+M.$trModule2 = "M"#
+
+-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0}
+M.$trModule1 :: GHC.Types.TrName
+[GblId,
+ Caf=NoCafRefs,
+ Str=m1,
+ Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
+         WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 20}]
+M.$trModule1 = GHC.Types.TrNameS M.$trModule2
+
+-- RHS size: {terms: 3, types: 0, coercions: 0, joins: 0/0}
+M.$trModule :: GHC.Types.Module
+[GblId,
+ Caf=NoCafRefs,
+ Str=m,
+ Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
+         WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 30}]
+M.$trModule = GHC.Types.Module M.$trModule3 M.$trModule1
+
+-- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0}
+M.minusOne1 :: Natural
+[GblId,
+ Caf=NoCafRefs,
+ Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
+         WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 100 0}]
+M.minusOne1 = 1
+
+-- RHS size: {terms: 6, types: 1, coercions: 0, joins: 0/0}
+minusOne :: Natural
+[GblId,
+ Unf=Unf{Src=<vanilla>, TopLvl=True, Value=False, ConLike=False,
+         WorkFree=False, Expandable=False, Guidance=IF_ARGS [] 40 20}]
+minusOne
+  = case GHC.Natural.$wnegateNatural M.minusOne1 of ww { __DEFAULT ->
+    GHC.Natural.NatS# ww
+    }
+
+-- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0}
+twoTimesTwo :: Natural
+[GblId,
+ Caf=NoCafRefs,
+ Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
+         WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 100 0}]
+twoTimesTwo = 4
+
+-- RHS size: {terms: 4, types: 1, coercions: 0, joins: 0/0}
+plusOne :: Natural -> Natural
+[GblId,
+ Arity=1,
+ Caf=NoCafRefs,
+ Str=<S,U>,
+ Unf=Unf{Src=InlineStable, TopLvl=True, Value=True, ConLike=True,
+         WorkFree=True, Expandable=True,
+         Guidance=ALWAYS_IF(arity=1,unsat_ok=True,boring_ok=False)
+         Tmpl= \ (n [Occ=Once] :: Natural) -> plusNatural n M.minusOne1}]
+plusOne = \ (n :: Natural) -> plusNatural n M.minusOne1
+
+-- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0}
+one :: Natural
+[GblId,
+ Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
+         WorkFree=True, Expandable=True,
+         Guidance=ALWAYS_IF(arity=0,unsat_ok=True,boring_ok=True)}]
+one = M.minusOne1
+
+
+
index e7bc4c6..5011627 100644 (file)
@@ -1,4 +1,6 @@
 test('T7116', normal, run_command, ['$MAKE -s --no-print-directory T7116'])
+test('T14170', normal, run_command, ['$MAKE -s --no-print-directory T14170'])
+test('T14465', normal, run_command, ['$MAKE -s --no-print-directory T14465'])
 test('T7895', normal, compile, [''])
 test('T7881', normal, compile, [''])
 # For T8542, the hpc way adds extra annotations that prevent
index 5ece21f..c0d371f 100644 (file)
@@ -8,7 +8,7 @@ overloadedlistsfail01.hs:5:8: error:
         instance Show Integer -- Defined in ‘GHC.Show’
         instance Show a => Show (Maybe a) -- Defined in ‘GHC.Show’
         ...plus 22 others
-        ...plus 12 instances involving out-of-scope types
+        ...plus 13 instances involving out-of-scope types
         (use -fprint-potential-instances to see them all)
     • In the expression: print [1]
       In an equation for ‘main’: main = print [1]
@@ -35,6 +35,7 @@ overloadedlistsfail01.hs:5:15: error:
         instance Num Double -- Defined in ‘GHC.Float’
         instance Num Float -- Defined in ‘GHC.Float’
         ...plus two others
+        ...plus one instance involving out-of-scope types
         (use -fprint-potential-instances to see them all)
     • In the expression: 1
       In the first argument of ‘print’, namely ‘[1]’
index 88652a7..5da9692 100644 (file)
@@ -25,7 +25,7 @@ T10999.hs:8:28: error:
         instance Ord Ordering -- Defined in ‘GHC.Classes’
         instance Ord Integer
           -- Defined in ‘integer-gmp-1.0.1.0:GHC.Integer.Type’
-        ...plus 23 others
+        ...plus 22 others
         ...plus three instances involving out-of-scope types
         (use -fprint-potential-instances to see them all)
     • In the second argument of ‘($)’, namely ‘f ()’
index efb740b..5e212f3 100644 (file)
@@ -5,4 +5,5 @@ interfacePlugin: GHC.Base
 interfacePlugin: GHC.Types
 typeCheckPlugin (rn)
 typeCheckPlugin (tc)
-interfacePlugin: GHC.Integer.Type
\ No newline at end of file
+interfacePlugin: GHC.Integer.Type
+interfacePlugin: GHC.Natural
index 1e63042..ff31aa3 100644 (file)
@@ -5,4 +5,5 @@ interfacePlugin: GHC.Base
 interfacePlugin: GHC.Types
 typeCheckPlugin (rn)
 typeCheckPlugin (tc)
-interfacePlugin: GHC.Integer.Type
\ No newline at end of file
+interfacePlugin: GHC.Integer.Type
+interfacePlugin: GHC.Natural
index 65dd9a1..9d4869d 100644 (file)
@@ -167,7 +167,7 @@ Roman.foo1 :: Maybe Int
  Str=m2,
  Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
          WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 20}]
-Roman.foo1 = GHC.Base.Just @ Int Roman.foo2
+Roman.foo1 = GHC.Maybe.Just @ Int Roman.foo2
 
 -- RHS size: {terms: 11, types: 4, coercions: 0, joins: 0/0}
 foo :: Int -> Int
@@ -180,7 +180,7 @@ foo :: Int -> Int
          Guidance=ALWAYS_IF(arity=1,unsat_ok=True,boring_ok=False)
          Tmpl= \ (n [Occ=Once!] :: Int) ->
                  case n of n1 [Occ=Once] { GHC.Types.I# _ [Occ=Dead] ->
-                 Roman.foo_go (GHC.Base.Just @ Int n1) Roman.foo1
+                 Roman.foo_go (GHC.Maybe.Just @ Int n1) Roman.foo1
                  }}]
 foo
   = \ (n :: Int) ->
@@ -192,8 +192,8 @@ foo
 ------ Local rules for imported ids --------
 "SC:$wgo0" [2]
     forall (sc :: GHC.Prim.Int#) (sc1 :: GHC.Prim.Int#).
-      Roman.$wgo (GHC.Base.Just @ Int (GHC.Types.I# sc1))
-                 (GHC.Base.Just @ Int (GHC.Types.I# sc))
+      Roman.$wgo (GHC.Maybe.Just @ Int (GHC.Types.I# sc1))
+                 (GHC.Maybe.Just @ Int (GHC.Types.I# sc))
       = Roman.foo_$s$wgo sc sc1
 
 
index 8855da2..8db3754 100644 (file)
@@ -1,6 +1,6 @@
 
-ClosedFam1TH.hs:7:3: Warning:
+ClosedFam1TH.hs:7:3: warning:
     type family Foo_0 a_1 (b_2 :: k_3) where
     Foo_0 GHC.Types.Int GHC.Types.Bool = GHC.Types.Int
-    Foo_0 a_4 GHC.Base.Maybe = GHC.Types.Bool
+    Foo_0 a_4 GHC.Maybe.Maybe = GHC.Types.Bool
     Foo_0 b_5 (x_6 :: GHC.Types.Bool) = GHC.Types.Char
index c7668cf..01857c3 100644 (file)
@@ -3,8 +3,8 @@ newtype Main.Foo1
                                       ('(:) 'GHC.Types.True
                                             ('(:) 'GHC.Types.False ('[] :: [GHC.Types.Bool])))))
 newtype Main.Foo2 (a_0 :: *)
-  = Main.Foo2 (Data.Proxy.Proxy (Main.Wurble (GHC.Base.Maybe a_0)
-                                             ('GHC.Base.Nothing :: GHC.Base.Maybe a_0)))
+  = Main.Foo2 (Data.Proxy.Proxy (Main.Wurble (GHC.Maybe.Maybe a_0)
+                                             ('GHC.Maybe.Nothing :: GHC.Maybe.Maybe a_0)))
 newtype Main.Foo3
   = Main.Foo3 (Data.Proxy.Proxy (Main.Foo3Fam2 GHC.Types.Int :: *))
 newtype Main.Foo4
index c666082..3a4c608 100644 (file)
@@ -1,2 +1,2 @@
-instance Bug.C (GHC.Base.Maybe a_0)
-    where type Bug.T (GHC.Base.Maybe a_0) = GHC.Types.Char
+instance Bug.C (GHC.Maybe.Maybe a_0)
+    where type Bug.T (GHC.Maybe.Maybe a_0) = GHC.Types.Char
index 944cfa5..67d7e2e 100644 (file)
@@ -1,3 +1,3 @@
-f_0 :: GHC.Base.Maybe GHC.Types.Int -> GHC.Types.Int
-f_0 (GHC.Base.Nothing) = 3
-f_0 (GHC.Base.Just x_1) = x
+f_0 :: GHC.Maybe.Maybe GHC.Types.Int -> GHC.Types.Int
+f_0 (GHC.Maybe.Nothing) = 3
+f_0 (GHC.Maybe.Just x_1) = x
index c724a8e..3dad412 100644 (file)
@@ -1,6 +1,6 @@
 type family T8953.Poly (a_0 :: k_1) :: *
 type instance T8953.Poly (x_2 :: GHC.Types.Bool) = GHC.Types.Int
-type instance T8953.Poly (x_3 :: GHC.Base.Maybe k_4) = GHC.Types.Double
+type instance T8953.Poly (x_3 :: GHC.Maybe.Maybe k_4) = GHC.Types.Double
 type family T8953.Silly :: k_0 -> *
 type instance T8953.Silly = (Data.Proxy.Proxy :: * -> *)
 type instance T8953.Silly = (Data.Proxy.Proxy :: (* -> *) -> *)
index 8970da8..a0b29a1 100644 (file)
@@ -1,8 +1,8 @@
 
 TH_RichKinds2.hs:25:4: warning:
-    data SMaybe_0 :: (k_0 -> *) -> GHC.Base.Maybe k_0 -> * where
-    SNothing_2 :: SMaybe_0 s_3 'GHC.Base.Nothing
-    SJust_4 :: (s_5 a_6) -> SMaybe_0 s_5 ('GHC.Base.Just a_6)
+    data SMaybe_0 :: (k_0 -> *) -> GHC.Maybe.Maybe k_0 -> * where
+    SNothing_2 :: SMaybe_0 s_3 'GHC.Maybe.Nothing
+    SJust_4 :: (s_5 a_6) -> SMaybe_0 s_5 ('GHC.Maybe.Just a_6)
 type instance TH_RichKinds2.Map f_7 '[] = '[]
 type instance TH_RichKinds2.Map f_8
                                 ('(GHC.Types.:) h_9 t_10) = '(GHC.Types.:) (f_8 h_9)
index 64436f8..2e7650b 100644 (file)
@@ -1,2 +1,2 @@
-data GHC.Base.Maybe (a_0 :: *)
-    = GHC.Base.Nothing | GHC.Base.Just a_0
+data GHC.Maybe.Maybe (a_0 :: *)
+    = GHC.Maybe.Nothing | GHC.Maybe.Just a_0
index bbef7ee..ce93ab9 100644 (file)
@@ -1,7 +1,7 @@
 foo_0 :: GHC.Types.Int -> GHC.Types.Int
 foo_0 x_1 | x_1 GHC.Classes.== 5 = 6
 foo_0 x_2 = 7
-bar_0 :: GHC.Base.Maybe GHC.Types.Int -> GHC.Types.Int
-bar_0 x_1 | GHC.Base.Just y_2 <- x_1
+bar_0 :: GHC.Maybe.Maybe GHC.Types.Int -> GHC.Types.Int
+bar_0 x_1 | GHC.Maybe.Just y_2 <- x_1
               = y_2
 bar_0 _ = 9
index f307c77..ca739a3 100644 (file)
@@ -12,7 +12,7 @@ T14273.hs:7:27: warning: [-Wdeferred-type-errors (in -Wdefault)]
         instance Show Ordering -- Defined in ‘GHC.Show’
         instance Show Integer -- Defined in ‘GHC.Show’
         ...plus 23 others
-        ...plus 68 instances involving out-of-scope types
+        ...plus 69 instances involving out-of-scope types
         (use -fprint-potential-instances to see them all)
     • In the first argument of ‘Just’, namely ‘(show _a)’
       In the expression: Just (show _a)
@@ -65,7 +65,7 @@ T14273.hs:13:10: warning: [-Wdeferred-type-errors (in -Wdefault)]
         instance Show Ordering -- Defined in ‘GHC.Show’
         instance Show Integer -- Defined in ‘GHC.Show’
         ...plus 23 others
-        ...plus 68 instances involving out-of-scope types
+        ...plus 69 instances involving out-of-scope types
         (use -fprint-potential-instances to see them all)
     • In the expression: show (_h ++ [])
       In an equation for ‘foo’: foo xs = show (_h ++ [])
index 6421709..329e939 100644 (file)
@@ -9,7 +9,7 @@ holes2.hs:3:5: warning: [-Wdeferred-type-errors (in -Wdefault)]
         instance Show Ordering -- Defined in ‘GHC.Show’
         instance Show Integer -- Defined in ‘GHC.Show’
         ...plus 23 others
-        ...plus 68 instances involving out-of-scope types
+        ...plus 69 instances involving out-of-scope types
         (use -fprint-potential-instances to see them all)
     • In the expression: show _
       In an equation for ‘f’: f = show _
index 6ddc274..17c487f 100644 (file)
@@ -78,7 +78,7 @@ valid_hole_fits.hs:27:5: warning: [-Wtyped-holes (in -Wdefault)]
         Just :: forall a. a -> Maybe a
           with Just @Integer
           (imported from ‘Data.Maybe’ at valid_hole_fits.hs:5:1-17
-           (and originally defined in ‘GHC.Base’))
+           (and originally defined in ‘GHC.Maybe’))
         return :: forall (m :: * -> *) a. Monad m => a -> m a
           with return @Maybe @Integer
           (imported from ‘Prelude’ at valid_hole_fits.hs:3:1-40
@@ -98,7 +98,7 @@ valid_hole_fits.hs:30:5: warning: [-Wdeferred-type-errors (in -Wdefault)]
         instance Show Ordering -- Defined in ‘GHC.Show’
         instance Show Integer -- Defined in ‘GHC.Show’
         ...plus 23 others
-        ...plus 68 instances involving out-of-scope types
+        ...plus 69 instances involving out-of-scope types
         (use -fprint-potential-instances to see them all)
     • In the expression: show _
       In an equation for ‘f’: f = show _
@@ -148,7 +148,7 @@ valid_hole_fits.hs:34:5: warning: [-Wdeferred-type-errors (in -Wdefault)]
         instance Show Ordering -- Defined in ‘GHC.Show’
         instance Show Integer -- Defined in ‘GHC.Show’
         ...plus 23 others
-        ...plus 68 instances involving out-of-scope types
+        ...plus 69 instances involving out-of-scope types
         (use -fprint-potential-instances to see them all)
     • In the expression: show (_ (_ :: Bool))
       In an equation for ‘h’: h = show (_ (_ :: Bool))
@@ -172,7 +172,7 @@ valid_hole_fits.hs:34:11: warning: [-Wtyped-holes (in -Wdefault)]
         Just :: forall a. a -> Maybe a
           with Just @Bool
           (imported from ‘Data.Maybe’ at valid_hole_fits.hs:5:1-17
-           (and originally defined in ‘GHC.Base’))
+           (and originally defined in ‘GHC.Maybe’))
         id :: forall a. a -> a
           with id @Bool
           (imported from ‘Prelude’ at valid_hole_fits.hs:3:1-40
index 8adae18..89ddef9 100644 (file)
@@ -42,7 +42,7 @@ T14884.hs:4:7: error:
         instance Show Ordering -- Defined in ‘GHC.Show’
         instance Show Integer -- Defined in ‘GHC.Show’
         ...plus 23 others
-        ...plus 65 instances involving out-of-scope types
+        ...plus 66 instances involving out-of-scope types
         (use -fprint-potential-instances to see them all)
     • In the first argument of ‘_’, namely ‘print’
       In the expression: _ print "abc"
index accc6b6..ace7e91 100644 (file)
@@ -7,7 +7,7 @@ T5095.hs:9:9: error:
         instance Eq Integer
           -- Defined in ‘integer-gmp-1.0.1.0:GHC.Integer.Type’
         ...plus 23 others
-        ...plus six instances involving out-of-scope types
+        ...plus 7 instances involving out-of-scope types
         (use -fprint-potential-instances to see them all)
       (The choice depends on the instantiation of ‘a’
        To pick the first instance above, use IncoherentInstances
index d84c3b9..1e7bc19 100644 (file)
@@ -1,21 +1,22 @@
 
 tcfail008.hs:3:5: error:
-    Ambiguous type variable ‘a0’ arising from the literal ‘1’
-    prevents the constraint ‘(Num a0)’ from being solved.
-    Relevant bindings include o :: [a0] (bound at tcfail008.hs:3:1)
-    Probable fix: use a type annotation to specify what ‘a0’ should be.
-    These potential instances exist:
-      instance Num Integer -- Defined in ‘GHC.Num’
-      instance Num Double -- Defined in ‘GHC.Float’
-      instance Num Float -- Defined in ‘GHC.Float’
-      ...plus two others
-      (use -fprint-potential-instances to see them all)
-    In the first argument of ‘(:)’, namely ‘1’
-    In the expression: 1 : 2
-    In an equation for ‘o’: o = 1 : 2
+    • Ambiguous type variable ‘a0’ arising from the literal ‘1’
+      prevents the constraint ‘(Num a0)’ from being solved.
+      Relevant bindings include o :: [a0] (bound at tcfail008.hs:3:1)
+      Probable fix: use a type annotation to specify what ‘a0’ should be.
+      These potential instances exist:
+        instance Num Integer -- Defined in ‘GHC.Num’
+        instance Num Double -- Defined in ‘GHC.Float’
+        instance Num Float -- Defined in ‘GHC.Float’
+        ...plus two others
+        ...plus one instance involving out-of-scope types
+        (use -fprint-potential-instances to see them all)
+    • In the first argument of ‘(:)’, namely ‘1’
+      In the expression: 1 : 2
+      In an equation for ‘o’: o = 1 : 2
 
 tcfail008.hs:3:7: error:
-    No instance for (Num [a0]) arising from the literal ‘2’
-    In the second argument of ‘(:)’, namely ‘2’
-    In the expression: 1 : 2
-    In an equation for ‘o’: o = 1 : 2
+    • No instance for (Num [a0]) arising from the literal ‘2’
+    • In the second argument of ‘(:)’, namely ‘2’
+      In the expression: 1 : 2
+      In an equation for ‘o’: o = 1 : 2
index 89f1e83..c3fdb25 100644 (file)
@@ -10,8 +10,8 @@ tcfail072.hs:23:13: error:
         instance Ord Ordering -- Defined in ‘GHC.Classes’
         instance Ord Integer
           -- Defined in ‘integer-gmp-1.0.1.0:GHC.Integer.Type’
-        instance Ord a => Ord (Maybe a) -- Defined in ‘GHC.Base
-        ...plus 22 others
+        instance Ord () -- Defined in ‘GHC.Classes
+        ...plus 21 others
         ...plus three instances involving out-of-scope types
         (use -fprint-potential-instances to see them all)
     • In the expression: g A
index 80e5ea7..bbaf091 100644 (file)
@@ -12,7 +12,7 @@ tcfail133.hs:68:7: error:
         instance (Number a, Digit b, Show a, Show b) => Show (a :@ b)
           -- Defined at tcfail133.hs:11:54
         ...plus 25 others
-        ...plus 11 instances involving out-of-scope types
+        ...plus 12 instances involving out-of-scope types
         (use -fprint-potential-instances to see them all)
     • In the expression: show $ add (One :@ Zero) (One :@ One)
       In an equation for ‘foo’:
index 8d621da..35e2e2d 100644 (file)
@@ -3,7 +3,8 @@ tcfail182.hs:9:3: error:
     • Couldn't match expected type ‘Prelude.Maybe a’
                   with actual type ‘Maybe a0’
       NB: ‘Maybe’ is defined at tcfail182.hs:6:1-18
-          ‘Prelude.Maybe’ is defined in ‘GHC.Base’ in package ‘base-4.12.0.0’
+          ‘Prelude.Maybe’
+            is defined in ‘GHC.Maybe’ in package ‘base-4.12.0.0’
     • In the pattern: Foo
       In an equation for ‘f’: f Foo = 3
     • Relevant bindings include