[Git][ghc/ghc][wip/or-pats] 2 commits: Update submodule

[David (@knothed)]

David pushed to branch wip/or-pats at Glasgow Haskell Compiler / GHC


Commits:
c6c565a2 by David Knothe at 2022-12-08T10:54:58+01:00
Update submodule

- - - - -
8b306b81 by David Knothe at 2022-12-12T12:20:06+01:00
Check for variable/dictionary binders after zonking

- - - - -


7 changed files:

- compiler/GHC/Hs/Utils.hs
- compiler/GHC/Rename/Pat.hs
- compiler/GHC/Tc/Errors/Ppr.hs
- compiler/GHC/Tc/Errors/Types.hs
- compiler/GHC/Tc/Gen/Pat.hs
- compiler/GHC/Tc/Utils/Zonk.hs
- utils/haddock


Changes:

=====================================
compiler/GHC/Hs/Utils.hs
=====================================
@@ -1159,7 +1159,7 @@ collect_pat flag pat bndrs = case pat of
   ParPat _ _ pat _      -> collect_lpat flag pat bndrs
   ListPat _ pats        -> foldr (collect_lpat flag) bndrs pats
   TuplePat _ pats _     -> foldr (collect_lpat flag) bndrs pats
-  OrPat _ _             -> [] -- or-patterns can't bind any variables and we don't want to have "conflicting defintions" errors
+  OrPat _ pats          -> [] -- Don't collect binders recursively as we only want to get an error in the most specific or-pattern
   SumPat _ pat _ _      -> collect_lpat flag pat bndrs
   LitPat _ _            -> bndrs
   NPat {}               -> bndrs


=====================================
compiler/GHC/Rename/Pat.hs
=====================================
@@ -609,14 +609,7 @@ rnPatAndThen mk (TuplePat _ pats boxed)
 
 rnPatAndThen mk (OrPat _ pats)
   = do { pats' <- rnLPatsAndThen mk (NE.toList pats)
-       ; mapM_ checkNoVarsBound pats'
        ; return (OrPat noExtField (NE.fromList pats')) }
-       where
-        checkNoVarsBound :: LPat GhcRn -> CpsRn ()
-        checkNoVarsBound pat = do
-          let bnds = collectPatsBinders CollNoDictBinders [pat]
-          unless (null bnds) $
-            liftCps $ addErrAt (locA $ getLoc pat) (TcRnOrPatBindsVariables pat)
 
 rnPatAndThen mk (SumPat _ pat alt arity)
   = do { pat <- rnLPatAndThen mk pat


=====================================
compiler/GHC/Tc/Errors/Ppr.hs
=====================================
@@ -1153,8 +1153,9 @@ instance Diagnostic TcRnMessage where
                            False -> text (TH.pprint item))
     TcRnReportCustomQuasiError _ msg -> mkSimpleDecorated $ text msg
     TcRnInterfaceLookupError _ sdoc -> mkSimpleDecorated sdoc
-    TcRnOrPatBindsVariables pat
-      -> mkSimpleDecorated $ vcat [text "Or-pattern may not bind variables:" <+> ppr (unLoc pat)]
+    TcRnOrPatBindsVariables pat vars -> case vars of
+      True -> mkSimpleDecorated $ text "Or-pattern may not bind variables:" <+> ppr pat
+      False -> mkSimpleDecorated $ text "Or-pattern may not bind (type) variable, dictionary or equality constraints:" <+> ppr pat
     TcRnUnsatisfiedMinimalDef mindef
       -> mkSimpleDecorated $
         vcat [text "No explicit implementation for"


=====================================
compiler/GHC/Tc/Errors/Types.hs
=====================================
@@ -2549,12 +2549,15 @@ data TcRnMessage where
   TcRnInterfaceLookupError :: !Name -> !SDoc -> TcRnMessage
 
   {-| TcRnOrPatBindsVariables is an error that happens when an
-     or-pattern binds variables, e.g. (one of A, B x).
+     or-pattern binds variables or has dictionary or evidence biders, e.g. (one of A, B x).
 
      Test case:
        none yet (TODO)
   -}
-  TcRnOrPatBindsVariables :: LPat GhcRn -> TcRnMessage
+  TcRnOrPatBindsVariables
+    :: Pat GhcTc -- the or-pattern
+    -> Bool -- True => pattern contains just variables; False => pattern contains other dictionary/evidence binders
+    -> TcRnMessage
 
   {- | TcRnUnsatisfiedMinimalDef is a warning that occurs when a class instance
        is missing methods that are required by the minimal definition.


=====================================
compiler/GHC/Tc/Gen/Pat.hs
=====================================
@@ -382,12 +382,10 @@ tc_pat pat_ty penv ps_pat thing_inside = case ps_pat of
         { (pat', res) <- tc_lpat pat_ty penv pat thing_inside
         ; return (BangPat x pat', res) }
 
-  -- TODO: reject more programs
-  OrPat _ (NE.toList -> pats) -> do {
-    (pats', res) <- tc_lpats (map (const pat_ty) pats) penv pats thing_inside;
-    pat_ty <- expTypeToType (scaledThing pat_ty);
-    return (OrPat pat_ty (NE.fromList pats'), res)
-  }
+  OrPat _ (NE.toList -> pats) -> do -- or-patterns with variables are rejected later, after zonking
+    { (pats', res) <- tc_lpats (map (const pat_ty) pats) penv pats thing_inside
+    ; pat_ty <- expTypeToType (scaledThing pat_ty)
+    ; return (OrPat pat_ty (NE.fromList pats'), res) }
 
   LazyPat x pat -> do
         { mult_wrap <- checkManyPattern pat_ty


=====================================
compiler/GHC/Tc/Utils/Zonk.hs
=====================================
@@ -56,6 +56,7 @@ import GHC.Tc.Utils.TcType
 import GHC.Tc.Utils.TcMType
 import GHC.Tc.Utils.Env   ( tcLookupGlobalOnly )
 import GHC.Tc.Types.Evidence
+import GHC.Tc.Errors.Types
 
 import GHC.Core.TyCo.Ppr     ( pprTyVar )
 import GHC.Core.TyCon
@@ -1339,10 +1340,17 @@ zonk_pat env (TuplePat tys pats boxed)
         ; (env', pats') <- zonkPats env pats
         ; return (env', TuplePat tys' pats' boxed) }
 
-zonk_pat env (OrPat ty pats)
+zonk_pat env p@(OrPat ty pats)
   = do  { ty' <- zonkTcTypeToTypeX env ty
         ; (env', pats') <- zonkPats env (NE.toList pats)
+        ; checkNoVarsBound pats' p
         ; return (env', OrPat ty' (NE.fromList pats')) }
+    where
+      checkNoVarsBound :: [LPat GhcTc] -> Pat GhcTc -> TcRn ()
+      checkNoVarsBound pats orpat = do
+        let bnds = collectPatsBinders CollWithDictBinders pats
+        let varBnds = collectPatsBinders CollNoDictBinders pats
+        unless (null bnds) $ addErr (TcRnOrPatBindsVariables orpat (varBnds `equalLength` bnds))
 
 zonk_pat env (SumPat tys pat alt arity )
   = do  { tys' <- mapM (zonkTcTypeToTypeX env) tys


=====================================
utils/haddock
=====================================
@@ -1 +1 @@
-Subproject commit 2ffde83344bab8ed0aee3e8ef46f43856c7ca6ef
+Subproject commit f6bb16e7ea03a20d0b929fffc58031ef42526405



View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/d3b2d20835c7b9c3bed896e1472d67913640b42e...8b306b81a1f3db1f660dc88b34f2e1c1260ce81e

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/d3b2d20835c7b9c3bed896e1472d67913640b42e...8b306b81a1f3db1f660dc88b34f2e1c1260ce81e
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/20221212/7346c732/attachment-0001.html>