Follow changes in GHC

3 files changed, 91 insertions, 86 deletions

diff --git a/src/Haddock/Backends/Hoogle.hs b/src/Haddock/Backends/Hoogle.hs
index 78e81d11..9c5d57c3 100644
--- a/src/Haddock/Backends/Hoogle.hs
+++ b/src/Haddock/Backends/Hoogle.hs
@@ -34,24 +34,25 @@ prefix = ["-- Hoogle documentation, generated by Haddock"
          ,""]
 
 
-ppHoogle :: String -> String -> String -> Maybe (Doc RdrName) -> [Interface] -> FilePath -> IO ()
-ppHoogle package version synopsis prologue ifaces odir = do
+ppHoogle :: DynFlags -> String -> String -> String -> Maybe (Doc RdrName) -> [Interface] -> FilePath -> IO ()
+ppHoogle dflags package version synopsis prologue ifaces odir = do
     let filename = package ++ ".txt"
         contents = prefix ++
-                   docWith (drop 2 $ dropWhile (/= ':') synopsis) prologue ++
+                   docWith dflags (drop 2 $ dropWhile (/= ':') synopsis) prologue ++
                    ["@package " ++ package] ++
                    ["@version " ++ version | version /= ""] ++
-                   concat [ppModule i | i <- ifaces, OptHide `notElem` ifaceOptions i]
+                   concat [ppModule dflags i | i <- ifaces, OptHide `notElem` ifaceOptions i]
     h <- openFile (odir </> filename) WriteMode
     hSetEncoding h utf8
     hPutStr h (unlines contents)
     hClose h
 
-ppModule :: Interface -> [String]
-ppModule iface = "" : doc (ifaceDoc iface) ++
+ppModule :: DynFlags -> Interface -> [String]
+ppModule dflags iface
+               = "" : doc dflags (ifaceDoc iface) ++
                  ["module " ++ moduleString (ifaceMod iface)] ++
-                 concatMap ppExport (ifaceExportItems iface) ++
-                 concatMap ppInstance (ifaceInstances iface)
+                 concatMap (ppExport dflags) (ifaceExportItems iface) ++
+                 concatMap (ppInstance dflags) (ifaceInstances iface)
 
 
 ---------------------------------------------------------------------
@@ -74,8 +75,8 @@ dropHsDocTy = f
         f (HsDocTy a _) = f $ unL a
         f x = x
 
-outHsType :: OutputableBndr a => HsType a -> String
-outHsType = out . dropHsDocTy
+outHsType :: OutputableBndr a => DynFlags -> HsType a -> String
+outHsType dflags = out dflags . dropHsDocTy
 
 
 makeExplicit :: HsType a -> HsType a
@@ -92,8 +93,8 @@ dropComment (x:xs) = x : dropComment xs
 dropComment [] = []
 
 
-out :: Outputable a => a -> String
-out = f . unwords . map (dropWhile isSpace) . lines . showSDocUnqual . ppr
+out :: Outputable a => DynFlags -> a -> String
+out dflags = f . unwords . map (dropWhile isSpace) . lines . showSDocUnqual dflags . ppr
     where
         f xs | " <document comment>" `isPrefixOf` xs = f $ drop 19 xs
         f (x:xs) = x : f xs
@@ -108,34 +109,35 @@ operator x = x
 ---------------------------------------------------------------------
 -- How to print each export
 
-ppExport :: ExportItem Name -> [String]
-ppExport (ExportDecl decl dc subdocs _) = doc (fst dc) ++ f (unL decl)
+ppExport :: DynFlags -> ExportItem Name -> [String]
+ppExport dflags (ExportDecl decl dc subdocs _) = doc dflags (fst dc) ++ f (unL decl)
     where
         f (TyClD d@TyDecl{})
-            | isDataDecl d      = ppData d subdocs
-            | otherwise         = ppSynonym d
-        f (TyClD d@ClassDecl{}) = ppClass d
-        f (ForD (ForeignImport name typ _ _)) = ppSig $ TypeSig [name] typ
-        f (ForD (ForeignExport name typ _ _)) = ppSig $ TypeSig [name] typ
-        f (SigD sig) = ppSig sig
+            | isDataDecl d      = ppData dflags d subdocs
+            | otherwise         = ppSynonym dflags d
+        f (TyClD d@ClassDecl{}) = ppClass dflags d
+        f (ForD (ForeignImport name typ _ _)) = ppSig dflags $ TypeSig [name] typ
+        f (ForD (ForeignExport name typ _ _)) = ppSig dflags $ TypeSig [name] typ
+        f (SigD sig) = ppSig dflags sig
         f _ = []
-ppExport _ = []
+ppExport _ _ = []
 
 
-ppSig :: Sig Name -> [String]
-ppSig (TypeSig names sig) = [operator prettyNames ++ " :: " ++ outHsType typ]
+ppSig :: DynFlags -> Sig Name -> [String]
+ppSig dflags (TypeSig names sig)
+    = [operator prettyNames ++ " :: " ++ outHsType dflags typ]
     where
-        prettyNames = concat . intersperse ", " $ map out names
+        prettyNames = concat . intersperse ", " $ map (out dflags) names
         typ = case unL sig of
                    HsForAllTy Explicit a b c -> HsForAllTy Implicit a b c
                    x -> x
-ppSig _ = []
+ppSig _ _ = []
 
 
 -- note: does not yet output documentation for class methods
-ppClass :: TyClDecl Name -> [String]
-ppClass x = out x{tcdSigs=[]} :
-            concatMap (ppSig . addContext . unL) (tcdSigs x)
+ppClass :: DynFlags -> TyClDecl Name -> [String]
+ppClass dflags x = out dflags x{tcdSigs=[]} :
+            concatMap (ppSig dflags . addContext . unL) (tcdSigs x)
     where
         addContext (TypeSig name (L l sig)) = TypeSig name (L l $ f sig)
         addContext _ = error "expected TypeSig"
@@ -147,27 +149,27 @@ ppClass x = out x{tcdSigs=[]} :
             (map (reL . HsTyVar . hsTyVarName . unL) (hsQTvBndrs (tcdTyVars x)))
 
 
-ppInstance :: ClsInst -> [String]
-ppInstance x = [dropComment $ out x]
+ppInstance :: DynFlags -> ClsInst -> [String]
+ppInstance dflags x = [dropComment $ out dflags x]
 
 
-ppSynonym :: TyClDecl Name -> [String]
-ppSynonym x = [out x]
+ppSynonym :: DynFlags -> TyClDecl Name -> [String]
+ppSynonym dflags x = [out dflags x]
 
-ppData :: TyClDecl Name -> [(Name, DocForDecl Name)] -> [String]
-ppData decl@(TyDecl { tcdTyDefn = defn }) subdocs
+ppData :: DynFlags -> TyClDecl Name -> [(Name, DocForDecl Name)] -> [String]
+ppData dflags decl@(TyDecl { tcdTyDefn = defn }) subdocs
     = showData decl{ tcdTyDefn = defn { td_cons=[],td_derivs=Nothing }} :
-      concatMap (ppCtor decl subdocs . unL) (td_cons defn)
+      concatMap (ppCtor dflags decl subdocs . unL) (td_cons defn)
     where
         
         -- GHC gives out "data Bar =", we want to delete the equals
         -- also writes data : a b, when we want data (:) a b
         showData d = unwords $ map f $ if last xs == "=" then init xs else xs
             where
-                xs = words $ out d
-                nam = out $ tcdLName d
+                xs = words $ out dflags d
+                nam = out dflags $ tcdLName d
                 f w = if w == nam then operator nam else w
-ppData _ _ = panic "ppData"
+ppData _ _ _ = panic "ppData"
 
 -- | for constructors, and named-fields...
 lookupCon :: [(Name, DocForDecl Name)] -> Located Name -> Maybe (Doc Name)
@@ -175,22 +177,22 @@ lookupCon subdocs (L _ name) = case lookup name subdocs of
   Just (d, _) -> d
   _ -> Nothing
 
-ppCtor :: TyClDecl Name -> [(Name, DocForDecl Name)] -> ConDecl Name -> [String]
-ppCtor dat subdocs con = doc (lookupCon subdocs (con_name con))
+ppCtor :: DynFlags -> TyClDecl Name -> [(Name, DocForDecl Name)] -> ConDecl Name -> [String]
+ppCtor dflags dat subdocs con = doc dflags (lookupCon subdocs (con_name con))
                          ++ f (con_details con)
     where
         f (PrefixCon args) = [typeSig name $ args ++ [resType]]
         f (InfixCon a1 a2) = f $ PrefixCon [a1,a2]
         f (RecCon recs) = f (PrefixCon $ map cd_fld_type recs) ++ concat
-                          [doc (lookupCon subdocs (cd_fld_name r)) ++
-                           [out (unL $ cd_fld_name r) `typeSig` [resType, cd_fld_type r]]
+                          [doc dflags (lookupCon subdocs (cd_fld_name r)) ++
+                           [out dflags (unL $ cd_fld_name r) `typeSig` [resType, cd_fld_type r]]
                           | r <- recs]
 
         funs = foldr1 (\x y -> reL $ HsFunTy (makeExplicitL x) (makeExplicitL y))
         apps = foldl1 (\x y -> reL $ HsAppTy x y)
 
-        typeSig nm flds = operator nm ++ " :: " ++ outHsType (makeExplicit $ unL $ funs flds)
-        name = out $ unL $ con_name con
+        typeSig nm flds = operator nm ++ " :: " ++ outHsType dflags (makeExplicit $ unL $ funs flds)
+        name = out dflags $ unL $ con_name con
 
         resType = case con_res con of
             ResTyH98 -> apps $ map (reL . HsTyVar) $ 
@@ -201,15 +203,16 @@ ppCtor dat subdocs con = doc (lookupCon subdocs (con_name con))
 ---------------------------------------------------------------------
 -- DOCUMENTATION
 
-doc :: Outputable o => Maybe (Doc o) -> [String]
-doc = docWith ""
+doc :: Outputable o => DynFlags -> Maybe (Doc o) -> [String]
+doc dflags = docWith dflags ""
 
 
-docWith :: Outputable o => String -> Maybe (Doc o) -> [String]
-docWith [] Nothing = []
-docWith header d = ("":) $ zipWith (++) ("-- | " : repeat "--   ") $
+docWith :: Outputable o => DynFlags -> String -> Maybe (Doc o) -> [String]
+docWith _ [] Nothing = []
+docWith dflags header d
+  = ("":) $ zipWith (++) ("-- | " : repeat "--   ") $
     [header | header /= ""] ++ ["" | header /= "" && isJust d] ++
-    maybe [] (showTags . markup markupTag) d
+    maybe [] (showTags . markup (markupTag dflags)) d
 
 
 data Tag = TagL Char [Tags] | TagP Tags | TagPre Tags | TagInline String Tags | Str String
@@ -230,14 +233,14 @@ str a = [Str a]
 -- or inlne for others (a,i,tt)
 -- entities (&,>,<) should always be appropriately escaped
 
-markupTag :: Outputable o => DocMarkup o [Tag]
-markupTag = Markup {
+markupTag :: Outputable o => DynFlags -> DocMarkup o [Tag]
+markupTag dflags = Markup {
   markupParagraph            = box TagP,
   markupEmpty                = str "",
   markupString               = str,
   markupAppend               = (++),
-  markupIdentifier           = box (TagInline "a") . str . out,
-  markupIdentifierUnchecked  = box (TagInline "a") . str . out . snd,
+  markupIdentifier           = box (TagInline "a") . str . out dflags,
+  markupIdentifierUnchecked  = box (TagInline "a") . str . out dflags . snd,
   markupModule               = box (TagInline "a") . str,
   markupEmphasis             = box (TagInline "i"),
   markupMonospaced           = box (TagInline "tt"),
diff --git a/src/Haddock/Interface/LexParseRn.hs b/src/Haddock/Interface/LexParseRn.hs
index 27a52ea2..0871c560 100644
--- a/src/Haddock/Interface/LexParseRn.hs
+++ b/src/Haddock/Interface/LexParseRn.hs
@@ -80,7 +80,7 @@ lexParseRnHaddockModHeader dflags gre safety mbStr = do
             tell ["haddock module header parse failed: " ++ mess]
             return failure
           Right (info, doc) -> return (renameHmi gre info, Just (rename gre doc))
-  return (hmi { hmi_safety = Just $ showPpr safety }, docn)
+  return (hmi { hmi_safety = Just $ showPpr dflags safety }, docn)
   where
     failure = (emptyHaddockModInfo, Nothing)
 
diff --git a/src/Main.hs b/src/Main.hs
index 0a3c9ffc..b80c0e96 100644
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -130,31 +130,6 @@ main = handleTopExceptions $ do
   (flags, files) <- parseHaddockOpts args
   shortcutFlags flags
 
-  if not (null files) then do
-    (packages, ifaces, homeLinks) <- readPackagesAndProcessModules flags files
-
-    -- Dump an "interface file" (.haddock file), if requested.
-    case optDumpInterfaceFile flags of
-      Just f -> dumpInterfaceFile f (map toInstalledIface ifaces) homeLinks
-      Nothing -> return ()
-
-    -- Render the interfaces.
-    renderStep flags packages ifaces
-
-  else do
-    when (any (`elem` [Flag_Html, Flag_Hoogle, Flag_LaTeX]) flags) $
-      throwE "No input file(s)."
-
-    -- Get packages supplied with --read-interface.
-    packages <- readInterfaceFiles freshNameCache (readIfaceArgs flags)
-
-    -- Render even though there are no input files (usually contents/index).
-    renderStep flags packages []
-
-
-readPackagesAndProcessModules :: [Flag] -> [String]
-                              -> IO ([(DocPaths, InterfaceFile)], [Interface], LinkEnv)
-readPackagesAndProcessModules flags files = do
   libDir <- fmap snd (getGhcDirs flags)
 
   -- Catches all GHC source errors, then prints and re-throws them.
@@ -165,6 +140,33 @@ readPackagesAndProcessModules flags files = do
   -- Initialize GHC.
   withGhc libDir (ghcFlags flags) $ \_ -> handleSrcErrors $ do
 
+    dflags <- getDynFlags
+
+    if not (null files) then do
+      (packages, ifaces, homeLinks) <- readPackagesAndProcessModules flags files
+
+      -- Dump an "interface file" (.haddock file), if requested.
+      case optDumpInterfaceFile flags of
+        Just f -> liftIO $ dumpInterfaceFile f (map toInstalledIface ifaces) homeLinks
+        Nothing -> return ()
+
+      -- Render the interfaces.
+      liftIO $ renderStep dflags flags packages ifaces
+
+    else do
+      when (any (`elem` [Flag_Html, Flag_Hoogle, Flag_LaTeX]) flags) $
+        throwE "No input file(s)."
+
+      -- Get packages supplied with --read-interface.
+      packages <- liftIO $ readInterfaceFiles freshNameCache (readIfaceArgs flags)
+
+      -- Render even though there are no input files (usually contents/index).
+      liftIO $ renderStep dflags flags packages []
+
+
+readPackagesAndProcessModules :: [Flag] -> [String]
+                              -> Ghc ([(DocPaths, InterfaceFile)], [Interface], LinkEnv)
+readPackagesAndProcessModules flags files = do
     -- Get packages supplied with --read-interface.
     packages <- readInterfaceFiles nameCacheFromGhc (readIfaceArgs flags)
 
@@ -175,19 +177,19 @@ readPackagesAndProcessModules flags files = do
     return (packages, ifaces, homeLinks)
 
 
-renderStep :: [Flag] -> [(DocPaths, InterfaceFile)] -> [Interface] -> IO ()
-renderStep flags pkgs interfaces = do
+renderStep :: DynFlags -> [Flag] -> [(DocPaths, InterfaceFile)] -> [Interface] -> IO ()
+renderStep dflags flags pkgs interfaces = do
   updateHTMLXRefs pkgs
   let
     ifaceFiles = map snd pkgs
     installedIfaces = concatMap ifInstalledIfaces ifaceFiles
     srcMap = Map.fromList [ (ifPackageId if_, x) | ((_, Just x), if_) <- pkgs ]
-  render flags interfaces installedIfaces srcMap
+  render dflags flags interfaces installedIfaces srcMap
 
 
 -- | Render the interfaces with whatever backend is specified in the flags.
-render :: [Flag] -> [Interface] -> [InstalledInterface] -> SrcMap -> IO ()
-render flags ifaces installedIfaces srcMap = do
+render :: DynFlags -> [Flag] -> [Interface] -> [InstalledInterface] -> SrcMap -> IO ()
+render dflags flags ifaces installedIfaces srcMap = do
 
   let
     title                = fromMaybe "" (optTitle flags)
@@ -241,7 +243,7 @@ render flags ifaces installedIfaces srcMap = do
 
   when (Flag_Hoogle `elem` flags) $ do
     let pkgName2 = if pkgName == "main" && title /= [] then title else pkgName
-    ppHoogle pkgName2 pkgVer title prologue visibleIfaces odir
+    ppHoogle dflags pkgName2 pkgVer title prologue visibleIfaces odir
 
   when (Flag_LaTeX `elem` flags) $ do
     ppLaTeX title pkgStr visibleIfaces odir prologue opt_latex_style