[commit: ghc] wip/gadtpm: Propagate (some) term constraints in nested matches (814f007)

[git at git.haskell.org]

Repository : ssh://git@git.haskell.org/ghc

On branch  : wip/gadtpm
Link       : http://ghc.haskell.org/trac/ghc/changeset/814f0072ad4f1c515dc1518a271f12a47b8c33ae/ghc

>---------------------------------------------------------------

commit 814f0072ad4f1c515dc1518a271f12a47b8c33ae
Author: George Karachalias <george.karachalias at gmail.com>
Date:   Tue Sep 15 16:43:05 2015 +0200

    Propagate (some) term constraints in nested matches


>---------------------------------------------------------------

814f0072ad4f1c515dc1518a271f12a47b8c33ae
 compiler/deSugar/Check.hs | 31 ++++++++++++++++---------------
 compiler/deSugar/Match.hs | 27 +++++++++++++++------------
 2 files changed, 31 insertions(+), 27 deletions(-)

diff --git a/compiler/deSugar/Check.hs b/compiler/deSugar/Check.hs
index 02f0c0d..95d2ded 100644
--- a/compiler/deSugar/Check.hs
+++ b/compiler/deSugar/Check.hs
@@ -7,7 +7,7 @@
 
 {-# LANGUAGE CPP #-}
 
-module Check ( toTcTypeBag, pprUncovered, checkSingle, checkMatches, PmResult, hsCaseTmCt ) where
+module Check ( toTcTypeBag, pprUncovered, checkSingle, checkMatches, PmResult, hsCaseTmCt, hsCaseTmCtOne ) where
 
 #include "HsVersions.h"
 
@@ -117,11 +117,11 @@ type PmResult = ( [[LPat Id]] -- redundant clauses
 -}
 
 -- Check a single pattern binding (let)
-checkSingle :: Type -> Pat Id -> DsM PmResult
-checkSingle ty p = do
+checkSingle :: Id -> Pat Id -> DsM PmResult
+checkSingle var p = do
   let lp = [noLoc p]
   vec <- liftUs (translatePat p)
-  vsa <- initial_uncovered [ty]
+  vsa <- initial_uncovered [var]
   (c,d,us') <- patVectProc (vec,[]) vsa -- no guards
   us <- pruneValSetAbs us'
   return $ case (c,d) of
@@ -130,11 +130,11 @@ checkSingle ty p = do
     (False, False) -> ([lp], [],   us)
 
 -- Check a matchgroup (case, etc)
-checkMatches :: [Type] -> [LMatch Id (LHsExpr Id)] -> DsM PmResult
-checkMatches tys matches
+checkMatches :: [Id] -> [LMatch Id (LHsExpr Id)] -> DsM PmResult
+checkMatches vars matches
   | null matches = return ([],[],[])
   | otherwise    = do
-      missing    <- initial_uncovered tys
+      missing    <- initial_uncovered vars
       (rs,is,us) <- go matches missing
       return (map hsLMatchPats rs, map hsLMatchPats is, us)
   where
@@ -151,14 +151,12 @@ checkMatches tys matches
         (False, True)  -> (  rs, m:is, us')
         (False, False) -> (m:rs,   is, us')
 
--- You should extend this to algo get term-leven constraints from
--- case expressions.
-initial_uncovered :: [Type] -> DsM ValSetAbs
-initial_uncovered tys = do
+initial_uncovered :: [Id] -> DsM ValSetAbs
+initial_uncovered vars = do
   us <- getUniqueSupplyM
   ty_cs <- TyConstraint . bagToList <$> getDictsDs
   tm_cs <- map (uncurry TmConstraint) . bagToList <$> getTmCsDs
-  let vsa = zipWith mkValAbsVar (listSplitUniqSupply us) tys
+  let vsa = map (VA . PmVar) vars -- zipWith mkValAbsVar (listSplitUniqSupply us) tys
   return $ mkConstraint (ty_cs:tm_cs) (foldr Cons Singleton vsa)
 
 {-
@@ -1080,14 +1078,17 @@ pprOne (vs,(complex, subst)) =
 
 hsCaseTmCt :: Maybe (LHsExpr Id) -- scrutinee
            -> [Pat Id]           -- match (should have length 1)
-           -> [Type]             -- types of patterns (should have length 1)
+           -> [Id]               -- types of patterns (should have length 1)
            -> DsM (Bag SimpleEq)
 hsCaseTmCt Nothing _ _ = return emptyBag
-hsCaseTmCt (Just scr) [p] [ty] = liftUs $ do
+hsCaseTmCt (Just scr) [p] [var] = liftUs $ do
   [e] <- map valAbsToPmExpr . coercePmPats <$> translatePat p
   let scr_e = lhsExprToPmExpr scr
-  var <- mkPmIdSM ty
   return $ listToBag [(var, e), (var, scr_e)]
 hsCaseTmCt _ _ _ = panic "hsCaseTmCt: HsCase"
 
+hsCaseTmCtOne :: Maybe (LHsExpr Id) -> [Id] -> Bag SimpleEq
+hsCaseTmCtOne Nothing     _    = emptyBag
+hsCaseTmCtOne (Just scr) [var] = unitBag (var, lhsExprToPmExpr scr)
+hsCaseTmCtOne _ _              = panic "hsCaseTmCtOne: HsCase"
 
diff --git a/compiler/deSugar/Match.hs b/compiler/deSugar/Match.hs
index 5303872..f38531c 100644
--- a/compiler/deSugar/Match.hs
+++ b/compiler/deSugar/Match.hs
@@ -696,26 +696,29 @@ matchWrapper ctxt mb_scr (MG { mg_alts = matches
   = do  { dflags <- getDynFlags
         ; locn   <- getSrcSpanDs
 
-        -- pattern match check warnings
-        ; unless (isGenerated origin) $
-            dsPmWarn dflags (DsMatchContext ctxt locn) (checkMatches arg_tys matches)
-
-        ; eqns_info   <- mapM mk_eqn_info matches
         ; new_vars    <- case matches of
                            []    -> mapM newSysLocalDs arg_tys
                            (m:_) -> selectMatchVars (map unLoc (hsLMatchPats m))
+
+        ; eqns_info   <- mapM (mk_eqn_info new_vars) matches
+
+        -- pattern match check warnings
+        ; let tm_cs = hsCaseTmCtOne mb_scr new_vars
+        ; unless (isGenerated origin) $
+            dsPmWarn dflags (DsMatchContext ctxt locn) (addTmCsDs tm_cs $ checkMatches new_vars matches)
+
         ; result_expr <- handleWarnings $
                          matchEquations ctxt new_vars eqns_info rhs_ty
         ; return (new_vars, result_expr) }
   where
-    mk_eqn_info (L _ (Match pats _ grhss))
+    mk_eqn_info vars (L _ (Match pats _ grhss))
       = do { let upats  = map unLoc pats
-                 dicts  = toTcTypeBag (collectEvVarsPats upats) -- check rhs with constraints from match in scope -- Only TcTyVars
+                 dicts  = toTcTypeBag (collectEvVarsPats upats) -- Only TcTyVars
 
-           ; tm_cs <- hsCaseTmCt mb_scr upats arg_tys
-           ; match_result <- addDictsDs dicts $
-                               addTmCsDs tm_cs $
-                                 dsGRHSs ctxt upats grhss rhs_ty
+           ; tm_cs <- hsCaseTmCt mb_scr upats vars -- arg_tys
+           ; match_result <- addDictsDs dicts $  -- pass type constraints inwards
+                               addTmCsDs tm_cs $ -- pass term constraints inwards
+                                 dsGRHSs ctxt upats grhss rhs_ty -- THEY SHOULD BE PASSED HERE TOO BECAUSE IT IS GONNA GENERATE AGAIN
            ; return (EqnInfo { eqn_pats = upats, eqn_rhs  = match_result}) }
 
     -- not sure if it is needed anymore (does `matchEquations' generate any other warning?)
@@ -774,7 +777,7 @@ matchSinglePat (Var var) ctx (L _ pat) ty match_result
        ; locn   <- getSrcSpanDs
 
        -- pattern match check warnings
-       ; dsPmWarn dflags (DsMatchContext ctx locn) (checkSingle (idType var) pat)
+       ; dsPmWarn dflags (DsMatchContext ctx locn) (checkSingle var pat)
 
        ; matchCheck (DsMatchContext ctx locn)
                     [var] ty