Fix Trac #3012: allow more free-wheeling in standalone deriving

[ghc-hetmet.git] / compiler / typecheck / TcEnv.lhs

diff --git a/compiler/typecheck/TcEnv.lhs b/compiler/typecheck/TcEnv.lhs
index 36231cd..055fc2c 100644 (file)
--- a/compiler/typecheck/TcEnv.lhs
+++ b/compiler/typecheck/TcEnv.lhs
@@ -640,6 +640,7 @@ data InstBindings a
        (LHsBinds a)            -- Bindings for the instance methods
        [LSig a]                -- User pragmas recorded for generating 
                                -- specialised instances
+       Bool                    -- True <=> This code came from a standalone deriving clause
 
   | NewTypeDerived              -- Used for deriving instances of newtypes, where the
        CoercionI               -- witness dictionary is identical to the argument 
@@ -655,8 +656,8 @@ pprInstInfo info = vcat [ptext (sLit "InstInfo:") <+> ppr (idType (iDFunId info)
 pprInstInfoDetails :: OutputableBndr a => InstInfo a -> SDoc
 pprInstInfoDetails info = pprInstInfo info $$ nest 2 (details (iBinds info))
   where
-    details (VanillaInst b _)  = pprLHsBinds b
-    details (NewTypeDerived _) = text "Derived from the representation type"
+    details (VanillaInst b _ _) = pprLHsBinds b
+    details (NewTypeDerived _)  = text "Derived from the representation type"
 
 simpleInstInfoClsTy :: InstInfo a -> (Class, Type)
 simpleInstInfoClsTy info = case instanceHead (iSpec info) of
@@ -677,17 +678,13 @@ name, like otber top-level names, and hence must be made with newGlobalBinder.
 
 \begin{code}
 newDFunName :: Class -> [Type] -> SrcSpan -> TcM Name
-newDFunName clas (ty:_) loc
-  = do { index   <- nextDFunIndex
-       ; is_boot <- tcIsHsBoot
+newDFunName clas tys loc
+  = do { is_boot <- tcIsHsBoot
        ; mod     <- getModule
        ; let info_string = occNameString (getOccName clas) ++ 
-                           occNameString (getDFunTyKey ty)
-             dfun_occ = mkDFunOcc info_string is_boot index
-
+                           concatMap (occNameString.getDFunTyKey) tys
+        ; dfun_occ <- chooseUniqueOccTc (mkDFunOcc info_string is_boot)
        ; newGlobalBinder mod dfun_occ loc }
-
-newDFunName clas [] loc = pprPanic "newDFunName" (ppr clas <+> ppr loc)
 \end{code}
 
 Make a name for the representation tycon of a family instance.  It's an
@@ -695,12 +692,13 @@ Make a name for the representation tycon of a family instance.  It's an
 newGlobalBinder.
 
 \begin{code}
-newFamInstTyConName :: Name -> SrcSpan -> TcM Name
-newFamInstTyConName tc_name loc
-  = do { index <- nextDFunIndex
-       ; mod   <- getModule
-       ; let occ = nameOccName tc_name
-       ; newGlobalBinder mod (mkInstTyTcOcc index occ) loc }
+newFamInstTyConName :: Name -> [Type] -> SrcSpan -> TcM Name
+newFamInstTyConName tc_name tys loc
+  = do { mod   <- getModule
+       ; let info_string = occNameString (getOccName tc_name) ++ 
+                           concatMap (occNameString.getDFunTyKey) tys
+        ; occ   <- chooseUniqueOccTc (mkInstTyTcOcc info_string)
+       ; newGlobalBinder mod occ loc }
 \end{code}
 
 Stable names used for foreign exports and annotations.