Revert "Fix #14838 by marking TH-spliced code as FromSource"

This reverts commit ffb2738f.

Due to #14987.

Reviewers: goldfire, RyanGlScott

Reviewed By: RyanGlScott

Subscribers: RyanGlScott, thomie, carter

GHC Trac Issues: #14987, #14838

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

compiler/hsSyn/Convert.hs

@@ -145,7 +145,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 FromSource s' [cl'] }
+        ; returnJustL $ Hs.ValD $ mkFunBind s' [cl'] }
 
   | otherwise
   = do  { pat' <- cvtPat pat
@@ -164,7 +164,7 @@ cvtDec (TH.FunD nm cls)
   | otherwise
   = do  { nm' <- vNameL nm
         ; cls' <- mapM (cvtClause (mkPrefixFunRhs nm')) cls
-        ; returnJustL $ Hs.ValD $ mkFunBind FromSource nm' cls' }
+        ; returnJustL $ Hs.ValD $ mkFunBind nm' cls' }
 
 cvtDec (TH.SigD nm typ)
   = do  { nm' <- vNameL nm

compiler/hsSyn/HsUtils.hs

@@ -782,14 +782,14 @@ l
 ************************************************************************
 -}
 
-mkFunBind :: Origin -> Located RdrName -> [LMatch GhcPs (LHsExpr GhcPs)]
+mkFunBind :: Located RdrName -> [LMatch GhcPs (LHsExpr GhcPs)]
           -> HsBind GhcPs
 -- Not infix, with place holders for coercion and free vars
-mkFunBind origin fn ms = FunBind { fun_id = fn
-                                 , fun_matches = mkMatchGroup origin ms
-                                 , fun_co_fn = idHsWrapper
-                                 , bind_fvs = placeHolderNames
-                                 , fun_tick = [] }
+mkFunBind fn ms = FunBind { fun_id = fn
+                          , fun_matches = mkMatchGroup Generated ms
+                          , fun_co_fn = idHsWrapper
+                          , bind_fvs = placeHolderNames
+                          , fun_tick = [] }
 
 mkTopFunBind :: Origin -> Located Name -> [LMatch GhcRn (LHsExpr GhcRn)]
              -> HsBind GhcRn
@@ -830,7 +830,7 @@ isInfixFunBind _ = False
 mk_easy_FunBind :: SrcSpan -> RdrName -> [LPat GhcPs]
                 -> LHsExpr GhcPs -> LHsBind GhcPs
 mk_easy_FunBind loc fun pats expr
-  = L loc $ mkFunBind Generated (L loc fun)
+  = L loc $ mkFunBind (L loc fun)
               [mkMatch (mkPrefixFunRhs (L loc fun)) pats expr
                        (noLoc emptyLocalBinds)]
 

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 FromSource fun_id1 (reverse mtchs))
+        = ( L loc (makeFunBind 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
@@ -1077,7 +1077,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 FromSource fun
+        return (ann, makeFunBind fun
                   [L match_span (Match { m_ctxt = FunRhs { mc_fun    = fun
                                                          , mc_fixity = is_infix
                                                          , mc_strictness = strictness }
@@ -1086,12 +1086,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 :: Origin -> Located RdrName -> [LMatch GhcPs (LHsExpr GhcPs)]
+makeFunBind :: Located RdrName -> [LMatch GhcPs (LHsExpr GhcPs)]
             -> HsBind GhcPs
 -- Like HsUtils.mkFunBind, but we need to be able to set the fixity too
-makeFunBind origin fn ms
+makeFunBind fn ms
   = FunBind { fun_id = fn,
-              fun_matches = mkMatchGroup origin ms,
+              fun_matches = mkMatchGroup FromSource ms,
               fun_co_fn = idHsWrapper,
               bind_fvs = placeHolderNames,
               fun_tick = [] }

compiler/typecheck/TcGenDeriv.hs

@@ -1862,7 +1862,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 Generated fun matches)
+  = L loc (mkFunBind 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
@@ -1890,8 +1890,7 @@ mkRdrFunBindEC :: Arity
                -> [LMatch GhcPs (LHsExpr GhcPs)]
                -> LHsBind GhcPs
 mkRdrFunBindEC arity catch_all
-                 fun@(L loc _fun_rdr) matches
-  = L loc (mkFunBind Generated fun matches')
+                 fun@(L loc _fun_rdr) matches = L loc (mkFunBind fun matches')
  where
    -- Catch-all eqn looks like
    --     fmap _ z = case z of {}
@@ -1915,8 +1914,7 @@ 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 Generated fun matches')
+                 fun@(L loc fun_rdr) matches = L loc (mkFunBind fun matches')
  where
    -- Catch-all eqn looks like
    --     compare _ _ = error "Void compare"

testsuite/tests/th/T14838.hs

-{-# LANGUAGE TemplateHaskell #-}
-module T14838 where
-import T14838Lib
-
-$qIncompleteCase
-
-$qIncompleteFunction
-
-incompleteCase' :: Bool -> ()
-incompleteCase' b = case b of
-  True -> ()
-
-incompleteFunction' :: Bool -> ()
-incompleteFunction' True = ()

testsuite/tests/th/T14838.stderr

-
-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

testsuite/tests/th/T14838Lib.hs

-{-# 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 = () |]

testsuite/tests/th/all.T

@@ -399,8 +399,6 @@ 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'])
 test('T13776', normal, compile, ['-ddump-splices -v0'])