[commit: ghc] wip/gadtpm: It works (b4bcb69)
git at git.haskell.org
git at git.haskell.org
Mon Jul 6 15:49:44 UTC 2015
Repository : ssh://git@git.haskell.org/ghc
On branch : wip/gadtpm
Link : http://ghc.haskell.org/trac/ghc/changeset/b4bcb697676cef8fb3293147af952740d462579f/ghc
>---------------------------------------------------------------
commit b4bcb697676cef8fb3293147af952740d462579f
Author: George Karachalias <george.karachalias at gmail.com>
Date: Mon Jul 6 16:28:26 2015 +0200
It works
>---------------------------------------------------------------
b4bcb697676cef8fb3293147af952740d462579f
compiler/deSugar/Check.hs | 18 ++++++++--------
compiler/deSugar/Match.hs | 53 ++++++++++++++++++++---------------------------
2 files changed, 32 insertions(+), 39 deletions(-)
diff --git a/compiler/deSugar/Check.hs b/compiler/deSugar/Check.hs
index 2b537e5..3484df7 100644
--- a/compiler/deSugar/Check.hs
+++ b/compiler/deSugar/Check.hs
@@ -8,7 +8,7 @@
{-# LANGUAGE CPP #-}
{-# LANGUAGE DataKinds, GADTs, KindSignatures #-}
-module Check ( toTcTypeBag, pprUncovered, check, checkSingle2, checkMatches2, showMeTheGuards ) where
+module Check ( toTcTypeBag, pprUncovered, check, checkSingle2, checkMatches2, showMeTheGuards, ValAbs, PmConstraint, PmResult2 ) where
#include "HsVersions.h"
@@ -1196,7 +1196,7 @@ pprUncovered vsa = vcat (map pprOne vsa)
instance Outputable PmConstraint where
ppr (TmConstraint x expr) = ppr x <+> equals <+> ppr expr
- ppr (TyConstraint theta) = empty -- pprSet $ map idType theta
+ ppr (TyConstraint theta) = pprSet $ map idType theta
ppr (BtConstraint x) = braces (ppr x <+> ptext (sLit "~") <+> ptext (sLit "_|_"))
instance Outputable (PmPat abs) where
@@ -1454,25 +1454,24 @@ patVectProc2 :: (PatVec, [PatVec]) -> ValSetAbs -> PmM (Bool, Bool, ValSetAbs) -
patVectProc2 (vec,gvs) vsa = do
us <- getUniqueSupplyM
let (c_def, u_def, d_def) = process_guards us gvs -- default (the continuation)
+
(usC, usU, usD) <- getUniqueSupplyM3
mb_c <- anySatValSetAbs (covered2 usC c_def vec vsa)
mb_d <- anySatValSetAbs (divergent2 usD d_def vec vsa)
return (mb_c, mb_d, uncovered2 usU u_def vec vsa)
-- Single pattern binding (let)
-checkSingle2 :: Type -> Pat Id -> DsM (PmResult2 (Pat Id))
+checkSingle2 :: Type -> Pat Id -> DsM (PmResult2 [LPat Id])
checkSingle2 ty p = do
+ let lp = [noLoc p]
vec <- liftUs (translatePat p)
vsa <- initial_uncovered [ty]
(c,d,us) <- patVectProc2 (vec,[]) vsa -- no guards
let us' = valSetAbsToList us
return $ case (c,d) of
- (True, _) -> ([], [], us')
- (False, True) -> ([], [p], us')
- (False, False) -> ([p], [], us')
-
-
--- lmatchToLPats :: LMatch id body -> [LPat id]
+ (True, _) -> ([], [], us')
+ (False, True) -> ([], [lp], us')
+ (False, False) -> ([lp], [], us')
checkMatches2 :: [Type] -> [LMatch Id (LHsExpr Id)] -> DsM (PmResult2 [LPat Id])
checkMatches2 tys matches
@@ -1492,6 +1491,7 @@ checkMatches'2 [] missing = do
checkMatches'2 (m:ms) missing = do
patterns_n_guards <- liftUs (translateMatch m)
+ -- pprInTcRnIf (ptext (sLit "translated") <+> ppr patterns_n_guards)
(c, d, us ) <- patVectProc2 patterns_n_guards missing -- process_vector_alternative patterns_n_guards missing
(rs, is, us') <- checkMatches'2 ms us
return $ case (c,d) of
diff --git a/compiler/deSugar/Match.hs b/compiler/deSugar/Match.hs
index da4f1bd..f7610e8 100644
--- a/compiler/deSugar/Match.hs
+++ b/compiler/deSugar/Match.hs
@@ -694,17 +694,11 @@ matchWrapper ctxt (MG { mg_alts = matches
, mg_arg_tys = arg_tys
, mg_res_ty = rhs_ty
, mg_origin = origin })
- = do { -- showMeTheGuards matches --just to see
- dflags <- getDynFlags
- ; let flag_i = wopt Opt_WarnOverlappingPatterns dflags
- ; let flag_u = wopt Opt_WarnIncompletePatterns dflags
- || wopt Opt_WarnIncompleteUniPatterns dflags
- || wopt Opt_WarnIncompletePatternsRecUpd dflags
- ; when (flag_i || flag_u) $ do
- {- Checking -} (rs, is, us) <- checkMatches2 arg_tys matches
- {- Checking -} pprInTcRnIf (ptext (sLit "rs:") <+> ppr rs)
- {- Checking -} pprInTcRnIf (ptext (sLit "is:") <+> ppr is)
- {- Checking -} pprInTcRnIf (pprUncovered us)
+ = do { dflags <- getDynFlags
+ ; locn <- getSrcSpanDs
+
+ -- ; pmresult <- checkMatches2 arg_tys matches
+ ; dsPmWarn2 dflags (DsMatchContext ctxt locn) (checkMatches2 arg_tys matches) -- pmresult
; eqns_info <- mapM mk_eqn_info matches
; new_vars <- case matches of
@@ -771,20 +765,13 @@ matchSinglePat :: CoreExpr -> HsMatchContext Name -> LPat Id
-- Used for things like [ e | pat <- stuff ], where
-- incomplete patterns are just fine
matchSinglePat (Var var) ctx (L _ pat) ty match_result
- = do {
- dflags <- getDynFlags
- ; let flag_i = wopt Opt_WarnOverlappingPatterns dflags
- ; let flag_u = wopt Opt_WarnIncompletePatterns dflags
- || wopt Opt_WarnIncompleteUniPatterns dflags
- || wopt Opt_WarnIncompletePatternsRecUpd dflags
- ; when (flag_i || flag_u) $ do
- {- Checking -} (rs,is,us) <- checkSingle2 ty pat
- {- Checking -} pprInTcRnIf (ptext (sLit "rs:") <+> ppr rs)
- {- Checking -} pprInTcRnIf (ptext (sLit "is:") <+> ppr is)
- {- Checking -} pprInTcRnIf (pprUncovered us)
-
-
- ; locn <- getSrcSpanDs
+ = do { dflags <- getDynFlags
+ ; locn <- getSrcSpanDs
+
+ -- Maybe I should remove this
+ -- ; (rs, is, us) <- checkSingle2 (idType var) pat
+ ; dsPmWarn2 dflags (DsMatchContext ctx locn) (checkSingle2 (idType var) pat) -- (map ((:[]) . noLoc) rs, map ((:[]) . noLoc) is, us)
+
; matchCheck (DsMatchContext ctx locn)
[var] ty
[EqnInfo { eqn_pats = [pat], eqn_rhs = match_result }] }
@@ -1022,10 +1009,16 @@ Hence we don't regard 1 and 2, or (n+1) and (n+2), as part of the same group.
%************************************************************************
-}
-dsPmWarn :: DynFlags -> DsMatchContext -> [Type] -> [EquationInfo] -> DsM ()
-dsPmWarn dflags ctx@(DsMatchContext kind loc) tys qs
+-- DsM (PmResult2 [LPat Id])
+-- type PmResult2 a = ([a], [a], [([ValAbs],[PmConstraint])])
+-- ([LPat Id], [LPat Id], [([ValAbs],[PmConstraint])]) -- redundant, inaccessible, missing
+
+
+dsPmWarn2 :: DynFlags -> DsMatchContext -> DsM (PmResult2 [LPat Id]) -> DsM ()
+-- ([[LPat Id]], [[LPat Id]], [([ValAbs],[PmConstraint])]) -> DsM ()
+dsPmWarn2 dflags ctx@(DsMatchContext kind loc) mPmResult -- (redundant, inaccessible, uncovered)
= when (flag_i || flag_u) $ do
- (redundant, inaccessible, uncovered) <- check tys qs
+ (redundant, inaccessible, uncovered) <- mPmResult
let exists_r = flag_i && notNull redundant
exists_i = flag_i && notNull inaccessible
exists_u = flag_u && notNull uncovered
@@ -1079,8 +1072,8 @@ ppr_shadow_pats :: HsMatchContext Name -> [Pat Id] -> SDoc
ppr_shadow_pats kind pats
= sep [ppr_pats pats, matchSeparator kind, ptext (sLit "...")]
-ppr_eqn :: (SDoc -> SDoc) -> HsMatchContext Name -> EquationInfo -> SDoc
-ppr_eqn prefixF kind eqn = prefixF (ppr_shadow_pats kind (eqn_pats eqn))
+ppr_eqn :: (SDoc -> SDoc) -> HsMatchContext Name -> [LPat Id] -> SDoc
+ppr_eqn prefixF kind eqn = prefixF (ppr_shadow_pats kind (map unLoc eqn))
-- This variable shows the maximum number of lines of output generated for warnings.
-- It will limit the number of patterns/equations displayed to maximum_output.
More information about the ghc-commits
mailing list