diff --git a/CHANGES b/CHANGES --- a/CHANGES +++ b/CHANGES @@ -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 diff --git a/README b/README --- a/README +++ b/README @@ -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 or Simon Marlow diff --git a/TODO b/TODO deleted file mode 100644 --- a/TODO +++ /dev/null @@ -1,160 +0,0 @@ ------------------------------------------------------------------------------ --- Small improvements - -* When no GHC can be found, give an error message that tells you to use - --with-ghc= - -* 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 - diff --git a/doc/haddock.xml b/doc/haddock.xml --- a/doc/haddock.xml +++ b/doc/haddock.xml @@ -16,7 +16,7 @@ Simon Marlow - This document describes Haddock version 2.1.0, a Haskell + This document describes Haddock version 2.2.0, a Haskell documentation tool. @@ -93,8 +93,8 @@ 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. @@ -231,7 +231,7 @@ Tell GHC that that its lib directory is - dir. Needed to do any processing. + dir. Can be used to override the default path. @@ -795,6 +795,20 @@ + + + + + + + + + + + + Turn off all warnings. + +
Using literate or pre-processed source diff --git a/haddock.cabal b/haddock.cabal --- a/haddock.cabal +++ b/haddock.cabal @@ -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 diff --git a/haddock.spec b/haddock.spec --- a/haddock.spec +++ b/haddock.spec @@ -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} diff --git a/src/Haddock/Backends/Hoogle.hs b/src/Haddock/Backends/Hoogle.hs --- a/src/Haddock/Backends/Hoogle.hs +++ b/src/Haddock/Backends/Hoogle.hs @@ -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 | " " `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) = ["
"] ++ showPre xs ++ ["
"] +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) ++ "" + 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 ++ "" + 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] diff --git a/src/Haddock/Backends/Html.hs b/src/Haddock/Backends/Html.hs --- a/src/Haddock/Backends/Html.hs +++ b/src/Haddock/Backends/Html.hs @@ -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 = diff --git a/src/Haddock/GHC/Typecheck.hs b/src/Haddock/GHC/Typecheck.hs --- a/src/Haddock/GHC/Typecheck.hs +++ b/src/Haddock/GHC/Typecheck.hs @@ -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 diff --git a/src/Haddock/GHC/Utils.hs b/src/Haddock/GHC/Utils.hs --- a/src/Haddock/GHC/Utils.hs +++ b/src/Haddock/GHC/Utils.hs @@ -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 diff --git a/src/Haddock/Interface/AttachInstances.hs b/src/Haddock/Interface/AttachInstances.hs --- a/src/Haddock/Interface/AttachInstances.hs +++ b/src/Haddock/Interface/AttachInstances.hs @@ -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) ] diff --git a/src/Haddock/Interface/Create.hs b/src/Haddock/Interface/Create.hs --- a/src/Haddock/Interface/Create.hs +++ b/src/Haddock/Interface/Create.hs @@ -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 diff --git a/src/Haddock/Interface/Rename.hs b/src/Haddock/Interface/Rename.hs --- a/src/Haddock/Interface/Rename.hs +++ b/src/Haddock/Interface/Rename.hs @@ -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 diff --git a/src/Haddock/Options.hs b/src/Haddock/Options.hs --- a/src/Haddock/Options.hs +++ b/src/Haddock/Options.hs @@ -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" diff --git a/src/Haddock/Types.hs b/src/Haddock/Types.hs --- a/src/Haddock/Types.hs +++ b/src/Haddock/Types.hs @@ -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], diff --git a/src/Main.hs b/src/Main.hs --- a/src/Main.hs +++ b/src/Main.hs @@ -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