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

[git at git.haskell.org]

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

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

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

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

    Renamer for PatSynSigs: handle type variable bindings


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

37a4d470d65ce4d567f452dc89a42e916d0c31f2
 compiler/hsSyn/HsBinds.lhs  |  8 +++----
 compiler/rename/RnBinds.lhs | 57 +++++++++++++++++++++++++++++++--------------
 2 files changed, 43 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..4a98a35 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
@@ -50,6 +50,7 @@ import FastString
 import Data.List        ( partition, sort )
 import Maybes           ( orElse )
 import Control.Monad
+import Util             ( filterOut )
 #if __GLASGOW_HASKELL__ < 709
 import Data.Traversable ( traverse )
 #endif
@@ -841,23 +842,43 @@ 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 args ty (ex_flag, _ex_tvs, prov) (univ_flag, _univ_tvs, req))
+  = do	{ v' <- lookupSigOccRn ctxt sig v
+        ; let doc = TypeSigCtx $ quotes (ppr v)
+        ; loc <- getSrcSpanM
+
+        ; let (univ_kvs, univ_tvs) = extractHsTysRdrTyVars (ty:unLoc req)
+        ; let univ_tv_bndrs = mkHsQTvs . userHsTyVarBndrs loc $ univ_tvs
+
+        ; bindHsTyVars doc Nothing univ_kvs univ_tv_bndrs $ \ univ_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 (ex_kvs, ex_tvs) = extractHsTysRdrTyVars (arg_tys ++ unLoc prov)
+              ex_kvs' = filterOut (`elem` univ_kvs) ex_kvs
+              ex_tvs' = filterOut (`elem` univ_tvs) ex_tvs
+
+        ; let ex_tv_bndrs = mkHsQTvs . userHsTyVarBndrs loc $ ex_tvs'
+
+        ; bindHsTyVars doc Nothing ex_kvs' ex_tv_bndrs $ \ ex_tyvars -> do
+        { (prov', fvs3) <- rnContext doc prov
+        ; (args', fvs4) <- rnArgs
+
+        ; let fvs = plusFVs [fvs1, fvs2, fvs3, fvs4]
+        ; return (PatSynSig v' args' ty' (ex_flag, ex_tyvars, prov') (univ_flag, univ_tyvars, req'), fvs) }}}
 
 ppr_sig_bndrs :: [Located RdrName] -> SDoc
 ppr_sig_bndrs bs = quotes (pprWithCommas ppr bs)