mkconfig.hs

Haskell是一种程序语言。特别的

-----------------------------------------------------------------------------
-- |
-- Module      :  MkConfig
-- Copyright   :  Malcolm Wallace
-- 
-- Maintainer  :  Malcolm Wallace <[e-mail]>
-- Stability   :  Stable
-- Portability :  All
--
-- Main program for utility hmake-config
-----------------------------------------------------------------------------

module Main where

import Config
import RunAndReadStdout (dirname)
import Directory (createDirectory)
import System (exitWith,ExitCode(..),getArgs)
import List (nub,sort)
import Maybe (fromJust)
import IO (stderr,isDoesNotExistError)
#ifdef __HBC__
import IOMisc (hPutStrLn)
#else
import IO (hPutStrLn)
#endif


main = do
  args <- getArgs
  (gfile,lfile,args) <- findConfigFile args
  case args of
    ["new"]  -> do newConfigFile (gfile,lfile)
                   exitWith ExitSuccess
    _ -> return ()
  config <- readPersonalConfig (gfile,lfile)
  case args of
    ["list"] -> do putStrLn ("Global config file is:\n    "++gfile)
                   (case lfile of
                      Just f -> putStrLn ("Personal config file is:\n    "++f)
                      Nothing -> return ())
                   known <- mapM unDyn $ knownComps config
                   putStrLn "Known compilers:"
                   mapM_ putStrLn
                         ((reverse . sort
                           . map (\c-> "    "++compilerPath c
                                       ++"\t("++compilerVersion c++")"))
                          known)
                   putStrLn "Default compiler:"
                   putStrLn ("    "++defaultComp config)
    [hc] -> do -- no command, assume 'add'
               cc <- configure hc
               config' <- add cc config
               writeBack gfile lfile config'
    ["add",hc]     -> do cc <- configure hc
                         config' <- add cc config
                         writeBack gfile lfile config'
    ["add-dyn",hc] -> do config' <- add (DynCompiler hc) config
                         writeBack gfile lfile config'
    ["delete",hc]  -> do config' <- delete config gfile hc
                         writeBack gfile lfile config'
    ["default",hc] -> do config' <- mkDefault config hc
                         writeBack gfile lfile config'
    ["list",hc]    -> do let cc = matchCompiler hc config
                         putStrLn (show cc)
    _ -> do hPutStrLn stderr usage
            exitWith (ExitFailure 1)
  ----
  exitWith ExitSuccess

 where
    findConfigFile :: [String] -> IO (FilePath, Maybe FilePath, [String])
    findConfigFile args =
      case args of
        [] -> do let (g,_) = defaultConfigLocation False
                 hPutStrLn stderr (usage++"\ndefault configfile is:\n    "++g)
                 exitWith (ExitFailure 1)
        (file:"new":_)  -> return (file, Nothing, tail args)
        (file:"list":_) -> return (file, Nothing, tail args)
        [file,_,_]      -> return (file, Nothing, tail args)
        ("list":_) ->
             let (g,l) = defaultConfigLocation False in return (g, l, args)
        _ -> let (g,l) = defaultConfigLocation True in return (g, l, args)
    usage = "Usage: hmake-config [configfile] list\n"
         ++ "       hmake-config [configfile] [add|add-dyn|delete|default] hc\n"
         ++ "              -- hc is name/path of a Haskell compiler"

{-
    parseConfigFile :: String -> FilePath -> IO HmakeConfig
    parseConfigFile machine path =
      catch (safeReadConfig path)
            (\e-> if isDoesNotExistError e
                  then do
                    hPutStrLn stderr ("hmake-config: Warning: "
                                      ++"Config file not found:\n  '"
                                      ++path++"'")
                    globalDir <- getEnv "HMAKECONFDIR"
                    let global = globalDir++"/"++machine++"/hmakerc"
                    if path == global
                      then newConfigFile path
                      else do
                        hPutStrLn stderr ("hmake-config: Copying from\n  '"
                                          ++global++"'.")
                        catch (do config <- safeReadConfig global
                                  catch (writeFile path (show config))
                                        (\e-> hPutStrLn stderr
                                                ("hmake-config: Cannot create "
                                                ++"file "++path))
                                  return config)
                              (\e-> if isDoesNotExistError e
                                    then do
                                      hPutStrLn stderr
                                        ("hmake-config: Warning: "
                                         ++"System config file not found:\n  '"
                                         ++global++"'")
                                      newConfigFile path
                                    else ioError e)
                  else ioError e)
-}

newConfigFile (gpath,lpath) = do
  (path,config) <-
      case lpath of
        Just lo -> do hPutStrLn stderr
                        ("hmake-config: Starting new personal config file in"
                         ++"\n  "++lo)
                      gconf <- safeReadConfig gpath
                      return (lo, HmakeConfig {defaultCompiler=
                                                     defaultCompiler gconf
                                              ,knownCompilers=[]})
        Nothing -> do hPutStrLn stderr
                        ("hmake-config: Starting new config file in\n  "++gpath)
                      return (gpath, HmakeConfig {defaultCompiler="unknown"
                                                 ,knownCompilers=[]})
  catch (writeFile path (show config))
        (\e -> if isDoesNotExistError e	-- fails because no directory
               then do createDirectory (dirname path)
                       writeFile path (show config)
               else ioError e)		-- fails for other reason


writeBack :: FilePath -> Maybe FilePath -> PersonalConfig -> IO ()
writeBack gfile lfile config =
  case lfile of
    Just f  -> writeFile f (show (fromJust (localConfig config)))
    Nothing -> writeFile gfile (show (globalConfig config))

delete :: PersonalConfig -> FilePath -> String -> IO PersonalConfig
delete config gfile hc
  | hc == defaultComp config = do
        hPutStrLn stderr ("hmake-config: cannot delete\n  '"++hc
                          ++"'\n  because it is the default compiler.")
        exitWith (ExitFailure 3)
        return undefined -- never reached
  | otherwise =
        case localConfig config of
          Just lo -> if hc `elem` map compilerPath (knownCompilers lo) then
                       return config {localConfig=
                                       Just (lo {knownCompilers=
                                          filter (\cc-> compilerPath cc /= hc)
                                                 (knownCompilers lo) })}
                     else do
                       hPutStrLn stderr
                                ("hmake-config: Cannot delete compiler\n  "++hc
                                ++"\nIt is configured globally.  Use\n  "
                                ++"hmake-config "++gfile++" delete "++hc)
                       exitWith (ExitFailure 3)
                       return undefined
          Nothing -> let gl = globalConfig config in
                     if hc `elem` map compilerPath (knownCompilers gl) then
                       return config {globalConfig =
                                       gl {knownCompilers=
                                         filter (\cc-> compilerPath cc /= hc)
                                                (knownCompilers gl)}}
                     else do
                       hPutStrLn stderr
                                 ("hmake-config: compiler not known:\n  "++hc)
                       exitWith (ExitFailure 3)
                       return undefined

mkDefault :: PersonalConfig -> String -> IO PersonalConfig
mkDefault config hc
  | hc `elem` map compilerPath (knownComps config)
              = case localConfig config of
                  Just lo -> return config {localConfig=
                                              Just (lo {defaultCompiler = hc})}
                  Nothing -> let gl = globalConfig config in
                             return config {globalConfig=
                                              gl {defaultCompiler = hc}}
  | otherwise = do hPutStrLn stderr ("hmake-config: compiler not known:\n  '"