Commit c054162a authored by Ben Gamari's avatar Ben Gamari Committed by Ben Gamari

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
parent 2534164a
......@@ -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
......
......@@ -782,11 +782,11 @@ 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
mkFunBind fn ms = FunBind { fun_id = fn
, fun_matches = mkMatchGroup Generated ms
, fun_co_fn = idHsWrapper
, bind_fvs = placeHolderNames
, fun_tick = [] }
......@@ -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)]
......
......@@ -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 = [] }
......
......@@ -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"
......
{-# LANGUAGE TemplateHaskell #-}
module T14838 where
import T14838Lib
$qIncompleteCase
$qIncompleteFunction
incompleteCase' :: Bool -> ()
incompleteCase' b = case b of
True -> ()
incompleteFunction' :: Bool -> ()
incompleteFunction' True = ()
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
{-# 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 = () |]
......@@ -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'])
......
Markdown is supported
0%
or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment