1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
|
Written by Ian Lynagh <igloo@debian.org>.
Copyright (C) 2003, 2004 Ian Lynagh.
Released under the GNU GPL version 2.
\begin{code}
module Main (main) where
import System (getArgs, ExitCode(ExitSuccess, ExitFailure), exitWith, system)
import IO (hPutStrLn, stderr)
import Directory (doesFileExist, removeFile)
import Char (toUpper)
import List (partition)
import Monad (when)
type State = ([Compiler], [Trigger])
type Err = Bool
data Compiler = Compiler FilePath CType Version
deriving (Show, Read)
data Trigger = Trigger TrigIdent When CType TrigStr
deriving (Show, Read)
data CType = GHC | NHC | HUGS | Other
deriving (Show, Read, Eq)
data When = OnAdd | OnRemove
deriving (Show, Read, Eq)
type Version = String
type TrigIdent = String
type TrigStr = String
fail_args, fail_bad_ctype, fail_del_compiler, fail_del_trig, fail_parse :: Int
fail_args = 1
fail_bad_ctype = 2
fail_del_compiler = 3
fail_del_trig = 4
fail_parse = 5
main :: IO ()
main = do args <- getArgs
let (err, args') = case args of
"-e":xs -> (True, xs)
_ -> (False, args)
case args' of
["--help"] -> usage
["-h"] -> usage
["--version"] -> show_version
["-V"] -> show_version
["--add-compiler", path, ctype, version] ->
add_compiler err path ctype version
["--remove-compiler", path] ->
remove_compiler err path
["--add-trigger", ident, ctype, trigstr] ->
add_trigger err ident ctype trigstr
["--add-untrigger", ident, ctype, trigstr] ->
add_untrigger ident ctype trigstr
["--remove-triggers", ident] ->
remove_triggers err ident
_ -> do hPutStrLn stderr $ "Invalid args: " ++ show args
usage
exitWith (ExitFailure fail_args)
compiler_file :: String
compiler_file = "@localstatedir@/haskell-utils/compilers"
usage :: IO ()
usage = do putStrLn "Usage: haskell-utils [ --help | -h | --version | -V ]"
putStrLn " haskell-utils [ -e ] --add-compiler /path/to/compiler TYPE VERSION"
putStrLn " haskell-utils [ -e ] --remove-compiler /path/to/compiler"
putStrLn " haskell-utils [ -e ] --add-trigger IDENT TYPE TRIGGER"
putStrLn " haskell-utils [ -e ] --add-untrigger IDENT TYPE TRIGGER"
putStrLn " haskell-utils [ -e ] --remove-triggers IDENT"
putStrLn " TYPE is GHC | NHC | HUGS | Other."
putStrLn " IDENT is a string uniquely identifying the trigger owner."
putStrLn " TRIGGER is the command to be run when the trigger happens."
putStrLn " %% is replaced with % and %p with the path to the compiler."
putStrLn " If -e is given then haskell-utils will fail if anything external does."
putStrLn ""
putStrLn "haskell-utils allows compilers and tools that like to know about compilers to"
putStrLn "register themselves so the latter can be informed about the addition and"
putStrLn "removal of the former."
putStrLn ""
show_version :: IO ()
show_version = do putStrLn "haskell-utils @version@"
putStrLn "Written by Ian Lynagh."
putStrLn "Copyright (C) 2003, 2004 Ian Lynagh."
get_current :: IO State
get_current =
do exists <- doesFileExist compiler_file
if exists
then do contents <- readFile compiler_file
case reads contents of
[(cs, "")] -> return cs
_ -> do hPutStrLn stderr ("Failed to parse " ++ compiler_file)
exitWith (ExitFailure fail_parse)
else return ([], [])
put_new :: State -> IO ()
put_new ([], []) = removeFile compiler_file
put_new cs = writeFile compiler_file $ show cs
del_compiler :: FilePath -> State -> Maybe ([Compiler], State)
del_compiler p (cs, ts) = case partition is_at_p cs of
([], _) -> Nothing
(cs_removed, cs') -> Just (cs_removed, (cs', ts))
where is_at_p (Compiler q _ _) = p == q
del_triggers :: TrigIdent -> State -> Maybe State
del_triggers ti (cs, ts) = case partition is_a_ti ts of
([], _) -> Nothing
(_, ts') -> Just (cs, ts')
where is_a_ti (Trigger ti' _ _ _) = ti == ti'
add_compiler :: Err -> FilePath -> String -> Version -> IO ()
add_compiler err path ctype version
= case lookup (map toUpper ctype) ctypes of
Just ct -> do let c = Compiler path ct version
cur <- get_current
case del_compiler path cur of
Nothing -> put_new (push_compiler c cur)
Just (cs, cur') ->
do putStrLn "Overwriting old entry"
mapM_ (trigger err cur OnRemove) cs
put_new (push_compiler c cur')
trigger err cur OnAdd c
Nothing -> do hPutStrLn stderr ("Bad TYPE " ++ show ctype)
usage
exitWith (ExitFailure fail_bad_ctype)
remove_compiler :: Err -> FilePath -> IO ()
remove_compiler err path
= do cur <- get_current
case del_compiler path cur of
Nothing -> do hPutStrLn stderr ("Can't find " ++ path)
when err $ exitWith (ExitFailure fail_del_compiler)
Just (cs, cur') -> do mapM_ (trigger err cur OnRemove) cs
put_new cur'
add_trigger :: Err -> TrigIdent -> String -> TrigStr -> IO ()
add_trigger err ident ctype trigstr
= case lookup (map toUpper ctype) ctypes of
Just ct -> do let t = Trigger ident OnAdd ct trigstr
cur <- get_current
mapM_ (do_trigger err trigstr)
[ fp | Compiler fp c_ct _ <- get_compilers cur,
c_ct == ct ]
put_new (push_trigger t cur)
Nothing -> do hPutStrLn stderr ("Bad TYPE " ++ show ctype)
usage
exitWith (ExitFailure fail_bad_ctype)
add_untrigger :: TrigIdent -> String -> TrigStr -> IO ()
add_untrigger ident ctype trigstr
= case lookup (map toUpper ctype) ctypes of
Just ct -> do let t = Trigger ident OnRemove ct trigstr
cur <- get_current
put_new (push_trigger t cur)
Nothing -> do hPutStrLn stderr ("Bad TYPE " ++ show ctype)
usage
exitWith (ExitFailure fail_bad_ctype)
remove_triggers :: Err -> TrigIdent -> IO ()
remove_triggers err ti
= do cur <- get_current
case del_triggers ti cur of
Nothing -> do hPutStrLn stderr ("Can't find " ++ ti)
when err $ exitWith (ExitFailure fail_del_trig)
Just cur' -> put_new cur'
trigger :: Err -> State -> When -> Compiler -> IO ()
trigger err (_, ts) trig_when c = mapM_ (trig c) ts
where trig (Compiler p ct1 _) (Trigger _ w ct2 trigstr)
| ct1 == ct2 && w == trig_when = do_trigger err trigstr p
trig _ _ = return ()
do_trigger :: Err -> TrigStr -> FilePath -> IO ()
do_trigger err ts p
= do r <- system (subst ts)
case r of
ExitSuccess -> return ()
f -> do hPutStrLn stderr ("Trigger failed: " ++ show (ts, p))
when err $ exitWith f
where subst "" = ""
subst ('%':'%':xs) = '%':subst xs
subst ('%':'p':xs) = p ++ subst xs
subst (x:xs) = x:subst xs
get_compilers :: State -> [Compiler]
get_compilers (cs, _) = cs
push_compiler :: Compiler -> State -> State
push_compiler c (cs, ts) = (c:cs, ts)
push_trigger :: Trigger -> State -> State
push_trigger t (cs, ts) = (cs, t:ts)
ctypes :: [(String, CType)]
ctypes = [("GHC", GHC), ("NHC", NHC), ("HUGS", HUGS), ("OTHER", Other)]
\end{code}
|
