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

git at git.haskell.org git at git.haskell.org
Fri Nov 7 15:02:52 UTC 2014


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

On branch  : wip/T8584
Link       : http://ghc.haskell.org/trac/ghc/changeset/39ce4cd710754943ebf26cd2f0390bd6b4c6884e/ghc

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

commit 39ce4cd710754943ebf26cd2f0390bd6b4c6884e
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.


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

39ce4cd710754943ebf26cd2f0390bd6b4c6884e
 compiler/hsSyn/HsBinds.lhs   |  1 +
 compiler/hsSyn/HsTypes.lhs   | 19 +++++++++++++------
 compiler/parser/Parser.y.pp  |  9 +++++++--
 compiler/parser/RdrHsSyn.lhs | 31 ++++++++++++++++++++++++++++++-
 4 files changed, 51 insertions(+), 9 deletions(-)

diff --git a/compiler/hsSyn/HsBinds.lhs b/compiler/hsSyn/HsBinds.lhs
index 23534cf..f75fa2e 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..db4d976 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, splitLHsForAllTyFlag, splitLHsForAllTy,
         splitHsAppTys, hsTyGetAppHead_maybe, mkHsAppTys, mkHsOpTy,
 
         -- Printing
@@ -510,15 +510,22 @@ splitLHsInstDeclTy_maybe inst_ty = do
     (cls, tys) <- splitLHsClassTy_maybe ty
     return (tvs, cxt, cls, tys)
 
+splitLHsForAllTyFlag
+    :: LHsType name
+    -> (HsExplicitFlag, LHsTyVarBndrs name, HsContext name, LHsType name)
+splitLHsForAllTyFlag poly_ty
+  = case unLoc poly_ty of
+        HsParTy ty                 -> splitLHsForAllTyFlag ty
+        HsForAllTy flag tvs cxt ty -> (flag, tvs, unLoc cxt, ty)
+        _                          -> (Implicit, emptyHsQTvs, [], poly_ty)
+        -- The type vars should have been computed by now, even if they were implicit
+
 splitLHsForAllTy
     :: LHsType name 
     -> (LHsTyVarBndrs name, HsContext name, LHsType name)
 splitLHsForAllTy poly_ty
-  = case unLoc poly_ty of
-        HsParTy ty              -> splitLHsForAllTy ty
-        HsForAllTy _ tvs cxt ty -> (tvs, unLoc cxt, ty)
-        _                       -> (emptyHsQTvs, [], poly_ty)
-        -- The type vars should have been computed by now, even if they were implicit
+  = let (_, tvs, cxt, ty) = splitLHsForAllTyFlag poly_ty
+    in (tvs, cxt, ty)
 
 splitHsClassTy_maybe :: HsType name -> Maybe (name, [LHsType name])
 splitHsClassTy_maybe ty = fmap (\(L _ n, tys) -> (n, tys)) $ splitLHsClassTy_maybe (noLoc ty)
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..3152642 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,35 @@ 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,
+            (HsExplicitFlag, LHsTyVarBndrs RdrName, LHsContext RdrName),
+            (HsExplicitFlag, LHsTyVarBndrs 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, (ex_flag, ex_tvs, prov'), (univ_flag, univ_tvs, req'))
+  where
+    (ex_flag, ex_tvs, prov, pat_ty) = splitLHsForAllTyFlag lty1
+    (univ_flag, univ_tvs, req, res_ty) = splitLHsForAllTyFlag lty2
+    prov' = L (getLoc lty1) prov
+    req' = L (getLoc lty2) req
+
 mkDeprecatedGadtRecordDecl :: SrcSpan
                            -> Located RdrName
                            -> [ConDeclField RdrName]



More information about the ghc-commits mailing list