Check whether the main function is actually exported (#414)

[ghc-hetmet.git] / compiler / typecheck / TcRnDriver.lhs

diff --git a/compiler/typecheck/TcRnDriver.lhs b/compiler/typecheck/TcRnDriver.lhs
index 12069ff..511fcbf 100644 (file)
--- a/compiler/typecheck/TcRnDriver.lhs
+++ b/compiler/typecheck/TcRnDriver.lhs
@@ -40,6 +40,7 @@ import TcHsSyn
 import TcExpr
 import TcRnMonad
 import TcType
+import Coercion
 import Inst
 import FamInst
 import InstEnv
@@ -74,6 +75,7 @@ import Name
 import NameEnv
 import NameSet
 import TyCon
+import TysPrim
 import TysWiredIn
 import SrcLoc
 import HscTypes
@@ -176,6 +178,9 @@ tcRnModule hsc_env hsc_src save_rn_syntax
        tcg_env <- rnExports (isJust maybe_mod) export_ies tcg_env ;
        traceRn (text "rn4b: after exportss") ;
 
+                -- Check that main is exported (must be after rnExports)
+        checkMainExported tcg_env ;
+
        -- Compare the hi-boot iface (if any) with the real thing
        -- Must be done after processing the exports
        tcg_env <- checkHiBootIface tcg_env boot_iface ;
@@ -555,6 +560,15 @@ checkHiBootIface
                -- Check the exports of the boot module, one by one
        ; mapM_ check_export boot_exports
 
+               -- Check instance declarations
+       ; mb_dfun_prs <- mapM check_inst boot_insts
+       ; let tcg_env' = tcg_env { tcg_binds    = binds `unionBags` dfun_binds,
+                                  tcg_type_env = extendTypeEnvWithIds local_type_env boot_dfuns }
+             dfun_prs   = catMaybes mb_dfun_prs
+             boot_dfuns = map fst dfun_prs
+             dfun_binds = listToBag [ mkVarBind boot_dfun (nlHsVar dfun)
+                                    | (boot_dfun, dfun) <- dfun_prs ]
+
                -- Check for no family instances
        ; unless (null boot_fam_insts) $
            panic ("TcRnDriver.checkHiBootIface: Cannot handle family " ++
@@ -569,7 +583,7 @@ checkHiBootIface
              final_type_env = extendTypeEnvWithIds local_type_env boot_dfuns
              dfun_prs   = catMaybes mb_dfun_prs
              boot_dfuns = map fst dfun_prs
-             dfun_binds = listToBag [ noLoc $ VarBind boot_dfun (nlHsVar dfun)
+             dfun_binds = listToBag [ mkVarBind boot_dfun (nlHsVar dfun)
                                     | (boot_dfun, dfun) <- dfun_prs ]
 
         ; failIfErrsM
@@ -929,15 +943,16 @@ check_main dflags tcg_env
                                                    (mkTyConApp ioTyCon [res_ty])
              ; co  = mkWpTyApps [res_ty]
              ; rhs = nlHsApp (mkLHsWrap co (nlHsVar run_main_id)) main_expr
-             ; main_bind = noLoc (VarBind root_main_id rhs) }
+             ; main_bind = mkVarBind root_main_id rhs }
 
-       ; return (tcg_env { tcg_binds = tcg_binds tcg_env 
+       ; return (tcg_env { tcg_main  = Just main_name,
+                            tcg_binds = tcg_binds tcg_env
                                        `snocBag` main_bind,
                            tcg_dus   = tcg_dus tcg_env
                                        `plusDU` usesOnly (unitFV main_name)
                        -- Record the use of 'main', so that we don't 
                        -- complain about it being defined but not used
-                }) 
+                })
     }}}
   where
     mod         = tcg_mod tcg_env
@@ -953,8 +968,13 @@ check_main dflags tcg_env
     mainCtxt  = ptext (sLit "When checking the type of the") <+> pp_main_fn
     noMainMsg = ptext (sLit "The") <+> pp_main_fn
                <+> ptext (sLit "is not defined in module") <+> quotes (ppr main_mod)
-    pp_main_fn | main_fn == main_RDR_Unqual = ptext (sLit "function") <+> quotes (ppr main_fn)
-              | otherwise                  = ptext (sLit "main function") <+> quotes (ppr main_fn)
+    pp_main_fn = ppMainFn main_fn
+
+ppMainFn main_fn
+  | main_fn == main_RDR_Unqual
+  = ptext (sLit "function") <+> quotes (ppr main_fn)
+  | otherwise
+  = ptext (sLit "main function") <+> quotes (ppr main_fn)
               
 -- | Get the unqualified name of the function to use as the \"main\" for the main module.
 -- Either returns the default name or the one configured on the command line with -main-is
@@ -962,6 +982,17 @@ getMainFun :: DynFlags -> RdrName
 getMainFun dflags = case (mainFunIs dflags) of
     Just fn -> mkRdrUnqual (mkVarOccFS (mkFastString fn))
     Nothing -> main_RDR_Unqual
+
+checkMainExported :: TcGblEnv -> TcM ()
+checkMainExported tcg_env = do
+  dflags    <- getDOpts
+  case tcg_main tcg_env of
+    Nothing -> return () -- not the main module
+    Just main_name -> do
+      let main_mod = mainModIs dflags
+      checkTc (main_name `elem` concatMap availNames (tcg_exports tcg_env)) $
+              ptext (sLit "The") <+> ppMainFn (nameRdrName main_name) <+>
+              ptext (sLit "is not exported by module") <+> quotes (ppr main_mod)
 \end{code}
 
 Note [Root-main Id]
@@ -1392,7 +1423,7 @@ tcRnGetInfo :: HscEnv
            -> Name
            -> IO (Messages, Maybe (TyThing, Fixity, [Instance]))
 
--- Used to implemnent :info in GHCi
+-- Used to implement :info in GHCi
 --
 -- Look up a RdrName and return all the TyThings it might be
 -- A capitalised RdrName is given to us in the DataName namespace,
@@ -1571,8 +1602,12 @@ ppr_tydecls tycons
   where
     le_sig tycon1 tycon2 = getOccName tycon1 <= getOccName tycon2
     ppr_tycon tycon 
-      | isCoercionTyCon tycon = ptext (sLit "coercion") <+> ppr tycon
+      | isCoercionTyCon tycon 
+      = sep [ptext (sLit "coercion") <+> ppr tycon <+> ppr tvs
+            , nest 2 (dcolon <+> pprEqPred (coercionKind (mkTyConApp tycon (mkTyVarTys tvs))))]
       | otherwise             = ppr (tyThingToIfaceDecl (ATyCon tycon))
+      where
+        tvs = take (tyConArity tycon) alphaTyVars
 
 ppr_rules :: [CoreRule] -> SDoc
 ppr_rules [] = empty