From 134a7bb054ea730b13c8629a76232d73e3ace049 Mon Sep 17 00:00:00 2001 From: Alan Zimmerman Date: Mon, 13 Nov 2017 09:40:34 +0200 Subject: Clean up use of PlaceHolder, to match TTG --- haddock-api/src/Haddock/Backends/Hoogle.hs | 6 ++-- haddock-api/src/Haddock/Backends/LaTeX.hs | 2 +- haddock-api/src/Haddock/Backends/Xhtml/Decl.hs | 4 +-- haddock-api/src/Haddock/Interface/Create.hs | 16 ++++----- haddock-api/src/Haddock/Interface/Rename.hs | 45 +++++++++++++------------ haddock-api/src/Haddock/Interface/Specialize.hs | 6 ++-- haddock-api/src/Haddock/Types.hs | 8 +++-- haddock-api/src/Haddock/Utils.hs | 8 ++--- 8 files changed, 49 insertions(+), 46 deletions(-) (limited to 'haddock-api') diff --git a/haddock-api/src/Haddock/Backends/Hoogle.hs b/haddock-api/src/Haddock/Backends/Hoogle.hs index ae993aba..5707d45f 100644 --- a/haddock-api/src/Haddock/Backends/Hoogle.hs +++ b/haddock-api/src/Haddock/Backends/Hoogle.hs @@ -240,8 +240,8 @@ ppCtor dflags dat subdocs con@ConDeclH98 {} [out dflags (map (extFieldOcc . unLoc) $ cd_fld_names r) `typeSig` [resType, cd_fld_type r]] | r <- map unLoc recs] - funs = foldr1 (\x y -> reL $ HsFunTy PlaceHolder x y) - apps = foldl1 (\x y -> reL $ HsAppTy PlaceHolder x y) + funs = foldr1 (\x y -> reL $ HsFunTy noExt x y) + apps = foldl1 (\x y -> reL $ HsAppTy noExt x y) typeSig nm flds = operator nm ++ " :: " ++ outHsType dflags (unL $ funs flds) @@ -249,7 +249,7 @@ ppCtor dflags dat subdocs con@ConDeclH98 {} -- docs for con_names on why it is a list to begin with. name = commaSeparate dflags . map unL $ getConNames con - resType = apps $ map (reL . HsTyVar PlaceHolder NotPromoted . reL) $ + resType = apps $ map (reL . HsTyVar noExt NotPromoted . reL) $ (tcdName dat) : [hsTyVarName v | L _ v@(UserTyVar _ _) <- hsQTvExplicit $ tyClDeclTyVars dat] ppCtor dflags _dat subdocs con@ConDeclGADT {} diff --git a/haddock-api/src/Haddock/Backends/LaTeX.hs b/haddock-api/src/Haddock/Backends/LaTeX.hs index 856a5f38..03cd868a 100644 --- a/haddock-api/src/Haddock/Backends/LaTeX.hs +++ b/haddock-api/src/Haddock/Backends/LaTeX.hs @@ -660,7 +660,7 @@ ppSideBySideConstr subdocs unicode leader (L _ con@(ConDeclH98 {})) = ppOcc = case occ of [one] -> ppBinder one _ -> cat (punctuate comma (map ppBinder occ)) - tyVars = tyvarNames (fromMaybe (HsQTvs PlaceHolder [] PlaceHolder) (con_qvars con)) + tyVars = tyvarNames (fromMaybe (HsQTvs placeHolder [] placeHolder) (con_qvars con)) context = unLoc (fromMaybe (noLoc []) (con_cxt con)) -- don't use "con_doc con", in case it's reconstructed from a .hi file, diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs index eb7705d1..eda53c61 100644 --- a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs +++ b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs @@ -800,7 +800,7 @@ ppShortConstrParts summary dataInst con unicode qual = case con of [one] -> ppBinderInfix summary one _ -> hsep (punctuate comma (map (ppBinderInfix summary) occ)) - ltvs = fromMaybe (HsQTvs PlaceHolder [] PlaceHolder) (con_qvars con) + ltvs = fromMaybe (HsQTvs placeHolder [] placeHolder) (con_qvars con) tyVars = tyvarNames ltvs lcontext = fromMaybe (noLoc []) (con_cxt con) context = unLoc lcontext @@ -870,7 +870,7 @@ ppSideBySideConstr subdocs fixities unicode qual (L _ con) [one] -> ppBinderInfix False one _ -> hsep (punctuate comma (map (ppBinderInfix False) occ)) - tyVars = tyvarNames (fromMaybe (HsQTvs PlaceHolder [] PlaceHolder) (con_qvars con)) + tyVars = tyvarNames (fromMaybe (HsQTvs placeHolder [] placeHolder) (con_qvars con)) context = unLoc (fromMaybe (noLoc []) (con_cxt con)) forall_ = False -- don't use "con_doc con", in case it's reconstructed from a .hi file, diff --git a/haddock-api/src/Haddock/Interface/Create.hs b/haddock-api/src/Haddock/Interface/Create.hs index 357cd780..048126cf 100644 --- a/haddock-api/src/Haddock/Interface/Create.hs +++ b/haddock-api/src/Haddock/Interface/Create.hs @@ -1057,18 +1057,18 @@ extractPatternSyn nm t tvs cons = typ = longArrow args (data_ty con) typ' = case con of - ConDeclH98 { con_cxt = Just cxt } -> noLoc (HsQualTy PlaceHolder cxt typ) + ConDeclH98 { con_cxt = Just cxt } -> noLoc (HsQualTy noExt cxt typ) _ -> typ - typ'' = noLoc (HsQualTy PlaceHolder (noLoc []) typ') + typ'' = noLoc (HsQualTy noExt (noLoc []) typ') in PatSynSig [noLoc nm] (mkEmptyImplicitBndrs typ'') longArrow :: [LHsType (GhcPass name)] -> LHsType (GhcPass name) -> LHsType (GhcPass name) - longArrow inputs output = foldr (\x y -> noLoc (HsFunTy PlaceHolder x y)) output inputs + longArrow inputs output = foldr (\x y -> noLoc (HsFunTy noExt x y)) output inputs data_ty con | ConDeclGADT{} <- con = hsib_body $ con_type con - | otherwise = foldl' (\x y -> noLoc (HsAppTy PlaceHolder x y)) - (noLoc (HsTyVar PlaceHolder NotPromoted (noLoc t))) tvs + | otherwise = foldl' (\x y -> noLoc (HsAppTy noExt x y)) + (noLoc (HsTyVar noExt NotPromoted (noLoc t))) tvs extractRecSel :: Name -> Name -> [LHsType GhcRn] -> [LConDecl GhcRn] -> LSig GhcRn @@ -1077,7 +1077,7 @@ 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 PlaceHolder data_ty (getBangType ty))))) + L l (TypeSig [noLoc nm] (mkEmptySigWcType (noLoc (HsFunTy noExt data_ty (getBangType ty))))) _ -> extractRecSel nm t tvs rest where matching_fields :: [LConDeclField GhcRn] -> [(SrcSpan, LConDeclField GhcRn)] @@ -1086,8 +1086,8 @@ extractRecSel nm t tvs (L _ con : rest) = data_ty -- ResTyGADT _ ty <- con_res con = ty | ConDeclGADT{} <- con = hsib_body $ con_type con - | otherwise = foldl' (\x y -> noLoc (HsAppTy PlaceHolder x y)) - (noLoc (HsTyVar PlaceHolder NotPromoted (noLoc t))) tvs + | otherwise = foldl' (\x y -> noLoc (HsAppTy noExt x y)) + (noLoc (HsTyVar noExt 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 c7e4f6f8..fc2d5723 100644 --- a/haddock-api/src/Haddock/Interface/Rename.hs +++ b/haddock-api/src/Haddock/Interface/Rename.hs @@ -21,6 +21,7 @@ import Haddock.Types import Bag (emptyBag) import GHC hiding (NoLink) import Name +import PlaceHolder import Control.Applicative import Control.Monad hiding (mapM) @@ -212,55 +213,55 @@ renameType t = case t of HsForAllTy { hst_bndrs = tyvars, hst_body = ltype } -> do tyvars' <- mapM renameLTyVarBndr tyvars ltype' <- renameLType ltype - return (HsForAllTy { hst_xforall = PlaceHolder, hst_bndrs = tyvars', hst_body = ltype' }) + return (HsForAllTy { hst_xforall = noExt, hst_bndrs = tyvars', hst_body = ltype' }) HsQualTy { hst_ctxt = lcontext , hst_body = ltype } -> do lcontext' <- renameLContext lcontext ltype' <- renameLType ltype - return (HsQualTy { hst_xqual = PlaceHolder, hst_ctxt = lcontext', hst_body = ltype' }) + return (HsQualTy { hst_xqual = noExt, hst_ctxt = lcontext', hst_body = ltype' }) - HsTyVar _ ip (L l n) -> return . HsTyVar PlaceHolder ip . L l =<< rename n - HsBangTy _ b ltype -> return . HsBangTy PlaceHolder b =<< renameLType ltype + HsTyVar _ ip (L l n) -> return . HsTyVar noExt ip . L l =<< rename n + HsBangTy _ b ltype -> return . HsBangTy noExt b =<< renameLType ltype HsAppTy _ a b -> do a' <- renameLType a b' <- renameLType b - return (HsAppTy PlaceHolder a' b') + return (HsAppTy noExt a' b') HsFunTy _ a b -> do a' <- renameLType a b' <- renameLType b - return (HsFunTy PlaceHolder a' b') + return (HsFunTy noExt a' b') - 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) + HsListTy _ ty -> return . (HsListTy noExt) =<< renameLType ty + HsPArrTy _ ty -> return . (HsPArrTy noExt) =<< renameLType ty + HsIParamTy _ n ty -> liftM (HsIParamTy noExt n) (renameLType ty) + HsEqTy _ ty1 ty2 -> liftM2 (HsEqTy noExt) (renameLType ty1) (renameLType ty2) - HsTupleTy _ b ts -> return . HsTupleTy PlaceHolder b =<< mapM renameLType ts - HsSumTy _ ts -> HsSumTy PlaceHolder <$> mapM renameLType ts + HsTupleTy _ b ts -> return . HsTupleTy noExt b =<< mapM renameLType ts + HsSumTy _ ts -> HsSumTy noExt <$> mapM renameLType ts HsOpTy _ a (L loc op) b -> do op' <- rename op a' <- renameLType a b' <- renameLType b - return (HsOpTy PlaceHolder a' (L loc op') b') + return (HsOpTy noExt a' (L loc op') b') - HsParTy _ ty -> return . (HsParTy PlaceHolder) =<< renameLType ty + HsParTy _ ty -> return . (HsParTy noExt) =<< renameLType ty HsKindSig _ ty k -> do ty' <- renameLType ty k' <- renameLKind k - return (HsKindSig PlaceHolder ty' k') + return (HsKindSig noExt ty' k') HsDocTy _ ty doc -> do ty' <- renameLType ty doc' <- renameLDocHsSyn doc - return (HsDocTy PlaceHolder ty' doc') + return (HsDocTy noExt ty' doc') - HsTyLit _ x -> return (HsTyLit PlaceHolder x) + HsTyLit _ x -> return (HsTyLit noExt x) - HsRecTy _ a -> HsRecTy PlaceHolder <$> mapM renameConDeclFieldField a + HsRecTy _ a -> HsRecTy noExt <$> 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 @@ -358,7 +359,7 @@ renameTyClD d = case d of lname' <- renameL lname tyvars' <- renameLHsQTyVars tyvars defn' <- renameDataDefn defn - return (DataDecl { tcdLName = lname', tcdTyVars = tyvars', tcdFixity = fixity, tcdDataDefn = defn', tcdDataCusk = PlaceHolder, tcdFVs = placeHolderNames }) + return (DataDecl { tcdLName = lname', tcdTyVars = tyvars', tcdFixity = fixity, tcdDataDefn = defn', tcdDataCusk = placeHolder, tcdFVs = placeHolderNames }) ClassDecl { tcdCtxt = lcontext, tcdLName = lname, tcdTyVars = ltyvars, tcdFixity = fixity , tcdFDs = lfundeps, tcdSigs = lsigs, tcdATs = ats, tcdATDefs = at_defs } -> do @@ -597,8 +598,8 @@ renameImplicit :: (in_thing -> RnM out_thing) renameImplicit rn_thing (HsIB { hsib_body = thing }) = do { thing' <- rn_thing thing ; return (HsIB { hsib_body = thing' - , hsib_vars = PlaceHolder - , hsib_closed = PlaceHolder }) } + , hsib_vars = placeHolder + , hsib_closed = placeHolder }) } renameWc :: (in_thing -> RnM out_thing) -> HsWildCardBndrs GhcRn in_thing @@ -606,7 +607,7 @@ renameWc :: (in_thing -> RnM out_thing) renameWc rn_thing (HsWC { hswc_body = thing }) = do { thing' <- rn_thing thing ; return (HsWC { hswc_body = thing' - , hswc_wcs = PlaceHolder }) } + , hswc_wcs = placeHolder }) } renameDocInstance :: DocInstance GhcRn -> RnM (DocInstance DocNameI) renameDocInstance (inst, idoc, L l n) = do diff --git a/haddock-api/src/Haddock/Interface/Specialize.hs b/haddock-api/src/Haddock/Interface/Specialize.hs index f0cf08a1..8d9ec58e 100644 --- a/haddock-api/src/Haddock/Interface/Specialize.hs +++ b/haddock-api/src/Haddock/Interface/Specialize.hs @@ -111,7 +111,7 @@ sugar = sugarOperators . sugarTuples . sugarLists sugarLists :: NamedThing (IdP (GhcPass p)) => HsType (GhcPass p) -> HsType (GhcPass p) sugarLists (HsAppTy _ (L _ (HsTyVar _ _ (L _ name))) ltyp) - | isBuiltInSyntax name' && strName == "[]" = HsListTy PlaceHolder ltyp + | isBuiltInSyntax name' && strName == "[]" = HsListTy noExt ltyp where name' = getName name strName = occNameString . nameOccName $ name' @@ -125,7 +125,7 @@ sugarTuples typ = 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 + | isBuiltInSyntax name' && suitable = HsTupleTy noExt HsBoxedTuple apps where name' = getName name strName = occNameString . nameOccName $ name' @@ -138,7 +138,7 @@ sugarTuples typ = 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 PlaceHolder la lb + | isBuiltInSyntax name' && getOccString name == "(->)" = HsFunTy noExt la lb where name' = getName name sugarOperators typ = typ diff --git a/haddock-api/src/Haddock/Types.hs b/haddock-api/src/Haddock/Types.hs index bb8ea9c7..265c939d 100644 --- a/haddock-api/src/Haddock/Types.hs +++ b/haddock-api/src/Haddock/Types.hs @@ -43,6 +43,7 @@ import Coercion import NameSet import OccName import Outputable +import PlaceHolder import Control.Applicative (Applicative(..)) import Control.Monad (ap) @@ -381,11 +382,12 @@ mkPseudoFamilyDecl (FamilyDecl { .. }) = PseudoFamilyDecl , pfdKindSig = fdResultSig } where + mkType :: HsTyVarBndr (GhcPass p) -> HsType (GhcPass p) mkType (KindedTyVar _ (L loc name) lkind) = - HsKindSig PlaceHolder tvar lkind + HsKindSig noExt tvar lkind where - tvar = L loc (HsTyVar PlaceHolder NotPromoted (L loc name)) - mkType (UserTyVar _ name) = HsTyVar PlaceHolder NotPromoted name + tvar = L loc (HsTyVar noExt NotPromoted (L loc name)) + mkType (UserTyVar _ name) = HsTyVar noExt NotPromoted name mkType (XTyVarBndr _ ) = panic "haddock:mkPseudoFamilyDecl" diff --git a/haddock-api/src/Haddock/Utils.hs b/haddock-api/src/Haddock/Utils.hs index 815aad47..3f5f16b1 100644 --- a/haddock-api/src/Haddock/Utils.hs +++ b/haddock-api/src/Haddock/Utils.hs @@ -136,13 +136,13 @@ addClassContext cls tvs0 (L pos (ClassOpSig _ lname ltype)) -- The mkEmptySigWcType is suspicious where go (L loc (HsForAllTy { hst_bndrs = tvs, hst_body = ty })) - = L loc (HsForAllTy { hst_xforall = PlaceHolder + = L loc (HsForAllTy { hst_xforall = noExt , hst_bndrs = tvs, hst_body = go ty }) go (L loc (HsQualTy { hst_ctxt = ctxt, hst_body = ty })) - = L loc (HsQualTy { hst_xqual = PlaceHolder + = L loc (HsQualTy { hst_xqual = noExt , hst_ctxt = add_ctxt ctxt, hst_body = ty }) go (L loc ty) - = L loc (HsQualTy { hst_xqual = PlaceHolder + = L loc (HsQualTy { hst_xqual = noExt , hst_ctxt = add_ctxt (L loc []), hst_body = L loc ty }) extra_pred = nlHsTyConApp cls (lHsQTyVarsToTypes tvs0) @@ -152,7 +152,7 @@ addClassContext _ _ sig = sig -- E.g. a MinimalSig is fine lHsQTyVarsToTypes :: LHsQTyVars GhcRn -> [LHsType GhcRn] lHsQTyVarsToTypes tvs - = [ noLoc (HsTyVar PlaceHolder NotPromoted (noLoc (hsLTyVarName tv))) + = [ noLoc (HsTyVar noExt NotPromoted (noLoc (hsLTyVarName tv))) | tv <- hsQTvExplicit tvs ] -------------------------------------------------------------------------------- -- cgit v1.2.3