----------------------------------------------------------------------------- -- | -- Module : MkConfig -- Copyright : Malcolm Wallace -- -- Maintainer : Malcolm Wallace -- 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 '" ++hc++"'") exitWith (ExitFailure 2) return undefined -- never reached add :: CompilerConfig -> PersonalConfig -> IO PersonalConfig add hc config = return $ case localConfig config of Just local -> config { localConfig = Just (local { knownCompilers = nub (hc: knownCompilers local)})} Nothing -> let global = globalConfig config in config { globalConfig = global { knownCompilers = nub (hc: knownCompilers global)}} {- -- | configure for each style of compiler configure :: HC -> String -> IO CompilerConfig configure Ghc ghcpath = do ghcversion <- runAndReadStdout (escape ghcpath ++ " --version 2>&1 | " ++"sed 's/^.*version[ ]*\\([0-9.]*\\).*/\\1/'" ) let ghcsym = let v = (read (take 3 (filter isDigit ghcversion ++ "0"))) :: Int in if v <= 600 then v else let hundreds = (v`div`100)*100 in hundreds + ((v-hundreds)`div`10) config = CompilerConfig { compilerStyle = Ghc , compilerPath = ghcpath , compilerVersion = ghcversion , includePaths = undefined , cppSymbols = ["__GLASGOW_HASKELL__="++show ghcsym] , extraCompilerFlags = [] , isHaskell98 = ghcsym>=400 } if windows && ghcsym<500 then do fullpath <- which exe ghcpath let incdir1 = dirname (dirname fullpath)++"/imports" ok <- doesDirectoryExist incdir1 if ok then return config{ includePaths = ghcDirs ghcsym incdir1 } else do ioError (userError ("Can't find ghc includes at\n "++incdir1)) else if ghcsym<500 then do fullpath <- which exe ghcpath dir <- runAndReadStdout ("grep '^\\$libdir=' "++fullpath++" | head -n 1 | " ++ "sed 's/^\\$libdir=[^/]*\\(.*\\).;/\\1/'") let incdir1 = dir++"/imports" ok <- doesDirectoryExist incdir1 if ok then return config{ includePaths = ghcDirs ghcsym incdir1 } else do let incdir2 = dir++"/lib/imports" ok <- doesDirectoryExist incdir2 if ok then return config{ includePaths = ghcDirs ghcsym incdir2 } else do ioError (userError ("Can't find ghc includes at\n " ++incdir1++"\n "++incdir2)) else do -- 5.00 and above pkgcfg <- runAndReadStdout (escape ghcpath++" --print-libdir") let libdir = escape pkgcfg incdir1 = libdir++"/imports" ok <- doesDirectoryExist incdir1 if ok then do fullpath <- fmap escape (which exe ghcpath) let ghcpkg0 = dirname fullpath++"/ghc-pkg-"++ghcversion ok <- doesFileExist ghcpkg0 let ghcpkg = if ok then ghcpkg0 else dirname fullpath++"/ghc-pkg" -- pkgs <- runAndReadStdout (ghcpkg++" --list-packages") pkgs <- runAndReadStdout (ghcpkg++" -l") let pkgsOK = filter (\p-> any (`isPrefixOf` p) ["std","base","haskell98"]) (deComma pkgs) idirs <- mapM (\p-> runAndReadStdout (ghcpkg++" --show-package=" ++deVersion (ghcsym>=604) p ++" --field=import_dirs")) pkgsOK return config{ includePaths = pkgDirs libdir (nub idirs) } else do ioError (userError ("Can't find ghc includes at "++incdir1)) where -- ghcDirs only static for ghc < 500; for later versions found dynamically ghcDirs n root | n < 400 = [root] | n < 406 = map ((root++"/")++) ["std","exts","misc" ,"posix"] | otherwise = map ((root++"/")++) ["std","lang","data","net" ,"posix","num","text" ,"util","hssource" ,"win32","concurrent"] pkgDirs libdir dirs = map (\dir-> if "$libdir" `isPrefixOf` dir then libdir++drop 7 dir else if "[\"" `isPrefixOf` dir then drop 2 (init (init dir)) else dir) (concatMap words dirs) deComma pkgs = map (\p-> if last p==',' then init p else p) (words pkgs) deVersion False pkg = pkg deVersion True pkg = let (suf,pref) = span (/='-') (reverse pkg) in case pref of "" -> pkg; _ -> reverse (tail pref) configure Nhc98 nhcpath = do fullpath <- which id nhcpath nhcversion <- runAndReadStdout (escape nhcpath ++" --version 2>&1 | cut -d' ' -f2 | head -n 1") dir <- runAndReadStdout ("grep '^NHC98INCDIR' "++escape fullpath ++ "| cut -c27- | cut -d'}' -f1 | head -n 1") return CompilerConfig { compilerStyle = Nhc98 , compilerPath = nhcpath , compilerVersion = nhcversion , includePaths = [dir] , cppSymbols = ["__NHC__="++ take 3 (filter isDigit nhcversion)] , extraCompilerFlags = [] , isHaskell98 = True } configure Hbc hbcpath = do let field n = "| cut -d' ' -f"++show n++" | head -n 1" wibble <- runAndReadStdout (hbcpath ++ " -v 2>&1 " ++ field 2) hbcversion <- case wibble of "version" -> runAndReadStdout (hbcpath ++ " -v 2>&1 " ++ field 3) _ -> runAndReadStdout (hbcpath ++ " -v 2>&1 " ++ field 4) dir <- catch (getEnv "HBCDIR") (\e-> catch (getEnv "LMLDIR") (\e-> return "/usr/local/lib/lmlc")) return CompilerConfig { compilerStyle = Hbc , compilerPath = hbcpath , compilerVersion = hbcversion , includePaths = map ((dir++"/")++) ["hlib1.3","hbc_library1.3"] , cppSymbols = ["__HBC__"] , extraCompilerFlags = [] , isHaskell98 = ((hbcversion!!7) >= '5') } configure (Unknown hc) hcpath = do hPutStrLn stderr ("hmake-config: the compiler\n '"++hcpath ++"'\n does not look like a Haskell compiler.") exitWith (ExitFailure 4) return undefined -- never reached -- | Work out which basic compiler. hcStyle :: String -> HC hcStyle path = toCompiler (basename path) where toCompiler :: String -> HC toCompiler hc | "gcc" `isPrefixOf` hc = Nhc98 | "nhc" `isPrefixOf` hc = Nhc98 | "ghc" `isPrefixOf` hc = Ghc | "hbc" `isPrefixOf` hc = Hbc | otherwise = Unknown hc -- | Emulate the shell `which` command. which :: (String->String) -> String -> IO String which exe cmd = let dir = dirname cmd in case dir of "" -> do -- search the shell environment PATH variable for candidates val <- getEnv "PATH" let psep = pathSep val dirs = splitPath psep "" val search <- foldM (\a dir-> testFile a (dir++'/': exe cmd)) Nothing dirs case search of Just x -> return x Nothing -> ioError (userError (cmd++" not found")) _ -> do f <- testFile Nothing (exe cmd) case f of Just x -> return x Nothing -> ioError (userError (cmd++" is not executable")) where splitPath :: Char -> String -> String -> [String] splitPath sep acc [] = [reverse acc] splitPath sep acc (c:path) | c==sep = reverse acc : splitPath sep "" path splitPath sep acc (c:path) = splitPath sep (c:acc) path pathSep s = if length (filter (==';') s) >0 then ';' else ':' testFile :: Maybe String -> String -> IO (Maybe String) testFile gotit@(Just _) path = return gotit testFile Nothing path = do ok <- doesFileExist path if ok then perms path else return Nothing perms file = do p <- getPermissions file return (if executable p then Just file else Nothing) -}