diff options
Diffstat (limited to 'compiler/rename')
| -rw-r--r-- | compiler/rename/RnEnv.lhs | 80 | ||||
| -rw-r--r-- | compiler/rename/RnExpr.lhs | 848 | ||||
| -rw-r--r-- | compiler/rename/RnNames.lhs | 94 | ||||
| -rw-r--r-- | compiler/rename/RnPat.lhs | 13 | ||||
| -rw-r--r-- | compiler/rename/RnSource.lhs | 30 | ||||
| -rw-r--r-- | compiler/rename/RnTypes.lhs | 541 |
6 files changed, 824 insertions, 782 deletions
diff --git a/compiler/rename/RnEnv.lhs b/compiler/rename/RnEnv.lhs index 90061b10a2..d73b537af0 100644 --- a/compiler/rename/RnEnv.lhs +++ b/compiler/rename/RnEnv.lhs @@ -25,7 +25,7 @@ module RnEnv ( newLocalBndrRn, newLocalBndrsRn, bindLocalName, bindLocalNames, bindLocalNamesFV, - MiniFixityEnv, emptyFsEnv, extendFsEnv, lookupFsEnv, + MiniFixityEnv, addLocalFixities, bindLocatedLocalsFV, bindLocatedLocalsRn, extendTyVarEnvFVRn, @@ -36,7 +36,10 @@ module RnEnv ( warnUnusedMatches, warnUnusedTopBinds, warnUnusedLocalBinds, dataTcOccs, unknownNameErr, kindSigErr, perhapsForallMsg, - HsDocContext(..), docOfHsDocContext + HsDocContext(..), docOfHsDocContext, + + -- FsEnv + FastStringEnv, emptyFsEnv, lookupFsEnv, extendFsEnv, mkFsEnv ) where #include "HsVersions.h" @@ -57,8 +60,9 @@ import Module import UniqFM import DataCon ( dataConFieldLabels, dataConTyCon ) import TyCon ( isTupleTyCon, tyConArity ) -import PrelNames ( mkUnboundName, rOOT_MAIN, forall_tv_RDR ) +import PrelNames ( mkUnboundName, isUnboundName, rOOT_MAIN, forall_tv_RDR ) import ErrUtils ( MsgDoc ) +import BasicTypes ( Fixity(..), FixityDirection(..), minPrecedence ) import SrcLoc import Outputable import Util @@ -72,12 +76,6 @@ import qualified Data.Set as Set import Constants ( mAX_TUPLE_SIZE ) \end{code} -\begin{code} --- XXX -thenM :: Monad a => a b -> (b -> a c) -> a c -thenM = (>>=) -\end{code} - %********************************************************* %* * Source-code binders @@ -530,8 +528,8 @@ we'll miss the fact that the qualified import is redundant. \begin{code} getLookupOccRn :: RnM (Name -> Maybe Name) getLookupOccRn - = getLocalRdrEnv `thenM` \ local_env -> - return (lookupLocalRdrOcc local_env . nameOccName) + = do local_env <- getLocalRdrEnv + return (lookupLocalRdrOcc local_env . nameOccName) lookupLocatedOccRn :: Located RdrName -> RnM (Located Name) lookupLocatedOccRn = wrapLocM lookupOccRn @@ -814,15 +812,15 @@ lookupQualifiedName rdr_name | Just (mod,occ) <- isQual_maybe rdr_name -- Note: we want to behave as we would for a source file import here, -- and respect hiddenness of modules/packages, hence loadSrcInterface. - = loadSrcInterface doc mod False Nothing `thenM` \ iface -> + = do iface <- loadSrcInterface doc mod False Nothing - case [ name - | avail <- mi_exports iface, - name <- availNames avail, - nameOccName name == occ ] of - (n:ns) -> ASSERT (null ns) return (Just n) - _ -> do { traceRn (text "lookupQualified" <+> ppr rdr_name) - ; return Nothing } + case [ name + | avail <- mi_exports iface, + name <- availNames avail, + nameOccName name == occ ] of + (n:ns) -> ASSERT(null ns) return (Just n) + _ -> do { traceRn (text "lookupQualified" <+> ppr rdr_name) + ; return Nothing } | otherwise = pprPanic "RnEnv.lookupQualifiedName" (ppr rdr_name) @@ -1040,10 +1038,12 @@ type FastStringEnv a = UniqFM a -- Keyed by FastString emptyFsEnv :: FastStringEnv a lookupFsEnv :: FastStringEnv a -> FastString -> Maybe a extendFsEnv :: FastStringEnv a -> FastString -> a -> FastStringEnv a +mkFsEnv :: [(FastString,a)] -> FastStringEnv a emptyFsEnv = emptyUFM lookupFsEnv = lookupUFM extendFsEnv = addToUFM +mkFsEnv = listToUFM -------------------------------- type MiniFixityEnv = FastStringEnv (Located Fixity) @@ -1090,14 +1090,25 @@ lookupFixity is a bit strange. \begin{code} lookupFixityRn :: Name -> RnM Fixity lookupFixityRn name - = getModule `thenM` \ this_mod -> - if nameIsLocalOrFrom this_mod name - then do -- It's defined in this module - local_fix_env <- getFixityEnv - traceRn (text "lookupFixityRn: looking up name in local environment:" <+> - vcat [ppr name, ppr local_fix_env]) - return $ lookupFixity local_fix_env name - else -- It's imported + | isUnboundName name + = return (Fixity minPrecedence InfixL) + -- Minimise errors from ubound names; eg + -- a>0 `foo` b>0 + -- where 'foo' is not in scope, should not give an error (Trac #7937) + + | otherwise + = do { this_mod <- getModule + ; if nameIsLocalOrFrom this_mod name + then lookup_local + else lookup_imported } + where + lookup_local -- It's defined in this module + = do { local_fix_env <- getFixityEnv + ; traceRn (text "lookupFixityRn: looking up name in local environment:" <+> + vcat [ppr name, ppr local_fix_env]) + ; return (lookupFixity local_fix_env name) } + + lookup_imported -- For imported names, we have to get their fixities by doing a -- loadInterfaceForName, and consulting the Ifaces that comes back -- from that, because the interface file for the Name might not @@ -1114,12 +1125,11 @@ lookupFixityRn name -- -- loadInterfaceForName will find B.hi even if B is a hidden module, -- and that's what we want. - loadInterfaceForName doc name `thenM` \ iface -> do { - traceRn (text "lookupFixityRn: looking up name in iface cache and found:" <+> - vcat [ppr name, ppr $ mi_fix_fn iface (nameOccName name)]); - return (mi_fix_fn iface (nameOccName name)) - } - where + = do { iface <- loadInterfaceForName doc name + ; traceRn (text "lookupFixityRn: looking up name in iface cache and found:" <+> + vcat [ppr name, ppr $ mi_fix_fn iface (nameOccName name)]) + ; return (mi_fix_fn iface (nameOccName name)) } + doc = ptext (sLit "Checking fixity for") <+> ppr name --------------- @@ -1262,8 +1272,8 @@ bindLocatedLocalsFV :: [Located RdrName] -> ([Name] -> RnM (a,FreeVars)) -> RnM (a, FreeVars) bindLocatedLocalsFV rdr_names enclosed_scope = bindLocatedLocalsRn rdr_names $ \ names -> - enclosed_scope names `thenM` \ (thing, fvs) -> - return (thing, delFVs names fvs) + do (thing, fvs) <- enclosed_scope names + return (thing, delFVs names fvs) ------------------------------------- diff --git a/compiler/rename/RnExpr.lhs b/compiler/rename/RnExpr.lhs index 29674ca34c..0ef169085b 100644 --- a/compiler/rename/RnExpr.lhs +++ b/compiler/rename/RnExpr.lhs @@ -10,45 +10,38 @@ general, all of these functions return a renamed thing, and a set of free variables. \begin{code} -{-# OPTIONS -fno-warn-tabs #-} --- The above warning supression flag is a temporary kludge. --- While working on this module you are encouraged to remove it and --- detab the module (please do the detabbing in a separate patch). See --- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces --- for details - module RnExpr ( - rnLExpr, rnExpr, rnStmts + rnLExpr, rnExpr, rnStmts ) where #include "HsVersions.h" #ifdef GHCI import {-# SOURCE #-} TcSplice( runQuasiQuoteExpr ) -#endif /* GHCI */ +#endif /* GHCI */ import RnSource ( rnSrcDecls, findSplice ) import RnBinds ( rnLocalBindsAndThen, rnLocalValBindsLHS, rnLocalValBindsRHS, - rnMatchGroup, rnGRHS, makeMiniFixityEnv) + rnMatchGroup, rnGRHS, makeMiniFixityEnv) import HsSyn import TcRnMonad -import TcEnv ( thRnBrack ) +import TcEnv ( thRnBrack ) import RnEnv import RnTypes import RnPat import DynFlags -import BasicTypes ( FixityDirection(..) ) +import BasicTypes ( FixityDirection(..) ) import PrelNames import Module import Name import NameSet import RdrName -import LoadIface ( loadInterfaceForName ) +import LoadIface ( loadInterfaceForName ) import UniqSet import Data.List import Util -import ListSetOps ( removeDups ) +import ListSetOps ( removeDups ) import Outputable import SrcLoc import FastString @@ -67,9 +60,9 @@ thenM_ = (>>) \end{code} %************************************************************************ -%* * +%* * \subsubsection{Expressions} -%* * +%* * %************************************************************************ \begin{code} @@ -78,18 +71,18 @@ rnExprs ls = rnExprs' ls emptyUniqSet where rnExprs' [] acc = return ([], acc) rnExprs' (expr:exprs) acc - = rnLExpr expr `thenM` \ (expr', fvExpr) -> + = rnLExpr expr `thenM` \ (expr', fvExpr) -> - -- Now we do a "seq" on the free vars because typically it's small - -- or empty, especially in very long lists of constants + -- Now we do a "seq" on the free vars because typically it's small + -- or empty, especially in very long lists of constants let - acc' = acc `plusFV` fvExpr + acc' = acc `plusFV` fvExpr in acc' `seq` rnExprs' exprs acc' `thenM` \ (exprs', fvExprs) -> return (expr':exprs', fvExprs) \end{code} -Variables. We look up the variable and return the resulting name. +Variables. We look up the variable and return the resulting name. \begin{code} rnLExpr :: LHsExpr RdrName -> RnM (LHsExpr Name, FreeVars) @@ -101,12 +94,12 @@ finishHsVar :: Name -> RnM (HsExpr Name, FreeVars) -- Separated from rnExpr because it's also used -- when renaming infix expressions -- See Note [Adding the implicit parameter to 'assert'] -finishHsVar name +finishHsVar name = do { ignore_asserts <- goptM Opt_IgnoreAsserts ; if ignore_asserts || not (name `hasKey` assertIdKey) - then return (HsVar name, unitFV name) - else do { e <- mkAssertErrorExpr - ; return (e, unitFV name) } } + then return (HsVar name, unitFV name) + else do { e <- mkAssertErrorExpr + ; return (e, unitFV name) } } rnExpr (HsVar v) = do { mb_name <- lookupOccRn_maybe v @@ -115,11 +108,11 @@ rnExpr (HsVar v) ; if opt_TypeHoles && startsWithUnderscore (rdrNameOcc v) then return (HsUnboundVar v, emptyFVs) else do { n <- reportUnboundName v; finishHsVar n } } ; - Just name + Just name | name == nilDataConName -- Treat [] as an ExplicitList, so that -- OverloadedLists works correctly -> rnExpr (ExplicitList placeHolderType Nothing []) - | otherwise + | otherwise -> finishHsVar name } } rnExpr (HsIPVar v) @@ -130,48 +123,48 @@ rnExpr (HsLit lit@(HsString s)) opt_OverloadedStrings <- xoptM Opt_OverloadedStrings ; if opt_OverloadedStrings then rnExpr (HsOverLit (mkHsIsString s placeHolderType)) - else -- Same as below - rnLit lit `thenM_` + else -- Same as below + rnLit lit `thenM_` return (HsLit lit, emptyFVs) } -rnExpr (HsLit lit) - = rnLit lit `thenM_` +rnExpr (HsLit lit) + = rnLit lit `thenM_` return (HsLit lit, emptyFVs) -rnExpr (HsOverLit lit) - = rnOverLit lit `thenM` \ (lit', fvs) -> +rnExpr (HsOverLit lit) + = rnOverLit lit `thenM` \ (lit', fvs) -> return (HsOverLit lit', fvs) rnExpr (HsApp fun arg) - = rnLExpr fun `thenM` \ (fun',fvFun) -> - rnLExpr arg `thenM` \ (arg',fvArg) -> + = rnLExpr fun `thenM` \ (fun',fvFun) -> + 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 - ; (e2', fv_e2) <- rnLExpr e2 - ; op_name <- setSrcSpan op_loc (lookupOccRn op_rdr) - ; (op', fv_op) <- finishHsVar op_name - -- NB: op' is usually just a variable, but might be - -- an applicatoin (assert "Foo.hs:47") - -- Deal with fixity - -- When renaming code synthesised from "deriving" declarations - -- we used to avoid fixity stuff, but we can't easily tell any - -- more, so I've removed the test. Adding HsPars in TcGenDeriv - -- should prevent bad things happening. - ; 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) } + ; (e2', fv_e2) <- rnLExpr e2 + ; op_name <- setSrcSpan op_loc (lookupOccRn op_rdr) + ; (op', fv_op) <- finishHsVar op_name + -- NB: op' is usually just a variable, but might be + -- an applicatoin (assert "Foo.hs:47") + -- Deal with fixity + -- When renaming code synthesised from "deriving" declarations + -- we used to avoid fixity stuff, but we can't easily tell any + -- more, so I've removed the test. Adding HsPars in TcGenDeriv + -- should prevent bad things happening. + ; 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 "Infix 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) -> - lookupSyntaxName negateName `thenM` \ (neg_name, fv_neg) -> - mkNegAppRn e' neg_name `thenM` \ final_e -> + = rnLExpr e `thenM` \ (e', fv_e) -> + lookupSyntaxName negateName `thenM` \ (neg_name, fv_neg) -> + mkNegAppRn e' neg_name `thenM` \ final_e -> return (final_e, fv_e `plusFV` fv_neg) ------------------------------------------ @@ -189,36 +182,36 @@ rnExpr e@(HsBracket br_body) return (HsBracket body', fvs_e) rnExpr (HsSpliceE splice) - = rnSplice splice `thenM` \ (splice', fvs) -> + = rnSplice splice `thenM` \ (splice', fvs) -> return (HsSpliceE splice', fvs) #ifndef GHCI rnExpr e@(HsQuasiQuoteE _) = pprPanic "Cant do quasiquotation without GHCi" (ppr e) #else rnExpr (HsQuasiQuoteE qq) - = runQuasiQuoteExpr qq `thenM` \ (L _ expr') -> + = runQuasiQuoteExpr qq `thenM` \ (L _ expr') -> rnExpr expr' -#endif /* GHCI */ +#endif /* GHCI */ --------------------------------------------- --- Sections +-- Sections -- See Note [Parsing sections] in Parser.y.pp rnExpr (HsPar (L loc (section@(SectionL {})))) - = do { (section', fvs) <- rnSection section - ; return (HsPar (L loc section'), fvs) } + = do { (section', fvs) <- rnSection section + ; return (HsPar (L loc section'), fvs) } rnExpr (HsPar (L loc (section@(SectionR {})))) - = do { (section', fvs) <- rnSection section - ; return (HsPar (L loc section'), fvs) } + = do { (section', fvs) <- rnSection section + ; return (HsPar (L loc section'), fvs) } rnExpr (HsPar e) - = do { (e', fvs_e) <- rnLExpr e - ; return (HsPar e', fvs_e) } + = do { (e', fvs_e) <- rnLExpr e + ; return (HsPar e', fvs_e) } rnExpr expr@(SectionL {}) - = do { addErr (sectionErr expr); rnSection expr } + = do { addErr (sectionErr expr); rnSection expr } rnExpr expr@(SectionR {}) - = do { addErr (sectionErr expr); rnSection expr } + = do { addErr (sectionErr expr); rnSection expr } --------------------------------------------- rnExpr (HsCoreAnn ann expr) @@ -226,10 +219,10 @@ rnExpr (HsCoreAnn ann expr) return (HsCoreAnn ann expr', fvs_expr) rnExpr (HsSCC lbl expr) - = rnLExpr expr `thenM` \ (expr', fvs_expr) -> + = rnLExpr expr `thenM` \ (expr', fvs_expr) -> return (HsSCC lbl expr', fvs_expr) rnExpr (HsTickPragma info expr) - = rnLExpr expr `thenM` \ (expr', fvs_expr) -> + = rnLExpr expr `thenM` \ (expr', fvs_expr) -> return (HsTickPragma info expr', fvs_expr) rnExpr (HsLam matches) @@ -237,7 +230,7 @@ rnExpr (HsLam matches) return (HsLam matches', fvMatch) rnExpr (HsLamCase arg matches) - = rnMatchGroup CaseAlt rnLExpr matches `thenM` \ (matches', fvs_ms) -> + = rnMatchGroup CaseAlt rnLExpr matches `thenM` \ (matches', fvs_ms) -> return (HsLamCase arg matches', fvs_ms) rnExpr (HsCase expr matches) @@ -246,26 +239,26 @@ rnExpr (HsCase expr matches) return (HsCase new_expr new_matches, e_fvs `plusFV` ms_fvs) rnExpr (HsLet binds expr) - = rnLocalBindsAndThen binds $ \ binds' -> - rnLExpr expr `thenM` \ (expr',fvExpr) -> + = rnLocalBindsAndThen binds $ \ binds' -> + rnLExpr expr `thenM` \ (expr',fvExpr) -> return (HsLet binds' expr', fvExpr) rnExpr (HsDo do_or_lc stmts _) - = do { ((stmts', _), fvs) <- rnStmts do_or_lc rnLExpr stmts (\ _ -> return ((), emptyFVs)) - ; return ( HsDo do_or_lc stmts' placeHolderType, fvs ) } + = do { ((stmts', _), fvs) <- rnStmts do_or_lc rnLExpr stmts (\ _ -> return ((), emptyFVs)) + ; return ( HsDo do_or_lc stmts' placeHolderType, fvs ) } rnExpr (ExplicitList _ _ exps) = do { opt_OverloadedLists <- xoptM Opt_OverloadedLists ; (exps', fvs) <- rnExprs exps - ; if opt_OverloadedLists + ; if opt_OverloadedLists then do { - ; (from_list_n_name, fvs') <- lookupSyntaxName fromListNName - ; return (ExplicitList placeHolderType (Just from_list_n_name) exps', fvs `plusFV` fvs') } + ; (from_list_n_name, fvs') <- lookupSyntaxName fromListNName + ; return (ExplicitList placeHolderType (Just from_list_n_name) exps', fvs `plusFV` fvs') } else return (ExplicitList placeHolderType Nothing exps', fvs) } rnExpr (ExplicitPArr _ exps) - = rnExprs exps `thenM` \ (exps', fvs) -> + = rnExprs exps `thenM` \ (exps', fvs) -> return (ExplicitPArr placeHolderType exps', fvs) rnExpr (ExplicitTuple tup_args boxity) @@ -278,22 +271,22 @@ rnExpr (ExplicitTuple tup_args boxity) rnTupArg (Missing _) = return (Missing placeHolderType, emptyFVs) rnExpr (RecordCon con_id _ rbinds) - = do { conname <- lookupLocatedOccRn con_id - ; (rbinds', fvRbinds) <- rnHsRecBinds (HsRecFieldCon (unLoc conname)) rbinds - ; return (RecordCon conname noPostTcExpr rbinds', - fvRbinds `addOneFV` unLoc conname) } + = do { conname <- lookupLocatedOccRn con_id + ; (rbinds', fvRbinds) <- rnHsRecBinds (HsRecFieldCon (unLoc conname)) rbinds + ; return (RecordCon conname noPostTcExpr rbinds', + fvRbinds `addOneFV` unLoc conname) } rnExpr (RecordUpd expr rbinds _ _ _) - = do { (expr', fvExpr) <- rnLExpr expr - ; (rbinds', fvRbinds) <- rnHsRecBinds HsRecFieldUpd rbinds - ; return (RecordUpd expr' rbinds' [] [] [], - fvExpr `plusFV` fvRbinds) } + = do { (expr', fvExpr) <- rnLExpr expr + ; (rbinds', fvRbinds) <- rnHsRecBinds HsRecFieldUpd rbinds + ; return (RecordUpd expr' rbinds' [] [] [], + fvExpr `plusFV` fvRbinds) } rnExpr (ExprWithTySig expr pty) - = do { (pty', fvTy) <- rnLHsType ExprWithTySigCtx pty - ; (expr', fvExpr) <- bindSigTyVarsFV (hsExplicitTvs pty') $ - rnLExpr expr - ; return (ExprWithTySig expr' pty', fvExpr `plusFV` fvTy) } + = do { (pty', fvTy) <- rnLHsType ExprWithTySigCtx pty + ; (expr', fvExpr) <- bindSigTyVarsFV (hsExplicitTvs pty') $ + rnLExpr expr + ; return (ExprWithTySig expr' pty', fvExpr `plusFV` fvTy) } rnExpr (HsIf _ p b1 b2) = do { (p', fvP) <- rnLExpr p @@ -307,21 +300,21 @@ rnExpr (HsMultiIf ty alts) ; return (HsMultiIf ty alts', fvs) } rnExpr (HsType a) - = rnLHsType HsTypeCtx a `thenM` \ (t, fvT) -> + = rnLHsType HsTypeCtx a `thenM` \ (t, fvT) -> return (HsType t, fvT) rnExpr (ArithSeq _ _ seq) = do { opt_OverloadedLists <- xoptM Opt_OverloadedLists ; (new_seq, fvs) <- rnArithSeq seq - ; if opt_OverloadedLists + ; if opt_OverloadedLists then do { - ; (from_list_name, fvs') <- lookupSyntaxName fromListName - ; return (ArithSeq noPostTcExpr (Just from_list_name) new_seq, fvs `plusFV` fvs') } + ; (from_list_name, fvs') <- lookupSyntaxName fromListName + ; return (ArithSeq noPostTcExpr (Just from_list_name) new_seq, fvs `plusFV` fvs') } else return (ArithSeq noPostTcExpr Nothing new_seq, fvs) } rnExpr (PArrSeq _ seq) - = rnArithSeq seq `thenM` \ (new_seq, fvs) -> + = rnArithSeq seq `thenM` \ (new_seq, fvs) -> return (PArrSeq noPostTcExpr new_seq, fvs) \end{code} @@ -341,16 +334,16 @@ rnExpr e@(ELazyPat {}) = patSynErr e \end{code} %************************************************************************ -%* * - Arrow notation -%* * +%* * + Arrow notation +%* * %************************************************************************ \begin{code} rnExpr (HsProc pat body) = newArrowScope $ rnPat ProcExpr pat $ \ pat' -> - rnCmdTop body `thenM` \ (body',fvBody) -> + rnCmdTop body `thenM` \ (body',fvBody) -> return (HsProc pat' body', fvBody) -- Ideally, these would be done in parsing, but to keep parsing simple, we do it here. @@ -358,7 +351,7 @@ rnExpr e@(HsArrApp {}) = arrowFail e rnExpr e@(HsArrForm {}) = arrowFail e rnExpr other = pprPanic "rnExpr: unexpected expression" (ppr other) - -- HsWrap + -- HsWrap hsHoleExpr :: HsExpr Name hsHoleExpr = HsUnboundVar (mkRdrUnqual (mkVarOcc "_")) @@ -375,24 +368,24 @@ arrowFail e -- See Note [Parsing sections] in Parser.y.pp rnSection :: HsExpr RdrName -> RnM (HsExpr Name, FreeVars) rnSection section@(SectionR op expr) - = do { (op', fvs_op) <- rnLExpr op - ; (expr', fvs_expr) <- rnLExpr expr - ; checkSectionPrec InfixR section op' expr' - ; return (SectionR op' expr', fvs_op `plusFV` fvs_expr) } + = do { (op', fvs_op) <- rnLExpr op + ; (expr', fvs_expr) <- rnLExpr expr + ; checkSectionPrec InfixR section op' expr' + ; return (SectionR op' expr', fvs_op `plusFV` fvs_expr) } rnSection section@(SectionL expr op) - = do { (expr', fvs_expr) <- rnLExpr expr - ; (op', fvs_op) <- rnLExpr op - ; checkSectionPrec InfixL section op' expr' - ; return (SectionL expr' op', fvs_op `plusFV` fvs_expr) } + = do { (expr', fvs_expr) <- rnLExpr expr + ; (op', fvs_op) <- rnLExpr op + ; checkSectionPrec InfixL section op' expr' + ; return (SectionL expr' op', fvs_op `plusFV` fvs_expr) } rnSection other = pprPanic "rnSection" (ppr other) \end{code} %************************************************************************ -%* * - Records -%* * +%* * + Records +%* * %************************************************************************ \begin{code} @@ -401,40 +394,40 @@ rnHsRecBinds :: HsRecFieldContext -> HsRecordBinds RdrName rnHsRecBinds ctxt rec_binds@(HsRecFields { rec_dotdot = dd }) = do { (flds, fvs) <- rnHsRecFields1 ctxt HsVar rec_binds ; (flds', fvss) <- mapAndUnzipM rn_field flds - ; return (HsRecFields { rec_flds = flds', rec_dotdot = dd }, + ; return (HsRecFields { rec_flds = flds', rec_dotdot = dd }, fvs `plusFV` plusFVs fvss) } - where + where rn_field fld = do { (arg', fvs) <- rnLExpr (hsRecFieldArg fld) ; return (fld { hsRecFieldArg = arg' }, fvs) } \end{code} %************************************************************************ -%* * - Arrow commands -%* * +%* * + Arrow commands +%* * %************************************************************************ \begin{code} rnCmdArgs :: [LHsCmdTop RdrName] -> RnM ([LHsCmdTop Name], FreeVars) rnCmdArgs [] = return ([], emptyFVs) rnCmdArgs (arg:args) - = rnCmdTop arg `thenM` \ (arg',fvArg) -> - rnCmdArgs args `thenM` \ (args',fvArgs) -> + = rnCmdTop arg `thenM` \ (arg',fvArg) -> + rnCmdArgs args `thenM` \ (args',fvArgs) -> return (arg':args', fvArg `plusFV` fvArgs) rnCmdTop :: LHsCmdTop RdrName -> RnM (LHsCmdTop Name, FreeVars) rnCmdTop = wrapLocFstM rnCmdTop' where - rnCmdTop' (HsCmdTop cmd _ _ _) + rnCmdTop' (HsCmdTop cmd _ _ _) = do { (cmd', fvCmd) <- rnLCmd cmd ; let cmd_names = [arrAName, composeAName, firstAName] ++ - nameSetToList (methodNamesCmd (unLoc cmd')) - -- Generate the rebindable syntax for the monad + nameSetToList (methodNamesCmd (unLoc cmd')) + -- Generate the rebindable syntax for the monad ; (cmd_names', cmd_fvs) <- lookupSyntaxNames cmd_names - ; return (HsCmdTop cmd' placeHolderType placeHolderType (cmd_names `zip` cmd_names'), - fvCmd `plusFV` cmd_fvs) } + ; return (HsCmdTop cmd' placeHolderType placeHolderType (cmd_names `zip` cmd_names'), + fvCmd `plusFV` cmd_fvs) } rnLCmd :: LHsCmd RdrName -> RnM (LHsCmd Name, FreeVars) rnLCmd = wrapLocFstM rnCmd @@ -451,10 +444,10 @@ rnCmd (HsCmdArrApp arrow arg _ ho rtl) HsHigherOrderApp -> tc HsFirstOrderApp -> escapeArrowScope tc -- See Note [Escaping the arrow scope] in TcRnTypes - -- Before renaming 'arrow', use the environment of the enclosing - -- proc for the (-<) case. - -- Local bindings, inside the enclosing proc, are not in scope - -- inside 'arrow'. In the higher-order case (-<<), they are. + -- Before renaming 'arrow', use the environment of the enclosing + -- proc for the (-<) case. + -- Local bindings, inside the enclosing proc, are not in scope + -- inside 'arrow'. In the higher-order case (-<<), they are. -- infix form rnCmd (HsCmdArrForm op (Just _) [arg1, arg2]) @@ -467,7 +460,7 @@ rnCmd (HsCmdArrForm op (Just _) [arg1, arg2]) -- Deal with fixity lookupFixityRn op_name `thenM` \ fixity -> - mkOpFormRn arg1' op' fixity arg2' `thenM` \ final_e -> + mkOpFormRn arg1' op' fixity arg2' `thenM` \ final_e -> return (final_e, fv_arg1 `plusFV` fv_op `plusFV` fv_arg2) @@ -514,8 +507,8 @@ rnCmd (HsCmdDo stmts _) rnCmd cmd@(HsCmdCast {}) = pprPanic "rnCmd" (ppr cmd) --------------------------------------------------- -type CmdNeeds = FreeVars -- Only inhabitants are - -- appAName, choiceAName, loopAName +type CmdNeeds = FreeVars -- Only inhabitants are + -- appAName, choiceAName, loopAName -- find what methods the Cmd needs (loop, choice, apply) methodNamesLCmd :: LHsCmd Name -> CmdNeeds @@ -536,7 +529,7 @@ methodNamesCmd (HsCmdIf _ _ c1 c2) = methodNamesLCmd c1 `plusFV` methodNamesLCmd c2 `addOneFV` choiceAName methodNamesCmd (HsCmdLet _ c) = methodNamesLCmd c -methodNamesCmd (HsCmdDo stmts _) = methodNamesStmts stmts +methodNamesCmd (HsCmdDo stmts _) = methodNamesStmts stmts methodNamesCmd (HsCmdApp c _) = methodNamesLCmd c methodNamesCmd (HsCmdLam match) = methodNamesMatch match @@ -544,7 +537,7 @@ methodNamesCmd (HsCmdCase _ matches) = methodNamesMatch matches `addOneFV` choiceAName --methodNamesCmd _ = emptyFVs - -- Other forms can't occur in commands, but it's not convenient + -- Other forms can't occur in commands, but it's not convenient -- to error here so we just do what's convenient. -- The type checker will complain later @@ -552,7 +545,7 @@ methodNamesCmd (HsCmdCase _ matches) methodNamesMatch :: MatchGroup Name (LHsCmd Name) -> FreeVars methodNamesMatch (MG { mg_alts = ms }) = plusFVs (map do_one ms) - where + where do_one (L _ (Match _ _ grhss)) = methodNamesGRHSs grhss ------------------------------------------------- @@ -581,107 +574,107 @@ methodNamesStmt (RecStmt { recS_stmts = stmts }) = methodNamesStmts stmts `addOn methodNamesStmt (LetStmt {}) = emptyFVs methodNamesStmt (ParStmt {}) = emptyFVs methodNamesStmt (TransStmt {}) = emptyFVs - -- ParStmt and TransStmt can't occur in commands, but it's not convenient to error + -- ParStmt and TransStmt can't occur in commands, but it's not convenient to error -- here so we just do what's convenient \end{code} %************************************************************************ -%* * - Arithmetic sequences -%* * +%* * + Arithmetic sequences +%* * %************************************************************************ \begin{code} rnArithSeq :: ArithSeqInfo RdrName -> RnM (ArithSeqInfo Name, FreeVars) rnArithSeq (From expr) - = rnLExpr expr `thenM` \ (expr', fvExpr) -> + = rnLExpr expr `thenM` \ (expr', fvExpr) -> return (From expr', fvExpr) rnArithSeq (FromThen expr1 expr2) - = rnLExpr expr1 `thenM` \ (expr1', fvExpr1) -> - rnLExpr expr2 `thenM` \ (expr2', fvExpr2) -> + = rnLExpr expr1 `thenM` \ (expr1', fvExpr1) -> + rnLExpr expr2 `thenM` \ (expr2', fvExpr2) -> return (FromThen expr1' expr2', fvExpr1 `plusFV` fvExpr2) rnArithSeq (FromTo expr1 expr2) - = rnLExpr expr1 `thenM` \ (expr1', fvExpr1) -> - rnLExpr expr2 `thenM` \ (expr2', fvExpr2) -> + = rnLExpr expr1 `thenM` \ (expr1', fvExpr1) -> + rnLExpr expr2 `thenM` \ (expr2', fvExpr2) -> return (FromTo expr1' expr2', fvExpr1 `plusFV` fvExpr2) rnArithSeq (FromThenTo expr1 expr2 expr3) - = rnLExpr expr1 `thenM` \ (expr1', fvExpr1) -> - rnLExpr expr2 `thenM` \ (expr2', fvExpr2) -> - rnLExpr expr3 `thenM` \ (expr3', fvExpr3) -> + = rnLExpr expr1 `thenM` \ (expr1', fvExpr1) -> + rnLExpr expr2 `thenM` \ (expr2', fvExpr2) -> + rnLExpr expr3 `thenM` \ (expr3', fvExpr3) -> return (FromThenTo expr1' expr2' expr3', - plusFVs [fvExpr1, fvExpr2, fvExpr3]) + plusFVs [fvExpr1, fvExpr2, fvExpr3]) \end{code} %************************************************************************ -%* * - Template Haskell brackets -%* * +%* * + Template Haskell brackets +%* * %************************************************************************ \begin{code} rnBracket :: HsBracket RdrName -> RnM (HsBracket Name, FreeVars) -rnBracket (VarBr flg n) +rnBracket (VarBr flg n) = do { name <- lookupOccRn n ; this_mod <- getModule ; unless (nameIsLocalOrFrom this_mod name) $ -- Reason: deprecation checking assumes do { _ <- loadInterfaceForName msg name -- the home interface is loaded, and - ; return () } -- this is the only way that is going - -- to happen + ; return () } -- this is the only way that is going + -- to happen ; return (VarBr flg name, unitFV name) } where msg = ptext (sLit "Need interface for Template Haskell quoted Name") rnBracket (ExpBr e) = do { (e', fvs) <- rnLExpr e - ; return (ExpBr e', fvs) } + ; return (ExpBr e', fvs) } rnBracket (PatBr p) = rnPat ThPatQuote p $ \ p' -> return (PatBr p', emptyFVs) rnBracket (TypBr t) = do { (t', fvs) <- rnLHsType TypBrCtx t - ; return (TypBr t', fvs) } + ; return (TypBr t', fvs) } -rnBracket (DecBrL decls) +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. + -- Why not? See Section 7.3 of the TH paper. ; gbl_env <- getGblEnv ; let new_gbl_env = gbl_env { tcg_dus = emptyDUs } - -- The emptyDUs is so that we just collect uses for this + -- The emptyDUs is so that we just collect uses for this -- group alone in the call to rnSrcDecls below - ; (tcg_env, group') <- setGblEnv new_gbl_env $ - setStage thRnBrack $ - rnSrcDecls [] group + ; (tcg_env, group') <- setGblEnv new_gbl_env $ + setStage thRnBrack $ + rnSrcDecls [] group -- The empty list is for extra dependencies coming from .hs-boot files -- See Note [Extra dependencies from .hs-boot files] in RnSource - -- Discard the tcg_env; it contains only extra info about fixity - ; traceRn (text "rnBracket dec" <+> (ppr (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)) } + ; return (DecBrG group', duUses (tcg_dus tcg_env)) } rnBracket (DecBrG _) = panic "rnBracket: unexpected DecBrG" \end{code} %************************************************************************ -%* * +%* * \subsubsection{@Stmt@s: in @do@ expressions} -%* * +%* * %************************************************************************ \begin{code} -rnStmts :: Outputable (body RdrName) => HsStmtContext Name +rnStmts :: Outputable (body RdrName) => HsStmtContext Name -> (Located (body RdrName) -> RnM (Located (body Name), FreeVars)) -> [LStmt RdrName (Located (body RdrName))] -> ([Name] -> RnM (thing, FreeVars)) - -> RnM (([LStmt Name (Located (body Name))], thing), FreeVars) + -> RnM (([LStmt Name (Located (body Name))], thing), FreeVars) -- Variables bound by the Stmts, and mentioned in thing_inside, -- do not appear in the result FreeVars @@ -692,11 +685,11 @@ rnStmts ctxt _ [] thing_inside rnStmts MDoExpr rnBody stmts thing_inside -- Deal with mdo = -- Behave like do { rec { ...all but last... }; last } - do { ((stmts1, (stmts2, thing)), fvs) - <- rnStmt MDoExpr rnBody (noLoc $ mkRecStmt all_but_last) $ \ _ -> - do { last_stmt' <- checkLastStmt MDoExpr last_stmt - ; rnStmt MDoExpr rnBody last_stmt' thing_inside } - ; return (((stmts1 ++ stmts2), thing), fvs) } + do { ((stmts1, (stmts2, thing)), fvs) + <- rnStmt MDoExpr rnBody (noLoc $ mkRecStmt all_but_last) $ \ _ -> + do { last_stmt' <- checkLastStmt MDoExpr last_stmt + ; rnStmt MDoExpr rnBody last_stmt' thing_inside } + ; return (((stmts1 ++ stmts2), thing), fvs) } where Just (all_but_last, last_stmt) = snocView stmts @@ -707,16 +700,16 @@ rnStmts ctxt rnBody (lstmt@(L loc _) : lstmts) thing_inside ; rnStmt ctxt rnBody lstmt' thing_inside } | otherwise - = do { ((stmts1, (stmts2, thing)), fvs) + = do { ((stmts1, (stmts2, thing)), fvs) <- setSrcSpan loc $ do { checkStmt ctxt lstmt ; rnStmt ctxt rnBody lstmt $ \ bndrs1 -> rnStmts ctxt rnBody lstmts $ \ bndrs2 -> thing_inside (bndrs1 ++ bndrs2) } - ; return (((stmts1 ++ stmts2), thing), fvs) } + ; return (((stmts1 ++ stmts2), thing), fvs) } ---------------------- -rnStmt :: Outputable (body RdrName) => HsStmtContext Name +rnStmt :: Outputable (body RdrName) => HsStmtContext Name -> (Located (body RdrName) -> RnM (Located (body Name), FreeVars)) -> LStmt RdrName (Located (body RdrName)) -> ([Name] -> RnM (thing, FreeVars)) @@ -725,91 +718,72 @@ rnStmt :: Outputable (body RdrName) => HsStmtContext Name -- do not appear in the result FreeVars rnStmt ctxt rnBody (L loc (LastStmt body _)) thing_inside - = do { (body', fv_expr) <- rnBody body - ; (ret_op, fvs1) <- lookupStmtName ctxt returnMName - ; (thing, fvs3) <- thing_inside [] - ; return (([L loc (LastStmt body' ret_op)], thing), - fv_expr `plusFV` fvs1 `plusFV` fvs3) } + = do { (body', fv_expr) <- rnBody body + ; (ret_op, fvs1) <- lookupStmtName ctxt returnMName + ; (thing, fvs3) <- thing_inside [] + ; return (([L loc (LastStmt body' ret_op)], thing), + fv_expr `plusFV` fvs1 `plusFV` fvs3) } rnStmt ctxt rnBody (L loc (BodyStmt body _ _ _)) thing_inside - = do { (body', fv_expr) <- rnBody body - ; (then_op, fvs1) <- lookupStmtName ctxt thenMName - ; (guard_op, fvs2) <- if isListCompExpr ctxt + = do { (body', fv_expr) <- rnBody body + ; (then_op, fvs1) <- lookupStmtName ctxt thenMName + ; (guard_op, fvs2) <- if isListCompExpr ctxt then lookupStmtName ctxt guardMName - else return (noSyntaxExpr, emptyFVs) - -- Only list/parr/monad comprehensions use 'guard' - -- Also for sub-stmts of same eg [ e | x<-xs, gd | blah ] - -- Here "gd" is a guard - ; (thing, fvs3) <- thing_inside [] - ; return (([L loc (BodyStmt body' then_op guard_op placeHolderType)], thing), - fv_expr `plusFV` fvs1 `plusFV` fvs2 `plusFV` fvs3) } + else return (noSyntaxExpr, emptyFVs) + -- Only list/parr/monad comprehensions use 'guard' + -- Also for sub-stmts of same eg [ e | x<-xs, gd | blah ] + -- Here "gd" is a guard + ; (thing, fvs3) <- thing_inside [] + ; return (([L loc (BodyStmt body' then_op guard_op placeHolderType)], thing), + fv_expr `plusFV` fvs1 `plusFV` fvs2 `plusFV` fvs3) } rnStmt ctxt rnBody (L loc (BindStmt pat body _ _)) thing_inside - = do { (body', fv_expr) <- rnBody body - -- The binders do not scope over the expression - ; (bind_op, fvs1) <- lookupStmtName ctxt bindMName - ; (fail_op, fvs2) <- lookupStmtName ctxt failMName - ; rnPat (StmtCtxt ctxt) pat $ \ pat' -> do - { (thing, fvs3) <- thing_inside (collectPatBinders pat') - ; return (([L loc (BindStmt pat' body' bind_op fail_op)], thing), - fv_expr `plusFV` fvs1 `plusFV` fvs2 `plusFV` fvs3) }} + = do { (body', fv_expr) <- rnBody body + -- The binders do not scope over the expression + ; (bind_op, fvs1) <- lookupStmtName ctxt bindMName + ; (fail_op, fvs2) <- lookupStmtName ctxt failMName + ; rnPat (StmtCtxt ctxt) pat $ \ pat' -> do + { (thing, fvs3) <- thing_inside (collectPatBinders pat') + ; return (([L loc (BindStmt pat' body' bind_op fail_op)], thing), + fv_expr `plusFV` fvs1 `plusFV` fvs2 `plusFV` fvs3) }} -- fv_expr shouldn't really be filtered by the rnPatsAndThen - -- but it does not matter because the names are unique + -- but it does not matter because the names are unique -rnStmt _ _ (L loc (LetStmt binds)) thing_inside - = do { rnLocalBindsAndThen binds $ \binds' -> do - { (thing, fvs) <- thing_inside (collectLocalBinders binds') +rnStmt _ _ (L loc (LetStmt binds)) thing_inside + = do { rnLocalBindsAndThen binds $ \binds' -> do + { (thing, fvs) <- thing_inside (collectLocalBinders binds') ; return (([L loc (LetStmt binds')], thing), fvs) } } rnStmt ctxt rnBody (L _ (RecStmt { recS_stmts = rec_stmts })) thing_inside - = do { - -- Step1: Bring all the binders of the mdo into scope - -- (Remember that this also removes the binders from the - -- finally-returned free-vars.) - -- And rename each individual stmt, making a - -- singleton segment. At this stage the FwdRefs field - -- isn't finished: it's empty for all except a BindStmt - -- for which it's the fwd refs within the bind itself - -- (This set may not be empty, because we're in a recursive - -- context.) + = do { (return_op, fvs1) <- lookupStmtName ctxt returnMName + ; (mfix_op, fvs2) <- lookupStmtName ctxt mfixName + ; (bind_op, fvs3) <- lookupStmtName ctxt bindMName + ; let empty_rec_stmt = emptyRecStmt { recS_ret_fn = return_op + , recS_mfix_fn = mfix_op + , recS_bind_fn = bind_op } + + -- Step1: Bring all the binders of the mdo into scope + -- (Remember that this also removes the binders from the + -- finally-returned free-vars.) + -- And rename each individual stmt, making a + -- singleton segment. At this stage the FwdRefs field + -- isn't finished: it's empty for all except a BindStmt + -- for which it's the fwd refs within the bind itself + -- (This set may not be empty, because we're in a recursive + -- context.) ; rnRecStmtsAndThen rnBody rec_stmts $ \ segs -> do - - { let bndrs = nameSetToList $ foldr (unionNameSets . (\(ds,_,_,_) -> ds)) + { let bndrs = nameSetToList $ foldr (unionNameSets . (\(ds,_,_,_) -> ds)) emptyNameSet segs ; (thing, fvs_later) <- thing_inside bndrs - ; (return_op, fvs1) <- lookupStmtName ctxt returnMName - ; (mfix_op, fvs2) <- lookupStmtName ctxt mfixName - ; (bind_op, fvs3) <- lookupStmtName ctxt bindMName - ; let - -- Step 2: Fill in the fwd refs. - -- The segments are all singletons, but their fwd-ref - -- field mentions all the things used by the segment - -- that are bound after their use - segs_w_fwd_refs = addFwdRefs segs - - -- Step 3: Group together the segments to make bigger segments - -- Invariant: in the result, no segment uses a variable - -- bound in a later segment - grouped_segs = glomSegments ctxt segs_w_fwd_refs - - -- Step 4: Turn the segments into Stmts - -- Use RecStmt when and only when there are fwd refs - -- Also gather up the uses from the end towards the - -- start, so we can tell the RecStmt which things are - -- used 'after' the RecStmt - empty_rec_stmt = emptyRecStmt { recS_ret_fn = return_op - , recS_mfix_fn = mfix_op - , recS_bind_fn = bind_op } - (rec_stmts', fvs) = segsToStmts empty_rec_stmt grouped_segs fvs_later - - ; return ((rec_stmts', thing), fvs `plusFV` fvs1 `plusFV` fvs2 `plusFV` fvs3) } } + ; let (rec_stmts', fvs) = segmentRecStmts ctxt empty_rec_stmt segs fvs_later + ; return ((rec_stmts', thing), fvs `plusFV` fvs1 `plusFV` fvs2 `plusFV` fvs3) } } rnStmt ctxt _ (L loc (ParStmt segs _ _)) thing_inside - = do { (mzip_op, fvs1) <- lookupStmtName ctxt mzipName + = do { (mzip_op, fvs1) <- lookupStmtName ctxt mzipName ; (bind_op, fvs2) <- lookupStmtName ctxt bindMName ; (return_op, fvs3) <- lookupStmtName ctxt returnMName - ; ((segs', thing), fvs4) <- rnParallelStmts (ParStmtCtxt ctxt) return_op segs thing_inside - ; return ( ([L loc (ParStmt segs' mzip_op bind_op)], thing) + ; ((segs', thing), fvs4) <- rnParallelStmts (ParStmtCtxt ctxt) return_op segs thing_inside + ; return ( ([L loc (ParStmt segs' mzip_op bind_op)], thing) , fvs1 `plusFV` fvs2 `plusFV` fvs3 `plusFV` fvs4) } rnStmt ctxt _ (L loc (TransStmt { trS_stmts = stmts, trS_by = by, trS_form = form @@ -819,7 +793,7 @@ rnStmt ctxt _ (L loc (TransStmt { trS_stmts = stmts, trS_by = by, trS_form = for -- Rename the stmts and the 'by' expression -- Keep track of the variables mentioned in the 'by' expression - ; ((stmts', (by', used_bndrs, thing)), fvs2) + ; ((stmts', (by', used_bndrs, thing)), fvs2) <- rnStmts (TransStmtCtxt ctxt) rnLExpr stmts $ \ bndrs -> do { (by', fvs_by) <- mapMaybeFvRn rnLExpr by ; (thing, fvs_thing) <- thing_inside bndrs @@ -836,10 +810,10 @@ rnStmt ctxt _ (L loc (TransStmt { trS_stmts = stmts, trS_by = by, trS_form = for ThenForm -> return (noSyntaxExpr, emptyFVs) _ -> lookupStmtName ctxt fmapName - ; let all_fvs = fvs1 `plusFV` fvs2 `plusFV` fvs3 + ; let all_fvs = fvs1 `plusFV` fvs2 `plusFV` fvs3 `plusFV` fvs4 `plusFV` fvs5 bndr_map = used_bndrs `zip` used_bndrs - -- See Note [TransStmt binder map] in HsExpr + -- See Note [TransStmt binder map] in HsExpr ; traceRn (text "rnStmt: implicitly rebound these used binders:" <+> ppr bndr_map) ; return (([L loc (TransStmt { trS_stmts = stmts', trS_bndrs = bndr_map @@ -847,7 +821,7 @@ rnStmt ctxt _ (L loc (TransStmt { trS_stmts = stmts, trS_by = by, trS_form = for , trS_ret = return_op, trS_bind = bind_op , trS_fmap = fmap_op })], thing), all_fvs) } -rnParallelStmts :: forall thing. HsStmtContext Name +rnParallelStmts :: forall thing. HsStmtContext Name -> SyntaxExpr Name -> [ParStmtBlock RdrName RdrName] -> ([Name] -> RnM (thing, FreeVars)) @@ -860,20 +834,20 @@ rnParallelStmts ctxt return_op segs thing_inside rn_segs :: LocalRdrEnv -> [Name] -> [ParStmtBlock RdrName RdrName] -> RnM (([ParStmtBlock Name Name], thing), FreeVars) - rn_segs _ bndrs_so_far [] + rn_segs _ bndrs_so_far [] = do { let (bndrs', dups) = removeDups cmpByOcc bndrs_so_far ; mapM_ dupErr dups ; (thing, fvs) <- bindLocalNames bndrs' (thing_inside bndrs') ; return (([], thing), fvs) } - rn_segs env bndrs_so_far (ParStmtBlock stmts _ _ : segs) + rn_segs env bndrs_so_far (ParStmtBlock stmts _ _ : segs) = do { ((stmts', (used_bndrs, segs', thing)), fvs) <- rnStmts ctxt rnLExpr stmts $ \ bndrs -> setLocalRdrEnv env $ do { ((segs', thing), fvs) <- rn_segs env (bndrs ++ bndrs_so_far) segs - ; let used_bndrs = filter (`elemNameSet` fvs) bndrs + ; let used_bndrs = filter (`elemNameSet` fvs) bndrs ; return ((used_bndrs, segs', thing), fvs) } - + ; let seg' = ParStmtBlock stmts' used_bndrs return_op ; return ((seg':segs', thing), fvs) } @@ -884,7 +858,7 @@ rnParallelStmts ctxt return_op segs thing_inside lookupStmtName :: HsStmtContext Name -> Name -> RnM (HsExpr Name, FreeVars) -- Like lookupSyntaxName, but ListComp/PArrComp are never rebindable -- Neither is ArrowExpr, which has its own desugarer in DsArrows -lookupStmtName ctxt n +lookupStmtName ctxt n = case ctxt of ListComp -> not_rebindable PArrComp -> not_rebindable @@ -896,8 +870,8 @@ lookupStmtName ctxt n MonadComp -> rebindable GhciStmtCtxt -> rebindable -- I suppose? - ParStmtCtxt c -> lookupStmtName c n -- Look inside to - TransStmtCtxt c -> lookupStmtName c n -- the parent context + ParStmtCtxt c -> lookupStmtName c n -- Look inside to + TransStmtCtxt c -> lookupStmtName c n -- the parent context where rebindable = lookupSyntaxName n not_rebindable = return (HsVar n, emptyFVs) @@ -905,36 +879,36 @@ lookupStmtName ctxt n Note [Renaming parallel Stmts] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Renaming parallel statements is painful. Given, say +Renaming parallel statements is painful. Given, say [ a+c | a <- as, bs <- bss | c <- bs, a <- ds ] Note that (a) In order to report "Defined by not used" about 'bs', we must rename each group of Stmts with a thing_inside whose FreeVars include at least {a,c} - + (b) We want to report that 'a' is illegally bound in both branches - (c) The 'bs' in the second group must obviously not be captured by + (c) The 'bs' in the second group must obviously not be captured by the binding in the first group -To satisfy (a) we nest the segements. +To satisfy (a) we nest the segements. To satisfy (b) we check for duplicates just before thing_inside. To satisfy (c) we reset the LocalRdrEnv each time. %************************************************************************ -%* * +%* * \subsubsection{mdo expressions} -%* * +%* * %************************************************************************ \begin{code} type FwdRefs = NameSet type Segment stmts = (Defs, - Uses, -- May include defs - FwdRefs, -- A subset of uses that are - -- (a) used before they are bound in this segment, or - -- (b) used here, and bound in subsequent segments - stmts) -- Either Stmt or [Stmt] + Uses, -- May include defs + FwdRefs, -- A subset of uses that are + -- (a) used before they are bound in this segment, or + -- (b) used here, and bound in subsequent segments + stmts) -- Either Stmt or [Stmt] -- wrapper that does both the left- and right-hand sides @@ -946,35 +920,35 @@ rnRecStmtsAndThen :: Outputable (body RdrName) => -> ([Segment (LStmt Name (Located (body Name)))] -> RnM (a, FreeVars)) -> RnM (a, FreeVars) rnRecStmtsAndThen rnBody s cont - = do { -- (A) Make the mini fixity env for all of the stmts - fix_env <- makeMiniFixityEnv (collectRecStmtsFixities s) + = do { -- (A) Make the mini fixity env for all of the stmts + fix_env <- makeMiniFixityEnv (collectRecStmtsFixities s) - -- (B) Do the LHSes - ; new_lhs_and_fv <- rn_rec_stmts_lhs fix_env s + -- (B) Do the LHSes + ; new_lhs_and_fv <- rn_rec_stmts_lhs fix_env s - -- ...bring them and their fixities into scope - ; let bound_names = collectLStmtsBinders (map fst new_lhs_and_fv) - -- Fake uses of variables introduced implicitly (warning suppression, see #4404) - implicit_uses = lStmtsImplicits (map fst new_lhs_and_fv) - ; bindLocalNamesFV bound_names $ + -- ...bring them and their fixities into scope + ; let bound_names = collectLStmtsBinders (map fst new_lhs_and_fv) + -- 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 rnBody bound_names new_lhs_and_fv - ; (res, fvs) <- cont segs - ; warnUnusedLocalBinds bound_names (fvs `unionNameSets` implicit_uses) - ; return (res, fvs) }} + -- (C) do the right-hand-sides and thing-inside + { segs <- rn_rec_stmts rnBody bound_names new_lhs_and_fv + ; (res, fvs) <- cont segs + ; warnUnusedLocalBinds bound_names (fvs `unionNameSets` implicit_uses) + ; return (res, fvs) }} -- get all the fixity decls in any Let stmt collectRecStmtsFixities :: [LStmtLR RdrName RdrName body] -> [LFixitySig RdrName] -collectRecStmtsFixities l = - foldr (\ s -> \acc -> case s of - (L _ (LetStmt (HsValBinds (ValBindsIn _ sigs)))) -> - foldr (\ sig -> \ acc -> case sig of +collectRecStmtsFixities l = + foldr (\ s -> \acc -> case s of + (L _ (LetStmt (HsValBinds (ValBindsIn _ sigs)))) -> + foldr (\ sig -> \ acc -> case sig of (L loc (FixSig s)) -> (L loc s) : acc _ -> acc) acc sigs _ -> acc) [] l - + -- left-hand sides rn_rec_stmt_lhs :: Outputable body => MiniFixityEnv @@ -984,23 +958,23 @@ rn_rec_stmt_lhs :: Outputable body => MiniFixityEnv -- so we don't bother to compute it accurately in the other cases -> RnM [(LStmtLR Name RdrName body, FreeVars)] -rn_rec_stmt_lhs _ (L loc (BodyStmt body a b c)) +rn_rec_stmt_lhs _ (L loc (BodyStmt body a b c)) = return [(L loc (BodyStmt body a b c), emptyFVs)] -rn_rec_stmt_lhs _ (L loc (LastStmt body a)) +rn_rec_stmt_lhs _ (L loc (LastStmt body a)) = return [(L loc (LastStmt body a), emptyFVs)] -rn_rec_stmt_lhs fix_env (L loc (BindStmt pat body a b)) - = do +rn_rec_stmt_lhs fix_env (L loc (BindStmt pat body a b)) + = do -- should the ctxt be MDo instead? - (pat', fv_pat) <- rnBindPat (localRecNameMaker fix_env) pat + (pat', fv_pat) <- rnBindPat (localRecNameMaker fix_env) pat return [(L loc (BindStmt pat' body a b), fv_pat)] 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))) +rn_rec_stmt_lhs fix_env (L loc (LetStmt (HsValBinds binds))) = do (_bound_names, binds') <- rnLocalValBindsLHS fix_env binds return [(L loc (LetStmt (HsValBinds binds')), -- Warning: this is bogus; see function invariant @@ -1008,20 +982,20 @@ rn_rec_stmt_lhs fix_env (L loc (LetStmt (HsValBinds binds))) )] -- XXX Do we need to do something with the return and mfix names? -rn_rec_stmt_lhs fix_env (L _ (RecStmt { recS_stmts = stmts })) -- Flatten Rec inside Rec +rn_rec_stmt_lhs fix_env (L _ (RecStmt { recS_stmts = stmts })) -- Flatten Rec inside Rec = rn_rec_stmts_lhs fix_env stmts -rn_rec_stmt_lhs _ stmt@(L _ (ParStmt {})) -- Syntactically illegal in mdo +rn_rec_stmt_lhs _ stmt@(L _ (ParStmt {})) -- Syntactically illegal in mdo = pprPanic "rn_rec_stmt" (ppr stmt) - -rn_rec_stmt_lhs _ stmt@(L _ (TransStmt {})) -- Syntactically illegal in mdo + +rn_rec_stmt_lhs _ stmt@(L _ (TransStmt {})) -- Syntactically illegal in mdo = pprPanic "rn_rec_stmt" (ppr stmt) rn_rec_stmt_lhs _ (L _ (LetStmt EmptyLocalBinds)) = panic "rn_rec_stmt LetStmt EmptyLocalBinds" rn_rec_stmts_lhs :: Outputable body => MiniFixityEnv - -> [LStmt RdrName body] + -> [LStmt RdrName body] -> RnM [(LStmtLR Name RdrName body, FreeVars)] rn_rec_stmts_lhs fix_env stmts = do { ls <- concatMapM (rn_rec_stmt_lhs fix_env) stmts @@ -1039,41 +1013,41 @@ rn_rec_stmt :: (Outputable (body RdrName)) => (Located (body RdrName) -> RnM (Located (body Name), FreeVars)) -> [Name] -> LStmtLR Name RdrName (Located (body RdrName)) -> FreeVars -> RnM [Segment (LStmt Name (Located (body Name)))] - -- Rename a Stmt that is inside a RecStmt (or mdo) - -- Assumes all binders are already in scope - -- Turns each stmt into a singleton Stmt + -- Rename a Stmt that is inside a RecStmt (or mdo) + -- Assumes all binders are already in scope + -- Turns each stmt into a singleton Stmt rn_rec_stmt rnBody _ (L loc (LastStmt body _)) _ - = do { (body', fv_expr) <- rnBody body - ; (ret_op, fvs1) <- lookupSyntaxName returnMName - ; return [(emptyNameSet, fv_expr `plusFV` fvs1, emptyNameSet, + = do { (body', fv_expr) <- rnBody body + ; (ret_op, fvs1) <- lookupSyntaxName returnMName + ; return [(emptyNameSet, fv_expr `plusFV` fvs1, emptyNameSet, L loc (LastStmt body' ret_op))] } rn_rec_stmt rnBody _ (L loc (BodyStmt body _ _ _)) _ = rnBody body `thenM` \ (body', fvs) -> - lookupSyntaxName thenMName `thenM` \ (then_op, fvs1) -> + lookupSyntaxName thenMName `thenM` \ (then_op, fvs1) -> return [(emptyNameSet, fvs `plusFV` fvs1, emptyNameSet, - L loc (BodyStmt body' then_op noSyntaxExpr placeHolderType))] + L loc (BodyStmt body' then_op noSyntaxExpr placeHolderType))] rn_rec_stmt rnBody _ (L loc (BindStmt pat' body _ _)) fv_pat - = rnBody body `thenM` \ (body', fv_expr) -> - lookupSyntaxName bindMName `thenM` \ (bind_op, fvs1) -> - lookupSyntaxName failMName `thenM` \ (fail_op, fvs2) -> + = rnBody body `thenM` \ (body', fv_expr) -> + lookupSyntaxName bindMName `thenM` \ (bind_op, fvs1) -> + lookupSyntaxName failMName `thenM` \ (fail_op, fvs2) -> let - bndrs = mkNameSet (collectPatBinders pat') - fvs = fv_expr `plusFV` fv_pat `plusFV` fvs1 `plusFV` fvs2 + bndrs = mkNameSet (collectPatBinders pat') + fvs = fv_expr `plusFV` fv_pat `plusFV` fvs1 `plusFV` fvs2 in return [(bndrs, fvs, bndrs `intersectNameSet` fvs, - L loc (BindStmt pat' body' bind_op fail_op))] + L loc (BindStmt pat' body' bind_op fail_op))] rn_rec_stmt _ _ (L _ (LetStmt binds@(HsIPBinds _))) _ = failWith (badIpBinds (ptext (sLit "an mdo expression")) binds) -rn_rec_stmt _ all_bndrs (L loc (LetStmt (HsValBinds binds'))) _ = do - (binds', du_binds) <- +rn_rec_stmt _ all_bndrs (L loc (LetStmt (HsValBinds binds'))) _ = do + (binds', du_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')))] + return [(duDefs du_binds, allUses du_binds, + emptyNameSet, L loc (LetStmt (HsValBinds binds')))] -- no RecStmt case because they get flattened above when doing the LHSes rn_rec_stmt _ _ stmt@(L _ (RecStmt {})) _ @@ -1090,99 +1064,139 @@ rn_rec_stmt _ _ (L _ (LetStmt EmptyLocalBinds)) _ rn_rec_stmts :: Outputable (body RdrName) => (Located (body RdrName) -> RnM (Located (body Name), FreeVars)) - -> [Name] - -> [(LStmtLR Name RdrName (Located (body RdrName)), FreeVars)] + -> [Name] + -> [(LStmtLR Name RdrName (Located (body RdrName)), FreeVars)] -> RnM [Segment (LStmt Name (Located (body Name)))] -rn_rec_stmts rnBody bndrs stmts = +rn_rec_stmts rnBody bndrs stmts = mapM (uncurry (rn_rec_stmt rnBody bndrs)) stmts `thenM` \ segs_s -> return (concat segs_s) --------------------------------------------- +segmentRecStmts :: HsStmtContext Name + -> Stmt Name body + -> [Segment (LStmt Name body)] -> FreeVars + -> ([LStmt Name body], FreeVars) + +segmentRecStmts ctxt empty_rec_stmt segs fvs_later + | MDoExpr <- ctxt + = segsToStmts empty_rec_stmt grouped_segs fvs_later + -- Step 4: Turn the segments into Stmts + -- Use RecStmt when and only when there are fwd refs + -- Also gather up the uses from the end towards the + -- start, so we can tell the RecStmt which things are + -- used 'after' the RecStmt + + | otherwise + = ([ L (getLoc (head ss)) $ + empty_rec_stmt { recS_stmts = ss + , recS_later_ids = nameSetToList (defs `intersectNameSet` fvs_later) + , recS_rec_ids = nameSetToList (defs `intersectNameSet` uses) }] + , uses `plusFV` fvs_later) + + where + (defs_s, uses_s, _, ss) = unzip4 segs + defs = plusFVs defs_s + uses = plusFVs uses_s + + -- Step 2: Fill in the fwd refs. + -- The segments are all singletons, but their fwd-ref + -- field mentions all the things used by the segment + -- that are bound after their use + segs_w_fwd_refs = addFwdRefs segs + + -- Step 3: Group together the segments to make bigger segments + -- Invariant: in the result, no segment uses a variable + -- bound in a later segment + grouped_segs = glomSegments ctxt segs_w_fwd_refs + +---------------------------- addFwdRefs :: [Segment a] -> [Segment a] -- So far the segments only have forward refs *within* the Stmt --- (which happens for bind: x <- ...x...) +-- (which happens for bind: x <- ...x...) -- This function adds the cross-seg fwd ref info -addFwdRefs pairs - = fst (foldr mk_seg ([], emptyNameSet) pairs) +addFwdRefs segs + = fst (foldr mk_seg ([], emptyNameSet) segs) where mk_seg (defs, uses, fwds, stmts) (segs, later_defs) - = (new_seg : segs, all_defs) - where - new_seg = (defs, uses, new_fwds, stmts) - all_defs = later_defs `unionNameSets` defs - new_fwds = fwds `unionNameSets` (uses `intersectNameSet` later_defs) - -- Add the downstream fwd refs here + = (new_seg : segs, all_defs) + where + new_seg = (defs, uses, new_fwds, stmts) + all_defs = later_defs `unionNameSets` defs + new_fwds = fwds `unionNameSets` (uses `intersectNameSet` later_defs) + -- Add the downstream fwd refs here +\end{code} ----------------------------------------------------- --- Glomming the singleton segments of an mdo into --- minimal recursive groups. --- --- At first I thought this was just strongly connected components, but --- there's an important constraint: the order of the stmts must not change. --- --- Consider --- mdo { x <- ...y... --- p <- z --- y <- ...x... --- q <- x --- z <- y --- r <- x } --- --- Here, the first stmt mention 'y', which is bound in the third. --- But that means that the innocent second stmt (p <- z) gets caught --- up in the recursion. And that in turn means that the binding for --- 'z' has to be included... and so on. --- --- Start at the tail { r <- x } --- Now add the next one { z <- y ; r <- x } --- Now add one more { q <- x ; z <- y ; r <- x } --- Now one more... but this time we have to group a bunch into rec --- { rec { y <- ...x... ; q <- x ; z <- y } ; r <- x } --- Now one more, which we can add on without a rec --- { p <- z ; --- rec { y <- ...x... ; q <- x ; z <- y } ; --- r <- x } --- Finally we add the last one; since it mentions y we have to --- glom it togeher with the first two groups --- { rec { x <- ...y...; p <- z ; y <- ...x... ; --- q <- x ; z <- y } ; --- r <- x } --- --- NB. June 7 2012: We only glom segments that appear in --- an explicit mdo; and leave those found in "do rec"'s intact. --- See http://hackage.haskell.org/trac/ghc/ticket/4148 for --- the discussion leading to this design choice. +Note [Segmenting mdo] +~~~~~~~~~~~~~~~~~~~~~ +NB. June 7 2012: We only glom segments that appear in an explicit mdo; +and leave those found in "do rec"'s intact. See +http://hackage.haskell.org/trac/ghc/ticket/4148 for the discussion +leading to this design choice. Hence the test in segmentRecStmts. + +Note [Glomming segments] +~~~~~~~~~~~~~~~~~~~~~~~~ +Glomming the singleton segments of an mdo into minimal recursive groups. + +At first I thought this was just strongly connected components, but +there's an important constraint: the order of the stmts must not change. + +Consider + mdo { x <- ...y... + p <- z + y <- ...x... + q <- x + z <- y + r <- x } + +Here, the first stmt mention 'y', which is bound in the third. +But that means that the innocent second stmt (p <- z) gets caught +up in the recursion. And that in turn means that the binding for +'z' has to be included... and so on. + +Start at the tail { r <- x } +Now add the next one { z <- y ; r <- x } +Now add one more { q <- x ; z <- y ; r <- x } +Now one more... but this time we have to group a bunch into rec + { rec { y <- ...x... ; q <- x ; z <- y } ; r <- x } +Now one more, which we can add on without a rec + { p <- z ; + rec { y <- ...x... ; q <- x ; z <- y } ; + r <- x } +Finally we add the last one; since it mentions y we have to +glom it together with the first two groups + { rec { x <- ...y...; p <- z ; y <- ...x... ; + q <- x ; z <- y } ; + r <- x } +\begin{code} glomSegments :: HsStmtContext Name -> [Segment (LStmt Name body)] -> [Segment [LStmt Name body]] +-- See Note [Glomming segments] glomSegments _ [] = [] glomSegments ctxt ((defs,uses,fwds,stmt) : segs) - -- Actually stmts will always be a singleton + -- Actually stmts will always be a singleton = (seg_defs, seg_uses, seg_fwds, seg_stmts) : others where - segs' = glomSegments ctxt segs + segs' = glomSegments ctxt segs (extras, others) = grab uses segs' (ds, us, fs, ss) = unzip4 extras - + seg_defs = plusFVs ds `plusFV` defs seg_uses = plusFVs us `plusFV` uses seg_fwds = plusFVs fs `plusFV` fwds seg_stmts = stmt : concat ss - grab :: NameSet -- The client - -> [Segment a] - -> ([Segment a], -- Needed by the 'client' - [Segment a]) -- Not needed by the client - -- The result is simply a split of the input - grab uses dus - = (reverse yeses, reverse noes) - where - (noes, yeses) = span not_needed (reverse dus) - not_needed (defs,_,_,_) = case ctxt of - MDoExpr -> not (intersectsNameSet defs uses) - _ -> False -- unless we're in mdo, we *need* everything - + grab :: NameSet -- The client + -> [Segment a] + -> ([Segment a], -- Needed by the 'client' + [Segment a]) -- Not needed by the client + -- The result is simply a split of the input + grab uses dus + = (reverse yeses, reverse noes) + where + (noes, yeses) = span not_needed (reverse dus) + not_needed (defs,_,_,_) = not (intersectsNameSet defs uses) ---------------------------------------------------- segsToStmts :: Stmt Name body -- A RecStmt with the SyntaxOps filled in @@ -1196,20 +1210,20 @@ segsToStmts empty_rec_stmt ((defs, uses, fwds, ss) : segs) fvs_later (new_stmt : later_stmts, later_uses `plusFV` uses) where (later_stmts, later_uses) = segsToStmts empty_rec_stmt segs fvs_later - new_stmt | non_rec = head ss - | otherwise = L (getLoc (head ss)) rec_stmt + new_stmt | non_rec = head ss + | otherwise = L (getLoc (head ss)) rec_stmt rec_stmt = empty_rec_stmt { recS_stmts = ss , recS_later_ids = nameSetToList used_later , recS_rec_ids = nameSetToList fwds } non_rec = isSingleton ss && isEmptyNameSet fwds used_later = defs `intersectNameSet` later_uses - -- The ones needed after the RecStmt + -- The ones needed after the RecStmt \end{code} %************************************************************************ -%* * +%* * \subsubsection{Assertion utils} -%* * +%* * %************************************************************************ \begin{code} @@ -1230,22 +1244,22 @@ Note [Adding the implicit parameter to 'assert'] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ The renamer transforms (assert e1 e2) to (assert "Foo.hs:27" e1 e2). By doing this in the renamer we allow the typechecker to just see the -expanded application and do the right thing. But it's not really +expanded application and do the right thing. But it's not really the Right Thing because there's no way to "undo" if you want to see the original source code. We'll have fix this in due course, when -we care more about being able to reconstruct the exact original +we care more about being able to reconstruct the exact original program. %************************************************************************ -%* * +%* * \subsubsection{Errors} -%* * +%* * %************************************************************************ \begin{code} checkEmptyStmts :: HsStmtContext Name -> RnM () -- We've seen an empty sequence of Stmts... is that ok? -checkEmptyStmts ctxt +checkEmptyStmts ctxt = unless (okEmpty ctxt) (addErr (emptyErr ctxt)) okEmpty :: HsStmtContext a -> Bool @@ -1257,35 +1271,35 @@ emptyErr (ParStmtCtxt {}) = ptext (sLit "Empty statement group in parallel com emptyErr (TransStmtCtxt {}) = ptext (sLit "Empty statement group preceding 'group' or 'then'") emptyErr ctxt = ptext (sLit "Empty") <+> pprStmtContext ctxt ----------------------- +---------------------- checkLastStmt :: Outputable (body RdrName) => HsStmtContext Name -> LStmt RdrName (Located (body RdrName)) -> RnM (LStmt RdrName (Located (body RdrName))) checkLastStmt ctxt lstmt@(L loc stmt) - = case ctxt of + = case ctxt of ListComp -> check_comp MonadComp -> check_comp PArrComp -> check_comp - ArrowExpr -> check_do - DoExpr -> check_do + ArrowExpr -> check_do + DoExpr -> check_do MDoExpr -> check_do _ -> check_other where - check_do -- Expect BodyStmt, and change it to LastStmt - = case stmt of + check_do -- Expect BodyStmt, and change it to LastStmt + = case stmt of BodyStmt e _ _ _ -> return (L loc (mkLastStmt e)) LastStmt {} -> return lstmt -- "Deriving" clauses may generate a - -- LastStmt directly (unlike the parser) - _ -> do { addErr (hang last_error 2 (ppr stmt)); return lstmt } + -- LastStmt directly (unlike the parser) + _ -> do { addErr (hang last_error 2 (ppr stmt)); return lstmt } last_error = (ptext (sLit "The last statement in") <+> pprAStmtContext ctxt <+> ptext (sLit "must be an expression")) - check_comp -- Expect LastStmt; this should be enforced by the parser! - = case stmt of + check_comp -- Expect LastStmt; this should be enforced by the parser! + = case stmt of LastStmt {} -> return lstmt _ -> pprPanic "checkLastStmt" (ppr lstmt) - check_other -- Behave just as if this wasn't the last stmt + check_other -- Behave just as if this wasn't the last stmt = do { checkStmt ctxt lstmt; return lstmt } -- Checking when a particular Stmt is ok @@ -1294,7 +1308,7 @@ checkStmt :: HsStmtContext Name -> RnM () checkStmt ctxt (L _ stmt) = do { dflags <- getDynFlags - ; case okStmt dflags ctxt stmt of + ; case okStmt dflags ctxt stmt of Nothing -> return () Just extra -> addErr (msg $$ extra) } where @@ -1321,17 +1335,17 @@ okStmt, okDoStmt, okCompStmt, okParStmt, okPArrStmt -- Return Nothing if OK, (Just extra) if not ok -- The "extra" is an SDoc that is appended to an generic error message -okStmt dflags ctxt stmt +okStmt dflags ctxt stmt = case ctxt of - PatGuard {} -> okPatGuardStmt stmt - ParStmtCtxt ctxt -> okParStmt dflags ctxt stmt - DoExpr -> okDoStmt dflags ctxt stmt - MDoExpr -> okDoStmt dflags ctxt stmt - ArrowExpr -> okDoStmt dflags ctxt stmt + PatGuard {} -> okPatGuardStmt stmt + ParStmtCtxt ctxt -> okParStmt dflags ctxt stmt + DoExpr -> okDoStmt dflags ctxt stmt + MDoExpr -> okDoStmt dflags ctxt stmt + ArrowExpr -> okDoStmt dflags ctxt stmt GhciStmtCtxt -> okDoStmt dflags ctxt stmt - ListComp -> okCompStmt dflags ctxt stmt - MonadComp -> okCompStmt dflags ctxt stmt - PArrComp -> okPArrStmt dflags ctxt stmt + ListComp -> okCompStmt dflags ctxt stmt + MonadComp -> okCompStmt dflags ctxt stmt + PArrComp -> okPArrStmt dflags ctxt stmt TransStmtCtxt ctxt -> okStmt dflags ctxt stmt ------------- @@ -1354,7 +1368,7 @@ okDoStmt dflags ctxt stmt = case stmt of RecStmt {} | Opt_RecursiveDo `xopt` dflags -> isOK - | ArrowExpr <- ctxt -> isOK -- Arrows allows 'rec' + | ArrowExpr <- ctxt -> isOK -- Arrows allows 'rec' | otherwise -> Just (ptext (sLit "Use -XRecursiveDo")) BindStmt {} -> isOK LetStmt {} -> isOK @@ -1367,10 +1381,10 @@ okCompStmt dflags _ stmt BindStmt {} -> isOK LetStmt {} -> isOK BodyStmt {} -> isOK - ParStmt {} + ParStmt {} | Opt_ParallelListComp `xopt` dflags -> isOK | otherwise -> Just (ptext (sLit "Use -XParallelListComp")) - TransStmt {} + TransStmt {} | Opt_TransformListComp `xopt` dflags -> isOK | otherwise -> Just (ptext (sLit "Use -XTransformListComp")) RecStmt {} -> notOK @@ -1382,7 +1396,7 @@ okPArrStmt dflags _ stmt BindStmt {} -> isOK LetStmt {} -> isOK BodyStmt {} -> isOK - ParStmt {} + ParStmt {} | Opt_ParallelListComp `xopt` dflags -> isOK | otherwise -> Just (ptext (sLit "Use -XParallelListComp")) TransStmt {} -> notOK @@ -1392,8 +1406,8 @@ okPArrStmt dflags _ stmt --------- checkTupleSection :: [HsTupArg RdrName] -> RnM () checkTupleSection args - = do { tuple_section <- xoptM Opt_TupleSections - ; checkErr (all tupArgPresent args || tuple_section) msg } + = do { tuple_section <- xoptM Opt_TupleSections + ; checkErr (all tupArgPresent args || tuple_section) msg } where msg = ptext (sLit "Illegal tuple section: use -XTupleSections") @@ -1405,11 +1419,11 @@ sectionErr expr patSynErr :: HsExpr RdrName -> RnM (HsExpr Name, FreeVars) patSynErr e = do { addErr (sep [ptext (sLit "Pattern syntax in expression context:"), - nest 4 (ppr e)]) - ; return (EWildPat, emptyFVs) } + nest 4 (ppr e)]) + ; return (EWildPat, emptyFVs) } badIpBinds :: Outputable a => SDoc -> a -> SDoc badIpBinds what binds = hang (ptext (sLit "Implicit-parameter bindings illegal in") <+> what) - 2 (ppr binds) + 2 (ppr binds) \end{code} diff --git a/compiler/rename/RnNames.lhs b/compiler/rename/RnNames.lhs index 2055f8a989..203e1e271c 100644 --- a/compiler/rename/RnNames.lhs +++ b/compiler/rename/RnNames.lhs @@ -476,7 +476,7 @@ getLocalNonValBinders :: MiniFixityEnv -> HsGroup RdrName -> RnM ((TcGblEnv, TcLclEnv), NameSet) -- Get all the top-level binders bound the group *except* -- for value bindings, which are treated separately --- Specificaly we return AvailInfo for +-- Specifically we return AvailInfo for -- type decls (incl constructors and record selectors) -- class decls (including class ops) -- associated types @@ -596,8 +596,7 @@ filterImports iface decl_spec Nothing filterImports iface decl_spec (Just (want_hiding, import_items)) = do -- check for errors, convert RdrNames to Names - opt_typeFamilies <- xoptM Opt_TypeFamilies - items1 <- mapM (lookup_lie opt_typeFamilies) import_items + items1 <- mapM lookup_lie import_items let items2 :: [(LIE Name, AvailInfo)] items2 = concat items1 @@ -646,12 +645,18 @@ filterImports iface decl_spec (Just (want_hiding, import_items)) (name, AvailTC name subs, Just parent) combine x y = pprPanic "filterImports/combine" (ppr x $$ ppr y) - lookup_lie :: Bool -> LIE RdrName -> TcRn [(LIE Name, AvailInfo)] - lookup_lie opt_typeFamilies (L loc ieRdr) - = do - (stuff, warns) <- setSrcSpan loc . - liftM (fromMaybe ([],[])) $ - run_lookup (lookup_ie opt_typeFamilies ieRdr) + lookup_name :: RdrName -> IELookupM (Name, AvailInfo, Maybe Name) + lookup_name rdr | isQual rdr = failLookupWith (QualImportError rdr) + | Just succ <- mb_success = return succ + | otherwise = failLookupWith BadImport + where + mb_success = lookupOccEnv occ_env (rdrNameOcc rdr) + + lookup_lie :: LIE RdrName -> TcRn [(LIE Name, AvailInfo)] + lookup_lie (L loc ieRdr) + = do (stuff, warns) <- setSrcSpan loc $ + liftM (fromMaybe ([],[])) $ + run_lookup (lookup_ie ieRdr) mapM_ emit_warning warns return [ (L loc ie, avail) | (ie,avail) <- stuff ] where @@ -672,9 +677,6 @@ filterImports iface decl_spec (Just (want_hiding, import_items)) BadImport -> badImportItemErr iface decl_spec ieRdr all_avails IllegalImport -> illegalImportItemErr QualImportError rdr -> qualImportItemErr rdr - TypeItemError children -> typeItemErr - (head . filter isTyConName $ children) - (text "in import list") -- For each import item, we convert its RdrNames to Names, -- and at the same time construct an AvailInfo corresponding @@ -686,15 +688,8 @@ filterImports iface decl_spec (Just (want_hiding, import_items)) -- data constructors of an associated family, we need separate -- AvailInfos for the data constructors and the family (as they have -- different parents). See the discussion at occ_env. - lookup_ie :: Bool -> IE RdrName -> IELookupM ([(IE Name, AvailInfo)], [IELookupWarning]) - lookup_ie opt_typeFamilies ie = handle_bad_import $ do - let lookup_name rdr - | isQual rdr - = failLookupWith (QualImportError rdr) - | Just nm <- lookupOccEnv occ_env (rdrNameOcc rdr) - = return nm - | otherwise - = failLookupWith BadImport + lookup_ie :: IE RdrName -> IELookupM ([(IE Name, AvailInfo)], [IELookupWarning]) + lookup_ie ie = handle_bad_import $ do case ie of IEVar n -> do (name, avail, _) <- lookup_name n @@ -702,13 +697,9 @@ filterImports iface decl_spec (Just (want_hiding, import_items)) IEThingAll tc -> do (name, avail@(AvailTC name2 subs), mb_parent) <- lookup_name tc - let warns - | null (drop 1 subs) - = [DodgyImport tc] - | not (is_qual decl_spec) - = [MissingImportList] - | otherwise - = [] + let warns | null (drop 1 subs) = [DodgyImport tc] + | not (is_qual decl_spec) = [MissingImportList] + | otherwise = [] case mb_parent of -- non-associated ty/cls Nothing -> return ([(IEThingAll name, avail)], warns) @@ -734,15 +725,14 @@ filterImports iface decl_spec (Just (want_hiding, import_items)) IEThingWith tc ns -> do (name, AvailTC _ subnames, mb_parent) <- lookup_name tc - let - env = mkOccEnv [(nameOccName s, s) | s <- subnames] - mb_children = map (lookupOccEnv env . rdrNameOcc) ns + + -- Look up the children in the sub-names of the parent + let mb_children = lookupChildren subnames ns + children <- if any isNothing mb_children then failLookupWith BadImport else return (catMaybes mb_children) - -- check for proper import of type families - when (not opt_typeFamilies && any isTyConName children) $ - failLookupWith (TypeItemError children) + case mb_parent of -- non-associated ty/cls Nothing -> return ([(IEThingWith name children, @@ -779,7 +769,6 @@ data IELookupError = QualImportError RdrName | BadImport | IllegalImport - | TypeItemError [Name] failLookupWith :: IELookupError -> IELookupM a failLookupWith err = Failed err @@ -864,6 +853,19 @@ mkChildEnv gres = foldr add emptyNameEnv gres findChildren :: NameEnv [Name] -> Name -> [Name] findChildren env n = lookupNameEnv env n `orElse` [] +lookupChildren :: [Name] -> [RdrName] -> [Maybe Name] +-- (lookupChildren all_kids rdr_items) maps each rdr_item to its +-- corresponding Name all_kids, if the former exists +-- The matching is done by FastString, not OccName, so that +-- Cls( meth, AssocTy ) +-- will correctly find AssocTy among the all_kids of Cls, even though +-- the RdrName for AssocTy may have a (bogus) DataName namespace +-- (Really the rdr_items should be FastStrings in the first place.) +lookupChildren all_kids rdr_items + = map (lookupFsEnv kid_env . occNameFS . rdrNameOcc) rdr_items + where + kid_env = mkFsEnv [(occNameFS (nameOccName n), n) | n <- all_kids] + -- | Combines 'AvailInfo's from the same family -- 'avails' may have several items with the same availName -- E.g import Ix( Ix(..), index ) @@ -966,7 +968,7 @@ rnExports explicit_mod exports ; let real_exports | explicit_mod = exports | ghcLink dflags == LinkInMemory = Nothing - | otherwise = Just ([noLoc (IEVar main_RDR_Unqual)]) + | otherwise = Just [noLoc (IEVar main_RDR_Unqual)] -- ToDo: the 'noLoc' here is unhelpful if 'main' -- turns out to be out of scope @@ -1103,20 +1105,12 @@ exports_from_avail (Just rdr_items) rdr_env imports this_mod if isUnboundName name then return (IEThingWith name [], AvailTC name [name]) else do - let env = mkOccEnv [ (nameOccName s, s) - | s <- findChildren kids_env name ] - mb_names = map (lookupOccEnv env . rdrNameOcc) sub_rdrs + let mb_names = lookupChildren (findChildren kids_env name) sub_rdrs if any isNothing mb_names then do addErr (exportItemErr ie) return (IEThingWith name [], AvailTC name [name]) else do let names = catMaybes mb_names addUsedKids rdr names - optTyFam <- xoptM Opt_TypeFamilies - when (not optTyFam && any isTyConName names) $ - addErr (typeItemErr ( head - . filter isTyConName - $ names ) - (text "in export list")) return (IEThingWith name names, AvailTC name (name:names)) lookup_ie _ = panic "lookup_ie" -- Other cases covered earlier @@ -1318,12 +1312,9 @@ warnUnusedImportDecls gbl_env ; whenGOptM Opt_D_dump_minimal_imports $ printMinimalImports usage } where - explicit_import (L _ decl) = unLoc (ideclName decl) /= pRELUDE_NAME + explicit_import (L _ decl) = not (ideclImplicit decl) -- Filter out the implicit Prelude import -- which we do not want to bleat about - -- This also filters out an *explicit* Prelude import - -- but solving that problem involves more plumbing, and - -- it just doesn't seem worth it \end{code} @@ -1621,11 +1612,6 @@ exportItemErr export_item = sep [ ptext (sLit "The export item") <+> quotes (ppr export_item), ptext (sLit "attempts to export constructors or class methods that are not visible here") ] -typeItemErr :: Name -> SDoc -> SDoc -typeItemErr name wherestr - = sep [ ptext (sLit "Using 'type' tag on") <+> quotes (ppr name) <+> wherestr, - ptext (sLit "Use -XTypeFamilies to enable this extension") ] - exportClashErr :: GlobalRdrEnv -> Name -> Name -> IE RdrName -> IE RdrName -> MsgDoc exportClashErr global_env name1 name2 ie1 ie2 diff --git a/compiler/rename/RnPat.lhs b/compiler/rename/RnPat.lhs index a039f36b25..205dde1969 100644 --- a/compiler/rename/RnPat.lhs +++ b/compiler/rename/RnPat.lhs @@ -330,8 +330,17 @@ rnPatAndThen mk (VarPat rdr) = do { loc <- liftCps getSrcSpanM -- (e.g. in the pattern (x, x -> y) x needs to be bound in the rhs of the tuple) rnPatAndThen mk (SigPatIn pat sig) - = do { pat' <- rnLPatAndThen mk pat - ; sig' <- rnHsSigCps sig + -- When renaming a pattern type signature (e.g. f (a :: T) = ...), it is + -- important to rename its type signature _before_ renaming the rest of the + -- pattern, so that type variables are first bound by the _outermost_ pattern + -- type signature they occur in. This keeps the type checker happy when + -- pattern type signatures happen to be nested (#7827) + -- + -- f ((Just (x :: a) :: Maybe a) + -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~^ `a' is first bound here + -- ~~~~~~~~~~~~~~~^ the same `a' then used here + = do { sig' <- rnHsSigCps sig + ; pat' <- rnLPatAndThen mk pat ; return (SigPatIn pat' sig') } rnPatAndThen mk (LitPat lit) diff --git a/compiler/rename/RnSource.lhs b/compiler/rename/RnSource.lhs index cc410388df..e1236cac10 100644 --- a/compiler/rename/RnSource.lhs +++ b/compiler/rename/RnSource.lhs @@ -542,10 +542,9 @@ rnFamInstDecl doc mb_cls tycon pats payload rnPayload rnTyFamInstDecl :: Maybe (Name, [Name]) -> TyFamInstDecl RdrName -> RnM (TyFamInstDecl Name, FreeVars) -rnTyFamInstDecl mb_cls (TyFamInstDecl { tfid_eqns = eqns, tfid_group = group }) - = do { (eqns', fvs) <- rnList (rnTyFamInstEqn mb_cls) eqns - ; return (TyFamInstDecl { tfid_eqns = eqns' - , tfid_group = group +rnTyFamInstDecl mb_cls (TyFamInstDecl { tfid_eqn = L loc eqn }) + = do { (eqn', fvs) <- rnTyFamInstEqn mb_cls eqn + ; return (TyFamInstDecl { tfid_eqn = L loc eqn' , tfid_fvs = fvs }, fvs) } rnTyFamInstEqn :: Maybe (Name, [Name]) @@ -1044,16 +1043,27 @@ rnFamDecl :: Maybe Name -> FamilyDecl RdrName -> RnM (FamilyDecl Name, FreeVars) rnFamDecl mb_cls (FamilyDecl { fdLName = tycon, fdTyVars = tyvars - , fdFlavour = flav, fdKindSig = kind }) - = bindHsTyVars fmly_doc mb_cls kvs tyvars $ \tyvars' -> - do { tycon' <- lookupLocatedTopBndrRn tycon - ; (kind', fv_kind) <- rnLHsMaybeKind fmly_doc kind + , fdInfo = info, fdKindSig = kind }) + = do { ((tycon', tyvars', kind'), fv1) <- + bindHsTyVars fmly_doc mb_cls kvs tyvars $ \tyvars' -> + do { tycon' <- lookupLocatedTopBndrRn tycon + ; (kind', fv_kind) <- rnLHsMaybeKind fmly_doc kind + ; return ((tycon', tyvars', kind'), fv_kind) } + ; (info', fv2) <- rn_info info ; return (FamilyDecl { fdLName = tycon', fdTyVars = tyvars' - , fdFlavour = flav, fdKindSig = kind' } - , fv_kind ) } + , fdInfo = info', fdKindSig = kind' } + , fv1 `plusFV` fv2) } where fmly_doc = TyFamilyCtx tycon kvs = extractRdrKindSigVars kind + + rn_info (ClosedTypeFamily eqns) + = do { (eqns', fvs) <- rnList (rnTyFamInstEqn Nothing) eqns + -- no class context, + ; return (ClosedTypeFamily eqns', fvs) } + rn_info OpenTypeFamily = return (OpenTypeFamily, emptyFVs) + rn_info DataFamily = return (DataFamily, emptyFVs) + \end{code} Note [Stupid theta] diff --git a/compiler/rename/RnTypes.lhs b/compiler/rename/RnTypes.lhs index 95bdcb413f..a1c4bac25c 100644 --- a/compiler/rename/RnTypes.lhs +++ b/compiler/rename/RnTypes.lhs @@ -4,26 +4,19 @@ \section[RnSource]{Main pass of renamer} \begin{code} -{-# OPTIONS -fno-warn-tabs #-} --- The above warning supression flag is a temporary kludge. --- While working on this module you are encouraged to remove it and --- detab the module (please do the detabbing in a separate patch). See --- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces --- for details - -module RnTypes ( - -- Type related stuff - rnHsType, rnLHsType, rnLHsTypes, rnContext, +module RnTypes ( + -- Type related stuff + rnHsType, rnLHsType, rnLHsTypes, rnContext, rnHsKind, rnLHsKind, rnLHsMaybeKind, - rnHsSigType, rnLHsInstType, rnConDeclFields, + rnHsSigType, rnLHsInstType, rnConDeclFields, newTyVarNameRn, - -- Precence related stuff - mkOpAppRn, mkNegAppRn, mkOpFormRn, mkConOpPatRn, - checkPrecMatch, checkSectionPrec, warnUnusedForAlls, + -- Precence related stuff + mkOpAppRn, mkNegAppRn, mkOpFormRn, mkConOpPatRn, + checkPrecMatch, checkSectionPrec, warnUnusedForAlls, - -- Splice related stuff - rnSplice, checkTH, + -- Splice related stuff + rnSplice, checkTH, -- Binding related stuff bindSigTyVarsFV, bindHsTyVars, rnHsBndrSig, @@ -34,7 +27,7 @@ module RnTypes ( import {-# SOURCE #-} RnExpr( rnLExpr ) #ifdef GHCI import {-# SOURCE #-} TcSplice( runQuasiQuoteType ) -#endif /* GHCI */ +#endif /* GHCI */ import DynFlags import HsSyn @@ -49,13 +42,13 @@ import SrcLoc import NameSet import Util -import BasicTypes ( compareFixity, funTyFixity, negateFixity, - Fixity(..), FixityDirection(..) ) +import BasicTypes ( compareFixity, funTyFixity, negateFixity, + Fixity(..), FixityDirection(..) ) import Outputable import FastString import Maybes import Data.List ( nub ) -import Control.Monad ( unless, when ) +import Control.Monad ( unless, when ) #include "HsVersions.h" \end{code} @@ -64,20 +57,20 @@ These type renamers are in a separate module, rather than in (say) RnSource, to break several loop. %********************************************************* -%* * +%* * \subsection{Renaming types} -%* * +%* * %********************************************************* \begin{code} rnHsSigType :: SDoc -> LHsType RdrName -> RnM (LHsType Name, FreeVars) - -- rnHsSigType is used for source-language type signatures, - -- which use *implicit* universal quantification. + -- rnHsSigType is used for source-language type signatures, + -- which use *implicit* universal quantification. rnHsSigType doc_str ty = rnLHsType (TypeSigCtx doc_str) ty rnLHsInstType :: SDoc -> LHsType RdrName -> RnM (LHsType Name, FreeVars) -- Rename the type in an instance or standalone deriving decl -rnLHsInstType doc_str ty +rnLHsInstType doc_str ty = do { (ty', fvs) <- rnLHsType (GenericCtx doc_str) ty ; unless good_inst_ty (addErrAt (getLoc ty) (badInstTy ty)) ; return (ty', fvs) } @@ -88,7 +81,7 @@ rnLHsInstType doc_str ty | otherwise = False badInstTy :: LHsType RdrName -> SDoc -badInstTy ty = ptext (sLit "Malformed instance:") <+> ppr ty +badInstTy ty = ptext (sLit "Malformed instance:") <+> ppr ty \end{code} rnHsType is here because we call it from loadInstDecl, and I didn't @@ -98,7 +91,7 @@ want a gratuitous knot. rnLHsTyKi :: Bool -- True <=> renaming a type, False <=> a kind -> HsDocContext -> LHsType RdrName -> RnM (LHsType Name, FreeVars) rnLHsTyKi isType doc (L loc ty) - = setSrcSpan loc $ + = setSrcSpan loc $ do { (ty', fvs) <- rnHsTyKi isType doc ty ; return (L loc ty', fvs) } @@ -110,9 +103,9 @@ rnLHsKind = rnLHsTyKi False rnLHsMaybeKind :: HsDocContext -> Maybe (LHsKind RdrName) -> RnM (Maybe (LHsKind Name), FreeVars) -rnLHsMaybeKind _ Nothing +rnLHsMaybeKind _ Nothing = return (Nothing, emptyFVs) -rnLHsMaybeKind doc (Just kind) +rnLHsMaybeKind doc (Just kind) = do { (kind', fvs) <- rnLHsKind doc kind ; return (Just kind', fvs) } @@ -123,15 +116,15 @@ rnHsKind = rnHsTyKi False rnHsTyKi :: Bool -> HsDocContext -> HsType RdrName -> RnM (HsType Name, FreeVars) -rnHsTyKi isType doc (HsForAllTy Implicit _ lctxt@(L _ ctxt) ty) - = ASSERT ( isType ) do - -- Implicit quantifiction in source code (no kinds on tyvars) - -- Given the signature C => T we universally quantify - -- over FV(T) \ {in-scope-tyvars} +rnHsTyKi isType doc (HsForAllTy Implicit _ lctxt@(L _ ctxt) ty) + = ASSERT( isType ) do + -- Implicit quantifiction in source code (no kinds on tyvars) + -- Given the signature C => T we universally quantify + -- over FV(T) \ {in-scope-tyvars} rdr_env <- getLocalRdrEnv loc <- getSrcSpanM let - (forall_kvs, forall_tvs) = filterInScope rdr_env $ + (forall_kvs, forall_tvs) = filterInScope rdr_env $ extractHsTysRdrTyVars (ty:ctxt) -- In for-all types we don't bring in scope -- kind variables mentioned in kind signatures @@ -139,17 +132,17 @@ rnHsTyKi isType doc (HsForAllTy Implicit _ lctxt@(L _ ctxt) ty) -- f :: Int -> T (a::k) -- Not allowed -- The filterInScope is to ensure that we don't quantify over - -- type variables that are in scope; when GlasgowExts is off, - -- there usually won't be any, except for class signatures: - -- class C a where { op :: a -> a } - tyvar_bndrs = userHsTyVarBndrs loc forall_tvs + -- type variables that are in scope; when GlasgowExts is off, + -- there usually won't be any, except for class signatures: + -- class C a where { op :: a -> a } + tyvar_bndrs = userHsTyVarBndrs loc forall_tvs rnForAll doc Implicit forall_kvs (mkHsQTvs tyvar_bndrs) lctxt ty rnHsTyKi isType doc ty@(HsForAllTy Explicit forall_tyvars lctxt@(L _ ctxt) tau) - = ASSERT ( isType ) do { -- Explicit quantification. - -- Check that the forall'd tyvars are actually - -- mentioned in the type, and produce a warning if not + = ASSERT( isType ) do { -- Explicit quantification. + -- Check that the forall'd tyvars are actually + -- mentioned in the type, and produce a warning if not let (kvs, mentioned) = extractHsTysRdrTyVars (tau:ctxt) in_type_doc = ptext (sLit "In the type") <+> quotes (ppr ty) ; warnUnusedForAlls (in_type_doc $$ docOfHsDocContext doc) forall_tyvars mentioned @@ -164,17 +157,17 @@ rnHsTyKi isType _ (HsTyVar rdr_name) -- a sensible error message, but we don't want to complain about the dot too -- Hence the jiggery pokery with ty1 rnHsTyKi isType doc ty@(HsOpTy ty1 (wrapper, L loc op) ty2) - = ASSERT ( isType ) setSrcSpan loc $ - do { ops_ok <- xoptM Opt_TypeOperators - ; op' <- if ops_ok - then rnTyVar isType op - else do { addErr (opTyErr op ty) - ; return (mkUnboundName op) } -- Avoid double complaint - ; let l_op' = L loc op' - ; fix <- lookupTyFixityRn l_op' - ; (ty1', fvs1) <- rnLHsType doc ty1 - ; (ty2', fvs2) <- rnLHsType doc ty2 - ; res_ty <- mkHsOpTyRn (\t1 t2 -> HsOpTy t1 (wrapper, l_op') t2) + = ASSERT( isType ) setSrcSpan loc $ + do { ops_ok <- xoptM Opt_TypeOperators + ; op' <- if ops_ok + then rnTyVar isType op + else do { addErr (opTyErr op ty) + ; return (mkUnboundName op) } -- Avoid double complaint + ; let l_op' = L loc op' + ; fix <- lookupTyFixityRn l_op' + ; (ty1', fvs1) <- rnLHsType doc ty1 + ; (ty2', fvs2) <- rnLHsType doc ty2 + ; res_ty <- mkHsOpTyRn (\t1 t2 -> HsOpTy t1 (wrapper, l_op') t2) op' fix ty1' ty2' ; return (res_ty, (fvs1 `plusFV` fvs2) `addOneFV` op') } @@ -183,23 +176,24 @@ rnHsTyKi isType doc (HsParTy ty) ; return (HsParTy ty', fvs) } rnHsTyKi isType doc (HsBangTy b ty) - = ASSERT ( isType ) + = ASSERT( isType ) do { (ty', fvs) <- rnLHsType doc ty ; return (HsBangTy b ty', fvs) } -rnHsTyKi isType doc (HsRecTy flds) - = ASSERT ( isType ) - do { (flds', fvs) <- rnConDeclFields doc flds +rnHsTyKi _ doc ty@(HsRecTy flds) + = do { addErr (hang (ptext (sLit "Record syntax is illegal here:")) + 2 (ppr ty)) + ; (flds', fvs) <- rnConDeclFields doc flds ; return (HsRecTy flds', fvs) } rnHsTyKi isType doc (HsFunTy ty1 ty2) = do { (ty1', fvs1) <- rnLHsTyKi isType doc ty1 - -- Might find a for-all as the arg of a function type + -- Might find a for-all as the arg of a function type ; (ty2', fvs2) <- rnLHsTyKi isType doc ty2 - -- Or as the result. This happens when reading Prelude.hi - -- when we find return :: forall m. Monad m -> forall a. a -> m a + -- Or as the result. This happens when reading Prelude.hi + -- when we find return :: forall m. Monad m -> forall a. a -> m a - -- Check for fixity rearrangements + -- Check for fixity rearrangements ; res_ty <- if isType then mkHsOpTyRn HsFunTy funTyConName funTyFixity ty1' ty2' else return (HsFunTy ty1' ty2') @@ -212,15 +206,18 @@ rnHsTyKi isType doc listTy@(HsListTy ty) ; return (HsListTy ty', fvs) } rnHsTyKi isType doc (HsKindSig ty k) - = ASSERT ( isType ) + = ASSERT( isType ) do { kind_sigs_ok <- xoptM Opt_KindSignatures ; unless kind_sigs_ok (badSigErr False doc ty) ; (ty', fvs1) <- rnLHsType doc ty ; (k', fvs2) <- rnLHsKind doc k ; return (HsKindSig ty' k', fvs1 `plusFV` fvs2) } -rnHsTyKi isType doc (HsPArrTy ty) - = ASSERT ( isType ) +rnHsTyKi _ doc (HsRoleAnnot ty _) + = illegalRoleAnnotDoc doc ty >> failM + +rnHsTyKi isType doc (HsPArrTy ty) + = ASSERT( isType ) do { (ty', fvs) <- rnLHsType doc ty ; return (HsPArrTy ty', fvs) } @@ -249,19 +246,19 @@ rnHsTyKi isType doc (HsIParamTy n ty) do { (ty', fvs) <- rnLHsType doc ty ; return (HsIParamTy n ty', fvs) } -rnHsTyKi isType doc (HsEqTy ty1 ty2) +rnHsTyKi isType doc (HsEqTy ty1 ty2) = ASSERT( isType ) do { (ty1', fvs1) <- rnLHsType doc ty1 ; (ty2', fvs2) <- rnLHsType doc ty2 ; return (HsEqTy ty1' ty2', fvs1 `plusFV` fvs2) } rnHsTyKi isType _ (HsSpliceTy sp _ k) - = ASSERT ( isType ) - do { (sp', fvs) <- rnSplice sp -- ToDo: deal with fvs + = ASSERT( isType ) + do { (sp', fvs) <- rnSplice sp -- ToDo: deal with fvs ; return (HsSpliceTy sp' fvs k, fvs) } -rnHsTyKi isType doc (HsDocTy ty haddock_doc) - = ASSERT ( isType ) +rnHsTyKi isType doc (HsDocTy ty haddock_doc) + = ASSERT( isType ) do { (ty', fvs) <- rnLHsType doc ty ; haddock_doc' <- rnLHsDoc haddock_doc ; return (HsDocTy ty' haddock_doc', fvs) } @@ -269,19 +266,19 @@ rnHsTyKi isType doc (HsDocTy ty haddock_doc) #ifndef GHCI rnHsTyKi _ _ ty@(HsQuasiQuoteTy _) = pprPanic "Can't do quasiquotation without GHCi" (ppr ty) #else -rnHsTyKi isType doc (HsQuasiQuoteTy qq) - = ASSERT ( isType ) +rnHsTyKi isType doc (HsQuasiQuoteTy qq) + = ASSERT( isType ) do { ty <- runQuasiQuoteType qq ; rnHsType doc (unLoc ty) } #endif -rnHsTyKi isType _ (HsCoreTy ty) - = ASSERT ( isType ) +rnHsTyKi isType _ (HsCoreTy ty) + = ASSERT( isType ) return (HsCoreTy ty, emptyFVs) - -- The emptyFVs probably isn't quite right + -- The emptyFVs probably isn't quite right -- but I don't think it matters -rnHsTyKi _ _ (HsWrapTy {}) +rnHsTyKi _ _ (HsWrapTy {}) = panic "rnHsTyKi" rnHsTyKi isType doc ty@(HsExplicitListTy k tys) @@ -291,7 +288,7 @@ rnHsTyKi isType doc ty@(HsExplicitListTy k tys) ; (tys', fvs) <- rnLHsTypes doc tys ; return (HsExplicitListTy k tys', fvs) } -rnHsTyKi isType doc ty@(HsExplicitTupleTy kis tys) +rnHsTyKi isType doc ty@(HsExplicitTupleTy kis tys) = ASSERT( isType ) do { data_kinds <- xoptM Opt_DataKinds ; unless data_kinds (addErr (dataKindsErr isType ty)) @@ -313,60 +310,60 @@ rnLHsTypes doc tys = mapFvRn (rnLHsType doc) tys \begin{code} -rnForAll :: HsDocContext -> HsExplicitFlag +rnForAll :: HsDocContext -> HsExplicitFlag -> [RdrName] -- Kind variables -> LHsTyVarBndrs RdrName -- Type variables - -> LHsContext RdrName -> LHsType RdrName + -> LHsContext RdrName -> LHsType RdrName -> RnM (HsType Name, FreeVars) rnForAll doc exp kvs forall_tyvars ctxt ty | null kvs, null (hsQTvBndrs forall_tyvars), null (unLoc ctxt) = rnHsType doc (unLoc ty) - -- One reason for this case is that a type like Int# - -- starts off as (HsForAllTy Nothing [] Int), in case - -- there is some quantification. Now that we have quantified - -- and discovered there are no type variables, it's nicer to turn - -- it into plain Int. If it were Int# instead of Int, we'd actually - -- get an error, because the body of a genuine for-all is - -- of kind *. + -- One reason for this case is that a type like Int# + -- starts off as (HsForAllTy Nothing [] Int), in case + -- there is some quantification. Now that we have quantified + -- and discovered there are no type variables, it's nicer to turn + -- it into plain Int. If it were Int# instead of Int, we'd actually + -- get an error, because the body of a genuine for-all is + -- of kind *. | otherwise = bindHsTyVars doc Nothing kvs forall_tyvars $ \ new_tyvars -> do { (new_ctxt, fvs1) <- rnContext doc ctxt ; (new_ty, fvs2) <- rnLHsType doc ty ; return (HsForAllTy exp new_tyvars new_ctxt new_ty, fvs1 `plusFV` fvs2) } - -- Retain the same implicit/explicit flag as before - -- so that we can later print it correctly + -- Retain the same implicit/explicit flag as before + -- so that we can later print it correctly --------------- bindSigTyVarsFV :: [Name] - -> RnM (a, FreeVars) - -> RnM (a, FreeVars) + -> RnM (a, FreeVars) + -> RnM (a, FreeVars) -- Used just before renaming the defn of a function -- with a separate type signature, to bring its tyvars into scope -- With no -XScopedTypeVariables, this is a no-op bindSigTyVarsFV tvs thing_inside - = do { scoped_tyvars <- xoptM Opt_ScopedTypeVariables - ; if not scoped_tyvars then - thing_inside - else - bindLocalNamesFV tvs thing_inside } + = do { scoped_tyvars <- xoptM Opt_ScopedTypeVariables + ; if not scoped_tyvars then + thing_inside + else + bindLocalNamesFV tvs thing_inside } --------------- -bindHsTyVars :: HsDocContext +bindHsTyVars :: HsDocContext -> Maybe a -- Just _ => an associated type decl -> [RdrName] -- Kind variables from scope -> LHsTyVarBndrs RdrName -- Type variables -> (LHsTyVarBndrs Name -> RnM (b, FreeVars)) -> RnM (b, FreeVars) --- (a) Bring kind variables into scope --- both (i) passed in (kv_bndrs) +-- (a) Bring kind variables into scope +-- both (i) passed in (kv_bndrs) -- and (ii) mentioned in the kinds of tv_bndrs -- (b) Bring type variables into scope bindHsTyVars doc mb_assoc kv_bndrs tv_bndrs thing_inside = do { rdr_env <- getLocalRdrEnv ; let tvs = hsQTvBndrs tv_bndrs - kvs_from_tv_bndrs = [ kv | L _ (KindedTyVar _ kind) <- tvs + kvs_from_tv_bndrs = [ kv | L _ (HsTyVarBndr _ (Just kind) _) <- tvs , let (_, kvs) = extractHsTyRdrTyVars kind , kv <- kvs ] all_kvs = filterOut (`elemLocalRdrEnv` rdr_env) $ @@ -377,26 +374,30 @@ bindHsTyVars doc mb_assoc kv_bndrs tv_bndrs thing_inside -- We disallow this: too confusing! ; poly_kind <- xoptM Opt_PolyKinds - ; unless (poly_kind || null all_kvs) + ; unless (poly_kind || null all_kvs) (addErr (badKindBndrs doc all_kvs)) - ; unless (null overlap_kvs) + ; unless (null overlap_kvs) (addErr (overlappingKindVars doc overlap_kvs)) ; loc <- getSrcSpanM ; kv_names <- mapM (newLocalBndrRn . L loc) all_kvs - ; bindLocalNamesFV kv_names $ + ; bindLocalNamesFV kv_names $ do { let tv_names_w_loc = hsLTyVarLocNames tv_bndrs - rn_tv_bndr :: LHsTyVarBndr RdrName -> RnM (LHsTyVarBndr Name, FreeVars) - rn_tv_bndr (L loc (UserTyVar rdr)) - = do { nm <- newTyVarNameRn mb_assoc rdr_env loc rdr - ; return (L loc (UserTyVar nm), emptyFVs) } - rn_tv_bndr (L loc (KindedTyVar rdr kind)) - = do { sig_ok <- xoptM Opt_KindSignatures - ; unless sig_ok (badSigErr False doc kind) - ; nm <- newTyVarNameRn mb_assoc rdr_env loc rdr - ; (kind', fvs) <- rnLHsKind doc kind - ; return (L loc (KindedTyVar nm kind'), fvs) } + rn_tv_bndr :: LHsTyVarBndr RdrName -> RnM (LHsTyVarBndr Name, FreeVars) + rn_tv_bndr (L loc (HsTyVarBndr name mkind mrole)) + = do { ksig_ok <- xoptM Opt_KindSignatures + ; unless ksig_ok $ + whenIsJust mkind $ \k -> badSigErr False doc k + ; rsig_ok <- xoptM Opt_RoleAnnotations + ; unless rsig_ok $ + whenIsJust mrole $ \_ -> badRoleAnnotOpt loc doc + ; nm <- newTyVarNameRn mb_assoc rdr_env loc name + ; (mkind', fvs) <- case mkind of + Just k -> do { (kind', fvs) <- rnLHsKind doc k + ; return (Just kind', fvs) } + Nothing -> return (Nothing, emptyFVs) + ; return (L loc (HsTyVarBndr nm mkind' mrole), fvs) } -- Check for duplicate or shadowed tyvar bindrs ; checkDupRdrNames tv_names_w_loc @@ -413,8 +414,8 @@ newTyVarNameRn :: Maybe a -> LocalRdrEnv -> SrcSpan -> RdrName -> RnM Name newTyVarNameRn mb_assoc rdr_env loc rdr | Just _ <- mb_assoc -- Use the same Name as the parent class decl , Just n <- lookupLocalRdrEnv rdr_env rdr - = return n - | otherwise + = return n + | otherwise = newLocalBndrRn (L loc rdr) -------------------------------- @@ -431,16 +432,16 @@ rnHsBndrSig doc (HsWB { hswb_cts = ty@(L loc _) }) thing_inside , not (tv `elemLocalRdrEnv` name_env) ] ; kv_names <- newLocalBndrsRn [L loc kv | kv <- kv_bndrs , not (kv `elemLocalRdrEnv` name_env) ] - ; bindLocalNamesFV kv_names $ - bindLocalNamesFV tv_names $ + ; bindLocalNamesFV kv_names $ + bindLocalNamesFV tv_names $ do { (ty', fvs1) <- rnLHsType doc ty ; (res, fvs2) <- thing_inside (HsWB { hswb_cts = ty', hswb_kvs = kv_names, hswb_tvs = tv_names }) ; return (res, fvs1 `plusFV` fvs2) } } overlappingKindVars :: HsDocContext -> [RdrName] -> SDoc overlappingKindVars doc kvs - = vcat [ ptext (sLit "Kind variable") <> plural kvs <+> - ptext (sLit "also used as type variable") <> plural kvs + = vcat [ ptext (sLit "Kind variable") <> plural kvs <+> + ptext (sLit "also used as type variable") <> plural kvs <> colon <+> pprQuotedList kvs , docOfHsDocContext doc ] @@ -454,7 +455,7 @@ badKindBndrs doc kvs badSigErr :: Bool -> HsDocContext -> LHsType RdrName -> TcM () badSigErr is_type doc (L loc ty) = setSrcSpan loc $ addErr $ - vcat [ hang (ptext (sLit "Illegal") <+> what + vcat [ hang (ptext (sLit "Illegal") <+> what <+> ptext (sLit "signature:") <+> quotes (ppr ty)) 2 (ptext (sLit "Perhaps you intended to use") <+> flag) , docOfHsDocContext doc ] @@ -471,16 +472,29 @@ dataKindsErr is_type thing where what | is_type = ptext (sLit "type") | otherwise = ptext (sLit "kind") + +badRoleAnnotOpt :: SrcSpan -> HsDocContext -> TcM () +badRoleAnnotOpt loc doc + = setSrcSpan loc $ addErr $ + vcat [ ptext (sLit "Illegal role annotation") + , ptext (sLit "Perhaps you intended to use -XRoleAnnotations") + , docOfHsDocContext doc ] + +illegalRoleAnnotDoc :: HsDocContext -> LHsType RdrName -> TcM () +illegalRoleAnnotDoc doc (L loc ty) + = setSrcSpan loc $ addErr $ + vcat [ ptext (sLit "Illegal role annotation on") <+> (ppr ty) + , docOfHsDocContext doc ] \end{code} -Note [Renaming associated types] +Note [Renaming associated types] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Check that the RHS of the decl mentions only type variables bound on the LHS. For example, this is not ok class C a b where type F a x :: * instance C (p,q) r where - type F (p,q) x = (x, r) -- BAD: mentions 'r' + type F (p,q) x = (x, r) -- BAD: mentions 'r' c.f. Trac #5515 What makes it tricky is that the *kind* variable from the class *are* @@ -488,8 +502,8 @@ in scope (Trac #5862): class Category (x :: k -> k -> *) where type Ob x :: k -> Constraint id :: Ob x a => x a a - (.) :: (Ob x a, Ob x b, Ob x c) => x b c -> x a b -> x a c -Here 'k' is in scope in the kind signature even though it's not + (.) :: (Ob x a, Ob x b, Ob x c) => x b c -> x a b -> x a c +Here 'k' is in scope in the kind signature even though it's not explicitly mentioned on the LHS of the type Ob declaration. We could force you to mention k explicitly, thus @@ -499,13 +513,13 @@ but it seems tiresome to do so. %********************************************************* -%* * +%* * \subsection{Contexts and predicates} -%* * +%* * %********************************************************* \begin{code} -rnConDeclFields :: HsDocContext -> [ConDeclField RdrName] +rnConDeclFields :: HsDocContext -> [ConDeclField RdrName] -> RnM ([ConDeclField Name], FreeVars) rnConDeclFields doc fields = mapFvRn (rnField doc) fields @@ -517,16 +531,16 @@ rnField doc (ConDeclField name ty haddock_doc) ; return (ConDeclField new_name new_ty new_haddock_doc, fvs) } rnContext :: HsDocContext -> LHsContext RdrName -> RnM (LHsContext Name, FreeVars) -rnContext doc (L loc cxt) +rnContext doc (L loc cxt) = do { (cxt', fvs) <- rnLHsTypes doc cxt ; return (L loc cxt', fvs) } \end{code} %************************************************************************ -%* * - Fixities and precedence parsing -%* * +%* * + Fixities and precedence parsing +%* * %************************************************************************ @mkOpAppRn@ deals with operator fixities. The argument expressions @@ -539,9 +553,9 @@ operator application. Why? Because the parser parses all operator appications left-associatively, EXCEPT negation, which we need to handle specially. Infix types are read in a *right-associative* way, so that - a `op` b `op` c + a `op` b `op` c is always read in as - a `op` (b `op` c) + a `op` (b `op` c) mkHsOpTyRn rearranges where necessary. The two arguments have already been renamed and rearranged. It's made rather tiresome @@ -551,46 +565,46 @@ by the presence of ->, which is a separate syntactic construct. --------------- -- Building (ty1 `op1` (ty21 `op2` ty22)) mkHsOpTyRn :: (LHsType Name -> LHsType Name -> HsType Name) - -> Name -> Fixity -> LHsType Name -> LHsType Name - -> RnM (HsType Name) + -> Name -> Fixity -> LHsType Name -> LHsType Name + -> RnM (HsType Name) mkHsOpTyRn mk1 pp_op1 fix1 ty1 (L loc2 (HsOpTy ty21 (w2, op2) ty22)) = do { fix2 <- lookupTyFixityRn op2 - ; mk_hs_op_ty mk1 pp_op1 fix1 ty1 - (\t1 t2 -> HsOpTy t1 (w2, op2) t2) - (unLoc op2) fix2 ty21 ty22 loc2 } + ; mk_hs_op_ty mk1 pp_op1 fix1 ty1 + (\t1 t2 -> HsOpTy t1 (w2, op2) t2) + (unLoc op2) fix2 ty21 ty22 loc2 } mkHsOpTyRn mk1 pp_op1 fix1 ty1 (L loc2 (HsFunTy ty21 ty22)) - = mk_hs_op_ty mk1 pp_op1 fix1 ty1 - HsFunTy funTyConName funTyFixity ty21 ty22 loc2 + = mk_hs_op_ty mk1 pp_op1 fix1 ty1 + HsFunTy funTyConName funTyFixity ty21 ty22 loc2 -mkHsOpTyRn mk1 _ _ ty1 ty2 -- Default case, no rearrangment +mkHsOpTyRn mk1 _ _ ty1 ty2 -- Default case, no rearrangment = return (mk1 ty1 ty2) --------------- mk_hs_op_ty :: (LHsType Name -> LHsType Name -> HsType Name) - -> Name -> Fixity -> LHsType Name - -> (LHsType Name -> LHsType Name -> HsType Name) - -> Name -> Fixity -> LHsType Name -> LHsType Name -> SrcSpan - -> RnM (HsType Name) -mk_hs_op_ty mk1 op1 fix1 ty1 - mk2 op2 fix2 ty21 ty22 loc2 + -> Name -> Fixity -> LHsType Name + -> (LHsType Name -> LHsType Name -> HsType Name) + -> Name -> Fixity -> LHsType Name -> LHsType Name -> SrcSpan + -> RnM (HsType Name) +mk_hs_op_ty mk1 op1 fix1 ty1 + mk2 op2 fix2 ty21 ty22 loc2 | nofix_error = do { precParseErr (op1,fix1) (op2,fix2) - ; return (mk1 ty1 (L loc2 (mk2 ty21 ty22))) } + ; return (mk1 ty1 (L loc2 (mk2 ty21 ty22))) } | associate_right = return (mk1 ty1 (L loc2 (mk2 ty21 ty22))) - | otherwise = do { -- Rearrange to ((ty1 `op1` ty21) `op2` ty22) - new_ty <- mkHsOpTyRn mk1 op1 fix1 ty1 ty21 - ; return (mk2 (noLoc new_ty) ty22) } + | otherwise = do { -- Rearrange to ((ty1 `op1` ty21) `op2` ty22) + new_ty <- mkHsOpTyRn mk1 op1 fix1 ty1 ty21 + ; return (mk2 (noLoc new_ty) ty22) } where (nofix_error, associate_right) = compareFixity fix1 fix2 --------------------------- -mkOpAppRn :: LHsExpr Name -- Left operand; already rearranged - -> LHsExpr Name -> Fixity -- Operator and fixity - -> LHsExpr Name -- Right operand (not an OpApp, but might - -- be a NegApp) - -> RnM (HsExpr Name) +mkOpAppRn :: LHsExpr Name -- Left operand; already rearranged + -> LHsExpr Name -> Fixity -- Operator and fixity + -> LHsExpr Name -- Right operand (not an OpApp, but might + -- be a NegApp) + -> RnM (HsExpr Name) -- (e11 `op1` e12) `op2` e2 mkOpAppRn e1@(L _ (OpApp e11 op1 fix1 e12)) op2 fix2 e2 @@ -606,13 +620,13 @@ mkOpAppRn e1@(L _ (OpApp e11 op1 fix1 e12)) op2 fix2 e2 (nofix_error, associate_right) = compareFixity fix1 fix2 --------------------------- --- (- neg_arg) `op` e2 +-- (- neg_arg) `op` e2 mkOpAppRn e1@(L _ (NegApp neg_arg neg_name)) op2 fix2 e2 | nofix_error = do precParseErr (negateName,negateFixity) (get_op op2,fix2) return (OpApp e1 op2 fix2 e2) - | associate_right + | associate_right = do new_e <- mkOpAppRn neg_arg op2 fix2 e2 return (NegApp (L loc' new_e) neg_name) where @@ -620,19 +634,19 @@ mkOpAppRn e1@(L _ (NegApp neg_arg neg_name)) op2 fix2 e2 (nofix_error, associate_right) = compareFixity negateFixity fix2 --------------------------- --- e1 `op` - neg_arg -mkOpAppRn e1 op1 fix1 e2@(L _ (NegApp _ _)) -- NegApp can occur on the right - | not associate_right -- We *want* right association +-- e1 `op` - neg_arg +mkOpAppRn e1 op1 fix1 e2@(L _ (NegApp _ _)) -- NegApp can occur on the right + | not associate_right -- We *want* right association = do precParseErr (get_op op1, fix1) (negateName, negateFixity) return (OpApp e1 op1 fix1 e2) where (_, associate_right) = compareFixity fix1 negateFixity --------------------------- --- Default case -mkOpAppRn e1 op fix e2 -- Default case, no rearrangment +-- Default case +mkOpAppRn e1 op fix e2 -- Default case, no rearrangment = ASSERT2( right_op_ok fix (unLoc e2), - ppr e1 $$ text "---" $$ ppr op $$ text "---" $$ ppr fix $$ text "---" $$ ppr e2 + ppr e1 $$ text "---" $$ ppr op $$ text "---" $$ ppr fix $$ text "---" $$ ppr e2 ) return (OpApp e1 op fix e2) @@ -641,7 +655,7 @@ get_op :: LHsExpr Name -> Name get_op (L _ (HsVar n)) = n get_op other = pprPanic "get_op" (ppr other) --- Parser left-associates everything, but +-- Parser left-associates everything, but -- derived instances may have correctly-associated things to -- in the right operarand. So we just check that the right operand is OK right_op_ok :: Fixity -> HsExpr Name -> Bool @@ -661,17 +675,17 @@ mkNegAppRn neg_arg neg_name not_op_app :: HsExpr id -> Bool not_op_app (OpApp _ _ _ _) = False -not_op_app _ = True +not_op_app _ = True --------------------------- -mkOpFormRn :: LHsCmdTop Name -- Left operand; already rearranged - -> LHsExpr Name -> Fixity -- Operator and fixity - -> LHsCmdTop Name -- Right operand (not an infix) - -> RnM (HsCmd Name) +mkOpFormRn :: LHsCmdTop Name -- Left operand; already rearranged + -> LHsExpr Name -> Fixity -- Operator and fixity + -> LHsCmdTop Name -- Right operand (not an infix) + -> RnM (HsCmd Name) -- (e11 `op1` e12) `op2` e2 mkOpFormRn a1@(L loc (HsCmdTop (L _ (HsCmdArrForm op1 (Just fix1) [a11,a12])) _ _ _)) - op2 fix2 a2 + op2 fix2 a2 | nofix_error = do precParseErr (get_op op1,fix1) (get_op op2,fix2) return (HsCmdArrForm op2 (Just fix2) [a1, a2]) @@ -679,40 +693,40 @@ mkOpFormRn a1@(L loc (HsCmdTop (L _ (HsCmdArrForm op1 (Just fix1) [a11,a12])) _ | associate_right = do new_c <- mkOpFormRn a12 op2 fix2 a2 return (HsCmdArrForm op1 (Just fix1) - [a11, L loc (HsCmdTop (L loc new_c) placeHolderType placeHolderType [])]) - -- TODO: locs are wrong + [a11, L loc (HsCmdTop (L loc new_c) placeHolderType placeHolderType [])]) + -- TODO: locs are wrong where (nofix_error, associate_right) = compareFixity fix1 fix2 --- Default case -mkOpFormRn arg1 op fix arg2 -- Default case, no rearrangment +-- Default case +mkOpFormRn arg1 op fix arg2 -- Default case, no rearrangment = return (HsCmdArrForm op (Just fix) [arg1, arg2]) -------------------------------------- mkConOpPatRn :: Located Name -> Fixity -> LPat Name -> LPat Name - -> RnM (Pat Name) + -> RnM (Pat Name) mkConOpPatRn op2 fix2 p1@(L loc (ConPatIn op1 (InfixCon p11 p12))) p2 - = do { fix1 <- lookupFixityRn (unLoc op1) - ; let (nofix_error, associate_right) = compareFixity fix1 fix2 + = do { fix1 <- lookupFixityRn (unLoc op1) + ; let (nofix_error, associate_right) = compareFixity fix1 fix2 - ; if nofix_error then do - { precParseErr (unLoc op1,fix1) (unLoc op2,fix2) - ; return (ConPatIn op2 (InfixCon p1 p2)) } + ; if nofix_error then do + { precParseErr (unLoc op1,fix1) (unLoc op2,fix2) + ; return (ConPatIn op2 (InfixCon p1 p2)) } - else if associate_right then do - { new_p <- mkConOpPatRn op2 fix2 p12 p2 - ; return (ConPatIn op1 (InfixCon p11 (L loc new_p))) } -- XXX loc right? - else return (ConPatIn op2 (InfixCon p1 p2)) } + else if associate_right then do + { new_p <- mkConOpPatRn op2 fix2 p12 p2 + ; return (ConPatIn op1 (InfixCon p11 (L loc new_p))) } -- XXX loc right? + else return (ConPatIn op2 (InfixCon p1 p2)) } -mkConOpPatRn op _ p1 p2 -- Default case, no rearrangment +mkConOpPatRn op _ p1 p2 -- Default case, no rearrangment = ASSERT( not_op_pat (unLoc p2) ) return (ConPatIn op (InfixCon p1 p2)) not_op_pat :: Pat Name -> Bool not_op_pat (ConPatIn _ (InfixCon _ _)) = False -not_op_pat _ = True +not_op_pat _ = True -------------------------------------- checkPrecMatch :: Name -> MatchGroup Name body -> RnM () @@ -720,36 +734,36 @@ checkPrecMatch :: Name -> MatchGroup Name body -> RnM () -- eg a `op` b `C` c = ... -- See comments with rnExpr (OpApp ...) about "deriving" -checkPrecMatch op (MG { mg_alts = ms }) - = mapM_ check ms +checkPrecMatch op (MG { mg_alts = ms }) + = mapM_ check ms where check (L _ (Match (L l1 p1 : L l2 p2 :_) _ _)) = setSrcSpan (combineSrcSpans l1 l2) $ do checkPrec op p1 False checkPrec op p2 True - check _ = return () - -- This can happen. Consider - -- a `op` True = ... - -- op = ... - -- The infix flag comes from the first binding of the group - -- but the second eqn has no args (an error, but not discovered - -- until the type checker). So we don't want to crash on the - -- second eqn. + check _ = return () + -- This can happen. Consider + -- a `op` True = ... + -- op = ... + -- The infix flag comes from the first binding of the group + -- but the second eqn has no args (an error, but not discovered + -- until the type checker). So we don't want to crash on the + -- second eqn. checkPrec :: Name -> Pat Name -> Bool -> IOEnv (Env TcGblEnv TcLclEnv) () checkPrec op (ConPatIn op1 (InfixCon _ _)) right = do op_fix@(Fixity op_prec op_dir) <- lookupFixityRn op op1_fix@(Fixity op1_prec op1_dir) <- lookupFixityRn (unLoc op1) let - inf_ok = op1_prec > op_prec || - (op1_prec == op_prec && - (op1_dir == InfixR && op_dir == InfixR && right || - op1_dir == InfixL && op_dir == InfixL && not right)) - - info = (op, op_fix) - info1 = (unLoc op1, op1_fix) - (infol, infor) = if right then (info, info1) else (info1, info) + inf_ok = op1_prec > op_prec || + (op1_prec == op_prec && + (op1_dir == InfixR && op_dir == InfixR && right || + op1_dir == InfixL && op_dir == InfixL && not right)) + + info = (op, op_fix) + info1 = (unLoc op1, op1_fix) + (infol, infor) = if right then (info, info1) else (info1, info) unless inf_ok (precParseErr infol infor) checkPrec _ _ _ @@ -760,56 +774,56 @@ checkPrec _ _ _ -- (a) its precedence must be higher than that of op -- (b) its precedency & associativity must be the same as that of op checkSectionPrec :: FixityDirection -> HsExpr RdrName - -> LHsExpr Name -> LHsExpr Name -> RnM () + -> LHsExpr Name -> LHsExpr Name -> RnM () checkSectionPrec direction section op arg = case unLoc arg of - OpApp _ op fix _ -> go_for_it (get_op op) fix - NegApp _ _ -> go_for_it negateName negateFixity - _ -> return () + OpApp _ op fix _ -> go_for_it (get_op op) fix + NegApp _ _ -> go_for_it negateName negateFixity + _ -> return () where op_name = get_op op go_for_it arg_op arg_fix@(Fixity arg_prec assoc) = do op_fix@(Fixity op_prec _) <- lookupFixityRn op_name - unless (op_prec < arg_prec - || (op_prec == arg_prec && direction == assoc)) - (sectionPrecErr (op_name, op_fix) - (arg_op, arg_fix) section) + unless (op_prec < arg_prec + || (op_prec == arg_prec && direction == assoc)) + (sectionPrecErr (op_name, op_fix) + (arg_op, arg_fix) section) \end{code} Precedence-related error messages \begin{code} precParseErr :: (Name, Fixity) -> (Name, Fixity) -> RnM () -precParseErr op1@(n1,_) op2@(n2,_) +precParseErr op1@(n1,_) op2@(n2,_) | isUnboundName n1 || isUnboundName n2 - = return () -- Avoid error cascade + = return () -- Avoid error cascade | otherwise = addErr $ hang (ptext (sLit "Precedence parsing error")) - 4 (hsep [ptext (sLit "cannot mix"), ppr_opfix op1, ptext (sLit "and"), - ppr_opfix op2, - ptext (sLit "in the same infix expression")]) + 4 (hsep [ptext (sLit "cannot mix"), ppr_opfix op1, ptext (sLit "and"), + ppr_opfix op2, + ptext (sLit "in the same infix expression")]) sectionPrecErr :: (Name, Fixity) -> (Name, Fixity) -> HsExpr RdrName -> RnM () sectionPrecErr op@(n1,_) arg_op@(n2,_) section | isUnboundName n1 || isUnboundName n2 - = return () -- Avoid error cascade + = return () -- Avoid error cascade | otherwise = addErr $ vcat [ptext (sLit "The operator") <+> ppr_opfix op <+> ptext (sLit "of a section"), - nest 4 (sep [ptext (sLit "must have lower precedence than that of the operand,"), - nest 2 (ptext (sLit "namely") <+> ppr_opfix arg_op)]), - nest 4 (ptext (sLit "in the section:") <+> quotes (ppr section))] + nest 4 (sep [ptext (sLit "must have lower precedence than that of the operand,"), + nest 2 (ptext (sLit "namely") <+> ppr_opfix arg_op)]), + nest 4 (ptext (sLit "in the section:") <+> quotes (ppr section))] ppr_opfix :: (Name, Fixity) -> SDoc ppr_opfix (op, fixity) = pp_op <+> brackets (ppr fixity) where pp_op | op == negateName = ptext (sLit "prefix `-'") - | otherwise = quotes (ppr op) + | otherwise = quotes (ppr op) \end{code} %********************************************************* -%* * +%* * \subsection{Errors} -%* * +%* * %********************************************************* \begin{code} @@ -821,7 +835,7 @@ warnUnusedForAlls in_doc bound mentioned_rdrs bound_names = hsLTyVarLocNames bound bound_but_not_used = filterOut ((`elem` mentioned_rdrs) . unLoc) bound_names - add_warn (L loc tv) + add_warn (L loc tv) = addWarnAt loc $ vcat [ ptext (sLit "Unused quantified type variable") <+> quotes (ppr tv) , in_doc ] @@ -829,30 +843,30 @@ warnUnusedForAlls in_doc bound mentioned_rdrs opTyErr :: RdrName -> HsType RdrName -> SDoc opTyErr op ty@(HsOpTy ty1 _ _) = hang (ptext (sLit "Illegal operator") <+> quotes (ppr op) <+> ptext (sLit "in type") <+> quotes (ppr ty)) - 2 extra + 2 extra where extra | op == dot_tv_RDR && forall_head ty1 - = perhapsForallMsg - | otherwise - = ptext (sLit "Use -XTypeOperators to allow operators in types") + = perhapsForallMsg + | otherwise + = ptext (sLit "Use -XTypeOperators to allow operators in types") forall_head (L _ (HsTyVar tv)) = tv == forall_tv_RDR forall_head (L _ (HsAppTy ty _)) = forall_head ty - forall_head _other = False + forall_head _other = False opTyErr _ ty = pprPanic "opTyErr: Not an op" (ppr ty) \end{code} %********************************************************* -%* * - Splices -%* * +%* * + Splices +%* * %********************************************************* Note [Splices] ~~~~~~~~~~~~~~ Consider - f = ... - h = ...$(thing "f")... + f = ... + h = ...$(thing "f")... The splice can expand into literally anything, so when we do dependency analysis we must assume that it might mention 'f'. So we simply treat @@ -870,30 +884,30 @@ type checker. Not very satisfactory really. \begin{code} rnSplice :: HsSplice RdrName -> RnM (HsSplice Name, FreeVars) rnSplice (HsSplice n expr) - = do { checkTH expr "splice" - ; loc <- getSrcSpanM - ; n' <- newLocalBndrRn (L loc n) - ; (expr', fvs) <- rnLExpr expr + = do { checkTH expr "splice" + ; loc <- getSrcSpanM + ; n' <- newLocalBndrRn (L loc n) + ; (expr', fvs) <- rnLExpr expr - -- Ugh! See Note [Splices] above - ; lcl_rdr <- getLocalRdrEnv - ; gbl_rdr <- getGlobalRdrEnv - ; let gbl_names = mkNameSet [gre_name gre | gre <- globalRdrEnvElts gbl_rdr, - isLocalGRE gre] - lcl_names = mkNameSet (localRdrEnvElts lcl_rdr) + -- Ugh! See Note [Splices] above + ; lcl_rdr <- getLocalRdrEnv + ; gbl_rdr <- getGlobalRdrEnv + ; let gbl_names = mkNameSet [gre_name gre | gre <- globalRdrEnvElts gbl_rdr, + isLocalGRE gre] + lcl_names = mkNameSet (localRdrEnvElts lcl_rdr) - ; return (HsSplice n' expr', fvs `plusFV` lcl_names `plusFV` gbl_names) } + ; return (HsSplice n' expr', fvs `plusFV` lcl_names `plusFV` gbl_names) } checkTH :: Outputable a => a -> String -> RnM () -#ifdef GHCI -checkTH _ _ = return () -- OK +#ifdef GHCI +checkTH _ _ = return () -- OK #else -checkTH e what -- Raise an error in a stage-1 compiler - = addErr (vcat [ptext (sLit "Template Haskell") <+> text what <+> - ptext (sLit "requires GHC with interpreter support"), +checkTH e what -- Raise an error in a stage-1 compiler + = addErr (vcat [ptext (sLit "Template Haskell") <+> text what <+> + ptext (sLit "requires GHC with interpreter support"), ptext (sLit "Perhaps you are using a stage-1 compiler?"), - nest 2 (ppr e)]) -#endif + nest 2 (ppr e)]) +#endif \end{code} %************************************************************************ @@ -924,7 +938,7 @@ recently, kind variables. For example: * type instance F (T (a :: Maybe k)) = ...a...k... Here we want to constrain the kind of 'a', and bind 'k'. -In general we want to walk over a type, and find +In general we want to walk over a type, and find * Its free type variables * The free kind variables of any kind signatures in the type @@ -935,7 +949,7 @@ See also Note [HsBSig binder lists] in HsTypes type FreeKiTyVars = ([RdrName], [RdrName]) filterInScope :: LocalRdrEnv -> FreeKiTyVars -> FreeKiTyVars -filterInScope rdr_env (kvs, tvs) +filterInScope rdr_env (kvs, tvs) = (filterOut in_scope kvs, filterOut in_scope tvs) where in_scope tv = tv `elemLocalRdrEnv` rdr_env @@ -945,13 +959,13 @@ extractHsTyRdrTyVars :: LHsType RdrName -> FreeKiTyVars -- or the free (sort, kind) variables of a HsKind -- It's used when making the for-alls explicit. -- See Note [Kind and type-variable binders] -extractHsTyRdrTyVars ty +extractHsTyRdrTyVars ty = case extract_lty ty ([],[]) of (kvs, tvs) -> (nub kvs, nub tvs) extractHsTysRdrTyVars :: [LHsType RdrName] -> FreeKiTyVars -- See Note [Kind and type-variable binders] -extractHsTysRdrTyVars ty +extractHsTysRdrTyVars ty = case extract_ltys ty ([],[]) of (kvs, tvs) -> (nub kvs, nub tvs) @@ -1017,26 +1031,25 @@ extract_lty (L _ ty) acc HsTyLit _ -> acc HsWrapTy _ _ -> panic "extract_lty" HsKindSig ty ki -> extract_lty ty (extract_lkind ki acc) + HsRoleAnnot ty _ -> extract_lty ty acc HsForAllTy _ tvs cx ty -> extract_hs_tv_bndrs tvs acc $ extract_lctxt cx $ extract_lty ty ([],[]) extract_hs_tv_bndrs :: LHsTyVarBndrs RdrName -> FreeKiTyVars -> FreeKiTyVars -> FreeKiTyVars -extract_hs_tv_bndrs (HsQTvs { hsq_tvs = tvs }) - acc@(acc_kvs, acc_tvs) -- Note accumulator comes first +extract_hs_tv_bndrs (HsQTvs { hsq_tvs = tvs }) + (acc_kvs, acc_tvs) -- Note accumulator comes first (body_kvs, body_tvs) | null tvs = (body_kvs ++ acc_kvs, body_tvs ++ acc_tvs) | otherwise - = (outer_kvs ++ body_kvs, - outer_tvs ++ filterOut (`elem` local_tvs) body_tvs) + = (acc_kvs ++ filterOut (`elem` local_kvs) body_kvs, + acc_tvs ++ filterOut (`elem` local_tvs) body_tvs) where local_tvs = map hsLTyVarName tvs - -- Currently we don't have a syntax to explicitly bind - -- kind variables, so these are all type variables - - (outer_kvs, outer_tvs) = foldr extract_lkind acc [k | L _ (KindedTyVar _ k) <- tvs] + (_, local_kvs) = foldr extract_lty ([], []) [k | L _ (HsTyVarBndr _ (Just k) _) <- tvs] + -- These kind variables are bound here if not bound further out extract_tv :: RdrName -> FreeKiTyVars -> FreeKiTyVars extract_tv tv acc |