From fcd1bb7177a800f6f56a623c2468fc46a59c527b Mon Sep 17 00:00:00 2001 From: Alan Zimmerman Date: Sat, 21 Nov 2015 21:16:12 +0200 Subject: Update to match GHC wip/T11019 --- haddock-api/src/Haddock/Backends/Hoogle.hs | 4 ++-- haddock-api/src/Haddock/Backends/LaTeX.hs | 6 +++--- haddock-api/src/Haddock/Backends/Xhtml/Decl.hs | 10 +++++----- haddock-api/src/Haddock/Convert.hs | 6 +++--- haddock-api/src/Haddock/Interface/Create.hs | 4 ++-- haddock-api/src/Haddock/Interface/Rename.hs | 10 +++++----- haddock-api/src/Haddock/Types.hs | 13 +++++++------ 7 files changed, 27 insertions(+), 26 deletions(-) diff --git a/haddock-api/src/Haddock/Backends/Hoogle.hs b/haddock-api/src/Haddock/Backends/Hoogle.hs index 55075e20..68896d72 100644 --- a/haddock-api/src/Haddock/Backends/Hoogle.hs +++ b/haddock-api/src/Haddock/Backends/Hoogle.hs @@ -152,7 +152,7 @@ ppClass dflags x = out dflags x{tcdSigs=[]} : f t = HsForAllTy Implicit Nothing emptyHsQTvs (reL [context]) (reL t) context = nlHsTyConApp (tcdName x) - (map (reL . HsTyVar . hsTyVarName . unL) (hsQTvBndrs (tyClDeclTyVars x))) + (map (reL . HsTyVar . reL . hsTyVarName . unL) (hsQTvBndrs (tyClDeclTyVars x))) ppInstance :: DynFlags -> ClsInst -> [String] @@ -201,7 +201,7 @@ ppCtor dflags dat subdocs con name = out dflags $ map unL $ con_names con resType = case con_res con of - ResTyH98 -> apps $ map (reL . HsTyVar) $ + ResTyH98 -> apps $ map (reL . HsTyVar . reL) $ (tcdName dat) : [hsTyVarName v | L _ v@(UserTyVar _) <- hsQTvBndrs $ tyClDeclTyVars dat] ResTyGADT _ x -> x diff --git a/haddock-api/src/Haddock/Backends/LaTeX.hs b/haddock-api/src/Haddock/Backends/LaTeX.hs index 68149b41..c4468c9c 100644 --- a/haddock-api/src/Haddock/Backends/LaTeX.hs +++ b/haddock-api/src/Haddock/Backends/LaTeX.hs @@ -902,14 +902,14 @@ ppr_mono_ty ctxt_prec (HsForAllTy expl extra tvs ctxt ty) unicode hsep [ppForAll expl tvs ctxt' unicode, ppr_mono_lty pREC_TOP ty unicode] where anonWC :: HsType DocName - anonWC = HsWildCardTy (AnonWildCard (Undocumented underscore)) + anonWC = HsWildCardTy (AnonWildCard (noLoc (Undocumented underscore))) underscore = mkUnboundName (mkRdrUnqual (mkTyVarOcc "_")) ctxt' | Just loc <- extra = (++ [L loc anonWC]) `fmap` ctxt | otherwise = ctxt ppr_mono_ty _ (HsBangTy b ty) u = ppBang b <> ppLParendType u ty -ppr_mono_ty _ (HsTyVar name) _ = ppDocName name +ppr_mono_ty _ (HsTyVar (L _ name)) _ = ppDocName name ppr_mono_ty ctxt_prec (HsFunTy ty1 ty2) u = ppr_fun_ty ctxt_prec ty1 ty2 u ppr_mono_ty _ (HsTupleTy con tys) u = tupleParens con (map (ppLType u) tys) ppr_mono_ty _ (HsKindSig ty kind) u = parens (ppr_mono_lty pREC_TOP ty u <+> dcolon u <+> ppLKind u kind) @@ -947,7 +947,7 @@ ppr_mono_ty ctxt_prec (HsDocTy ty _) unicode ppr_mono_ty _ (HsWildCardTy (AnonWildCard _)) _ = char '_' -ppr_mono_ty _ (HsWildCardTy (NamedWildCard name)) _ = ppDocName name +ppr_mono_ty _ (HsWildCardTy (NamedWildCard (L _ name))) _ = ppDocName name ppr_mono_ty _ (HsTyLit t) u = ppr_tylit t u diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs index 8996fc87..328684f3 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs @@ -835,7 +835,7 @@ ppParendType unicode qual ty = ppr_mono_ty pREC_CON ty unicode qual ppFunLhType unicode qual ty = ppr_mono_ty pREC_FUN ty unicode qual ppHsTyVarBndr :: Unicode -> Qualification -> HsTyVarBndr DocName -> Html -ppHsTyVarBndr _ qual (UserTyVar name ) = +ppHsTyVarBndr _ qual (UserTyVar (L _ name)) = ppDocName qual Raw False name ppHsTyVarBndr unicode qual (KindedTyVar name kind) = parens (ppDocName qual Raw False (unLoc name) <+> dcolon unicode <+> @@ -877,19 +877,19 @@ ppr_mono_ty ctxt_prec (HsForAllTy expl extra tvs ctxt ty) unicode qual = maybeParen ctxt_prec pREC_FUN $ ppForAllCon expl tvs ctxt' unicode qual <+> ppr_mono_lty pREC_TOP ty unicode qual where - anonWC = HsWildCardTy (AnonWildCard (Undocumented underscore)) + anonWC = HsWildCardTy (AnonWildCard (noLoc (Undocumented underscore))) underscore = mkUnboundName (mkRdrUnqual (mkTyVarOcc "_")) ctxt' | Just loc <- extra = (++ [L loc anonWC]) `fmap` ctxt | otherwise = ctxt -- UnicodeSyntax alternatives -ppr_mono_ty _ (HsTyVar name) True _ +ppr_mono_ty _ (HsTyVar (L _ name)) True _ | getOccString (getName name) == "*" = toHtml "★" | getOccString (getName name) == "(->)" = toHtml "(→)" ppr_mono_ty _ (HsBangTy b ty) u q = ppBang b +++ ppLParendType u q ty -ppr_mono_ty _ (HsTyVar name) _ q = ppDocName q Prefix True name +ppr_mono_ty _ (HsTyVar (L _ name)) _ q = ppDocName q Prefix True name ppr_mono_ty ctxt_prec (HsFunTy ty1 ty2) u q = ppr_fun_ty ctxt_prec ty1 ty2 u q ppr_mono_ty _ (HsTupleTy con tys) u q = tupleParens con (map (ppLType u q) tys) ppr_mono_ty _ (HsKindSig ty kind) u q = @@ -928,7 +928,7 @@ ppr_mono_ty ctxt_prec (HsDocTy ty _) unicode qual ppr_mono_ty _ (HsWildCardTy (AnonWildCard _)) _ _ = char '_' -ppr_mono_ty _ (HsWildCardTy (NamedWildCard name)) _ q = ppDocName q Prefix True name +ppr_mono_ty _ (HsWildCardTy (NamedWildCard (L _ name))) _ q = ppDocName q Prefix True name ppr_mono_ty _ (HsTyLit n) _ _ = ppr_tylit n diff --git a/haddock-api/src/Haddock/Convert.hs b/haddock-api/src/Haddock/Convert.hs index a61e3696..ff34d271 100644 --- a/haddock-api/src/Haddock/Convert.hs +++ b/haddock-api/src/Haddock/Convert.hs @@ -326,7 +326,7 @@ synifyTyVars ktvs = HsQTvs { hsq_kvs = map tyVarName kvs where (kvs, tvs) = partition isKindVar ktvs synifyTyVar tv - | isLiftedTypeKind kind = noLoc (UserTyVar name) + | isLiftedTypeKind kind = noLoc (UserTyVar (noLoc name)) | otherwise = noLoc (KindedTyVar (noLoc name) (synifyKindSig kind)) where kind = tyVarKind tv @@ -349,7 +349,7 @@ data SynifyTypeState synifyType :: SynifyTypeState -> Type -> LHsType Name -synifyType _ (TyVarTy tv) = noLoc $ HsTyVar (getName tv) +synifyType _ (TyVarTy tv) = noLoc $ HsTyVar $ noLoc (getName tv) synifyType _ (TyConApp tc tys) -- Use non-prefix tuple syntax where possible, because it looks nicer. | Just sort <- tyConTuple_maybe tc @@ -374,7 +374,7 @@ synifyType _ (TyConApp tc tys) -- Most TyCons: | otherwise = foldl (\t1 t2 -> noLoc (HsAppTy t1 t2)) - (noLoc $ HsTyVar (getName tc)) + (noLoc $ HsTyVar $ noLoc (getName tc)) (map (synifyType WithinType) tys) synifyType _ (AppTy t1 t2) = let s1 = synifyType WithinType t1 diff --git a/haddock-api/src/Haddock/Interface/Create.hs b/haddock-api/src/Haddock/Interface/Create.hs index 9b8bbe50..349356d6 100644 --- a/haddock-api/src/Haddock/Interface/Create.hs +++ b/haddock-api/src/Haddock/Interface/Create.hs @@ -800,7 +800,7 @@ extractDecl name mdl decl toTypeNoLoc :: Located Name -> LHsType Name -toTypeNoLoc = noLoc . HsTyVar . unLoc +toTypeNoLoc = noLoc . HsTyVar extractClassDecl :: Name -> [Located Name] -> LSig Name -> LSig Name @@ -829,7 +829,7 @@ extractRecSel nm mdl t tvs (L _ con : rest) = , L l n <- ns, selectorFieldOcc n == nm ] data_ty | ResTyGADT _ ty <- con_res con = ty - | otherwise = foldl' (\x y -> noLoc (HsAppTy x y)) (noLoc (HsTyVar t)) tvs + | otherwise = foldl' (\x y -> noLoc (HsAppTy x y)) (noLoc (HsTyVar (noLoc t))) tvs -- | Keep export items with docs. diff --git a/haddock-api/src/Haddock/Interface/Rename.hs b/haddock-api/src/Haddock/Interface/Rename.hs index 131082cd..f9edb574 100644 --- a/haddock-api/src/Haddock/Interface/Rename.hs +++ b/haddock-api/src/Haddock/Interface/Rename.hs @@ -204,7 +204,7 @@ renameType t = case t of ltype' <- renameLType ltype return (HsForAllTy expl extra tyvars' lcontext' ltype') - HsTyVar n -> return . HsTyVar =<< rename n + HsTyVar (L l n) -> return . HsTyVar . L l =<< rename n HsBangTy b ltype -> return . HsBangTy b =<< renameLType ltype HsAppTy a b -> do @@ -259,9 +259,9 @@ renameLTyVarBndrs (HsQTvs { hsq_kvs = _, hsq_tvs = tvs }) -- This is rather bogus, but I'm not sure what else to do renameLTyVarBndr :: LHsTyVarBndr Name -> RnM (LHsTyVarBndr DocName) -renameLTyVarBndr (L loc (UserTyVar n)) +renameLTyVarBndr (L loc (UserTyVar (L l n))) = do { n' <- rename n - ; return (L loc (UserTyVar n')) } + ; return (L loc (UserTyVar (L l n'))) } renameLTyVarBndr (L loc (KindedTyVar (L lv n) kind)) = do { n' <- rename n ; kind' <- renameLKind kind @@ -273,8 +273,8 @@ renameLContext (L loc context) = do return (L loc context') renameWildCardInfo :: HsWildCardInfo Name -> RnM (HsWildCardInfo DocName) -renameWildCardInfo (AnonWildCard name) = AnonWildCard <$> rename name -renameWildCardInfo (NamedWildCard name) = NamedWildCard <$> rename name +renameWildCardInfo (AnonWildCard (L l name)) = AnonWildCard . L l <$> rename name +renameWildCardInfo (NamedWildCard (L l name)) = NamedWildCard . L l <$> rename name renameInstHead :: InstHead Name -> RnM (InstHead DocName) renameInstHead (className, k, types, rest) = do diff --git a/haddock-api/src/Haddock/Types.hs b/haddock-api/src/Haddock/Types.hs index 33ab9592..43671de3 100644 --- a/haddock-api/src/Haddock/Types.hs +++ b/haddock-api/src/Haddock/Types.hs @@ -558,12 +558,13 @@ instance Monad ErrMsgGhc where -- * Pass sensitive types ----------------------------------------------------------------------------- -type instance PostRn DocName NameSet = PlaceHolder -type instance PostRn DocName Fixity = PlaceHolder -type instance PostRn DocName Bool = PlaceHolder -type instance PostRn DocName Name = DocName -type instance PostRn DocName [Name] = PlaceHolder -type instance PostRn DocName DocName = DocName +type instance PostRn DocName NameSet = PlaceHolder +type instance PostRn DocName Fixity = PlaceHolder +type instance PostRn DocName Bool = PlaceHolder +type instance PostRn DocName Name = DocName +type instance PostRn DocName (Located Name) = Located DocName +type instance PostRn DocName [Name] = PlaceHolder +type instance PostRn DocName DocName = DocName type instance PostTc DocName Kind = PlaceHolder type instance PostTc DocName Type = PlaceHolder -- cgit v1.2.3