diff options
149 files changed, 5510 insertions, 968 deletions
@@ -0,0 +1 @@ +:set -isrc -idist/build/autogen -idist/build/haddock/haddock-tmp/ -packageghc -optP-include -optPdist/build/autogen/cabal_macros.h diff --git a/.gitignore b/.gitignore new file mode 100644 index 00000000..7fcbdc38 --- /dev/null +++ b/.gitignore @@ -0,0 +1,2 @@ +/dist/ +/doc/haddock @@ -1,3 +1,28 @@ +Changes in version 2.12.0 + + * Labeled URLs (e.g <http://example.net/ some label>) + +Changes in version 2.11.0 + + * Show deprecation messages for identifiers + + * List identifiers declared on the same line (with a common type) separately + + * Don't crash on unicode strings in doc comments + + * Fix reporting of modules safe haskell mode + + * Fix a case where we were generating invalid xhtml + + * Improved --qual option (no crashes, proper error messages) + + * A new --qual option "aliased" which qualifies identifers by the module alias + used in the source code + + * The Haddock API restores GHC's static flags after invocation + + * Access to unexported identifiers through the Haddock API again + Changes in version 2.10.0 * Require GHC >= 7.4 diff --git a/doc/haddock.xml b/doc/haddock.xml index 7b5a07e6..7ddfdccd 100644 --- a/doc/haddock.xml +++ b/doc/haddock.xml @@ -21,7 +21,7 @@ <holder>Simon Marlow, David Waern</holder> </copyright> <abstract> - <para>This document describes Haddock version 2.10.0, a Haskell + <para>This document describes Haddock version 2.12.0, a Haskell documentation tool.</para> </abstract> </bookinfo> diff --git a/haddock.cabal b/haddock.cabal index 84d3c2a8..f70d6813 100644 --- a/haddock.cabal +++ b/haddock.cabal @@ -1,5 +1,5 @@ name: haddock -version: 2.10.0 +version: 2.12.0 synopsis: A documentation-generation tool for Haskell libraries description: Haddock is a documentation-generation tool for Haskell libraries @@ -83,15 +83,16 @@ executable haddock if !flag(in-ghc-tree) build-tools: alex >= 2.3, happy >= 1.18 build-depends: - base >= 4.3 && < 4.6, + base >= 4.3 && < 4.7, filepath, directory, pretty, containers, + deepseq, array, xhtml >= 3000.2 && < 3000.3, Cabal >= 1.10, - ghc >= 7.4 && < 7.6 + ghc >= 7.4 && < 7.8 if flag(in-ghc-tree) cpp-options: -DIN_GHC_TREE @@ -104,8 +105,6 @@ executable haddock main-is: Main.hs hs-source-dirs: src - default-extensions: CPP, DeriveDataTypeable, - ScopedTypeVariables, MagicHash ghc-options: -funbox-strict-fields -O2 -Wall -fwarn-tabs other-modules: @@ -145,15 +144,16 @@ library if !flag(in-ghc-tree) build-tools: alex >= 2.3, happy >= 1.18 build-depends: - base >= 4.3 && < 4.6, + base >= 4.3 && < 4.7, filepath, directory, pretty, containers, + deepseq, array, xhtml >= 3000.2 && < 3000.3, Cabal >= 1.10, - ghc >= 7.4 && < 7.6 + ghc >= 7.4 && < 7.8 if flag(in-ghc-tree) cpp-options: -DIN_GHC_TREE @@ -165,8 +165,6 @@ library build-depends: QuickCheck >= 2.1 && < 3 hs-source-dirs: src - default-extensions: CPP, DeriveDataTypeable, - ScopedTypeVariables, MagicHash ghc-options: -funbox-strict-fields -O2 -Wall -fwarn-tabs exposed-modules: diff --git a/haddock.spec b/haddock.spec index 4a602e02..d8821a4a 100644 --- a/haddock.spec +++ b/haddock.spec @@ -17,7 +17,7 @@ # version label of your release tarball. %define name haddock -%define version 2.10.0 +%define version 2.12.0 %define release 1 Name: %{name} diff --git a/html/Classic.theme/xhaddock.css b/html/Classic.theme/xhaddock.css index d6b58d22..40ea0d06 100644 --- a/html/Classic.theme/xhaddock.css +++ b/html/Classic.theme/xhaddock.css @@ -488,6 +488,6 @@ td.rdoc p { background: inherit; } - - - +.warning { + color: red; +} diff --git a/html/Ocean.std-theme/ocean.css b/html/Ocean.std-theme/ocean.css index e0ba8b0c..42238709 100644 --- a/html/Ocean.std-theme/ocean.css +++ b/html/Ocean.std-theme/ocean.css @@ -429,6 +429,10 @@ div#style-menu-holder { padding-left: 2em; } +.warning { + color: red; +} + .arguments { margin-top: -0.4em; } diff --git a/html/frames.html b/html/frames.html index 30ce1fa5..1b4e38d4 100644 --- a/html/frames.html +++ b/html/frames.html @@ -3,6 +3,7 @@ "http://www.w3.org/TR/xhtml1/DTD/xhtml1-frameset.dtd"> <html xmlns="http://www.w3.org/1999/xhtml"> <head> +<title></title> <script src="haddock-util.js" type="text/javascript"></script> <script type="text/javascript"><!-- /* @@ -18,11 +19,12 @@ function load() { postReframe(); } --></script> +</head> <frameset id="outer-fs" cols="25%,75%" onload="load()"> <frameset id="inner-fs" rows="100%,0%"> - <frame src="index-frames.html" name="modules"> - <frame src="" name="synopsis"> + <frame src="index-frames.html" name="modules" /> + <frame src="" name="synopsis" /> </frameset> - <frame src="index.html" name="main"> + <frame src="index.html" name="main" /> </frameset> </html> diff --git a/src/Haddock/Backends/Hoogle.hs b/src/Haddock/Backends/Hoogle.hs index 6e3e306a..4949daa1 100644 --- a/src/Haddock/Backends/Hoogle.hs +++ b/src/Haddock/Backends/Hoogle.hs @@ -34,24 +34,25 @@ prefix = ["-- Hoogle documentation, generated by Haddock" ,""] -ppHoogle :: String -> String -> String -> Maybe (Doc RdrName) -> [Interface] -> FilePath -> IO () -ppHoogle package version synopsis prologue ifaces odir = do +ppHoogle :: DynFlags -> String -> String -> String -> Maybe (Doc RdrName) -> [Interface] -> FilePath -> IO () +ppHoogle dflags package version synopsis prologue ifaces odir = do let filename = package ++ ".txt" contents = prefix ++ - docWith (drop 2 $ dropWhile (/= ':') synopsis) prologue ++ + docWith dflags (drop 2 $ dropWhile (/= ':') synopsis) prologue ++ ["@package " ++ package] ++ ["@version " ++ version | version /= ""] ++ - concat [ppModule i | i <- ifaces, OptHide `notElem` ifaceOptions i] + concat [ppModule dflags i | i <- ifaces, OptHide `notElem` ifaceOptions i] h <- openFile (odir </> filename) WriteMode hSetEncoding h utf8 hPutStr h (unlines contents) hClose h -ppModule :: Interface -> [String] -ppModule iface = "" : doc (ifaceDoc iface) ++ - ["module " ++ moduleString (ifaceMod iface)] ++ - concatMap ppExport (ifaceExportItems iface) ++ - concatMap ppInstance (ifaceInstances iface) +ppModule :: DynFlags -> Interface -> [String] +ppModule dflags iface = + "" : ppDocumentation dflags (ifaceDoc iface) ++ + ["module " ++ moduleString (ifaceMod iface)] ++ + concatMap (ppExport dflags) (ifaceExportItems iface) ++ + concatMap (ppInstance dflags) (ifaceInstances iface) --------------------------------------------------------------------- @@ -74,8 +75,8 @@ dropHsDocTy = f f (HsDocTy a _) = f $ unL a f x = x -outHsType :: OutputableBndr a => HsType a -> String -outHsType = out . dropHsDocTy +outHsType :: OutputableBndr a => DynFlags -> HsType a -> String +outHsType dflags = out dflags . dropHsDocTy makeExplicit :: HsType a -> HsType a @@ -92,8 +93,8 @@ dropComment (x:xs) = x : dropComment xs dropComment [] = [] -out :: Outputable a => a -> String -out = f . unwords . map (dropWhile isSpace) . lines . showSDocUnqual . ppr +out :: Outputable a => DynFlags -> a -> String +out dflags = f . unwords . map (dropWhile isSpace) . lines . showSDocUnqual dflags . ppr where f xs | " <document comment>" `isPrefixOf` xs = f $ drop 19 xs f (x:xs) = x : f xs @@ -101,111 +102,121 @@ out = f . unwords . map (dropWhile isSpace) . lines . showSDocUnqual . ppr operator :: String -> String -operator (x:xs) | not (isAlphaNum x) && x `notElem` "_' ([{" = "(" ++ x:xs ++ ")" +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 subdocs _) = doc (fst dc) ++ f (unL decl) +ppExport :: DynFlags -> ExportItem Name -> [String] +ppExport dflags (ExportDecl decl dc subdocs _) = ppDocumentation dflags (fst dc) ++ f (unL decl) where - f (TyClD d@TyData{}) = ppData d subdocs - f (TyClD d@ClassDecl{}) = ppClass d - f (TyClD d@TySynonym{}) = ppSynonym d - f (ForD (ForeignImport name typ _ _)) = ppSig $ TypeSig [name] typ - f (ForD (ForeignExport name typ _ _)) = ppSig $ TypeSig [name] typ - f (SigD sig) = ppSig sig + f (TyClD d@TyDecl{}) + | isDataDecl d = ppData dflags d subdocs + | otherwise = ppSynonym dflags d + f (TyClD d@ClassDecl{}) = ppClass dflags d + f (ForD (ForeignImport name typ _ _)) = ppSig dflags $ TypeSig [name] typ + f (ForD (ForeignExport name typ _ _)) = ppSig dflags $ TypeSig [name] typ + f (SigD sig) = ppSig dflags sig f _ = [] -ppExport _ = [] +ppExport _ _ = [] -ppSig :: Sig Name -> [String] -ppSig (TypeSig names sig) = [operator prettyNames ++ " :: " ++ outHsType typ] +ppSig :: DynFlags -> Sig Name -> [String] +ppSig dflags (TypeSig names sig) + = [operator prettyNames ++ " :: " ++ outHsType dflags typ] where - prettyNames = concat . intersperse ", " $ map out names + prettyNames = intercalate ", " $ map (out dflags) names typ = case unL sig of HsForAllTy Explicit a b c -> HsForAllTy Implicit a b c x -> x -ppSig _ = [] - - -ppSynonym :: TyClDecl Name -> [String] -ppSynonym x = [out x] +ppSig _ _ = [] -- note: does not yet output documentation for class methods -ppClass :: TyClDecl Name -> [String] -ppClass x = out x{tcdSigs=[]} : - concatMap (ppSig . addContext . unL) (tcdSigs x) +ppClass :: DynFlags -> TyClDecl Name -> [String] +ppClass dflags x = out dflags x{tcdSigs=[]} : + concatMap (ppSig dflags . addContext . unL) (tcdSigs x) where addContext (TypeSig name (L l sig)) = TypeSig name (L l $ f sig) addContext _ = error "expected TypeSig" f (HsForAllTy a b con d) = HsForAllTy a b (reL (context : unLoc con)) d - f t = HsForAllTy Implicit [] (reL [context]) (reL t) + f t = HsForAllTy Implicit emptyHsQTvs (reL [context]) (reL t) context = nlHsTyConApp (unL $ tcdLName x) - (map (reL . HsTyVar . hsTyVarName . unL) (tcdTyVars x)) + (map (reL . HsTyVar . hsTyVarName . unL) (hsQTvBndrs (tcdTyVars x))) + +ppInstance :: DynFlags -> ClsInst -> [String] +ppInstance dflags x = [dropComment $ out dflags x] -ppInstance :: Instance -> [String] -ppInstance x = [dropComment $ out x] +ppSynonym :: DynFlags -> TyClDecl Name -> [String] +ppSynonym dflags x = [out dflags x] -ppData :: TyClDecl Name -> [(Name, DocForDecl Name)] -> [String] -ppData x subdocs = showData x{tcdCons=[],tcdDerivs=Nothing} : - concatMap (ppCtor x subdocs . unL) (tcdCons x) +ppData :: DynFlags -> TyClDecl Name -> [(Name, DocForDecl Name)] -> [String] +ppData dflags decl@(TyDecl { tcdTyDefn = defn }) subdocs + = showData decl{ tcdTyDefn = defn { td_cons=[],td_derivs=Nothing }} : + concatMap (ppCtor dflags decl subdocs . unL) (td_cons defn) where + -- GHC gives out "data Bar =", we want to delete the equals -- also writes data : a b, when we want data (:) a b showData d = unwords $ map f $ if last xs == "=" then init xs else xs where - xs = words $ out d - nam = out $ tcdLName d + xs = words $ out dflags d + nam = out dflags $ tcdLName d f w = if w == nam then operator nam else w +ppData _ _ _ = panic "ppData" -- | for constructors, and named-fields... -lookupCon :: [(Name, DocForDecl Name)] -> Located Name -> Maybe (Doc Name) -lookupCon subdocs (L _ name) = case lookup name subdocs of - Just (d, _) -> d - _ -> Nothing +lookupCon :: DynFlags -> [(Name, DocForDecl Name)] -> Located Name -> [String] +lookupCon dflags subdocs (L _ name) = case lookup name subdocs of + Just (d, _) -> ppDocumentation dflags d + _ -> [] -ppCtor :: TyClDecl Name -> [(Name, DocForDecl Name)] -> ConDecl Name -> [String] -ppCtor dat subdocs con = doc (lookupCon subdocs (con_name con)) +ppCtor :: DynFlags -> TyClDecl Name -> [(Name, DocForDecl Name)] -> ConDecl Name -> [String] +ppCtor dflags dat subdocs con = lookupCon dflags subdocs (con_name con) ++ f (con_details con) where f (PrefixCon args) = [typeSig name $ args ++ [resType]] f (InfixCon a1 a2) = f $ PrefixCon [a1,a2] f (RecCon recs) = f (PrefixCon $ map cd_fld_type recs) ++ concat - [doc (lookupCon subdocs (cd_fld_name r)) ++ - [out (unL $ cd_fld_name r) `typeSig` [resType, cd_fld_type r]] + [lookupCon dflags subdocs (cd_fld_name r) ++ + [out dflags (unL $ cd_fld_name r) `typeSig` [resType, cd_fld_type r]] | r <- recs] funs = foldr1 (\x y -> reL $ HsFunTy (makeExplicitL x) (makeExplicitL y)) apps = foldl1 (\x y -> reL $ HsAppTy x y) - typeSig nm flds = operator nm ++ " :: " ++ outHsType (makeExplicit $ unL $ funs flds) - name = out $ unL $ con_name con + typeSig nm flds = operator nm ++ " :: " ++ outHsType dflags (makeExplicit $ unL $ funs flds) + name = out dflags $ unL $ con_name con resType = case con_res con of - ResTyH98 -> apps $ map (reL . HsTyVar) $ unL (tcdLName dat) : [hsTyVarName v | v@UserTyVar {} <- map unL $ tcdTyVars dat] + ResTyH98 -> apps $ map (reL . HsTyVar) $ + unL (tcdLName dat) : [hsTyVarName v | L _ (v@UserTyVar {}) <- hsQTvBndrs $ tcdTyVars dat] ResTyGADT x -> x --------------------------------------------------------------------- -- DOCUMENTATION -doc :: Outputable o => Maybe (Doc o) -> [String] -doc = docWith "" +ppDocumentation :: Outputable o => DynFlags -> Documentation o -> [String] +ppDocumentation dflags (Documentation d w) = doc dflags d ++ doc dflags w + + +doc :: Outputable o => DynFlags -> Maybe (Doc o) -> [String] +doc dflags = docWith dflags "" -docWith :: Outputable o => String -> Maybe (Doc o) -> [String] -docWith [] Nothing = [] -docWith header d = ("":) $ zipWith (++) ("-- | " : repeat "-- ") $ +docWith :: Outputable o => DynFlags -> String -> Maybe (Doc o) -> [String] +docWith _ [] Nothing = [] +docWith dflags header d + = ("":) $ zipWith (++) ("-- | " : repeat "-- ") $ [header | header /= ""] ++ ["" | header /= "" && isJust d] ++ - maybe [] (showTags . markup markupTag) d + maybe [] (showTags . markup (markupTag dflags)) d data Tag = TagL Char [Tags] | TagP Tags | TagPre Tags | TagInline String Tags | Str String @@ -226,15 +237,16 @@ str a = [Str a] -- or inlne for others (a,i,tt) -- entities (&,>,<) should always be appropriately escaped -markupTag :: Outputable o => DocMarkup o [Tag] -markupTag = Markup { +markupTag :: Outputable o => DynFlags -> DocMarkup o [Tag] +markupTag dflags = Markup { markupParagraph = box TagP, markupEmpty = str "", markupString = str, markupAppend = (++), - markupIdentifier = box (TagInline "a") . str . out, - markupIdentifierUnchecked = box (TagInline "a") . str . out . snd, + markupIdentifier = box (TagInline "a") . str . out dflags, + markupIdentifierUnchecked = box (TagInline "a") . str . out dflags . snd, markupModule = box (TagInline "a") . str, + markupWarning = box (TagInline "i"), markupEmphasis = box (TagInline "i"), markupMonospaced = box (TagInline "tt"), markupPic = const $ str " ", @@ -242,7 +254,7 @@ markupTag = Markup { markupOrderedList = box (TagL 'o'), markupDefList = box (TagL 'u') . map (\(a,b) -> TagInline "i" a : Str " " : b), markupCodeBlock = box TagPre, - markupURL = box (TagInline "a") . str, + markupHyperlink = \(Hyperlink url mLabel) -> (box (TagInline "a") . str) (fromMaybe url mLabel), markupAName = const $ str "", markupExample = box TagPre . str . unlines . map exampleToString } diff --git a/src/Haddock/Backends/LaTeX.hs b/src/Haddock/Backends/LaTeX.hs index e0a530be..68cf715a 100644 --- a/src/Haddock/Backends/LaTeX.hs +++ b/src/Haddock/Backends/LaTeX.hs @@ -24,7 +24,6 @@ import GHC import OccName import Name ( nameOccName ) import RdrName ( rdrNameOcc ) -import BasicTypes ( ipNameName ) import FastString ( unpackFS, unpackLitString ) import qualified Data.Map as Map @@ -158,9 +157,7 @@ ppLaTeXModule _title odir iface = do ] description - = case ifaceRnDoc iface of - Nothing -> empty - Just doc -> docToLaTeX doc + = (fromMaybe empty . documentationToLaTeX . ifaceRnDoc) iface body = processExports exports -- @@ -210,7 +207,7 @@ processExports (e : es) = isSimpleSig :: ExportItem DocName -> Maybe ([DocName], HsType DocName) isSimpleSig (ExportDecl (L _ (SigD (TypeSig lnames (L _ t)))) - (Nothing, argDocs) _ _) + (Documentation Nothing Nothing, argDocs) _ _) | Map.null argDocs = Just (map unLoc lnames, t) isSimpleSig _ = Nothing @@ -276,40 +273,30 @@ ppDecl :: LHsDecl DocName -> [(DocName, DocForDecl DocName)] -> LaTeX -ppDecl (L loc decl) (mbDoc, fnArgsDoc) instances subdocs = case decl of - TyClD d@(TyFamily {}) -> ppTyFam False loc mbDoc d unicode - TyClD d@(TyData {}) - | Nothing <- tcdTyPats d -> ppDataDecl instances subdocs loc mbDoc d unicode - | Just _ <- tcdTyPats d -> ppDataInst loc mbDoc d - TyClD d@(TySynonym {}) - | 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 lnames (L _ t)) -> ppFunSig loc (mbDoc, fnArgsDoc) (map unLoc lnames) t unicode - ForD d -> ppFor loc (mbDoc, fnArgsDoc) d unicode +ppDecl (L loc decl) (doc, fnArgsDoc) instances subdocs = case decl of + TyClD d@(TyFamily {}) -> ppTyFam False loc doc d unicode + TyClD d@(TyDecl{ tcdTyDefn = defn }) + | isHsDataDefn defn -> ppDataDecl instances subdocs loc doc d unicode + | otherwise -> ppTySyn loc (doc, fnArgsDoc) d unicode +-- Family instances happen via FamInst now +-- TyClD d@(TySynonym {}) +-- | Just _ <- tcdTyPats d -> ppTyInst False loc doc d unicode +-- Family instances happen via FamInst now + TyClD d@(ClassDecl {}) -> ppClassDecl instances loc doc subdocs d unicode + SigD (TypeSig lnames (L _ t)) -> ppFunSig loc (doc, fnArgsDoc) (map unLoc lnames) t unicode + ForD d -> ppFor loc (doc, fnArgsDoc) d unicode InstD _ -> empty _ -> error "declaration not supported by ppDecl" where unicode = False -ppTyFam :: Bool -> SrcSpan -> Maybe (Doc DocName) -> +ppTyFam :: Bool -> SrcSpan -> Documentation DocName -> TyClDecl DocName -> Bool -> LaTeX ppTyFam _ _ _ _ _ = error "type family declarations are currently not supported by --latex" -ppDataInst :: a -ppDataInst = - error "data instance declarations are currently not supported by --latex" - - -ppTyInst :: Bool -> SrcSpan -> Maybe (Doc DocName) -> - TyClDecl DocName -> Bool -> LaTeX -ppTyInst _ _ _ _ _ = - error "type instance declarations are currently not supported by --latex" - - ppFor :: SrcSpan -> DocForDecl DocName -> ForeignDecl DocName -> Bool -> LaTeX ppFor _ _ _ _ = error "foreign declarations are currently not supported by --latex" @@ -323,7 +310,8 @@ ppFor _ _ _ _ = -- we skip type patterns for now ppTySyn :: SrcSpan -> DocForDecl DocName -> TyClDecl DocName -> Bool -> LaTeX -ppTySyn loc doc (TySynonym (L _ name) ltyvars _ ltype) unicode +ppTySyn loc doc (TyDecl { tcdLName = L _ name, tcdTyVars = ltyvars + , tcdTyDefn = TySynonym { td_synRhs = ltype } }) unicode = ppTypeOrFunSig loc [name] (unLoc ltype) doc (full, hdr, char '=') unicode where hdr = hsep (keyword "type" : ppDocBinder name : ppTyVars ltyvars) @@ -355,13 +343,13 @@ ppTypeOrFunSig :: SrcSpan -> [DocName] -> HsType DocName ppTypeOrFunSig _ _ typ (doc, argDocs) (pref1, pref2, sep0) unicode | Map.null argDocs = - declWithDoc pref1 (fmap docToLaTeX doc) + declWithDoc pref1 (documentationToLaTeX doc) | otherwise = declWithDoc pref2 $ Just $ text "\\haddockbeginargs" $$ do_args 0 sep0 typ $$ text "\\end{tabulary}\\par" $$ - maybe empty docToLaTeX doc + fromMaybe empty (documentationToLaTeX doc) where do_largs n leader (L _ t) = do_args n leader t @@ -396,12 +384,12 @@ ppTypeSig nms ty unicode = <+> ppType unicode ty -ppTyVars :: [LHsTyVarBndr DocName] -> [LaTeX] +ppTyVars :: LHsTyVarBndrs DocName -> [LaTeX] ppTyVars tvs = map ppSymName (tyvarNames tvs) -tyvarNames :: [LHsTyVarBndr DocName] -> [Name] -tyvarNames = map (getName . hsTyVarName . unLoc) +tyvarNames :: LHsTyVarBndrs DocName -> [Name] +tyvarNames = map getName . hsLTyVarNames declWithDoc :: LaTeX -> Maybe LaTeX -> LaTeX @@ -450,7 +438,7 @@ rDoc = maybeDoc . fmap latexStripTrailingWhitespace ppClassHdr :: Bool -> Located [LHsType DocName] -> DocName - -> [Located (HsTyVarBndr DocName)] -> [Located ([DocName], [DocName])] + -> LHsTyVarBndrs DocName -> [Located ([DocName], [DocName])] -> Bool -> LaTeX ppClassHdr summ lctxt n tvs fds unicode = keyword "class" @@ -469,10 +457,11 @@ ppFds fds unicode = ppClassDecl :: [DocInstance DocName] -> SrcSpan - -> Maybe (Doc DocName) -> [(DocName, DocForDecl DocName)] + -> Documentation DocName -> [(DocName, DocForDecl DocName)] -> TyClDecl DocName -> Bool -> LaTeX -ppClassDecl instances loc mbDoc subdocs - (ClassDecl lctxt lname ltyvars lfds lsigs _ ats at_defs _) unicode +ppClassDecl instances loc doc subdocs + (ClassDecl { tcdCtxt = lctxt, tcdLName = lname, tcdTyVars = ltyvars, tcdFDs = lfds + , tcdSigs = lsigs, tcdATs = ats, tcdATDefs = at_defs }) unicode = declWithDoc classheader (if null body then Nothing else Just (vcat body)) $$ instancesBit where @@ -482,7 +471,7 @@ ppClassDecl instances loc mbDoc subdocs hdr = ppClassHdr False lctxt (unLoc lname) ltyvars lfds - body = catMaybes [fmap docToLaTeX mbDoc, body_] + body = catMaybes [documentationToLaTeX doc, body_] body_ | null lsigs, null ats, null at_defs = Nothing @@ -523,8 +512,8 @@ isUndocdInstance _ = Nothing -- an 'argBox'. The comment is printed to the right of the box in normal comment -- style. ppDocInstance :: Bool -> DocInstance DocName -> LaTeX -ppDocInstance unicode (instHead, mbDoc) = - declWithDoc (ppInstDecl unicode instHead) (fmap docToLaTeX mbDoc) +ppDocInstance unicode (instHead, doc) = + declWithDoc (ppInstDecl unicode instHead) (fmap docToLaTeX doc) ppInstDecl :: Bool -> InstHead DocName -> LaTeX @@ -550,19 +539,19 @@ lookupAnySubdoc n subdocs = case lookup n subdocs of ppDataDecl :: [DocInstance DocName] -> [(DocName, DocForDecl DocName)] -> - SrcSpan -> Maybe (Doc DocName) -> TyClDecl DocName -> Bool -> + SrcSpan -> Documentation DocName -> TyClDecl DocName -> Bool -> LaTeX -ppDataDecl instances subdocs _loc mbDoc dataDecl unicode +ppDataDecl instances subdocs _loc doc dataDecl unicode = declWithDoc (ppDataHeader dataDecl unicode <+> whereBit) (if null body then Nothing else Just (vcat body)) $$ instancesBit where - cons = tcdCons dataDecl + cons = td_cons (tcdTyDefn dataDecl) resTy = (con_res . unLoc . head) cons - body = catMaybes [constrBit, fmap docToLaTeX mbDoc] + body = catMaybes [constrBit, documentationToLaTeX doc] (whereBit, leaders) | null cons = (empty,[]) @@ -642,8 +631,7 @@ ppSideBySideConstr subdocs unicode leader (L _ con) = forall = con_explicit con -- don't use "con_doc con", in case it's reconstructed from a .hi file, -- or also because we want Haddock to do the doc-parsing, not GHC. - -- 'join' is in Maybe. - mbDoc = join $ fmap fst $ lookup (unLoc $ con_name con) subdocs + mbDoc = lookup (unLoc $ con_name con) subdocs >>= combineDocumentation . fst mkFunTy a b = noLoc (HsFunTy a b) @@ -653,7 +641,7 @@ ppSideBySideField subdocs unicode (ConDeclField (L _ name) ltype _) = <+> dcolon unicode <+> ppLType unicode ltype) <-> rDoc mbDoc where -- don't use cd_fld_doc for same reason we don't use con_doc above - mbDoc = join $ fmap fst $ lookup name subdocs + mbDoc = lookup name subdocs >>= combineDocumentation . fst -- {- -- ppHsFullConstr :: HsConDecl -> LaTeX @@ -705,27 +693,15 @@ ppSideBySideField subdocs unicode (ConDeclField (L _ name) ltype _) = -- | Print the LHS of a data\/newtype declaration. -- Currently doesn't handle 'data instance' decls or kind signatures ppDataHeader :: TyClDecl DocName -> Bool -> LaTeX -ppDataHeader decl unicode - | not (isDataDecl decl) = error "ppDataHeader: illegal argument" - | otherwise = - -- newtype or data - (if tcdND decl == NewType then keyword "newtype" else keyword "data") <+> +ppDataHeader (TyDecl { tcdLName = L _ name, tcdTyVars = tyvars + , tcdTyDefn = TyData { td_ND = nd, td_ctxt = ctxt } }) unicode + = -- newtype or data + (case nd of { NewType -> keyword "newtype"; DataType -> keyword "data" }) <+> -- context - ppLContext (tcdCtxt decl) unicode <+> + ppLContext ctxt unicode <+> -- T a b c ..., or a :+: b - ppTyClBinderWithVars False decl - - --------------------------------------------------------------------------------- --- * TyClDecl helpers --------------------------------------------------------------------------------- - - --- | Print a type family / newtype / data / class binder and its variables -ppTyClBinderWithVars :: Bool -> TyClDecl DocName -> LaTeX -ppTyClBinderWithVars summ decl = - ppAppDocNameNames summ (unLoc $ tcdLName decl) (tyvarNames $ tcdTyVars decl) - + ppAppDocNameNames False name (tyvarNames tyvars) +ppDataHeader _ _ = error "ppDataHeader: illegal argument" -------------------------------------------------------------------------------- -- * Type applications @@ -845,13 +821,13 @@ ppKind unicode ki = ppr_mono_ty pREC_TOP ki unicode -- Drop top-level for-all type variables in user style -- since they are implicit in Haskell -ppForAll :: HsExplicitFlag -> [Located (HsTyVarBndr DocName)] +ppForAll :: HsExplicitFlag -> LHsTyVarBndrs DocName -> Located (HsContext DocName) -> Bool -> LaTeX ppForAll expl tvs cxt unicode | show_forall = forall_part <+> ppLContext cxt unicode | otherwise = ppLContext cxt unicode where - show_forall = not (null tvs) && is_explicit + show_forall = not (null (hsQTvBndrs tvs)) && is_explicit is_explicit = case expl of {Explicit -> True; Implicit -> False} forall_part = hsep (forallSymbol unicode : ppTyVars tvs) <> dot @@ -872,7 +848,7 @@ ppr_mono_ty _ (HsTupleTy con tys) u = tupleParens con (map (ppLType u) t ppr_mono_ty _ (HsKindSig ty kind) u = parens (ppr_mono_lty pREC_TOP ty u <+> dcolon u <+> ppLKind u kind) ppr_mono_ty _ (HsListTy ty) u = brackets (ppr_mono_lty pREC_TOP ty u) ppr_mono_ty _ (HsPArrTy ty) u = pabrackets (ppr_mono_lty pREC_TOP ty u) -ppr_mono_ty _ (HsIParamTy n ty) u = brackets (ppDocName (ipNameName n) <+> dcolon u <+> ppr_mono_lty pREC_TOP ty u) +ppr_mono_ty _ (HsIParamTy n ty) u = brackets (ppIPName n <+> dcolon u <+> ppr_mono_lty pREC_TOP ty u) ppr_mono_ty _ (HsSpliceTy {}) _ = error "ppr_mono_ty HsSpliceTy" ppr_mono_ty _ (HsQuasiQuoteTy {}) _ = error "ppr_mono_ty HsQuasiQuoteTy" ppr_mono_ty _ (HsRecTy {}) _ = error "ppr_mono_ty HsRecTy" @@ -903,6 +879,15 @@ ppr_mono_ty ctxt_prec (HsParTy ty) unicode ppr_mono_ty ctxt_prec (HsDocTy ty _) unicode = ppr_mono_lty ctxt_prec ty unicode +ppr_mono_ty _ (HsTyLit t) u = ppr_tylit t u + + +ppr_tylit :: HsTyLit -> Bool -> LaTeX +ppr_tylit (HsNumTy n) _ = integer n +ppr_tylit (HsStrTy s) _ = text (show s) + -- XXX: Ok in verbatim, but not otherwise + -- XXX: Do something with Unicode parameter? + ppr_fun_ty :: Int -> LHsType DocName -> LHsType DocName -> Bool -> LaTeX ppr_fun_ty ctxt_prec ty1 ty2 unicode @@ -933,6 +918,8 @@ ppSymName name ppVerbOccName :: OccName -> LaTeX ppVerbOccName = text . latexFilter . occNameString +ppIPName :: HsIPName -> LaTeX +ppIPName ip = text $ unpackFS $ hsIPNameFS ip ppOccName :: OccName -> LaTeX ppOccName = text . occNameString @@ -1006,6 +993,7 @@ parLatexMarkup ppId = Markup { markupIdentifier = markupId ppId, markupIdentifierUnchecked = markupId (ppVerbOccName . snd), markupModule = \m _ -> let (mdl,_ref) = break (=='#') m in tt (text mdl), + markupWarning = \p v -> emph (p v), markupEmphasis = \p v -> emph (p v), markupMonospaced = \p _ -> tt (p Mono), markupUnorderedList = \p v -> itemizedList (map ($v) p) $$ text "", @@ -1013,7 +1001,7 @@ parLatexMarkup ppId = Markup { markupOrderedList = \p v -> enumeratedList (map ($v) p) $$ text "", markupDefList = \l v -> descriptionList (map (\(a,b) -> (a v, b v)) l), markupCodeBlock = \p _ -> quote (verb (p Verb)) $$ text "", - markupURL = \u _ -> text "\\url" <> braces (text u), + markupHyperlink = \l _ -> markupLink l, markupAName = \_ _ -> empty, markupExample = \e _ -> quote $ verb $ text $ unlines $ map exampleToString e } @@ -1022,6 +1010,10 @@ parLatexMarkup ppId = Markup { fixString Verb s = s fixString Mono s = latexMonoFilter s + markupLink (Hyperlink url mLabel) = case mLabel of + Just label -> text "\\href" <> braces (text url) <> braces (text label) + Nothing -> text "\\url" <> braces (text url) + markupId ppId_ id v = case v of Verb -> theid @@ -1042,6 +1034,10 @@ docToLaTeX :: Doc DocName -> LaTeX docToLaTeX doc = markup latexMarkup doc Plain +documentationToLaTeX :: Documentation DocName -> Maybe LaTeX +documentationToLaTeX = fmap docToLaTeX . combineDocumentation + + rdrDocToLaTeX :: Doc RdrName -> LaTeX rdrDocToLaTeX doc = markup rdrLatexMarkup doc Plain diff --git a/src/Haddock/Backends/Xhtml.hs b/src/Haddock/Backends/Xhtml.hs index 52bde5b6..c68b7cbc 100644 --- a/src/Haddock/Backends/Xhtml.hs +++ b/src/Haddock/Backends/Xhtml.hs @@ -66,7 +66,7 @@ ppHtml :: String -> Maybe String -- ^ The contents URL (--use-contents) -> Maybe String -- ^ The index URL (--use-index) -> Bool -- ^ Whether to use unicode in output (--use-unicode) - -> Qualification -- ^ How to qualify names + -> QualOption -- ^ How to qualify names -> Bool -- ^ Output pretty html (newlines and indenting) -> IO () @@ -83,7 +83,7 @@ ppHtml doctitle maybe_package ifaces odir prologue themes maybe_index_url maybe_source_url maybe_wiki_url (map toInstalledIface visible_ifaces) False -- we don't want to display the packages in a single-package contents - prologue debug qual + prologue debug (makeContentsQual qual) when (isNothing maybe_index_url) $ ppHtmlIndex odir doctitle maybe_package @@ -175,7 +175,7 @@ bodyHtml doctitle iface contentsButton maybe_contents_url, indexButton maybe_index_url]) ! [theclass "links", identifier "page-menu"], - nonEmpty sectionName << doctitle + nonEmptySectionName << doctitle ], divContent << pageContent, divFooter << paragraph << ( @@ -431,7 +431,7 @@ ppHtmlIndex odir doctitle _maybe_package themes indexLinks nm entries many_entities -> td ! [ theclass "src" ] << toHtml str <-> td << spaceHtml </> - aboves (map doAnnotatedEntity (zip [1..] many_entities)) + aboves (zipWith (curry doAnnotatedEntity) [1..] many_entities) doAnnotatedEntity :: (Integer, (Name, [(Module, Bool)])) -> HtmlTable doAnnotatedEntity (j,(nm,entries)) @@ -461,18 +461,16 @@ ppHtmlIndex odir doctitle _maybe_package themes ppHtmlModule :: FilePath -> String -> Themes -> SourceURLs -> WikiURLs - -> Maybe String -> Maybe String -> Bool -> Qualification + -> Maybe String -> Maybe String -> Bool -> QualOption -> Bool -> Interface -> IO () ppHtmlModule odir doctitle themes maybe_source_url maybe_wiki_url maybe_contents_url maybe_index_url unicode qual debug iface = do let mdl = ifaceMod iface + aliases = ifaceModuleAliases iface mdl_str = moduleString mdl - real_qual = case qual of - LocalQual Nothing -> LocalQual (Just mdl) - RelativeQual Nothing -> RelativeQual (Just mdl) - _ -> qual + real_qual = makeModuleQual qual aliases mdl html = headHtml mdl_str (Just $ "mini_" ++ moduleHtmlFile mdl) themes +++ bodyHtml doctitle (Just iface) @@ -484,8 +482,7 @@ ppHtmlModule odir doctitle themes createDirectoryIfMissing True odir writeFile (joinPath [odir, moduleHtmlFile mdl]) (renderToString debug html) - ppHtmlModuleMiniSynopsis odir doctitle themes iface unicode qual debug - + ppHtmlModuleMiniSynopsis odir doctitle themes iface unicode real_qual debug ppHtmlModuleMiniSynopsis :: FilePath -> String -> Themes -> Interface -> Bool -> Qualification -> Bool -> IO () @@ -511,18 +508,16 @@ ifaceToHtml maybe_source_url maybe_wiki_url iface unicode qual -- todo: if something has only sub-docs, or fn-args-docs, should -- it be measured here and thus prevent omitting the synopsis? - has_doc (ExportDecl _ doc _ _) = isJust (fst doc) + has_doc (ExportDecl _ (Documentation mDoc mWarning, _) _ _) = isJust mDoc || isJust mWarning has_doc (ExportNoDecl _ _) = False has_doc (ExportModule _) = False has_doc _ = True no_doc_at_all = not (any has_doc exports) - description - = case ifaceRnDoc iface of - Nothing -> noHtml - Just doc -> divDescription $ - sectionName << "Description" +++ docSection qual doc + description | isNoHtml doc = doc + | otherwise = divDescription $ sectionName << "Description" +++ doc + where doc = docSection qual (ifaceRnDoc iface) -- omit the synopsis if there are no documentation annotations at all synopsis @@ -539,7 +534,7 @@ ifaceToHtml maybe_source_url maybe_wiki_url iface unicode qual maybe_doc_hdr = case exports of [] -> noHtml - ExportGroup _ _ _ : _ -> noHtml + ExportGroup {} : _ -> noHtml _ -> h1 << "Documentation" bdy = @@ -562,12 +557,8 @@ processForMiniSynopsis mdl unicode qual (ExportDecl (L _loc decl0) _doc _ _insts ((divTopDecl <<).(declElem <<)) `fmap` case decl0 of TyClD d -> let b = ppTyClBinderWithVarsMini mdl d in case d of (TyFamily{}) -> [ppTyFamHeader True False d unicode qual] - (TyData{tcdTyPats = ps}) - | Nothing <- ps -> [keyword "data" <+> b] - | Just _ <- ps -> [keyword "data" <+> keyword "instance" <+> b] - (TySynonym{tcdTyPats = ps}) - | Nothing <- ps -> [keyword "type" <+> b] - | Just _ <- ps -> [keyword "type" <+> keyword "instance" <+> b] + (TyDecl{ tcdTyDefn = TyData {} }) -> [keyword "data" <+> b] + (TyDecl{ tcdTyDefn = TySynonym {} }) -> [keyword "type" <+> b] (ClassDecl {}) -> [keyword "class" <+> b] _ -> [] SigD (TypeSig lnames (L _ _)) -> @@ -621,7 +612,7 @@ ppModuleContents qual exports -- we need to assign a unique id to each section heading so we can hyperlink -- them from the contents: numberSectionHeadings :: [ExportItem DocName] -> [ExportItem DocName] -numberSectionHeadings exports = go 1 exports +numberSectionHeadings = go 1 where go :: Int -> [ExportItem DocName] -> [ExportItem DocName] go _ [] = [] go n (ExportGroup lev _ doc : es) @@ -642,7 +633,7 @@ processExport summary _ _ qual (ExportNoDecl y subs) = processDeclOneLiner summary $ ppDocName qual y +++ parenList (map (ppDocName qual) subs) processExport summary _ _ qual (ExportDoc doc) - = nothingIf summary $ docSection qual doc + = nothingIf summary $ docSection_ qual doc processExport summary _ _ _ (ExportModule mdl) = processDeclOneLiner summary $ toHtml "module" <+> ppModule mdl diff --git a/src/Haddock/Backends/Xhtml/Decl.hs b/src/Haddock/Backends/Xhtml/Decl.hs index 686e9a3e..59be34f7 100644 --- a/src/Haddock/Backends/Xhtml/Decl.hs +++ b/src/Haddock/Backends/Xhtml/Decl.hs @@ -26,7 +26,6 @@ import Haddock.Backends.Xhtml.Utils import Haddock.GhcUtils import Haddock.Types -import Control.Monad ( join ) import Data.List ( intersperse ) import qualified Data.Map as Map import Data.Maybe @@ -34,21 +33,16 @@ import Text.XHtml hiding ( name, title, p, quote ) import GHC import Name -import BasicTypes ( ipNameName ) --- TODO: use DeclInfo DocName or something ppDecl :: Bool -> LinksInfo -> LHsDecl DocName -> DocForDecl DocName -> [DocInstance DocName] -> [(DocName, DocForDecl DocName)] -> Bool -> Qualification -> Html ppDecl summ links (L loc decl) (mbDoc, fnArgsDoc) instances subdocs unicode qual = case decl of TyClD d@(TyFamily {}) -> ppTyFam summ False links loc mbDoc d unicode qual - TyClD d@(TyData {}) - | Nothing <- tcdTyPats d -> ppDataDecl summ links instances subdocs loc mbDoc d unicode qual - | Just _ <- tcdTyPats d -> ppDataInst summ links loc mbDoc d - TyClD d@(TySynonym {}) - | Nothing <- tcdTyPats d -> ppTySyn summ links loc (mbDoc, fnArgsDoc) d unicode qual - | Just _ <- tcdTyPats d -> ppTyInst summ False links loc mbDoc d unicode qual + TyClD d@(TyDecl{ tcdTyDefn = defn }) + | isHsDataDefn defn -> ppDataDecl summ links instances subdocs loc mbDoc d unicode qual + | otherwise -> ppTySyn summ links loc (mbDoc, fnArgsDoc) d unicode qual TyClD d@(ClassDecl {}) -> ppClassDecl summ links instances loc mbDoc subdocs d unicode qual SigD (TypeSig lnames (L _ t)) -> ppFunSig summ links loc (mbDoc, fnArgsDoc) (map unLoc lnames) t unicode qual ForD d -> ppFor summ links loc (mbDoc, fnArgsDoc) d unicode qual @@ -73,14 +67,14 @@ 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 docnames pref1 +++ maybeDocSection qual doc + | Map.null argDocs = topDeclElem links loc docnames pref1 +++ docSection qual doc | otherwise = topDeclElem links loc docnames pref2 +++ - subArguments qual (do_args 0 sep typ) +++ maybeDocSection qual doc + subArguments qual (do_args 0 sep typ) +++ docSection qual doc where argDoc n = Map.lookup n argDocs do_largs n leader (L _ t) = do_args n leader t - do_args :: Int -> Html -> (HsType DocName) -> [SubDecl] + do_args :: Int -> Html -> HsType DocName -> [SubDecl] do_args n leader (HsForAllTy Explicit tvs lctxt ltype) = (leader <+> hsep (forallSymbol unicode : ppTyVars tvs ++ [dot]) <+> @@ -100,15 +94,15 @@ ppTypeOrFunSig summary links loc docnames typ (doc, argDocs) (pref1, pref2, sep) = (leader <+> ppLFunLhType unicode qual lt, argDoc n, []) : do_largs (n+1) (arrow unicode) r do_args n leader t - = (leader <+> ppType unicode qual t, argDoc n, []) : [] + = [(leader <+> ppType unicode qual t, argDoc n, [])] -ppTyVars :: [LHsTyVarBndr DocName] -> [Html] +ppTyVars :: LHsTyVarBndrs DocName -> [Html] ppTyVars tvs = map ppTyName (tyvarNames tvs) -tyvarNames :: [LHsTyVarBndr DocName] -> [Name] -tyvarNames = map (getName . hsTyVarName . unLoc) +tyvarNames :: LHsTyVarBndrs DocName -> [Name] +tyvarNames = map getName . hsLTyVarNames ppFor :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName @@ -121,7 +115,9 @@ ppFor _ _ _ _ _ _ _ = error "ppFor" -- we skip type patterns for now ppTySyn :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName -> TyClDecl DocName -> Bool -> Qualification -> Html -ppTySyn summary links loc doc (TySynonym (L _ name) ltyvars _ ltype) unicode qual +ppTySyn summary links loc doc (TyDecl { tcdLName = L _ name, tcdTyVars = ltyvars + , tcdTyDefn = TySynonym { td_synRhs = ltype } }) + unicode qual = ppTypeOrFunSig summary links loc [name] (unLoc ltype) doc (full, hdr, spaceHtml +++ equals) unicode qual where @@ -163,17 +159,17 @@ ppTyFamHeader summary associated decl unicode qual = ppTyClBinderWithVars summary decl <+> - case tcdKind decl of + case tcdKindSig decl of Just kind -> dcolon unicode <+> ppLKind unicode qual kind - Nothing -> noHtml + Nothing -> noHtml -ppTyFam :: Bool -> Bool -> LinksInfo -> SrcSpan -> Maybe (Doc DocName) -> +ppTyFam :: Bool -> Bool -> LinksInfo -> SrcSpan -> Documentation DocName -> TyClDecl DocName -> Bool -> Qualification -> Html -ppTyFam summary associated links loc mbDoc decl unicode qual +ppTyFam summary associated links loc doc decl unicode qual | summary = ppTyFamHeader True associated decl unicode qual - | otherwise = header_ +++ maybeDocSection qual mbDoc +++ instancesBit + | otherwise = header_ +++ docSection qual doc +++ instancesBit where docname = tcdName decl @@ -187,50 +183,6 @@ ppTyFam summary associated links loc mbDoc decl unicode qual -------------------------------------------------------------------------------- --- * Indexed data types --------------------------------------------------------------------------------- - - -ppDataInst :: a -ppDataInst = undefined - - --------------------------------------------------------------------------------- --- * Indexed newtypes --------------------------------------------------------------------------------- - --- TODO --- ppNewTyInst = undefined - - --------------------------------------------------------------------------------- --- * Indexed types --------------------------------------------------------------------------------- - - -ppTyInst :: Bool -> Bool -> LinksInfo -> SrcSpan -> Maybe (Doc DocName) -> - TyClDecl DocName -> Bool -> Qualification -> Html -ppTyInst summary associated links loc mbDoc decl unicode qual - - | summary = ppTyInstHeader True associated decl unicode qual - | otherwise = header_ +++ maybeDocSection qual mbDoc - - where - docname = tcdName decl - - header_ = topDeclElem links loc [docname] - (ppTyInstHeader summary associated decl unicode qual) - - -ppTyInstHeader :: Bool -> Bool -> TyClDecl DocName -> Bool -> Qualification -> Html -ppTyInstHeader _ _ decl unicode qual = - keyword "type instance" <+> - ppAppNameTypes (tcdName decl) typeArgs unicode qual - where - typeArgs = map unLoc . fromJust . tcdTyPats $ decl - - --------------------------------------------------------------------------------- -- * Associated Types -------------------------------------------------------------------------------- @@ -240,7 +192,6 @@ ppAssocType :: Bool -> LinksInfo -> DocForDecl DocName -> LTyClDecl DocName -> B ppAssocType summ links doc (L loc decl) unicode qual = case decl of TyFamily {} -> ppTyFam summ True links loc (fst doc) decl unicode qual - TySynonym {} -> ppTySyn summ links loc doc decl unicode qual _ -> error "declaration type not supported by ppAssocType" @@ -297,12 +248,12 @@ ppLContextNoArrow = ppContextNoArrow . unLoc ppContextNoArrow :: HsContext DocName -> Bool -> Qualification -> Html ppContextNoArrow [] _ _ = noHtml -ppContextNoArrow cxt unicode qual = pp_hs_context (map unLoc cxt) unicode qual +ppContextNoArrow cxt unicode qual = ppHsContext (map unLoc cxt) unicode qual ppContextNoLocs :: [HsType DocName] -> Bool -> Qualification -> Html ppContextNoLocs [] _ _ = noHtml -ppContextNoLocs cxt unicode qual = pp_hs_context cxt unicode qual +ppContextNoLocs cxt unicode qual = ppHsContext cxt unicode qual <+> darrow unicode @@ -310,10 +261,10 @@ ppContext :: HsContext DocName -> Bool -> Qualification -> Html ppContext cxt unicode qual = ppContextNoLocs (map unLoc cxt) unicode qual -pp_hs_context :: [HsType DocName] -> Bool -> Qualification-> Html -pp_hs_context [] _ _ = noHtml -pp_hs_context [p] unicode qual = ppType unicode qual p -pp_hs_context cxt unicode qual = parenList (map (ppType unicode qual) cxt) +ppHsContext :: [HsType DocName] -> Bool -> Qualification-> Html +ppHsContext [] _ _ = noHtml +ppHsContext [p] unicode qual = ppType unicode qual p +ppHsContext cxt unicode qual = parenList (map (ppType unicode qual) cxt) ------------------------------------------------------------------------------- @@ -322,13 +273,13 @@ pp_hs_context cxt unicode qual = parenList (map (ppType unicode qual) cxt) ppClassHdr :: Bool -> Located [LHsType DocName] -> DocName - -> [Located (HsTyVarBndr DocName)] -> [Located ([DocName], [DocName])] + -> LHsTyVarBndrs DocName -> [Located ([DocName], [DocName])] -> Bool -> Qualification -> Html ppClassHdr summ lctxt n tvs fds unicode qual = keyword "class" <+> (if not . null . unLoc $ lctxt then ppLContext lctxt unicode qual else noHtml) - <+> ppAppDocNameNames summ n (tyvarNames $ tvs) - <+> ppFds fds unicode qual + <+> ppAppDocNameNames summ n (tyvarNames tvs) + <+> ppFds fds unicode qual ppFds :: [Located ([DocName], [DocName])] -> Bool -> Qualification -> Html @@ -343,7 +294,8 @@ ppFds fds unicode qual = ppShortClassDecl :: Bool -> LinksInfo -> TyClDecl DocName -> SrcSpan -> [(DocName, DocForDecl DocName)] -> Bool -> Qualification -> Html -ppShortClassDecl summary links (ClassDecl lctxt lname tvs fds sigs _ ats _ _) loc +ppShortClassDecl summary links (ClassDecl { tcdCtxt = lctxt, tcdLName = lname, tcdTyVars = tvs + , tcdFDs = fds, tcdSigs = sigs, tcdATs = ats }) loc subdocs unicode qual = if null sigs && null ats then (if summary then id else topDeclElem links loc [nm]) hdr @@ -353,6 +305,8 @@ ppShortClassDecl summary links (ClassDecl lctxt lname tvs fds sigs _ ats _ _) lo [ ppAssocType summary links doc at unicode qual | at <- ats , let doc = lookupAnySubdoc (tcdName $ unL at) subdocs ] ++ + -- ToDo: add associated type defaults + [ ppFunSig summary links loc doc names typ unicode qual | L _ (TypeSig lnames (L _ typ)) <- sigs , let doc = lookupAnySubdoc (head names) subdocs @@ -369,12 +323,13 @@ ppShortClassDecl _ _ _ _ _ _ _ = error "declaration type not supported by ppShor ppClassDecl :: Bool -> LinksInfo -> [DocInstance DocName] -> SrcSpan - -> Maybe (Doc DocName) -> [(DocName, DocForDecl DocName)] + -> Documentation DocName -> [(DocName, DocForDecl DocName)] -> TyClDecl DocName -> Bool -> Qualification -> Html -ppClassDecl summary links instances loc mbDoc subdocs - decl@(ClassDecl lctxt lname ltyvars lfds lsigs _ ats _ _) unicode qual +ppClassDecl summary links instances loc d subdocs + decl@(ClassDecl { tcdCtxt = lctxt, tcdLName = lname, tcdTyVars = ltyvars + , tcdFDs = lfds, tcdSigs = lsigs, tcdATs = ats }) unicode qual | summary = ppShortClassDecl summary links decl loc subdocs unicode qual - | otherwise = classheader +++ maybeDocSection qual mbDoc + | otherwise = classheader +++ docSection qual d +++ atBit +++ methodBit +++ instancesBit where classheader @@ -385,6 +340,7 @@ ppClassDecl summary links instances loc mbDoc subdocs hdr = ppClassHdr summary lctxt (unLoc lname) ltyvars lfds + -- ToDo: add assocatied typ defaults atBit = subAssociatedTypes [ ppAssocType summary links doc at unicode qual | at <- ats , let doc = lookupAnySubdoc (tcdName $ unL at) subdocs ] @@ -397,7 +353,7 @@ ppClassDecl summary links instances loc mbDoc subdocs -- there are different subdocs for different names in a single -- type signature? - instancesBit = ppInstances instances nm unicode qual + instancesBit = ppInstances instances nm unicode qual ppClassDecl _ _ _ _ _ _ _ _ _ = error "declaration type not supported by ppShortClassDecl" @@ -414,11 +370,8 @@ ppInstances instances baseName unicode qual <+> ppAppNameTypes n ts unicode qual -lookupAnySubdoc :: (Eq name1) => - name1 -> [(name1, DocForDecl name2)] -> DocForDecl name2 -lookupAnySubdoc n subdocs = case lookup n subdocs of - Nothing -> noDocForDecl - Just docs -> docs +lookupAnySubdoc :: Eq id1 => id1 -> [(id1, DocForDecl id2)] -> DocForDecl id2 +lookupAnySubdoc n = fromMaybe noDocForDecl . lookup n ------------------------------------------------------------------------------- @@ -431,7 +384,7 @@ ppShortDataDecl :: Bool -> LinksInfo -> SrcSpan -> TyClDecl DocName -> Bool -> Qualification -> Html ppShortDataDecl summary _links _loc dataDecl unicode qual - | [] <- cons = dataHeader + | [] <- cons = dataHeader | [lcon] <- cons, ResTyH98 <- resTy, (cHead,cBody,cFoot) <- ppShortConstrParts summary (unLoc lcon) unicode qual @@ -448,22 +401,22 @@ ppShortDataDecl summary _links _loc dataDecl unicode qual doConstr c con = toHtml [c] <+> ppShortConstr summary (unLoc con) unicode qual doGADTConstr con = ppShortConstr summary (unLoc con) unicode qual - cons = tcdCons dataDecl + cons = td_cons (tcdTyDefn dataDecl) resTy = (con_res . unLoc . head) cons ppDataDecl :: Bool -> LinksInfo -> [DocInstance DocName] -> [(DocName, DocForDecl DocName)] -> - SrcSpan -> Maybe (Doc DocName) -> TyClDecl DocName -> Bool -> + SrcSpan -> Documentation DocName -> TyClDecl DocName -> Bool -> Qualification -> Html -ppDataDecl summary links instances subdocs loc mbDoc dataDecl unicode qual +ppDataDecl summary links instances subdocs loc doc dataDecl unicode qual | summary = ppShortDataDecl summary links loc dataDecl unicode qual - | otherwise = header_ +++ maybeDocSection qual mbDoc +++ constrBit +++ instancesBit + | otherwise = header_ +++ docSection qual doc +++ constrBit +++ instancesBit where docname = unLoc . tcdLName $ dataDecl - cons = tcdCons dataDecl + cons = td_cons (tcdTyDefn dataDecl) resTy = (con_res . unLoc . head) cons header_ = topDeclElem links loc [docname] (ppDataHeader summary dataDecl unicode qual @@ -514,7 +467,7 @@ ppShortConstrParts summary con unicode qual = case con_res con of -- (except each field gets its own line in docs, to match -- non-GADT records) RecCon fields -> (ppBinder summary occ <+> dcolon unicode <+> - ppForAll forall ltvs lcontext unicode qual <+> char '{', + ppForAll forall_ ltvs lcontext unicode qual <+> char '{', doRecordFields fields, char '}' <+> arrow unicode <+> ppLType unicode qual resTy) InfixCon arg1 arg2 -> (doGADTCon [arg1, arg2] resTy, noHtml, noHtml) @@ -522,29 +475,29 @@ ppShortConstrParts summary con unicode qual = case con_res con of where doRecordFields fields = shortSubDecls (map (ppShortField summary unicode qual) fields) doGADTCon args resTy = ppBinder summary occ <+> dcolon unicode <+> hsep [ - ppForAll forall ltvs lcontext unicode qual, + ppForAll forall_ ltvs lcontext unicode qual, ppLType unicode qual (foldr mkFunTy resTy args) ] - header_ = ppConstrHdr forall tyVars context + header_ = ppConstrHdr forall_ tyVars context occ = nameOccName . getName . unLoc . con_name $ con ltvs = con_qvars con tyVars = tyvarNames ltvs lcontext = con_cxt con context = unLoc (con_cxt con) - forall = con_explicit con + forall_ = con_explicit con mkFunTy a b = noLoc (HsFunTy a b) -- ppConstrHdr is for (non-GADT) existentials constructors' syntax ppConstrHdr :: HsExplicitFlag -> [Name] -> HsContext DocName -> Bool -> Qualification -> Html -ppConstrHdr forall tvs ctxt unicode qual +ppConstrHdr forall_ tvs ctxt unicode qual = (if null tvs then noHtml else ppForall) +++ (if null ctxt then noHtml else ppContextNoArrow ctxt unicode qual <+> darrow unicode +++ toHtml " ") where - ppForall = case forall of + ppForall = case forall_ of Explicit -> forallSymbol unicode <+> hsep (map ppName tvs) <+> toHtml ". " Implicit -> noHtml @@ -582,19 +535,18 @@ ppSideBySideConstr subdocs unicode qual (L _ con) = (decl, mbDoc, fieldPart) doGADTCon :: [LHsType DocName] -> Located (HsType DocName) -> Html doGADTCon args resTy = ppBinder False occ <+> dcolon unicode - <+> hsep [ppForAll forall ltvs (con_cxt con) unicode qual, + <+> hsep [ppForAll forall_ ltvs (con_cxt con) unicode qual, ppLType unicode qual (foldr mkFunTy resTy args) ] - header_ = ppConstrHdr forall tyVars context + header_ = ppConstrHdr forall_ tyVars context occ = nameOccName . getName . unLoc . con_name $ con ltvs = con_qvars con tyVars = tyvarNames (con_qvars con) context = unLoc (con_cxt con) - forall = con_explicit con + forall_ = con_explicit con -- don't use "con_doc con", in case it's reconstructed from a .hi file, -- or also because we want Haddock to do the doc-parsing, not GHC. - -- 'join' is in Maybe. - mbDoc = join $ fmap fst $ lookup (unLoc $ con_name con) subdocs + mbDoc = lookup (unLoc $ con_name con) subdocs >>= combineDocumentation . fst mkFunTy a b = noLoc (HsFunTy a b) @@ -606,7 +558,7 @@ ppSideBySideField subdocs unicode qual (ConDeclField (L _ name) ltype _) = []) where -- don't use cd_fld_doc for same reason we don't use con_doc above - mbDoc = join $ fmap fst $ lookup name subdocs + mbDoc = lookup name subdocs >>= combineDocumentation . fst ppShortField :: Bool -> Bool -> Qualification -> ConDeclField DocName -> Html @@ -618,15 +570,15 @@ ppShortField summary unicode qual (ConDeclField (L _ name) ltype _) -- | Print the LHS of a data\/newtype declaration. -- Currently doesn't handle 'data instance' decls or kind signatures ppDataHeader :: Bool -> TyClDecl DocName -> Bool -> Qualification -> Html -ppDataHeader summary decl unicode qual - | not (isDataDecl decl) = error "ppDataHeader: illegal argument" - | otherwise = - -- newtype or data - (if tcdND decl == NewType then keyword "newtype" else keyword "data") <+> +ppDataHeader summary decl@(TyDecl { tcdTyDefn = TyData { td_ND = nd, td_ctxt = ctxt } }) + unicode qual + = -- newtype or data + (case nd of { NewType -> keyword "newtype"; DataType -> keyword "data" }) <+> -- context - ppLContext (tcdCtxt decl) unicode qual <+> + ppLContext ctxt unicode qual <+> -- T a b c ..., or a :+: b ppTyClBinderWithVars summary decl +ppDataHeader _ _ _ _ = error "ppDataHeader: illegal argument" -------------------------------------------------------------------------------- @@ -652,13 +604,13 @@ tupleParens _ = parenList pREC_TOP, pREC_FUN, pREC_OP, pREC_CON :: Int -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 (->) -pREC_OP = (2 :: Int) -- Used for arg of any infix operator - -- (we don't keep their fixities around) -pREC_CON = (3 :: Int) -- Used for arg of type applicn: - -- always parenthesise unless atomic +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 (->) +pREC_OP = 2 :: Int -- Used for arg of any infix operator + -- (we don't keep their fixities around) +pREC_CON = 3 :: Int -- Used for arg of type applicn: + -- always parenthesise unless atomic maybeParen :: Int -- Precedence of context -> Int -- Precedence of top-level operator @@ -688,19 +640,19 @@ ppKind unicode qual ki = ppr_mono_ty pREC_TOP ki unicode qual -- Drop top-level for-all type variables in user style -- since they are implicit in Haskell -ppForAll :: HsExplicitFlag -> [Located (HsTyVarBndr DocName)] +ppForAll :: HsExplicitFlag -> LHsTyVarBndrs DocName -> Located (HsContext DocName) -> Bool -> Qualification -> Html ppForAll expl tvs cxt unicode qual | show_forall = forall_part <+> ppLContext cxt unicode qual | otherwise = ppLContext cxt unicode qual where - show_forall = not (null tvs) && is_explicit + show_forall = not (null (hsQTvBndrs tvs)) && is_explicit is_explicit = case expl of {Explicit -> True; Implicit -> False} forall_part = hsep (forallSymbol unicode : ppTyVars tvs) +++ dot ppr_mono_lty :: Int -> LHsType DocName -> Bool -> Qualification -> Html -ppr_mono_lty ctxt_prec ty unicode qual = ppr_mono_ty ctxt_prec (unLoc ty) unicode qual +ppr_mono_lty ctxt_prec ty = ppr_mono_ty ctxt_prec (unLoc ty) ppr_mono_ty :: Int -> HsType DocName -> Bool -> Qualification -> Html @@ -716,13 +668,9 @@ ppr_mono_ty _ (HsKindSig ty kind) u q = parens (ppr_mono_lty pREC_TOP ty u q <+> dcolon u <+> ppLKind u q kind) ppr_mono_ty _ (HsListTy ty) u q = brackets (ppr_mono_lty pREC_TOP ty u q) ppr_mono_ty _ (HsPArrTy ty) u q = pabrackets (ppr_mono_lty pREC_TOP ty u q) -ppr_mono_ty _ (HsIParamTy n ty) u q = brackets (ppDocName q (ipNameName n) <+> dcolon u <+> ppr_mono_lty pREC_TOP ty u q) +ppr_mono_ty _ (HsIParamTy n ty) u q = brackets (ppIPName n <+> dcolon u <+> ppr_mono_lty pREC_TOP ty u q) ppr_mono_ty _ (HsSpliceTy {}) _ _ = error "ppr_mono_ty HsSpliceTy" -#if __GLASGOW_HASKELL__ == 612 -ppr_mono_ty _ (HsSpliceTyOut {}) _ _ = error "ppr_mono_ty HsQuasiQuoteTy" -#else ppr_mono_ty _ (HsQuasiQuoteTy {}) _ _ = error "ppr_mono_ty HsQuasiQuoteTy" -#endif ppr_mono_ty _ (HsRecTy {}) _ _ = error "ppr_mono_ty HsRecTy" ppr_mono_ty _ (HsCoreTy {}) _ _ = error "ppr_mono_ty HsCoreTy" ppr_mono_ty _ (HsExplicitListTy _ tys) u q = quote $ brackets $ hsep $ punctuate comma $ map (ppLType u q) tys @@ -741,8 +689,8 @@ ppr_mono_ty ctxt_prec (HsOpTy ty1 (_, op) ty2) unicode qual = maybeParen ctxt_prec pREC_FUN $ ppr_mono_lty pREC_OP ty1 unicode qual <+> ppr_op <+> ppr_mono_lty pREC_OP ty2 unicode qual where - ppr_op = if not (isSymOcc occName) then quote (ppLDocName qual op) else ppLDocName qual op - occName = nameOccName . getName . unLoc $ op + ppr_op = if not (isSymOcc occ) then quote (ppLDocName qual op) else ppLDocName qual op + occ = nameOccName . getName . unLoc $ op ppr_mono_ty ctxt_prec (HsParTy ty) unicode qual -- = parens (ppr_mono_lty pREC_TOP ty) @@ -751,6 +699,12 @@ ppr_mono_ty ctxt_prec (HsParTy ty) unicode qual ppr_mono_ty ctxt_prec (HsDocTy ty _) unicode qual = ppr_mono_lty ctxt_prec ty unicode qual +ppr_mono_ty _ (HsTyLit n) _ _ = ppr_tylit n + +ppr_tylit :: HsTyLit -> Html +ppr_tylit (HsNumTy n) = toHtml (show n) +ppr_tylit (HsStrTy s) = toHtml (show s) + ppr_fun_ty :: Int -> LHsType DocName -> LHsType DocName -> Bool -> Qualification -> Html ppr_fun_ty ctxt_prec ty1 ty2 unicode qual diff --git a/src/Haddock/Backends/Xhtml/DocMarkup.hs b/src/Haddock/Backends/Xhtml/DocMarkup.hs index f506d2b8..e75cfaba 100644 --- a/src/Haddock/Backends/Xhtml/DocMarkup.hs +++ b/src/Haddock/Backends/Xhtml/DocMarkup.hs @@ -15,7 +15,7 @@ module Haddock.Backends.Xhtml.DocMarkup ( rdrDocToHtml, origDocToHtml, - docElement, docSection, maybeDocSection, + docElement, docSection, docSection_, ) where @@ -25,6 +25,7 @@ import Haddock.Types import Haddock.Utils import Text.XHtml hiding ( name, title, p, quote ) +import Data.Maybe (fromMaybe) import GHC @@ -39,13 +40,14 @@ parHtmlMarkup qual ppId = Markup { markupIdentifierUnchecked = thecode . ppUncheckedLink qual, markupModule = \m -> let (mdl,ref) = break (=='#') m in ppModuleRef (mkModuleName mdl) ref, + markupWarning = thediv ! [theclass "warning"], markupEmphasis = emphasize, markupMonospaced = thecode, markupUnorderedList = unordList, markupOrderedList = ordList, markupDefList = defList, markupCodeBlock = pre, - markupURL = \url -> anchor ! [href url] << url, + markupHyperlink = \(Hyperlink url mLabel) -> anchor ! [href url] << fromMaybe url mLabel, markupAName = \aname -> namedAnchor aname << "", markupPic = \path -> image ! [src path], markupExample = examplesToHtml @@ -84,12 +86,12 @@ docElement el content_ = else el ! [theclass "doc"] << content_ -docSection :: Qualification -> Doc DocName -> Html -docSection qual = (docElement thediv <<) . docToHtml qual +docSection :: Qualification -> Documentation DocName -> Html +docSection qual = maybe noHtml (docSection_ qual) . combineDocumentation -maybeDocSection :: Qualification -> Maybe (Doc DocName) -> Html -maybeDocSection qual = maybe noHtml (docSection qual) +docSection_ :: Qualification -> Doc DocName -> Html +docSection_ qual = (docElement thediv <<) . docToHtml qual cleanup :: Doc a -> Doc a diff --git a/src/Haddock/Backends/Xhtml/Layout.hs b/src/Haddock/Backends/Xhtml/Layout.hs index bdd5ac78..3ddbd28b 100644 --- a/src/Haddock/Backends/Xhtml/Layout.hs +++ b/src/Haddock/Backends/Xhtml/Layout.hs @@ -18,6 +18,7 @@ module Haddock.Backends.Xhtml.Layout ( divIndex, divAlphabet, divModuleList, sectionName, + nonEmptySectionName, shortDeclList, shortSubDecls, @@ -66,6 +67,14 @@ sectionName :: Html -> Html sectionName = paragraph ! [theclass "caption"] +-- | Make an element that always has at least something (a non-breaking space). +-- If it would have otherwise been empty, then give it the class ".empty". +nonEmptySectionName :: Html -> Html +nonEmptySectionName c + | isNoHtml c = paragraph ! [theclass "caption empty"] $ spaceHtml + | otherwise = paragraph ! [theclass "caption"] $ c + + divPackageHeader, divContent, divModuleHeader, divFooter, divTableOfContents, divDescription, divSynposis, divInterface, divIndex, divAlphabet, divModuleList diff --git a/src/Haddock/Backends/Xhtml/Names.hs b/src/Haddock/Backends/Xhtml/Names.hs index 7c2375cf..2f2b82ed 100644 --- a/src/Haddock/Backends/Xhtml/Names.hs +++ b/src/Haddock/Backends/Xhtml/Names.hs @@ -14,6 +14,7 @@ module Haddock.Backends.Xhtml.Names ( ppName, ppDocName, ppLDocName, ppRdrName, ppUncheckedLink, ppBinder, ppBinder', ppModule, ppModuleRef, + ppIPName, linkId ) where @@ -24,11 +25,13 @@ import Haddock.Types import Haddock.Utils import Text.XHtml hiding ( name, title, p, quote ) +import qualified Data.Map as M import qualified Data.List as List import GHC import Name import RdrName +import FastString (unpackFS) ppOccName :: OccName -> Html @@ -38,6 +41,9 @@ ppOccName = toHtml . occNameString ppRdrName :: RdrName -> Html ppRdrName = ppOccName . rdrNameOcc +ppIPName :: HsIPName -> Html +ppIPName = toHtml . unpackFS . hsIPNameFS + ppUncheckedLink :: Qualification -> (ModuleName, OccName) -> Html ppUncheckedLink _ (mdl, occ) = linkIdOcc' mdl (Just occ) << ppOccName occ -- TODO: apply ppQualifyName @@ -52,7 +58,10 @@ ppDocName qual docName = case docName of Documented name mdl -> linkIdOcc mdl (Just (nameOccName name)) << ppQualifyName qual name mdl - Undocumented name -> ppQualifyName qual name (nameModule name) + Undocumented name + | isExternalName name || isWiredInName name -> + ppQualifyName qual name (nameModule name) + | otherwise -> ppName name -- | Render a name depending on the selected qualification mode @@ -61,28 +70,33 @@ ppQualifyName qual name mdl = case qual of NoQual -> ppName name FullQual -> ppFullQualName mdl name - -- this is just in case, it should never happen - LocalQual Nothing -> ppQualifyName FullQual name mdl - LocalQual (Just localmdl) - | moduleString mdl == moduleString localmdl -> ppName name - | otherwise -> ppFullQualName mdl name - -- again, this never happens - RelativeQual Nothing -> ppQualifyName FullQual name mdl - RelativeQual (Just localmdl) -> + LocalQual localmdl -> + if moduleString mdl == moduleString localmdl + then ppName name + else ppFullQualName mdl name + RelativeQual localmdl -> case List.stripPrefix (moduleString localmdl) (moduleString mdl) of -- local, A.x -> x - Just [] -> ppQualifyName NoQual name mdl + Just [] -> ppName name -- sub-module, A.B.x -> B.x Just ('.':m) -> toHtml $ m ++ '.' : getOccString name -- some module with same prefix, ABC.x -> ABC.x - Just _ -> ppQualifyName FullQual name mdl + Just _ -> ppFullQualName mdl name -- some other module, D.x -> D.x - Nothing -> ppQualifyName FullQual name mdl + Nothing -> ppFullQualName mdl name + AliasedQual aliases localmdl -> + case (moduleString mdl == moduleString localmdl, + M.lookup mdl aliases) of + (False, Just alias) -> ppQualName alias name + _ -> ppName name ppFullQualName :: Module -> Name -> Html ppFullQualName mdl name = toHtml $ moduleString mdl ++ '.' : getOccString name +ppQualName :: ModuleName -> Name -> Html +ppQualName mdlName name = + toHtml $ moduleNameString mdlName ++ '.' : getOccString name ppName :: Name -> Html ppName name = toHtml (getOccString name) diff --git a/src/Haddock/Backends/Xhtml/Utils.hs b/src/Haddock/Backends/Xhtml/Utils.hs index 7ba6d5f4..be1fcb9b 100644 --- a/src/Haddock/Backends/Xhtml/Utils.hs +++ b/src/Haddock/Backends/Xhtml/Utils.hs @@ -17,7 +17,7 @@ module Haddock.Backends.Xhtml.Utils ( spliceURL, groupId, - (<+>), char, nonEmpty, + (<+>), char, keyword, punctuate, braces, brackets, pabrackets, parens, parenList, ubxParenList, @@ -44,7 +44,7 @@ import Name ( getOccString, nameOccName, isValOcc ) spliceURL :: Maybe FilePath -> Maybe Module -> Maybe GHC.Name -> Maybe SrcSpan -> String -> String -spliceURL maybe_file maybe_mod maybe_name maybe_loc url = run url +spliceURL maybe_file maybe_mod maybe_name maybe_loc = run where file = fromMaybe "" maybe_file mdl = case maybe_mod of @@ -72,7 +72,7 @@ spliceURL maybe_file maybe_mod maybe_name maybe_loc url = run url run ('%':'N':rest) = name ++ run rest run ('%':'K':rest) = kind ++ run rest run ('%':'L':rest) = line ++ run rest - run ('%':'%':rest) = "%" ++ run rest + run ('%':'%':rest) = '%' : run rest run ('%':'{':'M':'O':'D':'U':'L':'E':'}':rest) = mdl ++ run rest run ('%':'{':'F':'I':'L':'E':'}':rest) = file ++ run rest @@ -119,15 +119,6 @@ char :: Char -> Html char c = toHtml [c] --- | Make an element that always has at least something (a non-breaking space) --- If it would have otherwise been empty, then give it the class ".empty" -nonEmpty :: (Html -> Html) -> Html -> Html -nonEmpty el content_ = - if isNoHtml content_ - then el ! [theclass "empty"] << spaceHtml - else el << content_ - - quote :: Html -> Html quote h = char '`' +++ h +++ '`' diff --git a/src/Haddock/Convert.hs b/src/Haddock/Convert.hs index 82b57f0c..7c9a2ee5 100644 --- a/src/Haddock/Convert.hs +++ b/src/Haddock/Convert.hs @@ -20,6 +20,7 @@ module Haddock.Convert where import HsSyn import TcType ( tcSplitTyConApp_maybe, tcSplitSigmaTy ) import TypeRep +import Type(isStrLitTy) import Kind ( splitKindFunTys, synTyConResKind ) import Name import Var @@ -29,8 +30,10 @@ import DataCon import BasicTypes ( TupleSort(..) ) import TysPrim ( alphaTyVars ) import TysWiredIn ( listTyConName, eqTyCon ) +import PrelNames (ipClassName) import Bag ( emptyBag ) import SrcLoc ( Located, noLoc, unLoc ) +import Data.List( partition ) -- the main function here! yay! @@ -51,77 +54,78 @@ tyThingToLHsDecl t = noLoc $ case t of ATyCon tc | Just cl <- tyConClass_maybe tc -- classes are just a little tedious -> TyClD $ ClassDecl - (synifyCtx (classSCTheta cl)) - (synifyName cl) - (synifyTyVars (classTyVars cl)) - (map (\ (l,r) -> noLoc - (map getName l, map getName r) ) $ - snd $ classTvsFds cl) - (map (noLoc . synifyIdSig DeleteTopLevelQuantification) - (classMethods cl)) - emptyBag --ignore default method definitions, they don't affect signature + { tcdCtxt = synifyCtx (classSCTheta cl) + , tcdLName = synifyName cl + , tcdTyVars = synifyTyVars (classTyVars cl) + , tcdFDs = map (\ (l,r) -> noLoc + (map getName l, map getName r) ) $ + snd $ classTvsFds cl + , tcdSigs = map (noLoc . synifyIdSig DeleteTopLevelQuantification) + (classMethods cl) + , tcdMeths = emptyBag --ignore default method definitions, they don't affect signature -- class associated-types are a subset of TyCon: - [noLoc (synifyTyCon at_tc) | (at_tc, _) <- classATItems cl] - [] --ignore associated type defaults - [] --we don't have any docs at this point + , tcdATs = [noLoc (synifyTyCon at_tc) | (at_tc, _) <- classATItems cl] + , tcdATDefs = [] --ignore associated type defaults + , tcdDocs = [] --we don't have any docs at this point + , tcdFVs = placeHolderNames } | otherwise -> TyClD (synifyTyCon tc) -- type-constructors (e.g. Maybe) are complicated, put the definition -- later in the file (also it's used for class associated-types too.) - ACoAxiom ax -> TyClD (synifyAxiom ax) + ACoAxiom ax -> InstD (FamInstD { lid_inst = synifyAxiom ax }) -- a data-constructor alone just gets rendered as a function: ADataCon dc -> SigD (TypeSig [synifyName dc] (synifyType ImplicitizeForAll (dataConUserType dc))) -synifyATDefault :: TyCon -> LTyClDecl Name +synifyATDefault :: TyCon -> LFamInstDecl Name synifyATDefault tc = noLoc (synifyAxiom ax) where Just ax = tyConFamilyCoercion_maybe tc -synifyAxiom :: CoAxiom -> TyClDecl Name +synifyAxiom :: CoAxiom -> FamInstDecl Name synifyAxiom (CoAxiom { co_ax_tvs = tvs, co_ax_lhs = lhs, co_ax_rhs = rhs }) | Just (tc, args) <- tcSplitTyConApp_maybe lhs = let name = synifyName tc - tyvars = synifyTyVars tvs typats = map (synifyType WithinType) args hs_rhs_ty = synifyType WithinType rhs - in TySynonym name tyvars (Just typats) hs_rhs_ty + in FamInstDecl { fid_tycon = name + , fid_pats = HsWB { hswb_cts = typats, hswb_kvs = [], hswb_tvs = map tyVarName tvs } + , fid_defn = TySynonym hs_rhs_ty, fid_fvs = placeHolderNames } | otherwise = error "synifyAxiom" synifyTyCon :: TyCon -> TyClDecl Name synifyTyCon tc - | isFunTyCon tc || isPrimTyCon tc = - TyData - -- arbitrary lie, they are neither algebraic data nor newtype: - DataType - -- no built-in type has any stupidTheta: - (noLoc []) - (synifyName tc) - -- tyConTyVars doesn't work on fun/prim, but we can make them up: - (zipWith - (\fakeTyVar realKind -> noLoc $ - KindedTyVar (getName fakeTyVar) (synifyKind realKind) placeHolderKind) - alphaTyVars --a, b, c... which are unfortunately all kind * - (fst . splitKindFunTys $ tyConKind tc) - ) - -- assume primitive types aren't members of data/newtype families: - Nothing - -- we have their kind accurately: - (Just (synifyKind (tyConKind tc))) - -- no algebraic constructors: - [] - -- "deriving" needn't be specified: - Nothing - | isSynFamilyTyCon tc = - case synTyConRhs tc of + | isFunTyCon tc || isPrimTyCon tc + = TyDecl { tcdLName = synifyName tc + , tcdTyVars = -- tyConTyVars doesn't work on fun/prim, but we can make them up: + let mk_hs_tv realKind fakeTyVar + = noLoc $ KindedTyVar (getName fakeTyVar) + (synifyKindSig realKind) + in HsQTvs { hsq_kvs = [] -- No kind polymorhism + , hsq_tvs = zipWith mk_hs_tv (fst (splitKindFunTys (tyConKind tc))) + alphaTyVars --a, b, c... which are unfortunately all kind * + } + + , tcdTyDefn = TyData { td_ND = DataType -- arbitrary lie, they are neither + -- algebraic data nor newtype: + , td_ctxt = noLoc [] + , td_cType = Nothing + , td_kindSig = Just (synifyKindSig (tyConKind tc)) + -- we have their kind accurately: + , td_cons = [] -- No constructors + , td_derivs = Nothing } + , tcdFVs = placeHolderNames } + | isSynFamilyTyCon tc + = case synTyConRhs tc of SynFamilyTyCon -> TyFamily TypeFamily (synifyName tc) (synifyTyVars (tyConTyVars tc)) - (Just (synifyKind (synTyConResKind tc))) -- placeHolderKind + (Just (synifyKindSig (synTyConResKind tc))) _ -> error "synifyTyCon: impossible open type synonym?" - | isDataFamilyTyCon tc = --(why no "isOpenAlgTyCon"?) - case algTyConRhs tc of + | isDataFamilyTyCon tc + = --(why no "isOpenAlgTyCon"?) + case algTyConRhs tc of DataFamilyTyCon -> TyFamily DataFamily (synifyName tc) (synifyTyVars (tyConTyVars tc)) Nothing --always kind '*' @@ -137,9 +141,6 @@ synifyTyCon tc alg_ctx = synifyCtx (tyConStupidTheta tc) name = synifyName tc tyvars = synifyTyVars (tyConTyVars tc) - typats = case tyConFamInst_maybe tc of - Nothing -> Nothing - Just (_, indexes) -> Just (map (synifyType WithinType) indexes) alg_kindSig = Just (tyConKind tc) -- The data constructors. -- @@ -162,10 +163,14 @@ synifyTyCon tc -- "deriving" doesn't affect the signature, no need to specify any. alg_deriv = Nothing syn_type = synifyType WithinType (synTyConType tc) - in if isSynTyCon tc - then TySynonym name tyvars typats syn_type - else TyData alg_nd alg_ctx name tyvars typats (fmap synifyKind alg_kindSig) alg_cons alg_deriv - + defn | isSynTyCon tc = TySynonym syn_type + | otherwise = TyData { td_ND = alg_nd, td_ctxt = alg_ctx + , td_cType = Nothing + , td_kindSig = fmap synifyKindSig alg_kindSig + , td_cons = alg_cons + , td_derivs = alg_deriv } + in TyDecl { tcdLName = name, tcdTyVars = tyvars, tcdTyDefn = defn + , tcdFVs = placeHolderNames } -- User beware: it is your responsibility to pass True (use_gadt_syntax) -- for any constructor that would be misrepresented by omitting its @@ -230,16 +235,17 @@ synifyCtx :: [PredType] -> LHsContext Name synifyCtx = noLoc . map (synifyType WithinType) -synifyTyVars :: [TyVar] -> [LHsTyVarBndr Name] -synifyTyVars = map synifyTyVar +synifyTyVars :: [TyVar] -> LHsTyVarBndrs Name +synifyTyVars ktvs = HsQTvs { hsq_kvs = map tyVarName kvs + , hsq_tvs = map synifyTyVar tvs } where - synifyTyVar tv = noLoc $ let - kind = tyVarKind tv - name = getName tv - in if isLiftedTypeKind kind - then UserTyVar name placeHolderKind - else KindedTyVar name (synifyKind kind) placeHolderKind - + (kvs, tvs) = partition isKindVar ktvs + synifyTyVar tv + | isLiftedTypeKind kind = noLoc (UserTyVar name) + | otherwise = noLoc (KindedTyVar name (synifyKindSig kind)) + where + kind = tyVarKind tv + name = getName tv --states of what to do with foralls: data SynifyTypeState @@ -271,9 +277,10 @@ synifyType _ (TyConApp tc tys) | getName tc == listTyConName, [ty] <- tys = noLoc $ HsListTy (synifyType WithinType ty) -- ditto for implicit parameter tycons - | Just ip <- tyConIP_maybe tc - , [ty] <- tys - = noLoc $ HsIParamTy ip (synifyType WithinType ty) + | tyConName tc == ipClassName + , [name, ty] <- tys + , Just x <- isStrLitTy name + = noLoc $ HsIParamTy (HsIPName x) (synifyType WithinType ty) -- and equalities | tc == eqTyCon , [ty1, ty2] <- tys @@ -305,9 +312,14 @@ synifyType s forallty@(ForAllTy _tv _ty) = sTau = synifyType WithinType tau in noLoc $ HsForAllTy forallPlicitness sTvs sCtx sTau +synifyType _ (LitTy t) = noLoc $ HsTyLit $ synifyTyLit t + +synifyTyLit :: TyLit -> HsTyLit +synifyTyLit (NumTyLit n) = HsNumTy n +synifyTyLit (StrTyLit s) = HsStrTy s -synifyKind :: Kind -> LHsKind Name -synifyKind = synifyType (error "synifyKind") +synifyKindSig :: Kind -> LHsKind Name +synifyKindSig k = synifyType (error "synifyKind") k synifyInstHead :: ([TyVar], [PredType], Class, [Type]) -> ([HsType Name], Name, [HsType Name]) diff --git a/src/Haddock/GhcUtils.hs b/src/Haddock/GhcUtils.hs index fc04351b..a841e567 100644 --- a/src/Haddock/GhcUtils.hs +++ b/src/Haddock/GhcUtils.hs @@ -78,7 +78,7 @@ isVarSym = isLexVarSym . occNameFS getMainDeclBinder :: HsDecl name -> [name] -getMainDeclBinder (TyClD d) | not (isFamInstDecl d) = [tcdName d] +getMainDeclBinder (TyClD d) = [tcdName d] getMainDeclBinder (ValD d) = case collectHsBindBinders d of [] -> [] @@ -138,7 +138,6 @@ isDocD _ = False isInstD :: HsDecl a -> Bool isInstD (InstD _) = True -isInstD (TyClD d) = isFamInstDecl d isInstD _ = False @@ -152,12 +151,12 @@ declATs (TyClD d) | isClassDecl d = map (tcdName . unL) $ tcdATs d declATs _ = [] -pretty :: Outputable a => a -> String -pretty x = showSDoc (ppr x) +pretty :: Outputable a => DynFlags -> a -> String +pretty = showPpr -trace_ppr :: Outputable a => a -> b -> b -trace_ppr x y = trace (pretty x) y +trace_ppr :: Outputable a => DynFlags -> a -> b -> b +trace_ppr dflags x y = trace (pretty dflags x) y ------------------------------------------------------------------------------- @@ -216,7 +215,7 @@ instance Parent (ConDecl Name) where instance Parent (TyClDecl Name) where children d - | isDataDecl d = map (unL . con_name . unL) . tcdCons $ d + | isDataDecl d = map (unL . con_name . unL) . td_cons . tcdTyDefn $ d | isClassDecl d = map (tcdName . unL) (tcdATs d) ++ [ unL n | L _ (TypeSig ns _) <- tcdSigs d, n <- ns ] @@ -232,7 +231,7 @@ family = getName &&& children -- child to its grand-children, recursively. families :: TyClDecl Name -> [(Name, [Name])] families d - | isDataDecl d = family d : map (family . unL) (tcdCons d) + | isDataDecl d = family d : map (family . unL) (td_cons (tcdTyDefn d)) | isClassDecl d = family d : concatMap (families . unL) (tcdATs d) | otherwise = [] diff --git a/src/Haddock/Interface.hs b/src/Haddock/Interface.hs index 0003cba2..5a8e8485 100644 --- a/src/Haddock/Interface.hs +++ b/src/Haddock/Interface.hs @@ -50,6 +50,7 @@ import System.FilePath import Text.Printf import Digraph +import DynFlags hiding (verbosity, flags) import Exception import GHC hiding (verbosity, flags) import HscTypes @@ -88,8 +89,9 @@ processModules verbosity modules flags extIfaces = do out verbosity verbose "Renaming interfaces..." let warnings = Flag_NoWarnings `notElem` flags + dflags <- getDynFlags let (interfaces'', msgs) = - runWriter $ mapM (renameInterface links warnings) interfaces' + runWriter $ mapM (renameInterface dflags links warnings) interfaces' liftIO $ mapM_ putStrLn msgs return (interfaces'', homeLinks) diff --git a/src/Haddock/Interface/AttachInstances.hs b/src/Haddock/Interface/AttachInstances.hs index 089f31b4..8fff4d7a 100644 --- a/src/Haddock/Interface/AttachInstances.hs +++ b/src/Haddock/Interface/AttachInstances.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE MagicHash #-} +{-# LANGUAGE CPP, MagicHash #-} ----------------------------------------------------------------------------- -- | -- Module : Haddock.Interface.AttachInstances @@ -96,7 +96,7 @@ lookupInstDoc name iface ifaceMap instIfaceMap = -- | Like GHC's getInfo but doesn't cut things out depending on the -- interative context, which we don't set sufficiently anyway. -getAllInfo :: GhcMonad m => Name -> m (Maybe (TyThing,Fixity,[Instance])) +getAllInfo :: GhcMonad m => Name -> m (Maybe (TyThing,Fixity,[ClsInst])) getAllInfo name = withSession $ \hsc_env -> do (_msgs, r) <- liftIO $ tcRnGetInfo hsc_env name return r @@ -111,7 +111,9 @@ getAllInfo name = withSession $ \hsc_env -> do -- in Haddock output) and unifying special tycons with normal ones. -- For the benefit of the user (looks nice and predictable) and the -- tests (which prefer output to be deterministic). -data SimpleType = SimpleType Name [SimpleType] deriving (Eq,Ord) +data SimpleType = SimpleType Name [SimpleType] + | SimpleTyLit TyLit + deriving (Eq,Ord) instHead :: ([TyVar], [PredType], Class, [Type]) -> ([Int], Name, [SimpleType]) @@ -131,6 +133,7 @@ instHead (_, _, cls, args) where (SimpleType s ts) = simplify t1 simplify (TyVarTy v) = SimpleType (tyVarName v) [] simplify (TyConApp tc ts) = SimpleType (tyConName tc) (map simplify ts) + simplify (LitTy l) = SimpleTyLit l -- sortImage f = sortBy (\x y -> compare (f x) (f y)) diff --git a/src/Haddock/Interface/Create.hs b/src/Haddock/Interface/Create.hs index 2bca57d0..32f287f5 100644 --- a/src/Haddock/Interface/Create.hs +++ b/src/Haddock/Interface/Create.hs @@ -1,4 +1,5 @@ -{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TupleSections, BangPatterns #-} +{-# OPTIONS_GHC -Wwarn #-} ----------------------------------------------------------------------------- -- | -- Module : Haddock.Interface.Create @@ -27,14 +28,20 @@ import Data.Maybe import Data.Monoid import Data.Ord import Control.Applicative +import Control.DeepSeq import Control.Monad -import qualified Data.Traversable as Traversable +import qualified Data.Traversable as T +import qualified Packages +import qualified Module +import qualified SrcLoc import GHC hiding (flags) import HscTypes import Name import Bag -import RdrName (GlobalRdrEnv) +import RdrName +import TcRnTypes +import FastString (unpackFS) -- | Use a 'TypecheckedModule' to produce an 'Interface'. @@ -43,12 +50,15 @@ import RdrName (GlobalRdrEnv) createInterface :: TypecheckedModule -> [Flag] -> IfaceMap -> InstIfaceMap -> ErrMsgGhc Interface createInterface tm flags modMap instIfaceMap = do - let ms = pm_mod_summary . tm_parsed_module $ tm - mi = moduleInfo tm - mdl = ms_mod ms - dflags = ms_hspp_opts ms - instances = modInfoInstances mi - exportedNames = modInfoExports mi + let ms = pm_mod_summary . tm_parsed_module $ tm + mi = moduleInfo tm + !safety = modInfoSafe mi + mdl = ms_mod ms + dflags = ms_hspp_opts ms + !instances = modInfoInstances mi + !exportedNames = modInfoExports mi + + (TcGblEnv {tcg_rdr_env = gre, tcg_warns = warnings}, _) = tm_internals_ tm -- The renamed source should always be available to us, but it's best -- to be on the safe side. @@ -59,56 +69,55 @@ createInterface tm flags modMap instIfaceMap = do return (emptyRnGroup, Nothing, Nothing) Just (x, _, y, z) -> return (x, y, z) - -- The pattern-match should not fail, because createInterface is only - -- done on loaded modules. - Just gre <- liftGhcToErrMsgGhc $ lookupLoadedHomeModuleGRE (moduleName mdl) - opts0 <- liftErrMsg $ mkDocOpts (haddockOptions dflags) flags mdl let opts | Flag_IgnoreAllExports `elem` flags = OptIgnoreExports : opts0 | otherwise = opts0 - (info, mbDoc) <- liftErrMsg $ lexParseRnHaddockModHeader dflags gre mayDocHeader + (!info, mbDoc) <- liftErrMsg $ processModuleHeader dflags gre safety mayDocHeader let declsWithDocs = topDecls group_ (decls, _) = unzip declsWithDocs localInsts = filter (nameIsLocalOrFrom mdl . getName) instances - maps@(docMap, argMap, subMap, declMap) <- - liftErrMsg $ mkMaps dflags gre localInsts exportedNames declsWithDocs + maps@(!docMap, !argMap, !subMap, !declMap) <- + liftErrMsg $ mkMaps dflags gre localInsts declsWithDocs let exports0 = fmap (reverse . map unLoc) mayExports exports | OptIgnoreExports `elem` opts = Nothing | otherwise = exports0 - liftErrMsg $ warnAboutFilteredDecls mdl decls + liftErrMsg $ warnAboutFilteredDecls dflags mdl decls - exportItems <- mkExportItems modMap mdl gre exportedNames decls maps exports + let warningMap = mkWarningMap warnings gre exportedNames + exportItems <- mkExportItems modMap mdl warningMap gre exportedNames decls maps exports instances instIfaceMap dflags - let visibleNames = mkVisibleNames exportItems opts + let !visibleNames = mkVisibleNames exportItems opts -- Measure haddock documentation coverage. - let - prunedExportItems0 = pruneExportItems exportItems - haddockable = 1 + length exportItems -- module + exports - haddocked = (if isJust mbDoc then 1 else 0) + length prunedExportItems0 - coverage = (haddockable, haddocked) + let prunedExportItems0 = pruneExportItems exportItems + !haddockable = 1 + length exportItems -- module + exports + !haddocked = (if isJust mbDoc then 1 else 0) + length prunedExportItems0 + !coverage = (haddockable, haddocked) -- Prune the export list to just those declarations that have -- documentation, if the 'prune' option is on. - let - prunedExportItems - | OptPrune `elem` opts = prunedExportItems0 - | otherwise = exportItems + let prunedExportItems' + | OptPrune `elem` opts = prunedExportItems0 + | otherwise = exportItems + !prunedExportItems = seqList prunedExportItems' `seq` prunedExportItems' - return Interface { + let !aliases = + mkAliasMap dflags $ tm_renamed_source tm + + return $! Interface { ifaceMod = mdl, ifaceOrigFilename = msHsFilePath ms, ifaceInfo = info, - ifaceDoc = mbDoc, - ifaceRnDoc = Nothing, + ifaceDoc = Documentation mbDoc (moduleWarning warnings), + ifaceRnDoc = Documentation Nothing Nothing, ifaceOptions = opts, ifaceDocMap = docMap, ifaceArgMap = argMap, @@ -120,10 +129,70 @@ createInterface tm flags modMap instIfaceMap = do ifaceVisibleExports = visibleNames, ifaceDeclMap = declMap, ifaceSubMap = subMap, + ifaceModuleAliases = aliases, ifaceInstances = instances, ifaceHaddockCoverage = coverage } +mkAliasMap :: DynFlags -> Maybe RenamedSource -> M.Map Module ModuleName +mkAliasMap dflags mRenamedSource = + case mRenamedSource of + Nothing -> M.empty + Just (_,impDecls,_,_) -> + M.fromList $ + mapMaybe (\(SrcLoc.L _ impDecl) -> do + alias <- ideclAs impDecl + return $ + (lookupModuleDyn dflags + (fmap Module.fsToPackageId $ + ideclPkgQual impDecl) + (case ideclName impDecl of SrcLoc.L _ name -> name), + alias)) + impDecls + +-- similar to GHC.lookupModule +lookupModuleDyn :: + DynFlags -> Maybe PackageId -> ModuleName -> Module +lookupModuleDyn _ (Just pkgId) mdlName = + Module.mkModule pkgId mdlName +lookupModuleDyn dflags Nothing mdlName = + flip Module.mkModule mdlName $ + case filter snd $ + Packages.lookupModuleInAllPackages dflags mdlName of + (pkgId,_):_ -> Packages.packageConfigId pkgId + [] -> Module.mainPackageId + + +------------------------------------------------------------------------------- +-- Warnings +------------------------------------------------------------------------------- + +type WarningMap = DocMap Name + +mkWarningMap :: Warnings -> GlobalRdrEnv -> [Name] -> WarningMap +mkWarningMap NoWarnings _ _ = M.empty +mkWarningMap (WarnAll _) _ _ = M.empty +mkWarningMap (WarnSome ws) gre exps = M.fromList + [ (n, warnToDoc w) | (occ, w) <- ws, elt <- lookupGlobalRdrEnv gre occ + , let n = gre_name elt, n `elem` exps ] + + +moduleWarning :: Warnings -> Maybe (Doc id) +moduleWarning ws = + case ws of + NoWarnings -> Nothing + WarnSome _ -> Nothing + WarnAll w -> Just $! warnToDoc w + + +warnToDoc :: WarningTxt -> Doc id +warnToDoc w = case w of + (DeprecatedTxt msg) -> format "Deprecated: " msg + (WarningTxt msg) -> format "Warning: " msg + where + format x xs = let !str = force $ concat (x : map unpackFS xs) + in DocWarning $ DocParagraph $ DocString str + ------------------------------------------------------------------------------- -- Doc options @@ -153,62 +222,71 @@ parseOption other = tell ["Unrecognised option: " ++ other] >> return Nothing -------------------------------------------------------------------------------- --- Declarations +-- Maps -------------------------------------------------------------------------------- type Maps = (DocMap Name, ArgMap Name, SubMap, DeclMap) - +-- | Create 'Maps' by looping through the declarations. For each declaration, +-- find its names, its subordinates, and its doc strings. Process doc strings +-- into 'Doc's. mkMaps :: DynFlags -> GlobalRdrEnv - -> [Instance] - -> [Name] + -> [ClsInst] -> [(LHsDecl Name, [HsDocString])] -> ErrMsgM Maps -mkMaps dflags gre instances exports decls = do - (dm, am, sm, cm) <- unzip4 <$> mapM mappings decls - let f :: (Ord a, Monoid b) => [[(a, b)]] -> Map a b - f = M.fromListWith mappend . concat - return (f dm, f am, f sm, f cm) +mkMaps dflags gre instances decls = do + (a, b, c, d) <- unzip4 <$> mapM mappings decls + return (f a, f b, f c, f d) where - mappings (ldecl@(L _ decl), docs) = do - doc <- lexParseRnHaddockCommentList dflags NormalHaddockComment gre docs - argDocs <- fmap (M.mapMaybe id) $ Traversable.forM (typeDocs decl) $ - lexParseRnHaddockComment dflags NormalHaddockComment gre - - let subs = [ s | s@(n, _, _) <- subordinates decl, n `elem` exports ] - - (subDocs, subArgMap) <- unzip <$> (forM subs $ \(n, mbSubDocStr, subFnArgsDocStr) -> do - mbSubDoc <- lexParseRnHaddockCommentList dflags NormalHaddockComment gre mbSubDocStr - subFnArgsDoc <- fmap (M.mapMaybe id) $ Traversable.forM subFnArgsDocStr $ - lexParseRnHaddockComment dflags NormalHaddockComment gre - return ((n, mbSubDoc), (n, subFnArgsDoc))) - - let names = case decl of - -- See note [2]. - InstD (InstDecl (L l _) _ _ _) -> maybeToList (M.lookup l instanceMap) - _ -> filter (`elem` exports) (getMainDeclBinder decl) - - let subNames = map fst subDocs - dm = [ (n, d) | (n, Just d) <- (zip names (repeat doc)) ++ subDocs ] - am = [ (n, argDocs) | n <- names ] ++ subArgMap - sm = [ (n, subNames) | n <- names ] - cm = [ (n, [ldecl]) | n <- names ++ subNames ] - return (dm, am, sm, cm) - + f :: (Ord a, Monoid b) => [[(a, b)]] -> Map a b + f = M.fromListWith (<>) . concat + + mappings (ldecl, docStrs) = do + let decl = unLoc ldecl + let declDoc strs m = do + doc <- processDocStrings dflags gre strs + m' <- M.mapMaybe id <$> T.mapM (processDocStringParas dflags gre) m + return (doc, m') + (doc, args) <- declDoc docStrs (typeDocs decl) + let subs = subordinates decl + (subDocs, subArgs) <- unzip <$> mapM (\(_, strs, m) -> declDoc strs m) subs + let ns = names decl + subNs = [ n | (n, _, _) <- subs ] + dm = [ (n, d) | (n, Just d) <- zip ns (repeat doc) ++ zip subNs subDocs ] + am = [ (n, args) | n <- ns ] ++ zip subNs subArgs + sm = [ (n, subNs) | n <- ns ] + cm = [ (n, [ldecl]) | n <- ns ++ subNs ] + seqList ns `seq` + seqList subNs `seq` + doc `seq` + seqList subDocs `seq` + seqList subArgs `seq` + return (dm, am, sm, cm) + + instanceMap :: Map SrcSpan Name instanceMap = M.fromList [ (getSrcSpan n, n) | i <- instances, let n = getName i ] + names :: HsDecl Name -> [Name] + names (InstD (ClsInstD { cid_poly_ty = L l _ })) = maybeToList (M.lookup l instanceMap) -- See note [2]. + names decl = getMainDeclBinder decl -- Note [2]: ------------ --- We relate Instances to InstDecls using the SrcSpans buried inside them. +-- We relate ClsInsts to InstDecls using the SrcSpans buried inside them. -- That should work for normal user-written instances (from looking at GHC -- sources). We can assume that commented instances are user-written. --- This lets us relate Names (from Instances) to comments (associated +-- This lets us relate Names (from ClsInsts) to comments (associated -- with InstDecls). +-------------------------------------------------------------------------------- +-- Declarations +-------------------------------------------------------------------------------- + + +-- | Get all subordinate declarations inside a declaration, and their docs. subordinates :: HsDecl Name -> [(Name, [HsDocString], Map Int HsDocString)] subordinates (TyClD decl) | isClassDecl decl = classSubs @@ -219,7 +297,7 @@ subordinates (TyClD decl) ] dataSubs = constrs ++ fields where - cons = map unL $ tcdCons decl + cons = map unL $ (td_cons (tcdTyDefn decl)) constrs = [ (unL $ con_name c, maybeToList $ fmap unL $ con_doc c, M.empty) | c <- cons ] fields = [ (unL n, maybeToList $ fmap unL doc, M.empty) @@ -235,7 +313,7 @@ typeDocs d = case d of SigD (TypeSig _ ty) -> docs (unLoc ty) ForD (ForeignImport _ ty _ _) -> docs (unLoc ty) - TyClD (TySynonym {tcdSynRhs = ty}) -> docs (unLoc ty) + TyClD (TyDecl { tcdTyDefn = TySynonym {td_synRhs = ty}}) -> docs (unLoc ty) _ -> M.empty where go n (HsForAllTy _ _ _ ty) = go n (unLoc ty) @@ -293,26 +371,26 @@ sortByLoc :: [Located a] -> [Located a] sortByLoc = sortBy (comparing getLoc) -warnAboutFilteredDecls :: Module -> [LHsDecl Name] -> ErrMsgM () -warnAboutFilteredDecls mdl decls = do +warnAboutFilteredDecls :: DynFlags -> Module -> [LHsDecl Name] -> ErrMsgM () +warnAboutFilteredDecls dflags mdl decls = do let modStr = moduleString mdl let typeInstances = - nub [ tcdName d | L _ (TyClD d) <- decls, isFamInstDecl d ] + nub [ unLoc (fid_tycon d) | L _ (InstD (FamInstD { lid_inst = d })) <- decls ] unless (null typeInstances) $ tell [ "Warning: " ++ modStr ++ ": Instances of type and data " ++ "families are not yet supported. Instances of the following families " - ++ "will be filtered out:\n " ++ concat (intersperse ", " + ++ "will be filtered out:\n " ++ (intercalate ", " $ map (occNameString . nameOccName) typeInstances) ] - let instances = nub [ pretty i | L _ (InstD (InstDecl i _ _ ats)) <- decls + let instances = nub [ pretty dflags i | L _ (InstD (ClsInstD { cid_poly_ty = i, cid_fam_insts = ats })) <- decls , not (null ats) ] unless (null instances) $ tell [ "Warning: " ++ modStr ++ ": We do not support associated types in instances yet. " - ++ "These instances are affected:\n" ++ concat (intersperse ", " instances) ] + ++ "These instances are affected:\n" ++ intercalate ", " instances ] -------------------------------------------------------------------------------- @@ -324,7 +402,7 @@ warnAboutFilteredDecls mdl decls = do -- | Filter out declarations that we don't handle in Haddock filterDecls :: [(LHsDecl a, doc)] -> [(LHsDecl a, doc)] -filterDecls decls = filter (isHandled . unL . fst) decls +filterDecls = filter (isHandled . unL . fst) where isHandled (ForD (ForeignImport {})) = True isHandled (TyClD {}) = True @@ -361,10 +439,10 @@ collectDocs = go Nothing [] where go Nothing _ [] = [] go (Just prev) docs [] = finished prev docs [] - go prev docs ((L _ (DocD (DocCommentNext str))):ds) + go prev docs (L _ (DocD (DocCommentNext str)) : ds) | Nothing <- prev = go Nothing (str:docs) ds | Just decl <- prev = finished decl docs (go Nothing [str] ds) - go prev docs ((L _ (DocD (DocCommentPrev str))):ds) = go prev (str:docs) ds + go prev docs (L _ (DocD (DocCommentPrev str)) : ds) = go prev (str:docs) ds go Nothing docs (d:ds) = go (Just d) docs ds go (Just prev) docs (d:ds) = finished prev docs (go (Just d) [] ds) @@ -380,49 +458,42 @@ collectDocs = go Nothing [] mkExportItems :: IfaceMap -> Module -- this module + -> WarningMap -> GlobalRdrEnv -> [Name] -- exported names (orig) -> [LHsDecl Name] -> Maps -> Maybe [IE Name] - -> [Instance] + -> [ClsInst] -> InstIfaceMap -> DynFlags -> ErrMsgGhc [ExportItem Name] mkExportItems - modMap thisMod gre exportedNames decls0 + modMap thisMod warnings gre exportedNames decls0 (maps@(docMap, argMap, subMap, declMap)) optExports _ instIfaceMap dflags = case optExports of - Nothing -> fullModuleContents dflags gre maps decls - Just exports -> liftM (nubBy commaDeclared . concat) $ mapM lookupExport exports + Nothing -> fullModuleContents dflags warnings gre maps decls + Just exports -> liftM concat $ mapM lookupExport exports where decls = filter (not . isInstD . unLoc) decls0 - -- 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 (IEThingAll t) = declWith t lookupExport (IEThingWith t _) = declWith t lookupExport (IEModuleContents m) = - moduleExports thisMod m dflags gre exportedNames decls modMap instIfaceMap maps + moduleExports thisMod m dflags warnings gre exportedNames decls modMap instIfaceMap maps lookupExport (IEGroup lev docStr) = liftErrMsg $ - ifDoc (lexParseRnHaddockComment dflags DocSectionComment gre docStr) + ifDoc (processDocString dflags gre docStr) (\doc -> return [ ExportGroup lev "" doc ]) lookupExport (IEDoc docStr) = liftErrMsg $ - ifDoc (lexParseRnHaddockComment dflags NormalHaddockComment gre docStr) + ifDoc (processDocStringParas dflags gre docStr) (\doc -> return [ ExportDoc doc ]) lookupExport (IEDocNamed str) = liftErrMsg $ ifDoc (findNamedDoc str [ unL d | d <- decls ]) (\docStr -> - ifDoc (lexParseRnHaddockComment dflags NormalHaddockComment gre docStr) + ifDoc (processDocStringParas dflags gre docStr) (\doc -> return [ ExportDoc doc ])) @@ -437,7 +508,7 @@ mkExportItems case findDecl t of ([L _ (ValD _)], (doc, _)) -> do -- Top-level binding without type signature - export <- hiValExportItem t doc + export <- hiValExportItem dflags t doc return [export] (ds, docs_) | decl : _ <- filter (not . isValD . unLoc) ds -> let declNames = getMainDeclBinder (unL decl) @@ -450,12 +521,12 @@ mkExportItems -- We should not show a subordinate by itself if any of its -- parents is also exported. See note [1]. - | not $ t `elem` declNames, + | t `notElem` declNames, Just p <- find isExported (parents t $ unL decl) -> do liftErrMsg $ tell [ "Warning: " ++ moduleString thisMod ++ ": " ++ - pretty (nameOccName t) ++ " is exported separately but " ++ - "will be documented under " ++ pretty (nameOccName p) ++ + pretty dflags (nameOccName t) ++ " is exported separately but " ++ + "will be documented under " ++ pretty dflags (nameOccName p) ++ ". Consider exporting it together with its parent(s)" ++ " for code clarity." ] return [] @@ -463,33 +534,32 @@ mkExportItems -- normal case | otherwise -> return [ mkExportDecl t newDecl docs_ ] 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. + -- A single signature might refer to many names, but we + -- create an export item for a single name only. So we + -- modify the signature to contain only that single name. newDecl = case decl of (L loc (SigD sig)) -> - L loc . SigD . fromJust $ filterSigNames isExported sig + L loc . SigD . fromJust $ filterSigNames (== t) sig -- fromJust is safe since we already checked in guards -- that 't' is a name declared in this declaration. _ -> decl -- Declaration from another package ([], _) -> do - mayDecl <- hiDecl t + mayDecl <- hiDecl dflags t case mayDecl of Nothing -> return [ ExportNoDecl t [] ] - Just decl -> do + Just decl -> -- We try to get the subs and docs -- from the installed .haddock file for that package. case M.lookup (nameModule t) instIfaceMap of Nothing -> do liftErrMsg $ tell - ["Warning: Couldn't find .haddock for export " ++ pretty t] + ["Warning: Couldn't find .haddock for export " ++ pretty dflags t] let subs_ = [ (n, noDocForDecl) | (n, _, _) <- subordinates (unLoc decl) ] return [ mkExportDecl t decl (noDocForDecl, subs_) ] - Just iface -> do - return [ mkExportDecl t decl (lookupDocs t (instDocMap iface) (instArgMap iface) (instSubMap iface)) ] + Just iface -> + return [ mkExportDecl t decl (lookupDocs t warnings (instDocMap iface) (instArgMap iface) (instSubMap iface)) ] _ -> return [] @@ -509,39 +579,42 @@ mkExportItems findDecl :: Name -> ([LHsDecl Name], (DocForDecl Name, [(Name, DocForDecl Name)])) findDecl n | m == thisMod, Just ds <- M.lookup n declMap = - (ds, lookupDocs n docMap argMap subMap) + (ds, lookupDocs n warnings docMap argMap subMap) | Just iface <- M.lookup m modMap, Just ds <- M.lookup n (ifaceDeclMap iface) = - (ds, lookupDocs n (ifaceDocMap iface) (ifaceArgMap iface) (ifaceSubMap iface)) + (ds, lookupDocs n warnings (ifaceDocMap iface) (ifaceArgMap iface) (ifaceSubMap iface)) | otherwise = ([], (noDocForDecl, [])) where m = nameModule n -hiDecl :: Name -> ErrMsgGhc (Maybe (LHsDecl Name)) -hiDecl t = do +hiDecl :: DynFlags -> Name -> ErrMsgGhc (Maybe (LHsDecl Name)) +hiDecl dflags t = do mayTyThing <- liftGhcToErrMsgGhc $ lookupName t case mayTyThing of Nothing -> do - liftErrMsg $ tell ["Warning: Not found in environment: " ++ pretty t] + liftErrMsg $ tell ["Warning: Not found in environment: " ++ pretty dflags t] return Nothing Just x -> return (Just (tyThingToLHsDecl x)) -hiValExportItem :: Name -> DocForDecl Name -> ErrMsgGhc (ExportItem Name) -hiValExportItem name doc = do - mayDecl <- hiDecl name +hiValExportItem :: DynFlags -> Name -> DocForDecl Name -> ErrMsgGhc (ExportItem Name) +hiValExportItem dflags name doc = do + mayDecl <- hiDecl dflags name case mayDecl of Nothing -> return (ExportNoDecl name []) Just decl -> return (ExportDecl decl doc [] []) -- | Lookup docs for a declaration from maps. -lookupDocs :: Name -> DocMap Name -> ArgMap Name -> SubMap -> (DocForDecl Name, [(Name, DocForDecl Name)]) -lookupDocs name docMap argMap subMap = - let lookupArgMap x = maybe M.empty id (M.lookup x argMap) in - let doc = (M.lookup name docMap, lookupArgMap name) in - let subs = [ (sub, (M.lookup sub docMap, lookupArgMap sub)) | sub <- maybe [] id (M.lookup name subMap) ] in - (doc, subs) +lookupDocs :: Name -> WarningMap -> DocMap Name -> ArgMap Name -> SubMap -> (DocForDecl Name, [(Name, DocForDecl Name)]) +lookupDocs n warnings docMap argMap subMap = + let lookupArgDoc x = M.findWithDefault M.empty x argMap in + let doc = (lookupDoc n, lookupArgDoc n) in + let subs = M.findWithDefault [] n subMap in + let subDocs = [ (s, (lookupDoc s, lookupArgDoc s)) | s <- subs ] in + (doc, subDocs) + where + lookupDoc name = Documentation (M.lookup name docMap) (M.lookup name warnings) -- | Return all export items produced by an exported module. That is, we're @@ -560,6 +633,7 @@ lookupDocs name docMap argMap subMap = moduleExports :: Module -- ^ Module A -> ModuleName -- ^ The real name of B, the exported module -> DynFlags -- ^ The flags used when typechecking A + -> WarningMap -> GlobalRdrEnv -- ^ The renaming environment used for A -> [Name] -- ^ All the exports of A -> [LHsDecl Name] -- ^ All the declarations in A @@ -567,8 +641,8 @@ moduleExports :: Module -- ^ Module A -> InstIfaceMap -- ^ Interfaces in other packages -> Maps -> ErrMsgGhc [ExportItem Name] -- ^ Resulting export items -moduleExports thisMod expMod dflags gre _exports decls ifaceMap instIfaceMap maps - | m == thisMod = fullModuleContents dflags gre maps decls +moduleExports thisMod expMod dflags warnings gre _exports decls ifaceMap instIfaceMap maps + | m == thisMod = fullModuleContents dflags warnings gre maps decls | otherwise = case M.lookup m ifaceMap of Just iface @@ -581,8 +655,8 @@ moduleExports thisMod expMod dflags gre _exports decls ifaceMap instIfaceMap map Just iface -> return [ ExportModule (instMod iface) ] Nothing -> do liftErrMsg $ - tell ["Warning: " ++ pretty thisMod ++ ": Could not find " ++ - "documentation for exported module: " ++ pretty expMod] + tell ["Warning: " ++ pretty dflags thisMod ++ ": Could not find " ++ + "documentation for exported module: " ++ pretty dflags expMod] return [] where m = mkModule packageId expMod @@ -606,25 +680,39 @@ moduleExports thisMod expMod dflags gre _exports decls ifaceMap instIfaceMap map -- (For more information, see Trac #69) -fullModuleContents :: DynFlags -> GlobalRdrEnv -> Maps -> [LHsDecl Name] -> ErrMsgGhc [ExportItem Name] -fullModuleContents dflags gre (docMap, argMap, subMap, declMap) decls = - liftM catMaybes $ mapM mkExportItem decls +fullModuleContents :: DynFlags -> WarningMap -> GlobalRdrEnv -> Maps -> [LHsDecl Name] -> ErrMsgGhc [ExportItem Name] +fullModuleContents dflags warnings gre (docMap, argMap, subMap, declMap) decls = + liftM catMaybes $ mapM mkExportItem (expandSig decls) where + -- A type signature can have multiple names, like: + -- foo, bar :: Types.. + -- + -- We go through the list of declarations and expand type signatures, so + -- that every type signature has exactly one name! + expandSig :: [LHsDecl name] -> [LHsDecl name] + expandSig = foldr f [] + where + f :: LHsDecl name -> [LHsDecl name] -> [LHsDecl name] + f (L l (SigD (TypeSig names t))) xs = foldr (\n acc -> L l (SigD (TypeSig [n] t)) : acc) xs names + f (L l (SigD (GenericSig names t))) xs = foldr (\n acc -> L l (SigD (GenericSig [n] t)) : acc) xs names + f x xs = x : xs + + mkExportItem :: LHsDecl Name -> ErrMsgGhc (Maybe (ExportItem Name)) mkExportItem (L _ (DocD (DocGroup lev docStr))) = do - mbDoc <- liftErrMsg $ lexParseRnHaddockComment dflags DocSectionComment gre docStr + mbDoc <- liftErrMsg $ processDocString dflags gre docStr return $ fmap (ExportGroup lev "") mbDoc mkExportItem (L _ (DocD (DocCommentNamed _ docStr))) = do - mbDoc <- liftErrMsg $ lexParseRnHaddockComment dflags NormalHaddockComment gre docStr + mbDoc <- liftErrMsg $ processDocStringParas dflags gre docStr return $ fmap ExportDoc mbDoc mkExportItem (L _ (ValD d)) | name:_ <- collectHsBindBinders d, Just [L _ (ValD _)] <- M.lookup name declMap = -- Top-level binding without type signature. - let (doc, _) = lookupDocs name docMap argMap subMap in - fmap Just (hiValExportItem name doc) + let (doc, _) = lookupDocs name warnings docMap argMap subMap in + fmap Just (hiValExportItem dflags name doc) | otherwise = return Nothing mkExportItem decl | name:_ <- getMainDeclBinder (unLoc decl) = - let (doc, subs) = lookupDocs name docMap argMap subMap in + let (doc, subs) = lookupDocs name warnings docMap argMap subMap in return $ Just (ExportDecl decl doc subs []) | otherwise = return Nothing @@ -648,7 +736,7 @@ extractDecl name mdl decl _ -> error "internal: extractDecl" TyClD d | isDataDecl d -> let (n, tyvar_names) = name_and_tyvars d - L pos sig = extractRecSel name mdl n tyvar_names (tcdCons d) + L pos sig = extractRecSel name mdl n tyvar_names (td_cons (tcdTyDefn d)) in L pos (SigD sig) _ -> error "internal: extractDecl" where @@ -663,7 +751,7 @@ extractClassDecl :: Name -> [Located Name] -> LSig Name -> LSig Name extractClassDecl c tvs0 (L pos (TypeSig lname ltype)) = case ltype of L _ (HsForAllTy expl tvs (L _ preds) ty) -> L pos (TypeSig lname (noLoc (HsForAllTy expl tvs (lctxt preds) ty))) - _ -> L pos (TypeSig lname (noLoc (mkImplicitHsForAllTy (lctxt []) ltype))) + _ -> L pos (TypeSig lname (noLoc (HsForAllTy Implicit emptyHsQTvs (lctxt []) ltype))) where lctxt = noLoc . ctxt ctxt preds = nlHsTyConApp c (map toTypeNoLoc tvs0) : preds @@ -684,18 +772,19 @@ extractRecSel nm mdl t tvs (L _ con : rest) = data_ty = foldl (\x y -> noLoc (HsAppTy x y)) (noLoc (HsTyVar t)) (map toTypeNoLoc tvs) --- Pruning +-- | Keep export items with docs. pruneExportItems :: [ExportItem Name] -> [ExportItem Name] -pruneExportItems items = filter hasDoc items +pruneExportItems = filter hasDoc where - hasDoc (ExportDecl{expItemMbDoc = (d, _)}) = isJust d + hasDoc (ExportDecl{expItemMbDoc = (Documentation d _, _)}) = isJust d hasDoc _ = True mkVisibleNames :: [ExportItem Name] -> [DocOption] -> [Name] mkVisibleNames exports opts | OptHide `elem` opts = [] - | otherwise = concatMap exportName exports + | otherwise = let ns = concatMap exportName exports + in seqList ns `seq` ns where exportName e@ExportDecl {} = getMainDeclBinder (unL $ expItemDecl e) ++ subs where subs = map fst (expItemSubDocs e) @@ -703,15 +792,18 @@ mkVisibleNames exports opts -- we don't want links to go to them. exportName _ = [] +seqList :: [a] -> () +seqList [] = () +seqList (x : xs) = x `seq` seqList xs -- | Find a stand-alone documentation comment by its name. findNamedDoc :: String -> [HsDecl Name] -> ErrMsgM (Maybe HsDocString) -findNamedDoc name decls = search decls +findNamedDoc name = search where search [] = do tell ["Cannot find documentation for: $" ++ name] return Nothing - search ((DocD (DocCommentNamed name' doc)):rest) + 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/LexParseRn.hs b/src/Haddock/Interface/LexParseRn.hs index f70c5953..3ad9719e 100644 --- a/src/Haddock/Interface/LexParseRn.hs +++ b/src/Haddock/Interface/LexParseRn.hs @@ -1,4 +1,6 @@ ------------------------------------------------------------------------------ +{-# OPTIONS_GHC -Wwarn #-} +{-# LANGUAGE BangPatterns #-} + ----------------------------------------------------------------------------- -- | -- Module : Haddock.Interface.LexParseRn -- Copyright : (c) Isaac Dupree 2009, @@ -9,11 +11,10 @@ -- Portability : portable ----------------------------------------------------------------------------- module Haddock.Interface.LexParseRn - ( HaddockCommentType(..) - , lexParseRnHaddockComment - , lexParseRnHaddockCommentList - , lexParseRnMbHaddockComment - , lexParseRnHaddockModHeader + ( processDocString + , processDocStringParas + , processDocStrings + , processModuleHeader ) where @@ -24,6 +25,7 @@ import Haddock.Interface.ParseModuleHeader import Haddock.Doc import Control.Applicative +import Data.List import Data.Maybe import FastString import GHC @@ -33,64 +35,62 @@ import RdrName import RnEnv -data HaddockCommentType = NormalHaddockComment | DocSectionComment - - -lexParseRnHaddockCommentList :: DynFlags -> HaddockCommentType -> GlobalRdrEnv -> [HsDocString] -> ErrMsgM (Maybe (Doc Name)) -lexParseRnHaddockCommentList dflags hty gre docStrs = do - docMbs <- mapM (lexParseRnHaddockComment dflags hty gre) docStrs - let docs = catMaybes docMbs - let doc = foldl docAppend DocEmpty docs +processDocStrings :: DynFlags -> GlobalRdrEnv -> [HsDocString] -> ErrMsgM (Maybe (Doc Name)) +processDocStrings dflags gre strs = do + docs <- catMaybes <$> mapM (processDocStringParas dflags gre) strs + let doc = foldl' docAppend DocEmpty docs case doc of DocEmpty -> return Nothing _ -> return (Just doc) -lexParseRnHaddockComment :: DynFlags -> HaddockCommentType -> - GlobalRdrEnv -> HsDocString -> ErrMsgM (Maybe (Doc Name)) -lexParseRnHaddockComment dflags hty gre (HsDocString fs) = do +processDocStringParas :: DynFlags -> GlobalRdrEnv -> HsDocString -> ErrMsgM (Maybe (Doc Name)) +processDocStringParas = process parseParas + + +processDocString :: DynFlags -> GlobalRdrEnv -> HsDocString -> ErrMsgM (Maybe (Doc Name)) +processDocString = process parseString + +process :: ([LToken] -> Maybe (Doc RdrName)) + -> DynFlags + -> GlobalRdrEnv + -> HsDocString + -> ErrMsgM (Maybe (Doc Name)) +process parse dflags gre (HsDocString fs) = do let str = unpackFS fs - let toks = tokenise dflags str (0,0) -- TODO: real position - let parse = case hty of - NormalHaddockComment -> parseParas - DocSectionComment -> parseString + let toks = tokenise dflags str (0,0) -- TODO: real position case parse toks of Nothing -> do - tell ["doc comment parse failed: "++str] + tell [ "doc comment parse failed: " ++ str ] return Nothing - Just doc -> return (Just (rename gre doc)) - + Just doc -> return (Just (rename dflags gre doc)) -lexParseRnMbHaddockComment :: DynFlags -> HaddockCommentType -> GlobalRdrEnv -> Maybe HsDocString -> ErrMsgM (Maybe (Doc Name)) -lexParseRnMbHaddockComment _ _ _ Nothing = return Nothing -lexParseRnMbHaddockComment dflags hty gre (Just d) = lexParseRnHaddockComment dflags hty gre d +processModuleHeader :: DynFlags -> GlobalRdrEnv -> SafeHaskellMode -> Maybe LHsDocString + -> ErrMsgM (HaddockModInfo Name, Maybe (Doc Name)) +processModuleHeader dflags gre safety mayStr = do + (hmi, doc) <- + case mayStr of --- yes, you always get a HaddockModInfo though it might be empty -lexParseRnHaddockModHeader :: DynFlags -> GlobalRdrEnv -> GhcDocHdr -> ErrMsgM (HaddockModInfo Name, Maybe (Doc Name)) -lexParseRnHaddockModHeader dflags gre mbStr = do - (hmi, docn) <- - case mbStr of Nothing -> return failure Just (L _ (HsDocString fs)) -> do let str = unpackFS fs case parseModuleHeader dflags str of - Left mess -> do - tell ["haddock module header parse failed: " ++ mess] + Left msg -> do + tell ["haddock module header parse failed: " ++ msg] return failure - Right (info, doc) -> return (renameHmi gre info, Just (rename gre doc)) - return (hmi { hmi_safety = safety }, docn) + Right (hmi, doc) -> do + let !descr = rename dflags gre <$> hmi_description hmi + hmi' = hmi { hmi_description = descr } + doc' = rename dflags gre doc + return (hmi', Just doc') + return (hmi { hmi_safety = Just $ showPpr dflags safety }, doc) where - safety = Just $ showPpr $ safeHaskell dflags failure = (emptyHaddockModInfo, Nothing) -renameHmi :: GlobalRdrEnv -> HaddockModInfo RdrName -> HaddockModInfo Name -renameHmi gre hmi = hmi { hmi_description = rename gre <$> hmi_description hmi } - - -rename :: GlobalRdrEnv -> Doc RdrName -> Doc Name -rename gre = rn +rename :: DynFlags -> GlobalRdrEnv -> Doc RdrName -> Doc Name +rename dflags gre = rn where rn d = case d of DocAppend a b -> DocAppend (rn a) (rn b) @@ -101,13 +101,15 @@ rename gre = rn case names of [] -> case choices of - [] -> DocMonospaced (DocString (showSDoc $ ppr x)) - [a] -> outOfScope a - a:b:_ | isRdrTc a -> outOfScope a | otherwise -> outOfScope b + [] -> DocMonospaced (DocString (showPpr dflags x)) + [a] -> outOfScope dflags a + a:b:_ | isRdrTc a -> outOfScope dflags a + | otherwise -> outOfScope dflags b [a] -> DocIdentifier a a:b:_ | isTyConName a -> DocIdentifier a | otherwise -> DocIdentifier b -- If an id can refer to multiple things, we give precedence to type -- constructors. + DocWarning doc -> DocWarning (rn doc) DocEmphasis doc -> DocEmphasis (rn doc) DocMonospaced doc -> DocMonospaced (rn doc) DocUnorderedList docs -> DocUnorderedList (map rn docs) @@ -116,7 +118,7 @@ rename gre = rn DocCodeBlock doc -> DocCodeBlock (rn doc) DocIdentifierUnchecked x -> DocIdentifierUnchecked x DocModule str -> DocModule str - DocURL str -> DocURL str + DocHyperlink l -> DocHyperlink l DocPic str -> DocPic str DocAName str -> DocAName str DocExamples e -> DocExamples e @@ -124,12 +126,12 @@ rename gre = rn DocString str -> DocString str -outOfScope :: RdrName -> Doc a -outOfScope x = +outOfScope :: DynFlags -> RdrName -> Doc a +outOfScope dflags x = case x of Unqual occ -> monospaced occ Qual mdl occ -> DocIdentifierUnchecked (mdl, occ) Orig _ occ -> monospaced occ Exact name -> monospaced name -- Shouldn't happen since x is out of scope where - monospaced a = DocMonospaced (DocString (showSDoc $ ppr a)) + monospaced a = DocMonospaced (DocString (showPpr dflags a)) diff --git a/src/Haddock/Interface/ParseModuleHeader.hs b/src/Haddock/Interface/ParseModuleHeader.hs index 35533d0d..18f4c768 100644 --- a/src/Haddock/Interface/ParseModuleHeader.hs +++ b/src/Haddock/Interface/ParseModuleHeader.hs @@ -1,3 +1,4 @@ +{-# OPTIONS_GHC -Wwarn #-} ----------------------------------------------------------------------------- -- | -- Module : Haddock.Interface.ParseModuleHeader @@ -137,14 +138,14 @@ parseKey key toParse0 = (spaces1,cs1) = extractLeadingSpaces cs in (c:spaces1,cs1) - | True = ([],s) + | otherwise = ([],s) extractNextLine :: String -> (String,String) extractNextLine [] = ([],[]) extractNextLine (c:cs) | c == '\n' = ([],cs) - | True = + | otherwise = let (line,rest) = extractNextLine cs in @@ -156,5 +157,5 @@ parseKey key toParse0 = extractPrefix _ [] = Nothing extractPrefix (c1:cs1) (c2:cs2) | toUpper c1 == toUpper c2 = extractPrefix cs1 cs2 - | True = Nothing + | otherwise = Nothing diff --git a/src/Haddock/Interface/Rename.hs b/src/Haddock/Interface/Rename.hs index 691dafbc..0f702683 100644 --- a/src/Haddock/Interface/Rename.hs +++ b/src/Haddock/Interface/Rename.hs @@ -12,23 +12,23 @@ module Haddock.Interface.Rename (renameInterface) where -import Haddock.Types import Haddock.GhcUtils +import Haddock.Types +import Bag (emptyBag) import GHC hiding (NoLink) import Name -import Bag (emptyBag) -import BasicTypes ( IPName(..), ipNameName ) +import Control.Applicative +import Control.Monad hiding (mapM) import Data.List import qualified Data.Map as Map hiding ( Map ) -import Prelude hiding (mapM) import Data.Traversable (mapM) -import Control.Monad hiding (mapM) +import Prelude hiding (mapM) -renameInterface :: LinkEnv -> Bool -> Interface -> ErrMsgM Interface -renameInterface renamingEnv warnings iface = +renameInterface :: DynFlags -> LinkEnv -> Bool -> Interface -> ErrMsgM Interface +renameInterface dflags renamingEnv warnings iface = -- first create the local env, where every name exported by this module -- is mapped to itself, and everything else comes from the global renaming @@ -46,7 +46,7 @@ renameInterface renamingEnv warnings iface = (rnArgMap, missingNames3) = runRnFM localEnv (mapM (mapM renameDoc) (ifaceArgMap iface)) (finalModuleDoc, missingNames4) - = runRnFM localEnv (renameMaybeDoc (ifaceDoc iface)) + = runRnFM localEnv (renameDocumentation (ifaceDoc iface)) -- combine the missing names and filter out the built-ins, which would -- otherwise allways be missing. @@ -57,7 +57,7 @@ renameInterface renamingEnv warnings iface = -- representation. TODO: use the Name constants from the GHC API. -- strings = filter (`notElem` ["()", "[]", "(->)"]) -- (map pretty missingNames) - strings = map pretty . filter (\n -> not (isSystemName n || isBuiltInSyntax n)) $ missingNames + strings = map (pretty dflags) . filter (\n -> not (isSystemName n || isBuiltInSyntax n)) $ missingNames in do -- report things that we couldn't link to. Only do this for non-hidden @@ -93,6 +93,13 @@ instance Monad (GenRnM n) where (>>=) = thenRn return = returnRn +instance Functor (GenRnM n) where + fmap f x = do a <- x; return (f a) + +instance Applicative (GenRnM n) where + pure = return + (<*>) = ap + returnRn :: a -> GenRnM n a returnRn a = RnM (const (a,[])) thenRn :: GenRnM n a -> (a -> GenRnM n b) -> GenRnM n b @@ -138,15 +145,14 @@ renameExportItems :: [ExportItem Name] -> RnM [ExportItem DocName] renameExportItems = mapM renameExportItem -renameDocForDecl :: (Maybe (Doc Name), FnArgsDoc Name) -> RnM (Maybe (Doc DocName), FnArgsDoc DocName) -renameDocForDecl (mbDoc, fnArgsDoc) = do - mbDoc' <- renameMaybeDoc mbDoc - fnArgsDoc' <- renameFnArgsDoc fnArgsDoc - return (mbDoc', fnArgsDoc') +renameDocForDecl :: DocForDecl Name -> RnM (DocForDecl DocName) +renameDocForDecl (doc, fnArgsDoc) = + (,) <$> renameDocumentation doc <*> renameFnArgsDoc fnArgsDoc -renameMaybeDoc :: Maybe (Doc Name) -> RnM (Maybe (Doc DocName)) -renameMaybeDoc = mapM renameDoc +renameDocumentation :: Documentation Name -> RnM (Documentation DocName) +renameDocumentation (Documentation mDoc mWarning) = + Documentation <$> mapM renameDoc mDoc <*> mapM renameDoc mWarning renameLDocHsSyn :: LHsDocString -> RnM LHsDocString @@ -169,6 +175,9 @@ renameDoc d = case d of return (DocIdentifier x') DocIdentifierUnchecked x -> return (DocIdentifierUnchecked x) DocModule str -> return (DocModule str) + DocWarning doc -> do + doc' <- renameDoc doc + return (DocWarning doc') DocEmphasis doc -> do doc' <- renameDoc doc return (DocEmphasis doc') @@ -190,7 +199,7 @@ renameDoc d = case d of DocCodeBlock doc -> do doc' <- renameDoc doc return (DocCodeBlock doc') - DocURL str -> return (DocURL str) + DocHyperlink l -> return (DocHyperlink l) DocPic str -> return (DocPic str) DocAName str -> return (DocAName str) DocExamples e -> return (DocExamples e) @@ -206,14 +215,17 @@ renameLType = mapM renameType renameLKind :: LHsKind Name -> RnM (LHsKind DocName) renameLKind = renameLType -renameMaybeLKind :: Maybe (LHsKind Name) -> RnM (Maybe (LHsKind DocName)) +renameMaybeLKind :: Maybe (LHsKind Name) + -> RnM (Maybe (LHsKind DocName)) renameMaybeLKind Nothing = return Nothing -renameMaybeLKind (Just ki) = renameLKind ki >>= return . Just +renameMaybeLKind (Just ki) + = do { ki' <- renameLKind ki + ; return (Just ki') } renameType :: HsType Name -> RnM (HsType DocName) renameType t = case t of HsForAllTy expl tyvars lcontext ltype -> do - tyvars' <- mapM renameLTyVarBndr tyvars + tyvars' <- renameLTyVarBndrs tyvars lcontext' <- renameLContext lcontext ltype' <- renameLType ltype return (HsForAllTy expl tyvars' lcontext' ltype') @@ -233,16 +245,16 @@ renameType t = case t of HsListTy ty -> return . HsListTy =<< renameLType ty HsPArrTy ty -> return . HsPArrTy =<< renameLType ty - HsIParamTy n ty -> liftM2 HsIParamTy (liftM IPName (rename (ipNameName n))) (renameLType ty) + HsIParamTy n ty -> liftM (HsIParamTy n) (renameLType ty) HsEqTy ty1 ty2 -> liftM2 HsEqTy (renameLType ty1) (renameLType ty2) HsTupleTy b ts -> return . HsTupleTy b =<< mapM renameLType ts - HsOpTy a (w, (L loc op)) b -> do + HsOpTy a (w, L loc op) b -> do op' <- rename op a' <- renameLType a b' <- renameLType b - return (HsOpTy a' (w, (L loc op')) b') + return (HsOpTy a' (w, L loc op') b') HsParTy ty -> return . HsParTy =<< renameLType ty @@ -256,15 +268,25 @@ renameType t = case t of doc' <- renameLDocHsSyn doc return (HsDocTy ty' doc') + HsTyLit x -> return (HsTyLit x) + _ -> error "renameType" -renameLTyVarBndr :: LHsTyVarBndr Name -> RnM (LHsTyVarBndr DocName) -renameLTyVarBndr (L loc tv) = do - name' <- rename (hsTyVarName tv) - tyvar' <- replaceTyVarName tv name' renameLKind - return $ L loc tyvar' +renameLTyVarBndrs :: LHsTyVarBndrs Name -> RnM (LHsTyVarBndrs DocName) +renameLTyVarBndrs (HsQTvs { hsq_kvs = _, hsq_tvs = tvs }) + = do { tvs' <- mapM renameLTyVarBndr tvs + ; return (HsQTvs { hsq_kvs = error "haddock:renameLTyVarBndrs", hsq_tvs = tvs' }) } + -- This is rather bogus, but I'm not sure what else to do +renameLTyVarBndr :: LHsTyVarBndr Name -> RnM (LHsTyVarBndr DocName) +renameLTyVarBndr (L loc (UserTyVar n)) + = do { n' <- rename n + ; return (L loc (UserTyVar n')) } +renameLTyVarBndr (L loc (KindedTyVar n k)) + = do { n' <- rename n + ; k' <- renameLKind k + ; return (L loc (KindedTyVar n' k')) } renameLContext :: Located [LHsType Name] -> RnM (Located [LHsType DocName]) renameLContext (L loc context) = do @@ -314,54 +336,67 @@ renameTyClD d = case d of -- TyFamily flav lname ltyvars kind tckind -> do TyFamily flav lname ltyvars tckind -> do lname' <- renameL lname - ltyvars' <- mapM renameLTyVarBndr ltyvars + ltyvars' <- renameLTyVarBndrs ltyvars -- kind' <- renameMaybeLKind kind tckind' <- renameMaybeLKind tckind -- return (TyFamily flav lname' ltyvars' kind' tckind) return (TyFamily flav lname' ltyvars' tckind') - TyData x lcontext lname ltyvars typats k cons _ -> do - lcontext' <- renameLContext lcontext + TyDecl { tcdLName = lname, tcdTyVars = tyvars, tcdTyDefn = defn, tcdFVs = fvs } -> do lname' <- renameL lname - ltyvars' <- mapM renameLTyVarBndr ltyvars - typats' <- mapM (mapM renameLType) typats - k' <- renameMaybeLKind k - cons' <- mapM renameLCon cons - -- I don't think we need the derivings, so we return Nothing - return (TyData x lcontext' lname' ltyvars' typats' k' cons' Nothing) + tyvars' <- renameLTyVarBndrs tyvars + defn' <- renameTyDefn defn + return (TyDecl { tcdLName = lname', tcdTyVars = tyvars', tcdTyDefn = defn', tcdFVs = fvs }) - TySynonym lname ltyvars typats ltype -> do - lname' <- renameL lname - ltyvars' <- mapM renameLTyVarBndr ltyvars - ltype' <- renameLType ltype - typats' <- mapM (mapM renameLType) typats - return (TySynonym lname' ltyvars' typats' ltype') - - ClassDecl lcontext lname ltyvars lfundeps lsigs _ ats at_defs _ -> do + ClassDecl { tcdCtxt = lcontext, tcdLName = lname, tcdTyVars = ltyvars + , tcdFDs = lfundeps, tcdSigs = lsigs, tcdATs = ats, tcdATDefs = at_defs } -> do lcontext' <- renameLContext lcontext lname' <- renameL lname - ltyvars' <- mapM renameLTyVarBndr ltyvars + ltyvars' <- renameLTyVarBndrs ltyvars lfundeps' <- mapM renameLFunDep lfundeps lsigs' <- mapM renameLSig lsigs ats' <- mapM renameLTyClD ats - at_defs' <- mapM renameLTyClD at_defs + at_defs' <- mapM (mapM renameFamInstD) at_defs -- we don't need the default methods or the already collected doc entities - return (ClassDecl lcontext' lname' ltyvars' lfundeps' lsigs' emptyBag ats' at_defs' []) + return (ClassDecl { tcdCtxt = lcontext', tcdLName = lname', tcdTyVars = ltyvars' + , tcdFDs = lfundeps', tcdSigs = lsigs', tcdMeths= emptyBag + , tcdATs = ats', tcdATDefs = at_defs', tcdDocs = [], tcdFVs = placeHolderNames }) where - renameLCon (L loc con) = return . L loc =<< renameCon con - renameCon decl@(ConDecl { con_name = lname, con_qvars = ltyvars - , con_cxt = lcontext, con_details = details - , con_res = restype, con_doc = mbldoc }) = do + renameLFunDep (L loc (xs, ys)) = do + xs' <- mapM rename xs + ys' <- mapM rename ys + return (L loc (xs', ys')) + + renameLSig (L loc sig) = return . L loc =<< renameSig sig + +renameTyDefn :: HsTyDefn Name -> RnM (HsTyDefn DocName) +renameTyDefn (TyData { td_ND = nd, td_ctxt = lcontext, td_cType = cType + , td_kindSig = k, td_cons = cons }) = do + lcontext' <- renameLContext lcontext + k' <- renameMaybeLKind k + cons' <- mapM (mapM renameCon) cons + -- I don't think we need the derivings, so we return Nothing + return (TyData { td_ND = nd, td_ctxt = lcontext', td_cType = cType + , td_kindSig = k', td_cons = cons', td_derivs = Nothing }) + +renameTyDefn (TySynonym { td_synRhs = ltype }) = do + ltype' <- renameLType ltype + return (TySynonym { td_synRhs = ltype' }) + +renameCon :: ConDecl Name -> RnM (ConDecl DocName) +renameCon decl@(ConDecl { con_name = lname, con_qvars = ltyvars + , con_cxt = lcontext, con_details = details + , con_res = restype, con_doc = mbldoc }) = do lname' <- renameL lname - ltyvars' <- mapM renameLTyVarBndr ltyvars + ltyvars' <- renameLTyVarBndrs ltyvars lcontext' <- renameLContext lcontext details' <- renameDetails details restype' <- renameResType restype mbldoc' <- mapM renameLDocHsSyn mbldoc return (decl { con_name = lname', con_qvars = ltyvars', con_cxt = lcontext' , con_details = details', con_res = restype', con_doc = mbldoc' }) - + where renameDetails (RecCon fields) = return . RecCon =<< mapM renameField fields renameDetails (PrefixCon ps) = return . PrefixCon =<< mapM renameLType ps renameDetails (InfixCon a b) = do @@ -378,14 +413,6 @@ renameTyClD d = case d of renameResType (ResTyH98) = return ResTyH98 renameResType (ResTyGADT t) = return . ResTyGADT =<< renameLType t - renameLFunDep (L loc (xs, ys)) = do - xs' <- mapM rename xs - ys' <- mapM rename ys - return (L loc (xs', ys')) - - renameLSig (L loc sig) = return . L loc =<< renameSig sig - - renameSig :: Sig Name -> RnM (Sig DocName) renameSig sig = case sig of TypeSig lnames ltype -> do @@ -408,10 +435,23 @@ renameForD (ForeignExport lname ltype co x) = do renameInstD :: InstDecl Name -> RnM (InstDecl DocName) -renameInstD (InstDecl ltype _ _ lATs) = do +renameInstD (ClsInstD { cid_poly_ty =ltype, cid_fam_insts = lATs }) = do ltype' <- renameLType ltype - lATs' <- mapM renameLTyClD lATs - return (InstDecl ltype' emptyBag [] lATs') + lATs' <- mapM (mapM renameFamInstD) lATs + return (ClsInstD { cid_poly_ty = ltype', cid_binds = emptyBag, cid_sigs = [] + , cid_fam_insts = lATs' }) + +renameInstD (FamInstD { lid_inst = d }) = do + d' <- renameFamInstD d + return (FamInstD { lid_inst = d' }) + +renameFamInstD :: FamInstDecl Name -> RnM (FamInstDecl DocName) +renameFamInstD (FamInstDecl { fid_tycon = tc, fid_pats = pats_w_bndrs, fid_defn = defn }) + = do { tc' <- renameL tc + ; pats' <- mapM renameLType (hswb_cts pats_w_bndrs) + ; defn' <- renameTyDefn defn + ; return (FamInstDecl { fid_tycon = tc', fid_pats = pats_w_bndrs { hswb_cts = pats' } + , fid_defn = defn', fid_fvs = placeHolderNames }) } renameExportItem :: ExportItem Name -> RnM (ExportItem DocName) diff --git a/src/Haddock/InterfaceFile.hs b/src/Haddock/InterfaceFile.hs index fcf7fe65..8fa8ce95 100644 --- a/src/Haddock/InterfaceFile.hs +++ b/src/Haddock/InterfaceFile.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE CPP, RankNTypes, ScopedTypeVariables #-} {-# OPTIONS_GHC -fno-warn-orphans #-} ----------------------------------------------------------------------------- -- | @@ -22,24 +22,25 @@ module Haddock.InterfaceFile ( import Haddock.Types import Haddock.Utils hiding (out) -import Data.List -import Data.Word +import Control.Monad import Data.Array import Data.IORef +import Data.List import qualified Data.Map as Map import Data.Map (Map) +import Data.Word -import GHC hiding (NoLink) -import Binary import BinIface (getSymtabName, getDictFastString) -import Name -import UniqSupply -import UniqFM -import IfaceEnv -import HscTypes -import GhcMonad (withSession) +import Binary import FastMutInt import FastString +import GHC hiding (NoLink) +import GhcMonad (withSession) +import HscTypes +import IfaceEnv +import Name +import UniqFM +import UniqSupply import Unique @@ -65,13 +66,15 @@ binaryInterfaceMagic = 0xD0Cface -- we version our interface files accordingly. binaryInterfaceVersion :: Word16 #if __GLASGOW_HASKELL__ == 702 -binaryInterfaceVersion = 19 +binaryInterfaceVersion = 21 #elif __GLASGOW_HASKELL__ == 703 -binaryInterfaceVersion = 19 +binaryInterfaceVersion = 21 #elif __GLASGOW_HASKELL__ == 704 -binaryInterfaceVersion = 19 +binaryInterfaceVersion = 21 #elif __GLASGOW_HASKELL__ == 705 -binaryInterfaceVersion = 19 +binaryInterfaceVersion = 21 +#elif __GLASGOW_HASKELL__ == 706 +binaryInterfaceVersion = 21 #else #error Unknown GHC version #endif @@ -110,8 +113,8 @@ writeInterfaceFile filename iface = do bin_dict_map = dict_map_ref } -- put the main thing - bh <- return $ setUserData bh0 $ newWriteState (putName bin_symtab) - (putFastString bin_dict) + let bh = setUserData bh0 $ newWriteState (putName bin_symtab) + (putFastString bin_dict) put_ bh iface -- write the symtab pointer at the front of the file @@ -295,12 +298,9 @@ putSymbolTable bh next_off symtab = do getSymbolTable :: BinHandle -> NameCache -> IO (NameCache, Array Int Name) getSymbolTable bh namecache = do sz <- get bh - od_names <- sequence (replicate sz (get bh)) - let - arr = listArray (0,sz-1) names - (namecache', names) = - mapAccumR (fromOnDiskName arr) namecache od_names - -- + od_names <- replicateM sz (get bh) + let arr = listArray (0,sz-1) names + (namecache', names) = mapAccumR (fromOnDiskName arr) namecache od_names return (namecache', arr) @@ -415,6 +415,15 @@ instance Binary Example where result <- get bh return (Example expression result) +instance Binary Hyperlink where + put_ bh (Hyperlink url label) = do + put_ bh url + put_ bh label + get bh = do + url <- get bh + label <- get bh + return (Hyperlink url label) + {-* Generated by DrIFT : Look, but Don't Touch. *-} instance (Binary id) => Binary (Doc id) where @@ -454,7 +463,7 @@ instance (Binary id) => Binary (Doc id) where put_ bh (DocCodeBlock al) = do putByte bh 11 put_ bh al - put_ bh (DocURL am) = do + put_ bh (DocHyperlink am) = do putByte bh 12 put_ bh am put_ bh (DocPic x) = do @@ -469,6 +478,9 @@ instance (Binary id) => Binary (Doc id) where put_ bh (DocIdentifierUnchecked x) = do putByte bh 16 put_ bh x + put_ bh (DocWarning ag) = do + putByte bh 17 + put_ bh ag get bh = do h <- getByte bh case h of @@ -510,7 +522,7 @@ instance (Binary id) => Binary (Doc id) where return (DocCodeBlock al) 12 -> do am <- get bh - return (DocURL am) + return (DocHyperlink am) 13 -> do x <- get bh return (DocPic x) @@ -523,6 +535,9 @@ instance (Binary id) => Binary (Doc id) where 16 -> do x <- get bh return (DocIdentifierUnchecked x) + 17 -> do + ag <- get bh + return (DocWarning ag) _ -> fail "invalid binary data found" diff --git a/src/Haddock/Lex.x b/src/Haddock/Lex.x index f65aee8c..b9ebe688 100644 --- a/src/Haddock/Lex.x +++ b/src/Haddock/Lex.x @@ -34,6 +34,7 @@ import Data.Char import Data.Word (Word8) import Numeric import System.IO.Unsafe +import Debug.Trace } $ws = $white # \n @@ -181,7 +182,7 @@ tokenise dflags str (line, col) = let toks = go (posn, '\n', eofHack str) para i go inp@(pos, _, str) sc = case alexScan inp sc of AlexEOF -> [] - AlexError _ -> error "lexical error" + AlexError _ -> [] AlexSkip inp' _ -> go inp' sc AlexToken inp'@(pos',_,_) len act -> act pos (take len str) sc (\sc -> go inp' sc) dflags diff --git a/src/Haddock/Options.hs b/src/Haddock/Options.hs index 4e42fd32..46f9def7 100644 --- a/src/Haddock/Options.hs +++ b/src/Haddock/Options.hs @@ -126,7 +126,7 @@ options backwardsCompat = Option ['t'] ["title"] (ReqArg Flag_Heading "TITLE") "page heading", Option ['q'] ["qual"] (ReqArg Flag_Qualification "QUAL") - "qualification of names, one of \n'none' (default), 'full', 'local'\nor 'relative'", + "qualification of names, one of \n'none' (default), 'full', 'local'\n'relative' or 'aliased'", Option ['?'] ["help"] (NoArg Flag_Help) "display this help and exit", Option ['V'] ["version"] (NoArg Flag_Version) @@ -229,13 +229,17 @@ optLaTeXStyle :: [Flag] -> Maybe String optLaTeXStyle flags = optLast [ str | Flag_LaTeXStyle str <- flags ] -qualification :: [Flag] -> Qualification +qualification :: [Flag] -> Either String QualOption qualification flags = case map (map Char.toLower) [ str | Flag_Qualification str <- flags ] of - "full":_ -> FullQual - "local":_ -> LocalQual Nothing - "relative":_ -> RelativeQual Nothing - _ -> NoQual + [] -> Right OptNoQual + ["none"] -> Right OptNoQual + ["full"] -> Right OptFullQual + ["local"] -> Right OptLocalQual + ["relative"] -> Right OptRelativeQual + ["aliased"] -> Right OptAliasedQual + [arg] -> Left $ "unknown qualification type " ++ show arg + _:_ -> Left "qualification option given multiple times" verbosity :: [Flag] -> Verbosity diff --git a/src/Haddock/Parse.y b/src/Haddock/Parse.y index e36e8416..b34b14b9 100644 --- a/src/Haddock/Parse.y +++ b/src/Haddock/Parse.y @@ -10,7 +10,7 @@ module Haddock.Parse where import Haddock.Lex -import Haddock.Types (Doc(..), Example(Example)) +import Haddock.Types (Doc(..), Example(Example), Hyperlink(..)) import Haddock.Doc import HsSyn import RdrName @@ -107,7 +107,7 @@ seq1 :: { Doc RdrName } elem1 :: { Doc RdrName } : STRING { DocString $1 } | '/../' { DocEmphasis (DocString $1) } - | URL { DocURL $1 } + | URL { DocHyperlink (makeHyperlink $1) } | PIC { DocPic $1 } | ANAME { DocAName $1 } | IDENT { DocIdentifier $1 } @@ -121,6 +121,15 @@ strings :: { String } happyError :: [LToken] -> Maybe a happyError toks = Nothing +-- | Create a `Hyperlink` from given string. +-- +-- A hyperlink consists of a URL and an optional label. The label is separated +-- from the url by one or more whitespace characters. +makeHyperlink :: String -> Hyperlink +makeHyperlink input = case break isSpace $ strip input of + (url, "") -> Hyperlink url Nothing + (url, label) -> Hyperlink url (Just . dropWhile isSpace $ label) + -- | Create an 'Example', stripping superfluous characters as appropriate makeExample :: String -> String -> [String] -> Example makeExample prompt expression result = diff --git a/src/Haddock/Types.hs b/src/Haddock/Types.hs index a3a7db15..fbd05fae 100644 --- a/src/Haddock/Types.hs +++ b/src/Haddock/Types.hs @@ -24,6 +24,7 @@ import Control.Exception import Control.Arrow import Data.Typeable import Data.Map (Map) +import Data.Maybe import qualified Data.Map as Map import Data.Monoid import GHC hiding (NoLink) @@ -42,7 +43,6 @@ type ArgMap a = Map Name (Map Int (Doc a)) type SubMap = Map Name [Name] type DeclMap = Map Name [LHsDecl Name] type SrcMap = Map PackageId FilePath -type GhcDocHdr = Maybe LHsDocString type DocPaths = (FilePath, Maybe FilePath) -- paths to HTML and sources @@ -59,19 +59,19 @@ type DocPaths = (FilePath, Maybe FilePath) -- paths to HTML and sources data Interface = Interface { -- | The module behind this interface. - ifaceMod :: Module + ifaceMod :: !Module -- | Original file name of the module. - , ifaceOrigFilename :: FilePath + , ifaceOrigFilename :: !FilePath -- | Textual information about the module. , ifaceInfo :: !(HaddockModInfo Name) -- | Documentation header. - , ifaceDoc :: !(Maybe (Doc Name)) + , ifaceDoc :: !(Documentation Name) -- | Documentation header with cross-reference information. - , ifaceRnDoc :: Maybe (Doc DocName) + , ifaceRnDoc :: !(Documentation DocName) -- | Haddock options for this module (prune, ignore-exports, etc). , ifaceOptions :: ![DocOption] @@ -79,22 +79,22 @@ data Interface = Interface -- | Declarations originating from the module. Excludes declarations without -- names (instances and stand-alone documentation comments). Includes -- names of subordinate declarations mapped to their parent declarations. - , ifaceDeclMap :: Map Name [LHsDecl Name] + , ifaceDeclMap :: !(Map Name [LHsDecl Name]) -- | Documentation of declarations originating from the module (including -- subordinates). - , ifaceDocMap :: DocMap Name - , ifaceArgMap :: ArgMap Name + , ifaceDocMap :: !(DocMap Name) + , ifaceArgMap :: !(ArgMap Name) -- | Documentation of declarations originating from the module (including -- subordinates). - , ifaceRnDocMap :: DocMap DocName - , ifaceRnArgMap :: ArgMap DocName + , ifaceRnDocMap :: !(DocMap DocName) + , ifaceRnArgMap :: !(ArgMap DocName) - , ifaceSubMap :: Map Name [Name] + , ifaceSubMap :: !(Map Name [Name]) , ifaceExportItems :: ![ExportItem Name] - , ifaceRnExportItems :: [ExportItem DocName] + , ifaceRnExportItems :: ![ExportItem DocName] -- | All names exported by the module. , ifaceExports :: ![Name] @@ -104,12 +104,15 @@ data Interface = Interface -- module. , ifaceVisibleExports :: ![Name] + -- | Aliases of module imports as in @import A.B.C as C@. + , ifaceModuleAliases :: !AliasMap + -- | Instances exported by the module. - , ifaceInstances :: ![Instance] + , ifaceInstances :: ![ClsInst] -- | The number of haddockable and haddocked items in the module, as a -- tuple. Haddockable items are the exports and the module itself. - , ifaceHaddockCoverage :: (Int,Int) + , ifaceHaddockCoverage :: !(Int, Int) } @@ -169,62 +172,72 @@ data ExportItem name = ExportDecl { -- | A declaration. - expItemDecl :: LHsDecl name + expItemDecl :: !(LHsDecl name) -- | Maybe a doc comment, and possibly docs for arguments (if this -- decl is a function or type-synonym). - , expItemMbDoc :: DocForDecl name + , expItemMbDoc :: !(DocForDecl name) -- | Subordinate names, possibly with documentation. - , expItemSubDocs :: [(name, DocForDecl name)] + , expItemSubDocs :: ![(name, DocForDecl name)] -- | Instances relevant to this declaration, possibly with -- documentation. - , expItemInstances :: [DocInstance name] + , expItemInstances :: ![DocInstance name] } -- | An exported entity for which we have no documentation (perhaps because it -- resides in another package). | ExportNoDecl - { expItemName :: name + { expItemName :: !name -- | Subordinate names. - , expItemSubs :: [name] + , expItemSubs :: ![name] } -- | A section heading. | ExportGroup { -- | Section level (1, 2, 3, ...). - expItemSectionLevel :: Int + expItemSectionLevel :: !Int -- | Section id (for hyperlinks). - , expItemSectionId :: String + , expItemSectionId :: !String -- | Section heading text. - , expItemSectionText :: Doc name + , expItemSectionText :: !(Doc name) } -- | Some documentation. - | ExportDoc (Doc name) + | ExportDoc !(Doc name) -- | A cross-reference to another module. - | ExportModule Module + | ExportModule !Module + +data Documentation name = Documentation + { documentationDoc :: Maybe (Doc name) + , documentationWarning :: !(Maybe (Doc name)) + } deriving Functor + + +combineDocumentation :: Documentation name -> Maybe (Doc name) +combineDocumentation (Documentation Nothing Nothing) = Nothing +combineDocumentation (Documentation mDoc mWarning) = Just (fromMaybe mempty mWarning `mappend` fromMaybe mempty mDoc) -- | Arguments and result are indexed by Int, zero-based from the left, -- because that's the easiest to use when recursing over types. type FnArgsDoc name = Map Int (Doc name) -type DocForDecl name = (Maybe (Doc name), FnArgsDoc name) +type DocForDecl name = (Documentation name, FnArgsDoc name) noDocForDecl :: DocForDecl name -noDocForDecl = (Nothing, Map.empty) +noDocForDecl = (Documentation Nothing Nothing, Map.empty) unrenameDocForDecl :: DocForDecl DocName -> DocForDecl Name -unrenameDocForDecl (mbDoc, fnArgsDoc) = - (fmap unrenameDoc mbDoc, fmap unrenameDoc fnArgsDoc) +unrenameDocForDecl (doc, fnArgsDoc) = + (fmap getName doc, (fmap . fmap) getName fnArgsDoc) ----------------------------------------------------------------------------- @@ -283,13 +296,14 @@ data Doc id | DocIdentifier id | DocIdentifierUnchecked (ModuleName, OccName) | DocModule String + | DocWarning (Doc id) | DocEmphasis (Doc id) | DocMonospaced (Doc id) | DocUnorderedList [Doc id] | DocOrderedList [Doc id] | DocDefList [(Doc id, Doc id)] | DocCodeBlock (Doc id) - | DocURL String + | DocHyperlink Hyperlink | DocPic String | DocAName String | DocExamples [Example] @@ -301,8 +315,10 @@ instance Monoid (Doc id) where mappend = DocAppend -unrenameDoc :: Doc DocName -> Doc Name -unrenameDoc = fmap getName +data Hyperlink = Hyperlink + { hyperlinkUrl :: String + , hyperlinkLabel :: Maybe String + } deriving (Eq, Show) data Example = Example @@ -324,13 +340,14 @@ data DocMarkup id a = Markup , markupIdentifier :: id -> a , markupIdentifierUnchecked :: (ModuleName, OccName) -> a , markupModule :: String -> a + , markupWarning :: a -> a , markupEmphasis :: a -> a , markupMonospaced :: a -> a , markupUnorderedList :: [a] -> a , markupOrderedList :: [a] -> a , markupDefList :: [(a,a)] -> a , markupCodeBlock :: a -> a - , markupURL :: String -> a + , markupHyperlink :: Hyperlink -> a , markupAName :: String -> a , markupPic :: String -> a , markupExample :: [Example] -> a @@ -338,11 +355,11 @@ data DocMarkup id a = Markup data HaddockModInfo name = HaddockModInfo - { hmi_description :: Maybe (Doc name) - , hmi_portability :: Maybe String - , hmi_stability :: Maybe String - , hmi_maintainer :: Maybe String - , hmi_safety :: Maybe String + { hmi_description :: (Maybe (Doc name)) + , hmi_portability :: (Maybe String) + , hmi_stability :: (Maybe String) + , hmi_maintainer :: (Maybe String) + , hmi_safety :: (Maybe String) } @@ -373,12 +390,44 @@ data DocOption -- | Option controlling how to qualify names +data QualOption + = OptNoQual -- ^ Never qualify any names. + | OptFullQual -- ^ Qualify all names fully. + | OptLocalQual -- ^ Qualify all imported names fully. + | OptRelativeQual -- ^ Like local, but strip module prefix + -- from modules in the same hierarchy. + | OptAliasedQual -- ^ Uses aliases of module names + -- as suggested by module import renamings. + -- However, we are unfortunately not able + -- to maintain the original qualifications. + -- Image a re-export of a whole module, + -- how could the re-exported identifiers be qualified? + +type AliasMap = Map Module ModuleName + data Qualification - = NoQual -- ^ Never qualify any names. - | FullQual -- ^ Qualify all names fully. - | LocalQual (Maybe Module) -- ^ Qualify all imported names fully. - | RelativeQual (Maybe Module) -- ^ Like local, but strip module prefix. - -- from modules in the same hierarchy. + = NoQual + | FullQual + | LocalQual Module + | RelativeQual Module + | AliasedQual AliasMap Module + -- ^ @Module@ contains the current module. + -- This way we can distinguish imported and local identifiers. + +makeContentsQual :: QualOption -> Qualification +makeContentsQual qual = + case qual of + OptNoQual -> NoQual + _ -> FullQual + +makeModuleQual :: QualOption -> AliasMap -> Module -> Qualification +makeModuleQual qual aliases mdl = + case qual of + OptLocalQual -> LocalQual mdl + OptRelativeQual -> RelativeQual mdl + OptAliasedQual -> AliasedQual aliases mdl + OptFullQual -> FullQual + OptNoQual -> NoQual ----------------------------------------------------------------------------- @@ -429,7 +478,7 @@ throwE str = throw (HaddockException str) -- @Haddock.Types.ErrMsg@s a lot, like @ErrMsgM@ does, -- but we can't just use @GhcT ErrMsgM@ because GhcT requires the -- transformed monad to be MonadIO. -newtype ErrMsgGhc a = WriterGhc { runWriterGhc :: (Ghc (a, [ErrMsg])) } +newtype ErrMsgGhc a = WriterGhc { runWriterGhc :: Ghc (a, [ErrMsg]) } --instance MonadIO ErrMsgGhc where -- liftIO = WriterGhc . fmap (\a->(a,[])) liftIO --er, implementing GhcMonad involves annoying ExceptionMonad and diff --git a/src/Haddock/Utils.hs b/src/Haddock/Utils.hs index de97ef85..b8f32589 100644 --- a/src/Haddock/Utils.hs +++ b/src/Haddock/Utils.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} ----------------------------------------------------------------------------- -- | -- Module : Haddock.Utils @@ -13,7 +14,7 @@ module Haddock.Utils ( -- * Misc utilities - restrictTo, + restrictTo, emptyHsQTvs, toDescription, toInstalledDescription, -- * Filename utilities @@ -70,7 +71,7 @@ import Data.IORef ( IORef, newIORef, readIORef ) import Data.List ( isSuffixOf ) import Data.Maybe ( mapMaybe ) import System.Environment ( getProgName ) -import System.Exit ( exitWith, ExitCode(..) ) +import System.Exit import System.IO ( hPutStr, stderr ) import System.IO.Unsafe ( unsafePerformIO ) import qualified System.FilePath.Posix as HtmlPath @@ -125,18 +126,24 @@ toInstalledDescription = hmi_description . instInfo restrictTo :: [Name] -> LHsDecl Name -> LHsDecl Name restrictTo names (L loc decl) = L loc $ case decl of - TyClD d | isDataDecl d && tcdND d == DataType -> - TyClD (d { tcdCons = restrictCons names (tcdCons d) }) - TyClD d | isDataDecl d && tcdND d == NewType -> - case restrictCons names (tcdCons d) of - [] -> TyClD (d { tcdND = DataType, tcdCons = [] }) - [con] -> TyClD (d { tcdCons = [con] }) - _ -> error "Should not happen" + TyClD d | isDataDecl d -> + TyClD (d { tcdTyDefn = restrictTyDefn names (tcdTyDefn d) }) TyClD d | isClassDecl d -> TyClD (d { tcdSigs = restrictDecls names (tcdSigs d), tcdATs = restrictATs names (tcdATs d) }) _ -> decl +restrictTyDefn :: [Name] -> HsTyDefn Name -> HsTyDefn Name +restrictTyDefn _ defn@(TySynonym {}) + = defn +restrictTyDefn names defn@(TyData { td_ND = new_or_data, td_cons = cons }) + | DataType <- new_or_data + = defn { td_cons = restrictCons names cons } + | otherwise -- Newtype + = case restrictCons names cons of + [] -> defn { td_ND = DataType, td_cons = [] } + [con] -> defn { td_cons = [con] } + _ -> error "Should not happen" restrictCons :: [Name] -> [LConDecl Name] -> [LConDecl Name] restrictCons names decls = [ L p d | L p (Just d) <- map (fmap keep) decls ] @@ -156,16 +163,22 @@ restrictCons names decls = [ L p d | L p (Just d) <- map (fmap keep) decls ] field_avail (ConDeclField n _ _) = unLoc n `elem` names field_types flds = [ t | ConDeclField _ t _ <- flds ] - keep _ | otherwise = Nothing + keep _ = Nothing restrictDecls :: [Name] -> [LSig Name] -> [LSig Name] -restrictDecls names decls = mapMaybe (filterLSigNames (`elem` names)) decls +restrictDecls names = mapMaybe (filterLSigNames (`elem` names)) restrictATs :: [Name] -> [LTyClDecl Name] -> [LTyClDecl Name] restrictATs names ats = [ at | at <- ats , tcdName (unL at) `elem` names ] +emptyHsQTvs :: LHsTyVarBndrs Name +-- This function is here, rather than in HsTypes, because it *renamed*, but +-- does not necessarily have all the rigt kind variables. It is used +-- in Haddock just for printing, so it doesn't matter +emptyHsQTvs = HsQTvs { hsq_kvs = error "haddock:emptyHsQTvs", hsq_tvs = [] } + -------------------------------------------------------------------------------- -- * Filename mangling functions stolen from s main/DriverUtil.lhs. @@ -286,7 +299,7 @@ getProgramName = liftM (`withoutSuffix` ".bin") getProgName bye :: String -> IO a -bye s = putStr s >> exitWith ExitSuccess +bye s = putStr s >> exitSuccess die :: String -> IO a @@ -319,7 +332,6 @@ escapeStr = escapeURIString isUnreserved -- to avoid depending on the network lib, since doing so gives a -- circular build dependency between haddock and network -- (at least if you want to build network with haddock docs) --- NB: These functions do NOT escape Unicode strings for URLs as per the RFCs escapeURIChar :: (Char -> Bool) -> Char -> String escapeURIChar p c | p c = [c] @@ -410,13 +422,14 @@ markup m (DocParagraph d) = markupParagraph m (markup m d) markup m (DocIdentifier x) = markupIdentifier m x markup m (DocIdentifierUnchecked x) = markupIdentifierUnchecked m x markup m (DocModule mod0) = markupModule m mod0 +markup m (DocWarning d) = markupWarning m (markup m d) markup m (DocEmphasis d) = markupEmphasis m (markup m d) markup m (DocMonospaced d) = markupMonospaced m (markup m d) markup m (DocUnorderedList ds) = markupUnorderedList m (map (markup m) ds) markup m (DocOrderedList ds) = markupOrderedList m (map (markup m) ds) markup m (DocDefList ds) = markupDefList m (map (markupPair m) ds) markup m (DocCodeBlock d) = markupCodeBlock m (markup m d) -markup m (DocURL url) = markupURL m url +markup m (DocHyperlink l) = markupHyperlink m l markup m (DocAName ref) = markupAName m ref markup m (DocPic img) = markupPic m img markup m (DocExamples e) = markupExample m e @@ -436,13 +449,14 @@ idMarkup = Markup { markupIdentifier = DocIdentifier, markupIdentifierUnchecked = DocIdentifierUnchecked, markupModule = DocModule, + markupWarning = DocWarning, markupEmphasis = DocEmphasis, markupMonospaced = DocMonospaced, markupUnorderedList = DocUnorderedList, markupOrderedList = DocOrderedList, markupDefList = DocDefList, markupCodeBlock = DocCodeBlock, - markupURL = DocURL, + markupHyperlink = DocHyperlink, markupAName = DocAName, markupPic = DocPic, markupExample = DocExamples diff --git a/src/Main.hs b/src/Main.hs index 0a3c9ffc..31e2726c 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -1,5 +1,5 @@ {-# OPTIONS_GHC -Wwarn #-} -{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE CPP, ScopedTypeVariables #-} ----------------------------------------------------------------------------- -- | -- Module : Main @@ -57,6 +57,7 @@ import Paths_haddock import GHC hiding (flags, verbosity) import Config import DynFlags hiding (flags, verbosity) +import StaticFlags (saveStaticFlagGlobals, restoreStaticFlagGlobals) import Panic (panic, handleGhcException) import Module @@ -126,35 +127,14 @@ main :: IO () main = handleTopExceptions $ do -- Parse command-line flags and handle some of them initially. + -- TODO: unify all of this (and some of what's in the 'render' function), + -- into one function that returns a record with a field for each option, + -- or which exits with an error or help message. args <- getArgs (flags, files) <- parseHaddockOpts args shortcutFlags flags + qual <- case qualification flags of {Left msg -> throwE msg; Right q -> return q} - if not (null files) then do - (packages, ifaces, homeLinks) <- readPackagesAndProcessModules flags files - - -- Dump an "interface file" (.haddock file), if requested. - case optDumpInterfaceFile flags of - Just f -> dumpInterfaceFile f (map toInstalledIface ifaces) homeLinks - Nothing -> return () - - -- Render the interfaces. - renderStep flags packages ifaces - - else do - when (any (`elem` [Flag_Html, Flag_Hoogle, Flag_LaTeX]) flags) $ - throwE "No input file(s)." - - -- Get packages supplied with --read-interface. - packages <- readInterfaceFiles freshNameCache (readIfaceArgs flags) - - -- Render even though there are no input files (usually contents/index). - renderStep flags packages [] - - -readPackagesAndProcessModules :: [Flag] -> [String] - -> IO ([(DocPaths, InterfaceFile)], [Interface], LinkEnv) -readPackagesAndProcessModules flags files = do libDir <- fmap snd (getGhcDirs flags) -- Catches all GHC source errors, then prints and re-throws them. @@ -165,6 +145,33 @@ readPackagesAndProcessModules flags files = do -- Initialize GHC. withGhc libDir (ghcFlags flags) $ \_ -> handleSrcErrors $ do + dflags <- getDynFlags + + if not (null files) then do + (packages, ifaces, homeLinks) <- readPackagesAndProcessModules flags files + + -- Dump an "interface file" (.haddock file), if requested. + case optDumpInterfaceFile flags of + Just f -> liftIO $ dumpInterfaceFile f (map toInstalledIface ifaces) homeLinks + Nothing -> return () + + -- Render the interfaces. + liftIO $ renderStep dflags flags qual packages ifaces + + else do + when (any (`elem` [Flag_Html, Flag_Hoogle, Flag_LaTeX]) flags) $ + throwE "No input file(s)." + + -- Get packages supplied with --read-interface. + packages <- liftIO $ readInterfaceFiles freshNameCache (readIfaceArgs flags) + + -- Render even though there are no input files (usually contents/index). + liftIO $ renderStep dflags flags qual packages [] + + +readPackagesAndProcessModules :: [Flag] -> [String] + -> Ghc ([(DocPaths, InterfaceFile)], [Interface], LinkEnv) +readPackagesAndProcessModules flags files = do -- Get packages supplied with --read-interface. packages <- readInterfaceFiles nameCacheFromGhc (readIfaceArgs flags) @@ -175,19 +182,19 @@ readPackagesAndProcessModules flags files = do return (packages, ifaces, homeLinks) -renderStep :: [Flag] -> [(DocPaths, InterfaceFile)] -> [Interface] -> IO () -renderStep flags pkgs interfaces = do +renderStep :: DynFlags -> [Flag] -> QualOption -> [(DocPaths, InterfaceFile)] -> [Interface] -> IO () +renderStep dflags flags qual pkgs interfaces = do updateHTMLXRefs pkgs let ifaceFiles = map snd pkgs installedIfaces = concatMap ifInstalledIfaces ifaceFiles srcMap = Map.fromList [ (ifPackageId if_, x) | ((_, Just x), if_) <- pkgs ] - render flags interfaces installedIfaces srcMap + render dflags flags qual interfaces installedIfaces srcMap -- | Render the interfaces with whatever backend is specified in the flags. -render :: [Flag] -> [Interface] -> [InstalledInterface] -> SrcMap -> IO () -render flags ifaces installedIfaces srcMap = do +render :: DynFlags -> [Flag] -> QualOption -> [Interface] -> [InstalledInterface] -> SrcMap -> IO () +render dflags flags qual ifaces installedIfaces srcMap = do let title = fromMaybe "" (optTitle flags) @@ -198,7 +205,6 @@ render flags ifaces installedIfaces srcMap = do opt_index_url = optIndexUrl flags odir = outputDir flags opt_latex_style = optLaTeXStyle flags - opt_qualification = qualification flags visibleIfaces = [ i | i <- ifaces, OptHide `notElem` ifaceOptions i ] @@ -228,20 +234,21 @@ render flags ifaces installedIfaces srcMap = do when (Flag_GenContents `elem` flags) $ do ppHtmlContents odir title pkgStr themes opt_index_url sourceUrls' opt_wiki_urls - allVisibleIfaces True prologue pretty opt_qualification + allVisibleIfaces True prologue pretty + (makeContentsQual qual) copyHtmlBits odir libDir themes when (Flag_Html `elem` flags) $ do ppHtml title pkgStr visibleIfaces odir prologue themes sourceUrls' opt_wiki_urls - opt_contents_url opt_index_url unicode opt_qualification + opt_contents_url opt_index_url unicode qual pretty copyHtmlBits odir libDir themes when (Flag_Hoogle `elem` flags) $ do let pkgName2 = if pkgName == "main" && title /= [] then title else pkgName - ppHoogle pkgName2 pkgVer title prologue visibleIfaces odir + ppHoogle dflags pkgName2 pkgVer title prologue visibleIfaces odir when (Flag_LaTeX `elem` flags) $ do ppLaTeX title pkgStr visibleIfaces odir prologue opt_latex_style @@ -290,7 +297,7 @@ dumpInterfaceFile path ifaces homeLinks = writeInterfaceFile path ifaceFile -- | Start a GHC session with the -haddock flag set. Also turn off -- compilation and linking. Then run the given 'Ghc' action. withGhc :: String -> [String] -> (DynFlags -> Ghc a) -> IO a -withGhc libDir flags ghcActs = do +withGhc libDir flags ghcActs = saveStaticFlagGlobals >>= \savedFlags -> do -- TODO: handle warnings? (restFlags, _) <- parseStaticFlags (map noLoc flags) runGhc (Just libDir) $ do @@ -308,6 +315,7 @@ withGhc libDir flags ghcActs = do -- dynamic or static linking at all! _ <- setSessionDynFlags dynflags''' ghcActs dynflags''' + `finally` restoreStaticFlagGlobals savedFlags where parseGhcFlags :: Monad m => DynFlags -> [Located String] -> [String] -> m DynFlags diff --git a/tests/html-tests/accept.hs b/tests/html-tests/accept.hs index fe1e5422..45b32078 100644 --- a/tests/html-tests/accept.hs +++ b/tests/html-tests/accept.hs @@ -5,17 +5,24 @@ import System.Exit import System.Directory import Data.List import Control.Monad +import Control.Applicative main = do args <- getArgs dir <- getCurrentDirectory - contents <- getDirectoryContents (dir </> "output") + contents <- filter (`notElem` ignore) <$> getDirectoryContents (dir </> "output") if not $ null args then - mapM copy [ "output" </> file | file <- contents, ".html" `isSuffixOf` file, takeBaseName file `elem` args ] + mapM_ copy [ "output" </> file | file <- contents, ".html" `isSuffixOf` file, takeBaseName file `elem` args ] else - mapM copy [ "output" </> file | file <- contents, ".html" `isSuffixOf` file ] + mapM_ copy [ "output" </> file | file <- contents, ".html" `isSuffixOf` file ] + where + ignore = [ + "doc-index.html" + , "index-frames.html" + , "index.html" + ] copy file = do diff --git a/tests/html-tests/copy.hs b/tests/html-tests/copy.hs deleted file mode 100644 index fe1e5422..00000000 --- a/tests/html-tests/copy.hs +++ /dev/null @@ -1,36 +0,0 @@ -import System.Cmd -import System.Environment -import System.FilePath -import System.Exit -import System.Directory -import Data.List -import Control.Monad - - -main = do - args <- getArgs - dir <- getCurrentDirectory - contents <- getDirectoryContents (dir </> "output") - if not $ null args - then - mapM copy [ "output" </> file | file <- contents, ".html" `isSuffixOf` file, takeBaseName file `elem` args ] - else - mapM copy [ "output" </> file | file <- contents, ".html" `isSuffixOf` file ] - - -copy file = do - let new = "tests" </> takeFileName file <.> ".ref" - print file - print new - contents <- readFile file - writeFile new (stripLinks contents) - - -stripLinks str = - let prefix = "<a href=\"" in - case stripPrefix prefix str of - Just str' -> prefix ++ stripLinks (dropWhile (/= '"') str') - Nothing -> - case str of - [] -> [] - x : xs -> x : stripLinks xs diff --git a/tests/html-tests/tests/A.html.ref b/tests/html-tests/tests/A.html.ref index 143f8a73..ec9dc975 100644 --- a/tests/html-tests/tests/A.html.ref +++ b/tests/html-tests/tests/A.html.ref @@ -25,7 +25,7 @@ window.onload = function () {pageLoad();setSynopsis("mini_A.html");}; >Index</a ></li ></ul - ><p class="caption" class="empty" + ><p class="caption empty" > </p ></div ><div id="content" @@ -176,7 +176,7 @@ window.onload = function () {pageLoad();setSynopsis("mini_A.html");}; ><p >Produced by <a href="" >Haddock</a - > version 2.10.0</p + > version 2.12.0</p ></div ></body ></html diff --git a/tests/html-tests/tests/B.html.ref b/tests/html-tests/tests/B.html.ref index 374e34e3..a3a32711 100644 --- a/tests/html-tests/tests/B.html.ref +++ b/tests/html-tests/tests/B.html.ref @@ -25,7 +25,7 @@ window.onload = function () {pageLoad();setSynopsis("mini_B.html");}; >Index</a ></li ></ul - ><p class="caption" class="empty" + ><p class="caption empty" > </p ></div ><div id="content" @@ -168,7 +168,7 @@ window.onload = function () {pageLoad();setSynopsis("mini_B.html");}; ><p >Produced by <a href="" >Haddock</a - > version 2.10.0</p + > version 2.12.0</p ></div ></body ></html diff --git a/tests/html-tests/tests/Bug1.html.ref b/tests/html-tests/tests/Bug1.html.ref index f565996b..ad59f00c 100644 --- a/tests/html-tests/tests/Bug1.html.ref +++ b/tests/html-tests/tests/Bug1.html.ref @@ -25,7 +25,7 @@ window.onload = function () {pageLoad();setSynopsis("mini_Bug1.html");}; >Index</a ></li ></ul - ><p class="caption" class="empty" + ><p class="caption empty" > </p ></div ><div id="content" @@ -96,7 +96,7 @@ window.onload = function () {pageLoad();setSynopsis("mini_Bug1.html");}; ><p >Produced by <a href="" >Haddock</a - > version 2.10.0</p + > version 2.12.0</p ></div ></body ></html diff --git a/tests/html-tests/tests/Bug2.html.ref b/tests/html-tests/tests/Bug2.html.ref index e28d2dea..9b66e4cb 100644 --- a/tests/html-tests/tests/Bug2.html.ref +++ b/tests/html-tests/tests/Bug2.html.ref @@ -25,7 +25,7 @@ window.onload = function () {pageLoad();setSynopsis("mini_Bug2.html");}; >Index</a ></li ></ul - ><p class="caption" class="empty" + ><p class="caption empty" > </p ></div ><div id="content" @@ -58,7 +58,7 @@ window.onload = function () {pageLoad();setSynopsis("mini_Bug2.html");}; ><p >Produced by <a href="" >Haddock</a - > version 2.10.0</p + > version 2.12.0</p ></div ></body ></html diff --git a/tests/html-tests/tests/Bug3.html.ref b/tests/html-tests/tests/Bug3.html.ref index 66317897..3fe7adcb 100644 --- a/tests/html-tests/tests/Bug3.html.ref +++ b/tests/html-tests/tests/Bug3.html.ref @@ -25,7 +25,7 @@ window.onload = function () {pageLoad();setSynopsis("mini_Bug3.html");}; >Index</a ></li ></ul - ><p class="caption" class="empty" + ><p class="caption empty" > </p ></div ><div id="content" @@ -76,7 +76,7 @@ window.onload = function () {pageLoad();setSynopsis("mini_Bug3.html");}; ><p >Produced by <a href="" >Haddock</a - > version 2.10.0</p + > version 2.12.0</p ></div ></body ></html diff --git a/tests/html-tests/tests/Bug4.html.ref b/tests/html-tests/tests/Bug4.html.ref index b19a428e..a36140b1 100644 --- a/tests/html-tests/tests/Bug4.html.ref +++ b/tests/html-tests/tests/Bug4.html.ref @@ -25,7 +25,7 @@ window.onload = function () {pageLoad();setSynopsis("mini_Bug4.html");}; >Index</a ></li ></ul - ><p class="caption" class="empty" + ><p class="caption empty" > </p ></div ><div id="content" @@ -75,7 +75,7 @@ window.onload = function () {pageLoad();setSynopsis("mini_Bug4.html");}; ><p >Produced by <a href="" >Haddock</a - > version 2.10.0</p + > version 2.12.0</p ></div ></body ></html diff --git a/tests/html-tests/tests/Bug6.html.ref b/tests/html-tests/tests/Bug6.html.ref index c05c1f94..b28fbe9c 100644 --- a/tests/html-tests/tests/Bug6.html.ref +++ b/tests/html-tests/tests/Bug6.html.ref @@ -25,7 +25,7 @@ window.onload = function () {pageLoad();setSynopsis("mini_Bug6.html");}; >Index</a ></li ></ul - ><p class="caption" class="empty" + ><p class="caption empty" > </p ></div ><div id="content" @@ -328,7 +328,7 @@ window.onload = function () {pageLoad();setSynopsis("mini_Bug6.html");}; ><p >Produced by <a href="" >Haddock</a - > version 2.10.0</p + > version 2.12.0</p ></div ></body ></html diff --git a/tests/html-tests/tests/Bug7.html.ref b/tests/html-tests/tests/Bug7.html.ref index f7ab171a..f63d7297 100644 --- a/tests/html-tests/tests/Bug7.html.ref +++ b/tests/html-tests/tests/Bug7.html.ref @@ -25,7 +25,7 @@ window.onload = function () {pageLoad();setSynopsis("mini_Bug7.html");}; >Index</a ></li ></ul - ><p class="caption" class="empty" + ><p class="caption empty" > </p ></div ><div id="content" @@ -166,7 +166,7 @@ window.onload = function () {pageLoad();setSynopsis("mini_Bug7.html");}; ><p >Produced by <a href="" >Haddock</a - > version 2.10.0</p + > version 2.12.0</p ></div ></body ></html diff --git a/tests/html-tests/tests/Bug8.html.ref b/tests/html-tests/tests/Bug8.html.ref index 05d3ebeb..3f708a38 100644 --- a/tests/html-tests/tests/Bug8.html.ref +++ b/tests/html-tests/tests/Bug8.html.ref @@ -25,7 +25,7 @@ window.onload = function () {pageLoad();setSynopsis("mini_Bug8.html");}; >Index</a ></li ></ul - ><p class="caption" class="empty" + ><p class="caption empty" > </p ></div ><div id="content" @@ -124,7 +124,7 @@ window.onload = function () {pageLoad();setSynopsis("mini_Bug8.html");}; ><p >Produced by <a href="" >Haddock</a - > version 2.10.0</p + > version 2.12.0</p ></div ></body ></html diff --git a/tests/html-tests/tests/BugDeprecated.hs b/tests/html-tests/tests/BugDeprecated.hs new file mode 100644 index 00000000..0f7ac2eb --- /dev/null +++ b/tests/html-tests/tests/BugDeprecated.hs @@ -0,0 +1,18 @@ +module BugDeprecated where + +foo, bar, baz :: Int +foo = 23 +bar = 23 +baz = 23 +{-# DEPRECATED foo "for foo" #-} +{-# DEPRECATED bar "for bar" #-} +{-# DEPRECATED baz "for baz" #-} + +-- | some documentation for one, two and three +one, two, three :: Int +one = 23 +two = 23 +three = 23 +{-# DEPRECATED one "for one" #-} +{-# DEPRECATED two "for two" #-} +{-# DEPRECATED three "for three" #-} diff --git a/tests/html-tests/tests/BugDeprecated.html.ref b/tests/html-tests/tests/BugDeprecated.html.ref new file mode 100644 index 00000000..303bf11e --- /dev/null +++ b/tests/html-tests/tests/BugDeprecated.html.ref @@ -0,0 +1,192 @@ +<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd"> +<html xmlns="http://www.w3.org/1999/xhtml" +><head + ><meta http-equiv="Content-Type" content="text/html; charset=UTF-8" + /><title + >BugDeprecated</title + ><link href="ocean.css" rel="stylesheet" type="text/css" title="Ocean" + /><script src="haddock-util.js" type="text/javascript" + ></script + ><script type="text/javascript" + >//<![CDATA[ +window.onload = function () {pageLoad();setSynopsis("mini_BugDeprecated.html");}; +//]]> +</script + ></head + ><body + ><div id="package-header" + ><ul class="links" id="page-menu" + ><li + ><a href="" + >Contents</a + ></li + ><li + ><a href="" + >Index</a + ></li + ></ul + ><p class="caption empty" + > </p + ></div + ><div id="content" + ><div id="module-header" + ><table class="info" + ><tr + ><th + >Safe Haskell</th + ><td + >None</td + ></tr + ></table + ><p class="caption" + >BugDeprecated</p + ></div + ><div id="synopsis" + ><p id="control.syn" class="caption expander" onclick="toggleSection('syn')" + >Synopsis</p + ><ul id="section.syn" class="hide" onclick="toggleSection('syn')" + ><li class="src short" + ><a href="" + >foo</a + > :: <a href="" + >Int</a + ></li + ><li class="src short" + ><a href="" + >baz</a + > :: <a href="" + >Int</a + ></li + ><li class="src short" + ><a href="" + >bar</a + > :: <a href="" + >Int</a + ></li + ><li class="src short" + ><a href="" + >one</a + > :: <a href="" + >Int</a + ></li + ><li class="src short" + ><a href="" + >three</a + > :: <a href="" + >Int</a + ></li + ><li class="src short" + ><a href="" + >two</a + > :: <a href="" + >Int</a + ></li + ></ul + ></div + ><div id="interface" + ><h1 + >Documentation</h1 + ><div class="top" + ><p class="src" + ><a name="v:foo" class="def" + >foo</a + > :: <a href="" + >Int</a + ></p + ><div class="doc" + ><div class="warning" + ><p + >Deprecated: for foo</p + ></div + ></div + ></div + ><div class="top" + ><p class="src" + ><a name="v:baz" class="def" + >baz</a + > :: <a href="" + >Int</a + ></p + ><div class="doc" + ><div class="warning" + ><p + >Deprecated: for baz</p + ></div + ></div + ></div + ><div class="top" + ><p class="src" + ><a name="v:bar" class="def" + >bar</a + > :: <a href="" + >Int</a + ></p + ><div class="doc" + ><div class="warning" + ><p + >Deprecated: for bar</p + ></div + ></div + ></div + ><div class="top" + ><p class="src" + ><a name="v:one" class="def" + >one</a + > :: <a href="" + >Int</a + ></p + ><div class="doc" + ><div class="warning" + ><p + >Deprecated: for one</p + ></div + ><p + >some documentation for one, two and three +</p + ></div + ></div + ><div class="top" + ><p class="src" + ><a name="v:three" class="def" + >three</a + > :: <a href="" + >Int</a + ></p + ><div class="doc" + ><div class="warning" + ><p + >Deprecated: for three</p + ></div + ><p + >some documentation for one, two and three +</p + ></div + ></div + ><div class="top" + ><p class="src" + ><a name="v:two" class="def" + >two</a + > :: <a href="" + >Int</a + ></p + ><div class="doc" + ><div class="warning" + ><p + >Deprecated: for two</p + ></div + ><p + >some documentation for one, two and three +</p + ></div + ></div + ></div + ></div + ><div id="footer" + ><p + >Produced by <a href="" + >Haddock</a + > version 2.12.0</p + ></div + ></body + ></html +> diff --git a/tests/html-tests/tests/BugExportHeadings.hs b/tests/html-tests/tests/BugExportHeadings.hs new file mode 100644 index 00000000..a5493a08 --- /dev/null +++ b/tests/html-tests/tests/BugExportHeadings.hs @@ -0,0 +1,29 @@ +-- test for #192 +module BugExportHeadings ( +-- * Foo + foo +-- * Bar +, bar +-- * Baz +, baz + +-- * One +, one +-- * Two +, two +-- * Three +, three +) where + +foo, bar, baz :: Int +foo = 23 +bar = 23 +baz = 23 + +one, two, three :: Int +one = 23 +two = 23 +three = 23 +{-# DEPRECATED one "for one" #-} +{-# DEPRECATED two "for two" #-} +{-# DEPRECATED three "for three" #-} diff --git a/tests/html-tests/tests/BugExportHeadings.html.ref b/tests/html-tests/tests/BugExportHeadings.html.ref new file mode 100644 index 00000000..91d94d0b --- /dev/null +++ b/tests/html-tests/tests/BugExportHeadings.html.ref @@ -0,0 +1,217 @@ +<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd"> +<html xmlns="http://www.w3.org/1999/xhtml" +><head + ><meta http-equiv="Content-Type" content="text/html; charset=UTF-8" + /><title + >BugExportHeadings</title + ><link href="ocean.css" rel="stylesheet" type="text/css" title="Ocean" + /><script src="haddock-util.js" type="text/javascript" + ></script + ><script type="text/javascript" + >//<![CDATA[ +window.onload = function () {pageLoad();setSynopsis("mini_BugExportHeadings.html");}; +//]]> +</script + ></head + ><body + ><div id="package-header" + ><ul class="links" id="page-menu" + ><li + ><a href="" + >Contents</a + ></li + ><li + ><a href="" + >Index</a + ></li + ></ul + ><p class="caption empty" + > </p + ></div + ><div id="content" + ><div id="module-header" + ><table class="info" + ><tr + ><th + >Safe Haskell</th + ><td + >None</td + ></tr + ></table + ><p class="caption" + >BugExportHeadings</p + ></div + ><div id="table-of-contents" + ><p class="caption" + >Contents</p + ><ul + ><li + ><a href="" + >Foo +</a + ></li + ><li + ><a href="" + >Bar +</a + ></li + ><li + ><a href="" + >Baz +</a + ></li + ><li + ><a href="" + >One +</a + ></li + ><li + ><a href="" + >Two +</a + ></li + ><li + ><a href="" + >Three +</a + ></li + ></ul + ></div + ><div id="synopsis" + ><p id="control.syn" class="caption expander" onclick="toggleSection('syn')" + >Synopsis</p + ><ul id="section.syn" class="hide" onclick="toggleSection('syn')" + ><li class="src short" + ><a href="" + >foo</a + > :: <a href="" + >Int</a + ></li + ><li class="src short" + ><a href="" + >bar</a + > :: <a href="" + >Int</a + ></li + ><li class="src short" + ><a href="" + >baz</a + > :: <a href="" + >Int</a + ></li + ><li class="src short" + ><a href="" + >one</a + > :: <a href="" + >Int</a + ></li + ><li class="src short" + ><a href="" + >two</a + > :: <a href="" + >Int</a + ></li + ><li class="src short" + ><a href="" + >three</a + > :: <a href="" + >Int</a + ></li + ></ul + ></div + ><div id="interface" + ><h1 id="g:1" + >Foo +</h1 + ><div class="top" + ><p class="src" + ><a name="v:foo" class="def" + >foo</a + > :: <a href="" + >Int</a + ></p + ></div + ><h1 id="g:2" + >Bar +</h1 + ><div class="top" + ><p class="src" + ><a name="v:bar" class="def" + >bar</a + > :: <a href="" + >Int</a + ></p + ></div + ><h1 id="g:3" + >Baz +</h1 + ><div class="top" + ><p class="src" + ><a name="v:baz" class="def" + >baz</a + > :: <a href="" + >Int</a + ></p + ></div + ><h1 id="g:4" + >One +</h1 + ><div class="top" + ><p class="src" + ><a name="v:one" class="def" + >one</a + > :: <a href="" + >Int</a + ></p + ><div class="doc" + ><div class="warning" + ><p + >Deprecated: for one</p + ></div + ></div + ></div + ><h1 id="g:5" + >Two +</h1 + ><div class="top" + ><p class="src" + ><a name="v:two" class="def" + >two</a + > :: <a href="" + >Int</a + ></p + ><div class="doc" + ><div class="warning" + ><p + >Deprecated: for two</p + ></div + ></div + ></div + ><h1 id="g:6" + >Three +</h1 + ><div class="top" + ><p class="src" + ><a name="v:three" class="def" + >three</a + > :: <a href="" + >Int</a + ></p + ><div class="doc" + ><div class="warning" + ><p + >Deprecated: for three</p + ></div + ></div + ></div + ></div + ></div + ><div id="footer" + ><p + >Produced by <a href="" + >Haddock</a + > version 2.12.0</p + ></div + ></body + ></html +> diff --git a/tests/html-tests/tests/Bugs.html.ref b/tests/html-tests/tests/Bugs.html.ref index 61d3a82b..3ea34893 100644 --- a/tests/html-tests/tests/Bugs.html.ref +++ b/tests/html-tests/tests/Bugs.html.ref @@ -25,7 +25,7 @@ window.onload = function () {pageLoad();setSynopsis("mini_Bugs.html");}; >Index</a ></li ></ul - ><p class="caption" class="empty" + ><p class="caption empty" > </p ></div ><div id="content" @@ -74,7 +74,7 @@ window.onload = function () {pageLoad();setSynopsis("mini_Bugs.html");}; ><p >Produced by <a href="" >Haddock</a - > version 2.10.0</p + > version 2.12.0</p ></div ></body ></html diff --git a/tests/html-tests/tests/CrossPackageDocs.html.ref b/tests/html-tests/tests/CrossPackageDocs.html.ref index c12f697d..57bf900d 100644 --- a/tests/html-tests/tests/CrossPackageDocs.html.ref +++ b/tests/html-tests/tests/CrossPackageDocs.html.ref @@ -25,7 +25,7 @@ window.onload = function () {pageLoad();setSynopsis("mini_CrossPackageDocs.html" >Index</a ></li ></ul - ><p class="caption" class="empty" + ><p class="caption empty" > </p ></div ><div id="content" @@ -358,7 +358,11 @@ defined in the <a href="" ></td ><td class="doc" ><p - >Filename of the executable + >Filename of the executable (see <code + ><a href="" + >proc</a + ></code + > for details) </p ></td ></tr @@ -461,7 +465,7 @@ defined in the <a href="" ><p >Produced by <a href="" >Haddock</a - > version 2.10.0</p + > version 2.12.0</p ></div ></body ></html diff --git a/tests/html-tests/tests/DeprecatedClass.hs b/tests/html-tests/tests/DeprecatedClass.hs new file mode 100644 index 00000000..018904ab --- /dev/null +++ b/tests/html-tests/tests/DeprecatedClass.hs @@ -0,0 +1,15 @@ +module DeprecatedClass where + +-- | some class +class SomeClass a where + -- | documentation for foo + foo :: a -> a + +{-# DEPRECATED SomeClass "SomeClass" #-} +{-# DEPRECATED foo "foo" #-} + +class SomeOtherClass a where + bar :: a -> a + +{-# DEPRECATED SomeOtherClass "SomeOtherClass" #-} +{-# DEPRECATED bar "bar" #-} diff --git a/tests/html-tests/tests/DeprecatedClass.html.ref b/tests/html-tests/tests/DeprecatedClass.html.ref new file mode 100644 index 00000000..cc6aca71 --- /dev/null +++ b/tests/html-tests/tests/DeprecatedClass.html.ref @@ -0,0 +1,157 @@ +<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd"> +<html xmlns="http://www.w3.org/1999/xhtml" +><head + ><meta http-equiv="Content-Type" content="text/html; charset=UTF-8" + /><title + >DeprecatedClass</title + ><link href="ocean.css" rel="stylesheet" type="text/css" title="Ocean" + /><script src="haddock-util.js" type="text/javascript" + ></script + ><script type="text/javascript" + >//<![CDATA[ +window.onload = function () {pageLoad();setSynopsis("mini_DeprecatedClass.html");}; +//]]> +</script + ></head + ><body + ><div id="package-header" + ><ul class="links" id="page-menu" + ><li + ><a href="" + >Contents</a + ></li + ><li + ><a href="" + >Index</a + ></li + ></ul + ><p class="caption empty" + > </p + ></div + ><div id="content" + ><div id="module-header" + ><table class="info" + ><tr + ><th + >Safe Haskell</th + ><td + >None</td + ></tr + ></table + ><p class="caption" + >DeprecatedClass</p + ></div + ><div id="synopsis" + ><p id="control.syn" class="caption expander" onclick="toggleSection('syn')" + >Synopsis</p + ><ul id="section.syn" class="hide" onclick="toggleSection('syn')" + ><li class="src short" + ><span class="keyword" + >class</span + > <a href="" + >SomeClass</a + > a <span class="keyword" + >where</span + ><ul class="subs" + ><li + ><a href="" + >foo</a + > :: a -> a</li + ></ul + ></li + ><li class="src short" + ><span class="keyword" + >class</span + > <a href="" + >SomeOtherClass</a + > a <span class="keyword" + >where</span + ><ul class="subs" + ><li + ><a href="" + >bar</a + > :: a -> a</li + ></ul + ></li + ></ul + ></div + ><div id="interface" + ><h1 + >Documentation</h1 + ><div class="top" + ><p class="src" + ><span class="keyword" + >class</span + > <a name="t:SomeClass" class="def" + >SomeClass</a + > a <span class="keyword" + >where</span + ></p + ><div class="doc" + ><div class="warning" + ><p + >Deprecated: SomeClass</p + ></div + ><p + >some class +</p + ></div + ><div class="subs methods" + ><p class="caption" + >Methods</p + ><p class="src" + ><a name="v:foo" class="def" + >foo</a + > :: a -> a</p + ><div class="doc" + ><div class="warning" + ><p + >Deprecated: foo</p + ></div + ><p + >documentation for foo +</p + ></div + ></div + ></div + ><div class="top" + ><p class="src" + ><span class="keyword" + >class</span + > <a name="t:SomeOtherClass" class="def" + >SomeOtherClass</a + > a <span class="keyword" + >where</span + ></p + ><div class="doc" + ><div class="warning" + ><p + >Deprecated: SomeOtherClass</p + ></div + ></div + ><div class="subs methods" + ><p class="caption" + >Methods</p + ><p class="src" + ><a name="v:bar" class="def" + >bar</a + > :: a -> a</p + ><div class="doc" + ><div class="warning" + ><p + >Deprecated: bar</p + ></div + ></div + ></div + ></div + ></div + ></div + ><div id="footer" + ><p + >Produced by <a href="" + >Haddock</a + > version 2.12.0</p + ></div + ></body + ></html +> diff --git a/tests/html-tests/tests/DeprecatedData.hs b/tests/html-tests/tests/DeprecatedData.hs new file mode 100644 index 00000000..c40ba122 --- /dev/null +++ b/tests/html-tests/tests/DeprecatedData.hs @@ -0,0 +1,15 @@ +{-# LANGUAGE TypeFamilies #-} +module DeprecatedData where + +-- | type Foo +data Foo = Foo -- ^ constructor Foo + | Bar -- ^ constructor Bar + +{-# DEPRECATED Foo "Foo" #-} +{-# DEPRECATED Bar "Bar" #-} + +data One = One + | Two + +{-# DEPRECATED One "One" #-} +{-# DEPRECATED Two "Two" #-} diff --git a/tests/html-tests/tests/DeprecatedData.html.ref b/tests/html-tests/tests/DeprecatedData.html.ref new file mode 100644 index 00000000..ffd0506c --- /dev/null +++ b/tests/html-tests/tests/DeprecatedData.html.ref @@ -0,0 +1,192 @@ +<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd"> +<html xmlns="http://www.w3.org/1999/xhtml" +><head + ><meta http-equiv="Content-Type" content="text/html; charset=UTF-8" + /><title + >DeprecatedData</title + ><link href="ocean.css" rel="stylesheet" type="text/css" title="Ocean" + /><script src="haddock-util.js" type="text/javascript" + ></script + ><script type="text/javascript" + >//<![CDATA[ +window.onload = function () {pageLoad();setSynopsis("mini_DeprecatedData.html");}; +//]]> +</script + ></head + ><body + ><div id="package-header" + ><ul class="links" id="page-menu" + ><li + ><a href="" + >Contents</a + ></li + ><li + ><a href="" + >Index</a + ></li + ></ul + ><p class="caption empty" + > </p + ></div + ><div id="content" + ><div id="module-header" + ><table class="info" + ><tr + ><th + >Safe Haskell</th + ><td + >None</td + ></tr + ></table + ><p class="caption" + >DeprecatedData</p + ></div + ><div id="synopsis" + ><p id="control.syn" class="caption expander" onclick="toggleSection('syn')" + >Synopsis</p + ><ul id="section.syn" class="hide" onclick="toggleSection('syn')" + ><li class="src short" + ><span class="keyword" + >data</span + > <a href="" + >Foo</a + > <ul class="subs" + ><li + >= <a href="" + >Foo</a + > </li + ><li + >| <a href="" + >Bar</a + > </li + ></ul + ></li + ><li class="src short" + ><span class="keyword" + >data</span + > <a href="" + >One</a + > <ul class="subs" + ><li + >= <a href="" + >One</a + > </li + ><li + >| <a href="" + >Two</a + > </li + ></ul + ></li + ></ul + ></div + ><div id="interface" + ><h1 + >Documentation</h1 + ><div class="top" + ><p class="src" + ><span class="keyword" + >data</span + > <a name="t:Foo" class="def" + >Foo</a + > </p + ><div class="doc" + ><div class="warning" + ><p + >Deprecated: Foo</p + ></div + ><p + >type Foo +</p + ></div + ><div class="subs constructors" + ><p class="caption" + >Constructors</p + ><table + ><tr + ><td class="src" + ><a name="v:Foo" class="def" + >Foo</a + ></td + ><td class="doc" + ><div class="warning" + ><p + >Deprecated: Foo</p + ></div + ><p + >constructor Foo +</p + ></td + ></tr + ><tr + ><td class="src" + ><a name="v:Bar" class="def" + >Bar</a + ></td + ><td class="doc" + ><div class="warning" + ><p + >Deprecated: Bar</p + ></div + ><p + >constructor Bar +</p + ></td + ></tr + ></table + ></div + ></div + ><div class="top" + ><p class="src" + ><span class="keyword" + >data</span + > <a name="t:One" class="def" + >One</a + > </p + ><div class="doc" + ><div class="warning" + ><p + >Deprecated: One</p + ></div + ></div + ><div class="subs constructors" + ><p class="caption" + >Constructors</p + ><table + ><tr + ><td class="src" + ><a name="v:One" class="def" + >One</a + ></td + ><td class="doc" + ><div class="warning" + ><p + >Deprecated: One</p + ></div + ></td + ></tr + ><tr + ><td class="src" + ><a name="v:Two" class="def" + >Two</a + ></td + ><td class="doc" + ><div class="warning" + ><p + >Deprecated: Two</p + ></div + ></td + ></tr + ></table + ></div + ></div + ></div + ></div + ><div id="footer" + ><p + >Produced by <a href="" + >Haddock</a + > version 2.12.0</p + ></div + ></body + ></html +> diff --git a/tests/html-tests/tests/DeprecatedFunction.hs b/tests/html-tests/tests/DeprecatedFunction.hs new file mode 100644 index 00000000..55416369 --- /dev/null +++ b/tests/html-tests/tests/DeprecatedFunction.hs @@ -0,0 +1,6 @@ +module DeprecatedFunction where + +-- | some documentation foo +foo :: Int +foo = 23 +{-# DEPRECATED foo "use bar instead" #-} diff --git a/tests/html-tests/tests/DeprecatedFunction.html.ref b/tests/html-tests/tests/DeprecatedFunction.html.ref new file mode 100644 index 00000000..ff8513b3 --- /dev/null +++ b/tests/html-tests/tests/DeprecatedFunction.html.ref @@ -0,0 +1,86 @@ +<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd"> +<html xmlns="http://www.w3.org/1999/xhtml" +><head + ><meta http-equiv="Content-Type" content="text/html; charset=UTF-8" + /><title + >DeprecatedFunction</title + ><link href="ocean.css" rel="stylesheet" type="text/css" title="Ocean" + /><script src="haddock-util.js" type="text/javascript" + ></script + ><script type="text/javascript" + >//<![CDATA[ +window.onload = function () {pageLoad();setSynopsis("mini_DeprecatedFunction.html");}; +//]]> +</script + ></head + ><body + ><div id="package-header" + ><ul class="links" id="page-menu" + ><li + ><a href="" + >Contents</a + ></li + ><li + ><a href="" + >Index</a + ></li + ></ul + ><p class="caption empty" + > </p + ></div + ><div id="content" + ><div id="module-header" + ><table class="info" + ><tr + ><th + >Safe Haskell</th + ><td + >None</td + ></tr + ></table + ><p class="caption" + >DeprecatedFunction</p + ></div + ><div id="synopsis" + ><p id="control.syn" class="caption expander" onclick="toggleSection('syn')" + >Synopsis</p + ><ul id="section.syn" class="hide" onclick="toggleSection('syn')" + ><li class="src short" + ><a href="" + >foo</a + > :: <a href="" + >Int</a + ></li + ></ul + ></div + ><div id="interface" + ><h1 + >Documentation</h1 + ><div class="top" + ><p class="src" + ><a name="v:foo" class="def" + >foo</a + > :: <a href="" + >Int</a + ></p + ><div class="doc" + ><div class="warning" + ><p + >Deprecated: use bar instead</p + ></div + ><p + >some documentation foo +</p + ></div + ></div + ></div + ></div + ><div id="footer" + ><p + >Produced by <a href="" + >Haddock</a + > version 2.12.0</p + ></div + ></body + ></html +> diff --git a/tests/html-tests/tests/DeprecatedFunction2.hs b/tests/html-tests/tests/DeprecatedFunction2.hs new file mode 100644 index 00000000..bdbbf95c --- /dev/null +++ b/tests/html-tests/tests/DeprecatedFunction2.hs @@ -0,0 +1,6 @@ +module DeprecatedFunction2 where + + +foo :: Int +foo = 23 +{-# DEPRECATED foo "use bar instead" #-} diff --git a/tests/html-tests/tests/DeprecatedFunction2.html.ref b/tests/html-tests/tests/DeprecatedFunction2.html.ref new file mode 100644 index 00000000..64ac8029 --- /dev/null +++ b/tests/html-tests/tests/DeprecatedFunction2.html.ref @@ -0,0 +1,83 @@ +<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd"> +<html xmlns="http://www.w3.org/1999/xhtml" +><head + ><meta http-equiv="Content-Type" content="text/html; charset=UTF-8" + /><title + >DeprecatedFunction2</title + ><link href="ocean.css" rel="stylesheet" type="text/css" title="Ocean" + /><script src="haddock-util.js" type="text/javascript" + ></script + ><script type="text/javascript" + >//<![CDATA[ +window.onload = function () {pageLoad();setSynopsis("mini_DeprecatedFunction2.html");}; +//]]> +</script + ></head + ><body + ><div id="package-header" + ><ul class="links" id="page-menu" + ><li + ><a href="" + >Contents</a + ></li + ><li + ><a href="" + >Index</a + ></li + ></ul + ><p class="caption empty" + > </p + ></div + ><div id="content" + ><div id="module-header" + ><table class="info" + ><tr + ><th + >Safe Haskell</th + ><td + >None</td + ></tr + ></table + ><p class="caption" + >DeprecatedFunction2</p + ></div + ><div id="synopsis" + ><p id="control.syn" class="caption expander" onclick="toggleSection('syn')" + >Synopsis</p + ><ul id="section.syn" class="hide" onclick="toggleSection('syn')" + ><li class="src short" + ><a href="" + >foo</a + > :: <a href="" + >Int</a + ></li + ></ul + ></div + ><div id="interface" + ><h1 + >Documentation</h1 + ><div class="top" + ><p class="src" + ><a name="v:foo" class="def" + >foo</a + > :: <a href="" + >Int</a + ></p + ><div class="doc" + ><div class="warning" + ><p + >Deprecated: use bar instead</p + ></div + ></div + ></div + ></div + ></div + ><div id="footer" + ><p + >Produced by <a href="" + >Haddock</a + > version 2.12.0</p + ></div + ></body + ></html +> diff --git a/tests/html-tests/tests/DeprecatedFunction3.hs b/tests/html-tests/tests/DeprecatedFunction3.hs new file mode 100644 index 00000000..ca719bda --- /dev/null +++ b/tests/html-tests/tests/DeprecatedFunction3.hs @@ -0,0 +1,6 @@ +module DeprecatedFunction3 where + + + +foo = 23 +{-# DEPRECATED foo "use bar instead" #-} diff --git a/tests/html-tests/tests/DeprecatedFunction3.html.ref b/tests/html-tests/tests/DeprecatedFunction3.html.ref new file mode 100644 index 00000000..45be9fee --- /dev/null +++ b/tests/html-tests/tests/DeprecatedFunction3.html.ref @@ -0,0 +1,83 @@ +<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd"> +<html xmlns="http://www.w3.org/1999/xhtml" +><head + ><meta http-equiv="Content-Type" content="text/html; charset=UTF-8" + /><title + >DeprecatedFunction3</title + ><link href="ocean.css" rel="stylesheet" type="text/css" title="Ocean" + /><script src="haddock-util.js" type="text/javascript" + ></script + ><script type="text/javascript" + >//<![CDATA[ +window.onload = function () {pageLoad();setSynopsis("mini_DeprecatedFunction3.html");}; +//]]> +</script + ></head + ><body + ><div id="package-header" + ><ul class="links" id="page-menu" + ><li + ><a href="" + >Contents</a + ></li + ><li + ><a href="" + >Index</a + ></li + ></ul + ><p class="caption empty" + > </p + ></div + ><div id="content" + ><div id="module-header" + ><table class="info" + ><tr + ><th + >Safe Haskell</th + ><td + >None</td + ></tr + ></table + ><p class="caption" + >DeprecatedFunction3</p + ></div + ><div id="synopsis" + ><p id="control.syn" class="caption expander" onclick="toggleSection('syn')" + >Synopsis</p + ><ul id="section.syn" class="hide" onclick="toggleSection('syn')" + ><li class="src short" + ><a href="" + >foo</a + > :: <a href="" + >Integer</a + ></li + ></ul + ></div + ><div id="interface" + ><h1 + >Documentation</h1 + ><div class="top" + ><p class="src" + ><a name="v:foo" class="def" + >foo</a + > :: <a href="" + >Integer</a + ></p + ><div class="doc" + ><div class="warning" + ><p + >Deprecated: use bar instead</p + ></div + ></div + ></div + ></div + ></div + ><div id="footer" + ><p + >Produced by <a href="" + >Haddock</a + > version 2.12.0</p + ></div + ></body + ></html +> diff --git a/tests/html-tests/tests/DeprecatedModule.hs b/tests/html-tests/tests/DeprecatedModule.hs new file mode 100644 index 00000000..61a09d64 --- /dev/null +++ b/tests/html-tests/tests/DeprecatedModule.hs @@ -0,0 +1,5 @@ +-- | Documentation for "DeprecatedModule". +module DeprecatedModule {-# DEPRECATED "Use Foo instead" #-} where + +foo :: Int +foo = 23 diff --git a/tests/html-tests/tests/DeprecatedModule.html.ref b/tests/html-tests/tests/DeprecatedModule.html.ref new file mode 100644 index 00000000..2352e3e8 --- /dev/null +++ b/tests/html-tests/tests/DeprecatedModule.html.ref @@ -0,0 +1,80 @@ +<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd"> +<html xmlns="http://www.w3.org/1999/xhtml" +><head + ><meta http-equiv="Content-Type" content="text/html; charset=UTF-8" + /><title + >DeprecatedModule</title + ><link href="ocean.css" rel="stylesheet" type="text/css" title="Ocean" + /><script src="haddock-util.js" type="text/javascript" + ></script + ><script type="text/javascript" + >//<![CDATA[ +window.onload = function () {pageLoad();setSynopsis("mini_DeprecatedModule.html");}; +//]]> +</script + ></head + ><body + ><div id="package-header" + ><ul class="links" id="page-menu" + ><li + ><a href="" + >Contents</a + ></li + ><li + ><a href="" + >Index</a + ></li + ></ul + ><p class="caption empty" + > </p + ></div + ><div id="content" + ><div id="module-header" + ><table class="info" + ><tr + ><th + >Safe Haskell</th + ><td + >None</td + ></tr + ></table + ><p class="caption" + >DeprecatedModule</p + ></div + ><div id="description" + ><p class="caption" + >Description</p + ><div class="doc" + ><div class="warning" + ><p + >Deprecated: Use Foo instead</p + ></div + ><p + >Documentation for <a href="" + >DeprecatedModule</a + >. +</p + ></div + ></div + ><div id="interface" + ><h1 + >Documentation</h1 + ><div class="top" + ><p class="src" + ><a name="v:foo" class="def" + >foo</a + > :: <a href="" + >Int</a + ></p + ></div + ></div + ></div + ><div id="footer" + ><p + >Produced by <a href="" + >Haddock</a + > version 2.12.0</p + ></div + ></body + ></html +> diff --git a/tests/html-tests/tests/DeprecatedModule2.hs b/tests/html-tests/tests/DeprecatedModule2.hs new file mode 100644 index 00000000..94185297 --- /dev/null +++ b/tests/html-tests/tests/DeprecatedModule2.hs @@ -0,0 +1,4 @@ +module DeprecatedModule2 {-# DEPRECATED "Use Foo instead" #-} where + +foo :: Int +foo = 23 diff --git a/tests/html-tests/tests/DeprecatedModule2.html.ref b/tests/html-tests/tests/DeprecatedModule2.html.ref new file mode 100644 index 00000000..d7ae063d --- /dev/null +++ b/tests/html-tests/tests/DeprecatedModule2.html.ref @@ -0,0 +1,75 @@ +<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd"> +<html xmlns="http://www.w3.org/1999/xhtml" +><head + ><meta http-equiv="Content-Type" content="text/html; charset=UTF-8" + /><title + >DeprecatedModule2</title + ><link href="ocean.css" rel="stylesheet" type="text/css" title="Ocean" + /><script src="haddock-util.js" type="text/javascript" + ></script + ><script type="text/javascript" + >//<![CDATA[ +window.onload = function () {pageLoad();setSynopsis("mini_DeprecatedModule2.html");}; +//]]> +</script + ></head + ><body + ><div id="package-header" + ><ul class="links" id="page-menu" + ><li + ><a href="" + >Contents</a + ></li + ><li + ><a href="" + >Index</a + ></li + ></ul + ><p class="caption empty" + > </p + ></div + ><div id="content" + ><div id="module-header" + ><table class="info" + ><tr + ><th + >Safe Haskell</th + ><td + >None</td + ></tr + ></table + ><p class="caption" + >DeprecatedModule2</p + ></div + ><div id="description" + ><p class="caption" + >Description</p + ><div class="doc" + ><div class="warning" + ><p + >Deprecated: Use Foo instead</p + ></div + ></div + ></div + ><div id="interface" + ><h1 + >Documentation</h1 + ><div class="top" + ><p class="src" + ><a name="v:foo" class="def" + >foo</a + > :: <a href="" + >Int</a + ></p + ></div + ></div + ></div + ><div id="footer" + ><p + >Produced by <a href="" + >Haddock</a + > version 2.12.0</p + ></div + ></body + ></html +> diff --git a/tests/html-tests/tests/DeprecatedNewtype.hs b/tests/html-tests/tests/DeprecatedNewtype.hs new file mode 100644 index 00000000..254f1f55 --- /dev/null +++ b/tests/html-tests/tests/DeprecatedNewtype.hs @@ -0,0 +1,10 @@ +module DeprecatedNewtype where + +-- | some documentation +newtype SomeNewType = SomeNewTypeConst String {- ^ constructor docu -} +{-# DEPRECATED SomeNewType "SomeNewType" #-} +{-# DEPRECATED SomeNewTypeConst "SomeNewTypeConst" #-} + +newtype SomeOtherNewType = SomeOtherNewTypeConst String +{-# DEPRECATED SomeOtherNewType "SomeOtherNewType" #-} +{-# DEPRECATED SomeOtherNewTypeConst "SomeOtherNewTypeConst" #-} diff --git a/tests/html-tests/tests/DeprecatedNewtype.html.ref b/tests/html-tests/tests/DeprecatedNewtype.html.ref new file mode 100644 index 00000000..83f18777 --- /dev/null +++ b/tests/html-tests/tests/DeprecatedNewtype.html.ref @@ -0,0 +1,157 @@ +<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd"> +<html xmlns="http://www.w3.org/1999/xhtml" +><head + ><meta http-equiv="Content-Type" content="text/html; charset=UTF-8" + /><title + >DeprecatedNewtype</title + ><link href="ocean.css" rel="stylesheet" type="text/css" title="Ocean" + /><script src="haddock-util.js" type="text/javascript" + ></script + ><script type="text/javascript" + >//<![CDATA[ +window.onload = function () {pageLoad();setSynopsis("mini_DeprecatedNewtype.html");}; +//]]> +</script + ></head + ><body + ><div id="package-header" + ><ul class="links" id="page-menu" + ><li + ><a href="" + >Contents</a + ></li + ><li + ><a href="" + >Index</a + ></li + ></ul + ><p class="caption empty" + > </p + ></div + ><div id="content" + ><div id="module-header" + ><table class="info" + ><tr + ><th + >Safe Haskell</th + ><td + >None</td + ></tr + ></table + ><p class="caption" + >DeprecatedNewtype</p + ></div + ><div id="synopsis" + ><p id="control.syn" class="caption expander" onclick="toggleSection('syn')" + >Synopsis</p + ><ul id="section.syn" class="hide" onclick="toggleSection('syn')" + ><li class="src short" + ><span class="keyword" + >newtype</span + > <a href="" + >SomeNewType</a + > = <a href="" + >SomeNewTypeConst</a + > <a href="" + >String</a + ></li + ><li class="src short" + ><span class="keyword" + >newtype</span + > <a href="" + >SomeOtherNewType</a + > = <a href="" + >SomeOtherNewTypeConst</a + > <a href="" + >String</a + ></li + ></ul + ></div + ><div id="interface" + ><h1 + >Documentation</h1 + ><div class="top" + ><p class="src" + ><span class="keyword" + >newtype</span + > <a name="t:SomeNewType" class="def" + >SomeNewType</a + > </p + ><div class="doc" + ><div class="warning" + ><p + >Deprecated: SomeNewType</p + ></div + ><p + >some documentation +</p + ></div + ><div class="subs constructors" + ><p class="caption" + >Constructors</p + ><table + ><tr + ><td class="src" + ><a name="v:SomeNewTypeConst" class="def" + >SomeNewTypeConst</a + > <a href="" + >String</a + ></td + ><td class="doc" + ><div class="warning" + ><p + >Deprecated: SomeNewTypeConst</p + ></div + ><p + >constructor docu +</p + ></td + ></tr + ></table + ></div + ></div + ><div class="top" + ><p class="src" + ><span class="keyword" + >newtype</span + > <a name="t:SomeOtherNewType" class="def" + >SomeOtherNewType</a + > </p + ><div class="doc" + ><div class="warning" + ><p + >Deprecated: SomeOtherNewType</p + ></div + ></div + ><div class="subs constructors" + ><p class="caption" + >Constructors</p + ><table + ><tr + ><td class="src" + ><a name="v:SomeOtherNewTypeConst" class="def" + >SomeOtherNewTypeConst</a + > <a href="" + >String</a + ></td + ><td class="doc" + ><div class="warning" + ><p + >Deprecated: SomeOtherNewTypeConst</p + ></div + ></td + ></tr + ></table + ></div + ></div + ></div + ></div + ><div id="footer" + ><p + >Produced by <a href="" + >Haddock</a + > version 2.12.0</p + ></div + ></body + ></html +> diff --git a/tests/html-tests/tests/DeprecatedRecord.hs b/tests/html-tests/tests/DeprecatedRecord.hs new file mode 100644 index 00000000..d44499e7 --- /dev/null +++ b/tests/html-tests/tests/DeprecatedRecord.hs @@ -0,0 +1,9 @@ +module DeprecatedRecord where + +-- | type Foo +data Foo = Foo { + fooName :: String -- ^ some name +, fooValue :: Int -- ^ some value +} + +{-# DEPRECATED fooValue "do not use this" #-} diff --git a/tests/html-tests/tests/DeprecatedRecord.html.ref b/tests/html-tests/tests/DeprecatedRecord.html.ref new file mode 100644 index 00000000..08749470 --- /dev/null +++ b/tests/html-tests/tests/DeprecatedRecord.html.ref @@ -0,0 +1,150 @@ +<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd"> +<html xmlns="http://www.w3.org/1999/xhtml" +><head + ><meta http-equiv="Content-Type" content="text/html; charset=UTF-8" + /><title + >DeprecatedRecord</title + ><link href="ocean.css" rel="stylesheet" type="text/css" title="Ocean" + /><script src="haddock-util.js" type="text/javascript" + ></script + ><script type="text/javascript" + >//<![CDATA[ +window.onload = function () {pageLoad();setSynopsis("mini_DeprecatedRecord.html");}; +//]]> +</script + ></head + ><body + ><div id="package-header" + ><ul class="links" id="page-menu" + ><li + ><a href="" + >Contents</a + ></li + ><li + ><a href="" + >Index</a + ></li + ></ul + ><p class="caption empty" + > </p + ></div + ><div id="content" + ><div id="module-header" + ><table class="info" + ><tr + ><th + >Safe Haskell</th + ><td + >None</td + ></tr + ></table + ><p class="caption" + >DeprecatedRecord</p + ></div + ><div id="synopsis" + ><p id="control.syn" class="caption expander" onclick="toggleSection('syn')" + >Synopsis</p + ><ul id="section.syn" class="hide" onclick="toggleSection('syn')" + ><li class="src short" + ><span class="keyword" + >data</span + > <a href="" + >Foo</a + > = <a href="" + >Foo</a + > {<ul class="subs" + ><li + ><a href="" + >fooName</a + > :: <a href="" + >String</a + ></li + ><li + ><a href="" + >fooValue</a + > :: <a href="" + >Int</a + ></li + ></ul + >}</li + ></ul + ></div + ><div id="interface" + ><h1 + >Documentation</h1 + ><div class="top" + ><p class="src" + ><span class="keyword" + >data</span + > <a name="t:Foo" class="def" + >Foo</a + > </p + ><div class="doc" + ><p + >type Foo +</p + ></div + ><div class="subs constructors" + ><p class="caption" + >Constructors</p + ><table + ><tr + ><td class="src" + ><a name="v:Foo" class="def" + >Foo</a + ></td + ><td class="doc empty" + > </td + ></tr + ><tr + ><td colspan="2" + ><div class="subs fields" + ><p class="caption" + >Fields</p + ><dl + ><dt class="src" + ><a name="v:fooName" class="def" + >fooName</a + > :: <a href="" + >String</a + ></dt + ><dd class="doc" + ><p + >some name +</p + ></dd + ><dt class="src" + ><a name="v:fooValue" class="def" + >fooValue</a + > :: <a href="" + >Int</a + ></dt + ><dd class="doc" + ><div class="warning" + ><p + >Deprecated: do not use this</p + ></div + ><p + >some value +</p + ></dd + ></dl + ><div class="clear" + ></div + ></div + ></td + ></tr + ></table + ></div + ></div + ></div + ></div + ><div id="footer" + ><p + >Produced by <a href="" + >Haddock</a + > version 2.12.0</p + ></div + ></body + ></html +> diff --git a/tests/html-tests/tests/DeprecatedTypeFamily.hs b/tests/html-tests/tests/DeprecatedTypeFamily.hs new file mode 100644 index 00000000..70473bb8 --- /dev/null +++ b/tests/html-tests/tests/DeprecatedTypeFamily.hs @@ -0,0 +1,9 @@ +{-# LANGUAGE TypeFamilies #-} +module DeprecatedTypeFamily where + +-- | some documentation +data family SomeTypeFamily k :: * -> * +{-# DEPRECATED SomeTypeFamily "SomeTypeFamily" #-} + +data family SomeOtherTypeFamily k :: * -> * +{-# DEPRECATED SomeOtherTypeFamily "SomeOtherTypeFamily" #-} diff --git a/tests/html-tests/tests/DeprecatedTypeFamily.html.ref b/tests/html-tests/tests/DeprecatedTypeFamily.html.ref new file mode 100644 index 00000000..0c2d5677 --- /dev/null +++ b/tests/html-tests/tests/DeprecatedTypeFamily.html.ref @@ -0,0 +1,106 @@ +<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd"> +<html xmlns="http://www.w3.org/1999/xhtml" +><head + ><meta http-equiv="Content-Type" content="text/html; charset=UTF-8" + /><title + >DeprecatedTypeFamily</title + ><link href="ocean.css" rel="stylesheet" type="text/css" title="Ocean" + /><script src="haddock-util.js" type="text/javascript" + ></script + ><script type="text/javascript" + >//<![CDATA[ +window.onload = function () {pageLoad();setSynopsis("mini_DeprecatedTypeFamily.html");}; +//]]> +</script + ></head + ><body + ><div id="package-header" + ><ul class="links" id="page-menu" + ><li + ><a href="" + >Contents</a + ></li + ><li + ><a href="" + >Index</a + ></li + ></ul + ><p class="caption empty" + > </p + ></div + ><div id="content" + ><div id="module-header" + ><table class="info" + ><tr + ><th + >Safe Haskell</th + ><td + >None</td + ></tr + ></table + ><p class="caption" + >DeprecatedTypeFamily</p + ></div + ><div id="synopsis" + ><p id="control.syn" class="caption expander" onclick="toggleSection('syn')" + >Synopsis</p + ><ul id="section.syn" class="hide" onclick="toggleSection('syn')" + ><li class="src short" + ><span class="keyword" + >data family</span + > <a href="" + >SomeTypeFamily</a + > k :: * -> *</li + ><li class="src short" + ><span class="keyword" + >data family</span + > <a href="" + >SomeOtherTypeFamily</a + > k :: * -> *</li + ></ul + ></div + ><div id="interface" + ><h1 + >Documentation</h1 + ><div class="top" + ><p class="src" + ><span class="keyword" + >data family</span + > <a name="t:SomeTypeFamily" class="def" + >SomeTypeFamily</a + > k :: * -> *</p + ><div class="doc" + ><div class="warning" + ><p + >Deprecated: SomeTypeFamily</p + ></div + ><p + >some documentation +</p + ></div + ></div + ><div class="top" + ><p class="src" + ><span class="keyword" + >data family</span + > <a name="t:SomeOtherTypeFamily" class="def" + >SomeOtherTypeFamily</a + > k :: * -> *</p + ><div class="doc" + ><div class="warning" + ><p + >Deprecated: SomeOtherTypeFamily</p + ></div + ></div + ></div + ></div + ></div + ><div id="footer" + ><p + >Produced by <a href="" + >Haddock</a + > version 2.12.0</p + ></div + ></body + ></html +> diff --git a/tests/html-tests/tests/DeprecatedTypeSynonym.hs b/tests/html-tests/tests/DeprecatedTypeSynonym.hs new file mode 100644 index 00000000..34df47da --- /dev/null +++ b/tests/html-tests/tests/DeprecatedTypeSynonym.hs @@ -0,0 +1,9 @@ + +module DeprecatedTypeSynonym where + +-- | some documentation +type TypeSyn = String +{-# DEPRECATED TypeSyn "TypeSyn" #-} + +type OtherTypeSyn = String +{-# DEPRECATED OtherTypeSyn "OtherTypeSyn" #-} diff --git a/tests/html-tests/tests/DeprecatedTypeSynonym.html.ref b/tests/html-tests/tests/DeprecatedTypeSynonym.html.ref new file mode 100644 index 00000000..7cea8770 --- /dev/null +++ b/tests/html-tests/tests/DeprecatedTypeSynonym.html.ref @@ -0,0 +1,114 @@ +<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd"> +<html xmlns="http://www.w3.org/1999/xhtml" +><head + ><meta http-equiv="Content-Type" content="text/html; charset=UTF-8" + /><title + >DeprecatedTypeSynonym</title + ><link href="ocean.css" rel="stylesheet" type="text/css" title="Ocean" + /><script src="haddock-util.js" type="text/javascript" + ></script + ><script type="text/javascript" + >//<![CDATA[ +window.onload = function () {pageLoad();setSynopsis("mini_DeprecatedTypeSynonym.html");}; +//]]> +</script + ></head + ><body + ><div id="package-header" + ><ul class="links" id="page-menu" + ><li + ><a href="" + >Contents</a + ></li + ><li + ><a href="" + >Index</a + ></li + ></ul + ><p class="caption empty" + > </p + ></div + ><div id="content" + ><div id="module-header" + ><table class="info" + ><tr + ><th + >Safe Haskell</th + ><td + >None</td + ></tr + ></table + ><p class="caption" + >DeprecatedTypeSynonym</p + ></div + ><div id="synopsis" + ><p id="control.syn" class="caption expander" onclick="toggleSection('syn')" + >Synopsis</p + ><ul id="section.syn" class="hide" onclick="toggleSection('syn')" + ><li class="src short" + ><span class="keyword" + >type</span + > <a href="" + >TypeSyn</a + > = <a href="" + >String</a + ></li + ><li class="src short" + ><span class="keyword" + >type</span + > <a href="" + >OtherTypeSyn</a + > = <a href="" + >String</a + ></li + ></ul + ></div + ><div id="interface" + ><h1 + >Documentation</h1 + ><div class="top" + ><p class="src" + ><span class="keyword" + >type</span + > <a name="t:TypeSyn" class="def" + >TypeSyn</a + > = <a href="" + >String</a + ></p + ><div class="doc" + ><div class="warning" + ><p + >Deprecated: TypeSyn</p + ></div + ><p + >some documentation +</p + ></div + ></div + ><div class="top" + ><p class="src" + ><span class="keyword" + >type</span + > <a name="t:OtherTypeSyn" class="def" + >OtherTypeSyn</a + > = <a href="" + >String</a + ></p + ><div class="doc" + ><div class="warning" + ><p + >Deprecated: OtherTypeSyn</p + ></div + ></div + ></div + ></div + ></div + ><div id="footer" + ><p + >Produced by <a href="" + >Haddock</a + > version 2.12.0</p + ></div + ></body + ></html +> diff --git a/tests/html-tests/tests/Examples.html.ref b/tests/html-tests/tests/Examples.html.ref index 4a44907c..714ba4c9 100644 --- a/tests/html-tests/tests/Examples.html.ref +++ b/tests/html-tests/tests/Examples.html.ref @@ -25,7 +25,7 @@ window.onload = function () {pageLoad();setSynopsis("mini_Examples.html");}; >Index</a ></li ></ul - ><p class="caption" class="empty" + ><p class="caption empty" > </p ></div ><div id="content" @@ -172,7 +172,7 @@ bar ><p >Produced by <a href="" >Haddock</a - > version 2.10.0</p + > version 2.12.0</p ></div ></body ></html diff --git a/tests/html-tests/tests/FunArgs.html.ref b/tests/html-tests/tests/FunArgs.html.ref index 15be13a7..0c551487 100644 --- a/tests/html-tests/tests/FunArgs.html.ref +++ b/tests/html-tests/tests/FunArgs.html.ref @@ -25,7 +25,7 @@ window.onload = function () {pageLoad();setSynopsis("mini_FunArgs.html");}; >Index</a ></li ></ul - ><p class="caption" class="empty" + ><p class="caption empty" > </p ></div ><div id="content" @@ -105,9 +105,7 @@ window.onload = function () {pageLoad();setSynopsis("mini_FunArgs.html");}; ></tr ><tr ><td class="src" - >-> <a href="" - >()</a - ></td + >-> ()</td ><td class="doc" ><p >Result @@ -171,7 +169,7 @@ window.onload = function () {pageLoad();setSynopsis("mini_FunArgs.html");}; ><p >Produced by <a href="" >Haddock</a - > version 2.10.0</p + > version 2.12.0</p ></div ></body ></html diff --git a/tests/html-tests/tests/GADTRecords.html.ref b/tests/html-tests/tests/GADTRecords.html.ref index 349a9d10..bb6d3398 100644 --- a/tests/html-tests/tests/GADTRecords.html.ref +++ b/tests/html-tests/tests/GADTRecords.html.ref @@ -25,7 +25,7 @@ window.onload = function () {pageLoad();setSynopsis("mini_GADTRecords.html");}; >Index</a ></li ></ul - ><p class="caption" class="empty" + ><p class="caption empty" > </p ></div ><div id="content" @@ -227,7 +227,7 @@ window.onload = function () {pageLoad();setSynopsis("mini_GADTRecords.html");}; ><p >Produced by <a href="" >Haddock</a - > version 2.10.0</p + > version 2.12.0</p ></div ></body ></html diff --git a/tests/html-tests/tests/Hash.html.ref b/tests/html-tests/tests/Hash.html.ref index b6ee0c26..889ec1d9 100644 --- a/tests/html-tests/tests/Hash.html.ref +++ b/tests/html-tests/tests/Hash.html.ref @@ -25,7 +25,7 @@ window.onload = function () {pageLoad();setSynopsis("mini_Hash.html");}; >Index</a ></li ></ul - ><p class="caption" class="empty" + ><p class="caption empty" > </p ></div ><div id="content" @@ -113,9 +113,7 @@ window.onload = function () {pageLoad();setSynopsis("mini_Hash.html");}; >Hash</a > key) => key -> val -> <a href="" >IO</a - > <a href="" - >()</a - ></li + > ()</li ><li class="src short" ><a href="" >lookup</a @@ -210,9 +208,7 @@ window.onload = function () {pageLoad();setSynopsis("mini_Hash.html");}; >Hash</a > key) => key -> val -> <a href="" >IO</a - > <a href="" - >()</a - ></p + > ()</p ><div class="doc" ><p >Inserts a new element into the hash table @@ -334,7 +330,7 @@ window.onload = function () {pageLoad();setSynopsis("mini_Hash.html");}; ><p >Produced by <a href="" >Haddock</a - > version 2.10.0</p + > version 2.12.0</p ></div ></body ></html diff --git a/tests/html-tests/tests/Hyperlinks.hs b/tests/html-tests/tests/Hyperlinks.hs new file mode 100644 index 00000000..34e64448 --- /dev/null +++ b/tests/html-tests/tests/Hyperlinks.hs @@ -0,0 +1,8 @@ +module Hyperlinks where + +-- | +-- A plain URL: <http://example.com/> +-- +-- A URL with a label: <http://example.com/ some link> +foo :: Int +foo = 23 diff --git a/tests/html-tests/tests/Hyperlinks.html.ref b/tests/html-tests/tests/Hyperlinks.html.ref new file mode 100644 index 00000000..d8cd7757 --- /dev/null +++ b/tests/html-tests/tests/Hyperlinks.html.ref @@ -0,0 +1,89 @@ +<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd"> +<html xmlns="http://www.w3.org/1999/xhtml" +><head + ><meta http-equiv="Content-Type" content="text/html; charset=UTF-8" + /><title + >Hyperlinks</title + ><link href="ocean.css" rel="stylesheet" type="text/css" title="Ocean" + /><script src="haddock-util.js" type="text/javascript" + ></script + ><script type="text/javascript" + >//<![CDATA[ +window.onload = function () {pageLoad();setSynopsis("mini_Hyperlinks.html");}; +//]]> +</script + ></head + ><body + ><div id="package-header" + ><ul class="links" id="page-menu" + ><li + ><a href="" + >Contents</a + ></li + ><li + ><a href="" + >Index</a + ></li + ></ul + ><p class="caption empty" + > </p + ></div + ><div id="content" + ><div id="module-header" + ><table class="info" + ><tr + ><th + >Safe Haskell</th + ><td + >None</td + ></tr + ></table + ><p class="caption" + >Hyperlinks</p + ></div + ><div id="synopsis" + ><p id="control.syn" class="caption expander" onclick="toggleSection('syn')" + >Synopsis</p + ><ul id="section.syn" class="hide" onclick="toggleSection('syn')" + ><li class="src short" + ><a href="" + >foo</a + > :: <a href="" + >Int</a + ></li + ></ul + ></div + ><div id="interface" + ><h1 + >Documentation</h1 + ><div class="top" + ><p class="src" + ><a name="v:foo" class="def" + >foo</a + > :: <a href="" + >Int</a + ></p + ><div class="doc" + ><p + >A plain URL: <a href="" + >http://example.com/</a + > +</p + ><p + >A URL with a label: <a href="" + >some link</a + > +</p + ></div + ></div + ></div + ></div + ><div id="footer" + ><p + >Produced by <a href="" + >Haddock</a + > version 2.12.0</p + ></div + ></body + ></html +> diff --git a/tests/html-tests/tests/IgnoreExports.hs b/tests/html-tests/tests/IgnoreExports.hs new file mode 100644 index 00000000..0321ad02 --- /dev/null +++ b/tests/html-tests/tests/IgnoreExports.hs @@ -0,0 +1,10 @@ +{-# OPTIONS_HADDOCK ignore-exports #-} +module IgnoreExports (foo) where + +-- | documentation for foo +foo :: Int +foo = 23 + +-- | documentation for bar +bar :: Int +bar = 23 diff --git a/tests/html-tests/tests/IgnoreExports.html.ref b/tests/html-tests/tests/IgnoreExports.html.ref new file mode 100644 index 00000000..0a42572a --- /dev/null +++ b/tests/html-tests/tests/IgnoreExports.html.ref @@ -0,0 +1,101 @@ +<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd"> +<html xmlns="http://www.w3.org/1999/xhtml" +><head + ><meta http-equiv="Content-Type" content="text/html; charset=UTF-8" + /><title + >IgnoreExports</title + ><link href="ocean.css" rel="stylesheet" type="text/css" title="Ocean" + /><script src="haddock-util.js" type="text/javascript" + ></script + ><script type="text/javascript" + >//<![CDATA[ +window.onload = function () {pageLoad();setSynopsis("mini_IgnoreExports.html");}; +//]]> +</script + ></head + ><body + ><div id="package-header" + ><ul class="links" id="page-menu" + ><li + ><a href="" + >Contents</a + ></li + ><li + ><a href="" + >Index</a + ></li + ></ul + ><p class="caption empty" + > </p + ></div + ><div id="content" + ><div id="module-header" + ><table class="info" + ><tr + ><th + >Safe Haskell</th + ><td + >None</td + ></tr + ></table + ><p class="caption" + >IgnoreExports</p + ></div + ><div id="synopsis" + ><p id="control.syn" class="caption expander" onclick="toggleSection('syn')" + >Synopsis</p + ><ul id="section.syn" class="hide" onclick="toggleSection('syn')" + ><li class="src short" + ><a href="" + >foo</a + > :: <a href="" + >Int</a + ></li + ><li class="src short" + ><a href="" + >bar</a + > :: <a href="" + >Int</a + ></li + ></ul + ></div + ><div id="interface" + ><h1 + >Documentation</h1 + ><div class="top" + ><p class="src" + ><a name="v:foo" class="def" + >foo</a + > :: <a href="" + >Int</a + ></p + ><div class="doc" + ><p + >documentation for foo +</p + ></div + ></div + ><div class="top" + ><p class="src" + ><a name="v:bar" class="def" + >bar</a + > :: <a href="" + >Int</a + ></p + ><div class="doc" + ><p + >documentation for bar +</p + ></div + ></div + ></div + ></div + ><div id="footer" + ><p + >Produced by <a href="" + >Haddock</a + > version 2.12.0</p + ></div + ></body + ></html +> diff --git a/tests/html-tests/tests/ModuleWithWarning.hs b/tests/html-tests/tests/ModuleWithWarning.hs new file mode 100644 index 00000000..2114bac6 --- /dev/null +++ b/tests/html-tests/tests/ModuleWithWarning.hs @@ -0,0 +1,5 @@ +-- | Documentation for "ModuleWithWarning". +module ModuleWithWarning {-# WARNING "This is an unstable interface." #-} where + +foo :: Int +foo = 23 diff --git a/tests/html-tests/tests/ModuleWithWarning.html.ref b/tests/html-tests/tests/ModuleWithWarning.html.ref new file mode 100644 index 00000000..a7358018 --- /dev/null +++ b/tests/html-tests/tests/ModuleWithWarning.html.ref @@ -0,0 +1,80 @@ +<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd"> +<html xmlns="http://www.w3.org/1999/xhtml" +><head + ><meta http-equiv="Content-Type" content="text/html; charset=UTF-8" + /><title + >ModuleWithWarning</title + ><link href="ocean.css" rel="stylesheet" type="text/css" title="Ocean" + /><script src="haddock-util.js" type="text/javascript" + ></script + ><script type="text/javascript" + >//<![CDATA[ +window.onload = function () {pageLoad();setSynopsis("mini_ModuleWithWarning.html");}; +//]]> +</script + ></head + ><body + ><div id="package-header" + ><ul class="links" id="page-menu" + ><li + ><a href="" + >Contents</a + ></li + ><li + ><a href="" + >Index</a + ></li + ></ul + ><p class="caption empty" + > </p + ></div + ><div id="content" + ><div id="module-header" + ><table class="info" + ><tr + ><th + >Safe Haskell</th + ><td + >None</td + ></tr + ></table + ><p class="caption" + >ModuleWithWarning</p + ></div + ><div id="description" + ><p class="caption" + >Description</p + ><div class="doc" + ><div class="warning" + ><p + >Warning: This is an unstable interface.</p + ></div + ><p + >Documentation for <a href="" + >ModuleWithWarning</a + >. +</p + ></div + ></div + ><div id="interface" + ><h1 + >Documentation</h1 + ><div class="top" + ><p class="src" + ><a name="v:foo" class="def" + >foo</a + > :: <a href="" + >Int</a + ></p + ></div + ></div + ></div + ><div id="footer" + ><p + >Produced by <a href="" + >Haddock</a + > version 2.12.0</p + ></div + ></body + ></html +> diff --git a/tests/html-tests/tests/NamedDoc.html.ref b/tests/html-tests/tests/NamedDoc.html.ref index 40c4ebeb..56da6d84 100644 --- a/tests/html-tests/tests/NamedDoc.html.ref +++ b/tests/html-tests/tests/NamedDoc.html.ref @@ -25,7 +25,7 @@ window.onload = function () {pageLoad();setSynopsis("mini_NamedDoc.html");}; >Index</a ></li ></ul - ><p class="caption" class="empty" + ><p class="caption empty" > </p ></div ><div id="content" @@ -61,7 +61,7 @@ window.onload = function () {pageLoad();setSynopsis("mini_NamedDoc.html");}; ><p >Produced by <a href="" >Haddock</a - > version 2.10.0</p + > version 2.12.0</p ></div ></body ></html diff --git a/tests/html-tests/tests/NoLayout.html.ref b/tests/html-tests/tests/NoLayout.html.ref index cdf0e799..6951a63a 100644 --- a/tests/html-tests/tests/NoLayout.html.ref +++ b/tests/html-tests/tests/NoLayout.html.ref @@ -25,7 +25,7 @@ window.onload = function () {pageLoad();setSynopsis("mini_NoLayout.html");}; >Index</a ></li ></ul - ><p class="caption" class="empty" + ><p class="caption empty" > </p ></div ><div id="content" @@ -79,7 +79,7 @@ window.onload = function () {pageLoad();setSynopsis("mini_NoLayout.html");}; ><p >Produced by <a href="" >Haddock</a - > version 2.10.0</p + > version 2.12.0</p ></div ></body ></html diff --git a/tests/html-tests/tests/NonGreedy.html.ref b/tests/html-tests/tests/NonGreedy.html.ref index c707a6bc..80cd0fc0 100644 --- a/tests/html-tests/tests/NonGreedy.html.ref +++ b/tests/html-tests/tests/NonGreedy.html.ref @@ -25,7 +25,7 @@ window.onload = function () {pageLoad();setSynopsis("mini_NonGreedy.html");}; >Index</a ></li ></ul - ><p class="caption" class="empty" + ><p class="caption empty" > </p ></div ><div id="content" @@ -75,7 +75,7 @@ window.onload = function () {pageLoad();setSynopsis("mini_NonGreedy.html");}; ><p >Produced by <a href="" >Haddock</a - > version 2.10.0</p + > version 2.12.0</p ></div ></body ></html diff --git a/tests/html-tests/tests/PruneWithWarning.hs b/tests/html-tests/tests/PruneWithWarning.hs new file mode 100644 index 00000000..fefe81f5 --- /dev/null +++ b/tests/html-tests/tests/PruneWithWarning.hs @@ -0,0 +1,9 @@ +{-# OPTIONS_HADDOCK prune #-} +module PruneWithWarning (foo, bar) where + +foo :: Int +foo = 23 +{-# DEPRECATED foo "use bar instead" #-} + +bar :: Int +bar = 42 diff --git a/tests/html-tests/tests/PruneWithWarning.html.ref b/tests/html-tests/tests/PruneWithWarning.html.ref new file mode 100644 index 00000000..e5c1ea5b --- /dev/null +++ b/tests/html-tests/tests/PruneWithWarning.html.ref @@ -0,0 +1,55 @@ +<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd"> +<html xmlns="http://www.w3.org/1999/xhtml" +><head + ><meta http-equiv="Content-Type" content="text/html; charset=UTF-8" + /><title + >PruneWithWarning</title + ><link href="ocean.css" rel="stylesheet" type="text/css" title="Ocean" + /><script src="haddock-util.js" type="text/javascript" + ></script + ><script type="text/javascript" + >//<![CDATA[ +window.onload = function () {pageLoad();setSynopsis("mini_PruneWithWarning.html");}; +//]]> +</script + ></head + ><body + ><div id="package-header" + ><ul class="links" id="page-menu" + ><li + ><a href="" + >Contents</a + ></li + ><li + ><a href="" + >Index</a + ></li + ></ul + ><p class="caption empty" + > </p + ></div + ><div id="content" + ><div id="module-header" + ><table class="info" + ><tr + ><th + >Safe Haskell</th + ><td + >None</td + ></tr + ></table + ><p class="caption" + >PruneWithWarning</p + ></div + ><div id="interface" + ></div + ></div + ><div id="footer" + ><p + >Produced by <a href="" + >Haddock</a + > version 2.12.0</p + ></div + ></body + ></html +> diff --git a/tests/html-tests/tests/QuasiExpr.html.ref b/tests/html-tests/tests/QuasiExpr.html.ref index 8241c3f7..288af484 100644 --- a/tests/html-tests/tests/QuasiExpr.html.ref +++ b/tests/html-tests/tests/QuasiExpr.html.ref @@ -25,7 +25,7 @@ window.onload = function () {pageLoad();setSynopsis("mini_QuasiExpr.html");}; >Index</a ></li ></ul - ><p class="caption" class="empty" + ><p class="caption empty" > </p ></div ><div id="content" @@ -214,7 +214,7 @@ window.onload = function () {pageLoad();setSynopsis("mini_QuasiExpr.html");}; ><p >Produced by <a href="" >Haddock</a - > version 2.10.0</p + > version 2.12.0</p ></div ></body ></html diff --git a/tests/html-tests/tests/QuasiQuote.html.ref b/tests/html-tests/tests/QuasiQuote.html.ref index 2613b657..30e124b9 100644 --- a/tests/html-tests/tests/QuasiQuote.html.ref +++ b/tests/html-tests/tests/QuasiQuote.html.ref @@ -25,7 +25,7 @@ window.onload = function () {pageLoad();setSynopsis("mini_QuasiQuote.html");}; >Index</a ></li ></ul - ><p class="caption" class="empty" + ><p class="caption empty" > </p ></div ><div id="content" @@ -58,7 +58,7 @@ window.onload = function () {pageLoad();setSynopsis("mini_QuasiQuote.html");}; ><p >Produced by <a href="" >Haddock</a - > version 2.10.0</p + > version 2.12.0</p ></div ></body ></html diff --git a/tests/html-tests/tests/TH.html.ref b/tests/html-tests/tests/TH.html.ref index 2deb950d..711b7b2a 100644 --- a/tests/html-tests/tests/TH.html.ref +++ b/tests/html-tests/tests/TH.html.ref @@ -25,7 +25,7 @@ window.onload = function () {pageLoad();setSynopsis("mini_TH.html");}; >Index</a ></li ></ul - ><p class="caption" class="empty" + ><p class="caption empty" > </p ></div ><div id="content" @@ -56,7 +56,7 @@ window.onload = function () {pageLoad();setSynopsis("mini_TH.html");}; ><p >Produced by <a href="" >Haddock</a - > version 2.10.0</p + > version 2.12.0</p ></div ></body ></html diff --git a/tests/html-tests/tests/TH2.html.ref b/tests/html-tests/tests/TH2.html.ref index 3d284850..56955ce5 100644 --- a/tests/html-tests/tests/TH2.html.ref +++ b/tests/html-tests/tests/TH2.html.ref @@ -25,7 +25,7 @@ window.onload = function () {pageLoad();setSynopsis("mini_TH2.html");}; >Index</a ></li ></ul - ><p class="caption" class="empty" + ><p class="caption empty" > </p ></div ><div id="content" @@ -56,7 +56,7 @@ window.onload = function () {pageLoad();setSynopsis("mini_TH2.html");}; ><p >Produced by <a href="" >Haddock</a - > version 2.10.0</p + > version 2.12.0</p ></div ></body ></html diff --git a/tests/html-tests/tests/Test.html.ref b/tests/html-tests/tests/Test.html.ref index 84d28b10..3ee3706b 100644 --- a/tests/html-tests/tests/Test.html.ref +++ b/tests/html-tests/tests/Test.html.ref @@ -25,7 +25,7 @@ window.onload = function () {pageLoad();setSynopsis("mini_Test.html");}; >Index</a ></li ></ul - ><p class="caption" class="empty" + ><p class="caption empty" > </p ></div ><div id="content" @@ -410,11 +410,7 @@ window.onload = function () {pageLoad();setSynopsis("mini_Test.html");}; >Float</a > -> <a href="" >T5</a - > <a href="" - >()</a - > <a href="" - >()</a - ></li + > () ()</li ><li ><a href="" >u</a @@ -590,11 +586,7 @@ window.onload = function () {pageLoad();setSynopsis("mini_Test.html");}; >k</a > :: <a href="" >T</a - > <a href="" - >()</a - > <a href="" - >()</a - > -> <a href="" + > () () -> <a href="" >T2</a > <a href="" >Int</a @@ -614,15 +606,9 @@ window.onload = function () {pageLoad();setSynopsis("mini_Test.html");}; >Float</a >) -> <a href="" >T5</a - > <a href="" - >()</a - > <a href="" - >()</a - > -> <a href="" + > () () -> <a href="" >IO</a - > <a href="" - >()</a - ></li + > ()</li ><li class="src short" ><a href="" >l</a @@ -642,9 +628,7 @@ window.onload = function () {pageLoad();setSynopsis("mini_Test.html");}; >R</a > -> <a href="" >N1</a - > <a href="" - >()</a - > -> <a href="" + > () -> <a href="" >IO</a > <a href="" >Int</a @@ -1391,11 +1375,7 @@ window.onload = function () {pageLoad();setSynopsis("mini_Test.html");}; >Float</a > -> <a href="" >T5</a - > <a href="" - >()</a - > <a href="" - >()</a - ></dt + > () ()</dt ><dd class="doc empty" > </dd ><dt class="src" @@ -1981,11 +1961,7 @@ test2 ><td class="src" >:: <a href="" >T</a - > <a href="" - >()</a - > <a href="" - >()</a - ></td + > () ()</td ><td class="doc" ><p >This argument has type <code @@ -2038,11 +2014,7 @@ test2 ><td class="src" >-> <a href="" >T5</a - > <a href="" - >()</a - > <a href="" - >()</a - ></td + > () ()</td ><td class="doc" ><p >This argument has a very long description that should @@ -2055,9 +2027,7 @@ test2 ><td class="src" >-> <a href="" >IO</a - > <a href="" - >()</a - ></td + > ()</td ><td class="doc" ><p >This is the result type @@ -2135,9 +2105,7 @@ test2 ><td class="src" >-> <a href="" >N1</a - > <a href="" - >()</a - ></td + > ()</td ><td class="doc" ><p >one of the arguments @@ -2270,7 +2238,7 @@ test2 ><p >Produced by <a href="" >Haddock</a - > version 2.10.0</p + > version 2.12.0</p ></div ></body ></html diff --git a/tests/html-tests/tests/Ticket112.html.ref b/tests/html-tests/tests/Ticket112.html.ref index b21f628c..dfda7125 100644 --- a/tests/html-tests/tests/Ticket112.html.ref +++ b/tests/html-tests/tests/Ticket112.html.ref @@ -25,7 +25,7 @@ window.onload = function () {pageLoad();setSynopsis("mini_Ticket112.html");}; >Index</a ></li ></ul - ><p class="caption" class="empty" + ><p class="caption empty" > </p ></div ><div id="content" @@ -75,7 +75,7 @@ window.onload = function () {pageLoad();setSynopsis("mini_Ticket112.html");}; ><p >Produced by <a href="" >Haddock</a - > version 2.10.0</p + > version 2.12.0</p ></div ></body ></html diff --git a/tests/html-tests/tests/Ticket61.html.ref b/tests/html-tests/tests/Ticket61.html.ref index 111c2cc3..6dcdb59e 100644 --- a/tests/html-tests/tests/Ticket61.html.ref +++ b/tests/html-tests/tests/Ticket61.html.ref @@ -25,7 +25,7 @@ window.onload = function () {pageLoad();setSynopsis("mini_Ticket61.html");}; >Index</a ></li ></ul - ><p class="caption" class="empty" + ><p class="caption empty" > </p ></div ><div id="content" @@ -73,7 +73,7 @@ window.onload = function () {pageLoad();setSynopsis("mini_Ticket61.html");}; ><p >Produced by <a href="" >Haddock</a - > version 2.10.0</p + > version 2.12.0</p ></div ></body ></html diff --git a/tests/html-tests/tests/Ticket75.html.ref b/tests/html-tests/tests/Ticket75.html.ref index e9fef85a..4f8f466a 100644 --- a/tests/html-tests/tests/Ticket75.html.ref +++ b/tests/html-tests/tests/Ticket75.html.ref @@ -25,7 +25,7 @@ window.onload = function () {pageLoad();setSynopsis("mini_Ticket75.html");}; >Index</a ></li ></ul - ><p class="caption" class="empty" + ><p class="caption empty" > </p ></div ><div id="content" @@ -109,7 +109,7 @@ window.onload = function () {pageLoad();setSynopsis("mini_Ticket75.html");}; ><p >Produced by <a href="" >Haddock</a - > version 2.10.0</p + > version 2.12.0</p ></div ></body ></html diff --git a/tests/html-tests/tests/TypeFamilies.html.ref b/tests/html-tests/tests/TypeFamilies.html.ref index a3d94bb0..ccd771f0 100644 --- a/tests/html-tests/tests/TypeFamilies.html.ref +++ b/tests/html-tests/tests/TypeFamilies.html.ref @@ -25,7 +25,7 @@ window.onload = function () {pageLoad();setSynopsis("mini_TypeFamilies.html");}; >Index</a ></li ></ul - ><p class="caption" class="empty" + ><p class="caption empty" > </p ></div ><div id="content" @@ -205,7 +205,7 @@ window.onload = function () {pageLoad();setSynopsis("mini_TypeFamilies.html");}; ><p >Produced by <a href="" >Haddock</a - > version 2.10.0</p + > version 2.12.0</p ></div ></body ></html diff --git a/tests/html-tests/tests/TypeOperators.html.ref b/tests/html-tests/tests/TypeOperators.html.ref index 59f47a55..0155ab0d 100644 --- a/tests/html-tests/tests/TypeOperators.html.ref +++ b/tests/html-tests/tests/TypeOperators.html.ref @@ -25,7 +25,7 @@ window.onload = function () {pageLoad();setSynopsis("mini_TypeOperators.html");} >Index</a ></li ></ul - ><p class="caption" class="empty" + ><p class="caption empty" > </p ></div ><div id="content" @@ -232,7 +232,7 @@ window.onload = function () {pageLoad();setSynopsis("mini_TypeOperators.html");} ><p >Produced by <a href="" >Haddock</a - > version 2.10.0</p + > version 2.12.0</p ></div ></body ></html diff --git a/tests/html-tests/tests/Unicode.html.ref b/tests/html-tests/tests/Unicode.html.ref index d234d374..74c8fa90 100644 --- a/tests/html-tests/tests/Unicode.html.ref +++ b/tests/html-tests/tests/Unicode.html.ref @@ -25,7 +25,7 @@ window.onload = function () {pageLoad();setSynopsis("mini_Unicode.html");}; >Index</a ></li ></ul - ><p class="caption" class="empty" + ><p class="caption empty" > </p ></div ><div id="content" @@ -75,7 +75,7 @@ window.onload = function () {pageLoad();setSynopsis("mini_Unicode.html");}; ><p >Produced by <a href="" >Haddock</a - > version 2.10.0</p + > version 2.12.0</p ></div ></body ></html diff --git a/tests/html-tests/tests/Visible.html.ref b/tests/html-tests/tests/Visible.html.ref index a2c52407..2b829d3c 100644 --- a/tests/html-tests/tests/Visible.html.ref +++ b/tests/html-tests/tests/Visible.html.ref @@ -25,7 +25,7 @@ window.onload = function () {pageLoad();setSynopsis("mini_Visible.html");}; >Index</a ></li ></ul - ><p class="caption" class="empty" + ><p class="caption empty" > </p ></div ><div id="content" @@ -60,7 +60,7 @@ window.onload = function () {pageLoad();setSynopsis("mini_Visible.html");}; ><p >Produced by <a href="" >Haddock</a - > version 2.10.0</p + > version 2.12.0</p ></div ></body ></html diff --git a/tests/html-tests/tests/frames.html.ref b/tests/html-tests/tests/frames.html.ref new file mode 100644 index 00000000..1b4e38d4 --- /dev/null +++ b/tests/html-tests/tests/frames.html.ref @@ -0,0 +1,30 @@ +<!DOCTYPE html + PUBLIC "-//W3C//DTD XHTML 1.0 Frameset//EN" + "http://www.w3.org/TR/xhtml1/DTD/xhtml1-frameset.dtd"> +<html xmlns="http://www.w3.org/1999/xhtml"> +<head> +<title></title> +<script src="haddock-util.js" type="text/javascript"></script> +<script type="text/javascript"><!-- +/* + + The synopsis frame needs to be updated using javascript, so we hide + it by default and only show it if javascript is enabled. + + TODO: provide some means to disable it. +*/ +function load() { + var d = document.getElementById("inner-fs"); + d.rows = "50%,50%"; + postReframe(); +} +--></script> +</head> +<frameset id="outer-fs" cols="25%,75%" onload="load()"> + <frameset id="inner-fs" rows="100%,0%"> + <frame src="index-frames.html" name="modules" /> + <frame src="" name="synopsis" /> + </frameset> + <frame src="index.html" name="main" /> +</frameset> +</html> diff --git a/tests/html-tests/tests/mini_A.html.ref b/tests/html-tests/tests/mini_A.html.ref new file mode 100644 index 00000000..cbe50e41 --- /dev/null +++ b/tests/html-tests/tests/mini_A.html.ref @@ -0,0 +1,59 @@ +<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd"> +<html xmlns="http://www.w3.org/1999/xhtml" +><head + ><meta http-equiv="Content-Type" content="text/html; charset=UTF-8" + /><title + >A</title + ><link href="ocean.css" rel="stylesheet" type="text/css" title="Ocean" + /><script src="haddock-util.js" type="text/javascript" + ></script + ><script type="text/javascript" + >//<![CDATA[ +window.onload = function () {pageLoad();}; +//]]> +</script + ></head + ><body id="mini" + ><div id="module-header" + ><p class="caption" + >A</p + ></div + ><div id="interface" + ><div class="top" + ><p class="src" + ><span class="keyword" + >data</span + > <a href="" target="main" + >A</a + > </p + ></div + ><div class="top" + ><p class="src" + ><a href="" target="main" + >other</a + ></p + ></div + ><div class="top" + ><p class="src" + ><a href="" target="main" + >test2</a + ></p + ></div + ><div class="top" + ><p class="src" + ><span class="keyword" + >data</span + > <a href="" target="main" + >X</a + > </p + ></div + ><div class="top" + ><p class="src" + ><a href="" target="main" + >reExport</a + ></p + ></div + ></div + ></body + ></html +> diff --git a/tests/html-tests/tests/mini_B.html.ref b/tests/html-tests/tests/mini_B.html.ref new file mode 100644 index 00000000..211a7deb --- /dev/null +++ b/tests/html-tests/tests/mini_B.html.ref @@ -0,0 +1,45 @@ +<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd"> +<html xmlns="http://www.w3.org/1999/xhtml" +><head + ><meta http-equiv="Content-Type" content="text/html; charset=UTF-8" + /><title + >B</title + ><link href="ocean.css" rel="stylesheet" type="text/css" title="Ocean" + /><script src="haddock-util.js" type="text/javascript" + ></script + ><script type="text/javascript" + >//<![CDATA[ +window.onload = function () {pageLoad();}; +//]]> +</script + ></head + ><body id="mini" + ><div id="module-header" + ><p class="caption" + >B</p + ></div + ><div id="interface" + ><div class="top" + ><p class="src" + ><a href="" target="main" + >test</a + ></p + ></div + ><div class="top" + ><p class="src" + ><a href="" target="main" + >reExport</a + ></p + ></div + ><div class="top" + ><p class="src" + ><span class="keyword" + >data</span + > <a href="" target="main" + >X</a + > </p + ></div + ></div + ></body + ></html +> diff --git a/tests/html-tests/tests/mini_Bug1.html.ref b/tests/html-tests/tests/mini_Bug1.html.ref new file mode 100644 index 00000000..adf81c73 --- /dev/null +++ b/tests/html-tests/tests/mini_Bug1.html.ref @@ -0,0 +1,33 @@ +<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd"> +<html xmlns="http://www.w3.org/1999/xhtml" +><head + ><meta http-equiv="Content-Type" content="text/html; charset=UTF-8" + /><title + >Bug1</title + ><link href="ocean.css" rel="stylesheet" type="text/css" title="Ocean" + /><script src="haddock-util.js" type="text/javascript" + ></script + ><script type="text/javascript" + >//<![CDATA[ +window.onload = function () {pageLoad();}; +//]]> +</script + ></head + ><body id="mini" + ><div id="module-header" + ><p class="caption" + >Bug1</p + ></div + ><div id="interface" + ><div class="top" + ><p class="src" + ><span class="keyword" + >data</span + > <a href="" target="main" + >T</a + > </p + ></div + ></div + ></body + ></html +> diff --git a/tests/html-tests/tests/mini_Bug2.html.ref b/tests/html-tests/tests/mini_Bug2.html.ref new file mode 100644 index 00000000..b673e459 --- /dev/null +++ b/tests/html-tests/tests/mini_Bug2.html.ref @@ -0,0 +1,31 @@ +<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd"> +<html xmlns="http://www.w3.org/1999/xhtml" +><head + ><meta http-equiv="Content-Type" content="text/html; charset=UTF-8" + /><title + >Bug2</title + ><link href="ocean.css" rel="stylesheet" type="text/css" title="Ocean" + /><script src="haddock-util.js" type="text/javascript" + ></script + ><script type="text/javascript" + >//<![CDATA[ +window.onload = function () {pageLoad();}; +//]]> +</script + ></head + ><body id="mini" + ><div id="module-header" + ><p class="caption" + >Bug2</p + ></div + ><div id="interface" + ><div class="top" + ><p class="src" + ><a href="" target="main" + >x</a + ></p + ></div + ></div + ></body + ></html +> diff --git a/tests/html-tests/tests/mini_Bug3.html.ref b/tests/html-tests/tests/mini_Bug3.html.ref new file mode 100644 index 00000000..af4cc445 --- /dev/null +++ b/tests/html-tests/tests/mini_Bug3.html.ref @@ -0,0 +1,31 @@ +<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd"> +<html xmlns="http://www.w3.org/1999/xhtml" +><head + ><meta http-equiv="Content-Type" content="text/html; charset=UTF-8" + /><title + >Bug3</title + ><link href="ocean.css" rel="stylesheet" type="text/css" title="Ocean" + /><script src="haddock-util.js" type="text/javascript" + ></script + ><script type="text/javascript" + >//<![CDATA[ +window.onload = function () {pageLoad();}; +//]]> +</script + ></head + ><body id="mini" + ><div id="module-header" + ><p class="caption" + >Bug3</p + ></div + ><div id="interface" + ><div class="top" + ><p class="src" + ><a href="" target="main" + >foo</a + ></p + ></div + ></div + ></body + ></html +> diff --git a/tests/html-tests/tests/mini_Bug4.html.ref b/tests/html-tests/tests/mini_Bug4.html.ref new file mode 100644 index 00000000..b403e94a --- /dev/null +++ b/tests/html-tests/tests/mini_Bug4.html.ref @@ -0,0 +1,31 @@ +<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd"> +<html xmlns="http://www.w3.org/1999/xhtml" +><head + ><meta http-equiv="Content-Type" content="text/html; charset=UTF-8" + /><title + >Bug4</title + ><link href="ocean.css" rel="stylesheet" type="text/css" title="Ocean" + /><script src="haddock-util.js" type="text/javascript" + ></script + ><script type="text/javascript" + >//<![CDATA[ +window.onload = function () {pageLoad();}; +//]]> +</script + ></head + ><body id="mini" + ><div id="module-header" + ><p class="caption" + >Bug4</p + ></div + ><div id="interface" + ><div class="top" + ><p class="src" + ><a href="" target="main" + >foo</a + ></p + ></div + ></div + ></body + ></html +> diff --git a/tests/html-tests/tests/mini_Bug6.html.ref b/tests/html-tests/tests/mini_Bug6.html.ref new file mode 100644 index 00000000..5c5c1119 --- /dev/null +++ b/tests/html-tests/tests/mini_Bug6.html.ref @@ -0,0 +1,65 @@ +<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd"> +<html xmlns="http://www.w3.org/1999/xhtml" +><head + ><meta http-equiv="Content-Type" content="text/html; charset=UTF-8" + /><title + >Bug6</title + ><link href="ocean.css" rel="stylesheet" type="text/css" title="Ocean" + /><script src="haddock-util.js" type="text/javascript" + ></script + ><script type="text/javascript" + >//<![CDATA[ +window.onload = function () {pageLoad();}; +//]]> +</script + ></head + ><body id="mini" + ><div id="module-header" + ><p class="caption" + >Bug6</p + ></div + ><div id="interface" + ><div class="top" + ><p class="src" + ><span class="keyword" + >data</span + > <a href="" target="main" + >A</a + > </p + ></div + ><div class="top" + ><p class="src" + ><span class="keyword" + >data</span + > <a href="" target="main" + >B</a + > </p + ></div + ><div class="top" + ><p class="src" + ><span class="keyword" + >data</span + > <a href="" target="main" + >C</a + > </p + ></div + ><div class="top" + ><p class="src" + ><span class="keyword" + >data</span + > <a href="" target="main" + >D</a + > </p + ></div + ><div class="top" + ><p class="src" + ><span class="keyword" + >data</span + > <a href="" target="main" + >E</a + > </p + ></div + ></div + ></body + ></html +> diff --git a/tests/html-tests/tests/mini_Bug7.html.ref b/tests/html-tests/tests/mini_Bug7.html.ref new file mode 100644 index 00000000..1bec82ee --- /dev/null +++ b/tests/html-tests/tests/mini_Bug7.html.ref @@ -0,0 +1,41 @@ +<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd"> +<html xmlns="http://www.w3.org/1999/xhtml" +><head + ><meta http-equiv="Content-Type" content="text/html; charset=UTF-8" + /><title + >Bug7</title + ><link href="ocean.css" rel="stylesheet" type="text/css" title="Ocean" + /><script src="haddock-util.js" type="text/javascript" + ></script + ><script type="text/javascript" + >//<![CDATA[ +window.onload = function () {pageLoad();}; +//]]> +</script + ></head + ><body id="mini" + ><div id="module-header" + ><p class="caption" + >Bug7</p + ></div + ><div id="interface" + ><div class="top" + ><p class="src" + ><span class="keyword" + >data</span + > <a href="" target="main" + >Foo</a + > </p + ></div + ><div class="top" + ><p class="src" + ><span class="keyword" + >class</span + > <a href="" target="main" + >Bar</a + > x y</p + ></div + ></div + ></body + ></html +> diff --git a/tests/html-tests/tests/mini_Bug8.html.ref b/tests/html-tests/tests/mini_Bug8.html.ref new file mode 100644 index 00000000..070dbcf8 --- /dev/null +++ b/tests/html-tests/tests/mini_Bug8.html.ref @@ -0,0 +1,63 @@ +<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd"> +<html xmlns="http://www.w3.org/1999/xhtml" +><head + ><meta http-equiv="Content-Type" content="text/html; charset=UTF-8" + /><title + >Bug8</title + ><link href="ocean.css" rel="stylesheet" type="text/css" title="Ocean" + /><script src="haddock-util.js" type="text/javascript" + ></script + ><script type="text/javascript" + >//<![CDATA[ +window.onload = function () {pageLoad();}; +//]]> +</script + ></head + ><body id="mini" + ><div id="module-header" + ><p class="caption" + >Bug8</p + ></div + ><div id="interface" + ><div class="top" + ><p class="src" + ><span class="keyword" + >data</span + > <a href="" target="main" + >Typ</a + > </p + ></div + ><div class="top" + ><p class="src" + ><a href="" target="main" + >(-->)</a + ></p + ></div + ><div class="top" + ><p class="src" + ><a href="" target="main" + >(--->)</a + ></p + ></div + ><div class="top" + ><p class="src" + ><a href="" target="main" + >s</a + ></p + ></div + ><div class="top" + ><p class="src" + ><a href="" target="main" + >t</a + ></p + ></div + ><div class="top" + ><p class="src" + ><a href="" target="main" + >main</a + ></p + ></div + ></div + ></body + ></html +> diff --git a/tests/html-tests/tests/mini_BugDeprecated.html.ref b/tests/html-tests/tests/mini_BugDeprecated.html.ref new file mode 100644 index 00000000..f0410137 --- /dev/null +++ b/tests/html-tests/tests/mini_BugDeprecated.html.ref @@ -0,0 +1,61 @@ +<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd"> +<html xmlns="http://www.w3.org/1999/xhtml" +><head + ><meta http-equiv="Content-Type" content="text/html; charset=UTF-8" + /><title + >BugDeprecated</title + ><link href="ocean.css" rel="stylesheet" type="text/css" title="Ocean" + /><script src="haddock-util.js" type="text/javascript" + ></script + ><script type="text/javascript" + >//<![CDATA[ +window.onload = function () {pageLoad();}; +//]]> +</script + ></head + ><body id="mini" + ><div id="module-header" + ><p class="caption" + >BugDeprecated</p + ></div + ><div id="interface" + ><div class="top" + ><p class="src" + ><a href="" target="main" + >foo</a + ></p + ></div + ><div class="top" + ><p class="src" + ><a href="" target="main" + >baz</a + ></p + ></div + ><div class="top" + ><p class="src" + ><a href="" target="main" + >bar</a + ></p + ></div + ><div class="top" + ><p class="src" + ><a href="" target="main" + >one</a + ></p + ></div + ><div class="top" + ><p class="src" + ><a href="" target="main" + >three</a + ></p + ></div + ><div class="top" + ><p class="src" + ><a href="" target="main" + >two</a + ></p + ></div + ></div + ></body + ></html +> diff --git a/tests/html-tests/tests/mini_BugExportHeadings.html.ref b/tests/html-tests/tests/mini_BugExportHeadings.html.ref new file mode 100644 index 00000000..b481720d --- /dev/null +++ b/tests/html-tests/tests/mini_BugExportHeadings.html.ref @@ -0,0 +1,79 @@ +<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd"> +<html xmlns="http://www.w3.org/1999/xhtml" +><head + ><meta http-equiv="Content-Type" content="text/html; charset=UTF-8" + /><title + >BugExportHeadings</title + ><link href="ocean.css" rel="stylesheet" type="text/css" title="Ocean" + /><script src="haddock-util.js" type="text/javascript" + ></script + ><script type="text/javascript" + >//<![CDATA[ +window.onload = function () {pageLoad();}; +//]]> +</script + ></head + ><body id="mini" + ><div id="module-header" + ><p class="caption" + >BugExportHeadings</p + ></div + ><div id="interface" + ><h1 + >Foo +</h1 + ><div class="top" + ><p class="src" + ><a href="" target="main" + >foo</a + ></p + ></div + ><h1 + >Bar +</h1 + ><div class="top" + ><p class="src" + ><a href="" target="main" + >bar</a + ></p + ></div + ><h1 + >Baz +</h1 + ><div class="top" + ><p class="src" + ><a href="" target="main" + >baz</a + ></p + ></div + ><h1 + >One +</h1 + ><div class="top" + ><p class="src" + ><a href="" target="main" + >one</a + ></p + ></div + ><h1 + >Two +</h1 + ><div class="top" + ><p class="src" + ><a href="" target="main" + >two</a + ></p + ></div + ><h1 + >Three +</h1 + ><div class="top" + ><p class="src" + ><a href="" target="main" + >three</a + ></p + ></div + ></div + ></body + ></html +> diff --git a/tests/html-tests/tests/mini_Bugs.html.ref b/tests/html-tests/tests/mini_Bugs.html.ref new file mode 100644 index 00000000..3c758375 --- /dev/null +++ b/tests/html-tests/tests/mini_Bugs.html.ref @@ -0,0 +1,33 @@ +<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd"> +<html xmlns="http://www.w3.org/1999/xhtml" +><head + ><meta http-equiv="Content-Type" content="text/html; charset=UTF-8" + /><title + >Bugs</title + ><link href="ocean.css" rel="stylesheet" type="text/css" title="Ocean" + /><script src="haddock-util.js" type="text/javascript" + ></script + ><script type="text/javascript" + >//<![CDATA[ +window.onload = function () {pageLoad();}; +//]]> +</script + ></head + ><body id="mini" + ><div id="module-header" + ><p class="caption" + >Bugs</p + ></div + ><div id="interface" + ><div class="top" + ><p class="src" + ><span class="keyword" + >data</span + > <a href="" target="main" + >A</a + > a</p + ></div + ></div + ></body + ></html +> diff --git a/tests/html-tests/tests/mini_CrossPackageDocs.html.ref b/tests/html-tests/tests/mini_CrossPackageDocs.html.ref new file mode 100644 index 00000000..9d957c1e --- /dev/null +++ b/tests/html-tests/tests/mini_CrossPackageDocs.html.ref @@ -0,0 +1,45 @@ +<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd"> +<html xmlns="http://www.w3.org/1999/xhtml" +><head + ><meta http-equiv="Content-Type" content="text/html; charset=UTF-8" + /><title + >CrossPackageDocs</title + ><link href="ocean.css" rel="stylesheet" type="text/css" title="Ocean" + /><script src="haddock-util.js" type="text/javascript" + ></script + ><script type="text/javascript" + >//<![CDATA[ +window.onload = function () {pageLoad();}; +//]]> +</script + ></head + ><body id="mini" + ><div id="module-header" + ><p class="caption" + >CrossPackageDocs</p + ></div + ><div id="interface" + ><div class="top" + ><p class="src" + ><a href="" target="main" + >map</a + ></p + ></div + ><div class="top" + ><p class="src" + ><span class="keyword" + >class</span + > <a href="" target="main" + >Monad</a + > m</p + ></div + ><div class="top" + ><p class="src" + ><a href="" target="main" + >runInteractiveProcess</a + ></p + ></div + ></div + ></body + ></html +> diff --git a/tests/html-tests/tests/mini_DeprecatedClass.html.ref b/tests/html-tests/tests/mini_DeprecatedClass.html.ref new file mode 100644 index 00000000..3923c1ff --- /dev/null +++ b/tests/html-tests/tests/mini_DeprecatedClass.html.ref @@ -0,0 +1,41 @@ +<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd"> +<html xmlns="http://www.w3.org/1999/xhtml" +><head + ><meta http-equiv="Content-Type" content="text/html; charset=UTF-8" + /><title + >DeprecatedClass</title + ><link href="ocean.css" rel="stylesheet" type="text/css" title="Ocean" + /><script src="haddock-util.js" type="text/javascript" + ></script + ><script type="text/javascript" + >//<![CDATA[ +window.onload = function () {pageLoad();}; +//]]> +</script + ></head + ><body id="mini" + ><div id="module-header" + ><p class="caption" + >DeprecatedClass</p + ></div + ><div id="interface" + ><div class="top" + ><p class="src" + ><span class="keyword" + >class</span + > <a href="" target="main" + >SomeClass</a + > a</p + ></div + ><div class="top" + ><p class="src" + ><span class="keyword" + >class</span + > <a href="" target="main" + >SomeOtherClass</a + > a</p + ></div + ></div + ></body + ></html +> diff --git a/tests/html-tests/tests/mini_DeprecatedData.html.ref b/tests/html-tests/tests/mini_DeprecatedData.html.ref new file mode 100644 index 00000000..8ef20113 --- /dev/null +++ b/tests/html-tests/tests/mini_DeprecatedData.html.ref @@ -0,0 +1,41 @@ +<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd"> +<html xmlns="http://www.w3.org/1999/xhtml" +><head + ><meta http-equiv="Content-Type" content="text/html; charset=UTF-8" + /><title + >DeprecatedData</title + ><link href="ocean.css" rel="stylesheet" type="text/css" title="Ocean" + /><script src="haddock-util.js" type="text/javascript" + ></script + ><script type="text/javascript" + >//<![CDATA[ +window.onload = function () {pageLoad();}; +//]]> +</script + ></head + ><body id="mini" + ><div id="module-header" + ><p class="caption" + >DeprecatedData</p + ></div + ><div id="interface" + ><div class="top" + ><p class="src" + ><span class="keyword" + >data</span + > <a href="" target="main" + >Foo</a + > </p + ></div + ><div class="top" + ><p class="src" + ><span class="keyword" + >data</span + > <a href="" target="main" + >One</a + > </p + ></div + ></div + ></body + ></html +> diff --git a/tests/html-tests/tests/mini_DeprecatedFunction.html.ref b/tests/html-tests/tests/mini_DeprecatedFunction.html.ref new file mode 100644 index 00000000..17d3e526 --- /dev/null +++ b/tests/html-tests/tests/mini_DeprecatedFunction.html.ref @@ -0,0 +1,31 @@ +<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd"> +<html xmlns="http://www.w3.org/1999/xhtml" +><head + ><meta http-equiv="Content-Type" content="text/html; charset=UTF-8" + /><title + >DeprecatedFunction</title + ><link href="ocean.css" rel="stylesheet" type="text/css" title="Ocean" + /><script src="haddock-util.js" type="text/javascript" + ></script + ><script type="text/javascript" + >//<![CDATA[ +window.onload = function () {pageLoad();}; +//]]> +</script + ></head + ><body id="mini" + ><div id="module-header" + ><p class="caption" + >DeprecatedFunction</p + ></div + ><div id="interface" + ><div class="top" + ><p class="src" + ><a href="" target="main" + >foo</a + ></p + ></div + ></div + ></body + ></html +> diff --git a/tests/html-tests/tests/mini_DeprecatedFunction2.html.ref b/tests/html-tests/tests/mini_DeprecatedFunction2.html.ref new file mode 100644 index 00000000..a03991a9 --- /dev/null +++ b/tests/html-tests/tests/mini_DeprecatedFunction2.html.ref @@ -0,0 +1,31 @@ +<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd"> +<html xmlns="http://www.w3.org/1999/xhtml" +><head + ><meta http-equiv="Content-Type" content="text/html; charset=UTF-8" + /><title + >DeprecatedFunction2</title + ><link href="ocean.css" rel="stylesheet" type="text/css" title="Ocean" + /><script src="haddock-util.js" type="text/javascript" + ></script + ><script type="text/javascript" + >//<![CDATA[ +window.onload = function () {pageLoad();}; +//]]> +</script + ></head + ><body id="mini" + ><div id="module-header" + ><p class="caption" + >DeprecatedFunction2</p + ></div + ><div id="interface" + ><div class="top" + ><p class="src" + ><a href="" target="main" + >foo</a + ></p + ></div + ></div + ></body + ></html +> diff --git a/tests/html-tests/tests/mini_DeprecatedFunction3.html.ref b/tests/html-tests/tests/mini_DeprecatedFunction3.html.ref new file mode 100644 index 00000000..4ea60339 --- /dev/null +++ b/tests/html-tests/tests/mini_DeprecatedFunction3.html.ref @@ -0,0 +1,31 @@ +<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd"> +<html xmlns="http://www.w3.org/1999/xhtml" +><head + ><meta http-equiv="Content-Type" content="text/html; charset=UTF-8" + /><title + >DeprecatedFunction3</title + ><link href="ocean.css" rel="stylesheet" type="text/css" title="Ocean" + /><script src="haddock-util.js" type="text/javascript" + ></script + ><script type="text/javascript" + >//<![CDATA[ +window.onload = function () {pageLoad();}; +//]]> +</script + ></head + ><body id="mini" + ><div id="module-header" + ><p class="caption" + >DeprecatedFunction3</p + ></div + ><div id="interface" + ><div class="top" + ><p class="src" + ><a href="" target="main" + >foo</a + ></p + ></div + ></div + ></body + ></html +> diff --git a/tests/html-tests/tests/mini_DeprecatedModule.html.ref b/tests/html-tests/tests/mini_DeprecatedModule.html.ref new file mode 100644 index 00000000..bfdef611 --- /dev/null +++ b/tests/html-tests/tests/mini_DeprecatedModule.html.ref @@ -0,0 +1,31 @@ +<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd"> +<html xmlns="http://www.w3.org/1999/xhtml" +><head + ><meta http-equiv="Content-Type" content="text/html; charset=UTF-8" + /><title + >DeprecatedModule</title + ><link href="ocean.css" rel="stylesheet" type="text/css" title="Ocean" + /><script src="haddock-util.js" type="text/javascript" + ></script + ><script type="text/javascript" + >//<![CDATA[ +window.onload = function () {pageLoad();}; +//]]> +</script + ></head + ><body id="mini" + ><div id="module-header" + ><p class="caption" + >DeprecatedModule</p + ></div + ><div id="interface" + ><div class="top" + ><p class="src" + ><a href="" target="main" + >foo</a + ></p + ></div + ></div + ></body + ></html +> diff --git a/tests/html-tests/tests/mini_DeprecatedModule2.html.ref b/tests/html-tests/tests/mini_DeprecatedModule2.html.ref new file mode 100644 index 00000000..dbcc43b9 --- /dev/null +++ b/tests/html-tests/tests/mini_DeprecatedModule2.html.ref @@ -0,0 +1,31 @@ +<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd"> +<html xmlns="http://www.w3.org/1999/xhtml" +><head + ><meta http-equiv="Content-Type" content="text/html; charset=UTF-8" + /><title + >DeprecatedModule2</title + ><link href="ocean.css" rel="stylesheet" type="text/css" title="Ocean" + /><script src="haddock-util.js" type="text/javascript" + ></script + ><script type="text/javascript" + >//<![CDATA[ +window.onload = function () {pageLoad();}; +//]]> +</script + ></head + ><body id="mini" + ><div id="module-header" + ><p class="caption" + >DeprecatedModule2</p + ></div + ><div id="interface" + ><div class="top" + ><p class="src" + ><a href="" target="main" + >foo</a + ></p + ></div + ></div + ></body + ></html +> diff --git a/tests/html-tests/tests/mini_DeprecatedNewtype.html.ref b/tests/html-tests/tests/mini_DeprecatedNewtype.html.ref new file mode 100644 index 00000000..a913525f --- /dev/null +++ b/tests/html-tests/tests/mini_DeprecatedNewtype.html.ref @@ -0,0 +1,41 @@ +<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd"> +<html xmlns="http://www.w3.org/1999/xhtml" +><head + ><meta http-equiv="Content-Type" content="text/html; charset=UTF-8" + /><title + >DeprecatedNewtype</title + ><link href="ocean.css" rel="stylesheet" type="text/css" title="Ocean" + /><script src="haddock-util.js" type="text/javascript" + ></script + ><script type="text/javascript" + >//<![CDATA[ +window.onload = function () {pageLoad();}; +//]]> +</script + ></head + ><body id="mini" + ><div id="module-header" + ><p class="caption" + >DeprecatedNewtype</p + ></div + ><div id="interface" + ><div class="top" + ><p class="src" + ><span class="keyword" + >data</span + > <a href="" target="main" + >SomeNewType</a + > </p + ></div + ><div class="top" + ><p class="src" + ><span class="keyword" + >data</span + > <a href="" target="main" + >SomeOtherNewType</a + > </p + ></div + ></div + ></body + ></html +> diff --git a/tests/html-tests/tests/mini_DeprecatedRecord.html.ref b/tests/html-tests/tests/mini_DeprecatedRecord.html.ref new file mode 100644 index 00000000..3d949d2d --- /dev/null +++ b/tests/html-tests/tests/mini_DeprecatedRecord.html.ref @@ -0,0 +1,33 @@ +<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd"> +<html xmlns="http://www.w3.org/1999/xhtml" +><head + ><meta http-equiv="Content-Type" content="text/html; charset=UTF-8" + /><title + >DeprecatedRecord</title + ><link href="ocean.css" rel="stylesheet" type="text/css" title="Ocean" + /><script src="haddock-util.js" type="text/javascript" + ></script + ><script type="text/javascript" + >//<![CDATA[ +window.onload = function () {pageLoad();}; +//]]> +</script + ></head + ><body id="mini" + ><div id="module-header" + ><p class="caption" + >DeprecatedRecord</p + ></div + ><div id="interface" + ><div class="top" + ><p class="src" + ><span class="keyword" + >data</span + > <a href="" target="main" + >Foo</a + > </p + ></div + ></div + ></body + ></html +> diff --git a/tests/html-tests/tests/mini_DeprecatedTypeFamily.html.ref b/tests/html-tests/tests/mini_DeprecatedTypeFamily.html.ref new file mode 100644 index 00000000..c87d9637 --- /dev/null +++ b/tests/html-tests/tests/mini_DeprecatedTypeFamily.html.ref @@ -0,0 +1,41 @@ +<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd"> +<html xmlns="http://www.w3.org/1999/xhtml" +><head + ><meta http-equiv="Content-Type" content="text/html; charset=UTF-8" + /><title + >DeprecatedTypeFamily</title + ><link href="ocean.css" rel="stylesheet" type="text/css" title="Ocean" + /><script src="haddock-util.js" type="text/javascript" + ></script + ><script type="text/javascript" + >//<![CDATA[ +window.onload = function () {pageLoad();}; +//]]> +</script + ></head + ><body id="mini" + ><div id="module-header" + ><p class="caption" + >DeprecatedTypeFamily</p + ></div + ><div id="interface" + ><div class="top" + ><p class="src" + ><span class="keyword" + >data family</span + > <a href="" + >SomeTypeFamily</a + > k :: * -> *</p + ></div + ><div class="top" + ><p class="src" + ><span class="keyword" + >data family</span + > <a href="" + >SomeOtherTypeFamily</a + > k :: * -> *</p + ></div + ></div + ></body + ></html +> diff --git a/tests/html-tests/tests/mini_DeprecatedTypeSynonym.html.ref b/tests/html-tests/tests/mini_DeprecatedTypeSynonym.html.ref new file mode 100644 index 00000000..5ade100d --- /dev/null +++ b/tests/html-tests/tests/mini_DeprecatedTypeSynonym.html.ref @@ -0,0 +1,41 @@ +<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd"> +<html xmlns="http://www.w3.org/1999/xhtml" +><head + ><meta http-equiv="Content-Type" content="text/html; charset=UTF-8" + /><title + >DeprecatedTypeSynonym</title + ><link href="ocean.css" rel="stylesheet" type="text/css" title="Ocean" + /><script src="haddock-util.js" type="text/javascript" + ></script + ><script type="text/javascript" + >//<![CDATA[ +window.onload = function () {pageLoad();}; +//]]> +</script + ></head + ><body id="mini" + ><div id="module-header" + ><p class="caption" + >DeprecatedTypeSynonym</p + ></div + ><div id="interface" + ><div class="top" + ><p class="src" + ><span class="keyword" + >type</span + > <a href="" target="main" + >TypeSyn</a + > </p + ></div + ><div class="top" + ><p class="src" + ><span class="keyword" + >type</span + > <a href="" target="main" + >OtherTypeSyn</a + > </p + ></div + ></div + ></body + ></html +> diff --git a/tests/html-tests/tests/mini_Examples.html.ref b/tests/html-tests/tests/mini_Examples.html.ref new file mode 100644 index 00000000..c99c2c48 --- /dev/null +++ b/tests/html-tests/tests/mini_Examples.html.ref @@ -0,0 +1,31 @@ +<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd"> +<html xmlns="http://www.w3.org/1999/xhtml" +><head + ><meta http-equiv="Content-Type" content="text/html; charset=UTF-8" + /><title + >Examples</title + ><link href="ocean.css" rel="stylesheet" type="text/css" title="Ocean" + /><script src="haddock-util.js" type="text/javascript" + ></script + ><script type="text/javascript" + >//<![CDATA[ +window.onload = function () {pageLoad();}; +//]]> +</script + ></head + ><body id="mini" + ><div id="module-header" + ><p class="caption" + >Examples</p + ></div + ><div id="interface" + ><div class="top" + ><p class="src" + ><a href="" target="main" + >fib</a + ></p + ></div + ></div + ></body + ></html +> diff --git a/tests/html-tests/tests/mini_FunArgs.html.ref b/tests/html-tests/tests/mini_FunArgs.html.ref new file mode 100644 index 00000000..89729720 --- /dev/null +++ b/tests/html-tests/tests/mini_FunArgs.html.ref @@ -0,0 +1,37 @@ +<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd"> +<html xmlns="http://www.w3.org/1999/xhtml" +><head + ><meta http-equiv="Content-Type" content="text/html; charset=UTF-8" + /><title + >FunArgs</title + ><link href="ocean.css" rel="stylesheet" type="text/css" title="Ocean" + /><script src="haddock-util.js" type="text/javascript" + ></script + ><script type="text/javascript" + >//<![CDATA[ +window.onload = function () {pageLoad();}; +//]]> +</script + ></head + ><body id="mini" + ><div id="module-header" + ><p class="caption" + >FunArgs</p + ></div + ><div id="interface" + ><div class="top" + ><p class="src" + ><a href="" target="main" + >f</a + ></p + ></div + ><div class="top" + ><p class="src" + ><a href="" target="main" + >g</a + ></p + ></div + ></div + ></body + ></html +> diff --git a/tests/html-tests/tests/mini_GADTRecords.html.ref b/tests/html-tests/tests/mini_GADTRecords.html.ref new file mode 100644 index 00000000..a8b838f0 --- /dev/null +++ b/tests/html-tests/tests/mini_GADTRecords.html.ref @@ -0,0 +1,33 @@ +<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd"> +<html xmlns="http://www.w3.org/1999/xhtml" +><head + ><meta http-equiv="Content-Type" content="text/html; charset=UTF-8" + /><title + >GADTRecords</title + ><link href="ocean.css" rel="stylesheet" type="text/css" title="Ocean" + /><script src="haddock-util.js" type="text/javascript" + ></script + ><script type="text/javascript" + >//<![CDATA[ +window.onload = function () {pageLoad();}; +//]]> +</script + ></head + ><body id="mini" + ><div id="module-header" + ><p class="caption" + >GADTRecords</p + ></div + ><div id="interface" + ><div class="top" + ><p class="src" + ><span class="keyword" + >data</span + > <a href="" target="main" + >H1</a + > a b</p + ></div + ></div + ></body + ></html +> diff --git a/tests/html-tests/tests/mini_Hash.html.ref b/tests/html-tests/tests/mini_Hash.html.ref new file mode 100644 index 00000000..1e6ad1a9 --- /dev/null +++ b/tests/html-tests/tests/mini_Hash.html.ref @@ -0,0 +1,74 @@ +<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd"> +<html xmlns="http://www.w3.org/1999/xhtml" +><head + ><meta http-equiv="Content-Type" content="text/html; charset=UTF-8" + /><title + >Hash</title + ><link href="ocean.css" rel="stylesheet" type="text/css" title="Ocean" + /><script src="haddock-util.js" type="text/javascript" + ></script + ><script type="text/javascript" + >//<![CDATA[ +window.onload = function () {pageLoad();}; +//]]> +</script + ></head + ><body id="mini" + ><div id="module-header" + ><p class="caption" + >Hash</p + ></div + ><div id="interface" + ><h1 + >The <code + >HashTable</code + > type +</h1 + ><div class="top" + ><p class="src" + ><span class="keyword" + >data</span + > <a href="" target="main" + >HashTable</a + > key val</p + ></div + ><h2 + >Operations on <code + >HashTable</code + >s +</h2 + ><div class="top" + ><p class="src" + ><a href="" target="main" + >new</a + ></p + ></div + ><div class="top" + ><p class="src" + ><a href="" target="main" + >insert</a + ></p + ></div + ><div class="top" + ><p class="src" + ><a href="" target="main" + >lookup</a + ></p + ></div + ><h1 + >The <code + >Hash</code + > class +</h1 + ><div class="top" + ><p class="src" + ><span class="keyword" + >class</span + > <a href="" target="main" + >Hash</a + > a</p + ></div + ></div + ></body + ></html +> diff --git a/tests/html-tests/tests/mini_Hyperlinks.html.ref b/tests/html-tests/tests/mini_Hyperlinks.html.ref new file mode 100644 index 00000000..f0c7d65a --- /dev/null +++ b/tests/html-tests/tests/mini_Hyperlinks.html.ref @@ -0,0 +1,31 @@ +<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd"> +<html xmlns="http://www.w3.org/1999/xhtml" +><head + ><meta http-equiv="Content-Type" content="text/html; charset=UTF-8" + /><title + >Hyperlinks</title + ><link href="ocean.css" rel="stylesheet" type="text/css" title="Ocean" + /><script src="haddock-util.js" type="text/javascript" + ></script + ><script type="text/javascript" + >//<![CDATA[ +window.onload = function () {pageLoad();}; +//]]> +</script + ></head + ><body id="mini" + ><div id="module-header" + ><p class="caption" + >Hyperlinks</p + ></div + ><div id="interface" + ><div class="top" + ><p class="src" + ><a href="" target="main" + >foo</a + ></p + ></div + ></div + ></body + ></html +> diff --git a/tests/html-tests/tests/mini_IgnoreExports.html.ref b/tests/html-tests/tests/mini_IgnoreExports.html.ref new file mode 100644 index 00000000..a420e65a --- /dev/null +++ b/tests/html-tests/tests/mini_IgnoreExports.html.ref @@ -0,0 +1,37 @@ +<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd"> +<html xmlns="http://www.w3.org/1999/xhtml" +><head + ><meta http-equiv="Content-Type" content="text/html; charset=UTF-8" + /><title + >IgnoreExports</title + ><link href="ocean.css" rel="stylesheet" type="text/css" title="Ocean" + /><script src="haddock-util.js" type="text/javascript" + ></script + ><script type="text/javascript" + >//<![CDATA[ +window.onload = function () {pageLoad();}; +//]]> +</script + ></head + ><body id="mini" + ><div id="module-header" + ><p class="caption" + >IgnoreExports</p + ></div + ><div id="interface" + ><div class="top" + ><p class="src" + ><a href="" target="main" + >foo</a + ></p + ></div + ><div class="top" + ><p class="src" + ><a href="" target="main" + >bar</a + ></p + ></div + ></div + ></body + ></html +> diff --git a/tests/html-tests/tests/mini_ModuleWithWarning.html.ref b/tests/html-tests/tests/mini_ModuleWithWarning.html.ref new file mode 100644 index 00000000..19315a14 --- /dev/null +++ b/tests/html-tests/tests/mini_ModuleWithWarning.html.ref @@ -0,0 +1,31 @@ +<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd"> +<html xmlns="http://www.w3.org/1999/xhtml" +><head + ><meta http-equiv="Content-Type" content="text/html; charset=UTF-8" + /><title + >ModuleWithWarning</title + ><link href="ocean.css" rel="stylesheet" type="text/css" title="Ocean" + /><script src="haddock-util.js" type="text/javascript" + ></script + ><script type="text/javascript" + >//<![CDATA[ +window.onload = function () {pageLoad();}; +//]]> +</script + ></head + ><body id="mini" + ><div id="module-header" + ><p class="caption" + >ModuleWithWarning</p + ></div + ><div id="interface" + ><div class="top" + ><p class="src" + ><a href="" target="main" + >foo</a + ></p + ></div + ></div + ></body + ></html +> diff --git a/tests/html-tests/tests/mini_NamedDoc.html.ref b/tests/html-tests/tests/mini_NamedDoc.html.ref new file mode 100644 index 00000000..066bbc61 --- /dev/null +++ b/tests/html-tests/tests/mini_NamedDoc.html.ref @@ -0,0 +1,25 @@ +<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd"> +<html xmlns="http://www.w3.org/1999/xhtml" +><head + ><meta http-equiv="Content-Type" content="text/html; charset=UTF-8" + /><title + >NamedDoc</title + ><link href="ocean.css" rel="stylesheet" type="text/css" title="Ocean" + /><script src="haddock-util.js" type="text/javascript" + ></script + ><script type="text/javascript" + >//<![CDATA[ +window.onload = function () {pageLoad();}; +//]]> +</script + ></head + ><body id="mini" + ><div id="module-header" + ><p class="caption" + >NamedDoc</p + ></div + ><div id="interface" + ></div + ></body + ></html +> diff --git a/tests/html-tests/tests/mini_NoLayout.html.ref b/tests/html-tests/tests/mini_NoLayout.html.ref new file mode 100644 index 00000000..19562d70 --- /dev/null +++ b/tests/html-tests/tests/mini_NoLayout.html.ref @@ -0,0 +1,31 @@ +<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd"> +<html xmlns="http://www.w3.org/1999/xhtml" +><head + ><meta http-equiv="Content-Type" content="text/html; charset=UTF-8" + /><title + >NoLayout</title + ><link href="ocean.css" rel="stylesheet" type="text/css" title="Ocean" + /><script src="haddock-util.js" type="text/javascript" + ></script + ><script type="text/javascript" + >//<![CDATA[ +window.onload = function () {pageLoad();}; +//]]> +</script + ></head + ><body id="mini" + ><div id="module-header" + ><p class="caption" + >NoLayout</p + ></div + ><div id="interface" + ><div class="top" + ><p class="src" + ><a href="" target="main" + >g</a + ></p + ></div + ></div + ></body + ></html +> diff --git a/tests/html-tests/tests/mini_NonGreedy.html.ref b/tests/html-tests/tests/mini_NonGreedy.html.ref new file mode 100644 index 00000000..698c368e --- /dev/null +++ b/tests/html-tests/tests/mini_NonGreedy.html.ref @@ -0,0 +1,31 @@ +<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd"> +<html xmlns="http://www.w3.org/1999/xhtml" +><head + ><meta http-equiv="Content-Type" content="text/html; charset=UTF-8" + /><title + >NonGreedy</title + ><link href="ocean.css" rel="stylesheet" type="text/css" title="Ocean" + /><script src="haddock-util.js" type="text/javascript" + ></script + ><script type="text/javascript" + >//<![CDATA[ +window.onload = function () {pageLoad();}; +//]]> +</script + ></head + ><body id="mini" + ><div id="module-header" + ><p class="caption" + >NonGreedy</p + ></div + ><div id="interface" + ><div class="top" + ><p class="src" + ><a href="" target="main" + >f</a + ></p + ></div + ></div + ></body + ></html +> diff --git a/tests/html-tests/tests/mini_PruneWithWarning.html.ref b/tests/html-tests/tests/mini_PruneWithWarning.html.ref new file mode 100644 index 00000000..9eb3aa00 --- /dev/null +++ b/tests/html-tests/tests/mini_PruneWithWarning.html.ref @@ -0,0 +1,25 @@ +<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd"> +<html xmlns="http://www.w3.org/1999/xhtml" +><head + ><meta http-equiv="Content-Type" content="text/html; charset=UTF-8" + /><title + >PruneWithWarning</title + ><link href="ocean.css" rel="stylesheet" type="text/css" title="Ocean" + /><script src="haddock-util.js" type="text/javascript" + ></script + ><script type="text/javascript" + >//<![CDATA[ +window.onload = function () {pageLoad();}; +//]]> +</script + ></head + ><body id="mini" + ><div id="module-header" + ><p class="caption" + >PruneWithWarning</p + ></div + ><div id="interface" + ></div + ></body + ></html +> diff --git a/tests/html-tests/tests/mini_QuasiExpr.html.ref b/tests/html-tests/tests/mini_QuasiExpr.html.ref new file mode 100644 index 00000000..7dd9b829 --- /dev/null +++ b/tests/html-tests/tests/mini_QuasiExpr.html.ref @@ -0,0 +1,59 @@ +<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd"> +<html xmlns="http://www.w3.org/1999/xhtml" +><head + ><meta http-equiv="Content-Type" content="text/html; charset=UTF-8" + /><title + >QuasiExpr</title + ><link href="ocean.css" rel="stylesheet" type="text/css" title="Ocean" + /><script src="haddock-util.js" type="text/javascript" + ></script + ><script type="text/javascript" + >//<![CDATA[ +window.onload = function () {pageLoad();}; +//]]> +</script + ></head + ><body id="mini" + ><div id="module-header" + ><p class="caption" + >QuasiExpr</p + ></div + ><div id="interface" + ><div class="top" + ><p class="src" + ><span class="keyword" + >data</span + > <a href="" target="main" + >Expr</a + > </p + ></div + ><div class="top" + ><p class="src" + ><span class="keyword" + >data</span + > <a href="" target="main" + >BinOp</a + > </p + ></div + ><div class="top" + ><p class="src" + ><a href="" target="main" + >eval</a + ></p + ></div + ><div class="top" + ><p class="src" + ><a href="" target="main" + >expr</a + ></p + ></div + ><div class="top" + ><p class="src" + ><a href="" target="main" + >parseExprExp</a + ></p + ></div + ></div + ></body + ></html +> diff --git a/tests/html-tests/tests/mini_QuasiQuote.html.ref b/tests/html-tests/tests/mini_QuasiQuote.html.ref new file mode 100644 index 00000000..5dac6acc --- /dev/null +++ b/tests/html-tests/tests/mini_QuasiQuote.html.ref @@ -0,0 +1,31 @@ +<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd"> +<html xmlns="http://www.w3.org/1999/xhtml" +><head + ><meta http-equiv="Content-Type" content="text/html; charset=UTF-8" + /><title + >QuasiQuote</title + ><link href="ocean.css" rel="stylesheet" type="text/css" title="Ocean" + /><script src="haddock-util.js" type="text/javascript" + ></script + ><script type="text/javascript" + >//<![CDATA[ +window.onload = function () {pageLoad();}; +//]]> +</script + ></head + ><body id="mini" + ><div id="module-header" + ><p class="caption" + >QuasiQuote</p + ></div + ><div id="interface" + ><div class="top" + ><p class="src" + ><a href="" target="main" + >val</a + ></p + ></div + ></div + ></body + ></html +> diff --git a/tests/html-tests/tests/mini_TH.html.ref b/tests/html-tests/tests/mini_TH.html.ref new file mode 100644 index 00000000..d2ddbabc --- /dev/null +++ b/tests/html-tests/tests/mini_TH.html.ref @@ -0,0 +1,31 @@ +<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd"> +<html xmlns="http://www.w3.org/1999/xhtml" +><head + ><meta http-equiv="Content-Type" content="text/html; charset=UTF-8" + /><title + >TH</title + ><link href="ocean.css" rel="stylesheet" type="text/css" title="Ocean" + /><script src="haddock-util.js" type="text/javascript" + ></script + ><script type="text/javascript" + >//<![CDATA[ +window.onload = function () {pageLoad();}; +//]]> +</script + ></head + ><body id="mini" + ><div id="module-header" + ><p class="caption" + >TH</p + ></div + ><div id="interface" + ><div class="top" + ><p class="src" + ><a href="" target="main" + >decl</a + ></p + ></div + ></div + ></body + ></html +> diff --git a/tests/html-tests/tests/mini_TH2.html.ref b/tests/html-tests/tests/mini_TH2.html.ref new file mode 100644 index 00000000..2c9f1340 --- /dev/null +++ b/tests/html-tests/tests/mini_TH2.html.ref @@ -0,0 +1,31 @@ +<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd"> +<html xmlns="http://www.w3.org/1999/xhtml" +><head + ><meta http-equiv="Content-Type" content="text/html; charset=UTF-8" + /><title + >TH2</title + ><link href="ocean.css" rel="stylesheet" type="text/css" title="Ocean" + /><script src="haddock-util.js" type="text/javascript" + ></script + ><script type="text/javascript" + >//<![CDATA[ +window.onload = function () {pageLoad();}; +//]]> +</script + ></head + ><body id="mini" + ><div id="module-header" + ><p class="caption" + >TH2</p + ></div + ><div id="interface" + ><div class="top" + ><p class="src" + ><a href="" target="main" + >f</a + ></p + ></div + ></div + ></body + ></html +> diff --git a/tests/html-tests/tests/mini_Test.html.ref b/tests/html-tests/tests/mini_Test.html.ref new file mode 100644 index 00000000..26db2c0f --- /dev/null +++ b/tests/html-tests/tests/mini_Test.html.ref @@ -0,0 +1,269 @@ +<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd"> +<html xmlns="http://www.w3.org/1999/xhtml" +><head + ><meta http-equiv="Content-Type" content="text/html; charset=UTF-8" + /><title + >Test</title + ><link href="ocean.css" rel="stylesheet" type="text/css" title="Ocean" + /><script src="haddock-util.js" type="text/javascript" + ></script + ><script type="text/javascript" + >//<![CDATA[ +window.onload = function () {pageLoad();}; +//]]> +</script + ></head + ><body id="mini" + ><div id="module-header" + ><p class="caption" + >Test</p + ></div + ><div id="interface" + ><h1 + >Type declarations +</h1 + ><h2 + >Data types +</h2 + ><div class="top" + ><p class="src" + ><span class="keyword" + >data</span + > <a href="" target="main" + >T</a + > a b</p + ></div + ><div class="top" + ><p class="src" + ><span class="keyword" + >data</span + > <a href="" target="main" + >T2</a + > a b</p + ></div + ><div class="top" + ><p class="src" + ><span class="keyword" + >data</span + > <a href="" target="main" + >T3</a + > a b</p + ></div + ><div class="top" + ><p class="src" + ><span class="keyword" + >data</span + > <a href="" target="main" + >T4</a + > a b</p + ></div + ><div class="top" + ><p class="src" + ><span class="keyword" + >data</span + > <a href="" target="main" + >T5</a + > a b</p + ></div + ><div class="top" + ><p class="src" + ><span class="keyword" + >data</span + > <a href="" target="main" + >T6</a + > </p + ></div + ><div class="top" + ><p class="src" + ><span class="keyword" + >data</span + > <a href="" target="main" + >N1</a + > a</p + ></div + ><div class="top" + ><p class="src" + ><span class="keyword" + >data</span + > <a href="" target="main" + >N2</a + > a b</p + ></div + ><div class="top" + ><p class="src" + ><span class="keyword" + >data</span + > <a href="" target="main" + >N3</a + > a b</p + ></div + ><div class="top" + ><p class="src" + ><span class="keyword" + >data</span + > <a href="" target="main" + >N4</a + > a b</p + ></div + ><div class="top" + ><p class="src" + ><span class="keyword" + >data</span + > <a href="" target="main" + >N5</a + > a b</p + ></div + ><div class="top" + ><p class="src" + ><span class="keyword" + >data</span + > <a href="" target="main" + >N6</a + > a b</p + ></div + ><div class="top" + ><p class="src" + ><span class="keyword" + >data</span + > <a href="" target="main" + >N7</a + > a b</p + ></div + ><h2 + >Records +</h2 + ><div class="top" + ><p class="src" + ><span class="keyword" + >data</span + > <a href="" target="main" + >R</a + > </p + ></div + ><div class="top" + ><p class="src" + ><span class="keyword" + >data</span + > <a href="" target="main" + >R1</a + > </p + ></div + ><h1 + >Class declarations +</h1 + ><div class="top" + ><p class="src" + ><span class="keyword" + >class</span + > <a href="" target="main" + >C</a + > a</p + ></div + ><div class="top" + ><p class="src" + ><span class="keyword" + >class</span + > <a href="" target="main" + >D</a + > a</p + ></div + ><div class="top" + ><p class="src" + ><span class="keyword" + >class</span + > <a href="" target="main" + >E</a + > a</p + ></div + ><div class="top" + ><p class="src" + ><span class="keyword" + >class</span + > <a href="" target="main" + >F</a + > a</p + ></div + ><h1 + >Function types +</h1 + ><div class="top" + ><p class="src" + ><a href="" target="main" + >f</a + ></p + ></div + ><h1 + >Auxiliary stuff +</h1 + ><h1 + >A hidden module +</h1 + ><div class="top" + ><p class="src" + ><a href="" target="main" + >hidden</a + ></p + ></div + ><h1 + >A visible module +</h1 + ><h1 + >Existential / Universal types +</h1 + ><div class="top" + ><p class="src" + ><span class="keyword" + >data</span + > <a href="" target="main" + >Ex</a + > a</p + ></div + ><h1 + >Type signatures with argument docs +</h1 + ><div class="top" + ><p class="src" + ><a href="" target="main" + >k</a + ></p + ></div + ><div class="top" + ><p class="src" + ><a href="" target="main" + >l</a + ></p + ></div + ><div class="top" + ><p class="src" + ><a href="" target="main" + >m</a + ></p + ></div + ><h1 + >A section +</h1 + ><h2 + >A subsection +</h2 + ><div class="top" + ><p class="src" + ><a href="" target="main" + >f'</a + ></p + ></div + ><div class="top" + ><p class="src" + ><a href="" target="main" + >withType</a + ></p + ></div + ><div class="top" + ><p class="src" + ><a href="" target="main" + >withoutType</a + ></p + ></div + ></div + ></body + ></html +> diff --git a/tests/html-tests/tests/mini_Ticket112.html.ref b/tests/html-tests/tests/mini_Ticket112.html.ref new file mode 100644 index 00000000..68a0a5e5 --- /dev/null +++ b/tests/html-tests/tests/mini_Ticket112.html.ref @@ -0,0 +1,31 @@ +<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd"> +<html xmlns="http://www.w3.org/1999/xhtml" +><head + ><meta http-equiv="Content-Type" content="text/html; charset=UTF-8" + /><title + >Ticket112</title + ><link href="ocean.css" rel="stylesheet" type="text/css" title="Ocean" + /><script src="haddock-util.js" type="text/javascript" + ></script + ><script type="text/javascript" + >//<![CDATA[ +window.onload = function () {pageLoad();}; +//]]> +</script + ></head + ><body id="mini" + ><div id="module-header" + ><p class="caption" + >Ticket112</p + ></div + ><div id="interface" + ><div class="top" + ><p class="src" + ><a href="" target="main" + >f</a + ></p + ></div + ></div + ></body + ></html +> diff --git a/tests/html-tests/tests/mini_Ticket61.html.ref b/tests/html-tests/tests/mini_Ticket61.html.ref new file mode 100644 index 00000000..a73fefca --- /dev/null +++ b/tests/html-tests/tests/mini_Ticket61.html.ref @@ -0,0 +1,33 @@ +<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd"> +<html xmlns="http://www.w3.org/1999/xhtml" +><head + ><meta http-equiv="Content-Type" content="text/html; charset=UTF-8" + /><title + >Ticket61</title + ><link href="ocean.css" rel="stylesheet" type="text/css" title="Ocean" + /><script src="haddock-util.js" type="text/javascript" + ></script + ><script type="text/javascript" + >//<![CDATA[ +window.onload = function () {pageLoad();}; +//]]> +</script + ></head + ><body id="mini" + ><div id="module-header" + ><p class="caption" + >Ticket61</p + ></div + ><div id="interface" + ><div class="top" + ><p class="src" + ><span class="keyword" + >class</span + > <a href="" target="main" + >C</a + > a</p + ></div + ></div + ></body + ></html +> diff --git a/tests/html-tests/tests/mini_Ticket75.html.ref b/tests/html-tests/tests/mini_Ticket75.html.ref new file mode 100644 index 00000000..75ce882c --- /dev/null +++ b/tests/html-tests/tests/mini_Ticket75.html.ref @@ -0,0 +1,39 @@ +<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd"> +<html xmlns="http://www.w3.org/1999/xhtml" +><head + ><meta http-equiv="Content-Type" content="text/html; charset=UTF-8" + /><title + >Ticket75</title + ><link href="ocean.css" rel="stylesheet" type="text/css" title="Ocean" + /><script src="haddock-util.js" type="text/javascript" + ></script + ><script type="text/javascript" + >//<![CDATA[ +window.onload = function () {pageLoad();}; +//]]> +</script + ></head + ><body id="mini" + ><div id="module-header" + ><p class="caption" + >Ticket75</p + ></div + ><div id="interface" + ><div class="top" + ><p class="src" + ><span class="keyword" + >data</span + > a <a href="" target="main" + >:-</a + > b</p + ></div + ><div class="top" + ><p class="src" + ><a href="" target="main" + >f</a + ></p + ></div + ></div + ></body + ></html +> diff --git a/tests/html-tests/tests/mini_TypeFamilies.html.ref b/tests/html-tests/tests/mini_TypeFamilies.html.ref new file mode 100644 index 00000000..0cf39c88 --- /dev/null +++ b/tests/html-tests/tests/mini_TypeFamilies.html.ref @@ -0,0 +1,55 @@ +<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd"> +<html xmlns="http://www.w3.org/1999/xhtml" +><head + ><meta http-equiv="Content-Type" content="text/html; charset=UTF-8" + /><title + >TypeFamilies</title + ><link href="ocean.css" rel="stylesheet" type="text/css" title="Ocean" + /><script src="haddock-util.js" type="text/javascript" + ></script + ><script type="text/javascript" + >//<![CDATA[ +window.onload = function () {pageLoad();}; +//]]> +</script + ></head + ><body id="mini" + ><div id="module-header" + ><p class="caption" + >TypeFamilies</p + ></div + ><div id="interface" + ><div class="top" + ><p class="src" + ><span class="keyword" + >type family</span + > <a href="" + >G</a + > a :: *</p + ></div + ><div class="top" + ><p class="src" + ><span class="keyword" + >class</span + > <a href="" target="main" + >A</a + > a</p + ></div + ><div class="top" + ><p class="src" + ><span class="keyword" + >type family</span + > <a href="" + >F</a + > a </p + ></div + ><div class="top" + ><p class="src" + ><a href="" target="main" + >g</a + ></p + ></div + ></div + ></body + ></html +> diff --git a/tests/html-tests/tests/mini_TypeOperators.html.ref b/tests/html-tests/tests/mini_TypeOperators.html.ref new file mode 100644 index 00000000..f70a0fae --- /dev/null +++ b/tests/html-tests/tests/mini_TypeOperators.html.ref @@ -0,0 +1,74 @@ +<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd"> +<html xmlns="http://www.w3.org/1999/xhtml" +><head + ><meta http-equiv="Content-Type" content="text/html; charset=UTF-8" + /><title + >TypeOperators</title + ><link href="ocean.css" rel="stylesheet" type="text/css" title="Ocean" + /><script src="haddock-util.js" type="text/javascript" + ></script + ><script type="text/javascript" + >//<![CDATA[ +window.onload = function () {pageLoad();}; +//]]> +</script + ></head + ><body id="mini" + ><div id="module-header" + ><p class="caption" + >TypeOperators</p + ></div + ><div id="interface" + ><h1 + >stuff +</h1 + ><div class="top" + ><p class="src" + ><span class="keyword" + >data</span + > a <a href="" target="main" + >:-:</a + > b</p + ></div + ><div class="top" + ><p class="src" + ><span class="keyword" + >data</span + > (a <a href="" target="main" + >:+:</a + > b) c</p + ></div + ><div class="top" + ><p class="src" + ><span class="keyword" + >data</span + > <a href="" target="main" + >Op</a + > a b</p + ></div + ><div class="top" + ><p class="src" + ><span class="keyword" + >data</span + > <a href="" target="main" + >O</a + > g f a</p + ></div + ><div class="top" + ><p class="src" + ><a href="" target="main" + >biO</a + ></p + ></div + ><div class="top" + ><p class="src" + ><span class="keyword" + >data</span + > <a href="" target="main" + >Flip</a + > (~>) b a</p + ></div + ></div + ></body + ></html +> diff --git a/tests/html-tests/tests/mini_Unicode.html.ref b/tests/html-tests/tests/mini_Unicode.html.ref new file mode 100644 index 00000000..55336980 --- /dev/null +++ b/tests/html-tests/tests/mini_Unicode.html.ref @@ -0,0 +1,31 @@ +<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd"> +<html xmlns="http://www.w3.org/1999/xhtml" +><head + ><meta http-equiv="Content-Type" content="text/html; charset=UTF-8" + /><title + >Unicode</title + ><link href="ocean.css" rel="stylesheet" type="text/css" title="Ocean" + /><script src="haddock-util.js" type="text/javascript" + ></script + ><script type="text/javascript" + >//<![CDATA[ +window.onload = function () {pageLoad();}; +//]]> +</script + ></head + ><body id="mini" + ><div id="module-header" + ><p class="caption" + >Unicode</p + ></div + ><div id="interface" + ><div class="top" + ><p class="src" + ><a href="" target="main" + >x</a + ></p + ></div + ></div + ></body + ></html +> diff --git a/tests/html-tests/tests/mini_Visible.html.ref b/tests/html-tests/tests/mini_Visible.html.ref new file mode 100644 index 00000000..976a30c5 --- /dev/null +++ b/tests/html-tests/tests/mini_Visible.html.ref @@ -0,0 +1,31 @@ +<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd"> +<html xmlns="http://www.w3.org/1999/xhtml" +><head + ><meta http-equiv="Content-Type" content="text/html; charset=UTF-8" + /><title + >Visible</title + ><link href="ocean.css" rel="stylesheet" type="text/css" title="Ocean" + /><script src="haddock-util.js" type="text/javascript" + ></script + ><script type="text/javascript" + >//<![CDATA[ +window.onload = function () {pageLoad();}; +//]]> +</script + ></head + ><body id="mini" + ><div id="module-header" + ><p class="caption" + >Visible</p + ></div + ><div id="interface" + ><div class="top" + ><p class="src" + ><a href="" target="main" + >visible</a + ></p + ></div + ></div + ></body + ></html +> diff --git a/tests/unit-tests/.ghci b/tests/unit-tests/.ghci new file mode 100644 index 00000000..dcc5b13d --- /dev/null +++ b/tests/unit-tests/.ghci @@ -0,0 +1 @@ +:set -i../../src -i../../dist/build/autogen -i../../dist/build/haddock/haddock-tmp/ -packageghc -optP-include -optP../../dist/build/autogen/cabal_macros.h diff --git a/tests/unit-tests/parsetests.hs b/tests/unit-tests/parsetests.hs index e0645401..0192ebfc 100644 --- a/tests/unit-tests/parsetests.hs +++ b/tests/unit-tests/parsetests.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE StandaloneDeriving, FlexibleInstances, UndecidableInstances, IncoherentInstances #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} module Main (main) where import Test.HUnit @@ -6,9 +8,14 @@ import DynFlags (defaultDynFlags) import Haddock.Lex (tokenise) import Haddock.Parse (parseParas) import Haddock.Types +import Outputable +import Data.Monoid -instance Show RdrName where - show x = "RdrName" +instance Outputable a => Show a where + show = showSDoc . ppr + +deriving instance Show a => Show (Doc a) +deriving instance Eq a =>Eq (Doc a) data ParseTest = ParseTest { input :: String @@ -47,16 +54,30 @@ tests = [ input = ">>> putFooBar\nfoo\n<BLANKLINE>\nbar" , result = Just $ DocExamples $ [Example "putFooBar" ["foo","","bar"]] } + + -- tests for links + , ParseTest { + input = "<http://example.com/>" + , result = Just . DocParagraph $ hyperlink "http://example.com/" Nothing `mappend` DocString "\n" + } + + , ParseTest { + input = "<http://example.com/ some link>" + , result = Just . DocParagraph $ hyperlink "http://example.com/" (Just "some link") `mappend` DocString "\n" + } ] +hyperlink :: String -> Maybe String -> Doc RdrName +hyperlink url = DocHyperlink . Hyperlink url +main :: IO () main = do _ <- runTestTT $ TestList $ map toTestCase tests return (); where toTestCase :: ParseTest -> Test - toTestCase (ParseTest input result) = TestCase $ assertEqual input result (parse input) + toTestCase (ParseTest s r) = TestCase $ assertEqual s r (parse s) parse :: String -> Maybe (Doc RdrName) - parse input = parseParas $ tokenise defaultDynFlags input (0,0) + parse s = parseParas $ tokenise (defaultDynFlags undefined) s (0,0) diff --git a/tests/unit-tests/runparsetests.sh b/tests/unit-tests/runparsetests.sh index 1dae69c2..ead0ccf5 100644..100755 --- a/tests/unit-tests/runparsetests.sh +++ b/tests/unit-tests/runparsetests.sh @@ -1,15 +1,15 @@ #!/bin/sh cd `dirname $0` -runhaskell -hide-all-packages -cpp \ - -packagecontainers \ - -packagearray \ - -packagebase \ +runhaskell \ + -i../../src \ + -i../../dist/build/autogen \ + -i../../dist/build/haddock/haddock-tmp/ \ -packageghc \ - -packagexhtml \ - -packageghc-paths \ - -packageHUnit \ - -i../../dist/build/ \ - -i../../src/ \ - -optP-include -optP../../dist/build/autogen/cabal_macros.h \ + -optP-include \ + -optP../../dist/build/autogen/cabal_macros.h \ + -XCPP \ + -XDeriveDataTypeable \ + -XScopedTypeVariables \ + -XMagicHash \ parsetests.hs |