{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE DeriveDataTypeable #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module IdeSession.Cabal ( buildDeps, externalDeps , configureAndBuild, configureAndHaddock , generateMacros, buildDotCabal , runComponentCc , BuildExeArgs(..), RunCcArgs(..), LicenseArgs(..) , ExeCabalRequest(..), ExeCabalResponse(..) , buildLicsFromPkgs ) where import Control.Applicative ((<$>), (<*>)) import Control.Monad import Data.Binary import Data.Function (on) import Data.List hiding (find) import Data.Maybe (catMaybes, fromMaybe, isNothing) import Data.Monoid (Monoid(..)) import Data.Proxy import Data.Time import Data.Typeable (Typeable) import Data.Version (Version (..), parseVersion) import System.Directory (removeFile, doesFileExist) import System.Exit (ExitCode (ExitSuccess, ExitFailure), exitFailure) import System.FilePath import System.FilePath.Find (find, always, extension) import System.IO import System.IO.Error (isUserError, catchIOError) import System.IO.Temp (createTempDirectory) import Text.ParserCombinators.ReadP (readP_to_S) import qualified Control.Exception as Ex import qualified Data.ByteString.Lazy as BSL import qualified Data.ByteString.Lazy.Char8 as BSL8 import qualified Data.Map as Map import qualified Data.Text as Text import qualified Language.Haskell.Extension as Haskell import qualified Language.Haskell.TH.Syntax as TH import Distribution.License (License (..)) import Distribution.PackageDescription import Distribution.PackageDescription.PrettyPrint (showGenericPackageDescription) import Distribution.ParseUtils import Distribution.Simple (PackageDBStack) import Distribution.Simple.Build.Macros import Distribution.Simple.Configure (configure) import Distribution.Simple.LocalBuildInfo (LocalBuildInfo) import Distribution.Simple.PackageIndex ( lookupSourcePackageId ) import Distribution.Simple.PreProcess (PPSuffixHandler) import Distribution.Simple.Program.Builtin (ghcPkgProgram) import Distribution.Simple.Program.Db (configureAllKnownPrograms, requireProgram) import Distribution.Simple.Utils (createDirectoryIfMissingVerbose) import Distribution.System (buildPlatform) import Distribution.Verbosity (silent) import Distribution.Version (anyVersion, thisVersion) import qualified Distribution.Compiler as Compiler import qualified Distribution.InstalledPackageInfo as InstInfo import qualified Distribution.ModuleName import qualified Distribution.Package as Package import qualified Distribution.Simple.Build as Build import qualified Distribution.Simple.Compiler as Simple.Compiler import qualified Distribution.Simple.GHC as GHC import qualified Distribution.Simple.Haddock as Haddock import qualified Distribution.Simple.LocalBuildInfo as BuildInfo import qualified Distribution.Simple.Program as Cabal.Program import qualified Distribution.Simple.Program.GHC as GHC import qualified Distribution.Simple.Program.HcPkg as HcPkg import qualified Distribution.Simple.Setup as Setup import qualified Distribution.Text import qualified Distribution.Utils.NubList as NubList import IdeSession.GHC.API (cExtensions, cHeaderExtensions) import IdeSession.Licenses ( bsd3, gplv2, gplv3, lgpl2, lgpl3, apache20 ) import IdeSession.State import IdeSession.Strict.Container import IdeSession.Strict.Maybe (just) import IdeSession.Types.Progress import IdeSession.Types.Public import IdeSession.Types.Translation import IdeSession.Util import qualified IdeSession.Strict.List as StrictList import qualified IdeSession.Strict.Map as StrictMap -- TODO: factor out common parts of exe building and haddock generation -- after Cabal and the code that calls it are improved not to require -- the configure step, etc. pkgNameMain :: Package.PackageName pkgNameMain = Package.PackageName "main" -- matches the import default pkgVersionMain :: Version pkgVersionMain = Version [1, 0] [] pkgDescFromName :: String -> Version -> PackageDescription pkgDescFromName pkgName version = PackageDescription { -- the following are required by all packages: package = Package.PackageIdentifier { pkgName = Package.PackageName pkgName , pkgVersion = version } , license = AllRightsReserved -- dummy , licenseFiles = [] , copyright = "" , maintainer = "" , author = "" , stability = "" , testedWith = [] , homepage = "" , pkgUrl = "" , bugReports = "" , sourceRepos = [] , synopsis = "" , description = "" , category = "" , customFieldsPD = [] , buildDepends = [] -- probably ignored , specVersionRaw = Left $ Version [1, 14, 0] [] , buildType = Just Simple -- components , library = Nothing -- ignored inside @GenericPackageDescription@ , executables = [] -- ignored when inside @GenericPackageDescription@ , testSuites = [] , benchmarks = [] , dataFiles = [] -- for now, we don't mention files from managedData? , dataDir = "" -- for now we don't put ideDataDir? , extraSrcFiles = [] , extraTmpFiles = [] , extraDocFiles = [] } pkgDesc :: PackageDescription pkgDesc = pkgDescFromName "main" pkgVersionMain bInfo :: [FilePath] -> [String] -> [FilePath] -> [FilePath] -> BuildInfo bInfo hsSourceDirs ghcOpts cSources installIncludes = emptyBuildInfo { buildable = True , defaultLanguage = Just Haskell.Haskell2010 , options = [(Simple.Compiler.GHC, realGhcOptions)] , ccOptions = actuallyCcOptions , otherExtensions = [Haskell.EnableExtension Haskell.TemplateHaskell] -- TODO: specify in SessionConfig? , hsSourceDirs , cSources , installIncludes } where -- Cabal does not pass ghc-options to ghc when compiling C code, so we -- must split these options out and explicitly pass them as options for the -- C compiler. -- -- See https://github.com/fpco/ide-backend/issues/218 and -- https://github.com/haskell/cabal/pull/2043 actuallyCcOptions, realGhcOptions :: [String] (actuallyCcOptions, realGhcOptions) = let (cOpts, hsOpts) = partition isCcOpt ghcOpts in (map (drop 5) cOpts, hsOpts) isCcOpt :: String -> Bool isCcOpt = isPrefixOf "-optc" -- @relative@ is a hack, because when building, we need an absolute path -- (so that ghc sees the .c files), but .cabal files need a relative path -- (and that's enough for 'cabal install', since the package dir -- will have both the .cabal and the C sources, unlike the directories -- we build exes in). getCSources :: Bool -> [FilePath] -> IO [FilePath] getCSources relative [sourceDir] = do files <- find always ((`elem` cExtensions) `liftM` extension) sourceDir return $ if relative then map (makeRelative sourceDir) files else files getCSources _ _sourceDirs = fail $ "getCSources: wrong sourceDir: " ++ intercalate ", " _sourceDirs getCHeaders :: [FilePath] -> IO [FilePath] getCHeaders [sourceDir] = fmap (map takeFileName) $ find always ((`elem` cHeaderExtensions) `liftM` extension) sourceDir getCHeaders _sourceDirs = fail $ "getCHeaders: wrong sourceDir: " ++ intercalate ", " _sourceDirs -- TODO: this works OK if @(m, path)@ are simple, @updateRelativeIncludes@ -- includes @""@ and/or the @Main@ module is in @Main.hs@. -- For more complex cases we'd need extensive exotic tests and then perhaps -- also more complex code that searches @updateRelativeIncludes@ paths, etc. -- I'd rather wait until we fix cabal/GHC not to require "Main" in "./Main.hs" -- and then simplify this and other code instead. exeDesc :: [FilePath] -> [FilePath] -> FilePath -> [String] -> (ModuleName, FilePath) -> IO Executable exeDesc ideSourcesDir ideSourcesDirForC ideDistDir ghcOpts (m, path) = do cSources <- getCSources False ideSourcesDirForC cHeaders <- getCHeaders ideSourcesDirForC let exeName = Text.unpack m if exeName == "Main" then do -- that's what Cabal expects, no wrapper needed return $ Executable { exeName , modulePath = path , buildInfo = bInfo ideSourcesDir ghcOpts cSources cHeaders } else do -- TODO: Verify @path@ somehow. mDir <- createTempDirectory ideDistDir exeName -- Cabal insists on "Main" and on ".hs". let modulePath = mDir "Main.hs" wrapper = "import qualified " ++ exeName ++ "\n" ++ "main = " ++ exeName ++ ".main" writeFile modulePath wrapper return $ Executable { exeName , modulePath , buildInfo = bInfo [mDir] ghcOpts cSources cHeaders } libDesc :: Bool -> [FilePath] -> [FilePath] -> [String] -> [Distribution.ModuleName.ModuleName] -> IO Library libDesc relative ideSourcesDir ideSourcesDirForC ghcOpts ms = do cSources <- getCSources relative ideSourcesDirForC cHeaders <- getCHeaders ideSourcesDirForC return $ Library { exposedModules = ms , libExposed = False , libBuildInfo = bInfo ideSourcesDir ghcOpts cSources cHeaders -- These are new fields. TODO: Do we give them the right values? , reexportedModules = [] , requiredSignatures = [] , exposedSignatures = [] } -- TODO: we could do the parsing early and export parsed Versions via our API, -- but we'd need to define our own strict internal variant of Version, etc. parseVersionString :: Monad m => String -> m Version parseVersionString versionString = do let parser = readP_to_S parseVersion case [ v | (v, "") <- parser versionString] of [v] -> return v _ -> fail $ "parseVersionString: can't parse package version: " ++ versionString externalDeps :: Monad m => [PackageId] -> m [Package.Dependency] externalDeps pkgs = let depOfName :: Monad m => PackageId -> m (Maybe Package.Dependency) depOfName PackageId{packageName, packageVersion = Nothing} = do let packageN = Package.PackageName $ Text.unpack $ packageName if packageN == pkgNameMain then return Nothing else return $ Just $ Package.Dependency packageN anyVersion depOfName PackageId{packageName, packageVersion = Just versionText} = do let packageN = Package.PackageName $ Text.unpack $ packageName versionString = Text.unpack versionText version <- parseVersionString versionString return $ Just $ Package.Dependency packageN (thisVersion version) in liftM catMaybes $ mapM depOfName pkgs mkConfFlags :: FilePath -> PackageDBStack -> [FilePath] -> Setup.ConfigFlags mkConfFlags ideDistDir configPackageDBStack progPathExtra = (Setup.defaultConfigFlags (defaultProgramConfiguration progPathExtra)) { Setup.configDistPref = Setup.Flag ideDistDir , Setup.configUserInstall = Setup.Flag False , Setup.configVerbosity = Setup.Flag minBound -- @Nothing@ wipes out default, initial DBs. , Setup.configPackageDBs = Nothing : map Just configPackageDBStack , Setup.configProgramPathExtra = NubList.toNubList progPathExtra } configureAndBuild :: BuildExeArgs -> [(ModuleName, FilePath)] -> IO ExitCode configureAndBuild BuildExeArgs{ bePackageDBStack = configPackageDBStack , beExtraPathDirs = configExtraPathDirs , beSourcesDir = ideSourcesDir , beDistDir = ideDistDir , beRelativeIncludes = relativeIncludes , beGhcOpts = ghcOpts , beLibDeps = libDeps , beLoadedMs = loadedMs , .. } ms = do -- We need to make sure the user never loses any error message. -- Therefore we never wipe out such files in the midst of ide-backend -- operation, but only at the start of user-triggered commands, -- after he had full access to the previous content of the files. beStderrLogExists <- doesFileExist beStderrLog when beStderrLogExists $ removeFile beStderrLog let mainDep = Package.Dependency pkgNameMain anyVersion exeDeps = mainDep : libDeps sourcesDirs = map (\path -> ideSourcesDir path) relativeIncludes executables <- mapM (exeDesc sourcesDirs [ideSourcesDir] ideDistDir ghcOpts) ms let condExe exe = (exeName exe, CondNode exe exeDeps []) condExecutables = map condExe executables mainFileExistsInDir dir = do hsFound <- doesFileExist $ dir "Main.hs" lhsFound <- doesFileExist $ dir "Main.lhs" return $! hsFound || lhsFound mainFileChecks <- mapM mainFileExistsInDir sourcesDirs let mainFileExists = or mainFileChecks -- Cabal can't find the code of @Main@ (to be used as the main executable -- module) in subdirectories or in @Foo.hs@. We need a @Main@ to build -- an executable, so any other @Main@ modules have to be ignored. -- So, if another module depends on such a @Main@, -- we're in trouble, but if the @Main@ is only an executable, we are fine. -- Michael said in https://github.com/fpco/fpco/issues/1049 -- "We'll be handling the disambiguation of Main modules ourselves before -- passing the files to you, so that shouldn't be an ide-backend concern.", -- so perhaps there won't be any problems. let soundMs | mainFileExists = loadedMs | otherwise = delete (Text.pack "Main") loadedMs projectMs = map (Distribution.ModuleName.fromString . Text.unpack) soundMs library <- libDesc False sourcesDirs [ideSourcesDir] ghcOpts projectMs let gpDesc = GenericPackageDescription { packageDescription = pkgDesc , genPackageFlags = [] -- seem unused , condLibrary = Just $ CondNode library libDeps [] , condExecutables , condTestSuites = [] , condBenchmarks = [] } confFlags = mkConfFlags ideDistDir configPackageDBStack configExtraPathDirs -- We don't override most build flags, but use configured values. buildFlags = Setup.defaultBuildFlags { Setup.buildDistPref = Setup.Flag ideDistDir , Setup.buildVerbosity = Setup.Flag $ toEnum 1 } preprocessors :: [PPSuffixHandler] preprocessors = [] hookedBuildInfo = (Nothing, []) -- we don't want to use hooks let confAndBuild = do lbi <- configure (gpDesc, hookedBuildInfo) confFlags -- Setting @withPackageDB@ here is too late, @configure@ would fail -- already. Hence we set it in @mkConfFlags@ (can be reverted, -- when/if we construct @lbi@ without @configure@). Build.build (BuildInfo.localPkgDescr lbi) lbi buildFlags preprocessors -- Handle various exceptions and stderr printouts. exitCode :: Either ExitCode () <- redirectStderr beStderrLog $ Ex.try $ catchIOError confAndBuild $ \e -> if isUserError e then do -- In the new cabal code some exceptions are handled with 'die', -- raising a user error, while some still do 'exit 1' and print to -- stderr. For uniformity, we redirect user errors to stderr, as -- well. hPutStrLn stderr $ "Exception caught:" hPutStrLn stderr $ show e exitFailure else ioError e return $! either id (const ExitSuccess) exitCode configureAndHaddock :: BuildExeArgs -> IO ExitCode configureAndHaddock BuildExeArgs{ bePackageDBStack = configPackageDBStack , beExtraPathDirs = configExtraPathDirs , beSourcesDir = ideSourcesDir , beDistDir = ideDistDir , beRelativeIncludes = relativeIncludes , beGhcOpts = ghcOpts , beLibDeps = libDeps , beLoadedMs = loadedMs , .. } = do beStderrLogExists <- doesFileExist beStderrLog when beStderrLogExists $ removeFile beStderrLog let condExecutables = [] sourcesDirs = map (\path -> ideSourcesDir path) relativeIncludes mainFileExistsInDir dir = do hsFound <- doesFileExist $ dir "Main.hs" lhsFound <- doesFileExist $ dir "Main.lhs" return $! hsFound || lhsFound mainFileChecks <- mapM mainFileExistsInDir sourcesDirs let mainFileExists = or mainFileChecks -- Cabal can't find the code of @Main@, except in the main dir. -- See the comment above. let soundMs | mainFileExists = loadedMs | otherwise = delete (Text.pack "Main") loadedMs projectMs = map (Distribution.ModuleName.fromString . Text.unpack) soundMs library <- libDesc False sourcesDirs [ideSourcesDir] ghcOpts projectMs let gpDesc = GenericPackageDescription { packageDescription = pkgDesc , genPackageFlags = [] -- seem unused , condLibrary = Just $ CondNode library libDeps [] , condExecutables , condTestSuites = [] , condBenchmarks = [] } confFlags = mkConfFlags ideDistDir configPackageDBStack configExtraPathDirs preprocessors :: [PPSuffixHandler] preprocessors = [] haddockFlags = Setup.defaultHaddockFlags { Setup.haddockDistPref = Setup.Flag ideDistDir , Setup.haddockHtml = Setup.Flag True , Setup.haddockHoogle = Setup.Flag True , Setup.haddockVerbosity = Setup.Flag minBound } hookedBuildInfo = (Nothing, []) -- we don't want to use hooks let confAndBuild = do lbi <- configure (gpDesc, hookedBuildInfo) confFlags Haddock.haddock (BuildInfo.localPkgDescr lbi) lbi preprocessors haddockFlags -- Handle various exceptions and stderr printouts. exitCode :: Either ExitCode () <- redirectStderr beStderrLog $ Ex.try $ catchIOError confAndBuild $ \e -> if isUserError e then do -- In the new cabal code some exceptions are handled with 'die', -- raising a user error, while some still do 'exit 1' and print to -- stderr. For uniformity, we redirect user errors to stderr, as -- well. hPutStrLn stderr $ "Exception caught:" hPutStrLn stderr $ show e exitFailure else ioError e return $! either id (const ExitSuccess) exitCode buildDotCabal :: FilePath -> [FilePath] -> [String] -> Computed -> IO (String -> Version -> BSL.ByteString) buildDotCabal ideSourcesDir relativeIncludes ghcOpts computed = do (loadedMs, pkgs) <- buildDeps $ just computed libDeps <- externalDeps pkgs -- We ignore any @Main@ modules (even in subdirectories or in @Foo.hs@) -- so that they don't get in the way when we build an executable -- using the library. So, if another module depends on such a @Main@, -- we're in trouble, but if the @Main@ is only an executable, we are fine. -- Michael said in https://github.com/fpco/fpco/issues/1049 -- "We'll be handling the disambiguation of Main modules ourselves before -- passing the files to you, so that shouldn't be an ide-backend concern.", -- so perhaps there won't be any problems. let soundMs = delete (Text.pack "Main") loadedMs projectMs = sort $ map (Distribution.ModuleName.fromString . Text.unpack) soundMs library <- libDesc True -- relative C files paths (filter (/= "") relativeIncludes) [ideSourcesDir] ghcOpts projectMs let libE = library {libExposed = True} gpDesc libName version = GenericPackageDescription { packageDescription = pkgDescFromName libName version , genPackageFlags = [] -- seem unused , condLibrary = Just $ CondNode libE libDeps [] , condExecutables = [] , condTestSuites = [] , condBenchmarks = [] } return $ \libName version -> BSL8.pack $ showGenericPackageDescription $ gpDesc libName version lFieldDescrs :: [FieldDescr (Maybe License, Maybe FilePath, Maybe String)] lFieldDescrs = [ simpleField "license" Distribution.Text.disp parseLicenseQ (\(t1, _, _) -> fromMaybe BSD3 t1) (\l (_, t2, t3) -> (Just l, t2, t3)) , simpleField "license-file" showFilePath parseFilePathQ (\(_, t2, _) -> fromMaybe "" t2) (\lf (t1, _, t3) -> (t1, Just lf, t3)) , simpleField "author" showFreeText parseFreeText (\(_, _, t3) -> fromMaybe "???" t3) (\a (t1, t2, _) -> (t1, t2, Just a)) ] -- | Build the concatenation of all license files from a given list -- of packages. See 'buildLicenses'. buildLicsFromPkgs :: Bool -> LicenseArgs -> IO ExitCode buildLicsFromPkgs logProgress LicenseArgs{ liPackageDBStack = configPackageDBStack , liExtraPathDirs = configExtraPathDirs , liLicenseExc = configLicenseExc , liDistDir = ideDistDir , liStdoutLog = stdoutLogFN , liStderrLog = stderrLogFN , licenseFixed , liCabalsDir = cabalsDir , liPkgs = pkgs } = do -- Note that @liStderrLog@ is removed in @openBinaryFile@ below. -- The following computations are very expensive, so should be done once, -- instead of at each invocation of @findLicense@ that needs to perform -- @lookupSourcePackageId@. programDB <- configureAllKnownPrograms -- won't die minBound (defaultProgramConfiguration configExtraPathDirs) pkgIndex <- GHC.getInstalledPackages minBound configPackageDBStack programDB let licensesFN = ideDistDir "licenses.txt" -- result stderrLog <- openBinaryFile stderrLogFN WriteMode licensesFile <- openBinaryFile licensesFN WriteMode -- The file containing concatenated licenses for core components. let bsCore = BSL8.pack $(TH.runIO (BSL.readFile "CoreLicenses.txt") >>= TH.lift . BSL8.unpack) BSL.hPut licensesFile bsCore let numSteps = length pkgs mainPackageName = Text.pack "main" printProgress step packageName = when logProgress $ putStrLn $ "[" ++ show step ++ " of " ++ show numSteps ++ "] " ++ Text.unpack packageName f :: (PackageId, Int) -> IO () f (PackageId{packageName}, step) | packageName == mainPackageName = printProgress step packageName f (PackageId{..}, step) = do let nameString = Text.unpack packageName packageFile = cabalsDir nameString ++ ".cabal" versionString = maybe "" Text.unpack packageVersion version <- parseVersionString versionString let _outputWarns :: [PWarning] -> IO () _outputWarns [] = return () _outputWarns warns = do let warnMsg = "Parse warnings for " ++ packageFile ++ ":\n" ++ unlines (map (showPWarning packageFile) warns) hPutStrLn stderrLog warnMsg cabalFileExists <- doesFileExist packageFile if cabalFileExists then do hPutStrLn licensesFile $ "\nLicense for " ++ nameString ++ ":\n" pkgS <- readFile packageFile let parseResult = parseFields lFieldDescrs (Nothing, Nothing, Nothing) pkgS findLicense parseResult nameString version packageFile else case lookup nameString licenseFixed of Just fixedLicense -> do hPutStrLn licensesFile $ "\nLicense for " ++ nameString ++ ":\n" let fakeParseResult = ParseOk undefined fixedLicense findLicense fakeParseResult nameString version packageFile Nothing -> unless (nameString `elem` configLicenseExc) $ do let errorMsg = "No .cabal file provided for package " ++ nameString ++ " so no license can be found." hPutStrLn licensesFile errorMsg hPutStrLn stderrLog errorMsg printProgress step packageName findLicense :: ParseResult (Maybe License, Maybe FilePath, Maybe String) -> String -> Version -> FilePath -> IO () findLicense parseResult nameString version packageFile = -- We can't use @parsePackageDescription@, because it defaults to -- AllRightsReserved and we default to BSD3. It's very hard -- to use the machinery from the inside of @parsePackageDescription@, -- so instead we use the much simpler @ParseUtils.parseFields@. -- The downside is that we are much less past- and future-proof -- against .cabal format changes. The upside is @parseFields@ -- is faster and does not care about most parsing errors -- the .cabal file may (appear to) have. case parseResult of ParseFailed err -> do hPutStrLn licensesFile $ snd $ locatedErrorMsg err hPutStrLn stderrLog $ snd $ locatedErrorMsg err ParseOk _warns (_, Just lf, _) -> do -- outputWarns warns -- false positives let pkgId = Package.PackageIdentifier { pkgName = Package.PackageName nameString , pkgVersion = version } pkgInfos = lookupSourcePackageId pkgIndex pkgId case pkgInfos of InstInfo.InstalledPackageInfo{InstInfo.haddockInterfaces = hIn : _} : _ -> do -- Since the license file path can't be specified -- in InstalledPackageInfo, we can only guess what it is -- and we do that on the basis of the haddock interfaces path. -- TODO: on next rewrite (and re-testing), base it on htmldir let candidatePaths = [ iterate takeDirectory hIn !! 2 -- covers cabal default case: htmldir = docdir/html , takeDirectory hIn -- covers case where htmldir = docdir, for in-place , iterate takeDirectory hIn !! 5 -- covers another case for in-place packages ] tryPaths (p : ps) = do -- The directory of the license file is ignored -- in installed packages, hence @takeFileName@. let loc = p takeFileName lf exists <- doesFileExist loc if exists then do bs <- BSL.readFile loc BSL.hPut licensesFile bs else tryPaths ps tryPaths [] = do let errorMsg = "Package " ++ nameString ++ " has no license file in path " ++ concat (intersperse " nor " candidatePaths) ++ ". Haddock interfaces path (from, e.g., --haddockdir or --docdir) is " ++ hIn ++ "." hPutStrLn licensesFile errorMsg hPutStrLn stderrLog errorMsg tryPaths candidatePaths _ -> do let errorMsg = "Package " ++ nameString ++ " not properly installed." ++ "\n" ++ show pkgInfos hPutStrLn licensesFile errorMsg hPutStrLn stderrLog errorMsg ParseOk _warns (l, Nothing, mauthor) -> do -- outputWarns warns -- false positives when (isNothing l) $ do let warnMsg = "WARNING: Package " ++ packageFile ++ " has no license nor license file specified." hPutStrLn stderrLog warnMsg let license = fromMaybe BSD3 l author = fromMaybe "???" mauthor ms <- licenseText license author case ms of Nothing -> do let errorMsg = "No license text can be found for package " ++ nameString ++ "." hPutStrLn licensesFile errorMsg hPutStrLn stderrLog errorMsg Just s -> do hPutStr licensesFile s let assumed = if isNothing l then " and the assumed" else ", but" warnMsg = "WARNING: No license file specified for package " ++ packageFile ++ assumed ++ " license is " ++ show license ++ ". Reproducing standard license text." hPutStrLn stderrLog warnMsg res <- Ex.try $ mapM_ f (zip pkgs [1..]) hClose stderrLog hClose licensesFile let handler :: Ex.IOException -> IO ExitCode handler e = do let msg = "Licenses concatenation failed. The exception is:\n" ++ show e writeFile stderrLogFN msg return $ ExitFailure 1 either handler (const $ return ExitSuccess) res -- Gives a list of all modules and a list of all transitive package -- dependencies of the currently loaded project. buildDeps :: Strict Maybe Computed -> IO ([ModuleName], [PackageId]) buildDeps mcomputed = do case toLazyMaybe mcomputed of Nothing -> fail "This session state does not admit artifact generation." Just Computed{..} -> do let loadedMs = toLazyList computedLoadedModules imp m = do let mdeps = fmap (toLazyList . StrictList.map (removeExplicitSharing Proxy computedCache)) $ StrictMap.lookup m computedPkgDeps missing = fail $ "Module '" ++ Text.unpack m ++ "' not loaded." return $ fromMaybe missing mdeps imps <- mapM imp loadedMs return $ (nub $ sort $ loadedMs, nub $ sort $ concat imps) licenseText :: License -> String -> IO (Maybe String) licenseText license author = do year <- getYear return $! case license of BSD3 -> Just $ bsd3 author (show year) (GPL (Just (Version {versionBranch = [2]}))) -> Just gplv2 (GPL (Just (Version {versionBranch = [3]}))) -> Just gplv3 (LGPL (Just (Version {versionBranch = [2]}))) -> Just lgpl2 (LGPL (Just (Version {versionBranch = [3]}))) -> Just lgpl3 (Apache (Just (Version {versionBranch = [2, 0]}))) -> Just apache20 _ -> Nothing getYear :: IO Integer getYear = do u <- getCurrentTime z <- getCurrentTimeZone let l = utcToLocalTime z u (y, _, _) = toGregorian $ localDay l return y generateMacros :: PackageDBStack -> [FilePath] -> IO String generateMacros configPackageDBStack configExtraPathDirs = do let verbosity = silent (_ghcPkg, ghcConf) <- requireProgram verbosity ghcPkgProgram (defaultProgramConfiguration configExtraPathDirs) let hcPkgInfo = GHC.hcPkgInfo ghcConf pkgidss <- mapM (HcPkg.list hcPkgInfo verbosity) configPackageDBStack let newestPkgs = map last . groupBy ((==) `on` Package.packageName) . sort . concat $ pkgidss return $ generatePackageVersionMacros newestPkgs defaultProgramConfiguration :: [FilePath] -> Cabal.Program.ProgramConfiguration defaultProgramConfiguration configExtraPathDirs = Cabal.Program.setProgramSearchPath ( Cabal.Program.ProgramSearchPathDefault : map Cabal.Program.ProgramSearchPathDir configExtraPathDirs ) Cabal.Program.defaultProgramConfiguration localBuildInfo :: FilePath -> PackageDBStack -> [FilePath] -> LocalBuildInfo localBuildInfo buildDir withPackageDB configExtraPathDirs = BuildInfo.LocalBuildInfo { BuildInfo.withPackageDB , BuildInfo.withOptimization = Simple.Compiler.NormalOptimisation , BuildInfo.hostPlatform = buildPlatform , BuildInfo.withPrograms = defaultProgramConfiguration configExtraPathDirs , BuildInfo.withProfLib = False , BuildInfo.withSharedLib = False , BuildInfo.compiler = Simple.Compiler.Compiler -- TODO: Why is it okay that we always say 7.4.2 here? { compilerId = Compiler.CompilerId Compiler.GHC (Version [7, 4, 2] []) , compilerLanguages = error "compilerLanguages not defined" , compilerExtensions = error "compilerExtensions not defined" -- TOOD: new fields , compilerAbiTag = error "compilerAbiTag not defined" , compilerCompat = error "compilerCompat not defined" , compilerProperties = Map.empty -- Must be defined } , BuildInfo.buildDir , BuildInfo.configFlags = error "BuildInfo.configFlags not defined" , BuildInfo.extraConfigArgs = error "BuildInfo.extraConfigArgs not defined" , BuildInfo.installDirTemplates = error "BuildInfo.installDirTemplates not defined" , BuildInfo.componentsConfigs = error "BuildInfo.componentsConfigs not defined" , BuildInfo.installedPkgs = error "BuildInfo.installedPkgs not defined" , BuildInfo.pkgDescrFile = error "BuildInfo.pkgDescrFile not defined" , BuildInfo.localPkgDescr = error "BuildInfo.localPkgDescr not defined" , BuildInfo.withVanillaLib = error "BuildInfo.withVanillaLib not defined" , BuildInfo.withDynExe = error "BuildInfo.withDynExe not defined" , BuildInfo.withProfExe = error "BuildInfo.withProfExe not defined" , BuildInfo.withGHCiLib = error "BuildInfo.withGHCiLib not defined" , BuildInfo.splitObjs = error "BuildInfo.splitObjs not defined" , BuildInfo.stripExes = error "BuildInfo.stripExes not defined" , BuildInfo.progPrefix = error "BuildInfo.progPrefix not defined" , BuildInfo.progSuffix = error "BuildInfo.progSuffix not defined" -- TODO: New fields , BuildInfo.pkgKey = error "BuildInfo.pkgKey not defined" , BuildInfo.instantiatedWith = error "BuildInfo.instantiatedWith not defined" , BuildInfo.withDebugInfo = Simple.Compiler.NoDebugInfo -- must be defined , BuildInfo.stripLibs = error "BuildInfo.stripLibs not defined" , BuildInfo.relocatable = error "BuildInfo.relocatable not defined" } -- | Run gcc via ghc, with correct parameters. -- Copied from bits and pieces of @Distribution.Simple.GHC@. runComponentCc :: RunCcArgs -> IO ExitCode runComponentCc RunCcArgs{ rcPackageDBStack = configPackageDBStack , rcExtraPathDirs = configExtraPathDirs , rcDistDir = ideDistDir , rcAbsC = absC , rcAbsObj = absObj , rcPref = pref , rcIncludeDirs = includeDirs , .. } = do rcStderrLogExists <- doesFileExist rcStderrLog when rcStderrLogExists $ removeFile rcStderrLog exitCode <- redirectStderr rcStderrLog $ Ex.try $ do createDirectoryIfMissingVerbose verbosity True odir (ghcProg, _) <- requireProgram verbosity Cabal.Program.ghcProgram (BuildInfo.withPrograms lbi) let runGhcProg = GHC.runGHC verbosity ghcProg comp runGhcProg vanillaCcOpts -- TH always needs default libs, even when building for profiling -- TODO: Should we detect the use of TH in a different way? let doingTH = Haskell.EnableExtension Haskell.TemplateHaskell `elem` allExtensions libBi isGhcDynamic = GHC.isDynamic comp forceSharedLib = doingTH && isGhcDynamic whenProfLib = when (BuildInfo.withProfLib lbi) whenSharedLib forceShared = when (forceShared || BuildInfo.withSharedLib lbi) whenSharedLib forceSharedLib (runGhcProg sharedCcOpts) whenProfLib (runGhcProg profCcOpts) return $! either id (\() -> ExitSuccess) exitCode where verbosity = silent buildDir = ideDistDir -- TODO: create dist.23412/build? see cabalMacrosLocation lbi = localBuildInfo buildDir configPackageDBStack configExtraPathDirs comp = BuildInfo.compiler lbi libBi = emptyBuildInfo{includeDirs} -- TODO: set ccOptions? odir = Setup.fromFlag (GHC.ghcOptObjDir vanillaCcOpts) -- a stub, this would be expensive (lookups in pkgIndex); -- TODO: is it needed? e.g., for C calling into Haskell? clbi = BuildInfo.LibComponentLocalBuildInfo [] [] Map.empty [] -- Construct CC options for various kinds of flavours vanillaCcOpts = (GHC.componentCcGhcOptions verbosity lbi libBi clbi pref absC) `mappend` mempty { -- ghc ignores -odir for .o files coming from .c files GHC.ghcOptExtra = NubList.toNubListR $ ["-o", absObj] ++ rcOptions, GHC.ghcOptFPic = Setup.toFlag True } profCcOpts = vanillaCcOpts `mappend` mempty { GHC.ghcOptProfilingMode = Setup.toFlag True, GHC.ghcOptObjSuffix = Setup.toFlag "p_o" } sharedCcOpts = vanillaCcOpts `mappend` mempty { GHC.ghcOptDynLinkMode = Setup.toFlag GHC.GhcDynamicOnly, GHC.ghcOptObjSuffix = Setup.toFlag "dyn_o", GHC.ghcOptExtra = NubList.toNubListR ["-o", replaceExtension absObj "dyn_o"] } data BuildExeArgs = BuildExeArgs { bePackageDBStack :: PackageDBStack , beExtraPathDirs :: [FilePath] , beSourcesDir :: FilePath , beDistDir :: FilePath , beStdoutLog :: FilePath , beStderrLog :: FilePath , beRelativeIncludes :: [FilePath] , beGhcOpts :: [String] , beLibDeps :: [Package.Dependency] , beLoadedMs :: [ModuleName] } data RunCcArgs = RunCcArgs { rcPackageDBStack :: PackageDBStack , rcExtraPathDirs :: [FilePath] , rcDistDir :: FilePath , rcStdoutLog :: FilePath , rcStderrLog :: FilePath , rcAbsC :: FilePath , rcAbsObj :: FilePath , rcPref :: FilePath , rcIncludeDirs :: [FilePath] , rcOptions :: [String] } data LicenseArgs = LicenseArgs { -- | 3 fields from session configuration liPackageDBStack :: PackageDBStack , liExtraPathDirs :: [FilePath] , liLicenseExc :: [String] -- | the working directory; the resulting file is written there , liDistDir :: FilePath , liStdoutLog :: FilePath , liStderrLog :: FilePath -- | see 'configLicenseFixed' , licenseFixed :: [( String , (Maybe License, Maybe FilePath, Maybe String) )] -- | the directory with all the .cabal files , liCabalsDir :: FilePath -- | the list of packages to process , liPkgs :: [PackageId] } data ExeCabalRequest = ReqExeBuild BuildExeArgs [(ModuleName, FilePath)] | ReqExeDoc BuildExeArgs | ReqExeCc RunCcArgs | ReqExeLic LicenseArgs deriving Typeable data ExeCabalResponse = ExeCabalProgress Progress | ExeCabalDone ExitCode deriving Typeable instance Binary ExeCabalRequest where put (ReqExeBuild buildArgs ms) = putWord8 0 >> put buildArgs >> put ms put (ReqExeDoc buildArgs) = putWord8 1 >> put buildArgs put (ReqExeCc ccArgs) = putWord8 2 >> put ccArgs put (ReqExeLic licenseArgs) = putWord8 3 >> put licenseArgs get = do header <- getWord8 case header of 0 -> ReqExeBuild <$> get <*> get 1 -> ReqExeDoc <$> get 2 -> ReqExeCc <$> get 3 -> ReqExeLic <$> get _ -> fail "ExeCabalRequest.get: invalid header" instance Binary ExeCabalResponse where put (ExeCabalProgress progress) = putWord8 0 >> put progress put (ExeCabalDone exitCode) = putWord8 1 >> put exitCode get = do header <- getWord8 case header of 0 -> ExeCabalProgress <$> get 1 -> ExeCabalDone <$> get _ -> fail "ExeCabalResponse.get: invalid header" instance Binary BuildExeArgs where put BuildExeArgs{..} = do put bePackageDBStack put beExtraPathDirs put beSourcesDir put beDistDir put beStdoutLog put beStderrLog put beRelativeIncludes put beGhcOpts put beLibDeps put beLoadedMs get = BuildExeArgs <$> get <*> get <*> get <*> get <*> get <*> get <*> get <*> get <*> get <*> get instance Binary RunCcArgs where put RunCcArgs{..} = do put rcPackageDBStack put rcExtraPathDirs put rcDistDir put rcStdoutLog put rcStderrLog put rcAbsC put rcAbsObj put rcPref put rcIncludeDirs put rcOptions get = RunCcArgs <$> get <*> get <*> get <*> get <*> get <*> get <*> get <*> get <*> get <*> get instance Binary LicenseArgs where put LicenseArgs{..} = do put liPackageDBStack put liExtraPathDirs put liLicenseExc put liDistDir put liStdoutLog put liStderrLog put licenseFixed put liCabalsDir put liPkgs get = LicenseArgs <$> get <*> get <*> get <*> get <*> get <*> get <*> get <*> get <*> get instance Binary ExitCode where put ExitSuccess = putWord8 0 put (ExitFailure code) = putWord8 1 >> put code get = do header <- getWord8 case header of 0 -> return ExitSuccess 1 -> ExitFailure <$> get _ -> fail "ExitCode.get: invalid header"