[commit: ghc] master: Fix logic error in GhcMake.enableCodeGenForTH (ea75124)

[git at git.haskell.org]

Repository : ssh://git@git.haskell.org/ghc

On branch  : master
Link       : http://ghc.haskell.org/trac/ghc/changeset/ea751248d80efe7633a31120da56e9a31b6820ff/ghc

>---------------------------------------------------------------

commit ea751248d80efe7633a31120da56e9a31b6820ff
Author: Douglas Wilson <douglas.wilson at gmail.com>
Date:   Tue Jul 11 13:58:17 2017 -0400

    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


>---------------------------------------------------------------

ea751248d80efe7633a31120da56e9a31b6820ff
 compiler/main/GhcMake.hs                           | 37 ++++++++++++----------
 testsuite/tests/th/should_compile/T13949/ASCII.hs  | 10 ++++++
 .../T12062 => th/should_compile/T13949}/Makefile   |  0
 .../th/should_compile/T13949/PatternGenerator.hs   |  8 +++++
 testsuite/tests/th/should_compile/T13949/These.hs  |  4 +++
 testsuite/tests/th/should_compile/T13949/Tree.hs   |  6 ++++
 testsuite/tests/th/should_compile/T13949/all.T     |  2 ++
 7 files changed, 51 insertions(+), 16 deletions(-)

diff --git a/compiler/main/GhcMake.hs b/compiler/main/GhcMake.hs
index 4706672..f4ea4de 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 at 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 0000000..4539987
--- /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/driver/T12062/Makefile b/testsuite/tests/th/should_compile/T13949/Makefile
similarity index 100%
copy from testsuite/tests/driver/T12062/Makefile
copy to testsuite/tests/th/should_compile/T13949/Makefile
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 0000000..2805650
--- /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 0000000..eefe506
--- /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 0000000..d6fdc0c
--- /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 0000000..9975e58
--- /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