Commit c271b647 authored by simonpj's avatar simonpj

[project @ 2000-11-20 14:48:52 by simonpj]

When renaming, typechecking an expression from the user
interface, we may suck in declarations from interface
files (e.g. the Prelude).  This commit takes account of that.

To do so, I did some significant restructuring in TcModule,
with consequential changes and tidy ups elsewhere in the type
checker.  I think there should be fewer lines in total than before.
parent 9a094a5c
......@@ -12,7 +12,9 @@ module CmLink ( Linkable(..), Unlinked(..),
link,
unload,
PersistentLinkerState{-abstractly!-}, emptyPLS,
#ifdef GHCI
linkExpr
#endif
) where
......
......@@ -5,7 +5,9 @@
\begin{code}
module CompManager ( cmInit, cmLoadModule,
#ifdef GHCI
cmGetExpr, cmRunExpr,
#endif
CmState, emptyCmState -- abstract
)
where
......@@ -15,8 +17,6 @@ where
import CmLink
import CmTypes
import HscTypes
import HscMain ( hscExpr )
import Interpreter ( HValue )
import Module ( ModuleName, moduleName,
isModuleInThisPackage, moduleEnvElts,
moduleNameUserString )
......@@ -26,7 +26,6 @@ import GetImports
import HscTypes ( HomeSymbolTable, HomeIfaceTable,
PersistentCompilerState, ModDetails(..) )
import Name ( lookupNameEnv )
import RdrName
import Module
import PrelNames ( mainName )
import HscMain ( initPersistentCompilerState )
......@@ -36,11 +35,18 @@ import UniqFM ( emptyUFM, lookupUFM, addToUFM, delListFromUFM,
import Unique ( Uniquable )
import Digraph ( SCC(..), stronglyConnComp )
import DriverUtil ( BarfKind(..), splitFilename3 )
import CmdLineOpts ( DynFlags )
import Util
import Outputable
import Panic ( panic )
#ifdef GHCI
import CmdLineOpts ( DynFlags )
import Interpreter ( HValue )
import HscMain ( hscExpr )
import RdrName
import PrelGHC ( unsafeCoerce# )
#endif
-- lang
import Exception ( throwDyn )
......@@ -50,7 +56,6 @@ import Directory ( getModificationTime, doesFileExist )
import IO
import List ( nub )
import Maybe ( catMaybes, fromMaybe, isJust )
import PrelGHC ( unsafeCoerce# )
\end{code}
......@@ -59,6 +64,7 @@ cmInit :: PackageConfigInfo -> GhciMode -> IO CmState
cmInit raw_package_info gmode
= emptyCmState raw_package_info gmode
#ifdef GHCI
cmGetExpr :: CmState
-> DynFlags
-> ModuleName
......@@ -83,6 +89,7 @@ cmRunExpr :: HValue -> IO ()
cmRunExpr hval
= do unsafeCoerce# hval :: IO ()
-- putStrLn "done."
#endif
-- Persistent state just for CM, excluding link & compile subsystems
data PersistentCMState
......
......@@ -18,7 +18,7 @@ module CoreFVs (
#include "HsVersions.h"
import CoreSyn
import Id ( Id, idName, idType, isLocalId, hasNoBinding, idSpecialisation )
import Id ( Id, idType, isLocalId, hasNoBinding, idSpecialisation )
import VarSet
import Var ( Var, isId )
import Type ( tyVarsOfType )
......
......@@ -54,10 +54,8 @@ import IdInfo ( LBVarInfo(..),
IdFlavour(..),
megaSeqIdInfo )
import Demand ( appIsBottom )
import Type ( Type, mkFunTy, mkForAllTy,
splitFunTy_maybe, tyVarsOfType, tyVarsOfTypes,
applyTys, isUnLiftedType, seqType,
mkUTy
import Type ( Type, mkFunTy, mkForAllTy, splitFunTy_maybe,
applyTys, isUnLiftedType, seqType, mkUTy
)
import TysWiredIn ( boolTy, trueDataCon, falseDataCon )
import CostCentre ( CostCentre )
......
......@@ -27,7 +27,7 @@ import IdInfo ( IdInfo, megaSeqIdInfo,
arityInfo, ppArityInfo, ppFlavourInfo, flavourInfo,
specInfo, cprInfo, ppCprInfo,
strictnessInfo, ppStrictnessInfo, cafInfo, ppCafInfo,
cprInfo, ppCprInfo, lbvarInfo,
cprInfo, ppCprInfo,
workerInfo, ppWorkerInfo,
tyGenInfo, ppTyGenInfo
)
......
......@@ -282,7 +282,6 @@ instance (NamedThing name, Ord name) => Eq (TyClDecl name pat) where
(==) _ _ = False -- default case
eq_hsFD env (ns1,ms1) (ns2,ms2)
= eqListBy (eq_hsVar env) ns1 ns2 && eqListBy (eq_hsVar env) ms1 ms2
......
......@@ -9,17 +9,18 @@ module HscMain ( HscResult(..), hscMain, hscExpr,
#include "HsVersions.h"
import Maybe ( isJust )
import IO ( hPutStrLn, stderr )
#ifdef GHCI
import RdrHsSyn ( RdrNameHsExpr )
import CoreToStg ( coreToStgExpr )
import StringBuffer ( stringToStringBuffer, freeStringBuffer )
#endif
import HsSyn
import StringBuffer ( hGetStringBuffer,
stringToStringBuffer, freeStringBuffer )
import StringBuffer ( hGetStringBuffer )
import Parser
import RdrHsSyn ( RdrNameHsExpr )
import Lex ( PState(..), ParseResult(..) )
import SrcLoc ( mkSrcLoc )
import Rename
import Rules ( emptyRuleBase )
import PrelInfo ( wiredInThingEnv, wiredInThings )
......@@ -33,7 +34,7 @@ import SimplCore
import OccurAnal ( occurAnalyseBinds )
import CoreUtils ( coreBindsSize )
import CoreTidy ( tidyCorePgm )
import CoreToStg ( topCoreBindsToStg, coreToStgExpr )
import CoreToStg ( topCoreBindsToStg )
import StgSyn ( collectFinalStgBinders )
import SimplStg ( stg2stg )
import CodeGen ( codeGen )
......@@ -47,7 +48,7 @@ import UniqSupply ( mkSplitUniqSupply )
import Bag ( emptyBag )
import Outputable
import Interpreter
import Interpreter ( stgBindsToInterpSyn, UnlinkedIExpr, UnlinkedIBind, ItblEnv )
import CmStaticInfo ( GhciMode(..) )
import HscStats ( ppSourceStats )
import HscTypes ( ModDetails, ModIface(..), PersistentCompilerState(..),
......@@ -62,6 +63,8 @@ import Name ( emptyNameEnv )
import Module ( Module, lookupModuleEnvByName )
import Monad ( when )
import Maybe ( isJust )
import IO ( hPutStrLn, stderr )
\end{code}
......@@ -131,7 +134,6 @@ hscNoRecomp ghci_mode dflags location (Just old_iface) hst hit pcs_ch
| otherwise
= do {
hPutStrLn stderr "COMPILATION NOT REQUIRED";
let this_mod = mi_module old_iface
;
-- CLOSURE
(pcs_cl, closure_errs, cl_hs_decls)
......@@ -391,6 +393,11 @@ hscExpr
-> String -- The expression
-> IO ( PersistentCompilerState, Maybe UnlinkedIExpr )
#ifndef GHCI
hscExpr dflags hst hit pcs this_module expr
= panic "hscExpr: non-interactive build"
#else
hscExpr dflags hst hit pcs0 this_module expr
= do { -- Parse it
maybe_parsed <- hscParseExpr dflags expr;
......@@ -406,7 +413,7 @@ hscExpr dflags hst hit pcs0 this_module expr
Just (print_unqual, rn_expr) -> do {
-- Typecheck it
maybe_tc_expr <- typecheckExpr dflags pcs1 hst print_unqual rn_expr;
maybe_tc_expr <- typecheckExpr dflags pcs1 hst print_unqual this_module rn_expr;
case maybe_tc_expr of
Nothing -> return (pcs1, Nothing)
Just tc_expr -> do {
......@@ -460,6 +467,7 @@ hscParseExpr dflags str
return (Just rdr_expr)
}}
#endif
\end{code}
%************************************************************************
......
......@@ -17,7 +17,7 @@ module HscTypes (
VersionInfo(..), initialVersionInfo,
TyThing(..), isTyClThing,
TyThing(..), isTyClThing, implicitTyThingIds,
TypeEnv, lookupType, mkTypeEnv, extendTypeEnvList,
typeEnvClasses, typeEnvTyCons,
......@@ -54,8 +54,9 @@ import Module ( Module, ModuleName, ModuleEnv,
import InstEnv ( InstEnv, ClsInstEnv, DFunId )
import Rules ( RuleBase )
import Id ( Id )
import Class ( Class )
import TyCon ( TyCon )
import Class ( Class, classSelIds )
import TyCon ( TyCon, tyConGenIds, tyConSelIds, tyConDataConsIfAvailable )
import DataCon ( dataConId, dataConWrapId )
import BasicTypes ( Version, initialVersion, Fixity )
......@@ -259,6 +260,18 @@ instance NamedThing TyThing where
typeEnvClasses env = [cl | AClass cl <- nameEnvElts env]
typeEnvTyCons env = [tc | ATyCon tc <- nameEnvElts env]
implicitTyThingIds :: [TyThing] -> [Id]
-- Add the implicit data cons and selectors etc
implicitTyThingIds things
= concat (map go things)
where
go (AnId f) = []
go (AClass cl) = classSelIds cl
go (ATyCon tc) = tyConGenIds tc ++
tyConSelIds tc ++
[ n | dc <- tyConDataConsIfAvailable tc,
n <- [dataConId dc, dataConWrapId dc] ]
-- Synonyms return empty list of constructors and selectors
\end{code}
......
-----------------------------------------------------------------------------
-- $Id: Interpreter.hs,v 1.6 2000/11/20 14:26:27 simonmar Exp $
-- $Id: Interpreter.hs,v 1.7 2000/11/20 14:48:54 simonpj Exp $
--
-- Interpreter subsystem wrapper
--
......@@ -16,7 +16,7 @@ module Interpreter (
ClosureEnv, emptyClosureEnv,
ItblEnv, emptyItblEnv,
linkIModules,
stgToInterpSyn,
stgToInterpSyn, stgBindsToInterpSyn,
HValue,
UnlinkedIBind, UnlinkedIExpr,
loadObjs, resolveObjs,
......@@ -55,9 +55,10 @@ data UnlinkedIExpr = UnlinkedIExpr
instance Outputable UnlinkedIBind where
ppr x = text "Can't output UnlinkedIBind"
linkIModules = error "linkIModules"
stgToInterpSyn = error "linkIModules"
loadObjs = error "loadObjs"
resolveObjs = error "loadObjs"
interactiveUI = error "interactiveUI"
linkIModules = error "linkIModules"
stgToInterpSyn = error "stgToInterpSyn"
stgBindsToInterpSyn = error "stgBindsToInterpSyn"
loadObjs = error "loadObjs"
resolveObjs = error "loadObjs"
interactiveUI = error "interactiveUI"
#endif
......@@ -32,15 +32,14 @@ module PrelInfo (
import PrelNames -- Prelude module names
import PrimOp ( PrimOp(..), allThePrimOps, primOpRdrName )
import DataCon ( DataCon, dataConId, dataConWrapId )
import DataCon ( DataCon )
import MkId ( mkPrimOpId, wiredInIds )
import MkId -- All of it, for re-export
import TysPrim ( primTyCons )
import TysWiredIn ( wiredInTyCons )
import HscTypes ( TyThing(..), TypeEnv, mkTypeEnv )
import HscTypes ( TyThing(..), implicitTyThingIds, TypeEnv, mkTypeEnv )
-- others:
import TyCon ( tyConDataConsIfAvailable, tyConGenIds, TyCon )
import Class ( Class, classKey )
import Type ( funTyCon )
import Util ( isIn )
......@@ -59,8 +58,9 @@ We have two ``builtin name funs,'' one to look up @TyCons@ and
wiredInThings :: [TyThing]
wiredInThings
= concat
[ -- Wired in TyCons
concat (map wiredInTyConThings ([funTyCon] ++ primTyCons ++ wiredInTyCons))
[ -- Wired in TyCons and their implicit Ids
tycon_things
, map AnId (implicitTyThingIds tycon_things)
-- Wired in Ids
, map AnId wiredInIds
......@@ -68,16 +68,8 @@ wiredInThings
-- PrimOps
, map (AnId . mkPrimOpId) allThePrimOps
]
wiredInTyConThings :: TyCon -> [TyThing]
-- This is a bit of a cheat (c.f. TcTyDecls.mkImplicitDataBinds
-- It assumes that wired in tycons have no record selectors
wiredInTyConThings tc
= [ATyCon tc]
++ [ AnId i | i <- tyConGenIds tc ]
++ [ AnId n | dc <- tyConDataConsIfAvailable tc,
n <- [dataConId dc, dataConWrapId dc] ]
-- Synonyms return empty list of constructors
where
tycon_things = map ATyCon ([funTyCon] ++ primTyCons ++ wiredInTyCons)
wiredInThingEnv :: TypeEnv
wiredInThingEnv = mkTypeEnv wiredInThings
......
......@@ -168,7 +168,8 @@ pcTyCon new_or_data is_rec name tyvars argvrcs cons
[] -- No context
argvrcs
cons
(length cons)
(length cons)
[] -- No record selectors
new_or_data
is_rec
gen_info
......
......@@ -101,7 +101,7 @@ renameExpr :: DynFlags
-> HomeIfaceTable -> HomeSymbolTable
-> PersistentCompilerState
-> Module -> RdrNameHsExpr
-> IO (PersistentCompilerState, Maybe (PrintUnqualified, RenamedHsExpr))
-> IO (PersistentCompilerState, Maybe (PrintUnqualified, (RenamedHsExpr, [RenamedHsDecl])))
renameExpr dflags hit hst pcs this_module expr
| Just iface <- lookupModuleEnv hit this_module
......@@ -109,13 +109,11 @@ renameExpr dflags hit hst pcs this_module expr
; let print_unqual = unQualInScope rdr_env
; renameSource dflags hit hst pcs this_module $
initRnMS rdr_env emptyLocalFixityEnv SourceMode $
( rnExpr expr `thenRn` \ (e,_) ->
doptRn Opt_D_dump_rn `thenRn` \ dump_rn ->
ioToRnM (dumpIfSet dump_rn "Renamer:" (ppr e)) `thenRn_`
returnRn (Just (print_unqual, e)))
initRnMS rdr_env emptyLocalFixityEnv SourceMode (rnExpr expr) `thenRn` \ (e,fvs) ->
closeDecls [] fvs `thenRn` \ decls ->
doptRn Opt_D_dump_rn `thenRn` \ dump_rn ->
ioToRnM (dumpIfSet dump_rn "Renamer:" (ppr e)) `thenRn_`
returnRn (Just (print_unqual, (e, decls)))
}
| otherwise
......
......@@ -4,13 +4,13 @@
\section[TcClassDcl]{Typechecking class declarations}
\begin{code}
module TcClassDcl ( tcClassDecl1, tcClassDecls2, mkImplicitClassBinds,
module TcClassDcl ( tcClassDecl1, tcClassDecls2,
tcMethodBind, badMethodErr
) where
#include "HsVersions.h"
import HsSyn ( HsDecl(..), TyClDecl(..), Sig(..), MonoBinds(..),
import HsSyn ( TyClDecl(..), Sig(..), MonoBinds(..),
HsExpr(..), HsLit(..), HsType(..), HsPred(..),
mkSimpleMatch, andMonoBinds, andMonoBindList,
isClassDecl, isClassOpSig, isPragSig,
......@@ -19,10 +19,10 @@ import HsSyn ( HsDecl(..), TyClDecl(..), Sig(..), MonoBinds(..),
import BasicTypes ( TopLevelFlag(..), RecFlag(..) )
import RnHsSyn ( RenamedTyClDecl,
RenamedClassOpSig, RenamedMonoBinds,
RenamedContext, RenamedHsDecl, RenamedSig,
RenamedContext, RenamedSig,
maybeGenericMatch
)
import TcHsSyn ( TcMonoBinds, idsToMonoBinds )
import TcHsSyn ( TcMonoBinds )
import Inst ( InstOrigin(..), LIE, emptyLIE, plusLIE, plusLIEs,
newDicts, newMethod )
......@@ -37,7 +37,7 @@ import TcType ( TcType, TcTyVar, tcInstTyVars, zonkTcSigTyVars )
import TcMonad
import Generics ( mkGenericRhs, validGenericMethodType )
import PrelInfo ( nO_METHOD_BINDING_ERROR_ID )
import Class ( classTyVars, classBigSig, classSelIds, classTyCon,
import Class ( classTyVars, classBigSig, classTyCon,
Class, ClassOpItem, DefMeth (..) )
import MkId ( mkDictSelId, mkDataConId, mkDataConWrapId, mkDefaultMethodId )
import DataCon ( mkDataCon, notMarkedStrict )
......@@ -292,34 +292,6 @@ tcClassSig is_rec unf_env clas clas_tyvars dm_info
\end{code}
%************************************************************************
%* *
\subsection[ClassDcl-pass2]{Class decls pass 2: default methods}
%* *
%************************************************************************
@mkImplicitClassBinds@ produces a binding for the selector function for each method
and superclass dictionary.
\begin{code}
mkImplicitClassBinds :: Module -> [Class] -> NF_TcM ([Id], TcMonoBinds)
mkImplicitClassBinds this_mod classes
= returnNF_Tc (concat cls_ids_s, andMonoBindList binds_s)
-- The selector binds are already in the selector Id's unfoldings
-- We don't return the data constructor etc from the class,
-- because that's done via the class's TyCon
where
(cls_ids_s, binds_s) = unzip (map mk_implicit classes)
mk_implicit clas = (sel_ids, binds)
where
sel_ids = classSelIds clas
binds | isFrom this_mod clas = idsToMonoBinds sel_ids
| otherwise = EmptyMonoBinds
\end{code}
%************************************************************************
%* *
\subsection[Default methods]{Default methods}
......@@ -385,12 +357,12 @@ The function @tcClassDecls2@ just arranges to apply @tcClassDecl2@ to
each local class decl.
\begin{code}
tcClassDecls2 :: Module -> [RenamedHsDecl] -> NF_TcM (LIE, TcMonoBinds)
tcClassDecls2 :: Module -> [RenamedTyClDecl] -> NF_TcM (LIE, TcMonoBinds)
tcClassDecls2 this_mod decls
= foldr combine
(returnNF_Tc (emptyLIE, EmptyMonoBinds))
[tcClassDecl2 cls_decl | TyClD cls_decl <- decls,
[tcClassDecl2 cls_decl | cls_decl <- decls,
isClassDecl cls_decl,
isFrom this_mod (tyClDeclName cls_decl)]
where
......
......@@ -27,7 +27,7 @@ module TcEnv(
tcGetGlobalTyVars, tcExtendGlobalTyVars,
-- Random useful things
RecTcEnv, tcAddImportedIdInfo, tcLookupRecId, tcInstId,
RecTcEnv, tcAddImportedIdInfo, tcLookupRecId, tcLookupRecId_maybe, tcInstId,
-- New Ids
newLocalId, newSpecPragmaId,
......@@ -165,7 +165,7 @@ getTcGEnv (TcEnv { tcGEnv = genv }) = genv
-- This data type is used to help tie the knot
-- when type checking type and class declarations
data TyThingDetails = SynTyDetails Type
| DataTyDetails ClassContext [DataCon]
| DataTyDetails ClassContext [DataCon] [Id]
| ClassDetails ClassContext [Id] [ClassOpItem] DataCon
\end{code}
......@@ -205,16 +205,20 @@ tcAddImportedIdInfo env id
= id `lazySetIdInfo` new_info
-- The Id must be returned without a data dependency on maybe_id
where
new_info = case tcLookupRecId env (idName id) of
new_info = case tcLookupRecId_maybe env (idName id) of
Nothing -> constantIdInfo
Just imported_id -> idInfo imported_id
-- ToDo: could check that types are the same
tcLookupRecId :: RecTcEnv -> Name -> Maybe Id
tcLookupRecId env name = case lookup_global env name of
Just (AnId id) -> Just id
other -> Nothing
tcLookupRecId_maybe :: RecTcEnv -> Name -> Maybe Id
tcLookupRecId_maybe env name = case lookup_global env name of
Just (AnId id) -> Just id
other -> Nothing
tcLookupRecId :: RecTcEnv -> Name -> Id
tcLookupRecId env name = case lookup_global env name of
Just (AnId id) -> id
Nothing -> pprPanic "tcLookupRecId" (ppr name)
\end{code}
%************************************************************************
......@@ -304,17 +308,21 @@ isLocalThing mod thing = case nameModule_maybe (getName thing) of
%************************************************************************
\begin{code}
tcExtendGlobalEnv :: [(Name, TyThing)] -> TcM r -> TcM r
tcExtendGlobalEnv bindings thing_inside
tcExtendGlobalEnv :: [TyThing] -> TcM r -> TcM r
tcExtendGlobalEnv things thing_inside
= tcGetEnv `thenNF_Tc` \ env ->
let
ge' = extendNameEnvList (tcGEnv env) bindings
ge' = extendNameEnvList (tcGEnv env) [(getName thing, thing) | thing <- things]
in
tcSetEnv (env {tcGEnv = ge'}) thing_inside
tcExtendGlobalValEnv :: [Id] -> TcM a -> TcM a
tcExtendGlobalValEnv ids thing_inside
= tcExtendGlobalEnv [(getName id, AnId id) | id <- ids] thing_inside
= tcGetEnv `thenNF_Tc` \ env ->
let
ge' = extendNameEnvList (tcGEnv env) [(getName id, AnId id) | id <- ids]
in
tcSetEnv (env {tcGEnv = ge'}) thing_inside
\end{code}
......
......@@ -24,7 +24,6 @@ module TcHsSyn (
mkHsTyApp, mkHsDictApp, mkHsConApp,
mkHsTyLam, mkHsDictLam, mkHsLet,
idsToMonoBinds,
-- re-exported from TcEnv
TcId, tcInstId,
......@@ -39,7 +38,7 @@ module TcHsSyn (
import HsSyn -- oodles of it
-- others:
import Id ( idName, idType, isLocalId, idUnfolding, setIdType, isIP, Id )
import Id ( idName, idType, isLocalId, setIdType, isIP, Id )
import DataCon ( dataConWrapId )
import TcEnv ( tcLookupGlobal_maybe, tcExtendGlobalValEnv,
TcEnv, TcId, tcInstId
......@@ -49,7 +48,6 @@ import TcMonad
import TcType ( zonkTcTypeToType, zonkTcTyVarToTyVar, zonkTcType, zonkTcSigTyVars
)
import CoreSyn ( Expr )
import CoreUnfold( unfoldingTemplate )
import BasicTypes ( RecFlag(..) )
import Bag
import Outputable
......@@ -118,12 +116,6 @@ mkHsLet EmptyMonoBinds expr = expr
mkHsLet mbinds expr = HsLet (MonoBind mbinds [] Recursive) expr
mkHsConApp data_con tys args = foldl HsApp (HsVar (dataConWrapId data_con) `mkHsTyApp` tys) args
idsToMonoBinds :: [Id] -> TcMonoBinds
idsToMonoBinds ids
= andMonoBindList [ CoreMonoBind id (unfoldingTemplate (idUnfolding id))
| id <- ids
]
\end{code}
%************************************************************************
......
......@@ -8,7 +8,7 @@ module TcIfaceSig ( tcInterfaceSigs, tcVar, tcCoreExpr, tcCoreLamBndrs ) where
#include "HsVersions.h"
import HsSyn ( HsDecl(..), TyClDecl(..), HsTupCon(..) )
import HsSyn ( TyClDecl(..), HsTupCon(..) )
import TcMonad
import TcMonoType ( tcHsType )
-- NB: all the tyars in interface files are kinded,
......@@ -17,10 +17,10 @@ import TcMonoType ( tcHsType )
import TcEnv ( TcEnv, RecTcEnv, tcExtendTyVarEnv,
tcExtendGlobalValEnv, tcSetEnv,
tcLookupGlobal_maybe, tcLookupRecId
tcLookupGlobal_maybe, tcLookupRecId_maybe
)
import RnHsSyn ( RenamedHsDecl )
import RnHsSyn ( RenamedTyClDecl )
import HsCore
import Literal ( Literal(..) )
import CoreSyn
......@@ -52,13 +52,13 @@ signatures.
\begin{code}
tcInterfaceSigs :: RecTcEnv -- Envt to use when checking unfoldings
-> [RenamedHsDecl] -- Ignore non-sig-decls in these decls
-> [RenamedTyClDecl] -- Ignore non-sig-decls in these decls
-> TcM [Id]
tcInterfaceSigs unf_env decls
= listTc [ do_one name ty id_infos src_loc
| TyClD (IfaceSig name ty id_infos src_loc) <- decls]
| IfaceSig name ty id_infos src_loc <- decls]
where
in_scope_vars = [] -- I think this will be OK
......@@ -108,7 +108,7 @@ tcWorkerInfo unf_env ty info worker_name
= uniqSMToTcM (mkWrapper ty arity demands res_bot cpr_info) `thenNF_Tc` \ wrap_fn ->
let
-- Watch out! We can't pull on unf_env too eagerly!
info' = case tcLookupRecId unf_env worker_name of
info' = case tcLookupRecId_maybe unf_env worker_name of
Just worker_id -> info `setUnfoldingInfo` mkTopUnfolding (wrap_fn worker_id)
`setWorkerInfo` HasWorker worker_id arity
......
......@@ -167,11 +167,10 @@ tcInstDecls1 :: PackageInstEnv
-> TcEnv -- Contains IdInfo for dfun ids
-> (Name -> Maybe Fixity) -- for deriving Show and Read
-> Module -- Module for deriving
-> [TyCon]
-> [RenamedHsDecl]
-> TcM (PackageInstEnv, InstEnv, [InstInfo], RenamedHsBinds)
tcInstDecls1 inst_env0 prs hst unf_env get_fixity mod tycons decls
tcInstDecls1 inst_env0 prs hst unf_env get_fixity mod decls
= let
inst_decls = [inst_decl | InstD inst_decl <- decls]
tycl_decls = [decl | TyClD decl <- decls]
......
......@@ -11,9 +11,11 @@ module TcModule (
#include "HsVersions.h"
import CmdLineOpts ( DynFlag(..), DynFlags, opt_PprStyle_Debug )
import HsSyn ( HsBinds(..), MonoBinds(..), HsDecl(..) )
import HsSyn ( HsBinds(..), MonoBinds(..), HsDecl(..),
isIfaceRuleDecl, nullBinds, andMonoBindList
)
import HsTypes ( toHsType )
import RnHsSyn ( RenamedHsDecl, RenamedHsExpr )
import RnHsSyn ( RenamedHsBinds, RenamedHsDecl, RenamedHsExpr )
import TcHsSyn ( TypecheckedMonoBinds, TypecheckedHsExpr,
TypecheckedForeignDecl, TypecheckedRuleDecl,
zonkTopBinds, zonkForeignExports, zonkRules, mkHsLet
......@@ -24,22 +26,20 @@ import TcMonad
import TcType ( newTyVarTy )
import Inst ( plusLIE )
import TcBinds ( tcTopBinds )
import TcClassDcl ( tcClassDecls2, mkImplicitClassBinds )
import TcClassDcl ( tcClassDecls2 )
import TcDefaults ( tcDefaults )
import TcExpr ( tcMonoExpr )
import TcEnv ( TcEnv, InstInfo(iDFunId), tcExtendGlobalValEnv,
tcEnvTyCons, tcEnvClasses, isLocalThing,
tcSetEnv, tcSetInstEnv, initTcEnv, getTcGEnv
isLocalThing, tcSetEnv, tcSetInstEnv, initTcEnv, getTcGEnv
)
import TcRules ( tcRules )
import TcRules ( tcIfaceRules, tcSourceRules )
import TcForeign ( tcForeignImports, tcForeignExports )
import TcIfaceSig ( tcInterfaceSigs )
import TcInstDcls ( tcInstDecls1, tcInstDecls2 )
import TcSimplify ( tcSimplifyTop )
import TcTyClsDecls ( tcTyAndClassDecls )
import TcTyDecls ( mkImplicitDataBinds )
import CoreUnfold ( unfoldingTemplate )
import CoreUnfold ( unfoldingTemplate, hasUnfolding )
import Type ( funResultTy, splitForAllTys, openTypeKind )
import Bag ( isEmptyBag )
import ErrUtils ( printErrorsAndWarnings, dumpIfSet_dyn, showPass )
......@@ -55,8 +55,9 @@ import Outputable
import HscTypes ( PersistentCompilerState(..), HomeSymbolTable,
PackageTypeEnv, DFunId, ModIface(..),
TypeEnv, extendTypeEnvList,
TyThing(..), mkTypeEnv )
import List ( partition )
TyThing(..), implicitTyThingIds,
mkTypeEnv
)
\end{code}
Outside-world interface:
......@@ -103,15 +104,25 @@ typecheckExpr :: DynFlags
-> PersistentCompilerState
-> HomeSymbolTable
-> PrintUnqualified -- For error printing
-> Ren