aboutsummaryrefslogtreecommitdiff
path: root/src/Haddock/Backends
diff options
context:
space:
mode:
authorIan Lynagh <igloo@earth.li>2012-06-12 14:38:01 +0100
committerIan Lynagh <igloo@earth.li>2012-06-12 14:38:01 +0100
commit315338287ea84b525da7d8fa8252cc9ec99597bb (patch)
treee6d25af665d95c1002a98b81eaf5f902cf6bb112 /src/Haddock/Backends
parent4fbd2b4b0088d373f0d026dc1cd7117269c7a9db (diff)
Follow changes in GHC
Diffstat (limited to 'src/Haddock/Backends')
-rw-r--r--src/Haddock/Backends/Hoogle.hs111
1 files changed, 57 insertions, 54 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"),