Adding pushing of hpc translation status through hi files.

[ghc-hetmet.git] / compiler / ghci / InteractiveUI.hs

diff --git a/compiler/ghci/InteractiveUI.hs b/compiler/ghci/InteractiveUI.hs
index 4494f22..169168f 100644 (file)
--- a/compiler/ghci/InteractiveUI.hs
+++ b/compiler/ghci/InteractiveUI.hs
@@ -6,7 +6,7 @@
 -- (c) The GHC Team 2005-2006
 --
 -----------------------------------------------------------------------------
-module InteractiveUI ( interactiveUI ) where
+module InteractiveUI ( interactiveUI, ghciWelcomeMsg ) where
 
 #include "HsVersions.h"
 
@@ -81,16 +81,9 @@ import System.Posix.Internals ( setNonBlockingFD )
 
 -----------------------------------------------------------------------------
 
-ghciWelcomeMsg =
- "   ___         ___ _\n"++
- "  / _ \\ /\\  /\\/ __(_)\n"++
- " / /_\\// /_/ / /  | |    GHC Interactive, version " ++ cProjectVersion ++ ", for Haskell 98.\n"++
- "/ /_\\\\/ __  / /___| |    http://www.haskell.org/ghc/\n"++
- "\\____/\\/ /_/\\____/|_|    Type :? for help.\n"
-
-ghciShortWelcomeMsg =
-    "GHCi, version " ++ cProjectVersion ++
-    ": http://www.haskell.org/ghc/  :? for help"
+ghciWelcomeMsg :: String
+ghciWelcomeMsg = "GHCi, version " ++ cProjectVersion ++
+                 ": http://www.haskell.org/ghc/  :? for help"
 
 type Command = (String, String -> GHCi Bool, Bool, String -> IO [String])
 cmdName (n,_,_,_) = n
@@ -366,11 +359,6 @@ runGHCi paths maybe_expr = do
             -- initialise the console if necessary
             io setUpConsole
 
-            let msg = if dopt Opt_ShortGhciBanner dflags
-                      then ghciShortWelcomeMsg
-                      else ghciWelcomeMsg
-            when (verbosity dflags >= 1) $ io $ putStrLn msg
-
             -- enter the interactive loop
             interactiveLoop is_tty show_prompt
         Just expr -> do
@@ -611,9 +599,11 @@ runBreakCmd info = do
 
 printTypeOfNames :: Session -> [Name] -> GHCi ()
 printTypeOfNames session names
- = mapM_ (printTypeOfName session) $ sortBy compareFun names
+ = mapM_ (printTypeOfName session) $ sortBy compareNames names
+
+compareNames :: Name -> Name -> Ordering
+n1 `compareNames` n2 = compareWith n1 `compare` compareWith n2
     where compareWith n = (getOccString n, getSrcSpan n)
-          compareFun n1 n2 = compareWith n1 `compare` compareWith n2
 
 printTypeOfName :: Session -> Name -> GHCi ()
 printTypeOfName session n
@@ -638,7 +628,7 @@ lookupCommand str = do
   -- look for exact match first, then the first prefix match
   case [ c | c <- cmds, str == cmdName c ] of
      c:_ -> return (Just c)
-     [] -> case [ c | c@(s,_,_,_) <- cmds, prefixMatch str s ] of
+     [] -> case [ c | c@(s,_,_,_) <- cmds, str `isPrefixOf` s ] of
                [] -> return Nothing
                c:_ -> return (Just c)
 
@@ -673,17 +663,17 @@ info "" = throwDyn (CmdLineError "syntax: ':i <thing-you-want-info-about>'")
 info s  = do { let names = words s
             ; session <- getSession
             ; dflags <- getDynFlags
-            ; let exts = dopt Opt_GlasgowExts dflags
-            ; mapM_ (infoThing exts session) names }
+            ; let pefas = dopt Opt_PrintExplicitForalls dflags
+            ; mapM_ (infoThing pefas session) names }
   where
-    infoThing exts session str = io $ do
+    infoThing pefas session str = io $ do
        names <- GHC.parseName session str
        let filtered = filterOutChildren names
        mb_stuffs <- mapM (GHC.getInfo session) filtered
        unqual <- GHC.getPrintUnqual session
        putStrLn (showSDocForUser unqual $
                   vcat (intersperse (text "") $
-                  [ pprInfo exts stuff | Just stuff <-  mb_stuffs ]))
+                  [ pprInfo pefas stuff | Just stuff <-  mb_stuffs ]))
 
   -- Filter out names whose parent is also there Good
   -- example is '[]', which is both a type and data
@@ -695,8 +685,9 @@ filterOutChildren names = filter (not . parent_is_there) names
 -- ToDo!!
         | otherwise                       = False
 
-pprInfo exts (thing, fixity, insts)
-  =  pprTyThingInContextLoc exts thing 
+pprInfo :: PrintExplicitForalls -> (TyThing, Fixity, [GHC.Instance]) -> SDoc
+pprInfo pefas (thing, fixity, insts)
+  =  pprTyThingInContextLoc pefas thing
   $$ show_fixity fixity
   $$ vcat (map GHC.pprInstance insts)
   where
@@ -863,7 +854,7 @@ checkModule :: String -> GHCi ()
 checkModule m = do
   let modl = GHC.mkModuleName m
   session <- getSession
-  result <- io (GHC.checkModule session modl)
+  result <- io (GHC.checkModule session modl False)
   case result of
     Nothing -> io $ putStrLn "Nothing"
     Just r  -> io $ putStrLn (showSDoc (
@@ -1010,9 +1001,9 @@ browseModule m exports_only = do
         things <- io $ mapM (GHC.lookupName s) filtered
 
         dflags <- getDynFlags
-       let exts = dopt Opt_GlasgowExts dflags
+       let pefas = dopt Opt_PrintExplicitForalls dflags
        io (putStrLn (showSDocForUser unqual (
-               vcat (map (pprTyThingInContext exts) (catMaybes things))
+               vcat (map (pprTyThingInContext pefas) (catMaybes things))
           )))
        -- ToDo: modInfoInstances currently throws an exception for
        -- package modules.  When it works, we can do this:
@@ -1258,9 +1249,12 @@ showBindings = do
   s <- getSession
   unqual <- io (GHC.getPrintUnqual s)
   bindings <- io (GHC.getBindings s)
-  mapM_ printTyThing bindings
+  mapM_ printTyThing $ sortBy compareTyThings bindings
   return ()
 
+compareTyThings :: TyThing -> TyThing -> Ordering
+t1 `compareTyThings` t2 = getName t1 `compareNames` getName t2
+
 printTyThing :: TyThing -> GHCi ()
 printTyThing (AnId id) = do
   ty' <- cleanType (GHC.idType id)
@@ -1271,7 +1265,7 @@ printTyThing _ = return ()
 cleanType :: Type -> GHCi Type
 cleanType ty = do
   dflags <- getDynFlags
-  if dopt Opt_GlasgowExts dflags 
+  if dopt Opt_PrintExplicitForalls dflags 
        then return ty
        else return $! GHC.dropForAlls ty
 
@@ -1648,14 +1642,17 @@ breakByModule :: Session -> Module -> [String] -> GHCi ()
 breakByModule session mod args@(arg1:rest)
    | all isDigit arg1 = do  -- looks like a line number
         breakByModuleLine mod (read arg1) rest
-   | otherwise = io $ putStrLn "Invalid arguments to :break"
+breakByModule session mod _
+   = breakSyntax
 
 breakByModuleLine :: Module -> Int -> [String] -> GHCi ()
 breakByModuleLine mod line args
    | [] <- args = findBreakAndSet mod $ findBreakByLine line
    | [col] <- args, all isDigit col =
         findBreakAndSet mod $ findBreakByCoord Nothing (line, read col)
-   | otherwise = io $ putStrLn "Invalid arguments to :break"
+   | otherwise = breakSyntax
+
+breakSyntax = throwDyn (CmdLineError "Syntax: :break [<mod>] <line> [<column>]")
 
 findBreakAndSet :: Module -> (TickArray -> Maybe (Int, SrcSpan)) -> GHCi ()
 findBreakAndSet mod lookupTickTree = do 
@@ -1808,8 +1805,7 @@ listModuleLine modl line = do
 -- If the highlight flag is True, also highlight the span using
 -- start_bold/end_bold.
 listAround span do_highlight = do
-      pwd      <- getEnv "PWD" 
-      contents <- BS.readFile (pwd `joinFileName` unpackFS file)
+      contents <- BS.readFile (unpackFS file)
       let 
           lines = BS.split '\n' contents
           these_lines = take (line2 - line1 + 1 + pad_before + pad_after) $