haddock 2.11.1 → 2.12.0
raw patch · 24 files changed
+560/−488 lines, 24 filesdep +deepseqdep ~basedep ~ghc
Dependencies added: deepseq
Dependency ranges changed: base, ghc
Files
- CHANGES +7/−1
- doc/haddock.xml +1/−1
- haddock.cabal +9/−11
- haddock.spec +1/−1
- src/Documentation/Haddock.hs +0/−4
- src/Haddock/Backends/Hoogle.hs +72/−65
- src/Haddock/Backends/LaTeX.hs +42/−48
- src/Haddock/Backends/Xhtml.hs +2/−6
- src/Haddock/Backends/Xhtml/Decl.hs +38/−74
- src/Haddock/Backends/Xhtml/DocMarkup.hs +2/−1
- src/Haddock/Backends/Xhtml/Names.hs +5/−0
- src/Haddock/Convert.hs +77/−65
- src/Haddock/GhcUtils.hs +7/−8
- src/Haddock/Interface.hs +3/−1
- src/Haddock/Interface/AttachInstances.hs +6/−3
- src/Haddock/Interface/Create.hs +64/−52
- src/Haddock/Interface/LexParseRn.hs +18/−13
- src/Haddock/Interface/ParseModuleHeader.hs +1/−0
- src/Haddock/Interface/Rename.hs +81/−51
- src/Haddock/InterfaceFile.hs +18/−7
- src/Haddock/Parse.y +11/−2
- src/Haddock/Types.hs +38/−32
- src/Haddock/Utils.hs +23/−10
- src/Main.hs +34/−32
CHANGES view
@@ -1,3 +1,9 @@+Changes in version 2.12.0++ * Labeled URLs (e.g <http://example.net/ some label>)++ * Improved memory usage (new dependency: deepseq)+ Changes in version 2.11.0 * Show deprecation messages for identifiers@@ -8,7 +14,7 @@ * Fix reporting of modules safe haskell mode - * Fix a case where we were generating invalid xhtml + * Fix a case where we were generating invalid xhtml * Improved --qual option (no crashes, proper error messages)
doc/haddock.xml view
@@ -21,7 +21,7 @@ <holder>Simon Marlow, David Waern</holder> </copyright> <abstract>- <para>This document describes Haddock version 2.11.0, a Haskell+ <para>This document describes Haddock version 2.12.0, a Haskell documentation tool.</para> </abstract> </bookinfo>
haddock.cabal view
@@ -1,5 +1,5 @@ name: haddock-version: 2.11.1+version: 2.12.0 synopsis: A documentation-generation tool for Haskell libraries description: Haddock is a documentation-generation tool for Haskell libraries@@ -83,15 +83,16 @@ if !flag(in-ghc-tree) build-tools: alex >= 2.3, happy >= 1.18 build-depends:- base >= 4.3 && < 4.6,+ base >= 4.3 && < 4.7, filepath, directory, pretty, containers,+ deepseq, array, xhtml >= 3000.2 && < 3000.3, Cabal >= 1.10,- ghc >= 7.4 && < 7.6+ ghc == 7.6.* if flag(in-ghc-tree) cpp-options: -DIN_GHC_TREE@@ -104,9 +105,7 @@ main-is: Main.hs hs-source-dirs: src- default-extensions: CPP, DeriveDataTypeable,- ScopedTypeVariables, MagicHash- ghc-options: -funbox-strict-fields -Wall -fwarn-tabs+ ghc-options: -funbox-strict-fields -O2 -Wall -fwarn-tabs other-modules: Haddock.Interface@@ -145,15 +144,16 @@ if !flag(in-ghc-tree) build-tools: alex >= 2.3, happy >= 1.18 build-depends:- base >= 4.3 && < 4.6,+ base >= 4.3 && < 4.7, filepath, directory, pretty, containers,+ deepseq, array, xhtml >= 3000.2 && < 3000.3, Cabal >= 1.10,- ghc >= 7.4 && < 7.6+ ghc == 7.6.* if flag(in-ghc-tree) cpp-options: -DIN_GHC_TREE@@ -165,9 +165,7 @@ build-depends: QuickCheck >= 2.1 && < 3 hs-source-dirs: src- default-extensions: CPP, DeriveDataTypeable,- ScopedTypeVariables, MagicHash- ghc-options: -funbox-strict-fields -Wall -fwarn-tabs+ ghc-options: -funbox-strict-fields -O2 -Wall -fwarn-tabs exposed-modules: Documentation.Haddock
haddock.spec view
@@ -17,7 +17,7 @@ # version label of your release tarball. %define name haddock-%define version 2.11.0+%define version 2.12.0 %define release 1 Name: %{name}
src/Documentation/Haddock.hs view
@@ -20,10 +20,6 @@ processModules, -- * Export items & declarations- DocMap,- ArgMap,- AliasMap,- Documentation(..), ExportItem(..), DocForDecl, FnArgsDoc,
src/Haddock/Backends/Hoogle.hs view
@@ -34,24 +34,25 @@ ,""] -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 = "" : ppDocumentation (ifaceDoc iface) ++- ["module " ++ moduleString (ifaceMod iface)] ++- concatMap ppExport (ifaceExportItems iface) ++- concatMap ppInstance (ifaceInstances iface)+ppModule :: DynFlags -> Interface -> [String]+ppModule dflags iface =+ "" : ppDocumentation dflags (ifaceDoc iface) +++ ["module " ++ moduleString (ifaceMod iface)] +++ concatMap (ppExport dflags) (ifaceExportItems iface) +++ concatMap (ppInstance dflags) (ifaceInstances iface) ---------------------------------------------------------------------@@ -74,8 +75,8 @@ 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 [] = [] -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,108 +109,114 @@ --------------------------------------------------------------------- -- How to print each export -ppExport :: ExportItem Name -> [String]-ppExport (ExportDecl decl dc subdocs _) = ppDocumentation (fst dc) ++ f (unL decl)+ppExport :: DynFlags -> ExportItem Name -> [String]+ppExport dflags (ExportDecl decl dc subdocs _) = ppDocumentation dflags (fst dc) ++ f (unL decl) where- f (TyClD d@TyData{}) = ppData d subdocs- f (TyClD d@ClassDecl{}) = ppClass d- f (TyClD d@TySynonym{}) = ppSynonym d- f (ForD (ForeignImport name typ _ _)) = ppSig $ TypeSig [name] typ- f (ForD (ForeignExport name typ _ _)) = ppSig $ TypeSig [name] typ- f (SigD sig) = ppSig sig+ f (TyClD d@TyDecl{})+ | 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 = intercalate ", " $ map out names+ prettyNames = intercalate ", " $ map (out dflags) names typ = case unL sig of HsForAllTy Explicit a b c -> HsForAllTy Implicit a b c x -> x-ppSig _ = []---ppSynonym :: TyClDecl Name -> [String]-ppSynonym x = [out x]+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" f (HsForAllTy a b con d) = HsForAllTy a b (reL (context : unLoc con)) d- f t = HsForAllTy Implicit [] (reL [context]) (reL t)+ f t = HsForAllTy Implicit emptyHsQTvs (reL [context]) (reL t) context = nlHsTyConApp (unL $ tcdLName x)- (map (reL . HsTyVar . hsTyVarName . unL) (tcdTyVars x))+ (map (reL . HsTyVar . hsTyVarName . unL) (hsQTvBndrs (tcdTyVars x))) -ppInstance :: Instance -> [String]-ppInstance x = [dropComment $ out x]+ppInstance :: DynFlags -> ClsInst -> [String]+ppInstance dflags x = [dropComment $ out dflags x] -ppData :: TyClDecl Name -> [(Name, DocForDecl Name)] -> [String]-ppData x subdocs = showData x{tcdCons=[],tcdDerivs=Nothing} :- concatMap (ppCtor x subdocs . unL) (tcdCons x)+ppSynonym :: DynFlags -> TyClDecl Name -> [String]+ppSynonym dflags x = [out dflags x]++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 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" -- | for constructors, and named-fields...-lookupCon :: [(Name, DocForDecl Name)] -> Located Name -> [String]-lookupCon subdocs (L _ name) = case lookup name subdocs of- Just (d, _) -> ppDocumentation d+lookupCon :: DynFlags -> [(Name, DocForDecl Name)] -> Located Name -> [String]+lookupCon dflags subdocs (L _ name) = case lookup name subdocs of+ Just (d, _) -> ppDocumentation dflags d _ -> [] -ppCtor :: TyClDecl Name -> [(Name, DocForDecl Name)] -> ConDecl Name -> [String]-ppCtor dat subdocs con = lookupCon subdocs (con_name con)+ppCtor :: DynFlags -> TyClDecl Name -> [(Name, DocForDecl Name)] -> ConDecl Name -> [String]+ppCtor dflags dat subdocs con = lookupCon dflags 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- [lookupCon subdocs (cd_fld_name r) ++- [out (unL $ cd_fld_name r) `typeSig` [resType, cd_fld_type r]]+ [lookupCon dflags 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) $ unL (tcdLName dat) : [hsTyVarName v | v@UserTyVar {} <- map unL $ tcdTyVars dat]+ ResTyH98 -> apps $ map (reL . HsTyVar) $ + unL (tcdLName dat) : [hsTyVarName v | L _ (v@UserTyVar {}) <- hsQTvBndrs $ tcdTyVars dat] ResTyGADT x -> x --------------------------------------------------------------------- -- DOCUMENTATION -ppDocumentation :: Outputable o => Documentation o -> [String]-ppDocumentation (Documentation d w) = doc d ++ doc w+ppDocumentation :: Outputable o => DynFlags -> Documentation o -> [String]+ppDocumentation dflags (Documentation d w) = doc dflags d ++ doc dflags w -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 +237,14 @@ -- 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, markupWarning = box (TagInline "i"), markupEmphasis = box (TagInline "i"),@@ -247,7 +254,7 @@ markupOrderedList = box (TagL 'o'), markupDefList = box (TagL 'u') . map (\(a,b) -> TagInline "i" a : Str " " : b), markupCodeBlock = box TagPre,- markupURL = box (TagInline "a") . str,+ markupHyperlink = \(Hyperlink url mLabel) -> (box (TagInline "a") . str) (fromMaybe url mLabel), markupAName = const $ str "", markupExample = box TagPre . str . unlines . map exampleToString }
src/Haddock/Backends/LaTeX.hs view
@@ -24,7 +24,6 @@ import OccName import Name ( nameOccName ) import RdrName ( rdrNameOcc )-import BasicTypes ( ipNameName ) import FastString ( unpackFS, unpackLitString ) import qualified Data.Map as Map@@ -276,12 +275,13 @@ ppDecl (L loc decl) (doc, fnArgsDoc) instances subdocs = case decl of TyClD d@(TyFamily {}) -> ppTyFam False loc doc d unicode- TyClD d@(TyData {})- | Nothing <- tcdTyPats d -> ppDataDecl instances subdocs loc doc d unicode- | Just _ <- tcdTyPats d -> ppDataInst loc doc d- TyClD d@(TySynonym {})- | Nothing <- tcdTyPats d -> ppTySyn loc (doc, fnArgsDoc) d unicode- | Just _ <- tcdTyPats d -> ppTyInst False loc doc d unicode+ TyClD d@(TyDecl{ tcdTyDefn = defn }) + | isHsDataDefn defn -> ppDataDecl instances subdocs loc doc d unicode+ | otherwise -> ppTySyn loc (doc, fnArgsDoc) d unicode+-- Family instances happen via FamInst now+-- TyClD d@(TySynonym {}) +-- | Just _ <- tcdTyPats d -> ppTyInst False loc doc d unicode+-- Family instances happen via FamInst now TyClD d@(ClassDecl {}) -> ppClassDecl instances loc doc subdocs d unicode SigD (TypeSig lnames (L _ t)) -> ppFunSig loc (doc, fnArgsDoc) (map unLoc lnames) t unicode ForD d -> ppFor loc (doc, fnArgsDoc) d unicode@@ -297,17 +297,6 @@ error "type family declarations are currently not supported by --latex" -ppDataInst :: a-ppDataInst =- error "data instance declarations are currently not supported by --latex"---ppTyInst :: Bool -> SrcSpan -> Documentation DocName ->- TyClDecl DocName -> Bool -> LaTeX-ppTyInst _ _ _ _ _ =- error "type instance declarations are currently not supported by --latex"-- ppFor :: SrcSpan -> DocForDecl DocName -> ForeignDecl DocName -> Bool -> LaTeX ppFor _ _ _ _ = error "foreign declarations are currently not supported by --latex"@@ -321,7 +310,8 @@ -- we skip type patterns for now ppTySyn :: SrcSpan -> DocForDecl DocName -> TyClDecl DocName -> Bool -> LaTeX -ppTySyn loc doc (TySynonym (L _ name) ltyvars _ ltype) unicode+ppTySyn loc doc (TyDecl { tcdLName = L _ name, tcdTyVars = ltyvars+ , tcdTyDefn = TySynonym { td_synRhs = ltype } }) unicode = ppTypeOrFunSig loc [name] (unLoc ltype) doc (full, hdr, char '=') unicode where hdr = hsep (keyword "type" : ppDocBinder name : ppTyVars ltyvars)@@ -394,12 +384,12 @@ <+> ppType unicode ty -ppTyVars :: [LHsTyVarBndr DocName] -> [LaTeX]+ppTyVars :: LHsTyVarBndrs DocName -> [LaTeX] ppTyVars tvs = map ppSymName (tyvarNames tvs) -tyvarNames :: [LHsTyVarBndr DocName] -> [Name]-tyvarNames = map (getName . hsTyVarName . unLoc)+tyvarNames :: LHsTyVarBndrs DocName -> [Name]+tyvarNames = map getName . hsLTyVarNames declWithDoc :: LaTeX -> Maybe LaTeX -> LaTeX@@ -448,7 +438,7 @@ ppClassHdr :: Bool -> Located [LHsType DocName] -> DocName- -> [Located (HsTyVarBndr DocName)] -> [Located ([DocName], [DocName])]+ -> LHsTyVarBndrs DocName -> [Located ([DocName], [DocName])] -> Bool -> LaTeX ppClassHdr summ lctxt n tvs fds unicode = keyword "class"@@ -470,7 +460,8 @@ -> Documentation DocName -> [(DocName, DocForDecl DocName)] -> TyClDecl DocName -> Bool -> LaTeX ppClassDecl instances loc doc subdocs- (ClassDecl lctxt lname ltyvars lfds lsigs _ ats at_defs _) unicode+ (ClassDecl { tcdCtxt = lctxt, tcdLName = lname, tcdTyVars = ltyvars, tcdFDs = lfds + , tcdSigs = lsigs, tcdATs = ats, tcdATDefs = at_defs }) unicode = declWithDoc classheader (if null body then Nothing else Just (vcat body)) $$ instancesBit where@@ -557,7 +548,7 @@ $$ instancesBit where- cons = tcdCons dataDecl+ cons = td_cons (tcdTyDefn dataDecl) resTy = (con_res . unLoc . head) cons body = catMaybes [constrBit, documentationToLaTeX doc]@@ -702,27 +693,15 @@ -- | Print the LHS of a data\/newtype declaration. -- Currently doesn't handle 'data instance' decls or kind signatures ppDataHeader :: TyClDecl DocName -> Bool -> LaTeX-ppDataHeader decl unicode- | not (isDataDecl decl) = error "ppDataHeader: illegal argument"- | otherwise =- -- newtype or data- (if tcdND decl == NewType then keyword "newtype" else keyword "data") <+>+ppDataHeader (TyDecl { tcdLName = L _ name, tcdTyVars = tyvars+ , tcdTyDefn = TyData { td_ND = nd, td_ctxt = ctxt } }) unicode+ = -- newtype or data+ (case nd of { NewType -> keyword "newtype"; DataType -> keyword "data" }) <+> -- context- ppLContext (tcdCtxt decl) unicode <+>+ ppLContext ctxt unicode <+> -- T a b c ..., or a :+: b- ppTyClBinderWithVars False decl-------------------------------------------------------------------------------------- * TyClDecl helpers-------------------------------------------------------------------------------------- | Print a type family / newtype / data / class binder and its variables -ppTyClBinderWithVars :: Bool -> TyClDecl DocName -> LaTeX-ppTyClBinderWithVars summ decl =- ppAppDocNameNames summ (unLoc $ tcdLName decl) (tyvarNames $ tcdTyVars decl)-+ ppAppDocNameNames False name (tyvarNames tyvars)+ppDataHeader _ _ = error "ppDataHeader: illegal argument" -------------------------------------------------------------------------------- -- * Type applications@@ -842,13 +821,13 @@ -- Drop top-level for-all type variables in user style -- since they are implicit in Haskell -ppForAll :: HsExplicitFlag -> [Located (HsTyVarBndr DocName)]+ppForAll :: HsExplicitFlag -> LHsTyVarBndrs DocName -> Located (HsContext DocName) -> Bool -> LaTeX ppForAll expl tvs cxt unicode | show_forall = forall_part <+> ppLContext cxt unicode | otherwise = ppLContext cxt unicode where- show_forall = not (null tvs) && is_explicit+ show_forall = not (null (hsQTvBndrs tvs)) && is_explicit is_explicit = case expl of {Explicit -> True; Implicit -> False} forall_part = hsep (forallSymbol unicode : ppTyVars tvs) <> dot @@ -869,7 +848,7 @@ ppr_mono_ty _ (HsKindSig ty kind) u = parens (ppr_mono_lty pREC_TOP ty u <+> dcolon u <+> ppLKind u kind) ppr_mono_ty _ (HsListTy ty) u = brackets (ppr_mono_lty pREC_TOP ty u) ppr_mono_ty _ (HsPArrTy ty) u = pabrackets (ppr_mono_lty pREC_TOP ty u)-ppr_mono_ty _ (HsIParamTy n ty) u = brackets (ppDocName (ipNameName n) <+> dcolon u <+> ppr_mono_lty pREC_TOP ty u)+ppr_mono_ty _ (HsIParamTy n ty) u = brackets (ppIPName n <+> dcolon u <+> ppr_mono_lty pREC_TOP ty u) ppr_mono_ty _ (HsSpliceTy {}) _ = error "ppr_mono_ty HsSpliceTy" ppr_mono_ty _ (HsQuasiQuoteTy {}) _ = error "ppr_mono_ty HsQuasiQuoteTy" ppr_mono_ty _ (HsRecTy {}) _ = error "ppr_mono_ty HsRecTy"@@ -900,7 +879,16 @@ ppr_mono_ty ctxt_prec (HsDocTy ty _) unicode = ppr_mono_lty ctxt_prec ty unicode +ppr_mono_ty _ (HsTyLit t) u = ppr_tylit t u ++ppr_tylit :: HsTyLit -> Bool -> LaTeX+ppr_tylit (HsNumTy n) _ = integer n+ppr_tylit (HsStrTy s) _ = text (show s)+ -- XXX: Ok in verbatim, but not otherwise+ -- XXX: Do something with Unicode parameter?++ ppr_fun_ty :: Int -> LHsType DocName -> LHsType DocName -> Bool -> LaTeX ppr_fun_ty ctxt_prec ty1 ty2 unicode = let p1 = ppr_mono_lty pREC_FUN ty1 unicode@@ -930,6 +918,8 @@ ppVerbOccName :: OccName -> LaTeX ppVerbOccName = text . latexFilter . occNameString +ppIPName :: HsIPName -> LaTeX+ppIPName ip = text $ unpackFS $ hsIPNameFS ip ppOccName :: OccName -> LaTeX ppOccName = text . occNameString@@ -1011,7 +1001,7 @@ markupOrderedList = \p v -> enumeratedList (map ($v) p) $$ text "", markupDefList = \l v -> descriptionList (map (\(a,b) -> (a v, b v)) l), markupCodeBlock = \p _ -> quote (verb (p Verb)) $$ text "",- markupURL = \u _ -> text "\\url" <> braces (text u),+ markupHyperlink = \l _ -> markupLink l, markupAName = \_ _ -> empty, markupExample = \e _ -> quote $ verb $ text $ unlines $ map exampleToString e }@@ -1019,6 +1009,10 @@ fixString Plain s = latexFilter s fixString Verb s = s fixString Mono s = latexMonoFilter s++ markupLink (Hyperlink url mLabel) = case mLabel of+ Just label -> text "\\href" <> braces (text url) <> braces (text label)+ Nothing -> text "\\url" <> braces (text url) markupId ppId_ id v = case v of
src/Haddock/Backends/Xhtml.hs view
@@ -557,12 +557,8 @@ ((divTopDecl <<).(declElem <<)) `fmap` case decl0 of TyClD d -> let b = ppTyClBinderWithVarsMini mdl d in case d of (TyFamily{}) -> [ppTyFamHeader True False d unicode qual]- (TyData{tcdTyPats = ps})- | Nothing <- ps -> [keyword "data" <+> b]- | Just _ <- ps -> [keyword "data" <+> keyword "instance" <+> b]- (TySynonym{tcdTyPats = ps})- | Nothing <- ps -> [keyword "type" <+> b]- | Just _ <- ps -> [keyword "type" <+> keyword "instance" <+> b]+ (TyDecl{ tcdTyDefn = TyData {} }) -> [keyword "data" <+> b]+ (TyDecl{ tcdTyDefn = TySynonym {} }) -> [keyword "type" <+> b] (ClassDecl {}) -> [keyword "class" <+> b] _ -> [] SigD (TypeSig lnames (L _ _)) ->
src/Haddock/Backends/Xhtml/Decl.hs view
@@ -33,7 +33,6 @@ import GHC import Name-import BasicTypes ( ipNameName ) ppDecl :: Bool -> LinksInfo -> LHsDecl DocName ->@@ -41,12 +40,9 @@ Bool -> Qualification -> Html ppDecl summ links (L loc decl) (mbDoc, fnArgsDoc) instances subdocs unicode qual = case decl of TyClD d@(TyFamily {}) -> ppTyFam summ False links loc mbDoc d unicode qual- TyClD d@(TyData {})- | Nothing <- tcdTyPats d -> ppDataDecl summ links instances subdocs loc mbDoc d unicode qual- | Just _ <- tcdTyPats d -> ppDataInst summ links loc mbDoc d- TyClD d@(TySynonym {})- | Nothing <- tcdTyPats d -> ppTySyn summ links loc (mbDoc, fnArgsDoc) d unicode qual- | Just _ <- tcdTyPats d -> ppTyInst summ False links loc mbDoc d unicode qual+ TyClD d@(TyDecl{ tcdTyDefn = defn }) + | isHsDataDefn defn -> ppDataDecl summ links instances subdocs loc mbDoc d unicode qual+ | otherwise -> ppTySyn summ links loc (mbDoc, fnArgsDoc) d unicode qual TyClD d@(ClassDecl {}) -> ppClassDecl summ links instances loc mbDoc subdocs d unicode qual SigD (TypeSig lnames (L _ t)) -> ppFunSig summ links loc (mbDoc, fnArgsDoc) (map unLoc lnames) t unicode qual ForD d -> ppFor summ links loc (mbDoc, fnArgsDoc) d unicode qual@@ -101,12 +97,12 @@ = [(leader <+> ppType unicode qual t, argDoc n, [])] -ppTyVars :: [LHsTyVarBndr DocName] -> [Html]+ppTyVars :: LHsTyVarBndrs DocName -> [Html] ppTyVars tvs = map ppTyName (tyvarNames tvs) -tyvarNames :: [LHsTyVarBndr DocName] -> [Name]-tyvarNames = map (getName . hsTyVarName . unLoc)+tyvarNames :: LHsTyVarBndrs DocName -> [Name]+tyvarNames = map getName . hsLTyVarNames ppFor :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName@@ -119,7 +115,9 @@ -- we skip type patterns for now ppTySyn :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName -> TyClDecl DocName -> Bool -> Qualification -> Html-ppTySyn summary links loc doc (TySynonym (L _ name) ltyvars _ ltype) unicode qual+ppTySyn summary links loc doc (TyDecl { tcdLName = L _ name, tcdTyVars = ltyvars+ , tcdTyDefn = TySynonym { td_synRhs = ltype } }) + unicode qual = ppTypeOrFunSig summary links loc [name] (unLoc ltype) doc (full, hdr, spaceHtml +++ equals) unicode qual where@@ -161,9 +159,9 @@ ppTyClBinderWithVars summary decl <+> - case tcdKind decl of+ case tcdKindSig decl of Just kind -> dcolon unicode <+> ppLKind unicode qual kind- Nothing -> noHtml+ Nothing -> noHtml ppTyFam :: Bool -> Bool -> LinksInfo -> SrcSpan -> Documentation DocName ->@@ -185,50 +183,6 @@ ----------------------------------------------------------------------------------- * Indexed data types------------------------------------------------------------------------------------ppDataInst :: a-ppDataInst = undefined-------------------------------------------------------------------------------------- * Indexed newtypes------------------------------------------------------------------------------------- TODO--- ppNewTyInst = undefined-------------------------------------------------------------------------------------- * Indexed types------------------------------------------------------------------------------------ppTyInst :: Bool -> Bool -> LinksInfo -> SrcSpan -> Documentation DocName ->- TyClDecl DocName -> Bool -> Qualification -> Html-ppTyInst summary associated links loc doc decl unicode qual-- | summary = ppTyInstHeader True associated decl unicode qual- | otherwise = header_ +++ docSection qual doc-- where- docname = tcdName decl-- header_ = topDeclElem links loc [docname]- (ppTyInstHeader summary associated decl unicode qual)---ppTyInstHeader :: Bool -> Bool -> TyClDecl DocName -> Bool -> Qualification -> Html-ppTyInstHeader _ _ decl unicode qual =- keyword "type instance" <+>- ppAppNameTypes (tcdName decl) typeArgs unicode qual- where- typeArgs = map unLoc . fromJust . tcdTyPats $ decl----------------------------------------------------------------------------------- -- * Associated Types -------------------------------------------------------------------------------- @@ -238,7 +192,6 @@ ppAssocType summ links doc (L loc decl) unicode qual = case decl of TyFamily {} -> ppTyFam summ True links loc (fst doc) decl unicode qual- TySynonym {} -> ppTySyn summ links loc doc decl unicode qual _ -> error "declaration type not supported by ppAssocType" @@ -320,7 +273,7 @@ ppClassHdr :: Bool -> Located [LHsType DocName] -> DocName- -> [Located (HsTyVarBndr DocName)] -> [Located ([DocName], [DocName])]+ -> LHsTyVarBndrs DocName -> [Located ([DocName], [DocName])] -> Bool -> Qualification -> Html ppClassHdr summ lctxt n tvs fds unicode qual = keyword "class"@@ -341,7 +294,8 @@ ppShortClassDecl :: Bool -> LinksInfo -> TyClDecl DocName -> SrcSpan -> [(DocName, DocForDecl DocName)] -> Bool -> Qualification -> Html-ppShortClassDecl summary links (ClassDecl lctxt lname tvs fds sigs _ ats _ _) loc+ppShortClassDecl summary links (ClassDecl { tcdCtxt = lctxt, tcdLName = lname, tcdTyVars = tvs+ , tcdFDs = fds, tcdSigs = sigs, tcdATs = ats }) loc subdocs unicode qual = if null sigs && null ats then (if summary then id else topDeclElem links loc [nm]) hdr@@ -351,6 +305,8 @@ [ ppAssocType summary links doc at unicode qual | at <- ats , let doc = lookupAnySubdoc (tcdName $ unL at) subdocs ] ++ + -- ToDo: add associated type defaults+ [ ppFunSig summary links loc doc names typ unicode qual | L _ (TypeSig lnames (L _ typ)) <- sigs , let doc = lookupAnySubdoc (head names) subdocs@@ -370,7 +326,8 @@ -> Documentation DocName -> [(DocName, DocForDecl DocName)] -> TyClDecl DocName -> Bool -> Qualification -> Html ppClassDecl summary links instances loc d subdocs- decl@(ClassDecl lctxt lname ltyvars lfds lsigs _ ats _ _) unicode qual+ decl@(ClassDecl { tcdCtxt = lctxt, tcdLName = lname, tcdTyVars = ltyvars+ , tcdFDs = lfds, tcdSigs = lsigs, tcdATs = ats }) unicode qual | summary = ppShortClassDecl summary links decl loc subdocs unicode qual | otherwise = classheader +++ docSection qual d +++ atBit +++ methodBit +++ instancesBit@@ -383,6 +340,7 @@ hdr = ppClassHdr summary lctxt (unLoc lname) ltyvars lfds + -- ToDo: add assocatied typ defaults atBit = subAssociatedTypes [ ppAssocType summary links doc at unicode qual | at <- ats , let doc = lookupAnySubdoc (tcdName $ unL at) subdocs ]@@ -443,7 +401,7 @@ doConstr c con = toHtml [c] <+> ppShortConstr summary (unLoc con) unicode qual doGADTConstr con = ppShortConstr summary (unLoc con) unicode qual - cons = tcdCons dataDecl+ cons = td_cons (tcdTyDefn dataDecl) resTy = (con_res . unLoc . head) cons @@ -458,7 +416,7 @@ where docname = unLoc . tcdLName $ dataDecl- cons = tcdCons dataDecl+ cons = td_cons (tcdTyDefn dataDecl) resTy = (con_res . unLoc . head) cons header_ = topDeclElem links loc [docname] (ppDataHeader summary dataDecl unicode qual@@ -612,15 +570,15 @@ -- | Print the LHS of a data\/newtype declaration. -- Currently doesn't handle 'data instance' decls or kind signatures ppDataHeader :: Bool -> TyClDecl DocName -> Bool -> Qualification -> Html-ppDataHeader summary decl unicode qual- | not (isDataDecl decl) = error "ppDataHeader: illegal argument"- | otherwise =- -- newtype or data- (if tcdND decl == NewType then keyword "newtype" else keyword "data") <+>+ppDataHeader summary decl@(TyDecl { tcdTyDefn = TyData { td_ND = nd, td_ctxt = ctxt } }) + unicode qual+ = -- newtype or data+ (case nd of { NewType -> keyword "newtype"; DataType -> keyword "data" }) <+> -- context- ppLContext (tcdCtxt decl) unicode qual <+>+ ppLContext ctxt unicode qual <+> -- T a b c ..., or a :+: b ppTyClBinderWithVars summary decl+ppDataHeader _ _ _ _ = error "ppDataHeader: illegal argument" --------------------------------------------------------------------------------@@ -682,13 +640,13 @@ -- Drop top-level for-all type variables in user style -- since they are implicit in Haskell -ppForAll :: HsExplicitFlag -> [Located (HsTyVarBndr DocName)]+ppForAll :: HsExplicitFlag -> LHsTyVarBndrs DocName -> Located (HsContext DocName) -> Bool -> Qualification -> Html ppForAll expl tvs cxt unicode qual | show_forall = forall_part <+> ppLContext cxt unicode qual | otherwise = ppLContext cxt unicode qual where- show_forall = not (null tvs) && is_explicit+ show_forall = not (null (hsQTvBndrs tvs)) && is_explicit is_explicit = case expl of {Explicit -> True; Implicit -> False} forall_part = hsep (forallSymbol unicode : ppTyVars tvs) +++ dot @@ -710,7 +668,7 @@ parens (ppr_mono_lty pREC_TOP ty u q <+> dcolon u <+> ppLKind u q kind) ppr_mono_ty _ (HsListTy ty) u q = brackets (ppr_mono_lty pREC_TOP ty u q) ppr_mono_ty _ (HsPArrTy ty) u q = pabrackets (ppr_mono_lty pREC_TOP ty u q)-ppr_mono_ty _ (HsIParamTy n ty) u q = brackets (ppDocName q (ipNameName n) <+> dcolon u <+> ppr_mono_lty pREC_TOP ty u q)+ppr_mono_ty _ (HsIParamTy n ty) u q = brackets (ppIPName n <+> dcolon u <+> ppr_mono_lty pREC_TOP ty u q) ppr_mono_ty _ (HsSpliceTy {}) _ _ = error "ppr_mono_ty HsSpliceTy" ppr_mono_ty _ (HsQuasiQuoteTy {}) _ _ = error "ppr_mono_ty HsQuasiQuoteTy" ppr_mono_ty _ (HsRecTy {}) _ _ = error "ppr_mono_ty HsRecTy"@@ -731,8 +689,8 @@ = maybeParen ctxt_prec pREC_FUN $ ppr_mono_lty pREC_OP ty1 unicode qual <+> ppr_op <+> ppr_mono_lty pREC_OP ty2 unicode qual where- ppr_op = if not (isSymOcc occName) then quote (ppLDocName qual op) else ppLDocName qual op- occName = nameOccName . getName . unLoc $ op+ ppr_op = if not (isSymOcc occ) then quote (ppLDocName qual op) else ppLDocName qual op+ occ = nameOccName . getName . unLoc $ op ppr_mono_ty ctxt_prec (HsParTy ty) unicode qual -- = parens (ppr_mono_lty pREC_TOP ty)@@ -740,6 +698,12 @@ ppr_mono_ty ctxt_prec (HsDocTy ty _) unicode qual = ppr_mono_lty ctxt_prec ty unicode qual++ppr_mono_ty _ (HsTyLit n) _ _ = ppr_tylit n++ppr_tylit :: HsTyLit -> Html+ppr_tylit (HsNumTy n) = toHtml (show n)+ppr_tylit (HsStrTy s) = toHtml (show s) ppr_fun_ty :: Int -> LHsType DocName -> LHsType DocName -> Bool -> Qualification -> Html
src/Haddock/Backends/Xhtml/DocMarkup.hs view
@@ -25,6 +25,7 @@ import Haddock.Utils import Text.XHtml hiding ( name, title, p, quote )+import Data.Maybe (fromMaybe) import GHC @@ -46,7 +47,7 @@ markupOrderedList = ordList, markupDefList = defList, markupCodeBlock = pre,- markupURL = \url -> anchor ! [href url] << url,+ markupHyperlink = \(Hyperlink url mLabel) -> anchor ! [href url] << fromMaybe url mLabel, markupAName = \aname -> namedAnchor aname << "", markupPic = \path -> image ! [src path], markupExample = examplesToHtml
src/Haddock/Backends/Xhtml/Names.hs view
@@ -14,6 +14,7 @@ ppName, ppDocName, ppLDocName, ppRdrName, ppUncheckedLink, ppBinder, ppBinder', ppModule, ppModuleRef,+ ppIPName, linkId ) where @@ -30,6 +31,7 @@ import GHC import Name import RdrName+import FastString (unpackFS) ppOccName :: OccName -> Html@@ -38,6 +40,9 @@ ppRdrName :: RdrName -> Html ppRdrName = ppOccName . rdrNameOcc++ppIPName :: HsIPName -> Html+ppIPName = toHtml . unpackFS . hsIPNameFS ppUncheckedLink :: Qualification -> (ModuleName, OccName) -> Html
src/Haddock/Convert.hs view
@@ -20,6 +20,7 @@ import HsSyn import TcType ( tcSplitTyConApp_maybe, tcSplitSigmaTy ) import TypeRep+import Type(isStrLitTy) import Kind ( splitKindFunTys, synTyConResKind ) import Name import Var@@ -29,8 +30,10 @@ import BasicTypes ( TupleSort(..) ) import TysPrim ( alphaTyVars ) import TysWiredIn ( listTyConName, eqTyCon )+import PrelNames (ipClassName) import Bag ( emptyBag ) import SrcLoc ( Located, noLoc, unLoc )+import Data.List( partition ) -- the main function here! yay!@@ -51,77 +54,78 @@ ATyCon tc | Just cl <- tyConClass_maybe tc -- classes are just a little tedious -> TyClD $ ClassDecl- (synifyCtx (classSCTheta cl))- (synifyName cl)- (synifyTyVars (classTyVars cl))- (map (\ (l,r) -> noLoc- (map getName l, map getName r) ) $- snd $ classTvsFds cl)- (map (noLoc . synifyIdSig DeleteTopLevelQuantification)- (classMethods cl))- emptyBag --ignore default method definitions, they don't affect signature+ { tcdCtxt = synifyCtx (classSCTheta cl)+ , tcdLName = synifyName cl+ , tcdTyVars = synifyTyVars (classTyVars cl)+ , tcdFDs = map (\ (l,r) -> noLoc+ (map getName l, map getName r) ) $+ snd $ classTvsFds cl+ , tcdSigs = map (noLoc . synifyIdSig DeleteTopLevelQuantification)+ (classMethods cl)+ , tcdMeths = emptyBag --ignore default method definitions, they don't affect signature -- class associated-types are a subset of TyCon:- [noLoc (synifyTyCon at_tc) | (at_tc, _) <- classATItems cl]- [] --ignore associated type defaults- [] --we don't have any docs at this point+ , tcdATs = [noLoc (synifyTyCon at_tc) | (at_tc, _) <- classATItems cl]+ , tcdATDefs = [] --ignore associated type defaults+ , tcdDocs = [] --we don't have any docs at this point+ , tcdFVs = placeHolderNames } | otherwise -> TyClD (synifyTyCon tc) -- type-constructors (e.g. Maybe) are complicated, put the definition -- later in the file (also it's used for class associated-types too.)- ACoAxiom ax -> TyClD (synifyAxiom ax)+ ACoAxiom ax -> InstD (FamInstD { lid_inst = synifyAxiom ax }) -- a data-constructor alone just gets rendered as a function: ADataCon dc -> SigD (TypeSig [synifyName dc] (synifyType ImplicitizeForAll (dataConUserType dc))) -synifyATDefault :: TyCon -> LTyClDecl Name+synifyATDefault :: TyCon -> LFamInstDecl Name synifyATDefault tc = noLoc (synifyAxiom ax) where Just ax = tyConFamilyCoercion_maybe tc -synifyAxiom :: CoAxiom -> TyClDecl Name+synifyAxiom :: CoAxiom -> FamInstDecl Name synifyAxiom (CoAxiom { co_ax_tvs = tvs, co_ax_lhs = lhs, co_ax_rhs = rhs }) | Just (tc, args) <- tcSplitTyConApp_maybe lhs = let name = synifyName tc- tyvars = synifyTyVars tvs typats = map (synifyType WithinType) args hs_rhs_ty = synifyType WithinType rhs- in TySynonym name tyvars (Just typats) hs_rhs_ty+ in FamInstDecl { fid_tycon = name + , fid_pats = HsWB { hswb_cts = typats, hswb_kvs = [], hswb_tvs = map tyVarName tvs }+ , fid_defn = TySynonym hs_rhs_ty, fid_fvs = placeHolderNames } | otherwise = error "synifyAxiom" synifyTyCon :: TyCon -> TyClDecl Name synifyTyCon tc- | isFunTyCon tc || isPrimTyCon tc =- TyData- -- arbitrary lie, they are neither algebraic data nor newtype:- DataType- -- no built-in type has any stupidTheta:- (noLoc [])- (synifyName tc)- -- tyConTyVars doesn't work on fun/prim, but we can make them up:- (zipWith- (\fakeTyVar realKind -> noLoc $- KindedTyVar (getName fakeTyVar) (synifyKind realKind) placeHolderKind)- alphaTyVars --a, b, c... which are unfortunately all kind *- (fst . splitKindFunTys $ tyConKind tc)- )- -- assume primitive types aren't members of data/newtype families:- Nothing- -- we have their kind accurately:- (Just (synifyKind (tyConKind tc)))- -- no algebraic constructors:- []- -- "deriving" needn't be specified:- Nothing- | isSynFamilyTyCon tc =- case synTyConRhs tc of+ | isFunTyCon tc || isPrimTyCon tc + = TyDecl { tcdLName = synifyName tc+ , tcdTyVars = -- tyConTyVars doesn't work on fun/prim, but we can make them up:+ let mk_hs_tv realKind fakeTyVar + = noLoc $ KindedTyVar (getName fakeTyVar) + (synifyKindSig realKind)+ in HsQTvs { hsq_kvs = [] -- No kind polymorhism+ , hsq_tvs = zipWith mk_hs_tv (fst (splitKindFunTys (tyConKind tc)))+ alphaTyVars --a, b, c... which are unfortunately all kind *+ }+ + , tcdTyDefn = TyData { td_ND = DataType -- arbitrary lie, they are neither + -- algebraic data nor newtype:+ , td_ctxt = noLoc []+ , td_cType = Nothing+ , td_kindSig = Just (synifyKindSig (tyConKind tc))+ -- we have their kind accurately:+ , td_cons = [] -- No constructors+ , td_derivs = Nothing }+ , tcdFVs = placeHolderNames }+ | isSynFamilyTyCon tc + = case synTyConRhs tc of SynFamilyTyCon -> TyFamily TypeFamily (synifyName tc) (synifyTyVars (tyConTyVars tc))- (Just (synifyKind (synTyConResKind tc))) -- placeHolderKind+ (Just (synifyKindSig (synTyConResKind tc))) _ -> error "synifyTyCon: impossible open type synonym?"- | isDataFamilyTyCon tc = --(why no "isOpenAlgTyCon"?)- case algTyConRhs tc of+ | isDataFamilyTyCon tc + = --(why no "isOpenAlgTyCon"?)+ case algTyConRhs tc of DataFamilyTyCon -> TyFamily DataFamily (synifyName tc) (synifyTyVars (tyConTyVars tc)) Nothing --always kind '*'@@ -137,9 +141,6 @@ alg_ctx = synifyCtx (tyConStupidTheta tc) name = synifyName tc tyvars = synifyTyVars (tyConTyVars tc)- typats = case tyConFamInst_maybe tc of- Nothing -> Nothing- Just (_, indexes) -> Just (map (synifyType WithinType) indexes) alg_kindSig = Just (tyConKind tc) -- The data constructors. --@@ -162,10 +163,14 @@ -- "deriving" doesn't affect the signature, no need to specify any. alg_deriv = Nothing syn_type = synifyType WithinType (synTyConType tc)- in if isSynTyCon tc- then TySynonym name tyvars typats syn_type- else TyData alg_nd alg_ctx name tyvars typats (fmap synifyKind alg_kindSig) alg_cons alg_deriv-+ defn | isSynTyCon tc = TySynonym syn_type+ | otherwise = TyData { td_ND = alg_nd, td_ctxt = alg_ctx+ , td_cType = Nothing+ , td_kindSig = fmap synifyKindSig alg_kindSig+ , td_cons = alg_cons + , td_derivs = alg_deriv }+ in TyDecl { tcdLName = name, tcdTyVars = tyvars, tcdTyDefn = defn+ , tcdFVs = placeHolderNames } -- User beware: it is your responsibility to pass True (use_gadt_syntax) -- for any constructor that would be misrepresented by omitting its@@ -230,16 +235,17 @@ synifyCtx = noLoc . map (synifyType WithinType) -synifyTyVars :: [TyVar] -> [LHsTyVarBndr Name]-synifyTyVars = map synifyTyVar+synifyTyVars :: [TyVar] -> LHsTyVarBndrs Name+synifyTyVars ktvs = HsQTvs { hsq_kvs = map tyVarName kvs+ , hsq_tvs = map synifyTyVar tvs } where- synifyTyVar tv = noLoc $ let- kind = tyVarKind tv- name = getName tv- in if isLiftedTypeKind kind- then UserTyVar name placeHolderKind- else KindedTyVar name (synifyKind kind) placeHolderKind-+ (kvs, tvs) = partition isKindVar ktvs+ synifyTyVar tv + | isLiftedTypeKind kind = noLoc (UserTyVar name)+ | otherwise = noLoc (KindedTyVar name (synifyKindSig kind))+ where+ kind = tyVarKind tv+ name = getName tv --states of what to do with foralls: data SynifyTypeState@@ -271,9 +277,10 @@ | getName tc == listTyConName, [ty] <- tys = noLoc $ HsListTy (synifyType WithinType ty) -- ditto for implicit parameter tycons- | Just ip <- tyConIP_maybe tc- , [ty] <- tys- = noLoc $ HsIParamTy ip (synifyType WithinType ty)+ | tyConName tc == ipClassName+ , [name, ty] <- tys+ , Just x <- isStrLitTy name+ = noLoc $ HsIParamTy (HsIPName x) (synifyType WithinType ty) -- and equalities | tc == eqTyCon , [ty1, ty2] <- tys@@ -305,9 +312,14 @@ sTau = synifyType WithinType tau in noLoc $ HsForAllTy forallPlicitness sTvs sCtx sTau+synifyType _ (LitTy t) = noLoc $ HsTyLit $ synifyTyLit t -synifyKind :: Kind -> LHsKind Name-synifyKind = synifyType (error "synifyKind")+synifyTyLit :: TyLit -> HsTyLit+synifyTyLit (NumTyLit n) = HsNumTy n+synifyTyLit (StrTyLit s) = HsStrTy s++synifyKindSig :: Kind -> LHsKind Name+synifyKindSig k = synifyType (error "synifyKind") k synifyInstHead :: ([TyVar], [PredType], Class, [Type]) -> ([HsType Name], Name, [HsType Name])
src/Haddock/GhcUtils.hs view
@@ -78,7 +78,7 @@ getMainDeclBinder :: HsDecl name -> [name]-getMainDeclBinder (TyClD d) | not (isFamInstDecl d) = [tcdName d]+getMainDeclBinder (TyClD d) = [tcdName d] getMainDeclBinder (ValD d) = case collectHsBindBinders d of [] -> []@@ -138,7 +138,6 @@ isInstD :: HsDecl a -> Bool isInstD (InstD _) = True-isInstD (TyClD d) = isFamInstDecl d isInstD _ = False @@ -152,12 +151,12 @@ 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 -------------------------------------------------------------------------------@@ -216,7 +215,7 @@ instance Parent (TyClDecl Name) where children d- | isDataDecl d = map (unL . con_name . unL) . tcdCons $ d+ | isDataDecl d = map (unL . con_name . unL) . td_cons . tcdTyDefn $ d | isClassDecl d = map (tcdName . unL) (tcdATs d) ++ [ unL n | L _ (TypeSig ns _) <- tcdSigs d, n <- ns ]@@ -232,7 +231,7 @@ -- child to its grand-children, recursively. families :: TyClDecl Name -> [(Name, [Name])] families d- | isDataDecl d = family d : map (family . unL) (tcdCons d)+ | isDataDecl d = family d : map (family . unL) (td_cons (tcdTyDefn d)) | isClassDecl d = family d : concatMap (families . unL) (tcdATs d) | otherwise = []
src/Haddock/Interface.hs view
@@ -49,6 +49,7 @@ import Text.Printf import Digraph+import DynFlags hiding (verbosity, flags) import Exception import GHC hiding (verbosity, flags) import HscTypes@@ -83,8 +84,9 @@ 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)
src/Haddock/Interface/AttachInstances.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE MagicHash #-}+{-# LANGUAGE CPP, MagicHash #-} ----------------------------------------------------------------------------- -- | -- Module : Haddock.Interface.AttachInstances@@ -91,7 +91,7 @@ -- | Like GHC's getInfo but doesn't cut things out depending on the -- interative context, which we don't set sufficiently anyway.-getAllInfo :: GhcMonad m => Name -> m (Maybe (TyThing,Fixity,[Instance]))+getAllInfo :: GhcMonad m => Name -> m (Maybe (TyThing,Fixity,[ClsInst])) getAllInfo name = withSession $ \hsc_env -> do (_msgs, r) <- liftIO $ tcRnGetInfo hsc_env name return r@@ -106,7 +106,9 @@ -- in Haddock output) and unifying special tycons with normal ones. -- For the benefit of the user (looks nice and predictable) and the -- tests (which prefer output to be deterministic).-data SimpleType = SimpleType Name [SimpleType] deriving (Eq,Ord)+data SimpleType = SimpleType Name [SimpleType]+ | SimpleTyLit TyLit+ deriving (Eq,Ord) instHead :: ([TyVar], [PredType], Class, [Type]) -> ([Int], Name, [SimpleType])@@ -126,6 +128,7 @@ where (SimpleType s ts) = simplify t1 simplify (TyVarTy v) = SimpleType (tyVarName v) [] simplify (TyConApp tc ts) = SimpleType (tyConName tc) (map simplify ts)+ simplify (LitTy l) = SimpleTyLit l -- sortImage f = sortBy (\x y -> compare (f x) (f y))
src/Haddock/Interface/Create.hs view
@@ -1,4 +1,5 @@-{-# LANGUAGE TupleSections #-}+{-# LANGUAGE TupleSections, BangPatterns #-}+{-# OPTIONS_GHC -Wwarn #-} ----------------------------------------------------------------------------- -- | -- Module : Haddock.Interface.Create@@ -27,6 +28,7 @@ import Data.Monoid import Data.Ord import Control.Applicative+import Control.DeepSeq import Control.Monad import qualified Data.Traversable as T @@ -48,13 +50,13 @@ createInterface :: TypecheckedModule -> [Flag] -> IfaceMap -> InstIfaceMap -> ErrMsgGhc Interface createInterface tm flags modMap instIfaceMap = do - let ms = pm_mod_summary . tm_parsed_module $ tm- mi = moduleInfo tm- safety = modInfoSafe mi- mdl = ms_mod ms- dflags = ms_hspp_opts ms- instances = modInfoInstances mi- exportedNames = modInfoExports mi+ let ms = pm_mod_summary . tm_parsed_module $ tm+ mi = moduleInfo tm+ !safety = modInfoSafe mi+ mdl = ms_mod ms+ dflags = ms_hspp_opts ms+ !instances = modInfoInstances mi+ !exportedNames = modInfoExports mi (TcGblEnv {tcg_rdr_env = gre, tcg_warns = warnings}, _) = tm_internals_ tm @@ -72,13 +74,13 @@ | Flag_IgnoreAllExports `elem` flags = OptIgnoreExports : opts0 | otherwise = opts0 - (info, mbDoc) <- liftErrMsg $ processModuleHeader dflags gre safety mayDocHeader+ (!info, mbDoc) <- liftErrMsg $ processModuleHeader dflags gre safety mayDocHeader let declsWithDocs = topDecls group_ (decls, _) = unzip declsWithDocs localInsts = filter (nameIsLocalOrFrom mdl . getName) instances - maps@(docMap, argMap, subMap, declMap) <-+ maps@(!docMap, !argMap, !subMap, !declMap) <- liftErrMsg $ mkMaps dflags gre localInsts declsWithDocs let exports0 = fmap (reverse . map unLoc) mayExports@@ -86,30 +88,31 @@ | OptIgnoreExports `elem` opts = Nothing | otherwise = exports0 - liftErrMsg $ warnAboutFilteredDecls mdl decls+ liftErrMsg $ warnAboutFilteredDecls dflags mdl decls let warningMap = mkWarningMap warnings gre exportedNames exportItems <- mkExportItems modMap mdl warningMap gre exportedNames decls maps exports instances instIfaceMap dflags - let visibleNames = mkVisibleNames exportItems opts+ let !visibleNames = mkVisibleNames exportItems opts -- Measure haddock documentation coverage. let prunedExportItems0 = pruneExportItems exportItems- haddockable = 1 + length exportItems -- module + exports- haddocked = (if isJust mbDoc then 1 else 0) + length prunedExportItems0- coverage = (haddockable, haddocked)+ !haddockable = 1 + length exportItems -- module + exports+ !haddocked = (if isJust mbDoc then 1 else 0) + length prunedExportItems0+ !coverage = (haddockable, haddocked) -- Prune the export list to just those declarations that have -- documentation, if the 'prune' option is on.- let prunedExportItems+ let prunedExportItems' | OptPrune `elem` opts = prunedExportItems0 | otherwise = exportItems+ !prunedExportItems = seqList prunedExportItems' `seq` prunedExportItems' - let aliases =+ let !aliases = mkAliasMap dflags $ tm_renamed_source tm - return Interface {+ return $! Interface { ifaceMod = mdl, ifaceOrigFilename = msHsFilePath ms, ifaceInfo = info,@@ -179,7 +182,7 @@ case ws of NoWarnings -> Nothing WarnSome _ -> Nothing- WarnAll w -> Just (warnToDoc w)+ WarnAll w -> Just $! warnToDoc w warnToDoc :: WarningTxt -> Doc id@@ -187,7 +190,8 @@ (DeprecatedTxt msg) -> format "Deprecated: " msg (WarningTxt msg) -> format "Warning: " msg where- format x xs = DocWarning . DocParagraph . DocString . concat $ x : map unpackFS xs+ format x xs = let !str = force $ concat (x : map unpackFS xs)+ in DocWarning $ DocParagraph $ DocString str -------------------------------------------------------------------------------@@ -224,13 +228,12 @@ type Maps = (DocMap Name, ArgMap Name, SubMap, DeclMap) - -- | Create 'Maps' by looping through the declarations. For each declaration, -- find its names, its subordinates, and its doc strings. Process doc strings -- into 'Doc's. mkMaps :: DynFlags -> GlobalRdrEnv- -> [Instance]+ -> [ClsInst] -> [(LHsDecl Name, [HsDocString])] -> ErrMsgM Maps mkMaps dflags gre instances decls = do@@ -255,22 +258,26 @@ am = [ (n, args) | n <- ns ] ++ zip subNs subArgs sm = [ (n, subNs) | n <- ns ] cm = [ (n, [ldecl]) | n <- ns ++ subNs ]- return (dm, am, sm, cm)+ seqList ns `seq`+ seqList subNs `seq`+ doc `seq`+ seqList subDocs `seq`+ seqList subArgs `seq`+ return (dm, am, sm, cm) instanceMap :: Map SrcSpan Name instanceMap = M.fromList [ (getSrcSpan n, n) | i <- instances, let n = getName i ] names :: HsDecl Name -> [Name]- names (InstD (InstDecl (L l _) _ _ _)) = maybeToList (M.lookup l instanceMap) -- See note [2].+ names (InstD (ClsInstD { cid_poly_ty = L l _ })) = maybeToList (M.lookup l instanceMap) -- See note [2]. names decl = getMainDeclBinder decl - -- Note [2]: --------------- We relate Instances to InstDecls using the SrcSpans buried inside them.+-- We relate ClsInsts to InstDecls using the SrcSpans buried inside them. -- That should work for normal user-written instances (from looking at GHC -- sources). We can assume that commented instances are user-written.--- This lets us relate Names (from Instances) to comments (associated+-- This lets us relate Names (from ClsInsts) to comments (associated -- with InstDecls). @@ -290,7 +297,7 @@ ] dataSubs = constrs ++ fields where- cons = map unL $ tcdCons decl+ cons = map unL $ (td_cons (tcdTyDefn decl)) constrs = [ (unL $ con_name c, maybeToList $ fmap unL $ con_doc c, M.empty) | c <- cons ] fields = [ (unL n, maybeToList $ fmap unL doc, M.empty)@@ -306,7 +313,7 @@ case d of SigD (TypeSig _ ty) -> docs (unLoc ty) ForD (ForeignImport _ ty _ _) -> docs (unLoc ty)- TyClD (TySynonym {tcdSynRhs = ty}) -> docs (unLoc ty)+ TyClD (TyDecl { tcdTyDefn = TySynonym {td_synRhs = ty}}) -> docs (unLoc ty) _ -> M.empty where go n (HsForAllTy _ _ _ ty) = go n (unLoc ty)@@ -364,11 +371,11 @@ 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 [ tcdName d | L _ (TyClD d) <- decls, isFamInstDecl d ]+ nub [ unLoc (fid_tycon d) | L _ (InstD (FamInstD { lid_inst = d })) <- decls ] unless (null typeInstances) $ tell [@@ -377,7 +384,7 @@ ++ "will be filtered out:\n " ++ (intercalate ", " $ map (occNameString . nameOccName) typeInstances) ] - let instances = nub [ pretty i | L _ (InstD (InstDecl i _ _ 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) $@@ -457,7 +464,7 @@ -> [LHsDecl Name] -> Maps -> Maybe [IE Name]- -> [Instance]+ -> [ClsInst] -> InstIfaceMap -> DynFlags -> ErrMsgGhc [ExportItem Name]@@ -501,7 +508,7 @@ case findDecl t of ([L _ (ValD _)], (doc, _)) -> do -- Top-level binding without type signature- export <- hiValExportItem t doc+ export <- hiValExportItem dflags t doc return [export] (ds, docs_) | decl : _ <- filter (not . isValD . unLoc) ds -> let declNames = getMainDeclBinder (unL decl)@@ -518,8 +525,8 @@ 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 []@@ -539,7 +546,7 @@ -- Declaration from another package ([], _) -> do- mayDecl <- hiDecl t+ mayDecl <- hiDecl dflags t case mayDecl of Nothing -> return [ ExportNoDecl t [] ] Just decl ->@@ -548,7 +555,7 @@ 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 ->@@ -580,19 +587,19 @@ m = nameModule n -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 [] [])@@ -648,8 +655,8 @@ 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@@ -690,6 +697,7 @@ f (L l (SigD (GenericSig names t))) xs = foldr (\n acc -> L l (SigD (GenericSig [n] t)) : acc) xs names f x xs = x : xs + mkExportItem :: LHsDecl Name -> ErrMsgGhc (Maybe (ExportItem Name)) mkExportItem (L _ (DocD (DocGroup lev docStr))) = do mbDoc <- liftErrMsg $ processDocString dflags gre docStr return $ fmap (ExportGroup lev "") mbDoc@@ -700,7 +708,7 @@ | name:_ <- collectHsBindBinders d, Just [L _ (ValD _)] <- M.lookup name declMap = -- Top-level binding without type signature. let (doc, _) = lookupDocs name warnings docMap argMap subMap in- fmap Just (hiValExportItem name doc)+ fmap Just (hiValExportItem dflags name doc) | otherwise = return Nothing mkExportItem decl | name:_ <- getMainDeclBinder (unLoc decl) =@@ -728,7 +736,7 @@ _ -> error "internal: extractDecl" TyClD d | isDataDecl d -> let (n, tyvar_names) = name_and_tyvars d- L pos sig = extractRecSel name mdl n tyvar_names (tcdCons d)+ L pos sig = extractRecSel name mdl n tyvar_names (td_cons (tcdTyDefn d)) in L pos (SigD sig) _ -> error "internal: extractDecl" where@@ -743,7 +751,7 @@ extractClassDecl c tvs0 (L pos (TypeSig lname ltype)) = case ltype of L _ (HsForAllTy expl tvs (L _ preds) ty) -> L pos (TypeSig lname (noLoc (HsForAllTy expl tvs (lctxt preds) ty)))- _ -> L pos (TypeSig lname (noLoc (mkImplicitHsForAllTy (lctxt []) ltype)))+ _ -> L pos (TypeSig lname (noLoc (HsForAllTy Implicit emptyHsQTvs (lctxt []) ltype))) where lctxt = noLoc . ctxt ctxt preds = nlHsTyConApp c (map toTypeNoLoc tvs0) : preds@@ -764,7 +772,7 @@ data_ty = foldl (\x y -> noLoc (HsAppTy x y)) (noLoc (HsTyVar t)) (map toTypeNoLoc tvs) --- | Keep exprt items with docs.+-- | Keep export items with docs. pruneExportItems :: [ExportItem Name] -> [ExportItem Name] pruneExportItems = filter hasDoc where@@ -775,7 +783,8 @@ mkVisibleNames :: [ExportItem Name] -> [DocOption] -> [Name] mkVisibleNames exports opts | OptHide `elem` opts = []- | otherwise = concatMap exportName exports+ | otherwise = let ns = concatMap exportName exports+ in seqList ns `seq` ns where exportName e@ExportDecl {} = getMainDeclBinder (unL $ expItemDecl e) ++ subs where subs = map fst (expItemSubDocs e)@@ -783,6 +792,9 @@ -- we don't want links to go to them. exportName _ = [] +seqList :: [a] -> ()+seqList [] = ()+seqList (x : xs) = x `seq` seqList xs -- | Find a stand-alone documentation comment by its name. findNamedDoc :: String -> [HsDecl Name] -> ErrMsgM (Maybe HsDocString)
src/Haddock/Interface/LexParseRn.hs view
@@ -1,3 +1,5 @@+{-# OPTIONS_GHC -Wwarn #-}+{-# LANGUAGE BangPatterns #-} ----------------------------------------------------------------------------- -- | -- Module : Haddock.Interface.LexParseRn@@ -61,7 +63,7 @@ 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)) processModuleHeader :: DynFlags -> GlobalRdrEnv -> SafeHaskellMode -> Maybe LHsDocString@@ -69,6 +71,7 @@ processModuleHeader dflags gre safety mayStr = do (hmi, doc) <- case mayStr of+ Nothing -> return failure Just (L _ (HsDocString fs)) -> do let str = unpackFS fs@@ -77,16 +80,17 @@ tell ["haddock module header parse failed: " ++ msg] return failure Right (hmi, doc) -> do- let hmi' = hmi { hmi_description = rename gre <$> hmi_description hmi }- doc' = rename gre doc+ let !descr = rename dflags gre <$> hmi_description hmi+ hmi' = hmi { hmi_description = descr }+ doc' = rename dflags gre doc return (hmi', Just doc')- return (hmi { hmi_safety = Just $ showPpr safety }, doc)+ return (hmi { hmi_safety = Just $ showPpr dflags safety }, doc) where failure = (emptyHaddockModInfo, Nothing) -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)@@ -97,9 +101,10 @@ 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@@ -113,7 +118,7 @@ DocCodeBlock doc -> DocCodeBlock (rn doc) DocIdentifierUnchecked x -> DocIdentifierUnchecked x DocModule str -> DocModule str- DocURL str -> DocURL str+ DocHyperlink l -> DocHyperlink l DocPic str -> DocPic str DocAName str -> DocAName str DocExamples e -> DocExamples e@@ -121,12 +126,12 @@ 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))
src/Haddock/Interface/ParseModuleHeader.hs view
@@ -1,3 +1,4 @@+{-# OPTIONS_GHC -Wwarn #-} ----------------------------------------------------------------------------- -- | -- Module : Haddock.Interface.ParseModuleHeader
src/Haddock/Interface/Rename.hs view
@@ -16,7 +16,6 @@ import Haddock.Types import Bag (emptyBag)-import BasicTypes ( IPName(..), ipNameName ) import GHC hiding (NoLink) import Name @@ -28,8 +27,8 @@ import Prelude 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@@ -58,7 +57,7 @@ -- 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@@ -200,7 +199,7 @@ DocCodeBlock doc -> do doc' <- renameDoc doc return (DocCodeBlock doc')- DocURL str -> return (DocURL str)+ DocHyperlink l -> return (DocHyperlink l) DocPic str -> return (DocPic str) DocAName str -> return (DocAName str) DocExamples e -> return (DocExamples e)@@ -216,14 +215,17 @@ renameLKind :: LHsKind Name -> RnM (LHsKind DocName) renameLKind = renameLType -renameMaybeLKind :: Maybe (LHsKind Name) -> RnM (Maybe (LHsKind DocName))+renameMaybeLKind :: Maybe (LHsKind Name)+ -> RnM (Maybe (LHsKind DocName)) renameMaybeLKind Nothing = return Nothing-renameMaybeLKind (Just ki) = Just <$> renameLKind ki+renameMaybeLKind (Just ki)+ = do { ki' <- renameLKind ki+ ; return (Just ki') } renameType :: HsType Name -> RnM (HsType DocName) renameType t = case t of HsForAllTy expl tyvars lcontext ltype -> do- tyvars' <- mapM renameLTyVarBndr tyvars+ tyvars' <- renameLTyVarBndrs tyvars lcontext' <- renameLContext lcontext ltype' <- renameLType ltype return (HsForAllTy expl tyvars' lcontext' ltype')@@ -243,7 +245,7 @@ HsListTy ty -> return . HsListTy =<< renameLType ty HsPArrTy ty -> return . HsPArrTy =<< renameLType ty- HsIParamTy n ty -> liftM2 HsIParamTy (liftM IPName (rename (ipNameName n))) (renameLType ty)+ HsIParamTy n ty -> liftM (HsIParamTy n) (renameLType ty) HsEqTy ty1 ty2 -> liftM2 HsEqTy (renameLType ty1) (renameLType ty2) HsTupleTy b ts -> return . HsTupleTy b =<< mapM renameLType ts@@ -266,15 +268,25 @@ doc' <- renameLDocHsSyn doc return (HsDocTy ty' doc') + HsTyLit x -> return (HsTyLit x)+ _ -> error "renameType" -renameLTyVarBndr :: LHsTyVarBndr Name -> RnM (LHsTyVarBndr DocName)-renameLTyVarBndr (L loc tv) = do- name' <- rename (hsTyVarName tv)- tyvar' <- replaceTyVarName tv name' renameLKind- return $ L loc tyvar'+renameLTyVarBndrs :: LHsTyVarBndrs Name -> RnM (LHsTyVarBndrs DocName)+renameLTyVarBndrs (HsQTvs { hsq_kvs = _, hsq_tvs = tvs })+ = do { tvs' <- mapM renameLTyVarBndr tvs+ ; return (HsQTvs { hsq_kvs = error "haddock:renameLTyVarBndrs", hsq_tvs = tvs' }) }+ -- This is rather bogus, but I'm not sure what else to do +renameLTyVarBndr :: LHsTyVarBndr Name -> RnM (LHsTyVarBndr DocName)+renameLTyVarBndr (L loc (UserTyVar n))+ = do { n' <- rename n+ ; return (L loc (UserTyVar n')) }+renameLTyVarBndr (L loc (KindedTyVar n k))+ = do { n' <- rename n+ ; k' <- renameLKind k+ ; return (L loc (KindedTyVar n' k')) } renameLContext :: Located [LHsType Name] -> RnM (Located [LHsType DocName]) renameLContext (L loc context) = do@@ -324,54 +336,67 @@ -- TyFamily flav lname ltyvars kind tckind -> do TyFamily flav lname ltyvars tckind -> do lname' <- renameL lname- ltyvars' <- mapM renameLTyVarBndr ltyvars+ ltyvars' <- renameLTyVarBndrs ltyvars -- kind' <- renameMaybeLKind kind tckind' <- renameMaybeLKind tckind -- return (TyFamily flav lname' ltyvars' kind' tckind) return (TyFamily flav lname' ltyvars' tckind') - TyData x lcontext lname ltyvars typats k cons _ -> do- lcontext' <- renameLContext lcontext+ TyDecl { tcdLName = lname, tcdTyVars = tyvars, tcdTyDefn = defn, tcdFVs = fvs } -> do lname' <- renameL lname- ltyvars' <- mapM renameLTyVarBndr ltyvars- typats' <- mapM (mapM renameLType) typats- k' <- renameMaybeLKind k- cons' <- mapM renameLCon cons- -- I don't think we need the derivings, so we return Nothing- return (TyData x lcontext' lname' ltyvars' typats' k' cons' Nothing)-- TySynonym lname ltyvars typats ltype -> do- lname' <- renameL lname- ltyvars' <- mapM renameLTyVarBndr ltyvars- ltype' <- renameLType ltype- typats' <- mapM (mapM renameLType) typats- return (TySynonym lname' ltyvars' typats' ltype')+ tyvars' <- renameLTyVarBndrs tyvars+ defn' <- renameTyDefn defn+ return (TyDecl { tcdLName = lname', tcdTyVars = tyvars', tcdTyDefn = defn', tcdFVs = fvs }) - ClassDecl lcontext lname ltyvars lfundeps lsigs _ ats at_defs _ -> do+ ClassDecl { tcdCtxt = lcontext, tcdLName = lname, tcdTyVars = ltyvars+ , tcdFDs = lfundeps, tcdSigs = lsigs, tcdATs = ats, tcdATDefs = at_defs } -> do lcontext' <- renameLContext lcontext lname' <- renameL lname- ltyvars' <- mapM renameLTyVarBndr ltyvars+ ltyvars' <- renameLTyVarBndrs ltyvars lfundeps' <- mapM renameLFunDep lfundeps lsigs' <- mapM renameLSig lsigs ats' <- mapM renameLTyClD ats- at_defs' <- mapM renameLTyClD at_defs+ at_defs' <- mapM (mapM renameFamInstD) at_defs -- we don't need the default methods or the already collected doc entities- return (ClassDecl lcontext' lname' ltyvars' lfundeps' lsigs' emptyBag ats' at_defs' [])+ return (ClassDecl { tcdCtxt = lcontext', tcdLName = lname', tcdTyVars = ltyvars'+ , tcdFDs = lfundeps', tcdSigs = lsigs', tcdMeths= emptyBag+ , tcdATs = ats', tcdATDefs = at_defs', tcdDocs = [], tcdFVs = placeHolderNames }) where- renameLCon (L loc con) = return . L loc =<< renameCon con- renameCon decl@(ConDecl { con_name = lname, con_qvars = ltyvars- , con_cxt = lcontext, con_details = details- , con_res = restype, con_doc = mbldoc }) = do+ renameLFunDep (L loc (xs, ys)) = do+ xs' <- mapM rename xs+ ys' <- mapM rename ys+ return (L loc (xs', ys'))++ renameLSig (L loc sig) = return . L loc =<< renameSig sig++renameTyDefn :: HsTyDefn Name -> RnM (HsTyDefn DocName)+renameTyDefn (TyData { td_ND = nd, td_ctxt = lcontext, td_cType = cType+ , td_kindSig = k, td_cons = cons }) = do+ lcontext' <- renameLContext lcontext+ k' <- renameMaybeLKind k+ cons' <- mapM (mapM renameCon) cons+ -- I don't think we need the derivings, so we return Nothing+ return (TyData { td_ND = nd, td_ctxt = lcontext', td_cType = cType+ , td_kindSig = k', td_cons = cons', td_derivs = Nothing })++renameTyDefn (TySynonym { td_synRhs = ltype }) = do+ ltype' <- renameLType ltype+ return (TySynonym { td_synRhs = ltype' })++renameCon :: ConDecl Name -> RnM (ConDecl DocName)+renameCon decl@(ConDecl { con_name = lname, con_qvars = ltyvars+ , con_cxt = lcontext, con_details = details+ , con_res = restype, con_doc = mbldoc }) = do lname' <- renameL lname- ltyvars' <- mapM renameLTyVarBndr ltyvars+ ltyvars' <- renameLTyVarBndrs ltyvars lcontext' <- renameLContext lcontext details' <- renameDetails details restype' <- renameResType restype mbldoc' <- mapM renameLDocHsSyn mbldoc return (decl { con_name = lname', con_qvars = ltyvars', con_cxt = lcontext' , con_details = details', con_res = restype', con_doc = mbldoc' })-+ where renameDetails (RecCon fields) = return . RecCon =<< mapM renameField fields renameDetails (PrefixCon ps) = return . PrefixCon =<< mapM renameLType ps renameDetails (InfixCon a b) = do@@ -388,14 +413,6 @@ renameResType (ResTyH98) = return ResTyH98 renameResType (ResTyGADT t) = return . ResTyGADT =<< renameLType t - renameLFunDep (L loc (xs, ys)) = do- xs' <- mapM rename xs- ys' <- mapM rename ys- return (L loc (xs', ys'))-- renameLSig (L loc sig) = return . L loc =<< renameSig sig-- renameSig :: Sig Name -> RnM (Sig DocName) renameSig sig = case sig of TypeSig lnames ltype -> do@@ -418,10 +435,23 @@ renameInstD :: InstDecl Name -> RnM (InstDecl DocName)-renameInstD (InstDecl ltype _ _ lATs) = do+renameInstD (ClsInstD { cid_poly_ty =ltype, cid_fam_insts = lATs }) = do ltype' <- renameLType ltype- lATs' <- mapM renameLTyClD lATs- return (InstDecl ltype' emptyBag [] lATs')+ lATs' <- mapM (mapM renameFamInstD) lATs+ return (ClsInstD { cid_poly_ty = ltype', cid_binds = emptyBag, cid_sigs = []+ , cid_fam_insts = lATs' })++renameInstD (FamInstD { lid_inst = d }) = do+ d' <- renameFamInstD d+ return (FamInstD { lid_inst = d' })++renameFamInstD :: FamInstDecl Name -> RnM (FamInstDecl DocName)+renameFamInstD (FamInstDecl { fid_tycon = tc, fid_pats = pats_w_bndrs, fid_defn = defn })+ = do { tc' <- renameL tc+ ; pats' <- mapM renameLType (hswb_cts pats_w_bndrs)+ ; defn' <- renameTyDefn defn + ; return (FamInstDecl { fid_tycon = tc', fid_pats = pats_w_bndrs { hswb_cts = pats' }+ , fid_defn = defn', fid_fvs = placeHolderNames }) } renameExportItem :: ExportItem Name -> RnM (ExportItem DocName)
src/Haddock/InterfaceFile.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE CPP, RankNTypes, ScopedTypeVariables #-} {-# OPTIONS_GHC -fno-warn-orphans #-} ----------------------------------------------------------------------------- -- |@@ -66,13 +66,15 @@ -- we version our interface files accordingly. binaryInterfaceVersion :: Word16 #if __GLASGOW_HASKELL__ == 702-binaryInterfaceVersion = 20+binaryInterfaceVersion = 21 #elif __GLASGOW_HASKELL__ == 703-binaryInterfaceVersion = 20+binaryInterfaceVersion = 21 #elif __GLASGOW_HASKELL__ == 704-binaryInterfaceVersion = 20+binaryInterfaceVersion = 21 #elif __GLASGOW_HASKELL__ == 705-binaryInterfaceVersion = 20+binaryInterfaceVersion = 21+#elif __GLASGOW_HASKELL__ == 706+binaryInterfaceVersion = 21 #else #error Unknown GHC version #endif@@ -413,7 +415,16 @@ result <- get bh return (Example expression result) +instance Binary Hyperlink where+ put_ bh (Hyperlink url label) = do+ put_ bh url+ put_ bh label+ get bh = do+ url <- get bh+ label <- get bh+ return (Hyperlink url label) + {-* Generated by DrIFT : Look, but Don't Touch. *-} instance (Binary id) => Binary (Doc id) where put_ bh DocEmpty = do@@ -452,7 +463,7 @@ put_ bh (DocCodeBlock al) = do putByte bh 11 put_ bh al- put_ bh (DocURL am) = do+ put_ bh (DocHyperlink am) = do putByte bh 12 put_ bh am put_ bh (DocPic x) = do@@ -511,7 +522,7 @@ return (DocCodeBlock al) 12 -> do am <- get bh- return (DocURL am)+ return (DocHyperlink am) 13 -> do x <- get bh return (DocPic x)
src/Haddock/Parse.y view
@@ -10,7 +10,7 @@ module Haddock.Parse where import Haddock.Lex-import Haddock.Types (Doc(..), Example(Example))+import Haddock.Types (Doc(..), Example(Example), Hyperlink(..)) import Haddock.Doc import HsSyn import RdrName@@ -107,7 +107,7 @@ elem1 :: { Doc RdrName } : STRING { DocString $1 } | '/../' { DocEmphasis (DocString $1) }- | URL { DocURL $1 }+ | URL { DocHyperlink (makeHyperlink $1) } | PIC { DocPic $1 } | ANAME { DocAName $1 } | IDENT { DocIdentifier $1 }@@ -120,6 +120,15 @@ { happyError :: [LToken] -> Maybe a happyError toks = Nothing++-- | Create a `Hyperlink` from given string.+--+-- A hyperlink consists of a URL and an optional label. The label is separated+-- from the url by one or more whitespace characters.+makeHyperlink :: String -> Hyperlink+makeHyperlink input = case break isSpace $ strip input of+ (url, "") -> Hyperlink url Nothing+ (url, label) -> Hyperlink url (Just . dropWhile isSpace $ label) -- | Create an 'Example', stripping superfluous characters as appropriate makeExample :: String -> String -> [String] -> Example
src/Haddock/Types.hs view
@@ -59,10 +59,10 @@ data Interface = Interface { -- | The module behind this interface.- ifaceMod :: Module+ ifaceMod :: !Module -- | Original file name of the module.- , ifaceOrigFilename :: FilePath+ , ifaceOrigFilename :: !FilePath -- | Textual information about the module. , ifaceInfo :: !(HaddockModInfo Name)@@ -71,7 +71,7 @@ , ifaceDoc :: !(Documentation Name) -- | Documentation header with cross-reference information.- , ifaceRnDoc :: Documentation DocName+ , ifaceRnDoc :: !(Documentation DocName) -- | Haddock options for this module (prune, ignore-exports, etc). , ifaceOptions :: ![DocOption]@@ -79,22 +79,22 @@ -- | Declarations originating from the module. Excludes declarations without -- names (instances and stand-alone documentation comments). Includes -- names of subordinate declarations mapped to their parent declarations.- , ifaceDeclMap :: Map Name [LHsDecl Name]+ , ifaceDeclMap :: !(Map Name [LHsDecl Name]) -- | Documentation of declarations originating from the module (including -- subordinates).- , ifaceDocMap :: DocMap Name- , ifaceArgMap :: ArgMap Name+ , ifaceDocMap :: !(DocMap Name)+ , ifaceArgMap :: !(ArgMap Name) -- | Documentation of declarations originating from the module (including -- subordinates).- , ifaceRnDocMap :: DocMap DocName- , ifaceRnArgMap :: ArgMap DocName+ , ifaceRnDocMap :: !(DocMap DocName)+ , ifaceRnArgMap :: !(ArgMap DocName) - , ifaceSubMap :: Map Name [Name]+ , ifaceSubMap :: !(Map Name [Name]) , ifaceExportItems :: ![ExportItem Name]- , ifaceRnExportItems :: [ExportItem DocName]+ , ifaceRnExportItems :: ![ExportItem DocName] -- | All names exported by the module. , ifaceExports :: ![Name]@@ -105,14 +105,14 @@ , ifaceVisibleExports :: ![Name] -- | Aliases of module imports as in @import A.B.C as C@.- , ifaceModuleAliases :: AliasMap+ , ifaceModuleAliases :: !AliasMap -- | Instances exported by the module.- , ifaceInstances :: ![Instance]+ , ifaceInstances :: ![ClsInst] -- | The number of haddockable and haddocked items in the module, as a -- tuple. Haddockable items are the exports and the module itself.- , ifaceHaddockCoverage :: (Int,Int)+ , ifaceHaddockCoverage :: !(Int, Int) } @@ -172,51 +172,51 @@ = ExportDecl { -- | A declaration.- expItemDecl :: LHsDecl name+ expItemDecl :: !(LHsDecl name) -- | Maybe a doc comment, and possibly docs for arguments (if this -- decl is a function or type-synonym).- , expItemMbDoc :: DocForDecl name+ , expItemMbDoc :: !(DocForDecl name) -- | Subordinate names, possibly with documentation.- , expItemSubDocs :: [(name, DocForDecl name)]+ , expItemSubDocs :: ![(name, DocForDecl name)] -- | Instances relevant to this declaration, possibly with -- documentation.- , expItemInstances :: [DocInstance name]+ , expItemInstances :: ![DocInstance name] } -- | An exported entity for which we have no documentation (perhaps because it -- resides in another package). | ExportNoDecl- { expItemName :: name+ { expItemName :: !name -- | Subordinate names.- , expItemSubs :: [name]+ , expItemSubs :: ![name] } -- | A section heading. | ExportGroup { -- | Section level (1, 2, 3, ...).- expItemSectionLevel :: Int+ expItemSectionLevel :: !Int -- | Section id (for hyperlinks).- , expItemSectionId :: String+ , expItemSectionId :: !String -- | Section heading text.- , expItemSectionText :: Doc name+ , expItemSectionText :: !(Doc name) } -- | Some documentation.- | ExportDoc (Doc name)+ | ExportDoc !(Doc name) -- | A cross-reference to another module.- | ExportModule Module+ | ExportModule !Module data Documentation name = Documentation { documentationDoc :: Maybe (Doc name)- , documentationWarning :: Maybe (Doc name)+ , documentationWarning :: !(Maybe (Doc name)) } deriving Functor @@ -303,7 +303,7 @@ | DocOrderedList [Doc id] | DocDefList [(Doc id, Doc id)] | DocCodeBlock (Doc id)- | DocURL String+ | DocHyperlink Hyperlink | DocPic String | DocAName String | DocExamples [Example]@@ -315,6 +315,12 @@ mappend = DocAppend +data Hyperlink = Hyperlink+ { hyperlinkUrl :: String+ , hyperlinkLabel :: Maybe String+ } deriving (Eq, Show)++ data Example = Example { exampleExpression :: String , exampleResult :: [String]@@ -341,7 +347,7 @@ , markupOrderedList :: [a] -> a , markupDefList :: [(a,a)] -> a , markupCodeBlock :: a -> a- , markupURL :: String -> a+ , markupHyperlink :: Hyperlink -> a , markupAName :: String -> a , markupPic :: String -> a , markupExample :: [Example] -> a@@ -349,11 +355,11 @@ data HaddockModInfo name = HaddockModInfo- { hmi_description :: Maybe (Doc name)- , hmi_portability :: Maybe String- , hmi_stability :: Maybe String- , hmi_maintainer :: Maybe String- , hmi_safety :: Maybe String+ { hmi_description :: (Maybe (Doc name))+ , hmi_portability :: (Maybe String)+ , hmi_stability :: (Maybe String)+ , hmi_maintainer :: (Maybe String)+ , hmi_safety :: (Maybe String) }
src/Haddock/Utils.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE CPP #-} ----------------------------------------------------------------------------- -- | -- Module : Haddock.Utils@@ -13,7 +14,7 @@ module Haddock.Utils ( -- * Misc utilities- restrictTo,+ restrictTo, emptyHsQTvs, toDescription, toInstalledDescription, -- * Filename utilities@@ -125,18 +126,24 @@ restrictTo :: [Name] -> LHsDecl Name -> LHsDecl Name restrictTo names (L loc decl) = L loc $ case decl of- TyClD d | isDataDecl d && tcdND d == DataType ->- TyClD (d { tcdCons = restrictCons names (tcdCons d) })- TyClD d | isDataDecl d && tcdND d == NewType ->- case restrictCons names (tcdCons d) of- [] -> TyClD (d { tcdND = DataType, tcdCons = [] })- [con] -> TyClD (d { tcdCons = [con] })- _ -> error "Should not happen"+ TyClD d | isDataDecl d -> + TyClD (d { tcdTyDefn = restrictTyDefn names (tcdTyDefn d) }) TyClD d | isClassDecl d -> TyClD (d { tcdSigs = restrictDecls names (tcdSigs d), tcdATs = restrictATs names (tcdATs d) }) _ -> decl +restrictTyDefn :: [Name] -> HsTyDefn Name -> HsTyDefn Name+restrictTyDefn _ defn@(TySynonym {})+ = defn+restrictTyDefn names defn@(TyData { td_ND = new_or_data, td_cons = cons })+ | DataType <- new_or_data+ = defn { td_cons = restrictCons names cons }+ | otherwise -- Newtype+ = case restrictCons names cons of+ [] -> defn { td_ND = DataType, td_cons = [] }+ [con] -> defn { td_cons = [con] }+ _ -> error "Should not happen" restrictCons :: [Name] -> [LConDecl Name] -> [LConDecl Name] restrictCons names decls = [ L p d | L p (Just d) <- map (fmap keep) decls ]@@ -166,7 +173,13 @@ restrictATs :: [Name] -> [LTyClDecl Name] -> [LTyClDecl Name] restrictATs names ats = [ at | at <- ats , tcdName (unL at) `elem` names ] +emptyHsQTvs :: LHsTyVarBndrs Name+-- This function is here, rather than in HsTypes, because it *renamed*, but+-- does not necessarily have all the rigt kind variables. It is used+-- in Haddock just for printing, so it doesn't matter+emptyHsQTvs = HsQTvs { hsq_kvs = error "haddock:emptyHsQTvs", hsq_tvs = [] } + -------------------------------------------------------------------------------- -- * Filename mangling functions stolen from s main/DriverUtil.lhs. --------------------------------------------------------------------------------@@ -416,7 +429,7 @@ markup m (DocOrderedList ds) = markupOrderedList m (map (markup m) ds) markup m (DocDefList ds) = markupDefList m (map (markupPair m) ds) markup m (DocCodeBlock d) = markupCodeBlock m (markup m d)-markup m (DocURL url) = markupURL m url+markup m (DocHyperlink l) = markupHyperlink m l markup m (DocAName ref) = markupAName m ref markup m (DocPic img) = markupPic m img markup m (DocExamples e) = markupExample m e@@ -443,7 +456,7 @@ markupOrderedList = DocOrderedList, markupDefList = DocDefList, markupCodeBlock = DocCodeBlock,- markupURL = DocURL,+ markupHyperlink = DocHyperlink, markupAName = DocAName, markupPic = DocPic, markupExample = DocExamples
src/Main.hs view
@@ -1,5 +1,5 @@ {-# OPTIONS_GHC -Wwarn #-}-{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE CPP, ScopedTypeVariables #-} ----------------------------------------------------------------------------- -- | -- Module : Main@@ -135,31 +135,6 @@ shortcutFlags flags qual <- case qualification flags of {Left msg -> throwE msg; Right q -> return q} - 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 qual 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 qual 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.@@ -170,6 +145,33 @@ -- 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 qual 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 qual packages []+++readPackagesAndProcessModules :: [Flag] -> [String]+ -> Ghc ([(DocPaths, InterfaceFile)], [Interface], LinkEnv)+readPackagesAndProcessModules flags files = do -- Get packages supplied with --read-interface. packages <- readInterfaceFiles nameCacheFromGhc (readIfaceArgs flags) @@ -180,19 +182,19 @@ return (packages, ifaces, homeLinks) -renderStep :: [Flag] -> QualOption -> [(DocPaths, InterfaceFile)] -> [Interface] -> IO ()-renderStep flags qual pkgs interfaces = do+renderStep :: DynFlags -> [Flag] -> QualOption -> [(DocPaths, InterfaceFile)] -> [Interface] -> IO ()+renderStep dflags flags qual 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 qual interfaces installedIfaces srcMap+ render dflags flags qual interfaces installedIfaces srcMap -- | Render the interfaces with whatever backend is specified in the flags.-render :: [Flag] -> QualOption -> [Interface] -> [InstalledInterface] -> SrcMap -> IO ()-render flags qual ifaces installedIfaces srcMap = do+render :: DynFlags -> [Flag] -> QualOption -> [Interface] -> [InstalledInterface] -> SrcMap -> IO ()+render dflags flags qual ifaces installedIfaces srcMap = do let title = fromMaybe "" (optTitle flags)@@ -246,7 +248,7 @@ 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