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