[commit: ghc] wip/T9023: Add parser for pattern synonym type signatures. Syntax is of the form (6986976)

[git at git.haskell.org]

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

On branch  : wip/T9023
Link       : http://ghc.haskell.org/trac/ghc/changeset/698697656bb0501df40713aff847555e61b9411c/ghc

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

commit 698697656bb0501df40713aff847555e61b9411c
Author: Dr. ERDI Gergo <gergo at erdi.hu>
Date:   Mon Jul 14 18:18:44 2014 +0800

    Add parser for pattern synonym type signatures.
    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.


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

698697656bb0501df40713aff847555e61b9411c
 compiler/hsSyn/HsBinds.lhs   |  1 +
 compiler/hsSyn/HsTypes.lhs   |  2 +-
 compiler/parser/Parser.y.pp  | 12 ++++++++----
 compiler/parser/RdrHsSyn.lhs | 29 ++++++++++++++++++++++++++++-
 4 files changed, 38 insertions(+), 6 deletions(-)

diff --git a/compiler/hsSyn/HsBinds.lhs b/compiler/hsSyn/HsBinds.lhs
index 2261a89..3b3f3f8 100644
--- a/compiler/hsSyn/HsBinds.lhs
+++ b/compiler/hsSyn/HsBinds.lhs
@@ -717,6 +717,7 @@ pprPatSynSig :: (OutputableBndr a)
              => a -> Bool -> HsPatSynDetails SDoc -> SDoc -> Maybe SDoc -> Maybe SDoc -> SDoc
 pprPatSynSig ident is_bidir args rhs_ty prov_theta req_theta
   = sep [ ptext (sLit "pattern")
+        , ptext (sLit "type")
         , thetaOpt prov_theta, name_and_args
         , colon
         , thetaOpt req_theta, rhs_ty
diff --git a/compiler/hsSyn/HsTypes.lhs b/compiler/hsSyn/HsTypes.lhs
index 08a0eef..52b919e 100644
--- a/compiler/hsSyn/HsTypes.lhs
+++ b/compiler/hsSyn/HsTypes.lhs
@@ -31,7 +31,7 @@ module HsTypes (
         hsLTyVarName, hsLTyVarNames, hsLTyVarLocName, hsLTyVarLocNames,
         splitLHsInstDeclTy_maybe,
         splitHsClassTy_maybe, splitLHsClassTy_maybe,
-        splitHsFunType,
+        splitHsFunType, splitLHsForAllTy,
         splitHsAppTys, hsTyGetAppHead_maybe, mkHsAppTys, mkHsOpTy,
 
         -- Printing
diff --git a/compiler/parser/Parser.y.pp b/compiler/parser/Parser.y.pp
index 45b0a2b..4773e9b 100644
--- a/compiler/parser/Parser.y.pp
+++ b/compiler/parser/Parser.y.pp
@@ -829,12 +829,15 @@ role : VARID             { L1 $ Just $ getVARID $1 }
 pattern_synonym_decl :: { LHsDecl RdrName }
         : 'pattern' pat '=' pat
             {% do { (name, args) <- splitPatSyn $2
-                  ; return $ LL . ValD $ mkPatSynBind name args $4 ImplicitBidirectional
-                  }}
+                  ; return $ LL . ValD $ mkPatSynBind name args $4 ImplicitBidirectional }}
         | 'pattern' pat '<-' pat
             {% do { (name, args) <- splitPatSyn $2
-                  ; return $ LL . ValD $ mkPatSynBind name args $4 Unidirectional
-                  }}
+                  ; return . LL $ ValD $ mkPatSynBind name args $4 Unidirectional }}
+
+pattern_synonym_sig :: { LSig RdrName }
+        : 'pattern' 'type' ctype '::' ctype
+             {% do { (name, details, ty, prov, req) <- splitPatSynSig $3 $5
+                   ; return . LL $ PatSynSig name details ty prov req }}
 
 vars0 :: { [Located RdrName] }
         : {- empty -}                 { [] }
@@ -1445,6 +1448,7 @@ sigdecl :: { Located (OrdList (LHsDecl RdrName)) }
                                 { LL $ toOL [ LL $ SigD (TypeSig ($1 : reverse (unLoc $3)) $5) ] }
         | infix prec ops        { LL $ toOL [ LL $ SigD (FixSig (FixitySig n (Fixity $2 (unLoc $1))))
                                              | n <- unLoc $3 ] }
+        | pattern_synonym_sig   { LL . unitOL $ LL . SigD . unLoc $ $1 }
         | '{-# INLINE' activation qvar '#-}'
                 { LL $ unitOL (LL $ SigD (InlineSig $3 (mkInlinePragma (getINLINE $1) $2))) }
         | '{-# SPECIALISE' activation qvar '::' sigtypes1 '#-}'
diff --git a/compiler/parser/RdrHsSyn.lhs b/compiler/parser/RdrHsSyn.lhs
index 0536286..cd025a7 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]