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

[git at git.haskell.org]

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

On branch  : wip/T8584
Link       : http://ghc.haskell.org/trac/ghc/changeset/7774b507abae777593ee575307bd4284788e1ba7/ghc

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

commit 7774b507abae777593ee575307bd4284788e1ba7
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.


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

7774b507abae777593ee575307bd4284788e1ba7
 compiler/hsSyn/HsBinds.lhs   |  1 +
 compiler/hsSyn/HsTypes.lhs   |  2 +-
 compiler/parser/Parser.y.pp  |  9 +++++++--
 compiler/parser/RdrHsSyn.lhs | 29 ++++++++++++++++++++++++++++-
 4 files changed, 37 insertions(+), 4 deletions(-)

diff --git a/compiler/hsSyn/HsBinds.lhs b/compiler/hsSyn/HsBinds.lhs
index bbf6bc2..91e60c7 100644
--- a/compiler/hsSyn/HsBinds.lhs
+++ b/compiler/hsSyn/HsBinds.lhs
@@ -743,6 +743,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 9bd5845..9d35c91 100644
--- a/compiler/hsSyn/HsTypes.lhs
+++ b/compiler/hsSyn/HsTypes.lhs
@@ -39,7 +39,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 e0eaf4d..41ad6f0 100644
--- a/compiler/parser/Parser.y.pp
+++ b/compiler/parser/Parser.y.pp
@@ -856,8 +856,7 @@ 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
@@ -873,6 +872,11 @@ where_decls :: { Located (OrdList (LHsDecl RdrName)) }
         : 'where' '{' decls '}'       { $3 }
         | 'where' vocurly decls close { $3 }
 
+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 -}                 { [] }
         | varid vars0                 { $1 : $2 }
@@ -1484,6 +1488,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 e6969e7..3f2f4bf 100644
--- a/compiler/parser/RdrHsSyn.lhs
+++ b/compiler/parser/RdrHsSyn.lhs
@@ -18,7 +18,7 @@ module RdrHsSyn (
         mkTyFamInst, 
         mkFamDecl, 
         splitCon, mkInlinePragma,
-        splitPatSyn, toPatSynMatchGroup,
+        splitPatSyn, splitPatSynSig, toPatSynMatchGroup,
         mkRecConstrOrUpdate, -- HsExp -> [HsFieldUpdate] -> P HsExp
         mkTyClD, mkInstD,
 
@@ -471,6 +471,33 @@ toPatSynMatchGroup (L _ patsyn_name) (L _ decls) =
         text "pattern synonym 'where' clause must bind the pattern synonym's name" <+>
         quotes (ppr patsyn_name) $$ ppr decl
 
+-- 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]