Avoid nasty name clash with associated data types (fixes Trac #2888)

[ghc-hetmet.git] / compiler / iface / BuildTyCl.lhs

diff --git a/compiler/iface/BuildTyCl.lhs b/compiler/iface/BuildTyCl.lhs
index 8459edf..b8c04d3 100644 (file)
--- a/compiler/iface/BuildTyCl.lhs
+++ b/compiler/iface/BuildTyCl.lhs
@@ -8,7 +8,7 @@ module BuildTyCl (
        buildSynTyCon, buildAlgTyCon, buildDataCon,
        buildClass,
        mkAbstractTyConRhs, mkOpenDataTyConRhs, 
-       mkNewTyConRhs, mkDataTyConRhs 
+       mkNewTyConRhs, mkDataTyConRhs, setAssocFamilyPermutation
     ) where
 
 #include "HsVersions.h"
@@ -39,22 +39,23 @@ import Data.List
 ------------------------------------------------------
 buildSynTyCon :: Name -> [TyVar] 
               -> SynTyConRhs 
+             -> Kind                   -- Kind of the RHS
              -> Maybe (TyCon, [Type])  -- family instance if applicable
               -> TcRnIf m n TyCon
 
-buildSynTyCon tc_name tvs rhs@(OpenSynTyCon rhs_ki _) _
+buildSynTyCon tc_name tvs rhs@(OpenSynTyCon {}) rhs_kind _
   = let
-      kind = mkArrowKinds (map tyVarKind tvs) rhs_ki
+      kind = mkArrowKinds (map tyVarKind tvs) rhs_kind
     in
     return $ mkSynTyCon tc_name kind tvs rhs NoParentTyCon
     
-buildSynTyCon tc_name tvs rhs@(SynonymTyCon rhs_ty) mb_family
+buildSynTyCon tc_name tvs rhs@(SynonymTyCon {}) rhs_kind mb_family
   = do { -- We need to tie a knot as the coercion of a data instance depends
         -- on the instance representation tycon and vice versa.
        ; tycon <- fixM (\ tycon_rec -> do 
         { parent <- mkParentInfo mb_family tc_name tvs tycon_rec
         ; let { tycon   = mkSynTyCon tc_name kind tvs rhs parent
-              ; kind    = mkArrowKinds (map tyVarKind tvs) (typeKind rhs_ty)
+              ; kind    = mkArrowKinds (map tyVarKind tvs) rhs_kind
               }
          ; return tycon
          })
@@ -92,7 +93,7 @@ buildAlgTyCon tc_name tvs stupid_theta rhs is_rec want_generics gadt_syn
 --
 -- (1) create a coercion that identifies the family instance type and the
 --     representation type from Step (1); ie, it is of the form 
---        `Co tvs :: F ts :=: R tvs', where `Co' is the name of the coercion,
+--        `Co tvs :: F ts ~ R tvs', where `Co' is the name of the coercion,
 --        `F' the family tycon and `R' the (derived) representation tycon,
 --        and
 -- (2) produce a `TyConParent' value containing the parent and coercion
@@ -147,13 +148,16 @@ mkNewTyConRhs tycon_name tycon con
         -- non-recursive newtypes
     all_coercions = True
     tvs    = tyConTyVars tycon
-    rhs_ty = ASSERT(not (null (dataConInstOrigDictsAndArgTys con (mkTyVarTys tvs)))) 
-            -- head (dataConInstOrigArgTys con (mkTyVarTys tvs))
-            head (dataConInstOrigDictsAndArgTys con (mkTyVarTys tvs))
+    inst_con_ty = applyTys (dataConUserType con) (mkTyVarTys tvs)
+    rhs_ty = ASSERT( isFunTy inst_con_ty ) funArgTy inst_con_ty
        -- Instantiate the data con with the 
        -- type variables from the tycon
-       -- NB: a newtype DataCon has no existentials; hence the
-       --     call to dataConInstOrigArgTys has the right type args
+       -- NB: a newtype DataCon has a type that must look like
+       --        forall tvs.  <arg-ty> -> T tvs
+       -- Note that we *can't* use dataConInstOrigArgTys here because
+       -- the newtype arising from   class Foo a => Bar a where {}
+       -- has a single argument (Foo a) that is a *type class*, so
+       -- dataConInstOrigArgTys returns [].
 
     etad_tvs :: [TyVar]        -- Matched lazily, so that mkNewTypeCoercion can
     etad_rhs :: Type   -- return a TyCon without pulling on rhs_ty
@@ -171,6 +175,13 @@ mkNewTyConRhs tycon_name tycon con
     eta_reduce tvs ty = (reverse tvs, ty)
                                
 
+setAssocFamilyPermutation :: [TyVar] -> TyThing -> TyThing
+setAssocFamilyPermutation clas_tvs (ATyCon tc) 
+  = ATyCon (setTyConArgPoss clas_tvs tc)
+setAssocFamilyPermutation _clas_tvs other
+  = pprPanic "setAssocFamilyPermutation" (ppr other)
+
+
 ------------------------------------------------------
 buildDataCon :: Name -> Bool
            -> [StrictnessMark] 
@@ -179,14 +190,15 @@ buildDataCon :: Name -> Bool
             -> [(TyVar,Type)]           -- Equality spec
            -> ThetaType                -- Does not include the "stupid theta"
                                        -- or the GADT equalities
-           -> [Type] -> TyCon
+           -> [Type] -> Type           -- Argument and result types
+           -> TyCon                    -- Rep tycon
            -> TcRnIf m n DataCon
 -- A wrapper for DataCon.mkDataCon that
 --   a) makes the worker Id
 --   b) makes the wrapper Id if necessary, including
 --     allocating its unique (hence monadic)
 buildDataCon src_name declared_infix arg_stricts field_lbls
-            univ_tvs ex_tvs eq_spec ctxt arg_tys tycon
+            univ_tvs ex_tvs eq_spec ctxt arg_tys res_ty rep_tycon
   = do { wrap_name <- newImplicitBinder src_name mkDataConWrapperOcc
        ; work_name <- newImplicitBinder src_name mkDataConWorkerOcc
        -- This last one takes the name of the data constructor in the source
@@ -194,11 +206,11 @@ buildDataCon src_name declared_infix arg_stricts field_lbls
        -- space, and puts it into the VarName name space
 
        ; let
-               stupid_ctxt = mkDataConStupidTheta tycon arg_tys univ_tvs
+               stupid_ctxt = mkDataConStupidTheta rep_tycon arg_tys univ_tvs
                data_con = mkDataCon src_name declared_infix
                                     arg_stricts field_lbls
                                     univ_tvs ex_tvs eq_spec ctxt
-                                    arg_tys tycon
+                                    arg_tys res_ty rep_tycon
                                     stupid_ctxt dc_ids
                dc_ids = mkDataConIds wrap_name work_name data_con
 
@@ -267,7 +279,8 @@ buildClass no_unf class_name tvs sc_theta fds ats sig_stuff tc_isrec
                                   [{- No labelled fields -}]
                                   tvs [{- no existentials -}]
                                    [{- No GADT equalities -}] sc_theta 
-                                   op_tys
+                                   op_tys 
+                                  (mkTyConApp rec_tycon (mkTyVarTys tvs))
                                   rec_tycon
 
        ; let n_value_preds   = count (not . isEqPred) sc_theta