haddock 2.1.0 → 2.2.0
raw patch · 16 files changed
+858/−704 lines, 16 filesdep +ghc-pathsdep ~ghc
Dependencies added: ghc-paths
Dependency ranges changed: ghc
Files
- CHANGES +19/−0
- README +2/−1
- TODO +0/−160
- doc/haddock.xml +18/−4
- haddock.cabal +107/−92
- haddock.spec +1/−1
- src/Haddock/Backends/Hoogle.hs +196/−114
- src/Haddock/Backends/Html.hs +216/−73
- src/Haddock/GHC/Typecheck.hs +7/−2
- src/Haddock/GHC/Utils.hs +14/−5
- src/Haddock/Interface/AttachInstances.hs +8/−7
- src/Haddock/Interface/Create.hs +212/−214
- src/Haddock/Interface/Rename.hs +36/−16
- src/Haddock/Options.hs +2/−2
- src/Haddock/Types.hs +2/−5
- src/Main.hs +18/−8
CHANGES view
@@ -1,3 +1,22 @@+Changes in version 2.2.0:++ * Support for GHC 6.8.3++ * The Hoogle backend is back, thanks to Neil Mitchell. The plan is to be+ compatible with the upcoming Hoogle 4 pre-release++ * Shows associated types in the documentation for class declarations++ * Shows type family declarations++ * Major bug fixes (#44 and #crash)++ * It is no longer required to specify the path to GHC's lib dir++ * Remove unnecessary parenthesis in type signatures++-----------------------------------------------------------------------------+ Changes in version 2.1.0: * Fix a bug that made links point to the defining module instead
README view
@@ -36,8 +36,9 @@ Full documentation can be found in the doc/ subdirectory, in DocBook format. -Please send questions and suggestions to me:+Please send questions and suggestions to: +David Waern <david.waern@gmail.com> or Simon Marlow <simonmar@microsoft.com>
− TODO
@@ -1,160 +0,0 @@--------------------------------------------------------------------------------- Small improvements--* When no GHC can be found, give an error message that tells you to use- --with-ghc=<path>--* Instead of receiving the GHC lib dir as input, try to autodetect it with- ghc --print-libdir. Add a --with-ghc flag instead of -B.--* Print an error message when given -optghc=.. instead of --optghc=..---- ------------------------------------------------------------------------------ Before next release--* There should be a --maintainer flag to allow Cabal to pass the maintainer- from the .cabal file to the generated docs.--* The docs don't mention the module header stuff.---------------------------------------------------------------------------------- bugs--* parser doesn't support doc comments on types in type aliases:- type MyInt = Int -- ^ comment--* HsParser bug: starting the module with '-- | doc' followed by a declaration- doesn't parse, because the '-- | doc' is interpreted as the module- documentation (the grammar has an S/R conflict because of this).--* We don't point module references ("..." in doc strings) to the correct- package, they are always assumed to be modules in the current package.--* For a non-home occurrence of an entity, we should point to the home- location in the doc somehow. This would help to distinguish- multiple functions with the same name (eg. we don't know whether- Prelude.catch is Control.Exception.catch vs. System.IO.Error.catch).--* The lexer should handle "...." in doc strings, only recognising it if the- contents looks like a module name.--* Mentioning a qualified identifer in doc loses the qualifier, even when- it is required? (see "[Haskell] auto-qualification of identifiers in- Haddock").--* A module re-export should only reference the target module if the- target module is imported without hiding any of its exports (otherwise- we should inline just the exported bits).--* Be a bit cleaner about error cases: some internal errors can be- generated by bugs in the Haskell source. Divide out the proper- internal error cases and emit proper error messages.--* The synopsis generated for a module with no docs should not attempt to- link to the doc for each entity. We need a different kind of summary- here: what we really want is just the documentation section but without- the extra whitespace between decls.--* We don't handle non-ASCII characters in doc comments. (need to specify- the encoding in the generated HTML too?).--* There's no way to refer explicitly to either a type/class- constructor or data constructor When there are more than one of- these with the same name. Perhaps introduce a special syntax for- them? (eg. ':C' means data constructor C?)---------------------------------------------------------------------------------- features---* Optionally show qualifications of identifiers, that is print-"Sequence.map" rather than "map", "Music.T" rather than just "T". The-option for haddock could be- --qualification QUAL- QUAL=none (default) strip off qualification (just "map")- QUAL=orig show the identifiers as they are written in the module (e.g. "map" or "List.map")- QUAL=full show all identifiers with full qualification (Data.List.map)- Actually I tried to implement it by myself in the old Haddock, but I-could not precisely identify the place, where the qualification is-removed.--* Documentation of arguments of type constructors other than 'top level' arrows. E.g.- T (a {- ^ arg -} -> b {- ^ result -} )- (a {- ^ arg -} -> b {- ^ result -} ) -> c- (a {- ^ x coord -}, b {- ^ y coord -}) -> c- It's probably difficult to format properly in HTML.--* Do something better about re-exported symbols from another package.--* Haddock could compare interfaces from multiple versions of a module- and indicate changes between versions (eg. a small "new!" or- "changed!" icon, or "stable since 1.0").--* Something equivalent to JavaDoc's @since--* Source code: various people want to get at the source code from the docs.- * Optionally include source code for a function in its docs?- * Suggestion from Benjamin Pierce: generat separate HTML pages with the- source code, with anchors that you can link to from the docs.- Sounds fairly easy to implement...--* Parse and remember {-# SOURCE #-} imports, possibly do something sensible- with them?--* nested itemized and enumerated lists.--* There ought to be a way to include some structure in the "description"- (section headings, etc.) and possibly in other comments. (suggseted- by Daan).--* Comments on instance declarations? (suggested by Daan and Iavor).--* Comments on default method declarations? (suggested by Satnam).--* Comments on components of a tuple, for argument or return types.--* Add a search feature which just invokes Google?--* attributes for individual declarations, eg.- -- #abstract- or targetted to a specific decl:- -- #T: abstract-- #long, #short, #noinstances (on a type or class)-- #inline, #noinline on a module export--* Allow documentation annotations to explicitly name the entity they- refer to.--* In the contents page, indicate portability/stability of each module- somehow.--* Add back-references from the definition to the uses of types/classes- (perhaps in the index?)--* Add a link to the defining location of a re-exported entity--* fixities--* include file revision info in module headers--* Allow individual function arguments to be documented when the function- type is a record element?--* hiding instances?--* Add a way to indicate DEPRECATED functions/types/modules? Perhaps- parse the GHC DEPRECATED pragma?---------------------------------------------------------------------------------- cosmetic--* Allow more parts of the documentation to be squashed and expanded?--* for a constructor, don't fill its entire cell with a grey background.--* switch to longer rendering form for datatypes when necessary?--* remove extra whitespace from the generated HTML to save space-
doc/haddock.xml view
@@ -16,7 +16,7 @@ <holder>Simon Marlow</holder> </copyright> <abstract>- <para>This document describes Haddock version 2.1.0, a Haskell+ <para>This document describes Haddock version 2.2.0, a Haskell documentation tool.</para> </abstract> </bookinfo>@@ -93,8 +93,8 @@ </listitem> <listitem> <para>We might want documentation in multiple formats - online- and printed, for example. Haddock comes with HTML and DocBook- backends, and it is structured in such a way that adding new+ and printed, for example. Haddock comes with HTML, DocBook+ and Hoogle backends, and it is structured in such a way that adding new back-ends is straightforward.</para> </listitem> </itemizedlist>@@ -231,7 +231,7 @@ </term> <listitem> <para>Tell GHC that that its lib directory is- <replaceable>dir</replaceable>. Needed to do any processing. </para>+ <replaceable>dir</replaceable>. Can be used to override the default path.</para> </listitem> </varlistentry> @@ -795,6 +795,20 @@ </listitem> </varlistentry> </variablelist>+ +<varlistentry>+ <term>+ <indexterm><primary><option>-w</option></primary></indexterm>+ <option>-w</option>+ </term>+ <term>+ <indexterm><primary><option>--no-warnings</option></primary></indexterm>+ <option>--no-warnings</option>+ </term>+ <listitem>+ <para>Turn off all warnings.</para>+ </listitem>+ </varlistentry> <section id="cpp"> <title>Using literate or pre-processed source</title>
haddock.cabal view
@@ -1,8 +1,8 @@-cabal-version: >= 1.2-build-type: Simple name: haddock-version: 2.1.0+version: 2.2.0+cabal-version: >= 1.2 license: BSD3+build-type: Simple license-file: LICENSE copyright: (c) Simon Marlow, David Waern author: Simon Marlow, David Waern@@ -13,94 +13,109 @@ description: Haddock is a documentation-generation tool for Haskell libraries category: Development-build-depends:- base,- haskell98,- ghc >= 6.8.2 && < 6.9,- filepath,- directory,- pretty,- containers,- array-extensions: CPP, PatternGuards, DeriveDataTypeable,- PatternSignatures, MagicHash-hs-source-dirs: src-exposed-modules: Distribution.Haddock-other-modules:- Haddock.Types- Haddock.InterfaceFile- Haddock.Exception-data-files:- html/haddock-DEBUG.css- html/haddock.css- html/haddock-util.js- html/haskell_icon.gif- html/minus.gif- html/plus.gif+ extra-source-files:- CHANGES- README- TODO- doc/Makefile- doc/README- doc/aclocal.m4- doc/config.mk.in- doc/configure.ac- doc/docbook-xml.mk- doc/fptools.css- doc/haddock.xml- examples/A.hs- examples/B.hs- examples/Bug1.hs- examples/Bug2.hs- examples/Bug3.hs- examples/Bug4.hs- examples/Bug6.hs- examples/Bug7.hs- examples/Bug8.hs- examples/Bug9.hs- examples/Hash.hs- examples/Hidden.hs- examples/Makefile- examples/NoLayout.hs- examples/Test.hs- examples/Visible.hs- examples/hide-bug/A.hs- examples/hide-bug/B.hs- examples/hide-bug/C.hs- examples/hide-bug/D.hs- haddock.spec- haskell.vim- src/haddock.sh+ CHANGES+ README+ doc/Makefile+ doc/README+ doc/aclocal.m4+ doc/config.mk.in+ doc/configure.ac+ doc/docbook-xml.mk+ doc/fptools.css+ doc/haddock.xml+ examples/A.hs+ examples/B.hs+ examples/Bug1.hs+ examples/Bug2.hs+ examples/Bug3.hs+ examples/Bug4.hs+ examples/Bug6.hs+ examples/Bug7.hs+ examples/Bug8.hs+ examples/Bug9.hs+ examples/Hash.hs+ examples/Hidden.hs+ examples/Makefile+ examples/NoLayout.hs+ examples/Test.hs+ examples/Visible.hs+ examples/hide-bug/A.hs+ examples/hide-bug/B.hs+ examples/hide-bug/C.hs+ examples/hide-bug/D.hs+ haddock.spec+ haskell.vim+ src/haddock.sh -executable: haddock-hs-source-dirs: src-main-is: Main.hs-extensions: CPP, PatternGuards, DeriveDataTypeable,- PatternSignatures, MagicHash-ghc-options: -funbox-strict-fields -O2-other-modules:- Haddock.Interface- Haddock.Interface.Rename- Haddock.Interface.Create- Haddock.Interface.AttachInstances- Haddock.Utils.FastMutInt2- Haddock.Utils.BlockTable- Haddock.Utils.Html- Haddock.Utils- Haddock.Backends.Html- Haddock.Backends.HaddockDB- Haddock.Backends.DevHelp- Haddock.Backends.HH- Haddock.Backends.HH2- Haddock.Backends.Hoogle- Haddock.ModuleTree- Haddock.Types- Haddock.DocName- Haddock.Version- Haddock.InterfaceFile - Haddock.Exception- Haddock.Options- Haddock.GHC.Typecheck- Haddock.GHC.Utils- Haddock.GHC+data-files:+ html/haddock-DEBUG.css+ html/haddock.css+ html/haddock-util.js+ html/haskell_icon.gif+ html/minus.gif+ html/plus.gif++++executable haddock+ build-depends:+ base,+ haskell98,+ ghc == 6.8.2 || == 6.8.3,+ ghc-paths <= 0.1.0.2,+ filepath,+ directory,+ pretty,+ containers,+ array+ main-is: Main.hs+ hs-source-dirs: src+ extensions: CPP, PatternGuards, DeriveDataTypeable,+ PatternSignatures, MagicHash+ ghc-options: -funbox-strict-fields -O2++ other-modules:+ Haddock.Interface+ Haddock.Interface.Rename+ Haddock.Interface.Create+ Haddock.Interface.AttachInstances+ Haddock.Utils.FastMutInt2+ Haddock.Utils.BlockTable+ Haddock.Utils.Html+ Haddock.Utils+ Haddock.Backends.Html+ Haddock.Backends.HaddockDB+ Haddock.Backends.DevHelp+ Haddock.Backends.HH+ Haddock.Backends.HH2+ Haddock.Backends.Hoogle+ Haddock.ModuleTree+ Haddock.Types+ Haddock.DocName+ Haddock.Version+ Haddock.InterfaceFile + Haddock.Exception+ Haddock.Options+ Haddock.GHC.Typecheck+ Haddock.GHC.Utils+ Haddock.GHC+ + -- Cabal doesn't define __GHC_PATCHLEVEL__+ if impl(ghc == 6.8.3)+ cpp-options: -D__GHC_PATCHLEVEL__=3+ if impl(ghc == 6.8.2)+ cpp-options: -D__GHC_PATCHLEVEL__=2++++library+ hs-source-dirs: src+ extensions: CPP, PatternGuards, DeriveDataTypeable,+ PatternSignatures, MagicHash+ exposed-modules: Distribution.Haddock+ other-modules:+ Haddock.Types+ Haddock.InterfaceFile+ Haddock.Exception
haddock.spec view
@@ -17,7 +17,7 @@ # version label of your release tarball. %define name haddock-%define version 2.1.0+%define version 2.2.0 %define release 1 Name: %{name}
src/Haddock/Backends/Hoogle.hs view
@@ -3,182 +3,264 @@ -- -- (c) Simon Marlow 2003 ----- This file, (c) Neil Mitchell 2006+-- This file, (c) Neil Mitchell 2006-2008 -- Write out Hoogle compatible documentation -- http://www.haskell.org/hoogle/ module Haddock.Backends.Hoogle ( - ppHoogle+ ppHoogle ) where -ppHoogle = undefined -{--import HaddockTypes-import HaddockUtil-import HsSyn2+import Haddock.GHC+import Haddock.GHC.Utils+import Haddock.Types+import Haddock.Utils+import GHC hiding ((<.>))+import SrcLoc+import Outputable -import Data.List ( intersperse )+import Control.Monad+import Data.Char+import Data.List+import Data.Maybe+import qualified Data.Set as Set+import System.FilePath +prefix = ["-- Hoogle documentation, generated by Haddock"+ ,"-- See Hoogle, http://www.haskell.org/hoogle/"+ ,""] -prefix = ["-- Hoogle documentation, generated by Haddock",- "-- See Hoogle, http://www.haskell.org/hoogle/"] -ppHoogle :: Maybe String -> [Interface] -> FilePath -> IO ()-ppHoogle maybe_package ifaces odir =- do- let- filename = case maybe_package of- Just x -> x ++ ".txt"- Nothing -> "hoogle.txt"+ppHoogle :: String -> String -> [Interface] -> FilePath -> IO ()+ppHoogle package version ifaces odir = do+ let filename = package <.> "txt"+ contents = prefix +++ ["@package " ++ package] +++ ["@version " ++ version | version /= ""] +++ concat [ppModule i | i <- ifaces, OptHide `notElem` ifaceOptions i]+ writeFile (odir </> filename) (unlines contents) - visible_ifaces = filter visible ifaces- visible i = OptHide `notElem` iface_options i - contents = prefix : map ppModule visible_ifaces+ppModule :: Interface -> [String]+ppModule iface = "" : doc (ifaceDoc iface) +++ ["module " ++ moduleString (ifaceMod iface)] +++ concatMap ppExport exported +++ concatMap ppInstance (ifaceInstances iface)+ where+ locals = Set.fromList $ ifaceLocals iface+ exported = [i | i@(ExportDecl{expItemDecl=decl}) <- ifaceExportItems iface+ , isLocal (unLoc decl)]+ isLocal decl+ | Just name <- getMainDeclBinder decl = name `Set.member` locals+ | otherwise = False - writeFile (pathJoin [odir, filename]) (unlines $ concat contents)- +---------------------------------------------------------------------+-- Utility functions --- ------------------------------------------------------------------------------ Generate the HTML page for a module+unL (L _ x) = x+reL = L undefined -ppDecl :: HsDecl -> [String]-ppDecl (HsNewTypeDecl src context name args ctor unknown docs) =- ppData "newtype" context name args [ctor]+dropComment (' ':'-':'-':' ':_) = []+dropComment (x:xs) = x : dropComment xs+dropComment [] = [] -ppDecl (HsDataDecl src context name args ctors unknown docs) =- ppData "data" context name args ctors -ppDecl (HsTypeSig src names t doc) = map (`ppFunc` t) names+out :: Outputable a => a -> String+out = f . unwords . map (dropWhile isSpace) . lines . showSDocUnqual . ppr+ where+ f xs | " <document comment>" `isPrefixOf` xs = f $ drop 19 xs+ f (x:xs) = x : f xs+ f [] = [] -ppDecl (HsForeignImport src _ _ _ name t doc) = ppDecl $ HsTypeSig src [name] t doc -ppDecl (HsClassDecl src context name args fundeps members doc) =- ("class " ++ ppContext context ++ ppType typ) : concatMap f members+typeSig :: String -> [String] -> String+typeSig name flds = operator name ++ " :: " ++ concat (intersperse " -> " flds)+++operator :: String -> String+operator (x:xs) | not (isAlphaNum x) && x `notElem` " ([{" = "(" ++ x:xs ++ ")"+operator x = x+++---------------------------------------------------------------------+-- How to print each export++ppExport :: ExportItem Name -> [String]+ppExport (ExportDecl decl dc _) = doc dc ++ f (unL decl) where- typ = foldl HsTyApp (HsTyCon $ UnQual name) (map HsTyVar args)- newcontext = (UnQual name, map HsTyVar args)- f (HsTypeSig src names t doc) = ppDecl (HsTypeSig src names (addContext newcontext t) doc)- f (HsFunBind{}) = []- f (HsPatBind{}) = []- f x = ["-- ERR " ++ show x]+ f (TyClD d@TyData{}) = ppData 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+ f _ = []+ppExport _ = [] -ppDecl (HsTypeDecl src name args t doc) =- ["type " ++ show name ++ concatMap (\x -> ' ':show x) args ++ " = " ++ ppType t] -ppDecl x = ["-- ERR " ++ show x]+ppSig :: Sig Name -> [String]+ppSig (TypeSig name sig) = [operator (out name) ++ " :: " ++ out sig]+ppSig _ = [] +-- note: does not yet output documentation for class methods+ppClass :: TyClDecl Name -> [String]+ppClass x = out x{tcdSigs=[]} :+ map (out . addContext . unL) (tcdSigs x)+ where+ addContext (TypeSig name (L l sig)) = TypeSig name (L l $ f sig)+ f (HsForAllTy a b con d) = HsForAllTy a b (reL $ context : unL con) d+ f x = HsForAllTy Implicit [] (reL [context]) (reL x) -addContext :: HsAsst -> HsType -> HsType-addContext ctx (HsForAllType Nothing context t) = HsForAllType Nothing (HsAssump ctx : context) t-addContext ctx x = HsForAllType Nothing [HsAssump ctx] x+ context = reL $ HsClassP (unL $ tcdLName x)+ (map (reL . HsTyVar . tyVar . unL) (tcdTyVars x)) + tyVar (UserTyVar x) = x+ tyVar (KindedTyVar x _) = x -ppFunc :: HsName -> HsType -> String-ppFunc name typ = show name ++ " :: " ++ ppType typ+ppInstance :: Instance -> [String]+ppInstance x = [dropComment $ out x] -ppData :: String -> HsContext -> HsName -> [HsName] -> [HsConDecl] -> [String]-ppData mode context name args ctors = (mode ++ " " ++ ppType typ) : concatMap (ppCtor typ) ctors+ppData :: TyClDecl Name -> [String]+ppData x = showData x{tcdCons=[],tcdDerivs=Nothing} :+ concatMap (ppCtor x . unL) (tcdCons x) where- typ = foldl HsTyApp (HsTyCon $ UnQual name) (map HsTyVar args)- - -deBang :: HsBangType -> HsType-deBang (HsBangedTy x) = x-deBang (HsUnBangedTy x) = x+ -- GHC gives out "data Bar =", we want to delete the equals+ -- also writes data : a b, when we want data (:) a b+ showData x = unwords $ map f $ if last xs == "=" then init xs else xs+ where+ xs = words $ out x+ nam = out $ tcdLName x+ f x = if x == nam then operator nam else x -ppCtor :: HsType -> HsConDecl -> [String]-ppCtor result (HsConDecl src name types context typ doc) =- [show name ++ " :: " ++ ppContext context ++ ppTypesArr (map deBang typ ++ [result])]--ppCtor result (HsRecDecl src name types context fields doc) =- ppCtor result (HsConDecl src name types context (map snd fields2) doc) ++- concatMap f fields2+ppCtor :: TyClDecl Name -> ConDecl Name -> [String]+ppCtor dat con = ldoc (con_doc con) ++ f (con_details con) where- fields2 = [(name, typ) | HsFieldDecl names typ _ <- fields, name <- names]- f (name, typ) = ppDecl $ HsTypeSig src [name] (HsTyFun result (deBang typ)) doc+ f (PrefixCon args) = [typeSig name $ map out args ++ [resType]]+ f (InfixCon a1 a2) = f $ PrefixCon [a1,a2]+ f (RecCon recs) = f (PrefixCon $ map cd_fld_type recs) ++ concat+ [ldoc (cd_fld_doc r) +++ [out (unL $ cd_fld_name r) `typeSig` [resType, out $ cd_fld_type r]]+ | r <- recs] + name = out $ unL $ con_name con -brack True x = "(" ++ x ++ ")"-brack False x = x+ resType = case con_res con of+ ResTyH98 -> unwords $ operator (out (tcdLName dat)) : map out (tcdTyVars dat)+ ResTyGADT x -> out $ unL x -ppContext :: HsContext -> String-ppContext [] = ""-ppContext xs = brack (length xs > 1) (concat $ intersperse ", " $ map ppContextItem xs) ++ " => " -ppContextItem :: HsAsst -> String-ppContextItem (name, types) = ppQName name ++ concatMap (\x -> ' ':ppType x) types+---------------------------------------------------------------------+-- DOCUMENTATION -ppContext2 :: HsIPContext -> String-ppContext2 xs = ppContext [x | HsAssump x <- xs]+ldoc :: Maybe (LHsDoc Name) -> [String]+ldoc = doc . liftM unL +doc :: Maybe (HsDoc Name) -> [String]+doc Nothing = []+doc (Just d) = "" : zipWith (++) ("-- | " : repeat "-- ") (showTags $ markup markupTag d) -ppType :: HsType -> String-ppType x = f 0 x- where- f _ (HsTyTuple _ xs) = brack True $ concat $ intersperse ", " $ map (f 0) xs- f _ (HsTyCon x) = ppQName x- f _ (HsTyVar x) = show x - -- ignore ForAll types as Hoogle does not support them- f n (HsForAllType (Just items) context t) =- -- brack (n > 1) $- -- "forall" ++ concatMap (\x -> ' ':toStr x) items ++ " . " ++ f 0 t- f n t+data Tag = TagL Char [Tags] | TagP Tags | TagPre Tags | TagInline String Tags | Str String+ deriving Show - f n (HsForAllType Nothing context t) = brack (n > 1) $- ppContext2 context ++ f 0 t+type Tags = [Tag] - f n (HsTyFun a b) = brack g $ f (h 3) a ++ " -> " ++ f (h 2) b- where- g = n > 2- h x = if g then 0 else x- - f n (HsTyApp a b) | ppType a == "[]" = "[" ++ f 0 b ++ "]"- - f n (HsTyApp a b) = brack g $ f (h 3) a ++ " " ++ f (h 4) b- where- g = n > 3- h x = if g then 0 else x- - f n (HsTyDoc x _) = f n x+box f x = [f x]+str a = [Str a] - f n x = brack True $ show x+-- want things like paragraph, pre etc to be handled by blank lines in the source document+-- and things like \n and \t converted away+-- much like blogger in HTML mode+-- everything else wants to be included as tags, neatly nested for some (ul,li,ol)+-- or inlne for others (a,i,tt)+-- entities (&,>,<) should always be appropriately escaped +markupTag :: DocMarkup Name [Tag]+markupTag = Markup {+ markupParagraph = box TagP,+ markupEmpty = str "",+ markupString = str,+ markupAppend = (++),+ markupIdentifier = box (TagInline "a") . str . out . head,+ markupModule = box (TagInline "a") . str,+ markupEmphasis = box (TagInline "i"),+ markupMonospaced = box (TagInline "tt"),+ markupUnorderedList = box (TagL 'u'),+ markupOrderedList = box (TagL 'o'),+ markupDefList = box (TagL 'u') . map (\(a,b) -> TagInline "b" a : Str " " : b),+ markupCodeBlock = box TagPre,+ markupURL = box (TagInline "a") . str,+ markupAName = const $ str ""+ } -ppQName :: HsQName -> String-ppQName (Qual _ name) = show name-ppQName (UnQual name) = show name +showTags :: [Tag] -> [String]+showTags = concat . intersperse [""] . map showBlock+ where -ppTypesArr :: [HsType] -> String-ppTypesArr xs = ppType $ foldr1 HsTyFun xs+showBlock :: Tag -> [String]+showBlock (TagP xs) = showInline xs+showBlock (TagL t xs) = ['<':t:"l>"] ++ mid ++ ['<':'/':t:"l>"]+ where mid = concatMap (showInline . box (TagInline "li")) xs+showBlock (TagPre xs) = ["<pre>"] ++ showPre xs ++ ["</pre>"]+showBlock x = showInline [x] +asInline (TagP xs) = xs+asInline (TagPre xs) = [TagInline "pre" xs]+asInline (TagL t xs) = [TagInline (t:"l") $ map (TagInline "li") xs]+asInline x = [x] -ppInst :: InstHead -> String-ppInst (context, item) = "instance " ++ ppContext context ++ ppContextItem item +showInline :: [Tag] -> [String]+showInline = unwordsWrap 70 . words . concatMap f+ where+ fs = concatMap f+ f (Str x) = escape x+ f (TagInline s xs) = "<"++s++">" ++ (if s == "li" then trim else id) (fs xs) ++ "</"++s++">"+ f x = fs $ asInline x + trim = dropWhile isSpace . reverse . dropWhile isSpace . reverse -ppModule :: Interface -> [String]-ppModule iface = "" : ("module " ++ mdl) : concatMap ppExport (iface_exports iface)++showPre :: [Tag] -> [String]+showPre = trimFront . trimLines . lines . concatMap f where- Module mdl = iface_module iface+ trimLines = dropWhile null . reverse . dropWhile null . reverse+ trimFront xs = map (drop i) xs+ where+ ns = [length a | x <- xs, let (a,b) = span isSpace x, b /= ""]+ i = if null ns then 0 else minimum ns + fs = concatMap f+ f (Str x) = escape x+ f (TagInline s xs) = "<"++s++">" ++ fs xs ++ "</"++s++">"+ f x = fs $ asInline x -ppExport :: ExportItem -> [String]-ppExport (ExportDecl name decl insts) = ppDecl decl ++ map ppInst insts-ppExport _ = [] +unwordsWrap :: Int -> [String] -> [String]+unwordsWrap n = f n []+ where+ f i s [] = [g s | s /= []]+ f i s (x:xs) | nx > i = g s : f (n - nx - 1) [x] xs+ | otherwise = f (i - nx - 1) (x:s) xs+ where nx = length x --}+ g = unwords . reverse+++escape :: String -> String+escape = concatMap f+ where+ f '<' = "<"+ f '>' = ">"+ f '&' = "&"+ f x = [x]
src/Haddock/Backends/Html.hs view
@@ -1,4 +1,4 @@---+ -- Haddock - A Haskell Documentation Tool -- -- (c) Simon Marlow 2003@@ -30,7 +30,7 @@ import Control.Monad ( when, unless ) import Data.Char ( isUpper, toUpper ) import Data.List ( sortBy )-import Data.Maybe ( fromJust, isJust, mapMaybe, fromMaybe )+import Data.Maybe import Foreign.Marshal.Alloc ( allocaBytes ) import System.IO ( IOMode(..), hClose, hGetBuf, hPutBuf, openFile ) import Data.Map ( Map )@@ -549,7 +549,7 @@ exports = numberSectionHeadings (ifaceRnExportItems iface) - has_doc (ExportDecl _ _ doc _) = isJust doc+ has_doc (ExportDecl _ doc _) = isJust doc has_doc (ExportNoDecl _ _ _) = False has_doc (ExportModule _) = False has_doc _ = True@@ -626,8 +626,8 @@ processExport :: Bool -> LinksInfo -> DocMap -> (ExportItem DocName) -> HtmlTable processExport _ _ _ (ExportGroup lev id0 doc) = ppDocGroup lev (namedAnchor id0 << docToHtml doc)-processExport summary links docMap (ExportDecl x decl doc insts)- = doDecl summary links x decl doc insts docMap+processExport summary links docMap (ExportDecl decl doc insts)+ = ppDecl summary links decl doc insts docMap processExport summmary _ _ (ExportNoDecl _ y []) = declBox (ppDocName y) processExport summmary _ _ (ExportNoDecl _ y subs)@@ -655,19 +655,21 @@ declWithDoc False links loc nm (Just doc) html_decl = topDeclBox links loc nm html_decl </> docBox (docToHtml doc) -doDecl :: Bool -> LinksInfo -> Name -> LHsDecl DocName -> - Maybe (HsDoc DocName) -> [InstHead DocName] -> DocMap -> HtmlTable-doDecl summary links x (L loc d) mbDoc instances docMap = doDecl d- where- doDecl (TyClD d) = doTyClD d - doDecl (SigD (TypeSig (L _ n) (L _ t))) = - ppFunSig summary links loc mbDoc (docNameOrig n) t- doDecl (ForD d) = ppFor summary links loc mbDoc d - doTyClD d0@(TyData {}) = ppDataDecl summary links instances x loc mbDoc d0- doTyClD d0@(TySynonym {}) = ppTySyn summary links loc mbDoc d0- doTyClD d0@(ClassDecl {}) = ppClassDecl summary links instances x loc mbDoc docMap d0-+ppDecl :: Bool -> LinksInfo -> LHsDecl DocName -> + Maybe (HsDoc DocName) -> [InstHead DocName] -> DocMap -> HtmlTable+ppDecl summ links (L loc decl) mbDoc instances docMap = case decl of+ TyClD d@(TyFamily {}) -> ppTyFam summ False links loc mbDoc d+ TyClD d@(TyData {})+ | Nothing <- tcdTyPats d -> ppDataDecl summ links instances loc mbDoc d+ | Just _ <- tcdTyPats d -> ppDataInst summ links loc mbDoc d + TyClD d@(TySynonym {})+ | Nothing <- tcdTyPats d -> ppTySyn summ links loc mbDoc d+ | Just _ <- tcdTyPats d -> ppTyInst summ False links loc mbDoc d+ TyClD d@(ClassDecl {}) -> ppClassDecl summ links instances loc mbDoc docMap d+ SigD (TypeSig (L _ n) (L _ t)) -> ppFunSig summ links loc mbDoc (docNameOrig n) t+ ForD d -> ppFor summ links loc mbDoc d+ InstD d -> Html.emptyTable ppFunSig :: Bool -> LinksInfo -> SrcSpan -> Maybe (HsDoc DocName) -> Name -> HsType DocName -> HtmlTable@@ -753,6 +755,141 @@ --------------------------------------------------------------------------------+-- Type families+--------------------------------------------------------------------------------+++ppTyFamHeader :: Bool -> Bool -> TyClDecl DocName -> Html+ppTyFamHeader summary associated decl =++ (case tcdFlavour decl of+ TypeFamily+ | associated -> keyword "type"+ | otherwise -> keyword "type family"+ DataFamily+ | associated -> keyword "data"+ | otherwise -> keyword "data family"+ ) <+>++ ppTyClBinderWithVars summary decl <+>++ case tcdKind decl of+ Just kind -> dcolon <+> ppKind kind + Nothing -> empty+++ppTyFam :: Bool -> Bool -> LinksInfo -> SrcSpan -> Maybe (HsDoc DocName) ->+ TyClDecl DocName -> HtmlTable+ppTyFam summary associated links loc mbDoc decl+ + | summary = declWithDoc summary links loc name mbDoc + (ppTyFamHeader True associated decl)+ + | associated, isJust mbDoc = header </> bodyBox << doc + | associated = header + | null instances, isJust mbDoc = header </> bodyBox << doc+ | null instances = header+ | isJust mbDoc = header </> bodyBox << (doc </> instancesBit)+ | otherwise = header </> bodyBox << instancesBit++ where+ name = docNameOrig . tcdName $ decl++ header = topDeclBox links loc name (ppTyFamHeader summary associated decl)++ doc = ndocBox . docToHtml . fromJust $ mbDoc ++ instId = collapseId name++ instancesBit = instHdr instId </>+ tda [theclass "body"] << + collapsed thediv instId (+ spacedTable1 << (+ aboves (map (declBox . ppInstHead) instances)+ )+ )++ -- TODO: get the instances+ instances = []+++--------------------------------------------------------------------------------+-- Indexed data types+--------------------------------------------------------------------------------+++ppDataInst = undefined+++--------------------------------------------------------------------------------+-- Indexed newtypes+--------------------------------------------------------------------------------+++ppNewTyInst = undefined+++--------------------------------------------------------------------------------+-- Indexed types+--------------------------------------------------------------------------------++ +ppTyInst :: Bool -> Bool -> LinksInfo -> SrcSpan -> Maybe (HsDoc DocName) ->+ TyClDecl DocName -> HtmlTable+ppTyInst summary associated links loc mbDoc decl+ + | summary = declWithDoc summary links loc name mbDoc+ (ppTyInstHeader True associated decl)+ + | isJust mbDoc = header </> bodyBox << doc + | otherwise = header++ where+ name = docNameOrig . tcdName $ decl++ header = topDeclBox links loc name (ppTyInstHeader summary associated decl)++ doc = case mbDoc of+ Just d -> ndocBox (docToHtml d)+ Nothing -> Html.emptyTable+++ppTyInstHeader :: Bool -> Bool -> TyClDecl DocName -> Html+ppTyInstHeader summary associated decl =++ keyword "type instance" <+>++ ppAppNameTypes (tcdName decl) typeArgs+ where+ typeArgs = map unLoc . fromJust . tcdTyPats $ decl+++--------------------------------------------------------------------------------+-- Associated Types+--------------------------------------------------------------------------------+ ++ppAssocType :: Bool -> LinksInfo -> DocMap -> LTyClDecl DocName -> HtmlTable+ppAssocType summ links docMap (L loc decl) = + case decl of+ TyFamily {} -> ppTyFam summ True links loc doc decl+ TySynonym {} -> ppTySyn summ links loc doc decl+ where+ doc = Map.lookup (docNameOrig $ tcdName decl) docMap+++--------------------------------------------------------------------------------+-- TyClDecl helpers+--------------------------------------------------------------------------------+++-- | Print a type family / newtype / data / class binder and its variables +ppTyClBinderWithVars :: Bool -> TyClDecl DocName -> Html+ppTyClBinderWithVars summ decl = + ppAppDocNameNames summ (unLoc $ tcdLName decl) (tyvarNames $ tcdTyVars decl)+++-------------------------------------------------------------------------------- -- Type applications -------------------------------------------------------------------------------- @@ -763,8 +900,8 @@ -- | Print an application of a DocName and a list of Names -ppDataClassHead :: Bool -> DocName -> [Name] -> Html-ppDataClassHead summ n ns = +ppAppDocNameNames :: Bool -> DocName -> [Name] -> Html+ppAppDocNameNames summ n ns = ppTypeApp n ns (ppBinder summ . docNameOcc) ppTyName @@ -780,9 +917,9 @@ ppTypeApp n ts ppDN ppT = ppDN n <+> hsep (map ppT ts) ---------------------------------------------------------------------------------+------------------------------------------------------------------------------- -- Contexts ---------------------------------------------------------------------------------+------------------------------------------------------------------------------- ppLContext = ppContext . unLoc ppLContextNoArrow = ppContextNoArrow . unLoc@@ -812,13 +949,15 @@ = toHtml "?" +++ ppDocName n <+> dcolon <+> ppLType t --- -----------------------------------------------------------------------------+------------------------------------------------------------------------------- -- Class declarations+------------------------------------------------------------------------------- + ppClassHdr summ lctxt n tvs fds = keyword "class" <+> (if not . null . unLoc $ lctxt then ppLContext lctxt else empty)- <+> ppDataClassHead summ n (tyvarNames $ tvs)+ <+> ppAppDocNameNames summ n (tyvarNames $ tvs) <+> ppFds fds ppFds fds =@@ -834,39 +973,37 @@ then (if summary then declBox else topDeclBox links loc nm) hdr else (if summary then declBox else topDeclBox links loc nm) (hdr <+> keyword "where") </> - (tda [theclass "body"] << - vanillaTable << - aboves ([ ppAT summary at | L _ at <- ats ] ++- [ ppFunSig summary links loc mbDoc n typ- | L _ (TypeSig (L _ fname) (L _ typ)) <- sigs- , let n = docNameOrig fname, let mbDoc = Map.lookup n docMap ])- )+ (+ bodyBox <<+ aboves+ (+ map (ppAssocType summary links docMap) ats ++++ [ ppFunSig summary links loc mbDoc n typ+ | L _ (TypeSig (L _ fname) (L _ typ)) <- sigs+ , let n = docNameOrig fname, let mbDoc = Map.lookup n docMap ] ++ )+ ) where hdr = ppClassHdr summary lctxt (unLoc lname) tvs fds nm = docNameOrig . unLoc $ lname - ppAT summary at = case at of- TyData {} -> topDeclBox links loc nm (ppDataHeader summary at)- _ -> error "associated type synonyms or type families not supported yet" --- we skip ATs for now-ppClassDecl :: Ord key => Bool -> LinksInfo -> [InstHead DocName] -> key -> SrcSpan ->- Maybe (HsDoc DocName) -> DocMap -> TyClDecl DocName -> - HtmlTable-ppClassDecl summary links instances orig_c loc mbDoc docMap- decl@(ClassDecl lctxt lname ltyvars lfds lsigs _ _ _)++ppClassDecl :: Bool -> LinksInfo -> [InstHead DocName] -> SrcSpan ->+ Maybe (HsDoc DocName) -> DocMap -> TyClDecl DocName -> + HtmlTable+ppClassDecl summary links instances loc mbDoc docMap+ decl@(ClassDecl lctxt lname ltyvars lfds lsigs _ ats _) | summary = ppShortClassDecl summary links decl loc docMap- | otherwise- = classheader </>- tda [theclass "body"] << vanillaTable << (- classdoc </> methodsBit </> instancesBit- )+ | otherwise = classheader </> bodyBox << (classdoc </> body </> instancesBit) where classheader | null lsigs = topDeclBox links loc nm hdr | otherwise = topDeclBox links loc nm (hdr <+> keyword "where") - nm = docNameOrig . unLoc $ lname+ nm = docNameOrig . unLoc $ tcdLName decl ctxt = unLoc lctxt hdr = ppClassHdr summary lctxt (unLoc lname) ltyvars lfds@@ -875,16 +1012,19 @@ Nothing -> Html.emptyTable Just d -> ndocBox (docToHtml d) - methodsBit- | null lsigs = Html.emptyTable- | otherwise = - s8 </> methHdr </>- tda [theclass "body"] << vanillaTable << (- abovesSep s8 [ ppFunSig summary links loc mbDoc (docNameOrig n) typ- | L _ (TypeSig (L _ n) (L _ typ)) <- lsigs- , let mbDoc = Map.lookup (docNameOrig n) docMap ]- )+ body+ | null lsigs, null ats = Html.emptyTable+ | null ats = s8 </> methHdr </> bodyBox << methodTable+ | otherwise = s8 </> atHdr </> bodyBox << atTable </> + s8 </> methHdr </> bodyBox << methodTable + + methodTable =+ abovesSep s8 [ ppFunSig summary links loc doc (docNameOrig n) typ+ | L _ (TypeSig (L _ n) (L _ typ)) <- lsigs+ , let doc = Map.lookup (docNameOrig n) docMap ] + atTable = abovesSep s8 $ map (ppAssocType summary links docMap) ats+ instId = collapseId nm instancesBit | null instances = Html.emptyTable@@ -945,15 +1085,15 @@ cons = tcdCons dataDecl resTy = (con_res . unLoc . head) cons -ppDataDecl :: Ord key => Bool -> LinksInfo -> [InstHead DocName] -> key -> +ppDataDecl :: Bool -> LinksInfo -> [InstHead DocName] -> SrcSpan -> Maybe (HsDoc DocName) -> TyClDecl DocName -> HtmlTable-ppDataDecl summary links instances x loc mbDoc dataDecl+ppDataDecl summary links instances loc mbDoc dataDecl | summary = declWithDoc summary links loc name mbDoc (ppShortDataDecl summary links loc mbDoc dataDecl) | otherwise- = (if validTable then (</>) else const) dataHeader $+ = (if validTable then (</>) else const) header $ tda [theclass "body"] << vanillaTable << ( datadoc </> constrBit </>@@ -970,9 +1110,8 @@ cons = tcdCons dataDecl resTy = (con_res . unLoc . head) cons - dataHeader = - (if summary then declBox else topDeclBox links loc name)- ((ppDataHeader summary dataDecl) <+> whereBit)+ header = topDeclBox links loc name (ppDataHeader summary dataDecl+ <+> whereBit) whereBit | null cons = empty @@ -1157,7 +1296,7 @@ -- context ppLContext (tcdCtxt decl) <+> -- T a b c ..., or a :+: b- ppDataClassHead summary (unLoc $ tcdLName decl) (tyvarNames $ tcdTyVars decl)+ ppTyClBinderWithVars summary decl -- ----------------------------------------------------------------------------@@ -1197,10 +1336,13 @@ HsSpliceTy _ -> error "ppType" HsDocTy t _ -> ppLType t -}++ -------------------------------------------------------------------------------- -- Rendering of HsType -------------------------------------------------------------------------------- + pREC_TOP = (0 :: Int) -- type in ParseIface.y in GHC pREC_FUN = (1 :: Int) -- btype in ParseIface.y in GHC -- Used for LH arg of (->)@@ -1227,16 +1369,12 @@ ppLParendType = ppParendType . unLoc -ppType ty = ppr_mono_ty pREC_TOP (prepare ty)+ppType ty = ppr_mono_ty pREC_TOP ty ppParendType ty = ppr_mono_ty pREC_CON ty --- Before printing a type--- (a) Remove outermost HsParTy parens--- (b) Drop top-level for-all type variables in user style--- since they are implicit in Haskell-prepare (HsParTy ty) = prepare (unLoc ty)-prepare ty = ty+-- Drop top-level for-all type variables in user style+-- since they are implicit in Haskell ppForAll exp tvs cxt | show_forall = forall_part <+> ppLContext cxt@@ -1253,7 +1391,7 @@ hsep [ppForAll exp tvs ctxt, ppr_mono_lty pREC_TOP ty] -- gaw 2004-ppr_mono_ty ctxt_prec (HsBangTy b ty) = ppBang b +++ ppLType ty+ppr_mono_ty ctxt_prec (HsBangTy b ty) = ppBang b +++ ppLParendType ty ppr_mono_ty ctxt_prec (HsTyVar name) = ppDocName name ppr_mono_ty ctxt_prec (HsFunTy ty1 ty2) = ppr_fun_ty ctxt_prec ty1 ty2 ppr_mono_ty ctxt_prec (HsTupleTy con tys) = tupleParens con (map ppLType tys)@@ -1269,17 +1407,18 @@ hsep [ppr_mono_lty pREC_FUN fun_ty, ppr_mono_lty pREC_CON arg_ty] ppr_mono_ty ctxt_prec (HsOpTy ty1 op ty2)- = maybeParen ctxt_prec pREC_OP $+ = maybeParen ctxt_prec pREC_FUN $ ppr_mono_lty pREC_OP ty1 <+> ppr_op <+> ppr_mono_lty pREC_OP ty2 where ppr_op = if not (isSymOcc occName) then quote (ppLDocName op) else ppLDocName op occName = docNameOcc . unLoc $ op ppr_mono_ty ctxt_prec (HsParTy ty)- = parens (ppr_mono_lty pREC_TOP ty)+-- = parens (ppr_mono_lty pREC_TOP ty)+ = ppr_mono_lty ctxt_prec ty ppr_mono_ty ctxt_prec (HsDocTy ty doc)- = ppLType ty+ = ppr_mono_lty ctxt_prec ty ppr_fun_ty ctxt_prec ty1 ty2 = let p1 = ppr_mono_lty pREC_FUN ty1@@ -1349,7 +1488,7 @@ markupString = toHtml, markupAppend = (+++), markupIdentifier = tt . ppId . head,- markupModule = \m -> ppModule (mkModuleNoPkg m) "",+ markupModule = \m -> ppModule (mkModuleNoPackage m) "", markupEmphasis = emphasize . toHtml, markupMonospaced = tt . toHtml, markupUnorderedList = ulist . concatHtml . map (li <<),@@ -1526,6 +1665,9 @@ topButBox :: Html -> HtmlTable topButBox html = tda [theclass "topbut"] << html +bodyBox :: Html -> HtmlTable+bodyBox html = tda [theclass "body"] << vanillaTable << html+ -- a vanilla table has width 100%, no border, no padding, no spacing -- a narrow table is the same but without width 100%. vanillaTable, narrowTable :: Html -> Html@@ -1540,6 +1682,7 @@ constrHdr, methHdr :: HtmlTable constrHdr = tda [ theclass "section4" ] << toHtml "Constructors" methHdr = tda [ theclass "section4" ] << toHtml "Methods"+atHdr = tda [ theclass "section4" ] << toHtml "Associated Types" instHdr :: String -> HtmlTable instHdr id =
src/Haddock/GHC/Typecheck.hs view
@@ -75,10 +75,15 @@ ghcGroup = group, ghcMbExports = mbExports, ghcExportedNames = modInfoExports modInfo,+ ghcDefinedNames = map getName $ modInfoTyThings modInfo, ghcNamesInScope = fromJust $ modInfoTopLevelScope modInfo, ghcInstances = modInfoInstances modInfo } where- HsModule _ _ _ _ _ mbOpts _ _ = unLoc parsed+#if __GLASGOW_HASKELL__ == 608 && __GHC_PATCHLEVEL__ == 2+ HsModule _ _ _ _ _ mbOpts _ _ = unLoc parsed+#else+ mbOpts = haddockOptions dynflags+#endif (group, _, mbExports, mbDoc, info) = renamed- (parsed, renamed, _, modInfo) = checkedMod+ (parsed, renamed, _, modInfo) = checkedMod
src/Haddock/GHC/Utils.hs view
@@ -13,6 +13,7 @@ import Data.Char+import Data.Version import qualified Data.Map as Map import GHC@@ -27,13 +28,21 @@ moduleString = moduleNameString . moduleName -modulePkgStr = packageIdString . modulePackageId+-- return the name of the package, with version info+modulePackageString = packageIdString . modulePackageId -mkModuleNoPkg :: String -> Module-mkModuleNoPkg str = mkModule (stringToPackageId "") (mkModuleName str)+-- return the (name,version) of the package+modulePackageInfo mod = case unpackPackageId pkg of+ Nothing -> (packageIdString pkg, "")+ Just x -> (pkgName x, showVersion (pkgVersion x))+ where pkg = modulePackageId mod +mkModuleNoPackage :: String -> Module+mkModuleNoPackage str = mkModule (stringToPackageId "") (mkModuleName str)++ instance (Outputable a, Outputable b) => Outputable (Map.Map a b) where ppr m = ppr (Map.toList m) @@ -59,8 +68,8 @@ pretty :: Outputable a => a -> String-pretty x = show (ppr x defaultUserStyle)+pretty x = showSDoc (ppr x) trace_ppr :: Outputable a => a -> b -> b-trace_ppr x y = trace (showSDoc (ppr x)) y+trace_ppr x y = trace (pretty x) y
src/Haddock/Interface/AttachInstances.hs view
@@ -43,11 +43,12 @@ where newItems = map attachExport (ifaceExportItems mod) - attachExport (ExportDecl n decl doc _) =- ExportDecl n decl doc (case Map.lookup n instMap of- Nothing -> []- Just instheads -> instheads)- attachExport otherExport = otherExport+ attachExport (ExportDecl decl@(L _ (TyClD d)) doc _)+ | isClassDecl d || isDataDecl d || isFamilyDecl d =+ ExportDecl decl doc (case Map.lookup (tcdName d) instMap of+ Nothing -> []+ Just instheads -> instheads)+ attachExport export = export --------------------------------------------------------------------------------@@ -71,8 +72,8 @@ where allInstances = concat (map ifaceInstances modules) classInstPairs = [ (is_cls inst, [instanceHead inst]) | - inst <- allInstances, Just n <- nub (is_tcs inst), - n `elem` filterNames ]+ inst <- allInstances, Just n <- nub (is_tcs inst) ]+ -- n `elem` filterNames ] tyInstPairs = [ (tycon, [instanceHead inst]) | inst <- allInstances, Just tycon <- nub (is_tcs inst) ]
src/Haddock/Interface/Create.hs view
@@ -20,6 +20,7 @@ import Data.Char import Data.Ord import Control.Monad+import Control.Arrow import GHC import Outputable@@ -34,10 +35,6 @@ import PrelNames import Bag import HscTypes-import Util (handleDyn)-import ErrUtils (printBagOfErrors)-import FastString-#define FSLIT(x) (mkFastString# (x#)) -- | Process the data in the GhcModule to produce an interface.@@ -54,26 +51,26 @@ | otherwise = opts0 let group = ghcGroup ghcMod- entities = (nubBy sameName . getTopEntities) group exports = fmap (reverse . map unLoc) (ghcMbExports ghcMod)- entityNames_ = entityNames entities- subNames = allSubNames group- localNames = entityNames_ ++ subNames+ localNames = ghcDefinedNames ghcMod subMap = mkSubMap group- expDeclMap = mkDeclMap (ghcExportedNames ghcMod) group- localDeclMap = mkDeclMap entityNames_ group- docMap = mkDocMap group + decls = topDecls group+ decls' = filterOutInstances decls+ declMap = mkDeclMap decls'+ famMap = Map.empty --mkFamMap decls' ignoreExps = Flag_IgnoreAllExports `elem` flags exportedNames = ghcExportedNames ghcMod origEnv = Map.fromList [ (nameOccName n, n) | n <- exportedNames ]+ instances = ghcInstances ghcMod + warnAboutFilteredDecls mod decls+ visibleNames <- mkVisibleNames mod modMap localNames (ghcNamesInScope ghcMod) - subMap exports opts localDeclMap + subMap exports opts declMap - exportItems <- mkExportItems modMap mod (ghcExportedNames ghcMod)- expDeclMap localDeclMap subMap entities - opts exports ignoreExps docMap + exportItems <- mkExportItems modMap mod (ghcExportedNames ghcMod) decls' declMap+ famMap subMap opts exports ignoreExps instances -- prune the export list to just those declarations that have -- documentation, if the 'prune' option is on.@@ -90,7 +87,6 @@ ifaceRnDoc = Nothing, ifaceOptions = opts, ifaceLocals = localNames,- ifaceDocMap = docMap, ifaceRnDocMap = Map.empty, ifaceSubMap = subMap, ifaceExportItems = prunedExportItems,@@ -98,7 +94,7 @@ ifaceEnv = origEnv, ifaceExports = exportedNames, ifaceVisibleExports = visibleNames, - ifaceExportedDeclMap = expDeclMap,+ ifaceDeclMap = declMap, ifaceInstances = ghcInstances ghcMod } @@ -131,76 +127,173 @@ ----------------------------------------------------------------------------------- Source code entities--- --- An entity is a Haskell declaration or a Haddock comment. We need to extract--- entities out of classes and top levels since we need them in the interface. +-- Declarations -------------------------------------------------------------------------------- +type DeclWithDoc = (LHsDecl Name, Maybe (HsDoc Name)) -data Entity = DocEntity (DocDecl Name) | DeclEntity Name-data LEntity = Located Entity -sameName (DocEntity _) _ = False-sameName (DeclEntity _) (DocEntity _) = False-sameName (DeclEntity a) (DeclEntity b) = a == b+-- | A list of type or data instance declarations with an optional family+-- declaration.+type Family = (Maybe DeclWithDoc, [DeclWithDoc]) -sortByLoc = map unLoc . sortBy (comparing getLoc)+-- | Make a map from names to declarations with documentation. The map excludes+-- all kinds of instance declarations (including type family instances) and+-- documentation declarations.+-- Subordinate names are mapped to the parent declaration, but with the doc+-- for the subordinate declaration.+mkDeclMap :: [DeclWithDoc] -> Map Name DeclWithDoc+mkDeclMap decls = Map.fromList [ (n, (L loc d, doc)) | (L loc d, doc) <- decls + , (n, doc) <- (declName d, doc) : subordinates d+ , not (isDoc d), not (isInstance d) ] --- | Get all the entities in a class. The entities are sorted by their --- SrcLoc.-getClassEntities tcd = sortByLoc (docs ++ meths ++ sigs)+-- | Group type family instances together. Include the family declaration+-- if found.+{-mkFamMap :: [DeclWithDoc] -> Map Name Family+mkFamMap decls = + Map.fromList [ (tcdName $ ex $ head $ g, family g) | g <- groups ] where- docs = [ L l (DocEntity d) | L l d <- tcdDocs tcd ]+ family g = first listToMaybe $ partition (isFamilyDecl . ex) g+ groups = groupBy (comparing (tcdName . ex)) $ + filter (isTyClD . unLoc . fst) decls+ ex ((L _ (TyClD d)), _) = d+-} - meths = - let bindings = bagToList (tcdMeths tcd)- bindingName = unLoc . fun_id- in [ L l (DeclEntity (bindingName b)) | L l b <- bindings ] +isTyClD (TyClD _) = True+isTyClD _ = False - -- TODO: fixities- sigs = [ L l $ DeclEntity name | L l (TypeSig (L _ name) _) <- tcdSigs tcd ] +isDoc (DocD _) = True+isDoc _ = False --- | Get all the top level entities in a module. The entities are sorted by--- their SrcLoc.-getTopEntities :: HsGroup Name -> [Entity]-getTopEntities group = sortByLoc (docs ++ declarations)++isInstance (InstD _) = True+isInstance (TyClD d) = isFamInstDecl d+isInstance _ = False+++subordinates (TyClD d) = classDataSubs d+subordinates _ = []+++classDataSubs :: TyClDecl Name -> [(Name, Maybe (HsDoc Name))]+classDataSubs decl+ | isClassDecl decl = classMeths+ | isDataDecl decl = recordFields+ | otherwise = [] where- docs = [ L l (DocEntity d) | L l d <- hs_docs group ]+ classMeths = [ (declName d, doc) | (L _ d, doc) <- classDecls decl ]+ recordFields = [ (unLoc lname, fmap unLoc doc) |+ ConDeclField lname _ doc <- fields ]+ cons = [ con | L _ con <- tcdCons decl ]+ fields = concat [ fields | RecCon fields <- map con_details cons] - declarations = [ L l (DeclEntity n) | (l, n) <- valds ++ tyclds ++ fords ]- where- valds = let ValBindsOut _ sigs = hs_valds group - -- we just use the sigs here for now.- -- TODO: collect from the bindings as well - -- (needed for docs to work for inferred entities)- in [ (l, fromJust (sigNameNoLoc s)) | L l s <- sigs, - isVanillaLSig (L l s) ] -- TODO: document fixity decls- tyclds = [ (l, tcdName t) | L l t <- hs_tyclds group ]- fords = [ (l, forName f) | L l f <- hs_fords group ] - where- forName (ForeignImport name _ _) = unLoc name- forName (ForeignExport name _ _) = unLoc name +-- All the sub declarations of a class (except default methods), ordered by+-- source location, with documentation attached if it exists. +classDecls = filter notDef . collectDocs . sortByLoc . declsFromClass+ where+ notDef (L _ (ValD _), _) = False+ notDef _ = True ++declsFromClass class_ = docs ++ defs ++ sigs ++ ats+ where + docs = decls tcdDocs DocD class_+ defs = decls (bagToList . tcdMeths) ValD class_+ sigs = decls tcdSigs SigD class_+ ats = decls tcdATs TyClD class_+++declName (TyClD d) = tcdName d+declName (ForD (ForeignImport n _ _)) = unLoc n+-- we have normal sigs only (since they are taken from ValBindsOut)+declName (SigD sig) = fromJust $ sigNameNoLoc sig+++-- All the top-level declarations of a module, ordered by source location,+-- with documentation attached if it exists.+topDecls :: HsGroup Name -> [DeclWithDoc] +topDecls = collectDocs . sortByLoc . declsFromGroup +++filterOutInstances = filter (\(L _ d, _) -> not (isInstance d))+++-- | Pick out the declarations that we want from a group+declsFromGroup :: HsGroup Name -> [LHsDecl Name]+declsFromGroup group = + decls hs_tyclds TyClD group +++ decls hs_fords ForD group +++ decls hs_docs DocD group +++ decls hs_instds InstD group +++ decls (sigs . hs_valds) SigD group+ where+ sigs (ValBindsOut _ x) = x+++-- | Take a field of declarations from a data structure and create HsDecls+-- using the given constructor+decls field con struct = [ L loc (con decl) | L loc decl <- field struct ]+++-- | Sort by source location+sortByLoc = sortBy (comparing getLoc)+++warnAboutFilteredDecls mod decls = do+ let modStr = moduleString mod+ let typeInstances =+ nub [ tcdName d | (L _ (TyClD d), _) <- decls, isFamInstDecl d ]++ when (not $null typeInstances) $+ tell $ nub [+ "Warning: " ++ modStr ++ ": Instances of type and data "+ ++ "families are not yet supported. Instances of the following families "+ ++ "will be filtered out:\n " ++ (concat $ intersperse ", "+ $ map (occNameString . nameOccName) typeInstances) ]++ let instances = nub [ pretty i | (L _ (InstD (InstDecl i _ _ ats)), _) <- decls+ , not (null ats) ]++ when (not $ null instances) $++ tell $ nub $ [+ "Warning: " ++ modStr ++ ": Rendering of associated types for instances has "+ ++ "not yet been implemented. Associated types will not be shown for the "+ ++ "following instances:\n" ++ (concat $ intersperse ", " instances) ]++ --------------------------------------------------------------------------------+-- Instances+--------------------------------------------------------------------------------++{-+matchingInsts :: Name -> [Instances] -> [Instances]+matchingInsts name instances = filter ((==) name . is_cls) instances+++instToData :: Instance -> LHsDecl Name+instToData inst = TyData {+-}++-------------------------------------------------------------------------------- -- Collect docs -- -- To be able to attach the right Haddock comment to the right declaration,--- we sort the entities by their SrcLoc and "collect" the docs for each +-- we sort the declarations by their SrcLoc and "collect" the docs for each -- declaration. -------------------------------------------------------------------------------- --- | Collect the docs and attach them to the right name-collectDocs :: [Entity] -> [(Name, HsDoc Name)]-collectDocs entities = collect Nothing DocEmpty entities+-- | Collect the docs and attach them to the right declaration+collectDocs :: [LHsDecl Name] -> [DeclWithDoc]+collectDocs decls = collect Nothing DocEmpty decls -collect :: Maybe Entity -> HsDoc Name -> [Entity] -> [(Name, HsDoc Name)]+collect :: Maybe (LHsDecl Name) -> HsDoc Name -> [LHsDecl Name] -> [DeclWithDoc] collect d doc_so_far [] = case d of Nothing -> []@@ -208,54 +301,30 @@ collect d doc_so_far (e:es) = case e of- DocEntity (DocCommentNext str) ->+ L _ (DocD (DocCommentNext str)) -> case d of Nothing -> collect d (docAppend doc_so_far str) es Just d0 -> finishedDoc d0 doc_so_far (collect Nothing str es) - DocEntity (DocCommentPrev str) -> collect d (docAppend doc_so_far str) es+ L _ (DocD (DocCommentPrev str)) -> collect d (docAppend doc_so_far str) es _ -> case d of Nothing -> collect (Just e) doc_so_far es Just d0- | sameName d0 e -> collect d doc_so_far es + | sameDecl d0 e -> collect d doc_so_far es | otherwise -> finishedDoc d0 doc_so_far (collect (Just e) DocEmpty es) -finishedDoc :: Entity -> HsDoc Name -> [(Name, HsDoc Name)] -> - [(Name, HsDoc Name)]-finishedDoc d DocEmpty rest = rest-finishedDoc (DeclEntity name) doc rest = (name, doc) : rest+finishedDoc :: LHsDecl Name -> HsDoc Name -> [DeclWithDoc] -> [DeclWithDoc]+finishedDoc d DocEmpty rest = (d, Nothing) : rest+finishedDoc d doc rest | notDocDecl d = (d, Just doc) : rest+ where+ notDocDecl (L _ (DocD _)) = False+ notDocDecl _ = True finishedDoc _ _ rest = rest ----------------------------------------------------------------------------------- ------------------------------------------------------------------------------------- This map includes everything that can be exported separately,--- that means: top declarations, class methods and record selectors--- TODO: merge this with mkDeclMap and the extractXXX functions -mkDocMap :: HsGroup Name -> Map Name (HsDoc Name)-mkDocMap group = Map.fromList (topDeclDocs ++ classMethDocs ++ recordFieldDocs)- where- tyclds = map unLoc (hs_tyclds group)- classes = filter isClassDecl tyclds - datadecls = filter isDataDecl tyclds- constrs = [ con | d <- datadecls, L _ con <- tcdCons d ]- fields = concat [ fields | RecCon fields <- map con_details constrs]-- topDeclDocs = collectDocs (getTopEntities group)- classMethDocs = concatMap (collectDocs . getClassEntities) classes-- recordFieldDocs = [ (unLoc lname, doc) | - ConDeclField lname _ (Just (L _ doc)) <- fields ]-- -allSubNames :: HsGroup Name -> [Name]-allSubNames group = - concat [ tail (map unLoc (tyClDeclNames tycld)) | L _ tycld <- hs_tyclds group ]+sameDecl d1 d2 = getLoc d1 == getLoc d2 mkSubMap :: HsGroup Name -> Map Name [Name]@@ -263,78 +332,6 @@ let name:subs = map unLoc (tyClDeclNames tycld) ] -mkDeclMap :: [Name] -> HsGroup Name -> Map Name (LHsDecl Name) -mkDeclMap names group = Map.fromList [ (n,d) | (n,Just d) <- maybeDecls ]- where - maybeDecls = [ (name, getDeclFromGroup group name) | name <- names ]---entityNames :: [Entity] -> [Name]-entityNames entities = [ name | DeclEntity name <- entities ] -{--getValSig :: Name -> HsValBinds Name -> TypeEnv -> Maybe (LSig Name)-getValSig name (ValBindsOut recsAndBinds _) typEnv = case matchingBinds of- [bind] -> -- OK we have found a binding that matches. Now look up the- -- type, even though it may be present in the ValBindsOut- let tything = lookupTypeEnv typeEnv name - _ -> Nothing- where - binds = snd $ unzip recsAndBinds - matchingBinds = Bag.filter matchesName binds- matchesName (L _ bind) = fun_id bind == name-getValSig _ _ _ = error "getValSig"--}---getDeclFromGroup :: HsGroup Name -> Name -> Maybe (LHsDecl Name)-getDeclFromGroup group name = - case catMaybes [ getDeclFromVals (hs_valds group), - getDeclFromTyCls (hs_tyclds group),- getDeclFromFors (hs_fords group) ] of- [decl] -> Just decl- _ -> Nothing- where - getDeclFromVals (ValBindsOut _ lsigs) = case matching of - [lsig] -> Just (L (getLoc lsig) (SigD (unLoc lsig)))- _ -> Nothing- where - matching = [ s | s@(L l (TypeSig (L _ n) _)) <- lsigs, n == name ]-- getDeclFromVals _ = error "getDeclFromVals: illegal input"--{- getDeclFromVals (ValBindsOut recsAndbinds _) = - let binds = snd $ unzip recsAndBinds - matchingBinds = Bag.filter matchesName binds- matchesName (L _ bind) = fun_id bind == name- in case matchingBinds of - [bind] -> -- OK we have found a binding that matches. Now look up the- -- type, even though it may be present in the ValBindsOut- - _ -> Nothing- where - matching = [ lsig | lsig <- lsigs, let Just n = sigName lsig, n == name ]- getDeclFromVals _ = error "getDeclFromVals: illegal input"- -} - getDeclFromTyCls ltycls = case matching of - [ltycl] -> Just (L (getLoc ltycl) (TyClD (unLoc ltycl)))- _ -> Nothing- where- matching = [ fmap makeVanillaClass ltycl | ltycl <- ltycls,- name `elem` (map unLoc . tyClDeclNames . unLoc $ ltycl)]- where - makeVanillaClass tycl- | isClassDecl tycl = tycl { tcdSigs = filter isVanillaLSig (tcdSigs tycl) }- | otherwise = tycl- - getDeclFromFors lfors = case matching of - [for] -> Just (L (getLoc for) (ForD (unLoc for)))- _ -> Nothing- where- matching = [ for | for <- lfors, forName (unLoc for) == name ]- forName (ForeignExport n _ _) = unLoc n- forName (ForeignImport n _ _) = unLoc n-- -- | Build the list of items that will become the documentation, from the -- export list. At this point, the list of ExportItems is in terms of -- original names.@@ -342,46 +339,52 @@ :: ModuleMap -> Module -- this module -> [Name] -- exported names (orig)- -> Map Name (LHsDecl Name) -- maps exported names to declarations- -> Map Name (LHsDecl Name) -- maps local names to declarations+ -> [DeclWithDoc]+ -> Map Name DeclWithDoc -- maps local names to declarations+ -> Map Name Family -> Map Name [Name] -- sub-map for this module- -> [Entity] -- entities in the current module -> [DocOption] -> Maybe [IE Name] -> Bool -- --ignore-all-exports flag- -> Map Name (HsDoc Name)+ -> [Instance] -> ErrMsgM [ExportItem Name] -mkExportItems modMap this_mod exported_names exportedDeclMap localDeclMap sub_map entities- opts maybe_exps ignore_all_exports docMap+mkExportItems modMap this_mod exported_names decls declMap famMap sub_map+ opts maybe_exps ignore_all_exports instances | isNothing maybe_exps || ignore_all_exports || OptIgnoreExports `elem` opts = everything_local_exported- | Just specs <- maybe_exps = do - exps <- mapM lookupExport specs- return (concat exps)+ | Just specs <- maybe_exps = liftM concat $ mapM lookupExport specs where+ instances = [ d | d@(L _ decl, _) <- decls, isInstance decl ]+ everything_local_exported = -- everything exported- return (fullContentsOfThisModule this_mod entities localDeclMap docMap)+ return (fullContentsOfThisModule this_mod decls) packageId = modulePackageId this_mod - lookupExport (IEVar x) = declWith x- lookupExport (IEThingAbs t) = declWith t+ lookupExport (IEVar x) = declWith x+ lookupExport (IEThingAbs t) = declWith t+ -- | Just fam <- Map.lookup t famMap = absFam fam+ -- | otherwise = declWith t+ -- where+ -- absFam (Just (famDecl, doc), instances) = return $ [ ExportDecl famDecl doc [] ] ++ matchingInsts t+ -- absFam (Nothing, instances) =+ lookupExport (IEThingAll t) = declWith t lookupExport (IEThingWith t cs) = declWith t lookupExport (IEModuleContents m) = fullContentsOf (mkModule packageId m) lookupExport (IEGroup lev doc) = return [ ExportGroup lev "" doc ] lookupExport (IEDoc doc) = return [ ExportDoc doc ] - lookupExport (IEDocNamed str)- = do r <- findNamedDoc str entities- case r of- Nothing -> return []- Just found -> return [ ExportDoc found ]+ lookupExport (IEDocNamed str) = do+ r <- findNamedDoc str (map (unLoc . fst) decls)+ case r of+ Nothing -> return []+ Just found -> return [ ExportDoc found ] declWith :: Name -> ErrMsgM [ ExportItem Name ] declWith t- | (Just decl, maybeDoc) <- findDecl t- = return [ ExportDecl t (restrictTo subs (extractDecl t mdl decl)) maybeDoc [] ]+ | Just (decl, maybeDoc) <- findDecl t+ = return [ ExportDecl (restrictTo subs (extractDecl t mdl decl)) maybeDoc [] ] | otherwise = return [] where @@ -391,7 +394,7 @@ | otherwise = allSubsOfName modMap t fullContentsOf m - | m == this_mod = return (fullContentsOfThisModule this_mod entities localDeclMap docMap)+ | m == this_mod = return (fullContentsOfThisModule this_mod decls) | otherwise = case Map.lookup m modMap of Just iface@@ -400,28 +403,22 @@ | otherwise -> return [ ExportModule m ] Nothing -> return [] -- already emitted a warning in visibleNames - findDecl :: Name -> (Maybe (LHsDecl Name), Maybe (HsDoc Name))- findDecl n | not (isExternalName n) = error "This shouldn't happen"+ findDecl :: Name -> Maybe (LHsDecl Name, Maybe (HsDoc Name)) findDecl n - | m == this_mod = (Map.lookup n exportedDeclMap, Map.lookup n docMap)- | otherwise = - case Map.lookup m modMap of- Just iface -> (Map.lookup n (ifaceExportedDeclMap iface), - Map.lookup n (ifaceDocMap iface))- Nothing -> (Nothing, Nothing)+ | m == this_mod = Map.lookup n declMap+ | otherwise = case Map.lookup m modMap of+ Just iface -> Map.lookup n (ifaceDeclMap iface) + Nothing -> Nothing where m = nameModule n -fullContentsOfThisModule :: Module -> [Entity] -> Map Name (LHsDecl Name) ->- Map Name (HsDoc Name) -> [ExportItem Name]-fullContentsOfThisModule module_ entities declMap docMap - = catMaybes (map mkExportItem entities)- where - mkExportItem (DocEntity (DocGroup lev doc)) = Just (ExportGroup lev "" doc)- mkExportItem (DeclEntity name) = fmap mkExport (Map.lookup name declMap) - where mkExport decl = ExportDecl name decl (Map.lookup name docMap) []- mkExportItem _ = Nothing+fullContentsOfThisModule :: Module -> [(LHsDecl Name, Maybe (HsDoc Name))] -> [ExportItem Name]+fullContentsOfThisModule module_ decls = catMaybes (map mkExportItem decls)+ where+ mkExportItem (L _ (DocD (DocGroup lev doc)), _) = Just $ ExportGroup lev "" doc+ mkExportItem (decl, doc) = Just $ ExportDecl decl doc []+-- mkExportItem _ = Nothing -- TODO: see if this is really needed -- | Sometimes the declaration we want to export is not the "main" declaration:@@ -487,7 +484,7 @@ -- Pruning pruneExportItems :: [ExportItem Name] -> [ExportItem Name] pruneExportItems items = filter hasDoc items- where hasDoc (ExportDecl _ _ d _) = isJust d+ where hasDoc (ExportDecl _ d _) = isJust d hasDoc _ = True @@ -499,7 +496,7 @@ -> Map Name [Name] -> Maybe [IE Name] -> [DocOption]- -> Map Name (LHsDecl Name)+ -> Map Name (LHsDecl Name, Maybe (HsDoc Name)) -> ErrMsgM [Name] mkVisibleNames mdl modMap localNames scope subMap maybeExps opts declMap @@ -558,12 +555,13 @@ -- Named documentation -findNamedDoc :: String -> [Entity] -> ErrMsgM (Maybe (HsDoc Name))-findNamedDoc name entities = search entities - where search [] = do- tell ["Cannot find documentation for: $" ++ name]- return Nothing- search ((DocEntity (DocCommentNamed name' doc)):rest) - | name == name' = return (Just doc)- | otherwise = search rest- search (_other_decl : rest) = search rest+findNamedDoc :: String -> [HsDecl Name] -> ErrMsgM (Maybe (HsDoc Name))+findNamedDoc name decls = search decls+ where+ search [] = do+ tell ["Cannot find documentation for: $" ++ name]+ return Nothing+ search ((DocD (DocCommentNamed name' doc)):rest) + | name == name' = return (Just doc)+ | otherwise = search rest+ search (_other_decl : rest) = search rest
src/Haddock/Interface/Rename.hs view
@@ -38,7 +38,8 @@ let localEnv = foldl fn renamingEnv (ifaceVisibleExports mod) where fn env name = Map.insert name (ifaceMod mod) env - docs = Map.toList (ifaceDocMap mod)+ docMap = Map.map (\(_, doc) -> doc) $ ifaceDeclMap mod+ docs = [ (n, doc) | (n, Just doc) <- Map.toList docMap ] renameMapElem (k,d) = do d' <- renameDoc d; return (k, d') -- rename names in the exported declarations to point to things that@@ -291,37 +292,50 @@ ForD d -> do d' <- renameForD d return (ForD d')+ InstD d -> do+ d' <- renameInstD d+ return (InstD d') _ -> error "renameDecl" +renameLTyClD (L loc d) = return . L loc =<< renameTyClD d ++ renameTyClD d = case d of- ForeignType _ _ _ -> error "renameTyClD" -- I'm guessing these can't be exported- -- ForeignType name a b -> do- -- name' <- renameL name- -- return (ForeignType name' a b)+ ForeignType lname a b -> do+ lname' <- renameL lname+ return (ForeignType lname' a b) - TyData x lcontext lname ltyvars _ k cons _ -> do+ TyFamily flav lname ltyvars kind -> do+ lname' <- renameL lname+ ltyvars' <- mapM renameLTyVarBndr ltyvars+ return (TyFamily flav lname' ltyvars' kind)++ TyData x lcontext lname ltyvars typats k cons _ -> do lcontext' <- renameLContext lcontext+ lname' <- renameL lname ltyvars' <- mapM renameLTyVarBndr ltyvars+ typats' <- mapM (mapM renameLType) typats cons' <- mapM renameLCon cons -- I don't think we need the derivings, so we return Nothing- -- We skip the type patterns too. TODO: find out what they are :-)- return (TyData x lcontext' (keepL lname) ltyvars' Nothing k cons' Nothing) + return (TyData x lcontext' lname' ltyvars' typats' k cons' Nothing) - TySynonym lname ltyvars typat ltype -> do+ TySynonym lname ltyvars typats ltype -> do+ lname' <- renameL lname ltyvars' <- mapM renameLTyVarBndr ltyvars ltype' <- renameLType ltype- -- We skip type patterns here as well.- return (TySynonym (keepL lname) ltyvars' Nothing ltype')+ typats' <- mapM (mapM renameLType) typats+ return (TySynonym lname' ltyvars' typats' ltype') - ClassDecl lcontext lname ltyvars lfundeps lsigs _ _ _ -> do+ ClassDecl lcontext lname ltyvars lfundeps lsigs _ ats _ -> do lcontext' <- renameLContext lcontext+ lname' <- renameL lname ltyvars' <- mapM renameLTyVarBndr ltyvars lfundeps' <- mapM renameLFunDep lfundeps lsigs' <- mapM renameLSig lsigs+ ats' <- mapM renameLTyClD ats -- we don't need the default methods or the already collected doc entities- -- we skip the ATs for now.- return (ClassDecl lcontext' (keepL lname) ltyvars' lfundeps' lsigs' emptyBag [] [])+ return (ClassDecl lcontext' lname' ltyvars' lfundeps' lsigs' emptyBag ats' []) where renameLCon (L loc con) = return . L loc =<< renameCon con@@ -368,17 +382,23 @@ return (ForeignExport (keepL lname) ltype' x) +renameInstD (InstDecl ltype _ _ lATs) = do+ ltype <- renameLType ltype+ lATs' <- mapM renameLTyClD lATs+ return (InstDecl ltype emptyBag [] lATs') ++ renameExportItem :: ExportItem Name -> RnM (ExportItem DocName) renameExportItem item = case item of ExportModule mod -> return (ExportModule mod) ExportGroup lev id doc -> do doc' <- renameDoc doc return (ExportGroup lev id doc')- ExportDecl x decl doc instances -> do+ ExportDecl decl doc instances -> do decl' <- renameLDecl decl doc' <- mapM renameDoc doc instances' <- mapM renameInstHead instances- return (ExportDecl x decl' doc' instances')+ return (ExportDecl decl' doc' instances') ExportNoDecl x y subs -> do y' <- lookupRn id y subs' <- mapM (lookupRn id) subs
src/Haddock/Options.hs view
@@ -91,7 +91,7 @@ options backwardsCompat = [ Option ['B'] [] (ReqArg Flag_GhcLibDir "DIR")- "path to the GHC lib dir, e.g /usr/lib/ghc",+ "path to a GHC lib dir, to override the default path", Option ['o'] ["odir"] (ReqArg Flag_OutputDir "DIR") "directory in which to put the output files", Option ['l'] ["lib"] (ReqArg Flag_Lib "DIR") @@ -148,7 +148,7 @@ Option [] ["hide"] (ReqArg Flag_HideModule "MODULE") "behave as if MODULE has the hide attribute", Option [] ["optghc"] (ReqArg Flag_OptGhc "OPTION")- "Forward option to GHC",+ "option to be forwarded to GHC", Option [] ["ghc-version"] (NoArg Flag_GhcVersion) "output GHC version in numeric format", Option ['w'] ["no-warnings"] (NoArg Flag_NoWarnings) "turn off all warnings"
src/Haddock/Types.hs view
@@ -37,9 +37,6 @@ = ExportDecl { - -- | The original name- expItemName :: Name, - -- | A declaration expItemDecl :: LHsDecl name, @@ -100,6 +97,7 @@ ghcGroup :: HsGroup Name, ghcMbExports :: Maybe [LIE Name], ghcExportedNames :: [Name],+ ghcDefinedNames :: [Name], ghcNamesInScope :: [Name], ghcInstances :: [Instance] }@@ -129,8 +127,7 @@ -- | The Haddock options for this module (prune, ignore-exports, etc) ifaceOptions :: [DocOption], - ifaceExportedDeclMap :: Map Name (LHsDecl Name),- ifaceDocMap :: Map Name (HsDoc Name), + ifaceDeclMap :: Map Name (LHsDecl Name, Maybe (HsDoc Name)), ifaceRnDocMap :: Map Name (HsDoc DocName), ifaceExportItems :: [ExportItem Name],
src/Main.hs view
@@ -34,6 +34,7 @@ import System.Environment import GHC+import GHC.Paths import DynFlags import Bag import Util (handleDyn)@@ -111,8 +112,12 @@ if not (null fileArgs) then do++ let libDir+ | Just dir <- getGhcLibDir flags = dir+ | otherwise = libdir -- from GHC.Paths+ -- initialize GHC- libDir <- getGhcLibDir flags (session, dynflags) <- startGhc libDir (ghcFlags flags) -- get packages supplied with --read-interface@@ -203,30 +208,35 @@ allVisibleIfaces = map toInstalledIface visibleIfaces ++ installedIfaces - packageName = (Just . modulePkgStr . ifaceMod . head) visibleIfaces+ packageMod = ifaceMod (head visibleIfaces)+ packageStr = Just (modulePackageString packageMod)+ (pkgName,pkgVer) = modulePackageInfo packageMod+ when (Flag_GenIndex `elem` flags) $ do- ppHtmlIndex odir title packageName maybe_html_help_format+ ppHtmlIndex odir title packageStr maybe_html_help_format maybe_contents_url maybe_source_urls maybe_wiki_urls allVisibleIfaces copyHtmlBits odir libdir css_file when (Flag_GenContents `elem` flags && Flag_GenIndex `elem` flags) $ do- ppHtmlHelpFiles title packageName visibleIfaces odir maybe_html_help_format []+ ppHtmlHelpFiles title packageStr visibleIfaces odir maybe_html_help_format [] when (Flag_GenContents `elem` flags) $ do- ppHtmlContents odir title packageName maybe_html_help_format+ ppHtmlContents odir title packageStr maybe_html_help_format maybe_index_url maybe_source_urls maybe_wiki_urls allVisibleIfaces True prologue copyHtmlBits odir libdir css_file when (Flag_Html `elem` flags) $ do- ppHtml title packageName visibleIfaces odir+ ppHtml title packageStr visibleIfaces odir prologue maybe_html_help_format maybe_source_urls maybe_wiki_urls maybe_contents_url maybe_index_url copyHtmlBits odir libdir css_file + when (Flag_Hoogle `elem` flags) $ do+ ppHoogle pkgName pkgVer visibleIfaces odir ------------------------------------------------------------------------------- -- Reading and dumping interface files@@ -270,8 +280,8 @@ getGhcLibDir flags = case [ dir | Flag_GhcLibDir dir <- flags ] of- [] -> throwE "no GHC lib dir specified"- xs -> return $ last xs+ [] -> Nothing+ xs -> Just $ last xs handleEasyFlags flags fileArgs = do