diff options
Diffstat (limited to 'compiler/rename')
| -rw-r--r-- | compiler/rename/RnBinds.hs | 150 | ||||
| -rw-r--r-- | compiler/rename/RnEnv.hs | 29 | ||||
| -rw-r--r-- | compiler/rename/RnExpr.hs | 226 | ||||
| -rw-r--r-- | compiler/rename/RnExpr.hs-boot | 22 | ||||
| -rw-r--r-- | compiler/rename/RnFixity.hs | 2 | ||||
| -rw-r--r-- | compiler/rename/RnNames.hs | 87 | ||||
| -rw-r--r-- | compiler/rename/RnPat.hs | 64 | ||||
| -rw-r--r-- | compiler/rename/RnSource.hs | 187 | ||||
| -rw-r--r-- | compiler/rename/RnSplice.hs | 63 | ||||
| -rw-r--r-- | compiler/rename/RnSplice.hs-boot | 12 | ||||
| -rw-r--r-- | compiler/rename/RnTypes.hs | 211 | ||||
| -rw-r--r-- | compiler/rename/RnUtils.hs | 2 |
12 files changed, 549 insertions, 506 deletions
diff --git a/compiler/rename/RnBinds.hs b/compiler/rename/RnBinds.hs index 7f0490a68e..5d6d037e6e 100644 --- a/compiler/rename/RnBinds.hs +++ b/compiler/rename/RnBinds.hs @@ -1,4 +1,5 @@ {-# LANGUAGE ScopedTypeVariables, BangPatterns #-} +{-# LANGUAGE TypeFamilies #-} {- (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 @@ -170,12 +171,13 @@ it expects the global environment to contain bindings for the binders -- for top-level bindings, we need to make top-level names, -- so we have a different entry point than for local bindings rnTopBindsLHS :: MiniFixityEnv - -> HsValBinds RdrName - -> RnM (HsValBindsLR Name RdrName) + -> HsValBinds GhcPs + -> RnM (HsValBindsLR GhcRn GhcPs) rnTopBindsLHS fix_env binds = rnValBindsLHS (topRecNameMaker fix_env) binds -rnTopBindsBoot :: NameSet -> HsValBindsLR Name RdrName -> RnM (HsValBinds Name, DefUses) +rnTopBindsBoot :: NameSet -> HsValBindsLR GhcRn GhcPs + -> RnM (HsValBinds GhcRn, DefUses) -- A hs-boot file has no bindings. -- Return a single HsBindGroup with empty binds and renamed signatures rnTopBindsBoot bound_names (ValBindsIn mbinds sigs) @@ -192,9 +194,9 @@ rnTopBindsBoot _ b = pprPanic "rnTopBindsBoot" (ppr b) ********************************************************* -} -rnLocalBindsAndThen :: HsLocalBinds RdrName - -> (HsLocalBinds Name -> FreeVars -> RnM (result, FreeVars)) - -> RnM (result, FreeVars) +rnLocalBindsAndThen :: HsLocalBinds GhcPs + -> (HsLocalBinds GhcRn -> FreeVars -> RnM (result, FreeVars)) + -> RnM (result, FreeVars) -- This version (a) assumes that the binding vars are *not* already in scope -- (b) removes the binders from the free vars of the thing inside -- The parser doesn't produce ThenBinds @@ -210,12 +212,12 @@ rnLocalBindsAndThen (HsIPBinds binds) thing_inside = do (thing, fvs_thing) <- thing_inside (HsIPBinds binds') fv_binds return (thing, fvs_thing `plusFV` fv_binds) -rnIPBinds :: HsIPBinds RdrName -> RnM (HsIPBinds Name, FreeVars) +rnIPBinds :: HsIPBinds GhcPs -> RnM (HsIPBinds GhcRn, FreeVars) rnIPBinds (IPBinds ip_binds _no_dict_binds) = do (ip_binds', fvs_s) <- mapAndUnzipM (wrapLocFstM rnIPBind) ip_binds return (IPBinds ip_binds' emptyTcEvBinds, plusFVs fvs_s) -rnIPBind :: IPBind RdrName -> RnM (IPBind Name, FreeVars) +rnIPBind :: IPBind GhcPs -> RnM (IPBind GhcRn, FreeVars) rnIPBind (IPBind ~(Left n) expr) = do (expr',fvExpr) <- rnLExpr expr return (IPBind (Left n) expr', fvExpr) @@ -231,8 +233,8 @@ rnIPBind (IPBind ~(Left n) expr) = do -- Renaming local binding groups -- Does duplicate/shadow check rnLocalValBindsLHS :: MiniFixityEnv - -> HsValBinds RdrName - -> RnM ([Name], HsValBindsLR Name RdrName) + -> HsValBinds GhcPs + -> RnM ([Name], HsValBindsLR GhcRn GhcPs) rnLocalValBindsLHS fix_env binds = do { binds' <- rnValBindsLHS (localRecNameMaker fix_env) binds @@ -267,8 +269,8 @@ rnLocalValBindsLHS fix_env binds -- generic version used both at the top level and for local binds -- does some error checking, but not what gets done elsewhere at the top level rnValBindsLHS :: NameMaker - -> HsValBinds RdrName - -> RnM (HsValBindsLR Name RdrName) + -> HsValBinds GhcPs + -> RnM (HsValBindsLR GhcRn GhcPs) rnValBindsLHS topP (ValBindsIn mbinds sigs) = do { mbinds' <- mapBagM (wrapLocM (rnBindLHS topP doc)) mbinds ; return $ ValBindsIn mbinds' sigs } @@ -283,8 +285,8 @@ rnValBindsLHS _ b = pprPanic "rnValBindsLHSFromDoc" (ppr b) -- -- Does not bind the local fixity declarations rnValBindsRHS :: HsSigCtxt - -> HsValBindsLR Name RdrName - -> RnM (HsValBinds Name, DefUses) + -> HsValBindsLR GhcRn GhcPs + -> RnM (HsValBinds GhcRn, DefUses) rnValBindsRHS ctxt (ValBindsIn mbinds sigs) = do { (sigs', sig_fvs) <- renameSigs ctxt sigs @@ -317,8 +319,8 @@ rnValBindsRHS _ b = pprPanic "rnValBindsRHS" (ppr b) -- -- The client is also responsible for bringing the fixities into scope rnLocalValBindsRHS :: NameSet -- names bound by the LHSes - -> HsValBindsLR Name RdrName - -> RnM (HsValBinds Name, DefUses) + -> HsValBindsLR GhcRn GhcPs + -> RnM (HsValBinds GhcRn, DefUses) rnLocalValBindsRHS bound_names binds = rnValBindsRHS (LocalBindCtxt bound_names) binds @@ -328,8 +330,8 @@ rnLocalValBindsRHS bound_names binds -- here there are no local fixity decls passed in; -- the local fixity decls come from the ValBinds sigs rnLocalValBindsAndThen - :: HsValBinds RdrName - -> (HsValBinds Name -> FreeVars -> RnM (result, FreeVars)) + :: HsValBinds GhcPs + -> (HsValBinds GhcRn -> FreeVars -> RnM (result, FreeVars)) -> RnM (result, FreeVars) rnLocalValBindsAndThen binds@(ValBindsIn _ sigs) thing_inside = do { -- (A) Create the local fixity environment @@ -390,11 +392,11 @@ rnLocalValBindsAndThen bs _ = pprPanic "rnLocalValBindsAndThen" (ppr bs) rnBindLHS :: NameMaker -> SDoc - -> HsBind RdrName + -> HsBind GhcPs -- returns the renamed left-hand side, -- and the FreeVars *of the LHS* -- (i.e., any free variables of the pattern) - -> RnM (HsBindLR Name RdrName) + -> RnM (HsBindLR GhcRn GhcPs) rnBindLHS name_maker _ bind@(PatBind { pat_lhs = pat }) = do @@ -429,18 +431,18 @@ rnBindLHS name_maker _ (PatSynBind psb@PSB{ psb_id = rdrname }) rnBindLHS _ _ b = pprPanic "rnBindHS" (ppr b) -rnLBind :: (Name -> [Name]) -- Signature tyvar function - -> LHsBindLR Name RdrName - -> RnM (LHsBind Name, [Name], Uses) +rnLBind :: (Name -> [Name]) -- Signature tyvar function + -> LHsBindLR GhcRn GhcPs + -> RnM (LHsBind GhcRn, [Name], Uses) rnLBind sig_fn (L loc bind) = setSrcSpan loc $ do { (bind', bndrs, dus) <- rnBind sig_fn bind ; return (L loc bind', bndrs, dus) } -- assumes the left-hands-side vars are in scope -rnBind :: (Name -> [Name]) -- Signature tyvar function - -> HsBindLR Name RdrName - -> RnM (HsBind Name, [Name], Uses) +rnBind :: (Name -> [Name]) -- Signature tyvar function + -> HsBindLR GhcRn GhcPs + -> RnM (HsBind GhcRn, [Name], Uses) rnBind _ bind@(PatBind { pat_lhs = pat , pat_rhs = grhss -- pat fvs were stored in bind_fvs @@ -542,8 +544,8 @@ trac ticket #1136. * * ********************************************************************* -} -depAnalBinds :: Bag (LHsBind Name, [Name], Uses) - -> ([(RecFlag, LHsBinds Name)], DefUses) +depAnalBinds :: Bag (LHsBind GhcRn, [Name], Uses) + -> ([(RecFlag, LHsBinds GhcRn)], DefUses) -- Dependency analysis; this is important so that -- unused-binding reporting is accurate depAnalBinds binds_w_dus @@ -577,14 +579,14 @@ depAnalBinds binds_w_dus -- (x,y) = e -- In e, 'a' will be in scope, and it'll be the one from 'y'! -mkSigTvFn :: [LSig Name] -> (Name -> [Name]) +mkSigTvFn :: [LSig GhcRn] -> (Name -> [Name]) -- Return a lookup function that maps an Id Name to the names -- of the type variables that should scope over its body. mkSigTvFn sigs = \n -> lookupNameEnv env n `orElse` [] where env = mkHsSigEnv get_scoped_tvs sigs - get_scoped_tvs :: LSig Name -> Maybe ([Located Name], [Name]) + get_scoped_tvs :: LSig GhcRn -> Maybe ([Located Name], [Name]) -- Returns (binders, scoped tvs for those binders) get_scoped_tvs (L _ (ClassOpSig _ names sig_ty)) = Just (names, hsScopedTvs sig_ty) @@ -601,7 +603,7 @@ mkSigTvFn sigs = \n -> lookupNameEnv env n `orElse` [] -- Note: for local fixity declarations, duplicates would also be checked in -- check_sigs below. But we also use this function at the top level. -makeMiniFixityEnv :: [LFixitySig RdrName] -> RnM MiniFixityEnv +makeMiniFixityEnv :: [LFixitySig GhcPs] -> RnM MiniFixityEnv makeMiniFixityEnv decls = foldlM add_one_sig emptyFsEnv decls where @@ -637,9 +639,9 @@ dupFixityDecl loc rdr_name * * ********************************************************************* -} -rnPatSynBind :: (Name -> [Name]) -- Signature tyvar function - -> PatSynBind Name RdrName - -> RnM (PatSynBind Name Name, [Name], Uses) +rnPatSynBind :: (Name -> [Name]) -- Signature tyvar function + -> PatSynBind GhcRn GhcPs + -> RnM (PatSynBind GhcRn GhcRn, [Name], Uses) rnPatSynBind sig_fn bind@(PSB { psb_id = L l name , psb_args = details , psb_def = pat @@ -809,9 +811,9 @@ a binder. rnMethodBinds :: Bool -- True <=> is a class declaration -> Name -- Class name -> [Name] -- Type variables from the class/instance header - -> LHsBinds RdrName -- Binds - -> [LSig RdrName] -- and signatures/pragmas - -> RnM (LHsBinds Name, [LSig Name], FreeVars) + -> LHsBinds GhcPs -- Binds + -> [LSig GhcPs] -- and signatures/pragmas + -> RnM (LHsBinds GhcRn, [LSig GhcRn], FreeVars) -- Used for -- * the default method bindings in a class decl -- * the method bindings in an instance decl @@ -864,9 +866,9 @@ rnMethodBinds is_cls_decl cls ktv_names binds sigs | otherwise = thing_inside rnMethodBindLHS :: Bool -> Name - -> LHsBindLR RdrName RdrName - -> LHsBindsLR Name RdrName - -> RnM (LHsBindsLR Name RdrName) + -> LHsBindLR GhcPs GhcPs + -> LHsBindsLR GhcRn GhcPs + -> RnM (LHsBindsLR GhcRn GhcPs) rnMethodBindLHS _ cls (L loc bind@(FunBind { fun_id = name })) rest = setSrcSpan loc $ do do { sel_name <- wrapLocM (lookupInstDeclBndr cls (text "method")) name @@ -910,8 +912,8 @@ signatures. We'd only need this if we wanted to report unused tyvars. -} renameSigs :: HsSigCtxt - -> [LSig RdrName] - -> RnM ([LSig Name], FreeVars) + -> [LSig GhcPs] + -> RnM ([LSig GhcRn], FreeVars) -- Renames the signatures and performs error checks renameSigs ctxt sigs = do { mapM_ dupSigDeclErr (findDupSigs sigs) @@ -935,7 +937,7 @@ renameSigs ctxt sigs -- is in scope. (I'm assuming that Baz.op isn't in scope unqualified.) -- Doesn't seem worth much trouble to sort this. -renameSig :: HsSigCtxt -> Sig RdrName -> RnM (Sig Name, FreeVars) +renameSig :: HsSigCtxt -> Sig GhcPs -> RnM (Sig GhcRn, FreeVars) -- FixitySig is renamed elsewhere. renameSig _ (IdSig x) = return (IdSig x, emptyFVs) -- Actually this never occurs @@ -1089,7 +1091,7 @@ okHsSig ctxt (L _ sig) (CompleteMatchSig {}, _) -> False ------------------- -findDupSigs :: [LSig RdrName] -> [[(Located RdrName, Sig RdrName)]] +findDupSigs :: [LSig GhcPs] -> [[(Located RdrName, Sig GhcPs)]] -- Check for duplicates on RdrName version, -- because renamed version has unboundName for -- not-in-scope binders, which gives bogus dup-sig errors @@ -1119,7 +1121,7 @@ findDupSigs sigs mtch _ _ = False -- Warn about multiple MINIMAL signatures -checkDupMinimalSigs :: [LSig RdrName] -> RnM () +checkDupMinimalSigs :: [LSig GhcPs] -> RnM () checkDupMinimalSigs sigs = case filter isMinimalLSig sigs of minSigs@(_:_:_) -> dupMinimalSigErr minSigs @@ -1133,26 +1135,26 @@ checkDupMinimalSigs sigs ************************************************************************ -} -rnMatchGroup :: Outputable (body RdrName) => HsMatchContext Name - -> (Located (body RdrName) -> RnM (Located (body Name), FreeVars)) - -> MatchGroup RdrName (Located (body RdrName)) - -> RnM (MatchGroup Name (Located (body Name)), FreeVars) +rnMatchGroup :: Outputable (body GhcPs) => HsMatchContext Name + -> (Located (body GhcPs) -> RnM (Located (body GhcRn), FreeVars)) + -> MatchGroup GhcPs (Located (body GhcPs)) + -> RnM (MatchGroup GhcRn (Located (body GhcRn)), FreeVars) rnMatchGroup ctxt rnBody (MG { mg_alts = L _ ms, mg_origin = origin }) = do { empty_case_ok <- xoptM LangExt.EmptyCase ; when (null ms && not empty_case_ok) (addErr (emptyCaseErr ctxt)) ; (new_ms, ms_fvs) <- mapFvRn (rnMatch ctxt rnBody) ms ; return (mkMatchGroup origin new_ms, ms_fvs) } -rnMatch :: Outputable (body RdrName) => HsMatchContext Name - -> (Located (body RdrName) -> RnM (Located (body Name), FreeVars)) - -> LMatch RdrName (Located (body RdrName)) - -> RnM (LMatch Name (Located (body Name)), FreeVars) +rnMatch :: Outputable (body GhcPs) => HsMatchContext Name + -> (Located (body GhcPs) -> RnM (Located (body GhcRn), FreeVars)) + -> LMatch GhcPs (Located (body GhcPs)) + -> RnM (LMatch GhcRn (Located (body GhcRn)), FreeVars) rnMatch ctxt rnBody = wrapLocFstM (rnMatch' ctxt rnBody) -rnMatch' :: Outputable (body RdrName) => HsMatchContext Name - -> (Located (body RdrName) -> RnM (Located (body Name), FreeVars)) - -> Match RdrName (Located (body RdrName)) - -> RnM (Match Name (Located (body Name)), FreeVars) +rnMatch' :: Outputable (body GhcPs) => HsMatchContext Name + -> (Located (body GhcPs) -> RnM (Located (body GhcRn), FreeVars)) + -> Match GhcPs (Located (body GhcPs)) + -> RnM (Match GhcRn (Located (body GhcRn)), FreeVars) rnMatch' ctxt rnBody match@(Match { m_ctxt = mf, m_pats = pats , m_type = maybe_rhs_sig, m_grhss = grhss }) = do { -- Result type signatures are no longer supported @@ -1183,7 +1185,7 @@ emptyCaseErr ctxt = hang (text "Empty list of alternatives in" <+> pp_ctxt) resSigErr :: Outputable body - => Match RdrName body -> HsType RdrName -> SDoc + => Match GhcPs body -> HsType GhcPs -> SDoc resSigErr match ty = vcat [ text "Illegal result type signature" <+> quotes (ppr ty) , nest 2 $ ptext (sLit @@ -1199,24 +1201,24 @@ resSigErr match ty -} rnGRHSs :: HsMatchContext Name - -> (Located (body RdrName) -> RnM (Located (body Name), FreeVars)) - -> GRHSs RdrName (Located (body RdrName)) - -> RnM (GRHSs Name (Located (body Name)), FreeVars) + -> (Located (body GhcPs) -> RnM (Located (body GhcRn), FreeVars)) + -> GRHSs GhcPs (Located (body GhcPs)) + -> RnM (GRHSs GhcRn (Located (body GhcRn)), FreeVars) rnGRHSs ctxt rnBody (GRHSs grhss (L l binds)) = rnLocalBindsAndThen binds $ \ binds' _ -> do (grhss', fvGRHSs) <- mapFvRn (rnGRHS ctxt rnBody) grhss return (GRHSs grhss' (L l binds'), fvGRHSs) rnGRHS :: HsMatchContext Name - -> (Located (body RdrName) -> RnM (Located (body Name), FreeVars)) - -> LGRHS RdrName (Located (body RdrName)) - -> RnM (LGRHS Name (Located (body Name)), FreeVars) + -> (Located (body GhcPs) -> RnM (Located (body GhcRn), FreeVars)) + -> LGRHS GhcPs (Located (body GhcPs)) + -> RnM (LGRHS GhcRn (Located (body GhcRn)), FreeVars) rnGRHS ctxt rnBody = wrapLocFstM (rnGRHS' ctxt rnBody) rnGRHS' :: HsMatchContext Name - -> (Located (body RdrName) -> RnM (Located (body Name), FreeVars)) - -> GRHS RdrName (Located (body RdrName)) - -> RnM (GRHS Name (Located (body Name)), FreeVars) + -> (Located (body GhcPs) -> RnM (Located (body GhcRn), FreeVars)) + -> GRHS GhcPs (Located (body GhcPs)) + -> RnM (GRHS GhcRn (Located (body GhcRn)), FreeVars) rnGRHS' ctxt rnBody (GRHS guards rhs) = do { pattern_guards_allowed <- xoptM LangExt.PatternGuards ; ((guards', rhs'), fvs) <- rnStmts (PatGuard ctxt) rnLExpr guards $ \ _ -> @@ -1242,7 +1244,7 @@ rnGRHS' ctxt rnBody (GRHS guards rhs) ************************************************************************ -} -dupSigDeclErr :: [(Located RdrName, Sig RdrName)] -> RnM () +dupSigDeclErr :: [(Located RdrName, Sig GhcPs)] -> RnM () dupSigDeclErr pairs@((L loc name, sig) : _) = addErrAt loc $ vcat [ text "Duplicate" <+> what_it_is @@ -1253,32 +1255,32 @@ dupSigDeclErr pairs@((L loc name, sig) : _) dupSigDeclErr [] = panic "dupSigDeclErr" -misplacedSigErr :: LSig Name -> RnM () +misplacedSigErr :: LSig GhcRn -> RnM () misplacedSigErr (L loc sig) = addErrAt loc $ sep [text "Misplaced" <+> hsSigDoc sig <> colon, ppr sig] -defaultSigErr :: Sig RdrName -> SDoc +defaultSigErr :: Sig GhcPs -> SDoc defaultSigErr sig = vcat [ hang (text "Unexpected default signature:") 2 (ppr sig) , text "Use DefaultSignatures to enable default signatures" ] -bindsInHsBootFile :: LHsBindsLR Name RdrName -> SDoc +bindsInHsBootFile :: LHsBindsLR GhcRn GhcPs -> SDoc bindsInHsBootFile mbinds = hang (text "Bindings in hs-boot files are not allowed") 2 (ppr mbinds) -nonStdGuardErr :: Outputable body => [LStmtLR Name Name body] -> SDoc +nonStdGuardErr :: Outputable body => [LStmtLR GhcRn GhcRn body] -> SDoc nonStdGuardErr guards = hang (text "accepting non-standard pattern guards (use PatternGuards to suppress this message)") 4 (interpp'SP guards) -unusedPatBindWarn :: HsBind Name -> SDoc +unusedPatBindWarn :: HsBind GhcRn -> SDoc unusedPatBindWarn bind = hang (text "This pattern-binding binds no variables:") 2 (ppr bind) -dupMinimalSigErr :: [LSig RdrName] -> RnM () +dupMinimalSigErr :: [LSig GhcPs] -> RnM () dupMinimalSigErr sigs@(L loc _ : _) = addErrAt loc $ vcat [ text "Multiple minimal complete definitions" diff --git a/compiler/rename/RnEnv.hs b/compiler/rename/RnEnv.hs index 902c10a379..2ad4413920 100644 --- a/compiler/rename/RnEnv.hs +++ b/compiler/rename/RnEnv.hs @@ -385,7 +385,8 @@ lookupInstDeclBndr cls what rdr doc = what <+> text "of class" <+> quotes (ppr cls) ----------------------------------------------- -lookupFamInstName :: Maybe Name -> Located RdrName -> RnM (Located Name) +lookupFamInstName :: Maybe Name -> Located RdrName + -> RnM (Located Name) -- Used for TyData and TySynonym family instances only, -- See Note [Family instance binders] lookupFamInstName (Just cls) tc_rdr -- Associated type; c.f RnBinds.rnMethodBind @@ -440,8 +441,8 @@ lookupExactOrOrig rdr_name res k -- unambiguous because there is only one field id 'fld' in scope. -- But currently it's rejected. -lookupRecFieldOcc :: Maybe Name -- Nothing => just look it up as usual - -- Just tycon => use tycon to disambiguate +lookupRecFieldOcc :: Maybe Name -- Nothing => just look it up as usual + -- Just tycon => use tycon to disambiguate -> SDoc -> RdrName -> RnM Name lookupRecFieldOcc parent doc rdr_name @@ -612,8 +613,8 @@ data ChildLookupResult Name -- Name of thing we were looking for SDoc -- How to print the name [Name] -- List of possible parents - | FoundName Parent Name -- We resolved to a normal name - | FoundFL FieldLabel -- We resolved to a FL + | FoundName Parent Name -- We resolved to a normal name + | FoundFL FieldLabel -- We resolved to a FL -- | Specialised version of msum for RnM ChildLookupResult combineChildLookupResult :: [RnM ChildLookupResult] -> RnM ChildLookupResult @@ -935,7 +936,8 @@ lookupOccRnX_maybe globalLookup wrapper rdr_name lookupOccRn_maybe :: RdrName -> RnM (Maybe Name) lookupOccRn_maybe = lookupOccRnX_maybe lookupGlobalOccRn_maybe id -lookupOccRn_overloaded :: Bool -> RdrName -> RnM (Maybe (Either Name [Name])) +lookupOccRn_overloaded :: Bool -> RdrName + -> RnM (Maybe (Either Name [Name])) lookupOccRn_overloaded overload_ok = lookupOccRnX_maybe global_lookup Left where @@ -1343,7 +1345,7 @@ instance Outputable HsSigCtxt where ppr (RoleAnnotCtxt ns) = text "RoleAnnotCtxt" <+> ppr ns lookupSigOccRn :: HsSigCtxt - -> Sig RdrName + -> Sig GhcPs -> Located RdrName -> RnM (Located Name) lookupSigOccRn ctxt sig = lookupSigCtxtOccRn ctxt (hsSigDoc sig) @@ -1507,10 +1509,10 @@ We treat the original (standard) names as free-vars too, because the type checke checks the type of the user thing against the type of the standard thing. -} -lookupIfThenElse :: RnM (Maybe (SyntaxExpr Name), FreeVars) +lookupIfThenElse :: RnM (Maybe (SyntaxExpr GhcRn), FreeVars) -- Different to lookupSyntaxName because in the non-rebindable -- case we desugar directly rather than calling an existing function --- Hence the (Maybe (SyntaxExpr Name)) return type +-- Hence the (Maybe (SyntaxExpr GhcRn)) return type lookupIfThenElse = do { rebindable_on <- xoptM LangExt.RebindableSyntax ; if not rebindable_on @@ -1529,8 +1531,9 @@ lookupSyntaxName' std_name -- Get the similarly named thing from the local environment lookupOccRn (mkRdrUnqual (nameOccName std_name)) } -lookupSyntaxName :: Name -- The standard name - -> RnM (SyntaxExpr Name, FreeVars) -- Possibly a non-standard name +lookupSyntaxName :: Name -- The standard name + -> RnM (SyntaxExpr GhcRn, FreeVars) -- Possibly a non-standard + -- name lookupSyntaxName std_name = do { rebindable_on <- xoptM LangExt.RebindableSyntax ; if not rebindable_on then @@ -1540,8 +1543,8 @@ lookupSyntaxName std_name do { usr_name <- lookupOccRn (mkRdrUnqual (nameOccName std_name)) ; return (mkRnSyntaxExpr usr_name, unitFV usr_name) } } -lookupSyntaxNames :: [Name] -- Standard names - -> RnM ([HsExpr Name], FreeVars) -- See comments with HsExpr.ReboundNames +lookupSyntaxNames :: [Name] -- Standard names + -> RnM ([HsExpr GhcRn], FreeVars) -- See comments with HsExpr.ReboundNames -- this works with CmdTop, which wants HsExprs, not SyntaxExprs lookupSyntaxNames std_names = do { rebindable_on <- xoptM LangExt.RebindableSyntax diff --git a/compiler/rename/RnExpr.hs b/compiler/rename/RnExpr.hs index 027f6dc178..e1a314f029 100644 --- a/compiler/rename/RnExpr.hs +++ b/compiler/rename/RnExpr.hs @@ -13,6 +13,7 @@ free variables. {-# LANGUAGE CPP #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE TypeFamilies #-} module RnExpr ( rnLExpr, rnExpr, rnStmts @@ -65,7 +66,7 @@ import Data.Array ************************************************************************ -} -rnExprs :: [LHsExpr RdrName] -> RnM ([LHsExpr Name], FreeVars) +rnExprs :: [LHsExpr GhcPs] -> RnM ([LHsExpr GhcRn], FreeVars) rnExprs ls = rnExprs' ls emptyUniqSet where rnExprs' [] acc = return ([], acc) @@ -79,12 +80,12 @@ rnExprs ls = rnExprs' ls emptyUniqSet -- Variables. We look up the variable and return the resulting name. -rnLExpr :: LHsExpr RdrName -> RnM (LHsExpr Name, FreeVars) +rnLExpr :: LHsExpr GhcPs -> RnM (LHsExpr GhcRn, FreeVars) rnLExpr = wrapLocFstM rnExpr -rnExpr :: HsExpr RdrName -> RnM (HsExpr Name, FreeVars) +rnExpr :: HsExpr GhcPs -> RnM (HsExpr GhcRn, FreeVars) -finishHsVar :: Located Name -> RnM (HsExpr Name, FreeVars) +finishHsVar :: Located Name -> RnM (HsExpr GhcRn, FreeVars) -- Separated from rnExpr because it's also used -- when renaming infix expressions finishHsVar (L l name) @@ -93,7 +94,7 @@ finishHsVar (L l name) checkThLocalName name ; return (HsVar (L l name), unitFV name) } -rnUnboundVar :: RdrName -> RnM (HsExpr Name, FreeVars) +rnUnboundVar :: RdrName -> RnM (HsExpr GhcRn, FreeVars) rnUnboundVar v = do { if isUnqual v then -- Treat this as a "hole" @@ -145,11 +146,11 @@ rnExpr (HsLit lit@(HsString src s)) rnExpr (HsOverLit (mkHsIsString src s placeHolderType)) else do { ; rnLit lit - ; return (HsLit lit, emptyFVs) } } + ; return (HsLit (convertLit lit), emptyFVs) } } rnExpr (HsLit lit) = do { rnLit lit - ; return (HsLit lit, emptyFVs) } + ; return (HsLit (convertLit lit), emptyFVs) } rnExpr (HsOverLit lit) = do { ((lit', mb_neg), fvs) <- rnOverLit lit -- See Note [Negative zero] @@ -409,7 +410,7 @@ rnExpr other = pprPanic "rnExpr: unexpected expression" (ppr other) hsHoleExpr :: HsExpr id hsHoleExpr = HsUnboundVar (TrueExprHole (mkVarOcc "_")) -arrowFail :: HsExpr RdrName -> RnM (HsExpr Name, FreeVars) +arrowFail :: HsExpr GhcPs -> RnM (HsExpr GhcRn, FreeVars) arrowFail e = do { addErr (vcat [ text "Arrow command found where an expression was expected:" , nest 2 (ppr e) ]) @@ -419,7 +420,7 @@ arrowFail e ---------------------- -- See Note [Parsing sections] in Parser.y -rnSection :: HsExpr RdrName -> RnM (HsExpr Name, FreeVars) +rnSection :: HsExpr GhcPs -> RnM (HsExpr GhcRn, FreeVars) rnSection section@(SectionR op expr) = do { (op', fvs_op) <- rnLExpr op ; (expr', fvs_expr) <- rnLExpr expr @@ -442,14 +443,14 @@ rnSection other = pprPanic "rnSection" (ppr other) ************************************************************************ -} -rnCmdArgs :: [LHsCmdTop RdrName] -> RnM ([LHsCmdTop Name], FreeVars) +rnCmdArgs :: [LHsCmdTop GhcPs] -> RnM ([LHsCmdTop GhcRn], FreeVars) rnCmdArgs [] = return ([], emptyFVs) rnCmdArgs (arg:args) = do { (arg',fvArg) <- rnCmdTop arg ; (args',fvArgs) <- rnCmdArgs args ; return (arg':args', fvArg `plusFV` fvArgs) } -rnCmdTop :: LHsCmdTop RdrName -> RnM (LHsCmdTop Name, FreeVars) +rnCmdTop :: LHsCmdTop GhcPs -> RnM (LHsCmdTop GhcRn, FreeVars) rnCmdTop = wrapLocFstM rnCmdTop' where rnCmdTop' (HsCmdTop cmd _ _ _) @@ -463,10 +464,10 @@ rnCmdTop = wrapLocFstM rnCmdTop' (cmd_names `zip` cmd_names'), fvCmd `plusFV` cmd_fvs) } -rnLCmd :: LHsCmd RdrName -> RnM (LHsCmd Name, FreeVars) +rnLCmd :: LHsCmd GhcPs -> RnM (LHsCmd GhcRn, FreeVars) rnLCmd = wrapLocFstM rnCmd -rnCmd :: HsCmd RdrName -> RnM (HsCmd Name, FreeVars) +rnCmd :: HsCmd GhcPs -> RnM (HsCmd GhcRn, FreeVars) rnCmd (HsCmdArrApp arrow arg _ ho rtl) = do { (arrow',fvArrow) <- select_arrow_scope (rnLExpr arrow) @@ -541,10 +542,10 @@ type CmdNeeds = FreeVars -- Only inhabitants are -- appAName, choiceAName, loopAName -- find what methods the Cmd needs (loop, choice, apply) -methodNamesLCmd :: LHsCmd Name -> CmdNeeds +methodNamesLCmd :: LHsCmd GhcRn -> CmdNeeds methodNamesLCmd = methodNamesCmd . unLoc -methodNamesCmd :: HsCmd Name -> CmdNeeds +methodNamesCmd :: HsCmd GhcRn -> CmdNeeds methodNamesCmd (HsCmdArrApp _arrow _arg _ HsFirstOrderApp _rtl) = emptyFVs @@ -572,7 +573,7 @@ methodNamesCmd (HsCmdCase _ matches) -- The type checker will complain later --------------------------------------------------- -methodNamesMatch :: MatchGroup Name (LHsCmd Name) -> FreeVars +methodNamesMatch :: MatchGroup GhcRn (LHsCmd GhcRn) -> FreeVars methodNamesMatch (MG { mg_alts = L _ ms }) = plusFVs (map do_one ms) where @@ -580,23 +581,23 @@ methodNamesMatch (MG { mg_alts = L _ ms }) ------------------------------------------------- -- gaw 2004 -methodNamesGRHSs :: GRHSs Name (LHsCmd Name) -> FreeVars +methodNamesGRHSs :: GRHSs GhcRn (LHsCmd GhcRn) -> FreeVars methodNamesGRHSs (GRHSs grhss _) = plusFVs (map methodNamesGRHS grhss) ------------------------------------------------- -methodNamesGRHS :: Located (GRHS Name (LHsCmd Name)) -> CmdNeeds +methodNamesGRHS :: Located (GRHS GhcRn (LHsCmd GhcRn)) -> CmdNeeds methodNamesGRHS (L _ (GRHS _ rhs)) = methodNamesLCmd rhs --------------------------------------------------- -methodNamesStmts :: [Located (StmtLR Name Name (LHsCmd Name))] -> FreeVars +methodNamesStmts :: [Located (StmtLR GhcRn GhcRn (LHsCmd GhcRn))] -> FreeVars methodNamesStmts stmts = plusFVs (map methodNamesLStmt stmts) --------------------------------------------------- -methodNamesLStmt :: Located (StmtLR Name Name (LHsCmd Name)) -> FreeVars +methodNamesLStmt :: Located (StmtLR GhcRn GhcRn (LHsCmd GhcRn)) -> FreeVars methodNamesLStmt = methodNamesStmt . unLoc -methodNamesStmt :: StmtLR Name Name (LHsCmd Name) -> FreeVars +methodNamesStmt :: StmtLR GhcRn GhcRn (LHsCmd GhcRn) -> FreeVars methodNamesStmt (LastStmt cmd _ _) = methodNamesLCmd cmd methodNamesStmt (BodyStmt cmd _ _ _) = methodNamesLCmd cmd methodNamesStmt (BindStmt _ cmd _ _ _) = methodNamesLCmd cmd @@ -617,7 +618,7 @@ methodNamesStmt ApplicativeStmt{} = emptyFVs ************************************************************************ -} -rnArithSeq :: ArithSeqInfo RdrName -> RnM (ArithSeqInfo Name, FreeVars) +rnArithSeq :: ArithSeqInfo GhcPs -> RnM (ArithSeqInfo GhcRn, FreeVars) rnArithSeq (From expr) = do { (expr', fvExpr) <- rnLExpr expr ; return (From expr', fvExpr) } @@ -669,34 +670,34 @@ See Note [Deterministic UniqFM] to learn more about nondeterminism. -} -- | Rename some Stmts -rnStmts :: Outputable (body RdrName) +rnStmts :: Outputable (body GhcPs) => HsStmtContext Name - -> (Located (body RdrName) -> RnM (Located (body Name), FreeVars)) + -> (Located (body GhcPs) -> RnM (Located (body GhcRn), FreeVars)) -- ^ How to rename the body of each statement (e.g. rnLExpr) - -> [LStmt RdrName (Located (body RdrName))] + -> [LStmt GhcPs (Located (body GhcPs))] -- ^ Statements -> ([Name] -> RnM (thing, FreeVars)) -- ^ if these statements scope over something, this renames it -- and returns the result. - -> RnM (([LStmt Name (Located (body Name))], thing), FreeVars) + -> RnM (([LStmt GhcRn (Located (body GhcRn))], thing), FreeVars) rnStmts ctxt rnBody = rnStmtsWithPostProcessing ctxt rnBody noPostProcessStmts -- | like 'rnStmts' but applies a post-processing step to the renamed Stmts rnStmtsWithPostProcessing - :: Outputable (body RdrName) + :: Outputable (body GhcPs) => HsStmtContext Name - -> (Located (body RdrName) -> RnM (Located (body Name), FreeVars)) + -> (Located (body GhcPs) -> RnM (Located (body GhcRn), FreeVars)) -- ^ How to rename the body of each statement (e.g. rnLExpr) -> (HsStmtContext Name - -> [(LStmt Name (Located (body Name)), FreeVars)] - -> RnM ([LStmt Name (Located (body Name))], FreeVars)) + -> [(LStmt GhcRn (Located (body GhcRn)), FreeVars)] + -> RnM ([LStmt GhcRn (Located (body GhcRn))], FreeVars)) -- ^ postprocess the statements - -> [LStmt RdrName (Located (body RdrName))] + -> [LStmt GhcPs (Located (body GhcPs))] -- ^ Statements -> ([Name] -> RnM (thing, FreeVars)) -- ^ if these statements scope over something, this renames it -- and returns the result. - -> RnM (([LStmt Name (Located (body Name))], thing), FreeVars) + -> RnM (([LStmt GhcRn (Located (body GhcRn))], thing), FreeVars) rnStmtsWithPostProcessing ctxt rnBody ppStmts stmts thing_inside = do { ((stmts', thing), fvs) <- rnStmtsWithFreeVars ctxt rnBody stmts thing_inside @@ -707,8 +708,8 @@ rnStmtsWithPostProcessing ctxt rnBody ppStmts stmts thing_inside -- | maybe rearrange statements according to the ApplicativeDo transformation postProcessStmtsForApplicativeDo :: HsStmtContext Name - -> [(ExprLStmt Name, FreeVars)] - -> RnM ([ExprLStmt Name], FreeVars) + -> [(ExprLStmt GhcRn, FreeVars)] + -> RnM ([ExprLStmt GhcRn], FreeVars) postProcessStmtsForApplicativeDo ctxt stmts = do { -- rearrange the statements using ApplicativeStmt if @@ -724,17 +725,17 @@ postProcessStmtsForApplicativeDo ctxt stmts -- | strip the FreeVars annotations from statements noPostProcessStmts :: HsStmtContext Name - -> [(LStmt Name (Located (body Name)), FreeVars)] - -> RnM ([LStmt Name (Located (body Name))], FreeVars) + -> [(LStmt GhcRn (Located (body GhcRn)), FreeVars)] + -> RnM ([LStmt GhcRn (Located (body GhcRn))], FreeVars) noPostProcessStmts _ stmts = return (map fst stmts, emptyNameSet) -rnStmtsWithFreeVars :: Outputable (body RdrName) +rnStmtsWithFreeVars :: Outputable (body GhcPs) => HsStmtContext Name - -> (Located (body RdrName) -> RnM (Located (body Name), FreeVars)) - -> [LStmt RdrName (Located (body RdrName))] + -> (Located (body GhcPs) -> RnM (Located (body GhcRn), FreeVars)) + -> [LStmt GhcPs (Located (body GhcPs))] -> ([Name] -> RnM (thing, FreeVars)) - -> RnM ( ([(LStmt Name (Located (body Name)), FreeVars)], thing) + -> RnM ( ([(LStmt GhcRn (Located (body GhcRn)), FreeVars)], thing) , FreeVars) -- Each Stmt body is annotated with its FreeVars, so that -- we can rearrange statements for ApplicativeDo. @@ -792,15 +793,15 @@ exhaustive list). How we deal with pattern match failure is context-dependent. At one point we failed to make this distinction, leading to #11216. -} -rnStmt :: Outputable (body RdrName) +rnStmt :: Outputable (body GhcPs) => HsStmtContext Name - -> (Located (body RdrName) -> RnM (Located (body Name), FreeVars)) + -> (Located (body GhcPs) -> RnM (Located (body GhcRn), FreeVars)) -- ^ How to rename the body of the statement - -> LStmt RdrName (Located (body RdrName)) + -> LStmt GhcPs (Located (body GhcPs)) -- ^ The statement -> ([Name] -> RnM (thing, FreeVars)) -- ^ Rename the stuff that this statement scopes over - -> RnM ( ([(LStmt Name (Located (body Name)), FreeVars)], thing) + -> RnM ( ([(LStmt GhcRn (Located (body GhcRn)), FreeVars)], thing) , FreeVars) -- Variables bound by the Stmt, and mentioned in thing_inside, -- do not appear in the result FreeVars @@ -938,18 +939,18 @@ rnStmt _ _ (L _ ApplicativeStmt{}) _ = panic "rnStmt: ApplicativeStmt" rnParallelStmts :: forall thing. HsStmtContext Name - -> SyntaxExpr Name - -> [ParStmtBlock RdrName RdrName] + -> SyntaxExpr GhcRn + -> [ParStmtBlock GhcPs GhcPs] -> ([Name] -> RnM (thing, FreeVars)) - -> RnM (([ParStmtBlock Name Name], thing), FreeVars) + -> RnM (([ParStmtBlock GhcRn GhcRn], thing), FreeVars) -- Note [Renaming parallel Stmts] rnParallelStmts ctxt return_op segs thing_inside = do { orig_lcl_env <- getLocalRdrEnv ; rn_segs orig_lcl_env [] segs } where rn_segs :: LocalRdrEnv - -> [Name] -> [ParStmtBlock RdrName RdrName] - -> RnM (([ParStmtBlock Name Name], thing), FreeVars) + -> [Name] -> [ParStmtBlock GhcPs GhcPs] + -> RnM (([ParStmtBlock GhcRn GhcRn], thing), FreeVars) rn_segs _ bndrs_so_far [] = do { let (bndrs', dups) = removeDups cmpByOcc bndrs_so_far ; mapM_ dupErr dups @@ -971,7 +972,7 @@ rnParallelStmts ctxt return_op segs thing_inside dupErr vs = addErr (text "Duplicate binding in parallel list comprehension for:" <+> quotes (ppr (head vs))) -lookupStmtName :: HsStmtContext Name -> Name -> RnM (SyntaxExpr Name, FreeVars) +lookupStmtName :: HsStmtContext Name -> Name -> RnM (SyntaxExpr GhcRn, FreeVars) -- Like lookupSyntaxName, but respects contexts lookupStmtName ctxt n | rebindableContext ctxt @@ -979,7 +980,7 @@ lookupStmtName ctxt n | otherwise = return (mkRnSyntaxExpr n, emptyFVs) -lookupStmtNamePoly :: HsStmtContext Name -> Name -> RnM (HsExpr Name, FreeVars) +lookupStmtNamePoly :: HsStmtContext Name -> Name -> RnM (HsExpr GhcRn, FreeVars) lookupStmtNamePoly ctxt name | rebindableContext ctxt = do { rebindable_on <- xoptM LangExt.RebindableSyntax @@ -1047,13 +1048,13 @@ type Segment stmts = (Defs, -- wrapper that does both the left- and right-hand sides -rnRecStmtsAndThen :: Outputable (body RdrName) => - (Located (body RdrName) - -> RnM (Located (body Name), FreeVars)) - -> [LStmt RdrName (Located (body RdrName))] +rnRecStmtsAndThen :: Outputable (body GhcPs) => + (Located (body GhcPs) + -> RnM (Located (body GhcRn), FreeVars)) + -> [LStmt GhcPs (Located (body GhcPs))] -- assumes that the FreeVars returned includes -- the FreeVars of the Segments - -> ([Segment (LStmt Name (Located (body Name)))] + -> ([Segment (LStmt GhcRn (Located (body GhcRn)))] -> RnM (a, FreeVars)) -> RnM (a, FreeVars) rnRecStmtsAndThen rnBody s cont @@ -1077,7 +1078,7 @@ rnRecStmtsAndThen rnBody s cont ; return (res, fvs) }} -- get all the fixity decls in any Let stmt -collectRecStmtsFixities :: [LStmtLR RdrName RdrName body] -> [LFixitySig RdrName] +collectRecStmtsFixities :: [LStmtLR GhcPs GhcPs body] -> [LFixitySig GhcPs] collectRecStmtsFixities l = foldr (\ s -> \acc -> case s of (L _ (LetStmt (L _ (HsValBinds (ValBindsIn _ sigs))))) -> @@ -1089,11 +1090,11 @@ collectRecStmtsFixities l = -- left-hand sides rn_rec_stmt_lhs :: Outputable body => MiniFixityEnv - -> LStmt RdrName body + -> LStmt GhcPs body -- rename LHS, and return its FVs -- Warning: we will only need the FreeVars below in the case of a BindStmt, -- so we don't bother to compute it accurately in the other cases - -> RnM [(LStmtLR Name RdrName body, FreeVars)] + -> RnM [(LStmtLR GhcRn GhcPs body, FreeVars)] rn_rec_stmt_lhs _ (L loc (BodyStmt body a b c)) = return [(L loc (BodyStmt body a b c), emptyFVs)] @@ -1135,8 +1136,8 @@ rn_rec_stmt_lhs _ (L _ (LetStmt (L _ EmptyLocalBinds))) = panic "rn_rec_stmt LetStmt EmptyLocalBinds" rn_rec_stmts_lhs :: Outputable body => MiniFixityEnv - -> [LStmt RdrName body] - -> RnM [(LStmtLR Name RdrName body, FreeVars)] + -> [LStmt GhcPs body] + -> RnM [(LStmtLR GhcRn GhcPs body, FreeVars)] rn_rec_stmts_lhs fix_env stmts = do { ls <- concatMapM (rn_rec_stmt_lhs fix_env) stmts ; let boundNames = collectLStmtsBinders (map fst ls) @@ -1149,11 +1150,11 @@ rn_rec_stmts_lhs fix_env stmts -- right-hand-sides -rn_rec_stmt :: (Outputable (body RdrName)) => - (Located (body RdrName) -> RnM (Located (body Name), FreeVars)) +rn_rec_stmt :: (Outputable (body GhcPs)) => + (Located (body GhcPs) -> RnM (Located (body GhcRn), FreeVars)) -> [Name] - -> (LStmtLR Name RdrName (Located (body RdrName)), FreeVars) - -> RnM [Segment (LStmt Name (Located (body Name)))] + -> (LStmtLR GhcRn GhcPs (Located (body GhcPs)), FreeVars) + -> RnM [Segment (LStmt GhcRn (Located (body GhcRn)))] -- Rename a Stmt that is inside a RecStmt (or mdo) -- Assumes all binders are already in scope -- Turns each stmt into a singleton Stmt @@ -1209,20 +1210,20 @@ rn_rec_stmt _ _ (L _ (LetStmt (L _ EmptyLocalBinds)), _) rn_rec_stmt _ _ stmt@(L _ (ApplicativeStmt {}), _) = pprPanic "rn_rec_stmt: ApplicativeStmt" (ppr stmt) -rn_rec_stmts :: Outputable (body RdrName) => - (Located (body RdrName) -> RnM (Located (body Name), FreeVars)) +rn_rec_stmts :: Outputable (body GhcPs) => + (Located (body GhcPs) -> RnM (Located (body GhcRn), FreeVars)) -> [Name] - -> [(LStmtLR Name RdrName (Located (body RdrName)), FreeVars)] - -> RnM [Segment (LStmt Name (Located (body Name)))] + -> [(LStmtLR GhcRn GhcPs (Located (body GhcPs)), FreeVars)] + -> RnM [Segment (LStmt GhcRn (Located (body GhcRn)))] rn_rec_stmts rnBody bndrs stmts = do { segs_s <- mapM (rn_rec_stmt rnBody bndrs) stmts ; return (concat segs_s) } --------------------------------------------- segmentRecStmts :: SrcSpan -> HsStmtContext Name - -> Stmt Name body - -> [Segment (LStmt Name body)] -> FreeVars - -> ([LStmt Name body], FreeVars) + -> Stmt GhcRn body + -> [Segment (LStmt GhcRn body)] -> FreeVars + -> ([LStmt GhcRn body], FreeVars) segmentRecStmts loc ctxt empty_rec_stmt segs fvs_later | null segs @@ -1324,8 +1325,9 @@ glom it together with the first two groups -} glomSegments :: HsStmtContext Name - -> [Segment (LStmt Name body)] - -> [Segment [LStmt Name body]] -- Each segment has a non-empty list of Stmts + -> [Segment (LStmt GhcRn body)] + -> [Segment [LStmt GhcRn body]] + -- Each segment has a non-empty list of Stmts -- See Note [Glomming segments] glomSegments _ [] = [] @@ -1354,10 +1356,12 @@ glomSegments ctxt ((defs,uses,fwds,stmt) : segs) not_needed (defs,_,_,_) = not (intersectsNameSet defs uses) ---------------------------------------------------- -segsToStmts :: Stmt Name body -- A RecStmt with the SyntaxOps filled in - -> [Segment [LStmt Name body]] -- Each Segment has a non-empty list of Stmts - -> FreeVars -- Free vars used 'later' - -> ([LStmt Name body], FreeVars) +segsToStmts :: Stmt GhcRn body + -- A RecStmt with the SyntaxOps filled in + -> [Segment [LStmt GhcRn body]] + -- Each Segment has a non-empty list of Stmts + -> FreeVars -- Free vars used 'later' + -> ([LStmt GhcRn body], FreeVars) segsToStmts _ [] fvs_later = ([], fvs_later) segsToStmts empty_rec_stmt ((defs, uses, fwds, ss) : segs) fvs_later @@ -1499,8 +1503,8 @@ data MonadNames = MonadNames { return_name, pure_name :: Name } -- Note [ApplicativeDo]. rearrangeForApplicativeDo :: HsStmtContext Name - -> [(ExprLStmt Name, FreeVars)] - -> RnM ([ExprLStmt Name], FreeVars) + -> [(ExprLStmt GhcRn, FreeVars)] + -> RnM ([ExprLStmt GhcRn], FreeVars) rearrangeForApplicativeDo _ [] = return ([], emptyNameSet) rearrangeForApplicativeDo _ [(one,_)] = return ([one], emptyNameSet) @@ -1532,12 +1536,12 @@ flattenStmtTree t = go t [] go (StmtTreeBind l r) as = go l (go r as) go (StmtTreeApplicative ts) as = foldr go as ts -type ExprStmtTree = StmtTree (ExprLStmt Name, FreeVars) +type ExprStmtTree = StmtTree (ExprLStmt GhcRn, FreeVars) type Cost = Int -- | Turn a sequence of statements into an ExprStmtTree using a -- heuristic algorithm. /O(n^2)/ -mkStmtTreeHeuristic :: [(ExprLStmt Name, FreeVars)] -> ExprStmtTree +mkStmtTreeHeuristic :: [(ExprLStmt GhcRn, FreeVars)] -> ExprStmtTree mkStmtTreeHeuristic [one] = StmtTreeOne one mkStmtTreeHeuristic stmts = case segments stmts of @@ -1551,7 +1555,7 @@ mkStmtTreeHeuristic stmts = -- | Turn a sequence of statements into an ExprStmtTree optimally, -- using dynamic programming. /O(n^3)/ -mkStmtTreeOptimal :: [(ExprLStmt Name, FreeVars)] -> ExprStmtTree +mkStmtTreeOptimal :: [(ExprLStmt GhcRn, FreeVars)] -> ExprStmtTree mkStmtTreeOptimal stmts = ASSERT(not (null stmts)) -- the empty case is handled by the caller; -- we don't support empty StmtTrees. @@ -1618,9 +1622,9 @@ stmtTreeToStmts :: MonadNames -> HsStmtContext Name -> ExprStmtTree - -> [ExprLStmt Name] -- ^ the "tail" + -> [ExprLStmt GhcRn] -- ^ the "tail" -> FreeVars -- ^ free variables of the tail - -> RnM ( [ExprLStmt Name] -- ( output statements, + -> RnM ( [ExprLStmt GhcRn] -- ( output statements, , FreeVars ) -- , things we needed -- If we have a single bind, and we can do it without a join, transform @@ -1679,8 +1683,8 @@ stmtTreeToStmts monad_names ctxt (StmtTreeApplicative trees) tail tail_fvs = do -- | Divide a sequence of statements into segments, where no segment -- depends on any variables defined by a statement in another segment. segments - :: [(ExprLStmt Name, FreeVars)] - -> [[(ExprLStmt Name, FreeVars)]] + :: [(ExprLStmt GhcRn, FreeVars)] + -> [[(ExprLStmt GhcRn, FreeVars)]] segments stmts = map fst $ merge $ reverse $ map reverse $ walk (reverse stmts) where allvars = mkNameSet (concatMap (collectStmtBinders.unLoc.fst) stmts) @@ -1702,7 +1706,7 @@ segments stmts = map fst $ merge $ reverse $ map reverse $ walk (reverse stmts) -- the sequence from the back to the front, and keeping track of -- the set of free variables of the current segment. Whenever -- this set of free variables is empty, we have a complete segment. - walk :: [(ExprLStmt Name, FreeVars)] -> [[(ExprLStmt Name, FreeVars)]] + walk :: [(ExprLStmt GhcRn, FreeVars)] -> [[(ExprLStmt GhcRn, FreeVars)]] walk [] = [] walk ((stmt,fvs) : stmts) = ((stmt,fvs) : seg) : walk rest where (seg,rest) = chunter fvs' stmts @@ -1732,9 +1736,9 @@ isLetStmt _ = False -- heuristic is to peel off the first group of independent statements -- and put the bind after those. splitSegment - :: [(ExprLStmt Name, FreeVars)] - -> ( [(ExprLStmt Name, FreeVars)] - , [(ExprLStmt Name, FreeVars)] ) + :: [(ExprLStmt GhcRn, FreeVars)] + -> ( [(ExprLStmt GhcRn, FreeVars)] + , [(ExprLStmt GhcRn, FreeVars)] ) splitSegment [one,two] = ([one],[two]) -- there is no choice when there are only two statements; this just saves -- some work in a common case. @@ -1749,10 +1753,10 @@ splitSegment stmts _other -> (stmts,[]) slurpIndependentStmts - :: [(LStmt Name (Located (body Name)), FreeVars)] - -> Maybe ( [(LStmt Name (Located (body Name)), FreeVars)] -- LetStmts - , [(LStmt Name (Located (body Name)), FreeVars)] -- BindStmts - , [(LStmt Name (Located (body Name)), FreeVars)] ) + :: [(LStmt GhcRn (Located (body GhcRn)), FreeVars)] + -> Maybe ( [(LStmt GhcRn (Located (body GhcRn)), FreeVars)] -- LetStmts + , [(LStmt GhcRn (Located (body GhcRn)), FreeVars)] -- BindStmts + , [(LStmt GhcRn (Located (body GhcRn)), FreeVars)] ) slurpIndependentStmts stmts = go [] [] emptyNameSet stmts where -- If we encounter a BindStmt that doesn't depend on a previous BindStmt @@ -1789,10 +1793,10 @@ slurpIndependentStmts stmts = go [] [] emptyNameSet stmts -- typechecker and the desugarer (I tried it that way first!). mkApplicativeStmt :: HsStmtContext Name - -> [ApplicativeArg Name Name] -- ^ The args + -> [ApplicativeArg GhcRn GhcRn] -- ^ The args -> Bool -- ^ True <=> need a join - -> [ExprLStmt Name] -- ^ The body statements - -> RnM ([ExprLStmt Name], FreeVars) + -> [ExprLStmt GhcRn] -- ^ The body statements + -> RnM ([ExprLStmt GhcRn], FreeVars) mkApplicativeStmt ctxt args need_join body_stmts = do { (fmap_op, fvs1) <- lookupStmtName ctxt fmapName ; (ap_op, fvs2) <- lookupStmtName ctxt apAName @@ -1812,8 +1816,8 @@ mkApplicativeStmt ctxt args need_join body_stmts -- | Given the statements following an ApplicativeStmt, determine whether -- we need a @join@ or not, and remove the @return@ if necessary. needJoin :: MonadNames - -> [ExprLStmt Name] - -> (Bool, [ExprLStmt Name]) + -> [ExprLStmt GhcRn] + -> (Bool, [ExprLStmt GhcRn]) needJoin _monad_names [] = (False, []) -- we're in an ApplicativeArg needJoin monad_names [L loc (LastStmt e _ t)] | Just arg <- isReturnApp monad_names e = @@ -1823,8 +1827,8 @@ needJoin _monad_names stmts = (True, stmts) -- | @Just e@, if the expression is @return e@ or @return $ e@, -- otherwise @Nothing@ isReturnApp :: MonadNames - -> LHsExpr Name - -> Maybe (LHsExpr Name) + -> LHsExpr GhcRn + -> Maybe (LHsExpr GhcRn) isReturnApp monad_names (L _ (HsPar expr)) = isReturnApp monad_names expr isReturnApp monad_names (L _ e) = case e of OpApp l op _ r | is_return l, is_dollar op -> Just r @@ -1864,9 +1868,9 @@ emptyErr (TransStmtCtxt {}) = text "Empty statement group preceding 'group' or ' emptyErr ctxt = text "Empty" <+> pprStmtContext ctxt ---------------------- -checkLastStmt :: Outputable (body RdrName) => HsStmtContext Name - -> LStmt RdrName (Located (body RdrName)) - -> RnM (LStmt RdrName (Located (body RdrName))) +checkLastStmt :: Outputable (body GhcPs) => HsStmtContext Name + -> LStmt GhcPs (Located (body GhcPs)) + -> RnM (LStmt GhcPs (Located (body GhcPs))) checkLastStmt ctxt lstmt@(L loc stmt) = case ctxt of ListComp -> check_comp @@ -1896,7 +1900,7 @@ checkLastStmt ctxt lstmt@(L loc stmt) -- Checking when a particular Stmt is ok checkStmt :: HsStmtContext Name - -> LStmt RdrName (Located (body RdrName)) + -> LStmt GhcPs (Located (body GhcPs)) -> RnM () checkStmt ctxt (L _ stmt) = do { dflags <- getDynFlags @@ -1923,7 +1927,7 @@ emptyInvalid = NotValid Outputable.empty okStmt, okDoStmt, okCompStmt, okParStmt, okPArrStmt :: DynFlags -> HsStmtContext Name - -> Stmt RdrName (Located (body RdrName)) -> Validity + -> Stmt GhcPs (Located (body GhcPs)) -> Validity -- Return Nothing if OK, (Just extra) if not ok -- The "extra" is an SDoc that is appended to an generic error message @@ -1941,7 +1945,7 @@ okStmt dflags ctxt stmt TransStmtCtxt ctxt -> okStmt dflags ctxt stmt ------------- -okPatGuardStmt :: Stmt RdrName (Located (body RdrName)) -> Validity +okPatGuardStmt :: Stmt GhcPs (Located (body GhcPs)) -> Validity okPatGuardStmt stmt = case stmt of BodyStmt {} -> IsValid @@ -1998,7 +2002,7 @@ okPArrStmt dflags _ stmt ApplicativeStmt {} -> emptyInvalid --------- -checkTupleSection :: [LHsTupArg RdrName] -> RnM () +checkTupleSection :: [LHsTupArg GhcPs] -> RnM () checkTupleSection args = do { tuple_section <- xoptM LangExt.TupleSections ; checkErr (all tupArgPresent args || tuple_section) msg } @@ -2006,12 +2010,12 @@ checkTupleSection args msg = text "Illegal tuple section: use TupleSections" --------- -sectionErr :: HsExpr RdrName -> SDoc +sectionErr :: HsExpr GhcPs -> SDoc sectionErr expr = hang (text "A section must be enclosed in parentheses") 2 (text "thus:" <+> (parens (ppr expr))) -patSynErr :: HsExpr RdrName -> SDoc -> RnM (HsExpr Name, FreeVars) +patSynErr :: HsExpr GhcPs -> SDoc -> RnM (HsExpr GhcRn, FreeVars) patSynErr e explanation = do { addErr (sep [text "Pattern syntax in expression context:", nest 4 (ppr e)] $$ explanation) diff --git a/compiler/rename/RnExpr.hs-boot b/compiler/rename/RnExpr.hs-boot index 5419870d38..a944d7124e 100644 --- a/compiler/rename/RnExpr.hs-boot +++ b/compiler/rename/RnExpr.hs-boot @@ -1,18 +1,18 @@ module RnExpr where +import Name import HsSyn -import Name ( Name ) -import NameSet ( FreeVars ) -import RdrName ( RdrName ) +import NameSet ( FreeVars ) import TcRnTypes -import SrcLoc ( Located ) -import Outputable ( Outputable ) +import SrcLoc ( Located ) +import Outputable ( Outputable ) +import HsExtension ( GhcPs, GhcRn ) -rnLExpr :: LHsExpr RdrName - -> RnM (LHsExpr Name, FreeVars) +rnLExpr :: LHsExpr GhcPs + -> RnM (LHsExpr GhcRn, FreeVars) rnStmts :: --forall thing body. - Outputable (body RdrName) => HsStmtContext Name - -> (Located (body RdrName) -> RnM (Located (body Name), FreeVars)) - -> [LStmt RdrName (Located (body RdrName))] + Outputable (body GhcPs) => HsStmtContext Name + -> (Located (body GhcPs) -> RnM (Located (body GhcRn), FreeVars)) + -> [LStmt GhcPs (Located (body GhcPs))] -> ([Name] -> RnM (thing, FreeVars)) - -> RnM (([LStmt Name (Located (body Name))], thing), FreeVars) + -> RnM (([LStmt GhcRn (Located (body GhcRn))], thing), FreeVars) diff --git a/compiler/rename/RnFixity.hs b/compiler/rename/RnFixity.hs index 61566f0ba5..0bd08574a0 100644 --- a/compiler/rename/RnFixity.hs +++ b/compiler/rename/RnFixity.hs @@ -176,7 +176,7 @@ lookupTyFixityRn (L _ n) = lookupFixityRn n -- the field label, which might be different to the 'OccName' of the selector -- 'Name' if @DuplicateRecordFields@ is in use (Trac #1173). If there are -- multiple possible selectors with different fixities, generate an error. -lookupFieldFixityRn :: AmbiguousFieldOcc Name -> RnM Fixity +lookupFieldFixityRn :: AmbiguousFieldOcc GhcRn -> RnM Fixity lookupFieldFixityRn (Unambiguous (L _ rdr) n) = lookupFixityRn' n (rdrNameOcc rdr) lookupFieldFixityRn (Ambiguous (L _ rdr) _) = get_ambiguous_fixity rdr diff --git a/compiler/rename/RnNames.hs b/compiler/rename/RnNames.hs index fa5f24fb46..3c1473402c 100644 --- a/compiler/rename/RnNames.hs +++ b/compiler/rename/RnNames.hs @@ -5,6 +5,10 @@ -} {-# LANGUAGE CPP, NondecreasingIndentation, MultiWayIf, NamedFieldPuns #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} module RnNames ( rnImports, getLocalNonValBinders, newRecordSelector, @@ -15,7 +19,8 @@ module RnNames ( checkConName, mkChildEnv, findChildren, - dodgyMsg + dodgyMsg, + dodgyMsgInsert ) where #include "HsVersions.h" @@ -154,8 +159,8 @@ with yes we have gone with no for now. -- the return types represent. -- Note: Do the non SOURCE ones first, so that we get a helpful warning -- for SOURCE ones that are unnecessary -rnImports :: [LImportDecl RdrName] - -> RnM ([LImportDecl Name], GlobalRdrEnv, ImportAvails, AnyHpcUsage) +rnImports :: [LImportDecl GhcPs] + -> RnM ([LImportDecl GhcRn], GlobalRdrEnv, ImportAvails, AnyHpcUsage) rnImports imports = do tcg_env <- getGblEnv -- NB: want an identity module here, because it's OK for a signature @@ -170,8 +175,8 @@ rnImports imports = do return (decls, rdr_env, imp_avails, hpc_usage) where - combine :: [(LImportDecl Name, GlobalRdrEnv, ImportAvails, AnyHpcUsage)] - -> ([LImportDecl Name], GlobalRdrEnv, ImportAvails, AnyHpcUsage) + combine :: [(LImportDecl GhcRn, GlobalRdrEnv, ImportAvails, AnyHpcUsage)] + -> ([LImportDecl GhcRn], GlobalRdrEnv, ImportAvails, AnyHpcUsage) combine = foldr plus ([], emptyGlobalRdrEnv, emptyImportAvails, False) plus (decl, gbl_env1, imp_avails1,hpc_usage1) @@ -196,8 +201,8 @@ rnImports imports = do -- -- 4. A boolean 'AnyHpcUsage' which is true if the imported module -- used HPC. -rnImportDecl :: Module -> LImportDecl RdrName - -> RnM (LImportDecl Name, GlobalRdrEnv, ImportAvails, AnyHpcUsage) +rnImportDecl :: Module -> LImportDecl GhcPs + -> RnM (LImportDecl GhcRn, GlobalRdrEnv, ImportAvails, AnyHpcUsage) rnImportDecl this_mod (L loc decl@(ImportDecl { ideclName = loc_imp_mod_name, ideclPkgQual = mb_pkg , ideclSource = want_boot, ideclSafe = mod_safe @@ -543,7 +548,7 @@ extendGlobalRdrEnvRn avails new_fixities * * ********************************************************************* -} -getLocalNonValBinders :: MiniFixityEnv -> HsGroup RdrName +getLocalNonValBinders :: MiniFixityEnv -> HsGroup GhcPs -> RnM ((TcGblEnv, TcLclEnv), NameSet) -- Get all the top-level binders bound the group *except* -- for value bindings, which are treated separately @@ -614,7 +619,7 @@ getLocalNonValBinders fixity_env new_simple rdr_name = do{ nm <- newTopSrcBinder rdr_name ; return (avail nm) } - new_tc :: Bool -> LTyClDecl RdrName + new_tc :: Bool -> LTyClDecl GhcPs -> RnM (AvailInfo, [(Name, [FieldLabel])]) new_tc overload_ok tc_decl -- NOT for type/data instances = do { let (bndrs, flds) = hsLTyClDeclBinders tc_decl @@ -629,7 +634,8 @@ getLocalNonValBinders fixity_env -- Calculate the mapping from constructor names to fields, which -- will go in tcg_field_env. It's convenient to do this here where -- we are working with a single datatype definition. - mk_fld_env :: HsDataDefn RdrName -> [Name] -> [FieldLabel] -> [(Name, [FieldLabel])] + mk_fld_env :: HsDataDefn GhcPs -> [Name] -> [FieldLabel] + -> [(Name, [FieldLabel])] mk_fld_env d names flds = concatMap find_con_flds (dd_cons d) where find_con_flds (L _ (ConDeclH98 { con_name = L _ rdr @@ -662,7 +668,7 @@ getLocalNonValBinders fixity_env find (\ fl -> flLabel fl == lbl) flds where lbl = occNameFS (rdrNameOcc rdr) - new_assoc :: Bool -> LInstDecl RdrName + new_assoc :: Bool -> LInstDecl GhcPs -> RnM ([AvailInfo], [(Name, [FieldLabel])]) new_assoc _ (L _ (TyFamInstD {})) = return ([], []) -- type instances don't bind new names @@ -681,7 +687,7 @@ getLocalNonValBinders fixity_env = return ([], []) -- Do not crash on ill-formed instances -- Eg instance !Show Int Trac #3811c - new_di :: Bool -> Maybe Name -> DataFamInstDecl RdrName + new_di :: Bool -> Maybe Name -> DataFamInstDecl GhcPs -> RnM (AvailInfo, [(Name, [FieldLabel])]) new_di overload_ok mb_cls ti_decl = do { main_name <- lookupFamInstName mb_cls (dfid_tycon ti_decl) @@ -693,11 +699,11 @@ getLocalNonValBinders fixity_env fld_env = mk_fld_env (dfid_defn ti_decl) sub_names flds' ; return (avail, fld_env) } - new_loc_di :: Bool -> Maybe Name -> LDataFamInstDecl RdrName + new_loc_di :: Bool -> Maybe Name -> LDataFamInstDecl GhcPs -> RnM (AvailInfo, [(Name, [FieldLabel])]) new_loc_di overload_ok mb_cls (L _ d) = new_di overload_ok mb_cls d -newRecordSelector :: Bool -> [Name] -> LFieldOcc RdrName -> RnM FieldLabel +newRecordSelector :: Bool -> [Name] -> LFieldOcc GhcPs -> RnM FieldLabel newRecordSelector _ [] _ = error "newRecordSelector: datatype has no constructors!" newRecordSelector overload_ok (dc:_) (L loc (FieldOcc (L _ fld) _)) = do { selName <- newTopSrcBinder $ L loc $ field @@ -780,8 +786,8 @@ although we never look up data constructors. filterImports :: ModIface -> ImpDeclSpec -- The span for the entire import decl - -> Maybe (Bool, Located [LIE RdrName]) -- Import spec; True => hiding - -> RnM (Maybe (Bool, Located [LIE Name]), -- Import spec w/ Names + -> Maybe (Bool, Located [LIE GhcPs]) -- Import spec; True => hiding + -> RnM (Maybe (Bool, Located [LIE GhcRn]), -- Import spec w/ Names [GlobalRdrElt]) -- Same again, but in GRE form filterImports iface decl_spec Nothing = return (Nothing, gresFromAvails (Just imp_spec) (mi_exports iface)) @@ -793,7 +799,7 @@ filterImports iface decl_spec (Just (want_hiding, L l import_items)) = do -- check for errors, convert RdrNames to Names items1 <- mapM lookup_lie import_items - let items2 :: [(LIE Name, AvailInfo)] + let items2 :: [(LIE GhcRn, AvailInfo)] items2 = concat items1 -- NB the AvailInfo may have duplicates, and several items -- for the same parent; e.g N(x) and N(y) @@ -811,7 +817,7 @@ filterImports iface decl_spec (Just (want_hiding, L l import_items)) all_avails = mi_exports iface -- See Note [Dealing with imports] - imp_occ_env :: OccEnv (Name, -- the name + imp_occ_env :: OccEnv (Name, -- the name AvailInfo, -- the export item providing the name Maybe Name) -- the parent of associated types imp_occ_env = mkOccEnv_C combine [ (nameOccName n, (n, a, Nothing)) @@ -837,7 +843,7 @@ filterImports iface decl_spec (Just (want_hiding, L l import_items)) where mb_success = lookupOccEnv imp_occ_env (rdrNameOcc rdr) - lookup_lie :: LIE RdrName -> TcRn [(LIE Name, AvailInfo)] + lookup_lie :: LIE GhcPs -> TcRn [(LIE GhcRn, AvailInfo)] lookup_lie (L loc ieRdr) = do (stuff, warns) <- setSrcSpan loc $ liftM (fromMaybe ([],[])) $ @@ -873,7 +879,8 @@ filterImports iface decl_spec (Just (want_hiding, L l 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 Note [Dealing with imports] - lookup_ie :: IE RdrName -> IELookupM ([(IE Name, AvailInfo)], [IELookupWarning]) + lookup_ie :: IE GhcPs + -> IELookupM ([(IE GhcRn, AvailInfo)], [IELookupWarning]) lookup_ie ie = handle_bad_import $ do case ie of IEVar (L l n) -> do @@ -1007,7 +1014,7 @@ catIELookupM ms = [ a | Succeeded a <- ms ] -} -- | Given an import\/export spec, construct the appropriate 'GlobalRdrElt's. -gresFromIE :: ImpDeclSpec -> (LIE Name, AvailInfo) -> [GlobalRdrElt] +gresFromIE :: ImpDeclSpec -> (LIE GhcRn, AvailInfo) -> [GlobalRdrElt] gresFromIE decl_spec (L loc ie, avail) = gresFromAvail prov_fn avail where @@ -1081,7 +1088,7 @@ lookupChildren all_kids rdr_items ********************************************************* -} -reportUnusedNames :: Maybe (Located [LIE RdrName]) -- Export list +reportUnusedNames :: Maybe (Located [LIE GhcPs]) -- Export list -> TcGblEnv -> RnM () reportUnusedNames _export_decls gbl_env = do { traceRn "RUN" (ppr (tcg_dus gbl_env)) @@ -1137,9 +1144,9 @@ specification and implementation notes are here: -} type ImportDeclUsage - = ( LImportDecl Name -- The import declaration + = ( LImportDecl GhcRn -- The import declaration , [AvailInfo] -- What *is* used (normalised) - , [Name] ) -- What is imported but *not* used + , [Name] ) -- What is imported but *not* used warnUnusedImportDecls :: TcGblEnv -> RnM () warnUnusedImportDecls gbl_env @@ -1200,6 +1207,7 @@ warnMissingSignatures gbl_env name = patSynName p pp_ty = pprPatSynType p + add_bind_warn :: Id -> IOEnv (Env TcGblEnv TcLclEnv) () add_bind_warn id = do { env <- tcInitTidyEnv -- Why not use emptyTidyEnv? ; let name = idName id @@ -1242,7 +1250,7 @@ not normalised). type ImportMap = Map SrcLoc [AvailInfo] -- See [The ImportMap] -findImportUsage :: [LImportDecl Name] +findImportUsage :: [LImportDecl GhcRn] -> [GlobalRdrElt] -> [ImportDeclUsage] @@ -1267,7 +1275,7 @@ findImportUsage imports used_gres foldr (add_unused . unLoc) emptyNameSet imp_ies _other -> emptyNameSet -- No explicit import list => no unused-name list - add_unused :: IE Name -> NameSet -> NameSet + add_unused :: IE GhcRn -> NameSet -> NameSet add_unused (IEVar (L _ n)) acc = add_unused_name (ieWrappedName n) acc add_unused (IEThingAbs (L _ n)) acc @@ -1410,7 +1418,7 @@ printMinimalImports imports_w_usage where doc = text "Compute minimal imports for" <+> ppr decl - to_ie :: ModIface -> AvailInfo -> [IE Name] + to_ie :: ModIface -> AvailInfo -> [IE GhcRn] -- The main trick here is that if we're importing all the constructors -- we want to say "T(..)", but if we're importing only a subset we want -- to say "T(A,B,C)". So we have to find out what the module exports. @@ -1509,7 +1517,7 @@ qualImportItemErr rdr = hang (text "Illegal qualified name in import item:") 2 (ppr rdr) -badImportItemErrStd :: ModIface -> ImpDeclSpec -> IE RdrName -> SDoc +badImportItemErrStd :: ModIface -> ImpDeclSpec -> IE GhcPs -> SDoc badImportItemErrStd iface decl_spec ie = sep [text "Module", quotes (ppr (is_mod decl_spec)), source_import, text "does not export", quotes (ppr ie)] @@ -1517,7 +1525,8 @@ badImportItemErrStd iface decl_spec ie source_import | mi_boot iface = text "(hi-boot interface)" | otherwise = Outputable.empty -badImportItemErrDataCon :: OccName -> ModIface -> ImpDeclSpec -> IE RdrName -> SDoc +badImportItemErrDataCon :: OccName -> ModIface -> ImpDeclSpec -> IE GhcPs + -> SDoc badImportItemErrDataCon dataType_occ iface decl_spec ie = vcat [ text "In module" <+> quotes (ppr (is_mod decl_spec)) @@ -1542,7 +1551,7 @@ badImportItemErrDataCon dataType_occ iface decl_spec ie | otherwise = Outputable.empty parens_sp d = parens (space <> d <> space) -- T( f,g ) -badImportItemErr :: ModIface -> ImpDeclSpec -> IE RdrName -> [AvailInfo] -> SDoc +badImportItemErr :: ModIface -> ImpDeclSpec -> IE GhcPs -> [AvailInfo] -> SDoc badImportItemErr iface decl_spec ie avails = case find checkIfDataCon avails of Just con -> badImportItemErrDataCon (availOccName con) iface decl_spec ie @@ -1561,16 +1570,24 @@ illegalImportItemErr :: SDoc illegalImportItemErr = text "Illegal import item" dodgyImportWarn :: RdrName -> SDoc -dodgyImportWarn item = dodgyMsg (text "import") item +dodgyImportWarn item + = dodgyMsg (text "import") item (dodgyMsgInsert item :: IE GhcPs) -dodgyMsg :: (OutputableBndr n, HasOccName n) => SDoc -> n -> SDoc -dodgyMsg kind tc +dodgyMsg :: (Outputable a, Outputable b) => SDoc -> a -> b -> SDoc +dodgyMsg kind tc ie = sep [ text "The" <+> kind <+> ptext (sLit "item") - <+> quotes (ppr (IEThingAll (noLoc (IEName $ noLoc tc)))) + -- <+> quotes (ppr (IEThingAll (noLoc (IEName $ noLoc tc)))) + <+> quotes (ppr ie) <+> text "suggests that", quotes (ppr tc) <+> text "has (in-scope) constructors or class methods,", text "but it has none" ] +dodgyMsgInsert :: forall p . IdP p -> IE p +dodgyMsgInsert tc = IEThingAll ii + where + ii :: LIEWrappedName (IdP p) + ii = noLoc (IEName $ noLoc tc) + addDupDeclErr :: [GlobalRdrElt] -> TcRn () addDupDeclErr [] = panic "addDupDeclErr: empty list" @@ -1594,7 +1611,7 @@ missingImportListWarn :: ModuleName -> SDoc missingImportListWarn mod = text "The module" <+> quotes (ppr mod) <+> ptext (sLit "does not have an explicit import list") -missingImportListItem :: IE RdrName -> SDoc +missingImportListItem :: IE GhcPs -> SDoc missingImportListItem ie = text "The import item" <+> quotes (ppr ie) <+> ptext (sLit "does not have an explicit import list") diff --git a/compiler/rename/RnPat.hs b/compiler/rename/RnPat.hs index 30dd61bece..ff88dbffbc 100644 --- a/compiler/rename/RnPat.hs +++ b/compiler/rename/RnPat.hs @@ -210,7 +210,7 @@ matchNameMaker ctxt = LamMk report_unused ThPatQuote -> False _ -> True -rnHsSigCps :: LHsSigWcType RdrName -> CpsRn (LHsSigWcType Name) +rnHsSigCps :: LHsSigWcType GhcPs -> CpsRn (LHsSigWcType GhcRn) rnHsSigCps sig = CpsRn (rnHsSigWcTypeScoped PatCtx sig) newPatLName :: NameMaker -> Located RdrName -> CpsRn (Located Name) @@ -302,8 +302,8 @@ There are various entry points to renaming patterns, depending on -- * unused and duplicate checking -- * no fixities rnPats :: HsMatchContext Name -- for error messages - -> [LPat RdrName] - -> ([LPat Name] -> RnM (a, FreeVars)) + -> [LPat GhcPs] + -> ([LPat GhcRn] -> RnM (a, FreeVars)) -> RnM (a, FreeVars) rnPats ctxt pats thing_inside = do { envs_before <- getRdrEnvs @@ -329,8 +329,8 @@ rnPats ctxt pats thing_inside doc_pat = text "In" <+> pprMatchContext ctxt rnPat :: HsMatchContext Name -- for error messages - -> LPat RdrName - -> (LPat Name -> RnM (a, FreeVars)) + -> LPat GhcPs + -> (LPat GhcRn -> RnM (a, FreeVars)) -> RnM (a, FreeVars) -- Variables bound by pattern do not -- appear in the result FreeVars rnPat ctxt pat thing_inside @@ -348,8 +348,8 @@ applyNameMaker mk rdr = do { (n, _fvs) <- runCps (newPatLName mk rdr) -- * no unused and duplicate checking -- * fixities might be coming in rnBindPat :: NameMaker - -> LPat RdrName - -> RnM (LPat Name, FreeVars) + -> LPat GhcPs + -> RnM (LPat GhcRn, FreeVars) -- Returned FreeVars are the free variables of the pattern, -- of course excluding variables bound by this pattern @@ -366,17 +366,17 @@ rnBindPat name_maker pat = runCps (rnLPatAndThen name_maker pat) -- ----------- Entry point 3: rnLPatAndThen ------------------- -- General version: parametrized by how you make new names -rnLPatsAndThen :: NameMaker -> [LPat RdrName] -> CpsRn [LPat Name] +rnLPatsAndThen :: NameMaker -> [LPat GhcPs] -> CpsRn [LPat GhcRn] rnLPatsAndThen mk = mapM (rnLPatAndThen mk) -- Despite the map, the monad ensures that each pattern binds -- variables that may be mentioned in subsequent patterns in the list -------------------- -- The workhorse -rnLPatAndThen :: NameMaker -> LPat RdrName -> CpsRn (LPat Name) +rnLPatAndThen :: NameMaker -> LPat GhcPs -> CpsRn (LPat GhcRn) rnLPatAndThen nm lpat = wrapSrcSpanCps (rnPatAndThen nm) lpat -rnPatAndThen :: NameMaker -> Pat RdrName -> CpsRn (Pat Name) +rnPatAndThen :: NameMaker -> Pat GhcPs -> CpsRn (Pat GhcRn) rnPatAndThen _ (WildPat _) = return (WildPat placeHolderType) rnPatAndThen mk (ParPat pat) = do { pat' <- rnLPatAndThen mk pat; return (ParPat pat') } rnPatAndThen mk (LazyPat pat) = do { pat' <- rnLPatAndThen mk pat; return (LazyPat pat') } @@ -411,7 +411,7 @@ rnPatAndThen mk (LitPat lit) else normal_lit } | otherwise = normal_lit where - normal_lit = do { liftCps (rnLit lit); return (LitPat lit) } + normal_lit = do { liftCps (rnLit lit); return (LitPat (convertLit lit)) } rnPatAndThen _ (NPat (L l lit) mb_neg _eq _) = do { (lit', mb_neg') <- liftCpsFV $ rnOverLit lit @@ -502,9 +502,9 @@ rnPatAndThen _ pat = pprPanic "rnLPatAndThen" (ppr pat) -------------------- rnConPatAndThen :: NameMaker - -> Located RdrName -- the constructor - -> HsConPatDetails RdrName - -> CpsRn (Pat Name) + -> Located RdrName -- the constructor + -> HsConPatDetails GhcPs + -> CpsRn (Pat GhcRn) rnConPatAndThen mk con (PrefixCon pats) = do { con' <- lookupConCps con @@ -526,8 +526,8 @@ rnConPatAndThen mk con (RecCon rpats) -------------------- rnHsRecPatsAndThen :: NameMaker -> Located Name -- Constructor - -> HsRecFields RdrName (LPat RdrName) - -> CpsRn (HsRecFields Name (LPat Name)) + -> HsRecFields GhcPs (LPat GhcPs) + -> CpsRn (HsRecFields GhcRn (LPat GhcRn)) rnHsRecPatsAndThen mk (L _ con) hs_rec_fields@(HsRecFields { rec_dotdot = dd }) = do { flds <- liftCpsFV $ rnHsRecFields (HsRecFieldPat con) mkVarPat hs_rec_fields @@ -562,8 +562,8 @@ rnHsRecFields HsRecFieldContext -> (SrcSpan -> RdrName -> arg) -- When punning, use this to build a new field - -> HsRecFields RdrName (Located arg) - -> RnM ([LHsRecField Name (Located arg)], FreeVars) + -> HsRecFields GhcPs (Located arg) + -> RnM ([LHsRecField GhcRn (Located arg)], FreeVars) -- This surprisingly complicated pass -- a) looks up the field name (possibly using disambiguation) @@ -597,8 +597,8 @@ rnHsRecFields ctxt mk_arg (HsRecFields { rec_flds = flds, rec_dotdot = dotdot }) Nothing -> text "constructor field name" Just con -> text "field of constructor" <+> quotes (ppr con) - rn_fld :: Bool -> Maybe Name -> LHsRecField RdrName (Located arg) - -> RnM (LHsRecField Name (Located arg)) + rn_fld :: Bool -> Maybe Name -> LHsRecField GhcPs (Located arg) + -> RnM (LHsRecField GhcRn (Located arg)) rn_fld pun_ok parent (L l (HsRecField { hsRecFieldLbl = L loc (FieldOcc (L ll lbl) _) , hsRecFieldArg = arg @@ -616,10 +616,10 @@ rnHsRecFields ctxt mk_arg (HsRecFields { rec_flds = flds, rec_dotdot = dotdot }) , hsRecPun = pun })) } rn_dotdot :: Maybe Int -- See Note [DotDot fields] in HsPat - -> Maybe Name -- The constructor (Nothing for an + -> Maybe Name -- The constructor (Nothing for an -- out of scope constructor) - -> [LHsRecField Name (Located arg)] -- Explicit fields - -> RnM [LHsRecField Name (Located arg)] -- Filled in .. fields + -> [LHsRecField GhcRn (Located arg)] -- Explicit fields + -> RnM [LHsRecField GhcRn (Located arg)] -- Filled in .. fields rn_dotdot Nothing _mb_con _flds -- No ".." at all = return [] rn_dotdot (Just {}) Nothing _flds -- Constructor out of scope @@ -668,7 +668,8 @@ rnHsRecFields ctxt mk_arg (HsRecFields { rec_flds = flds, rec_dotdot = dotdot }) = do { env <- getGlobalRdrEnv; return (find_tycon env con) } | otherwise = return Nothing - find_tycon :: GlobalRdrEnv -> Name {- DataCon -} -> Maybe Name {- TyCon -} + find_tycon :: GlobalRdrEnv -> Name {- DataCon -} + -> Maybe Name {- TyCon -} -- Return the parent *type constructor* of the data constructor -- (that is, the parent of the data constructor), -- or 'Nothing' if it is a pattern synonym or not in scope. @@ -713,8 +714,8 @@ fail. But there is no need for disambiguation anyway, so we just return Nothing -} rnHsRecUpdFields - :: [LHsRecUpdField RdrName] - -> RnM ([LHsRecUpdField Name], FreeVars) + :: [LHsRecUpdField GhcPs] + -> RnM ([LHsRecUpdField GhcRn], FreeVars) rnHsRecUpdFields flds = do { pun_ok <- xoptM LangExt.RecordPuns ; overload_ok <- xoptM LangExt.DuplicateRecordFields @@ -729,7 +730,8 @@ rnHsRecUpdFields flds where doc = text "constructor field name" - rn_fld :: Bool -> Bool -> LHsRecUpdField RdrName -> RnM (LHsRecUpdField Name, FreeVars) + rn_fld :: Bool -> Bool -> LHsRecUpdField GhcPs + -> RnM (LHsRecUpdField GhcRn, FreeVars) rn_fld pun_ok overload_ok (L l (HsRecField { hsRecFieldLbl = L loc f , hsRecFieldArg = arg , hsRecPun = pun })) @@ -775,7 +777,7 @@ rnHsRecUpdFields flds -getFieldIds :: [LHsRecField Name arg] -> [Name] +getFieldIds :: [LHsRecField GhcRn arg] -> [Name] getFieldIds flds = map (unLoc . hsRecFieldSel . unLoc) flds getFieldLbls :: [LHsRecField id arg] -> [RdrName] @@ -824,7 +826,7 @@ that the types and classes they involve are made available. -} -rnLit :: HsLit -> RnM () +rnLit :: HsLit p -> RnM () rnLit (HsChar _ c) = checkErr (inCharRange c) (bogusCharError c) rnLit _ = return () @@ -855,7 +857,7 @@ can apply it explicitly. In this case it stays negative zero. Trac #13211 -} rnOverLit :: HsOverLit t -> - RnM ((HsOverLit Name, Maybe (HsExpr Name)), FreeVars) + RnM ((HsOverLit GhcRn, Maybe (HsExpr GhcRn)), FreeVars) rnOverLit origLit = do { opt_NumDecimals <- xoptM LangExt.NumDecimals ; let { lit@(OverLit {ol_val=val}) @@ -895,6 +897,6 @@ bogusCharError :: Char -> SDoc bogusCharError c = text "character literal out of range: '\\" <> char c <> char '\'' -badViewPat :: Pat RdrName -> SDoc +badViewPat :: Pat GhcPs -> SDoc badViewPat pat = vcat [text "Illegal view pattern: " <+> ppr pat, text "Use ViewPatterns to enable view patterns"] diff --git a/compiler/rename/RnSource.hs b/compiler/rename/RnSource.hs index 572ed82814..ff7251e5d5 100644 --- a/compiler/rename/RnSource.hs +++ b/compiler/rename/RnSource.hs @@ -5,6 +5,8 @@ -} {-# LANGUAGE CPP, ScopedTypeVariables #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeFamilies #-} module RnSource ( rnSrcDecls, addTcgDUs, findSplice @@ -81,7 +83,7 @@ It also does the following error checks: Brings the binders of the group into scope in the appropriate places; does NOT assume that anything is in scope already -} -rnSrcDecls :: HsGroup RdrName -> RnM (TcGblEnv, HsGroup Name) +rnSrcDecls :: HsGroup GhcPs -> RnM (TcGblEnv, HsGroup GhcRn) -- Rename a top-level HsGroup; used for normal source files *and* hs-boot files rnSrcDecls group@(HsGroup { hs_valds = val_decls, hs_splcds = splice_decls, @@ -266,7 +268,7 @@ rnDocDecl (DocGroup lev doc) = do ********************************************************* -} -rnSrcFixityDecls :: NameSet -> [LFixitySig RdrName] -> RnM [LFixitySig Name] +rnSrcFixityDecls :: NameSet -> [LFixitySig GhcPs] -> RnM [LFixitySig GhcRn] -- Rename the fixity decls, so we can put -- the renamed decls in the renamed syntax tree -- Errors if the thing being fixed is not defined locally. @@ -279,7 +281,7 @@ rnSrcFixityDecls bndr_set fix_decls where sig_ctxt = TopSigCtxt bndr_set - rn_decl :: LFixitySig RdrName -> RnM [LFixitySig Name] + rn_decl :: LFixitySig GhcPs -> RnM [LFixitySig GhcRn] -- GHC extension: look up both the tycon and data con -- for con-like things; hence returning a list -- If neither are in scope, report an error; otherwise @@ -312,7 +314,7 @@ gather them together. -} -- checks that the deprecations are defined locally, and that there are no duplicates -rnSrcWarnDecls :: NameSet -> [LWarnDecls RdrName] -> RnM Warnings +rnSrcWarnDecls :: NameSet -> [LWarnDecls GhcPs] -> RnM Warnings rnSrcWarnDecls _ [] = return NoWarnings @@ -360,7 +362,7 @@ dupWarnDecl (L loc _) rdr_name ********************************************************* -} -rnAnnDecl :: AnnDecl RdrName -> RnM (AnnDecl Name, FreeVars) +rnAnnDecl :: AnnDecl GhcPs -> RnM (AnnDecl GhcRn, FreeVars) rnAnnDecl ann@(HsAnnotation s provenance expr) = addErrCtxt (annCtxt ann) $ do { (provenance', provenance_fvs) <- rnAnnProvenance provenance @@ -369,7 +371,8 @@ rnAnnDecl ann@(HsAnnotation s provenance expr) ; return (HsAnnotation s provenance' expr', provenance_fvs `plusFV` expr_fvs) } -rnAnnProvenance :: AnnProvenance RdrName -> RnM (AnnProvenance Name, FreeVars) +rnAnnProvenance :: AnnProvenance RdrName + -> RnM (AnnProvenance Name, FreeVars) rnAnnProvenance provenance = do provenance' <- traverse lookupTopBndrRn provenance return (provenance', maybe emptyFVs unitFV (annProvenanceName_maybe provenance')) @@ -382,7 +385,7 @@ rnAnnProvenance provenance = do ********************************************************* -} -rnDefaultDecl :: DefaultDecl RdrName -> RnM (DefaultDecl Name, FreeVars) +rnDefaultDecl :: DefaultDecl GhcPs -> RnM (DefaultDecl GhcRn, FreeVars) rnDefaultDecl (DefaultDecl tys) = do { (tys', fvs) <- rnLHsTypes doc_str tys ; return (DefaultDecl tys', fvs) } @@ -397,7 +400,7 @@ rnDefaultDecl (DefaultDecl tys) ********************************************************* -} -rnHsForeignDecl :: ForeignDecl RdrName -> RnM (ForeignDecl Name, FreeVars) +rnHsForeignDecl :: ForeignDecl GhcPs -> RnM (ForeignDecl GhcRn, FreeVars) rnHsForeignDecl (ForeignImport { fd_name = name, fd_sig_ty = ty, fd_fi = spec }) = do { topEnv :: HscEnv <- getTopEnv ; name' <- lookupLocatedTopBndrRn name @@ -452,7 +455,7 @@ patchCCallTarget unitId callTarget = ********************************************************* -} -rnSrcInstDecl :: InstDecl RdrName -> RnM (InstDecl Name, FreeVars) +rnSrcInstDecl :: InstDecl GhcPs -> RnM (InstDecl GhcRn, FreeVars) rnSrcInstDecl (TyFamInstD { tfid_inst = tfi }) = do { (tfi', fvs) <- rnTyFamInstDecl Nothing tfi ; return (TyFamInstD { tfid_inst = tfi' }, fvs) } @@ -477,7 +480,7 @@ rnSrcInstDecl (ClsInstD { cid_inst = cid }) -- -- See also descriptions of 'checkCanonicalMonadInstances' and -- 'checkCanonicalMonoidInstances' -checkCanonicalInstances :: Name -> LHsSigType Name -> LHsBinds Name -> RnM () +checkCanonicalInstances :: Name -> LHsSigType GhcRn -> LHsBinds GhcRn -> RnM () checkCanonicalInstances cls poly_ty mbinds = do whenWOptM Opt_WarnNonCanonicalMonadInstances checkCanonicalMonadInstances @@ -608,7 +611,7 @@ checkCanonicalInstances cls poly_ty mbinds = do -- | test whether MatchGroup represents a trivial \"lhsName = rhsName\" -- binding, and return @Just rhsName@ if this is the case - isAliasMG :: MatchGroup Name (LHsExpr Name) -> Maybe Name + isAliasMG :: MatchGroup GhcRn (LHsExpr GhcRn) -> Maybe Name isAliasMG MG {mg_alts = L _ [L _ (Match { m_pats = [], m_grhss = grhss })]} | GRHSs [L _ (GRHS [] body)] lbinds <- grhss , L _ EmptyLocalBinds <- lbinds @@ -651,7 +654,7 @@ checkCanonicalInstances cls poly_ty mbinds = do ] -- stolen from TcInstDcls - instDeclCtxt1 :: LHsSigType Name -> SDoc + instDeclCtxt1 :: LHsSigType GhcRn -> SDoc instDeclCtxt1 hs_inst_ty = inst_decl_ctxt (ppr (getLHsInstDeclHead hs_inst_ty)) @@ -660,7 +663,7 @@ checkCanonicalInstances cls poly_ty mbinds = do 2 (quotes doc <> text ".") -rnClsInstDecl :: ClsInstDecl RdrName -> RnM (ClsInstDecl Name, FreeVars) +rnClsInstDecl :: ClsInstDecl GhcPs -> RnM (ClsInstDecl GhcRn, FreeVars) rnClsInstDecl (ClsInstDecl { cid_poly_ty = inst_ty, cid_binds = mbinds , cid_sigs = uprags, cid_tyfam_insts = ats , cid_overlap_mode = oflag @@ -710,15 +713,15 @@ rnClsInstDecl (ClsInstDecl { cid_poly_ty = inst_ty, cid_binds = mbinds -- to remove the context). rnFamInstDecl :: HsDocContext - -> Maybe (Name, [Name]) -- Nothing => not associated + -> Maybe (Name, [Name]) -- Nothing => not associated -- Just (cls,tvs) => associated, -- and gives class and tyvars of the -- parent instance delc -> Located RdrName - -> HsTyPats RdrName + -> HsTyPats GhcPs -> rhs -> (HsDocContext -> rhs -> RnM (rhs', FreeVars)) - -> RnM (Located Name, HsTyPats Name, rhs', FreeVars) + -> RnM (Located Name, HsTyPats GhcRn, rhs', FreeVars) rnFamInstDecl doc mb_cls tycon (HsIB { hsib_body = pats }) payload rnPayload = do { tycon' <- lookupFamInstName (fmap fst mb_cls) tycon ; let loc = case pats of @@ -789,16 +792,16 @@ rnFamInstDecl doc mb_cls tycon (HsIB { hsib_body = pats }) payload rnPayload -- type instance => use, hence addOneFV rnTyFamInstDecl :: Maybe (Name, [Name]) - -> TyFamInstDecl RdrName - -> RnM (TyFamInstDecl Name, FreeVars) + -> TyFamInstDecl GhcPs + -> RnM (TyFamInstDecl GhcRn, FreeVars) 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]) - -> TyFamInstEqn RdrName - -> RnM (TyFamInstEqn Name, FreeVars) + -> TyFamInstEqn GhcPs + -> RnM (TyFamInstEqn GhcRn, FreeVars) rnTyFamInstEqn mb_cls (TyFamEqn { tfe_tycon = tycon , tfe_pats = pats , tfe_fixity = fixity @@ -811,8 +814,8 @@ rnTyFamInstEqn mb_cls (TyFamEqn { tfe_tycon = tycon , tfe_rhs = rhs' }, fvs) } rnTyFamDefltEqn :: Name - -> TyFamDefltEqn RdrName - -> RnM (TyFamDefltEqn Name, FreeVars) + -> TyFamDefltEqn GhcPs + -> RnM (TyFamDefltEqn GhcRn, FreeVars) rnTyFamDefltEqn cls (TyFamEqn { tfe_tycon = tycon , tfe_pats = tyvars , tfe_fixity = fixity @@ -828,8 +831,8 @@ rnTyFamDefltEqn cls (TyFamEqn { tfe_tycon = tycon ctx = TyFamilyCtx tycon rnDataFamInstDecl :: Maybe (Name, [Name]) - -> DataFamInstDecl RdrName - -> RnM (DataFamInstDecl Name, FreeVars) + -> DataFamInstDecl GhcPs + -> RnM (DataFamInstDecl GhcRn, FreeVars) rnDataFamInstDecl mb_cls (DataFamInstDecl { dfid_tycon = tycon , dfid_pats = pats , dfid_fixity = fixity @@ -846,18 +849,18 @@ rnDataFamInstDecl mb_cls (DataFamInstDecl { dfid_tycon = tycon -- Rename associated type family decl in class rnATDecls :: Name -- Class - -> [LFamilyDecl RdrName] - -> RnM ([LFamilyDecl Name], FreeVars) + -> [LFamilyDecl GhcPs] + -> RnM ([LFamilyDecl GhcRn], FreeVars) rnATDecls cls at_decls = rnList (rnFamDecl (Just cls)) at_decls -rnATInstDecls :: (Maybe (Name, [Name]) -> -- The function that renames - decl RdrName -> -- an instance. rnTyFamInstDecl - RnM (decl Name, FreeVars)) -- or rnDataFamInstDecl +rnATInstDecls :: (Maybe (Name, [Name]) -> -- The function that renames + decl GhcPs -> -- an instance. rnTyFamInstDecl + RnM (decl GhcRn, FreeVars)) -- or rnDataFamInstDecl -> Name -- Class -> [Name] - -> [Located (decl RdrName)] - -> RnM ([Located (decl Name)], FreeVars) + -> [Located (decl GhcPs)] + -> RnM ([Located (decl GhcRn)], FreeVars) -- Used for data and type family defaults in a class decl -- and the family instance declarations in an instance -- @@ -954,7 +957,7 @@ Here 'k' is in scope in the kind signature, just like 'x'. ********************************************************* -} -rnSrcDerivDecl :: DerivDecl RdrName -> RnM (DerivDecl Name, FreeVars) +rnSrcDerivDecl :: DerivDecl GhcPs -> RnM (DerivDecl GhcRn, FreeVars) rnSrcDerivDecl (DerivDecl ty deriv_strat overlap) = do { standalone_deriv_ok <- xoptM LangExt.StandaloneDeriving ; deriv_strats_ok <- xoptM LangExt.DerivingStrategies @@ -977,12 +980,12 @@ standaloneDerivErr ********************************************************* -} -rnHsRuleDecls :: RuleDecls RdrName -> RnM (RuleDecls Name, FreeVars) +rnHsRuleDecls :: RuleDecls GhcPs -> RnM (RuleDecls GhcRn, FreeVars) rnHsRuleDecls (HsRules src rules) = do { (rn_rules,fvs) <- rnList rnHsRuleDecl rules ; return (HsRules src rn_rules,fvs) } -rnHsRuleDecl :: RuleDecl RdrName -> RnM (RuleDecl Name, FreeVars) +rnHsRuleDecl :: RuleDecl GhcPs -> RnM (RuleDecl GhcRn, FreeVars) rnHsRuleDecl (HsRule rule_name act vars lhs _fv_lhs rhs _fv_rhs) = do { let rdr_names_w_loc = map get_var vars ; checkDupRdrNames rdr_names_w_loc @@ -998,8 +1001,8 @@ rnHsRuleDecl (HsRule rule_name act vars lhs _fv_lhs rhs _fv_rhs) get_var (L _ (RuleBndrSig v _)) = v get_var (L _ (RuleBndr v)) = v -bindHsRuleVars :: RuleName -> [LRuleBndr RdrName] -> [Name] - -> ([LRuleBndr Name] -> RnM (a, FreeVars)) +bindHsRuleVars :: RuleName -> [LRuleBndr GhcPs] -> [Name] + -> ([LRuleBndr GhcRn] -> RnM (a, FreeVars)) -> RnM (a, FreeVars) bindHsRuleVars rule_name vars names thing_inside = go vars names $ \ vars' -> @@ -1035,7 +1038,7 @@ lambdas. So it seems simmpler not to check at all, and that is why check_e is commented out. -} -checkValidRule :: FastString -> [Name] -> LHsExpr Name -> NameSet -> RnM () +checkValidRule :: FastString -> [Name] -> LHsExpr GhcRn -> NameSet -> RnM () checkValidRule rule_name ids lhs' fv_lhs' = do { -- Check for the form of the LHS case (validRuleLhs ids lhs') of @@ -1046,7 +1049,7 @@ checkValidRule rule_name ids lhs' fv_lhs' ; let bad_vars = [var | var <- ids, not (var `elemNameSet` fv_lhs')] ; mapM_ (addErr . badRuleVar rule_name) bad_vars } -validRuleLhs :: [Name] -> LHsExpr Name -> Maybe (HsExpr Name) +validRuleLhs :: [Name] -> LHsExpr GhcRn -> Maybe (HsExpr GhcRn) -- Nothing => OK -- Just e => Not ok, and e is the offending sub-expression validRuleLhs foralls lhs @@ -1084,7 +1087,7 @@ badRuleVar name var text "Forall'd variable" <+> quotes (ppr var) <+> text "does not appear on left hand side"] -badRuleLhsErr :: FastString -> LHsExpr Name -> HsExpr Name -> SDoc +badRuleLhsErr :: FastString -> LHsExpr GhcRn -> HsExpr GhcRn -> SDoc badRuleLhsErr name lhs bad_e = sep [text "Rule" <+> pprRuleName name <> colon, nest 4 (vcat [err, @@ -1104,7 +1107,7 @@ badRuleLhsErr name lhs bad_e ********************************************************* -} -rnHsVectDecl :: VectDecl RdrName -> RnM (VectDecl Name, FreeVars) +rnHsVectDecl :: VectDecl GhcPs -> RnM (VectDecl GhcRn, FreeVars) -- FIXME: For the moment, the right-hand side is restricted to be a variable as we cannot properly -- typecheck a complex right-hand side without invoking 'vectType' from the vectoriser. rnHsVectDecl (HsVect s var rhs@(L _ (HsVar _))) @@ -1286,8 +1289,8 @@ constructors] in TcEnv -} -rnTyClDecls :: [TyClGroup RdrName] - -> RnM ([TyClGroup Name], FreeVars) +rnTyClDecls :: [TyClGroup GhcPs] + -> RnM ([TyClGroup GhcRn], FreeVars) -- Rename the declarations and do dependency analysis on them rnTyClDecls tycl_ds = do { -- Rename the type/class, instance, and role declaraations @@ -1332,9 +1335,9 @@ rnTyClDecls tycl_ds ; return (all_groups, all_fvs) } where mk_group :: (InstDeclFreeVarsMap, RoleAnnotEnv) - -> SCC (LTyClDecl Name) + -> SCC (LTyClDecl GhcRn) -> ( (InstDeclFreeVarsMap, RoleAnnotEnv) - , TyClGroup Name ) + , TyClGroup GhcRn ) mk_group (inst_map, role_env) scc = ((inst_map', role_env'), group) where @@ -1348,13 +1351,13 @@ rnTyClDecls tycl_ds depAnalTyClDecls :: GlobalRdrEnv - -> [(LTyClDecl Name, FreeVars)] - -> [SCC (LTyClDecl Name)] + -> [(LTyClDecl GhcRn, FreeVars)] + -> [SCC (LTyClDecl GhcRn)] -- See Note [Dependency analysis of type, class, and instance decls] depAnalTyClDecls rdr_env ds_w_fvs = stronglyConnCompFromEdgedVerticesUniq edges where - edges :: [ Node Name (LTyClDecl Name) ] + edges :: [ Node Name (LTyClDecl GhcRn) ] edges = [ DigraphNode d (tcdName (unLoc d)) (map (getParent rdr_env) (nonDetEltsUniqSet fvs)) | (d, fvs) <- ds_w_fvs ] -- It's OK to use nonDetEltsUFM here as @@ -1469,21 +1472,24 @@ cannot infer a type to be polymorphically instantiated while we are inferring its kind), but no one has hollered about this (yet!) -} -addBootDeps :: [(LTyClDecl Name, FreeVars)] -> RnM [(LTyClDecl Name, FreeVars)] +addBootDeps :: [(LTyClDecl GhcRn, FreeVars)] + -> RnM [(LTyClDecl GhcRn, FreeVars)] -- See Note [Extra dependencies from .hs-boot files] addBootDeps ds_w_fvs = do { tcg_env <- getGblEnv ; let this_mod = tcg_mod tcg_env boot_info = tcg_self_boot tcg_env - add_boot_deps :: [(LTyClDecl Name, FreeVars)] -> [(LTyClDecl Name, FreeVars)] + add_boot_deps :: [(LTyClDecl GhcRn, FreeVars)] + -> [(LTyClDecl GhcRn, FreeVars)] add_boot_deps ds_w_fvs = case boot_info of SelfBoot { sb_tcs = tcs } | not (isEmptyNameSet tcs) -> map (add_one tcs) ds_w_fvs _ -> ds_w_fvs - add_one :: NameSet -> (LTyClDecl Name, FreeVars) -> (LTyClDecl Name, FreeVars) + add_one :: NameSet -> (LTyClDecl GhcRn, FreeVars) + -> (LTyClDecl GhcRn, FreeVars) add_one tcs pr@(decl,fvs) | has_local_imports fvs = (decl, fvs `plusFV` tcs) | otherwise = pr @@ -1505,8 +1511,8 @@ addBootDeps ds_w_fvs -- It is quite convenient to do both of these in the same place. -- See also Note [Role annotations in the renamer] rnRoleAnnots :: NameSet - -> [LRoleAnnotDecl RdrName] - -> RnM [LRoleAnnotDecl Name] + -> [LRoleAnnotDecl GhcPs] + -> RnM [LRoleAnnotDecl GhcRn] rnRoleAnnots tc_names role_annots = do { -- Check for duplicates *before* renaming, to avoid -- lumping together all the unboundNames @@ -1524,7 +1530,7 @@ rnRoleAnnots tc_names role_annots tycon ; return $ RoleAnnotDecl tycon' roles } -dupRoleAnnotErr :: [LRoleAnnotDecl RdrName] -> RnM () +dupRoleAnnotErr :: [LRoleAnnotDecl GhcPs] -> RnM () dupRoleAnnotErr [] = panic "dupRoleAnnotErr" dupRoleAnnotErr list = addErrAt loc $ @@ -1540,7 +1546,7 @@ dupRoleAnnotErr list cmp_annot (L loc1 _) (L loc2 _) = loc1 `compare` loc2 -orphanRoleAnnotErr :: LRoleAnnotDecl Name -> RnM () +orphanRoleAnnotErr :: LRoleAnnotDecl GhcRn -> RnM () orphanRoleAnnotErr (L loc decl) = addErrAt loc $ hang (text "Role annotation for a type previously declared:") @@ -1594,13 +1600,13 @@ modules), we get better error messages, too. -- the tycon names that are both -- a) free in the instance declaration -- b) bound by this group of type/class/instance decls -type InstDeclFreeVarsMap = [(LInstDecl Name, FreeVars)] +type InstDeclFreeVarsMap = [(LInstDecl GhcRn, FreeVars)] -- | Construct an @InstDeclFreeVarsMap@ by eliminating any @Name@s from the -- @FreeVars@ which are *not* the binders of a @TyClDecl@. mkInstDeclFreeVarsMap :: GlobalRdrEnv -> NameSet - -> [(LInstDecl Name, FreeVars)] + -> [(LInstDecl GhcRn, FreeVars)] -> InstDeclFreeVarsMap mkInstDeclFreeVarsMap rdr_env tycl_bndrs inst_ds_fvs = [ (inst_decl, toParents rdr_env fvs `intersectFVs` tycl_bndrs) @@ -1614,12 +1620,13 @@ mkInstDeclFreeVarsMap rdr_env tycl_bndrs inst_ds_fvs -- whose free vars are now defined -- instd_map' is the inst-decl map with 'tcs' removed from -- the free-var set -getInsts :: [Name] -> InstDeclFreeVarsMap -> ([LInstDecl Name], InstDeclFreeVarsMap) +getInsts :: [Name] -> InstDeclFreeVarsMap + -> ([LInstDecl GhcRn], InstDeclFreeVarsMap) getInsts bndrs inst_decl_map = partitionWith pick_me inst_decl_map where - pick_me :: (LInstDecl Name, FreeVars) - -> Either (LInstDecl Name) (LInstDecl Name, FreeVars) + pick_me :: (LInstDecl GhcRn, FreeVars) + -> Either (LInstDecl GhcRn) (LInstDecl GhcRn, FreeVars) pick_me (decl, fvs) | isEmptyNameSet depleted_fvs = Left decl | otherwise = Right (decl, depleted_fvs) @@ -1632,8 +1639,8 @@ getInsts bndrs inst_decl_map * * ****************************************************** -} -rnTyClDecl :: TyClDecl RdrName - -> RnM (TyClDecl Name, FreeVars) +rnTyClDecl :: TyClDecl GhcPs + -> RnM (TyClDecl GhcRn, FreeVars) -- All flavours of type family declarations ("type family", "newtype family", -- and "data family"), both top level and (for an associated type) @@ -1744,11 +1751,11 @@ rnTyClDecl (ClassDecl { tcdCtxt = context, tcdLName = lcls, cls_doc = ClassDeclCtx lcls -- "type" and "type instance" declarations -rnTySyn :: HsDocContext -> LHsType RdrName -> RnM (LHsType Name, FreeVars) +rnTySyn :: HsDocContext -> LHsType GhcPs -> RnM (LHsType GhcRn, FreeVars) rnTySyn doc rhs = rnLHsType doc rhs -rnDataDefn :: HsDocContext -> HsDataDefn RdrName - -> RnM ((HsDataDefn Name, NameSet), FreeVars) +rnDataDefn :: HsDocContext -> HsDataDefn GhcPs + -> RnM ((HsDataDefn GhcRn, NameSet), FreeVars) -- the NameSet includes all Names free in the kind signature -- See Note [Complete user-supplied kind signatures] rnDataDefn doc (HsDataDefn { dd_ND = new_or_data, dd_cType = cType @@ -1794,8 +1801,8 @@ rnDataDefn doc (HsDataDefn { dd_ND = new_or_data, dd_cType = cType ; (ds', fvs) <- mapFvRn (rnLHsDerivingClause deriv_strats_ok doc) ds ; return (L loc ds', fvs) } -rnLHsDerivingClause :: Bool -> HsDocContext -> LHsDerivingClause RdrName - -> RnM (LHsDerivingClause Name, FreeVars) +rnLHsDerivingClause :: Bool -> HsDocContext -> LHsDerivingClause GhcPs + -> RnM (LHsDerivingClause GhcRn, FreeVars) rnLHsDerivingClause deriv_strats_ok doc (L loc (HsDerivingClause { deriv_clause_strategy = dcs , deriv_clause_tys = L loc' dct })) @@ -1824,8 +1831,8 @@ multipleDerivClausesErr rnFamDecl :: Maybe Name -- Just cls => this FamilyDecl is nested -- inside an *class decl* for cls -- used for associated types - -> FamilyDecl RdrName - -> RnM (FamilyDecl Name, FreeVars) + -> FamilyDecl GhcPs + -> RnM (FamilyDecl GhcRn, FreeVars) rnFamDecl mb_cls (FamilyDecl { fdLName = tycon, fdTyVars = tyvars , fdFixity = fixity , fdInfo = info, fdResultSig = res_sig @@ -1861,8 +1868,8 @@ rnFamDecl mb_cls (FamilyDecl { fdLName = tycon, fdTyVars = tyvars rnFamResultSig :: HsDocContext -> [Name] -- kind variables already in scope - -> FamilyResultSig RdrName - -> RnM (FamilyResultSig Name, FreeVars) + -> FamilyResultSig GhcPs + -> RnM (FamilyResultSig GhcRn, FreeVars) rnFamResultSig _ _ NoSig = return (NoSig, emptyFVs) rnFamResultSig doc _ (KindSig kind) @@ -1928,11 +1935,11 @@ rnFamResultSig doc kv_names (TyVarSig tvbndr) -- | Rename injectivity annotation. Note that injectivity annotation is just the -- part after the "|". Everything that appears before it is renamed in -- rnFamDecl. -rnInjectivityAnn :: LHsQTyVars Name -- ^ Type variables declared in +rnInjectivityAnn :: LHsQTyVars GhcRn -- ^ Type variables declared in -- type family head - -> LFamilyResultSig Name -- ^ Result signature - -> LInjectivityAnn RdrName -- ^ Injectivity annotation - -> RnM (LInjectivityAnn Name) + -> LFamilyResultSig GhcRn -- ^ Result signature + -> LInjectivityAnn GhcPs -- ^ Injectivity annotation + -> RnM (LInjectivityAnn GhcRn) rnInjectivityAnn tvBndrs (L _ (TyVarSig resTv)) (L srcSpan (InjectivityAnn injFrom injTo)) = do @@ -2013,10 +2020,10 @@ badAssocRhs ns 2 (text "All such variables must be bound on the LHS")) ----------------- -rnConDecls :: [LConDecl RdrName] -> RnM ([LConDecl Name], FreeVars) +rnConDecls :: [LConDecl GhcPs] -> RnM ([LConDecl GhcRn], FreeVars) rnConDecls = mapFvRn (wrapLocFstM rnConDecl) -rnConDecl :: ConDecl RdrName -> RnM (ConDecl Name, FreeVars) +rnConDecl :: ConDecl GhcPs -> RnM (ConDecl GhcRn, FreeVars) rnConDecl decl@(ConDeclH98 { con_name = name, con_qvars = qtvs , con_cxt = mcxt, con_details = details , con_doc = mb_doc }) @@ -2050,8 +2057,8 @@ rnConDecl decl@(ConDeclH98 { con_name = name, con_qvars = qtvs cxt = maybe [] unLoc mcxt get_rdr_tvs tys = extractHsTysRdrTyVars (cxt ++ tys) - get_con_qtvs :: [LHsType RdrName] - -> RnM ([Located RdrName], LHsQTyVars RdrName) + get_con_qtvs :: [LHsType GhcPs] + -> RnM ([Located RdrName], LHsQTyVars GhcPs) get_con_qtvs arg_tys | Just tvs <- qtvs -- data T = forall a. MkT (a -> a) = do { free_vars <- get_rdr_tvs arg_tys @@ -2076,8 +2083,9 @@ rnConDecl decl@(ConDeclGADT { con_names = names, con_type = ty rnConDeclDetails :: Name -> HsDocContext - -> HsConDetails (LHsType RdrName) (Located [LConDeclField RdrName]) - -> RnM (HsConDetails (LHsType Name) (Located [LConDeclField Name]), FreeVars) + -> HsConDetails (LHsType GhcPs) (Located [LConDeclField GhcPs]) + -> RnM (HsConDetails (LHsType GhcRn) (Located [LConDeclField GhcRn]), + FreeVars) rnConDeclDetails _ doc (PrefixCon tys) = do { (new_tys, fvs) <- rnLHsTypes doc tys ; return (PrefixCon new_tys, fvs) } @@ -2098,7 +2106,7 @@ rnConDeclDetails con doc (RecCon (L l fields)) -- | Brings pattern synonym names and also pattern synonym selectors -- from record pattern synonyms into scope. -extendPatSynEnv :: HsValBinds RdrName -> MiniFixityEnv +extendPatSynEnv :: HsValBinds GhcPs -> MiniFixityEnv -> ([Name] -> TcRnIf TcGblEnv TcLclEnv a) -> TcM a extendPatSynEnv val_decls local_fix_env thing = do { names_with_fls <- new_ps val_decls @@ -2111,11 +2119,11 @@ extendPatSynEnv val_decls local_fix_env thing = do { final_gbl_env = gbl_env { tcg_field_env = field_env' } ; setEnvs (final_gbl_env, lcl_env) (thing pat_syn_bndrs) } where - new_ps :: HsValBinds RdrName -> TcM [(Name, [FieldLabel])] + new_ps :: HsValBinds GhcPs -> TcM [(Name, [FieldLabel])] new_ps (ValBindsIn binds _) = foldrBagM new_ps' [] binds new_ps _ = panic "new_ps" - new_ps' :: LHsBindLR RdrName RdrName + new_ps' :: LHsBindLR GhcPs GhcPs -> [(Name, [FieldLabel])] -> TcM [(Name, [FieldLabel])] new_ps' bind names @@ -2124,7 +2132,7 @@ extendPatSynEnv val_decls local_fix_env thing = do { = do bnd_name <- newTopSrcBinder (L bind_loc n) let rnames = map recordPatSynSelectorId as - mkFieldOcc :: Located RdrName -> LFieldOcc RdrName + mkFieldOcc :: Located RdrName -> LFieldOcc GhcPs mkFieldOcc (L l name) = L l (FieldOcc (L l name) PlaceHolder) field_occs = map mkFieldOcc rnames flds <- mapM (newRecordSelector False [bnd_name]) field_occs @@ -2175,18 +2183,19 @@ Template Haskell splice. As it does so it b) runs any top-level quasi-quotes -} -findSplice :: [LHsDecl RdrName] -> RnM (HsGroup RdrName, Maybe (SpliceDecl RdrName, [LHsDecl RdrName])) +findSplice :: [LHsDecl GhcPs] + -> RnM (HsGroup GhcPs, Maybe (SpliceDecl GhcPs, [LHsDecl GhcPs])) findSplice ds = addl emptyRdrGroup ds -addl :: HsGroup RdrName -> [LHsDecl RdrName] - -> RnM (HsGroup RdrName, Maybe (SpliceDecl RdrName, [LHsDecl RdrName])) +addl :: HsGroup GhcPs -> [LHsDecl GhcPs] + -> RnM (HsGroup GhcPs, Maybe (SpliceDecl GhcPs, [LHsDecl GhcPs])) -- This stuff reverses the declarations (again) but it doesn't matter addl gp [] = return (gp, Nothing) addl gp (L l d : ds) = add gp l d ds -add :: HsGroup RdrName -> SrcSpan -> HsDecl RdrName -> [LHsDecl RdrName] - -> RnM (HsGroup RdrName, Maybe (SpliceDecl RdrName, [LHsDecl RdrName])) +add :: HsGroup GhcPs -> SrcSpan -> HsDecl GhcPs -> [LHsDecl GhcPs] + -> RnM (HsGroup GhcPs, Maybe (SpliceDecl GhcPs, [LHsDecl GhcPs])) -- #10047: Declaration QuasiQuoters are expanded immediately, without -- causing a group split diff --git a/compiler/rename/RnSplice.hs b/compiler/rename/RnSplice.hs index e0f9493291..a03e4c88df 100644 --- a/compiler/rename/RnSplice.hs +++ b/compiler/rename/RnSplice.hs @@ -1,4 +1,5 @@ {-# LANGUAGE CPP #-} +{-# LANGUAGE TypeFamilies #-} module RnSplice ( rnTopSpliceDecls, @@ -40,7 +41,6 @@ import FastString import ErrUtils ( dumpIfSet_dyn_printer ) import TcEnv ( tcMetaTy ) import Hooks -import Var ( Id ) import THNames ( quoteExpName, quotePatName, quoteDecName, quoteTypeName , decsQTyConName, expQTyConName, patQTyConName, typeQTyConName, ) @@ -67,7 +67,7 @@ import qualified GHC.LanguageExtensions as LangExt ************************************************************************ -} -rnBracket :: HsExpr RdrName -> HsBracket RdrName -> RnM (HsExpr Name, FreeVars) +rnBracket :: HsExpr GhcPs -> HsBracket GhcPs -> RnM (HsExpr GhcRn, FreeVars) rnBracket e br_body = addErrCtxt (quotationCtxtDoc br_body) $ do { -- Check that -XTemplateHaskellQuotes is enabled and available @@ -112,7 +112,7 @@ rnBracket e br_body ; return (HsRnBracketOut body' pendings, fvs_e) } } -rn_bracket :: ThStage -> HsBracket RdrName -> RnM (HsBracket Name, FreeVars) +rn_bracket :: ThStage -> HsBracket GhcPs -> RnM (HsBracket GhcRn, FreeVars) rn_bracket outer_stage br@(VarBr flg rdr_name) = do { name <- lookupOccRn rdr_name ; this_mod <- getModule @@ -159,7 +159,7 @@ rn_bracket _ (DecBrL decls) ppr (duUses (tcg_dus tcg_env))) ; return (DecBrG group', duUses (tcg_dus tcg_env)) } where - groupDecls :: [LHsDecl RdrName] -> RnM (HsGroup RdrName) + groupDecls :: [LHsDecl GhcPs] -> RnM (HsGroup GhcPs) groupDecls decls = do { (group, mb_splice) <- findSplice decls ; case mb_splice of @@ -176,7 +176,7 @@ rn_bracket _ (DecBrG _) = panic "rn_bracket: unexpected DecBrG" rn_bracket _ (TExpBr e) = do { (e', fvs) <- rnLExpr e ; return (TExpBr e', fvs) } -quotationCtxtDoc :: HsBracket RdrName -> SDoc +quotationCtxtDoc :: HsBracket GhcPs -> SDoc quotationCtxtDoc br_body = hang (text "In the Template Haskell quotation") 2 (ppr br_body) @@ -194,7 +194,7 @@ illegalUntypedBracket :: SDoc illegalUntypedBracket = text "Untyped brackets may only appear in untyped splices." -quotedNameStageErr :: HsBracket RdrName -> SDoc +quotedNameStageErr :: HsBracket GhcPs -> SDoc quotedNameStageErr br = sep [ text "Stage error: the non-top-level quoted name" <+> ppr br , text "must be used at the same stage at which it is bound" ] @@ -236,9 +236,11 @@ returns a bogus term/type, so that it can report more than one error. We don't want the type checker to see these bogus unbound variables. -} -rnSpliceGen :: (HsSplice Name -> RnM (a, FreeVars)) -- Outside brackets, run splice - -> (HsSplice Name -> (PendingRnSplice, a)) -- Inside brackets, make it pending - -> HsSplice RdrName +rnSpliceGen :: (HsSplice GhcRn -> RnM (a, FreeVars)) + -- Outside brackets, run splice + -> (HsSplice GhcRn -> (PendingRnSplice, a)) + -- Inside brackets, make it pending + -> HsSplice GhcPs -> RnM (a, FreeVars) rnSpliceGen run_splice pend_splice splice = addErrCtxt (spliceCtxt splice) $ do @@ -281,10 +283,10 @@ rnSpliceGen run_splice pend_splice splice -- -- See Note [Delaying modFinalizers in untyped splices]. runRnSplice :: UntypedSpliceFlavour - -> (LHsExpr Id -> TcRn res) + -> (LHsExpr GhcTc -> TcRn res) -> (res -> SDoc) -- How to pretty-print res -- Usually just ppr, but not for [Decl] - -> HsSplice Name -- Always untyped + -> HsSplice GhcRn -- Always untyped -> TcRn (res, [ForeignRef (TH.Q ())]) runRnSplice flavour run_meta ppr_res splice = do { splice' <- getHooked runRnSpliceHook return >>= ($ splice) @@ -329,7 +331,7 @@ runRnSplice flavour run_meta ppr_res splice ------------------ makePending :: UntypedSpliceFlavour - -> HsSplice Name + -> HsSplice GhcRn -> PendingRnSplice makePending flavour (HsUntypedSplice _ n e) = PendingRnSplice flavour n e @@ -341,7 +343,8 @@ makePending _ splice@(HsSpliced {}) = pprPanic "makePending" (ppr splice) ------------------ -mkQuasiQuoteExpr :: UntypedSpliceFlavour -> Name -> SrcSpan -> FastString -> LHsExpr Name +mkQuasiQuoteExpr :: UntypedSpliceFlavour -> Name -> SrcSpan -> FastString + -> LHsExpr GhcRn -- Return the expression (quoter "...quote...") -- which is what we must run in a quasi-quote mkQuasiQuoteExpr flavour quoter q_span quote @@ -359,7 +362,7 @@ mkQuasiQuoteExpr flavour quoter q_span quote UntypedDeclSplice -> quoteDecName --------------------- -rnSplice :: HsSplice RdrName -> RnM (HsSplice Name, FreeVars) +rnSplice :: HsSplice GhcPs -> RnM (HsSplice GhcRn, FreeVars) -- Not exported...used for all rnSplice (HsTypedSplice hasParen splice_name expr) = do { checkTH expr "Template Haskell typed splice" @@ -391,15 +394,15 @@ rnSplice (HsQuasiQuote splice_name quoter q_loc quote) rnSplice splice@(HsSpliced {}) = pprPanic "rnSplice" (ppr splice) --------------------- -rnSpliceExpr :: HsSplice RdrName -> RnM (HsExpr Name, FreeVars) +rnSpliceExpr :: HsSplice GhcPs -> RnM (HsExpr GhcRn, FreeVars) rnSpliceExpr splice = rnSpliceGen run_expr_splice pend_expr_splice splice where - pend_expr_splice :: HsSplice Name -> (PendingRnSplice, HsExpr Name) + pend_expr_splice :: HsSplice GhcRn -> (PendingRnSplice, HsExpr GhcRn) pend_expr_splice rn_splice = (makePending UntypedExpSplice rn_splice, HsSpliceE rn_splice) - run_expr_splice :: HsSplice Name -> RnM (HsExpr Name, FreeVars) + run_expr_splice :: HsSplice GhcRn -> RnM (HsExpr GhcRn, FreeVars) run_expr_splice rn_splice | isTypedSplice rn_splice -- Run it later, in the type checker = do { -- Ugh! See Note [Splices] above @@ -516,8 +519,8 @@ References: -} ---------------------- -rnSpliceType :: HsSplice RdrName -> PostTc Name Kind - -> RnM (HsType Name, FreeVars) +rnSpliceType :: HsSplice GhcPs -> PostTc GhcRn Kind + -> RnM (HsType GhcRn, FreeVars) rnSpliceType splice k = rnSpliceGen run_type_splice pend_type_splice splice where @@ -583,7 +586,7 @@ whole signature, instead of as an arbitrary type. ---------------------- -- | Rename a splice pattern. See Note [rnSplicePat] -rnSplicePat :: HsSplice RdrName -> RnM ( Either (Pat RdrName) (Pat Name) +rnSplicePat :: HsSplice GhcPs -> RnM ( Either (Pat GhcPs) (Pat GhcRn) , FreeVars) rnSplicePat splice = rnSpliceGen run_pat_splice pend_pat_splice splice @@ -606,7 +609,7 @@ rnSplicePat splice -- lose the outermost location set by runQuasiQuote (#7918) ---------------------- -rnSpliceDecl :: SpliceDecl RdrName -> RnM (SpliceDecl Name, FreeVars) +rnSpliceDecl :: SpliceDecl GhcPs -> RnM (SpliceDecl GhcRn, FreeVars) rnSpliceDecl (SpliceDecl (L loc splice) flg) = rnSpliceGen run_decl_splice pend_decl_splice splice where @@ -615,7 +618,7 @@ rnSpliceDecl (SpliceDecl (L loc splice) flg) run_decl_splice rn_splice = pprPanic "rnSpliceDecl" (ppr rn_splice) -rnTopSpliceDecls :: HsSplice RdrName -> RnM ([LHsDecl RdrName], FreeVars) +rnTopSpliceDecls :: HsSplice GhcPs -> RnM ([LHsDecl GhcPs], FreeVars) -- Declaration splice at the very top level of the module rnTopSpliceDecls splice = do { (rn_splice, fvs) <- checkNoErrs $ @@ -629,7 +632,7 @@ rnTopSpliceDecls splice ; add_mod_finalizers_now mod_finalizers ; return (decls,fvs) } where - ppr_decls :: [LHsDecl RdrName] -> SDoc + ppr_decls :: [LHsDecl GhcPs] -> SDoc ppr_decls ds = vcat (map ppr ds) -- Adds finalizers to the global environment instead of delaying them @@ -673,7 +676,7 @@ Pat RdrName (the result of running a top-level splice) or a Pat Name rnSplicePat. -} -spliceCtxt :: HsSplice RdrName -> SDoc +spliceCtxt :: HsSplice GhcPs -> SDoc spliceCtxt splice = hang (text "In the" <+> what) 2 (ppr splice) where @@ -686,12 +689,12 @@ spliceCtxt splice -- | The splice data to be logged data SpliceInfo = SpliceInfo - { spliceDescription :: String - , spliceSource :: Maybe (LHsExpr Name) -- Nothing <=> top-level decls - -- added by addTopDecls - , spliceIsDecl :: Bool -- True <=> put the generate code in a file - -- when -dth-dec-file is on - , spliceGenerated :: SDoc + { spliceDescription :: String + , spliceSource :: Maybe (LHsExpr GhcRn) -- Nothing <=> top-level decls + -- added by addTopDecls + , spliceIsDecl :: Bool -- True <=> put the generate code in a file + -- when -dth-dec-file is on + , spliceGenerated :: SDoc } -- Note that 'spliceSource' is *renamed* but not *typechecked* -- Reason (a) less typechecking crap diff --git a/compiler/rename/RnSplice.hs-boot b/compiler/rename/RnSplice.hs-boot index b079b30bd5..875ba05e52 100644 --- a/compiler/rename/RnSplice.hs-boot +++ b/compiler/rename/RnSplice.hs-boot @@ -2,16 +2,14 @@ module RnSplice where import HsSyn import TcRnMonad -import RdrName -import Name import NameSet import Kind -rnSpliceType :: HsSplice RdrName -> PostTc Name Kind - -> RnM (HsType Name, FreeVars) -rnSplicePat :: HsSplice RdrName -> RnM ( Either (Pat RdrName) (Pat Name) +rnSpliceType :: HsSplice GhcPs -> PostTc GhcRn Kind + -> RnM (HsType GhcRn, FreeVars) +rnSplicePat :: HsSplice GhcPs -> RnM ( Either (Pat GhcPs) (Pat GhcRn) , FreeVars ) -rnSpliceDecl :: SpliceDecl RdrName -> RnM (SpliceDecl Name, FreeVars) +rnSpliceDecl :: SpliceDecl GhcPs -> RnM (SpliceDecl GhcRn, FreeVars) -rnTopSpliceDecls :: HsSplice RdrName -> RnM ([LHsDecl RdrName], FreeVars) +rnTopSpliceDecls :: HsSplice GhcPs -> RnM ([LHsDecl GhcPs], FreeVars) diff --git a/compiler/rename/RnTypes.hs b/compiler/rename/RnTypes.hs index 7571684754..b75fcf2fc4 100644 --- a/compiler/rename/RnTypes.hs +++ b/compiler/rename/RnTypes.hs @@ -78,14 +78,14 @@ to break several loop. ********************************************************* -} -rnHsSigWcType :: HsDocContext -> LHsSigWcType RdrName - -> RnM (LHsSigWcType Name, FreeVars) +rnHsSigWcType :: HsDocContext -> LHsSigWcType GhcPs + -> RnM (LHsSigWcType GhcRn, FreeVars) rnHsSigWcType doc sig_ty = rn_hs_sig_wc_type True doc sig_ty $ \sig_ty' -> return (sig_ty', emptyFVs) -rnHsSigWcTypeScoped :: HsDocContext -> LHsSigWcType RdrName - -> (LHsSigWcType Name -> RnM (a, FreeVars)) +rnHsSigWcTypeScoped :: HsDocContext -> LHsSigWcType GhcPs + -> (LHsSigWcType GhcRn -> RnM (a, FreeVars)) -> RnM (a, FreeVars) -- Used for -- - Signatures on binders in a RULE @@ -104,8 +104,8 @@ rnHsSigWcTypeScoped ctx sig_ty thing_inside rn_hs_sig_wc_type :: Bool -- see rnImplicitBndrs -> HsDocContext - -> LHsSigWcType RdrName - -> (LHsSigWcType Name -> RnM (a, FreeVars)) + -> LHsSigWcType GhcPs + -> (LHsSigWcType GhcRn -> RnM (a, FreeVars)) -> RnM (a, FreeVars) -- rn_hs_sig_wc_type is used for source-language type signatures rn_hs_sig_wc_type no_implicit_if_forall ctxt @@ -120,7 +120,7 @@ rn_hs_sig_wc_type no_implicit_if_forall ctxt ; (res, fvs2) <- thing_inside sig_ty' ; return (res, fvs1 `plusFV` fvs2) } } -rnHsWcType :: HsDocContext -> LHsWcType RdrName -> RnM (LHsWcType Name, FreeVars) +rnHsWcType :: HsDocContext -> LHsWcType GhcPs -> RnM (LHsWcType GhcRn, FreeVars) rnHsWcType ctxt (HsWC { hswc_body = hs_ty }) = do { free_vars <- extractFilteredRdrTyVars hs_ty ; (_, nwc_rdrs) <- partition_nwcs free_vars @@ -128,8 +128,8 @@ rnHsWcType ctxt (HsWC { hswc_body = hs_ty }) ; let sig_ty' = HsWC { hswc_wcs = wcs, hswc_body = hs_ty' } ; return (sig_ty', fvs) } -rnWcBody :: HsDocContext -> [Located RdrName] -> LHsType RdrName - -> RnM ([Name], LHsType Name, FreeVars) +rnWcBody :: HsDocContext -> [Located RdrName] -> LHsType GhcPs + -> RnM ([Name], LHsType GhcRn, FreeVars) rnWcBody ctxt nwc_rdrs hs_ty = do { nwcs <- mapM newLocalBndrRn nwc_rdrs ; let env = RTKE { rtke_level = TypeLevel @@ -146,7 +146,7 @@ rnWcBody ctxt nwc_rdrs hs_ty do { (hs_ty', fvs) <- rn_ty env hs_ty ; return (L loc hs_ty', fvs) } - rn_ty :: RnTyKiEnv -> HsType RdrName -> RnM (HsType Name, FreeVars) + rn_ty :: RnTyKiEnv -> HsType GhcPs -> RnM (HsType GhcRn, FreeVars) -- A lot of faff just to allow the extra-constraints wildcard to appear rn_ty env hs_ty@(HsForAllTy { hst_bndrs = tvs, hst_body = hs_body }) = bindLHsTyVarBndrs (rtke_ctxt env) (Just $ inTypeDoc hs_ty) @@ -177,7 +177,7 @@ rnWcBody ctxt nwc_rdrs hs_ty rn_top_constraint env = rnLHsTyKi (env { rtke_what = RnTopConstraint }) -checkExtraConstraintWildCard :: RnTyKiEnv -> HsWildCardInfo RdrName +checkExtraConstraintWildCard :: RnTyKiEnv -> HsWildCardInfo GhcPs -> RnM () -- Rename the extra-constraint spot in a type signature -- (blah, _) => type @@ -204,7 +204,7 @@ extraConstraintWildCardsAllowed env -- without variables that are already in scope in LocalRdrEnv -- NB: this includes named wildcards, which look like perfectly -- ordinary type variables at this point -extractFilteredRdrTyVars :: LHsType RdrName -> RnM FreeKiTyVars +extractFilteredRdrTyVars :: LHsType GhcPs -> RnM FreeKiTyVars extractFilteredRdrTyVars hs_ty = do { rdr_env <- getLocalRdrEnv ; filterInScope rdr_env <$> extractHsTyRdrTyVars hs_ty } @@ -245,8 +245,8 @@ of the HsWildCardBndrs structure, and we are done. * * ****************************************************** -} -rnHsSigType :: HsDocContext -> LHsSigType RdrName - -> RnM (LHsSigType Name, FreeVars) +rnHsSigType :: HsDocContext -> LHsSigType GhcPs + -> RnM (LHsSigType GhcRn, FreeVars) -- Used for source-language type signatures -- that cannot have wildcards rnHsSigType ctx (HsIB { hsib_body = hs_ty }) @@ -260,7 +260,7 @@ rnImplicitBndrs :: Bool -- True <=> no implicit quantification -- E.g. f :: forall a. a->b -- Do not quantify over 'b' too. -> FreeKiTyVars - -> LHsType RdrName + -> LHsType GhcPs -> ([Name] -> RnM (a, FreeVars)) -> RnM (a, FreeVars) rnImplicitBndrs no_implicit_if_forall free_vars hs_ty@(L loc _) thing_inside @@ -279,7 +279,7 @@ rnImplicitBndrs no_implicit_if_forall free_vars hs_ty@(L loc _) thing_inside ; bindLocalNamesFV vars $ thing_inside vars } -rnLHsInstType :: SDoc -> LHsSigType RdrName -> RnM (LHsSigType Name, FreeVars) +rnLHsInstType :: SDoc -> LHsSigType GhcPs -> RnM (LHsSigType GhcRn, FreeVars) -- Rename the type in an instance or standalone deriving decl -- The 'doc_str' is "an instance declaration" or "a VECTORISE pragma" rnLHsInstType doc_str inst_ty @@ -297,10 +297,10 @@ rnLHsInstType doc_str inst_ty text "Malformed instance:" <+> ppr inst_ty ; rnHsSigType (GenericCtx doc_str) inst_ty } -mk_implicit_bndrs :: [Name] -- implicitly bound +mk_implicit_bndrs :: [Name] -- implicitly bound -> a -- payload -> FreeVars -- FreeVars of payload - -> HsImplicitBndrs Name a + -> HsImplicitBndrs GhcRn a mk_implicit_bndrs vars body fvs = HsIB { hsib_vars = vars , hsib_body = body @@ -428,40 +428,42 @@ isRnKindLevel (RTKE { rtke_level = KindLevel }) = True isRnKindLevel _ = False -------------- -rnLHsType :: HsDocContext -> LHsType RdrName -> RnM (LHsType Name, FreeVars) +rnLHsType :: HsDocContext -> LHsType GhcPs -> RnM (LHsType GhcRn, FreeVars) rnLHsType ctxt ty = rnLHsTyKi (mkTyKiEnv ctxt TypeLevel RnTypeBody) ty -rnLHsTypes :: HsDocContext -> [LHsType RdrName] -> RnM ([LHsType Name], FreeVars) +rnLHsTypes :: HsDocContext -> [LHsType GhcPs] -> RnM ([LHsType GhcRn], FreeVars) rnLHsTypes doc tys = mapFvRn (rnLHsType doc) tys -rnHsType :: HsDocContext -> HsType RdrName -> RnM (HsType Name, FreeVars) +rnHsType :: HsDocContext -> HsType GhcPs -> RnM (HsType GhcRn, FreeVars) rnHsType ctxt ty = rnHsTyKi (mkTyKiEnv ctxt TypeLevel RnTypeBody) ty -rnLHsKind :: HsDocContext -> LHsKind RdrName -> RnM (LHsKind Name, FreeVars) +rnLHsKind :: HsDocContext -> LHsKind GhcPs -> RnM (LHsKind GhcRn, FreeVars) rnLHsKind ctxt kind = rnLHsTyKi (mkTyKiEnv ctxt KindLevel RnTypeBody) kind -rnHsKind :: HsDocContext -> HsKind RdrName -> RnM (HsKind Name, FreeVars) +rnHsKind :: HsDocContext -> HsKind GhcPs -> RnM (HsKind GhcRn, FreeVars) rnHsKind ctxt kind = rnHsTyKi (mkTyKiEnv ctxt KindLevel RnTypeBody) kind -------------- -rnTyKiContext :: RnTyKiEnv -> LHsContext RdrName -> RnM (LHsContext Name, FreeVars) +rnTyKiContext :: RnTyKiEnv -> LHsContext GhcPs + -> RnM (LHsContext GhcRn, FreeVars) rnTyKiContext env (L loc cxt) = do { traceRn "rncontext" (ppr cxt) ; let env' = env { rtke_what = RnConstraint } ; (cxt', fvs) <- mapFvRn (rnLHsTyKi env') cxt ; return (L loc cxt', fvs) } -rnContext :: HsDocContext -> LHsContext RdrName -> RnM (LHsContext Name, FreeVars) +rnContext :: HsDocContext -> LHsContext GhcPs + -> RnM (LHsContext GhcRn, FreeVars) rnContext doc theta = rnTyKiContext (mkTyKiEnv doc TypeLevel RnConstraint) theta -------------- -rnLHsTyKi :: RnTyKiEnv -> LHsType RdrName -> RnM (LHsType Name, FreeVars) +rnLHsTyKi :: RnTyKiEnv -> LHsType GhcPs -> RnM (LHsType GhcRn, FreeVars) rnLHsTyKi env (L loc ty) = setSrcSpan loc $ do { (ty', fvs) <- rnHsTyKi env ty ; return (L loc ty', fvs) } -rnHsTyKi :: RnTyKiEnv -> HsType RdrName -> RnM (HsType Name, FreeVars) +rnHsTyKi :: RnTyKiEnv -> HsType GhcPs -> RnM (HsType GhcRn, FreeVars) rnHsTyKi env ty@(HsForAllTy { hst_bndrs = tyvars, hst_body = tau }) = do { checkTypeInType env ty @@ -593,9 +595,9 @@ rnHsTyKi env overall_ty@(HsAppsTy tys) ; return (res_ty, fvs1 `plusFV` fvs2) } where -- See Note [Dealing with *] - deal_with_star :: [[LHsType Name]] -> [Located Name] - -> [[LHsType Name]] -> [Located Name] - -> ([[LHsType Name]], [Located Name]) + deal_with_star :: [[LHsType GhcRn]] -> [Located Name] + -> [[LHsType GhcRn]] -> [Located Name] + -> ([[LHsType GhcRn]], [Located Name]) deal_with_star acc1 acc2 (non_syms1 : non_syms2 : non_syms) (L loc star : ops) | star `hasKey` starKindTyConKey || star `hasKey` unicodeStarKindTyConKey @@ -610,14 +612,14 @@ rnHsTyKi env overall_ty@(HsAppsTy tys) deal_with_star _ _ _ _ = pprPanic "deal_with_star" (ppr overall_ty) - -- collapse [LHsType Name] to LHsType Name by making applications + -- collapse [LHsType GhcRn] to LHsType GhcRn by making applications -- monadic only for failure - deal_with_non_syms :: [LHsType Name] -> RnM (LHsType Name) + deal_with_non_syms :: [LHsType GhcRn] -> RnM (LHsType GhcRn) deal_with_non_syms (non_sym : non_syms) = return $ mkHsAppTys non_sym non_syms deal_with_non_syms [] = failWith (emptyNonSymsErr overall_ty) -- assemble a right-biased OpTy for use in mkHsOpTyRn - build_res_ty :: [LHsType Name] -> [Located Name] -> RnM (LHsType Name) + build_res_ty :: [LHsType GhcRn] -> [Located Name] -> RnM (LHsType GhcRn) build_res_ty (arg1 : args) (op1 : ops) = do { rhs <- build_res_ty args ops ; fix <- lookupTyFixityRn op1 @@ -697,7 +699,8 @@ rnLTyVar (L loc rdr_name) -------------- rnHsTyOp :: Outputable a - => RnTyKiEnv -> a -> Located RdrName -> RnM (Located Name, FreeVars) + => RnTyKiEnv -> a -> Located RdrName + -> RnM (Located Name, FreeVars) rnHsTyOp env overall_ty (L loc op) = do { ops_ok <- xoptM LangExt.TypeOperators ; op' <- rnTyVar env op @@ -720,7 +723,7 @@ checkWildCard env (Just doc) checkWildCard _ Nothing = return () -checkAnonWildCard :: RnTyKiEnv -> HsWildCardInfo RdrName -> RnM () +checkAnonWildCard :: RnTyKiEnv -> HsWildCardInfo GhcPs -> RnM () -- Report an error if an anonymous wildcard is illegal here checkAnonWildCard env wc = checkWildCard env mb_bad @@ -770,7 +773,7 @@ wildCardsAllowed env HsTypeCtx {} -> True _ -> False -rnAnonWildCard :: HsWildCardInfo RdrName -> RnM (HsWildCardInfo Name) +rnAnonWildCard :: HsWildCardInfo GhcPs -> RnM (HsWildCardInfo GhcRn) rnAnonWildCard (AnonWildCard _) = do { loc <- getSrcSpanM ; uniq <- newUnique @@ -836,10 +839,10 @@ bindHsQTyVars :: forall a b. -> Maybe SDoc -- if we are to check for unused tvs, -- a phrase like "in the type ..." -> Maybe a -- Just _ => an associated type decl - -> [Located RdrName] -- Kind variables from scope, in l-to-r + -> [Located RdrName] -- Kind variables from scope, in l-to-r -- order, but not from ... - -> (LHsQTyVars RdrName) -- ... these user-written tyvars - -> (LHsQTyVars Name -> NameSet -> RnM (b, FreeVars)) + -> (LHsQTyVars GhcPs) -- ... these user-written tyvars + -> (LHsQTyVars GhcRn -> NameSet -> RnM (b, FreeVars)) -- also returns all names used in kind signatures, for the -- TypeInType clause of Note [Complete user-supplied kind -- signatures] in HsDecls @@ -861,11 +864,11 @@ bindLHsTyVarBndrs :: forall a b. -> Maybe SDoc -- if we are to check for unused tvs, -- a phrase like "in the type ..." -> Maybe a -- Just _ => an associated type decl - -> [Located RdrName] -- Unbound kind variables from scope, - -- in l-to-r order, but not from ... - -> [LHsTyVarBndr RdrName] -- ... these user-written tyvars + -> [Located RdrName] -- Unbound kind variables from scope, + -- in l-to-r order, but not from ... + -> [LHsTyVarBndr GhcPs] -- ... these user-written tyvars -> ( [Name] -- all kv names - -> [LHsTyVarBndr Name] + -> [LHsTyVarBndr GhcRn] -> NameSet -- which names, from the preceding list, -- are used dependently within that list -- See Note [Dependent LHsQTyVars] in TcHsType @@ -879,11 +882,11 @@ bindLHsTyVarBndrs doc mb_in_doc mb_assoc kv_bndrs tv_bndrs thing_inside tv_names_w_loc = map hsLTyVarLocName tv_bndrs go :: [Name] -- kind-vars found (in reverse order) - -> [LHsTyVarBndr Name] -- already renamed (in reverse order) + -> [LHsTyVarBndr GhcRn] -- already renamed (in reverse order) -> NameSet -- kind vars already in scope (for dup checking) -> NameSet -- type vars already in scope (for dup checking) -> NameSet -- (all) variables used dependently - -> [LHsTyVarBndr RdrName] -- still to be renamed, scoped + -> [LHsTyVarBndr GhcPs] -- still to be renamed, scoped -> RnM (b, FreeVars) go rn_kvs rn_tvs kv_names tv_names dep_vars (tv_bndr : tv_bndrs) = bindLHsTyVarBndr doc mb_assoc kv_names tv_names tv_bndr $ @@ -923,8 +926,9 @@ bindLHsTyVarBndr :: HsDocContext -> Maybe a -- associated class -> NameSet -- kind vars already in scope -> NameSet -- type vars already in scope - -> LHsTyVarBndr RdrName - -> ([Name] -> NameSet -> LHsTyVarBndr Name -> RnM (b, FreeVars)) + -> LHsTyVarBndr GhcPs + -> ([Name] -> NameSet -> LHsTyVarBndr GhcRn + -> RnM (b, FreeVars)) -- passed the newly-bound implicitly-declared kind vars, -- any other names used in a kind -- and the renamed LHsTyVarBndr @@ -1038,7 +1042,7 @@ newTyVarNameRn mb_assoc (L loc rdr) _ -> newLocalBndrRn (L loc rdr) } --------------------- -collectAnonWildCards :: LHsType Name -> [Name] +collectAnonWildCards :: LHsType GhcRn -> [Name] -- | Extract all wild cards from a type. collectAnonWildCards lty = go lty where @@ -1077,7 +1081,7 @@ collectAnonWildCards lty = go lty prefix_types_only (HsAppPrefix ty) = Just ty prefix_types_only (HsAppInfix _) = Nothing -collectAnonWildCardsBndrs :: [LHsTyVarBndr Name] -> [Name] +collectAnonWildCardsBndrs :: [LHsTyVarBndr GhcRn] -> [Name] collectAnonWildCardsBndrs ltvs = concatMap (go . unLoc) ltvs where go (UserTyVar _) = [] @@ -1097,8 +1101,8 @@ RnNames.getLocalNonValBinders), so we just take the list as an argument, build a map and look them up. -} -rnConDeclFields :: HsDocContext -> [FieldLabel] -> [LConDeclField RdrName] - -> RnM ([LConDeclField Name], FreeVars) +rnConDeclFields :: HsDocContext -> [FieldLabel] -> [LConDeclField GhcPs] + -> RnM ([LConDeclField GhcRn], FreeVars) -- Also called from RnSource -- No wildcards can appear in record fields rnConDeclFields ctxt fls fields @@ -1107,15 +1111,15 @@ rnConDeclFields ctxt fls fields env = mkTyKiEnv ctxt TypeLevel RnTypeBody fl_env = mkFsEnv [ (flLabel fl, fl) | fl <- fls ] -rnField :: FastStringEnv FieldLabel -> RnTyKiEnv -> LConDeclField RdrName - -> RnM (LConDeclField Name, FreeVars) +rnField :: FastStringEnv FieldLabel -> RnTyKiEnv -> LConDeclField GhcPs + -> RnM (LConDeclField GhcRn, FreeVars) rnField fl_env env (L l (ConDeclField names ty haddock_doc)) = do { let new_names = map (fmap lookupField) names ; (new_ty, fvs) <- rnLHsTyKi env ty ; new_haddock_doc <- rnMbLHsDoc haddock_doc ; return (L l (ConDeclField new_names new_ty new_haddock_doc), fvs) } where - lookupField :: FieldOcc RdrName -> FieldOcc Name + lookupField :: FieldOcc GhcPs -> FieldOcc GhcRn lookupField (FieldOcc (L lr rdr) _) = FieldOcc (L lr rdr) (flSelector fl) where lbl = occNameFS $ rdrNameOcc rdr @@ -1149,9 +1153,9 @@ 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) +mkHsOpTyRn :: (LHsType GhcRn -> LHsType GhcRn -> HsType GhcRn) + -> Name -> Fixity -> LHsType GhcRn -> LHsType GhcRn + -> RnM (HsType GhcRn) mkHsOpTyRn mk1 pp_op1 fix1 ty1 (L loc2 (HsOpTy ty21 op2 ty22)) = do { fix2 <- lookupTyFixityRn op2 @@ -1167,11 +1171,11 @@ 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 :: (LHsType GhcRn -> LHsType GhcRn -> HsType GhcRn) + -> Name -> Fixity -> LHsType GhcRn + -> (LHsType GhcRn -> LHsType GhcRn -> HsType GhcRn) + -> Name -> Fixity -> LHsType GhcRn -> LHsType GhcRn -> SrcSpan + -> RnM (HsType GhcRn) mk_hs_op_ty mk1 op1 fix1 ty1 mk2 op2 fix2 ty21 ty22 loc2 | nofix_error = do { precParseErr (NormalOp op1,fix1) (NormalOp op2,fix2) @@ -1185,11 +1189,11 @@ mk_hs_op_ty mk1 op1 fix1 ty1 --------------------------- -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 GhcRn -- Left operand; already rearranged + -> LHsExpr GhcRn -> Fixity -- Operator and fixity + -> LHsExpr GhcRn -- Right operand (not an OpApp, but might + -- be a NegApp) + -> RnM (HsExpr GhcRn) -- (e11 `op1` e12) `op2` e2 mkOpAppRn e1@(L _ (OpApp e11 op1 fix1 e12)) op2 fix2 e2 @@ -1241,7 +1245,7 @@ mkOpAppRn e1 op fix e2 -- Default case, no rearrangment data OpName = NormalOp Name -- ^ A normal identifier | NegateOp -- ^ Prefix negation | UnboundOp UnboundVar -- ^ An unbound indentifier - | RecFldOp (AmbiguousFieldOcc Name) + | RecFldOp (AmbiguousFieldOcc GhcRn) -- ^ A (possibly ambiguous) record field occurrence instance Outputable OpName where @@ -1250,7 +1254,7 @@ instance Outputable OpName where ppr (UnboundOp uv) = ppr uv ppr (RecFldOp fld) = ppr fld -get_op :: LHsExpr Name -> OpName +get_op :: LHsExpr GhcRn -> OpName -- An unbound name could be either HsVar or HsUnboundVar -- See RnExpr.rnUnboundVar get_op (L _ (HsVar (L _ n))) = NormalOp n @@ -1261,7 +1265,7 @@ get_op other = pprPanic "get_op" (ppr other) -- Parser left-associates everything, but -- derived instances may have correctly-associated things to -- in the right operand. So we just check that the right operand is OK -right_op_ok :: Fixity -> HsExpr Name -> Bool +right_op_ok :: Fixity -> HsExpr GhcRn -> Bool right_op_ok fix1 (OpApp _ _ fix2 _) = not error_please && associate_right where @@ -1281,10 +1285,10 @@ not_op_app (OpApp _ _ _ _) = False 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 GhcRn -- Left operand; already rearranged + -> LHsExpr GhcRn -> Fixity -- Operator and fixity + -> LHsCmdTop GhcRn -- Right operand (not an infix) + -> RnM (HsCmd GhcRn) -- (e11 `op1` e12) `op2` e2 mkOpFormRn a1@(L loc (HsCmdTop (L _ (HsCmdArrForm op1 f (Just fix1) @@ -1309,8 +1313,8 @@ mkOpFormRn arg1 op fix arg2 -- Default case, no rearrangment -------------------------------------- -mkConOpPatRn :: Located Name -> Fixity -> LPat Name -> LPat Name - -> RnM (Pat Name) +mkConOpPatRn :: Located Name -> Fixity -> LPat GhcRn -> LPat GhcRn + -> RnM (Pat GhcRn) mkConOpPatRn op2 fix2 p1@(L loc (ConPatIn op1 (InfixCon p11 p12))) p2 = do { fix1 <- lookupFixityRn (unLoc op1) @@ -1330,12 +1334,12 @@ 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 :: Pat GhcRn -> Bool not_op_pat (ConPatIn _ (InfixCon _ _)) = False not_op_pat _ = True -------------------------------------- -checkPrecMatch :: Name -> MatchGroup Name body -> RnM () +checkPrecMatch :: Name -> MatchGroup GhcRn body -> RnM () -- Check precedence of a function binding written infix -- eg a `op` b `C` c = ... -- See comments with rnExpr (OpApp ...) about "deriving" @@ -1357,7 +1361,7 @@ checkPrecMatch op (MG { mg_alts = L _ ms }) -- 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 :: Name -> Pat GhcRn -> 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) @@ -1379,8 +1383,8 @@ checkPrec _ _ _ -- If arg is itself an operator application, then either -- (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 () +checkSectionPrec :: FixityDirection -> HsExpr GhcPs + -> LHsExpr GhcRn -> LHsExpr GhcRn -> RnM () checkSectionPrec direction section op arg = case unLoc arg of OpApp _ op' fix _ -> go_for_it (get_op op') fix @@ -1417,7 +1421,7 @@ precParseErr op1@(n1,_) op2@(n2,_) ppr_opfix op2, text "in the same infix expression"]) -sectionPrecErr :: (OpName,Fixity) -> (OpName,Fixity) -> HsExpr RdrName -> RnM () +sectionPrecErr :: (OpName,Fixity) -> (OpName,Fixity) -> HsExpr GhcPs -> RnM () sectionPrecErr op@(n1,_) arg_op@(n2,_) section | is_unbound n1 || is_unbound n2 = return () -- Avoid error cascade @@ -1444,7 +1448,7 @@ ppr_opfix (op, fixity) = pp_op <+> brackets (ppr fixity) * * ***************************************************** -} -unexpectedTypeSigErr :: LHsSigWcType RdrName -> SDoc +unexpectedTypeSigErr :: LHsSigWcType GhcPs -> SDoc unexpectedTypeSigErr ty = hang (text "Illegal type signature:" <+> quotes (ppr ty)) 2 (text "Type signatures are only allowed in patterns with ScopedTypeVariables") @@ -1456,14 +1460,14 @@ badKindBndrs doc kvs <+> pprQuotedList kvs) 2 (text "Perhaps you intended to use PolyKinds") -badKindSigErr :: HsDocContext -> LHsType RdrName -> TcM () +badKindSigErr :: HsDocContext -> LHsType GhcPs -> TcM () badKindSigErr doc (L loc ty) = setSrcSpan loc $ addErr $ withHsDocContext doc $ hang (text "Illegal kind signature:" <+> quotes (ppr ty)) 2 (text "Perhaps you intended to use KindSignatures") -dataKindsErr :: RnTyKiEnv -> HsType RdrName -> SDoc +dataKindsErr :: RnTyKiEnv -> HsType GhcPs -> SDoc dataKindsErr env thing = hang (text "Illegal" <+> pp_what <> colon <+> quotes (ppr thing)) 2 (text "Perhaps you intended to use DataKinds") @@ -1471,10 +1475,10 @@ dataKindsErr env thing pp_what | isRnKindLevel env = text "kind" | otherwise = text "type" -inTypeDoc :: HsType RdrName -> SDoc +inTypeDoc :: HsType GhcPs -> SDoc inTypeDoc ty = text "In the type" <+> quotes (ppr ty) -warnUnusedForAll :: SDoc -> LHsTyVarBndr Name -> FreeVars -> TcM () +warnUnusedForAll :: SDoc -> LHsTyVarBndr GhcRn -> FreeVars -> TcM () warnUnusedForAll in_doc (L loc tv) used_names = whenWOptM Opt_WarnUnusedForalls $ unless (hsTyVarName tv `elemNameSet` used_names) $ @@ -1492,7 +1496,7 @@ opTyErr op overall_ty | otherwise = text "Use TypeOperators to allow operators in types" -emptyNonSymsErr :: HsType RdrName -> SDoc +emptyNonSymsErr :: HsType GhcPs -> SDoc emptyNonSymsErr overall_ty = text "Operator applied to too few arguments:" <+> ppr overall_ty @@ -1569,7 +1573,7 @@ filterInScope rdr_env (FKTV kis k_set tys t_set all) inScope :: LocalRdrEnv -> RdrName -> Bool inScope rdr_env rdr = rdr `elemLocalRdrEnv` rdr_env -extractHsTyRdrTyVars :: LHsType RdrName -> RnM FreeKiTyVars +extractHsTyRdrTyVars :: LHsType GhcPs -> RnM FreeKiTyVars -- extractHsTyRdrNames finds the free (kind, type) variables of a HsType -- or the free (sort, kind) variables of a HsKind -- It's used when making the for-alls explicit. @@ -1587,14 +1591,14 @@ extractHsTyRdrTyVars ty -- When the same name occurs multiple times in the types, only the first -- occurrence is returned and the rest is filtered out. -- See Note [Kind and type-variable binders] -extractHsTysRdrTyVars :: [LHsType RdrName] -> RnM FreeKiTyVars +extractHsTysRdrTyVars :: [LHsType GhcPs] -> RnM FreeKiTyVars extractHsTysRdrTyVars tys = rmDupsInRdrTyVars <$> extractHsTysRdrTyVarsDups tys -- | Extracts free type and kind variables from types in a list. -- When the same name occurs multiple times in the types, all occurrences -- are returned. -extractHsTysRdrTyVarsDups :: [LHsType RdrName] -> RnM FreeKiTyVars +extractHsTysRdrTyVarsDups :: [LHsType GhcPs] -> RnM FreeKiTyVars extractHsTysRdrTyVarsDups tys = extract_ltys TypeLevel tys emptyFKTV @@ -1603,14 +1607,14 @@ rmDupsInRdrTyVars :: FreeKiTyVars -> FreeKiTyVars rmDupsInRdrTyVars (FKTV kis k_set tys t_set all) = FKTV (nubL kis) k_set (nubL tys) t_set (nubL all) -extractRdrKindSigVars :: LFamilyResultSig RdrName -> RnM [Located RdrName] +extractRdrKindSigVars :: LFamilyResultSig GhcPs -> RnM [Located RdrName] extractRdrKindSigVars (L _ resultSig) | KindSig k <- resultSig = kindRdrNameFromSig k | TyVarSig (L _ (KindedTyVar _ k)) <- resultSig = kindRdrNameFromSig k | otherwise = return [] where kindRdrNameFromSig k = freeKiTyVarsAllVars <$> extractHsTyRdrTyVars k -extractDataDefnKindVars :: HsDataDefn RdrName -> RnM [Located RdrName] +extractDataDefnKindVars :: HsDataDefn GhcPs -> RnM [Located RdrName] -- Get the scoped kind variables mentioned free in the constructor decls -- Eg data T a = T1 (S (a :: k) | forall (b::k). T2 (S b) -- Here k should scope over the whole definition @@ -1629,21 +1633,21 @@ extractDataDefnKindVars (HsDataDefn { dd_ctxt = ctxt, dd_kindSig = ksig extract_mlctxt ctxt =<< extract_ltys TypeLevel (hsConDeclArgTys details) emptyFKTV -extract_mlctxt :: Maybe (LHsContext RdrName) -> FreeKiTyVars -> RnM FreeKiTyVars +extract_mlctxt :: Maybe (LHsContext GhcPs) -> FreeKiTyVars -> RnM FreeKiTyVars extract_mlctxt Nothing acc = return acc extract_mlctxt (Just ctxt) acc = extract_lctxt TypeLevel ctxt acc extract_lctxt :: TypeOrKind - -> LHsContext RdrName -> FreeKiTyVars -> RnM FreeKiTyVars + -> LHsContext GhcPs -> FreeKiTyVars -> RnM FreeKiTyVars extract_lctxt t_or_k ctxt = extract_ltys t_or_k (unLoc ctxt) -extract_sig_tys :: [LHsSigType RdrName] -> FreeKiTyVars -> RnM FreeKiTyVars +extract_sig_tys :: [LHsSigType GhcPs] -> FreeKiTyVars -> RnM FreeKiTyVars extract_sig_tys sig_tys acc = foldrM (\sig_ty acc -> extract_lty TypeLevel (hsSigType sig_ty) acc) acc sig_tys extract_ltys :: TypeOrKind - -> [LHsType RdrName] -> FreeKiTyVars -> RnM FreeKiTyVars + -> [LHsType GhcPs] -> FreeKiTyVars -> RnM FreeKiTyVars extract_ltys t_or_k tys acc = foldrM (extract_lty t_or_k) acc tys extract_mb :: (a -> FreeKiTyVars -> RnM FreeKiTyVars) @@ -1651,10 +1655,10 @@ extract_mb :: (a -> FreeKiTyVars -> RnM FreeKiTyVars) extract_mb _ Nothing acc = return acc extract_mb f (Just x) acc = f x acc -extract_lkind :: LHsType RdrName -> FreeKiTyVars -> RnM FreeKiTyVars +extract_lkind :: LHsType GhcPs -> FreeKiTyVars -> RnM FreeKiTyVars extract_lkind = extract_lty KindLevel -extract_lty :: TypeOrKind -> LHsType RdrName -> FreeKiTyVars -> RnM FreeKiTyVars +extract_lty :: TypeOrKind -> LHsType GhcPs -> FreeKiTyVars -> RnM FreeKiTyVars extract_lty t_or_k (L _ ty) acc = case ty of HsTyVar _ ltv -> extract_tv t_or_k ltv acc @@ -1696,15 +1700,15 @@ extract_lty t_or_k (L _ ty) acc HsWildCardTy {} -> return acc extract_apps :: TypeOrKind - -> [LHsAppType RdrName] -> FreeKiTyVars -> RnM FreeKiTyVars + -> [LHsAppType GhcPs] -> FreeKiTyVars -> RnM FreeKiTyVars extract_apps t_or_k tys acc = foldrM (extract_app t_or_k) acc tys -extract_app :: TypeOrKind -> LHsAppType RdrName -> FreeKiTyVars +extract_app :: TypeOrKind -> LHsAppType GhcPs -> FreeKiTyVars -> RnM FreeKiTyVars extract_app t_or_k (L _ (HsAppInfix tv)) acc = extract_tv t_or_k tv acc extract_app t_or_k (L _ (HsAppPrefix ty)) acc = extract_lty t_or_k ty acc -extract_hs_tv_bndrs :: [LHsTyVarBndr RdrName] -> FreeKiTyVars +extract_hs_tv_bndrs :: [LHsTyVarBndr GhcPs] -> FreeKiTyVars -> FreeKiTyVars -> RnM FreeKiTyVars -- In (forall (a :: Maybe e). a -> b) we have -- 'a' is bound by the forall @@ -1731,7 +1735,8 @@ extract_hs_tv_bndrs tvs ((body_t_set `minusOccSet` locals) `unionOccSets` acc_t_set) (filterOut ((`elemOccSet` locals) . rdrNameOcc . unLoc) (bndr_kvs ++ body_all) ++ acc_all) } -extract_tv :: TypeOrKind -> Located RdrName -> FreeKiTyVars -> RnM FreeKiTyVars +extract_tv :: TypeOrKind -> Located RdrName -> FreeKiTyVars + -> RnM FreeKiTyVars extract_tv t_or_k ltv@(L _ tv) acc | isRdrTyVar tv = case acc of FKTV kvs k_set tvs t_set all diff --git a/compiler/rename/RnUtils.hs b/compiler/rename/RnUtils.hs index 85977d6073..7b2f74f1da 100644 --- a/compiler/rename/RnUtils.hs +++ b/compiler/rename/RnUtils.hs @@ -369,7 +369,7 @@ data HsDocContext | TypBrCtx | HsTypeCtx | GHCiCtx - | SpliceTypeCtx (LHsType RdrName) + | SpliceTypeCtx (LHsType GhcPs) | ClassInstanceCtx | VectDeclCtx (Located RdrName) | GenericCtx SDoc -- Maybe we want to use this more! |