In concrete syntax, existential and universial tyvars of a pattern synonym

type signature are not split

4 files changed, 39 insertions, 56 deletions

diff --git a/compiler/hsSyn/HsBinds.lhs b/compiler/hsSyn/HsBinds.lhs
index 5a45956ae1..516f23e692 100644
--- a/compiler/hsSyn/HsBinds.lhs
+++ b/compiler/hsSyn/HsBinds.lhs
@@ -570,10 +570,10 @@ data Sig name
       -- | A pattern synonym type signature
       -- @pattern type forall b. (Eq b) => P a b :: forall a. (Num a) => T a
   | PatSynSig (Located name)
-              (HsPatSynDetails (LHsType name))
-              (LHsType name)    -- Type
-              (HsExplicitFlag, LHsTyVarBndrs name, LHsContext name) -- Provided context
-              (HsExplicitFlag, LHsTyVarBndrs name, LHsContext name) -- Required contex
+              (HsExplicitFlag, LHsTyVarBndrs name)
+              (LHsContext name) -- Provided context
+              (LHsContext name) -- Required context
+              (LHsType name)
 
         -- | A type signature for a default method inside a class
         --
@@ -730,13 +730,15 @@ 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)
-  = pprPatSynSig (unLoc name) False args (ppr ty) (pprCtx prov) (pprCtx req)
-  where
-    args = fmap ppr arg_tys
+ppr_sig (PatSynSig name tvs prov req ty)
+  = ptext (sLit "pattern type") <+> pprPrefixOcc (unLoc name)
+  -- = pprPatSynSig (unLoc name) False args (ppr ty) (pprCtx prov) (pprCtx req)
+  -- where
+  --   args = fmap ppr arg_tys
 
-    pprCtx (flag, tvs, lctx) = pprHsForAll flag tvs lctx
+  --   pprCtx (flag, tvs, lctx) = pprHsForAll flag tvs lctx
 
+{-
 pprPatSynSig :: (OutputableBndr a)
              => a -> Bool -> HsPatSynDetails SDoc -> SDoc -> SDoc -> SDoc -> SDoc
 pprPatSynSig ident is_bidir args rhs_ty prov req
@@ -750,6 +752,7 @@ pprPatSynSig ident is_bidir args rhs_ty prov req
             left_ty <+> pprInfixOcc ident <+> right_ty
 
     colon = if is_bidir then dcolon else dcolon -- TODO
+-}
 
 instance OutputableBndr name => Outputable (FixitySig name) where
   ppr (FixitySig name fixity) = sep [ppr fixity, pprInfixOcc (unLoc name)]
diff --git a/compiler/iface/IfaceSyn.lhs b/compiler/iface/IfaceSyn.lhs
index d22851067a..3baa98340a 100644
--- a/compiler/iface/IfaceSyn.lhs
+++ b/compiler/iface/IfaceSyn.lhs
@@ -765,6 +765,8 @@ pprIfaceDecl _ (IfacePatSyn { ifName = name, ifPatWrapper = wrapper,
                               ifPatProvCtxt = prov_ctxt, ifPatReqCtxt = req_ctxt,
                               ifPatArgs = args,
                               ifPatTy = ty })
+  = ptext (sLit "pattern type")
+  {-
   = pprPatSynSig name has_wrap args' ty'
                  (pprCtxt ex_tvs prov_ctxt)
                  (pprCtxt univ_tvs req_ctxt)
@@ -779,6 +781,7 @@ pprIfaceDecl _ (IfacePatSyn { ifName = name, ifPatWrapper = wrapper,
     ty' = pprParendIfaceType ty
 
     pprCtxt tvs ctxt = pprIfaceForAllPart tvs ctxt empty
+-}
 
 pprIfaceDecl ss (IfaceId { ifName = var, ifType = ty,
                               ifIdDetails = details, ifIdInfo = info })
diff --git a/compiler/rename/RnBinds.lhs b/compiler/rename/RnBinds.lhs
index 4a98a357b9..8fe52137b8 100644
--- a/compiler/rename/RnBinds.lhs
+++ b/compiler/rename/RnBinds.lhs
@@ -842,43 +842,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 (ex_flag, _ex_tvs, prov) (univ_flag, _univ_tvs, req))
+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 (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) }}}
+        ; 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)
diff --git a/compiler/typecheck/TcBinds.lhs b/compiler/typecheck/TcBinds.lhs
index b2c7fcca13..56a04ffab2 100644
--- a/compiler/typecheck/TcBinds.lhs
+++ b/compiler/typecheck/TcBinds.lhs
@@ -33,7 +33,7 @@ import PatSyn
 import ConLike
 import FamInstEnv( normaliseType )
 import FamInst( tcGetFamInstEnvs )
-import Type( tidyOpenType )
+import Type( tidyOpenType, splitFunTys )
 import TyCon
 import TcType
 import TysPrim
@@ -61,6 +61,7 @@ import PrelNames(ipClassName)
 import TcValidity (checkValidType)
 
 import Control.Monad
+import Data.List (partition)
 
 #include "HsVersions.h"
 \end{code}
@@ -1316,27 +1317,25 @@ tcTySig (L loc (TypeSig names@(L _ name1 : _) hs_ty))
   = setSrcSpan loc $ 
     do { sigma_ty <- tcHsSigType (FunSigCtxt name1) hs_ty
        ; mapM (instTcTySig hs_ty sigma_ty) (map unLoc names) }
-tcTySig (L loc (PatSynSig (L _ name) args ty (_, ex_tvs, prov) (_, univ_tvs, req)))
+tcTySig (L loc (PatSynSig (L _ name) (_, qtvs) prov req ty))
   = setSrcSpan loc $
-    do { traceTc "tcTySig" $ ppr name $$ ppr ty $$ ppr prov $$ ppr req
+    do { traceTc "tcTySig {" $ ppr name $$ ppr qtvs $$ ppr prov $$ ppr req $$ ppr ty
        ; let ctxt = FunSigCtxt name
-       ; tcHsTyVarBndrs univ_tvs $ \ univ_tvs' -> do
+       ; tcHsTyVarBndrs qtvs $ \ qtvs' -> do
        { ty' <- tcHsSigType ctxt ty
        ; req' <- tcHsContext req
-       ; tcHsTyVarBndrs ex_tvs $ \ ex_tvs' -> do
-       { ex_tvs' <- return $ filter (`notElem` univ_tvs') ex_tvs'
-       ; args' <- mapM (tcHsSigType ctxt) $ case args of
-           PrefixPatSyn tys -> tys
-           InfixPatSyn ty1 ty2 -> [ty1, ty2]
        ; prov' <- tcHsContext prov
-       ; traceTc "tcTySig" $ ppr ty' $$ ppr args' $$ ppr (ex_tvs', prov') $$ ppr (univ_tvs', req')
+       ; let (_, pat_ty) = splitFunTys ty'
+             univ_set = tyVarsOfType pat_ty
+             (univ_tvs, ex_tvs) = partition (`elemVarSet` univ_set) qtvs'
+       ; traceTc "tcTySig }" $ ppr (ex_tvs, prov') $$ ppr (univ_tvs, req') $$ ppr ty'
        ; let tpsi = TPSI{ patsig_name = name,
-                          patsig_tau = mkFunTys args' ty',
-                          patsig_ex = ex_tvs',
+                          patsig_tau = ty',
+                          patsig_ex = ex_tvs,
+                          patsig_univ = univ_tvs,
                           patsig_prov = prov',
-                          patsig_univ = univ_tvs',
                           patsig_req = req' }
-       ; return [TcPatSynInfo tpsi]}}}
+       ; return [TcPatSynInfo tpsi]}}
 tcTySig _ = return []
 
 instTcTySigFromId :: SrcSpan -> Id -> TcM TcSigInfo