From: Simon Marlow Date: Mon, 5 Jul 2010 10:45:57 +0000 (+0000) Subject: refactor import declaration support (#2362) X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=commitdiff_plain;h=0f84e2ce427b68295d057cb1ce2cab8f8d12742d refactor import declaration support (#2362) --- diff --git a/ghc/GhciMonad.hs b/ghc/GhciMonad.hs index 88c8caa..f1859d7 100644 --- a/ghc/GhciMonad.hs +++ b/ghc/GhciMonad.hs @@ -69,7 +69,7 @@ data GHCiState = GHCiState -- remember is here: last_command :: Maybe Command, cmdqueue :: [String], - remembered_ctx :: [Either (CtxtCmd, [String], [String]) String], + remembered_ctx :: [CtxtCmd], -- we remember the :module commands between :loads, so that -- on a :reload we can replay them. See bugs #2049, -- \#1873, #1360. Previously we tried to remember modules that @@ -80,9 +80,10 @@ data GHCiState = GHCiState } data CtxtCmd - = SetContext - | AddModules - | RemModules + = SetContext [String] [String] + | AddModules [String] [String] + | RemModules [String] [String] + | Import String type TickArray = Array Int [(BreakIndex,SrcSpan)] @@ -257,10 +258,6 @@ runStmt expr step = do return GHC.RunFailed) $ do GHC.runStmt expr step -parseImportDecl :: GhcMonad m => String -> m (Maybe (GHC.ImportDecl GHC.RdrName)) -parseImportDecl expr - = GHC.handleSourceError (\e -> GHC.printExceptionAndWarnings e >> return Nothing) (Monad.liftM Just (GHC.parseImportDecl expr)) - resume :: (SrcSpan -> Bool) -> GHC.SingleStep -> GHCi GHC.RunResult resume canLogSpan step = do st <- getGHCiState diff --git a/ghc/InteractiveUI.hs b/ghc/InteractiveUI.hs index a62e10d..6b8f984 100644 --- a/ghc/InteractiveUI.hs +++ b/ghc/InteractiveUI.hs @@ -643,8 +643,10 @@ enqueueCommands cmds = do runStmt :: String -> SingleStep -> GHCi Bool runStmt stmt step - | null (filter (not.isSpace) stmt) = return False - | x@('i':'m':'p':'o':'r':'t':' ':_) <- stmt = keepGoing' (importContext True) x + | null (filter (not.isSpace) stmt) + = return False + | "import " `isPrefixOf` stmt + = do newContextCmd (Import stmt); return False | otherwise = do #if __GLASGOW_HASKELL__ >= 611 @@ -1134,10 +1136,7 @@ setContextKeepingPackageModules prev_context keep_ctxt (as,bs) = do if keep_ctxt then do st <- getGHCiState - let mem = remembered_ctx st - playCmd (Left x) = playCtxtCmd False x - playCmd (Right x) = importContext False x - mapM_ playCmd mem + mapM_ (playCtxtCmd False) (remembered_ctx st) else do st <- getGHCiState setGHCiState st{ remembered_ctx = [] } @@ -1294,39 +1293,25 @@ browseModule bang modl exports_only = do ----------------------------------------------------------------------------- -- Setting the module context -importContext :: Bool -> String -> GHCi () -importContext fail str - = do - (as,bs) <- GHC.getContext - x <- do_checks fail - case Monad.join x of - Nothing -> return () - (Just a) -> do - m <- loadModuleName a - GHC.setContext as (bs++[(m,Just a)]) - st <- getGHCiState - let cmds = remembered_ctx st - setGHCiState st{ remembered_ctx = cmds++[Right str] } - where - do_checks True = liftM Just (GhciMonad.parseImportDecl str) - do_checks False = trymaybe (GhciMonad.parseImportDecl str) +newContextCmd :: CtxtCmd -> GHCi () +newContextCmd cmd = do + playCtxtCmd True cmd + st <- getGHCiState + let cmds = remembered_ctx st + setGHCiState st{ remembered_ctx = cmds ++ [cmd] } setContext :: String -> GHCi () setContext str - | all sensible strs = do - playCtxtCmd True (cmd, as, bs) - st <- getGHCiState - let cmds = remembered_ctx st - setGHCiState st{ remembered_ctx = cmds ++ [Left (cmd,as,bs)] } + | all sensible strs = newContextCmd cmd | otherwise = ghcError (CmdLineError "syntax: :module [+/-] [*]M1 ... [*]Mn") where - (cmd, strs, as, bs) = + (cmd, strs) = case str of '+':stuff -> rest AddModules stuff '-':stuff -> rest RemModules stuff stuff -> rest SetContext stuff - rest cmd stuff = (cmd, strs, as, bs) + rest cmd stuff = (cmd as bs, strs) where strs = words stuff (as,bs) = partitionWith starred strs @@ -1336,38 +1321,51 @@ setContext str starred ('*':m) = Left m starred m = Right m -playCtxtCmd :: Bool -> (CtxtCmd, [String], [String]) -> GHCi () -playCtxtCmd fail (cmd, as, bs) - = do - (as',bs') <- do_checks fail +playCtxtCmd:: Bool -> CtxtCmd -> GHCi () +playCtxtCmd fail cmd = do (prev_as,prev_bs) <- GHC.getContext - (new_as, new_bs) <- - case cmd of - SetContext -> do + case cmd of + SetContext as bs -> do + (as',bs') <- do_checks as bs prel_mod <- getPrelude - let bs'' = if null as && prel_mod `notElem` (map fst bs') then (prel_mod,Nothing):bs' - else bs' - return (as', bs'') - AddModules -> do + let bs'' = if null as && prel_mod `notElem` (map fst bs') + then (prel_mod,Nothing):bs' + else bs' + GHC.setContext as' bs'' + + AddModules as bs -> do + (as',bs') <- do_checks as bs -- it should replace the old stuff, not the other way around -- need deleteAllBy, not deleteFirstsBy for sameFst let remaining_as = prev_as \\ (as' ++ map fst bs') remaining_bs = deleteAllBy sameFst prev_bs (bs' ++ map contextualize as') - return (remaining_as ++ as', remaining_bs ++ bs') - RemModules -> do + GHC.setContext (remaining_as ++ as') (remaining_bs ++ bs') + + RemModules as bs -> do + (as',bs') <- do_checks as bs let new_as = prev_as \\ (as' ++ map fst bs') new_bs = deleteAllBy sameFst prev_bs (map contextualize as' ++ bs') - return (new_as, new_bs) - GHC.setContext new_as new_bs + GHC.setContext new_as new_bs + + Import str -> do + m_idecl <- maybe_fail $ GHC.parseImportDecl str + case m_idecl of + Nothing -> return () + Just idecl -> do + m_mdl <- maybe_fail $ loadModuleName idecl + case m_mdl of + Nothing -> return () + Just m -> GHC.setContext prev_as (prev_bs ++ [(m, Just idecl)]) + where - do_checks True = do - as' <- mapM wantInterpretedModule as - bs' <- mapM lookupModule bs - return (as', map contextualize bs') - do_checks False = do - as' <- mapM (trymaybe . wantInterpretedModule) as - bs' <- mapM (trymaybe . lookupModule) bs - return (catMaybes as', map contextualize (catMaybes bs')) + maybe_fail | fail = liftM Just + | otherwise = trymaybe + + do_checks as bs = do + as' <- mapM (maybe_fail . wantInterpretedModule) as + bs' <- mapM (maybe_fail . lookupModule) bs + return (catMaybes as', map contextualize (catMaybes bs')) + contextualize x = (x,Nothing) deleteAllBy f a b = filter (\x->(not (any (f x) b))) a