{-# LANGUAGE NoImplicitPrelude   #-}
{-# LANGUAGE CPP                 #-}
{-# LANGUAGE DataKinds           #-}
{-# LANGUAGE FlexibleContexts    #-}
{-# LANGUAGE FlexibleInstances   #-}
{-# LANGUAGE OverloadedStrings   #-}
{-# LANGUAGE RecordWildCards     #-}
{-# LANGUAGE ScopedTypeVariables #-}

-- | Dealing with Cabal.

module Stack.Package
  ( readDotBuildinfo
  , resolvePackage
  , packageFromPackageDescription
  , Package (..)
  , PackageDescriptionPair (..)
  , GetPackageOpts (..)
  , PackageConfig (..)
  , buildLogPath
  , PackageException (..)
  , resolvePackageDescription
  , packageDependencies
  , applyForceCustomBuild
  ) where

import           Data.List ( unzip )
import qualified Data.Map.Strict as M
import qualified Data.Set as S
import qualified Data.Text as T
import           Distribution.CabalSpecVersion
import           Distribution.Compiler
import           Distribution.Package
                   hiding
                     ( Package, packageName, packageVersion, PackageIdentifier )
import           Distribution.PackageDescription hiding ( FlagName )
#if !MIN_VERSION_Cabal(3,8,1)
import           Distribution.PackageDescription.Parsec
#endif
import           Distribution.Pretty ( prettyShow )
#if MIN_VERSION_Cabal(3,8,1)
import           Distribution.Simple.PackageDescription ( readHookedBuildInfo )
#endif
import           Distribution.System ( OS (..), Arch, Platform (..) )
import           Distribution.Text ( display )
import qualified Distribution.Types.CondTree as Cabal
import qualified Distribution.Types.ExeDependency as Cabal
import qualified Distribution.Types.LegacyExeDependency as Cabal
import           Distribution.Types.MungedPackageName
import qualified Distribution.Types.UnqualComponentName as Cabal
import           Distribution.Utils.Path ( getSymbolicPath )
import           Distribution.Verbosity ( silent )
import           Distribution.Version ( mkVersion, orLaterVersion, anyVersion )
import           Path as FL hiding ( replaceExtension )
import           Path.Extra
import           Path.IO hiding ( findFiles )
import           Stack.Build.Installed
import           Stack.Constants
import           Stack.Constants.Config
import           Stack.Prelude hiding ( Display (..) )
import           Stack.Types.Compiler
import           Stack.Types.Config
import           Stack.Types.GhcPkgId
import           Stack.Types.NamedComponent
import           Stack.Types.Package
import           Stack.Types.Version
import           System.FilePath ( replaceExtension )
import           Stack.Types.Dependency ( DepValue (..), DepType (..) )
import           Stack.Types.PackageFile
                   ( GetPackageFileContext (..), DotCabalPath
                   , GetPackageFiles (..)
                   )
import           Stack.PackageFile ( packageDescModulesAndFiles )
import           Stack.ComponentFile
-- | Read @<package>.buildinfo@ ancillary files produced by some Setup.hs hooks.
-- The file includes Cabal file syntax to be merged into the package description
-- derived from the package's Cabal file.
--
-- NOTE: not to be confused with BuildInfo, an Stack-internal datatype.
readDotBuildinfo :: MonadIO m
                 => Path Abs File
                 -> m HookedBuildInfo
readDotBuildinfo buildinfofp =
    liftIO $ readHookedBuildInfo silent (toFilePath buildinfofp)

-- | Resolve a parsed Cabal file into a 'Package', which contains all of
-- the info needed for Stack to build the 'Package' given the current
-- configuration.
resolvePackage :: PackageConfig
               -> GenericPackageDescription
               -> Package
resolvePackage packageConfig gpkg =
    packageFromPackageDescription
        packageConfig
        (genPackageFlags gpkg)
        (resolvePackageDescription packageConfig gpkg)

packageFromPackageDescription :: PackageConfig
                              -> [PackageFlag]
                              -> PackageDescriptionPair
                              -> Package
packageFromPackageDescription packageConfig pkgFlags (PackageDescriptionPair pkgNoMod pkg) =
    Package
    { packageName = name
    , packageVersion = pkgVersion pkgId
    , packageLicense = licenseRaw pkg
    , packageDeps = deps
    , packageFiles = pkgFiles
    , packageUnknownTools = unknownTools
    , packageGhcOptions = packageConfigGhcOptions packageConfig
    , packageCabalConfigOpts = packageConfigCabalConfigOpts packageConfig
    , packageFlags = packageConfigFlags packageConfig
    , packageDefaultFlags = M.fromList
      [(flagName flag, flagDefault flag) | flag <- pkgFlags]
    , packageAllDeps = M.keysSet deps
    , packageLibraries =
        let mlib = do
              lib <- library pkg
              guard $ buildable $ libBuildInfo lib
              Just lib
         in
          case mlib of
            Nothing -> NoLibraries
            Just _ -> HasLibraries foreignLibNames
    , packageInternalLibraries = subLibNames
    , packageTests = M.fromList
      [(T.pack (Cabal.unUnqualComponentName $ testName t), testInterface t)
          | t <- testSuites pkgNoMod
          , buildable (testBuildInfo t)
      ]
    , packageBenchmarks = S.fromList
      [T.pack (Cabal.unUnqualComponentName $ benchmarkName b)
          | b <- benchmarks pkgNoMod
          , buildable (benchmarkBuildInfo b)
      ]
        -- Same comment about buildable applies here too.
    , packageExes = S.fromList
      [T.pack (Cabal.unUnqualComponentName $ exeName biBuildInfo)
        | biBuildInfo <- executables pkg
                                    , buildable (buildInfo biBuildInfo)]
    -- This is an action used to collect info needed for "stack ghci".
    -- This info isn't usually needed, so computation of it is deferred.
    , packageOpts = GetPackageOpts $
      \installMap installedMap omitPkgs addPkgs cabalfp ->
           do (componentsModules,componentFiles,_,_) <- getPackageFiles pkgFiles cabalfp
              let internals = S.toList $ internalLibComponents $ M.keysSet componentsModules
              excludedInternals <- mapM (parsePackageNameThrowing . T.unpack) internals
              mungedInternals <- mapM (parsePackageNameThrowing . T.unpack .
                                       toInternalPackageMungedName) internals
              componentsOpts <-
                  generatePkgDescOpts installMap installedMap
                  (excludedInternals ++ omitPkgs) (mungedInternals ++ addPkgs)
                  cabalfp pkg componentFiles
              pure (componentsModules,componentFiles,componentsOpts)
    , packageHasExposedModules = maybe
          False
          (not . null . exposedModules)
          (library pkg)
    , packageBuildType = buildType pkg
    , packageSetupDeps = msetupDeps
    , packageCabalSpec = specVersion pkg
    }
  where
    extraLibNames = S.union subLibNames foreignLibNames

    subLibNames
      = S.fromList
      $ map (T.pack . Cabal.unUnqualComponentName)
      $ mapMaybe (libraryNameString . libName) -- this is a design bug in the Cabal API: this should statically be known to exist
      $ filter (buildable . libBuildInfo)
      $ subLibraries pkg

    foreignLibNames
      = S.fromList
      $ map (T.pack . Cabal.unUnqualComponentName . foreignLibName)
      $ filter (buildable . foreignLibBuildInfo)
      $ foreignLibs pkg

    toInternalPackageMungedName
      = T.pack . prettyShow . MungedPackageName (pkgName pkgId)
      . maybeToLibraryName . Just . Cabal.mkUnqualComponentName . T.unpack

    -- Gets all of the modules, files, build files, and data files that
    -- constitute the package. This is primarily used for dirtiness
    -- checking during build, as well as use by "stack ghci"
    pkgFiles = GetPackageFiles $
        \cabalfp -> debugBracket ("getPackageFiles" <+> pretty cabalfp) $ do
             let pkgDir = parent cabalfp
             distDir <- distDirFromDir pkgDir
             bc <- view buildConfigL
             cabalVer <- view cabalVersionL
             (componentModules,componentFiles,dataFiles',warnings) <-
                 runRIO
                     (GetPackageFileContext cabalfp distDir bc cabalVer)
                     (packageDescModulesAndFiles pkg)
             setupFiles <-
                 if buildType pkg == Custom
                 then do
                     let setupHsPath = pkgDir </> relFileSetupHs
                         setupLhsPath = pkgDir </> relFileSetupLhs
                     setupHsExists <- doesFileExist setupHsPath
                     if setupHsExists then pure (S.singleton setupHsPath) else do
                         setupLhsExists <- doesFileExist setupLhsPath
                         if setupLhsExists then pure (S.singleton setupLhsPath) else pure S.empty
                 else pure S.empty
             buildFiles <- liftM (S.insert cabalfp . S.union setupFiles) $ do
                 let hpackPath = pkgDir </> relFileHpackPackageConfig
                 hpackExists <- doesFileExist hpackPath
                 pure $ if hpackExists then S.singleton hpackPath else S.empty
             pure (componentModules, componentFiles, buildFiles <> dataFiles', warnings)
    pkgId = package pkg
    name = pkgName pkgId

    (unknownTools, knownTools) = packageDescTools pkg

    deps = M.filterWithKey (const . not . isMe) (M.unionsWith (<>)
        [ asLibrary <$> packageDependencies packageConfig pkg
        -- We include all custom-setup deps - if present - in the
        -- package deps themselves. Stack always works with the
        -- invariant that there will be a single installed package
        -- relating to a package name, and this applies at the setup
        -- dependency level as well.
        , asLibrary <$> fromMaybe M.empty msetupDeps
        , knownTools
        ])
    msetupDeps = fmap
        (M.fromList . map (depPkgName &&& depVerRange) . setupDepends)
        (setupBuildInfo pkg)

    asLibrary range = DepValue
      { dvVersionRange = range
      , dvType = AsLibrary
      }

    -- Is the package dependency mentioned here me: either the package
    -- name itself, or the name of one of the sub libraries
    isMe name' = name' == name || fromString (packageNameString name') `S.member` extraLibNames

-- | Generate GHC options for the package's components, and a list of
-- options which apply generally to the package, not one specific
-- component.
generatePkgDescOpts
    :: (HasEnvConfig env, MonadThrow m, MonadReader env m, MonadIO m)
    => InstallMap
    -> InstalledMap
    -> [PackageName] -- ^ Packages to omit from the "-package" / "-package-id" flags
    -> [PackageName] -- ^ Packages to add to the "-package" flags
    -> Path Abs File
    -> PackageDescription
    -> Map NamedComponent [DotCabalPath]
    -> m (Map NamedComponent BuildInfoOpts)
generatePkgDescOpts installMap installedMap omitPkgs addPkgs cabalfp pkg componentPaths = do
    config <- view configL
    cabalVer <- view cabalVersionL
    distDir <- distDirFromDir cabalDir
    let generate namedComponent binfo =
            ( namedComponent
            , generateBuildInfoOpts BioInput
                { biInstallMap = installMap
                , biInstalledMap = installedMap
                , biCabalDir = cabalDir
                , biDistDir = distDir
                , biOmitPackages = omitPkgs
                , biAddPackages = addPkgs
                , biBuildInfo = binfo
                , biDotCabalPaths = fromMaybe [] (M.lookup namedComponent componentPaths)
                , biConfigLibDirs = configExtraLibDirs config
                , biConfigIncludeDirs = configExtraIncludeDirs config
                , biComponentName = namedComponent
                , biCabalVersion = cabalVer
                }
            )
    pure
        ( M.fromList
              (concat
                   [ maybe
                         []
                         (pure . generate CLib . libBuildInfo)
                         (library pkg)
                   , mapMaybe
                         (\sublib -> do
                            let maybeLib = CInternalLib . T.pack . Cabal.unUnqualComponentName <$> (libraryNameString . libName) sublib
                            flip generate  (libBuildInfo sublib) <$> maybeLib
                          )
                         (subLibraries pkg)
                   , fmap
                         (\exe ->
                               generate
                                    (CExe (T.pack (Cabal.unUnqualComponentName (exeName exe))))
                                    (buildInfo exe))
                         (executables pkg)
                   , fmap
                         (\bench ->
                               generate
                                    (CBench (T.pack (Cabal.unUnqualComponentName (benchmarkName bench))))
                                    (benchmarkBuildInfo bench))
                         (benchmarks pkg)
                   , fmap
                         (\test ->
                               generate
                                    (CTest (T.pack (Cabal.unUnqualComponentName (testName test))))
                                    (testBuildInfo test))
                         (testSuites pkg)]))
  where
    cabalDir = parent cabalfp

-- | Input to 'generateBuildInfoOpts'
data BioInput = BioInput
    { biInstallMap :: !InstallMap
    , biInstalledMap :: !InstalledMap
    , biCabalDir :: !(Path Abs Dir)
    , biDistDir :: !(Path Abs Dir)
    , biOmitPackages :: ![PackageName]
    , biAddPackages :: ![PackageName]
    , biBuildInfo :: !BuildInfo
    , biDotCabalPaths :: ![DotCabalPath]
    , biConfigLibDirs :: ![FilePath]
    , biConfigIncludeDirs :: ![FilePath]
    , biComponentName :: !NamedComponent
    , biCabalVersion :: !Version
    }

-- | Generate GHC options for the target. Since Cabal also figures out
-- these options, currently this is only used for invoking GHCI (via
-- stack ghci).
generateBuildInfoOpts :: BioInput -> BuildInfoOpts
generateBuildInfoOpts BioInput {..} =
    BuildInfoOpts
        { bioOpts = ghcOpts ++ fmap ("-optP" <>) (cppOptions biBuildInfo)
        -- NOTE for future changes: Due to this use of nubOrd (and other uses
        -- downstream), these generated options must not rely on multiple
        -- argument sequences.  For example, ["--main-is", "Foo.hs", "--main-
        -- is", "Bar.hs"] would potentially break due to the duplicate
        -- "--main-is" being removed.
        --
        -- See https://github.com/commercialhaskell/stack/issues/1255
        , bioOneWordOpts = nubOrd $ concat
            [extOpts, srcOpts, includeOpts, libOpts, fworks, cObjectFiles]
        , bioPackageFlags = deps
        , bioCabalMacros = componentAutogen </> relFileCabalMacrosH
        }
  where
    cObjectFiles =
        mapMaybe (fmap toFilePath .
                  makeObjectFilePathFromC biCabalDir biComponentName biDistDir)
                 cfiles
    cfiles = mapMaybe dotCabalCFilePath biDotCabalPaths
    installVersion = snd
    -- Generates: -package=base -package=base16-bytestring-0.1.1.6 ...
    deps =
        concat
            [ case M.lookup name biInstalledMap of
                Just (_, Stack.Types.Package.Library _ident ipid _) -> ["-package-id=" <> ghcPkgIdString ipid]
                _ -> ["-package=" <> packageNameString name <>
                 maybe "" -- This empty case applies to e.g. base.
                     ((("-" <>) . versionString) . installVersion)
                     (M.lookup name biInstallMap)]
            | name <- pkgs]
    pkgs =
        biAddPackages ++
        [ name
        | Dependency name _ _ <- targetBuildDepends biBuildInfo -- TODO: cabal 3 introduced multiple public libraries in a single dependency
        , name `notElem` biOmitPackages]
    PerCompilerFlavor ghcOpts _ = options biBuildInfo
    extOpts = map (("-X" ++) . display) (usedExtensions biBuildInfo)
    srcOpts =
        map (("-i" <>) . toFilePathNoTrailingSep)
            (concat
              [ [ componentBuildDir biCabalVersion biComponentName biDistDir ]
              , [ biCabalDir
                | null (hsSourceDirs biBuildInfo)
                ]
              , mapMaybe (toIncludeDir . getSymbolicPath) (hsSourceDirs biBuildInfo)
              , [ componentAutogen ]
              , maybeToList (packageAutogenDir biCabalVersion biDistDir)
              , [ componentOutputDir biComponentName biDistDir ]
              ]) ++
        [ "-stubdir=" ++ toFilePathNoTrailingSep (buildDir biDistDir) ]
    componentAutogen = componentAutogenDir biCabalVersion biComponentName biDistDir
    toIncludeDir "." = Just biCabalDir
    toIncludeDir relDir = concatAndCollapseAbsDir biCabalDir relDir
    includeOpts =
        map ("-I" <>) (biConfigIncludeDirs <> pkgIncludeOpts)
    pkgIncludeOpts =
        [ toFilePathNoTrailingSep absDir
        | dir <- includeDirs biBuildInfo
        , absDir <- handleDir dir
        ]
    libOpts =
        map ("-l" <>) (extraLibs biBuildInfo) <>
        map ("-L" <>) (biConfigLibDirs <> pkgLibDirs)
    pkgLibDirs =
        [ toFilePathNoTrailingSep absDir
        | dir <- extraLibDirs biBuildInfo
        , absDir <- handleDir dir
        ]
    handleDir dir = case (parseAbsDir dir, parseRelDir dir) of
       (Just ab, _       ) -> [ab]
       (_      , Just rel) -> [biCabalDir </> rel]
       (Nothing, Nothing ) -> []
    fworks = map (\fwk -> "-framework=" <> fwk) (frameworks biBuildInfo)

-- | Make the .o path from the .c file path for a component. Example:
--
-- @
-- executable FOO
--   c-sources:        cbits/text_search.c
-- @
--
-- Produces
--
-- <dist-dir>/build/FOO/FOO-tmp/cbits/text_search.o
--
-- Example:
--
-- λ> makeObjectFilePathFromC
--     $(mkAbsDir "/Users/chris/Repos/hoogle")
--     CLib
--     $(mkAbsDir "/Users/chris/Repos/hoogle/.stack-work/Cabal-x.x.x/dist")
--     $(mkAbsFile "/Users/chris/Repos/hoogle/cbits/text_search.c")
-- Just "/Users/chris/Repos/hoogle/.stack-work/Cabal-x.x.x/dist/build/cbits/text_search.o"
-- λ> makeObjectFilePathFromC
--     $(mkAbsDir "/Users/chris/Repos/hoogle")
--     (CExe "hoogle")
--     $(mkAbsDir "/Users/chris/Repos/hoogle/.stack-work/Cabal-x.x.x/dist")
--     $(mkAbsFile "/Users/chris/Repos/hoogle/cbits/text_search.c")
-- Just "/Users/chris/Repos/hoogle/.stack-work/Cabal-x.x.x/dist/build/hoogle/hoogle-tmp/cbits/text_search.o"
-- λ>
makeObjectFilePathFromC
    :: MonadThrow m
    => Path Abs Dir          -- ^ The cabal directory.
    -> NamedComponent        -- ^ The name of the component.
    -> Path Abs Dir          -- ^ Dist directory.
    -> Path Abs File         -- ^ The path to the .c file.
    -> m (Path Abs File) -- ^ The path to the .o file for the component.
makeObjectFilePathFromC cabalDir namedComponent distDir cFilePath = do
    relCFilePath <- stripProperPrefix cabalDir cFilePath
    relOFilePath <-
        parseRelFile (replaceExtension (toFilePath relCFilePath) "o")
    pure (componentOutputDir namedComponent distDir </> relOFilePath)

-- | Get all dependencies of the package (buildable targets only).
--
-- Note that for Cabal versions 1.22 and earlier, there is a bug where
-- Cabal requires dependencies for non-buildable components to be
-- present. We're going to use GHC version as a proxy for Cabal
-- library version in this case for simplicity, so we'll check for GHC
-- being 7.10 or earlier. This obviously makes our function a lot more
-- fun to write...
packageDependencies
  :: PackageConfig
  -> PackageDescription
  -> Map PackageName VersionRange
packageDependencies pkgConfig pkg' =
  M.fromListWith intersectVersionRanges $
  map (depPkgName &&& depVerRange) $
  concatMap targetBuildDepends (allBuildInfo' pkg) ++
  maybe [] setupDepends (setupBuildInfo pkg)
  where
    pkg
      | getGhcVersion (packageConfigCompilerVersion pkgConfig) >= mkVersion [8, 0] = pkg'
      -- Set all components to buildable. Only need to worry about
      -- library, exe, test, and bench, since others didn't exist in
      -- older Cabal versions
      | otherwise = pkg'
        { library = (\c -> c { libBuildInfo = go (libBuildInfo c) }) <$> library pkg'
        , executables = (\c -> c { buildInfo = go (buildInfo c) }) <$> executables pkg'
        , testSuites =
            if packageConfigEnableTests pkgConfig
              then (\c -> c { testBuildInfo = go (testBuildInfo c) }) <$> testSuites pkg'
              else testSuites pkg'
        , benchmarks =
            if packageConfigEnableBenchmarks pkgConfig
              then (\c -> c { benchmarkBuildInfo = go (benchmarkBuildInfo c) }) <$> benchmarks pkg'
              else benchmarks pkg'
        }

    go bi = bi { buildable = True }

-- | Get all dependencies of the package (buildable targets only).
--
-- This uses both the new 'buildToolDepends' and old 'buildTools'
-- information.
packageDescTools
  :: PackageDescription
  -> (Set ExeName, Map PackageName DepValue)
packageDescTools pd =
    (S.fromList $ concat unknowns, M.fromListWith (<>) $ concat knowns)
  where
    (unknowns, knowns) = unzip $ map perBI $ allBuildInfo' pd

    perBI :: BuildInfo -> ([ExeName], [(PackageName, DepValue)])
    perBI bi =
        (unknownTools, tools)
      where
        (unknownTools, knownTools) = partitionEithers $ map go1 (buildTools bi)

        tools = mapMaybe go2 (knownTools ++ buildToolDepends bi)

        -- This is similar to desugarBuildTool from Cabal, however it
        -- uses our own hard-coded map which drops tools shipped with
        -- GHC (like hsc2hs), and includes some tools from Stackage.
        go1 :: Cabal.LegacyExeDependency -> Either ExeName Cabal.ExeDependency
        go1 (Cabal.LegacyExeDependency name range) =
          case M.lookup name hardCodedMap of
            Just pkgName -> Right $ Cabal.ExeDependency pkgName (Cabal.mkUnqualComponentName name) range
            Nothing -> Left $ ExeName $ T.pack name

        go2 :: Cabal.ExeDependency -> Maybe (PackageName, DepValue)
        go2 (Cabal.ExeDependency pkg _name range)
          | pkg `S.member` preInstalledPackages = Nothing
          | otherwise = Just
              ( pkg
              , DepValue
                  { dvVersionRange = range
                  , dvType = AsBuildTool
                  }
              )

-- | A hard-coded map for tool dependencies
hardCodedMap :: Map String PackageName
hardCodedMap = M.fromList
  [ ("alex", Distribution.Package.mkPackageName "alex")
  , ("happy", Distribution.Package.mkPackageName "happy")
  , ("cpphs", Distribution.Package.mkPackageName "cpphs")
  , ("greencard", Distribution.Package.mkPackageName "greencard")
  , ("c2hs", Distribution.Package.mkPackageName "c2hs")
  , ("hscolour", Distribution.Package.mkPackageName "hscolour")
  , ("hspec-discover", Distribution.Package.mkPackageName "hspec-discover")
  , ("hsx2hs", Distribution.Package.mkPackageName "hsx2hs")
  , ("gtk2hsC2hs", Distribution.Package.mkPackageName "gtk2hs-buildtools")
  , ("gtk2hsHookGenerator", Distribution.Package.mkPackageName "gtk2hs-buildtools")
  , ("gtk2hsTypeGen", Distribution.Package.mkPackageName "gtk2hs-buildtools")
  ]

-- | Executable-only packages which come pre-installed with GHC and do
-- not need to be built. Without this exception, we would either end
-- up unnecessarily rebuilding these packages, or failing because the
-- packages do not appear in the Stackage snapshot.
preInstalledPackages :: Set PackageName
preInstalledPackages = S.fromList
  [ mkPackageName "hsc2hs"
  , mkPackageName "haddock"
  ]

-- | Variant of 'allBuildInfo' from Cabal that, like versions before
-- 2.2, only includes buildable components.
allBuildInfo' :: PackageDescription -> [BuildInfo]
allBuildInfo' pkg_descr = [ bi | lib <- allLibraries pkg_descr
                               , let bi = libBuildInfo lib
                               , buildable bi ]
                       ++ [ bi | flib <- foreignLibs pkg_descr
                               , let bi = foreignLibBuildInfo flib
                               , buildable bi ]
                       ++ [ bi | exe <- executables pkg_descr
                               , let bi = buildInfo exe
                               , buildable bi ]
                       ++ [ bi | tst <- testSuites pkg_descr
                               , let bi = testBuildInfo tst
                               , buildable bi ]
                       ++ [ bi | tst <- benchmarks pkg_descr
                               , let bi = benchmarkBuildInfo tst
                               , buildable bi ]

-- | A pair of package descriptions: one which modified the buildable
-- values of test suites and benchmarks depending on whether they are
-- enabled, and one which does not.
--
-- Fields are intentionally lazy, we may only need one or the other
-- value.
--
-- MSS 2017-08-29: The very presence of this data type is terribly
-- ugly, it represents the fact that the Cabal 2.0 upgrade did _not_
-- go well. Specifically, we used to have a field to indicate whether
-- a component was enabled in addition to buildable, but that's gone
-- now, and this is an ugly proxy. We should at some point clean up
-- the mess of Package, LocalPackage, etc, and probably pull in the
-- definition of PackageDescription from Cabal with our additionally
-- needed metadata. But this is a good enough hack for the
-- moment. Odds are, you're reading this in the year 2024 and thinking
-- "wtf?"
data PackageDescriptionPair = PackageDescriptionPair
  { pdpOrigBuildable :: PackageDescription
  , pdpModifiedBuildable :: PackageDescription
  }

-- | Evaluates the conditions of a 'GenericPackageDescription', yielding
-- a resolved 'PackageDescription'.
resolvePackageDescription :: PackageConfig
                          -> GenericPackageDescription
                          -> PackageDescriptionPair
resolvePackageDescription packageConfig (GenericPackageDescription desc _ defaultFlags mlib subLibs foreignLibs' exes tests benches) =
    PackageDescriptionPair
      { pdpOrigBuildable = go False
      , pdpModifiedBuildable = go True
      }
  where
        go modBuildable =
          desc {library =
                  fmap (resolveConditions rc updateLibDeps) mlib
               ,subLibraries =
                  map (\(n, v) -> (resolveConditions rc updateLibDeps v){libName=LSubLibName n})
                      subLibs
               ,foreignLibs =
                  map (\(n, v) -> (resolveConditions rc updateForeignLibDeps v){foreignLibName=n})
                      foreignLibs'
               ,executables =
                  map (\(n, v) -> (resolveConditions rc updateExeDeps v){exeName=n})
                      exes
               ,testSuites =
                  map (\(n,v) -> (resolveConditions rc (updateTestDeps modBuildable) v){testName=n})
                      tests
               ,benchmarks =
                  map (\(n,v) -> (resolveConditions rc (updateBenchmarkDeps modBuildable) v){benchmarkName=n})
                      benches}

        flags =
          M.union (packageConfigFlags packageConfig)
                  (flagMap defaultFlags)

        rc = mkResolveConditions
                (packageConfigCompilerVersion packageConfig)
                (packageConfigPlatform packageConfig)
                flags

        updateLibDeps lib deps =
          lib {libBuildInfo =
                 (libBuildInfo lib) {targetBuildDepends = deps}}
        updateForeignLibDeps lib deps =
          lib {foreignLibBuildInfo =
                 (foreignLibBuildInfo lib) {targetBuildDepends = deps}}
        updateExeDeps exe deps =
          exe {buildInfo =
                 (buildInfo exe) {targetBuildDepends = deps}}

        -- Note that, prior to moving to Cabal 2.0, we would set
        -- testEnabled/benchmarkEnabled here. These fields no longer
        -- exist, so we modify buildable instead here.  The only
        -- wrinkle in the Cabal 2.0 story is
        -- https://github.com/haskell/cabal/issues/1725, where older
        -- versions of Cabal (which may be used for actually building
        -- code) don't properly exclude build-depends for
        -- non-buildable components. Testing indicates that everything
        -- is working fine, and that this comment can be completely
        -- ignored. I'm leaving the comment anyway in case something
        -- breaks and you, poor reader, are investigating.
        updateTestDeps modBuildable test deps =
          let bi = testBuildInfo test
              bi' = bi
                { targetBuildDepends = deps
                , buildable = buildable bi && (if modBuildable then packageConfigEnableTests packageConfig else True)
                }
           in test { testBuildInfo = bi' }
        updateBenchmarkDeps modBuildable benchmark deps =
          let bi = benchmarkBuildInfo benchmark
              bi' = bi
                { targetBuildDepends = deps
                , buildable = buildable bi && (if modBuildable then packageConfigEnableBenchmarks packageConfig else True)
                }
           in benchmark { benchmarkBuildInfo = bi' }

-- | Make a map from a list of flag specifications.
--
-- What is @flagManual@ for?
flagMap :: [PackageFlag] -> Map FlagName Bool
flagMap = M.fromList . map pair
  where pair :: PackageFlag -> (FlagName, Bool)
        pair = flagName &&& flagDefault

data ResolveConditions = ResolveConditions
    { rcFlags :: Map FlagName Bool
    , rcCompilerVersion :: ActualCompiler
    , rcOS :: OS
    , rcArch :: Arch
    }

-- | Generic a @ResolveConditions@ using sensible defaults.
mkResolveConditions :: ActualCompiler -- ^ Compiler version
                    -> Platform -- ^ installation target platform
                    -> Map FlagName Bool -- ^ enabled flags
                    -> ResolveConditions
mkResolveConditions compilerVersion (Platform arch os) flags = ResolveConditions
    { rcFlags = flags
    , rcCompilerVersion = compilerVersion
    , rcOS = os
    , rcArch = arch
    }

-- | Resolve the condition tree for the library.
resolveConditions :: (Semigroup target,Monoid target,Show target)
                  => ResolveConditions
                  -> (target -> cs -> target)
                  -> CondTree ConfVar cs target
                  -> target
resolveConditions rc addDeps (CondNode lib deps cs) = basic <> children
  where basic = addDeps lib deps
        children = mconcat (map apply cs)
          where apply (Cabal.CondBranch cond node mcs) =
                  if condSatisfied cond
                     then resolveConditions rc addDeps node
                     else maybe mempty (resolveConditions rc addDeps) mcs
                condSatisfied c =
                  case c of
                    Var v -> varSatisfied v
                    Lit b -> b
                    CNot c' ->
                      not (condSatisfied c')
                    COr cx cy ->
                      condSatisfied cx || condSatisfied cy
                    CAnd cx cy ->
                      condSatisfied cx && condSatisfied cy
                varSatisfied v =
                  case v of
                    OS os -> os == rcOS rc
                    Arch arch -> arch == rcArch rc
                    PackageFlag flag ->
                      fromMaybe False $ M.lookup flag (rcFlags rc)
                      -- NOTE:  ^^^^^ This should never happen, as all flags
                      -- which are used must be declared. Defaulting to
                      -- False.
                    Impl flavor range ->
                      case (flavor, rcCompilerVersion rc) of
                        (GHC, ACGhc vghc) -> vghc `withinRange` range
                        _ -> False

-- | Path for the package's build log.
buildLogPath :: (MonadReader env m, HasBuildConfig env, MonadThrow m)
             => Package -> Maybe String -> m (Path Abs File)
buildLogPath package' msuffix = do
  env <- ask
  let stack = getProjectWorkDir env
  fp <- parseRelFile $ concat $
    packageIdentifierString (packageIdentifier package') :
    maybe id (\suffix -> ("-" :) . (suffix :)) msuffix [".log"]
  pure $ stack </> relDirLogs </> fp

    {- FIXME
-- | Create a 'ProjectPackage' from a directory containing a package.
mkProjectPackage
  :: forall env. (HasPantryConfig env, HasLogFunc env, HasProcessContext env)
  => PrintWarnings
  -> ResolvedPath Dir
  -> RIO env ProjectPackage
mkProjectPackage printWarnings dir = do
  (gpd, name, cabalfp) <- loadCabalFilePath (resolvedAbsolute dir)
  pure ProjectPackage
    { ppCabalFP = cabalfp
    , ppGPD' = gpd printWarnings
    , ppResolvedDir = dir
    , ppName = name
    }

-- | Create a 'DepPackage' from a 'PackageLocation'
mkDepPackage
  :: forall env. (HasPantryConfig env, HasLogFunc env, HasProcessContext env)
  => PackageLocation
  -> RIO env DepPackage
mkDepPackage pl = do
  (name, gpdio) <-
    case pl of
      PLMutable dir -> do
        (gpdio, name, _cabalfp) <- loadCabalFilePath (resolvedAbsolute dir)
        pure (name, gpdio NoPrintWarnings)
      PLImmutable pli -> do
        PackageIdentifier name _ <- getPackageLocationIdent pli
        run <- askRunInIO
        pure (name, run $ loadCabalFileImmutable pli)
  pure DepPackage
    { dpGPD' = gpdio
    , dpLocation = pl
    , dpName = name
    }

    -}

-- | Force a package to be treated as a custom build type, see
-- <https://github.com/commercialhaskell/stack/issues/4488>
applyForceCustomBuild
  :: Version -- ^ global Cabal version
  -> Package
  -> Package
applyForceCustomBuild cabalVersion package
    | forceCustomBuild =
        package
          { packageBuildType = Custom
          , packageDeps = M.insertWith (<>) "Cabal" (DepValue cabalVersionRange AsLibrary)
                        $ packageDeps package
          , packageSetupDeps = Just $ M.fromList
              [ ("Cabal", cabalVersionRange)
              , ("base", anyVersion)
              ]
          }
    | otherwise = package
  where
    cabalVersionRange =
      orLaterVersion $ mkVersion $ cabalSpecToVersionDigits $
        packageCabalSpec package
    forceCustomBuild =
      packageBuildType package == Simple &&
      not (cabalVersion `withinRange` cabalVersionRange)