Skip to content

GHC
GHC
Commit e3ec2e7a authored by Alan Zimmerman's avatar Alan Zimmerman
6 Browse files
Options

WIP on combined Step 1 and 3 for Trees That Grow, HsExpr 

See https://ghc.haskell.org/trac/ghc/wiki/ImplementingTreesThatGrow

Trees that grow extension points are added for
- HsExpr

Updates haddock submodule

Test Plan: ./validate

Reviewers: bgamari, goldfire

Subscribers: rwbarton, thomie, shayan-najd, mpickering

Differential Revision: https://phabricator.haskell.org/D4177
parent 86c50a16
Expand all Hide whitespace changes
Inline Side-by-side
Showing with 1452 additions and 1082 deletions
compiler/deSugar/Check.hs
View file @ e3ec2e7a
......@@ -675,12 +675,12 @@ truePattern = nullaryConPattern (RealDataCon trueDataCon)
-- | A fake guard pattern (True <- _) used to represent cases we cannot handle
fake_pat :: Pattern
fake_pat = PmGrd { pm_grd_pv = [truePattern]
, pm_grd_expr = PmExprOther EWildPat }
, pm_grd_expr = PmExprOther (EWildPat noExt) }
{-# INLINE fake_pat #-}
-- | Check whether a guard pattern is generated by the checker (unhandled)
isFakeGuard :: [Pattern] -> PmExpr -> Bool
isFakeGuard [PmCon { pm_con_con = RealDataCon c }] (PmExprOther EWildPat)
isFakeGuard [PmCon { pm_con_con = RealDataCon c }] (PmExprOther (EWildPat _))
| c == trueDataCon = True
| otherwise = False
isFakeGuard _pats _e = False
......@@ -760,7 +760,7 @@ translatePat fam_insts pat = case pat of
case all cantFailPattern ps of
True -> do
(xp,xe) <- mkPmId2Forms arg_ty
let g = mkGuard ps (HsApp lexpr xe)
let g = mkGuard ps (HsApp noExt lexpr xe)
return [xp,g]
False -> mkCanFailPmPat arg_ty
......@@ -1217,7 +1217,7 @@ mkPmId ty = getUniqueM >>= \unique ->
mkPmId2Forms :: Type -> DsM (Pattern, LHsExpr GhcTc)
mkPmId2Forms ty = do
x <- mkPmId ty
return (PmVar x, noLoc (HsVar (noLoc x)))
return (PmVar x, noLoc (HsVar noExt (noLoc x)))
-- ----------------------------------------------------------------------------
-- * Converting between Value Abstractions, Patterns and PmExpr
......
compiler/deSugar/Coverage.hs
View file @ e3ec2e7a
This diff is collapsed.
compiler/deSugar/DsArrows.hs
View file @ e3ec2e7a
......@@ -575,10 +575,12 @@ dsCmd ids local_vars stack_ty res_ty
left_con <- dsLookupDataCon leftDataConName
right_con <- dsLookupDataCon rightDataConName
let
left_id = HsConLikeOut (RealDataCon left_con)
right_id = HsConLikeOut (RealDataCon right_con)
left_expr ty1 ty2 e = noLoc $ HsApp (noLoc $ mkHsWrap (mkWpTyApps [ty1, ty2]) left_id ) e
right_expr ty1 ty2 e = noLoc $ HsApp (noLoc $ mkHsWrap (mkWpTyApps [ty1, ty2]) right_id) e
left_id = HsConLikeOut noExt (RealDataCon left_con)
right_id = HsConLikeOut noExt (RealDataCon right_con)
left_expr ty1 ty2 e = noLoc $ HsApp noExt
(noLoc $ mkHsWrap (mkWpTyApps [ty1, ty2]) left_id ) e
right_expr ty1 ty2 e = noLoc $ HsApp noExt
(noLoc $ mkHsWrap (mkWpTyApps [ty1, ty2]) right_id) e
-- Prefix each tuple with a distinct series of Left's and Right's,
-- in a balanced way, keeping track of the types.
......@@ -597,9 +599,10 @@ dsCmd ids local_vars stack_ty res_ty
(_, matches') = mapAccumL (replaceLeavesMatch res_ty) leaves' matches
in_ty = envStackType env_ids stack_ty
core_body <- dsExpr (HsCase exp (MG { mg_alts = L l matches'
, mg_arg_tys = arg_tys
, mg_res_ty = sum_ty, mg_origin = origin }))
core_body <- dsExpr (HsCase noExt exp
(MG { mg_alts = L l matches'
, mg_arg_tys = arg_tys
, mg_res_ty = sum_ty, mg_origin = origin }))
-- Note that we replace the HsCase result type by sum_ty,
-- which is the type of matches'
......
compiler/deSugar/DsExpr.hs
View file @ e3ec2e7a
This diff is collapsed.
compiler/deSugar/DsGRHSs.hs
View file @ e3ec2e7a
......@@ -136,24 +136,25 @@ isTrueLHsExpr :: LHsExpr GhcTc -> Maybe (CoreExpr -> DsM CoreExpr)
-- * Trivial wappings of these
-- The arguments to Just are any HsTicks that we have found,
-- because we still want to tick then, even it they are always evaluated.
isTrueLHsExpr (L _ (HsVar (L _ v))) | v `hasKey` otherwiseIdKey
|| v `hasKey` getUnique trueDataConId
= Just return
isTrueLHsExpr (L _ (HsVar _ (L _ v))) | v `hasKey` otherwiseIdKey
|| v `hasKey` getUnique trueDataConId
= Just return
-- trueDataConId doesn't have the same unique as trueDataCon
isTrueLHsExpr (L _ (HsConLikeOut con)) | con `hasKey` getUnique trueDataCon = Just return
isTrueLHsExpr (L _ (HsTick tickish e))
isTrueLHsExpr (L _ (HsConLikeOut _ con))
| con `hasKey` getUnique trueDataCon = Just return
isTrueLHsExpr (L _ (HsTick _ tickish e))
| Just ticks <- isTrueLHsExpr e
= Just (\x -> do wrapped <- ticks x
return (Tick tickish wrapped))
-- This encodes that the result is constant True for Hpc tick purposes;
-- which is specifically what isTrueLHsExpr is trying to find out.
isTrueLHsExpr (L _ (HsBinTick ixT _ e))
isTrueLHsExpr (L _ (HsBinTick _ ixT _ e))
| Just ticks <- isTrueLHsExpr e
= Just (\x -> do e <- ticks x
this_mod <- getModule
return (Tick (HpcTick this_mod ixT) e))
isTrueLHsExpr (L _ (HsPar e)) = isTrueLHsExpr e
isTrueLHsExpr (L _ (HsPar _ e)) = isTrueLHsExpr e
isTrueLHsExpr _ = Nothing
{-
......
compiler/deSugar/DsMeta.hs
View file @ e3ec2e7a
......@@ -1127,7 +1127,7 @@ repLE :: LHsExpr GhcRn -> DsM (Core TH.ExpQ)
repLE (L loc e) = putSrcSpanDs loc (repE e)
repE :: HsExpr GhcRn -> DsM (Core TH.ExpQ)
repE (HsVar (L _ x)) =
repE (HsVar _ (L _ x)) =
do { mb_val <- dsLookupMetaEnv x
; case mb_val of
Nothing -> do { str <- globalVar x
......@@ -1135,46 +1135,46 @@ repE (HsVar (L _ x)) =
Just (DsBound y) -> repVarOrCon x (coreVar y)
Just (DsSplice e) -> do { e' <- dsExpr e
; return (MkC e') } }
repE e@(HsIPVar _) = notHandled "Implicit parameters" (ppr e)
repE (HsOverLabel _ s) = repOverLabel s
repE e@(HsIPVar {}) = notHandled "Implicit parameters" (ppr e)
repE (HsOverLabel _ _ s) = repOverLabel s
repE e@(HsRecFld f) = case f of
Unambiguous x _ -> repE (HsVar (noLoc x))
repE e@(HsRecFld _ f) = case f of
Unambiguous x _ -> repE (HsVar noExt (noLoc x))
Ambiguous{} -> notHandled "Ambiguous record selectors" (ppr e)
XAmbiguousFieldOcc{} -> notHandled "XAmbiguous record selectors" (ppr e)
-- Remember, we're desugaring renamer output here, so
-- HsOverlit can definitely occur
repE (HsOverLit l) = do { a <- repOverloadedLiteral l; repLit a }
repE (HsLit l) = do { a <- repLiteral l; repLit a }
repE (HsLam (MG { mg_alts = L _ [m] })) = repLambda m
repE (HsLamCase (MG { mg_alts = L _ ms }))
repE (HsOverLit _ l) = do { a <- repOverloadedLiteral l; repLit a }
repE (HsLit _ l) = do { a <- repLiteral l; repLit a }
repE (HsLam _ (MG { mg_alts = L _ [m] })) = repLambda m
repE (HsLamCase _ (MG { mg_alts = L _ ms }))
= do { ms' <- mapM repMatchTup ms
; core_ms <- coreList matchQTyConName ms'
; repLamCase core_ms }
repE (HsApp x y) = do {a <- repLE x; b <- repLE y; repApp a b}
repE (HsAppType e t) = do { a <- repLE e
repE (HsApp _ x y) = do {a <- repLE x; b <- repLE y; repApp a b}
repE (HsAppType t e) = do { a <- repLE e
; s <- repLTy (hswc_body t)
; repAppType a s }
repE (OpApp e1 op _ e2) =
repE (OpApp _ e1 op e2) =
do { arg1 <- repLE e1;
arg2 <- repLE e2;
the_op <- repLE op ;
repInfixApp arg1 the_op arg2 }
repE (NegApp x _) = do
repE (NegApp _ x _) = do
a <- repLE x
negateVar <- lookupOcc negateName >>= repVar
negateVar `repApp` a
repE (HsPar x) = repLE x
repE (SectionL x y) = do { a <- repLE x; b <- repLE y; repSectionL a b }
repE (SectionR x y) = do { a <- repLE x; b <- repLE y; repSectionR a b }
repE (HsCase e (MG { mg_alts = L _ ms }))
repE (HsPar _ x) = repLE x
repE (SectionL _ x y) = do { a <- repLE x; b <- repLE y; repSectionL a b }
repE (SectionR _ x y) = do { a <- repLE x; b <- repLE y; repSectionR a b }
repE (HsCase _ e (MG { mg_alts = L _ ms }))
= do { arg <- repLE e
; ms2 <- mapM repMatchTup ms
; core_ms2 <- coreList matchQTyConName ms2
; repCaseE arg core_ms2 }
repE (HsIf _ x y z) = do
repE (HsIf _ _ x y z) = do
a <- repLE x
b <- repLE y
c <- repLE z
......@@ -1183,13 +1183,13 @@ repE (HsMultiIf _ alts)
= do { (binds, alts') <- liftM unzip $ mapM repLGRHS alts
; expr' <- repMultiIf (nonEmptyCoreList alts')
; wrapGenSyms (concat binds) expr' }
repE (HsLet (L _ bs) e) = do { (ss,ds) <- repBinds bs
repE (HsLet _ (L _ bs) e) = do { (ss,ds) <- repBinds bs
; e2 <- addBinds ss (repLE e)
; z <- repLetE ds e2
; wrapGenSyms ss z }
-- FIXME: I haven't got the types here right yet
repE e@(HsDo ctxt (L _ sts) _)
repE e@(HsDo _ ctxt (L _ sts))
| case ctxt of { DoExpr -> True; GhciStmtCtxt -> True; _ -> False }
= do { (ss,zs) <- repLSts sts;
e' <- repDoE (nonEmptyCoreList zs);
......@@ -1205,13 +1205,13 @@ repE e@(HsDo ctxt (L _ sts) _)
repE (ExplicitList _ _ es) = do { xs <- repLEs es; repListExp xs }
repE e@(ExplicitPArr _ _) = notHandled "Parallel arrays" (ppr e)
repE e@(ExplicitTuple es boxed)
repE e@(ExplicitTuple _ es boxed)
| not (all tupArgPresent es) = notHandled "Tuple sections" (ppr e)
| isBoxed boxed = do { xs <- repLEs [e | L _ (Present e) <- es]; repTup xs }
| otherwise = do { xs <- repLEs [e | L _ (Present e) <- es]
; repUnboxedTup xs }
repE (ExplicitSum alt arity e _)
repE (ExplicitSum _ alt arity e)
= do { e1 <- repLE e
; repUnboxedSum e1 alt arity }
......@@ -1224,7 +1224,7 @@ repE (RecordUpd { rupd_expr = e, rupd_flds = flds })
fs <- repUpdFields flds;
repRecUpd x fs }
repE (ExprWithTySig e ty)
repE (ExprWithTySig ty e)
= do { e1 <- repLE e
; t1 <- repHsSigWcType ty
; repSigExp e1 t1 }
......@@ -1246,9 +1246,9 @@ repE (ArithSeq _ _ aseq) =
ds3 <- repLE e3
repFromThenTo ds1 ds2 ds3
repE (HsSpliceE splice) = repSplice splice
repE (HsSpliceE _ splice) = repSplice splice
repE (HsStatic _ e) = repLE e >>= rep2 staticEName . (:[]) . unC
repE (HsUnboundVar uv) = do
repE (HsUnboundVar _ uv) = do
occ <- occNameLit (unboundVarOcc uv)
sname <- repNameS occ
repUnboundVar sname
......@@ -1257,7 +1257,6 @@ repE e@(PArrSeq {}) = notHandled "Parallel arrays" (ppr e)
repE e@(HsCoreAnn {}) = notHandled "Core annotations" (ppr e)
repE e@(HsSCC {}) = notHandled "Cost centres" (ppr e)
repE e@(HsTickPragma {}) = notHandled "Tick Pragma" (ppr e)
repE e@(HsTcBracketOut {}) = notHandled "TH brackets" (ppr e)
repE e = notHandled "Expression form" (ppr e)
-----------------------------------------------------------------------------
......
compiler/deSugar/Match.hs
View file @ e3ec2e7a
......@@ -977,18 +977,18 @@ viewLExprEq (e1,_) (e2,_) = lexp e1 e2
exp :: HsExpr GhcTc -> HsExpr GhcTc -> Bool
-- real comparison is on HsExpr's
-- strip parens
exp (HsPar (L _ e)) e' = exp e e'
exp e (HsPar (L _ e')) = exp e e'
exp (HsPar _ (L _ e)) e' = exp e e'
exp e (HsPar _ (L _ e')) = exp e e'
-- because the expressions do not necessarily have the same type,
-- we have to compare the wrappers
exp (HsWrap h e) (HsWrap h' e') = wrap h h' && exp e e'
exp (HsVar i) (HsVar i') = i == i'
exp (HsConLikeOut c) (HsConLikeOut c') = c == c'
exp (HsWrap _ h e) (HsWrap _ h' e') = wrap h h' && exp e e'
exp (HsVar _ i) (HsVar _ i') = i == i'
exp (HsConLikeOut _ c) (HsConLikeOut _ c') = c == c'
-- the instance for IPName derives using the id, so this works if the
-- above does
exp (HsIPVar i) (HsIPVar i') = i == i'
exp (HsOverLabel l x) (HsOverLabel l' x') = l == l' && x == x'
exp (HsOverLit l) (HsOverLit l') =
exp (HsIPVar _ i) (HsIPVar _ i') = i == i'
exp (HsOverLabel _ l x) (HsOverLabel _ l' x') = l == l' && x == x'
exp (HsOverLit _ l) (HsOverLit _ l') =
-- Overloaded lits are equal if they have the same type
-- and the data is the same.
-- this is coarser than comparing the SyntaxExpr's in l and l',
......@@ -996,20 +996,20 @@ viewLExprEq (e1,_) (e2,_) = lexp e1 e2
-- because these expressions get written as a bunch of different variables
-- (presumably to improve sharing)
eqType (overLitType l) (overLitType l') && l == l'
exp (HsApp e1 e2) (HsApp e1' e2') = lexp e1 e1' && lexp e2 e2'
exp (HsApp _ e1 e2) (HsApp _ e1' e2') = lexp e1 e1' && lexp e2 e2'
-- the fixities have been straightened out by now, so it's safe
-- to ignore them?
exp (OpApp l o _ ri) (OpApp l' o' _ ri') =
exp (OpApp _ l o ri) (OpApp _ l' o' ri') =
lexp l l' && lexp o o' && lexp ri ri'
exp (NegApp e n) (NegApp e' n') = lexp e e' && syn_exp n n'
exp (SectionL e1 e2) (SectionL e1' e2') =
exp (NegApp _ e n) (NegApp _ e' n') = lexp e e' && syn_exp n n'
exp (SectionL _ e1 e2) (SectionL _ e1' e2') =
lexp e1 e1' && lexp e2 e2'
exp (SectionR e1 e2) (SectionR e1' e2') =
exp (SectionR _ e1 e2) (SectionR _ e1' e2') =
lexp e1 e1' && lexp e2 e2'
exp (ExplicitTuple es1 _) (ExplicitTuple es2 _) =
exp (ExplicitTuple _ es1 _) (ExplicitTuple _ es2 _) =
eq_list tup_arg es1 es2
exp (ExplicitSum _ _ e _) (ExplicitSum _ _ e' _) = lexp e e'
exp (HsIf _ e e1 e2) (HsIf _ e' e1' e2') =
exp (ExplicitSum _ _ _ e) (ExplicitSum _ _ _ e') = lexp e e'
exp (HsIf _ _ e e1 e2) (HsIf _ _ e' e1' e2') =
lexp e e' && lexp e1 e1' && lexp e2 e2'
-- Enhancement: could implement equality for more expressions
......
compiler/deSugar/MatchLit.hs
View file @ e3ec2e7a
......@@ -241,10 +241,10 @@ warnAboutEmptyEnumerations dflags fromExpr mThnExpr toExpr
getLHsIntegralLit :: LHsExpr GhcTc -> Maybe (Integer, Name)
-- See if the expression is an Integral literal
-- Remember to look through automatically-added tick-boxes! (Trac #8384)
getLHsIntegralLit (L _ (HsPar e)) = getLHsIntegralLit e
getLHsIntegralLit (L _ (HsTick _ e)) = getLHsIntegralLit e
getLHsIntegralLit (L _ (HsBinTick _ _ e)) = getLHsIntegralLit e
getLHsIntegralLit (L _ (HsOverLit over_lit)) = getIntegralLit over_lit
getLHsIntegralLit (L _ (HsPar _ e)) = getLHsIntegralLit e
getLHsIntegralLit (L _ (HsTick _ _ e)) = getLHsIntegralLit e
getLHsIntegralLit (L _ (HsBinTick _ _ _ e)) = getLHsIntegralLit e
getLHsIntegralLit (L _ (HsOverLit _ over_lit)) = getIntegralLit over_lit
getLHsIntegralLit _ = Nothing
getIntegralLit :: HsOverLit GhcTc -> Maybe (Integer, Name)
......
compiler/deSugar/PmExpr.hs
View file @ e3ec2e7a
......@@ -236,32 +236,32 @@ lhsExprToPmExpr (L _ e) = hsExprToPmExpr e
hsExprToPmExpr :: HsExpr GhcTc -> PmExpr
hsExprToPmExpr (HsVar x) = PmExprVar (idName (unLoc x))
hsExprToPmExpr (HsConLikeOut c) = PmExprVar (conLikeName c)
hsExprToPmExpr (HsOverLit olit) = PmExprLit (PmOLit False olit)
hsExprToPmExpr (HsLit lit) = PmExprLit (PmSLit lit)
hsExprToPmExpr (HsVar _ x) = PmExprVar (idName (unLoc x))
hsExprToPmExpr (HsConLikeOut _ c) = PmExprVar (conLikeName c)
hsExprToPmExpr (HsOverLit _ olit) = PmExprLit (PmOLit False olit)
hsExprToPmExpr (HsLit _ lit) = PmExprLit (PmSLit lit)
hsExprToPmExpr e@(NegApp _ neg_e)
hsExprToPmExpr e@(NegApp _ _ neg_e)
| PmExprLit (PmOLit False ol) <- synExprToPmExpr neg_e
= PmExprLit (PmOLit True ol)
| otherwise = PmExprOther e
hsExprToPmExpr (HsPar (L _ e)) = hsExprToPmExpr e
hsExprToPmExpr (HsPar _ (L _ e)) = hsExprToPmExpr e
hsExprToPmExpr e@(ExplicitTuple ps boxity)
hsExprToPmExpr e@(ExplicitTuple _ ps boxity)
| all tupArgPresent ps = mkPmExprData tuple_con tuple_args
| otherwise = PmExprOther e
where
tuple_con = tupleDataCon boxity (length ps)
tuple_args = [ lhsExprToPmExpr e | L _ (Present e) <- ps ]
hsExprToPmExpr e@(ExplicitList _elem_ty mb_ol elems)
hsExprToPmExpr e@(ExplicitList _ mb_ol elems)
| Nothing <- mb_ol = foldr cons nil (map lhsExprToPmExpr elems)
| otherwise = PmExprOther e {- overloaded list: No PmExprApp -}
where
cons x xs = mkPmExprData consDataCon [x,xs]
nil = mkPmExprData nilDataCon []
hsExprToPmExpr (ExplicitPArr _elem_ty elems)
hsExprToPmExpr (ExplicitPArr _ elems)
= mkPmExprData (parrFakeCon (length elems)) (map lhsExprToPmExpr elems)
......@@ -272,16 +272,15 @@ hsExprToPmExpr (ExplicitPArr _elem_ty elems)
-- con <- dsLookupDataCon (unLoc c)
-- args <- mapM lhsExprToPmExpr (hsRecFieldsArgs binds)
-- return (PmExprCon con args)
hsExprToPmExpr e@(RecordCon _ _ _ _) = PmExprOther e
hsExprToPmExpr (HsTick _ e) = lhsExprToPmExpr e
hsExprToPmExpr (HsBinTick _ _ e) = lhsExprToPmExpr e
hsExprToPmExpr (HsTickPragma _ _ _ e) = lhsExprToPmExpr e
hsExprToPmExpr (HsSCC _ _ e) = lhsExprToPmExpr e
hsExprToPmExpr (HsCoreAnn _ _ e) = lhsExprToPmExpr e
hsExprToPmExpr (ExprWithTySig e _) = lhsExprToPmExpr e
hsExprToPmExpr (ExprWithTySigOut e _) = lhsExprToPmExpr e
hsExprToPmExpr (HsWrap _ e) = hsExprToPmExpr e
hsExprToPmExpr e@(RecordCon {}) = PmExprOther e
hsExprToPmExpr (HsTick _ _ e) = lhsExprToPmExpr e
hsExprToPmExpr (HsBinTick _ _ _ e) = lhsExprToPmExpr e
hsExprToPmExpr (HsTickPragma _ _ _ _ e) = lhsExprToPmExpr e
hsExprToPmExpr (HsSCC _ _ _ e) = lhsExprToPmExpr e
hsExprToPmExpr (HsCoreAnn _ _ _ e) = lhsExprToPmExpr e
hsExprToPmExpr (ExprWithTySig _ e) = lhsExprToPmExpr e
hsExprToPmExpr (HsWrap _ _ e) = hsExprToPmExpr e
hsExprToPmExpr e = PmExprOther e -- the rest are not handled by the oracle
synExprToPmExpr :: SyntaxExpr GhcTc -> PmExpr
......
compiler/hsSyn/Convert.hs
View file @ e3ec2e7a
......@@ -774,77 +774,87 @@ cvtClause ctxt (Clause ps body wheres)
cvtl :: TH.Exp -> CvtM (LHsExpr GhcPs)
cvtl e = wrapL (cvt e)
where
cvt (VarE s) = do { s' <- vName s; return $ HsVar (noLoc s') }
cvt (ConE s) = do { s' <- cName s; return $ HsVar (noLoc s') }
cvt (VarE s) = do { s' <- vName s; return $ HsVar noExt (noLoc s') }
cvt (ConE s) = do { s' <- cName s; return $ HsVar noExt (noLoc s') }
cvt (LitE l)
| overloadedLit l = do { l' <- cvtOverLit l; return $ HsOverLit l' }
| otherwise = do { l' <- cvtLit l; return $ HsLit l' }
| overloadedLit l = do { l' <- cvtOverLit l; return $ HsOverLit noExt l' }
| otherwise = do { l' <- cvtLit l; return $ HsLit noExt l' }
cvt (AppE x@(LamE _ _) y) = do { x' <- cvtl x; y' <- cvtl y
; return $ HsApp (mkLHsPar x') (mkLHsPar y')}
; return $ HsApp noExt (mkLHsPar x')
(mkLHsPar y')}
cvt (AppE x y) = do { x' <- cvtl x; y' <- cvtl y
; return $ HsApp (mkLHsPar x') (mkLHsPar y')}
; return $ HsApp noExt (mkLHsPar x')
(mkLHsPar y')}
cvt (AppTypeE e t) = do { e' <- cvtl e
; t' <- cvtType t
; tp <- wrap_apps t'
; return $ HsAppType e' $ mkHsWildCardBndrs tp }
; return $ HsAppType (mkHsWildCardBndrs tp) e' }
cvt (LamE [] e) = cvt e -- Degenerate case. We convert the body as its
-- own expression to avoid pretty-printing
-- oddities that can result from zero-argument
-- lambda expressions. See #13856.
cvt (LamE ps e) = do { ps' <- cvtPats ps; e' <- cvtl e
; return $ HsLam (mkMatchGroup FromSource
; return $ HsLam noExt (mkMatchGroup FromSource
[mkSimpleMatch LambdaExpr ps' e'])}
cvt (LamCaseE ms) = do { ms' <- mapM (cvtMatch LambdaExpr) ms
; return $ HsLamCase (mkMatchGroup FromSource ms')
; return $ HsLamCase noExt
(mkMatchGroup FromSource ms')
}
cvt (TupE [e]) = do { e' <- cvtl e; return $ HsPar e' }
cvt (TupE [e]) = do { e' <- cvtl e; return $ HsPar noExt e' }
-- Note [Dropping constructors]
-- Singleton tuples treated like nothing (just parens)
cvt (TupE es) = do { es' <- mapM cvtl es
; return $ ExplicitTuple (map (noLoc . Present) es')
Boxed }
; return $ ExplicitTuple noExt
(map (noLoc . Present) es') Boxed }
cvt (UnboxedTupE es) = do { es' <- mapM cvtl es
; return $ ExplicitTuple
; return $ ExplicitTuple noExt
(map (noLoc . Present) es') Unboxed }
cvt (UnboxedSumE e alt arity) = do { e' <- cvtl e
; unboxedSumChecks alt arity
; return $ ExplicitSum
alt arity e' placeHolderType }
; return $ ExplicitSum noExt
alt arity e'}
cvt (CondE x y z) = do { x' <- cvtl x; y' <- cvtl y; z' <- cvtl z;
; return $ HsIf (Just noSyntaxExpr) x' y' z' }
; return $ HsIf noExt (Just noSyntaxExpr) x' y' z' }
cvt (MultiIfE alts)
| null alts = failWith (text "Multi-way if-expression with no alternatives")
| otherwise = do { alts' <- mapM cvtpair alts
; return $ HsMultiIf placeHolderType alts' }
; return $ HsMultiIf noExt alts' }
cvt (LetE ds e) = do { ds' <- cvtLocalDecs (text "a let expression") ds
; e' <- cvtl e; return $ HsLet (noLoc ds') e' }
; e' <- cvtl e; return $ HsLet noExt (noLoc ds') e'}
cvt (CaseE e ms) = do { e' <- cvtl e; ms' <- mapM (cvtMatch CaseAlt) ms
; return $ HsCase e' (mkMatchGroup FromSource ms') }
; return $ HsCase noExt e'
(mkMatchGroup FromSource ms') }
cvt (DoE ss) = cvtHsDo DoExpr ss
cvt (CompE ss) = cvtHsDo ListComp ss
cvt (ArithSeqE dd) = do { dd' <- cvtDD dd; return $ ArithSeq noPostTcExpr Nothing dd' }
cvt (ArithSeqE dd) = do { dd' <- cvtDD dd
; return $ ArithSeq noExt Nothing dd' }
cvt (ListE xs)
| Just s <- allCharLs xs = do { l' <- cvtLit (StringL s); return (HsLit l') }
| Just s <- allCharLs xs = do { l' <- cvtLit (StringL s)
; return (HsLit noExt l') }
-- Note [Converting strings]
| otherwise = do { xs' <- mapM cvtl xs
; return $ ExplicitList placeHolderType Nothing xs'
; return $ ExplicitList noExt Nothing xs'
}
-- Infix expressions
cvt (InfixE (Just x) s (Just y)) = do { x' <- cvtl x; s' <- cvtl s; y' <- cvtl y
; wrapParL HsPar $
OpApp (mkLHsPar x') s' undefined (mkLHsPar y') }
; wrapParL (HsPar noExt) $
OpApp noExt (mkLHsPar x') s'
(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
; wrapParL HsPar $ SectionR s' y' }
; wrapParL (HsPar noExt)
$ SectionR noExt s' y' }
-- See Note [Sections in HsSyn] in HsExpr
cvt (InfixE (Just x) s Nothing ) = do { x' <- cvtl x; s' <- cvtl s
; wrapParL HsPar $ SectionL x' s' }
; wrapParL (HsPar noExt)
$ SectionL noExt x' s' }
cvt (InfixE Nothing s Nothing ) = do { s' <- cvtl s; return $ HsPar s' }
cvt (InfixE Nothing s Nothing ) = do { s' <- cvtl s
; return $ HsPar noExt s' }
-- Can I indicate this is an infix thing?
-- Note [Dropping constructors]
......@@ -854,9 +864,9 @@ cvtl e = wrapL (cvt e)
_ -> mkLHsPar x'
; cvtOpApp x'' s y } -- Note [Converting UInfix]
cvt (ParensE e) = do { e' <- cvtl e; return $ HsPar e' }
cvt (ParensE e) = do { e' <- cvtl e; return $ HsPar noExt e' }
cvt (SigE e t) = do { e' <- cvtl e; t' <- cvtType t
; return $ ExprWithTySig e' (mkLHsSigWcType t') }
; return $ ExprWithTySig (mkLHsSigWcType t') e' }
cvt (RecConE c flds) = do { c' <- cNameL c
; flds' <- mapM (cvtFld (mkFieldOcc . noLoc)) flds
; return $ mkRdrRecordCon c' (HsRecFields flds' Nothing) }
......@@ -865,9 +875,9 @@ cvtl e = wrapL (cvt e)
<- mapM (cvtFld (mkAmbiguousFieldOcc . noLoc))
flds
; return $ mkRdrRecordUpd e' flds' }
cvt (StaticE e) = fmap (HsStatic placeHolderNames) $ cvtl e
cvt (UnboundVarE s) = do { s' <- vName s; return $ HsVar (noLoc s') }
cvt (LabelE s) = do { return $ HsOverLabel Nothing (fsLit s) }
cvt (StaticE e) = fmap (HsStatic noExt) $ cvtl e
cvt (UnboundVarE s) = do { s' <- vName s; return $ HsVar noExt (noLoc s') }
cvt (LabelE s) = do { return $ HsOverLabel noExt Nothing (fsLit s) }
{- Note [Dropping constructors]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
......@@ -958,7 +968,7 @@ cvtOpApp x op1 (UInfixE y op2 z)
cvtOpApp x op y
= do { op' <- cvtl op
; y' <- cvtl y
; return (OpApp x op' undefined y') }
; return (OpApp noExt x op' y') }
-------------------------------------
-- Do notation and statements
......@@ -975,7 +985,7 @@ cvtHsDo do_or_lc stmts
L loc (BodyStmt body _ _ _) -> return (L loc (mkLastStmt body))
_ -> failWith (bad_last last')
; return $ HsDo do_or_lc (noLoc (stmts'' ++ [last''])) placeHolderType }
; return $ HsDo noExt do_or_lc (noLoc (stmts'' ++ [last''])) }
where
bad_last stmt = vcat [ text "Illegal last statement of" <+> pprAStmtContext do_or_lc <> colon
, nest 2 $ Outputable.ppr stmt
......
compiler/hsSyn/HsExpr.hs
View file @ e3ec2e7a
This diff is collapsed.
compiler/hsSyn/HsExtension.hs
View file @ e3ec2e7a
......@@ -154,9 +154,6 @@ type ForallXValBindsLR (c :: * -> Constraint) (x :: *) (x' :: *)=
, c (XXValBindsLR x x')
)
-- We define a type family for each HsLit extension point. This is based on
-- prepending 'X' to the constructor name, for ease of reference.
type family XHsChar x
......@@ -306,6 +303,112 @@ type ForallXAmbiguousFieldOcc (c :: * -> Constraint) (x :: *) =
)
-- ---------------------------------------------------------------------
-- Type families for the HsExpr type families
type family XVar x
type family XUnboundVar x
type family XConLikeOut x
type family XRecFld x
type family XOverLabel x
type family XIPVar x
type family XOverLitE x
type family XLitE x
type family XLam x
type family XLamCase x
type family XApp x
type family XAppTypeE x
type family XOpApp x
type family XNegApp x
type family XPar x
type family XSectionL x
type family XSectionR x
type family XExplicitTuple x
type family XExplicitSum x
type family XCase x
type family XIf x
type family XMultiIf x
type family XLet x
type family XDo x
type family XExplicitList x
type family XExplicitPArr x
type family XRecordCon x
type family XRecordUpd x
type family XExprWithTySig x
type family XArithSeq x
type family XPArrSeq x
type family XSCC x
type family XCoreAnn x
type family XBracket x
type family XRnBracketOut x
type family XTcBracketOut x
type family XSpliceE x
type family XProc x
type family XStatic x
type family XArrApp x
type family XArrForm x
type family XTick x
type family XBinTick x
type family XTickPragma x
type family XEWildPat x
type family XEAsPat x
type family XEViewPat x
type family XELazyPat x
type family XWrap x
type family XXExpr x
type ForallXExpr (c :: * -> Constraint) (x :: *) =
( c (XVar x)
, c (XUnboundVar x)
, c (XConLikeOut x)
, c (XRecFld x)
, c (XOverLabel x)
, c (XIPVar x)
, c (XOverLitE x)
, c (XLitE x)
, c (XLam x)
, c (XLamCase x)
, c (XApp x)
, c (XAppTypeE x)
, c (XOpApp x)
, c (XNegApp x)
, c (XPar x)
, c (XSectionL x)
, c (XSectionR x)
, c (XExplicitTuple x)
, c (XExplicitSum x)
, c (XCase x)
, c (XIf x)
, c (XMultiIf x)
, c (XLet x)
, c (XDo x)
, c (XExplicitList x)
, c (XExplicitPArr x)
, c (XRecordCon x)
, c (XRecordUpd x)
, c (XExprWithTySig x)
, c (XArithSeq x)
, c (XPArrSeq x)
, c (XSCC x)
, c (XCoreAnn x)
, c (XBracket x)
, c (XRnBracketOut x)
, c (XTcBracketOut x)
, c (XSpliceE x)
, c (XProc x)
, c (XStatic x)
, c (XArrApp x)
, c (XArrForm x)
, c (XTick x)
, c (XBinTick x)
, c (XTickPragma x)
, c (XEWildPat x)
, c (XEAsPat x)
, c (XEViewPat x)
, c (XELazyPat x)
, c (XWrap x)
, c (XXExpr x)
)
-- ---------------------------------------------------------------------
-- | The 'SourceText' fields have been moved into the extension fields, thus
-- placing a requirement in the extension field to contain a 'SourceText' so
......@@ -383,11 +486,21 @@ type ConvertIdX a b =
type OutputableX p =