Follow changes in GHC

2 files changed, 58 insertions, 55 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)