Commit 921b1b32 authored by Simon Peyton Jones's avatar Simon Peyton Jones

A bit of refactoring on handling HsPar and friends

This relates to Trac #4430 (infix expressions in TH),.
Mainly comments but a bit of code wibbling.
parent 9aab4f4c
......@@ -95,6 +95,9 @@ failWith m = CvtM (\_ -> Left m)
returnL :: a -> CvtM (Located a)
returnL x = CvtM (\loc -> Right (L loc x))
wrapParL :: (Located a -> a) -> a -> CvtM a
wrapParL add_par x = CvtM (\loc -> Right (add_par (L loc x)))
wrapMsg :: (Show a, TH.Ppr a) => String -> a -> CvtM b -> CvtM b
-- E.g wrapMsg "declaration" dec thing
wrapMsg what item (CvtM m)
......@@ -464,8 +467,8 @@ cvtl e = wrapL (cvt e)
cvt (LamE ps e) = do { ps' <- cvtPats ps; e' <- cvtl e
; return $ HsLam (mkMatchGroup [mkSimpleMatch ps' e']) }
cvt (TupE [e]) = do { e' <- cvtl e; return $ HsPar e' }
-- Note [Dropping constructors]
-- Singleton tuples treated like nothing (just parens)
-- 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;
......@@ -483,20 +486,27 @@ cvtl e = wrapL (cvt e)
| Just s <- allCharLs xs = do { l' <- cvtLit (StringL s); return (HsLit l') }
-- Note [Converting strings]
| otherwise = do { xs' <- mapM cvtl xs; return $ ExplicitList void xs' }
-- Infix expressions
cvt (InfixE (Just x) s (Just y)) = do { x' <- cvtl x; s' <- cvtl s; y' <- cvtl y
; x'' <- returnL (HsPar x'); y'' <- returnL (HsPar y')
; e' <- returnL $ OpApp x'' s' undefined y''
; return $ HsPar e' }
; wrapParL HsPar $
OpApp (mkLHsPar x') s' undefined (mkLHsPar y') }
-- Parenthesise both arguments and result,
-- to ensure this operator application does
-- does not get re-associated
-- See Note [Operator association]
cvt (InfixE Nothing s (Just y)) = do { s' <- cvtl s; y' <- cvtl y
; sec <- returnL $ SectionR s' y'
; return $ HsPar sec }
; wrapParL HsPar $ SectionR s' y' }
-- See Note [Sections in HsSyn] in HsExpr
cvt (InfixE (Just x) s Nothing ) = do { x' <- cvtl x; s' <- cvtl s
; sec <- returnL $ SectionL x' s'
; return $ HsPar sec }
; wrapParL HsPar $ SectionL x' s' }
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' }
......@@ -534,8 +544,16 @@ 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]
~~~~~~~~~~~~~~~~~~~~~~~~~~~
{- Note [Operator assocation]
We must be quite careful about adding parens:
* Infix (UInfix ...) op arg Needs parens round the first arg
* Infix (Infix ...) op arg Needs parens round the first arg
* UInfix (UInfix ...) op arg No parens for first arg
* UInfix (Infix ...) op arg Needs parens round first arg
Note [Converting UInfix]
~~~~~~~~~~~~~~~~~~~~~~~~
When converting @UInfixE@ and @UInfixP@ values, we want to readjust
the trees to reflect the fixities of the underlying operators:
......@@ -697,31 +715,32 @@ cvtPat pat = wrapL (cvtp pat)
cvtp :: TH.Pat -> CvtM (Hs.Pat RdrName)
cvtp (TH.LitP l)
| overloadedLit l = do { l' <- cvtOverLit l
; return (mkNPat l' Nothing) }
| overloadedLit l = do { l' <- cvtOverLit l
; return (mkNPat l' Nothing) }
-- Not right for negative patterns;
-- 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]) = do { p' <- cvtPat p; return $ ParPat p' } -- Note [Dropping constructors]
cvtp (TupP ps) = do { ps' <- cvtPats ps; return $ TuplePat ps' Boxed void }
| otherwise = do { l' <- cvtLit l; return $ Hs.LitPat l' }
cvtp (TH.VarP s) = do { s' <- vName s; return $ Hs.VarPat s' }
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
; 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
; 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' }
cvtp (ViewP e p) = do { e' <- cvtl e; p' <- cvtPat p; return $ ViewPat e' p' 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
; wrapParL ParPat $
ConPatIn s' (InfixCon (mkParPat p1') (mkParPat p2')) }
-- See Note [Operator association]
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
; 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' }
cvtp (ViewP e p) = do { e' <- cvtl e; p' <- cvtPat p; return $ ViewPat e' p' void }
cvtPatFld :: (TH.Name, TH.Pat) -> CvtM (HsRecField RdrName (LPat RdrName))
cvtPatFld (s,p)
......
......@@ -120,11 +120,11 @@ data HsExpr id
| NegApp (LHsExpr id) -- negated expr
(SyntaxExpr id) -- Name of 'negate'
| HsPar (LHsExpr id) -- parenthesised expr
| HsPar (LHsExpr id) -- Parenthesised expr; see Note [Parens in HsSyn]
| SectionL (LHsExpr id) -- operand
| SectionL (LHsExpr id) -- operand; see Note [Sections in HsSyn]
(LHsExpr id) -- operator
| SectionR (LHsExpr id) -- operator
| SectionR (LHsExpr id) -- operator; see Note [Sections in HsSyn]
(LHsExpr id) -- operand
| ExplicitTuple -- Used for explicit tuples and sections thereof
......@@ -300,6 +300,28 @@ type PendingSplice = (Name, LHsExpr Id) -- Typechecked splices, waiting to be
-- pasted back in by the desugarer
\end{code}
Note [Parens in HsSyn]
~~~~~~~~~~~~~~~~~~~~~~
HsPar (and ParPat in patterns, HsParTy in types) is used as follows
* Generally HsPar is optional; the pretty printer adds parens where
necessary. Eg (HsApp f (HsApp g x)) is fine, and prints 'f (g x)'
* HsPars are pretty printed as '( .. )' regardless of whether
or not they are strictly necssary
* HsPars are respected when rearranging operator fixities.
So a * (b + c) means what it says (where the parens are an HsPar)
Note [Sections in HsSyn]
~~~~~~~~~~~~~~~~~~~~~~~~
Sections should always appear wrapped in an HsPar, thus
HsPar (SectionR ...)
The parser parses sections in a wider variety of situations
(See Note [Parsing sections]), but the renamer checks for those
parens. This invariant makes pretty-printing easier; we don't need
a special case for adding the parens round sections.
Note [Rebindable if]
~~~~~~~~~~~~~~~~~~~~
The rebindable syntax for 'if' is a bit special, because when
......@@ -400,8 +422,7 @@ ppr_expr (SectionR op expr)
pp_prefixly = hang (hsep [text "( \\ x_ ->", ppr op, ptext (sLit "x_")])
4 ((<>) pp_expr rparen)
pp_infixly v
= (sep [pprHsInfix v, pp_expr])
pp_infixly v = sep [pprHsInfix v, pp_expr]
ppr_expr (ExplicitTuple exprs boxity)
= tupleParens boxity (fcat (ppr_tup_args exprs))
......@@ -557,29 +578,33 @@ pprDebugParendExpr expr
pprParendExpr :: OutputableBndr id => LHsExpr id -> SDoc
pprParendExpr expr
= let
pp_as_was = pprLExpr expr
| hsExprNeedsParens (unLoc expr) = parens (pprLExpr expr)
| otherwise = pprLExpr expr
-- Using pprLExpr makes sure that we go 'deeper'
-- I think that is usually (always?) right
in
case unLoc expr of
ArithSeq {} -> pp_as_was
PArrSeq {} -> pp_as_was
HsLit {} -> pp_as_was
HsOverLit {} -> pp_as_was
HsVar {} -> pp_as_was
HsIPVar {} -> pp_as_was
ExplicitTuple {} -> pp_as_was
ExplicitList {} -> pp_as_was
ExplicitPArr {} -> pp_as_was
HsPar {} -> pp_as_was
HsBracket {} -> pp_as_was
HsBracketOut _ [] -> pp_as_was
HsDo sc _ _
| isListCompExpr sc -> pp_as_was
_ -> parens pp_as_was
isAtomicHsExpr :: HsExpr id -> Bool -- A single token
hsExprNeedsParens :: HsExpr id -> Bool
-- True of expressions for which '(e)' and 'e'
-- mean the same thing
hsExprNeedsParens (ArithSeq {}) = False
hsExprNeedsParens (PArrSeq {}) = False
hsExprNeedsParens (HsLit {}) = False
hsExprNeedsParens (HsOverLit {}) = False
hsExprNeedsParens (HsVar {}) = False
hsExprNeedsParens (HsIPVar {}) = False
hsExprNeedsParens (ExplicitTuple {}) = False
hsExprNeedsParens (ExplicitList {}) = False
hsExprNeedsParens (ExplicitPArr {}) = False
hsExprNeedsParens (HsPar {}) = False
hsExprNeedsParens (HsBracket {}) = False
hsExprNeedsParens (HsBracketOut _ []) = False
hsExprNeedsParens (HsDo sc _ _)
| isListCompExpr sc = False
hsExprNeedsParens _ = True
isAtomicHsExpr :: HsExpr id -> Bool
-- True of a single token
isAtomicHsExpr (HsVar {}) = True
isAtomicHsExpr (HsLit {}) = True
isAtomicHsExpr (HsOverLit {}) = True
......
......@@ -68,6 +68,7 @@ data Pat id
| LazyPat (LPat id) -- Lazy pattern
| AsPat (Located id) (LPat id) -- As pattern
| ParPat (LPat id) -- Parenthesised pattern
-- See Note [Parens in HsSyn] in HsExpr
| BangPat (LPat id) -- Bang pattern
------------ Lists, tuples, arrays ---------------
......@@ -238,17 +239,8 @@ pprParendLPat :: (OutputableBndr name) => LPat name -> SDoc
pprParendLPat (L _ p) = pprParendPat p
pprParendPat :: (OutputableBndr name) => Pat name -> SDoc
pprParendPat p | patNeedsParens p = parens (pprPat p)
| otherwise = pprPat p
patNeedsParens :: Pat name -> Bool
patNeedsParens (ConPatIn _ d) = not (null (hsConPatArgs d))
patNeedsParens (ConPatOut { pat_args = d }) = not (null (hsConPatArgs d))
patNeedsParens (SigPatIn {}) = True
patNeedsParens (SigPatOut {}) = True
patNeedsParens (ViewPat {}) = True
patNeedsParens (CoPat {}) = True
patNeedsParens _ = False
pprParendPat p | hsPatNeedsParens p = parens (pprPat p)
| otherwise = pprPat p
pprPat :: (OutputableBndr name) => Pat name -> SDoc
pprPat (VarPat var) = pprPatBndr var
......@@ -268,8 +260,9 @@ pprPat (ConPatOut { pat_con = con, pat_tvs = tvs, pat_dicts = dicts,
= getPprStyle $ \ sty -> -- Tiresome; in TcBinds.tcRhs we print out a
if debugStyle sty then -- typechecked Pat in an error message,
-- and we want to make sure it prints nicely
ppr con <+> sep [ hsep (map pprPatBndr tvs) <+> hsep (map pprPatBndr dicts),
ppr binds, pprConArgs details]
ppr con <> braces (sep [ hsep (map pprPatBndr (tvs ++ dicts))
, ppr binds])
<+> pprConArgs details
else pprUserCon con details
pprPat (LitPat s) = ppr s
......@@ -438,29 +431,29 @@ isIrrefutableHsPat pat
urk pat = pprPanic "isIrrefutableHsPat:" (ppr pat)
hsPatNeedsParens :: Pat a -> Bool
hsPatNeedsParens (NPlusKPat {}) = True
hsPatNeedsParens (QuasiQuotePat {}) = True
hsPatNeedsParens (ConPatIn _ ds) = conPatNeedsParens ds
hsPatNeedsParens p@(ConPatOut {}) = conPatNeedsParens (pat_args p)
hsPatNeedsParens (SigPatIn {}) = True
hsPatNeedsParens (SigPatOut {}) = True
hsPatNeedsParens (ViewPat {}) = True
hsPatNeedsParens (CoPat {}) = True
hsPatNeedsParens (WildPat {}) = False
hsPatNeedsParens (VarPat {}) = False
hsPatNeedsParens (LazyPat {}) = False
hsPatNeedsParens (BangPat {}) = False
hsPatNeedsParens (CoPat {}) = True
hsPatNeedsParens (ParPat {}) = False
hsPatNeedsParens (AsPat {}) = False
hsPatNeedsParens (ViewPat {}) = True
hsPatNeedsParens (SigPatIn {}) = True
hsPatNeedsParens (SigPatOut {}) = True
hsPatNeedsParens (TuplePat {}) = False
hsPatNeedsParens (ListPat {}) = False
hsPatNeedsParens (PArrPat {}) = False
hsPatNeedsParens (ConPatIn _ ds) = conPatNeedsParens ds
hsPatNeedsParens (ConPatOut {}) = True
hsPatNeedsParens (LitPat {}) = False
hsPatNeedsParens (NPat {}) = False
hsPatNeedsParens (NPlusKPat {}) = True
hsPatNeedsParens (QuasiQuotePat {}) = True
conPatNeedsParens :: HsConDetails a b -> Bool
conPatNeedsParens (PrefixCon args) = not (null args)
conPatNeedsParens (InfixCon {}) = False
conPatNeedsParens (RecCon {}) = False
conPatNeedsParens (InfixCon {}) = True
conPatNeedsParens (RecCon {}) = True
\end{code}
......@@ -161,13 +161,9 @@ data HsType name
| HsOpTy (LHsType name) (Located name) (LHsType name)
| HsParTy (LHsType name)
| HsParTy (LHsType name) -- See Note [Parens in HsSyn] in HsExpr
-- Parenthesis preserved for the precedence re-arrangement in RnTypes
-- It's important that a * (b + c) doesn't get rearranged to (a*b) + c!
--
-- However, NB that toHsType doesn't add HsParTys (in an effort to keep
-- interface files smaller), so when printing a HsType we may need to
-- add parens.
| HsPredTy (HsPred name) -- Only used in the type of an instance
-- declaration, eg. Eq [a] -> Eq a
......
......@@ -22,6 +22,7 @@ module HsUtils(
mkHsWrap, mkLHsWrap, mkHsWrapCo, mkLHsWrapCo,
coToHsWrapper, mkHsDictLet, mkHsLams,
mkHsOpApp, mkHsDo, mkHsComp, mkHsWrapPat, mkHsWrapPatCo,
mkLHsPar,
nlHsTyApp, nlHsVar, nlHsLit, nlHsApp, nlHsApps, nlHsIntLit, nlHsVarApps,
nlHsDo, nlHsOpApp, nlHsLam, nlHsPar, nlHsIf, nlHsCase, nlList,
......@@ -35,7 +36,7 @@ module HsUtils(
-- Patterns
mkNPat, mkNPlusKPat, nlVarPat, nlLitPat, nlConVarPat, nlConPat, nlInfixConPat,
nlNullaryConPat, nlWildConPat, nlWildPat, nlTuplePat,
nlNullaryConPat, nlWildConPat, nlWildPat, nlTuplePat, mkParPat,
-- Types
mkHsAppTy, userHsTyVarBndrs,
......@@ -120,15 +121,50 @@ unguardedGRHSs rhs = GRHSs (unguardedRHS rhs) emptyLocalBinds
unguardedRHS :: LHsExpr id -> [LGRHS id]
unguardedRHS rhs@(L loc _) = [L loc (GRHS [] rhs)]
mkMatchGroup :: [LMatch id] -> MatchGroup id
mkMatchGroup matches = MatchGroup matches placeHolderType
mkHsAppTy :: LHsType name -> LHsType name -> LHsType name
mkHsAppTy t1 t2 = addCLoc t1 t2 (HsAppTy t1 t2)
mkHsApp :: LHsExpr name -> LHsExpr name -> LHsExpr name
mkHsApp e1 e2 = addCLoc e1 e2 (HsApp e1 e2)
mkHsLam :: [LPat id] -> LHsExpr id -> LHsExpr id
mkHsLam pats body = mkHsPar (L (getLoc body) (HsLam matches))
where
matches = mkMatchGroup [mkSimpleMatch pats body]
mkHsLams :: [TyVar] -> [EvVar] -> LHsExpr Id -> LHsExpr Id
mkHsLams tyvars dicts expr = mkLHsWrap (mkWpTyLams tyvars <.> mkWpLams dicts) expr
mkHsConApp :: DataCon -> [Type] -> [HsExpr Id] -> LHsExpr Id
-- Used for constructing dictionary terms etc, so no locations
mkHsConApp data_con tys args
= foldl mk_app (nlHsTyApp (dataConWrapId data_con) tys) args
where
mk_app f a = noLoc (HsApp f (noLoc a))
mkSimpleHsAlt :: LPat id -> LHsExpr id -> LMatch id
-- A simple lambda with a single pattern, no binds, no guards; pre-typechecking
mkSimpleHsAlt pat expr
= mkSimpleMatch [pat] expr
nlHsTyApp :: name -> [Type] -> LHsExpr name
nlHsTyApp fun_id tys = noLoc (HsWrap (mkWpTyApps tys) (HsVar fun_id))
--------- Adding parens ---------
mkLHsPar :: LHsExpr name -> LHsExpr name
-- Wrap in parens if hsExprNeedsParens says it needs them
-- So 'f x' becomes '(f x)', but '3' stays as '3'
mkLHsPar le@(L loc e) | hsExprNeedsParens e = L loc (HsPar le)
| otherwise = le
mkParPat :: LPat name -> LPat name
mkParPat lp@(L loc p) | hsPatNeedsParens p = L loc (ParPat lp)
| otherwise = lp
--------- HsWrappers: type args, dict args, casts ---------
mkLHsWrap :: HsWrapper -> LHsExpr id -> LHsExpr id
mkLHsWrap co_fn (L loc e) = L loc (mkHsWrap co_fn e)
......@@ -156,31 +192,9 @@ mkHsWrapPatCo :: Coercion -> Pat id -> Type -> Pat id
mkHsWrapPatCo (Refl _) pat _ = pat
mkHsWrapPatCo co pat ty = CoPat (WpCast co) pat ty
mkHsLam :: [LPat id] -> LHsExpr id -> LHsExpr id
mkHsLam pats body = mkHsPar (L (getLoc body) (HsLam matches))
where
matches = mkMatchGroup [mkSimpleMatch pats body]
mkMatchGroup :: [LMatch id] -> MatchGroup id
mkMatchGroup matches = MatchGroup matches placeHolderType
mkHsLams :: [TyVar] -> [EvVar] -> LHsExpr Id -> LHsExpr Id
mkHsLams tyvars dicts expr = mkLHsWrap (mkWpTyLams tyvars <.> mkWpLams dicts) expr
mkHsDictLet :: TcEvBinds -> LHsExpr Id -> LHsExpr Id
mkHsDictLet ev_binds expr = mkLHsWrap (mkWpLet ev_binds) expr
mkHsConApp :: DataCon -> [Type] -> [HsExpr Id] -> LHsExpr Id
-- Used for constructing dictionary terms etc, so no locations
mkHsConApp data_con tys args
= foldl mk_app (nlHsTyApp (dataConWrapId data_con) tys) args
where
mk_app f a = noLoc (HsApp f (noLoc a))
mkSimpleHsAlt :: LPat id -> LHsExpr id -> LMatch id
-- A simple lambda with a single pattern, no binds, no guards; pre-typechecking
mkSimpleHsAlt pat expr
= mkSimpleMatch [pat] expr
-------------------------------
-- These are the bits of syntax that contain rebindable names
......
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