[commit: testsuite] master: Test Trac #6002 (a8286eb)

[Simon Peyton Jones]

Repository : ssh://darcs.haskell.org//srv/darcs/testsuite

On branch  : master

http://hackage.haskell.org/trac/ghc/changeset/a8286ebaf84502bac8d4680aa0ac785c3b003f08

>---------------------------------------------------------------

commit a8286ebaf84502bac8d4680aa0ac785c3b003f08
Author: Simon Peyton Jones <simonpj at microsoft.com>
Date:   Tue Apr 24 12:15:50 2012 +0100

    Test Trac #6002

>---------------------------------------------------------------

 tests/polykinds/T6002.hs |  100 ++++++++++++++++++++++++++++++++++++++++++++++
 tests/polykinds/all.T    |    1 +
 2 files changed, 101 insertions(+), 0 deletions(-)

diff --git a/tests/polykinds/T6002.hs b/tests/polykinds/T6002.hs
new file mode 100644
index 0000000..b21914b
--- /dev/null
+++ b/tests/polykinds/T6002.hs
@@ -0,0 +1,100 @@
+-- This module should compile with -XIncoherentInstances, but didn't in 7.4
+
+
+{- Here we define all the stuff that is needed for our singleton
+   types:
+ - phantom types (when GHC 7.4 arrives, the user-defined kinds)
+ - corresponding singleton types
+
+These are basically the constructs from Omega,
+reimplemented in Haskell for our purposes. -}
+
+{-# LANGUAGE GADTs, KindSignatures, StandaloneDeriving,
+             RankNTypes, TypeFamilies, FlexibleInstances, IncoherentInstances #-}
+module TypeMachinery where
+
+-- The natural numbers:
+--  o first the phantom types
+
+data Z; data S n
+
+-- o the using the above the singleton type Nat'
+
+data Nat' :: * -> * where
+  Z :: Nat' Z
+  S :: Nat' n -> Nat' (S n)
+
+deriving instance Show (Nat' a)
+
+-- Type-level addition
+
+type family Plus m n :: *
+type instance Plus Z n = n
+type instance Plus (S m) n = S (Plus m n)
+
+-- Nat' addition
+
+plus :: Nat' a -> Nat' b -> Nat' (Plus a b)
+plus Z n = n
+plus (S m) n = S (plus m n)
+
+-- Equality on Nat'
+
+sameNat' :: Nat' a -> Nat' b -> Bool
+sameNat' Z Z = True
+sameNat' (S m) (S n) = sameNat' m n
+sameNat' _ _ = False
+
+-- A data type for existentially hiding
+-- (e.g.) Nat' values
+
+data Hidden :: (* -> *) -> * where
+  Hide :: Show (a n) => a n -> Hidden a
+
+deriving instance Show (Hidden t)
+
+toNat' :: Integral i => i -> Hidden Nat'
+toNat' 0 = Hide Z
+toNat' n = case toNat' (n - 1) of
+           Hide n -> Hide (S n)
+
+-- Now we are ready to make Hidden Nat' an Integral type
+
+instance Eq (Hidden Nat') where
+Hide a == Hide b = sameNat' a b
+
+instance Ord (Hidden Nat') where
+  Hide Z `compare` Hide Z = EQ
+  Hide Z `compare` Hide _ = LT
+  Hide _ `compare` Hide Z = GT
+  Hide (S m) `compare` Hide (S n) = Hide m `compare` Hide n
+
+instance Enum (Hidden Nat') where
+  toEnum = toEnum . fromIntegral
+  fromEnum = fromIntegral
+
+instance Num (Hidden Nat') where
+  fromInteger = toNat'
+  signum (Hide Z) = 0
+  signum _ = 1
+  abs n = n
+  Hide a + Hide b = Hide $ plus a b
+  a * b = fromInteger $ toInteger a * toInteger b
+
+instance Real (Hidden Nat') where
+  toRational = toRational . toInteger
+
+instance Integral (Hidden Nat') where
+  toInteger (Hide Z) = 0
+  toInteger (Hide (S n)) = 1 + toInteger (Hide n)
+  quotRem a b = let (a', b') = toInteger a `quotRem` toInteger b in (fromInteger a', fromInteger b')
+
+-- McBride's Fin data type. By counting backwards from the
+-- result index, it only admits a fixed number of inhabitants.
+
+data Fin :: * -> * where
+    Stop :: Fin (S Z)
+    Retreat :: Fin s -> Fin (S s)
+
+deriving instance Show (Fin a)
+
diff --git a/tests/polykinds/all.T b/tests/polykinds/all.T
index ae73e04..44a1703 100644
--- a/tests/polykinds/all.T
+++ b/tests/polykinds/all.T
@@ -36,3 +36,4 @@ test('T5938', normal, compile, [''])
 test('T5948', normal, compile, [''])
 test('T6020', normal, compile, [''])
 test('T6025', normal, run_command, ['$MAKE -s --no-print-directory T6025'])
+test('T6002', normal, compile, [''])