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

Apoorv Ingle (@ani) gitlab at gitlab.haskell.org
Sat May 6 02:01:54 UTC 2023



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


Commits:
4e9c64e6 by Apoorv Ingle at 2023-05-05T21:01:42-05:00
experimenting with irrefutable patterns

- - - - -


3 changed files:

- compiler/GHC/HsToCore/Match.hs
- compiler/GHC/Tc/Gen/Match.hs
- compiler/GHC/Tc/Gen/Pat.hs


Changes:

=====================================
compiler/GHC/HsToCore/Match.hs
=====================================
@@ -836,7 +836,7 @@ matchWrapper ctxt scrs (MG { mg_alts = L _ matches'
     non_wc :: Origin -> LMatch GhcTc (LHsExpr GhcTc) -> Bool
     non_wc Generated (L _ (Match _ _ ([L _ (WildPat _)]) _)) = False
     non_wc _ _ = True
-    
+
 matchEquations  :: HsMatchContext GhcRn
                 -> [MatchId] -> [EquationInfo] -> Type
                 -> DsM CoreExpr


=====================================
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
=====================================
@@ -41,7 +41,6 @@ import GHC.Types.Id
 import GHC.Types.Var
 import GHC.Types.Name
 import GHC.Types.Name.Reader
-import GHC.Types.TypeEnv (lookupTypeEnv)
 import GHC.Core.Multiplicity
 import GHC.Tc.Utils.Concrete ( hasFixedRuntimeRep_syntactic )
 import GHC.Tc.Utils.Env
@@ -1623,55 +1622,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 _ 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/4e9c64e654f6542aff51606a13ca866f58410755

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


More information about the ghc-commits mailing list