-----BEGIN PGP SIGNED MESSAGE----- Hash: SHA256 On 19/09/14 08:15, Arash Rouhani wrote: > When I make mistakes like this though I just quickly undo it with a > force push. ^^ Please don't ever force push to a public repository.
On 19/09/14 06:48, Gabor Greif wrote: > Sorry for the messup. How can I repair this? I did not intend to > "merge" my work yet. Just revert? Patch attached. Pushing this patch will revert your commits in a clean way. - -- Alexander alexan...@plaimi.net https://secure.plaimi.net/~alexander -----BEGIN PGP SIGNATURE----- Version: GnuPG v2 Comment: Using GnuPG with Thunderbird - http://www.enigmail.net/ iF4EAREIAAYFAlQb5uUACgkQRtClrXBQc7W3AAD/d8bh9VvkgZzr6Y8JMPodPcwg +uKct2eapooVjZiaimEBAKo/4MJJBamfPRYOO07GZUUYvXxybtZNaS3nFwPNfY9d =Y8Ka -----END PGP SIGNATURE-----
>From cade7ed5b3e725a9128367fc2336af1a132ca734 Mon Sep 17 00:00:00 2001
From: Alexander Berntsen <alexan...@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
0001-Revert-Gabor-s-accidental-merge.patch.sig
Description: PGP signature
_______________________________________________ ghc-devs mailing list ghc-devs@haskell.org http://www.haskell.org/mailman/listinfo/ghc-devs
