Commit 30f5ac07 authored by Sebastian Graf's avatar Sebastian Graf Committed by Marge Bot

Much simpler language for PmCheck

Simon realised that the simple language composed of let bindings, bang
patterns and flat constructor patterns is enough to capture the
semantics of the source pattern language that are important for
pattern-match checking. Well, given that the Oracle is smart enough to
connect the dots in this less informationally dense form, which it is
now.

So we transform `translatePat` to return a list of `PmGrd`s relative to
an incoming match variable. `pmCheck` then trivially translates each of
the `PmGrd`s into constraints that the oracle understands.

Since we pass in the match variable, we incidentally fix #15884
(coverage checks for view patterns) through an interaction with !1746.
parent d584e3f0
Pipeline #11277 failed with stages
in 352 minutes and 27 seconds
This diff is collapsed.
......@@ -93,7 +93,7 @@ tracePm herald doc = do
-- | Generate a fresh `Id` of a given type
mkPmId :: Type -> DsM Id
mkPmId ty = getUniqueM >>= \unique ->
let occname = mkVarOccFS $ fsLit "$pm"
let occname = mkVarOccFS $ fsLit "pm"
name = mkInternalName unique occname noSrcSpan
in return (mkLocalId name ty)
......@@ -1576,8 +1576,8 @@ addVarCoreCt delta x e = runMaybeT (execStateT (core_expr x e) delta)
= do { arg_ids <- traverse bind_expr args
; data_con_app x dc arg_ids }
-- See Note [Detecting pattern synonym applications in expressions]
| Var y <- e, not (isDataConWorkId x)
-- We don't consider (unsaturated!) DataCons as flexible variables
| Var y <- e, Nothing <- isDataConId_maybe x
-- We don't consider DataCons flexible variables
= modifyT (\delta -> addVarVarCt delta (x, y))
| otherwise
-- Any other expression. Try to find other uses of a semantically
......@@ -1635,9 +1635,9 @@ Compared to the situation where P and Q are DataCons, the lack of generativity
means we could never flag Q as redundant.
(also see Note [Undecidable Equality for PmAltCons] in PmTypes.)
On the other hand, if we fail to recognise the pattern synonym, we flag the
pattern match as incomplete. That wouldn't happen if had knowledge about the
scrutinee, in which case the oracle basically knows "If it's a P, then its field
is 15".
pattern match as inexhaustive. That wouldn't happen if we had knowledge about
the scrutinee, in which case the oracle basically knows "If it's a P, then its
field is 15".
This is a pretty narrow use case and I don't think we should to try to fix it
until a user complains energetically.
......
......@@ -327,7 +327,7 @@ dsProcExpr pat (dL->L _ (HsCmdTop (CmdTopTc _unitTy cmd_ty ids) cmd)) = do
fail_expr <- mkFailExpr ProcExpr env_stk_ty
var <- selectSimpleMatchVarL pat
match_code <- matchSimply (Var var) ProcExpr pat env_stk_expr fail_expr
let pat_ty = hsLPatType pat
let pat_ty = hsPatType pat
let proc_code = do_premap meth_ids pat_ty env_stk_ty cmd_ty
(Lam var match_code)
core_cmd
......@@ -868,7 +868,7 @@ dsCmdStmt ids local_vars out_ids (BodyStmt c_ty cmd _ _) env_ids = do
-- but that's likely to be defined in terms of first.
dsCmdStmt ids local_vars out_ids (BindStmt _ pat cmd _ _) env_ids = do
let pat_ty = hsLPatType pat
let pat_ty = hsPatType pat
(core_cmd, fv_cmd, env_ids1) <- dsfixCmd ids local_vars unitTy pat_ty cmd
let pat_vars = mkVarSet (collectPatBinders pat)
let
......
module DsBinds where
import DsMonad ( DsM )
import CoreSyn ( CoreExpr )
import TcEvidence (HsWrapper)
dsHsWrapper :: HsWrapper -> DsM (CoreExpr -> CoreExpr)
......@@ -930,7 +930,7 @@ dsDo stmts
(pat, dsDo (stmts ++ [noLoc $ mkLastStmt (noLoc ret)]))
do_arg (XApplicativeArg nec) = noExtCon nec
arg_tys = map hsLPatType pats
arg_tys = map hsPatType pats
; rhss' <- sequence rhss
......
......@@ -279,7 +279,7 @@ deBindComp pat core_list1 quals core_list2 = do
let u3_ty@u1_ty = exprType core_list1 -- two names, same thing
-- u1_ty is a [alpha] type, and u2_ty = alpha
let u2_ty = hsLPatType pat
let u2_ty = hsPatType pat
let res_ty = exprType core_list2
h_ty = u1_ty `mkVisFunTy` res_ty
......@@ -373,7 +373,7 @@ dfBindComp :: Id -> Id -- 'c' and 'n'
-> DsM CoreExpr
dfBindComp c_id n_id (pat, core_list1) quals = do
-- find the required type
let x_ty = hsLPatType pat
let x_ty = hsPatType pat
let b_ty = idType n_id
-- create some new local id's
......
......@@ -672,7 +672,7 @@ mkSelectorBinds ticks pat val_expr
= return (v, [(v, val_expr)])
| is_flat_prod_lpat pat' -- Special case (B)
= do { let pat_ty = hsLPatType pat'
= do { let pat_ty = hsPatType pat'
; val_var <- newSysLocalDsNoLP pat_ty
; let mk_bind tick bndr_var
......@@ -758,7 +758,7 @@ mkLHsPatTup lpats = cL (getLoc (head lpats)) $
mkVanillaTuplePat :: [OutPat GhcTc] -> Boxity -> Pat GhcTc
-- A vanilla tuple pattern simply gets its type from its sub-patterns
mkVanillaTuplePat pats box = TuplePat (map hsLPatType pats) pats box
mkVanillaTuplePat pats box = TuplePat (map hsPatType pats) pats box
-- The Big equivalents for the source tuple expressions
mkBigLHsVarTupId :: [Id] -> LHsExpr GhcTc
......
......@@ -16,7 +16,7 @@ import {-# SOURCE #-} TcExpr( tcMonoExpr, tcInferRho, tcSyntaxOp, tcCheckId, t
import GHC.Hs
import TcMatches
import TcHsSyn( hsLPatType )
import TcHsSyn( hsPatType )
import TcType
import TcMType
import TcBinds
......@@ -257,7 +257,7 @@ tc_cmd env
; let match' = L mtch_loc (Match { m_ext = noExtField
, m_ctxt = LambdaExpr, m_pats = pats'
, m_grhss = grhss' })
arg_tys = map hsLPatType pats'
arg_tys = map hsPatType pats'
cmd' = HsCmdLam x (MG { mg_alts = L l [match']
, mg_ext = MatchGroupTc arg_tys res_ty
, mg_origin = origin })
......
......@@ -16,7 +16,7 @@ checker.
module TcHsSyn (
-- * Extracting types from HsSyn
hsLitType, hsLPatType, hsPatType,
hsLitType, hsPatType,
-- * Other HsSyn functions
mkHsDictLet, mkHsApp,
......@@ -96,15 +96,12 @@ import Control.Arrow ( second )
-}
hsLPatType :: OutPat GhcTc -> Type
hsLPatType lpat = hsPatType (unLoc lpat)
hsPatType :: Pat GhcTc -> Type
hsPatType (ParPat _ pat) = hsLPatType pat
hsPatType (ParPat _ pat) = hsPatType pat
hsPatType (WildPat ty) = ty
hsPatType (VarPat _ lvar) = idType (unLoc lvar)
hsPatType (BangPat _ pat) = hsLPatType pat
hsPatType (LazyPat _ pat) = hsLPatType pat
hsPatType (BangPat _ pat) = hsPatType pat
hsPatType (LazyPat _ pat) = hsPatType pat
hsPatType (LitPat _ lit) = hsLitType lit
hsPatType (AsPat _ var _) = idType (unLoc var)
hsPatType (ViewPat ty _ _) = ty
......@@ -120,7 +117,10 @@ hsPatType (SigPat ty _ _) = ty
hsPatType (NPat ty _ _ _) = ty
hsPatType (NPlusKPat ty _ _ _ _ _) = ty
hsPatType (CoPat _ _ _ ty) = ty
hsPatType p = pprPanic "hsPatType" (ppr p)
-- XPat wraps a Located (Pat GhcTc) in GhcTc
hsPatType (XPat lpat) = hsPatType (unLoc lpat)
hsPatType ConPatIn{} = panic "hsPatType: ConPatIn"
hsPatType SplicePat{} = panic "hsPatType: SplicePat"
hsLitType :: HsLit (GhcPass p) -> TcType
hsLitType (HsChar _ _) = charTy
......
......@@ -9,5 +9,5 @@ test('T13615',
# reproduction probability is around 75% on my dual-core hyperthreaded
# laptop.
extra_run_opts('+RTS -N15 -ki4k')],
multimod_compile_and_run,
[fragile_for(17269, 'threaded1'), multimod_compile_and_run],
['T13615','-rtsopts'])
......@@ -11,3 +11,9 @@ safeLast xs
safeLast2 :: [a] -> Maybe a
safeLast2 (reverse -> []) = Nothing
safeLast2 (reverse -> (x:_)) = Just x
safeLast3 :: [a] -> Maybe a
safeLast3 xs
| [] <- reverse xs = Nothing
safeLast3 xs'
| (x:_) <- reverse xs' = Just x
......@@ -76,7 +76,7 @@ test('T15753c', normal, compile,
['-fwarn-incomplete-patterns -fwarn-overlapping-patterns'])
test('T15753d', normal, compile,
['-fwarn-incomplete-patterns -fwarn-overlapping-patterns'])
test('T15884', expect_broken(15884), compile,
test('T15884', normal, compile,
['-fwarn-incomplete-patterns -fwarn-overlapping-patterns'])
test('T16289', normal, compile,
['-fwarn-incomplete-patterns -fwarn-overlapping-patterns'])
......
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