{-# LANGUAGE CPP                        #-}
{-# LANGUAGE DefaultSignatures          #-}
{-# LANGUAGE DeriveDataTypeable         #-}
{-# LANGUAGE DeriveGeneric              #-}
{-# LANGUAGE FlexibleContexts           #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE PolyKinds                  #-}
{-# LANGUAGE ScopedTypeVariables        #-}
{-# LANGUAGE Trustworthy                #-}
{-# LANGUAGE TypeOperators              #-}

-----------------------------------------------------------------------------
-- |
-- Module      :  Data.Semigroup
-- Copyright   :  (C) 2011-2015 Edward Kmett
-- License     :  BSD-style (see the file LICENSE)
--
-- Maintainer  :  libraries@haskell.org
-- Stability   :  provisional
-- Portability :  portable
--
-- A type @a@ is a 'Semigroup' if it provides an associative function ('<>')
-- that lets you combine any two values of type @a@ into one. Where being
-- associative means that the following must always hold:
--
-- >>> (a <> b) <> c == a <> (b <> c)
--
-- ==== __Examples__
--
-- The 'Min' 'Semigroup' instance for 'Int' is defined to always pick the smaller
-- number:
-- >>> Min 1 <> Min 2 <> Min 3 <> Min 4 :: Min Int
-- Min {getMin = 1}
--
-- If we need to combine multiple values we can use the 'sconcat' function
-- to do so. We need to ensure however that we have at least one value to
-- operate on, since otherwise our result would be undefined. It is for this
-- reason that 'sconcat' uses "Data.List.NonEmpty.NonEmpty" - a list that
-- can never be empty:
--
-- >>> (1 :| [])
-- 1 :| []               -- equivalent to [1] but guaranteed to be non-empty
-- >>> (1 :| [2, 3, 4])
-- 1 :| [2,3,4]          -- equivalent to [1,2,3,4] but guaranteed to be non-empty
--
-- Equipped with this guaranteed to be non-empty data structure, we can combine
-- values using 'sconcat' and a 'Semigroup' of our choosing. We can try the 'Min'
-- and 'Max' instances of 'Int' which pick the smallest, or largest number
-- respectively:
--
-- >>> sconcat (1 :| [2, 3, 4]) :: Min Int
-- Min {getMin = 1}
-- >>> sconcat (1 :| [2, 3, 4]) :: Max Int
-- Max {getMax = 4}
--
-- String concatenation is another example of a 'Semigroup' instance:
--
-- >>> "foo" <> "bar"
-- "foobar"
--
-- A 'Semigroup' is a generalization of a 'Monoid'. Yet unlike the 'Semigroup', the 'Monoid'
-- requires the presence of a neutral element ('mempty') in addition to the associative
-- operator. The requirement for a neutral element prevents many types from being a full Monoid,
-- like "Data.List.NonEmpty.NonEmpty".
--
-- Note that the use of @(\<\>)@ in this module conflicts with an operator with the same
-- name that is being exported by "Data.Monoid". However, this package
-- re-exports (most of) the contents of Data.Monoid, so to use semigroups
-- and monoids in the same package just
--
-- > import Data.Semigroup
--
-- @since 4.9.0.0
----------------------------------------------------------------------------
module Data.Semigroup (
    Semigroup(..)
  , stimesMonoid
  , stimesIdempotent
  , stimesIdempotentMonoid
  , mtimesDefault
  -- * Semigroups
  , Min(..)
  , Max(..)
  , First(..)
  , Last(..)
  , WrappedMonoid(..)
  -- * Re-exported monoids from Data.Monoid
  , Dual(..)
  , Endo(..)
  , All(..)
  , Any(..)
  , Sum(..)
  , Product(..)
  -- * A better monoid for Maybe
  , Option(..)
  , option
  -- * Difference lists of a semigroup
  , diff
  , cycle1
  -- * ArgMin, ArgMax
  , Arg(..)
  , ArgMin
  , ArgMax
  ) where

import           Prelude             hiding (foldr1)

import GHC.Base (Semigroup(..))

import           Data.Semigroup.Internal

import           Control.Applicative
import           Control.Monad
import           Control.Monad.Fix
import           Data.Bifoldable
import           Data.Bifunctor
import           Data.Bitraversable
import           Data.Coerce
import           Data.Data
import           GHC.Generics

-- | A generalization of 'Data.List.cycle' to an arbitrary 'Semigroup'.
-- May fail to terminate for some values in some semigroups.
cycle1 :: Semigroup m => m -> m
cycle1 xs = xs' where xs' = xs <> xs'

-- | This lets you use a difference list of a 'Semigroup' as a 'Monoid'.
diff :: Semigroup m => m -> Endo m
diff = Endo . (<>)

newtype Min a = Min { getMin :: a }
  deriving ( Bounded  -- ^ @since 4.9.0.0
           , Eq       -- ^ @since 4.9.0.0
           , Ord      -- ^ @since 4.9.0.0
           , Show     -- ^ @since 4.9.0.0
           , Read     -- ^ @since 4.9.0.0
           , Data     -- ^ @since 4.9.0.0
           , Generic  -- ^ @since 4.9.0.0
           , Generic1 -- ^ @since 4.9.0.0
           )

-- | @since 4.9.0.0
instance Enum a => Enum (Min a) where
  succ (Min a) = Min (succ a)
  pred (Min a) = Min (pred a)
  toEnum = Min . toEnum
  fromEnum = fromEnum . getMin
  enumFrom (Min a) = Min <$> enumFrom a
  enumFromThen (Min a) (Min b) = Min <$> enumFromThen a b
  enumFromTo (Min a) (Min b) = Min <$> enumFromTo a b
  enumFromThenTo (Min a) (Min b) (Min c) = Min <$> enumFromThenTo a b c

-- | @since 4.9.0.0
instance Ord a => Semigroup (Min a) where
  (<>) = coerce (min :: a -> a -> a)
  stimes = stimesIdempotent

-- | @since 4.9.0.0
instance (Ord a, Bounded a) => Monoid (Min a) where
  mempty = maxBound

-- | @since 4.9.0.0
instance Functor Min where
  fmap f (Min x) = Min (f x)

-- | @since 4.9.0.0
instance Foldable Min where
  foldMap f (Min a) = f a

-- | @since 4.9.0.0
instance Traversable Min where
  traverse f (Min a) = Min <$> f a

-- | @since 4.9.0.0
instance Applicative Min where
  pure = Min
  a <* _ = a
  _ *> a = a
  (<*>) = coerce
  liftA2 = coerce

-- | @since 4.9.0.0
instance Monad Min where
  (>>) = (*>)
  Min a >>= f = f a

-- | @since 4.9.0.0
instance MonadFix Min where
  mfix f = fix (f . getMin)

-- | @since 4.9.0.0
instance Num a => Num (Min a) where
  (Min a) + (Min b) = Min (a + b)
  (Min a) * (Min b) = Min (a * b)
  (Min a) - (Min b) = Min (a - b)
  negate (Min a) = Min (negate a)
  abs    (Min a) = Min (abs a)
  signum (Min a) = Min (signum a)
  fromInteger    = Min . fromInteger

newtype Max a = Max { getMax :: a }
  deriving ( Bounded  -- ^ @since 4.9.0.0
           , Eq       -- ^ @since 4.9.0.0
           , Ord      -- ^ @since 4.9.0.0
           , Show     -- ^ @since 4.9.0.0
           , Read     -- ^ @since 4.9.0.0
           , Data     -- ^ @since 4.9.0.0
           , Generic  -- ^ @since 4.9.0.0
           , Generic1 -- ^ @since 4.9.0.0
           )

-- | @since 4.9.0.0
instance Enum a => Enum (Max a) where
  succ (Max a) = Max (succ a)
  pred (Max a) = Max (pred a)
  toEnum = Max . toEnum
  fromEnum = fromEnum . getMax
  enumFrom (Max a) = Max <$> enumFrom a
  enumFromThen (Max a) (Max b) = Max <$> enumFromThen a b
  enumFromTo (Max a) (Max b) = Max <$> enumFromTo a b
  enumFromThenTo (Max a) (Max b) (Max c) = Max <$> enumFromThenTo a b c

-- | @since 4.9.0.0
instance Ord a => Semigroup (Max a) where
  (<>) = coerce (max :: a -> a -> a)
  stimes = stimesIdempotent

-- | @since 4.9.0.0
instance (Ord a, Bounded a) => Monoid (Max a) where
  mempty = minBound

-- | @since 4.9.0.0
instance Functor Max where
  fmap f (Max x) = Max (f x)

-- | @since 4.9.0.0
instance Foldable Max where
  foldMap f (Max a) = f a

-- | @since 4.9.0.0
instance Traversable Max where
  traverse f (Max a) = Max <$> f a

-- | @since 4.9.0.0
instance Applicative Max where
  pure = Max
  a <* _ = a
  _ *> a = a
  (<*>) = coerce
  liftA2 = coerce

-- | @since 4.9.0.0
instance Monad Max where
  (>>) = (*>)
  Max a >>= f = f a

-- | @since 4.9.0.0
instance MonadFix Max where
  mfix f = fix (f . getMax)

-- | @since 4.9.0.0
instance Num a => Num (Max a) where
  (Max a) + (Max b) = Max (a + b)
  (Max a) * (Max b) = Max (a * b)
  (Max a) - (Max b) = Max (a - b)
  negate (Max a) = Max (negate a)
  abs    (Max a) = Max (abs a)
  signum (Max a) = Max (signum a)
  fromInteger    = Max . fromInteger

-- | 'Arg' isn't itself a 'Semigroup' in its own right, but it can be
-- placed inside 'Min' and 'Max' to compute an arg min or arg max.
data Arg a b = Arg a b deriving
  ( Show     -- ^ @since 4.9.0.0
  , Read     -- ^ @since 4.9.0.0
  , Data     -- ^ @since 4.9.0.0
  , Generic  -- ^ @since 4.9.0.0
  , Generic1 -- ^ @since 4.9.0.0
  )

type ArgMin a b = Min (Arg a b)
type ArgMax a b = Max (Arg a b)

-- | @since 4.9.0.0
instance Functor (Arg a) where
  fmap f (Arg x a) = Arg x (f a)

-- | @since 4.9.0.0
instance Foldable (Arg a) where
  foldMap f (Arg _ a) = f a

-- | @since 4.9.0.0
instance Traversable (Arg a) where
  traverse f (Arg x a) = Arg x <$> f a

-- | @since 4.9.0.0
instance Eq a => Eq (Arg a b) where
  Arg a _ == Arg b _ = a == b

-- | @since 4.9.0.0
instance Ord a => Ord (Arg a b) where
  Arg a _ `compare` Arg b _ = compare a b
  min x@(Arg a _) y@(Arg b _)
    | a <= b    = x
    | otherwise = y
  max x@(Arg a _) y@(Arg b _)
    | a >= b    = x
    | otherwise = y

-- | @since 4.9.0.0
instance Bifunctor Arg where
  bimap f g (Arg a b) = Arg (f a) (g b)

-- | @since 4.10.0.0
instance Bifoldable Arg where
  bifoldMap f g (Arg a b) = f a <> g b

-- | @since 4.10.0.0
instance Bitraversable Arg where
  bitraverse f g (Arg a b) = Arg <$> f a <*> g b

-- | Use @'Option' ('First' a)@ to get the behavior of
-- 'Data.Monoid.First' from "Data.Monoid".
newtype First a = First { getFirst :: a }
  deriving ( Bounded  -- ^ @since 4.9.0.0
           , Eq       -- ^ @since 4.9.0.0
           , Ord      -- ^ @since 4.9.0.0
           , Show     -- ^ @since 4.9.0.0
           , Read     -- ^ @since 4.9.0.0
           , Data     -- ^ @since 4.9.0.0
           , Generic  -- ^ @since 4.9.0.0
           , Generic1 -- ^ @since 4.9.0.0
           )

-- | @since 4.9.0.0
instance Enum a => Enum (First a) where
  succ (First a) = First (succ a)
  pred (First a) = First (pred a)
  toEnum = First . toEnum
  fromEnum = fromEnum . getFirst
  enumFrom (First a) = First <$> enumFrom a
  enumFromThen (First a) (First b) = First <$> enumFromThen a b
  enumFromTo (First a) (First b) = First <$> enumFromTo a b
  enumFromThenTo (First a) (First b) (First c) = First <$> enumFromThenTo a b c

-- | @since 4.9.0.0
instance Semigroup (First a) where
  a <> _ = a
  stimes = stimesIdempotent

-- | @since 4.9.0.0
instance Functor First where
  fmap f (First x) = First (f x)

-- | @since 4.9.0.0
instance Foldable First where
  foldMap f (First a) = f a

-- | @since 4.9.0.0
instance Traversable First where
  traverse f (First a) = First <$> f a

-- | @since 4.9.0.0
instance Applicative First where
  pure x = First x
  a <* _ = a
  _ *> a = a
  (<*>) = coerce
  liftA2 = coerce

-- | @since 4.9.0.0
instance Monad First where
  (>>) = (*>)
  First a >>= f = f a

-- | @since 4.9.0.0
instance MonadFix First where
  mfix f = fix (f . getFirst)

-- | Use @'Option' ('Last' a)@ to get the behavior of
-- 'Data.Monoid.Last' from "Data.Monoid"
newtype Last a = Last { getLast :: a }
  deriving ( Bounded  -- ^ @since 4.9.0.0
           , Eq       -- ^ @since 4.9.0.0
           , Ord      -- ^ @since 4.9.0.0
           , Show     -- ^ @since 4.9.0.0
           , Read     -- ^ @since 4.9.0.0
           , Data     -- ^ @since 4.9.0.0
           , Generic  -- ^ @since 4.9.0.0
           , Generic1 -- ^ @since 4.9.0.0
           )

-- | @since 4.9.0.0
instance Enum a => Enum (Last a) where
  succ (Last a) = Last (succ a)
  pred (Last a) = Last (pred a)
  toEnum = Last . toEnum
  fromEnum = fromEnum . getLast
  enumFrom (Last a) = Last <$> enumFrom a
  enumFromThen (Last a) (Last b) = Last <$> enumFromThen a b
  enumFromTo (Last a) (Last b) = Last <$> enumFromTo a b
  enumFromThenTo (Last a) (Last b) (Last c) = Last <$> enumFromThenTo a b c

-- | @since 4.9.0.0
instance Semigroup (Last a) where
  _ <> b = b
  stimes = stimesIdempotent

-- | @since 4.9.0.0
instance Functor Last where
  fmap f (Last x) = Last (f x)
  a <$ _ = Last a

-- | @since 4.9.0.0
instance Foldable Last where
  foldMap f (Last a) = f a

-- | @since 4.9.0.0
instance Traversable Last where
  traverse f (Last a) = Last <$> f a

-- | @since 4.9.0.0
instance Applicative Last where
  pure = Last
  a <* _ = a
  _ *> a = a
  (<*>) = coerce
  liftA2 = coerce

-- | @since 4.9.0.0
instance Monad Last where
  (>>) = (*>)
  Last a >>= f = f a

-- | @since 4.9.0.0
instance MonadFix Last where
  mfix f = fix (f . getLast)

-- | Provide a Semigroup for an arbitrary Monoid.
--
-- __NOTE__: This is not needed anymore since 'Semigroup' became a superclass of
-- 'Monoid' in /base-4.11/ and this newtype be deprecated at some point in the future.
newtype WrappedMonoid m = WrapMonoid { unwrapMonoid :: m }
  deriving ( Bounded  -- ^ @since 4.9.0.0
           , Eq       -- ^ @since 4.9.0.0
           , Ord      -- ^ @since 4.9.0.0
           , Show     -- ^ @since 4.9.0.0
           , Read     -- ^ @since 4.9.0.0
           , Data     -- ^ @since 4.9.0.0
           , Generic  -- ^ @since 4.9.0.0
           , Generic1 -- ^ @since 4.9.0.0
           )

-- | @since 4.9.0.0
instance Monoid m => Semigroup (WrappedMonoid m) where
  (<>) = coerce (mappend :: m -> m -> m)

-- | @since 4.9.0.0
instance Monoid m => Monoid (WrappedMonoid m) where
  mempty = WrapMonoid mempty

-- | @since 4.9.0.0
instance Enum a => Enum (WrappedMonoid a) where
  succ (WrapMonoid a) = WrapMonoid (succ a)
  pred (WrapMonoid a) = WrapMonoid (pred a)
  toEnum = WrapMonoid . toEnum
  fromEnum = fromEnum . unwrapMonoid
  enumFrom (WrapMonoid a) = WrapMonoid <$> enumFrom a
  enumFromThen (WrapMonoid a) (WrapMonoid b) = WrapMonoid <$> enumFromThen a b
  enumFromTo (WrapMonoid a) (WrapMonoid b) = WrapMonoid <$> enumFromTo a b
  enumFromThenTo (WrapMonoid a) (WrapMonoid b) (WrapMonoid c) =
      WrapMonoid <$> enumFromThenTo a b c

-- | Repeat a value @n@ times.
--
-- > mtimesDefault n a = a <> a <> ... <> a  -- using <> (n-1) times
--
-- Implemented using 'stimes' and 'mempty'.
--
-- This is a suitable definition for an 'mtimes' member of 'Monoid'.
mtimesDefault :: (Integral b, Monoid a) => b -> a -> a
mtimesDefault n x
  | n == 0    = mempty
  | otherwise = unwrapMonoid (stimes n (WrapMonoid x))

-- | 'Option' is effectively 'Maybe' with a better instance of
-- 'Monoid', built off of an underlying 'Semigroup' instead of an
-- underlying 'Monoid'.
--
-- Ideally, this type would not exist at all and we would just fix the
-- 'Monoid' instance of 'Maybe'.
--
-- In GHC 8.4 and higher, the 'Monoid' instance for 'Maybe' has been
-- corrected to lift a 'Semigroup' instance instead of a 'Monoid'
-- instance. Consequently, this type is no longer useful. It will be
-- marked deprecated in GHC 8.8 and removed in GHC 8.10.
newtype Option a = Option { getOption :: Maybe a }
  deriving ( Eq       -- ^ @since 4.9.0.0
           , Ord      -- ^ @since 4.9.0.0
           , Show     -- ^ @since 4.9.0.0
           , Read     -- ^ @since 4.9.0.0
           , Data     -- ^ @since 4.9.0.0
           , Generic  -- ^ @since 4.9.0.0
           , Generic1 -- ^ @since 4.9.0.0
           )

-- | @since 4.9.0.0
instance Functor Option where
  fmap f (Option a) = Option (fmap f a)

-- | @since 4.9.0.0
instance Applicative Option where
  pure a = Option (Just a)
  Option a <*> Option b = Option (a <*> b)
  liftA2 f (Option x) (Option y) = Option (liftA2 f x y)

  Option Nothing  *>  _ = Option Nothing
  _               *>  b = b

-- | @since 4.9.0.0
instance Monad Option where
  Option (Just a) >>= k = k a
  _               >>= _ = Option Nothing
  (>>) = (*>)

-- | @since 4.9.0.0
instance Alternative Option where
  empty = Option Nothing
  Option Nothing <|> b = b
  a <|> _ = a

-- | @since 4.9.0.0
instance MonadPlus Option

-- | @since 4.9.0.0
instance MonadFix Option where
  mfix f = Option (mfix (getOption . f))

-- | @since 4.9.0.0
instance Foldable Option where
  foldMap f (Option (Just m)) = f m
  foldMap _ (Option Nothing)  = mempty

-- | @since 4.9.0.0
instance Traversable Option where
  traverse f (Option (Just a)) = Option . Just <$> f a
  traverse _ (Option Nothing)  = pure (Option Nothing)

-- | Fold an 'Option' case-wise, just like 'maybe'.
option :: b -> (a -> b) -> Option a -> b
option n j (Option m) = maybe n j m

-- | @since 4.9.0.0
instance Semigroup a => Semigroup (Option a) where
  (<>) = coerce ((<>) :: Maybe a -> Maybe a -> Maybe a)
#if !defined(__HADDOCK_VERSION__)
    -- workaround https://github.com/haskell/haddock/issues/680
  stimes _ (Option Nothing) = Option Nothing
  stimes n (Option (Just a)) = case compare n 0 of
    LT -> errorWithoutStackTrace "stimes: Option, negative multiplier"
    EQ -> Option Nothing
    GT -> Option (Just (stimes n a))
#endif

-- | @since 4.9.0.0
instance Semigroup a => Monoid (Option a) where
  mempty = Option Nothing


{-# LANGUAGE Trustworthy #-}

-----------------------------------------------------------------------------
-- |
-- Module      :  Data.STRef
-- 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 (uses Control.Monad.ST)
--
-- Mutable references in the (strict) ST monad.
--
-----------------------------------------------------------------------------

module Data.STRef (
        -- * STRefs
        STRef,          -- abstract
        newSTRef,
        readSTRef,
        writeSTRef,
        modifySTRef,
        modifySTRef'
 ) where

import GHC.ST
import GHC.STRef

-- | Mutate the contents of an 'STRef'.
--
-- >>> :{
-- runST (do
--     ref <- newSTRef ""
--     modifySTRef ref (const "world")
--     modifySTRef ref (++ "!")
--     modifySTRef ref ("Hello, " ++)
--     readSTRef ref )
-- :}
-- "Hello, world!"
--
-- Be warned that 'modifySTRef' does not apply the function strictly.  This
-- means if the program calls 'modifySTRef' many times, but seldomly uses the
-- value, thunks will pile up in memory resulting in a space leak.  This is a
-- common mistake made when using an 'STRef' as a counter.  For example, the
-- following will leak memory and may produce a stack overflow:
--
-- >>> import Control.Monad (replicateM_)
-- >>> :{
-- print (runST (do
--     ref <- newSTRef 0
--     replicateM_ 1000 $ modifySTRef ref (+1)
--     readSTRef ref ))
-- :}
-- 1000
--
-- To avoid this problem, use 'modifySTRef'' instead.
modifySTRef :: STRef s a -> (a -> a) -> ST s ()
modifySTRef ref f = writeSTRef ref . f =<< readSTRef ref

-- | Strict version of 'modifySTRef'
--
-- @since 4.6.0.0
modifySTRef' :: STRef s a -> (a -> a) -> ST s ()
modifySTRef' ref f = do
    x <- readSTRef ref
    let x' = f x
    x' `seq` writeSTRef ref x'


{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE Trustworthy #-}
{-# LANGUAGE TypeFamilies #-}

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

module Data.String (
   String
 , IsString(..)

 -- * Functions on strings
 , lines
 , words
 , unlines
 , unwords
 ) where

import GHC.Base
import Data.Functor.Const (Const (Const))
import Data.Functor.Identity (Identity (Identity))
import Data.List (lines, words, unlines, unwords)

-- | Class for string-like datastructures; used by the overloaded string
--   extension (-XOverloadedStrings in GHC).
class IsString a where
    fromString :: String -> a

{- Note [IsString String]
~~~~~~~~~~~~~~~~~~~~~~~~~
Previously, the IsString instance that covered String was a flexible
instance for [Char]. This is in some sense the most accurate choice,
but there are cases where it can lead to an ambiguity, for instance:

  show $ "foo" ++ "bar"

The use of (++) ensures that "foo" and "bar" must have type [t] for
some t, but a flexible instance for [Char] will _only_ match if
something further determines t to be Char, and nothing in the above
example actually does.

So, the above example generates an error about the ambiguity of t,
and what's worse, the above behavior can be generated by simply
typing:

   "foo" ++ "bar"

into GHCi with the OverloadedStrings extension enabled.

The new instance fixes this by defining an instance that matches all
[a], and forces a to be Char. This instance, of course, overlaps
with things that the [Char] flexible instance doesn't, but this was
judged to be an acceptable cost, for the gain of providing a less
confusing experience for people experimenting with overloaded strings.

It may be possible to fix this via (extended) defaulting. Currently,
the rules are not able to default t to Char in the above example. If
a more flexible system that enabled this defaulting were put in place,
then it would probably make sense to revert to the flexible [Char]
instance, since extended defaulting is enabled in GHCi. However, it
is not clear at the time of this note exactly what such a system
would be, and it certainly hasn't been implemented.

A test case (should_run/overloadedstringsrun01.hs) has been added to
ensure the good behavior of the above example remains in the future.
-}

-- | @(a ~ Char)@ context was introduced in @4.9.0.0@
--
-- @since 2.01
instance (a ~ Char) => IsString [a] where
         -- See Note [IsString String]
    fromString xs = xs

-- | @since 4.9.0.0
deriving instance IsString a => IsString (Const a b)

-- | @since 4.9.0.0
deriving instance IsString a => IsString (Identity a)


{-# LANGUAGE DeriveTraversable #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE Trustworthy #-}
{-# LANGUAGE TypeOperators #-}

-----------------------------------------------------------------------------
-- |
-- Module      :  Data.Traversable
-- Copyright   :  Conor McBride and Ross Paterson 2005
-- License     :  BSD-style (see the LICENSE file in the distribution)
--
-- Maintainer  :  libraries@haskell.org
-- Stability   :  experimental
-- Portability :  portable
--
-- Class of data structures that can be traversed from left to right,
-- performing an action on each element.
--
-- See also
--
--  * \"Applicative Programming with Effects\",
--    by Conor McBride and Ross Paterson,
--    /Journal of Functional Programming/ 18:1 (2008) 1-13, online at
--    <http://www.soi.city.ac.uk/~ross/papers/Applicative.html>.
--
--  * \"The Essence of the Iterator Pattern\",
--    by Jeremy Gibbons and Bruno Oliveira,
--    in /Mathematically-Structured Functional Programming/, 2006, online at
--    <http://web.comlab.ox.ac.uk/oucl/work/jeremy.gibbons/publications/#iterator>.
--
--  * \"An Investigation of the Laws of Traversals\",
--    by Mauro Jaskelioff and Ondrej Rypacek,
--    in /Mathematically-Structured Functional Programming/, 2012, online at
--    <http://arxiv.org/pdf/1202.2919>.
--
-----------------------------------------------------------------------------

module Data.Traversable (
    -- * The 'Traversable' class
    Traversable(..),
    -- * Utility functions
    for,
    forM,
    mapAccumL,
    mapAccumR,
    -- * General definitions for superclass methods
    fmapDefault,
    foldMapDefault,
    ) where

-- It is convenient to use 'Const' here but this means we must
-- define a few instances here which really belong in Control.Applicative
import Control.Applicative ( Const(..), ZipList(..) )
import Data.Coerce
import Data.Either ( Either(..) )
import Data.Foldable ( Foldable )
import Data.Functor
import Data.Functor.Identity ( Identity(..) )
import Data.Functor.Utils ( StateL(..), StateR(..) )
import Data.Monoid ( Dual(..), Sum(..), Product(..),
                     First(..), Last(..), Alt(..), Ap(..) )
import Data.Ord ( Down(..) )
import Data.Proxy ( Proxy(..) )

import GHC.Arr
import GHC.Base ( Applicative(..), Monad(..), Monoid, Maybe(..), NonEmpty(..),
                  ($), (.), id, flip )
import GHC.Generics
import qualified GHC.List as List ( foldr )

-- | Functors representing data structures that can be traversed from
-- left to right.
--
-- A definition of 'traverse' must satisfy the following laws:
--
-- [Naturality]
--   @t . 'traverse' f = 'traverse' (t . f)@
--   for every applicative transformation @t@
--
-- [Identity]
--   @'traverse' 'Identity' = 'Identity'@
--
-- [Composition]
--   @'traverse' ('Data.Functor.Compose.Compose' . 'fmap' g . f)
--     = 'Data.Functor.Compose.Compose' . 'fmap' ('traverse' g) . 'traverse' f@
--
-- A definition of 'sequenceA' must satisfy the following laws:
--
-- [Naturality]
--   @t . 'sequenceA' = 'sequenceA' . 'fmap' t@
--   for every applicative transformation @t@
--
-- [Identity]
--   @'sequenceA' . 'fmap' 'Identity' = 'Identity'@
--
-- [Composition]
--   @'sequenceA' . 'fmap' 'Data.Functor.Compose.Compose'
--     = 'Data.Functor.Compose.Compose' . 'fmap' 'sequenceA' . 'sequenceA'@
--
-- where an /applicative transformation/ is a function
--
-- @t :: (Applicative f, Applicative g) => f a -> g a@
--
-- preserving the 'Applicative' operations, i.e.
--
-- @
-- 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".
--
-- (The naturality law is implied by parametricity.)
--
-- Instances are similar to 'Functor', e.g. given a data type
--
-- > data Tree a = Empty | Leaf a | Node (Tree a) a (Tree a)
--
-- a suitable instance would be
--
-- > instance Traversable Tree where
-- >    traverse f Empty = pure Empty
-- >    traverse f (Leaf x) = Leaf <$> f x
-- >    traverse f (Node l k r) = Node <$> traverse f l <*> f k <*> traverse f r
--
-- This is suitable even for abstract types, as the laws for '<*>'
-- imply a form of associativity.
--
-- The superclass instances should satisfy the following:
--
--  * In the 'Functor' instance, 'fmap' should be equivalent to traversal
--    with the identity applicative functor ('fmapDefault').
--
--  * In the 'Foldable' instance, 'Data.Foldable.foldMap' should be
--    equivalent to traversal with a constant applicative functor
--    ('foldMapDefault').
--
class (Functor t, Foldable t) => Traversable t where
    {-# MINIMAL traverse | sequenceA #-}

    -- | Map each element of a structure to an action, evaluate these actions
    -- from left to right, and collect the results. For a version that ignores
    -- the results see 'Data.Foldable.traverse_'.
    traverse :: Applicative f => (a -> f b) -> t a -> f (t b)
    {-# INLINE traverse #-}  -- See Note [Inline default methods]
    traverse f = sequenceA . fmap f

    -- | Evaluate each action in the structure from left to right, and
    -- collect the results. For a version that ignores the results
    -- see 'Data.Foldable.sequenceA_'.
    sequenceA :: Applicative f => t (f a) -> f (t a)
    {-# INLINE sequenceA #-}  -- See Note [Inline default methods]
    sequenceA = traverse id

    -- | Map each element of a structure to a monadic action, evaluate
    -- these actions from left to right, and collect the results. For
    -- a version that ignores the results see 'Data.Foldable.mapM_'.
    mapM :: Monad m => (a -> m b) -> t a -> m (t b)
    {-# INLINE mapM #-}  -- See Note [Inline default methods]
    mapM = traverse

    -- | Evaluate each monadic action in the structure from left to
    -- right, and collect the results. For a version that ignores the
    -- results see 'Data.Foldable.sequence_'.
    sequence :: Monad m => t (m a) -> m (t a)
    {-# INLINE sequence #-}  -- See Note [Inline default methods]
    sequence = sequenceA

{- Note [Inline default methods]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Consider

   class ... => Traversable t where
       ...
       mapM :: Monad m => (a -> m b) -> t a -> m (t b)
       mapM = traverse   -- Default method

   instance Traversable [] where
       {-# INLINE traverse #-}
       traverse = ...code for traverse on lists ...

This gives rise to a list-instance of mapM looking like this

  $fTraversable[]_$ctraverse = ...code for traverse on lists...
       {-# INLINE $fTraversable[]_$ctraverse #-}
  $fTraversable[]_$cmapM    = $fTraversable[]_$ctraverse

Now the $ctraverse obediently inlines into the RHS of $cmapM, /but/
that's all!  We get

  $fTraversable[]_$cmapM = ...code for traverse on lists...

with NO INLINE pragma!  This happens even though 'traverse' had an
INLINE pragma because the author knew it should be inlined pretty
vigorously.

Indeed, it turned out that the rhs of $cmapM was just too big to
inline, so all uses of mapM on lists used a terribly inefficient
dictionary-passing style, because of its 'Monad m =>' type.  Disaster!

Solution: add an INLINE pragma on the default method:

   class ... => Traversable t where
       ...
       mapM :: Monad m => (a -> m b) -> t a -> m (t b)
       {-# INLINE mapM #-}     -- VERY IMPORTANT!
       mapM = traverse
-}

-- instances for Prelude types

-- | @since 2.01
instance Traversable Maybe where
    traverse _ Nothing = pure Nothing
    traverse f (Just x) = Just <$> f x

-- | @since 2.01
instance Traversable [] where
    {-# INLINE traverse #-} -- so that traverse can fuse
    traverse f = List.foldr cons_f (pure [])
      where cons_f x ys = liftA2 (:) (f x) ys

-- | @since 4.9.0.0
instance Traversable NonEmpty where
  traverse f ~(a :| as) = liftA2 (:|) (f a) (traverse f as)

-- | @since 4.7.0.0
instance Traversable (Either a) where
    traverse _ (Left x) = pure (Left x)
    traverse f (Right y) = Right <$> f y

-- | @since 4.7.0.0
instance Traversable ((,) a) where
    traverse f (x, y) = (,) x <$> f y

-- | @since 2.01
instance Ix i => Traversable (Array i) where
    traverse f arr = listArray (bounds arr) `fmap` traverse f (elems arr)

-- | @since 4.7.0.0
instance Traversable Proxy where
    traverse _ _ = pure Proxy
    {-# INLINE traverse #-}
    sequenceA _ = pure Proxy
    {-# INLINE sequenceA #-}
    mapM _ _ = pure Proxy
    {-# INLINE mapM #-}
    sequence _ = pure Proxy
    {-# INLINE sequence #-}

-- | @since 4.7.0.0
instance Traversable (Const m) where
    traverse _ (Const m) = pure $ Const m

-- | @since 4.8.0.0
instance Traversable Dual where
    traverse f (Dual x) = Dual <$> f x

-- | @since 4.8.0.0
instance Traversable Sum where
    traverse f (Sum x) = Sum <$> f x

-- | @since 4.8.0.0
instance Traversable Product where
    traverse f (Product x) = Product <$> f x

-- | @since 4.8.0.0
instance Traversable First where
    traverse f (First x) = First <$> traverse f x

-- | @since 4.8.0.0
instance Traversable Last where
    traverse f (Last x) = Last <$> traverse f x

-- | @since 4.12.0.0
instance (Traversable f) => Traversable (Alt f) where
    traverse f (Alt x) = Alt <$> traverse f x

-- | @since 4.12.0.0
instance (Traversable f) => Traversable (Ap f) where
    traverse f (Ap x) = Ap <$> traverse f x

-- | @since 4.9.0.0
instance Traversable ZipList where
    traverse f (ZipList x) = ZipList <$> traverse f x

-- | @since 4.9.0.0
deriving instance Traversable Identity

-- Instances for GHC.Generics
-- | @since 4.9.0.0
instance Traversable U1 where
    traverse _ _ = pure U1
    {-# INLINE traverse #-}
    sequenceA _ = pure U1
    {-# INLINE sequenceA #-}
    mapM _ _ = pure U1
    {-# INLINE mapM #-}
    sequence _ = pure U1
    {-# INLINE sequence #-}

-- | @since 4.9.0.0
deriving instance Traversable V1

-- | @since 4.9.0.0
deriving instance Traversable Par1

-- | @since 4.9.0.0
deriving instance Traversable f => Traversable (Rec1 f)

-- | @since 4.9.0.0
deriving instance Traversable (K1 i c)

-- | @since 4.9.0.0
deriving instance Traversable f => Traversable (M1 i c f)

-- | @since 4.9.0.0
deriving instance (Traversable f, Traversable g) => Traversable (f :+: g)

-- | @since 4.9.0.0
deriving instance (Traversable f, Traversable g) => Traversable (f :*: g)

-- | @since 4.9.0.0
deriving instance (Traversable f, Traversable g) => Traversable (f :.: g)

-- | @since 4.9.0.0
deriving instance Traversable UAddr

-- | @since 4.9.0.0
deriving instance Traversable UChar

-- | @since 4.9.0.0
deriving instance Traversable UDouble

-- | @since 4.9.0.0
deriving instance Traversable UFloat

-- | @since 4.9.0.0
deriving instance Traversable UInt

-- | @since 4.9.0.0
deriving instance Traversable UWord

-- Instance for Data.Ord
-- | @since 4.12.0.0
deriving instance Traversable Down

-- general functions

-- | 'for' is 'traverse' with its arguments flipped. For a version
-- that ignores the results see 'Data.Foldable.for_'.
for :: (Traversable t, Applicative f) => t a -> (a -> f b) -> f (t b)
{-# INLINE for #-}
for = flip traverse

-- | 'forM' is 'mapM' with its arguments flipped. For a version that
-- ignores the results see 'Data.Foldable.forM_'.
forM :: (Traversable t, Monad m) => t a -> (a -> m b) -> m (t b)
{-# INLINE forM #-}
forM = flip mapM

-- |The 'mapAccumL' function behaves like a combination of 'fmap'
-- and 'Data.Foldable.foldl'; it applies a function to each element of a structure,
-- passing an accumulating parameter from left to right, and returning
-- a final value of this accumulator together with the new structure.
mapAccumL :: Traversable t => (a -> b -> (a, c)) -> a -> t b -> (a, t c)
mapAccumL f s t = runStateL (traverse (StateL . flip f) t) s

-- |The 'mapAccumR' function behaves like a combination of 'fmap'
-- and 'Data.Foldable.foldr'; it applies a function to each element of a structure,
-- passing an accumulating parameter from right to left, and returning
-- a final value of this accumulator together with the new structure.
mapAccumR :: Traversable t => (a -> b -> (a, c)) -> a -> t b -> (a, t c)
mapAccumR f s t = runStateR (traverse (StateR . flip f) t) s

-- | This function may be used as a value for `fmap` in a `Functor`
--   instance, provided that 'traverse' is defined. (Using
--   `fmapDefault` with a `Traversable` instance defined only by
--   'sequenceA' will result in infinite recursion.)
--
-- @
-- 'fmapDefault' f â‰¡ 'runIdentity' . 'traverse' ('Identity' . f)
-- @
fmapDefault :: forall t a b . Traversable t
            => (a -> b) -> t a -> t b
{-# INLINE fmapDefault #-}
-- See Note [Function coercion] in Data.Functor.Utils.
fmapDefault = coerce (traverse :: (a -> Identity b) -> t a -> Identity (t b))

-- | This function may be used as a value for `Data.Foldable.foldMap`
-- in a `Foldable` instance.
--
-- @
-- 'foldMapDefault' f â‰¡ 'getConst' . 'traverse' ('Const' . f)
-- @
foldMapDefault :: forall t m a . (Traversable t, Monoid m)
               => (a -> m) -> t a -> m
{-# INLINE foldMapDefault #-}
-- See Note [Function coercion] in Data.Functor.Utils.
foldMapDefault = coerce (traverse :: (a -> Const m ()) -> t a -> Const m (t ()))


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

-----------------------------------------------------------------------------
-- |
-- Module      :  Data.Tuple
-- Copyright   :  (c) The University of Glasgow 2001
-- License     :  BSD-style (see the file libraries/base/LICENSE)
--
-- Maintainer  :  libraries@haskell.org
-- Stability   :  experimental
-- Portability :  portable
--
-- Functions associated with the tuple data types.
--
-----------------------------------------------------------------------------

module Data.Tuple
  ( fst
  , snd
  , curry
  , uncurry
  , swap
  ) where

import GHC.Base ()      -- Note [Depend on GHC.Tuple]

default ()              -- Double isn't available yet

-- ---------------------------------------------------------------------------
-- Standard functions over tuples

-- | Extract the first component of a pair.
fst                     :: (a,b) -> a
fst (x,_)               =  x

-- | Extract the second component of a pair.
snd                     :: (a,b) -> b
snd (_,y)               =  y

-- | 'curry' converts an uncurried function to a curried function.
--
-- ==== __Examples__
--
-- >>> curry fst 1 2
-- 1
curry                   :: ((a, b) -> c) -> a -> b -> c
curry f x y             =  f (x, y)

-- | 'uncurry' converts a curried function to a function on pairs.
--
-- ==== __Examples__
--
-- >>> uncurry (+) (1,2)
-- 3
--
-- >>> uncurry ($) (show, 1)
-- "1"
--
-- >>> map (uncurry max) [(1,2), (3,4), (6,8)]
-- [2,4,8]
uncurry                 :: (a -> b -> c) -> ((a, b) -> c)
uncurry f p             =  f (fst p) (snd p)

-- | Swap the components of a pair.
swap                    :: (a,b) -> (b,a)
swap (a,b)              = (b,a)

-- $setup
-- >>> import Prelude hiding (curry, uncurry, fst, snd)


{-# LANGUAGE Trustworthy #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE TypeOperators #-}

-----------------------------------------------------------------------------
-- |
-- Module      :  Data.Typeable
-- Copyright   :  (c) The University of Glasgow, CWI 2001--2004
-- License     :  BSD-style (see the file libraries/base/LICENSE)
--
-- Maintainer  :  libraries@haskell.org
-- Stability   :  experimental
-- Portability :  portable
--
-- The 'Typeable' class reifies types to some extent by associating type
-- representations to types. These type representations can be compared,
-- and one can in turn define a type-safe cast operation. To this end,
-- an unsafe cast is guarded by a test for type (representation)
-- equivalence. The module "Data.Dynamic" uses Typeable for an
-- implementation of dynamics. The module "Data.Data" uses Typeable
-- and type-safe cast (but not dynamics) to support the \"Scrap your
-- boilerplate\" style of generic programming.
--
-- == Compatibility Notes
--
-- Since GHC 8.2, GHC has supported type-indexed type representations.
-- "Data.Typeable" provides type representations which are qualified over this
-- index, providing an interface very similar to the "Typeable" notion seen in
-- previous releases. For the type-indexed interface, see "Type.Reflection".
--
-- Since GHC 7.8, 'Typeable' is poly-kinded. The changes required for this might
-- break some old programs involving 'Typeable'. More details on this, including
-- how to fix your code, can be found on the
-- <https://ghc.haskell.org/trac/ghc/wiki/GhcKinds/PolyTypeable PolyTypeable wiki page>
--
-----------------------------------------------------------------------------

module Data.Typeable
    ( -- * The Typeable class
      Typeable
    , typeOf
    , typeRep

      -- * Propositional equality
    , (:~:)(Refl)
    , (:~~:)(HRefl)

      -- * Type-safe cast
    , cast
    , eqT
    , gcast                -- a generalisation of cast

      -- * Generalized casts for higher-order kinds
    , gcast1               -- :: ... => c (t a) -> Maybe (c (t' a))
    , gcast2               -- :: ... => c (t a b) -> Maybe (c (t' a b))

      -- * A canonical proxy type
    , Proxy (..)

      -- * Type representations
    , TypeRep
    , rnfTypeRep
    , showsTypeRep
    , mkFunTy

      -- * Observing type representations
    , funResultTy
    , splitTyConApp
    , typeRepArgs
    , typeRepTyCon
    , typeRepFingerprint

      -- * Type constructors
    , I.TyCon          -- abstract, instance of: Eq, Show, Typeable
                       -- For now don't export Module to avoid name clashes
    , I.tyConPackage
    , I.tyConModule
    , I.tyConName
    , I.rnfTyCon
    , I.tyConFingerprint

      -- * For backwards compatibility
    , typeOf1, typeOf2, typeOf3, typeOf4, typeOf5, typeOf6, typeOf7
    ) where

import qualified Data.Typeable.Internal as I
import Data.Typeable.Internal (Typeable)
import Data.Type.Equality

import Data.Maybe
import Data.Proxy
import GHC.Fingerprint.Type
import GHC.Show
import GHC.Base

-- | A quantified type representation.
type TypeRep = I.SomeTypeRep

-- | Observe a type representation for the type of a value.
typeOf :: forall a. Typeable a => a -> TypeRep
typeOf _ = I.someTypeRep (Proxy :: Proxy a)

-- | Takes a value of type @a@ and returns a concrete representation
-- of that type.
--
-- @since 4.7.0.0
typeRep :: forall proxy a. Typeable a => proxy a -> TypeRep
typeRep = I.someTypeRep

-- | Show a type representation
showsTypeRep :: TypeRep -> ShowS
showsTypeRep = shows

-- | The type-safe cast operation
cast :: forall a b. (Typeable a, Typeable b) => a -> Maybe b
cast x
  | Just HRefl <- ta `I.eqTypeRep` tb = Just x
  | otherwise                         = Nothing
  where
    ta = I.typeRep :: I.TypeRep a
    tb = I.typeRep :: I.TypeRep b

-- | Extract a witness of equality of two types
--
-- @since 4.7.0.0
eqT :: forall a b. (Typeable a, Typeable b) => Maybe (a :~: b)
eqT
  | Just HRefl <- ta `I.eqTypeRep` tb = Just Refl
  | otherwise                         = Nothing
  where
    ta = I.typeRep :: I.TypeRep a
    tb = I.typeRep :: I.TypeRep b

-- | A flexible variation parameterised in a type constructor
gcast :: forall a b c. (Typeable a, Typeable b) => c a -> Maybe (c b)
gcast x = fmap (\Refl -> x) (eqT :: Maybe (a :~: b))

-- | Cast over @k1 -> k2@
gcast1 :: forall c t t' a. (Typeable t, Typeable t')
       => c (t a) -> Maybe (c (t' a))
gcast1 x = fmap (\Refl -> x) (eqT :: Maybe (t :~: t'))

-- | Cast over @k1 -> k2 -> k3@
gcast2 :: forall c t t' a b. (Typeable t, Typeable t')
       => c (t a b) -> Maybe (c (t' a b))
gcast2 x = fmap (\Refl -> x) (eqT :: Maybe (t :~: t'))

-- | Applies a type to a function type. Returns: @Just u@ if the first argument
-- represents a function of type @t -> u@ and the second argument represents a
-- function of type @t@. Otherwise, returns @Nothing@.
funResultTy :: TypeRep -> TypeRep -> Maybe TypeRep
funResultTy (I.SomeTypeRep f) (I.SomeTypeRep x)
  | Just HRefl <- (I.typeRep :: I.TypeRep Type) `I.eqTypeRep` I.typeRepKind f
  , I.Fun arg res <- f
  , Just HRefl <- arg `I.eqTypeRep` x
  = Just (I.SomeTypeRep res)
  | otherwise = Nothing

-- | Build a function type.
mkFunTy :: TypeRep -> TypeRep -> TypeRep
mkFunTy (I.SomeTypeRep arg) (I.SomeTypeRep res)
  | Just HRefl <- I.typeRepKind arg `I.eqTypeRep` liftedTy
  , Just HRefl <- I.typeRepKind res `I.eqTypeRep` liftedTy
  = I.SomeTypeRep (I.Fun arg res)
  | otherwise
  = error $ "mkFunTy: Attempted to construct function type from non-lifted "++
            "type: arg="++show arg++", res="++show res
  where liftedTy = I.typeRep :: I.TypeRep Type

-- | Splits a type constructor application. Note that if the type constructor is
-- polymorphic, this will not return the kinds that were used.
splitTyConApp :: TypeRep -> (TyCon, [TypeRep])
splitTyConApp (I.SomeTypeRep x) = I.splitApps x

-- | Observe the argument types of a type representation
typeRepArgs :: TypeRep -> [TypeRep]
typeRepArgs ty = case splitTyConApp ty of (_, args) -> args

-- | Observe the type constructor of a quantified type representation.
typeRepTyCon :: TypeRep -> TyCon
typeRepTyCon = I.someTypeRepTyCon

-- | Takes a value of type @a@ and returns a concrete representation
-- of that type.
--
-- @since 4.7.0.0
typeRepFingerprint :: TypeRep -> Fingerprint
typeRepFingerprint = I.someTypeRepFingerprint

-- | Force a 'TypeRep' to normal form.
rnfTypeRep :: TypeRep -> ()
rnfTypeRep = I.rnfSomeTypeRep

-- Keeping backwards-compatibility
typeOf1 :: forall t (a :: Type). Typeable t => t a -> TypeRep
typeOf1 _ = I.someTypeRep (Proxy :: Proxy t)

typeOf2 :: forall t (a :: Type) (b :: Type). Typeable t => t a b -> TypeRep
typeOf2 _ = I.someTypeRep (Proxy :: Proxy t)

typeOf3 :: forall t (a :: Type) (b :: Type) (c :: Type).
           Typeable t => t a b c -> TypeRep
typeOf3 _ = I.someTypeRep (Proxy :: Proxy t)

typeOf4 :: forall t (a :: Type) (b :: Type) (c :: Type) (d :: Type).
           Typeable t => t a b c d -> TypeRep
typeOf4 _ = I.someTypeRep (Proxy :: Proxy t)

typeOf5 :: forall t (a :: Type) (b :: Type) (c :: Type) (d :: Type) (e :: Type).
           Typeable t => t a b c d e -> TypeRep
typeOf5 _ = I.someTypeRep (Proxy :: Proxy t)

typeOf6 :: forall t (a :: Type) (b :: Type) (c :: Type)
                    (d :: Type) (e :: Type) (f :: Type).
           Typeable t => t a b c d e f -> TypeRep
typeOf6 _ = I.someTypeRep (Proxy :: Proxy t)

typeOf7 :: forall t (a :: Type) (b :: Type) (c :: Type)
                    (d :: Type) (e :: Type) (f :: Type) (g :: Type).
           Typeable t => t a b c d e f g -> TypeRep
typeOf7 _ = I.someTypeRep (Proxy :: Proxy t)


{-# LANGUAGE Trustworthy #-}
{-# LANGUAGE MagicHash #-}

-----------------------------------------------------------------------------
-- |
-- Module      :  Data.Unique
-- 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
--
-- An abstract interface to a unique symbol generator.
--
-----------------------------------------------------------------------------

module Data.Unique (
   -- * Unique objects
   Unique,
   newUnique,
   hashUnique
 ) where

import System.IO.Unsafe (unsafePerformIO)

import GHC.Base
import GHC.Num
import Data.IORef

-- | An abstract unique object.  Objects of type 'Unique' may be
-- compared for equality and ordering and hashed into 'Int'.
--
-- >>> :{
-- do x <- newUnique
--    print (x == x)
--    y <- newUnique
--    print (x == y)
-- :}
-- True
-- False
newtype Unique = Unique Integer deriving (Eq,Ord)

uniqSource :: IORef Integer
uniqSource = unsafePerformIO (newIORef 0)
{-# NOINLINE uniqSource #-}

-- | Creates a new object of type 'Unique'.  The value returned will
-- not compare equal to any other value of type 'Unique' returned by
-- previous calls to 'newUnique'.  There is no limit on the number of
-- times 'newUnique' may be called.
newUnique :: IO Unique
newUnique = do
  r <- atomicModifyIORef' uniqSource $ \x -> let z = x+1 in (z,z)
  return (Unique r)

-- SDM (18/3/2010): changed from MVar to STM.  This fixes
--  1. there was no async exception protection
--  2. there was a space leak (now new value is strict)
--  3. using atomicModifyIORef would be slightly quicker, but can
--     suffer from adverse scheduling issues (see #3838)
--  4. also, the STM version is faster.

-- SDM (30/4/2012): changed to IORef using atomicModifyIORef.  Reasons:
--  1. STM version could not be used inside unsafePerformIO, if it
--     happened to be poked inside an STM transaction.
--  2. IORef version can be used with unsafeIOToSTM inside STM,
--     because if the transaction retries then we just get a new
--     Unique.
--  3. IORef version is very slightly faster.

-- IGL (08/06/2013): changed to using atomicModifyIORef' instead.
--  This feels a little safer, from the point of view of not leaking
--  memory, but the resulting core is identical.

-- | Hashes a 'Unique' into an 'Int'.  Two 'Unique's may hash to the
-- same value, although in practice this is unlikely.  The 'Int'
-- returned makes a good hash key.
hashUnique :: Unique -> Int
hashUnique (Unique i) = I# (hashInteger i)


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

-----------------------------------------------------------------------------
-- |
-- Module      :  Data.Version
-- Copyright   :  (c) The University of Glasgow 2004
-- License     :  BSD-style (see the file libraries/base/LICENSE)
--
-- Maintainer  :  libraries@haskell.org
-- Stability   :  experimental
-- Portability :  non-portable (local universal quantification in ReadP)
--
-- A general library for representation and manipulation of versions.
--
-- Versioning schemes are many and varied, so the version
-- representation provided by this library is intended to be a
-- compromise between complete generality, where almost no common
-- functionality could reasonably be provided, and fixing a particular
-- versioning scheme, which would probably be too restrictive.
--
-- So the approach taken here is to provide a representation which
-- subsumes many of the versioning schemes commonly in use, and we
-- provide implementations of 'Eq', 'Ord' and conversion to\/from 'String'
-- which will be appropriate for some applications, but not all.
--
-----------------------------------------------------------------------------

module Data.Version (
        -- * The @Version@ type
        Version(..),
        -- * A concrete representation of @Version@
        showVersion, parseVersion,
        -- * Constructor function
        makeVersion
  ) where

import Data.Functor     ( Functor(..) )
import Control.Applicative ( Applicative(..) )
import Data.Bool        ( (&&) )
import Data.Char        ( isDigit, isAlphaNum )
import Data.Eq
import Data.Int         ( Int )
import Data.List
import Data.Ord
import Data.String      ( String )
import GHC.Generics
import GHC.Read
import GHC.Show
import Text.ParserCombinators.ReadP
import Text.Read        ( read )

{- |
A 'Version' represents the version of a software entity.

An instance of 'Eq' is provided, which implements exact equality
modulo reordering of the tags in the 'versionTags' field.

An instance of 'Ord' is also provided, which gives lexicographic
ordering on the 'versionBranch' fields (i.e. 2.1 > 2.0, 1.2.3 > 1.2.2,
etc.).  This is expected to be sufficient for many uses, but note that
you may need to use a more specific ordering for your versioning
scheme.  For example, some versioning schemes may include pre-releases
which have tags @\"pre1\"@, @\"pre2\"@, and so on, and these would need to
be taken into account when determining ordering.  In some cases, date
ordering may be more appropriate, so the application would have to
look for @date@ tags in the 'versionTags' field and compare those.
The bottom line is, don't always assume that 'compare' and other 'Ord'
operations are the right thing for every 'Version'.

Similarly, concrete representations of versions may differ.  One
possible concrete representation is provided (see 'showVersion' and
'parseVersion'), but depending on the application a different concrete
representation may be more appropriate.
-}
data Version =
  Version { versionBranch :: [Int],
                -- ^ The numeric branch for this version.  This reflects the
                -- fact that most software versions are tree-structured; there
                -- is a main trunk which is tagged with versions at various
                -- points (1,2,3...), and the first branch off the trunk after
                -- version 3 is 3.1, the second branch off the trunk after
                -- version 3 is 3.2, and so on.  The tree can be branched
                -- arbitrarily, just by adding more digits.
                --
                -- We represent the branch as a list of 'Int', so
                -- version 3.2.1 becomes [3,2,1].  Lexicographic ordering
                -- (i.e. the default instance of 'Ord' for @[Int]@) gives
                -- the natural ordering of branches.

           versionTags :: [String]  -- really a bag
                -- ^ A version can be tagged with an arbitrary list of strings.
                -- The interpretation of the list of tags is entirely dependent
                -- on the entity that this version applies to.
        }
  deriving ( Read    -- ^ @since 2.01
           , Show    -- ^ @since 2.01
           , Generic -- ^ @since 4.9.0.0
           )
{-# DEPRECATED versionTags "See GHC ticket #2496" #-}
-- TODO. Remove all references to versionTags in GHC 8.0 release.

-- | @since 2.01
instance Eq Version where
  v1 == v2  =  versionBranch v1 == versionBranch v2
                && sort (versionTags v1) == sort (versionTags v2)
                -- tags may be in any order

-- | @since 2.01
instance Ord Version where
  v1 `compare` v2 = versionBranch v1 `compare` versionBranch v2

-- -----------------------------------------------------------------------------
-- A concrete representation of 'Version'

-- | Provides one possible concrete representation for 'Version'.  For
-- a version with 'versionBranch' @= [1,2,3]@ and 'versionTags'
-- @= [\"tag1\",\"tag2\"]@, the output will be @1.2.3-tag1-tag2@.
--
showVersion :: Version -> String
showVersion (Version branch tags)
  = concat (intersperse "." (map show branch)) ++
     concatMap ('-':) tags

-- | A parser for versions in the format produced by 'showVersion'.
--
parseVersion :: ReadP Version
parseVersion = do branch <- sepBy1 (fmap read (munch1 isDigit)) (char '.')
                  tags   <- many (char '-' *> munch1 isAlphaNum)
                  pure Version{versionBranch=branch, versionTags=tags}

-- | Construct tag-less 'Version'
--
-- @since 4.8.0.0
makeVersion :: [Int] -> Version
makeVersion b = Version b []


{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE EmptyCase #-}
{-# LANGUAGE EmptyDataDeriving #-}
{-# LANGUAGE Safe #-}
{-# LANGUAGE StandaloneDeriving #-}

-----------------------------------------------------------------------------
-- |
-- Copyright   :  (C) 2008-2014 Edward Kmett
-- License     :  BSD-style (see the file libraries/base/LICENSE)
--
-- Maintainer  :  Edward Kmett <ekmett@gmail.com>
-- Stability   :  provisional
-- Portability :  portable
--
-- A logically uninhabited data type, used to indicate that a given
-- term should not exist.
--
-- @since 4.8.0.0
----------------------------------------------------------------------------
module Data.Void
    ( Void
    , absurd
    , vacuous
    ) where

import Control.Exception
import Data.Data
import Data.Ix
import GHC.Generics
import Data.Semigroup (Semigroup(..), stimesIdempotent)

-- | Uninhabited data type
--
-- @since 4.8.0.0
data Void deriving
  ( Eq      -- ^ @since 4.8.0.0
  , Data    -- ^ @since 4.8.0.0
  , Generic -- ^ @since 4.8.0.0
  , Ord     -- ^ @since 4.8.0.0
  , Read    -- ^ Reading a 'Void' value is always a parse error, considering
            -- 'Void' as a data type with no constructors.
            --
            -- @since 4.8.0.0
  , Show    -- ^ @since 4.8.0.0
  )

-- | @since 4.8.0.0
instance Ix Void where
    range _     = []
    index _     = absurd
    inRange _   = absurd
    rangeSize _ = 0

-- | @since 4.8.0.0
instance Exception Void

-- | @since 4.9.0.0
instance Semigroup Void where
    a <> _ = a
    stimes = stimesIdempotent

-- | Since 'Void' values logically don't exist, this witnesses the
-- logical reasoning tool of \"ex falso quodlibet\".
--
-- >>> let x :: Either Void Int; x = Right 5
-- >>> :{
-- case x of
--     Right r -> r
--     Left l  -> absurd l
-- :}
-- 5
--
-- @since 4.8.0.0
absurd :: Void -> a
absurd a = case a of {}

-- | If 'Void' is uninhabited then any 'Functor' that holds only
-- values of type 'Void' is holding no values.
--
-- @since 4.8.0.0
vacuous :: Functor f => f Void -> f a
vacuous = fmap absurd


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

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

module Data.Word
  (
        -- * Unsigned integral types

        Word,
        Word8, Word16, Word32, Word64,

        -- * byte swapping
        byteSwap16, byteSwap32, byteSwap64,

        -- * Notes

        -- $notes
        ) where

import GHC.Word
import GHC.Read () -- Need the `Read` instance for types defined in `GHC.Word`.

{- $notes

* All arithmetic is performed modulo 2^n, where n is the number of
  bits in the type.  One non-obvious consequence of this is that 'Prelude.negate'
  should /not/ raise an error on negative arguments.

* For coercing between any two integer types, use
  'Prelude.fromIntegral', which is specialized for all the
  common cases so should be fast enough.  Coercing word types to and
  from integer types preserves representation, not sign.

* An unbounded size unsigned integer type is available with
  'Numeric.Natural.Natural'.

* The rules that hold for 'Prelude.Enum' instances over a bounded type
  such as 'Prelude.Int' (see the section of the Haskell report dealing
  with arithmetic sequences) also hold for the 'Prelude.Enum' instances
  over the various 'Word' types defined here.

* Right and left shifts by amounts greater than or equal to the width
  of the type result in a zero result.  This is contrary to the
  behaviour in C, which is undefined; a common interpretation is to
  truncate the shift count to the width of the type, for example @1 \<\<
  32 == 1@ in some C implementations.
-}


{-# LANGUAGE Safe #-}
-----------------------------------------------------------------------------
-- |
-- Module      :  Data.Functor.Classes
-- Copyright   :  (c) Ross Paterson 2013
-- License     :  BSD-style (see the file LICENSE)
--
-- Maintainer  :  libraries@haskell.org
-- Stability   :  experimental
-- Portability :  portable
--
-- Liftings of the Prelude classes 'Eq', 'Ord', 'Read' and 'Show' to
-- unary and binary type constructors.
--
-- These classes are needed to express the constraints on arguments of
-- transformers in portable Haskell.  Thus for a new transformer @T@,
-- one might write instances like
--
-- > instance (Eq1 f) => Eq1 (T f) where ...
-- > instance (Ord1 f) => Ord1 (T f) where ...
-- > instance (Read1 f) => Read1 (T f) where ...
-- > instance (Show1 f) => Show1 (T f) where ...
--
-- If these instances can be defined, defining instances of the base
-- classes is mechanical:
--
-- > instance (Eq1 f, Eq a) => Eq (T f a) where (==) = eq1
-- > instance (Ord1 f, Ord a) => Ord (T f a) where compare = compare1
-- > instance (Read1 f, Read a) => Read (T f a) where
-- >   readPrec     = readPrec1
-- >   readListPrec = readListPrecDefault
-- > instance (Show1 f, Show a) => Show (T f a) where showsPrec = showsPrec1
--
-- @since 4.9.0.0
-----------------------------------------------------------------------------

module Data.Functor.Classes (
    -- * Liftings of Prelude classes
    -- ** For unary constructors
    Eq1(..), eq1,
    Ord1(..), compare1,
    Read1(..), readsPrec1, readPrec1,
    liftReadListDefault, liftReadListPrecDefault,
    Show1(..), showsPrec1,
    -- ** For binary constructors
    Eq2(..), eq2,
    Ord2(..), compare2,
    Read2(..), readsPrec2, readPrec2,
    liftReadList2Default, liftReadListPrec2Default,
    Show2(..), showsPrec2,
    -- * Helper functions
    -- $example
    readsData, readData,
    readsUnaryWith, readUnaryWith,
    readsBinaryWith, readBinaryWith,
    showsUnaryWith,
    showsBinaryWith,
    -- ** Obsolete helpers
    readsUnary,
    readsUnary1,
    readsBinary1,
    showsUnary,
    showsUnary1,
    showsBinary1,
  ) where

import Control.Applicative (Alternative((<|>)), Const(Const))

import Data.Functor.Identity (Identity(Identity))
import Data.Proxy (Proxy(Proxy))
import Data.List.NonEmpty (NonEmpty(..))
import Data.Ord (Down(Down))

import GHC.Read (expectP, list, paren)

import Text.ParserCombinators.ReadPrec (ReadPrec, readPrec_to_S, readS_to_Prec)
import Text.Read (Read(..), parens, prec, step)
import Text.Read.Lex (Lexeme(..))
import Text.Show (showListWith)

-- | Lifting of the 'Eq' class to unary type constructors.
--
-- @since 4.9.0.0
class Eq1 f where
    -- | Lift an equality test through the type constructor.
    --
    -- The function will usually be applied to an equality function,
    -- but the more general type ensures that the implementation uses
    -- it to compare elements of the first container with elements of
    -- the second.
    --
    -- @since 4.9.0.0
    liftEq :: (a -> b -> Bool) -> f a -> f b -> Bool

-- | Lift the standard @('==')@ function through the type constructor.
--
-- @since 4.9.0.0
eq1 :: (Eq1 f, Eq a) => f a -> f a -> Bool
eq1 = liftEq (==)

-- | Lifting of the 'Ord' class to unary type constructors.
--
-- @since 4.9.0.0
class (Eq1 f) => Ord1 f where
    -- | Lift a 'compare' function through the type constructor.
    --
    -- The function will usually be applied to a comparison function,
    -- but the more general type ensures that the implementation uses
    -- it to compare elements of the first container with elements of
    -- the second.
    --
    -- @since 4.9.0.0
    liftCompare :: (a -> b -> Ordering) -> f a -> f b -> Ordering

-- | Lift the standard 'compare' function through the type constructor.
--
-- @since 4.9.0.0
compare1 :: (Ord1 f, Ord a) => f a -> f a -> Ordering
compare1 = liftCompare compare

-- | Lifting of the 'Read' class to unary type constructors.
--
-- Both 'liftReadsPrec' and 'liftReadPrec' exist to match the interface
-- provided in the 'Read' type class, but it is recommended to implement
-- 'Read1' instances using 'liftReadPrec' as opposed to 'liftReadsPrec', since
-- the former is more efficient than the latter. For example:
--
-- @
-- instance 'Read1' T where
--   'liftReadPrec'     = ...
--   'liftReadListPrec' = 'liftReadListPrecDefault'
-- @
--
-- For more information, refer to the documentation for the 'Read' class.
--
-- @since 4.9.0.0
class Read1 f where
    {-# MINIMAL liftReadsPrec | liftReadPrec #-}

    -- | 'readsPrec' function for an application of the type constructor
    -- based on 'readsPrec' and 'readList' functions for the argument type.
    --
    -- @since 4.9.0.0
    liftReadsPrec :: (Int -> ReadS a) -> ReadS [a] -> Int -> ReadS (f a)
    liftReadsPrec rp rl = readPrec_to_S $
        liftReadPrec (readS_to_Prec rp) (readS_to_Prec (const rl))

    -- | 'readList' function for an application of the type constructor
    -- based on 'readsPrec' and 'readList' functions for the argument type.
    -- The default implementation using standard list syntax is correct
    -- for most types.
    --
    -- @since 4.9.0.0
    liftReadList :: (Int -> ReadS a) -> ReadS [a] -> ReadS [f a]
    liftReadList rp rl = readPrec_to_S
        (list $ liftReadPrec (readS_to_Prec rp) (readS_to_Prec (const rl))) 0

    -- | 'readPrec' function for an application of the type constructor
    -- based on 'readPrec' and 'readListPrec' functions for the argument type.
    --
    -- @since 4.10.0.0
    liftReadPrec :: ReadPrec a -> ReadPrec [a] -> ReadPrec (f a)
    liftReadPrec rp rl = readS_to_Prec $
        liftReadsPrec (readPrec_to_S rp) (readPrec_to_S rl 0)

    -- | 'readListPrec' function for an application of the type constructor
    -- based on 'readPrec' and 'readListPrec' functions for the argument type.
    --
    -- The default definition uses 'liftReadList'. Instances that define
    -- 'liftReadPrec' should also define 'liftReadListPrec' as
    -- 'liftReadListPrecDefault'.
    --
    -- @since 4.10.0.0
    liftReadListPrec :: ReadPrec a -> ReadPrec [a] -> ReadPrec [f a]
    liftReadListPrec rp rl = readS_to_Prec $ \_ ->
        liftReadList (readPrec_to_S rp) (readPrec_to_S rl 0)

-- | Lift the standard 'readsPrec' and 'readList' functions through the
-- type constructor.
--
-- @since 4.9.0.0
readsPrec1 :: (Read1 f, Read a) => Int -> ReadS (f a)
readsPrec1 = liftReadsPrec readsPrec readList

-- | Lift the standard 'readPrec' and 'readListPrec' functions through the
-- type constructor.
--
-- @since 4.10.0.0
readPrec1 :: (Read1 f, Read a) => ReadPrec (f a)
readPrec1 = liftReadPrec readPrec readListPrec

-- | A possible replacement definition for the 'liftReadList' method.
-- This is only needed for 'Read1' instances where 'liftReadListPrec' isn't
-- defined as 'liftReadListPrecDefault'.
--
-- @since 4.10.0.0
liftReadListDefault :: Read1 f => (Int -> ReadS a) -> ReadS [a] -> ReadS [f a]
liftReadListDefault rp rl = readPrec_to_S
    (liftReadListPrec (readS_to_Prec rp) (readS_to_Prec (const rl))) 0

-- | A possible replacement definition for the 'liftReadListPrec' method,
-- defined using 'liftReadPrec'.
--
-- @since 4.10.0.0
liftReadListPrecDefault :: Read1 f => ReadPrec a -> ReadPrec [a]
                        -> ReadPrec [f a]
liftReadListPrecDefault rp rl = list (liftReadPrec rp rl)

-- | Lifting of the 'Show' class to unary type constructors.
--
-- @since 4.9.0.0
class Show1 f where
    -- | 'showsPrec' function for an application of the type constructor
    -- based on 'showsPrec' and 'showList' functions for the argument type.
    --
    -- @since 4.9.0.0
    liftShowsPrec :: (Int -> a -> ShowS) -> ([a] -> ShowS) ->
        Int -> f a -> ShowS

    -- | 'showList' function for an application of the type constructor
    -- based on 'showsPrec' and 'showList' functions for the argument type.
    -- The default implementation using standard list syntax is correct
    -- for most types.
    --
    -- @since 4.9.0.0
    liftShowList :: (Int -> a -> ShowS) -> ([a] -> ShowS) ->
        [f a] -> ShowS
    liftShowList sp sl = showListWith (liftShowsPrec sp sl 0)

-- | Lift the standard 'showsPrec' and 'showList' functions through the
-- type constructor.
--
-- @since 4.9.0.0
showsPrec1 :: (Show1 f, Show a) => Int -> f a -> ShowS
showsPrec1 = liftShowsPrec showsPrec showList

-- | Lifting of the 'Eq' class to binary type constructors.
--
-- @since 4.9.0.0
class Eq2 f where
    -- | Lift equality tests through the type constructor.
    --
    -- The function will usually be applied to equality functions,
    -- but the more general type ensures that the implementation uses
    -- them to compare elements of the first container with elements of
    -- the second.
    --
    -- @since 4.9.0.0
    liftEq2 :: (a -> b -> Bool) -> (c -> d -> Bool) -> f a c -> f b d -> Bool

-- | Lift the standard @('==')@ function through the type constructor.
--
-- @since 4.9.0.0
eq2 :: (Eq2 f, Eq a, Eq b) => f a b -> f a b -> Bool
eq2 = liftEq2 (==) (==)

-- | Lifting of the 'Ord' class to binary type constructors.
--
-- @since 4.9.0.0
class (Eq2 f) => Ord2 f where
    -- | Lift 'compare' functions through the type constructor.
    --
    -- The function will usually be applied to comparison functions,
    -- but the more general type ensures that the implementation uses
    -- them to compare elements of the first container with elements of
    -- the second.
    --
    -- @since 4.9.0.0
    liftCompare2 :: (a -> b -> Ordering) -> (c -> d -> Ordering) ->
        f a c -> f b d -> Ordering

-- | Lift the standard 'compare' function through the type constructor.
--
-- @since 4.9.0.0
compare2 :: (Ord2 f, Ord a, Ord b) => f a b -> f a b -> Ordering
compare2 = liftCompare2 compare compare

-- | Lifting of the 'Read' class to binary type constructors.
--
-- Both 'liftReadsPrec2' and 'liftReadPrec2' exist to match the interface
-- provided in the 'Read' type class, but it is recommended to implement
-- 'Read2' instances using 'liftReadPrec2' as opposed to 'liftReadsPrec2',
-- since the former is more efficient than the latter. For example:
--
-- @
-- instance 'Read2' T where
--   'liftReadPrec2'     = ...
--   'liftReadListPrec2' = 'liftReadListPrec2Default'
-- @
--
-- For more information, refer to the documentation for the 'Read' class.
-- @since 4.9.0.0
class Read2 f where
    {-# MINIMAL liftReadsPrec2 | liftReadPrec2 #-}

    -- | 'readsPrec' function for an application of the type constructor
    -- based on 'readsPrec' and 'readList' functions for the argument types.
    --
    -- @since 4.9.0.0
    liftReadsPrec2 :: (Int -> ReadS a) -> ReadS [a] ->
        (Int -> ReadS b) -> ReadS [b] -> Int -> ReadS (f a b)
    liftReadsPrec2 rp1 rl1 rp2 rl2 = readPrec_to_S $
        liftReadPrec2 (readS_to_Prec rp1) (readS_to_Prec (const rl1))
                      (readS_to_Prec rp2) (readS_to_Prec (const rl2))

    -- | 'readList' function for an application of the type constructor
    -- based on 'readsPrec' and 'readList' functions for the argument types.
    -- The default implementation using standard list syntax is correct
    -- for most types.
    --
    -- @since 4.9.0.0
    liftReadList2 :: (Int -> ReadS a) -> ReadS [a] ->
        (Int -> ReadS b) -> ReadS [b] -> ReadS [f a b]
    liftReadList2 rp1 rl1 rp2 rl2 = readPrec_to_S
       (list $ liftReadPrec2 (readS_to_Prec rp1) (readS_to_Prec (const rl1))
                             (readS_to_Prec rp2) (readS_to_Prec (const rl2))) 0

    -- | 'readPrec' function for an application of the type constructor
    -- based on 'readPrec' and 'readListPrec' functions for the argument types.
    --
    -- @since 4.10.0.0
    liftReadPrec2 :: ReadPrec a -> ReadPrec [a] ->
        ReadPrec b -> ReadPrec [b] -> ReadPrec (f a b)
    liftReadPrec2 rp1 rl1 rp2 rl2 = readS_to_Prec $
        liftReadsPrec2 (readPrec_to_S rp1) (readPrec_to_S rl1 0)
                       (readPrec_to_S rp2) (readPrec_to_S rl2 0)

    -- | 'readListPrec' function for an application of the type constructor
    -- based on 'readPrec' and 'readListPrec' functions for the argument types.
    --
    -- The default definition uses 'liftReadList2'. Instances that define
    -- 'liftReadPrec2' should also define 'liftReadListPrec2' as
    -- 'liftReadListPrec2Default'.
    --
    -- @since 4.10.0.0
    liftReadListPrec2 :: ReadPrec a -> ReadPrec [a] ->
        ReadPrec b -> ReadPrec [b] -> ReadPrec [f a b]
    liftReadListPrec2 rp1 rl1 rp2 rl2 = readS_to_Prec $ \_ ->
        liftReadList2 (readPrec_to_S rp1) (readPrec_to_S rl1 0)
                      (readPrec_to_S rp2) (readPrec_to_S rl2 0)

-- | Lift the standard 'readsPrec' function through the type constructor.
--
-- @since 4.9.0.0
readsPrec2 :: (Read2 f, Read a, Read b) => Int -> ReadS (f a b)
readsPrec2 = liftReadsPrec2 readsPrec readList readsPrec readList

-- | Lift the standard 'readPrec' function through the type constructor.
--
-- @since 4.10.0.0
readPrec2 :: (Read2 f, Read a, Read b) => ReadPrec (f a b)
readPrec2 = liftReadPrec2 readPrec readListPrec readPrec readListPrec

-- | A possible replacement definition for the 'liftReadList2' method.
-- This is only needed for 'Read2' instances where 'liftReadListPrec2' isn't
-- defined as 'liftReadListPrec2Default'.
--
-- @since 4.10.0.0
liftReadList2Default :: Read2 f => (Int -> ReadS a) -> ReadS [a] ->
    (Int -> ReadS b) -> ReadS [b] ->ReadS [f a b]
liftReadList2Default rp1 rl1 rp2 rl2 = readPrec_to_S
    (liftReadListPrec2 (readS_to_Prec rp1) (readS_to_Prec (const rl1))
                       (readS_to_Prec rp2) (readS_to_Prec (const rl2))) 0

-- | A possible replacement definition for the 'liftReadListPrec2' method,
-- defined using 'liftReadPrec2'.
--
-- @since 4.10.0.0
liftReadListPrec2Default :: Read2 f => ReadPrec a -> ReadPrec [a] ->
    ReadPrec b -> ReadPrec [b] -> ReadPrec [f a b]
liftReadListPrec2Default rp1 rl1 rp2 rl2 = list (liftReadPrec2 rp1 rl1 rp2 rl2)

-- | Lifting of the 'Show' class to binary type constructors.
--
-- @since 4.9.0.0
class Show2 f where
    -- | 'showsPrec' function for an application of the type constructor
    -- based on 'showsPrec' and 'showList' functions for the argument types.
    --
    -- @since 4.9.0.0
    liftShowsPrec2 :: (Int -> a -> ShowS) -> ([a] -> ShowS) ->
        (Int -> b -> ShowS) -> ([b] -> ShowS) -> Int -> f a b -> ShowS

    -- | 'showList' function for an application of the type constructor
    -- based on 'showsPrec' and 'showList' functions for the argument types.
    -- The default implementation using standard list syntax is correct
    -- for most types.
    --
    -- @since 4.9.0.0
    liftShowList2 :: (Int -> a -> ShowS) -> ([a] -> ShowS) ->
        (Int -> b -> ShowS) -> ([b] -> ShowS) -> [f a b] -> ShowS
    liftShowList2 sp1 sl1 sp2 sl2 =
        showListWith (liftShowsPrec2 sp1 sl1 sp2 sl2 0)

-- | Lift the standard 'showsPrec' function through the type constructor.
--
-- @since 4.9.0.0
showsPrec2 :: (Show2 f, Show a, Show b) => Int -> f a b -> ShowS
showsPrec2 = liftShowsPrec2 showsPrec showList showsPrec showList

-- Instances for Prelude type constructors

-- | @since 4.9.0.0
instance Eq1 Maybe where
    liftEq _ Nothing Nothing = True
    liftEq _ Nothing (Just _) = False
    liftEq _ (Just _) Nothing = False
    liftEq eq (Just x) (Just y) = eq x y

-- | @since 4.9.0.0
instance Ord1 Maybe where
    liftCompare _ Nothing Nothing = EQ
    liftCompare _ Nothing (Just _) = LT
    liftCompare _ (Just _) Nothing = GT
    liftCompare comp (Just x) (Just y) = comp x y

-- | @since 4.9.0.0
instance Read1 Maybe where
    liftReadPrec rp _ =
        parens (expectP (Ident "Nothing") *> pure Nothing)
        <|>
        readData (readUnaryWith rp "Just" Just)

    liftReadListPrec = liftReadListPrecDefault
    liftReadList     = liftReadListDefault

-- | @since 4.9.0.0
instance Show1 Maybe where
    liftShowsPrec _ _ _ Nothing = showString "Nothing"
    liftShowsPrec sp _ d (Just x) = showsUnaryWith sp "Just" d x

-- | @since 4.9.0.0
instance Eq1 [] where
    liftEq _ [] [] = True
    liftEq _ [] (_:_) = False
    liftEq _ (_:_) [] = False
    liftEq eq (x:xs) (y:ys) = eq x y && liftEq eq xs ys

-- | @since 4.9.0.0
instance Ord1 [] where
    liftCompare _ [] [] = EQ
    liftCompare _ [] (_:_) = LT
    liftCompare _ (_:_) [] = GT
    liftCompare comp (x:xs) (y:ys) = comp x y `mappend` liftCompare comp xs ys

-- | @since 4.9.0.0
instance Read1 [] where
    liftReadPrec _ rl = rl
    liftReadListPrec  = liftReadListPrecDefault
    liftReadList      = liftReadListDefault

-- | @since 4.9.0.0
instance Show1 [] where
    liftShowsPrec _ sl _ = sl

-- | @since 4.10.0.0
instance Eq1 NonEmpty where
  liftEq eq (a :| as) (b :| bs) = eq a b && liftEq eq as bs

-- | @since 4.10.0.0
instance Ord1 NonEmpty where
  liftCompare cmp (a :| as) (b :| bs) = cmp a b `mappend` liftCompare cmp as bs

-- | @since 4.10.0.0
instance Read1 NonEmpty where
  liftReadsPrec rdP rdL p s = readParen (p > 5) (\s' -> do
    (a, s'') <- rdP 6 s'
    (":|", s''') <- lex s''
    (as, s'''') <- rdL s'''
    return (a :| as, s'''')) s

-- | @since 4.10.0.0
instance Show1 NonEmpty where
  liftShowsPrec shwP shwL p (a :| as) = showParen (p > 5) $
    shwP 6 a . showString " :| " . shwL as

-- | @since 4.9.0.0
instance Eq2 (,) where
    liftEq2 e1 e2 (x1, y1) (x2, y2) = e1 x1 x2 && e2 y1 y2

-- | @since 4.9.0.0
instance Ord2 (,) where
    liftCompare2 comp1 comp2 (x1, y1) (x2, y2) =
        comp1 x1 x2 `mappend` comp2 y1 y2

-- | @since 4.9.0.0
instance Read2 (,) where
    liftReadPrec2 rp1 _ rp2 _ = parens $ paren $ do
        x <- rp1
        expectP (Punc ",")
        y <- rp2
        return (x,y)

    liftReadListPrec2 = liftReadListPrec2Default
    liftReadList2     = liftReadList2Default

-- | @since 4.9.0.0
instance Show2 (,) where
    liftShowsPrec2 sp1 _ sp2 _ _ (x, y) =
        showChar '(' . sp1 0 x . showChar ',' . sp2 0 y . showChar ')'

-- | @since 4.9.0.0
instance (Eq a) => Eq1 ((,) a) where
    liftEq = liftEq2 (==)

-- | @since 4.9.0.0
instance (Ord a) => Ord1 ((,) a) where
    liftCompare = liftCompare2 compare

-- | @since 4.9.0.0
instance (Read a) => Read1 ((,) a) where
    liftReadPrec = liftReadPrec2 readPrec readListPrec

    liftReadListPrec = liftReadListPrecDefault
    liftReadList     = liftReadListDefault

-- | @since 4.9.0.0
instance (Show a) => Show1 ((,) a) where
    liftShowsPrec = liftShowsPrec2 showsPrec showList

-- | @since 4.9.0.0
instance Eq2 Either where
    liftEq2 e1 _ (Left x) (Left y) = e1 x y
    liftEq2 _ _ (Left _) (Right _) = False
    liftEq2 _ _ (Right _) (Left _) = False
    liftEq2 _ e2 (Right x) (Right y) = e2 x y

-- | @since 4.9.0.0
instance Ord2 Either where
    liftCompare2 comp1 _ (Left x) (Left y) = comp1 x y
    liftCompare2 _ _ (Left _) (Right _) = LT
    liftCompare2 _ _ (Right _) (Left _) = GT
    liftCompare2 _ comp2 (Right x) (Right y) = comp2 x y

-- | @since 4.9.0.0
instance Read2 Either where
    liftReadPrec2 rp1 _ rp2 _ = readData $
         readUnaryWith rp1 "Left" Left <|>
         readUnaryWith rp2 "Right" Right

    liftReadListPrec2 = liftReadListPrec2Default
    liftReadList2     = liftReadList2Default

-- | @since 4.9.0.0
instance Show2 Either where
    liftShowsPrec2 sp1 _ _ _ d (Left x) = showsUnaryWith sp1 "Left" d x
    liftShowsPrec2 _ _ sp2 _ d (Right x) = showsUnaryWith sp2 "Right" d x

-- | @since 4.9.0.0
instance (Eq a) => Eq1 (Either a) where
    liftEq = liftEq2 (==)

-- | @since 4.9.0.0
instance (Ord a) => Ord1 (Either a) where
    liftCompare = liftCompare2 compare

-- | @since 4.9.0.0
instance (Read a) => Read1 (Either a) where
    liftReadPrec = liftReadPrec2 readPrec readListPrec

    liftReadListPrec = liftReadListPrecDefault
    liftReadList     = liftReadListDefault

-- | @since 4.9.0.0
instance (Show a) => Show1 (Either a) where
    liftShowsPrec = liftShowsPrec2 showsPrec showList

-- Instances for other functors defined in the base package

-- | @since 4.9.0.0
instance Eq1 Identity where
    liftEq eq (Identity x) (Identity y) = eq x y

-- | @since 4.9.0.0
instance Ord1 Identity where
    liftCompare comp (Identity x) (Identity y) = comp x y

-- | @since 4.9.0.0
instance Read1 Identity where
    liftReadPrec rp _ = readData $
         readUnaryWith rp "Identity" Identity

    liftReadListPrec = liftReadListPrecDefault
    liftReadList     = liftReadListDefault

-- | @since 4.9.0.0
instance Show1 Identity where
    liftShowsPrec sp _ d (Identity x) = showsUnaryWith sp "Identity" d x

-- | @since 4.9.0.0
instance Eq2 Const where
    liftEq2 eq _ (Const x) (Const y) = eq x y

-- | @since 4.9.0.0
instance Ord2 Const where
    liftCompare2 comp _ (Const x) (Const y) = comp x y

-- | @since 4.9.0.0
instance Read2 Const where
    liftReadPrec2 rp _ _ _ = readData $
         readUnaryWith rp "Const" Const

    liftReadListPrec2 = liftReadListPrec2Default
    liftReadList2     = liftReadList2Default

-- | @since 4.9.0.0
instance Show2 Const where
    liftShowsPrec2 sp _ _ _ d (Const x) = showsUnaryWith sp "Const" d x

-- | @since 4.9.0.0
instance (Eq a) => Eq1 (Const a) where
    liftEq = liftEq2 (==)
-- | @since 4.9.0.0
instance (Ord a) => Ord1 (Const a) where
    liftCompare = liftCompare2 compare
-- | @since 4.9.0.0
instance (Read a) => Read1 (Const a) where
    liftReadPrec = liftReadPrec2 readPrec readListPrec

    liftReadListPrec = liftReadListPrecDefault
    liftReadList     = liftReadListDefault
-- | @since 4.9.0.0
instance (Show a) => Show1 (Const a) where
    liftShowsPrec = liftShowsPrec2 showsPrec showList

-- Proxy unfortunately imports this module, hence these instances are placed
-- here,
-- | @since 4.9.0.0
instance Eq1 Proxy where
  liftEq _ _ _ = True

-- | @since 4.9.0.0
instance Ord1 Proxy where
  liftCompare _ _ _ = EQ

-- | @since 4.9.0.0
instance Show1 Proxy where
  liftShowsPrec _ _ _ _ = showString "Proxy"

-- | @since 4.9.0.0
instance Read1 Proxy where
  liftReadPrec _ _ = parens (expectP (Ident "Proxy") *> pure Proxy)

  liftReadListPrec = liftReadListPrecDefault
  liftReadList     = liftReadListDefault

-- | @since 4.12.0.0
instance Eq1 Down where
    liftEq eq (Down x) (Down y) = eq x y

-- | @since 4.12.0.0
instance Ord1 Down where
    liftCompare comp (Down x) (Down y) = comp x y

-- | @since 4.12.0.0
instance Read1 Down where
    liftReadsPrec rp _ = readsData $
         readsUnaryWith rp "Down" Down

-- | @since 4.12.0.0
instance Show1 Down where
    liftShowsPrec sp _ d (Down x) = showsUnaryWith sp "Down" d x

-- Building blocks

-- | @'readsData' p d@ is a parser for datatypes where each alternative
-- begins with a data constructor.  It parses the constructor and
-- passes it to @p@.  Parsers for various constructors can be constructed
-- with 'readsUnary', 'readsUnary1' and 'readsBinary1', and combined with
-- @mappend@ from the @Monoid@ class.
--
-- @since 4.9.0.0
readsData :: (String -> ReadS a) -> Int -> ReadS a
readsData reader d =
    readParen (d > 10) $ \ r -> [res | (kw,s) <- lex r, res <- reader kw s]

-- | @'readData' p@ is a parser for datatypes where each alternative
-- begins with a data constructor.  It parses the constructor and
-- passes it to @p@.  Parsers for various constructors can be constructed
-- with 'readUnaryWith' and 'readBinaryWith', and combined with
-- '(<|>)' from the 'Alternative' class.
--
-- @since 4.10.0.0
readData :: ReadPrec a -> ReadPrec a
readData reader = parens $ prec 10 reader

-- | @'readsUnaryWith' rp n c n'@ matches the name of a unary data constructor
-- and then parses its argument using @rp@.
--
-- @since 4.9.0.0
readsUnaryWith :: (Int -> ReadS a) -> String -> (a -> t) -> String -> ReadS t
readsUnaryWith rp name cons kw s =
    [(cons x,t) | kw == name, (x,t) <- rp 11 s]

-- | @'readUnaryWith' rp n c'@ matches the name of a unary data constructor
-- and then parses its argument using @rp@.
--
-- @since 4.10.0.0
readUnaryWith :: ReadPrec a -> String -> (a -> t) -> ReadPrec t
readUnaryWith rp name cons = do
    expectP $ Ident name
    x <- step rp
    return $ cons x

-- | @'readsBinaryWith' rp1 rp2 n c n'@ matches the name of a binary
-- data constructor and then parses its arguments using @rp1@ and @rp2@
-- respectively.
--
-- @since 4.9.0.0
readsBinaryWith :: (Int -> ReadS a) -> (Int -> ReadS b) ->
    String -> (a -> b -> t) -> String -> ReadS t
readsBinaryWith rp1 rp2 name cons kw s =
    [(cons x y,u) | kw == name, (x,t) <- rp1 11 s, (y,u) <- rp2 11 t]

-- | @'readBinaryWith' rp1 rp2 n c'@ matches the name of a binary
-- data constructor and then parses its arguments using @rp1@ and @rp2@
-- respectively.
--
-- @since 4.10.0.0
readBinaryWith :: ReadPrec a -> ReadPrec b ->
    String -> (a -> b -> t) -> ReadPrec t
readBinaryWith rp1 rp2 name cons = do
    expectP $ Ident name
    x <- step rp1
    y <- step rp2
    return $ cons x y

-- | @'showsUnaryWith' sp n d x@ produces the string representation of a
-- unary data constructor with name @n@ and argument @x@, in precedence
-- context @d@.
--
-- @since 4.9.0.0
showsUnaryWith :: (Int -> a -> ShowS) -> String -> Int -> a -> ShowS
showsUnaryWith sp name d x = showParen (d > 10) $
    showString name . showChar ' ' . sp 11 x

-- | @'showsBinaryWith' sp1 sp2 n d x y@ produces the string
-- representation of a binary data constructor with name @n@ and arguments
-- @x@ and @y@, in precedence context @d@.
--
-- @since 4.9.0.0
showsBinaryWith :: (Int -> a -> ShowS) -> (Int -> b -> ShowS) ->
    String -> Int -> a -> b -> ShowS
showsBinaryWith sp1 sp2 name d x y = showParen (d > 10) $
    showString name . showChar ' ' . sp1 11 x . showChar ' ' . sp2 11 y

-- Obsolete building blocks

-- | @'readsUnary' n c n'@ matches the name of a unary data constructor
-- and then parses its argument using 'readsPrec'.
--
-- @since 4.9.0.0
{-# DEPRECATED readsUnary "Use 'readsUnaryWith' to define 'liftReadsPrec'" #-}
readsUnary :: (Read a) => String -> (a -> t) -> String -> ReadS t
readsUnary name cons kw s =
    [(cons x,t) | kw == name, (x,t) <- readsPrec 11 s]

-- | @'readsUnary1' n c n'@ matches the name of a unary data constructor
-- and then parses its argument using 'readsPrec1'.
--
-- @since 4.9.0.0
{-# DEPRECATED readsUnary1 "Use 'readsUnaryWith' to define 'liftReadsPrec'" #-}
readsUnary1 :: (Read1 f, Read a) => String -> (f a -> t) -> String -> ReadS t
readsUnary1 name cons kw s =
    [(cons x,t) | kw == name, (x,t) <- readsPrec1 11 s]

-- | @'readsBinary1' n c n'@ matches the name of a binary data constructor
-- and then parses its arguments using 'readsPrec1'.
--
-- @since 4.9.0.0
{-# DEPRECATED readsBinary1
      "Use 'readsBinaryWith' to define 'liftReadsPrec'" #-}
readsBinary1 :: (Read1 f, Read1 g, Read a) =>
    String -> (f a -> g a -> t) -> String -> ReadS t
readsBinary1 name cons kw s =
    [(cons x y,u) | kw == name,
        (x,t) <- readsPrec1 11 s, (y,u) <- readsPrec1 11 t]

-- | @'showsUnary' n d x@ produces the string representation of a unary data
-- constructor with name @n@ and argument @x@, in precedence context @d@.
--
-- @since 4.9.0.0
{-# DEPRECATED showsUnary "Use 'showsUnaryWith' to define 'liftShowsPrec'" #-}
showsUnary :: (Show a) => String -> Int -> a -> ShowS
showsUnary name d x = showParen (d > 10) $
    showString name . showChar ' ' . showsPrec 11 x

-- | @'showsUnary1' n d x@ produces the string representation of a unary data
-- constructor with name @n@ and argument @x@, in precedence context @d@.
--
-- @since 4.9.0.0
{-# DEPRECATED showsUnary1 "Use 'showsUnaryWith' to define 'liftShowsPrec'" #-}
showsUnary1 :: (Show1 f, Show a) => String -> Int -> f a -> ShowS
showsUnary1 name d x = showParen (d > 10) $
    showString name . showChar ' ' . showsPrec1 11 x

-- | @'showsBinary1' n d x y@ produces the string representation of a binary
-- data constructor with name @n@ and arguments @x@ and @y@, in precedence
-- context @d@.
--
-- @since 4.9.0.0
{-# DEPRECATED showsBinary1
      "Use 'showsBinaryWith' to define 'liftShowsPrec'" #-}
showsBinary1 :: (Show1 f, Show1 g, Show a) =>
    String -> Int -> f a -> g a -> ShowS
showsBinary1 name d x y = showParen (d > 10) $
    showString name . showChar ' ' . showsPrec1 11 x .
        showChar ' ' . showsPrec1 11 y

{- $example
These functions can be used to assemble 'Read' and 'Show' instances for
new algebraic types.  For example, given the definition

> data T f a = Zero a | One (f a) | Two a (f a)

a standard 'Read1' instance may be defined as

> instance (Read1 f) => Read1 (T f) where
>     liftReadPrec rp rl = readData $
>         readUnaryWith rp "Zero" Zero <|>
>         readUnaryWith (liftReadPrec rp rl) "One" One <|>
>         readBinaryWith rp (liftReadPrec rp rl) "Two" Two
>     liftReadListPrec = liftReadListPrecDefault

and the corresponding 'Show1' instance as

> instance (Show1 f) => Show1 (T f) where
>     liftShowsPrec sp _ d (Zero x) =
>         showsUnaryWith sp "Zero" d x
>     liftShowsPrec sp sl d (One x) =
>         showsUnaryWith (liftShowsPrec sp sl) "One" d x
>     liftShowsPrec sp sl d (Two x y) =
>         showsBinaryWith sp (liftShowsPrec sp sl) "Two" d x y

-}


{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE Trustworthy #-}
{-# LANGUAGE TypeOperators #-}
-----------------------------------------------------------------------------
-- |
-- Module      :  Data.Functor.Compose
-- Copyright   :  (c) Ross Paterson 2010
-- License     :  BSD-style (see the file LICENSE)
--
-- Maintainer  :  libraries@haskell.org
-- Stability   :  experimental
-- Portability :  portable
--
-- Composition of functors.
--
-- @since 4.9.0.0
-----------------------------------------------------------------------------

module Data.Functor.Compose (
    Compose(..),
  ) where

import Data.Functor.Classes

import Control.Applicative
import Data.Coerce (coerce)
import Data.Data (Data)
import Data.Type.Equality (TestEquality(..), (:~:)(..))
import GHC.Generics (Generic, Generic1)
import Text.Read (Read(..), readListDefault, readListPrecDefault)

infixr 9 `Compose`

-- | Right-to-left composition of functors.
-- The composition of applicative functors is always applicative,
-- but the composition of monads is not always a monad.
newtype Compose f g a = Compose { getCompose :: f (g a) }
  deriving ( Data     -- ^ @since 4.9.0.0
           , Generic  -- ^ @since 4.9.0.0
           , Generic1 -- ^ @since 4.9.0.0
           )

-- Instances of lifted Prelude classes

-- | @since 4.9.0.0
instance (Eq1 f, Eq1 g) => Eq1 (Compose f g) where
    liftEq eq (Compose x) (Compose y) = liftEq (liftEq eq) x y

-- | @since 4.9.0.0
instance (Ord1 f, Ord1 g) => Ord1 (Compose f g) where
    liftCompare comp (Compose x) (Compose y) =
        liftCompare (liftCompare comp) x y

-- | @since 4.9.0.0
instance (Read1 f, Read1 g) => Read1 (Compose f g) where
    liftReadPrec rp rl = readData $
        readUnaryWith (liftReadPrec rp' rl') "Compose" Compose
      where
        rp' = liftReadPrec     rp rl
        rl' = liftReadListPrec rp rl

    liftReadListPrec = liftReadListPrecDefault
    liftReadList     = liftReadListDefault

-- | @since 4.9.0.0
instance (Show1 f, Show1 g) => Show1 (Compose f g) where
    liftShowsPrec sp sl d (Compose x) =
        showsUnaryWith (liftShowsPrec sp' sl') "Compose" d x
      where
        sp' = liftShowsPrec sp sl
        sl' = liftShowList sp sl

-- Instances of Prelude classes

-- | @since 4.9.0.0
instance (Eq1 f, Eq1 g, Eq a) => Eq (Compose f g a) where
    (==) = eq1

-- | @since 4.9.0.0
instance (Ord1 f, Ord1 g, Ord a) => Ord (Compose f g a) where
    compare = compare1

-- | @since 4.9.0.0
instance (Read1 f, Read1 g, Read a) => Read (Compose f g a) where
    readPrec = readPrec1

    readListPrec = readListPrecDefault
    readList     = readListDefault

-- | @since 4.9.0.0
instance (Show1 f, Show1 g, Show a) => Show (Compose f g a) where
    showsPrec = showsPrec1

-- Functor instances

-- | @since 4.9.0.0
instance (Functor f, Functor g) => Functor (Compose f g) where
    fmap f (Compose x) = Compose (fmap (fmap f) x)

-- | @since 4.9.0.0
instance (Foldable f, Foldable g) => Foldable (Compose f g) where
    foldMap f (Compose t) = foldMap (foldMap f) t

-- | @since 4.9.0.0
instance (Traversable f, Traversable g) => Traversable (Compose f g) where
    traverse f (Compose t) = Compose <$> traverse (traverse f) t

-- | @since 4.9.0.0
instance (Applicative f, Applicative g) => Applicative (Compose f g) where
    pure x = Compose (pure (pure x))
    Compose f <*> Compose x = Compose (liftA2 (<*>) f x)
    liftA2 f (Compose x) (Compose y) =
      Compose (liftA2 (liftA2 f) x y)

-- | @since 4.9.0.0
instance (Alternative f, Applicative g) => Alternative (Compose f g) where
    empty = Compose empty
    (<|>) = coerce ((<|>) :: f (g a) -> f (g a) -> f (g a))
      :: forall a . Compose f g a -> Compose f g a -> Compose f g a

-- | The deduction (via generativity) that if @g x :~: g y@ then @x :~: y@.
--
-- @since 4.14.0.0
instance (TestEquality f) => TestEquality (Compose f g) where
  testEquality (Compose x) (Compose y) =
    case testEquality x y of -- :: Maybe (g x :~: g y)
      Just Refl -> Just Refl -- :: Maybe (x :~: y)
      Nothing   -> Nothing


{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE Trustworthy #-}

-----------------------------------------------------------------------------
-- |
-- Module      :  Data.Functor.Const
-- Copyright   :  Conor McBride and Ross Paterson 2005
-- License     :  BSD-style (see the LICENSE file in the distribution)
--
-- Maintainer  :  libraries@haskell.org
-- Stability   :  experimental
-- Portability :  portable

-- The 'Const' functor.
--
-- @since 4.9.0.0

module Data.Functor.Const (Const(..)) where

import Data.Bits (Bits, FiniteBits)
import Data.Foldable (Foldable(foldMap))
import Foreign.Storable (Storable)

import GHC.Arr (Ix)
import GHC.Base
import GHC.Enum (Bounded, Enum)
import GHC.Float (Floating, RealFloat)
import GHC.Generics (Generic, Generic1)
import GHC.Num (Num)
import GHC.Real (Fractional, Integral, Real, RealFrac)
import GHC.Read (Read(readsPrec), readParen, lex)
import GHC.Show (Show(showsPrec), showParen, showString)

-- | The 'Const' functor.
newtype Const a b = Const { getConst :: a }
    deriving ( Bits       -- ^ @since 4.9.0.0
             , Bounded    -- ^ @since 4.9.0.0
             , Enum       -- ^ @since 4.9.0.0
             , Eq         -- ^ @since 4.9.0.0
             , FiniteBits -- ^ @since 4.9.0.0
             , Floating   -- ^ @since 4.9.0.0
             , Fractional -- ^ @since 4.9.0.0
             , Generic    -- ^ @since 4.9.0.0
             , Generic1   -- ^ @since 4.9.0.0
             , Integral   -- ^ @since 4.9.0.0
             , Ix         -- ^ @since 4.9.0.0
             , Semigroup  -- ^ @since 4.9.0.0
             , Monoid     -- ^ @since 4.9.0.0
             , Num        -- ^ @since 4.9.0.0
             , Ord        -- ^ @since 4.9.0.0
             , Real       -- ^ @since 4.9.0.0
             , RealFrac   -- ^ @since 4.9.0.0
             , RealFloat  -- ^ @since 4.9.0.0
             , Storable   -- ^ @since 4.9.0.0
             )

-- | This instance would be equivalent to the derived instances of the
-- 'Const' newtype if the 'getConst' field were removed
--
-- @since 4.8.0.0
instance Read a => Read (Const a b) where
    readsPrec d = readParen (d > 10)
        $ \r -> [(Const x,t) | ("Const", s) <- lex r, (x, t) <- readsPrec 11 s]

-- | This instance would be equivalent to the derived instances of the
-- 'Const' newtype if the 'getConst' field were removed
--
-- @since 4.8.0.0
instance Show a => Show (Const a b) where
    showsPrec d (Const x) = showParen (d > 10) $
                            showString "Const " . showsPrec 11 x

-- | @since 4.7.0.0
instance Foldable (Const m) where
    foldMap _ _ = mempty

-- | @since 2.01
instance Functor (Const m) where
    fmap _ (Const v) = Const v

-- | @since 2.0.1
instance Monoid m => Applicative (Const m) where
    pure _ = Const mempty
    liftA2 _ (Const x) (Const y) = Const (x `mappend` y)
    (<*>) = coerce (mappend :: m -> m -> m)
-- This is pretty much the same as
-- Const f <*> Const v = Const (f `mappend` v)
-- but guarantees that mappend for Const a b will have the same arity
-- as the one for a; it won't create a closure to raise the arity
-- to 2.