[commit: ghc] wip/T8584: #WIP #STASH (f216eec)

[git at git.haskell.org]

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

On branch  : wip/T8584
Link       : http://ghc.haskell.org/trac/ghc/changeset/f216eec563974cd6019b46a5c2c80391fc4d0a8b/ghc

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

commit f216eec563974cd6019b46a5c2c80391fc4d0a8b
Author: Dr. ERDI Gergo <gergo at erdi.hu>
Date:   Sun Nov 2 14:37:43 2014 +0800

    #WIP #STASH


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

f216eec563974cd6019b46a5c2c80391fc4d0a8b
 compiler/typecheck/TcPatSyn.lhs                  | 28 ++++++++++++++----------
 testsuite/tests/patsyn/should_compile/T8584-1.hs | 10 +++++++++
 testsuite/tests/patsyn/should_compile/all.T      |  1 +
 3 files changed, 27 insertions(+), 12 deletions(-)

diff --git a/compiler/typecheck/TcPatSyn.lhs b/compiler/typecheck/TcPatSyn.lhs
index c0ef09b..9ca3e0f 100644
--- a/compiler/typecheck/TcPatSyn.lhs
+++ b/compiler/typecheck/TcPatSyn.lhs
@@ -74,9 +74,10 @@ tcInferPatSynDecl PSB{ psb_id = lname@(L _ name), psb_args = details,
        ; req_theta  <- zonkTcThetaType req_theta
        ; pat_ty     <- zonkTcType pat_ty
        ; args       <- mapM zonkId args
+       ; let arg_w_wraps = zip args $ repeat idHsWrapper
 
        ; let theta = prov_theta ++ req_theta
-       ; (matcher_id, matcher_bind) <- tcPatSynMatcher lname lpat' args idHsWrapper
+       ; (matcher_id, matcher_bind) <- tcPatSynMatcher lname lpat' arg_w_wraps
                                          univ_tvs ex_tvs
                                          ev_binds
                                          prov_dicts req_dicts
@@ -111,7 +112,7 @@ tcCheckPatSynDecl PSB{ psb_id = lname@(L loc name), psb_args = details,
          ppr (univ_tvs, req_theta) $$
          ppr tau
 
-       -- ; prov_dicts <- newEvVars prov_theta
+       ; _prov_dicts <- newEvVars prov_theta
        ; req_dicts <- newEvVars req_theta
 
        ; let skol_info = SigSkol (FunSigCtxt name) (mkFunTys arg_tys pat_ty)
@@ -136,8 +137,11 @@ tcCheckPatSynDecl PSB{ psb_id = lname@(L loc name), psb_args = details,
        ; let ex_tvs'     = varSetElems ex_vars'
              prov_theta' = map evVarPred prov_dicts'
 
+       ; traceTc "prov_theta" $ ppr prov_theta
+       ; traceTc "prov_theta'" $ ppr prov_theta'
+       ; traceTc "prov_dicts'" $ ppr prov_dicts'
 
-       ; checkConstraints skol_info ex_tvs' prov_dicts' $ do
+       ; (ev_binds', _) <- checkConstraints skol_info ex_tvs' prov_dicts' $ do
            ctLoc <- getCtLoc PatSigOrigin
            forM_ prov_theta $ \pred -> do
                let ctEv = CtWanted{ ctev_pred = pred
@@ -145,16 +149,15 @@ tcCheckPatSynDecl PSB{ psb_id = lname@(L loc name), psb_args = details,
                                   , ctev_loc = ctLoc
                                   }
                emitFlat $ mkNonCanonical ctEv
-       ; let (args', _wraps) = unzip arg_w_wraps
-             -- wrap = foldr (<.>) idHsWrapper wraps
-             wrap = idHsWrapper
        ; ex_tvs' <- mapM zonkQuantifiedTyVar ex_tvs'
-       ; args' <- mapM zonkId args'
+       ; arg_w_wraps <- forM arg_w_wraps $ \(arg', wrap) -> do
+           arg' <- zonkId arg'
+           return (arg', wrap)
 
        ; (matcher_id, matcher_bind) <- tcPatSynMatcher lname lpat'
-                                         args' wrap
+                                         arg_w_wraps
                                          univ_tvs ex_tvs'
-                                         ev_binds
+                                         ev_binds'
                                          prov_dicts' req_dicts
                                          prov_theta' req_theta
                                          pat_ty
@@ -180,7 +183,7 @@ tcCheckPatSynDecl PSB{ psb_id = lname@(L loc name), psb_args = details,
 \begin{code}
 tcPatSynMatcher :: Located Name
                 -> LPat Id
-                -> [Var] -> HsWrapper
+                -> [(Var, HsWrapper)]
                 -> [TcTyVar] -> [TcTyVar]
                 -> TcEvBinds
                 -> [EvVar] -> [EvVar]
@@ -188,7 +191,7 @@ tcPatSynMatcher :: Located Name
                 -> TcType
                 -> TcM (Id, LHsBinds Id)
 -- See Note [Matchers and wrappers for pattern synonyms] in PatSyn
-tcPatSynMatcher (L loc name) lpat args wrap univ_tvs ex_tvs ev_binds prov_dicts req_dicts prov_theta req_theta pat_ty
+tcPatSynMatcher (L loc name) lpat arg_w_wraps univ_tvs ex_tvs ev_binds prov_dicts req_dicts prov_theta req_theta pat_ty
   = do { res_tv <- zonkQuantifiedTyVar =<< newFlexiTyVar liftedTypeKind
        ; matcher_name <- newImplicitBinder name mkMatcherOcc
        ; let res_ty = TyVarTy res_tv
@@ -204,7 +207,7 @@ tcPatSynMatcher (L loc name) lpat args wrap univ_tvs ex_tvs ev_binds prov_dicts
 
        ; scrutinee <- mkId "scrut" pat_ty
        ; cont <- mkId "cont" cont_ty
-       ; let cont' = mkLHsWrap wrap $ nlHsApps cont $ map nlHsVar (ex_tvs ++ prov_dicts ++ args)
+       ; let cont' = nlHsApps cont $ map nlHsVar (ex_tvs ++ prov_dicts) ++ [mkLHsWrap wrap $ nlHsVar arg | (arg, wrap) <- arg_w_wraps]
        ; fail <- mkId "fail" res_ty
        ; let fail' = nlHsVar fail
 
@@ -253,6 +256,7 @@ tcPatSynMatcher (L loc name) lpat args wrap univ_tvs ex_tvs ev_binds prov_dicts
     mkId s ty = do
         name <- newName . mkVarOccFS . fsLit $ s
         return $ mkLocalId name ty
+    args = map fst arg_w_wraps
 
 isBidirectional :: HsPatSynDir a -> Bool
 isBidirectional Unidirectional = False
diff --git a/testsuite/tests/patsyn/should_compile/T8584-1.hs b/testsuite/tests/patsyn/should_compile/T8584-1.hs
new file mode 100644
index 0000000..7a017c8
--- /dev/null
+++ b/testsuite/tests/patsyn/should_compile/T8584-1.hs
@@ -0,0 +1,10 @@
+{-# LANGUAGE PatternSynonyms #-}
+module ShouldCompile where
+
+pattern type (Eq a) => Single a :: (Show a) => [a]
+-- pattern type Single a :: (Eq a, Show a) => [a]
+-- pattern type Single a :: [a]
+pattern Single x = [x]
+
+-- f :: (Show a) => [a] -> a
+foobar (Single x) = x
diff --git a/testsuite/tests/patsyn/should_compile/all.T b/testsuite/tests/patsyn/should_compile/all.T
index 3b7bf27..8896008 100644
--- a/testsuite/tests/patsyn/should_compile/all.T
+++ b/testsuite/tests/patsyn/should_compile/all.T
@@ -11,3 +11,4 @@ test('export', normal, compile, [''])
 test('T8966', normal, compile, [''])
 test('T9023', normal, compile, [''])
 test('T8968-1', normal, compile, [''])
+test('T8584-1', normal, compile, [''])