11{-# LANGUAGE CPP #-}
22{-# LANGUAGE DeriveDataTypeable #-}
33{-# LANGUAGE GADTs #-}
4+ {-# LANGUAGE QuantifiedConstraints #-}
45{-# LANGUAGE RankNTypes #-}
56{-# LANGUAGE ScopedTypeVariables #-}
67{-# LANGUAGE TypeOperators #-}
7- #if __GLASGOW_HASKELL__ >= 706
88{-# LANGUAGE PolyKinds #-}
9- #endif
10- #if __GLASGOW_HASKELL__ >= 708
119{-# LANGUAGE RoleAnnotations #-}
12- #endif
1310#if __GLASGOW_HASKELL__ >= 810
1411{-# LANGUAGE StandaloneKindSignatures #-}
1512#endif
16- #if (__GLASGOW_HASKELL__ >= 704 && __GLASGOW_HASKELL__ < 707) || __GLASGOW_HASKELL__ >= 801
13+ {-# LANGUAGE StandaloneDeriving #-}
1714{-# LANGUAGE Safe #-}
18- #elif __GLASGOW_HASKELL__ >= 702
19- {-# LANGUAGE Trustworthy #-}
20- #endif
15+
16+ -- For GShow
17+ {-# LANGUAGE FlexibleInstances #-}
18+ {-# LANGUAGE UndecidableInstances #-}
19+
2120module Data.GADT.Internal where
2221
2322import Control.Applicative (Applicative (.. ))
@@ -28,9 +27,7 @@ import Data.Monoid (Monoid (..))
2827import Data.Semigroup (Semigroup (.. ))
2928import Data.Type.Equality ((:~:) (.. ))
3029
31- #if __GLASGOW_HASKELL__ >=708
3230import Data.Typeable (Typeable )
33- #endif
3431
3532#if MIN_VERSION_base(4,10,0)
3633import Data.Type.Equality (testEquality )
@@ -41,6 +38,7 @@ import qualified Type.Reflection as TR
4138import Data.Kind (Type , Constraint )
4239#endif
4340
41+ {-# DEPRECATED GShow "Just use the underlying quantified constraint" #-}
4442-- $setup
4543-- >>> :set -XKindSignatures -XGADTs
4644
@@ -49,48 +47,18 @@ import Data.Kind (Type, Constraint)
4947-- to write (or derive) an @instance Show (T a)@, and then simply say:
5048--
5149-- > instance GShow t where gshowsPrec = showsPrec
52- #if __GLASGOW_HASKELL__ >= 810
53- type GShow :: (k -> Type ) -> Constraint
54- #endif
55- class GShow t where
56- gshowsPrec :: Int -> t a -> ShowS
50+ class (forall a . Show (t a )) => GShow t
51+ instance (forall a . Show (t a )) => GShow t
5752
58- -- | If 'f' has a 'Show (f a)' instance, this function makes a suitable default
59- -- implementation of 'gshowsPrec'.
60- defaultGshowsPrec :: Show (t a ) => Int -> t a -> ShowS
61- defaultGshowsPrec = showsPrec
53+ gshowsPrec :: GShow t => Int -> t a -> ShowS
54+ gshowsPrec = showsPrec
6255
6356gshows :: GShow t => t a -> ShowS
6457gshows = gshowsPrec (- 1 )
6558
6659gshow :: (GShow t ) => t a -> String
6760gshow x = gshows x " "
6861
69- instance GShow ((:~: ) a ) where
70- gshowsPrec _ Refl = showString " Refl"
71-
72- #if MIN_VERSION_base(4,10,0)
73- instance GShow TR. TypeRep where
74- gshowsPrec = showsPrec
75- #endif
76-
77- --
78- -- | >>> gshow (InL Refl :: Sum ((:~:) Int) ((:~:) Bool) Int)
79- -- "InL Refl"
80- instance (GShow a , GShow b ) => GShow (Sum a b ) where
81- gshowsPrec d = \ s -> case s of
82- InL x -> showParen (d > 10 ) (showString " InL " . gshowsPrec 11 x)
83- InR x -> showParen (d > 10 ) (showString " InR " . gshowsPrec 11 x)
84-
85- -- | >>> gshow (Pair Refl Refl :: Product ((:~:) Int) ((:~:) Int) Int)
86- -- "Pair Refl Refl"
87- instance (GShow a , GShow b ) => GShow (Product a b ) where
88- gshowsPrec d (Pair x y) = showParen (d > 10 )
89- $ showString " Pair "
90- . gshowsPrec 11 x
91- . showChar ' '
92- . gshowsPrec 11 y
93-
9462-- | @GReadS t@ is equivalent to @ReadS (forall b. (forall a. t a -> b) -> b)@, which is
9563-- in turn equivalent to @ReadS (Exists t)@ (with @data Exists t where Exists :: t a -> Exists t@)
9664#if __GLASGOW_HASKELL__ >= 810
@@ -113,6 +81,9 @@ type GRead :: (k -> Type) -> Constraint
11381class GRead t where
11482 greadsPrec :: Int -> GReadS t
11583
84+ -- (forall a. Read (t a)) =>
85+ -- Skipping because it is rather misleading to use.
86+
11687greads :: GRead t => GReadS t
11788greads = greadsPrec (- 1 )
11889
@@ -162,7 +133,7 @@ instance (GRead a, GRead b) => GRead (Sum a b) where
162133#if __GLASGOW_HASKELL__ >= 810
163134type GEq :: (k -> Type ) -> Constraint
164135#endif
165- class GEq f where
136+ class ( forall a . Eq ( f a )) => GEq f where
166137 -- | Produce a witness of type-equality, if one exists.
167138 --
168139 -- A handy idiom for using this would be to pattern-bind in the Maybe monad, eg.:
@@ -249,9 +220,21 @@ data GOrdering a b where
249220 GLT :: GOrdering a b
250221 GEQ :: GOrdering t t
251222 GGT :: GOrdering a b
252- #if __GLASGOW_HASKELL__ >=708
253223 deriving Typeable
254- #endif
224+
225+ deriving instance Eq (GOrdering a b )
226+ deriving instance Ord (GOrdering a b )
227+ deriving instance Show (GOrdering a b )
228+
229+ {-
230+ instance Read (GOrdering a b) where
231+ readsPrec _ s = case con of
232+ "GGT" -> [(GGT, rest)]
233+ "GEQ" -> [] -- cannot read without evidence of equality
234+ "GLT" -> [(GLT, rest)]
235+ _ -> []
236+ where (con, rest) = splitAt 3 s
237+ -}
255238
256239-- | TODO: Think of a better name
257240--
@@ -261,20 +244,6 @@ weakenOrdering GLT = LT
261244weakenOrdering GEQ = EQ
262245weakenOrdering GGT = GT
263246
264- instance Eq (GOrdering a b ) where
265- x == y = weakenOrdering x == weakenOrdering y
266-
267- instance Ord (GOrdering a b ) where
268- compare x y = compare (weakenOrdering x) (weakenOrdering y)
269-
270- instance Show (GOrdering a b ) where
271- showsPrec _ GGT = showString " GGT"
272- showsPrec _ GEQ = showString " GEQ"
273- showsPrec _ GLT = showString " GLT"
274-
275- instance GShow (GOrdering a ) where
276- gshowsPrec = showsPrec
277-
278247instance GRead (GOrdering a ) where
279248 greadsPrec _ s = case con of
280249 " GGT" -> [(mkSome GGT , rest)]
@@ -288,7 +257,7 @@ instance GRead (GOrdering a) where
288257#if __GLASGOW_HASKELL__ >= 810
289258type GCompare :: (k -> Type ) -> Constraint
290259#endif
291- class GEq f => GCompare f where
260+ class ( GEq f , forall a . Ord ( f a )) => GCompare f where
292261 gcompare :: f a -> f b -> GOrdering a b
293262
294263instance GCompare ((:~: ) a ) where
@@ -380,9 +349,7 @@ newtype Some tag = S
380349 withSome :: forall r . (forall a . tag a -> r ) -> r
381350 }
382351
383- #if __GLASGOW_HASKELL__ >= 708
384352type role Some representational
385- #endif
386353
387354-- | Constructor.
388355mkSome :: tag a -> Some tag
0 commit comments