[project @ 2000-11-20 16:28:29 by simonmar]

[ghc-hetmet.git] / ghc / compiler / main / DriverUtil.hs

diff --git a/ghc/compiler/main/DriverUtil.hs b/ghc/compiler/main/DriverUtil.hs
index 7d6e6eb..764be3f 100644 (file)
--- a/ghc/compiler/main/DriverUtil.hs
+++ b/ghc/compiler/main/DriverUtil.hs
@@ -1,5 +1,5 @@
 -----------------------------------------------------------------------------
--- $Id: DriverUtil.hs,v 1.7 2000/11/16 11:39:37 simonmar Exp $
+-- $Id: DriverUtil.hs,v 1.11 2000/11/20 16:28:29 simonmar Exp $
 --
 -- Utils for the driver
 --
@@ -11,7 +11,6 @@ module DriverUtil where
 
 #include "HsVersions.h"
 
-import Config
 import Util
 
 import IOExts
@@ -39,7 +38,7 @@ long_usage = do
   exitWith ExitSuccess
   where
      dump "" = return ()
-     dump ('$':'$':s) = hPutStr stderr get_prog_name >> dump s
+     dump ('$':'$':s) = hPutStr stderr prog_name >> dump s
      dump (c:s) = hPutChar stderr c >> dump s
 
 data BarfKind
@@ -49,22 +48,25 @@ data BarfKind
   | OtherError String                  -- just prints the error message
   deriving Eq
 
-GLOBAL_VAR(v_Prog_name, "ghc", String)
-
-get_prog_name = unsafePerformIO (readIORef v_Prog_name) -- urk!
+prog_name = unsafePerformIO (getProgName)
+{-# NOINLINE prog_name #-}
 
 instance Show BarfKind where
-  showsPrec _ e = showString get_prog_name . showString ": " . showBarf e
+  showsPrec _ e = showString prog_name . showString ": " . showBarf e
 
-showBarf (UsageError str) = showString str . showChar '\n' . showString short_usage
-showBarf (OtherError str) = showString str
-showBarf (PhaseFailed phase code) = 
-       showString phase . showString " failed, code = " . shows code
-showBarf (Interrupted) = showString "interrupted"
+showBarf (UsageError str)
+   = showString str . showChar '\n' . showString short_usage
+showBarf (OtherError str)
+   = showString str
+showBarf (PhaseFailed phase code)
+   = showString phase . showString " failed, code = " . shows code
+showBarf (Interrupted)
+   = showString "interrupted"
 
 unknownFlagErr f = throwDyn (UsageError ("unrecognised flag: " ++ f))
 
 barfKindTc = mkTyCon "BarfKind"
+{-# NOINLINE barfKindTc #-}
 instance Typeable BarfKind where
   typeOf _ = mkAppTy barfKindTc []
 
@@ -131,10 +133,16 @@ addNoDups var x = do
   unless (x `elem` xs) $ writeIORef var (x:xs)
 
 splitFilename :: String -> (String,String)
-splitFilename f = (reverse (stripDot rev_basename), reverse rev_ext)
-  where (rev_ext, rev_basename) = span ('.' /=) (reverse f)
-        stripDot ('.':xs) = xs
-        stripDot xs       = xs
+splitFilename f = split_longest_prefix f '.'
+
+-- "foo/bar/xyzzy.ext" -> ("foo/bar", "xyzzy", ".ext")
+splitFilename3 :: String -> (String,String,String)
+splitFilename3 str
+   = let (dir, rest) = split_longest_prefix str '/'
+        (name, ext) = splitFilename rest
+        real_dir | null dir  = "."
+                 | otherwise = dir
+     in  (real_dir, name, ext)
 
 remove_suffix :: Char -> String -> String
 remove_suffix c s
@@ -150,6 +158,16 @@ take_longest_prefix :: String -> Char -> String
 take_longest_prefix s c = reverse pre
   where (_suf,pre) = break (==c) (reverse s)
 
+-- split a string at the last occurence of 'c', returning the two
+-- parts of the string with the 'c' removed.  If the string contains
+-- no 'c's, the entire string is returned in the second component.
+split_longest_prefix :: String -> Char -> (String,String)
+split_longest_prefix s c
+  = case pre of
+       []      -> ([], reverse suf)
+       (_:pre) -> (reverse pre, reverse suf)
+  where (suf,pre) = break (==c) (reverse s)
+
 newsuf :: String -> String -> String
 newsuf suf s = remove_suffix '.' s ++ suf