X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcTyClsDecls.lhs;h=633dc52812add6baabc4ba4b2c9b0df470e68fca;hp=3177b66a4866fd9a8eed9b6148c0106ab6149014;hb=432b9c9322181a3644083e3c19b7e240d90659e7;hpb=4d926e46bacf11ba9d7714c3f36f507c67fef0ba

diff --git a/compiler/typecheck/TcTyClsDecls.lhs b/compiler/typecheck/TcTyClsDecls.lhs
index 3177b66..633dc52 100644
--- a/compiler/typecheck/TcTyClsDecls.lhs
+++ b/compiler/typecheck/TcTyClsDecls.lhs
@@ -275,7 +275,8 @@ tcFamInstDecl1 (decl@TySynonym {tcdLName = L loc tc_name})
        ; checkTc (isSynTyCon family) (wrongKindOfFamily family)
 
        ; -- (1) kind check the right-hand side of the type equation
-       ; k_rhs <- kcCheckLHsType (tcdSynRhs decl) resKind
+       ; k_rhs <- kcCheckLHsType (tcdSynRhs decl) (EK resKind EkUnk)
+       	       	  -- ToDo: the ExpKind could be better
 
          -- we need the exact same number of type parameters as the family
          -- declaration 
@@ -378,7 +379,8 @@ kcIdxTyPats :: TyClDecl Name
 	    -> TcM a
 kcIdxTyPats decl thing_inside
   = kcHsTyVars (tcdTyVars decl) $ \tvs -> 
-    do { fam_tycon <- tcLookupLocatedTyCon (tcdLName decl)
+    do { let tc_name = tcdLName decl
+       ; fam_tycon <- tcLookupLocatedTyCon tc_name
        ; let { (kinds, resKind) = splitKindFunTys (tyConKind fam_tycon)
 	     ; hs_typats	= fromJust $ tcdTyPats decl }
 
@@ -388,10 +390,11 @@ kcIdxTyPats decl thing_inside
 
          -- type functions can have a higher-kinded result
        ; let resultKind = mkArrowKinds (drop (length hs_typats) kinds) resKind
-       ; typats <- zipWithM kcCheckLHsType hs_typats kinds
+       ; typats <- zipWithM kcCheckLHsType hs_typats 
+       	 	   	    [ EK kind (EkArg (ppr tc_name) n) 
+                            | (kind,n) <- kinds `zip` [1..]]
        ; thing_inside tvs typats resultKind fam_tycon
        }
-  where
 \end{code}
 
 
@@ -587,7 +590,8 @@ kcDataDecl decl@(TyData {tcdND = new_or_data, tcdCtxt = ctxt, tcdCons = cons})
 	; return (decl {tcdTyVars = tvs, tcdCtxt = ctxt', tcdCons = cons'}) }
   where
     -- doc comments are typechecked to Nothing here
-    kc_con_decl (ConDecl name expl ex_tvs ex_ctxt details res _) 
+    kc_con_decl con_decl@(ConDecl { con_name = name, con_qvars = ex_tvs
+                                  , con_cxt = ex_ctxt, con_details = details, con_res = res })
       = addErrCtxt (dataConCtxt name)	$ 
         kcHsTyVars ex_tvs $ \ex_tvs' -> do
         do { ex_ctxt' <- kcHsContext ex_ctxt
@@ -595,7 +599,8 @@ kcDataDecl decl@(TyData {tcdND = new_or_data, tcdCtxt = ctxt, tcdCons = cons})
            ; res'     <- case res of
                 ResTyH98 -> return ResTyH98
                 ResTyGADT ty -> do { ty' <- kcHsSigType ty; return (ResTyGADT ty') }
-           ; return (ConDecl name expl ex_tvs' ex_ctxt' details' res' Nothing) }
+           ; return (con_decl { con_qvars = ex_tvs', con_cxt = ex_ctxt'
+                              , con_details = details', con_res = res' }) }
 
     kc_con_details (PrefixCon btys) 
 	= do { btys' <- mapM kc_larg_ty btys 
@@ -826,7 +831,8 @@ tcConDecl :: Bool 		-- True <=> -funbox-strict_fields
 	  -> TcM DataCon
 
 tcConDecl unbox_strict existential_ok rep_tycon res_tmpl 	-- Data types
-	  (ConDecl name _ tvs ctxt details res_ty _)
+	  (ConDecl {con_name =name, con_qvars = tvs, con_cxt = ctxt
+                   , con_details = details, con_res = res_ty })
   = addErrCtxt (dataConCtxt name)	$ 
     tcTyVarBndrs tvs			$ \ tvs' -> do 
     { ctxt' <- tcHsKindedContext ctxt
@@ -1236,7 +1242,7 @@ mkRecSelBind (tycon, sel_name)
     data_tvs   = tyVarsOfType data_ty
     is_naughty = not (tyVarsOfType field_ty `subVarSet` data_tvs)  
     (field_tvs, field_theta, field_tau) = tcSplitSigmaTy field_ty
-    sel_ty | is_naughty = unitTy
+    sel_ty | is_naughty = unitTy  -- See Note [Naughty record selectors]
            | otherwise  = mkForAllTys (varSetElems data_tvs ++ field_tvs) $ 
     	     	          mkPhiTy (dataConStupidTheta con1) $	-- Urgh!
     	     	          mkPhiTy field_theta               $	-- Urgh!
@@ -1299,10 +1305,12 @@ so that if the user tries to use 'x' as a selector we can bleat
 helpfully, rather than saying unhelpfully that 'x' is not in scope.
 Hence the sel_naughty flag, to identify record selectors that don't really exist.
 
-In general, a field is naughty if its type mentions a type variable that
-isn't in the result type of the constructor.
+In general, a field is "naughty" if its type mentions a type variable that
+isn't in the result type of the constructor.  Note that this *allows*
+GADT record selectors (Note [GADT record selectors]) whose types may look 
+like     sel :: T [a] -> a
 
-We make a dummy binding 
+For naughty selectors we make a dummy binding 
    sel = ()
 for naughty selectors, so that the later type-check will add them to the
 environment, and they'll be exported.  The function is never called, because