X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Frename%2FRnExpr.lhs;h=1b7eef0253534341c78f571393c7eea67c5fb76f;hp=78088d52cef6c39e52e1fe3bac22ec0d89aca487;hb=cf5905ea24904cf73a041fd7535e8723a668cb9a;hpb=f1cc3eb980a634e62f2739a7a25387c902fa9d8a diff --git a/compiler/rename/RnExpr.lhs b/compiler/rename/RnExpr.lhs index 78088d5..1b7eef0 100644 --- a/compiler/rename/RnExpr.lhs +++ b/compiler/rename/RnExpr.lhs @@ -21,19 +21,20 @@ import {-# SOURCE #-} TcSplice( runQuasiQuoteExpr ) #endif /* GHCI */ import RnSource ( rnSrcDecls, findSplice ) -import RnBinds ( rnLocalBindsAndThen, rnValBindsLHS, rnValBindsRHS, +import RnBinds ( rnLocalBindsAndThen, rnLocalValBindsLHS, rnLocalValBindsRHS, rnMatchGroup, makeMiniFixityEnv) import HsSyn import TcRnMonad -import TcEnv ( thRnBrack ) +import TcEnv ( thRnBrack, getHetMetLevel ) import RnEnv import RnTypes ( rnHsTypeFVs, rnSplice, checkTH, mkOpFormRn, mkOpAppRn, mkNegAppRn, checkSectionPrec) import RnPat -import DynFlags ( DynFlag(..) ) +import DynFlags import BasicTypes ( FixityDirection(..) ) import PrelNames +import Var ( TyVar, varName ) import Name import NameSet import RdrName @@ -84,6 +85,13 @@ rnExprs ls = rnExprs' ls emptyUniqSet Variables. We look up the variable and return the resulting name. \begin{code} + +-- during the renamer phase we only care about the length of the +-- current HetMet level; the actual tyvars don't +-- matter, so we use bottoms for them +dummyTyVar :: TyVar +dummyTyVar = error "tried to force RnExpr.dummyTyVar" + rnLExpr :: LHsExpr RdrName -> RnM (LHsExpr Name, FreeVars) rnLExpr = wrapLocFstM rnExpr @@ -110,7 +118,7 @@ rnExpr (HsIPVar v) rnExpr (HsLit lit@(HsString s)) = do { - opt_OverloadedStrings <- doptM Opt_OverloadedStrings + opt_OverloadedStrings <- xoptM Opt_OverloadedStrings ; if opt_OverloadedStrings then rnExpr (HsOverLit (mkHsIsString s placeHolderType)) else -- Same as below @@ -131,8 +139,8 @@ rnExpr (HsApp fun arg) rnLExpr arg `thenM` \ (arg',fvArg) -> return (HsApp fun' arg', fvFun `plusFV` fvArg) -rnExpr (OpApp e1 (L op_loc (HsVar op_rdr)) _ e2) - = do { (e1', fv_e1) <- rnLExpr e1 +rnExpr (OpApp e1 (L op_loc (HsVar op_rdr)) _ e2) + = do { (e1', fv_e1) <- rnLExpr e1 ; (e2', fv_e2) <- rnLExpr e2 ; op_name <- setSrcSpan op_loc (lookupOccRn op_rdr) ; (op', fv_op) <- finishHsVar op_name @@ -146,6 +154,10 @@ rnExpr (OpApp e1 (L op_loc (HsVar op_rdr)) _ e2) ; fixity <- lookupFixityRn op_name ; final_e <- mkOpAppRn e1' (L op_loc op') fixity e2' ; return (final_e, fv_e1 `plusFV` fv_op `plusFV` fv_e2) } +rnExpr (OpApp _ other_op _ _) + = failWith (vcat [ hang (ptext (sLit "Operator application with a non-variable operator:")) + 2 (ppr other_op) + , ptext (sLit "(Probably resulting from a Template Haskell splice)") ]) rnExpr (NegApp e _) = rnLExpr e `thenM` \ (e', fv_e) -> @@ -153,6 +165,21 @@ rnExpr (NegApp e _) mkNegAppRn e' neg_name `thenM` \ final_e -> return (final_e, fv_e `plusFV` fv_neg) +rnExpr (HsHetMetBrak c e) + = do { (e', fv_e) <- updLclEnv (\x -> x { tcl_hetMetLevel = dummyTyVar:(tcl_hetMetLevel x) }) $ rnLExpr e + ; return (HsHetMetBrak c e', fv_e) + } +rnExpr (HsHetMetEsc c t e) + = do { (e', fv_e) <- updLclEnv (\x -> x { tcl_hetMetLevel = tail (tcl_hetMetLevel x) }) $ rnLExpr e + ; return (HsHetMetEsc c t e', fv_e) + } +rnExpr (HsHetMetCSP c e) + = do { (e', fv_e) <- updLclEnv (\x -> x { tcl_hetMetLevel = tail (tcl_hetMetLevel x) }) $ rnLExpr e + ; return (HsHetMetCSP c e', fv_e) + } + + + ------------------------------------------ -- Template Haskell extensions -- Don't ifdef-GHCI them because we want to fail gracefully @@ -221,7 +248,7 @@ rnExpr (HsLet binds expr) return (HsLet binds' expr', fvExpr) rnExpr (HsDo do_or_lc stmts body _) - = do { ((stmts', body'), fvs) <- rnStmts do_or_lc stmts $ + = do { ((stmts', body'), fvs) <- rnStmts do_or_lc stmts $ \ _ -> rnLExpr body ; return (HsDo do_or_lc stmts' body' placeHolderType, fvs) } @@ -262,11 +289,12 @@ rnExpr (ExprWithTySig expr pty) where doc = text "In an expression type signature" -rnExpr (HsIf p b1 b2) - = rnLExpr p `thenM` \ (p', fvP) -> - rnLExpr b1 `thenM` \ (b1', fvB1) -> - rnLExpr b2 `thenM` \ (b2', fvB2) -> - return (HsIf p' b1' b2', plusFVs [fvP, fvB1, fvB2]) +rnExpr (HsIf _ p b1 b2) + = do { (p', fvP) <- rnLExpr p + ; (b1', fvB1) <- rnLExpr b1 + ; (b2', fvB2) <- rnLExpr b2 + ; (mb_ite, fvITE) <- lookupIfThenElse + ; return (HsIf mb_ite p' b1' b2', plusFVs [fvITE, fvP, fvB1, fvB2]) } rnExpr (HsType a) = rnHsTypeFVs doc a `thenM` \ (t, fvT) -> @@ -320,7 +348,8 @@ rnExpr (HsArrApp arrow arg _ ho rtl) -- infix form rnExpr (HsArrForm op (Just _) [arg1, arg2]) = escapeArrowScope (rnLExpr op) - `thenM` \ (op'@(L _ (HsVar op_name)),fv_op) -> + `thenM` \ (op',fv_op) -> + let L _ (HsVar op_name) = op' in rnCmdTop arg1 `thenM` \ (arg1',fv_arg1) -> rnCmdTop arg2 `thenM` \ (arg2',fv_arg2) -> @@ -429,8 +458,8 @@ convertOpFormsCmd (HsPar c) = HsPar (convertOpFormsLCmd c) convertOpFormsCmd (HsCase exp matches) = HsCase exp (convertOpFormsMatch matches) -convertOpFormsCmd (HsIf exp c1 c2) - = HsIf exp (convertOpFormsLCmd c1) (convertOpFormsLCmd c2) +convertOpFormsCmd (HsIf f exp c1 c2) + = HsIf f exp (convertOpFormsLCmd c1) (convertOpFormsLCmd c2) convertOpFormsCmd (HsLet binds cmd) = HsLet binds (convertOpFormsLCmd cmd) @@ -486,7 +515,7 @@ methodNamesCmd (HsArrForm {}) = emptyFVs methodNamesCmd (HsPar c) = methodNamesLCmd c -methodNamesCmd (HsIf _ c1 c2) +methodNamesCmd (HsIf _ _ c1 c2) = methodNamesLCmd c1 `plusFV` methodNamesLCmd c2 `addOneFV` choiceAName methodNamesCmd (HsLet _ c) = methodNamesLCmd c @@ -605,7 +634,7 @@ rnBracket (DecBrL decls) = do { (group, mb_splice) <- findSplice decls ; case mb_splice of Nothing -> return () - Just (SpliceDecl (L loc _), _) + Just (SpliceDecl (L loc _) _, _) -> setSrcSpan loc $ addErr (ptext (sLit "Declaration splices are not permitted inside declaration brackets")) -- Why not? See Section 7.3 of the TH paper. @@ -618,8 +647,9 @@ rnBracket (DecBrL decls) setStage thRnBrack $ rnSrcDecls group - -- Discard the tcg_env; it contains only extra info about fixity - ; return (DecBrG group', allUses (tcg_dus tcg_env)) } + -- Discard the tcg_env; it contains only extra info about fixity + ; traceRn (text "rnBracket dec" <+> (ppr (tcg_dus tcg_env) $$ ppr (duUses (tcg_dus tcg_env)))) + ; return (DecBrG group', duUses (tcg_dus tcg_env)) } rnBracket (DecBrG _) = panic "rnBracket: unexpected DecBrG" \end{code} @@ -631,16 +661,7 @@ rnBracket (DecBrG _) = panic "rnBracket: unexpected DecBrG" %************************************************************************ \begin{code} -rnStmts :: HsStmtContext Name -> [LStmt RdrName] - -> RnM (thing, FreeVars) - -> RnM (([LStmt Name], thing), FreeVars) --- Variables bound by the Stmts, and mentioned in thing_inside, --- do not appear in the result FreeVars - -rnStmts (MDoExpr _) stmts thing_inside = rnMDoStmts stmts thing_inside -rnStmts ctxt stmts thing_inside = rnNormalStmts ctxt stmts (\ _ -> thing_inside) - -rnNormalStmts :: HsStmtContext Name -> [LStmt RdrName] +rnStmts :: HsStmtContext Name -> [LStmt RdrName] -> ([Name] -> RnM (thing, FreeVars)) -> RnM (([LStmt Name], thing), FreeVars) -- Variables bound by the Stmts, and mentioned in thing_inside, @@ -648,15 +669,15 @@ rnNormalStmts :: HsStmtContext Name -> [LStmt RdrName] -- -- Renaming a single RecStmt can give a sequence of smaller Stmts -rnNormalStmts _ [] thing_inside +rnStmts _ [] thing_inside = do { (res, fvs) <- thing_inside [] ; return (([], res), fvs) } -rnNormalStmts ctxt (stmt@(L loc _) : stmts) thing_inside +rnStmts ctxt (stmt@(L loc _) : stmts) thing_inside = do { ((stmts1, (stmts2, thing)), fvs) <- setSrcSpan loc $ rnStmt ctxt stmt $ \ bndrs1 -> - rnNormalStmts ctxt stmts $ \ bndrs2 -> + rnStmts ctxt stmts $ \ bndrs2 -> thing_inside (bndrs1 ++ bndrs2) ; return (((stmts1 ++ stmts2), thing), fvs) } @@ -704,7 +725,7 @@ rnStmt ctxt (L _ (RecStmt { recS_stmts = rec_stmts })) thing_inside -- for which it's the fwd refs within the bind itself -- (This set may not be empty, because we're in a recursive -- context.) - ; rn_rec_stmts_and_then rec_stmts $ \ segs -> do + ; rnRecStmtsAndThen rec_stmts $ \ segs -> do { let bndrs = nameSetToList $ foldr (unionNameSets . (\(ds,_,_,_) -> ds)) emptyNameSet segs @@ -747,13 +768,15 @@ rnStmt ctxt (L loc (TransformStmt stmts _ using by)) thing_inside ; (using', fvs1) <- rnLExpr using ; ((stmts', (by', used_bndrs, thing)), fvs2) - <- rnNormalStmts (TransformStmtCtxt ctxt) stmts $ \ bndrs -> + <- rnStmts (TransformStmtCtxt ctxt) stmts $ \ bndrs -> do { (by', fvs_by) <- case by of Nothing -> return (Nothing, emptyFVs) Just e -> do { (e', fvs) <- rnLExpr e; return (Just e', fvs) } ; (thing, fvs_thing) <- thing_inside bndrs ; let fvs = fvs_by `plusFV` fvs_thing - used_bndrs = filter (`elemNameSet` fvs_thing) bndrs + used_bndrs = filter (`elemNameSet` fvs) bndrs + -- The paper (Fig 5) has a bug here; we must treat any free varaible of + -- the "thing inside", **or of the by-expression**, as used ; return ((by', used_bndrs, thing), fvs) } ; return (([L loc (TransformStmt stmts' used_bndrs using' by')], thing), @@ -771,7 +794,7 @@ rnStmt ctxt (L loc (GroupStmt stmts _ by using)) thing_inside -- Rename the stmts and the 'by' expression -- Keep track of the variables mentioned in the 'by' expression ; ((stmts', (by', used_bndrs, thing)), fvs2) - <- rnNormalStmts (TransformStmtCtxt ctxt) stmts $ \ bndrs -> + <- rnStmts (TransformStmtCtxt ctxt) stmts $ \ bndrs -> do { (by', fvs_by) <- mapMaybeFvRn rnLExpr by ; (thing, fvs_thing) <- thing_inside bndrs ; let fvs = fvs_by `plusFV` fvs_thing @@ -780,6 +803,7 @@ rnStmt ctxt (L loc (GroupStmt stmts _ by using)) thing_inside ; let all_fvs = fvs1 `plusFV` fvs2 bndr_map = used_bndrs `zip` used_bndrs + -- See Note [GroupStmt binder map] in HsExpr ; traceRn (text "rnStmt: implicitly rebound these used binders:" <+> ppr bndr_map) ; return (([L loc (GroupStmt stmts' bndr_map by' using')], thing), all_fvs) } @@ -807,7 +831,7 @@ rnParallelStmts ctxt segs thing_inside rn_segs env bndrs_so_far ((stmts,_) : segs) = do { ((stmts', (used_bndrs, segs', thing)), fvs) - <- rnNormalStmts ctxt stmts $ \ bndrs -> + <- rnStmts ctxt stmts $ \ bndrs -> setLocalRdrEnv env $ do { ((segs', thing), fvs) <- rn_segs env (bndrs ++ bndrs_so_far) segs ; let used_bndrs = filter (`elemNameSet` fvs) bndrs @@ -855,28 +879,13 @@ type Segment stmts = (Defs, stmts) -- Either Stmt or [Stmt] ----------------------------------------------------- - -rnMDoStmts :: [LStmt RdrName] - -> RnM (thing, FreeVars) - -> RnM (([LStmt Name], thing), FreeVars) -rnMDoStmts stmts thing_inside - = rn_rec_stmts_and_then stmts $ \ segs -> do - { (thing, fvs_later) <- thing_inside - ; let segs_w_fwd_refs = addFwdRefs segs - grouped_segs = glomSegments segs_w_fwd_refs - (stmts', fvs) = segsToStmts emptyRecStmt grouped_segs fvs_later - ; return ((stmts', thing), fvs) } - ---------------------------------------------- - -- wrapper that does both the left- and right-hand sides -rn_rec_stmts_and_then :: [LStmt RdrName] +rnRecStmtsAndThen :: [LStmt RdrName] -- assumes that the FreeVars returned includes -- the FreeVars of the Segments -> ([Segment (LStmt Name)] -> RnM (a, FreeVars)) -> RnM (a, FreeVars) -rn_rec_stmts_and_then s cont +rnRecStmtsAndThen s cont = do { -- (A) Make the mini fixity env for all of the stmts fix_env <- makeMiniFixityEnv (collectRecStmtsFixities s) @@ -885,12 +894,15 @@ rn_rec_stmts_and_then s cont -- ...bring them and their fixities into scope ; let bound_names = collectLStmtsBinders (map fst new_lhs_and_fv) - ; bindLocalNamesFV_WithFixities bound_names fix_env $ do + -- Fake uses of variables introduced implicitly (warning suppression, see #4404) + implicit_uses = lStmtsImplicits (map fst new_lhs_and_fv) + ; bindLocalNamesFV bound_names $ + addLocalFixities fix_env bound_names $ do -- (C) do the right-hand-sides and thing-inside { segs <- rn_rec_stmts bound_names new_lhs_and_fv ; (res, fvs) <- cont segs - ; warnUnusedLocalBinds bound_names fvs + ; warnUnusedLocalBinds bound_names (fvs `unionNameSets` implicit_uses) ; return (res, fvs) }} -- get all the fixity decls in any Let stmt @@ -927,7 +939,7 @@ rn_rec_stmt_lhs _ (L _ (LetStmt binds@(HsIPBinds _))) = failWith (badIpBinds (ptext (sLit "an mdo expression")) binds) rn_rec_stmt_lhs fix_env (L loc (LetStmt (HsValBinds binds))) - = do (_bound_names, binds') <- rnValBindsLHS fix_env binds + = do (_bound_names, binds') <- rnLocalValBindsLHS fix_env binds return [(L loc (LetStmt (HsValBinds binds')), -- Warning: this is bogus; see function invariant emptyFVs @@ -990,10 +1002,10 @@ rn_rec_stmt _ (L _ (LetStmt binds@(HsIPBinds _))) _ rn_rec_stmt all_bndrs (L loc (LetStmt (HsValBinds binds'))) _ = do (binds', du_binds) <- - -- fixities and unused are handled above in rn_rec_stmts_and_then - rnValBindsRHS (mkNameSet all_bndrs) binds' - return [(duDefs du_binds, duUses du_binds, - emptyNameSet, L loc (LetStmt (HsValBinds binds')))] + -- fixities and unused are handled above in rnRecStmtsAndThen + rnLocalValBindsRHS (mkNameSet all_bndrs) binds' + return [(duDefs du_binds, allUses du_binds, + emptyNameSet, L loc (LetStmt (HsValBinds binds')))] -- no RecStmt case becuase they get flattened above when doing the LHSes rn_rec_stmt _ stmt@(L _ (RecStmt {})) _ @@ -1163,16 +1175,16 @@ checkLetStmt _ctxt _binds = return () --------- checkRecStmt :: HsStmtContext Name -> RnM () -checkRecStmt (MDoExpr {}) = return () -- Recursive stmt ok in 'mdo' -checkRecStmt (DoExpr {}) = return () -- and in 'do' -checkRecStmt ctxt = addErr msg +checkRecStmt MDoExpr = return () -- Recursive stmt ok in 'mdo' +checkRecStmt DoExpr = return () -- and in 'do' +checkRecStmt ctxt = addErr msg where msg = ptext (sLit "Illegal 'rec' stmt in") <+> pprStmtContext ctxt --------- checkParStmt :: HsStmtContext Name -> RnM () checkParStmt _ - = do { parallel_list_comp <- doptM Opt_ParallelListComp + = do { parallel_list_comp <- xoptM Opt_ParallelListComp ; checkErr parallel_list_comp msg } where msg = ptext (sLit "Illegal parallel list comprehension: use -XParallelListComp") @@ -1181,7 +1193,7 @@ checkParStmt _ checkTransformStmt :: HsStmtContext Name -> RnM () checkTransformStmt ListComp -- Ensure we are really within a list comprehension because otherwise the -- desugarer will break when we come to operate on a parallel array - = do { transform_list_comp <- doptM Opt_TransformListComp + = do { transform_list_comp <- xoptM Opt_TransformListComp ; checkErr transform_list_comp msg } where msg = ptext (sLit "Illegal transform or grouping list comprehension: use -XTransformListComp") @@ -1194,7 +1206,7 @@ checkTransformStmt ctxt = addErr msg --------- checkTupleSection :: [HsTupArg RdrName] -> RnM () checkTupleSection args - = do { tuple_section <- doptM Opt_TupleSections + = do { tuple_section <- xoptM Opt_TupleSections ; checkErr (all tupArgPresent args || tuple_section) msg } where msg = ptext (sLit "Illegal tuple section: use -XTupleSections")