{-# LANGUAGE Trustworthy #-}
{-# LANGUAGE CPP, NoImplicitPrelude, ScopedTypeVariables, MagicHash #-}
{-# LANGUAGE BangPatterns #-}

-----------------------------------------------------------------------------
-- |
-- Module      :  GHC.List
-- 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 List data type and its operations
--
-----------------------------------------------------------------------------

module GHC.List (
   -- [] (..),          -- built-in syntax; can't be used in export list

   map, (++), filter, concat,
   head, last, tail, init, uncons, null, length, (!!),
   foldl, foldl', foldl1, foldl1', scanl, scanl1, scanl', foldr, foldr1,
   scanr, scanr1, iterate, iterate', repeat, replicate, cycle,
   take, drop, sum, product, maximum, minimum, splitAt, takeWhile, dropWhile,
   span, break, reverse, and, or,
   any, all, elem, notElem, lookup,
   concatMap,
   zip, zip3, zipWith, zipWith3, unzip, unzip3,
   errorEmptyList,

 ) where

import Data.Maybe
import GHC.Base
import GHC.Num (Num(..))
import GHC.Integer (Integer)

infixl 9  !!
infix  4 `elem`, `notElem`

--------------------------------------------------------------
-- List-manipulation functions
--------------------------------------------------------------

-- | /O(1)/. Extract the first element of a list, which must be non-empty.
head                    :: [a] -> a
head (x:_)              =  x
head []                 =  badHead
{-# NOINLINE [1] head #-}

badHead :: a
badHead = errorEmptyList "head"

-- This rule is useful in cases like
--      head [y | (x,y) <- ps, x==t]
{-# RULES
"head/build"    forall (g::forall b.(a->b->b)->b->b) .
                head (build g) = g (\x _ -> x) badHead
"head/augment"  forall xs (g::forall b. (a->b->b) -> b -> b) .
                head (augment g xs) = g (\x _ -> x) (head xs)
 #-}

-- | /O(1)/. Decompose a list into its head and tail. If the list is empty,
-- returns 'Nothing'. If the list is non-empty, returns @'Just' (x, xs)@,
-- where @x@ is the head of the list and @xs@ its tail.
--
-- @since 4.8.0.0
uncons                  :: [a] -> Maybe (a, [a])
uncons []               = Nothing
uncons (x:xs)           = Just (x, xs)

-- | /O(1)/. Extract the elements after the head of a list, which must be
-- non-empty.
tail                    :: [a] -> [a]
tail (_:xs)             =  xs
tail []                 =  errorEmptyList "tail"

-- | /O(n)/. Extract the last element of a list, which must be finite and
-- non-empty.
last                    :: [a] -> a
#if defined(USE_REPORT_PRELUDE)
last [x]                =  x
last (_:xs)             =  last xs
last []                 =  errorEmptyList "last"
#else
-- Use foldl to make last a good consumer.
-- This will compile to good code for the actual GHC.List.last.
-- (At least as long it is eta-expaned, otherwise it does not, #10260.)
last xs = foldl (\_ x -> x) lastError xs
{-# INLINE last #-}
-- The inline pragma is required to make GHC remember the implementation via
-- foldl.
lastError :: a
lastError = errorEmptyList "last"
#endif

-- | /O(n)/. Return all the elements of a list except the last one.
-- The list must be non-empty.
init                    :: [a] -> [a]
#if defined(USE_REPORT_PRELUDE)
init [x]                =  []
init (x:xs)             =  x : init xs
init []                 =  errorEmptyList "init"
#else
-- eliminate repeated cases
init []                 =  errorEmptyList "init"
init (x:xs)             =  init' x xs
  where init' _ []     = []
        init' y (z:zs) = y : init' z zs
#endif

-- | /O(1)/. Test whether a list is empty.
null                    :: [a] -> Bool
null []                 =  True
null (_:_)              =  False

-- | /O(n)/. 'length' returns the length of a finite list as an 'Int'.
-- It is an instance of the more general 'Data.List.genericLength',
-- the result type of which may be any kind of number.
{-# NOINLINE [1] length #-}
length                  :: [a] -> Int
length xs               = lenAcc xs 0

lenAcc          :: [a] -> Int -> Int
lenAcc []     n = n
lenAcc (_:ys) n = lenAcc ys (n+1)

{-# RULES
"length" [~1] forall xs . length xs = foldr lengthFB idLength xs 0
"lengthList" [1] foldr lengthFB idLength = lenAcc
 #-}

-- The lambda form turns out to be necessary to make this inline
-- when we need it to and give good performance.
{-# INLINE [0] lengthFB #-}
lengthFB :: x -> (Int -> Int) -> Int -> Int
lengthFB _ r = \ !a -> r (a + 1)

{-# INLINE [0] idLength #-}
idLength :: Int -> Int
idLength = id

-- | /O(n)/. 'filter', applied to a predicate and a list, returns the list of
-- those elements that satisfy the predicate; i.e.,
--
-- > filter p xs = [ x | x <- xs, p x]
--
-- >>> filter odd [1, 2, 3]
-- [1,3]

{-# NOINLINE [1] filter #-}
filter :: (a -> Bool) -> [a] -> [a]
filter _pred []    = []
filter pred (x:xs)
  | pred x         = x : filter pred xs
  | otherwise      = filter pred xs

{-# INLINE [0] filterFB #-} -- See Note [Inline FB functions]
filterFB :: (a -> b -> b) -> (a -> Bool) -> a -> b -> b
filterFB c p x r | p x       = x `c` r
                 | otherwise = r

{-# RULES
"filter"     [~1] forall p xs.  filter p xs = build (\c n -> foldr (filterFB c p) n xs)
"filterList" [1]  forall p.     foldr (filterFB (:) p) [] = filter p
"filterFB"        forall c p q. filterFB (filterFB c p) q = filterFB c (\x -> q x && p x)
 #-}

-- Note the filterFB rule, which has p and q the "wrong way round" in the RHS.
--     filterFB (filterFB c p) q a b
--   = if q a then filterFB c p a b else b
--   = if q a then (if p a then c a b else b) else b
--   = if q a && p a then c a b else b
--   = filterFB c (\x -> q x && p x) a b
-- I originally wrote (\x -> p x && q x), which is wrong, and actually
-- gave rise to a live bug report.  SLPJ.

-- | 'foldl', applied to a binary operator, a starting value (typically
-- the left-identity of the operator), and a list, reduces the list
-- using the binary operator, from left to right:
--
-- > foldl f z [x1, x2, ..., xn] == (...((z `f` x1) `f` x2) `f`...) `f` xn
--
-- The list must be finite.

foldl :: forall a b. (b -> a -> b) -> b -> [a] -> b
{-# INLINE foldl #-}
foldl k z0 xs =
  foldr (\(v::a) (fn::b->b) -> oneShot (\(z::b) -> fn (k z v))) (id :: b -> b) xs z0
  -- See Note [Left folds via right fold]

{-
Note [Left folds via right fold]

Implementing foldl et. al. via foldr is only a good idea if the compiler can
optimize the resulting code (eta-expand the recursive "go"). See #7994.
We hope that one of the two measure kick in:

   * Call Arity (-fcall-arity, enabled by default) eta-expands it if it can see
     all calls and determine that the arity is large.
   * The oneShot annotation gives a hint to the regular arity analysis that
     it may assume that the lambda is called at most once.
     See [One-shot lambdas] in CoreArity and especially [Eta expanding thunks]
     in CoreArity.

The oneShot annotations used in this module are correct, as we only use them in
arguments to foldr, where we know how the arguments are called.

Note [Inline FB functions]
~~~~~~~~~~~~~~~~~~~~~~~~~~
After fusion rules successfully fire, we are usually left with one or more calls
to list-producing functions abstracted over cons and nil. Here we call them
FB functions because their names usually end with 'FB'. It's a good idea to
inline FB functions because:

* They are higher-order functions and therefore benefits from inlining.

* When the final consumer is a left fold, inlining the FB functions is the only
  way to make arity expansion to happen. See Note [Left fold via right fold].

For this reason we mark all FB functions INLINE [0]. The [0] phase-specifier
ensures that calls to FB functions can be written back to the original form
when no fusion happens.

Without these inline pragmas, the loop in perf/should_run/T13001 won't be
allocation-free. Also see Trac #13001.
-}

-- ----------------------------------------------------------------------------

-- | A strict version of 'foldl'.
foldl'           :: forall a b . (b -> a -> b) -> b -> [a] -> b
{-# INLINE foldl' #-}
foldl' k z0 xs =
  foldr (\(v::a) (fn::b->b) -> oneShot (\(z::b) -> z `seq` fn (k z v))) (id :: b -> b) xs z0
  -- See Note [Left folds via right fold]

-- | 'foldl1' is a variant of 'foldl' that has no starting value argument,
-- and thus must be applied to non-empty lists.
foldl1                  :: (a -> a -> a) -> [a] -> a
foldl1 f (x:xs)         =  foldl f x xs
foldl1 _ []             =  errorEmptyList "foldl1"

-- | A strict version of 'foldl1'
foldl1'                  :: (a -> a -> a) -> [a] -> a
foldl1' f (x:xs)         =  foldl' f x xs
foldl1' _ []             =  errorEmptyList "foldl1'"

-- -----------------------------------------------------------------------------
-- List sum and product

-- | The 'sum' function computes the sum of a finite list of numbers.
sum                     :: (Num a) => [a] -> a
{-# INLINE sum #-}
sum                     =  foldl (+) 0

-- | The 'product' function computes the product of a finite list of numbers.
product                 :: (Num a) => [a] -> a
{-# INLINE product #-}
product                 =  foldl (*) 1

-- | /O(n)/. 'scanl' is similar to 'foldl', but returns a list of successive
-- reduced values from the left:
--
-- > scanl f z [x1, x2, ...] == [z, z `f` x1, (z `f` x1) `f` x2, ...]
--
-- Note that
--
-- > last (scanl f z xs) == foldl f z xs.

-- This peculiar arrangement is necessary to prevent scanl being rewritten in
-- its own right-hand side.
{-# NOINLINE [1] scanl #-}
scanl                   :: (b -> a -> b) -> b -> [a] -> [b]
scanl                   = scanlGo
  where
    scanlGo           :: (b -> a -> b) -> b -> [a] -> [b]
    scanlGo f q ls    = q : (case ls of
                               []   -> []
                               x:xs -> scanlGo f (f q x) xs)

-- Note [scanl rewrite rules]
{-# RULES
"scanl"  [~1] forall f a bs . scanl f a bs =
  build (\c n -> a `c` foldr (scanlFB f c) (constScanl n) bs a)
"scanlList" [1] forall f (a::a) bs .
    foldr (scanlFB f (:)) (constScanl []) bs a = tail (scanl f a bs)
 #-}

{-# INLINE [0] scanlFB #-} -- See Note [Inline FB functions]
scanlFB :: (b -> a -> b) -> (b -> c -> c) -> a -> (b -> c) -> b -> c
scanlFB f c = \b g -> oneShot (\x -> let b' = f x b in b' `c` g b')
  -- See Note [Left folds via right fold]

{-# INLINE [0] constScanl #-}
constScanl :: a -> b -> a
constScanl = const

-- | /O(n)/. 'scanl1' is a variant of 'scanl' that has no starting value
-- argument:
--
-- > scanl1 f [x1, x2, ...] == [x1, x1 `f` x2, ...]

scanl1                  :: (a -> a -> a) -> [a] -> [a]
scanl1 f (x:xs)         =  scanl f x xs
scanl1 _ []             =  []

-- | /O(n)/. A strictly accumulating version of 'scanl'
{-# NOINLINE [1] scanl' #-}
scanl'           :: (b -> a -> b) -> b -> [a] -> [b]
-- This peculiar form is needed to prevent scanl' from being rewritten
-- in its own right hand side.
scanl' = scanlGo'
  where
    scanlGo'           :: (b -> a -> b) -> b -> [a] -> [b]
    scanlGo' f !q ls    = q : (case ls of
                            []   -> []
                            x:xs -> scanlGo' f (f q x) xs)

-- Note [scanl rewrite rules]
{-# RULES
"scanl'"  [~1] forall f a bs . scanl' f a bs =
  build (\c n -> a `c` foldr (scanlFB' f c) (flipSeqScanl' n) bs a)
"scanlList'" [1] forall f a bs .
    foldr (scanlFB' f (:)) (flipSeqScanl' []) bs a = tail (scanl' f a bs)
 #-}

{-# INLINE [0] scanlFB' #-} -- See Note [Inline FB functions]
scanlFB' :: (b -> a -> b) -> (b -> c -> c) -> a -> (b -> c) -> b -> c
scanlFB' f c = \b g -> oneShot (\x -> let !b' = f x b in b' `c` g b')
  -- See Note [Left folds via right fold]

{-# INLINE [0] flipSeqScanl' #-}
flipSeqScanl' :: a -> b -> a
flipSeqScanl' a !_b = a

{-
Note [scanl rewrite rules]
~~~~~~~~~~~~~~~~~~~~~~~~~~

In most cases, when we rewrite a form to one that can fuse, we try to rewrite it
back to the original form if it does not fuse. For scanl, we do something a
little different. In particular, we rewrite

scanl f a bs

to

build (\c n -> a `c` foldr (scanlFB f c) (constScanl n) bs a)

When build is inlined, this becomes

a : foldr (scanlFB f (:)) (constScanl []) bs a

To rewrite this form back to scanl, we would need a rule that looked like

forall f a bs. a : foldr (scanlFB f (:)) (constScanl []) bs a = scanl f a bs

The problem with this rule is that it has (:) at its head. This would have the
effect of changing the way the inliner looks at (:), not only here but
everywhere.  In most cases, this makes no difference, but in some cases it
causes it to come to a different decision about whether to inline something.
Based on nofib benchmarks, this is bad for performance. Therefore, we instead
match on everything past the :, which is just the tail of scanl.
-}

-- foldr, foldr1, scanr, and scanr1 are the right-to-left duals of the
-- above functions.

-- | 'foldr1' is a variant of 'foldr' that has no starting value argument,
-- and thus must be applied to non-empty lists.

foldr1                  :: (a -> a -> a) -> [a] -> a
foldr1 f = go
  where go [x]            =  x
        go (x:xs)         =  f x (go xs)
        go []             =  errorEmptyList "foldr1"
{-# INLINE [0] foldr1 #-}

-- | /O(n)/. 'scanr' is the right-to-left dual of 'scanl'.
-- Note that
--
-- > head (scanr f z xs) == foldr f z xs.
{-# NOINLINE [1] scanr #-}
scanr                   :: (a -> b -> b) -> b -> [a] -> [b]
scanr _ q0 []           =  [q0]
scanr f q0 (x:xs)       =  f x q : qs
                           where qs@(q:_) = scanr f q0 xs

{-# INLINE [0] strictUncurryScanr #-}
strictUncurryScanr :: (a -> b -> c) -> (a, b) -> c
strictUncurryScanr f pair = case pair of
                              (x, y) -> f x y

{-# INLINE [0] scanrFB #-} -- See Note [Inline FB functions]
scanrFB :: (a -> b -> b) -> (b -> c -> c) -> a -> (b, c) -> (b, c)
scanrFB f c = \x (r, est) -> (f x r, r `c` est)

{-# RULES
"scanr" [~1] forall f q0 ls . scanr f q0 ls =
  build (\c n -> strictUncurryScanr c (foldr (scanrFB f c) (q0,n) ls))
"scanrList" [1] forall f q0 ls .
               strictUncurryScanr (:) (foldr (scanrFB f (:)) (q0,[]) ls) =
                 scanr f q0 ls
 #-}

-- | /O(n)/. 'scanr1' is a variant of 'scanr' that has no starting value
-- argument.
scanr1                  :: (a -> a -> a) -> [a] -> [a]
scanr1 _ []             =  []
scanr1 _ [x]            =  [x]
scanr1 f (x:xs)         =  f x q : qs
                           where qs@(q:_) = scanr1 f xs

-- | 'maximum' returns the maximum value from a list,
-- which must be non-empty, finite, and of an ordered type.
-- It is a special case of 'Data.List.maximumBy', which allows the
-- programmer to supply their own comparison function.
maximum                 :: (Ord a) => [a] -> a
{-# INLINABLE maximum #-}
maximum []              =  errorEmptyList "maximum"
maximum xs              =  foldl1 max xs

-- We want this to be specialized so that with a strict max function, GHC
-- produces good code. Note that to see if this is happending, one has to
-- look at -ddump-prep, not -ddump-core!
{-# SPECIALIZE  maximum :: [Int] -> Int #-}
{-# SPECIALIZE  maximum :: [Integer] -> Integer #-}

-- | 'minimum' returns the minimum value from a list,
-- which must be non-empty, finite, and of an ordered type.
-- It is a special case of 'Data.List.minimumBy', which allows the
-- programmer to supply their own comparison function.
minimum                 :: (Ord a) => [a] -> a
{-# INLINABLE minimum #-}
minimum []              =  errorEmptyList "minimum"
minimum xs              =  foldl1 min xs

{-# SPECIALIZE  minimum :: [Int] -> Int #-}
{-# SPECIALIZE  minimum :: [Integer] -> Integer #-}

-- | 'iterate' @f x@ returns an infinite list of repeated applications
-- of @f@ to @x@:
--
-- > iterate f x == [x, f x, f (f x), ...]
--
-- Note that 'iterate' is lazy, potentially leading to thunk build-up if
-- the consumer doesn't force each iterate. See 'iterate'' for a strict
-- variant of this function.
{-# NOINLINE [1] iterate #-}
iterate :: (a -> a) -> a -> [a]
iterate f x =  x : iterate f (f x)

{-# INLINE [0] iterateFB #-} -- See Note [Inline FB functions]
iterateFB :: (a -> b -> b) -> (a -> a) -> a -> b
iterateFB c f x0 = go x0
  where go x = x `c` go (f x)

{-# RULES
"iterate"    [~1] forall f x.   iterate f x = build (\c _n -> iterateFB c f x)
"iterateFB"  [1]                iterateFB (:) = iterate
 #-}

-- | 'iterate'' is the strict version of 'iterate'.
--
-- It ensures that the result of each application of force to weak head normal
-- form before proceeding.
{-# NOINLINE [1] iterate' #-}
iterate' :: (a -> a) -> a -> [a]
iterate' f x =
    let x' = f x
    in x' `seq` (x : iterate' f x')

{-# INLINE [0] iterate'FB #-} -- See Note [Inline FB functions]
iterate'FB :: (a -> b -> b) -> (a -> a) -> a -> b
iterate'FB c f x0 = go x0
  where go x =
            let x' = f x
            in x' `seq` (x `c` go x')

{-# RULES
"iterate'"    [~1] forall f x.   iterate' f x = build (\c _n -> iterate'FB c f x)
"iterate'FB"  [1]                iterate'FB (:) = iterate'
 #-}

-- | 'repeat' @x@ is an infinite list, with @x@ the value of every element.
repeat :: a -> [a]
{-# INLINE [0] repeat #-}
-- The pragma just gives the rules more chance to fire
repeat x = xs where xs = x : xs

{-# INLINE [0] repeatFB #-}     -- ditto -- See Note [Inline FB functions]
repeatFB :: (a -> b -> b) -> a -> b
repeatFB c x = xs where xs = x `c` xs

{-# RULES
"repeat"    [~1] forall x. repeat x = build (\c _n -> repeatFB c x)
"repeatFB"  [1]  repeatFB (:)       = repeat
 #-}

-- | 'replicate' @n x@ is a list of length @n@ with @x@ the value of
-- every element.
-- It is an instance of the more general 'Data.List.genericReplicate',
-- in which @n@ may be of any integral type.
{-# INLINE replicate #-}
replicate               :: Int -> a -> [a]
replicate n x           =  take n (repeat x)

-- | 'cycle' ties a finite list into a circular one, or equivalently,
-- the infinite repetition of the original list.  It is the identity
-- on infinite lists.

cycle                   :: [a] -> [a]
cycle []                = errorEmptyList "cycle"
cycle xs                = xs' where xs' = xs ++ xs'

-- | 'takeWhile', applied to a predicate @p@ and a list @xs@, returns the
-- longest prefix (possibly empty) of @xs@ of elements that satisfy @p@:
--
-- > takeWhile (< 3) [1,2,3,4,1,2,3,4] == [1,2]
-- > takeWhile (< 9) [1,2,3] == [1,2,3]
-- > takeWhile (< 0) [1,2,3] == []
--

{-# NOINLINE [1] takeWhile #-}
takeWhile               :: (a -> Bool) -> [a] -> [a]
takeWhile _ []          =  []
takeWhile p (x:xs)
            | p x       =  x : takeWhile p xs
            | otherwise =  []

{-# INLINE [0] takeWhileFB #-} -- See Note [Inline FB functions]
takeWhileFB :: (a -> Bool) -> (a -> b -> b) -> b -> a -> b -> b
takeWhileFB p c n = \x r -> if p x then x `c` r else n

-- The takeWhileFB rule is similar to the filterFB rule. It works like this:
-- takeWhileFB q (takeWhileFB p c n) n =
-- \x r -> if q x then (takeWhileFB p c n) x r else n =
-- \x r -> if q x then (\x' r' -> if p x' then x' `c` r' else n) x r else n =
-- \x r -> if q x then (if p x then x `c` r else n) else n =
-- \x r -> if q x && p x then x `c` r else n =
-- takeWhileFB (\x -> q x && p x) c n
{-# RULES
"takeWhile"     [~1] forall p xs. takeWhile p xs =
                                build (\c n -> foldr (takeWhileFB p c n) n xs)
"takeWhileList" [1]  forall p.    foldr (takeWhileFB p (:) []) [] = takeWhile p
"takeWhileFB"        forall c n p q. takeWhileFB q (takeWhileFB p c n) n =
                        takeWhileFB (\x -> q x && p x) c n
 #-}

-- | 'dropWhile' @p xs@ returns the suffix remaining after 'takeWhile' @p xs@:
--
-- > dropWhile (< 3) [1,2,3,4,5,1,2,3] == [3,4,5,1,2,3]
-- > dropWhile (< 9) [1,2,3] == []
-- > dropWhile (< 0) [1,2,3] == [1,2,3]
--

dropWhile               :: (a -> Bool) -> [a] -> [a]
dropWhile _ []          =  []
dropWhile p xs@(x:xs')
            | p x       =  dropWhile p xs'
            | otherwise =  xs

-- | 'take' @n@, applied to a list @xs@, returns the prefix of @xs@
-- of length @n@, or @xs@ itself if @n > 'length' xs@:
--
-- > take 5 "Hello World!" == "Hello"
-- > take 3 [1,2,3,4,5] == [1,2,3]
-- > take 3 [1,2] == [1,2]
-- > take 3 [] == []
-- > take (-1) [1,2] == []
-- > take 0 [1,2] == []
--
-- It is an instance of the more general 'Data.List.genericTake',
-- in which @n@ may be of any integral type.
take                   :: Int -> [a] -> [a]
#if defined(USE_REPORT_PRELUDE)
take n _      | n <= 0 =  []
take _ []              =  []
take n (x:xs)          =  x : take (n-1) xs
#else

{- We always want to inline this to take advantage of a known length argument
sign. Note, however, that it's important for the RULES to grab take, rather
than trying to INLINE take immediately and then letting the RULES grab
unsafeTake. Presumably the latter approach doesn't grab it early enough; it led
to an allocation regression in nofib/fft2. -}
{-# INLINE [1] take #-}
take n xs | 0 < n     = unsafeTake n xs
          | otherwise = []

-- A version of take that takes the whole list if it's given an argument less
-- than 1.
{-# NOINLINE [1] unsafeTake #-}
unsafeTake :: Int -> [a] -> [a]
unsafeTake !_  []     = []
unsafeTake 1   (x: _) = [x]
unsafeTake m   (x:xs) = x : unsafeTake (m - 1) xs

{-# RULES
"take"     [~1] forall n xs . take n xs =
  build (\c nil -> if 0 < n
                   then foldr (takeFB c nil) (flipSeqTake nil) xs n
                   else nil)
"unsafeTakeList"  [1] forall n xs . foldr (takeFB (:) []) (flipSeqTake []) xs n
                                        = unsafeTake n xs
 #-}

{-# INLINE [0] flipSeqTake #-}
-- Just flip seq, specialized to Int, but not inlined too early.
-- It's important to force the numeric argument here, even though
-- it's not used. Otherwise, take n [] doesn't force n. This is
-- bad for strictness analysis and unboxing, and leads to increased
-- allocation in T7257.
flipSeqTake :: a -> Int -> a
flipSeqTake x !_n = x

{-# INLINE [0] takeFB #-} -- See Note [Inline FB functions]
takeFB :: (a -> b -> b) -> b -> a -> (Int -> b) -> Int -> b
-- The \m accounts for the fact that takeFB is used in a higher-order
-- way by takeFoldr, so it's better to inline.  A good example is
--     take n (repeat x)
-- for which we get excellent code... but only if we inline takeFB
-- when given four arguments
takeFB c n x xs
  = \ m -> case m of
            1 -> x `c` n
            _ -> x `c` xs (m - 1)
#endif

-- | 'drop' @n xs@ returns the suffix of @xs@
-- after the first @n@ elements, or @[]@ if @n > 'length' xs@:
--
-- > drop 6 "Hello World!" == "World!"
-- > drop 3 [1,2,3,4,5] == [4,5]
-- > drop 3 [1,2] == []
-- > drop 3 [] == []
-- > drop (-1) [1,2] == [1,2]
-- > drop 0 [1,2] == [1,2]
--
-- It is an instance of the more general 'Data.List.genericDrop',
-- in which @n@ may be of any integral type.
drop                   :: Int -> [a] -> [a]
#if defined(USE_REPORT_PRELUDE)
drop n xs     | n <= 0 =  xs
drop _ []              =  []
drop n (_:xs)          =  drop (n-1) xs
#else /* hack away */
{-# INLINE drop #-}
drop n ls
  | n <= 0     = ls
  | otherwise  = unsafeDrop n ls
  where
    -- A version of drop that drops the whole list if given an argument
    -- less than 1
    unsafeDrop :: Int -> [a] -> [a]
    unsafeDrop !_ []     = []
    unsafeDrop 1  (_:xs) = xs
    unsafeDrop m  (_:xs) = unsafeDrop (m - 1) xs
#endif

-- | 'splitAt' @n xs@ returns a tuple where first element is @xs@ prefix of
-- length @n@ and second element is the remainder of the list:
--
-- > splitAt 6 "Hello World!" == ("Hello ","World!")
-- > splitAt 3 [1,2,3,4,5] == ([1,2,3],[4,5])
-- > splitAt 1 [1,2,3] == ([1],[2,3])
-- > splitAt 3 [1,2,3] == ([1,2,3],[])
-- > splitAt 4 [1,2,3] == ([1,2,3],[])
-- > splitAt 0 [1,2,3] == ([],[1,2,3])
-- > splitAt (-1) [1,2,3] == ([],[1,2,3])
--
-- It is equivalent to @('take' n xs, 'drop' n xs)@ when @n@ is not @_|_@
-- (@splitAt _|_ xs = _|_@).
-- 'splitAt' is an instance of the more general 'Data.List.genericSplitAt',
-- in which @n@ may be of any integral type.
splitAt                :: Int -> [a] -> ([a],[a])

#if defined(USE_REPORT_PRELUDE)
splitAt n xs           =  (take n xs, drop n xs)
#else
splitAt n ls
  | n <= 0 = ([], ls)
  | otherwise          = splitAt' n ls
    where
        splitAt' :: Int -> [a] -> ([a], [a])
        splitAt' _  []     = ([], [])
        splitAt' 1  (x:xs) = ([x], xs)
        splitAt' m  (x:xs) = (x:xs', xs'')
          where
            (xs', xs'') = splitAt' (m - 1) xs
#endif /* USE_REPORT_PRELUDE */

-- | 'span', applied to a predicate @p@ and a list @xs@, returns a tuple where
-- first element is longest prefix (possibly empty) of @xs@ of elements that
-- satisfy @p@ and second element is the remainder of the list:
--
-- > span (< 3) [1,2,3,4,1,2,3,4] == ([1,2],[3,4,1,2,3,4])
-- > span (< 9) [1,2,3] == ([1,2,3],[])
-- > span (< 0) [1,2,3] == ([],[1,2,3])
--
-- 'span' @p xs@ is equivalent to @('takeWhile' p xs, 'dropWhile' p xs)@

span                    :: (a -> Bool) -> [a] -> ([a],[a])
span _ xs@[]            =  (xs, xs)
span p xs@(x:xs')
         | p x          =  let (ys,zs) = span p xs' in (x:ys,zs)
         | otherwise    =  ([],xs)

-- | 'break', applied to a predicate @p@ and a list @xs@, returns a tuple where
-- first element is longest prefix (possibly empty) of @xs@ of elements that
-- /do not satisfy/ @p@ and second element is the remainder of the list:
--
-- > break (> 3) [1,2,3,4,1,2,3,4] == ([1,2,3],[4,1,2,3,4])
-- > break (< 9) [1,2,3] == ([],[1,2,3])
-- > break (> 9) [1,2,3] == ([1,2,3],[])
--
-- 'break' @p@ is equivalent to @'span' ('not' . p)@.

break                   :: (a -> Bool) -> [a] -> ([a],[a])
#if defined(USE_REPORT_PRELUDE)
break p                 =  span (not . p)
#else
-- HBC version (stolen)
break _ xs@[]           =  (xs, xs)
break p xs@(x:xs')
           | p x        =  ([],xs)
           | otherwise  =  let (ys,zs) = break p xs' in (x:ys,zs)
#endif

-- | 'reverse' @xs@ returns the elements of @xs@ in reverse order.
-- @xs@ must be finite.
reverse                 :: [a] -> [a]
#if defined(USE_REPORT_PRELUDE)
reverse                 =  foldl (flip (:)) []
#else
reverse l =  rev l []
  where
    rev []     a = a
    rev (x:xs) a = rev xs (x:a)
#endif

-- | 'and' returns the conjunction of a Boolean list.  For the result to be
-- 'True', the list must be finite; 'False', however, results from a 'False'
-- value at a finite index of a finite or infinite list.
and                     :: [Bool] -> Bool
#if defined(USE_REPORT_PRELUDE)
and                     =  foldr (&&) True
#else
and []          =  True
and (x:xs)      =  x && and xs
{-# NOINLINE [1] and #-}

{-# RULES
"and/build"     forall (g::forall b.(Bool->b->b)->b->b) .
                and (build g) = g (&&) True
 #-}
#endif

-- | 'or' returns the disjunction of a Boolean list.  For the result to be
-- 'False', the list must be finite; 'True', however, results from a 'True'
-- value at a finite index of a finite or infinite list.
or                      :: [Bool] -> Bool
#if defined(USE_REPORT_PRELUDE)
or                      =  foldr (||) False
#else
or []           =  False
or (x:xs)       =  x || or xs
{-# NOINLINE [1] or #-}

{-# RULES
"or/build"      forall (g::forall b.(Bool->b->b)->b->b) .
                or (build g) = g (||) False
 #-}
#endif

-- | Applied to a predicate and a list, 'any' determines if any element
-- of the list satisfies the predicate.  For the result to be
-- 'False', the list must be finite; 'True', however, results from a 'True'
-- value for the predicate applied to an element at a finite index of a finite or infinite list.
any                     :: (a -> Bool) -> [a] -> Bool

#if defined(USE_REPORT_PRELUDE)
any p                   =  or . map p
#else
any _ []        = False
any p (x:xs)    = p x || any p xs

{-# NOINLINE [1] any #-}

{-# RULES
"any/build"     forall p (g::forall b.(a->b->b)->b->b) .
                any p (build g) = g ((||) . p) False
 #-}
#endif

-- | Applied to a predicate and a list, 'all' determines if all elements
-- of the list satisfy the predicate. For the result to be
-- 'True', the list must be finite; 'False', however, results from a 'False'
-- value for the predicate applied to an element at a finite index of a finite or infinite list.
all                     :: (a -> Bool) -> [a] -> Bool
#if defined(USE_REPORT_PRELUDE)
all p                   =  and . map p
#else
all _ []        =  True
all p (x:xs)    =  p x && all p xs

{-# NOINLINE [1] all #-}

{-# RULES
"all/build"     forall p (g::forall b.(a->b->b)->b->b) .
                all p (build g) = g ((&&) . p) True
 #-}
#endif

-- | 'elem' is the list membership predicate, usually written in infix form,
-- e.g., @x \`elem\` xs@.  For the result to be
-- 'False', the list must be finite; 'True', however, results from an element
-- equal to @x@ found at a finite index of a finite or infinite list.
elem                    :: (Eq a) => a -> [a] -> Bool
#if defined(USE_REPORT_PRELUDE)
elem x                  =  any (== x)
#else
elem _ []       = False
elem x (y:ys)   = x==y || elem x ys
{-# NOINLINE [1] elem #-}
{-# RULES
"elem/build"    forall x (g :: forall b . Eq a => (a -> b -> b) -> b -> b)
   . elem x (build g) = g (\ y r -> (x == y) || r) False
 #-}
#endif

-- | 'notElem' is the negation of 'elem'.
notElem                 :: (Eq a) => a -> [a] -> Bool
#if defined(USE_REPORT_PRELUDE)
notElem x               =  all (/= x)
#else
notElem _ []    =  True
notElem x (y:ys)=  x /= y && notElem x ys
{-# NOINLINE [1] notElem #-}
{-# RULES
"notElem/build" forall x (g :: forall b . Eq a => (a -> b -> b) -> b -> b)
   . notElem x (build g) = g (\ y r -> (x /= y) && r) True
 #-}
#endif

-- | /O(n)/. 'lookup' @key assocs@ looks up a key in an association list.
--
-- >>> lookup 2 [(1, "first"), (2, "second"), (3, "third")]
-- Just "second"
lookup                  :: (Eq a) => a -> [(a,b)] -> Maybe b
lookup _key []          =  Nothing
lookup  key ((x,y):xys)
    | key == x           =  Just y
    | otherwise         =  lookup key xys

-- | Map a function over a list and concatenate the results.
concatMap               :: (a -> [b]) -> [a] -> [b]
concatMap f             =  foldr ((++) . f) []

{-# NOINLINE [1] concatMap #-}

{-# RULES
"concatMap" forall f xs . concatMap f xs =
    build (\c n -> foldr (\x b -> foldr c b (f x)) n xs)
 #-}

-- | Concatenate a list of lists.
concat :: [[a]] -> [a]
concat = foldr (++) []

{-# NOINLINE [1] concat #-}

{-# RULES
  "concat" forall xs. concat xs =
     build (\c n -> foldr (\x y -> foldr c y x) n xs)
-- We don't bother to turn non-fusible applications of concat back into concat
 #-}

-- | List index (subscript) operator, starting from 0.
-- It is an instance of the more general 'Data.List.genericIndex',
-- which takes an index of any integral type.
(!!)                    :: [a] -> Int -> a
#if defined(USE_REPORT_PRELUDE)
xs     !! n | n < 0 =  errorWithoutStackTrace "Prelude.!!: negative index"
[]     !! _         =  errorWithoutStackTrace "Prelude.!!: index too large"
(x:_)  !! 0         =  x
(_:xs) !! n         =  xs !! (n-1)
#else

-- We don't really want the errors to inline with (!!).
-- We may want to fuss around a bit with NOINLINE, and
-- if so we should be careful not to trip up known-bottom
-- optimizations.
tooLarge :: Int -> a
tooLarge _ = errorWithoutStackTrace (prel_list_str ++ "!!: index too large")

negIndex :: a
negIndex = errorWithoutStackTrace $ prel_list_str ++ "!!: negative index"

{-# INLINABLE (!!) #-}
xs !! n
  | n < 0     = negIndex
  | otherwise = foldr (\x r k -> case k of
                                   0 -> x
                                   _ -> r (k-1)) tooLarge xs n
#endif

--------------------------------------------------------------
-- The zip family
--------------------------------------------------------------

foldr2 :: (a -> b -> c -> c) -> c -> [a] -> [b] -> c
foldr2 k z = go
  where
        go []    _ys     = z
        go _xs   []      = z
        go (x:xs) (y:ys) = k x y (go xs ys)
{-# INLINE [0] foldr2 #-}  -- See Note [Fusion for foldrN]

foldr2_left :: (a -> b -> c -> d) -> d -> a -> ([b] -> c) -> [b] -> d
foldr2_left _k  z _x _r []     = z
foldr2_left  k _z  x  r (y:ys) = k x y (r ys)

-- foldr2 k z xs ys = foldr (foldr2_left k z)  (\_ -> z) xs ys
{-# RULES   -- See Note [Fusion for foldrN]
"foldr2/left"   forall k z ys (g::forall b.(a->b->b)->b->b) .
                  foldr2 k z (build g) ys = g (foldr2_left  k z) (\_ -> z) ys
 #-}

foldr3 :: (a -> b -> c -> d -> d) -> d -> [a] -> [b] -> [c] -> d
foldr3 k z = go
  where
    go  []    _      _      = z
    go  _     []     _      = z
    go  _     _      []     = z
    go (a:as) (b:bs) (c:cs) = k a b c (go as bs cs)
{-# INLINE [0] foldr3 #-}  -- See Note [Fusion for foldrN]

foldr3_left :: (a -> b -> c -> d -> e) -> e -> a ->
               ([b] -> [c] -> d) -> [b] -> [c] -> e
foldr3_left k _z a r (b:bs) (c:cs) = k a b c (r bs cs)
foldr3_left _  z _ _  _      _     = z

-- foldr3 k n xs ys zs = foldr (foldr3_left k n) (\_ _ -> n) xs ys zs
{-# RULES   -- See Note [Fusion for foldrN]
"foldr3/left"   forall k z (g::forall b.(a->b->b)->b->b).
                  foldr3 k z (build g) = g (foldr3_left k z) (\_ _ -> z)
 #-}

{- Note [Fusion for foldrN]
~~~~~~~~~~~~~~~~~~~~~~~~~~~
We arrange that foldr2, foldr3, etc is a good consumer for its first
(left) list argument. Here's how. See below for the second, third
etc list arguments

* The rule "foldr2/left" (active only before phase 1) does this:
     foldr2 k z (build g) ys = g (foldr2_left  k z) (\_ -> z) ys
  thereby fusing away the 'build' on the left argument

* To ensure this rule has a chance to fire, foldr2 has a NOINLINE[1] pragma

There used to be a "foldr2/right" rule, allowing foldr2 to fuse with a build
form on the right. However, this causes trouble if the right list ends in
a bottom that is only avoided by the left list ending at that spot. That is,
foldr2 f z [a,b,c] (d:e:f:_|_), where the right list is produced by a build
form, would cause the foldr2/right rule to introduce bottom. Example:
  zip [1,2,3,4] (unfoldr (\s -> if s > 4 then undefined else Just (s,s+1)) 1)
should produce
  [(1,1),(2,2),(3,3),(4,4)]
but with the foldr2/right rule it would instead produce
  (1,1):(2,2):(3,3):(4,4):_|_

Note [Fusion for zipN/zipWithN]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
We arrange that zip, zip3, etc, and zipWith, zipWit3 etc, are all
good consumers for their first (left) argument, and good producers.
Here's how.  See Note [Fusion for foldr2] for why it can't fuse its
second (right) list argument.

NB: Zips for larger tuples are in the List module.

* Rule "zip" (active only before phase 1) rewrites
    zip xs ys = build (\c n -> foldr2 (zipFB c) n xs ys)
  See also Note [Inline FB functions]

  Ditto rule "zipWith".

* To give this rule a chance to fire, we give zip a NOLINLINE[1]
  pragma (although since zip is recursive it might not need it)

* Now the rules for foldr2 (see Note [Fusion for foldr2]) may fire,
  or rules that fuse the build-produced output of zip.

* If none of these fire, rule "zipList" (active only in phase 1)
  rewrites the foldr2 call back to zip
     foldr2 (zipFB (:)) []   = zip
  This rule will only fire when build has inlined, which also
  happens in phase 1.

  Ditto rule "zipWithList".
-}

----------------------------------------------
-- | /O(min(m,n))/. 'zip' takes two lists and returns a list of corresponding
-- pairs.
--
-- > zip [1, 2] ['a', 'b'] = [(1, 'a'), (2, 'b')]
--
-- If one input list is short, excess elements of the longer list are
-- discarded:
--
-- > zip [1] ['a', 'b'] = [(1, 'a')]
-- > zip [1, 2] ['a'] = [(1, 'a')]
--
-- 'zip' is right-lazy:
--
-- > zip [] _|_ = []
-- > zip _|_ [] = _|_
--
-- 'zip' is capable of list fusion, but it is restricted to its
-- first list argument and its resulting list.
{-# NOINLINE [1] zip #-}  -- See Note [Fusion for zipN/zipWithN]
zip :: [a] -> [b] -> [(a,b)]
zip []     _bs    = []
zip _as    []     = []
zip (a:as) (b:bs) = (a,b) : zip as bs

{-# INLINE [0] zipFB #-} -- See Note [Inline FB functions]
zipFB :: ((a, b) -> c -> d) -> a -> b -> c -> d
zipFB c = \x y r -> (x,y) `c` r

{-# RULES  -- See Note [Fusion for zipN/zipWithN]
"zip"      [~1] forall xs ys. zip xs ys = build (\c n -> foldr2 (zipFB c) n xs ys)
"zipList"  [1]  foldr2 (zipFB (:)) []   = zip
 #-}

----------------------------------------------
-- | 'zip3' takes three lists and returns a list of triples, analogous to
-- 'zip'.
-- It is capable of list fusion, but it is restricted to its
-- first list argument and its resulting list.
{-# NOINLINE [1] zip3 #-}
zip3 :: [a] -> [b] -> [c] -> [(a,b,c)]
-- Specification
-- zip3 =  zipWith3 (,,)
zip3 (a:as) (b:bs) (c:cs) = (a,b,c) : zip3 as bs cs
zip3 _      _      _      = []

{-# INLINE [0] zip3FB #-} -- See Note [Inline FB functions]
zip3FB :: ((a,b,c) -> xs -> xs') -> a -> b -> c -> xs -> xs'
zip3FB cons = \a b c r -> (a,b,c) `cons` r

{-# RULES    -- See Note [Fusion for zipN/zipWithN]
"zip3"       [~1] forall as bs cs. zip3 as bs cs = build (\c n -> foldr3 (zip3FB c) n as bs cs)
"zip3List"   [1]          foldr3 (zip3FB (:)) [] = zip3
 #-}

-- The zipWith family generalises the zip family by zipping with the
-- function given as the first argument, instead of a tupling function.

----------------------------------------------
-- | /O(min(m,n))/. 'zipWith' generalises 'zip' by zipping with the function
-- given as the first argument, instead of a tupling function. For example,
-- @'zipWith' (+)@ is applied to two lists to produce the list of corresponding
-- sums:
--
-- >>> zipWith (+) [1, 2, 3] [4, 5, 6]
-- [5,7,9]
--
-- 'zipWith' is right-lazy:
--
-- > zipWith f [] _|_ = []
--
-- 'zipWith' is capable of list fusion, but it is restricted to its
-- first list argument and its resulting list.
{-# NOINLINE [1] zipWith #-}  -- See Note [Fusion for zipN/zipWithN]
zipWith :: (a->b->c) -> [a]->[b]->[c]
zipWith f = go
  where
    go [] _ = []
    go _ [] = []
    go (x:xs) (y:ys) = f x y : go xs ys

-- zipWithFB must have arity 2 since it gets two arguments in the "zipWith"
-- rule; it might not get inlined otherwise
{-# INLINE [0] zipWithFB #-} -- See Note [Inline FB functions]
zipWithFB :: (a -> b -> c) -> (d -> e -> a) -> d -> e -> b -> c
zipWithFB c f = \x y r -> (x `f` y) `c` r

{-# RULES       -- See Note [Fusion for zipN/zipWithN]
"zipWith"       [~1] forall f xs ys.    zipWith f xs ys = build (\c n -> foldr2 (zipWithFB c f) n xs ys)
"zipWithList"   [1]  forall f.  foldr2 (zipWithFB (:) f) [] = zipWith f
  #-}

-- | The 'zipWith3' function takes a function which combines three
-- elements, as well as three lists and returns a list of their point-wise
-- combination, analogous to 'zipWith'.
-- It is capable of list fusion, but it is restricted to its
-- first list argument and its resulting list.
{-# NOINLINE [1] zipWith3 #-}
zipWith3                :: (a->b->c->d) -> [a]->[b]->[c]->[d]
zipWith3 z = go
  where
    go (a:as) (b:bs) (c:cs) = z a b c : go as bs cs
    go _ _ _                = []

{-# INLINE [0] zipWith3FB #-} -- See Note [Inline FB functions]
zipWith3FB :: (d -> xs -> xs') -> (a -> b -> c -> d) -> a -> b -> c -> xs -> xs'
zipWith3FB cons func = \a b c r -> (func a b c) `cons` r

{-# RULES
"zipWith3"      [~1] forall f as bs cs.   zipWith3 f as bs cs = build (\c n -> foldr3 (zipWith3FB c f) n as bs cs)
"zipWith3List"  [1]  forall f.   foldr3 (zipWith3FB (:) f) [] = zipWith3 f
 #-}

-- | 'unzip' transforms a list of pairs into a list of first components
-- and a list of second components.
unzip    :: [(a,b)] -> ([a],[b])
{-# INLINE unzip #-}
-- Inline so that fusion `foldr` has an opportunity to fire.
-- See Note [Inline @unzipN@ functions] in GHC/OldList.hs.
unzip    =  foldr (\(a,b) ~(as,bs) -> (a:as,b:bs)) ([],[])

-- | The 'unzip3' function takes a list of triples and returns three
-- lists, analogous to 'unzip'.
unzip3   :: [(a,b,c)] -> ([a],[b],[c])
{-# INLINE unzip3 #-}
-- Inline so that fusion `foldr` has an opportunity to fire.
-- See Note [Inline @unzipN@ functions] in GHC/OldList.hs.
unzip3   =  foldr (\(a,b,c) ~(as,bs,cs) -> (a:as,b:bs,c:cs))
                  ([],[],[])

--------------------------------------------------------------
-- Error code
--------------------------------------------------------------

-- Common up near identical calls to `error' to reduce the number
-- constant strings created when compiled:

errorEmptyList :: String -> a
errorEmptyList fun =
  errorWithoutStackTrace (prel_list_str ++ fun ++ ": empty list")

prel_list_str :: String
prel_list_str = "Prelude."


{-# LANGUAGE NoImplicitPrelude #-}
{-# OPTIONS_HADDOCK not-home #-}

-- | Maybe type
module GHC.Maybe
   ( Maybe (..)
   )
where

import GHC.Integer () -- See Note [Depend on GHC.Integer] in GHC.Base
import GHC.Classes

default ()

-------------------------------------------------------------------------------
-- Maybe type
-------------------------------------------------------------------------------

-- | The 'Maybe' type encapsulates an optional value.  A value of type
-- @'Maybe' a@ either contains a value of type @a@ (represented as @'Just' a@),
-- or it is empty (represented as 'Nothing').  Using 'Maybe' is a good way to
-- deal with errors or exceptional cases without resorting to drastic
-- measures such as 'Prelude.error'.
--
-- The 'Maybe' type is also a monad.  It is a simple kind of error
-- monad, where all errors are represented by 'Nothing'.  A richer
-- error monad can be built using the 'Data.Either.Either' type.
--
data  Maybe a  =  Nothing | Just a
  deriving ( Eq  -- ^ @since 2.01
           , Ord -- ^ @since 2.01
           )


{-# LANGUAGE Unsafe #-}
{-# LANGUAGE NoImplicitPrelude, MagicHash, UnboxedTuples #-}
{-# OPTIONS_GHC -funbox-strict-fields #-}
{-# OPTIONS_HADDOCK not-home #-}

-----------------------------------------------------------------------------
-- |
-- Module      :  GHC.MVar
-- Copyright   :  (c) The University of Glasgow 2008
-- License     :  see libraries/base/LICENSE
--
-- Maintainer  :  cvs-ghc@haskell.org
-- Stability   :  internal
-- Portability :  non-portable (GHC Extensions)
--
-- The MVar type
--
-----------------------------------------------------------------------------

module GHC.MVar (
        -- * MVars
          MVar(..)
        , newMVar
        , newEmptyMVar
        , takeMVar
        , readMVar
        , putMVar
        , tryTakeMVar
        , tryPutMVar
        , tryReadMVar
        , isEmptyMVar
        , addMVarFinalizer
    ) where

import GHC.Base

data MVar a = MVar (MVar# RealWorld a)
{- ^
An 'MVar' (pronounced \"em-var\") is a synchronising variable, used
for communication between concurrent threads.  It can be thought of
as a box, which may be empty or full.
-}

-- pull in Eq (Mvar a) too, to avoid GHC.Conc being an orphan-instance module
-- | @since 4.1.0.0
instance Eq (MVar a) where
        (MVar mvar1#) == (MVar mvar2#) = isTrue# (sameMVar# mvar1# mvar2#)

{-
M-Vars are rendezvous points for concurrent threads.  They begin
empty, and any attempt to read an empty M-Var blocks.  When an M-Var
is written, a single blocked thread may be freed.  Reading an M-Var
toggles its state from full back to empty.  Therefore, any value
written to an M-Var may only be read once.  Multiple reads and writes
are allowed, but there must be at least one read between any two
writes.
-}

--Defined in IOBase to avoid cycle: data MVar a = MVar (SynchVar# RealWorld a)

-- |Create an 'MVar' which is initially empty.
newEmptyMVar  :: IO (MVar a)
newEmptyMVar = IO $ \ s# ->
    case newMVar# s# of
         (# s2#, svar# #) -> (# s2#, MVar svar# #)

-- |Create an 'MVar' which contains the supplied value.
newMVar :: a -> IO (MVar a)
newMVar value =
    newEmptyMVar        >>= \ mvar ->
    putMVar mvar value  >>
    return mvar

-- |Return the contents of the 'MVar'.  If the 'MVar' is currently
-- empty, 'takeMVar' will wait until it is full.  After a 'takeMVar',
-- the 'MVar' is left empty.
--
-- There are two further important properties of 'takeMVar':
--
--   * 'takeMVar' is single-wakeup.  That is, if there are multiple
--     threads blocked in 'takeMVar', and the 'MVar' becomes full,
--     only one thread will be woken up.  The runtime guarantees that
--     the woken thread completes its 'takeMVar' operation.
--
--   * When multiple threads are blocked on an 'MVar', they are
--     woken up in FIFO order.  This is useful for providing
--     fairness properties of abstractions built using 'MVar's.
--
takeMVar :: MVar a -> IO a
takeMVar (MVar mvar#) = IO $ \ s# -> takeMVar# mvar# s#

-- |Atomically read the contents of an 'MVar'.  If the 'MVar' is
-- currently empty, 'readMVar' will wait until it is full.
-- 'readMVar' is guaranteed to receive the next 'putMVar'.
--
-- 'readMVar' is multiple-wakeup, so when multiple readers are
-- blocked on an 'MVar', all of them are woken up at the same time.
--
-- /Compatibility note:/ Prior to base 4.7, 'readMVar' was a combination
-- of 'takeMVar' and 'putMVar'.  This mean that in the presence of
-- other threads attempting to 'putMVar', 'readMVar' could block.
-- Furthermore, 'readMVar' would not receive the next 'putMVar' if there
-- was already a pending thread blocked on 'takeMVar'.  The old behavior
-- can be recovered by implementing 'readMVar as follows:
--
-- @
--  readMVar :: MVar a -> IO a
--  readMVar m =
--    mask_ $ do
--      a <- takeMVar m
--      putMVar m a
--      return a
-- @
readMVar :: MVar a -> IO a
readMVar (MVar mvar#) = IO $ \ s# -> readMVar# mvar# s#

-- |Put a value into an 'MVar'.  If the 'MVar' is currently full,
-- 'putMVar' will wait until it becomes empty.
--
-- There are two further important properties of 'putMVar':
--
--   * 'putMVar' is single-wakeup.  That is, if there are multiple
--     threads blocked in 'putMVar', and the 'MVar' becomes empty,
--     only one thread will be woken up.  The runtime guarantees that
--     the woken thread completes its 'putMVar' operation.
--
--   * When multiple threads are blocked on an 'MVar', they are
--     woken up in FIFO order.  This is useful for providing
--     fairness properties of abstractions built using 'MVar's.
--
putMVar  :: MVar a -> a -> IO ()
putMVar (MVar mvar#) x = IO $ \ s# ->
    case putMVar# mvar# x s# of
        s2# -> (# s2#, () #)

-- |A non-blocking version of 'takeMVar'.  The 'tryTakeMVar' function
-- returns immediately, with 'Nothing' if the 'MVar' was empty, or
-- @'Just' a@ if the 'MVar' was full with contents @a@.  After 'tryTakeMVar',
-- the 'MVar' is left empty.
tryTakeMVar :: MVar a -> IO (Maybe a)
tryTakeMVar (MVar m) = IO $ \ s ->
    case tryTakeMVar# m s of
        (# s', 0#, _ #) -> (# s', Nothing #)      -- MVar is empty
        (# s', _,  a #) -> (# s', Just a  #)      -- MVar is full

-- |A non-blocking version of 'putMVar'.  The 'tryPutMVar' function
-- attempts to put the value @a@ into the 'MVar', returning 'True' if
-- it was successful, or 'False' otherwise.
tryPutMVar  :: MVar a -> a -> IO Bool
tryPutMVar (MVar mvar#) x = IO $ \ s# ->
    case tryPutMVar# mvar# x s# of
        (# s, 0# #) -> (# s, False #)
        (# s, _  #) -> (# s, True #)

-- |A non-blocking version of 'readMVar'.  The 'tryReadMVar' function
-- returns immediately, with 'Nothing' if the 'MVar' was empty, or
-- @'Just' a@ if the 'MVar' was full with contents @a@.
--
-- @since 4.7.0.0
tryReadMVar :: MVar a -> IO (Maybe a)
tryReadMVar (MVar m) = IO $ \ s ->
    case tryReadMVar# m s of
        (# s', 0#, _ #) -> (# s', Nothing #)      -- MVar is empty
        (# s', _,  a #) -> (# s', Just a  #)      -- MVar is full

-- |Check whether a given 'MVar' is empty.
--
-- Notice that the boolean value returned  is just a snapshot of
-- the state of the MVar. By the time you get to react on its result,
-- the MVar may have been filled (or emptied) - so be extremely
-- careful when using this operation.   Use 'tryTakeMVar' instead if possible.
isEmptyMVar :: MVar a -> IO Bool
isEmptyMVar (MVar mv#) = IO $ \ s# ->
    case isEmptyMVar# mv# s# of
        (# s2#, flg #) -> (# s2#, isTrue# (flg /=# 0#) #)

-- |Add a finalizer to an 'MVar' (GHC only).  See "Foreign.ForeignPtr" and
-- "System.Mem.Weak" for more about finalizers.
addMVarFinalizer :: MVar a -> IO () -> IO ()
addMVarFinalizer (MVar m) (IO finalizer) =
    IO $ \s -> case mkWeak# m () finalizer s of { (# s1, _ #) -> (# s1, () #) }


{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE MagicHash #-}
{-# LANGUAGE UnboxedTuples #-}

-----------------------------------------------------------------------------
-- |
-- Module      :  GHC.Natural
-- Copyright   :  (C) 2014 Herbert Valerio Riedel,
--                (C) 2011 Edward Kmett
-- License     :  see libraries/base/LICENSE
--
-- Maintainer  :  libraries@haskell.org
-- Stability   :  internal
-- Portability :  non-portable (GHC Extensions)
--
-- The arbitrary-precision 'Natural' number type.
--
-- __Note__: This is an internal GHC module with an API subject to
-- change.  It's recommended use the "Numeric.Natural" module to import
-- the 'Natural' type.
--
-- @since 4.8.0.0
-----------------------------------------------------------------------------
module GHC.Natural
    ( -- * The 'Natural' number type
      --
      -- | __Warning__: The internal implementation of 'Natural'
      -- (i.e. which constructors are available) depends on the
      -- 'Integer' backend used!
      Natural(..)
    , mkNatural
    , isValidNatural
      -- * Arithmetic
    , plusNatural
    , minusNatural
    , minusNaturalMaybe
    , timesNatural
    , negateNatural
    , signumNatural
    , quotRemNatural
    , quotNatural
    , remNatural
    , gcdNatural
    , lcmNatural
      -- * Bits
    , andNatural
    , orNatural
    , xorNatural
    , bitNatural
    , testBitNatural
    , popCountNatural
    , shiftLNatural
    , shiftRNatural
      -- * Conversions
    , naturalToInteger
    , naturalToWord
    , naturalToInt
    , naturalFromInteger
    , wordToNatural
    , intToNatural
    , naturalToWordMaybe
    , wordToNatural#
    , wordToNaturalBase
      -- * Modular arithmetic
    , powModNatural
    ) where

#include "MachDeps.h"

import GHC.Classes
import GHC.Maybe
import GHC.Types
import GHC.Prim
import {-# SOURCE #-} GHC.Exception.Type (underflowException, divZeroException)
#if defined(MIN_VERSION_integer_gmp)
import GHC.Integer.GMP.Internals
#else
import GHC.Integer
#endif

default ()

-- Most high-level operations need to be marked `NOINLINE` as
-- otherwise GHC doesn't recognize them and fails to apply constant
-- folding to `Natural`-typed expression.
--
-- To this end, the CPP hack below allows to write the pseudo-pragma
--
--   {-# CONSTANT_FOLDED plusNatural #-}
--
-- which is simply expanded into a
--
--   {-# NOINLINE plusNatural #-}
--
--
-- TODO: Note that some functions have commented CONSTANT_FOLDED annotations,
-- that's because the Integer counter-parts of these functions do actually have
-- a builtinRule in PrelRules, where the Natural functions do not. The plan is
-- to eventually also add builtin rules for those functions on Natural.
#define CONSTANT_FOLDED NOINLINE

-------------------------------------------------------------------------------
-- Arithmetic underflow
-------------------------------------------------------------------------------

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

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

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

-------------------------------------------------------------------------------
-- Natural type
-------------------------------------------------------------------------------

#if defined(MIN_VERSION_integer_gmp)
-- TODO: if saturated arithmetic is to used, replace 'underflowError' by '0'

-- | Type representing arbitrary-precision non-negative integers.
--
-- >>> 2^100 :: Natural
-- 1267650600228229401496703205376
--
-- Operations whose result would be negative @'Control.Exception.throw'
-- ('Control.Exception.Underflow' :: 'Control.Exception.ArithException')@,
--
-- >>> -1 :: Natural
-- *** Exception: arithmetic underflow
--
-- @since 4.8.0.0
data Natural = NatS#                 GmpLimb# -- ^ in @[0, maxBound::Word]@
             | NatJ# {-# UNPACK #-} !BigNat   -- ^ in @]maxBound::Word, +inf[@
                                              --
                                              -- __Invariant__: 'NatJ#' is used
                                              -- /iff/ value doesn't fit in
                                              -- 'NatS#' constructor.
                               -- NB: Order of constructors *must*
                               -- coincide with 'Ord' relation
             deriving ( Eq  -- ^ @since 4.8.0.0
                      , Ord -- ^ @since 4.8.0.0
                      )

-- | Test whether all internal invariants are satisfied by 'Natural' value
--
-- This operation is mostly useful for test-suites and/or code which
-- constructs 'Integer' values directly.
--
-- @since 4.8.0.0
isValidNatural :: Natural -> Bool
isValidNatural (NatS# _)  = True
isValidNatural (NatJ# bn) = isTrue# (isValidBigNat# bn)
                            && isTrue# (sizeofBigNat# bn ># 0#)

signumNatural :: Natural -> Natural
signumNatural (NatS# 0##) = NatS# 0##
signumNatural _           = NatS# 1##
-- {-# CONSTANT_FOLDED signumNatural #-}

negateNatural :: Natural -> Natural
negateNatural (NatS# 0##) = NatS# 0##
negateNatural _           = underflowError
-- {-# CONSTANT_FOLDED negateNatural #-}

-- | @since 4.10.0.0
naturalFromInteger :: Integer -> Natural
naturalFromInteger (S# i#)
  | isTrue# (i# >=# 0#)     = NatS# (int2Word# i#)
naturalFromInteger (Jp# bn) = bigNatToNatural bn
naturalFromInteger _        = underflowError
{-# CONSTANT_FOLDED naturalFromInteger #-}

-- | Compute greatest common divisor.
gcdNatural :: Natural -> Natural -> Natural
gcdNatural (NatS# 0##) y       = y
gcdNatural x       (NatS# 0##) = x
gcdNatural (NatS# 1##) _       = NatS# 1##
gcdNatural _       (NatS# 1##) = NatS# 1##
gcdNatural (NatJ# x) (NatJ# y) = bigNatToNatural (gcdBigNat x y)
gcdNatural (NatJ# x) (NatS# y) = NatS# (gcdBigNatWord x y)
gcdNatural (NatS# x) (NatJ# y) = NatS# (gcdBigNatWord y x)
gcdNatural (NatS# x) (NatS# y) = NatS# (gcdWord x y)

-- | Compute least common multiple.
lcmNatural :: Natural -> Natural -> Natural
lcmNatural (NatS# 0##) _ = NatS# 0##
lcmNatural _ (NatS# 0##) = NatS# 0##
lcmNatural (NatS# 1##) y = y
lcmNatural x (NatS# 1##) = x
lcmNatural x y           = (x `quotNatural` (gcdNatural x y)) `timesNatural` y

----------------------------------------------------------------------------

quotRemNatural :: Natural -> Natural -> (Natural, Natural)
quotRemNatural _ (NatS# 0##) = divZeroError
quotRemNatural n (NatS# 1##) = (n,NatS# 0##)
quotRemNatural n@(NatS# _) (NatJ# _) = (NatS# 0##, n)
quotRemNatural (NatS# n) (NatS# d) = case quotRemWord# n d of
    (# q, r #) -> (NatS# q, NatS# r)
quotRemNatural (NatJ# n) (NatS# d) = case quotRemBigNatWord n d of
    (# q, r #) -> (bigNatToNatural q, NatS# r)
quotRemNatural (NatJ# n) (NatJ# d) = case quotRemBigNat n d of
    (# q, r #) -> (bigNatToNatural q, bigNatToNatural r)
-- {-# CONSTANT_FOLDED quotRemNatural #-}

quotNatural :: Natural -> Natural -> Natural
quotNatural _       (NatS# 0##) = divZeroError
quotNatural n       (NatS# 1##) = n
quotNatural (NatS# _) (NatJ# _) = NatS# 0##
quotNatural (NatS# n) (NatS# d) = NatS# (quotWord# n d)
quotNatural (NatJ# n) (NatS# d) = bigNatToNatural (quotBigNatWord n d)
quotNatural (NatJ# n) (NatJ# d) = bigNatToNatural (quotBigNat n d)
-- {-# CONSTANT_FOLDED quotNatural #-}

remNatural :: Natural -> Natural -> Natural
remNatural _         (NatS# 0##) = divZeroError
remNatural _         (NatS# 1##) = NatS# 0##
remNatural n@(NatS# _) (NatJ# _) = n
remNatural   (NatS# n) (NatS# d) = NatS# (remWord# n d)
remNatural   (NatJ# n) (NatS# d) = NatS# (remBigNatWord n d)
remNatural   (NatJ# n) (NatJ# d) = bigNatToNatural (remBigNat n d)
-- {-# CONSTANT_FOLDED remNatural #-}

-- | @since 4.X.0.0
naturalToInteger :: Natural -> Integer
naturalToInteger (NatS# w)  = wordToInteger w
naturalToInteger (NatJ# bn) = Jp# bn
{-# CONSTANT_FOLDED naturalToInteger #-}

andNatural :: Natural -> Natural -> Natural
andNatural (NatS# n) (NatS# m) = NatS# (n `and#` m)
andNatural (NatS# n) (NatJ# m) = NatS# (n `and#` bigNatToWord m)
andNatural (NatJ# n) (NatS# m) = NatS# (bigNatToWord n `and#` m)
andNatural (NatJ# n) (NatJ# m) = bigNatToNatural (andBigNat n m)
-- {-# CONSTANT_FOLDED andNatural #-}

orNatural :: Natural -> Natural -> Natural
orNatural (NatS# n) (NatS# m) = NatS# (n `or#` m)
orNatural (NatS# n) (NatJ# m) = NatJ# (orBigNat (wordToBigNat n) m)
orNatural (NatJ# n) (NatS# m) = NatJ# (orBigNat n (wordToBigNat m))
orNatural (NatJ# n) (NatJ# m) = NatJ# (orBigNat n m)
-- {-# CONSTANT_FOLDED orNatural #-}

xorNatural :: Natural -> Natural -> Natural
xorNatural (NatS# n) (NatS# m) = NatS# (n `xor#` m)
xorNatural (NatS# n) (NatJ# m) = NatJ# (xorBigNat (wordToBigNat n) m)
xorNatural (NatJ# n) (NatS# m) = NatJ# (xorBigNat n (wordToBigNat m))
xorNatural (NatJ# n) (NatJ# m) = bigNatToNatural (xorBigNat n m)
-- {-# CONSTANT_FOLDED xorNatural #-}

bitNatural :: Int# -> Natural
bitNatural i#
  | isTrue# (i# <# WORD_SIZE_IN_BITS#) = NatS# (1## `uncheckedShiftL#` i#)
  | True                               = NatJ# (bitBigNat i#)
-- {-# CONSTANT_FOLDED bitNatural #-}

testBitNatural :: Natural -> Int -> Bool
testBitNatural (NatS# w) (I# i#)
  | isTrue# (i# <# WORD_SIZE_IN_BITS#) =
      isTrue# ((w `and#` (1## `uncheckedShiftL#` i#)) `neWord#` 0##)
  | True                               = False
testBitNatural (NatJ# bn) (I# i#)      = testBitBigNat bn i#
-- {-# CONSTANT_FOLDED testBitNatural #-}

popCountNatural :: Natural -> Int
popCountNatural (NatS# w)  = I# (word2Int# (popCnt# w))
popCountNatural (NatJ# bn) = I# (popCountBigNat bn)
-- {-# CONSTANT_FOLDED popCountNatural #-}

shiftLNatural :: Natural -> Int -> Natural
shiftLNatural n           (I# 0#) = n
shiftLNatural (NatS# 0##) _       = NatS# 0##
shiftLNatural (NatS# 1##) (I# i#) = bitNatural i#
shiftLNatural (NatS# w) (I# i#)
    = bigNatToNatural (shiftLBigNat (wordToBigNat w) i#)
shiftLNatural (NatJ# bn) (I# i#)
    = bigNatToNatural (shiftLBigNat bn i#)
-- {-# CONSTANT_FOLDED shiftLNatural #-}

shiftRNatural :: Natural -> Int -> Natural
shiftRNatural n          (I# 0#) = n
shiftRNatural (NatS# w)  (I# i#)
      | isTrue# (i# >=# WORD_SIZE_IN_BITS#) = NatS# 0##
      | True = NatS# (w `uncheckedShiftRL#` i#)
shiftRNatural (NatJ# bn) (I# i#) = bigNatToNatural (shiftRBigNat bn i#)
-- {-# CONSTANT_FOLDED shiftRNatural #-}

----------------------------------------------------------------------------

-- | 'Natural' Addition
plusNatural :: Natural -> Natural -> Natural
plusNatural (NatS# 0##) y         = y
plusNatural x         (NatS# 0##) = x
plusNatural (NatS# x) (NatS# y)
    = case plusWord2# x y of
       (# 0##, l #) -> NatS# l
       (# h,   l #) -> NatJ# (wordToBigNat2 h l)
plusNatural (NatS# x) (NatJ# y) = NatJ# (plusBigNatWord y x)
plusNatural (NatJ# x) (NatS# y) = NatJ# (plusBigNatWord x y)
plusNatural (NatJ# x) (NatJ# y) = NatJ# (plusBigNat     x y)
{-# CONSTANT_FOLDED plusNatural #-}

-- | 'Natural' multiplication
timesNatural :: Natural -> Natural -> Natural
timesNatural _         (NatS# 0##) = NatS# 0##
timesNatural (NatS# 0##) _         = NatS# 0##
timesNatural x         (NatS# 1##) = x
timesNatural (NatS# 1##) y         = y
timesNatural (NatS# x) (NatS# y) = case timesWord2# x y of
    (# 0##, 0## #) -> NatS# 0##
    (# 0##, xy  #) -> NatS# xy
    (# h  , l   #) -> NatJ# (wordToBigNat2 h l)
timesNatural (NatS# x) (NatJ# y) = NatJ# (timesBigNatWord y x)
timesNatural (NatJ# x) (NatS# y) = NatJ# (timesBigNatWord x y)
timesNatural (NatJ# x) (NatJ# y) = NatJ# (timesBigNat     x y)
{-# CONSTANT_FOLDED timesNatural #-}

-- | 'Natural' subtraction. May @'Control.Exception.throw'
-- 'Control.Exception.Underflow'@.
minusNatural :: Natural -> Natural -> Natural
minusNatural x         (NatS# 0##) = x
minusNatural (NatS# x) (NatS# y) = case subWordC# x y of
    (# l, 0# #) -> NatS# l
    _           -> underflowError
minusNatural (NatS# _) (NatJ# _) = underflowError
minusNatural (NatJ# x) (NatS# y)
    = bigNatToNatural (minusBigNatWord x y)
minusNatural (NatJ# x) (NatJ# y)
    = bigNatToNatural (minusBigNat     x y)
{-# CONSTANT_FOLDED minusNatural #-}

-- | 'Natural' subtraction. Returns 'Nothing's for non-positive results.
--
-- @since 4.8.0.0
minusNaturalMaybe :: Natural -> Natural -> Maybe Natural
minusNaturalMaybe x         (NatS# 0##) = Just x
minusNaturalMaybe (NatS# x) (NatS# y) = case subWordC# x y of
    (# l, 0# #) -> Just (NatS# l)
    _           -> Nothing
minusNaturalMaybe (NatS# _) (NatJ# _) = Nothing
minusNaturalMaybe (NatJ# x) (NatS# y)
    = Just (bigNatToNatural (minusBigNatWord x y))
minusNaturalMaybe (NatJ# x) (NatJ# y)
  | isTrue# (isNullBigNat# res) = Nothing
  | True                        = Just (bigNatToNatural res)
  where
    res = minusBigNat x y

-- | Convert 'BigNat' to 'Natural'.
-- Throws 'Control.Exception.Underflow' if passed a 'nullBigNat'.
bigNatToNatural :: BigNat -> Natural
bigNatToNatural bn
  | isTrue# (sizeofBigNat# bn ==# 1#) = NatS# (bigNatToWord bn)
  | isTrue# (isNullBigNat# bn)        = underflowError
  | True                              = NatJ# bn

naturalToBigNat :: Natural -> BigNat
naturalToBigNat (NatS# w#) = wordToBigNat w#
naturalToBigNat (NatJ# bn) = bn

naturalToWord :: Natural -> Word
naturalToWord (NatS# w#) = W# w#
naturalToWord (NatJ# bn) = W# (bigNatToWord bn)

naturalToInt :: Natural -> Int
naturalToInt (NatS# w#) = I# (word2Int# w#)
naturalToInt (NatJ# bn) = I# (bigNatToInt bn)

----------------------------------------------------------------------------

-- | Convert a Word# into a Natural
--
-- Built-in rule ensures that applications of this function to literal Word# are
-- lifted into Natural literals.
wordToNatural# :: Word# -> Natural
wordToNatural# w# = NatS# w#
{-# CONSTANT_FOLDED wordToNatural# #-}

-- | Convert a Word# into a Natural
--
-- In base we can't use wordToNatural# as built-in rules transform some of them
-- into Natural literals. Use this function instead.
wordToNaturalBase :: Word# -> Natural
wordToNaturalBase w# = NatS# w#

#else /* !defined(MIN_VERSION_integer_gmp) */
----------------------------------------------------------------------------
-- Use wrapped 'Integer' as fallback; taken from Edward Kmett's nats package

-- | Type representing arbitrary-precision non-negative integers.
--
-- Operations whose result would be negative @'Control.Exception.throw'
-- ('Control.Exception.Underflow' :: 'Control.Exception.ArithException')@.
--
-- @since 4.8.0.0
newtype Natural = Natural Integer -- ^ __Invariant__: non-negative 'Integer'
                  deriving (Eq,Ord)

-- | Test whether all internal invariants are satisfied by 'Natural' value
--
-- This operation is mostly useful for test-suites and/or code which
-- constructs 'Natural' values directly.
--
-- @since 4.8.0.0
isValidNatural :: Natural -> Bool
isValidNatural (Natural i) = i >= wordToInteger 0##

-- | Convert a 'Word#' into a 'Natural'
--
-- Built-in rule ensures that applications of this function to literal 'Word#'
-- are lifted into 'Natural' literals.
wordToNatural# :: Word# -> Natural
wordToNatural# w## = Natural (wordToInteger w##)
{-# CONSTANT_FOLDED wordToNatural# #-}

-- | Convert a 'Word#' into a Natural
--
-- In base we can't use wordToNatural# as built-in rules transform some of them
-- into Natural literals. Use this function instead.
wordToNaturalBase :: Word# -> Natural
wordToNaturalBase w## = Natural (wordToInteger w##)

-- | @since 4.10.0.0
naturalFromInteger :: Integer -> Natural
naturalFromInteger n
  | n >= wordToInteger 0## = Natural n
  | True                   = underflowError
{-# INLINE naturalFromInteger #-}

-- | Compute greatest common divisor.
gcdNatural :: Natural -> Natural -> Natural
gcdNatural (Natural n) (Natural m) = Natural (n `gcdInteger` m)

-- | Compute lowest common multiple.
lcmNatural :: Natural -> Natural -> Natural
lcmNatural (Natural n) (Natural m) = Natural (n `lcmInteger` m)

-- | 'Natural' subtraction. Returns 'Nothing's for non-positive results.
--
-- @since 4.8.0.0
minusNaturalMaybe :: Natural -> Natural -> Maybe Natural
minusNaturalMaybe (Natural x) (Natural y)
  | x >= y  = Just (Natural (x `minusInteger` y))
  | True    = Nothing

shiftLNatural :: Natural -> Int -> Natural
shiftLNatural (Natural n) (I# i) = Natural (n `shiftLInteger` i)
-- {-# CONSTANT_FOLDED shiftLNatural #-}

shiftRNatural :: Natural -> Int -> Natural
shiftRNatural (Natural n) (I# i) = Natural (n `shiftRInteger` i)
-- {-# CONSTANT_FOLDED shiftRNatural #-}

plusNatural :: Natural -> Natural -> Natural
plusNatural (Natural x) (Natural y) = Natural (x `plusInteger` y)
{-# CONSTANT_FOLDED plusNatural #-}

minusNatural :: Natural -> Natural -> Natural
minusNatural (Natural x) (Natural y)
  = if z `ltInteger` wordToInteger 0## then underflowError else Natural z
  where z = x `minusInteger` y
{-# CONSTANT_FOLDED minusNatural #-}

timesNatural :: Natural -> Natural -> Natural
timesNatural (Natural x) (Natural y) = Natural (x `timesInteger` y)
{-# CONSTANT_FOLDED timesNatural #-}

orNatural :: Natural -> Natural -> Natural
orNatural (Natural x) (Natural y) = Natural (x `orInteger` y)
-- {-# CONSTANT_FOLDED orNatural #-}

xorNatural :: Natural -> Natural -> Natural
xorNatural (Natural x) (Natural y) = Natural (x `xorInteger` y)
-- {-# CONSTANT_FOLDED xorNatural #-}

andNatural :: Natural -> Natural -> Natural
andNatural (Natural x) (Natural y) = Natural (x `andInteger` y)
-- {-# CONSTANT_FOLDED andNatural #-}

naturalToInt :: Natural -> Int
naturalToInt (Natural i) = I# (integerToInt i)

naturalToWord :: Natural -> Word
naturalToWord (Natural i) = W# (integerToWord i)

naturalToInteger :: Natural -> Integer
naturalToInteger (Natural i) = i
{-# CONSTANT_FOLDED naturalToInteger #-}

testBitNatural :: Natural -> Int -> Bool
testBitNatural (Natural n) (I# i) = testBitInteger n i
-- {-# CONSTANT_FOLDED testBitNatural #-}

popCountNatural :: Natural -> Int
popCountNatural (Natural n) = I# (popCountInteger n)

bitNatural :: Int# -> Natural
bitNatural i#
  | isTrue# (i# <# WORD_SIZE_IN_BITS#) = wordToNaturalBase (1## `uncheckedShiftL#` i#)
  | True                               = Natural (1 `shiftLInteger` i#)
-- {-# CONSTANT_FOLDED bitNatural #-}

quotNatural :: Natural -> Natural -> Natural
quotNatural n@(Natural x) (Natural y)
   | y == wordToInteger 0## = divZeroError
   | y == wordToInteger 1## = n
   | True                   = Natural (x `quotInteger` y)
-- {-# CONSTANT_FOLDED quotNatural #-}

remNatural :: Natural -> Natural -> Natural
remNatural (Natural x) (Natural y)
   | y == wordToInteger 0## = divZeroError
   | y == wordToInteger 1## = wordToNaturalBase 0##
   | True                   = Natural (x `remInteger` y)
-- {-# CONSTANT_FOLDED remNatural #-}

quotRemNatural :: Natural -> Natural -> (Natural, Natural)
quotRemNatural n@(Natural x) (Natural y)
   | y == wordToInteger 0## = divZeroError
   | y == wordToInteger 1## = (n,wordToNaturalBase 0##)
   | True                   = case quotRemInteger x y of
      (# k, r #) -> (Natural k, Natural r)
-- {-# CONSTANT_FOLDED quotRemNatural #-}

signumNatural :: Natural -> Natural
signumNatural (Natural x)
   | x == wordToInteger 0## = wordToNaturalBase 0##
   | True                   = wordToNaturalBase 1##
-- {-# CONSTANT_FOLDED signumNatural #-}

negateNatural :: Natural -> Natural
negateNatural (Natural x)
   | x == wordToInteger 0## = wordToNaturalBase 0##
   | True                   = underflowError
-- {-# CONSTANT_FOLDED negateNatural #-}

#endif

-- | Construct 'Natural' from 'Word' value.
--
-- @since 4.8.0.0
wordToNatural :: Word -> Natural
wordToNatural (W# w#) = wordToNatural# w#

-- | Try downcasting 'Natural' to 'Word' value.
-- Returns 'Nothing' if value doesn't fit in 'Word'.
--
-- @since 4.8.0.0
naturalToWordMaybe :: Natural -> Maybe Word
#if defined(MIN_VERSION_integer_gmp)
naturalToWordMaybe (NatS# w#) = Just (W# w#)
naturalToWordMaybe (NatJ# _)  = Nothing
#else
naturalToWordMaybe (Natural i)
  | i < maxw  = Just (W# (integerToWord i))
  | True      = Nothing
  where
    maxw = 1 `shiftLInteger` WORD_SIZE_IN_BITS#
#endif

-- | \"@'powModNatural' /b/ /e/ /m/@\" computes base @/b/@ raised to
-- exponent @/e/@ modulo @/m/@.
--
-- @since 4.8.0.0
powModNatural :: Natural -> Natural -> Natural -> Natural
#if defined(MIN_VERSION_integer_gmp)
powModNatural _           _           (NatS# 0##) = divZeroError
powModNatural _           _           (NatS# 1##) = NatS# 0##
powModNatural _           (NatS# 0##) _           = NatS# 1##
powModNatural (NatS# 0##) _           _           = NatS# 0##
powModNatural (NatS# 1##) _           _           = NatS# 1##
powModNatural (NatS# b)   (NatS# e)   (NatS# m)   = NatS# (powModWord b e m)
powModNatural b           e           (NatS# m)
  = NatS# (powModBigNatWord (naturalToBigNat b) (naturalToBigNat e) m)
powModNatural b           e           (NatJ# m)
  = bigNatToNatural (powModBigNat (naturalToBigNat b) (naturalToBigNat e) m)
#else
-- Portable reference fallback implementation
powModNatural (Natural b0) (Natural e0) (Natural m)
   | m  == wordToInteger 0## = divZeroError
   | m  == wordToInteger 1## = wordToNaturalBase 0##
   | e0 == wordToInteger 0## = wordToNaturalBase 1##
   | b0 == wordToInteger 0## = wordToNaturalBase 0##
   | b0 == wordToInteger 1## = wordToNaturalBase 1##
   | True    = go b0 e0 (wordToInteger 1##)
  where
    go !b e !r
      | e `testBitInteger` 0#  = go b' e' ((r `timesInteger` b) `modInteger` m)
      | e == wordToInteger 0## = naturalFromInteger r
      | True                   = go b' e' r
      where
        b' = (b `timesInteger` b) `modInteger` m
        e' = e `shiftRInteger` 1# -- slightly faster than "e `div` 2"
#endif

-- | Construct 'Natural' value from list of 'Word's.
--
-- This function is used by GHC for constructing 'Natural' literals.
mkNatural :: [Word]  -- ^ value expressed in 32 bit chunks, least
                     --   significant first
          -> Natural
mkNatural [] = wordToNaturalBase 0##
mkNatural (W# i : is') = wordToNaturalBase (i `and#` 0xffffffff##) `orNatural`
                         shiftLNatural (mkNatural is') 32
{-# CONSTANT_FOLDED mkNatural #-}

-- | Convert 'Int' to 'Natural'.
-- Throws 'Control.Exception.Underflow' when passed a negative 'Int'.
intToNatural :: Int -> Natural
intToNatural (I# i#)
  | isTrue# (i# <# 0#) = underflowError
  | True               = wordToNaturalBase (int2Word# i#)


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

-----------------------------------------------------------------------------
-- |
-- Module      :  GHC.Num
-- 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 'Num' class and the 'Integer' type.
--
-----------------------------------------------------------------------------

module GHC.Num (module GHC.Num, module GHC.Integer, module GHC.Natural) where

#include "MachDeps.h"

import GHC.Base
import GHC.Integer
import GHC.Natural

infixl 7  *
infixl 6  +, -

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

-- | Basic numeric class.
--
-- The Haskell Report defines no laws for 'Num'. However, @('+')@ and @('*')@ are
-- customarily expected to define a ring and have the following properties:
--
-- [__Associativity of @('+')@__]: @(x + y) + z@ = @x + (y + z)@
-- [__Commutativity of @('+')@__]: @x + y@ = @y + x@
-- [__@'fromInteger' 0@ is the additive identity__]: @x + fromInteger 0@ = @x@
-- [__'negate' gives the additive inverse__]: @x + negate x@ = @fromInteger 0@
-- [__Associativity of @('*')@__]: @(x * y) * z@ = @x * (y * z)@
-- [__@'fromInteger' 1@ is the multiplicative identity__]:
-- @x * fromInteger 1@ = @x@ and @fromInteger 1 * x@ = @x@
-- [__Distributivity of @('*')@ with respect to @('+')@__]:
-- @a * (b + c)@ = @(a * b) + (a * c)@ and @(b + c) * a@ = @(b * a) + (c * a)@
--
-- Note that it /isn't/ customarily expected that a type instance of both 'Num'
-- and 'Ord' implement an ordered ring. Indeed, in @base@ only 'Integer' and
-- 'Data.Ratio.Rational' do.
class  Num a  where
    {-# MINIMAL (+), (*), abs, signum, fromInteger, (negate | (-)) #-}

    (+), (-), (*)       :: a -> a -> a
    -- | Unary negation.
    negate              :: a -> a
    -- | Absolute value.
    abs                 :: a -> a
    -- | Sign of a number.
    -- The functions 'abs' and 'signum' should satisfy the law:
    --
    -- > abs x * signum x == x
    --
    -- For real numbers, the 'signum' is either @-1@ (negative), @0@ (zero)
    -- or @1@ (positive).
    signum              :: a -> a
    -- | Conversion from an 'Integer'.
    -- An integer literal represents the application of the function
    -- 'fromInteger' to the appropriate value of type 'Integer',
    -- so such literals have type @('Num' a) => a@.
    fromInteger         :: Integer -> a

    {-# INLINE (-) #-}
    {-# INLINE negate #-}
    x - y               = x + negate y
    negate x            = 0 - x

-- | the same as @'flip' ('-')@.
--
-- Because @-@ is treated specially in the Haskell grammar,
-- @(-@ /e/@)@ is not a section, but an application of prefix negation.
-- However, @('subtract'@ /exp/@)@ is equivalent to the disallowed section.
{-# INLINE subtract #-}
subtract :: (Num a) => a -> a -> a
subtract x y = y - x

-- | @since 2.01
instance  Num Int  where
    I# x + I# y = I# (x +# y)
    I# x - I# y = I# (x -# y)
    negate (I# x) = I# (negateInt# x)
    I# x * I# y = I# (x *# y)
    abs n  = if n `geInt` 0 then n else negate n

    signum n | n `ltInt` 0 = negate 1
             | n `eqInt` 0 = 0
             | otherwise   = 1

    {-# INLINE fromInteger #-}   -- Just to be sure!
    fromInteger i = I# (integerToInt i)

-- | @since 2.01
instance Num Word where
    (W# x#) + (W# y#)      = W# (x# `plusWord#` y#)
    (W# x#) - (W# y#)      = W# (x# `minusWord#` y#)
    (W# x#) * (W# y#)      = W# (x# `timesWord#` y#)
    negate (W# x#)         = W# (int2Word# (negateInt# (word2Int# x#)))
    abs x                  = x
    signum 0               = 0
    signum _               = 1
    fromInteger i          = W# (integerToWord i)

-- | @since 2.01
instance  Num Integer  where
    (+) = plusInteger
    (-) = minusInteger
    (*) = timesInteger
    negate         = negateInteger
    fromInteger x  =  x

    abs = absInteger
    signum = signumInteger

-- | Note that `Natural`'s 'Num' instance isn't a ring: no element but 0 has an
-- additive inverse. It is a semiring though.
--
-- @since 4.8.0.0
instance  Num Natural  where
    (+) = plusNatural
    (-) = minusNatural
    (*) = timesNatural
    negate      = negateNatural
    fromInteger = naturalFromInteger

    abs = id
    signum = signumNatural


{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE Safe #-}

-----------------------------------------------------------------------------
-- |
-- Module      :  GHC.OldList
-- Copyright   :  (c) The University of Glasgow 2001
-- License     :  BSD-style (see the file libraries/base/LICENSE)
--
-- Maintainer  :  libraries@haskell.org
-- Stability   :  experimental
-- Portability :  portable
--
-- This legacy module provides access to the list-specialised operations
-- of "Data.List". This module may go away again in future GHC versions and
-- is provided as transitional tool to access some of the list-specialised
-- operations that had to be generalised due to the implementation of the
-- <https://wiki.haskell.org/Foldable_Traversable_In_Prelude Foldable/Traversable-in-Prelude Proposal (FTP)>.
--
-- If the operations needed are available in "GHC.List", it's
-- recommended to avoid importing this module and use "GHC.List"
-- instead for now.
--
-- @since 4.8.0.0
-----------------------------------------------------------------------------

module GHC.OldList (module Data.OldList) where

import Data.OldList


{-# LANGUAGE AllowAmbiguousTypes
           , DataKinds
           , FlexibleInstances
           , KindSignatures
           , MultiParamTypeClasses
           , ScopedTypeVariables
           , TypeApplications
  #-}

-----------------------------------------------------------------------------
-- |
-- Module      :  GHC.OverloadedLabels
-- 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 'IsLabel' class is used by the
-- @OverloadedLabels@ extension.  See the
-- <https://ghc.haskell.org/trac/ghc/wiki/Records/OverloadedRecordFields/OverloadedLabels wiki page>
-- for more details.
--
-- When @OverloadedLabels@ is enabled, if GHC sees an occurrence of
-- the overloaded label syntax @#foo@, it is replaced with
--
-- > fromLabel @"foo" :: alpha
--
-- plus a wanted constraint @IsLabel "foo" alpha@.
--
-- Note that if @RebindableSyntax@ is enabled, the desugaring of
-- overloaded label syntax will make use of whatever @fromLabel@ is in
-- scope.
--
-----------------------------------------------------------------------------

-- Note [Overloaded labels]
-- ~~~~~~~~~~~~~~~~~~~~~~~~
-- An overloaded label is represented by the 'HsOverLabel' constructor
-- of 'HsExpr', which stores the 'FastString' text of the label and an
-- optional id for the 'fromLabel' function to use (if
-- RebindableSyntax is enabled) .  The type-checker transforms it into
-- a call to 'fromLabel'.  See Note [Type-checking overloaded labels]
-- in TcExpr for more details in how type-checking works.

module GHC.OverloadedLabels
       ( IsLabel(..)
       ) where

import GHC.Base ( Symbol )

class IsLabel (x :: Symbol) a where
  fromLabel :: a


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

-----------------------------------------------------------------------------
-- |
-- Module      :  GHC.Pack
-- Copyright   :  (c) The University of Glasgow 1997-2002
-- License     :  see libraries/base/LICENSE
--
-- Maintainer  :  cvs-ghc@haskell.org
-- Stability   :  internal
-- Portability :  non-portable (GHC Extensions)
--
-- This module provides a small set of low-level functions for packing
-- and unpacking a chunk of bytes. Used by code emitted by the compiler
-- plus the prelude libraries.
--
-- The programmer level view of packed strings is provided by a GHC
-- system library PackedString.
--
-----------------------------------------------------------------------------

module GHC.Pack
       (
        -- (**) - emitted by compiler.

        packCString#,
        unpackCString,
        unpackCString#,
        unpackNBytes#,
        unpackFoldrCString#,  -- (**)
        unpackAppendCString#,  -- (**)
       )
        where

import GHC.Base
import GHC.List ( length )
import GHC.ST
import GHC.Ptr

data ByteArray ix              = ByteArray        ix ix ByteArray#
data MutableByteArray s ix     = MutableByteArray ix ix (MutableByteArray# s)

unpackCString :: Ptr a -> [Char]
unpackCString a@(Ptr addr)
  | a == nullPtr  = []
  | otherwise      = unpackCString# addr

packCString#         :: [Char]          -> ByteArray#
packCString# str = case (packString str) of { ByteArray _ _ bytes -> bytes }

packString :: [Char] -> ByteArray Int
packString str = runST (packStringST str)

packStringST :: [Char] -> ST s (ByteArray Int)
packStringST str =
  let len = length str  in
  packNBytesST len str

packNBytesST :: Int -> [Char] -> ST s (ByteArray Int)
packNBytesST (I# length#) str =
  {-
   allocate an array that will hold the string
   (not forgetting the NUL byte at the end)
  -}
 new_ps_array (length# +# 1#) >>= \ ch_array ->
   -- fill in packed string from "str"
 fill_in ch_array 0# str   >>
   -- freeze the puppy:
 freeze_ps_array ch_array length#
 where
  fill_in :: MutableByteArray s Int -> Int# -> [Char] -> ST s ()
  fill_in arr_in# idx [] =
   write_ps_array arr_in# idx (chr# 0#) >>
   return ()

  fill_in arr_in# idx (C# c : cs) =
   write_ps_array arr_in# idx c  >>
   fill_in arr_in# (idx +# 1#) cs

-- (Very :-) ``Specialised'' versions of some CharArray things...

new_ps_array    :: Int# -> ST s (MutableByteArray s Int)
write_ps_array  :: MutableByteArray s Int -> Int# -> Char# -> ST s ()
freeze_ps_array :: MutableByteArray s Int -> Int# -> ST s (ByteArray Int)

new_ps_array size = ST $ \ s ->
    case (newByteArray# size s)   of { (# s2#, barr# #) ->
    (# s2#, MutableByteArray bot bot barr# #) }
  where
    bot = errorWithoutStackTrace "new_ps_array"

write_ps_array (MutableByteArray _ _ barr#) n ch = ST $ \ s# ->
    case writeCharArray# barr# n ch s#  of { s2#   ->
    (# s2#, () #) }

-- same as unsafeFreezeByteArray
freeze_ps_array (MutableByteArray _ _ arr#) len# = ST $ \ s# ->
    case unsafeFreezeByteArray# arr# s# of { (# s2#, frozen# #) ->
    (# s2#, ByteArray 0 (I# len#) frozen# #) }


{-# LANGUAGE Trustworthy #-}
{-# LANGUAGE NoImplicitPrelude #-}

-- | @since 4.7.0.0
module GHC.Profiling where

import GHC.Base

-- | Stop attributing ticks to cost centres. Allocations will still be
-- attributed.
--
-- @since 4.7.0.0
foreign import ccall stopProfTimer :: IO ()

-- | Start attributing ticks to cost centres. This is called by the RTS on
-- startup.
--
-- @since 4.7.0.0
foreign import ccall startProfTimer :: IO ()


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

-----------------------------------------------------------------------------
-- |
-- Module      :  GHC.Ptr
-- Copyright   :  (c) The FFI Task Force, 2000-2002
-- License     :  see libraries/base/LICENSE
--
-- Maintainer  :  ffi@haskell.org
-- Stability   :  internal
-- Portability :  non-portable (GHC Extensions)
--
-- The 'Ptr' and 'FunPtr' types and operations.
--
-----------------------------------------------------------------------------

module GHC.Ptr (
        Ptr(..), FunPtr(..),
        nullPtr, castPtr, plusPtr, alignPtr, minusPtr,
        nullFunPtr, castFunPtr,

        -- * Unsafe functions
        castFunPtrToPtr, castPtrToFunPtr
    ) where

import GHC.Base
import GHC.Show
import GHC.Num
import GHC.List ( length, replicate )
import Numeric          ( showHex )

#include "MachDeps.h"

------------------------------------------------------------------------
-- Data pointers.

-- The role of Ptr's parameter is phantom, as there is no relation between
-- the Haskell representation and whathever the user puts at the end of the
-- pointer. And phantom is useful to implement castPtr (see #9163)

-- redundant role annotation checks that this doesn't change
type role Ptr phantom
data Ptr a = Ptr Addr#
  deriving ( Eq  -- ^ @since 2.01
           , Ord -- ^ @since 2.01
           )
-- ^ A value of type @'Ptr' a@ represents a pointer to an object, or an
-- array of objects, which may be marshalled to or from Haskell values
-- of type @a@.
--
-- The type @a@ will often be an instance of class
-- 'Foreign.Storable.Storable' which provides the marshalling operations.
-- However this is not essential, and you can provide your own operations
-- to access the pointer.  For example you might write small foreign
-- functions to get or set the fields of a C @struct@.

-- |The constant 'nullPtr' contains a distinguished value of 'Ptr'
-- that is not associated with a valid memory location.
nullPtr :: Ptr a
nullPtr = Ptr nullAddr#

-- |The 'castPtr' function casts a pointer from one type to another.
castPtr :: Ptr a -> Ptr b
castPtr = coerce

-- |Advances the given address by the given offset in bytes.
plusPtr :: Ptr a -> Int -> Ptr b
plusPtr (Ptr addr) (I# d) = Ptr (plusAddr# addr d)

-- |Given an arbitrary address and an alignment constraint,
-- 'alignPtr' yields the next higher address that fulfills the
-- alignment constraint.  An alignment constraint @x@ is fulfilled by
-- any address divisible by @x@.  This operation is idempotent.
alignPtr :: Ptr a -> Int -> Ptr a
alignPtr addr@(Ptr a) (I# i)
  = case remAddr# a i of {
      0# -> addr;
      n -> Ptr (plusAddr# a (i -# n)) }

-- |Computes the offset required to get from the second to the first
-- argument.  We have
--
-- > p2 == p1 `plusPtr` (p2 `minusPtr` p1)
minusPtr :: Ptr a -> Ptr b -> Int
minusPtr (Ptr a1) (Ptr a2) = I# (minusAddr# a1 a2)

------------------------------------------------------------------------
-- Function pointers for the default calling convention.

-- 'FunPtr' has a phantom role for similar reasons to 'Ptr'. Note
-- that 'FunPtr's role cannot become nominal without changes elsewhere
-- in GHC. See Note [FFI type roles] in TcForeign.
type role FunPtr phantom
data FunPtr a = FunPtr Addr# deriving (Eq, Ord)
-- ^ A value of type @'FunPtr' a@ is a pointer to a function callable
-- from foreign code.  The type @a@ will normally be a /foreign type/,
-- a function type with zero or more arguments where
--
-- * the argument types are /marshallable foreign types/,
--   i.e. 'Char', 'Int', 'Double', 'Float',
--   'Bool', 'Data.Int.Int8', 'Data.Int.Int16', 'Data.Int.Int32',
--   'Data.Int.Int64', 'Data.Word.Word8', 'Data.Word.Word16',
--   'Data.Word.Word32', 'Data.Word.Word64', @'Ptr' a@, @'FunPtr' a@,
--   @'Foreign.StablePtr.StablePtr' a@ or a renaming of any of these
--   using @newtype@.
--
-- * the return type is either a marshallable foreign type or has the form
--   @'IO' t@ where @t@ is a marshallable foreign type or @()@.
--
-- A value of type @'FunPtr' a@ may be a pointer to a foreign function,
-- either returned by another foreign function or imported with a
-- a static address import like
--
-- > foreign import ccall "stdlib.h &free"
-- >   p_free :: FunPtr (Ptr a -> IO ())
--
-- or a pointer to a Haskell function created using a /wrapper/ stub
-- declared to produce a 'FunPtr' of the correct type.  For example:
--
-- > type Compare = Int -> Int -> Bool
-- > foreign import ccall "wrapper"
-- >   mkCompare :: Compare -> IO (FunPtr Compare)
--
-- Calls to wrapper stubs like @mkCompare@ allocate storage, which
-- should be released with 'Foreign.Ptr.freeHaskellFunPtr' when no
-- longer required.
--
-- To convert 'FunPtr' values to corresponding Haskell functions, one
-- can define a /dynamic/ stub for the specific foreign type, e.g.
--
-- > type IntFunction = CInt -> IO ()
-- > foreign import ccall "dynamic"
-- >   mkFun :: FunPtr IntFunction -> IntFunction

-- |The constant 'nullFunPtr' contains a
-- distinguished value of 'FunPtr' that is not
-- associated with a valid memory location.
nullFunPtr :: FunPtr a
nullFunPtr = FunPtr nullAddr#

-- |Casts a 'FunPtr' to a 'FunPtr' of a different type.
castFunPtr :: FunPtr a -> FunPtr b
castFunPtr = coerce

-- |Casts a 'FunPtr' to a 'Ptr'.
--
-- /Note:/ this is valid only on architectures where data and function
-- pointers range over the same set of addresses, and should only be used
-- for bindings to external libraries whose interface already relies on
-- this assumption.
castFunPtrToPtr :: FunPtr a -> Ptr b
castFunPtrToPtr (FunPtr addr) = Ptr addr

-- |Casts a 'Ptr' to a 'FunPtr'.
--
-- /Note:/ this is valid only on architectures where data and function
-- pointers range over the same set of addresses, and should only be used
-- for bindings to external libraries whose interface already relies on
-- this assumption.
castPtrToFunPtr :: Ptr a -> FunPtr b
castPtrToFunPtr (Ptr addr) = FunPtr addr

------------------------------------------------------------------------
-- Show instances for Ptr and FunPtr

-- | @since 2.01
instance Show (Ptr a) where
   showsPrec _ (Ptr a) rs = pad_out (showHex (wordToInteger(int2Word#(addr2Int# a))) "")
     where
        -- want 0s prefixed to pad it out to a fixed length.
       pad_out ls =
          '0':'x':(replicate (2*SIZEOF_HSPTR - length ls) '0') ++ ls ++ rs

-- | @since 2.01
instance Show (FunPtr a) where
   showsPrec p = showsPrec p . castFunPtrToPtr