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) ...@@ -145,7 +145,7 @@ cvtDec (TH.ValD pat body ds)
| TH.VarP s <- pat | TH.VarP s <- pat
= do { s' <- vNameL s = do { s' <- vNameL s
; cl' <- cvtClause (mkPrefixFunRhs s') (Clause [] body ds) ; cl' <- cvtClause (mkPrefixFunRhs s') (Clause [] body ds)
; returnJustL $ Hs.ValD $ mkFunBind FromSource s' [cl'] } ; returnJustL $ Hs.ValD $ mkFunBind s' [cl'] }
| otherwise | otherwise
= do { pat' <- cvtPat pat = do { pat' <- cvtPat pat
...@@ -164,7 +164,7 @@ cvtDec (TH.FunD nm cls) ...@@ -164,7 +164,7 @@ cvtDec (TH.FunD nm cls)
| otherwise | otherwise
= do { nm' <- vNameL nm = do { nm' <- vNameL nm
; cls' <- mapM (cvtClause (mkPrefixFunRhs nm')) cls ; cls' <- mapM (cvtClause (mkPrefixFunRhs nm')) cls
; returnJustL $ Hs.ValD $ mkFunBind FromSource nm' cls' } ; returnJustL $ Hs.ValD $ mkFunBind nm' cls' }
cvtDec (TH.SigD nm typ) cvtDec (TH.SigD nm typ)
= do { nm' <- vNameL nm = do { nm' <- vNameL nm
......
...@@ -782,14 +782,14 @@ l ...@@ -782,14 +782,14 @@ l
************************************************************************ ************************************************************************
-} -}
mkFunBind :: Origin -> Located RdrName -> [LMatch GhcPs (LHsExpr GhcPs)] mkFunBind :: Located RdrName -> [LMatch GhcPs (LHsExpr GhcPs)]
-> HsBind GhcPs -> HsBind GhcPs
-- Not infix, with place holders for coercion and free vars -- Not infix, with place holders for coercion and free vars
mkFunBind origin fn ms = FunBind { fun_id = fn mkFunBind fn ms = FunBind { fun_id = fn
, fun_matches = mkMatchGroup origin ms , fun_matches = mkMatchGroup Generated ms
, fun_co_fn = idHsWrapper , fun_co_fn = idHsWrapper
, bind_fvs = placeHolderNames , bind_fvs = placeHolderNames
, fun_tick = [] } , fun_tick = [] }
mkTopFunBind :: Origin -> Located Name -> [LMatch GhcRn (LHsExpr GhcRn)] mkTopFunBind :: Origin -> Located Name -> [LMatch GhcRn (LHsExpr GhcRn)]
-> HsBind GhcRn -> HsBind GhcRn
...@@ -830,7 +830,7 @@ isInfixFunBind _ = False ...@@ -830,7 +830,7 @@ isInfixFunBind _ = False
mk_easy_FunBind :: SrcSpan -> RdrName -> [LPat GhcPs] mk_easy_FunBind :: SrcSpan -> RdrName -> [LPat GhcPs]
-> LHsExpr GhcPs -> LHsBind GhcPs -> LHsExpr GhcPs -> LHsBind GhcPs
mk_easy_FunBind loc fun pats expr 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 [mkMatch (mkPrefixFunRhs (L loc fun)) pats expr
(noLoc emptyLocalBinds)] (noLoc emptyLocalBinds)]
......
...@@ -422,7 +422,7 @@ getMonoBind (L loc1 (FunBind { fun_id = fun_id1@(L _ f1), ...@@ -422,7 +422,7 @@ getMonoBind (L loc1 (FunBind { fun_id = fun_id1@(L _ f1),
= let doc_decls' = doc_decl : doc_decls = let doc_decls' = doc_decl : doc_decls
in go mtchs (combineSrcSpans loc loc2) binds doc_decls' in go mtchs (combineSrcSpans loc loc2) binds doc_decls'
go mtchs loc 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 doc_decls) ++ binds)
-- Reverse the final matches, to get it back in the right order -- Reverse the final matches, to get it back in the right order
-- Do the same thing with the trailing doc comments -- 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) ...@@ -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 let match_span = combineSrcSpans lhs_loc rhs_span
-- Add back the annotations stripped from any HsPar values in the lhs -- Add back the annotations stripped from any HsPar values in the lhs
-- mapM_ (\a -> a match_span) ann -- 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 [L match_span (Match { m_ctxt = FunRhs { mc_fun = fun
, mc_fixity = is_infix , mc_fixity = is_infix
, mc_strictness = strictness } , mc_strictness = strictness }
...@@ -1086,12 +1086,12 @@ checkFunBind msg strictness ann lhs_loc fun is_infix pats (L rhs_span grhss) ...@@ -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. -- The span of the match covers the entire equation.
-- That isn't quite right, but it'll do for now. -- 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 -> HsBind GhcPs
-- Like HsUtils.mkFunBind, but we need to be able to set the fixity too -- 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, = FunBind { fun_id = fn,
fun_matches = mkMatchGroup origin ms, fun_matches = mkMatchGroup FromSource ms,
fun_co_fn = idHsWrapper, fun_co_fn = idHsWrapper,
bind_fvs = placeHolderNames, bind_fvs = placeHolderNames,
fun_tick = [] } fun_tick = [] }
......
...@@ -1862,7 +1862,7 @@ mkFunBindSE arity loc fun pats_and_exprs ...@@ -1862,7 +1862,7 @@ mkFunBindSE arity loc fun pats_and_exprs
mkRdrFunBind :: Located RdrName -> [LMatch GhcPs (LHsExpr GhcPs)] mkRdrFunBind :: Located RdrName -> [LMatch GhcPs (LHsExpr GhcPs)]
-> LHsBind GhcPs -> LHsBind GhcPs
mkRdrFunBind fun@(L loc _fun_rdr) matches 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 -- | 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 -- with the given arity that uses an empty case expression for the last
...@@ -1890,8 +1890,7 @@ mkRdrFunBindEC :: Arity ...@@ -1890,8 +1890,7 @@ mkRdrFunBindEC :: Arity
-> [LMatch GhcPs (LHsExpr GhcPs)] -> [LMatch GhcPs (LHsExpr GhcPs)]
-> LHsBind GhcPs -> LHsBind GhcPs
mkRdrFunBindEC arity catch_all mkRdrFunBindEC arity catch_all
fun@(L loc _fun_rdr) matches fun@(L loc _fun_rdr) matches = L loc (mkFunBind fun matches')
= L loc (mkFunBind Generated fun matches')
where where
-- Catch-all eqn looks like -- Catch-all eqn looks like
-- fmap _ z = case z of {} -- fmap _ z = case z of {}
...@@ -1915,8 +1914,7 @@ mkRdrFunBindEC arity catch_all ...@@ -1915,8 +1914,7 @@ mkRdrFunBindEC arity catch_all
mkRdrFunBindSE :: Arity -> Located RdrName -> mkRdrFunBindSE :: Arity -> Located RdrName ->
[LMatch GhcPs (LHsExpr GhcPs)] -> LHsBind GhcPs [LMatch GhcPs (LHsExpr GhcPs)] -> LHsBind GhcPs
mkRdrFunBindSE arity mkRdrFunBindSE arity
fun@(L loc fun_rdr) matches fun@(L loc fun_rdr) matches = L loc (mkFunBind fun matches')
= L loc (mkFunBind Generated fun matches')
where where
-- Catch-all eqn looks like -- Catch-all eqn looks like
-- compare _ _ = error "Void compare" -- 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']) ...@@ -399,8 +399,6 @@ test('T14204', normal, compile_fail, ['-v0'])
test('T14060', normal, compile_and_run, ['-v0']) test('T14060', normal, compile_and_run, ['-v0'])
test('T14646', normal, compile, ['-v0 -ddump-splices -dsuppress-uniques']) test('T14646', normal, compile, ['-v0 -ddump-splices -dsuppress-uniques'])
test('T14681', 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('T14817', normal, compile, ['-v0 -ddump-splices -dsuppress-uniques'])
test('T14843', normal, compile, ['-v0']) test('T14843', normal, compile, ['-v0'])
test('T13776', normal, compile, ['-ddump-splices -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