[Git][ghc/ghc][wip/expand-do] a new check for irrefutable pattern

Apoorv Ingle (@ani) gitlab at gitlab.haskell.org
Mon May 1 19:41:32 UTC 2023



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


Commits:
f477fa38 by Apoorv Ingle at 2023-05-01T14:41:20-05:00
a new check for irrefutable pattern

- - - - -


7 changed files:

- compiler/GHC/Hs/Expr.hs
- compiler/GHC/Hs/Pat.hs
- compiler/GHC/HsToCore/Expr.hs
- compiler/GHC/Tc/Gen/Match.hs
- compiler/GHC/Tc/Gen/Pat.hs
- compiler/Language/Haskell/Syntax/Expr.hs
- testsuite/tests/rebindable/T18324b.hs


Changes:

=====================================
compiler/GHC/Hs/Expr.hs
=====================================
@@ -729,8 +729,8 @@ ppr_expr (XExpr x) = case ghcPass @p of
 ppr_expr (PopSrcSpan x) = case ghcPass @p of
   GhcPs -> panic "ppr_expr Ps HsPopSrcSpan"
   GhcRn -> ppr x
-  GhcTc -> panic "ppr_expr Tc HsPopSrcSpan" 
-  
+  GhcTc -> panic "ppr_expr Tc HsPopSrcSpan"
+
 
 instance Outputable XXExprGhcTc where
   ppr (WrapExpr (HsWrap co_fn e))
@@ -1114,9 +1114,9 @@ data HsExpansion orig expanded
 -- | Just print the original expression (the @a@) with the expanded version (the @b@)
 instance (Outputable a, Outputable b) => Outputable (HsExpansion a b) where
   ppr (HsExpanded orig expanded)
-    = ifPprDebug (vcat [ppr orig, braces (text "Expansion:" <+> ppr expanded)])
-               (ppr orig)
-    -- = braces (ppr orig) $$ braces (text "Expansion:" <+> ppr expanded)
+    -- = ifPprDebug (vcat [ppr orig, braces (text "Expansion:" <+> ppr expanded)])
+    --            (ppr orig)
+    = braces (ppr orig) $$ braces (text "Expansion:" <+> ppr expanded)
 
 
 {-


=====================================
compiler/GHC/Hs/Pat.hs
=====================================
@@ -502,6 +502,7 @@ looksLazyPat (VarPat {})   = False
 looksLazyPat (WildPat {})  = False
 looksLazyPat _             = True
 
+
 isIrrefutableHsPat :: forall p. (OutputableBndrId p)
                    => DynFlags -> LPat (GhcPass p) -> Bool
 -- (isIrrefutableHsPat p) is true if matching against p cannot fail,


=====================================
compiler/GHC/HsToCore/Expr.hs
=====================================
@@ -858,14 +858,15 @@ warnDiscardedDoBindings rhs rhs_ty
 
 warnUnusedBindValue :: LHsExpr GhcTc -> LHsExpr GhcTc -> Type -> DsM ()
 warnUnusedBindValue fun arg arg_ty
-  | Just (SrcSpanAnn _ l, f) <- fish_var fun
+  | Just (SrcSpanAnn _ l, (L (SrcSpanAnn _ loc) f)) <- fish_var fun
   , is_gen_then f
   -- , isNoSrcSpan l
   = do tracePm "warnUnusedBindValue" (vcat [ text "fun" <+> ppr fun
                                            , text "arg" <+> ppr arg
                                            , text "arg_ty" <+> ppr arg_ty
                                            , text "f" <+> ppr f <+> ppr (is_gen_then f)
-                                           , text "l" <+> ppr (isNoSrcSpan l)])
+                                           , text "l" <+> ppr (isNoSrcSpan l) <+> ppr (isNoSrcSpan loc)
+                                           ])
        warnDiscardedDoBindings arg arg_ty
   where
     -- retrieve the location info and the head of the application
@@ -879,8 +880,8 @@ warnUnusedBindValue fun arg arg_ty
     fish_var _ = Nothing
 
     -- is this id a compiler generated (>>) with expanded do
-    is_gen_then :: LIdP GhcTc -> Bool
-    is_gen_then (L _ f) = f `hasKey` thenMClassOpKey
+    is_gen_then :: Id -> Bool
+    is_gen_then f = f `hasKey` thenMClassOpKey
 
 warnUnusedBindValue _ _ _  = return ()
 


=====================================
compiler/GHC/Tc/Gen/Match.hs
=====================================
@@ -59,7 +59,6 @@ import GHC.Tc.Types.Evidence
 
 import GHC.Core.Multiplicity
 import GHC.Core.UsageEnv
-import GHC.Core.ConLike
 import GHC.Core.TyCon
 -- Create chunkified tuple types for monad comprehensions
 import GHC.Core.Make
@@ -81,6 +80,7 @@ import GHC.Types.Name
 import GHC.Types.Id
 import GHC.Types.SrcLoc
 import GHC.Types.Basic (Origin (..))
+import qualified GHC.LanguageExtensions as LangExt
 
 import Control.Monad
 import Control.Arrow ( second )
@@ -1237,8 +1237,8 @@ expand_do_stmts do_or_lc ((L _ (BindStmt xbsrn pat e)): lstmts)
   , fail_op              <- xbsrn_failOp xbsrn =
 -- the pattern binding x can fail
 -- instead of making an internal name, the fail block is just an anonymous match block
---      stmts ~~> stmt'    let /  = stmts';
---                             _ = fail "..";
+--      stmts ~~> stmt'    let / pat = stmts';
+--                               _   = fail "Pattern match failure .."
 --    -------------------------------------------------------
 --       pat <- e ; stmts   ~~> (>>=) e f
       do expand_stmts <- expand_do_stmts do_or_lc lstmts
@@ -1381,19 +1381,19 @@ mk_failable_lexpr_tcm :: LPat GhcRn -> LHsExpr GhcRn -> FailOperator GhcRn -> Tc
 -- generate a fail block even if it is not really needed. This would fail typechecking as
 -- a monad fail instance for such datatypes maynot be defined. cf. GHC.Hs.isIrrefutableHsPat
 mk_failable_lexpr_tcm pat lexpr fail_op =
-  do { ((tc_pat, _), _) <- tcInferPat (FRRBindStmt DoNotation)
-                           PatBindRhs pat $ return id -- whatever
-     ; dflags <- getDynFlags
-     ; traceTc "mk_fail_lexpr_tcm" (vcat [ppr tc_pat
-                                         , ppr $ isIrrefutableHsPat dflags tc_pat
-                                         , ppr $ isPatSynCon (unLoc tc_pat)])
-     ; if isIrrefutableHsPat dflags tc_pat -- don't decorate with fail statement if the pattern is irrefutable
-          || (isPatSynCon (unLoc tc_pat))  -- pattern syns always get a fail block while desugaring so skip
+  do { tc_env <- getGblEnv
+     ; is_strict <- xoptM LangExt.Strict
+     ; traceTc "mk_fail_lexpr_tcm" (vcat [ppr pat
+                                         , ppr $ isIrrefutableHsPatRn tc_env is_strict pat
+                                         ])
+
+     ; if isIrrefutableHsPatRn tc_env is_strict pat
+          -- don't decorate with fail statement if the pattern is irrefutable
+          -- pattern syns always get a fail block while desugaring so skip
        then return $ mkHsLam [pat] (noLocA (PopSrcSpan lexpr))
        else mk_fail_lexpr pat lexpr fail_op
      }
-  where isPatSynCon (ConPat {pat_con = L _ (PatSynCon _)}) = True
-        isPatSynCon _ = False
+  where
 
 -- makes the fail block
 -- TODO: check the discussion around MonadFail.fail type signature.
@@ -1401,9 +1401,9 @@ mk_failable_lexpr_tcm pat lexpr fail_op =
 mk_fail_lexpr :: LPat GhcRn -> LHsExpr GhcRn -> FailOperator GhcRn -> TcM (LHsExpr GhcRn)
 mk_fail_lexpr pat lexpr (Just (SyntaxExprRn fail_op)) =
   do  dflags <- getDynFlags
-      return $ noLocA (HsLam noExtField $ mkMatchGroup Generated   -- \
+      return $ noLocA (HsLam noExtField $ mkMatchGroup Generated            -- \
                       (noLocA [ mkHsCaseAlt pat (noLocA $ PopSrcSpan lexpr) --   pat -> expr
-                              , mkHsCaseAlt nlWildPatName          --   _   -> fail "fail pattern"
+                              , mkHsCaseAlt nlWildPatName                   --   _   -> fail "fail pattern"
                                 (noLocA $ genHsApp fail_op
                                  (mk_fail_msg_expr dflags (DoExpr Nothing) pat))
                               ]))
@@ -1415,3 +1415,10 @@ mk_fail_lexpr pat lexpr (Just (SyntaxExprRn fail_op)) =
                    <+> text "at" <+> ppr (getLocA pat)
 
 mk_fail_lexpr _ _ _ = pprPanic "mk_fail_lexpr: impossible happened" empty
+
+{- Note [Desugaring Do with HsExpansion]
+ ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+We expand do blocks before typeching it rather than after type checking it
+TODO expand using examples
+
+-}


=====================================
compiler/GHC/Tc/Gen/Pat.hs
=====================================
@@ -20,6 +20,7 @@ module GHC.Tc.Gen.Pat
    , tcCheckPat, tcCheckPat_O, tcInferPat
    , tcPats
    , addDataConStupidTheta
+   , isIrrefutableHsPatRn
    )
 where
 
@@ -40,6 +41,7 @@ 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
@@ -77,6 +79,7 @@ import GHC.Data.List.SetOps ( getNth )
 import Language.Haskell.Syntax.Basic (FieldLabelString(..))
 
 import Data.List( partition )
+import Data.Maybe (isJust)
 
 {-
 ************************************************************************
@@ -1619,3 +1622,45 @@ checkGADT conlike ex_tvs arg_tys = \case
   where
     has_existentials :: Bool
     has_existentials = any (`elemVarSet` tyCoVarsOfTypes arg_tys) ex_tvs
+
+
+isIrrefutableHsPatRn :: TcGblEnv -> Bool -> LPat GhcRn -> Bool
+isIrrefutableHsPatRn tc_env@(TcGblEnv{tcg_type_env = type_env}) is_strict pat = goL pat
+  where
+    goL :: LPat GhcRn -> Bool
+    goL = go . unLoc
+
+    go :: Pat GhcRn -> Bool
+    go (WildPat {})        = True
+    go (VarPat {})         = True
+    go (LazyPat _ p')
+      | is_strict
+      = isIrrefutableHsPatRn tc_env False p'
+      | otherwise          = 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
+                    -- See Note [Unboxed sum patterns aren't irrefutable]
+    go (ListPat {})        = False
+
+    go (ConPat
+        { pat_con  = L _ dcName
+        , pat_args = details }) = case lookupTypeEnv type_env dcName of
+                                    Just (ATyCon con) ->
+                                      isJust (tyConSingleDataCon_maybe con)
+                                      && all goL (hsConPatArgs details)
+                                    _ -> False -- conservative.
+    go (LitPat {})         = False
+    go (NPat {})           = False
+    go (NPlusKPat {})      = False
+
+    -- We conservatively assume that no TH splices are irrefutable
+    -- since we cannot know until the splice is evaluated.
+    go (SplicePat {})      = False
+
+    go (XPat ext)          = case ext of
+                               HsPatExpanded _ pat -> go pat


=====================================
compiler/Language/Haskell/Syntax/Expr.hs
=====================================
@@ -587,7 +587,7 @@ data HsExpr p
   | PopSrcSpan (LHsExpr p)
   -- Placeholder for identifying generated source locations in GhcRn phase
   -- Should not presist post typechecking
-  -- Note [Desugaring Do with HsExpansion] TODO
+  -- Note [Desugaring Do with HsExpansion] in GHC.Tc.Gen.Match
 
 -- ---------------------------------------------------------------------
 


=====================================
testsuite/tests/rebindable/T18324b.hs
=====================================
@@ -14,7 +14,7 @@ unLoc (L _ e)  = e
 
 data B = B
 
-type family Anno a = b 
+type family Anno a = b
 
 type family XRec p a = r | r -> a
 type instance XRec (GhcPass p) a = L (Anno a) a
@@ -33,17 +33,14 @@ type GhcRn = GhcPass 'Rn
 data ClsInstDecl pass =
   ClsInstDecl { cid_datafam_insts :: LDataFamInstDecl pass }
 
-
--- type LTyFamInstDecl pass = XRec pass (TyFamInstDecl pass)
 type LDataFamInstDecl pass = XRec pass ([FamEqn pass (HsDataDefn pass)])
--- type TyFamDefltDecl = TyFamInstDecl
 
 type family IdP p
 type instance IdP (GhcPass p) = IdGhcP p
 
 type LIdP p = XRec p (IdP p)
 
-data HsDataDefn pass 
+data HsDataDefn pass
 
 data FamEqn pass rhs
   = FamEqn
@@ -54,7 +51,9 @@ fffggg :: ClsInstDecl GhcRn -> [Int]
 fffggg ddd = -- let
       do
         FamEqn { feqn_tycon = L _ _
-               , feqn_rhs   = _ } {-:: FamEqn GhcRn (HsDataDefn GhcRn)-} <- unLoc $ cid_datafam_insts ddd
-        [ 0 ]
-
-
+               , feqn_rhs   = defns } :: FamEqn GhcRn (HsDataDefn GhcRn) <- unLoc $ cid_datafam_insts ddd
+        [ 0 ] ++ dataSubs defns
+  where
+    dataSubs :: HsDataDefn GhcRn
+             -> [Int]
+    dataSubs = undefined



View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/f477fa38f40b35768110a7005578773ac8db7c17

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


More information about the ghc-commits mailing list