[project @ 2005-01-28 12:55:17 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 f1d61e4..dab7eb6 100644 (file)
--- a/ghc/compiler/main/DriverUtil.hs
+++ b/ghc/compiler/main/DriverUtil.hs
@@ -1,5 +1,5 @@
 -----------------------------------------------------------------------------
--- $Id: DriverUtil.hs,v 1.44 2004/09/30 10:37:11 simonpj Exp $
+-- $Id: DriverUtil.hs,v 1.50 2005/01/28 12:55:37 simonmar Exp $
 --
 -- Utils for the driver
 --
@@ -15,16 +15,16 @@ module DriverUtil (
        split, add, addNoDups, 
        Suffix, splitFilename, getFileSuffix,
        splitFilename3, remove_suffix, split_longest_prefix,
-       replaceFilenameSuffix, directoryOf, replaceFilenameDirectory,
-       remove_spaces, escapeSpaces,
+       replaceFilenameSuffix, directoryOf, filenameOf,
+       replaceFilenameDirectory, remove_spaces, escapeSpaces,
   ) where
 
-#include "../includes/ghcconfig.h"
 #include "HsVersions.h"
 
 import Util
 import Panic
 import Config          ( cLeadingUnderscore )
+import Ctype
 
 import EXCEPTION       ( Exception(..), finally, throwDyn, catchDyn, throw )
 import qualified EXCEPTION as Exception
@@ -45,29 +45,45 @@ getOptionsFromSource
        -> IO [String]          -- options, if any
 getOptionsFromSource file
   = do h <- openFile file ReadMode
-       catchJust ioErrors (look h `finally` hClose h)
-         (\e -> if isEOFError e then return [] else ioError e)
+       look h `finally` hClose h
   where
-
        look h = do
-           l' <- hGetLine h
-           let l = remove_spaces l'
-           case () of
-               () | null l -> look h
-                  | prefixMatch "#" l -> look h
-                  | prefixMatch "{-# LINE" l -> look h   -- -}
-                  | Just opts <- matchOptions l
-                       -> do rest <- look h
+           r <- tryJust ioErrors (hGetLine h)
+           case r of
+             Left e | isEOFError e -> return []
+                    | otherwise    -> ioError e
+             Right l' -> do
+               let l = remove_spaces l'
+               case () of
+                   () | null l -> look h
+                      | prefixMatch "#" l -> look h
+                      | prefixMatch "{-# LINE" l -> look h   -- -}
+                      | Just opts <- matchOptions l
+                       -> do rest <- look h
                               return (words opts ++ rest)
-                  | otherwise -> return []
+                      | otherwise -> return []
 
+-- detect {-# OPTIONS_GHC ... #-}.  For the time being, we accept OPTIONS
+-- instead of OPTIONS_GHC, but that is deprecated.
 matchOptions s
-  | Just s1 <- maybePrefixMatch "{-#" s, -- -}
-    Just s2 <- maybePrefixMatch "OPTIONS" (remove_spaces s1),
-    Just s3 <- maybePrefixMatch "}-#" (reverse s2)
-  = Just (reverse s3)
+  | Just s1 <- maybePrefixMatch "{-#" s -- -} 
+  = matchOptions1 (remove_spaces s1)
   | otherwise
   = Nothing
+ where
+  matchOptions1 s
+    | Just s2 <- maybePrefixMatch "OPTIONS" s
+    = case () of
+       _ | Just s3 <- maybePrefixMatch "_GHC" s2, not (is_ident (head s3))
+         -> matchOptions2 s3
+         | not (is_ident (head s2))
+         -> matchOptions2 s2
+         | otherwise
+         -> Just []  -- OPTIONS_anything is ignored, not treated as start of source
+    | otherwise = Nothing
+  matchOptions2 s
+    | Just s3 <- maybePrefixMatch "}-#" (reverse s) = Just (reverse s3)
+    | otherwise = Nothing
 
 -----------------------------------------------------------------------------
 -- A version of getDirectoryContents that is non-fatal if the
@@ -212,6 +228,11 @@ replaceFilenameSuffix s suf = remove_suffix '.' s ++ suf
 directoryOf :: FilePath -> String
 directoryOf = fst . splitFilenameDir
 
+-- filenameOf strips the directory off the input string, returning
+-- the filename.
+filenameOf :: FilePath -> String
+filenameOf = snd . splitFilenameDir
+
 replaceFilenameDirectory :: FilePath -> String -> FilePath
 replaceFilenameDirectory s dir
  = dir ++ '/':drop_longest_prefix s isPathSeparator