Ticket #4430: compiler-0001-Add-support-for-unresolved-infix-expressions-and-pat.patch

File compiler-0001-Add-support-for-unresolved-infix-expressions-and-pat.patch, 8.0 KB (added by reinerp, 4 years ago)
  • compiler/hsSyn/Convert.lhs

    From 4ede9f41f80625ad7474a5caad4156c8097ff6d8 Mon Sep 17 00:00:00 2001
    From: Reiner Pope <[email protected]>
    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) 
    463463    cvt (AppE x y)     = do { x' <- cvtl x; y' <- cvtl y; return $ HsApp x' y' } 
    464464    cvt (LamE ps e)    = do { ps' <- cvtPats ps; e' <- cvtl e  
    465465                            ; 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) 
    467469    cvt (TupE es)      = do { es' <- mapM cvtl es; return $ ExplicitTuple (map Present es') Boxed } 
    468470    cvt (UnboxedTupE es)      = do { es' <- mapM cvtl es; return $ ExplicitTuple (map Present es') Unboxed } 
    469471    cvt (CondE x y z)  = do { x' <- cvtl x; y' <- cvtl y; z' <- cvtl z; 
    cvtl e = wrapL (cvt e) 
    482484             -- Note [Converting strings] 
    483485      | otherwise                    = do { xs' <- mapM cvtl xs; return $ ExplicitList void xs' } 
    484486    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'' 
    486489                                          ; return $ HsPar e' } 
    487490    cvt (InfixE Nothing  s (Just y)) = do { s' <- cvtl s; y' <- cvtl y 
    488491                                          ; sec <- returnL $ SectionR s' y' 
    cvtl e = wrapL (cvt e) 
    490493    cvt (InfixE (Just x) s Nothing ) = do { x' <- cvtl x; s' <- cvtl s 
    491494                                          ; sec <- returnL $ SectionL x' s' 
    492495                                          ; 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' } 
    495501    cvt (SigE e t)       = do { e' <- cvtl e; t' <- cvtType t 
    496502                              ; return $ ExprWithTySig e' t' } 
    497503    cvt (RecConE c flds) = do { c' <- cNameL c 
    cvtl e = wrapL (cvt e) 
    501507                              ; flds' <- mapM cvtFld flds 
    502508                              ; return $ RecordUpd e' (HsRecFields flds' Nothing) [] [] [] } 
    503509 
     510{- Note [Dropping constructors] 
     511~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 
     512When we drop constructors from the input (for instance, when we encounter @TupE [e]@) 
     513we must insert parentheses around the argument. Otherwise, @UInfix@ constructors in @e@ 
     514could meet @UInfix@ constructors containing the @TupE [e]@. For example: 
     515 
     516  UInfixE x * (TupE [UInfixE y + z]) 
     517 
     518If we drop the singleton tuple but don't insert parentheses, the @UInfixE@s would meet 
     519and the above expression would be reassociated to 
     520 
     521  OpApp (OpApp x * y) + z 
     522 
     523which we don't want. 
     524-} 
     525 
    504526cvtFld :: (TH.Name, TH.Exp) -> CvtM (HsRecField RdrName (LHsExpr RdrName)) 
    505527cvtFld (v,e)  
    506528  = do  { v' <- vNameL v; e' <- cvtl e 
    cvtDD (FromThenR x y) = do { x' <- cvtl x; y' <- cvtl y; return $ FromThen x 
    512534cvtDD (FromToR x y)       = do { x' <- cvtl x; y' <- cvtl y; return $ FromTo x' y' } 
    513535cvtDD (FromThenToR x y z) = do { x' <- cvtl x; y' <- cvtl y; z' <- cvtl z; return $ FromThenTo x' y' z' } 
    514536 
     537{- Note [Converting UInfix] 
     538~~~~~~~~~~~~~~~~~~~~~~~~~~~ 
     539When converting @UInfixE@ and @UInfixP@ values, we want to readjust 
     540the trees to reflect the fixities of the underlying operators: 
     541 
     542  UInfixE x * (UInfixE y + z) ---> (x * y) + z 
     543 
     544This is done by the renamer (see @mkOppAppRn@ and @mkConOppPatRn@ in 
     545RnTypes), which expects that the input will be completely left-biased. 
     546So we left-bias the trees  of @UInfixP@ and @UInfixE@ that we come across. 
     547 
     548Sample input: 
     549 
     550  UInfixE 
     551   (UInfixE x op1 y) 
     552   op2 
     553   (UInfixE z op3 w) 
     554 
     555Sample output: 
     556 
     557  OpApp 
     558    (OpApp 
     559      (OpApp x op1 y) 
     560      op2 
     561      z) 
     562    op3 
     563    w 
     564 
     565The functions @cvtOpApp@ and @cvtOpAppP@ are responsible for this 
     566left-biasing. 
     567-} 
     568 
     569{- | @cvtOpApp x op y@ converts @op@ and @y@ and produces the operator application @x `op` y@. 
     570The produced tree of infix expressions will be left-biased, provided @x@ is. 
     571 
     572We can see that @cvtOpApp@ is correct as follows. The inductive hypothesis 
     573is that @cvtOpApp x op y@ is left-biased, provided @x@ is. It is clear that 
     574this holds for both branches (of @cvtOpApp@), provided we assume it holds for 
     575the recursive calls to @cvtOpApp@. 
     576 
     577When we call @cvtOpApp@ from @cvtl@, the first argument will always be left-biased 
     578since we have already run @cvtl@ on it. 
     579-} 
     580cvtOpApp :: LHsExpr RdrName -> TH.Exp -> TH.Exp -> CvtM (HsExpr RdrName) 
     581cvtOpApp x op1 (UInfixE y op2 z) 
     582  = do { l <- wrapL $ cvtOpApp x op1 y 
     583       ; cvtOpApp l op2 z } 
     584cvtOpApp x op y 
     585  = do { op' <- cvtl op 
     586       ; y' <- cvtl y 
     587       ; return (OpApp x op' undefined y') } 
     588 
    515589------------------------------------- 
    516590--      Do notation and statements 
    517591------------------------------------- 
    cvtp (TH.LitP l) 
    629703                                  -- need to think about that! 
    630704  | otherwise         = do { l' <- cvtLit l; return $ Hs.LitPat l' } 
    631705cvtp (TH.VarP s)      = do { s' <- vName s; return $ Hs.VarPat s' } 
    632 cvtp (TupP [p])       = cvtp p 
     706cvtp (TupP [p])       = do { p' <- cvtPat p; return $ ParPat p' } -- Note [Dropping constructors] 
    633707cvtp (TupP ps)        = do { ps' <- cvtPats ps; return $ TuplePat ps' Boxed void } 
    634708cvtp (UnboxedTupP ps)  = do { ps' <- cvtPats ps; return $ TuplePat ps' Unboxed void } 
    635709cvtp (ConP s ps)      = do { s' <- cNameL s; ps' <- cvtPats ps; return $ ConPatIn s' (PrefixCon ps') } 
    636710cvtp (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 } 
     714cvtp (UInfixP p1 s p2)= do { p1' <- cvtPat p1; cvtOpAppP p1' s p2 } -- Note [Converting UInfix] 
     715cvtp (ParensP p)      = do { p' <- cvtPat p; return $ ParPat p' } 
    638716cvtp (TildeP p)       = do { p' <- cvtPat p; return $ LazyPat p' } 
    639717cvtp (BangP p)        = do { p' <- cvtPat p; return $ BangPat p' } 
    640718cvtp (TH.AsP s p)     = do { s' <- vNameL s; p' <- cvtPat p; return $ AsPat s' p' } 
    641719cvtp TH.WildP         = return $ WildPat void 
    642 cvtp (RecP c fs)      = do { c' <- cNameL c; fs' <- mapM cvtPatFld fs  
     720cvtp (RecP c fs)      = do { c' <- cNameL c; fs' <- mapM cvtPatFld fs 
    643721                           ; return $ ConPatIn c' $ Hs.RecCon (HsRecFields fs' Nothing) } 
    644722cvtp (ListP ps)       = do { ps' <- cvtPats ps; return $ ListPat ps' void } 
    645723cvtp (SigP p t)       = do { p' <- cvtPat p; t' <- cvtType t; return $ SigPatIn p' t' } 
    cvtPatFld (s,p) 
    650728  = do  { s' <- vNameL s; p' <- cvtPat p 
    651729        ; return (HsRecField { hsRecFieldId = s', hsRecFieldArg = p', hsRecPun = False}) } 
    652730 
     731{- | @cvtOpAppP x op y@ converts @op@ and @y@ and produces the operator application @x `op` y@. 
     732The produced tree of infix patterns will be left-biased, provided @x@ is. 
     733 
     734See the @cvtOpApp@ documentation for how this function works. 
     735-} 
     736cvtOpAppP :: Hs.LPat RdrName -> TH.Name -> TH.Pat -> CvtM (Hs.Pat RdrName) 
     737cvtOpAppP x op1 (UInfixP y op2 z) 
     738  = do { l <- wrapL $ cvtOpAppP x op1 y 
     739       ; cvtOpAppP l op2 z } 
     740cvtOpAppP x op y 
     741  = do { op' <- cNameL op 
     742       ; y' <- cvtPat y 
     743       ; return (ConPatIn op' (InfixCon x y')) } 
     744 
    653745----------------------------------------------------------- 
    654746--      Types and type variables 
    655747