{-# 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

{-|
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(..)
    -- * '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

-------------------------------------------------------------------------------
-- * 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 be checked for equality.
class 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 Apply m) (fmap Apply 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 a1) (UAddr a2) = Int# -> Bool
isTrue# (Addr# -> Addr# -> Int#
eqAddr# Addr#
a1 Addr#
a2)

instance GEq1 v UChar where
  gliftEq :: Eq1Args v a b -> UChar a -> UChar b -> Bool
gliftEq Eq1Args v a b
_ (UChar c1) (UChar c2) = Int# -> Bool
isTrue# (Char# -> Char# -> Int#
eqChar# Char#
c1 Char#
c2)

instance GEq1 v UDouble where
  gliftEq :: Eq1Args v a b -> UDouble a -> UDouble b -> Bool
gliftEq Eq1Args v a b
_ (UDouble d1) (UDouble d2) = Int# -> Bool
isTrue# (Double#
d1 Double# -> Double# -> Int#
==## Double#
d2)

instance GEq1 v UFloat where
  gliftEq :: Eq1Args v a b -> UFloat a -> UFloat b -> Bool
gliftEq Eq1Args v a b
_ (UFloat f1) (UFloat f2) = Int# -> Bool
isTrue# (Float# -> Float# -> Int#
eqFloat# Float#
f1 Float#
f2)

instance GEq1 v UInt where
  gliftEq :: Eq1Args v a b -> UInt a -> UInt b -> Bool
gliftEq Eq1Args v a b
_ (UInt i1) (UInt i2) = Int# -> Bool
isTrue# (Int#
i1 Int# -> Int# -> Int#
==# Int#
i2)

instance GEq1 v UWord where
  gliftEq :: Eq1Args v a b -> UWord a -> UWord b -> Bool
gliftEq Eq1Args v a b
_ (UWord w1) (UWord w2) = Int# -> Bool
isTrue# (Word# -> Word# -> Int#
eqWord# Word#
w1 Word#
w2)
#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 be totally ordered.
class GEq1 v t => 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 Apply m) (fmap Apply 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 a1) (UAddr a2) = Int# -> Int# -> Ordering
primCompare (Addr# -> Addr# -> Int#
eqAddr# Addr#
a1 Addr#
a2) (Addr# -> Addr# -> Int#
leAddr# Addr#
a1 Addr#
a2)

instance GOrd1 v UChar where
  gliftCompare :: Ord1Args v a b -> UChar a -> UChar b -> Ordering
gliftCompare Ord1Args v a b
_ (UChar c1) (UChar c2) = Int# -> Int# -> Ordering
primCompare (Char# -> Char# -> Int#
eqChar# Char#
c1 Char#
c2) (Char# -> Char# -> Int#
leChar# Char#
c1 Char#
c2)

instance GOrd1 v UDouble where
  gliftCompare :: Ord1Args v a b -> UDouble a -> UDouble b -> Ordering
gliftCompare Ord1Args v a b
_ (UDouble d1) (UDouble d2) = Int# -> Int# -> Ordering
primCompare (Double#
d1 Double# -> Double# -> Int#
==## Double#
d2) (Double#
d1 Double# -> Double# -> Int#
<=## Double#
d2)

instance GOrd1 v UFloat where
  gliftCompare :: Ord1Args v a b -> UFloat a -> UFloat b -> Ordering
gliftCompare Ord1Args v a b
_ (UFloat f1) (UFloat f2) = Int# -> Int# -> Ordering
primCompare (Float# -> Float# -> Int#
eqFloat# Float#
f1 Float#
f2) (Float# -> Float# -> Int#
leFloat# Float#
f1 Float#
f2)

instance GOrd1 v UInt where
  gliftCompare :: Ord1Args v a b -> UInt a -> UInt b -> Ordering
gliftCompare Ord1Args v a b
_ (UInt i1) (UInt i2) = Int# -> Int# -> Ordering
primCompare (Int#
i1 Int# -> Int# -> Int#
==# Int#
i2) (Int#
i1 Int# -> Int# -> Int#
<=# Int#
i2)

instance GOrd1 v UWord where
  gliftCompare :: Ord1Args v a b -> UWord a -> UWord b -> Ordering
gliftCompare Ord1Args v a b
_ (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

-------------------------------------------------------------------------------
-- * 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

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 that can be parsed from a 'String'.
class 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 (f :: * -> *) p i (c :: Meta).
ReadPrec (f p) -> ReadPrec (M1 i c f p)
coerceM1 (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
. ReadPrec (f a) -> ReadPrec (f a)
forall a. ReadPrec a -> ReadPrec a
parensIfNonNullary (ReadPrec (f a) -> ReadPrec (f a))
-> (Read1Args v a -> ReadPrec (f a))
-> Read1Args v a
-> ReadPrec (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
    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 Any -> Bool
forall (f :: * -> *) a. IsNullaryDataType f => f a -> Bool
isNullaryDataType f Any
forall p. 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 = ReadPrec (f a) -> ReadPrec (C1 c f a)
forall (f :: * -> *) p i (c :: Meta).
ReadPrec (f p) -> ReadPrec (M1 i c f p)
coerceM1 (ReadPrec (f a) -> ReadPrec (C1 c f a))
-> ReadPrec (f a) -> ReadPrec (C1 c f a)
forall a b. (a -> b) -> a -> b
$ case Fixity
fixity of
      Fixity
Prefix -> ReadPrec (f a) -> ReadPrec (f a)
forall a. ReadPrec a -> ReadPrec a
precIfNonNullary (ReadPrec (f a) -> ReadPrec (f a))
-> ReadPrec (f a) -> ReadPrec (f a)
forall a b. (a -> b) -> a -> b
$ do
                  if C1 c f Any -> Bool
forall (c :: Meta) (f :: * -> *) p.
Constructor c =>
C1 c f p -> Bool
conIsTuple C1 c f Any
forall p. C1 c f p
c
                     then () -> ReadPrec ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
                     else let cn :: String
cn = C1 c f Any -> 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 Any
forall p. 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 a) -> ReadPrec (f a)
forall a. ConType -> ReadPrec a -> ReadPrec a
readBraces 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)
      Infix Associativity
_ Int
m -> Int -> ReadPrec (f a) -> ReadPrec (f a)
forall a. Int -> ReadPrec a -> ReadPrec a
prec Int
m (ReadPrec (f a) -> ReadPrec (f a))
-> ReadPrec (f a) -> ReadPrec (f a)
forall a b. (a -> b) -> a -> b
$ 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
    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 Any -> 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 Any
forall p. C1 c f p
c

      precIfNonNullary :: ReadPrec a -> ReadPrec a
      precIfNonNullary :: ReadPrec a -> ReadPrec a
precIfNonNullary = if f Any -> Bool
forall (f :: * -> *) a. IsNullaryCon f => f a -> Bool
isNullaryCon f Any
forall p. 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 Any -> 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 Any
forall p. C1 c f p
c
                                          then Int
appPrec1
                                          else Int
appPrec)

      t :: ConType
      t :: ConType
t = if C1 c f Any -> 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 Any
forall p. C1 c f p
c
          then ConType
Rec
          else case C1 c f Any -> Bool
forall (c :: Meta) (f :: * -> *) p.
Constructor c =>
C1 c f p -> Bool
conIsTuple C1 c f Any
forall p. 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 Any -> 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 Any
forall p. 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 that can be parsed from a 'String', and
-- for which the 'ConType' has been determined.
class 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 p. ReadPrec c -> ReadPrec (K1 i c p)
coerceK1 ReadPrec c
forall a. Read a => ReadPrec a
readPrec
    where
      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

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 Read1Args v a
ras
    | String
selectorName String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"" = ReadPrec (f a) -> ReadPrec (S1 s f a)
forall (f :: * -> *) p i (c :: Meta).
ReadPrec (f p) -> ReadPrec (M1 i c f p)
coerceM1 (ReadPrec (f a) -> ReadPrec (S1 s f a))
-> ReadPrec (f a) -> ReadPrec (S1 s f a)
forall a b. (a -> b) -> a -> b
$ ReadPrec (f a) -> ReadPrec (f a)
forall a. ReadPrec a -> ReadPrec a
step (ReadPrec (f a) -> ReadPrec (f a))
-> ReadPrec (f a) -> ReadPrec (f a)
forall a b. (a -> b) -> a -> b
$ 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
    | Bool
otherwise          = ReadPrec (f a) -> ReadPrec (S1 s f a)
forall (f :: * -> *) p i (c :: Meta).
ReadPrec (f p) -> ReadPrec (M1 i c f p)
coerceM1 (ReadPrec (f a) -> ReadPrec (S1 s f a))
-> ReadPrec (f a) -> ReadPrec (S1 s f a)
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 a) -> ReadPrec (f a)
forall a. ReadPrec a -> ReadPrec a
reset (ReadPrec (f a) -> ReadPrec (f a))
-> ReadPrec (f a) -> ReadPrec (f a)
forall a b. (a -> b) -> a -> b
$ 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
    where
      selectorName :: String
      selectorName :: String
selectorName = M1 S s f Any -> String
forall k (s :: k) k1 (t :: k -> (k1 -> *) -> k1 -> *)
       (f :: k1 -> *) (a :: k1).
Selector s =>
t s f a -> String
selName (forall p. M1 S 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 = do
      f a
l <- 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
      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 a
r <- 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
      (:*:) f g a -> ReadPrec ((:*:) f g a)
forall (m :: * -> *) a. Monad m => a -> m a
return (f a
l f a -> g a -> (:*:) f g a
forall k (f :: k -> *) (g :: k -> *) (p :: k).
f p -> g p -> (:*:) f g p
:*: g a
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 a) =
      coerceComp1 $ fmap (fmap getApply) $ readS_to_Prec crp1
    where
      crp1 :: Int -> ReadS (f (Apply g a))
      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

-------------------------------------------------------------------------------
-- * 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 that can be converted to a 'String'.
class 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
#if __GLASGOW_HASKELL__ >= 708
  gliftShowsPrec :: Options -> Show1Args v a -> Int -> V1 a -> ShowS
gliftShowsPrec Options
_ Show1Args v a
_ Int
_  V1 a
x = case V1 a
x of {}
#else
  gliftShowsPrec _ _ _ !_ = 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 Int
p c :: C1 c f a
c@(M1 f a
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 a -> Bool
forall (f :: * -> *) a. IsNullaryCon f => f a -> Bool
isNullaryCon f a
x Bool -> Bool -> Bool
|| C1 c f a -> Bool
forall (c :: Meta) (f :: * -> *) p.
Constructor c =>
C1 c f p -> Bool
conIsTuple C1 c f a
c)
                           ) (ShowS -> ShowS) -> ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$
             (if C1 c f a -> Bool
forall (c :: Meta) (f :: * -> *) p.
Constructor c =>
C1 c f p -> Bool
conIsTuple C1 c f a
c
                 then ShowS
forall a. a -> a
id
                 else let cn :: String
cn = C1 c f a -> 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 a
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 a -> Bool
forall (f :: * -> *) a. IsNullaryCon f => f a -> Bool
isNullaryCon f a
x Bool -> Bool -> Bool
|| C1 c f a -> Bool
forall (c :: Meta) (f :: * -> *) p.
Constructor c =>
C1 c f p -> Bool
conIsTuple C1 c f a
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 (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 Int
appPrec1 f a
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
$ 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 (Int
mInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) f a
x
    where
      fixity :: Fixity
      fixity :: Fixity
fixity = C1 c f a -> 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 a
c

      t :: ConType
      t :: ConType
t = if C1 c f a -> 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 a
c
          then ConType
Rec
          else case C1 c f a -> Bool
forall (c :: Meta) (f :: * -> *) p.
Constructor c =>
C1 c f p -> Bool
conIsTuple C1 c f a
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 a -> 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 a
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 that can be converted to a 'String', and
-- for which the 'ConType' has been determined.
class 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
p sel :: S1 s f a
sel@(M1 f a
x)
    | S1 s f a -> 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 a
sel String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"" =   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 Int
p f a
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
. 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 Int
0 f a
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 a -> 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 a
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
p (f a
a :*: g a
b) =
    case ConType
t of
         ConType
Rec ->     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 Int
0 f a
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
. 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 Int
0 g a
b

         Inf String
o ->   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 Int
p f a
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
. 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 Int
p g a
b

         ConType
Tup ->     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 Int
0 f a
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
. 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 Int
0 g a
b

         ConType
Pref ->    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 Int
p f a
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
. 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 Int
p g a
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 Apply 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
_ 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

instance GShow1Con v UDouble where
  gliftShowsPrecCon :: Options -> ConType -> Show1Args v a -> Int -> UDouble a -> ShowS
gliftShowsPrecCon Options
opts ConType
_ Show1Args v a
_ 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

instance GShow1Con v UFloat where
  gliftShowsPrecCon :: Options -> ConType -> Show1Args v a -> Int -> UFloat a -> ShowS
gliftShowsPrecCon Options
opts ConType
_ Show1Args v a
_ 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

instance GShow1Con v UInt where
  gliftShowsPrecCon :: Options -> ConType -> Show1Args v a -> Int -> UInt a -> ShowS
gliftShowsPrecCon Options
opts ConType
_ Show1Args v a
_ 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

instance GShow1Con v UWord where
  gliftShowsPrecCon :: Options -> ConType -> Show1Args v a -> Int -> UWord a -> ShowS
gliftShowsPrecCon Options
opts ConType
_ Show1Args v a
_ 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

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 }

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

instance (GOrd1 V4 g, Ord a) => Ord (Apply g a) where
    compare (Apply x) (Apply 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 (GRead1Con V4 g, Read a) => Read (Apply g a) where
    readPrec = fmap Apply $ gliftReadPrecCon Pref V4Read1Args

instance (GShow1Con V4 g, Show a) => Show (Apply g a) where
    showsPrec d = gliftShowsPrecCon defaultOptions Pref V4Show1Args d . getApply
#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