diff options
| author | Alan Zimmerman <alan.zimm@gmail.com> | 2017-02-17 12:13:14 +0200 |
|---|---|---|
| committer | Alan Zimmerman <alan.zimm@gmail.com> | 2017-02-18 20:40:09 +0200 |
| commit | 43a082bb59310d10d3c7550d5cbeaab384ca4c76 (patch) | |
| tree | 4aa60f80be7e87ede1db0af69e2c3e20d14d16a9 | |
| parent | 98e494afed3c73f88ff1d57a9ca46b1f6ddbd1b9 (diff) | |
| download | haskell-wip/embelleshed-rdr.tar.gz | |
Add HsEmbellished type to hsSynwip/embelleshed-rdr
Summary:
A RdrName can be parsed with parens or backquotes if it is used prefix or infix
respectively when it is normally not used that way.
This is not captured in hsSyn, and must be inferred from the occName when pretty
printing, or using the API annotations.
Introduce a wrapper type around the name to capture this
data Embellished name
= EName name
| EParens (Located name)
| EBackquotes (Located name)
So that we now have
data HsExpr id
= HsVar (LEmbellished id) -- ^ Variable
and in the other relevant points in hsSyn.
Test Plan: ./validate
Reviewers: bgamari, austin, goldfire
Subscribers: goldfire, thomie, mpickering, snowleopard
Differential Revision: https://phabricator.haskell.org/D3145
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 |