content: {-# 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"
  