From 1b774aef07ad33b667fbf33e01c2dc9ed0e039f4 Mon Sep 17 00:00:00 2001 From: Ian Lynagh Date: Tue, 12 Jun 2012 18:52:16 +0100 Subject: Follow changes in GHC --- src/Haddock/GhcUtils.hs | 8 ++++---- src/Haddock/Interface.hs | 4 +++- src/Haddock/Interface/Create.hs | 36 ++++++++++++++++++------------------ src/Haddock/Interface/LexParseRn.hs | 25 +++++++++++++------------ src/Haddock/Interface/Rename.hs | 6 +++--- 5 files changed, 41 insertions(+), 38 deletions(-) (limited to 'src/Haddock') diff --git a/src/Haddock/GhcUtils.hs b/src/Haddock/GhcUtils.hs index c38bf9e5..a841e567 100644 --- a/src/Haddock/GhcUtils.hs +++ b/src/Haddock/GhcUtils.hs @@ -151,12 +151,12 @@ declATs (TyClD d) | isClassDecl d = map (tcdName . unL) $ tcdATs d declATs _ = [] -pretty :: Outputable a => a -> String -pretty x = showSDoc (ppr x) +pretty :: Outputable a => DynFlags -> a -> String +pretty = showPpr -trace_ppr :: Outputable a => a -> b -> b -trace_ppr x y = trace (pretty x) y +trace_ppr :: Outputable a => DynFlags -> a -> b -> b +trace_ppr dflags x y = trace (pretty dflags x) y ------------------------------------------------------------------------------- diff --git a/src/Haddock/Interface.hs b/src/Haddock/Interface.hs index 09f01883..dcd794af 100644 --- a/src/Haddock/Interface.hs +++ b/src/Haddock/Interface.hs @@ -49,6 +49,7 @@ import System.FilePath import Text.Printf import Digraph +import DynFlags hiding (verbosity, flags) import Exception import GHC hiding (verbosity, flags) import HscTypes @@ -83,8 +84,9 @@ processModules verbosity modules flags extIfaces = do out verbosity verbose "Renaming interfaces..." let warnings = Flag_NoWarnings `notElem` flags + dflags <- getDynFlags let (interfaces'', msgs) = - runWriter $ mapM (renameInterface links warnings) interfaces' + runWriter $ mapM (renameInterface dflags links warnings) interfaces' liftIO $ mapM_ putStrLn msgs return (interfaces'', homeLinks) diff --git a/src/Haddock/Interface/Create.hs b/src/Haddock/Interface/Create.hs index 9db2dc69..6c35a12c 100644 --- a/src/Haddock/Interface/Create.hs +++ b/src/Haddock/Interface/Create.hs @@ -83,7 +83,7 @@ createInterface tm flags modMap instIfaceMap = do | OptIgnoreExports `elem` opts = Nothing | otherwise = exports0 - liftErrMsg $ warnAboutFilteredDecls mdl decls + liftErrMsg $ warnAboutFilteredDecls dflags mdl decls exportItems <- mkExportItems modMap mdl gre exportedNames decls maps exports instances instIfaceMap dflags @@ -292,8 +292,8 @@ 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 [ unLoc (fid_tycon d) | L _ (InstD (FamInstD { lid_inst = d })) <- decls ] @@ -305,7 +305,7 @@ warnAboutFilteredDecls mdl decls = do ++ "will be filtered out:\n " ++ concat (intersperse ", " $ map (occNameString . nameOccName) typeInstances) ] - let instances = nub [ pretty i | L _ (InstD (ClsInstD { cid_poly_ty = i, cid_fam_insts = 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) $ @@ -437,7 +437,7 @@ mkExportItems case findDecl t of [L _ (ValD _)] -> do -- Top-level binding without type signature - export <- hiValExportItem t doc + export <- hiValExportItem dflags t doc return [export] ds | decl : _ <- filter (not . isValD . unLoc) ds -> let declNames = getMainDeclBinder (unL decl) @@ -454,8 +454,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 [] @@ -476,7 +476,7 @@ mkExportItems -- Declaration from another package [] -> do - mayDecl <- hiDecl t + mayDecl <- hiDecl dflags t case mayDecl of Nothing -> return [ ExportNoDecl t [] ] Just decl -> do @@ -485,7 +485,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 -> do @@ -515,19 +515,19 @@ mkExportItems mdl = nameModule name -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 [] []) @@ -578,8 +578,8 @@ moduleExports thisMod expMod dflags gre _exports decls ifaceMap instIfaceMap map 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 @@ -617,7 +617,7 @@ fullModuleContents dflags gre (docMap, argMap, subMap, declMap) decls = | name:_ <- collectHsBindBinders d, Just [L _ (ValD _)] <- M.lookup name declMap = -- Top-level binding without type signature. let (doc, _) = exportDecl name docMap argMap subMap in - fmap Just (hiValExportItem name doc) + fmap Just (hiValExportItem dflags name doc) | otherwise = return Nothing mkExportItem decl | name:_ <- getMainDeclBinder (unLoc decl) = diff --git a/src/Haddock/Interface/LexParseRn.hs b/src/Haddock/Interface/LexParseRn.hs index 0871c560..c13e57be 100644 --- a/src/Haddock/Interface/LexParseRn.hs +++ b/src/Haddock/Interface/LexParseRn.hs @@ -58,7 +58,7 @@ lexParseRnHaddockComment dflags hty gre (HsDocString fs) = do Nothing -> do tell ["doc comment parse failed: "++str] return Nothing - Just doc -> return (Just (rename gre doc)) + Just doc -> return (Just (rename dflags gre doc)) lexParseRnMbHaddockComment :: DynFlags -> HaddockCommentType -> GlobalRdrEnv -> Maybe HsDocString -> ErrMsgM (Maybe (Doc Name)) @@ -79,18 +79,18 @@ lexParseRnHaddockModHeader dflags gre safety mbStr = do Left mess -> do tell ["haddock module header parse failed: " ++ mess] return failure - Right (info, doc) -> return (renameHmi gre info, Just (rename gre doc)) + Right (info, doc) -> return (renameHmi dflags gre info, Just (rename dflags gre doc)) return (hmi { hmi_safety = Just $ showPpr dflags safety }, docn) where failure = (emptyHaddockModInfo, Nothing) -renameHmi :: GlobalRdrEnv -> HaddockModInfo RdrName -> HaddockModInfo Name -renameHmi gre hmi = hmi { hmi_description = rename gre <$> hmi_description hmi } +renameHmi :: DynFlags -> GlobalRdrEnv -> HaddockModInfo RdrName -> HaddockModInfo Name +renameHmi dflags gre hmi = hmi { hmi_description = rename dflags gre <$> hmi_description hmi } -rename :: GlobalRdrEnv -> Doc RdrName -> Doc Name -rename gre = rn +rename :: DynFlags -> GlobalRdrEnv -> Doc RdrName -> Doc Name +rename dflags gre = rn where rn d = case d of DocAppend a b -> DocAppend (rn a) (rn b) @@ -101,9 +101,10 @@ rename gre = rn case names of [] -> case choices of - [] -> DocMonospaced (DocString (showSDoc $ ppr x)) - [a] -> outOfScope a - a:b:_ | isRdrTc a -> outOfScope a | otherwise -> outOfScope b + [] -> DocMonospaced (DocString (showPpr dflags x)) + [a] -> outOfScope dflags a + a:b:_ | isRdrTc a -> outOfScope dflags a + | otherwise -> outOfScope dflags b [a] -> DocIdentifier a a:b:_ | isTyConName a -> DocIdentifier a | otherwise -> DocIdentifier b -- If an id can refer to multiple things, we give precedence to type @@ -124,12 +125,12 @@ rename gre = rn DocString str -> DocString str -outOfScope :: RdrName -> Doc a -outOfScope x = +outOfScope :: DynFlags -> RdrName -> Doc a +outOfScope dflags x = case x of Unqual occ -> monospaced occ Qual mdl occ -> DocIdentifierUnchecked (mdl, occ) Orig _ occ -> monospaced occ Exact name -> monospaced name -- Shouldn't happen since x is out of scope where - monospaced a = DocMonospaced (DocString (showSDoc $ ppr a)) + monospaced a = DocMonospaced (DocString (showPpr dflags a)) diff --git a/src/Haddock/Interface/Rename.hs b/src/Haddock/Interface/Rename.hs index 0912d954..b762bcbb 100644 --- a/src/Haddock/Interface/Rename.hs +++ b/src/Haddock/Interface/Rename.hs @@ -27,8 +27,8 @@ import Data.Traversable (mapM) import Control.Monad hiding (mapM) -renameInterface :: LinkEnv -> Bool -> Interface -> ErrMsgM Interface -renameInterface renamingEnv warnings iface = +renameInterface :: DynFlags -> LinkEnv -> Bool -> Interface -> ErrMsgM Interface +renameInterface dflags renamingEnv warnings iface = -- first create the local env, where every name exported by this module -- is mapped to itself, and everything else comes from the global renaming @@ -57,7 +57,7 @@ renameInterface renamingEnv warnings iface = -- representation. TODO: use the Name constants from the GHC API. -- strings = filter (`notElem` ["()", "[]", "(->)"]) -- (map pretty missingNames) - strings = map pretty . filter (\n -> not (isSystemName n || isBuiltInSyntax n)) $ missingNames + strings = map (pretty dflags) . filter (\n -> not (isSystemName n || isBuiltInSyntax n)) $ missingNames in do -- report things that we couldn't link to. Only do this for non-hidden -- cgit v1.2.3