-----------------------------------------------------------------------------
-- |
-- Module : Config
-- Copyright : Malcolm Wallace
--
-- Maintainer : Malcolm Wallace <Malcolm.Wallace@cs.york.ac.uk>
-- Stability : Stable
-- Portability : All
--
-- Handles compiler configuration information, both globally and
-- locally. Does reading & writing of configuration files, etc.
-----------------------------------------------------------------------------
module Config where
import Compiler
import System (ExitCode(..),exitWith,getEnv)
import Directory (doesFileExist,doesDirectoryExist,createDirectory
,getPermissions,Permissions(..))
import Monad (when)
import List (nub,isPrefixOf)
import Platform (unsafePerformIO,exe,escape,windows)
import RunAndReadStdout (runAndReadStdout, basename, dirname)
import Char (isDigit)
import Monad (foldM)
import IO (stderr)
#ifdef __HBC__
import IOMisc (hPutStrLn)
#else
import IO (hPutStrLn)
#endif
----
data PersonalConfig = PersonalConfig
{ globalConfig :: HmakeConfig
, localConfig :: Maybe HmakeConfig
}
defaultComp :: PersonalConfig -> FilePath
defaultComp conf =
case localConfig conf of
Just local -> defaultCompiler local
Nothing -> defaultCompiler (globalConfig conf)
knownComps :: PersonalConfig -> [CompilerConfig]
knownComps conf =
case localConfig conf of
Just local -> nub (knownCompilers local ++ globals)
Nothing -> globals
where
globals = knownCompilers (globalConfig conf)
----
data HmakeConfig = HmakeConfig
{ defaultCompiler :: FilePath
, knownCompilers :: [CompilerConfig]
}
deriving (Eq,Read)
data CompilerConfig = CompilerConfig
{ compilerStyle :: HC
, compilerPath :: FilePath
, compilerVersion :: String
, includePaths :: [FilePath]
, cppSymbols :: [String]
, extraCompilerFlags :: [String]
, isHaskell98 :: Bool
}
| DynCompiler { compilerPath :: FilePath }
deriving (Read)
-- Expand a dynamically-specified compiler by doing the configure step.
unDyn :: CompilerConfig -> IO CompilerConfig
unDyn (DynCompiler path) = configure path
unDyn cc = return cc
instance Eq CompilerConfig where -- equality on filename only
cc1 == cc2 = compilerPath cc1 == compilerPath cc2
instance Show CompilerConfig where
showsPrec p (DynCompiler hc) =
showString "DynCompiler { compilerPath = " . shows hc .showString " }\n"
showsPrec p cc =
showString "CompilerConfig"
. showString "\n { compilerStyle = " . shows (compilerStyle cc)
. showString "\n , compilerPath = " . shows (compilerPath cc)
. showString "\n , compilerVersion = " . shows (compilerVersion cc)
. showString "\n , includePaths = " . showPaths (includePaths cc)
. showString "\n , cppSymbols = " . shows (cppSymbols cc)
. showString "\n , extraCompilerFlags = "
. shows (extraCompilerFlags cc)
. showString "\n , isHaskell98 = " . shows (isHaskell98 cc)
. showString "\n }\n"
where
showPaths [] = showString "[]"
showPaths [x] = showChar '[' . shows x . showChar ']'
showPaths (x:xs) = showString "[" . shows x . showl xs
where
showl [] = showChar '\n'
. showString (take 23 (repeat ' '))
. showChar ']'
showl (x:xs) = showChar '\n'
. showString (take 23 (repeat ' '))
. showChar ',' . shows x . showl xs
showList [] = showString " []"
showList (x:xs) = showString "\n [ " . showsPrec 0 x . showl xs
where showl [] = showString " ]"
showl (x:xs) = showString " , " . showsPrec 0 x . showl xs
instance Show HmakeConfig where
showsPrec p hmc = showString "HmakeConfig\n { defaultCompiler = "
. shows (defaultCompiler hmc)
. showString "\n , knownCompilers ="
. showList (knownCompilers hmc)
. showString "\n }\n"
----
-- | Suck in a single configuration file. (Uses unsafePerformIO.)
readConfig :: FilePath -> HmakeConfig
readConfig file = unsafePerformIO (safeReadConfig file)
-- | A safe version of "readConfig". Sucks in a single configuration file,
-- ensuring it parses correctly.
safeReadConfig :: FilePath -> IO HmakeConfig
safeReadConfig file = do
f <- catch (readFile file)
(\e-> error ("Config file "++file++" does not exist.\n"
++" Try running 'hmake-config new' first."))
config <- saferead file f
return config
where
-- ensure the value read from the file is fully evaluated
saferead :: FilePath -> String -> IO HmakeConfig
saferead path s =
let val = case [x | (x,t) <- reads s, ("","") <- lex t] of
[x] -> x
[] -> error ("hmake-config: can't parse config file '"
++ path++"'")
_ -> error ("hmake-config: ambiguous parse of config '"
++ path++"'")
in (return $! val)
-- | Read the user's complete configuration.
readPersonalConfig :: (FilePath,Maybe FilePath) -- ^ (global, local)
-> IO PersonalConfig
readPersonalConfig (global,local) = do
g <- safeReadConfig global
l <- case local of
Just lo -> do l <- safeReadConfig lo
return (Just l)
Nothing -> return Nothing
return PersonalConfig { globalConfig = g , localConfig = l }
-- | Use getEnv to find the configuration location. (Uses unsafePerformIO)
defaultConfigLocation :: Bool -- ^ Create the directory if it doesn't exist.
-> (FilePath, Maybe FilePath)
defaultConfigLocation create = unsafePerformIO $ do
machine <- getEnv "MACHINE"
global <- getEnv "HMAKECONFDIR"
let g = global++"/"++machine++"/hmakerc"
catch (do home <- getEnv "HOME"
let dir = home ++ "/.hmakerc"
loc = dir ++"/"++ machine
exists <- doesFileExist loc
if exists
then return (g, Just loc)
else if create then
do ok <- doesDirectoryExist dir
when (not ok) (createDirectory dir)
return (g, Just loc)
else return (g, Nothing))
(\e-> return (g, Nothing))
matchCompiler :: String -> PersonalConfig -> CompilerConfig
matchCompiler hc conf =
case localConfig conf of
Just local -> foldr search global (knownCompilers local)
Nothing -> global
where
search comp other = if compilerPath comp == hc then comp else other
global = foldr search
(error ("hmake: the compiler '"++hc++"' is not known.\n"))
(knownCompilers (globalConfig conf))
compilerKnown :: String -> PersonalConfig -> Bool
compilerKnown hc config =
any (\comp -> compilerPath comp == hc) known
where
known = knownCompilers (globalConfig config) ++
case localConfig config of
Just l -> knownCompilers l
Nothing -> []
usualCompiler :: PersonalConfig -> CompilerConfig
usualCompiler config = matchCompiler def config
where def = case localConfig config of
Just l -> defaultCompiler l
Nothing -> defaultCompiler (globalConfig config)
{-
matchCompiler :: String -> HmakeConfig -> CompilerConfig
matchCompiler hc config =
foldr (\comp other-> if compilerPath comp == hc then comp else other)
(error ("hmake: the compiler '"++hc++"' is not known.\n"))
(knownCompilers config)
compilerKnown :: String -> HmakeConfig -> Bool
compilerKnown hc config =
any (\comp -> compilerPath comp == hc) (knownCompilers config)
usualCompiler :: HmakeConfig -> CompilerConfig
usualCompiler config = matchCompiler (defaultCompiler config) config
-}
-- | configure for each style of compiler
configure :: String -> IO CompilerConfig
configure path = do kind <- hcStyle path
configure' kind path
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 -> IO HC
hcStyle path =
case toCompiler (basename path) of
Unknown hc -> do x <- runAndReadStdout
(path++" 2>&1 | head -n 1 | cut -c1-3")
return (case toCompiler x of
Unknown _ -> Unknown hc
y -> y)
s -> return s
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)
|
