Follow changes in GHC

5 files changed, 41 insertions, 38 deletions

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