Commit 1c62b517 authored by simonmar's avatar simonmar

[project @ 2001-02-26 15:06:57 by simonmar]

Implement do-style bindings on the GHCi command line.

The syntax for a command-line is exactly that of a do statement, with
the following meanings:

  - `pat <- expr'
    performs expr, and binds each of the variables in pat.

  - `let pat = expr; ...'
    binds each of the variables in pat, doesn't do any evaluation

  - `expr'
    behaves as `it <- expr' if expr is IO-typed, or `let it = expr'
    followed by `print it' otherwise.
parent 8d0e6c63
......@@ -16,7 +16,7 @@ module IdInfo (
zapFragileInfo, zapLamInfo, zapSpecPragInfo, shortableIdInfo, copyIdInfo,
-- Flavour
IdFlavour(..), flavourInfo,
IdFlavour(..), flavourInfo, makeConstantFlavour,
setNoDiscardInfo, setFlavourInfo,
ppFlavourInfo,
......@@ -267,6 +267,18 @@ data IdFlavour
| RecordSelId FieldLabel -- The Id for a record selector
makeConstantFlavour :: IdFlavour -> IdFlavour
makeConstantFlavour flavour = new_flavour
where new_flavour = case flavour of
VanillaId -> ConstantId
ExportedId -> ConstantId
ConstantId -> ConstantId -- e.g. Default methods
DictFunId -> DictFunId
flavour -> pprTrace "makeConstantFlavour"
(ppFlavourInfo flavour)
flavour
ppFlavourInfo :: IdFlavour -> SDoc
ppFlavourInfo VanillaId = empty
ppFlavourInfo ExportedId = ptext SLIT("[Exported]")
......
......@@ -20,10 +20,11 @@ module Name (
toRdrName, hashName,
globaliseName, localiseName,
nameSrcLoc, nameIsLocallyDefined, isDllName, nameIsFrom, nameIsLocalOrFrom,
nameSrcLoc,
isSystemName, isLocalName, isGlobalName, isExternallyVisibleName,
isTyVarName,
isTyVarName, isDllName,
nameIsLocalOrFrom, isHomePackageName,
-- Environment
NameEnv, mkNameEnv,
......@@ -35,8 +36,7 @@ module Name (
-- Class NamedThing and overloaded friends
NamedThing(..),
getSrcLoc, getOccString, toRdrName,
isFrom, isLocalOrFrom
getSrcLoc, getOccString, toRdrName
) where
#include "HsVersions.h"
......@@ -121,26 +121,29 @@ nameModule_maybe name = Nothing
\end{code}
\begin{code}
nameIsLocallyDefined :: Name -> Bool
nameIsFrom :: Module -> Name -> Bool
nameIsLocalOrFrom :: Module -> Name -> Bool
isLocalName :: Name -> Bool -- Not globals
isGlobalName :: Name -> Bool
isSystemName :: Name -> Bool
isExternallyVisibleName :: Name -> Bool
isHomePackageName :: Name -> Bool
isGlobalName (Name {n_sort = Global _}) = True
isGlobalName other = False
isLocalName name = not (isGlobalName name)
nameIsLocallyDefined name = isLocalName name
nameIsLocalOrFrom from (Name {n_sort = Global mod}) = mod == from
nameIsLocalOrFrom from other = True
nameIsFrom from (Name {n_sort = Global mod}) = mod == from
nameIsFrom from other = pprPanic "nameIsFrom" (ppr other)
isHomePackageName (Name {n_sort = Global mod}) = isHomeModule mod
isHomePackageName other = True -- Local and system names
isDllName :: Name -> Bool -- Does this name refer to something in a different DLL?
isDllName nm = not opt_Static && not (isHomePackageName nm)
isTyVarName :: Name -> Bool
isTyVarName name = isTvOcc (nameOccName name)
-- Global names are by definition those that are visible
-- outside the module, *as seen by the linker*. Externally visible
......@@ -238,17 +241,6 @@ nameRdrName :: Name -> RdrName
-- and an unqualified name just for Locals
nameRdrName (Name { n_occ = occ, n_sort = Global mod }) = mkRdrOrig (moduleName mod) occ
nameRdrName (Name { n_occ = occ }) = mkRdrUnqual occ
isDllName :: Name -> Bool
-- Does this name refer to something in a different DLL?
isDllName nm = not opt_Static &&
not (isLocalName nm) && -- isLocalName test needed 'cos
not (isHomeModule (nameModule nm)) -- nameModule won't work on local names
isTyVarName :: Name -> Bool
isTyVarName name = isTvOcc (nameOccName name)
\end{code}
......@@ -390,13 +382,9 @@ class NamedThing a where
getSrcLoc :: NamedThing a => a -> SrcLoc
getOccString :: NamedThing a => a -> String
toRdrName :: NamedThing a => a -> RdrName
isFrom :: NamedThing a => Module -> a -> Bool
isLocalOrFrom :: NamedThing a => Module -> a -> Bool
getSrcLoc = nameSrcLoc . getName
getOccString = occNameString . getOccName
toRdrName = nameRdrName . getName
isFrom mod x = nameIsFrom mod (getName x)
isLocalOrFrom mod x = nameIsLocalOrFrom mod ( getName x)
\end{code}
......@@ -8,6 +8,7 @@ module CmLink ( Linkable(..), Unlinked(..),
filterModuleLinkables,
findModuleLinkable_maybe,
LinkResult(..),
updateClosureEnv,
link,
unload,
PersistentLinkerState{-abstractly!-}, emptyPLS,
......@@ -23,6 +24,7 @@ import CmTypes
import CmStaticInfo ( GhciMode(..) )
import Outputable ( SDoc )
import Digraph ( SCC(..), flattenSCC )
import Name ( Name )
import Module ( ModuleName )
import FiniteMap
import Outputable
......@@ -88,6 +90,11 @@ emptyPLS = return (PersistentLinkerState { closure_env = emptyFM,
emptyPLS = return (PersistentLinkerState {})
#endif
updateClosureEnv :: PersistentLinkerState -> [(Name,HValue)]
-> IO PersistentLinkerState
updateClosureEnv pls new_bindings
= return pls{ closure_env = addListToFM (closure_env pls) new_bindings }
-----------------------------------------------------------------------------
-- Unloading old objects ready for a new compilation sweep.
--
......
......@@ -4,12 +4,19 @@
\section[CompManager]{The Compilation Manager}
\begin{code}
module CompManager ( cmInit, cmLoadModule, cmUnload,
module CompManager (
cmInit, -- :: GhciMode -> IO CmState
cmLoadModule, -- :: CmState -> FilePath -> IO (CmState, [String])
cmUnload, -- :: CmState -> IO CmState
cmTypeOfName, -- :: CmState -> Name -> IO (Maybe String)
cmSetContext, -- :: CmState -> String -> IO CmState
cmGetContext, -- :: CmState -> IO String
#ifdef GHCI
cmGetExpr, cmRunExpr,
cmRunStmt, -- :: CmState -> DynFlags -> String -> IO (CmState, [Name])
#endif
CmState, emptyCmState -- abstract
)
CmState, emptyCmState -- abstract
)
where
#include "HsVersions.h"
......@@ -17,16 +24,19 @@ where
import CmLink
import CmTypes
import HscTypes
import RnEnv ( unQualInScope )
import Id ( idType, idName )
import Name ( Name, lookupNameEnv )
import RdrName ( emptyRdrEnv )
import Module ( Module, ModuleName, moduleName, isHomeModule,
mkModuleName, moduleNameUserString )
mkModuleName, moduleNameUserString, moduleUserString )
import CmStaticInfo ( GhciMode(..) )
import DriverPipeline
import GetImports
import HscTypes ( HomeSymbolTable, HomeIfaceTable,
PersistentCompilerState, ModDetails(..) )
import HscTypes
import HscMain ( initPersistentCompilerState )
import Finder
import UniqFM ( emptyUFM, lookupUFM, addToUFM, delListFromUFM,
import UniqFM ( lookupUFM, addToUFM, delListFromUFM,
UniqFM, listToUFM )
import Unique ( Uniquable )
import Digraph ( SCC(..), stronglyConnComp, flattenSCC )
......@@ -44,8 +54,7 @@ import IOExts
#ifdef GHCI
import Interpreter ( HValue )
import HscMain ( hscExpr )
import Type ( Type )
import HscMain ( hscStmt )
import PrelGHC ( unsafeCoerce# )
#endif
......@@ -63,43 +72,6 @@ import Maybe ( catMaybes, fromMaybe, isJust, fromJust )
\begin{code}
cmInit :: GhciMode -> IO CmState
cmInit gmode
= emptyCmState gmode
#ifdef GHCI
cmGetExpr :: CmState
-> DynFlags
-> Bool -- True <=> wrap in 'print' to get an IO-typed result
-> Module
-> String
-> IO (CmState, Maybe (HValue, PrintUnqualified, Type))
cmGetExpr cmstate dflags wrap_io mod expr
= do (new_pcs, maybe_stuff) <-
hscExpr dflags wrap_io hst hit pcs mod expr
case maybe_stuff of
Nothing -> return (cmstate{ pcs=new_pcs }, Nothing)
Just (bcos, print_unqual, ty) -> do
hValue <- linkExpr pls bcos
return (cmstate{ pcs=new_pcs },
Just (hValue, print_unqual, ty))
-- ToDo: check that the module we passed in is sane/exists?
where
CmState{ hst=hst, hit=hit, pcs=pcs, pls=pls } = cmstate
-- The HValue should represent a value of type IO () (Perhaps IO a?)
cmRunExpr :: HValue -> IO ()
cmRunExpr hval
= do unsafeCoerce# hval :: IO ()
-- putStrLn "done."
#endif
emptyHIT :: HomeIfaceTable
emptyHIT = emptyUFM
emptyHST :: HomeSymbolTable
emptyHST = emptyUFM
-- Persistent state for the entire system
data CmState
= CmState {
......@@ -108,23 +80,33 @@ data CmState
ui :: UnlinkedImage, -- the unlinked images
mg :: ModuleGraph, -- the module graph
gmode :: GhciMode, -- NEVER CHANGES
ic :: InteractiveContext, -- command-line binding info
pcs :: PersistentCompilerState, -- compile's persistent state
pls :: PersistentLinkerState -- link's persistent state
}
emptyCmState :: GhciMode -> IO CmState
emptyCmState gmode
emptyCmState :: GhciMode -> Module -> IO CmState
emptyCmState gmode mod
= do pcs <- initPersistentCompilerState
pls <- emptyPLS
return (CmState { hst = emptyHST,
hit = emptyHIT,
ui = emptyUI,
mg = emptyMG,
gmode = gmode,
return (CmState { hst = emptySymbolTable,
hit = emptyIfaceTable,
ui = emptyUI,
mg = emptyMG,
gmode = gmode,
ic = emptyInteractiveContext mod,
pcs = pcs,
pls = pls })
emptyInteractiveContext mod
= InteractiveContext { ic_module = mod,
ic_rn_env = emptyRdrEnv,
ic_type_env = emptyTypeEnv }
defaultCurrentModuleName = mkModuleName "Prelude"
GLOBAL_VAR(defaultCurrentModule, error "no defaultCurrentModule", Module)
-- CM internal types
type UnlinkedImage = [Linkable] -- the unlinked images (should be a set, really)
emptyUI :: UnlinkedImage
......@@ -134,12 +116,106 @@ type ModuleGraph = [ModSummary] -- the module graph, topologically sorted
emptyMG :: ModuleGraph
emptyMG = []
\end{code}
-----------------------------------------------------------------------------
-- Produce an initial CmState.
cmInit :: GhciMode -> IO CmState
cmInit mode = do
prel <- moduleNameToModule defaultCurrentModuleName
writeIORef defaultCurrentModule prel
emptyCmState mode prel
Unload the compilation manager's state: everything it knows about the
current collection of modules in the Home package.
-----------------------------------------------------------------------------
-- Setting the context doesn't throw away any bindings; the bindings
-- we've built up in the InteractiveContext simply move to the new
-- module. They always shadow anything in scope in the current context.
cmSetContext :: CmState -> String -> IO CmState
cmSetContext cmstate str
= do let mn = mkModuleName str
modules_loaded = [ (name_of_summary s, ms_mod s) | s <- mg cmstate ]
m <- case lookup mn modules_loaded of
Just m -> return m
Nothing -> do
mod <- moduleNameToModule mn
if isHomeModule mod
then throwDyn (OtherError (showSDoc
(quotes (ppr (moduleName mod))
<+> text "is not currently loaded")))
else return mod
return cmstate{ ic = (ic cmstate){ic_module=m} }
cmGetContext :: CmState -> IO String
cmGetContext cmstate = return (moduleUserString (ic_module (ic cmstate)))
moduleNameToModule :: ModuleName -> IO Module
moduleNameToModule mn
= do maybe_stuff <- findModule mn
case maybe_stuff of
Nothing -> throwDyn (OtherError ("can't find module `"
++ moduleNameUserString mn ++ "'"))
Just (m,_) -> return m
-----------------------------------------------------------------------------
-- cmRunStmt: Run a statement/expr.
#ifdef GHCI
cmRunStmt :: CmState -> DynFlags -> String -> IO (CmState, [Name])
cmRunStmt cmstate dflags expr
= do (new_pcs, maybe_stuff) <- hscStmt dflags hst hit pcs (ic cmstate) expr
case maybe_stuff of
Nothing -> return (cmstate{ pcs=new_pcs }, [])
Just (new_ic, ids, bcos) -> do
hval <- linkExpr pls bcos
hvals <- unsafeCoerce# hval :: IO [HValue]
let names = map idName ids
new_pls <- updateClosureEnv pls (zip names hvals)
return (cmstate{ pcs=new_pcs, pls=new_pls, ic=new_ic }, names)
-- ToDo: check that the module we passed in is sane/exists?
where
CmState{ hst=hst, hit=hit, pcs=pcs, pls=pls } = cmstate
#endif
-----------------------------------------------------------------------------
-- cmTypeOf: returns a string representing the type of a name.
cmTypeOfName :: CmState -> Name -> IO (Maybe String)
cmTypeOfName CmState{ hit=hit, pcs=pcs, ic=ic } name
= case lookupNameEnv (ic_type_env ic) name of
Nothing -> return Nothing
Just (AnId id) ->
let pit = pcs_PIT pcs
modname = moduleName (ic_module ic)
str = case lookupIfaceByModName hit pit modname of
Nothing -> showSDoc (ppr (idType id))
Just iface -> showSDocForUser unqual (ppr (idType id))
where unqual = unQualInScope (mi_globals iface)
in return (Just str)
_ -> panic "cmTypeOfName"
-----------------------------------------------------------------------------
-- cmInfo: return "info" about an expression. The info might be:
--
-- * its type, for an expression,
-- * the class definition, for a class
-- * the datatype definition, for a tycon (or synonym)
-- * the export list, for a module
--
-- Can be used to find the type of the last expression compiled, by looking
-- for "it".
cmInfo :: CmState -> String -> IO (Maybe String)
cmInfo cmstate str
= do error "cmInfo not implemented yet"
-----------------------------------------------------------------------------
-- Unload the compilation manager's state: everything it knows about the
-- current collection of modules in the Home package.
\begin{code}
cmUnload :: CmState -> IO CmState
cmUnload state
= do -- Throw away the old home dir cache
......@@ -149,18 +225,17 @@ cmUnload state
where
CmState{ hst=hst, hit=hit } = state
(new_hst, new_hit) = retainInTopLevelEnvs [] (hst,hit)
\end{code}
The real business of the compilation manager: given a system state and
a module name, try and bring the module up to date, probably changing
the system state at the same time.
-----------------------------------------------------------------------------
-- The real business of the compilation manager: given a system state and
-- a module name, try and bring the module up to date, probably changing
-- the system state at the same time.
\begin{code}
cmLoadModule :: CmState
-> FilePath
-> IO (CmState, -- new state
Bool, -- was successful
[Module]) -- list of modules loaded
[String]) -- list of modules loaded
cmLoadModule cmstate1 rootname
= do -- version 1's are the original, before downsweep
......@@ -172,6 +247,7 @@ cmLoadModule cmstate1 rootname
-- the previous pass, if any.
let ui1 = ui cmstate1
let mg1 = mg cmstate1
let ic1 = ic cmstate1
let ghci_mode = gmode cmstate1 -- this never changes
......@@ -228,7 +304,7 @@ cmLoadModule cmstate1 rootname
valid_linkables
when (verb >= 2) $
putStrLn (showSDoc (text "STABLE MODULES:"
putStrLn (showSDoc (text "Stable modules:"
<+> sep (map (text.moduleNameUserString) stable_mods)))
-- unload any modules which aren't going to be re-linked this
......@@ -289,19 +365,11 @@ cmLoadModule cmstate1 rootname
-- clean up after ourselves
cleanTempFilesExcept verb (ppFilesFromSummaries modsDone)
linkresult
<- link ghci_mode dflags a_root_is_Main ui3 pls2
case linkresult of
LinkErrs _ _
-> panic "cmLoadModule: link failed (1)"
LinkOK pls3
-> do let cmstate3
= CmState { hst=hst3, hit=hit3,
ui=ui3, mg=modsDone,
gmode=ghci_mode,
pcs=pcs3, pls=pls3 }
return (cmstate3, True,
map ms_mod modsDone)
-- link everything together
linkresult <- link ghci_mode dflags a_root_is_Main ui3 pls2
cmLoadFinish True linkresult
hst3 hit3 ui3 modsDone ghci_mode pcs3
else
-- Tricky. We need to back out the effects of compiling any
......@@ -313,34 +381,50 @@ cmLoadModule cmstate1 rootname
let modsDone_names
= map name_of_summary modsDone
let mods_to_zap_names
= findPartiallyCompletedCycles modsDone_names mg2_with_srcimps
let (hst4, hit4, ui4)
= findPartiallyCompletedCycles modsDone_names
mg2_with_srcimps
let (hst4, hit4, ui4)
= removeFromTopLevelEnvs mods_to_zap_names (hst3,hit3,ui3)
let mods_to_keep
= filter ((`notElem` mods_to_zap_names).name_of_summary) modsDone
let mods_to_keep_names
= map name_of_summary mods_to_keep
-- we could get the relevant linkables by filtering newLis, but
-- it seems easier to drag them out of the updated, cleaned-up UI
let linkables_to_link
= map (unJust "linkables_to_link" . findModuleLinkable_maybe ui4)
mods_to_keep_names
= filter ((`notElem` mods_to_zap_names).name_of_summary)
modsDone
-- clean up after ourselves
cleanTempFilesExcept verb (ppFilesFromSummaries mods_to_keep)
linkresult <- link ghci_mode dflags False linkables_to_link pls2
case linkresult of
LinkErrs _ _
-> panic "cmLoadModule: link failed (2)"
LinkOK pls3
-> do let cmstate4
= CmState { hst=hst4, hit=hit4,
ui=ui4, mg=mods_to_keep,
gmode=ghci_mode, pcs=pcs3, pls=pls3 }
return (cmstate4, False,
map ms_mod mods_to_keep)
-- link everything together
linkresult <- link ghci_mode dflags False ui4 pls2
cmLoadFinish False linkresult
hst4 hit4 ui4 mods_to_keep ghci_mode pcs3
-- Finish up after a cmLoad.
--
-- Empty the interactive context and set the module context to the topmost
-- newly loaded module, or the Prelude if none were loaded.
cmLoadFinish ok linkresult hst hit ui mods ghci_mode pcs
= do case linkresult of {
LinkErrs _ _ -> panic "cmLoadModule: link failed (2)";
LinkOK pls -> do
def_mod <- readIORef defaultCurrentModule
let current_mod = case mods of
[] -> def_mod
(x:_) -> ms_mod x
new_ic = emptyInteractiveContext current_mod
new_cmstate = CmState{ hst=hst, hit=hit,
ui=ui, mg=mods,
gmode=ghci_mode, pcs=pcs,
pls=pls,
ic = new_ic }
mods_loaded = map (moduleNameUserString.name_of_summary) mods
return (new_cmstate, ok, mods_loaded)
}
ppFilesFromSummaries summaries
= [ fn | Just fn <- map (ml_hspp_file . ms_location) summaries ]
......
......@@ -387,16 +387,9 @@ tidyIdInfo us tidy_env is_external unfold_info arity_info caf_info id
-- after this!).
where
core_idinfo = idInfo id
new_flavour = makeConstantFlavour (flavourInfo core_idinfo)
-- A DFunId must stay a DFunId, so that we can gather the
-- DFunIds up later. Other local things become ConstantIds.
new_flavour = case flavourInfo core_idinfo of
VanillaId -> ConstantId
ExportedId -> ConstantId
ConstantId -> ConstantId -- e.g. Default methods
DictFunId -> DictFunId
flavour -> pprTrace "tidyIdInfo" (ppr id <+> ppFlavourInfo flavour)
flavour
-- This is where we set names to local/global based on whether they really are
......
......@@ -78,8 +78,8 @@ dsMonoBinds _ (VarMonoBind var expr) rest
dsMonoBinds auto_scc (FunMonoBind fun _ matches locn) rest
= putSrcLocDs locn $
matchWrapper (FunMatch fun) matches error_string `thenDs` \ (args, body) ->
addAutoScc auto_scc (fun, mkLams args body) `thenDs` \ pair ->
matchWrapper (FunRhs (idName fun)) matches error_string `thenDs` \ (args, body) ->
addAutoScc auto_scc (fun, mkLams args body) `thenDs` \ pair ->
returnDs (pair : rest)
where
error_string = "function " ++ showSDoc (ppr fun)
......
......@@ -11,8 +11,8 @@ module DsExpr ( dsExpr, dsLet ) where
import HsSyn ( failureFreePat,
HsExpr(..), OutPat(..), HsLit(..), ArithSeqInfo(..),
Stmt(..), StmtCtxt(..), Match(..), HsBinds(..), MonoBinds(..),
mkSimpleMatch
Stmt(..), HsMatchContext(..), Match(..), HsBinds(..), MonoBinds(..),
mkSimpleMatch, isDoExpr
)
import TcHsSyn ( TypecheckedHsExpr, TypecheckedHsBinds,
TypecheckedStmt
......@@ -95,7 +95,7 @@ dsLet (MonoBind (AbsBinds [] [] binder_triples inlines
in
mkErrorAppDs iRREFUT_PAT_ERROR_ID result_ty (showSDoc (ppr pat))
`thenDs` \ error_expr ->
matchSimply rhs PatBindMatch pat body' error_expr
matchSimply rhs PatBindRhs pat body' error_expr
where
result_ty = exprType body
......@@ -122,7 +122,7 @@ dsExpr (HsLit lit) = dsLit lit
-- HsOverLit has been gotten rid of by the type checker
dsExpr expr@(HsLam a_Match)
= matchWrapper LambdaMatch [a_Match] "lambda" `thenDs` \ (binders, matching_code) ->
= matchWrapper LambdaExpr [a_Match] "lambda" `thenDs` \ (binders, matching_code) ->
returnDs (mkLams binders matching_code)
dsExpr expr@(HsApp fun arg)
......@@ -203,8 +203,8 @@ dsExpr (HsSCC cc expr)
dsExpr (HsCase discrim matches src_loc)
| all ubx_tuple_match matches
= putSrcLocDs src_loc $
dsExpr discrim `thenDs` \ core_discrim ->
matchWrapper CaseMatch matches "case" `thenDs` \ ([discrim_var], matching_code) ->
dsExpr discrim `thenDs` \ core_discrim ->
matchWrapper CaseAlt matches "case" `thenDs` \ ([discrim_var], matching_code) ->
case matching_code of
Case (Var x) bndr alts | x == discrim_var ->
returnDs (Case core_discrim bndr alts)
......@@ -215,8 +215,8 @@ dsExpr (HsCase discrim matches src_loc)
dsExpr (HsCase discrim matches src_loc)
= putSrcLocDs src_loc $
dsExpr discrim `thenDs` \ core_discrim ->
matchWrapper CaseMatch matches "case" `thenDs` \ ([discrim_var], matching_code) ->
dsExpr discrim `thenDs` \ core_discrim ->
matchWrapper CaseAlt matches "case" `thenDs` \ ([discrim_var], matching_code) ->
returnDs (bindNonRec discrim_var core_discrim matching_code)
dsExpr (HsLet binds body)
......@@ -248,8 +248,8 @@ dsExpr (HsDoOut do_or_lc stmts return_id then_id fail_id result_ty src_loc)
-> Just elt_ty
other -> Nothing
-- We need the ListComp form to use deListComp (rather than the "do" form)
-- because the "return" in a do block is a call to "PrelBase.return", and
-- not a ReturnStmt. Only the ListComp form has ReturnStmts
-- because the interpretation of ExprStmt depends on what sort of thing
-- it is.
Just elt_ty = maybe_list_comp
......@@ -430,8 +430,8 @@ dsExpr (RecordUpdOut record_expr record_out_ty dicts rbinds)
-- and the right hand sides with applications of the wrapper Id
-- so that everything works when we are doing fancy unboxing on the
-- constructor aguments.
mapDs mk_alt cons_to_upd `thenDs` \ alts ->
matchWrapper RecUpdMatch alts "record update" `thenDs` \ ([discrim_var], matching_code) ->
mapDs mk_alt cons_to_upd `thenDs` \ alts ->
matchWrapper RecUpd alts "record update" `thenDs` \ ([discrim_var], matching_code) ->
returnDs (bindNonRec discrim_var record_expr' matching_code)
......@@ -490,7 +490,7 @@ dsExpr (ArithSeqIn _) = panic "dsExpr:ArithSeqIn"
Basically does the translation given in the Haskell~1.3 report:
\begin{code}
dsDo :: StmtCtxt
dsDo :: HsMatchContext
-> [TypecheckedStmt]
-> Id -- id for: return m
-> Id -- id for: (>>=) m
......@@ -502,34 +502,36 @@ dsDo do_or_lc stmts return_id then_id fail_id result_ty
= let
(_, b_ty) = splitAppTy result_ty -- result_ty must be of the form (m b)
go [ReturnStmt expr]
= dsExpr expr `thenDs` \ expr2 ->
returnDs (mkApps (Var return_id) [Type b_ty, expr2])
go (GuardStmt expr locn : stmts)
= do_expr expr locn `thenDs` \ expr2 ->
go stmts `thenDs` \ rest ->
let msg = "Pattern match failure in do expression, " ++ showSDoc (ppr locn)
in
mkStringLit msg `thenDs` \ core_msg ->