[project @ 2000-11-16 11:39:36 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 75cda59..7d6e6eb 100644 (file)
--- a/ghc/compiler/main/DriverUtil.hs
+++ b/ghc/compiler/main/DriverUtil.hs
@@ -1,5 +1,5 @@
 -----------------------------------------------------------------------------
--- $Id: DriverUtil.hs,v 1.1 2000/10/11 11:54:58 simonmar Exp $
+-- $Id: DriverUtil.hs,v 1.7 2000/11/16 11:39:37 simonmar Exp $
 --
 -- Utils for the driver
 --
@@ -17,10 +17,10 @@ import Util
 import IOExts
 import Exception
 import Dynamic
+import RegexString
 
 import IO
 import System
-import Directory
 import List
 import Char
 import Monad
@@ -30,9 +30,10 @@ import Monad
 
 short_usage = "Usage: For basic information, try the `--help' option."
    
+GLOBAL_VAR(v_Path_usage,  "",  String)
+
 long_usage = do
-  let usage_file = "ghc-usage.txt"
-      usage_path = findFile usage_file (cGHC_DRIVER_DIR ++ '/':usage_file)
+  usage_path <- readIORef v_Path_usage
   usage <- readFile usage_path
   dump usage
   exitWith ExitSuccess
@@ -41,8 +42,6 @@ long_usage = do
      dump ('$':'$':s) = hPutStr stderr get_prog_name >> dump s
      dump (c:s) = hPutChar stderr c >> dump s
 
-version_str = cProjectVersion
-
 data BarfKind
   = PhaseFailed String ExitCode
   | Interrupted
@@ -50,9 +49,9 @@ data BarfKind
   | OtherError String                  -- just prints the error message
   deriving Eq
 
-GLOBAL_VAR(prog_name, "ghc", String)
+GLOBAL_VAR(v_Prog_name, "ghc", String)
 
-get_prog_name = unsafePerformIO (readIORef prog_name) -- urk!
+get_prog_name = unsafePerformIO (readIORef v_Prog_name) -- urk!
 
 instance Show BarfKind where
   showsPrec _ e = showString get_prog_name . showString ": " . showBarf e
@@ -70,28 +69,27 @@ instance Typeable BarfKind where
   typeOf _ = mkAppTy barfKindTc []
 
 -----------------------------------------------------------------------------
--- Finding files in the installation
-
-GLOBAL_VAR(topDir, clibdir, String)
-
-       -- grab the last -B option on the command line, and
-       -- set topDir to its value.
-setTopDir :: [String] -> IO [String]
-setTopDir args = do
-  let (minusbs, others) = partition (prefixMatch "-B") args
-  (case minusbs of
-    []   -> writeIORef topDir clibdir
-    some -> writeIORef topDir (drop 2 (last some)))
-  return others
-
-findFile name alt_path = unsafePerformIO (do
-  top_dir <- readIORef topDir
-  let installed_file = top_dir ++ '/':name
-  let inplace_file   = top_dir ++ '/':cCURRENT_DIR ++ '/':alt_path
-  b <- doesFileExist inplace_file
-  if b  then return inplace_file
-       else return installed_file
- )
+-- Reading OPTIONS pragmas
+
+getOptionsFromSource 
+       :: String               -- input file
+       -> IO [String]          -- options, if any
+getOptionsFromSource file
+  = do h <- openFile file ReadMode
+       catchJust ioErrors (look h)
+         (\e -> if isEOFError e then return [] else ioError e)
+  where
+       look h = do
+           l <- hGetLine h
+           case () of
+               () | null l -> look h
+                  | prefixMatch "#" l -> look h
+                  | prefixMatch "{-# LINE" l -> look h   -- -}
+                  | Just (opts:_) <- matchRegex optionRegex l
+                       -> return (words opts)
+                  | otherwise -> return []
+
+optionRegex = mkRegex "\\{-#[ \t]+OPTIONS[ \t]+(.*)#-\\}"   -- -}
 
 -----------------------------------------------------------------------------
 -- Utils
@@ -111,15 +109,6 @@ my_prefix_match (p:pat) (r:rest)
   | p == r    = my_prefix_match pat rest
   | otherwise = Nothing
 
-prefixMatch :: Eq a => [a] -> [a] -> Bool
-prefixMatch [] _str = True
-prefixMatch _pat [] = False
-prefixMatch (p:ps) (s:ss) | p == s    = prefixMatch ps ss
-                         | otherwise = False
-
-postfixMatch :: String -> String -> Bool
-postfixMatch pat str = prefixMatch (reverse pat) (reverse str)
-
 later = flip finally
 
 handleDyn :: Typeable ex => (ex -> IO a) -> IO a -> IO a
@@ -141,6 +130,12 @@ addNoDups var x = do
   xs <- readIORef var
   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
+
 remove_suffix :: Char -> String -> String
 remove_suffix c s
   | null pre  = reverse suf
@@ -168,10 +163,3 @@ newdir dir s = dir ++ '/':drop_longest_prefix s '/'
 
 remove_spaces :: String -> String
 remove_spaces = reverse . dropWhile isSpace . reverse . dropWhile isSpace
-
-booter_version
- = case "\ 
-       \ __GLASGOW_HASKELL__" of
-    ' ':n:ns -> n:'.':ns
-    ' ':m    -> m
-