Commit fb54b2c1 authored by Alan Zimmerman's avatar Alan Zimmerman Committed by Austin Seipp

API Annotations : add Locations in hsSyn were layout occurs

At the moment ghc-exactprint, which uses the GHC API Annotations to
provide a framework for roundtripping Haskell source code with optional
AST edits, has to implement a horrible workaround to manage the points
where layout needs to be captured.

These are

    MatchGroup
    HsDo
    HsCmdDo
    HsLet
    LetStmt
    HsCmdLet
    GRHSs

To provide a more natural representation, the contents subject to layout
rules need to be wrapped in a SrcSpan.

This commit does this.

Trac ticket #10250

Reviewed By: austin

Differential Revision: https://phabricator.haskell.org/D815

GHC Trac Issues: #10250
parent fa0474da
......@@ -509,14 +509,14 @@ addTickHsExpr (HsMultiIf ty alts)
= do { let isOneOfMany = case alts of [_] -> False; _ -> True
; alts' <- mapM (liftL $ addTickGRHS isOneOfMany False) alts
; return $ HsMultiIf ty alts' }
addTickHsExpr (HsLet binds e) =
bindLocals (collectLocalBinders binds) $
liftM2 HsLet
(addTickHsLocalBinds binds) -- to think about: !patterns.
(addTickLHsExprLetBody e)
addTickHsExpr (HsDo cxt stmts srcloc)
addTickHsExpr (HsLet (L l binds) e) =
bindLocals (collectLocalBinders binds) $ do
binds' <- addTickHsLocalBinds binds -- to think about: !patterns.
e' <- addTickLHsExprLetBody e
return $ HsLet (L l binds') e'
addTickHsExpr (HsDo cxt (L l stmts) srcloc)
= do { (stmts', _) <- addTickLStmts' forQual stmts (return ())
; return (HsDo cxt stmts' srcloc) }
; return (HsDo cxt (L l stmts') srcloc) }
where
forQual = case cxt of
ListComp -> Just $ BinBox QualBinBox
......@@ -610,10 +610,10 @@ addTickTupArg (L l (Present e)) = do { e' <- addTickLHsExpr e
addTickTupArg (L l (Missing ty)) = return (L l (Missing ty))
addTickMatchGroup :: Bool{-is lambda-} -> MatchGroup Id (LHsExpr Id) -> TM (MatchGroup Id (LHsExpr Id))
addTickMatchGroup is_lam mg@(MG { mg_alts = matches }) = do
addTickMatchGroup is_lam mg@(MG { mg_alts = L l matches }) = do
let isOneOfMany = matchesOneOfMany matches
matches' <- mapM (liftL (addTickMatch isOneOfMany is_lam)) matches
return $ mg { mg_alts = matches' }
return $ mg { mg_alts = L l matches' }
addTickMatch :: Bool -> Bool -> Match Id (LHsExpr Id) -> TM (Match Id (LHsExpr Id))
addTickMatch isOneOfMany isLambda (Match mf pats opSig gRHSs) =
......@@ -622,11 +622,11 @@ addTickMatch isOneOfMany isLambda (Match mf pats opSig gRHSs) =
return $ Match mf pats opSig gRHSs'
addTickGRHSs :: Bool -> Bool -> GRHSs Id (LHsExpr Id) -> TM (GRHSs Id (LHsExpr Id))
addTickGRHSs isOneOfMany isLambda (GRHSs guarded local_binds) = do
addTickGRHSs isOneOfMany isLambda (GRHSs guarded (L l local_binds)) = do
bindLocals binders $ do
local_binds' <- addTickHsLocalBinds local_binds
guarded' <- mapM (liftL (addTickGRHS isOneOfMany isLambda)) guarded
return $ GRHSs guarded' local_binds'
return $ GRHSs guarded' (L l local_binds')
where
binders = collectLocalBinders local_binds
......@@ -678,9 +678,9 @@ addTickStmt isGuard (BodyStmt e bind' guard' ty) = do
(addTickSyntaxExpr hpcSrcSpan bind')
(addTickSyntaxExpr hpcSrcSpan guard')
(return ty)
addTickStmt _isGuard (LetStmt binds) = do
liftM LetStmt
(addTickHsLocalBinds binds)
addTickStmt _isGuard (LetStmt (L l binds)) = do
binds' <- addTickHsLocalBinds binds
return $ LetStmt (L l binds')
addTickStmt isGuard (ParStmt pairs mzipExpr bindExpr) = do
liftM3 ParStmt
(mapM (addTickStmtAndBinders isGuard) pairs)
......@@ -797,14 +797,14 @@ addTickHsCmd (HsCmdIf cnd e1 c2 c3) =
(addBinTickLHsExpr (BinBox CondBinBox) e1)
(addTickLHsCmd c2)
(addTickLHsCmd c3)
addTickHsCmd (HsCmdLet binds c) =
bindLocals (collectLocalBinders binds) $
liftM2 HsCmdLet
(addTickHsLocalBinds binds) -- to think about: !patterns.
(addTickLHsCmd c)
addTickHsCmd (HsCmdDo stmts srcloc)
addTickHsCmd (HsCmdLet (L l binds) c) =
bindLocals (collectLocalBinders binds) $ do
binds' <- addTickHsLocalBinds binds -- to think about: !patterns.
c' <- addTickLHsCmd c
return $ HsCmdLet (L l binds') c'
addTickHsCmd (HsCmdDo (L l stmts) srcloc)
= do { (stmts', _) <- addTickLCmdStmts' stmts (return ())
; return (HsCmdDo stmts' srcloc) }
; return (HsCmdDo (L l stmts') srcloc) }
addTickHsCmd (HsCmdArrApp e1 e2 ty1 arr_ty lr) =
liftM5 HsCmdArrApp
......@@ -826,9 +826,9 @@ addTickHsCmd (HsCmdCast co cmd)
--addTickHsCmd e = pprPanic "addTickHsCmd" (ppr e)
addTickCmdMatchGroup :: MatchGroup Id (LHsCmd Id) -> TM (MatchGroup Id (LHsCmd Id))
addTickCmdMatchGroup mg@(MG { mg_alts = matches }) = do
addTickCmdMatchGroup mg@(MG { mg_alts = L l matches }) = do
matches' <- mapM (liftL addTickCmdMatch) matches
return $ mg { mg_alts = matches' }
return $ mg { mg_alts = L l matches' }
addTickCmdMatch :: Match Id (LHsCmd Id) -> TM (Match Id (LHsCmd Id))
addTickCmdMatch (Match mf pats opSig gRHSs) =
......@@ -837,11 +837,11 @@ addTickCmdMatch (Match mf pats opSig gRHSs) =
return $ Match mf pats opSig gRHSs'
addTickCmdGRHSs :: GRHSs Id (LHsCmd Id) -> TM (GRHSs Id (LHsCmd Id))
addTickCmdGRHSs (GRHSs guarded local_binds) = do
addTickCmdGRHSs (GRHSs guarded (L l local_binds)) = do
bindLocals binders $ do
local_binds' <- addTickHsLocalBinds local_binds
guarded' <- mapM (liftL addTickCmdGRHS) guarded
return $ GRHSs guarded' local_binds'
return $ GRHSs guarded' (L l local_binds')
where
binders = collectLocalBinders local_binds
......@@ -884,9 +884,9 @@ addTickCmdStmt (BodyStmt c bind' guard' ty) = do
(addTickSyntaxExpr hpcSrcSpan bind')
(addTickSyntaxExpr hpcSrcSpan guard')
(return ty)
addTickCmdStmt (LetStmt binds) = do
liftM LetStmt
(addTickHsLocalBinds binds)
addTickCmdStmt (LetStmt (L l binds)) = do
binds' <- addTickHsLocalBinds binds
return $ LetStmt (L l binds')
addTickCmdStmt stmt@(RecStmt {})
= do { stmts' <- addTickLCmdStmts (recS_stmts stmt)
; ret' <- addTickSyntaxExpr hpcSrcSpan (recS_ret_fn stmt)
......
......@@ -399,8 +399,8 @@ dsCmd ids local_vars stack_ty res_ty (HsCmdApp cmd arg) env_ids = do
-- ---> premap (\ ((xs), (p1, ... (pk,stk)...)) -> ((ys),stk)) cmd
dsCmd ids local_vars stack_ty res_ty
(HsCmdLam (MG { mg_alts = [L _ (Match _ pats _
(GRHSs [L _ (GRHS [] body)] _ ))] }))
(HsCmdLam (MG { mg_alts = L _ [L _ (Match _ pats _
(GRHSs [L _ (GRHS [] body)] _ ))] }))
env_ids = do
let
pat_vars = mkVarSet (collectPatsBinders pats)
......@@ -504,7 +504,8 @@ case bodies, containing the following fields:
-}
dsCmd ids local_vars stack_ty res_ty
(HsCmdCase exp (MG { mg_alts = matches, mg_arg_tys = arg_tys, mg_origin = origin }))
(HsCmdCase exp (MG { mg_alts = L l matches, mg_arg_tys = arg_tys
, mg_origin = origin }))
env_ids = do
stack_id <- newSysLocalDs stack_ty
......@@ -547,7 +548,8 @@ 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 = matches', mg_arg_tys = arg_tys
core_body <- dsExpr (HsCase 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'
......@@ -562,7 +564,7 @@ dsCmd ids local_vars stack_ty res_ty
--
-- ---> premap (\ ((xs),stk) -> let binds in ((ys),stk)) c
dsCmd ids local_vars stack_ty res_ty (HsCmdLet binds body) env_ids = do
dsCmd ids local_vars stack_ty res_ty (HsCmdLet (L _ binds) body) env_ids = do
let
defined_vars = mkVarSet (collectLocalBinders binds)
local_vars' = defined_vars `unionVarSet` local_vars
......@@ -587,7 +589,7 @@ dsCmd ids local_vars stack_ty res_ty (HsCmdLet binds body) env_ids = do
--
-- ---> premap (\ (env,stk) -> env) c
dsCmd ids local_vars stack_ty res_ty (HsCmdDo stmts _) env_ids = do
dsCmd ids local_vars stack_ty res_ty (HsCmdDo (L _ stmts) _) env_ids = do
(core_stmts, env_ids') <- dsCmdDo ids local_vars res_ty stmts env_ids
let env_ty = mkBigCoreVarTupTy env_ids
core_fst <- mkFstExpr env_ty stack_ty
......@@ -832,7 +834,7 @@ dsCmdStmt ids local_vars out_ids (BindStmt pat cmd _ _) env_ids = do
--
-- ---> arr (\ (xs) -> let binds in (xs')) >>> ss
dsCmdStmt ids local_vars out_ids (LetStmt binds) env_ids = do
dsCmdStmt ids local_vars out_ids (LetStmt (L _ binds)) env_ids = do
-- build a new environment using the let bindings
core_binds <- dsLocalBinds binds (mkBigCoreVarTup out_ids)
-- match the old environment against the input
......@@ -1047,7 +1049,7 @@ matchSimplys _ _ _ _ _ = panic "matchSimplys"
-- List of leaf expressions, with set of variables bound in each
leavesMatch :: LMatch Id (Located (body Id)) -> [(Located (body Id), IdSet)]
leavesMatch (L _ (Match _ pats _ (GRHSs grhss binds)))
leavesMatch (L _ (Match _ pats _ (GRHSs grhss (L _ binds))))
= let
defined_vars = mkVarSet (collectPatsBinders pats)
`unionVarSet`
......@@ -1167,11 +1169,11 @@ collectLStmtBinders :: LStmt Id body -> [Id]
collectLStmtBinders = collectStmtBinders . unLoc
collectStmtBinders :: Stmt Id body -> [Id]
collectStmtBinders (BindStmt pat _ _ _) = collectPatBinders pat
collectStmtBinders (LetStmt binds) = collectLocalBinders binds
collectStmtBinders (BodyStmt {}) = []
collectStmtBinders (LastStmt {}) = []
collectStmtBinders (ParStmt xs _ _) = collectLStmtsBinders
$ [ s | ParStmtBlock ss _ _ <- xs, s <- ss]
collectStmtBinders (BindStmt pat _ _ _) = collectPatBinders pat
collectStmtBinders (LetStmt (L _ binds)) = collectLocalBinders binds
collectStmtBinders (BodyStmt {}) = []
collectStmtBinders (LastStmt {}) = []
collectStmtBinders (ParStmt xs _ _) = collectLStmtsBinders
$ [ s | ParStmtBlock ss _ _ <- xs, s <- ss]
collectStmtBinders (TransStmt { trS_stmts = stmts }) = collectLStmtsBinders stmts
collectStmtBinders (RecStmt { recS_later_ids = later_ids }) = later_ids
......@@ -321,19 +321,19 @@ dsExpr (HsCase discrim matches)
-- Pepe: The binds are in scope in the body but NOT in the binding group
-- This is to avoid silliness in breakpoints
dsExpr (HsLet binds body) = do
dsExpr (HsLet (L _ binds) body) = do
body' <- dsLExpr body
dsLocalBinds binds body'
-- We need the `ListComp' form to use `deListComp' (rather than the "do" form)
-- because the interpretation of `stmts' depends on what sort of thing it is.
--
dsExpr (HsDo ListComp stmts res_ty) = dsListComp stmts res_ty
dsExpr (HsDo PArrComp stmts _) = dsPArrComp (map unLoc stmts)
dsExpr (HsDo DoExpr stmts _) = dsDo stmts
dsExpr (HsDo GhciStmtCtxt stmts _) = dsDo stmts
dsExpr (HsDo MDoExpr stmts _) = dsDo stmts
dsExpr (HsDo MonadComp stmts _) = dsMonadComp stmts
dsExpr (HsDo ListComp (L _ stmts) res_ty) = dsListComp stmts res_ty
dsExpr (HsDo PArrComp (L _ stmts) _) = dsPArrComp (map unLoc stmts)
dsExpr (HsDo DoExpr (L _ stmts) _) = dsDo stmts
dsExpr (HsDo GhciStmtCtxt (L _ stmts) _) = dsDo stmts
dsExpr (HsDo MDoExpr (L _ stmts) _) = dsDo stmts
dsExpr (HsDo MonadComp (L _ stmts) _) = dsMonadComp stmts
dsExpr (HsIf mb_fun guard_expr then_expr else_expr)
= do { pred <- dsLExpr guard_expr
......@@ -571,7 +571,8 @@ dsExpr expr@(RecordUpd record_expr (HsRecFields { rec_flds = fields })
-- constructor aguments.
; alts <- mapM (mk_alt upd_fld_env) cons_to_upd
; ([discrim_var], matching_code)
<- matchWrapper RecUpd (MG { mg_alts = alts, mg_arg_tys = [in_ty]
<- matchWrapper RecUpd (MG { mg_alts = noLoc alts
, mg_arg_tys = [in_ty]
, mg_res_ty = out_ty, mg_origin = FromSource })
-- FromSource is not strictly right, but we
-- want incomplete pattern-match warnings
......@@ -839,7 +840,7 @@ dsDo stmts
; rest <- goL stmts
; return (mkApps then_expr2 [rhs2, rest]) }
go _ (LetStmt binds) stmts
go _ (LetStmt (L _ binds)) stmts
= do { rest <- goL stmts
; dsLocalBinds binds rest }
......@@ -871,11 +872,12 @@ dsDo stmts
later_pats = rec_tup_pats
rets = map noLoc rec_rets
mfix_app = nlHsApp (noLoc mfix_op) mfix_arg
mfix_arg = noLoc $ HsLam (MG { mg_alts = [mkSimpleMatch [mfix_pat] body]
, mg_arg_tys = [tup_ty], mg_res_ty = body_ty
, mg_origin = Generated })
mfix_arg = noLoc
$ HsLam (MG { mg_alts = noLoc [mkSimpleMatch [mfix_pat] body]
, mg_arg_tys = [tup_ty], mg_res_ty = body_ty
, mg_origin = Generated })
mfix_pat = noLoc $ LazyPat $ mkBigLHsPatTup rec_tup_pats
body = noLoc $ HsDo DoExpr (rec_stmts ++ [ret_stmt]) body_ty
body = noLoc $ HsDo DoExpr (noLoc (rec_stmts ++ [ret_stmt])) body_ty
ret_app = nlHsApp (noLoc return_op) (mkBigLHsTup rets)
ret_stmt = noLoc $ mkLastStmt ret_app
-- This LastStmt will be desugared with dsDo,
......
......@@ -57,7 +57,7 @@ dsGRHSs :: HsMatchContext Name -> [Pat Id] -- These are to build a MatchCon
-> GRHSs Id (LHsExpr Id) -- Guarded RHSs
-> Type -- Type of RHS
-> DsM MatchResult
dsGRHSs hs_ctx _ (GRHSs grhss binds) rhs_ty
dsGRHSs hs_ctx _ (GRHSs grhss (L _ binds)) rhs_ty
= ASSERT( notNull grhss )
do { match_results <- mapM (dsGRHS hs_ctx rhs_ty) grhss
; let match_result1 = foldr1 combineMatchResults match_results
......@@ -106,7 +106,7 @@ matchGuards (BodyStmt expr _ _ _ : stmts) ctx rhs rhs_ty = do
pred_expr <- dsLExpr expr
return (mkGuardedMatchResult pred_expr match_result)
matchGuards (LetStmt binds : stmts) ctx rhs rhs_ty = do
matchGuards (LetStmt (L _ binds) : stmts) ctx rhs rhs_ty = do
match_result <- matchGuards stmts ctx rhs rhs_ty
return (adjustMatchResultDs (dsLocalBinds binds) match_result)
-- NB the dsLet occurs inside the match_result
......
......@@ -221,7 +221,7 @@ deListComp (BodyStmt guard _ _ _ : quals) list = do -- rule B above
return (mkIfThenElse core_guard core_rest list)
-- [e | let B, qs] = let B in [e | qs]
deListComp (LetStmt binds : quals) list = do
deListComp (LetStmt (L _ binds) : quals) list = do
core_rest <- deListComp quals list
dsLocalBinds binds core_rest
......@@ -323,7 +323,7 @@ dfListComp c_id n_id (BodyStmt guard _ _ _ : quals) = do
core_rest <- dfListComp c_id n_id quals
return (mkIfThenElse core_guard core_rest (Var n_id))
dfListComp c_id n_id (LetStmt binds : quals) = do
dfListComp c_id n_id (LetStmt (L _ binds) : quals) = do
-- new in 1.3, local bindings
core_rest <- dfListComp c_id n_id quals
dsLocalBinds binds core_rest
......@@ -563,7 +563,7 @@ dePArrComp (BindStmt p e _ _ : qs) pa cea = do
-- where
-- {x_1, ..., x_n} = DV (ds) -- Defined Variables
--
dePArrComp (LetStmt ds : qs) pa cea = do
dePArrComp (LetStmt (L _ ds) : qs) pa cea = do
mapP <- dsDPHBuiltin mapPVar
let xs = collectLocalBinders ds
ty'cea = parrElemType cea
......@@ -673,7 +673,7 @@ dsMcStmt (LastStmt body ret_op) stmts
; return (App ret_op' body') }
-- [ .. | let binds, stmts ]
dsMcStmt (LetStmt binds) stmts
dsMcStmt (LetStmt (L _ binds)) stmts
= do { rest <- dsMcStmts stmts
; dsLocalBinds binds rest }
......
......@@ -1013,8 +1013,8 @@ repE e@(HsIPVar _) = notHandled "Implicit parameters" (ppr e)
-- 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 = [m] })) = repLambda m
repE (HsLamCase _ (MG { mg_alts = ms }))
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 }
......@@ -1032,7 +1032,7 @@ repE (NegApp x _) = do
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 = ms }))
repE (HsCase e (MG { mg_alts = L _ ms }))
= do { arg <- repLE e
; ms2 <- mapM repMatchTup ms
; core_ms2 <- coreList matchQTyConName ms2
......@@ -1046,13 +1046,13 @@ repE (HsMultiIf _ alts)
= do { (binds, alts') <- liftM unzip $ mapM repLGRHS alts
; expr' <- repMultiIf (nonEmptyCoreList alts')
; wrapGenSyms (concat binds) expr' }
repE (HsLet bs e) = do { (ss,ds) <- repBinds bs
; e2 <- addBinds ss (repLE e)
; z <- repLetE ds e2
; wrapGenSyms ss z }
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 sts _)
repE e@(HsDo ctxt (L _ sts) _)
| case ctxt of { DoExpr -> True; GhciStmtCtxt -> True; _ -> False }
= do { (ss,zs) <- repLSts sts;
e' <- repDoE (nonEmptyCoreList zs);
......@@ -1114,7 +1114,7 @@ repE e = notHandled "Expression form" (ppr e)
-- Building representations of auxillary structures like Match, Clause, Stmt,
repMatchTup :: LMatch Name (LHsExpr Name) -> DsM (Core TH.MatchQ)
repMatchTup (L _ (Match _ [p] _ (GRHSs guards wheres))) =
repMatchTup (L _ (Match _ [p] _ (GRHSs guards (L _ wheres)))) =
do { ss1 <- mkGenSyms (collectPatBinders p)
; addBinds ss1 $ do {
; p1 <- repLP p
......@@ -1126,7 +1126,7 @@ repMatchTup (L _ (Match _ [p] _ (GRHSs guards wheres))) =
repMatchTup _ = panic "repMatchTup: case alt with more than one arg"
repClauseTup :: LMatch Name (LHsExpr Name) -> DsM (Core TH.ClauseQ)
repClauseTup (L _ (Match _ ps _ (GRHSs guards wheres))) =
repClauseTup (L _ (Match _ ps _ (GRHSs guards (L _ wheres)))) =
do { ss1 <- mkGenSyms (collectPatsBinders ps)
; addBinds ss1 $ do {
ps1 <- repLPs ps
......@@ -1201,7 +1201,7 @@ repSts (BindStmt p e _ _ : ss) =
; (ss2,zs) <- repSts ss
; z <- repBindSt p1 e2
; return (ss1++ss2, z : zs) }}
repSts (LetStmt bs : ss) =
repSts (LetStmt (L _ bs) : ss) =
do { (ss1,ds) <- repBinds bs
; z <- repLetSt ds
; (ss2,zs) <- addBinds ss1 (repSts ss)
......@@ -1280,8 +1280,9 @@ rep_bind :: LHsBind Name -> DsM (SrcSpan, Core TH.DecQ)
-- with an empty list of patterns
rep_bind (L loc (FunBind
{ fun_id = fn,
fun_matches = MG { mg_alts = [L _ (Match _ [] _
(GRHSs guards wheres))] } }))
fun_matches = MG { mg_alts
= L _ [L _ (Match _ [] _
(GRHSs guards (L _ wheres)))] } }))
= do { (ss,wherecore) <- repBinds wheres
; guardcore <- addBinds ss (repGuards guards)
; fn' <- lookupLBinder fn
......@@ -1290,13 +1291,15 @@ rep_bind (L loc (FunBind
; ans' <- wrapGenSyms ss ans
; return (loc, ans') }
rep_bind (L loc (FunBind { fun_id = fn, fun_matches = MG { mg_alts = ms } }))
rep_bind (L loc (FunBind { fun_id = fn
, fun_matches = MG { mg_alts = L _ ms } }))
= do { ms1 <- mapM repClauseTup ms
; fn' <- lookupLBinder fn
; ans <- repFun fn' (nonEmptyCoreList ms1)
; return (loc, ans) }
rep_bind (L loc (PatBind { pat_lhs = pat, pat_rhs = GRHSs guards wheres }))
rep_bind (L loc (PatBind { pat_lhs = pat
, pat_rhs = GRHSs guards (L _ wheres) }))
= do { patcore <- repLP pat
; (ss,wherecore) <- repBinds wheres
; guardcore <- addBinds ss (repGuards guards)
......@@ -1340,7 +1343,7 @@ rep_bind (L _ dec@(PatSynBind {})) = notHandled "pattern synonyms" (ppr dec)
-- (\ p1 .. pn -> exp) by causing an error.
repLambda :: LMatch Name (LHsExpr Name) -> DsM (Core TH.ExpQ)
repLambda (L _ (Match _ ps _ (GRHSs [L _ (GRHS [] e)] EmptyLocalBinds)))
repLambda (L _ (Match _ ps _ (GRHSs [L _ (GRHS [] e)] (L _ EmptyLocalBinds))))
= do { let bndrs = collectPatsBinders ps ;
; ss <- mkGenSyms bndrs
; lam <- addBinds ss (
......
......@@ -791,7 +791,7 @@ one pattern, and match simply only accepts one pattern.
JJQC 30-Nov-1997
-}
matchWrapper ctxt (MG { mg_alts = matches
matchWrapper ctxt (MG { mg_alts = L _ matches
, mg_arg_tys = arg_tys
, mg_res_ty = rhs_ty
, mg_origin = origin })
......
......@@ -153,7 +153,7 @@ cvtDec (TH.ValD pat body ds)
; body' <- cvtGuard body
; ds' <- cvtLocalDecs (ptext (sLit "a where clause")) ds
; returnJustL $ Hs.ValD $
PatBind { pat_lhs = pat', pat_rhs = GRHSs body' ds'
PatBind { pat_lhs = pat', pat_rhs = GRHSs body' (noLoc ds')
, pat_rhs_ty = placeHolderType, bind_fvs = placeHolderNames
, pat_ticks = ([],[]) } }
......@@ -611,7 +611,7 @@ cvtClause (Clause ps body wheres)
= do { ps' <- cvtPats ps
; g' <- cvtGuard body
; ds' <- cvtLocalDecs (ptext (sLit "a where clause")) wheres
; returnL $ Hs.Match Nothing ps' Nothing (GRHSs g' ds') }
; returnL $ Hs.Match Nothing ps' Nothing (GRHSs g' (noLoc ds')) }
-------------------------------------------------------------------
......@@ -650,7 +650,7 @@ cvtl e = wrapL (cvt e)
| otherwise = do { alts' <- mapM cvtpair alts
; return $ HsMultiIf placeHolderType alts' }
cvt (LetE ds e) = do { ds' <- cvtLocalDecs (ptext (sLit "a let expression")) ds
; e' <- cvtl e; return $ HsLet ds' e' }
; e' <- cvtl e; return $ HsLet (noLoc ds') e' }
cvt (CaseE e ms) = do { e' <- cvtl e; ms' <- mapM cvtMatch ms
; return $ HsCase e' (mkMatchGroup FromSource ms') }
cvt (DoE ss) = cvtHsDo DoExpr ss
......@@ -801,7 +801,7 @@ cvtHsDo do_or_lc stmts
L loc (BodyStmt body _ _ _) -> return (L loc (mkLastStmt body))
_ -> failWith (bad_last last')
; return $ HsDo do_or_lc (stmts'' ++ [last'']) placeHolderType }
; return $ HsDo do_or_lc (noLoc (stmts'' ++ [last''])) placeHolderType }
where
bad_last stmt = vcat [ ptext (sLit "Illegal last statement of") <+> pprAStmtContext do_or_lc <> colon
, nest 2 $ Outputable.ppr stmt
......@@ -814,7 +814,7 @@ cvtStmt :: TH.Stmt -> CvtM (Hs.LStmt RdrName (LHsExpr RdrName))
cvtStmt (NoBindS e) = do { e' <- cvtl e; returnL $ mkBodyStmt e' }
cvtStmt (TH.BindS p e) = do { p' <- cvtPat p; e' <- cvtl e; returnL $ mkBindStmt p' e' }
cvtStmt (TH.LetS ds) = do { ds' <- cvtLocalDecs (ptext (sLit "a let binding")) ds
; returnL $ LetStmt ds' }
; returnL $ LetStmt (noLoc ds') }
cvtStmt (TH.ParS dss) = do { dss' <- mapM cvt_one dss; returnL $ ParStmt dss' noSyntaxExpr noSyntaxExpr }
where
cvt_one ds = do { ds' <- cvtStmts ds; return (ParStmtBlock ds' undefined noSyntaxExpr) }
......@@ -824,7 +824,7 @@ cvtMatch (TH.Match p body decs)
= do { p' <- cvtPat p
; g' <- cvtGuard body
; decs' <- cvtLocalDecs (ptext (sLit "a where clause")) decs
; returnL $ Hs.Match Nothing [p'] Nothing (GRHSs g' decs') }
; returnL $ Hs.Match Nothing [p'] Nothing (GRHSs g' (noLoc decs')) }
cvtGuard :: TH.Body -> CvtM [LGRHS RdrName (LHsExpr RdrName)]
cvtGuard (GuardedB pairs) = mapM cvtpair pairs
......
......@@ -227,7 +227,7 @@ data HsExpr id
-- 'ApiAnnotation.AnnClose' @'}'@,'ApiAnnotation.AnnIn'
-- For details on above see note [Api annotations] in ApiAnnotation
| HsLet (HsLocalBinds id)
| HsLet (Located (HsLocalBinds id))
(LHsExpr id)
-- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnDo',
......@@ -236,11 +236,11 @@ data HsExpr id
-- 'ApiAnnotation.AnnClose'
-- For details on above see note [Api annotations] in ApiAnnotation
| HsDo (HsStmtContext Name) -- The parameterisation is unimportant
-- because in this context we never use
-- the PatGuard or ParStmt variant
[ExprLStmt id] -- "do":one or more stmts
(PostTc id Type) -- Type of the whole expression
| HsDo (HsStmtContext Name) -- The parameterisation is unimportant
-- because in this context we never use
-- the PatGuard or ParStmt variant
(Located [ExprLStmt id]) -- "do":one or more stmts
(PostTc id Type) -- Type of the whole expression
-- | Syntactic list: [a,b,c,...]
--
......@@ -672,15 +672,15 @@ ppr_expr (HsMultiIf _ alts)
, ptext (sLit "->") <+> pprDeeper (ppr expr) ]
-- special case: let ... in let ...
ppr_expr (HsLet binds expr@(L _ (HsLet _ _)))
ppr_expr (HsLet (L _ binds) expr@(L _ (HsLet _ _)))
= sep [hang (ptext (sLit "let")) 2 (hsep [pprBinds binds, ptext (sLit "in")]),
ppr_lexpr expr]
ppr_expr (HsLet binds expr)
ppr_expr (HsLet (L _ binds) expr)
= sep [hang (ptext (sLit "let")) 2 (pprBinds binds),
hang (ptext (sLit "in")) 2 (ppr expr)]
ppr_expr (HsDo do_or_list_comp stmts _) = pprDo do_or_list_comp stmts
ppr_expr (HsDo do_or_list_comp (L _ stmts) _) = pprDo do_or_list_comp stmts
ppr_expr (ExplicitList _ _ exprs)
= brackets (pprDeeperList fsep (punctuate comma (map ppr_lexpr exprs)))
......@@ -898,7 +898,7 @@ data HsCmd id
-- For details on above see note [Api annotations] in ApiAnnotation
| HsCmdLet (HsLocalBinds id) -- let(rec)
| HsCmdLet (Located (HsLocalBinds id)) -- let(rec)
(LHsCmd id)
-- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnLet',
-- 'ApiAnnotation.AnnOpen' @'{'@,
......@@ -906,7 +906,7 @@ data HsCmd id
-- For details on above see note [Api annotations] in ApiAnnotation
| HsCmdDo [CmdLStmt id]
| HsCmdDo (Located [CmdLStmt id])
(PostTc id Type) -- Type of the whole expression
-- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnDo',
-- 'ApiAnnotation.AnnOpen', 'ApiAnnotation.AnnSemi',
......@@ -992,15 +992,15 @@ ppr_cmd (HsCmdIf _ e ct ce)
nest 4 (ppr ce)]
-- special case: let ... in let ...
ppr_cmd (HsCmdLet binds cmd@(L _ (HsCmdLet _ _)))
ppr_cmd (HsCmdLet (L _ binds) cmd@(L _ (HsCmdLet _ _)))
= sep [hang (ptext (sLit "let")) 2 (hsep [pprBinds binds, ptext (sLit "in")]),
ppr_lcmd cmd]
ppr_cmd (HsCmdLet binds cmd)
ppr_cmd (HsCmdLet (L _ binds) cmd)
= sep [hang (ptext (sLit "let")) 2 (pprBinds binds),
hang (ptext (sLit "in")) 2 (ppr cmd)]
ppr_cmd (HsCmdDo stmts _) = pprDo ArrowExpr stmts
ppr_cmd (HsCmdDo (L _ stmts) _) = pprDo ArrowExpr stmts
ppr_cmd (HsCmdCast co cmd) = sep [ ppr_cmd cmd
, ptext (sLit "|>") <+> ppr co ]
......@@ -1061,7 +1061,7 @@ patterns in each equation.
-}
data MatchGroup id body
= MG { mg_alts :: [LMatch id body] -- The alternatives
= MG { mg_alts :: Located [LMatch id body] -- The alternatives
, mg_arg_tys :: [PostTc id Type] -- Types of the arguments, t1..tn
, mg_res_ty :: PostTc id Type -- Type of the result, tr
, mg_origin :: Origin }
......@@ -1116,13 +1116,13 @@ Example infix function definition requiring individual API Annotations
-}
isEmptyMatchGroup :: MatchGroup id body -> Bool
isEmptyMatchGroup (MG { mg_alts = ms }) = null ms
isEmptyMatchGroup (MG { mg_alts = ms }) = null $ unLoc ms
matchGroupArity :: MatchGroup id body -> Arity
-- Precondition: MatchGroup is non-empty
-- This is called before type checking, when mg_arg_tys is not set
matchGroupArity (MG { mg_alts = alts })
| (alt1:_) <- alts = length (hsLMatchPats alt1)
| L _ (alt1:_) <- alts = length (hsLMatchPats alt1)
| otherwise = panic "matchGroupArity"
hsLMatchPats :: LMatch id body -> [LPat id]
......@@ -1139,7 +1139,7 @@ hsLMatchPats (L _ (Match _ pats _ _)) = pats
data GRHSs id body
= GRHSs {
grhssGRHSs :: [LGRHS id body], -- ^ Guarded RHSs
grhssLocalBinds :: (HsLocalBinds id) -- ^ The where clause
grhssLocalBinds :: Located (HsLocalBinds id) -- ^ The where clause
} deriving (Typeable)
deriving instance (Data body,DataId id) => Data (GRHSs id body)
......@@ -1156,7 +1156,7 @@ deriving instance (Data body,DataId id) => Data (GRHS id body)
pprMatches :: (OutputableBndr idL, OutputableBndr idR, Outputable body)
=> HsMatchContext idL -> MatchGroup idR body -> SDoc
pprMatches ctxt (MG { mg_alts = matches })