Ticket #4430: compiler0001Addsupportforunresolvedinfixexpressionsandpat.patch
File compiler0001Addsupportforunresolvedinfixexpressionsandpat.patch, 8.0 KB (added by reinerp, 5 years ago) 


compiler/hsSyn/Convert.lhs
From 4ede9f41f80625ad7474a5caad4156c8097ff6d8 Mon Sep 17 00:00:00 2001 From: Reiner Pope <reiner.pope@gmail.com> Date: Sat, 23 Jul 2011 16:15:41 +1000 Subject: [PATCH] Add support for unresolved infix expressions and patterns  compiler/hsSyn/Convert.lhs  106 +++++++++++++++++++++++++++++++++++++++++ 1 files changed, 99 insertions(+), 7 deletions() diff git a/compiler/hsSyn/Convert.lhs b/compiler/hsSyn/Convert.lhs index 5d0fb8c..6f44199 100644
a b cvtl e = wrapL (cvt e) 463 463 cvt (AppE x y) = do { x' < cvtl x; y' < cvtl y; return $ HsApp x' y' } 464 464 cvt (LamE ps e) = do { ps' < cvtPats ps; e' < cvtl e 465 465 ; return $ HsLam (mkMatchGroup [mkSimpleMatch ps' e']) } 466 cvt (TupE [e]) = cvt e  Singleton tuples treated like nothing (just parens) 466 cvt (TupE [e]) = do { e' < cvtl e; return $ HsPar e' } 467  Note [Dropping constructors] 468  Singleton tuples treated like nothing (just parens) 467 469 cvt (TupE es) = do { es' < mapM cvtl es; return $ ExplicitTuple (map Present es') Boxed } 468 470 cvt (UnboxedTupE es) = do { es' < mapM cvtl es; return $ ExplicitTuple (map Present es') Unboxed } 469 471 cvt (CondE x y z) = do { x' < cvtl x; y' < cvtl y; z' < cvtl z; … … cvtl e = wrapL (cvt e) 482 484  Note [Converting strings] 483 485  otherwise = do { xs' < mapM cvtl xs; return $ ExplicitList void xs' } 484 486 cvt (InfixE (Just x) s (Just y)) = do { x' < cvtl x; s' < cvtl s; y' < cvtl y 485 ; e' < returnL $ OpApp x' s' undefined y' 487 ; x'' < returnL (HsPar x'); y'' < returnL (HsPar y') 488 ; e' < returnL $ OpApp x'' s' undefined y'' 486 489 ; return $ HsPar e' } 487 490 cvt (InfixE Nothing s (Just y)) = do { s' < cvtl s; y' < cvtl y 488 491 ; sec < returnL $ SectionR s' y' … … cvtl e = wrapL (cvt e) 490 493 cvt (InfixE (Just x) s Nothing ) = do { x' < cvtl x; s' < cvtl s 491 494 ; sec < returnL $ SectionL x' s' 492 495 ; return $ HsPar sec } 493 cvt (InfixE Nothing s Nothing ) = cvt s  Can I indicate this is an infix thing? 494 496 cvt (InfixE Nothing s Nothing ) = do { s' < cvtl s; return $ HsPar s' } 497  Can I indicate this is an infix thing? 498  Note [Dropping constructors] 499 cvt (UInfixE x s y) = do { x' < cvtl x; cvtOpApp x' s y }  Note [Converting UInfix] 500 cvt (ParensE e) = do { e' < cvtl e; return $ HsPar e' } 495 501 cvt (SigE e t) = do { e' < cvtl e; t' < cvtType t 496 502 ; return $ ExprWithTySig e' t' } 497 503 cvt (RecConE c flds) = do { c' < cNameL c … … cvtl e = wrapL (cvt e) 501 507 ; flds' < mapM cvtFld flds 502 508 ; return $ RecordUpd e' (HsRecFields flds' Nothing) [] [] [] } 503 509 510 { Note [Dropping constructors] 511 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 512 When we drop constructors from the input (for instance, when we encounter @TupE [e]@) 513 we must insert parentheses around the argument. Otherwise, @UInfix@ constructors in @e@ 514 could meet @UInfix@ constructors containing the @TupE [e]@. For example: 515 516 UInfixE x * (TupE [UInfixE y + z]) 517 518 If we drop the singleton tuple but don't insert parentheses, the @UInfixE@s would meet 519 and the above expression would be reassociated to 520 521 OpApp (OpApp x * y) + z 522 523 which we don't want. 524 } 525 504 526 cvtFld :: (TH.Name, TH.Exp) > CvtM (HsRecField RdrName (LHsExpr RdrName)) 505 527 cvtFld (v,e) 506 528 = do { v' < vNameL v; e' < cvtl e … … cvtDD (FromThenR x y) = do { x' < cvtl x; y' < cvtl y; return $ FromThen x 512 534 cvtDD (FromToR x y) = do { x' < cvtl x; y' < cvtl y; return $ FromTo x' y' } 513 535 cvtDD (FromThenToR x y z) = do { x' < cvtl x; y' < cvtl y; z' < cvtl z; return $ FromThenTo x' y' z' } 514 536 537 { Note [Converting UInfix] 538 ~~~~~~~~~~~~~~~~~~~~~~~~~~~ 539 When converting @UInfixE@ and @UInfixP@ values, we want to readjust 540 the trees to reflect the fixities of the underlying operators: 541 542 UInfixE x * (UInfixE y + z) > (x * y) + z 543 544 This is done by the renamer (see @mkOppAppRn@ and @mkConOppPatRn@ in 545 RnTypes), which expects that the input will be completely leftbiased. 546 So we leftbias the trees of @UInfixP@ and @UInfixE@ that we come across. 547 548 Sample input: 549 550 UInfixE 551 (UInfixE x op1 y) 552 op2 553 (UInfixE z op3 w) 554 555 Sample output: 556 557 OpApp 558 (OpApp 559 (OpApp x op1 y) 560 op2 561 z) 562 op3 563 w 564 565 The functions @cvtOpApp@ and @cvtOpAppP@ are responsible for this 566 leftbiasing. 567 } 568 569 {  @cvtOpApp x op y@ converts @op@ and @y@ and produces the operator application @x `op` y@. 570 The produced tree of infix expressions will be leftbiased, provided @x@ is. 571 572 We can see that @cvtOpApp@ is correct as follows. The inductive hypothesis 573 is that @cvtOpApp x op y@ is leftbiased, provided @x@ is. It is clear that 574 this holds for both branches (of @cvtOpApp@), provided we assume it holds for 575 the recursive calls to @cvtOpApp@. 576 577 When we call @cvtOpApp@ from @cvtl@, the first argument will always be leftbiased 578 since we have already run @cvtl@ on it. 579 } 580 cvtOpApp :: LHsExpr RdrName > TH.Exp > TH.Exp > CvtM (HsExpr RdrName) 581 cvtOpApp x op1 (UInfixE y op2 z) 582 = do { l < wrapL $ cvtOpApp x op1 y 583 ; cvtOpApp l op2 z } 584 cvtOpApp x op y 585 = do { op' < cvtl op 586 ; y' < cvtl y 587 ; return (OpApp x op' undefined y') } 588 515 589  516 590  Do notation and statements 517 591  … … cvtp (TH.LitP l) 629 703  need to think about that! 630 704  otherwise = do { l' < cvtLit l; return $ Hs.LitPat l' } 631 705 cvtp (TH.VarP s) = do { s' < vName s; return $ Hs.VarPat s' } 632 cvtp (TupP [p]) = cvtp p706 cvtp (TupP [p]) = do { p' < cvtPat p; return $ ParPat p' }  Note [Dropping constructors] 633 707 cvtp (TupP ps) = do { ps' < cvtPats ps; return $ TuplePat ps' Boxed void } 634 708 cvtp (UnboxedTupP ps) = do { ps' < cvtPats ps; return $ TuplePat ps' Unboxed void } 635 709 cvtp (ConP s ps) = do { s' < cNameL s; ps' < cvtPats ps; return $ ConPatIn s' (PrefixCon ps') } 636 710 cvtp (InfixP p1 s p2) = do { s' < cNameL s; p1' < cvtPat p1; p2' < cvtPat p2 637 ; return $ ConPatIn s' (InfixCon p1' p2') } 711 ; p1'' < returnL (ParPat p1'); p2'' < returnL (ParPat p2') 712 ; p < returnL $ ConPatIn s' (InfixCon p1'' p2'') 713 ; return $ ParPat p } 714 cvtp (UInfixP p1 s p2)= do { p1' < cvtPat p1; cvtOpAppP p1' s p2 }  Note [Converting UInfix] 715 cvtp (ParensP p) = do { p' < cvtPat p; return $ ParPat p' } 638 716 cvtp (TildeP p) = do { p' < cvtPat p; return $ LazyPat p' } 639 717 cvtp (BangP p) = do { p' < cvtPat p; return $ BangPat p' } 640 718 cvtp (TH.AsP s p) = do { s' < vNameL s; p' < cvtPat p; return $ AsPat s' p' } 641 719 cvtp TH.WildP = return $ WildPat void 642 cvtp (RecP c fs) = do { c' < cNameL c; fs' < mapM cvtPatFld fs 720 cvtp (RecP c fs) = do { c' < cNameL c; fs' < mapM cvtPatFld fs 643 721 ; return $ ConPatIn c' $ Hs.RecCon (HsRecFields fs' Nothing) } 644 722 cvtp (ListP ps) = do { ps' < cvtPats ps; return $ ListPat ps' void } 645 723 cvtp (SigP p t) = do { p' < cvtPat p; t' < cvtType t; return $ SigPatIn p' t' } … … cvtPatFld (s,p) 650 728 = do { s' < vNameL s; p' < cvtPat p 651 729 ; return (HsRecField { hsRecFieldId = s', hsRecFieldArg = p', hsRecPun = False}) } 652 730 731 {  @cvtOpAppP x op y@ converts @op@ and @y@ and produces the operator application @x `op` y@. 732 The produced tree of infix patterns will be leftbiased, provided @x@ is. 733 734 See the @cvtOpApp@ documentation for how this function works. 735 } 736 cvtOpAppP :: Hs.LPat RdrName > TH.Name > TH.Pat > CvtM (Hs.Pat RdrName) 737 cvtOpAppP x op1 (UInfixP y op2 z) 738 = do { l < wrapL $ cvtOpAppP x op1 y 739 ; cvtOpAppP l op2 z } 740 cvtOpAppP x op y 741 = do { op' < cNameL op 742 ; y' < cvtPat y 743 ; return (ConPatIn op' (InfixCon x y')) } 744 653 745  654 746  Types and type variables 655 747