X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Fiface%2FTcIface.lhs;h=32735a4e3621f10a7abe74ed6237370aff1a678f;hp=2dcdf78bd3f5049c5ee7ccca2766fec16e2734cc;hb=1fa3580c54985d73178d1d396b897176a57cd7f3;hpb=6084fb5517da34f65034370a3695e2af3b85ce2b

diff --git a/compiler/iface/TcIface.lhs b/compiler/iface/TcIface.lhs
index 2dcdf78..32735a4 100644
--- a/compiler/iface/TcIface.lhs
+++ b/compiler/iface/TcIface.lhs
@@ -68,7 +68,7 @@ This module takes
 An IfaceDecl is populated with RdrNames, and these are not renamed to
 Names before typechecking, because there should be no scope errors etc.
 
-	-- For (b) consider: f = $(...h....)
+	-- For (b) consider: f = \$(...h....)
 	-- where h is imported, and calls f via an hi-boot file.  
 	-- This is bad!  But it is not seen as a staging error, because h
 	-- is indeed imported.  We don't want the type-checker to black-hole 
@@ -356,14 +356,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 +384,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, 
@@ -505,6 +509,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.
 
 %************************************************************************
 %*									*
@@ -880,6 +901,7 @@ tcIdInfo ignore_prags name ty info
     -- we start; default assumption is that it has CAFs
     init_info = vanillaIdInfo
 
+    tcPrag :: IdInfo -> IfaceInfoItem -> IfL IdInfo
     tcPrag info HsNoCafRefs         = return (info `setCafInfo`   NoCafRefs)
     tcPrag info (HsArity arity)     = return (info `setArityInfo` arity)
     tcPrag info (HsStrictness str)  = return (info `setAllStrictnessInfo` Just str)
@@ -985,9 +1007,9 @@ tcIfaceGlobal name
 
 	  ; _ -> do
 
-	{ (eps,hpt) <- getEpsAndHpt
- 	; dflags <- getDOpts
-	; case lookupType dflags hpt (eps_PTE eps) name of {
+	{ hsc_env <- getTopEnv
+        ; mb_thing <- liftIO (lookupTypeHscEnv hsc_env name)
+	; case mb_thing of {
 	    Just thing -> return thing ;
 	    Nothing    -> do
 
@@ -1125,13 +1147,13 @@ newExtCoreBndr (IfLetBndr var ty _)    -- Ignoring IdInfo for now
 -----------------------
 bindIfaceTyVar :: IfaceTvBndr -> (TyVar -> IfL a) -> IfL a
 bindIfaceTyVar (occ,kind) thing_inside
-  = do	{ name <- newIfaceName (mkTyVarOcc occ)
+  = do	{ name <- newIfaceName (mkTyVarOccFS occ)
    	; tyvar <- mk_iface_tyvar name kind
 	; extendIfaceTyVarEnv [tyvar] (thing_inside tyvar) }
 
 bindIfaceTyVars :: [IfaceTvBndr] -> ([TyVar] -> IfL a) -> IfL a
 bindIfaceTyVars bndrs thing_inside
-  = do	{ names <- newIfaceNames (map mkTyVarOcc occs)
+  = do	{ names <- newIfaceNames (map mkTyVarOccFS occs)
   	; tyvars <- zipWithM mk_iface_tyvar names kinds
 	; extendIfaceTyVarEnv tyvars (thing_inside tyvars) }
   where