Commit e17072d1 authored by Simon Peyton Jones's avatar Simon Peyton Jones
Browse files

Refactor AMP warnings a bit

There was a bit of clutter (tryTc stuff) caused by the
fact that tcLookupImported didn't return a MaybeErr.
Now it does.  That finishes up Trac #8004.
parent d57f2ad3
......@@ -7,7 +7,8 @@ Type checking of type signatures in interface files
\begin{code}
module TcIface (
tcImportDecl, importDecl, checkWiredInTyCon, tcHiBootIface, typecheckIface,
tcLookupImported_maybe,
importDecl, checkWiredInTyCon, tcHiBootIface, typecheckIface,
tcIfaceDecl, tcIfaceInst, tcIfaceFamInst, tcIfaceRules,
tcIfaceVectInfo, tcIfaceAnnotations,
tcIfaceExpr, -- Desired by HERMIT (Trac #7683)
......@@ -116,20 +117,25 @@ where the code that e1 expands to might import some defns that
also turn out to be needed by the code that e2 expands to.
\begin{code}
tcImportDecl :: Name -> TcM TyThing
tcLookupImported_maybe :: Name -> TcM (MaybeErr MsgDoc TyThing)
-- Returns (Failed err) if we can't find the interface file for the thing
tcLookupImported_maybe name
= do { hsc_env <- getTopEnv
; mb_thing <- liftIO (lookupTypeHscEnv hsc_env name)
; case mb_thing of
Just thing -> return (Succeeded thing)
Nothing -> tcImportDecl_maybe name }
tcImportDecl_maybe :: Name -> TcM (MaybeErr MsgDoc TyThing)
-- Entry point for *source-code* uses of importDecl
tcImportDecl name
tcImportDecl_maybe name
| Just thing <- wiredInNameTyThing_maybe name
= do { when (needWiredInHomeIface thing)
(initIfaceTcRn (loadWiredInHomeIface name))
-- See Note [Loading instances for wired-in things]
; return thing }
; return (Succeeded thing) }
| otherwise
= do { traceIf (text "tcImportDecl" <+> ppr name)
; mb_thing <- initIfaceTcRn (importDecl name)
; case mb_thing of
Succeeded thing -> return thing
Failed err -> failWithTc err }
= initIfaceTcRn (importDecl name)
importDecl :: Name -> IfM lcl (MaybeErr MsgDoc TyThing)
-- Get the TyThing for this Name from an interface file
......
......@@ -81,13 +81,14 @@ import VarEnv
import HscTypes
import DynFlags
import SrcLoc
import BasicTypes
import BasicTypes hiding( SuccessFlag(..) )
import Module
import Outputable
import Encoding
import FastString
import ListSetOps
import Util
import Maybes( MaybeErr(..) )
import Data.IORef
import Data.List
\end{code}
......@@ -129,11 +130,10 @@ tcLookupGlobal name
| otherwise -> do
-- Try home package table and external package table
{ hsc_env <- getTopEnv
; mb_thing <- liftIO (lookupTypeHscEnv hsc_env name)
; case mb_thing of
Just thing -> return thing
Nothing -> tcImportDecl name -- Go find it in an interface
{ mb_thing <- tcLookupImported_maybe name
; case mb_thing of
Succeeded thing -> return thing
Failed msg -> failWithTc msg
}}}}
tcLookupField :: Name -> TcM Id -- Returns the selector Id
......
......@@ -87,7 +87,7 @@ import TcMatches
import RnTypes
import RnExpr
import MkId
import BasicTypes
import BasicTypes hiding( SuccessFlag(..) )
import TidyPgm ( globaliseAndTidyId )
import TysWiredIn ( unitTy, mkListTy )
#endif
......@@ -911,14 +911,18 @@ rnTopSrcDecls extra_deps group
return (tcg_env', rn_decls)
}
\end{code}
%************************************************************************
%* *
AMP warnings
The functions defined here issue warnings according to
the 2013 Applicative-Monad proposal. (Trac #8004)
%* *
%************************************************************************
-- ########## BEGIN AMP WARNINGS ###############################################
--
-- The functions defined here issue warnings according to the 2013
-- Applicative-Monad proposal. (#8004)
\begin{code}
-- | Main entry point for generating AMP warnings
tcAmpWarn :: TcM ()
tcAmpWarn =
......@@ -986,8 +990,8 @@ tcAmpMissingParentClassWarn :: Name -- ^ Class instance is defined for
-- Example: in case of Applicative/Monad: is = Monad,
-- should = Applicative
tcAmpMissingParentClassWarn isName shouldName
= do { isClass' <- tcLookupClassMaybe isName -- Note [tryTc oddity]
; shouldClass' <- tcLookupClassMaybe shouldName -- Note [tryTc oddity]
= do { isClass' <- tcLookupClass_maybe isName
; shouldClass' <- tcLookupClass_maybe shouldName
; case (isClass', shouldClass') of
(Just isClass, Just shouldClass) -> do
{ localInstances <- tcGetInsts
......@@ -1031,28 +1035,31 @@ tcAmpMissingParentClassWarn isName shouldName
warnMsg (is_tcs isInst)
}
{-
Note [tryTc oddity]
~~~~~~~~~~~~~~~~~~~
tcLookupClass in tcLookupClassMaybe should fail all on its own if the
given name doesn't exist, and the names we're looking for in the AMP
check should always exist. However, under some mysterious
circumstances, base apparently fails to compile without catching the
errors via tryTc. So tcLookupClassMaybe wraps all this behavior
together.
-}
-- | Looks up a class, returning Nothing on failure. Similar to
-- TcEnv.tcLookupClass, but does not issue any error messages.
tcLookupClassMaybe :: Name -> TcM (Maybe Class)
tcLookupClassMaybe = fmap toMaybe . tryTc . tcLookupClass
where toMaybe (_, Just cls) = Just cls
toMaybe _ = Nothing
--
-- In particular, it may be called by the AMP check on, say,
-- Control.Applicative.Applicative, well before Control.Applicative
-- has been compiled. In this case we just return Nothing, and the
-- AMP test is silently dropped.
tcLookupClass_maybe :: Name -> TcM (Maybe Class)
tcLookupClass_maybe name
= do { mb_thing <- tcLookupImported_maybe name
; case mb_thing of
Succeeded (ATyCon tc) | Just cls <- tyConClass_maybe tc -> return (Just cls)
_ -> return Nothing }
\end{code}
-- ########## END AMP WARNINGS #################################################
%************************************************************************
%* *
tcTopSrcDecls
%* *
%************************************************************************
\begin{code}
tcTopSrcDecls :: ModDetails -> HsGroup Name -> TcM (TcGblEnv, TcLclEnv)
tcTopSrcDecls boot_details
(HsGroup { hs_tyclds = tycl_decls,
......
......@@ -72,7 +72,8 @@ import Util
import Data.List ( mapAccumL )
import Unique
import Data.Maybe
import BasicTypes
import BasicTypes hiding( SuccessFlag(..) )
import Maybes( MaybeErr(..) )
import DynFlags
import Panic
import FastString
......@@ -1135,14 +1136,10 @@ tcLookupTh name
Nothing -> failWithTc (notInEnv name)
else do -- It's imported
{ (eps,hpt) <- getEpsAndHpt
; dflags <- getDynFlags
; case lookupType dflags hpt (eps_PTE eps) name of
Just thing -> return (AGlobal thing)
Nothing -> do { thing <- tcImportDecl name
; return (AGlobal thing) }
-- Imported names should always be findable;
-- if not, we fail hard in tcImportDecl
{ mb_thing <- tcLookupImported_maybe name
; case mb_thing of
Succeeded thing -> return (AGlobal thing)
Failed msg -> failWithTc msg
}}}}
notInScope :: TH.Name -> SDoc
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment