haddock 2.9.2 → 2.9.3
raw patch · 25 files changed
+552/−262 lines, 25 filesdep +processdep +regex-compatdep ~Cabaldep ~basedep ~ghc
Dependencies added: process, regex-compat
Dependency ranges changed: Cabal, base, ghc
Files
- CHANGES +12/−0
- dist/build/haddock/haddock-tmp/Haddock/Lex.hs +23/−16
- dist/build/haddock/haddock-tmp/Haddock/Parse.hs +31/−23
- doc/haddock.xml +5/−2
- haddock.cabal +16/−5
- haddock.spec +1/−1
- src/Haddock/Backends/Hoogle.hs +4/−3
- src/Haddock/Backends/LaTeX.hs +35/−31
- src/Haddock/Backends/Xhtml.hs +15/−15
- src/Haddock/Backends/Xhtml/Decl.hs +51/−34
- src/Haddock/Backends/Xhtml/Layout.hs +7/−4
- src/Haddock/Backends/Xhtml/Utils.hs +7/−2
- src/Haddock/Convert.hs +32/−12
- src/Haddock/GhcUtils.hs +47/−10
- src/Haddock/Interface/AttachInstances.hs +2/−1
- src/Haddock/Interface/Create.hs +102/−70
- src/Haddock/Interface/Rename.hs +3/−5
- src/Haddock/Interface/Rn.hs +2/−2
- src/Haddock/InterfaceFile.hs +4/−0
- src/Haddock/Lex.x +11/−4
- src/Haddock/Parse.y +11/−4
- src/Haddock/Types.hs +0/−1
- src/Haddock/Utils.hs +2/−4
- src/Main.hs +12/−13
- tests/html-tests/runtests.hs +117/−0
CHANGES view
@@ -1,3 +1,15 @@+Changes in version 2.9.3++ [This is the version that comes with GHC 7.2.1 although it claims it's 2.9.2!]++ * Build with GHC 7.2.1++ * Support blank lines in results of examples++ * A type signature for multiple names generates one signature in the output++ * Minor bug fixes+ Changes in version 2.9.2 * Build with GHC 7.0.2
dist/build/haddock/haddock-tmp/Haddock/Lex.hs view
@@ -1,4 +1,4 @@-{-# OPTIONS -fglasgow-exts -cpp #-}+{-# LANGUAGE CPP,MagicHash #-} {-# LINE 10 "src/Haddock/Lex.x" #-} {-# LANGUAGE BangPatterns #-} -- Generated by Alex@@ -21,6 +21,7 @@ import RdrName import SrcLoc import DynFlags+import FastString import Data.Char import Numeric@@ -136,7 +137,7 @@ where go inp@(pos,_,str) = case alexScan inp 0 of AlexEOF -> []- AlexError _ -> error "lexical error"+ AlexError ((AlexPn _ line column),_,_) -> error $ "lexical error at " ++ (show line) ++ " line, " ++ (show column) ++ " column" AlexSkip inp' len -> go inp' AlexToken inp' len act -> act pos (take len str) : go inp' @@ -166,7 +167,7 @@ alex_deflt = AlexA# "\xff\xff\x1b\x00\x41\x00\xff\xff\x22\x00\x24\x00\xff\xff\xff\xff\x41\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x22\x00\xff\xff\x24\x00\xff\xff\xff\xff\xff\xff\x29\x00\x29\x00\x2c\x00\xff\xff\x2c\x00\xff\xff\x2f\x00\x2f\x00\xff\xff\x32\x00\x32\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x37\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\xff\xff\xff\xff"# alex_accept = listArray (0::Int,67) [[(AlexAcc (alex_action_7))],[(AlexAcc (alex_action_12))],[],[(AlexAcc (alex_action_15))],[],[],[(AlexAcc (alex_action_11))],[(AlexAcc (alex_action_7))],[],[(AlexAccSkip)],[(AlexAcc (alex_action_7))],[(AlexAcc (alex_action_1))],[(AlexAcc (alex_action_2))],[],[(AlexAcc (alex_action_3))],[(AlexAcc (alex_action_4))],[(AlexAcc (alex_action_5))],[],[],[(AlexAcc (alex_action_6))],[],[(AlexAcc (alex_action_8))],[],[(AlexAcc (alex_action_9))],[],[(AlexAcc (alex_action_10))],[(AlexAcc (alex_action_12))],[(AlexAcc (alex_action_12))],[(AlexAcc (alex_action_13))],[],[(AlexAcc (alex_action_14))],[],[],[(AlexAcc (alex_action_16))],[],[(AlexAcc (alex_action_17))],[],[(AlexAcc (alex_action_18))],[(AlexAcc (alex_action_19))],[(AlexAcc (alex_action_20))],[],[],[(AlexAcc (alex_action_27))],[(AlexAcc (alex_action_20))],[],[(AlexAcc (alex_action_21))],[(AlexAcc (alex_action_27))],[],[(AlexAcc (alex_action_22))],[(AlexAcc (alex_action_27))],[],[(AlexAcc (alex_action_23))],[(AlexAcc (alex_action_23))],[],[(AlexAcc (alex_action_27))],[(AlexAcc (alex_action_24))],[(AlexAcc (alex_action_27))],[(AlexAcc (alex_action_25))],[],[],[(AlexAcc (alex_action_27))],[(AlexAcc (alex_action_26))],[],[],[(AlexAcc (alex_action_28))],[(AlexAcc (alex_action_29))],[(AlexAcc (alex_action_30))],[(AlexAcc (alex_action_31))]]-{-# LINE 113 "src/Haddock/Lex.x" #-}+{-# LINE 114 "src/Haddock/Lex.x" #-} -- | A located token type LToken = (Token, AlexPosn)@@ -235,19 +236,25 @@ ident :: Action ident pos str sc cont dflags = - case strToHsQNames dflags id of+ case strToHsQNames dflags loc id of Just names -> (TokIdent names, pos) : cont sc Nothing -> (TokString str, pos) : cont sc where id = init (tail str)+ -- TODO: Get the real filename here. Maybe we should just be+ -- using GHC SrcLoc's ourself?+ filename = mkFastString "<unknown file>"+ loc = case pos of+ AlexPn _ line col ->+ mkRealSrcLoc filename line col -strToHsQNames :: DynFlags -> String -> Maybe [RdrName]-strToHsQNames dflags str0 = +strToHsQNames :: DynFlags -> RealSrcLoc -> String -> Maybe [RdrName]+strToHsQNames dflags loc str0 = #if MIN_VERSION_ghc(7,1,0) let buffer = stringToStringBuffer str0 #else let buffer = unsafePerformIO (stringToStringBuffer str0) #endif- pstate = mkPState dflags buffer noSrcLoc+ pstate = mkPState dflags buffer loc result = unP parseIdentifier pstate in case result of POk _ name -> Just [unLoc name] @@ -324,10 +331,10 @@ #ifdef WORDS_BIGENDIAN narrow16Int# i where- i = word2Int# ((high `uncheckedShiftL#` 8#) `or#` low)- high = int2Word# (ord# (indexCharOffAddr# arr (off' +# 1#)))- low = int2Word# (ord# (indexCharOffAddr# arr off'))- off' = off *# 2#+ i = word2Int# ((high `uncheckedShiftL#` 8#) `or#` low)+ high = int2Word# (ord# (indexCharOffAddr# arr (off' +# 1#)))+ low = int2Word# (ord# (indexCharOffAddr# arr off'))+ off' = off *# 2# #else indexInt16OffAddr# arr off #endif@@ -424,12 +431,12 @@ let- !(base) = alexIndexInt32OffAddr alex_base s- !((I# (ord_c))) = ord c- !(offset) = (base +# ord_c)- !(check) = alexIndexInt16OffAddr alex_check offset+ (base) = alexIndexInt32OffAddr alex_base s+ ((I# (ord_c))) = ord c+ (offset) = (base +# ord_c)+ (check) = alexIndexInt16OffAddr alex_check offset - !(new_s) = if (offset >=# 0#) && (check ==# ord_c)+ (new_s) = if (offset >=# 0#) && (check ==# ord_c) then alexIndexInt16OffAddr alex_table offset else alexIndexInt16OffAddr alex_deflt s in
dist/build/haddock/haddock-tmp/Haddock/Parse.hs view
@@ -1,4 +1,4 @@-{-# OPTIONS_GHC -fno-warn-overlapping-patterns #-}+{-# OPTIONS_GHC -w #-} {-# OPTIONS -fglasgow-exts -cpp #-} {-# LANGUAGE BangPatterns #-} -- required for versions of Happy before 1.18.6 {-# OPTIONS -Wwarn -w #-}@@ -21,7 +21,7 @@ import qualified Data.Array as Happy_Data_Array import qualified GHC.Exts as Happy_GHC_Exts --- parser produced by Happy Version 1.18.5+-- parser produced by Happy Version 1.18.6 newtype HappyAbsSyn = HappyAbsSyn HappyAny #if __GLASGOW_HASKELL__ >= 607@@ -543,14 +543,21 @@ -- whitespace in expressions, so drop them result' where- -- drop trailing whitespace from the prompt, remember the prefix+ -- 1. drop trailing whitespace from the prompt, remember the prefix (prefix, _) = span isSpace prompt- -- drop, if possible, the exact same sequence of whitespace characters- -- from each result line- result' = map (tryStripPrefix prefix) result++ -- 2. drop, if possible, the exact same sequence of whitespace+ -- characters from each result line+ --+ -- 3. interpret lines that only contain the string "<BLANKLINE>" as an+ -- empty line+ result' = map (substituteBlankLine . tryStripPrefix prefix) result where tryStripPrefix xs ys = fromMaybe ys $ stripPrefix xs ys + substituteBlankLine "<BLANKLINE>" = ""+ substituteBlankLine line = line+ -- | Remove all leading and trailing whitespace strip :: String -> String strip = dropWhile isSpace . reverse . dropWhile isSpace . reverse@@ -617,13 +624,13 @@ happyShift new_state i tk st- where !(new_state) = (n Happy_GHC_Exts.-# (1# :: Happy_GHC_Exts.Int#))- where !(off) = indexShortOffAddr happyActOffsets st- !(off_i) = (off Happy_GHC_Exts.+# i)+ where (new_state) = (n Happy_GHC_Exts.-# (1# :: Happy_GHC_Exts.Int#))+ where (off) = indexShortOffAddr happyActOffsets st+ (off_i) = (off Happy_GHC_Exts.+# i) check = if (off_i Happy_GHC_Exts.>=# (0# :: Happy_GHC_Exts.Int#)) then (indexShortOffAddr happyCheck off_i Happy_GHC_Exts.==# i) else False- !(action)+ (action) | check = indexShortOffAddr happyTable off_i | otherwise = indexShortOffAddr happyDefActions st @@ -633,10 +640,10 @@ indexShortOffAddr (HappyA# arr) off = Happy_GHC_Exts.narrow16Int# i where- !i = Happy_GHC_Exts.word2Int# (Happy_GHC_Exts.or# (Happy_GHC_Exts.uncheckedShiftL# high 8#) low)- !high = Happy_GHC_Exts.int2Word# (Happy_GHC_Exts.ord# (Happy_GHC_Exts.indexCharOffAddr# arr (off' Happy_GHC_Exts.+# 1#)))- !low = Happy_GHC_Exts.int2Word# (Happy_GHC_Exts.ord# (Happy_GHC_Exts.indexCharOffAddr# arr off'))- !off' = off Happy_GHC_Exts.*# 2#+ i = Happy_GHC_Exts.word2Int# (Happy_GHC_Exts.or# (Happy_GHC_Exts.uncheckedShiftL# high 8#) low)+ high = Happy_GHC_Exts.int2Word# (Happy_GHC_Exts.ord# (Happy_GHC_Exts.indexCharOffAddr# arr (off' Happy_GHC_Exts.+# 1#)))+ low = Happy_GHC_Exts.int2Word# (Happy_GHC_Exts.ord# (Happy_GHC_Exts.indexCharOffAddr# arr off'))+ off' = off Happy_GHC_Exts.*# 2# @@ -656,7 +663,7 @@ -- Shifting a token happyShift new_state 0# tk st sts stk@(x `HappyStk` _) =- let !(i) = (case Happy_GHC_Exts.unsafeCoerce# x of { (Happy_GHC_Exts.I# (i)) -> i }) in+ let (i) = (case Happy_GHC_Exts.unsafeCoerce# x of { (Happy_GHC_Exts.I# (i)) -> i }) in -- trace "shifting the error token" $ happyDoAction i tk new_state (HappyCons (st) (sts)) (stk) @@ -700,19 +707,19 @@ = happyFail 0# tk st sts stk happyMonadReduce k nt fn j tk st sts stk = happyThen1 (fn stk tk) (\r -> happyGoto nt j tk st1 sts1 (r `HappyStk` drop_stk))- where !(sts1@((HappyCons (st1@(action)) (_)))) = happyDrop k (HappyCons (st) (sts))+ where (sts1@((HappyCons (st1@(action)) (_)))) = happyDrop k (HappyCons (st) (sts)) drop_stk = happyDropStk k stk happyMonad2Reduce k nt fn 0# tk st sts stk = happyFail 0# tk st sts stk happyMonad2Reduce k nt fn j tk st sts stk = happyThen1 (fn stk tk) (\r -> happyNewToken new_state sts1 (r `HappyStk` drop_stk))- where !(sts1@((HappyCons (st1@(action)) (_)))) = happyDrop k (HappyCons (st) (sts))+ where (sts1@((HappyCons (st1@(action)) (_)))) = happyDrop k (HappyCons (st) (sts)) drop_stk = happyDropStk k stk - !(off) = indexShortOffAddr happyGotoOffsets st1- !(off_i) = (off Happy_GHC_Exts.+# nt)- !(new_state) = indexShortOffAddr happyTable off_i+ (off) = indexShortOffAddr happyGotoOffsets st1+ (off_i) = (off Happy_GHC_Exts.+# nt)+ (new_state) = indexShortOffAddr happyTable off_i @@ -730,9 +737,9 @@ happyGoto nt j tk st = {- nothing -} happyDoAction j tk new_state- where !(off) = indexShortOffAddr happyGotoOffsets st- !(off_i) = (off Happy_GHC_Exts.+# nt)- !(new_state) = indexShortOffAddr happyTable off_i+ where (off) = indexShortOffAddr happyGotoOffsets st+ (off_i) = (off Happy_GHC_Exts.+# nt)+ (new_state) = indexShortOffAddr happyTable off_i @@ -764,6 +771,7 @@ -- Internal happy errors: +notHappyAtAll :: a notHappyAtAll = error "Internal Happy error\n" -----------------------------------------------------------------------------
doc/haddock.xml view
@@ -21,7 +21,7 @@ <holder>Simon Marlow, David Waern</holder> </copyright> <abstract>- <para>This document describes Haddock version 2.9.2, a Haskell+ <para>This document describes Haddock version 2.9.3, a Haskell documentation tool.</para> </abstract> </bookinfo>@@ -936,7 +936,7 @@ <literal>ignore-exports</literal> attribute (<xref linkend="module-attributes" />). This might be useful for generating implementation documentation rather than interface- documetnation, for example.</para>+ documentation, for example.</para> </listitem> </varlistentry> @@ -1667,6 +1667,9 @@ -- foo -- bar </programlisting>+ <para>Result lines that only contain the string+ <literal><BLANKLINE></literal> are rendered as blank lines in the+ generated documenation.</para> </section>
haddock.cabal view
@@ -1,5 +1,5 @@ name: haddock-version: 2.9.2+version: 2.9.3 cabal-version: >= 1.10 license: BSD3 build-type: Simple@@ -48,6 +48,9 @@ haddock.spec haskell.vim src/haddock.sh+-- The test files shouldn't have to go here, but the source files for+-- the test-suite stanzas don't get picked up by `cabal sdist`.+ tests/html-tests/runtests.hs data-files: html/frames.html@@ -75,7 +78,7 @@ executable haddock default-language: Haskell2010 build-depends:- base == 4.3.*,+ base >= 4.3 && < 4.5, filepath, directory, pretty,@@ -83,7 +86,7 @@ array, xhtml >= 3000.2 && < 3000.3, Cabal >= 1.10,- ghc >= 7.0 && < 7.2+ ghc >= 7.0 && < 7.4 if flag(in-ghc-tree) cpp-options: -DIN_GHC_TREE@@ -135,7 +138,7 @@ library default-language: Haskell2010 build-depends:- base == 4.3.*,+ base >= 4.3 && < 4.5, filepath, directory, pretty,@@ -143,7 +146,7 @@ array, xhtml >= 3000.2 && < 3000.3, Cabal >= 1.10,- ghc >= 7.0 && < 7.2+ ghc >= 7.0 && < 7.4 if flag(in-ghc-tree) cpp-options: -DIN_GHC_TREE@@ -198,3 +201,11 @@ if flag(in-ghc-tree) buildable: False++test-suite html-tests+ type: exitcode-stdio-1.0+ default-language: Haskell2010+ main-is: runtests.hs+ hs-source-dirs: tests/html-tests+ build-depends: base, directory, process, filepath, Cabal, regex-compat+
haddock.spec view
@@ -17,7 +17,7 @@ # version label of your release tarball. %define name haddock-%define version 2.9.2+%define version 2.9.3 %define release 1 Name: %{name}
src/Haddock/Backends/Hoogle.hs view
@@ -114,16 +114,17 @@ f (TyClD d@TyData{}) = ppData d subdocs f (TyClD d@ClassDecl{}) = ppClass d f (TyClD d@TySynonym{}) = ppSynonym d- f (ForD (ForeignImport name typ _)) = ppSig $ TypeSig name typ- f (ForD (ForeignExport name typ _)) = ppSig $ TypeSig name typ+ f (ForD (ForeignImport name typ _)) = ppSig $ TypeSig [name] typ+ f (ForD (ForeignExport name typ _)) = ppSig $ TypeSig [name] typ f (SigD sig) = ppSig sig f _ = [] ppExport _ = [] ppSig :: Sig Name -> [String]-ppSig (TypeSig name sig) = [operator (out name) ++ " :: " ++ outHsType typ]+ppSig (TypeSig names sig) = [operator prettyNames ++ " :: " ++ outHsType typ] where+ prettyNames = concat . intersperse ", " $ map out names typ = case unL sig of HsForAllTy Explicit a b c -> HsForAllTy Implicit a b c x -> x
src/Haddock/Backends/LaTeX.hs view
@@ -177,7 +177,7 @@ exportListItem :: ExportItem DocName -> LaTeX exportListItem (ExportDecl decl _doc subdocs _insts)- = ppDocBinder (declName decl) <>+ = sep (punctuate comma . map ppDocBinder $ declNames decl) <> case subdocs of [] -> empty _ -> parens (sep (punctuate comma (map (ppDocBinder . fst) subdocs)))@@ -197,8 +197,8 @@ processExports [] = empty processExports (decl : es) | Just sig <- isSimpleSig decl- = multiDecl [ ppTypeSig (getName name) typ False- | (name,typ) <- sig:sigs ] $$+ = multiDecl [ ppTypeSig (map getName names) typ False+ | (names,typ) <- sig:sigs ] $$ processExports es' where (sigs, es') = spanWith isSimpleSig es processExports (ExportModule mdl : es)@@ -209,10 +209,10 @@ processExport e $$ processExports es -isSimpleSig :: ExportItem DocName -> Maybe (DocName, HsType DocName)-isSimpleSig (ExportDecl (L _ (SigD (TypeSig (L _ n) (L _ t))))+isSimpleSig :: ExportItem DocName -> Maybe ([DocName], HsType DocName)+isSimpleSig (ExportDecl (L _ (SigD (TypeSig lnames (L _ t)))) (Nothing, argDocs) _ _)- | Map.null argDocs = Just (n, t)+ | Map.null argDocs = Just (map unLoc lnames, t) isSimpleSig _ = Nothing @@ -244,11 +244,11 @@ sec _ = text "\\paragraph" -declName :: LHsDecl DocName -> DocName-declName (L _ decl) = case decl of- TyClD d -> unLoc $ tcdLName d- SigD (TypeSig (L _ n) _) -> n- _ -> error "declaration not supported by declName"+declNames :: LHsDecl DocName -> [DocName]+declNames (L _ decl) = case decl of+ TyClD d -> [unLoc $ tcdLName d]+ SigD (TypeSig lnames _) -> map unLoc lnames+ _ -> error "declaration not supported by declNames" forSummary :: (ExportItem DocName) -> Bool@@ -286,7 +286,7 @@ | Nothing <- tcdTyPats d -> ppTySyn loc (mbDoc, fnArgsDoc) d unicode | Just _ <- tcdTyPats d -> ppTyInst False loc mbDoc d unicode TyClD d@(ClassDecl {}) -> ppClassDecl instances loc mbDoc subdocs d unicode- SigD (TypeSig (L _ n) (L _ t)) -> ppFunSig loc (mbDoc, fnArgsDoc) n t unicode+ SigD (TypeSig lnames (L _ t)) -> ppFunSig loc (mbDoc, fnArgsDoc) (map unLoc lnames) t unicode ForD d -> ppFor loc (mbDoc, fnArgsDoc) d unicode InstD _ -> empty _ -> error "declaration not supported by ppDecl"@@ -325,7 +325,7 @@ ppTySyn :: SrcSpan -> DocForDecl DocName -> TyClDecl DocName -> Bool -> LaTeX ppTySyn loc doc (TySynonym (L _ name) ltyvars _ ltype) unicode- = ppTypeOrFunSig loc name (unLoc ltype) doc (full, hdr, char '=') unicode+ = ppTypeOrFunSig loc [name] (unLoc ltype) doc (full, hdr, char '=') unicode where hdr = hsep (keyword "type" : ppDocBinder name : ppTyVars ltyvars) full = hdr <+> char '=' <+> ppLType unicode ltype@@ -338,20 +338,22 @@ ------------------------------------------------------------------------------- -ppFunSig :: SrcSpan -> DocForDecl DocName -> DocName -> HsType DocName+ppFunSig :: SrcSpan -> DocForDecl DocName -> [DocName] -> HsType DocName -> Bool -> LaTeX-ppFunSig loc doc docname typ unicode =- ppTypeOrFunSig loc docname typ doc- (ppTypeSig name typ False, ppSymName name, dcolon unicode)+ppFunSig loc doc docnames typ unicode =+ ppTypeOrFunSig loc docnames typ doc+ ( ppTypeSig names typ False+ , hsep . punctuate comma $ map ppSymName names+ , dcolon unicode) unicode where- name = getName docname+ names = map getName docnames -ppTypeOrFunSig :: SrcSpan -> DocName -> HsType DocName ->- DocForDecl DocName -> (LaTeX, LaTeX, LaTeX)+ppTypeOrFunSig :: SrcSpan -> [DocName] -> HsType DocName+ -> DocForDecl DocName -> (LaTeX, LaTeX, LaTeX) -> Bool -> LaTeX-ppTypeOrFunSig _loc _docname typ (doc, argDocs) (pref1, pref2, sep0)+ppTypeOrFunSig _ _ typ (doc, argDocs) (pref1, pref2, sep0) unicode | Map.null argDocs = declWithDoc pref1 (fmap docToLaTeX doc)@@ -388,9 +390,11 @@ = decltt leader <-> decltt (ppType unicode t) <-> arg_doc n <+> nl -ppTypeSig :: Name -> HsType DocName -> Bool -> LaTeX-ppTypeSig nm ty unicode =- ppSymName nm <+> dcolon unicode <+> ppType unicode ty+ppTypeSig :: [Name] -> HsType DocName -> Bool -> LaTeX+ppTypeSig nms ty unicode =+ hsep (punctuate comma $ map ppSymName nms)+ <+> dcolon unicode+ <+> ppType unicode ty ppTyVars :: [LHsTyVarBndr DocName] -> [LaTeX]@@ -489,12 +493,13 @@ methodTable = text "\\haddockpremethods{}\\textbf{Methods}" $$- vcat [ ppFunSig loc doc n typ unicode- | L _ (TypeSig (L _ n) (L _ typ)) <- lsigs- , let doc = lookupAnySubdoc n subdocs ]---- atTable = abovesSep s8 $ [ ppAssocType summary links doc at unicode | at <- ats--- , let doc = lookupAnySubdoc (tcdName $ unL at) subdocs ]+ vcat [ ppFunSig loc doc names typ unicode+ | L _ (TypeSig lnames (L _ typ)) <- lsigs+ , let doc = lookupAnySubdoc (head names) subdocs+ names = map unLoc lnames ]+ -- FIXME: is taking just the first name ok? Is it possible that+ -- there are different subdocs for different names in a single+ -- type signature? instancesBit = ppDocInstances unicode instances @@ -874,7 +879,6 @@ ppr_mono_ty _ (HsListTy ty) u = brackets (ppr_mono_lty pREC_TOP ty u) ppr_mono_ty _ (HsPArrTy ty) u = pabrackets (ppr_mono_lty pREC_TOP ty u) ppr_mono_ty _ (HsPredTy p) u = parens (ppPred u p)-ppr_mono_ty _ (HsNumTy n) _ = text (show n) -- generics only ppr_mono_ty _ (HsSpliceTy {}) _ = error "ppr_mono_ty HsSpliceTy" ppr_mono_ty _ (HsQuasiQuoteTy {}) _ = error "ppr_mono_ty HsQuasiQuoteTy" ppr_mono_ty _ (HsRecTy {}) _ = error "ppr_mono_ty HsRecTy"
src/Haddock/Backends/Xhtml.hs view
@@ -246,7 +246,7 @@ ppPrologue :: String -> Maybe (Doc GHC.RdrName) -> Html ppPrologue _ Nothing = noHtml ppPrologue title (Just doc) =- docElement divDescription << (h1 << title +++ rdrDocToHtml doc)+ divDescription << (h1 << title +++ docElement thediv (rdrDocToHtml doc)) ppModuleTree :: [ModuleTree] -> Html@@ -547,31 +547,31 @@ miniSynopsis :: Module -> Interface -> Bool -> Qualification -> Html miniSynopsis mdl iface unicode qual =- divInterface << mapMaybe (processForMiniSynopsis mdl unicode qual) exports+ divInterface << concatMap (processForMiniSynopsis mdl unicode qual) exports where exports = numberSectionHeadings (ifaceRnExportItems iface) processForMiniSynopsis :: Module -> Bool -> Qualification -> ExportItem DocName- -> Maybe Html+ -> [Html] processForMiniSynopsis mdl unicode _ (ExportDecl (L _loc decl0) _doc _ _insts) = ((divTopDecl <<).(declElem <<)) `fmap` case decl0 of TyClD d -> let b = ppTyClBinderWithVarsMini mdl d in case d of- (TyFamily{}) -> Just $ ppTyFamHeader True False d unicode+ (TyFamily{}) -> [ppTyFamHeader True False d unicode] (TyData{tcdTyPats = ps})- | Nothing <- ps -> Just $ keyword "data" <+> b- | Just _ <- ps -> Just $ keyword "data" <+> keyword "instance" <+> b+ | Nothing <- ps -> [keyword "data" <+> b]+ | Just _ <- ps -> [keyword "data" <+> keyword "instance" <+> b] (TySynonym{tcdTyPats = ps})- | Nothing <- ps -> Just $ keyword "type" <+> b- | Just _ <- ps -> Just $ keyword "type" <+> keyword "instance" <+> b- (ClassDecl {}) -> Just $ keyword "class" <+> b- _ -> Nothing- SigD (TypeSig (L _ n) (L _ _)) ->- Just $ ppNameMini mdl (nameOccName . getName $ n)- _ -> Nothing+ | Nothing <- ps -> [keyword "type" <+> b]+ | Just _ <- ps -> [keyword "type" <+> keyword "instance" <+> b]+ (ClassDecl {}) -> [keyword "class" <+> b]+ _ -> []+ SigD (TypeSig lnames (L _ _)) ->+ map (ppNameMini mdl . nameOccName . getName . unLoc) lnames+ _ -> [] processForMiniSynopsis _ _ qual (ExportGroup lvl _id txt) =- Just $ groupTag lvl << docToHtml qual txt-processForMiniSynopsis _ _ _ _ = Nothing+ [groupTag lvl << docToHtml qual txt]+processForMiniSynopsis _ _ _ _ = [] ppNameMini :: Module -> OccName -> Html
src/Haddock/Backends/Xhtml/Decl.hs view
@@ -27,6 +27,7 @@ import Haddock.Types import Control.Monad ( join )+import Data.List ( intersperse ) import qualified Data.Map as Map import Data.Maybe import Text.XHtml hiding ( name, title, p, quote )@@ -50,28 +51,31 @@ | Nothing <- tcdTyPats d -> ppTySyn summ links loc (mbDoc, fnArgsDoc) d unicode qual | Just _ <- tcdTyPats d -> ppTyInst summ False links loc mbDoc d unicode qual TyClD d@(ClassDecl {}) -> ppClassDecl summ links instances loc mbDoc subdocs d unicode qual- SigD (TypeSig (L _ n) (L _ t)) -> ppFunSig summ links loc (mbDoc, fnArgsDoc) n t unicode qual+ SigD (TypeSig lnames (L _ t)) -> ppFunSig summ links loc (mbDoc, fnArgsDoc) (map unLoc lnames) t unicode qual ForD d -> ppFor summ links loc (mbDoc, fnArgsDoc) d unicode qual InstD _ -> noHtml _ -> error "declaration not supported by ppDecl" ppFunSig :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName ->- DocName -> HsType DocName -> Bool -> Qualification -> Html-ppFunSig summary links loc doc docname typ unicode qual =- ppTypeOrFunSig summary links loc docname typ doc- (ppTypeSig summary occname typ unicode qual, ppBinder False occname, dcolon unicode)+ [DocName] -> HsType DocName -> Bool -> Qualification -> Html+ppFunSig summary links loc doc docnames typ unicode qual =+ ppTypeOrFunSig summary links loc docnames typ doc+ ( ppTypeSig summary occnames typ unicode qual+ , concatHtml . punctuate comma $ map (ppBinder False) occnames+ , dcolon unicode+ ) unicode qual where- occname = nameOccName . getName $ docname+ occnames = map (nameOccName . getName) docnames -ppTypeOrFunSig :: Bool -> LinksInfo -> SrcSpan -> DocName -> HsType DocName ->- DocForDecl DocName -> (Html, Html, Html) -> Bool -> Qualification-> Html-ppTypeOrFunSig summary links loc docname typ (doc, argDocs) (pref1, pref2, sep) unicode qual+ppTypeOrFunSig :: Bool -> LinksInfo -> SrcSpan -> [DocName] -> HsType DocName+ -> DocForDecl DocName -> (Html, Html, Html) -> Bool -> Qualification -> Html+ppTypeOrFunSig summary links loc docnames typ (doc, argDocs) (pref1, pref2, sep) unicode qual | summary = pref1- | Map.null argDocs = topDeclElem links loc docname pref1 +++ maybeDocSection qual doc- | otherwise = topDeclElem links loc docname pref2 ++++ | Map.null argDocs = topDeclElem links loc docnames pref1 +++ maybeDocSection qual doc+ | otherwise = topDeclElem links loc docnames pref2 +++ subArguments qual (do_args 0 sep typ) +++ maybeDocSection qual doc where argDoc n = Map.lookup n argDocs@@ -108,10 +112,10 @@ tyvarNames = map (getName . hsTyVarName . unLoc) -ppFor :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName -> ForeignDecl DocName -> Bool - -> Qualification -> Html+ppFor :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName+ -> ForeignDecl DocName -> Bool -> Qualification -> Html ppFor summary links loc doc (ForeignImport (L _ name) (L _ typ) _) unicode qual- = ppFunSig summary links loc doc name typ unicode qual+ = ppFunSig summary links loc doc [name] typ unicode qual ppFor _ _ _ _ _ _ _ = error "ppFor" @@ -119,7 +123,7 @@ ppTySyn :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName -> TyClDecl DocName -> Bool -> Qualification -> Html ppTySyn summary links loc doc (TySynonym (L _ name) ltyvars _ ltype) unicode qual- = ppTypeOrFunSig summary links loc name (unLoc ltype) doc+ = ppTypeOrFunSig summary links loc [name] (unLoc ltype) doc (full, hdr, spaceHtml +++ equals) unicode qual where hdr = hsep ([keyword "type", ppBinder summary occ] ++ ppTyVars ltyvars)@@ -128,9 +132,11 @@ ppTySyn _ _ _ _ _ _ _ = error "declaration not supported by ppTySyn" -ppTypeSig :: Bool -> OccName -> HsType DocName -> Bool -> Qualification -> Html-ppTypeSig summary nm ty unicode qual =- ppBinder summary nm <+> dcolon unicode <+> ppType unicode qual ty+ppTypeSig :: Bool -> [OccName] -> HsType DocName -> Bool -> Qualification -> Html+ppTypeSig summary nms ty unicode qual =+ concatHtml htmlNames <+> dcolon unicode <+> ppType unicode qual ty+ where+ htmlNames = intersperse (stringToHtml ", ") $ map (ppBinder summary) nms ppTyName :: Name -> Html@@ -173,7 +179,7 @@ where docname = tcdName decl - header_ = topDeclElem links loc docname (ppTyFamHeader summary associated decl unicode)+ header_ = topDeclElem links loc [docname] (ppTyFamHeader summary associated decl unicode) instancesBit = ppInstances instances docname unicode qual @@ -213,8 +219,8 @@ where docname = tcdName decl - header_ = topDeclElem links loc docname- (ppTyInstHeader summary associated decl unicode qual)+ header_ = topDeclElem links loc [docname]+ (ppTyInstHeader summary associated decl unicode qual) ppTyInstHeader :: Bool -> Bool -> TyClDecl DocName -> Bool -> Qualification -> Html@@ -349,16 +355,20 @@ ppShortClassDecl summary links (ClassDecl lctxt lname tvs fds sigs _ ats _) loc subdocs unicode qual = if null sigs && null ats- then (if summary then id else topDeclElem links loc nm) hdr- else (if summary then id else topDeclElem links loc nm) (hdr <+> keyword "where")+ then (if summary then id else topDeclElem links loc [nm]) hdr+ else (if summary then id else topDeclElem links loc [nm]) (hdr <+> keyword "where") +++ shortSubDecls ( [ ppAssocType summary links doc at unicode qual | at <- ats , let doc = lookupAnySubdoc (tcdName $ unL at) subdocs ] ++ - [ ppFunSig summary links loc doc n typ unicode qual- | L _ (TypeSig (L _ n) (L _ typ)) <- sigs- , let doc = lookupAnySubdoc n subdocs ]+ [ ppFunSig summary links loc doc names typ unicode qual+ | L _ (TypeSig lnames (L _ typ)) <- sigs+ , let doc = lookupAnySubdoc (head names) subdocs+ names = map unLoc lnames ]+ -- FIXME: is taking just the first name ok? Is it possible that+ -- there are different subdocs for different names in a single+ -- type signature? ) where hdr = ppClassHdr summary lctxt (unLoc lname) tvs fds unicode qual@@ -377,8 +387,8 @@ +++ atBit +++ methodBit +++ instancesBit where classheader- | null lsigs = topDeclElem links loc nm (hdr unicode qual)- | otherwise = topDeclElem links loc nm (hdr unicode qual <+> keyword "where")+ | null lsigs = topDeclElem links loc [nm] (hdr unicode qual)+ | otherwise = topDeclElem links loc [nm] (hdr unicode qual <+> keyword "where") nm = unLoc $ tcdLName decl @@ -388,9 +398,13 @@ | at <- ats , let doc = lookupAnySubdoc (tcdName $ unL at) subdocs ] - methodBit = subMethods [ ppFunSig summary links loc doc n typ unicode qual- | L _ (TypeSig (L _ n) (L _ typ)) <- lsigs- , let doc = lookupAnySubdoc n subdocs ]+ methodBit = subMethods [ ppFunSig summary links loc doc names typ unicode qual+ | L _ (TypeSig lnames (L _ typ)) <- lsigs+ , let doc = lookupAnySubdoc (head names) subdocs+ names = map unLoc lnames ]+ -- FIXME: is taking just the first name ok? Is it possible that+ -- there are different subdocs for different names in a single+ -- type signature? instancesBit = ppInstances instances nm unicode qual @@ -461,7 +475,7 @@ cons = tcdCons dataDecl resTy = (con_res . unLoc . head) cons - header_ = topDeclElem links loc docname (ppDataHeader summary dataDecl unicode qual+ header_ = topDeclElem links loc [docname] (ppDataHeader summary dataDecl unicode qual <+> whereBit) whereBit@@ -711,11 +725,14 @@ ppr_mono_ty _ (HsListTy ty) u q = brackets (ppr_mono_lty pREC_TOP ty u q) ppr_mono_ty _ (HsPArrTy ty) u q = pabrackets (ppr_mono_lty pREC_TOP ty u q) ppr_mono_ty _ (HsPredTy p) u q = parens (ppPred u q p)-ppr_mono_ty _ (HsNumTy n) _ _ = toHtml (show n) -- generics only ppr_mono_ty _ (HsSpliceTy {}) _ _ = error "ppr_mono_ty HsSpliceTy"+#if __GLASGOW_HASKELL__ == 612+ppr_mono_ty _ (HsSpliceTyOut {}) _ _ = error "ppr_mono_ty HsQuasiQuoteTy"+#else ppr_mono_ty _ (HsQuasiQuoteTy {}) _ _ = error "ppr_mono_ty HsQuasiQuoteTy"-ppr_mono_ty _ (HsCoreTy {}) _ _ = error "ppr_mono_ty HsCoreTy"+#endif ppr_mono_ty _ (HsRecTy {}) _ _ = error "ppr_mono_ty HsRecTy"+ppr_mono_ty _ (HsCoreTy {}) _ _ = error "ppr_mono_ty HsCoreTy" ppr_mono_ty ctxt_prec (HsAppTy fun_ty arg_ty) unicode qual = maybeParen ctxt_prec pREC_CON $
src/Haddock/Backends/Xhtml/Layout.hs view
@@ -176,8 +176,8 @@ -- a box for top level documented names -- it adds a source and wiki link at the right hand side of the box-topDeclElem :: LinksInfo -> SrcSpan -> DocName -> Html -> Html-topDeclElem ((_,_,sourceMap), (_,_,maybe_wiki_url)) loc name html =+topDeclElem :: LinksInfo -> SrcSpan -> [DocName] -> Html -> Html+topDeclElem ((_,_,sourceMap), (_,_,maybe_wiki_url)) loc names html = declElem << (html +++ srcLink +++ wikiLink) where srcLink = case Map.lookup origPkg sourceMap of@@ -201,7 +201,10 @@ origPkg = modulePackageId origMod -- Name must be documented, otherwise we wouldn't get here- Documented n mdl = name+ Documented n mdl = head names+ -- FIXME: is it ok to simply take the first name? - fname = unpackFS (srcSpanFile loc)+ fname = case loc of+ RealSrcSpan l -> unpackFS (srcSpanFile l)+ UnhelpfulSpan _ -> error "topDeclElem UnhelpfulSpan"
src/Haddock/Backends/Xhtml/Utils.hs view
@@ -37,7 +37,7 @@ import Text.XHtml hiding ( name, title, p, quote ) import qualified Text.XHtml as XHtml -import GHC ( SrcSpan, srcSpanStartLine, Name )+import GHC ( SrcSpan(..), srcSpanStartLine, Name ) import Module ( Module ) import Name ( getOccString, nameOccName, isValOcc ) @@ -59,7 +59,12 @@ line = case maybe_loc of Nothing -> ""- Just span_ -> show $ srcSpanStartLine span_+ Just span_ ->+ case span_ of+ RealSrcSpan span__ ->+ show $ srcSpanStartLine span__+ UnhelpfulSpan _ ->+ error "spliceURL UnhelpfulSpan" run "" = "" run ('%':'M':rest) = mdl ++ run rest
src/Haddock/Convert.hs view
@@ -18,7 +18,7 @@ import HsSyn-import TcType ( tcSplitSigmaTy )+import TcType ( tcSplitTyConApp_maybe, tcSplitSigmaTy ) import TypeRep import Coercion ( splitKindFunTys, synTyConResKind ) import Name@@ -44,11 +44,17 @@ -- into a ForD instead of a SigD if we wanted. Haddock doesn't -- need to care. AnId i -> SigD (synifyIdSig ImplicitizeForAll i)+ -- type-constructors (e.g. Maybe) are complicated, put the definition -- later in the file (also it's used for class associated-types too.) ATyCon tc -> TyClD (synifyTyCon tc)++ -- type-constructors (e.g. Maybe) are complicated, put the definition+ -- later in the file (also it's used for class associated-types too.)+ ACoAxiom ax -> TyClD (synifyAxiom ax)+ -- a data-constructor alone just gets rendered as a function:- ADataCon dc -> SigD (TypeSig (synifyName dc)+ ADataCon dc -> SigD (TypeSig [synifyName dc] (synifyType ImplicitizeForAll (dataConUserType dc))) -- classes are just a little tedious AClass cl ->@@ -71,6 +77,16 @@ synifyClassAT :: TyCon -> LTyClDecl Name synifyClassAT = noLoc . synifyTyCon +synifyAxiom :: CoAxiom -> TyClDecl Name+synifyAxiom (CoAxiom { co_ax_tvs = tvs, co_ax_lhs = lhs, co_ax_rhs = rhs })+ | Just (tc, args) <- tcSplitTyConApp_maybe lhs+ = let name = synifyName tc+ tyvars = synifyTyVars tvs+ typats = map (synifyType WithinType) args+ hs_rhs_ty = synifyType WithinType rhs+ in TySynonym name tyvars (Just typats) hs_rhs_ty+ | otherwise+ = error "synifyAxiom" synifyTyCon :: TyCon -> TyClDecl Name synifyTyCon tc@@ -162,11 +178,15 @@ use_named_field_syntax = not (null field_tys) name = synifyName dc -- con_qvars means a different thing depending on gadt-syntax+ (univ_tvs, ex_tvs, _eq_spec, theta, arg_tys, res_ty) = dataConFullSig dc+ qvars = if use_gadt_syntax- then synifyTyVars (dataConAllTyVars dc)- else synifyTyVars (dataConExTyVars dc)+ then synifyTyVars (univ_tvs ++ ex_tvs)+ else synifyTyVars ex_tvs+ -- skip any EqTheta, use 'orig'inal syntax- ctx = synifyCtx (dataConDictTheta dc)+ ctx = synifyCtx theta+ linear_tys = zipWith (\ty bang -> let tySyn = synifyType WithinType ty in case bang of@@ -175,23 +195,23 @@ -- HsNoBang never appears, it's implied instead. _ -> noLoc $ HsBangTy bang tySyn )- (dataConOrigArgTys dc) (dataConStrictMarks dc)+ arg_tys (dataConStrictMarks dc) field_tys = zipWith (\field synTy -> ConDeclField (synifyName field) synTy Nothing) (dataConFieldLabels dc) linear_tys- tys = case (use_named_field_syntax, use_infix_syntax) of+ hs_arg_tys = case (use_named_field_syntax, use_infix_syntax) of (True,True) -> error "synifyDataCon: contradiction!" (True,False) -> RecCon field_tys (False,False) -> PrefixCon linear_tys (False,True) -> case linear_tys of [a,b] -> InfixCon a b _ -> error "synifyDataCon: infix with non-2 args?"- res_ty = if use_gadt_syntax- then ResTyGADT (synifyType WithinType (dataConOrigResTy dc))- else ResTyH98+ hs_res_ty = if use_gadt_syntax+ then ResTyGADT (synifyType WithinType res_ty)+ else ResTyH98 -- finally we get synifyDataCon's result! in ConDecl name Implicit{-we don't know nor care-}- qvars ctx tys res_ty Nothing+ qvars ctx hs_arg_tys hs_res_ty Nothing False --we don't want any "deprecated GADT syntax" warnings! @@ -200,7 +220,7 @@ synifyIdSig :: SynifyTypeState -> Id -> Sig Name-synifyIdSig s i = TypeSig (synifyName i) (synifyType s (varType i))+synifyIdSig s i = TypeSig [synifyName i] (synifyType s (varType i)) synifyCtx :: [PredType] -> LHsContext Name
src/Haddock/GhcUtils.hs view
@@ -17,6 +17,7 @@ import Data.Version+import Control.Applicative ( (<$>) ) import Control.Arrow import Data.Foldable hiding (concatMap) import Data.Traversable@@ -81,20 +82,56 @@ isVarSym = isLexVarSym . occNameFS -getMainDeclBinder :: HsDecl name -> Maybe name-getMainDeclBinder (TyClD d) = Just (tcdName d)+getMainDeclBinder :: HsDecl name -> [name]+getMainDeclBinder (TyClD d) = [tcdName d] getMainDeclBinder (ValD d) =+#if __GLASGOW_HASKELL__ == 612+ case collectAcc d [] of+ [] -> []+ (name:_) -> [unLoc name]+#else case collectHsBindBinders d of+ [] -> []+ (name:_) -> [name]+#endif++getMainDeclBinder (SigD d) = sigNameNoLoc d+getMainDeclBinder (ForD (ForeignImport name _ _)) = [unLoc name]+getMainDeclBinder (ForD (ForeignExport _ _ _)) = []+getMainDeclBinder _ = []++-- Useful when there is a signature with multiple names, e.g.+-- foo, bar :: Types..+-- but only one of the names is exported and we have to change the+-- type signature to only include the exported names.+filterLSigNames :: (name -> Bool) -> LSig name -> Maybe (LSig name)+filterLSigNames p (L loc sig) = L loc <$> (filterSigNames p sig)++filterSigNames :: (name -> Bool) -> Sig name -> Maybe (Sig name)+filterSigNames p orig@(SpecSig n _ _) = ifTrueJust (p $ unLoc n) orig+filterSigNames p orig@(InlineSig n _) = ifTrueJust (p $ unLoc n) orig+filterSigNames p orig@(FixSig (FixitySig n _)) = ifTrueJust (p $ unLoc n) orig+filterSigNames p (TypeSig ns ty) =+ case filter (p . unLoc) ns of [] -> Nothing- (name:_) -> Just name+ filtered -> Just (TypeSig filtered ty)+filterSigNames _ _ = Nothing +ifTrueJust :: Bool -> name -> Maybe name+ifTrueJust True = Just+ifTrueJust False = const Nothing -getMainDeclBinder (SigD d) = sigNameNoLoc d-getMainDeclBinder (ForD (ForeignImport name _ _)) = Just (unLoc name)-getMainDeclBinder (ForD (ForeignExport _ _ _)) = Nothing-getMainDeclBinder _ = Nothing+sigName :: LSig name -> [name]+sigName (L _ sig) = sigNameNoLoc sig +sigNameNoLoc :: Sig name -> [name]+sigNameNoLoc (TypeSig ns _) = map unLoc ns+sigNameNoLoc (SpecSig n _ _) = [unLoc n]+sigNameNoLoc (InlineSig n _) = [unLoc n]+sigNameNoLoc (FixSig (FixitySig n _)) = [unLoc n]+sigNameNoLoc _ = [] + isTyClD :: HsDecl a -> Bool isTyClD (TyClD _) = True isTyClD _ = False@@ -142,11 +179,11 @@ reL = L undefined -instance Foldable Located where+instance Foldable (GenLocated l) where foldMap f (L _ x) = f x -instance Traversable Located where+instance Traversable (GenLocated l) where mapM f (L l x) = (return . L l) =<< f x @@ -184,7 +221,7 @@ | isDataDecl d = map (unL . con_name . unL) . tcdCons $ d | isClassDecl d = map (tcdName . unL) (tcdATs d) ++- [ unL n | L _ (TypeSig n _) <- tcdSigs d ]+ [ unL n | L _ (TypeSig ns _) <- tcdSigs d, n <- ns ] | otherwise = []
src/Haddock/Interface/AttachInstances.hs view
@@ -30,9 +30,10 @@ #else import HscTypes (withSession) #endif+import TysPrim( funTyCon ) import MonadUtils (liftIO) import TcRnDriver (tcRnGetInfo)-import TypeRep hiding (funTyConName)+import TypeRep import Var hiding (varName) import TyCon import PrelNames
src/Haddock/Interface/Create.hs view
@@ -35,9 +35,9 @@ import RdrName (GlobalRdrEnv) --- | Process the data in a GhcModule to produce an interface.+-- | Use a 'TypecheckedModule' to produce an 'Interface'. -- To do this, we need access to already processed modules in the topological--- sort. That's what's in the interface map.+-- sort. That's what's in the 'IfaceMap'. createInterface :: TypecheckedModule -> [Flag] -> IfaceMap -> InstIfaceMap -> ErrMsgGhc Interface createInterface tm flags modMap instIfaceMap = do@@ -69,13 +69,15 @@ decls = filterOutInstances decls0 declMap = mkDeclMap decls- exports = fmap (reverse . map unLoc) optExports- ignoreExps = Flag_IgnoreAllExports `elem` flags+ exports0 = fmap (reverse . map unLoc) optExports+ exports+ | OptIgnoreExports `elem` opts = Nothing+ | otherwise = exports0 liftErrMsg $ warnAboutFilteredDecls mdl decls0 exportItems <- mkExportItems modMap mdl gre exportedNames decls declMap- opts exports ignoreExps instances instIfaceMap dflags+ exports instances instIfaceMap dflags let visibleNames = mkVisibleNames exportItems opts @@ -174,9 +176,10 @@ -- subordinate names, but map them to their parent declarations. mkDeclMap :: [DeclInfo] -> Map Name DeclInfo mkDeclMap decls = Map.fromList . concat $- [ (declName d, (parent, doc, subs)) : subDecls+ [ decls_ ++ subDecls | (parent@(L _ d), doc, subs) <- decls- , let subDecls = [ (n, (parent, doc', [])) | (n, doc') <- subs ]+ , let decls_ = [ (name, (parent, doc, subs)) | name <- declNames d ]+ subDecls = [ (n, (parent, doc', [])) | (n, doc') <- subs ] , not (isDocD d), not (isInstD d) ] @@ -225,8 +228,9 @@ | isDataDecl decl = dataSubs | otherwise = [] where- classSubs = [ (declName d, doc, fnArgsDoc)+ classSubs = [ (name, doc, fnArgsDoc) | (L _ d, doc) <- classDecls decl+ , name <- declNames d , let fnArgsDoc = getDeclFnArgDocs d ] dataSubs = constrs ++ fields where@@ -257,12 +261,12 @@ ats = mkDecls tcdATs TyClD class_ -declName :: HsDecl a -> a-declName (TyClD d) = tcdName d-declName (ForD (ForeignImport n _ _)) = unLoc n+declNames :: HsDecl a -> [a]+declNames (TyClD d) = [tcdName d]+declNames (ForD (ForeignImport n _ _)) = [unLoc n] -- we have normal sigs only (since they are taken from ValBindsOut)-declName (SigD sig) = fromJust $ sigNameNoLoc sig-declName _ = error "unexpected argument to declName"+declNames (SigD sig) = sigNameNoLoc sig+declNames _ = error "unexpected argument to declNames" -- | The top-level declarations of a module that we care about,@@ -442,38 +446,39 @@ -> [Name] -- exported names (orig) -> [DeclInfo] -> Map Name DeclInfo -- maps local names to declarations- -> [DocOption] -> Maybe [IE Name]- -> Bool -- --ignore-all-exports flag -> [Instance] -> InstIfaceMap -> DynFlags -> ErrMsgGhc [ExportItem Name]--mkExportItems modMap this_mod gre exported_names decls declMap- opts maybe_exps ignore_all_exports _ instIfaceMap dflags- | isNothing maybe_exps || ignore_all_exports || OptIgnoreExports `elem` opts- = everything_local_exported- | otherwise = liftM concat $ mapM lookupExport (fromJust maybe_exps)+mkExportItems modMap thisMod gre exportedNames decls declMap+ optExports _ instIfaceMap dflags =+ case optExports of+ Nothing -> liftErrMsg $ fullContentsOfThisModule dflags gre decls+ Just exports -> liftM (nubBy commaDeclared . concat) $ mapM lookupExport exports where--- everything_local_exported = -- everything exported- liftErrMsg $ fullContentsOfThisModule dflags gre decls+ -- A type signature can have multiple names, like:+ -- foo, bar :: Types..+ -- When going throug the exported names we have to take care to detect such+ -- situations and remove the duplicates.+ commaDeclared (ExportDecl (L _ sig1) _ _ _) (ExportDecl (L _ sig2) _ _ _) =+ getMainDeclBinder sig1 == getMainDeclBinder sig2+ commaDeclared _ _ = False - lookupExport (IEVar x) = declWith x- lookupExport (IEThingAbs t) = declWith t+ lookupExport (IEVar x) = declWith x+ lookupExport (IEThingAbs t) = declWith t lookupExport (IEThingAll t) = declWith t lookupExport (IEThingWith t _) = declWith t- lookupExport (IEModuleContents m) = fullContentsOf m+ lookupExport (IEModuleContents m) =+ moduleExports thisMod m dflags gre exportedNames decls modMap instIfaceMap lookupExport (IEGroup lev docStr) = liftErrMsg $ ifDoc (lexParseRnHaddockComment dflags DocSectionComment gre docStr) (\doc -> return [ ExportGroup lev "" doc ]) lookupExport (IEDoc docStr) = liftErrMsg $ ifDoc (lexParseRnHaddockComment dflags NormalHaddockComment gre docStr) (\doc -> return [ ExportDoc doc ])- lookupExport (IEDocNamed str) = liftErrMsg $+ lookupExport (IEDocNamed str) = liftErrMsg $ ifDoc (findNamedDoc str [ unL d | (d,_,_) <- decls ]) (\docStr -> ifDoc (lexParseRnHaddockComment dflags NormalHaddockComment gre docStr)@@ -489,11 +494,8 @@ declWith :: Name -> ErrMsgGhc [ ExportItem Name ] declWith t = case findDecl t of- Just x@(decl,_,_) ->- let declName_ =- case getMainDeclBinder (unL decl) of- Just n -> n- Nothing -> error "declWith: should not happen"+ Just (decl, doc, subs) ->+ let declNames_ = getMainDeclBinder (unL decl) in case () of _ -- temp hack: we filter out separately exported ATs, since we haven't decided how@@ -503,10 +505,10 @@ -- We should not show a subordinate by itself if any of its -- parents is also exported. See note [1].- | t /= declName_,+ | not $ t `elem` declNames_, Just p <- find isExported (parents t $ unL decl) -> do liftErrMsg $ tell [- "Warning: " ++ moduleString this_mod ++ ": " +++ "Warning: " ++ moduleString thisMod ++ ": " ++ pretty (nameOccName t) ++ " is exported separately but " ++ "will be documented under " ++ pretty (nameOccName p) ++ ". Consider exporting it together with its parent(s)" ++@@ -514,7 +516,18 @@ return [] -- normal case- | otherwise -> return [ mkExportDecl t x ]+ | otherwise -> return [ mkExportDecl t (newDecl, doc, subs) ]+ where+ -- Since a single signature might refer to many names, we+ -- need to filter the ones that are actually exported. This+ -- requires modifying the type signatures to "hide" the+ -- names that are not exported.+ newDecl = case decl of+ (L loc (SigD sig)) ->+ L loc . SigD . fromJust $ filterSigNames isExported sig+ -- fromJust is safe since we already checked in guards+ -- that 't' is a name declared in this declaration.+ _ -> decl Nothing -> do -- If we can't find the declaration, it must belong to -- another package@@ -524,7 +537,7 @@ -- looked for the .hi/.haddock). It's to help people -- debugging after all, so good to show more info. let exportInfoString =- moduleString this_mod ++ "." ++ getOccString t+ moduleString thisMod ++ "." ++ getOccString t ++ ": " ++ pretty (nameModule t) ++ "." ++ getOccString t @@ -630,38 +643,16 @@ where decl' = ExportDecl (restrictTo sub_names (extractDecl n mdl decl)) doc subs' [] mdl = nameModule n- subs' = filter ((`elem` exported_names) . fst) subs+ subs' = filter (isExported . fst) subs sub_names = map fst subs' - isExported = (`elem` exported_names)--- fullContentsOf modname- | m == this_mod = liftErrMsg $ fullContentsOfThisModule dflags gre decls- | otherwise =- case Map.lookup m modMap of- Just iface- | OptHide `elem` ifaceOptions iface -> return (ifaceExportItems iface)- | otherwise -> return [ ExportModule m ]-- Nothing -> -- we have to try to find it in the installed interfaces- -- (external packages)- case Map.lookup modname (Map.mapKeys moduleName instIfaceMap) of- Just iface -> return [ ExportModule (instMod iface) ]- Nothing -> do- liftErrMsg $- tell ["Warning: " ++ pretty this_mod ++ ": Could not find " ++- "documentation for exported module: " ++ pretty modname]- return []- where- m = mkModule packageId modname- packageId = modulePackageId this_mod+ isExported = (`elem` exportedNames) findDecl :: Name -> Maybe DeclInfo findDecl n- | m == this_mod = Map.lookup n declMap+ | m == thisMod = Map.lookup n declMap | otherwise = case Map.lookup m modMap of Just iface -> Map.lookup n (ifaceDeclMap iface) Nothing -> Nothing@@ -669,6 +660,50 @@ m = nameModule n +-- | Return all export items produced by an exported module. That is, we're+-- interested in the exports produced by \"module B\" in such a scenario:+--+-- > module A (module B) where+-- > import B (...) hiding (...)+--+-- There are three different cases to consider:+--+-- 1) B is hidden, in which case we return all its exports that are in scope in A.+-- 2) B is visible, but not all its exports are in scope in A, in which case we+-- only return those that are.+-- 3) B is visible and all its exports are in scope, in which case we return+-- a single 'ExportModule' item. +moduleExports :: Module -- ^ Module A+ -> ModuleName -- ^ The real name of B, the exported module+ -> DynFlags -- ^ The flag used when typechecking A+ -> GlobalRdrEnv -- ^ The renaming environment used for A+ -> [Name] -- ^ All the exports of A+ -> [DeclInfo] -- ^ All the declarations in A+ -> IfaceMap -- ^ Already created interfaces+ -> InstIfaceMap -- ^ Interfaces in other packages+ -> ErrMsgGhc [ExportItem Name] -- ^ Resulting export items+moduleExports thisMod expMod dflags gre _exports decls ifaceMap instIfaceMap+ | m == thisMod = liftErrMsg $ fullContentsOfThisModule dflags gre decls+ | otherwise =+ case Map.lookup m ifaceMap of+ Just iface+ | OptHide `elem` ifaceOptions iface -> return (ifaceExportItems iface)+ | otherwise -> return [ ExportModule m ]++ Nothing -> -- we have to try to find it in the installed interfaces+ -- (external packages)+ case Map.lookup expMod (Map.mapKeys moduleName instIfaceMap) of+ Just iface -> return [ ExportModule (instMod iface) ]+ Nothing -> do+ liftErrMsg $+ tell ["Warning: " ++ pretty thisMod ++ ": Could not find " +++ "documentation for exported module: " ++ pretty expMod]+ return []+ where+ m = mkModule packageId expMod+ packageId = modulePackageId thisMod++ -- Note [1]: ------------ -- It is unnecessary to document a subordinate by itself at the top level if@@ -704,11 +739,11 @@ -- together a type signature for it...) extractDecl :: Name -> Module -> Decl -> Decl extractDecl name mdl decl- | Just n <- getMainDeclBinder (unLoc decl), n == name = decl+ | name `elem` getMainDeclBinder (unLoc decl) = decl | otherwise = case unLoc decl of TyClD d | isClassDecl d ->- let matches = [ sig | sig <- tcdSigs d, sigName sig == Just name,+ let matches = [ sig | sig <- tcdSigs d, name `elem` sigName sig, isVanillaLSig sig ] -- TODO: document fixity in case matches of [s0] -> let (n, tyvar_names) = name_and_tyvars d@@ -746,7 +781,7 @@ extractRecSel nm mdl t tvs (L _ con : rest) = case con_details con of RecCon fields | (ConDeclField n ty _ : _) <- matching_fields fields ->- L (getLoc n) (TypeSig (noLoc nm) (noLoc (HsFunTy data_ty (getBangType ty))))+ L (getLoc n) (TypeSig [noLoc nm] (noLoc (HsFunTy data_ty (getBangType ty)))) _ -> extractRecSel nm mdl t tvs rest where matching_fields flds = [ f | f@(ConDeclField n _ _) <- flds, unLoc n == nm ]@@ -766,10 +801,7 @@ | OptHide `elem` opts = [] | otherwise = concatMap exportName exports where- exportName e@ExportDecl {} =- case getMainDeclBinder $ unL $ expItemDecl e of- Just n -> n : subs- Nothing -> subs+ exportName e@ExportDecl {} = getMainDeclBinder (unL $ expItemDecl e) ++ subs where subs = map fst (expItemSubDocs e) exportName ExportNoDecl {} = [] -- we don't count these as visible, since -- we don't want links to go to them.
src/Haddock/Interface/Rename.hs view
@@ -265,8 +265,6 @@ HsParTy ty -> return . HsParTy =<< renameLType ty - HsNumTy n -> return (HsNumTy n)- HsPredTy p -> return . HsPredTy =<< renamePred p HsKindSig ty k -> do@@ -403,10 +401,10 @@ renameSig :: Sig Name -> RnM (Sig DocName) renameSig sig = case sig of- TypeSig lname ltype -> do- lname' <- renameL lname+ TypeSig lnames ltype -> do+ lnames' <- mapM renameL lnames ltype' <- renameLType ltype- return (TypeSig lname' ltype')+ return (TypeSig lnames' ltype') -- we have filtered out all other kinds of signatures in Interface.Create _ -> error "expected TypeSig"
src/Haddock/Interface/Rn.hs view
@@ -6,7 +6,7 @@ import RdrName ( RdrName, gre_name, GlobalRdrEnv, lookupGRE_RdrName ) import Name ( Name )-import Outputable ( ppr, defaultUserStyle )+import Outputable ( ppr, showSDoc ) rnHaddockModInfo :: GlobalRdrEnv -> HaddockModInfo RdrName -> HaddockModInfo Name rnHaddockModInfo gre (HaddockModInfo desc port stab maint) =@@ -14,7 +14,7 @@ ids2string :: [RdrName] -> String ids2string [] = []-ids2string (x:_) = show $ ppr x defaultUserStyle+ids2string (x:_) = showSDoc $ ppr x data Id x = Id {unId::x} instance Monad Id where (Id v)>>=f = f v; return = Id
src/Haddock/InterfaceFile.hs view
@@ -68,6 +68,10 @@ binaryInterfaceVersion = 16 #elif __GLASGOW_HASKELL__ == 701 binaryInterfaceVersion = 16+#elif __GLASGOW_HASKELL__ == 702+binaryInterfaceVersion = 16+#elif __GLASGOW_HASKELL__ == 703+binaryInterfaceVersion = 16 #else #error Unknown GHC version #endif
src/Haddock/Lex.x view
@@ -28,6 +28,7 @@ import RdrName import SrcLoc import DynFlags+import FastString import Data.Char import Numeric@@ -178,19 +179,25 @@ ident :: Action ident pos str sc cont dflags = - case strToHsQNames dflags id of+ case strToHsQNames dflags loc id of Just names -> (TokIdent names, pos) : cont sc Nothing -> (TokString str, pos) : cont sc where id = init (tail str)+ -- TODO: Get the real filename here. Maybe we should just be+ -- using GHC SrcLoc's ourself?+ filename = mkFastString "<unknown file>"+ loc = case pos of+ AlexPn _ line col ->+ mkRealSrcLoc filename line col -strToHsQNames :: DynFlags -> String -> Maybe [RdrName]-strToHsQNames dflags str0 = +strToHsQNames :: DynFlags -> RealSrcLoc -> String -> Maybe [RdrName]+strToHsQNames dflags loc str0 = #if MIN_VERSION_ghc(7,1,0) let buffer = stringToStringBuffer str0 #else let buffer = unsafePerformIO (stringToStringBuffer str0) #endif- pstate = mkPState dflags buffer noSrcLoc+ pstate = mkPState dflags buffer loc result = unP parseIdentifier pstate in case result of POk _ name -> Just [unLoc name]
src/Haddock/Parse.y view
@@ -129,13 +129,20 @@ -- whitespace in expressions, so drop them result' where- -- drop trailing whitespace from the prompt, remember the prefix+ -- 1. drop trailing whitespace from the prompt, remember the prefix (prefix, _) = span isSpace prompt- -- drop, if possible, the exact same sequence of whitespace characters- -- from each result line- result' = map (tryStripPrefix prefix) result++ -- 2. drop, if possible, the exact same sequence of whitespace+ -- characters from each result line+ --+ -- 3. interpret lines that only contain the string "<BLANKLINE>" as an+ -- empty line+ result' = map (substituteBlankLine . tryStripPrefix prefix) result where tryStripPrefix xs ys = fromMaybe ys $ stripPrefix xs ys++ substituteBlankLine "<BLANKLINE>" = ""+ substituteBlankLine line = line -- | Remove all leading and trailing whitespace strip :: String -> String
src/Haddock/Types.hs view
@@ -26,7 +26,6 @@ import Data.Map (Map) import qualified Data.Map as Map import GHC hiding (NoLink)-import Name -----------------------------------------------------------------------------
src/Haddock/Utils.hs view
@@ -68,7 +68,7 @@ import qualified Data.Map as Map hiding ( Map ) import Data.IORef ( IORef, newIORef, readIORef ) import Data.List ( isSuffixOf )-import Data.Maybe ( fromJust )+import Data.Maybe ( mapMaybe ) import System.Environment ( getProgName ) import System.Exit ( exitWith, ExitCode(..) ) import System.IO ( hPutStr, stderr )@@ -160,9 +160,7 @@ restrictDecls :: [Name] -> [LSig Name] -> [LSig Name]-restrictDecls names decls = filter keep decls- where keep d = fromJust (sigName d) `elem` names- -- has to have a name, since it's a class method type signature+restrictDecls names decls = mapMaybe (filterLSigNames (`elem` names)) decls restrictATs :: [Name] -> [LTyClDecl Name] -> [LTyClDecl Name]
src/Main.hs view
@@ -57,7 +57,7 @@ import GHC hiding (flags, verbosity) import Config import DynFlags hiding (flags, verbosity)-import Panic (handleGhcException)+import Panic (panic, handleGhcException) import Module @@ -393,7 +393,7 @@ [] -> return Nothing [filename] -> do str <- readFile filename- case parseParas (tokenise defaultDynFlags str+ case parseParas (tokenise (defaultDynFlags (panic "No settings")) str (1,0) {- TODO: real position -}) of Nothing -> throwE $ "failed to parse haddock prologue from file: " ++ filename Just doc -> return (Just doc)@@ -416,18 +416,17 @@ getExecDir :: IO (Maybe String) #if defined(mingw32_HOST_OS)-getExecDir = allocaArray len $ \buf -> do- ret <- getModuleFileName nullPtr buf len- if ret == 0 then- return Nothing- else do- s <- peekCString buf- return (Just (dropFileName s))- where len = 2048 -- Plenty, PATH_MAX is 512 under Win32.-+getExecDir = try_size 2048 -- plenty, PATH_MAX is 512 under Win32.+ where+ try_size size = allocaArray (fromIntegral size) $ \buf -> do+ ret <- c_GetModuleFileName nullPtr buf size+ case ret of+ 0 -> return Nothing+ _ | ret < size -> fmap (Just . dropFileName) $ peekCWString buf+ | otherwise -> try_size (size * 2) -foreign import stdcall unsafe "GetModuleFileNameA"- getModuleFileName :: Ptr () -> CString -> Int -> IO Int32+foreign import stdcall unsafe "windows.h GetModuleFileNameW"+ c_GetModuleFileName :: Ptr () -> CWString -> Word32 -> IO Word32 #else getExecDir = return Nothing #endif
+ tests/html-tests/runtests.hs view
@@ -0,0 +1,117 @@+import System.Cmd+import System.Environment+import System.FilePath+import System.Exit+import System.Directory+import System.Process+import Data.List+import Control.Monad+import Text.Printf+import Text.Regex+import Distribution.Simple.Utils+import Distribution.Simple.Program+import Distribution.Verbosity+import Data.Maybe+++packageRoot = "."+haddockPath = packageRoot </> "dist" </> "build" </> "haddock" </> "haddock"+testSuiteRoot = packageRoot </> "tests" </> "html-tests"+testDir = testSuiteRoot </> "tests"+outDir = testSuiteRoot </> "output"+++main = do+ test+ putStrLn "All tests passed!"+++test = do+ x <- doesFileExist haddockPath+ when (not x) $ die "you need to run 'cabal build' successfully first"++ contents <- getDirectoryContents testDir+ args <- getArgs+ let (opts, spec) = span ("-" `isPrefixOf`) args+ let mods =+ case spec of+ x:_ | x /= "all" -> [x ++ ".hs"]+ _ -> filter ((==) ".hs" . takeExtension) contents++ let mods' = map (testDir </>) mods+ putStrLn ""+ putStrLn "Haddock version: "+ h1 <- runProcess haddockPath ["--version"] Nothing+ (Just [("haddock_datadir", packageRoot)]) Nothing Nothing Nothing+ waitForProcess h1+ putStrLn ""+ putStrLn "GHC version: "+ h2 <- runProcess haddockPath ["--ghc-version"] Nothing+ (Just [("haddock_datadir", packageRoot)]) Nothing Nothing Nothing+ waitForProcess h2+ putStrLn ""++ -- TODO: use Distribution.* to get the packages instead+ libdir <- rawSystemStdout normal haddockPath ["--print-ghc-libdir"]+ let librariesPath = ".."</>".."</>"share"</>"doc"</>"ghc"</>"html"</>"libraries"++ let mkDep name version =+ let path = init libdir </> librariesPath </> name ++ "-" ++ version+ in "-i " ++ path ++ "," ++ path </> name ++ ".haddock"++ let base = mkDep "base" "4.3.1.0"+ process = mkDep "process" "1.0.1.5"+ ghcprim = mkDep "ghc-prim" "0.2.0.0"++ putStrLn "Running tests..."+ handle <- runProcess haddockPath+ (["-w", "-o", outDir, "-h", "--pretty-html", "--optghc=-fglasgow-exts"+ , "--optghc=-w", base, process, ghcprim] ++ opts ++ mods')+ Nothing (Just [("haddock_datadir", packageRoot)]) Nothing+ Nothing Nothing++ code <- waitForProcess handle+ when (code /= ExitSuccess) $ error "Haddock run failed! Exiting."+ check mods (if not (null args) && args !! 0 == "all" then False else True)+++check modules strict = do+ forM_ modules $ \mod -> do+ let outfile = outDir </> dropExtension mod ++ ".html"+ let reffile = testDir </> dropExtension mod ++ ".html.ref"+ b <- doesFileExist reffile+ if b+ then do+ copyFile reffile (outDir </> takeFileName reffile)+ out <- readFile outfile+ ref <- readFile reffile+ if not $ haddockEq out ref+ then do+ putStrLn $ "Output for " ++ mod ++ " has changed! Exiting with diff:"+ let ref' = stripLinks ref+ out' = stripLinks out+ let reffile' = outDir </> takeFileName reffile ++ ".nolinks"+ outfile' = outDir </> takeFileName outfile ++ ".nolinks"+ writeFile reffile' ref'+ writeFile outfile' out'+ b <- programOnPath "colordiff"+ if b+ then system $ "colordiff " ++ reffile' ++ " " ++ outfile'+ else system $ "diff " ++ reffile' ++ " " ++ outfile'+ if strict then exitFailure else return ()+ else do+ putStrLn $ "Pass: " ++ mod+ else do+ putStrLn $ "Pass: " ++ mod ++ " (no .ref file)"+++haddockEq file1 file2 = stripLinks file1 == stripLinks file2+++stripLinks f = subRegex (mkRegexWithOpts "<A HREF=[^>]*>" False False) f "<A HREF=\"\">"+++programOnPath p = do+ result <- findProgramLocation silent p+ return (isJust result)+