Commit 54d7c6be authored by reinerp's avatar reinerp Committed by Simon Peyton Jones

Add support for unresolved infix expressions and patterns

parent be0693dc
......@@ -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
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment