{-# LANGUAGE CPP #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE MagicHash #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE PatternGuards #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE EmptyDataDecls #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}

#if __GLASGOW_HASKELL__ >= 708
{-# LANGUAGE EmptyCase #-}
#endif

#if __GLASGOW_HASKELL__ >= 806
{-# LANGUAGE QuantifiedConstraints #-}
#endif

{-|
Module:      Data.Functor.Classes.Generic
Copyright:   (C) 2015-2016 Edward Kmett, Ryan Scott
License:     BSD-style (see the file LICENSE)
Maintainer:  Ryan Scott
Stability:   Provisional
Portability: GHC

Internal functionality for "Data.Functor.Classes.Generic".

This is an internal module and, as such, the API is not guaranteed to remain the
same between any given release.
-}
module Data.Functor.Classes.Generic.Internal
  ( -- * Options
    Options(..)
  , defaultOptions
  , latestGHCOptions
    -- * 'Eq1'
#if defined(TRANSFORMERS_FOUR)
  , eq1Default
  , eq1Options
#else
  , liftEqDefault
  , liftEqOptions
#endif
  , GEq1(..)
  , Eq1Args(..)
    -- * 'Ord1'
#if defined(TRANSFORMERS_FOUR)
  , compare1Default
  , compare1Options
#else
  , liftCompareDefault
  , liftCompareOptions
#endif
  , GOrd1(..)
  , Ord1Args(..)
    -- * 'Read1'
#if defined(TRANSFORMERS_FOUR)
  , readsPrec1Default
  , readsPrec1Options
#else
  , liftReadsPrecDefault
  , liftReadsPrecOptions
#endif
  , GRead1(..)
  , GRead1Con(..)
  , Read1Args(..)
    -- * 'Show1'
#if defined(TRANSFORMERS_FOUR)
  , showsPrec1Default
  , showsPrec1Options
#else
  , liftShowsPrecDefault
  , liftShowsPrecOptions
#endif
  , GShow1(..)
  , GShow1Con(..)
  , Show1Args(..)
    -- * 'Eq'
  , eqDefault
  , GEq(..)
    -- * 'Ord'
  , compareDefault
  , GOrd(..)
    -- * 'Read'
  , readsPrecDefault
  , GRead(..)
    -- * 'Show'
  , showsPrecDefault
  , showsPrecOptions
  , GShow(..)
    -- * 'FunctorClassesDefault'
  , FunctorClassesDefault(..)
  -- * Miscellaneous types
  , V4
  , NonV4
  , ConType(..)
  , IsNullaryDataType(..)
  , IsNullaryCon(..)
  ) where

import Data.Char (isSymbol, ord)
import Data.Functor.Classes
#ifdef GENERIC_DERIVING
import Generics.Deriving.Base hiding (prec)
#else
import GHC.Generics hiding (prec)
#endif
import GHC.Read (paren, parens)
import GHC.Show (appPrec, appPrec1, showSpace)
import Text.ParserCombinators.ReadPrec
import Text.Read (Read(..))
import Text.Read.Lex (Lexeme(..))

#if !defined(TRANSFORMERS_FOUR)
import GHC.Read (list)
import Text.Show (showListWith)
#endif

#if MIN_VERSION_base(4,7,0)
import GHC.Read (expectP)
#else
import GHC.Read (lexP)
import Unsafe.Coerce (unsafeCoerce)
#endif

#if MIN_VERSION_base(4,7,0) || defined(GENERIC_DERIVING)
import GHC.Exts
#endif

#if !(MIN_VERSION_base(4,8,0))
import Data.Monoid
#endif

-------------------------------------------------------------------------------
-- * Options
-------------------------------------------------------------------------------

-- | Options that further configure how the functions in
-- "Data.Functor.Classes.Generic" should behave.
newtype Options = Options
  { Options -> Bool
ghc8ShowBehavior :: Bool
    -- ^ If 'True', a default 'Show1' implementation will show hash signs
    -- (@#@) when showing unlifted types.
  }

-- | Options that match the behavior of the installed version of GHC.
defaultOptions :: Options
defaultOptions :: Options
defaultOptions = Options :: Bool -> Options
Options
  {
#if __GLASGOW_HASKELL__ >= 800
  ghc8ShowBehavior :: Bool
ghc8ShowBehavior = Bool
True
#else
  ghc8ShowBehavior = False
#endif
  }

-- | Options that match the behavior of the most recent GHC release.
latestGHCOptions :: Options
latestGHCOptions :: Options
latestGHCOptions = Options :: Bool -> Options
Options { ghc8ShowBehavior :: Bool
ghc8ShowBehavior = Bool
True }

-- | A type-level indicator that the @transformers-0.4@ version of a class method
-- is being derived generically.
data V4

-- | A type-level indicator that the non-@transformers-0.4@ version of a class
-- method is being derived generically.
data NonV4

-------------------------------------------------------------------------------
-- * Eq
-------------------------------------------------------------------------------

-- | A default @('==')@ implementation for 'Generic1' instances that leverages
-- 'Eq1'.
eqDefault :: (GEq (Rep1 f a), Generic1 f) => f a -> f a -> Bool
eqDefault :: f a -> f a -> Bool
eqDefault f a
m f a
n = Rep1 f a -> Rep1 f a -> Bool
forall a. GEq a => a -> a -> Bool
geq (f a -> Rep1 f a
forall k (f :: k -> *) (a :: k). Generic1 f => f a -> Rep1 f a
from1 f a
m) (f a -> Rep1 f a
forall k (f :: k -> *) (a :: k). Generic1 f => f a -> Rep1 f a
from1 f a
n)

-- | Class of generic representation types that can be checked for equality.
class GEq a where
  geq :: a -> a -> Bool

instance Eq c => GEq (K1 i c p) where
  geq :: K1 i c p -> K1 i c p -> Bool
geq (K1 c
c) (K1 c
d) = c
c c -> c -> Bool
forall a. Eq a => a -> a -> Bool
== c
d

instance (GEq (f p), GEq (g p)) => GEq ((f :*: g) p) where
  geq :: (:*:) f g p -> (:*:) f g p -> Bool
geq (f p
a :*: g p
b) (f p
c :*: g p
d) = f p -> f p -> Bool
forall a. GEq a => a -> a -> Bool
geq f p
a f p
c Bool -> Bool -> Bool
&& g p -> g p -> Bool
forall a. GEq a => a -> a -> Bool
geq g p
b g p
d

instance (GEq (f p), GEq (g p)) => GEq ((f :+: g) p) where
  geq :: (:+:) f g p -> (:+:) f g p -> Bool
geq (L1 f p
a) (L1 f p
c) = f p -> f p -> Bool
forall a. GEq a => a -> a -> Bool
geq f p
a f p
c
  geq (R1 g p
b) (R1 g p
d) = g p -> g p -> Bool
forall a. GEq a => a -> a -> Bool
geq g p
b g p
d
  geq (:+:) f g p
_      (:+:) f g p
_      = Bool
False

instance GEq (f p) => GEq (M1 i c f p) where
  geq :: M1 i c f p -> M1 i c f p -> Bool
geq (M1 f p
a) (M1 f p
b) = f p -> f p -> Bool
forall a. GEq a => a -> a -> Bool
geq f p
a f p
b

instance GEq (U1 p) where
  geq :: U1 p -> U1 p -> Bool
geq U1 p
U1 U1 p
U1 = Bool
True

instance GEq (V1 p) where
  geq :: V1 p -> V1 p -> Bool
geq V1 p
_ V1 p
_ = Bool
True

instance Eq p => GEq (Par1 p) where
  geq :: Par1 p -> Par1 p -> Bool
geq (Par1 p
a) (Par1 p
b) = p
a p -> p -> Bool
forall a. Eq a => a -> a -> Bool
== p
b

instance (Eq1 f, Eq p) => GEq (Rec1 f p) where
  geq :: Rec1 f p -> Rec1 f p -> Bool
geq (Rec1 f p
a) (Rec1 f p
b) = f p -> f p -> Bool
forall (f :: * -> *) a. (Eq1 f, Eq a) => f a -> f a -> Bool
eq1 f p
a f p
b

#if defined(TRANSFORMERS_FOUR)
instance (Functor f, Eq1 f, GEq (g p)) => GEq ((f :.: g) p) where
  geq (Comp1 m) (Comp1 n) = eq1 (fmap Apply m) (fmap Apply n)
#else
instance (Eq1 f, GEq (g p)) => GEq ((f :.: g) p) where
  geq :: (:.:) f g p -> (:.:) f g p -> Bool
geq (Comp1 f (g p)
m) (Comp1 f (g p)
n) = (g p -> g p -> Bool) -> f (g p) -> f (g p) -> Bool
forall (f :: * -> *) a b.
Eq1 f =>
(a -> b -> Bool) -> f a -> f b -> Bool
liftEq g p -> g p -> Bool
forall a. GEq a => a -> a -> Bool
geq f (g p)
m f (g p)
n
#endif

#if MIN_VERSION_base(4,9,0) || defined(GENERIC_DERIVING)
-- Unboxed types
instance GEq (UAddr p) where
  geq :: UAddr p -> UAddr p -> Bool
geq = UAddr p -> UAddr p -> Bool
forall p q. UAddr p -> UAddr q -> Bool
eqUAddr

instance GEq (UChar p) where
  geq :: UChar p -> UChar p -> Bool
geq = UChar p -> UChar p -> Bool
forall p q. UChar p -> UChar q -> Bool
eqUChar

instance GEq (UDouble p) where
  geq :: UDouble p -> UDouble p -> Bool
geq = UDouble p -> UDouble p -> Bool
forall p q. UDouble p -> UDouble q -> Bool
eqUDouble

instance GEq (UFloat p) where
  geq :: UFloat p -> UFloat p -> Bool
geq = UFloat p -> UFloat p -> Bool
forall p q. UFloat p -> UFloat q -> Bool
eqUFloat

instance GEq (UInt p) where
  geq :: UInt p -> UInt p -> Bool
geq = UInt p -> UInt p -> Bool
forall p q. UInt p -> UInt q -> Bool
eqUInt

instance GEq (UWord p) where
  geq :: UWord p -> UWord p -> Bool
geq = UWord p -> UWord p -> Bool
forall p q. UWord p -> UWord q -> Bool
eqUWord
#endif

-------------------------------------------------------------------------------
-- * Eq1
-------------------------------------------------------------------------------

-- | An 'Eq1Args' value either stores an @Eq a@ dictionary (for the
-- @transformers-0.4@ version of 'Eq1'), or it stores the function argument that
-- checks the equality of occurrences of the type parameter (for the
-- non-@transformers-0.4@ version of 'Eq1').
data Eq1Args v a b where
    V4Eq1Args    :: Eq a             => Eq1Args V4    a a
    NonV4Eq1Args :: (a -> b -> Bool) -> Eq1Args NonV4 a b

#if defined(TRANSFORMERS_FOUR)
-- | A sensible default 'eq1' implementation for 'Generic1' instances.
eq1Default :: (GEq1 V4 (Rep1 f), Generic1 f, Eq a)
           => f a -> f a -> Bool
eq1Default = eq1Options defaultOptions

-- | Like 'eq1Default', but with configurable 'Options'. Currently,
-- the 'Options' have no effect (but this may change in the future).
eq1Options :: (GEq1 V4 (Rep1 f), Generic1 f, Eq a)
           => Options -> f a -> f a -> Bool
eq1Options _ m n = gliftEq V4Eq1Args (from1 m) (from1 n)
#else
-- | A sensible default 'liftEq' implementation for 'Generic1' instances.
liftEqDefault :: (GEq1 NonV4 (Rep1 f), Generic1 f)
              => (a -> b -> Bool) -> f a -> f b -> Bool
liftEqDefault :: (a -> b -> Bool) -> f a -> f b -> Bool
liftEqDefault = Options -> (a -> b -> Bool) -> f a -> f b -> Bool
forall (f :: * -> *) a b.
(GEq1 NonV4 (Rep1 f), Generic1 f) =>
Options -> (a -> b -> Bool) -> f a -> f b -> Bool
liftEqOptions Options
defaultOptions

-- | Like 'liftEqDefault', but with configurable 'Options'. Currently,
-- the 'Options' have no effect (but this may change in the future).
liftEqOptions :: (GEq1 NonV4 (Rep1 f), Generic1 f)
              => Options -> (a -> b -> Bool) -> f a -> f b -> Bool
liftEqOptions :: Options -> (a -> b -> Bool) -> f a -> f b -> Bool
liftEqOptions Options
_ a -> b -> Bool
f f a
m f b
n = Eq1Args NonV4 a b -> Rep1 f a -> Rep1 f b -> Bool
forall v (t :: * -> *) a b.
GEq1 v t =>
Eq1Args v a b -> t a -> t b -> Bool
gliftEq ((a -> b -> Bool) -> Eq1Args NonV4 a b
forall a b. (a -> b -> Bool) -> Eq1Args NonV4 a b
NonV4Eq1Args a -> b -> Bool
f) (f a -> Rep1 f a
forall k (f :: k -> *) (a :: k). Generic1 f => f a -> Rep1 f a
from1 f a
m) (f b -> Rep1 f b
forall k (f :: k -> *) (a :: k). Generic1 f => f a -> Rep1 f a
from1 f b
n)
#endif

-- | Class of generic representation types that can lift equality through unary
-- type constructors.
class
#if __GLASGOW_HASKELL__ >= 806
    (forall a. Eq a => GEq (t a)) =>
#endif
    GEq1 v t where
  gliftEq :: Eq1Args v a b -> t a -> t b -> Bool

instance Eq c => GEq1 v (K1 i c) where
  gliftEq :: Eq1Args v a b -> K1 i c a -> K1 i c b -> Bool
gliftEq Eq1Args v a b
_ (K1 c
c) (K1 c
d) = c
c c -> c -> Bool
forall a. Eq a => a -> a -> Bool
== c
d

instance (GEq1 v f, GEq1 v g) => GEq1 v (f :*: g) where
  gliftEq :: Eq1Args v a b -> (:*:) f g a -> (:*:) f g b -> Bool
gliftEq Eq1Args v a b
f (f a
a :*: g a
b) (f b
c :*: g b
d) = Eq1Args v a b -> f a -> f b -> Bool
forall v (t :: * -> *) a b.
GEq1 v t =>
Eq1Args v a b -> t a -> t b -> Bool
gliftEq Eq1Args v a b
f f a
a f b
c Bool -> Bool -> Bool
&& Eq1Args v a b -> g a -> g b -> Bool
forall v (t :: * -> *) a b.
GEq1 v t =>
Eq1Args v a b -> t a -> t b -> Bool
gliftEq Eq1Args v a b
f g a
b g b
d

instance (GEq1 v f, GEq1 v g) => GEq1 v (f :+: g) where
  gliftEq :: Eq1Args v a b -> (:+:) f g a -> (:+:) f g b -> Bool
gliftEq Eq1Args v a b
f (L1 f a
a) (L1 f b
c) = Eq1Args v a b -> f a -> f b -> Bool
forall v (t :: * -> *) a b.
GEq1 v t =>
Eq1Args v a b -> t a -> t b -> Bool
gliftEq Eq1Args v a b
f f a
a f b
c
  gliftEq Eq1Args v a b
f (R1 g a
b) (R1 g b
d) = Eq1Args v a b -> g a -> g b -> Bool
forall v (t :: * -> *) a b.
GEq1 v t =>
Eq1Args v a b -> t a -> t b -> Bool
gliftEq Eq1Args v a b
f g a
b g b
d
  gliftEq Eq1Args v a b
_ (:+:) f g a
_      (:+:) f g b
_      = Bool
False

instance GEq1 v f => GEq1 v (M1 i c f) where
  gliftEq :: Eq1Args v a b -> M1 i c f a -> M1 i c f b -> Bool
gliftEq Eq1Args v a b
f (M1 f a
a) (M1 f b
b) = Eq1Args v a b -> f a -> f b -> Bool
forall v (t :: * -> *) a b.
GEq1 v t =>
Eq1Args v a b -> t a -> t b -> Bool
gliftEq Eq1Args v a b
f f a
a f b
b

instance GEq1 v U1 where
  gliftEq :: Eq1Args v a b -> U1 a -> U1 b -> Bool
gliftEq Eq1Args v a b
_ U1 a
U1 U1 b
U1 = Bool
True

instance GEq1 v V1 where
  gliftEq :: Eq1Args v a b -> V1 a -> V1 b -> Bool
gliftEq Eq1Args v a b
_ V1 a
_ V1 b
_ = Bool
True

#if defined(TRANSFORMERS_FOUR)
instance GEq1 V4 Par1 where
  gliftEq V4Eq1Args (Par1 a) (Par1 b) = a == b

instance Eq1 f => GEq1 V4 (Rec1 f) where
  gliftEq V4Eq1Args (Rec1 a) (Rec1 b) = eq1 a b

instance (Functor f, Eq1 f, GEq1 V4 g) => GEq1 V4 (f :.: g) where
  gliftEq V4Eq1Args (Comp1 m) (Comp1 n) = eq1 (fmap Apply1 m) (fmap Apply1 n)
#else
instance GEq1 NonV4 Par1 where
  gliftEq :: Eq1Args NonV4 a b -> Par1 a -> Par1 b -> Bool
gliftEq (NonV4Eq1Args a -> b -> Bool
f) (Par1 a
a) (Par1 b
b) = a -> b -> Bool
f a
a b
b

instance Eq1 f => GEq1 NonV4 (Rec1 f) where
  gliftEq :: Eq1Args NonV4 a b -> Rec1 f a -> Rec1 f b -> Bool
gliftEq (NonV4Eq1Args a -> b -> Bool
f) (Rec1 f a
a) (Rec1 f b
b) = (a -> b -> Bool) -> f a -> f b -> Bool
forall (f :: * -> *) a b.
Eq1 f =>
(a -> b -> Bool) -> f a -> f b -> Bool
liftEq a -> b -> Bool
f f a
a f b
b

instance (Eq1 f, GEq1 NonV4 g) => GEq1 NonV4 (f :.: g) where
  gliftEq :: Eq1Args NonV4 a b -> (:.:) f g a -> (:.:) f g b -> Bool
gliftEq (NonV4Eq1Args a -> b -> Bool
f) (Comp1 f (g a)
m) (Comp1 f (g b)
n) =
    (g a -> g b -> Bool) -> f (g a) -> f (g b) -> Bool
forall (f :: * -> *) a b.
Eq1 f =>
(a -> b -> Bool) -> f a -> f b -> Bool
liftEq (Eq1Args NonV4 a b -> g a -> g b -> Bool
forall v (t :: * -> *) a b.
GEq1 v t =>
Eq1Args v a b -> t a -> t b -> Bool
gliftEq ((a -> b -> Bool) -> Eq1Args NonV4 a b
forall a b. (a -> b -> Bool) -> Eq1Args NonV4 a b
NonV4Eq1Args a -> b -> Bool
f)) f (g a)
m f (g b)
n
#endif

#if MIN_VERSION_base(4,9,0) || defined(GENERIC_DERIVING)
-- Unboxed types
instance GEq1 v UAddr where
  gliftEq :: Eq1Args v a b -> UAddr a -> UAddr b -> Bool
gliftEq Eq1Args v a b
_ = UAddr a -> UAddr b -> Bool
forall p q. UAddr p -> UAddr q -> Bool
eqUAddr

instance GEq1 v UChar where
  gliftEq :: Eq1Args v a b -> UChar a -> UChar b -> Bool
gliftEq Eq1Args v a b
_ = UChar a -> UChar b -> Bool
forall p q. UChar p -> UChar q -> Bool
eqUChar

instance GEq1 v UDouble where
  gliftEq :: Eq1Args v a b -> UDouble a -> UDouble b -> Bool
gliftEq Eq1Args v a b
_ = UDouble a -> UDouble b -> Bool
forall p q. UDouble p -> UDouble q -> Bool
eqUDouble

instance GEq1 v UFloat where
  gliftEq :: Eq1Args v a b -> UFloat a -> UFloat b -> Bool
gliftEq Eq1Args v a b
_ = UFloat a -> UFloat b -> Bool
forall p q. UFloat p -> UFloat q -> Bool
eqUFloat

instance GEq1 v UInt where
  gliftEq :: Eq1Args v a b -> UInt a -> UInt b -> Bool
gliftEq Eq1Args v a b
_ = UInt a -> UInt b -> Bool
forall p q. UInt p -> UInt q -> Bool
eqUInt

instance GEq1 v UWord where
  gliftEq :: Eq1Args v a b -> UWord a -> UWord b -> Bool
gliftEq Eq1Args v a b
_ = UWord a -> UWord b -> Bool
forall p q. UWord p -> UWord q -> Bool
eqUWord

eqUAddr :: UAddr p -> UAddr q -> Bool
eqUAddr :: UAddr p -> UAddr q -> Bool
eqUAddr (UAddr a1) (UAddr a2) = Int# -> Bool
isTrue# (Addr# -> Addr# -> Int#
eqAddr# Addr#
a1 Addr#
a2)

eqUChar :: UChar p -> UChar q -> Bool
eqUChar :: UChar p -> UChar q -> Bool
eqUChar (UChar c1) (UChar c2) = Int# -> Bool
isTrue# (Char# -> Char# -> Int#
eqChar# Char#
c1 Char#
c2)

eqUDouble :: UDouble p -> UDouble q -> Bool
eqUDouble :: UDouble p -> UDouble q -> Bool
eqUDouble (UDouble d1) (UDouble d2) = Int# -> Bool
isTrue# (Double#
d1 Double# -> Double# -> Int#
==## Double#
d2)

eqUFloat :: UFloat p -> UFloat q -> Bool
eqUFloat :: UFloat p -> UFloat q -> Bool
eqUFloat (UFloat f1) (UFloat f2) = Int# -> Bool
isTrue# (Float# -> Float# -> Int#
eqFloat# Float#
f1 Float#
f2)

eqUInt :: UInt p -> UInt q -> Bool
eqUInt :: UInt p -> UInt q -> Bool
eqUInt (UInt i1) (UInt i2) = Int# -> Bool
isTrue# (Int#
i1 Int# -> Int# -> Int#
==# Int#
i2)

eqUWord :: UWord p -> UWord q -> Bool
eqUWord :: UWord p -> UWord q -> Bool
eqUWord (UWord w1) (UWord w2) = Int# -> Bool
isTrue# (Word# -> Word# -> Int#
eqWord# Word#
w1 Word#
w2)
#endif

-------------------------------------------------------------------------------
-- * Ord
-------------------------------------------------------------------------------

-- | A default 'compare' implementation for 'Generic1' instances that leverages
-- 'Ord1'.
compareDefault :: (GOrd (Rep1 f a), Generic1 f) => f a -> f a -> Ordering
compareDefault :: f a -> f a -> Ordering
compareDefault f a
m f a
n = Rep1 f a -> Rep1 f a -> Ordering
forall a. GOrd a => a -> a -> Ordering
gcompare (f a -> Rep1 f a
forall k (f :: k -> *) (a :: k). Generic1 f => f a -> Rep1 f a
from1 f a
m) (f a -> Rep1 f a
forall k (f :: k -> *) (a :: k). Generic1 f => f a -> Rep1 f a
from1 f a
n)

-- | Class of generic representation types that can be totally ordered.
class GEq a => GOrd a where
  gcompare :: a -> a -> Ordering

instance Ord c => GOrd (K1 i c p) where
  gcompare :: K1 i c p -> K1 i c p -> Ordering
gcompare (K1 c
c) (K1 c
d) = c -> c -> Ordering
forall a. Ord a => a -> a -> Ordering
compare c
c c
d

instance (GOrd (f p), GOrd (g p)) => GOrd ((f :*: g) p) where
  gcompare :: (:*:) f g p -> (:*:) f g p -> Ordering
gcompare (f p
a :*: g p
b) (f p
c :*: g p
d) = f p -> f p -> Ordering
forall a. GOrd a => a -> a -> Ordering
gcompare f p
a f p
c Ordering -> Ordering -> Ordering
forall a. Monoid a => a -> a -> a
`mappend` g p -> g p -> Ordering
forall a. GOrd a => a -> a -> Ordering
gcompare g p
b g p
d

instance (GOrd (f p), GOrd (g p)) => GOrd ((f :+: g) p) where
  gcompare :: (:+:) f g p -> (:+:) f g p -> Ordering
gcompare (L1 f p
a) (L1 f p
c) = f p -> f p -> Ordering
forall a. GOrd a => a -> a -> Ordering
gcompare f p
a f p
c
  gcompare L1{}   R1{}   = Ordering
LT
  gcompare R1{}   L1{}   = Ordering
GT
  gcompare (R1 g p
b) (R1 g p
d) = g p -> g p -> Ordering
forall a. GOrd a => a -> a -> Ordering
gcompare g p
b g p
d

instance GOrd (f p) => GOrd (M1 i c f p) where
  gcompare :: M1 i c f p -> M1 i c f p -> Ordering
gcompare (M1 f p
a) (M1 f p
b) = f p -> f p -> Ordering
forall a. GOrd a => a -> a -> Ordering
gcompare f p
a f p
b

instance GOrd (U1 p) where
  gcompare :: U1 p -> U1 p -> Ordering
gcompare U1 p
U1 U1 p
U1 = Ordering
EQ

instance GOrd (V1 p) where
  gcompare :: V1 p -> V1 p -> Ordering
gcompare V1 p
_ V1 p
_ = Ordering
EQ

instance Ord p => GOrd (Par1 p) where
  gcompare :: Par1 p -> Par1 p -> Ordering
gcompare (Par1 p
a) (Par1 p
b) = p -> p -> Ordering
forall a. Ord a => a -> a -> Ordering
compare p
a p
b

instance (Ord1 f, Ord p) => GOrd (Rec1 f p) where
  gcompare :: Rec1 f p -> Rec1 f p -> Ordering
gcompare (Rec1 f p
a) (Rec1 f p
b) = f p -> f p -> Ordering
forall (f :: * -> *) a. (Ord1 f, Ord a) => f a -> f a -> Ordering
compare1 f p
a f p
b

#if defined(TRANSFORMERS_FOUR)
instance (Functor f, Ord1 f, GOrd (g p)) => GOrd ((f :.: g) p) where
  gcompare (Comp1 m) (Comp1 n) = compare1 (fmap Apply m) (fmap Apply n)
#else
instance (Ord1 f, GOrd (g p)) => GOrd ((f :.: g) p) where
  gcompare :: (:.:) f g p -> (:.:) f g p -> Ordering
gcompare (Comp1 f (g p)
m) (Comp1 f (g p)
n) = (g p -> g p -> Ordering) -> f (g p) -> f (g p) -> Ordering
forall (f :: * -> *) a b.
Ord1 f =>
(a -> b -> Ordering) -> f a -> f b -> Ordering
liftCompare g p -> g p -> Ordering
forall a. GOrd a => a -> a -> Ordering
gcompare f (g p)
m f (g p)
n
#endif

#if MIN_VERSION_base(4,9,0) || defined(GENERIC_DERIVING)
-- Unboxed types
instance GOrd (UAddr p) where
  gcompare :: UAddr p -> UAddr p -> Ordering
gcompare = UAddr p -> UAddr p -> Ordering
forall p q. UAddr p -> UAddr q -> Ordering
compareUAddr

instance GOrd (UChar p) where
  gcompare :: UChar p -> UChar p -> Ordering
gcompare = UChar p -> UChar p -> Ordering
forall p q. UChar p -> UChar q -> Ordering
compareUChar

instance GOrd (UDouble p) where
  gcompare :: UDouble p -> UDouble p -> Ordering
gcompare = UDouble p -> UDouble p -> Ordering
forall p q. UDouble p -> UDouble q -> Ordering
compareUDouble

instance GOrd (UFloat p) where
  gcompare :: UFloat p -> UFloat p -> Ordering
gcompare = UFloat p -> UFloat p -> Ordering
forall p q. UFloat p -> UFloat q -> Ordering
compareUFloat

instance GOrd (UInt p) where
  gcompare :: UInt p -> UInt p -> Ordering
gcompare = UInt p -> UInt p -> Ordering
forall p q. UInt p -> UInt q -> Ordering
compareUInt

instance GOrd (UWord p) where
  gcompare :: UWord p -> UWord p -> Ordering
gcompare = UWord p -> UWord p -> Ordering
forall p q. UWord p -> UWord q -> Ordering
compareUWord
#endif

-------------------------------------------------------------------------------
-- * Ord1
-------------------------------------------------------------------------------

-- | An 'Ord1Args' value either stores an @Ord a@ dictionary (for the
-- @transformers-0.4@ version of 'Ord1'), or it stores the function argument that
-- compares occurrences of the type parameter (for the non-@transformers-0.4@
-- version of 'Ord1').
data Ord1Args v a b where
    V4Ord1Args    :: Ord a                => Ord1Args V4    a a
    NonV4Ord1Args :: (a -> b -> Ordering) -> Ord1Args NonV4 a b

#if defined(TRANSFORMERS_FOUR)
-- | A sensible default 'compare1' implementation for 'Generic1' instances.
compare1Default :: (GOrd1 V4 (Rep1 f), Generic1 f, Ord a)
                => f a -> f a -> Ordering
compare1Default = compare1Options defaultOptions

-- | Like 'compare1Default', but with configurable 'Options'. Currently,
-- the 'Options' have no effect (but this may change in the future).
compare1Options :: (GOrd1 V4 (Rep1 f), Generic1 f, Ord a)
                => Options -> f a -> f a -> Ordering
compare1Options _ m n = gliftCompare V4Ord1Args (from1 m) (from1 n)
#else
-- | A sensible default 'liftCompare' implementation for 'Generic1' instances.
liftCompareDefault :: (GOrd1 NonV4 (Rep1 f), Generic1 f)
                   => (a -> b -> Ordering) -> f a -> f b -> Ordering
liftCompareDefault :: (a -> b -> Ordering) -> f a -> f b -> Ordering
liftCompareDefault = Options -> (a -> b -> Ordering) -> f a -> f b -> Ordering
forall (f :: * -> *) a b.
(GOrd1 NonV4 (Rep1 f), Generic1 f) =>
Options -> (a -> b -> Ordering) -> f a -> f b -> Ordering
liftCompareOptions Options
defaultOptions

-- | Like 'liftCompareDefault', but with configurable 'Options'. Currently,
-- the 'Options' have no effect (but this may change in the future).
liftCompareOptions :: (GOrd1 NonV4 (Rep1 f), Generic1 f)
                   => Options -> (a -> b -> Ordering) -> f a -> f b -> Ordering
liftCompareOptions :: Options -> (a -> b -> Ordering) -> f a -> f b -> Ordering
liftCompareOptions Options
_ a -> b -> Ordering
f f a
m f b
n = Ord1Args NonV4 a b -> Rep1 f a -> Rep1 f b -> Ordering
forall v (t :: * -> *) a b.
GOrd1 v t =>
Ord1Args v a b -> t a -> t b -> Ordering
gliftCompare ((a -> b -> Ordering) -> Ord1Args NonV4 a b
forall a b. (a -> b -> Ordering) -> Ord1Args NonV4 a b
NonV4Ord1Args a -> b -> Ordering
f) (f a -> Rep1 f a
forall k (f :: k -> *) (a :: k). Generic1 f => f a -> Rep1 f a
from1 f a
m) (f b -> Rep1 f b
forall k (f :: k -> *) (a :: k). Generic1 f => f a -> Rep1 f a
from1 f b
n)
#endif

-- | Class of generic representation types that can lift a total order through
-- unary type constructors.
class ( GEq1 v t
#if __GLASGOW_HASKELL__ >= 806
      , forall a. Ord a => GOrd (t a)
#endif
      ) => GOrd1 v t where
  gliftCompare :: Ord1Args v a b -> t a -> t b -> Ordering

instance Ord c => GOrd1 v (K1 i c) where
  gliftCompare :: Ord1Args v a b -> K1 i c a -> K1 i c b -> Ordering
gliftCompare Ord1Args v a b
_ (K1 c
c) (K1 c
d) = c -> c -> Ordering
forall a. Ord a => a -> a -> Ordering
compare c
c c
d

instance (GOrd1 v f, GOrd1 v g) => GOrd1 v (f :*: g) where
  gliftCompare :: Ord1Args v a b -> (:*:) f g a -> (:*:) f g b -> Ordering
gliftCompare Ord1Args v a b
f (f a
a :*: g a
b) (f b
c :*: g b
d) =
    Ord1Args v a b -> f a -> f b -> Ordering
forall v (t :: * -> *) a b.
GOrd1 v t =>
Ord1Args v a b -> t a -> t b -> Ordering
gliftCompare Ord1Args v a b
f f a
a f b
c Ordering -> Ordering -> Ordering
forall a. Monoid a => a -> a -> a
`mappend` Ord1Args v a b -> g a -> g b -> Ordering
forall v (t :: * -> *) a b.
GOrd1 v t =>
Ord1Args v a b -> t a -> t b -> Ordering
gliftCompare Ord1Args v a b
f g a
b g b
d

instance (GOrd1 v f, GOrd1 v g) => GOrd1 v (f :+: g) where
  gliftCompare :: Ord1Args v a b -> (:+:) f g a -> (:+:) f g b -> Ordering
gliftCompare Ord1Args v a b
f (L1 f a
a) (L1 f b
c) = Ord1Args v a b -> f a -> f b -> Ordering
forall v (t :: * -> *) a b.
GOrd1 v t =>
Ord1Args v a b -> t a -> t b -> Ordering
gliftCompare Ord1Args v a b
f f a
a f b
c
  gliftCompare Ord1Args v a b
_ L1{}   R1{}   = Ordering
LT
  gliftCompare Ord1Args v a b
_ R1{}   L1{}   = Ordering
GT
  gliftCompare Ord1Args v a b
f (R1 g a
b) (R1 g b
d) = Ord1Args v a b -> g a -> g b -> Ordering
forall v (t :: * -> *) a b.
GOrd1 v t =>
Ord1Args v a b -> t a -> t b -> Ordering
gliftCompare Ord1Args v a b
f g a
b g b
d

instance GOrd1 v f => GOrd1 v (M1 i c f) where
  gliftCompare :: Ord1Args v a b -> M1 i c f a -> M1 i c f b -> Ordering
gliftCompare Ord1Args v a b
f (M1 f a
a) (M1 f b
b) = Ord1Args v a b -> f a -> f b -> Ordering
forall v (t :: * -> *) a b.
GOrd1 v t =>
Ord1Args v a b -> t a -> t b -> Ordering
gliftCompare Ord1Args v a b
f f a
a f b
b

instance GOrd1 v U1 where
  gliftCompare :: Ord1Args v a b -> U1 a -> U1 b -> Ordering
gliftCompare Ord1Args v a b
_ U1 a
U1 U1 b
U1 = Ordering
EQ

instance GOrd1 v V1 where
  gliftCompare :: Ord1Args v a b -> V1 a -> V1 b -> Ordering
gliftCompare Ord1Args v a b
_ V1 a
_ V1 b
_ = Ordering
EQ

#if defined(TRANSFORMERS_FOUR)
instance GOrd1 V4 Par1 where
  gliftCompare V4Ord1Args (Par1 a) (Par1 b) = compare a b

instance Ord1 f => GOrd1 V4 (Rec1 f) where
  gliftCompare V4Ord1Args (Rec1 a) (Rec1 b) = compare1 a b

instance (Functor f, Ord1 f, GOrd1 V4 g) => GOrd1 V4 (f :.: g) where
  gliftCompare V4Ord1Args (Comp1 m) (Comp1 n) =
    compare1 (fmap Apply1 m) (fmap Apply1 n)
#else
instance GOrd1 NonV4 Par1 where
  gliftCompare :: Ord1Args NonV4 a b -> Par1 a -> Par1 b -> Ordering
gliftCompare (NonV4Ord1Args a -> b -> Ordering
f) (Par1 a
a) (Par1 b
b) = a -> b -> Ordering
f a
a b
b

instance Ord1 f => GOrd1 NonV4 (Rec1 f) where
  gliftCompare :: Ord1Args NonV4 a b -> Rec1 f a -> Rec1 f b -> Ordering
gliftCompare (NonV4Ord1Args a -> b -> Ordering
f) (Rec1 f a
a) (Rec1 f b
b) = (a -> b -> Ordering) -> f a -> f b -> Ordering
forall (f :: * -> *) a b.
Ord1 f =>
(a -> b -> Ordering) -> f a -> f b -> Ordering
liftCompare a -> b -> Ordering
f f a
a f b
b

instance (Ord1 f, GOrd1 NonV4 g) => GOrd1 NonV4 (f :.: g) where
  gliftCompare :: Ord1Args NonV4 a b -> (:.:) f g a -> (:.:) f g b -> Ordering
gliftCompare (NonV4Ord1Args a -> b -> Ordering
f) (Comp1 f (g a)
m) (Comp1 f (g b)
n) =
    (g a -> g b -> Ordering) -> f (g a) -> f (g b) -> Ordering
forall (f :: * -> *) a b.
Ord1 f =>
(a -> b -> Ordering) -> f a -> f b -> Ordering
liftCompare (Ord1Args NonV4 a b -> g a -> g b -> Ordering
forall v (t :: * -> *) a b.
GOrd1 v t =>
Ord1Args v a b -> t a -> t b -> Ordering
gliftCompare ((a -> b -> Ordering) -> Ord1Args NonV4 a b
forall a b. (a -> b -> Ordering) -> Ord1Args NonV4 a b
NonV4Ord1Args a -> b -> Ordering
f)) f (g a)
m f (g b)
n
#endif

#if MIN_VERSION_base(4,9,0) || defined(GENERIC_DERIVING)
-- Unboxed types
instance GOrd1 v UAddr where
  gliftCompare :: Ord1Args v a b -> UAddr a -> UAddr b -> Ordering
gliftCompare Ord1Args v a b
_ = UAddr a -> UAddr b -> Ordering
forall p q. UAddr p -> UAddr q -> Ordering
compareUAddr

instance GOrd1 v UChar where
  gliftCompare :: Ord1Args v a b -> UChar a -> UChar b -> Ordering
gliftCompare Ord1Args v a b
_ = UChar a -> UChar b -> Ordering
forall p q. UChar p -> UChar q -> Ordering
compareUChar

instance GOrd1 v UDouble where
  gliftCompare :: Ord1Args v a b -> UDouble a -> UDouble b -> Ordering
gliftCompare Ord1Args v a b
_ = UDouble a -> UDouble b -> Ordering
forall p q. UDouble p -> UDouble q -> Ordering
compareUDouble

instance GOrd1 v UFloat where
  gliftCompare :: Ord1Args v a b -> UFloat a -> UFloat b -> Ordering
gliftCompare Ord1Args v a b
_ = UFloat a -> UFloat b -> Ordering
forall p q. UFloat p -> UFloat q -> Ordering
compareUFloat

instance GOrd1 v UInt where
  gliftCompare :: Ord1Args v a b -> UInt a -> UInt b -> Ordering
gliftCompare Ord1Args v a b
_ = UInt a -> UInt b -> Ordering
forall p q. UInt p -> UInt q -> Ordering
compareUInt

instance GOrd1 v UWord where
  gliftCompare :: Ord1Args v a b -> UWord a -> UWord b -> Ordering
gliftCompare Ord1Args v a b
_ = UWord a -> UWord b -> Ordering
forall p q. UWord p -> UWord q -> Ordering
compareUWord

compareUAddr :: UAddr p -> UAddr q -> Ordering
compareUAddr :: UAddr p -> UAddr q -> Ordering
compareUAddr (UAddr a1) (UAddr a2) = Int# -> Int# -> Ordering
primCompare (Addr# -> Addr# -> Int#
eqAddr# Addr#
a1 Addr#
a2) (Addr# -> Addr# -> Int#
leAddr# Addr#
a1 Addr#
a2)

compareUChar :: UChar p -> UChar q -> Ordering
compareUChar :: UChar p -> UChar q -> Ordering
compareUChar (UChar c1) (UChar c2) = Int# -> Int# -> Ordering
primCompare (Char# -> Char# -> Int#
eqChar# Char#
c1 Char#
c2) (Char# -> Char# -> Int#
leChar# Char#
c1 Char#
c2)

compareUDouble :: UDouble p -> UDouble q -> Ordering
compareUDouble :: UDouble p -> UDouble q -> Ordering
compareUDouble (UDouble d1) (UDouble d2) = Int# -> Int# -> Ordering
primCompare (Double#
d1 Double# -> Double# -> Int#
==## Double#
d2) (Double#
d1 Double# -> Double# -> Int#
<=## Double#
d2)

compareUFloat :: UFloat p -> UFloat q -> Ordering
compareUFloat :: UFloat p -> UFloat q -> Ordering
compareUFloat (UFloat f1) (UFloat f2) = Int# -> Int# -> Ordering
primCompare (Float# -> Float# -> Int#
eqFloat# Float#
f1 Float#
f2) (Float# -> Float# -> Int#
leFloat# Float#
f1 Float#
f2)

compareUInt :: UInt p -> UInt q -> Ordering
compareUInt :: UInt p -> UInt q -> Ordering
compareUInt (UInt i1) (UInt i2) = Int# -> Int# -> Ordering
primCompare (Int#
i1 Int# -> Int# -> Int#
==# Int#
i2) (Int#
i1 Int# -> Int# -> Int#
<=# Int#
i2)

compareUWord :: UWord p -> UWord q -> Ordering
compareUWord :: UWord p -> UWord q -> Ordering
compareUWord (UWord w1) (UWord w2) = Int# -> Int# -> Ordering
primCompare (Word# -> Word# -> Int#
eqWord# Word#
w1 Word#
w2) (Word# -> Word# -> Int#
leWord# Word#
w1 Word#
w2)

# if __GLASGOW_HASKELL__ >= 708
primCompare :: Int# -> Int# -> Ordering
# else
primCompare :: Bool -> Bool -> Ordering
# endif
primCompare :: Int# -> Int# -> Ordering
primCompare Int#
eq Int#
le = if Int# -> Bool
isTrue# Int#
eq then Ordering
EQ
                    else if Int# -> Bool
isTrue# Int#
le then Ordering
LT
                    else Ordering
GT
#endif

-------------------------------------------------------------------------------
-- * Read
-------------------------------------------------------------------------------

-- | A default 'readsPrec' implementation for 'Generic1' instances that leverages
-- 'Read1'.
readsPrecDefault :: (GRead (Rep1 f a), Generic1 f) => Int -> ReadS (f a)
readsPrecDefault :: Int -> ReadS (f a)
readsPrecDefault Int
p = ReadPrec (f a) -> Int -> ReadS (f a)
forall a. ReadPrec a -> Int -> ReadS a
readPrec_to_S ((Rep1 f a -> f a) -> ReadPrec (Rep1 f a) -> ReadPrec (f a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Rep1 f a -> f a
forall k (f :: k -> *) (a :: k). Generic1 f => Rep1 f a -> f a
to1 ReadPrec (Rep1 f a)
forall a. GRead a => ReadPrec a
greadPrec) Int
p

-- | Class of generic representation types that can be parsed from a 'String'.
class GRead a where
  greadPrec :: ReadPrec a

instance (GRead (f p), IsNullaryDataType f) => GRead (D1 d f p) where
  greadPrec :: ReadPrec (D1 d f p)
greadPrec = ReadPrec (f p) -> ReadPrec (D1 d f p)
forall (d :: Meta) (f :: * -> *) p.
IsNullaryDataType f =>
ReadPrec (f p) -> ReadPrec (D1 d f p)
d1ReadPrec ReadPrec (f p)
forall a. GRead a => ReadPrec a
greadPrec

instance GRead (V1 p) where
  greadPrec :: ReadPrec (V1 p)
greadPrec = ReadPrec (V1 p)
forall a. ReadPrec a
pfail

instance (GRead (f p), GRead (g p)) => GRead ((f :+: g) p) where
  greadPrec :: ReadPrec ((:+:) f g p)
greadPrec = (f p -> (:+:) f g p) -> ReadPrec (f p) -> ReadPrec ((:+:) f g p)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap f p -> (:+:) f g p
forall k (f :: k -> *) (g :: k -> *) (p :: k). f p -> (:+:) f g p
L1 ReadPrec (f p)
forall a. GRead a => ReadPrec a
greadPrec ReadPrec ((:+:) f g p)
-> ReadPrec ((:+:) f g p) -> ReadPrec ((:+:) f g p)
forall a. ReadPrec a -> ReadPrec a -> ReadPrec a
+++ (g p -> (:+:) f g p) -> ReadPrec (g p) -> ReadPrec ((:+:) f g p)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap g p -> (:+:) f g p
forall k (f :: k -> *) (g :: k -> *) (p :: k). g p -> (:+:) f g p
R1 ReadPrec (g p)
forall a. GRead a => ReadPrec a
greadPrec

instance (Constructor c, GReadCon (f p), IsNullaryCon f) => GRead (C1 c f p) where
  greadPrec :: ReadPrec (C1 c f p)
greadPrec = (ConType -> ReadPrec (f p)) -> ReadPrec (C1 c f p)
forall (c :: Meta) (f :: * -> *) p.
(Constructor c, IsNullaryCon f) =>
(ConType -> ReadPrec (f p)) -> ReadPrec (C1 c f p)
c1ReadPrec ConType -> ReadPrec (f p)
forall a. GReadCon a => ConType -> ReadPrec a
greadPrecCon

-- | Class of generic representation types that can be parsed from a 'String',
-- and for which the 'ConType' has been determined.
class GReadCon a where
  greadPrecCon :: ConType -> ReadPrec a

instance GReadCon (U1 p) where
  greadPrecCon :: ConType -> ReadPrec (U1 p)
greadPrecCon ConType
_ = U1 p -> ReadPrec (U1 p)
forall (m :: * -> *) a. Monad m => a -> m a
return U1 p
forall k (p :: k). U1 p
U1

instance Read c => GReadCon (K1 i c p) where
  greadPrecCon :: ConType -> ReadPrec (K1 i c p)
greadPrecCon ConType
_ = ReadPrec c -> ReadPrec (K1 i c p)
forall c i p. ReadPrec c -> ReadPrec (K1 i c p)
coerceK1 ReadPrec c
forall a. Read a => ReadPrec a
readPrec

instance (Selector s, GReadCon (f p)) => GReadCon (S1 s f p) where
  greadPrecCon :: ConType -> ReadPrec (S1 s f p)
greadPrecCon = ReadPrec (f p) -> ReadPrec (S1 s f p)
forall (s :: Meta) (f :: * -> *) p.
Selector s =>
ReadPrec (f p) -> ReadPrec (S1 s f p)
s1ReadPrec (ReadPrec (f p) -> ReadPrec (S1 s f p))
-> (ConType -> ReadPrec (f p)) -> ConType -> ReadPrec (S1 s f p)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ConType -> ReadPrec (f p)
forall a. GReadCon a => ConType -> ReadPrec a
greadPrecCon

instance (GReadCon (f p), GReadCon (g p)) => GReadCon ((f :*: g) p) where
  greadPrecCon :: ConType -> ReadPrec ((:*:) f g p)
greadPrecCon ConType
t = ConType
-> ReadPrec (f p) -> ReadPrec (g p) -> ReadPrec ((:*:) f g p)
forall (f :: * -> *) p (g :: * -> *).
ConType
-> ReadPrec (f p) -> ReadPrec (g p) -> ReadPrec ((:*:) f g p)
productReadPrec ConType
t (ConType -> ReadPrec (f p)
forall a. GReadCon a => ConType -> ReadPrec a
greadPrecCon ConType
t) (ConType -> ReadPrec (g p)
forall a. GReadCon a => ConType -> ReadPrec a
greadPrecCon ConType
t)

instance Read p => GReadCon (Par1 p) where
  greadPrecCon :: ConType -> ReadPrec (Par1 p)
greadPrecCon ConType
_ = ReadPrec p -> ReadPrec (Par1 p)
forall p. ReadPrec p -> ReadPrec (Par1 p)
coercePar1 ReadPrec p
forall a. Read a => ReadPrec a
readPrec

#if defined(TRANSFORMERS_FOUR)
instance (Read1 f, Read p) => GReadCon (Rec1 f p) where
  greadPrecCon _ = coerceRec1 $ readS_to_Prec readsPrec1

instance (Functor f, Read1 f, GReadCon (g p)) => GReadCon ((f :.: g) p) where
  greadPrecCon _ =
      coerceComp1 $ fmap (fmap getApply) $ readS_to_Prec crp1
    where
      crp1 :: Int -> ReadS (f (Apply g p))
      crp1 = readsPrec1
#else
instance (Read1 f, Read p) => GReadCon (Rec1 f p) where
  greadPrecCon :: ConType -> ReadPrec (Rec1 f p)
greadPrecCon ConType
_ = ReadPrec (f p) -> ReadPrec (Rec1 f p)
forall (f :: * -> *) a. ReadPrec (f a) -> ReadPrec (Rec1 f a)
coerceRec1 (ReadPrec (f p) -> ReadPrec (Rec1 f p))
-> ReadPrec (f p) -> ReadPrec (Rec1 f p)
forall a b. (a -> b) -> a -> b
$ (Int -> ReadS (f p)) -> ReadPrec (f p)
forall a. (Int -> ReadS a) -> ReadPrec a
readS_to_Prec ((Int -> ReadS (f p)) -> ReadPrec (f p))
-> (Int -> ReadS (f p)) -> ReadPrec (f p)
forall a b. (a -> b) -> a -> b
$
      (Int -> ReadS p) -> ReadS [p] -> Int -> ReadS (f p)
forall (f :: * -> *) a.
Read1 f =>
(Int -> ReadS a) -> ReadS [a] -> Int -> ReadS (f a)
liftReadsPrec (ReadPrec p -> Int -> ReadS p
forall a. ReadPrec a -> Int -> ReadS a
readPrec_to_S ReadPrec p
forall a. Read a => ReadPrec a
readPrec) (ReadPrec [p] -> Int -> ReadS [p]
forall a. ReadPrec a -> Int -> ReadS a
readPrec_to_S ReadPrec [p]
forall a. Read a => ReadPrec [a]
readListPrec Int
0)

instance (Read1 f, GReadCon (g p)) => GReadCon ((f :.: g) p) where
  greadPrecCon :: ConType -> ReadPrec ((:.:) f g p)
greadPrecCon ConType
t = ReadPrec (f (g p)) -> ReadPrec ((:.:) f g p)
forall (f :: * -> *) (g :: * -> *) a.
ReadPrec (f (g a)) -> ReadPrec ((:.:) f g a)
coerceComp1 (ReadPrec (f (g p)) -> ReadPrec ((:.:) f g p))
-> ReadPrec (f (g p)) -> ReadPrec ((:.:) f g p)
forall a b. (a -> b) -> a -> b
$ (Int -> ReadS (f (g p))) -> ReadPrec (f (g p))
forall a. (Int -> ReadS a) -> ReadPrec a
readS_to_Prec ((Int -> ReadS (f (g p))) -> ReadPrec (f (g p)))
-> (Int -> ReadS (f (g p))) -> ReadPrec (f (g p))
forall a b. (a -> b) -> a -> b
$
      (Int -> ReadS (g p)) -> ReadS [g p] -> Int -> ReadS (f (g p))
forall (f :: * -> *) a.
Read1 f =>
(Int -> ReadS a) -> ReadS [a] -> Int -> ReadS (f a)
liftReadsPrec (ReadPrec (g p) -> Int -> ReadS (g p)
forall a. ReadPrec a -> Int -> ReadS a
readPrec_to_S       ReadPrec (g p)
grpc)
                    (ReadPrec [g p] -> Int -> ReadS [g p]
forall a. ReadPrec a -> Int -> ReadS a
readPrec_to_S (ReadPrec (g p) -> ReadPrec [g p]
forall a. ReadPrec a -> ReadPrec [a]
list ReadPrec (g p)
grpc) Int
0)
    where
      grpc :: ReadPrec (g p)
grpc = ConType -> ReadPrec (g p)
forall a. GReadCon a => ConType -> ReadPrec a
greadPrecCon ConType
t
#endif

-------------------------------------------------------------------------------
-- * Read1
-------------------------------------------------------------------------------

-- | A 'Read1Args' value either stores a @Read a@ dictionary (for the
-- @transformers-0.4@ version of 'Read1'), or it stores the two function arguments
-- that parse occurrences of the type parameter (for the non-@transformers-0.4@
-- version of 'Read1').
data Read1Args v a where
    V4Read1Args    :: Read a                     => Read1Args V4    a
    NonV4Read1Args :: ReadPrec a -> ReadPrec [a] -> Read1Args NonV4 a

#if defined(TRANSFORMERS_FOUR)
-- | A sensible default 'readsPrec1' implementation for 'Generic1' instances.
readsPrec1Default :: (GRead1 V4 (Rep1 f), Generic1 f, Read a)
                  => Int -> ReadS (f a)
readsPrec1Default = readsPrec1Options defaultOptions

-- | Like 'readsPrec1Default', but with configurable 'Options'. Currently,
-- the 'Options' have no effect (but this may change in the future).
readsPrec1Options :: (GRead1 V4 (Rep1 f), Generic1 f, Read a)
                  => Options -> Int -> ReadS (f a)
readsPrec1Options _ p =
  readPrec_to_S (fmap to1 $ gliftReadPrec V4Read1Args) p
#else
-- | A sensible default 'liftReadsPrec' implementation for 'Generic1' instances.
liftReadsPrecDefault :: (GRead1 NonV4 (Rep1 f), Generic1 f)
                     => (Int -> ReadS a) -> ReadS [a] -> Int -> ReadS (f a)
liftReadsPrecDefault :: (Int -> ReadS a) -> ReadS [a] -> Int -> ReadS (f a)
liftReadsPrecDefault = Options -> (Int -> ReadS a) -> ReadS [a] -> Int -> ReadS (f a)
forall (f :: * -> *) a.
(GRead1 NonV4 (Rep1 f), Generic1 f) =>
Options -> (Int -> ReadS a) -> ReadS [a] -> Int -> ReadS (f a)
liftReadsPrecOptions Options
defaultOptions

-- | Like 'liftReadsPrecDefault', but with configurable 'Options'. Currently,
-- the 'Options' have no effect (but this may change in the future).
liftReadsPrecOptions :: (GRead1 NonV4 (Rep1 f), Generic1 f)
                     => Options -> (Int -> ReadS a) -> ReadS [a] -> Int -> ReadS (f a)
liftReadsPrecOptions :: Options -> (Int -> ReadS a) -> ReadS [a] -> Int -> ReadS (f a)
liftReadsPrecOptions Options
_ Int -> ReadS a
rp ReadS [a]
rl Int
p =
  ReadPrec (f a) -> Int -> ReadS (f a)
forall a. ReadPrec a -> Int -> ReadS a
readPrec_to_S ((Rep1 f a -> f a) -> ReadPrec (Rep1 f a) -> ReadPrec (f a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Rep1 f a -> f a
forall k (f :: k -> *) (a :: k). Generic1 f => Rep1 f a -> f a
to1 (ReadPrec (Rep1 f a) -> ReadPrec (f a))
-> ReadPrec (Rep1 f a) -> ReadPrec (f a)
forall a b. (a -> b) -> a -> b
$ Read1Args NonV4 a -> ReadPrec (Rep1 f a)
forall v (f :: * -> *) a.
GRead1 v f =>
Read1Args v a -> ReadPrec (f a)
gliftReadPrec
                      (ReadPrec a -> ReadPrec [a] -> Read1Args NonV4 a
forall a. ReadPrec a -> ReadPrec [a] -> Read1Args NonV4 a
NonV4Read1Args ((Int -> ReadS a) -> ReadPrec a
forall a. (Int -> ReadS a) -> ReadPrec a
readS_to_Prec Int -> ReadS a
rp)
                                      ((Int -> ReadS [a]) -> ReadPrec [a]
forall a. (Int -> ReadS a) -> ReadPrec a
readS_to_Prec (ReadS [a] -> Int -> ReadS [a]
forall a b. a -> b -> a
const ReadS [a]
rl)))) Int
p
#endif

#if !(MIN_VERSION_base(4,7,0))
coerce :: a -> b
coerce = unsafeCoerce

expectP :: Lexeme -> ReadPrec ()
expectP lexeme = do
  thing <- lexP
  if thing == lexeme then return () else pfail
#endif

coerceM1 :: ReadPrec (f p) -> ReadPrec (M1 i c f p)
coerceM1 :: ReadPrec (f p) -> ReadPrec (M1 i c f p)
coerceM1 = ReadPrec (f p) -> ReadPrec (M1 i c f p)
coerce

coercePar1 :: ReadPrec p -> ReadPrec (Par1 p)
coercePar1 :: ReadPrec p -> ReadPrec (Par1 p)
coercePar1 = ReadPrec p -> ReadPrec (Par1 p)
coerce

coerceRec1 :: ReadPrec (f a) -> ReadPrec (Rec1 f a)
coerceRec1 :: ReadPrec (f a) -> ReadPrec (Rec1 f a)
coerceRec1 = ReadPrec (f a) -> ReadPrec (Rec1 f a)
coerce

coerceComp1 :: ReadPrec (f (g a)) -> ReadPrec ((f :.: g) a)
coerceComp1 :: ReadPrec (f (g a)) -> ReadPrec ((:.:) f g a)
coerceComp1 = ReadPrec (f (g a)) -> ReadPrec ((:.:) f g a)
coerce

coerceK1 :: ReadPrec c -> ReadPrec (K1 i c p)
coerceK1 :: ReadPrec c -> ReadPrec (K1 i c p)
coerceK1 = ReadPrec c -> ReadPrec (K1 i c p)
coerce

isSymVar :: String -> Bool
isSymVar :: String -> Bool
isSymVar String
""    = Bool
False
isSymVar (Char
c:String
_) = Char -> Bool
startsVarSym Char
c

startsVarSym :: Char -> Bool
startsVarSym :: Char -> Bool
startsVarSym Char
c = Char -> Bool
startsVarSymASCII Char
c Bool -> Bool -> Bool
|| (Char -> Int
ord Char
c Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0x7f Bool -> Bool -> Bool
&& Char -> Bool
isSymbol Char
c) -- Infix Ids

startsVarSymASCII :: Char -> Bool
startsVarSymASCII :: Char -> Bool
startsVarSymASCII Char
c = Char
c Char -> String -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` String
"!#$%&*+./<=>?@\\^|~-"

snocView :: [a] -> Maybe ([a],a)
        -- Split off the last element
snocView :: [a] -> Maybe ([a], a)
snocView [] = Maybe ([a], a)
forall a. Maybe a
Nothing
snocView [a]
xs = [a] -> [a] -> Maybe ([a], a)
forall a. [a] -> [a] -> Maybe ([a], a)
go [] [a]
xs
  where
      -- Invariant: second arg is non-empty
    go :: [a] -> [a] -> Maybe ([a], a)
go [a]
acc [a
a]    = ([a], a) -> Maybe ([a], a)
forall a. a -> Maybe a
Just ([a] -> [a]
forall a. [a] -> [a]
reverse [a]
acc, a
a)
    go [a]
acc (a
a:[a]
as) = [a] -> [a] -> Maybe ([a], a)
go (a
aa -> [a] -> [a]
forall a. a -> [a] -> [a]
:[a]
acc) [a]
as
    go [a]
_ [] = String -> Maybe ([a], a)
forall a. HasCallStack => String -> a
error String
"Util: snocView"

identHLexemes :: String -> [Lexeme]
identHLexemes :: String -> [Lexeme]
identHLexemes String
s | Just (String
ss, Char
'#') <- String -> Maybe (String, Char)
forall a. [a] -> Maybe ([a], a)
snocView String
s = [String -> Lexeme
Ident String
ss, String -> Lexeme
Symbol String
"#"]
                | Bool
otherwise                    = [String -> Lexeme
Ident String
s]

-- | Class of generic representation types for unary type constructors that can
-- be parsed from a 'String'.
class
#if __GLASGOW_HASKELL__ >= 806
    (forall a. Read a => GRead (f a)) =>
#endif
    GRead1 v f where
  gliftReadPrec :: Read1Args v a -> ReadPrec (f a)

instance (GRead1 v f, IsNullaryDataType f) => GRead1 v (D1 d f) where
  gliftReadPrec :: Read1Args v a -> ReadPrec (D1 d f a)
gliftReadPrec = ReadPrec (f a) -> ReadPrec (D1 d f a)
forall (d :: Meta) (f :: * -> *) p.
IsNullaryDataType f =>
ReadPrec (f p) -> ReadPrec (D1 d f p)
d1ReadPrec (ReadPrec (f a) -> ReadPrec (D1 d f a))
-> (Read1Args v a -> ReadPrec (f a))
-> Read1Args v a
-> ReadPrec (D1 d f a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Read1Args v a -> ReadPrec (f a)
forall v (f :: * -> *) a.
GRead1 v f =>
Read1Args v a -> ReadPrec (f a)
gliftReadPrec

d1ReadPrec :: forall d f p. IsNullaryDataType f
           => ReadPrec (f p) -> ReadPrec (D1 d f p)
d1ReadPrec :: ReadPrec (f p) -> ReadPrec (D1 d f p)
d1ReadPrec ReadPrec (f p)
rp = ReadPrec (f p) -> ReadPrec (D1 d f p)
forall (f :: * -> *) p i (c :: Meta).
ReadPrec (f p) -> ReadPrec (M1 i c f p)
coerceM1 (ReadPrec (f p) -> ReadPrec (D1 d f p))
-> ReadPrec (f p) -> ReadPrec (D1 d f p)
forall a b. (a -> b) -> a -> b
$ ReadPrec (f p) -> ReadPrec (f p)
forall a. ReadPrec a -> ReadPrec a
parensIfNonNullary ReadPrec (f p)
rp
  where
    x :: f p
    x :: f p
x = f p
forall a. HasCallStack => a
undefined

    parensIfNonNullary :: ReadPrec a -> ReadPrec a
    parensIfNonNullary :: ReadPrec a -> ReadPrec a
parensIfNonNullary = if f p -> Bool
forall (f :: * -> *) a. IsNullaryDataType f => f a -> Bool
isNullaryDataType f p
x
                            then ReadPrec a -> ReadPrec a
forall a. a -> a
id
                            else ReadPrec a -> ReadPrec a
forall a. ReadPrec a -> ReadPrec a
parens

instance GRead1 v V1 where
  gliftReadPrec :: Read1Args v a -> ReadPrec (V1 a)
gliftReadPrec Read1Args v a
_ = ReadPrec (V1 a)
forall a. ReadPrec a
pfail

instance (GRead1 v f, GRead1 v g) => GRead1 v (f :+: g) where
  gliftReadPrec :: Read1Args v a -> ReadPrec ((:+:) f g a)
gliftReadPrec Read1Args v a
ras =
    (f a -> (:+:) f g a) -> ReadPrec (f a) -> ReadPrec ((:+:) f g a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap f a -> (:+:) f g a
forall k (f :: k -> *) (g :: k -> *) (p :: k). f p -> (:+:) f g p
L1 (Read1Args v a -> ReadPrec (f a)
forall v (f :: * -> *) a.
GRead1 v f =>
Read1Args v a -> ReadPrec (f a)
gliftReadPrec Read1Args v a
ras) ReadPrec ((:+:) f g a)
-> ReadPrec ((:+:) f g a) -> ReadPrec ((:+:) f g a)
forall a. ReadPrec a -> ReadPrec a -> ReadPrec a
+++ (g a -> (:+:) f g a) -> ReadPrec (g a) -> ReadPrec ((:+:) f g a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap g a -> (:+:) f g a
forall k (f :: k -> *) (g :: k -> *) (p :: k). g p -> (:+:) f g p
R1 (Read1Args v a -> ReadPrec (g a)
forall v (f :: * -> *) a.
GRead1 v f =>
Read1Args v a -> ReadPrec (f a)
gliftReadPrec Read1Args v a
ras)

instance (Constructor c, GRead1Con v f, IsNullaryCon f) => GRead1 v (C1 c f) where
  gliftReadPrec :: Read1Args v a -> ReadPrec (C1 c f a)
gliftReadPrec Read1Args v a
ras = (ConType -> ReadPrec (f a)) -> ReadPrec (C1 c f a)
forall (c :: Meta) (f :: * -> *) p.
(Constructor c, IsNullaryCon f) =>
(ConType -> ReadPrec (f p)) -> ReadPrec (C1 c f p)
c1ReadPrec ((ConType -> ReadPrec (f a)) -> ReadPrec (C1 c f a))
-> (ConType -> ReadPrec (f a)) -> ReadPrec (C1 c f a)
forall a b. (a -> b) -> a -> b
$ \ConType
t -> ConType -> Read1Args v a -> ReadPrec (f a)
forall v (f :: * -> *) a.
GRead1Con v f =>
ConType -> Read1Args v a -> ReadPrec (f a)
gliftReadPrecCon ConType
t Read1Args v a
ras

c1ReadPrec :: forall c f p. (Constructor c, IsNullaryCon f)
           => (ConType -> ReadPrec (f p)) -> ReadPrec (C1 c f p)
c1ReadPrec :: (ConType -> ReadPrec (f p)) -> ReadPrec (C1 c f p)
c1ReadPrec ConType -> ReadPrec (f p)
rpc =
  ReadPrec (f p) -> ReadPrec (C1 c f p)
forall (f :: * -> *) p i (c :: Meta).
ReadPrec (f p) -> ReadPrec (M1 i c f p)
coerceM1 (ReadPrec (f p) -> ReadPrec (C1 c f p))
-> ReadPrec (f p) -> ReadPrec (C1 c f p)
forall a b. (a -> b) -> a -> b
$ case Fixity
fixity of
    Fixity
Prefix -> ReadPrec (f p) -> ReadPrec (f p)
forall a. ReadPrec a -> ReadPrec a
precIfNonNullary (ReadPrec (f p) -> ReadPrec (f p))
-> ReadPrec (f p) -> ReadPrec (f p)
forall a b. (a -> b) -> a -> b
$ do
                if C1 c f p -> Bool
forall (c :: Meta) (f :: * -> *) p.
Constructor c =>
C1 c f p -> Bool
conIsTuple C1 c f p
c
                   then () -> ReadPrec ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
                   else let cn :: String
cn = C1 c f p -> String
forall k (c :: k) k1 (t :: k -> (k1 -> *) -> k1 -> *)
       (f :: k1 -> *) (a :: k1).
Constructor c =>
t c f a -> String
conName C1 c f p
c
                        in if String -> Bool
isInfixDataCon String
cn
                              then Char -> ReadPrec () -> Char -> ReadPrec ()
forall a. Char -> ReadPrec a -> Char -> ReadPrec a
readSurround Char
'(' (Lexeme -> ReadPrec ()
expectP (String -> Lexeme
Symbol String
cn)) Char
')'
                              else (Lexeme -> ReadPrec ()) -> [Lexeme] -> ReadPrec ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Lexeme -> ReadPrec ()
expectP ([Lexeme] -> ReadPrec ()) -> [Lexeme] -> ReadPrec ()
forall a b. (a -> b) -> a -> b
$ String -> [Lexeme]
identHLexemes String
cn
                ConType -> ReadPrec (f p) -> ReadPrec (f p)
forall a. ConType -> ReadPrec a -> ReadPrec a
readBraces ConType
t (ConType -> ReadPrec (f p)
rpc ConType
t)
    Infix Associativity
_ Int
m -> Int -> ReadPrec (f p) -> ReadPrec (f p)
forall a. Int -> ReadPrec a -> ReadPrec a
prec Int
m (ReadPrec (f p) -> ReadPrec (f p))
-> ReadPrec (f p) -> ReadPrec (f p)
forall a b. (a -> b) -> a -> b
$ ConType -> ReadPrec (f p)
rpc ConType
t
  where
    c :: C1 c f p
    c :: C1 c f p
c = C1 c f p
forall a. HasCallStack => a
undefined

    x :: f p
    x :: f p
x = f p
forall a. HasCallStack => a
undefined

    fixity :: Fixity
    fixity :: Fixity
fixity = C1 c f p -> Fixity
forall k (c :: k) k1 (t :: k -> (k1 -> *) -> k1 -> *)
       (f :: k1 -> *) (a :: k1).
Constructor c =>
t c f a -> Fixity
conFixity C1 c f p
c

    precIfNonNullary :: ReadPrec a -> ReadPrec a
    precIfNonNullary :: ReadPrec a -> ReadPrec a
precIfNonNullary = if f p -> Bool
forall (f :: * -> *) a. IsNullaryCon f => f a -> Bool
isNullaryCon f p
x
                          then ReadPrec a -> ReadPrec a
forall a. a -> a
id
                          else Int -> ReadPrec a -> ReadPrec a
forall a. Int -> ReadPrec a -> ReadPrec a
prec (if C1 c f p -> Bool
forall k (c :: k) k1 (t :: k -> (k1 -> *) -> k1 -> *)
       (f :: k1 -> *) (a :: k1).
Constructor c =>
t c f a -> Bool
conIsRecord C1 c f p
c
                                        then Int
appPrec1
                                        else Int
appPrec)

    t :: ConType
    t :: ConType
t = if C1 c f p -> Bool
forall k (c :: k) k1 (t :: k -> (k1 -> *) -> k1 -> *)
       (f :: k1 -> *) (a :: k1).
Constructor c =>
t c f a -> Bool
conIsRecord C1 c f p
c
        then ConType
Rec
        else case C1 c f p -> Bool
forall (c :: Meta) (f :: * -> *) p.
Constructor c =>
C1 c f p -> Bool
conIsTuple C1 c f p
c of
            Bool
True  -> ConType
Tup
            Bool
False -> case Fixity
fixity of
                Fixity
Prefix    -> ConType
Pref
                Infix Associativity
_ Int
_ -> String -> ConType
Inf (String -> ConType) -> String -> ConType
forall a b. (a -> b) -> a -> b
$ C1 c f p -> String
forall k (c :: k) k1 (t :: k -> (k1 -> *) -> k1 -> *)
       (f :: k1 -> *) (a :: k1).
Constructor c =>
t c f a -> String
conName C1 c f p
c

readBraces :: ConType -> ReadPrec a -> ReadPrec a
readBraces :: ConType -> ReadPrec a -> ReadPrec a
readBraces ConType
Rec     ReadPrec a
r = Char -> ReadPrec a -> Char -> ReadPrec a
forall a. Char -> ReadPrec a -> Char -> ReadPrec a
readSurround Char
'{' ReadPrec a
r Char
'}'
readBraces ConType
Tup     ReadPrec a
r = ReadPrec a -> ReadPrec a
forall a. ReadPrec a -> ReadPrec a
paren ReadPrec a
r
readBraces ConType
Pref    ReadPrec a
r = ReadPrec a
r
readBraces (Inf String
_) ReadPrec a
r = ReadPrec a
r

readSurround :: Char -> ReadPrec a -> Char -> ReadPrec a
readSurround :: Char -> ReadPrec a -> Char -> ReadPrec a
readSurround Char
c1 ReadPrec a
r Char
c2 = do
  Lexeme -> ReadPrec ()
expectP (String -> Lexeme
Punc [Char
c1])
  a
r' <- ReadPrec a
r
  Lexeme -> ReadPrec ()
expectP (String -> Lexeme
Punc [Char
c2])
  a -> ReadPrec a
forall (m :: * -> *) a. Monad m => a -> m a
return a
r'

-- | Class of generic representation types for unary type constructors that
-- can be parsed from a 'String', and for which the 'ConType' has been
-- determined.
class
#if __GLASGOW_HASKELL__ >= 806
    (forall a. Read a => GReadCon (f a)) =>
#endif
    GRead1Con v f where
  gliftReadPrecCon :: ConType -> Read1Args v a -> ReadPrec (f a)

instance GRead1Con v U1 where
  gliftReadPrecCon :: ConType -> Read1Args v a -> ReadPrec (U1 a)
gliftReadPrecCon ConType
_ Read1Args v a
_ = U1 a -> ReadPrec (U1 a)
forall (m :: * -> *) a. Monad m => a -> m a
return U1 a
forall k (p :: k). U1 p
U1

instance Read c => GRead1Con v (K1 i c) where
  gliftReadPrecCon :: ConType -> Read1Args v a -> ReadPrec (K1 i c a)
gliftReadPrecCon ConType
_ Read1Args v a
_ = ReadPrec c -> ReadPrec (K1 i c a)
forall c i p. ReadPrec c -> ReadPrec (K1 i c p)
coerceK1 ReadPrec c
forall a. Read a => ReadPrec a
readPrec

instance (Selector s, GRead1Con v f) => GRead1Con v (S1 s f) where
  gliftReadPrecCon :: ConType -> Read1Args v a -> ReadPrec (S1 s f a)
gliftReadPrecCon ConType
t = ReadPrec (f a) -> ReadPrec (S1 s f a)
forall (s :: Meta) (f :: * -> *) p.
Selector s =>
ReadPrec (f p) -> ReadPrec (S1 s f p)
s1ReadPrec (ReadPrec (f a) -> ReadPrec (S1 s f a))
-> (Read1Args v a -> ReadPrec (f a))
-> Read1Args v a
-> ReadPrec (S1 s f a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ConType -> Read1Args v a -> ReadPrec (f a)
forall v (f :: * -> *) a.
GRead1Con v f =>
ConType -> Read1Args v a -> ReadPrec (f a)
gliftReadPrecCon ConType
t

s1ReadPrec :: forall s f p. Selector s
           => ReadPrec (f p) -> ReadPrec (S1 s f p)
s1ReadPrec :: ReadPrec (f p) -> ReadPrec (S1 s f p)
s1ReadPrec ReadPrec (f p)
rp
  | String
selectorName String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"" = ReadPrec (f p) -> ReadPrec (S1 s f p)
forall (f :: * -> *) p i (c :: Meta).
ReadPrec (f p) -> ReadPrec (M1 i c f p)
coerceM1 (ReadPrec (f p) -> ReadPrec (S1 s f p))
-> ReadPrec (f p) -> ReadPrec (S1 s f p)
forall a b. (a -> b) -> a -> b
$ ReadPrec (f p) -> ReadPrec (f p)
forall a. ReadPrec a -> ReadPrec a
step ReadPrec (f p)
rp
  | Bool
otherwise          = ReadPrec (f p) -> ReadPrec (S1 s f p)
forall (f :: * -> *) p i (c :: Meta).
ReadPrec (f p) -> ReadPrec (M1 i c f p)
coerceM1 (ReadPrec (f p) -> ReadPrec (S1 s f p))
-> ReadPrec (f p) -> ReadPrec (S1 s f p)
forall a b. (a -> b) -> a -> b
$ do
                            (Lexeme -> ReadPrec ()) -> [Lexeme] -> ReadPrec ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Lexeme -> ReadPrec ()
expectP ([Lexeme] -> ReadPrec ()) -> [Lexeme] -> ReadPrec ()
forall a b. (a -> b) -> a -> b
$ String -> [Lexeme]
readLblLexemes String
selectorName
                            Lexeme -> ReadPrec ()
expectP (String -> Lexeme
Punc String
"=")
                            ReadPrec (f p) -> ReadPrec (f p)
forall a. ReadPrec a -> ReadPrec a
reset ReadPrec (f p)
rp
  where
    selectorName :: String
    selectorName :: String
selectorName = S1 s f p -> String
forall k (s :: k) k1 (t :: k -> (k1 -> *) -> k1 -> *)
       (f :: k1 -> *) (a :: k1).
Selector s =>
t s f a -> String
selName (S1 s f p
forall a. HasCallStack => a
undefined :: S1 s f p)

    readLblLexemes :: String -> [Lexeme]
    readLblLexemes :: String -> [Lexeme]
readLblLexemes String
lbl | String -> Bool
isSymVar String
lbl
                       = [String -> Lexeme
Punc String
"(", String -> Lexeme
Symbol String
lbl, String -> Lexeme
Punc String
")"]
                       | Bool
otherwise
                       = String -> [Lexeme]
identHLexemes String
lbl

instance (GRead1Con v f, GRead1Con v g) => GRead1Con v (f :*: g) where
  gliftReadPrecCon :: ConType -> Read1Args v a -> ReadPrec ((:*:) f g a)
gliftReadPrecCon ConType
t Read1Args v a
ras =
    ConType
-> ReadPrec (f a) -> ReadPrec (g a) -> ReadPrec ((:*:) f g a)
forall (f :: * -> *) p (g :: * -> *).
ConType
-> ReadPrec (f p) -> ReadPrec (g p) -> ReadPrec ((:*:) f g p)
productReadPrec ConType
t (ConType -> Read1Args v a -> ReadPrec (f a)
forall v (f :: * -> *) a.
GRead1Con v f =>
ConType -> Read1Args v a -> ReadPrec (f a)
gliftReadPrecCon ConType
t Read1Args v a
ras) (ConType -> Read1Args v a -> ReadPrec (g a)
forall v (f :: * -> *) a.
GRead1Con v f =>
ConType -> Read1Args v a -> ReadPrec (f a)
gliftReadPrecCon ConType
t Read1Args v a
ras)

productReadPrec :: ConType -> ReadPrec (f p) -> ReadPrec (g p) -> ReadPrec ((f :*: g) p)
productReadPrec :: ConType
-> ReadPrec (f p) -> ReadPrec (g p) -> ReadPrec ((:*:) f g p)
productReadPrec ConType
t ReadPrec (f p)
rpf ReadPrec (g p)
rpg = do
    f p
l <- ReadPrec (f p)
rpf
    case ConType
t of
         ConType
Rec   -> Lexeme -> ReadPrec ()
expectP (String -> Lexeme
Punc String
",")
         Inf String
o -> String -> ReadPrec ()
infixPrec String
o
         ConType
Tup   -> Lexeme -> ReadPrec ()
expectP (String -> Lexeme
Punc String
",")
         ConType
Pref  -> () -> ReadPrec ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    g p
r <- ReadPrec (g p)
rpg
    (:*:) f g p -> ReadPrec ((:*:) f g p)
forall (m :: * -> *) a. Monad m => a -> m a
return (f p
l f p -> g p -> (:*:) f g p
forall k (f :: k -> *) (g :: k -> *) (p :: k).
f p -> g p -> (:*:) f g p
:*: g p
r)
  where
    infixPrec :: String -> ReadPrec ()
    infixPrec :: String -> ReadPrec ()
infixPrec String
o = if String -> Bool
isInfixDataCon String
o
                     then Lexeme -> ReadPrec ()
expectP (String -> Lexeme
Symbol String
o)
                     else (Lexeme -> ReadPrec ()) -> [Lexeme] -> ReadPrec ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Lexeme -> ReadPrec ()
expectP ([Lexeme] -> ReadPrec ()) -> [Lexeme] -> ReadPrec ()
forall a b. (a -> b) -> a -> b
$
                              [String -> Lexeme
Punc String
"`"] [Lexeme] -> [Lexeme] -> [Lexeme]
forall a. [a] -> [a] -> [a]
++ String -> [Lexeme]
identHLexemes String
o [Lexeme] -> [Lexeme] -> [Lexeme]
forall a. [a] -> [a] -> [a]
++ [String -> Lexeme
Punc String
"`"]

#if defined(TRANSFORMERS_FOUR)
instance GRead1Con V4 Par1 where
  gliftReadPrecCon _ V4Read1Args = coercePar1 readPrec

instance Read1 f => GRead1Con V4 (Rec1 f) where
  gliftReadPrecCon _ V4Read1Args = coerceRec1 $ readS_to_Prec readsPrec1

instance (Functor f, Read1 f, GRead1Con V4 g) => GRead1Con V4 (f :.: g) where
  gliftReadPrecCon _ (V4Read1Args :: Read1Args V4 p) =
      coerceComp1 $ fmap (fmap getApply1) $ readS_to_Prec crp1
    where
      crp1 :: Int -> ReadS (f (Apply1 g p))
      crp1 = readsPrec1
#else
instance GRead1Con NonV4 Par1 where
  gliftReadPrecCon :: ConType -> Read1Args NonV4 a -> ReadPrec (Par1 a)
gliftReadPrecCon ConType
_ (NonV4Read1Args ReadPrec a
rp ReadPrec [a]
_) = ReadPrec a -> ReadPrec (Par1 a)
forall p. ReadPrec p -> ReadPrec (Par1 p)
coercePar1 ReadPrec a
rp

instance Read1 f => GRead1Con NonV4 (Rec1 f) where
  gliftReadPrecCon :: ConType -> Read1Args NonV4 a -> ReadPrec (Rec1 f a)
gliftReadPrecCon ConType
_ (NonV4Read1Args ReadPrec a
rp ReadPrec [a]
rl) = ReadPrec (f a) -> ReadPrec (Rec1 f a)
forall (f :: * -> *) a. ReadPrec (f a) -> ReadPrec (Rec1 f a)
coerceRec1 (ReadPrec (f a) -> ReadPrec (Rec1 f a))
-> ReadPrec (f a) -> ReadPrec (Rec1 f a)
forall a b. (a -> b) -> a -> b
$ (Int -> ReadS (f a)) -> ReadPrec (f a)
forall a. (Int -> ReadS a) -> ReadPrec a
readS_to_Prec ((Int -> ReadS (f a)) -> ReadPrec (f a))
-> (Int -> ReadS (f a)) -> ReadPrec (f a)
forall a b. (a -> b) -> a -> b
$
      (Int -> ReadS a) -> ReadS [a] -> Int -> ReadS (f a)
forall (f :: * -> *) a.
Read1 f =>
(Int -> ReadS a) -> ReadS [a] -> Int -> ReadS (f a)
liftReadsPrec (ReadPrec a -> Int -> ReadS a
forall a. ReadPrec a -> Int -> ReadS a
readPrec_to_S ReadPrec a
rp) (ReadPrec [a] -> Int -> ReadS [a]
forall a. ReadPrec a -> Int -> ReadS a
readPrec_to_S ReadPrec [a]
rl Int
0)

instance (Read1 f, GRead1Con NonV4 g) => GRead1Con NonV4 (f :.: g) where
  gliftReadPrecCon :: ConType -> Read1Args NonV4 a -> ReadPrec ((:.:) f g a)
gliftReadPrecCon ConType
t (NonV4Read1Args ReadPrec a
rp ReadPrec [a]
rl) = ReadPrec (f (g a)) -> ReadPrec ((:.:) f g a)
forall (f :: * -> *) (g :: * -> *) a.
ReadPrec (f (g a)) -> ReadPrec ((:.:) f g a)
coerceComp1 (ReadPrec (f (g a)) -> ReadPrec ((:.:) f g a))
-> ReadPrec (f (g a)) -> ReadPrec ((:.:) f g a)
forall a b. (a -> b) -> a -> b
$ (Int -> ReadS (f (g a))) -> ReadPrec (f (g a))
forall a. (Int -> ReadS a) -> ReadPrec a
readS_to_Prec ((Int -> ReadS (f (g a))) -> ReadPrec (f (g a)))
-> (Int -> ReadS (f (g a))) -> ReadPrec (f (g a))
forall a b. (a -> b) -> a -> b
$
      (Int -> ReadS (g a)) -> ReadS [g a] -> Int -> ReadS (f (g a))
forall (f :: * -> *) a.
Read1 f =>
(Int -> ReadS a) -> ReadS [a] -> Int -> ReadS (f a)
liftReadsPrec (ReadPrec (g a) -> Int -> ReadS (g a)
forall a. ReadPrec a -> Int -> ReadS a
readPrec_to_S       ReadPrec (g a)
grpc)
                    (ReadPrec [g a] -> Int -> ReadS [g a]
forall a. ReadPrec a -> Int -> ReadS a
readPrec_to_S (ReadPrec (g a) -> ReadPrec [g a]
forall a. ReadPrec a -> ReadPrec [a]
list ReadPrec (g a)
grpc) Int
0)
    where
      grpc :: ReadPrec (g a)
grpc = ConType -> Read1Args NonV4 a -> ReadPrec (g a)
forall v (f :: * -> *) a.
GRead1Con v f =>
ConType -> Read1Args v a -> ReadPrec (f a)
gliftReadPrecCon ConType
t (ReadPrec a -> ReadPrec [a] -> Read1Args NonV4 a
forall a. ReadPrec a -> ReadPrec [a] -> Read1Args NonV4 a
NonV4Read1Args ReadPrec a
rp ReadPrec [a]
rl)
#endif

-------------------------------------------------------------------------------
-- * Show
-------------------------------------------------------------------------------

-- | A default 'showsPrec' implementation for 'Generic1' instances that leverages
-- 'Show1'.
showsPrecDefault :: (GShow (Rep1 f a), Generic1 f)
                 => Int -> f a -> ShowS
showsPrecDefault :: Int -> f a -> ShowS
showsPrecDefault = Options -> Int -> f a -> ShowS
forall (f :: * -> *) a.
(GShow (Rep1 f a), Generic1 f) =>
Options -> Int -> f a -> ShowS
showsPrecOptions Options
defaultOptions

-- | Like 'showsPrecDefault', but with configurable 'Options'.
showsPrecOptions :: (GShow (Rep1 f a), Generic1 f)
                 => Options -> Int -> f a -> ShowS
showsPrecOptions :: Options -> Int -> f a -> ShowS
showsPrecOptions Options
opts Int
p = Options -> Int -> Rep1 f a -> ShowS
forall a. GShow a => Options -> Int -> a -> ShowS
gshowsPrec Options
opts Int
p (Rep1 f a -> ShowS) -> (f a -> Rep1 f a) -> f a -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. f a -> Rep1 f a
forall k (f :: k -> *) (a :: k). Generic1 f => f a -> Rep1 f a
from1

-- | Class of generic representation types that can be converted to a 'String'.
class GShow a where
  gshowsPrec :: Options -> Int -> a -> ShowS

instance GShow (f p) => GShow (D1 d f p) where
  gshowsPrec :: Options -> Int -> D1 d f p -> ShowS
gshowsPrec Options
opts Int
p (M1 f p
x) = Options -> Int -> f p -> ShowS
forall a. GShow a => Options -> Int -> a -> ShowS
gshowsPrec Options
opts Int
p f p
x

instance GShow (V1 p) where
  gshowsPrec :: Options -> Int -> V1 p -> ShowS
gshowsPrec Options
_ = Int -> V1 p -> ShowS
forall p. Int -> V1 p -> ShowS
v1ShowsPrec

instance (GShow (f p), GShow (g p)) => GShow ((f :+: g) p) where
  gshowsPrec :: Options -> Int -> (:+:) f g p -> ShowS
gshowsPrec Options
opts Int
p (L1 f p
x) = Options -> Int -> f p -> ShowS
forall a. GShow a => Options -> Int -> a -> ShowS
gshowsPrec Options
opts Int
p f p
x
  gshowsPrec Options
opts Int
p (R1 g p
x) = Options -> Int -> g p -> ShowS
forall a. GShow a => Options -> Int -> a -> ShowS
gshowsPrec Options
opts Int
p g p
x

instance (Constructor c, GShowCon (f p), IsNullaryCon f) => GShow (C1 c f p) where
  gshowsPrec :: Options -> Int -> C1 c f p -> ShowS
gshowsPrec Options
opts = (ConType -> Int -> f p -> ShowS) -> Int -> C1 c f p -> ShowS
forall (c :: Meta) (f :: * -> *) p.
(Constructor c, IsNullaryCon f) =>
(ConType -> Int -> f p -> ShowS) -> Int -> C1 c f p -> ShowS
c1ShowsPrec ((ConType -> Int -> f p -> ShowS) -> Int -> C1 c f p -> ShowS)
-> (ConType -> Int -> f p -> ShowS) -> Int -> C1 c f p -> ShowS
forall a b. (a -> b) -> a -> b
$ Options -> ConType -> Int -> f p -> ShowS
forall a. GShowCon a => Options -> ConType -> Int -> a -> ShowS
gshowsPrecCon Options
opts

-- | Class of generic representation types that can be converted to a 'String', and
-- for which the 'ConType' has been determined.
class GShowCon a where
  gshowsPrecCon :: Options -> ConType -> Int -> a -> ShowS

instance GShowCon (U1 p) where
  gshowsPrecCon :: Options -> ConType -> Int -> U1 p -> ShowS
gshowsPrecCon Options
_ ConType
_ Int
_ U1 p
U1 = ShowS
forall a. a -> a
id

instance Show c => GShowCon (K1 i c p) where
  gshowsPrecCon :: Options -> ConType -> Int -> K1 i c p -> ShowS
gshowsPrecCon Options
_ ConType
_ Int
p (K1 c
x) = Int -> c -> ShowS
forall a. Show a => Int -> a -> ShowS
showsPrec Int
p c
x

instance (Selector s, GShowCon (f p)) => GShowCon (S1 s f p) where
  gshowsPrecCon :: Options -> ConType -> Int -> S1 s f p -> ShowS
gshowsPrecCon Options
opts = (Int -> f p -> ShowS) -> Int -> S1 s f p -> ShowS
forall (s :: Meta) (f :: * -> *) p.
Selector s =>
(Int -> f p -> ShowS) -> Int -> S1 s f p -> ShowS
s1ShowsPrec ((Int -> f p -> ShowS) -> Int -> S1 s f p -> ShowS)
-> (ConType -> Int -> f p -> ShowS)
-> ConType
-> Int
-> S1 s f p
-> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Options -> ConType -> Int -> f p -> ShowS
forall a. GShowCon a => Options -> ConType -> Int -> a -> ShowS
gshowsPrecCon Options
opts

instance (GShowCon (f p), GShowCon (g p)) => GShowCon ((f :*: g) p) where
  gshowsPrecCon :: Options -> ConType -> Int -> (:*:) f g p -> ShowS
gshowsPrecCon Options
opts ConType
t =
    (Int -> f p -> ShowS)
-> (Int -> g p -> ShowS) -> ConType -> Int -> (:*:) f g p -> ShowS
forall (f :: * -> *) p (g :: * -> *).
(Int -> f p -> ShowS)
-> (Int -> g p -> ShowS) -> ConType -> Int -> (:*:) f g p -> ShowS
productShowsPrec (Options -> ConType -> Int -> f p -> ShowS
forall a. GShowCon a => Options -> ConType -> Int -> a -> ShowS
gshowsPrecCon Options
opts ConType
t)
                     (Options -> ConType -> Int -> g p -> ShowS
forall a. GShowCon a => Options -> ConType -> Int -> a -> ShowS
gshowsPrecCon Options
opts ConType
t)
                     ConType
t

instance Show p => GShowCon (Par1 p) where
  gshowsPrecCon :: Options -> ConType -> Int -> Par1 p -> ShowS
gshowsPrecCon Options
_ ConType
_ Int
p (Par1 p
x) = Int -> p -> ShowS
forall a. Show a => Int -> a -> ShowS
showsPrec Int
p p
x

#if defined(TRANSFORMERS_FOUR)
instance (Show1 f, Show p) => GShowCon (Rec1 f p) where
  gshowsPrecCon _ _ p (Rec1 x) = showsPrec1 p x

instance (Functor f, Show1 f, GShowCon (g p)) => GShowCon ((f :.: g) p) where
  gshowsPrecCon _ _ p (Comp1 x) = showsPrec1 p (fmap Apply x)
#else
instance (Show1 f, Show p) => GShowCon (Rec1 f p) where
  gshowsPrecCon :: Options -> ConType -> Int -> Rec1 f p -> ShowS
gshowsPrecCon Options
_ ConType
_ Int
p (Rec1 f p
x) = (Int -> p -> ShowS) -> ([p] -> ShowS) -> Int -> f p -> ShowS
forall (f :: * -> *) a.
Show1 f =>
(Int -> a -> ShowS) -> ([a] -> ShowS) -> Int -> f a -> ShowS
liftShowsPrec Int -> p -> ShowS
forall a. Show a => Int -> a -> ShowS
showsPrec [p] -> ShowS
forall a. Show a => [a] -> ShowS
showList Int
p f p
x

instance (Show1 f, GShowCon (g p)) => GShowCon ((f :.: g) p) where
  gshowsPrecCon :: Options -> ConType -> Int -> (:.:) f g p -> ShowS
gshowsPrecCon Options
opts ConType
t Int
p (Comp1 f (g p)
x) =
    let glspc :: Int -> g p -> ShowS
glspc = Options -> ConType -> Int -> g p -> ShowS
forall a. GShowCon a => Options -> ConType -> Int -> a -> ShowS
gshowsPrecCon Options
opts ConType
t
    in (Int -> g p -> ShowS)
-> ([g p] -> ShowS) -> Int -> f (g p) -> ShowS
forall (f :: * -> *) a.
Show1 f =>
(Int -> a -> ShowS) -> ([a] -> ShowS) -> Int -> f a -> ShowS
liftShowsPrec Int -> g p -> ShowS
glspc ((g p -> ShowS) -> [g p] -> ShowS
forall a. (a -> ShowS) -> [a] -> ShowS
showListWith (Int -> g p -> ShowS
glspc Int
0)) Int
p f (g p)
x
#endif

#if MIN_VERSION_base(4,9,0) || defined(GENERIC_DERIVING)
instance GShowCon (UChar p) where
  gshowsPrecCon :: Options -> ConType -> Int -> UChar p -> ShowS
gshowsPrecCon Options
opts ConType
_ = Options -> Int -> UChar p -> ShowS
forall p. Options -> Int -> UChar p -> ShowS
uCharShowsPrec Options
opts

instance GShowCon (UDouble p) where
  gshowsPrecCon :: Options -> ConType -> Int -> UDouble p -> ShowS
gshowsPrecCon Options
opts ConType
_ = Options -> Int -> UDouble p -> ShowS
forall p. Options -> Int -> UDouble p -> ShowS
uDoubleShowsPrec Options
opts

instance GShowCon (UFloat p) where
  gshowsPrecCon :: Options -> ConType -> Int -> UFloat p -> ShowS
gshowsPrecCon Options
opts ConType
_ = Options -> Int -> UFloat p -> ShowS
forall p. Options -> Int -> UFloat p -> ShowS
uFloatShowsPrec Options
opts

instance GShowCon (UInt p) where
  gshowsPrecCon :: Options -> ConType -> Int -> UInt p -> ShowS
gshowsPrecCon Options
opts ConType
_ = Options -> Int -> UInt p -> ShowS
forall p. Options -> Int -> UInt p -> ShowS
uIntShowsPrec Options
opts

instance GShowCon (UWord p) where
  gshowsPrecCon :: Options -> ConType -> Int -> UWord p -> ShowS
gshowsPrecCon Options
opts ConType
_ = Options -> Int -> UWord p -> ShowS
forall p. Options -> Int -> UWord p -> ShowS
uWordShowsPrec Options
opts
#endif

-------------------------------------------------------------------------------
-- * Show1
-------------------------------------------------------------------------------

-- | A 'Show1Args' value either stores a @Show a@ dictionary (for the
-- @transformers-0.4@ version of 'Show1'), or it stores the two function arguments
-- that show occurrences of the type parameter (for the non-@transformers-0.4@
-- version of 'Show1').
data Show1Args v a where
    V4Show1Args    :: Show a                                => Show1Args V4    a
    NonV4Show1Args :: (Int -> a -> ShowS) -> ([a] -> ShowS) -> Show1Args NonV4 a

#if defined(TRANSFORMERS_FOUR)
-- | A sensible default 'showsPrec1' implementation for 'Generic1' instances.
showsPrec1Default :: (GShow1 V4 (Rep1 f), Generic1 f, Show a)
                  => Int -> f a -> ShowS
showsPrec1Default = showsPrec1Options defaultOptions

-- | Like 'showsPrec1Default', but with configurable 'Options'.
showsPrec1Options :: (GShow1 V4 (Rep1 f), Generic1 f, Show a)
                  => Options -> Int -> f a -> ShowS
showsPrec1Options opts p = gliftShowsPrec opts V4Show1Args p . from1
#else
-- | A sensible default 'liftShowsPrec' implementation for 'Generic1' instances.
liftShowsPrecDefault :: (GShow1 NonV4 (Rep1 f), Generic1 f)
                     => (Int -> a -> ShowS) -> ([a] -> ShowS)
                     -> Int -> f a -> ShowS
liftShowsPrecDefault :: (Int -> a -> ShowS) -> ([a] -> ShowS) -> Int -> f a -> ShowS
liftShowsPrecDefault = Options
-> (Int -> a -> ShowS) -> ([a] -> ShowS) -> Int -> f a -> ShowS
forall (f :: * -> *) a.
(GShow1 NonV4 (Rep1 f), Generic1 f) =>
Options
-> (Int -> a -> ShowS) -> ([a] -> ShowS) -> Int -> f a -> ShowS
liftShowsPrecOptions Options
defaultOptions

-- | Like 'liftShowsPrecDefault', but with configurable 'Options'.
liftShowsPrecOptions :: (GShow1 NonV4 (Rep1 f), Generic1 f)
                     => Options -> (Int -> a -> ShowS) -> ([a] -> ShowS)
                     -> Int -> f a -> ShowS
liftShowsPrecOptions :: Options
-> (Int -> a -> ShowS) -> ([a] -> ShowS) -> Int -> f a -> ShowS
liftShowsPrecOptions Options
opts Int -> a -> ShowS
sp [a] -> ShowS
sl Int
p = Options -> Show1Args NonV4 a -> Int -> Rep1 f a -> ShowS
forall v (f :: * -> *) a.
GShow1 v f =>
Options -> Show1Args v a -> Int -> f a -> ShowS
gliftShowsPrec Options
opts ((Int -> a -> ShowS) -> ([a] -> ShowS) -> Show1Args NonV4 a
forall a.
(Int -> a -> ShowS) -> ([a] -> ShowS) -> Show1Args NonV4 a
NonV4Show1Args Int -> a -> ShowS
sp [a] -> ShowS
sl) Int
p (Rep1 f a -> ShowS) -> (f a -> Rep1 f a) -> f a -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. f a -> Rep1 f a
forall k (f :: k -> *) (a :: k). Generic1 f => f a -> Rep1 f a
from1
#endif

-- | Class of generic representation types for unary type constructors that can
-- be converted to a 'String'.
class
#if __GLASGOW_HASKELL__ >= 806
    (forall a. Show a => GShow (f a)) =>
#endif
    GShow1 v f where
  gliftShowsPrec :: Options -> Show1Args v a -> Int -> f a -> ShowS

instance GShow1 v f => GShow1 v (D1 d f) where
  gliftShowsPrec :: Options -> Show1Args v a -> Int -> D1 d f a -> ShowS
gliftShowsPrec Options
opts Show1Args v a
sas Int
p (M1 f a
x) = Options -> Show1Args v a -> Int -> f a -> ShowS
forall v (f :: * -> *) a.
GShow1 v f =>
Options -> Show1Args v a -> Int -> f a -> ShowS
gliftShowsPrec Options
opts Show1Args v a
sas Int
p f a
x

instance GShow1 v V1 where
  gliftShowsPrec :: Options -> Show1Args v a -> Int -> V1 a -> ShowS
gliftShowsPrec Options
_ Show1Args v a
_ = Int -> V1 a -> ShowS
forall p. Int -> V1 p -> ShowS
v1ShowsPrec

v1ShowsPrec :: Int -> V1 p -> ShowS
#if __GLASGOW_HASKELL__ >= 708
v1ShowsPrec :: Int -> V1 p -> ShowS
v1ShowsPrec Int
_ V1 p
_  String
x = case String
x of {}
#else
v1ShowsPrec _ _ !_ = undefined
#endif

instance (GShow1 v f, GShow1 v g) => GShow1 v (f :+: g) where
  gliftShowsPrec :: Options -> Show1Args v a -> Int -> (:+:) f g a -> ShowS
gliftShowsPrec Options
opts Show1Args v a
sas Int
p (L1 f a
x) = Options -> Show1Args v a -> Int -> f a -> ShowS
forall v (f :: * -> *) a.
GShow1 v f =>
Options -> Show1Args v a -> Int -> f a -> ShowS
gliftShowsPrec Options
opts Show1Args v a
sas Int
p f a
x
  gliftShowsPrec Options
opts Show1Args v a
sas Int
p (R1 g a
x) = Options -> Show1Args v a -> Int -> g a -> ShowS
forall v (f :: * -> *) a.
GShow1 v f =>
Options -> Show1Args v a -> Int -> f a -> ShowS
gliftShowsPrec Options
opts Show1Args v a
sas Int
p g a
x

instance (Constructor c, GShow1Con v f, IsNullaryCon f) => GShow1 v (C1 c f) where
  gliftShowsPrec :: Options -> Show1Args v a -> Int -> C1 c f a -> ShowS
gliftShowsPrec Options
opts Show1Args v a
sas = (ConType -> Int -> f a -> ShowS) -> Int -> C1 c f a -> ShowS
forall (c :: Meta) (f :: * -> *) p.
(Constructor c, IsNullaryCon f) =>
(ConType -> Int -> f p -> ShowS) -> Int -> C1 c f p -> ShowS
c1ShowsPrec ((ConType -> Int -> f a -> ShowS) -> Int -> C1 c f a -> ShowS)
-> (ConType -> Int -> f a -> ShowS) -> Int -> C1 c f a -> ShowS
forall a b. (a -> b) -> a -> b
$ \ConType
t -> Options -> ConType -> Show1Args v a -> Int -> f a -> ShowS
forall v (f :: * -> *) a.
GShow1Con v f =>
Options -> ConType -> Show1Args v a -> Int -> f a -> ShowS
gliftShowsPrecCon Options
opts ConType
t Show1Args v a
sas

c1ShowsPrec :: (Constructor c, IsNullaryCon f)
            => (ConType -> Int -> f p -> ShowS) -> Int -> C1 c f p -> ShowS
c1ShowsPrec :: (ConType -> Int -> f p -> ShowS) -> Int -> C1 c f p -> ShowS
c1ShowsPrec ConType -> Int -> f p -> ShowS
sp Int
p c :: C1 c f p
c@(M1 f p
x) = case Fixity
fixity of
    Fixity
Prefix -> Bool -> ShowS -> ShowS
showParen ( Int
p Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
appPrec
                           Bool -> Bool -> Bool
&& Bool -> Bool
not (f p -> Bool
forall (f :: * -> *) a. IsNullaryCon f => f a -> Bool
isNullaryCon f p
x Bool -> Bool -> Bool
|| C1 c f p -> Bool
forall (c :: Meta) (f :: * -> *) p.
Constructor c =>
C1 c f p -> Bool
conIsTuple C1 c f p
c)
                         ) (ShowS -> ShowS) -> ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$
           (if C1 c f p -> Bool
forall (c :: Meta) (f :: * -> *) p.
Constructor c =>
C1 c f p -> Bool
conIsTuple C1 c f p
c
               then ShowS
forall a. a -> a
id
               else let cn :: String
cn = C1 c f p -> String
forall k (c :: k) k1 (t :: k -> (k1 -> *) -> k1 -> *)
       (f :: k1 -> *) (a :: k1).
Constructor c =>
t c f a -> String
conName C1 c f p
c
                    in Bool -> ShowS -> ShowS
showParen (String -> Bool
isInfixDataCon String
cn) (String -> ShowS
showString String
cn))
         ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (if f p -> Bool
forall (f :: * -> *) a. IsNullaryCon f => f a -> Bool
isNullaryCon f p
x Bool -> Bool -> Bool
|| C1 c f p -> Bool
forall (c :: Meta) (f :: * -> *) p.
Constructor c =>
C1 c f p -> Bool
conIsTuple C1 c f p
c
               then ShowS
forall a. a -> a
id
               else Char -> ShowS
showChar Char
' ')
         ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ConType -> ShowS -> ShowS
showBraces ConType
t (ConType -> Int -> f p -> ShowS
sp ConType
t Int
appPrec1 f p
x)
    Infix Associativity
_ Int
m -> Bool -> ShowS -> ShowS
showParen (Int
p Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
m) (ShowS -> ShowS) -> ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ ConType -> Int -> f p -> ShowS
sp ConType
t (Int
mInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) f p
x
  where
    fixity :: Fixity
    fixity :: Fixity
fixity = C1 c f p -> Fixity
forall k (c :: k) k1 (t :: k -> (k1 -> *) -> k1 -> *)
       (f :: k1 -> *) (a :: k1).
Constructor c =>
t c f a -> Fixity
conFixity C1 c f p
c

    t :: ConType
    t :: ConType
t = if C1 c f p -> Bool
forall k (c :: k) k1 (t :: k -> (k1 -> *) -> k1 -> *)
       (f :: k1 -> *) (a :: k1).
Constructor c =>
t c f a -> Bool
conIsRecord C1 c f p
c
        then ConType
Rec
        else case C1 c f p -> Bool
forall (c :: Meta) (f :: * -> *) p.
Constructor c =>
C1 c f p -> Bool
conIsTuple C1 c f p
c of
            Bool
True  -> ConType
Tup
            Bool
False -> case Fixity
fixity of
                Fixity
Prefix    -> ConType
Pref
                Infix Associativity
_ Int
_ -> String -> ConType
Inf (String -> ConType) -> String -> ConType
forall a b. (a -> b) -> a -> b
$ C1 c f p -> String
forall k (c :: k) k1 (t :: k -> (k1 -> *) -> k1 -> *)
       (f :: k1 -> *) (a :: k1).
Constructor c =>
t c f a -> String
conName C1 c f p
c

showBraces :: ConType -> ShowS -> ShowS
showBraces :: ConType -> ShowS -> ShowS
showBraces ConType
Rec     ShowS
b = Char -> ShowS
showChar Char
'{' ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
b ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> ShowS
showChar Char
'}'
showBraces ConType
Tup     ShowS
b = Char -> ShowS
showChar Char
'(' ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
b ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> ShowS
showChar Char
')'
showBraces ConType
Pref    ShowS
b = ShowS
b
showBraces (Inf String
_) ShowS
b = ShowS
b

-- | Class of generic representation types for unary type constructors that can
-- be converted to a 'String', and for which the 'ConType' has been determined.
class
#if __GLASGOW_HASKELL__ >= 806
    (forall a. Show a => GShowCon (f a)) =>
#endif
    GShow1Con v f where
  gliftShowsPrecCon :: Options -> ConType -> Show1Args v a
                    -> Int -> f a -> ShowS

instance GShow1Con v U1 where
  gliftShowsPrecCon :: Options -> ConType -> Show1Args v a -> Int -> U1 a -> ShowS
gliftShowsPrecCon Options
_ ConType
_ Show1Args v a
_ Int
_ U1 a
U1 = ShowS
forall a. a -> a
id

instance Show c => GShow1Con v (K1 i c) where
  gliftShowsPrecCon :: Options -> ConType -> Show1Args v a -> Int -> K1 i c a -> ShowS
gliftShowsPrecCon Options
_ ConType
_ Show1Args v a
_ Int
p (K1 c
x) = Int -> c -> ShowS
forall a. Show a => Int -> a -> ShowS
showsPrec Int
p c
x

instance (Selector s, GShow1Con v f) => GShow1Con v (S1 s f) where
  gliftShowsPrecCon :: Options -> ConType -> Show1Args v a -> Int -> S1 s f a -> ShowS
gliftShowsPrecCon Options
opts ConType
t Show1Args v a
sas = (Int -> f a -> ShowS) -> Int -> S1 s f a -> ShowS
forall (s :: Meta) (f :: * -> *) p.
Selector s =>
(Int -> f p -> ShowS) -> Int -> S1 s f p -> ShowS
s1ShowsPrec ((Int -> f a -> ShowS) -> Int -> S1 s f a -> ShowS)
-> (Int -> f a -> ShowS) -> Int -> S1 s f a -> ShowS
forall a b. (a -> b) -> a -> b
$ Options -> ConType -> Show1Args v a -> Int -> f a -> ShowS
forall v (f :: * -> *) a.
GShow1Con v f =>
Options -> ConType -> Show1Args v a -> Int -> f a -> ShowS
gliftShowsPrecCon Options
opts ConType
t Show1Args v a
sas

s1ShowsPrec :: Selector s => (Int -> f p -> ShowS) -> Int -> S1 s f p -> ShowS
s1ShowsPrec :: (Int -> f p -> ShowS) -> Int -> S1 s f p -> ShowS
s1ShowsPrec Int -> f p -> ShowS
sp Int
p sel :: S1 s f p
sel@(M1 f p
x)
  | S1 s f p -> String
forall k (s :: k) k1 (t :: k -> (k1 -> *) -> k1 -> *)
       (f :: k1 -> *) (a :: k1).
Selector s =>
t s f a -> String
selName S1 s f p
sel String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"" =   Int -> f p -> ShowS
sp Int
p f p
x
  | Bool
otherwise         =   ShowS
infixRec
                        ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
" = "
                        ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> f p -> ShowS
sp Int
0 f p
x
  where
    infixRec :: ShowS
    infixRec :: ShowS
infixRec | String -> Bool
isSymVar String
selectorName
             = Char -> ShowS
showChar Char
'(' ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
selectorName ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> ShowS
showChar Char
')'
             | Bool
otherwise
             = String -> ShowS
showString String
selectorName

    selectorName :: String
    selectorName :: String
selectorName = S1 s f p -> String
forall k (s :: k) k1 (t :: k -> (k1 -> *) -> k1 -> *)
       (f :: k1 -> *) (a :: k1).
Selector s =>
t s f a -> String
selName S1 s f p
sel

instance (GShow1Con v f, GShow1Con v g) => GShow1Con v (f :*: g) where
  gliftShowsPrecCon :: Options -> ConType -> Show1Args v a -> Int -> (:*:) f g a -> ShowS
gliftShowsPrecCon Options
opts ConType
t Show1Args v a
sas =
    (Int -> f a -> ShowS)
-> (Int -> g a -> ShowS) -> ConType -> Int -> (:*:) f g a -> ShowS
forall (f :: * -> *) p (g :: * -> *).
(Int -> f p -> ShowS)
-> (Int -> g p -> ShowS) -> ConType -> Int -> (:*:) f g p -> ShowS
productShowsPrec (Options -> ConType -> Show1Args v a -> Int -> f a -> ShowS
forall v (f :: * -> *) a.
GShow1Con v f =>
Options -> ConType -> Show1Args v a -> Int -> f a -> ShowS
gliftShowsPrecCon Options
opts ConType
t Show1Args v a
sas)
                     (Options -> ConType -> Show1Args v a -> Int -> g a -> ShowS
forall v (f :: * -> *) a.
GShow1Con v f =>
Options -> ConType -> Show1Args v a -> Int -> f a -> ShowS
gliftShowsPrecCon Options
opts ConType
t Show1Args v a
sas)
                     ConType
t

productShowsPrec :: (Int -> f p -> ShowS) -> (Int -> g p -> ShowS)
                 -> ConType -> Int -> (f :*: g) p -> ShowS
productShowsPrec :: (Int -> f p -> ShowS)
-> (Int -> g p -> ShowS) -> ConType -> Int -> (:*:) f g p -> ShowS
productShowsPrec Int -> f p -> ShowS
spf Int -> g p -> ShowS
spg ConType
t Int
p (f p
a :*: g p
b) =
  case ConType
t of
       ConType
Rec ->     Int -> f p -> ShowS
spf Int
0 f p
a
                ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
", "
                ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> g p -> ShowS
spg Int
0 g p
b

       Inf String
o ->   Int -> f p -> ShowS
spf Int
p f p
a
                ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
showSpace
                ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
infixOp String
o
                ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
showSpace
                ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> g p -> ShowS
spg Int
p g p
b

       ConType
Tup ->     Int -> f p -> ShowS
spf Int
0 f p
a
                ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> ShowS
showChar Char
','
                ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> g p -> ShowS
spg Int
0 g p
b

       ConType
Pref ->    Int -> f p -> ShowS
spf Int
p f p
a
                ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
showSpace
                ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> g p -> ShowS
spg Int
p g p
b
  where
    infixOp :: String -> ShowS
    infixOp :: String -> ShowS
infixOp String
o = if String -> Bool
isInfixDataCon String
o
                   then String -> ShowS
showString String
o
                   else Char -> ShowS
showChar Char
'`' ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
o ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> ShowS
showChar Char
'`'

#if defined(TRANSFORMERS_FOUR)
instance GShow1Con V4 Par1 where
  gliftShowsPrecCon _ _ V4Show1Args p (Par1 x) = showsPrec p x

instance Show1 f => GShow1Con V4 (Rec1 f) where
  gliftShowsPrecCon _ _ V4Show1Args p (Rec1 x) = showsPrec1 p x

instance (Functor f, Show1 f, GShow1Con V4 g) => GShow1Con V4 (f :.: g) where
  gliftShowsPrecCon _ _ V4Show1Args p (Comp1 x) = showsPrec1 p (fmap Apply1 x)
#else
instance GShow1Con NonV4 Par1 where
  gliftShowsPrecCon :: Options -> ConType -> Show1Args NonV4 a -> Int -> Par1 a -> ShowS
gliftShowsPrecCon Options
_ ConType
_ (NonV4Show1Args Int -> a -> ShowS
sp [a] -> ShowS
_) Int
p (Par1 a
x) = Int -> a -> ShowS
sp Int
p a
x

instance Show1 f => GShow1Con NonV4 (Rec1 f) where
  gliftShowsPrecCon :: Options -> ConType -> Show1Args NonV4 a -> Int -> Rec1 f a -> ShowS
gliftShowsPrecCon Options
_ ConType
_ (NonV4Show1Args Int -> a -> ShowS
sp [a] -> ShowS
sl) Int
p (Rec1 f a
x) = (Int -> a -> ShowS) -> ([a] -> ShowS) -> Int -> f a -> ShowS
forall (f :: * -> *) a.
Show1 f =>
(Int -> a -> ShowS) -> ([a] -> ShowS) -> Int -> f a -> ShowS
liftShowsPrec Int -> a -> ShowS
sp [a] -> ShowS
sl Int
p f a
x

instance (Show1 f, GShow1Con NonV4 g) => GShow1Con NonV4 (f :.: g) where
  gliftShowsPrecCon :: Options
-> ConType -> Show1Args NonV4 a -> Int -> (:.:) f g a -> ShowS
gliftShowsPrecCon Options
opts ConType
t (NonV4Show1Args Int -> a -> ShowS
sp [a] -> ShowS
sl) Int
p (Comp1 f (g a)
x) =
    let glspc :: Int -> g a -> ShowS
glspc = Options -> ConType -> Show1Args NonV4 a -> Int -> g a -> ShowS
forall v (f :: * -> *) a.
GShow1Con v f =>
Options -> ConType -> Show1Args v a -> Int -> f a -> ShowS
gliftShowsPrecCon Options
opts ConType
t ((Int -> a -> ShowS) -> ([a] -> ShowS) -> Show1Args NonV4 a
forall a.
(Int -> a -> ShowS) -> ([a] -> ShowS) -> Show1Args NonV4 a
NonV4Show1Args Int -> a -> ShowS
sp [a] -> ShowS
sl)
    in (Int -> g a -> ShowS)
-> ([g a] -> ShowS) -> Int -> f (g a) -> ShowS
forall (f :: * -> *) a.
Show1 f =>
(Int -> a -> ShowS) -> ([a] -> ShowS) -> Int -> f a -> ShowS
liftShowsPrec Int -> g a -> ShowS
glspc ((g a -> ShowS) -> [g a] -> ShowS
forall a. (a -> ShowS) -> [a] -> ShowS
showListWith (Int -> g a -> ShowS
glspc Int
0)) Int
p f (g a)
x
#endif

#if MIN_VERSION_base(4,9,0) || defined(GENERIC_DERIVING)
instance GShow1Con v UChar where
  gliftShowsPrecCon :: Options -> ConType -> Show1Args v a -> Int -> UChar a -> ShowS
gliftShowsPrecCon Options
opts ConType
_ Show1Args v a
_ = Options -> Int -> UChar a -> ShowS
forall p. Options -> Int -> UChar p -> ShowS
uCharShowsPrec Options
opts

instance GShow1Con v UDouble where
  gliftShowsPrecCon :: Options -> ConType -> Show1Args v a -> Int -> UDouble a -> ShowS
gliftShowsPrecCon Options
opts ConType
_ Show1Args v a
_ = Options -> Int -> UDouble a -> ShowS
forall p. Options -> Int -> UDouble p -> ShowS
uDoubleShowsPrec Options
opts

instance GShow1Con v UFloat where
  gliftShowsPrecCon :: Options -> ConType -> Show1Args v a -> Int -> UFloat a -> ShowS
gliftShowsPrecCon Options
opts ConType
_ Show1Args v a
_ = Options -> Int -> UFloat a -> ShowS
forall p. Options -> Int -> UFloat p -> ShowS
uFloatShowsPrec Options
opts

instance GShow1Con v UInt where
  gliftShowsPrecCon :: Options -> ConType -> Show1Args v a -> Int -> UInt a -> ShowS
gliftShowsPrecCon Options
opts ConType
_ Show1Args v a
_ = Options -> Int -> UInt a -> ShowS
forall p. Options -> Int -> UInt p -> ShowS
uIntShowsPrec Options
opts

instance GShow1Con v UWord where
  gliftShowsPrecCon :: Options -> ConType -> Show1Args v a -> Int -> UWord a -> ShowS
gliftShowsPrecCon Options
opts ConType
_ Show1Args v a
_ = Options -> Int -> UWord a -> ShowS
forall p. Options -> Int -> UWord p -> ShowS
uWordShowsPrec Options
opts

uCharShowsPrec :: Options -> Int -> UChar p -> ShowS
uCharShowsPrec :: Options -> Int -> UChar p -> ShowS
uCharShowsPrec Options
opts Int
p (UChar c) =
  Int -> Char -> ShowS
forall a. Show a => Int -> a -> ShowS
showsPrec (Options -> Int -> Int
hashPrec Options
opts Int
p) (Char# -> Char
C# Char#
c) ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Options -> ShowS
oneHash Options
opts

uDoubleShowsPrec :: Options -> Int -> UDouble p -> ShowS
uDoubleShowsPrec :: Options -> Int -> UDouble p -> ShowS
uDoubleShowsPrec Options
opts Int
p (UDouble d) =
  Int -> Double -> ShowS
forall a. Show a => Int -> a -> ShowS
showsPrec (Options -> Int -> Int
hashPrec Options
opts Int
p) (Double# -> Double
D# Double#
d) ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Options -> ShowS
twoHash Options
opts

uFloatShowsPrec :: Options -> Int -> UFloat p -> ShowS
uFloatShowsPrec :: Options -> Int -> UFloat p -> ShowS
uFloatShowsPrec Options
opts Int
p (UFloat f) =
  Int -> Float -> ShowS
forall a. Show a => Int -> a -> ShowS
showsPrec (Options -> Int -> Int
hashPrec Options
opts Int
p) (Float# -> Float
F# Float#
f) ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Options -> ShowS
oneHash Options
opts

uIntShowsPrec :: Options -> Int -> UInt p -> ShowS
uIntShowsPrec :: Options -> Int -> UInt p -> ShowS
uIntShowsPrec Options
opts Int
p (UInt i) =
  Int -> Int -> ShowS
forall a. Show a => Int -> a -> ShowS
showsPrec (Options -> Int -> Int
hashPrec Options
opts Int
p) (Int# -> Int
I# Int#
i) ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Options -> ShowS
oneHash Options
opts

uWordShowsPrec :: Options -> Int -> UWord p -> ShowS
uWordShowsPrec :: Options -> Int -> UWord p -> ShowS
uWordShowsPrec Options
opts Int
p (UWord w) =
  Int -> Word -> ShowS
forall a. Show a => Int -> a -> ShowS
showsPrec (Options -> Int -> Int
hashPrec Options
opts Int
p) (Word# -> Word
W# Word#
w) ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Options -> ShowS
twoHash Options
opts

oneHash, twoHash :: Options -> ShowS
hashPrec         :: Options -> Int -> Int
oneHash :: Options -> ShowS
oneHash  Options
opts = if Options -> Bool
ghc8ShowBehavior Options
opts then Char -> ShowS
showChar   Char
'#'  else ShowS
forall a. a -> a
id
twoHash :: Options -> ShowS
twoHash  Options
opts = if Options -> Bool
ghc8ShowBehavior Options
opts then String -> ShowS
showString String
"##" else ShowS
forall a. a -> a
id
hashPrec :: Options -> Int -> Int
hashPrec Options
opts = if Options -> Bool
ghc8ShowBehavior Options
opts then Int -> Int -> Int
forall a b. a -> b -> a
const Int
0         else Int -> Int
forall a. a -> a
id
#endif

-------------------------------------------------------------------------------
-- * GenericFunctorClasses
-------------------------------------------------------------------------------

-- | An adapter newtype, suitable for @DerivingVia@. Its 'Eq1', 'Ord1',
-- 'Read1', and 'Show1' instances leverage 'Generic1'-based defaults.
newtype FunctorClassesDefault f a =
  FunctorClassesDefault { FunctorClassesDefault f a -> f a
getFunctorClassesDefault :: f a }

#if defined(TRANSFORMERS_FOUR)
instance (GEq1 V4 (Rep1 f), Generic1 f) => Eq1 (FunctorClassesDefault f) where
   eq1 (FunctorClassesDefault x) (FunctorClassesDefault y) = eq1Default x y
instance (GOrd1 V4 (Rep1 f), Generic1 f) => Ord1 (FunctorClassesDefault f) where
   compare1 (FunctorClassesDefault x) (FunctorClassesDefault y) = compare1Default x y
instance (GRead1 V4 (Rep1 f), Generic1 f) => Read1 (FunctorClassesDefault f) where
   readsPrec1 p = coerceFCD (readsPrec1Default p)
instance (GShow1 V4 (Rep1 f), Generic1 f) => Show1 (FunctorClassesDefault f) where
   showsPrec1 p (FunctorClassesDefault x) = showsPrec1Default p x
#else
instance (GEq1 NonV4 (Rep1 f), Generic1 f) => Eq1 (FunctorClassesDefault f) where
   liftEq :: (a -> b -> Bool)
-> FunctorClassesDefault f a -> FunctorClassesDefault f b -> Bool
liftEq a -> b -> Bool
f (FunctorClassesDefault f a
x) (FunctorClassesDefault f b
y) = (a -> b -> Bool) -> f a -> f b -> Bool
forall (f :: * -> *) a b.
(GEq1 NonV4 (Rep1 f), Generic1 f) =>
(a -> b -> Bool) -> f a -> f b -> Bool
liftEqDefault a -> b -> Bool
f f a
x f b
y
instance (GOrd1 NonV4 (Rep1 f), Generic1 f) => Ord1 (FunctorClassesDefault f) where
   liftCompare :: (a -> b -> Ordering)
-> FunctorClassesDefault f a
-> FunctorClassesDefault f b
-> Ordering
liftCompare a -> b -> Ordering
f (FunctorClassesDefault f a
x) (FunctorClassesDefault f b
y) = (a -> b -> Ordering) -> f a -> f b -> Ordering
forall (f :: * -> *) a b.
(GOrd1 NonV4 (Rep1 f), Generic1 f) =>
(a -> b -> Ordering) -> f a -> f b -> Ordering
liftCompareDefault a -> b -> Ordering
f f a
x f b
y
instance (GRead1 NonV4 (Rep1 f), Generic1 f) => Read1 (FunctorClassesDefault f) where
   liftReadsPrec :: (Int -> ReadS a)
-> ReadS [a] -> Int -> ReadS (FunctorClassesDefault f a)
liftReadsPrec Int -> ReadS a
rp ReadS [a]
rl Int
p = ReadS (f a) -> ReadS (FunctorClassesDefault f a)
forall (f :: * -> *) a.
ReadS (f a) -> ReadS (FunctorClassesDefault f a)
coerceFCD ((Int -> ReadS a) -> ReadS [a] -> Int -> ReadS (f a)
forall (f :: * -> *) a.
(GRead1 NonV4 (Rep1 f), Generic1 f) =>
(Int -> ReadS a) -> ReadS [a] -> Int -> ReadS (f a)
liftReadsPrecDefault Int -> ReadS a
rp ReadS [a]
rl Int
p)
instance (GShow1 NonV4 (Rep1 f), Generic1 f) => Show1 (FunctorClassesDefault f) where
   liftShowsPrec :: (Int -> a -> ShowS)
-> ([a] -> ShowS) -> Int -> FunctorClassesDefault f a -> ShowS
liftShowsPrec Int -> a -> ShowS
sp [a] -> ShowS
sl Int
p (FunctorClassesDefault f a
x) = (Int -> a -> ShowS) -> ([a] -> ShowS) -> Int -> f a -> ShowS
forall (f :: * -> *) a.
(GShow1 NonV4 (Rep1 f), Generic1 f) =>
(Int -> a -> ShowS) -> ([a] -> ShowS) -> Int -> f a -> ShowS
liftShowsPrecDefault Int -> a -> ShowS
sp [a] -> ShowS
sl Int
p f a
x
#endif

instance (GEq (Rep1 f a), Generic1 f) => Eq (FunctorClassesDefault f a) where
  FunctorClassesDefault f a
x == :: FunctorClassesDefault f a -> FunctorClassesDefault f a -> Bool
== FunctorClassesDefault f a
y = f a -> f a -> Bool
forall (f :: * -> *) a.
(GEq (Rep1 f a), Generic1 f) =>
f a -> f a -> Bool
eqDefault f a
x f a
y
instance (GOrd (Rep1 f a), Generic1 f) => Ord (FunctorClassesDefault f a) where
  compare :: FunctorClassesDefault f a -> FunctorClassesDefault f a -> Ordering
compare (FunctorClassesDefault f a
x) (FunctorClassesDefault f a
y) = f a -> f a -> Ordering
forall (f :: * -> *) a.
(GOrd (Rep1 f a), Generic1 f) =>
f a -> f a -> Ordering
compareDefault f a
x f a
y
instance (GRead (Rep1 f a), Generic1 f) => Read (FunctorClassesDefault f a) where
  readsPrec :: Int -> ReadS (FunctorClassesDefault f a)
readsPrec Int
p = ReadS (f a) -> ReadS (FunctorClassesDefault f a)
forall (f :: * -> *) a.
ReadS (f a) -> ReadS (FunctorClassesDefault f a)
coerceFCD (Int -> ReadS (f a)
forall (f :: * -> *) a.
(GRead (Rep1 f a), Generic1 f) =>
Int -> ReadS (f a)
readsPrecDefault Int
p)
instance (GShow (Rep1 f a), Generic1 f) => Show (FunctorClassesDefault f a) where
  showsPrec :: Int -> FunctorClassesDefault f a -> ShowS
showsPrec Int
p (FunctorClassesDefault f a
x) = Int -> f a -> ShowS
forall (f :: * -> *) a.
(GShow (Rep1 f a), Generic1 f) =>
Int -> f a -> ShowS
showsPrecDefault Int
p f a
x

coerceFCD :: ReadS (f a) -> ReadS (FunctorClassesDefault f a)
coerceFCD :: ReadS (f a) -> ReadS (FunctorClassesDefault f a)
coerceFCD = ReadS (f a) -> ReadS (FunctorClassesDefault f a)
coerce

-------------------------------------------------------------------------------
-- * Shared code
-------------------------------------------------------------------------------

#if defined(TRANSFORMERS_FOUR)
newtype Apply  g a = Apply  { getApply  :: g a }
newtype Apply1 g a = Apply1 { getApply1 :: g a }

instance GEq (g a) => Eq (Apply g a) where
    Apply x == Apply y = geq x y
instance (GEq1 V4 g, Eq a) => Eq (Apply1 g a) where
    Apply1 x == Apply1 y = gliftEq V4Eq1Args x y

instance GOrd (g a) => Ord (Apply g a) where
    compare (Apply x) (Apply y) = gcompare x y
instance (GOrd1 V4 g, Ord a) => Ord (Apply1 g a) where
    compare (Apply1 x) (Apply1 y) = gliftCompare V4Ord1Args x y

-- Passing defaultOptions and Pref below is OK, since it's guaranteed that the
-- Options and ConType won't actually have any effect on how (g a) is shown.
-- If we augment Options or ConType with more features in the future, this
-- decision will need to be revisited.

instance GReadCon (g a) => Read (Apply g a) where
    readPrec = fmap Apply $ greadPrecCon Pref
instance (GRead1Con V4 g, Read a) => Read (Apply1 g a) where
    readPrec = fmap Apply1 $ gliftReadPrecCon Pref V4Read1Args

instance GShowCon (g a) => Show (Apply g a) where
    showsPrec d = gshowsPrecCon defaultOptions Pref d . getApply
instance (GShow1Con V4 g, Show a) => Show (Apply1 g a) where
    showsPrec d = gliftShowsPrecCon defaultOptions Pref V4Show1Args d . getApply1
#endif

-- | Whether a constructor is a record ('Rec'), a tuple ('Tup'), is prefix ('Pref'),
-- or infix ('Inf').
data ConType = Rec | Tup | Pref | Inf String

conIsTuple :: Constructor c => C1 c f p -> Bool
conIsTuple :: C1 c f p -> Bool
conIsTuple = String -> Bool
isTupleString (String -> Bool) -> (C1 c f p -> String) -> C1 c f p -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. C1 c f p -> String
forall k (c :: k) k1 (t :: k -> (k1 -> *) -> k1 -> *)
       (f :: k1 -> *) (a :: k1).
Constructor c =>
t c f a -> String
conName

isTupleString :: String -> Bool
isTupleString :: String -> Bool
isTupleString (Char
'(':Char
',':String
_) = Bool
True
isTupleString String
_           = Bool
False

isInfixDataCon :: String -> Bool
isInfixDataCon :: String -> Bool
isInfixDataCon (Char
':':String
_) = Bool
True
isInfixDataCon String
_       = Bool
False

-- | Class of generic representation types that represent a data type with
-- zero or more constructors.
class IsNullaryDataType f where
    -- | Returns 'True' if the data type has no constructors.
    isNullaryDataType :: f a -> Bool

instance IsNullaryDataType (f :+: g) where
    isNullaryDataType :: (:+:) f g a -> Bool
isNullaryDataType (:+:) f g a
_ = Bool
False

instance IsNullaryDataType (C1 c f) where
    isNullaryDataType :: C1 c f a -> Bool
isNullaryDataType C1 c f a
_ = Bool
False

-- | Class of generic representation types that represent a constructor with
-- zero or more fields.
class IsNullaryCon f where
    -- | Returns 'True' if the constructor has no fields.
    isNullaryCon :: f a -> Bool

instance IsNullaryDataType V1 where
    isNullaryDataType :: V1 a -> Bool
isNullaryDataType V1 a
_ = Bool
True

instance IsNullaryCon U1 where
    isNullaryCon :: U1 a -> Bool
isNullaryCon U1 a
_ = Bool
True

instance IsNullaryCon Par1 where
    isNullaryCon :: Par1 a -> Bool
isNullaryCon Par1 a
_ = Bool
False

instance IsNullaryCon (K1 i c) where
    isNullaryCon :: K1 i c a -> Bool
isNullaryCon K1 i c a
_ = Bool
False

instance IsNullaryCon f => IsNullaryCon (S1 s f) where
    isNullaryCon :: S1 s f a -> Bool
isNullaryCon (M1 f a
x) = f a -> Bool
forall (f :: * -> *) a. IsNullaryCon f => f a -> Bool
isNullaryCon f a
x

instance IsNullaryCon (Rec1 f) where
    isNullaryCon :: Rec1 f a -> Bool
isNullaryCon Rec1 f a
_ = Bool
False

instance IsNullaryCon (f :*: g) where
    isNullaryCon :: (:*:) f g a -> Bool
isNullaryCon (:*:) f g a
_ = Bool
False

instance IsNullaryCon (f :.: g) where
    isNullaryCon :: (:.:) f g a -> Bool
isNullaryCon (:.:) f g a
_ = Bool
False

#if MIN_VERSION_base(4,9,0) || defined(GENERIC_DERIVING)
instance IsNullaryCon UChar where
    isNullaryCon :: UChar a -> Bool
isNullaryCon UChar a
_ = Bool
False

instance IsNullaryCon UDouble where
    isNullaryCon :: UDouble a -> Bool
isNullaryCon UDouble a
_ = Bool
False

instance IsNullaryCon UFloat where
    isNullaryCon :: UFloat a -> Bool
isNullaryCon UFloat a
_ = Bool
False

instance IsNullaryCon UInt where
    isNullaryCon :: UInt a -> Bool
isNullaryCon UInt a
_ = Bool
False

instance IsNullaryCon UWord where
    isNullaryCon :: UWord a -> Bool
isNullaryCon UWord a
_ = Bool
False

# if __GLASGOW_HASKELL__ < 708
isTrue# :: Bool -> Bool
isTrue# = id
# endif
#endif