diff options
Diffstat (limited to 'src/Haddock/Interface/Create.hs')
| -rw-r--r-- | src/Haddock/Interface/Create.hs | 58 |
1 files changed, 28 insertions, 30 deletions
diff --git a/src/Haddock/Interface/Create.hs b/src/Haddock/Interface/Create.hs index 50f468db..4bb46cba 100644 --- a/src/Haddock/Interface/Create.hs +++ b/src/Haddock/Interface/Create.hs @@ -86,7 +86,7 @@ createInterface tm flags modMap instIfaceMap = do | OptIgnoreExports `elem` opts = Nothing | otherwise = exports0 - liftErrMsg $ warnAboutFilteredDecls mdl decls + liftErrMsg $ warnAboutFilteredDecls dflags mdl decls let warningMap = mkWarningMap warnings gre exportedNames exportItems <- mkExportItems modMap mdl warningMap gre exportedNames decls maps exports @@ -224,13 +224,12 @@ parseOption other = tell ["Unrecognised option: " ++ other] >> return Nothing type Maps = (DocMap Name, ArgMap Name, SubMap, DeclMap) - -- | Create 'Maps' by looping through the declarations. For each declaration, -- find its names, its subordinates, and its doc strings. Process doc strings -- into 'Doc's. mkMaps :: DynFlags -> GlobalRdrEnv - -> [Instance] + -> [ClsInst] -> [(LHsDecl Name, [HsDocString])] -> ErrMsgM Maps mkMaps dflags gre instances decls = do @@ -261,16 +260,15 @@ mkMaps dflags gre instances decls = do instanceMap = M.fromList [ (getSrcSpan n, n) | i <- instances, let n = getName i ] names :: HsDecl Name -> [Name] - names (InstD (InstDecl (L l _) _ _ _)) = maybeToList (M.lookup l instanceMap) -- See note [2]. + names (InstD (ClsInstD { cid_poly_ty = L l _ })) = maybeToList (M.lookup l instanceMap) -- See note [2]. names decl = getMainDeclBinder decl - -- Note [2]: ------------ --- We relate Instances to InstDecls using the SrcSpans buried inside them. +-- We relate ClsInsts to InstDecls using the SrcSpans buried inside them. -- That should work for normal user-written instances (from looking at GHC -- sources). We can assume that commented instances are user-written. --- This lets us relate Names (from Instances) to comments (associated +-- This lets us relate Names (from ClsInsts) to comments (associated -- with InstDecls). @@ -290,7 +288,7 @@ subordinates (TyClD decl) ] dataSubs = constrs ++ fields where - cons = map unL $ tcdCons decl + cons = map unL $ (td_cons (tcdTyDefn decl)) constrs = [ (unL $ con_name c, maybeToList $ fmap unL $ con_doc c, M.empty) | c <- cons ] fields = [ (unL n, maybeToList $ fmap unL doc, M.empty) @@ -306,7 +304,7 @@ typeDocs d = case d of SigD (TypeSig _ ty) -> docs (unLoc ty) ForD (ForeignImport _ ty _ _) -> docs (unLoc ty) - TyClD (TySynonym {tcdSynRhs = ty}) -> docs (unLoc ty) + TyClD (TyDecl { tcdTyDefn = TySynonym {td_synRhs = ty}}) -> docs (unLoc ty) _ -> M.empty where go n (HsForAllTy _ _ _ ty) = go n (unLoc ty) @@ -364,11 +362,11 @@ sortByLoc :: [Located a] -> [Located a] sortByLoc = sortBy (comparing getLoc) -warnAboutFilteredDecls :: Module -> [LHsDecl Name] -> ErrMsgM () -warnAboutFilteredDecls mdl decls = do +warnAboutFilteredDecls :: DynFlags -> Module -> [LHsDecl Name] -> ErrMsgM () +warnAboutFilteredDecls dflags mdl decls = do let modStr = moduleString mdl let typeInstances = - nub [ tcdName d | L _ (TyClD d) <- decls, isFamInstDecl d ] + nub [ unLoc (fid_tycon d) | L _ (InstD (FamInstD { lid_inst = d })) <- decls ] unless (null typeInstances) $ tell [ @@ -377,7 +375,7 @@ warnAboutFilteredDecls mdl decls = do ++ "will be filtered out:\n " ++ (intercalate ", " $ map (occNameString . nameOccName) typeInstances) ] - let instances = nub [ pretty i | L _ (InstD (InstDecl i _ _ ats)) <- decls + let instances = nub [ pretty dflags i | L _ (InstD (ClsInstD { cid_poly_ty = i, cid_fam_insts = ats })) <- decls , not (null ats) ] unless (null instances) $ @@ -457,7 +455,7 @@ mkExportItems -> [LHsDecl Name] -> Maps -> Maybe [IE Name] - -> [Instance] + -> [ClsInst] -> InstIfaceMap -> DynFlags -> ErrMsgGhc [ExportItem Name] @@ -501,7 +499,7 @@ mkExportItems case findDecl t of ([L _ (ValD _)], (doc, _)) -> do -- Top-level binding without type signature - export <- hiValExportItem t doc + export <- hiValExportItem dflags t doc return [export] (ds, docs_) | decl : _ <- filter (not . isValD . unLoc) ds -> let declNames = getMainDeclBinder (unL decl) @@ -518,8 +516,8 @@ mkExportItems Just p <- find isExported (parents t $ unL decl) -> do liftErrMsg $ tell [ "Warning: " ++ moduleString thisMod ++ ": " ++ - pretty (nameOccName t) ++ " is exported separately but " ++ - "will be documented under " ++ pretty (nameOccName p) ++ + pretty dflags (nameOccName t) ++ " is exported separately but " ++ + "will be documented under " ++ pretty dflags (nameOccName p) ++ ". Consider exporting it together with its parent(s)" ++ " for code clarity." ] return [] @@ -539,7 +537,7 @@ mkExportItems -- Declaration from another package ([], _) -> do - mayDecl <- hiDecl t + mayDecl <- hiDecl dflags t case mayDecl of Nothing -> return [ ExportNoDecl t [] ] Just decl -> @@ -548,7 +546,7 @@ mkExportItems case M.lookup (nameModule t) instIfaceMap of Nothing -> do liftErrMsg $ tell - ["Warning: Couldn't find .haddock for export " ++ pretty t] + ["Warning: Couldn't find .haddock for export " ++ pretty dflags t] let subs_ = [ (n, noDocForDecl) | (n, _, _) <- subordinates (unLoc decl) ] return [ mkExportDecl t decl (noDocForDecl, subs_) ] Just iface -> @@ -580,19 +578,19 @@ mkExportItems m = nameModule n -hiDecl :: Name -> ErrMsgGhc (Maybe (LHsDecl Name)) -hiDecl t = do +hiDecl :: DynFlags -> Name -> ErrMsgGhc (Maybe (LHsDecl Name)) +hiDecl dflags t = do mayTyThing <- liftGhcToErrMsgGhc $ lookupName t case mayTyThing of Nothing -> do - liftErrMsg $ tell ["Warning: Not found in environment: " ++ pretty t] + liftErrMsg $ tell ["Warning: Not found in environment: " ++ pretty dflags t] return Nothing Just x -> return (Just (tyThingToLHsDecl x)) -hiValExportItem :: Name -> DocForDecl Name -> ErrMsgGhc (ExportItem Name) -hiValExportItem name doc = do - mayDecl <- hiDecl name +hiValExportItem :: DynFlags -> Name -> DocForDecl Name -> ErrMsgGhc (ExportItem Name) +hiValExportItem dflags name doc = do + mayDecl <- hiDecl dflags name case mayDecl of Nothing -> return (ExportNoDecl name []) Just decl -> return (ExportDecl decl doc [] []) @@ -648,8 +646,8 @@ moduleExports thisMod expMod dflags warnings gre _exports decls ifaceMap instIfa Just iface -> return [ ExportModule (instMod iface) ] Nothing -> do liftErrMsg $ - tell ["Warning: " ++ pretty thisMod ++ ": Could not find " ++ - "documentation for exported module: " ++ pretty expMod] + tell ["Warning: " ++ pretty dflags thisMod ++ ": Could not find " ++ + "documentation for exported module: " ++ pretty dflags expMod] return [] where m = mkModule packageId expMod @@ -700,7 +698,7 @@ fullModuleContents dflags warnings gre (docMap, argMap, subMap, declMap) decls = | 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 name doc) + fmap Just (hiValExportItem dflags name doc) | otherwise = return Nothing mkExportItem decl | name:_ <- getMainDeclBinder (unLoc decl) = @@ -728,7 +726,7 @@ extractDecl name mdl decl _ -> error "internal: extractDecl" TyClD d | isDataDecl d -> let (n, tyvar_names) = name_and_tyvars d - L pos sig = extractRecSel name mdl n tyvar_names (tcdCons d) + L pos sig = extractRecSel name mdl n tyvar_names (td_cons (tcdTyDefn d)) in L pos (SigD sig) _ -> error "internal: extractDecl" where @@ -743,7 +741,7 @@ extractClassDecl :: Name -> [Located Name] -> LSig Name -> LSig Name extractClassDecl c tvs0 (L pos (TypeSig lname ltype)) = case ltype of L _ (HsForAllTy expl tvs (L _ preds) ty) -> L pos (TypeSig lname (noLoc (HsForAllTy expl tvs (lctxt preds) ty))) - _ -> L pos (TypeSig lname (noLoc (mkImplicitHsForAllTy (lctxt []) ltype))) + _ -> L pos (TypeSig lname (noLoc (HsForAllTy Implicit emptyHsQTvs (lctxt []) ltype))) where lctxt = noLoc . ctxt ctxt preds = nlHsTyConApp c (map toTypeNoLoc tvs0) : preds |