[Git][ghc/ghc][wip/expand-do] experimenting with irrefutable patterns

[Apoorv Ingle (@ani)]

Apoorv Ingle pushed to branch wip/expand-do at Glasgow Haskell Compiler / GHC


Commits:
a0785856 by Apoorv Ingle at 2023-05-05T20:21:39-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,77 @@ 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 (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')
         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 (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
 
         Just ax@(ACoAxiom _) -> pprPanic "isIrrefutableHsPatRn ACoAxiom" (ppr ax)
-        _ -> False -- conservative.
-    go (LitPat {})         = False
-    go (NPat {})           = False
-    go (NPlusKPat {})      = False
+        Nothing -> do traceTc "isIrrefutableHsPatRn no tycon" empty
+                      return True -- this may not be the right thing to do
+    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/a07858562ef9733d0c7fd7cc64fc868d2e574c6a

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/a07858562ef9733d0c7fd7cc64fc868d2e574c6a
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/d5f2233b/attachment-0001.html>