[project @ 2001-10-26 00:53:27 by sof]
[ghc-hetmet.git] / ghc / compiler / main / DriverUtil.hs
1 -----------------------------------------------------------------------------
2 -- $Id: DriverUtil.hs,v 1.28 2001/10/11 23:52:51 sof Exp $
3 --
4 -- Utils for the driver
5 --
6 -- (c) The University of Glasgow 2000
7 --
8 -----------------------------------------------------------------------------
9
10 module DriverUtil where
11
12 #include "../includes/config.h"
13 #include "HsVersions.h"
14
15 import Util
16 import Panic
17 import Config           ( cLeadingUnderscore )
18
19 import IOExts
20 import Exception
21 import Dynamic
22 import RegexString
23
24 import Directory        ( getDirectoryContents )
25 import IO
26 import List
27 import Char
28 import Monad
29
30
31 -----------------------------------------------------------------------------
32 -- Errors
33
34 -----------------------------------------------------------------------------
35 -- Reading OPTIONS pragmas
36
37 getOptionsFromSource 
38         :: String               -- input file
39         -> IO [String]          -- options, if any
40 getOptionsFromSource file
41   = do h <- openFile file ReadMode
42        catchJust ioErrors (look h `finally` hClose h)
43           (\e -> if isEOFError e then return [] else ioError e)
44   where
45         look h = do
46             l <- hGetLine h
47             case () of
48                 () | null l -> look h
49                    | prefixMatch "#" l -> look h
50                    | prefixMatch "{-# LINE" l -> look h   -- -}
51                    | Just (opts:_) <- matchRegex optionRegex l
52                         -> do rest <- look h
53                               return (words opts ++ rest)
54                    | otherwise -> return []
55
56 optionRegex = mkRegex "\\{-#[ \t]+OPTIONS[ \t]+(.*)#-\\}"   -- -}
57
58 -----------------------------------------------------------------------------
59 -- A version of getDirectoryContents that is non-fatal if the
60 -- directory doesn't exist.
61
62 softGetDirectoryContents d
63    = IO.catch (getDirectoryContents d)
64           (\_ -> do hPutStrLn stderr 
65                           ("WARNING: error while reading directory " ++ d)
66                     return []
67           )
68
69 -----------------------------------------------------------------------------
70 -- Prefixing underscore to linker-level names
71 prefixUnderscore :: String -> String
72 prefixUnderscore
73  | cLeadingUnderscore == "YES" = ('_':)
74  | otherwise                   = id
75
76 -----------------------------------------------------------------------------
77 -- Utils
78
79 unknownFlagErr :: String -> a
80 unknownFlagErr f = throwDyn (UsageError ("unrecognised flag: " ++ f))
81
82 my_partition :: (a -> Maybe b) -> [a] -> ([(a,b)],[a])
83 my_partition _ [] = ([],[])
84 my_partition p (a:as)
85   = let (bs,cs) = my_partition p as in
86     case p a of
87         Nothing -> (bs,a:cs)
88         Just b  -> ((a,b):bs,cs)
89
90 my_prefix_match :: String -> String -> Maybe String
91 my_prefix_match []    rest = Just rest
92 my_prefix_match (_:_) []   = Nothing
93 my_prefix_match (p:pat) (r:rest)
94   | p == r    = my_prefix_match pat rest
95   | otherwise = Nothing
96
97 later = flip finally
98
99 handleDyn :: Typeable ex => (ex -> IO a) -> IO a -> IO a
100 handleDyn = flip catchDyn
101
102 handle :: (Exception -> IO a) -> IO a -> IO a
103 #if __GLASGOW_HASKELL__ < 501
104 handle = flip Exception.catchAllIO
105 #else
106 handle h f = f `Exception.catch` \e -> case e of
107     ExitException _ -> throw e
108     _               -> h e
109 #endif
110
111 split :: Char -> String -> [String]
112 split c s = case rest of
113                 []     -> [chunk] 
114                 _:rest -> chunk : split c rest
115   where (chunk, rest) = break (==c) s
116
117 add :: IORef [a] -> a -> IO ()
118 add var x = do
119   xs <- readIORef var
120   writeIORef var (x:xs)
121
122 addNoDups :: Eq a => IORef [a] -> a -> IO ()
123 addNoDups var x = do
124   xs <- readIORef var
125   unless (x `elem` xs) $ writeIORef var (x:xs)
126
127 ------------------------------------------------------
128 --              Filename manipulation
129 ------------------------------------------------------
130                 
131 type Suffix = String
132
133 splitFilename :: String -> (String,Suffix)
134 splitFilename f = split_longest_prefix f (=='.')
135
136 getFileSuffix :: String -> Suffix
137 getFileSuffix f = drop_longest_prefix f (=='.')
138
139 -- "foo/bar/xyzzy.ext" -> ("foo/bar", "xyzzy", ".ext")
140 splitFilename3 :: String -> (String,String,Suffix)
141 splitFilename3 str
142    = let (dir, rest) = split_longest_prefix str isPathSeparator
143          (name, ext) = splitFilename rest
144          real_dir | null dir  = "."
145                   | otherwise = dir
146      in  (real_dir, name, ext)
147
148 remove_suffix :: Char -> String -> Suffix
149 remove_suffix c s
150   | null pre  = reverse suf
151   | otherwise = reverse pre
152   where (suf,pre) = break (==c) (reverse s)
153
154 drop_longest_prefix :: String -> (Char -> Bool) -> String
155 drop_longest_prefix s pred = reverse suf
156   where (suf,_pre) = break pred (reverse s)
157
158 take_longest_prefix :: String -> (Char -> Bool) -> String
159 take_longest_prefix s pred = reverse pre
160   where (_suf,pre) = break pred (reverse s)
161
162 -- split a string at the last character where 'pred' is True,
163 -- returning a pair of strings. The first component holds the string
164 -- up (but not including) the last character for which 'pred' returned
165 -- True, the second whatever comes after (but also not including the
166 -- last character).
167 --
168 -- If 'pred' returns False for all characters in the string, the original
169 -- string is returned in the second component (and the first one is just
170 -- empty).
171 split_longest_prefix :: String -> (Char -> Bool) -> (String,String)
172 split_longest_prefix s pred
173   = case pre of
174         []      -> ([], reverse suf)
175         (_:pre) -> (reverse pre, reverse suf)
176   where (suf,pre) = break pred (reverse s)
177
178 newsuf :: String -> Suffix -> String
179 newsuf suf s = remove_suffix '.' s ++ suf
180
181 -- getdir strips the filename off the input string, returning the directory.
182 getdir :: String -> String
183 getdir s = if null dir then "." else init dir
184   where dir = take_longest_prefix s isPathSeparator
185
186 newdir :: String -> String -> String
187 newdir dir s = dir ++ '/':drop_longest_prefix s isPathSeparator
188
189 remove_spaces :: String -> String
190 remove_spaces = reverse . dropWhile isSpace . reverse . dropWhile isSpace
191
192 isPathSeparator :: Char -> Bool
193 isPathSeparator ch =
194 #ifdef mingw32_TARGET_OS
195   ch == '/' || ch == '\\'
196 #else
197   ch == '/'
198 #endif