summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--compiler/hsSyn/Convert.hs4
-rw-r--r--compiler/hsSyn/HsUtils.hs14
-rw-r--r--compiler/parser/RdrHsSyn.hs10
-rw-r--r--compiler/typecheck/TcGenDeriv.hs8
-rw-r--r--testsuite/tests/th/T14838.hs14
-rw-r--r--testsuite/tests/th/T14838.stderr18
-rw-r--r--testsuite/tests/th/T14838Lib.hs14
-rw-r--r--testsuite/tests/th/all.T2
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'])
View Lorry Controller Status