uniques <- liftM uniqsFromSupply (mkSplitUniqSupply 'q')
return$ map (\u-> (mkSysTvName u (mkFastString "a"))) uniques
mb_ids <- io$ mapM (cleanUp cms newvarsNames) (words str)
- new_ids <- mapM (io . go cms) (catMaybes mb_ids)
- io$ updateIds cms new_ids
+ mb_new_ids <- mapM (io . go cms) (catMaybes mb_ids)
+ io$ updateIds cms (catMaybes mb_new_ids)
where
-- Find the Id, clean up 'Unknowns'
cleanUp :: Session -> [Name] -> String -> IO (Maybe Id)
-- Do the obtainTerm--bindSuspensions-refineIdType dance
-- Warning! This function got a good deal of side-effects
- go :: Session -> Id -> IO Id
+ go :: Session -> Id -> IO (Maybe Id)
go cms id = do
- Just term <- obtainTerm cms force id
- term' <- if not bindThings then return term
- else bindSuspensions cms term
- showterm <- pprTerm cms term'
- unqual <- GHC.getPrintUnqual cms
- let showSDocForUserOneLine unqual doc =
- showDocWith LeftMode (doc (mkErrStyle unqual))
- (putStrLn . showSDocForUserOneLine unqual) (ppr id <+> char '=' <+> showterm)
+ mb_term <- obtainTerm cms force id
+ maybe (return Nothing) `flip` mb_term $ \term -> do
+ term' <- if not bindThings then return term
+ else bindSuspensions cms term
+ showterm <- pprTerm cms term'
+ unqual <- GHC.getPrintUnqual cms
+ let showSDocForUserOneLine unqual doc =
+ showDocWith LeftMode (doc (mkErrStyle unqual))
+ (putStrLn . showSDocForUserOneLine unqual) (ppr id <+> char '=' <+> showterm)
-- Before leaving, we compare the type obtained to see if it's more specific
-- Note how we need the Unknown-clear type returned by obtainTerm
- let Just reconstructedType = termType term
- new_type <- instantiateTyVarsToUnknown cms
- (mostSpecificType (idType id) reconstructedType)
- return (setIdType id new_type)
+ let Just reconstructedType = termType term
+ new_type <- instantiateTyVarsToUnknown cms
+ (mostSpecificType (idType id) reconstructedType)
+ return . Just $ setIdType id new_type
updateIds :: Session -> [Id] -> IO ()
updateIds (Session ref) new_ids = do
-- | The inverse function. Strip the GHC.Base.Unknowns in the type of the id, they correspond to tyvars. The caller must provide an infinite list of fresh names
stripUnknowns :: [Name] -> Id -> Id
-stripUnknowns names id = setIdType id . sigmaType . fst . go names . idType
+stripUnknowns names id = setIdType id . fst . go names . idType
$ id
where
go tyvarsNames@(v:vv) ty
io$ putStrLn msg
bkptOptions' s ("add":cmds) bt
+ | [line] <- cmds
+ , [(lineNum,[])] <- reads line
+ = do (toplevel,_) <- io$ GHC.getContext s
+ case toplevel of
+ (m:_) -> handleAdd (\mod->addBkptByLine mod lineNum) m
+ [] -> throwDyn $ CmdLineError $ "No module loaded in debugging mode"
+
| [mod_name,line]<- cmds
, [(lineNum,[])] <- reads line
- = handleAdd mod_name $ (\mod->addBkptByLine mod lineNum)
+ = io(GHC.findModule s (GHC.mkModuleName mod_name) Nothing) >>=
+ handleAdd (\mod->addBkptByLine mod lineNum)
| [mod_name,line,col] <- cmds
- = handleAdd mod_name $ (\mod->addBkptByCoord mod (read line, read col))
+ = io(GHC.findModule s (GHC.mkModuleName mod_name) Nothing) >>=
+ handleAdd (\mod->addBkptByCoord mod (read line, read col))
| otherwise = throwDyn $ CmdLineError $
"syntax: :breakpoint add Module line [col]"
where
- handleAdd mod_name f = do
- mod <- io$ GHC.findModule s (GHC.mkModuleName mod_name) Nothing
+ handleAdd f mod =
either
(handleBkptEx s mod)
(\(newTable, site) -> do
- setBkptTable newTable
- io (putStrLn ("Breakpoint set at " ++
- show (getSiteCoords newTable mod site))))
+ setBkptTable newTable
+ let (x,y) = getSiteCoords newTable mod site
+ io (putStrLn ("Breakpoint set at " ++ showSDoc (ppr mod)
+ ++ ':' : show x ++ ':' : show y)))
(f mod bt)
bkptOptions' s ("del":cmds) bt
= handleDel mod $ delBkptByCoord mod (lineNum, colNum)
| otherwise = throwDyn $ CmdLineError $
- "syntax: :breakpoint del (breakpoint # | Module line [col])"
+ "syntax: :breakpoint del (breakpoint # | [Module] line [col])"
where delMsg = "Breakpoint deleted"
handleDel mod f = either (handleBkptEx s mod)
(\newtable-> setBkptTable newtable >> io (putStrLn delMsg))
(f bt)
-
bkptOptions' _ _ _ = throwDyn $ CmdLineError $
"syntax: :breakpoint (list|continue|stop|add|del)"
-- Error messages
-- handleBkptEx :: Session -> Module -> Debugger.BkptException -> a
- handleBkptEx s m NotHandled = io$
- findModSummary m >>= \mod_summary ->
- isModuleInterpreted s mod_summary >>= \it ->
- if it
+ handleBkptEx s m NotHandled = io$ do
+ isInterpreted <- findModSummary m >>= isModuleInterpreted s
+ if isInterpreted
then error$ "Module " ++ showSDoc (ppr m) ++ " was not loaded under debugging mode.\n"
++ "Enable debugging mode with -fdebugging (and reload your module)"
else error$ "Module " ++ showSDoc (ppr m) ++ " was loaded in compiled (.o) mode.\n"
++ "You must load a module in interpreted mode and with -fdebugging on to debug it."
- where findModSummary m = getModuleGraph s >>= \mod_graph ->
- case [ modsum | modsum <- mod_graph
- , ms_mod modsum == m ] of
- [modsum] -> return modsum
+ where findModSummary m = do
+ mod_graph <- getModuleGraph s
+ return$ head [ modsum | modsum <- mod_graph, ms_mod modsum == m]
handleBkptEx _ _ e = error (show e)
-------------------------