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

-----------------------------------------------------------------------------
-- |
-- Module      :  Control.Monad.ST.Imp
-- 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 (requires universal quantification for runST)
--
-- This library provides support for /strict/ state threads, as
-- described in the PLDI \'94 paper by John Launchbury and Simon Peyton
-- Jones /Lazy Functional State Threads/.
--
-----------------------------------------------------------------------------

module Control.Monad.ST.Imp (
        -- * The 'ST' Monad
        ST,             -- abstract, instance of Functor, Monad, Typeable.
        runST,
        fixST,

        -- * Converting 'ST' to 'Prelude.IO'
        RealWorld,              -- abstract
        stToIO,

        -- * Unsafe operations
        unsafeInterleaveST,
        unsafeDupableInterleaveST,
        unsafeIOToST,
        unsafeSTToIO
    ) where

import GHC.ST           ( ST, runST, unsafeInterleaveST
                        , unsafeDupableInterleaveST )
import GHC.Base         ( RealWorld, ($), return )
import GHC.IO           ( stToIO, unsafeIOToST, unsafeSTToIO
                        , unsafeDupableInterleaveIO )
import GHC.MVar         ( readMVar, putMVar, newEmptyMVar )
import Control.Exception.Base
                        ( catch, throwIO, NonTermination (..)
                        , BlockedIndefinitelyOnMVar (..) )

-- | Allow the result of an 'ST' computation to be used (lazily)
-- inside the computation.
--
-- Note that if @f@ is strict, @'fixST' f = _|_@.
fixST :: (a -> ST s a) -> ST s a
-- See Note [fixST]
fixST k = unsafeIOToST $ do
    m <- newEmptyMVar
    ans <- unsafeDupableInterleaveIO
             (readMVar m `catch` \BlockedIndefinitelyOnMVar ->
                                    throwIO NonTermination)
    result <- unsafeSTToIO (k ans)
    putMVar m result
    return result

{- Note [fixST]
   ~~~~~~~~~~~~

For many years, we implemented fixST much like a pure fixpoint,
using liftST:

  fixST :: (a -> ST s a) -> ST s a
  fixST k = ST $ \ s ->
      let ans       = liftST (k r) s
          STret _ r = ans
      in
      case ans of STret s' x -> (# s', x #)

We knew that lazy blackholing could cause the computation to be re-run if the
result was demanded strictly, but we thought that would be okay in the case of
ST. However, that is not the case (see Trac #15349). Notably, the first time
the computation is executed, it may mutate variables that cause it to behave
*differently* the second time it's run. That may allow it to terminate when it
should not. More frighteningly, Arseniy Alekseyev produced a somewhat contrived
example ( https://mail.haskell.org/pipermail/libraries/2018-July/028889.html )
demonstrating that it can break reasonable assumptions in "trustworthy" code,
causing a memory safety violation. So now we implement fixST much like we do
fixIO. See also the implementation notes for fixIO. Simon Marlow wondered
whether we could get away with an IORef instead of an MVar. I believe we
cannot. The function passed to fixST may spark a parallel computation that
demands the final result. Such a computation should block until the final
result is available.
-}


{-# LANGUAGE Trustworthy #-}

-----------------------------------------------------------------------------
-- |
-- Module      :  Control.Monad.ST.Lazy
-- Copyright   :  (c) The University of Glasgow 2001
-- License     :  BSD-style (see the file libraries/base/LICENSE)
--
-- Maintainer  :  libraries@haskell.org
-- Stability   :  provisional
-- Portability :  non-portable (requires universal quantification for runST)
--
-- This module presents an identical interface to "Control.Monad.ST",
-- except that the monad delays evaluation of state operations until
-- a value depending on them is required.
--
-----------------------------------------------------------------------------

module Control.Monad.ST.Lazy (
        -- * The 'ST' monad
        ST,
        runST,
        fixST,

        -- * Converting between strict and lazy 'ST'
        strictToLazyST, lazyToStrictST,

        -- * Converting 'ST' To 'IO'
        RealWorld,
        stToIO,
    ) where

import Control.Monad.ST.Lazy.Imp


{-# LANGUAGE Trustworthy #-}

-----------------------------------------------------------------------------
-- |
-- Module      :  Control.Monad.ST.Safe
-- 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 (requires universal quantification for runST)
--
-- This library provides support for /strict/ state threads, as
-- described in the PLDI \'94 paper by John Launchbury and Simon Peyton
-- Jones /Lazy Functional State Threads/.
--
-- Safe API Only.
--
-----------------------------------------------------------------------------

module Control.Monad.ST.Safe {-# DEPRECATED "Safe is now the default, please use Control.Monad.ST instead" #-} (
        -- * The 'ST' Monad
        ST,             -- abstract
        runST,
        fixST,

        -- * Converting 'ST' to 'IO'
        RealWorld,              -- abstract
        stToIO,
    ) where

import Control.Monad.ST.Imp


{-# LANGUAGE Safe #-}

-----------------------------------------------------------------------------
-- |
-- Module      :  Control.Monad.ST.Strict
-- Copyright   :  (c) The University of Glasgow 2001
-- License     :  BSD-style (see the file libraries/base/LICENSE)
--
-- Maintainer  :  libraries@haskell.org
-- Stability   :  provisional
-- Portability :  non-portable (requires universal quantification for runST)
--
-- The strict ST monad (re-export of "Control.Monad.ST")
--
-----------------------------------------------------------------------------

module Control.Monad.ST.Strict (
        module Control.Monad.ST
  ) where

import Control.Monad.ST


{-# LANGUAGE Unsafe #-}

-----------------------------------------------------------------------------
-- |
-- Module      :  Control.Monad.ST.Unsafe
-- 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 (requires universal quantification for runST)
--
-- This library provides support for /strict/ state threads, as
-- described in the PLDI \'94 paper by John Launchbury and Simon Peyton
-- Jones /Lazy Functional State Threads/.
--
-- Unsafe API.
--
-----------------------------------------------------------------------------

module Control.Monad.ST.Unsafe (
        -- * Unsafe operations
        unsafeInterleaveST,
        unsafeDupableInterleaveST,
        unsafeIOToST,
        unsafeSTToIO
    ) where

import Control.Monad.ST.Imp


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

-----------------------------------------------------------------------------
-- |
-- Module      :  Control.Monad.ST.Lazy.Imp
-- Copyright   :  (c) The University of Glasgow 2001
-- License     :  BSD-style (see the file libraries/base/LICENSE)
--
-- Maintainer  :  libraries@haskell.org
-- Stability   :  provisional
-- Portability :  non-portable (requires universal quantification for runST)
--
-- This module presents an identical interface to "Control.Monad.ST",
-- except that the monad delays evaluation of 'ST' operations until
-- a value depending on them is required.
--
-----------------------------------------------------------------------------

module Control.Monad.ST.Lazy.Imp (
        -- * The 'ST' monad
        ST,
        runST,
        fixST,

        -- * Converting between strict and lazy 'ST'
        strictToLazyST, lazyToStrictST,

        -- * Converting 'ST' To 'IO'
        RealWorld,
        stToIO,

        -- * Unsafe operations
        unsafeInterleaveST,
        unsafeIOToST
    ) where

import Control.Monad.Fix

import qualified Control.Monad.ST as ST
import qualified Control.Monad.ST.Unsafe as ST

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

-- | The lazy @'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 'stToIO').
--
-- It serves to keep the internal states of different invocations of
-- 'runST' separate from each other and from invocations of 'stToIO'.
--
-- The '>>=' and '>>' operations are not strict in the state.  For example,
--
-- @'runST' (writeSTRef _|_ v >>= readSTRef _|_ >> return 2) = 2@
newtype ST s a = ST { unST :: State s -> (a, State s) }

-- A lifted state token. This can be imagined as a moment in the timeline
-- of a lazy state thread. Forcing the token forces all delayed actions in
-- the thread up until that moment to be performed.
data State s = S# (State# s)

{- Note [Lazy ST and multithreading]

We used to imagine that passing a polymorphic state token was all that we
needed to keep state threads separate (see Launchbury and Peyton Jones, 1994:
https://www.microsoft.com/en-us/research/publication/lazy-functional-state-threads/).
But this breaks down in the face of concurrency (see #11760). Whereas a strict
ST computation runs to completion before producing anything, a value produced
by running a lazy ST computation may contain a thunk that, when forced, will
lead to further stateful computations. If such a thunk is entered by more than
one thread, then they may both read from and write to the same references and
arrays, interfering with each other. To work around this, any time we lazily
suspend execution of a lazy ST computation, we bind the result pair to a
NOINLINE binding (ensuring that it is not duplicated) and calculate that
pair using (unsafePerformIO . evaluate), ensuring that only one thread will
enter the thunk. We still use lifted state tokens to actually drive execution,
so in these cases we effectively deal with *two* state tokens: the lifted
one we get from the previous computation, and the unlifted one we pull out of
thin air. -}

{- Note [Lazy ST: not producing lazy pairs]

The fixST and strictToLazyST functions used to construct functions that
produced lazy pairs. Why don't we need that laziness? The ST type is kept
abstract, so no one outside this module can ever get their hands on a (result,
State s) pair. We ourselves never match on such pairs when performing ST
computations unless we also force one of their components. So no one should be
able to detect the change. By refraining from producing such thunks (which
reference delayed ST computations), we avoid having to ask whether we have to
wrap them up with unsafePerformIO. See Note [Lazy ST and multithreading]. -}

-- | This is a terrible hack to prevent a thunk from being entered twice.
-- Simon Peyton Jones would very much like to be rid of it.
noDup :: a -> a
noDup a = runRW# (\s ->
  case noDuplicate# s of
    _ -> a)

-- | @since 2.01
instance Functor (ST s) where
    fmap f m = ST $ \ s ->
      let
        -- See Note [Lazy ST and multithreading]
        {-# NOINLINE res #-}
        res = noDup (unST m s)
        (r,new_s) = res
      in
        (f r,new_s)

    x <$ m = ST $ \ s ->
      let
        {-# NOINLINE s' #-}
        -- See Note [Lazy ST and multithreading]
        s' = noDup (snd (unST m s))
      in (x, s')

-- | @since 2.01
instance Applicative (ST s) where
    pure a = ST $ \ s -> (a,s)

    fm <*> xm = ST $ \ s ->
       let
         {-# NOINLINE res1 #-}
         !res1 = unST fm s
         !(f, s') = res1

         {-# NOINLINE res2 #-}
         -- See Note [Lazy ST and multithreading]
         res2 = noDup (unST xm s')
         (x, s'') = res2
       in (f x, s'')
    -- Why can we use a strict binding for res1? If someone
    -- forces the (f x, s'') pair, then they must need
    -- f or s''. To get s'', they need s'.

    liftA2 f m n = ST $ \ s ->
      let
        {-# NOINLINE res1 #-}
        -- See Note [Lazy ST and multithreading]
        res1 = noDup (unST m s)
        (x, s') = res1

        {-# NOINLINE res2 #-}
        res2 = noDup (unST n s')
        (y, s'') = res2
      in (f x y, s'')
    -- We don't get to be strict in liftA2, but we clear out a
    -- NOINLINE in comparison to the default definition, which may
    -- help the simplifier.

    m *> n = ST $ \s ->
       let
         {-# NOINLINE s' #-}
         -- See Note [Lazy ST and multithreading]
         s' = noDup (snd (unST m s))
       in unST n s'

    m <* n = ST $ \s ->
       let
         {-# NOINLINE res1 #-}
         !res1 = unST m s
         !(mr, s') = res1

         {-# NOINLINE s'' #-}
         -- See Note [Lazy ST and multithreading]
         s'' = noDup (snd (unST n s'))
       in (mr, s'')
    -- Why can we use a strict binding for res1? The same reason as
    -- in <*>. If someone demands the (mr, s'') pair, then they will
    -- force mr or s''. To get s'', they need s'.

-- | @since 2.01
instance Monad (ST s) where

    fail s   = errorWithoutStackTrace s

    (>>) = (*>)

    m >>= k = ST $ \ s ->
       let
         -- See Note [Lazy ST and multithreading]
         {-# NOINLINE res #-}
         res = noDup (unST m s)
         (r,new_s) = res
       in
         unST (k r) new_s

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

-- | Return the value computed by an 'ST' computation.
-- 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) = runRW# (\s -> case st (S# s) of (r, _) -> r)

-- | Allow the result of an 'ST' computation to be used (lazily)
-- inside the computation.
-- Note that if @f@ is strict, @'fixST' f = _|_@.
fixST :: (a -> ST s a) -> ST s a
fixST m = ST (\ s ->
                let
                   q@(r,_s') = unST (m r) s
                in q)
-- Why don't we need unsafePerformIO in fixST? We create a thunk, q,
-- to perform a lazy state computation, and we pass a reference to that
-- thunk, r, to m. Uh oh? No, I think it should be fine, because that thunk
-- itself is demanded directly in the `let` body. See also
-- Note [Lazy ST: not producing lazy pairs].

-- | @since 2.01
instance MonadFix (ST s) where
        mfix = fixST

-- ---------------------------------------------------------------------------
-- Strict <--> Lazy

{-|
Convert a strict 'ST' computation into a lazy one.  The strict state
thread passed to 'strictToLazyST' is not performed until the result of
the lazy state thread it returns is demanded.
-}
strictToLazyST :: ST.ST s a -> ST s a
strictToLazyST (GHC.ST.ST m) = ST $ \(S# s) ->
  case m s of
    (# s', a #) -> (a, S# s')
-- See Note [Lazy ST: not producing lazy pairs]

{-|
Convert a lazy 'ST' computation into a strict one.
-}
lazyToStrictST :: ST s a -> ST.ST s a
lazyToStrictST (ST m) = GHC.ST.ST $ \s ->
        case (m (S# s)) of (a, S# s') -> (# s', a #)

-- | A monad transformer embedding lazy 'ST' in the 'IO'
-- monad.  The 'RealWorld' parameter indicates that the internal state
-- used by the 'ST' computation is a special one supplied by the 'IO'
-- monad, and thus distinct from those used by invocations of 'runST'.
stToIO :: ST RealWorld a -> IO a
stToIO = ST.stToIO . lazyToStrictST

-- ---------------------------------------------------------------------------
-- Strict <--> Lazy

unsafeInterleaveST :: ST s a -> ST s a
unsafeInterleaveST = strictToLazyST . ST.unsafeInterleaveST . lazyToStrictST

unsafeIOToST :: IO a -> ST s a
unsafeIOToST = strictToLazyST . ST.unsafeIOToST


{-# LANGUAGE Trustworthy #-}

-----------------------------------------------------------------------------
-- |
-- Module      :  Control.Monad.ST.Lazy.Safe
-- Copyright   :  (c) The University of Glasgow 2001
-- License     :  BSD-style (see the file libraries/base/LICENSE)
--
-- Maintainer  :  libraries@haskell.org
-- Stability   :  provisional
-- Portability :  non-portable (requires universal quantification for runST)
--
-- This module presents an identical interface to "Control.Monad.ST",
-- except that the monad delays evaluation of 'ST' operations until
-- a value depending on them is required.
--
-- Safe API only.
--
-----------------------------------------------------------------------------

module Control.Monad.ST.Lazy.Safe {-# DEPRECATED "Safe is now the default, please use Control.Monad.ST.Lazy instead" #-} (
        -- * The 'ST' monad
        ST,
        runST,
        fixST,

        -- * Converting between strict and lazy 'ST'
        strictToLazyST, lazyToStrictST,

        -- * Converting 'ST' To 'IO'
        RealWorld,
        stToIO,
    ) where

import Control.Monad.ST.Lazy.Imp


{-# LANGUAGE Unsafe #-}

-----------------------------------------------------------------------------
-- |
-- Module      :  Control.Monad.ST.Lazy.Unsafe
-- Copyright   :  (c) The University of Glasgow 2001
-- License     :  BSD-style (see the file libraries/base/LICENSE)
--
-- Maintainer  :  libraries@haskell.org
-- Stability   :  provisional
-- Portability :  non-portable (requires universal quantification for runST)
--
-- This module presents an identical interface to "Control.Monad.ST",
-- except that the monad delays evaluation of 'ST' operations until
-- a value depending on them is required.
--
-- Unsafe API.
--
-----------------------------------------------------------------------------

module Control.Monad.ST.Lazy.Unsafe (
        -- * Unsafe operations
        unsafeInterleaveST,
        unsafeIOToST
    ) where

import Control.Monad.ST.Lazy.Imp


{-# LANGUAGE Safe #-}
{-# LANGUAGE ScopedTypeVariables #-}

-----------------------------------------------------------------------------
-- |
-- Module      :  Data.Bifoldable
-- Copyright   :  (C) 2011-2016 Edward Kmett
-- License     :  BSD-style (see the file LICENSE)
--
-- Maintainer  :  libraries@haskell.org
-- Stability   :  provisional
-- Portability :  portable
--
-- @since 4.10.0.0
----------------------------------------------------------------------------
module Data.Bifoldable
  ( Bifoldable(..)
  , bifoldr'
  , bifoldr1
  , bifoldrM
  , bifoldl'
  , bifoldl1
  , bifoldlM
  , bitraverse_
  , bifor_
  , bimapM_
  , biforM_
  , bimsum
  , bisequenceA_
  , bisequence_
  , biasum
  , biList
  , binull
  , bilength
  , bielem
  , bimaximum
  , biminimum
  , bisum
  , biproduct
  , biconcat
  , biconcatMap
  , biand
  , bior
  , biany
  , biall
  , bimaximumBy
  , biminimumBy
  , binotElem
  , bifind
  ) where

import Control.Applicative
import Data.Functor.Utils (Max(..), Min(..), (#.))
import Data.Maybe (fromMaybe)
import Data.Monoid
import GHC.Generics (K1(..))

-- | 'Bifoldable' identifies foldable structures with two different varieties
-- of elements (as opposed to 'Foldable', which has one variety of element).
-- Common examples are 'Either' and '(,)':
--
-- > instance Bifoldable Either where
-- >   bifoldMap f _ (Left  a) = f a
-- >   bifoldMap _ g (Right b) = g b
-- >
-- > instance Bifoldable (,) where
-- >   bifoldr f g z (a, b) = f a (g b z)
--
-- A minimal 'Bifoldable' definition consists of either 'bifoldMap' or
-- 'bifoldr'. When defining more than this minimal set, one should ensure
-- that the following identities hold:
--
-- @
-- 'bifold' â‰¡ 'bifoldMap' 'id' 'id'
-- 'bifoldMap' f g â‰¡ 'bifoldr' ('mappend' . f) ('mappend' . g) 'mempty'
-- 'bifoldr' f g z t â‰¡ 'appEndo' ('bifoldMap' (Endo . f) (Endo . g) t) z
-- @
--
-- If the type is also a 'Data.Bifunctor.Bifunctor' instance, it should satisfy:
--
-- @
-- 'bifoldMap' f g â‰¡ 'bifold' . 'Data.Bifunctor.bimap' f g
-- @
--
-- which implies that
--
-- @
-- 'bifoldMap' f g . 'Data.Bifunctor.bimap' h i â‰¡ 'bifoldMap' (f . h) (g . i)
-- @
--
-- @since 4.10.0.0
class Bifoldable p where
  {-# MINIMAL bifoldr | bifoldMap #-}

  -- | Combines the elements of a structure using a monoid.
  --
  -- @'bifold' â‰¡ 'bifoldMap' 'id' 'id'@
  --
  -- @since 4.10.0.0
  bifold :: Monoid m => p m m -> m
  bifold = bifoldMap id id

  -- | Combines the elements of a structure, given ways of mapping them to a
  -- common monoid.
  --
  -- @'bifoldMap' f g
  --     â‰¡ 'bifoldr' ('mappend' . f) ('mappend' . g) 'mempty'@
  --
  -- @since 4.10.0.0
  bifoldMap :: Monoid m => (a -> m) -> (b -> m) -> p a b -> m
  bifoldMap f g = bifoldr (mappend . f) (mappend . g) mempty

  -- | Combines the elements of a structure in a right associative manner.
  -- Given a hypothetical function @toEitherList :: p a b -> [Either a b]@
  -- yielding a list of all elements of a structure in order, the following
  -- would hold:
  --
  -- @'bifoldr' f g z â‰¡ 'foldr' ('either' f g) z . toEitherList@
  --
  -- @since 4.10.0.0
  bifoldr :: (a -> c -> c) -> (b -> c -> c) -> c -> p a b -> c
  bifoldr f g z t = appEndo (bifoldMap (Endo #. f) (Endo #. g) t) z

  -- | Combines the elements of a structure in a left associative manner. Given
  -- a hypothetical function @toEitherList :: p a b -> [Either a b]@ yielding a
  -- list of all elements of a structure in order, the following would hold:
  --
  -- @'bifoldl' f g z
  --     â‰¡ 'foldl' (\acc -> 'either' (f acc) (g acc)) z . toEitherList@
  --
  -- Note that if you want an efficient left-fold, you probably want to use
  -- 'bifoldl'' instead of 'bifoldl'. The reason is that the latter does not
  -- force the "inner" results, resulting in a thunk chain which then must be
  -- evaluated from the outside-in.
  --
  -- @since 4.10.0.0
  bifoldl :: (c -> a -> c) -> (c -> b -> c) -> c -> p a b -> c
  bifoldl f g z t = appEndo (getDual (bifoldMap (Dual . Endo . flip f)
                                                (Dual . Endo . flip g) t)) z

-- | @since 4.10.0.0
instance Bifoldable (,) where
  bifoldMap f g ~(a, b) = f a `mappend` g b

-- | @since 4.10.0.0
instance Bifoldable Const where
  bifoldMap f _ (Const a) = f a

-- | @since 4.10.0.0
instance Bifoldable (K1 i) where
  bifoldMap f _ (K1 c) = f c

-- | @since 4.10.0.0
instance Bifoldable ((,,) x) where
  bifoldMap f g ~(_,a,b) = f a `mappend` g b

-- | @since 4.10.0.0
instance Bifoldable ((,,,) x y) where
  bifoldMap f g ~(_,_,a,b) = f a `mappend` g b

-- | @since 4.10.0.0
instance Bifoldable ((,,,,) x y z) where
  bifoldMap f g ~(_,_,_,a,b) = f a `mappend` g b

-- | @since 4.10.0.0
instance Bifoldable ((,,,,,) x y z w) where
  bifoldMap f g ~(_,_,_,_,a,b) = f a `mappend` g b

-- | @since 4.10.0.0
instance Bifoldable ((,,,,,,) x y z w v) where
  bifoldMap f g ~(_,_,_,_,_,a,b) = f a `mappend` g b

-- | @since 4.10.0.0
instance Bifoldable Either where
  bifoldMap f _ (Left a) = f a
  bifoldMap _ g (Right b) = g b

-- | As 'bifoldr', but strict in the result of the reduction functions at each
-- step.
--
-- @since 4.10.0.0
bifoldr' :: Bifoldable t => (a -> c -> c) -> (b -> c -> c) -> c -> t a b -> c
bifoldr' f g z0 xs = bifoldl f' g' id xs z0 where
  f' k x z = k $! f x z
  g' k x z = k $! g x z

-- | A variant of 'bifoldr' that has no base case,
-- and thus may only be applied to non-empty structures.
--
-- @since 4.10.0.0
bifoldr1 :: Bifoldable t => (a -> a -> a) -> t a a -> a
bifoldr1 f xs = fromMaybe (error "bifoldr1: empty structure")
                  (bifoldr mbf mbf Nothing xs)
  where
    mbf x m = Just (case m of
                      Nothing -> x
                      Just y  -> f x y)

-- | Right associative monadic bifold over a structure.
--
-- @since 4.10.0.0
bifoldrM :: (Bifoldable t, Monad m)
         => (a -> c -> m c) -> (b -> c -> m c) -> c -> t a b -> m c
bifoldrM f g z0 xs = bifoldl f' g' return xs z0 where
  f' k x z = f x z >>= k
  g' k x z = g x z >>= k

-- | As 'bifoldl', but strict in the result of the reduction functions at each
-- step.
--
-- This ensures that each step of the bifold is forced to weak head normal form
-- before being applied, avoiding the collection of thunks that would otherwise
-- occur. This is often what you want to strictly reduce a finite structure to
-- a single, monolithic result (e.g., 'bilength').
--
-- @since 4.10.0.0
bifoldl':: Bifoldable t => (a -> b -> a) -> (a -> c -> a) -> a -> t b c -> a
bifoldl' f g z0 xs = bifoldr f' g' id xs z0 where
  f' x k z = k $! f z x
  g' x k z = k $! g z x

-- | A variant of 'bifoldl' that has no base case,
-- and thus may only be applied to non-empty structures.
--
-- @since 4.10.0.0
bifoldl1 :: Bifoldable t => (a -> a -> a) -> t a a -> a
bifoldl1 f xs = fromMaybe (error "bifoldl1: empty structure")
                  (bifoldl mbf mbf Nothing xs)
  where
    mbf m y = Just (case m of
                      Nothing -> y
                      Just x  -> f x y)

-- | Left associative monadic bifold over a structure.
--
-- @since 4.10.0.0
bifoldlM :: (Bifoldable t, Monad m)
         => (a -> b -> m a) -> (a -> c -> m a) -> a -> t b c -> m a
bifoldlM f g z0 xs = bifoldr f' g' return xs z0 where
  f' x k z = f z x >>= k
  g' x k z = g z x >>= k

-- | Map each element of a structure using one of two actions, evaluate these
-- actions from left to right, and ignore the results. For a version that
-- doesn't ignore the results, see 'Data.Bitraversable.bitraverse'.
--
-- @since 4.10.0.0
bitraverse_ :: (Bifoldable t, Applicative f)
            => (a -> f c) -> (b -> f d) -> t a b -> f ()
bitraverse_ f g = bifoldr ((*>) . f) ((*>) . g) (pure ())

-- | As 'bitraverse_', but with the structure as the primary argument. For a
-- version that doesn't ignore the results, see 'Data.Bitraversable.bifor'.
--
-- >>> > bifor_ ('a', "bc") print (print . reverse)
-- 'a'
-- "cb"
--
-- @since 4.10.0.0
bifor_ :: (Bifoldable t, Applicative f)
       => t a b -> (a -> f c) -> (b -> f d) -> f ()
bifor_ t f g = bitraverse_ f g t

-- | Alias for 'bitraverse_'.
--
-- @since 4.10.0.0
bimapM_ :: (Bifoldable t, Applicative f)
        => (a -> f c) -> (b -> f d) -> t a b -> f ()
bimapM_ = bitraverse_

-- | Alias for 'bifor_'.
--
-- @since 4.10.0.0
biforM_ :: (Bifoldable t, Applicative f)
        => t a b ->  (a -> f c) -> (b -> f d) -> f ()
biforM_ = bifor_

-- | Alias for 'bisequence_'.
--
-- @since 4.10.0.0
bisequenceA_ :: (Bifoldable t, Applicative f) => t (f a) (f b) -> f ()
bisequenceA_ = bisequence_

-- | Evaluate each action in the structure from left to right, and ignore the
-- results. For a version that doesn't ignore the results, see
-- 'Data.Bitraversable.bisequence'.
--
-- @since 4.10.0.0
bisequence_ :: (Bifoldable t, Applicative f) => t (f a) (f b) -> f ()
bisequence_ = bifoldr (*>) (*>) (pure ())

-- | The sum of a collection of actions, generalizing 'biconcat'.
--
-- @since 4.10.0.0
biasum :: (Bifoldable t, Alternative f) => t (f a) (f a) -> f a
biasum = bifoldr (<|>) (<|>) empty

-- | Alias for 'biasum'.
--
-- @since 4.10.0.0
bimsum :: (Bifoldable t, Alternative f) => t (f a) (f a) -> f a
bimsum = biasum

-- | Collects the list of elements of a structure, from left to right.
--
-- @since 4.10.0.0
biList :: Bifoldable t => t a a -> [a]
biList = bifoldr (:) (:) []

-- | Test whether the structure is empty.
--
-- @since 4.10.0.0
binull :: Bifoldable t => t a b -> Bool
binull = bifoldr (\_ _ -> False) (\_ _ -> False) True

-- | Returns the size/length of a finite structure as an 'Int'.
--
-- @since 4.10.0.0
bilength :: Bifoldable t => t a b -> Int
bilength = bifoldl' (\c _ -> c+1) (\c _ -> c+1) 0

-- | Does the element occur in the structure?
--
-- @since 4.10.0.0
bielem :: (Bifoldable t, Eq a) => a -> t a a -> Bool
bielem x = biany (== x) (== x)

-- | Reduces a structure of lists to the concatenation of those lists.
--
-- @since 4.10.0.0
biconcat :: Bifoldable t => t [a] [a] -> [a]
biconcat = bifold

-- | The largest element of a non-empty structure.
--
-- @since 4.10.0.0
bimaximum :: forall t a. (Bifoldable t, Ord a) => t a a -> a
bimaximum = fromMaybe (error "bimaximum: empty structure") .
    getMax . bifoldMap mj mj
  where mj = Max #. (Just :: a -> Maybe a)

-- | The least element of a non-empty structure.
--
-- @since 4.10.0.0
biminimum :: forall t a. (Bifoldable t, Ord a) => t a a -> a
biminimum = fromMaybe (error "biminimum: empty structure") .
    getMin . bifoldMap mj mj
  where mj = Min #. (Just :: a -> Maybe a)

-- | The 'bisum' function computes the sum of the numbers of a structure.
--
-- @since 4.10.0.0
bisum :: (Bifoldable t, Num a) => t a a -> a
bisum = getSum #. bifoldMap Sum Sum

-- | The 'biproduct' function computes the product of the numbers of a
-- structure.
--
-- @since 4.10.0.0
biproduct :: (Bifoldable t, Num a) => t a a -> a
biproduct = getProduct #. bifoldMap Product Product

-- | Given a means of mapping the elements of a structure to lists, computes the
-- concatenation of all such lists in order.
--
-- @since 4.10.0.0
biconcatMap :: Bifoldable t => (a -> [c]) -> (b -> [c]) -> t a b -> [c]
biconcatMap = bifoldMap

-- | 'biand' returns the conjunction of a container of Bools.  For the
-- result to be 'True', the container must be finite; 'False', however,
-- results from a 'False' value finitely far from the left end.
--
-- @since 4.10.0.0
biand :: Bifoldable t => t Bool Bool -> Bool
biand = getAll #. bifoldMap All All

-- | 'bior' returns the disjunction of a container of Bools.  For the
-- result to be 'False', the container must be finite; 'True', however,
-- results from a 'True' value finitely far from the left end.
--
-- @since 4.10.0.0
bior :: Bifoldable t => t Bool Bool -> Bool
bior = getAny #. bifoldMap Any Any

-- | Determines whether any element of the structure satisfies its appropriate
-- predicate argument.
--
-- @since 4.10.0.0
biany :: Bifoldable t => (a -> Bool) -> (b -> Bool) -> t a b -> Bool
biany p q = getAny #. bifoldMap (Any . p) (Any . q)

-- | Determines whether all elements of the structure satisfy their appropriate
-- predicate argument.
--
-- @since 4.10.0.0
biall :: Bifoldable t => (a -> Bool) -> (b -> Bool) -> t a b -> Bool
biall p q = getAll #. bifoldMap (All . p) (All . q)

-- | The largest element of a non-empty structure with respect to the
-- given comparison function.
--
-- @since 4.10.0.0
bimaximumBy :: Bifoldable t => (a -> a -> Ordering) -> t a a -> a
bimaximumBy cmp = bifoldr1 max'
  where max' x y = case cmp x y of
                        GT -> x
                        _  -> y

-- | The least element of a non-empty structure with respect to the
-- given comparison function.
--
-- @since 4.10.0.0
biminimumBy :: Bifoldable t => (a -> a -> Ordering) -> t a a -> a
biminimumBy cmp = bifoldr1 min'
  where min' x y = case cmp x y of
                        GT -> y
                        _  -> x

-- | 'binotElem' is the negation of 'bielem'.
--
-- @since 4.10.0.0
binotElem :: (Bifoldable t, Eq a) => a -> t a a-> Bool
binotElem x =  not . bielem x

-- | The 'bifind' function takes a predicate and a structure and returns
-- the leftmost element of the structure matching the predicate, or
-- 'Nothing' if there is no such element.
--
-- @since 4.10.0.0
bifind :: Bifoldable t => (a -> Bool) -> t a a -> Maybe a
bifind p = getFirst . bifoldMap finder finder
  where finder x = First (if p x then Just x else Nothing)


{-# LANGUAGE Safe #-}
{-# LANGUAGE CPP #-}

-----------------------------------------------------------------------------
-- |
-- Module      :  Data.Bifunctor
-- Copyright   :  (C) 2008-2014 Edward Kmett,
-- License     :  BSD-style (see the file LICENSE)
--
-- Maintainer  :  libraries@haskell.org
-- Stability   :  provisional
-- Portability :  portable
--
-- @since 4.8.0.0
----------------------------------------------------------------------------
module Data.Bifunctor
  ( Bifunctor(..)
  ) where

import Control.Applicative  ( Const(..) )
import GHC.Generics ( K1(..) )

-- | A bifunctor is a type constructor that takes
-- two type arguments and is a functor in /both/ arguments. That
-- is, unlike with 'Functor', a type constructor such as 'Either'
-- does not need to be partially applied for a 'Bifunctor'
-- instance, and the methods in this class permit mapping
-- functions over the 'Left' value or the 'Right' value,
-- or both at the same time.
--
-- Formally, the class 'Bifunctor' represents a bifunctor
-- from @Hask@ -> @Hask@.
--
-- Intuitively it is a bifunctor where both the first and second
-- arguments are covariant.
--
-- You can define a 'Bifunctor' by either defining 'bimap' or by
-- defining both 'first' and 'second'.
--
-- If you supply 'bimap', you should ensure that:
--
-- @'bimap' 'id' 'id' â‰¡ 'id'@
--
-- If you supply 'first' and 'second', ensure:
--
-- @
-- 'first' 'id' â‰¡ 'id'
-- 'second' 'id' â‰¡ 'id'
-- @
--
-- If you supply both, you should also ensure:
--
-- @'bimap' f g â‰¡ 'first' f '.' 'second' g@
--
-- These ensure by parametricity:
--
-- @
-- 'bimap'  (f '.' g) (h '.' i) â‰¡ 'bimap' f h '.' 'bimap' g i
-- 'first'  (f '.' g) â‰¡ 'first'  f '.' 'first'  g
-- 'second' (f '.' g) â‰¡ 'second' f '.' 'second' g
-- @
--
-- @since 4.8.0.0
class Bifunctor p where
    {-# MINIMAL bimap | first, second #-}

    -- | Map over both arguments at the same time.
    --
    -- @'bimap' f g â‰¡ 'first' f '.' 'second' g@
    --
    -- ==== __Examples__
    -- >>> bimap toUpper (+1) ('j', 3)
    -- ('J',4)
    --
    -- >>> bimap toUpper (+1) (Left 'j')
    -- Left 'J'
    --
    -- >>> bimap toUpper (+1) (Right 3)
    -- Right 4
    bimap :: (a -> b) -> (c -> d) -> p a c -> p b d
    bimap f g = first f . second g

    -- | Map covariantly over the first argument.
    --
    -- @'first' f â‰¡ 'bimap' f 'id'@
    --
    -- ==== __Examples__
    -- >>> first toUpper ('j', 3)
    -- ('J',3)
    --
    -- >>> first toUpper (Left 'j')
    -- Left 'J'
    first :: (a -> b) -> p a c -> p b c
    first f = bimap f id

    -- | Map covariantly over the second argument.
    --
    -- @'second' â‰¡ 'bimap' 'id'@
    --
    -- ==== __Examples__
    -- >>> second (+1) ('j', 3)
    -- ('j',4)
    --
    -- >>> second (+1) (Right 3)
    -- Right 4
    second :: (b -> c) -> p a b -> p a c
    second = bimap id

-- | @since 4.8.0.0
instance Bifunctor (,) where
    bimap f g ~(a, b) = (f a, g b)

-- | @since 4.8.0.0
instance Bifunctor ((,,) x1) where
    bimap f g ~(x1, a, b) = (x1, f a, g b)

-- | @since 4.8.0.0
instance Bifunctor ((,,,) x1 x2) where
    bimap f g ~(x1, x2, a, b) = (x1, x2, f a, g b)

-- | @since 4.8.0.0
instance Bifunctor ((,,,,) x1 x2 x3) where
    bimap f g ~(x1, x2, x3, a, b) = (x1, x2, x3, f a, g b)

-- | @since 4.8.0.0
instance Bifunctor ((,,,,,) x1 x2 x3 x4) where
    bimap f g ~(x1, x2, x3, x4, a, b) = (x1, x2, x3, x4, f a, g b)

-- | @since 4.8.0.0
instance Bifunctor ((,,,,,,) x1 x2 x3 x4 x5) where
    bimap f g ~(x1, x2, x3, x4, x5, a, b) = (x1, x2, x3, x4, x5, f a, g b)

-- | @since 4.8.0.0
instance Bifunctor Either where
    bimap f _ (Left a) = Left (f a)
    bimap _ g (Right b) = Right (g b)

-- | @since 4.8.0.0
instance Bifunctor Const where
    bimap f _ (Const a) = Const (f a)

-- | @since 4.9.0.0
instance Bifunctor (K1 i) where
    bimap f _ (K1 c) = K1 (f c)


{-# LANGUAGE Trustworthy #-}
{-# LANGUAGE ScopedTypeVariables #-}

-----------------------------------------------------------------------------
-- |
-- Module      :  Data.Bitraversable
-- Copyright   :  (C) 2011-2016 Edward Kmett
-- License     :  BSD-style (see the file LICENSE)
--
-- Maintainer  :  libraries@haskell.org
-- Stability   :  provisional
-- Portability :  portable
--
-- @since 4.10.0.0
----------------------------------------------------------------------------
module Data.Bitraversable
  ( Bitraversable(..)
  , bisequenceA
  , bisequence
  , bimapM
  , bifor
  , biforM
  , bimapAccumL
  , bimapAccumR
  , bimapDefault
  , bifoldMapDefault
  ) where

import Control.Applicative
import Data.Bifunctor
import Data.Bifoldable
import Data.Coerce
import Data.Functor.Identity (Identity(..))
import Data.Functor.Utils (StateL(..), StateR(..))
import GHC.Generics (K1(..))

-- | 'Bitraversable' identifies bifunctorial data structures whose elements can
-- be traversed in order, performing 'Applicative' or 'Monad' actions at each
-- element, and collecting a result structure with the same shape.
--
-- As opposed to 'Traversable' data structures, which have one variety of
-- element on which an action can be performed, 'Bitraversable' data structures
-- have two such varieties of elements.
--
-- A definition of 'bitraverse' must satisfy the following laws:
--
-- [Naturality]
--   @'bitraverse' (t . f) (t . g) â‰¡ t . 'bitraverse' f g@
--   for every applicative transformation @t@
--
-- [Identity]
--   @'bitraverse' 'Identity' 'Identity' â‰¡ 'Identity'@
--
-- [Composition]
--   @'Data.Functor.Compose.Compose' .
--    'fmap' ('bitraverse' g1 g2) .
--    'bitraverse' f1 f2
--     â‰¡ 'bitraverse' ('Data.Functor.Compose.Compose' . 'fmap' g1 . f1)
--                  ('Data.Functor.Compose.Compose' . 'fmap' g2 . f2)@
--
-- where an /applicative transformation/ is a function
--
-- @t :: ('Applicative' f, 'Applicative' g) => f a -> g a@
--
-- preserving the 'Applicative' operations:
--
-- @
-- t ('pure' x) = 'pure' x
-- t (f '<*>' x) = t f '<*>' t x
-- @
--
-- and the identity functor 'Identity' and composition functors
-- 'Data.Functor.Compose.Compose' are from "Data.Functor.Identity" and
-- "Data.Functor.Compose".
--
-- Some simple examples are 'Either' and '(,)':
--
-- > instance Bitraversable Either where
-- >   bitraverse f _ (Left x) = Left <$> f x
-- >   bitraverse _ g (Right y) = Right <$> g y
-- >
-- > instance Bitraversable (,) where
-- >   bitraverse f g (x, y) = (,) <$> f x <*> g y
--
-- 'Bitraversable' relates to its superclasses in the following ways:
--
-- @
-- 'bimap' f g â‰¡ 'runIdentity' . 'bitraverse' ('Identity' . f) ('Identity' . g)
-- 'bifoldMap' f g = 'getConst' . 'bitraverse' ('Const' . f) ('Const' . g)
-- @
--
-- These are available as 'bimapDefault' and 'bifoldMapDefault' respectively.
--
-- @since 4.10.0.0
class (Bifunctor t, Bifoldable t) => Bitraversable t where
  -- | Evaluates the relevant functions at each element in the structure,
  -- running the action, and builds a new structure with the same shape, using
  -- the results produced from sequencing the actions.
  --
  -- @'bitraverse' f g â‰¡ 'bisequenceA' . 'bimap' f g@
  --
  -- For a version that ignores the results, see 'bitraverse_'.
  --
  -- @since 4.10.0.0
  bitraverse :: Applicative f => (a -> f c) -> (b -> f d) -> t a b -> f (t c d)
  bitraverse f g = bisequenceA . bimap f g

-- | Alias for 'bisequence'.
--
-- @since 4.10.0.0
bisequenceA :: (Bitraversable t, Applicative f) => t (f a) (f b) -> f (t a b)
bisequenceA = bisequence

-- | Alias for 'bitraverse'.
--
-- @since 4.10.0.0
bimapM :: (Bitraversable t, Applicative f)
       => (a -> f c) -> (b -> f d) -> t a b -> f (t c d)
bimapM = bitraverse

-- | Sequences all the actions in a structure, building a new structure with
-- the same shape using the results of the actions. For a version that ignores
-- the results, see 'bisequence_'.
--
-- @'bisequence' â‰¡ 'bitraverse' 'id' 'id'@
--
-- @since 4.10.0.0
bisequence :: (Bitraversable t, Applicative f) => t (f a) (f b) -> f (t a b)
bisequence = bitraverse id id

-- | @since 4.10.0.0
instance Bitraversable (,) where
  bitraverse f g ~(a, b) = liftA2 (,) (f a) (g b)

-- | @since 4.10.0.0
instance Bitraversable ((,,) x) where
  bitraverse f g ~(x, a, b) = liftA2 ((,,) x) (f a) (g b)

-- | @since 4.10.0.0
instance Bitraversable ((,,,) x y) where
  bitraverse f g ~(x, y, a, b) = liftA2 ((,,,) x y) (f a) (g b)

-- | @since 4.10.0.0
instance Bitraversable ((,,,,) x y z) where
  bitraverse f g ~(x, y, z, a, b) = liftA2 ((,,,,) x y z) (f a) (g b)

-- | @since 4.10.0.0
instance Bitraversable ((,,,,,) x y z w) where
  bitraverse f g ~(x, y, z, w, a, b) = liftA2 ((,,,,,) x y z w) (f a) (g b)

-- | @since 4.10.0.0
instance Bitraversable ((,,,,,,) x y z w v) where
  bitraverse f g ~(x, y, z, w, v, a, b) =
    liftA2 ((,,,,,,) x y z w v) (f a) (g b)

-- | @since 4.10.0.0
instance Bitraversable Either where
  bitraverse f _ (Left a) = Left <$> f a
  bitraverse _ g (Right b) = Right <$> g b

-- | @since 4.10.0.0
instance Bitraversable Const where
  bitraverse f _ (Const a) = Const <$> f a

-- | @since 4.10.0.0
instance Bitraversable (K1 i) where
  bitraverse f _ (K1 c) = K1 <$> f c

-- | 'bifor' is 'bitraverse' with the structure as the first argument. For a
-- version that ignores the results, see 'bifor_'.
--
-- @since 4.10.0.0
bifor :: (Bitraversable t, Applicative f)
      => t a b -> (a -> f c) -> (b -> f d) -> f (t c d)
bifor t f g = bitraverse f g t

-- | Alias for 'bifor'.
--
-- @since 4.10.0.0
biforM :: (Bitraversable t, Applicative f)
       => t a b -> (a -> f c) -> (b -> f d) -> f (t c d)
biforM = bifor

-- | The 'bimapAccumL' function behaves like a combination of 'bimap' and
-- 'bifoldl'; it traverses a structure from left to right, threading a state
-- of type @a@ and using the given actions to compute new elements for the
-- structure.
--
-- @since 4.10.0.0
bimapAccumL :: Bitraversable t => (a -> b -> (a, c)) -> (a -> d -> (a, e))
            -> a -> t b d -> (a, t c e)
bimapAccumL f g s t
  = runStateL (bitraverse (StateL . flip f) (StateL . flip g) t) s

-- | The 'bimapAccumR' function behaves like a combination of 'bimap' and
-- 'bifoldl'; it traverses a structure from right to left, threading a state
-- of type @a@ and using the given actions to compute new elements for the
-- structure.
--
-- @since 4.10.0.0
bimapAccumR :: Bitraversable t => (a -> b -> (a, c)) -> (a -> d -> (a, e))
            -> a -> t b d -> (a, t c e)
bimapAccumR f g s t
  = runStateR (bitraverse (StateR . flip f) (StateR . flip g) t) s

-- | A default definition of 'bimap' in terms of the 'Bitraversable'
-- operations.
--
-- @'bimapDefault' f g â‰¡
--     'runIdentity' . 'bitraverse' ('Identity' . f) ('Identity' . g)@
--
-- @since 4.10.0.0
bimapDefault :: forall t a b c d . Bitraversable t
             => (a -> b) -> (c -> d) -> t a c -> t b d
-- See Note [Function coercion] in Data.Functor.Utils.
bimapDefault = coerce
  (bitraverse :: (a -> Identity b)
              -> (c -> Identity d) -> t a c -> Identity (t b d))
{-# INLINE bimapDefault #-}

-- | A default definition of 'bifoldMap' in terms of the 'Bitraversable'
-- operations.
--
-- @'bifoldMapDefault' f g â‰¡
--    'getConst' . 'bitraverse' ('Const' . f) ('Const' . g)@
--
-- @since 4.10.0.0
bifoldMapDefault :: forall t m a b . (Bitraversable t, Monoid m)
                 => (a -> m) -> (b -> m) -> t a b -> m
-- See Note [Function coercion] in Data.Functor.Utils.
bifoldMapDefault = coerce
  (bitraverse :: (a -> Const m ())
              -> (b -> Const m ()) -> t a b -> Const m (t () ()))
{-# INLINE bifoldMapDefault #-}


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

-----------------------------------------------------------------------------
-- |
-- Module      :  Data.Bits
-- 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 module defines bitwise operations for signed and unsigned
-- integers.  Instances of the class 'Bits' for the 'Int' and
-- 'Integer' types are available from this module, and instances for
-- explicitly sized integral types are available from the
-- "Data.Int" and "Data.Word" modules.
--
-----------------------------------------------------------------------------

module Data.Bits (
  Bits(
    (.&.), (.|.), xor,
    complement,
    shift,
    rotate,
    zeroBits,
    bit,
    setBit,
    clearBit,
    complementBit,
    testBit,
    bitSizeMaybe,
    bitSize,
    isSigned,
    shiftL, shiftR,
    unsafeShiftL, unsafeShiftR,
    rotateL, rotateR,
    popCount
  ),
  FiniteBits(
    finiteBitSize,
    countLeadingZeros,
    countTrailingZeros
  ),

  bitDefault,
  testBitDefault,
  popCountDefault,
  toIntegralSized
 ) where

-- Defines the @Bits@ class containing bit-based operations.
-- See library document for details on the semantics of the
-- individual operations.

#include "MachDeps.h"

import Data.Maybe
import GHC.Enum
import GHC.Num
import GHC.Base
import GHC.Real

infixl 8 `shift`, `rotate`, `shiftL`, `shiftR`, `rotateL`, `rotateR`
infixl 7 .&.
infixl 6 `xor`
infixl 5 .|.

{-# DEPRECATED bitSize "Use 'bitSizeMaybe' or 'finiteBitSize' instead" #-} -- deprecated in 7.8

-- | The 'Bits' class defines bitwise operations over integral types.
--
-- * Bits are numbered from 0 with bit 0 being the least
--   significant bit.
class Eq a => Bits a where
    {-# MINIMAL (.&.), (.|.), xor, complement,
                (shift | (shiftL, shiftR)),
                (rotate | (rotateL, rotateR)),
                bitSize, bitSizeMaybe, isSigned, testBit, bit, popCount #-}

    -- | Bitwise \"and\"
    (.&.) :: a -> a -> a

    -- | Bitwise \"or\"
    (.|.) :: a -> a -> a

    -- | Bitwise \"xor\"
    xor :: a -> a -> a

    {-| Reverse all the bits in the argument -}
    complement        :: a -> a

    {-| @'shift' x i@ shifts @x@ left by @i@ bits if @i@ is positive,
        or right by @-i@ bits otherwise.
        Right shifts perform sign extension on signed number types;
        i.e. they fill the top bits with 1 if the @x@ is negative
        and with 0 otherwise.

        An instance can define either this unified 'shift' or 'shiftL' and
        'shiftR', depending on which is more convenient for the type in
        question. -}
    shift             :: a -> Int -> a

    x `shift`   i | i<0       = x `shiftR` (-i)
                  | i>0       = x `shiftL` i
                  | otherwise = x

    {-| @'rotate' x i@ rotates @x@ left by @i@ bits if @i@ is positive,
        or right by @-i@ bits otherwise.

        For unbounded types like 'Integer', 'rotate' is equivalent to 'shift'.

        An instance can define either this unified 'rotate' or 'rotateL' and
        'rotateR', depending on which is more convenient for the type in
        question. -}
    rotate            :: a -> Int -> a

    x `rotate`  i | i<0       = x `rotateR` (-i)
                  | i>0       = x `rotateL` i
                  | otherwise = x

    {-
    -- Rotation can be implemented in terms of two shifts, but care is
    -- needed for negative values.  This suggested implementation assumes
    -- 2's-complement arithmetic.  It is commented out because it would
    -- require an extra context (Ord a) on the signature of 'rotate'.
    x `rotate`  i | i<0 && isSigned x && x<0
                         = let left = i+bitSize x in
                           ((x `shift` i) .&. complement ((-1) `shift` left))
                           .|. (x `shift` left)
                  | i<0  = (x `shift` i) .|. (x `shift` (i+bitSize x))
                  | i==0 = x
                  | i>0  = (x `shift` i) .|. (x `shift` (i-bitSize x))
    -}

    -- | 'zeroBits' is the value with all bits unset.
    --
    -- The following laws ought to hold (for all valid bit indices @/n/@):
    --
    --   * @'clearBit' 'zeroBits' /n/ == 'zeroBits'@
    --   * @'setBit'   'zeroBits' /n/ == 'bit' /n/@
    --   * @'testBit'  'zeroBits' /n/ == False@
    --   * @'popCount' 'zeroBits'   == 0@
    --
    -- This method uses @'clearBit' ('bit' 0) 0@ as its default
    -- implementation (which ought to be equivalent to 'zeroBits' for
    -- types which possess a 0th bit).
    --
    -- @since 4.7.0.0
    zeroBits :: a
    zeroBits = clearBit (bit 0) 0

    -- | @bit /i/@ is a value with the @/i/@th bit set and all other bits clear.
    --
    -- Can be implemented using `bitDefault' if @a@ is also an
    -- instance of 'Num'.
    --
    -- See also 'zeroBits'.
    bit               :: Int -> a

    -- | @x \`setBit\` i@ is the same as @x .|. bit i@
    setBit            :: a -> Int -> a

    -- | @x \`clearBit\` i@ is the same as @x .&. complement (bit i)@
    clearBit          :: a -> Int -> a

    -- | @x \`complementBit\` i@ is the same as @x \`xor\` bit i@
    complementBit     :: a -> Int -> a

    -- | Return 'True' if the @n@th bit of the argument is 1
    --
    -- Can be implemented using `testBitDefault' if @a@ is also an
    -- instance of 'Num'.
    testBit           :: a -> Int -> Bool

    {-| Return the number of bits in the type of the argument.  The actual
        value of the argument is ignored.  Returns Nothing
        for types that do not have a fixed bitsize, like 'Integer'.

        @since 4.7.0.0
        -}
    bitSizeMaybe      :: a -> Maybe Int

    {-| Return the number of bits in the type of the argument.  The actual
        value of the argument is ignored.  The function 'bitSize' is
        undefined for types that do not have a fixed bitsize, like 'Integer'.

        Default implementation based upon 'bitSizeMaybe' provided since
        4.12.0.0.
        -}
    bitSize           :: a -> Int
    bitSize b = fromMaybe (error "bitSize is undefined") (bitSizeMaybe b)

    {-| Return 'True' if the argument is a signed type.  The actual
        value of the argument is ignored -}
    isSigned          :: a -> Bool

    {-# INLINE setBit #-}
    {-# INLINE clearBit #-}
    {-# INLINE complementBit #-}
    x `setBit` i        = x .|. bit i
    x `clearBit` i      = x .&. complement (bit i)
    x `complementBit` i = x `xor` bit i

    {-| Shift the argument left by the specified number of bits
        (which must be non-negative). Some instances may throw an
        'Control.Exception.Overflow' exception if given a negative input.

        An instance can define either this and 'shiftR' or the unified
        'shift', depending on which is more convenient for the type in
        question. -}
    shiftL            :: a -> Int -> a
    {-# INLINE shiftL #-}
    x `shiftL`  i = x `shift`  i

    {-| Shift the argument left by the specified number of bits.  The
        result is undefined for negative shift amounts and shift amounts
        greater or equal to the 'bitSize'.

        Defaults to 'shiftL' unless defined explicitly by an instance.

        @since 4.5.0.0 -}
    unsafeShiftL            :: a -> Int -> a
    {-# INLINE unsafeShiftL #-}
    x `unsafeShiftL` i = x `shiftL` i

    {-| Shift the first argument right by the specified number of bits. The
        result is undefined for negative shift amounts and shift amounts
        greater or equal to the 'bitSize'. Some instances may throw an
        'Control.Exception.Overflow' exception if given a negative input.

        Right shifts perform sign extension on signed number types;
        i.e. they fill the top bits with 1 if the @x@ is negative
        and with 0 otherwise.

        An instance can define either this and 'shiftL' or the unified
        'shift', depending on which is more convenient for the type in
        question. -}
    shiftR            :: a -> Int -> a
    {-# INLINE shiftR #-}
    x `shiftR`  i = x `shift`  (-i)

    {-| Shift the first argument right by the specified number of bits, which
        must be non-negative and smaller than the number of bits in the type.

        Right shifts perform sign extension on signed number types;
        i.e. they fill the top bits with 1 if the @x@ is negative
        and with 0 otherwise.

        Defaults to 'shiftR' unless defined explicitly by an instance.

        @since 4.5.0.0 -}
    unsafeShiftR            :: a -> Int -> a
    {-# INLINE unsafeShiftR #-}
    x `unsafeShiftR` i = x `shiftR` i

    {-| Rotate the argument left by the specified number of bits
        (which must be non-negative).

        An instance can define either this and 'rotateR' or the unified
        'rotate', depending on which is more convenient for the type in
        question. -}
    rotateL           :: a -> Int -> a
    {-# INLINE rotateL #-}
    x `rotateL` i = x `rotate` i

    {-| Rotate the argument right by the specified number of bits
        (which must be non-negative).

        An instance can define either this and 'rotateL' or the unified
        'rotate', depending on which is more convenient for the type in
        question. -}
    rotateR           :: a -> Int -> a
    {-# INLINE rotateR #-}
    x `rotateR` i = x `rotate` (-i)

    {-| Return the number of set bits in the argument.  This number is
        known as the population count or the Hamming weight.

        Can be implemented using `popCountDefault' if @a@ is also an
        instance of 'Num'.

        @since 4.5.0.0 -}
    popCount          :: a -> Int

-- |The 'FiniteBits' class denotes types with a finite, fixed number of bits.
--
-- @since 4.7.0.0
class Bits b => FiniteBits b where
    -- | Return the number of bits in the type of the argument.
    -- The actual value of the argument is ignored. Moreover, 'finiteBitSize'
    -- is total, in contrast to the deprecated 'bitSize' function it replaces.
    --
    -- @
    -- 'finiteBitSize' = 'bitSize'
    -- 'bitSizeMaybe' = 'Just' . 'finiteBitSize'
    -- @
    --
    -- @since 4.7.0.0
    finiteBitSize :: b -> Int

    -- | Count number of zero bits preceding the most significant set bit.
    --
    -- @
    -- 'countLeadingZeros' ('zeroBits' :: a) = finiteBitSize ('zeroBits' :: a)
    -- @
    --
    -- 'countLeadingZeros' can be used to compute log base 2 via
    --
    -- @
    -- logBase2 x = 'finiteBitSize' x - 1 - 'countLeadingZeros' x
    -- @
    --
    -- Note: The default implementation for this method is intentionally
    -- naive. However, the instances provided for the primitive
    -- integral types are implemented using CPU specific machine
    -- instructions.
    --
    -- @since 4.8.0.0
    countLeadingZeros :: b -> Int
    countLeadingZeros x = (w-1) - go (w-1)
      where
        go i | i < 0       = i -- no bit set
             | testBit x i = i
             | otherwise   = go (i-1)

        w = finiteBitSize x

    -- | Count number of zero bits following the least significant set bit.
    --
    -- @
    -- 'countTrailingZeros' ('zeroBits' :: a) = finiteBitSize ('zeroBits' :: a)
    -- 'countTrailingZeros' . 'negate' = 'countTrailingZeros'
    -- @
    --
    -- The related
    -- <http://en.wikipedia.org/wiki/Find_first_set find-first-set operation>
    -- can be expressed in terms of 'countTrailingZeros' as follows
    --
    -- @
    -- findFirstSet x = 1 + 'countTrailingZeros' x
    -- @
    --
    -- Note: The default implementation for this method is intentionally
    -- naive. However, the instances provided for the primitive
    -- integral types are implemented using CPU specific machine
    -- instructions.
    --
    -- @since 4.8.0.0
    countTrailingZeros :: b -> Int
    countTrailingZeros x = go 0
      where
        go i | i >= w      = i
             | testBit x i = i
             | otherwise   = go (i+1)

        w = finiteBitSize x

-- The defaults below are written with lambdas so that e.g.
--     bit = bitDefault
-- is fully applied, so inlining will happen

-- | Default implementation for 'bit'.
--
-- Note that: @bitDefault i = 1 `shiftL` i@
--
-- @since 4.6.0.0
bitDefault :: (Bits a, Num a) => Int -> a
bitDefault = \i -> 1 `shiftL` i
{-# INLINE bitDefault #-}

-- | Default implementation for 'testBit'.
--
-- Note that: @testBitDefault x i = (x .&. bit i) /= 0@
--
-- @since 4.6.0.0
testBitDefault ::  (Bits a, Num a) => a -> Int -> Bool
testBitDefault = \x i -> (x .&. bit i) /= 0
{-# INLINE testBitDefault #-}

-- | Default implementation for 'popCount'.
--
-- This implementation is intentionally naive. Instances are expected to provide
-- an optimized implementation for their size.
--
-- @since 4.6.0.0
popCountDefault :: (Bits a, Num a) => a -> Int
popCountDefault = go 0
 where
   go !c 0 = c
   go c w = go (c+1) (w .&. (w - 1)) -- clear the least significant
{-# INLINABLE popCountDefault #-}

-- | Interpret 'Bool' as 1-bit bit-field
--
--  @since 4.7.0.0
instance Bits Bool where
    (.&.) = (&&)

    (.|.) = (||)

    xor = (/=)

    complement = not

    shift x 0 = x
    shift _ _ = False

    rotate x _ = x

    bit 0 = True
    bit _ = False

    testBit x 0 = x
    testBit _ _ = False

    bitSizeMaybe _ = Just 1

    bitSize _ = 1

    isSigned _ = False

    popCount False = 0
    popCount True  = 1

-- | @since 4.7.0.0
instance FiniteBits Bool where
    finiteBitSize _ = 1
    countTrailingZeros x = if x then 0 else 1
    countLeadingZeros  x = if x then 0 else 1

-- | @since 2.01
instance Bits Int where
    {-# INLINE shift #-}
    {-# INLINE bit #-}
    {-# INLINE testBit #-}
    -- We want popCnt# to be inlined in user code so that `ghc -msse4.2`
    -- can compile it down to a popcnt instruction without an extra function call
    {-# INLINE popCount #-}

    zeroBits = 0

    bit     = bitDefault

    testBit = testBitDefault

    (I# x#) .&.   (I# y#)          = I# (x# `andI#` y#)
    (I# x#) .|.   (I# y#)          = I# (x# `orI#`  y#)
    (I# x#) `xor` (I# y#)          = I# (x# `xorI#` y#)
    complement (I# x#)             = I# (notI# x#)
    (I# x#) `shift` (I# i#)
        | isTrue# (i# >=# 0#)      = I# (x# `iShiftL#` i#)
        | otherwise                = I# (x# `iShiftRA#` negateInt# i#)
    (I# x#) `shiftL` (I# i#)
        | isTrue# (i# >=# 0#)      = I# (x# `iShiftL#` i#)
        | otherwise                = overflowError
    (I# x#) `unsafeShiftL` (I# i#) = I# (x# `uncheckedIShiftL#` i#)
    (I# x#) `shiftR` (I# i#)
        | isTrue# (i# >=# 0#)      = I# (x# `iShiftRA#` i#)
        | otherwise                = overflowError
    (I# x#) `unsafeShiftR` (I# i#) = I# (x# `uncheckedIShiftRA#` i#)

    {-# INLINE rotate #-}       -- See Note [Constant folding for rotate]
    (I# x#) `rotate` (I# i#) =
        I# ((x# `uncheckedIShiftL#` i'#) `orI#` (x# `uncheckedIShiftRL#` (wsib -# i'#)))
      where
        !i'# = i# `andI#` (wsib -# 1#)
        !wsib = WORD_SIZE_IN_BITS#   {- work around preprocessor problem (??) -}
    bitSizeMaybe i         = Just (finiteBitSize i)
    bitSize i              = finiteBitSize i

    popCount (I# x#) = I# (word2Int# (popCnt# (int2Word# x#)))

    isSigned _             = True

-- | @since 4.6.0.0
instance FiniteBits Int where
    finiteBitSize _ = WORD_SIZE_IN_BITS
    countLeadingZeros  (I# x#) = I# (word2Int# (clz# (int2Word# x#)))
    {-# INLINE countLeadingZeros #-}
    countTrailingZeros (I# x#) = I# (word2Int# (ctz# (int2Word# x#)))
    {-# INLINE countTrailingZeros #-}

-- | @since 2.01
instance Bits Word where
    {-# INLINE shift #-}
    {-# INLINE bit #-}
    {-# INLINE testBit #-}
    {-# INLINE popCount #-}

    (W# x#) .&.   (W# y#)    = W# (x# `and#` y#)
    (W# x#) .|.   (W# y#)    = W# (x# `or#`  y#)
    (W# x#) `xor` (W# y#)    = W# (x# `xor#` y#)
    complement (W# x#)       = W# (x# `xor#` mb#)
        where !(W# mb#) = maxBound
    (W# x#) `shift` (I# i#)
        | isTrue# (i# >=# 0#)      = W# (x# `shiftL#` i#)
        | otherwise                = W# (x# `shiftRL#` negateInt# i#)
    (W# x#) `shiftL` (I# i#)
        | isTrue# (i# >=# 0#)      = W# (x# `shiftL#` i#)
        | otherwise                = overflowError
    (W# x#) `unsafeShiftL` (I# i#) = W# (x# `uncheckedShiftL#` i#)
    (W# x#) `shiftR` (I# i#)
        | isTrue# (i# >=# 0#)      = W# (x# `shiftRL#` i#)
        | otherwise                = overflowError
    (W# x#) `unsafeShiftR` (I# i#) = W# (x# `uncheckedShiftRL#` i#)
    (W# x#) `rotate` (I# i#)
        | isTrue# (i'# ==# 0#) = W# x#
        | otherwise  = W# ((x# `uncheckedShiftL#` i'#) `or#` (x# `uncheckedShiftRL#` (wsib -# i'#)))
        where
        !i'# = i# `andI#` (wsib -# 1#)
        !wsib = WORD_SIZE_IN_BITS#  {- work around preprocessor problem (??) -}
    bitSizeMaybe i           = Just (finiteBitSize i)
    bitSize i                = finiteBitSize i
    isSigned _               = False
    popCount (W# x#)         = I# (word2Int# (popCnt# x#))
    bit                      = bitDefault
    testBit                  = testBitDefault

-- | @since 4.6.0.0
instance FiniteBits Word where
    finiteBitSize _ = WORD_SIZE_IN_BITS
    countLeadingZeros  (W# x#) = I# (word2Int# (clz# x#))
    {-# INLINE countLeadingZeros #-}
    countTrailingZeros (W# x#) = I# (word2Int# (ctz# x#))
    {-# INLINE countTrailingZeros #-}

-- | @since 2.01
instance Bits Integer where
   (.&.) = andInteger
   (.|.) = orInteger
   xor = xorInteger
   complement = complementInteger
   shift x i@(I# i#) | i >= 0    = shiftLInteger x i#
                     | otherwise = shiftRInteger x (negateInt# i#)
   testBit x (I# i) = testBitInteger x i
   zeroBits   = 0

   bit (I# i#) = bitInteger i#
   popCount x  = I# (popCountInteger x)

   rotate x i = shift x i   -- since an Integer never wraps around

   bitSizeMaybe _ = Nothing
   bitSize _  = errorWithoutStackTrace "Data.Bits.bitSize(Integer)"
   isSigned _ = True

-- | @since 4.8.0
instance Bits Natural where
   (.&.) = andNatural
   (.|.) = orNatural
   xor = xorNatural
   complement _ = errorWithoutStackTrace
                    "Bits.complement: Natural complement undefined"
   shift x i
     | i >= 0    = shiftLNatural x i
     | otherwise = shiftRNatural x (negate i)
   testBit x i   = testBitNatural x i
   zeroBits      = wordToNaturalBase 0##
   clearBit x i  = x `xor` (bit i .&. x)

   bit (I# i#) = bitNatural i#
   popCount x  = popCountNatural x

   rotate x i = shift x i   -- since an Natural never wraps around

   bitSizeMaybe _ = Nothing
   bitSize _  = errorWithoutStackTrace "Data.Bits.bitSize(Natural)"
   isSigned _ = False

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

-- | Attempt to convert an 'Integral' type @a@ to an 'Integral' type @b@ using
-- the size of the types as measured by 'Bits' methods.
--
-- A simpler version of this function is:
--
-- > toIntegral :: (Integral a, Integral b) => a -> Maybe b
-- > toIntegral x
-- >   | toInteger x == y = Just (fromInteger y)
-- >   | otherwise        = Nothing
-- >   where
-- >     y = toInteger x
--
-- This version requires going through 'Integer', which can be inefficient.
-- However, @toIntegralSized@ is optimized to allow GHC to statically determine
-- the relative type sizes (as measured by 'bitSizeMaybe' and 'isSigned') and
-- avoid going through 'Integer' for many types. (The implementation uses
-- 'fromIntegral', which is itself optimized with rules for @base@ types but may
-- go through 'Integer' for some type pairs.)
--
-- @since 4.8.0.0

toIntegralSized :: (Integral a, Integral b, Bits a, Bits b) => a -> Maybe b
toIntegralSized x                 -- See Note [toIntegralSized optimization]
  | maybe True (<= x) yMinBound
  , maybe True (x <=) yMaxBound = Just y
  | otherwise                   = Nothing
  where
    y = fromIntegral x

    xWidth = bitSizeMaybe x
    yWidth = bitSizeMaybe y

    yMinBound
      | isBitSubType x y = Nothing
      | isSigned x, not (isSigned y) = Just 0
      | isSigned x, isSigned y
      , Just yW <- yWidth = Just (negate $ bit (yW-1)) -- Assumes sub-type
      | otherwise = Nothing

    yMaxBound
      | isBitSubType x y = Nothing
      | isSigned x, not (isSigned y)
      , Just xW <- xWidth, Just yW <- yWidth
      , xW <= yW+1 = Nothing -- Max bound beyond a's domain
      | Just yW <- yWidth = if isSigned y
                            then Just (bit (yW-1)-1)
                            else Just (bit yW-1)
      | otherwise = Nothing
{-# INLINABLE toIntegralSized #-}

-- | 'True' if the size of @a@ is @<=@ the size of @b@, where size is measured
-- by 'bitSizeMaybe' and 'isSigned'.
isBitSubType :: (Bits a, Bits b) => a -> b -> Bool
isBitSubType x y
  -- Reflexive
  | xWidth == yWidth, xSigned == ySigned = True

  -- Every integer is a subset of 'Integer'
  | ySigned, Nothing == yWidth                  = True
  | not xSigned, not ySigned, Nothing == yWidth = True

  -- Sub-type relations between fixed-with types
  | xSigned == ySigned,   Just xW <- xWidth, Just yW <- yWidth = xW <= yW
  | not xSigned, ySigned, Just xW <- xWidth, Just yW <- yWidth = xW <  yW

  | otherwise = False
  where
    xWidth  = bitSizeMaybe x
    xSigned = isSigned     x

    yWidth  = bitSizeMaybe y
    ySigned = isSigned     y
{-# INLINE isBitSubType #-}

{-      Note [Constant folding for rotate]
        ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
The INLINE on the Int instance of rotate enables it to be constant
folded.  For example:
     sumU . mapU (`rotate` 3) . replicateU 10000000 $ (7 :: Int)
goes to:
   Main.$wfold =
     \ (ww_sO7 :: Int#) (ww1_sOb :: Int#) ->
       case ww1_sOb of wild_XM {
         __DEFAULT -> Main.$wfold (+# ww_sO7 56) (+# wild_XM 1);
         10000000 -> ww_sO7
whereas before it was left as a call to $wrotate.

All other Bits instances seem to inline well enough on their
own to enable constant folding; for example 'shift':
     sumU . mapU (`shift` 3) . replicateU 10000000 $ (7 :: Int)
 goes to:
     Main.$wfold =
       \ (ww_sOb :: Int#) (ww1_sOf :: Int#) ->
         case ww1_sOf of wild_XM {
           __DEFAULT -> Main.$wfold (+# ww_sOb 56) (+# wild_XM 1);
           10000000 -> ww_sOb
         }
-}

-- Note [toIntegralSized optimization]
-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-- The code in 'toIntegralSized' relies on GHC optimizing away statically
-- decidable branches.
--
-- If both integral types are statically known, GHC will be able optimize the
-- code significantly (for @-O1@ and better).
--
-- For instance (as of GHC 7.8.1) the following definitions:
--
-- > w16_to_i32 = toIntegralSized :: Word16 -> Maybe Int32
-- >
-- > i16_to_w16 = toIntegralSized :: Int16 -> Maybe Word16
--
-- are translated into the following (simplified) /GHC Core/ language:
--
-- > w16_to_i32 = \x -> Just (case x of _ { W16# x# -> I32# (word2Int# x#) })
-- >
-- > i16_to_w16 = \x -> case eta of _
-- >   { I16# b1 -> case tagToEnum# (<=# 0 b1) of _
-- >       { False -> Nothing
-- >       ; True -> Just (W16# (narrow16Word# (int2Word# b1)))
-- >       }
-- >   }


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

-----------------------------------------------------------------------------
-- |
-- Module      :  Data.Bool
-- Copyright   :  (c) The University of Glasgow 2001
-- License     :  BSD-style (see the file libraries/base/LICENSE)
--
-- Maintainer  :  libraries@haskell.org
-- Stability   :  experimental
-- Portability :  portable
--
-- The 'Bool' type and related functions.
--
-----------------------------------------------------------------------------

module Data.Bool (
   -- * Booleans
   Bool(..),
   -- ** Operations
   (&&),
   (||),
   not,
   otherwise,
   bool,
  ) where

import GHC.Base

-- | Case analysis for the 'Bool' type. @'bool' x y p@ evaluates to @x@
-- when @p@ is 'False', and evaluates to @y@ when @p@ is 'True'.
--
-- This is equivalent to @if p then y else x@; that is, one can
-- think of it as an if-then-else construct with its arguments
-- reordered.
--
-- @since 4.7.0.0
--
-- ==== __Examples__
--
-- Basic usage:
--
-- >>> bool "foo" "bar" True
-- "bar"
-- >>> bool "foo" "bar" False
-- "foo"
--
-- Confirm that @'bool' x y p@ and @if p then y else x@ are
-- equivalent:
--
-- >>> let p = True; x = "bar"; y = "foo"
-- >>> bool x y p == if p then y else x
-- True
-- >>> let p = False
-- >>> bool x y p == if p then y else x
-- True
--
bool :: a -> a -> Bool -> a
bool f _ False = f
bool _ t True  = t


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

-----------------------------------------------------------------------------
-- |
-- Module      :  Data.Char
-- Copyright   :  (c) The University of Glasgow 2001
-- License     :  BSD-style (see the file libraries/base/LICENSE)
--
-- Maintainer  :  libraries@haskell.org
-- Stability   :  stable
-- Portability :  portable
--
-- The Char type and associated operations.
--
-----------------------------------------------------------------------------

module Data.Char
    (
      Char

    -- * Character classification
    -- | Unicode characters are divided into letters, numbers, marks,
    -- punctuation, symbols, separators (including spaces) and others
    -- (including control characters).
    , isControl, isSpace
    , isLower, isUpper, isAlpha, isAlphaNum, isPrint
    , isDigit, isOctDigit, isHexDigit
    , isLetter, isMark, isNumber, isPunctuation, isSymbol, isSeparator

    -- ** Subranges
    , isAscii, isLatin1
    , isAsciiUpper, isAsciiLower

    -- ** Unicode general categories
    , GeneralCategory(..), generalCategory

    -- * Case conversion
    , toUpper, toLower, toTitle

    -- * Single digit characters
    , digitToInt
    , intToDigit

    -- * Numeric representations
    , ord
    , chr

    -- * String representations
    , showLitChar
    , lexLitChar
    , readLitChar
    ) where

import GHC.Base
import GHC.Char
import GHC.Real (fromIntegral)
import GHC.Show
import GHC.Read (readLitChar, lexLitChar)
import GHC.Unicode
import GHC.Num

-- $setup
-- Allow the use of Prelude in doctests.
-- >>> import Prelude

-- | Convert a single digit 'Char' to the corresponding 'Int'.  This
-- function fails unless its argument satisfies 'isHexDigit', but
-- recognises both upper- and lower-case hexadecimal digits (that
-- is, @\'0\'@..@\'9\'@, @\'a\'@..@\'f\'@, @\'A\'@..@\'F\'@).
--
-- ==== __Examples__
--
-- Characters @\'0\'@ through @\'9\'@ are converted properly to
-- @0..9@:
--
-- >>> map digitToInt ['0'..'9']
-- [0,1,2,3,4,5,6,7,8,9]
--
-- Both upper- and lower-case @\'A\'@ through @\'F\'@ are converted
-- as well, to @10..15@.
--
-- >>> map digitToInt ['a'..'f']
-- [10,11,12,13,14,15]
-- >>> map digitToInt ['A'..'F']
-- [10,11,12,13,14,15]
--
-- Anything else throws an exception:
--
-- >>> digitToInt 'G'
-- *** Exception: Char.digitToInt: not a digit 'G'
-- >>> digitToInt 'â™¥'
-- *** Exception: Char.digitToInt: not a digit '\9829'
--
digitToInt :: Char -> Int
digitToInt c
  | (fromIntegral dec::Word) <= 9 = dec
  | (fromIntegral hexl::Word) <= 5 = hexl + 10
  | (fromIntegral hexu::Word) <= 5 = hexu + 10
  | otherwise = errorWithoutStackTrace ("Char.digitToInt: not a digit " ++ show c) -- sigh
  where
    dec = ord c - ord '0'
    hexl = ord c - ord 'a'
    hexu = ord c - ord 'A'

-- derived character classifiers

-- | Selects alphabetic Unicode characters (lower-case, upper-case and
-- title-case letters, plus letters of caseless scripts and
-- modifiers letters). This function is equivalent to
-- 'Data.Char.isAlpha'.
--
-- This function returns 'True' if its argument has one of the
-- following 'GeneralCategory's, or 'False' otherwise:
--
-- * 'UppercaseLetter'
-- * 'LowercaseLetter'
-- * 'TitlecaseLetter'
-- * 'ModifierLetter'
-- * 'OtherLetter'
--
-- These classes are defined in the
-- <http://www.unicode.org/reports/tr44/tr44-14.html#GC_Values_Table Unicode Character Database>,
-- part of the Unicode standard. The same document defines what is
-- and is not a \"Letter\".
--
-- ==== __Examples__
--
-- Basic usage:
--
-- >>> isLetter 'a'
-- True
-- >>> isLetter 'A'
-- True
-- >>> isLetter 'Î»'
-- True
-- >>> isLetter '0'
-- False
-- >>> isLetter '%'
-- False
-- >>> isLetter 'â™¥'
-- False
-- >>> isLetter '\31'
-- False
--
-- Ensure that 'isLetter' and 'isAlpha' are equivalent.
--
-- >>> let chars = [(chr 0)..]
-- >>> let letters = map isLetter chars
-- >>> let alphas = map isAlpha chars
-- >>> letters == alphas
-- True
--
isLetter :: Char -> Bool
isLetter c = case generalCategory c of
        UppercaseLetter         -> True
        LowercaseLetter         -> True
        TitlecaseLetter         -> True
        ModifierLetter          -> True
        OtherLetter             -> True
        _                       -> False

-- | Selects Unicode mark characters, for example accents and the
-- like, which combine with preceding characters.
--
-- This function returns 'True' if its argument has one of the
-- following 'GeneralCategory's, or 'False' otherwise:
--
-- * 'NonSpacingMark'
-- * 'SpacingCombiningMark'
-- * 'EnclosingMark'
--
-- These classes are defined in the
-- <http://www.unicode.org/reports/tr44/tr44-14.html#GC_Values_Table Unicode Character Database>,
-- part of the Unicode standard. The same document defines what is
-- and is not a \"Mark\".
--
-- ==== __Examples__
--
-- Basic usage:
--
-- >>> isMark 'a'
-- False
-- >>> isMark '0'
-- False
--
-- Combining marks such as accent characters usually need to follow
-- another character before they become printable:
--
-- >>> map isMark "oÌ€"
-- [False,True]
--
-- Puns are not necessarily supported:
--
-- >>> isMark 'âœ“'
-- False
--
isMark :: Char -> Bool
isMark c = case generalCategory c of
        NonSpacingMark          -> True
        SpacingCombiningMark    -> True
        EnclosingMark           -> True
        _                       -> False

-- | Selects Unicode numeric characters, including digits from various
-- scripts, Roman numerals, et cetera.
--
-- This function returns 'True' if its argument has one of the
-- following 'GeneralCategory's, or 'False' otherwise:
--
-- * 'DecimalNumber'
-- * 'LetterNumber'
-- * 'OtherNumber'
--
-- These classes are defined in the
-- <http://www.unicode.org/reports/tr44/tr44-14.html#GC_Values_Table Unicode Character Database>,
-- part of the Unicode standard. The same document defines what is
-- and is not a \"Number\".
--
-- ==== __Examples__
--
-- Basic usage:
--
-- >>> isNumber 'a'
-- False
-- >>> isNumber '%'
-- False
-- >>> isNumber '3'
-- True
--
-- ASCII @\'0\'@ through @\'9\'@ are all numbers:
--
-- >>> and $ map isNumber ['0'..'9']
-- True
--
-- Unicode Roman numerals are \"numbers\" as well:
--
-- >>> isNumber 'â…¨'
-- True
--
isNumber :: Char -> Bool
isNumber c = case generalCategory c of
        DecimalNumber           -> True
        LetterNumber            -> True
        OtherNumber             -> True
        _                       -> False

-- | Selects Unicode space and separator characters.
--
-- This function returns 'True' if its argument has one of the
-- following 'GeneralCategory's, or 'False' otherwise:
--
-- * 'Space'
-- * 'LineSeparator'
-- * 'ParagraphSeparator'
--
-- These classes are defined in the
-- <http://www.unicode.org/reports/tr44/tr44-14.html#GC_Values_Table Unicode Character Database>,
-- part of the Unicode standard. The same document defines what is
-- and is not a \"Separator\".
--
-- ==== __Examples__
--
-- Basic usage:
--
-- >>> isSeparator 'a'
-- False
-- >>> isSeparator '6'
-- False
-- >>> isSeparator ' '
-- True
--
-- Warning: newlines and tab characters are not considered
-- separators.
--
-- >>> isSeparator '\n'
-- False
-- >>> isSeparator '\t'
-- False
--
-- But some more exotic characters are (like HTML's @ @):
--
-- >>> isSeparator '\160'
-- True
--
isSeparator :: Char -> Bool
isSeparator c = case generalCategory c of
        Space                   -> True
        LineSeparator           -> True
        ParagraphSeparator      -> True
        _                       -> False


{-# LANGUAGE Unsafe #-}
{-# LANGUAGE NoImplicitPrelude #-}

-----------------------------------------------------------------------------
-- |
-- Module      :  Data.Coerce
-- Copyright   :  (c) The University of Glasgow 2001
-- License     :  BSD-style (see the file libraries/base/LICENSE)
--
-- Maintainer  :  libraries@haskell.org
-- Stability   :  provisional
-- Portability :  portable
--
-- Safe coercions between data types.
--
-- More in-depth information can be found on the
-- <https://ghc.haskell.org/trac/ghc/wiki/Roles Roles wiki page>
--
-- @since 4.7.0.0
-----------------------------------------------------------------------------

module Data.Coerce
        ( -- * Safe coercions
          coerce, Coercible,
        ) where
import GHC.Prim (coerce)
import GHC.Types (Coercible)

import GHC.Base () -- for build ordering; see Notes in GHC.Base for more info


{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE Trustworthy #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DeriveTraversable #-}

-----------------------------------------------------------------------------
-- |
-- Module      :  Data.Complex
-- Copyright   :  (c) The University of Glasgow 2001
-- License     :  BSD-style (see the file libraries/base/LICENSE)
--
-- Maintainer  :  libraries@haskell.org
-- Stability   :  provisional
-- Portability :  portable
--
-- Complex numbers.
--
-----------------------------------------------------------------------------

module Data.Complex
        (
        -- * Rectangular form
          Complex((:+))

        , realPart
        , imagPart
        -- * Polar form
        , mkPolar
        , cis
        , polar
        , magnitude
        , phase
        -- * Conjugate
        , conjugate

        )  where

import GHC.Base (Applicative (..))
import GHC.Generics (Generic, Generic1)
import GHC.Float (Floating(..))
import Data.Data (Data)
import Foreign (Storable, castPtr, peek, poke, pokeElemOff, peekElemOff, sizeOf,
                alignment)

infix  6  :+

-- -----------------------------------------------------------------------------
-- The Complex type

-- | Complex numbers are an algebraic type.
--
-- For a complex number @z@, @'abs' z@ is a number with the magnitude of @z@,
-- but oriented in the positive real direction, whereas @'signum' z@
-- has the phase of @z@, but unit magnitude.
--
-- The 'Foldable' and 'Traversable' instances traverse the real part first.
--
-- Note that `Complex`'s instances inherit the deficiencies from the type
-- parameter's. For example, @Complex Float@'s 'Ord' instance has similar
-- problems to `Float`'s.
data Complex a
  = !a :+ !a    -- ^ forms a complex number from its real and imaginary
                -- rectangular components.
        deriving ( Eq          -- ^ @since 2.01
                 , Show        -- ^ @since 2.01
                 , Read        -- ^ @since 2.01
                 , Data        -- ^ @since 2.01
                 , Generic     -- ^ @since 4.9.0.0
                 , Generic1    -- ^ @since 4.9.0.0
                 , Functor     -- ^ @since 4.9.0.0
                 , Foldable    -- ^ @since 4.9.0.0
                 , Traversable -- ^ @since 4.9.0.0
                 )

-- -----------------------------------------------------------------------------
-- Functions over Complex

-- | Extracts the real part of a complex number.
realPart :: Complex a -> a
realPart (x :+ _) =  x

-- | Extracts the imaginary part of a complex number.
imagPart :: Complex a -> a
imagPart (_ :+ y) =  y

-- | The conjugate of a complex number.
{-# SPECIALISE conjugate :: Complex Double -> Complex Double #-}
conjugate        :: Num a => Complex a -> Complex a
conjugate (x:+y) =  x :+ (-y)

-- | Form a complex number from polar components of magnitude and phase.
{-# SPECIALISE mkPolar :: Double -> Double -> Complex Double #-}
mkPolar          :: Floating a => a -> a -> Complex a
mkPolar r theta  =  r * cos theta :+ r * sin theta

-- | @'cis' t@ is a complex value with magnitude @1@
-- and phase @t@ (modulo @2*'pi'@).
{-# SPECIALISE cis :: Double -> Complex Double #-}
cis              :: Floating a => a -> Complex a
cis theta        =  cos theta :+ sin theta

-- | The function 'polar' takes a complex number and
-- returns a (magnitude, phase) pair in canonical form:
-- the magnitude is nonnegative, and the phase in the range @(-'pi', 'pi']@;
-- if the magnitude is zero, then so is the phase.
{-# SPECIALISE polar :: Complex Double -> (Double,Double) #-}
polar            :: (RealFloat a) => Complex a -> (a,a)
polar z          =  (magnitude z, phase z)

-- | The nonnegative magnitude of a complex number.
{-# SPECIALISE magnitude :: Complex Double -> Double #-}
magnitude :: (RealFloat a) => Complex a -> a
magnitude (x:+y) =  scaleFloat k
                     (sqrt (sqr (scaleFloat mk x) + sqr (scaleFloat mk y)))
                    where k  = max (exponent x) (exponent y)
                          mk = - k
                          sqr z = z * z

-- | The phase of a complex number, in the range @(-'pi', 'pi']@.
-- If the magnitude is zero, then so is the phase.
{-# SPECIALISE phase :: Complex Double -> Double #-}
phase :: (RealFloat a) => Complex a -> a
phase (0 :+ 0)   = 0            -- SLPJ July 97 from John Peterson
phase (x:+y)     = atan2 y x

-- -----------------------------------------------------------------------------
-- Instances of Complex

-- | @since 2.01
instance  (RealFloat a) => Num (Complex a)  where
    {-# SPECIALISE instance Num (Complex Float) #-}
    {-# SPECIALISE instance Num (Complex Double) #-}
    (x:+y) + (x':+y')   =  (x+x') :+ (y+y')
    (x:+y) - (x':+y')   =  (x-x') :+ (y-y')
    (x:+y) * (x':+y')   =  (x*x'-y*y') :+ (x*y'+y*x')
    negate (x:+y)       =  negate x :+ negate y
    abs z               =  magnitude z :+ 0
    signum (0:+0)       =  0
    signum z@(x:+y)     =  x/r :+ y/r  where r = magnitude z
    fromInteger n       =  fromInteger n :+ 0

-- | @since 2.01
instance  (RealFloat a) => Fractional (Complex a)  where
    {-# SPECIALISE instance Fractional (Complex Float) #-}
    {-# SPECIALISE instance Fractional (Complex Double) #-}
    (x:+y) / (x':+y')   =  (x*x''+y*y'') / d :+ (y*x''-x*y'') / d
                           where x'' = scaleFloat k x'
                                 y'' = scaleFloat k y'
                                 k   = - max (exponent x') (exponent y')
                                 d   = x'*x'' + y'*y''

    fromRational a      =  fromRational a :+ 0

-- | @since 2.01
instance  (RealFloat a) => Floating (Complex a) where
    {-# SPECIALISE instance Floating (Complex Float) #-}
    {-# SPECIALISE instance Floating (Complex Double) #-}
    pi             =  pi :+ 0
    exp (x:+y)     =  expx * cos y :+ expx * sin y
                      where expx = exp x
    log z          =  log (magnitude z) :+ phase z

    x ** y = case (x,y) of
      (_ , (0:+0))  -> 1 :+ 0
      ((0:+0), (exp_re:+_)) -> case compare exp_re 0 of
                 GT -> 0 :+ 0
                 LT -> inf :+ 0
                 EQ -> nan :+ nan
      ((re:+im), (exp_re:+_))
        | (isInfinite re || isInfinite im) -> case compare exp_re 0 of
                 GT -> inf :+ 0
                 LT -> 0 :+ 0
                 EQ -> nan :+ nan
        | otherwise -> exp (log x * y)
      where
        inf = 1/0
        nan = 0/0

    sqrt (0:+0)    =  0
    sqrt z@(x:+y)  =  u :+ (if y < 0 then -v else v)
                      where (u,v) = if x < 0 then (v',u') else (u',v')
                            v'    = abs y / (u'*2)
                            u'    = sqrt ((magnitude z + abs x) / 2)

    sin (x:+y)     =  sin x * cosh y :+ cos x * sinh y
    cos (x:+y)     =  cos x * cosh y :+ (- sin x * sinh y)
    tan (x:+y)     =  (sinx*coshy:+cosx*sinhy)/(cosx*coshy:+(-sinx*sinhy))
                      where sinx  = sin x
                            cosx  = cos x
                            sinhy = sinh y
                            coshy = cosh y

    sinh (x:+y)    =  cos y * sinh x :+ sin  y * cosh x
    cosh (x:+y)    =  cos y * cosh x :+ sin y * sinh x
    tanh (x:+y)    =  (cosy*sinhx:+siny*coshx)/(cosy*coshx:+siny*sinhx)
                      where siny  = sin y
                            cosy  = cos y
                            sinhx = sinh x
                            coshx = cosh x

    asin z@(x:+y)  =  y':+(-x')
                      where  (x':+y') = log (((-y):+x) + sqrt (1 - z*z))
    acos z         =  y'':+(-x'')
                      where (x'':+y'') = log (z + ((-y'):+x'))
                            (x':+y')   = sqrt (1 - z*z)
    atan z@(x:+y)  =  y':+(-x')
                      where (x':+y') = log (((1-y):+x) / sqrt (1+z*z))

    asinh z        =  log (z + sqrt (1+z*z))
    -- Take care to allow (-1)::Complex, fixing #8532
    acosh z        =  log (z + (sqrt $ z+1) * (sqrt $ z-1))
    atanh z        =  0.5 * log ((1.0+z) / (1.0-z))

    log1p x@(a :+ b)
      | abs a < 0.5 && abs b < 0.5
      , u <- 2*a + a*a + b*b = log1p (u/(1 + sqrt(u+1))) :+ atan2 (1 + a) b
      | otherwise = log (1 + x)
    {-# INLINE log1p #-}

    expm1 x@(a :+ b)
      | a*a + b*b < 1
      , u <- expm1 a
      , v <- sin (b/2)
      , w <- -2*v*v = (u*w + u + w) :+ (u+1)*sin b
      | otherwise = exp x - 1
    {-# INLINE expm1 #-}

-- | @since 4.8.0.0
instance Storable a => Storable (Complex a) where
    sizeOf a       = 2 * sizeOf (realPart a)
    alignment a    = alignment (realPart a)
    peek p           = do
                        q <- return $ castPtr p
                        r <- peek q
                        i <- peekElemOff q 1
                        return (r :+ i)
    poke p (r :+ i)  = do
                        q <-return $  (castPtr p)
                        poke q r
                        pokeElemOff q 1 i

-- | @since 4.9.0.0
instance Applicative Complex where
  pure a = a :+ a
  f :+ g <*> a :+ b = f a :+ g b
  liftA2 f (x :+ y) (a :+ b) = f x a :+ f y b

-- | @since 4.9.0.0
instance Monad Complex where
  a :+ b >>= f = realPart (f a) :+ imagPart (f b)

-- -----------------------------------------------------------------------------
-- Rules on Complex

{-# RULES

"realToFrac/a->Complex Double"
  realToFrac = \x -> realToFrac x :+ (0 :: Double)

"realToFrac/a->Complex Float"
  realToFrac = \x -> realToFrac x :+ (0 :: Float)

  #-}