diff options
author | Dr. ERDI Gergo <gergo@erdi.hu> | 2014-07-06 17:33:00 +0800 |
---|---|---|
committer | Dr. ERDI Gergo <gergo@erdi.hu> | 2014-07-29 11:34:41 +0200 |
commit | 12644c3c0216edfcff33266f4f250e0c52004352 (patch) | |
tree | 3a8f02e512ebec5987651e4b288bd4bcc3310d94 | |
parent | b6d52294cd009ef620ad9d74ab88e0822e685919 (diff) | |
download | haskell-12644c3c0216edfcff33266f4f250e0c52004352.tar.gz |
New parser for pattern synonym declarations:
Like splitCon for constructor definitions, the left-hand side of a
pattern declaration is parsed as a single pattern which is then split
into a ConName and argument variable names
-rw-r--r-- | compiler/parser/Parser.y.pp | 14 | ||||
-rw-r--r-- | compiler/parser/RdrHsSyn.lhs | 21 |
2 files changed, 28 insertions, 7 deletions
diff --git a/compiler/parser/Parser.y.pp b/compiler/parser/Parser.y.pp index 3fff097d25..9321e03d87 100644 --- a/compiler/parser/Parser.y.pp +++ b/compiler/parser/Parser.y.pp @@ -848,17 +848,19 @@ role : VARID { L1 $ Just $ getVARID $1 } -- Glasgow extension: pattern synonyms pattern_synonym_decl :: { LHsDecl RdrName } - : 'pattern' con vars0 patsyn_token pat { LL . ValD $ mkPatSynBind $2 (PrefixPatSyn $3) $5 $4 } - | 'pattern' varid conop varid patsyn_token pat { LL . ValD $ mkPatSynBind $3 (InfixPatSyn $2 $4) $6 $5 } + : 'pattern' pat '=' pat + {% do { (name, args) <- splitPatSyn $2 + ; return $ LL . ValD $ mkPatSynBind name args $4 ImplicitBidirectional + }} + | 'pattern' pat '<-' pat + {% do { (name, args) <- splitPatSyn $2 + ; return $ LL . ValD $ mkPatSynBind name args $4 Unidirectional + }} vars0 :: { [Located RdrName] } : {- empty -} { [] } | varid vars0 { $1 : $2 } -patsyn_token :: { HsPatSynDir RdrName } - : '<-' { Unidirectional } - | '=' { ImplicitBidirectional } - ----------------------------------------------------------------------------- -- Nested declarations diff --git a/compiler/parser/RdrHsSyn.lhs b/compiler/parser/RdrHsSyn.lhs index 93a98d068e..ed29fe0e6f 100644 --- a/compiler/parser/RdrHsSyn.lhs +++ b/compiler/parser/RdrHsSyn.lhs @@ -16,7 +16,7 @@ module RdrHsSyn ( mkTySynonym, mkTyFamInstEqn, mkTyFamInst, mkFamDecl, - splitCon, mkInlinePragma, + splitCon, splitPatSyn, mkInlinePragma, mkRecConstrOrUpdate, -- HsExp -> [HsFieldUpdate] -> P HsExp mkTyLit, mkTyClD, mkInstD, @@ -428,6 +428,25 @@ splitCon ty mk_rest [L _ (HsRecTy flds)] = RecCon flds mk_rest ts = PrefixCon ts +splitPatSyn :: LPat RdrName + -> P (Located RdrName, HsPatSynDetails (Located RdrName)) +splitPatSyn (L _ (ParPat pat)) = splitPatSyn pat +splitPatSyn pat@(L loc (ConPatIn con details)) = do + details' <- case details of + PrefixCon pats -> liftM PrefixPatSyn (mapM patVar pats) + InfixCon pat1 pat2 -> liftM2 InfixPatSyn (patVar pat1) (patVar pat2) + RecCon{} -> parseErrorSDoc loc $ + text "record syntax not supported for pattern synonym declarations:" $$ ppr pat + return (con, details') + where + patVar :: LPat RdrName -> P (Located RdrName) + patVar (L loc (VarPat v)) = return $ L loc v + patVar (L _ (ParPat pat)) = patVar pat + patVar pat@(L loc _) = parseErrorSDoc loc $ + text "Pattern synonym arguments must be variable names:" $$ ppr pat +splitPatSyn pat@(L loc _) = parseErrorSDoc loc $ + text "invalid pattern synonym declaration:" $$ ppr pat + mkDeprecatedGadtRecordDecl :: SrcSpan -> Located RdrName -> [ConDeclField RdrName] |