1 -----------------------------------------------------------------------------
2 -- $Id: DriverUtil.hs,v 1.1 2000/10/11 11:54:58 simonmar Exp $
4 -- Utils for the driver
6 -- (c) The University of Glasgow 2000
8 -----------------------------------------------------------------------------
10 module DriverUtil where
12 #include "HsVersions.h"
28 -----------------------------------------------------------------------------
31 short_usage = "Usage: For basic information, try the `--help' option."
34 let usage_file = "ghc-usage.txt"
35 usage_path = findFile usage_file (cGHC_DRIVER_DIR ++ '/':usage_file)
36 usage <- readFile usage_path
41 dump ('$':'$':s) = hPutStr stderr get_prog_name >> dump s
42 dump (c:s) = hPutChar stderr c >> dump s
44 version_str = cProjectVersion
47 = PhaseFailed String ExitCode
49 | UsageError String -- prints the short usage msg after the error
50 | OtherError String -- just prints the error message
53 GLOBAL_VAR(prog_name, "ghc", String)
55 get_prog_name = unsafePerformIO (readIORef prog_name) -- urk!
57 instance Show BarfKind where
58 showsPrec _ e = showString get_prog_name . showString ": " . showBarf e
60 showBarf (UsageError str) = showString str . showChar '\n' . showString short_usage
61 showBarf (OtherError str) = showString str
62 showBarf (PhaseFailed phase code) =
63 showString phase . showString " failed, code = " . shows code
64 showBarf (Interrupted) = showString "interrupted"
66 unknownFlagErr f = throwDyn (UsageError ("unrecognised flag: " ++ f))
68 barfKindTc = mkTyCon "BarfKind"
69 instance Typeable BarfKind where
70 typeOf _ = mkAppTy barfKindTc []
72 -----------------------------------------------------------------------------
73 -- Finding files in the installation
75 GLOBAL_VAR(topDir, clibdir, String)
77 -- grab the last -B option on the command line, and
78 -- set topDir to its value.
79 setTopDir :: [String] -> IO [String]
81 let (minusbs, others) = partition (prefixMatch "-B") args
83 [] -> writeIORef topDir clibdir
84 some -> writeIORef topDir (drop 2 (last some)))
87 findFile name alt_path = unsafePerformIO (do
88 top_dir <- readIORef topDir
89 let installed_file = top_dir ++ '/':name
90 let inplace_file = top_dir ++ '/':cCURRENT_DIR ++ '/':alt_path
91 b <- doesFileExist inplace_file
92 if b then return inplace_file
93 else return installed_file
96 -----------------------------------------------------------------------------
99 my_partition :: (a -> Maybe b) -> [a] -> ([(a,b)],[a])
100 my_partition _ [] = ([],[])
101 my_partition p (a:as)
102 = let (bs,cs) = my_partition p as in
105 Just b -> ((a,b):bs,cs)
107 my_prefix_match :: String -> String -> Maybe String
108 my_prefix_match [] rest = Just rest
109 my_prefix_match (_:_) [] = Nothing
110 my_prefix_match (p:pat) (r:rest)
111 | p == r = my_prefix_match pat rest
112 | otherwise = Nothing
114 prefixMatch :: Eq a => [a] -> [a] -> Bool
115 prefixMatch [] _str = True
116 prefixMatch _pat [] = False
117 prefixMatch (p:ps) (s:ss) | p == s = prefixMatch ps ss
120 postfixMatch :: String -> String -> Bool
121 postfixMatch pat str = prefixMatch (reverse pat) (reverse str)
125 handleDyn :: Typeable ex => (ex -> IO a) -> IO a -> IO a
126 handleDyn = flip catchDyn
128 split :: Char -> String -> [String]
129 split c s = case rest of
131 _:rest -> chunk : split c rest
132 where (chunk, rest) = break (==c) s
134 add :: IORef [a] -> a -> IO ()
137 writeIORef var (x:xs)
139 addNoDups :: Eq a => IORef [a] -> a -> IO ()
142 unless (x `elem` xs) $ writeIORef var (x:xs)
144 remove_suffix :: Char -> String -> String
146 | null pre = reverse suf
147 | otherwise = reverse pre
148 where (suf,pre) = break (==c) (reverse s)
150 drop_longest_prefix :: String -> Char -> String
151 drop_longest_prefix s c = reverse suf
152 where (suf,_pre) = break (==c) (reverse s)
154 take_longest_prefix :: String -> Char -> String
155 take_longest_prefix s c = reverse pre
156 where (_suf,pre) = break (==c) (reverse s)
158 newsuf :: String -> String -> String
159 newsuf suf s = remove_suffix '.' s ++ suf
161 -- getdir strips the filename off the input string, returning the directory.
162 getdir :: String -> String
163 getdir s = if null dir then "." else init dir
164 where dir = take_longest_prefix s '/'
166 newdir :: String -> String -> String
167 newdir dir s = dir ++ '/':drop_longest_prefix s '/'
169 remove_spaces :: String -> String
170 remove_spaces = reverse . dropWhile isSpace . reverse . dropWhile isSpace
174 \ __GLASGOW_HASKELL__" of