[commit: ghc] wip/T8584: Renamer for PatSynSigs: handle type variable bindings (c98a7fd)

[git at git.haskell.org]

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

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

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

commit c98a7fd86543e97dea140f6548a2b443027ddd70
Author: Dr. ERDI Gergo <gergo at erdi.hu>
Date:   Sun Jul 20 12:49:21 2014 +0800

    Renamer for PatSynSigs: handle type variable bindings


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

c98a7fd86543e97dea140f6548a2b443027ddd70
 compiler/rename/RnBinds.lhs | 49 +++++++++++++++++++++++++++++----------------
 1 file changed, 32 insertions(+), 17 deletions(-)

diff --git a/compiler/rename/RnBinds.lhs b/compiler/rename/RnBinds.lhs
index 0f9f44a..807a05c 100644
--- a/compiler/rename/RnBinds.lhs
+++ b/compiler/rename/RnBinds.lhs
@@ -35,7 +35,7 @@ import {-# SOURCE #-} RnExpr( rnLExpr, rnStmts )
 import HsSyn
 import TcRnMonad
 import TcEvidence     ( emptyTcEvBinds )
-import RnTypes        ( bindSigTyVarsFV, rnHsSigType, rnLHsType, checkPrecMatch, rnContext )
+import RnTypes
 import RnPat
 import RnNames
 import RnEnv
@@ -832,22 +832,37 @@ renameSig ctxt sig@(MinimalSig bf)
        return (MinimalSig new_bf, emptyFVs)
 
 renameSig ctxt sig@(PatSynSig v args ty prov req)
-  = do	v' <- lookupSigOccRn ctxt sig v
-        let doc = quotes (ppr v)
-            rn_type = rnHsSigType doc
-        (ty', fvs1) <- rn_type ty
-        (args', fvs2) <- case args of
-            PrefixPatSyn tys ->
-                do (tys, fvs) <- unzip <$> mapM rn_type tys
-                   return (PrefixPatSyn tys, plusFVs fvs)
-            InfixPatSyn left right ->
-                do (left', fvs1) <- rn_type left
-                   (right', fvs2) <- rn_type right
-                   return (InfixPatSyn left' right', fvs1 `plusFV` fvs2)
-        (prov', fvs3) <- rnContext (TypeSigCtx doc) prov
-        (req', fvs4) <- rnContext (TypeSigCtx doc) req
-        let fvs = plusFVs [fvs1, fvs2, fvs3, fvs4]
-        return (PatSynSig v' args' ty' prov' req', fvs)
+  = do	{ v' <- lookupSigOccRn ctxt sig v
+        ; let doc = TypeSigCtx $ quotes (ppr v)
+        ; loc <- getSrcSpanM
+
+        ; let (ty_kvs, ty_tvs) = extractHsTysRdrTyVars (ty:unLoc req)
+        ; let ty_tv_bndrs = mkHsQTvs . userHsTyVarBndrs loc $ ty_tvs
+
+        ; bindHsTyVars doc Nothing ty_kvs ty_tv_bndrs $ \ _new_tyvars -> do
+        { (req', fvs1) <- rnContext doc req
+        ; (ty', fvs2) <- rnLHsType doc ty
+
+        ; let (arg_tys, rnArgs) = case args of
+                  PrefixPatSyn tys ->
+                      let rnArgs = do
+                              (tys', fvs) <- mapFvRn (rnLHsType doc) tys
+                              return (PrefixPatSyn tys', fvs)
+                      in (tys, rnArgs)
+                  InfixPatSyn ty1 ty2 ->
+                      let rnArgs = do
+                              (ty1', fvs1) <- rnLHsType doc ty1
+                              (ty2', fvs2) <- rnLHsType doc ty2
+                              return (InfixPatSyn ty1' ty2', fvs1 `plusFV` fvs2)
+                      in ([ty1, ty2], rnArgs)
+        ; let (arg_kvs, arg_tvs) = extractHsTysRdrTyVars (arg_tys ++ unLoc prov)
+        ; let arg_tv_bndrs = mkHsQTvs . userHsTyVarBndrs loc $ arg_tvs
+
+        ; bindHsTyVars doc Nothing arg_kvs arg_tv_bndrs $ \ _new_tyvars -> do
+        { (prov', fvs3) <- rnContext doc prov
+        ; (args', fvs4) <- rnArgs
+
+        ; return (PatSynSig v' args' ty' prov' req', plusFVs [fvs1, fvs2, fvs3, fvs4]) }}}
 
 ppr_sig_bndrs :: [Located RdrName] -> SDoc
 ppr_sig_bndrs bs = quotes (pprWithCommas ppr bs)