Commit 97d320f5 authored by Austin Seipp's avatar Austin Seipp
Browse files

Revert "API Annotations : add Locations in hsSyn were layout occurs"

This reverts commit fb54b2c1.

As Alan pointed out, this will make cherry picking a lot harder until
7.10.2, so lets back it out until after the release.
parent f34c0728
...@@ -509,14 +509,14 @@ addTickHsExpr (HsMultiIf ty alts) ...@@ -509,14 +509,14 @@ addTickHsExpr (HsMultiIf ty alts)
= do { let isOneOfMany = case alts of [_] -> False; _ -> True = do { let isOneOfMany = case alts of [_] -> False; _ -> True
; alts' <- mapM (liftL $ addTickGRHS isOneOfMany False) alts ; alts' <- mapM (liftL $ addTickGRHS isOneOfMany False) alts
; return $ HsMultiIf ty alts' } ; return $ HsMultiIf ty alts' }
addTickHsExpr (HsLet (L l binds) e) = addTickHsExpr (HsLet binds e) =
bindLocals (collectLocalBinders binds) $ do bindLocals (collectLocalBinders binds) $
binds' <- addTickHsLocalBinds binds -- to think about: !patterns. liftM2 HsLet
e' <- addTickLHsExprLetBody e (addTickHsLocalBinds binds) -- to think about: !patterns.
return $ HsLet (L l binds') e' (addTickLHsExprLetBody e)
addTickHsExpr (HsDo cxt (L l stmts) srcloc) addTickHsExpr (HsDo cxt stmts srcloc)
= do { (stmts', _) <- addTickLStmts' forQual stmts (return ()) = do { (stmts', _) <- addTickLStmts' forQual stmts (return ())
; return (HsDo cxt (L l stmts') srcloc) } ; return (HsDo cxt stmts' srcloc) }
where where
forQual = case cxt of forQual = case cxt of
ListComp -> Just $ BinBox QualBinBox ListComp -> Just $ BinBox QualBinBox
...@@ -610,10 +610,10 @@ addTickTupArg (L l (Present e)) = do { e' <- addTickLHsExpr e ...@@ -610,10 +610,10 @@ addTickTupArg (L l (Present e)) = do { e' <- addTickLHsExpr e
addTickTupArg (L l (Missing ty)) = return (L l (Missing ty)) addTickTupArg (L l (Missing ty)) = return (L l (Missing ty))
addTickMatchGroup :: Bool{-is lambda-} -> MatchGroup Id (LHsExpr Id) -> TM (MatchGroup Id (LHsExpr Id)) addTickMatchGroup :: Bool{-is lambda-} -> MatchGroup Id (LHsExpr Id) -> TM (MatchGroup Id (LHsExpr Id))
addTickMatchGroup is_lam mg@(MG { mg_alts = L l matches }) = do addTickMatchGroup is_lam mg@(MG { mg_alts = matches }) = do
let isOneOfMany = matchesOneOfMany matches let isOneOfMany = matchesOneOfMany matches
matches' <- mapM (liftL (addTickMatch isOneOfMany is_lam)) matches matches' <- mapM (liftL (addTickMatch isOneOfMany is_lam)) matches
return $ mg { mg_alts = L l matches' } return $ mg { mg_alts = matches' }
addTickMatch :: Bool -> Bool -> Match Id (LHsExpr Id) -> TM (Match Id (LHsExpr Id)) addTickMatch :: Bool -> Bool -> Match Id (LHsExpr Id) -> TM (Match Id (LHsExpr Id))
addTickMatch isOneOfMany isLambda (Match mf pats opSig gRHSs) = addTickMatch isOneOfMany isLambda (Match mf pats opSig gRHSs) =
...@@ -622,11 +622,11 @@ 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' return $ Match mf pats opSig gRHSs'
addTickGRHSs :: Bool -> Bool -> GRHSs Id (LHsExpr Id) -> TM (GRHSs Id (LHsExpr Id)) addTickGRHSs :: Bool -> Bool -> GRHSs Id (LHsExpr Id) -> TM (GRHSs Id (LHsExpr Id))
addTickGRHSs isOneOfMany isLambda (GRHSs guarded (L l local_binds)) = do addTickGRHSs isOneOfMany isLambda (GRHSs guarded local_binds) = do
bindLocals binders $ do bindLocals binders $ do
local_binds' <- addTickHsLocalBinds local_binds local_binds' <- addTickHsLocalBinds local_binds
guarded' <- mapM (liftL (addTickGRHS isOneOfMany isLambda)) guarded guarded' <- mapM (liftL (addTickGRHS isOneOfMany isLambda)) guarded
return $ GRHSs guarded' (L l local_binds') return $ GRHSs guarded' local_binds'
where where
binders = collectLocalBinders local_binds binders = collectLocalBinders local_binds
...@@ -678,9 +678,9 @@ addTickStmt isGuard (BodyStmt e bind' guard' ty) = do ...@@ -678,9 +678,9 @@ addTickStmt isGuard (BodyStmt e bind' guard' ty) = do
(addTickSyntaxExpr hpcSrcSpan bind') (addTickSyntaxExpr hpcSrcSpan bind')
(addTickSyntaxExpr hpcSrcSpan guard') (addTickSyntaxExpr hpcSrcSpan guard')
(return ty) (return ty)
addTickStmt _isGuard (LetStmt (L l binds)) = do addTickStmt _isGuard (LetStmt binds) = do
binds' <- addTickHsLocalBinds binds liftM LetStmt
return $ LetStmt (L l binds') (addTickHsLocalBinds binds)
addTickStmt isGuard (ParStmt pairs mzipExpr bindExpr) = do addTickStmt isGuard (ParStmt pairs mzipExpr bindExpr) = do
liftM3 ParStmt liftM3 ParStmt
(mapM (addTickStmtAndBinders isGuard) pairs) (mapM (addTickStmtAndBinders isGuard) pairs)
...@@ -797,14 +797,14 @@ addTickHsCmd (HsCmdIf cnd e1 c2 c3) = ...@@ -797,14 +797,14 @@ addTickHsCmd (HsCmdIf cnd e1 c2 c3) =
(addBinTickLHsExpr (BinBox CondBinBox) e1) (addBinTickLHsExpr (BinBox CondBinBox) e1)
(addTickLHsCmd c2) (addTickLHsCmd c2)
(addTickLHsCmd c3) (addTickLHsCmd c3)
addTickHsCmd (HsCmdLet (L l binds) c) = addTickHsCmd (HsCmdLet binds c) =
bindLocals (collectLocalBinders binds) $ do bindLocals (collectLocalBinders binds) $
binds' <- addTickHsLocalBinds binds -- to think about: !patterns. liftM2 HsCmdLet
c' <- addTickLHsCmd c (addTickHsLocalBinds binds) -- to think about: !patterns.
return $ HsCmdLet (L l binds') c' (addTickLHsCmd c)
addTickHsCmd (HsCmdDo (L l stmts) srcloc) addTickHsCmd (HsCmdDo stmts srcloc)
= do { (stmts', _) <- addTickLCmdStmts' stmts (return ()) = do { (stmts', _) <- addTickLCmdStmts' stmts (return ())
; return (HsCmdDo (L l stmts') srcloc) } ; return (HsCmdDo stmts' srcloc) }
addTickHsCmd (HsCmdArrApp e1 e2 ty1 arr_ty lr) = addTickHsCmd (HsCmdArrApp e1 e2 ty1 arr_ty lr) =
liftM5 HsCmdArrApp liftM5 HsCmdArrApp
...@@ -826,9 +826,9 @@ addTickHsCmd (HsCmdCast co cmd) ...@@ -826,9 +826,9 @@ addTickHsCmd (HsCmdCast co cmd)
--addTickHsCmd e = pprPanic "addTickHsCmd" (ppr e) --addTickHsCmd e = pprPanic "addTickHsCmd" (ppr e)
addTickCmdMatchGroup :: MatchGroup Id (LHsCmd Id) -> TM (MatchGroup Id (LHsCmd Id)) addTickCmdMatchGroup :: MatchGroup Id (LHsCmd Id) -> TM (MatchGroup Id (LHsCmd Id))
addTickCmdMatchGroup mg@(MG { mg_alts = L l matches }) = do addTickCmdMatchGroup mg@(MG { mg_alts = matches }) = do
matches' <- mapM (liftL addTickCmdMatch) matches matches' <- mapM (liftL addTickCmdMatch) matches
return $ mg { mg_alts = L l matches' } return $ mg { mg_alts = matches' }
addTickCmdMatch :: Match Id (LHsCmd Id) -> TM (Match Id (LHsCmd Id)) addTickCmdMatch :: Match Id (LHsCmd Id) -> TM (Match Id (LHsCmd Id))
addTickCmdMatch (Match mf pats opSig gRHSs) = addTickCmdMatch (Match mf pats opSig gRHSs) =
...@@ -837,11 +837,11 @@ addTickCmdMatch (Match mf pats opSig gRHSs) = ...@@ -837,11 +837,11 @@ addTickCmdMatch (Match mf pats opSig gRHSs) =
return $ Match mf pats opSig gRHSs' return $ Match mf pats opSig gRHSs'
addTickCmdGRHSs :: GRHSs Id (LHsCmd Id) -> TM (GRHSs Id (LHsCmd Id)) addTickCmdGRHSs :: GRHSs Id (LHsCmd Id) -> TM (GRHSs Id (LHsCmd Id))
addTickCmdGRHSs (GRHSs guarded (L l local_binds)) = do addTickCmdGRHSs (GRHSs guarded local_binds) = do
bindLocals binders $ do bindLocals binders $ do
local_binds' <- addTickHsLocalBinds local_binds local_binds' <- addTickHsLocalBinds local_binds
guarded' <- mapM (liftL addTickCmdGRHS) guarded guarded' <- mapM (liftL addTickCmdGRHS) guarded
return $ GRHSs guarded' (L l local_binds') return $ GRHSs guarded' local_binds'
where where
binders = collectLocalBinders local_binds binders = collectLocalBinders local_binds
...@@ -884,9 +884,9 @@ addTickCmdStmt (BodyStmt c bind' guard' ty) = do ...@@ -884,9 +884,9 @@ addTickCmdStmt (BodyStmt c bind' guard' ty) = do
(addTickSyntaxExpr hpcSrcSpan bind') (addTickSyntaxExpr hpcSrcSpan bind')
(addTickSyntaxExpr hpcSrcSpan guard') (addTickSyntaxExpr hpcSrcSpan guard')
(return ty) (return ty)
addTickCmdStmt (LetStmt (L l binds)) = do addTickCmdStmt (LetStmt binds) = do
binds' <- addTickHsLocalBinds binds liftM LetStmt
return $ LetStmt (L l binds') (addTickHsLocalBinds binds)
addTickCmdStmt stmt@(RecStmt {}) addTickCmdStmt stmt@(RecStmt {})
= do { stmts' <- addTickLCmdStmts (recS_stmts stmt) = do { stmts' <- addTickLCmdStmts (recS_stmts stmt)
; ret' <- addTickSyntaxExpr hpcSrcSpan (recS_ret_fn 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 ...@@ -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 -- ---> premap (\ ((xs), (p1, ... (pk,stk)...)) -> ((ys),stk)) cmd
dsCmd ids local_vars stack_ty res_ty dsCmd ids local_vars stack_ty res_ty
(HsCmdLam (MG { mg_alts = L _ [L _ (Match _ pats _ (HsCmdLam (MG { mg_alts = [L _ (Match _ pats _
(GRHSs [L _ (GRHS [] body)] _ ))] })) (GRHSs [L _ (GRHS [] body)] _ ))] }))
env_ids = do env_ids = do
let let
pat_vars = mkVarSet (collectPatsBinders pats) pat_vars = mkVarSet (collectPatsBinders pats)
...@@ -504,8 +504,7 @@ case bodies, containing the following fields: ...@@ -504,8 +504,7 @@ case bodies, containing the following fields:
-} -}
dsCmd ids local_vars stack_ty res_ty dsCmd ids local_vars stack_ty res_ty
(HsCmdCase exp (MG { mg_alts = L l matches, mg_arg_tys = arg_tys (HsCmdCase exp (MG { mg_alts = matches, mg_arg_tys = arg_tys, mg_origin = origin }))
, mg_origin = origin }))
env_ids = do env_ids = do
stack_id <- newSysLocalDs stack_ty stack_id <- newSysLocalDs stack_ty
...@@ -548,8 +547,7 @@ dsCmd ids local_vars stack_ty res_ty ...@@ -548,8 +547,7 @@ dsCmd ids local_vars stack_ty res_ty
(_, matches') = mapAccumL (replaceLeavesMatch res_ty) leaves' matches (_, matches') = mapAccumL (replaceLeavesMatch res_ty) leaves' matches
in_ty = envStackType env_ids stack_ty in_ty = envStackType env_ids stack_ty
core_body <- dsExpr (HsCase exp (MG { mg_alts = L l matches' core_body <- dsExpr (HsCase exp (MG { mg_alts = matches', mg_arg_tys = arg_tys
, mg_arg_tys = arg_tys
, mg_res_ty = sum_ty, mg_origin = origin })) , mg_res_ty = sum_ty, mg_origin = origin }))
-- Note that we replace the HsCase result type by sum_ty, -- Note that we replace the HsCase result type by sum_ty,
-- which is the type of matches' -- which is the type of matches'
...@@ -564,7 +562,7 @@ dsCmd ids local_vars stack_ty res_ty ...@@ -564,7 +562,7 @@ dsCmd ids local_vars stack_ty res_ty
-- --
-- ---> premap (\ ((xs),stk) -> let binds in ((ys),stk)) c -- ---> premap (\ ((xs),stk) -> let binds in ((ys),stk)) c
dsCmd ids local_vars stack_ty res_ty (HsCmdLet (L _ binds) body) env_ids = do dsCmd ids local_vars stack_ty res_ty (HsCmdLet binds body) env_ids = do
let let
defined_vars = mkVarSet (collectLocalBinders binds) defined_vars = mkVarSet (collectLocalBinders binds)
local_vars' = defined_vars `unionVarSet` local_vars local_vars' = defined_vars `unionVarSet` local_vars
...@@ -589,7 +587,7 @@ dsCmd ids local_vars stack_ty res_ty (HsCmdLet (L _ binds) body) env_ids = do ...@@ -589,7 +587,7 @@ dsCmd ids local_vars stack_ty res_ty (HsCmdLet (L _ binds) body) env_ids = do
-- --
-- ---> premap (\ (env,stk) -> env) c -- ---> premap (\ (env,stk) -> env) c
dsCmd ids local_vars stack_ty res_ty (HsCmdDo (L _ stmts) _) env_ids = do dsCmd ids local_vars stack_ty res_ty (HsCmdDo stmts _) env_ids = do
(core_stmts, env_ids') <- dsCmdDo ids local_vars res_ty stmts env_ids (core_stmts, env_ids') <- dsCmdDo ids local_vars res_ty stmts env_ids
let env_ty = mkBigCoreVarTupTy env_ids let env_ty = mkBigCoreVarTupTy env_ids
core_fst <- mkFstExpr env_ty stack_ty core_fst <- mkFstExpr env_ty stack_ty
...@@ -834,7 +832,7 @@ dsCmdStmt ids local_vars out_ids (BindStmt pat cmd _ _) env_ids = do ...@@ -834,7 +832,7 @@ dsCmdStmt ids local_vars out_ids (BindStmt pat cmd _ _) env_ids = do
-- --
-- ---> arr (\ (xs) -> let binds in (xs')) >>> ss -- ---> arr (\ (xs) -> let binds in (xs')) >>> ss
dsCmdStmt ids local_vars out_ids (LetStmt (L _ binds)) env_ids = do dsCmdStmt ids local_vars out_ids (LetStmt binds) env_ids = do
-- build a new environment using the let bindings -- build a new environment using the let bindings
core_binds <- dsLocalBinds binds (mkBigCoreVarTup out_ids) core_binds <- dsLocalBinds binds (mkBigCoreVarTup out_ids)
-- match the old environment against the input -- match the old environment against the input
...@@ -1049,7 +1047,7 @@ matchSimplys _ _ _ _ _ = panic "matchSimplys" ...@@ -1049,7 +1047,7 @@ matchSimplys _ _ _ _ _ = panic "matchSimplys"
-- List of leaf expressions, with set of variables bound in each -- List of leaf expressions, with set of variables bound in each
leavesMatch :: LMatch Id (Located (body Id)) -> [(Located (body Id), IdSet)] leavesMatch :: LMatch Id (Located (body Id)) -> [(Located (body Id), IdSet)]
leavesMatch (L _ (Match _ pats _ (GRHSs grhss (L _ binds)))) leavesMatch (L _ (Match _ pats _ (GRHSs grhss binds)))
= let = let
defined_vars = mkVarSet (collectPatsBinders pats) defined_vars = mkVarSet (collectPatsBinders pats)
`unionVarSet` `unionVarSet`
...@@ -1169,11 +1167,11 @@ collectLStmtBinders :: LStmt Id body -> [Id] ...@@ -1169,11 +1167,11 @@ collectLStmtBinders :: LStmt Id body -> [Id]
collectLStmtBinders = collectStmtBinders . unLoc collectLStmtBinders = collectStmtBinders . unLoc
collectStmtBinders :: Stmt Id body -> [Id] collectStmtBinders :: Stmt Id body -> [Id]
collectStmtBinders (BindStmt pat _ _ _) = collectPatBinders pat collectStmtBinders (BindStmt pat _ _ _) = collectPatBinders pat
collectStmtBinders (LetStmt (L _ binds)) = collectLocalBinders binds collectStmtBinders (LetStmt binds) = collectLocalBinders binds
collectStmtBinders (BodyStmt {}) = [] collectStmtBinders (BodyStmt {}) = []
collectStmtBinders (LastStmt {}) = [] collectStmtBinders (LastStmt {}) = []
collectStmtBinders (ParStmt xs _ _) = collectLStmtsBinders collectStmtBinders (ParStmt xs _ _) = collectLStmtsBinders
$ [ s | ParStmtBlock ss _ _ <- xs, s <- ss] $ [ s | ParStmtBlock ss _ _ <- xs, s <- ss]
collectStmtBinders (TransStmt { trS_stmts = stmts }) = collectLStmtsBinders stmts collectStmtBinders (TransStmt { trS_stmts = stmts }) = collectLStmtsBinders stmts
collectStmtBinders (RecStmt { recS_later_ids = later_ids }) = later_ids collectStmtBinders (RecStmt { recS_later_ids = later_ids }) = later_ids
...@@ -321,19 +321,19 @@ dsExpr (HsCase discrim matches) ...@@ -321,19 +321,19 @@ dsExpr (HsCase discrim matches)
-- Pepe: The binds are in scope in the body but NOT in the binding group -- Pepe: The binds are in scope in the body but NOT in the binding group
-- This is to avoid silliness in breakpoints -- This is to avoid silliness in breakpoints
dsExpr (HsLet (L _ binds) body) = do dsExpr (HsLet binds body) = do
body' <- dsLExpr body body' <- dsLExpr body
dsLocalBinds binds body' dsLocalBinds binds body'
-- We need the `ListComp' form to use `deListComp' (rather than the "do" form) -- 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. -- because the interpretation of `stmts' depends on what sort of thing it is.
-- --
dsExpr (HsDo ListComp (L _ stmts) res_ty) = dsListComp stmts res_ty dsExpr (HsDo ListComp stmts res_ty) = dsListComp stmts res_ty
dsExpr (HsDo PArrComp (L _ stmts) _) = dsPArrComp (map unLoc stmts) dsExpr (HsDo PArrComp stmts _) = dsPArrComp (map unLoc stmts)
dsExpr (HsDo DoExpr (L _ stmts) _) = dsDo stmts dsExpr (HsDo DoExpr stmts _) = dsDo stmts
dsExpr (HsDo GhciStmtCtxt (L _ stmts) _) = dsDo stmts dsExpr (HsDo GhciStmtCtxt stmts _) = dsDo stmts
dsExpr (HsDo MDoExpr (L _ stmts) _) = dsDo stmts dsExpr (HsDo MDoExpr stmts _) = dsDo stmts
dsExpr (HsDo MonadComp (L _ stmts) _) = dsMonadComp stmts dsExpr (HsDo MonadComp stmts _) = dsMonadComp stmts
dsExpr (HsIf mb_fun guard_expr then_expr else_expr) dsExpr (HsIf mb_fun guard_expr then_expr else_expr)
= do { pred <- dsLExpr guard_expr = do { pred <- dsLExpr guard_expr
...@@ -571,8 +571,7 @@ dsExpr expr@(RecordUpd record_expr (HsRecFields { rec_flds = fields }) ...@@ -571,8 +571,7 @@ dsExpr expr@(RecordUpd record_expr (HsRecFields { rec_flds = fields })
-- constructor aguments. -- constructor aguments.
; alts <- mapM (mk_alt upd_fld_env) cons_to_upd ; alts <- mapM (mk_alt upd_fld_env) cons_to_upd
; ([discrim_var], matching_code) ; ([discrim_var], matching_code)
<- matchWrapper RecUpd (MG { mg_alts = noLoc alts <- matchWrapper RecUpd (MG { mg_alts = alts, mg_arg_tys = [in_ty]
, mg_arg_tys = [in_ty]
, mg_res_ty = out_ty, mg_origin = FromSource }) , mg_res_ty = out_ty, mg_origin = FromSource })
-- FromSource is not strictly right, but we -- FromSource is not strictly right, but we
-- want incomplete pattern-match warnings -- want incomplete pattern-match warnings
...@@ -840,7 +839,7 @@ dsDo stmts ...@@ -840,7 +839,7 @@ dsDo stmts
; rest <- goL stmts ; rest <- goL stmts
; return (mkApps then_expr2 [rhs2, rest]) } ; return (mkApps then_expr2 [rhs2, rest]) }
go _ (LetStmt (L _ binds)) stmts go _ (LetStmt binds) stmts
= do { rest <- goL stmts = do { rest <- goL stmts
; dsLocalBinds binds rest } ; dsLocalBinds binds rest }
...@@ -872,12 +871,11 @@ dsDo stmts ...@@ -872,12 +871,11 @@ dsDo stmts
later_pats = rec_tup_pats later_pats = rec_tup_pats
rets = map noLoc rec_rets rets = map noLoc rec_rets
mfix_app = nlHsApp (noLoc mfix_op) mfix_arg mfix_app = nlHsApp (noLoc mfix_op) mfix_arg
mfix_arg = noLoc mfix_arg = noLoc $ HsLam (MG { mg_alts = [mkSimpleMatch [mfix_pat] body]
$ HsLam (MG { mg_alts = noLoc [mkSimpleMatch [mfix_pat] body] , mg_arg_tys = [tup_ty], mg_res_ty = body_ty
, mg_arg_tys = [tup_ty], mg_res_ty = body_ty , mg_origin = Generated })
, mg_origin = Generated })
mfix_pat = noLoc $ LazyPat $ mkBigLHsPatTup rec_tup_pats mfix_pat = noLoc $ LazyPat $ mkBigLHsPatTup rec_tup_pats
body = noLoc $ HsDo DoExpr (noLoc (rec_stmts ++ [ret_stmt])) body_ty body = noLoc $ HsDo DoExpr (rec_stmts ++ [ret_stmt]) body_ty
ret_app = nlHsApp (noLoc return_op) (mkBigLHsTup rets) ret_app = nlHsApp (noLoc return_op) (mkBigLHsTup rets)
ret_stmt = noLoc $ mkLastStmt ret_app ret_stmt = noLoc $ mkLastStmt ret_app
-- This LastStmt will be desugared with dsDo, -- This LastStmt will be desugared with dsDo,
......
...@@ -57,7 +57,7 @@ dsGRHSs :: HsMatchContext Name -> [Pat Id] -- These are to build a MatchCon ...@@ -57,7 +57,7 @@ dsGRHSs :: HsMatchContext Name -> [Pat Id] -- These are to build a MatchCon
-> GRHSs Id (LHsExpr Id) -- Guarded RHSs -> GRHSs Id (LHsExpr Id) -- Guarded RHSs
-> Type -- Type of RHS -> Type -- Type of RHS
-> DsM MatchResult -> DsM MatchResult
dsGRHSs hs_ctx _ (GRHSs grhss (L _ binds)) rhs_ty dsGRHSs hs_ctx _ (GRHSs grhss binds) rhs_ty
= ASSERT( notNull grhss ) = ASSERT( notNull grhss )
do { match_results <- mapM (dsGRHS hs_ctx rhs_ty) grhss do { match_results <- mapM (dsGRHS hs_ctx rhs_ty) grhss
; let match_result1 = foldr1 combineMatchResults match_results ; let match_result1 = foldr1 combineMatchResults match_results
...@@ -106,7 +106,7 @@ matchGuards (BodyStmt expr _ _ _ : stmts) ctx rhs rhs_ty = do ...@@ -106,7 +106,7 @@ matchGuards (BodyStmt expr _ _ _ : stmts) ctx rhs rhs_ty = do
pred_expr <- dsLExpr expr pred_expr <- dsLExpr expr
return (mkGuardedMatchResult pred_expr match_result) return (mkGuardedMatchResult pred_expr match_result)
matchGuards (LetStmt (L _ binds) : stmts) ctx rhs rhs_ty = do matchGuards (LetStmt binds : stmts) ctx rhs rhs_ty = do
match_result <- matchGuards stmts ctx rhs rhs_ty match_result <- matchGuards stmts ctx rhs rhs_ty
return (adjustMatchResultDs (dsLocalBinds binds) match_result) return (adjustMatchResultDs (dsLocalBinds binds) match_result)
-- NB the dsLet occurs inside the match_result -- NB the dsLet occurs inside the match_result
......
...@@ -221,7 +221,7 @@ deListComp (BodyStmt guard _ _ _ : quals) list = do -- rule B above ...@@ -221,7 +221,7 @@ deListComp (BodyStmt guard _ _ _ : quals) list = do -- rule B above
return (mkIfThenElse core_guard core_rest list) return (mkIfThenElse core_guard core_rest list)
-- [e | let B, qs] = let B in [e | qs] -- [e | let B, qs] = let B in [e | qs]
deListComp (LetStmt (L _ binds) : quals) list = do deListComp (LetStmt binds : quals) list = do
core_rest <- deListComp quals list core_rest <- deListComp quals list
dsLocalBinds binds core_rest dsLocalBinds binds core_rest
...@@ -323,7 +323,7 @@ dfListComp c_id n_id (BodyStmt guard _ _ _ : quals) = do ...@@ -323,7 +323,7 @@ dfListComp c_id n_id (BodyStmt guard _ _ _ : quals) = do
core_rest <- dfListComp c_id n_id quals core_rest <- dfListComp c_id n_id quals
return (mkIfThenElse core_guard core_rest (Var n_id)) return (mkIfThenElse core_guard core_rest (Var n_id))
dfListComp c_id n_id (LetStmt (L _ binds) : quals) = do dfListComp c_id n_id (LetStmt binds : quals) = do
-- new in 1.3, local bindings -- new in 1.3, local bindings
core_rest <- dfListComp c_id n_id quals core_rest <- dfListComp c_id n_id quals
dsLocalBinds binds core_rest dsLocalBinds binds core_rest
...@@ -563,7 +563,7 @@ dePArrComp (BindStmt p e _ _ : qs) pa cea = do ...@@ -563,7 +563,7 @@ dePArrComp (BindStmt p e _ _ : qs) pa cea = do
-- where -- where
-- {x_1, ..., x_n} = DV (ds) -- Defined Variables -- {x_1, ..., x_n} = DV (ds) -- Defined Variables
-- --
dePArrComp (LetStmt (L _ ds) : qs) pa cea = do dePArrComp (LetStmt ds : qs) pa cea = do
mapP <- dsDPHBuiltin mapPVar mapP <- dsDPHBuiltin mapPVar
let xs = collectLocalBinders ds let xs = collectLocalBinders ds
ty'cea = parrElemType cea ty'cea = parrElemType cea
...@@ -673,7 +673,7 @@ dsMcStmt (LastStmt body ret_op) stmts ...@@ -673,7 +673,7 @@ dsMcStmt (LastStmt body ret_op) stmts
; return (App ret_op' body') } ; return (App ret_op' body') }
-- [ .. | let binds, stmts ] -- [ .. | let binds, stmts ]
dsMcStmt (LetStmt (L _ binds)) stmts dsMcStmt (LetStmt binds) stmts
= do { rest <- dsMcStmts stmts = do { rest <- dsMcStmts stmts
; dsLocalBinds binds rest } ; dsLocalBinds binds rest }
......
...@@ -1013,8 +1013,8 @@ repE e@(HsIPVar _) = notHandled "Implicit parameters" (ppr e) ...@@ -1013,8 +1013,8 @@ repE e@(HsIPVar _) = notHandled "Implicit parameters" (ppr e)
-- HsOverlit can definitely occur -- HsOverlit can definitely occur
repE (HsOverLit l) = do { a <- repOverloadedLiteral l; repLit a } repE (HsOverLit l) = do { a <- repOverloadedLiteral l; repLit a }
repE (HsLit l) = do { a <- repLiteral l; repLit a } repE (HsLit l) = do { a <- repLiteral l; repLit a }
repE (HsLam (MG { mg_alts = L _ [m] })) = repLambda m repE (HsLam (MG { mg_alts = [m] })) = repLambda m
repE (HsLamCase _ (MG { mg_alts = L _ ms })) repE (HsLamCase _ (MG { mg_alts = ms }))
= do { ms' <- mapM repMatchTup ms = do { ms' <- mapM repMatchTup ms
; core_ms <- coreList matchQTyConName ms' ; core_ms <- coreList matchQTyConName ms'
; repLamCase core_ms } ; repLamCase core_ms }
...@@ -1032,7 +1032,7 @@ repE (NegApp x _) = do ...@@ -1032,7 +1032,7 @@ repE (NegApp x _) = do
repE (HsPar x) = repLE x repE (HsPar x) = repLE x
repE (SectionL x y) = do { a <- repLE x; b <- repLE y; repSectionL a b } 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 (SectionR x y) = do { a <- repLE x; b <- repLE y; repSectionR a b }
repE (HsCase e (MG { mg_alts = L _ ms })) repE (HsCase e (MG { mg_alts = ms }))
= do { arg <- repLE e = do { arg <- repLE e
; ms2 <- mapM repMatchTup ms ; ms2 <- mapM repMatchTup ms
; core_ms2 <- coreList matchQTyConName ms2 ; core_ms2 <- coreList matchQTyConName ms2
...@@ -1046,13 +1046,13 @@ repE (HsMultiIf _ alts) ...@@ -1046,13 +1046,13 @@ repE (HsMultiIf _ alts)
= do { (binds, alts') <- liftM unzip $ mapM repLGRHS alts = do { (binds, alts') <- liftM unzip $ mapM repLGRHS alts
; expr' <- repMultiIf (nonEmptyCoreList alts') ; expr' <- repMultiIf (nonEmptyCoreList alts')
; wrapGenSyms (concat binds) expr' } ; wrapGenSyms (concat binds) expr' }
repE (HsLet (L _ bs) e) = do { (ss,ds) <- repBinds bs repE (HsLet bs e) = do { (ss,ds) <- repBinds bs
; e2 <- addBinds ss (repLE e) ; e2 <- addBinds ss (repLE e)
; z <- repLetE ds e2 ; z <- repLetE ds e2
; wrapGenSyms ss z } ; wrapGenSyms ss z }
-- FIXME: I haven't got the types here right yet -- FIXME: I haven't got the types here right yet
repE e@(HsDo ctxt (L _ sts) _) repE e@(HsDo ctxt sts _)
| case ctxt of { DoExpr -> True; GhciStmtCtxt -> True; _ -> False } | case ctxt of { DoExpr -> True; GhciStmtCtxt -> True; _ -> False }
= do { (ss,zs) <- repLSts sts; = do { (ss,zs) <- repLSts sts;
e' <- repDoE (nonEmptyCoreList zs); e' <- repDoE (nonEmptyCoreList zs);
...@@ -1114,7 +1114,7 @@ repE e = notHandled "Expression form" (ppr e) ...@@ -1114,7 +1114,7 @@ repE e = notHandled "Expression form" (ppr e)
-- Building representations of auxillary structures like Match, Clause, Stmt, -- Building representations of auxillary structures like Match, Clause, Stmt,
repMatchTup :: LMatch Name (LHsExpr Name) -> DsM (Core TH.MatchQ) repMatchTup :: LMatch Name (LHsExpr Name) -> DsM (Core TH.MatchQ)
repMatchTup (L _ (Match _ [p] _ (GRHSs guards (L _ wheres)))) = repMatchTup (L _ (Match _ [p] _ (GRHSs guards wheres))) =
do { ss1 <- mkGenSyms (collectPatBinders p) do { ss1 <- mkGenSyms (collectPatBinders p)
; addBinds ss1 $ do { ; addBinds ss1 $ do {
; p1 <- repLP p ; p1 <- repLP p
...@@ -1126,7 +1126,7 @@ repMatchTup (L _ (Match _ [p] _ (GRHSs guards (L _ wheres)))) = ...@@ -1126,7 +1126,7 @@ repMatchTup (L _ (Match _ [p] _ (GRHSs guards (L _ wheres)))) =
repMatchTup _ = panic "repMatchTup: case alt with more than one arg" repMatchTup _ = panic "repMatchTup: case alt with more than one arg"
repClauseTup :: LMatch Name (LHsExpr Name) -> DsM (Core TH.ClauseQ) repClauseTup :: LMatch Name (LHsExpr Name) -> DsM (Core TH.ClauseQ)
repClauseTup (L _ (Match _ ps _ (GRHSs guards (L _ wheres)))) = repClauseTup (L _ (Match _ ps _ (GRHSs guards wheres))) =
do { ss1 <- mkGenSyms (collectPatsBinders ps) do { ss1 <- mkGenSyms (collectPatsBinders ps)
; addBinds ss1 $ do { ; addBinds ss1 $ do {
ps1 <- repLPs ps ps1 <- repLPs ps
...@@ -1201,7 +1201,7 @@ repSts (BindStmt p e _ _ : ss) = ...@@ -1201,7 +1201,7 @@ repSts (BindStmt p e _ _ : ss) =
; (ss2,zs) <- repSts ss ; (ss2,zs) <- repSts ss
; z <- repBindSt p1 e2 ; z <- repBindSt p1 e2
; return (ss1++ss2, z : zs) }} ; return (ss1++ss2, z : zs) }}
repSts (LetStmt (L _ bs) : ss) = repSts (LetStmt bs : ss) =
do { (ss1,ds) <- repBinds bs do { (ss1,ds) <- repBinds bs
; z <- repLetSt ds ; z <- repLetSt ds
; (ss2,zs) <- addBinds ss1 (repSts ss) ; (ss2,zs) <- addBinds ss1 (repSts ss)
...@@ -1280,9 +1280,8 @@ rep_bind :: LHsBind Name -> DsM (SrcSpan, Core TH.DecQ) ...@@ -1280,9 +1280,8 @@ rep_bind :: LHsBind Name -> DsM (SrcSpan, Core TH.DecQ)
-- with an empty list of patterns -- with an empty list of patterns
rep_bind (L loc (FunBind rep_bind (L loc (FunBind
{ fun_id = fn, { fun_id = fn,
fun_matches = MG { mg_alts fun_matches = MG { mg_alts = [L _ (Match _ [] _
= L _ [L _ (Match _ [] _ (GRHSs guards wheres))] } }))
(GRHSs guards (L _ wheres)))] } }))
= do { (ss,wherecore) <- repBinds wheres = do { (ss,wherecore) <- repBinds wheres
; guardcore <- addBinds ss (repGuards guards) ; guardcore <- addBinds ss (repGuards guards)
; fn' <- lookupLBinder fn ; fn' <- lookupLBinder fn
...@@ -1291,15 +1290,13 @@ rep_bind (L loc (FunBind ...@@ -1291,15 +1290,13 @@ rep_bind (L loc (FunBind
; ans' <- wrapGenSyms ss ans ; ans' <- wrapGenSyms ss ans
; return (loc, ans') } ; return (loc, ans') }
rep_bind (L loc (FunBind { fun_id = fn rep_bind (L loc (FunBind { fun_id = fn, fun_matches = MG { mg_alts = ms } }))
, fun_matches = MG { mg_alts = L _ ms } }))
= do { ms1 <- mapM repClauseTup ms = do { ms1 <- mapM repClauseTup ms
; fn' <- lookupLBinder fn ; fn' <- lookupLBinder fn
; ans <- repFun fn' (nonEmptyCoreList ms1) ; ans <- repFun fn' (nonEmptyCoreList ms1)
; return (loc, ans) } </