aboutsummaryrefslogtreecommitdiff
path: root/haddock-api/src/Haddock/Interface
diff options
context:
space:
mode:
authorAlan Zimmerman <alan.zimm@gmail.com>2017-10-17 15:00:02 +0200
committerAlan Zimmerman <alan.zimm@gmail.com>2017-11-07 08:28:03 +0200
commit01eeeb048acd2dd05ff6471ae148a97cf0720547 (patch)
tree3598e6d0f16fee0640d96b4cf12426155608acae /haddock-api/src/Haddock/Interface
parent1789c77a6ed1580dc10a4391dc8c398e902f03b1 (diff)
Match changes for Trees that Grow in GHC
Diffstat (limited to 'haddock-api/src/Haddock/Interface')
-rw-r--r--haddock-api/src/Haddock/Interface/Create.hs30
-rw-r--r--haddock-api/src/Haddock/Interface/Rename.hs72
-rw-r--r--haddock-api/src/Haddock/Interface/Specialize.hs164
3 files changed, 130 insertions, 136 deletions
diff --git a/haddock-api/src/Haddock/Interface/Create.hs b/haddock-api/src/Haddock/Interface/Create.hs
index 27456998..c6a67af0 100644
--- a/haddock-api/src/Haddock/Interface/Create.hs
+++ b/haddock-api/src/Haddock/Interface/Create.hs
@@ -454,12 +454,12 @@ subordinates instMap decl = case decl of
cons = map unL $ (dd_cons dd)
constrs = [ (unL cname, maybeToList $ fmap unL $ con_doc c, M.empty)
| c <- cons, cname <- getConNames c ]
- fields = [ (selectorFieldOcc n, maybeToList $ fmap unL doc, M.empty)
+ fields = [ (extFieldOcc n, maybeToList $ fmap unL doc, M.empty)
| RecCon flds <- map getConDetails cons
, L _ (ConDeclField ns _ doc) <- (unLoc flds)
, L _ n <- ns ]
derivs = [ (instName, [unL doc], M.empty)
- | HsIB { hsib_body = L l (HsDocTy _ doc) }
+ | HsIB { hsib_body = L l (HsDocTy _ _ doc) }
<- concatMap (unLoc . deriv_clause_tys . unLoc) $
unLoc $ dd_derivs dd
, Just instName <- [M.lookup l instMap] ]
@@ -478,9 +478,9 @@ typeDocs d =
where
go n (HsForAllTy { hst_body = ty }) = go n (unLoc ty)
go n (HsQualTy { hst_body = ty }) = go n (unLoc ty)
- go n (HsFunTy (L _ (HsDocTy _ (L _ x))) (L _ ty)) = M.insert n x $ go (n+1) ty
- go n (HsFunTy _ ty) = go (n+1) (unLoc ty)
- go n (HsDocTy _ (L _ doc)) = M.singleton n doc
+ go n (HsFunTy _ (L _ (HsDocTy _ _ (L _ x))) (L _ ty)) = M.insert n x $ go (n+1) ty
+ go n (HsFunTy _ _ ty) = go (n+1) (unLoc ty)
+ go n (HsDocTy _ _ (L _ doc)) = M.singleton n doc
go _ _ = M.empty
@@ -1031,7 +1031,7 @@ extractDecl name decl
, RecCon rec <- map (getConDetails . unLoc) (dd_cons (feqn_rhs d))
, ConDeclField { cd_fld_names = ns } <- map unLoc (unLoc rec)
, L _ n <- ns
- , selectorFieldOcc n == name
+ , extFieldOcc n == name
]
in case matches of
[d0] -> extractDecl name (noLoc . InstD $ DataFamInstD d0)
@@ -1057,17 +1057,18 @@ extractPatternSyn nm t tvs cons =
typ = longArrow args (data_ty con)
typ' =
case con of
- ConDeclH98 { con_cxt = Just cxt } -> noLoc (HsQualTy cxt typ)
+ ConDeclH98 { con_cxt = Just cxt } -> noLoc (HsQualTy PlaceHolder cxt typ)
_ -> typ
- typ'' = noLoc (HsQualTy (noLoc []) typ')
+ typ'' = noLoc (HsQualTy PlaceHolder (noLoc []) typ')
in PatSynSig [noLoc nm] (mkEmptyImplicitBndrs typ'')
- longArrow :: [LHsType name] -> LHsType name -> LHsType name
- longArrow inputs output = foldr (\x y -> noLoc (HsFunTy x y)) output inputs
+ longArrow :: [LHsType (GhcPass name)] -> LHsType (GhcPass name) -> LHsType (GhcPass name)
+ longArrow inputs output = foldr (\x y -> noLoc (HsFunTy PlaceHolder x y)) output inputs
data_ty con
| ConDeclGADT{} <- con = hsib_body $ con_type con
- | otherwise = foldl' (\x y -> noLoc (HsAppTy x y)) (noLoc (HsTyVar NotPromoted (noLoc t))) tvs
+ | otherwise = foldl' (\x y -> noLoc (HsAppTy PlaceHolder x y))
+ (noLoc (HsTyVar PlaceHolder NotPromoted (noLoc t))) tvs
extractRecSel :: Name -> Name -> [LHsType GhcRn] -> [LConDecl GhcRn]
-> LSig GhcRn
@@ -1076,16 +1077,17 @@ extractRecSel _ _ _ [] = error "extractRecSel: selector not found"
extractRecSel nm t tvs (L _ con : rest) =
case getConDetails con of
RecCon (L _ fields) | ((l,L _ (ConDeclField _nn ty _)) : _) <- matching_fields fields ->
- L l (TypeSig [noLoc nm] (mkEmptySigWcType (noLoc (HsFunTy data_ty (getBangType ty)))))
+ L l (TypeSig [noLoc nm] (mkEmptySigWcType (noLoc (HsFunTy PlaceHolder data_ty (getBangType ty)))))
_ -> extractRecSel nm t tvs rest
where
matching_fields :: [LConDeclField GhcRn] -> [(SrcSpan, LConDeclField GhcRn)]
matching_fields flds = [ (l,f) | f@(L _ (ConDeclField ns _ _)) <- flds
- , L l n <- ns, selectorFieldOcc n == nm ]
+ , L l n <- ns, extFieldOcc n == nm ]
data_ty
-- ResTyGADT _ ty <- con_res con = ty
| ConDeclGADT{} <- con = hsib_body $ con_type con
- | otherwise = foldl' (\x y -> noLoc (HsAppTy x y)) (noLoc (HsTyVar NotPromoted (noLoc t))) tvs
+ | otherwise = foldl' (\x y -> noLoc (HsAppTy PlaceHolder x y))
+ (noLoc (HsTyVar PlaceHolder NotPromoted (noLoc t))) tvs
-- | Keep export items with docs.
pruneExportItems :: [ExportItem GhcRn] -> [ExportItem GhcRn]
diff --git a/haddock-api/src/Haddock/Interface/Rename.hs b/haddock-api/src/Haddock/Interface/Rename.hs
index 7023a908..c7e4f6f8 100644
--- a/haddock-api/src/Haddock/Interface/Rename.hs
+++ b/haddock-api/src/Haddock/Interface/Rename.hs
@@ -212,61 +212,61 @@ renameType t = case t of
HsForAllTy { hst_bndrs = tyvars, hst_body = ltype } -> do
tyvars' <- mapM renameLTyVarBndr tyvars
ltype' <- renameLType ltype
- return (HsForAllTy { hst_bndrs = tyvars', hst_body = ltype' })
+ return (HsForAllTy { hst_xforall = PlaceHolder, hst_bndrs = tyvars', hst_body = ltype' })
HsQualTy { hst_ctxt = lcontext , hst_body = ltype } -> do
lcontext' <- renameLContext lcontext
ltype' <- renameLType ltype
- return (HsQualTy { hst_ctxt = lcontext', hst_body = ltype' })
+ return (HsQualTy { hst_xqual = PlaceHolder, hst_ctxt = lcontext', hst_body = ltype' })
- HsTyVar ip (L l n) -> return . HsTyVar ip . L l =<< rename n
- HsBangTy b ltype -> return . HsBangTy b =<< renameLType ltype
+ HsTyVar _ ip (L l n) -> return . HsTyVar PlaceHolder ip . L l =<< rename n
+ HsBangTy _ b ltype -> return . HsBangTy PlaceHolder b =<< renameLType ltype
- HsAppTy a b -> do
+ HsAppTy _ a b -> do
a' <- renameLType a
b' <- renameLType b
- return (HsAppTy a' b')
+ return (HsAppTy PlaceHolder a' b')
- HsFunTy a b -> do
+ HsFunTy _ a b -> do
a' <- renameLType a
b' <- renameLType b
- return (HsFunTy a' b')
+ return (HsFunTy PlaceHolder a' b')
- HsListTy ty -> return . HsListTy =<< renameLType ty
- HsPArrTy ty -> return . HsPArrTy =<< renameLType ty
- HsIParamTy n ty -> liftM (HsIParamTy n) (renameLType ty)
- HsEqTy ty1 ty2 -> liftM2 HsEqTy (renameLType ty1) (renameLType ty2)
+ HsListTy _ ty -> return . (HsListTy PlaceHolder) =<< renameLType ty
+ HsPArrTy _ ty -> return . (HsPArrTy PlaceHolder) =<< renameLType ty
+ HsIParamTy _ n ty -> liftM (HsIParamTy PlaceHolder n) (renameLType ty)
+ HsEqTy _ ty1 ty2 -> liftM2 (HsEqTy PlaceHolder) (renameLType ty1) (renameLType ty2)
- HsTupleTy b ts -> return . HsTupleTy b =<< mapM renameLType ts
- HsSumTy ts -> HsSumTy <$> mapM renameLType ts
+ HsTupleTy _ b ts -> return . HsTupleTy PlaceHolder b =<< mapM renameLType ts
+ HsSumTy _ ts -> HsSumTy PlaceHolder <$> mapM renameLType ts
- HsOpTy a (L loc op) b -> do
+ HsOpTy _ a (L loc op) b -> do
op' <- rename op
a' <- renameLType a
b' <- renameLType b
- return (HsOpTy a' (L loc op') b')
+ return (HsOpTy PlaceHolder a' (L loc op') b')
- HsParTy ty -> return . HsParTy =<< renameLType ty
+ HsParTy _ ty -> return . (HsParTy PlaceHolder) =<< renameLType ty
- HsKindSig ty k -> do
+ HsKindSig _ ty k -> do
ty' <- renameLType ty
k' <- renameLKind k
- return (HsKindSig ty' k')
+ return (HsKindSig PlaceHolder ty' k')
- HsDocTy ty doc -> do
+ HsDocTy _ ty doc -> do
ty' <- renameLType ty
doc' <- renameLDocHsSyn doc
- return (HsDocTy ty' doc')
+ return (HsDocTy PlaceHolder ty' doc')
- HsTyLit x -> return (HsTyLit x)
+ HsTyLit _ x -> return (HsTyLit PlaceHolder x)
- HsRecTy a -> HsRecTy <$> mapM renameConDeclFieldField a
- HsCoreTy a -> pure (HsCoreTy a)
- HsExplicitListTy i a b -> HsExplicitListTy i a <$> mapM renameLType b
- HsExplicitTupleTy a b -> HsExplicitTupleTy a <$> mapM renameLType b
- HsSpliceTy _ _ -> error "renameType: HsSpliceTy"
- HsWildCardTy a -> HsWildCardTy <$> renameWildCardInfo a
- HsAppsTy _ -> error "renameType: HsAppsTy"
+ HsRecTy _ a -> HsRecTy PlaceHolder <$> mapM renameConDeclFieldField a
+ (XHsType (NHsCoreTy a)) -> pure (XHsType (NHsCoreTy a))
+ HsExplicitListTy x i b -> HsExplicitListTy x i <$> mapM renameLType b
+ HsExplicitTupleTy x b -> HsExplicitTupleTy x <$> mapM renameLType b
+ HsSpliceTy _ _ -> error "renameType: HsSpliceTy"
+ HsWildCardTy a -> HsWildCardTy <$> renameWildCardInfo a
+ HsAppsTy _ _ -> error "renameType: HsAppsTy"
renameLHsQTyVars :: LHsQTyVars GhcRn -> RnM (LHsQTyVars DocNameI)
renameLHsQTyVars (HsQTvs { hsq_implicit = _, hsq_explicit = tvs })
@@ -275,13 +275,14 @@ renameLHsQTyVars (HsQTvs { hsq_implicit = _, hsq_explicit = tvs })
-- This is rather bogus, but I'm not sure what else to do
renameLTyVarBndr :: LHsTyVarBndr GhcRn -> RnM (LHsTyVarBndr DocNameI)
-renameLTyVarBndr (L loc (UserTyVar (L l n)))
+renameLTyVarBndr (L loc (UserTyVar x (L l n)))
= do { n' <- rename n
- ; return (L loc (UserTyVar (L l n'))) }
-renameLTyVarBndr (L loc (KindedTyVar (L lv n) kind))
+ ; return (L loc (UserTyVar x (L l n'))) }
+renameLTyVarBndr (L loc (KindedTyVar x (L lv n) kind))
= do { n' <- rename n
; kind' <- renameLKind kind
- ; return (L loc (KindedTyVar (L lv n') kind')) }
+ ; return (L loc (KindedTyVar x (L lv n') kind')) }
+renameLTyVarBndr (L _ (XTyVarBndr _ )) = error "haddock:renameLTyVarBndr"
renameLContext :: Located [LHsType GhcRn] -> RnM (Located [LHsType DocNameI])
renameLContext (L loc context) = do
@@ -466,9 +467,10 @@ renameConDeclFieldField (L l (ConDeclField names t doc)) = do
return $ L l (ConDeclField names' t' doc')
renameLFieldOcc :: LFieldOcc GhcRn -> RnM (LFieldOcc DocNameI)
-renameLFieldOcc (L l (FieldOcc lbl sel)) = do
+renameLFieldOcc (L l (FieldOcc sel lbl)) = do
sel' <- rename sel
- return $ L l (FieldOcc lbl sel')
+ return $ L l (FieldOcc sel' lbl)
+renameLFieldOcc (L _ (XFieldOcc _)) = error "haddock:renameLFieldOcc"
renameSig :: Sig GhcRn -> RnM (Sig DocNameI)
renameSig sig = case sig of
diff --git a/haddock-api/src/Haddock/Interface/Specialize.hs b/haddock-api/src/Haddock/Interface/Specialize.hs
index 6d2888d3..0cac818d 100644
--- a/haddock-api/src/Haddock/Interface/Specialize.hs
+++ b/haddock-api/src/Haddock/Interface/Specialize.hs
@@ -28,20 +28,19 @@ import Data.Set (Set)
import qualified Data.Set as Set
-- | Instantiate all occurrences of given names with corresponding types.
-specialize :: forall name a. (Ord (IdP name), DataId name, NamedThing (IdP name))
- => Data a
- => [(IdP name, HsType name)] -> a -> a
+specialize :: Data a
+ => [(Name, HsType GhcRn)] -> a -> a
specialize specs = go
where
go :: forall x. Data x => x -> x
- go = everywhereButType @name $ mkT $ sugar . strip_kind_sig . specialize_ty_var
+ go = everywhereButType @Name $ mkT $ sugar . strip_kind_sig . specialize_ty_var
strip_kind_sig :: HsType name -> HsType name
- strip_kind_sig (HsKindSig (L _ t) _) = t
+ strip_kind_sig (HsKindSig _ (L _ t) _) = t
strip_kind_sig typ = typ
- specialize_ty_var :: HsType name -> HsType name
- specialize_ty_var (HsTyVar _ (L _ name'))
+ specialize_ty_var :: HsType GhcRn -> HsType GhcRn
+ specialize_ty_var (HsTyVar _ _ (L _ name'))
| Just t <- Map.lookup name' spec_map = t
specialize_ty_var typ = typ
-- This is a tricky recursive definition that is guaranteed to terminate
@@ -54,35 +53,33 @@ specialize specs = go
--
-- Again, it is just a convenience function around 'specialize'. Note that
-- length of type list should be the same as the number of binders.
-specializeTyVarBndrs :: (Ord (IdP name), DataId name, NamedThing (IdP name))
- => Data a
- => LHsQTyVars name -> [HsType name]
+specializeTyVarBndrs :: Data a
+ => LHsQTyVars GhcRn -> [HsType GhcRn]
-> a -> a
specializeTyVarBndrs bndrs typs =
specialize $ zip bndrs' typs
where
bndrs' = map (bname . unLoc) . hsq_explicit $ bndrs
- bname (UserTyVar (L _ name)) = name
- bname (KindedTyVar (L _ name) _) = name
+ bname (UserTyVar _ (L _ name)) = name
+ bname (KindedTyVar _ (L _ name) _) = name
+ bname (XTyVarBndr _) = error "haddock:specializeTyVarBndrs"
-specializePseudoFamilyDecl :: (Ord (IdP name), DataId name, NamedThing (IdP name))
- => LHsQTyVars name -> [HsType name]
- -> PseudoFamilyDecl name
- -> PseudoFamilyDecl name
+specializePseudoFamilyDecl :: LHsQTyVars GhcRn -> [HsType GhcRn]
+ -> PseudoFamilyDecl GhcRn
+ -> PseudoFamilyDecl GhcRn
specializePseudoFamilyDecl bndrs typs decl =
decl {pfdTyVars = map (specializeTyVarBndrs bndrs typs) (pfdTyVars decl)}
-specializeSig :: forall name . (Ord (IdP name), DataId name, SetName (IdP name), NamedThing (IdP name))
- => LHsQTyVars name -> [HsType name]
- -> Sig name
- -> Sig name
+specializeSig :: LHsQTyVars GhcRn -> [HsType GhcRn]
+ -> Sig GhcRn
+ -> Sig GhcRn
specializeSig bndrs typs (TypeSig lnames typ) =
TypeSig lnames (typ {hswc_body = (hswc_body typ) {hsib_body = noLoc typ'}})
where
- true_type :: HsType name
+ true_type :: HsType GhcRn
true_type = unLoc (hsSigWcType typ)
- typ' :: HsType name
+ typ' :: HsType GhcRn
typ' = rename fv $ specializeTyVarBndrs bndrs typs true_type
fv = foldr Set.union Set.empty . map freeVariables $ typs
specializeSig _ _ sig = sig
@@ -90,8 +87,7 @@ specializeSig _ _ sig = sig
-- | Make all details of instance head (signatures, associated types)
-- specialized to that particular instance type.
-specializeInstHead :: (Ord (IdP name), DataId name, SetName (IdP name), NamedThing (IdP name))
- => InstHead name -> InstHead name
+specializeInstHead :: InstHead GhcRn -> InstHead GhcRn
specializeInstHead ihd@InstHead { ihdInstType = clsi@ClassInst { .. }, .. } =
ihd { ihdInstType = instType' }
where
@@ -110,27 +106,26 @@ specializeInstHead ihd = ihd
-- and tuple literals resulting in types like @[] a@ or @(,,) a b c@. This
-- can be fixed using 'sugar' function, that will turn such types into @[a]@
-- and @(a, b, c)@.
-sugar :: forall name. (NamedThing (IdP name), DataId name)
- => HsType name -> HsType name
+sugar :: HsType GhcRn -> HsType GhcRn
sugar = sugarOperators . sugarTuples . sugarLists
-sugarLists :: NamedThing (IdP name) => HsType name -> HsType name
-sugarLists (HsAppTy (L _ (HsTyVar _ (L _ name))) ltyp)
- | isBuiltInSyntax name' && strName == "[]" = HsListTy ltyp
+sugarLists :: NamedThing (IdP (GhcPass p)) => HsType (GhcPass p) -> HsType (GhcPass p)
+sugarLists (HsAppTy _ (L _ (HsTyVar _ _ (L _ name))) ltyp)
+ | isBuiltInSyntax name' && strName == "[]" = HsListTy PlaceHolder ltyp
where
name' = getName name
strName = occNameString . nameOccName $ name'
sugarLists typ = typ
-sugarTuples :: NamedThing (IdP name) => HsType name -> HsType name
+sugarTuples :: NamedThing (IdP (GhcPass p)) => HsType (GhcPass p) -> HsType (GhcPass p)
sugarTuples typ =
aux [] typ
where
- aux apps (HsAppTy (L _ ftyp) atyp) = aux (atyp:apps) ftyp
- aux apps (HsParTy (L _ typ')) = aux apps typ'
- aux apps (HsTyVar _ (L _ name))
- | isBuiltInSyntax name' && suitable = HsTupleTy HsBoxedTuple apps
+ aux apps (HsAppTy _ (L _ ftyp) atyp) = aux (atyp:apps) ftyp
+ aux apps (HsParTy _ (L _ typ')) = aux apps typ'
+ aux apps (HsTyVar _ _ (L _ name))
+ | isBuiltInSyntax name' && suitable = HsTupleTy PlaceHolder HsBoxedTuple apps
where
name' = getName name
strName = occNameString . nameOccName $ name'
@@ -140,10 +135,10 @@ sugarTuples typ =
aux _ _ = typ
-sugarOperators :: NamedThing (IdP name) => HsType name -> HsType name
-sugarOperators (HsAppTy (L _ (HsAppTy (L _ (HsTyVar _ (L l name))) la)) lb)
+sugarOperators :: NamedThing (IdP (GhcPass p)) => HsType (GhcPass p) -> HsType (GhcPass p)
+sugarOperators (HsAppTy _ (L _ (HsAppTy _ (L _ (HsTyVar _ _ (L l name))) la)) lb)
| isSymOcc $ getOccName name' = mkHsOpTy la (L l name) lb
- | isBuiltInSyntax name' && getOccString name == "(->)" = HsFunTy la lb
+ | isBuiltInSyntax name' && getOccString name == "(->)" = HsFunTy PlaceHolder la lb
where
name' = getName name
sugarOperators typ = typ
@@ -208,15 +203,15 @@ setInternalOccName occ name =
-- | Compute set of free variables of given type.
-freeVariables :: forall name. (NamedThing (IdP name), DataId name)
- => HsType name -> Set Name
+freeVariables :: forall p. (NamedThing (IdP p), DataId p, Typeable p)
+ => HsType p -> Set Name
freeVariables =
everythingWithState Set.empty Set.union query
where
- query term ctx = case cast term :: Maybe (HsType name) of
- Just (HsForAllTy bndrs _) ->
+ query term ctx = case cast term :: Maybe (HsType p) of
+ Just (HsForAllTy _ bndrs _) ->
(Set.empty, Set.union ctx (bndrsNames bndrs))
- Just (HsTyVar _ (L _ name))
+ Just (HsTyVar _ _ (L _ name))
| getName name `Set.member` ctx -> (Set.empty, ctx)
| otherwise -> (Set.singleton $ getName name, ctx)
_ -> (Set.empty, ctx)
@@ -231,8 +226,7 @@ freeVariables =
-- different type variable than latter one. Applying 'rename' function
-- will fix that type to be visually unambiguous again (making it something
-- like @(a -> b0) -> b@).
-rename :: (Eq (IdP name), DataId name, SetName (IdP name))
- => Set Name-> HsType name -> HsType name
+rename :: Set Name -> HsType GhcRn -> HsType GhcRn
rename fv typ = evalState (renameType typ) env
where
env = RenameEnv
@@ -252,63 +246,58 @@ data RenameEnv name = RenameEnv
}
-renameType :: (Eq (IdP name), SetName (IdP name))
- => HsType name -> Rename (IdP name) (HsType name)
-renameType (HsForAllTy bndrs lt) =
- HsForAllTy
+renameType :: HsType GhcRn -> Rename (IdP GhcRn) (HsType GhcRn)
+renameType (HsForAllTy x bndrs lt) =
+ HsForAllTy x
<$> mapM (located renameBinder) bndrs
<*> renameLType lt
-renameType (HsQualTy lctxt lt) =
- HsQualTy
+renameType (HsQualTy x lctxt lt) =
+ HsQualTy x
<$> located renameContext lctxt
<*> renameLType lt
-renameType (HsTyVar ip name) = HsTyVar ip <$> located renameName name
-renameType (HsAppTy lf la) = HsAppTy <$> renameLType lf <*> renameLType la
-renameType (HsFunTy la lr) = HsFunTy <$> renameLType la <*> renameLType lr
-renameType (HsListTy lt) = HsListTy <$> renameLType lt
-renameType (HsPArrTy lt) = HsPArrTy <$> renameLType lt
-renameType (HsTupleTy srt lt) = HsTupleTy srt <$> mapM renameLType lt
-renameType (HsSumTy lt) = HsSumTy <$> mapM renameLType lt
-renameType (HsOpTy la lop lb) =
- HsOpTy <$> renameLType la <*> located renameName lop <*> renameLType lb
-renameType (HsParTy lt) = HsParTy <$> renameLType lt
-renameType (HsIParamTy ip lt) = HsIParamTy ip <$> renameLType lt
-renameType (HsEqTy la lb) = HsEqTy <$> renameLType la <*> renameLType lb
-renameType (HsKindSig lt lk) = HsKindSig <$> renameLType lt <*> pure lk
+renameType (HsTyVar x ip name) = HsTyVar x ip <$> located renameName name
+renameType (HsAppTy x lf la) = HsAppTy x <$> renameLType lf <*> renameLType la
+renameType (HsFunTy x la lr) = HsFunTy x <$> renameLType la <*> renameLType lr
+renameType (HsListTy x lt) = HsListTy x <$> renameLType lt
+renameType (HsPArrTy x lt) = HsPArrTy x <$> renameLType lt
+renameType (HsTupleTy x srt lt) = HsTupleTy x srt <$> mapM renameLType lt
+renameType (HsSumTy x lt) = HsSumTy x <$> mapM renameLType lt
+renameType (HsOpTy x la lop lb) =
+ HsOpTy x <$> renameLType la <*> located renameName lop <*> renameLType lb
+renameType (HsParTy x lt) = HsParTy x <$> renameLType lt
+renameType (HsIParamTy x ip lt) = HsIParamTy x ip <$> renameLType lt
+renameType (HsEqTy x la lb) = HsEqTy x <$> renameLType la <*> renameLType lb
+renameType (HsKindSig x lt lk) = HsKindSig x <$> renameLType lt <*> pure lk
renameType t@(HsSpliceTy _ _) = pure t
-renameType (HsDocTy lt doc) = HsDocTy <$> renameLType lt <*> pure doc
-renameType (HsBangTy bang lt) = HsBangTy bang <$> renameLType lt
-renameType t@(HsRecTy _) = pure t
-renameType t@(HsCoreTy _) = pure t
-renameType (HsExplicitListTy ip ph ltys) =
- HsExplicitListTy ip ph <$> renameLTypes ltys
-renameType (HsExplicitTupleTy phs ltys) =
- HsExplicitTupleTy phs <$> renameLTypes ltys
-renameType t@(HsTyLit _) = pure t
+renameType (HsDocTy x lt doc) = HsDocTy x <$> renameLType lt <*> pure doc
+renameType (HsBangTy x bang lt) = HsBangTy x bang <$> renameLType lt
+renameType t@(HsRecTy _ _) = pure t
+renameType t@(XHsType (NHsCoreTy _)) = pure t
+renameType (HsExplicitListTy x ip ltys) =
+ HsExplicitListTy x ip <$> renameLTypes ltys
+renameType (HsExplicitTupleTy x ltys) =
+ HsExplicitTupleTy x <$> renameLTypes ltys
+renameType t@(HsTyLit _ _) = pure t
renameType (HsWildCardTy wc) = pure (HsWildCardTy wc)
-renameType (HsAppsTy _) = error "HsAppsTy: Only used before renaming"
+renameType (HsAppsTy _ _) = error "HsAppsTy: Only used before renaming"
-renameLType :: (Eq (IdP name), SetName (IdP name))
- => LHsType name -> Rename (IdP name) (LHsType name)
+renameLType :: LHsType GhcRn -> Rename (IdP GhcRn) (LHsType GhcRn)
renameLType = located renameType
-renameLTypes :: (Eq (IdP name), SetName (IdP name))
- => [LHsType name] -> Rename (IdP name) [LHsType name]
+renameLTypes :: [LHsType GhcRn] -> Rename (IdP GhcRn) [LHsType GhcRn]
renameLTypes = mapM renameLType
-renameContext :: (Eq (IdP name), SetName (IdP name))
- => HsContext name -> Rename (IdP name) (HsContext name)
+renameContext :: HsContext GhcRn -> Rename (IdP GhcRn) (HsContext GhcRn)
renameContext = renameLTypes
-renameBinder :: (Eq (IdP name), SetName (IdP name))
- => HsTyVarBndr name -> Rename (IdP name) (HsTyVarBndr name)
-renameBinder (UserTyVar lname) = UserTyVar <$> located renameName lname
-renameBinder (KindedTyVar lname lkind) =
- KindedTyVar <$> located renameName lname <*> located renameType lkind
-
+renameBinder :: HsTyVarBndr GhcRn -> Rename (IdP GhcRn) (HsTyVarBndr GhcRn)
+renameBinder (UserTyVar x lname) = UserTyVar x <$> located renameName lname
+renameBinder (KindedTyVar x lname lkind) =
+ KindedTyVar x <$> located renameName lname <*> located renameType lkind
+renameBinder (XTyVarBndr _) = error "haddock:renameBinder"
-- | Core renaming logic.
renameName :: (Eq name, SetName name) => name -> Rename name name
@@ -363,5 +352,6 @@ located f (L loc e) = L loc <$> f e
tyVarName :: HsTyVarBndr name -> IdP name
-tyVarName (UserTyVar name) = unLoc name
-tyVarName (KindedTyVar (L _ name) _) = name
+tyVarName (UserTyVar _ name) = unLoc name
+tyVarName (KindedTyVar _ (L _ name) _) = name
+tyVarName (XTyVarBndr _ ) = error "haddock:tyVarName"