feature/cross-compile

Cabal-syntax/src/Distribution/Compat/Graph.hs

@@ -100,10 +100,11 @@
 import qualified Data.Array as Array
 import qualified Data.Foldable as Foldable
 import qualified Data.Graph as G
+import qualified Data.List.NonEmpty as NE
 import qualified Data.Map.Strict as Map
 import qualified Data.Set as Set
 import qualified Data.Tree as Tree
-import qualified Distribution.Compat.Prelude as Prelude
+import GHC.Stack (HasCallStack)
 
 -- | A graph of nodes @a@.  The nodes are expected to have instance
 -- of class 'IsNode'.
@@ -114,7 +115,7 @@
   , graphAdjoint :: G.Graph
   , graphVertexToNode :: G.Vertex -> a
   , graphKeyToVertex :: Key a -> Maybe G.Vertex
-  , graphBroken :: [(a, [Key a])]
+  , graphBroken :: [(a, NonEmpty (Key a))]
   }
 
 -- NB: Not a Functor! (or Traversable), because you need
@@ -284,7 +285,7 @@
 -- | /O(1)/.  Return a list of nodes paired with their broken
 -- neighbors (i.e., neighbor keys which are not in the graph).
 -- Requires amortized construction of graph.
-broken :: Graph a -> [(a, [Key a])]
+broken :: Graph a -> [(a, NonEmpty (Key a))]
 broken g = graphBroken g
 
 -- | Lookup the immediate neighbors from a key in the graph.
@@ -343,7 +344,7 @@
 -- if you can't fulfill this invariant use @'fromList' ('Data.Map.elems' m)@
 -- instead.  The values of the map are assumed to already
 -- be in WHNF.
-fromMap :: IsNode a => Map (Key a) a -> Graph a
+fromMap :: forall a. (IsNode a, Eq (Key a)) => Map (Key a) a -> Graph a
 fromMap m =
   Graph
     { graphMap = m
@@ -352,17 +353,26 @@
     , graphAdjoint = G.transposeG g
     , graphVertexToNode = vertex_to_node
     , graphKeyToVertex = key_to_vertex
-    , graphBroken = broke
+    , graphBroken =
+        map (\ns'' -> (fst (NE.head ns''), NE.map snd ns'')) $
+          NE.groupWith (nodeKey . fst) $
+            brokenEdges'
     }
   where
-    try_key_to_vertex k = maybe (Left k) Right (key_to_vertex k)
+    brokenEdges' :: [(a, Key a)]
+    brokenEdges' = concat brokenEdges
 
+    brokenEdges :: [[(a, Key a)]]
     (brokenEdges, edges) =
-      unzip $
-        [ partitionEithers (map try_key_to_vertex (nodeNeighbors n))
+      unzip
+        [ partitionEithers
+          [ case key_to_vertex n' of
+            Just v -> Right v
+            Nothing -> Left (n, n')
+          | n' <- nodeNeighbors n
+          ]
         | n <- ns
         ]
-    broke = filter (not . Prelude.null . snd) (zip ns brokenEdges)
 
     g = Array.listArray bounds edges
 
@@ -377,7 +387,7 @@
     bounds = (0, Map.size m - 1)
 
 -- | /O(V log V)/. Convert a list of nodes (with distinct keys) into a graph.
-fromDistinctList :: (IsNode a, Show (Key a)) => [a] -> Graph a
+fromDistinctList :: HasCallStack => (IsNode a, Show (Key a)) => [a] -> Graph a
 fromDistinctList =
   fromMap
     . Map.fromListWith (\_ -> duplicateError)

Cabal/src/Distribution/Backpack/ComponentsGraph.hs

@@ -22,6 +22,7 @@ import Distribution.Types.ComponentRequestedSpec
 import Distribution.Utils.Generic
 
 import Distribution.Pretty (pretty)
+import GHC.Stack (HasCallStack)
 import Text.PrettyPrint
 
 ------------------------------------------------------------------------------
@@ -50,7 +51,8 @@ dispComponentsWithDeps graph =
 -- | Create a 'Graph' of 'Component', or report a cycle if there is a
 -- problem.
 mkComponentsGraph
-  :: ComponentRequestedSpec
+  :: HasCallStack
+  => ComponentRequestedSpec
   -> PackageDescription
   -> Either [ComponentName] ComponentsGraph
 mkComponentsGraph enabled pkg_descr =

Cabal/src/Distribution/Backpack/Configure.hs

@@ -54,14 +54,16 @@ import Data.Either
 import qualified Data.Map as Map
 import qualified Data.Set as Set
 import Distribution.Pretty
+import GHC.Stack (HasCallStack)
 import Text.PrettyPrint
 
 ------------------------------------------------------------------------------
 -- Pipeline
 ------------------------------------------------------------------------------
 
 configureComponentLocalBuildInfos
-  :: Verbosity
+  :: HasCallStack
+  => Verbosity
   -> Bool -- use_external_internal_deps
   -> ComponentRequestedSpec
   -> Bool -- deterministic
@@ -206,7 +208,8 @@ configureComponentLocalBuildInfos
 ------------------------------------------------------------------------------
 
 toComponentLocalBuildInfos
-  :: Compiler
+  :: HasCallStack
+  => Compiler
   -> InstalledPackageIndex -- FULL set
   -> [ConfiguredPromisedComponent]
   -> PackageDescription
@@ -232,12 +235,12 @@ toComponentLocalBuildInfos
       -- since we will pay for the ALL installed packages even if
       -- they are not related to what we are building.  This was true
       -- in the old configure code.
-      external_graph :: Graph (Either InstalledPackageInfo ReadyComponent)
+      external_graph :: HasCallStack => Graph (Either InstalledPackageInfo ReadyComponent)
       external_graph =
         Graph.fromDistinctList
           . map Left
           $ PackageIndex.allPackages installedPackageSet
-      internal_graph :: Graph (Either InstalledPackageInfo ReadyComponent)
+      internal_graph :: HasCallStack => Graph (Either InstalledPackageInfo ReadyComponent)
       internal_graph =
         Graph.fromDistinctList
           . map Right
@@ -280,14 +283,14 @@ toComponentLocalBuildInfos
                   [ "installed package "
                     ++ prettyShow (packageId pkg)
                     ++ " is broken due to missing package "
-                    ++ intercalate ", " (map prettyShow deps)
+                    ++ intercalate ", " (map prettyShow $ toList deps)
                   | (Left pkg, deps) <- broken
                   ]
                 ++ unlines
                   [ "planned package "
                     ++ prettyShow (packageId pkg)
                     ++ " is broken due to missing package "
-                    ++ intercalate ", " (map prettyShow deps)
+                    ++ intercalate ", " (map prettyShow $ toList deps)
                   | (Right pkg, deps) <- broken
                   ]
 

Cabal/src/Distribution/Backpack/ConfiguredComponent.hs

@@ -94,7 +94,7 @@ dispConfiguredComponent cc =
 
 -- | Construct a 'ConfiguredComponent', given that the 'ComponentId'
 -- and library/executable dependencies are known.  The primary
--- work this does is handling implicit @backpack-include@ fields.
+-- work this does is handling implicit @mixin@ fields.
 mkConfiguredComponent
   :: PackageDescription
   -> ComponentId
@@ -121,7 +121,7 @@ mkConfiguredComponent pkg_descr this_cid lib_deps exe_deps component = do
         }
 
   -- Any @build-depends@ which is not explicitly mentioned in
-  -- @backpack-include@ is converted into an "implicit" include.
+  -- @mixin@ is converted into an "implicit" include.
   let used_explicitly = Set.fromList (map ci_id explicit_includes)
       implicit_includes =
         map

Cabal/src/Distribution/Simple/Configure.hs

@@ -95,7 +95,6 @@ import Distribution.Package
 import Distribution.PackageDescription
 import Distribution.PackageDescription.Check hiding (doesFileExist, listDirectory)
 import Distribution.PackageDescription.Configuration
-import Distribution.PackageDescription.PrettyPrint
 import Distribution.Simple.BuildTarget
 import Distribution.Simple.BuildToolDepends
 import Distribution.Simple.BuildWay
@@ -196,6 +195,7 @@ import Text.PrettyPrint
 import qualified Data.Maybe as M
 import qualified Data.Set as Set
 import qualified Distribution.Compat.NonEmptySet as NES
+import GHC.Stack (HasCallStack)
 
 type UseExternalInternalDeps = Bool
 
@@ -1146,9 +1146,10 @@ configurePackage verbHandles cfg lbc0 pkg_descr00 flags enabled comp platform pa
         , extraCoverageFor = []
         }
 
-  debug verbosity $
-    "Finalized package description:\n"
-      ++ showPackageDescription pkg_descr2
+  -- FIXME: Printing the package description loops indefinitely.
+  -- debug verbosity $
+  --   "Finalized package description:\n"
+  --     ++ showPackageDescription pkg_descr2
 
   return (lbc, pbd)
 
@@ -1393,7 +1394,8 @@ finalCheckPackage
           CantFindForeignLibraries unsupportedFLibs
 
 configureComponents
-  :: VerbosityHandles
+  :: HasCallStack
+  => VerbosityHandles
   -> LBC.LocalBuildConfig
   -> LBC.PackageBuildDescr
   -> InstalledPackageIndex

Cabal/src/Distribution/Simple/GHC.hs

@@ -238,7 +238,13 @@ configureCompiler verbosity hcPath conf0 = do
       -- In this example, @AbiTag@ is "inplace".
       compilerAbiTag :: AbiTag
       compilerAbiTag =
-        maybe NoAbiTag (AbiTag . dropWhile (== '-') . stripCommonPrefix (prettyShow compilerId)) projectUnitId
+        case projectUnitId of
+          Nothing -> NoAbiTag
+          Just "" -> NoAbiTag
+          Just unitId ->
+            case dropWhile (== '-') $ stripCommonPrefix (prettyShow compilerId) unitId of
+              "" -> NoAbiTag
+              tag -> AbiTag tag
 
       wiredInUnitIds = do
         ghcInternalUnitId <- Map.lookup "ghc-internal Unit Id" ghcInfoMap
@@ -312,14 +318,8 @@ compilerProgramDb verbosity comp progdb1 hcPkgPath = do
       ghcProg = fromJust $ lookupProgram ghcProgram progdb1
       ghcVersion = compilerVersion comp
 
-      -- configure gcc, ld, ar etc... based on the paths stored
-      -- in the GHC settings file
-      progdb3 =
-        Internal.configureToolchain
-          (ghcVersionImplInfo ghcVersion)
-          ghcProg
-          (compilerProperties comp)
-          progdb2
+  -- configure gcc, ld, ar etc... based on the paths stored in the GHC settings file
+  progdb3 <- Internal.configureToolchain verbosity (ghcVersionImplInfo ghcVersion) ghcProg (compilerProperties comp) progdb2
 
   -- This is slightly tricky, we have to configure ghc first, then we use the
   -- location of ghc to help find ghc-pkg in the case that the user did not

Cabal/src/Distribution/Simple/GHC/Internal.hs

@@ -100,37 +100,47 @@
 
 -- | Adjust the way we find and configure gcc and ld
 configureToolchain
-  :: GhcImplInfo
+  :: Verbosity
+  -> GhcImplInfo
   -> ConfiguredProgram
   -> Map String String
   -> ProgramDb
-  -> ProgramDb
-configureToolchain _implInfo ghcProg ghcInfo =
-  addKnownProgram
-    gccProgram
-      { programFindLocation = findProg gccProgramName extraGccPath
-      , programPostConf = configureGcc
-      }
-    . addKnownProgram
-      gppProgram
-        { programFindLocation = findProg gppProgramName extraGppPath
-        , programPostConf = configureGpp
-        }
-    . addKnownProgram
-      ldProgram
-        { programFindLocation = findProg ldProgramName extraLdPath
-        , programPostConf = \v cp ->
-            -- Call any existing configuration first and then add any new configuration
-            configureLd v =<< programPostConf ldProgram v cp
-        }
-    . addKnownProgram
-      arProgram
-        { programFindLocation = findProg arProgramName extraArPath
-        }
-    . addKnownProgram
-      stripProgram
-        { programFindLocation = findProg stripProgramName extraStripPath
+  -> IO ProgramDb
+configureToolchain verbosity _implInfo ghcProg ghcInfo db = do
+  -- this is a bit of a hack. We have a dependency of ld on gcc.
+  -- ld needs to compiler a c program, to check an ld feature.
+  -- we _could_ use ghc as a c frontend, but we do not pass all
+  -- db stack appropriately, and thus we can run into situations
+  -- where GHC will fail if it's stricter in it's wired-in-unit
+  -- selction and has the wrong db stack. However we don't need
+  -- ghc to compile a _test_ c program. So we configure `gcc`
+  -- first and then use `gcc` (the generic c compiler in cabal
+  -- terminology) to compile the test program.
+  let gccProgram' = gccProgram
+        { programFindLocation = findProg gccProgramName extraGccPath
+        , programPostConf = configureGcc
         }
+  let db' = flip addKnownProgram db $ gccProgram'
+  (gccProg, db'') <- requireProgram verbosity gccProgram' db'
+  return $
+    flip addKnownPrograms db'' $
+      [ gppProgram
+          { programFindLocation = findProg gppProgramName extraGppPath
+          , programPostConf = configureGpp
+          }
+      , ldProgram
+          { programFindLocation = findProg ldProgramName extraLdPath
+          , programPostConf = \v cp ->
+              -- Call any existing configuration first and then add any new configuration
+              configureLd gccProg v =<< programPostConf ldProgram v cp
+          }
+      , arProgram
+          { programFindLocation = findProg arProgramName extraArPath
+          }
+      , stripProgram
+          { programFindLocation = findProg stripProgramName extraStripPath
+          }
+      ]
   where
     compilerDir, base_dir, mingwBinDir :: FilePath
     compilerDir = takeDirectory (programPath ghcProg)
@@ -228,27 +238,26 @@
                 ++ cxxFlags
           }
 
-    configureLd :: Verbosity -> ConfiguredProgram -> IO ConfiguredProgram
-    configureLd v ldProg = do
-      ldProg' <- configureLd' v ldProg
+    configureLd :: ConfiguredProgram -> Verbosity -> ConfiguredProgram -> IO ConfiguredProgram
+    configureLd gccProg v ldProg = do
+      ldProg' <- configureLd' gccProg v ldProg
       return
         ldProg'
           { programDefaultArgs = programDefaultArgs ldProg' ++ ldLinkerFlags
           }
 
     -- we need to find out if ld supports the -x flag
-    configureLd' :: Verbosity -> ConfiguredProgram -> IO ConfiguredProgram
-    configureLd' verbosity ldProg = do
+    configureLd' :: ConfiguredProgram -> Verbosity -> ConfiguredProgram -> IO ConfiguredProgram
+    configureLd' gccProg v ldProg = do
       ldx <- withTempFile ".c" $ \testcfile testchnd ->
         withTempFile ".o" $ \testofile testohnd -> do
           hPutStrLn testchnd "int foo() { return 0; }"
           hClose testchnd
           hClose testohnd
           runProgram
-            verbosity
-            ghcProg
-            [ "-hide-all-packages"
-            , "-c"
+            v
+            gccProg
+            [ "-c"
             , testcfile
             , "-o"
             , testofile

Cabal/src/Distribution/Simple/Program/Db.hs

@@ -68,6 +68,7 @@ module Distribution.Simple.Program.Db
   , updateUnconfiguredProgs
   , updateConfiguredProgs
   , updatePathProgDb
+  , programDbSignature
   ) where
 
 import Distribution.Compat.Prelude
@@ -604,3 +605,17 @@ requireProgramVersion verbosity prog range programDb =
   join $
     either (dieWithException verbosity) return
       `fmap` lookupProgramVersion verbosity prog range programDb
+
+-- | Select the bits of a 'ProgramDb' to monitor for value changes.
+-- Use 'programsMonitorFiles' for the files to monitor.
+programDbSignature :: ProgramDb -> [ConfiguredProgram]
+programDbSignature progdb =
+  [ prog
+    { programMonitorFiles = []
+    , programOverrideEnv =
+        filter
+          ((/= "PATH") . fst)
+          (programOverrideEnv prog)
+    }
+  | prog <- configuredPrograms progdb
+  ]