diff options
author | Dr. ERDI Gergo <gergo@erdi.hu> | 2014-07-14 18:18:44 +0800 |
---|---|---|
committer | Dr. ERDI Gergo <gergo@erdi.hu> | 2014-07-14 18:18:44 +0800 |
commit | 698697656bb0501df40713aff847555e61b9411c (patch) | |
tree | cdaa857d11c09ee0eee8fa72b793003cf08fea16 | |
parent | 105f16f1862eee9c3dd2f8eda2947552f8e570f2 (diff) | |
download | haskell-wip/T8968.tar.gz |
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.
-rw-r--r-- | compiler/hsSyn/HsBinds.lhs | 1 | ||||
-rw-r--r-- | compiler/hsSyn/HsTypes.lhs | 2 | ||||
-rw-r--r-- | compiler/parser/Parser.y.pp | 12 | ||||
-rw-r--r-- | 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 2261a89741..3b3f3f8a0c 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 08a0eef498..52b919e094 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 45b0a2bccc..4773e9be6a 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 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] |