From 1e1f85d6513b84bac3ae13470900ac7c23e8640e Mon Sep 17 00:00:00 2001 From: Alan Zimmerman Date: Tue, 23 May 2017 23:16:32 +0200 Subject: Match new AST as per GHC wip/new-tree-one-param See https://ghc.haskell.org/trac/ghc/wiki/ImplementingTreesThatGrow --- haddock-api/src/Haddock/Interface/AttachInstances.hs | 7 ++++--- 1 file changed, 4 insertions(+), 3 deletions(-) (limited to 'haddock-api/src/Haddock/Interface/AttachInstances.hs') diff --git a/haddock-api/src/Haddock/Interface/AttachInstances.hs b/haddock-api/src/Haddock/Interface/AttachInstances.hs index d5d74819..b89a14f4 100644 --- a/haddock-api/src/Haddock/Interface/AttachInstances.hs +++ b/haddock-api/src/Haddock/Interface/AttachInstances.hs @@ -1,4 +1,5 @@ {-# LANGUAGE CPP, MagicHash #-} +{-# LANGUAGE TypeFamilies #-} ----------------------------------------------------------------------------- -- | -- Module : Haddock.Interface.AttachInstances @@ -66,7 +67,7 @@ attachInstances expInfo ifaces instIfaceMap = mapM attach ifaces , ifaceOrphanInstances = orphanInstances } -attachOrphanInstances :: ExportInfo -> Interface -> IfaceMap -> InstIfaceMap -> [ClsInst] -> [DocInstance Name] +attachOrphanInstances :: ExportInfo -> Interface -> IfaceMap -> InstIfaceMap -> [ClsInst] -> [DocInstance GHCR] attachOrphanInstances expInfo iface ifaceMap instIfaceMap cls_instances = [ (synifyInstHead i, instLookup instDocMap n iface ifaceMap instIfaceMap, (L (getSrcSpan n) n)) | let is = [ (instanceSig i, getName i) | i <- cls_instances, isOrphan (is_orphan i) ] @@ -76,8 +77,8 @@ attachOrphanInstances expInfo iface ifaceMap instIfaceMap cls_instances = attachToExportItem :: ExportInfo -> Interface -> IfaceMap -> InstIfaceMap - -> ExportItem Name - -> Ghc (ExportItem Name) + -> ExportItem GHCR + -> Ghc (ExportItem GHCR) attachToExportItem expInfo iface ifaceMap instIfaceMap export = case attachFixities export of e@ExportDecl { expItemDecl = L eSpan (TyClD d) } -> do -- cgit v1.2.3 From a9f774fa3c12f9b8e093e46d58e7872d3d478951 Mon Sep 17 00:00:00 2001 From: Alan Zimmerman Date: Wed, 24 May 2017 17:39:06 +0200 Subject: Rename extension index tags --- haddock-api/src/Haddock/Backends/Hoogle.hs | 22 +++--- .../src/Haddock/Backends/Hyperlinker/Ast.hs | 24 +++---- haddock-api/src/Haddock/Convert.hs | 40 +++++------ haddock-api/src/Haddock/GhcUtils.hs | 14 ++-- haddock-api/src/Haddock/Interface.hs | 2 +- .../src/Haddock/Interface/AttachInstances.hs | 6 +- haddock-api/src/Haddock/Interface/Create.hs | 62 ++++++++--------- haddock-api/src/Haddock/Interface/Rename.hs | 78 +++++++++++----------- haddock-api/src/Haddock/Types.hs | 8 +-- haddock-api/src/Haddock/Utils.hs | 20 +++--- 10 files changed, 138 insertions(+), 138 deletions(-) (limited to 'haddock-api/src/Haddock/Interface/AttachInstances.hs') diff --git a/haddock-api/src/Haddock/Backends/Hoogle.hs b/haddock-api/src/Haddock/Backends/Hoogle.hs index 86e4ca30..02430deb 100644 --- a/haddock-api/src/Haddock/Backends/Hoogle.hs +++ b/haddock-api/src/Haddock/Backends/Hoogle.hs @@ -116,7 +116,7 @@ commaSeparate dflags = showSDocUnqual dflags . interpp'SP --------------------------------------------------------------------- -- How to print each export -ppExport :: DynFlags -> ExportItem GHCR -> [String] +ppExport :: DynFlags -> ExportItem GhcRn -> [String] ppExport dflags ExportDecl { expItemDecl = L _ decl , expItemMbDoc = (dc, _) , expItemSubDocs = subdocs @@ -134,7 +134,7 @@ ppExport dflags ExportDecl { expItemDecl = L _ decl ppFixities = concatMap (ppFixity dflags) fixities ppExport _ _ = [] -ppSigWithDoc :: DynFlags -> Sig GHCR -> [(Name, DocForDecl Name)] -> [String] +ppSigWithDoc :: DynFlags -> Sig GhcRn -> [(Name, DocForDecl Name)] -> [String] ppSigWithDoc dflags (TypeSig names sig) subdocs = concatMap mkDocSig names where @@ -146,17 +146,17 @@ ppSigWithDoc dflags (TypeSig names sig) subdocs ppSigWithDoc _ _ _ = [] -ppSig :: DynFlags -> Sig GHCR -> [String] +ppSig :: DynFlags -> Sig GhcRn -> [String] ppSig dflags x = ppSigWithDoc dflags x [] -pp_sig :: DynFlags -> [Located Name] -> LHsType GHCR -> String +pp_sig :: DynFlags -> [Located Name] -> LHsType GhcRn -> String pp_sig dflags names (L _ typ) = operator prettyNames ++ " :: " ++ outHsType dflags typ where prettyNames = intercalate ", " $ map (out dflags) names -- note: does not yet output documentation for class methods -ppClass :: DynFlags -> TyClDecl GHCR -> [(Name, DocForDecl Name)] -> [String] +ppClass :: DynFlags -> TyClDecl GhcRn -> [(Name, DocForDecl Name)] -> [String] ppClass dflags decl subdocs = (out dflags decl{tcdSigs=[]} ++ ppTyFams) : ppMethods where @@ -178,7 +178,7 @@ ppClass dflags decl subdocs = (out dflags decl{tcdSigs=[]} ++ ppTyFams) : ppMet , rbrace ] - tyFamEqnToSyn :: TyFamDefltEqn GHCR -> TyClDecl GHCR + tyFamEqnToSyn :: TyFamDefltEqn GhcRn -> TyClDecl GhcRn tyFamEqnToSyn tfe = SynDecl { tcdLName = tfe_tycon tfe , tcdTyVars = tfe_pats tfe @@ -200,10 +200,10 @@ ppInstance dflags x = cls = x { is_flag = OverlapFlag { overlapMode = NoOverlap NoSourceText , isSafeOverlap = False } } -ppSynonym :: DynFlags -> TyClDecl GHCR -> [String] +ppSynonym :: DynFlags -> TyClDecl GhcRn -> [String] ppSynonym dflags x = [out dflags x] -ppData :: DynFlags -> TyClDecl GHCR -> [(Name, DocForDecl Name)] -> [String] +ppData :: DynFlags -> TyClDecl GhcRn -> [(Name, DocForDecl Name)] -> [String] ppData dflags decl@(DataDecl { tcdDataDefn = defn }) subdocs = showData decl{ tcdDataDefn = defn { dd_cons=[],dd_derivs=noLoc [] }} : concatMap (ppCtor dflags decl subdocs . unL) (dd_cons defn) @@ -224,7 +224,7 @@ lookupCon dflags subdocs (L _ name) = case lookup name subdocs of Just (d, _) -> ppDocumentation dflags d _ -> [] -ppCtor :: DynFlags -> TyClDecl GHCR -> [(Name, DocForDecl Name)] -> ConDecl GHCR -> [String] +ppCtor :: DynFlags -> TyClDecl GhcRn -> [(Name, DocForDecl Name)] -> ConDecl GhcRn -> [String] ppCtor dflags dat subdocs con@ConDeclH98 {} -- AZ:TODO get rid of the concatMap = concatMap (lookupCon dflags subdocs) [con_name con] ++ f (getConDetails con) @@ -257,8 +257,8 @@ ppCtor dflags _dat subdocs con@ConDeclGADT {} name = out dflags $ map unL $ getConNames con -ppFixity :: DynFlags -> (IdP GHCR, Fixity) -> [String] -ppFixity dflags (name, fixity) = [out dflags ((FixitySig [noLoc name] fixity) :: FixitySig GHCR)] +ppFixity :: DynFlags -> (Name, Fixity) -> [String] +ppFixity dflags (name, fixity) = [out dflags ((FixitySig [noLoc name] fixity) :: FixitySig GhcRn)] --------------------------------------------------------------------- diff --git a/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs b/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs index abdcafcc..1b39e5e8 100644 --- a/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs +++ b/haddock-api/src/Haddock/Backends/Hyperlinker/Ast.hs @@ -56,13 +56,13 @@ variables = everything (<|>) (var `combine` rec) where var term = case cast term of - (Just ((GHC.L sspan (GHC.HsVar name)) :: GHC.LHsExpr GHC.GHCR)) -> + (Just ((GHC.L sspan (GHC.HsVar name)) :: GHC.LHsExpr GHC.GhcRn)) -> pure (sspan, RtkVar (GHC.unLoc name)) (Just (GHC.L _ (GHC.RecordCon (GHC.L sspan name) _ _ _))) -> pure (sspan, RtkVar name) _ -> empty rec term = case cast term of - Just (GHC.HsRecField (GHC.L sspan name) (_ :: GHC.LHsExpr GHC.GHCR) _) -> + Just (GHC.HsRecField (GHC.L sspan name) (_ :: GHC.LHsExpr GHC.GhcRn) _) -> pure (sspan, RtkVar name) _ -> empty @@ -72,7 +72,7 @@ types = everything (<|>) ty where ty term = case cast term of - (Just ((GHC.L sspan (GHC.HsTyVar _ name)) :: GHC.LHsType GHC.GHCR)) -> + (Just ((GHC.L sspan (GHC.HsTyVar _ name)) :: GHC.LHsType GHC.GhcRn)) -> pure (sspan, RtkType (GHC.unLoc name)) _ -> empty @@ -86,11 +86,11 @@ binds = everything (<|>) (fun `combine` pat `combine` tvar) where fun term = case cast term of - (Just (GHC.FunBind (GHC.L sspan name) _ _ _ _ :: GHC.HsBind GHC.GHCR)) -> + (Just (GHC.FunBind (GHC.L sspan name) _ _ _ _ :: GHC.HsBind GHC.GhcRn)) -> pure (sspan, RtkBind name) _ -> empty pat term = case cast term of - (Just ((GHC.L sspan (GHC.VarPat name)) :: GHC.LPat GHC.GHCR)) -> + (Just ((GHC.L sspan (GHC.VarPat name)) :: GHC.LPat GHC.GhcRn)) -> pure (sspan, RtkBind (GHC.unLoc name)) (Just (GHC.L _ (GHC.ConPatIn (GHC.L sspan name) recs))) -> [(sspan, RtkVar name)] ++ everything (<|>) rec recs @@ -98,11 +98,11 @@ binds = pure (sspan, RtkBind name) _ -> empty rec term = case cast term of - (Just (GHC.HsRecField (GHC.L sspan name) (_ :: GHC.LPat GHC.GHCR) _)) -> + (Just (GHC.HsRecField (GHC.L sspan name) (_ :: GHC.LPat GHC.GhcRn) _)) -> pure (sspan, RtkVar name) _ -> empty tvar term = case cast term of - (Just ((GHC.L sspan (GHC.UserTyVar name)) :: GHC.LHsTyVarBndr GHC.GHCR)) -> + (Just ((GHC.L sspan (GHC.UserTyVar name)) :: GHC.LHsTyVarBndr GHC.GhcRn)) -> pure (sspan, RtkBind (GHC.unLoc name)) (Just (GHC.L _ (GHC.KindedTyVar (GHC.L sspan name) _))) -> pure (sspan, RtkBind name) @@ -122,21 +122,21 @@ decls (group, _, _, _) = concatMap ($ group) GHC.FamDecl fam -> pure . decl $ GHC.fdLName fam GHC.ClassDecl{..} -> [decl tcdLName] ++ concatMap sig tcdSigs fun term = case cast term of - (Just (GHC.FunBind (GHC.L sspan name) _ _ _ _ :: GHC.HsBind GHC.GHCR)) + (Just (GHC.FunBind (GHC.L sspan name) _ _ _ _ :: GHC.HsBind GHC.GhcRn)) | GHC.isExternalName name -> pure (sspan, RtkDecl name) _ -> empty con term = case cast term of - (Just (cdcl :: GHC.ConDecl GHC.GHCR)) -> + (Just (cdcl :: GHC.ConDecl GHC.GhcRn)) -> map decl (GHC.getConNames cdcl) ++ everything (<|>) fld cdcl Nothing -> empty ins term = case cast term of - (Just ((GHC.DataFamInstD inst) :: GHC.InstDecl GHC.GHCR)) + (Just ((GHC.DataFamInstD inst) :: GHC.InstDecl GHC.GhcRn)) -> pure . tyref $ GHC.dfid_tycon inst (Just (GHC.TyFamInstD (GHC.TyFamInstDecl (GHC.L _ eqn) _))) -> pure . tyref $ GHC.tfe_tycon eqn _ -> empty fld term = case cast term of - Just (field :: GHC.ConDeclField GHC.GHCR) + Just (field :: GHC.ConDeclField GHC.GhcRn) -> map (decl . fmap GHC.selectorFieldOcc) $ GHC.cd_fld_names field Nothing -> empty sig (GHC.L _ (GHC.TypeSig names _)) = map decl names @@ -153,7 +153,7 @@ imports src@(_, imps, _, _) = everything (<|>) ie src ++ mapMaybe (imp . GHC.unLoc) imps where ie term = case cast term of - (Just ((GHC.IEVar v) :: GHC.IE GHC.GHCR)) -> pure $ var $ GHC.ieLWrappedName v + (Just ((GHC.IEVar v) :: GHC.IE GHC.GhcRn)) -> pure $ var $ GHC.ieLWrappedName v (Just (GHC.IEThingAbs t)) -> pure $ typ $ GHC.ieLWrappedName t (Just (GHC.IEThingAll t)) -> pure $ typ $ GHC.ieLWrappedName t (Just (GHC.IEThingWith t _ vs _fls)) -> diff --git a/haddock-api/src/Haddock/Convert.hs b/haddock-api/src/Haddock/Convert.hs index 03134695..19ed74ef 100644 --- a/haddock-api/src/Haddock/Convert.hs +++ b/haddock-api/src/Haddock/Convert.hs @@ -49,7 +49,7 @@ import Haddock.Interface.Specialize -- the main function here! yay! -tyThingToLHsDecl :: TyThing -> Either ErrMsg ([ErrMsg], (HsDecl GHCR)) +tyThingToLHsDecl :: TyThing -> Either ErrMsg ([ErrMsg], (HsDecl GhcRn)) tyThingToLHsDecl t = case t of -- ids (functions and zero-argument a.k.a. CAFs) get a type signature. -- Including built-in functions like seq. @@ -108,7 +108,7 @@ tyThingToLHsDecl t = case t of withErrs e x = return (e, x) allOK x = return (mempty, x) -synifyAxBranch :: TyCon -> CoAxBranch -> TyFamInstEqn GHCR +synifyAxBranch :: TyCon -> CoAxBranch -> TyFamInstEqn GhcRn synifyAxBranch tc (CoAxBranch { cab_tvs = tkvs, cab_lhs = args, cab_rhs = rhs }) = let name = synifyName tc typats = map (synifyType WithinType) args @@ -120,7 +120,7 @@ synifyAxBranch tc (CoAxBranch { cab_tvs = tkvs, cab_lhs = args, cab_rhs = rhs }) , tfe_fixity = Prefix , tfe_rhs = hs_rhs } -synifyAxiom :: CoAxiom br -> Either ErrMsg (HsDecl GHCR) +synifyAxiom :: CoAxiom br -> Either ErrMsg (HsDecl GhcRn) synifyAxiom ax@(CoAxiom { co_ax_tc = tc }) | isOpenTypeFamilyTyCon tc , Just branch <- coAxiomSingleBranch_maybe ax @@ -136,7 +136,7 @@ synifyAxiom ax@(CoAxiom { co_ax_tc = tc }) = Left "synifyAxiom: closed/open family confusion" -- | Turn type constructors into type class declarations -synifyTyCon :: Maybe (CoAxiom br) -> TyCon -> Either ErrMsg (TyClDecl GHCR) +synifyTyCon :: Maybe (CoAxiom br) -> TyCon -> Either ErrMsg (TyClDecl GhcRn) synifyTyCon _coax tc | isFunTyCon tc || isPrimTyCon tc = return $ @@ -247,14 +247,14 @@ synifyTyCon coax tc dataConErrs -> Left $ unlines dataConErrs synifyInjectivityAnn :: Maybe Name -> [TyVar] -> Injectivity - -> Maybe (LInjectivityAnn GHCR) + -> Maybe (LInjectivityAnn GhcRn) synifyInjectivityAnn Nothing _ _ = Nothing synifyInjectivityAnn _ _ NotInjective = Nothing synifyInjectivityAnn (Just lhs) tvs (Injective inj) = let rhs = map (noLoc . tyVarName) (filterByList inj tvs) in Just $ noLoc $ InjectivityAnn (noLoc lhs) rhs -synifyFamilyResultSig :: Maybe Name -> Kind -> LFamilyResultSig GHCR +synifyFamilyResultSig :: Maybe Name -> Kind -> LFamilyResultSig GhcRn synifyFamilyResultSig Nothing kind = noLoc $ KindSig (synifyKindSig kind) synifyFamilyResultSig (Just name) kind = @@ -265,7 +265,7 @@ synifyFamilyResultSig (Just name) kind = -- result-type. -- But you might want pass False in simple enough cases, -- if you think it looks better. -synifyDataCon :: Bool -> DataCon -> Either ErrMsg (LConDecl GHCR) +synifyDataCon :: Bool -> DataCon -> Either ErrMsg (LConDecl GhcRn) synifyDataCon use_gadt_syntax dc = let -- dataConIsInfix allegedly tells us whether it was declared with @@ -322,22 +322,22 @@ synifyName :: NamedThing n => n -> Located Name synifyName = noLoc . getName -synifyIdSig :: SynifyTypeState -> Id -> Sig GHCR +synifyIdSig :: SynifyTypeState -> Id -> Sig GhcRn synifyIdSig s i = TypeSig [synifyName i] (synifySigWcType s (varType i)) -synifyTcIdSig :: SynifyTypeState -> Id -> Sig GHCR +synifyTcIdSig :: SynifyTypeState -> Id -> Sig GhcRn synifyTcIdSig s i = ClassOpSig False [synifyName i] (synifySigType s (varType i)) -synifyCtx :: [PredType] -> LHsContext GHCR +synifyCtx :: [PredType] -> LHsContext GhcRn synifyCtx = noLoc . map (synifyType WithinType) -synifyTyVars :: [TyVar] -> LHsQTyVars GHCR +synifyTyVars :: [TyVar] -> LHsQTyVars GhcRn synifyTyVars ktvs = HsQTvs { hsq_implicit = [] , hsq_explicit = map synifyTyVar ktvs , hsq_dependent = emptyNameSet } -synifyTyVar :: TyVar -> LHsTyVarBndr GHCR +synifyTyVar :: TyVar -> LHsTyVarBndr GhcRn synifyTyVar tv | isLiftedTypeKind kind = noLoc (UserTyVar (noLoc name)) | otherwise = noLoc (KindedTyVar (noLoc name) (synifyKindSig kind)) @@ -361,20 +361,20 @@ data SynifyTypeState -- the defining class gets to quantify all its functions for free! -synifySigType :: SynifyTypeState -> Type -> LHsSigType GHCR +synifySigType :: SynifyTypeState -> Type -> LHsSigType GhcRn -- The empty binders is a bit suspicious; -- what if the type has free variables? synifySigType s ty = mkEmptyImplicitBndrs (synifyType s ty) -synifySigWcType :: SynifyTypeState -> Type -> LHsSigWcType GHCR +synifySigWcType :: SynifyTypeState -> Type -> LHsSigWcType GhcRn -- Ditto (see synifySigType) synifySigWcType s ty = mkEmptyWildCardBndrs (mkEmptyImplicitBndrs (synifyType s ty)) -synifyPatSynSigType :: PatSyn -> LHsSigType GHCR +synifyPatSynSigType :: PatSyn -> LHsSigType GhcRn -- Ditto (see synifySigType) synifyPatSynSigType ps = mkEmptyImplicitBndrs (synifyPatSynType ps) -synifyType :: SynifyTypeState -> Type -> LHsType GHCR +synifyType :: SynifyTypeState -> Type -> LHsType GhcRn synifyType _ (TyVarTy tv) = noLoc $ HsTyVar NotPromoted $ noLoc (getName tv) synifyType _ (TyConApp tc tys) -- Use */# instead of TYPE 'Lifted/TYPE 'Unlifted (#473) @@ -431,7 +431,7 @@ synifyType _ (LitTy t) = noLoc $ HsTyLit $ synifyTyLit t synifyType s (CastTy t _) = synifyType s t synifyType _ (CoercionTy {}) = error "synifyType:Coercion" -synifyPatSynType :: PatSyn -> LHsType GHCR +synifyPatSynType :: PatSyn -> LHsType GhcRn synifyPatSynType ps = let (univ_tvs, req_theta, ex_tvs, prov_theta, arg_tys, res_ty) = patSynSig ps req_theta' | null req_theta && not (null prov_theta && null ex_tvs) = [unitTy] @@ -451,10 +451,10 @@ synifyTyLit :: TyLit -> HsTyLit synifyTyLit (NumTyLit n) = HsNumTy NoSourceText n synifyTyLit (StrTyLit s) = HsStrTy NoSourceText s -synifyKindSig :: Kind -> LHsKind GHCR +synifyKindSig :: Kind -> LHsKind GhcRn synifyKindSig k = synifyType WithinType k -synifyInstHead :: ([TyVar], [PredType], Class, [Type]) -> InstHead GHCR +synifyInstHead :: ([TyVar], [PredType], Class, [Type]) -> InstHead GhcRn synifyInstHead (_, preds, cls, types) = specializeInstHead $ InstHead { ihdClsName = getName cls , ihdKinds = map (unLoc . synifyType WithinType) ks @@ -473,7 +473,7 @@ synifyInstHead (_, preds, cls, types) = specializeInstHead $ InstHead synifyClsIdSig = synifyIdSig DeleteTopLevelQuantification -- Convert a family instance, this could be a type family or data family -synifyFamInst :: FamInst -> Bool -> Either ErrMsg (InstHead GHCR) +synifyFamInst :: FamInst -> Bool -> Either ErrMsg (InstHead GhcRn) synifyFamInst fi opaque = do ityp' <- ityp $ fi_flavor fi return InstHead diff --git a/haddock-api/src/Haddock/GhcUtils.hs b/haddock-api/src/Haddock/GhcUtils.hs index 16c589f0..83e4dbd8 100644 --- a/haddock-api/src/Haddock/GhcUtils.hs +++ b/haddock-api/src/Haddock/GhcUtils.hs @@ -151,7 +151,7 @@ reL = L undefined ------------------------------------------------------------------------------- -instance NamedThing (TyClDecl GHCR) where +instance NamedThing (TyClDecl GhcRn) where getName = tcdName ------------------------------------------------------------------------------- @@ -163,14 +163,14 @@ class Parent a where children :: a -> [Name] -instance Parent (ConDecl GHCR) where +instance Parent (ConDecl GhcRn) where children con = case getConDetails con of RecCon fields -> map (selectorFieldOcc . unL) $ concatMap (cd_fld_names . unL) (unL fields) _ -> [] -instance Parent (TyClDecl GHCR) where +instance Parent (TyClDecl GhcRn) where children d | isDataDecl d = map unL $ concatMap (getConNames . unL) $ (dd_cons . tcdDataDefn) $ d @@ -185,12 +185,12 @@ family :: (NamedThing a, Parent a) => a -> (Name, [Name]) family = getName &&& children -familyConDecl :: ConDecl GHC.GHCR -> [(IdP GHCR, [IdP GHCR])] +familyConDecl :: ConDecl GHC.GhcRn -> [(Name, [Name])] familyConDecl d = zip (map unL (getConNames d)) (repeat $ children d) -- | A mapping from the parent (main-binder) to its children and from each -- child to its grand-children, recursively. -families :: TyClDecl GHCR -> [(IdP GHCR, [IdP GHCR])] +families :: TyClDecl GhcRn -> [(Name, [Name])] families d | isDataDecl d = family d : concatMap (familyConDecl . unL) (dd_cons (tcdDataDefn d)) | isClassDecl d = [family d] @@ -198,12 +198,12 @@ families d -- | A mapping from child to parent -parentMap :: TyClDecl GHCR -> [(IdP GHCR, IdP GHCR)] +parentMap :: TyClDecl GhcRn -> [(Name, Name)] parentMap d = [ (c, p) | (p, cs) <- families d, c <- cs ] -- | The parents of a subordinate in a declaration -parents :: IdP GHCR -> HsDecl GHCR -> [IdP GHCR] +parents :: Name -> HsDecl GhcRn -> [Name] parents n (TyClD d) = [ p | (c, p) <- parentMap d, c == n ] parents _ _ = [] diff --git a/haddock-api/src/Haddock/Interface.hs b/haddock-api/src/Haddock/Interface.hs index f920d75e..31991e25 100644 --- a/haddock-api/src/Haddock/Interface.hs +++ b/haddock-api/src/Haddock/Interface.hs @@ -167,7 +167,7 @@ processModule verbosity modsum flags modMap instIfaceMap = do , expItemMbDoc = (Documentation Nothing _, _) } <- ifaceExportItems interface ] where - formatName :: SrcSpan -> HsDecl GHCR -> String + formatName :: SrcSpan -> HsDecl GhcRn -> String formatName loc n = p (getMainDeclBinder n) ++ case loc of RealSrcSpan rss -> " (" ++ unpackFS (srcSpanFile rss) ++ ":" ++ show (srcSpanStartLine rss) ++ ")" _ -> "" diff --git a/haddock-api/src/Haddock/Interface/AttachInstances.hs b/haddock-api/src/Haddock/Interface/AttachInstances.hs index b89a14f4..6d0bed2a 100644 --- a/haddock-api/src/Haddock/Interface/AttachInstances.hs +++ b/haddock-api/src/Haddock/Interface/AttachInstances.hs @@ -67,7 +67,7 @@ attachInstances expInfo ifaces instIfaceMap = mapM attach ifaces , ifaceOrphanInstances = orphanInstances } -attachOrphanInstances :: ExportInfo -> Interface -> IfaceMap -> InstIfaceMap -> [ClsInst] -> [DocInstance GHCR] +attachOrphanInstances :: ExportInfo -> Interface -> IfaceMap -> InstIfaceMap -> [ClsInst] -> [DocInstance GhcRn] attachOrphanInstances expInfo iface ifaceMap instIfaceMap cls_instances = [ (synifyInstHead i, instLookup instDocMap n iface ifaceMap instIfaceMap, (L (getSrcSpan n) n)) | let is = [ (instanceSig i, getName i) | i <- cls_instances, isOrphan (is_orphan i) ] @@ -77,8 +77,8 @@ attachOrphanInstances expInfo iface ifaceMap instIfaceMap cls_instances = attachToExportItem :: ExportInfo -> Interface -> IfaceMap -> InstIfaceMap - -> ExportItem GHCR - -> Ghc (ExportItem GHCR) + -> ExportItem GhcRn + -> Ghc (ExportItem GhcRn) attachToExportItem expInfo iface ifaceMap instIfaceMap export = case attachFixities export of e@ExportDecl { expItemDecl = L eSpan (TyClD d) } -> do diff --git a/haddock-api/src/Haddock/Interface/Create.hs b/haddock-api/src/Haddock/Interface/Create.hs index 800c58ef..2b352d90 100644 --- a/haddock-api/src/Haddock/Interface/Create.hs +++ b/haddock-api/src/Haddock/Interface/Create.hs @@ -289,7 +289,7 @@ type Maps = (DocMap Name, ArgMap Name, SubMap, DeclMap, InstMap) mkMaps :: DynFlags -> GlobalRdrEnv -> [Name] - -> [(LHsDecl GHCR, [HsDocString])] + -> [(LHsDecl GhcRn, [HsDocString])] -> Maps mkMaps dflags gre instances decls = let (a, b, c, d) = unzip4 $ map mappings decls @@ -301,11 +301,11 @@ mkMaps dflags gre instances decls = f' :: [[(Name, MDoc Name)]] -> Map Name (MDoc Name) f' = M.fromListWith metaDocAppend . concat - mappings :: (LHsDecl GHCR, [HsDocString]) + mappings :: (LHsDecl GhcRn, [HsDocString]) -> ( [(Name, MDoc Name)] , [(Name, Map Int (MDoc Name))] , [(Name, [Name])] - , [(Name, [LHsDecl GHCR])] + , [(Name, [LHsDecl GhcRn])] ) mappings (ldecl, docStrs) = let L l decl = ldecl @@ -335,7 +335,7 @@ mkMaps dflags gre instances decls = instanceMap :: Map SrcSpan Name instanceMap = M.fromList [ (getSrcSpan n, n) | n <- instances ] - names :: SrcSpan -> HsDecl GHCR -> [Name] + names :: SrcSpan -> HsDecl GhcRn -> [Name] names l (InstD d) = maybeToList (M.lookup loc instanceMap) -- See note [2]. where loc = case d of TyFamInstD _ -> l -- The CoAx's loc is the whole line, but only for TFs @@ -359,7 +359,7 @@ mkMaps dflags gre instances decls = -- | Get all subordinate declarations inside a declaration, and their docs. -- A subordinate declaration is something like the associate type or data -- family of a type class. -subordinates :: InstMap -> HsDecl GHCR -> [(Name, [HsDocString], Map Int HsDocString)] +subordinates :: InstMap -> HsDecl GhcRn -> [(Name, [HsDocString], Map Int HsDocString)] subordinates instMap decl = case decl of InstD (ClsInstD d) -> do DataFamInstDecl { dfid_tycon = L l _ @@ -374,7 +374,7 @@ subordinates instMap decl = case decl of classSubs dd = [ (name, doc, typeDocs d) | (L _ d, doc) <- classDecls dd , name <- getMainDeclBinder d, not (isValD d) ] - dataSubs :: HsDataDefn GHCR -> [(Name, [HsDocString], Map Int HsDocString)] + dataSubs :: HsDataDefn GhcRn -> [(Name, [HsDocString], Map Int HsDocString)] dataSubs dd = constrs ++ fields ++ derivs where cons = map unL $ (dd_cons dd) @@ -391,7 +391,7 @@ subordinates instMap decl = case decl of , Just instName <- [M.lookup l instMap] ] -- | Extract function argument docs from inside types. -typeDocs :: HsDecl GHCR -> Map Int HsDocString +typeDocs :: HsDecl GhcRn -> Map Int HsDocString typeDocs d = let docs = go 0 in case d of @@ -411,7 +411,7 @@ typeDocs d = -- | All the sub declarations of a class (that we handle), ordered by -- source location, with documentation attached if it exists. -classDecls :: TyClDecl GHCR -> [(LHsDecl GHCR, [HsDocString])] +classDecls :: TyClDecl GhcRn -> [(LHsDecl GhcRn, [HsDocString])] classDecls class_ = filterDecls . collectDocs . sortByLoc $ decls where decls = docs ++ defs ++ sigs ++ ats @@ -423,18 +423,18 @@ classDecls class_ = filterDecls . collectDocs . sortByLoc $ decls -- | The top-level declarations of a module that we care about, -- ordered by source location, with documentation attached if it exists. -topDecls :: HsGroup GHCR -> [(LHsDecl GHCR, [HsDocString])] +topDecls :: HsGroup GhcRn -> [(LHsDecl GhcRn, [HsDocString])] topDecls = filterClasses . filterDecls . collectDocs . sortByLoc . ungroup -- | Extract a map of fixity declarations only -mkFixMap :: HsGroup GHCR -> FixMap +mkFixMap :: HsGroup GhcRn -> FixMap mkFixMap group_ = M.fromList [ (n,f) | L _ (FixitySig ns f) <- hs_fixds group_, L _ n <- ns ] -- | Take all declarations except pragmas, infix decls, rules from an 'HsGroup'. -ungroup :: HsGroup GHCR -> [LHsDecl GHCR] +ungroup :: HsGroup GhcRn -> [LHsDecl GhcRn] ungroup group_ = mkDecls (tyClGroupTyClDecls . hs_tyclds) TyClD group_ ++ mkDecls hs_derivds DerivD group_ ++ @@ -534,14 +534,14 @@ mkExportItems -> WarningMap -> GlobalRdrEnv -> [Name] -- exported names (orig) - -> [LHsDecl GHCR] -- renamed source declarations + -> [LHsDecl GhcRn] -- renamed source declarations -> Maps -> FixMap -> [SrcSpan] -- splice locations - -> Maybe [IE GHCR] + -> Maybe [IE GhcRn] -> InstIfaceMap -> DynFlags - -> ErrMsgGhc [ExportItem GHCR] + -> ErrMsgGhc [ExportItem GhcRn] mkExportItems is_sig modMap thisMod semMod warnings gre exportedNames decls maps@(docMap, argMap, subMap, declMap, instMap) fixMap splices optExports instIfaceMap dflags = @@ -571,7 +571,7 @@ mkExportItems Nothing -> [] Just doc -> return . ExportDoc $ processDocStringParas dflags gre doc - declWith :: Name -> ErrMsgGhc [ ExportItem GHCR ] + declWith :: Name -> ErrMsgGhc [ ExportItem GhcRn ] declWith t = do r <- findDecl t case r of @@ -641,7 +641,7 @@ mkExportItems _ -> return [] - mkExportDecl :: Name -> LHsDecl GHCR -> (DocForDecl Name, [(Name, DocForDecl Name)]) -> ExportItem GHCR + mkExportDecl :: Name -> LHsDecl GhcRn -> (DocForDecl Name, [(Name, DocForDecl Name)]) -> ExportItem GhcRn mkExportDecl name decl (doc, subs) = decl' where decl' = ExportDecl (restrictTo sub_names (extractDecl name decl)) doc subs' [] fixities False @@ -653,7 +653,7 @@ mkExportItems isExported = (`elem` exportedNames) - findDecl :: Name -> ErrMsgGhc ([LHsDecl GHCR], (DocForDecl Name, [(Name, DocForDecl Name)])) + findDecl :: Name -> ErrMsgGhc ([LHsDecl GhcRn], (DocForDecl Name, [(Name, DocForDecl Name)])) findDecl n | m == semMod = case M.lookup n declMap of @@ -689,7 +689,7 @@ semToIdMod this_uid m | Module.isHoleModule m = mkModule this_uid (moduleName m) | otherwise = m -hiDecl :: DynFlags -> Name -> ErrMsgGhc (Maybe (LHsDecl GHCR)) +hiDecl :: DynFlags -> Name -> ErrMsgGhc (Maybe (LHsDecl GhcRn)) hiDecl dflags t = do mayTyThing <- liftGhcToErrMsgGhc $ lookupName t case mayTyThing of @@ -711,7 +711,7 @@ hiDecl dflags t = do -- have a meaningful 'SrcSpan'. So we pass down 'SrcSpan' for the -- declaration and use it instead - 'nLoc' here. hiValExportItem :: DynFlags -> Name -> SrcSpan -> DocForDecl Name -> Bool - -> Maybe Fixity -> ErrMsgGhc (ExportItem GHCR) + -> Maybe Fixity -> ErrMsgGhc (ExportItem GhcRn) hiValExportItem dflags name nLoc doc splice fixity = do mayDecl <- hiDecl dflags name case mayDecl of @@ -756,13 +756,13 @@ moduleExports :: Module -- ^ Module A (identity, NOT semantic) -> WarningMap -> GlobalRdrEnv -- ^ The renaming environment used for A -> [Name] -- ^ All the exports of A - -> [LHsDecl GHCR] -- ^ All the renamed declarations in A + -> [LHsDecl GhcRn] -- ^ All the renamed declarations in A -> IfaceMap -- ^ Already created interfaces -> InstIfaceMap -- ^ Interfaces in other packages -> Maps -> FixMap -> [SrcSpan] -- ^ Locations of all TH splices - -> ErrMsgGhc [ExportItem GHCR] -- ^ Resulting export items + -> ErrMsgGhc [ExportItem GhcRn] -- ^ Resulting export items moduleExports thisMod expMod dflags warnings gre _exports decls ifaceMap instIfaceMap maps fixMap splices | expMod == moduleName thisMod = fullModuleContents dflags warnings gre maps fixMap splices decls @@ -814,8 +814,8 @@ fullModuleContents :: DynFlags -> Maps -> FixMap -> [SrcSpan] -- ^ Locations of all TH splices - -> [LHsDecl GHCR] -- ^ All the renamed declarations - -> ErrMsgGhc [ExportItem GHCR] + -> [LHsDecl GhcRn] -- ^ All the renamed declarations + -> ErrMsgGhc [ExportItem GhcRn] fullModuleContents dflags warnings gre (docMap, argMap, subMap, declMap, instMap) fixMap splices decls = liftM catMaybes $ mapM mkExportItem (expandSig decls) where @@ -832,7 +832,7 @@ fullModuleContents dflags warnings gre (docMap, argMap, subMap, declMap, instMap f (L l (SigD (ClassOpSig b names t))) xs = foldr (\n acc -> L l (SigD (ClassOpSig b [n] t)) : acc) xs names f x xs = x : xs - mkExportItem :: LHsDecl GHCR -> ErrMsgGhc (Maybe (ExportItem GHCR)) + mkExportItem :: LHsDecl GhcRn -> ErrMsgGhc (Maybe (ExportItem GhcRn)) mkExportItem (L _ (DocD (DocGroup lev docStr))) = do return . Just . ExportGroup lev "" $ processDocString dflags gre docStr mkExportItem (L _ (DocD (DocCommentNamed _ docStr))) = do @@ -872,7 +872,7 @@ fullModuleContents dflags warnings gre (docMap, argMap, subMap, declMap, instMap -- it might be an individual record selector or a class method. In these -- cases we have to extract the required declaration (and somehow cobble -- together a type signature for it...). -extractDecl :: Name -> LHsDecl GHCR -> LHsDecl GHCR +extractDecl :: Name -> LHsDecl GhcRn -> LHsDecl GhcRn extractDecl name decl | name `elem` getMainDeclBinder (unLoc decl) = decl | otherwise = @@ -913,8 +913,8 @@ extractDecl name decl _ -> error "internal: extractDecl (ClsInstD)" _ -> error "internal: extractDecl" -extractRecSel :: Name -> Name -> [LHsType GHCR] -> [LConDecl GHCR] - -> LSig GHCR +extractRecSel :: Name -> Name -> [LHsType GhcRn] -> [LConDecl GhcRn] + -> LSig GhcRn extractRecSel _ _ _ [] = error "extractRecSel: selector not found" extractRecSel nm t tvs (L _ con : rest) = @@ -923,7 +923,7 @@ extractRecSel nm t tvs (L _ con : rest) = L l (TypeSig [noLoc nm] (mkEmptySigWcType (noLoc (HsFunTy data_ty (getBangType ty))))) _ -> extractRecSel nm t tvs rest where - matching_fields :: [LConDeclField GHCR] -> [(SrcSpan, LConDeclField GHCR)] + matching_fields :: [LConDeclField GhcRn] -> [(SrcSpan, LConDeclField GhcRn)] matching_fields flds = [ (l,f) | f@(L _ (ConDeclField ns _ _)) <- flds , L l n <- ns, selectorFieldOcc n == nm ] data_ty @@ -932,14 +932,14 @@ extractRecSel nm t tvs (L _ con : rest) = | otherwise = foldl' (\x y -> noLoc (HsAppTy x y)) (noLoc (HsTyVar NotPromoted (noLoc t))) tvs -- | Keep export items with docs. -pruneExportItems :: [ExportItem GHCR] -> [ExportItem GHCR] +pruneExportItems :: [ExportItem GhcRn] -> [ExportItem GhcRn] pruneExportItems = filter hasDoc where hasDoc (ExportDecl{expItemMbDoc = (Documentation d _, _)}) = isJust d hasDoc _ = True -mkVisibleNames :: Maps -> [ExportItem GHCR] -> [DocOption] -> [Name] +mkVisibleNames :: Maps -> [ExportItem GhcRn] -> [DocOption] -> [Name] mkVisibleNames (_, _, _, _, instMap) exports opts | OptHide `elem` opts = [] | otherwise = let ns = concatMap exportName exports @@ -983,7 +983,7 @@ mkTokenizedSrc ms src = rawSrc = readFile $ msHsFilePath ms -- | Find a stand-alone documentation comment by its name. -findNamedDoc :: String -> [HsDecl GHCR] -> ErrMsgM (Maybe HsDocString) +findNamedDoc :: String -> [HsDecl GhcRn] -> ErrMsgM (Maybe HsDocString) findNamedDoc name = search where search [] = do diff --git a/haddock-api/src/Haddock/Interface/Rename.hs b/haddock-api/src/Haddock/Interface/Rename.hs index 2c51cf40..70846b31 100644 --- a/haddock-api/src/Haddock/Interface/Rename.hs +++ b/haddock-api/src/Haddock/Interface/Rename.hs @@ -147,7 +147,7 @@ renameL :: Located Name -> RnM (Located DocName) renameL = mapM rename -renameExportItems :: [ExportItem GHCR] -> RnM [ExportItem DocNameI] +renameExportItems :: [ExportItem GhcRn] -> RnM [ExportItem DocNameI] renameExportItems = mapM renameExportItem @@ -172,22 +172,22 @@ renameFnArgsDoc :: FnArgsDoc Name -> RnM (FnArgsDoc DocName) renameFnArgsDoc = mapM renameDoc -renameLType :: LHsType GHCR -> RnM (LHsType DocNameI) +renameLType :: LHsType GhcRn -> RnM (LHsType DocNameI) renameLType = mapM renameType -renameLSigType :: LHsSigType GHCR -> RnM (LHsSigType DocNameI) +renameLSigType :: LHsSigType GhcRn -> RnM (LHsSigType DocNameI) renameLSigType = renameImplicit renameLType -renameLSigWcType :: LHsSigWcType GHCR -> RnM (LHsSigWcType DocNameI) +renameLSigWcType :: LHsSigWcType GhcRn -> RnM (LHsSigWcType DocNameI) renameLSigWcType = renameWc (renameImplicit renameLType) -renameLKind :: LHsKind GHCR -> RnM (LHsKind DocNameI) +renameLKind :: LHsKind GhcRn -> RnM (LHsKind DocNameI) renameLKind = renameLType -renameMaybeLKind :: Maybe (LHsKind GHCR) -> RnM (Maybe (LHsKind DocNameI)) +renameMaybeLKind :: Maybe (LHsKind GhcRn) -> RnM (Maybe (LHsKind DocNameI)) renameMaybeLKind = traverse renameLKind -renameFamilyResultSig :: LFamilyResultSig GHCR -> RnM (LFamilyResultSig DocNameI) +renameFamilyResultSig :: LFamilyResultSig GhcRn -> RnM (LFamilyResultSig DocNameI) renameFamilyResultSig (L loc NoSig) = return (L loc NoSig) renameFamilyResultSig (L loc (KindSig ki)) @@ -197,17 +197,17 @@ renameFamilyResultSig (L loc (TyVarSig bndr)) = do { bndr' <- renameLTyVarBndr bndr ; return (L loc (TyVarSig bndr')) } -renameInjectivityAnn :: LInjectivityAnn GHCR -> RnM (LInjectivityAnn DocNameI) +renameInjectivityAnn :: LInjectivityAnn GhcRn -> RnM (LInjectivityAnn DocNameI) renameInjectivityAnn (L loc (InjectivityAnn lhs rhs)) = do { lhs' <- renameL lhs ; rhs' <- mapM renameL rhs ; return (L loc (InjectivityAnn lhs' rhs')) } -renameMaybeInjectivityAnn :: Maybe (LInjectivityAnn GHCR) +renameMaybeInjectivityAnn :: Maybe (LInjectivityAnn GhcRn) -> RnM (Maybe (LInjectivityAnn DocNameI)) renameMaybeInjectivityAnn = traverse renameInjectivityAnn -renameType :: HsType GHCR -> RnM (HsType DocNameI) +renameType :: HsType GhcRn -> RnM (HsType DocNameI) renameType t = case t of HsForAllTy { hst_bndrs = tyvars, hst_body = ltype } -> do tyvars' <- mapM renameLTyVarBndr tyvars @@ -268,13 +268,13 @@ renameType t = case t of HsWildCardTy a -> HsWildCardTy <$> renameWildCardInfo a HsAppsTy _ -> error "renameType: HsAppsTy" -renameLHsQTyVars :: LHsQTyVars GHCR -> RnM (LHsQTyVars DocNameI) +renameLHsQTyVars :: LHsQTyVars GhcRn -> RnM (LHsQTyVars DocNameI) renameLHsQTyVars (HsQTvs { hsq_implicit = _, hsq_explicit = tvs }) = do { tvs' <- mapM renameLTyVarBndr tvs ; return (HsQTvs { hsq_implicit = error "haddock:renameLHsQTyVars", hsq_explicit = tvs', hsq_dependent = error "haddock:renameLHsQTyVars" }) } -- This is rather bogus, but I'm not sure what else to do -renameLTyVarBndr :: LHsTyVarBndr GHCR -> RnM (LHsTyVarBndr DocNameI) +renameLTyVarBndr :: LHsTyVarBndr GhcRn -> RnM (LHsTyVarBndr DocNameI) renameLTyVarBndr (L loc (UserTyVar (L l n))) = do { n' <- rename n ; return (L loc (UserTyVar (L l n'))) } @@ -283,15 +283,15 @@ renameLTyVarBndr (L loc (KindedTyVar (L lv n) kind)) ; kind' <- renameLKind kind ; return (L loc (KindedTyVar (L lv n') kind')) } -renameLContext :: Located [LHsType GHCR] -> RnM (Located [LHsType DocNameI]) +renameLContext :: Located [LHsType GhcRn] -> RnM (Located [LHsType DocNameI]) renameLContext (L loc context) = do context' <- mapM renameLType context return (L loc context') -renameWildCardInfo :: HsWildCardInfo GHCR -> RnM (HsWildCardInfo DocNameI) +renameWildCardInfo :: HsWildCardInfo GhcRn -> RnM (HsWildCardInfo DocNameI) renameWildCardInfo (AnonWildCard (L l name)) = AnonWildCard . L l <$> rename name -renameInstHead :: InstHead GHCR -> RnM (InstHead DocNameI) +renameInstHead :: InstHead GhcRn -> RnM (InstHead DocNameI) renameInstHead InstHead {..} = do cname <- rename ihdClsName kinds <- mapM renameType ihdKinds @@ -311,11 +311,11 @@ renameInstHead InstHead {..} = do , ihdInstType = itype } -renameLDecl :: LHsDecl GHCR -> RnM (LHsDecl DocNameI) +renameLDecl :: LHsDecl GhcRn -> RnM (LHsDecl DocNameI) renameLDecl (L loc d) = return . L loc =<< renameDecl d -renameDecl :: HsDecl GHCR -> RnM (HsDecl DocNameI) +renameDecl :: HsDecl GhcRn -> RnM (HsDecl DocNameI) renameDecl decl = case decl of TyClD d -> do d' <- renameTyClD d @@ -334,10 +334,10 @@ renameDecl decl = case decl of return (DerivD d') _ -> error "renameDecl" -renameLThing :: (a GHCR -> RnM (a DocNameI)) -> Located (a GHCR) -> RnM (Located (a DocNameI)) +renameLThing :: (a GhcRn -> RnM (a DocNameI)) -> Located (a GhcRn) -> RnM (Located (a DocNameI)) renameLThing fn (L loc x) = return . L loc =<< fn x -renameTyClD :: TyClDecl GHCR -> RnM (TyClDecl DocNameI) +renameTyClD :: TyClDecl GhcRn -> RnM (TyClDecl DocNameI) renameTyClD d = case d of -- TyFamily flav lname ltyvars kind tckind -> do FamDecl { tcdFam = decl } -> do @@ -379,7 +379,7 @@ renameTyClD d = case d of renameLSig (L loc sig) = return . L loc =<< renameSig sig -renameFamilyDecl :: FamilyDecl GHCR -> RnM (FamilyDecl DocNameI) +renameFamilyDecl :: FamilyDecl GhcRn -> RnM (FamilyDecl DocNameI) renameFamilyDecl (FamilyDecl { fdInfo = info, fdLName = lname , fdTyVars = ltyvars , fdFixity = fixity @@ -397,7 +397,7 @@ renameFamilyDecl (FamilyDecl { fdInfo = info, fdLName = lname , fdInjectivityAnn = injectivity' }) -renamePseudoFamilyDecl :: PseudoFamilyDecl GHCR +renamePseudoFamilyDecl :: PseudoFamilyDecl GhcRn -> RnM (PseudoFamilyDecl DocNameI) renamePseudoFamilyDecl (PseudoFamilyDecl { .. }) = PseudoFamilyDecl <$> renameFamilyInfo pfdInfo @@ -406,14 +406,14 @@ renamePseudoFamilyDecl (PseudoFamilyDecl { .. }) = PseudoFamilyDecl <*> renameFamilyResultSig pfdKindSig -renameFamilyInfo :: FamilyInfo GHCR -> RnM (FamilyInfo DocNameI) +renameFamilyInfo :: FamilyInfo GhcRn -> RnM (FamilyInfo DocNameI) renameFamilyInfo DataFamily = return DataFamily renameFamilyInfo OpenTypeFamily = return OpenTypeFamily renameFamilyInfo (ClosedTypeFamily eqns) = do { eqns' <- mapM (mapM renameLTyFamInstEqn) eqns ; return $ ClosedTypeFamily eqns' } -renameDataDefn :: HsDataDefn GHCR -> RnM (HsDataDefn DocNameI) +renameDataDefn :: HsDataDefn GhcRn -> RnM (HsDataDefn DocNameI) renameDataDefn (HsDataDefn { dd_ND = nd, dd_ctxt = lcontext, dd_cType = cType , dd_kindSig = k, dd_cons = cons }) = do lcontext' <- renameLContext lcontext @@ -424,7 +424,7 @@ renameDataDefn (HsDataDefn { dd_ND = nd, dd_ctxt = lcontext, dd_cType = cType , dd_kindSig = k', dd_cons = cons' , dd_derivs = noLoc [] }) -renameCon :: ConDecl GHCR -> RnM (ConDecl DocNameI) +renameCon :: ConDecl GhcRn -> RnM (ConDecl DocNameI) renameCon decl@(ConDeclH98 { con_name = lname, con_qvars = ltyvars , con_cxt = lcontext, con_details = details , con_doc = mbldoc }) = do @@ -455,19 +455,19 @@ renameCon decl@(ConDeclGADT { con_names = lnames return (decl { con_names = lnames' , con_type = lty', con_doc = mbldoc' }) -renameConDeclFieldField :: LConDeclField GHCR -> RnM (LConDeclField DocNameI) +renameConDeclFieldField :: LConDeclField GhcRn -> RnM (LConDeclField DocNameI) renameConDeclFieldField (L l (ConDeclField names t doc)) = do names' <- mapM renameLFieldOcc names t' <- renameLType t doc' <- mapM renameLDocHsSyn doc return $ L l (ConDeclField names' t' doc') -renameLFieldOcc :: LFieldOcc GHCR -> RnM (LFieldOcc DocNameI) +renameLFieldOcc :: LFieldOcc GhcRn -> RnM (LFieldOcc DocNameI) renameLFieldOcc (L l (FieldOcc lbl sel)) = do sel' <- rename sel return $ L l (FieldOcc lbl sel') -renameSig :: Sig GHCR -> RnM (Sig DocNameI) +renameSig :: Sig GhcRn -> RnM (Sig DocNameI) renameSig sig = case sig of TypeSig lnames ltype -> do lnames' <- mapM renameL lnames @@ -491,7 +491,7 @@ renameSig sig = case sig of _ -> error "expected TypeSig" -renameForD :: ForeignDecl GHCR -> RnM (ForeignDecl DocNameI) +renameForD :: ForeignDecl GhcRn -> RnM (ForeignDecl DocNameI) renameForD (ForeignImport lname ltype co x) = do lname' <- renameL lname ltype' <- renameLSigType ltype @@ -502,7 +502,7 @@ renameForD (ForeignExport lname ltype co x) = do return (ForeignExport lname' ltype' co x) -renameInstD :: InstDecl GHCR -> RnM (InstDecl DocNameI) +renameInstD :: InstDecl GhcRn -> RnM (InstDecl DocNameI) renameInstD (ClsInstD { cid_inst = d }) = do d' <- renameClsInstD d return (ClsInstD { cid_inst = d' }) @@ -513,7 +513,7 @@ renameInstD (DataFamInstD { dfid_inst = d }) = do d' <- renameDataFamInstD d return (DataFamInstD { dfid_inst = d' }) -renameDerivD :: DerivDecl GHCR -> RnM (DerivDecl DocNameI) +renameDerivD :: DerivDecl GhcRn -> RnM (DerivDecl DocNameI) renameDerivD (DerivDecl { deriv_type = ty , deriv_strategy = strat , deriv_overlap_mode = omode }) = do @@ -522,7 +522,7 @@ renameDerivD (DerivDecl { deriv_type = ty , deriv_strategy = strat , deriv_overlap_mode = omode }) -renameClsInstD :: ClsInstDecl GHCR -> RnM (ClsInstDecl DocNameI) +renameClsInstD :: ClsInstDecl GhcRn -> RnM (ClsInstDecl DocNameI) renameClsInstD (ClsInstDecl { cid_overlap_mode = omode , cid_poly_ty =ltype, cid_tyfam_insts = lATs , cid_datafam_insts = lADTs }) = do @@ -535,13 +535,13 @@ renameClsInstD (ClsInstDecl { cid_overlap_mode = omode , cid_tyfam_insts = lATs', cid_datafam_insts = lADTs' }) -renameTyFamInstD :: TyFamInstDecl GHCR -> RnM (TyFamInstDecl DocNameI) +renameTyFamInstD :: TyFamInstDecl GhcRn -> RnM (TyFamInstDecl DocNameI) renameTyFamInstD (TyFamInstDecl { tfid_eqn = eqn }) = do { eqn' <- renameLTyFamInstEqn eqn ; return (TyFamInstDecl { tfid_eqn = eqn' , tfid_fvs = placeHolderNames }) } -renameLTyFamInstEqn :: LTyFamInstEqn GHCR -> RnM (LTyFamInstEqn DocNameI) +renameLTyFamInstEqn :: LTyFamInstEqn GhcRn -> RnM (LTyFamInstEqn DocNameI) renameLTyFamInstEqn (L loc (TyFamEqn { tfe_tycon = tc, tfe_pats = pats, tfe_fixity = fixity, tfe_rhs = rhs })) = do { tc' <- renameL tc ; pats' <- renameImplicit (mapM renameLType) pats @@ -551,7 +551,7 @@ renameLTyFamInstEqn (L loc (TyFamEqn { tfe_tycon = tc, tfe_pats = pats, tfe_fixi , tfe_fixity = fixity , tfe_rhs = rhs' })) } -renameLTyFamDefltEqn :: LTyFamDefltEqn GHCR -> RnM (LTyFamDefltEqn DocNameI) +renameLTyFamDefltEqn :: LTyFamDefltEqn GhcRn -> RnM (LTyFamDefltEqn DocNameI) renameLTyFamDefltEqn (L loc (TyFamEqn { tfe_tycon = tc, tfe_pats = tvs, tfe_fixity = fixity, tfe_rhs = rhs })) = do { tc' <- renameL tc ; tvs' <- renameLHsQTyVars tvs @@ -561,7 +561,7 @@ renameLTyFamDefltEqn (L loc (TyFamEqn { tfe_tycon = tc, tfe_pats = tvs, tfe_fixi , tfe_fixity = fixity , tfe_rhs = rhs' })) } -renameDataFamInstD :: DataFamInstDecl GHCR -> RnM (DataFamInstDecl DocNameI) +renameDataFamInstD :: DataFamInstDecl GhcRn -> RnM (DataFamInstDecl DocNameI) renameDataFamInstD (DataFamInstDecl { dfid_tycon = tc, dfid_pats = pats, dfid_fixity = fixity, dfid_defn = defn }) = do { tc' <- renameL tc ; pats' <- renameImplicit (mapM renameLType) pats @@ -572,7 +572,7 @@ renameDataFamInstD (DataFamInstDecl { dfid_tycon = tc, dfid_pats = pats, dfid_fi , dfid_defn = defn', dfid_fvs = placeHolderNames }) } renameImplicit :: (in_thing -> RnM out_thing) - -> HsImplicitBndrs GHCR in_thing + -> HsImplicitBndrs GhcRn in_thing -> RnM (HsImplicitBndrs DocNameI out_thing) renameImplicit rn_thing (HsIB { hsib_body = thing }) = do { thing' <- rn_thing thing @@ -581,21 +581,21 @@ renameImplicit rn_thing (HsIB { hsib_body = thing }) , hsib_closed = PlaceHolder }) } renameWc :: (in_thing -> RnM out_thing) - -> HsWildCardBndrs GHCR in_thing + -> HsWildCardBndrs GhcRn in_thing -> RnM (HsWildCardBndrs DocNameI out_thing) renameWc rn_thing (HsWC { hswc_body = thing }) = do { thing' <- rn_thing thing ; return (HsWC { hswc_body = thing' , hswc_wcs = PlaceHolder }) } -renameDocInstance :: DocInstance GHCR -> RnM (DocInstance DocNameI) +renameDocInstance :: DocInstance GhcRn -> RnM (DocInstance DocNameI) renameDocInstance (inst, idoc, L l n) = do inst' <- renameInstHead inst n' <- rename n idoc' <- mapM renameDoc idoc return (inst', idoc',L l n') -renameExportItem :: ExportItem GHCR -> RnM (ExportItem DocNameI) +renameExportItem :: ExportItem GhcRn -> RnM (ExportItem DocNameI) renameExportItem item = case item of ExportModule mdl -> return (ExportModule mdl) ExportGroup lev id_ doc -> do diff --git a/haddock-api/src/Haddock/Types.hs b/haddock-api/src/Haddock/Types.hs index b595c856..cb4a4bcc 100644 --- a/haddock-api/src/Haddock/Types.hs +++ b/haddock-api/src/Haddock/Types.hs @@ -57,7 +57,7 @@ type InstIfaceMap = Map Module InstalledInterface -- TODO: rename type DocMap a = Map Name (MDoc a) type ArgMap a = Map Name (Map Int (MDoc a)) type SubMap = Map Name [Name] -type DeclMap = Map Name [LHsDecl GHCR] +type DeclMap = Map Name [LHsDecl GhcRn] type InstMap = Map SrcSpan Name type FixMap = Map Name Fixity type DocPaths = (FilePath, Maybe FilePath) -- paths to HTML and sources @@ -99,7 +99,7 @@ data Interface = Interface -- | Declarations originating from the module. Excludes declarations without -- names (instances and stand-alone documentation comments). Includes -- names of subordinate declarations mapped to their parent declarations. - , ifaceDeclMap :: !(Map Name [LHsDecl GHCR]) + , ifaceDeclMap :: !(Map Name [LHsDecl GhcRn]) -- | Documentation of declarations originating from the module (including -- subordinates). @@ -114,7 +114,7 @@ data Interface = Interface , ifaceSubMap :: !(Map Name [Name]) , ifaceFixMap :: !(Map Name Fixity) - , ifaceExportItems :: ![ExportItem GHCR] + , ifaceExportItems :: ![ExportItem GhcRn] , ifaceRnExportItems :: ![ExportItem DocNameI] -- | All names exported by the module. @@ -133,7 +133,7 @@ data Interface = Interface , ifaceFamInstances :: ![FamInst] -- | Orphan instances - , ifaceOrphanInstances :: ![DocInstance GHCR] + , ifaceOrphanInstances :: ![DocInstance GhcRn] , ifaceRnOrphanInstances :: ![DocInstance DocNameI] -- | The number of haddockable and haddocked items in the module, as a diff --git a/haddock-api/src/Haddock/Utils.hs b/haddock-api/src/Haddock/Utils.hs index e5d589e0..f5c5b743 100644 --- a/haddock-api/src/Haddock/Utils.hs +++ b/haddock-api/src/Haddock/Utils.hs @@ -125,12 +125,12 @@ toInstalledDescription = fmap mkMeta . hmi_description . instInfo mkMeta :: Doc a -> MDoc a mkMeta x = emptyMetaDoc { _doc = x } -mkEmptySigWcType :: LHsType GHCR -> LHsSigWcType GHCR +mkEmptySigWcType :: LHsType GhcRn -> LHsSigWcType GhcRn -- Dubious, because the implicit binders are empty even -- though the type might have free varaiables mkEmptySigWcType ty = mkEmptyWildCardBndrs (mkEmptyImplicitBndrs ty) -addClassContext :: IdP GHCR -> LHsQTyVars GHCR -> LSig GHCR -> LSig GHCR +addClassContext :: Name -> LHsQTyVars GhcRn -> LSig GhcRn -> LSig GhcRn -- Add the class context to a class-op signature addClassContext cls tvs0 (L pos (ClassOpSig _ lname ltype)) = L pos (TypeSig lname (mkEmptySigWcType (go (hsSigType ltype)))) @@ -148,7 +148,7 @@ addClassContext cls tvs0 (L pos (ClassOpSig _ lname ltype)) addClassContext _ _ sig = sig -- E.g. a MinimalSig is fine -lHsQTyVarsToTypes :: LHsQTyVars GHCR -> [LHsType GHCR] +lHsQTyVarsToTypes :: LHsQTyVars GhcRn -> [LHsType GhcRn] lHsQTyVarsToTypes tvs = [ noLoc (HsTyVar NotPromoted (noLoc (hsLTyVarName tv))) | tv <- hsQTvExplicit tvs ] @@ -158,7 +158,7 @@ lHsQTyVarsToTypes tvs -------------------------------------------------------------------------------- -restrictTo :: [IdP GHCR] -> LHsDecl GHCR -> LHsDecl GHCR +restrictTo :: [Name] -> LHsDecl GhcRn -> LHsDecl GhcRn restrictTo names (L loc decl) = L loc $ case decl of TyClD d | isDataDecl d -> TyClD (d { tcdDataDefn = restrictDataDefn names (tcdDataDefn d) }) @@ -167,7 +167,7 @@ restrictTo names (L loc decl) = L loc $ case decl of tcdATs = restrictATs names (tcdATs d) }) _ -> decl -restrictDataDefn :: [IdP GHCR] -> HsDataDefn GHCR -> HsDataDefn GHCR +restrictDataDefn :: [Name] -> HsDataDefn GhcRn -> HsDataDefn GhcRn restrictDataDefn names defn@(HsDataDefn { dd_ND = new_or_data, dd_cons = cons }) | DataType <- new_or_data = defn { dd_cons = restrictCons names cons } @@ -177,7 +177,7 @@ restrictDataDefn names defn@(HsDataDefn { dd_ND = new_or_data, dd_cons = cons }) [con] -> defn { dd_cons = [con] } _ -> error "Should not happen" -restrictCons :: [IdP GHCR] -> [LConDecl GHCR] -> [LConDecl GHCR] +restrictCons :: [Name] -> [LConDecl GhcRn] -> [LConDecl GhcRn] restrictCons names decls = [ L p d | L p (Just d) <- map (fmap keep) decls ] where keep d | any (\n -> n `elem` names) (map unLoc $ getConNames d) = @@ -197,7 +197,7 @@ restrictCons names decls = [ L p d | L p (Just d) <- map (fmap keep) decls ] h98ConDecl c@ConDeclGADT{} = c' where (details,_res_ty,cxt,tvs) = gadtDeclDetails (con_type c) - c' :: ConDecl GHCR + c' :: ConDecl GhcRn c' = ConDeclH98 { con_name = head (con_names c) , con_qvars = Just $ HsQTvs { hsq_implicit = mempty @@ -208,18 +208,18 @@ restrictCons names decls = [ L p d | L p (Just d) <- map (fmap keep) decls ] , con_doc = con_doc c } - field_avail :: LConDeclField GHCR -> Bool + field_avail :: LConDeclField GhcRn -> Bool field_avail (L _ (ConDeclField fs _ _)) = all (\f -> selectorFieldOcc (unLoc f) `elem` names) fs field_types flds = [ t | ConDeclField _ t _ <- flds ] keep _ = Nothing -restrictDecls :: [IdP GHCR] -> [LSig GHCR] -> [LSig GHCR] +restrictDecls :: [Name] -> [LSig GhcRn] -> [LSig GhcRn] restrictDecls names = mapMaybe (filterLSigNames (`elem` names)) -restrictATs :: [IdP GHCR] -> [LFamilyDecl GHCR] -> [LFamilyDecl GHCR] +restrictATs :: [Name] -> [LFamilyDecl GhcRn] -> [LFamilyDecl GhcRn] restrictATs names ats = [ at | at <- ats , unL (fdLName (unL at)) `elem` names ] emptyHsQTvs :: LHsQTyVars Name -- cgit v1.2.3 From 7cecbd969298d5aa576750864a69fa5f70f71c32 Mon Sep 17 00:00:00 2001 From: Doug Wilson Date: Wed, 21 Jun 2017 19:27:33 +1200 Subject: Use new function getNameToInstancesIndex instead of tcRnGetInfo (#636) There is some performance improvement. GHC compiler: | version | bytes allocated | cpu_seconds --------------------------------- | before | 56057108648 | 41.0 | after | 51592019560 | 35.1 base: | version | bytes allocated | cpu_seconds --------------------------------- | before | 25174011784 | 14.6 | after | 23712637272 | 13.1 Cabal: | version | bytes allocated | cpu_seconds --------------------------------- | before | 18754966920 | 12.6 | after | 18198208864 | 11.6 --- .../src/Haddock/Interface/AttachInstances.hs | 82 +++++++++++----------- 1 file changed, 41 insertions(+), 41 deletions(-) (limited to 'haddock-api/src/Haddock/Interface/AttachInstances.hs') diff --git a/haddock-api/src/Haddock/Interface/AttachInstances.hs b/haddock-api/src/Haddock/Interface/AttachInstances.hs index 6d0bed2a..1eb227b9 100644 --- a/haddock-api/src/Haddock/Interface/AttachInstances.hs +++ b/haddock-api/src/Haddock/Interface/AttachInstances.hs @@ -23,9 +23,10 @@ import Control.Arrow hiding ((<+>)) import Data.List import Data.Ord (comparing) import Data.Function (on) -import Data.Maybe ( maybeToList, mapMaybe ) +import Data.Maybe ( maybeToList, mapMaybe, fromMaybe ) import qualified Data.Map as Map import qualified Data.Set as Set +import Control.Monad import Class import DynFlags @@ -38,10 +39,10 @@ import GhcMonad (withSession) import InstEnv import MonadUtils (liftIO) import Name +import NameEnv import Outputable (text, sep, (<+>)) import PrelNames import SrcLoc -import TcRnDriver (tcRnGetInfo) import TyCon import TyCoRep import TysPrim( funTyCon ) @@ -54,13 +55,15 @@ type ExportInfo = (ExportedNames, Modules) -- Also attaches fixities attachInstances :: ExportInfo -> [Interface] -> InstIfaceMap -> Ghc [Interface] -attachInstances expInfo ifaces instIfaceMap = mapM attach ifaces +attachInstances expInfo ifaces instIfaceMap = do + (_msgs, mb_index) <- getNameToInstancesIndex + mapM (attach $ fromMaybe emptyNameEnv mb_index) ifaces where -- TODO: take an IfaceMap as input ifaceMap = Map.fromList [ (ifaceMod i, i) | i <- ifaces ] - attach iface = do - newItems <- mapM (attachToExportItem expInfo iface ifaceMap instIfaceMap) + attach index iface = do + newItems <- mapM (attachToExportItem index expInfo iface ifaceMap instIfaceMap) (ifaceExportItems iface) let orphanInstances = attachOrphanInstances expInfo iface ifaceMap instIfaceMap (ifaceInstances iface) return $ iface { ifaceExportItems = newItems @@ -76,37 +79,42 @@ attachOrphanInstances expInfo iface ifaceMap instIfaceMap cls_instances = ] -attachToExportItem :: ExportInfo -> Interface -> IfaceMap -> InstIfaceMap - -> ExportItem GhcRn - -> Ghc (ExportItem GhcRn) -attachToExportItem expInfo iface ifaceMap instIfaceMap export = +attachToExportItem + :: NameEnv ([ClsInst], [FamInst]) + -> ExportInfo + -> Interface + -> IfaceMap + -> InstIfaceMap + -> ExportItem GhcRn + -> Ghc (ExportItem GhcRn) +attachToExportItem index expInfo iface ifaceMap instIfaceMap export = case attachFixities export of e@ExportDecl { expItemDecl = L eSpan (TyClD d) } -> do - mb_info <- getAllInfo (tcdName d) - insts <- case mb_info of - Just (_, _, cls_instances, fam_instances) -> - let fam_insts = [ (synifyFamInst i opaque, doc,spanNameE n (synifyFamInst i opaque) (L eSpan (tcdName d)) ) - | i <- sortBy (comparing instFam) fam_instances - , let n = getName i - , let doc = instLookup instDocMap n iface ifaceMap instIfaceMap - , not $ isNameHidden expInfo (fi_fam i) - , not $ any (isTypeHidden expInfo) (fi_tys i) - , let opaque = isTypeHidden expInfo (fi_rhs i) - ] - cls_insts = [ (synifyInstHead i, instLookup instDocMap n iface ifaceMap instIfaceMap, spanName n (synifyInstHead i) (L eSpan (tcdName d))) - | let is = [ (instanceSig i, getName i) | i <- cls_instances ] - , (i@(_,_,cls,tys), n) <- sortBy (comparing $ first instHead) is - , not $ isInstanceHidden expInfo cls tys - ] + insts <- + let mb_instances = lookupNameEnv index (tcdName d) + cls_instances = maybeToList mb_instances >>= fst + fam_instances = maybeToList mb_instances >>= snd + fam_insts = [ (synifyFamInst i opaque, doc,spanNameE n (synifyFamInst i opaque) (L eSpan (tcdName d)) ) + | i <- sortBy (comparing instFam) fam_instances + , let n = getName i + , let doc = instLookup instDocMap n iface ifaceMap instIfaceMap + , not $ isNameHidden expInfo (fi_fam i) + , not $ any (isTypeHidden expInfo) (fi_tys i) + , let opaque = isTypeHidden expInfo (fi_rhs i) + ] + cls_insts = [ (synifyInstHead i, instLookup instDocMap n iface ifaceMap instIfaceMap, spanName n (synifyInstHead i) (L eSpan (tcdName d))) + | let is = [ (instanceSig i, getName i) | i <- cls_instances ] + , (i@(_,_,cls,tys), n) <- sortBy (comparing $ first instHead) is + , not $ isInstanceHidden expInfo cls tys + ] -- fam_insts but with failing type fams filtered out - cleanFamInsts = [ (fi, n, L l r) | (Right fi, n, L l (Right r)) <- fam_insts ] - famInstErrs = [ errm | (Left errm, _, _) <- fam_insts ] - in do - dfs <- getDynFlags - let mkBug = (text "haddock-bug:" <+>) . text - liftIO $ putMsg dfs (sep $ map mkBug famInstErrs) - return $ cls_insts ++ cleanFamInsts - Nothing -> return [] + cleanFamInsts = [ (fi, n, L l r) | (Right fi, n, L l (Right r)) <- fam_insts ] + famInstErrs = [ errm | (Left errm, _, _) <- fam_insts ] + in do + dfs <- getDynFlags + let mkBug = (text "haddock-bug:" <+>) . text + liftIO $ putMsg dfs (sep $ map mkBug famInstErrs) + return $ cls_insts ++ cleanFamInsts return $ e { expItemInstances = insts } e -> return e where @@ -143,14 +151,6 @@ instLookup f name iface ifaceMap instIfaceMap = iface' <- Map.lookup (nameModule name) ifaceMaps Map.lookup name (f iface') --- | Like GHC's getInfo but doesn't cut things out depending on the --- interative context, which we don't set sufficiently anyway. -getAllInfo :: GhcMonad m => Name -> m (Maybe (TyThing,Fixity,[ClsInst],[FamInst])) -getAllInfo name = withSession $ \hsc_env -> do - (_msgs, r) <- liftIO $ tcRnGetInfo hsc_env name - return r - - -------------------------------------------------------------------------------- -- Collecting and sorting instances -------------------------------------------------------------------------------- -- cgit v1.2.3 From 3adf5bcb1a6c5326ab33dc77b4aa229a91d91ce9 Mon Sep 17 00:00:00 2001 From: Alexander Biehl Date: Thu, 5 Oct 2017 11:27:05 +0200 Subject: Don't use subMap in attachInstances --- haddock-api/src/Haddock/Interface/AttachInstances.hs | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) (limited to 'haddock-api/src/Haddock/Interface/AttachInstances.hs') diff --git a/haddock-api/src/Haddock/Interface/AttachInstances.hs b/haddock-api/src/Haddock/Interface/AttachInstances.hs index 0e5811b1..2231ce7e 100644 --- a/haddock-api/src/Haddock/Interface/AttachInstances.hs +++ b/haddock-api/src/Haddock/Interface/AttachInstances.hs @@ -118,12 +118,12 @@ attachToExportItem index expInfo iface ifaceMap instIfaceMap export = where attachFixities e@ExportDecl{ expItemDecl = L _ d , expItemPats = patsyns + , expItemSubDocs = subDocs } = e { expItemFixities = nubByName fst $ expItemFixities e ++ [ (n',f) | n <- getMainDeclBinder d - , Just subs <- [instLookup instSubMap n iface ifaceMap instIfaceMap <|> Just []] - , n' <- n : (subs ++ patsyn_names) - , Just f <- [instLookup instFixMap n' iface ifaceMap instIfaceMap] + , n' <- n : (map fst subDocs ++ patsyn_names) + , Just f <- [instLookup instFixMap n' iface ifaceMap instIfaceMap] ] } where patsyn_names = concatMap (getMainDeclBinder . fst) patsyns -- cgit v1.2.3 From 527596cdec687f4dc03b3281a400158be60fe36d Mon Sep 17 00:00:00 2001 From: Alexander Biehl Date: Thu, 5 Oct 2017 11:27:58 +0200 Subject: Revert "Don't use subMap in attachInstances" This reverts commit 3adf5bcb1a6c5326ab33dc77b4aa229a91d91ce9. --- haddock-api/src/Haddock/Interface/AttachInstances.hs | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) (limited to 'haddock-api/src/Haddock/Interface/AttachInstances.hs') diff --git a/haddock-api/src/Haddock/Interface/AttachInstances.hs b/haddock-api/src/Haddock/Interface/AttachInstances.hs index 2231ce7e..0e5811b1 100644 --- a/haddock-api/src/Haddock/Interface/AttachInstances.hs +++ b/haddock-api/src/Haddock/Interface/AttachInstances.hs @@ -118,12 +118,12 @@ attachToExportItem index expInfo iface ifaceMap instIfaceMap export = where attachFixities e@ExportDecl{ expItemDecl = L _ d , expItemPats = patsyns - , expItemSubDocs = subDocs } = e { expItemFixities = nubByName fst $ expItemFixities e ++ [ (n',f) | n <- getMainDeclBinder d - , n' <- n : (map fst subDocs ++ patsyn_names) - , Just f <- [instLookup instFixMap n' iface ifaceMap instIfaceMap] + , Just subs <- [instLookup instSubMap n iface ifaceMap instIfaceMap <|> Just []] + , n' <- n : (subs ++ patsyn_names) + , Just f <- [instLookup instFixMap n' iface ifaceMap instIfaceMap] ] } where patsyn_names = concatMap (getMainDeclBinder . fst) patsyns -- cgit v1.2.3 From e498b7871bfbee8b38858b546390246ddddb9509 Mon Sep 17 00:00:00 2001 From: Alexander Biehl Date: Sun, 8 Oct 2017 15:32:28 +0200 Subject: Precise Haddock: Use Avails for export resolution (#688) * Use Avails for export resolution * Support reexported modules * Factor out availExportItem * Use avails for fullModuleExports * Don't use subMap in attachInstances * lookupDocs without subMap * Completely remove subMap * Only calculate unqualified modules when explicit export list is given * Refactor * Refine comment * return * Fix * Refactoring * Split avail if declaration is not exported itself * Move avail splitting --- .../src/Haddock/Interface/AttachInstances.hs | 6 +- haddock-api/src/Haddock/Interface/Create.hs | 434 ++++++++++----------- haddock-api/src/Haddock/Interface/Json.hs | 3 - haddock-api/src/Haddock/InterfaceFile.hs | 11 +- haddock-api/src/Haddock/Types.hs | 10 - 5 files changed, 220 insertions(+), 244 deletions(-) (limited to 'haddock-api/src/Haddock/Interface/AttachInstances.hs') diff --git a/haddock-api/src/Haddock/Interface/AttachInstances.hs b/haddock-api/src/Haddock/Interface/AttachInstances.hs index 0e5811b1..2231ce7e 100644 --- a/haddock-api/src/Haddock/Interface/AttachInstances.hs +++ b/haddock-api/src/Haddock/Interface/AttachInstances.hs @@ -118,12 +118,12 @@ attachToExportItem index expInfo iface ifaceMap instIfaceMap export = where attachFixities e@ExportDecl{ expItemDecl = L _ d , expItemPats = patsyns + , expItemSubDocs = subDocs } = e { expItemFixities = nubByName fst $ expItemFixities e ++ [ (n',f) | n <- getMainDeclBinder d - , Just subs <- [instLookup instSubMap n iface ifaceMap instIfaceMap <|> Just []] - , n' <- n : (subs ++ patsyn_names) - , Just f <- [instLookup instFixMap n' iface ifaceMap instIfaceMap] + , n' <- n : (map fst subDocs ++ patsyn_names) + , Just f <- [instLookup instFixMap n' iface ifaceMap instIfaceMap] ] } where patsyn_names = concatMap (getMainDeclBinder . fst) patsyns diff --git a/haddock-api/src/Haddock/Interface/Create.hs b/haddock-api/src/Haddock/Interface/Create.hs index d9f37a4f..9bf21e52 100644 --- a/haddock-api/src/Haddock/Interface/Create.hs +++ b/haddock-api/src/Haddock/Interface/Create.hs @@ -31,6 +31,7 @@ import Haddock.Backends.Hyperlinker.Types import Haddock.Backends.Hyperlinker.Ast as Hyperlinker import Haddock.Backends.Hyperlinker.Parser as Hyperlinker +import Data.Bifunctor import Data.Bitraversable import qualified Data.ByteString as BS import qualified Data.Map as M @@ -44,9 +45,12 @@ import Control.Exception (evaluate) import Control.Monad import Data.Traversable +import Avail hiding (avail) +import qualified Avail import qualified Packages import qualified Module import qualified SrcLoc +import ConLike (ConLike(..)) import GHC import HscTypes import Name @@ -59,6 +63,7 @@ import BasicTypes ( StringLiteral(..), SourceText(..) ) import qualified Outputable as O import HsDecls ( getConDetails ) + -- | Use a 'TypecheckedModule' to produce an 'Interface'. -- To do this, we need access to already processed modules in the topological -- sort. That's what's in the 'IfaceMap'. @@ -83,47 +88,36 @@ createInterface tm flags modMap instIfaceMap = do (TcGblEnv { tcg_rdr_env = gre , tcg_warns = warnings - , tcg_patsyns = patsyns + , tcg_exports = all_exports }, md) = tm_internals_ tm -- The renamed source should always be available to us, but it's best -- to be on the safe side. - (group_, mayExports, mayDocHeader) <- + (group_, imports, mayExports, mayDocHeader) <- case renamedSource tm of Nothing -> do liftErrMsg $ tell [ "Warning: Renamed source is not available." ] - return (emptyRnGroup, Nothing, Nothing) - Just (x, _, y, z) -> return (x, y, z) + return (emptyRnGroup, [], Nothing, Nothing) + Just x -> return x - opts0 <- liftErrMsg $ mkDocOpts (haddockOptions dflags) flags mdl - let opts - | Flag_IgnoreAllExports `elem` flags = OptIgnoreExports : opts0 - | otherwise = opts0 + opts <- liftErrMsg $ mkDocOpts (haddockOptions dflags) flags mdl -- Process the top-level module header documentation. (!info, mbDoc) <- liftErrMsg $ processModuleHeader dflags gre safety mayDocHeader let declsWithDocs = topDecls group_ - exports0 = fmap (reverse . map (unLoc . fst)) mayExports + exports0 = fmap (reverse . map (first unLoc)) mayExports exports | OptIgnoreExports `elem` opts = Nothing | otherwise = exports0 - localBundledPatSyns :: Map Name [Name] - localBundledPatSyns = - case exports of - Nothing -> M.empty - Just ies -> - M.map (nubByName id) $ - M.fromListWith (++) [ (ieWrappedName ty_name, bundled_patsyns) - | IEThingWith (L _ ty_name) _ exported _ <- ies - , let bundled_patsyns = - filter is_patsyn (map (ieWrappedName . unLoc) exported) - , not (null bundled_patsyns) - ] - where - is_patsyn name = elemNameSet name (mkNameSet (map getName patsyns)) + unrestrictedImportedMods + -- module re-exports are only possible with + -- explicit export list + | Just _ <- exports + = unrestrictedModuleImports (map unLoc imports) + | otherwise = M.empty fixMap = mkFixMap group_ (decls, _) = unzip declsWithDocs @@ -135,15 +129,16 @@ createInterface tm flags modMap instIfaceMap = do warningMap <- liftErrMsg (mkWarningMap dflags warnings gre exportedNames) - maps@(!docMap, !argMap, !subMap, !declMap, _) <- + maps@(!docMap, !argMap, !declMap, _) <- liftErrMsg (mkMaps dflags gre localInsts declsWithDocs) let allWarnings = M.unions (warningMap : map ifaceWarningMap (M.elems modMap)) -- The MAIN functionality: compute the export items which will -- each be the actual documentation of this module. - exportItems <- mkExportItems is_sig modMap mdl sem_mdl allWarnings gre exportedNames decls - maps localBundledPatSyns fixMap splices exports instIfaceMap dflags + exportItems <- mkExportItems is_sig modMap mdl sem_mdl allWarnings gre + exportedNames decls maps fixMap unrestrictedImportedMods + splices exports all_exports instIfaceMap dflags let !visibleNames = mkVisibleNames maps exportItems opts @@ -184,8 +179,6 @@ createInterface tm flags modMap instIfaceMap = do , ifaceExports = exportedNames , ifaceVisibleExports = visibleNames , ifaceDeclMap = declMap - , ifaceBundledPatSynMap = localBundledPatSyns - , ifaceSubMap = subMap , ifaceFixMap = fixMap , ifaceModuleAliases = aliases , ifaceInstances = instances @@ -231,6 +224,41 @@ mkAliasMap dflags mRenamedSource = alias)) impDecls +-- We want to know which modules are imported without any qualification. This +-- way we can display module reexports more compactly. This mapping also looks +-- through aliases: +-- +-- module M (module X) where +-- import M1 as X +-- import M2 as X +-- +-- With our mapping we know that we can display exported modules M1 and M2. +-- +unrestrictedModuleImports :: [ImportDecl name] -> M.Map ModuleName [ModuleName] +unrestrictedModuleImports idecls = + M.map (map (unLoc . ideclName)) + $ M.filter (all isInteresting) impModMap + where + impModMap = + M.fromListWith (++) (concatMap moduleMapping idecls) + + moduleMapping idecl = + concat [ [ (unLoc (ideclName idecl), [idecl]) ] + , [ (unLoc mod_name, [idecl]) + | Just mod_name <- [ideclAs idecl] + ] + ] + + isInteresting idecl = + case ideclHiding idecl of + -- i) no subset selected + Nothing -> True + -- ii) an import with a hiding clause + -- without any names + Just (True, L _ []) -> True + -- iii) any other case of qualification + _ -> False + -- Similar to GHC.lookupModule -- ezyang: Not really... lookupModuleDyn :: @@ -289,10 +317,13 @@ mkDocOpts mbOpts flags mdl = do hm <- if Flag_HideModule (moduleString mdl) `elem` flags then return $ OptHide : opts else return opts - if Flag_ShowExtensions (moduleString mdl) `elem` flags - then return $ OptShowExtensions : hm - else return hm - + ie <- if Flag_IgnoreAllExports `elem` flags + then return $ OptIgnoreExports : hm + else return hm + se <- if Flag_ShowExtensions (moduleString mdl) `elem` flags + then return $ OptShowExtensions : ie + else return ie + return se parseOption :: String -> ErrMsgM (Maybe DocOption) parseOption "hide" = return (Just OptHide) @@ -308,7 +339,7 @@ parseOption other = tell ["Unrecognised option: " ++ other] >> return Nothing -------------------------------------------------------------------------------- -type Maps = (DocMap Name, ArgMap Name, SubMap, DeclMap, InstMap) +type Maps = (DocMap Name, ArgMap Name, DeclMap, InstMap) -- | Create 'Maps' by looping through the declarations. For each declaration, -- find its names, its subordinates, and its doc strings. Process doc strings @@ -319,11 +350,10 @@ mkMaps :: DynFlags -> [(LHsDecl GhcRn, [HsDocString])] -> ErrMsgM Maps mkMaps dflags gre instances decls = do - (a, b, c, d) <- unzip4 <$> traverse mappings decls + (a, b, c) <- unzip3 <$> traverse mappings decls pure ( f' (map (nubByName fst) a) , f (filterMapping (not . M.null) b) , f (filterMapping (not . null) c) - , f (filterMapping (not . null) d) , instanceMap ) where @@ -339,7 +369,6 @@ mkMaps dflags gre instances decls = do mappings :: (LHsDecl GhcRn, [HsDocString]) -> ErrMsgM ( [(Name, MDoc Name)] , [(Name, Map Int (MDoc Name))] - , [(Name, [Name])] , [(Name, [LHsDecl GhcRn])] ) mappings (ldecl, docStrs) = do @@ -364,7 +393,6 @@ mkMaps dflags gre instances decls = do subNs = [ n | (n, _, _) <- subs ] dm = [ (n, d) | (n, Just d) <- zip ns (repeat doc) ++ zip subNs subDocs ] am = [ (n, args) | n <- ns ] ++ zip subNs subArgs - sm = [ (n, subNs) | n <- ns ] cm = [ (n, [ldecl]) | n <- ns ++ subNs ] seqList ns `seq` @@ -372,7 +400,7 @@ mkMaps dflags gre instances decls = do doc `seq` seqList subDocs `seq` seqList subArgs `seq` - pure (dm, am, sm, cm) + pure (dm, am, cm) instanceMap :: Map SrcSpan Name instanceMap = M.fromList [ (getSrcSpan n, n) | n <- instances ] @@ -583,55 +611,86 @@ mkExportItems -> [Name] -- exported names (orig) -> [LHsDecl GhcRn] -- renamed source declarations -> Maps - -> Map Name [Name] -> FixMap + -> M.Map ModuleName [ModuleName] -> [SrcSpan] -- splice locations - -> Maybe [IE GhcRn] + -> Maybe [(IE GhcRn, Avails)] + -> Avails -- exported stuff from this module -> InstIfaceMap -> DynFlags -> ErrMsgGhc [ExportItem GhcRn] mkExportItems is_sig modMap thisMod semMod warnings gre exportedNames decls - maps@(docMap, argMap, subMap, declMap, instMap) patSynMap fixMap splices optExports instIfaceMap dflags = - case optExports of - Nothing -> fullModuleContents dflags warnings gre maps fixMap splices decls + maps fixMap unrestricted_imp_mods splices exportList allExports + instIfaceMap dflags = + case exportList of + Nothing -> + fullModuleContents is_sig modMap thisMod semMod warnings exportedNames + maps fixMap splices instIfaceMap dflags allExports Just exports -> liftM concat $ mapM lookupExport exports where - lookupExport (IEVar (L _ x)) = declWith [] $ ieWrappedName x - lookupExport (IEThingAbs (L _ t)) = declWith [] $ ieWrappedName t - lookupExport (IEThingAll (L _ t)) = do - let name = ieWrappedName t - pats <- findBundledPatterns name - declWith pats name - lookupExport (IEThingWith (L _ t) _ _ _) = do - let name = ieWrappedName t - pats <- findBundledPatterns name - declWith pats name - lookupExport (IEModuleContents (L _ m)) = - -- TODO: We could get more accurate reporting here if IEModuleContents - -- also recorded the actual names that are exported here. We CAN - -- compute this info using @gre@ but 'moduleExports does not seem to - -- do so. - -- NB: Pass in identity module, so we can look it up in index correctly - moduleExports thisMod m dflags warnings gre exportedNames decls modMap instIfaceMap maps fixMap splices - lookupExport (IEGroup lev docStr) = liftErrMsg $ do + lookupExport (IEGroup lev docStr, _) = liftErrMsg $ do doc <- processDocString dflags gre docStr return [ExportGroup lev "" doc] - lookupExport (IEDoc docStr) = liftErrMsg $ do + lookupExport (IEDoc docStr, _) = liftErrMsg $ do doc <- processDocStringParas dflags gre docStr return [ExportDoc doc] - lookupExport (IEDocNamed str) = liftErrMsg $ + lookupExport (IEDocNamed str, _) = liftErrMsg $ findNamedDoc str [ unL d | d <- decls ] >>= \case Nothing -> return [] Just docStr -> do doc <- processDocStringParas dflags gre docStr return [ExportDoc doc] - declWith :: [(HsDecl GhcRn, DocForDecl Name)] -> Name -> ErrMsgGhc [ ExportItem GhcRn ] - declWith pats t = do - r <- findDecl t + lookupExport (IEModuleContents (L _ mod_name), _) + -- only consider exporting a module if we are sure we + -- are really exporting the whole module and not some + -- subset. We also look through module aliases here. + | Just mods <- M.lookup mod_name unrestricted_imp_mods + , not (null mods) + = concat <$> traverse (moduleExport thisMod dflags modMap instIfaceMap) mods + + lookupExport (_, avails) = + concat <$> traverse availExport (nubAvails avails) + + availExport avail = + availExportItem is_sig modMap thisMod semMod warnings exportedNames + maps fixMap splices instIfaceMap dflags avail + +availExportItem :: Bool -- is it a signature + -> IfaceMap + -> Module -- this module + -> Module -- semantic module + -> WarningMap + -> [Name] -- exported names (orig) + -> Maps + -> FixMap + -> [SrcSpan] -- splice locations + -> InstIfaceMap + -> DynFlags + -> AvailInfo + -> ErrMsgGhc [ExportItem GhcRn] +availExportItem is_sig modMap thisMod semMod warnings exportedNames + maps@(docMap, argMap, declMap, instMap) fixMap splices instIfaceMap + dflags availInfo + | availName availInfo `notElem` availNamesWithSelectors availInfo = do + exportItems <- for (availNamesWithSelectors availInfo) + (availExportItem is_sig modMap thisMod semMod + warnings exportedNames maps fixMap splices + instIfaceMap dflags . Avail.avail) + return (concat exportItems) + | otherwise = do + pats <- findBundledPatterns availInfo + declWith availInfo pats + where + declWith :: AvailInfo + -> [(HsDecl GhcRn, DocForDecl Name)] + -> ErrMsgGhc [ ExportItem GhcRn ] + declWith avail pats = do + let t = availName avail + r <- findDecl avail case r of ([L l (ValD _)], (doc, _)) -> do -- Top-level binding without type signature @@ -667,15 +726,15 @@ mkExportItems -- fromJust is safe since we already checked in guards -- that 't' is a name declared in this declaration. let newDecl = L loc . SigD . fromJust $ filterSigNames (== t) sig - in return [ mkExportDecl t newDecl pats docs_ ] + in return [ mkExportDecl avail newDecl pats docs_ ] L loc (TyClD cl@ClassDecl{}) -> do mdef <- liftGhcToErrMsgGhc $ minimalDef t let sig = maybeToList $ fmap (noLoc . MinimalSig NoSourceText . noLoc . fmap noLoc) mdef - return [ mkExportDecl t + return [ mkExportDecl avail (L loc $ TyClD cl { tcdSigs = sig ++ tcdSigs cl }) pats docs_ ] - _ -> return [ mkExportDecl t decl pats docs_ ] + _ -> return [ mkExportDecl avail decl pats docs_ ] -- Declaration from another package ([], _) -> do @@ -692,33 +751,55 @@ mkExportItems liftErrMsg $ tell ["Warning: Couldn't find .haddock for export " ++ pretty dflags t] let subs_ = [ (n, noDocForDecl) | (n, _, _) <- subordinates instMap (unLoc decl) ] - return [ mkExportDecl t decl pats (noDocForDecl, subs_) ] + return [ mkExportDecl avail decl pats (noDocForDecl, subs_) ] Just iface -> - return [ mkExportDecl t decl pats (lookupDocs t warnings (instDocMap iface) (instArgMap iface) (instSubMap iface)) ] + return [ mkExportDecl avail decl pats (lookupDocs avail warnings (instDocMap iface) (instArgMap iface)) ] _ -> return [] - mkExportDecl :: Name -> LHsDecl GhcRn -> [(HsDecl GhcRn, DocForDecl Name)] + mkExportDecl :: AvailInfo -> LHsDecl GhcRn -> [(HsDecl GhcRn, DocForDecl Name)] -> (DocForDecl Name, [(Name, DocForDecl Name)]) -> ExportItem GhcRn - mkExportDecl name decl pats (doc, subs) = decl' + mkExportDecl avail decl pats (doc, subs) = + ExportDecl { + expItemDecl = restrictTo sub_names (extractDecl avail decl) + , expItemPats = pats' + , expItemMbDoc = doc + , expItemSubDocs = subs' + , expItemInstances = [] + , expItemFixities = fixities + , expItemSpliced = False + } where - decl' = ExportDecl (restrictTo sub_names (extractDecl name decl)) pats' doc subs' [] fixities False - subs' = filter (isExported . fst) subs - pats' = [ d | d@(patsyn_decl, _) <- pats - , all isExported (getMainDeclBinder patsyn_decl) ] + name = availName avail + -- all the exported names for this ExportItem + exported_names = availNamesWithSelectors avail + subs' = [ sub + | sub@(sub_name, _) <- subs + , sub_name `elem` exported_names + ] + pats' = [ patsyn + | patsyn@(patsyn_decl, _) <- pats + , all (`elem` exported_names) (getMainDeclBinder patsyn_decl) + ] sub_names = map fst subs' - pat_names = [ n | (patsyn_decl, _) <- pats', n <- getMainDeclBinder patsyn_decl] - fixities = [ (n, f) | n <- name:sub_names++pat_names, Just f <- [M.lookup n fixMap] ] + pat_names = [ n + | (patsyn_decl, _) <- pats' + , n <- getMainDeclBinder patsyn_decl + ] + fixities = [ (n, f) + | n <- name:sub_names ++ pat_names + , Just f <- [M.lookup n fixMap] + ] exportedNameSet = mkNameSet exportedNames isExported n = elemNameSet n exportedNameSet - findDecl :: Name -> ErrMsgGhc ([LHsDecl GhcRn], (DocForDecl Name, [(Name, DocForDecl Name)])) - findDecl n + findDecl :: AvailInfo -> ErrMsgGhc ([LHsDecl GhcRn], (DocForDecl Name, [(Name, DocForDecl Name)])) + findDecl avail | m == semMod = case M.lookup n declMap of - Just ds -> return (ds, lookupDocs n warnings docMap argMap subMap) + Just ds -> return (ds, lookupDocs avail warnings docMap argMap) Nothing | is_sig -> do -- OK, so it wasn't in the local declaration map. It could @@ -735,47 +816,31 @@ mkExportItems return ([], (noDocForDecl, [])) | Just iface <- M.lookup (semToIdMod (moduleUnitId thisMod) m) modMap , Just ds <- M.lookup n (ifaceDeclMap iface) = - return (ds, lookupDocs n warnings + return (ds, lookupDocs avail warnings (ifaceDocMap iface) - (ifaceArgMap iface) - (ifaceSubMap iface)) + (ifaceArgMap iface)) | otherwise = return ([], (noDocForDecl, [])) where + n = availName avail m = nameModule n - findBundledPatterns :: Name -> ErrMsgGhc [(HsDecl GhcRn, DocForDecl Name)] - findBundledPatterns t = - let - m = nameModule t - - local_bundled_patsyns = - M.findWithDefault [] t patSynMap - - iface_bundled_patsyns - | Just iface <- M.lookup (semToIdMod (moduleUnitId thisMod) m) modMap - , Just patsyns <- M.lookup t (ifaceBundledPatSynMap iface) - = patsyns - - | Just iface <- M.lookup m instIfaceMap - , Just patsyns <- M.lookup t (instBundledPatSynMap iface) - = patsyns - - | otherwise - = [] - - patsyn_decls = do - for (local_bundled_patsyns ++ iface_bundled_patsyns) $ \patsyn_name -> do - -- call declWith here so we don't have to prepare the pattern synonym for - -- showing ourselves. - export_items <- declWith [] patsyn_name + findBundledPatterns :: AvailInfo -> ErrMsgGhc [(HsDecl GhcRn, DocForDecl Name)] + findBundledPatterns avail = do + patsyns <- for constructor_names $ \name -> do + mtyThing <- liftGhcToErrMsgGhc (lookupName name) + case mtyThing of + Just (AConLike PatSynCon{}) -> do + export_items <- declWith (Avail.avail name) [] pure [ (unLoc patsyn_decl, patsyn_doc) | ExportDecl { expItemDecl = patsyn_decl , expItemMbDoc = patsyn_doc } <- export_items ] - - in concat <$> patsyn_decls + _ -> pure [] + pure (concat patsyns) + where + constructor_names = filter isDataConName (availNames avail) -- | Given a 'Module' from a 'Name', convert it into a 'Module' that -- we can actually find in the 'IfaceMap'. @@ -820,48 +885,29 @@ hiValExportItem dflags name nLoc doc splice fixity = do -- | Lookup docs for a declaration from maps. -lookupDocs :: Name -> WarningMap -> DocMap Name -> ArgMap Name -> SubMap +lookupDocs :: AvailInfo -> WarningMap -> DocMap Name -> ArgMap Name -> (DocForDecl Name, [(Name, DocForDecl Name)]) -lookupDocs n warnings docMap argMap subMap = +lookupDocs avail warnings docMap argMap = + let n = availName avail in let lookupArgDoc x = M.findWithDefault M.empty x argMap in let doc = (lookupDoc n, lookupArgDoc n) in - let subs = M.findWithDefault [] n subMap in - let subDocs = [ (s, (lookupDoc s, lookupArgDoc s)) | s <- subs ] in + let subDocs = [ (s, (lookupDoc s, lookupArgDoc s)) + | s <- availNamesWithSelectors avail + , s /= n ] in (doc, subDocs) where lookupDoc name = Documentation (M.lookup name docMap) (M.lookup name warnings) --- | Return all export items produced by an exported module. That is, we're --- interested in the exports produced by \"module B\" in such a scenario: --- --- > module A (module B) where --- > import B (...) hiding (...) --- --- There are three different cases to consider: --- --- 1) B is hidden, in which case we return all its exports that are in scope in A. --- 2) B is visible, but not all its exports are in scope in A, in which case we --- only return those that are. --- 3) B is visible and all its exports are in scope, in which case we return --- a single 'ExportModule' item. -moduleExports :: Module -- ^ Module A (identity, NOT semantic) - -> ModuleName -- ^ The real name of B, the exported module - -> DynFlags -- ^ The flags used when typechecking A - -> WarningMap - -> GlobalRdrEnv -- ^ The renaming environment used for A - -> [Name] -- ^ All the exports of A - -> [LHsDecl GhcRn] -- ^ All the renamed declarations in A - -> IfaceMap -- ^ Already created interfaces - -> InstIfaceMap -- ^ Interfaces in other packages - -> Maps - -> FixMap - -> [SrcSpan] -- ^ Locations of all TH splices - -> ErrMsgGhc [ExportItem GhcRn] -- ^ Resulting export items -moduleExports thisMod expMod dflags warnings gre _exports decls ifaceMap instIfaceMap maps fixMap splices - | expMod == moduleName thisMod - = fullModuleContents dflags warnings gre maps fixMap splices decls - | otherwise = +-- | Export the given module as `ExportModule`. We are not concerned with the +-- single export items of the given module. +moduleExport :: Module -- ^ Module A (identity, NOT semantic) + -> DynFlags -- ^ The flags used when typechecking A + -> IfaceMap -- ^ Already created interfaces + -> InstIfaceMap -- ^ Interfaces in other packages + -> ModuleName -- ^ The exported module + -> ErrMsgGhc [ExportItem GhcRn] -- ^ Resulting export items +moduleExport thisMod dflags ifaceMap instIfaceMap expMod = -- NB: we constructed the identity module when looking up in -- the IfaceMap. case M.lookup m ifaceMap of @@ -882,7 +928,6 @@ moduleExports thisMod expMod dflags warnings gre _exports decls ifaceMap instIfa m = mkModule unitId expMod -- Identity module! unitId = moduleUnitId thisMod - -- Note [1]: ------------ -- It is unnecessary to document a subordinate by itself at the top level if @@ -903,87 +948,35 @@ moduleExports thisMod expMod dflags warnings gre _exports decls ifaceMap instIfa -- | Simplified variant of 'mkExportItems', where we can assume that -- every locally defined declaration is exported; thus, we just -- zip through the renamed declarations. -fullModuleContents :: DynFlags + +fullModuleContents :: Bool -- is it a signature + -> IfaceMap + -> Module -- this module + -> Module -- semantic module -> WarningMap - -> GlobalRdrEnv -- ^ The renaming environment + -> [Name] -- exported names (orig) -> Maps -> FixMap - -> [SrcSpan] -- ^ Locations of all TH splices - -> [LHsDecl GhcRn] -- ^ All the renamed declarations + -> [SrcSpan] -- splice locations + -> InstIfaceMap + -> DynFlags + -> Avails -> ErrMsgGhc [ExportItem GhcRn] -fullModuleContents dflags warnings gre (docMap, argMap, subMap, declMap, instMap) fixMap splices decls = - liftM catMaybes $ mapM mkExportItem (expandSigDecls decls) - where - -- A type signature can have multiple names, like: - -- foo, bar :: Types.. - -- - -- We go through the list of declarations and expand type signatures, so - -- that every type signature has exactly one name! - expandSigDecls :: [LHsDecl name] -> [LHsDecl name] - expandSigDecls = concatMap f - where - f (L l (SigD sig)) = [ L l (SigD s) | s <- expandSig sig ] - - -- also expand type signatures for class methods - f (L l (TyClD cls@ClassDecl{})) = - [ L l (TyClD cls { tcdSigs = concatMap expandLSig (tcdSigs cls) }) ] - f x = [x] - - expandLSig :: LSig name -> [LSig name] - expandLSig (L l sig) = [ L l s | s <- expandSig sig ] - - expandSig :: Sig name -> [Sig name] - expandSig (TypeSig names t) = [ TypeSig [n] t | n <- names ] - expandSig (ClassOpSig b names t) = [ ClassOpSig b [n] t | n <- names ] - expandSig (PatSynSig names t) = [ PatSynSig [n] t | n <- names ] - expandSig x = [x] - - mkExportItem :: LHsDecl GhcRn -> ErrMsgGhc (Maybe (ExportItem GhcRn)) - mkExportItem (L _ (DocD (DocGroup lev docStr))) = do - doc <- liftErrMsg (processDocString dflags gre docStr) - return . Just . ExportGroup lev "" $ doc - mkExportItem (L _ (DocD (DocCommentNamed _ docStr))) = do - doc <- liftErrMsg (processDocStringParas dflags gre docStr) - return . Just . ExportDoc $ doc - mkExportItem (L l (ValD d)) - | name:_ <- collectHsBindBinders d, Just [L _ (ValD _)] <- M.lookup name declMap = - -- Top-level binding without type signature. - let (doc, _) = lookupDocs name warnings docMap argMap subMap in - fmap Just (hiValExportItem dflags name l doc (l `elem` splices) $ M.lookup name fixMap) - | otherwise = return Nothing - mkExportItem decl@(L l (InstD d)) - | Just name <- M.lookup (getInstLoc d) instMap = - expInst decl l name - mkExportItem decl@(L l (DerivD {})) - | Just name <- M.lookup l instMap = - expInst decl l name - mkExportItem (L l (TyClD cl@ClassDecl{ tcdLName = L _ name, tcdSigs = sigs })) = do - mdef <- liftGhcToErrMsgGhc $ minimalDef name - let sig = maybeToList $ fmap (noLoc . MinimalSig NoSourceText . noLoc . fmap noLoc) mdef - expDecl (L l (TyClD cl { tcdSigs = sig ++ sigs })) l name - mkExportItem decl@(L l d) - | name:_ <- getMainDeclBinder d = expDecl decl l name - | otherwise = return Nothing - - fixities name subs = [ (n,f) | n <- name : map fst subs - , Just f <- [M.lookup n fixMap] ] - - expDecl decl l name = return $ Just (ExportDecl decl [] doc subs [] (fixities name subs) (l `elem` splices)) - where (doc, subs) = lookupDocs name warnings docMap argMap subMap - - expInst decl l name = - let (doc, subs) = lookupDocs name warnings docMap argMap subMap in - return $ Just (ExportDecl decl [] doc subs [] (fixities name subs) (l `elem` splices)) +fullModuleContents is_sig modMap thisMod semMod warnings exportedNames + maps fixMap splices instIfaceMap dflags avails = + concat <$> traverse (availExportItem is_sig modMap thisMod + semMod warnings exportedNames maps fixMap + splices instIfaceMap dflags) avails -- | Sometimes the declaration we want to export is not the "main" declaration: -- it might be an individual record selector or a class method. In these -- cases we have to extract the required declaration (and somehow cobble -- together a type signature for it...). -extractDecl :: Name -> LHsDecl GhcRn -> LHsDecl GhcRn -extractDecl name decl - | name `elem` getMainDeclBinder (unLoc decl) = decl - | otherwise = +extractDecl :: AvailInfo -> LHsDecl GhcRn -> LHsDecl GhcRn +extractDecl avail decl + | availName avail `elem` getMainDeclBinder (unLoc decl) = decl + | [name] <- availNamesWithSelectors avail = case unLoc decl of TyClD d@ClassDecl {} -> let matches = [ lsig @@ -1021,9 +1014,10 @@ extractDecl name decl , selectorFieldOcc n == name ] in case matches of - [d0] -> extractDecl name (noLoc . InstD $ DataFamInstD d0) + [d0] -> extractDecl avail (noLoc . InstD $ DataFamInstD d0) _ -> error "internal: extractDecl (ClsInstD)" _ -> error "internal: extractDecl" + | otherwise = decl extractPatternSyn :: Name -> Name -> [LHsType GhcRn] -> [LConDecl GhcRn] -> LSig GhcRn extractPatternSyn nm t tvs cons = @@ -1082,7 +1076,7 @@ pruneExportItems = filter hasDoc mkVisibleNames :: Maps -> [ExportItem GhcRn] -> [DocOption] -> [Name] -mkVisibleNames (_, _, _, _, instMap) exports opts +mkVisibleNames (_, _, _, instMap) exports opts | OptHide `elem` opts = [] | otherwise = let ns = concatMap exportName exports in seqList ns `seq` ns diff --git a/haddock-api/src/Haddock/Interface/Json.hs b/haddock-api/src/Haddock/Interface/Json.hs index 9a569204..636d3e19 100644 --- a/haddock-api/src/Haddock/Interface/Json.hs +++ b/haddock-api/src/Haddock/Interface/Json.hs @@ -37,8 +37,6 @@ jsonInstalledInterface InstalledInterface{..} = jsonObject properties , ("exports" , jsonArray (map jsonName instExports)) , ("visible_exports" , jsonArray (map jsonName instVisibleExports)) , ("options" , jsonArray (map (jsonString . show) instOptions)) - , ("sub_map" , jsonMap nameStableString (jsonArray . map jsonName) instSubMap) - , ("bundled_patsyns" , jsonMap nameStableString (jsonArray . map jsonName) instBundledPatSynMap) , ("fix_map" , jsonMap nameStableString jsonFixity instFixMap) ] @@ -106,4 +104,3 @@ jsonInt = JSInt jsonBool :: Bool -> JsonDoc jsonBool = JSBool - diff --git a/haddock-api/src/Haddock/InterfaceFile.hs b/haddock-api/src/Haddock/InterfaceFile.hs index 3b1a5f33..59582fd2 100644 --- a/haddock-api/src/Haddock/InterfaceFile.hs +++ b/haddock-api/src/Haddock/InterfaceFile.hs @@ -83,7 +83,7 @@ binaryInterfaceMagic = 0xD0Cface -- binaryInterfaceVersion :: Word16 #if (__GLASGOW_HASKELL__ >= 803) && (__GLASGOW_HASKELL__ < 805) -binaryInterfaceVersion = 31 +binaryInterfaceVersion = 32 binaryInterfaceVersionCompatibility :: [Word16] binaryInterfaceVersionCompatibility = [binaryInterfaceVersion] @@ -373,7 +373,7 @@ instance Binary InterfaceFile where instance Binary InstalledInterface where put_ bh (InstalledInterface modu is_sig info docMap argMap - exps visExps opts subMap patSynMap fixMap) = do + exps visExps opts fixMap) = do put_ bh modu put_ bh is_sig put_ bh info @@ -381,8 +381,6 @@ instance Binary InstalledInterface where put_ bh exps put_ bh visExps put_ bh opts - put_ bh subMap - put_ bh patSynMap put_ bh fixMap get bh = do @@ -393,12 +391,9 @@ instance Binary InstalledInterface where exps <- get bh visExps <- get bh opts <- get bh - subMap <- get bh - patSynMap <- get bh fixMap <- get bh - return (InstalledInterface modu is_sig info docMap argMap - exps visExps opts subMap patSynMap fixMap) + exps visExps opts fixMap) instance Binary DocOption where diff --git a/haddock-api/src/Haddock/Types.hs b/haddock-api/src/Haddock/Types.hs index 3ad90912..188611a0 100644 --- a/haddock-api/src/Haddock/Types.hs +++ b/haddock-api/src/Haddock/Types.hs @@ -101,9 +101,6 @@ data Interface = Interface -- names of subordinate declarations mapped to their parent declarations. , ifaceDeclMap :: !(Map Name [LHsDecl GhcRn]) - -- | Bundled pattern synonym declarations for specific types. - , ifaceBundledPatSynMap :: !(Map Name [Name]) - -- | Documentation of declarations originating from the module (including -- subordinates). , ifaceDocMap :: !(DocMap Name) @@ -114,7 +111,6 @@ data Interface = Interface , ifaceRnDocMap :: !(DocMap DocName) , ifaceRnArgMap :: !(ArgMap DocName) - , ifaceSubMap :: !(Map Name [Name]) , ifaceFixMap :: !(Map Name Fixity) , ifaceExportItems :: ![ExportItem GhcRn] @@ -184,10 +180,6 @@ data InstalledInterface = InstalledInterface -- | Haddock options for this module (prune, ignore-exports, etc). , instOptions :: [DocOption] - , instSubMap :: Map Name [Name] - - , instBundledPatSynMap :: Map Name [Name] - , instFixMap :: Map Name Fixity } @@ -203,8 +195,6 @@ toInstalledIface interface = InstalledInterface , instExports = ifaceExports interface , instVisibleExports = ifaceVisibleExports interface , instOptions = ifaceOptions interface - , instSubMap = ifaceSubMap interface - , instBundledPatSynMap = ifaceBundledPatSynMap interface , instFixMap = ifaceFixMap interface } -- cgit v1.2.3