X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcRnMonad.lhs;h=a7c930d33f233969f028882d4d0639a230da0b2a;hb=79011516105291b58324ce71a87f6bb26a131090;hp=56f073fdc15885df48a6fec07c5e35fa13d46b20;hpb=ec0b859902e717c24addff49f9a83efb927fb669;p=ghc-hetmet.git diff --git a/compiler/typecheck/TcRnMonad.lhs b/compiler/typecheck/TcRnMonad.lhs index 56f073f..a7c930d 100644 --- a/compiler/typecheck/TcRnMonad.lhs +++ b/compiler/typecheck/TcRnMonad.lhs @@ -3,25 +3,22 @@ % \begin{code} +{-# OPTIONS -w #-} +-- The above warning supression flag is a temporary kludge. +-- While working on this module you are encouraged to remove it and fix +-- any warnings in the module. See +-- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings +-- for details + module TcRnMonad( module TcRnMonad, module TcRnTypes, module IOEnv ) where -#include "HsVersions.h" - import TcRnTypes -- Re-export all import IOEnv -- Re-export all -#if defined(GHCI) -import TypeRep -import IdInfo -import TysWiredIn -import PrelNames -import {-#SOURCE#-} TcEnv -#endif - import HsSyn hiding (LIE) import HscTypes import Module @@ -31,6 +28,7 @@ import TcType import InstEnv import FamInstEnv +import Coercion import Var import Id import VarSet @@ -44,14 +42,17 @@ import Bag import Outputable import UniqSupply import Unique +import LazyUniqFM import DynFlags import StaticFlags import FastString import Panic +import Util import System.IO import Data.IORef import Control.Exception +import Control.Monad \end{code} @@ -63,11 +64,6 @@ import Control.Exception %************************************************************************ \begin{code} -ioToTcRn :: IO r -> TcRn r -ioToTcRn = ioToIOEnv -\end{code} - -\begin{code} initTc :: HscEnv -> HscSource @@ -92,12 +88,13 @@ initTc hsc_env hsc_src keep_rn_syntax mod do_this | otherwise = Nothing ; gbl_env = TcGblEnv { - tcg_mod = mod, - tcg_src = hsc_src, - tcg_rdr_env = hsc_global_rdr_env hsc_env, - tcg_fix_env = emptyNameEnv, - tcg_default = Nothing, - tcg_type_env = hsc_global_type_env hsc_env, + tcg_mod = mod, + tcg_src = hsc_src, + tcg_rdr_env = hsc_global_rdr_env hsc_env, + tcg_fix_env = emptyNameEnv, + tcg_field_env = emptyNameEnv, + tcg_default = Nothing, + tcg_type_env = hsc_global_type_env hsc_env, tcg_type_env_var = type_env_var, tcg_inst_env = emptyInstEnv, tcg_fam_inst_env = emptyFamInstEnv, @@ -120,11 +117,12 @@ initTc hsc_env hsc_src keep_rn_syntax mod do_this tcg_dfun_n = dfun_n_var, tcg_keep = keep_var, tcg_doc = Nothing, - tcg_hmi = HaddockModInfo Nothing Nothing Nothing Nothing + tcg_hmi = HaddockModInfo Nothing Nothing Nothing Nothing, + tcg_hpc = False } ; lcl_env = TcLclEnv { tcl_errs = errs_var, - tcl_loc = mkGeneralSrcSpan FSLIT("Top level"), + tcl_loc = mkGeneralSrcSpan (fsLit "Top level"), tcl_ctxt = [], tcl_rdr = emptyLocalRdrEnv, tcl_th_ctxt = topStage, @@ -137,7 +135,6 @@ initTc hsc_env hsc_src keep_rn_syntax mod do_this -- OK, here's the business end! maybe_res <- initTcRnIf 'a' hsc_env gbl_env lcl_env $ - addBreakpointBindings $ do { r <- tryM do_this ; case r of Right res -> return (Just res) @@ -164,12 +161,6 @@ initTcPrintErrors env mod todo = do return res \end{code} -\begin{code} -addBreakpointBindings :: TcM a -> TcM a -addBreakpointBindings thing_inside - = thing_inside -\end{code} - %************************************************************************ %* * Initialisation @@ -190,7 +181,7 @@ initTcRnIf uniq_tag hsc_env gbl_env lcl_env thing_inside ; let { env = Env { env_top = hsc_env, env_us = us_var, env_gbl = gbl_env, - env_lcl = lcl_env } } + env_lcl = lcl_env} } ; runIOEnv env thing_inside } @@ -251,7 +242,8 @@ unsetOptM :: DynFlag -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a unsetOptM flag = updEnv (\ env@(Env { env_top = top }) -> env { env_top = top { hsc_dflags = dopt_unset (hsc_dflags top) flag}} ) -ifOptM :: DynFlag -> TcRnIf gbl lcl () -> TcRnIf gbl lcl () -- Do it flag is true +-- | Do it flag is true +ifOptM :: DynFlag -> TcRnIf gbl lcl () -> TcRnIf gbl lcl () ifOptM flag thing_inside = do { b <- doptM flag; if b then thing_inside else return () } @@ -332,7 +324,7 @@ newUniqueSupply newLocalName :: Name -> TcRnIf gbl lcl Name newLocalName name -- Make a clone = do { uniq <- newUnique - ; return (mkInternalName uniq (nameOccName name) (getSrcLoc name)) } + ; return (mkInternalName uniq (nameOccName name) (getSrcSpan name)) } newSysLocalIds :: FastString -> [TcType] -> TcRnIf gbl lcl [TcId] newSysLocalIds fs tys @@ -361,7 +353,7 @@ traceHiDiffs = traceOptIf Opt_D_dump_hi_diffs traceOptIf :: DynFlag -> SDoc -> TcRnIf m n () -- No RdrEnv available, so qualify everything traceOptIf flag doc = ifOptM flag $ - ioToIOEnv (printForUser stderr alwaysQualify doc) + liftIO (printForUser stderr alwaysQualify doc) traceOptTcRn :: DynFlag -> SDoc -> TcRn () traceOptTcRn flag doc = ifOptM flag $ do @@ -374,7 +366,8 @@ traceOptTcRn flag doc = ifOptM flag $ do dumpTcRn :: SDoc -> TcRn () dumpTcRn doc = do { rdr_env <- getGlobalRdrEnv ; - ioToTcRn (printForUser stderr (mkPrintUnqualified rdr_env) doc) } + dflags <- getDOpts ; + liftIO (printForUser stderr (mkPrintUnqualified dflags rdr_env) doc) } dumpOptTcRn :: DynFlag -> SDoc -> TcRn () dumpOptTcRn flag doc = ifOptM flag (dumpTcRn doc) @@ -400,6 +393,9 @@ tcIsHsBoot = do { env <- getGblEnv; return (isHsBoot (tcg_src env)) } getGlobalRdrEnv :: TcRn GlobalRdrEnv getGlobalRdrEnv = do { env <- getGblEnv; return (tcg_rdr_env env) } +getRdrEnvs :: TcRn (GlobalRdrEnv, LocalRdrEnv) +getRdrEnvs = do { (gbl,lcl) <- getEnvs; return (tcg_rdr_env gbl, tcl_rdr lcl) } + getImports :: TcRn ImportAvails getImports = do { env <- getGblEnv; return (tcg_imports env) } @@ -411,6 +407,14 @@ extendFixityEnv new_bit = updGblEnv (\env@(TcGblEnv { tcg_fix_env = old_fix_env }) -> env {tcg_fix_env = extendNameEnvList old_fix_env new_bit}) +getRecFieldEnv :: TcRn RecFieldEnv +getRecFieldEnv = do { env <- getGblEnv; return (tcg_field_env env) } + +extendRecFieldEnv :: RecFieldEnv -> RnM a -> RnM a +extendRecFieldEnv new_bit + = updGblEnv (\env@(TcGblEnv { tcg_field_env = old_env }) -> + env {tcg_field_env = old_env `plusNameEnv` new_bit}) + getDeclaredDefaultTys :: TcRn (Maybe [Type]) getDeclaredDefaultTys = do { env <- getGblEnv; return (tcg_default env) } \end{code} @@ -469,15 +473,16 @@ addErrAt loc msg = addLongErrAt loc msg empty addLongErrAt :: SrcSpan -> Message -> Message -> TcRn () addLongErrAt loc msg extra - = do { traceTc (ptext SLIT("Adding error:") <+> (mkLocMessage loc (msg $$ extra))) ; + = do { traceTc (ptext (sLit "Adding error:") <+> (mkLocMessage loc (msg $$ extra))) ; errs_var <- getErrsVar ; rdr_env <- getGlobalRdrEnv ; - let { err = mkLongErrMsg loc (mkPrintUnqualified rdr_env) msg extra } ; + dflags <- getDOpts ; + let { err = mkLongErrMsg loc (mkPrintUnqualified dflags rdr_env) msg extra } ; (warns, errs) <- readMutVar errs_var ; writeMutVar errs_var (warns, errs `snocBag` err) } addErrs :: [(SrcSpan,Message)] -> TcRn () -addErrs msgs = mappM_ add msgs +addErrs msgs = mapM_ add msgs where add (loc,msg) = addErrAt loc msg @@ -488,22 +493,23 @@ addReportAt :: SrcSpan -> Message -> TcRn () addReportAt loc msg = do { errs_var <- getErrsVar ; rdr_env <- getGlobalRdrEnv ; - let { warn = mkWarnMsg loc (mkPrintUnqualified rdr_env) msg } ; + dflags <- getDOpts ; + let { warn = mkWarnMsg loc (mkPrintUnqualified dflags rdr_env) msg } ; (warns, errs) <- readMutVar errs_var ; writeMutVar errs_var (warns `snocBag` warn, errs) } addWarn :: Message -> TcRn () -addWarn msg = addReport (ptext SLIT("Warning:") <+> msg) +addWarn msg = addReport (ptext (sLit "Warning:") <+> msg) addWarnAt :: SrcSpan -> Message -> TcRn () -addWarnAt loc msg = addReportAt loc (ptext SLIT("Warning:") <+> msg) +addWarnAt loc msg = addReportAt loc (ptext (sLit "Warning:") <+> msg) addLocWarn :: Located e -> (e -> Message) -> TcRn () addLocWarn (L loc e) fn = addReportAt loc (fn e) checkErr :: Bool -> Message -> TcRn () -- Add the error if the bool is False -checkErr ok msg = checkM ok (addErr msg) +checkErr ok msg = unless ok (addErr msg) warnIf :: Bool -> Message -> TcRn () warnIf True msg = addWarn msg @@ -552,7 +558,20 @@ recoverM recover thing = do { mb_res <- try_m thing ; case mb_res of Left exn -> recover - Right res -> returnM res } + Right res -> return res } + + +----------------------- +mapAndRecoverM :: (a -> TcRn b) -> [a] -> TcRn [b] +-- Drop elements of the input that fail, so the result +-- list can be shorter than the argument list +mapAndRecoverM f [] = return [] +mapAndRecoverM f (x:xs) = do { mb_r <- tryM (f x) + ; rs <- mapAndRecoverM f xs + ; return (case mb_r of + Left _ -> rs + Right r -> r:rs) } + ----------------------- tryTc :: TcRn a -> TcRn (Messages, Maybe a) @@ -626,7 +645,7 @@ checkNoErrs main = do { (msgs, mb_res) <- tryTcLIE main ; addMessages msgs ; case mb_res of - Nothing -> failM + Nothing -> failM Just val -> return val } @@ -664,7 +683,7 @@ setErrCtxt :: ErrCtxt -> TcM a -> TcM a setErrCtxt ctxt = updLclEnv (\ env -> env { tcl_ctxt = ctxt }) addErrCtxt :: Message -> TcM a -> TcM a -addErrCtxt msg = addErrCtxtM (\env -> returnM (env, msg)) +addErrCtxt msg = addErrCtxtM (\env -> return (env, msg)) addErrCtxtM :: (TidyEnv -> TcM (TidyEnv, Message)) -> TcM a -> TcM a addErrCtxtM msg = updCtxt (\ msgs -> msg : msgs) @@ -704,7 +723,7 @@ addErrTc err_msg = do { env0 <- tcInitTidyEnv ; addErrTcM (env0, err_msg) } addErrsTc :: [Message] -> TcM () -addErrsTc err_msgs = mappM_ addErrTc err_msgs +addErrsTc err_msgs = mapM_ addErrTc err_msgs addErrTcM :: (TidyEnv, Message) -> TcM () addErrTcM (tidy_env, err_msg) @@ -725,7 +744,7 @@ failWithTcM local_and_msg = addErrTcM local_and_msg >> failM checkTc :: Bool -> Message -> TcM () -- Check that the boolean is true -checkTc True err = returnM () +checkTc True err = return () checkTc False err = failWithTc err \end{code} @@ -733,11 +752,14 @@ checkTc False err = failWithTc err \begin{code} addWarnTc :: Message -> TcM () -addWarnTc msg +addWarnTc msg = do { env0 <- tcInitTidyEnv + ; addWarnTcM (env0, msg) } + +addWarnTcM :: (TidyEnv, Message) -> TcM () +addWarnTcM (env0, msg) = do { ctxt <- getErrCtxt ; - env0 <- tcInitTidyEnv ; ctxt_msgs <- do_ctxt env0 ctxt ; - addWarn (vcat (msg : ctxt_to_use ctxt_msgs)) } + addReport (vcat (ptext (sLit "Warning:") <+> msg : ctxt_to_use ctxt_msgs)) } warnTc :: Bool -> Message -> TcM () warnTc warn_if_true warn_msg @@ -792,11 +814,9 @@ debugTc is useful for monadic debugging code \begin{code} debugTc :: TcM () -> TcM () -#ifdef DEBUG -debugTc thing = thing -#else -debugTc thing = return () -#endif +debugTc thing + | debugIsOn = thing + | otherwise = return () \end{code} %************************************************************************ @@ -836,7 +856,7 @@ extendLIE inst extendLIEs :: [Inst] -> TcM () extendLIEs [] - = returnM () + = return () extendLIEs insts = do { lie_var <- getLIEVar ; lie <- readMutVar lie_var ; @@ -865,9 +885,11 @@ setLclTypeEnv lcl_env thing_inside recordThUse :: TcM () recordThUse = do { env <- getGblEnv; writeMutVar (tcg_th_used env) True } -keepAliveTc :: Name -> TcM () -- Record the name in the keep-alive set -keepAliveTc n = do { env <- getGblEnv; - ; updMutVar (tcg_keep env) (`addOneToNameSet` n) } +keepAliveTc :: Id -> TcM () -- Record the name in the keep-alive set +keepAliveTc id + | isLocalId id = do { env <- getGblEnv; + ; updMutVar (tcg_keep env) (`addOneToNameSet` idName id) } + | otherwise = return () keepAliveSetTc :: NameSet -> TcM () -- Record the name in the keep-alive set keepAliveSetTc ns = do { env <- getGblEnv; @@ -907,8 +929,8 @@ setLocalRdrEnv rdr_env thing_inside mkIfLclEnv :: Module -> SDoc -> IfLclEnv mkIfLclEnv mod loc = IfLclEnv { if_mod = mod, if_loc = loc, - if_tv_env = emptyOccEnv, - if_id_env = emptyOccEnv } + if_tv_env = emptyUFM, + if_id_env = emptyUFM } initIfaceTcRn :: IfG a -> TcRn a initIfaceTcRn thing_inside @@ -921,7 +943,7 @@ initIfaceExtCore :: IfL a -> TcRn a initIfaceExtCore thing_inside = do { tcg_env <- getGblEnv ; let { mod = tcg_mod tcg_env - ; doc = ptext SLIT("External Core file for") <+> quotes (ppr mod) + ; doc = ptext (sLit "External Core file for") <+> quotes (ppr mod) ; if_env = IfGblEnv { if_rec_types = Just (mod, return (tcg_type_env tcg_env)) } ; if_lenv = mkIfLclEnv mod doc @@ -949,7 +971,7 @@ initIfaceTc iface do_this } where mod = mi_module iface - doc = ptext SLIT("The interface for") <+> quotes (ppr mod) + doc = ptext (sLit "The interface for") <+> quotes (ppr mod) initIfaceRules :: HscEnv -> ModGuts -> IfG a -> IO a -- Used when sucking in new Rules in SimplCore @@ -979,7 +1001,7 @@ failIfM :: Message -> IfL a failIfM msg = do { env <- getLclEnv ; let full_msg = (if_loc env <> colon) $$ nest 2 msg - ; ioToIOEnv (printErrs (full_msg defaultErrStyle)) + ; liftIO (printErrs (full_msg defaultErrStyle)) ; failM } -------------------- @@ -1014,7 +1036,7 @@ forkM_maybe doc thing_inside ; return Nothing } }} where - print_errs sdoc = ioToIOEnv (printErrs (sdoc defaultErrStyle)) + print_errs sdoc = liftIO (printErrs (sdoc defaultErrStyle)) forkM :: SDoc -> IfL a -> IfL a forkM doc thing_inside @@ -1024,5 +1046,3 @@ forkM doc thing_inside -- pprPanic "forkM" doc Just r -> r) } \end{code} - -