X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fiface%2FTcIface.lhs;h=42dd3a8ac24c6db9854cc52fc590a1774fb2dad2;hb=d7b36bbbcd56ee14656223d02e32f5a1f52ea17b;hp=b36aad517749abdd22eb1d8de5312d08520ff269;hpb=beb406f4092f020b79077eb019dbee7c32a72238;p=ghc-hetmet.git

diff --git a/compiler/iface/TcIface.lhs b/compiler/iface/TcIface.lhs
index b36aad5..42dd3a8 100644
--- a/compiler/iface/TcIface.lhs
+++ b/compiler/iface/TcIface.lhs
@@ -127,7 +127,8 @@ checkWiredInTyCon tc
   = return ()
   | otherwise
   = do	{ mod <- getModule
-	; unless (mod == nameModule tc_name)
+	; ASSERT( isExternalName tc_name ) 
+	  unless (mod == nameModule tc_name)
 		 (initIfaceTcRn (loadWiredInHomeIface tc_name))
 		-- Don't look for (non-existent) Float.hi when
 		-- compiling Float.lhs, which mentions Float of course
@@ -144,7 +145,8 @@ importDecl name
     do	{ traceIf nd_doc
 
 	-- Load the interface, which should populate the PTE
-	; mb_iface <- loadInterface nd_doc (nameModule name) ImportBySystem
+	; mb_iface <- ASSERT2( isExternalName name, ppr name ) 
+	  	      loadInterface nd_doc (nameModule name) ImportBySystem
 	; case mb_iface of {
 		Failed err_msg  -> return (Failed err_msg) ;
 		Succeeded _ -> do
@@ -356,14 +358,13 @@ tcIfaceDecl ignore_prags (IfaceId {ifName = occ_name, ifType = iface_type, ifIdI
 	; info <- tcIdInfo ignore_prags name ty info
 	; return (AnId (mkVanillaGlobalWithInfo name ty info)) }
 
-tcIfaceDecl _
-	    (IfaceData {ifName = occ_name, 
-			ifTyVars = tv_bndrs, 
-			ifCtxt = ctxt, ifGadtSyntax = gadt_syn,
-			ifCons = rdr_cons, 
-			ifRec = is_rec, 
-			ifGeneric = want_generic,
-			ifFamInst = mb_family })
+tcIfaceDecl _ (IfaceData {ifName = occ_name, 
+			  ifTyVars = tv_bndrs, 
+			  ifCtxt = ctxt, ifGadtSyntax = gadt_syn,
+			  ifCons = rdr_cons, 
+			  ifRec = is_rec, 
+			  ifGeneric = want_generic,
+			  ifFamInst = mb_family })
   = do	{ tc_name <- lookupIfaceTop occ_name
 	; bindIfaceTyVars tv_bndrs $ \ tyvars -> do
 
@@ -385,25 +386,30 @@ tcIfaceDecl _
 	; return (ATyCon tycon)
     }}
 
-tcIfaceDecl _
-	    (IfaceSyn {ifName = occ_name, ifTyVars = tv_bndrs, 
-		       ifOpenSyn = isOpen, ifSynRhs = rdr_rhs_ty,
-		       ifFamInst = mb_family})
+tcIfaceDecl _ (IfaceSyn {ifName = occ_name, ifTyVars = tv_bndrs, 
+		         ifSynRhs = mb_rhs_ty,
+		         ifSynKind = kind, ifFamInst = mb_family})
    = bindIfaceTyVars tv_bndrs $ \ tyvars -> do
      { tc_name <- lookupIfaceTop occ_name
-     ; rhs_tyki <- tcIfaceType rdr_rhs_ty
-     ; let rhs = if isOpen then OpenSynTyCon rhs_tyki Nothing
-			   else SynonymTyCon rhs_tyki
-     ; famInst <- case mb_family of
-		    Nothing         -> return Nothing
-		    Just (fam, tys) -> 
-		      do { famTyCon <- tcIfaceTyCon fam
-		         ; insttys <- mapM tcIfaceType tys
-		         ; return $ Just (famTyCon, insttys)
-		         }
-     ; tycon <- buildSynTyCon tc_name tyvars rhs famInst
+     ; rhs_kind <- tcIfaceType kind	-- Note [Synonym kind loop]
+     ; ~(rhs, fam) <- forkM (mk_doc tc_name) $ 
+       	      	      do { rhs <- tc_syn_rhs rhs_kind mb_rhs_ty
+			 ; fam <- tc_syn_fam mb_family
+			 ; return (rhs, fam) }
+     ; tycon <- buildSynTyCon tc_name tyvars rhs rhs_kind fam
      ; return $ ATyCon tycon
      }
+   where
+     mk_doc n = ptext (sLit "Type syonym") <+> ppr n
+     tc_syn_rhs kind Nothing   = return (OpenSynTyCon kind Nothing)
+     tc_syn_rhs _    (Just ty) = do { rhs_ty <- tcIfaceType ty
+		   		    ; return (SynonymTyCon rhs_ty) }
+     tc_syn_fam Nothing 
+       = return Nothing
+     tc_syn_fam (Just (fam, tys)) 
+       = do { famTyCon <- tcIfaceTyCon fam
+      	    ; insttys <- mapM tcIfaceType tys
+       	    ; return $ Just (famTyCon, insttys) }
 
 tcIfaceDecl ignore_prags
 	    (IfaceClass {ifCtxt = rdr_ctxt, ifName = occ_name, 
@@ -488,11 +494,15 @@ tcIfaceDataCons tycon_name tycon _ if_cons
  	; arg_tys <- forkM (mk_doc name) (mapM tcIfaceType args)
 	; lbl_names <- mapM lookupIfaceTop field_lbls
 
+	-- Remember, tycon is the representation tycon
+	; let orig_res_ty = mkFamilyTyConApp tycon 
+				(substTyVars (mkTopTvSubst eq_spec) univ_tyvars)
+
 	; buildDataCon name is_infix {- Not infix -}
 		       stricts lbl_names
 		       univ_tyvars ex_tyvars 
                        eq_spec theta 
-		       arg_tys tycon
+		       arg_tys orig_res_ty tycon
 	}
     mk_doc con_name = ptext (sLit "Constructor") <+> ppr con_name
 
@@ -505,6 +515,23 @@ tcIfaceEqSpec spec
                               ; return (tv,ty) }
 \end{code}
 
+Note [Synonym kind loop]
+~~~~~~~~~~~~~~~~~~~~~~~~
+Notice that we eagerly grab the *kind* from the interface file, but
+build a forkM thunk for the *rhs* (and family stuff).  To see why, 
+consider this (Trac #2412)
+
+M.hs:       module M where { import X; data T = MkT S }
+X.hs:       module X where { import {-# SOURCE #-} M; type S = T }
+M.hs-boot:  module M where { data T }
+
+When kind-checking M.hs we need S's kind.  But we do not want to
+find S's kind from (typeKind S-rhs), because we don't want to look at
+S-rhs yet!  Since S is imported from X.hi, S gets just one chance to
+be defined, and we must not do that until we've finished with M.T.
+
+Solution: record S's kind in the interface file; now we can safely
+look at it.
 
 %************************************************************************
 %*									*
@@ -1026,7 +1053,8 @@ ifCheckWiredInThing name
 		-- we may typecheck GHC.Base.hi. At that point, GHC.Base is not in
 		-- the HPT, so without the test we'll demand-load it into the PIT!
 		-- C.f. the same test in checkWiredInTyCon above
-	; unless (mod == nameModule name)
+	; ASSERT2( isExternalName name, ppr name ) 
+	  unless (mod == nameModule name)
 		 (loadWiredInHomeIface name) }
 
 tcIfaceTyCon :: IfaceTyCon -> IfL TyCon