module Distribution.Simple.UHC (
configure, getInstalledPackages,
buildLib, buildExe, installLib, registerPackage, inplacePackageDbPath
) where
import Prelude ()
import Distribution.Compat.Prelude
import Distribution.InstalledPackageInfo
import Distribution.Package hiding (installedUnitId)
import Distribution.PackageDescription
import Distribution.Simple.BuildPaths
import Distribution.Simple.Compiler
import Distribution.Simple.LocalBuildInfo
import Distribution.Simple.PackageIndex
import Distribution.Simple.Program
import Distribution.Simple.Utils
import Distribution.Pretty
import Distribution.Parsec
import Distribution.Types.MungedPackageId
import Distribution.Verbosity
import Distribution.Version
import Distribution.System
import Language.Haskell.Extension
import qualified Data.Map as Map ( empty )
import System.Directory
import System.FilePath
configure :: Verbosity -> Maybe FilePath -> Maybe FilePath
-> ProgramDb -> IO (Compiler, Maybe Platform, ProgramDb)
configure verbosity hcPath _hcPkgPath progdb = do
(_uhcProg, uhcVersion, progdb') <-
requireProgramVersion verbosity uhcProgram
(orLaterVersion (mkVersion [1,0,2]))
(userMaybeSpecifyPath "uhc" hcPath progdb)
let comp = Compiler {
compilerId = CompilerId UHC uhcVersion,
compilerAbiTag = NoAbiTag,
compilerCompat = [],
compilerLanguages = uhcLanguages,
compilerExtensions = uhcLanguageExtensions,
compilerProperties = Map.empty
}
compPlatform = Nothing
return (comp, compPlatform, progdb')
uhcLanguages :: [(Language, CompilerFlag)]
uhcLanguages = [(Haskell98, "")]
uhcLanguageExtensions :: [(Extension, Maybe CompilerFlag)]
uhcLanguageExtensions =
let doFlag (f, (enable, disable)) = [(EnableExtension f, enable),
(DisableExtension f, disable)]
alwaysOn = (Nothing, Nothing)
in concatMap doFlag
[(CPP, (Just "--cpp", Nothing)),
(PolymorphicComponents, alwaysOn),
(ExistentialQuantification, alwaysOn),
(ForeignFunctionInterface, alwaysOn),
(UndecidableInstances, alwaysOn),
(MultiParamTypeClasses, alwaysOn),
(Rank2Types, alwaysOn),
(PatternSignatures, alwaysOn),
(EmptyDataDecls, alwaysOn),
(ImplicitPrelude, (Nothing, Just "--no-prelude")),
(TypeOperators, alwaysOn),
(OverlappingInstances, alwaysOn),
(FlexibleInstances, alwaysOn)]
getInstalledPackages :: Verbosity -> Compiler -> PackageDBStack -> ProgramDb
-> IO InstalledPackageIndex
getInstalledPackages verbosity comp packagedbs progdb = do
let compilerid = compilerId comp
systemPkgDir <- getGlobalPackageDir verbosity progdb
userPkgDir <- getUserPackageDir
let pkgDirs = nub (concatMap (packageDbPaths userPkgDir systemPkgDir) packagedbs)
pkgs <- liftM (map addBuiltinVersions . concat) $
traverse (\ d -> getDirectoryContents d >>= filterM (isPkgDir (prettyShow compilerid) d))
pkgDirs
let iPkgs =
map mkInstalledPackageInfo $
concatMap parsePackage $
pkgs
return (fromList iPkgs)
getGlobalPackageDir :: Verbosity -> ProgramDb -> IO FilePath
getGlobalPackageDir verbosity progdb = do
output <- getDbProgramOutput verbosity
uhcProgram progdb ["--meta-pkgdir-system"]
let pkgdir = trimEnd output
return pkgdir
where
trimEnd = reverse . dropWhile isSpace . reverse
getUserPackageDir :: IO FilePath
getUserPackageDir = do
homeDir <- getHomeDirectory
return $ homeDir </> ".cabal" </> "lib"
packageDbPaths :: FilePath -> FilePath -> PackageDB -> [FilePath]
packageDbPaths user system db =
case db of
GlobalPackageDB -> [ system ]
UserPackageDB -> [ user ]
SpecificPackageDB path -> [ path ]
addBuiltinVersions :: String -> String
addBuiltinVersions xs = xs
installedPkgConfig :: String
installedPkgConfig = "installed-pkg-config"
isPkgDir :: String -> String -> String -> IO Bool
isPkgDir _ _ ('.' : _) = return False
isPkgDir c dir xs = do
let candidate = dir </> uhcPackageDir xs c
doesFileExist (candidate </> installedPkgConfig)
parsePackage :: String -> [PackageId]
parsePackage = toList . simpleParsec
mkInstalledPackageInfo :: PackageId -> InstalledPackageInfo
mkInstalledPackageInfo p = emptyInstalledPackageInfo
{ installedUnitId = mkLegacyUnitId p,
sourcePackageId = p }
buildLib :: Verbosity -> PackageDescription -> LocalBuildInfo
-> Library -> ComponentLocalBuildInfo -> IO ()
buildLib verbosity pkg_descr lbi lib clbi = do
systemPkgDir <- getGlobalPackageDir verbosity (withPrograms lbi)
userPkgDir <- getUserPackageDir
let runUhcProg = runDbProgram verbosity uhcProgram (withPrograms lbi)
let uhcArgs =
["--pkg-build=" ++ prettyShow (packageId pkg_descr)]
++ constructUHCCmdLine userPkgDir systemPkgDir
lbi (libBuildInfo lib) clbi
(buildDir lbi) verbosity
++ map (map (\ c -> if c == '.' then pathSeparator else c))
(map prettyShow (allLibModules lib clbi))
runUhcProg uhcArgs
return ()
buildExe :: Verbosity -> PackageDescription -> LocalBuildInfo
-> Executable -> ComponentLocalBuildInfo -> IO ()
buildExe verbosity _pkg_descr lbi exe clbi = do
systemPkgDir <- getGlobalPackageDir verbosity (withPrograms lbi)
userPkgDir <- getUserPackageDir
let runUhcProg = runDbProgram verbosity uhcProgram (withPrograms lbi)
let uhcArgs =
constructUHCCmdLine userPkgDir systemPkgDir
lbi (buildInfo exe) clbi
(buildDir lbi) verbosity
++ ["--output", buildDir lbi </> prettyShow (exeName exe)]
++ [modulePath exe]
runUhcProg uhcArgs
constructUHCCmdLine :: FilePath -> FilePath
-> LocalBuildInfo -> BuildInfo -> ComponentLocalBuildInfo
-> FilePath -> Verbosity -> [String]
constructUHCCmdLine user system lbi bi clbi odir verbosity =
(if verbosity >= deafening then ["-v4"]
else if verbosity >= normal then []
else ["-v0"])
++ hcOptions UHC bi
++ languageToFlags (compiler lbi) (defaultLanguage bi)
++ extensionsToFlags (compiler lbi) (usedExtensions bi)
++ ["--hide-all-packages"]
++ uhcPackageDbOptions user system (withPackageDB lbi)
++ ["--package=uhcbase"]
++ ["--package=" ++ prettyShow (mungedName pkgid) | (_, pkgid) <- componentPackageDeps clbi ]
++ ["-i" ++ odir]
++ ["-i" ++ l | l <- nub (hsSourceDirs bi)]
++ ["-i" ++ autogenComponentModulesDir lbi clbi]
++ ["-i" ++ autogenPackageModulesDir lbi]
++ ["--optP=" ++ opt | opt <- cppOptions bi]
++ ["--odir=" ++ odir]
++ (case withOptimization lbi of
NoOptimisation -> ["-O0"]
NormalOptimisation -> ["-O1"]
MaximumOptimisation -> ["-O2"])
uhcPackageDbOptions :: FilePath -> FilePath -> PackageDBStack -> [String]
uhcPackageDbOptions user system db = map (\ x -> "--pkg-searchpath=" ++ x)
(concatMap (packageDbPaths user system) db)
installLib :: Verbosity -> LocalBuildInfo
-> FilePath -> FilePath -> FilePath
-> PackageDescription -> Library -> ComponentLocalBuildInfo -> IO ()
installLib verbosity _lbi targetDir _dynlibTargetDir builtDir pkg _library _clbi = do
installDirectoryContents verbosity (builtDir </> prettyShow (packageId pkg)) targetDir
uhcTarget, uhcTargetVariant :: String
uhcTarget = "bc"
uhcTargetVariant = "plain"
uhcPackageDir :: String -> String -> FilePath
uhcPackageSubDir :: String -> FilePath
uhcPackageDir pkgid compilerid = pkgid </> uhcPackageSubDir compilerid
uhcPackageSubDir compilerid = compilerid </> uhcTarget </> uhcTargetVariant
registerPackage
:: Verbosity
-> Compiler
-> ProgramDb
-> PackageDBStack
-> InstalledPackageInfo
-> IO ()
registerPackage verbosity comp progdb packageDbs installedPkgInfo = do
dbdir <- case registrationPackageDB packageDbs of
GlobalPackageDB -> getGlobalPackageDir verbosity progdb
UserPackageDB -> getUserPackageDir
SpecificPackageDB dir -> return dir
let pkgdir = dbdir </> uhcPackageDir (prettyShow pkgid) (prettyShow compilerid)
createDirectoryIfMissingVerbose verbosity True pkgdir
writeUTF8File (pkgdir </> installedPkgConfig)
(showInstalledPackageInfo installedPkgInfo)
where
pkgid = sourcePackageId installedPkgInfo
compilerid = compilerId comp
inplacePackageDbPath :: LocalBuildInfo -> FilePath
inplacePackageDbPath lbi = buildDir lbi