[Git][ghc/ghc][wip/expand-do] experimenting with irrefutable patterns
Apoorv Ingle (@ani)
gitlab at gitlab.haskell.org
Sat May 6 01:51:55 UTC 2023
Apoorv Ingle pushed to branch wip/expand-do at Glasgow Haskell Compiler / GHC
Commits:
ab8861a6 by Apoorv Ingle at 2023-05-05T20:51:44-05:00
experimenting with irrefutable patterns
- - - - -
2 changed files:
- compiler/GHC/Tc/Gen/Match.hs
- compiler/GHC/Tc/Gen/Pat.hs
Changes:
=====================================
compiler/GHC/Tc/Gen/Match.hs
=====================================
@@ -1383,11 +1383,12 @@ mk_failable_lexpr_tcm :: LPat GhcRn -> LHsExpr GhcRn -> FailOperator GhcRn -> Tc
mk_failable_lexpr_tcm pat lexpr fail_op =
do { tc_env <- getGblEnv
; is_strict <- xoptM LangExt.Strict
+ ; b <- isIrrefutableHsPatRn tc_env is_strict pat
; traceTc "mk_fail_lexpr_tcm" (vcat [ ppr pat
- , ppr $ isIrrefutableHsPatRn tc_env is_strict pat
+ , text "isIrrefutable:" <+> ppr b
])
- ; if isIrrefutableHsPatRn tc_env is_strict pat
+ ; if b
-- don't decorate with fail statement if
-- 1) the pattern is irrefutable
then return $ mkHsLam [pat] (noLocA (PopSrcSpan lexpr))
=====================================
compiler/GHC/Tc/Gen/Pat.hs
=====================================
@@ -1623,55 +1623,78 @@ checkGADT conlike ex_tvs arg_tys = \case
has_existentials :: Bool
has_existentials = any (`elemVarSet` tyCoVarsOfTypes arg_tys) ex_tvs
--- | Very similar to GHC.Tc.Pat.isIrrefutableHsPat, but doesn't depend on the
-isIrrefutableHsPatRn :: TcGblEnv -> Bool -> LPat GhcRn -> Bool
-isIrrefutableHsPatRn tc_env@(TcGblEnv{tcg_type_env = type_env}) is_strict = goL
+-- | Very similar to GHC.Tc.Pat.isIrrefutableHsPat, but doesn't depend on type checking
+isIrrefutableHsPatRn :: TcGblEnv -> Bool -> LPat GhcRn -> TcM Bool
+isIrrefutableHsPatRn tc_env@(TcGblEnv{tcg_type_env = type_env}) is_strict pat =
+ do traceTc "isIrrefutableHsPatRn" empty
+ goL pat
where
- goL :: LPat GhcRn -> Bool
+ goL :: LPat GhcRn -> TcM Bool
goL = go . unLoc
- go :: Pat GhcRn -> Bool
- go (WildPat {}) = True
- go (VarPat {}) = True
+ go :: Pat GhcRn -> TcM Bool
+ go (WildPat {}) = return True
+ go (VarPat {}) = return True
go (LazyPat _ p')
| is_strict
= isIrrefutableHsPatRn tc_env False p'
- | otherwise = True
+ | otherwise = return True
go (BangPat _ pat) = goL pat
go (ParPat _ _ pat _) = goL pat
go (AsPat _ _ _ pat) = goL pat
go (ViewPat _ _ pat) = goL pat
go (SigPat _ pat _) = goL pat
- go (TuplePat _ pats _) = all goL pats
- go (SumPat {}) = False
+ go (TuplePat _ pats _) =
+ do traceTc "isIrrefutableHsPatRn TuplePat" empty
+ foldM (\a p -> do {b <- goL p; return (a && b)}) True pats
+
+ go (SumPat {}) = return False
-- See Note [Unboxed sum patterns aren't irrefutable]
- go (ListPat {}) = False
+ go (ListPat {}) = return False
go (ConPat
{ pat_con = L _ dcName
, pat_args = details }) =
- case lookupTypeEnv type_env dcName of
- Just (ATyCon tycon) ->
- (isJust (tyConSingleDataCon_maybe tycon)
- || isNewTyCon tycon)
- && all goL (hsConPatArgs details)
- Just id@(AnId _) -> pprPanic "isIrrefutableHsPatRn AnId" (ppr id)
- Just (AConLike cl) -> case cl of
- RealDataCon dc -> let tycon = dataConTyCon dc in
- (isJust (tyConSingleDataCon_maybe tycon)
- || isNewTyCon tycon)
- && all goL (hsConPatArgs details)
- PatSynCon _ -> False -- conservative
-
- Just ax@(ACoAxiom _) -> pprPanic "isIrrefutableHsPatRn ACoAxiom" (ppr ax)
- _ -> False -- conservative.
- go (LitPat {}) = False
- go (NPat {}) = False
- go (NPlusKPat {}) = False
+ do { tyth <- tcLookupGlobal dcName
+ ; traceTc "isIrrefutableHsPatRn dataCon" (ppr tyth)
+ ; case tyth of
+ (ATyCon tycon) ->
+ do { b <- foldM (\a p -> do {b <- goL p; return (a && b)}) True (hsConPatArgs details)
+ ; traceTc "isIrrefutableHsPatRn ATyCon" (vcat [ ppr tycon
+ , ppr (isNewTyCon tycon)
+ , ppr (tcHasFixedRuntimeRep tycon)])
+ ; let b' = (isJust (tyConSingleDataCon_maybe tycon)
+ || isNewTyCon tycon
+ || tcHasFixedRuntimeRep tycon)
+ ; return (b && b') }
+ id@(AnId _) -> pprPanic "isIrrefutableHsPatRn AnId" (ppr id)
+ (AConLike cl) ->
+ case cl of
+ RealDataCon dc ->
+ do let tycon = dataConTyCon dc
+ b <- foldM (\a p -> do {b <- goL p; return (a && b)})
+ True (hsConPatArgs details)
+ traceTc "isIrrefutableHsPatRn AConLike" (vcat [ ppr tycon
+ , ppr (isNewTyCon tycon)
+ , ppr (tcHasFixedRuntimeRep tycon)] )
+ let b' = (isJust (tyConSingleDataCon_maybe tycon)
+ || isNewTyCon tycon
+ || tcHasFixedRuntimeRep tycon)
+ return (b && b')
+ PatSynCon con -> do traceTc "isIrrefutableHsPatRn AConLike" (ppr con)
+ return False -- conservative
+
+ ax@(ACoAxiom _) -> pprPanic "isIrrefutableHsPatRn ACoAxiom" (ppr ax)
+ }
+ go (LitPat {}) = do traceTc "isIrrefutableHsPatRn LitPat" empty
+ return False
+ go (NPat {}) = return False
+ go (NPlusKPat {}) = return False
-- We conservatively assume that no TH splices are irrefutable
-- since we cannot know until the splice is evaluated.
- go (SplicePat {}) = False
+ go (SplicePat {}) = return False
go (XPat ext) = case ext of
- HsPatExpanded _ pat -> go pat
+ HsPatExpanded _ pat -> do traceTc "isIrrefutableHsPatRn HsPatEx" empty
+ go pat
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/ab8861a684d86355df6be6837a52f0beca19501f
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/ab8861a684d86355df6be6837a52f0beca19501f
You're receiving this email because of your account on gitlab.haskell.org.
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20230505/d81d0394/attachment-0001.html>
More information about the ghc-commits
mailing list