stack-3.9.1: Setup.hs

module Main
  ( main
  ) where

import           Data.List ( nub, sortOn )
import           Distribution.InstalledPackageInfo
                   ( installedUnitId, sourcePackageId )
import           Distribution.Package ( UnitId, packageName, packageVersion )
import           Distribution.PackageDescription
                   ( Executable (..), PackageDescription )
import           Distribution.Pretty ( prettyShow )
import           Distribution.Simple
                   ( UserHooks(..), defaultMainWithHooks, simpleUserHooks )
import           Distribution.Simple.BuildPaths ( autogenPackageModulesDir )
import           Distribution.Simple.LocalBuildInfo
                   ( ComponentLocalBuildInfo (..), LocalBuildInfo, installedPkgs
                   , withExeLBI, withLibLBI
                   )
import           Distribution.Simple.PackageIndex
                   ( allPackages, dependencyClosure )
import           Distribution.Simple.Setup
                   ( BuildFlags (..), ReplFlags (..), fromFlag )
import           Distribution.Simple.Utils
                   ( createDirectoryIfMissingVerbose, rewriteFileEx )
import           Distribution.Types.PackageName ( unPackageName )
import           Distribution.Types.UnqualComponentName
                   ( unUnqualComponentName )
import           Distribution.Utils.Path ( interpretSymbolicPathCWD )
import           Distribution.Verbosity ( Verbosity, normal )
import           System.FilePath ( (</>) )

main :: IO ()
main = defaultMainWithHooks simpleUserHooks
  { buildHook = \pkg lbi hooks flags -> do
      generateBuildModule (fromFlag (buildVerbosity flags)) pkg lbi
      buildHook simpleUserHooks pkg lbi hooks flags
    -- The 'cabal repl' hook corresponds to the 'cabal build' hook and is added
    -- because, with a Cabal-based cradle, Haskell Language Server makes use of
    -- 'cabal repl'.
  , replHook = \pkg lbi hooks flags args -> do
      generateBuildModule (fromFlag (replVerbosity flags)) pkg lbi
      replHook simpleUserHooks pkg lbi hooks flags args
  }

generateBuildModule ::
     Verbosity
  -> PackageDescription
  -> LocalBuildInfo
  -> IO ()
generateBuildModule verbosity pkg lbi = do
  let dir = interpretSymbolicPathCWD (autogenPackageModulesDir lbi)
  createDirectoryIfMissingVerbose verbosity True dir
  withLibLBI pkg lbi $ \_ libcfg -> do
    withExeLBI pkg lbi $ \exe clbi -> do
      let name = exeName' exe
      rewriteFileEx normal (dir </> "Build_" ++ name ++ ".hs") $ unlines
        [ "{-|"
        , "Module      : Build_" ++ name
        , "License     : BSD-3-Clause"
        , "-}"
        , ""
        , "module Build_" ++ name
        , "  ( deps"
        , "  ) where"
        , ""
        , "-- | The dependencies against which \\'" ++ name ++ "\\' is built."
        , "deps :: [String]"
        , "deps = " ++ show (formatdeps (transDeps libcfg clbi))
        ]
  where
    exeName' = unUnqualComponentName . exeName
    formatdeps = map formatone . sortOn unPackageName'
    formatone p = unPackageName' p ++ "-" ++ prettyShow (packageVersion p)
    unPackageName' = unPackageName . packageName
    transDeps xs ys = either
      (map sourcePackageId . allPackages)
      handleDepClosureFailure $ dependencyClosure allInstPkgsIdx availInstPkgIds
     where
      allInstPkgsIdx = installedPkgs lbi
      allInstPkgIds = map installedUnitId $ allPackages allInstPkgsIdx
      -- instPkgIds includes `stack-X.X.X`, which is not a dependency hence is
      -- missing from allInstPkgsIdx. Filter that out.
      availInstPkgIds = filter (`elem` allInstPkgIds) $ testDeps xs ys
      handleDepClosureFailure unsatisfied =
        error $
             "Computation of transitive dependencies failed."
          ++ if null unsatisfied
               then ""
               else " Unresolved dependencies: " ++ show unsatisfied

testDeps :: ComponentLocalBuildInfo -> ComponentLocalBuildInfo -> [UnitId]
testDeps xs ys =
  map fst $ nub $ componentPackageDeps xs ++ componentPackageDeps ys