refactor import declaration support (#2362)

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

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