1 -----------------------------------------------------------------------------
2 -- $Id: DriverUtil.hs,v 1.5 2000/10/27 13:50:25 sewardj 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."
33 GLOBAL_VAR(v_Path_usage, "", String)
36 usage_path <- readIORef v_Path_usage
37 usage <- readFile usage_path
42 dump ('$':'$':s) = hPutStr stderr get_prog_name >> dump s
43 dump (c:s) = hPutChar stderr c >> dump s
45 version_str = cProjectVersion
48 = PhaseFailed String ExitCode
50 | UsageError String -- prints the short usage msg after the error
51 | OtherError String -- just prints the error message
54 GLOBAL_VAR(v_Prog_name, "ghc", String)
56 get_prog_name = unsafePerformIO (readIORef v_Prog_name) -- urk!
58 instance Show BarfKind where
59 showsPrec _ e = showString get_prog_name . showString ": " . showBarf e
61 showBarf (UsageError str) = showString str . showChar '\n' . showString short_usage
62 showBarf (OtherError str) = showString str
63 showBarf (PhaseFailed phase code) =
64 showString phase . showString " failed, code = " . shows code
65 showBarf (Interrupted) = showString "interrupted"
67 unknownFlagErr f = throwDyn (UsageError ("unrecognised flag: " ++ f))
69 barfKindTc = mkTyCon "BarfKind"
70 instance Typeable BarfKind where
71 typeOf _ = mkAppTy barfKindTc []
73 -----------------------------------------------------------------------------
74 -- Reading OPTIONS pragmas
76 :: String -- input file
77 -> IO [String] -- options, if any
78 getOptionsFromSource file
79 = do h <- openFile file ReadMode
80 catchJust ioErrors (look h)
81 (\e -> if isEOFError e then return [] else ioError e)
87 | prefixMatch "#" l -> look h
88 | prefixMatch "{-# LINE" l -> look h -- -}
89 | Just (opts:_) <- matchRegex optionRegex l
90 -> return (words opts)
91 | otherwise -> return []
93 optionRegex = mkRegex "\\{-#[ \t]+OPTIONS[ \t]+(.*)#-\\}" -- -}
95 -----------------------------------------------------------------------------
98 my_partition :: (a -> Maybe b) -> [a] -> ([(a,b)],[a])
99 my_partition _ [] = ([],[])
100 my_partition p (a:as)
101 = let (bs,cs) = my_partition p as in
104 Just b -> ((a,b):bs,cs)
106 my_prefix_match :: String -> String -> Maybe String
107 my_prefix_match [] rest = Just rest
108 my_prefix_match (_:_) [] = Nothing
109 my_prefix_match (p:pat) (r:rest)
110 | p == r = my_prefix_match pat rest
111 | otherwise = Nothing
115 handleDyn :: Typeable ex => (ex -> IO a) -> IO a -> IO a
116 handleDyn = flip catchDyn
118 split :: Char -> String -> [String]
119 split c s = case rest of
121 _:rest -> chunk : split c rest
122 where (chunk, rest) = break (==c) s
124 add :: IORef [a] -> a -> IO ()
127 writeIORef var (x:xs)
129 addNoDups :: Eq a => IORef [a] -> a -> IO ()
132 unless (x `elem` xs) $ writeIORef var (x:xs)
134 splitFilename :: String -> (String,String)
135 splitFilename f = (reverse (stripDot rev_basename), reverse rev_ext)
136 where (rev_ext, rev_basename) = span ('.' /=) (reverse f)
137 stripDot ('.':xs) = xs
140 remove_suffix :: Char -> String -> String
142 | null pre = reverse suf
143 | otherwise = reverse pre
144 where (suf,pre) = break (==c) (reverse s)
146 drop_longest_prefix :: String -> Char -> String
147 drop_longest_prefix s c = reverse suf
148 where (suf,_pre) = break (==c) (reverse s)
150 take_longest_prefix :: String -> Char -> String
151 take_longest_prefix s c = reverse pre
152 where (_suf,pre) = break (==c) (reverse s)
154 newsuf :: String -> String -> String
155 newsuf suf s = remove_suffix '.' s ++ suf
157 -- getdir strips the filename off the input string, returning the directory.
158 getdir :: String -> String
159 getdir s = if null dir then "." else init dir
160 where dir = take_longest_prefix s '/'
162 newdir :: String -> String -> String
163 newdir dir s = dir ++ '/':drop_longest_prefix s '/'
165 remove_spaces :: String -> String
166 remove_spaces = reverse . dropWhile isSpace . reverse . dropWhile isSpace
170 \ __GLASGOW_HASKELL__" of