{-# LANGUAGE Trustworthy #-}
{-# LANGUAGE CPP, NoImplicitPrelude, StandaloneDeriving, ScopedTypeVariables #-}
{-# OPTIONS_HADDOCK not-home #-}

-----------------------------------------------------------------------------
-- |
-- Module      :  GHC.Read
-- Copyright   :  (c) The University of Glasgow, 1994-2002
-- License     :  see libraries/base/LICENSE
--
-- Maintainer  :  cvs-ghc@haskell.org
-- Stability   :  internal
-- Portability :  non-portable (GHC Extensions)
--
-- The 'Read' class and instances for basic data types.
--
-----------------------------------------------------------------------------

module GHC.Read
  ( Read(..)   -- class

  -- ReadS type
  , ReadS

  -- H2010 compatibility
  , lex
  , lexLitChar
  , readLitChar
  , lexDigits

  -- defining readers
  , lexP, expectP
  , paren
  , parens
  , list
  , choose
  , readListDefault, readListPrecDefault
  , readNumber
  , readField
  , readFieldHash
  , readSymField

  -- Temporary
  , readParen
  )
 where

#include "MachDeps.h"

import qualified Text.ParserCombinators.ReadP as P

import Text.ParserCombinators.ReadP
  ( ReadS
  , readP_to_S
  )

import qualified Text.Read.Lex as L
-- Lex exports 'lex', which is also defined here,
-- hence the qualified import.
-- We can't import *anything* unqualified, because that
-- confuses Haddock.

import Text.ParserCombinators.ReadPrec

import Data.Maybe

import GHC.Unicode
import GHC.Num
import GHC.Real
import GHC.Float
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
-- parentheses.
--
-- @'readParen' 'False' p@ parses what @p@ parses, but optionally
-- surrounded with parentheses.
readParen       :: Bool -> ReadS a -> ReadS a
-- A Haskell 2010 function
readParen b g   =  if b then mandatory else optional
                   where optional r  = g r ++ mandatory r
                         mandatory r = do
                                ("(",s) <- lex r
                                (x,t)   <- optional s
                                (")",u) <- lex t
                                return (x,u)

-- | Parsing of 'String's, producing values.
--
-- Derived instances of 'Read' make the following assumptions, which
-- derived instances of 'Text.Show.Show' obey:
--
-- * If the constructor is defined to be an infix operator, then the
--   derived 'Read' instance will parse only infix applications of
--   the constructor (not the prefix form).
--
-- * Associativity is not used to reduce the occurrence of parentheses,
--   although precedence may be.
--
-- * If the constructor is defined using record syntax, the derived 'Read'
--   will parse only the record-syntax form, and furthermore, the fields
--   must be given in the same order as the original declaration.
--
-- * The derived 'Read' instance allows arbitrary Haskell whitespace
--   between tokens of the input string.  Extra parentheses are also
--   allowed.
--
-- For example, given the declarations
--
-- > infixr 5 :^:
-- > data Tree a =  Leaf a  |  Tree a :^: Tree a
--
-- the derived instance of 'Read' in Haskell 2010 is equivalent to
--
-- > instance (Read a) => Read (Tree a) where
-- >
-- >         readsPrec d r =  readParen (d > app_prec)
-- >                          (\r -> [(Leaf m,t) |
-- >                                  ("Leaf",s) <- lex r,
-- >                                  (m,t) <- readsPrec (app_prec+1) s]) r
-- >
-- >                       ++ readParen (d > up_prec)
-- >                          (\r -> [(u:^:v,w) |
-- >                                  (u,s) <- readsPrec (up_prec+1) r,
-- >                                  (":^:",t) <- lex s,
-- >                                  (v,w) <- readsPrec (up_prec+1) t]) r
-- >
-- >           where app_prec = 10
-- >                 up_prec = 5
--
-- Note that right-associativity of @:^:@ is unused.
--
-- The derived instance in GHC is equivalent to
--
-- > instance (Read a) => Read (Tree a) where
-- >
-- >         readPrec = parens $ (prec app_prec $ do
-- >                                  Ident "Leaf" <- lexP
-- >                                  m <- step readPrec
-- >                                  return (Leaf m))
-- >
-- >                      +++ (prec up_prec $ do
-- >                                  u <- step readPrec
-- >                                  Symbol ":^:" <- lexP
-- >                                  v <- step readPrec
-- >                                  return (u :^: v))
-- >
-- >           where app_prec = 10
-- >                 up_prec = 5
-- >
-- >         readListPrec = readListPrecDefault
--
-- Why do both 'readsPrec' and 'readPrec' exist, and why does GHC opt to
-- implement 'readPrec' in derived 'Read' instances instead of 'readsPrec'?
-- The reason is that 'readsPrec' is based on the 'ReadS' type, and although
-- 'ReadS' is mentioned in the Haskell 2010 Report, it is not a very efficient
-- parser data structure.
--
-- 'readPrec', on the other hand, is based on a much more efficient 'ReadPrec'
-- datatype (a.k.a \"new-style parsers\"), but its definition relies on the use
-- of the @RankNTypes@ language extension. Therefore, 'readPrec' (and its
-- cousin, 'readListPrec') are marked as GHC-only. Nevertheless, it is
-- recommended to use 'readPrec' instead of 'readsPrec' whenever possible
-- for the efficiency improvements it brings.
--
-- As mentioned above, derived 'Read' instances in GHC will implement
-- 'readPrec' instead of 'readsPrec'. The default implementations of
-- 'readsPrec' (and its cousin, 'readList') will simply use 'readPrec' under
-- the hood. If you are writing a 'Read' instance by hand, it is recommended
-- to write it like so:
--
-- @
-- instance 'Read' T where
--   'readPrec'     = ...
--   'readListPrec' = 'readListPrecDefault'
-- @

class Read a where
  {-# MINIMAL readsPrec | readPrec #-}

  -- | attempts to parse a value from the front of the string, returning
  -- a list of (parsed value, remaining string) pairs.  If there is no
  -- successful parse, the returned list is empty.
  --
  -- Derived instances of 'Read' and 'Text.Show.Show' satisfy the following:
  --
  -- * @(x,\"\")@ is an element of
  --   @('readsPrec' d ('Text.Show.showsPrec' d x \"\"))@.
  --
  -- That is, 'readsPrec' parses the string produced by
  -- 'Text.Show.showsPrec', and delivers the value that
  -- 'Text.Show.showsPrec' started with.

  readsPrec    :: Int   -- ^ the operator precedence of the enclosing
                        -- context (a number from @0@ to @11@).
                        -- Function application has precedence @10@.
                -> ReadS a

  -- | The method 'readList' is provided to allow the programmer to
  -- give a specialised way of parsing lists of values.
  -- For example, this is used by the predefined 'Read' instance of
  -- the 'Char' type, where values of type 'String' should be are
  -- expected to use double quotes, rather than square brackets.
  readList     :: ReadS [a]

  -- | Proposed replacement for 'readsPrec' using new-style parsers (GHC only).
  readPrec     :: ReadPrec a

  -- | Proposed replacement for 'readList' using new-style parsers (GHC only).
  -- The default definition uses 'readList'.  Instances that define 'readPrec'
  -- should also define 'readListPrec' as 'readListPrecDefault'.
  readListPrec :: ReadPrec [a]

  -- default definitions
  readsPrec    = readPrec_to_S readPrec
  readList     = readPrec_to_S (list readPrec) 0
  readPrec     = readS_to_Prec readsPrec
  readListPrec = readS_to_Prec (\_ -> readList)

readListDefault :: Read a => ReadS [a]
-- ^ A possible replacement definition for the 'readList' method (GHC only).
--   This is only needed for GHC, and even then only for 'Read' instances
--   where 'readListPrec' isn't defined as 'readListPrecDefault'.
readListDefault = readPrec_to_S readListPrec 0

readListPrecDefault :: Read a => ReadPrec [a]
-- ^ A possible replacement definition for the 'readListPrec' method,
--   defined using 'readPrec' (GHC only).
readListPrecDefault = list readPrec

------------------------------------------------------------------------
-- H2010 compatibility

-- | The 'lex' function reads a single lexeme from the input, discarding
-- initial white space, and returning the characters that constitute the
-- lexeme.  If the input string contains only white space, 'lex' returns a
-- single successful \`lexeme\' consisting of the empty string.  (Thus
-- @'lex' \"\" = [(\"\",\"\")]@.)  If there is no legal lexeme at the
-- beginning of the input string, 'lex' fails (i.e. returns @[]@).
--
-- This lexer is not completely faithful to the Haskell lexical syntax
-- in the following respects:
--
-- * Qualified names are not handled properly
--
-- * Octal and hexadecimal numerics are not recognized as a single token
--
-- * Comments are not treated properly
lex :: ReadS String             -- As defined by H2010
lex s  = readP_to_S L.hsLex s

-- | Read a string representation of a character, using Haskell
-- source-language escape conventions.  For example:
--
-- > lexLitChar  "\\nHello"  =  [("\\n", "Hello")]
--
lexLitChar :: ReadS String      -- As defined by H2010
lexLitChar = readP_to_S (do { (s, _) <- P.gather L.lexChar ;
                              let s' = removeNulls s in
                              return s' })
    where
    -- remove nulls from end of the character if they exist
    removeNulls [] = []
    removeNulls ('\\':'&':xs) = removeNulls xs
    removeNulls (first:rest) = first : removeNulls rest
        -- There was a skipSpaces before the P.gather L.lexChar,
        -- but that seems inconsistent with readLitChar

-- | Read a string representation of a character, using Haskell
-- source-language escape conventions, and convert it to the character
-- that it encodes.  For example:
--
-- > readLitChar "\\nHello"  =  [('\n', "Hello")]
--
readLitChar :: ReadS Char       -- As defined by H2010
readLitChar = readP_to_S L.lexChar

-- | Reads a non-empty string of decimal digits.
lexDigits :: ReadS String
lexDigits = readP_to_S (P.munch1 isDigit)

------------------------------------------------------------------------
-- utility parsers

lexP :: ReadPrec L.Lexeme
-- ^ Parse a single lexeme
lexP = lift L.lex

expectP :: L.Lexeme -> ReadPrec ()
expectP lexeme = lift (L.expect lexeme)

expectCharP :: Char -> ReadPrec a -> ReadPrec a
expectCharP c a = do
  q <- get
  if q == c
    then a
    else pfail
{-# INLINE expectCharP #-}

skipSpacesThenP :: ReadPrec a -> ReadPrec a
skipSpacesThenP m =
  do s <- look
     skip s
 where
   skip (c:s) | isSpace c = get *> skip s
   skip _ = m

paren :: ReadPrec a -> ReadPrec a
-- ^ @(paren p)@ parses \"(P0)\"
--      where @p@ parses \"P0\" in precedence context zero
paren p = skipSpacesThenP (paren' p)

paren' :: ReadPrec a -> ReadPrec a
paren' p = expectCharP '(' $ reset p >>= \x ->
              skipSpacesThenP (expectCharP ')' (pure x))

parens :: ReadPrec a -> ReadPrec a
-- ^ @(parens p)@ parses \"P\", \"(P0)\", \"((P0))\", etc,
--      where @p@ parses \"P\"  in the current precedence context
--          and parses \"P0\" in precedence context zero
parens p = optional
  where
    optional = skipSpacesThenP (p +++ mandatory)
    mandatory = paren' optional

list :: ReadPrec a -> ReadPrec [a]
-- ^ @(list p)@ parses a list of things parsed by @p@,
-- using the usual square-bracket syntax.
list readx =
  parens
  ( do expectP (L.Punc "[")
       (listRest False +++ listNext)
  )
 where
  listRest started =
    do L.Punc c <- lexP
       case c of
         "]"           -> return []
         "," | started -> listNext
         _             -> pfail

  listNext =
    do x  <- reset readx
       xs <- listRest True
       return (x:xs)

choose :: [(String, ReadPrec a)] -> ReadPrec a
-- ^ Parse the specified lexeme and continue as specified.
-- Esp useful for nullary constructors; e.g.
--    @choose [(\"A\", return A), (\"B\", return B)]@
-- We match both Ident and Symbol because the constructor
-- might be an operator eg @(:~:)@
choose sps = foldr ((+++) . try_one) pfail sps
           where
             try_one (s,p) = do { token <- lexP ;
                                  case token of
                                    L.Ident s'  | s==s' -> p
                                    L.Symbol s' | s==s' -> p
                                    _other              -> pfail }

-- See Note [Why readField]

-- | 'Read' parser for a record field, of the form @fieldName=value@. The
-- @fieldName@ must be an alphanumeric identifier; for symbols (operator-style)
-- field names, e.g. @(#)@, use 'readSymField'). The second argument is a
-- parser for the field value.
readField :: String -> ReadPrec a -> ReadPrec a
readField fieldName readVal = do
        expectP (L.Ident fieldName)
        expectP (L.Punc "=")
        readVal
{-# NOINLINE readField #-}

-- See Note [Why readField]

-- | 'Read' parser for a record field, of the form @fieldName#=value@. That is,
-- an alphanumeric identifier @fieldName@ followed by the symbol @#@. The
-- second argument is a parser for the field value.
--
-- Note that 'readField' does not suffice for this purpose due to
-- <https://ghc.haskell.org/trac/ghc/ticket/5041 Trac #5041>.
readFieldHash :: String -> ReadPrec a -> ReadPrec a
readFieldHash fieldName readVal = do
        expectP (L.Ident fieldName)
        expectP (L.Symbol "#")
        expectP (L.Punc "=")
        readVal
{-# NOINLINE readFieldHash #-}

-- See Note [Why readField]

-- | 'Read' parser for a symbol record field, of the form @(###)=value@ (where
-- @###@ is the field name). The field name must be a symbol (operator-style),
-- e.g. @(#)@. For regular (alphanumeric) field names, use 'readField'. The
-- second argument is a parser for the field value.
readSymField :: String -> ReadPrec a -> ReadPrec a
readSymField fieldName readVal = do
        expectP (L.Punc "(")
        expectP (L.Symbol fieldName)
        expectP (L.Punc ")")
        expectP (L.Punc "=")
        readVal
{-# NOINLINE readSymField #-}

-- Note [Why readField]
--
-- Previously, the code for automatically deriving Read instance (in
-- typecheck/TcGenDeriv.hs) would generate inline code for parsing fields;
-- this, however, turned out to produce massive amounts of intermediate code,
-- and produced a considerable performance hit in the code generator.
-- Since Read instances are not generally supposed to be perfomance critical,
-- the readField and readSymField functions have been factored out, and the
-- code generator now just generates calls rather than manually inlining the
-- parsers. For large record types (e.g. 500 fields), this produces a
-- significant performance boost.
--
-- See also Trac #14364.

--------------------------------------------------------------
-- Simple instances of Read
--------------------------------------------------------------

-- | @since 2.01
deriving instance Read GeneralCategory

-- | @since 2.01
instance Read Char where
  readPrec =
    parens
    ( do L.Char c <- lexP
         return c
    )

  readListPrec =
    parens
    ( do L.String s <- lexP     -- Looks for "foo"
         return s
     +++
      readListPrecDefault       -- Looks for ['f','o','o']
    )                           -- (more generous than H2010 spec)

  readList = readListDefault

-- | @since 2.01
instance Read Bool where
  readPrec =
    parens
    ( do L.Ident s <- lexP
         case s of
           "True"  -> return True
           "False" -> return False
           _       -> pfail
    )

  readListPrec = readListPrecDefault
  readList     = readListDefault

-- | @since 2.01
instance Read Ordering where
  readPrec =
    parens
    ( do L.Ident s <- lexP
         case s of
           "LT" -> return LT
           "EQ" -> return EQ
           "GT" -> return GT
           _    -> pfail
    )

  readListPrec = readListPrecDefault
  readList     = readListDefault

-- | @since 4.11.0.0
deriving instance Read a => Read (NonEmpty a)

--------------------------------------------------------------
-- Structure instances of Read: Maybe, List etc
--------------------------------------------------------------

{-
For structured instances of Read we start using the precedences.  The
idea is then that 'parens (prec k p)' will fail immediately when trying
to parse it in a context with a higher precedence level than k. But if
there is one parenthesis parsed, then the required precedence level
drops to 0 again, and parsing inside p may succeed.

'appPrec' is just the precedence level of function application.  So,
if we are parsing function application, we'd better require the
precedence level to be at least 'appPrec'. Otherwise, we have to put
parentheses around it.

'step' is used to increase the precedence levels inside a
parser, and can be used to express left- or right- associativity. For
example, % is defined to be left associative, so we only increase
precedence on the right hand side.

Note how step is used in for example the Maybe parser to increase the
precedence beyond appPrec, so that basically only literals and
parenthesis-like objects such as (...) and [...] can be an argument to
'Just'.
-}

-- | @since 2.01
instance Read a => Read (Maybe a) where
  readPrec =
    parens
    (do expectP (L.Ident "Nothing")
        return Nothing
     +++
     prec appPrec (
        do expectP (L.Ident "Just")
           x <- step readPrec
           return (Just x))
    )

  readListPrec = readListPrecDefault
  readList     = readListDefault

-- | @since 2.01
instance Read a => Read [a] where
  {-# SPECIALISE instance Read [String] #-}
  {-# SPECIALISE instance Read [Char] #-}
  {-# SPECIALISE instance Read [Int] #-}
  readPrec     = readListPrec
  readListPrec = readListPrecDefault
  readList     = readListDefault

-- | @since 2.01
instance  (Ix a, Read a, Read b) => Read (Array a b)  where
    readPrec = parens $ prec appPrec $
               do expectP (L.Ident "array")
                  theBounds <- step readPrec
                  vals   <- step readPrec
                  return (array theBounds vals)

    readListPrec = readListPrecDefault
    readList     = readListDefault

-- | @since 2.01
instance Read L.Lexeme where
  readPrec     = lexP
  readListPrec = readListPrecDefault
  readList     = readListDefault

--------------------------------------------------------------
-- Numeric instances of Read
--------------------------------------------------------------

readNumber :: Num a => (L.Lexeme -> ReadPrec a) -> ReadPrec a
-- Read a signed number
readNumber convert =
  parens
  ( do x <- lexP
       case x of
         L.Symbol "-" -> do y <- lexP
                            n <- convert y
                            return (negate n)

         _   -> convert x
  )

convertInt :: Num a => L.Lexeme -> ReadPrec a
convertInt (L.Number n)
 | Just i <- L.numberToInteger n = return (fromInteger i)
convertInt _ = pfail

convertFrac :: forall a . RealFloat a => L.Lexeme -> ReadPrec a
convertFrac (L.Ident "NaN")      = return (0 / 0)
convertFrac (L.Ident "Infinity") = return (1 / 0)
convertFrac (L.Number n) = let resRange = floatRange (undefined :: a)
                           in case L.numberToRangedRational resRange n of
                              Nothing -> return (1 / 0)
                              Just rat -> return $ fromRational rat
convertFrac _            = pfail

-- | @since 2.01
instance Read Int where
  readPrec     = readNumber convertInt
  readListPrec = readListPrecDefault
  readList     = readListDefault

-- | @since 4.5.0.0
instance Read Word where
    readsPrec p s = [(fromInteger x, r) | (x, r) <- readsPrec p s]

-- | @since 2.01
instance Read Word8 where
    readsPrec p s = [(fromIntegral (x::Int), r) | (x, r) <- readsPrec p s]

-- | @since 2.01
instance Read Word16 where
    readsPrec p s = [(fromIntegral (x::Int), r) | (x, r) <- readsPrec p s]

-- | @since 2.01
instance Read Word32 where
#if WORD_SIZE_IN_BITS < 33
    readsPrec p s = [(fromInteger x, r) | (x, r) <- readsPrec p s]
#else
    readsPrec p s = [(fromIntegral (x::Int), r) | (x, r) <- readsPrec p s]
#endif

-- | @since 2.01
instance Read Word64 where
    readsPrec p s = [(fromInteger x, r) | (x, r) <- readsPrec p s]

-- | @since 2.01
instance Read Integer where
  readPrec     = readNumber convertInt
  readListPrec = readListPrecDefault
  readList     = readListDefault

-- | @since 4.8.0.0
instance Read Natural where
  readsPrec d = map (\(n, s) -> (fromInteger n, s))
                  . filter ((>= 0) . (\(x,_)->x)) . readsPrec d

-- | @since 2.01
instance Read Float where
  readPrec     = readNumber convertFrac
  readListPrec = readListPrecDefault
  readList     = readListDefault

-- | @since 2.01
instance Read Double where
  readPrec     = readNumber convertFrac
  readListPrec = readListPrecDefault
  readList     = readListDefault

-- | @since 2.01
instance (Integral a, Read a) => Read (Ratio a) where
  readPrec =
    parens
    ( prec ratioPrec
      ( do x <- step readPrec
           expectP (L.Symbol "%")
           y <- step readPrec
           return (x % y)
      )
    )

  readListPrec = readListPrecDefault
  readList     = readListDefault

------------------------------------------------------------------------
-- Tuple instances of Read, up to size 15
------------------------------------------------------------------------

-- | @since 2.01
instance Read () where
  readPrec =
    parens
    ( paren
      ( return ()
      )
    )

  readListPrec = readListPrecDefault
  readList     = readListDefault

-- | @since 2.01
instance (Read a, Read b) => Read (a,b) where
  readPrec = wrap_tup read_tup2
  readListPrec = readListPrecDefault
  readList     = readListDefault

wrap_tup :: ReadPrec a -> ReadPrec a
wrap_tup p = parens (paren p)

read_comma :: ReadPrec ()
read_comma = expectP (L.Punc ",")

read_tup2 :: (Read a, Read b) => ReadPrec (a,b)
-- Reads "a , b"  no parens!
read_tup2 = do x <- readPrec
               read_comma
               y <- readPrec
               return (x,y)

read_tup4 :: (Read a, Read b, Read c, Read d) => ReadPrec (a,b,c,d)
read_tup4 = do  (a,b) <- read_tup2
                read_comma
                (c,d) <- read_tup2
                return (a,b,c,d)

read_tup8 :: (Read a, Read b, Read c, Read d, Read e, Read f, Read g, Read h)
          => ReadPrec (a,b,c,d,e,f,g,h)
read_tup8 = do  (a,b,c,d) <- read_tup4
                read_comma
                (e,f,g,h) <- read_tup4
                return (a,b,c,d,e,f,g,h)

-- | @since 2.01
instance (Read a, Read b, Read c) => Read (a, b, c) where
  readPrec = wrap_tup (do { (a,b) <- read_tup2; read_comma
                          ; c <- readPrec
                          ; return (a,b,c) })
  readListPrec = readListPrecDefault
  readList     = readListDefault

-- | @since 2.01
instance (Read a, Read b, Read c, Read d) => Read (a, b, c, d) where
  readPrec = wrap_tup read_tup4
  readListPrec = readListPrecDefault
  readList     = readListDefault

-- | @since 2.01
instance (Read a, Read b, Read c, Read d, Read e) => Read (a, b, c, d, e) where
  readPrec = wrap_tup (do { (a,b,c,d) <- read_tup4; read_comma
                          ; e <- readPrec
                          ; return (a,b,c,d,e) })
  readListPrec = readListPrecDefault
  readList     = readListDefault

-- | @since 2.01
instance (Read a, Read b, Read c, Read d, Read e, Read f)
        => Read (a, b, c, d, e, f) where
  readPrec = wrap_tup (do { (a,b,c,d) <- read_tup4; read_comma
                          ; (e,f) <- read_tup2
                          ; return (a,b,c,d,e,f) })
  readListPrec = readListPrecDefault
  readList     = readListDefault

-- | @since 2.01
instance (Read a, Read b, Read c, Read d, Read e, Read f, Read g)
        => Read (a, b, c, d, e, f, g) where
  readPrec = wrap_tup (do { (a,b,c,d) <- read_tup4; read_comma
                          ; (e,f) <- read_tup2; read_comma
                          ; g <- readPrec
                          ; return (a,b,c,d,e,f,g) })
  readListPrec = readListPrecDefault
  readList     = readListDefault

-- | @since 2.01
instance (Read a, Read b, Read c, Read d, Read e, Read f, Read g, Read h)
        => Read (a, b, c, d, e, f, g, h) where
  readPrec     = wrap_tup read_tup8
  readListPrec = readListPrecDefault
  readList     = readListDefault

-- | @since 2.01
instance (Read a, Read b, Read c, Read d, Read e, Read f, Read g, Read h,
          Read i)
        => Read (a, b, c, d, e, f, g, h, i) where
  readPrec = wrap_tup (do { (a,b,c,d,e,f,g,h) <- read_tup8; read_comma
                          ; i <- readPrec
                          ; return (a,b,c,d,e,f,g,h,i) })
  readListPrec = readListPrecDefault
  readList     = readListDefault

-- | @since 2.01
instance (Read a, Read b, Read c, Read d, Read e, Read f, Read g, Read h,
          Read i, Read j)
        => Read (a, b, c, d, e, f, g, h, i, j) where
  readPrec = wrap_tup (do { (a,b,c,d,e,f,g,h) <- read_tup8; read_comma
                          ; (i,j) <- read_tup2
                          ; return (a,b,c,d,e,f,g,h,i,j) })
  readListPrec = readListPrecDefault
  readList     = readListDefault

-- | @since 2.01
instance (Read a, Read b, Read c, Read d, Read e, Read f, Read g, Read h,
          Read i, Read j, Read k)
        => Read (a, b, c, d, e, f, g, h, i, j, k) where
  readPrec = wrap_tup (do { (a,b,c,d,e,f,g,h) <- read_tup8; read_comma
                          ; (i,j) <- read_tup2; read_comma
                          ; k <- readPrec
                          ; return (a,b,c,d,e,f,g,h,i,j,k) })
  readListPrec = readListPrecDefault
  readList     = readListDefault

-- | @since 2.01
instance (Read a, Read b, Read c, Read d, Read e, Read f, Read g, Read h,
          Read i, Read j, Read k, Read l)
        => Read (a, b, c, d, e, f, g, h, i, j, k, l) where
  readPrec = wrap_tup (do { (a,b,c,d,e,f,g,h) <- read_tup8; read_comma
                          ; (i,j,k,l) <- read_tup4
                          ; return (a,b,c,d,e,f,g,h,i,j,k,l) })
  readListPrec = readListPrecDefault
  readList     = readListDefault

-- | @since 2.01
instance (Read a, Read b, Read c, Read d, Read e, Read f, Read g, Read h,
          Read i, Read j, Read k, Read l, Read m)
        => Read (a, b, c, d, e, f, g, h, i, j, k, l, m) where
  readPrec = wrap_tup (do { (a,b,c,d,e,f,g,h) <- read_tup8; read_comma
                          ; (i,j,k,l) <- read_tup4; read_comma
                          ; m <- readPrec
                          ; return (a,b,c,d,e,f,g,h,i,j,k,l,m) })
  readListPrec = readListPrecDefault
  readList     = readListDefault

-- | @since 2.01
instance (Read a, Read b, Read c, Read d, Read e, Read f, Read g, Read h,
          Read i, Read j, Read k, Read l, Read m, Read n)
        => Read (a, b, c, d, e, f, g, h, i, j, k, l, m, n) where
  readPrec = wrap_tup (do { (a,b,c,d,e,f,g,h) <- read_tup8; read_comma
                          ; (i,j,k,l) <- read_tup4; read_comma
                          ; (m,n) <- read_tup2
                          ; return (a,b,c,d,e,f,g,h,i,j,k,l,m,n) })
  readListPrec = readListPrecDefault
  readList     = readListDefault

-- | @since 2.01
instance (Read a, Read b, Read c, Read d, Read e, Read f, Read g, Read h,
          Read i, Read j, Read k, Read l, Read m, Read n, Read o)
        => Read (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o) where
  readPrec = wrap_tup (do { (a,b,c,d,e,f,g,h) <- read_tup8; read_comma
                          ; (i,j,k,l) <- read_tup4; read_comma
                          ; (m,n) <- read_tup2; read_comma
                          ; o <- readPrec
                          ; return (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o) })
  readListPrec = readListPrecDefault
  readList     = readListDefault


{-# LANGUAGE Trustworthy #-}
{-# LANGUAGE CPP, NoImplicitPrelude, MagicHash, UnboxedTuples, BangPatterns #-}
{-# OPTIONS_GHC -Wno-orphans #-}
{-# OPTIONS_HADDOCK not-home #-}

-----------------------------------------------------------------------------
-- |
-- Module      :  GHC.Real
-- Copyright   :  (c) The University of Glasgow, 1994-2002
-- License     :  see libraries/base/LICENSE
--
-- Maintainer  :  cvs-ghc@haskell.org
-- Stability   :  internal
-- Portability :  non-portable (GHC Extensions)
--
-- The types 'Ratio' and 'Rational', and the classes 'Real', 'Fractional',
-- 'Integral', and 'RealFrac'.
--
-----------------------------------------------------------------------------

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
                                   , underflowException
                                   , ratioZeroDenomException )

#if defined(MIN_VERSION_integer_gmp)
import GHC.Integer.GMP.Internals
#endif

infixr 8  ^, ^^
infixl 7  /, `quot`, `rem`, `div`, `mod`
infixl 7  %

default ()              -- Double isn't available yet,
                        -- and we shouldn't be using defaults anyway

------------------------------------------------------------------------
-- Divide by zero and arithmetic overflow
------------------------------------------------------------------------

-- We put them here because they are needed relatively early
-- in the libraries before the Exception type has been defined yet.

{-# NOINLINE divZeroError #-}
divZeroError :: a
divZeroError = raise# divZeroException

{-# NOINLINE ratioZeroDenominatorError #-}
ratioZeroDenominatorError :: a
ratioZeroDenominatorError = raise# ratioZeroDenomException

{-# NOINLINE overflowError #-}
overflowError :: a
overflowError = raise# overflowException

{-# NOINLINE underflowError #-}
underflowError :: a
underflowError = raise# underflowException

--------------------------------------------------------------
-- The Ratio and Rational types
--------------------------------------------------------------

-- | Rational numbers, with numerator and denominator of some 'Integral' type.
--
-- Note that `Ratio`'s instances inherit the deficiencies from the type
-- parameter's. For example, @Ratio Natural@'s 'Num' instance has similar
-- problems to `Numeric.Natural.Natural`'s.
data  Ratio a = !a :% !a  deriving Eq -- ^ @since 2.01

-- | Arbitrary-precision rational numbers, represented as a ratio of
-- two 'Integer' values.  A rational number may be constructed using
-- the '%' operator.
type  Rational          =  Ratio Integer

ratioPrec, ratioPrec1 :: Int
ratioPrec  = 7  -- Precedence of ':%' constructor
ratioPrec1 = ratioPrec + 1

infinity, notANumber :: Rational
infinity   = 1 :% 0
notANumber = 0 :% 0

-- Use :%, not % for Inf/NaN; the latter would
-- immediately lead to a runtime error, because it normalises.

-- | Forms the ratio of two integral numbers.
{-# SPECIALISE (%) :: Integer -> Integer -> Rational #-}
(%)                     :: (Integral a) => a -> a -> Ratio a

-- | Extract the numerator of the ratio in reduced form:
-- the numerator and denominator have no common factor and the denominator
-- is positive.
numerator       :: Ratio a -> a

-- | Extract the denominator of the ratio in reduced form:
-- the numerator and denominator have no common factor and the denominator
-- is positive.
denominator     :: Ratio a -> a

-- | 'reduce' is a subsidiary function used only in this module.
-- It normalises a ratio by dividing both numerator and denominator by
-- their greatest common divisor.
reduce ::  (Integral a) => a -> a -> Ratio a
{-# SPECIALISE reduce :: Integer -> Integer -> Rational #-}
reduce _ 0              =  ratioZeroDenominatorError
reduce x y              =  (x `quot` d) :% (y `quot` d)
                           where d = gcd x y

x % y                   =  reduce (x * signum y) (abs y)

numerator   (x :% _)    =  x
denominator (_ :% y)    =  y

--------------------------------------------------------------
-- Standard numeric classes
--------------------------------------------------------------

class  (Num a, Ord a) => Real a  where
    -- | the rational equivalent of its real argument with full precision
    toRational          ::  a -> Rational

-- | Integral numbers, supporting integer division.
--
-- The Haskell Report defines no laws for 'Integral'. However, 'Integral'
-- instances are customarily expected to define a Euclidean domain and have the
-- following properties for the `div`\/`mod` and `quot`\/`rem` pairs, given
-- suitable Euclidean functions @f@ and @g@:
--
-- * @x@ = @y * quot x y + rem x y@ with @rem x y@ = @fromInteger 0@ or
-- @g (rem x y)@ < @g y@
-- * @x@ = @y * div x y + mod x y@ with @mod x y@ = @fromInteger 0@ or
-- @f (mod x y)@ < @f y@
--
-- An example of a suitable Euclidean function, for `Integer`'s instance, is
-- 'abs'.
class  (Real a, Enum a) => Integral a  where
    -- | integer division truncated toward zero
    quot                :: a -> a -> a
    -- | integer remainder, satisfying
    --
    -- > (x `quot` y)*y + (x `rem` y) == x
    rem                 :: a -> a -> a
    -- | integer division truncated toward negative infinity
    div                 :: a -> a -> a
    -- | integer modulus, satisfying
    --
    -- > (x `div` y)*y + (x `mod` y) == x
    mod                 :: a -> a -> a
    -- | simultaneous 'quot' and 'rem'
    quotRem             :: a -> a -> (a,a)
    -- | simultaneous 'div' and 'mod'
    divMod              :: a -> a -> (a,a)
    -- | conversion to 'Integer'
    toInteger           :: a -> Integer

    {-# INLINE quot #-}
    {-# INLINE rem #-}
    {-# INLINE div #-}
    {-# INLINE mod #-}
    n `quot` d          =  q  where (q,_) = quotRem n d
    n `rem` d           =  r  where (_,r) = quotRem n d
    n `div` d           =  q  where (q,_) = divMod n d
    n `mod` d           =  r  where (_,r) = divMod n d

    divMod n d          =  if signum r == negate (signum d) then (q-1, r+d) else qr
                           where qr@(q,r) = quotRem n d

-- | Fractional numbers, supporting real division.
--
-- The Haskell Report defines no laws for 'Fractional'. However, @('+')@ and
-- @('*')@ are customarily expected to define a division ring and have the
-- following properties:
--
-- [__'recip' gives the multiplicative inverse__]:
-- @x * recip x@ = @recip x * x@ = @fromInteger 1@
--
-- Note that it /isn't/ customarily expected that a type instance of
-- 'Fractional' implement a field. However, all instances in @base@ do.
class  (Num a) => Fractional a  where
    {-# MINIMAL fromRational, (recip | (/)) #-}

    -- | Fractional division.
    (/)                 :: a -> a -> a
    -- | Reciprocal fraction.
    recip               :: a -> a
    -- | Conversion from a 'Rational' (that is @'Ratio' 'Integer'@).
    -- A floating literal stands for an application of 'fromRational'
    -- to a value of type 'Rational', so such literals have type
    -- @('Fractional' a) => a@.
    fromRational        :: Rational -> a

    {-# INLINE recip #-}
    {-# INLINE (/) #-}
    recip x             =  1 / x
    x / y               = x * recip y

-- | Extracting components of fractions.
class  (Real a, Fractional a) => RealFrac a  where
    -- | The function 'properFraction' takes a real fractional number @x@
    -- and returns a pair @(n,f)@ such that @x = n+f@, and:
    --
    -- * @n@ is an integral number with the same sign as @x@; and
    --
    -- * @f@ is a fraction with the same type and sign as @x@,
    --   and with absolute value less than @1@.
    --
    -- The default definitions of the 'ceiling', 'floor', 'truncate'
    -- and 'round' functions are in terms of 'properFraction'.
    properFraction      :: (Integral b) => a -> (b,a)
    -- | @'truncate' x@ returns the integer nearest @x@ between zero and @x@
    truncate            :: (Integral b) => a -> b
    -- | @'round' x@ returns the nearest integer to @x@;
    --   the even integer if @x@ is equidistant between two integers
    round               :: (Integral b) => a -> b
    -- | @'ceiling' x@ returns the least integer not less than @x@
    ceiling             :: (Integral b) => a -> b
    -- | @'floor' x@ returns the greatest integer not greater than @x@
    floor               :: (Integral b) => a -> b

    {-# INLINE truncate #-}
    truncate x          =  m  where (m,_) = properFraction x

    round x             =  let (n,r) = properFraction x
                               m     = if r < 0 then n - 1 else n + 1
                           in case signum (abs r - 0.5) of
                                -1 -> n
                                0  -> if even n then n else m
                                1  -> m
                                _  -> errorWithoutStackTrace "round default defn: Bad value"

    ceiling x           =  if r > 0 then n + 1 else n
                           where (n,r) = properFraction x

    floor x             =  if r < 0 then n - 1 else n
                           where (n,r) = properFraction x

-- These 'numeric' enumerations come straight from the Report

numericEnumFrom         :: (Fractional a) => a -> [a]
numericEnumFrom n       = go 0
  where
    -- See Note [Numeric Stability of Enumerating Floating Numbers]
    go !k = let !n' = n + k
             in n' : go (k + 1)

numericEnumFromThen     :: (Fractional a) => a -> a -> [a]
numericEnumFromThen n m = go 0
  where
    step = m - n
    -- See Note [Numeric Stability of Enumerating Floating Numbers]
    go !k = let !n' = n + k * step
             in n' : go (k + 1)

numericEnumFromTo       :: (Ord a, Fractional a) => a -> a -> [a]
numericEnumFromTo n m   = takeWhile (<= m + 1/2) (numericEnumFrom n)

numericEnumFromThenTo   :: (Ord a, Fractional a) => a -> a -> a -> [a]
numericEnumFromThenTo e1 e2 e3
    = takeWhile predicate (numericEnumFromThen e1 e2)
                                where
                                 mid = (e2 - e1) / 2
                                 predicate | e2 >= e1  = (<= e3 + mid)
                                           | otherwise = (>= e3 + mid)

{- Note [Numeric Stability of Enumerating Floating Numbers]
-----------------------------------------------------------
When enumerate floating numbers, we could add the increment to the last number
at every run (as what we did previously):

    numericEnumFrom n =  n `seq` (n : numericEnumFrom (n + 1))

This approach is concise and really fast, only needs an addition operation.
However when a floating number is large enough, for `n`, `n` and `n+1` will
have the same binary representation. For example (all number has type
`Double`):

    9007199254740990                 is: 0x433ffffffffffffe
    9007199254740990 + 1             is: 0x433fffffffffffff
    (9007199254740990 + 1) + 1       is: 0x4340000000000000
    ((9007199254740990 + 1) + 1) + 1 is: 0x4340000000000000

When we evaluate ([9007199254740990..9007199254740991] :: Double), we would
never reach the condition in `numericEnumFromTo`

    9007199254740990 + 1 + 1 + ... > 9007199254740991 + 1/2

We would fall into infinite loop (as reported in Trac #15081).

To remedy the situation, we record the number of `1` that needed to be added
to the start number, rather than increasing `1` at every time. This approach
can improvement the numeric stability greatly at the cost of a multiplication.

Furthermore, we use the type of the enumerated number, `Fractional a => a`,
as the type of multiplier. In rare situations, the multiplier could be very
large and will lead to the enumeration to infinite loop, too, which should
be very rare. Consider the following example:

    [1..9007199254740994]

We could fix that by using an Integer as multiplier but we don't do that.
The benchmark on T7954.hs shows that this approach leads to significant
degeneration on performance (33% increase allocation and 300% increase on
elapsed time).

See Trac #15081 and Phab:D4650 for the related discussion about this problem.
-}

--------------------------------------------------------------
-- Instances for Int
--------------------------------------------------------------

-- | @since 2.0.1
instance  Real Int  where
    toRational x        =  toInteger x :% 1

-- | @since 2.0.1
instance  Integral Int  where
    toInteger (I# i) = smallInteger i

    a `quot` b
     | b == 0                     = divZeroError
     | b == (-1) && a == minBound = overflowError -- Note [Order of tests]
                                                  -- in GHC.Int
     | otherwise                  =  a `quotInt` b

    a `rem` b
     | b == 0                     = divZeroError
       -- The quotRem CPU instruction fails for minBound `quotRem` -1,
       -- but minBound `rem` -1 is well-defined (0). We therefore
       -- special-case it.
     | b == (-1)                  = 0
     | otherwise                  =  a `remInt` b

    a `div` b
     | b == 0                     = divZeroError
     | b == (-1) && a == minBound = overflowError -- Note [Order of tests]
                                                  -- in GHC.Int
     | otherwise                  =  a `divInt` b

    a `mod` b
     | b == 0                     = divZeroError
       -- The divMod CPU instruction fails for minBound `divMod` -1,
       -- but minBound `mod` -1 is well-defined (0). We therefore
       -- special-case it.
     | b == (-1)                  = 0
     | otherwise                  =  a `modInt` b

    a `quotRem` b
     | b == 0                     = divZeroError
       -- Note [Order of tests] in GHC.Int
     | b == (-1) && a == minBound = (overflowError, 0)
     | otherwise                  =  a `quotRemInt` b

    a `divMod` b
     | b == 0                     = divZeroError
       -- Note [Order of tests] in GHC.Int
     | b == (-1) && a == minBound = (overflowError, 0)
     | otherwise                  =  a `divModInt` b

--------------------------------------------------------------
-- Instances for @Word@
--------------------------------------------------------------

-- | @since 2.01
instance Real Word where
    toRational x = toInteger x % 1

-- | @since 2.01
instance Integral Word where
    quot    (W# x#) y@(W# y#)
        | y /= 0                = W# (x# `quotWord#` y#)
        | otherwise             = divZeroError
    rem     (W# x#) y@(W# y#)
        | y /= 0                = W# (x# `remWord#` y#)
        | otherwise             = divZeroError
    div     (W# x#) y@(W# y#)
        | y /= 0                = W# (x# `quotWord#` y#)
        | otherwise             = divZeroError
    mod     (W# x#) y@(W# y#)
        | y /= 0                = W# (x# `remWord#` y#)
        | otherwise             = divZeroError
    quotRem (W# x#) y@(W# y#)
        | y /= 0                = case x# `quotRemWord#` y# of
                                  (# q, r #) ->
                                      (W# q, W# r)
        | otherwise             = divZeroError
    divMod  (W# x#) y@(W# y#)
        | y /= 0                = (W# (x# `quotWord#` y#), W# (x# `remWord#` y#))
        | otherwise             = divZeroError
    toInteger (W# x#)           = wordToInteger x#

--------------------------------------------------------------
-- Instances for Integer
--------------------------------------------------------------

-- | @since 2.0.1
instance  Real Integer  where
    toRational x        =  x :% 1

-- | @since 4.8.0.0
instance Real Natural where
    toRational n = naturalToInteger n :% 1

-- Note [Integer division constant folding]
-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
--
-- Constant folding of quot, rem, div, mod, divMod and quotRem for
-- Integer arguments depends crucially on inlining. Constant folding
-- rules defined in compiler/prelude/PrelRules.hs trigger for
-- quotInteger, remInteger and so on. So if calls to quot, rem and so on
-- were not inlined the rules would not fire. The rules would also not
-- fire if calls to quotInteger and so on were inlined, but this does not
-- happen because they are all marked with NOINLINE pragma - see documentation
-- of integer-gmp or integer-simple.

-- | @since 2.0.1
instance  Integral Integer where
    toInteger n      = n

    {-# INLINE quot #-}
    _ `quot` 0 = divZeroError
    n `quot` d = n `quotInteger` d

    {-# INLINE rem #-}
    _ `rem` 0 = divZeroError
    n `rem` d = n `remInteger` d

    {-# INLINE div #-}
    _ `div` 0 = divZeroError
    n `div` d = n `divInteger` d

    {-# INLINE mod #-}
    _ `mod` 0 = divZeroError
    n `mod` d = n `modInteger` d

    {-# INLINE divMod #-}
    _ `divMod` 0 = divZeroError
    n `divMod` d = case n `divModInteger` d of
                     (# x, y #) -> (x, y)

    {-# INLINE quotRem #-}
    _ `quotRem` 0 = divZeroError
    n `quotRem` d = case n `quotRemInteger` d of
                      (# q, r #) -> (q, r)

-- | @since 4.8.0.0
instance Integral Natural where
    toInteger = naturalToInteger

    divMod = quotRemNatural
    div    = quotNatural
    mod    = remNatural

    quotRem = quotRemNatural
    quot    = quotNatural
    rem     = remNatural

--------------------------------------------------------------
-- Instances for @Ratio@
--------------------------------------------------------------

-- | @since 2.0.1
instance  (Integral a)  => Ord (Ratio a)  where
    {-# SPECIALIZE instance Ord Rational #-}
    (x:%y) <= (x':%y')  =  x * y' <= x' * y
    (x:%y) <  (x':%y')  =  x * y' <  x' * y

-- | @since 2.0.1
instance  (Integral a)  => Num (Ratio a)  where
    {-# SPECIALIZE instance Num Rational #-}
    (x:%y) + (x':%y')   =  reduce (x*y' + x'*y) (y*y')
    (x:%y) - (x':%y')   =  reduce (x*y' - x'*y) (y*y')
    (x:%y) * (x':%y')   =  reduce (x * x') (y * y')
    negate (x:%y)       =  (-x) :% y
    abs (x:%y)          =  abs x :% y
    signum (x:%_)       =  signum x :% 1
    fromInteger x       =  fromInteger x :% 1

-- | @since 2.0.1
{-# RULES "fromRational/id" fromRational = id :: Rational -> Rational #-}
instance  (Integral a)  => Fractional (Ratio a)  where
    {-# SPECIALIZE instance Fractional Rational #-}
    (x:%y) / (x':%y')   =  (x*y') % (y*x')
    recip (0:%_)        = ratioZeroDenominatorError
    recip (x:%y)
        | x < 0         = negate y :% negate x
        | otherwise     = y :% x
    fromRational (x:%y) =  fromInteger x % fromInteger y

-- | @since 2.0.1
instance  (Integral a)  => Real (Ratio a)  where
    {-# SPECIALIZE instance Real Rational #-}
    toRational (x:%y)   =  toInteger x :% toInteger y

-- | @since 2.0.1
instance  (Integral a)  => RealFrac (Ratio a)  where
    {-# SPECIALIZE instance RealFrac Rational #-}
    properFraction (x:%y) = (fromInteger (toInteger q), r:%y)
                          where (q,r) = quotRem x y

-- | @since 2.0.1
instance  (Show a)  => Show (Ratio a)  where
    {-# SPECIALIZE instance Show Rational #-}
    showsPrec p (x:%y)  =  showParen (p > ratioPrec) $
                           showsPrec ratioPrec1 x .
                           showString " % " .
                           -- H98 report has spaces round the %
                           -- but we removed them [May 04]
                           -- and added them again for consistency with
                           -- Haskell 98 [Sep 08, #1920]
                           showsPrec ratioPrec1 y

-- | @since 2.0.1
instance  (Integral a)  => Enum (Ratio a)  where
    {-# SPECIALIZE instance Enum Rational #-}
    succ x              =  x + 1
    pred x              =  x - 1

    toEnum n            =  fromIntegral n :% 1
    fromEnum            =  fromInteger . truncate

    enumFrom            =  numericEnumFrom
    enumFromThen        =  numericEnumFromThen
    enumFromTo          =  numericEnumFromTo
    enumFromThenTo      =  numericEnumFromThenTo

--------------------------------------------------------------
-- Coercions
--------------------------------------------------------------

-- | general coercion from integral types
{-# NOINLINE [1] fromIntegral #-}
fromIntegral :: (Integral a, Num b) => a -> b
fromIntegral = fromInteger . toInteger

{-# RULES
"fromIntegral/Int->Int" fromIntegral = id :: Int -> Int
    #-}

{-# RULES
"fromIntegral/Int->Word"  fromIntegral = \(I# x#) -> W# (int2Word# x#)
"fromIntegral/Word->Int"  fromIntegral = \(W# x#) -> I# (word2Int# x#)
"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 #-}
realToFrac = fromRational . toRational

--------------------------------------------------------------
-- Overloaded numeric functions
--------------------------------------------------------------

-- | Converts a possibly-negative 'Real' value to a string.
showSigned :: (Real a)
  => (a -> ShowS)       -- ^ a function that can show unsigned values
  -> Int                -- ^ the precedence of the enclosing context
  -> a                  -- ^ the value to show
  -> ShowS
showSigned showPos p x
   | x < 0     = showParen (p > 6) (showChar '-' . showPos (-x))
   | otherwise = showPos x

even, odd       :: (Integral a) => a -> Bool
even n          =  n `rem` 2 == 0
odd             =  not . even
{-# INLINABLE even #-}
{-# INLINABLE odd  #-}

-------------------------------------------------------
-- | raise a number to a non-negative integral power
{-# SPECIALISE [1] (^) ::
        Integer -> Integer -> Integer,
        Integer -> Int -> Integer,
        Int -> Int -> Int #-}
{-# INLINABLE [1] (^) #-}    -- See Note [Inlining (^)]
(^) :: (Num a, Integral b) => a -> b -> a
x0 ^ y0 | y0 < 0    = errorWithoutStackTrace "Negative exponent"
        | y0 == 0   = 1
        | otherwise = f x0 y0
    where -- f : x0 ^ y0 = x ^ y
          f x y | even y    = f (x * x) (y `quot` 2)
                | y == 1    = x
                | otherwise = g (x * x) (y `quot` 2) x         -- See Note [Half of y - 1]
          -- g : x0 ^ y0 = (x ^ y) * z
          g x y z | even y = g (x * x) (y `quot` 2) z
                  | y == 1 = x * z
                  | otherwise = g (x * x) (y `quot` 2) (x * z) -- See Note [Half of y - 1]

-- | raise a number to an integral power
(^^)            :: (Fractional a, Integral b) => a -> b -> a
{-# INLINABLE [1] (^^) #-}         -- See Note [Inlining (^)
x ^^ n          =  if n >= 0 then x^n else recip (x^(negate n))

{- Note [Half of y - 1]
   ~~~~~~~~~~~~~~~~~~~~~
   Since y is guaranteed to be odd and positive here,
   half of y - 1 can be computed as y `quot` 2, optimising subtraction away.
-}

{- Note [Inlining (^)
   ~~~~~~~~~~~~~~~~~~~~~
   The INLINABLE pragma allows (^) to be specialised at its call sites.
   If it is called repeatedly at the same type, that can make a huge
   difference, because of those constants which can be repeatedly
   calculated.

   Currently the fromInteger calls are not floated because we get
             \d1 d2 x y -> blah
   after the gentle round of simplification. -}

{- Rules for powers with known small exponent
    see #5237
    For small exponents, (^) is inefficient compared to manually
    expanding the multiplication tree.
    Here, rules for the most common exponent types are given.
    The range of exponents for which rules are given is quite
    arbitrary and kept small to not unduly increase the number of rules.
    0 and 1 are excluded based on the assumption that nobody would
    write x^0 or x^1 in code and the cases where an exponent could
    be statically resolved to 0 or 1 are rare.

    It might be desirable to have corresponding rules also for
    exponents of other types (e. g., Word), but it's doubtful they
    would fire, since the exponents of other types tend to get
    floated out before the rule has a chance to fire.

    Also desirable would be rules for (^^), but I haven't managed
    to get those to fire.

    Note: Trying to save multiplications by sharing the square for
    exponents 4 and 5 does not save time, indeed, for Double, it is
    up to twice slower, so the rules contain flat sequences of
    multiplications.
-}

{-# RULES
"^2/Int"        forall x. x ^ (2 :: Int) = let u = x in u*u
"^3/Int"        forall x. x ^ (3 :: Int) = let u = x in u*u*u
"^4/Int"        forall x. x ^ (4 :: Int) = let u = x in u*u*u*u
"^5/Int"        forall x. x ^ (5 :: Int) = let u = x in u*u*u*u*u
"^2/Integer"    forall x. x ^ (2 :: Integer) = let u = x in u*u
"^3/Integer"    forall x. x ^ (3 :: Integer) = let u = x in u*u*u
"^4/Integer"    forall x. x ^ (4 :: Integer) = let u = x in u*u*u*u
"^5/Integer"    forall x. x ^ (5 :: Integer) = let u = x in u*u*u*u*u
  #-}

-------------------------------------------------------
-- Special power functions for Rational
--
-- see #4337
--
-- Rationale:
-- For a legitimate Rational (n :% d), the numerator and denominator are
-- coprime, i.e. they have no common prime factor.
-- Therefore all powers (n ^ a) and (d ^ b) are also coprime, so it is
-- not necessary to compute the greatest common divisor, which would be
-- done in the default implementation at each multiplication step.
-- Since exponentiation quickly leads to very large numbers and
-- calculation of gcds is generally very slow for large numbers,
-- avoiding the gcd leads to an order of magnitude speedup relatively
-- soon (and an asymptotic improvement overall).
--
-- Note:
-- We cannot use these functions for general Ratio a because that would
-- change results in a multitude of cases.
-- The cause is that if a and b are coprime, their remainders by any
-- positive modulus generally aren't, so in the default implementation
-- reduction occurs.
--
-- Example:
-- (17 % 3) ^ 3 :: Ratio Word8
-- Default:
-- (17 % 3) ^ 3 = ((17 % 3) ^ 2) * (17 % 3)
--              = ((289 `mod` 256) % 9) * (17 % 3)
--              = (33 % 9) * (17 % 3)
--              = (11 % 3) * (17 % 3)
--              = (187 % 9)
-- But:
-- ((17^3) `mod` 256) % (3^3)   = (4913 `mod` 256) % 27
--                              = 49 % 27
--
-- TODO:
-- Find out whether special-casing for numerator, denominator or
-- exponent = 1 (or -1, where that may apply) gains something.

-- Special version of (^) for Rational base
{-# RULES "(^)/Rational"    (^) = (^%^) #-}
(^%^)           :: Integral a => Rational -> a -> Rational
(n :% d) ^%^ e
    | e < 0     = errorWithoutStackTrace "Negative exponent"
    | e == 0    = 1 :% 1
    | otherwise = (n ^ e) :% (d ^ e)

-- Special version of (^^) for Rational base
{-# RULES "(^^)/Rational"   (^^) = (^^%^^) #-}
(^^%^^)         :: Integral a => Rational -> a -> Rational
(n :% d) ^^%^^ e
    | e > 0     = (n ^ e) :% (d ^ e)
    | e == 0    = 1 :% 1
    | n > 0     = (d ^ (negate e)) :% (n ^ (negate e))
    | n == 0    = ratioZeroDenominatorError
    | otherwise = let nn = d ^ (negate e)
                      dd = (negate n) ^ (negate e)
                  in if even e then (nn :% dd) else (negate nn :% dd)

-------------------------------------------------------
-- | @'gcd' x y@ is the non-negative factor of both @x@ and @y@ of which
-- every common factor of @x@ and @y@ is also a factor; for example
-- @'gcd' 4 2 = 2@, @'gcd' (-4) 6 = 2@, @'gcd' 0 4@ = @4@. @'gcd' 0 0@ = @0@.
-- (That is, the common divisor that is \"greatest\" in the divisibility
-- preordering.)
--
-- Note: Since for signed fixed-width integer types, @'abs' 'minBound' < 0@,
-- the result may be negative if one of the arguments is @'minBound'@ (and
-- necessarily is if the other is @0@ or @'minBound'@) for such types.
gcd             :: (Integral a) => a -> a -> a
{-# NOINLINE [1] gcd #-}
gcd x y         =  gcd' (abs x) (abs y)
                   where gcd' a 0  =  a
                         gcd' a b  =  gcd' b (a `rem` b)

-- | @'lcm' x y@ is the smallest positive integer that both @x@ and @y@ divide.
lcm             :: (Integral a) => a -> a -> a
{-# SPECIALISE lcm :: Int -> Int -> Int #-}
{-# SPECIALISE lcm :: Word -> Word -> Word #-}
{-# NOINLINE [1] lcm #-}
lcm _ 0         =  0
lcm 0 _         =  0
lcm x y         =  abs ((x `quot` (gcd x y)) * y)

{-# RULES
"gcd/Integer->Integer->Integer" gcd = gcdInteger
"lcm/Integer->Integer->Integer" lcm = lcmInteger
"gcd/Natural->Natural->Natural" gcd = gcdNatural
"lcm/Natural->Natural->Natural" lcm = lcmNatural
 #-}

#if defined(MIN_VERSION_integer_gmp)
-- GMP defines a more efficient Int# and Word# GCD

gcdInt' :: Int -> Int -> Int
gcdInt' (I# x) (I# y) = I# (gcdInt x y)

gcdWord' :: Word -> Word -> Word
gcdWord' (W# x) (W# y) = W# (gcdWord x y)

{-# RULES
"gcd/Int->Int->Int"             gcd = gcdInt'
"gcd/Word->Word->Word"          gcd = gcdWord'
 #-}

#endif

integralEnumFrom :: (Integral a, Bounded a) => a -> [a]
integralEnumFrom n = map fromInteger [toInteger n .. toInteger (maxBound `asTypeOf` n)]

integralEnumFromThen :: (Integral a, Bounded a) => a -> a -> [a]
integralEnumFromThen n1 n2
  | i_n2 >= i_n1  = map fromInteger [i_n1, i_n2 .. toInteger (maxBound `asTypeOf` n1)]
  | otherwise     = map fromInteger [i_n1, i_n2 .. toInteger (minBound `asTypeOf` n1)]
  where
    i_n1 = toInteger n1
    i_n2 = toInteger n2

integralEnumFromTo :: Integral a => a -> a -> [a]
integralEnumFromTo n m = map fromInteger [toInteger n .. toInteger m]

integralEnumFromThenTo :: Integral a => a -> a -> a -> [a]
integralEnumFromThenTo n1 n2 m
  = map fromInteger [toInteger n1, toInteger n2 .. toInteger m]


{-# LANGUAGE AllowAmbiguousTypes
           , FunctionalDependencies
           , KindSignatures
           , MultiParamTypeClasses
           , PolyKinds
  #-}

-----------------------------------------------------------------------------
-- |
-- Module      :  GHC.Records
-- Copyright   :  (c) Adam Gundry 2015-2016
-- License     :  see libraries/base/LICENSE
--
-- Maintainer  :  cvs-ghc@haskell.org
-- Stability   :  internal
-- Portability :  non-portable (GHC extensions)
--
-- This module defines the 'HasField' class used by the
-- @OverloadedRecordFields@ extension.  See the
-- <https://ghc.haskell.org/trac/ghc/wiki/Records/OverloadedRecordFields
-- wiki page> for more details.
--
-----------------------------------------------------------------------------

module GHC.Records
       ( HasField(..)
       ) where

-- | Constraint representing the fact that the field @x@ belongs to
-- the record type @r@ and has field type @a@.  This will be solved
-- automatically, but manual instances may be provided as well.

--   HasField :: forall {k}. k -> * -> * -> Constraint
--   getField :: forall {k} (x::k) r a. HasField x r a => r -> a
-- NB: The {k} means that k is an 'inferred' type variable, and
--     hence not provided in visible type applications.  Thus you
--     say     getField @"foo"
--     not     getField @Symbol @"foo"
class HasField x r a | x r -> a where
  -- | Selector function to extract the field from the record.
  getField :: r -> a


{-# LANGUAGE ScopedTypeVariables #-}

-----------------------------------------------------------------------------
-- |
-- Module      :  GHC.ResponseFile
-- License     :  BSD-style (see the file LICENSE)
--
-- Maintainer  :  libraries@haskell.org
-- Stability   :  internal
-- Portability :  portable
--
-- GCC style response files.
--
-- @since 4.12.0.0
----------------------------------------------------------------------------

-- Migrated from Haddock.

module GHC.ResponseFile (
    getArgsWithResponseFiles,
    unescapeArgs,
    escapeArgs,
    expandResponse
  ) where

import Control.Exception
import Data.Char          (isSpace)
import Data.Foldable      (foldl')
import System.Environment (getArgs)
import System.Exit        (exitFailure)
import System.IO

{-|
Like 'getArgs', but can also read arguments supplied via response files.

For example, consider a program @foo@:

@
main :: IO ()
main = do
  args <- getArgsWithResponseFiles
  putStrLn (show args)
@

And a response file @args.txt@:

@
--one 1
--\'two\' 2
--"three" 3
@

Then the result of invoking @foo@ with @args.txt@ is:

> > ./foo @args.txt
> ["--one","1","--two","2","--three","3"]

-}
getArgsWithResponseFiles :: IO [String]
getArgsWithResponseFiles = getArgs >>= expandResponse

-- | Given a string of concatenated strings, separate each by removing
-- a layer of /quoting/ and\/or /escaping/ of certain characters.
--
-- These characters are: any whitespace, single quote, double quote,
-- and the backslash character.  The backslash character always
-- escapes (i.e., passes through without further consideration) the
-- character which follows.  Characters can also be escaped in blocks
-- by quoting (i.e., surrounding the blocks with matching pairs of
-- either single- or double-quotes which are not themselves escaped).
--
-- Any whitespace which appears outside of either of the quoting and
-- escaping mechanisms, is interpreted as having been added by this
-- special concatenation process to designate where the boundaries
-- are between the original, un-concatenated list of strings.  These
-- added whitespace characters are removed from the output.
--
-- > unescapeArgs "hello\\ \\\"world\\\"\n" == escapeArgs "hello \"world\""
unescapeArgs :: String -> [String]
unescapeArgs = filter (not . null) . unescape

-- | Given a list of strings, concatenate them into a single string
-- with escaping of certain characters, and the addition of a newline
-- between each string.  The escaping is done by adding a single
-- backslash character before any whitespace, single quote, double
-- quote, or backslash character, so this escaping character must be
-- removed.  Unescaped whitespace (in this case, newline) is part
-- of this "transport" format to indicate the end of the previous
-- string and the start of a new string.
--
-- While 'unescapeArgs' allows using quoting (i.e., convenient
-- escaping of many characters) by having matching sets of single- or
-- double-quotes,'escapeArgs' does not use the quoting mechasnism,
-- and thus will always escape any whitespace, quotes, and
-- backslashes.
--
-- > unescapeArgs "hello\\ \\\"world\\\"\\n" == escapeArgs "hello \"world\""
escapeArgs :: [String] -> String
escapeArgs = unlines . map escapeArg

-- | Arguments which look like @\@foo@ will be replaced with the
-- contents of file @foo@. A gcc-like syntax for response files arguments
-- is expected.  This must re-constitute the argument list by doing an
-- inverse of the escaping mechanism done by the calling-program side.
--
-- We quit if the file is not found or reading somehow fails.
-- (A convenience routine for haddock or possibly other clients)
expandResponse :: [String] -> IO [String]
expandResponse = fmap concat . mapM expand
  where
    expand :: String -> IO [String]
    expand ('@':f) = readFileExc f >>= return . unescapeArgs
    expand x = return [x]

    readFileExc f =
      readFile f `catch` \(e :: IOException) -> do
        hPutStrLn stderr $ "Error while expanding response file: " ++ show e
        exitFailure

data Quoting = NoneQ | SngQ | DblQ

unescape :: String -> [String]
unescape args = reverse . map reverse $ go args NoneQ False [] []
    where
      -- n.b., the order of these cases matters; these are cribbed from gcc
      -- case 1: end of input
      go []     _q    _bs   a as = a:as
      -- case 2: back-slash escape in progress
      go (c:cs) q     True  a as = go cs q     False (c:a) as
      -- case 3: no back-slash escape in progress, but got a back-slash
      go (c:cs) q     False a as
        | '\\' == c              = go cs q     True  a     as
      -- case 4: single-quote escaping in progress
      go (c:cs) SngQ  False a as
        | '\'' == c              = go cs NoneQ False a     as
        | otherwise              = go cs SngQ  False (c:a) as
      -- case 5: double-quote escaping in progress
      go (c:cs) DblQ  False a as
        | '"' == c               = go cs NoneQ False a     as
        | otherwise              = go cs DblQ  False (c:a) as
      -- case 6: no escaping is in progress
      go (c:cs) NoneQ False a as
        | isSpace c              = go cs NoneQ False []    (a:as)
        | '\'' == c              = go cs SngQ  False a     as
        | '"'  == c              = go cs DblQ  False a     as
        | otherwise              = go cs NoneQ False (c:a) as

escapeArg :: String -> String
escapeArg = reverse . foldl' escape []

escape :: String -> Char -> String
escape cs c
  |    isSpace c
    || '\\' == c
    || '\'' == c
    || '"'  == c = c:'\\':cs -- n.b., our caller must reverse the result
  | otherwise    = c:cs


{-# LANGUAGE Trustworthy #-}
{-# LANGUAGE CPP, NoImplicitPrelude, BangPatterns, StandaloneDeriving,
             MagicHash, UnboxedTuples #-}
{-# OPTIONS_HADDOCK not-home #-}

#include "MachDeps.h"
#if SIZEOF_HSWORD == 4
#define DIGITS       9
#define BASE         1000000000
#elif SIZEOF_HSWORD == 8
#define DIGITS       18
#define BASE         1000000000000000000
#else
#error Please define DIGITS and BASE
-- DIGITS should be the largest integer such that
--     10^DIGITS < 2^(SIZEOF_HSWORD * 8 - 1)
-- BASE should be 10^DIGITS. Note that ^ is not available yet.
#endif

-----------------------------------------------------------------------------
-- |
-- Module      :  GHC.Show
-- Copyright   :  (c) The University of Glasgow, 1992-2002
-- License     :  see libraries/base/LICENSE
--
-- Maintainer  :  cvs-ghc@haskell.org
-- Stability   :  internal
-- Portability :  non-portable (GHC Extensions)
--
-- The 'Show' class, and related operations.
--
-----------------------------------------------------------------------------

module GHC.Show
        (
        Show(..), ShowS,

        -- Instances for Show: (), [], Bool, Ordering, Int, Char

        -- Show support code
        shows, showChar, showString, showMultiLineString,
        showParen, showList__, showCommaSpace, showSpace,
        showLitChar, showLitString, protectEsc,
        intToDigit, showSignedInt,
        appPrec, appPrec1,

        -- Character operations
        asciiTab,
  )
        where

import GHC.Base
import GHC.List ((!!), foldr1, break)
import GHC.Num
import GHC.Stack.Types

-- | The @shows@ functions return a function that prepends the
-- output 'String' to an existing 'String'.  This allows constant-time
-- concatenation of results using function composition.
type ShowS = String -> String

-- | Conversion of values to readable 'String's.
--
-- Derived instances of 'Show' have the following properties, which
-- are compatible with derived instances of 'Text.Read.Read':
--
-- * The result of 'show' is a syntactically correct Haskell
--   expression containing only constants, given the fixity
--   declarations in force at the point where the type is declared.
--   It contains only the constructor names defined in the data type,
--   parentheses, and spaces.  When labelled constructor fields are
--   used, braces, commas, field names, and equal signs are also used.
--
-- * If the constructor is defined to be an infix operator, then
--   'showsPrec' will produce infix applications of the constructor.
--
-- * the representation will be enclosed in parentheses if the
--   precedence of the top-level constructor in @x@ is less than @d@
--   (associativity is ignored).  Thus, if @d@ is @0@ then the result
--   is never surrounded in parentheses; if @d@ is @11@ it is always
--   surrounded in parentheses, unless it is an atomic expression.
--
-- * If the constructor is defined using record syntax, then 'show'
--   will produce the record-syntax form, with the fields given in the
--   same order as the original declaration.
--
-- For example, given the declarations
--
-- > infixr 5 :^:
-- > data Tree a =  Leaf a  |  Tree a :^: Tree a
--
-- the derived instance of 'Show' is equivalent to
--
-- > instance (Show a) => Show (Tree a) where
-- >
-- >        showsPrec d (Leaf m) = showParen (d > app_prec) $
-- >             showString "Leaf " . showsPrec (app_prec+1) m
-- >          where app_prec = 10
-- >
-- >        showsPrec d (u :^: v) = showParen (d > up_prec) $
-- >             showsPrec (up_prec+1) u .
-- >             showString " :^: "      .
-- >             showsPrec (up_prec+1) v
-- >          where up_prec = 5
--
-- Note that right-associativity of @:^:@ is ignored.  For example,
--
-- * @'show' (Leaf 1 :^: Leaf 2 :^: Leaf 3)@ produces the string
--   @\"Leaf 1 :^: (Leaf 2 :^: Leaf 3)\"@.

class  Show a  where
    {-# MINIMAL showsPrec | show #-}

    -- | Convert a value to a readable 'String'.
    --
    -- 'showsPrec' should satisfy the law
    --
    -- > showsPrec d x r ++ s  ==  showsPrec d x (r ++ s)
    --
    -- Derived instances of 'Text.Read.Read' and 'Show' satisfy the following:
    --
    -- * @(x,\"\")@ is an element of
    --   @('Text.Read.readsPrec' d ('showsPrec' d x \"\"))@.
    --
    -- That is, 'Text.Read.readsPrec' parses the string produced by
    -- 'showsPrec', and delivers the value that 'showsPrec' started with.

    showsPrec :: Int    -- ^ the operator precedence of the enclosing
                        -- context (a number from @0@ to @11@).
                        -- Function application has precedence @10@.
              -> a      -- ^ the value to be converted to a 'String'
              -> ShowS

    -- | A specialised variant of 'showsPrec', using precedence context
    -- zero, and returning an ordinary 'String'.
    show      :: a   -> String

    -- | The method 'showList' is provided to allow the programmer to
    -- give a specialised way of showing lists of values.
    -- For example, this is used by the predefined 'Show' instance of
    -- the 'Char' type, where values of type 'String' should be shown
    -- in double quotes, rather than between square brackets.
    showList  :: [a] -> ShowS

    showsPrec _ x s = show x ++ s
    show x          = shows x ""
    showList ls   s = showList__ shows ls s

showList__ :: (a -> ShowS) ->  [a] -> ShowS
showList__ _     []     s = "[]" ++ s
showList__ showx (x:xs) s = '[' : showx x (showl xs)
  where
    showl []     = ']' : s
    showl (y:ys) = ',' : showx y (showl ys)

appPrec, appPrec1 :: Int
        -- Use unboxed stuff because we don't have overloaded numerics yet
appPrec = I# 10#        -- Precedence of application:
                        --   one more than the maximum operator precedence of 9
appPrec1 = I# 11#       -- appPrec + 1

--------------------------------------------------------------
-- Simple Instances
--------------------------------------------------------------

-- | @since 2.01
deriving instance Show ()

-- | @since 2.01
instance Show a => Show [a]  where
  {-# SPECIALISE instance Show [String] #-}
  {-# SPECIALISE instance Show [Char] #-}
  {-# SPECIALISE instance Show [Int] #-}
  showsPrec _         = showList

-- | @since 2.01
deriving instance Show Bool

-- | @since 2.01
deriving instance Show Ordering

-- | @since 2.01
instance  Show Char  where
    showsPrec _ '\'' = showString "'\\''"
    showsPrec _ c    = showChar '\'' . showLitChar c . showChar '\''

    showList cs = showChar '"' . showLitString cs . showChar '"'

-- | @since 2.01
instance Show Int where
    showsPrec = showSignedInt

-- | @since 2.01
instance Show Word where
    showsPrec _ (W# w) = showWord w

showWord :: Word# -> ShowS
showWord w# cs
 | isTrue# (w# `ltWord#` 10##) = C# (chr# (ord# '0'# +# word2Int# w#)) : cs
 | otherwise = case chr# (ord# '0'# +# word2Int# (w# `remWord#` 10##)) of
               c# ->
                   showWord (w# `quotWord#` 10##) (C# c# : cs)

-- | @since 2.01
deriving instance Show a => Show (Maybe a)

-- | @since 4.11.0.0
deriving instance Show a => Show (NonEmpty a)

-- | @since 2.01
instance Show TyCon where
  showsPrec p (TyCon _ _ _ tc_name _ _) = showsPrec p tc_name

-- | @since 4.9.0.0
instance Show TrName where
  showsPrec _ (TrNameS s) = showString (unpackCStringUtf8# s)
  showsPrec _ (TrNameD s) = showString s

-- | @since 4.9.0.0
instance Show Module where
  showsPrec _ (Module p m) = shows p . (':' :) . shows m

-- | @since 4.9.0.0
instance Show CallStack where
  showsPrec _ = shows . getCallStack

-- | @since 4.9.0.0
deriving instance Show SrcLoc

--------------------------------------------------------------
-- Show instances for the first few tuple
--------------------------------------------------------------

-- The explicit 's' parameters are important
-- Otherwise GHC thinks that "shows x" might take a lot of work to compute
-- and generates defns like
--      showsPrec _ (x,y) = let sx = shows x; sy = shows y in
--                          \s -> showChar '(' (sx (showChar ',' (sy (showChar ')' s))))

-- | @since 2.01
instance  (Show a, Show b) => Show (a,b)  where
  showsPrec _ (a,b) s = show_tuple [shows a, shows b] s

-- | @since 2.01
instance (Show a, Show b, Show c) => Show (a, b, c) where
  showsPrec _ (a,b,c) s = show_tuple [shows a, shows b, shows c] s

-- | @since 2.01
instance (Show a, Show b, Show c, Show d) => Show (a, b, c, d) where
  showsPrec _ (a,b,c,d) s = show_tuple [shows a, shows b, shows c, shows d] s

-- | @since 2.01
instance (Show a, Show b, Show c, Show d, Show e) => Show (a, b, c, d, e) where
  showsPrec _ (a,b,c,d,e) s = show_tuple [shows a, shows b, shows c, shows d, shows e] s

-- | @since 2.01
instance (Show a, Show b, Show c, Show d, Show e, Show f) => Show (a,b,c,d,e,f) where
  showsPrec _ (a,b,c,d,e,f) s = show_tuple [shows a, shows b, shows c, shows d, shows e, shows f] s

-- | @since 2.01
instance (Show a, Show b, Show c, Show d, Show e, Show f, Show g)
        => Show (a,b,c,d,e,f,g) where
  showsPrec _ (a,b,c,d,e,f,g) s
        = show_tuple [shows a, shows b, shows c, shows d, shows e, shows f, shows g] s

-- | @since 2.01
instance (Show a, Show b, Show c, Show d, Show e, Show f, Show g, Show h)
         => Show (a,b,c,d,e,f,g,h) where
  showsPrec _ (a,b,c,d,e,f,g,h) s
        = show_tuple [shows a, shows b, shows c, shows d, shows e, shows f, shows g, shows h] s

-- | @since 2.01
instance (Show a, Show b, Show c, Show d, Show e, Show f, Show g, Show h, Show i)
         => Show (a,b,c,d,e,f,g,h,i) where
  showsPrec _ (a,b,c,d,e,f,g,h,i) s
        = show_tuple [shows a, shows b, shows c, shows d, shows e, shows f, shows g, shows h,
                      shows i] s

-- | @since 2.01
instance (Show a, Show b, Show c, Show d, Show e, Show f, Show g, Show h, Show i, Show j)
         => Show (a,b,c,d,e,f,g,h,i,j) where
  showsPrec _ (a,b,c,d,e,f,g,h,i,j) s
        = show_tuple [shows a, shows b, shows c, shows d, shows e, shows f, shows g, shows h,
                      shows i, shows j] s

-- | @since 2.01
instance (Show a, Show b, Show c, Show d, Show e, Show f, Show g, Show h, Show i, Show j, Show k)
         => Show (a,b,c,d,e,f,g,h,i,j,k) where
  showsPrec _ (a,b,c,d,e,f,g,h,i,j,k) s
        = show_tuple [shows a, shows b, shows c, shows d, shows e, shows f, shows g, shows h,
                      shows i, shows j, shows k] s

-- | @since 2.01
instance (Show a, Show b, Show c, Show d, Show e, Show f, Show g, Show h, Show i, Show j, Show k,
          Show l)
         => Show (a,b,c,d,e,f,g,h,i,j,k,l) where
  showsPrec _ (a,b,c,d,e,f,g,h,i,j,k,l) s
        = show_tuple [shows a, shows b, shows c, shows d, shows e, shows f, shows g, shows h,
                      shows i, shows j, shows k, shows l] s

-- | @since 2.01
instance (Show a, Show b, Show c, Show d, Show e, Show f, Show g, Show h, Show i, Show j, Show k,
          Show l, Show m)
         => Show (a,b,c,d,e,f,g,h,i,j,k,l,m) where
  showsPrec _ (a,b,c,d,e,f,g,h,i,j,k,l,m) s
        = show_tuple [shows a, shows b, shows c, shows d, shows e, shows f, shows g, shows h,
                      shows i, shows j, shows k, shows l, shows m] s

-- | @since 2.01
instance (Show a, Show b, Show c, Show d, Show e, Show f, Show g, Show h, Show i, Show j, Show k,
          Show l, Show m, Show n)
         => Show (a,b,c,d,e,f,g,h,i,j,k,l,m,n) where
  showsPrec _ (a,b,c,d,e,f,g,h,i,j,k,l,m,n) s
        = show_tuple [shows a, shows b, shows c, shows d, shows e, shows f, shows g, shows h,
                      shows i, shows j, shows k, shows l, shows m, shows n] s

-- | @since 2.01
instance (Show a, Show b, Show c, Show d, Show e, Show f, Show g, Show h, Show i, Show j, Show k,
          Show l, Show m, Show n, Show o)
         => Show (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o) where
  showsPrec _ (a,b,c,d,e,f,g,h,i,j,k,l,m,n,o) s
        = show_tuple [shows a, shows b, shows c, shows d, shows e, shows f, shows g, shows h,
                      shows i, shows j, shows k, shows l, shows m, shows n, shows o] s

show_tuple :: [ShowS] -> ShowS
show_tuple ss = showChar '('
              . foldr1 (\s r -> s . showChar ',' . r) ss
              . showChar ')'

--------------------------------------------------------------
-- Support code for Show
--------------------------------------------------------------

-- | equivalent to 'showsPrec' with a precedence of 0.
shows           :: (Show a) => a -> ShowS
shows           =  showsPrec 0

-- | utility function converting a 'Char' to a show function that
-- simply prepends the character unchanged.
showChar        :: Char -> ShowS
showChar        =  (:)

-- | utility function converting a 'String' to a show function that
-- simply prepends the string unchanged.
showString      :: String -> ShowS
showString      =  (++)

-- | utility function that surrounds the inner show function with
-- parentheses when the 'Bool' parameter is 'True'.
showParen       :: Bool -> ShowS -> ShowS
showParen b p   =  if b then showChar '(' . p . showChar ')' else p

showSpace :: ShowS
showSpace = {-showChar ' '-} \ xs -> ' ' : xs

showCommaSpace :: ShowS
showCommaSpace = showString ", "
-- Code specific for characters

-- | Convert a character to a string using only printable characters,
-- using Haskell source-language escape conventions.  For example:
--
-- > showLitChar '\n' s  =  "\\n" ++ s
--
showLitChar                :: Char -> ShowS
showLitChar c s | c > '\DEL' =  showChar '\\' (protectEsc isDec (shows (ord c)) s)
showLitChar '\DEL'         s =  showString "\\DEL" s
showLitChar '\\'           s =  showString "\\\\" s
showLitChar c s | c >= ' '   =  showChar c s
showLitChar '\a'           s =  showString "\\a" s
showLitChar '\b'           s =  showString "\\b" s
showLitChar '\f'           s =  showString "\\f" s
showLitChar '\n'           s =  showString "\\n" s
showLitChar '\r'           s =  showString "\\r" s
showLitChar '\t'           s =  showString "\\t" s
showLitChar '\v'           s =  showString "\\v" s
showLitChar '\SO'          s =  protectEsc (== 'H') (showString "\\SO") s
showLitChar c              s =  showString ('\\' : asciiTab!!ord c) s
        -- I've done manual eta-expansion here, because otherwise it's
        -- impossible to stop (asciiTab!!ord) getting floated out as an MFE

showLitString :: String -> ShowS
-- | Same as 'showLitChar', but for strings
-- It converts the string to a string using Haskell escape conventions
-- for non-printable characters. Does not add double-quotes around the
-- whole thing; the caller should do that.
-- The main difference from showLitChar (apart from the fact that the
-- argument is a string not a list) is that we must escape double-quotes
showLitString []         s = s
showLitString ('"' : cs) s = showString "\\\"" (showLitString cs s)
showLitString (c   : cs) s = showLitChar c (showLitString cs s)
   -- Making 's' an explicit parameter makes it clear to GHC that
   -- showLitString has arity 2, which avoids it allocating an extra lambda
   -- The sticking point is the recursive call to (showLitString cs), which
   -- it can't figure out would be ok with arity 2.

showMultiLineString :: String -> [String]
-- | Like 'showLitString' (expand escape characters using Haskell
-- escape conventions), but
--   * break the string into multiple lines
--   * wrap the entire thing in double quotes
-- Example:  @showMultiLineString "hello\ngoodbye\nblah"@
-- returns   @["\"hello\\n\\", "\\goodbye\n\\", "\\blah\""]@
showMultiLineString str
  = go '\"' str
  where
    go ch s = case break (== '\n') s of
                (l, _:s'@(_:_)) -> (ch : showLitString l "\\n\\") : go '\\' s'
                (l, "\n")       -> [ch : showLitString l "\\n\""]
                (l, _)          -> [ch : showLitString l "\""]

isDec :: Char -> Bool
isDec c = c >= '0' && c <= '9'

protectEsc :: (Char -> Bool) -> ShowS -> ShowS
protectEsc p f             = f . cont
                             where cont s@(c:_) | p c = "\\&" ++ s
                                   cont s             = s

asciiTab :: [String]
asciiTab = -- Using an array drags in the array module.  listArray ('\NUL', ' ')
           ["NUL", "SOH", "STX", "ETX", "EOT", "ENQ", "ACK", "BEL",
            "BS",  "HT",  "LF",  "VT",  "FF",  "CR",  "SO",  "SI",
            "DLE", "DC1", "DC2", "DC3", "DC4", "NAK", "SYN", "ETB",
            "CAN", "EM",  "SUB", "ESC", "FS",  "GS",  "RS",  "US",
            "SP"]

-- Code specific for Ints.

-- | Convert an 'Int' in the range @0@..@15@ to the corresponding single
-- digit 'Char'.  This function fails on other inputs, and generates
-- lower-case hexadecimal digits.
intToDigit :: Int -> Char
intToDigit (I# i)
    | isTrue# (i >=# 0#)  && isTrue# (i <=#  9#) = unsafeChr (ord '0' + I# i)
    | isTrue# (i >=# 10#) && isTrue# (i <=# 15#) = unsafeChr (ord 'a' + I# i - 10)
    | otherwise =  errorWithoutStackTrace ("Char.intToDigit: not a digit " ++ show (I# i))

showSignedInt :: Int -> Int -> ShowS
showSignedInt (I# p) (I# n) r
    | isTrue# (n <# 0#) && isTrue# (p ># 6#) = '(' : itos n (')' : r)
    | otherwise                              = itos n r

itos :: Int# -> String -> String
itos n# cs
    | isTrue# (n# <# 0#) =
        let !(I# minInt#) = minInt in
        if isTrue# (n# ==# minInt#)
                -- negateInt# minInt overflows, so we can't do that:
           then '-' : (case n# `quotRemInt#` 10# of
                       (# q, r #) ->
                           itos' (negateInt# q) (itos' (negateInt# r) cs))
           else '-' : itos' (negateInt# n#) cs
    | otherwise = itos' n# cs
    where
    itos' :: Int# -> String -> String
    itos' x# cs'
        | isTrue# (x# <# 10#) = C# (chr# (ord# '0'# +# x#)) : cs'
        | otherwise = case x# `quotRemInt#` 10# of
                      (# q, r #) ->
                          case chr# (ord# '0'# +# r) of
                          c# ->
                              itos' q (C# c# : cs')

--------------------------------------------------------------
-- The Integer instances for Show
--------------------------------------------------------------

-- | @since 2.01
instance Show Integer where
    showsPrec p n r
        | p > 6 && n < 0 = '(' : integerToString n (')' : r)
        -- Minor point: testing p first gives better code
        -- in the not-uncommon case where the p argument
        -- is a constant
        | 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
    | n0 < 0    = '-' : integerToString' (- n0) cs0
    | otherwise = integerToString' n0 cs0
    where
    integerToString' :: Integer -> String -> String
    integerToString' n cs
        | n < BASE  = jhead (fromInteger n) cs
        | otherwise = jprinth (jsplitf (BASE*BASE) n) cs

    -- Split n into digits in base p. We first split n into digits
    -- in base p*p and then split each of these digits into two.
    -- Note that the first 'digit' modulo p*p may have a leading zero
    -- in base p that we need to drop - this is what jsplith takes care of.
    -- jsplitb the handles the remaining digits.
    jsplitf :: Integer -> Integer -> [Integer]
    jsplitf p n
        | p > n     = [n]
        | otherwise = jsplith p (jsplitf (p*p) n)

    jsplith :: Integer -> [Integer] -> [Integer]
    jsplith p (n:ns) =
        case n `quotRemInteger` p of
        (# q, r #) ->
            if q > 0 then q : r : jsplitb p ns
                     else     r : jsplitb p ns
    jsplith _ [] = errorWithoutStackTrace "jsplith: []"

    jsplitb :: Integer -> [Integer] -> [Integer]
    jsplitb _ []     = []
    jsplitb p (n:ns) = case n `quotRemInteger` p of
                       (# q, r #) ->
                           q : r : jsplitb p ns

    -- Convert a number that has been split into digits in base BASE^2
    -- this includes a last splitting step and then conversion of digits
    -- that all fit into a machine word.
    jprinth :: [Integer] -> String -> String
    jprinth (n:ns) cs =
        case n `quotRemInteger` BASE of
        (# q', r' #) ->
            let q = fromInteger q'
                r = fromInteger r'
            in if q > 0 then jhead q $ jblock r $ jprintb ns cs
                        else jhead r $ jprintb ns cs
    jprinth [] _ = errorWithoutStackTrace "jprinth []"

    jprintb :: [Integer] -> String -> String
    jprintb []     cs = cs
    jprintb (n:ns) cs = case n `quotRemInteger` BASE of
                        (# q', r' #) ->
                            let q = fromInteger q'
                                r = fromInteger r'
                            in jblock q $ jblock r $ jprintb ns cs

    -- Convert an integer that fits into a machine word. Again, we have two
    -- functions, one that drops leading zeros (jhead) and one that doesn't
    -- (jblock)
    jhead :: Int -> String -> String
    jhead n cs
        | n < 10    = case unsafeChr (ord '0' + n) of
            c@(C# _) -> c : cs
        | otherwise = case unsafeChr (ord '0' + r) of
            c@(C# _) -> jhead q (c : cs)
        where
        (q, r) = n `quotRemInt` 10

    jblock = jblock' {- ' -} DIGITS

    jblock' :: Int -> Int -> String -> String
    jblock' d n cs
        | d == 1    = case unsafeChr (ord '0' + n) of
             c@(C# _) -> c : cs
        | otherwise = case unsafeChr (ord '0' + r) of
             c@(C# _) -> jblock' (d - 1) q (c : cs)
        where
        (q, r) = n `quotRemInt` 10

instance Show KindRep where
  showsPrec d (KindRepVar v) = showParen (d > 10) $
    showString "KindRepVar " . showsPrec 11 v
  showsPrec d (KindRepTyConApp p q) = showParen (d > 10) $
    showString "KindRepTyConApp "
      . showsPrec 11 p
      . showString " "
      . showsPrec 11 q
  showsPrec d (KindRepApp p q) = showParen (d > 10) $
    showString "KindRepApp "
      . showsPrec 11 p
      . showString " "
      . showsPrec 11 q
  showsPrec d (KindRepFun p q) = showParen (d > 10) $
    showString "KindRepFun "
      . showsPrec 11 p
      . showString " "
      . showsPrec 11 q
  showsPrec d (KindRepTYPE rep) = showParen (d > 10) $
    showString "KindRepTYPE " . showsPrec 11 rep
  showsPrec d (KindRepTypeLitS p q) = showParen (d > 10) $
    showString "KindRepTypeLitS "
      . showsPrec 11 p
      . showString " "
      . showsPrec 11 (unpackCString# q)
  showsPrec d (KindRepTypeLitD p q) = showParen (d > 10) $
    showString "KindRepTypeLitD "
      . showsPrec 11 p
      . showString " "
      . showsPrec 11 q

-- | @since 4.11.0.0
deriving instance Show RuntimeRep

-- | @since 4.11.0.0
deriving instance Show VecCount

-- | @since 4.11.0.0
deriving instance Show VecElem

-- | @since 4.11.0.0
deriving instance Show TypeLitSort


{-# LANGUAGE Unsafe #-}
{-# LANGUAGE NoImplicitPrelude, MagicHash, UnboxedTuples, RankNTypes #-}
{-# OPTIONS_HADDOCK not-home #-}

-----------------------------------------------------------------------------
-- |
-- Module      :  GHC.ST
-- Copyright   :  (c) The University of Glasgow, 1992-2002
-- License     :  see libraries/base/LICENSE
--
-- Maintainer  :  cvs-ghc@haskell.org
-- Stability   :  internal
-- Portability :  non-portable (GHC Extensions)
--
-- The 'ST' Monad.
--
-----------------------------------------------------------------------------

module GHC.ST (
        ST(..), STret(..), STRep,
        runST,

        -- * Unsafe functions
        liftST, unsafeInterleaveST, unsafeDupableInterleaveST
    ) where

import GHC.Base
import GHC.Show
import qualified Control.Monad.Fail as Fail

default ()

-- The 'ST' monad proper.  By default the monad is strict;
-- too many people got bitten by space leaks when it was lazy.

-- | The strict 'ST' monad.
-- The 'ST' monad allows for destructive updates, but is escapable (unlike IO).
-- A computation of type @'ST' s a@ returns a value of type @a@, and
-- execute in "thread" @s@. The @s@ parameter is either
--
-- * an uninstantiated type variable (inside invocations of 'runST'), or
--
-- * 'RealWorld' (inside invocations of 'Control.Monad.ST.stToIO').
--
-- It serves to keep the internal states of different invocations
-- of 'runST' separate from each other and from invocations of
-- 'Control.Monad.ST.stToIO'.
--
-- The '>>=' and '>>' operations are strict in the state (though not in
-- values stored in the state).  For example,
--
-- @'runST' (writeSTRef _|_ v >>= f) = _|_@
newtype ST s a = ST (STRep s a)
type STRep s a = State# s -> (# State# s, a #)

-- | @since 2.01
instance Functor (ST s) where
    fmap f (ST m) = ST $ \ s ->
      case (m s) of { (# new_s, r #) ->
      (# new_s, f r #) }

-- | @since 4.4.0.0
instance Applicative (ST s) where
    {-# INLINE pure #-}
    {-# INLINE (*>)   #-}
    pure x = ST (\ s -> (# s, x #))
    m *> k = m >>= \ _ -> k
    (<*>) = ap
    liftA2 = liftM2

-- | @since 2.01
instance Monad (ST s) where
    {-# INLINE (>>=)  #-}
    (>>) = (*>)
    (ST m) >>= k
      = ST (\ s ->
        case (m s) of { (# new_s, r #) ->
        case (k r) of { ST k2 ->
        (k2 new_s) }})

-- | @since 4.11.0.0
instance Fail.MonadFail (ST s) where
    fail s = errorWithoutStackTrace s

-- | @since 4.11.0.0
instance Semigroup a => Semigroup (ST s a) where
    (<>) = liftA2 (<>)

-- | @since 4.11.0.0
instance Monoid a => Monoid (ST s a) where
    mempty = pure mempty

data STret s a = STret (State# s) a

-- liftST is useful when we want a lifted result from an ST computation.
liftST :: ST s a -> State# s -> STret s a
liftST (ST m) = \s -> case m s of (# s', r #) -> STret s' r

noDuplicateST :: ST s ()
noDuplicateST = ST $ \s -> (# noDuplicate# s, () #)

-- | 'unsafeInterleaveST' allows an 'ST' computation to be deferred
-- lazily.  When passed a value of type @ST a@, the 'ST' computation will
-- only be performed when the value of the @a@ is demanded.
{-# INLINE unsafeInterleaveST #-}
unsafeInterleaveST :: ST s a -> ST s a
unsafeInterleaveST m = unsafeDupableInterleaveST (noDuplicateST >> m)

-- | 'unsafeDupableInterleaveST' allows an 'ST' computation to be deferred
-- lazily.  When passed a value of type @ST a@, the 'ST' computation will
-- only be performed when the value of the @a@ is demanded.
--
-- The computation may be performed multiple times by different threads,
-- possibly at the same time. To prevent this, use 'unsafeInterleaveST' instead.
--
-- @since 4.11
{-# NOINLINE unsafeDupableInterleaveST #-}
-- See Note [unsafeDupableInterleaveIO should not be inlined]
-- in GHC.IO.Unsafe
unsafeDupableInterleaveST :: ST s a -> ST s a
unsafeDupableInterleaveST (ST m) = ST ( \ s ->
    let
        r = case m s of (# _, res #) -> res
    in
    (# s, r #)
  )

-- | @since 2.01
instance  Show (ST s a)  where
    showsPrec _ _  = showString "<<ST action>>"
    showList       = showList__ (showsPrec 0)

{-# INLINE runST #-}
-- | Return the value computed by a state thread.
-- The @forall@ ensures that the internal state used by the 'ST'
-- computation is inaccessible to the rest of the program.
runST :: (forall s. ST s a) -> a
runST (ST st_rep) = case runRW# st_rep of (# _, a #) -> a
-- See Note [Definition of runRW#] in GHC.Magic


{-# LANGUAGE Unsafe #-}
{-# LANGUAGE NoImplicitPrelude
           , MagicHash
           , UnboxedTuples
  #-}
{-# OPTIONS_HADDOCK not-home #-}

-----------------------------------------------------------------------------
-- |
-- Module      :  GHC.Stable
-- Copyright   :  (c) The University of Glasgow, 1992-2004
-- License     :  see libraries/base/LICENSE
--
-- Maintainer  :  ffi@haskell.org
-- Stability   :  internal
-- Portability :  non-portable (GHC Extensions)
--
-- Stable pointers.
--
-----------------------------------------------------------------------------

module GHC.Stable (
        StablePtr(..),
        newStablePtr,
        deRefStablePtr,
        freeStablePtr,
        castStablePtrToPtr,
        castPtrToStablePtr
    ) where

import GHC.Ptr
import GHC.Base

-----------------------------------------------------------------------------
-- Stable Pointers

{- |
A /stable pointer/ is a reference to a Haskell expression that is
guaranteed not to be affected by garbage collection, i.e., it will neither be
deallocated nor will the value of the stable pointer itself change during
garbage collection (ordinary references may be relocated during garbage
collection).  Consequently, stable pointers can be passed to foreign code,
which can treat it as an opaque reference to a Haskell value.

A value of type @StablePtr a@ is a stable pointer to a Haskell
expression of type @a@.
-}
data {-# CTYPE "HsStablePtr" #-} StablePtr a = StablePtr (StablePtr# a)

-- |
-- Create a stable pointer referring to the given Haskell value.
--
newStablePtr   :: a -> IO (StablePtr a)
newStablePtr a = IO $ \ s ->
    case makeStablePtr# a s of (# s', sp #) -> (# s', StablePtr sp #)

-- |
-- Obtain the Haskell value referenced by a stable pointer, i.e., the
-- same value that was passed to the corresponding call to
-- 'newStablePtr'.  If the argument to 'deRefStablePtr' has
-- already been freed using 'freeStablePtr', the behaviour of
-- 'deRefStablePtr' is undefined.
--
deRefStablePtr :: StablePtr a -> IO a
deRefStablePtr (StablePtr sp) = IO $ \s -> deRefStablePtr# sp s

-- |
-- Dissolve the association between the stable pointer and the Haskell
-- value. Afterwards, if the stable pointer is passed to
-- 'deRefStablePtr' or 'freeStablePtr', the behaviour is
-- undefined.  However, the stable pointer may still be passed to
-- 'castStablePtrToPtr', but the @'Foreign.Ptr.Ptr' ()@ value returned
-- by 'castStablePtrToPtr', in this case, is undefined (in particular,
-- it may be 'Foreign.Ptr.nullPtr').  Nevertheless, the call
-- to 'castStablePtrToPtr' is guaranteed not to diverge.
--
foreign import ccall unsafe "hs_free_stable_ptr" freeStablePtr :: StablePtr a -> IO ()

-- |
-- Coerce a stable pointer to an address. No guarantees are made about
-- the resulting value, except that the original stable pointer can be
-- recovered by 'castPtrToStablePtr'.  In particular, the address may not
-- refer to an accessible memory location and any attempt to pass it to
-- the member functions of the class 'Foreign.Storable.Storable' leads to
-- undefined behaviour.
--
castStablePtrToPtr :: StablePtr a -> Ptr ()
castStablePtrToPtr (StablePtr s) = Ptr (unsafeCoerce# s)

-- |
-- The inverse of 'castStablePtrToPtr', i.e., we have the identity
--
-- > sp == castPtrToStablePtr (castStablePtrToPtr sp)
--
-- for any stable pointer @sp@ on which 'freeStablePtr' has
-- not been executed yet.  Moreover, 'castPtrToStablePtr' may
-- only be applied to pointers that have been produced by
-- 'castStablePtrToPtr'.
--
castPtrToStablePtr :: Ptr () -> StablePtr a
castPtrToStablePtr (Ptr a) = StablePtr (unsafeCoerce# a)

-- | @since 2.01
instance Eq (StablePtr a) where
    (StablePtr sp1) == (StablePtr sp2) =
        case eqStablePtr# sp1 sp2 of
           0# -> False
           _  -> True


{-# LANGUAGE Trustworthy #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE MagicHash #-}
{-# LANGUAGE UnboxedTuples #-}

-----------------------------------------------------------------------------
-- |
-- Module      :  System.Mem.StableName
-- Copyright   :  (c) The University of Glasgow 2001
-- License     :  BSD-style (see the file libraries/base/LICENSE)
--
-- Maintainer  :  libraries@haskell.org
-- Stability   :  experimental
-- Portability :  non-portable
--
-- Stable names are a way of performing fast (O(1)), not-quite-exact
-- comparison between objects.
--
-- Stable names solve the following problem: suppose you want to build
-- a hash table with Haskell objects as keys, but you want to use
-- pointer equality for comparison; maybe because the keys are large
-- and hashing would be slow, or perhaps because the keys are infinite
-- in size.  We can\'t build a hash table using the address of the
-- object as the key, because objects get moved around by the garbage
-- collector, meaning a re-hash would be necessary after every garbage
-- collection.
--
-------------------------------------------------------------------------------

module GHC.StableName (
  -- * Stable Names
  StableName (..),
  makeStableName,
  hashStableName,
  eqStableName
  ) where

import GHC.IO           ( IO(..) )
import GHC.Base         ( Int(..), StableName#, makeStableName#
                        , eqStableName#, stableNameToInt# )

-----------------------------------------------------------------------------
-- Stable Names

{-|
  An abstract name for an object, that supports equality and hashing.

  Stable names have the following property:

  * If @sn1 :: StableName@ and @sn2 :: StableName@ and @sn1 == sn2@
   then @sn1@ and @sn2@ were created by calls to @makeStableName@ on
   the same object.

  The reverse is not necessarily true: if two stable names are not
  equal, then the objects they name may still be equal.  Note in particular
  that `makeStableName` may return a different `StableName` after an
  object is evaluated.

  Stable Names are similar to Stable Pointers ("Foreign.StablePtr"),
  but differ in the following ways:

  * There is no @freeStableName@ operation, unlike "Foreign.StablePtr"s.
    Stable names are reclaimed by the runtime system when they are no
    longer needed.

  * There is no @deRefStableName@ operation.  You can\'t get back from
    a stable name to the original Haskell object.  The reason for
    this is that the existence of a stable name for an object does not
    guarantee the existence of the object itself; it can still be garbage
    collected.
-}

data StableName a = StableName (StableName# a)

-- | Makes a 'StableName' for an arbitrary object.  The object passed as
-- the first argument is not evaluated by 'makeStableName'.
makeStableName  :: a -> IO (StableName a)
makeStableName a = IO $ \ s ->
    case makeStableName# a s of (# s', sn #) -> (# s', StableName sn #)

-- | Convert a 'StableName' to an 'Int'.  The 'Int' returned is not
-- necessarily unique; several 'StableName's may map to the same 'Int'
-- (in practice however, the chances of this are small, so the result
-- of 'hashStableName' makes a good hash key).
hashStableName :: StableName a -> Int
hashStableName (StableName sn) = I# (stableNameToInt# sn)

-- | @since 2.01
instance Eq (StableName a) where
    (StableName sn1) == (StableName sn2) =
       case eqStableName# sn1 sn2 of
         0# -> False
         _  -> True

-- | Equality on 'StableName' that does not require that the types of
-- the arguments match.
--
-- @since 4.7.0.0
eqStableName :: StableName a -> StableName b -> Bool
eqStableName (StableName sn1) (StableName sn2) =
       case eqStableName# sn1 sn2 of
         0# -> False
         _  -> True
  -- Requested by Emil Axelsson on glasgow-haskell-users, who wants to
  -- use it for implementing observable sharing.