From dd6f34b632c29306e56b6bdf232316af26800a4f Mon Sep 17 00:00:00 2001 From: simonmar Date: Wed, 15 Aug 2001 14:40:24 +0000 Subject: [PATCH] [project @ 2001-08-15 14:40:24 by simonmar] Implement the :info command for GHCi. --- ghc/compiler/compMan/CompManager.lhs | 58 +++++++++------- ghc/compiler/ghci/InteractiveUI.hs | 52 ++++++++++++--- ghc/compiler/main/HscMain.lhs | 94 +++++++++++++++++--------- ghc/compiler/main/MkIface.lhs | 28 +++++--- ghc/compiler/rename/Rename.lhs | 122 ++++++++++++++++++++++++---------- ghc/compiler/rename/RnMonad.lhs | 15 +++++ ghc/compiler/typecheck/TcModule.lhs | 28 ++++++++ 7 files changed, 288 insertions(+), 109 deletions(-) diff --git a/ghc/compiler/compMan/CompManager.lhs b/ghc/compiler/compMan/CompManager.lhs index dd5841e..347e1e9 100644 --- a/ghc/compiler/compMan/CompManager.lhs +++ b/ghc/compiler/compMan/CompManager.lhs @@ -147,7 +147,7 @@ cmInit mode = do cmSetContext :: CmState -> String -> IO CmState cmSetContext cmstate str = do let mn = mkModuleName str - modules_loaded = [ (name_of_summary s, ms_mod s) | s <- mg cmstate ] + modules_loaded = [ (name_of_summary s, ms_mod s) | s <- mg cmstate ] m <- case lookup mn modules_loaded of Just m -> return m @@ -173,14 +173,24 @@ moduleNameToModule mn Just (m,_) -> return m ----------------------------------------------------------------------------- +-- cmInfoThing: convert a String to a TyThing + +-- A string may refer to more than one TyThing (eg. a constructor, +-- and type constructor), so we return a list of all the possible TyThings. + +cmInfoThing :: CmState -> DynFlags -> String + -> IO (CmState, PrintUnqualified, [TyThing]) +cmInfoThing cmstate dflags id + = do (new_pcs, things) <- hscThing dflags hst hit pcs icontext id + return (cmstate{ pcs=new_pcs }, unqual, things) + where + CmState{ hst=hst, hit=hit, pcs=pcs, pls=pls, ic=icontext } = cmstate + unqual = getUnqual pcs hit icontext + +----------------------------------------------------------------------------- -- cmRunStmt: Run a statement/expr. #ifdef GHCI -cmInfoThing :: CmState -> DynFlags -> String -> IO (Maybe TyThing) -cmInfoThing CmState{ hst=hst, hit=hit, pcs=pcs, pls=pls, ic=icontext } dflags id - = do (pcs, thing) <- hscThing dflags hst hit pcs icontext id - return thing - cmRunStmt :: CmState -> DynFlags -> String -> IO (CmState, -- new state [Name]) -- names bound by this evaluation @@ -248,19 +258,23 @@ cmTypeOfExpr cmstate dflags expr case maybe_stuff of Nothing -> return (new_cmstate, Nothing) - Just (_, ty, _) -> - let pit = pcs_PIT pcs - modname = moduleName (ic_module ic) - tidy_ty = tidyType emptyTidyEnv ty - str = case lookupIfaceByModName hit pit modname of - Nothing -> showSDoc (ppr tidy_ty) - Just iface -> showSDocForUser unqual (ppr tidy_ty) - where unqual = unQualInScope (mi_globals iface) - in return (new_cmstate, Just str) + Just (_, ty, _) -> return (new_cmstate, Just str) + where + str = showSDocForUser unqual (ppr tidy_ty) + unqual = getUnqual pcs hit ic + tidy_ty = tidyType emptyTidyEnv ty where CmState{ hst=hst, hit=hit, pcs=pcs, ic=ic } = cmstate #endif +getUnqual pcs hit ic + = case lookupIfaceByModName hit pit modname of + Nothing -> alwaysQualify + Just iface -> unQualInScope (mi_globals iface) + where + pit = pcs_PIT pcs + modname = moduleName (ic_module ic) + ----------------------------------------------------------------------------- -- cmTypeOfName: returns a string representing the type of a name. @@ -269,15 +283,11 @@ cmTypeOfName :: CmState -> Name -> IO (Maybe String) cmTypeOfName CmState{ hit=hit, pcs=pcs, ic=ic } name = case lookupNameEnv (ic_type_env ic) name of Nothing -> return Nothing - Just (AnId id) -> - let pit = pcs_PIT pcs - modname = moduleName (ic_module ic) - ty = tidyType emptyTidyEnv (idType id) - str = case lookupIfaceByModName hit pit modname of - Nothing -> showSDoc (ppr ty) - Just iface -> showSDocForUser unqual (ppr ty) - where unqual = unQualInScope (mi_globals iface) - in return (Just str) + Just (AnId id) -> return (Just str) + where + unqual = getUnqual pcs hit ic + ty = tidyType emptyTidyEnv (idType id) + str = showSDocForUser unqual (ppr ty) _ -> panic "cmTypeOfName" #endif diff --git a/ghc/compiler/ghci/InteractiveUI.hs b/ghc/compiler/ghci/InteractiveUI.hs index ea3431c..f75c672 100644 --- a/ghc/compiler/ghci/InteractiveUI.hs +++ b/ghc/compiler/ghci/InteractiveUI.hs @@ -1,5 +1,5 @@ ----------------------------------------------------------------------------- --- $Id: InteractiveUI.hs,v 1.85 2001/08/13 15:49:37 simonmar Exp $ +-- $Id: InteractiveUI.hs,v 1.86 2001/08/15 14:40:24 simonmar Exp $ -- -- GHC Interactive User Interface -- @@ -16,7 +16,7 @@ module InteractiveUI ( interactiveUI, ghciWelcomeMsg ) where import Packages import CompManager -import HscTypes ( GhciMode(..) ) +import HscTypes ( GhciMode(..), TyThing(..) ) import MkIface ( ifaceTyCls ) import ByteCodeLink import DriverFlags @@ -25,7 +25,11 @@ import DriverUtil import Linker import Finder ( flushPackageCache ) import Util -import Name ( Name ) +import Id ( isDataConWrapId, idName ) +import Class ( className ) +import TyCon ( tyConName ) +import SrcLoc ( isGoodSrcLoc ) +import Name ( Name, isHomePackageName, nameSrcLoc ) import Outputable import CmdLineOpts ( DynFlag(..), getDynFlags, saveDynFlags, restoreDynFlags, dopt_unset ) import Panic ( GhcException(..) ) @@ -377,14 +381,42 @@ info :: String -> GHCi () info "" = throwDyn (CmdLineError "syntax: `:i '") info s = do let names = words s - st <- getGHCiState - let cmst = cmstate st + state <- getGHCiState dflags <- io getDynFlags - things <- io (mapM (cmInfoThing cmst dflags) names) - let real_things = [ x | Just x <- things ] - let descs = map (`ifaceTyCls` []) real_things - let strings = map (showSDoc . ppr) descs - io (mapM_ putStr strings) + let + infoThings cms [] = return cms + infoThings cms (name:names) = do + (cms, unqual, ty_things) <- io (cmInfoThing cms dflags name) + io (putStrLn (showSDocForUser unqual ( + vcat (intersperse (text "") (map showThing ty_things)))) + ) + infoThings cms names + + showThing ty_thing = vcat [ text "-- " <> showTyThing ty_thing, + ppr (ifaceTyCls ty_thing) ] + + showTyThing (AClass cl) + = hcat [ppr cl, text " is a class", showSrcLoc (className cl)] + showTyThing (ATyCon ty) + = hcat [ppr ty, text " is a type constructor", showSrcLoc (tyConName ty)] + showTyThing (AnId id) + | isDataConWrapId id + = hcat [ppr id, text " is a data constructor", showSrcLoc (idName id)] + | otherwise + = hcat [ppr id, text " is a variable", showSrcLoc (idName id)] + + -- also print out the source location for home things + showSrcLoc name + | isHomePackageName name && isGoodSrcLoc loc + = hsep [ text ", defined at", ppr loc ] + | otherwise + = empty + where loc = nameSrcLoc name + + cms <- infoThings (cmstate state) names + setGHCiState state{ cmstate = cms } + return () + addModule :: String -> GHCi () addModule str = do diff --git a/ghc/compiler/main/HscMain.lhs b/ghc/compiler/main/HscMain.lhs index 339bb5c..d8f4601 100644 --- a/ghc/compiler/main/HscMain.lhs +++ b/ghc/compiler/main/HscMain.lhs @@ -17,11 +17,10 @@ module HscMain ( HscResult(..), hscMain, import ByteCodeGen ( byteCodeGen ) import CoreTidy ( tidyCoreExpr ) import CorePrep ( corePrepExpr ) -import SrcLoc ( noSrcLoc ) -import Rename ( renameStmt ) -import RdrName ( mkUnqual ) +import Rename ( renameStmt, renameRdrName ) +import RdrName ( mkUnqual, mkQual ) import RdrHsSyn ( RdrNameStmt ) -import OccName ( dataName ) +import OccName ( varName, dataName, tcClsName ) import Type ( Type ) import Id ( Id, idName, setGlobalIdDetails ) import IdInfo ( GlobalIdDetails(VanillaGlobal) ) @@ -29,6 +28,8 @@ import HscTypes ( InteractiveContext(..) ) import PrelNames ( iNTERACTIVE ) import StringBuffer ( stringToStringBuffer ) import FastString ( mkFastString ) +import Char ( isLower ) +import DriverUtil ( split_longest_prefix ) #endif import HsSyn @@ -79,7 +80,7 @@ import Module ( Module ) import IOExts ( newIORef, readIORef, writeIORef, unsafePerformIO ) import Monad ( when ) -import Maybe ( isJust, fromJust ) +import Maybe ( isJust, fromJust, catMaybes ) import IO import MkExternalCore ( emitExternalCore ) @@ -562,31 +563,6 @@ hscStmt dflags hst hit pcs0 icontext stmt just_expr }}}}} -hscThing -- like hscStmt, but deals with a single identifier - :: DynFlags - -> HomeSymbolTable - -> HomeIfaceTable - -> PersistentCompilerState -- IN: persistent compiler state - -> InteractiveContext -- Context for compiling - -> String -- The identifier - -> IO ( PersistentCompilerState, - Maybe TyThing ) -hscThing dflags hst hit pcs0 icontext id - = let - InteractiveContext { - ic_rn_env = rn_env, - ic_type_env = type_env, - ic_module = scope_mod } = icontext - fname = mkFastString id - rn = mkUnqual dataName fname -- need to guess correct namespace - stmt = ResultStmt (HsVar rn) noSrcLoc - in - do { (pcs, err, maybe_stmt) <- renameStmt dflags hit hst pcs0 scope_mod scope_mod rn_env stmt - ; case maybe_stmt of - Nothing -> return (pcs, Nothing) - Just (n:ns, _) -> return (pcs, lookupType hst type_env n) - } - hscParseStmt :: DynFlags -> String -> IO (Maybe RdrNameStmt) hscParseStmt dflags str = do -------------------------- Parser ---------------- @@ -622,6 +598,64 @@ hscParseStmt dflags str %************************************************************************ %* * +\subsection{Getting information about an identifer} +%* * +%************************************************************************ + +\begin{code} +#ifdef GHCI +hscThing -- like hscStmt, but deals with a single identifier + :: DynFlags + -> HomeSymbolTable + -> HomeIfaceTable + -> PersistentCompilerState -- IN: persistent compiler state + -> InteractiveContext -- Context for compiling + -> String -- The identifier + -> IO ( PersistentCompilerState, + [TyThing] ) + +hscThing dflags hst hit pcs0 icontext str + = do let + InteractiveContext { + ic_rn_env = rn_env, + ic_type_env = type_env, + ic_module = scope_mod } = icontext + + rdr_names + | '.' `elem` str + = [ mkQual ns (fmod,fvar) | ns <- namespaces var ] + | otherwise + = [ mkUnqual ns fstr | ns <- namespaces str ] + where (mod,var) = split_longest_prefix str '.' + fmod = mkFastString mod + fvar = mkFastString var + fstr = mkFastString str + namespaces s | isLower (head s) = [ varName ] + | otherwise = [ tcClsName, dataName ] + + (pcs, unqual, maybe_rn_result) <- + renameRdrName dflags hit hst pcs0 scope_mod scope_mod + rn_env rdr_names + + case maybe_rn_result of { + Nothing -> return (pcs, []); + Just (names, decls) -> do { + + maybe_pcs <- typecheckExtraDecls dflags pcs hst unqual + iNTERACTIVE decls; + + case maybe_pcs of { + Nothing -> return (pcs, []); + Just pcs -> + let maybe_ty_things = map (lookupType hst (pcs_PTE pcs)) names + in + return (pcs, catMaybes maybe_ty_things) } + }} +#endif +\end{code} + +%************************************************************************ +%* * \subsection{Initial persistent state} %* * %************************************************************************ diff --git a/ghc/compiler/main/MkIface.lhs b/ghc/compiler/main/MkIface.lhs index 5d8f7c0..eb7b663 100644 --- a/ghc/compiler/main/MkIface.lhs +++ b/ghc/compiler/main/MkIface.lhs @@ -115,7 +115,7 @@ mkFinalIface ghci_mode dflags location hi_file_path = ml_hi_file location new_decls = mkIfaceDecls ty_cls_dcls rule_dcls inst_dcls inst_dcls = map ifaceInstance (md_insts new_details) - ty_cls_dcls = foldNameEnv ifaceTyCls [] (md_types new_details) + ty_cls_dcls = foldNameEnv ifaceTyCls_acc [] (md_types new_details) rule_dcls = map ifaceRule (md_rules new_details) orphan_mod = isOrphanModule (mi_module new_iface) new_details @@ -137,10 +137,22 @@ isOrphanModule this_mod (ModDetails {md_insts = insts, md_rules = rules}) no_locals names = isEmptyNameSet (filterNameSet (nameIsLocalOrFrom this_mod) names) \end{code} +Implicit Ids and class tycons aren't included in interface files, so +we miss them out of the accumulating parameter here. + +\begin{code} +ifaceTyCls_acc :: TyThing -> [RenamedTyClDecl] -> [RenamedTyClDecl] +ifaceTyCls_acc (AnId id) so_far | isImplicitId id = so_far +ifaceTyCls_acc (ATyCon id) so_far | isClassTyCon id = so_far +ifaceTyCls_acc other so_far = ifaceTyCls other : so_far +\end{code} + +Convert *any* TyThing into a RenamedTyClDecl. Used both for +generating interface files and for the ':info' command in GHCi. + \begin{code} -ifaceTyCls :: TyThing -> [RenamedTyClDecl] -> [RenamedTyClDecl] -ifaceTyCls (AClass clas) so_far - = cls_decl : so_far +ifaceTyCls :: TyThing -> RenamedTyClDecl +ifaceTyCls (AClass clas) = cls_decl where cls_decl = ClassDecl { tcdCtxt = toHsContext sc_theta, tcdName = getName clas, @@ -167,9 +179,7 @@ ifaceTyCls (AClass clas) so_far GenDefMeth -> GenDefMeth DefMeth id -> DefMeth (getName id) -ifaceTyCls (ATyCon tycon) so_far - | isClassTyCon tycon = so_far - | otherwise = ty_decl : so_far +ifaceTyCls (ATyCon tycon) = ty_decl where ty_decl | isSynTyCon tycon = TySynonym { tcdName = getName tycon, @@ -221,9 +231,7 @@ ifaceTyCls (ATyCon tycon) so_far mk_field strict_mark field_label = ([getName field_label], BangType strict_mark (toHsType (fieldLabelType field_label))) -ifaceTyCls (AnId id) so_far - | isImplicitId id = so_far - | otherwise = iface_sig : so_far +ifaceTyCls (AnId id) = iface_sig where iface_sig = IfaceSig { tcdName = getName id, tcdType = toHsType id_type, diff --git a/ghc/compiler/rename/Rename.lhs b/ghc/compiler/rename/Rename.lhs index 209ef63..1a75cb3 100644 --- a/ghc/compiler/rename/Rename.lhs +++ b/ghc/compiler/rename/Rename.lhs @@ -4,7 +4,10 @@ \section[Rename]{Renaming and dependency analysis passes} \begin{code} -module Rename ( renameModule, renameStmt, closeIfaceDecls, checkOldIface ) where +module Rename ( + renameModule, renameStmt, renameRdrName, + closeIfaceDecls, checkOldIface + ) where #include "HsVersions.h" @@ -34,8 +37,9 @@ import RnEnv ( availsToNameSet, mkIfaceGlobalRdrEnv, emptyAvailEnv, unitAvailEnv, availEnvElts, plusAvailEnv, groupAvails, warnUnusedImports, warnUnusedLocalBinds, warnUnusedModules, - lookupSrcName, getImplicitStmtFVs, getImplicitModuleFVs, - newGlobalName, unQualInScope,, ubiquitousNames + lookupSrcName, getImplicitStmtFVs, + getImplicitModuleFVs, newGlobalName, unQualInScope, + ubiquitousNames, lookupOccRn ) import Module ( Module, ModuleName, WhereFrom(..), moduleNameUserString, moduleName, @@ -73,7 +77,7 @@ import List ( partition, nub ) %********************************************************* %* * -\subsection{The two main wrappers} +\subsection{The main wrappers} %* * %********************************************************* @@ -91,7 +95,6 @@ renameModule dflags hit hst pcs this_module rdr_module rename this_module rdr_module \end{code} - \begin{code} renameStmt :: DynFlags -> HomeIfaceTable -> HomeSymbolTable @@ -108,54 +111,103 @@ renameStmt :: DynFlags renameStmt dflags hit hst pcs scope_module this_module local_env stmt = renameSource dflags hit hst pcs this_module $ - -- Load the interface for the context module, so - -- that we can get its top-level lexical environment - -- Bale out if we fail to do this - loadInterface doc (moduleName scope_module) ImportByUser `thenRn` \ iface -> - let rdr_env = mi_globals iface - print_unqual = unQualInScope rdr_env - in - checkErrsRn `thenRn` \ no_errs_so_far -> - if not no_errs_so_far then - returnRn (print_unqual, Nothing) - else + -- load the context module + loadContextModule scope_module $ \ (rdr_env, print_unqual) -> - -- Rename it + -- Rename the stmt initRnMS rdr_env local_env emptyLocalFixityEnv CmdLineMode ( rnStmt stmt $ \ stmt' -> returnRn (([], stmt'), emptyFVs) - ) `thenRn` \ ((binders, stmt), fvs) -> + ) `thenRn` \ ((binders, stmt), fvs) -> -- Bale out if we fail - checkErrsRn `thenRn` \ no_errs_so_far -> + checkErrsRn `thenRn` \ no_errs_so_far -> if not no_errs_so_far then - doDump [] stmt [] `thenRn_` returnRn (print_unqual, Nothing) + doDump dflags [] stmt [] `thenRn_` returnRn (print_unqual, Nothing) else - -- Add implicit free vars, and close decls - getImplicitStmtFVs `thenRn` \ implicit_fvs -> - let - filtered_fvs = fvs `delListFromNameSet` rdrEnvElts local_env - source_fvs = implicit_fvs `plusFV` filtered_fvs - in - slurpImpDecls source_fvs `thenRn` \ decls -> + slurpImplicitDecls fvs local_env `thenRn` \ decls -> - doDump binders stmt decls `thenRn_` + doDump dflags binders stmt decls `thenRn_` returnRn (print_unqual, Just (binders, (stmt, decls))) where - doc = text "context for compiling expression" - - doDump :: [Name] -> RenamedStmt -> [RenamedHsDecl] -> RnMG (Either IOError ()) - doDump bndrs stmt decls - = getDOptsRn `thenRn` \ dflags -> - ioToRnM (dumpIfSet_dyn dflags Opt_D_dump_rn "Renamer:" + doDump :: DynFlags -> [Name] -> RenamedStmt -> [RenamedHsDecl] + -> RnMG (Either IOError ()) + doDump dflags bndrs stmt decls + = ioToRnM (dumpIfSet_dyn dflags Opt_D_dump_rn "Renamer:" (vcat [text "Binders:" <+> ppr bndrs, ppr stmt, text "", vcat (map ppr decls)])) -\end{code} +renameRdrName + :: DynFlags + -> HomeIfaceTable -> HomeSymbolTable + -> PersistentCompilerState + -> Module -- current context (scope to compile in) + -> Module -- current module + -> LocalRdrEnv -- current context (temp bindings) + -> [RdrName] -- name to rename + -> IO ( PersistentCompilerState, + PrintUnqualified, + Maybe ([Name], [RenamedHsDecl]) + ) + +renameRdrName dflags hit hst pcs scope_module this_module local_env rdr_names = + renameSource dflags hit hst pcs this_module $ + loadContextModule scope_module $ \ (rdr_env, print_unqual) -> + + -- rename the rdr_name + initRnMS rdr_env local_env emptyLocalFixityEnv CmdLineMode + (mapRn (tryRn.lookupOccRn) rdr_names) `thenRn` \ maybe_names -> + let + ok_names = [ a | Right a <- maybe_names ] + in + if null ok_names + then let errs = head [ e | Left e <- maybe_names ] + in setErrsRn errs `thenRn_` + doDump dflags ok_names [] `thenRn_` + returnRn (print_unqual, Nothing) + else + + slurpImplicitDecls (mkNameSet ok_names) local_env `thenRn` \ decls -> + doDump dflags ok_names decls `thenRn_` + returnRn (print_unqual, Just (ok_names, decls)) + where + doDump :: DynFlags -> [Name] -> [RenamedHsDecl] -> RnMG (Either IOError ()) + doDump dflags names decls + = ioToRnM (dumpIfSet_dyn dflags Opt_D_dump_rn "Renamer:" + (vcat [ppr names, text "", + vcat (map ppr decls)])) + + +-- Load the interface for the context module, so +-- that we can get its top-level lexical environment +-- Bale out if we fail to do this +loadContextModule scope_module thing_inside + = let doc = text "context for compiling expression" + in + loadInterface doc (moduleName scope_module) ImportByUser `thenRn` \ iface -> + let rdr_env = mi_globals iface + print_unqual = unQualInScope rdr_env + in + checkErrsRn `thenRn` \ no_errs_so_far -> + if not no_errs_so_far then + returnRn (print_unqual, Nothing) + else + thing_inside (rdr_env, print_unqual) + +-- Add implicit free vars, and close decls +slurpImplicitDecls fvs local_env + = getImplicitStmtFVs `thenRn` \ implicit_fvs -> + let + filtered_fvs = fvs `delListFromNameSet` rdrEnvElts local_env + source_fvs = implicit_fvs `plusFV` filtered_fvs + in + slurpImpDecls source_fvs +\end{code} + %********************************************************* %* * \subsection{The main function: rename} diff --git a/ghc/compiler/rename/RnMonad.lhs b/ghc/compiler/rename/RnMonad.lhs index 7e8c679..02327bf 100644 --- a/ghc/compiler/rename/RnMonad.lhs +++ b/ghc/compiler/rename/RnMonad.lhs @@ -551,6 +551,21 @@ warnWithRn res msg (RnDown {rn_errs = errs_var, rn_loc = loc}) l_down where warn = addShortWarnLocLine loc msg +tryRn :: RnM d a -> RnM d (Either Messages a) +tryRn try_this down@(RnDown {rn_errs = errs_var}) l_down + = do current_msgs <- readIORef errs_var + writeIORef errs_var (emptyBag,emptyBag) + a <- try_this down l_down + (warns, errs) <- readIORef errs_var + writeIORef errs_var current_msgs + if (isEmptyBag errs) + then return (Right a) + else return (Left (warns,errs)) + +setErrsRn :: Messages -> RnM d () +setErrsRn msgs down@(RnDown {rn_errs = errs_var}) l_down + = do writeIORef errs_var msgs; return () + addErrRn :: Message -> RnM d () addErrRn err = failWithRn () err diff --git a/ghc/compiler/typecheck/TcModule.lhs b/ghc/compiler/typecheck/TcModule.lhs index 03f953f..acb7b66 100644 --- a/ghc/compiler/typecheck/TcModule.lhs +++ b/ghc/compiler/typecheck/TcModule.lhs @@ -6,6 +6,7 @@ \begin{code} module TcModule ( typecheckModule, typecheckIface, typecheckStmt, typecheckExpr, + typecheckExtraDecls, TcResults(..) ) where @@ -289,6 +290,33 @@ typecheckExpr dflags pcs hst ic_type_env unqual this_mod (expr, decls) %************************************************************************ %* * +\subsection{Typechecking extra declarations} +%* * +%************************************************************************ + +\begin{code} +typecheckExtraDecls + :: DynFlags + -> PersistentCompilerState + -> HomeSymbolTable + -> PrintUnqualified -- For error printing + -> Module -- Is this really needed + -> [RenamedHsDecl] -- extra decls sucked in from interface files + -> IO (Maybe PersistentCompilerState) + +typecheckExtraDecls dflags pcs hst unqual this_mod decls + = typecheck dflags pcs hst unqual $ + fixTc (\ ~(unf_env, _, _, _, _) -> + tcImports unf_env pcs hst get_fixity this_mod decls + ) `thenTc` \ (env, new_pcs, local_inst_info, deriv_binds, local_rules) -> + ASSERT( null local_inst_info && nullBinds deriv_binds && null local_rules ) + returnTc new_pcs + where + get_fixity n = pprPanic "typecheckExpr" (ppr n) +\end{code} + +%************************************************************************ +%* * \subsection{Typechecking a module} %* * %************************************************************************ -- 1.7.10.4