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}