Fix #14838 by marking TH-spliced code as FromSource

Previously, any Template Haskell code that was spliced would
be marked as `Generated`, which would completely suppress pattern-
match coverage warnings for it, which several folks found confusing.
Indeed, Template Haskell-spliced code is "source" code in some sense,
as users specifically request that it be put into their program, so
changing its designation to `FromSource` makes sense from that
perspective.

Test Plan: make test TEST=T14838

Reviewers: goldfire, bgamari

Reviewed By: bgamari

Subscribers: rwbarton, thomie, carter

GHC Trac Issues: #14838

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

8 files changed, 67 insertions, 17 deletions

diff --git a/compiler/hsSyn/Convert.hs b/compiler/hsSyn/Convert.hs
index c1cf77b39c..531f146a9d 100644
--- a/compiler/hsSyn/Convert.hs
+++ b/compiler/hsSyn/Convert.hs
@@ -144,7 +144,7 @@ cvtDec (TH.ValD pat body ds)
   | TH.VarP s <- pat
   = do  { s' <- vNameL s
         ; cl' <- cvtClause (mkPrefixFunRhs s') (Clause [] body ds)
-        ; returnJustL $ Hs.ValD $ mkFunBind s' [cl'] }
+        ; returnJustL $ Hs.ValD $ mkFunBind FromSource s' [cl'] }
 
   | otherwise
   = do  { pat' <- cvtPat pat
@@ -163,7 +163,7 @@ cvtDec (TH.FunD nm cls)
   | otherwise
   = do  { nm' <- vNameL nm
         ; cls' <- mapM (cvtClause (mkPrefixFunRhs nm')) cls
-        ; returnJustL $ Hs.ValD $ mkFunBind nm' cls' }
+        ; returnJustL $ Hs.ValD $ mkFunBind FromSource nm' cls' }
 
 cvtDec (TH.SigD nm typ)
   = do  { nm' <- vNameL nm
diff --git a/compiler/hsSyn/HsUtils.hs b/compiler/hsSyn/HsUtils.hs
index 2937c1a657..55fa0e4a0a 100644
--- a/compiler/hsSyn/HsUtils.hs
+++ b/compiler/hsSyn/HsUtils.hs
@@ -768,14 +768,14 @@ l
 ************************************************************************
 -}
 
-mkFunBind :: Located RdrName -> [LMatch GhcPs (LHsExpr GhcPs)]
+mkFunBind :: Origin -> Located RdrName -> [LMatch GhcPs (LHsExpr GhcPs)]
           -> HsBind GhcPs
 -- Not infix, with place holders for coercion and free vars
-mkFunBind fn ms = FunBind { fun_id = fn
-                          , fun_matches = mkMatchGroup Generated ms
-                          , fun_co_fn = idHsWrapper
-                          , bind_fvs = placeHolderNames
-                          , fun_tick = [] }
+mkFunBind origin fn ms = FunBind { fun_id = fn
+                                 , fun_matches = mkMatchGroup origin ms
+                                 , fun_co_fn = idHsWrapper
+                                 , bind_fvs = placeHolderNames
+                                 , fun_tick = [] }
 
 mkTopFunBind :: Origin -> Located Name -> [LMatch GhcRn (LHsExpr GhcRn)]
              -> HsBind GhcRn
@@ -816,7 +816,7 @@ isInfixFunBind _ = False
 mk_easy_FunBind :: SrcSpan -> RdrName -> [LPat GhcPs]
                 -> LHsExpr GhcPs -> LHsBind GhcPs
 mk_easy_FunBind loc fun pats expr
-  = L loc $ mkFunBind (L loc fun)
+  = L loc $ mkFunBind Generated (L loc fun)
               [mkMatch (mkPrefixFunRhs (L loc fun)) pats expr
                        (noLoc emptyLocalBinds)]
 
diff --git a/compiler/parser/RdrHsSyn.hs b/compiler/parser/RdrHsSyn.hs
index 6ac6cbc974..e2943c8001 100644
--- a/compiler/parser/RdrHsSyn.hs
+++ b/compiler/parser/RdrHsSyn.hs
@@ -422,7 +422,7 @@ getMonoBind (L loc1 (FunBind { fun_id = fun_id1@(L _ f1),
         = let doc_decls' = doc_decl : doc_decls
           in go mtchs (combineSrcSpans loc loc2) binds doc_decls'
     go mtchs loc binds doc_decls
-        = ( L loc (makeFunBind fun_id1 (reverse mtchs))
+        = ( L loc (makeFunBind FromSource fun_id1 (reverse mtchs))
           , (reverse doc_decls) ++ binds)
         -- Reverse the final matches, to get it back in the right order
         -- Do the same thing with the trailing doc comments
@@ -1075,7 +1075,7 @@ checkFunBind msg strictness ann lhs_loc fun is_infix pats (L rhs_span grhss)
         let match_span = combineSrcSpans lhs_loc rhs_span
         -- Add back the annotations stripped from any HsPar values in the lhs
         -- mapM_ (\a -> a match_span) ann
-        return (ann, makeFunBind fun
+        return (ann, makeFunBind FromSource fun
                   [L match_span (Match { m_ctxt = FunRhs { mc_fun    = fun
                                                          , mc_fixity = is_infix
                                                          , mc_strictness = strictness }
@@ -1084,12 +1084,12 @@ checkFunBind msg strictness ann lhs_loc fun is_infix pats (L rhs_span grhss)
         -- The span of the match covers the entire equation.
         -- That isn't quite right, but it'll do for now.
 
-makeFunBind :: Located RdrName -> [LMatch GhcPs (LHsExpr GhcPs)]
+makeFunBind :: Origin -> Located RdrName -> [LMatch GhcPs (LHsExpr GhcPs)]
             -> HsBind GhcPs
 -- Like HsUtils.mkFunBind, but we need to be able to set the fixity too
-makeFunBind fn ms
+makeFunBind origin fn ms
   = FunBind { fun_id = fn,
-              fun_matches = mkMatchGroup FromSource ms,
+              fun_matches = mkMatchGroup origin ms,
               fun_co_fn = idHsWrapper,
               bind_fvs = placeHolderNames,
               fun_tick = [] }
diff --git a/compiler/typecheck/TcGenDeriv.hs b/compiler/typecheck/TcGenDeriv.hs
index 1ac350523a..0a5c5aab65 100644
--- a/compiler/typecheck/TcGenDeriv.hs
+++ b/compiler/typecheck/TcGenDeriv.hs
@@ -1857,7 +1857,7 @@ mkFunBindSE arity loc fun pats_and_exprs
 mkRdrFunBind :: Located RdrName -> [LMatch GhcPs (LHsExpr GhcPs)]
              -> LHsBind GhcPs
 mkRdrFunBind fun@(L loc _fun_rdr) matches
-  = L loc (mkFunBind fun matches)
+  = L loc (mkFunBind Generated fun matches)
 
 -- | Make a function binding. If no equations are given, produce a function
 -- with the given arity that uses an empty case expression for the last
@@ -1885,7 +1885,8 @@ mkRdrFunBindEC :: Arity
                -> [LMatch GhcPs (LHsExpr GhcPs)]
                -> LHsBind GhcPs
 mkRdrFunBindEC arity catch_all
-                 fun@(L loc _fun_rdr) matches = L loc (mkFunBind fun matches')
+                 fun@(L loc _fun_rdr) matches
+  = L loc (mkFunBind Generated fun matches')
  where
    -- Catch-all eqn looks like
    --     fmap _ z = case z of {}
@@ -1909,7 +1910,8 @@ mkRdrFunBindEC arity catch_all
 mkRdrFunBindSE :: Arity -> Located RdrName ->
                     [LMatch GhcPs (LHsExpr GhcPs)] -> LHsBind GhcPs
 mkRdrFunBindSE arity
-                 fun@(L loc fun_rdr) matches = L loc (mkFunBind fun matches')
+                 fun@(L loc fun_rdr) matches
+  = L loc (mkFunBind Generated fun matches')
  where
    -- Catch-all eqn looks like
    --     compare _ _ = error "Void compare"
diff --git a/testsuite/tests/th/T14838.hs b/testsuite/tests/th/T14838.hs
new file mode 100644
index 0000000000..bb3be90c7a
--- /dev/null
+++ b/testsuite/tests/th/T14838.hs
@@ -0,0 +1,14 @@
+{-# LANGUAGE TemplateHaskell #-}
+module T14838 where
+import T14838Lib
+
+$qIncompleteCase
+
+$qIncompleteFunction
+
+incompleteCase' :: Bool -> ()
+incompleteCase' b = case b of
+  True -> ()
+
+incompleteFunction' :: Bool -> ()
+incompleteFunction' True = ()
diff --git a/testsuite/tests/th/T14838.stderr b/testsuite/tests/th/T14838.stderr
new file mode 100644
index 0000000000..6b268b3a3c
--- /dev/null
+++ b/testsuite/tests/th/T14838.stderr
@@ -0,0 +1,18 @@
+
+T14838.hs:5:1: warning: [-Wincomplete-patterns (in -Wextra)]
+    Pattern match(es) are non-exhaustive
+    In a case alternative: Patterns not matched: False
+
+T14838.hs:7:1: warning: [-Wincomplete-patterns (in -Wextra)]
+    Pattern match(es) are non-exhaustive
+    In an equation for ‘incompleteFunction’:
+        Patterns not matched: False
+
+T14838.hs:10:21: warning: [-Wincomplete-patterns (in -Wextra)]
+    Pattern match(es) are non-exhaustive
+    In a case alternative: Patterns not matched: False
+
+T14838.hs:14:1: warning: [-Wincomplete-patterns (in -Wextra)]
+    Pattern match(es) are non-exhaustive
+    In an equation for ‘incompleteFunction'’:
+        Patterns not matched: False
diff --git a/testsuite/tests/th/T14838Lib.hs b/testsuite/tests/th/T14838Lib.hs
new file mode 100644
index 0000000000..42e91afa9a
--- /dev/null
+++ b/testsuite/tests/th/T14838Lib.hs
@@ -0,0 +1,14 @@
+{-# LANGUAGE TemplateHaskell #-}
+module T14838Lib where
+import Language.Haskell.TH
+
+qIncompleteCase :: Q [Dec]
+qIncompleteCase = [d|
+  incompleteCase :: Bool -> ()
+  incompleteCase b = case b of
+    True -> () |]
+
+qIncompleteFunction :: Q [Dec]
+qIncompleteFunction =[d|
+  incompleteFunction :: Bool -> ()
+  incompleteFunction True = () |]
diff --git a/testsuite/tests/th/all.T b/testsuite/tests/th/all.T
index 50e731406d..47e8a9c03c 100644
--- a/testsuite/tests/th/all.T
+++ b/testsuite/tests/th/all.T
@@ -399,5 +399,7 @@ test('T14204', normal, compile_fail, ['-v0'])
 test('T14060', normal, compile_and_run, ['-v0'])
 test('T14646', normal, compile, ['-v0 -ddump-splices -dsuppress-uniques'])
 test('T14681', normal, compile, ['-v0 -ddump-splices -dsuppress-uniques'])
+test('T14838', [], multimod_compile,
+     ['T14838.hs', '-v0 -Wincomplete-patterns ' + config.ghc_th_way_flags])
 test('T14817', normal, compile, ['-v0 -ddump-splices -dsuppress-uniques'])
 test('T14843', normal, compile, ['-v0'])