Fix logic error in GhcMake.enableCodeGenForTH

transitive_deps_set was incorrect, it was not considering the
dependencies of dependencies in some cases. I've corrected it and tidied
it up a little.

The test case from leftaroundabout, as linked to from the ticket, is
added with small modifications to flatten directory structure.

Test Plan: make test TEST=T13949

Reviewers: austin, bgamari, alexbiehl

Reviewed By: alexbiehl

Subscribers: rwbarton, thomie, alexbiehl

GHC Trac Issues: #13949

Differential Revision: https://phabricator.haskell.org/D3720

7 files changed, 54 insertions, 16 deletions

diff --git a/compiler/main/GhcMake.hs b/compiler/main/GhcMake.hs
index 4706672e55..f4ea4de28d 100644
--- a/compiler/main/GhcMake.hs
+++ b/compiler/main/GhcMake.hs
@@ -1994,27 +1994,32 @@ enableCodeGenForTH target nodemap =
           , ms_hspp_opts = updOptLevel 0 $ dflags {hscTarget = target}
           }
       | otherwise = return ms
-    needs_codegen_set = transitive_deps_set Set.empty th_modSums
-    th_modSums =
+
+    needs_codegen_set = transitive_deps_set
       [ ms
       | mss <- Map.elems nodemap
       , Right ms <- mss
       , needsTemplateHaskellOrQQ $ [ms]
       ]
-    transitive_deps_set marked_mods modSums = foldl' go marked_mods modSums
-    go marked_mods ms
-      | Set.member (ms_mod ms) marked_mods = marked_mods
-      | otherwise =
-        let deps =
-              [ dep_ms
-              | (L _ mn, NotBoot) <- msDeps ms
-              , dep_ms <-
-                  toList (Map.lookup (mn, NotBoot) nodemap) >>= toList >>=
-                  toList
-              ]
-            new_marked_mods =
-              marked_mods `Set.union` Set.fromList (fmap ms_mod deps)
-        in transitive_deps_set new_marked_mods deps
+
+    -- find the set of all transitive dependencies of a list of modules.
+    transitive_deps_set modSums = foldl' go Set.empty modSums
+      where
+        go marked_mods ms@ModSummary{ms_mod}
+          | ms_mod `Set.member` marked_mods = marked_mods
+          | otherwise =
+            let deps =
+                  [ dep_ms
+                  -- If a module imports a boot module, msDeps helpfully adds a
+                  -- dependency to that non-boot module in it's result. This
+                  -- means we don't have to think about boot modules here.
+                  | (L _ mn, NotBoot) <- msDeps ms
+                  , dep_ms <-
+                      toList (Map.lookup (mn, NotBoot) nodemap) >>= toList >>=
+                      toList
+                  ]
+                new_marked_mods = Set.insert ms_mod marked_mods
+            in foldl' go new_marked_mods deps
 
 mkRootMap :: [ModSummary] -> NodeMap [Either ErrMsg ModSummary]
 mkRootMap summaries = Map.insertListWith (flip (++))
diff --git a/testsuite/tests/th/should_compile/T13949/ASCII.hs b/testsuite/tests/th/should_compile/T13949/ASCII.hs
new file mode 100644
index 0000000000..4539987cf1
--- /dev/null
+++ b/testsuite/tests/th/should_compile/T13949/ASCII.hs
@@ -0,0 +1,10 @@
+{-# LANGUAGE TemplateHaskell       #-}
+
+module ASCII () where
+
+import Tree
+import PatternGenerator
+
+type EP g = Bool
+
+templateFoo ''EP ['A'..'Z']
diff --git a/testsuite/tests/th/should_compile/T13949/Makefile b/testsuite/tests/th/should_compile/T13949/Makefile
new file mode 100644
index 0000000000..1c39d1c1fe
--- /dev/null
+++ b/testsuite/tests/th/should_compile/T13949/Makefile
@@ -0,0 +1,3 @@
+TOP=../../../..
+include $(TOP)/mk/boilerplate.mk
+include $(TOP)/mk/test.mk
diff --git a/testsuite/tests/th/should_compile/T13949/PatternGenerator.hs b/testsuite/tests/th/should_compile/T13949/PatternGenerator.hs
new file mode 100644
index 0000000000..2805650921
--- /dev/null
+++ b/testsuite/tests/th/should_compile/T13949/PatternGenerator.hs
@@ -0,0 +1,8 @@
+module PatternGenerator where
+
+import Tree
+
+import Language.Haskell.TH
+
+templateFoo :: Name -> [Char] -> DecsQ
+templateFoo _ _ = return []
diff --git a/testsuite/tests/th/should_compile/T13949/These.hs b/testsuite/tests/th/should_compile/T13949/These.hs
new file mode 100644
index 0000000000..eefe506d3e
--- /dev/null
+++ b/testsuite/tests/th/should_compile/T13949/These.hs
@@ -0,0 +1,4 @@
+module These where
+
+tuc :: t (k, a)
+tuc = undefined
diff --git a/testsuite/tests/th/should_compile/T13949/Tree.hs b/testsuite/tests/th/should_compile/T13949/Tree.hs
new file mode 100644
index 0000000000..d6fdc0cc6f
--- /dev/null
+++ b/testsuite/tests/th/should_compile/T13949/Tree.hs
@@ -0,0 +1,6 @@
+module Tree where
+
+import These
+
+mp :: Maybe (Int, ())
+mp = tuc
diff --git a/testsuite/tests/th/should_compile/T13949/all.T b/testsuite/tests/th/should_compile/T13949/all.T
new file mode 100644
index 0000000000..9975e58bf3
--- /dev/null
+++ b/testsuite/tests/th/should_compile/T13949/all.T
@@ -0,0 +1,2 @@
+test('T13949', extra_files(['ASCII.hs', 'PatternGenerator.hs', 'These.hs', 'Tree.hs']),
+     multimod_compile, ['ASCII PatternGenerator These Tree', '-fno-code -v0'])
\ No newline at end of file