>From cade7ed5b3e725a9128367fc2336af1a132ca734 Mon Sep 17 00:00:00 2001
From: Alexander Berntsen <alexander@plaimi.net>
Date: Fri, 19 Sep 2014 10:14:24 +0200
Subject: [PATCH] Revert Gabor's accidental merge

Gabor merged a branch he did not mean to merge.

This reverts commits: 4d90e44101559800947ce3cd7fd8704dc520b332
		      09fcd700cfe891ea83aab8f5e1e25f13c193e05c
		      7bd4babb933dbd52d26e40fdd6b2c572207bbc64
		      79c712528390bb170ea546fa8192cb6c9a0877ea
		      cc618e6de25fda149b7153141895ca942e5f8935
		      f097b779e215900f4746d3911094f7e599e51b1f
		      0a8e6fc97b2f7a944bc1723b2041cea4880dd5c2
		      e12a6a83851633722e8293e51e09a9c760be84f1
---
 compiler/typecheck/TcGenGenerics.lhs | 34 ++++++++++-----------
 libraries/base/GHC/Generics.hs       | 57 ++++++++----------------------------
 2 files changed, 29 insertions(+), 62 deletions(-)

diff --git a/compiler/typecheck/TcGenGenerics.lhs b/compiler/typecheck/TcGenGenerics.lhs
index dde339d..158a1e7 100644
--- a/compiler/typecheck/TcGenGenerics.lhs
+++ b/compiler/typecheck/TcGenGenerics.lhs
@@ -17,7 +17,6 @@ module TcGenGenerics (canDoGenerics, canDoGenerics1,
 import DynFlags
 import HsSyn
 import Type
-import TypeRep          ( Type( TyConApp ) )
 import Kind             ( isKind )
 import TcType
 import TcGenDeriv
@@ -42,7 +41,6 @@ import BuildTyCl
 import SrcLoc
 import Bag
 import VarSet (elemVarSet)
-import Var (mkTyVar)
 import Outputable
 import FastString
 import Util
@@ -85,13 +83,12 @@ genGenericMetaTyCons tc mod =
         c_occ m   = mkGenC tc_occ m
         s_occ m n = mkGenS tc_occ m n
 
-        mkTyCon tyvars name = ASSERT( isExternalName name )
-                              buildAlgTyCon name tyvars roles Nothing [] distinctAbstractTyConRhs
+        mkTyCon name = ASSERT( isExternalName name )
+                       buildAlgTyCon name [] [] Nothing [] distinctAbstractTyConRhs
                                           NonRecursive
                                           False          -- Not promotable
                                           False          -- Not GADT syntax
                                           NoParentTyCon
-                                  where roles = map (const Nominal) tyvars
 
       d_name  <- newGlobalBinder mod d_occ loc
       c_names <- forM (zip [0..] tc_cons) $ \(m,_) ->
@@ -99,12 +96,13 @@ genGenericMetaTyCons tc mod =
       s_names <- forM (zip [0..] tc_arits) $ \(m,a) -> forM [0..a-1] $ \n ->
                     newGlobalBinder mod (s_occ m n) loc
 
-      let metaDTyCon  = mkTyCon [] d_name
-          metaCTyCons = map (\c_name -> mkTyConApp (mkTyCon [mkTyVar d_name openTypeKind] c_name) [mkTyConTy metaDTyCon]) c_names
-          metaSTyCons = map (map $ mkTyCon []) s_names
+      let metaDTyCon  = mkTyCon d_name
+          metaCTyCons = map mkTyCon c_names
+          metaSTyCons = map (map mkTyCon) s_names
 
           metaDts = MetaTyCons metaDTyCon metaCTyCons metaSTyCons
 
+      -- pprTrace "rep0" (ppr rep0_tycon) $
       (,) metaDts `fmap` metaTyConsToDerivStuff tc metaDts
 
 -- both the tycon declarations and related instances
@@ -113,7 +111,7 @@ metaTyConsToDerivStuff tc metaDts =
   do  loc <- getSrcSpanM
       dflags <- getDynFlags
       dClas <- tcLookupClass datatypeClassName
-      let new_dfun_name clas tycon = newDFunName clas [mkTyConTy tycon] loc
+      let new_dfun_name clas tycon = newDFunName clas [mkTyConApp tycon []] loc
       d_dfun_name <- new_dfun_name dClas tc
       cClas <- tcLookupClass constructorClassName
       c_dfun_names <- sequence [ new_dfun_name cClas tc | _ <- metaC metaDts ]
@@ -125,12 +123,13 @@ metaTyConsToDerivStuff tc metaDts =
 
       let
         (dBinds,cBinds,sBinds) = mkBindsMetaD fix_env tc
-        mk_inst' clas ty dfun_name
-          = mkLocalInstance (mkDictFunId dfun_name [] [] clas [ty])
+        mk_inst clas tc dfun_name
+          = mkLocalInstance (mkDictFunId dfun_name [] [] clas tys)
                             OverlapFlag { overlapMode   = NoOverlap
                                         , isSafeOverlap = safeLanguageOn dflags }
-                            [] clas [ty]
-        mk_inst clas tc dfun_name = mk_inst' clas (mkTyConTy tc) dfun_name
+                            [] clas tys
+          where
+            tys = [mkTyConTy tc]
 
         -- Datatype
         d_metaTycon = metaD metaDts
@@ -143,7 +142,7 @@ metaTyConsToDerivStuff tc metaDts =
 
         -- Constructor
         c_metaTycons = metaC metaDts
-        c_insts = [ mk_inst' cClas c ds
+        c_insts = [ mk_inst cClas c ds
                   | (c, ds) <- myZip1 c_metaTycons c_dfun_names ]
         c_binds = [ InstBindings { ib_binds = c
                                  , ib_pragmas = []
@@ -645,7 +644,7 @@ tc_mkRepTy gk_ tycon metaDts =
 
 
         metaDTyCon  = mkTyConTy (metaD metaDts)
-        metaCTyCons = metaC metaDts
+        metaCTyCons = map mkTyConTy (metaC metaDts)
         metaSTyCons = map (map mkTyConTy) (metaS metaDts)
 
     return (mkD tycon)
@@ -657,7 +656,7 @@ tc_mkRepTy gk_ tycon metaDts =
 data MetaTyCons = MetaTyCons { -- One meta datatype per datatype
                                metaD :: TyCon
                                -- One meta datatype per constructor
-                             , metaC :: [Type]
+                             , metaC :: [TyCon]
                                -- One meta datatype per selector per constructor
                              , metaS :: [[TyCon]] }
 
@@ -665,8 +664,7 @@ instance Outputable MetaTyCons where
   ppr (MetaTyCons d c s) = ppr d $$ vcat (map ppr c) $$ vcat (map ppr (concat s))
 
 metaTyCons2TyCons :: MetaTyCons -> Bag TyCon
-metaTyCons2TyCons (MetaTyCons d cty s) = listToBag (d : c ++ concat s)
-  where c = map (\(TyConApp c [_]) -> c) cty
+metaTyCons2TyCons (MetaTyCons d c s) = listToBag (d : c ++ concat s)
 
 
 -- Bindings for Datatype, Constructor, and Selector instances
diff --git a/libraries/base/GHC/Generics.hs b/libraries/base/GHC/Generics.hs
index b3f6de7..1c81858 100644
--- a/libraries/base/GHC/Generics.hs
+++ b/libraries/base/GHC/Generics.hs
@@ -7,7 +7,6 @@
 {-# LANGUAGE TypeFamilies           #-}
 {-# LANGUAGE StandaloneDeriving     #-}
 {-# LANGUAGE DeriveGeneric          #-}
-{-# LANGUAGE FlexibleInstances      #-}
 
 -----------------------------------------------------------------------------
 -- |
@@ -556,9 +555,6 @@ module GHC.Generics  (
   , Datatype(..), Constructor(..), Selector(..), NoSelector
   , Fixity(..), Associativity(..), Arity(..), prec
 
-  -- * Propositional equality for meta-information
-  , sameDatatype, sameConstructor
-
   -- * Generic type classes
   , Generic(..), Generic1(..)
 
@@ -566,14 +562,11 @@ module GHC.Generics  (
 
 -- We use some base types
 import GHC.Types
-import Unsafe.Coerce
 import Data.Maybe ( Maybe(..) )
 import Data.Either ( Either(..) )
-import Data.Type.Equality
-import GHC.Base ( (&&), undefined )
 
 -- Needed for instances
-import GHC.Classes ( Eq((==)), Ord )
+import GHC.Classes ( Eq, Ord )
 import GHC.Read ( Read )
 import GHC.Show ( Show )
 import Data.Proxy
@@ -659,17 +652,6 @@ class Datatype d where
   isNewtype    :: t d (f :: * -> *) a -> Bool
   isNewtype _ = False
 
--- | Propositional equality predicate for datatypes
-sameDatatype :: (Datatype l, Datatype r) => Proxy l -> Proxy r -> Maybe (l :~: r)
-sameDatatype l r | moduleName dl == moduleName dr
-                 && datatypeName dl == datatypeName dr
-                 = Just (unsafeCoerce Refl)
-    where dummy :: Proxy m -> D1 m a p
-          dummy Proxy = undefined
-          dl = dummy l
-          dr = dummy r
-sameDatatype _ _ = Nothing
-
 
 -- | Class for datatypes that represent records
 class Selector s where
@@ -694,19 +676,6 @@ class Constructor c where
   conIsRecord :: t c (f :: * -> *) a -> Bool
   conIsRecord _ = False
 
--- | Propositional equality predicate for constructors
-sameConstructor :: (Datatype l, Datatype r, Constructor (cl l), Constructor (cr r))
-                => Proxy (cl l) -> Proxy (cr r) -> Maybe (cl l :~: cr r)
-sameConstructor l r | Just Refl <- pd l ` sameDatatype` pd r
-                    , True <- conName cl == conName cr
-                    = Just (unsafeCoerce Refl)
-    where pd :: Proxy (cm m) -> Proxy m
-          pd Proxy = Proxy
-          dummyC :: Proxy (cm m) -> C1 (cm m) a p
-          dummyC Proxy = undefined
-          cl = dummyC l
-          cr = dummyC r
-sameConstructor _ _ = Nothing
 
 -- | Datatype to represent the arity of a tuple.
 data Arity = NoArity | Arity Int
@@ -782,68 +751,68 @@ deriving instance Generic1 ((,,,,,,) a b c d e f)
 
 -- Int
 data D_Int
-data C_Int d
+data C_Int
 
 instance Datatype D_Int where
   datatypeName _ = "Int"
   moduleName   _ = "GHC.Int"
 
-instance Constructor (C_Int D_Int) where
+instance Constructor C_Int where
   conName _ = "" -- JPM: I'm not sure this is the right implementation...
 
 instance Generic Int where
-  type Rep Int = D1 D_Int (C1 (C_Int D_Int) (S1 NoSelector (Rec0 Int)))
+  type Rep Int = D1 D_Int (C1 C_Int (S1 NoSelector (Rec0 Int)))
   from x = M1 (M1 (M1 (K1 x)))
   to (M1 (M1 (M1 (K1 x)))) = x
 
 
 -- Float
 data D_Float
-data C_Float d
+data C_Float
 
 instance Datatype D_Float where
   datatypeName _ = "Float"
   moduleName   _ = "GHC.Float"
 
-instance Constructor (C_Float D_Float) where
+instance Constructor C_Float where
   conName _ = "" -- JPM: I'm not sure this is the right implementation...
 
 instance Generic Float where
-  type Rep Float = D1 D_Float (C1 (C_Float D_Float) (S1 NoSelector (Rec0 Float)))
+  type Rep Float = D1 D_Float (C1 C_Float (S1 NoSelector (Rec0 Float)))
   from x = M1 (M1 (M1 (K1 x)))
   to (M1 (M1 (M1 (K1 x)))) = x
 
 
 -- Double
 data D_Double
-data C_Double d
+data C_Double
 
 instance Datatype D_Double where
   datatypeName _ = "Double"
   moduleName   _ = "GHC.Float"
 
-instance Constructor (C_Double D_Double) where
+instance Constructor C_Double where
   conName _ = "" -- JPM: I'm not sure this is the right implementation...
 
 instance Generic Double where
-  type Rep Double = D1 D_Double (C1 (C_Double D_Double) (S1 NoSelector (Rec0 Double)))
+  type Rep Double = D1 D_Double (C1 C_Double (S1 NoSelector (Rec0 Double)))
   from x = M1 (M1 (M1 (K1 x)))
   to (M1 (M1 (M1 (K1 x)))) = x
 
 
 -- Char
 data D_Char
-data C_Char d
+data C_Char
 
 instance Datatype D_Char where
   datatypeName _ = "Char"
   moduleName   _ = "GHC.Base"
 
-instance Constructor (C_Char D_Char) where
+instance Constructor C_Char where
   conName _ = "" -- JPM: I'm not sure this is the right implementation...
 
 instance Generic Char where
-  type Rep Char = D1 D_Char (C1 (C_Char D_Char) (S1 NoSelector (Rec0 Char)))
+  type Rep Char = D1 D_Char (C1 C_Char (S1 NoSelector (Rec0 Char)))
   from x = M1 (M1 (M1 (K1 x)))
   to (M1 (M1 (M1 (K1 x)))) = x
 
-- 
1.8.5.5

