From 4ede9f41f80625ad7474a5caad4156c8097ff6d8 Mon Sep 17 00:00:00 2001 From: Reiner Pope 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/compiler/hsSyn/Convert.lhs +++ b/compiler/hsSyn/Convert.lhs @@ -463,7 +463,9 @@ cvtl e = wrapL (cvt e) cvt (AppE x y) = do { x' <- cvtl x; y' <- cvtl y; return $ HsApp x' y' } cvt (LamE ps e) = do { ps' <- cvtPats ps; e' <- cvtl e ; return $ HsLam (mkMatchGroup [mkSimpleMatch ps' e']) } - cvt (TupE [e]) = cvt e -- Singleton tuples treated like nothing (just parens) + cvt (TupE [e]) = do { e' <- cvtl e; return $ HsPar e' } + -- Note [Dropping constructors] + -- Singleton tuples treated like nothing (just parens) cvt (TupE es) = do { es' <- mapM cvtl es; return $ ExplicitTuple (map Present es') Boxed } cvt (UnboxedTupE es) = do { es' <- mapM cvtl es; return $ ExplicitTuple (map Present es') Unboxed } cvt (CondE x y z) = do { x' <- cvtl x; y' <- cvtl y; z' <- cvtl z; @@ -482,7 +484,8 @@ cvtl e = wrapL (cvt e) -- Note [Converting strings] | otherwise = do { xs' <- mapM cvtl xs; return $ ExplicitList void xs' } cvt (InfixE (Just x) s (Just y)) = do { x' <- cvtl x; s' <- cvtl s; y' <- cvtl y - ; e' <- returnL $ OpApp x' s' undefined y' + ; x'' <- returnL (HsPar x'); y'' <- returnL (HsPar y') + ; e' <- returnL $ OpApp x'' s' undefined y'' ; return $ HsPar e' } cvt (InfixE Nothing s (Just y)) = do { s' <- cvtl s; y' <- cvtl y ; sec <- returnL $ SectionR s' y' @@ -490,8 +493,11 @@ cvtl e = wrapL (cvt e) cvt (InfixE (Just x) s Nothing ) = do { x' <- cvtl x; s' <- cvtl s ; sec <- returnL $ SectionL x' s' ; return $ HsPar sec } - cvt (InfixE Nothing s Nothing ) = cvt s -- Can I indicate this is an infix thing? - + cvt (InfixE Nothing s Nothing ) = do { s' <- cvtl s; return $ HsPar s' } + -- Can I indicate this is an infix thing? + -- Note [Dropping constructors] + cvt (UInfixE x s y) = do { x' <- cvtl x; cvtOpApp x' s y } -- Note [Converting UInfix] + cvt (ParensE e) = do { e' <- cvtl e; return $ HsPar e' } cvt (SigE e t) = do { e' <- cvtl e; t' <- cvtType t ; return $ ExprWithTySig e' t' } cvt (RecConE c flds) = do { c' <- cNameL c @@ -501,6 +507,22 @@ cvtl e = wrapL (cvt e) ; flds' <- mapM cvtFld flds ; return $ RecordUpd e' (HsRecFields flds' Nothing) [] [] [] } +{- Note [Dropping constructors] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When we drop constructors from the input (for instance, when we encounter @TupE [e]@) +we must insert parentheses around the argument. Otherwise, @UInfix@ constructors in @e@ +could meet @UInfix@ constructors containing the @TupE [e]@. For example: + + UInfixE x * (TupE [UInfixE y + z]) + +If we drop the singleton tuple but don't insert parentheses, the @UInfixE@s would meet +and the above expression would be reassociated to + + OpApp (OpApp x * y) + z + +which we don't want. +-} + cvtFld :: (TH.Name, TH.Exp) -> CvtM (HsRecField RdrName (LHsExpr RdrName)) cvtFld (v,e) = do { v' <- vNameL v; e' <- cvtl e @@ -512,6 +534,58 @@ cvtDD (FromThenR x y) = do { x' <- cvtl x; y' <- cvtl y; return $ FromThen x cvtDD (FromToR x y) = do { x' <- cvtl x; y' <- cvtl y; return $ FromTo x' y' } cvtDD (FromThenToR x y z) = do { x' <- cvtl x; y' <- cvtl y; z' <- cvtl z; return $ FromThenTo x' y' z' } +{- Note [Converting UInfix] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When converting @UInfixE@ and @UInfixP@ values, we want to readjust +the trees to reflect the fixities of the underlying operators: + + UInfixE x * (UInfixE y + z) ---> (x * y) + z + +This is done by the renamer (see @mkOppAppRn@ and @mkConOppPatRn@ in +RnTypes), which expects that the input will be completely left-biased. +So we left-bias the trees of @UInfixP@ and @UInfixE@ that we come across. + +Sample input: + + UInfixE + (UInfixE x op1 y) + op2 + (UInfixE z op3 w) + +Sample output: + + OpApp + (OpApp + (OpApp x op1 y) + op2 + z) + op3 + w + +The functions @cvtOpApp@ and @cvtOpAppP@ are responsible for this +left-biasing. +-} + +{- | @cvtOpApp x op y@ converts @op@ and @y@ and produces the operator application @x `op` y@. +The produced tree of infix expressions will be left-biased, provided @x@ is. + +We can see that @cvtOpApp@ is correct as follows. The inductive hypothesis +is that @cvtOpApp x op y@ is left-biased, provided @x@ is. It is clear that +this holds for both branches (of @cvtOpApp@), provided we assume it holds for +the recursive calls to @cvtOpApp@. + +When we call @cvtOpApp@ from @cvtl@, the first argument will always be left-biased +since we have already run @cvtl@ on it. +-} +cvtOpApp :: LHsExpr RdrName -> TH.Exp -> TH.Exp -> CvtM (HsExpr RdrName) +cvtOpApp x op1 (UInfixE y op2 z) + = do { l <- wrapL $ cvtOpApp x op1 y + ; cvtOpApp l op2 z } +cvtOpApp x op y + = do { op' <- cvtl op + ; y' <- cvtl y + ; return (OpApp x op' undefined y') } + ------------------------------------- -- Do notation and statements ------------------------------------- @@ -629,17 +703,21 @@ cvtp (TH.LitP l) -- need to think about that! | otherwise = do { l' <- cvtLit l; return $ Hs.LitPat l' } cvtp (TH.VarP s) = do { s' <- vName s; return $ Hs.VarPat s' } -cvtp (TupP [p]) = cvtp p +cvtp (TupP [p]) = do { p' <- cvtPat p; return $ ParPat p' } -- Note [Dropping constructors] cvtp (TupP ps) = do { ps' <- cvtPats ps; return $ TuplePat ps' Boxed void } cvtp (UnboxedTupP ps) = do { ps' <- cvtPats ps; return $ TuplePat ps' Unboxed void } cvtp (ConP s ps) = do { s' <- cNameL s; ps' <- cvtPats ps; return $ ConPatIn s' (PrefixCon ps') } cvtp (InfixP p1 s p2) = do { s' <- cNameL s; p1' <- cvtPat p1; p2' <- cvtPat p2 - ; return $ ConPatIn s' (InfixCon p1' p2') } + ; p1'' <- returnL (ParPat p1'); p2'' <- returnL (ParPat p2') + ; p <- returnL $ ConPatIn s' (InfixCon p1'' p2'') + ; return $ ParPat p } +cvtp (UInfixP p1 s p2)= do { p1' <- cvtPat p1; cvtOpAppP p1' s p2 } -- Note [Converting UInfix] +cvtp (ParensP p) = do { p' <- cvtPat p; return $ ParPat p' } cvtp (TildeP p) = do { p' <- cvtPat p; return $ LazyPat p' } cvtp (BangP p) = do { p' <- cvtPat p; return $ BangPat p' } cvtp (TH.AsP s p) = do { s' <- vNameL s; p' <- cvtPat p; return $ AsPat s' p' } cvtp TH.WildP = return $ WildPat void -cvtp (RecP c fs) = do { c' <- cNameL c; fs' <- mapM cvtPatFld fs +cvtp (RecP c fs) = do { c' <- cNameL c; fs' <- mapM cvtPatFld fs ; return $ ConPatIn c' $ Hs.RecCon (HsRecFields fs' Nothing) } cvtp (ListP ps) = do { ps' <- cvtPats ps; return $ ListPat ps' void } cvtp (SigP p t) = do { p' <- cvtPat p; t' <- cvtType t; return $ SigPatIn p' t' } @@ -650,6 +728,20 @@ cvtPatFld (s,p) = do { s' <- vNameL s; p' <- cvtPat p ; return (HsRecField { hsRecFieldId = s', hsRecFieldArg = p', hsRecPun = False}) } +{- | @cvtOpAppP x op y@ converts @op@ and @y@ and produces the operator application @x `op` y@. +The produced tree of infix patterns will be left-biased, provided @x@ is. + +See the @cvtOpApp@ documentation for how this function works. +-} +cvtOpAppP :: Hs.LPat RdrName -> TH.Name -> TH.Pat -> CvtM (Hs.Pat RdrName) +cvtOpAppP x op1 (UInfixP y op2 z) + = do { l <- wrapL $ cvtOpAppP x op1 y + ; cvtOpAppP l op2 z } +cvtOpAppP x op y + = do { op' <- cNameL op + ; y' <- cvtPat y + ; return (ConPatIn op' (InfixCon x y')) } + ----------------------------------------------------------- -- Types and type variables -- 1.7.1