-----------------------------------------------------------------------------
--- $Id: DriverUtil.hs,v 1.40 2003/11/10 12:04:25 simonpj Exp $
+-- $Id: DriverUtil.hs,v 1.50 2005/01/28 12:55:37 simonmar Exp $
--
-- Utils for the driver
--
--
-----------------------------------------------------------------------------
-module DriverUtil where
+module DriverUtil (
+ getOptionsFromSource, softGetDirectoryContents,
+ createDirectoryHierarchy, doesDirNameExist, prefixUnderscore,
+ unknownFlagErr, unknownFlagsErr, missingArgErr,
+ later, handleDyn, handle,
+ split, add, addNoDups,
+ Suffix, splitFilename, getFileSuffix,
+ splitFilename3, remove_suffix, split_longest_prefix,
+ replaceFilenameSuffix, directoryOf, filenameOf,
+ replaceFilenameDirectory, remove_spaces, escapeSpaces,
+ ) where
-#include "../includes/config.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
-> 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
missingArgErr :: String -> a
missingArgErr f = throwDyn (UsageError ("missing argument for flag: " ++ f))
-my_partition :: (a -> Maybe b) -> [a] -> ([(a,b)],[a])
-my_partition _ [] = ([],[])
-my_partition p (a:as)
- = let (bs,cs) = my_partition p as in
- case p a of
- Nothing -> (bs,a:cs)
- Just b -> ((a,b):bs,cs)
-
later = flip finally
handleDyn :: Typeable ex => (ex -> IO a) -> IO a -> IO a
remove_suffix :: Char -> String -> Suffix
remove_suffix c s
- | null pre = reverse suf
+ | null pre = s
| otherwise = reverse pre
where (suf,pre) = break (==c) (reverse s)
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