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

[git at git.haskell.org]

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

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

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

commit 0276534ce117d77e75d92d57136716ee57e3392f
Author: Dr. ERDI Gergo <gergo at erdi.hu>
Date:   Fri Nov 7 19:29:06 2014 +0800

    Renamer for PatSynSigs: handle type variable bindings


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

0276534ce117d77e75d92d57136716ee57e3392f
 compiler/hsSyn/HsBinds.lhs  |  8 ++++----
 compiler/rename/RnBinds.lhs | 34 ++++++++++++++++------------------
 2 files changed, 20 insertions(+), 22 deletions(-)

diff --git a/compiler/hsSyn/HsBinds.lhs b/compiler/hsSyn/HsBinds.lhs
index bbf6bc2..23534cf 100644
--- a/compiler/hsSyn/HsBinds.lhs
+++ b/compiler/hsSyn/HsBinds.lhs
@@ -568,12 +568,12 @@ data Sig name
     TypeSig [Located name] (LHsType name)
 
       -- | A pattern synonym type signature
-      -- @pattern (Eq b) => P a b :: (Num a) => T a
+      -- @pattern type forall b. (Eq b) => P a b :: forall a. (Num a) => T a
   | PatSynSig (Located name)
               (HsPatSynDetails (LHsType name))
               (LHsType name)    -- Type
-              (LHsContext name) -- Provided context
-              (LHsContext name) -- Required contex
+              (HsExplicitFlag, LHsTyVarBndrs name, LHsContext name) -- Provided context
+              (HsExplicitFlag, LHsTyVarBndrs name, LHsContext name) -- Required contex
 
         -- | A type signature for a default method inside a class
         --
@@ -730,7 +730,7 @@ ppr_sig (SpecSig var ty inl)      = pragBrackets (pprSpec (unLoc var) (ppr ty) i
 ppr_sig (InlineSig var inl)       = pragBrackets (ppr inl <+> pprPrefixOcc (unLoc var))
 ppr_sig (SpecInstSig ty)          = pragBrackets (ptext (sLit "SPECIALIZE instance") <+> ppr ty)
 ppr_sig (MinimalSig bf)           = pragBrackets (pprMinimalSig bf)
-ppr_sig (PatSynSig name arg_tys ty prov req)
+ppr_sig (PatSynSig name arg_tys ty (_, _, prov) (_, _, req))
   = pprPatSynSig (unLoc name) False args (ppr ty) (pprCtx prov) (pprCtx req)
   where
     args = fmap ppr arg_tys
diff --git a/compiler/rename/RnBinds.lhs b/compiler/rename/RnBinds.lhs
index c2489cb..b43993e 100644
--- a/compiler/rename/RnBinds.lhs
+++ b/compiler/rename/RnBinds.lhs
@@ -30,7 +30,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
@@ -841,23 +841,21 @@ renameSig ctxt sig@(MinimalSig bf)
   = do new_bf <- traverse (lookupSigOccRn ctxt sig) 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)
+renameSig ctxt sig@(PatSynSig v (flag, qtvs) prov req ty)
+  = do  { v' <- lookupSigOccRn ctxt sig v
+        ; let doc = TypeSigCtx $ quotes (ppr v)
+        ; loc <- getSrcSpanM
+
+        ; let (tv_kvs, tvs) = extractHsTysRdrTyVars (ty:unLoc prov ++ unLoc req)
+        ; let tv_bndrs = mkHsQTvs . userHsTyVarBndrs loc $ tvs
+
+        ; bindHsTyVars doc Nothing tv_kvs tv_bndrs $ \ tyvars -> do
+        { (prov', fvs1) <- rnContext doc prov
+        ; (req', fvs2) <- rnContext doc req
+        ; (ty', fvs3) <- rnLHsType doc ty
+
+        ; let fvs = plusFVs [fvs1, fvs2, fvs3]
+        ; return (PatSynSig v' (flag, tyvars) prov' req' ty', fvs) }}
 
 ppr_sig_bndrs :: [Located RdrName] -> SDoc
 ppr_sig_bndrs bs = quotes (pprWithCommas ppr bs)