{-# LANGUAGE CPP, DeriveDataTypeable, RankNTypes, ScopedTypeVariables, StandaloneDeriving, TemplateHaskell #-}
{-# OPTIONS_GHC -Wall -fno-warn-orphans #-}
module Debian.GHC
( withCompilerVersion
, newestAvailable
, compilerIdFromDebianVersion
, compilerFlavorOption
, newestAvailableCompilerId
-- , ghcNewestAvailableVersion'
-- , ghcNewestAvailableVersion
-- , compilerIdFromDebianVersion
, hvrCabalVersion
, hvrHappyVersion
, hvrAlexVersion
, hvrCompilerPATH
, isHVRCompilerPackage
, withModifiedPATH
-- , CompilerChoice(..), hcVendor, hcFlavor
, compilerPackageName
#if MIN_VERSION_Cabal(1,22,0)
, getCompilerInfo
#endif
) where
#if !MIN_VERSION_base(4,8,0)
import Control.Applicative ((<$>))
#endif
import Control.DeepSeq (force)
import Control.Exception (SomeException, throw, try)
import Control.Lens (_2, over)
import Control.Monad.Trans (MonadIO, liftIO)
import Data.Char (isSpace, toLower, toUpper)
import Data.List (intercalate, isPrefixOf)
import Debian.Debianize.BinaryDebDescription (PackageType(..))
import Debian.Relation (BinPkgName(BinPkgName))
import Debian.Version (DebianVersion, parseDebianVersion')
import Distribution.Compiler (CompilerFlavor(..), CompilerId(CompilerId))
#if MIN_VERSION_Cabal(1,22,0)
import Distribution.Compiler (CompilerInfo(..), unknownCompilerInfo, AbiTag(NoAbiTag))
#endif
#if MIN_VERSION_Cabal(2,0,0)
import Data.Function.Memoize (deriveMemoizable, Memoizable, memoize, memoize2, memoizeFinite)
import Distribution.Version (mkVersion', mkVersion, showVersion, Version, versionNumbers)
import Data.Version (parseVersion)
import Data.Word (Word64)
#else
import Data.Function.Memoize (deriveMemoizable, memoize, memoize2)
import Data.Version (showVersion, Version(..), parseVersion)
#endif
import System.Console.GetOpt (ArgDescr(ReqArg), OptDescr(..))
import System.Directory (doesDirectoryExist)
import System.Environment (getEnv)
import System.Exit (ExitCode(ExitFailure, ExitSuccess))
-- import System.IO (hPutStrLn, stderr)
import System.IO.Error (isDoesNotExistError)
import System.IO.Unsafe (unsafePerformIO)
import System.Process (readProcess, showCommandForUser, readProcessWithExitCode)
import System.Posix.Env (setEnv)
import System.Unix.Chroot (useEnv, fchroot)
import System.Unix.Mount (WithProcAndSys)
import Text.ParserCombinators.ReadP (readP_to_S)
import Text.Read (readMaybe)
import Text.Regex.TDFA ((=~))
#if MIN_VERSION_Cabal(2,0,0)
instance Memoizable Word64 where memoize = memoizeFinite
#endif
$(deriveMemoizable ''CompilerFlavor)
$(deriveMemoizable ''Version)
$(deriveMemoizable ''BinPkgName)
-- | Up until now cabal-debian only worked with Debian's or Ubuntu's
-- ghc debs, which have binary package names ghc, ghc-prof, ghc-doc,
-- etc. This type is intended to add support for Herbert Valerio
-- Riedel's (hvr's) repository of several different versions of ghc
-- and supporting tools happy, alex and cabal. These have different
-- binary package names, and the packages put the executables in
-- different locations than the Debian (and Ubuntu) packages. This
-- option is activated when a directory such as /opt/ghc/8.0.1/bin is
-- present in $PATH and a ghc executable is found there.
--
-- This function decides whether a deb name is that of one of
-- debian/ubuntu's ghc packages or one of hvr's. If it is an hvr
-- package it returns the version number embedded in its name.
isHVRCompilerPackage :: CompilerFlavor -> BinPkgName -> Maybe Version
isHVRCompilerPackage hc (BinPkgName name) =
case isPrefixOf prefix name of
True -> toVersion (takeWhile (/= '-') (drop (length prefix) name))
False -> Nothing
where
prefix = map toLower (show hc) ++ "-"
toVersion :: String -> Maybe Version
toVersion s = case filter (all isSpace . snd) (readP_to_S parseVersion s) of
#if MIN_VERSION_Cabal(2,0,0)
[(v, _)] -> Just (mkVersion' v)
#else
[(v, _)] -> Just v
#endif
_ -> Nothing
withCompilerVersion :: FilePath -> CompilerFlavor -> (DebianVersion -> a) -> Either String a
withCompilerVersion root hc f = either Left (\v -> Right (f v)) (newestAvailableCompiler root hc)
-- | Return the a string containing the PATH environment variable value
-- suitable for using some version of ghc from hvr's compiler repo.
hvrCompilerPATH :: Version -> String -> String
hvrCompilerPATH v path0 =
intercalate ":" ["/opt/ghc/" ++ showVersion v ++ "/bin",
"/opt/cabal/" ++ showVersion (hvrCabalVersion v) ++ "/bin",
"/opt/happy/" ++ showVersion (hvrHappyVersion v) ++ "/bin",
"/opt/alex/" ++ showVersion (hvrAlexVersion v) ++ "/bin",
path0]
-- | What version of Cabal goes with this version of GHC?
hvrCabalVersion :: Version -> Version
#if MIN_VERSION_Cabal(2,0,0)
hvrCabalVersion v =
case versionNumbers v of
(m : n : _) | (m == 7 && n <= 7) || m < 7 -> mkVersion [1,16]
(7 : n : _) | n <= 9 -> mkVersion [1,18]
(7 : _) -> mkVersion [1,22]
_ -> mkVersion [1,24]
#else
hvrCabalVersion (Version (m : n : _) _) | (m == 7 && n <= 7) || m < 7 = Version [1,16] []
hvrCabalVersion (Version (7 : n : _) _) | n <= 9 = Version [1,18] []
hvrCabalVersion (Version (7 : _) _) = Version [1,22] []
hvrCabalVersion _ = Version [1,24] []
#endif
-- | What version of Happy goes with this version of GHC?
hvrHappyVersion :: Version -> Version
#if MIN_VERSION_Cabal(2,0,0)
hvrHappyVersion v =
case versionNumbers v of
(m : n : _) | (m == 7 && n <= 3) || m < 7 -> mkVersion [1,19,3]
(7 : n : _) | n <= 2 -> mkVersion [1,19,3]
_ -> mkVersion [1,19,5]
#else
hvrHappyVersion (Version (m : n : _) _) | (m == 7 && n <= 3) || m < 7 = Version [1,19,3] []
hvrHappyVersion (Version (7 : n : _) _) | n <= 2 = Version [1,19,3] []
hvrHappyVersion _ = Version [1,19,5] []
#endif
-- | What version of Alex goes with this version of GHC?
hvrAlexVersion :: Version -> Version
#if MIN_VERSION_Cabal(2,0,0)
hvrAlexVersion _ = mkVersion [3,1,7]
#else
hvrAlexVersion _ = Version [3,1,7] []
#endif
withModifiedPATH :: MonadIO m => (String -> String) -> m a -> m a
withModifiedPATH f action = do
path0 <- liftIO $ getEnv "PATH"
liftIO $ setEnv "PATH" (f path0) True
-- liftIO $ hPutStrLn stderr $ "*** withCompilerPath vendor=" ++ show vendor
-- liftIO $ hPutStrLn stderr $ "*** Setting $PATH to " ++ show path
r <- action
-- liftIO $ hPutStrLn stderr $ "*** Resetting $PATH to " ++ show path0
liftIO $ setEnv "PATH" path0 True
return r
-- | Memoized version of newestAvailable'
newestAvailable :: FilePath -> BinPkgName -> Either String DebianVersion
newestAvailable root pkg =
memoize2 f pkg root
where
f :: BinPkgName -> FilePath -> Either String DebianVersion
f pkg' root' = unsafePerformIO (newestAvailable' root' pkg')
-- | Look up the newest version of a deb available in the given changeroot.
newestAvailable' :: FilePath -> BinPkgName -> IO (Either String DebianVersion)
newestAvailable' root (BinPkgName name) = do
exists <- doesDirectoryExist root
case exists of
False -> return $ Left $ "newestAvailable: no such environment: " ++ show root
True -> do
versions <- try $ chroot root $
(readProcess "apt-cache" ["showpkg", name] "" >>=
return . dropWhile (/= "Versions: ") . lines) :: IO (Either SomeException [String])
case versions of
Left e -> return $ Left $ "newestAvailable failed in " ++ show root ++ ": " ++ show e
Right (_ : versionLine : _) -> return . Right . parseDebianVersion' . takeWhile (/= ' ') $ versionLine
Right x -> return $ Left $ "Unexpected result from apt-cache showpkg: " ++ show x
where
chroot "/" = id
chroot _ = useEnv root (return . force)
newestAvailableCompiler :: FilePath -> CompilerFlavor -> Either String DebianVersion
newestAvailableCompiler root hc = maybe (Left "No compiler package") (newestAvailable root) (compilerPackageName hc Development)
newestAvailableCompilerId :: FilePath -> CompilerFlavor -> Either String CompilerId
newestAvailableCompilerId root hc = either Left (Right . compilerIdFromDebianVersion hc) (newestAvailableCompiler root hc)
{-
-- | The IO portion of ghcVersion. For there to be no version of ghc
-- available is an exceptional condition, it has been standard in
-- Debian and Ubuntu for a long time.
ghcNewestAvailableVersion :: CompilerFlavor -> FilePath -> IO DebianVersion
ghcNewestAvailableVersion hc root = do
exists <- doesDirectoryExist root
when (not exists) (error $ "ghcVersion: no such environment: " ++ show root)
versions <- try $ chroot $
(readProcess "apt-cache" ["showpkg", map toLower (show hc)] "" >>=
return . dropWhile (/= "Versions: ") . lines) :: IO (Either SomeException [String])
case versions of
Left e -> error $ "ghcNewestAvailableVersion failed in " ++ show root ++ ": " ++ show e
Right (_ : versionLine : _) -> return . parseDebianVersion . takeWhile (/= ' ') $ versionLine
_ -> error $ "No version of ghc available in " ++ show root
where
chroot = case root of
"/" -> id
_ -> useEnv root (return . force)
-- | Memoize the CompilerId built for the newest available version of
-- the compiler package so we don't keep running apt-cache showpkg
-- over and over.
ghcNewestAvailableVersion' :: CompilerFlavor -> FilePath -> CompilerId
ghcNewestAvailableVersion' hc root =
memoize f (hc, root)
where
f :: (CompilerFlavor, FilePath) -> CompilerId
f (hc', root) = unsafePerformIO (g hc' root)
g hc root = do
ver <- ghcNewestAvailableVersion hc root
let cid = compilerIdFromDebianVersion ver
-- hPutStrLn stderr ("GHC Debian version: " ++ show ver ++ ", Compiler ID: " ++ show cid)
return cid
-}
compilerIdFromDebianVersion :: CompilerFlavor -> DebianVersion -> CompilerId
compilerIdFromDebianVersion hc debVersion =
#if MIN_VERSION_Cabal(2,0,0)
let ds = versionNumbers (greatestLowerBound debVersion (map (\ d -> mkVersion [d]) [0..])) in
CompilerId hc (greatestLowerBound debVersion (map (\ d -> mkVersion (ds ++ [d])) [0..]))
#else
let (Version ds ts) = greatestLowerBound debVersion (map (\ d -> Version [d] []) [0..]) in
CompilerId hc (greatestLowerBound debVersion (map (\ d -> Version (ds ++ [d]) ts) [0..]))
#endif
where
greatestLowerBound :: DebianVersion -> [Version] -> Version
greatestLowerBound b xs = last $ takeWhile (\ v -> parseDebianVersion' (showVersion v) < b) xs
-- | General function to build a command line option that reads most
-- of the possible values for CompilerFlavor.
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
-- Most of the constructors in CompilerFlavor are arity zero and
-- all caps, though two are capitalized - Hugs and Helium. This
-- won't read those, and it won't read HaskellSuite String or
-- OtherCompiler String
readHC :: String -> a -> a
readHC s = maybe (error $ "Invalid CompilerFlavor: " ++ show s) f (readMaybe (map toUpper s))
{-
debName :: CompilerFlavor -> Maybe BinPkgName
debName hc =
case map toLower (show hc) of
s | any isSpace s -> Nothing
s -> Just (BinPkgName s)
-}
-- | Compute the compiler package names by finding out what package
-- contains the corresponding executable.
compilerPackageName :: CompilerFlavor -> PackageType -> Maybe BinPkgName
compilerPackageName hc typ =
maybe Nothing (Just . finish) (compilerPackage hc)
where
finish (BinPkgName hcname) =
let isDebian = map toLower (show hc) == hcname in
-- hcname is the package that contains the compiler
-- executable. This will be ghc or ghcjs for Debian
-- packages, anything else is an hvr package.
case (hc, typ, isDebian) of
-- Debian puts the .haddock files in ghc-doc
(GHC, Documentation, True) -> BinPkgName (hcname ++ "-doc")
-- In HVR repo the .haddock files required to buid html
-- are in the main compiler package. However, the html
-- files in ghc-<version>-htmldocs are also needed to
-- create links.
(GHC, Documentation, False) -> BinPkgName (hcname ++ "-htmldocs")
(GHC, Profiling, _) -> BinPkgName (hcname ++ "-prof")
_ -> BinPkgName hcname
compilerPackage :: CompilerFlavor -> Maybe BinPkgName
compilerPackage GHC = filePackage "ghc"
#if MIN_VERSION_Cabal(1,22,0)
compilerPackage GHCJS = filePackage "ghcjs"
#endif
compilerPackage x = error $ "compilerPackage - unsupported CompilerFlavor: " ++ show x
{-
compilerExecutable :: CompilerFlavor -> String
compilerExecutable GHC = "ghc"
#if MIN_VERSION_Cabal(1,22,0)
compilerExecutable GHCJS = "ghcjs"
#endif
compilerExecutable x = error $ "compilerExecutable - unexpected flavor: " ++ show x
-}
filePackage :: FilePath -> Maybe BinPkgName
filePackage = memoize f
where
f :: FilePath -> Maybe BinPkgName
f p = unsafePerformIO (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 = do
(toPath . over _2 lines) <$> readProcessWithExitCode "which" [bin] ""
where
toPath :: (ExitCode, [String], String) -> Maybe String
toPath (ExitSuccess, [path], _) = Just path
toPath _ = Nothing
#if MIN_VERSION_Cabal(1,22,0)
-- | IO based alternative to newestAvailableCompilerId - install the
-- compiler into the chroot if necessary and ask it for its version
-- number. This has the benefit of working for ghcjs, which doesn't
-- make the base ghc version available in the version number.
getCompilerInfo :: MonadIO m => FilePath -> CompilerFlavor -> WithProcAndSys m (Either String CompilerInfo)
getCompilerInfo "/" flavor = liftIO $ getCompilerInfo' flavor
getCompilerInfo root flavor = liftIO $ fchroot root $ 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
#if MIN_VERSION_Cabal(1,22,0)
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"
#endif
_ -> 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"
#if MIN_VERSION_Cabal(1,22,0)
hcCommand GHCJS = "ghcjs"
#endif
hcCommand flavor = error $ "hcCommand - unexpected CompilerFlavor: " ++ show flavor
#endif