{-# LANGUAGE RankNTypes, ScopedTypeVariables #-}
{-# OPTIONS_GHC -Wall -fno-warn-orphans #-}
module Debian.GHC
( withCompilerVersion
, newestAvailable
, compilerIdFromDebianVersion
, compilerFlavorOption
, newestAvailableCompilerId
, withModifiedPATH
, compilerPackageName
, getCompilerInfo
) where
import Control.Exception (SomeException, throw, try)
import Control.Lens (_2, over)
import Control.Monad ((<=<))
import Control.Monad.Trans (MonadIO, liftIO)
import Data.Char (isSpace, toLower, toUpper)
import Data.List (intercalate)
import Debian.Debianize.BinaryDebDescription (PackageType(..))
import Debian.Relation (BinPkgName(BinPkgName))
import Debian.Version (DebianVersion, parseDebianVersion')
import Distribution.Compiler (CompilerFlavor(..), CompilerId(CompilerId))
import Distribution.Compiler (CompilerInfo(..), unknownCompilerInfo, AbiTag(NoAbiTag))
import Distribution.Pretty (prettyShow)
import Distribution.Version (mkVersion', mkVersion, Version, versionNumbers)
import Data.Version (parseVersion)
import System.Console.GetOpt (ArgDescr(ReqArg), OptDescr(..))
import System.Environment (getEnv)
import System.Exit (ExitCode(ExitFailure, ExitSuccess))
import System.IO.Error (isDoesNotExistError)
import System.Process (readProcess, showCommandForUser, readProcessWithExitCode)
import System.Posix.Env (setEnv)
import Text.ParserCombinators.ReadP (readP_to_S)
import Text.Read (readMaybe)
import Text.Regex.TDFA ((=~))
import UnliftIO.Memoize (memoizeMVar, runMemoized, Memoized)
toVersion :: String -> Maybe Version
toVersion s = case filter (all isSpace . snd) (readP_to_S parseVersion s) of
[(v, _)] -> Just (mkVersion' v)
_ -> Nothing
withCompilerVersion :: CompilerFlavor -> (DebianVersion -> a) -> IO (Either String a)
withCompilerVersion hc f = newestAvailableCompiler hc >>= \nac -> return (fmap f nac)
withModifiedPATH :: MonadIO m => (String -> String) -> m a -> m a
withModifiedPATH f action = do
path0 <- liftIO $ getEnv "PATH"
liftIO $ setEnv "PATH" (f path0) True
r <- action
liftIO $ setEnv "PATH" path0 True
return r
newestAvailable :: BinPkgName -> IO (Memoized (Either String DebianVersion))
newestAvailable pkg = memoizeMVar (f pkg)
where
f :: BinPkgName -> IO (Either String DebianVersion)
f = newestAvailable'
newestAvailable' :: BinPkgName -> IO (Either String DebianVersion)
newestAvailable' (BinPkgName name) = do
versions <- try $ dropWhile (/= "Versions: ") . lines <$> readProcess "apt-cache" ["showpkg", name] "" :: IO (Either SomeException [String])
case versions of
Left e -> return $ Left $ "newestAvailable failed: " ++ show e
Right (_ : versionLine : _) -> return . Right . parseDebianVersion' . takeWhile (/= ' ') $ versionLine
Right x -> return $ Left $ "Unexpected result from apt-cache showpkg: " ++ show x
newestAvailableCompiler :: CompilerFlavor -> IO (Either String DebianVersion)
newestAvailableCompiler hc = maybe (return (Left "No compiler package")) (runMemoized <=< newestAvailable) =<< compilerPackageName hc Development
newestAvailableCompilerId :: CompilerFlavor -> IO (Either String CompilerId)
newestAvailableCompilerId hc = fmap (compilerIdFromDebianVersion hc) <$> newestAvailableCompiler hc
compilerIdFromDebianVersion :: CompilerFlavor -> DebianVersion -> CompilerId
compilerIdFromDebianVersion hc debVersion =
let ds = versionNumbers (greatestLowerBound debVersion (map (\ d -> mkVersion [d]) [0..])) in
CompilerId hc (greatestLowerBound debVersion (map (\ d -> mkVersion (ds ++ [d])) [0..]))
where
greatestLowerBound :: DebianVersion -> [Version] -> Version
greatestLowerBound b xs = last $ takeWhile (\ v -> parseDebianVersion' (prettyShow v) < b) xs
compilerFlavorOption :: forall a. (CompilerFlavor -> a -> a) -> OptDescr (a -> a)
compilerFlavorOption f =
Option [] ["hc", "compiler-flavor"] (ReqArg readHC "COMPILER") "Build packages using this Haskell compiler"
where
readHC :: String -> a -> a
readHC s = maybe (error $ "Invalid CompilerFlavor: " ++ show s) f (readMaybe (map toUpper s))
compilerPackageName :: CompilerFlavor -> PackageType -> IO (Maybe BinPkgName)
compilerPackageName hc typ = do
mcp <- compilerPackage hc
return $ fmap finish mcp
where
finish (BinPkgName hcname) =
let isDebian = map toLower (show hc) == hcname in
case (hc, typ, isDebian) of
(GHC, Documentation, True) -> BinPkgName (hcname ++ "-doc")
(GHC, Documentation, False) -> BinPkgName (hcname ++ "-htmldocs")
(GHC, Profiling, _) -> BinPkgName (hcname ++ "-prof")
_ -> BinPkgName hcname
compilerPackage :: CompilerFlavor -> IO (Maybe BinPkgName)
compilerPackage GHC = filePackage "ghc" >>= runMemoized
compilerPackage GHCJS = filePackage "ghcjs" >>= runMemoized
compilerPackage x = error $ "compilerPackage - unsupported CompilerFlavor: " ++ show x
filePackage :: FilePath -> IO (Memoized (Maybe BinPkgName))
filePackage = memoizeMVar . f
where
f :: FilePath -> IO (Maybe BinPkgName)
f p = which p >>= maybe (return Nothing) (\x -> package <$> readProcess "dpkg-query" ["-S", x] "")
package :: String -> Maybe BinPkgName
package s =
case s =~ "^(.*): .*$" :: (String, String, String, [String]) of
(_, _, _, [name]) -> Just (BinPkgName name)
_ -> Nothing
which :: String -> IO (Maybe FilePath)
which bin = toPath . over _2 lines <$> readProcessWithExitCode "which" [bin] ""
where
toPath :: (ExitCode, [String], String) -> Maybe String
toPath (ExitSuccess, [path], _) = Just path
toPath _ = Nothing
getCompilerInfo :: MonadIO m => CompilerFlavor -> m (Either String CompilerInfo)
getCompilerInfo flavor = liftIO $ getCompilerInfo' flavor
getCompilerInfo' :: CompilerFlavor -> IO (Either String CompilerInfo)
getCompilerInfo' flavor = do
r <- try $ readProcessWithExitCode (hcCommand flavor) ["--numeric-version"] ""
case r of
Left e | isDoesNotExistError e -> return $ Left $ "getCompilerInfo - " ++ show e
Left e -> throw e
Right r'@(ExitFailure _, _, _) ->
error $ processErrorMessage "getCompilerInfo" (hcCommand flavor) ["--numeric-version"] r'
Right (_, out, _) -> do
let compilerId = maybe (error $ "Parse error in version string: " ++ show out) (CompilerId flavor) (toVersion out)
compilerCompat <- case flavor of
GHCJS -> do
(r' :: Either IOError (ExitCode, String, String)) <- try $ readProcessWithExitCode (hcCommand flavor) ["--numeric-ghc-version"] ""
case r' of
Right (ExitSuccess, out', _) ->
maybe (error $ "getCompilerInfo - parse error in version string: " ++ show out') (return . Just . (: []) . CompilerId GHC) (toVersion out')
_ -> error "getCompilerInfo - failure computing compilerCompat"
_ -> return Nothing
return $ Right $ (unknownCompilerInfo compilerId NoAbiTag) {compilerInfoCompat = compilerCompat}
processErrorMessage :: String -> String -> [String] -> (ExitCode, String, String) -> String
processErrorMessage msg cmd args (ExitFailure n, out, err) =
msg ++ " - " ++ showCommandForUser cmd args ++ " -> " ++ show n ++ "\n stdout: " ++ indent out ++ "\n stderr: " ++ indent err
where
indent :: String -> String
indent = intercalate "\n " . lines
processErrorMessage _msg _cmd _args (ExitSuccess, _out, _err) = ""
hcCommand :: CompilerFlavor -> String
hcCommand GHC = "ghc"
hcCommand GHCJS = "ghcjs"
hcCommand flavor = error $ "hcCommand - unexpected CompilerFlavor: " ++ show flavor