Add parser for pattern synonym type signatures.wip/T8968

Syntax is of the form

    pattern type Eq a => P a T b :: Num b => R a b

which declares a pattern synonym called P, with argument types a, T, and b.

1 files changed, 28 insertions, 1 deletions

diff --git a/compiler/parser/RdrHsSyn.lhs b/compiler/parser/RdrHsSyn.lhs
index 0536286972..cd025a7384 100644
--- a/compiler/parser/RdrHsSyn.lhs
+++ b/compiler/parser/RdrHsSyn.lhs
@@ -16,7 +16,7 @@ module RdrHsSyn (
         mkTySynonym, mkTyFamInstEqn,
         mkTyFamInst, 
         mkFamDecl, 
-        splitCon, splitPatSyn, mkInlinePragma,
+        splitCon, splitPatSyn, splitPatSynSig, mkInlinePragma,
         mkRecConstrOrUpdate, -- HsExp -> [HsFieldUpdate] -> P HsExp
         mkTyLit,
         mkTyClD, mkInstD,
@@ -431,6 +431,33 @@ splitPatSyn pat@(L loc (ConPatIn con details)) = do
 splitPatSyn pat@(L loc _) = parseErrorSDoc loc $
                             text "invalid pattern synonym declaration:" $$ ppr pat
 
+-- Given two types like
+--    Eq a => P a T b
+-- and
+--    Num b => R a b
+--
+-- This returns
+-- P as the name,
+-- PrefixPatSyn [a, T, b] as the details,
+-- R a b as the result type,
+-- and (Eq a) and (Num b) as the provided and required thetas (respectively)
+splitPatSynSig :: LHsType RdrName
+      -> LHsType RdrName
+      -> P (Located RdrName, HsPatSynDetails (LHsType RdrName), LHsType RdrName, LHsContext RdrName, LHsContext RdrName)
+splitPatSynSig lty1 lty2 = do
+    (name, details) <- splitCon pat_ty
+    details' <- case details of
+        PrefixCon tys    -> return $ PrefixPatSyn tys
+        InfixCon ty1 ty2 -> return $ InfixPatSyn ty1 ty2
+        RecCon{}         -> parseErrorSDoc (getLoc lty1) $
+                              text "record syntax not supported for pattern synonym declarations:" $$ ppr lty1
+    return (name, details', res_ty, prov', req')
+  where
+    (_, prov, pat_ty) = splitLHsForAllTy lty1
+    (_, req, res_ty) = splitLHsForAllTy lty2
+    prov' = L (getLoc lty1) prov
+    req' = L (getLoc lty2) req
+
 mkDeprecatedGadtRecordDecl :: SrcSpan
                            -> Located RdrName
                            -> [ConDeclField RdrName]