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.
zapFragileInfo, zapLamInfo, zapSpecPragInfo, shortableIdInfo, copyIdInfo,
-- Flavour
- IdFlavour(..), flavourInfo,
+ IdFlavour(..), flavourInfo, makeConstantFlavour,
setNoDiscardInfo, setFlavourInfo,
ppFlavourInfo,
| 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]")
toRdrName, hashName,
globaliseName, localiseName,
- nameSrcLoc, nameIsLocallyDefined, isDllName, nameIsFrom, nameIsLocalOrFrom,
+ nameSrcLoc,
isSystemName, isLocalName, isGlobalName, isExternallyVisibleName,
- isTyVarName,
+ isTyVarName, isDllName,
+ nameIsLocalOrFrom, isHomePackageName,
-- Environment
NameEnv, mkNameEnv,
-- Class NamedThing and overloaded friends
NamedThing(..),
- getSrcLoc, getOccString, toRdrName,
- isFrom, isLocalOrFrom
+ getSrcLoc, getOccString, toRdrName
) where
#include "HsVersions.h"
\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
-- 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}
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}
filterModuleLinkables,
findModuleLinkable_maybe,
LinkResult(..),
+ updateClosureEnv,
link,
unload,
PersistentLinkerState{-abstractly!-}, emptyPLS,
import CmStaticInfo ( GhciMode(..) )
import Outputable ( SDoc )
import Digraph ( SCC(..), flattenSCC )
+import Name ( Name )
import Module ( ModuleName )
import FiniteMap
import Outputable
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.
--
\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"
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 )
#ifdef GHCI
import Interpreter ( HValue )
-import HscMain ( hscExpr )
-import Type ( Type )
+import HscMain ( hscStmt )
import PrelGHC ( unsafeCoerce# )
#endif
\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 {
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
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
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
-- 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
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
-- 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
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 ]
-- 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
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)
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
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
-- 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)
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)
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)
-> 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
-- 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)
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
= 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 ->
, 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])
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}
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 )
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}
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)
-> 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)
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
import TysWiredIn ( nilDataCon, consDataCon, unitDataConId, tupleCon, mkListTy, mkTupleTy )
import Match ( matchSimply )
import PrelNames ( foldrName, buildName )
+import SrcLoc ( noSrcLoc )
import List ( zip4 )
\end{code}
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)
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)
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 $
-> [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))
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 ->
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 )
\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}
| 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 ->
-- (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
_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 ;;
__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 ;
= 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) =
\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}
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}
%************************************************************************
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
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) ->
-----------------------------------------------------------------------------
--- $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
--
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
import Monad ( when )
import PrelGHC ( unsafeCoerce# )
-import PrelPack ( packString )
-import PrelByteArr
import Foreign ( nullPtr )
import CString ( peekCString )
builtin_commands = [
("add", keepGoing addModule),
("cd", keepGoing changeDirectory),
- ("def", keepGoing defineMacro),
+-- ("def", keepGoing defineMacro),
("help", keepGoing help),
("?", keepGoing help),
("load", keepGoing loadModule),
helpText = "\
\ Commands available from the prompt:\n\
\\
-\ <expr> evaluate <expr>\n\
+\ <stmt> evaluate/run <stmt>\n\
\ :add <filename> add a module to the current set\n\
\ :cd <dir> change directory to <dir>\n\
\ :help, :? display this list of commands\n\
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 ()
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 ()
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 ->
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)
= 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
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
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
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
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
| 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)
= 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)
-----------------------------------------------------------------------------
#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 )
_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 ;;
__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 ;
+
#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 )
| 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
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
= 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}
%************************************************************************
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}
#include "HsVersions.h"
+
-- friends:
import HsLit ( HsLit, HsOverLit )
import HsExpr ( HsExpr )
module HsExpr,
module HsImpExp,
module HsLit,
- module HsMatches,
module HsPat,
module HsTypes,
Fixity, NewOrData,
- collectTopBinders, collectMonoBinders, collectLocatedMonoBinders,
+ collectHsBinders, collectLocatedHsBinders,
+ collectMonoBinders, collectLocatedMonoBinders,
hsModuleName, hsModuleImports
) where
import HsExpr
import HsImpExp
import HsLit
-import HsMatches
import HsPat
import HsTypes
import BasicTypes ( Fixity, Version, NewOrData )
import Name ( NamedThing )
import Outputable
import SrcLoc ( SrcLoc )
-import Bag
import Module ( ModuleName )
\end{code}
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
\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
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 )
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 )
}
| 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)
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
-------------------
-- 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
%************************************************************************
%* *
-\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
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("<no file>") 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}
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,
InstEnv, ClsInstEnv, DFunId,
PackageInstEnv, PackageRuleBase,
- GlobalRdrEnv, GlobalRdrElt(..), RdrAvailInfo, pprGlobalRdrEnv,
+ GlobalRdrEnv, GlobalRdrElt(..), pprGlobalRdrEnv,
+ LocalRdrEnv, extendLocalRdrEnv,
+
-- Provenance
Provenance(..), ImportReason(..),
#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,
type HomeSymbolTable = SymbolTable -- Domain = modules in the home package
+emptySymbolTable :: SymbolTable
+emptySymbolTable = emptyModuleEnv
+
emptyIfaceTable :: IfaceTable
emptyIfaceTable = emptyModuleEnv
\end{code}
%************************************************************************
%* *
+\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}
%* *
%************************************************************************
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}
%* *
%************************************************************************
+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.
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 )
{-
-----------------------------------------------------------------------------
-$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.
-}
{
-module Parser ( parseModule, parseExpr ) where
+module Parser ( parseModule, parseStmt ) where
import HsSyn
import HsTypes ( mkHsTupCon )
%monad { P } { thenP } { returnP }
%lexer { lexer } { ITeof }
%name parseModule module
-%name parseExpr exp
+%name parseStmt maybe_stmt
%tokentype { Token }
%%
| '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 }
body qss = [ParStmt (map reverse qss)] }
in
returnP ( HsDo ListComp
- (reverse (ReturnStmt $1 : body $3))
+ (reverse (ExprStmt $1 $2 : body $3))
$2
)
}
| '|' 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
| 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) }
#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,
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}
%************************************************************************
%* *
+\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}
%* *
%************************************************************************
newStablePtrName,
bindIOName,
returnIOName,
+ failIOName,
-- Strings and lists
mapName,
word64TyConName,
-- Others
+ unsafeCoerceName,
otherwiseIdName,
plusIntegerName,
timesIntegerName,
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
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
plusIntegerIdKey = mkPreludeMiscIdUnique 41
timesIntegerIdKey = mkPreludeMiscIdUnique 42
printIdKey = mkPreludeMiscIdUnique 43
+failIOIdKey = mkPreludeMiscIdUnique 44
\end{code}
Certain class operations from Prelude classes. They get their own
\begin{code}
assertIdKey = mkPreludeMiscIdUnique 121
runSTRepIdKey = mkPreludeMiscIdUnique 122
+itIdKey = mkPreludeMiscIdUnique 123 -- "it" for the interactive interface
\end{code}
= 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}
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
\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,
)
import RnHiFiles ( readIface, removeContext, loadInterface,
loadExports, loadFixDecls, loadDeprecs,
- tryLoadInterface )
+ )
import RnEnv ( availsToNameSet, mkIfaceGlobalRdrEnv,
emptyAvailEnv, unitAvailEnv, availEnvElts,
plusAvailEnv, groupAvails, warnUnusedImports,
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
GlobalRdrEnv, GlobalRdrElt(..), pprGlobalRdrEnv,
AvailEnv, GenAvailInfo(..), AvailInfo, Avails,
Provenance(..), ImportReason(..), initialVersionInfo,
- Deprecations(..)
+ Deprecations(..),
+ LocalRdrEnv
)
import CmStaticInfo ( GhciMode(..) )
import List ( partition, nub )
-> 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
\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}
-> 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
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
mi_decls = panic "mi_decls"
}
- print_unqualified = unQualInScope gbl_env
is_exported name = name `elemNameSet` exported_names
exported_names = availsToNameSet export_avails
in
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}
)
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(..) )
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)
import HscTypes ( Provenance(..), pprNameProvenance, hasBetterProv,
ImportReason(..), GlobalRdrEnv, GlobalRdrElt(..), AvailEnv,
AvailInfo, Avails, GenAvailInfo(..), NameSupply(..),
- Deprecations(..), lookupDeprec
+ Deprecations(..), lookupDeprec,
+ extendLocalRdrEnv
)
import RnMonad
import Name ( Name,
boolTyConName, funTyConName,
unpackCStringName, unpackCStringFoldrName, unpackCStringUtf8Name,
eqStringName, printName,
- hasKey, fractionalClassKey, numClassKey
+ hasKey, fractionalClassKey, numClassKey,
+ bindIOName, returnIOName, failIOName
)
import TysWiredIn ( unitTyCon ) -- A little odd
import FiniteMap
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 ->
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 $
\begin{code}
module RnExpr (
- rnMatch, rnGRHSs, rnPat, rnExpr, rnExprs,
+ rnMatch, rnGRHSs, rnPat, rnExpr, rnExprs, rnStmt,
checkPrecMatch
) where
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}
%************************************************************************
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)
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_`
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}
%************************************************************************
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,
ModuleName, WhereFrom(..),
extendModuleEnv, mkVanillaModule
)
-import RdrName ( RdrName, rdrNameOcc )
+import RdrName ( rdrNameOcc )
import SrcLoc ( mkSrcLoc )
import Maybes ( maybeToBool, orElse )
import StringBuffer ( hGetStringBuffer )
= 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
import Type ( namesOfType )
import TyCon ( isSynTyCon, getSynTyConDefn )
import Name ( Name {-instance NamedThing-}, nameOccName,
- nameModule, isLocalName,
+ nameModule, isLocalName, isHomePackageName,
NamedThing(..)
)
import Name ( elemNameEnv, delFromNameEnv )
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 ->
PersistentRenamerState(..), Avails,
DeclsMap, IfaceInsts, IfaceRules,
HomeSymbolTable, TyThing,
- PersistentCompilerState(..), GlobalRdrEnv,
+ PersistentCompilerState(..), GlobalRdrEnv, LocalRdrEnv,
HomeIfaceTable, PackageIfaceTable,
RdrAvailInfo )
import BasicTypes ( Version, defaultFixity )
\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
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}
import HsSyn ( HsModule(..), HsDecl(..), IE(..), ieName, ImportDecl(..),
ForeignDecl(..), ForKind(..), isDynamicExtName,
- collectTopBinders
+ collectLocatedHsBinders
)
import RdrHsSyn ( RdrNameIE, RdrNameImportDecl,
RdrNameHsModule, RdrNameHsDecl
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
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 ->
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
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,
-- 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)
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 )
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
)
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
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,
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 )
{- 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
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
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}
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 ->
#include "HsVersions.h"
import HsSyn ( HsExpr(..), HsLit(..), ArithSeqInfo(..),
- StmtCtxt(..), mkMonoBind
+ HsMatchContext(..), mkMonoBind
)
import RnHsSyn ( RenamedHsExpr, RenamedRecordBinds )
import TcHsSyn ( TcExpr, TcRecordBinds, mkHsLet )
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 )
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}
\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}
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 )
import Maybes ( maybeToBool, orElse )
import Constants
import List ( partition, intersperse )
-import Outputable ( pprPanic, ppr, pprTrace )
#if __GLASGOW_HASKELL__ >= 404
import GlaExts ( fromInt )
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)
| 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.
-- re-exported from TcEnv
TcId,
- zonkTopBinds, zonkId, zonkIdOcc, zonkExpr,
+ zonkTopBinds, zonkId, zonkIdBndr, zonkIdOcc, zonkExpr,
zonkForeignExports, zonkRules
) where
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 $
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
)
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)]
1 tcGRHSs ::
RnHsSyn.RenamedGRHSs
-> TcMonad.TcType
- -> HsExpr.StmtCtxt
+ -> HsExpr.HsMatchContext
-> TcMonad.TcM (TcHsSyn.TcGRHSs, Inst.LIE) ;
1 tcMatchesFun ::
[(Name.Name,Var.Id)]
\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 )
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}
tcMatches :: [(Name,Id)]
-> [RenamedMatch]
-> TcType
- -> StmtCtxt
+ -> HsMatchContext
-> TcM ([TcMatch], LIE)
tcMatches xve matches expected_ty fun_or_case
-> 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
= 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
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]
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}
where
ppr_fun = ppr fun
-matchCtxt LambdaBody match
+matchCtxt LambdaExpr match
= hang (ptext SLIT("In the lambda expression"))
4 (pprMatch (True, empty) match)
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}
\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(..),
)
\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]
-- 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)
\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
iface_rules = [d | RuleD d <- decls, isIfaceRuleDecl d]
\end{code}
+
%************************************************************************
%* *
\subsection{Checking the type of main}
%************************************************************************
%* *
+\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}
%* *
%************************************************************************
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)
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 ->
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
printSDoc, printErrs, printDump,
printForC, printForAsm, printForIface, printForUser,
pprCode, pprCols,
- showSDoc, showSDocDebug, showSDocIface, showSDocUnqual, showsPrecSDoc,
+ showSDoc, showSDocForUser, showSDocDebug, showSDocIface,
+ showSDocUnqual, showsPrecSDoc,
pprHsChar, pprHsString,
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))
projects / ghc-hetmet.git / commitdiff