diff options
65 files changed, 962 insertions, 649 deletions
diff --git a/compiler/deSugar/Check.hs b/compiler/deSugar/Check.hs index 4a8a18d77c..57eb020815 100644 --- a/compiler/deSugar/Check.hs +++ b/compiler/deSugar/Check.hs @@ -568,7 +568,7 @@ translatePat fam_insts pat = case pat of -- Note [Translating As Patterns] ps <- translatePat fam_insts (unLoc p) let [e] = map vaToPmExpr (coercePatVec ps) - g = PmGrd [PmVar (unLoc lid)] e + g = PmGrd [PmVar (unLocEmb lid)] e return (ps ++ [g]) SigPatOut p _ty -> translatePat fam_insts (unLoc p) @@ -1042,7 +1042,7 @@ mkPmId ty = getUniqueM >>= \unique -> mkPmId2Forms :: Type -> DsM (Pattern, LHsExpr Id) mkPmId2Forms ty = do x <- mkPmId ty - return (PmVar x, noLoc (HsVar (noLoc x))) + return (PmVar x, noLoc (HsVar (noEmb x))) -- ---------------------------------------------------------------------------- -- * Converting between Value Abstractions, Patterns and PmExpr diff --git a/compiler/deSugar/Coverage.hs b/compiler/deSugar/Coverage.hs index d42b6b0767..98f64d9bd0 100644 --- a/compiler/deSugar/Coverage.hs +++ b/compiler/deSugar/Coverage.hs @@ -508,7 +508,7 @@ addBinTickLHsExpr boxLabel (L pos e0) -- in the addTickLHsExpr family of functions.) addTickHsExpr :: HsExpr Id -> TM (HsExpr Id) -addTickHsExpr e@(HsVar (L _ id)) = do freeVar id; return e +addTickHsExpr e@(HsVar (L _ id)) = do freeVar $ unEmb id; return e addTickHsExpr (HsUnboundVar {}) = panic "addTickHsExpr.HsUnboundVar" addTickHsExpr e@(HsConLikeOut con) | Just id <- conLikeWrapId_maybe con = do freeVar id; return e diff --git a/compiler/deSugar/Desugar.hs b/compiler/deSugar/Desugar.hs index d5931d16e5..c74189af7a 100644 --- a/compiler/deSugar/Desugar.hs +++ b/compiler/deSugar/Desugar.hs @@ -547,10 +547,10 @@ dsVect :: LVectDecl Id -> DsM CoreVect dsVect (L loc (HsVect _ (L _ v) rhs)) = putSrcSpanDs loc $ do { rhs' <- dsLExpr rhs - ; return $ Vect v rhs' + ; return $ Vect (unEmb v) rhs' } dsVect (L _loc (HsNoVect _ (L _ v))) - = return $ NoVect v + = return $ NoVect $ unEmb v dsVect (L _loc (HsVectTypeOut isScalar tycon rhs_tycon)) = return $ VectType isScalar tycon' rhs_tycon where diff --git a/compiler/deSugar/DsArrows.hs b/compiler/deSugar/DsArrows.hs index f686b68947..7a576b564b 100644 --- a/compiler/deSugar/DsArrows.hs +++ b/compiler/deSugar/DsArrows.hs @@ -1187,7 +1187,7 @@ collectl (L _ pat) bndrs go (WildPat _) = bndrs go (LazyPat pat) = collectl pat bndrs go (BangPat pat) = collectl pat bndrs - go (AsPat (L _ a) pat) = a : collectl pat bndrs + go (AsPat (L _ a) pat) = unEmb a : collectl pat bndrs go (ParPat pat) = collectl pat bndrs go (ListPat pats _ _) = foldr collectl bndrs pats diff --git a/compiler/deSugar/DsExpr.hs b/compiler/deSugar/DsExpr.hs index 28254c93b4..f570b46b3f 100644 --- a/compiler/deSugar/DsExpr.hs +++ b/compiler/deSugar/DsExpr.hs @@ -254,7 +254,7 @@ dsLExprNoLP (L loc e) dsExpr :: HsExpr Id -> DsM CoreExpr dsExpr (HsPar e) = dsLExpr e dsExpr (ExprWithTySigOut e _) = dsLExpr e -dsExpr (HsVar (L _ var)) = return (varToCoreExpr var) +dsExpr (HsVar (L _ var)) = return (varToCoreExpr $ unEmb var) -- See Note [Desugaring vars] dsExpr (HsUnboundVar {}) = panic "dsExpr: HsUnboundVar" -- Typechecker eliminates them dsExpr (HsConLikeOut con) = return (dsConLike con) diff --git a/compiler/deSugar/DsGRHSs.hs b/compiler/deSugar/DsGRHSs.hs index 0a66bd0bb8..ea4c439a6a 100644 --- a/compiler/deSugar/DsGRHSs.hs +++ b/compiler/deSugar/DsGRHSs.hs @@ -134,8 +134,8 @@ isTrueLHsExpr :: LHsExpr Id -> Maybe (CoreExpr -> DsM CoreExpr) -- * Trivial wappings of these -- The arguments to Just are any HsTicks that we have found, -- because we still want to tick then, even it they are always evaluated. -isTrueLHsExpr (L _ (HsVar (L _ v))) | v `hasKey` otherwiseIdKey - || v `hasKey` getUnique trueDataConId +isTrueLHsExpr (L _ (HsVar (L _ v))) | unEmb v `hasKey` otherwiseIdKey + || unEmb v `hasKey` getUnique trueDataConId = Just return -- trueDataConId doesn't have the same unique as trueDataCon isTrueLHsExpr (L _ (HsConLikeOut con)) | con `hasKey` getUnique trueDataCon = Just return diff --git a/compiler/deSugar/DsMeta.hs b/compiler/deSugar/DsMeta.hs index 78804746d4..a8a1a44186 100644 --- a/compiler/deSugar/DsMeta.hs +++ b/compiler/deSugar/DsMeta.hs @@ -74,13 +74,13 @@ dsBracket brack splices where new_bit = mkNameEnv [(n, DsSplice (unLoc e)) | PendingTcSplice n e <- splices] - do_brack (VarBr _ n) = do { MkC e1 <- lookupOcc n ; return e1 } - do_brack (ExpBr e) = do { MkC e1 <- repLE e ; return e1 } - do_brack (PatBr p) = do { MkC p1 <- repTopP p ; return p1 } - do_brack (TypBr t) = do { MkC t1 <- repLTy t ; return t1 } - do_brack (DecBrG gp) = do { MkC ds1 <- repTopDs gp ; return ds1 } + do_brack (VarBr _ n) = do { MkC e1 <- lookupLEOcc n ; return e1 } + do_brack (ExpBr e) = do { MkC e1 <- repLE e ; return e1 } + do_brack (PatBr p) = do { MkC p1 <- repTopP p ; return p1 } + do_brack (TypBr t) = do { MkC t1 <- repLTy t ; return t1 } + do_brack (DecBrG gp) = do { MkC ds1 <- repTopDs gp ; return ds1 } do_brack (DecBrL _) = panic "dsBracket: unexpected DecBrL" - do_brack (TExpBr e) = do { MkC e1 <- repLE e ; return e1 } + do_brack (TExpBr e) = do { MkC e1 <- repLE e ; return e1 } {- -------------- Examples -------------------- @@ -299,7 +299,7 @@ repTyClD (L loc (ClassDecl { tcdCtxt = cxt, tcdLName = cls, ------------------------- repRoleD :: LRoleAnnotDecl Name -> DsM (SrcSpan, Core TH.DecQ) repRoleD (L loc (RoleAnnotDecl tycon roles)) - = do { tycon1 <- lookupLOcc tycon + = do { tycon1 <- lookupLEOcc tycon ; roles1 <- mapM repRole roles ; roles2 <- coreList roleTyConName roles1 ; dec <- repRoleAnnotD tycon1 roles2 @@ -568,7 +568,7 @@ repFixD (L loc (FixitySig names (Fixity _ prec dir))) InfixR -> infixRDName InfixN -> infixNDName ; let do_one name - = do { MkC name' <- lookupLOcc name + = do { MkC name' <- lookupLEOcc name ; dec <- rep2 rep_fn [prec', name'] ; return (loc,dec) } ; mapM do_one names } @@ -611,7 +611,7 @@ repAnnD (L loc (HsAnnotation _ ann_prov (L _ exp))) repAnnProv :: AnnProvenance Name -> DsM (Core TH.AnnTarget) repAnnProv (ValueAnnProvenance (L _ n)) - = do { MkC n' <- globalVar n -- ANNs are allowed only at top-level + = do { MkC n' <- globalVar $ unEmb n -- ANNs are allowed only at top-level ; rep2 valueAnnotationName [ n' ] } repAnnProv (TypeAnnProvenance (L _ n)) = do { MkC n' <- globalVar n @@ -740,32 +740,32 @@ rep_sig (L _ (SCCFunSig {})) = notHandled "SCC pragmas" empty rep_sig (L loc (CompleteMatchSig _st cls mty)) = rep_complete_sig cls mty loc -rep_ty_sig :: Name -> SrcSpan -> LHsSigType Name -> Located Name +rep_ty_sig :: Name -> SrcSpan -> LHsSigType Name -> LEmbellished Name -> DsM (SrcSpan, Core TH.DecQ) rep_ty_sig mk_sig loc sig_ty nm - = do { nm1 <- lookupLOcc nm + = do { nm1 <- lookupLEOcc nm ; ty1 <- repHsSigType sig_ty ; sig <- repProto mk_sig nm1 ty1 ; return (loc, sig) } -rep_patsyn_ty_sig :: SrcSpan -> LHsSigType Name -> Located Name +rep_patsyn_ty_sig :: SrcSpan -> LHsSigType Name -> LEmbellished Name -> DsM (SrcSpan, Core TH.DecQ) -- represents a pattern synonym type signature; -- see Note [Pattern synonym type signatures and Template Haskell] in Convert rep_patsyn_ty_sig loc sig_ty nm - = do { nm1 <- lookupLOcc nm + = do { nm1 <- lookupLEOcc nm ; ty1 <- repHsPatSynSigType sig_ty ; sig <- repProto patSynSigDName nm1 ty1 ; return (loc, sig) } -rep_wc_ty_sig :: Name -> SrcSpan -> LHsSigWcType Name -> Located Name +rep_wc_ty_sig :: Name -> SrcSpan -> LHsSigWcType Name -> LEmbellished Name -> DsM (SrcSpan, Core TH.DecQ) -- We must special-case the top-level explicit for-all of a TypeSig -- See Note [Scoped type variables in bindings] rep_wc_ty_sig mk_sig loc sig_ty nm | HsIB { hsib_body = hs_ty } <- hswc_body sig_ty , (explicit_tvs, ctxt, ty) <- splitLHsSigmaTy hs_ty - = do { nm1 <- lookupLOcc nm + = do { nm1 <- lookupLEOcc nm ; let rep_in_scope_tv tv = do { name <- lookupBinder (hsLTyVarName tv) ; repTyVarBndrWithKind tv name } ; th_explicit_tvs <- repList tyVarBndrTyConName rep_in_scope_tv @@ -781,12 +781,12 @@ rep_wc_ty_sig mk_sig loc sig_ty nm ; sig <- repProto mk_sig nm1 ty1 ; return (loc, sig) } -rep_inline :: Located Name +rep_inline :: LEmbellished Name -> InlinePragma -- Never defaultInlinePragma -> SrcSpan -> DsM [(SrcSpan, Core TH.DecQ)] rep_inline nm ispec loc - = do { nm1 <- lookupLOcc nm + = do { nm1 <- lookupLEOcc nm ; inline <- repInline $ inl_inline ispec ; rm <- repRuleMatch $ inl_rule ispec ; phases <- repPhases $ inl_act ispec @@ -794,10 +794,11 @@ rep_inline nm ispec loc ; return [(loc, pragma)] } -rep_specialise :: Located Name -> LHsSigType Name -> InlinePragma -> SrcSpan +rep_specialise + :: LEmbellished Name -> LHsSigType Name -> InlinePragma -> SrcSpan -> DsM [(SrcSpan, Core TH.DecQ)] rep_specialise nm ty ispec loc - = do { nm1 <- lookupLOcc nm + = do { nm1 <- lookupLEOcc nm ; ty1 <- repHsSigType ty ; phases <- repPhases $ inl_act ispec ; let inline = inl_inline ispec @@ -833,13 +834,13 @@ repPhases (ActiveAfter _ i) = do { MkC arg <- coreIntLit i ; dataCon' fromPhaseDataConName [arg] } repPhases _ = dataCon allPhasesDataConName -rep_complete_sig :: Located [Located Name] - -> Maybe (Located Name) +rep_complete_sig :: Located [LEmbellished Name] + -> Maybe (LEmbellished Name) -> SrcSpan -> DsM [(SrcSpan, Core TH.DecQ)] rep_complete_sig (L _ cls) mty loc - = do { mty' <- rep_maybe_name mty - ; cls' <- repList nameTyConName lookupLOcc cls + = do { mty' <- rep_maybe_name $ fmap unLEmb mty + ; cls' <- repList nameTyConName lookupLEOcc cls ; sig <- repPragComplete cls' mty' ; return [(loc, sig)] } where @@ -992,15 +993,15 @@ repTy ty@(HsForAllTy {}) = repForall ty repTy ty@(HsQualTy {}) = repForall ty repTy (HsTyVar _ (L _ n)) - | isTvOcc occ = do tv1 <- lookupOcc n + | isTvOcc occ = do tv1 <- lookupOcc $ unEmb n repTvar tv1 - | isDataOcc occ = do tc1 <- lookupOcc n + | isDataOcc occ = do tc1 <- lookupOcc $ unEmb n repPromotedDataCon tc1 - | n == eqTyConName = repTequality - | otherwise = do tc1 <- lookupOcc n + | unEmb n == eqTyConName = repTequality + | otherwise = do tc1 <- lookupOcc $ unEmb n repNamedTyCon tc1 where - occ = nameOccName n + occ = nameOccName $ unEmb n repTy (HsAppTy f a) = do f1 <- repLTy f @@ -1018,7 +1019,7 @@ repTy (HsListTy t) = do repTy (HsPArrTy t) = do t1 <- repLTy t tcon <- repTy (HsTyVar NotPromoted - (noLoc (tyConName parrTyCon))) + (noEmb (tyConName parrTyCon))) repTapp tcon t1 repTy (HsTupleTy HsUnboxedTuple tys) = do tys1 <- repLTys tys @@ -1090,10 +1091,10 @@ repNonArrowLKind (L _ ki) = repNonArrowKind ki repNonArrowKind :: HsKind Name -> DsM (Core TH.Kind) repNonArrowKind (HsTyVar _ (L _ name)) - | isLiftedTypeKindTyConName name = repKStar - | name `hasKey` constraintKindTyConKey = repKConstraint - | isTvOcc (nameOccName name) = lookupOcc name >>= repKVar - | otherwise = lookupOcc name >>= repKCon + | isLiftedTypeKindTyConName $ unEmb name = repKStar + | unEmb name `hasKey` constraintKindTyConKey = repKConstraint + | isTvOcc (nameOccName $ unEmb name) = lookupOcc (unEmb name) >>= repKVar + | otherwise = lookupOcc (unEmb name) >>= repKCon repNonArrowKind (HsAppTy f a) = do { f' <- repLKind f ; a' <- repLKind a ; repKApp f' a' @@ -1150,18 +1151,18 @@ repLE (L loc e) = putSrcSpanDs loc (repE e) repE :: HsExpr Name -> DsM (Core TH.ExpQ) repE (HsVar (L _ x)) = - do { mb_val <- dsLookupMetaEnv x + do { mb_val <- dsLookupMetaEnv(unEmb x) ; case mb_val of - Nothing -> do { str <- globalVar x - ; repVarOrCon x str } - Just (DsBound y) -> repVarOrCon x (coreVar y) + Nothing -> do { str <- globalVar (unEmb x) + ; repVarOrCon (unEmb x) str } + Just (DsBound y) -> repVarOrCon (unEmb x) (coreVar y) Just (DsSplice e) -> do { e' <- dsExpr e ; return (MkC e') } } repE e@(HsIPVar _) = notHandled "Implicit parameters" (ppr e) repE e@(HsOverLabel{}) = notHandled "Overloaded labels" (ppr e) repE e@(HsRecFld f) = case f of - Unambiguous _ x -> repE (HsVar (noLoc x)) + Unambiguous _ x -> repE (HsVar (noEmb x)) Ambiguous{} -> notHandled "Ambiguous record selectors" (ppr e) -- Remember, we're desugaring renamer output here, so @@ -1506,7 +1507,7 @@ rep_bind (L loc (PatSynBind (PSB { psb_id = syn , psb_args = args , psb_def = pat , psb_dir = dir }))) - = do { syn' <- lookupLBinder syn + = do { syn' <- lookupLBinder $ unLEmb syn ; dir' <- repPatSynDir dir ; ss <- mkGenArgSyms args ; patSynD' <- addBinds ss ( @@ -1637,7 +1638,8 @@ repP (LitPat l) = do { l2 <- repLiteral l; repPlit l2 } repP (VarPat (L _ x)) = do { x' <- lookupBinder x; repPvar x' } repP (LazyPat p) = do { p1 <- repLP p; repPtilde p1 } repP (BangPat p) = do { p1 <- repLP p; repPbang p1 } -repP (AsPat x p) = do { x' <- lookupLBinder x; p1 <- repLP p; repPaspat x' p1 } +repP (AsPat x p) = do { x' <- lookupLEBinder x + ; p1 <- repLP p; repPaspat x' p1 } repP (ParPat p) = repLP p repP (ListPat ps _ Nothing) = do { qs <- repLPs ps; repPlist qs } repP (ListPat ps ty1 (Just (_,e))) = do { p <- repP (ListPat ps ty1 Nothing); e' <- repE (syn_expr e); repPview e' p} @@ -1714,6 +1716,9 @@ addBinds bs m = dsExtendMetaEnv (mkNameEnv [(n,DsBound id) | (n,id) <- bs]) m -- Look up a locally bound name -- +lookupLEBinder :: LEmbellished Name -> DsM (Core TH.Name) +lookupLEBinder (L _ n) = lookupBinder $ unEmb n + lookupLBinder :: Located Name -> DsM (Core TH.Name) lookupLBinder (L _ n) = lookupBinder n @@ -1729,6 +1734,9 @@ lookupBinder = lookupOcc -- * If it is a global name, generate the "original name" representation (ie, -- the <module>:<name> form) for the associated entity -- +lookupLEOcc :: LEmbellished Name -> DsM (Core TH.Name) +lookupLEOcc (L _ n) = lookupOcc $ unEmb n + lookupLOcc :: Located Name -> DsM (Core TH.Name) -- Lookup an occurrence; it can't be a splice. -- Use the in-scope bindings if they exist @@ -2170,19 +2178,19 @@ repProto mk_sig (MkC s) (MkC ty) = rep2 mk_sig [s, ty] repCtxt :: Core [TH.PredQ] -> DsM (Core TH.CxtQ) repCtxt (MkC tys) = rep2 cxtName [tys] -repDataCon :: Located Name +repDataCon :: LEmbellished Name -> HsConDeclDetails Name -> DsM (Core TH.ConQ) repDataCon con details - = do con' <- lookupLOcc con -- See Note [Binders and occurrences] + = do con' <- lookupLEOcc con -- See Note [Binders and occurrences] repConstr details Nothing [con'] -repGadtDataCons :: [Located Name] +repGadtDataCons :: [LEmbellished Name] -> HsConDeclDetails Name -> LHsType Name -> DsM (Core TH.ConQ) repGadtDataCons cons details res_ty - = do cons' <- mapM lookupLOcc cons -- See Note [Binders and occurrences] + = do cons' <- mapM lookupLEOcc cons -- See Note [Binders and occurrences] repConstr details (Just res_ty) cons' -- Invariant: diff --git a/compiler/deSugar/DsUtils.hs b/compiler/deSugar/DsUtils.hs index 165130aa94..adfa3c3545 100644 --- a/compiler/deSugar/DsUtils.hs +++ b/compiler/deSugar/DsUtils.hs @@ -120,7 +120,7 @@ selectMatchVar (LazyPat pat) = selectMatchVar (unLoc pat) selectMatchVar (ParPat pat) = selectMatchVar (unLoc pat) selectMatchVar (VarPat var) = return (localiseId (unLoc var)) -- Note [Localise pattern binders] -selectMatchVar (AsPat var _) = return (unLoc var) +selectMatchVar (AsPat var _) = return (unLocEmb var) selectMatchVar other_pat = newSysLocalDsNoLP (hsPatType other_pat) -- OK, better make up one... diff --git a/compiler/deSugar/Match.hs b/compiler/deSugar/Match.hs index 840a5fe36b..045c5ee8c2 100644 --- a/compiler/deSugar/Match.hs +++ b/compiler/deSugar/Match.hs @@ -430,7 +430,7 @@ tidy1 v (VarPat (L _ var)) -- = case v of { p -> let x=v in mr[] } tidy1 v (AsPat (L _ var) pat) = do { (wrap, pat') <- tidy1 v (unLoc pat) - ; return (wrapBind var v . wrap, pat') } + ; return (wrapBind (unEmb var) v . wrap, pat') } {- now, here we handle lazy patterns: tidy1 v ~p bs = (v, v1 = case v of p -> v1 : diff --git a/compiler/deSugar/PmExpr.hs b/compiler/deSugar/PmExpr.hs index 8c3df9689e..f9d0c55dfd 100644 --- a/compiler/deSugar/PmExpr.hs +++ b/compiler/deSugar/PmExpr.hs @@ -234,7 +234,7 @@ lhsExprToPmExpr (L _ e) = hsExprToPmExpr e hsExprToPmExpr :: HsExpr Id -> PmExpr -hsExprToPmExpr (HsVar x) = PmExprVar (idName (unLoc x)) +hsExprToPmExpr (HsVar x) = PmExprVar (idName (unEmb $ unLoc x)) hsExprToPmExpr (HsConLikeOut c) = PmExprVar (conLikeName c) hsExprToPmExpr (HsOverLit olit) = PmExprLit (PmOLit False olit) hsExprToPmExpr (HsLit lit) = PmExprLit (PmSLit lit) diff --git a/compiler/ghc.cabal.in b/compiler/ghc.cabal.in index f3d6711f89..c91d0af334 100644 --- a/compiler/ghc.cabal.in +++ b/compiler/ghc.cabal.in @@ -310,6 +310,7 @@ Library HsImpExp HsLit PlaceHolder + HsEmbellished HsPat HsSyn HsTypes diff --git a/compiler/ghc.mk b/compiler/ghc.mk index ce41eca052..1018eac42f 100644 --- a/compiler/ghc.mk +++ b/compiler/ghc.mk @@ -481,6 +481,7 @@ compiler_stage2_dll0_MODULES = \ HsImpExp \ HsLit \ PlaceHolder \ + HsEmbellished \ PmExpr \ HsPat \ HsSyn \ diff --git a/compiler/hsSyn/Convert.hs b/compiler/hsSyn/Convert.hs index 7e786bd2e6..1d672b2bc2 100644 --- a/compiler/hsSyn/Convert.hs +++ b/compiler/hsSyn/Convert.hs @@ -165,14 +165,14 @@ cvtDec (TH.FunD nm cls) cvtDec (TH.SigD nm typ) = do { nm' <- vNameL nm ; ty' <- cvtType typ - ; returnJustL $ Hs.SigD (TypeSig [nm'] (mkLHsSigWcType ty')) } + ; returnJustL $ Hs.SigD (TypeSig [lEmb nm'] (mkLHsSigWcType ty')) } cvtDec (TH.InfixD fx nm) -- Fixity signatures are allowed for variables, constructors, and types -- the renamer automatically looks for types during renaming, even when -- the RdrName says it's a variable or a constructor. So, just assume -- it's a variable or constructor and proceed. - = do { nm' <- vcNameL nm + = do { nm' <- vcNameLE nm ; returnJustL (Hs.SigD (FixSig (FixitySig [nm'] (cvtFixity fx)))) } cvtDec (PragmaD prag) @@ -341,7 +341,7 @@ cvtDec (ClosedTypeFamilyD head eqns) cvtDec (TH.RoleAnnotD tc roles) = do { tc' <- tconNameL tc ; let roles' = map (noLoc . cvtRole) roles - ; returnJustL $ Hs.RoleAnnotD (RoleAnnotDecl tc' roles') } + ; returnJustL $ Hs.RoleAnnotD (RoleAnnotDecl (lEmb tc') roles') } cvtDec (TH.StandaloneDerivD ds cxt ty) = do { cxt' <- cvtContext cxt @@ -355,7 +355,7 @@ cvtDec (TH.StandaloneDerivD ds cxt ty) cvtDec (TH.DefaultSigD nm typ) = do { nm' <- vNameL nm ; ty' <- cvtType typ - ; returnJustL $ Hs.SigD $ ClassOpSig True [nm'] (mkLHsSigType ty') } + ; returnJustL $ Hs.SigD $ ClassOpSig True [lEmb nm'] (mkLHsSigType ty') } cvtDec (TH.PatSynD nm args dir pat) = do { nm' <- cNameL nm @@ -363,7 +363,7 @@ cvtDec (TH.PatSynD nm args dir pat) ; dir' <- cvtDir nm' dir ; pat' <- cvtPat pat ; returnJustL $ Hs.ValD $ PatSynBind $ - PSB nm' placeHolderType args' pat' dir' } + PSB (lEmb nm') placeHolderType args' pat' dir' } where cvtArgs (TH.PrefixPatSyn args) = Hs.PrefixPatSyn <$> mapM vNameL args cvtArgs (TH.InfixPatSyn a1 a2) = Hs.InfixPatSyn <$> vNameL a1 <*> vNameL a2 @@ -379,7 +379,7 @@ cvtDec (TH.PatSynD nm args dir pat) ; return $ ExplicitBidirectional $ mkMatchGroup FromSource ms } cvtDec (TH.PatSynSigD nm ty) - = do { nm' <- cNameL nm + = do { nm' <- cNameLE nm ; ty' <- cvtPatSynSigTy ty ; returnJustL $ Hs.SigD $ PatSynSig [nm'] (mkLHsSigType ty') } @@ -485,20 +485,20 @@ mkBadDecMsg doc bads cvtConstr :: TH.Con -> CvtM (LConDecl RdrName) cvtConstr (NormalC c strtys) - = do { c' <- cNameL c + = do { c' <- cNameLE c ; cxt' <- returnL [] ; tys' <- mapM cvt_arg strtys ; returnL $ mkConDeclH98 c' Nothing cxt' (PrefixCon tys') } cvtConstr (RecC c varstrtys) - = do { c' <- cNameL c + = do { c' <- cNameLE c ; cxt' <- returnL [] ; args' <- mapM cvt_id_arg varstrtys ; returnL $ mkConDeclH98 c' Nothing cxt' (RecCon (noLoc args')) } cvtConstr (InfixC st1 c st2) - = do { c' <- cNameL c + = do { c' <- cNameLE c ; cxt' <- returnL [] ; st1' <- cvt_arg st1 ; st2' <- cvt_arg st2 @@ -527,14 +527,14 @@ cvtConstr (ForallC tvs ctxt con) (con_cxt con'))) } } cvtConstr (GadtC c strtys ty) - = do { c' <- mapM cNameL c + = do { c' <- mapM cNameLE c ; args <- mapM cvt_arg strtys ; L _ ty' <- cvtType ty ; c_ty <- mk_arr_apps args ty' ; returnL $ mkGadtDecl c' (mkLHsSigType c_ty)} cvtConstr (RecGadtC c varstrtys ty) - = do { c' <- mapM cNameL c + = do { c' <- mapM cNameLE c ; ty' <- cvtType ty ; rec_flds <- mapM cvt_id_arg varstrtys ; let rec_ty = noLoc (HsFunTy (noLoc $ HsRecTy rec_flds) ty') @@ -563,7 +563,7 @@ cvt_id_arg (i, str, ty) ; ty' <- cvt_arg (str,ty) ; return $ noLoc (ConDeclField { cd_fld_names - = [L li $ FieldOcc (L li i') PlaceHolder] + = [L li $ FieldOcc (L li $ EName i') PlaceHolder] , cd_fld_type = ty' , cd_fld_doc = Nothing}) } @@ -646,7 +646,7 @@ cvtPragmaD (InlineP nm inline rm phases) , inl_rule = cvtRuleMatch rm , inl_act = cvtPhases phases dflt , inl_sat = Nothing } - ; returnJustL $ Hs.SigD $ InlineSig nm' ip } + ; returnJustL $ Hs.SigD $ InlineSig (lEmb nm') ip } cvtPragmaD (SpecialiseP nm ty inline phases) = do { nm' <- vNameL nm @@ -664,7 +664,7 @@ cvtPragmaD (SpecialiseP nm ty inline phases) , inl_rule = Hs.FunLike , inl_act = cvtPhases phases dflt , inl_sat = Nothing } - ; returnJustL $ Hs.SigD $ SpecSig nm' [mkLHsSigType ty'] ip } + ; returnJustL $ Hs.SigD $ SpecSig (lEmb nm') [mkLHsSigType ty'] ip } cvtPragmaD (SpecialiseInstP ty) = do { ty' <- cvtType ty @@ -693,7 +693,7 @@ cvtPragmaD (AnnP target exp) return (TypeAnnProvenance (noLoc n')) ValueAnnotation n -> do n' <- vcName n - return (ValueAnnProvenance (noLoc n')) + return (ValueAnnProvenance (noEmb n')) ; returnJustL $ Hs.AnnD $ HsAnnotation (SourceText "{-# ANN") target' exp' } @@ -703,8 +703,8 @@ cvtPragmaD (LineP line file) ; return Nothing } cvtPragmaD (CompleteP cls mty) - = do { cls' <- noLoc <$> mapM cNameL cls - ; mty' <- traverse tconNameL mty + = do { cls' <- noLoc <$> mapM cNameLE cls + ; mty' <- traverse tconNameLE mty ; returnJustL $ Hs.SigD $ CompleteMatchSig NoSourceText cls' mty' } @@ -768,8 +768,8 @@ cvtClause ctxt (Clause ps body wheres) cvtl :: TH.Exp -> CvtM (LHsExpr RdrName) cvtl e = wrapL (cvt e) where - cvt (VarE s) = do { s' <- vName s; return $ HsVar (noLoc s') } - cvt (ConE s) = do { s' <- cName s; return $ HsVar (noLoc s') } + cvt (VarE s) = do { s' <- vName s; return $ HsVar (noEmb s') } + cvt (ConE s) = do { s' <- cName s; return $ HsVar (noEmb s') } cvt (LitE l) | overloadedLit l = do { l' <- cvtOverLit l; return $ HsOverLit l' } | otherwise = do { l' <- cvtLit l; return $ HsLit l' } @@ -848,7 +848,7 @@ cvtl e = wrapL (cvt e) cvt (SigE e t) = do { e' <- cvtl e; t' <- cvtType t ; return $ ExprWithTySig e' (mkLHsSigWcType t') } cvt (RecConE c flds) = do { c' <- cNameL c - ; flds' <- mapM (cvtFld (mkFieldOcc . noLoc)) flds + ; flds' <- mapM (cvtFld (mkFieldOcc . noEmb)) flds ; return $ mkRdrRecordCon c' (HsRecFields flds' Nothing) } cvt (RecUpdE e flds) = do { e' <- cvtl e ; flds' @@ -856,7 +856,7 @@ cvtl e = wrapL (cvt e) flds ; return $ mkRdrRecordUpd e' flds' } cvt (StaticE e) = fmap (HsStatic placeHolderNames) $ cvtl e - cvt (UnboundVarE s) = do { s' <- vName s; return $ HsVar (noLoc s') } + cvt (UnboundVarE s) = do { s' <- vName s; return $ HsVar (noEmb s') } {- Note [Dropping constructors] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -1095,7 +1095,8 @@ cvtp (ParensP p) = do { p' <- cvtPat p; _ -> return $ ParPat p' } cvtp (TildeP p) = do { p' <- cvtPat p; return $ LazyPat p' } cvtp (BangP p) = do { p' <- cvtPat p; return $ BangPat p' } -cvtp (TH.AsP s p) = do { s' <- vNameL s; p' <- cvtPat p; return $ AsPat s' p' } +cvtp (TH.AsP s p) = do { s' <- vNameL s + ; p' <- cvtPat p; return $ AsPat (lEmb s') p' } cvtp TH.WildP = return $ WildPat placeHolderType cvtp (RecP c fs) = do { c' <- cNameL c; fs' <- mapM cvtPatFld fs ; return $ ConPatIn c' @@ -1111,7 +1112,7 @@ cvtPatFld :: (TH.Name, TH.Pat) -> CvtM (LHsRecField RdrName (LPat RdrName)) cvtPatFld (s,p) = do { L ls s' <- vNameL s; p' <- cvtPat p ; return (noLoc $ HsRecField { hsRecFieldLbl - = L ls $ mkFieldOcc (L ls s') + = L ls $ mkFieldOcc (L ls $ EName s') , hsRecFieldArg = p' , hsRecPun = False}) } @@ -1190,13 +1191,13 @@ cvtTypeKind ty_str ty -> failWith (ptext (sLit ("Illegal 1-tuple " ++ ty_str ++ " constructor"))) | otherwise -> mk_apps (HsTyVar NotPromoted - (noLoc (getRdrName (tupleTyCon Boxed n)))) tys' + (noEmb (getRdrName (tupleTyCon Boxed n)))) tys' UnboxedTupleT n | length tys' == n -- Saturated -> returnL (HsTupleTy HsUnboxedTuple tys') | otherwise -> mk_apps (HsTyVar NotPromoted - (noLoc (getRdrName (tupleTyCon Unboxed n)))) tys' + (noEmb (getRdrName (tupleTyCon Unboxed n)))) tys' UnboxedSumT n | n < 2 -> failWith $ @@ -1206,22 +1207,22 @@ cvtTypeKind ty_str ty | length tys' == n -- Saturated -> returnL (HsSumTy tys') | otherwise - -> mk_apps (HsTyVar NotPromoted (noLoc (getRdrName (sumTyCon n)))) + -> mk_apps (HsTyVar NotPromoted (noEmb (getRdrName (sumTyCon n)))) tys' ArrowT | [x',y'] <- tys' -> returnL (HsFunTy x' y') | otherwise -> - mk_apps (HsTyVar NotPromoted (noLoc (getRdrName funTyCon))) + mk_apps (HsTyVar NotPromoted (noEmb (getRdrName funTyCon))) tys' ListT | [x'] <- tys' -> returnL (HsListTy x') | otherwise -> - mk_apps (HsTyVar NotPromoted (noLoc (getRdrName listTyCon))) + mk_apps (HsTyVar NotPromoted (noEmb (getRdrName listTyCon))) tys' VarT nm -> do { nm' <- tNameL nm - ; mk_apps (HsTyVar NotPromoted nm') tys' } + ; mk_apps (HsTyVar NotPromoted (lEmb nm')) tys' } ConT nm -> do { nm' <- tconName nm - ; mk_apps (HsTyVar NotPromoted (noLoc nm')) tys' } + ; mk_apps (HsTyVar NotPromoted (noEmb nm')) tys' } ForallT tvs cxt ty | null tys' @@ -1250,7 +1251,7 @@ cvtTypeKind ty_str ty -> do { s' <- tconName s ; t1' <- cvtType t1 ; t2' <- cvtType t2 - ; mk_apps (HsTyVar NotPromoted (noLoc s')) [t1', t2'] + ; mk_apps (HsTyVar NotPromoted (noEmb s')) [t1', t2'] } UInfixT t1 s t2 @@ -1266,7 +1267,7 @@ cvtTypeKind ty_str ty } PromotedT nm -> do { nm' <- cName nm - ; mk_apps (HsTyVar NotPromoted (noLoc nm')) tys' } + ; mk_apps (HsTyVar NotPromoted (noEmb nm')) tys' } -- Promoted data constructor; hence cName PromotedTupleT n @@ -1287,22 +1288,22 @@ cvtTypeKind ty_str ty | [ty1, L _ (HsExplicitListTy ip _ tys2)] <- tys' -> returnL (HsExplicitListTy ip placeHolderKind (ty1:tys2)) | otherwise - -> mk_apps (HsTyVar NotPromoted (noLoc (getRdrName consDataCon))) + -> mk_apps (HsTyVar NotPromoted (noEmb (getRdrName consDataCon))) tys' StarT - -> returnL (HsTyVar NotPromoted (noLoc + -> returnL (HsTyVar NotPromoted (noEmb (getRdrName liftedTypeKindTyCon))) ConstraintT -> returnL (HsTyVar NotPromoted - (noLoc (getRdrName constraintKindTyCon))) + (noEmb (getRdrName constraintKindTyCon))) EqualityT | [x',y'] <- tys' -> returnL (HsEqTy x' y') | otherwise -> mk_apps (HsTyVar NotPromoted - (noLoc (getRdrName eqPrimTyCon))) tys' + (noEmb (getRdrName eqPrimTyCon))) tys' _ -> failWith (ptext (sLit ("Malformed " ++ ty_str)) <+> text (show ty)) } @@ -1345,7 +1346,7 @@ cvtTyLit (TH.StrTyLit s) = HsStrTy NoSourceText (fsLit s) cvtOpAppT :: LHsType RdrName -> RdrName -> LHsType RdrName -> LHsType RdrName cvtOpAppT t1@(L loc1 _) op t2@(L loc2 _) = L (combineSrcSpans loc1 loc2) $ - HsAppsTy (t1' ++ [noLoc $ HsAppInfix (noLoc op)] ++ t2') + HsAppsTy (t1' ++ [noLoc $ HsAppInfix (noEmb op)] ++ t2') where t1' | L _ (HsAppsTy t1s) <- t1 = t1s @@ -1492,7 +1493,8 @@ mkHsQualTy ctxt loc ctxt' ty -------------------------------------------------------------------- -- variable names -vNameL, cNameL, vcNameL, tNameL, tconNameL :: TH.Name -> CvtM (Located RdrName) +cNameLE, vcNameLE, tconNameLE :: TH.Name -> CvtM (LEmbellished RdrName) +vNameL, cNameL, tNameL, tconNameL :: TH.Name -> CvtM (Located RdrName) vName, cName, vcName, tName, tconName :: TH.Name -> CvtM RdrName -- Variable names @@ -1500,11 +1502,12 @@ vNameL n = wrapL (vName n) vName n = cvtName OccName.varName n -- Constructor function names; this is Haskell source, hence srcDataName +cNameLE n = wrapL (cName n >>= \nn -> return $ EName nn) cNameL n = wrapL (cName n) cName n = cvtName OccName.dataName n -- Variable *or* constructor names; check by looking at the first char -vcNameL n = wrapL (vcName n) +vcNameLE n = wrapL (vcName n >>= \nn -> return $ EName nn) vcName n = if isVarName n then vName n else cName n -- Type variable names @@ -1512,6 +1515,7 @@ tNameL n = wrapL (tName n) tName n = cvtName OccName.tvName n -- Type Constructor names +tconNameLE n = wrapL (tconName n >>= \nn -> return $ EName nn) tconNameL n = wrapL (tconName n) tconName n = cvtName OccName.tcClsName n diff --git a/compiler/hsSyn/HsBinds.hs b/compiler/hsSyn/HsBinds.hs index 1f38c387df..60a460aa81 100644 --- a/compiler/hsSyn/HsBinds.hs +++ b/compiler/hsSyn/HsBinds.hs @@ -24,6 +24,7 @@ import {-# SOURCE #-} HsPat ( LPat ) import PlaceHolder ( PostTc,PostRn,DataId,OutputableBndrId ) import HsTypes +import HsEmbellished import PprCore () import CoreSyn import TcEvidence @@ -292,7 +293,7 @@ data ABExport id -- | Pattern Synonym binding data PatSynBind idL idR - = PSB { psb_id :: Located idL, -- ^ Name of the pattern synonym + = PSB { psb_id :: LEmbellished idL, -- ^ Name of the pattern synonym psb_fvs :: PostRn idR NameSet, -- ^ See Note [Bind free vars] psb_args :: HsPatSynDetails (Located idR), -- ^ Formal parameter names psb_def :: LPat idR, -- ^ Right-hand side @@ -739,7 +740,7 @@ data Sig name -- For details on above see note [Api annotations] in ApiAnnotation TypeSig - [Located name] -- LHS of the signature; e.g. f,g,h :: blah + [LEmbellished name] -- LHS of the signature; e.g. f,g,h :: blah (LHsSigWcType name) -- RHS of the signature; can have wildcards -- | A pattern synonym type signature @@ -751,7 +752,7 @@ data Sig name -- 'ApiAnnotation.AnnDot','ApiAnnotation.AnnDarrow' -- For details on above see note [Api annotations] in ApiAnnotation - | PatSynSig [Located name] (LHsSigType name) + | PatSynSig [LEmbellished name] (LHsSigType name) -- P :: forall a b. Req => Prov => ty -- | A signature for a class method @@ -764,7 +765,7 @@ data Sig name -- -- - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnDefault', -- 'ApiAnnotation.AnnDcolon' - | ClassOpSig Bool [Located name] (LHsSigType name) + | ClassOpSig Bool [LEmbellished name] (LHsSigType name) -- | A type signature in generated code, notably the code -- generated for record selectors. We simply record @@ -795,7 +796,7 @@ data Sig name -- 'ApiAnnotation.AnnClose' -- For details on above see note [Api annotations] in ApiAnnotation - | InlineSig (Located name) -- Function name + | InlineSig (LEmbellished name) -- Function name InlinePragma -- Never defaultInlinePragma -- | A specialisation pragma @@ -810,7 +811,7 @@ data Sig name -- 'ApiAnnotation.AnnDcolon' -- For details on above see note [Api annotations] in ApiAnnotation - | SpecSig (Located name) -- Specialise a function or datatype ... + | SpecSig (LEmbellished name) -- Specialise a function or datatype ... [LHsSigType name] -- ... to these types InlinePragma -- The pragma on SPECIALISE_INLINE form. -- If it's just defaultInlinePragma, then we said @@ -839,7 +840,7 @@ data Sig name -- 'ApiAnnotation.AnnClose' -- For details on above see note [Api annotations] in ApiAnnotation - | MinimalSig SourceText (LBooleanFormula (Located name)) + | MinimalSig SourceText (LBooleanFormula (LEmbellished name)) -- Note [Pragma source text] in BasicTypes -- | A "set cost centre" pragma for declarations @@ -851,9 +852,11 @@ data Sig name -- > {-# SCC funName "cost_centre_name" #-} | SCCFunSig SourceText -- Note [Pragma source text] in BasicTypes - (Located name) -- Function name + (LEmbellished name) -- Function name (Maybe StringLiteral) - | CompleteMatchSig SourceText (Located [Located name]) (Maybe (Located name)) + | CompleteMatchSig SourceText + (Located [LEmbellished name]) + (Maybe (LEmbellished name)) deriving instance (DataId name) => Data (Sig name) @@ -861,7 +864,7 @@ deriving instance (DataId name) => Data (Sig name) type LFixitySig name = Located (FixitySig name) -- | Fixity Signature -data FixitySig name = FixitySig [Located name] Fixity +data FixitySig name = FixitySig [LEmbellished name] Fixity deriving Data -- | Type checker Specialisation Pragmas diff --git a/compiler/hsSyn/HsDecls.hs b/compiler/hsSyn/HsDecls.hs index e3029a23f5..4c29f2331b 100644 --- a/compiler/hsSyn/HsDecls.hs +++ b/compiler/hsSyn/HsDecls.hs @@ -100,6 +100,7 @@ import Coercion import ForeignCall import PlaceHolder ( PostTc,PostRn,PlaceHolder(..),DataId, OutputableBndrId ) import NameSet +import HsEmbellished -- others: import InstEnv @@ -1131,7 +1132,7 @@ type LConDecl name = Located (ConDecl name) -- | data Constructor Declaration data ConDecl name = ConDeclGADT - { con_names :: [Located name] + { con_names :: [LEmbellished name] , con_type :: LHsSigType name -- ^ The type after the ‘::’ , con_doc :: Maybe LHsDocString @@ -1139,7 +1140,7 @@ data ConDecl name } | ConDeclH98 - { con_name :: Located name + { con_name :: LEmbellished name , con_qvars :: Maybe (LHsQTyVars name) -- User-written forall (if any), and its implicit @@ -1163,7 +1164,7 @@ deriving instance (DataId name) => Data (ConDecl name) type HsConDeclDetails name = HsConDetails (LBangType name) (Located [LConDeclField name]) -getConNames :: ConDecl name -> [Located name] +getConNames :: ConDecl name -> [LEmbellished name] getConNames ConDeclH98 {con_name = name} = [name] getConNames ConDeclGADT {con_names = names} = names @@ -1865,7 +1866,7 @@ type LVectDecl name = Located (VectDecl name) data VectDecl name = HsVect SourceText -- Note [Pragma source text] in BasicTypes - (Located name) + (LEmbellished name) (LHsExpr name) -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen', -- 'ApiAnnotation.AnnEqual','ApiAnnotation.AnnClose' @@ -1873,7 +1874,7 @@ data VectDecl name -- For details on above see note [Api annotations] in ApiAnnotation | HsNoVect SourceText -- Note [Pragma source text] in BasicTypes - (Located name) + (LEmbellished name) -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen', -- 'ApiAnnotation.AnnClose' @@ -1881,8 +1882,8 @@ data VectDecl name | HsVectTypeIn -- pre type-checking SourceText -- Note [Pragma source text] in BasicTypes Bool -- 'TRUE' => SCALAR declaration - (Located name) - (Maybe (Located name)) -- 'Nothing' => no right-hand side + (LEmbellished name) + (Maybe (LEmbellished name)) -- 'Nothing' => no right-hand side -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen', -- 'ApiAnnotation.AnnType','ApiAnnotation.AnnClose', -- 'ApiAnnotation.AnnEqual' @@ -1894,7 +1895,7 @@ data VectDecl name (Maybe TyCon) -- 'Nothing' => no right-hand side | HsVectClassIn -- pre type-checking SourceText -- Note [Pragma source text] in BasicTypes - (Located name) + (LEmbellished name) -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnOpen', -- 'ApiAnnotation.AnnClass','ApiAnnotation.AnnClose', @@ -1908,11 +1909,11 @@ data VectDecl name deriving instance (DataId name) => Data (VectDecl name) lvectDeclName :: NamedThing name => LVectDecl name -> Name -lvectDeclName (L _ (HsVect _ (L _ name) _)) = getName name -lvectDeclName (L _ (HsNoVect _ (L _ name))) = getName name -lvectDeclName (L _ (HsVectTypeIn _ _ (L _ name) _)) = getName name +lvectDeclName (L _ (HsVect _ (L _ name) _)) = getName $ unEmb name +lvectDeclName (L _ (HsNoVect _ (L _ name))) = getName $ unEmb name +lvectDeclName (L _ (HsVectTypeIn _ _ (L _ name) _)) = getName $ unEmb name lvectDeclName (L _ (HsVectTypeOut _ tycon _)) = getName tycon -lvectDeclName (L _ (HsVectClassIn _ (L _ name))) = getName name +lvectDeclName (L _ (HsVectClassIn _ (L _ name))) = getName $ unEmb name lvectDeclName (L _ (HsVectClassOut cls)) = getName cls lvectDeclName (L _ (HsVectInstIn _)) = panic "HsDecls.lvectDeclName: HsVectInstIn" @@ -2009,7 +2010,7 @@ data WarnDecls name = Warnings { wd_src :: SourceText type LWarnDecl name = Located (WarnDecl name) -- | Warning pragma Declaration -data WarnDecl name = Warning [Located name] WarningTxt +data WarnDecl name = Warning [LEmbellished name] WarningTxt deriving Data instance OutputableBndr name => Outputable (WarnDecls name) where @@ -2050,7 +2051,7 @@ instance (OutputableBndrId name) => Outputable (AnnDecl name) where = hsep [text "{-#", pprAnnProvenance provenance, pprExpr (unLoc expr), text "#-}"] -- | Annotation Provenance -data AnnProvenance name = ValueAnnProvenance (Located name) +data AnnProvenance name = ValueAnnProvenance (LEmbellished name) | TypeAnnProvenance (Located name) | ModuleAnnProvenance deriving (Data, Functor) @@ -2058,7 +2059,7 @@ deriving instance Foldable AnnProvenance deriving instance Traversable AnnProvenance annProvenanceName_maybe :: AnnProvenance name -> Maybe name -annProvenanceName_maybe (ValueAnnProvenance (L _ name)) = Just name +annProvenanceName_maybe (ValueAnnProvenance (L _ name)) = Just $ unEmb name annProvenanceName_maybe (TypeAnnProvenance (L _ name)) = Just name annProvenanceName_maybe ModuleAnnProvenance = Nothing @@ -2084,7 +2085,7 @@ type LRoleAnnotDecl name = Located (RoleAnnotDecl name) -- top-level declarations -- | Role Annotation Declaration data RoleAnnotDecl name - = RoleAnnotDecl (Located name) -- type constructor + = RoleAnnotDecl (LEmbellished name) -- type constructor [Located (Maybe Role)] -- optional annotations -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnType', -- 'ApiAnnotation.AnnRole' @@ -2101,4 +2102,4 @@ instance OutputableBndr name => Outputable (RoleAnnotDecl name) where pp_role (Just r) = ppr r roleAnnotDeclName :: RoleAnnotDecl name -> name -roleAnnotDeclName (RoleAnnotDecl (L _ name) _) = name +roleAnnotDeclName (RoleAnnotDecl (L _ name) _) = unEmb name diff --git a/compiler/hsSyn/HsEmbellished.hs b/compiler/hsSyn/HsEmbellished.hs new file mode 100644 index 0000000000..9f6c8b39f9 --- /dev/null +++ b/compiler/hsSyn/HsEmbellished.hs @@ -0,0 +1,63 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveTraversable #-} +module HsEmbellished ( + Embellished(..), + LEmbellished, + noEmb, + unEmb, + unLEmb, + unLocEmb, + lEmb, + reEmb, + reLEmb + ) where + +import SrcLoc +import Outputable + +import Data.Data + +-- | An embellished name +-- +-- The parser can read a RdrName with either parens or backquotes around them. +-- This type wraps the name and captures whichever embellishment is present. +data Embellished name + = EName name + | EParens (Located name) + | EBackquotes (Located name) + deriving (Data, Ord, Eq, Functor, Foldable, Traversable) + +type LEmbellished name = Located (Embellished name) + +noEmb :: name -> LEmbellished name +noEmb n = noLoc $ EName n + +unEmb :: Embellished name -> name +unEmb (EName n) = n +unEmb (EParens (L _ n)) = n +unEmb (EBackquotes (L _ n)) = n + +unLEmb :: LEmbellished name -> Located name +unLEmb (L l en) = L l (unEmb en) + +unLocEmb :: LEmbellished name -> name +unLocEmb (L _ en) = unEmb en + +lEmb :: Located name -> LEmbellished name +lEmb (L l n) = L l $ EName n + +reEmb :: Embellished name1 -> name2 -> Embellished name2 +reEmb (EName _) n = EName n +reEmb (EParens (L l _)) n = EParens (L l n) +reEmb (EBackquotes (L l _)) n = EBackquotes (L l n) + +reLEmb :: LEmbellished name1 -> name2 -> LEmbellished name2 +reLEmb (L l e) n = L l (reEmb e n) + +instance (Outputable name) => Outputable (Embellished name) where + pprPrec n en = pprPrec n (unEmb en) + +instance (OutputableBndr name) => OutputableBndr (Embellished name) where + pprPrefixOcc en = pprPrefixOcc (unEmb en) + pprInfixOcc en = pprInfixOcc (unEmb en) diff --git a/compiler/hsSyn/HsExpr.hs b/compiler/hsSyn/HsExpr.hs index 71c408984b..0008827080 100644 --- a/compiler/hsSyn/HsExpr.hs +++ b/compiler/hsSyn/HsExpr.hs @@ -41,6 +41,7 @@ import Util import Outputable import FastString import Type +import HsEmbellished -- libraries: import Data.Data hiding (Fixity(..)) @@ -125,7 +126,7 @@ noSyntaxExpr = SyntaxExpr { syn_expr = HsLit (HsString NoSourceText -- | Make a 'SyntaxExpr Name' (the "rn" is because this is used in the -- renamer), missing its HsWrappers. mkRnSyntaxExpr :: Name -> SyntaxExpr Name -mkRnSyntaxExpr name = SyntaxExpr { syn_expr = HsVar $ noLoc name +mkRnSyntaxExpr name = SyntaxExpr { syn_expr = HsVar $ noLoc $ EName name , syn_arg_wraps = [] , syn_res_wrap = WpHole } -- don't care about filling in syn_arg_wraps because we're clearly @@ -274,7 +275,7 @@ information to use is the GlobalRdrEnv itself. -- | A Haskell expression. data HsExpr id - = HsVar (Located id) -- ^ Variable + = HsVar (LEmbellished id) -- ^ Variable -- See Note [Located RdrNames] @@ -667,12 +668,13 @@ data HsExpr id -- These constructors only appear temporarily in the parser. -- The renamer translates them into the Right Thing. + -- AZ: TODO: Needs to be embellished too, for backquotes | EWildPat -- wildcard -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnAt' -- For details on above see note [Api annotations] in ApiAnnotation - | EAsPat (Located id) -- as pattern + | EAsPat (LEmbellished id) -- as pattern (LHsExpr id) -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnRarrow' @@ -2242,7 +2244,7 @@ data HsBracket id = ExpBr (LHsExpr id) -- [| expr |] | DecBrL [LHsDecl id] -- [d| decls |]; result of parser | DecBrG (HsGroup id) -- [d| decls |]; result of renamer | TypBr (LHsType id) -- [t| type |] - | VarBr Bool id -- True: 'x, False: ''T + | VarBr Bool (LEmbellished id) -- True: 'x, False: ''T -- (The Bool flag is used only in pprHsBracket) | TExpBr (LHsExpr id) -- [|| expr ||] deriving instance (DataId id) => Data (HsBracket id) @@ -2261,9 +2263,9 @@ pprHsBracket (PatBr p) = thBrackets (char 'p') (ppr p) pprHsBracket (DecBrG gp) = thBrackets (char 'd') (ppr gp) pprHsBracket (DecBrL ds) = thBrackets (char 'd') (vcat (map ppr ds)) pprHsBracket (TypBr t) = thBrackets (char 't') (ppr t) -pprHsBracket (VarBr True n) +pprHsBracket (VarBr True (L _ n)) = char '\'' <> pprPrefixOcc n -pprHsBracket (VarBr False n) +pprHsBracket (VarBr False (L _ n)) = text "''" <> pprPrefixOcc n pprHsBracket (TExpBr e) = thTyBrackets (ppr e) diff --git a/compiler/hsSyn/HsPat.hs b/compiler/hsSyn/HsPat.hs index 174e83702e..e3c647a80a 100644 --- a/compiler/hsSyn/HsPat.hs +++ b/compiler/hsSyn/HsPat.hs @@ -45,6 +45,7 @@ import HsBinds import HsLit import PlaceHolder import HsTypes +import HsEmbellished import TcEvidence import BasicTypes -- others: @@ -88,7 +89,7 @@ data Pat id -- For details on above see note [Api annotations] in ApiAnnotation - | AsPat (Located id) (LPat id) -- ^ As pattern + | AsPat (LEmbellished id) (LPat id) -- ^ As pattern -- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnAt' -- For details on above see note [Api annotations] in ApiAnnotation @@ -391,7 +392,7 @@ hsRecFieldSel = fmap selectorFieldOcc . hsRecFieldLbl hsRecFieldId :: HsRecField Id arg -> Located Id hsRecFieldId = hsRecFieldSel -hsRecUpdFieldRdr :: HsRecUpdField id -> Located RdrName +hsRecUpdFieldRdr :: HsRecUpdField id -> LEmbellished RdrName hsRecUpdFieldRdr = fmap rdrNameAmbiguousFieldOcc . hsRecFieldLbl hsRecUpdFieldId :: HsRecField' (AmbiguousFieldOcc Id) arg -> Located Id diff --git a/compiler/hsSyn/HsSyn.hs b/compiler/hsSyn/HsSyn.hs index e7cae91572..4da8cd3b43 100644 --- a/compiler/hsSyn/HsSyn.hs +++ b/compiler/hsSyn/HsSyn.hs @@ -27,6 +27,7 @@ module HsSyn ( module HsUtils, module HsDoc, module PlaceHolder, + module HsEmbellished, Fixity, HsModule(..) @@ -39,6 +40,7 @@ import HsExpr import HsImpExp import HsLit import PlaceHolder +import HsEmbellished import HsPat import HsTypes import BasicTypes ( Fixity, WarningTxt ) diff --git a/compiler/hsSyn/HsTypes.hs b/compiler/hsSyn/HsTypes.hs index 998f8bdedd..0df26582bd 100644 --- a/compiler/hsSyn/HsTypes.hs +++ b/compiler/hsSyn/HsTypes.hs @@ -86,6 +86,7 @@ import BasicTypes import SrcLoc import Outputable import FastString +import HsEmbellished import Maybes( isJust ) import Data.Data hiding ( Fixity, Prefix, Infix ) @@ -434,7 +435,7 @@ data HsType name | HsTyVar Promoted -- whether explicitly promoted, for the pretty -- printer - (Located name) + (LEmbellished name) -- Type variable, type constructor, or data constructor -- see Note [Promotions (HsTyVar)] -- See Note [Located RdrNames] in HsExpr @@ -605,7 +606,7 @@ type LHsAppType name = Located (HsAppType name) -- | Haskell Application Type data HsAppType name - = HsAppInfix (Located name) -- either a symbol or an id in backticks + = HsAppInfix (LEmbellished name) -- either a symbol or an id in backticks | HsAppPrefix (LHsType name) -- anything else, including things like (+) deriving instance (DataId name) => Data (HsAppType name) @@ -884,9 +885,10 @@ hsLTyVarLocNames qtvs = map hsLTyVarLocName (hsQTvExplicit qtvs) -- | Convert a LHsTyVarBndr to an equivalent LHsType. hsLTyVarBndrToType :: LHsTyVarBndr name -> LHsType name hsLTyVarBndrToType = fmap cvt - where cvt (UserTyVar n) = HsTyVar NotPromoted n + where cvt (UserTyVar n) = HsTyVar NotPromoted (lEmb n) cvt (KindedTyVar (L name_loc n) kind) - = HsKindSig (L name_loc (HsTyVar NotPromoted (L name_loc n))) kind + = HsKindSig (L name_loc (HsTyVar NotPromoted (L name_loc $ EName n))) + kind -- | Convert a LHsTyVarBndrs to a list of types. -- Works on *type* variable only, no kind vars. @@ -953,7 +955,7 @@ splitHsFunType (L _ (HsFunTy x y)) splitHsFunType orig_ty@(L _ (HsAppTy t1 t2)) = go t1 [t2] where -- Look for (->) t1 t2, possibly with parenthesisation - go (L _ (HsTyVar _ (L _ fn))) tys | fn == funTyConName + go (L _ (HsTyVar _ (L _ fn))) tys | unEmb fn == funTyConName , [t1,t2] <- tys , (args, res) <- splitHsFunType t2 = (t1:args, res) @@ -983,7 +985,7 @@ getAppsTyHead_maybe tys = case splitHsAppsTy tys of -- element of @non_syms@ followed by the first element of @syms@ followed by -- the next element of @non_syms@, etc. It is guaranteed that the non_syms list -- has one more element than the syms list. -splitHsAppsTy :: [LHsAppType name] -> ([[LHsType name]], [Located name]) +splitHsAppsTy :: [LHsAppType name] -> ([[LHsType name]], [LEmbellished name]) splitHsAppsTy = go [] [] [] where go acc acc_non acc_sym [] = (reverse (reverse acc : acc_non), reverse acc_sym) @@ -999,7 +1001,7 @@ splitHsAppsTy = go [] [] [] hsTyGetAppHead_maybe :: LHsType name -> Maybe (Located name, [LHsType name]) hsTyGetAppHead_maybe = go [] where - go tys (L _ (HsTyVar _ ln)) = Just (ln, tys) + go tys (L _ (HsTyVar _ ln)) = Just (unLEmb ln, tys) go tys (L _ (HsAppsTy apps)) | Just (head, args, _) <- getAppsTyHead_maybe apps = go (args ++ tys) head @@ -1081,7 +1083,7 @@ type LFieldOcc name = Located (FieldOcc name) -- Represents an *occurrence* of an unambiguous field. We store -- both the 'RdrName' the user originally wrote, and after the -- renamer, the selector function. -data FieldOcc name = FieldOcc { rdrNameFieldOcc :: Located RdrName +data FieldOcc name = FieldOcc { rdrNameFieldOcc :: LEmbellished RdrName -- ^ See Note [Located RdrNames] in HsExpr , selectorFieldOcc :: PostRn name name } @@ -1092,7 +1094,7 @@ deriving instance (Data name, Data (PostRn name name)) => Data (FieldOcc name) instance Outputable (FieldOcc name) where ppr = ppr . rdrNameFieldOcc -mkFieldOcc :: Located RdrName -> FieldOcc RdrName +mkFieldOcc :: LEmbellished RdrName -> FieldOcc RdrName mkFieldOcc rdr = FieldOcc rdr PlaceHolder @@ -1109,8 +1111,8 @@ mkFieldOcc rdr = FieldOcc rdr PlaceHolder -- Note [Disambiguating record fields] in TcExpr. -- See Note [Located RdrNames] in HsExpr data AmbiguousFieldOcc name - = Unambiguous (Located RdrName) (PostRn name name) - | Ambiguous (Located RdrName) (PostTc name name) + = Unambiguous (LEmbellished RdrName) (PostRn name name) + | Ambiguous (LEmbellished RdrName) (PostTc name name) deriving instance ( Data name , Data (PostRn name name) , Data (PostTc name name)) @@ -1124,9 +1126,9 @@ instance OutputableBndr (AmbiguousFieldOcc name) where pprPrefixOcc = pprPrefixOcc . rdrNameAmbiguousFieldOcc mkAmbiguousFieldOcc :: Located RdrName -> AmbiguousFieldOcc RdrName -mkAmbiguousFieldOcc rdr = Unambiguous rdr PlaceHolder +mkAmbiguousFieldOcc rdr = Unambiguous (lEmb rdr) PlaceHolder -rdrNameAmbiguousFieldOcc :: AmbiguousFieldOcc name -> RdrName +rdrNameAmbiguousFieldOcc :: AmbiguousFieldOcc name -> Embellished RdrName rdrNameAmbiguousFieldOcc (Unambiguous (L _ rdr) _) = rdr rdrNameAmbiguousFieldOcc (Ambiguous (L _ rdr) _) = rdr diff --git a/compiler/hsSyn/HsUtils.hs b/compiler/hsSyn/HsUtils.hs index 8001a15d8d..e067d93719 100644 --- a/compiler/hsSyn/HsUtils.hs +++ b/compiler/hsSyn/HsUtils.hs @@ -120,6 +120,7 @@ import Util import Bag import Outputable import Constants +import HsEmbellished import Data.Either import Data.Function @@ -196,7 +197,7 @@ mkHsCaseAlt pat expr = mkSimpleMatch CaseAlt [pat] expr nlHsTyApp :: name -> [Type] -> LHsExpr name -nlHsTyApp fun_id tys = noLoc (HsWrap (mkWpTyApps tys) (HsVar (noLoc fun_id))) +nlHsTyApp fun_id tys = noLoc (HsWrap (mkWpTyApps tys) (HsVar (noEmb fun_id))) nlHsTyApps :: name -> [Type] -> [LHsExpr name] -> LHsExpr name nlHsTyApps fun_id tys xs = foldl nlHsApp (nlHsTyApp fun_id tys) xs @@ -315,7 +316,7 @@ mkRecStmt stmts = emptyRecStmt { recS_stmts = stmts } --- A useful function for building @OpApps@. The operator is always a -- variable, and we don't know the fixity yet. mkHsOpApp :: LHsExpr id -> id -> LHsExpr id -> HsExpr id -mkHsOpApp e1 op e2 = OpApp e1 (noLoc (HsVar (noLoc op))) +mkHsOpApp e1 op e2 = OpApp e1 (noLoc (HsVar (noEmb op))) (error "mkOpApp:fixity") e2 unqualSplice :: RdrName @@ -368,7 +369,7 @@ userHsTyVarBndrs loc bndrs = [ L loc (UserTyVar (L loc v)) | v <- bndrs ] -} nlHsVar :: id -> LHsExpr id -nlHsVar n = noLoc (HsVar (noLoc n)) +nlHsVar n = noLoc (HsVar (noEmb n)) -- NB: Only for LHsExpr **Id** nlHsDataCon :: DataCon -> LHsExpr Id @@ -405,7 +406,7 @@ nlHsApps :: id -> [LHsExpr id] -> LHsExpr id nlHsApps f xs = foldl nlHsApp (nlHsVar f) xs nlHsVarApps :: id -> [id] -> LHsExpr id -nlHsVarApps f xs = noLoc (foldl mk (HsVar (noLoc f)) (map (HsVar . noLoc) xs)) +nlHsVarApps f xs = noLoc (foldl mk (HsVar (noEmb f)) (map (HsVar . noEmb) xs)) where mk f a = HsApp (noLoc f) (noLoc a) @@ -472,7 +473,7 @@ nlHsFunTy :: LHsType name -> LHsType name -> LHsType name nlHsParTy :: LHsType name -> LHsType name nlHsAppTy f t = noLoc (HsAppTy f t) -nlHsTyVar x = noLoc (HsTyVar NotPromoted (noLoc x)) +nlHsTyVar x = noLoc (HsTyVar NotPromoted (noEmb x)) nlHsFunTy a b = noLoc (HsFunTy a b) nlHsParTy t = noLoc (HsParTy t) @@ -722,7 +723,7 @@ mkVarBind :: id -> LHsExpr id -> LHsBind id mkVarBind var rhs = L (getLoc rhs) $ VarBind { var_id = var, var_rhs = rhs, var_inline = False } -mkPatSynBind :: Located RdrName -> HsPatSynDetails (Located RdrName) +mkPatSynBind :: LEmbellished RdrName -> HsPatSynDetails (Located RdrName) -> LPat RdrName -> HsPatSynDir RdrName -> HsBind RdrName mkPatSynBind name details lpat dir = PatSynBind psb where @@ -891,7 +892,7 @@ collect_bind _ (AbsBinds { abs_exports = dbinds }) acc = map abe_poly dbinds ++ collect_bind _ (AbsBindsSig { abs_sig_export = poly }) acc = poly : acc collect_bind omitPatSyn (PatSynBind (PSB { psb_id = L _ ps })) acc | omitPatSyn = acc - | otherwise = ps : acc + | otherwise = unEmb ps : acc collectMethodBinders :: LHsBindsLR RdrName idR -> [Located RdrName] -- Used exclusively for the bindings of an instance decl which are all FunBinds @@ -940,7 +941,7 @@ collect_lpat (L _ pat) bndrs go (WildPat _) = bndrs go (LazyPat pat) = collect_lpat pat bndrs go (BangPat pat) = collect_lpat pat bndrs - go (AsPat (L _ a) pat) = a : collect_lpat pat bndrs + go (AsPat (L _ a) pat) = unEmb a : collect_lpat pat bndrs go (ViewPat _ pat _) = collect_lpat pat bndrs go (ParPat pat) = collect_lpat pat bndrs @@ -1007,11 +1008,13 @@ hsTyClForeignBinders tycl_decls foreign_decls `mappend` foldMap (foldMap hsLInstDeclBinders . group_instds) tycl_decls) where - getSelectorNames :: ([Located Name], [LFieldOcc Name]) -> [Name] - getSelectorNames (ns, fs) = map unLoc ns ++ map (selectorFieldOcc.unLoc) fs + getSelectorNames :: ([LEmbellished Name], [LFieldOcc Name]) -> [Name] + getSelectorNames (ns, fs) + = map unLocEmb ns ++ map (selectorFieldOcc.unLoc) fs ------------------- -hsLTyClDeclBinders :: Located (TyClDecl name) -> ([Located name], [LFieldOcc name]) +hsLTyClDeclBinders :: Located (TyClDecl name) + -> ([LEmbellished name], [LFieldOcc name]) -- ^ Returns all the /binding/ names of the decl. The first one is -- guaranteed to be the name of the decl. The first component @@ -1023,16 +1026,19 @@ hsLTyClDeclBinders :: Located (TyClDecl name) -> ([Located name], [LFieldOcc nam -- See Note [SrcSpan for binders] hsLTyClDeclBinders (L loc (FamDecl { tcdFam = FamilyDecl { fdLName = L _ name } })) - = ([L loc name], []) -hsLTyClDeclBinders (L loc (SynDecl { tcdLName = L _ name })) = ([L loc name], []) + = ([L loc $ EName name], []) +hsLTyClDeclBinders (L loc (SynDecl { tcdLName = L _ name })) + = ([L loc (EName name)], []) hsLTyClDeclBinders (L loc (ClassDecl { tcdLName = L _ cls_name , tcdSigs = sigs, tcdATs = ats })) - = (L loc cls_name : - [ L fam_loc fam_name | L fam_loc (FamilyDecl { fdLName = L _ fam_name }) <- ats ] ++ - [ L mem_loc mem_name | L mem_loc (ClassOpSig False ns _) <- sigs, L _ mem_name <- ns ] + = (L loc (EName cls_name) : + [ L fam_loc (EName fam_name) | + L fam_loc (FamilyDecl { fdLName = L _ fam_name }) <- ats ] ++ + [ L mem_loc (EName mem_name) | L mem_loc (ClassOpSig False ns _) <- sigs + , L _ mem_name <- (map unLEmb ns) ] , []) hsLTyClDeclBinders (L loc (DataDecl { tcdLName = L _ name, tcdDataDefn = defn })) - = (\ (xs, ys) -> (L loc name : xs, ys)) $ hsDataDefnBinders defn + = (\ (xs, ys) -> (L loc (EName name) : xs, ys)) $ hsDataDefnBinders defn ------------------- hsForeignDeclsBinders :: [LForeignDecl name] -> [Located name] @@ -1062,7 +1068,7 @@ getPatSynBinds binds , L _ (PatSynBind psb) <- bagToList lbinds ] ------------------- -hsLInstDeclBinders :: LInstDecl name -> ([Located name], [LFieldOcc name]) +hsLInstDeclBinders :: LInstDecl name -> ([LEmbellished name], [LFieldOcc name]) hsLInstDeclBinders (L _ (ClsInstD { cid_inst = ClsInstDecl { cid_datafam_insts = dfis } })) = foldMap (hsDataFamInstBinders . unLoc) dfis hsLInstDeclBinders (L _ (DataFamInstD { dfid_inst = fi })) @@ -1071,26 +1077,27 @@ hsLInstDeclBinders (L _ (TyFamInstD {})) = mempty ------------------- -- the SrcLoc returned are for the whole declarations, not just the names -hsDataFamInstBinders :: DataFamInstDecl name -> ([Located name], [LFieldOcc name]) +hsDataFamInstBinders :: DataFamInstDecl name + -> ([LEmbellished name], [LFieldOcc name]) hsDataFamInstBinders (DataFamInstDecl { dfid_defn = defn }) = hsDataDefnBinders defn -- There can't be repeated symbols because only data instances have binders ------------------- -- the SrcLoc returned are for the whole declarations, not just the names -hsDataDefnBinders :: HsDataDefn name -> ([Located name], [LFieldOcc name]) +hsDataDefnBinders :: HsDataDefn name -> ([LEmbellished name], [LFieldOcc name]) hsDataDefnBinders (HsDataDefn { dd_cons = cons }) = hsConDeclsBinders cons -- See Note [Binders in family instances] ------------------- -hsConDeclsBinders :: [LConDecl name] -> ([Located name], [LFieldOcc name]) +hsConDeclsBinders :: [LConDecl name] -> ([LEmbellished name], [LFieldOcc name]) -- See hsLTyClDeclBinders for what this does -- The function is boringly complicated because of the records -- And since we only have equality, we have to be a little careful hsConDeclsBinders cons = go id cons where go :: ([LFieldOcc name] -> [LFieldOcc name]) - -> [LConDecl name] -> ([Located name], [LFieldOcc name]) + -> [LConDecl name] -> ([LEmbellished name], [LFieldOcc name]) go _ [] = ([], []) go remSeen (r:rs) = -- don't re-mangle the location of field names, because we don't @@ -1112,7 +1119,8 @@ hsConDeclsBinders cons = go id cons where (ns, fs) = go remSeen rs where (_tvs, _cxt, tau) = splitLHsSigmaTy res_ty - record_gadt flds = (map (L loc . unLoc) names ++ ns, r' ++ fs) + record_gadt flds = (map (L loc . unLoc) names ++ ns + , r' ++ fs) where r' = remSeen (concatMap (cd_fld_names . unLoc) flds) remSeen' = foldr (.) remSeen [deleteBy ((==) `on` diff --git a/compiler/main/HscMain.hs b/compiler/main/HscMain.hs index 6e6ac04e5e..08374380fe 100644 --- a/compiler/main/HscMain.hs +++ b/compiler/main/HscMain.hs @@ -1678,7 +1678,7 @@ hscParseStmtWithLocation source linenumber stmt = hscParseType :: String -> Hsc (LHsType RdrName) hscParseType = hscParseThing parseType -hscParseIdentifier :: HscEnv -> String -> IO (Located RdrName) +hscParseIdentifier :: HscEnv -> String -> IO (LEmbellished RdrName) hscParseIdentifier hsc_env str = runInteractiveHsc hsc_env $ hscParseThing parseIdentifier str diff --git a/compiler/main/InteractiveEval.hs b/compiler/main/InteractiveEval.hs index 1fa269825d..dfab3d4631 100644 --- a/compiler/main/InteractiveEval.hs +++ b/compiler/main/InteractiveEval.hs @@ -775,7 +775,7 @@ getRdrNamesInScope = withSession $ \hsc_env -> do parseName :: GhcMonad m => String -> m [Name] parseName str = withSession $ \hsc_env -> liftIO $ do { lrdr_name <- hscParseIdentifier hsc_env str - ; hscTcRnLookupRdrName hsc_env lrdr_name } + ; hscTcRnLookupRdrName hsc_env $ unLEmb lrdr_name } -- | Returns @True@ if passed string is a statement. isStmt :: DynFlags -> String -> Bool @@ -890,7 +890,8 @@ dynCompileExpr expr = do parsed_expr <- parseExpr expr -- > Data.Dynamic.toDyn expr let loc = getLoc parsed_expr - to_dyn_expr = mkHsApp (L loc . HsVar . L loc $ getRdrName toDynName) + to_dyn_expr = mkHsApp (L loc . HsVar . L loc $ EName + $ getRdrName toDynName) parsed_expr hval <- compileParsedExpr to_dyn_expr return (unsafeCoerce# hval :: Dynamic) diff --git a/compiler/parser/ApiAnnotation.hs b/compiler/parser/ApiAnnotation.hs index b20f23f066..9d289d0d25 100644 --- a/compiler/parser/ApiAnnotation.hs +++ b/compiler/parser/ApiAnnotation.hs @@ -242,7 +242,6 @@ data AnnKeywordId | AnnMinus -- ^ '-' | AnnModule | AnnNewtype - | AnnName -- ^ where a name loses its location in the AST, this carries it | AnnOf | AnnOpen -- ^ '(\#' or '{-\# LANGUAGE' etc | AnnOpenC -- ^ '{' diff --git a/compiler/parser/Parser.y b/compiler/parser/Parser.y index 175cfbbdfc..82c696156f 100644 --- a/compiler/parser/Parser.y +++ b/compiler/parser/Parser.y @@ -552,12 +552,12 @@ TH_QQUASIQUOTE { L _ (ITqQuasiQuote _) } ----------------------------------------------------------------------------- -- Identifiers; one of the entry points -identifier :: { Located RdrName } +identifier :: { Located (Embellished RdrName) } : qvar { $1 } | qcon { $1 } | qvarop { $1 } | qconop { $1 } - | '(' '->' ')' {% ams (sLL $1 $> $ getRdrName funTyCon) + | '(' '->' ')' {% ams (sLL $1 $> $ EName $ getRdrName funTyCon) [mj AnnOpenP $1,mu AnnRarrow $2,mj AnnCloseP $3] } ----------------------------------------------------------------------------- @@ -793,7 +793,7 @@ export :: { OrdList (LIE RdrName) } >>= \ie -> amsu (sLL $1 $> ie) (fst $ unLoc $2) } | 'module' modid {% amsu (sLL $1 $> (IEModuleContents $2)) [mj AnnModule $1] } - | 'pattern' qcon {% amsu (sLL $1 $> (IEVar (sLL $1 $> (IEPattern $2)))) + | 'pattern' qcon {% amsu (sLL $1 $> (IEVar (sLL $1 $> (IEPattern $ unLEmb $2)))) [mj AnnPattern $1] } export_subspec :: { Located ([AddAnn],ImpExpSubSpec) } @@ -827,12 +827,12 @@ qcname_ext_w_wildcard :: { Located ([AddAnn], Located ImpExpQcSpec) } | '..' { sL1 $1 ([mj AnnDotdot $1], sL1 $1 ImpExpQcWildcard) } qcname_ext :: { Located ImpExpQcSpec } - : qcname { sL1 $1 (ImpExpQcName $1) } - | 'type' oqtycon {% do { n <- mkTypeImpExp $2 + : qcname { sL1 $1 (ImpExpQcName (unLEmb $1)) } + | 'type' oqtycon {% do { n <- mkTypeImpExp (unLEmb $2) ; ams (sLL $1 $> (ImpExpQcType n)) [mj AnnType $1] } } -qcname :: { Located RdrName } -- Variable or type constructor +qcname :: { Located (Embellished RdrName) } -- Variable or type constructor : qvar { $1 } -- Things which look like functions -- Note: This includes record selectors but -- also (-.->), see #11432 @@ -935,7 +935,7 @@ infix :: { Located FixityDirection } | 'infixl' { sL1 $1 InfixL } | 'infixr' { sL1 $1 InfixR } -ops :: { Located (OrdList (Located RdrName)) } +ops :: { Located (OrdList (Located (Embellished RdrName))) } : ops ',' op {% addAnnotation (oll $ unLoc $1) AnnComma (gl $2) >> return (sLL $1 $> ((unLoc $1) `appOL` unitOL $3))} | op { sL1 $1 (unitOL $1) } @@ -1352,7 +1352,7 @@ pattern_synonym_decl :: { LHsDecl RdrName } (as ++ ((mj AnnPattern $1:mu AnnLarrow $3:(fst $ unLoc $5))) ) }} -pattern_synonym_lhs :: { (Located RdrName, HsPatSynDetails (Located RdrName), [AddAnn]) } +pattern_synonym_lhs :: { (Located (Embellished RdrName), HsPatSynDetails (Located RdrName), [AddAnn]) } : con vars0 { ($1, PrefixPatSyn $2, []) } | varid conop varid { ($2, InfixPatSyn $1 $3, []) } | con '{' cvars1 '}' { ($1, RecordPatSyn $3, [moc $2, mcc $4] ) } @@ -1656,9 +1656,9 @@ fspec :: { Located ([AddAnn] ,(Located StringLiteral, Located RdrName, LHsSigType RdrName)) } : STRING var '::' sigtypedoc { sLL $1 $> ([mu AnnDcolon $3] ,(L (getLoc $1) - (getStringLiteral $1), $2, mkLHsSigType $4)) } + (getStringLiteral $1), unLEmb $2, mkLHsSigType $4)) } | var '::' sigtypedoc { sLL $1 $> ([mu AnnDcolon $2] - ,(noLoc (StringLiteral NoSourceText nilFS), $1, mkLHsSigType $3)) } + ,(noLoc (StringLiteral NoSourceText nilFS), unLEmb $1, mkLHsSigType $3)) } -- if the entity string is missing, it defaults to the empty string; -- the meaning of an empty entity string depends on the calling -- convention @@ -1674,7 +1674,7 @@ opt_asig :: { ([AddAnn],Maybe (LHsType RdrName)) } : {- empty -} { ([],Nothing) } | '::' atype { ([mu AnnDcolon $1],Just $2) } -opt_tyconsig :: { ([AddAnn], Maybe (Located RdrName)) } +opt_tyconsig :: { ([AddAnn], Maybe (Located (Embellished RdrName))) } : {- empty -} { ([], Nothing) } | '::' gtycon { ([mu AnnDcolon $1], Just $2) } @@ -1685,7 +1685,7 @@ sigtypedoc :: { LHsType RdrName } : ctypedoc { $1 } -sig_vars :: { Located [Located RdrName] } -- Returned in reversed order +sig_vars :: { Located [Located (Embellished RdrName)] } -- Returned in reversed order : sig_vars ',' var {% addAnnotation (gl $ head $ unLoc $1) AnnComma (gl $2) >> return (sLL $1 $> ($3 : unLoc $1)) } @@ -1846,8 +1846,8 @@ tyapp :: { LHsAppType RdrName } [mj AnnSimpleQuote $1] } atype :: { LHsType RdrName } - : ntgtycon { sL1 $1 (HsTyVar NotPromoted $1) } -- Not including unit tuples - | tyvar { sL1 $1 (HsTyVar NotPromoted $1) } -- (See Note [Unit tuples]) + : ntgtycon { sL1 $1 (HsTyVar NotPromoted $1) } -- Not including unit tuples + | tyvar { sL1 $1 (HsTyVar NotPromoted (lEmb $1)) } -- (See Note [Unit tuples]) | strict_mark atype {% ams (sLL $1 $> (HsBangTy (snd $ unLoc $1) $2)) (fst $ unLoc $1) } -- Constructor sigs only | '{' fielddecls '}' {% amms (checkRecordSyntax @@ -1877,10 +1877,10 @@ atype :: { LHsType RdrName } | '$(' exp ')' {% ams (sLL $1 $> $ mkHsSpliceTy HasParens $2) [mj AnnOpenPE $1,mj AnnCloseP $3] } | TH_ID_SPLICE {%ams (sLL $1 $> $ mkHsSpliceTy NoParens $ sL1 $1 $ HsVar $ - (sL1 $1 (mkUnqual varName (getTH_ID_SPLICE $1)))) + (sL1 $1 (EName $ mkUnqual varName (getTH_ID_SPLICE $1)))) [mj AnnThIdSplice $1] } -- see Note [Promotion] for the followings - | SIMPLEQUOTE qcon_nowiredlist {% ams (sLL $1 $> $ HsTyVar Promoted $2) [mj AnnSimpleQuote $1,mj AnnName $2] } + | SIMPLEQUOTE qcon_nowiredlist {% ams (sLL $1 $> $ HsTyVar Promoted $2) [mj AnnSimpleQuote $1] } | SIMPLEQUOTE '(' ctype ',' comma_types1 ')' {% addAnnotation (gl $3) AnnComma (gl $4) >> ams (sLL $1 $> $ HsExplicitTupleTy [] ($3 : $5)) @@ -1889,7 +1889,7 @@ atype :: { LHsType RdrName } placeHolderKind $3) [mj AnnSimpleQuote $1,mos $2,mcs $4] } | SIMPLEQUOTE var {% ams (sLL $1 $> $ HsTyVar Promoted $2) - [mj AnnSimpleQuote $1,mj AnnName $2] } + [mj AnnSimpleQuote $1] } -- Two or more [ty, ty, ty] must be a promoted list type, just as -- if you had written '[ty, ty, ty] @@ -2089,7 +2089,7 @@ forall :: { Located ([AddAnn], Maybe [LHsTyVarBndr RdrName]) } : 'forall' tv_bndrs '.' { sLL $1 $> ([mu AnnForall $1,mj AnnDot $3], Just $2) } | {- empty -} { noLoc ([], Nothing) } -constr_stuff :: { Located (Located RdrName, HsConDeclDetails RdrName) } +constr_stuff :: { Located (LEmbellished RdrName, HsConDeclDetails RdrName) } -- See Note [Parsing data constructors is hard] in RdrHsSyn : btype_no_ops {% do { c <- splitCon $1 ; return $ sLL $1 $> c } } @@ -2181,7 +2181,7 @@ docdecld :: { LDocDecl } decl_no_th :: { LHsDecl RdrName } : sigdecl { $1 } - | '!' aexp rhs {% do { let { e = sLL $1 $2 (SectionR (sL1 $1 (HsVar (sL1 $1 bang_RDR))) $2) }; + | '!' aexp rhs {% do { let { e = sLL $1 $2 (SectionR (sL1 $1 (HsVar (sL1 $1 $ EName bang_RDR))) $2) }; pat <- checkPattern empty e; _ <- ams (sLL $1 $> ()) (fst $ unLoc $3); @@ -2517,10 +2517,10 @@ aexp2 :: { LHsExpr RdrName } -- Template Haskell Extension | splice_exp { $1 } - | SIMPLEQUOTE qvar {% ams (sLL $1 $> $ HsBracket (VarBr True (unLoc $2))) [mj AnnSimpleQuote $1,mj AnnName $2] } - | SIMPLEQUOTE qcon {% ams (sLL $1 $> $ HsBracket (VarBr True (unLoc $2))) [mj AnnSimpleQuote $1,mj AnnName $2] } - | TH_TY_QUOTE tyvar {% ams (sLL $1 $> $ HsBracket (VarBr False (unLoc $2))) [mj AnnThTyQuote $1,mj AnnName $2] } - | TH_TY_QUOTE gtycon {% ams (sLL $1 $> $ HsBracket (VarBr False (unLoc $2))) [mj AnnThTyQuote $1,mj AnnName $2] } + | SIMPLEQUOTE qvar {% ams (sLL $1 $> $ HsBracket (VarBr True $2) ) [mj AnnSimpleQuote $1] } + | SIMPLEQUOTE qcon {% ams (sLL $1 $> $ HsBracket (VarBr True $2) ) [mj AnnSimpleQuote $1] } + | TH_TY_QUOTE tyvar {% ams (sLL $1 $> $ HsBracket (VarBr False (lEmb $2))) [mj AnnThTyQuote $1] } + | TH_TY_QUOTE gtycon {% ams (sLL $1 $> $ HsBracket (VarBr False $2)) [mj AnnThTyQuote $1] } | '[|' exp '|]' {% ams (sLL $1 $> $ HsBracket (ExpBr $2)) (if (hasE $1) then [mj AnnOpenE $1,mc $3] else [mo $1,mc $3]) } | '[||' exp '||]' {% ams (sLL $1 $> $ HsBracket (TExpBr $2)) @@ -2540,13 +2540,13 @@ aexp2 :: { LHsExpr RdrName } splice_exp :: { LHsExpr RdrName } : TH_ID_SPLICE {% ams (sL1 $1 $ mkHsSpliceE NoParens - (sL1 $1 $ HsVar (sL1 $1 (mkUnqual varName + (sL1 $1 $ HsVar (sL1 $1 (EName $ mkUnqual varName (getTH_ID_SPLICE $1))))) [mj AnnThIdSplice $1] } | '$(' exp ')' {% ams (sLL $1 $> $ mkHsSpliceE HasParens $2) [mj AnnOpenPE $1,mj AnnCloseP $3] } | TH_ID_TY_SPLICE {% ams (sL1 $1 $ mkHsSpliceTE NoParens - (sL1 $1 $ HsVar (sL1 $1 (mkUnqual varName + (sL1 $1 $ HsVar (sL1 $1 (EName $ mkUnqual varName (getTH_ID_TY_SPLICE $1))))) [mj AnnThIdTySplice $1] } | '$$(' exp ')' {% ams (sLL $1 $> $ mkHsSpliceTE HasParens $2) @@ -2821,7 +2821,7 @@ gdpat :: { LGRHS RdrName (LHsExpr RdrName) } pat :: { LPat RdrName } pat : exp {% checkPattern empty $1 } | '!' aexp {% amms (checkPattern empty (sLL $1 $> (SectionR - (sL1 $1 (HsVar (sL1 $1 bang_RDR))) $2))) + (sL1 $1 (HsVar (sL1 $1 $ EName bang_RDR))) $2))) [mj AnnBang $1] } bindpat :: { LPat RdrName } @@ -2829,14 +2829,14 @@ bindpat : exp {% checkPattern (text "Possibly caused by a missing 'do'?") $1 } | '!' aexp {% amms (checkPattern (text "Possibly caused by a missing 'do'?") - (sLL $1 $> (SectionR (sL1 $1 (HsVar (sL1 $1 bang_RDR))) $2))) + (sLL $1 $> (SectionR (sL1 $1 (HsVar (sL1 $1 $ EName bang_RDR))) $2))) [mj AnnBang $1] } apat :: { LPat RdrName } apat : aexp {% checkPattern empty $1 } | '!' aexp {% amms (checkPattern empty (sLL $1 $> (SectionR - (sL1 $1 (HsVar (sL1 $1 bang_RDR))) $2))) + (sL1 $1 (HsVar (sL1 $1 $ EName bang_RDR))) $2))) [mj AnnBang $1] } apats :: { [LPat RdrName] } @@ -2948,31 +2948,31 @@ overloaded_label :: { Located FastString } ----------------------------------------------------------------------------- -- Warnings and deprecations -name_boolformula_opt :: { LBooleanFormula (Located RdrName) } +name_boolformula_opt :: { LBooleanFormula (LEmbellished RdrName) } : name_boolformula { $1 } | {- empty -} { noLoc mkTrue } -name_boolformula :: { LBooleanFormula (Located RdrName) } +name_boolformula :: { LBooleanFormula (LEmbellished RdrName) } : name_boolformula_and { $1 } | name_boolformula_and '|' name_boolformula {% aa $1 (AnnVbar, $2) >> return (sLL $1 $> (Or [$1,$3])) } -name_boolformula_and :: { LBooleanFormula (Located RdrName) } +name_boolformula_and :: { LBooleanFormula (LEmbellished RdrName) } : name_boolformula_atom { $1 } | name_boolformula_atom ',' name_boolformula_and {% aa $1 (AnnComma,$2) >> return (sLL $1 $> (And [$1,$3])) } -name_boolformula_atom :: { LBooleanFormula (Located RdrName) } +name_boolformula_atom :: { LBooleanFormula (LEmbellished RdrName) } : '(' name_boolformula ')' {% ams (sLL $1 $> (Parens $2)) [mop $1,mcp $3] } | name_var { sL1 $1 (Var $1) } -namelist :: { Located [Located RdrName] } +namelist :: { Located [Located (Embellished RdrName)] } namelist : name_var { sL1 $1 [$1] } | name_var ',' namelist {% addAnnotation (gl $1) AnnComma (gl $2) >> return (sLL $1 $> ($1 : unLoc $3)) } -name_var :: { Located RdrName } +name_var :: { Located (Embellished RdrName) } name_var : var { $1 } | con { $1 } @@ -2981,28 +2981,28 @@ name_var : var { $1 } -- There are two different productions here as lifted list constructors -- are parsed differently. -qcon_nowiredlist :: { Located RdrName } +qcon_nowiredlist :: { Located (Embellished RdrName) } : gen_qcon { $1 } - | sysdcon_nolist { sL1 $1 $ nameRdrName (dataConName (unLoc $1)) } + | sysdcon_nolist { sL1 $1 $ EName $ nameRdrName (dataConName (unLoc $1)) } -qcon :: { Located RdrName } +qcon :: { Located (Embellished RdrName) } : gen_qcon { $1} - | sysdcon { sL1 $1 $ nameRdrName (dataConName (unLoc $1)) } + | sysdcon { sL1 $1 $ EParens $ sL1 $1 $ nameRdrName (dataConName (unLoc $1)) } -gen_qcon :: { Located RdrName } - : qconid { $1 } - | '(' qconsym ')' {% ams (sLL $1 $> (unLoc $2)) - [mop $1,mj AnnVal $2,mcp $3] } +gen_qcon :: { Located (Embellished RdrName) } + : qconid { sL1 $1 (EName $ unLoc $1) } + | '(' qconsym ')' {% ams (sLL $1 $> (EParens $2)) + [mop $1,mcp $3] } -- The case of '[:' ':]' is part of the production `parr' -con :: { Located RdrName } - : conid { $1 } - | '(' consym ')' {% ams (sLL $1 $> (unLoc $2)) - [mop $1,mj AnnVal $2,mcp $3] } - | sysdcon { sL1 $1 $ nameRdrName (dataConName (unLoc $1)) } +con :: { Located (Embellished RdrName) } + : conid { sL1 $1 (EName (unLoc $1)) } + | '(' consym ')' {% ams (sLL $1 $> (EParens $2)) + [mop $1,mcp $3] } + | sysdcon { sL1 $1 $ EName $ nameRdrName (dataConName (unLoc $1)) } -con_list :: { Located [Located RdrName] } +con_list :: { Located [Located (Embellished RdrName)] } con_list : con { sL1 $1 [$1] } | con ',' con_list {% addAnnotation (gl $1) AnnComma (gl $2) >> return (sLL $1 $> ($1 : unLoc $3)) } @@ -3019,16 +3019,16 @@ sysdcon :: { Located DataCon } : sysdcon_nolist { $1 } | '[' ']' {% ams (sLL $1 $> nilDataCon) [mos $1,mcs $2] } -conop :: { Located RdrName } - : consym { $1 } - | '`' conid '`' {% ams (sLL $1 $> (unLoc $2)) - [mj AnnBackquote $1,mj AnnVal $2 +conop :: { Located (Embellished RdrName) } + : consym { sL1 $1 (EName (unLoc $1)) } + | '`' conid '`' {% ams (sLL $1 $> (EBackquotes $2)) + [mj AnnBackquote $1 ,mj AnnBackquote $3] } -qconop :: { Located RdrName } - : qconsym { $1 } - | '`' qconid '`' {% ams (sLL $1 $> (unLoc $2)) - [mj AnnBackquote $1,mj AnnVal $2 +qconop :: { Located (Embellished RdrName) } + : qconsym { sL1 $1 $ (EName $ unLoc $1) } + | '`' qconid '`' {% ams (sLL $1 $> (EBackquotes $2)) + [mj AnnBackquote $1 ,mj AnnBackquote $3] } ---------------------------------------------------------------------------- @@ -3037,47 +3037,47 @@ qconop :: { Located RdrName } -- See Note [Unit tuples] in HsTypes for the distinction -- between gtycon and ntgtycon -gtycon :: { Located RdrName } -- A "general" qualified tycon, including unit tuples +gtycon :: { Located (Embellished RdrName) } -- A "general" qualified tycon, including unit tuples : ntgtycon { $1 } - | '(' ')' {% ams (sLL $1 $> $ getRdrName unitTyCon) + | '(' ')' {% ams (sLL $1 $> $ EName $ getRdrName unitTyCon) [mop $1,mcp $2] } - | '(#' '#)' {% ams (sLL $1 $> $ getRdrName unboxedUnitTyCon) + | '(#' '#)' {% ams (sLL $1 $> $ EName $ getRdrName unboxedUnitTyCon) [mo $1,mc $2] } -ntgtycon :: { Located RdrName } -- A "general" qualified tycon, excluding unit tuples +ntgtycon :: { Located (Embellished RdrName) } -- A "general" qualified tycon, excluding unit tuples : oqtycon { $1 } - | '(' commas ')' {% ams (sLL $1 $> $ getRdrName (tupleTyCon Boxed + | '(' commas ')' {% ams (sLL $1 $> $ EName $ getRdrName (tupleTyCon Boxed (snd $2 + 1))) (mop $1:mcp $3:(mcommas (fst $2))) } - | '(#' commas '#)' {% ams (sLL $1 $> $ getRdrName (tupleTyCon Unboxed + | '(#' commas '#)' {% ams (sLL $1 $> $ EName $ getRdrName (tupleTyCon Unboxed (snd $2 + 1))) (mo $1:mc $3:(mcommas (fst $2))) } - | '(' '->' ')' {% ams (sLL $1 $> $ getRdrName funTyCon) + | '(' '->' ')' {% ams (sLL $1 $> $ EName $ getRdrName funTyCon) [mop $1,mu AnnRarrow $2,mcp $3] } - | '[' ']' {% ams (sLL $1 $> $ listTyCon_RDR) [mos $1,mcs $2] } - | '[:' ':]' {% ams (sLL $1 $> $ parrTyCon_RDR) [mo $1,mc $2] } - | '(' '~#' ')' {% ams (sLL $1 $> $ getRdrName eqPrimTyCon) + | '[' ']' {% ams (sLL $1 $> $ EName $ listTyCon_RDR) [mos $1,mcs $2] } + | '[:' ':]' {% ams (sLL $1 $> $ EName $ parrTyCon_RDR) [mo $1,mc $2] } + | '(' '~#' ')' {% ams (sLL $1 $> $ EName $ getRdrName eqPrimTyCon) [mop $1,mj AnnTildehsh $2,mcp $3] } -oqtycon :: { Located RdrName } -- An "ordinary" qualified tycon; +oqtycon :: { Located (Embellished RdrName) } -- An "ordinary" qualified tycon; -- These can appear in export lists - : qtycon { $1 } - | '(' qtyconsym ')' {% ams (sLL $1 $> (unLoc $2)) - [mop $1,mj AnnVal $2,mcp $3] } - | '(' '~' ')' {% ams (sLL $1 $> $ eqTyCon_RDR) - [mop $1,mj AnnVal $2,mcp $3] } + : qtycon { sL1 $1 (EName $ unLoc $1) } + | '(' qtyconsym ')' {% ams (sLL $1 $> (EParens $2)) + [mop $1,mcp $3] } + | '(' '~' ')' {% ams (sLL $1 $> $ EParens (sL1 $1 eqTyCon_RDR)) + [mop $1,mcp $3] } -oqtycon_no_varcon :: { Located RdrName } -- Type constructor which cannot be mistaken +oqtycon_no_varcon :: { Located (Embellished RdrName) } -- Type constructor which cannot be mistaken -- for variable constructor in export lists -- see Note [Type constructors in export list] - : qtycon { $1 } + : qtycon { sL1 $1 (EName $ unLoc $1) } | '(' QCONSYM ')' {% let name = sL1 $2 $! mkQual tcClsName (getQCONSYM $2) - in ams (sLL $1 $> (unLoc name)) [mop $1,mj AnnVal name,mcp $3] } + in ams (sLL $1 $> (EParens name)) [mop $1,mcp $3] } | '(' CONSYM ')' {% let name = sL1 $2 $! mkUnqual tcClsName (getCONSYM $2) - in ams (sLL $1 $> (unLoc name)) [mop $1,mj AnnVal name,mcp $3] } + in ams (sLL $1 $> (EParens name)) [mop $1,mcp $3] } | '(' ':' ')' {% let name = sL1 $2 $! consDataCon_RDR - in ams (sLL $1 $> (unLoc name)) [mop $1,mj AnnVal name,mcp $3] } - | '(' '~' ')' {% ams (sLL $1 $> $ eqTyCon_RDR) [mop $1,mj AnnTilde $2,mcp $3] } + in ams (sLL $1 $> (EParens name)) [mop $1,mcp $3] } + | '(' '~' ')' {% ams (sLL $1 $> $ EParens (sL1 $2 eqTyCon_RDR)) [mop $1,mcp $3] } {- Note [Type constructors in export list] ~~~~~~~~~~~~~~~~~~~~~ @@ -3099,10 +3099,10 @@ until after renaming when we resolve the proper namespace for each exported child. -} -qtyconop :: { Located RdrName } -- Qualified or unqualified - : qtyconsym { $1 } - | '`' qtycon '`' {% ams (sLL $1 $> (unLoc $2)) - [mj AnnBackquote $1,mj AnnVal $2 +qtyconop :: { Located (Embellished RdrName) } -- Qualified or unqualified + : qtyconsym { sL1 $1 $ EName (unLoc $1) } + | '`' qtycon '`' {% ams (sLL $1 $> (EBackquotes $2)) + [mj AnnBackquote $1 ,mj AnnBackquote $3] } qtycon :: { Located RdrName } -- Qualified or unqualified @@ -3110,8 +3110,8 @@ qtycon :: { Located RdrName } -- Qualified or unqualified | tycon { $1 } qtycondoc :: { LHsType RdrName } -- Qualified or unqualified - : qtycon { sL1 $1 (HsTyVar NotPromoted $1) } - | qtycon docprev { sLL $1 $> (HsDocTy (sL1 $1 (HsTyVar NotPromoted $1)) $2) } + : qtycon { sL1 $1 (HsTyVar NotPromoted (lEmb $1)) } + | qtycon docprev { sLL $1 $> (HsDocTy (sL1 $1 (HsTyVar NotPromoted (lEmb $1))) $2) } tycon :: { Located RdrName } -- Unqualified : CONID { sL1 $1 $! mkUnqual tcClsName (getCONID $1) } @@ -3133,14 +3133,14 @@ tyconsym :: { Located RdrName } ----------------------------------------------------------------------------- -- Operators -op :: { Located RdrName } -- used in infix decls +op :: { Located (Embellished RdrName) } -- used in infix decls : varop { $1 } | conop { $1 } -varop :: { Located RdrName } - : varsym { $1 } - | '`' varid '`' {% ams (sLL $1 $> (unLoc $2)) - [mj AnnBackquote $1,mj AnnVal $2 +varop :: { Located (Embellished RdrName) } + : varsym { sL1 $1 (EName $ unLoc $1) } + | '`' varid '`' {% ams (sLL $1 $> (EBackquotes $2)) + [mj AnnBackquote $1 ,mj AnnBackquote $3] } qop :: { LHsExpr RdrName } -- used in sections @@ -3154,16 +3154,16 @@ qopm :: { LHsExpr RdrName } -- used in sections : qvaropm { sL1 $1 $ HsVar $1 } | qconop { sL1 $1 $ HsVar $1 } -qvarop :: { Located RdrName } - : qvarsym { $1 } - | '`' qvarid '`' {% ams (sLL $1 $> (unLoc $2)) - [mj AnnBackquote $1,mj AnnVal $2 +qvarop :: { Located (Embellished RdrName) } + : qvarsym { sL1 $1 $ EName (unLoc $1) } + | '`' qvarid '`' {% ams (sLL $1 $> (EBackquotes $2)) + [mj AnnBackquote $1 ,mj AnnBackquote $3] } -qvaropm :: { Located RdrName } - : qvarsym_no_minus { $1 } - | '`' qvarid '`' {% ams (sLL $1 $> (unLoc $2)) - [mj AnnBackquote $1,mj AnnVal $2 +qvaropm :: { Located (Embellished RdrName) } + : qvarsym_no_minus { sL1 $1 $ EName (unLoc $1) } + | '`' qvarid '`' {% ams (sLL $1 $> (EBackquotes $2)) + [mj AnnBackquote $1 ,mj AnnBackquote $3] } ----------------------------------------------------------------------------- @@ -3172,9 +3172,9 @@ qvaropm :: { Located RdrName } tyvar :: { Located RdrName } tyvar : tyvarid { $1 } -tyvarop :: { Located RdrName } -tyvarop : '`' tyvarid '`' {% ams (sLL $1 $> (unLoc $2)) - [mj AnnBackquote $1,mj AnnVal $2 +tyvarop :: { Located (Embellished RdrName) } +tyvarop : '`' tyvarid '`' {% ams (sLL $1 $> (EBackquotes $2)) + [mj AnnBackquote $1 ,mj AnnBackquote $3] } | '.' {% parseErrorSDoc (getLoc $1) (vcat [text "Illegal symbol '.' in type", @@ -3192,21 +3192,21 @@ tyvarid :: { Located RdrName } ----------------------------------------------------------------------------- -- Variables -var :: { Located RdrName } - : varid { $1 } - | '(' varsym ')' {% ams (sLL $1 $> (unLoc $2)) - [mop $1,mj AnnVal $2,mcp $3] } +var :: { Located (Embellished RdrName) } + : varid { sL1 $1 (EName $ unLoc $1) } + | '(' varsym ')' {% ams (sLL $1 $> (EParens $2)) + [mop $1,mcp $3] } -- Lexing type applications depends subtly on what characters can possibly -- end a qvar. Currently (June 2015), only $idchars and ")" can end a qvar. -- If you're changing this, please see Note [Lexing type applications] in -- Lexer.x. -qvar :: { Located RdrName } - : qvarid { $1 } - | '(' varsym ')' {% ams (sLL $1 $> (unLoc $2)) - [mop $1,mj AnnVal $2,mcp $3] } - | '(' qvarsym1 ')' {% ams (sLL $1 $> (unLoc $2)) - [mop $1,mj AnnVal $2,mcp $3] } +qvar :: { Located (Embellished RdrName) } + : qvarid { sL1 $1 (EName (unLoc $1)) } + | '(' varsym ')' {% ams (sLL $1 $> (EParens $2)) + [mop $1,mcp $3] } + | '(' qvarsym1 ')' {% ams (sLL $1 $> (EParens $2)) + [mop $1,mcp $3] } -- We've inlined qvarsym here so that the decision about -- whether it's a qvar or a var can be postponed until -- *after* we see the close paren. diff --git a/compiler/parser/RdrHsSyn.hs b/compiler/parser/RdrHsSyn.hs index 2c63c428b6..4fc18dd30a 100644 --- a/compiler/parser/RdrHsSyn.hs +++ b/compiler/parser/RdrHsSyn.hs @@ -293,7 +293,7 @@ mkSpliceDecl lexpr@(L loc expr) = SpliceD (SpliceDecl (L loc (mkUntypedSplice NoParens lexpr)) ImplicitSplice) mkRoleAnnotDecl :: SrcSpan - -> Located RdrName -- type being annotated + -> LEmbellished RdrName -- type being annotated -> [Located (Maybe FastString)] -- roles -> P (LRoleAnnotDecl RdrName) mkRoleAnnotDecl loc tycon roles @@ -463,7 +463,7 @@ So the plan is: -} splitCon :: LHsType RdrName - -> P (Located RdrName, HsConDeclDetails RdrName) + -> P (LEmbellished RdrName, HsConDeclDetails RdrName) -- See Note [Parsing data constructors is hard] -- This gets given a "type" that should look like -- C Int Bool @@ -474,34 +474,37 @@ splitCon ty where -- This is used somewhere where HsAppsTy is not used split (L _ (HsAppTy t u)) ts = split t (u : ts) - split (L l (HsTyVar _ (L _ tc))) ts = do data_con <- tyConToDataCon l tc - return (data_con, mk_rest ts) + split (L l (HsTyVar _ (L _ tc))) ts + = do data_con <- tyConToDataCon l tc + return (data_con, mk_rest ts) split (L l (HsTupleTy HsBoxedOrConstraintTuple ts)) [] - = return (L l (getRdrName (tupleDataCon Boxed (length ts))), PrefixCon ts) + = return (L l (EName $ getRdrName (tupleDataCon Boxed (length ts))) + , PrefixCon ts) split (L l _) _ = parseErrorSDoc l (text "Cannot parse data constructor in a data/newtype declaration:" <+> ppr ty) mk_rest [L l (HsRecTy flds)] = RecCon (L l flds) mk_rest ts = PrefixCon ts -tyConToDataCon :: SrcSpan -> RdrName -> P (Located RdrName) +tyConToDataCon :: SrcSpan -> Embellished RdrName -> P (LEmbellished RdrName) -- See Note [Parsing data constructors is hard] -- Data constructor RHSs are parsed as types tyConToDataCon loc tc | isTcOcc occ , isLexCon (occNameFS occ) - = return (L loc (setRdrNameSpace tc srcDataName)) + -- = return (L loc (setRdrNameSpace tc srcDataName)) + = return (L loc $ fmap (\n -> setRdrNameSpace n srcDataName) tc) | otherwise = parseErrorSDoc loc (msg $$ extra) where - occ = rdrNameOcc tc + occ = rdrNameOcc $ unEmb tc msg = text "Not a data constructor:" <+> quotes (ppr tc) - extra | tc == forall_tv_RDR + extra | unEmb tc == forall_tv_RDR = text "Perhaps you intended to use ExistentialQuantification" | otherwise = empty -mkPatSynMatchGroup :: Located RdrName +mkPatSynMatchGroup :: LEmbellished RdrName -> Located (OrdList (LHsDecl RdrName)) -> P (MatchGroup RdrName (LHsExpr RdrName)) mkPatSynMatchGroup (L loc patsyn_name) (L _ decls) = @@ -510,7 +513,7 @@ mkPatSynMatchGroup (L loc patsyn_name) (L _ decls) = ; return $ mkMatchGroup FromSource matches } where fromDecl (L loc decl@(ValD (PatBind pat@(L _ (ConPatIn ln@(L _ name) details)) rhs _ _ _))) = - do { unless (name == patsyn_name) $ + do { unless (name == unEmb patsyn_name) $ wrongNameBindingErr loc decl ; match <- case details of PrefixCon pats -> @@ -542,7 +545,7 @@ recordPatSynErr loc pat = text "record syntax not supported for pattern synonym declarations:" $$ ppr pat -mkConDeclH98 :: Located RdrName -> Maybe [LHsTyVarBndr RdrName] +mkConDeclH98 :: LEmbellished RdrName -> Maybe [LHsTyVarBndr RdrName] -> LHsContext RdrName -> HsConDeclDetails RdrName -> ConDecl RdrName @@ -555,7 +558,7 @@ mkConDeclH98 name mb_forall cxt details , con_details = details , con_doc = Nothing } -mkGadtDecl :: [Located RdrName] +mkGadtDecl :: [LEmbellished RdrName] -> LHsSigType RdrName -- Always a HsForAllTy -> ConDecl RdrName mkGadtDecl names ty = ConDeclGADT { con_names = names @@ -691,9 +694,9 @@ checkTyVars pp_what equals_or_where tc tparms -- Check that the name space is correct! chk (L l (HsKindSig (L _ (HsAppsTy [L _ (HsAppPrefix (L lv (HsTyVar _ (L _ tv))))])) k)) - | isRdrTyVar tv = return (L l (KindedTyVar (L lv tv) k)) + | isRdrTyVar $ unEmb tv = return (L l (KindedTyVar (L lv $ unEmb tv) k)) chk (L l (HsTyVar _ (L ltv tv))) - | isRdrTyVar tv = return (L l (UserTyVar (L ltv tv))) + | isRdrTyVar $ unEmb tv = return (L l (UserTyVar (L ltv $ unEmb tv))) chk t@(L loc _) = Left (loc, vcat [ text "Unexpected type" <+> quotes (ppr t) @@ -743,7 +746,7 @@ checkTyClHdr is_cls ty goL (L l ty) acc ann fix = go l ty acc ann fix go l (HsTyVar _ (L _ tc)) acc ann fix - | isRdrTc tc = return (L l tc, acc, fix, ann) + | isRdrTc $ unEmb tc = return (L l $ unEmb tc, acc, fix, ann) go _ (HsOpTy t1 ltc@(L _ tc) t2) acc ann _fix | isRdrTc tc = return (ltc, t1:t2:acc, Infix, ann) go l (HsParTy ty) acc ann fix = goL ty acc (ann ++ mkParensApiAnn l) fix @@ -753,9 +756,9 @@ checkTyClHdr is_cls ty = goL head (args ++ acc) ann fixity go _ (HsAppsTy [L _ (HsAppInfix (L loc star))]) [] ann fix - | occNameFS (rdrNameOcc star) == fsLit "*" + | occNameFS (rdrNameOcc $ unEmb star) == fsLit "*" = return (L loc (nameRdrName starKindTyConName), [], fix, ann) - | occNameFS (rdrNameOcc star) == fsLit "★" + | occNameFS (rdrNameOcc $ unEmb star) == fsLit "★" = return (L loc (nameRdrName unicodeStarKindTyConName), [], fix, ann) go l (HsTupleTy HsBoxedOrConstraintTuple ts) [] ann fix @@ -806,7 +809,8 @@ checkLPat msg e@(L l _) = checkPat msg l e [] checkPat :: SDoc -> SrcSpan -> LHsExpr RdrName -> [LPat RdrName] -> P (LPat RdrName) checkPat _ loc (L l (HsVar (L _ c))) args - | isRdrDataCon c = return (L loc (ConPatIn (L l c) (PrefixCon args))) + | isRdrDataCon $ unEmb c + = return (L loc (ConPatIn (L l $ unEmb c) (PrefixCon args))) checkPat msg loc e args -- OK to let this happen even if bang-patterns -- are not enabled, because there is no valid -- non-bang-pattern parse of (C ! e) @@ -827,9 +831,9 @@ checkAPat msg loc e0 = do pState <- getPState let opts = options pState case e0 of - EWildPat -> return (WildPat placeHolderType) - HsVar x -> return (VarPat x) - HsLit l -> return (LitPat l) + EWildPat -> return (WildPat placeHolderType) + HsVar (L l x) -> return (VarPat (L l $ unEmb x)) + HsLit l -> return (LitPat l) -- Overloaded numeric patterns (e.g. f 0 x = x) -- Negation is recorded separately, so that the literal is zero or +ve @@ -839,7 +843,7 @@ checkAPat msg loc e0 = do -> return (mkNPat (L l pos_lit) (Just noSyntaxExpr)) SectionR (L lb (HsVar (L _ bang))) e -- (! x) - | bang == bang_RDR + | unEmb bang == bang_RDR -> do { bang_on <- extension bangPatEnabled ; if bang_on then do { e' <- checkLPat msg e ; addAnnotation loc AnnBang lb @@ -857,14 +861,17 @@ checkAPat msg loc e0 = do -- n+k patterns OpApp (L nloc (HsVar (L _ n))) (L _ (HsVar (L _ plus))) _ (L lloc (HsOverLit lit@(OverLit {ol_val = HsIntegral {}}))) - | extopt LangExt.NPlusKPatterns opts && (plus == plus_RDR) - -> return (mkNPlusKPat (L nloc n) (L lloc lit)) + | extopt LangExt.NPlusKPatterns opts && + (unEmb plus == plus_RDR) + -> return (mkNPlusKPat (L nloc $ unEmb n) (L lloc lit)) OpApp l op _fix r -> do l <- checkLPat msg l r <- checkLPat msg r case op of - L cl (HsVar (L _ c)) | isDataOcc (rdrNameOcc c) - -> return (ConPatIn (L cl c) (InfixCon l r)) + L cl (HsVar (L _ c)) + | isDataOcc (rdrNameOcc $ unEmb c) + -> return (ConPatIn (L cl $ unEmb c) + (InfixCon l r)) _ -> patFail msg loc e0 HsPar e -> checkLPat msg e >>= (return . ParPat) @@ -893,7 +900,7 @@ checkAPat msg loc e0 = do placeHolderPunRhs :: LHsExpr RdrName -- The RHS of a punned record field will be filled in by the renamer -- It's better not to make it an error, in case we want to print it when debugging -placeHolderPunRhs = noLoc (HsVar (noLoc pun_RDR)) +placeHolderPunRhs = noLoc (HsVar (noEmb pun_RDR)) plus_RDR, bang_RDR, pun_RDR :: RdrName plus_RDR = mkUnqual varName (fsLit "+") -- Hack @@ -974,11 +981,11 @@ checkPatBind msg lhs (L _ (_,grhss)) ; return ([],PatBind lhs grhss placeHolderType placeHolderNames ([],[])) } -checkValSigLhs :: LHsExpr RdrName -> P (Located RdrName) -checkValSigLhs (L _ (HsVar lrdr@(L _ v))) - | isUnqual v - , not (isDataOcc (rdrNameOcc v)) - = return lrdr +checkValSigLhs :: LHsExpr RdrName -> P (LEmbellished RdrName) +checkValSigLhs (L _ (HsVar (L l v))) + | isUnqual $ unEmb v + , not (isDataOcc (rdrNameOcc $ unEmb v)) + = return (L l v) checkValSigLhs lhs@(L l _) = parseErrorSDoc l ((text "Invalid type signature:" <+> @@ -997,7 +1004,7 @@ checkValSigLhs lhs@(L l _) -- A common error is to forget the ForeignFunctionInterface flag -- so check for that, and suggest. cf Trac #3805 -- Sadly 'foreign import' still barfs 'parse error' because 'import' is a keyword - looks_like s (L _ (HsVar (L _ v))) = v == s + looks_like s (L _ (HsVar (L _ v))) = unEmb v == s looks_like s (L _ (HsApp lhs _)) = looks_like s lhs looks_like _ _ = False @@ -1033,7 +1040,7 @@ checkDoAndIfThenElse guardExpr semiThen thenExpr semiElse elseExpr splitBang :: LHsExpr RdrName -> Maybe (LHsExpr RdrName, [LHsExpr RdrName]) -- Splits (f ! g a b) into (f, [(! g), a, b]) splitBang (L _ (OpApp l_arg bang@(L _ (HsVar (L _ op))) _ r_arg)) - | op == bang_RDR = Just (l_arg, L l' (SectionR bang arg1) : argns) + | unEmb op == bang_RDR = Just (l_arg, L l' (SectionR bang arg1) : argns) where l' = combineLocs bang arg1 (arg1,argns) = split_bang r_arg [] @@ -1058,7 +1065,8 @@ isFunLhs :: LHsExpr RdrName isFunLhs e = go e [] [] where go (L loc (HsVar (L _ f))) es ann - | not (isRdrDataCon f) = return (Just (L loc f, Prefix, es, ann)) + | not (isRdrDataCon $ unEmb f) + = return (Just (L loc (unEmb f), Prefix, es, ann)) go (L _ (HsApp f e)) es ann = go f (e:es) ann go (L l (HsPar e)) es@(_:_) ann = go e es (ann ++ mkParensApiAnn l) @@ -1079,10 +1087,10 @@ isFunLhs e = go e [] [] | Just (e',es') <- splitBang e = do { bang_on <- extension bangPatEnabled ; if bang_on then go e' (es' ++ es) ann - else return (Just (L loc' op, Infix, (l:r:es), ann)) } + else return (Just (L loc' (unEmb op), Infix, (l:r:es), ann)) } -- No bangs; behave just like the next case - | not (isRdrDataCon op) -- We have found the function! - = return (Just (L loc' op, Infix, (l:r:es), ann)) + | not (isRdrDataCon $ unEmb op) -- We have found the function! + = return (Just (L loc' (unEmb op), Infix, (l:r:es), ann)) | otherwise -- Infix data con; keep going = do { mb_l <- go l es ann ; case mb_l of @@ -1132,7 +1140,7 @@ splitTildeApps (t : rest) = do ty)))) = addAnnotation l AnnTilde tilde_loc >> return - [L tilde_loc (HsAppInfix (L tilde_loc eqTyCon_RDR)), + [L tilde_loc (HsAppInfix (L tilde_loc $ EName eqTyCon_RDR)), L l (HsAppPrefix ty)] -- NOTE: no annotation is attached to an HsAppPrefix, so the -- surrounding SrcSpan is not critical @@ -1260,8 +1268,8 @@ mkRecConstrOrUpdate -> P (HsExpr RdrName) mkRecConstrOrUpdate (L l (HsVar (L _ c))) _ (fs,dd) - | isRdrDataCon c - = return (mkRdrRecordCon (L l c) (mk_rec_fields fs dd)) + | isRdrDataCon $ unEmb c + = return (mkRdrRecordCon (L l $ unEmb c) (mk_rec_fields fs dd)) mkRecConstrOrUpdate exp@(L l _) _ (fs,dd) | dd = parseErrorSDoc l (text "You cannot use `..' in a record update") | otherwise = return (mkRdrRecordUpd exp (map (fmap mk_rec_upd_field) fs)) diff --git a/compiler/rename/RnBinds.hs b/compiler/rename/RnBinds.hs index f6a22f5df2..05a7080425 100644 --- a/compiler/rename/RnBinds.hs +++ b/compiler/rename/RnBinds.hs @@ -409,14 +409,15 @@ rnBindLHS name_maker _ bind@(FunBind { fun_id = rdr_name }) rnBindLHS name_maker _ (PatSynBind psb@PSB{ psb_id = rdrname }) | isTopRecNameMaker name_maker = do { addLocM checkConName rdrname - ; name <- lookupLocatedTopBndrRn rdrname -- Should be in scope already - ; return (PatSynBind psb{ psb_id = name }) } + ; L _ name <- lookupLocatedTopBndrRn $ unLEmb rdrname + -- Should be in scope already + ; return (PatSynBind psb{ psb_id = reLEmb rdrname name }) } | otherwise -- Pattern synonym, not at top level = do { addErr localPatternSynonymErr -- Complain, but make up a fake -- name so that we can carry on - ; name <- applyNameMaker name_maker rdrname - ; return (PatSynBind psb{ psb_id = name }) } + ; L _ name <- applyNameMaker name_maker $ unLEmb rdrname + ; return (PatSynBind psb{ psb_id = reLEmb rdrname name }) } where localPatternSynonymErr :: SDoc localPatternSynonymErr @@ -565,11 +566,11 @@ mkSigTvFn sigs = \n -> lookupNameEnv env n `orElse` [] get_scoped_tvs :: LSig Name -> Maybe ([Located Name], [Name]) -- Returns (binders, scoped tvs for those binders) get_scoped_tvs (L _ (ClassOpSig _ names sig_ty)) - = Just (names, hsScopedTvs sig_ty) + = Just (map unLEmb names, hsScopedTvs sig_ty) get_scoped_tvs (L _ (TypeSig names sig_ty)) - = Just (names, hsWcScopedTvs sig_ty) + = Just (map unLEmb names, hsWcScopedTvs sig_ty) get_scoped_tvs (L _ (PatSynSig names sig_ty)) - = Just (names, hsScopedTvs sig_ty) + = Just (map unLEmb names, hsScopedTvs sig_ty) get_scoped_tvs _ = Nothing -- Process the fixity declarations, making a FastString -> (Located Fixity) map @@ -587,19 +588,19 @@ makeMiniFixityEnv decls = foldlM add_one_sig emptyFsEnv decls foldlM add_one env [ (loc,name_loc,name,fixity) | L name_loc name <- names ] - add_one env (loc, name_loc, name,fixity) = do + add_one env (loc, name_loc, name, fixity) = do { -- this fixity decl is a duplicate iff -- the ReaderName's OccName's FastString is already in the env -- (we only need to check the local fix_env because -- definitions of non-local will be caught elsewhere) - let { fs = occNameFS (rdrNameOcc name) + let { fs = occNameFS (rdrNameOcc $ unEmb name) ; fix_item = L loc fixity }; case lookupFsEnv env fs of Nothing -> return $ extendFsEnv env fs fix_item Just (L loc' _) -> do { setSrcSpan loc $ - addErrAt name_loc (dupFixityDecl loc' name) + addErrAt name_loc (dupFixityDecl loc' (unEmb name)) ; return env} } @@ -625,7 +626,7 @@ rnPatSynBind sig_fn bind@(PSB { psb_id = L l name -- invariant: no free vars here when it's a FunBind = do { pattern_synonym_ok <- xoptM LangExt.PatternSynonyms ; unless pattern_synonym_ok (addErr patternSynonymErr) - ; let sig_tvs = sig_fn name + ; let sig_tvs = sig_fn $ unEmb name ; ((pat', details'), fvs1) <- bindSigTyVarsFV sig_tvs $ rnPat PatSyn pat $ \pat' -> @@ -662,10 +663,10 @@ rnPatSynBind sig_fn bind@(PSB { psb_id = L l name Unidirectional -> return (Unidirectional, emptyFVs) ImplicitBidirectional -> return (ImplicitBidirectional, emptyFVs) ExplicitBidirectional mg -> - do { (mg', fvs) <- bindSigTyVarsFV sig_tvs $ - rnMatchGroup (FunRhs (L l name) Prefix) - rnLExpr mg - ; return (ExplicitBidirectional mg', fvs) } + do { (mg', fvs) <- bindSigTyVarsFV sig_tvs $ + rnMatchGroup (FunRhs (L l $ unEmb name) Prefix) + rnLExpr mg + ; return (ExplicitBidirectional mg', fvs) } ; mod <- getModule ; let fvs = fvs1 `plusFV` fvs2 @@ -684,7 +685,7 @@ rnPatSynBind sig_fn bind@(PSB { psb_id = L l name _ -> [] ; fvs' `seq` -- See Note [Free-variable space leak] - return (bind', name : selector_names , fvs1) + return (bind', unEmb name : selector_names , fvs1) -- Why fvs1? See Note [Pattern synonym builders don't yield dependencies] } where @@ -888,7 +889,7 @@ renameSig _ (IdSig x) = return (IdSig x, emptyFVs) -- Actually this never occurs renameSig ctxt sig@(TypeSig vs ty) - = do { new_vs <- mapM (lookupSigOccRn ctxt sig) vs + = do { new_vs <- mapM (lookupLESigOccRn ctxt sig) vs ; let doc = TypeSigCtx (ppr_sig_bndrs vs) ; (new_ty, fvs) <- rnHsSigWcType doc ty ; return (TypeSig new_vs new_ty, fvs) } @@ -897,7 +898,7 @@ renameSig ctxt sig@(ClassOpSig is_deflt vs ty) = do { defaultSigs_on <- xoptM LangExt.DefaultSignatures ; when (is_deflt && not defaultSigs_on) $ addErr (defaultSigErr sig) - ; new_v <- mapM (lookupSigOccRn ctxt sig) vs + ; new_v <- mapM (lookupLESigOccRn ctxt sig) vs ; (new_ty, fvs) <- rnHsSigType ty_ctxt ty ; return (ClassOpSig is_deflt new_v new_ty, fvs) } where @@ -915,8 +916,8 @@ renameSig _ (SpecInstSig src ty) -- then the SPECIALISE pragma is ambiguous, unlike all other signatures renameSig ctxt sig@(SpecSig v tys inl) = do { new_v <- case ctxt of - TopSigCtxt {} -> lookupLocatedOccRn v - _ -> lookupSigOccRn ctxt sig v + TopSigCtxt {} -> lookupLEmbellishedOccRn v + _ -> lookupLESigOccRn ctxt sig v ; (new_ty, fvs) <- foldM do_one ([],emptyFVs) tys ; return (SpecSig new_v new_ty inl, fvs) } where @@ -927,19 +928,19 @@ renameSig ctxt sig@(SpecSig v tys inl) ; return ( new_ty:tys, fvs_ty `plusFV` fvs) } renameSig ctxt sig@(InlineSig v s) - = do { new_v <- lookupSigOccRn ctxt sig v + = do { new_v <- lookupLESigOccRn ctxt sig v ; return (InlineSig new_v s, emptyFVs) } renameSig ctxt sig@(FixSig (FixitySig vs f)) - = do { new_vs <- mapM (lookupSigOccRn ctxt sig) vs + = do { new_vs <- mapM (lookupLESigOccRn ctxt sig) vs ; return (FixSig (FixitySig new_vs f), emptyFVs) } renameSig ctxt sig@(MinimalSig s (L l bf)) - = do new_bf <- traverse (lookupSigOccRn ctxt sig) bf + = do new_bf <- traverse (lookupLESigOccRn ctxt sig) bf return (MinimalSig s (L l new_bf), emptyFVs) renameSig ctxt sig@(PatSynSig vs ty) - = do { new_vs <- mapM (lookupSigOccRn ctxt sig) vs + = do { new_vs <- mapM (lookupLESigOccRn ctxt sig) vs ; (ty', fvs) <- rnHsSigType ty_ctxt ty ; return (PatSynSig new_vs ty', fvs) } where @@ -947,17 +948,17 @@ renameSig ctxt sig@(PatSynSig vs ty) <+> ppr_sig_bndrs vs) renameSig ctxt sig@(SCCFunSig st v s) - = do { new_v <- lookupSigOccRn ctxt sig v + = do { new_v <- lookupLESigOccRn ctxt sig v ; return (SCCFunSig st new_v s, emptyFVs) } -- COMPLETE Sigs can refer to imported IDs which is why we use -- lookupLocatedOccRn rather than lookupSigOccRn renameSig _ctxt (CompleteMatchSig s (L l bf) mty) - = do new_bf <- traverse lookupLocatedOccRn bf - new_mty <- traverse lookupLocatedOccRn mty + = do new_bf <- traverse lookupLEmbellishedOccRn bf + new_mty <- traverse lookupLEmbellishedOccRn mty return (CompleteMatchSig s (L l new_bf) new_mty, emptyFVs) -ppr_sig_bndrs :: [Located RdrName] -> SDoc +ppr_sig_bndrs :: [LEmbellished RdrName] -> SDoc ppr_sig_bndrs bs = quotes (pprWithCommas ppr bs) okHsSig :: HsSigCtxt -> LSig a -> Bool @@ -1014,12 +1015,12 @@ findDupSigs :: [LSig RdrName] -> [[(Located RdrName, Sig RdrName)]] findDupSigs sigs = findDupsEq matching_sig (concatMap (expand_sig . unLoc) sigs) where - expand_sig sig@(FixSig (FixitySig ns _)) = zip ns (repeat sig) - expand_sig sig@(InlineSig n _) = [(n,sig)] - expand_sig sig@(TypeSig ns _) = [(n,sig) | n <- ns] - expand_sig sig@(ClassOpSig _ ns _) = [(n,sig) | n <- ns] - expand_sig sig@(PatSynSig ns _ ) = [(n,sig) | n <- ns] - expand_sig sig@(SCCFunSig _ n _) = [(n,sig)] + expand_sig sig@(FixSig (FixitySig ns _)) = zip (map unLEmb ns) (repeat sig) + expand_sig sig@(InlineSig n _) = [(unLEmb n,sig)] + expand_sig sig@(TypeSig ns _) = [(unLEmb n,sig) | n <- ns] + expand_sig sig@(ClassOpSig _ ns _) = [(unLEmb n,sig) | n <- ns] + expand_sig sig@(PatSynSig ns _ ) = [(unLEmb n,sig) | n <- ns] + expand_sig sig@(SCCFunSig _ n _) = [(unLEmb n,sig)] expand_sig _ = [] matching_sig (L _ n1,sig1) (L _ n2,sig2) = n1 == n2 && mtch sig1 sig2 diff --git a/compiler/rename/RnEnv.hs b/compiler/rename/RnEnv.hs index 7c05994c0a..3ed1bf8137 100644 --- a/compiler/rename/RnEnv.hs +++ b/compiler/rename/RnEnv.hs @@ -9,7 +9,9 @@ module RnEnv ( newTopSrcBinder, lookupLocatedTopBndrRn, lookupTopBndrRn, + lookupLEmbellishedTopBndrRn, lookupLocatedOccRn, lookupOccRn, lookupOccRn_maybe, + lookupLEmbellishedOccRn, lookupLocalOccRn_maybe, lookupInfoOccRn, lookupLocalOccThLvl_maybe, lookupTypeOccRn, lookupKindOccRn, @@ -19,6 +21,7 @@ module RnEnv ( addNameClashErrRn, HsSigCtxt(..), lookupLocalTcNames, lookupSigOccRn, + lookupLESigOccRn, lookupSigCtxtOccRn, lookupFixityRn, lookupFixityRn_help, @@ -249,6 +252,13 @@ lookupTopBndrRn n = do nopt <- lookupTopBndrRn_maybe n Nothing -> do traceRn "lookupTopBndrRn fail" (ppr n) unboundName WL_LocalTop n +lookupLEmbellishedTopBndrRn :: LEmbellished RdrName -> RnM (LEmbellished Name) +lookupLEmbellishedTopBndrRn = wrapLocM lookup + where + lookup en = do + n <- lookupTopBndrRn (unEmb en) + return (reEmb en n) + lookupLocatedTopBndrRn :: Located RdrName -> RnM (Located Name) lookupLocatedTopBndrRn = wrapLocM lookupTopBndrRn @@ -668,6 +678,13 @@ getLookupOccRn mkUnboundNameRdr :: RdrName -> Name mkUnboundNameRdr rdr = mkUnboundName (rdrNameOcc rdr) +lookupLEmbellishedOccRn :: LEmbellished RdrName -> RnM (LEmbellished Name) +lookupLEmbellishedOccRn = wrapLocM lookup + where + lookup emb = do + n <- lookupOccRn (unEmb emb) + return (reEmb emb n) + lookupLocatedOccRn :: Located RdrName -> RnM (Located Name) lookupLocatedOccRn = wrapLocM lookupOccRn @@ -921,7 +938,7 @@ lookupGlobalOccRn_overloaded overload_ok rdr_name ; let fld_occ :: FieldOcc Name fld_occ - = FieldOcc (noLoc rdr_name) (gre_name gre) + = FieldOcc (noEmb rdr_name) (gre_name gre) ; return (Just (Right [fld_occ])) } | otherwise -> do { addUsedGRE True gre @@ -931,7 +948,7 @@ lookupGlobalOccRn_overloaded overload_ok rdr_name -- until we know which is meant -> return (Just (Right - (map (FieldOcc (noLoc rdr_name) . gre_name) + (map (FieldOcc (noEmb rdr_name) . gre_name) gres))) gres -> do { addNameClashErrRn rdr_name gres ; return (Just (Left (gre_name (head gres)))) } } @@ -1224,6 +1241,13 @@ instance Outputable HsSigCtxt where ppr (HsBootCtxt ns) = text "HsBootCtxt" <+> ppr ns ppr (RoleAnnotCtxt ns) = text "RoleAnnotCtxt" <+> ppr ns +lookupLESigOccRn :: HsSigCtxt + -> Sig RdrName + -> LEmbellished RdrName -> RnM (LEmbellished Name) +lookupLESigOccRn ctxt sig le = do + L _ n <- lookupSigOccRn ctxt sig (unLEmb le) + return (reLEmb le n ) + lookupSigOccRn :: HsSigCtxt -> Sig RdrName -> Located RdrName -> RnM (Located Name) @@ -1496,8 +1520,8 @@ lookupTyFixityRn (L _ n) = lookupFixityRn n -- multiple possible selectors with different fixities, generate an error. lookupFieldFixityRn :: AmbiguousFieldOcc Name -> RnM Fixity lookupFieldFixityRn (Unambiguous (L _ rdr) n) - = lookupFixityRn' n (rdrNameOcc rdr) -lookupFieldFixityRn (Ambiguous (L _ rdr) _) = get_ambiguous_fixity rdr + = lookupFixityRn' n (rdrNameOcc $ unEmb rdr) +lookupFieldFixityRn (Ambiguous (L _ rdr) _) = get_ambiguous_fixity $ unEmb rdr where get_ambiguous_fixity :: RdrName -> RnM Fixity get_ambiguous_fixity rdr_name = do @@ -1636,10 +1660,10 @@ lookupSyntaxNames :: [Name] -- Standard names lookupSyntaxNames std_names = do { rebindable_on <- xoptM LangExt.RebindableSyntax ; if not rebindable_on then - return (map (HsVar . noLoc) std_names, emptyFVs) + return (map (HsVar . noEmb) std_names, emptyFVs) else do { usr_names <- mapM (lookupOccRn . mkRdrUnqual . nameOccName) std_names - ; return (map (HsVar . noLoc) usr_names, mkFVs usr_names) } } + ; return (map (HsVar . noEmb) usr_names, mkFVs usr_names) } } {- ********************************************************* diff --git a/compiler/rename/RnExpr.hs b/compiler/rename/RnExpr.hs index 4e9192c26e..ddbd76249c 100644 --- a/compiler/rename/RnExpr.hs +++ b/compiler/rename/RnExpr.hs @@ -78,14 +78,14 @@ rnLExpr = wrapLocFstM rnExpr rnExpr :: HsExpr RdrName -> RnM (HsExpr Name, FreeVars) -finishHsVar :: Located Name -> RnM (HsExpr Name, FreeVars) +finishHsVar :: LEmbellished Name -> RnM (HsExpr Name, FreeVars) -- Separated from rnExpr because it's also used -- when renaming infix expressions finishHsVar (L l name) = do { this_mod <- getModule - ; when (nameIsLocalOrFrom this_mod name) $ - checkThLocalName name - ; return (HsVar (L l name), unitFV name) } + ; when (nameIsLocalOrFrom this_mod $ unEmb name) $ + checkThLocalName $ unEmb name + ; return (HsVar (L l name), unitFV $ unEmb name) } rnUnboundVar :: RdrName -> RnM (HsExpr Name, FreeVars) rnUnboundVar v @@ -101,20 +101,20 @@ rnUnboundVar v else -- Fail immediately (qualified name) do { n <- reportUnboundName v - ; return (HsVar (noLoc n), emptyFVs) } } + ; return (HsVar (noEmb n), emptyFVs) } } rnExpr (HsVar (L l v)) = do { opt_DuplicateRecordFields <- xoptM LangExt.DuplicateRecordFields - ; mb_name <- lookupOccRn_overloaded opt_DuplicateRecordFields v + ; mb_name <- lookupOccRn_overloaded opt_DuplicateRecordFields $ unEmb v ; case mb_name of { - Nothing -> rnUnboundVar v ; + Nothing -> rnUnboundVar $ unEmb v ; Just (Left name) | name == nilDataConName -- Treat [] as an ExplicitList, so that -- OverloadedLists works correctly -> rnExpr (ExplicitList placeHolderType Nothing []) | otherwise - -> finishHsVar (L l name) ; + -> finishHsVar (L l (reEmb v name)) ; Just (Right [f@(FieldOcc (L _ fn) s)]) -> return (HsRecFld (ambiguousFieldOcc (FieldOcc (L l fn) s)) , unitFV (selectorFieldOcc f)) ; @@ -170,7 +170,7 @@ rnExpr (OpApp e1 op _ e2) -- more, so I've removed the test. Adding HsPars in TcGenDeriv -- should prevent bad things happening. ; fixity <- case op' of - L _ (HsVar (L _ n)) -> lookupFixityRn n + L _ (HsVar (L _ n)) -> lookupFixityRn $ unEmb n L _ (HsRecFld f) -> lookupFieldFixityRn f _ -> return (Fixity NoSourceText minPrecedence InfixL) -- c.f. lookupFixity for unbound @@ -289,7 +289,7 @@ rnExpr (RecordCon { rcon_con_name = con_id , rcon_con_expr = noPostTcExpr, rcon_con_like = PlaceHolder } , fvs `plusFV` plusFVs fvss `addOneFV` con_name) } where - mk_hs_var l n = HsVar (L l n) + mk_hs_var l n = HsVar (L l $ EName n) rn_field (L l fld) = do { (arg', fvs) <- rnLExpr (hsRecFieldArg fld) ; return (L l (fld { hsRecFieldArg = arg' }), fvs) } @@ -481,7 +481,7 @@ rnCmd (HsCmdArrForm op _ (Just _) [arg1, arg2]) ; (arg1',fv_arg1) <- rnCmdTop arg1 ; (arg2',fv_arg2) <- rnCmdTop arg2 -- Deal with fixity - ; fixity <- lookupFixityRn op_name + ; fixity <- lookupFixityRn $ unEmb op_name ; final_e <- mkOpFormRn arg1' op' fixity arg2' ; return (final_e, fv_arg1 `plusFV` fv_op `plusFV` fv_arg2) } @@ -972,12 +972,12 @@ lookupStmtNamePoly ctxt name = do { rebindable_on <- xoptM LangExt.RebindableSyntax ; if rebindable_on then do { fm <- lookupOccRn (nameRdrName name) - ; return (HsVar (noLoc fm), unitFV fm) } + ; return (HsVar (noEmb fm), unitFV fm) } else not_rebindable } | otherwise = not_rebindable where - not_rebindable = return (HsVar (noLoc name), emptyFVs) + not_rebindable = return (HsVar (noEmb name), emptyFVs) -- | Is this a context where we respect RebindableSyntax? -- but ListComp/PArrComp are never rebindable @@ -1820,7 +1820,7 @@ isReturnApp monad_names (L _ e) = case e of where is_var f (L _ (HsPar e)) = is_var f e is_var f (L _ (HsAppType e _)) = is_var f e - is_var f (L _ (HsVar (L _ r))) = f r + is_var f (L _ (HsVar (L _ r))) = f $ unEmb r -- TODO: I don't know how to get this right for rebindable syntax is_var _ _ = False diff --git a/compiler/rename/RnNames.hs b/compiler/rename/RnNames.hs index dc9cdd9063..15e6133393 100644 --- a/compiler/rename/RnNames.hs +++ b/compiler/rename/RnNames.hs @@ -577,7 +577,7 @@ getLocalNonValBinders fixity_env -- type sigs in case of a hs-boot file only ; is_boot <- tcIsHsBootOrSig ; let val_bndrs | is_boot = hs_boot_sig_bndrs - | otherwise = for_hs_bndrs + | otherwise = map lEmb for_hs_bndrs ; val_avails <- mapM new_simple val_bndrs ; let avails = concat nti_availss ++ val_avails @@ -607,15 +607,16 @@ getLocalNonValBinders fixity_env -- the SrcSpan attached to the input should be the span of the -- declaration, not just the name - new_simple :: Located RdrName -> RnM AvailInfo - new_simple rdr_name = do{ nm <- newTopSrcBinder rdr_name + new_simple :: LEmbellished RdrName -> RnM AvailInfo + new_simple rdr_name = do{ nm <- newTopSrcBinder $ unLEmb rdr_name ; return (avail nm) } new_tc :: Bool -> LTyClDecl RdrName -> RnM (AvailInfo, [(Name, [FieldLabel])]) new_tc overload_ok tc_decl -- NOT for type/data instances = do { let (bndrs, flds) = hsLTyClDeclBinders tc_decl - ; names@(main_name : sub_names) <- mapM newTopSrcBinder bndrs + ; names@(main_name : sub_names) + <- mapM (newTopSrcBinder . unLEmb) bndrs ; flds' <- mapM (newRecordSelector overload_ok sub_names) flds ; let fld_env = case unLoc tc_decl of DataDecl { tcdDataDefn = d } -> mk_fld_env d names flds' @@ -631,12 +632,12 @@ getLocalNonValBinders fixity_env where find_con_flds (L _ (ConDeclH98 { con_name = L _ rdr , con_details = RecCon cdflds })) - = [( find_con_name rdr + = [( find_con_name $ unEmb rdr , concatMap find_con_decl_flds (unLoc cdflds) )] find_con_flds (L _ (ConDeclGADT { con_names = rdrs , con_type = (HsIB { hsib_body = res_ty})})) - = map (\ (L _ rdr) -> ( find_con_name rdr + = map (\ (L _ rdr) -> ( find_con_name $ unEmb rdr , concatMap find_con_decl_flds cdflds)) rdrs where @@ -657,7 +658,7 @@ getLocalNonValBinders fixity_env find_con_decl_fld (L _ (FieldOcc (L _ rdr) _)) = expectJust "getLocalNonValBinders/find_con_decl_fld" $ find (\ fl -> flLabel fl == lbl) flds - where lbl = occNameFS (rdrNameOcc rdr) + where lbl = occNameFS (rdrNameOcc $ unEmb rdr) new_assoc :: Bool -> LInstDecl RdrName -> RnM ([AvailInfo], [(Name, [FieldLabel])]) @@ -683,7 +684,7 @@ getLocalNonValBinders fixity_env new_di overload_ok mb_cls ti_decl = do { main_name <- lookupFamInstName mb_cls (dfid_tycon ti_decl) ; let (bndrs, flds) = hsDataFamInstBinders ti_decl - ; sub_names <- mapM newTopSrcBinder bndrs + ; sub_names <- mapM (newTopSrcBinder . unLEmb) bndrs ; flds' <- mapM (newRecordSelector overload_ok sub_names) flds ; let avail = AvailTC (unLoc main_name) sub_names flds' -- main_name is not bound here! @@ -697,19 +698,19 @@ getLocalNonValBinders fixity_env newRecordSelector :: Bool -> [Name] -> LFieldOcc RdrName -> RnM FieldLabel newRecordSelector _ [] _ = error "newRecordSelector: datatype has no constructors!" newRecordSelector overload_ok (dc:_) (L loc (FieldOcc (L _ fld) _)) - = do { selName <- newTopSrcBinder $ L loc $ field + = do { selName <- newTopSrcBinder $ L loc $ unEmb field ; return $ qualFieldLbl { flSelector = selName } } where - fieldOccName = occNameFS $ rdrNameOcc fld + fieldOccName = occNameFS $ rdrNameOcc $ unEmb fld qualFieldLbl = mkFieldLabelOccs fieldOccName (nameOccName dc) overload_ok - field | isExact fld = fld + field | isExact $ unEmb fld = fld -- use an Exact RdrName as is to preserve the bindings -- of an already renamer-resolved field and its use -- sites. This is needed to correctly support record -- selectors in Template Haskell. See Note [Binders in -- Template Haskell] in Convert.hs and Note [Looking up -- Exact RdrNames] in RnEnv.hs. - | otherwise = mkRdrUnqual (flSelector qualFieldLbl) + | otherwise = EName $ mkRdrUnqual (flSelector qualFieldLbl) {- Note [Looking up family names in family instances] @@ -1618,8 +1619,9 @@ packageImportErr -- data T = :% Int Int -- from interface files, which always print in prefix form -checkConName :: RdrName -> TcRn () -checkConName name = checkErr (isRdrDataCon name) (badDataCon name) +checkConName :: Embellished RdrName -> TcRn () +checkConName name + = checkErr (isRdrDataCon $ unEmb name) (badDataCon $ unEmb name) badDataCon :: RdrName -> SDoc badDataCon name diff --git a/compiler/rename/RnPat.hs b/compiler/rename/RnPat.hs index 3417494e21..fcaf891995 100644 --- a/compiler/rename/RnPat.hs +++ b/compiler/rename/RnPat.hs @@ -426,9 +426,9 @@ rnPatAndThen mk (NPlusKPat rdr (L l lit) _ _ _ _) -- The Report says that n+k patterns must be in Integral rnPatAndThen mk (AsPat rdr pat) - = do { new_name <- newPatLName mk rdr + = do { new_name <- newPatLName mk $ unLEmb rdr ; pat' <- rnLPatAndThen mk pat - ; return (AsPat new_name pat') } + ; return (AsPat (reLEmb rdr (unLoc new_name)) pat') } rnPatAndThen mk p@(ViewPat expr pat _ty) = do { liftCps $ do { vp_flag <- xoptM LangExt.ViewPatterns @@ -589,13 +589,13 @@ rnHsRecFields ctxt mk_arg (HsRecFields { rec_flds = flds, rec_dotdot = dotdot }) = L loc (FieldOcc (L ll lbl) _) , hsRecFieldArg = arg , hsRecPun = pun })) - = do { sel <- setSrcSpan loc $ lookupRecFieldOcc parent doc lbl + = do { sel <- setSrcSpan loc $ lookupRecFieldOcc parent doc (unEmb lbl) ; arg' <- if pun - then do { checkErr pun_ok (badPun (L loc lbl)) - -- Discard any module qualifier (#11662) - ; let arg_rdr = mkRdrUnqual (rdrNameOcc lbl) - ; return (L loc (mk_arg loc arg_rdr)) } - else return arg + then do { checkErr pun_ok (badPun (L loc $ unEmb lbl)) + -- Discard any module qualifier (#11662) + ; let arg_rdr = mkRdrUnqual (rdrNameOcc $ unEmb lbl) + ; return (L loc (mk_arg loc arg_rdr)) } + else return arg ; return (L l (HsRecField { hsRecFieldLbl = L loc (FieldOcc (L ll lbl) sel) , hsRecFieldArg = arg' @@ -640,7 +640,8 @@ rnHsRecFields ctxt mk_arg (HsRecFields { rec_flds = flds, rec_dotdot = dotdot }) ; addUsedGREs dot_dot_gres ; return [ L loc (HsRecField - { hsRecFieldLbl = L loc (FieldOcc (L loc arg_rdr) sel) + { hsRecFieldLbl + = L loc (FieldOcc (L loc $ EName arg_rdr) sel) , hsRecFieldArg = L loc (mk_arg loc arg_rdr) , hsRecPun = False }) | fl <- dot_dot_fields @@ -724,17 +725,20 @@ rnHsRecUpdFields flds -- Defer renaming of overloaded fields to the typechecker -- See Note [Disambiguating record fields] in TcExpr if overload_ok - then do { mb <- lookupGlobalOccRn_overloaded overload_ok lbl + then do { mb <- lookupGlobalOccRn_overloaded + overload_ok (unEmb lbl) ; case mb of - Nothing -> do { addErr (unknownSubordinateErr doc lbl) - ; return (Right []) } + Nothing -> do + { addErr (unknownSubordinateErr doc + (unEmb lbl)) + ; return (Right []) } Just r -> return r } - else fmap Left $ lookupGlobalOccRn lbl + else fmap Left $ lookupGlobalOccRn $ unEmb lbl ; arg' <- if pun - then do { checkErr pun_ok (badPun (L loc lbl)) - -- Discard any module qualifier (#11662) - ; let arg_rdr = mkRdrUnqual (rdrNameOcc lbl) - ; return (L loc (HsVar (L loc arg_rdr))) } + then do { checkErr pun_ok (badPun (L loc $ unEmb lbl)) + -- Discard any module qualifier (#11662) + ; let arg_rdr = mkRdrUnqual (rdrNameOcc $ unEmb lbl) + ; return (L loc (HsVar (L loc (reEmb lbl arg_rdr)))) } else return arg ; (arg'', fvs) <- rnLExpr arg' @@ -766,10 +770,11 @@ getFieldIds flds = map (unLoc . hsRecFieldSel . unLoc) flds getFieldLbls :: [LHsRecField id arg] -> [RdrName] getFieldLbls flds - = map (unLoc . rdrNameFieldOcc . unLoc . hsRecFieldLbl . unLoc) flds + = map (unLocEmb . rdrNameFieldOcc . unLoc . hsRecFieldLbl . unLoc) flds getFieldUpdLbls :: [LHsRecUpdField id] -> [RdrName] -getFieldUpdLbls flds = map (rdrNameAmbiguousFieldOcc . unLoc . hsRecFieldLbl . unLoc) flds +getFieldUpdLbls flds + = map (unEmb . rdrNameAmbiguousFieldOcc . unLoc . hsRecFieldLbl . unLoc) flds needFlagDotDot :: HsRecFieldContext -> SDoc needFlagDotDot ctxt = vcat [text "Illegal `..' in record" <+> pprRFC ctxt, @@ -832,7 +837,7 @@ rnOverLit origLit ; (SyntaxExpr { syn_expr = from_thing_name }, fvs) <- lookupSyntaxName std_name ; let rebindable = case from_thing_name of - HsVar (L _ v) -> v /= std_name + HsVar (L _ v) -> unEmb v /= std_name _ -> panic "rnOverLit" ; return (lit { ol_witness = from_thing_name , ol_rebindable = rebindable diff --git a/compiler/rename/RnSource.hs b/compiler/rename/RnSource.hs index 3e462744e1..5234308475 100644 --- a/compiler/rename/RnSource.hs +++ b/compiler/rename/RnSource.hs @@ -284,12 +284,12 @@ rnSrcFixityDecls bndr_set fix_decls return [ L loc (FixitySig name fixity) | name <- names ] - lookup_one :: Located RdrName -> RnM [Located Name] + lookup_one :: LEmbellished RdrName -> RnM [LEmbellished Name] lookup_one (L name_loc rdr_name) = setSrcSpan name_loc $ -- this lookup will fail if the definition isn't local - do names <- lookupLocalTcNames sig_ctxt what rdr_name - return [ L name_loc name | (_, name) <- names ] + do names <- lookupLocalTcNames sig_ctxt what $ unEmb rdr_name + return [ L name_loc (reEmb rdr_name name) | (_, name) <- names ] what = text "fixity signature" {- @@ -325,14 +325,14 @@ rnSrcWarnDecls bndr_set decls' rn_deprec (Warning rdr_names txt) -- ensures that the names are defined locally - = do { names <- concatMapM (lookupLocalTcNames sig_ctxt what . unLoc) + = do { names <- concatMapM (lookupLocalTcNames sig_ctxt what . unLocEmb) rdr_names ; return [(rdrNameOcc rdr, txt) | (rdr, _) <- names] } what = text "deprecation" - warn_rdr_dups = findDupRdrNames $ concatMap (\(L _ (Warning ns _)) -> ns) - decls + warn_rdr_dups = findDupRdrNames + $ concatMap (\(L _ (Warning ns _)) -> map unLEmb ns) decls findDupRdrNames :: [Located RdrName] -> [[Located RdrName]] findDupRdrNames = findDupsEq (\ x -> \ y -> rdrNameOcc (unLoc x) == rdrNameOcc (unLoc y)) @@ -607,7 +607,7 @@ checkCanonicalInstances cls poly_ty mbinds = do isAliasMG MG {mg_alts = L _ [L _ (Match { m_pats = [], m_grhss = grhss })]} | GRHSs [L _ (GRHS [] body)] lbinds <- grhss , L _ EmptyLocalBinds <- lbinds - , L _ (HsVar (L _ rhsName)) <- body = Just rhsName + , L _ (HsVar (L _ rhsName)) <- body = Just $ unEmb rhsName isAliasMG _ = Nothing -- got "lhs = rhs" but expected something different @@ -1051,7 +1051,7 @@ validRuleLhs foralls lhs check (OpApp e1 op _ e2) = checkl op `mplus` checkl_e e1 `mplus` checkl_e e2 check (HsApp e1 e2) = checkl e1 `mplus` checkl_e e2 check (HsAppType e _) = checkl e - check (HsVar (L _ v)) | v `notElem` foralls = Nothing + check (HsVar (L _ v)) | unEmb v `notElem` foralls = Nothing check other = Just other -- Failure -- Check an argument @@ -1102,9 +1102,9 @@ rnHsVectDecl :: VectDecl RdrName -> RnM (VectDecl Name, 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 _))) - = do { var' <- lookupLocatedOccRn var + = do { var' <- lookupLEmbellishedOccRn var ; (rhs', fv_rhs) <- rnLExpr rhs - ; return (HsVect s var' rhs', fv_rhs `addOneFV` unLoc var') + ; return (HsVect s var' rhs', fv_rhs `addOneFV` unLocEmb var') } rnHsVectDecl (HsVect _ _var _rhs) = failWith $ vcat @@ -1112,24 +1112,26 @@ rnHsVectDecl (HsVect _ _var _rhs) , text "must be an identifier" ] rnHsVectDecl (HsNoVect s var) - = do { var' <- lookupLocatedTopBndrRn var -- only applies to local (not imported) names - ; return (HsNoVect s var', unitFV (unLoc var')) + = do { var' <- lookupLEmbellishedTopBndrRn var + -- only applies to local (not imported) names + ; return (HsNoVect s var', unitFV (unLocEmb var')) } rnHsVectDecl (HsVectTypeIn s isScalar tycon Nothing) - = do { tycon' <- lookupLocatedOccRn tycon - ; return (HsVectTypeIn s isScalar tycon' Nothing, unitFV (unLoc tycon')) + = do { tycon' <- lookupLEmbellishedOccRn tycon + ; return (HsVectTypeIn s isScalar tycon' Nothing + , unitFV (unLocEmb tycon')) } rnHsVectDecl (HsVectTypeIn s isScalar tycon (Just rhs_tycon)) - = do { tycon' <- lookupLocatedOccRn tycon - ; rhs_tycon' <- lookupLocatedOccRn rhs_tycon + = do { tycon' <- lookupLEmbellishedOccRn tycon + ; rhs_tycon' <- lookupLEmbellishedOccRn rhs_tycon ; return ( HsVectTypeIn s isScalar tycon' (Just rhs_tycon') - , mkFVs [unLoc tycon', unLoc rhs_tycon']) + , mkFVs [unLocEmb tycon', unLocEmb rhs_tycon']) } rnHsVectDecl (HsVectTypeOut _ _ _) = panic "RnSource.rnHsVectDecl: Unexpected 'HsVectTypeOut'" rnHsVectDecl (HsVectClassIn s cls) - = do { cls' <- lookupLocatedOccRn cls - ; return (HsVectClassIn s cls', unitFV (unLoc cls')) + = do { cls' <- lookupLEmbellishedOccRn cls + ; return (HsVectClassIn s cls', unitFV (unLocEmb cls')) } rnHsVectDecl (HsVectClassOut _) = panic "RnSource.rnHsVectDecl: Unexpected 'HsVectClassOut'" @@ -1514,8 +1516,8 @@ rnRoleAnnots tc_names role_annots -- decls defined in this group (see #10263) tycon' <- lookupSigCtxtOccRn (RoleAnnotCtxt tc_names) (text "role annotation") - tycon - ; return $ RoleAnnotDecl tycon' roles } + (unLEmb tycon) + ; return $ RoleAnnotDecl (reLEmb tycon (unLoc tycon')) roles } dupRoleAnnotErr :: [LRoleAnnotDecl RdrName] -> RnM () dupRoleAnnotErr [] = panic "dupRoleAnnotErr" @@ -1701,7 +1703,8 @@ rnTyClDecl (ClassDecl { tcdCtxt = context, tcdLName = lcls, -- Check the signatures -- First process the class op sigs (op_sigs), then the fixity sigs (non_op_sigs). - ; let sig_rdr_names_w_locs = [op | L _ (ClassOpSig False ops _) <- sigs + ; let sig_rdr_names_w_locs = [unLEmb op + | L _ (ClassOpSig False ops _) <- sigs , op <- ops] ; checkDupRdrNames sig_rdr_names_w_locs -- Typechecker is responsible for checking that we only @@ -2014,8 +2017,8 @@ rnConDecl decl@(ConDeclH98 { con_name = name, con_qvars = qtvs , con_cxt = mcxt, con_details = details , con_doc = mb_doc }) = do { _ <- addLocM checkConName name - ; new_name <- lookupLocatedTopBndrRn name - ; let doc = ConDeclCtx [new_name] + ; new_name <- lookupLEmbellishedTopBndrRn name + ; let doc = ConDeclCtx [unLEmb new_name] ; mb_doc' <- rnMbLHsDoc mb_doc ; (kvs, qtvs') <- get_con_qtvs (hsConDeclArgTys details) @@ -2025,7 +2028,8 @@ rnConDecl decl@(ConDeclH98 { con_name = name, con_qvars = qtvs Nothing -> return (Nothing,emptyFVs) Just lcxt -> do { (lctx',fvs) <- rnContext doc lcxt ; return (Just lctx',fvs) } - ; (new_details, fvs2) <- rnConDeclDetails (unLoc new_name) doc details + ; (new_details, fvs2) + <- rnConDeclDetails (unLocEmb new_name) doc details ; let (new_details',fvs3) = (new_details,emptyFVs) ; traceRn "rnConDecl" (ppr name <+> vcat [ text "free_kvs:" <+> ppr kvs @@ -2055,8 +2059,8 @@ rnConDecl decl@(ConDeclH98 { con_name = name, con_qvars = qtvs rnConDecl decl@(ConDeclGADT { con_names = names, con_type = ty , con_doc = mb_doc }) = do { mapM_ (addLocM checkConName) names - ; new_names <- mapM lookupLocatedTopBndrRn names - ; let doc = ConDeclCtx new_names + ; new_names <- mapM lookupLEmbellishedTopBndrRn names + ; let doc = ConDeclCtx $ map unLEmb new_names ; mb_doc' <- rnMbLHsDoc mb_doc ; (ty', fvs) <- rnHsSigType doc ty @@ -2115,16 +2119,16 @@ extendPatSynEnv val_decls local_fix_env thing = do { | L bind_loc (PatSynBind (PSB { psb_id = L _ n , psb_args = RecordPatSyn as })) <- bind = do - bnd_name <- newTopSrcBinder (L bind_loc n) - let rnames = map recordPatSynSelectorId as - mkFieldOcc :: Located RdrName -> LFieldOcc RdrName + bnd_name <- newTopSrcBinder (L bind_loc $ unEmb n) + let rnames = map (lEmb . recordPatSynSelectorId) as + mkFieldOcc :: LEmbellished RdrName -> LFieldOcc RdrName mkFieldOcc (L l name) = L l (FieldOcc (L l name) PlaceHolder) field_occs = map mkFieldOcc rnames flds <- mapM (newRecordSelector False [bnd_name]) field_occs return ((bnd_name, flds): names) | L bind_loc (PatSynBind (PSB { psb_id = L _ n})) <- bind = do - bnd_name <- newTopSrcBinder (L bind_loc n) + bnd_name <- newTopSrcBinder (L bind_loc $ unEmb n) return ((bnd_name, []): names) | otherwise = return names diff --git a/compiler/rename/RnSplice.hs b/compiler/rename/RnSplice.hs index b927a898c8..7e068c4e21 100644 --- a/compiler/rename/RnSplice.hs +++ b/compiler/rename/RnSplice.hs @@ -112,7 +112,7 @@ rnBracket e br_body rn_bracket :: ThStage -> HsBracket RdrName -> RnM (HsBracket Name, FreeVars) rn_bracket outer_stage br@(VarBr flg rdr_name) - = do { name <- lookupOccRn rdr_name + = do { name <- lookupOccRn $ unLocEmb rdr_name ; this_mod <- getModule ; when (flg && nameIsLocalOrFrom this_mod name) $ @@ -133,7 +133,7 @@ rn_bracket outer_stage br@(VarBr flg rdr_name) (quotedNameStageErr br) } } } - ; return (VarBr flg name, unitFV name) } + ; return (VarBr flg (reLEmb rdr_name name), unitFV name) } rn_bracket _ (ExpBr e) = do { (e', fvs) <- rnLExpr e ; return (ExpBr e', fvs) } @@ -344,11 +344,11 @@ mkQuasiQuoteExpr :: UntypedSpliceFlavour -> Name -> SrcSpan -> FastString -> LHs -- which is what we must run in a quasi-quote mkQuasiQuoteExpr flavour quoter q_span quote = L q_span $ HsApp (L q_span $ - HsApp (L q_span (HsVar (L q_span quote_selector))) + HsApp (L q_span (HsVar (L q_span $ EName quote_selector))) quoterExpr) quoteExpr where - quoterExpr = L q_span $! HsVar $! (L q_span quoter) + quoterExpr = L q_span $! HsVar $! (L q_span $ EName quoter) quoteExpr = L q_span $! HsLit $! HsString NoSourceText quote quote_selector = case flavour of UntypedExpSplice -> quoteExpName diff --git a/compiler/rename/RnTypes.hs b/compiler/rename/RnTypes.hs index b74064751d..8fe4abdd79 100644 --- a/compiler/rename/RnTypes.hs +++ b/compiler/rename/RnTypes.hs @@ -465,8 +465,8 @@ rnHsTyKi env ty@(HsQualTy { hst_ctxt = lctxt, hst_body = tau }) , fvs1 `plusFV` fvs2) } rnHsTyKi env (HsTyVar ip (L loc rdr_name)) - = do { name <- rnTyVar env rdr_name - ; return (HsTyVar ip (L loc name), unitFV name) } + = do { name <- rnTyVar env $ unEmb rdr_name + ; return (HsTyVar ip (L loc (reEmb rdr_name name)), unitFV name) } rnHsTyKi env ty@(HsOpTy ty1 l_op ty2) = setSrcSpan (getLoc l_op) $ @@ -563,7 +563,7 @@ rnHsTyKi env overall_ty@(HsAppsTy tys) let (non_syms, syms) = splitHsAppsTy tys -- Step 2: rename the pieces - ; (syms1, fvs1) <- mapFvRn (rnHsTyOp env overall_ty) syms + ; (syms1, fvs1) <- mapFvRn (rnHsTyOp env overall_ty . unLEmb) syms ; (non_syms1, fvs2) <- (mapFvRn . mapFvRn) (rnLHsTyKi env) non_syms -- Step 3: deal with *. See Note [Dealing with *] @@ -586,7 +586,8 @@ rnHsTyKi env overall_ty@(HsAppsTy tys) (non_syms1 : non_syms2 : non_syms) (L loc star : ops) | star `hasKey` starKindTyConKey || star `hasKey` unicodeStarKindTyConKey = deal_with_star acc1 acc2 - ((non_syms1 ++ L loc (HsTyVar NotPromoted (L loc star)) + ((non_syms1 + ++ L loc (HsTyVar NotPromoted (L loc $ EName star)) : non_syms2) : non_syms) ops deal_with_star acc1 acc2 (non_syms1 : non_syms) (op1 : ops) @@ -1104,7 +1105,7 @@ rnField fl_env env (L l (ConDeclField names ty haddock_doc)) lookupField :: FieldOcc RdrName -> FieldOcc Name lookupField (FieldOcc (L lr rdr) _) = FieldOcc (L lr rdr) (flSelector fl) where - lbl = occNameFS $ rdrNameOcc rdr + lbl = occNameFS $ rdrNameOcc $ unEmb rdr fl = expectJust "rnField" $ lookupFsEnv fl_env lbl {- @@ -1239,7 +1240,7 @@ instance Outputable OpName where get_op :: LHsExpr Name -> OpName -- An unbound name could be either HsVar or HsUnboundVar -- See RnExpr.rnUnboundVar -get_op (L _ (HsVar (L _ n))) = NormalOp n +get_op (L _ (HsVar (L _ n))) = NormalOp $ unEmb n get_op (L _ (HsUnboundVar uv)) = UnboundOp uv get_op (L _ (HsRecFld fld)) = RecFldOp fld get_op other = pprPanic "get_op" (ppr other) @@ -1643,7 +1644,7 @@ extract_lkind = extract_lty KindLevel extract_lty :: TypeOrKind -> LHsType RdrName -> FreeKiTyVars -> RnM FreeKiTyVars extract_lty t_or_k (L _ ty) acc = case ty of - HsTyVar _ ltv -> extract_tv t_or_k ltv acc + HsTyVar _ ltv -> extract_tv t_or_k (unLEmb ltv) acc HsBangTy _ ty -> extract_lty t_or_k ty acc HsRecTy flds -> foldrM (extract_lty t_or_k . cd_fld_type . unLoc) acc @@ -1687,7 +1688,7 @@ extract_apps t_or_k tys acc = foldrM (extract_app t_or_k) acc tys extract_app :: TypeOrKind -> LHsAppType RdrName -> 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 _ (HsAppInfix tv)) acc = extract_tv t_or_k (unLEmb 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 diff --git a/compiler/typecheck/Inst.hs b/compiler/typecheck/Inst.hs index 75b17ef039..57b2f465d8 100644 --- a/compiler/typecheck/Inst.hs +++ b/compiler/typecheck/Inst.hs @@ -94,7 +94,7 @@ newMethodFromName origin name inst_ty ; wrap <- ASSERT( not (isForAllTy ty) && isSingleton theta ) instCall origin [inst_ty] theta - ; return (mkHsWrap wrap (HsVar (noLoc id))) } + ; return (mkHsWrap wrap (HsVar (noEmb id))) } {- ************************************************************************ @@ -530,7 +530,7 @@ newNonTrivialOverloadedLit orig , ol_rebindable = rebindable }) res_ty = do { hs_lit <- mkOverLit val ; let lit_ty = hsLitType hs_lit - ; (_, fi') <- tcSyntaxOp orig (mkRnSyntaxExpr meth_name) + ; (_, fi') <- tcSyntaxOp orig (mkRnSyntaxExpr $ unEmb meth_name) [synKnownType lit_ty] res_ty $ \_ -> return () ; let L _ witness = nlHsSyntaxApps fi' [nlHsLit hs_lit] @@ -593,7 +593,7 @@ tcSyntaxName :: CtOrigin -- See Note [CmdSyntaxTable] in HsExpr tcSyntaxName orig ty (std_nm, HsVar (L _ user_nm)) - | std_nm == user_nm + | std_nm == unEmb user_nm = do rhs <- newMethodFromName orig std_nm ty return (std_nm, rhs) diff --git a/compiler/typecheck/TcAnnotations.hs b/compiler/typecheck/TcAnnotations.hs index 7b3cc65dd1..5d1f5a1071 100644 --- a/compiler/typecheck/TcAnnotations.hs +++ b/compiler/typecheck/TcAnnotations.hs @@ -42,7 +42,8 @@ tcAnnotation (L loc ann@(HsAnnotation _ provenance expr)) = do , text "See https://ghc.haskell.org/trac/ghc/ticket/10826" ] annProvenanceToTarget :: Module -> AnnProvenance Name -> AnnTarget Name -annProvenanceToTarget _ (ValueAnnProvenance (L _ name)) = NamedTarget name +annProvenanceToTarget _ (ValueAnnProvenance (L _ name)) + = NamedTarget $ unEmb name annProvenanceToTarget _ (TypeAnnProvenance (L _ name)) = NamedTarget name annProvenanceToTarget mod ModuleAnnProvenance = ModuleTarget mod diff --git a/compiler/typecheck/TcBinds.hs b/compiler/typecheck/TcBinds.hs index 25c40618f2..b451984b0e 100644 --- a/compiler/typecheck/TcBinds.hs +++ b/compiler/typecheck/TcBinds.hs @@ -235,7 +235,7 @@ tcCompleteSigs sigs = addErrCtxt (text "In" <+> ppr c) $ case mtc of Nothing -> infer_complete_match - Just tc -> check_complete_match tc + Just tc -> check_complete_match $ unLEmb tc where checkCLTypes acc = foldM checkCLType (acc, []) (unLoc lns) @@ -259,10 +259,10 @@ tcCompleteSigs sigs = -- See note [Typechecking Complete Matches] - checkCLType :: (CompleteSigType, [ConLike]) -> Located Name + checkCLType :: (CompleteSigType, [ConLike]) -> LEmbellished Name -> TcM (CompleteSigType, [ConLike]) checkCLType (cst, cs) n = do - cl <- addLocM tcLookupConLike n + cl <- addLocM tcLookupConLike $ unLEmb n let (_,_,_,_,_,_, res_ty) = conLikeFullSig cl res_ty_con = fst <$> splitTyConApp_maybe res_ty case (cst, res_ty_con) of @@ -315,8 +315,8 @@ tcHsBootSigs binds sigs where f (L _ name) = do { sigma_ty <- solveEqualities $ - tcHsSigWcType (FunSigCtxt name False) hs_ty - ; return (mkVanillaGlobal name sigma_ty) } + tcHsSigWcType (FunSigCtxt (unEmb name) False) hs_ty + ; return (mkVanillaGlobal (unEmb name) sigma_ty) } -- Notice that we make GlobalIds, not LocalIds tc_boot_sig s = pprPanic "tcHsBootSigs/tc_boot_sig" (ppr s) @@ -527,7 +527,7 @@ tc_single _top_lvl sig_fn _prag_fn } where tc_pat_syn_decl :: TcM (LHsBinds TcId, TcGblEnv) - tc_pat_syn_decl = case sig_fn name of + tc_pat_syn_decl = case sig_fn $ unEmb name of Nothing -> tcInferPatSynDecl psb Just (TcPatSynSig tpsi) -> tcCheckPatSynDecl psb tpsi Just _ -> panic "tc_single" @@ -1139,34 +1139,35 @@ tcVect :: VectDecl Name -> TcM (VectDecl TcId) -- from the vectoriser here. tcVect (HsVect s name rhs) = addErrCtxt (vectCtxt name) $ - do { var <- wrapLocM tcLookupId name + do { var <- wrapLocM tcLookupId $ unLEmb name ; let L rhs_loc (HsVar (L lv rhs_var_name)) = rhs - ; rhs_id <- tcLookupId rhs_var_name - ; return $ HsVect s var (L rhs_loc (HsVar (L lv rhs_id))) + ; rhs_id <- tcLookupId $ unEmb rhs_var_name + ; return $ HsVect s (reLEmb name (unLoc var)) + (L rhs_loc (HsVar (L lv (reEmb rhs_var_name rhs_id)))) } tcVect (HsNoVect s name) - = addErrCtxt (vectCtxt name) $ - do { var <- wrapLocM tcLookupId name - ; return $ HsNoVect s var + = addErrCtxt (vectCtxt $ unLEmb name) $ + do { var <- wrapLocM tcLookupId $ unLEmb name + ; return $ HsNoVect s (reLEmb name (unLoc var)) } tcVect (HsVectTypeIn _ isScalar lname rhs_name) = addErrCtxt (vectCtxt lname) $ - do { tycon <- tcLookupLocatedTyCon lname + do { tycon <- tcLookupLocatedTyCon $ unLEmb lname ; checkTc ( not isScalar -- either we have a non-SCALAR declaration || isJust rhs_name -- or we explicitly provide a vectorised type || tyConArity tycon == 0 -- otherwise the type constructor must be nullary ) scalarTyConMustBeNullary - ; rhs_tycon <- fmapMaybeM (tcLookupTyCon . unLoc) rhs_name + ; rhs_tycon <- fmapMaybeM (tcLookupTyCon . unLocEmb) rhs_name ; return $ HsVectTypeOut isScalar tycon rhs_tycon } tcVect (HsVectTypeOut _ _ _) = panic "TcBinds.tcVect: Unexpected 'HsVectTypeOut'" tcVect (HsVectClassIn _ lname) = addErrCtxt (vectCtxt lname) $ - do { cls <- tcLookupLocatedClass lname + do { cls <- tcLookupLocatedClass $ unLEmb lname ; return $ HsVectClassOut cls } tcVect (HsVectClassOut _) diff --git a/compiler/typecheck/TcClassDcl.hs b/compiler/typecheck/TcClassDcl.hs index 3b9e6ac431..ee49f7f238 100644 --- a/compiler/typecheck/TcClassDcl.hs +++ b/compiler/typecheck/TcClassDcl.hs @@ -135,8 +135,10 @@ tcClassSigs clas sigs def_methods ; traceTc "tcClassSigs 2" (ppr clas) ; return op_info } where - vanilla_sigs = [L loc (nm,ty) | L loc (ClassOpSig False nm ty) <- sigs] - gen_sigs = [L loc (nm,ty) | L loc (ClassOpSig True nm ty) <- sigs] + vanilla_sigs = [L loc (map unLEmb nm,ty) + | L loc (ClassOpSig False nm ty) <- sigs] + gen_sigs = [L loc (map unLEmb nm,ty) + | L loc (ClassOpSig True nm ty) <- sigs] dm_bind_names :: [Name] -- These ones have a value binding in the class decl dm_bind_names = [op | L _ (FunBind {fun_id = L _ op}) <- bagToList def_methods] @@ -346,7 +348,7 @@ mkHsSigFun sigs = lookupNameEnv env env = mkHsSigEnv get_classop_sig sigs get_classop_sig :: LSig Name -> Maybe ([Located Name], LHsSigType Name) - get_classop_sig (L _ (ClassOpSig _ ns hs_ty)) = Just (ns, hs_ty) + get_classop_sig (L _ (ClassOpSig _ ns hs_ty)) = Just (map unLEmb ns,hs_ty) get_classop_sig _ = Nothing --------------------------- @@ -372,7 +374,7 @@ findMinimalDef :: [LSig Name] -> Maybe ClassMinimalDef findMinimalDef = firstJusts . map toMinimalDef where toMinimalDef :: LSig Name -> Maybe ClassMinimalDef - toMinimalDef (L _ (MinimalSig _ (L _ bf))) = Just (fmap unLoc bf) + toMinimalDef (L _ (MinimalSig _ (L _ bf))) = Just (fmap unLocEmb bf) toMinimalDef _ = Nothing {- diff --git a/compiler/typecheck/TcEnv.hs b/compiler/typecheck/TcEnv.hs index 7b19cd0311..715da1fc94 100644 --- a/compiler/typecheck/TcEnv.hs +++ b/compiler/typecheck/TcEnv.hs @@ -575,13 +575,13 @@ tcAddDataFamConPlaceholders inst_decls thing_inside get_fi_cons :: DataFamInstDecl Name -> [Name] get_fi_cons (DataFamInstDecl { dfid_defn = HsDataDefn { dd_cons = cons } }) - = map unLoc $ concatMap (getConNames . unLoc) cons + = map unLocEmb $ concatMap (getConNames . unLoc) cons tcAddPatSynPlaceholders :: [PatSynBind Name Name] -> TcM a -> TcM a -- See Note [Don't promote pattern synonyms] tcAddPatSynPlaceholders pat_syns thing_inside - = tcExtendKindEnv2 [ (name, APromotionErr PatSynPE) + = tcExtendKindEnv2 [ (unEmb name, APromotionErr PatSynPE) | PSB{ psb_id = L _ name } <- pat_syns ] thing_inside @@ -593,8 +593,8 @@ getTypeSigNames sigs get_type_sig :: LSig Name -> NameSet -> NameSet get_type_sig sig ns = case sig of - L _ (TypeSig names _) -> extendNameSetList ns (map unLoc names) - L _ (PatSynSig names _) -> extendNameSetList ns (map unLoc names) + L _ (TypeSig names _) -> extendNameSetList ns (map unLocEmb names) + L _ (PatSynSig names _) -> extendNameSetList ns (map unLocEmb names) _ -> ns diff --git a/compiler/typecheck/TcErrors.hs b/compiler/typecheck/TcErrors.hs index 6d4e3def8c..1f9d253f01 100644 --- a/compiler/typecheck/TcErrors.hs +++ b/compiler/typecheck/TcErrors.hs @@ -30,6 +30,7 @@ import DataCon import TcEvidence import HsExpr ( UnboundVar(..) ) import HsBinds ( PatSynBind(..) ) +import HsEmbellished import Name import RdrName ( lookupGlobalRdrEnv, lookupGRE_Name, GlobalRdrEnv , mkRdrUnqual, isLocalGRE, greSrcSpan ) @@ -2347,7 +2348,7 @@ ctxtFixes has_ambig_tvs pred implics discardProvCtxtGivens :: CtOrigin -> [UserGiven] -> [UserGiven] discardProvCtxtGivens orig givens -- See Note [discardProvCtxtGivens] | ProvCtxtOrigin (PSB {psb_id = L _ name}) <- orig - = filterOut (discard name) givens + = filterOut (discard $ unEmb name) givens | otherwise = givens where diff --git a/compiler/typecheck/TcExpr.hs b/compiler/typecheck/TcExpr.hs index fe2bbab5cb..645fa7b8da 100644 --- a/compiler/typecheck/TcExpr.hs +++ b/compiler/typecheck/TcExpr.hs @@ -163,7 +163,7 @@ NB: The res_ty is always deeply skolemised. -} tcExpr :: HsExpr Name -> ExpRhoType -> TcM (HsExpr TcId) -tcExpr (HsVar (L _ name)) res_ty = tcCheckId name res_ty +tcExpr (HsVar (L _ name)) res_ty = tcCheckId (unEmb name) res_ty tcExpr (HsUnboundVar uv) res_ty = tcUnboundId uv res_ty tcExpr e@(HsApp {}) res_ty = tcApp1 e res_ty @@ -207,7 +207,7 @@ tcExpr e@(HsIPVar x) res_ty ; let ip_name = mkStrLitTy (hsIPNameFS x) ; ipClass <- tcLookupClass ipClassName ; ip_var <- emitWantedEvVar origin (mkClassPred ipClass [ip_name, ip_ty]) - ; tcWrapResult e (fromDict ipClass ip_name ip_ty (HsVar (noLoc ip_var))) + ; tcWrapResult e (fromDict ipClass ip_name ip_ty (HsVar (noEmb ip_var))) ip_ty res_ty } where -- Coerces a dictionary for `IP "x" t` into `t`. @@ -225,7 +225,8 @@ tcExpr e@(HsOverLabel mb_fromLabel l) res_ty ; let pred = mkClassPred isLabelClass [lbl, alpha] ; loc <- getSrcSpanM ; var <- emitWantedEvVar origin pred - ; tcWrapResult e (fromDict pred (HsVar (L loc var))) + ; tcWrapResult e (fromDict pred + (HsVar (L loc $ EName var))) alpha res_ty } } where -- Coerces a dictionary for `IsLabel "x" t` into `t`, @@ -235,7 +236,7 @@ tcExpr e@(HsOverLabel mb_fromLabel l) res_ty lbl = mkStrLitTy l applyFromLabel loc fromLabel = - L loc (HsVar (L loc fromLabel)) `HsAppType` + L loc (HsVar (L loc $ EName fromLabel)) `HsAppType` mkEmptyWildCardBndrs (L loc (HsTyLit (HsStrTy NoSourceText l))) tcExpr (HsLam match) res_ty @@ -346,20 +347,20 @@ See also Note [seqId magic] in MkId tcExpr expr@(OpApp arg1 op fix arg2) res_ty | (L loc (HsVar (L lv op_name))) <- op - , op_name `hasKey` seqIdKey -- Note [Typing rule for seq] + , unEmb op_name `hasKey` seqIdKey -- Note [Typing rule for seq] = do { arg1_ty <- newFlexiTyVarTy liftedTypeKind ; let arg2_exp_ty = res_ty ; arg1' <- tcArg op arg1 arg1_ty 1 ; arg2' <- addErrCtxt (funAppCtxt op arg2 2) $ tc_poly_expr_nc arg2 arg2_exp_ty ; arg2_ty <- readExpType arg2_exp_ty - ; op_id <- tcLookupId op_name + ; op_id <- tcLookupId $ unEmb op_name ; let op' = L loc (HsWrap (mkWpTyApps [arg1_ty, arg2_ty]) - (HsVar (L lv op_id))) + (HsVar (L lv $ reEmb op_name op_id))) ; return $ OpApp arg1' op' fix arg2' } | (L loc (HsVar (L lv op_name))) <- op - , op_name `hasKey` dollarIdKey -- Note [Typing rule for ($)] + , unEmb op_name `hasKey` dollarIdKey -- Note [Typing rule for ($)] = do { traceTc "Application rule" (ppr op) ; (arg1', arg1_ty) <- tcInferSigma arg1 @@ -390,12 +391,12 @@ tcExpr expr@(OpApp arg1 op fix arg2) res_ty ; wrap_res <- tcSubTypeHR orig1 (Just expr) op_res_ty res_ty -- op_res -> res - ; op_id <- tcLookupId op_name + ; op_id <- tcLookupId $ unEmb op_name ; res_ty <- readExpType res_ty ; let op' = L loc (HsWrap (mkWpTyApps [ getRuntimeRep "tcExpr ($)" res_ty , arg2_sigma , res_ty]) - (HsVar (L lv op_id))) + (HsVar (L lv $ reEmb op_name op_id))) -- arg1' :: arg1_ty -- wrap_arg1 :: arg1_ty "->" (arg2_sigma -> op_res_ty) -- wrap_res :: op_res_ty "->" res_ty @@ -819,7 +820,8 @@ tcExpr expr@(RecordUpd { rupd_expr = record_expr, rupd_flds = rbnds }) res_ty -- After this we know that rbinds is unambiguous ; rbinds <- disambiguateRecordBinds record_expr record_rho rbnds res_ty ; let upd_flds = map (unLoc . hsRecFieldLbl . unLoc) rbinds - upd_fld_occs = map (occNameFS . rdrNameOcc . rdrNameAmbiguousFieldOcc) upd_flds + upd_fld_occs = map (occNameFS . rdrNameOcc + . unEmb . rdrNameAmbiguousFieldOcc) upd_flds sel_ids = map selectorAmbiguousFieldOcc upd_flds -- STEP 0 -- Check that the field names are really field names @@ -1143,14 +1145,14 @@ tcApp m_herald orig_fun orig_args res_ty go (L _ (HsAppType e t)) args = go e (Right t:args) go (L loc (HsVar (L _ fun))) args - | fun `hasKey` tagToEnumKey + | unEmb fun `hasKey` tagToEnumKey , count isLeft args == 1 - = do { (wrap, expr, args) <- tcTagToEnum loc fun args res_ty + = do { (wrap, expr, args) <- tcTagToEnum loc (unEmb fun) args res_ty ; return (wrap, expr, args) } - | fun `hasKey` seqIdKey + | unEmb fun `hasKey` seqIdKey , count isLeft args == 2 - = do { (wrap, expr, args) <- tcSeq loc fun args res_ty + = do { (wrap, expr, args) <- tcSeq loc (unEmb fun) args res_ty ; return (wrap, expr, args) } go (L loc (HsRecFld (Ambiguous lbl _))) args@(Left (L _ arg) : _) @@ -1191,7 +1193,7 @@ mk_op_msg op = text "The operator" <+> quotes (ppr op) <+> text "takes" tcInferFun :: LHsExpr Name -> TcM (LHsExpr TcId, TcSigmaType) -- Infer type of a function tcInferFun (L loc (HsVar (L _ name))) - = do { (fun, ty) <- setSrcSpan loc (tcInferId name) + = do { (fun, ty) <- setSrcSpan loc (tcInferId $ unEmb name) -- Don't wrap a context around a plain Id ; return (L loc fun, ty) } @@ -1309,7 +1311,7 @@ tcSyntaxOpGen :: CtOrigin -> TcM (a, SyntaxExpr TcId) tcSyntaxOpGen orig (SyntaxExpr { syn_expr = HsVar (L _ op) }) arg_tys res_ty thing_inside - = do { (expr, sigma) <- tcInferId op + = do { (expr, sigma) <- tcInferId $ unEmb op ; (result, expr_wrap, arg_wraps, res_wrap) <- tcSynArgA orig sigma arg_tys res_ty $ thing_inside @@ -1580,14 +1582,15 @@ tcCheckId :: Name -> ExpRhoType -> TcM (HsExpr TcId) tcCheckId name res_ty = do { (expr, actual_res_ty) <- tcInferId name ; traceTc "tcCheckId" (vcat [ppr name, ppr actual_res_ty, ppr res_ty]) - ; addFunResCtxt False (HsVar (noLoc name)) actual_res_ty res_ty $ + ; addFunResCtxt False (HsVar (noEmb name)) actual_res_ty res_ty $ tcWrapResultO (OccurrenceOf name) expr actual_res_ty res_ty } tcCheckRecSelId :: AmbiguousFieldOcc Name -> ExpRhoType -> TcM (HsExpr TcId) tcCheckRecSelId f@(Unambiguous (L _ lbl) _) res_ty = do { (expr, actual_res_ty) <- tcInferRecSelId f ; addFunResCtxt False (HsRecFld f) actual_res_ty res_ty $ - tcWrapResultO (OccurrenceOfRecSel lbl) expr actual_res_ty res_ty } + tcWrapResultO (OccurrenceOfRecSel $ unEmb lbl) expr + actual_res_ty res_ty } tcCheckRecSelId (Ambiguous lbl _) res_ty = case tcSplitFunTy_maybe =<< checkingExpType_maybe res_ty of Nothing -> ambiguousSelector lbl @@ -1597,7 +1600,7 @@ tcCheckRecSelId (Ambiguous lbl _) res_ty ------------------------ tcInferRecSelId :: AmbiguousFieldOcc Name -> TcM (HsExpr TcId, TcRhoType) tcInferRecSelId (Unambiguous (L _ lbl) sel) - = do { (expr', ty) <- tc_infer_id lbl sel + = do { (expr', ty) <- tc_infer_id (unEmb lbl) sel ; return (expr', ty) } tcInferRecSelId (Ambiguous lbl _) = ambiguousSelector lbl @@ -1629,7 +1632,7 @@ tc_infer_assert assert_name = do { assert_error_id <- tcLookupId assertErrorName ; (wrap, id_rho) <- topInstantiate (OccurrenceOf assert_name) (idType assert_error_id) - ; return (mkHsWrap wrap (HsVar (noLoc assert_error_id)), id_rho) + ; return (mkHsWrap wrap (HsVar (noEmb assert_error_id)), id_rho) } tc_infer_id :: RdrName -> Name -> TcM (HsExpr TcId, TcSigmaType) @@ -1655,7 +1658,7 @@ tc_infer_id lbl id_name _ -> failWithTc $ ppr thing <+> text "used where a value identifier was expected" } where - return_id id = return (HsVar (noLoc id), idType id) + return_id id = return (HsVar (noEmb id), idType id) return_data_con con -- For data constructors, must perform the stupid-theta check @@ -1703,7 +1706,7 @@ tcUnboundId unbound res_ty , ctev_loc = loc} , cc_hole = ExprHole unbound } ; emitInsoluble can - ; tcWrapResultO (UnboundOccurrenceOf occ) (HsVar (noLoc ev)) ty res_ty } + ; tcWrapResultO (UnboundOccurrenceOf occ) (HsVar (noEmb ev)) ty res_ty } {- @@ -1785,7 +1788,7 @@ tcSeq loc fun_name args res_ty ; arg1' <- tcMonoExpr arg1 (mkCheckExpType arg1_ty) ; arg2' <- tcMonoExpr arg2 arg2_exp_ty ; res_ty <- readExpType res_ty -- by now, it's surely filled in - ; let fun' = L loc (HsWrap ty_args (HsVar (L loc fun))) + ; let fun' = L loc (HsWrap ty_args (HsVar (L loc $ EName fun))) ty_args = WpTyApp res_ty <.> WpTyApp arg1_ty ; return (idHsWrapper, fun', [Left arg1', Left arg2']) } @@ -1827,7 +1830,7 @@ tcTagToEnum loc fun_name args res_ty (mk_error ty' doc2) ; arg' <- tcMonoExpr arg (mkCheckExpType intPrimTy) - ; let fun' = L loc (HsWrap (WpTyApp rep_ty) (HsVar (L loc fun))) + ; let fun' = L loc (HsWrap (WpTyApp rep_ty) (HsVar (L loc $ EName fun))) rep_ty = mkTyConApp rep_tc rep_args ; return (mkWpCastR (mkTcSymCo coi), fun', [Left arg']) } @@ -1905,7 +1908,7 @@ checkCrossStageLifting id (Brack _ (TcPending ps_var lie_var)) ; lift <- if isStringTy id_ty then do { sid <- tcLookupId THNames.liftStringName -- See Note [Lifting strings] - ; return (HsVar (noLoc sid)) } + ; return (HsVar (noEmb sid)) } else setConstraintVar lie_var $ -- Put the 'lift' constraint into the right LIE @@ -2069,26 +2072,26 @@ See also Note [HsRecField and HsRecUpdField] in HsPat. -- Given a RdrName that refers to multiple record fields, and the type -- of its argument, try to determine the name of the selector that is -- meant. -disambiguateSelector :: Located RdrName -> Type -> TcM Name +disambiguateSelector :: LEmbellished RdrName -> Type -> TcM Name disambiguateSelector lr@(L _ rdr) parent_type = do { fam_inst_envs <- tcGetFamInstEnvs ; case tyConOf fam_inst_envs parent_type of Nothing -> ambiguousSelector lr Just p -> - do { xs <- lookupParents rdr + do { xs <- lookupParents $ unEmb rdr ; let parent = RecSelData p ; case lookup parent xs of Just gre -> do { addUsedGRE True gre ; return (gre_name gre) } - Nothing -> failWithTc (fieldNotInType parent rdr) } } + Nothing -> failWithTc (fieldNotInType parent $ unEmb rdr) }} -- This field name really is ambiguous, so add a suitable "ambiguous -- occurrence" error, then give up. -ambiguousSelector :: Located RdrName -> TcM a +ambiguousSelector :: LEmbellished RdrName -> TcM a ambiguousSelector (L _ rdr) = do { env <- getGlobalRdrEnv - ; let gres = lookupGRE_RdrName rdr env - ; setErrCtxt [] $ addNameClashErrRn rdr gres + ; let gres = lookupGRE_RdrName (unEmb rdr) env + ; setErrCtxt [] $ addNameClashErrRn (unEmb rdr) gres ; failM } -- Disambiguate the fields in a record update. @@ -2123,7 +2126,7 @@ disambiguateRecordBinds record_expr record_rho rbnds res_ty , [(RecSelParent, GlobalRdrElt)])] getUpdFieldsParents = fmap (zip rbnds) $ mapM - (lookupParents . unLoc . hsRecUpdFieldRdr . unLoc) + (lookupParents . unLocEmb . hsRecUpdFieldRdr . unLoc) rbnds -- Given a the lists of possible parents for each field, @@ -2172,7 +2175,7 @@ disambiguateRecordBinds record_expr record_rho rbnds res_ty -- The field doesn't belong to this parent, so report -- an error but keep going through all the fields Nothing -> do { addErrTc (fieldNotInType p - (unLoc (hsRecUpdFieldRdr (unLoc upd)))) + (unLocEmb (hsRecUpdFieldRdr (unLoc upd)))) ; lookupSelector (upd, gre_name (snd (head xs))) } -- Given a (field update, selector name) pair, look up the @@ -2311,7 +2314,7 @@ tcRecordField con_like flds_w_tys (L loc (FieldOcc lbl sel_name)) rhs = do { addErrTc (badFieldCon con_like field_lbl) ; return Nothing } where - field_lbl = occNameFS $ rdrNameOcc (unLoc lbl) + field_lbl = occNameFS $ rdrNameOcc (unLocEmb lbl) checkMissingFields :: ConLike -> HsRecordBinds Name -> TcM () @@ -2469,7 +2472,8 @@ badFieldsUpd rbinds data_cons membership :: [(FieldLabelString, [Bool])] membership = sortMembership $ map (\fld -> (fld, map (Set.member fld) fieldLabelSets)) $ - map (occNameFS . rdrNameOcc . rdrNameAmbiguousFieldOcc . unLoc . hsRecFieldLbl . unLoc) rbinds + map (occNameFS . rdrNameOcc . unEmb . rdrNameAmbiguousFieldOcc + . unLoc . hsRecFieldLbl . unLoc) rbinds fieldLabelSets :: [Set.Set FieldLabelString] fieldLabelSets = map (Set.fromList . map flLabel . conLikeFieldLabels) data_cons diff --git a/compiler/typecheck/TcGenDeriv.hs b/compiler/typecheck/TcGenDeriv.hs index 533664ec57..f0fe8645c3 100644 --- a/compiler/typecheck/TcGenDeriv.hs +++ b/compiler/typecheck/TcGenDeriv.hs @@ -773,7 +773,7 @@ gen_Ix_binds loc tycon = do enum_index dflags = mk_easy_FunBind loc unsafeIndex_RDR - [noLoc (AsPat (noLoc c_RDR) + [noLoc (AsPat (noEmb c_RDR) (nlTuplePat [a_Pat, nlWildPat] Boxed)), d_Pat] ( untag_Expr dflags tycon [(a_RDR, ah_RDR)] ( @@ -1314,7 +1314,7 @@ gen_data dflags data_type_name constr_names loc rep_tc genDataTyCon :: DerivStuff genDataTyCon -- $dT = DerivHsBind (mkHsVarBind loc data_type_name rhs, - L loc (TypeSig [L loc data_type_name] sig_ty)) + L loc (TypeSig [L loc (EName data_type_name)] sig_ty)) sig_ty = mkLHsSigWcType (nlHsTyVar dataType_RDR) rhs = nlHsVar mkDataType_RDR @@ -1324,7 +1324,7 @@ gen_data dflags data_type_name constr_names loc rep_tc genDataDataCon :: DataCon -> RdrName -> DerivStuff genDataDataCon dc constr_name -- $cT1 etc = DerivHsBind (mkHsVarBind loc constr_name rhs, - L loc (TypeSig [L loc constr_name] sig_ty)) + L loc (TypeSig [L loc (EName constr_name)] sig_ty)) where sig_ty = mkLHsSigWcType (nlHsTyVar constr_RDR) rhs = nlHsApps mkConstr_RDR constr_args @@ -1753,7 +1753,7 @@ genAuxBindSpec :: DynFlags -> SrcSpan -> AuxBindSpec -> (LHsBind RdrName, LSig RdrName) genAuxBindSpec dflags loc (DerivCon2Tag tycon) = (mk_FunBind loc rdr_name eqns, - L loc (TypeSig [L loc rdr_name] sig_ty)) + L loc (TypeSig [L loc (EName rdr_name)] sig_ty)) where rdr_name = con2tag_RDR dflags tycon @@ -1779,7 +1779,7 @@ genAuxBindSpec dflags loc (DerivTag2Con tycon) = (mk_FunBind loc rdr_name [([nlConVarPat intDataCon_RDR [a_RDR]], nlHsApp (nlHsVar tagToEnum_RDR) a_Expr)], - L loc (TypeSig [L loc rdr_name] sig_ty)) + L loc (TypeSig [L loc (EName rdr_name)] sig_ty)) where sig_ty = mkLHsSigWcType $ L loc $ HsCoreTy $ mkSpecForAllTys (tyConTyVars tycon) $ @@ -1789,7 +1789,7 @@ genAuxBindSpec dflags loc (DerivTag2Con tycon) genAuxBindSpec dflags loc (DerivMaxTag tycon) = (mkHsVarBind loc rdr_name rhs, - L loc (TypeSig [L loc rdr_name] sig_ty)) + L loc (TypeSig [L loc (EName rdr_name)] sig_ty)) where rdr_name = maxtag_RDR dflags tycon sig_ty = mkLHsSigWcType (L loc (HsCoreTy intTy)) diff --git a/compiler/typecheck/TcHsSyn.hs b/compiler/typecheck/TcHsSyn.hs index 6ad2b281f9..113cc24ed5 100644 --- a/compiler/typecheck/TcHsSyn.hs +++ b/compiler/typecheck/TcHsSyn.hs @@ -92,7 +92,7 @@ hsPatType (VarPat (L _ var)) = idType var hsPatType (BangPat pat) = hsLPatType pat hsPatType (LazyPat pat) = hsLPatType pat hsPatType (LitPat lit) = hsLitType lit -hsPatType (AsPat var _) = idType (unLoc var) +hsPatType (AsPat var _) = idType (unLocEmb var) hsPatType (ViewPat _ _ ty) = ty hsPatType (ListPat _ ty Nothing) = mkListTy ty hsPatType (ListPat _ _ (Just (ty,_))) = ty @@ -522,12 +522,12 @@ zonk_bind env (PatSynBind bind@(PSB { psb_id = L loc id , psb_args = details , psb_def = lpat , psb_dir = dir })) - = do { id' <- zonkIdBndr env id + = do { id' <- zonkIdBndr env $ unEmb id ; details' <- zonkPatSynDetails env details ; (env1, lpat') <- zonkPat env lpat ; (_env2, dir') <- zonkPatSynDir env1 dir ; return $ PatSynBind $ - bind { psb_id = L loc id' + bind { psb_id = L loc (reEmb id id') , psb_args = details' , psb_def = lpat' , psb_dir = dir' } } @@ -615,8 +615,8 @@ zonkLExprs env exprs = mapM (zonkLExpr env) exprs zonkLExpr env expr = wrapLocM (zonkExpr env) expr zonkExpr env (HsVar (L l id)) - = ASSERT2( isNothing (isDataConId_maybe id), ppr id ) - return (HsVar (L l (zonkIdOcc env id))) + = ASSERT2( isNothing (isDataConId_maybe $ unEmb id), ppr id ) + return (HsVar (L l (reEmb id (zonkIdOcc env $ unEmb id)))) zonkExpr _ e@(HsConLikeOut {}) = return e @@ -1204,9 +1204,9 @@ zonk_pat env (BangPat pat) ; return (env', BangPat pat') } zonk_pat env (AsPat (L loc v) pat) - = do { v' <- zonkIdBndr env v + = do { v' <- zonkIdBndr env (unEmb v) ; (env', pat') <- zonkPat (extendIdZonkEnv1 env v') pat - ; return (env', AsPat (L loc v') pat') } + ; return (env', AsPat (L loc (reEmb v v')) pat') } zonk_pat env (ViewPat expr pat ty) = do { expr' <- zonkLExpr env expr @@ -1389,13 +1389,13 @@ zonkVects env = mapM (wrapLocM (zonkVect env)) zonkVect :: ZonkEnv -> VectDecl TcId -> TcM (VectDecl Id) zonkVect env (HsVect s v e) - = do { v' <- wrapLocM (zonkIdBndr env) v + = do { v' <- wrapLocM (zonkIdBndr env) (unLEmb v) ; e' <- zonkLExpr env e - ; return $ HsVect s v' e' + ; return $ HsVect s (reLEmb v (unLoc v')) e' } zonkVect env (HsNoVect s v) - = do { v' <- wrapLocM (zonkIdBndr env) v - ; return $ HsNoVect s v' + = do { v' <- wrapLocM (zonkIdBndr env) (unLEmb v) + ; return $ HsNoVect s (reLEmb v (unLoc v')) } zonkVect _env (HsVectTypeOut s t rt) = return $ HsVectTypeOut s t rt diff --git a/compiler/typecheck/TcHsType.hs b/compiler/typecheck/TcHsType.hs index ef8d84c5cd..e2489e6206 100644 --- a/compiler/typecheck/TcHsType.hs +++ b/compiler/typecheck/TcHsType.hs @@ -429,7 +429,7 @@ tc_infer_lhs_type mode (L span ty) -- | Infer the kind of a type and desugar. This is the "up" type-checker, -- as described in Note [Bidirectional type checking] tc_infer_hs_type :: TcTyMode -> HsType Name -> TcM (TcType, TcKind) -tc_infer_hs_type mode (HsTyVar _ (L _ tv)) = tcTyVar mode tv +tc_infer_hs_type mode (HsTyVar _ (L _ tv)) = tcTyVar mode $ unEmb tv tc_infer_hs_type mode (HsAppTy ty1 ty2) = do { let (fun_ty, arg_tys) = splitHsAppTys ty1 [ty2] ; (fun_ty', fun_kind) <- tc_infer_lhs_type mode fun_ty diff --git a/compiler/typecheck/TcInstDcls.hs b/compiler/typecheck/TcInstDcls.hs index 95d33dde30..3601196975 100644 --- a/compiler/typecheck/TcInstDcls.hs +++ b/compiler/typecheck/TcInstDcls.hs @@ -907,7 +907,7 @@ addDFunPrags dfun_id sc_meth_ids is_newtype = isNewTyCon clas_tc wrapId :: HsWrapper -> id -> HsExpr id -wrapId wrapper id = mkHsWrap wrapper (HsVar (noLoc id)) +wrapId wrapper id = mkHsWrap wrapper (HsVar (noEmb id)) {- Note [Typechecking plan for instance declarations] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -1547,7 +1547,7 @@ mkDefMethBind clas inst_tys sel_id dm_name ; dm_id <- tcLookupId dm_name ; let inline_prag = idInlinePragma dm_id inline_prags | isAnyInlinePragma inline_prag - = [noLoc (InlineSig fn inline_prag)] + = [noLoc (InlineSig (lEmb fn) inline_prag)] | otherwise = [] -- Copy the inline pragma (if any) from the default method diff --git a/compiler/typecheck/TcPat.hs b/compiler/typecheck/TcPat.hs index ebf10cbb22..bc3935ea5b 100644 --- a/compiler/typecheck/TcPat.hs +++ b/compiler/typecheck/TcPat.hs @@ -357,8 +357,9 @@ tc_pat _ (WildPat _) pat_ty thing_inside ; return (WildPat pat_ty, res) } tc_pat penv (AsPat (L nm_loc name) pat) pat_ty thing_inside - = do { (wrap, bndr_id) <- setSrcSpan nm_loc (tcPatBndr penv name pat_ty) - ; (pat', res) <- tcExtendIdEnv1 name bndr_id $ + = do { (wrap, bndr_id) + <- setSrcSpan nm_loc (tcPatBndr penv (unEmb name) pat_ty) + ; (pat', res) <- tcExtendIdEnv1 (unEmb name) bndr_id $ tc_lpat pat (mkCheckExpType $ idType bndr_id) penv thing_inside -- NB: if we do inference on: @@ -369,7 +370,8 @@ tc_pat penv (AsPat (L nm_loc name) pat) pat_ty thing_inside -- -- If you fix it, don't forget the bindInstsOfPatIds! ; pat_ty <- readExpType pat_ty - ; return (mkHsWrapPat wrap (AsPat (L nm_loc bndr_id) pat') pat_ty, res) } + ; return (mkHsWrapPat wrap (AsPat (L nm_loc (reEmb name bndr_id)) pat') + pat_ty, res) } tc_pat penv (ViewPat expr pat _) overall_pat_ty thing_inside = do { @@ -977,7 +979,8 @@ tcConArgs con_like arg_tys (RecCon (HsRecFields rpats dd)) penv thing_inside tc_field (L l (HsRecField (L loc (FieldOcc (L lr rdr) sel)) pat pun)) penv thing_inside = do { sel' <- tcLookupId sel - ; pat_ty <- setSrcSpan loc $ find_field_ty (occNameFS $ rdrNameOcc rdr) + ; pat_ty <- setSrcSpan loc + $ find_field_ty (occNameFS $ rdrNameOcc $ unEmb rdr) ; (pat', res) <- tcConArg (pat, pat_ty) penv thing_inside ; return (L l (HsRecField (L loc (FieldOcc (L lr rdr) sel')) pat' pun), res) } diff --git a/compiler/typecheck/TcPatSyn.hs b/compiler/typecheck/TcPatSyn.hs index 587e2b8806..198f4fc156 100644 --- a/compiler/typecheck/TcPatSyn.hs +++ b/compiler/typecheck/TcPatSyn.hs @@ -78,7 +78,8 @@ tcInferPatSynDecl PSB{ psb_id = lname@(L _ name), psb_args = details, tcPat PatSyn lpat exp_ty $ mapM tcLookupId arg_names - ; let named_taus = (name, pat_ty) : map (\arg -> (getName arg, varType arg)) args + ; let named_taus = (unEmb name, pat_ty) + : map (\arg -> (getName arg, varType arg)) args ; (qtvs, req_dicts, ev_binds) <- simplifyInfer tclvl NoRestrictions [] named_taus wanted @@ -119,8 +120,9 @@ tcCheckPatSynDecl psb@PSB{ psb_id = lname@(L _ name), psb_args = details ; tcCheckPatSynPat lpat ; (arg_tys, pat_ty) <- case tcSplitFunTysN decl_arity sig_body_ty of - Right stuff -> return stuff - Left missing -> wrongNumberOfParmsErr name decl_arity missing + Right stuff -> return stuff + Left missing -> wrongNumberOfParmsErr + (unEmb name) decl_arity missing -- Complain about: pattern P :: () => forall x. x -> P x -- The existential 'x' should not appear in the result type @@ -168,7 +170,8 @@ tcCheckPatSynDecl psb@PSB{ psb_id = lname@(L _ name), psb_args = details ; args' <- zipWithM (tc_arg subst) arg_names arg_tys ; return (ex_tvs', prov_dicts, args') } - ; let skol_info = SigSkol (PatSynCtxt name) (mkPhiTy req_theta pat_ty) + ; let skol_info = SigSkol (PatSynCtxt $ unEmb name) + (mkPhiTy req_theta pat_ty) -- The type here is a bit bogus, but we do not print -- the type for PatSynCtxt, so it doesn't matter -- See TcRnTypes Note [Skolem info for pattern synonyms] @@ -266,7 +269,7 @@ collectPatSynArgInfo details = , recordPatSynSelectorId = L _ selId }) = (patVar, selId) -addPatSynCtxt :: Located Name -> TcM a -> TcM a +addPatSynCtxt :: LEmbellished Name -> TcM a -> TcM a addPatSynCtxt (L loc name) thing_inside = setSrcSpan loc $ addErrCtxt (text "In the declaration for pattern synonym" @@ -282,7 +285,7 @@ wrongNumberOfParmsErr name decl_arity missing ------------------------- -- Shared by both tcInferPatSyn and tcCheckPatSyn -tc_patsyn_finish :: Located Name -- ^ PatSyn Name +tc_patsyn_finish :: LEmbellished Name -- ^ PatSyn Name -> HsPatSynDir Name -- ^ PatSyn type (Uni/Bidir/ExplicitBidir) -> Bool -- ^ Whether infix -> LPat Id -- ^ Pattern of the PatSyn @@ -324,14 +327,14 @@ tc_patsyn_finish lname dir is_infix lpat' ppr pat_ty -- Make the 'matcher' - ; (matcher_id, matcher_bind) <- tcPatSynMatcher lname lpat' + ; (matcher_id, matcher_bind) <- tcPatSynMatcher (unLEmb lname) lpat' (binderVars univ_tvs, req_theta, req_ev_binds, req_dicts) (binderVars ex_tvs, ex_tys, prov_theta, prov_dicts) (args, arg_tys) pat_ty -- Make the 'builder' - ; builder_id <- mkPatSynBuilderId dir lname + ; builder_id <- mkPatSynBuilderId dir (unLEmb lname) univ_tvs req_theta ex_tvs prov_theta arg_tys pat_ty @@ -344,7 +347,7 @@ tc_patsyn_finish lname dir is_infix lpat' -- Make the PatSyn itself - ; let patSyn = mkPatSyn (unLoc lname) is_infix + ; let patSyn = mkPatSyn (unLocEmb lname) is_infix (univ_tvs, req_theta) (ex_tvs, prov_theta) arg_tys @@ -521,7 +524,7 @@ tcPatSynBuilderBind (PSB { psb_id = L loc name, psb_def = lpat , text "RHS pattern:" <+> ppr lpat ] | Right match_group <- mb_match_group -- Bidirectional - = do { patsyn <- tcLookupPatSyn name + = do { patsyn <- tcLookupPatSyn $ unEmb name ; traceTc "tcPatSynBuilderBind {" $ ppr patsyn ; let Just (builder_id, need_dummy_arg) = patSynBuilder patsyn -- Bidirectional, so patSynBuilder returns Just @@ -535,7 +538,7 @@ tcPatSynBuilderBind (PSB { psb_id = L loc name, psb_def = lpat , bind_fvs = placeHolderNamesTc , fun_tick = [] } - sig = completeSigFromId (PatSynCtxt name) builder_id + sig = completeSigFromId (PatSynCtxt $ unEmb name) builder_id ; (builder_binds, _) <- tcPolyCheck emptyPragEnv sig (noLoc bind) ; traceTc "tcPatSynBuilderBind }" $ ppr builder_binds @@ -553,7 +556,7 @@ tcPatSynBuilderBind (PSB { psb_id = L loc name, psb_def = lpat mk_mg body = mkMatchGroup Generated [builder_match] where builder_args = [L loc (VarPat (L loc n)) | L loc n <- args] - builder_match = mkMatch (FunRhs (L loc name) Prefix) + builder_match = mkMatch (FunRhs (L loc $ unEmb name) Prefix) builder_args body (noLoc EmptyLocalBinds) @@ -608,10 +611,10 @@ tcPatToExpr args pat = go pat -- Make a prefix con for prefix and infix patterns for simplicity mkPrefixConExpr :: Located Name -> [LPat Name] -> Either MsgDoc (HsExpr Name) - mkPrefixConExpr lcon@(L loc _) pats + mkPrefixConExpr (L loc n) pats = do { exprs <- mapM go pats ; return (foldl (\x y -> HsApp (L loc x) y) - (HsVar lcon) exprs) } + (HsVar (L loc (EName n))) exprs) } mkRecordConExpr :: Located Name -> HsRecFields Name (LPat Name) -> Either MsgDoc (HsExpr Name) @@ -634,7 +637,7 @@ tcPatToExpr args pat = go pat go1 (VarPat (L l var)) | var `elemNameSet` lhsVars - = return $ HsVar (L l var) + = return $ HsVar (L l $ EName var) | otherwise = Left (quotes (ppr var) <+> text "is not bound by the LHS of the pattern synonym") go1 (ParPat pat) = fmap HsPar $ go pat diff --git a/compiler/typecheck/TcRnDriver.hs b/compiler/typecheck/TcRnDriver.hs index 082b2fd693..6cd3a3544f 100644 --- a/compiler/typecheck/TcRnDriver.hs +++ b/compiler/typecheck/TcRnDriver.hs @@ -1609,7 +1609,7 @@ check_main dflags tcg_env explicit_mod_hdr ; res_ty <- newFlexiTyVarTy liftedTypeKind ; main_expr <- addErrCtxt mainCtxt $ - tcMonoExpr (L loc (HsVar (L loc main_name))) + tcMonoExpr (L loc (HsVar (L loc $ EName main_name))) (mkCheckExpType $ mkTyConApp ioTyCon [res_ty]) diff --git a/compiler/typecheck/TcRnTypes.hs b/compiler/typecheck/TcRnTypes.hs index f0ca574cd4..eb2ff37cbf 100644 --- a/compiler/typecheck/TcRnTypes.hs +++ b/compiler/typecheck/TcRnTypes.hs @@ -3105,10 +3105,11 @@ lexprCtOrigin :: LHsExpr Name -> CtOrigin lexprCtOrigin (L _ e) = exprCtOrigin e exprCtOrigin :: HsExpr Name -> CtOrigin -exprCtOrigin (HsVar (L _ name)) = OccurrenceOf name +exprCtOrigin (HsVar (L _ name)) = OccurrenceOf (unEmb name) exprCtOrigin (HsUnboundVar uv) = UnboundOccurrenceOf (unboundVarOcc uv) exprCtOrigin (HsConLikeOut {}) = panic "exprCtOrigin HsConLikeOut" -exprCtOrigin (HsRecFld f) = OccurrenceOfRecSel (rdrNameAmbiguousFieldOcc f) +exprCtOrigin (HsRecFld f) = OccurrenceOfRecSel + (unEmb $ rdrNameAmbiguousFieldOcc f) exprCtOrigin (HsOverLabel _ l) = OverLabelOrigin l exprCtOrigin (HsIPVar ip) = IPOccOrigin ip exprCtOrigin (HsOverLit lit) = LiteralOrigin lit diff --git a/compiler/typecheck/TcSigs.hs b/compiler/typecheck/TcSigs.hs index e26133ed3d..7da6df8d14 100644 --- a/compiler/typecheck/TcSigs.hs +++ b/compiler/typecheck/TcSigs.hs @@ -206,7 +206,8 @@ tcTySig (L loc (PatSynSig names sig_ty)) tcTySig _ = return [] -tcUserTypeSig :: SrcSpan -> LHsSigWcType Name -> Maybe Name -> TcM TcIdSigInfo +tcUserTypeSig :: SrcSpan -> LHsSigWcType Name -> Maybe (Embellished Name) + -> TcM TcIdSigInfo -- A function or expression type signature -- Returns a fully quantified type signature; even the wildcards -- are quantified with ordinary skolems that should be instantiated @@ -222,24 +223,24 @@ tcUserTypeSig loc hs_sig_ty mb_name | isCompleteHsSig hs_sig_ty = do { sigma_ty <- tcHsSigWcType ctxt_F hs_sig_ty ; return $ - CompleteSig { sig_bndr = mkLocalId name sigma_ty + CompleteSig { sig_bndr = mkLocalId (unEmb name) sigma_ty , sig_ctxt = ctxt_T , sig_loc = loc } } -- Location of the <type> in f :: <type> -- Partial sig with wildcards | otherwise - = return (PartialSig { psig_name = name, psig_hs_ty = hs_sig_ty + = return (PartialSig { psig_name = unEmb name, psig_hs_ty = hs_sig_ty , sig_ctxt = ctxt_F, sig_loc = loc }) where name = case mb_name of Just n -> n - Nothing -> mkUnboundName (mkVarOcc "<expression>") + Nothing -> EName $ mkUnboundName (mkVarOcc "<expression>") ctxt_F = case mb_name of - Just n -> FunSigCtxt n False + Just n -> FunSigCtxt (unEmb n) False Nothing -> ExprSigCtxt ctxt_T = case mb_name of - Just n -> FunSigCtxt n True + Just n -> FunSigCtxt (unEmb n) True Nothing -> ExprSigCtxt @@ -342,7 +343,7 @@ for example, in hs-boot file, we may need to think what to do... (eg don't have any implicitly-bound variables). -} -tcPatSynSig :: Name -> LHsSigType Name -> TcM TcPatSynInfo +tcPatSynSig :: Embellished Name -> LHsSigType Name -> TcM TcPatSynInfo tcPatSynSig name sig_ty | HsIB { hsib_vars = implicit_hs_tvs , hsib_body = hs_ty } <- sig_ty @@ -399,7 +400,7 @@ tcPatSynSig name sig_ty , text "ex_tvs" <+> ppr_tvs ex_tvs , text "prov" <+> ppr prov , text "body_ty" <+> ppr body_ty ] - ; return (TPSI { patsig_name = name + ; return (TPSI { patsig_name = unEmb name , patsig_implicit_bndrs = mkTyVarBinders Inferred kvs ++ mkTyVarBinders Specified implicit_tvs , patsig_univ_bndrs = univ_tvs @@ -408,7 +409,7 @@ tcPatSynSig name sig_ty , patsig_prov = prov , patsig_body_ty = body_ty }) } where - ctxt = PatSynCtxt name + ctxt = PatSynCtxt $ unEmb name build_patsyn_type kvs imp univ req ex prov body = mkInvForAllTys kvs $ @@ -503,15 +504,18 @@ mkPragEnv sigs binds prs = mapMaybe get_sig sigs get_sig :: LSig Name -> Maybe (Name, LSig Name) - get_sig (L l (SpecSig lnm@(L _ nm) ty inl)) = Just (nm, L l $ SpecSig lnm ty (add_arity nm inl)) - get_sig (L l (InlineSig lnm@(L _ nm) inl)) = Just (nm, L l $ InlineSig lnm (add_arity nm inl)) - get_sig (L l (SCCFunSig st lnm@(L _ nm) str)) = Just (nm, L l $ SCCFunSig st lnm str) + get_sig (L l (SpecSig lnm@(L _ nm) ty inl)) + = Just (unEmb nm, L l $ SpecSig lnm ty (add_arity nm inl)) + get_sig (L l (InlineSig lnm@(L _ nm) inl)) + = Just (unEmb nm, L l $ InlineSig lnm (add_arity nm inl)) + get_sig (L l (SCCFunSig st lnm@(L _ nm) str)) + = Just (unEmb nm, L l $ SCCFunSig st lnm str) get_sig _ = Nothing add_arity n inl_prag -- Adjust inl_sat field to match visible arity of function | Inline <- inl_inline inl_prag -- add arity only for real INLINE pragmas, not INLINABLE - = case lookupNameEnv ar_env n of + = case lookupNameEnv ar_env (unEmb n) of Just ar -> inl_prag { inl_sat = Just ar } Nothing -> WARN( True, text "mkPragEnv no arity" <+> ppr n ) -- There really should be a binding for every INLINE pragma @@ -746,9 +750,9 @@ tcImpPrags prags return [] else do { pss <- mapAndRecoverM (wrapLocM tcImpSpec) - [L loc (name,prag) + [L loc (unEmb name,prag) | (L loc prag@(SpecSig (L _ name) _ _)) <- prags - , not (nameIsLocalOrFrom this_mod name) ] + , not (nameIsLocalOrFrom this_mod $ unEmb name)] ; return $ concatMap (\(L l ps) -> map (L l) ps) pss } } where -- Ignore SPECIALISE pragmas for imported things diff --git a/compiler/typecheck/TcSplice.hs b/compiler/typecheck/TcSplice.hs index e5904943f7..a7942c16a7 100644 --- a/compiler/typecheck/TcSplice.hs +++ b/compiler/typecheck/TcSplice.hs @@ -573,7 +573,7 @@ runAnnotation target expr = do ; wrapper <- instCall AnnOrigin [expr_ty] [mkClassPred data_class [expr_ty]] ; let specialised_to_annotation_wrapper_expr = L loc (HsWrap wrapper - (HsVar (L loc to_annotation_wrapper_id))) + (HsVar (L loc $ EName to_annotation_wrapper_id))) ; return (L loc (HsApp specialised_to_annotation_wrapper_expr expr')) } -- Run the appropriately wrapped expression to get the value of diff --git a/compiler/typecheck/TcTyClsDecls.hs b/compiler/typecheck/TcTyClsDecls.hs index a66f401603..a0c76e9a89 100644 --- a/compiler/typecheck/TcTyClsDecls.hs +++ b/compiler/typecheck/TcTyClsDecls.hs @@ -475,7 +475,7 @@ getInitialKind decl@(DataDecl { tcdLName = L _ name Just ksig -> tcLHsKind ksig Nothing -> return liftedTypeKind ; return (res_k, ()) } - ; let inner_prs = [ (unLoc con, APromotionErr RecDataConPE) + ; let inner_prs = [ (unLocEmb con, APromotionErr RecDataConPE) | L _ con' <- cons, con <- getConNames con' ] ; return (mkTcTyConPair tycon : inner_prs) } @@ -573,7 +573,7 @@ kcTyClDecl (ClassDecl { tcdLName = L _ name do { _ <- tcHsContext ctxt ; mapM_ (wrapLocM kc_sig) sigs } where - kc_sig (ClassOpSig _ nms op_ty) = kcHsSigType nms op_ty + kc_sig (ClassOpSig _ nms op_ty) = kcHsSigType (map unLEmb nms) op_ty kc_sig _ = return () kcTyClDecl (FamDecl (FamilyDecl { fdLName = L _ fam_tc_name @@ -594,7 +594,7 @@ kcConDecl (ConDeclH98 { con_name = name, con_qvars = ex_tvs -- the 'False' says that the existentials don't have a CUSK, as the -- concept doesn't really apply here. We just need to bring the variables -- into scope. - do { _ <- kcHsTyVarBndrs (unLoc name) False False False False + do { _ <- kcHsTyVarBndrs (unLocEmb name) False False False False ((fromMaybe emptyLHsQTvs ex_tvs)) $ do { _ <- tcHsContext (fromMaybe (noLoc []) ex_ctxt) ; mapM_ (tcHsOpenType . getBangType) (hsConDeclArgTys details) @@ -606,7 +606,7 @@ kcConDecl (ConDeclH98 { con_name = name, con_qvars = ex_tvs kcConDecl (ConDeclGADT { con_names = names , con_type = ty }) = addErrCtxt (dataConCtxtName names) $ - do { _ <- tcGadtSigType (ppr names) (unLoc $ head names) ty + do { _ <- tcGadtSigType (ppr names) (unLocEmb $ head names) ty ; return () } @@ -1161,7 +1161,7 @@ kcDataDefn fam_name (HsIB { hsib_body = pats }) Just k -> do { k' <- tcLHsKind k ; unifyKind (Just hs_ty_pats) res_k k' } } where - hs_ty_pats = mkHsAppTys (noLoc $ HsTyVar NotPromoted (noLoc fam_name)) pats + hs_ty_pats = mkHsAppTys (noLoc $ HsTyVar NotPromoted (noEmb fam_name)) pats {- Kind check type patterns and kind annotate the embedded type variables. @@ -1469,7 +1469,7 @@ tcConDecl rep_tycon tmpl_bndrs res_tmpl do { traceTc "tcConDecl" (ppr name <+> text "tvs:" <+> ppr hs_tvs) ; ctxt <- tcHsContext (fromMaybe (noLoc []) hs_ctxt) ; btys <- tcConArgs hs_details - ; field_lbls <- lookupConstructorFields (unLoc name) + ; field_lbls <- lookupConstructorFields (unLocEmb name) ; let (arg_tys, stricts) = unzip btys bound_vars = allBoundVariabless ctxt `unionVarSet` allBoundVariabless arg_tys @@ -1509,10 +1509,10 @@ tcConDecl rep_tycon tmpl_bndrs res_tmpl ex_tvs = mkTyVarBinders Inferred qkvs ++ mkTyVarBinders Specified user_qtvs buildOneDataCon (L _ name) = do - { is_infix <- tcConIsInfixH98 name hs_details - ; rep_nm <- newTyConRepName name + { is_infix <- tcConIsInfixH98 (unEmb name) hs_details + ; rep_nm <- newTyConRepName $ unEmb name - ; buildDataCon fam_envs name is_infix rep_nm + ; buildDataCon fam_envs (unEmb name) is_infix rep_nm stricts Nothing field_lbls (mkDataConUnivTyVarBinders tmpl_bndrs) ex_tvs @@ -1531,7 +1531,7 @@ tcConDecl rep_tycon tmpl_bndrs res_tmpl = addErrCtxt (dataConCtxtName names) $ do { traceTc "tcConDecl 1" (ppr names) ; (user_tvs, ctxt, stricts, field_lbls, arg_tys, res_ty,hs_details) - <- tcGadtSigType (ppr names) (unLoc $ head names) ty + <- tcGadtSigType (ppr names) (unLocEmb $ head names) ty ; vars <- zonkTcTypeAndSplitDepVars (mkSpecForAllTys user_tvs $ mkFunTys ctxt $ @@ -1561,10 +1561,10 @@ tcConDecl rep_tycon tmpl_bndrs res_tmpl ; traceTc "tcConDecl 2" (ppr names $$ ppr field_lbls) ; let buildOneDataCon (L _ name) = do - { is_infix <- tcConIsInfixGADT name hs_details - ; rep_nm <- newTyConRepName name + { is_infix <- tcConIsInfixGADT (unEmb name) hs_details + ; rep_nm <- newTyConRepName $ unEmb name - ; buildDataCon fam_envs name is_infix + ; buildDataCon fam_envs (unEmb name) is_infix rep_nm stricts Nothing field_lbls univ_bndrs ex_bndrs eq_preds @@ -2910,7 +2910,7 @@ fieldTypeMisMatch field_name con1 con2 = sep [text "Constructors" <+> ppr con1 <+> text "and" <+> ppr con2, text "give different types for field", quotes (ppr field_name)] -dataConCtxtName :: [Located Name] -> SDoc +dataConCtxtName :: [LEmbellished Name] -> SDoc dataConCtxtName [con] = text "In the definition of data constructor" <+> quotes (ppr con) dataConCtxtName con diff --git a/compiler/typecheck/TcTyDecls.hs b/compiler/typecheck/TcTyDecls.hs index 96154cca8b..89cd83e3b4 100644 --- a/compiler/typecheck/TcTyDecls.hs +++ b/compiler/typecheck/TcTyDecls.hs @@ -840,12 +840,13 @@ mkOneRecordSelector all_cons idDetails fl | otherwise = map mk_match cons_w_field ++ deflt mk_match con = mkSimpleMatch (FunRhs sel_lname Prefix) [L loc (mk_sel_pat con)] - (L loc (HsVar (L loc field_var))) + (L loc (HsVar (L loc $ EName field_var))) mk_sel_pat con = ConPatIn (L loc (getName con)) (RecCon rec_fields) rec_fields = HsRecFields { rec_flds = [rec_field], rec_dotdot = Nothing } rec_field = noLoc (HsRecField { hsRecFieldLbl - = L loc (FieldOcc (L loc $ mkVarUnqual lbl) sel_name) + = L loc (FieldOcc (L loc $ EName $ mkVarUnqual lbl) + sel_name) , hsRecFieldArg = L loc (VarPat (L loc field_var)) , hsRecPun = False }) sel_lname = L loc sel_name @@ -855,11 +856,12 @@ mkOneRecordSelector all_cons idDetails fl -- We do this explicitly so that we get a nice error message that -- mentions this particular record selector deflt | all dealt_with all_cons = [] - | otherwise = [mkSimpleMatch CaseAlt - [L loc (WildPat placeHolderType)] - (mkHsApp (L loc (HsVar - (L loc (getName rEC_SEL_ERROR_ID)))) - (L loc (HsLit msg_lit)))] + | otherwise + = [mkSimpleMatch CaseAlt + [L loc (WildPat placeHolderType)] + (mkHsApp (L loc (HsVar + (L loc (EName $ getName rEC_SEL_ERROR_ID)))) + (L loc (HsLit msg_lit)))] -- Do not add a default case unless there are unmatched -- constructors. We must take account of GADTs, else we diff --git a/ghc/GHCi/UI/Info.hs b/ghc/GHCi/UI/Info.hs index ef5e9ef207..2d015030e4 100644 --- a/ghc/GHCi/UI/Info.hs +++ b/ghc/GHCi/UI/Info.hs @@ -321,7 +321,7 @@ processAllTypeCheckedModule tcm = do return $ fmap (\expr -> (mid, getLoc e, CoreUtils.exprType expr)) mbe where mid :: Maybe Id - mid | HsVar (L _ i) <- unwrapVar (unLoc e) = Just i + mid | HsVar (L _ i) <- unwrapVar (unLoc e) = Just $ unEmb i | otherwise = Nothing unwrapVar (HsWrap _ var) = var diff --git a/testsuite/tests/ghc-api/annotations/T10357.stdout b/testsuite/tests/ghc-api/annotations/T10357.stdout index 15d5139be5..d826e5076c 100644 --- a/testsuite/tests/ghc-api/annotations/T10357.stdout +++ b/testsuite/tests/ghc-api/annotations/T10357.stdout @@ -32,7 +32,6 @@ ((Test10357.hs:7:31-36,AnnVal), [Test10357.hs:7:33]), ((Test10357.hs:7:31-40,AnnVal), [Test10357.hs:7:38]), ((Test10357.hs:7:43-52,AnnBackquote), [Test10357.hs:7:43, Test10357.hs:7:52]), -((Test10357.hs:7:43-52,AnnVal), [Test10357.hs:7:44-51]), ((Test10357.hs:8:18-59,AnnCloseP), [Test10357.hs:8:59]), ((Test10357.hs:8:18-59,AnnOpenP), [Test10357.hs:8:18]), ((Test10357.hs:8:19-58,AnnVal), [Test10357.hs:8:43-52]), @@ -40,7 +39,6 @@ ((Test10357.hs:8:37-41,AnnOpenS), [Test10357.hs:8:37]), ((Test10357.hs:8:38-40,AnnMinus), [Test10357.hs:8:38]), ((Test10357.hs:8:43-52,AnnBackquote), [Test10357.hs:8:43, Test10357.hs:8:52]), -((Test10357.hs:8:43-52,AnnVal), [Test10357.hs:8:44-51]), ((Test10357.hs:10:7-20,AnnComma), [Test10357.hs:10:21]), ((Test10357.hs:10:7-20,AnnLarrow), [Test10357.hs:10:13-14]), ((Test10357.hs:10:16-20,AnnCloseS), [Test10357.hs:10:20]), diff --git a/testsuite/tests/ghc-api/annotations/T11321.stdout b/testsuite/tests/ghc-api/annotations/T11321.stdout index d4df67dfe5..8165425302 100644 --- a/testsuite/tests/ghc-api/annotations/T11321.stdout +++ b/testsuite/tests/ghc-api/annotations/T11321.stdout @@ -35,7 +35,6 @@ ((Test11321.hs:16:24-34,AnnTilde), [Test11321.hs:16:26]), ((Test11321.hs:16:28-30,AnnCloseP), [Test11321.hs:16:30]), ((Test11321.hs:16:28-30,AnnOpenP), [Test11321.hs:16:28]), -((Test11321.hs:16:28-30,AnnVal), [Test11321.hs:16:29]), ((Test11321.hs:17:11-18,AnnCloseP), [Test11321.hs:17:18]), ((Test11321.hs:17:11-18,AnnOpenP), [Test11321.hs:17:11]), ((Test11321.hs:17:20-27,AnnCloseP), [Test11321.hs:17:27]), diff --git a/testsuite/tests/ghc-api/annotations/T13163.stdout b/testsuite/tests/ghc-api/annotations/T13163.stdout index f216acdf98..d5f177786e 100644 --- a/testsuite/tests/ghc-api/annotations/T13163.stdout +++ b/testsuite/tests/ghc-api/annotations/T13163.stdout @@ -19,13 +19,11 @@ ((Test13163.hs:6:5-16,AnnOpenP), [Test13163.hs:6:13]), ((Test13163.hs:6:10-12,AnnCloseP), [Test13163.hs:6:12]), ((Test13163.hs:6:10-12,AnnOpenP), [Test13163.hs:6:10]), -((Test13163.hs:6:10-12,AnnVal), [Test13163.hs:6:11]), ((Test13163.hs:7:5,AnnComma), [Test13163.hs:7:6]), ((Test13163.hs:7:8-15,AnnComma), [Test13163.hs:7:16]), ((Test13163.hs:7:8-15,AnnType), [Test13163.hs:7:8-11]), ((Test13163.hs:7:13-15,AnnCloseP), [Test13163.hs:7:15]), ((Test13163.hs:7:13-15,AnnOpenP), [Test13163.hs:7:13]), -((Test13163.hs:7:13-15,AnnVal), [Test13163.hs:7:14]), ((Test13163.hs:7:18-31,AnnPattern), [Test13163.hs:7:18-24]), ((Test13163.hs:10:1-78,AnnImport), [Test13163.hs:10:1-6]), ((Test13163.hs:10:1-78,AnnSemi), [Test13163.hs:11:1]), @@ -35,21 +33,17 @@ ((Test13163.hs:10:32-41,AnnType), [Test13163.hs:10:32-35]), ((Test13163.hs:10:37-41,AnnCloseP), [Test13163.hs:10:41]), ((Test13163.hs:10:37-41,AnnOpenP), [Test13163.hs:10:37]), -((Test13163.hs:10:37-41,AnnVal), [Test13163.hs:10:38-40]), ((Test13163.hs:10:44-53,AnnComma), [Test13163.hs:10:54]), ((Test13163.hs:10:44-53,AnnType), [Test13163.hs:10:44-47]), ((Test13163.hs:10:49-53,AnnCloseP), [Test13163.hs:10:53]), ((Test13163.hs:10:49-53,AnnOpenP), [Test13163.hs:10:49]), -((Test13163.hs:10:49-53,AnnVal), [Test13163.hs:10:50-52]), ((Test13163.hs:10:56-65,AnnComma), [Test13163.hs:10:66]), ((Test13163.hs:10:56-65,AnnType), [Test13163.hs:10:56-59]), ((Test13163.hs:10:61-65,AnnCloseP), [Test13163.hs:10:65]), ((Test13163.hs:10:61-65,AnnOpenP), [Test13163.hs:10:61]), -((Test13163.hs:10:61-65,AnnVal), [Test13163.hs:10:62-64]), ((Test13163.hs:10:68-77,AnnType), [Test13163.hs:10:68-71]), ((Test13163.hs:10:73-77,AnnCloseP), [Test13163.hs:10:77]), ((Test13163.hs:10:73-77,AnnOpenP), [Test13163.hs:10:73]), -((Test13163.hs:10:73-77,AnnVal), [Test13163.hs:10:74-76]), ((Test13163.hs:11:1-61,AnnImport), [Test13163.hs:11:1-6]), ((Test13163.hs:11:1-61,AnnSemi), [Test13163.hs:12:1]), ((Test13163.hs:11:24-61,AnnCloseP), [Test13163.hs:11:61]), @@ -62,7 +56,6 @@ ((Test13163.hs:11:47-60,AnnOpenP), [Test13163.hs:11:57]), ((Test13163.hs:11:52-56,AnnCloseP), [Test13163.hs:11:56]), ((Test13163.hs:11:52-56,AnnOpenP), [Test13163.hs:11:52]), -((Test13163.hs:11:52-56,AnnVal), [Test13163.hs:11:53-55]), ((Test13163.hs:12:1-19,AnnImport), [Test13163.hs:12:1-6]), ((Test13163.hs:12:1-19,AnnSemi), [Test13163.hs:14:1]), ((Test13163.hs:14:1-22,AnnEqual), [Test13163.hs:14:18]), diff --git a/testsuite/tests/ghc-api/landmines/landmines.stdout b/testsuite/tests/ghc-api/landmines/landmines.stdout index 61ddb374a7..766bccaa28 100644 --- a/testsuite/tests/ghc-api/landmines/landmines.stdout +++ b/testsuite/tests/ghc-api/landmines/landmines.stdout @@ -1,4 +1,4 @@ -(12,12,8) +(13,13,8) (93,63,0) (15,13,8) (10,10,8) diff --git a/testsuite/tests/parser/should_compile/DumpParsedAst.hs b/testsuite/tests/parser/should_compile/DumpParsedAst.hs index 0f83b12f65..c95706630f 100644 --- a/testsuite/tests/parser/should_compile/DumpParsedAst.hs +++ b/testsuite/tests/parser/should_compile/DumpParsedAst.hs @@ -9,3 +9,7 @@ type family Length (as :: [k]) :: Peano where Length '[] = Zero main = putStrLn "hello" + +foo = 5 `mod` 2 + +bar = (+) 3 4 diff --git a/testsuite/tests/parser/should_compile/DumpParsedAst.stderr b/testsuite/tests/parser/should_compile/DumpParsedAst.stderr index 9f6b869871..b1c971859a 100644 --- a/testsuite/tests/parser/should_compile/DumpParsedAst.stderr +++ b/testsuite/tests/parser/should_compile/DumpParsedAst.stderr @@ -28,7 +28,8 @@ ({ DumpParsedAst.hs:5:14-17 } (ConDeclH98 ({ DumpParsedAst.hs:5:14-17 } - (Unqual {OccName: Zero})) + (EName + (Unqual {OccName: Zero}))) (Nothing) (Just ({ <no location info> } @@ -39,7 +40,8 @@ ({ DumpParsedAst.hs:5:21-30 } (ConDeclH98 ({ DumpParsedAst.hs:5:21-24 } - (Unqual {OccName: Succ})) + (EName + (Unqual {OccName: Succ}))) (Nothing) (Just ({ <no location info> } @@ -50,7 +52,8 @@ (HsTyVar (NotPromoted) ({ DumpParsedAst.hs:5:26-30 } - (Unqual {OccName: Peano}))))]) + (EName + (Unqual {OccName: Peano})))))]) (Nothing)))] ({ <no location info> } [])) @@ -81,18 +84,21 @@ (HsTyVar (NotPromoted) ({ DumpParsedAst.hs:8:11 } - (Unqual {OccName: a})))))), + (EName + (Unqual {OccName: a}))))))), ({ DumpParsedAst.hs:8:13 } (HsAppInfix ({ DumpParsedAst.hs:8:13 } - (Exact {Name: ghc-prim:GHC.Types.:{(w) d}})))), + (EName + (Exact {Name: ghc-prim:GHC.Types.:{(w) d}}))))), ({ DumpParsedAst.hs:8:15-16 } (HsAppPrefix ({ DumpParsedAst.hs:8:15-16 } (HsTyVar (NotPromoted) ({ DumpParsedAst.hs:8:15-16 } - (Unqual {OccName: as}))))))]))))]) + (EName + (Unqual {OccName: as})))))))]))))]) (Prefix) ({ DumpParsedAst.hs:8:21-36 } (HsAppsTy @@ -103,7 +109,8 @@ (HsTyVar (NotPromoted) ({ DumpParsedAst.hs:8:21-24 } - (Unqual {OccName: Succ})))))), + (EName + (Unqual {OccName: Succ}))))))), ({ DumpParsedAst.hs:8:26-36 } (HsAppPrefix ({ DumpParsedAst.hs:8:26-36 } @@ -117,14 +124,16 @@ (HsTyVar (NotPromoted) ({ DumpParsedAst.hs:8:27-32 } - (Unqual {OccName: Length})))))), + (EName + (Unqual {OccName: Length}))))))), ({ DumpParsedAst.hs:8:34-35 } (HsAppPrefix ({ DumpParsedAst.hs:8:34-35 } (HsTyVar (NotPromoted) ({ DumpParsedAst.hs:8:34-35 } - (Unqual {OccName: as}))))))]))))))])))), + (EName + (Unqual {OccName: as})))))))]))))))])))), ({ DumpParsedAst.hs:9:3-24 } (TyFamEqn ({ DumpParsedAst.hs:9:3-8 } @@ -147,7 +156,8 @@ (HsTyVar (NotPromoted) ({ DumpParsedAst.hs:9:21-24 } - (Unqual {OccName: Zero}))))))]))))])) + (EName + (Unqual {OccName: Zero})))))))]))))])) ({ DumpParsedAst.hs:7:13-18 } (Unqual {OccName: Length})) (HsQTvs @@ -173,7 +183,8 @@ (HsTyVar (NotPromoted) ({ DumpParsedAst.hs:7:28 } - (Unqual {OccName: k}))))))]))))))]))))] + (EName + (Unqual {OccName: k})))))))]))))))]))))] (PlaceHolder)) (Prefix) ({ DumpParsedAst.hs:7:32-39 } @@ -187,7 +198,8 @@ (HsTyVar (NotPromoted) ({ DumpParsedAst.hs:7:35-39 } - (Unqual {OccName: Peano}))))))])))) + (EName + (Unqual {OccName: Peano})))))))])))) (Nothing))))), ({ DumpParsedAst.hs:11:1-23 } (ValD @@ -215,7 +227,8 @@ ({ DumpParsedAst.hs:11:8-15 } (HsVar ({ DumpParsedAst.hs:11:8-15 } - (Unqual {OccName: putStrLn})))) + (EName + (Unqual {OccName: putStrLn}))))) ({ DumpParsedAst.hs:11:17-23 } (HsLit (HsString @@ -227,6 +240,127 @@ (FromSource)) (WpHole) (PlaceHolder) + []))), + ({ DumpParsedAst.hs:13:1-15 } + (ValD + (FunBind + ({ DumpParsedAst.hs:13:1-3 } + (Unqual {OccName: foo})) + (MG + ({ DumpParsedAst.hs:13:1-15 } + [ + ({ DumpParsedAst.hs:13:1-15 } + (Match + (FunRhs + ({ DumpParsedAst.hs:13:1-3 } + (Unqual {OccName: foo})) + (Prefix)) + [] + (Nothing) + (GRHSs + [ + ({ DumpParsedAst.hs:13:5-15 } + (GRHS + [] + ({ DumpParsedAst.hs:13:7-15 } + (OpApp + ({ DumpParsedAst.hs:13:7 } + (HsOverLit + (OverLit + (HsIntegral + (SourceText "5") + (5)) + (PlaceHolder) + (HsLit + (HsString + (SourceText "noExpr") {FastString: "noExpr"})) + (PlaceHolder)))) + ({ DumpParsedAst.hs:13:9-13 } + (HsVar + ({ DumpParsedAst.hs:13:9-13 } + (EBackquotes + ({ DumpParsedAst.hs:13:10-12 } + (Unqual {OccName: mod})))))) + (PlaceHolder) + ({ DumpParsedAst.hs:13:15 } + (HsOverLit + (OverLit + (HsIntegral + (SourceText "2") + (2)) + (PlaceHolder) + (HsLit + (HsString + (SourceText "noExpr") {FastString: "noExpr"})) + (PlaceHolder))))))))] + ({ <no location info> } + (EmptyLocalBinds)))))]) + [] + (PlaceHolder) + (FromSource)) + (WpHole) + (PlaceHolder) + []))), + ({ DumpParsedAst.hs:15:1-13 } + (ValD + (FunBind + ({ DumpParsedAst.hs:15:1-3 } + (Unqual {OccName: bar})) + (MG + ({ DumpParsedAst.hs:15:1-13 } + [ + ({ DumpParsedAst.hs:15:1-13 } + (Match + (FunRhs + ({ DumpParsedAst.hs:15:1-3 } + (Unqual {OccName: bar})) + (Prefix)) + [] + (Nothing) + (GRHSs + [ + ({ DumpParsedAst.hs:15:5-13 } + (GRHS + [] + ({ DumpParsedAst.hs:15:7-13 } + (HsApp + ({ DumpParsedAst.hs:15:7-11 } + (HsApp + ({ DumpParsedAst.hs:15:7-9 } + (HsVar + ({ DumpParsedAst.hs:15:7-9 } + (EParens + ({ DumpParsedAst.hs:15:8 } + (Unqual {OccName: +})))))) + ({ DumpParsedAst.hs:15:11 } + (HsOverLit + (OverLit + (HsIntegral + (SourceText "3") + (3)) + (PlaceHolder) + (HsLit + (HsString + (SourceText "noExpr") {FastString: "noExpr"})) + (PlaceHolder)))))) + ({ DumpParsedAst.hs:15:13 } + (HsOverLit + (OverLit + (HsIntegral + (SourceText "4") + (4)) + (PlaceHolder) + (HsLit + (HsString + (SourceText "noExpr") {FastString: "noExpr"})) + (PlaceHolder))))))))] + ({ <no location info> } + (EmptyLocalBinds)))))]) + [] + (PlaceHolder) + (FromSource)) + (WpHole) + (PlaceHolder) [])))] (Nothing) (Nothing))) diff --git a/testsuite/tests/parser/should_compile/DumpRenamedAst.stderr b/testsuite/tests/parser/should_compile/DumpRenamedAst.stderr index 437390cbce..aa69781532 100644 --- a/testsuite/tests/parser/should_compile/DumpRenamedAst.stderr +++ b/testsuite/tests/parser/should_compile/DumpRenamedAst.stderr @@ -29,7 +29,8 @@ (HsApp ({ DumpRenamedAst.hs:11:8-15 } (HsVar - ({ DumpRenamedAst.hs:11:8-15 }{Name: base:System.IO.putStrLn{v}}))) + ({ DumpRenamedAst.hs:11:8-15 } + (EName {Name: base:System.IO.putStrLn{v}})))) ({ DumpRenamedAst.hs:11:17-23 } (HsLit (HsString @@ -64,7 +65,8 @@ [ ({ DumpRenamedAst.hs:5:14-17 } (ConDeclH98 - ({ DumpRenamedAst.hs:5:14-17 }{Name: main:DumpRenamedAst.Zero{d}}) + ({ DumpRenamedAst.hs:5:14-17 } + (EName {Name: main:DumpRenamedAst.Zero{d}})) (Nothing) (Just ({ <no location info> } @@ -74,7 +76,8 @@ (Nothing))), ({ DumpRenamedAst.hs:5:21-30 } (ConDeclH98 - ({ DumpRenamedAst.hs:5:21-24 }{Name: main:DumpRenamedAst.Succ{d}}) + ({ DumpRenamedAst.hs:5:21-24 } + (EName {Name: main:DumpRenamedAst.Succ{d}})) (Nothing) (Just ({ <no location info> } @@ -84,7 +87,8 @@ ({ DumpRenamedAst.hs:5:26-30 } (HsTyVar (NotPromoted) - ({ DumpRenamedAst.hs:5:26-30 }{Name: main:DumpRenamedAst.Peano{tc}})))]) + ({ DumpRenamedAst.hs:5:26-30 } + (EName {Name: main:DumpRenamedAst.Peano{tc}}))))]) (Nothing)))] ({ <no location info> } [])) @@ -113,19 +117,22 @@ ({ DumpRenamedAst.hs:8:11 } (HsTyVar (NotPromoted) - ({ DumpRenamedAst.hs:8:11 }{Name: a{tv}}))) + ({ DumpRenamedAst.hs:8:11 } + (EName {Name: a{tv}})))) ({ DumpRenamedAst.hs:8:13 }{Name: ghc-prim:GHC.Types.:{(w) d}}) ({ DumpRenamedAst.hs:8:15-16 } (HsTyVar (NotPromoted) - ({ DumpRenamedAst.hs:8:15-16 }{Name: as{tv}})))))))]) + ({ DumpRenamedAst.hs:8:15-16 } + (EName {Name: as{tv}}))))))))]) (Prefix) ({ DumpRenamedAst.hs:8:21-36 } (HsAppTy ({ DumpRenamedAst.hs:8:21-24 } (HsTyVar (NotPromoted) - ({ DumpRenamedAst.hs:8:21-24 }{Name: main:DumpRenamedAst.Succ{d}}))) + ({ DumpRenamedAst.hs:8:21-24 } + (EName {Name: main:DumpRenamedAst.Succ{d}})))) ({ DumpRenamedAst.hs:8:26-36 } (HsParTy ({ DumpRenamedAst.hs:8:27-35 } @@ -133,11 +140,13 @@ ({ DumpRenamedAst.hs:8:27-32 } (HsTyVar (NotPromoted) - ({ DumpRenamedAst.hs:8:27-32 }{Name: main:DumpRenamedAst.Length{tc}}))) + ({ DumpRenamedAst.hs:8:27-32 } + (EName {Name: main:DumpRenamedAst.Length{tc}})))) ({ DumpRenamedAst.hs:8:34-35 } (HsTyVar (NotPromoted) - ({ DumpRenamedAst.hs:8:34-35 }{Name: as{tv}}))))))))))), + ({ DumpRenamedAst.hs:8:34-35 } + (EName {Name: as{tv}})))))))))))), ({ DumpRenamedAst.hs:9:3-24 } (TyFamEqn ({ DumpRenamedAst.hs:9:3-8 }{Name: main:DumpRenamedAst.Length{tc}}) @@ -153,7 +162,8 @@ ({ DumpRenamedAst.hs:9:21-24 } (HsTyVar (NotPromoted) - ({ DumpRenamedAst.hs:9:21-24 }{Name: main:DumpRenamedAst.Zero{d}})))))])) + ({ DumpRenamedAst.hs:9:21-24 } + (EName {Name: main:DumpRenamedAst.Zero{d}}))))))])) ({ DumpRenamedAst.hs:7:13-18 }{Name: main:DumpRenamedAst.Length{tc}}) (HsQTvs [{Name: k{tv}}] @@ -166,7 +176,8 @@ ({ DumpRenamedAst.hs:7:28 } (HsTyVar (NotPromoted) - ({ DumpRenamedAst.hs:7:28 }{Name: k{tv}})))))))] {NameSet: + ({ DumpRenamedAst.hs:7:28 } + (EName {Name: k{tv}}))))))))] {NameSet: []}) (Prefix) ({ DumpRenamedAst.hs:7:32-39 } @@ -174,7 +185,8 @@ ({ DumpRenamedAst.hs:7:35-39 } (HsTyVar (NotPromoted) - ({ DumpRenamedAst.hs:7:35-39 }{Name: main:DumpRenamedAst.Peano{tc}}))))) + ({ DumpRenamedAst.hs:7:35-39 } + (EName {Name: main:DumpRenamedAst.Peano{tc}})))))) (Nothing))))] [] [])] diff --git a/testsuite/tests/parser/should_compile/DumpTypecheckedAst.stderr b/testsuite/tests/parser/should_compile/DumpTypecheckedAst.stderr index c7db52a5df..2fd0e22e35 100644 --- a/testsuite/tests/parser/should_compile/DumpTypecheckedAst.stderr +++ b/testsuite/tests/parser/should_compile/DumpTypecheckedAst.stderr @@ -31,7 +31,8 @@ (2739668351064589274)))))) ({ <no location info> } (HsVar - ({ <no location info> }{Var: (main:DumpTypecheckedAst.$trModule{v} [lidx] :: ghc-prim:GHC.Types.Module{tc})}))))) + ({ <no location info> } + (EName {Var: (main:DumpTypecheckedAst.$trModule{v} [lidx] :: ghc-prim:GHC.Types.Module{tc})})))))) ({ <no location info> } (HsPar ({ <no location info> } @@ -50,7 +51,8 @@ (0)))))) ({ <no location info> } (HsVar - ({ <no location info> }{Var: (krep{v} [lid] :: ghc-prim:GHC.Types.KindRep{tc})}))))) + ({ <no location info> } + (EName {Var: (krep{v} [lid] :: ghc-prim:GHC.Types.KindRep{tc})})))))) (False))), ({ <no location info> } (VarBind {Var: (krep{v} [lid] :: ghc-prim:GHC.Types.KindRep{tc})} @@ -92,7 +94,8 @@ (12314848029315386153)))))) ({ <no location info> } (HsVar - ({ <no location info> }{Var: (main:DumpTypecheckedAst.$trModule{v} [lidx] :: ghc-prim:GHC.Types.Module{tc})}))))) + ({ <no location info> } + (EName {Var: (main:DumpTypecheckedAst.$trModule{v} [lidx] :: ghc-prim:GHC.Types.Module{tc})})))))) ({ <no location info> } (HsPar ({ <no location info> } @@ -111,7 +114,8 @@ (0)))))) ({ <no location info> } (HsVar - ({ <no location info> }{Var: (krep{v} [lid] :: ghc-prim:GHC.Types.KindRep{tc})}))))) + ({ <no location info> } + (EName {Var: (krep{v} [lid] :: ghc-prim:GHC.Types.KindRep{tc})})))))) (False))), ({ <no location info> } (VarBind {Var: (krep{v} [lid] :: ghc-prim:GHC.Types.KindRep{tc})} @@ -124,7 +128,8 @@ ({abstract:ConLike}))) ({ <no location info> } (HsVar - ({ <no location info> }{Var: (main:DumpTypecheckedAst.$tcPeano{v} [lidx] :: ghc-prim:GHC.Types.TyCon{tc})}))))) + ({ <no location info> } + (EName {Var: (main:DumpTypecheckedAst.$tcPeano{v} [lidx] :: ghc-prim:GHC.Types.TyCon{tc})})))))) ({ <no location info> } (HsWrap (WpTyApp @@ -163,7 +168,8 @@ (14802086722010293686)))))) ({ <no location info> } (HsVar - ({ <no location info> }{Var: (main:DumpTypecheckedAst.$trModule{v} [lidx] :: ghc-prim:GHC.Types.Module{tc})}))))) + ({ <no location info> } + (EName {Var: (main:DumpTypecheckedAst.$trModule{v} [lidx] :: ghc-prim:GHC.Types.Module{tc})})))))) ({ <no location info> } (HsPar ({ <no location info> } @@ -182,7 +188,8 @@ (0)))))) ({ <no location info> } (HsVar - ({ <no location info> }{Var: (krep{v} [lid] :: ghc-prim:GHC.Types.KindRep{tc})}))))) + ({ <no location info> } + (EName {Var: (krep{v} [lid] :: ghc-prim:GHC.Types.KindRep{tc})})))))) (False))), ({ <no location info> } (VarBind {Var: (krep{v} [lid] :: ghc-prim:GHC.Types.KindRep{tc})} @@ -204,7 +211,8 @@ ({abstract:ConLike}))) ({ <no location info> } (HsVar - ({ <no location info> }{Var: (main:DumpTypecheckedAst.$tcPeano{v} [lidx] :: ghc-prim:GHC.Types.TyCon{tc})}))))) + ({ <no location info> } + (EName {Var: (main:DumpTypecheckedAst.$tcPeano{v} [lidx] :: ghc-prim:GHC.Types.TyCon{tc})})))))) ({ <no location info> } (HsWrap (WpTyApp @@ -224,7 +232,8 @@ ({abstract:ConLike}))) ({ <no location info> } (HsVar - ({ <no location info> }{Var: (main:DumpTypecheckedAst.$tcPeano{v} [lidx] :: ghc-prim:GHC.Types.TyCon{tc})}))))) + ({ <no location info> } + (EName {Var: (main:DumpTypecheckedAst.$tcPeano{v} [lidx] :: ghc-prim:GHC.Types.TyCon{tc})})))))) ({ <no location info> } (HsWrap (WpTyApp @@ -301,8 +310,9 @@ (HsApp ({ DumpTypecheckedAst.hs:11:8-15 } (HsVar - ({ <no location info> }{Var: (base:System.IO.putStrLn{v} [gid] :: base:GHC.Base.String{tc} - -> ghc-prim:GHC.Types.IO{tc} ())}))) + ({ <no location info> } + (EName {Var: (base:System.IO.putStrLn{v} [gid] :: base:GHC.Base.String{tc} + -> ghc-prim:GHC.Types.IO{tc} ())})))) ({ DumpTypecheckedAst.hs:11:17-23 } (HsLit (HsString diff --git a/testsuite/tests/quasiquotation/T7918.hs b/testsuite/tests/quasiquotation/T7918.hs index 0f32699415..f27c9828f2 100644 --- a/testsuite/tests/quasiquotation/T7918.hs +++ b/testsuite/tests/quasiquotation/T7918.hs @@ -30,13 +30,13 @@ traverse a = where showVar :: Maybe (HsExpr Id) -> Traverse () showVar (Just (HsVar (L _ v))) = - modify $ \(loc, ids) -> (loc, (varName v, loc) : ids) + modify $ \(loc, ids) -> (loc, (varName $ unEmb v, loc) : ids) showVar _ = return () showTyVar :: Maybe (HsType Name) -> Traverse () showTyVar (Just (HsTyVar _ (L _ v))) = - modify $ \(loc, ids) -> (loc, (v, loc) : ids) + modify $ \(loc, ids) -> (loc, (unEmb v, loc) : ids) showTyVar _ = return () diff --git a/utils/ghctags/Main.hs b/utils/ghctags/Main.hs index 138687e5fa..18ff53e958 100644 --- a/utils/ghctags/Main.hs +++ b/utils/ghctags/Main.hs @@ -259,7 +259,7 @@ boundValues mod group = _other -> error "boundValues" tys = [ n | ns <- map (fst . hsLTyClDeclBinders) (hs_tyclds group >>= group_tyclds) - , n <- map found ns ] + , n <- map (found . unLEmb) ns ] fors = concat $ map forBound (hs_fords group) where forBound lford = case unLoc lford of ForeignImport n _ _ _ -> [found n] @@ -283,7 +283,7 @@ boundThings modname lbinding = VarBind { var_id = id } -> [FoundThing modname (getOccString id) (startOfLocated lbinding)] AbsBinds { } -> [] -- nothing interesting in a type abstraction AbsBindsSig { } -> [] - PatSynBind PSB{ psb_id = id } -> [thing id] + PatSynBind PSB{ psb_id = id } -> [thing $ unLEmb id] where thing = foundOfLName modname patThings lpat tl = let loc = startOfLocated lpat @@ -292,7 +292,7 @@ boundThings modname lbinding = WildPat _ -> tl VarPat (L _ name) -> lid name : tl LazyPat p -> patThings p tl - AsPat id p -> patThings p (thing id : tl) + AsPat id p -> patThings p (thing (unLEmb id) : tl) ParPat p -> patThings p tl BangPat p -> patThings p tl ListPat ps _ _ -> foldr patThings tl ps diff --git a/utils/haddock b/utils/haddock -Subproject dbbdabfd3842f70c78d4c64e10f75f47fe5c0f5 +Subproject fdaaa11fd38d03f09ef4d26ef411f37b8922e6c |