module Debian.GHC
( withCompilerVersion
, newestAvailable
, compilerIdFromDebianVersion
, compilerFlavorOption
, newestAvailableCompilerId
) where
import Control.DeepSeq (force)
import Control.Exception (SomeException, try)
import Control.Monad (when)
import Data.Char (toLower, toUpper, isSpace)
import Data.Function.Memoize (deriveMemoizable, memoize2)
import Data.Maybe (fromMaybe)
import Data.Version (showVersion, Version(Version))
import Debian.Relation (BinPkgName(BinPkgName))
import Debian.Version (DebianVersion, parseDebianVersion)
import Distribution.Compiler (CompilerId(CompilerId), CompilerFlavor(..))
import System.Console.GetOpt
import System.Directory (doesDirectoryExist)
import System.IO.Unsafe (unsafePerformIO)
import System.Process (readProcess)
import System.Unix.Chroot (useEnv)
import Text.Read (readMaybe)
$(deriveMemoizable ''CompilerFlavor)
$(deriveMemoizable ''BinPkgName)
withCompilerVersion :: CompilerFlavor -> FilePath -> (DebianVersion -> a) -> a
withCompilerVersion hc root f = f (newestAvailableCompiler hc root)
newestAvailable :: BinPkgName -> FilePath -> Maybe DebianVersion
newestAvailable pkg root =
memoize2 f pkg root
where
f :: BinPkgName -> FilePath -> Maybe DebianVersion
f pkg' root' = unsafePerformIO (newestAvailable' pkg' root')
newestAvailable' :: BinPkgName -> FilePath -> IO (Maybe DebianVersion)
newestAvailable' (BinPkgName name) root = do
exists <- doesDirectoryExist root
when (not exists) (error $ "newestAvailable: no such environment: " ++ show root)
versions <- try $ chroot root $
(readProcess "apt-cache" ["showpkg", name] "" >>=
return . dropWhile (/= "Versions: ") . lines) :: IO (Either SomeException [String])
case versions of
Left e -> error $ "newestAvailable failed in " ++ show root ++ ": " ++ show e
Right (_ : versionLine : _) -> return . Just . parseDebianVersion . takeWhile (/= ' ') $ versionLine
_ -> return Nothing
where
chroot "/" = id
chroot _ = useEnv root (return . force)
newestAvailableCompiler :: CompilerFlavor -> FilePath -> DebianVersion
newestAvailableCompiler hc root =
case debName hc of
Nothing -> error $ "newestAvailableCompiler - Unsupported CompilerFlavor: " ++ show hc
Just pkg -> fromMaybe (error $ "newestAvailableCompiler - No versions of " ++ show hc ++ " available in " ++ show root) (newestAvailable pkg root)
newestAvailableCompilerId :: CompilerFlavor -> FilePath -> CompilerId
newestAvailableCompilerId hc root = compilerIdFromDebianVersion hc (newestAvailableCompiler hc root)
compilerIdFromDebianVersion :: CompilerFlavor -> DebianVersion -> CompilerId
compilerIdFromDebianVersion hc debVersion =
let (Version ds ts) = greatestLowerBound debVersion (map (\ d -> Version [d] []) [0..]) in
CompilerId hc (greatestLowerBound debVersion (map (\ d -> Version (ds ++ [d]) ts) [0..]))
#if MIN_VERSION_Cabal(1,21,0)
Nothing
#endif
where
greatestLowerBound :: DebianVersion -> [Version] -> Version
greatestLowerBound b xs = last $ takeWhile (\ v -> parseDebianVersion (showVersion 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))
debName :: CompilerFlavor -> Maybe BinPkgName
debName hc =
case map toLower (show hc) of
s | any isSpace s -> Nothing
s -> Just (BinPkgName s)