Revert accidental wip/generics-propeq-conservative merge
authorHerbert Valerio Riedel <hvr@gnu.org>
Fri, 19 Sep 2014 08:13:16 +0000 (10:13 +0200)
committerHerbert Valerio Riedel <hvr@gnu.org>
Fri, 19 Sep 2014 08:18:23 +0000 (10:18 +0200)
This commit reverts the commits

   e12a6a8 Propositional equality for Datatype meta-information
   0a8e6fc Make constructor metadata parametrized (with intended parameter <- datatype)
   f097b77 Implement sameConstructor
   cc618e6 get roles right and fix a FIXME
   79c7125 Actually parametrize the Constructor with the Datatype
   7bd4bab Supply a reasonable name (should be derived from d_name tho)
   09fcd70 Use 'd_name' as the name (should be derived from d_name tho)
   4d90e44 Add default case (fixes -Werror)

and effectively resets ghc.git to the state it was at commit
8c79dcb4dc2c6b8b663fa0c2e61d40d0ac0e9996

compiler/typecheck/TcGenGenerics.lhs
libraries/base/GHC/Generics.hs

index dde339d..158a1e7 100644 (file)
@@ -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
index b3f6de7..1c81858 100644 (file)
@@ -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