Clean the bootstrapping extensible-exceptions package

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

diff --git a/compiler/iface/TcIface.lhs b/compiler/iface/TcIface.lhs
index 43ec524..d9072f8 100644 (file)
--- 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.
 
 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 
        -- 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 

@@ -127,7 +127,8 @@ checkWiredInTyCon tc
   = return ()
   | otherwise
   = do { mod <- getModule
   = 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
                 (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
     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
        ; case mb_iface of {
                Failed err_msg  -> return (Failed err_msg) ;
                Succeeded _ -> do

@@ -354,16 +356,15 @@ tcIfaceDecl ignore_prags (IfaceId {ifName = occ_name, ifType = iface_type, ifIdI
   = do { name <- lookupIfaceTop occ_name
        ; ty <- tcIfaceType iface_type
        ; info <- tcIdInfo ignore_prags name ty info
   = do { name <- lookupIfaceTop occ_name
        ; ty <- tcIfaceType iface_type
        ; info <- tcIdInfo ignore_prags name ty info

-       ; return (AnId (mkVanillaGlobal 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 })
+       ; 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 })

   = do { tc_name <- lookupIfaceTop occ_name
        ; bindIfaceTyVars tv_bndrs $ \ tyvars -> do
 
   = do { tc_name <- lookupIfaceTop occ_name
        ; bindIfaceTyVars tv_bndrs $ \ tyvars -> do
 

@@ -385,25 +386,30 @@ tcIfaceDecl _
        ; return (ATyCon tycon)
     }}
 
        ; 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
    = 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
      }
      ; 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, 
 
 tcIfaceDecl ignore_prags
            (IfaceClass {ifCtxt = rdr_ctxt, ifName = occ_name, 

@@ -505,6 +511,23 @@ tcIfaceEqSpec spec
                               ; return (tv,ty) }
 \end{code}
 
                               ; 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.

 
 %************************************************************************
 %*                                                                     *
 
 %************************************************************************
 %*                                                                     *

@@ -525,7 +548,7 @@ tcIfaceFamInst :: IfaceFamInst -> IfL FamInst
 tcIfaceFamInst (IfaceFamInst { ifFamInstTyCon = tycon, 
                               ifFamInstFam = fam, ifFamInstTys = mb_tcs })
 --     { tycon'  <- forkM (ptext (sLit "Inst tycon") <+> ppr tycon) $
 tcIfaceFamInst (IfaceFamInst { ifFamInstTyCon = tycon, 
                               ifFamInstFam = fam, ifFamInstTys = mb_tcs })
 --     { tycon'  <- forkM (ptext (sLit "Inst tycon") <+> ppr tycon) $

--- ^^^this line doesn't work, but vvv this does => CPP in Haskell = evil!
+-- the above line doesn't work, but this below does => CPP in Haskell = evil!

     = do tycon'  <- forkM (text ("Inst tycon") <+> ppr tycon) $
                     tcIfaceTyCon tycon
          let mb_tcs' = map (fmap ifaceTyConName) mb_tcs
     = do tycon'  <- forkM (text ("Inst tycon") <+> ppr tycon) $
                     tcIfaceTyCon tycon
          let mb_tcs' = map (fmap ifaceTyConName) mb_tcs

@@ -880,6 +903,7 @@ tcIdInfo ignore_prags name ty info
     -- we start; default assumption is that it has CAFs
     init_info = vanillaIdInfo
 
     -- 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)
     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 +1009,9 @@ tcIfaceGlobal name
 
          ; _ -> do
 
 
          ; _ -> 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
 
            Just thing -> return thing ;
            Nothing    -> do
 

@@ -1025,7 +1049,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
                -- 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
                 (loadWiredInHomeIface name) }
 
 tcIfaceTyCon :: IfaceTyCon -> IfL TyCon

@@ -1125,13 +1150,13 @@ newExtCoreBndr (IfLetBndr var ty _)    -- Ignoring IdInfo for now
 -----------------------
 bindIfaceTyVar :: IfaceTvBndr -> (TyVar -> IfL a) -> IfL a
 bindIfaceTyVar (occ,kind) thing_inside
 -----------------------
 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
        ; 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
        ; tyvars <- zipWithM mk_iface_tyvar names kinds
        ; extendIfaceTyVarEnv tyvars (thing_inside tyvars) }
   where