Cabal/src/Distribution/Backpack/Configure.hs

   1 {-# LANGUAGE DeriveDataTypeable #-}
   2 {-# LANGUAGE NondecreasingIndentation #-}
   3 {-# LANGUAGE OverloadedStrings #-}
   4 {-# LANGUAGE PatternGuards #-}
   5 {-# LANGUAGE RecordWildCards #-}
   6 {-# LANGUAGE ScopedTypeVariables #-}
   7 {-# LANGUAGE TypeFamilies #-}
   8 {-# LANGUAGE NoMonoLocalBinds #-}
   9
  10 -- | See <https://github.com/ezyang/ghc-proposals/blob/backpack/proposals/0000-backpack.rst>
  11 --
  12 -- WARNING: The contents of this module are HIGHLY experimental.
  13 -- We may refactor it under you.
  14 module Distribution.Backpack.Configure
  15   ( configureComponentLocalBuildInfos
  16   ) where
  17
  18 import Distribution.Compat.Prelude hiding ((<>))
  19 import Prelude ()
  20
  21 import Distribution.Backpack
  22 import Distribution.Backpack.ComponentsGraph
  23 import Distribution.Backpack.ConfiguredComponent
  24 import Distribution.Backpack.FullUnitId
  25 import Distribution.Backpack.Id
  26 import Distribution.Backpack.LinkedComponent
  27 import Distribution.Backpack.PreExistingComponent
  28 import Distribution.Backpack.ReadyComponent
  29
  30 import Distribution.Backpack.ModuleShape
  31 import Distribution.Compat.Graph (Graph, IsNode (..))
  32 import qualified Distribution.Compat.Graph as Graph
  33 import Distribution.InstalledPackageInfo
  34   ( InstalledPackageInfo
  35   , emptyInstalledPackageInfo
  36   )
  37 import qualified Distribution.InstalledPackageInfo as Installed
  38 import Distribution.ModuleName
  39 import Distribution.Package
  40 import Distribution.PackageDescription
  41 import Distribution.Simple.Compiler
  42 import Distribution.Simple.Flag
  43 import Distribution.Simple.LocalBuildInfo
  44 import Distribution.Simple.PackageIndex (InstalledPackageIndex)
  45 import qualified Distribution.Simple.PackageIndex as PackageIndex
  46 import Distribution.Types.AnnotatedId
  47 import Distribution.Types.ComponentInclude
  48 import Distribution.Types.ComponentRequestedSpec
  49 import Distribution.Types.MungedPackageName
  50 import Distribution.Utils.LogProgress
  51 import Distribution.Verbosity
  52
  53 import Data.Either
  54   ( lefts
  55   )
  56 import qualified Data.Map as Map
  57 import qualified Data.Set as Set
  58 import Distribution.Pretty
  59 import Text.PrettyPrint
  60
  61 ------------------------------------------------------------------------------
  62 -- Pipeline
  63 ------------------------------------------------------------------------------
  64
  65 configureComponentLocalBuildInfos
  66   :: Verbosity
  67   -> Bool -- use_external_internal_deps
  68   -> ComponentRequestedSpec
  69   -> Bool -- deterministic
  70   -> Flag String -- configIPID
  71   -> Flag ComponentId -- configCID
  72   -> PackageDescription
  73   -> ([PreExistingComponent], [ConfiguredPromisedComponent])
  74   -> FlagAssignment -- configConfigurationsFlags
  75   -> [(ModuleName, Module)] -- configInstantiateWith
  76   -> InstalledPackageIndex
  77   -> Compiler
  78   -> LogProgress ([ComponentLocalBuildInfo], InstalledPackageIndex)
  79 configureComponentLocalBuildInfos
  80   verbosity
  81   use_external_internal_deps
  82   enabled
  83   deterministic
  84   ipid_flag
  85   cid_flag
  86   pkg_descr
  87   (prePkgDeps, promisedPkgDeps)
  88   flags
  89   instantiate_with
  90   installedPackageSet
  91   comp = do
  92     -- NB: In single component mode, this returns a *single* component.
  93     -- In this graph, the graph is NOT closed.
  94     graph0 <- case mkComponentsGraph enabled pkg_descr of
  95       Left ccycle -> dieProgress (componentCycleMsg (package pkg_descr) ccycle)
  96       Right g -> return (componentsGraphToList g)
  97     infoProgress $
  98       hang
  99         (text "Source component graph:")
 100         4
 101         (dispComponentsWithDeps graph0)
 102
 103     let conf_pkg_map =
 104           Map.fromListWith
 105             Map.union
 106             [ ( pc_pkgname pkg
 107               , Map.singleton
 108                   (pc_compname pkg)
 109                   ( AnnotatedId
 110                       { ann_id = pc_cid pkg
 111                       , ann_pid = packageId pkg
 112                       , ann_cname = pc_compname pkg
 113                       }
 114                   )
 115               )
 116             | pkg <- prePkgDeps
 117             ]
 118             `Map.union` Map.fromListWith
 119               Map.union
 120               [ (pkg, Map.singleton (ann_cname aid) aid)
 121               | ConfiguredPromisedComponent pkg aid <- promisedPkgDeps
 122               ]
 123     graph1 <-
 124       toConfiguredComponents
 125         use_external_internal_deps
 126         flags
 127         deterministic
 128         ipid_flag
 129         cid_flag
 130         pkg_descr
 131         conf_pkg_map
 132         (map fst graph0)
 133     infoProgress $
 134       hang
 135         (text "Configured component graph:")
 136         4
 137         (vcat (map dispConfiguredComponent graph1))
 138
 139     let shape_pkg_map =
 140           Map.fromList
 141             [ (pc_cid pkg, (pc_open_uid pkg, pc_shape pkg))
 142             | pkg <- prePkgDeps
 143             ]
 144             `Map.union` Map.fromList
 145               [ ( ann_id aid
 146                 ,
 147                   ( DefiniteUnitId
 148                       ( unsafeMkDefUnitId
 149                           (mkUnitId (unComponentId (ann_id aid)))
 150                       )
 151                   , emptyModuleShape
 152                   )
 153                 )
 154               | ConfiguredPromisedComponent _ aid <- promisedPkgDeps
 155               ]
 156         uid_lookup def_uid
 157           | Just pkg <- PackageIndex.lookupUnitId installedPackageSet uid =
 158               FullUnitId
 159                 (Installed.installedComponentId pkg)
 160                 (Map.fromList (Installed.instantiatedWith pkg))
 161           | otherwise = error ("uid_lookup: " ++ prettyShow uid)
 162           where
 163             uid = unDefUnitId def_uid
 164     graph2 <-
 165       toLinkedComponents
 166         verbosity
 167         (not (null promisedPkgDeps))
 168         uid_lookup
 169         (package pkg_descr)
 170         shape_pkg_map
 171         graph1
 172
 173     infoProgress $
 174       hang
 175         (text "Linked component graph:")
 176         4
 177         (vcat (map dispLinkedComponent graph2))
 178
 179     let pid_map =
 180           Map.fromList $
 181             [ (pc_uid pkg, pc_munged_id pkg)
 182             | pkg <- prePkgDeps
 183             ]
 184               ++ [ (Installed.installedUnitId pkg, mungedId pkg)
 185                  | (_, Module uid _) <- instantiate_with
 186                  , Just pkg <-
 187                     [ PackageIndex.lookupUnitId
 188                         installedPackageSet
 189                         (unDefUnitId uid)
 190                     ]
 191                  ]
 192         subst = Map.fromList instantiate_with
 193         graph3 = toReadyComponents pid_map subst graph2
 194         graph4 = Graph.revTopSort (Graph.fromDistinctList graph3)
 195
 196     infoProgress $
 197       hang
 198         (text "Ready component graph:")
 199         4
 200         (vcat (map dispReadyComponent graph4))
 201
 202     toComponentLocalBuildInfos comp installedPackageSet promisedPkgDeps pkg_descr prePkgDeps graph4
 203
 204 ------------------------------------------------------------------------------
 205 -- ComponentLocalBuildInfo
 206 ------------------------------------------------------------------------------
 207
 208 toComponentLocalBuildInfos
 209   :: Compiler
 210   -> InstalledPackageIndex -- FULL set
 211   -> [ConfiguredPromisedComponent]
 212   -> PackageDescription
 213   -> [PreExistingComponent] -- external package deps
 214   -> [ReadyComponent]
 215   -> LogProgress
 216       ( [ComponentLocalBuildInfo]
 217       , InstalledPackageIndex -- only relevant packages
 218       )
 219 toComponentLocalBuildInfos
 220   comp
 221   installedPackageSet
 222   promisedPkgDeps
 223   pkg_descr
 224   externalPkgDeps
 225   graph = do
 226     -- Check and make sure that every instantiated component exists.
 227     -- We have to do this now, because prior to linking/instantiating
 228     -- we don't actually know what the full set of 'UnitId's we need
 229     -- are.
 230     let
 231       -- TODO: This is actually a bit questionable performance-wise,
 232       -- since we will pay for the ALL installed packages even if
 233       -- they are not related to what we are building.  This was true
 234       -- in the old configure code.
 235       external_graph :: Graph (Either InstalledPackageInfo ReadyComponent)
 236       external_graph =
 237         Graph.fromDistinctList
 238           . map Left
 239           $ PackageIndex.allPackages installedPackageSet
 240       internal_graph :: Graph (Either InstalledPackageInfo ReadyComponent)
 241       internal_graph =
 242         Graph.fromDistinctList
 243           . map Right
 244           $ graph
 245       combined_graph = Graph.unionRight external_graph internal_graph
 246       local_graph =
 247         fromMaybe (error "toComponentLocalBuildInfos: closure returned Nothing") $
 248           Graph.closure combined_graph (map nodeKey graph)
 249       -- The database of transitively reachable installed packages that the
 250       -- external components the package (as a whole) depends on.  This will be
 251       -- used in several ways:
 252       --
 253       --      * We'll use it to do a consistency check so we're not depending
 254       --        on multiple versions of the same package (TODO: someday relax
 255       --        this for private dependencies.)  See right below.
 256       --
 257       --      * We'll pass it on in the LocalBuildInfo, where preprocessors
 258       --        and other things will incorrectly use it to determine what
 259       --        the include paths and everything should be.
 260       --
 261       packageDependsIndex = PackageIndex.fromList (lefts local_graph)
 262       fullIndex = Graph.fromDistinctList local_graph
 263
 264     case Graph.broken fullIndex of
 265       [] -> return ()
 266       -- If there are promised dependencies, we don't know what the dependencies
 267       -- of these are and that can easily lead to a broken graph. So assume that
 268       -- any promised package is not broken (ie all its dependencies, transitively,
 269       -- will be there). That's a promise.
 270       broken
 271         | not (null promisedPkgDeps) -> return ()
 272         | otherwise ->
 273             -- TODO: ppr this
 274             dieProgress . text $
 275               "The following packages are broken because other"
 276                 ++ " packages they depend on are missing. These broken "
 277                 ++ "packages must be rebuilt before they can be used.\n"
 278                 -- TODO: Undupe.
 279                 ++ unlines
 280                   [ "installed package "
 281                     ++ prettyShow (packageId pkg)
 282                     ++ " is broken due to missing package "
 283                     ++ intercalate ", " (map prettyShow deps)
 284                   | (Left pkg, deps) <- broken
 285                   ]
 286                 ++ unlines
 287                   [ "planned package "
 288                     ++ prettyShow (packageId pkg)
 289                     ++ " is broken due to missing package "
 290                     ++ intercalate ", " (map prettyShow deps)
 291                   | (Right pkg, deps) <- broken
 292                   ]
 293
 294     -- In this section, we'd like to look at the 'packageDependsIndex'
 295     -- and see if we've picked multiple versions of the same
 296     -- installed package (this is bad, because it means you might
 297     -- get an error could not match foo-0.1:Type with foo-0.2:Type).
 298     --
 299     -- What is pseudoTopPkg for? I have no idea.  It was used
 300     -- in the very original commit which introduced checking for
 301     -- inconsistencies 5115bb2be4e13841ea07dc9166b9d9afa5f0d012,
 302     -- and then moved out of PackageIndex and put here later.
 303     -- TODO: Try this code without it...
 304     --
 305     -- TODO: Move this into a helper function
 306     --
 307     -- TODO: This is probably wrong for Backpack
 308     let pseudoTopPkg :: InstalledPackageInfo
 309         pseudoTopPkg =
 310           emptyInstalledPackageInfo
 311             { Installed.installedUnitId = mkLegacyUnitId (packageId pkg_descr)
 312             , Installed.sourcePackageId = packageId pkg_descr
 313             , Installed.depends = map pc_uid externalPkgDeps
 314             }
 315     case PackageIndex.dependencyInconsistencies
 316       . PackageIndex.insert pseudoTopPkg
 317       $ packageDependsIndex of
 318       [] -> return ()
 319       inconsistencies ->
 320         warnProgress $
 321           hang
 322             ( text "This package indirectly depends on multiple versions of the same"
 323                 <+> text "package. This is very likely to cause a compile failure."
 324             )
 325             2
 326             ( vcat
 327                 [ text "package"
 328                   <+> pretty (packageName user)
 329                   <+> parens (pretty (installedUnitId user))
 330                   <+> text "requires"
 331                   <+> pretty inst
 332                 | (_dep_key, insts) <- inconsistencies
 333                 , (inst, users) <- insts
 334                 , user <- users
 335                 ]
 336             )
 337     let clbis = mkLinkedComponentsLocalBuildInfo comp graph
 338     -- forM clbis $ \(clbi,deps) -> info verbosity $ "UNIT" ++ hashUnitId (componentUnitId clbi) ++ "\n" ++ intercalate "\n" (map hashUnitId deps)
 339     return (clbis, packageDependsIndex)
 340
 341 -- Build ComponentLocalBuildInfo for each component we are going
 342 -- to build.
 343 --
 344 -- This conversion is lossy; we lose some invariants from ReadyComponent
 345 mkLinkedComponentsLocalBuildInfo
 346   :: Compiler
 347   -> [ReadyComponent]
 348   -> [ComponentLocalBuildInfo]
 349 mkLinkedComponentsLocalBuildInfo comp rcs = map go rcs
 350   where
 351     internalUnits = Set.fromList (map rc_uid rcs)
 352     isInternal x = Set.member x internalUnits
 353     go rc =
 354       case rc_component rc of
 355         CLib lib ->
 356           let convModuleExport (modname', (Module uid modname))
 357                 | this_uid == unDefUnitId uid
 358                 , modname' == modname =
 359                     Installed.ExposedModule modname' Nothing
 360                 | otherwise =
 361                     Installed.ExposedModule
 362                       modname'
 363                       (Just (OpenModule (DefiniteUnitId uid) modname))
 364               convOpenModuleExport (modname', modu@(OpenModule uid modname))
 365                 | uid == this_open_uid
 366                 , modname' == modname =
 367                     Installed.ExposedModule modname' Nothing
 368                 | otherwise =
 369                     Installed.ExposedModule modname' (Just modu)
 370               convOpenModuleExport (_, OpenModuleVar _) =
 371                 error "convOpenModuleExport: top-level modvar"
 372               exports =
 373                 -- Loses invariants
 374                 case rc_i rc of
 375                   Left indefc ->
 376                     map convOpenModuleExport $
 377                       Map.toList (indefc_provides indefc)
 378                   Right instc ->
 379                     map convModuleExport $
 380                       Map.toList (instc_provides instc)
 381               insts =
 382                 case rc_i rc of
 383                   Left indefc -> [(m, OpenModuleVar m) | m <- indefc_requires indefc]
 384                   Right instc ->
 385                     [ (m, OpenModule (DefiniteUnitId uid') m')
 386                     | (m, Module uid' m') <- instc_insts instc
 387                     ]
 388
 389               compat_name = MungedPackageName (packageName rc) (libName lib)
 390               compat_key = computeCompatPackageKey comp compat_name (packageVersion rc) this_uid
 391            in LibComponentLocalBuildInfo
 392                 { componentPackageDeps = cpds
 393                 , componentUnitId = this_uid
 394                 , componentComponentId = this_cid
 395                 , componentInstantiatedWith = insts
 396                 , componentIsIndefinite_ = is_indefinite
 397                 , componentLocalName = cname
 398                 , componentInternalDeps = internal_deps
 399                 , componentExeDeps = exe_deps
 400                 , componentIncludes = includes
 401                 , componentExposedModules = exports
 402                 , componentIsPublic = rc_public rc
 403                 , componentCompatPackageKey = compat_key
 404                 , componentCompatPackageName = compat_name
 405                 }
 406         CFLib _ ->
 407           FLibComponentLocalBuildInfo
 408             { componentUnitId = this_uid
 409             , componentComponentId = this_cid
 410             , componentLocalName = cname
 411             , componentPackageDeps = cpds
 412             , componentExeDeps = exe_deps
 413             , componentInternalDeps = internal_deps
 414             , componentIncludes = includes
 415             }
 416         CExe _ ->
 417           ExeComponentLocalBuildInfo
 418             { componentUnitId = this_uid
 419             , componentComponentId = this_cid
 420             , componentLocalName = cname
 421             , componentPackageDeps = cpds
 422             , componentExeDeps = exe_deps
 423             , componentInternalDeps = internal_deps
 424             , componentIncludes = includes
 425             }
 426         CTest _ ->
 427           TestComponentLocalBuildInfo
 428             { componentUnitId = this_uid
 429             , componentComponentId = this_cid
 430             , componentLocalName = cname
 431             , componentPackageDeps = cpds
 432             , componentExeDeps = exe_deps
 433             , componentInternalDeps = internal_deps
 434             , componentIncludes = includes
 435             }
 436         CBench _ ->
 437           BenchComponentLocalBuildInfo
 438             { componentUnitId = this_uid
 439             , componentComponentId = this_cid
 440             , componentLocalName = cname
 441             , componentPackageDeps = cpds
 442             , componentExeDeps = exe_deps
 443             , componentInternalDeps = internal_deps
 444             , componentIncludes = includes
 445             }
 446       where
 447         this_uid = rc_uid rc
 448         this_open_uid = rc_open_uid rc
 449         this_cid = rc_cid rc
 450         cname = componentName (rc_component rc)
 451         cpds = rc_depends rc
 452         exe_deps = map ann_id $ rc_exe_deps rc
 453         is_indefinite =
 454           case rc_i rc of
 455             Left _ -> True
 456             Right _ -> False
 457         includes =
 458           map (\ci -> (ci_id ci, ci_renaming ci)) $
 459             case rc_i rc of
 460               Left indefc ->
 461                 indefc_includes indefc
 462               Right instc ->
 463                 map
 464                   (\ci -> ci{ci_ann_id = fmap DefiniteUnitId (ci_ann_id ci)})
 465                   (instc_includes instc)
 466         internal_deps = filter isInternal (nodeNeighbors rc)