GitLab

Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC

Commits:

c7061392

by mangoiv at 2025-12-05T16:27:42-05:00

driver: don't expect nodes to exist when checking paths between them

In `mgQueryZero`, previously node lookups were expected to never fail,
i.e. it was expected that when calculating the path between two nodes in
a zero level import graph, both nodes would always exist. This is not
the case, e.g. in some situations involving exact names (see the
test-case). The fix is to first check whether the node is present in the
graph at all, instead of panicking, just to report that there is no
path.

Closes #26568

4 changed files:

compiler/GHC/Unit/Module/Graph.hs
+ testsuite/tests/th/T26568.hs
+ testsuite/tests/th/T26568.stderr
testsuite/tests/th/all.T

Changes:

compiler/GHC/Unit/Module/Graph.hs

@@ -565,16 +565,26 @@ mgReachableLoop mg nk = map summaryNodeSummary modules_below where
      allReachableMany td_map (mapMaybe lookup_node nk)
 --- | @'mgQueryZero' g root b@ answers the question: can we reach @b@ from @root@
 +-- | @'mgQueryZero' g root target@ answers the question: can we reach @target@ from @root@
  -- in the module graph @g@, only using normal (level 0) imports?
 +--
 +-- If the @target@ key is not reachable, there is no path.
 +-- The @root@ key not being in @g@ results in a panic.
  mgQueryZero :: ModuleGraph
              -> ZeroScopeKey
              -> ZeroScopeKey
              -> Bool
 -mgQueryZero mg nka nkb = isReachable td_map na nb where
 +mgQueryZero mg rootKey targetKey =
 +  case lookup_node targetKey of
 +    -- The module we are looking for may not be in the module graph at all,
 +    -- e.g. if a reference to it did not arise from an explicit import
 +    -- declaration (as in #26568).
 +    Nothing -> False
 +    Just ntarget -> isReachable td_map nroot ntarget
 +  where
 +  -- invariant: the root key has to exist in the graph
 +  nroot = fromJust $ lookup_node rootKey
    (td_map, lookup_node) = mg_zero_graph mg
 -  na = expectJust $ lookup_node nka
 -  nb = expectJust $ lookup_node nkb
  -- | Reachability Query.

testsuite/tests/th/T26568.hs

 +{-# LANGUAGE ExplicitLevelImports, TemplateHaskell, NoImplicitPrelude #-}
 +module T16568 where
++
 +x = $(do
 +  _ <- _
 +  _)
++

testsuite/tests/th/T26568.stderr

 +T26568.hs:5:3: error: [GHC-28914]
 +    • Level error:
 +      instance for ‘GHC.Internal.Base.Monad GHC.Internal.TH.Monad.Q’
 +      is bound at levels {} but used at level -1
 +    • In a stmt of a 'do' block: _ <- _
 +      In the expression:
 +        do _ <- _
 +           _
 +      In the untyped splice:
 +        $(do _ <- _
 +             _)
++
 +T26568.hs:5:8: error: [GHC-88464]
 +    • Found hole: _ :: GHC.Internal.TH.Monad.Q a0
 +      Where: ‘a0’ is an ambiguous type variable
 +    • In a stmt of a 'do' block: _ <- _
 +      In the expression:
 +        do _ <- _
 +           _
 +      In the untyped splice:
 +        $(do _ <- _
 +             _)
++
 +T26568.hs:6:3: error: [GHC-88464]
 +    • Found hole:
 +        _ :: GHC.Internal.TH.Monad.Q GHC.Internal.TH.Syntax.Exp
 +    • In a stmt of a 'do' block: _
 +      In the expression:
 +        do _ <- _
 +           _
 +      In the untyped splice:
 +        $(do _ <- _
 +             _)
++

testsuite/tests/th/all.T

@@ -625,6 +625,7 @@ test('T25256', normal, compile_and_run, [''])
  test('T24572a', normal, compile, [''])
  test('T24572b', normal, compile_fail, [''])
  test('T24572c', normal, compile_fail, [''])
 +test('T26568', normal, compile_fail, [''])
  test('T24572d', normal, compile, [''])
  test('T25209', normal, compile, ['-v0 -ddump-splices -dsuppress-uniques'])
  test('TH_MultilineStrings', normal, compile_and_run, [''])