Commit 3df9563e authored by Alan Zimmerman's avatar Alan Zimmerman Committed by Ben Gamari

ApiAnnotations: Make all RdrName occurences Located

At the moment the API Annotations can only be used on the ParsedSource,
as there are changes made to the RenamedSource that prevent it from
being used to round trip source code.

It is possible to build a map from every Located Name in the
RenamedSource from its location to the Name, which can then be used when
resolved names are required when changing the ParsedSource.

However, there are instances where the identifier is not located,
specifically

  (GHC.VarPat name)
  (GHC.HsVar name)
  (GHC.UserTyVar name)
  (GHC.HsTyVar name)

Replace each of the name types above with (Located name)

Updates the haddock submodule.

Test Plan: ./validate

Reviewers: austin, goldfire, bgamari

Reviewed By: bgamari

Subscribers: goldfire, thomie, mpickering

Differential Revision: https://phabricator.haskell.org/D1512

GHC Trac Issues: #11019
parent 64737f2d
......@@ -688,7 +688,7 @@ tidy_lpat p = fmap tidy_pat p
--------------
tidy_pat :: Pat Id -> Pat Id
tidy_pat pat@(WildPat _) = pat
tidy_pat (VarPat id) = WildPat (idType id)
tidy_pat (VarPat id) = WildPat (idType (unLoc id))
tidy_pat (ParPat p) = tidy_pat (unLoc p)
tidy_pat (LazyPat p) = WildPat (hsLPatType p) -- For overlap and exhaustiveness checking
-- purposes, a ~pat is like a wildcard
......
......@@ -461,7 +461,7 @@ addBinTickLHsExpr boxLabel (L pos e0)
-- Decoarate an HsExpr with ticks
addTickHsExpr :: HsExpr Id -> TM (HsExpr Id)
addTickHsExpr e@(HsVar id) = do freeVar id; return e
addTickHsExpr e@(HsVar (L _ id)) = do freeVar id; return e
addTickHsExpr (HsUnboundVar {}) = panic "addTickHsExpr.HsUnboundVar"
addTickHsExpr e@(HsIPVar _) = return e
addTickHsExpr e@(HsOverLit _) = return e
......
......@@ -527,8 +527,8 @@ dsCmd ids local_vars stack_ty res_ty
left_con <- dsLookupDataCon leftDataConName
right_con <- dsLookupDataCon rightDataConName
let
left_id = HsVar (dataConWrapId left_con)
right_id = HsVar (dataConWrapId right_con)
left_id = HsVar (noLoc (dataConWrapId left_con))
right_id = HsVar (noLoc (dataConWrapId right_con))
left_expr ty1 ty2 e = noLoc $ HsApp (noLoc $ HsWrap (mkWpTyApps [ty1, ty2]) left_id ) e
right_expr ty1 ty2 e = noLoc $ HsApp (noLoc $ HsWrap (mkWpTyApps [ty1, ty2]) right_id) e
......@@ -1129,7 +1129,7 @@ collectl :: LPat Id -> [Id] -> [Id]
collectl (L _ pat) bndrs
= go pat
where
go (VarPat var) = var : bndrs
go (VarPat (L _ var)) = var : bndrs
go (WildPat _) = bndrs
go (LazyPat pat) = collectl pat bndrs
go (BangPat pat) = collectl pat bndrs
......
......@@ -196,7 +196,8 @@ dsLExpr (L loc e) = putSrcSpanDs loc $ dsExpr e
dsExpr :: HsExpr Id -> DsM CoreExpr
dsExpr (HsPar e) = dsLExpr e
dsExpr (ExprWithTySigOut e _) = dsLExpr e
dsExpr (HsVar var) = return (varToCoreExpr var) -- See Note [Desugaring vars]
dsExpr (HsVar (L _ var)) = return (varToCoreExpr var)
-- See Note [Desugaring vars]
dsExpr (HsUnboundVar {}) = panic "dsExpr: HsUnboundVar" -- Typechecker eliminates them
dsExpr (HsIPVar _) = panic "dsExpr: HsIPVar"
dsExpr (HsOverLabel _) = panic "dsExpr: HsOverLabel"
......@@ -624,7 +625,7 @@ dsExpr expr@(RecordUpd { rupd_expr = record_expr, rupd_flds = fields
-- SAFE: the typechecker will complain if the synonym is
-- not bidirectional
wrap_id = expectJust "dsExpr:mk_alt" (conLikeWrapId_maybe con)
inst_con = noLoc $ HsWrap wrap (HsVar wrap_id)
inst_con = noLoc $ HsWrap wrap (HsVar (noLoc wrap_id))
-- Reconstruct with the WrapId so that unpacking happens
-- The order here is because of the order in `TcPatSyn`.
wrap =
......
......@@ -134,9 +134,9 @@ 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 aways evaluted.
isTrueLHsExpr (L _ (HsVar v)) | v `hasKey` otherwiseIdKey
|| v `hasKey` getUnique trueDataConId
= Just return
isTrueLHsExpr (L _ (HsVar (L _ v))) | v `hasKey` otherwiseIdKey
|| v `hasKey` getUnique trueDataConId
= Just return
-- trueDataConId doesn't have the same unique as trueDataCon
isTrueLHsExpr (L _ (HsTick tickish e))
| Just ticks <- isTrueLHsExpr e
......
......@@ -410,7 +410,7 @@ mk_extra_tvs tc tvs defn
; hs_tvs <- go rest
; return (hs_tv : hs_tvs) }
go (L _ (HsTyVar n))
go (L _ (HsTyVar (L _ n)))
| n == liftedTypeKindTyConName
= return []
......@@ -456,7 +456,7 @@ repClsInstD (ClsInstDecl { cid_poly_ty = ty, cid_binds = binds
-- the selector Ids, not to fresh names (Trac #5410)
--
do { cxt1 <- repContext cxt
; cls_tcon <- repTy (HsTyVar (unLoc cls))
; cls_tcon <- repTy (HsTyVar cls)
; cls_tys <- repLTys tys
; inst_ty1 <- repTapps cls_tcon cls_tys
; binds1 <- rep_binds binds
......@@ -472,7 +472,7 @@ repStandaloneDerivD :: LDerivDecl Name -> DsM (SrcSpan, Core TH.DecQ)
repStandaloneDerivD (L loc (DerivDecl { deriv_type = ty }))
= do { dec <- addTyVarBinds tvs $ \_ ->
do { cxt' <- repContext cxt
; cls_tcon <- repTy (HsTyVar (unLoc cls))
; cls_tcon <- repTy (HsTyVar cls)
; cls_tys <- repLTys tys
; inst_ty <- repTapps cls_tcon cls_tys
; repDeriv cxt' inst_ty }
......@@ -677,11 +677,11 @@ mkGadtCtxt data_tvs (ResTyGADT _ res_ty)
= go (eq_pred : cxt) subst rest
where
loc = getLoc ty
eq_pred = L loc (HsEqTy (L loc (HsTyVar data_tv)) ty)
eq_pred = L loc (HsEqTy (L loc (HsTyVar (L loc data_tv))) ty)
is_hs_tyvar (L _ (HsTyVar n)) = Just n -- Type variables *and* tycons
is_hs_tyvar (L _ (HsParTy ty)) = is_hs_tyvar ty
is_hs_tyvar _ = Nothing
is_hs_tyvar (L _ (HsTyVar (L _ n))) = Just n -- Type variables *and* tycons
is_hs_tyvar (L _ (HsParTy ty)) = is_hs_tyvar ty
is_hs_tyvar _ = Nothing
repBangTy :: LBangType Name -> DsM (Core (TH.StrictTypeQ))
......@@ -870,8 +870,8 @@ repTyVarBndrWithKind (L _ (KindedTyVar _ ki)) nm
-- | Represent a type variable binder
repTyVarBndr :: LHsTyVarBndr Name -> DsM (Core TH.TyVarBndr)
repTyVarBndr (L _ (UserTyVar nm)) = do { nm' <- lookupBinder nm
; repPlainTV nm' }
repTyVarBndr (L _ (UserTyVar (L _ nm)) )= do { nm' <- lookupBinder nm
; repPlainTV nm' }
repTyVarBndr (L _ (KindedTyVar (L _ nm) ki)) = do { nm' <- lookupBinder nm
; ki' <- repLKind ki
; repKindedTV nm' ki' }
......@@ -911,13 +911,13 @@ repTy (HsForAllTy _ extra tvs ctxt ty) =
-- This unique will be discarded by repLContext, but is required
-- to make a Name
name = mkInternalName uniq (mkTyVarOcc "_") loc
in (++ [L loc (HsWildCardTy (AnonWildCard name))]) `fmap` ctxt
in (++ [L loc (HsWildCardTy (AnonWildCard (L loc name)))]) `fmap` ctxt
| otherwise
= ctxt
repTy (HsTyVar n)
repTy (HsTyVar (L _ n))
| isTvOcc occ = do tv1 <- lookupOcc n
repTvar tv1
| isDataOcc occ = do tc1 <- lookupOcc n
......@@ -940,10 +940,10 @@ repTy (HsListTy t) = do
t1 <- repLTy t
tcon <- repListTyCon
repTapp tcon t1
repTy (HsPArrTy t) = do
t1 <- repLTy t
tcon <- repTy (HsTyVar (tyConName parrTyCon))
repTapp tcon t1
repTy (HsPArrTy t) = do
t1 <- repLTy t
tcon <- repTy (HsTyVar (noLoc (tyConName parrTyCon)))
repTapp tcon t1
repTy (HsTupleTy HsUnboxedTuple tys) = do
tys1 <- repLTys tys
tcon <- repUnboxedTupleTyCon (length tys)
......@@ -975,7 +975,7 @@ repTy (HsTyLit lit) = do
lit' <- repTyLit lit
repTLit lit'
repTy (HsWildCardTy (AnonWildCard _)) = repTWildCard
repTy (HsWildCardTy (NamedWildCard n)) = do
repTy (HsWildCardTy (NamedWildCard (L _ n))) = do
nwc <- lookupOcc n
repTNamedWildCard nwc
......@@ -1004,7 +1004,7 @@ repNonArrowLKind :: LHsKind Name -> DsM (Core TH.Kind)
repNonArrowLKind (L _ ki) = repNonArrowKind ki
repNonArrowKind :: HsKind Name -> DsM (Core TH.Kind)
repNonArrowKind (HsTyVar name)
repNonArrowKind (HsTyVar (L _ name))
| name == liftedTypeKindTyConName = repKStar
| name == constraintKindTyConName = repKConstraint
| isTvOcc (nameOccName name) = lookupOcc name >>= repKVar
......@@ -1063,7 +1063,7 @@ repLE :: LHsExpr Name -> DsM (Core TH.ExpQ)
repLE (L loc e) = putSrcSpanDs loc (repE e)
repE :: HsExpr Name -> DsM (Core TH.ExpQ)
repE (HsVar x) =
repE (HsVar (L _ x)) =
do { mb_val <- dsLookupMetaEnv x
; case mb_val of
Nothing -> do { str <- globalVar x
......@@ -1075,7 +1075,7 @@ 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 x)
Unambiguous _ x -> repE (HsVar (noLoc x))
Ambiguous{} -> notHandled "Ambiguous record selectors" (ppr e)
-- Remember, we're desugaring renamer output here, so
......@@ -1456,7 +1456,7 @@ repLP (L _ p) = repP p
repP :: Pat Name -> DsM (Core TH.PatQ)
repP (WildPat _) = repPwild
repP (LitPat l) = do { l2 <- repLiteral l; repPlit l2 }
repP (VarPat x) = do { x' <- lookupBinder x; repPvar x' }
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 }
......
......@@ -116,7 +116,8 @@ selectMatchVar :: Pat Id -> DsM Id
selectMatchVar (BangPat pat) = selectMatchVar (unLoc pat)
selectMatchVar (LazyPat pat) = selectMatchVar (unLoc pat)
selectMatchVar (ParPat pat) = selectMatchVar (unLoc pat)
selectMatchVar (VarPat var) = return (localiseId var) -- Note [Localise pattern binders]
selectMatchVar (VarPat var) = return (localiseId (unLoc var))
-- Note [Localise pattern binders]
selectMatchVar (AsPat var _) = return (unLoc var)
selectMatchVar other_pat = newSysLocalDs (hsPatType other_pat)
-- OK, better make up one...
......@@ -621,7 +622,7 @@ mkSelectorBinds :: Bool -- ^ is strict
-- binds (see Note [Desugar Strict binds] in DsBinds)
-- and all the desugared binds
mkSelectorBinds _ ticks (L _ (VarPat v)) val_expr
mkSelectorBinds _ ticks (L _ (VarPat (L _ v))) val_expr
= return (Just v
,[(v, case ticks of
[t] -> mkOptTickBox t val_expr
......
......@@ -524,7 +524,7 @@ tidy1 v (BangPat (L l p)) = tidy_bang_pat v l p
-- case v of { x -> mr[] }
-- = case v of { _ -> let x=v in mr[] }
tidy1 v (VarPat var)
tidy1 v (VarPat (L _ var))
= return (wrapBind var v, WildPat (idType var))
-- case v of { x@p -> mr[] }
......
......@@ -465,7 +465,7 @@ cvtDerivs cs = do { cs' <- mapM cvt_one cs
; return (Just (noLoc cs')) }
where
cvt_one c = do { c' <- tconName c
; returnL $ HsTyVar c' }
; returnL $ HsTyVar (noLoc c') }
cvt_fundep :: FunDep -> CvtM (Located (Class.FunDep (Located RdrName)))
cvt_fundep (FunDep xs ys) = do { xs' <- mapM tName xs
......@@ -641,8 +641,8 @@ cvtClause (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 s' }
cvt (ConE s) = do { s' <- cName s; return $ HsVar s' }
cvt (VarE s) = do { s' <- vName s; return $ HsVar (noLoc s') }
cvt (ConE s) = do { s' <- cName s; return $ HsVar (noLoc s') }
cvt (LitE l)
| overloadedLit l = do { l' <- cvtOverLit l; return $ HsOverLit l' }
| otherwise = do { l' <- cvtLit l; return $ HsLit l' }
......@@ -717,7 +717,7 @@ cvtl e = wrapL (cvt e)
; flds'<- mapM (cvtFld mkAmbiguousFieldOcc) flds
; return $ mkRdrRecordUpd e' flds' }
cvt (StaticE e) = fmap HsStatic $ cvtl e
cvt (UnboundVarE s) = do { s' <- vName s; return $ HsVar s' }
cvt (UnboundVarE s) = do { s' <- vName s; return $ HsVar (noLoc s') }
{- Note [Dropping constructors]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
......@@ -930,7 +930,7 @@ cvtp (TH.LitP l)
-- Not right for negative patterns;
-- need to think about that!
| otherwise = do { l' <- cvtLit l; return $ Hs.LitPat l' }
cvtp (TH.VarP s) = do { s' <- vName s; return $ Hs.VarPat s' }
cvtp (TH.VarP s) = do { s' <- vName s; return $ Hs.VarPat (noLoc s') }
cvtp (TupP [p]) = do { p' <- cvtPat p; return $ ParPat p' } -- Note [Dropping constructors]
cvtp (TupP ps) = do { ps' <- cvtPats ps; return $ TuplePat ps' Boxed [] }
cvtp (UnboxedTupP ps) = do { ps' <- cvtPats ps; return $ TuplePat ps' Unboxed [] }
......@@ -986,7 +986,7 @@ cvtTvs tvs = do { tvs' <- mapM cvt_tv tvs; return (mkHsQTvs tvs') }
cvt_tv :: TH.TyVarBndr -> CvtM (LHsTyVarBndr RdrName)
cvt_tv (TH.PlainTV nm)
= do { nm' <- tName nm
; returnL $ UserTyVar nm' }
; returnL $ UserTyVar (noLoc nm') }
cvt_tv (TH.KindedTV nm ki)
= do { nm' <- tName nm
; ki' <- cvtKind ki
......@@ -1019,22 +1019,26 @@ cvtTypeKind ty_str ty
| n == 1
-> failWith (ptext (sLit ("Illegal 1-tuple " ++ ty_str ++ " constructor")))
| otherwise
-> mk_apps (HsTyVar (getRdrName (tupleTyCon Boxed n))) tys'
-> mk_apps (HsTyVar (noLoc (getRdrName (tupleTyCon Boxed n)))) tys'
UnboxedTupleT n
| length tys' == n -- Saturated
-> if n==1 then return (head tys') -- Singleton tuples treated
-- like nothing (ie just parens)
else returnL (HsTupleTy HsUnboxedTuple tys')
| otherwise
-> mk_apps (HsTyVar (getRdrName (tupleTyCon Unboxed n))) tys'
-> mk_apps (HsTyVar (noLoc (getRdrName (tupleTyCon Unboxed n))))
tys'
ArrowT
| [x',y'] <- tys' -> returnL (HsFunTy x' y')
| otherwise -> mk_apps (HsTyVar (getRdrName funTyCon)) tys'
| otherwise -> mk_apps (HsTyVar (noLoc (getRdrName funTyCon))) tys'
ListT
| [x'] <- tys' -> returnL (HsListTy x')
| otherwise -> mk_apps (HsTyVar (getRdrName listTyCon)) tys'
VarT nm -> do { nm' <- tName nm; mk_apps (HsTyVar nm') tys' }
ConT nm -> do { nm' <- tconName nm; mk_apps (HsTyVar nm') tys' }
| otherwise
-> mk_apps (HsTyVar (noLoc (getRdrName listTyCon))) tys'
VarT nm -> do { nm' <- tName nm
; mk_apps (HsTyVar (noLoc nm')) tys' }
ConT nm -> do { nm' <- tconName nm
; mk_apps (HsTyVar (noLoc nm')) tys' }
ForallT tvs cxt ty
| null tys'
......@@ -1057,13 +1061,14 @@ cvtTypeKind ty_str ty
-> mk_apps mkAnonWildCardTy tys'
WildCardT (Just nm)
-> do { nm' <- tName nm; mk_apps (mkNamedWildCardTy nm') tys' }
-> do { nm' <- tName nm
; mk_apps (mkNamedWildCardTy (noLoc nm')) tys' }
InfixT t1 s t2
-> do { s' <- tconName s
; t1' <- cvtType t1
; t2' <- cvtType t2
; mk_apps (HsTyVar s') [t1', t2']
; mk_apps (HsTyVar (noLoc s')) [t1', t2']
}
UInfixT t1 s t2
......@@ -1076,7 +1081,8 @@ cvtTypeKind ty_str ty
; returnL $ HsParTy t'
}
PromotedT nm -> do { nm' <- cName nm; mk_apps (HsTyVar nm') tys' }
PromotedT nm -> do { nm' <- cName nm
; mk_apps (HsTyVar (noLoc nm')) tys' }
-- Promoted data constructor; hence cName
PromotedTupleT n
......@@ -1097,17 +1103,18 @@ cvtTypeKind ty_str ty
| [ty1, L _ (HsExplicitListTy _ tys2)] <- tys'
-> returnL (HsExplicitListTy placeHolderKind (ty1:tys2))
| otherwise
-> mk_apps (HsTyVar (getRdrName consDataCon)) tys'
-> mk_apps (HsTyVar (noLoc (getRdrName consDataCon))) tys'
StarT
-> returnL (HsTyVar (getRdrName liftedTypeKindTyCon))
-> returnL (HsTyVar (noLoc (getRdrName liftedTypeKindTyCon)))
ConstraintT
-> returnL (HsTyVar (getRdrName constraintKindTyCon))
-> returnL (HsTyVar (noLoc (getRdrName constraintKindTyCon)))
EqualityT
| [x',y'] <- tys' -> returnL (HsEqTy x' y')
| otherwise -> mk_apps (HsTyVar (getRdrName eqPrimTyCon)) tys'
| otherwise
-> mk_apps (HsTyVar (noLoc (getRdrName eqPrimTyCon))) tys'
_ -> failWith (ptext (sLit ("Malformed " ++ ty_str)) <+> text (show ty))
}
......
......@@ -127,7 +127,7 @@ is Less Cool because
-- | A Haskell expression.
data HsExpr id
= HsVar id -- ^ Variable
= HsVar (Located id) -- ^ Variable
| HsUnboundVar OccName -- ^ Unbound variable; also used for "holes" _, or _x.
-- Turned from HsVar to HsUnboundVar by the renamer, when
......@@ -626,7 +626,7 @@ ppr_lexpr :: OutputableBndr id => LHsExpr id -> SDoc
ppr_lexpr e = ppr_expr (unLoc e)
ppr_expr :: forall id. OutputableBndr id => HsExpr id -> SDoc
ppr_expr (HsVar v) = pprPrefixOcc v
ppr_expr (HsVar (L _ v)) = pprPrefixOcc v
ppr_expr (HsUnboundVar v) = pprPrefixOcc v
ppr_expr (HsIPVar v) = ppr v
ppr_expr (HsOverLabel l) = char '#' <> ppr l
......@@ -646,8 +646,8 @@ ppr_expr (HsApp e1 e2)
ppr_expr (OpApp e1 op _ e2)
= case unLoc op of
HsVar v -> pp_infixly v
_ -> pp_prefixly
HsVar (L _ v) -> pp_infixly v
_ -> pp_prefixly
where
pp_e1 = pprDebugParendExpr e1 -- In debug mode, add parens
pp_e2 = pprDebugParendExpr e2 -- to make precedence clear
......@@ -662,8 +662,8 @@ ppr_expr (NegApp e _) = char '-' <+> pprDebugParendExpr e
ppr_expr (SectionL expr op)
= case unLoc op of
HsVar v -> pp_infixly v
_ -> pp_prefixly
HsVar (L _ v) -> pp_infixly v
_ -> pp_prefixly
where
pp_expr = pprDebugParendExpr expr
......@@ -673,8 +673,8 @@ ppr_expr (SectionL expr op)
ppr_expr (SectionR op expr)
= case unLoc op of
HsVar v -> pp_infixly v
_ -> pp_prefixly
HsVar (L _ v) -> pp_infixly v
_ -> pp_prefixly
where
pp_expr = pprDebugParendExpr expr
......@@ -802,7 +802,7 @@ ppr_expr (HsArrApp arrow arg _ HsHigherOrderApp True)
ppr_expr (HsArrApp arrow arg _ HsHigherOrderApp False)
= hsep [ppr_lexpr arg, arrowtt, ppr_lexpr arrow]
ppr_expr (HsArrForm (L _ (HsVar v)) (Just _) [arg1, arg2])
ppr_expr (HsArrForm (L _ (HsVar (L _ v))) (Just _) [arg1, arg2])
= sep [pprCmdArg (unLoc arg1), hsep [pprInfixOcc v, pprCmdArg (unLoc arg2)]]
ppr_expr (HsArrForm op _ args)
= hang (ptext (sLit "(|") <+> ppr_lexpr op)
......@@ -1064,7 +1064,7 @@ ppr_cmd (HsCmdArrApp arrow arg _ HsHigherOrderApp True)
ppr_cmd (HsCmdArrApp arrow arg _ HsHigherOrderApp False)
= hsep [ppr_lexpr arg, arrowtt, ppr_lexpr arrow]
ppr_cmd (HsCmdArrForm (L _ (HsVar v)) (Just _) [arg1, arg2])
ppr_cmd (HsCmdArrForm (L _ (HsVar (L _ v))) (Just _) [arg1, arg2])
= sep [pprCmdArg (unLoc arg1), hsep [pprInfixOcc v, pprCmdArg (unLoc arg2)]]
ppr_cmd (HsCmdArrForm op _ args)
= hang (ptext (sLit "(|") <> ppr_lexpr op)
......
......@@ -74,7 +74,7 @@ data Pat id
-- The sole reason for a type on a WildPat is to
-- support hsPatType :: Pat Id -> Type
| VarPat id -- Variable
| VarPat (Located id) -- Variable
| LazyPat (LPat id) -- Lazy pattern
-- ^ - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnTilde'
......@@ -384,7 +384,7 @@ pprParendPat p = getPprStyle $ \ sty ->
-- is the pattern inside that matters. Sigh.
pprPat :: (OutputableBndr name) => Pat name -> SDoc
pprPat (VarPat var) = pprPatBndr var
pprPat (VarPat (L _ var)) = pprPatBndr var
pprPat (WildPat _) = char '_'
pprPat (LazyPat pat) = char '~' <> pprParendLPat pat
pprPat (BangPat pat) = char '!' <> pprParendLPat pat
......
......@@ -225,7 +225,7 @@ instance OutputableBndr HsIPName where
--------------------------------------------------
data HsTyVarBndr name
= UserTyVar -- no explicit kinding
name
(Located name)
| KindedTyVar
(Located name)
......@@ -265,8 +265,9 @@ data HsType name
-- For details on above see note [Api annotations] in ApiAnnotation
| HsTyVar name -- Type variable, type constructor, or data constructor
-- see Note [Promotions (HsTyVar)]
| HsTyVar (Located name)
-- Type variable, type constructor, or data constructor
-- see Note [Promotions (HsTyVar)]
-- ^ - 'ApiAnnotation.AnnKeywordId' : None
-- For details on above see note [Api annotations] in ApiAnnotation
......@@ -426,9 +427,9 @@ mkHsOpTy :: LHsType name -> Located name -> LHsType name -> HsType name
mkHsOpTy ty1 op ty2 = HsOpTy ty1 (WpKiApps [], op) ty2
data HsWildCardInfo name
= AnonWildCard (PostRn name Name)
= AnonWildCard (PostRn name (Located Name))
-- A anonymous wild card ('_'). A name is generated during renaming.
| NamedWildCard name
| NamedWildCard (Located name)
-- A named wild card ('_a').
deriving (Typeable)
deriving instance (DataId name) => Data (HsWildCardInfo name)
......@@ -726,7 +727,7 @@ hsExplicitTvs _ = []
---------------------
hsTyVarName :: HsTyVarBndr name -> name
hsTyVarName (UserTyVar n) = n
hsTyVarName (UserTyVar (L _ n)) = n
hsTyVarName (KindedTyVar (L _ n) _) = n
hsLTyVarName :: LHsTyVarBndr name -> name
......@@ -752,8 +753,8 @@ hsLTyVarLocNames qtvs = map hsLTyVarLocName (hsQTvBndrs qtvs)
hsLTyVarBndrToType :: LHsTyVarBndr name -> LHsType name
hsLTyVarBndrToType = fmap cvt
where cvt (UserTyVar n) = HsTyVar n
cvt (KindedTyVar (L name_loc n) kind) = HsKindSig (L name_loc (HsTyVar n))
kind
cvt (KindedTyVar (L name_loc n) kind)
= HsKindSig (L name_loc (HsTyVar (L name_loc n))) kind
-- | Convert a LHsTyVarBndrs to a list of types. Used in Template Haskell
-- quoting for type family equations. Works on *type* variable only, no kind
......@@ -765,7 +766,7 @@ hsLTyVarBndrsToTypes (HsQTvs { hsq_tvs = tvbs }) = map hsLTyVarBndrToType tvbs
mkAnonWildCardTy :: HsType RdrName
mkAnonWildCardTy = HsWildCardTy (AnonWildCard PlaceHolder)
mkNamedWildCardTy :: n -> HsType n
mkNamedWildCardTy :: Located n -> HsType n
mkNamedWildCardTy = HsWildCardTy . NamedWildCard
isAnonWildCard :: HsWildCardInfo name -> Bool
......@@ -776,8 +777,8 @@ isNamedWildCard :: HsWildCardInfo name -> Bool
isNamedWildCard = not . isAnonWildCard
wildCardName :: HsWildCardInfo Name -> Name
wildCardName (NamedWildCard n) = n
wildCardName (AnonWildCard n) = n
wildCardName (NamedWildCard (L _ n)) = n
wildCardName (AnonWildCard (L _ n)) = n
-- Two wild cards are the same when: they're both named and have the same
-- name, or they're both anonymous and have the same location.
......@@ -785,13 +786,15 @@ sameWildCard :: Eq name
=> Located (HsWildCardInfo name)
-> Located (HsWildCardInfo name) -> Bool
sameWildCard (L l1 (AnonWildCard _)) (L l2 (AnonWildCard _)) = l1 == l2
sameWildCard (L _ (NamedWildCard n1)) (L _ (NamedWildCard n2)) = n1 == n2
sameWildCard (L _ (NamedWildCard (L _ n1)))
(L _ (NamedWildCard (L _ n2))) = n1 == n2
sameWildCard _ _ = False
sameNamedWildCard :: Eq name
=> Located (HsWildCardInfo name)
-> Located (HsWildCardInfo name) -> Bool
sameNamedWildCard (L _ (NamedWildCard n1)) (L _ (NamedWildCard n2)) = n1 == n2
sameNamedWildCard (L _ (NamedWildCard (L _ n1)))
(L _ (NamedWildCard (L _ n2))) = n1 == n2
sameNamedWildCard _ _ = False
splitHsAppTys :: LHsType n -> [LHsType n] -> (LHsType n, [LHsType n])
......@@ -806,7 +809,7 @@ splitHsAppTys f as = (f,as)
hsTyGetAppHead_maybe :: LHsType n -> Maybe (n, [LHsType n])
hsTyGetAppHead_maybe = go []
where
go tys (L _ (HsTyVar n)) = Just (n, tys)
go tys (L _ (HsTyVar (L _ n))) = Just (n, tys)
go tys (L _ (HsAppTy l r)) = go (r : tys) l
go tys (L _ (HsOpTy l (_, L _ n) r)) = Just (n, l : r : tys)
go tys (L _ (HsParTy t)) = go tys t
......@@ -854,13 +857,13 @@ splitLHsClassTy_maybe :: LHsType name -> Maybe (Located name, [LHsType name])
splitLHsClassTy_maybe ty
= checkl ty []
where
checkl (L l ty) args = case ty of
HsTyVar t -> Just (L l t, args)
HsAppTy l r -> checkl l (r:args)
HsOpTy l (_, tc) r -> checkl (fmap HsTyVar tc) (l:r:args)
HsParTy t -> checkl t args
HsKindSig ty _ -> checkl ty args
_ -> Nothing
checkl (L _ ty) args = case ty of
HsTyVar (L lt t) -> Just (L lt t, args)
HsAppTy l r -> checkl l (r:args)
HsOpTy l (_,L lt tc) r -> checkl (L lt (HsTyVar (L lt tc))) (l:r:args)
HsParTy t -> checkl t args
HsKindSig ty _ -> checkl ty args
_ -> Nothing
-- splitHsFunType decomposes a type (t1 -> t2 ... -> tn)
-- Breaks up any parens in the result type:
......@@ -878,7 +881,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 fn)) tys | fn == funTyConName
go (L _ (HsTyVar (L _ fn))) tys | fn == funTyConName
, [t1,t2] <- tys
, (args, res) <- splitHsFunType t2
= (t1:args, res)
......@@ -1010,7 +1013,7 @@ ppr_mono_ty ctxt_prec (HsForAllTy exp extra tvs ctxt ty)
ppr_mono_ty _ (HsBangTy b ty) = ppr b <> ppr_mono_lty TyConPrec ty
ppr_mono_ty _ (HsRecTy flds) = pprConDeclFields flds
ppr_mono_ty _ (HsTyVar name) = pprPrefixOcc name
ppr_mono_ty _ (HsTyVar (L _ name))= pprPrefixOcc name
ppr_mono_ty prec (HsFunTy ty1 ty2) = ppr_fun_ty prec ty1 ty2
ppr_mono_ty _ (HsTupleTy con tys) = tupleParens std_con (pprWithCommas ppr tys)
where std_con = case con of
......
......@@ -194,7 +194,7 @@ mkSimpleHsAlt pat expr
= mkSimpleMatch [pat] expr
nlHsTyApp :: name -> [Type] -> LHsExpr name
nlHsTyApp fun_id tys = noLoc (HsWrap (mkWpTyApps tys) (HsVar fun_id))
nlHsTyApp fun_id tys = noLoc (HsWrap (mkWpTyApps tys) (HsVar (noLoc fun_id)))
nlHsTyApps :: name -> [Type] -> [LHsExpr name] -> LHsExpr name
nlHsTyApps fun_id tys xs = foldl nlHsApp (nlHsTyApp fun_id tys) xs
......@@ -299,7 +299,8 @@ 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 op)) (error "mkOpApp:fixity") e2
mkHsOpApp e1 op e2 = OpApp e1 (noLoc (HsVar (noLoc op)))
(error "mkOpApp:fixity") e2
unqualSplice :: RdrName
unqualSplice = mkRdrUnqual (mkVarOccFS (fsLit "splice"))
......@@ -334,7 +335,7 @@ mkHsStringPrimLit fs
-------------
userHsTyVarBndrs :: SrcSpan -> [name] -> [Located (HsTyVarBndr name)]
-- Caller sets location
userHsTyVarBndrs loc bndrs = [ L loc (UserTyVar v) | v <- bndrs ]
userHsTyVarBndrs loc bndrs = [ L loc (UserTyVar (L loc v)) | v <- bndrs ]
{-
************************************************************************
......@@ -345,13 +346,13 @@ userHsTyVarBndrs loc bndrs = [ L loc (UserTyVar v) | v <- bndrs ]
-}
nlHsVar :: id -> LHsExpr id
nlHsVar n = noLoc (HsVar n)
nlHsVar n = noLoc (HsVar (noLoc n))
nlHsLit :: HsLit -> LHsExpr id
nlHsLit n = noLoc (HsLit n)
nlVarPat :: id -> LPat id
nlVarPat n = noLoc (VarPat n)
nlVarPat n = noLoc (VarPat (noLoc n))
nlLitPat :: HsLit -> LPat id
nlLitPat l = noLoc (LitPat l)
......@@ -366,7 +367,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 f) (map HsVar xs))
nlHsVarApps f xs = noLoc (foldl mk (HsVar (noLoc f)) (map (HsVar . noLoc) xs))
where
mk f a = HsApp (noLoc f) (noLoc a)
......@@ -427,7 +428,7 @@ nlHsTyVar :: name -> LHsType name
nlHsFunTy :: LHsType name -> LHsType name -> LHsType name
nlHsAppTy f t = noLoc (HsAppTy f t)
nlHsTyVar x = noLoc (HsTyVar x)
nlHsTyVar x = noLoc (HsTyVar (noLoc x))
nlHsFunTy a b = noLoc (HsFunTy a b)
nlHsTyConApp :: name -> [LHsType name] -> LHsType name
......@@ -781,7 +782,7 @@ collect_lpat :: LPat name -> [name] -> [name]
collect_lpat (L _ pat) bndrs
= go pat
where
go (VarPat var) = var : bndrs
go (VarPat (L _ var)) = var : bndrs
go (WildPat _) = bndrs
go (LazyPat pat) = collect_lpat pat bndrs
go (BangPat pat) = collect_lpat pat bndrs
......
......@@ -17,6 +17,7 @@ import Coercion
import {-# SOURCE #-} ConLike (ConLike)
import TcEvidence (HsWrapper)
import FieldLabel
import SrcLoc (Located)
import Data.Data hiding ( Fixity )
import BasicTypes (Fixity)
......@@ -103,6 +104,7 @@ type DataId id =
, Data (PostRn id Fixity)
, Data (PostRn id Bool)
, Data (PostRn id Name)
, Data (PostRn id (Located Name))
, Data (PostRn id [Name])
-- , Data (PostRn id [id])
, Data (PostRn id id)
......
......@@ -1045,7 +1045,8 @@ dynCompileExpr expr = do
parsed_expr <- parseExpr expr
-- > Data.Dynamic.toDyn expr
let loc = getLoc parsed_expr
to_dyn_expr = mkHsApp (L loc . HsVar $ getRdrName toDynName) parsed_expr
to_dyn_expr = mkHsApp (L loc . HsVar . L loc $ getRdrName toDynName)
parsed_expr
hval <- compileParsedExpr to_dyn_expr
return (unsafeCoerce# hval :: Dynamic)