From 1c62b517711ac232a8024d91fd4b317a6804d28e Mon Sep 17 00:00:00 2001 From: simonmar Date: Mon, 26 Feb 2001 15:07:02 +0000 Subject: [PATCH] [project @ 2001-02-26 15:06:57 by simonmar] Implement do-style bindings on the GHCi command line. The syntax for a command-line is exactly that of a do statement, with the following meanings: - `pat <- expr' performs expr, and binds each of the variables in pat. - `let pat = expr; ...' binds each of the variables in pat, doesn't do any evaluation - `expr' behaves as `it <- expr' if expr is IO-typed, or `let it = expr' followed by `print it' otherwise. --- ghc/compiler/basicTypes/IdInfo.lhs | 14 +- ghc/compiler/basicTypes/Name.lhs | 38 +-- ghc/compiler/compMan/CmLink.lhs | 7 + ghc/compiler/compMan/CompManager.lhs | 282 ++++++++++++------- ghc/compiler/coreSyn/CoreTidy.lhs | 9 +- ghc/compiler/deSugar/DsBinds.lhs | 4 +- ghc/compiler/deSugar/DsExpr.lhs | 78 +++--- ghc/compiler/deSugar/DsGRHSs.lhs | 16 +- ghc/compiler/deSugar/DsListComp.lhs | 21 +- ghc/compiler/deSugar/DsMonad.lhs | 16 +- ghc/compiler/deSugar/DsUtils.lhs | 4 +- ghc/compiler/deSugar/Match.hi-boot | 2 +- ghc/compiler/deSugar/Match.hi-boot-5 | 2 +- ghc/compiler/deSugar/Match.lhs | 101 ++----- ghc/compiler/ghci/InteractiveUI.hs | 228 +++++----------- ghc/compiler/hsSyn/HsBinds.lhs | 3 +- ghc/compiler/hsSyn/HsExpr.hi-boot | 8 +- ghc/compiler/hsSyn/HsExpr.hi-boot-5 | 11 +- ghc/compiler/hsSyn/HsExpr.lhs | 256 ++++++++++++++--- ghc/compiler/hsSyn/HsPat.lhs | 1 + ghc/compiler/hsSyn/HsSyn.lhs | 23 +- ghc/compiler/main/HscMain.lhs | 169 ++++++++---- ghc/compiler/main/HscTypes.lhs | 62 ++++- ghc/compiler/parser/ParseUtil.lhs | 2 +- ghc/compiler/parser/Parser.y | 26 +- ghc/compiler/prelude/PrelNames.lhs | 44 ++- ghc/compiler/prelude/TysPrim.lhs | 2 +- ghc/compiler/rename/Rename.lhs | 140 +++++----- ghc/compiler/rename/RnBinds.lhs | 4 +- ghc/compiler/rename/RnEnv.lhs | 16 +- ghc/compiler/rename/RnExpr.lhs | 69 ++--- ghc/compiler/rename/RnHiFiles.lhs | 12 +- ghc/compiler/rename/RnIfaces.lhs | 8 +- ghc/compiler/rename/RnMonad.lhs | 11 +- ghc/compiler/rename/RnNames.lhs | 6 +- ghc/compiler/rename/RnSource.lhs | 6 +- ghc/compiler/typecheck/TcBinds.lhs | 5 +- ghc/compiler/typecheck/TcClassDcl.lhs | 2 +- ghc/compiler/typecheck/TcDeriv.lhs | 2 +- ghc/compiler/typecheck/TcEnv.lhs | 38 ++- ghc/compiler/typecheck/TcExpr.lhs | 42 ++- ghc/compiler/typecheck/TcGenDeriv.lhs | 7 +- ghc/compiler/typecheck/TcHsSyn.lhs | 11 +- ghc/compiler/typecheck/TcIfaceSig.lhs | 2 +- ghc/compiler/typecheck/TcMatches.hi-boot | 2 +- ghc/compiler/typecheck/TcMatches.hi-boot-5 | 2 +- ghc/compiler/typecheck/TcMatches.lhs | 88 +++--- ghc/compiler/typecheck/TcModule.lhs | 410 +++++++++++++++++----------- ghc/compiler/typecheck/TcSimplify.lhs | 10 +- ghc/compiler/utils/Outputable.lhs | 6 +- 50 files changed, 1335 insertions(+), 993 deletions(-) diff --git a/ghc/compiler/basicTypes/IdInfo.lhs b/ghc/compiler/basicTypes/IdInfo.lhs index 76cb1f9..ca1e2b3 100644 --- a/ghc/compiler/basicTypes/IdInfo.lhs +++ b/ghc/compiler/basicTypes/IdInfo.lhs @@ -16,7 +16,7 @@ module IdInfo ( zapFragileInfo, zapLamInfo, zapSpecPragInfo, shortableIdInfo, copyIdInfo, -- Flavour - IdFlavour(..), flavourInfo, + IdFlavour(..), flavourInfo, makeConstantFlavour, setNoDiscardInfo, setFlavourInfo, ppFlavourInfo, @@ -267,6 +267,18 @@ data IdFlavour | RecordSelId FieldLabel -- The Id for a record selector +makeConstantFlavour :: IdFlavour -> IdFlavour +makeConstantFlavour flavour = new_flavour + where new_flavour = case flavour of + VanillaId -> ConstantId + ExportedId -> ConstantId + ConstantId -> ConstantId -- e.g. Default methods + DictFunId -> DictFunId + flavour -> pprTrace "makeConstantFlavour" + (ppFlavourInfo flavour) + flavour + + ppFlavourInfo :: IdFlavour -> SDoc ppFlavourInfo VanillaId = empty ppFlavourInfo ExportedId = ptext SLIT("[Exported]") diff --git a/ghc/compiler/basicTypes/Name.lhs b/ghc/compiler/basicTypes/Name.lhs index aef8355..0e0524e 100644 --- a/ghc/compiler/basicTypes/Name.lhs +++ b/ghc/compiler/basicTypes/Name.lhs @@ -20,10 +20,11 @@ module Name ( toRdrName, hashName, globaliseName, localiseName, - nameSrcLoc, nameIsLocallyDefined, isDllName, nameIsFrom, nameIsLocalOrFrom, + nameSrcLoc, isSystemName, isLocalName, isGlobalName, isExternallyVisibleName, - isTyVarName, + isTyVarName, isDllName, + nameIsLocalOrFrom, isHomePackageName, -- Environment NameEnv, mkNameEnv, @@ -35,8 +36,7 @@ module Name ( -- Class NamedThing and overloaded friends NamedThing(..), - getSrcLoc, getOccString, toRdrName, - isFrom, isLocalOrFrom + getSrcLoc, getOccString, toRdrName ) where #include "HsVersions.h" @@ -121,26 +121,29 @@ nameModule_maybe name = Nothing \end{code} \begin{code} -nameIsLocallyDefined :: Name -> Bool -nameIsFrom :: Module -> Name -> Bool nameIsLocalOrFrom :: Module -> Name -> Bool isLocalName :: Name -> Bool -- Not globals isGlobalName :: Name -> Bool isSystemName :: Name -> Bool isExternallyVisibleName :: Name -> Bool +isHomePackageName :: Name -> Bool isGlobalName (Name {n_sort = Global _}) = True isGlobalName other = False isLocalName name = not (isGlobalName name) -nameIsLocallyDefined name = isLocalName name - nameIsLocalOrFrom from (Name {n_sort = Global mod}) = mod == from nameIsLocalOrFrom from other = True -nameIsFrom from (Name {n_sort = Global mod}) = mod == from -nameIsFrom from other = pprPanic "nameIsFrom" (ppr other) +isHomePackageName (Name {n_sort = Global mod}) = isHomeModule mod +isHomePackageName other = True -- Local and system names + +isDllName :: Name -> Bool -- Does this name refer to something in a different DLL? +isDllName nm = not opt_Static && not (isHomePackageName nm) + +isTyVarName :: Name -> Bool +isTyVarName name = isTvOcc (nameOccName name) -- Global names are by definition those that are visible -- outside the module, *as seen by the linker*. Externally visible @@ -238,17 +241,6 @@ nameRdrName :: Name -> RdrName -- and an unqualified name just for Locals nameRdrName (Name { n_occ = occ, n_sort = Global mod }) = mkRdrOrig (moduleName mod) occ nameRdrName (Name { n_occ = occ }) = mkRdrUnqual occ - -isDllName :: Name -> Bool - -- Does this name refer to something in a different DLL? -isDllName nm = not opt_Static && - not (isLocalName nm) && -- isLocalName test needed 'cos - not (isHomeModule (nameModule nm)) -- nameModule won't work on local names - - - -isTyVarName :: Name -> Bool -isTyVarName name = isTvOcc (nameOccName name) \end{code} @@ -390,13 +382,9 @@ class NamedThing a where getSrcLoc :: NamedThing a => a -> SrcLoc getOccString :: NamedThing a => a -> String toRdrName :: NamedThing a => a -> RdrName -isFrom :: NamedThing a => Module -> a -> Bool -isLocalOrFrom :: NamedThing a => Module -> a -> Bool getSrcLoc = nameSrcLoc . getName getOccString = occNameString . getOccName toRdrName = nameRdrName . getName -isFrom mod x = nameIsFrom mod (getName x) -isLocalOrFrom mod x = nameIsLocalOrFrom mod ( getName x) \end{code} diff --git a/ghc/compiler/compMan/CmLink.lhs b/ghc/compiler/compMan/CmLink.lhs index 3b3e28b..9b1045d 100644 --- a/ghc/compiler/compMan/CmLink.lhs +++ b/ghc/compiler/compMan/CmLink.lhs @@ -8,6 +8,7 @@ module CmLink ( Linkable(..), Unlinked(..), filterModuleLinkables, findModuleLinkable_maybe, LinkResult(..), + updateClosureEnv, link, unload, PersistentLinkerState{-abstractly!-}, emptyPLS, @@ -23,6 +24,7 @@ import CmTypes import CmStaticInfo ( GhciMode(..) ) import Outputable ( SDoc ) import Digraph ( SCC(..), flattenSCC ) +import Name ( Name ) import Module ( ModuleName ) import FiniteMap import Outputable @@ -88,6 +90,11 @@ emptyPLS = return (PersistentLinkerState { closure_env = emptyFM, emptyPLS = return (PersistentLinkerState {}) #endif +updateClosureEnv :: PersistentLinkerState -> [(Name,HValue)] + -> IO PersistentLinkerState +updateClosureEnv pls new_bindings + = return pls{ closure_env = addListToFM (closure_env pls) new_bindings } + ----------------------------------------------------------------------------- -- Unloading old objects ready for a new compilation sweep. -- diff --git a/ghc/compiler/compMan/CompManager.lhs b/ghc/compiler/compMan/CompManager.lhs index f136af7..73c5bf3 100644 --- a/ghc/compiler/compMan/CompManager.lhs +++ b/ghc/compiler/compMan/CompManager.lhs @@ -4,12 +4,19 @@ \section[CompManager]{The Compilation Manager} \begin{code} -module CompManager ( cmInit, cmLoadModule, cmUnload, +module CompManager ( + cmInit, -- :: GhciMode -> IO CmState + cmLoadModule, -- :: CmState -> FilePath -> IO (CmState, [String]) + cmUnload, -- :: CmState -> IO CmState + cmTypeOfName, -- :: CmState -> Name -> IO (Maybe String) + + cmSetContext, -- :: CmState -> String -> IO CmState + cmGetContext, -- :: CmState -> IO String #ifdef GHCI - cmGetExpr, cmRunExpr, + cmRunStmt, -- :: CmState -> DynFlags -> String -> IO (CmState, [Name]) #endif - CmState, emptyCmState -- abstract - ) + CmState, emptyCmState -- abstract + ) where #include "HsVersions.h" @@ -17,16 +24,19 @@ where import CmLink import CmTypes import HscTypes +import RnEnv ( unQualInScope ) +import Id ( idType, idName ) +import Name ( Name, lookupNameEnv ) +import RdrName ( emptyRdrEnv ) import Module ( Module, ModuleName, moduleName, isHomeModule, - mkModuleName, moduleNameUserString ) + mkModuleName, moduleNameUserString, moduleUserString ) import CmStaticInfo ( GhciMode(..) ) import DriverPipeline import GetImports -import HscTypes ( HomeSymbolTable, HomeIfaceTable, - PersistentCompilerState, ModDetails(..) ) +import HscTypes import HscMain ( initPersistentCompilerState ) import Finder -import UniqFM ( emptyUFM, lookupUFM, addToUFM, delListFromUFM, +import UniqFM ( lookupUFM, addToUFM, delListFromUFM, UniqFM, listToUFM ) import Unique ( Uniquable ) import Digraph ( SCC(..), stronglyConnComp, flattenSCC ) @@ -44,8 +54,7 @@ import IOExts #ifdef GHCI import Interpreter ( HValue ) -import HscMain ( hscExpr ) -import Type ( Type ) +import HscMain ( hscStmt ) import PrelGHC ( unsafeCoerce# ) #endif @@ -63,43 +72,6 @@ import Maybe ( catMaybes, fromMaybe, isJust, fromJust ) \begin{code} -cmInit :: GhciMode -> IO CmState -cmInit gmode - = emptyCmState gmode - -#ifdef GHCI -cmGetExpr :: CmState - -> DynFlags - -> Bool -- True <=> wrap in 'print' to get an IO-typed result - -> Module - -> String - -> IO (CmState, Maybe (HValue, PrintUnqualified, Type)) -cmGetExpr cmstate dflags wrap_io mod expr - = do (new_pcs, maybe_stuff) <- - hscExpr dflags wrap_io hst hit pcs mod expr - case maybe_stuff of - Nothing -> return (cmstate{ pcs=new_pcs }, Nothing) - Just (bcos, print_unqual, ty) -> do - hValue <- linkExpr pls bcos - return (cmstate{ pcs=new_pcs }, - Just (hValue, print_unqual, ty)) - - -- ToDo: check that the module we passed in is sane/exists? - where - CmState{ hst=hst, hit=hit, pcs=pcs, pls=pls } = cmstate - --- The HValue should represent a value of type IO () (Perhaps IO a?) -cmRunExpr :: HValue -> IO () -cmRunExpr hval - = do unsafeCoerce# hval :: IO () - -- putStrLn "done." -#endif - -emptyHIT :: HomeIfaceTable -emptyHIT = emptyUFM -emptyHST :: HomeSymbolTable -emptyHST = emptyUFM - -- Persistent state for the entire system data CmState = CmState { @@ -108,23 +80,33 @@ data CmState ui :: UnlinkedImage, -- the unlinked images mg :: ModuleGraph, -- the module graph gmode :: GhciMode, -- NEVER CHANGES + ic :: InteractiveContext, -- command-line binding info pcs :: PersistentCompilerState, -- compile's persistent state pls :: PersistentLinkerState -- link's persistent state } -emptyCmState :: GhciMode -> IO CmState -emptyCmState gmode +emptyCmState :: GhciMode -> Module -> IO CmState +emptyCmState gmode mod = do pcs <- initPersistentCompilerState pls <- emptyPLS - return (CmState { hst = emptyHST, - hit = emptyHIT, - ui = emptyUI, - mg = emptyMG, - gmode = gmode, + return (CmState { hst = emptySymbolTable, + hit = emptyIfaceTable, + ui = emptyUI, + mg = emptyMG, + gmode = gmode, + ic = emptyInteractiveContext mod, pcs = pcs, pls = pls }) +emptyInteractiveContext mod + = InteractiveContext { ic_module = mod, + ic_rn_env = emptyRdrEnv, + ic_type_env = emptyTypeEnv } + +defaultCurrentModuleName = mkModuleName "Prelude" +GLOBAL_VAR(defaultCurrentModule, error "no defaultCurrentModule", Module) + -- CM internal types type UnlinkedImage = [Linkable] -- the unlinked images (should be a set, really) emptyUI :: UnlinkedImage @@ -134,12 +116,106 @@ type ModuleGraph = [ModSummary] -- the module graph, topologically sorted emptyMG :: ModuleGraph emptyMG = [] -\end{code} +----------------------------------------------------------------------------- +-- Produce an initial CmState. + +cmInit :: GhciMode -> IO CmState +cmInit mode = do + prel <- moduleNameToModule defaultCurrentModuleName + writeIORef defaultCurrentModule prel + emptyCmState mode prel -Unload the compilation manager's state: everything it knows about the -current collection of modules in the Home package. +----------------------------------------------------------------------------- +-- Setting the context doesn't throw away any bindings; the bindings +-- we've built up in the InteractiveContext simply move to the new +-- module. They always shadow anything in scope in the current context. + +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 ] + + m <- case lookup mn modules_loaded of + Just m -> return m + Nothing -> do + mod <- moduleNameToModule mn + if isHomeModule mod + then throwDyn (OtherError (showSDoc + (quotes (ppr (moduleName mod)) + <+> text "is not currently loaded"))) + else return mod + + return cmstate{ ic = (ic cmstate){ic_module=m} } + +cmGetContext :: CmState -> IO String +cmGetContext cmstate = return (moduleUserString (ic_module (ic cmstate))) + +moduleNameToModule :: ModuleName -> IO Module +moduleNameToModule mn + = do maybe_stuff <- findModule mn + case maybe_stuff of + Nothing -> throwDyn (OtherError ("can't find module `" + ++ moduleNameUserString mn ++ "'")) + Just (m,_) -> return m + +----------------------------------------------------------------------------- +-- cmRunStmt: Run a statement/expr. + +#ifdef GHCI +cmRunStmt :: CmState -> DynFlags -> String -> IO (CmState, [Name]) +cmRunStmt cmstate dflags expr + = do (new_pcs, maybe_stuff) <- hscStmt dflags hst hit pcs (ic cmstate) expr + case maybe_stuff of + Nothing -> return (cmstate{ pcs=new_pcs }, []) + Just (new_ic, ids, bcos) -> do + hval <- linkExpr pls bcos + hvals <- unsafeCoerce# hval :: IO [HValue] + let names = map idName ids + new_pls <- updateClosureEnv pls (zip names hvals) + return (cmstate{ pcs=new_pcs, pls=new_pls, ic=new_ic }, names) + + -- ToDo: check that the module we passed in is sane/exists? + where + CmState{ hst=hst, hit=hit, pcs=pcs, pls=pls } = cmstate +#endif + +----------------------------------------------------------------------------- +-- cmTypeOf: returns a string representing the type of a name. + +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) + str = case lookupIfaceByModName hit pit modname of + Nothing -> showSDoc (ppr (idType id)) + Just iface -> showSDocForUser unqual (ppr (idType id)) + where unqual = unQualInScope (mi_globals iface) + in return (Just str) + + _ -> panic "cmTypeOfName" + +----------------------------------------------------------------------------- +-- cmInfo: return "info" about an expression. The info might be: +-- +-- * its type, for an expression, +-- * the class definition, for a class +-- * the datatype definition, for a tycon (or synonym) +-- * the export list, for a module +-- +-- Can be used to find the type of the last expression compiled, by looking +-- for "it". + +cmInfo :: CmState -> String -> IO (Maybe String) +cmInfo cmstate str + = do error "cmInfo not implemented yet" + +----------------------------------------------------------------------------- +-- Unload the compilation manager's state: everything it knows about the +-- current collection of modules in the Home package. -\begin{code} cmUnload :: CmState -> IO CmState cmUnload state = do -- Throw away the old home dir cache @@ -149,18 +225,17 @@ cmUnload state where CmState{ hst=hst, hit=hit } = state (new_hst, new_hit) = retainInTopLevelEnvs [] (hst,hit) -\end{code} -The real business of the compilation manager: given a system state and -a module name, try and bring the module up to date, probably changing -the system state at the same time. +----------------------------------------------------------------------------- +-- The real business of the compilation manager: given a system state and +-- a module name, try and bring the module up to date, probably changing +-- the system state at the same time. -\begin{code} cmLoadModule :: CmState -> FilePath -> IO (CmState, -- new state Bool, -- was successful - [Module]) -- list of modules loaded + [String]) -- list of modules loaded cmLoadModule cmstate1 rootname = do -- version 1's are the original, before downsweep @@ -172,6 +247,7 @@ cmLoadModule cmstate1 rootname -- the previous pass, if any. let ui1 = ui cmstate1 let mg1 = mg cmstate1 + let ic1 = ic cmstate1 let ghci_mode = gmode cmstate1 -- this never changes @@ -228,7 +304,7 @@ cmLoadModule cmstate1 rootname valid_linkables when (verb >= 2) $ - putStrLn (showSDoc (text "STABLE MODULES:" + putStrLn (showSDoc (text "Stable modules:" <+> sep (map (text.moduleNameUserString) stable_mods))) -- unload any modules which aren't going to be re-linked this @@ -289,19 +365,11 @@ cmLoadModule cmstate1 rootname -- clean up after ourselves cleanTempFilesExcept verb (ppFilesFromSummaries modsDone) - linkresult - <- link ghci_mode dflags a_root_is_Main ui3 pls2 - case linkresult of - LinkErrs _ _ - -> panic "cmLoadModule: link failed (1)" - LinkOK pls3 - -> do let cmstate3 - = CmState { hst=hst3, hit=hit3, - ui=ui3, mg=modsDone, - gmode=ghci_mode, - pcs=pcs3, pls=pls3 } - return (cmstate3, True, - map ms_mod modsDone) + -- link everything together + linkresult <- link ghci_mode dflags a_root_is_Main ui3 pls2 + + cmLoadFinish True linkresult + hst3 hit3 ui3 modsDone ghci_mode pcs3 else -- Tricky. We need to back out the effects of compiling any @@ -313,34 +381,50 @@ cmLoadModule cmstate1 rootname let modsDone_names = map name_of_summary modsDone let mods_to_zap_names - = findPartiallyCompletedCycles modsDone_names mg2_with_srcimps - let (hst4, hit4, ui4) + = findPartiallyCompletedCycles modsDone_names + mg2_with_srcimps + let (hst4, hit4, ui4) = removeFromTopLevelEnvs mods_to_zap_names (hst3,hit3,ui3) + let mods_to_keep - = filter ((`notElem` mods_to_zap_names).name_of_summary) modsDone - let mods_to_keep_names - = map name_of_summary mods_to_keep - -- we could get the relevant linkables by filtering newLis, but - -- it seems easier to drag them out of the updated, cleaned-up UI - let linkables_to_link - = map (unJust "linkables_to_link" . findModuleLinkable_maybe ui4) - mods_to_keep_names + = filter ((`notElem` mods_to_zap_names).name_of_summary) + modsDone -- clean up after ourselves cleanTempFilesExcept verb (ppFilesFromSummaries mods_to_keep) - linkresult <- link ghci_mode dflags False linkables_to_link pls2 - case linkresult of - LinkErrs _ _ - -> panic "cmLoadModule: link failed (2)" - LinkOK pls3 - -> do let cmstate4 - = CmState { hst=hst4, hit=hit4, - ui=ui4, mg=mods_to_keep, - gmode=ghci_mode, pcs=pcs3, pls=pls3 } - return (cmstate4, False, - map ms_mod mods_to_keep) + -- link everything together + linkresult <- link ghci_mode dflags False ui4 pls2 + cmLoadFinish False linkresult + hst4 hit4 ui4 mods_to_keep ghci_mode pcs3 + + +-- Finish up after a cmLoad. +-- +-- Empty the interactive context and set the module context to the topmost +-- newly loaded module, or the Prelude if none were loaded. +cmLoadFinish ok linkresult hst hit ui mods ghci_mode pcs + = do case linkresult of { + LinkErrs _ _ -> panic "cmLoadModule: link failed (2)"; + LinkOK pls -> do + + def_mod <- readIORef defaultCurrentModule + let current_mod = case mods of + [] -> def_mod + (x:_) -> ms_mod x + + new_ic = emptyInteractiveContext current_mod + + new_cmstate = CmState{ hst=hst, hit=hit, + ui=ui, mg=mods, + gmode=ghci_mode, pcs=pcs, + pls=pls, + ic = new_ic } + mods_loaded = map (moduleNameUserString.name_of_summary) mods + + return (new_cmstate, ok, mods_loaded) + } ppFilesFromSummaries summaries = [ fn | Just fn <- map (ml_hspp_file . ms_location) summaries ] diff --git a/ghc/compiler/coreSyn/CoreTidy.lhs b/ghc/compiler/coreSyn/CoreTidy.lhs index 5692636..2eb70e1 100644 --- a/ghc/compiler/coreSyn/CoreTidy.lhs +++ b/ghc/compiler/coreSyn/CoreTidy.lhs @@ -387,16 +387,9 @@ tidyIdInfo us tidy_env is_external unfold_info arity_info caf_info id -- after this!). where core_idinfo = idInfo id - + new_flavour = makeConstantFlavour (flavourInfo core_idinfo) -- A DFunId must stay a DFunId, so that we can gather the -- DFunIds up later. Other local things become ConstantIds. - new_flavour = case flavourInfo core_idinfo of - VanillaId -> ConstantId - ExportedId -> ConstantId - ConstantId -> ConstantId -- e.g. Default methods - DictFunId -> DictFunId - flavour -> pprTrace "tidyIdInfo" (ppr id <+> ppFlavourInfo flavour) - flavour -- This is where we set names to local/global based on whether they really are diff --git a/ghc/compiler/deSugar/DsBinds.lhs b/ghc/compiler/deSugar/DsBinds.lhs index 9cb09ed..cc9c363 100644 --- a/ghc/compiler/deSugar/DsBinds.lhs +++ b/ghc/compiler/deSugar/DsBinds.lhs @@ -78,8 +78,8 @@ dsMonoBinds _ (VarMonoBind var expr) rest dsMonoBinds auto_scc (FunMonoBind fun _ matches locn) rest = putSrcLocDs locn $ - matchWrapper (FunMatch fun) matches error_string `thenDs` \ (args, body) -> - addAutoScc auto_scc (fun, mkLams args body) `thenDs` \ pair -> + matchWrapper (FunRhs (idName fun)) matches error_string `thenDs` \ (args, body) -> + addAutoScc auto_scc (fun, mkLams args body) `thenDs` \ pair -> returnDs (pair : rest) where error_string = "function " ++ showSDoc (ppr fun) diff --git a/ghc/compiler/deSugar/DsExpr.lhs b/ghc/compiler/deSugar/DsExpr.lhs index efd42ff..02dc08e 100644 --- a/ghc/compiler/deSugar/DsExpr.lhs +++ b/ghc/compiler/deSugar/DsExpr.lhs @@ -11,8 +11,8 @@ module DsExpr ( dsExpr, dsLet ) where import HsSyn ( failureFreePat, HsExpr(..), OutPat(..), HsLit(..), ArithSeqInfo(..), - Stmt(..), StmtCtxt(..), Match(..), HsBinds(..), MonoBinds(..), - mkSimpleMatch + Stmt(..), HsMatchContext(..), Match(..), HsBinds(..), MonoBinds(..), + mkSimpleMatch, isDoExpr ) import TcHsSyn ( TypecheckedHsExpr, TypecheckedHsBinds, TypecheckedStmt @@ -95,7 +95,7 @@ dsLet (MonoBind (AbsBinds [] [] binder_triples inlines in mkErrorAppDs iRREFUT_PAT_ERROR_ID result_ty (showSDoc (ppr pat)) `thenDs` \ error_expr -> - matchSimply rhs PatBindMatch pat body' error_expr + matchSimply rhs PatBindRhs pat body' error_expr where result_ty = exprType body @@ -122,7 +122,7 @@ dsExpr (HsLit lit) = dsLit lit -- HsOverLit has been gotten rid of by the type checker dsExpr expr@(HsLam a_Match) - = matchWrapper LambdaMatch [a_Match] "lambda" `thenDs` \ (binders, matching_code) -> + = matchWrapper LambdaExpr [a_Match] "lambda" `thenDs` \ (binders, matching_code) -> returnDs (mkLams binders matching_code) dsExpr expr@(HsApp fun arg) @@ -203,8 +203,8 @@ dsExpr (HsSCC cc expr) dsExpr (HsCase discrim matches src_loc) | all ubx_tuple_match matches = putSrcLocDs src_loc $ - dsExpr discrim `thenDs` \ core_discrim -> - matchWrapper CaseMatch matches "case" `thenDs` \ ([discrim_var], matching_code) -> + dsExpr discrim `thenDs` \ core_discrim -> + matchWrapper CaseAlt matches "case" `thenDs` \ ([discrim_var], matching_code) -> case matching_code of Case (Var x) bndr alts | x == discrim_var -> returnDs (Case core_discrim bndr alts) @@ -215,8 +215,8 @@ dsExpr (HsCase discrim matches src_loc) dsExpr (HsCase discrim matches src_loc) = putSrcLocDs src_loc $ - dsExpr discrim `thenDs` \ core_discrim -> - matchWrapper CaseMatch matches "case" `thenDs` \ ([discrim_var], matching_code) -> + dsExpr discrim `thenDs` \ core_discrim -> + matchWrapper CaseAlt matches "case" `thenDs` \ ([discrim_var], matching_code) -> returnDs (bindNonRec discrim_var core_discrim matching_code) dsExpr (HsLet binds body) @@ -248,8 +248,8 @@ dsExpr (HsDoOut do_or_lc stmts return_id then_id fail_id result_ty src_loc) -> Just elt_ty other -> Nothing -- We need the ListComp form to use deListComp (rather than the "do" form) - -- because the "return" in a do block is a call to "PrelBase.return", and - -- not a ReturnStmt. Only the ListComp form has ReturnStmts + -- because the interpretation of ExprStmt depends on what sort of thing + -- it is. Just elt_ty = maybe_list_comp @@ -430,8 +430,8 @@ dsExpr (RecordUpdOut record_expr record_out_ty dicts rbinds) -- and the right hand sides with applications of the wrapper Id -- so that everything works when we are doing fancy unboxing on the -- constructor aguments. - mapDs mk_alt cons_to_upd `thenDs` \ alts -> - matchWrapper RecUpdMatch alts "record update" `thenDs` \ ([discrim_var], matching_code) -> + mapDs mk_alt cons_to_upd `thenDs` \ alts -> + matchWrapper RecUpd alts "record update" `thenDs` \ ([discrim_var], matching_code) -> returnDs (bindNonRec discrim_var record_expr' matching_code) @@ -490,7 +490,7 @@ dsExpr (ArithSeqIn _) = panic "dsExpr:ArithSeqIn" Basically does the translation given in the Haskell~1.3 report: \begin{code} -dsDo :: StmtCtxt +dsDo :: HsMatchContext -> [TypecheckedStmt] -> Id -- id for: return m -> Id -- id for: (>>=) m @@ -502,34 +502,36 @@ dsDo do_or_lc stmts return_id then_id fail_id result_ty = let (_, b_ty) = splitAppTy result_ty -- result_ty must be of the form (m b) - go [ReturnStmt expr] - = dsExpr expr `thenDs` \ expr2 -> - returnDs (mkApps (Var return_id) [Type b_ty, expr2]) - - go (GuardStmt expr locn : stmts) - = do_expr expr locn `thenDs` \ expr2 -> - go stmts `thenDs` \ rest -> - let msg = "Pattern match failure in do expression, " ++ showSDoc (ppr locn) - in - mkStringLit msg `thenDs` \ core_msg -> - returnDs (mkIfThenElse expr2 - rest - (App (App (Var fail_id) - (Type b_ty)) - core_msg)) - + -- For ExprStmt, see the comments near HsExpr.HsStmt about + -- exactly what ExprStmts mean! + -- + -- In dsDo we can only see DoStmt and ListComp (no gaurds) + + go [ExprStmt expr locn] + | isDoExpr do_or_lc = do_expr expr locn + | otherwise = do_expr expr locn `thenDs` \ expr2 -> + returnDs (mkApps (Var return_id) [Type b_ty, expr2]) + go (ExprStmt expr locn : stmts) + | isDoExpr do_or_lc = do_expr expr locn `thenDs` \ expr2 -> + go stmts `thenDs` \ rest -> let (_, a_ty) = splitAppTy (exprType expr2) -- Must be of form (m a) in - if null stmts then - returnDs expr2 - else - go stmts `thenDs` \ rest -> - newSysLocalDs a_ty `thenDs` \ ignored_result_id -> - returnDs (mkApps (Var then_id) [Type a_ty, Type b_ty, expr2, - Lam ignored_result_id rest]) + newSysLocalDs a_ty `thenDs` \ ignored_result_id -> + returnDs (mkApps (Var then_id) [Type a_ty, Type b_ty, expr2, + Lam ignored_result_id rest]) + + | otherwise -- List comprehension + = do_expr expr locn `thenDs` \ expr2 -> + go stmts `thenDs` \ rest -> + let + msg = "Pattern match failure in do expression, " ++ showSDoc (ppr locn) + in + mkStringLit msg `thenDs` \ core_msg -> + returnDs (mkIfThenElse expr2 rest + (App (App (Var fail_id) (Type b_ty)) core_msg)) go (LetStmt binds : stmts ) = go stmts `thenDs` \ rest -> @@ -554,7 +556,7 @@ dsDo do_or_lc stmts return_id then_id fail_id result_ty , mkSimpleMatch [WildPat a_ty] fail_expr (Just result_ty) locn ] in - matchWrapper DoBindMatch the_matches match_msg + matchWrapper DoExpr the_matches match_msg `thenDs` \ (binders, matching_code) -> returnDs (mkApps (Var then_id) [Type a_ty, Type b_ty, expr2, mkLams binders matching_code]) @@ -565,7 +567,7 @@ dsDo do_or_lc stmts return_id then_id fail_id result_ty do_expr expr locn = putSrcLocDs locn (dsExpr expr) match_msg = case do_or_lc of - DoStmt -> "`do' statement" + DoExpr -> "`do' statement" ListComp -> "comprehension" \end{code} diff --git a/ghc/compiler/deSugar/DsGRHSs.lhs b/ghc/compiler/deSugar/DsGRHSs.lhs index b14e264..918ec65 100644 --- a/ghc/compiler/deSugar/DsGRHSs.lhs +++ b/ghc/compiler/deSugar/DsGRHSs.lhs @@ -11,7 +11,7 @@ module DsGRHSs ( dsGuarded, dsGRHSs ) where import {-# SOURCE #-} DsExpr ( dsExpr, dsLet ) import {-# SOURCE #-} Match ( matchSinglePat ) -import HsSyn ( Stmt(..), HsExpr(..), GRHSs(..), GRHS(..) ) +import HsSyn ( Stmt(..), HsExpr(..), GRHSs(..), GRHS(..), HsMatchContext(..) ) import TcHsSyn ( TypecheckedGRHSs, TypecheckedPat, TypecheckedStmt ) import CoreSyn ( CoreExpr ) import Type ( Type ) @@ -37,7 +37,7 @@ necessary. The type argument gives the type of the @ei@. dsGuarded :: TypecheckedGRHSs -> DsM CoreExpr dsGuarded grhss - = dsGRHSs PatBindMatch [] grhss `thenDs` \ (err_ty, match_result) -> + = dsGRHSs PatBindRhs [] grhss `thenDs` \ (err_ty, match_result) -> mkErrorAppDs nON_EXHAUSTIVE_GUARDS_ERROR_ID err_ty "" `thenDs` \ error_expr -> extractMatchResult match_result error_expr \end{code} @@ -45,7 +45,7 @@ dsGuarded grhss In contrast, @dsGRHSs@ produces a @MatchResult@. \begin{code} -dsGRHSs :: DsMatchKind -> [TypecheckedPat] -- These are to build a MatchContext from +dsGRHSs :: HsMatchContext -> [TypecheckedPat] -- These are to build a MatchContext from -> TypecheckedGRHSs -- Guarded RHSs -> DsM (Type, MatchResult) @@ -74,17 +74,21 @@ matchGuard :: [TypecheckedStmt] -- Guard -> DsMatchContext -- Context -> DsM MatchResult -matchGuard (ExprStmt expr locn : should_be_null) ctx +-- See comments with HsExpr.HsStmt re what an ExprStmt means +-- Here we must be in a guard context (not do-expression, nor list-comp) + +matchGuard [ExprStmt expr locn] ctx = putSrcLocDs locn (dsExpr expr) `thenDs` \ core_expr -> returnDs (cantFailMatchResult core_expr) + -- Other ExprStmts must be guards -- Turn an "otherwise" guard is a no-op -matchGuard (GuardStmt (HsVar v) _ : stmts) ctx +matchGuard (ExprStmt (HsVar v) _ : stmts) ctx | v `hasKey` otherwiseIdKey || v `hasKey` trueDataConKey = matchGuard stmts ctx -matchGuard (GuardStmt expr locn : stmts) ctx +matchGuard (ExprStmt expr locn : stmts) ctx = matchGuard stmts ctx `thenDs` \ match_result -> putSrcLocDs locn (dsExpr expr) `thenDs` \ pred_expr -> returnDs (mkGuardedMatchResult pred_expr match_result) diff --git a/ghc/compiler/deSugar/DsListComp.lhs b/ghc/compiler/deSugar/DsListComp.lhs index 68de254..431fb93 100644 --- a/ghc/compiler/deSugar/DsListComp.lhs +++ b/ghc/compiler/deSugar/DsListComp.lhs @@ -11,7 +11,7 @@ module DsListComp ( dsListComp ) where import {-# SOURCE #-} DsExpr ( dsExpr, dsLet ) import BasicTypes ( Boxity(..) ) -import HsSyn ( OutPat(..), HsExpr(..), Stmt(..) ) +import HsSyn ( OutPat(..), HsExpr(..), Stmt(..), HsMatchContext(..) ) import TcHsSyn ( TypecheckedStmt ) import DsHsSyn ( outPatType ) import CoreSyn @@ -28,6 +28,7 @@ import TysPrim ( alphaTyVar ) import TysWiredIn ( nilDataCon, consDataCon, unitDataConId, tupleCon, mkListTy, mkTupleTy ) import Match ( matchSimply ) import PrelNames ( foldrName, buildName ) +import SrcLoc ( noSrcLoc ) import List ( zip4 ) \end{code} @@ -144,7 +145,7 @@ deListComp (ParStmtOut bndrstmtss : quals) list pat = TuplePat pats Boxed qualss = map mkQuals bndrstmtss - mkQuals (bndrs, stmts) = (bndrs, stmts ++ [ReturnStmt (myTupleExpr bndrs)]) + mkQuals (bndrs, stmts) = (bndrs, stmts ++ [ExprStmt (myTupleExpr bndrs) noSrcLoc]) qualTys = map mkBndrsTy bndrss mkBndrsTy bndrs = myTupleTy Boxed (length bndrs) (map idType bndrs) @@ -176,11 +177,13 @@ deListComp (ParStmtOut bndrstmtss : quals) list myTupleExpr [id] = HsVar id myTupleExpr ids = ExplicitTuple [ HsVar i | i <- ids ] Boxed -deListComp [ReturnStmt expr] list -- Figure 7.4, SLPJ, p 135, rule C above + -- Last: the one to return +deListComp [ExprStmt expr locn] list -- Figure 7.4, SLPJ, p 135, rule C above = dsExpr expr `thenDs` \ core_expr -> returnDs (mkConsExpr (exprType core_expr) core_expr list) -deListComp (GuardStmt guard locn : quals) list -- rule B above + -- Non-last: must be a guard +deListComp (ExprStmt guard locn : quals) list -- rule B above = dsExpr guard `thenDs` \ core_guard -> deListComp quals list `thenDs` \ core_rest -> returnDs (mkIfThenElse core_guard core_rest list) @@ -212,7 +215,7 @@ deBindComp pat core_list1 quals core_list2 letrec_body = App (Var h) core_list1 in deListComp quals core_fail `thenDs` \ rest_expr -> - matchSimply (Var u2) ListCompMatch pat + matchSimply (Var u2) ListComp pat rest_expr core_fail `thenDs` \ core_match -> let rhs = Lam u1 $ @@ -247,11 +250,13 @@ dfListComp :: Id -> Id -- 'c' and 'n' -> [TypecheckedStmt] -- the rest of the qual's -> DsM CoreExpr -dfListComp c_id n_id [ReturnStmt expr] + -- Last: the one to return +dfListComp c_id n_id [ExprStmt expr locn] = dsExpr expr `thenDs` \ core_expr -> returnDs (mkApps (Var c_id) [core_expr, Var n_id]) -dfListComp c_id n_id (GuardStmt guard locn : quals) + -- Non-last: must be a guard +dfListComp c_id n_id (ExprStmt guard locn : quals) = dsExpr guard `thenDs` \ core_guard -> dfListComp c_id n_id quals `thenDs` \ core_rest -> returnDs (mkIfThenElse core_guard core_rest (Var n_id)) @@ -277,7 +282,7 @@ dfListComp c_id n_id (BindStmt pat list1 locn : quals) dfListComp c_id b quals `thenDs` \ core_rest -> -- build the pattern match - matchSimply (Var x) ListCompMatch pat core_rest (Var b) `thenDs` \ core_expr -> + matchSimply (Var x) ListComp pat core_rest (Var b) `thenDs` \ core_expr -> -- now build the outermost foldr, and return dsLookupGlobalValue foldrName `thenDs` \ foldr_id -> diff --git a/ghc/compiler/deSugar/DsMonad.lhs b/ghc/compiler/deSugar/DsMonad.lhs index 83b21bd..a83a1f4 100644 --- a/ghc/compiler/deSugar/DsMonad.lhs +++ b/ghc/compiler/deSugar/DsMonad.lhs @@ -20,11 +20,12 @@ module DsMonad ( dsWarn, DsWarnings, - DsMatchContext(..), DsMatchKind(..) + DsMatchContext(..) ) where #include "HsVersions.h" +import HsSyn ( HsMatchContext ) import Bag ( emptyBag, snocBag, Bag ) import ErrUtils ( WarnMsg ) import Id ( mkSysLocal, setIdUnique, Id ) @@ -218,18 +219,7 @@ dsLookupGlobalValue name dflags us genv loc mod warns \begin{code} data DsMatchContext - = DsMatchContext DsMatchKind [TypecheckedPat] SrcLoc + = DsMatchContext HsMatchContext [TypecheckedPat] SrcLoc | NoMatchContext deriving () - -data DsMatchKind - = FunMatch Id - | CaseMatch - | LambdaMatch - | PatBindMatch - | DoBindMatch - | ListCompMatch - | LetMatch - | RecUpdMatch - deriving () \end{code} diff --git a/ghc/compiler/deSugar/DsUtils.lhs b/ghc/compiler/deSugar/DsUtils.lhs index 7344cd7..15e08a8 100644 --- a/ghc/compiler/deSugar/DsUtils.lhs +++ b/ghc/compiler/deSugar/DsUtils.lhs @@ -483,7 +483,7 @@ mkSelectorBinds pat val_expr | otherwise = mkErrorAppDs iRREFUT_PAT_ERROR_ID tuple_ty (showSDoc (ppr pat)) `thenDs` \ error_expr -> - matchSimply val_expr LetMatch pat local_tuple error_expr + matchSimply val_expr PatBindRhs pat local_tuple error_expr `thenDs` \ tuple_expr -> newSysLocalDs tuple_ty `thenDs` \ tuple_var -> @@ -501,7 +501,7 @@ mkSelectorBinds pat val_expr -- (mk_bind sv bv) generates -- bv = case sv of { pat -> bv; other -> error-msg } -- Remember, pat binds bv - = matchSimply (Var scrut_var) LetMatch pat + = matchSimply (Var scrut_var) PatBindRhs pat (Var bndr_var) error_expr `thenDs` \ rhs_expr -> returnDs (bndr_var, rhs_expr) where diff --git a/ghc/compiler/deSugar/Match.hi-boot b/ghc/compiler/deSugar/Match.hi-boot index 4864b89..2db27a8 100644 --- a/ghc/compiler/deSugar/Match.hi-boot +++ b/ghc/compiler/deSugar/Match.hi-boot @@ -4,6 +4,6 @@ Match match matchExport matchSimply matchSinglePat; _declarations_ 1 match _:_ [Var.Id] -> [DsUtils.EquationInfo] -> DsMonad.DsM DsUtils.MatchResult ;; 1 matchExport _:_ [Var.Id] -> [DsUtils.EquationInfo] -> DsMonad.DsM DsUtils.MatchResult ;; -1 matchSimply _:_ CoreSyn.CoreExpr -> DsMonad.DsMatchKind -> TcHsSyn.TypecheckedPat -> CoreSyn.CoreExpr -> CoreSyn.CoreExpr -> DsMonad.DsM CoreSyn.CoreExpr ;; +1 matchSimply _:_ CoreSyn.CoreExpr -> HsExpr.HsMatchContext -> TcHsSyn.TypecheckedPat -> CoreSyn.CoreExpr -> CoreSyn.CoreExpr -> DsMonad.DsM CoreSyn.CoreExpr ;; 1 matchSinglePat _:_ CoreSyn.CoreExpr -> DsMonad.DsMatchContext -> TcHsSyn.TypecheckedPat -> DsUtils.MatchResult -> DsMonad.DsM DsUtils.MatchResult ;; diff --git a/ghc/compiler/deSugar/Match.hi-boot-5 b/ghc/compiler/deSugar/Match.hi-boot-5 index b55d53a..a0727f4 100644 --- a/ghc/compiler/deSugar/Match.hi-boot-5 +++ b/ghc/compiler/deSugar/Match.hi-boot-5 @@ -2,5 +2,5 @@ __interface Match 1 0 where __export Match match matchExport matchSimply matchSinglePat; 1 match :: [Var.Id] -> [DsUtils.EquationInfo] -> DsMonad.DsM DsUtils.MatchResult ; 1 matchExport :: [Var.Id] -> [DsUtils.EquationInfo] -> DsMonad.DsM DsUtils.MatchResult ; -1 matchSimply :: CoreSyn.CoreExpr -> DsMonad.DsMatchKind -> TcHsSyn.TypecheckedPat -> CoreSyn.CoreExpr -> CoreSyn.CoreExpr -> DsMonad.DsM CoreSyn.CoreExpr ; +1 matchSimply :: CoreSyn.CoreExpr -> HsExpr.HsMatchContext -> TcHsSyn.TypecheckedPat -> CoreSyn.CoreExpr -> CoreSyn.CoreExpr -> DsMonad.DsM CoreSyn.CoreExpr ; 1 matchSinglePat :: CoreSyn.CoreExpr -> DsMonad.DsMatchContext -> TcHsSyn.TypecheckedPat -> DsUtils.MatchResult -> DsMonad.DsM DsUtils.MatchResult ; diff --git a/ghc/compiler/deSugar/Match.lhs b/ghc/compiler/deSugar/Match.lhs index e50d8a5..a537ee8 100644 --- a/ghc/compiler/deSugar/Match.lhs +++ b/ghc/compiler/deSugar/Match.lhs @@ -111,73 +111,19 @@ pp_context NoMatchContext msg rest_of_msg_fun = dontAddErrLoc (ptext SLIT("Some match(es)") <+> hang msg 8 (rest_of_msg_fun id)) pp_context (DsMatchContext kind pats loc) msg rest_of_msg_fun - = case pp_match kind pats of - (ppr_match, pref) -> - addWarnLocHdrLine loc message (nest 8 (rest_of_msg_fun pref)) - where - message = ptext SLIT("Pattern match(es)") <+> msg <+> ppr_match <> char ':' - where - pp_match (FunMatch fun) pats - = let ppr_fun = ppr fun in - ( hsep [ptext SLIT("in the definition of function"), quotes ppr_fun] - , (\ x -> ppr_fun <+> x) - ) - - pp_match CaseMatch pats - = (hang (ptext SLIT("in a group of case alternatives beginning")) - 4 (ppr_pats pats) - , id - ) - - pp_match RecUpdMatch pats - = (hang (ptext SLIT("in a record-update construct")) - 4 (ppr_pats pats) - , id - ) - - pp_match PatBindMatch pats - = ( hang (ptext SLIT("in a pattern binding")) - 4 (ppr_pats pats) - , id - ) - - pp_match LambdaMatch pats - = ( hang (ptext SLIT("in a lambda abstraction")) - 4 (ppr_pats pats) - , id - ) - - pp_match DoBindMatch pats - = ( hang (ptext SLIT("in a `do' pattern binding")) - 4 (ppr_pats pats) - , id - ) - - pp_match ListCompMatch pats - = ( hang (ptext SLIT("in a `list comprension' pattern binding")) - 4 (ppr_pats pats) - , id - ) - - pp_match LetMatch pats - = ( hang (ptext SLIT("in a `let' pattern binding")) - 4 (ppr_pats pats) - , id - ) + = addWarnLocHdrLine loc message (nest 8 (rest_of_msg_fun pref)) + where + (ppr_match, pref) + = case kind of + FunRhs fun -> (pprMatchContext kind, \ pp -> ppr fun <+> pp) + other -> (pprMatchContext kind <+> ppr_pats pats, \ pp -> pp) + + message = ptext SLIT("Pattern match(es)") <+> msg <+> ppr_match <> char ':' ppr_pats pats = sep (map ppr pats) -separator (FunMatch _) = SLIT("=") -separator (CaseMatch) = SLIT("->") -separator (LambdaMatch) = SLIT("->") -separator (PatBindMatch) = panic "When is this used?" -separator (RecUpdMatch) = panic "When is this used?" -separator (DoBindMatch) = SLIT("<-") -separator (ListCompMatch) = SLIT("<-") -separator (LetMatch) = SLIT("=") - ppr_shadow_pats kind pats - = sep [ppr_pats pats, ptext (separator kind), ptext SLIT("...")] + = sep [ppr_pats pats, ptext (matchSeparator kind), ptext SLIT("...")] ppr_incomplete_pats kind (pats,[]) = ppr_pats pats ppr_incomplete_pats kind (pats,constraints) = @@ -676,9 +622,9 @@ Call @match@ with all of this information! \end{enumerate} \begin{code} -matchWrapper :: DsMatchKind -- For shadowing warning messages - -> [TypecheckedMatch] -- Matches being desugared - -> String -- Error message if the match fails +matchWrapper :: HsMatchContext -- For shadowing warning messages + -> [TypecheckedMatch] -- Matches being desugared + -> String -- Error message if the match fails -> DsM ([Id], CoreExpr) -- Results \end{code} @@ -719,9 +665,9 @@ matchWrapper kind matches error_string returnDs (new_vars, result_expr) where match_fun dflags = case kind of - LambdaMatch | dopt Opt_WarnSimplePatterns dflags -> matchExport - | otherwise -> match - _ -> matchExport + LambdaExpr | dopt Opt_WarnSimplePatterns dflags -> matchExport + | otherwise -> match + _ -> matchExport \end{code} %************************************************************************ @@ -735,11 +681,11 @@ situation where we want to match a single expression against a single pattern. It returns an expression. \begin{code} -matchSimply :: CoreExpr -- Scrutinee - -> DsMatchKind -- Match kind - -> TypecheckedPat -- Pattern it should match - -> CoreExpr -- Return this if it matches - -> CoreExpr -- Return this if it doesn't +matchSimply :: CoreExpr -- Scrutinee + -> HsMatchContext -- Match kind + -> TypecheckedPat -- Pattern it should match + -> CoreExpr -- Return this if it matches + -> CoreExpr -- Return this if it doesn't -> DsM CoreExpr matchSimply scrut kind pat result_expr fail_expr @@ -780,10 +726,9 @@ matchSinglePat scrut ctx pat match_result This is actually local to @matchWrapper@. \begin{code} -flattenMatches - :: DsMatchKind - -> [TypecheckedMatch] - -> DsM (Type, [EquationInfo]) +flattenMatches :: HsMatchContext + -> [TypecheckedMatch] + -> DsM (Type, [EquationInfo]) flattenMatches kind matches = mapAndUnzipDs flatten_match (matches `zip` [1..]) `thenDs` \ (result_tys, eqn_infos) -> diff --git a/ghc/compiler/ghci/InteractiveUI.hs b/ghc/compiler/ghci/InteractiveUI.hs index 063b3be..8f0795f 100644 --- a/ghc/compiler/ghci/InteractiveUI.hs +++ b/ghc/compiler/ghci/InteractiveUI.hs @@ -1,5 +1,5 @@ ----------------------------------------------------------------------------- --- $Id: InteractiveUI.hs,v 1.51 2001/02/14 11:36:07 sewardj Exp $ +-- $Id: InteractiveUI.hs,v 1.52 2001/02/26 15:06:58 simonmar Exp $ -- -- GHC Interactive User Interface -- @@ -18,13 +18,10 @@ import ByteCodeLink import DriverFlags import DriverState import DriverUtil -import Type import Linker -import Finder -import Module -import Outputable import Util -import PprType {- instance Outputable Type; do not delete -} +import Name ( Name ) +import Outputable import Panic ( GhcException(..) ) import Config @@ -45,8 +42,6 @@ import Char import Monad ( when ) import PrelGHC ( unsafeCoerce# ) -import PrelPack ( packString ) -import PrelByteArr import Foreign ( nullPtr ) import CString ( peekCString ) @@ -65,7 +60,7 @@ builtin_commands :: [(String, String -> GHCi Bool)] builtin_commands = [ ("add", keepGoing addModule), ("cd", keepGoing changeDirectory), - ("def", keepGoing defineMacro), +-- ("def", keepGoing defineMacro), ("help", keepGoing help), ("?", keepGoing help), ("load", keepGoing loadModule), @@ -86,7 +81,7 @@ shortHelpText = "use :? for help.\n" helpText = "\ \ Commands available from the prompt:\n\ \\ -\ evaluate \n\ +\ evaluate/run \n\ \ :add add a module to the current set\n\ \ :cd change directory to \n\ \ :help, :? display this list of commands\n\ @@ -127,33 +122,25 @@ interactiveUI cmstate mod cmdline_libs = do Readline.initialize #endif - prel <- moduleNameToModule defaultCurrentModuleName - writeIORef defaultCurrentModule prel - dflags <- getDynFlags - (cmstate, maybe_stuff) <- cmGetExpr cmstate dflags False prel - "PrelHandle.hFlush PrelHandle.stdout" +{- + (cmstate, _) <- cmRunStmt cmstate dflags False prel + "PrelHandle.hFlush PrelHandle.stdout" case maybe_stuff of Nothing -> return () Just (hv,_,_) -> writeIORef flush_stdout hv - (cmstate, maybe_stuff) <- cmGetExpr cmstate dflags False prel + (cmstate, _) <- cmGetExpr cmstate dflags False prel "PrelHandle.hFlush PrelHandle.stdout" case maybe_stuff of Nothing -> return () Just (hv,_,_) -> writeIORef flush_stderr hv +-} - let this_mod = case mods of - [] -> prel - m:ms -> m - - (unGHCi runGHCi) GHCiState{ modules = mods, - current_module = this_mod, - target = mod, - cmstate = cmstate, - options = [ShowTiming], - last_expr = Nothing} + (unGHCi runGHCi) GHCiState{ target = mod, + cmstate = cmstate, + options = [ShowTiming] } return () @@ -189,7 +176,8 @@ runGHCi = do fileLoop :: Handle -> Bool -> GHCi () fileLoop hdl prompt = do st <- getGHCiState - when prompt (io (hPutStr hdl (moduleUserString (current_module st) ++ "> "))) + mod <- io (cmGetContext (cmstate st)) + when prompt (io (hPutStr hdl (mod ++ "> "))) l <- io (IO.try (hGetLine hdl)) case l of Left e | isEOFError e -> return () @@ -213,7 +201,8 @@ stringLoop (s:ss) = do readlineLoop :: GHCi () readlineLoop = do st <- getGHCiState - l <- io (readline (moduleUserString (current_module st) ++ "> ")) + mod <- io (cmGetContext (cmstate st)) + l <- io (readline (mod ++ "> ")) case l of Nothing -> return () Just l -> @@ -251,49 +240,49 @@ runCommand c = doCommand (':' : command) = specialCommand command doCommand ('-':'-':_) = return False -- comments, useful in scripts -doCommand expr - = do expr_expanded <- expandExpr expr - -- io (putStrLn ( "Before: " ++ expr ++ "\nAfter: " ++ expr_expanded)) - expr_ok <- timeIt (do stuff <- evalExpr expr_expanded - finishEvalExpr expr_expanded stuff) - when expr_ok (rememberExpr expr_expanded) +doCommand stmt + = do timeIt (do stuff <- runStmt stmt; finishEvalExpr stuff) return False -- Returns True if the expr was successfully parsed, renamed and -- typechecked. -evalExpr :: String -> GHCi Bool -evalExpr expr - | null (filter (not.isSpace) expr) - = return False +runStmt :: String -> GHCi (Maybe [Name]) +runStmt stmt + | null (filter (not.isSpace) stmt) + = return Nothing | otherwise = do st <- getGHCiState dflags <- io (getDynFlags) - (new_cmstate, maybe_stuff) <- - io (cmGetExpr (cmstate st) dflags True (current_module st) expr) + (new_cmstate, names) <- io (cmRunStmt (cmstate st) dflags stmt) setGHCiState st{cmstate = new_cmstate} - case maybe_stuff of - Nothing -> return False - Just (hv, unqual, ty) -> - do io (cmRunExpr hv) - return True + return (Just names) -- possibly print the type and revert CAFs after evaluating an expression -finishEvalExpr _ False = return False -finishEvalExpr expr True +finishEvalExpr Nothing = return False +finishEvalExpr (Just names) = do b <- isOptionSet ShowType - -- re-typecheck, don't wrap with print this time - when b (io (putStr ":: ") >> typeOfExpr expr) + st <- getGHCiState + when b (mapM_ (showTypeOfName (cmstate st)) names) + b <- isOptionSet RevertCAFs io (when b revertCAFs) flushEverything return True +showTypeOfName :: CmState -> Name -> GHCi () +showTypeOfName cmstate n + = do maybe_str <- io (cmTypeOfName cmstate n) + case maybe_str of + Nothing -> return () + Just str -> io (putStrLn (showSDoc (ppr n) ++ " :: " ++ str)) + flushEverything :: GHCi () flushEverything - = io $ do flush_so <- readIORef flush_stdout + = io $ {-do flush_so <- readIORef flush_stdout cmRunExpr flush_so flush_se <- readIORef flush_stdout cmRunExpr flush_se + -} (return ()) specialCommand :: String -> GHCi Bool specialCommand ('!':str) = shellEscape (dropWhile isSpace str) @@ -327,28 +316,13 @@ setContext m | not (isUpper (head m)) || not (all isAlphaNum (tail m)) = throwDyn (OtherError ("strange looking module name: `" ++ m ++ "'")) setContext str = do st <- getGHCiState - - let mn = mkModuleName str - m <- case [ m | m <- modules st, moduleName m == mn ] of - (m:_) -> return m - [] -> io (moduleNameToModule mn) - - if (isHomeModule m && m `notElem` modules st) - then throwDyn (OtherError (showSDoc (quotes (ppr (moduleName m)) - <+> text "is not currently loaded, use :load"))) - else setGHCiState st{current_module = m} - -moduleNameToModule :: ModuleName -> IO Module -moduleNameToModule mn - = do maybe_stuff <- findModule mn - case maybe_stuff of - Nothing -> throwDyn (OtherError ("can't find module `" - ++ moduleNameUserString mn ++ "'")) - Just (m,_) -> return m + new_cmstate <- io (cmSetContext (cmstate st) str) + setGHCiState st{cmstate=new_cmstate} changeDirectory :: String -> GHCi () changeDirectory d = io (setCurrentDirectory d) +{- defineMacro :: String -> GHCi () defineMacro s = do let (macro_name, definition) = break isSpace s @@ -369,13 +343,14 @@ defineMacro s = do st <- getGHCiState dflags <- io (getDynFlags) (new_cmstate, maybe_stuff) <- - io (cmGetExpr (cmstate st) dflags False (current_module st) new_expr) + io (cmGetExpr (cmstate st) dflags new_expr) setGHCiState st{cmstate = new_cmstate} case maybe_stuff of Nothing -> return () Just (hv, unqual, ty) -> io (writeIORef commands ((macro_name, keepGoing (runMacro hv)) : cmds)) +-} runMacro :: HValue{-String -> IO String-} -> String -> GHCi () runMacro fun s = do @@ -403,28 +378,11 @@ loadModule' path = do cmstate1 <- io (cmUnload (cmstate state)) io (revertCAFs) -- always revert CAFs on load. (cmstate2, ok, mods) <- io (cmLoadModule cmstate1 path) - - def_mod <- io (readIORef defaultCurrentModule) - - let new_state = state{ - cmstate = cmstate2, - modules = mods, - current_module = case mods of - [] -> def_mod - xs -> head xs, - target = Just path - } + let new_state = state{ cmstate = cmstate2, + target = Just path + } setGHCiState new_state - - let mod_commas - | null mods = text "none." - | otherwise = hsep ( - punctuate comma (map (text.moduleUserString) mods)) <> text "." - case ok of - False -> - io (putStrLn (showSDoc (text "Failed, modules loaded: " <> mod_commas))) - True -> - io (putStrLn (showSDoc (text "Ok, modules loaded: " <> mod_commas))) + modulesLoadedMsg ok mods reloadModule :: String -> GHCi () reloadModule "" = do @@ -434,27 +392,37 @@ reloadModule "" = do Just path -> do io (revertCAFs) -- always revert CAFs on reload. (new_cmstate, ok, mods) <- io (cmLoadModule (cmstate state) path) - def_mod <- io (readIORef defaultCurrentModule) - setGHCiState - state{cmstate=new_cmstate, - modules = mods, - current_module = case mods of - [] -> def_mod - xs -> head xs - } + setGHCiState state{ cmstate=new_cmstate } + modulesLoadedMsg ok mods reloadModule _ = noArgs ":reload" + +modulesLoadedMsg ok mods = do + let mod_commas + | null mods = text "none." + | otherwise = hsep ( + punctuate comma (map text mods)) <> text "." + case ok of + False -> + io (putStrLn (showSDoc (text "Failed, modules loaded: " <> mod_commas))) + True -> + io (putStrLn (showSDoc (text "Ok, modules loaded: " <> mod_commas))) + + typeOfExpr :: String -> GHCi () typeOfExpr str = do st <- getGHCiState dflags <- io (getDynFlags) - (new_cmstate, maybe_ty) <- io (cmGetExpr (cmstate st) dflags False - (current_module st) str) + (new_cmstate, names) + <- io (cmRunStmt (cmstate st) dflags ("let it=" ++ str)) setGHCiState st{cmstate = new_cmstate} - case maybe_ty of - Nothing -> return () - Just (_, unqual, ty) -> io (printForUser stdout unqual (ppr ty)) + case names of + [name] -> do maybe_tystr <- io (cmTypeOfName new_cmstate name) + case maybe_tystr of + Nothing -> return () + Just tystr -> io (putStrLn (":: " ++ tystr)) + _other -> pprPanic "typeOfExpr" (ppr names) quit :: String -> GHCi Bool quit _ = return True @@ -557,54 +525,13 @@ optToStr ShowType = "t" optToStr RevertCAFs = "r" ----------------------------------------------------------------------------- --- Code to do last-expression-entered stuff. (a.k.a the $$ facility) - --- Take a string and replace $$s in it with the last expr, if any. -expandExpr :: String -> GHCi String -expandExpr str - = do mle <- getLastExpr - return (outside mle str) - where - outside mle ('$':'$':cs) - = case mle of - Just le -> " (" ++ le ++ ") " ++ outside mle cs - Nothing -> outside mle cs - - outside mle [] = [] - outside mle ('"':str) = '"' : inside2 mle str -- " - outside mle ('\'':str) = '\'' : inside1 mle str -- ' - outside mle (c:cs) = c : outside mle cs - - inside2 mle ('"':cs) = '"' : outside mle cs -- " - inside2 mle (c:cs) = c : inside2 mle cs - inside2 mle [] = [] - - inside1 mle ('\'':cs) = '\'': outside mle cs - inside1 mle (c:cs) = c : inside1 mle cs - inside1 mle [] = [] - - -rememberExpr :: String -> GHCi () -rememberExpr str - = do let cleaned = (clean . reverse . clean . reverse) str - let forget_me_not | null cleaned = Nothing - | otherwise = Just cleaned - setLastExpr forget_me_not - where - clean = dropWhile isSpace - - ------------------------------------------------------------------------------ -- GHCi monad data GHCiState = GHCiState { - modules :: [Module], - current_module :: Module, target :: Maybe FilePath, cmstate :: CmState, - options :: [GHCiOption], - last_expr :: Maybe String + options :: [GHCiOption] } data GHCiOption @@ -613,9 +540,6 @@ data GHCiOption | RevertCAFs -- revert CAFs after every evaluation deriving Eq -defaultCurrentModuleName = mkModuleName "Prelude" -GLOBAL_VAR(defaultCurrentModule, error "no defaultCurrentModule", Module) - GLOBAL_VAR(flush_stdout, error "no flush_stdout", HValue) GLOBAL_VAR(flush_stderr, error "no flush_stdout", HValue) @@ -643,14 +567,6 @@ unsetOption opt = do st <- getGHCiState setGHCiState (st{ options = filter (/= opt) (options st) }) -getLastExpr :: GHCi (Maybe String) -getLastExpr - = do st <- getGHCiState ; return (last_expr st) - -setLastExpr :: Maybe String -> GHCi () -setLastExpr last_expr - = do st <- getGHCiState ; setGHCiState (st{last_expr = last_expr}) - io m = GHCi $ \s -> m >>= \a -> return (s,a) ----------------------------------------------------------------------------- diff --git a/ghc/compiler/hsSyn/HsBinds.lhs b/ghc/compiler/hsSyn/HsBinds.lhs index 09c4e2c..4483543 100644 --- a/ghc/compiler/hsSyn/HsBinds.lhs +++ b/ghc/compiler/hsSyn/HsBinds.lhs @@ -10,8 +10,7 @@ module HsBinds where #include "HsVersions.h" -import {-# SOURCE #-} HsExpr ( pprExpr, HsExpr ) -import {-# SOURCE #-} HsMatches ( pprMatches, Match, pprGRHSs, GRHSs ) +import {-# SOURCE #-} HsExpr ( pprExpr, HsExpr, pprMatches, Match, pprGRHSs, GRHSs ) -- friends: import HsTypes ( HsType ) diff --git a/ghc/compiler/hsSyn/HsExpr.hi-boot b/ghc/compiler/hsSyn/HsExpr.hi-boot index 984de0f..a631f59 100644 --- a/ghc/compiler/hsSyn/HsExpr.hi-boot +++ b/ghc/compiler/hsSyn/HsExpr.hi-boot @@ -1,6 +1,12 @@ _interface_ HsExpr 1 _exports_ -HsExpr HsExpr pprExpr; +HsExpr HsExpr pprExpr Match GRHSs pprMatch pprMatches pprGRHSs ; _declarations_ 1 data HsExpr i p; 1 pprExpr _:_ _forall_ [i p] {Outputable.Outputable i, Outputable.Outputable p} => HsExpr.HsExpr i p -> Outputable.SDoc ;; + +1 data Match a b ; +1 data GRHSs a b ; +1 pprGRHSs _:_ _forall_ [i p] {Outputable.Outputable i, Outputable.Outputable p} => PrelBase.Bool -> HsExpr.GRHSs i p -> Outputable.SDoc ;; +1 pprMatch _:_ _forall_ [i p] {Outputable.Outputable i, Outputable.Outputable p} => (PrelBase.Bool, Outputable.SDoc) -> HsExpr.Match i p -> Outputable.SDoc ;; +1 pprMatches _:_ _forall_ [i p] {Outputable.Outputable i, Outputable.Outputable p} => (PrelBase.Bool, Outputable.SDoc) -> [HsExpr.Match i p] -> Outputable.SDoc ;; diff --git a/ghc/compiler/hsSyn/HsExpr.hi-boot-5 b/ghc/compiler/hsSyn/HsExpr.hi-boot-5 index bf7cb53..5f17708 100644 --- a/ghc/compiler/hsSyn/HsExpr.hi-boot-5 +++ b/ghc/compiler/hsSyn/HsExpr.hi-boot-5 @@ -1,4 +1,13 @@ __interface HsExpr 1 0 where -__export HsExpr HsExpr pprExpr; +__export HsExpr HsExpr pprExpr Match GRHSs pprMatch pprMatches pprGRHSs ; + 1 data HsExpr i p ; 1 pprExpr :: __forall [i p] {Outputable.Outputable i, Outputable.Outputable p} => HsExpr.HsExpr i p -> Outputable.SDoc ; + + +1 data Match a b ; +1 data GRHSs a b ; +1 pprGRHSs :: __forall [i p] {Outputable.Outputable i, Outputable.Outputable p} => PrelBase.Bool -> HsExpr.GRHSs i p -> Outputable.SDoc ; +1 pprMatch :: __forall [i p] {Outputable.Outputable i, Outputable.Outputable p} => (PrelBase.Bool, Outputable.SDoc) -> HsExpr.Match i p -> Outputable.SDoc ; +1 pprMatches :: __forall [i p] {Outputable.Outputable i, Outputable.Outputable p} => (PrelBase.Bool, Outputable.SDoc) -> [HsExpr.Match i p] -> Outputable.SDoc ; + diff --git a/ghc/compiler/hsSyn/HsExpr.lhs b/ghc/compiler/hsSyn/HsExpr.lhs index 5c5f095..cf3a5f3 100644 --- a/ghc/compiler/hsSyn/HsExpr.lhs +++ b/ghc/compiler/hsSyn/HsExpr.lhs @@ -9,15 +9,13 @@ module HsExpr where #include "HsVersions.h" -- friends: -import {-# SOURCE #-} HsMatches ( pprMatches, pprMatch, Match ) - -import HsBinds ( HsBinds(..) ) +import HsBinds ( HsBinds(..), nullBinds ) import HsLit ( HsLit, HsOverLit ) import BasicTypes ( Fixity(..) ) import HsTypes ( HsType ) -- others: -import Name ( Name, isLexSym ) +import Name ( Name, isLexSym ) import Outputable import PprType ( pprParendType ) import Type ( Type ) @@ -83,15 +81,15 @@ data HsExpr id pat | HsWith (HsExpr id pat) -- implicit parameter binding [(id, HsExpr id pat)] - | HsDo StmtCtxt + | HsDo HsMatchContext [Stmt id pat] -- "do":one or more stmts SrcLoc - | HsDoOut StmtCtxt + | HsDoOut HsMatchContext [Stmt id pat] -- "do":one or more stmts id -- id for return id -- id for >>= - id -- id for zero + id -- id for fail Type -- Type of the whole expression SrcLoc @@ -421,50 +419,167 @@ pp_rbinds thing rbinds hsep [ppr v, char '=', ppr e] \end{code} + + %************************************************************************ %* * -\subsection{Do stmts and list comprehensions} +\subsection{@Match@, @GRHSs@, and @GRHS@ datatypes} %* * %************************************************************************ +@Match@es are sets of pattern bindings and right hand sides for +functions, patterns or case branches. For example, if a function @g@ +is defined as: +\begin{verbatim} +g (x,y) = y +g ((x:ys),y) = y+1, +\end{verbatim} +then \tr{g} has two @Match@es: @(x,y) = y@ and @((x:ys),y) = y+1@. + +It is always the case that each element of an @[Match]@ list has the +same number of @pats@s inside it. This corresponds to saying that +a function defined by pattern matching must have the same number of +patterns in each equation. + \begin{code} -data StmtCtxt -- Context of a Stmt - = DoStmt -- Do Statment - | ListComp -- List comprehension - | CaseAlt -- Guard on a case alternative - | PatBindRhs -- Guard on a pattern binding - | FunRhs Name -- Guard on a function defn for f - | LambdaBody -- Body of a lambda abstraction - -pprDo DoStmt stmts - = hang (ptext SLIT("do")) 2 (vcat (map ppr stmts)) -pprDo ListComp stmts - = brackets $ - hang (pprExpr expr <+> char '|') - 4 (interpp'SP quals) - where - ReturnStmt expr = last stmts -- Last stmt should be a ReturnStmt for list comps - quals = init stmts +data Match id pat + = Match + [id] -- Tyvars wrt which this match is universally quantified + -- empty after typechecking + [pat] -- The patterns + (Maybe (HsType id)) -- A type signature for the result of the match + -- Nothing after typechecking + + (GRHSs id pat) + +-- GRHSs are used both for pattern bindings and for Matches +data GRHSs id pat + = GRHSs [GRHS id pat] -- Guarded RHSs + (HsBinds id pat) -- The where clause + (Maybe Type) -- Just rhs_ty after type checking + +data GRHS id pat + = GRHS [Stmt id pat] -- The RHS is the final ExprStmt + -- I considered using a RetunStmt, but + -- it printed 'wrong' in error messages + SrcLoc + +mkSimpleMatch :: [pat] -> HsExpr id pat -> Maybe Type -> SrcLoc -> Match id pat +mkSimpleMatch pats rhs maybe_rhs_ty locn + = Match [] pats Nothing (GRHSs (unguardedRHS rhs locn) EmptyBinds maybe_rhs_ty) + +unguardedRHS :: HsExpr id pat -> SrcLoc -> [GRHS id pat] +unguardedRHS rhs loc = [GRHS [ExprStmt rhs loc] loc] \end{code} +@getMatchLoc@ takes a @Match@ and returns the +source-location gotten from the GRHS inside. +THis is something of a nuisance, but no more. + \begin{code} -data Stmt id pat - = ParStmt [[Stmt id pat]] -- List comp only: parallel set of quals - | ParStmtOut [([id], [Stmt id pat])] -- PLC after renaming - | BindStmt pat - (HsExpr id pat) - SrcLoc +getMatchLoc :: Match id pat -> SrcLoc +getMatchLoc (Match _ _ _ (GRHSs (GRHS _ loc : _) _ _)) = loc +\end{code} - | LetStmt (HsBinds id pat) +We know the list must have at least one @Match@ in it. - | GuardStmt (HsExpr id pat) -- List comps only - SrcLoc +\begin{code} +pprMatches :: (Outputable id, Outputable pat) + => (Bool, SDoc) -> [Match id pat] -> SDoc +pprMatches print_info matches = vcat (map (pprMatch print_info) matches) + + +pprMatch :: (Outputable id, Outputable pat) + => (Bool, SDoc) -> Match id pat -> SDoc +pprMatch print_info@(is_case, name) (Match _ pats maybe_ty grhss) + = maybe_name <+> sep [sep (map ppr pats), + ppr_maybe_ty, + nest 2 (pprGRHSs is_case grhss)] + where + maybe_name | is_case = empty + | otherwise = name + ppr_maybe_ty = case maybe_ty of + Just ty -> dcolon <+> ppr ty + Nothing -> empty + + +pprGRHSs :: (Outputable id, Outputable pat) + => Bool -> GRHSs id pat -> SDoc +pprGRHSs is_case (GRHSs grhss binds maybe_ty) + = vcat (map (pprGRHS is_case) grhss) + $$ + (if nullBinds binds then empty + else text "where" $$ nest 4 (pprDeeper (ppr binds))) + + +pprGRHS :: (Outputable id, Outputable pat) + => Bool -> GRHS id pat -> SDoc + +pprGRHS is_case (GRHS [ExprStmt expr _] locn) + = text (if is_case then "->" else "=") <+> pprDeeper (ppr expr) + +pprGRHS is_case (GRHS guarded locn) + = sep [char '|' <+> interpp'SP guards, + text (if is_case then "->" else "=") <+> pprDeeper (ppr expr) + ] + where + ExprStmt expr _ = last guarded -- Last stmt should be a ExprStmt for guards + guards = init guarded +\end{code} - | ExprStmt (HsExpr id pat) -- Do stmts; and guarded things at the end - SrcLoc - | ReturnStmt (HsExpr id pat) -- List comps only, at the end +%************************************************************************ +%* * +\subsection{Do stmts and list comprehensions} +%* * +%************************************************************************ + +\begin{code} +data Stmt id pat + = BindStmt pat (HsExpr id pat) SrcLoc + | LetStmt (HsBinds id pat) + | ExprStmt (HsExpr id pat) SrcLoc -- See notes that follow + | ParStmt [[Stmt id pat]] -- List comp only: parallel set of quals + | ParStmtOut [([id], [Stmt id pat])] -- PLC after renaming +\end{code} + +ExprStmts are a bit tricky, because what +they mean depends on the context. Consider + ExprStmt E +in the following contexts: + + A do expression of type (m res_ty) + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + * Non-last stmt in list: do { ....; E; ... } + E :: m any_ty + Translation: E >> ... + + * Last stmt in list: do { ....; E } + E :: m res_ty + Translation: E + + A list comprehensions of type [elt_ty] + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + * Non-last stmt in list: [ .. | ..., E, ... ] + E :: Bool + Translation: if E then fail else ... + + * Last stmt in list: [ E | ... ] + E :: elt_ty + Translation: return E + + A guard list, guarding a RHS of type rhs_ty + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + * Non-last stmt in list: f x | ..., E, ... = ...rhs... + E :: Bool + Translation: if E then fail else ... + + * Last stmt in list: f x | ...guards... = E + E :: rhs_ty + Translation: E + +\begin{code} consLetStmt :: HsBinds id pat -> [Stmt id pat] -> [Stmt id pat] consLetStmt EmptyBinds stmts = stmts consLetStmt binds stmts = LetStmt binds : stmts @@ -485,10 +600,15 @@ pprStmt (LetStmt binds) = hsep [ptext SLIT("let"), pprBinds binds] pprStmt (ExprStmt expr _) = ppr expr -pprStmt (GuardStmt expr _) - = ppr expr -pprStmt (ReturnStmt expr) - = hsep [ptext SLIT("return"), ppr expr] + +pprDo :: (Outputable id, Outputable pat) => HsMatchContext -> [Stmt id pat] -> SDoc +pprDo DoExpr stmts = hang (ptext SLIT("do")) 2 (vcat (map ppr stmts)) +pprDo ListComp stmts = brackets $ + hang (pprExpr expr <+> char '|') + 4 (interpp'SP quals) + where + ExprStmt expr _ = last stmts -- Last stmt should + quals = init stmts -- be an ExprStmt \end{code} %************************************************************************ @@ -520,3 +640,57 @@ instance (Outputable id, Outputable pat) => pp_dotdot = ptext SLIT(" .. ") \end{code} + + +%************************************************************************ +%* * +\subsection{HsMatchCtxt} +%* * +%************************************************************************ + +\begin{code} +data HsMatchContext -- Context of a Match or Stmt + = ListComp -- List comprehension + | DoExpr -- Do Statment + + | FunRhs Name -- Function binding for f + | CaseAlt -- Guard on a case alternative + | LambdaExpr -- Lambda + | PatBindRhs -- Pattern binding + | RecUpd -- Record update + deriving () + +-- It's convenient to have FunRhs as a Name +-- throughout so that HsMatchContext doesn't +-- need to be parameterised. +-- In the RdrName world we never use the FunRhs variant. +\end{code} + +\begin{code} +isDoExpr DoExpr = True +isDoExpr other = False + +isDoOrListComp ListComp = True +isDoOrListComp DoExpr = True +isDoOrListComp other = False +\end{code} + +\begin{code} +matchSeparator (FunRhs _) = SLIT("=") +matchSeparator CaseAlt = SLIT("->") +matchSeparator LambdaExpr = SLIT("->") +matchSeparator PatBindRhs = SLIT("=") +matchSeparator DoExpr = SLIT("<-") +matchSeparator ListComp = SLIT("<-") +matchSeparator RecUpd = panic "When is this used?" +\end{code} + +\begin{code} +pprMatchContext (FunRhs fun) = ptext SLIT("in the definition of function") <+> quotes (ppr fun) +pprMatchContext CaseAlt = ptext SLIT("in a group of case alternatives beginning") +pprMatchContext RecUpd = ptext SLIT("in a record-update construct") +pprMatchContext PatBindRhs = ptext SLIT("in a pattern binding") +pprMatchContext LambdaExpr = ptext SLIT("in a lambda abstraction") +pprMatchContext DoExpr = ptext SLIT("in a `do' expression pattern binding") +pprMatchContext ListComp = ptext SLIT("in a `list comprension' pattern binding") +\end{code} diff --git a/ghc/compiler/hsSyn/HsPat.lhs b/ghc/compiler/hsSyn/HsPat.lhs index e8c9296..ec92913 100644 --- a/ghc/compiler/hsSyn/HsPat.lhs +++ b/ghc/compiler/hsSyn/HsPat.lhs @@ -18,6 +18,7 @@ module HsPat ( #include "HsVersions.h" + -- friends: import HsLit ( HsLit, HsOverLit ) import HsExpr ( HsExpr ) diff --git a/ghc/compiler/hsSyn/HsSyn.lhs b/ghc/compiler/hsSyn/HsSyn.lhs index f2ad080..c2feb2a 100644 --- a/ghc/compiler/hsSyn/HsSyn.lhs +++ b/ghc/compiler/hsSyn/HsSyn.lhs @@ -19,12 +19,12 @@ module HsSyn ( module HsExpr, module HsImpExp, module HsLit, - module HsMatches, module HsPat, module HsTypes, Fixity, NewOrData, - collectTopBinders, collectMonoBinders, collectLocatedMonoBinders, + collectHsBinders, collectLocatedHsBinders, + collectMonoBinders, collectLocatedMonoBinders, hsModuleName, hsModuleImports ) where @@ -36,7 +36,6 @@ import HsBinds import HsExpr import HsImpExp import HsLit -import HsMatches import HsPat import HsTypes import BasicTypes ( Fixity, Version, NewOrData ) @@ -45,7 +44,6 @@ import BasicTypes ( Fixity, Version, NewOrData ) import Name ( NamedThing ) import Outputable import SrcLoc ( SrcLoc ) -import Bag import Module ( ModuleName ) \end{code} @@ -119,10 +117,19 @@ where it should return @[x, y, f, a, b]@ (remember, order important). \begin{code} -collectTopBinders :: HsBinds name (InPat name) -> Bag (name,SrcLoc) -collectTopBinders EmptyBinds = emptyBag -collectTopBinders (MonoBind b _ _) = listToBag (collectLocatedMonoBinders b) -collectTopBinders (ThenBinds b1 b2) = collectTopBinders b1 `unionBags` collectTopBinders b2 +collectLocatedHsBinders :: HsBinds name (InPat name) -> [(name,SrcLoc)] +collectLocatedHsBinders EmptyBinds = [] +collectLocatedHsBinders (MonoBind b _ _) + = collectLocatedMonoBinders b +collectLocatedHsBinders (ThenBinds b1 b2) + = collectLocatedHsBinders b1 ++ collectLocatedHsBinders b2 + +collectHsBinders :: HsBinds name (InPat name) -> [name] +collectHsBinders EmptyBinds = [] +collectHsBinders (MonoBind b _ _) + = collectMonoBinders b +collectHsBinders (ThenBinds b1 b2) + = collectHsBinders b1 ++ collectHsBinders b2 collectLocatedMonoBinders :: MonoBinds name (InPat name) -> [(name,SrcLoc)] collectLocatedMonoBinders binds diff --git a/ghc/compiler/main/HscMain.lhs b/ghc/compiler/main/HscMain.lhs index fd2f0a9..e42f092 100644 --- a/ghc/compiler/main/HscMain.lhs +++ b/ghc/compiler/main/HscMain.lhs @@ -6,18 +6,15 @@ \begin{code} module HscMain ( HscResult(..), hscMain, #ifdef GHCI - hscExpr, + hscStmt, #endif initPersistentCompilerState ) where #include "HsVersions.h" #ifdef GHCI -import RdrHsSyn ( RdrNameHsExpr ) -import Rename ( renameExpr ) -import Unique ( Uniquable(..) ) -import Type ( Type, splitTyConApp_maybe, tidyType ) -import PrelNames ( ioTyConKey ) +import RdrHsSyn ( RdrNameStmt ) +import Rename ( renameStmt ) import ByteCodeGen ( byteCodeGen ) #endif @@ -46,6 +43,8 @@ import SimplStg ( stg2stg ) import CodeGen ( codeGen ) import CodeOutput ( codeOutput ) +import Id ( Id, idName, idFlavour, modifyIdInfo ) +import IdInfo ( setFlavourInfo, makeConstantFlavour ) import Module ( ModuleName, moduleName, mkHomeModule ) import CmdLineOpts import ErrUtils ( dumpIfSet_dyn, showPass ) @@ -59,14 +58,16 @@ import CmStaticInfo ( GhciMode(..) ) import HscStats ( ppSourceStats ) import HscTypes ( ModDetails, ModIface(..), PersistentCompilerState(..), PersistentRenamerState(..), ModuleLocation(..), - HomeSymbolTable, + HomeSymbolTable, InteractiveContext(..), TyThing(..), NameSupply(..), PackageRuleBase, HomeIfaceTable, - typeEnvClasses, typeEnvTyCons, emptyIfaceTable ) + typeEnvClasses, typeEnvTyCons, emptyIfaceTable, + extendLocalRdrEnv + ) import FiniteMap ( FiniteMap, plusFM, emptyFM, addToFM ) import OccName ( OccName ) -import VarEnv ( emptyTidyEnv ) import Name ( Name, nameModule, nameOccName, getName, isGlobalName, - emptyNameEnv ) + emptyNameEnv, extendNameEnvList + ) import Module ( Module, lookupModuleEnvByName ) import Monad ( when ) @@ -146,7 +147,9 @@ hscNoRecomp ghci_mode dflags location (Just old_iface) hst hit pcs_ch } | otherwise = do { - hPutStrLn stderr "compilation IS NOT required"; + when (verbosity dflags >= 1) $ + hPutStrLn stderr ("Skipping " ++ + (unJust "hscNoRecomp" (ml_hs_file location))); -- CLOSURE (pcs_cl, closure_errs, cl_hs_decls) @@ -173,7 +176,8 @@ hscNoRecomp ghci_mode dflags location (Just old_iface) hst hit pcs_ch hscRecomp ghci_mode dflags location maybe_checked_iface hst hit pcs_ch = do { ; when (verbosity dflags >= 1) $ - hPutStrLn stderr "compilation IS required"; + hPutStrLn stderr ("Compiling " ++ + (unJust "hscRecomp" (ml_hs_file location))) -- what target are we shooting for? ; let toInterp = dopt_HscLang dflags == HscInterpreted @@ -191,12 +195,12 @@ hscRecomp ghci_mode dflags location maybe_checked_iface hst hit pcs_ch ------------------- -- RENAME ------------------- - ; (pcs_rn, maybe_rn_result) + ; (pcs_rn, print_unqualified, maybe_rn_result) <- _scc_ "Rename" renameModule dflags hit hst pcs_ch this_mod rdr_module ; case maybe_rn_result of { Nothing -> return (HscFail pcs_ch{-was: pcs_rn-}); - Just (print_unqualified, (is_exported, new_iface, rn_hs_decls)) -> do { + Just (is_exported, new_iface, rn_hs_decls) -> do { -- In interactive mode, we don't want to discard any top-level entities at -- all (eg. do not inline them away during simplification), and retain them @@ -394,66 +398,116 @@ myCoreToStg dflags this_mod tidy_binds env_tc %************************************************************************ %* * -\subsection{Compiling an expression} +\subsection{Compiling a do-statement} %* * %************************************************************************ \begin{code} #ifdef GHCI -hscExpr +hscStmt :: DynFlags - -> Bool -- True <=> wrap in 'print' to get a result of IO type -> HomeSymbolTable -> HomeIfaceTable -> PersistentCompilerState -- IN: persistent compiler state - -> Module -- Context for compiling - -> String -- The expression + -> InteractiveContext -- Context for compiling + -> String -- The statement -> IO ( PersistentCompilerState, - Maybe (UnlinkedBCOExpr, PrintUnqualified, Type) ) + Maybe (InteractiveContext, + [Id], + UnlinkedBCOExpr) ) +\end{code} + +When the UnlinkedBCOExpr is linked you get an HValue of type + IO [HValue] +When you run it you get a list of HValues that should be +the same length as the list of names; add them to the ClosureEnv. + +A naked expression returns a singleton Name [it]. + + What you type The IO [HValue] that hscStmt returns + ------------- ------------------------------------ + let pat = expr ==> let pat = expr in return [coerce HVal x, coerce HVal y, ...] + bindings: [x,y,...] + + pat <- expr ==> expr >>= \ pat -> return [coerce HVal x, coerce HVal y, ...] + bindings: [x,y,...] + + expr (of IO type) ==> expr >>= \ v -> return [v] + [NB: result not printed] bindings: [it] + + + expr (of non-IO type, + result showable) ==> let v = expr in print v >> return [v] + bindings: [it] -hscExpr dflags wrap_io hst hit pcs0 this_module expr - = do { - maybe_parsed <- hscParseExpr dflags expr; - case maybe_parsed of + expr (of non-IO type, + result not showable) ==> error + +\begin{code} +hscStmt dflags hst hit pcs0 icontext stmt + = let + InteractiveContext { + ic_rn_env = rn_env, + ic_type_env = type_env, + ic_module = this_mod } = icontext + in + do { maybe_stmt <- hscParseStmt dflags stmt + ; case maybe_stmt of Nothing -> return (pcs0, Nothing) - Just parsed_expr -> do { + Just parsed_stmt -> do { -- Rename it - (pcs1, maybe_renamed_expr) <- - renameExpr dflags hit hst pcs0 this_module parsed_expr; - case maybe_renamed_expr of - Nothing -> return ({-WAS:pcs1-} pcs0, Nothing) - Just (print_unqual, rn_expr) -> do { + (pcs1, print_unqual, maybe_renamed_stmt) + <- renameStmt dflags hit hst pcs0 this_mod rn_env parsed_stmt + ; case maybe_renamed_stmt of + Nothing -> return (pcs0, Nothing) + Just (bound_names, rn_stmt) -> do { -- Typecheck it - maybe_tc_return - <- typecheckExpr dflags wrap_io pcs1 hst print_unqual this_module rn_expr; - case maybe_tc_return of { - Nothing -> return ({-WAS:pcs1-} pcs0, Nothing); - Just (pcs2, tc_expr, ty) -> do - - let tidy_ty = tidyType emptyTidyEnv ty; + maybe_tc_return <- typecheckStmt dflags pcs1 hst type_env + print_unqual this_mod bound_names rn_stmt + ; case maybe_tc_return of { + Nothing -> return (pcs0, Nothing) ; + Just (pcs2, tc_expr, bound_ids) -> do { -- Desugar it - ds_expr <- deSugarExpr dflags pcs2 hst this_module - print_unqual tc_expr; + ds_expr <- deSugarExpr dflags pcs2 hst this_mod print_unqual tc_expr -- Simplify it - simpl_expr <- simplifyExpr dflags pcs2 hst ds_expr; + ; simpl_expr <- simplifyExpr dflags pcs2 hst ds_expr -- Saturate it - sat_expr <- coreSatExpr dflags simpl_expr; - - -- ToDo: need to do SRTs? + ; sat_expr <- coreSatExpr dflags simpl_expr -- Convert to BCOs - bcos <- coreExprToBCOs dflags sat_expr - - return (pcs2, Just (bcos, print_unqual, tidy_ty)); - }}}} - -hscParseExpr :: DynFlags -> String -> IO (Maybe RdrNameHsExpr) -hscParseExpr dflags str + ; bcos <- coreExprToBCOs dflags sat_expr + + ; let + -- make all the bound ids "constant" ids, now that + -- they're notionally top-level bindings. This is + -- important: otherwise when we come to compile an expression + -- using these ids later, the byte code generator will consider + -- the occurrences to be free rather than global. + constant_bound_ids = map constantizeId bound_ids + constantizeId id + = modifyIdInfo (`setFlavourInfo` makeConstantFlavour + (idFlavour id)) id + + new_rn_env = extendLocalRdrEnv rn_env + (map idName constant_bound_ids) + -- Extend the renamer-env from bound_ids, not bound_names, + -- because the latter may contain [it] when the former is empty + + new_type_env = extendNameEnvList type_env + [(getName id, AnId id) | id <- constant_bound_ids] + + new_icontext = icontext { ic_rn_env = new_rn_env, + ic_type_env = new_type_env } + ; return (pcs2, Just (new_icontext, bound_ids, bcos)) + }}}}} + +hscParseStmt :: DynFlags -> String -> IO (Maybe RdrNameStmt) +hscParseStmt dflags str = do -------------------------- Parser ---------------- showPass dflags "Parser" _scc_ "Parser" do @@ -461,23 +515,26 @@ hscParseExpr dflags str buf <- stringToStringBuffer str let glaexts | dopt Opt_GlasgowExts dflags = 1# - | otherwise = 0# + | otherwise = 0# - case parseExpr buf PState{ bol = 0#, atbol = 1#, + case parseStmt buf PState{ bol = 0#, atbol = 1#, context = [], glasgow_exts = glaexts, loc = mkSrcLoc SLIT("") 0 } of { PFailed err -> do { hPutStrLn stderr (showSDoc err); --- Not yet implemented in <4.11 freeStringBuffer buf; +-- Not yet implemented in <4.11 freeStringBuffer buf; return Nothing }; - POk _ rdr_expr -> do { + -- no stmt: the line consisted of just space or comments + POk _ Nothing -> return Nothing; + + POk _ (Just rdr_stmt) -> do { --ToDo: can't free the string buffer until we've finished this -- compilation sweep and all the identifiers have gone away. --freeStringBuffer buf; - dumpIfSet_dyn dflags Opt_D_dump_parsed "Parser" (ppr rdr_expr); - return (Just rdr_expr) + dumpIfSet_dyn dflags Opt_D_dump_parsed "Parser" (ppr rdr_stmt); + return (Just rdr_stmt) }} #endif \end{code} diff --git a/ghc/compiler/main/HscTypes.lhs b/ghc/compiler/main/HscTypes.lhs index eea91a4..f52f2cd 100644 --- a/ghc/compiler/main/HscTypes.lhs +++ b/ghc/compiler/main/HscTypes.lhs @@ -8,25 +8,29 @@ module HscTypes ( ModuleLocation(..), ModDetails(..), ModIface(..), - HomeSymbolTable, PackageTypeEnv, + HomeSymbolTable, emptySymbolTable, + PackageTypeEnv, HomeIfaceTable, PackageIfaceTable, emptyIfaceTable, lookupIface, lookupIfaceByModName, emptyModIface, + InteractiveContext(..), + IfaceDecls, mkIfaceDecls, dcl_tycl, dcl_rules, dcl_insts, VersionInfo(..), initialVersionInfo, TyThing(..), isTyClThing, implicitTyThingIds, - TypeEnv, lookupType, mkTypeEnv, extendTypeEnvList, + TypeEnv, lookupType, mkTypeEnv, emptyTypeEnv, + extendTypeEnvList, extendTypeEnvWithIds, typeEnvClasses, typeEnvTyCons, typeEnvIds, ImportedModuleInfo, WhetherHasOrphans, ImportVersion, WhatsImported(..), - PersistentRenamerState(..), IsBootInterface, Avails, DeclsMap, + PersistentRenamerState(..), IsBootInterface, DeclsMap, IfaceInsts, IfaceRules, GatedDecl, IsExported, NameSupply(..), OrigNameCache, OrigIParamCache, - AvailEnv, AvailInfo, GenAvailInfo(..), + Avails, AvailEnv, GenAvailInfo(..), AvailInfo, RdrAvailInfo, PersistentCompilerState(..), Deprecations(..), lookupDeprec, @@ -34,7 +38,9 @@ module HscTypes ( InstEnv, ClsInstEnv, DFunId, PackageInstEnv, PackageRuleBase, - GlobalRdrEnv, GlobalRdrElt(..), RdrAvailInfo, pprGlobalRdrEnv, + GlobalRdrEnv, GlobalRdrElt(..), pprGlobalRdrEnv, + LocalRdrEnv, extendLocalRdrEnv, + -- Provenance Provenance(..), ImportReason(..), @@ -44,8 +50,8 @@ module HscTypes ( #include "HsVersions.h" -import RdrName ( RdrNameEnv, emptyRdrEnv, rdrEnvToList ) -import Name ( Name, NamedThing, getName, nameModule, nameSrcLoc ) +import RdrName ( RdrNameEnv, addListToRdrEnv, emptyRdrEnv, mkRdrUnqual, rdrEnvToList ) +import Name ( Name, NamedThing, getName, nameOccName, nameModule, nameSrcLoc ) import Name -- Env import OccName ( OccName ) import Module ( Module, ModuleName, ModuleEnv, @@ -199,6 +205,9 @@ type PackageIfaceTable = IfaceTable type HomeSymbolTable = SymbolTable -- Domain = modules in the home package +emptySymbolTable :: SymbolTable +emptySymbolTable = emptyModuleEnv + emptyIfaceTable :: IfaceTable emptyIfaceTable = emptyModuleEnv \end{code} @@ -222,6 +231,26 @@ lookupIfaceByModName hit pit mod %************************************************************************ %* * +\subsection{The interactive context} +%* * +%************************************************************************ + +\begin{code} +data InteractiveContext + = InteractiveContext { + ic_module :: Module, -- The current module in which + -- the user is sitting + + ic_rn_env :: LocalRdrEnv, -- Lexical context for variables bound + -- during interaction + + ic_type_env :: TypeEnv -- Ditto for types + } +\end{code} + + +%************************************************************************ +%* * \subsection{Type environment stuff} %* * %************************************************************************ @@ -275,10 +304,11 @@ mkTypeEnv things = extendTypeEnvList emptyTypeEnv things extendTypeEnvList :: TypeEnv -> [TyThing] -> TypeEnv extendTypeEnvList env things - = foldl add_thing env things - where - add_thing :: TypeEnv -> TyThing -> TypeEnv - add_thing env thing = extendNameEnv env (getName thing) thing + = extendNameEnvList env [(getName thing, thing) | thing <- things] + +extendTypeEnvWithIds :: TypeEnv -> [Id] -> TypeEnv +extendTypeEnvWithIds env ids + = extendNameEnvList env [(getName id, AnId id) | id <- ids] \end{code} \begin{code} @@ -531,6 +561,16 @@ type GatedDecl d = ([Name], (Module, d)) %* * %************************************************************************ +A LocalRdrEnv is used for local bindings (let, where, lambda, case) + +\begin{code} +type LocalRdrEnv = RdrNameEnv Name + +extendLocalRdrEnv :: LocalRdrEnv -> [Name] -> LocalRdrEnv +extendLocalRdrEnv env names + = addListToRdrEnv env [(mkRdrUnqual (nameOccName n), n) | n <- names] +\end{code} + The GlobalRdrEnv gives maps RdrNames to Names. There is a separate one for each module, corresponding to that module's top-level scope. diff --git a/ghc/compiler/parser/ParseUtil.lhs b/ghc/compiler/parser/ParseUtil.lhs index 6e2de99..d0d3419 100644 --- a/ghc/compiler/parser/ParseUtil.lhs +++ b/ghc/compiler/parser/ParseUtil.lhs @@ -37,7 +37,7 @@ import RdrHsSyn ( RdrBinding(..), RdrNameHsRecordBinds, RdrNameMonoBinds, RdrNameConDetails ) import RdrName -import PrelNames ( unitTyCon_RDR, minus_RDR ) +import PrelNames ( unitTyCon_RDR ) import CallConv import OccName ( dataName, varName, tcClsName, occNameSpace, setOccNameSpace, occNameUserString ) diff --git a/ghc/compiler/parser/Parser.y b/ghc/compiler/parser/Parser.y index 52d81e7..7631659 100644 --- a/ghc/compiler/parser/Parser.y +++ b/ghc/compiler/parser/Parser.y @@ -1,6 +1,6 @@ {- ----------------------------------------------------------------------------- -$Id: Parser.y,v 1.54 2001/02/20 15:36:55 simonpj Exp $ +$Id: Parser.y,v 1.55 2001/02/26 15:06:59 simonmar Exp $ Haskell grammar. @@ -9,7 +9,7 @@ Author(s): Simon Marlow, Sven Panne 1997, 1998, 1999 -} { -module Parser ( parseModule, parseExpr ) where +module Parser ( parseModule, parseStmt ) where import HsSyn import HsTypes ( mkHsTupCon ) @@ -200,7 +200,7 @@ Conflicts: 14 shift/reduce %monad { P } { thenP } { returnP } %lexer { lexer } { ITeof } %name parseModule module -%name parseExpr exp +%name parseStmt maybe_stmt %tokentype { Token } %% @@ -693,7 +693,7 @@ exp10 :: { RdrNameHsExpr } | 'if' srcloc exp 'then' exp 'else' exp { HsIf $3 $5 $7 $2 } | 'case' srcloc exp 'of' altslist { HsCase $3 $5 $2 } | '-' fexp { mkHsNegApp $2 } - | srcloc 'do' stmtlist { HsDo DoStmt $3 $1 } + | srcloc 'do' stmtlist { HsDo DoExpr $3 $1 } | '_ccall_' ccallid aexps0 { HsCCall $2 $3 False False cbot } | '_ccall_GC_' ccallid aexps0 { HsCCall $2 $3 True False cbot } @@ -773,7 +773,7 @@ list :: { RdrNameHsExpr } body qss = [ParStmt (map reverse qss)] } in returnP ( HsDo ListComp - (reverse (ReturnStmt $1 : body $3)) + (reverse (ExprStmt $1 $2 : body $3)) $2 ) } @@ -790,14 +790,8 @@ pquals :: { [[RdrNameStmt]] } | '|' quals { [$2] } quals :: { [RdrNameStmt] } - : quals ',' qual { $3 : $1 } - | qual { [$1] } - -qual :: { RdrNameStmt } - : srcloc infixexp '<-' exp {% checkPattern $2 `thenP` \p -> - returnP (BindStmt p $4 $1) } - | srcloc exp { GuardStmt $2 $1 } - | srcloc 'let' declbinds { LetStmt $3 } + : quals ',' stmt { $3 : $1 } + | stmt { [$1] } ----------------------------------------------------------------------------- -- Case alternatives @@ -852,6 +846,12 @@ stmts1 :: { [RdrNameStmt] } | stmts1 ';' { $1 } | stmt { [$1] } +-- for typing stmts at the GHCi prompt, where the input may consist of +-- just comments. +maybe_stmt :: { Maybe RdrNameStmt } + : stmt { Just $1 } + | {- nothing -} { Nothing } + stmt :: { RdrNameStmt } : srcloc infixexp '<-' exp {% checkPattern $2 `thenP` \p -> returnP (BindStmt p $4 $1) } diff --git a/ghc/compiler/prelude/PrelNames.lhs b/ghc/compiler/prelude/PrelNames.lhs index b0ca305..c30e8ca 100644 --- a/ghc/compiler/prelude/PrelNames.lhs +++ b/ghc/compiler/prelude/PrelNames.lhs @@ -39,7 +39,9 @@ module PrelNames ( #include "HsVersions.h" import Module ( ModuleName, mkPrelModule, mkModuleName ) -import OccName ( NameSpace, UserFS, varName, dataName, tcName, clsName, mkKindOccFS ) +import OccName ( NameSpace, UserFS, varName, dataName, tcName, clsName, + mkKindOccFS, mkOccFS + ) import RdrName ( RdrName, mkOrig, mkUnqual ) import UniqFM import Unique ( Unique, Uniquable(..), hasKey, @@ -50,7 +52,7 @@ import BasicTypes ( Boxity(..), Arity ) import UniqFM ( UniqFM, listToUFM ) import Name ( Name, mkLocalName, mkKnownKeyGlobal, nameRdrName ) import RdrName ( rdrNameOcc ) -import SrcLoc ( builtinSrcLoc ) +import SrcLoc ( builtinSrcLoc, noSrcLoc ) import Util ( nOfThem ) import Panic ( panic ) \end{code} @@ -58,6 +60,29 @@ import Panic ( panic ) %************************************************************************ %* * +\subsection{Local Names} +%* * +%************************************************************************ + +This *local* name is used by the interactive stuff + +\begin{code} +itName = mkLocalName itIdKey (mkOccFS varName SLIT("it")) noSrcLoc +\end{code} + +\begin{code} +-- mkUnboundName makes a place-holder Name; it shouldn't be looked at except possibly +-- during compiler debugging. +mkUnboundName :: RdrName -> Name +mkUnboundName rdr_name = mkLocalName unboundKey (rdrNameOcc rdr_name) builtinSrcLoc + +isUnboundName :: Name -> Bool +isUnboundName name = name `hasKey` unboundKey +\end{code} + + +%************************************************************************ +%* * \subsection{Known key Names} %* * %************************************************************************ @@ -129,6 +154,7 @@ knownKeyNames newStablePtrName, bindIOName, returnIOName, + failIOName, -- Strings and lists mapName, @@ -157,6 +183,7 @@ knownKeyNames word64TyConName, -- Others + unsafeCoerceName, otherwiseIdName, plusIntegerName, timesIntegerName, @@ -337,6 +364,7 @@ genUnitTyConName = tcQual pREL_BASE_Name SLIT("Unit") genUnitTyConKey genUnitDataConName = dataQual pREL_BASE_Name SLIT("Unit") genUnitDataConKey -- Random PrelBase functions +unsafeCoerceName = varQual pREL_BASE_Name SLIT("unsafeCoerce") unsafeCoerceIdKey otherwiseIdName = varQual pREL_BASE_Name SLIT("otherwise") otherwiseIdKey appendName = varQual pREL_BASE_Name SLIT("++") appendIdKey foldrName = varQual pREL_BASE_Name SLIT("foldr") foldrIdKey @@ -427,6 +455,7 @@ ioTyConName = tcQual pREL_IO_BASE_Name SLIT("IO") ioTyConKey ioDataConName = dataQual pREL_IO_BASE_Name SLIT("IO") ioDataConKey bindIOName = varQual pREL_IO_BASE_Name SLIT("bindIO") bindIOIdKey returnIOName = varQual pREL_IO_BASE_Name SLIT("returnIO") returnIOIdKey +failIOName = varQual pREL_IO_BASE_Name SLIT("failIO") failIOIdKey -- IO things printName = varQual pREL_IO_Name SLIT("print") printIdKey @@ -799,6 +828,7 @@ getTagIdKey = mkPreludeMiscIdUnique 40 plusIntegerIdKey = mkPreludeMiscIdUnique 41 timesIntegerIdKey = mkPreludeMiscIdUnique 42 printIdKey = mkPreludeMiscIdUnique 43 +failIOIdKey = mkPreludeMiscIdUnique 44 \end{code} Certain class operations from Prelude classes. They get their own @@ -832,6 +862,7 @@ mapIdKey = mkPreludeMiscIdUnique 120 \begin{code} assertIdKey = mkPreludeMiscIdUnique 121 runSTRepIdKey = mkPreludeMiscIdUnique 122 +itIdKey = mkPreludeMiscIdUnique 123 -- "it" for the interactive interface \end{code} @@ -1022,12 +1053,3 @@ noDictClassKeys -- These classes are used only for type annotations; = cCallishClassKeys \end{code} -\begin{code} --- mkUnboundName makes a place-holder Name; it shouldn't be looked at except possibly --- during compiler debugging. -mkUnboundName :: RdrName -> Name -mkUnboundName rdr_name = mkLocalName unboundKey (rdrNameOcc rdr_name) builtinSrcLoc - -isUnboundName :: Name -> Bool -isUnboundName name = name `hasKey` unboundKey -\end{code} diff --git a/ghc/compiler/prelude/TysPrim.lhs b/ghc/compiler/prelude/TysPrim.lhs index b91ebfa..395da7d 100644 --- a/ghc/compiler/prelude/TysPrim.lhs +++ b/ghc/compiler/prelude/TysPrim.lhs @@ -50,7 +50,7 @@ module TysPrim( import Var ( TyVar, mkSysTyVar ) import Name ( Name ) -import PrimRep ( PrimRep(..), isFollowableRep ) +import PrimRep ( PrimRep(..) ) import TyCon ( TyCon, ArgVrcs, mkPrimTyCon ) import Type ( mkTyConApp, mkTyConTy, mkTyVarTys, mkTyVarTy, unliftedTypeKind, liftedTypeKind, openTypeKind, mkArrowKinds diff --git a/ghc/compiler/rename/Rename.lhs b/ghc/compiler/rename/Rename.lhs index 90027bb..8e6a7d7 100644 --- a/ghc/compiler/rename/Rename.lhs +++ b/ghc/compiler/rename/Rename.lhs @@ -4,22 +4,23 @@ \section[Rename]{Renaming and dependency analysis passes} \begin{code} -module Rename ( renameModule, renameExpr, closeIfaceDecls, checkOldIface ) where +module Rename ( renameModule, renameStmt, closeIfaceDecls, checkOldIface ) where #include "HsVersions.h" import HsSyn -import RdrHsSyn ( RdrNameHsModule, RdrNameHsDecl, RdrNameDeprecation, RdrNameHsExpr, - RdrNameTyClDecl, RdrNameRuleDecl, RdrNameInstDecl, RdrNameImportDecl +import RdrHsSyn ( RdrNameHsModule, RdrNameHsDecl, RdrNameDeprecation, + RdrNameTyClDecl, RdrNameRuleDecl, RdrNameInstDecl, RdrNameImportDecl, + RdrNameStmt ) import RnHsSyn ( RenamedHsDecl, RenamedTyClDecl, RenamedRuleDecl, RenamedInstDecl, - extractHsTyNames, RenamedHsExpr, + extractHsTyNames, RenamedStmt, instDeclFVs, tyClDeclFVs, ruleDeclFVs ) import CmdLineOpts ( DynFlags, DynFlag(..) ) import RnMonad -import RnExpr ( rnExpr ) +import RnExpr ( rnStmt ) import RnNames ( getGlobalNames, exportsFromAvail ) import RnSource ( rnSourceDecls, rnTyClDecl, rnIfaceRuleDecl, rnInstDecl ) import RnIfaces ( slurpImpDecls, mkImportInfo, recordLocalSlurps, @@ -28,7 +29,7 @@ import RnIfaces ( slurpImpDecls, mkImportInfo, recordLocalSlurps, ) import RnHiFiles ( readIface, removeContext, loadInterface, loadExports, loadFixDecls, loadDeprecs, - tryLoadInterface ) + ) import RnEnv ( availsToNameSet, mkIfaceGlobalRdrEnv, emptyAvailEnv, unitAvailEnv, availEnvElts, plusAvailEnv, groupAvails, warnUnusedImports, @@ -40,9 +41,7 @@ import Module ( Module, ModuleName, WhereFrom(..), moduleNameUserString, moduleName, moduleEnvElts ) -import Name ( Name, NamedThing(..), - nameIsLocalOrFrom, nameOccName, nameModule, - ) +import Name ( Name, nameIsLocalOrFrom, nameModule ) import Name ( mkNameEnv, nameEnvElts, extendNameEnv ) import RdrName ( foldRdrEnv, isQual ) import NameSet @@ -63,7 +62,8 @@ import HscTypes ( PersistentCompilerState, HomeIfaceTable, HomeSymbolTable, GlobalRdrEnv, GlobalRdrElt(..), pprGlobalRdrEnv, AvailEnv, GenAvailInfo(..), AvailInfo, Avails, Provenance(..), ImportReason(..), initialVersionInfo, - Deprecations(..) + Deprecations(..), + LocalRdrEnv ) import CmStaticInfo ( GhciMode(..) ) import List ( partition, nub ) @@ -83,8 +83,8 @@ renameModule :: DynFlags -> HomeIfaceTable -> HomeSymbolTable -> PersistentCompilerState -> Module -> RdrNameHsModule - -> IO (PersistentCompilerState, - Maybe (PrintUnqualified, (IsExported, ModIface, (SyntaxMap, [RenamedHsDecl])))) + -> IO (PersistentCompilerState, PrintUnqualified, + Maybe (IsExported, ModIface, (SyntaxMap, [RenamedHsDecl]))) -- Nothing => some error occurred in the renamer renameModule dflags hit hst pcs this_module rdr_module @@ -94,54 +94,64 @@ renameModule dflags hit hst pcs this_module rdr_module \begin{code} -renameExpr :: DynFlags +renameStmt :: DynFlags -> HomeIfaceTable -> HomeSymbolTable -> PersistentCompilerState - -> Module -> RdrNameHsExpr + -> Module -- current context (module) + -> LocalRdrEnv -- current context (temp bindings) + -> RdrNameStmt -- parsed stmt -> IO ( PersistentCompilerState, - Maybe (PrintUnqualified, (SyntaxMap, RenamedHsExpr, [RenamedHsDecl])) + PrintUnqualified, + Maybe ([Name], (SyntaxMap, RenamedStmt, [RenamedHsDecl])) ) -renameExpr dflags hit hst pcs this_module expr +renameStmt dflags hit hst pcs this_module local_env stmt = renameSource dflags hit hst pcs this_module $ - tryLoadInterface doc (moduleName this_module) ImportByUser - `thenRn` \ (iface, maybe_err) -> - case maybe_err of { - Just msg -> ioToRnM (printErrs alwaysQualify - (ptext SLIT("failed to load interface for") - <+> quotes (ppr this_module) - <> char ':' <+> msg)) `thenRn_` - returnRn Nothing; - Nothing -> - - let rdr_env = mi_globals iface - print_unqual = unQualInScope rdr_env - in - - initRnMS rdr_env emptyLocalFixityEnv CmdLineMode (rnExpr expr) - `thenRn` \ (e,fvs) -> - - checkErrsRn `thenRn` \ no_errs_so_far -> - if not no_errs_so_far then - -- Found errors already, so exit now - doDump e [] `thenRn_` - returnRn Nothing - else - - addImplicitFVs rdr_env Nothing fvs `thenRn` \ (slurp_fvs, syntax_map) -> - slurpImpDecls slurp_fvs `thenRn` \ decls -> - - doDump e decls `thenRn_` - returnRn (Just (print_unqual, (syntax_map, e, 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 + loadInterface doc (moduleName this_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 + + -- Rename it + initRnMS rdr_env local_env emptyLocalFixityEnv CmdLineMode ( + rnStmt stmt $ \ stmt' -> + returnRn (([], stmt'), emptyFVs) + ) `thenRn` \ ((binders, stmt), fvs) -> + + -- Bale out if we fail + checkErrsRn `thenRn` \ no_errs_so_far -> + if not no_errs_so_far then + doDump [] stmt [] `thenRn_` returnRn (print_unqual, Nothing) + else + + let filtered_fvs = fvs `delListFromNameSet` rdrEnvElts local_env in + + -- Add implicit free vars, and close decls + addImplicitFVs rdr_env Nothing filtered_fvs + `thenRn` \ (slurp_fvs, syntax_map) -> + slurpImpDecls slurp_fvs `thenRn` \ decls -> + + doDump binders stmt decls `thenRn_` + returnRn (print_unqual, Just (binders, (syntax_map, stmt, decls))) + where doc = text "context for compiling expression" - doDump :: RenamedHsExpr -> [RenamedHsDecl] -> RnMG (Either IOError ()) - doDump e decls = - getDOptsRn `thenRn` \ dflags -> - ioToRnM (dumpIfSet_dyn dflags Opt_D_dump_rn "Renamer:" - (vcat (ppr e : map ppr decls))) + doDump :: [Name] -> RenamedStmt -> [RenamedHsDecl] -> RnMG (Either IOError ()) + doDump bndrs stmt decls + = getDOptsRn `thenRn` \ dflags -> + ioToRnM (dumpIfSet_dyn dflags Opt_D_dump_rn "Renamer:" + (vcat [text "Binders:" <+> ppr bndrs, + ppr stmt, text "", + vcat (map ppr decls)])) \end{code} @@ -156,46 +166,45 @@ renameSource :: DynFlags -> HomeIfaceTable -> HomeSymbolTable -> PersistentCompilerState -> Module - -> RnMG (Maybe (PrintUnqualified, r)) - -> IO (PersistentCompilerState, Maybe (PrintUnqualified, r)) + -> RnMG (PrintUnqualified, Maybe r) + -> IO (PersistentCompilerState, PrintUnqualified, Maybe r) -- Nothing => some error occurred in the renamer renameSource dflags hit hst old_pcs this_module thing_inside = do { showPass dflags "Renamer" -- Initialise the renamer monad - ; (new_pcs, msgs, maybe_rn_stuff) <- initRn dflags hit hst old_pcs this_module thing_inside + ; (new_pcs, msgs, (print_unqual, maybe_rn_stuff)) + <- initRn dflags hit hst old_pcs this_module thing_inside -- Print errors from renaming - ; let print_unqual = case maybe_rn_stuff of - Just (unqual, _) -> unqual - Nothing -> alwaysQualify - ; printErrorsAndWarnings print_unqual msgs ; -- Return results. No harm in updating the PCS ; if errorsFound msgs then - return (new_pcs, Nothing) + return (new_pcs, print_unqual, Nothing) else - return (new_pcs, maybe_rn_stuff) + return (new_pcs, print_unqual, maybe_rn_stuff) } \end{code} \begin{code} rename :: Module -> RdrNameHsModule - -> RnMG (Maybe (PrintUnqualified, (IsExported, ModIface, (SyntaxMap, [RenamedHsDecl])))) + -> RnMG (PrintUnqualified, Maybe (IsExported, ModIface, (SyntaxMap, [RenamedHsDecl]))) rename this_module contents@(HsModule _ _ exports imports local_decls mod_deprec loc) = pushSrcLocRn loc $ -- FIND THE GLOBAL NAME ENVIRONMENT getGlobalNames this_module contents `thenRn` \ (gbl_env, local_gbl_env, all_avails@(_, global_avail_env)) -> - + let + print_unqualified = unQualInScope gbl_env + in -- Exit if we've found any errors checkErrsRn `thenRn` \ no_errs_so_far -> if not no_errs_so_far then -- Found errors already, so exit now rnDump [] [] `thenRn_` - returnRn Nothing + returnRn (print_unqualified, Nothing) else -- PROCESS EXPORT LIST @@ -223,7 +232,7 @@ rename this_module contents@(HsModule _ _ exports imports local_decls mod_deprec if not no_errs_so_far then -- Found errors already, so exit now rnDump [] rn_local_decls `thenRn_` - returnRn Nothing + returnRn (print_unqualified, Nothing) else -- SLURP IN ALL THE NEEDED DECLARATIONS @@ -263,7 +272,6 @@ rename this_module contents@(HsModule _ _ exports imports local_decls mod_deprec mi_decls = panic "mi_decls" } - print_unqualified = unQualInScope gbl_env is_exported name = name `elemNameSet` exported_names exported_names = availsToNameSet export_avails in @@ -273,7 +281,7 @@ rename this_module contents@(HsModule _ _ exports imports local_decls mod_deprec imports global_avail_env source_fvs export_avails rn_imp_decls `thenRn_` - returnRn (Just (print_unqualified, (is_exported, mod_iface, (sugar_map, final_decls)))) + returnRn (print_unqualified, Just (is_exported, mod_iface, (sugar_map, final_decls))) where mod_name = moduleName this_module \end{code} diff --git a/ghc/compiler/rename/RnBinds.lhs b/ghc/compiler/rename/RnBinds.lhs index cf28052..6ab814b 100644 --- a/ghc/compiler/rename/RnBinds.lhs +++ b/ghc/compiler/rename/RnBinds.lhs @@ -32,7 +32,7 @@ import RnEnv ( bindLocatedLocalsRn, lookupBndrRn, ) import CmdLineOpts ( DynFlag(..) ) import Digraph ( stronglyConnComp, SCC(..) ) -import Name ( OccName, Name, nameOccName, nameSrcLoc ) +import Name ( Name, nameOccName, nameSrcLoc ) import NameSet import RdrName ( RdrName, rdrNameOcc ) import BasicTypes ( RecFlag(..) ) @@ -237,7 +237,7 @@ rnMonoBinds mbinds sigs thing_inside -- Non-empty monobinds rn_mono_binds siglist mbinds `thenRn` \ (binds, bind_fvs) -> -- Now do the "thing inside", and deal with the free-variable calculations - thing_inside binds `thenRn` \ (result,result_fvs) -> + thing_inside binds `thenRn` \ (result,result_fvs) -> let all_fvs = result_fvs `plusFV` bind_fvs `plusFV` sig_fvs unused_binders = nameSetToList (binder_set `minusNameSet` all_fvs) diff --git a/ghc/compiler/rename/RnEnv.lhs b/ghc/compiler/rename/RnEnv.lhs index 9005d08..34a254e 100644 --- a/ghc/compiler/rename/RnEnv.lhs +++ b/ghc/compiler/rename/RnEnv.lhs @@ -21,7 +21,8 @@ import HsTypes ( hsTyVarName, replaceTyVarName ) import HscTypes ( Provenance(..), pprNameProvenance, hasBetterProv, ImportReason(..), GlobalRdrEnv, GlobalRdrElt(..), AvailEnv, AvailInfo, Avails, GenAvailInfo(..), NameSupply(..), - Deprecations(..), lookupDeprec + Deprecations(..), lookupDeprec, + extendLocalRdrEnv ) import RnMonad import Name ( Name, @@ -42,7 +43,8 @@ import PrelNames ( mkUnboundName, syntaxList, SyntaxMap, vanillaSyntaxMap, boolTyConName, funTyConName, unpackCStringName, unpackCStringFoldrName, unpackCStringUtf8Name, eqStringName, printName, - hasKey, fractionalClassKey, numClassKey + hasKey, fractionalClassKey, numClassKey, + bindIOName, returnIOName, failIOName ) import TysWiredIn ( unitTyCon ) -- A little odd import FiniteMap @@ -376,8 +378,10 @@ addImplicitFVs gbl_env maybe_mod source_fvs returnRn (slurp_fvs, sugar_map) where - extra_implicits Nothing -- Compiling an expression - = returnRn (unitFV printName) -- print :: a -> IO () may be needed later + extra_implicits Nothing -- Compiling a statement + = returnRn (mkFVs [printName, bindIOName, returnIOName, failIOName]) + -- These are all needed implicitly when compiling a statement + -- See TcModule.tc_stmts extra_implicits (Just (mod_name, decls)) -- Compiling a module = lookupOrigNames deriv_occs `thenRn` \ deriving_names -> @@ -540,10 +544,8 @@ bindCoreLocalsRn (b:bs) thing_inside = bindCoreLocalRn b $ \ name' -> bindLocalNames names enclosed_scope = getLocalNameEnv `thenRn` \ name_env -> - setLocalNameEnv (addListToRdrEnv name_env pairs) + setLocalNameEnv (extendLocalRdrEnv name_env names) enclosed_scope - where - pairs = [(mkRdrUnqual (nameOccName n), n) | n <- names] bindLocalNamesFV names enclosed_scope = bindLocalNames names $ diff --git a/ghc/compiler/rename/RnExpr.lhs b/ghc/compiler/rename/RnExpr.lhs index 8e60af9..d0463da 100644 --- a/ghc/compiler/rename/RnExpr.lhs +++ b/ghc/compiler/rename/RnExpr.lhs @@ -11,7 +11,7 @@ free variables. \begin{code} module RnExpr ( - rnMatch, rnGRHSs, rnPat, rnExpr, rnExprs, + rnMatch, rnGRHSs, rnPat, rnExpr, rnExprs, rnStmt, checkPrecMatch ) where @@ -229,15 +229,15 @@ rnGRHS (GRHS guarded locn) returnRn () ) `thenRn_` - rnStmts rnExpr guarded `thenRn` \ ((_, guarded'), fvs) -> + rnStmts guarded `thenRn` \ ((_, guarded'), fvs) -> returnRn (GRHS guarded' locn, fvs) where -- Standard Haskell 1.4 guards are just a single boolean -- expression, rather than a list of qualifiers as in the -- Glasgow extension - is_standard_guard [ExprStmt _ _] = True - is_standard_guard [GuardStmt _ _, ExprStmt _ _] = True - is_standard_guard other = False + is_standard_guard [ExprStmt _ _] = True + is_standard_guard [ExprStmt _ _, ExprStmt _ _] = True + is_standard_guard other = False \end{code} %************************************************************************ @@ -375,11 +375,10 @@ rnExpr (HsWith expr binds) rnExpr e@(HsDo do_or_lc stmts src_loc) = pushSrcLocRn src_loc $ lookupOrigNames implicit_rdr_names `thenRn` \ implicit_fvs -> - rnStmts rnExpr stmts `thenRn` \ ((_, stmts'), fvs) -> + rnStmts stmts `thenRn` \ ((_, stmts'), fvs) -> -- check the statement list ends in an expression case last stmts' of { ExprStmt _ _ -> returnRn () ; - ReturnStmt _ -> returnRn () ; -- for list comprehensions _ -> addErrRn (doStmtListErr e) } `thenRn_` returnRn (HsDo do_or_lc stmts' src_loc, fvs `plusFV` implicit_fvs) @@ -539,28 +538,28 @@ be @{r}@, and the free var set for the entire Quals will be @{r}@. This Quals. \begin{code} -type RnExprTy = RdrNameHsExpr -> RnMS (RenamedHsExpr, FreeVars) - -rnStmts :: RnExprTy - -> [RdrNameStmt] +rnStmts :: [RdrNameStmt] -> RnMS (([Name], [RenamedStmt]), FreeVars) -rnStmts rn_expr [] +rnStmts [] = returnRn (([], []), emptyFVs) -rnStmts rn_expr (stmt:stmts) +rnStmts (stmt:stmts) = getLocalNameEnv `thenRn` \ name_env -> - rnStmt rn_expr stmt $ \ stmt' -> - rnStmts rn_expr stmts `thenRn` \ ((binders, stmts'), fvs) -> + rnStmt stmt $ \ stmt' -> + rnStmts stmts `thenRn` \ ((binders, stmts'), fvs) -> returnRn ((binders, stmt' : stmts'), fvs) -rnStmt :: RnExprTy -> RdrNameStmt +rnStmt :: RdrNameStmt -> (RenamedStmt -> RnMS (([Name], a), FreeVars)) -> RnMS (([Name], a), FreeVars) +-- The thing list of names returned is the list returned by the +-- thing_inside, plus the binders of the arguments stmt + -- Because of mutual recursion we have to pass in rnExpr. -rnStmt rn_expr (ParStmt stmtss) thing_inside - = mapFvRn (rnStmts rn_expr) stmtss `thenRn` \ (bndrstmtss, fv_stmtss) -> +rnStmt (ParStmt stmtss) thing_inside + = mapFvRn rnStmts stmtss `thenRn` \ (bndrstmtss, fv_stmtss) -> let binderss = map fst bndrstmtss checkBndrs all_bndrs bndrs = checkRn (null (intersectBy eqOcc all_bndrs bndrs)) err `thenRn_` @@ -568,45 +567,35 @@ rnStmt rn_expr (ParStmt stmtss) thing_inside eqOcc n1 n2 = nameOccName n1 == nameOccName n2 err = text "duplicate binding in parallel list comprehension" in - foldlRn checkBndrs [] binderss `thenRn` \ binders -> - bindLocalNamesFV binders $ + foldlRn checkBndrs [] binderss `thenRn` \ new_binders -> + bindLocalNamesFV new_binders $ thing_inside (ParStmtOut bndrstmtss)`thenRn` \ ((rest_bndrs, result), fv_rest) -> - returnRn ((rest_bndrs ++ binders, result), fv_stmtss `plusFV` fv_rest) + returnRn ((new_binders ++ rest_bndrs, result), fv_stmtss `plusFV` fv_rest) -rnStmt rn_expr (BindStmt pat expr src_loc) thing_inside +rnStmt (BindStmt pat expr src_loc) thing_inside = pushSrcLocRn src_loc $ - rn_expr expr `thenRn` \ (expr', fv_expr) -> + rnExpr expr `thenRn` \ (expr', fv_expr) -> bindLocalsFVRn doc binders $ \ new_binders -> rnPat pat `thenRn` \ (pat', fv_pat) -> thing_inside (BindStmt pat' expr' src_loc) `thenRn` \ ((rest_binders, result), fvs) -> -- ZZ is shadowing handled correctly? - returnRn ((rest_binders ++ new_binders, result), + returnRn ((new_binders ++ rest_binders, result), fv_expr `plusFV` fvs `plusFV` fv_pat) where binders = collectPatBinders pat doc = text "a pattern in do binding" -rnStmt rn_expr (ExprStmt expr src_loc) thing_inside +rnStmt (ExprStmt expr src_loc) thing_inside = pushSrcLocRn src_loc $ - rn_expr expr `thenRn` \ (expr', fv_expr) -> + rnExpr expr `thenRn` \ (expr', fv_expr) -> thing_inside (ExprStmt expr' src_loc) `thenRn` \ (result, fvs) -> returnRn (result, fv_expr `plusFV` fvs) -rnStmt rn_expr (GuardStmt expr src_loc) thing_inside - = pushSrcLocRn src_loc $ - rn_expr expr `thenRn` \ (expr', fv_expr) -> - thing_inside (GuardStmt expr' src_loc) `thenRn` \ (result, fvs) -> - returnRn (result, fv_expr `plusFV` fvs) - -rnStmt rn_expr (ReturnStmt expr) thing_inside - = rn_expr expr `thenRn` \ (expr', fv_expr) -> - thing_inside (ReturnStmt expr') `thenRn` \ (result, fvs) -> - returnRn (result, fv_expr `plusFV` fvs) - -rnStmt rn_expr (LetStmt binds) thing_inside +rnStmt (LetStmt binds) thing_inside = rnBinds binds $ \ binds' -> - thing_inside (LetStmt binds') - + let new_binders = collectHsBinders binds' in + thing_inside (LetStmt binds') `thenRn` \ ((rest_binders, result), fvs) -> + returnRn ((new_binders ++ rest_binders, result), fvs ) \end{code} %************************************************************************ diff --git a/ghc/compiler/rename/RnHiFiles.lhs b/ghc/compiler/rename/RnHiFiles.lhs index a8b7257..690795b 100644 --- a/ghc/compiler/rename/RnHiFiles.lhs +++ b/ghc/compiler/rename/RnHiFiles.lhs @@ -39,9 +39,8 @@ import RnEnv import RnMonad import ParseIface ( parseIface ) -import Name ( Name {-instance NamedThing-}, nameOccName, - nameModule, isLocalName, nameIsLocalOrFrom, - NamedThing(..), +import Name ( Name {-instance NamedThing-}, + nameModule, isLocalName, nameIsLocalOrFrom ) import Name ( mkNameEnv, extendNameEnv ) import Module ( Module, @@ -49,7 +48,7 @@ import Module ( Module, ModuleName, WhereFrom(..), extendModuleEnv, mkVanillaModule ) -import RdrName ( RdrName, rdrNameOcc ) +import RdrName ( rdrNameOcc ) import SrcLoc ( mkSrcLoc ) import Maybes ( maybeToBool, orElse ) import StringBuffer ( hGetStringBuffer ) @@ -94,7 +93,10 @@ loadInterface doc mod from = tryLoadInterface doc mod from `thenRn` \ (ifaces, maybe_err) -> case maybe_err of Nothing -> returnRn ifaces - Just err -> failWithRn ifaces err + Just err -> failWithRn ifaces (elaborate err) + where + elaborate err = hang (ptext SLIT("failed to load interface for") <+> quotes (ppr mod) <> colon) + 4 err tryLoadInterface :: SDoc -> ModuleName -> WhereFrom -> RnM d (ModIface, Maybe Message) -- Returns (Just err) if an error happened diff --git a/ghc/compiler/rename/RnIfaces.lhs b/ghc/compiler/rename/RnIfaces.lhs index d0d16e2..3666e0b 100644 --- a/ghc/compiler/rename/RnIfaces.lhs +++ b/ghc/compiler/rename/RnIfaces.lhs @@ -38,7 +38,7 @@ import Id ( idType ) import Type ( namesOfType ) import TyCon ( isSynTyCon, getSynTyConDefn ) import Name ( Name {-instance NamedThing-}, nameOccName, - nameModule, isLocalName, + nameModule, isLocalName, isHomePackageName, NamedThing(..) ) import Name ( elemNameEnv, delFromNameEnv ) @@ -313,10 +313,10 @@ recordSlurp ifaces@(Ifaces { iDecls = (decls_map, n_slurped), where decls_map' = foldl delFromNameEnv decls_map (availNames avail) main_name = availName avail - mod = nameModule main_name new_slurped_names = addAvailToNameSet slurped_names avail - new_vslurp | isHomeModule mod = (imp_mods, addOneToNameSet imp_names main_name) - | otherwise = (extendModuleSet imp_mods mod, imp_names) + new_vslurp | isHomePackageName main_name = (imp_mods, addOneToNameSet imp_names main_name) + | otherwise = (extendModuleSet imp_mods mod, imp_names) + mod = nameModule main_name recordLocalSlurps new_names = getIfacesRn `thenRn` \ ifaces -> diff --git a/ghc/compiler/rename/RnMonad.lhs b/ghc/compiler/rename/RnMonad.lhs index 5a215ab..9f3bb3e 100644 --- a/ghc/compiler/rename/RnMonad.lhs +++ b/ghc/compiler/rename/RnMonad.lhs @@ -42,7 +42,7 @@ import HscTypes ( AvailEnv, lookupType, PersistentRenamerState(..), Avails, DeclsMap, IfaceInsts, IfaceRules, HomeSymbolTable, TyThing, - PersistentCompilerState(..), GlobalRdrEnv, + PersistentCompilerState(..), GlobalRdrEnv, LocalRdrEnv, HomeIfaceTable, PackageIfaceTable, RdrAvailInfo ) import BasicTypes ( Version, defaultFixity ) @@ -180,7 +180,6 @@ isInterfaceMode _ = False \begin{code} -------------------------------- -type LocalRdrEnv = RdrNameEnv Name type LocalFixityEnv = NameEnv RenamedFixitySig -- We keep the whole fixity sig so that we -- can report line-number info when there is a duplicate @@ -364,21 +363,21 @@ initRn dflags hit hst pcs mod do_rn return (new_pcs, (warns, errs), res) -initRnMS :: GlobalRdrEnv -> LocalFixityEnv -> RnMode +initRnMS :: GlobalRdrEnv -> LocalRdrEnv -> LocalFixityEnv -> RnMode -> RnMS a -> RnM d a -initRnMS rn_env fixity_env mode thing_inside rn_down g_down +initRnMS rn_env local_env fixity_env mode thing_inside rn_down g_down -- The fixity_env appears in both the rn_fixenv field -- and in the HIT. See comments with RnHiFiles.lookupFixityRn = let - s_down = SDown { rn_genv = rn_env, rn_lenv = emptyRdrEnv, + s_down = SDown { rn_genv = rn_env, rn_lenv = local_env, rn_fixenv = fixity_env, rn_mode = mode } in thing_inside rn_down s_down initIfaceRnMS :: Module -> RnMS r -> RnM d r initIfaceRnMS mod thing_inside - = initRnMS emptyRdrEnv emptyLocalFixityEnv InterfaceMode $ + = initRnMS emptyRdrEnv emptyRdrEnv emptyLocalFixityEnv InterfaceMode $ setModuleRn mod thing_inside \end{code} diff --git a/ghc/compiler/rename/RnNames.lhs b/ghc/compiler/rename/RnNames.lhs index d56b708..9e2b777 100644 --- a/ghc/compiler/rename/RnNames.lhs +++ b/ghc/compiler/rename/RnNames.lhs @@ -14,7 +14,7 @@ import CmdLineOpts ( DynFlag(..) ) import HsSyn ( HsModule(..), HsDecl(..), IE(..), ieName, ImportDecl(..), ForeignDecl(..), ForKind(..), isDynamicExtName, - collectTopBinders + collectLocatedHsBinders ) import RdrHsSyn ( RdrNameIE, RdrNameImportDecl, RdrNameHsModule, RdrNameHsDecl @@ -35,7 +35,7 @@ import HscTypes ( Provenance(..), ImportReason(..), GlobalRdrEnv, GenAvailInfo(..), AvailInfo, Avails, AvailEnv, Deprecations(..), ModIface(..) ) -import RdrName ( RdrName, rdrNameOcc, setRdrNameOcc ) +import RdrName ( rdrNameOcc, setRdrNameOcc ) import OccName ( setOccNameSpace, dataName ) import NameSet ( elemNameSet, emptyNameSet ) import Outputable @@ -236,7 +236,7 @@ getLocalDeclBinders mod (TyClD tycl_decl) returnRn [avail] getLocalDeclBinders mod (ValD binds) - = mapRn new (bagToList (collectTopBinders binds)) `thenRn` \ avails -> + = mapRn new (collectLocatedHsBinders binds) `thenRn` \ avails -> returnRn avails where new (rdr_name, loc) = newTopBinder mod rdr_name loc `thenRn` \ name -> diff --git a/ghc/compiler/rename/RnSource.lhs b/ghc/compiler/rename/RnSource.lhs index 9575ebc..9bcad7e 100644 --- a/ghc/compiler/rename/RnSource.lhs +++ b/ghc/compiler/rename/RnSource.lhs @@ -14,7 +14,7 @@ import RnExpr import HsSyn import HscTypes ( GlobalRdrEnv ) import HsTypes ( hsTyVarNames, pprHsContext ) -import RdrName ( RdrName, isRdrDataCon, rdrNameOcc, elemRdrEnv ) +import RdrName ( RdrName, isRdrDataCon, elemRdrEnv ) import RdrHsSyn ( RdrNameContext, RdrNameHsType, RdrNameConDecl, RdrNameTyClDecl, extractRuleBndrsTyVars, extractHsTyRdrTyVars, extractHsCtxtRdrTyVars, extractGenericPatTyVars @@ -35,7 +35,7 @@ import RnMonad import Class ( FunDep, DefMeth (..) ) import DataCon ( dataConId ) -import Name ( Name, OccName, nameOccName, NamedThing(..) ) +import Name ( Name, NamedThing(..) ) import NameSet import PrelInfo ( derivableClassKeys, cCallishClassKeys ) import PrelNames ( deRefStablePtr_RDR, newStablePtr_RDR, @@ -83,7 +83,7 @@ rnSourceDecls :: GlobalRdrEnv -> LocalFixityEnv -- The decls get reversed, but that's ok rnSourceDecls gbl_env local_fixity_env decls - = initRnMS gbl_env local_fixity_env SourceMode (go emptyFVs [] decls) + = initRnMS gbl_env emptyRdrEnv local_fixity_env SourceMode (go emptyFVs [] decls) where -- Fixity and deprecations have been dealt with already; ignore them go fvs ds' [] = returnRn (ds', fvs) diff --git a/ghc/compiler/typecheck/TcBinds.lhs b/ghc/compiler/typecheck/TcBinds.lhs index 64a7d2f..65c8549 100644 --- a/ghc/compiler/typecheck/TcBinds.lhs +++ b/ghc/compiler/typecheck/TcBinds.lhs @@ -13,8 +13,9 @@ import {-# SOURCE #-} TcMatches ( tcGRHSs, tcMatchesFun ) import {-# SOURCE #-} TcExpr ( tcExpr ) import CmdLineOpts ( opt_NoMonomorphismRestriction ) -import HsSyn ( HsExpr(..), HsBinds(..), MonoBinds(..), Sig(..), StmtCtxt(..), - Match(..), collectMonoBinders, andMonoBinds +import HsSyn ( HsExpr(..), HsBinds(..), MonoBinds(..), Sig(..), + Match(..), HsMatchContext(..), + collectMonoBinders, andMonoBinds ) import RnHsSyn ( RenamedHsBinds, RenamedSig, RenamedMonoBinds ) import TcHsSyn ( TcMonoBinds, TcId, zonkId, mkHsLet ) diff --git a/ghc/compiler/typecheck/TcClassDcl.lhs b/ghc/compiler/typecheck/TcClassDcl.lhs index c3d2074..3d0e943 100644 --- a/ghc/compiler/typecheck/TcClassDcl.lhs +++ b/ghc/compiler/typecheck/TcClassDcl.lhs @@ -26,7 +26,7 @@ import TcHsSyn ( TcMonoBinds ) import Inst ( Inst, InstOrigin(..), LIE, emptyLIE, plusLIE, plusLIEs, instToId, newDicts, newMethod ) -import TcEnv ( TcEnv, RecTcEnv, TyThingDetails(..), tcAddImportedIdInfo, +import TcEnv ( RecTcEnv, TyThingDetails(..), tcAddImportedIdInfo, tcLookupClass, tcExtendTyVarEnvForMeths, tcExtendGlobalTyVars, tcExtendLocalValEnv, tcExtendTyVarEnv ) diff --git a/ghc/compiler/typecheck/TcDeriv.lhs b/ghc/compiler/typecheck/TcDeriv.lhs index 650eb71..103af50 100644 --- a/ghc/compiler/typecheck/TcDeriv.lhs +++ b/ghc/compiler/typecheck/TcDeriv.lhs @@ -17,7 +17,7 @@ import RnHsSyn ( RenamedHsBinds, RenamedMonoBinds, RenamedTyClDecl ) import CmdLineOpts ( DynFlag(..), DynFlags ) import TcMonad -import TcEnv ( TcEnv, tcSetInstEnv, newDFunName, InstInfo(..), pprInstInfo, +import TcEnv ( tcSetInstEnv, newDFunName, InstInfo(..), pprInstInfo, tcLookupClass, tcLookupTyCon ) import TcGenDeriv -- Deriv stuff diff --git a/ghc/compiler/typecheck/TcEnv.lhs b/ghc/compiler/typecheck/TcEnv.lhs index cbd92f8..4d9dbb8 100644 --- a/ghc/compiler/typecheck/TcEnv.lhs +++ b/ghc/compiler/typecheck/TcEnv.lhs @@ -14,14 +14,14 @@ module TcEnv( simpleInstInfoTy, simpleInstInfoTyCon, -- Global environment - tcExtendGlobalEnv, tcExtendGlobalValEnv, + tcExtendGlobalEnv, tcExtendGlobalValEnv, tcExtendGlobalTypeEnv, tcLookupTyCon, tcLookupClass, tcLookupGlobalId, tcLookupDataCon, tcLookupGlobal_maybe, tcLookupGlobal, tcLookupSyntaxId, tcLookupSyntaxName, -- Local environment tcExtendKindEnv, tcLookupLocalIds, tcExtendTyVarEnv, tcExtendTyVarEnvForMeths, - tcExtendLocalValEnv, tcLookup, tcLookup_maybe, + tcExtendLocalValEnv, tcLookup, tcLookup_maybe, tcLookupId, -- Global type variables tcGetGlobalTyVars, tcExtendGlobalTyVars, @@ -60,10 +60,14 @@ import Name ( Name, OccName, NamedThing(..), nameOccName, getSrcLoc, mkLocalName, isLocalName, nameIsLocalOrFrom, nameModule_maybe ) -import Name ( NameEnv, lookupNameEnv, nameEnvElts, extendNameEnvList, emptyNameEnv ) +import Name ( NameEnv, lookupNameEnv, nameEnvElts, + extendNameEnvList, emptyNameEnv, plusNameEnv ) import OccName ( mkDFunOcc, occNameString ) -import HscTypes ( DFunId, TypeEnv, HomeSymbolTable, PackageTypeEnv, - typeEnvTyCons, typeEnvClasses, typeEnvIds +import HscTypes ( DFunId, + PackageTypeEnv, TypeEnv, + extendTypeEnvList, extendTypeEnvWithIds, + typeEnvTyCons, typeEnvClasses, typeEnvIds, + HomeSymbolTable ) import Module ( Module ) import InstEnv ( InstEnv, emptyInstEnv ) @@ -98,7 +102,8 @@ data TcEnv {- NameEnv TyThing-} -- compiling this module: -- types and classes (both imported and local) -- imported Ids - -- (Ids defined in this module are in the local envt) + -- (Ids defined in this module start in the local envt, + -- though they move to the global envt during zonking) tcLEnv :: NameEnv TcTyThing, -- The local type environment: Ids and TyVars -- defined in this module @@ -277,7 +282,16 @@ tcExtendGlobalEnv :: [TyThing] -> TcM r -> TcM r tcExtendGlobalEnv things thing_inside = tcGetEnv `thenNF_Tc` \ env -> let - ge' = extendNameEnvList (tcGEnv env) [(getName thing, thing) | thing <- things] + ge' = extendTypeEnvList (tcGEnv env) things + in + tcSetEnv (env {tcGEnv = ge'}) thing_inside + + +tcExtendGlobalTypeEnv :: TypeEnv -> TcM r -> TcM r +tcExtendGlobalTypeEnv extra_env thing_inside + = tcGetEnv `thenNF_Tc` \ env -> + let + ge' = tcGEnv env `plusNameEnv` extra_env in tcSetEnv (env {tcGEnv = ge'}) thing_inside @@ -285,7 +299,7 @@ tcExtendGlobalValEnv :: [Id] -> TcM a -> TcM a tcExtendGlobalValEnv ids thing_inside = tcGetEnv `thenNF_Tc` \ env -> let - ge' = extendNameEnvList (tcGEnv env) [(getName id, AnId id) | id <- ids] + ge' = extendTypeEnvWithIds (tcGEnv env) ids in tcSetEnv (env {tcGEnv = ge'}) thing_inside \end{code} @@ -337,6 +351,14 @@ tcLookupTyCon name Just (ATyCon tc) -> returnNF_Tc tc other -> notFound "tcLookupTyCon" name +tcLookupId :: Name -> NF_TcM Id +tcLookupId name + = tcLookup name `thenNF_Tc` \ thing -> + case thing of + ATcId tc_id -> returnNF_Tc tc_id + AGlobal (AnId id) -> returnNF_Tc id + other -> pprPanic "tcLookupId" (ppr name) + tcLookupLocalIds :: [Name] -> NF_TcM [TcId] tcLookupLocalIds ns = tcGetEnv `thenNF_Tc` \ env -> diff --git a/ghc/compiler/typecheck/TcExpr.lhs b/ghc/compiler/typecheck/TcExpr.lhs index 59730b2..37fdce6 100644 --- a/ghc/compiler/typecheck/TcExpr.lhs +++ b/ghc/compiler/typecheck/TcExpr.lhs @@ -9,7 +9,7 @@ module TcExpr ( tcApp, tcExpr, tcMonoExpr, tcPolyExpr, tcId ) where #include "HsVersions.h" import HsSyn ( HsExpr(..), HsLit(..), ArithSeqInfo(..), - StmtCtxt(..), mkMonoBind + HsMatchContext(..), mkMonoBind ) import RnHsSyn ( RenamedHsExpr, RenamedRecordBinds ) import TcHsSyn ( TcExpr, TcRecordBinds, mkHsLet ) @@ -24,9 +24,8 @@ import Inst ( InstOrigin(..), instToId, tcInstId ) import TcBinds ( tcBindsAndThen ) -import TcEnv ( TcTyThing(..), - tcLookupClass, tcLookupGlobalId, tcLookupGlobal_maybe, - tcLookupTyCon, tcLookupDataCon, tcLookup, +import TcEnv ( tcLookupClass, tcLookupGlobalId, tcLookupGlobal_maybe, + tcLookupTyCon, tcLookupDataCon, tcLookupId, tcExtendGlobalTyVars, tcLookupSyntaxName ) import TcMatches ( tcMatchesCase, tcMatchLambda, tcStmts ) @@ -645,22 +644,6 @@ tcIPBind (name, expr) returnTc ((ip, expr'), lie) \end{code} -Typecheck expression which in most cases will be an Id. - -\begin{code} -tcExpr_id :: RenamedHsExpr - -> TcM (TcExpr, - LIE, - TcType) -tcExpr_id id_expr - = case id_expr of - HsVar name -> tcId name `thenNF_Tc` \ stuff -> - returnTc stuff - other -> newTyVarTy openTypeKind `thenNF_Tc` \ id_ty -> - tcMonoExpr id_expr id_ty `thenTc` \ (id_expr', lie_id) -> - returnTc (id_expr', lie_id, id_ty) -\end{code} - %************************************************************************ %* * \subsection{@tcApp@ typchecks an application} @@ -753,15 +736,22 @@ tcArg the_fun (arg, expected_arg_ty, arg_no) \begin{code} tcId :: Name -> NF_TcM (TcExpr, LIE, TcType) +tcId name -- Look up the Id and instantiate its type + = tcLookupId name `thenNF_Tc` \ id -> + tcInstId id +\end{code} + +Typecheck expression which in most cases will be an Id. -tcId name - = -- Look up the Id and instantiate its type - tcLookup name `thenNF_Tc` \ thing -> - case thing of - ATcId tc_id -> tcInstId tc_id - AGlobal (AnId id) -> tcInstId id +\begin{code} +tcExpr_id :: RenamedHsExpr -> TcM (TcExpr, LIE, TcType) +tcExpr_id (HsVar name) = tcId name +tcExpr_id expr = newTyVarTy openTypeKind `thenNF_Tc` \ id_ty -> + tcMonoExpr expr id_ty `thenTc` \ (expr', lie_id) -> + returnTc (expr', lie_id, id_ty) \end{code} + %************************************************************************ %* * \subsection{@tcDoStmts@ typechecks a {\em list} of do statements} diff --git a/ghc/compiler/typecheck/TcGenDeriv.lhs b/ghc/compiler/typecheck/TcGenDeriv.lhs index 96ac572..a5a993a 100644 --- a/ghc/compiler/typecheck/TcGenDeriv.lhs +++ b/ghc/compiler/typecheck/TcGenDeriv.lhs @@ -28,7 +28,7 @@ module TcGenDeriv ( import HsSyn ( InPat(..), HsExpr(..), MonoBinds(..), Match(..), GRHSs(..), Stmt(..), HsLit(..), - HsBinds(..), StmtCtxt(..), HsType(..), + HsBinds(..), HsType(..), HsMatchContext(..), unguardedRHS, mkSimpleMatch, mkMonoBind, andMonoBindList ) import RdrHsSyn ( mkHsOpApp, RdrNameMonoBinds, RdrNameHsExpr, RdrNamePat ) @@ -63,7 +63,6 @@ import Panic ( panic, assertPanic ) import Maybes ( maybeToBool, orElse ) import Constants import List ( partition, intersperse ) -import Outputable ( pprPanic, ppr, pprTrace ) #if __GLASGOW_HASKELL__ >= 404 import GlaExts ( fromInt ) @@ -719,7 +718,7 @@ gen_Ix_binds tycon where stmts = zipWith3Equal "single_con_range" mk_qual as_needed bs_needed cs_needed ++ - [ReturnStmt con_expr] + [ExprStmt con_expr tycon_loc] mk_qual a b c = BindStmt (VarPatIn c) (HsApp (HsVar range_RDR) @@ -908,7 +907,7 @@ gen_Read_binds get_fixity tycon | is_infix = let (h:t) = field_quals in (h:con_qual:t) | otherwise = con_qual:field_quals - stmts = quals ++ [ReturnStmt result_expr] + stmts = quals ++ [ExprStmt result_expr tycon_loc] {- c.f. Figure 18 in Haskell 1.1 report. diff --git a/ghc/compiler/typecheck/TcHsSyn.lhs b/ghc/compiler/typecheck/TcHsSyn.lhs index ec0b920..e7805cf 100644 --- a/ghc/compiler/typecheck/TcHsSyn.lhs +++ b/ghc/compiler/typecheck/TcHsSyn.lhs @@ -28,7 +28,7 @@ module TcHsSyn ( -- re-exported from TcEnv TcId, - zonkTopBinds, zonkId, zonkIdOcc, zonkExpr, + zonkTopBinds, zonkId, zonkIdBndr, zonkIdOcc, zonkExpr, zonkForeignExports, zonkRules ) where @@ -510,20 +510,11 @@ zonkStmts (ParStmtOut bndrstmtss : stmts) returnNF_Tc (ParStmtOut (zip new_bndrss new_stmtss) : new_stmts) where (bndrss, stmtss) = unzip bndrstmtss -zonkStmts [ReturnStmt expr] - = zonkExpr expr `thenNF_Tc` \ new_expr -> - returnNF_Tc [ReturnStmt new_expr] - zonkStmts (ExprStmt expr locn : stmts) = zonkExpr expr `thenNF_Tc` \ new_expr -> zonkStmts stmts `thenNF_Tc` \ new_stmts -> returnNF_Tc (ExprStmt new_expr locn : new_stmts) -zonkStmts (GuardStmt expr locn : stmts) - = zonkExpr expr `thenNF_Tc` \ new_expr -> - zonkStmts stmts `thenNF_Tc` \ new_stmts -> - returnNF_Tc (GuardStmt new_expr locn : new_stmts) - zonkStmts (LetStmt binds : stmts) = zonkBinds binds `thenNF_Tc` \ (new_binds, new_env) -> tcSetEnv new_env $ diff --git a/ghc/compiler/typecheck/TcIfaceSig.lhs b/ghc/compiler/typecheck/TcIfaceSig.lhs index 256bcae..6ec6b44 100644 --- a/ghc/compiler/typecheck/TcIfaceSig.lhs +++ b/ghc/compiler/typecheck/TcIfaceSig.lhs @@ -11,7 +11,7 @@ module TcIfaceSig ( tcInterfaceSigs, tcVar, tcCoreExpr, tcCoreLamBndrs ) where import HsSyn ( TyClDecl(..), HsTupCon(..) ) import TcMonad import TcMonoType ( tcIfaceType ) -import TcEnv ( TcEnv, RecTcEnv, tcExtendTyVarEnv, +import TcEnv ( RecTcEnv, tcExtendTyVarEnv, tcExtendGlobalValEnv, tcSetEnv, tcEnvIds, tcLookupGlobal_maybe, tcLookupRecId_maybe ) diff --git a/ghc/compiler/typecheck/TcMatches.hi-boot b/ghc/compiler/typecheck/TcMatches.hi-boot index fa47d4e..593f18e 100644 --- a/ghc/compiler/typecheck/TcMatches.hi-boot +++ b/ghc/compiler/typecheck/TcMatches.hi-boot @@ -5,7 +5,7 @@ _declarations_ 2 tcGRHSs _:_ _forall_ [s] => RnHsSyn.RenamedGRHSs -> TcMonad.TcType - -> HsExpr.StmtCtxt + -> HsExpr.HsMatchContext -> TcMonad.TcM s (TcHsSyn.TcGRHSs, Inst.LIE) ;; 3 tcMatchesFun _:_ _forall_ [s] => [(Name.Name,Var.Id)] diff --git a/ghc/compiler/typecheck/TcMatches.hi-boot-5 b/ghc/compiler/typecheck/TcMatches.hi-boot-5 index ee566f1..044339d 100644 --- a/ghc/compiler/typecheck/TcMatches.hi-boot-5 +++ b/ghc/compiler/typecheck/TcMatches.hi-boot-5 @@ -3,7 +3,7 @@ __export TcMatches tcGRHSs tcMatchesFun; 1 tcGRHSs :: RnHsSyn.RenamedGRHSs -> TcMonad.TcType - -> HsExpr.StmtCtxt + -> HsExpr.HsMatchContext -> TcMonad.TcM (TcHsSyn.TcGRHSs, Inst.LIE) ; 1 tcMatchesFun :: [(Name.Name,Var.Id)] diff --git a/ghc/compiler/typecheck/TcMatches.lhs b/ghc/compiler/typecheck/TcMatches.lhs index 47315c0..32fd91e 100644 --- a/ghc/compiler/typecheck/TcMatches.lhs +++ b/ghc/compiler/typecheck/TcMatches.lhs @@ -4,15 +4,17 @@ \section[TcMatches]{Typecheck some @Matches@} \begin{code} -module TcMatches ( tcMatchesFun, tcMatchesCase, tcMatchLambda, tcStmts, tcGRHSs ) where +module TcMatches ( tcMatchesFun, tcMatchesCase, tcMatchLambda, + tcStmts, tcStmtsAndThen, tcGRHSs + ) where #include "HsVersions.h" import {-# SOURCE #-} TcExpr( tcExpr ) import HsSyn ( HsBinds(..), Match(..), GRHSs(..), GRHS(..), - MonoBinds(..), StmtCtxt(..), Stmt(..), - pprMatch, getMatchLoc, + MonoBinds(..), Stmt(..), HsMatchContext(..), + pprMatch, getMatchLoc, pprMatchContext, isDoExpr, mkMonoBind, nullMonoBinds, collectSigTysFromPats ) import RnHsSyn ( RenamedMatch, RenamedGRHSs, RenamedStmt ) @@ -94,7 +96,7 @@ tcMatchesCase matches expr_ty returnTc (scrut_ty, matches', lie) tcMatchLambda :: RenamedMatch -> TcType -> TcM (TcMatch, LIE) -tcMatchLambda match res_ty = tcMatch [] match res_ty LambdaBody +tcMatchLambda match res_ty = tcMatch [] match res_ty LambdaExpr \end{code} @@ -102,7 +104,7 @@ tcMatchLambda match res_ty = tcMatch [] match res_ty LambdaBody tcMatches :: [(Name,Id)] -> [RenamedMatch] -> TcType - -> StmtCtxt + -> HsMatchContext -> TcM ([TcMatch], LIE) tcMatches xve matches expected_ty fun_or_case @@ -124,7 +126,7 @@ tcMatch :: [(Name,Id)] -> RenamedMatch -> TcType -- Expected result-type of the Match. -- Early unification with this guy gives better error messages - -> StmtCtxt + -> HsMatchContext -> TcM (TcMatch, LIE) tcMatch xve1 match@(Match sig_tvs pats maybe_rhs_sig grhss) expected_ty ctxt @@ -205,7 +207,7 @@ glue_on is_rec mbinds (GRHSs grhss binds ty) = GRHSs grhss (mkMonoBind mbinds [] is_rec `ThenBinds` binds) ty tcGRHSs :: RenamedGRHSs - -> TcType -> StmtCtxt + -> TcType -> HsMatchContext -> TcM (TcGRHSs, LIE) tcGRHSs (GRHSs grhss binds _) expected_ty ctxt @@ -318,7 +320,7 @@ tcStmts do_or_lc m_ty stmts tcStmtsAndThen :: (TcStmt -> thing -> thing) -- Combiner - -> StmtCtxt + -> HsMatchContext -> (TcType -> TcType, TcType) -- m, the relationship type of pat and rhs in pat <- rhs -- elt_ty, where type of the comprehension is (m elt_ty) -> [RenamedStmt] @@ -390,50 +392,40 @@ tcStmtsAndThen combine do_or_lc m_ty (ParStmtOut bndr_stmts_s : stmts) do_next not_required = panic "tcStmtsAndThen: elt_ty" -- The simple-statment case -tcStmtsAndThen combine do_or_lc m_ty (stmt:stmts) do_next +tcStmtsAndThen combine do_or_lc m_ty (stmt@(ExprStmt exp locn):stmts) do_next = tcSetErrCtxt (stmtCtxt do_or_lc stmt) ( - tcSimpleStmt do_or_lc m_ty stmt (null stmts) - ) `thenTc` \ (stmt', stmt_lie) -> + tcExprStmt do_or_lc m_ty exp (null stmts) + ) `thenTc` \ (exp', stmt_lie) -> tcStmtsAndThen combine do_or_lc m_ty stmts do_next `thenTc` \ (thing, stmts_lie) -> - returnTc (combine stmt' thing, + returnTc (combine (ExprStmt exp' locn) thing, stmt_lie `plusLIE` stmts_lie) ------------------------------ - -- ReturnStmt -tcSimpleStmt do_or_lc (_,elt_ty) (ReturnStmt exp) is_last_stmt - = ASSERT( is_last_stmt ) - tcExpr exp elt_ty `thenTc` \ (exp', exp_lie) -> - returnTc (ReturnStmt exp', exp_lie) - - -- ExprStmt -tcSimpleStmt do_or_lc (m, elt_ty) (ExprStmt exp src_loc) is_last_stmt - = tcAddSrcLoc src_loc $ - (if is_last_stmt then -- do { ... ; wuggle } wuggle : m elt_ty - returnNF_Tc elt_ty - else -- do { ... ; wuggle ; .... } wuggle : m any_ty - ASSERT( isDoStmt do_or_lc ) - newTyVarTy openTypeKind - ) `thenNF_Tc` \ arg_ty -> - tcExpr exp (m arg_ty) `thenTc` \ (exp', exp_lie) -> - returnTc (ExprStmt exp' src_loc, exp_lie) - - -- GuardStmt -tcSimpleStmt do_or_lc m_ty (GuardStmt exp src_loc) is_last_stmt - = ASSERT( not (isDoStmt do_or_lc) ) - tcAddSrcLoc src_loc $ - tcExpr exp boolTy `thenTc` \ (exp', exp_lie) -> - returnTc (GuardStmt exp' src_loc, exp_lie) + -- ExprStmt; see comments with HsExpr.HsStmt + -- for meaning of ExprStmt +tcExprStmt do_or_lc (m, res_elt_ty) exp is_last_stmt + = compute_expr_ty `thenNF_Tc` \ expr_ty -> + tcExpr exp expr_ty + where + compute_expr_ty + | is_last_stmt = if isDoExpr do_or_lc then + returnNF_Tc (m res_elt_ty) + else + returnNF_Tc res_elt_ty + + | otherwise = if isDoExpr do_or_lc then + newTyVarTy openTypeKind `thenNF_Tc` \ any_ty -> + returnNF_Tc (m any_ty) + else + returnNF_Tc boolTy ------------------------------ glue_binds combine is_rec binds thing | nullMonoBinds binds = thing | otherwise = combine (LetStmt (mkMonoBind binds [] is_rec)) thing - -isDoStmt DoStmt = True -isDoStmt other = False \end{code} @@ -465,7 +457,7 @@ matchCtxt (FunRhs fun) match where ppr_fun = ppr fun -matchCtxt LambdaBody match +matchCtxt LambdaExpr match = hang (ptext SLIT("In the lambda expression")) 4 (pprMatch (True, empty) match) @@ -475,19 +467,5 @@ varyingArgsErr name matches lurkingRank2SigErr = ptext SLIT("Too few explicit arguments when defining a function with a rank-2 type") -stmtCtxt do_or_lc stmt - = hang (ptext SLIT("In") <+> what <> colon) - 4 (ppr stmt) - where - what = case do_or_lc of - ListComp -> ptext SLIT("a list-comprehension qualifier") - DoStmt -> ptext SLIT("a do statement") - PatBindRhs -> thing <+> ptext SLIT("a pattern binding") - FunRhs f -> thing <+> ptext SLIT("an equation for") <+> quotes (ppr f) - CaseAlt -> thing <+> ptext SLIT("a case alternative") - LambdaBody -> thing <+> ptext SLIT("a lambda abstraction") - thing = case stmt of - BindStmt _ _ _ -> ptext SLIT("a pattern guard for") - GuardStmt _ _ -> ptext SLIT("a guard for") - ExprStmt _ _ -> ptext SLIT("the right-hand side of") +stmtCtxt do_or_lc stmt = hang (pprMatchContext do_or_lc <> colon) 4 (ppr stmt) \end{code} diff --git a/ghc/compiler/typecheck/TcModule.lhs b/ghc/compiler/typecheck/TcModule.lhs index 50343ef..7987d4f 100644 --- a/ghc/compiler/typecheck/TcModule.lhs +++ b/ghc/compiler/typecheck/TcModule.lhs @@ -5,56 +5,63 @@ \begin{code} module TcModule ( - typecheckModule, typecheckIface, typecheckExpr, TcResults(..) + typecheckModule, typecheckIface, typecheckStmt, TcResults(..) ) where #include "HsVersions.h" import CmdLineOpts ( DynFlag(..), DynFlags, opt_PprStyle_Debug ) import HsSyn ( HsBinds(..), MonoBinds(..), HsDecl(..), HsExpr(..), - isIfaceRuleDecl, nullBinds, andMonoBindList + Stmt(..), InPat(..), HsMatchContext(..), + isIfaceRuleDecl, nullBinds, andMonoBindList, mkSimpleMatch ) import HsTypes ( toHsType ) -import PrelNames ( SyntaxMap, mAIN_Name, mainName, ioTyConName, printName ) -import RnHsSyn ( RenamedHsBinds, RenamedHsDecl, RenamedHsExpr ) +import PrelNames ( SyntaxMap, mAIN_Name, mainName, ioTyConName, printName, + returnIOName, bindIOName, failIOName, + itName + ) +import MkId ( unsafeCoerceId ) +import RnHsSyn ( RenamedHsBinds, RenamedHsDecl, RenamedStmt ) import TcHsSyn ( TypecheckedMonoBinds, TypecheckedHsExpr, TypecheckedForeignDecl, TypecheckedRuleDecl, zonkTopBinds, zonkForeignExports, zonkRules, mkHsLet, - zonkExpr + zonkExpr, zonkIdBndr ) import TcMonad import TcType ( newTyVarTy, zonkTcType, tcInstType ) +import TcMatches ( tcStmtsAndThen ) import TcUnify ( unifyTauTy ) -import Inst ( plusLIE ) -import VarSet ( varSetElems ) +import Inst ( emptyLIE, plusLIE ) import TcBinds ( tcTopBinds ) import TcClassDcl ( tcClassDecls2 ) import TcDefaults ( tcDefaults, defaultDefaultTys ) -import TcExpr ( tcMonoExpr ) import TcEnv ( TcEnv, RecTcEnv, InstInfo, tcExtendGlobalValEnv, tcLookup_maybe, isLocalThing, tcSetEnv, tcSetInstEnv, initTcEnv, getTcGEnv, - TcTyThing(..), tcLookupTyCon + tcExtendGlobalTypeEnv, tcLookupGlobalId, tcLookupTyCon, + TcTyThing(..), tcLookupId ) import TcRules ( tcIfaceRules, tcSourceRules ) import TcForeign ( tcForeignImports, tcForeignExports ) import TcIfaceSig ( tcInterfaceSigs ) import TcInstDcls ( tcInstDecls1, tcInstDecls2 ) -import TcSimplify ( tcSimplifyTop, tcSimplifyInfer ) +import TcSimplify ( tcSimplifyTop ) import TcTyClsDecls ( tcTyAndClassDecls ) import CoreUnfold ( unfoldingTemplate, hasUnfolding ) -import Type ( funResultTy, splitForAllTys, mkForAllTys, mkFunTys, - liftedTypeKind, openTypeKind, mkTyConApp, tyVarsOfType, tidyType ) +import TysWiredIn ( mkListTy, unitTy ) +import Type ( funResultTy, splitForAllTys, + liftedTypeKind, mkTyConApp, tidyType ) import ErrUtils ( printErrorsAndWarnings, errorsFound, dumpIfSet_dyn, showPass ) -import Id ( idType, idName, isLocalId, idUnfolding ) +import Id ( Id, idType, idName, isLocalId, idUnfolding ) import Module ( Module, isHomeModule, moduleName ) import Name ( Name, toRdrName, isGlobalName ) import Name ( nameEnvElts, lookupNameEnv ) import TyCon ( tyConGenInfo ) import Util -import BasicTypes ( EP(..), Fixity ) +import BasicTypes ( EP(..), Fixity, RecFlag(..) ) +import SrcLoc ( noSrcLoc ) import Outputable import HscTypes ( PersistentCompilerState(..), HomeSymbolTable, PackageTypeEnv, ModIface(..), @@ -64,99 +71,29 @@ import HscTypes ( PersistentCompilerState(..), HomeSymbolTable, ) \end{code} -Outside-world interface: -\begin{code} - --- Convenient type synonyms first: -data TcResults - = TcResults { - -- All these fields have info *just for this module* - tc_env :: TypeEnv, -- The top level TypeEnv - tc_binds :: TypecheckedMonoBinds, -- Bindings - tc_fords :: [TypecheckedForeignDecl], -- Foreign import & exports. - tc_rules :: [TypecheckedRuleDecl] -- Transformation rules - } - ---------------- -typecheckModule - :: DynFlags - -> PersistentCompilerState - -> HomeSymbolTable - -> ModIface -- Iface for this module (just module & fixities) - -> PrintUnqualified -- For error printing - -> (SyntaxMap, [RenamedHsDecl]) - -> IO (Maybe (PersistentCompilerState, TcResults)) - -- The new PCS is Augmented with imported information, - -- (but not stuff from this module) - -typecheckModule dflags pcs hst mod_iface unqual (syn_map, decls) - = do { maybe_tc_result <- typecheck dflags syn_map pcs hst unqual $ - tcModule pcs hst get_fixity this_mod decls - ; printTcDump dflags maybe_tc_result - ; return maybe_tc_result } - where - this_mod = mi_module mod_iface - fixity_env = mi_fixities mod_iface - - get_fixity :: Name -> Maybe Fixity - get_fixity nm = lookupNameEnv fixity_env nm - ---------------- -typecheckIface - :: DynFlags - -> PersistentCompilerState - -> HomeSymbolTable - -> ModIface -- Iface for this module (just module & fixities) - -> (SyntaxMap, [RenamedHsDecl]) - -> IO (Maybe (PersistentCompilerState, TypeEnv, [TypecheckedRuleDecl])) - -- The new PCS is Augmented with imported information, - -- (but not stuff from this module). - -- The TcResults returned contains only the environment - -- and rules. - - -typecheckIface dflags pcs hst mod_iface (syn_map, decls) - = do { maybe_tc_stuff <- typecheck dflags syn_map pcs hst alwaysQualify $ - tcIfaceImports pcs hst get_fixity this_mod decls - ; printIfaceDump dflags maybe_tc_stuff - ; return maybe_tc_stuff } - where - this_mod = mi_module mod_iface - fixity_env = mi_fixities mod_iface - - get_fixity :: Name -> Maybe Fixity - get_fixity nm = lookupNameEnv fixity_env nm - - tcIfaceImports pcs hst get_fixity this_mod decls - = 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(nullBinds deriv_binds) - let - local_things = filter (isLocalThing this_mod) - (nameEnvElts (getTcGEnv env)) - local_type_env :: TypeEnv - local_type_env = mkTypeEnv local_things - in - - -- throw away local_inst_info - returnTc (new_pcs, local_type_env, local_rules) +%************************************************************************ +%* * +\subsection{The stmt interface} +%* * +%************************************************************************ ---------------- -typecheckExpr :: DynFlags - -> Bool -- True <=> wrap in 'print' to get a result of IO type +\begin{code} +typecheckStmt :: DynFlags -> PersistentCompilerState -> HomeSymbolTable + -> TypeEnv -- The interactive context's type envt -> PrintUnqualified -- For error printing - -> Module + -> Module -- Is this really needed + -> [Name] -- Names bound by the Stmt (empty for expressions) -> (SyntaxMap, - RenamedHsExpr, -- The expression itself + RenamedStmt, -- The stmt itself [RenamedHsDecl]) -- Plus extra decls it sucked in from interface files - -> IO (Maybe (PersistentCompilerState, TypecheckedHsExpr, TcType)) + -> IO (Maybe (PersistentCompilerState, TypecheckedHsExpr, [Id])) + -- The returned [Name] is the same as the input except for + -- ExprStmt, in which case the returned [Name] is [itName] -typecheckExpr dflags wrap_io pcs hst unqual this_mod (syn_map, expr, decls) +typecheckStmt dflags pcs hst ic_type_env unqual this_mod names (syn_map, stmt, iface_decls) = typecheck dflags syn_map pcs hst unqual $ -- use the default default settings, i.e. [Integer, Double] @@ -164,83 +101,156 @@ typecheckExpr dflags wrap_io pcs hst unqual this_mod (syn_map, expr, decls) -- Typecheck the extra declarations fixTc (\ ~(unf_env, _, _, _, _) -> - tcImports unf_env pcs hst get_fixity this_mod decls + tcImports unf_env pcs hst get_fixity this_mod iface_decls ) `thenTc` \ (env, new_pcs, local_inst_info, deriv_binds, local_rules) -> ASSERT( null local_inst_info && nullBinds deriv_binds && null local_rules ) - -- Now typecheck the expression tcSetEnv env $ - tc_expr expr `thenTc` \ (expr', expr_ty) -> - zonkExpr expr' `thenNF_Tc` \ zonked_expr -> - zonkTcType expr_ty `thenNF_Tc` \ zonked_ty -> - ioToTc (dumpIfSet_dyn dflags - Opt_D_dump_tc "Typechecked" (ppr zonked_expr)) `thenNF_Tc_` - returnTc (new_pcs, zonked_expr, zonked_ty) + tcExtendGlobalTypeEnv ic_type_env $ + + -- The real work is done here + tcUserStmt names stmt `thenTc` \ (expr, bound_ids) -> + + traceTc (text "tcs 1") `thenNF_Tc_` + zonkExpr expr `thenNF_Tc` \ zonked_expr -> + mapNF_Tc zonkIdBndr bound_ids `thenNF_Tc` \ zonked_ids -> + + ioToTc (dumpIfSet_dyn dflags Opt_D_dump_tc "Bound Ids" (vcat (map ppr zonked_ids))) `thenNF_Tc_` + ioToTc (dumpIfSet_dyn dflags Opt_D_dump_tc "Typechecked" (ppr zonked_expr)) `thenNF_Tc_` + + returnTc (new_pcs, zonked_expr, zonked_ids) where get_fixity :: Name -> Maybe Fixity get_fixity n = pprPanic "typecheckExpr" (ppr n) +\end{code} - smpl_doc = ptext SLIT("main expression") - - -- Typecheck it, wrapping in 'print' if necessary to - -- get a result of type IO t. Returns the result type - -- that is free in the result type - tc_expr e - | wrap_io = tryTc_ (tc_io_expr (HsApp (HsVar printName) e)) -- Recovery case - (tc_io_expr e) -- Main case - | otherwise = newTyVarTy openTypeKind `thenTc` \ ty -> - tcMonoExpr e ty `thenTc` \ (e', lie) -> - tcSimplifyInfer smpl_doc (varSetElems (tyVarsOfType ty)) lie - `thenTc` \ (qtvs, lie_free, dict_binds, dict_ids) -> - tcSimplifyTop lie_free `thenTc` \ const_binds -> - let all_expr = mkHsLet const_binds $ - TyLam qtvs $ - DictLam dict_ids $ - mkHsLet dict_binds $ - e' - all_expr_ty = mkForAllTys qtvs $ - mkFunTys (map idType dict_ids) $ - ty - in - returnTc (all_expr, all_expr_ty) - where - tc_io_expr e = newTyVarTy openTypeKind `thenTc` \ ty -> - tcLookupTyCon ioTyConName `thenNF_Tc` \ ioTyCon -> - let - res_ty = mkTyConApp ioTyCon [ty] - in - tcMonoExpr e res_ty `thenTc` \ (e', lie) -> - tcSimplifyTop lie `thenTc` \ const_binds -> - let all_expr = mkHsLet const_binds e' in - returnTc (all_expr, res_ty) - ---------------- -typecheck :: DynFlags - -> SyntaxMap - -> PersistentCompilerState - -> HomeSymbolTable - -> PrintUnqualified -- For error printing - -> TcM r - -> IO (Maybe r) +Here is the grand plan, implemented in tcUserStmt -typecheck dflags syn_map pcs hst unqual thing_inside - = do { showPass dflags "Typechecker"; - ; env <- initTcEnv syn_map hst (pcs_PTE pcs) + What you type The IO [HValue] that hscStmt returns + ------------- ------------------------------------ + let pat = expr ==> let pat = expr in return [coerce HVal x, coerce HVal y, ...] + bindings: [x,y,...] - ; (maybe_tc_result, errs) <- initTc dflags env thing_inside + pat <- expr ==> expr >>= \ pat -> return [coerce HVal x, coerce HVal y, ...] + bindings: [x,y,...] - ; printErrorsAndWarnings unqual errs + expr (of IO type) ==> expr >>= \ v -> return [v] + [NB: result not printed] bindings: [it] + - ; if errorsFound errs then - return Nothing - else - return maybe_tc_result - } + expr (of non-IO type, + result showable) ==> let v = expr in print v >> return [v] + bindings: [it] + + expr (of non-IO type, + result not showable) ==> error + + +\begin{code} +tcUserStmt :: [Name] -> RenamedStmt -> TcM (TypecheckedHsExpr, [Id]) + +tcUserStmt names (ExprStmt expr loc) + = ASSERT( null names ) + tryTc_ (traceTc (text "tcs 1b") `thenNF_Tc_` + tc_stmts [itName] [LetStmt (MonoBind the_bind [] NonRecursive), + ExprStmt (HsApp (HsVar printName) (HsVar itName)) loc]) + ( traceTc (text "tcs 1a") `thenNF_Tc_` + tc_stmts [itName] [BindStmt (VarPatIn itName) expr loc]) + where + the_bind = FunMonoBind itName False [mkSimpleMatch [] expr Nothing loc] loc + +tcUserStmt names stmt + = tc_stmts names [stmt] + + +tc_stmts names stmts + = tcLookupGlobalId returnIOName `thenNF_Tc` \ return_id -> + tcLookupGlobalId bindIOName `thenNF_Tc` \ bind_id -> + tcLookupGlobalId failIOName `thenNF_Tc` \ fail_id -> + tcLookupTyCon ioTyConName `thenNF_Tc` \ ioTyCon -> + newTyVarTy liftedTypeKind `thenNF_Tc` \ res_ty -> + let + io_ty = (\ ty -> mkTyConApp ioTyCon [ty], res_ty) + + -- mk_return builds the expression + -- returnIO @ [()] [coerce () x, .., coerce () z] + mk_return ids = HsApp (TyApp (HsVar return_id) [mkListTy unitTy]) + (ExplicitListOut unitTy (map mk_item ids)) + + mk_item id = HsApp (TyApp (HsVar unsafeCoerceId) [idType id, unitTy]) + (HsVar id) + in + + traceTc (text "tcs 2") `thenNF_Tc_` + tcStmtsAndThen combine DoExpr io_ty stmts ( + -- Look up the names right in the middle, + -- where they will all be in scope + mapNF_Tc tcLookupId names `thenNF_Tc` \ ids -> + returnTc ((ids, [ExprStmt (mk_return ids) noSrcLoc]), emptyLIE) + ) `thenTc` \ ((ids, tc_stmts), lie) -> + + -- Simplify the context right here, so that we fail + -- if there aren't enough instances. Notably, when we see + -- e + -- we use tryTc_ to try it <- e + -- and then let it = e + -- It's the simplify step that rejects the first. + + traceTc (text "tcs 3") `thenNF_Tc_` + tcSimplifyTop lie `thenTc` \ const_binds -> + traceTc (text "tcs 4") `thenNF_Tc_` + + returnTc (mkHsLet const_binds $ + HsDoOut DoExpr tc_stmts return_id bind_id fail_id + (mkTyConApp ioTyCon [mkListTy unitTy]) noSrcLoc, + ids) + where + combine stmt (ids, stmts) = (ids, stmt:stmts) \end{code} -The internal monster: + +%************************************************************************ +%* * +\subsection{Typechecking a module} +%* * +%************************************************************************ + \begin{code} +typecheckModule + :: DynFlags + -> PersistentCompilerState + -> HomeSymbolTable + -> ModIface -- Iface for this module + -> PrintUnqualified -- For error printing + -> (SyntaxMap, [RenamedHsDecl]) + -> IO (Maybe (PersistentCompilerState, TcResults)) + -- The new PCS is Augmented with imported information, + -- (but not stuff from this module) + +data TcResults + = TcResults { + -- All these fields have info *just for this module* + tc_env :: TypeEnv, -- The top level TypeEnv + tc_binds :: TypecheckedMonoBinds, -- Bindings + tc_fords :: [TypecheckedForeignDecl], -- Foreign import & exports. + tc_rules :: [TypecheckedRuleDecl] -- Transformation rules + } + + +typecheckModule dflags pcs hst mod_iface unqual (syn_map, decls) + = do { maybe_tc_result <- typecheck dflags syn_map pcs hst unqual $ + tcModule pcs hst get_fixity this_mod decls + ; printTcDump dflags maybe_tc_result + ; return maybe_tc_result } + where + this_mod = mi_module mod_iface + fixity_env = mi_fixities mod_iface + + get_fixity :: Name -> Maybe Fixity + get_fixity nm = lookupNameEnv fixity_env nm + + tcModule :: PersistentCompilerState -> HomeSymbolTable -> (Name -> Maybe Fixity) @@ -357,7 +367,55 @@ tcModule pcs hst get_fixity this_mod decls \end{code} +%************************************************************************ +%* * +\subsection{Typechecking interface decls} +%* * +%************************************************************************ + \begin{code} +typecheckIface + :: DynFlags + -> PersistentCompilerState + -> HomeSymbolTable + -> ModIface -- Iface for this module (just module & fixities) + -> (SyntaxMap, [RenamedHsDecl]) + -> IO (Maybe (PersistentCompilerState, TypeEnv, [TypecheckedRuleDecl])) + -- The new PCS is Augmented with imported information, + -- (but not stuff from this module). + -- The TcResults returned contains only the environment + -- and rules. + + +typecheckIface dflags pcs hst mod_iface (syn_map, decls) + = do { maybe_tc_stuff <- typecheck dflags syn_map pcs hst alwaysQualify $ + tcIfaceImports pcs hst get_fixity this_mod decls + ; printIfaceDump dflags maybe_tc_stuff + ; return maybe_tc_stuff } + where + this_mod = mi_module mod_iface + fixity_env = mi_fixities mod_iface + + get_fixity :: Name -> Maybe Fixity + get_fixity nm = lookupNameEnv fixity_env nm + + tcIfaceImports pcs hst get_fixity this_mod decls + = 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(nullBinds deriv_binds) + let + local_things = filter (isLocalThing this_mod) + (nameEnvElts (getTcGEnv env)) + local_type_env :: TypeEnv + local_type_env = mkTypeEnv local_things + in + + -- throw away local_inst_info + returnTc (new_pcs, local_type_env, local_rules) + + tcImports :: RecTcEnv -> PersistentCompilerState -> HomeSymbolTable @@ -442,6 +500,7 @@ tcImports unf_env pcs hst get_fixity this_mod decls iface_rules = [d | RuleD d <- decls, isIfaceRuleDecl d] \end{code} + %************************************************************************ %* * \subsection{Checking the type of main} @@ -496,6 +555,37 @@ noMainErr = hsep [ptext SLIT("Module") <+> quotes (ppr mAIN_Name), %************************************************************************ %* * +\subsection{Interfacing the Tc monad to the IO monad} +%* * +%************************************************************************ + +\begin{code} +typecheck :: DynFlags + -> SyntaxMap + -> PersistentCompilerState + -> HomeSymbolTable + -> PrintUnqualified -- For error printing + -> TcM r + -> IO (Maybe r) + +typecheck dflags syn_map pcs hst unqual thing_inside + = do { showPass dflags "Typechecker"; + ; env <- initTcEnv syn_map hst (pcs_PTE pcs) + + ; (maybe_tc_result, errs) <- initTc dflags env thing_inside + + ; printErrorsAndWarnings unqual errs + + ; if errorsFound errs then + return Nothing + else + return maybe_tc_result + } +\end{code} + + +%************************************************************************ +%* * \subsection{Dumping output} %* * %************************************************************************ diff --git a/ghc/compiler/typecheck/TcSimplify.lhs b/ghc/compiler/typecheck/TcSimplify.lhs index d9d165c..7af5b97 100644 --- a/ghc/compiler/typecheck/TcSimplify.lhs +++ b/ghc/compiler/typecheck/TcSimplify.lhs @@ -1205,6 +1205,10 @@ tcSimplifyTop wanted_lie mapTc disambigGroup std_oks `thenTc` \ binds_ambig -> -- And complain about the ones that don't + -- This group includes both non-existent instances + -- e.g. Num (IO a) and Eq (Int -> Int) + -- and ambiguous dictionaries + -- e.g. Num a addTopAmbigErrs bad_guys `thenNF_Tc_` returnTc (binds `andMonoBinds` andMonoBindList binds_ambig) @@ -1264,7 +1268,8 @@ disambigGroup dicts in -- See if any default works, and if so bind the type variable to it -- If not, add an AmbigErr - recoverTc (addAmbigErrs dicts `thenNF_Tc_` returnTc EmptyMonoBinds) $ + recoverTc (addAmbigErrs dicts `thenNF_Tc_` + returnTc EmptyMonoBinds) $ try_default default_tys `thenTc` \ chosen_default_ty -> @@ -1468,7 +1473,8 @@ addTopAmbigErrs dicts fixed_tvs = oclose (predsOfInsts tidy_dicts) emptyVarSet (tidy_env, tidy_dicts) = tidyInsts emptyTidyEnv dicts complain d | not (null (getIPs d)) = addTopIPErr tidy_env d - | tyVarsOfInst d `subVarSet` fixed_tvs = addTopInstanceErr tidy_env d + | not (isTyVarDict d) || + tyVarsOfInst d `subVarSet` fixed_tvs = addTopInstanceErr tidy_env d | otherwise = addAmbigErr tidy_env d addTopIPErr tidy_env tidy_dict diff --git a/ghc/compiler/utils/Outputable.lhs b/ghc/compiler/utils/Outputable.lhs index 4ffb74d..c8e454d 100644 --- a/ghc/compiler/utils/Outputable.lhs +++ b/ghc/compiler/utils/Outputable.lhs @@ -34,7 +34,8 @@ module Outputable ( printSDoc, printErrs, printDump, printForC, printForAsm, printForIface, printForUser, pprCode, pprCols, - showSDoc, showSDocDebug, showSDocIface, showSDocUnqual, showsPrecSDoc, + showSDoc, showSDocForUser, showSDocDebug, showSDocIface, + showSDocUnqual, showsPrecSDoc, pprHsChar, pprHsString, @@ -203,6 +204,9 @@ pprCode cs d = withPprStyle (PprCode cs) d showSDoc :: SDoc -> String showSDoc d = show (d defaultUserStyle) +showSDocForUser :: PrintUnqualified -> SDoc -> String +showSDocForUser unqual doc = show (doc (mkUserStyle unqual AllTheWay)) + showSDocUnqual :: SDoc -> String -- Only used in the gruesome HsExpr.isOperator showSDocUnqual d = show (d (mkUserStyle neverQualify AllTheWay)) -- 1.7.10.4