haddock-api 2.15.0.2 → 2.16.0
raw patch · 25 files changed
+930/−670 lines, 25 filesdep ~basedep ~ghcdep ~haddock-library
Dependency ranges changed: base, ghc, haddock-library
Files
- haddock-api.cabal +4/−4
- resources/html/Ocean.std-theme/ocean.css +10/−0
- src/Haddock.hs +44/−16
- src/Haddock/Backends/Hoogle.hs +28/−23
- src/Haddock/Backends/LaTeX.hs +87/−73
- src/Haddock/Backends/Xhtml.hs +21/−24
- src/Haddock/Backends/Xhtml/Decl.hs +135/−99
- src/Haddock/Backends/Xhtml/DocMarkup.hs +121/−15
- src/Haddock/Backends/Xhtml/Layout.hs +38/−17
- src/Haddock/Backends/Xhtml/Types.hs +1/−1
- src/Haddock/Convert.hs +138/−129
- src/Haddock/Doc.hs +5/−2
- src/Haddock/GhcUtils.hs +23/−58
- src/Haddock/Interface.hs +1/−1
- src/Haddock/Interface/AttachInstances.hs +33/−24
- src/Haddock/Interface/Create.hs +55/−54
- src/Haddock/Interface/LexParseRn.hs +15/−20
- src/Haddock/Interface/ParseModuleHeader.hs +1/−1
- src/Haddock/Interface/Rename.hs +78/−53
- src/Haddock/InterfaceFile.hs +21/−8
- src/Haddock/ModuleTree.hs +12/−9
- src/Haddock/Options.hs +31/−10
- src/Haddock/Parser.hs +2/−2
- src/Haddock/Types.hs +13/−13
- src/Haddock/Utils.hs +13/−14
haddock-api.cabal view
@@ -1,5 +1,5 @@ name: haddock-api-version: 2.15.0.2+version: 2.16.0 synopsis: A documentation-generation tool for Haskell libraries description: Haddock is a documentation-generation tool for Haskell libraries@@ -36,7 +36,7 @@ Haskell2010 build-depends:- base >= 4.3 && < 4.8+ base >= 4.3 && < 4.9 , bytestring , filepath , directory@@ -45,10 +45,10 @@ , array , xhtml >= 3000.2 && < 3000.3 , Cabal >= 1.10- , ghc >= 7.8.2 && < 7.8.5+ , ghc >= 7.10 && < 7.10.2 , ghc-paths- , haddock-library == 1.1.1.*+ , haddock-library == 1.2.0.* hs-source-dirs: src
resources/html/Ocean.std-theme/ocean.css view
@@ -318,6 +318,7 @@ height: 80%; top: 10%; padding: 0;+ max-width: 75%; } #synopsis .caption {@@ -370,6 +371,15 @@ margin-top: 1em; } #interface p.src .link {+ float: right;+ color: #919191;+ border-left: 1px solid #919191;+ background: #f0f0f0;+ padding: 0 0.5em 0.2em;+ margin: 0 -0.5em 0 0.5em;+}++#interface td.src .link { float: right; color: #919191; border-left: 1px solid #919191;
src/Haddock.hs view
@@ -25,6 +25,7 @@ withGhc ) where +import Data.Version import Haddock.Backends.Xhtml import Haddock.Backends.Xhtml.Themes (getThemes) import Haddock.Backends.LaTeX@@ -36,7 +37,6 @@ import Haddock.InterfaceFile import Haddock.Options import Haddock.Utils-import Haddock.GhcUtils hiding (pretty) import Control.Monad hiding (forM_) import Data.Foldable (forM_)@@ -47,7 +47,6 @@ import qualified Data.Map as Map import System.IO import System.Exit-import System.Directory #if defined(mingw32_HOST_OS) import Foreign@@ -60,14 +59,17 @@ #else import qualified GHC.Paths as GhcPaths import Paths_haddock_api (getDataDir)+import System.Directory (doesDirectoryExist) #endif import GHC hiding (verbosity) import Config-import DynFlags hiding (verbosity)+import DynFlags hiding (projectVersion, verbosity) import StaticFlags (discardStaticFlags)+import Packages import Panic (handleGhcException) import Module+import FastString -------------------------------------------------------------------------------- -- * Exception handling@@ -223,7 +225,7 @@ let ifaceFiles = map snd pkgs installedIfaces = concatMap ifInstalledIfaces ifaceFiles- srcMap = Map.fromList [ (ifPackageId if_, x) | ((_, Just x), if_) <- pkgs ]+ srcMap = Map.fromList [ (ifPackageKey if_, x) | ((_, Just x), if_) <- pkgs ] render dflags flags qual interfaces installedIfaces srcMap @@ -248,14 +250,14 @@ allVisibleIfaces = [ i | i <- allIfaces, OptHide `notElem` instOptions i ] pkgMod = ifaceMod (head ifaces)- pkgId = modulePackageId pkgMod- pkgStr = Just (packageIdString pkgId)- (pkgName,pkgVer) = modulePackageInfo pkgMod+ pkgKey = modulePackageKey pkgMod+ pkgStr = Just (packageKeyString pkgKey)+ (pkgName,pkgVer) = modulePackageInfo dflags flags pkgMod (srcBase, srcModule, srcEntity, srcLEntity) = sourceUrls flags- srcMap' = maybe srcMap (\path -> Map.insert pkgId path srcMap) srcEntity+ srcMap' = maybe srcMap (\path -> Map.insert pkgKey path srcMap) srcEntity -- TODO: Get these from the interface files as with srcMap- srcLMap' = maybe Map.empty (\path -> Map.singleton pkgId path) srcLEntity+ srcLMap' = maybe Map.empty (\path -> Map.singleton pkgKey path) srcLEntity sourceUrls' = (srcBase, srcModule, srcMap', srcLMap') libDir <- getHaddockLibDir flags@@ -269,29 +271,55 @@ copyHtmlBits odir libDir themes when (Flag_GenContents `elem` flags) $ do- ppHtmlContents odir title pkgStr+ ppHtmlContents dflags odir title pkgStr themes opt_index_url sourceUrls' opt_wiki_urls allVisibleIfaces True prologue pretty (makeContentsQual qual) copyHtmlBits odir libDir themes when (Flag_Html `elem` flags) $ do- ppHtml title pkgStr visibleIfaces odir+ ppHtml dflags title pkgStr visibleIfaces odir prologue themes sourceUrls' opt_wiki_urls opt_contents_url opt_index_url unicode qual pretty copyHtmlBits odir libDir themes + -- TODO: we throw away Meta for both Hoogle and LaTeX right now,+ -- might want to fix that if/when these two get some work on them when (Flag_Hoogle `elem` flags) $ do- let pkgName2 = if pkgName == "main" && title /= [] then title else pkgName- ppHoogle dflags pkgName2 pkgVer title prologue visibleIfaces odir+ let pkgNameStr | unpackFS pkgNameFS == "main" && title /= []+ = title+ | otherwise = unpackFS pkgNameFS+ where PackageName pkgNameFS = pkgName+ ppHoogle dflags pkgNameStr pkgVer title (fmap _doc prologue) visibleIfaces+ odir when (Flag_LaTeX `elem` flags) $ do- ppLaTeX title pkgStr visibleIfaces odir prologue opt_latex_style+ ppLaTeX title pkgStr visibleIfaces odir (fmap _doc prologue) opt_latex_style libDir +-- | From GHC 7.10, this function has a potential to crash with a+-- nasty message such as @expectJust getPackageDetails@ because+-- package name and versions can no longer reliably be extracted in+-- all cases: if the package is not installed yet then this info is no+-- longer available. The @--package-name@ and @--package-version@+-- Haddock flags allow the user to specify this information and it is+-- returned here if present: if it is not present, the error will+-- occur. Nasty but that's how it is for now. Potential TODO.+modulePackageInfo :: DynFlags+ -> [Flag] -- ^ Haddock flags are checked as they may+ -- contain the package name or version+ -- provided by the user which we+ -- prioritise+ -> Module -> (PackageName, Data.Version.Version)+modulePackageInfo dflags flags modu =+ (fromMaybe (packageName pkg) (optPackageName flags),+ fromMaybe (packageVersion pkg) (optPackageVersion flags))+ where+ pkg = getPackageDetails dflags (modulePackageKey modu) + ------------------------------------------------------------------------------- -- * Reading and dumping interface files -------------------------------------------------------------------------------@@ -449,14 +477,14 @@ mapping' = [ (moduleName m, html) | (m, html) <- mapping ] -getPrologue :: DynFlags -> [Flag] -> IO (Maybe (Doc RdrName))+getPrologue :: DynFlags -> [Flag] -> IO (Maybe (MDoc RdrName)) getPrologue dflags flags = case [filename | Flag_Prologue filename <- flags ] of [] -> return Nothing [filename] -> withFile filename ReadMode $ \h -> do hSetEncoding h utf8 str <- hGetContents h- return . Just $ parseParas dflags str+ return . Just $! parseParas dflags str _ -> throwE "multiple -p/--prologue options"
src/Haddock/Backends/Hoogle.hs view
@@ -17,7 +17,7 @@ import Haddock.GhcUtils-import Haddock.Types+import Haddock.Types hiding (Version) import Haddock.Utils hiding (out) import GHC import Outputable@@ -25,6 +25,7 @@ import Data.Char import Data.List import Data.Maybe+import Data.Version import System.FilePath import System.IO @@ -34,13 +35,14 @@ ,""] -ppHoogle :: DynFlags -> String -> String -> String -> Maybe (Doc RdrName) -> [Interface] -> FilePath -> IO ()+ppHoogle :: DynFlags -> String -> Version -> String -> Maybe (Doc RdrName) -> [Interface] -> FilePath -> IO () ppHoogle dflags package version synopsis prologue ifaces odir = do let filename = package ++ ".txt" contents = prefix ++ docWith dflags (drop 2 $ dropWhile (/= ':') synopsis) prologue ++ ["@package " ++ package] ++- ["@version " ++ version | version /= ""] +++ ["@version " ++ showVersion version+ | not (null (versionBranch version)) ] ++ concat [ppModule dflags i | i <- ifaces, OptHide `notElem` ifaceOptions i] h <- openFile (odir </> filename) WriteMode hSetEncoding h utf8@@ -62,7 +64,7 @@ dropHsDocTy = f where g (L src x) = L src (f x)- f (HsForAllTy a b c d) = HsForAllTy a b c (g d)+ f (HsForAllTy a b c d e) = HsForAllTy a b c d (g e) f (HsBangTy a b) = HsBangTy a (g b) f (HsAppTy a b) = HsAppTy (g a) (g b) f (HsFunTy a b) = HsFunTy (g a) (g b)@@ -80,7 +82,7 @@ makeExplicit :: HsType a -> HsType a-makeExplicit (HsForAllTy _ a b c) = HsForAllTy Explicit a b c+makeExplicit (HsForAllTy _ a b c d) = HsForAllTy Explicit a b c d makeExplicit x = x makeExplicitL :: LHsType a -> LHsType a@@ -118,20 +120,21 @@ f (TyClD d@DataDecl{}) = ppData dflags d subdocs f (TyClD d@SynDecl{}) = 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 (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 _ _ = [] ppSig :: DynFlags -> Sig Name -> [String]-ppSig dflags (TypeSig names sig)+ppSig dflags (TypeSig names sig _) = [operator prettyNames ++ " :: " ++ outHsType dflags typ] where prettyNames = intercalate ", " $ map (out dflags) names typ = case unL sig of- HsForAllTy Explicit a b c -> HsForAllTy Implicit a b c+ HsForAllTy Explicit a b c d -> HsForAllTy Implicit a b c d+ HsForAllTy Qualified a b c d -> HsForAllTy Implicit a b c d x -> x ppSig _ _ = [] @@ -141,12 +144,12 @@ 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 (MinimalSig sig) = MinimalSig sig+ addContext (TypeSig name (L l sig) nwcs) = TypeSig name (L l $ f sig) nwcs+ addContext (MinimalSig src sig) = MinimalSig src sig addContext _ = error "expected TypeSig" - f (HsForAllTy a b con d) = HsForAllTy a b (reL (context : unLoc con)) d- f t = HsForAllTy Implicit emptyHsQTvs (reL [context]) (reL t)+ f (HsForAllTy a b c con d) = HsForAllTy a b c (reL (context : unLoc con)) d+ f t = HsForAllTy Implicit Nothing emptyHsQTvs (reL [context]) (reL t) context = nlHsTyConApp (tcdName x) (map (reL . HsTyVar . hsTyVarName . unL) (hsQTvBndrs (tyClDeclTyVars x)))@@ -181,44 +184,46 @@ _ -> [] 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)+ppCtor dflags dat subdocs con+ = concatMap (lookupCon dflags subdocs) (con_names con) ++ f (con_details con) where f (PrefixCon args) = [typeSig name $ args ++ [resType]] f (InfixCon a1 a2) = f $ PrefixCon [a1,a2]- f (RecCon recs) = f (PrefixCon $ map cd_fld_type recs) ++ concat- [lookupCon dflags subdocs (cd_fld_name r) ++- [out dflags (unL $ cd_fld_name r) `typeSig` [resType, cd_fld_type r]]- | r <- recs]+ f (RecCon (L _ recs)) = f (PrefixCon $ map cd_fld_type (map unLoc recs)) ++ concat+ [(concatMap (lookupCon dflags subdocs) (cd_fld_names r)) +++ [out dflags (map unL $ cd_fld_names r) `typeSig` [resType, cd_fld_type r]]+ | r <- map unLoc 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 dflags (makeExplicit $ unL $ funs flds)- name = out dflags $ unL $ con_name con+ name = out dflags $ map unL $ con_names con resType = case con_res con of ResTyH98 -> apps $ map (reL . HsTyVar) $ (tcdName dat) : [hsTyVarName v | L _ v@(UserTyVar _) <- hsQTvBndrs $ tyClDeclTyVars dat]- ResTyGADT x -> x+ ResTyGADT _ x -> x --------------------------------------------------------------------- -- DOCUMENTATION ppDocumentation :: Outputable o => DynFlags -> Documentation o -> [String]-ppDocumentation dflags (Documentation d w) = doc dflags d ++ doc dflags w+ppDocumentation dflags (Documentation d w) = mdoc dflags d ++ doc dflags w doc :: Outputable o => DynFlags -> Maybe (Doc o) -> [String] doc dflags = docWith dflags "" +mdoc :: Outputable o => DynFlags -> Maybe (MDoc o) -> [String]+mdoc dflags = docWith dflags "" . fmap _doc docWith :: Outputable o => DynFlags -> String -> Maybe (Doc o) -> [String] docWith _ [] Nothing = [] docWith dflags header d = ("":) $ zipWith (++) ("-- | " : repeat "-- ") $- [header | header /= ""] ++ ["" | header /= "" && isJust d] +++ lines header ++ ["" | header /= "" && isJust d] ++ maybe [] (showTags . markup (markupTag dflags)) d
src/Haddock/Backends/LaTeX.hs view
@@ -26,6 +26,7 @@ import Name ( nameOccName ) import RdrName ( rdrNameOcc ) import FastString ( unpackFS, unpackLitString, zString )+import Outputable ( panic) import qualified Data.Map as Map import System.Directory@@ -211,7 +212,7 @@ isSimpleSig :: ExportItem DocName -> Maybe ([DocName], HsType DocName)-isSimpleSig ExportDecl { expItemDecl = L _ (SigD (TypeSig lnames (L _ t)))+isSimpleSig ExportDecl { expItemDecl = L _ (SigD (TypeSig lnames (L _ t) _)) , expItemMbDoc = (Documentation Nothing Nothing, argDocs) } | Map.null argDocs = Just (map unLoc lnames, t) isSimpleSig _ = Nothing@@ -234,7 +235,7 @@ processExport (ExportModule mdl) = declWithDoc (text "module" <+> text (moduleString mdl)) Nothing processExport (ExportDoc doc)- = docToLaTeX doc+ = docToLaTeX $ _doc doc ppDocGroup :: Int -> LaTeX -> LaTeX@@ -248,7 +249,7 @@ declNames :: LHsDecl DocName -> [DocName] declNames (L _ decl) = case decl of TyClD d -> [tcdName d]- SigD (TypeSig lnames _) -> map unLoc lnames+ SigD (TypeSig lnames _ _) -> map unLoc lnames SigD (PatSynSig lname _ _ _ _) -> [unLoc lname] ForD (ForeignImport (L _ n) _ _ _) -> [n] ForD (ForeignExport (L _ n) _ _ _) -> [n]@@ -292,9 +293,9 @@ -- | 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- SigD (PatSynSig lname args ty prov req) ->- ppLPatSig loc (doc, fnArgsDoc) lname args ty prov req unicode+ SigD (TypeSig lnames (L _ t) _) -> ppFunSig loc (doc, fnArgsDoc) (map unLoc lnames) t unicode+ SigD (PatSynSig lname qtvs prov req ty) ->+ ppLPatSig loc (doc, fnArgsDoc) lname qtvs prov req ty unicode ForD d -> ppFor loc (doc, fnArgsDoc) d unicode InstD _ -> empty _ -> error "declaration not supported by ppDecl"@@ -350,32 +351,28 @@ names = map getName docnames ppLPatSig :: SrcSpan -> DocForDecl DocName -> Located DocName- -> HsPatSynDetails (LHsType DocName) -> LHsType DocName+ -> (HsExplicitFlag, LHsTyVarBndrs DocName) -> LHsContext DocName -> LHsContext DocName- -> Bool -> LaTeX-ppLPatSig loc doc docname args typ prov req unicode =- ppPatSig loc doc (unLoc docname) (fmap unLoc args) (unLoc typ) (unLoc prov) (unLoc req) unicode--ppPatSig :: SrcSpan -> DocForDecl DocName -> DocName- -> HsPatSynDetails (HsType DocName) -> HsType DocName- -> HsContext DocName -> HsContext DocName+ -> LHsType DocName -> Bool -> LaTeX-ppPatSig _loc (doc, _argDocs) docname args typ prov req unicode = declWithDoc pref1 (documentationToLaTeX doc)+ppLPatSig _loc (doc, _argDocs) (L _ name) (expl, qtvs) lprov lreq (L _ ty) unicode+ = declWithDoc pref1 (documentationToLaTeX doc) where pref1 = hsep [ keyword "pattern"- , pp_ctx prov- , pp_head+ , ppDocBinder name , dcolon unicode- , pp_ctx req- , ppType unicode typ+ , ppLTyVarBndrs expl qtvs unicode+ , ctx+ , ppType unicode ty ] - pp_head = case args of- PrefixPatSyn typs -> hsep $ ppDocBinder docname : map pp_type typs- InfixPatSyn left right -> hsep [pp_type left, ppDocBinderInfix docname, pp_type right]+ ctx = case (ppLContextMaybe lprov unicode, ppLContextMaybe lreq unicode) of+ (Nothing, Nothing) -> empty+ (Nothing, Just req) -> parens empty <+> darr <+> req <+> darr+ (Just prov, Nothing) -> prov <+> darr+ (Just prov, Just req) -> prov <+> darr <+> req <+> darr - pp_type = ppParendType unicode- pp_ctx ctx = ppContext ctx unicode+ darr = darrow unicode ppTypeOrFunSig :: SrcSpan -> [DocName] -> HsType DocName -> DocForDecl DocName -> (LaTeX, LaTeX, LaTeX)@@ -393,16 +390,18 @@ where do_largs n leader (L _ t) = do_args n leader t - arg_doc n = rDoc (Map.lookup n argDocs)+ arg_doc n = rDoc . fmap _doc $ Map.lookup n argDocs do_args :: Int -> LaTeX -> (HsType DocName) -> LaTeX- do_args n leader (HsForAllTy Explicit tvs lctxt ltype)+ do_args n leader (HsForAllTy Explicit _ tvs lctxt ltype) = decltt leader <-> decltt (hsep (forallSymbol unicode : ppTyVars tvs ++ [dot]) <+> ppLContextNoArrow lctxt unicode) <+> nl $$ do_largs n (darrow unicode) ltype - do_args n leader (HsForAllTy Implicit _ lctxt ltype)+ do_args n leader (HsForAllTy Qualified e a lctxt ltype)+ = do_args n leader (HsForAllTy Implicit e a lctxt ltype)+ do_args n leader (HsForAllTy Implicit _ _ lctxt ltype) | not (null (unLoc lctxt)) = decltt leader <-> decltt (ppLContextNoArrow lctxt unicode) <+> nl $$ do_largs n (darrow unicode) ltype@@ -478,7 +477,7 @@ ppClassHdr :: Bool -> Located [LHsType DocName] -> DocName- -> LHsTyVarBndrs DocName -> [Located ([DocName], [DocName])]+ -> LHsTyVarBndrs DocName -> [Located ([Located DocName], [Located DocName])] -> Bool -> LaTeX ppClassHdr summ lctxt n tvs fds unicode = keyword "class"@@ -487,13 +486,13 @@ <+> ppFds fds unicode -ppFds :: [Located ([DocName], [DocName])] -> Bool -> LaTeX+ppFds :: [Located ([Located DocName], [Located DocName])] -> Bool -> LaTeX ppFds fds unicode = if null fds then empty else char '|' <+> hsep (punctuate comma (map (fundep . unLoc) fds)) where- fundep (vars1,vars2) = hsep (map ppDocName vars1) <+> arrow unicode <+>- hsep (map ppDocName vars2)+ fundep (vars1,vars2) = hsep (map (ppDocName . unLoc) vars1) <+> arrow unicode <+>+ hsep (map (ppDocName . unLoc) vars2) ppClassDecl :: [DocInstance DocName] -> SrcSpan@@ -522,7 +521,7 @@ methodTable = text "\\haddockpremethods{}\\textbf{Methods}" $$ vcat [ ppFunSig loc doc names typ unicode- | L _ (TypeSig lnames (L _ typ)) <- lsigs+ | L _ (TypeSig lnames (L _ typ) _) <- lsigs , let doc = lookupAnySubdoc (head names) subdocs names = map unLoc lnames ] -- FIXME: is taking just the first name ok? Is it possible that@@ -545,15 +544,15 @@ (is, rest') = spanWith isUndocdInstance rest isUndocdInstance :: DocInstance a -> Maybe (InstHead a)-isUndocdInstance (i,Nothing) = Just i+isUndocdInstance (L _ i,Nothing) = Just i isUndocdInstance _ = Nothing -- | Print a possibly commented instance. The instance header is printed inside -- an 'argBox'. The comment is printed to the right of the box in normal comment -- style. ppDocInstance :: Bool -> DocInstance DocName -> LaTeX-ppDocInstance unicode (instHead, doc) =- declWithDoc (ppInstDecl unicode instHead) (fmap docToLaTeX doc)+ppDocInstance unicode (L _ instHead, doc) =+ declWithDoc (ppInstDecl unicode instHead) (fmap docToLaTeX $ fmap _doc doc) ppInstDecl :: Bool -> InstHead DocName -> LaTeX@@ -599,8 +598,8 @@ (whereBit, leaders) | null cons = (empty,[]) | otherwise = case resTy of- ResTyGADT _ -> (decltt (keyword "where"), repeat empty)- _ -> (empty, (decltt (text "=") : repeat (decltt (text "|"))))+ ResTyGADT _ _ -> (decltt (keyword "where"), repeat empty)+ _ -> (empty, (decltt (text "=") : repeat (decltt (text "|")))) constrBit | null cons = Nothing@@ -621,6 +620,7 @@ where ppForall = case forall of Explicit -> forallSymbol unicode <+> hsep (map ppName tvs) <+> text ". "+ Qualified -> empty Implicit -> empty @@ -632,59 +632,66 @@ ResTyH98 -> case con_details con of PrefixCon args ->- decltt (hsep ((header_ unicode <+> ppBinder occ) :+ decltt (hsep ((header_ unicode <+> ppOcc) : map (ppLParendType unicode) args)) <-> rDoc mbDoc <+> nl - RecCon fields ->- (decltt (header_ unicode <+> ppBinder occ)+ RecCon (L _ fields) ->+ (decltt (header_ unicode <+> ppOcc) <-> rDoc mbDoc <+> nl) $$ doRecordFields fields InfixCon arg1 arg2 -> decltt (hsep [ header_ unicode <+> ppLParendType unicode arg1,- ppBinder occ,+ ppOcc, ppLParendType unicode arg2 ]) <-> rDoc mbDoc <+> nl - ResTyGADT resTy -> case con_details con of+ ResTyGADT _ resTy -> case con_details con of -- prefix & infix could also use hsConDeclArgTys if it seemed to -- simplify the code. PrefixCon args -> doGADTCon args resTy- cd@(RecCon fields) -> doGADTCon (hsConDeclArgTys cd) resTy <+> nl $$+ cd@(RecCon (L _ fields)) -> doGADTCon (hsConDeclArgTys cd) resTy <+> nl $$ doRecordFields fields InfixCon arg1 arg2 -> doGADTCon [arg1, arg2] resTy where doRecordFields fields =- vcat (map (ppSideBySideField subdocs unicode) fields)+ vcat (map (ppSideBySideField subdocs unicode) (map unLoc fields)) - doGADTCon args resTy = decltt (ppBinder occ <+> dcolon unicode <+> hsep [+ doGADTCon args resTy = decltt (ppOcc <+> dcolon unicode <+> hsep [ ppForAll forall ltvs (con_cxt con) unicode, ppLType unicode (foldr mkFunTy resTy args) ] ) <-> rDoc mbDoc header_ = ppConstrHdr forall tyVars context- occ = nameOccName . getName . unLoc . con_name $ con+ occ = map (nameOccName . getName . unLoc) $ con_names con+ ppOcc = case occ of+ [one] -> ppBinder one+ _ -> cat (punctuate comma (map ppBinder occ)) ltvs = con_qvars con tyVars = tyvarNames (con_qvars con) context = unLoc (con_cxt 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.- mbDoc = lookup (unLoc $ con_name con) subdocs >>= combineDocumentation . fst+ mbDoc = case con_names con of+ [] -> panic "empty con_names"+ (cn:_) -> lookup (unLoc cn) subdocs >>=+ fmap _doc . combineDocumentation . fst mkFunTy a b = noLoc (HsFunTy a b) ppSideBySideField :: [(DocName, DocForDecl DocName)] -> Bool -> ConDeclField DocName -> LaTeX-ppSideBySideField subdocs unicode (ConDeclField (L _ name) ltype _) =- decltt (ppBinder (nameOccName . getName $ name)+ppSideBySideField subdocs unicode (ConDeclField names ltype _) =+ decltt (cat (punctuate comma (map (ppBinder . nameOccName . getName . unL) names)) <+> 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 = lookup name subdocs >>= combineDocumentation . fst+ -- Where there is more than one name, they all have the same documentation+ mbDoc = lookup (unL $ head names) subdocs >>= fmap _doc . combineDocumentation . fst -- {- -- ppHsFullConstr :: HsConDecl -> LaTeX@@ -783,15 +790,21 @@ ppLContext = ppContext . unLoc ppLContextNoArrow = ppContextNoArrow . unLoc +ppLContextMaybe :: Located (HsContext DocName) -> Bool -> Maybe LaTeX+ppLContextMaybe = ppContextNoLocsMaybe . map unLoc . unLoc +ppContextNoLocsMaybe :: [HsType DocName] -> Bool -> Maybe LaTeX+ppContextNoLocsMaybe [] _ = Nothing+ppContextNoLocsMaybe cxt unicode = Just $ pp_hs_context cxt unicode+ ppContextNoArrow :: HsContext DocName -> Bool -> LaTeX-ppContextNoArrow [] _ = empty-ppContextNoArrow cxt unicode = pp_hs_context (map unLoc cxt) unicode+ppContextNoArrow cxt unicode = fromMaybe empty $+ ppContextNoLocsMaybe (map unLoc cxt) unicode ppContextNoLocs :: [HsType DocName] -> Bool -> LaTeX-ppContextNoLocs [] _ = empty-ppContextNoLocs cxt unicode = pp_hs_context cxt unicode <+> darrow unicode+ppContextNoLocs cxt unicode = maybe empty (<+> darrow unicode) $+ ppContextNoLocsMaybe cxt unicode ppContext :: HsContext DocName -> Bool -> LaTeX@@ -866,23 +879,28 @@ 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+ppForAll expl tvs cxt unicode = ppLTyVarBndrs expl tvs unicode <+> ppLContext cxt unicode++ppLTyVarBndrs :: HsExplicitFlag -> LHsTyVarBndrs DocName+ -> Bool -> LaTeX+ppLTyVarBndrs expl tvs unicode+ | show_forall = hsep (forallSymbol unicode : ppTyVars tvs) <> dot+ | otherwise = empty where 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-+ is_explicit = case expl of {Explicit -> True; Implicit -> False; Qualified -> False} ppr_mono_lty :: Int -> LHsType DocName -> Bool -> LaTeX ppr_mono_lty ctxt_prec ty unicode = ppr_mono_ty ctxt_prec (unLoc ty) unicode ppr_mono_ty :: Int -> HsType DocName -> Bool -> LaTeX-ppr_mono_ty ctxt_prec (HsForAllTy expl tvs ctxt ty) unicode+ppr_mono_ty ctxt_prec (HsForAllTy expl extra tvs ctxt ty) unicode = maybeParen ctxt_prec pREC_FUN $- hsep [ppForAll expl tvs ctxt unicode, ppr_mono_lty pREC_TOP ty unicode]+ hsep [ppForAll expl tvs ctxt' unicode, ppr_mono_lty pREC_TOP ty unicode]+ where ctxt' = case extra of+ Just loc -> (++ [L loc HsWildcardTy]) `fmap` ctxt+ Nothing -> ctxt ppr_mono_ty _ (HsBangTy b ty) u = ppBang b <> ppLParendType u ty ppr_mono_ty _ (HsTyVar name) _ = ppDocName name@@ -922,12 +940,16 @@ ppr_mono_ty ctxt_prec (HsDocTy ty _) unicode = ppr_mono_lty ctxt_prec ty unicode +ppr_mono_ty _ HsWildcardTy _ = char '_'++ppr_mono_ty _ (HsNamedWildcardTy name) _ = ppDocName name+ 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)+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? @@ -951,11 +973,6 @@ | isInfixName n = parens $ ppOccName n | otherwise = ppOccName n -ppBinderInfix :: OccName -> LaTeX-ppBinderInfix n- | isInfixName n = ppOccName n- | otherwise = quotes $ ppOccName n- isInfixName :: OccName -> Bool isInfixName n = isVarSym n || isConSym n @@ -994,10 +1011,7 @@ ppDocBinder :: DocName -> LaTeX ppDocBinder = ppBinder . nameOccName . getName -ppDocBinderInfix :: DocName -> LaTeX-ppDocBinderInfix = ppBinderInfix . nameOccName . getName - ppName :: Name -> LaTeX ppName = ppOccName . nameOccName @@ -1105,7 +1119,7 @@ documentationToLaTeX :: Documentation DocName -> Maybe LaTeX-documentationToLaTeX = fmap docToLaTeX . combineDocumentation+documentationToLaTeX = fmap docToLaTeX . fmap _doc . combineDocumentation rdrDocToLaTeX :: Doc RdrName -> LaTeX
src/Haddock/Backends/Xhtml.hs view
@@ -35,9 +35,6 @@ import Haddock.GhcUtils import Control.Monad ( when, unless )-#if !MIN_VERSION_base(4,7,0)-import Control.Monad.Instances ( ) -- for Functor Either a-#endif import Data.Char ( toUpper ) import Data.Functor ( (<$>) ) import Data.List ( sortBy, groupBy, intercalate, isPrefixOf )@@ -60,11 +57,12 @@ -------------------------------------------------------------------------------- -ppHtml :: String+ppHtml :: DynFlags+ -> String -- ^ Title -> Maybe String -- ^ Package -> [Interface] -> FilePath -- ^ Destination directory- -> Maybe (Doc GHC.RdrName) -- ^ Prologue text, maybe+ -> Maybe (MDoc GHC.RdrName) -- ^ Prologue text, maybe -> Themes -- ^ Themes -> SourceURLs -- ^ The source URL (--source) -> WikiURLs -- ^ The wiki URL (--wiki)@@ -75,7 +73,7 @@ -> Bool -- ^ Output pretty html (newlines and indenting) -> IO () -ppHtml doctitle maybe_package ifaces odir prologue+ppHtml dflags doctitle maybe_package ifaces odir prologue themes maybe_source_url maybe_wiki_url maybe_contents_url maybe_index_url unicode qual debug = do@@ -84,7 +82,7 @@ visible i = OptHide `notElem` ifaceOptions i when (isNothing maybe_contents_url) $- ppHtmlContents odir doctitle maybe_package+ ppHtmlContents dflags odir doctitle maybe_package 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@@ -239,21 +237,22 @@ ppHtmlContents- :: FilePath+ :: DynFlags+ -> FilePath -> String -> Maybe String -> Themes -> Maybe String -> SourceURLs -> WikiURLs- -> [InstalledInterface] -> Bool -> Maybe (Doc GHC.RdrName)+ -> [InstalledInterface] -> Bool -> Maybe (MDoc GHC.RdrName) -> Bool -> Qualification -- ^ How to qualify names -> IO ()-ppHtmlContents odir doctitle _maybe_package+ppHtmlContents dflags odir doctitle _maybe_package themes maybe_index_url maybe_source_url maybe_wiki_url ifaces showPkgs prologue debug qual = do- let tree = mkModuleTree showPkgs+ let tree = mkModuleTree dflags showPkgs [(instMod iface, toInstalledDescription iface) | iface <- ifaces] html = headHtml doctitle Nothing themes +++@@ -270,7 +269,7 @@ ppHtmlContentsFrame odir doctitle themes ifaces debug -ppPrologue :: Qualification -> String -> Maybe (Doc GHC.RdrName) -> Html+ppPrologue :: Qualification -> String -> Maybe (MDoc GHC.RdrName) -> Html ppPrologue _ _ Nothing = noHtml ppPrologue qual title (Just doc) = divDescription << (h1 << title +++ docElement thediv (rdrDocToHtml qual doc))@@ -306,7 +305,7 @@ htmlModule = thespan ! modAttrs << (cBtn +++ if leaf- then ppModule (mkModule (stringToPackageId (fromMaybe "" pkg))+ then ppModule (mkModule (stringToPackageKey (fromMaybe "" pkg)) (mkModuleName mdl)) else toHtml s )@@ -542,7 +541,7 @@ description | isNoHtml doc = doc | otherwise = divDescription $ sectionName << "Description" +++ doc- where doc = docSection qual (ifaceRnDoc iface)+ where doc = docSection Nothing qual (ifaceRnDoc iface) -- omit the synopsis if there are no documentation annotations at all synopsis@@ -585,12 +584,11 @@ (DataDecl{}) -> [keyword "data" <+> b] (SynDecl{}) -> [keyword "type" <+> b] (ClassDecl {}) -> [keyword "class" <+> b]- _ -> []- SigD (TypeSig lnames (L _ _)) ->+ SigD (TypeSig lnames (L _ _) _) -> map (ppNameMini Prefix mdl . nameOccName . getName . unLoc) lnames _ -> [] processForMiniSynopsis _ _ qual (ExportGroup lvl _id txt) =- [groupTag lvl << docToHtml qual txt]+ [groupTag lvl << docToHtml Nothing qual (mkMeta txt)] processForMiniSynopsis _ _ _ _ = [] @@ -607,7 +605,6 @@ ns = tyvarNames $ tcdTyVars decl -- it's safe to use tcdTyVars, see code above in ppTypeApp n [] ns (\is_infix -> ppNameMini is_infix mdl . nameOccName . getName) ppTyName - ppModuleContents :: Qualification -> [ExportItem DocName] -> Html ppModuleContents qual exports | null sections = noHtml@@ -625,10 +622,10 @@ | lev <= n = ( [], items ) | otherwise = ( html:secs, rest2 ) where- html = linkedAnchor (groupId id0)- << docToHtmlNoAnchors qual doc +++ mk_subsections ssecs- (ssecs, rest1) = process lev rest- (secs, rest2) = process n rest1+ html = linkedAnchor (groupId id0)+ << docToHtmlNoAnchors (Just id0) qual (mkMeta doc) +++ mk_subsections ssecs+ (ssecs, rest1) = process lev rest+ (secs, rest2) = process n rest1 process n (_ : rest) = process n rest mk_subsections [] = noHtml@@ -650,7 +647,7 @@ -> ExportItem DocName -> Maybe Html processExport _ _ _ _ ExportDecl { expItemDecl = L _ (InstD _) } = Nothing -- Hide empty instances processExport summary _ _ qual (ExportGroup lev id0 doc)- = nothingIf summary $ groupHeading lev id0 << docToHtml qual doc+ = nothingIf summary $ groupHeading lev id0 << docToHtml (Just id0) qual (mkMeta doc) processExport summary links unicode qual (ExportDecl decl doc subdocs insts fixities splice) = processDecl summary $ ppDecl summary links decl doc insts fixities subdocs splice unicode qual processExport summary _ _ qual (ExportNoDecl y [])@@ -660,7 +657,7 @@ ppDocName qual Prefix True y +++ parenList (map (ppDocName qual Prefix True) subs) processExport summary _ _ qual (ExportDoc doc)- = nothingIf summary $ docSection_ qual doc+ = nothingIf summary $ docSection_ Nothing qual doc processExport summary _ _ _ (ExportModule mdl) = processDeclOneLiner summary $ toHtml "module" <+> ppModule mdl
src/Haddock/Backends/Xhtml/Decl.hs view
@@ -18,7 +18,6 @@ tyvarNames ) where - import Haddock.Backends.Xhtml.DocMarkup import Haddock.Backends.Xhtml.Layout import Haddock.Backends.Xhtml.Names@@ -28,10 +27,10 @@ import Haddock.Types import Haddock.Doc (combineDocumentation) +import Control.Applicative import Data.List ( intersperse, sort ) import qualified Data.Map as Map import Data.Maybe-import Data.Monoid ( mempty ) import Text.XHtml hiding ( name, title, p, quote ) import GHC@@ -43,13 +42,13 @@ -> DocForDecl DocName -> [DocInstance DocName] -> [(DocName, Fixity)] -> [(DocName, DocForDecl DocName)] -> Splice -> Unicode -> Qualification -> Html ppDecl summ links (L loc decl) (mbDoc, fnArgsDoc) instances fixities subdocs splice unicode qual = case decl of- TyClD (FamDecl d) -> ppTyFam summ False links instances fixities loc mbDoc d splice unicode qual- TyClD d@(DataDecl {}) -> ppDataDecl summ links instances fixities subdocs loc mbDoc d splice unicode qual- TyClD d@(SynDecl {}) -> ppTySyn summ links fixities loc (mbDoc, fnArgsDoc) d splice unicode qual- TyClD d@(ClassDecl {}) -> ppClassDecl summ links instances fixities loc mbDoc subdocs d splice unicode qual- SigD (TypeSig lnames lty) -> ppLFunSig summ links loc (mbDoc, fnArgsDoc) lnames lty fixities splice unicode qual- SigD (PatSynSig lname args ty prov req) ->- ppLPatSig summ links loc (mbDoc, fnArgsDoc) lname args ty prov req fixities splice unicode qual+ TyClD (FamDecl d) -> ppTyFam summ False links instances fixities loc mbDoc d splice unicode qual+ TyClD d@(DataDecl {}) -> ppDataDecl summ links instances fixities subdocs loc mbDoc d splice unicode qual+ TyClD d@(SynDecl {}) -> ppTySyn summ links fixities loc (mbDoc, fnArgsDoc) d splice unicode qual+ TyClD d@(ClassDecl {}) -> ppClassDecl summ links instances fixities loc mbDoc subdocs d splice unicode qual+ SigD (TypeSig lnames lty _) -> ppLFunSig summ links loc (mbDoc, fnArgsDoc) lnames lty fixities splice unicode qual+ SigD (PatSynSig lname qtvs prov req ty) ->+ ppLPatSig summ links loc (mbDoc, fnArgsDoc) lname qtvs prov req ty fixities splice unicode qual ForD d -> ppFor summ links loc (mbDoc, fnArgsDoc) d fixities splice unicode qual InstD _ -> noHtml _ -> error "declaration not supported by ppDecl"@@ -73,39 +72,32 @@ ppLPatSig :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName -> Located DocName ->- HsPatSynDetails (LHsType DocName) -> LHsType DocName ->- LHsContext DocName -> LHsContext DocName -> [(DocName, Fixity)] ->+ (HsExplicitFlag, LHsTyVarBndrs DocName) ->+ LHsContext DocName -> LHsContext DocName ->+ LHsType DocName ->+ [(DocName, Fixity)] -> Splice -> Unicode -> Qualification -> Html-ppLPatSig summary links loc doc lname args typ prov req fixities splice unicode qual =- ppPatSig summary links loc doc (unLoc lname) (fmap unLoc args) (unLoc typ)- (unLoc prov) (unLoc req) fixities splice unicode qual--ppPatSig :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName ->- DocName ->- HsPatSynDetails (HsType DocName) -> HsType DocName ->- HsContext DocName -> HsContext DocName -> [(DocName, Fixity)] ->- Splice -> Unicode -> Qualification -> Html-ppPatSig summary links loc (doc, _argDocs) docname args typ prov req fixities- splice unicode qual+ppLPatSig summary links loc (doc, _argDocs) (L _ name) (expl, qtvs) lprov lreq typ fixities splice unicode qual | summary = pref1- | otherwise = topDeclElem links loc splice [docname] (pref1 <+> ppFixities fixities qual)- +++ docSection qual doc+ | otherwise = topDeclElem links loc splice [name] (pref1 <+> ppFixities fixities qual)+ +++ docSection Nothing qual doc where- pref1 = hsep [ toHtml "pattern"- , pp_cxt prov- , pp_head+ pref1 = hsep [ keyword "pattern"+ , ppBinder summary occname , dcolon unicode- , pp_cxt req- , ppType unicode qual typ+ , ppLTyVarBndrs expl qtvs unicode qual+ , cxt+ , ppLType unicode qual typ ]- pp_head = case args of- PrefixPatSyn typs -> hsep $ ppBinder summary occname : map pp_type typs- InfixPatSyn left right -> hsep [pp_type left, ppBinderInfix summary occname, pp_type right] - pp_cxt cxt = ppContext cxt unicode qual- pp_type = ppParendType unicode qual+ cxt = case (ppLContextMaybe lprov unicode qual, ppLContextMaybe lreq unicode qual) of+ (Nothing, Nothing) -> noHtml+ (Nothing, Just req) -> parens noHtml <+> darr <+> req <+> darr+ (Just prov, Nothing) -> prov <+> darr+ (Just prov, Just req) -> prov <+> darr <+> req <+> darr - occname = nameOccName . getName $ docname+ darr = darrow unicode+ occname = nameOccName . getName $ name ppSigLike :: Bool -> LinksInfo -> SrcSpan -> Html -> DocForDecl DocName -> [DocName] -> [(DocName, Fixity)] -> (HsType DocName, Html) ->@@ -130,15 +122,16 @@ -> Splice -> Unicode -> Qualification -> Html ppTypeOrFunSig summary links loc docnames typ (doc, argDocs) (pref1, pref2, sep) splice unicode qual | summary = pref1- | Map.null argDocs = topDeclElem links loc splice docnames pref1 +++ docSection qual doc+ | Map.null argDocs = topDeclElem links loc splice docnames pref1 +++ docSection curName qual doc | otherwise = topDeclElem links loc splice docnames pref2 +++- subArguments qual (do_args 0 sep typ) +++ docSection qual doc+ subArguments qual (do_args 0 sep typ) +++ docSection curName qual doc where+ curName = getName <$> listToMaybe docnames 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 n leader (HsForAllTy _ tvs lctxt ltype)+ do_args n leader (HsForAllTy _ _ tvs lctxt ltype) = case unLoc lctxt of [] -> do_largs n leader' ltype _ -> (leader' <+> ppLContextNoArrow lctxt unicode qual, Nothing, [])@@ -152,7 +145,7 @@ ppForAll :: LHsTyVarBndrs DocName -> Unicode -> Qualification -> Html ppForAll tvs unicode qual =- case [ppKTv n k | L _ (KindedTyVar n k) <- hsQTvBndrs tvs] of+ case [ppKTv n k | L _ (KindedTyVar (L _ n) k) <- hsQTvBndrs tvs] of [] -> noHtml ts -> forallSymbol unicode <+> hsep ts +++ dot where ppKTv n k = parens $@@ -262,7 +255,7 @@ ppTyFam summary associated links instances fixities loc doc decl splice unicode qual | summary = ppTyFamHeader True associated decl unicode qual- | otherwise = header_ +++ docSection qual doc +++ instancesBit+ | otherwise = header_ +++ docSection Nothing qual doc +++ instancesBit where docname = unLoc $ fdLName decl@@ -276,11 +269,11 @@ = subEquations qual $ map (ppTyFamEqn . unLoc) eqns | otherwise- = ppInstances instances docname unicode qual+ = ppInstances links instances docname unicode qual -- Individual equation of a closed type family- ppTyFamEqn TyFamInstEqn { tfie_tycon = n, tfie_rhs = rhs- , tfie_pats = HsWB { hswb_cts = ts }}+ ppTyFamEqn TyFamEqn { tfe_tycon = n, tfe_rhs = rhs+ , tfe_pats = HsWB { hswb_cts = ts }} = ( ppAppNameTypes (unLoc n) [] (map unLoc ts) unicode qual <+> equals <+> ppType unicode qual (unLoc rhs) , Nothing, [] )@@ -354,17 +347,23 @@ ppLContextNoArrow = ppContextNoArrow . unLoc +ppLContextMaybe :: Located (HsContext DocName) -> Unicode -> Qualification -> Maybe Html+ppLContextMaybe = ppContextNoLocsMaybe . map unLoc . unLoc+ ppContextNoArrow :: HsContext DocName -> Unicode -> Qualification -> Html-ppContextNoArrow [] _ _ = noHtml-ppContextNoArrow cxt unicode qual = ppHsContext (map unLoc cxt) unicode qual+ppContextNoArrow cxt unicode qual = fromMaybe noHtml $+ ppContextNoLocsMaybe (map unLoc cxt) unicode qual ppContextNoLocs :: [HsType DocName] -> Unicode -> Qualification -> Html-ppContextNoLocs [] _ _ = noHtml-ppContextNoLocs cxt unicode qual = ppHsContext cxt unicode qual- <+> darrow unicode+ppContextNoLocs cxt unicode qual = maybe noHtml (<+> darrow unicode) $+ ppContextNoLocsMaybe cxt unicode qual +ppContextNoLocsMaybe :: [HsType DocName] -> Unicode -> Qualification -> Maybe Html+ppContextNoLocsMaybe [] _ _ = Nothing+ppContextNoLocsMaybe cxt unicode qual = Just $ ppHsContext cxt unicode qual+ ppContext :: HsContext DocName -> Unicode -> Qualification -> Html ppContext cxt unicode qual = ppContextNoLocs (map unLoc cxt) unicode qual @@ -381,7 +380,7 @@ ppClassHdr :: Bool -> Located [LHsType DocName] -> DocName- -> LHsTyVarBndrs DocName -> [Located ([DocName], [DocName])]+ -> LHsTyVarBndrs DocName -> [Located ([Located DocName], [Located DocName])] -> Unicode -> Qualification -> Html ppClassHdr summ lctxt n tvs fds unicode qual = keyword "class"@@ -390,13 +389,13 @@ <+> ppFds fds unicode qual -ppFds :: [Located ([DocName], [DocName])] -> Unicode -> Qualification -> Html+ppFds :: [Located ([Located DocName], [Located DocName])] -> Unicode -> Qualification -> Html ppFds fds unicode qual = if null fds then noHtml else char '|' <+> hsep (punctuate comma (map (fundep . unLoc) fds)) where fundep (vars1,vars2) = ppVars vars1 <+> arrow unicode <+> ppVars vars2- ppVars = hsep . map (ppDocName qual Prefix True)+ ppVars = hsep . map ((ppDocName qual Prefix True) . unLoc) ppShortClassDecl :: Bool -> LinksInfo -> TyClDecl DocName -> SrcSpan -> [(DocName, DocForDecl DocName)]@@ -415,7 +414,7 @@ -- ToDo: add associated type defaults [ ppFunSig summary links loc doc names typ [] splice unicode qual- | L _ (TypeSig lnames (L _ typ)) <- sigs+ | L _ (TypeSig lnames (L _ typ) _) <- sigs , let doc = lookupAnySubdoc (head names) subdocs names = map unLoc lnames ] -- FIXME: is taking just the first name ok? Is it possible that@@ -438,7 +437,7 @@ , tcdFDs = lfds, tcdSigs = lsigs, tcdATs = ats }) splice unicode qual | summary = ppShortClassDecl summary links decl loc subdocs splice unicode qual- | otherwise = classheader +++ docSection qual d+ | otherwise = classheader +++ docSection Nothing qual d +++ minimalBit +++ atBit +++ methodBit +++ instancesBit where classheader@@ -460,7 +459,7 @@ subfixs = [ f | f@(n',_) <- fixities, n == n' ] ] methodBit = subMethods [ ppFunSig summary links loc doc names typ subfixs splice unicode qual- | L _ (TypeSig lnames (L _ typ)) <- lsigs+ | L _ (TypeSig lnames (L _ typ) _) <- lsigs , let doc = lookupAnySubdoc (head names) subdocs subfixs = [ f | n <- names , f@(n',_) <- fixities@@ -470,15 +469,15 @@ -- there are different subdocs for different names in a single -- type signature? - minimalBit = case [ s | L _ (MinimalSig s) <- lsigs ] of+ minimalBit = case [ s | L _ (MinimalSig _ s) <- lsigs ] of -- Miminal complete definition = every shown method And xs : _ | sort [getName n | Var (L _ n) <- xs] ==- sort [getName n | L _ (TypeSig ns _) <- lsigs, L _ n <- ns]+ sort [getName n | L _ (TypeSig ns _ _) <- lsigs, L _ n <- ns] -> noHtml -- Minimal complete definition = the only shown method Var (L _ n) : _ | [getName n] ==- [getName n' | L _ (TypeSig ns _) <- lsigs, L _ n' <- ns]+ [getName n' | L _ (TypeSig ns _ _) <- lsigs, L _ n' <- ns] -> noHtml -- Minimal complete definition = nothing@@ -492,18 +491,19 @@ ppMinimal p (Or fs) = wrap $ foldr1 (\a b -> a+++" | "+++b) $ map (ppMinimal False) fs where wrap | p = parens | otherwise = id - instancesBit = ppInstances instances nm unicode qual+ instancesBit = ppInstances links instances nm unicode qual ppClassDecl _ _ _ _ _ _ _ _ _ _ _ = error "declaration type not supported by ppShortClassDecl" -ppInstances :: [DocInstance DocName] -> DocName -> Unicode -> Qualification -> Html-ppInstances instances baseName unicode qual- = subInstances qual instName (map instDecl instances)+ppInstances :: LinksInfo -> [DocInstance DocName] -> DocName -> Unicode -> Qualification -> Html+ppInstances links instances baseName unicode qual+ = subInstances qual instName links True baseName (map instDecl instances)+ -- force Splice = True to use line URLs where instName = getOccString $ getName baseName- instDecl :: DocInstance DocName -> SubDecl- instDecl (inst, maybeDoc) = (instHead inst, maybeDoc, [])+ instDecl :: DocInstance DocName -> (SubDecl,SrcSpan)+ instDecl (L l inst, maybeDoc) = ((instHead inst, maybeDoc, []),l) instHead (n, ks, ts, ClassInst cs) = ppContextNoLocs cs unicode qual <+> ppAppNameTypes n ks ts unicode qual instHead (n, ks, ts, TypeInst rhs) = keyword "type"@@ -557,7 +557,7 @@ splice unicode qual | summary = ppShortDataDecl summary False dataDecl unicode qual- | otherwise = header_ +++ docSection qual doc +++ constrBit +++ instancesBit+ | otherwise = header_ +++ docSection Nothing qual doc +++ constrBit +++ instancesBit where docname = tcdName dataDecl@@ -572,16 +572,17 @@ whereBit | null cons = noHtml | otherwise = case resTy of- ResTyGADT _ -> keyword "where"+ ResTyGADT _ _ -> keyword "where" _ -> noHtml constrBit = subConstructors qual [ ppSideBySideConstr subdocs subfixs unicode qual c | c <- cons- , let subfixs = filter (\(n,_) -> n == unLoc (con_name (unLoc c))) fixities+ , let subfixs = filter (\(n,_) -> any (\cn -> cn == n)+ (map unLoc (con_names (unLoc c)))) fixities ] - instancesBit = ppInstances instances docname unicode qual+ instancesBit = ppInstances links instances docname unicode qual @@ -597,18 +598,18 @@ ppShortConstrParts summary dataInst con unicode qual = case con_res con of ResTyH98 -> case con_details con of PrefixCon args ->- (header_ unicode qual +++ hsep (ppBinder summary occ+ (header_ unicode qual +++ hsep (ppOcc : map (ppLParendType unicode qual) args), noHtml, noHtml)- RecCon fields ->- (header_ unicode qual +++ ppBinder summary occ <+> char '{',+ RecCon (L _ fields) ->+ (header_ unicode qual +++ ppOcc <+> char '{', doRecordFields fields, char '}') InfixCon arg1 arg2 -> (header_ unicode qual +++ hsep [ppLParendType unicode qual arg1,- ppBinderInfix summary occ, ppLParendType unicode qual arg2],+ ppOccInfix, ppLParendType unicode qual arg2], noHtml, noHtml) - ResTyGADT resTy -> case con_details con of+ ResTyGADT _ resTy -> case con_details con of -- prefix & infix could use hsConDeclArgTys if it seemed to -- simplify the code. PrefixCon args -> (doGADTCon args resTy, noHtml, noHtml)@@ -616,20 +617,29 @@ -- Constr :: (Context) => { field :: a, field2 :: b } -> Ty (a, b) -- (except each field gets its own line in docs, to match -- non-GADT records)- RecCon fields -> (ppBinder summary occ <+> dcolon unicode <+>+ RecCon (L _ fields) -> (ppOcc <+> dcolon unicode <+> ppForAllCon forall_ ltvs lcontext unicode qual <+> char '{', doRecordFields fields, char '}' <+> arrow unicode <+> ppLType unicode qual resTy) InfixCon arg1 arg2 -> (doGADTCon [arg1, arg2] resTy, noHtml, noHtml) where- doRecordFields fields = shortSubDecls dataInst (map (ppShortField summary unicode qual) fields)- doGADTCon args resTy = ppBinder summary occ <+> dcolon unicode <+> hsep [+ doRecordFields fields = shortSubDecls dataInst (map (ppShortField summary unicode qual) (map unLoc fields))+ doGADTCon args resTy = ppOcc <+> dcolon unicode <+> hsep [ ppForAllCon forall_ ltvs lcontext unicode qual, ppLType unicode qual (foldr mkFunTy resTy args) ] header_ = ppConstrHdr forall_ tyVars context- occ = nameOccName . getName . unLoc . con_name $ con+ occ = map (nameOccName . getName . unLoc) $ con_names con++ ppOcc = case occ of+ [one] -> ppBinder summary one+ _ -> hsep (punctuate comma (map (ppBinder summary) occ))++ ppOccInfix = case occ of+ [one] -> ppBinderInfix summary one+ _ -> hsep (punctuate comma (map (ppBinderInfix summary) occ))+ ltvs = con_qvars con tyVars = tyvarNames ltvs lcontext = con_cxt con@@ -649,6 +659,7 @@ where ppForall = case forall_ of Explicit -> forallSymbol unicode <+> hsep (map (ppName Prefix) tvs) <+> toHtml ". "+ Qualified -> noHtml Implicit -> noHtml @@ -659,19 +670,19 @@ decl = case con_res con of ResTyH98 -> case con_details con of PrefixCon args ->- hsep ((header_ +++ ppBinder False occ)+ hsep ((header_ +++ ppOcc) : map (ppLParendType unicode qual) args) <+> fixity - RecCon _ -> header_ +++ ppBinder False occ <+> fixity+ RecCon _ -> header_ +++ ppOcc <+> fixity InfixCon arg1 arg2 -> hsep [header_ +++ ppLParendType unicode qual arg1,- ppBinderInfix False occ,+ ppOccInfix, ppLParendType unicode qual arg2] <+> fixity - ResTyGADT resTy -> case con_details con of+ ResTyGADT _ resTy -> case con_details con of -- prefix & infix could also use hsConDeclArgTys if it seemed to -- simplify the code. PrefixCon args -> doGADTCon args resTy@@ -679,44 +690,55 @@ InfixCon arg1 arg2 -> doGADTCon [arg1, arg2] resTy fieldPart = case con_details con of- RecCon fields -> [doRecordFields fields]+ RecCon (L _ fields) -> [doRecordFields fields] _ -> [] doRecordFields fields = subFields qual- (map (ppSideBySideField subdocs unicode qual) fields)+ (map (ppSideBySideField subdocs unicode qual) (map unLoc fields)) doGADTCon :: [LHsType DocName] -> Located (HsType DocName) -> Html- doGADTCon args resTy = ppBinder False occ <+> dcolon unicode+ doGADTCon args resTy = ppOcc <+> dcolon unicode <+> hsep [ppForAllCon forall_ ltvs (con_cxt con) unicode qual, ppLType unicode qual (foldr mkFunTy resTy args) ] <+> fixity fixity = ppFixities fixities qual header_ = ppConstrHdr forall_ tyVars context unicode qual- occ = nameOccName . getName . unLoc . con_name $ con+ occ = map (nameOccName . getName . unLoc) $ con_names con++ ppOcc = case occ of+ [one] -> ppBinder False one+ _ -> hsep (punctuate comma (map (ppBinder False) occ))++ ppOccInfix = case occ of+ [one] -> ppBinderInfix False one+ _ -> hsep (punctuate comma (map (ppBinderInfix False) occ))+ ltvs = con_qvars con tyVars = tyvarNames (con_qvars con) context = unLoc (con_cxt 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.- mbDoc = lookup (unLoc $ con_name con) subdocs >>= combineDocumentation . fst+ mbDoc = lookup (unLoc $ head $ con_names con) subdocs >>=+ combineDocumentation . fst mkFunTy a b = noLoc (HsFunTy a b) ppSideBySideField :: [(DocName, DocForDecl DocName)] -> Unicode -> Qualification -> ConDeclField DocName -> SubDecl-ppSideBySideField subdocs unicode qual (ConDeclField (L _ name) ltype _) =- (ppBinder False (nameOccName . getName $ name) <+> dcolon unicode <+> ppLType unicode qual ltype,+ppSideBySideField subdocs unicode qual (ConDeclField names ltype _) =+ (hsep (punctuate comma (map ((ppBinder False) . nameOccName . getName . unL) names)) <+> dcolon unicode <+> ppLType unicode qual ltype, mbDoc, []) where -- don't use cd_fld_doc for same reason we don't use con_doc above- mbDoc = lookup name subdocs >>= combineDocumentation . fst+ -- Where there is more than one name, they all have the same documentation+ mbDoc = lookup (unL $ head names) subdocs >>= combineDocumentation . fst ppShortField :: Bool -> Unicode -> Qualification -> ConDeclField DocName -> Html-ppShortField summary unicode qual (ConDeclField (L _ name) ltype _)- = ppBinder summary (nameOccName . getName $ name)+ppShortField summary unicode qual (ConDeclField names ltype _)+ = hsep (punctuate comma (map ((ppBinder summary) . nameOccName . getName . unL) names)) <+> dcolon unicode <+> ppLType unicode qual ltype @@ -806,13 +828,20 @@ ppForAllCon :: HsExplicitFlag -> LHsTyVarBndrs DocName -> Located (HsContext DocName) -> Unicode -> Qualification -> Html-ppForAllCon expl tvs cxt unicode qual- | show_forall = forall_part <+> ppLContext cxt unicode qual- | otherwise = ppLContext cxt unicode qual+ppForAllCon expl tvs cxt unicode qual =+ forall_part <+> ppLContext cxt unicode qual where+ forall_part = ppLTyVarBndrs expl tvs unicode qual++ppLTyVarBndrs :: HsExplicitFlag -> LHsTyVarBndrs DocName+ -> Unicode -> Qualification+ -> Html+ppLTyVarBndrs expl tvs unicode _qual+ | show_forall = hsep (forallSymbol unicode : ppTyVars tvs) +++ dot+ | otherwise = noHtml+ where 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+ is_explicit = case expl of {Explicit -> True; Implicit -> False; Qualified -> False} ppr_mono_lty :: Int -> LHsType DocName -> Unicode -> Qualification -> Html@@ -820,9 +849,12 @@ ppr_mono_ty :: Int -> HsType DocName -> Unicode -> Qualification -> Html-ppr_mono_ty ctxt_prec (HsForAllTy expl tvs ctxt ty) unicode qual- = maybeParen ctxt_prec pREC_FUN $ ppForAllCon expl tvs ctxt unicode qual+ppr_mono_ty ctxt_prec (HsForAllTy expl extra tvs ctxt ty) unicode qual+ = maybeParen ctxt_prec pREC_FUN $ ppForAllCon expl tvs ctxt' unicode qual <+> ppr_mono_lty pREC_TOP ty unicode qual+ where ctxt' = case extra of+ Just loc -> (++ [L loc HsWildcardTy]) `fmap` ctxt+ Nothing -> ctxt -- UnicodeSyntax alternatives ppr_mono_ty _ (HsTyVar name) True _@@ -868,11 +900,15 @@ ppr_mono_ty ctxt_prec (HsDocTy ty _) unicode qual = ppr_mono_lty ctxt_prec ty unicode qual +ppr_mono_ty _ HsWildcardTy _ _ = char '_'++ppr_mono_ty _ (HsNamedWildcardTy name) _ q = ppDocName q Prefix True name+ 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_tylit (HsNumTy _ n) = toHtml (show n)+ppr_tylit (HsStrTy _ s) = toHtml (show s) ppr_fun_ty :: Int -> LHsType DocName -> LHsType DocName -> Unicode -> Qualification -> Html
src/Haddock/Backends/Xhtml/DocMarkup.hs view
@@ -21,16 +21,19 @@ import Control.Applicative ((<$>)) +import Data.List import Haddock.Backends.Xhtml.Names import Haddock.Backends.Xhtml.Utils import Haddock.Types import Haddock.Utils-import Haddock.Doc (combineDocumentation)+import Haddock.Doc (combineDocumentation, emptyMetaDoc,+ metaDocAppend, metaConcat) import Text.XHtml hiding ( name, p, quote ) import Data.Maybe (fromMaybe) import GHC+import Name parHtmlMarkup :: Qualification -> Bool -> (Bool -> a -> Html) -> DocMarkup a Html@@ -86,26 +89,126 @@ htmlPrompt = (thecode . toHtml $ ">>> ") ! [theclass "prompt"] htmlExpression = (strong . thecode . toHtml $ expression ++ "\n") ! [theclass "userinput"] +-- | We use this intermediate type to transform the input 'Doc' tree+-- in an arbitrary way before rendering, such as grouping some+-- elements. This is effectivelly a hack to prevent the 'Doc' type+-- from changing if it is possible to recover the layout information+-- we won't need after the fact.+data Hack a id =+ UntouchedDoc (MetaDoc a id)+ | CollapsingHeader (Header (DocH a id)) (MetaDoc a id) Int (Maybe String)+ | HackAppend (Hack a id) (Hack a id)+ deriving Eq +-- | Group things under bold 'DocHeader's together.+toHack :: Int -- ^ Counter for header IDs which serves to assign+ -- unique identifiers within the comment scope+ -> Maybe String+ -- ^ It is not enough to have unique identifier within the+ -- scope of the comment: if two different comments have the+ -- same ID for headers, the collapse/expand behaviour will act+ -- on them both. This serves to make each header a little bit+ -- more unique. As we can't export things with the same names,+ -- this should work more or less fine: it is in fact the+ -- implicit assumption the collapse/expand mechanism makes for+ -- things like ‘Instances’ boxes.+ -> [MetaDoc a id] -> Hack a id+toHack _ _ [] = UntouchedDoc emptyMetaDoc+toHack _ _ [x] = UntouchedDoc x+toHack n nm (MetaDoc { _doc = DocHeader (Header l (DocBold x)) }:xs) =+ let -- Header with dropped bold+ h = Header l x+ -- Predicate for takeWhile, grab everything including ‘smaller’+ -- headers+ p (MetaDoc { _doc = DocHeader (Header l' _) }) = l' > l+ p _ = True+ -- Stuff ‘under’ this header+ r = takeWhile p xs+ -- Everything else that didn't make it under+ r' = drop (length r) xs+ app y [] = y+ app y ys = HackAppend y (toHack (n + 1) nm ys)+ in case r of+ -- No content under this header+ [] -> CollapsingHeader h emptyMetaDoc n nm `app` r'+ -- We got something out, stitch it back together into one chunk+ y:ys -> CollapsingHeader h (foldl metaDocAppend y ys) n nm `app` r'+toHack n nm (x:xs) = HackAppend (UntouchedDoc x) (toHack n nm xs)++-- | Remove ‘top-level’ 'DocAppend's turning them into a flat list.+-- This lends itself much better to processing things in order user+-- might look at them, such as in 'toHack'.+flatten :: MetaDoc a id -> [MetaDoc a id]+flatten MetaDoc { _meta = m, _doc = DocAppend x y } =+ let f z = MetaDoc { _meta = m, _doc = z }+ in flatten (f x) ++ flatten (f y)+flatten x = [x]++-- | Generate the markup needed for collapse to happen. For+-- 'UntouchedDoc' and 'HackAppend' we do nothing more but+-- extract/append the underlying 'Doc' and convert it to 'Html'. For+-- 'CollapsingHeader', we attach extra info to the generated 'Html'+-- that allows us to expand/collapse the content.+hackMarkup :: DocMarkup id Html -> Hack (ModuleName, OccName) id -> Html+hackMarkup fmt' h' =+ let (html, ms) = hackMarkup' fmt' h'+ in html +++ renderMeta fmt' (metaConcat ms)+ where+ hackMarkup' :: DocMarkup id Html -> Hack (ModuleName, OccName) id+ -> (Html, [Meta])+ hackMarkup' fmt h = case h of+ UntouchedDoc d -> (markup fmt $ _doc d, [_meta d])+ CollapsingHeader (Header lvl titl) par n nm ->+ let id_ = makeAnchorId $ "ch:" ++ fromMaybe "noid:" nm ++ show n+ col' = collapseControl id_ True "caption"+ instTable = (thediv ! collapseSection id_ False [] <<)+ lvs = zip [1 .. ] [h1, h2, h3, h4, h5, h6]+ getHeader = fromMaybe caption (lookup lvl lvs)+ subCaption = getHeader ! col' << markup fmt titl+ in ((subCaption +++) . instTable $ markup fmt (_doc par), [_meta par])+ HackAppend d d' -> let (x, m) = hackMarkup' fmt d+ (y, m') = hackMarkup' fmt d'+ in (markupAppend fmt x y, m ++ m')++renderMeta :: DocMarkup id Html -> Meta -> Html+renderMeta fmt (Meta { _version = Just x }) =+ markupParagraph fmt . markupEmphasis fmt . toHtml $+ "Since: " ++ formatVersion x+ where+ formatVersion v = concat . intersperse "." $ map show v+renderMeta _ _ = noHtml++-- | Goes through 'hackMarkup' to generate the 'Html' rather than+-- skipping straight to 'markup': this allows us to employ XHtml+-- specific hacks to the tree first.+markupHacked :: DocMarkup id Html+ -> Maybe String+ -> MDoc id+ -> Html+markupHacked fmt n = hackMarkup fmt . toHack 0 n . flatten+ -- If the doc is a single paragraph, don't surround it with <P> (this causes -- ugly extra whitespace with some browsers). FIXME: Does this still apply?-docToHtml :: Qualification -> Doc DocName -> Html-docToHtml qual = markup fmt . cleanup+docToHtml :: Maybe String -- ^ Name of the thing this doc is for. See+ -- comments on 'toHack' for details.+ -> Qualification -> MDoc DocName -> Html+docToHtml n qual = markupHacked fmt n . cleanup where fmt = parHtmlMarkup qual True (ppDocName qual Raw) -- | Same as 'docToHtml' but it doesn't insert the 'anchor' element -- in links. This is used to generate the Contents box elements.-docToHtmlNoAnchors :: Qualification -> Doc DocName -> Html-docToHtmlNoAnchors qual = markup fmt . cleanup+docToHtmlNoAnchors :: Maybe String -- ^ See 'toHack'+ -> Qualification -> MDoc DocName -> Html+docToHtmlNoAnchors n qual = markupHacked fmt n . cleanup where fmt = parHtmlMarkup qual False (ppDocName qual Raw) -origDocToHtml :: Qualification -> Doc Name -> Html-origDocToHtml qual = markup fmt . cleanup+origDocToHtml :: Qualification -> MDoc Name -> Html+origDocToHtml qual = markupHacked fmt Nothing . cleanup where fmt = parHtmlMarkup qual True (const $ ppName Raw) -rdrDocToHtml :: Qualification -> Doc RdrName -> Html-rdrDocToHtml qual = markup fmt . cleanup+rdrDocToHtml :: Qualification -> MDoc RdrName -> Html+rdrDocToHtml qual = markupHacked fmt Nothing . cleanup where fmt = parHtmlMarkup qual True (const ppRdrName) @@ -116,16 +219,19 @@ else el ! [theclass "doc"] << content_ -docSection :: Qualification -> Documentation DocName -> Html-docSection qual = maybe noHtml (docSection_ qual) . combineDocumentation+docSection :: Maybe Name -- ^ Name of the thing this doc is for+ -> Qualification -> Documentation DocName -> Html+docSection n qual = maybe noHtml (docSection_ n qual) . combineDocumentation -docSection_ :: Qualification -> Doc DocName -> Html-docSection_ qual = (docElement thediv <<) . docToHtml qual+docSection_ :: Maybe Name -- ^ Name of the thing this doc is for+ -> Qualification -> MDoc DocName -> Html+docSection_ n qual =+ (docElement thediv <<) . docToHtml (getOccString <$> n) qual -cleanup :: Doc a -> Doc a-cleanup = markup fmtUnParagraphLists+cleanup :: MDoc a -> MDoc a+cleanup = overDoc (markup fmtUnParagraphLists) where -- If there is a single paragraph, then surrounding it with <P>..</P> -- can add too much whitespace in some browsers (eg. IE). However if
src/Haddock/Backends/Xhtml/Layout.hs view
@@ -51,7 +51,6 @@ import FastString ( unpackFS ) import GHC - -------------------------------------------------------------------------------- -- * Sections of the document --------------------------------------------------------------------------------@@ -116,7 +115,7 @@ divTopDecl = thediv ! [theclass "top"] -type SubDecl = (Html, Maybe (Doc DocName), [Html])+type SubDecl = (Html, Maybe (MDoc DocName), [Html]) divSubDecls :: (HTML a) => String -> a -> Maybe Html -> Html@@ -134,7 +133,7 @@ subEntry (decl, mdoc, subs) = dterm ! [theclass "src"] << decl +++- docElement ddef << (fmap (docToHtml qual) mdoc +++ subs)+ docElement ddef << (fmap (docToHtml Nothing qual) mdoc +++ subs) clearDiv = thediv ! [ theclass "clear" ] << noHtml @@ -146,9 +145,23 @@ subRow (decl, mdoc, subs) = (td ! [theclass "src"] << decl <->- docElement td << fmap (docToHtml qual) mdoc)+ docElement td << fmap (docToHtml Nothing qual) mdoc) : map (cell . (td <<)) subs +-- | Sub table with source information (optional).+subTableSrc :: Qualification -> LinksInfo -> Bool -> DocName -> [(SubDecl,SrcSpan)] -> Maybe Html+subTableSrc _ _ _ _ [] = Nothing+subTableSrc qual lnks splice dn decls = Just $ table << aboves (concatMap subRow decls)+ where+ subRow ((decl, mdoc, subs),loc) =+ (td ! [theclass "src"] << decl+ <+> linkHtml loc+ <->+ docElement td << fmap (docToHtml Nothing qual) mdoc+ )+ : map (cell . (td <<)) subs+ linkHtml loc@(RealSrcSpan _) = links lnks loc splice dn+ linkHtml _ = noHtml subBlock :: [Html] -> Maybe Html subBlock [] = Nothing@@ -175,11 +188,15 @@ subEquations qual = divSubDecls "equations" "Equations" . subTable qual -subInstances :: Qualification -> String -> [SubDecl] -> Html-subInstances qual nm = maybe noHtml wrap . instTable+-- | Generate sub table for instance declarations, with source+subInstances :: Qualification+ -> String -- ^ Class name, used for anchor generation+ -> LinksInfo -> Bool -> DocName+ -> [(SubDecl,SrcSpan)] -> Html+subInstances qual nm lnks splice dn = maybe noHtml wrap . instTable where wrap = (subSection <<) . (subCaption +++)- instTable = fmap (thediv ! collapseSection id_ True [] <<) . subTable qual+ instTable = fmap (thediv ! collapseSection id_ True [] <<) . subTableSrc qual lnks splice dn subSection = thediv ! [theclass "subs instances"] subCaption = paragraph ! collapseControl id_ True "caption" << "Instances" id_ = makeAnchorId $ "i:" ++ nm@@ -199,12 +216,19 @@ -- a box for top level documented names -- it adds a source and wiki link at the right hand side of the box topDeclElem :: LinksInfo -> SrcSpan -> Bool -> [DocName] -> Html -> Html-topDeclElem ((_,_,sourceMap,lineMap), (_,_,maybe_wiki_url)) loc splice names html =- declElem << (html <+> srcLink <+> wikiLink)+topDeclElem lnks loc splice names html =+ declElem << (html <+> (links lnks loc splice $ head names))+ -- FIXME: is it ok to simply take the first name?++-- | Adds a source and wiki link at the right hand side of the box.+-- Name must be documented, otherwise we wouldn't get here.+links :: LinksInfo -> SrcSpan -> Bool -> DocName -> Html+links ((_,_,sourceMap,lineMap), (_,_,maybe_wiki_url)) loc splice (Documented n mdl) =+ (srcLink <+> wikiLink) where srcLink = let nameUrl = Map.lookup origPkg sourceMap lineUrl = Map.lookup origPkg lineMap mUrl | splice = lineUrl- -- Use the lineUrl as a backup+ -- Use the lineUrl as a backup | otherwise = maybe lineUrl Just nameUrl in case mUrl of Nothing -> noHtml@@ -224,12 +248,9 @@ -- TODO: do something about type instances. They will point to -- the module defining the type family, which is wrong. origMod = nameModule n- origPkg = modulePackageId origMod-- -- Name must be documented, otherwise we wouldn't get here- Documented n mdl = head names- -- FIXME: is it ok to simply take the first name?+ origPkg = modulePackageKey origMod fname = case loc of- RealSrcSpan l -> unpackFS (srcSpanFile l)- UnhelpfulSpan _ -> error "topDeclElem UnhelpfulSpan"+ RealSrcSpan l -> unpackFS (srcSpanFile l)+ UnhelpfulSpan _ -> error "links: UnhelpfulSpan"+links _ _ _ _ = noHtml
src/Haddock/Backends/Xhtml/Types.hs view
@@ -23,7 +23,7 @@ -- the base, module and entity URLs for the source code and wiki links.-type SourceURLs = (Maybe FilePath, Maybe FilePath, Map PackageId FilePath, Map PackageId FilePath)+type SourceURLs = (Maybe FilePath, Maybe FilePath, Map PackageKey FilePath, Map PackageKey FilePath) type WikiURLs = (Maybe FilePath, Maybe FilePath, Maybe FilePath)
src/Haddock/Convert.hs view
@@ -16,35 +16,36 @@ -- Some other functions turned out to be useful for converting -- instance heads, which aren't TyThings, so just export everything. --import HsSyn-import TcType ( tcSplitSigmaTy )-import TypeRep-import Type(isStrLitTy)-import Kind ( splitKindFunTys, synTyConResKind, isKind )-import Name-import Var+import Bag ( emptyBag )+import BasicTypes ( TupleSort(..) ) import Class-import TyCon import CoAxiom import ConLike+import Data.Either (lefts, rights)+import Data.List( partition ) import DataCon-import PatSyn import FamInstEnv-import BasicTypes ( TupleSort(..) )+import Haddock.Types+import HsSyn+import Kind ( splitKindFunTys, synTyConResKind, isKind )+import Name+import PatSyn+import PrelNames (ipClassName)+import SrcLoc ( Located, noLoc, unLoc, noSrcSpan )+import TcType ( tcSplitSigmaTy )+import TyCon+import Type (isStrLitTy, mkFunTys)+import TypeRep import TysPrim ( alphaTyVars ) import TysWiredIn ( listTyConName, eqTyCon )-import PrelNames (ipClassName)-import Bag ( emptyBag ) import Unique ( getUnique )-import SrcLoc ( Located, noLoc, unLoc )-import Data.List( partition )-import Haddock.Types+import Var + -- the main function here! yay!-tyThingToLHsDecl :: TyThing -> LHsDecl Name-tyThingToLHsDecl t = noLoc $ case t of+tyThingToLHsDecl :: TyThing -> Either ErrMsg ([ErrMsg], (HsDecl Name))+tyThingToLHsDecl t = case t of -- ids (functions and zero-argument a.k.a. CAFs) get a type signature. -- Including built-in functions like seq. -- foreign-imported functions could be represented with ForD@@ -53,62 +54,60 @@ -- in a future code version we could turn idVarDetails = foreign-call -- into a ForD instead of a SigD if we wanted. Haddock doesn't -- need to care.- AnId i -> SigD (synifyIdSig ImplicitizeForAll i)+ AnId i -> allOK $ SigD (synifyIdSig ImplicitizeForAll i) -- type-constructors (e.g. Maybe) are complicated, put the definition -- later in the file (also it's used for class associated-types too.) ATyCon tc | Just cl <- tyConClass_maybe tc -- classes are just a little tedious- -> let extractFamilyDecl :: TyClDecl a -> LFamilyDecl a- extractFamilyDecl (FamDecl d) = noLoc d+ -> let extractFamilyDecl :: TyClDecl a -> Either ErrMsg (LFamilyDecl a)+ extractFamilyDecl (FamDecl d) = return $ noLoc d extractFamilyDecl _ =- error "tyThingToLHsDecl: impossible associated tycon"+ Left "tyThingToLHsDecl: impossible associated tycon" - atTyClDecls = [synifyTyCon Nothing at_tc | (at_tc, _) <- classATItems cl]- atFamDecls = map extractFamilyDecl atTyClDecls in- TyClD $ ClassDecl+ atTyClDecls = [synifyTyCon Nothing at_tc | ATI at_tc _ <- classATItems cl]+ atFamDecls = map extractFamilyDecl (rights atTyClDecls)+ tyClErrors = lefts atTyClDecls+ famDeclErrors = lefts atFamDecls+ in withErrs (tyClErrors ++ famDeclErrors) . TyClD $ ClassDecl { tcdCtxt = synifyCtx (classSCTheta cl) , tcdLName = synifyName cl , tcdTyVars = synifyTyVars (classTyVars cl) , tcdFDs = map (\ (l,r) -> noLoc- (map getName l, map getName r) ) $+ (map (noLoc . getName) l, map (noLoc . getName) r) ) $ snd $ classTvsFds cl- , tcdSigs = noLoc (MinimalSig . fmap noLoc $ classMinimalDef cl) :+ , tcdSigs = noLoc (MinimalSig mempty . fmap noLoc $ classMinimalDef cl) : 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:- , tcdATs = atFamDecls+ , tcdATs = rights atFamDecls , tcdATDefs = [] --ignore associated type defaults , tcdDocs = [] --we don't have any docs at this point- , tcdFVs = placeHolderNames }+ , tcdFVs = placeHolderNamesTc } | otherwise- -> TyClD (synifyTyCon Nothing tc)+ -> synifyTyCon Nothing tc >>= allOK . TyClD -- 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 -> synifyAxiom ax+ ACoAxiom ax -> synifyAxiom ax >>= allOK -- a data-constructor alone just gets rendered as a function:- AConLike (RealDataCon dc) -> SigD (TypeSig [synifyName dc]- (synifyType ImplicitizeForAll (dataConUserType dc)))+ AConLike (RealDataCon dc) -> allOK $ SigD (TypeSig [synifyName dc]+ (synifyType ImplicitizeForAll (dataConUserType dc)) []) AConLike (PatSynCon ps) ->-#if MIN_VERSION_ghc(7,8,3)- let (_, _, req_theta, prov_theta, _, res_ty) = patSynSig ps-#else- let (_, _, (req_theta, prov_theta)) = patSynSig ps-#endif- in SigD $ PatSynSig (synifyName ps)-#if MIN_VERSION_ghc(7,8,3)- (fmap (synifyType WithinType) (patSynTyDetails ps))- (synifyType WithinType res_ty)-#else- (fmap (synifyType WithinType) (patSynTyDetails ps))- (synifyType WithinType (patSynType ps))-#endif+ let (univ_tvs, ex_tvs, req_theta, prov_theta, arg_tys, res_ty) = patSynSig ps+ qtvs = univ_tvs ++ ex_tvs+ ty = mkFunTys arg_tys res_ty+ in allOK . SigD $ PatSynSig (synifyName ps)+ (Implicit, synifyTyVars qtvs) (synifyCtx req_theta) (synifyCtx prov_theta)+ (synifyType WithinType ty)+ where+ withErrs e x = return (e, x)+ allOK x = return (mempty, x) synifyAxBranch :: TyCon -> CoAxBranch -> TyFamInstEqn Name synifyAxBranch tc (CoAxBranch { cab_tvs = tkvs, cab_lhs = args, cab_rhs = rhs })@@ -116,40 +115,44 @@ typats = map (synifyType WithinType) args hs_rhs = synifyType WithinType rhs (kvs, tvs) = partition isKindVar tkvs- in TyFamInstEqn { tfie_tycon = name- , tfie_pats = HsWB { hswb_cts = typats- , hswb_kvs = map tyVarName kvs- , hswb_tvs = map tyVarName tvs }- , tfie_rhs = hs_rhs }+ in TyFamEqn { tfe_tycon = name+ , tfe_pats = HsWB { hswb_cts = typats+ , hswb_kvs = map tyVarName kvs+ , hswb_tvs = map tyVarName tvs+ , hswb_wcs = [] }+ , tfe_rhs = hs_rhs } -synifyAxiom :: CoAxiom br -> HsDecl Name+synifyAxiom :: CoAxiom br -> Either ErrMsg (HsDecl Name) synifyAxiom ax@(CoAxiom { co_ax_tc = tc })- | isOpenSynFamilyTyCon tc+ | isOpenTypeFamilyTyCon tc , Just branch <- coAxiomSingleBranch_maybe ax- = InstD (TyFamInstD (TyFamInstDecl { tfid_eqn = noLoc $ synifyAxBranch tc branch- , tfid_fvs = placeHolderNames }))+ = return $ InstD (TyFamInstD+ (TyFamInstDecl { tfid_eqn = noLoc $ synifyAxBranch tc branch+ , tfid_fvs = placeHolderNamesTc })) | Just ax' <- isClosedSynFamilyTyCon_maybe tc , getUnique ax' == getUnique ax -- without the getUniques, type error- = TyClD (synifyTyCon (Just ax) tc)+ = synifyTyCon (Just ax) tc >>= return . TyClD | otherwise- = error "synifyAxiom: closed/open family confusion"+ = Left "synifyAxiom: closed/open family confusion" -synifyTyCon :: Maybe (CoAxiom br) -> TyCon -> TyClDecl Name+-- | Turn type constructors into type class declarations+synifyTyCon :: Maybe (CoAxiom br) -> TyCon -> Either ErrMsg (TyClDecl Name) synifyTyCon coax tc- | isFunTyCon tc || isPrimTyCon tc - = DataDecl { tcdLName = synifyName tc+ | isFunTyCon tc || isPrimTyCon tc+ = return $+ DataDecl { 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) + let mk_hs_tv realKind fakeTyVar+ = noLoc $ KindedTyVar (noLoc (getName fakeTyVar)) (synifyKindSig realKind) in HsQTvs { hsq_kvs = [] -- No kind polymorphism , hsq_tvs = zipWith mk_hs_tv (fst (splitKindFunTys (tyConKind tc))) alphaTyVars --a, b, c... which are unfortunately all kind * }- - , tcdDataDefn = HsDataDefn { dd_ND = DataType -- arbitrary lie, they are neither ++ , tcdDataDefn = HsDataDefn { dd_ND = DataType -- arbitrary lie, they are neither -- algebraic data nor newtype: , dd_ctxt = noLoc [] , dd_cType = Nothing@@ -157,37 +160,40 @@ -- we have their kind accurately: , dd_cons = [] -- No constructors , dd_derivs = Nothing }- , tcdFVs = placeHolderNames }+ , tcdFVs = placeHolderNamesTc } - | isSynFamilyTyCon tc - = case synTyConRhs_maybe tc of+ | isTypeFamilyTyCon tc+ = case famTyConFlav_maybe tc of Just rhs -> let info = case rhs of- OpenSynFamilyTyCon -> OpenTypeFamily- ClosedSynFamilyTyCon (CoAxiom { co_ax_branches = branches }) ->- ClosedTypeFamily (brListMap (noLoc . synifyAxBranch tc) branches)- _ -> error "synifyTyCon: type/data family confusion"- in FamDecl (FamilyDecl { fdInfo = info+ OpenSynFamilyTyCon -> return OpenTypeFamily+ ClosedSynFamilyTyCon (CoAxiom { co_ax_branches = branches }) ->+ return $ ClosedTypeFamily+ (brListMap (noLoc . synifyAxBranch tc) branches)+ BuiltInSynFamTyCon {} -> return $ ClosedTypeFamily []+ AbstractClosedSynFamilyTyCon {} -> return $ ClosedTypeFamily []+ in info >>= \i ->+ return (FamDecl+ (FamilyDecl { fdInfo = i , fdLName = synifyName tc , fdTyVars = synifyTyVars (tyConTyVars tc)- , fdKindSig = Just (synifyKindSig (synTyConResKind tc)) })- Nothing -> error "synifyTyCon: impossible open type synonym?"+ , fdKindSig =+ Just (synifyKindSig (synTyConResKind tc))+ }))+ Nothing -> Left "synifyTyCon: impossible open type synonym?" - | isDataFamilyTyCon tc + | isDataFamilyTyCon tc = --(why no "isOpenAlgTyCon"?) case algTyConRhs tc of- DataFamilyTyCon ->+ DataFamilyTyCon -> return $ FamDecl (FamilyDecl DataFamily (synifyName tc) (synifyTyVars (tyConTyVars tc)) Nothing) --always kind '*'- _ -> error "synifyTyCon: impossible open data type?"- | isSynTyCon tc- = case synTyConRhs_maybe tc of- Just (SynonymTyCon ty) ->- SynDecl { tcdLName = synifyName tc- , tcdTyVars = synifyTyVars (tyConTyVars tc)- , tcdRhs = synifyType WithinType ty- , tcdFVs = placeHolderNames }- _ -> error "synifyTyCon: impossible synTyCon"+ _ -> Left "synifyTyCon: impossible open data type?"+ | Just ty <- synTyConRhs_maybe tc+ = return $ SynDecl { tcdLName = synifyName tc+ , tcdTyVars = synifyTyVars (tyConTyVars tc)+ , tcdRhs = synifyType WithinType ty+ , tcdFVs = placeHolderNamesTc } | otherwise = -- (closed) newtype and data let@@ -216,25 +222,29 @@ -- in prefix position), since, otherwise, the logic (at best) gets much more -- complicated. (would use dataConIsInfix.) use_gadt_syntax = any (not . isVanillaDataCon) (tyConDataCons tc)- cons = map (synifyDataCon use_gadt_syntax) (tyConDataCons tc)+ consRaw = map (synifyDataCon use_gadt_syntax) (tyConDataCons tc)+ cons = rights consRaw -- "deriving" doesn't affect the signature, no need to specify any. alg_deriv = Nothing defn = HsDataDefn { dd_ND = alg_nd , dd_ctxt = alg_ctx , dd_cType = Nothing , dd_kindSig = fmap synifyKindSig kindSig- , dd_cons = cons + , dd_cons = cons , dd_derivs = alg_deriv }- in DataDecl { tcdLName = name, tcdTyVars = tyvars, tcdDataDefn = defn- , tcdFVs = placeHolderNames }+ in case lefts consRaw of+ [] -> return $+ DataDecl { tcdLName = name, tcdTyVars = tyvars, tcdDataDefn = defn+ , tcdFVs = placeHolderNamesTc }+ dataConErrs -> Left $ unlines dataConErrs -- User beware: it is your responsibility to pass True (use_gadt_syntax) -- for any constructor that would be misrepresented by omitting its -- result-type. -- But you might want pass False in simple enough cases, -- if you think it looks better.-synifyDataCon :: Bool -> DataCon -> LConDecl Name-synifyDataCon use_gadt_syntax dc = noLoc $+synifyDataCon :: Bool -> DataCon -> Either ErrMsg (LConDecl Name)+synifyDataCon use_gadt_syntax dc = let -- dataConIsInfix allegedly tells us whether it was declared with -- infix *syntax*.@@ -254,40 +264,41 @@ linear_tys = zipWith (\ty bang -> let tySyn = synifyType WithinType ty src_bang = case bang of- HsUnpack {} -> HsUserBang (Just True) True- HsStrict -> HsUserBang (Just False) True+ HsUnpack {} -> HsSrcBang Nothing (Just True) True+ HsStrict -> HsSrcBang Nothing (Just False) True _ -> bang in case src_bang of HsNoBang -> tySyn _ -> noLoc $ HsBangTy bang tySyn -- HsNoBang never appears, it's implied instead. )- arg_tys (dataConStrictMarks dc)- field_tys = zipWith (\field synTy -> ConDeclField- (synifyName field) synTy Nothing)+ arg_tys (dataConSrcBangs dc)+ field_tys = zipWith (\field synTy -> noLoc $ ConDeclField+ [synifyName field] synTy Nothing) (dataConFieldLabels dc) linear_tys hs_arg_tys = case (use_named_field_syntax, use_infix_syntax) of- (True,True) -> error "synifyDataCon: contradiction!"- (True,False) -> RecCon field_tys- (False,False) -> PrefixCon linear_tys+ (True,True) -> Left "synifyDataCon: contradiction!"+ (True,False) -> return $ RecCon (noLoc field_tys)+ (False,False) -> return $ PrefixCon linear_tys (False,True) -> case linear_tys of- [a,b] -> InfixCon a b- _ -> error "synifyDataCon: infix with non-2 args?"+ [a,b] -> return $ InfixCon a b+ _ -> Left "synifyDataCon: infix with non-2 args?" hs_res_ty = if use_gadt_syntax- then ResTyGADT (synifyType WithinType res_ty)+ then ResTyGADT noSrcSpan (synifyType WithinType res_ty) else ResTyH98 -- finally we get synifyDataCon's result!- in ConDecl name Implicit{-we don't know nor care-}- qvars ctx hs_arg_tys hs_res_ty Nothing- False --we don't want any "deprecated GADT syntax" warnings!-+ in hs_arg_tys >>=+ \hat -> return . noLoc $ ConDecl [name] Implicit -- we don't know nor care+ qvars ctx hat hs_res_ty Nothing+ -- we don't want any "deprecated GADT syntax" warnings!+ False synifyName :: NamedThing n => n -> Located Name synifyName = noLoc . getName synifyIdSig :: SynifyTypeState -> Id -> Sig Name-synifyIdSig s i = TypeSig [synifyName i] (synifyType s (varType i))+synifyIdSig s i = TypeSig [synifyName i] (synifyType s (varType i)) [] synifyCtx :: [PredType] -> LHsContext Name@@ -299,9 +310,9 @@ , hsq_tvs = map synifyTyVar tvs } where (kvs, tvs) = partition isKindVar ktvs- synifyTyVar tv + synifyTyVar tv | isLiftedTypeKind kind = noLoc (UserTyVar name)- | otherwise = noLoc (KindedTyVar name (synifyKindSig kind))+ | otherwise = noLoc (KindedTyVar (noLoc name) (synifyKindSig kind)) where kind = tyVarKind tv name = getName tv@@ -359,23 +370,21 @@ in noLoc $ HsFunTy s1 s2 synifyType s forallty@(ForAllTy _tv _ty) = let (tvs, ctx, tau) = tcSplitSigmaTy forallty- in case s of- DeleteTopLevelQuantification -> synifyType ImplicitizeForAll tau- _ -> let- forallPlicitness = case s of- WithinType -> Explicit- ImplicitizeForAll -> Implicit- _ -> error "synifyType: impossible case!!!" sTvs = synifyTyVars tvs sCtx = synifyCtx ctx sTau = synifyType WithinType tau- in noLoc $- HsForAllTy forallPlicitness sTvs sCtx sTau+ mkHsForAllTy forallPlicitness =+ noLoc $ HsForAllTy forallPlicitness Nothing sTvs sCtx sTau+ in case s of+ DeleteTopLevelQuantification -> synifyType ImplicitizeForAll tau+ WithinType -> mkHsForAllTy Explicit+ ImplicitizeForAll -> mkHsForAllTy Implicit+ synifyType _ (LitTy t) = noLoc $ HsTyLit $ synifyTyLit t synifyTyLit :: TyLit -> HsTyLit-synifyTyLit (NumTyLit n) = HsNumTy n-synifyTyLit (StrTyLit s) = HsStrTy s+synifyTyLit (NumTyLit n) = HsNumTy mempty n+synifyTyLit (StrTyLit s) = HsStrTy mempty s synifyKindSig :: Kind -> LHsKind Name synifyKindSig k = synifyType WithinType k@@ -390,14 +399,14 @@ where (ks,ts) = break (not . isKind) types -- Convert a family instance, this could be a type family or data family-synifyFamInst :: FamInst -> Bool -> InstHead Name+synifyFamInst :: FamInst -> Bool -> Either ErrMsg (InstHead Name) synifyFamInst fi opaque =- ( fi_fam fi- , map (unLoc . synifyType WithinType) ks- , map (unLoc . synifyType WithinType) ts- , case fi_flavor fi of- SynFamilyInst | opaque -> TypeInst Nothing- SynFamilyInst -> TypeInst . Just . unLoc . synifyType WithinType $ fi_rhs fi- DataFamilyInst c -> DataInst $ synifyTyCon (Just $ famInstAxiom fi) c- )+ let fff = case fi_flavor fi of+ SynFamilyInst | opaque -> return $ TypeInst Nothing+ SynFamilyInst ->+ return . TypeInst . Just . unLoc . synifyType WithinType $ fi_rhs fi+ DataFamilyInst c ->+ synifyTyCon (Just $ famInstAxiom fi) c >>= return . DataInst+ in fff >>= \f' -> return (fi_fam fi , map (unLoc . synifyType WithinType) ks,+ map (unLoc . synifyType WithinType) ts , f') where (ks,ts) = break (not . isKind) $ fi_tys fi
src/Haddock/Doc.hs view
@@ -7,11 +7,14 @@ import Data.Maybe import Documentation.Haddock.Doc import Haddock.Types+import Haddock.Utils (mkMeta) -combineDocumentation :: Documentation name -> Maybe (Doc name)+combineDocumentation :: Documentation name -> Maybe (MDoc name) combineDocumentation (Documentation Nothing Nothing) = Nothing combineDocumentation (Documentation mDoc mWarning) =- Just (fromMaybe DocEmpty mWarning `docAppend` fromMaybe DocEmpty mDoc)+ Just (maybe emptyMetaDoc mkMeta mWarning+ `metaDocAppend`+ fromMaybe emptyMetaDoc mDoc) -- Drop trailing whitespace from @..@ code blocks. Otherwise this: --
src/Haddock/GhcUtils.hs view
@@ -16,19 +16,14 @@ module Haddock.GhcUtils where -import Data.Version import Control.Applicative ( (<$>) ) import Control.Arrow-import Data.Foldable hiding (concatMap) import Data.Function-import Data.Traversable-import Distribution.Compat.ReadP-import Distribution.Text import Exception import Outputable import Name-import Packages+import Lexeme import Module import RdrName (GlobalRdrEnv) import GhcMonad (withSession)@@ -41,28 +36,6 @@ moduleString :: Module -> String moduleString = moduleNameString . moduleName ---- return the (name,version) of the package-modulePackageInfo :: Module -> (String, [Char])-modulePackageInfo modu = case unpackPackageId pkg of- Nothing -> (packageIdString pkg, "")- Just x -> (display $ pkgName x, showVersion (pkgVersion x))- where pkg = modulePackageId modu----- This was removed from GHC 6.11--- XXX we shouldn't be using it, probably---- | Try and interpret a GHC 'PackageId' as a cabal 'PackageIdentifer'. Returns @Nothing@ if--- we could not parse it as such an object.-unpackPackageId :: PackageId -> Maybe PackageIdentifier-unpackPackageId p- = case [ pid | (pid,"") <- readP_to_S parse str ] of- [] -> Nothing- (pid:_) -> Just pid- where str = packageIdString p-- lookupLoadedHomeModuleGRE :: GhcMonad m => ModuleName -> m (Maybe GlobalRdrEnv) lookupLoadedHomeModuleGRE mod_name = withSession $ \hsc_env -> case lookupUFM (hsc_HPT hsc_env) mod_name of@@ -102,7 +75,7 @@ -- Since CoAxioms' Names refer to the whole line for type family instances -- in particular, we need to dig a bit deeper to pull out the entire -- equation. This does not happen for data family instances, for some reason.- { tfid_eqn = L _ (TyFamInstEqn { tfie_rhs = L l _ })})) = l+ { tfid_eqn = L _ (TyFamEqn { tfe_rhs = L l _ })})) = l -- Useful when there is a signature with multiple names, e.g. -- foo, bar :: Types..@@ -114,12 +87,15 @@ filterSigNames :: (name -> Bool) -> Sig name -> Maybe (Sig name) filterSigNames p orig@(SpecSig n _ _) = ifTrueJust (p $ unLoc n) orig filterSigNames p orig@(InlineSig n _) = ifTrueJust (p $ unLoc n) orig-filterSigNames p orig@(FixSig (FixitySig n _)) = ifTrueJust (p $ unLoc n) orig-filterSigNames _ orig@(MinimalSig _) = Just orig-filterSigNames p (TypeSig ns ty) =+filterSigNames p (FixSig (FixitySig ns ty)) = case filter (p . unLoc) ns of [] -> Nothing- filtered -> Just (TypeSig filtered ty)+ filtered -> Just (FixSig (FixitySig filtered ty))+filterSigNames _ orig@(MinimalSig _ _) = Just orig+filterSigNames p (TypeSig ns ty nwcs) =+ case filter (p . unLoc) ns of+ [] -> Nothing+ filtered -> Just (TypeSig filtered ty nwcs) filterSigNames _ _ = Nothing ifTrueJust :: Bool -> name -> Maybe name@@ -130,12 +106,12 @@ sigName (L _ sig) = sigNameNoLoc sig sigNameNoLoc :: Sig name -> [name]-sigNameNoLoc (TypeSig ns _) = map unLoc ns-sigNameNoLoc (PatSynSig n _ _ _ _) = [unLoc n]-sigNameNoLoc (SpecSig n _ _) = [unLoc n]-sigNameNoLoc (InlineSig n _) = [unLoc n]-sigNameNoLoc (FixSig (FixitySig n _)) = [unLoc n]-sigNameNoLoc _ = []+sigNameNoLoc (TypeSig ns _ _) = map unLoc ns+sigNameNoLoc (PatSynSig n _ _ _ _) = [unLoc n]+sigNameNoLoc (SpecSig n _ _) = [unLoc n]+sigNameNoLoc (InlineSig n _) = [unLoc n]+sigNameNoLoc (FixSig (FixitySig ns _)) = map unLoc ns+sigNameNoLoc _ = [] isTyClD :: HsDecl a -> Bool@@ -193,14 +169,6 @@ before = (<) `on` getLoc -instance Foldable (GenLocated l) where- foldMap f (L _ x) = f x---instance Traversable (GenLocated l) where- mapM f (L l x) = (return . L l) =<< f x- traverse f (L l x) = L l <$> f x- ------------------------------------------------------------------------------- -- * NamedThing instances -------------------------------------------------------------------------------@@ -209,11 +177,6 @@ instance NamedThing (TyClDecl Name) where getName = tcdName --instance NamedThing (ConDecl Name) where- getName = unL . con_name-- ------------------------------------------------------------------------------- -- * Subordinates -------------------------------------------------------------------------------@@ -226,16 +189,16 @@ instance Parent (ConDecl Name) where children con = case con_details con of- RecCon fields -> map (unL . cd_fld_name) fields+ RecCon fields -> map unL $ concatMap (cd_fld_names . unL) (unL fields) _ -> [] - instance Parent (TyClDecl Name) where children d- | isDataDecl d = map (unL . con_name . unL) . dd_cons . tcdDataDefn $ d+ | isDataDecl d = map unL $ concatMap (con_names . unL)+ $ (dd_cons . tcdDataDefn) $ d | isClassDecl d = map (unL . fdLName . unL) (tcdATs d) ++- [ unL n | L _ (TypeSig ns _) <- tcdSigs d, n <- ns ]+ [ unL n | L _ (TypeSig ns _ _) <- tcdSigs d, n <- ns ] | otherwise = [] @@ -244,11 +207,14 @@ family = getName &&& children +familyConDecl :: ConDecl Name -> [(Name, [Name])]+familyConDecl d = zip (map unL (con_names d)) (repeat $ children d)+ -- | A mapping from the parent (main-binder) to its children and from each -- child to its grand-children, recursively. families :: TyClDecl Name -> [(Name, [Name])] families d- | isDataDecl d = family d : map (family . unL) (dd_cons (tcdDataDefn d))+ | isDataDecl d = family d : concatMap (familyConDecl . unL) (dd_cons (tcdDataDefn d)) | isClassDecl d = [family d] | otherwise = [] @@ -301,4 +267,3 @@ -- -stubdir D adds an implicit -I D, so that gcc can find the _stub.h file -- \#included from the .hc file when compiling with -fvia-C. setOutputDir f = setObjectDir f . setHiDir f . setStubDir f-
src/Haddock/Interface.hs view
@@ -195,7 +195,7 @@ else n out verbosity normal coverageMsg- when (Flag_PrintMissingDocs `elem` flags+ when (Flag_NoPrintMissingDocs `notElem` flags && not (null undocumentedExports && header)) $ do out verbosity normal " Missing documentation for:" unless header $ out verbosity normal " Module header"
src/Haddock/Interface/AttachInstances.hs view
@@ -18,7 +18,7 @@ import Haddock.Convert import Haddock.GhcUtils -import Control.Arrow+import Control.Arrow hiding ((<+>)) import Data.List import Data.Ord (comparing) import Data.Function (on)@@ -26,6 +26,8 @@ import qualified Data.Set as Set import Class+import DynFlags+import ErrUtils import FamInstEnv import FastString import GHC@@ -34,6 +36,7 @@ import InstEnv import MonadUtils (liftIO) import Name+import Outputable (text, sep, (<+>)) import PrelNames import TcRnDriver (tcRnGetInfo) import TcType (tcSplitSigmaTy)@@ -60,32 +63,38 @@ return $ iface { ifaceExportItems = newItems } -attachToExportItem :: ExportInfo -> Interface -> IfaceMap -> InstIfaceMap -> ExportItem Name -> Ghc (ExportItem Name)+attachToExportItem :: ExportInfo -> Interface -> IfaceMap -> InstIfaceMap+ -> ExportItem Name+ -> Ghc (ExportItem Name) attachToExportItem expInfo iface ifaceMap instIfaceMap export = case attachFixities export of e@ExportDecl { expItemDecl = L _ (TyClD d) } -> do mb_info <- getAllInfo (tcdName d)- let export' =- e {- expItemInstances =- case mb_info of- Just (_, _, cls_instances, fam_instances) ->- let fam_insts = [ (synifyFamInst i opaque, n)- | i <- sortBy (comparing instFam) fam_instances- , let n = instLookup instDocMap (getName i) iface ifaceMap instIfaceMap- , not $ isNameHidden expInfo (fi_fam i)- , not $ any (isTypeHidden expInfo) (fi_tys i)- , let opaque = isTypeHidden expInfo (fi_rhs i)- ]- cls_insts = [ (synifyInstHead i, instLookup instDocMap n iface ifaceMap instIfaceMap)- | let is = [ (instanceHead' i, getName i) | i <- cls_instances ]- , (i@(_,_,cls,tys), n) <- sortBy (comparing $ first instHead) is- , not $ isInstanceHidden expInfo cls tys- ]- in cls_insts ++ fam_insts- Nothing -> []- }- return export'+ insts <- case mb_info of+ Just (_, _, cls_instances, fam_instances) ->+ let fam_insts = [ (L (getSrcSpan n) $ synifyFamInst i opaque, doc)+ | i <- sortBy (comparing instFam) fam_instances+ , let n = getName i+ , let doc = instLookup instDocMap n iface ifaceMap instIfaceMap+ , not $ isNameHidden expInfo (fi_fam i)+ , not $ any (isTypeHidden expInfo) (fi_tys i)+ , let opaque = isTypeHidden expInfo (fi_rhs i)+ ]+ cls_insts = [ (L (getSrcSpan n) $ synifyInstHead i, instLookup instDocMap n iface ifaceMap instIfaceMap)+ | let is = [ (instanceHead' i, getName i) | i <- cls_instances ]+ , (i@(_,_,cls,tys), n) <- sortBy (comparing $ first instHead) is+ , not $ isInstanceHidden expInfo cls tys+ ]+ -- fam_insts but with failing type fams filtered out+ cleanFamInsts = [ (L l fi, n) | (L l (Right fi), n) <- fam_insts ]+ famInstErrs = [ errm | (L _ (Left errm), _) <- fam_insts ]+ in do+ dfs <- getDynFlags+ let mkBug = (text "haddock-bug:" <+>) . text+ liftIO $ putMsg dfs (sep $ map mkBug famInstErrs)+ return $ cls_insts ++ cleanFamInsts+ Nothing -> return []+ return $ e { expItemInstances = insts } e -> return e where attachFixities e@ExportDecl{ expItemDecl = L _ d } = e { expItemFixities =@@ -126,7 +135,7 @@ -- | Like GHC's getInfo but doesn't cut things out depending on the -- interative context, which we don't set sufficiently anyway. getAllInfo :: GhcMonad m => Name -> m (Maybe (TyThing,Fixity,[ClsInst],[FamInst]))-getAllInfo name = withSession $ \hsc_env -> do +getAllInfo name = withSession $ \hsc_env -> do (_msgs, r) <- liftIO $ tcRnGetInfo hsc_env name return r
src/Haddock/Interface/Create.hs view
@@ -14,7 +14,7 @@ ----------------------------------------------------------------------------- module Haddock.Interface.Create (createInterface) where -import Documentation.Haddock.Doc (docAppend)+import Documentation.Haddock.Doc (metaDocAppend) import Haddock.Types import Haddock.Options import Haddock.GhcUtils@@ -45,7 +45,7 @@ import RdrName import TcRnTypes import FastString (concatFS)-+import qualified Outputable as O -- | Use a 'TypecheckedModule' to produce an 'Interface'. -- To do this, we need access to already processed modules in the topological@@ -157,7 +157,7 @@ alias <- ideclAs impDecl return $ (lookupModuleDyn dflags- (fmap Module.fsToPackageId $+ (fmap Module.fsToPackageKey $ ideclPkgQual impDecl) (case ideclName impDecl of SrcLoc.L _ name -> name), alias))@@ -165,15 +165,13 @@ -- similar to GHC.lookupModule lookupModuleDyn ::- DynFlags -> Maybe PackageId -> ModuleName -> Module+ DynFlags -> Maybe PackageKey -> 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+ case Packages.lookupModuleInAllPackages dflags mdlName of+ (m,_):_ -> m+ [] -> Module.mkModule Module.mainPackageKey mdlName -------------------------------------------------------------------------------@@ -196,8 +194,8 @@ parseWarning :: DynFlags -> GlobalRdrEnv -> WarningTxt -> Doc Name parseWarning dflags gre w = force $ case w of- DeprecatedTxt msg -> format "Deprecated: " (concatFS msg)- WarningTxt msg -> format "Warning: " (concatFS msg)+ DeprecatedTxt _ msg -> format "Deprecated: " (concatFS $ map unLoc msg)+ WarningTxt _ msg -> format "Warning: " (concatFS $ map unLoc msg) where format x xs = DocWarning . DocParagraph . DocAppend (DocString x) . processDocString dflags gre $ HsDocString xs@@ -256,19 +254,19 @@ f :: (Ord a, Monoid b) => [[(a, b)]] -> Map a b f = M.fromListWith (<>) . concat - f' :: [[(Name, Doc Name)]] -> Map Name (Doc Name)- f' = M.fromListWith docAppend . concat+ f' :: [[(Name, MDoc Name)]] -> Map Name (MDoc Name)+ f' = M.fromListWith metaDocAppend . concat mappings :: (LHsDecl Name, [HsDocString])- -> ( [(Name, Doc Name)]- , [(Name, Map Int (Doc Name))]+ -> ( [(Name, MDoc Name)]+ , [(Name, Map Int (MDoc Name))] , [(Name, [Name])] , [(Name, [LHsDecl Name])] ) mappings (ldecl, docStrs) = let L l decl = ldecl declDoc :: [HsDocString] -> Map Int HsDocString- -> (Maybe (Doc Name), Map Int (Doc Name))+ -> (Maybe (MDoc Name), Map Int (MDoc Name)) declDoc strs m = let doc' = processDocStrings dflags gre strs m' = M.map (processDocStringParas dflags gre) m@@ -333,26 +331,27 @@ dataSubs dd = constrs ++ fields where cons = map unL $ (dd_cons dd)- constrs = [ (unL $ con_name c, maybeToList $ fmap unL $ con_doc c, M.empty)- | c <- cons ]+ constrs = [ (unL cname, maybeToList $ fmap unL $ con_doc c, M.empty)+ | c <- cons, cname <- con_names c ] fields = [ (unL n, maybeToList $ fmap unL doc, M.empty) | RecCon flds <- map con_details cons- , ConDeclField n _ doc <- flds ]+ , L _ (ConDeclField ns _ doc) <- (unLoc flds)+ , n <- ns ] -- | Extract function argument docs from inside types. typeDocs :: HsDecl Name -> Map Int HsDocString typeDocs d = let docs = go 0 in case d of- SigD (TypeSig _ ty) -> docs (unLoc ty)- SigD (PatSynSig _ arg_tys ty req prov) ->- let allTys = ty : concat [ F.toList arg_tys, unLoc req, unLoc prov ]+ SigD (TypeSig _ ty _) -> docs (unLoc ty)+ SigD (PatSynSig _ _ req prov ty) ->+ let allTys = ty : concat [ unLoc req, unLoc prov ] in F.foldMap (docs . unLoc) allTys ForD (ForeignImport _ ty _ _) -> docs (unLoc ty) TyClD (SynDecl { tcdRhs = ty }) -> docs (unLoc ty) _ -> M.empty where- go n (HsForAllTy _ _ _ ty) = go n (unLoc ty)+ go n (HsForAllTy _ _ _ _ ty) = go n (unLoc ty) go n (HsFunTy (L _ (HsDocTy _ (L _ x))) (L _ ty)) = M.insert n x $ go (n+1) ty go n (HsFunTy _ ty) = go (n+1) (unLoc ty) go n (HsDocTy _ (L _ doc)) = M.singleton n doc@@ -366,11 +365,7 @@ where decls = docs ++ defs ++ sigs ++ ats docs = mkDecls tcdDocs DocD class_-#if MIN_VERSION_ghc(7,8,3) defs = mkDecls (bagToList . tcdMeths) ValD class_-#else- defs = mkDecls (map snd . bagToList . tcdMeths) ValD class_-#endif sigs = mkDecls tcdSigs SigD class_ ats = mkDecls tcdATs (TyClD . FamDecl) class_ @@ -383,7 +378,8 @@ -- | Extract a map of fixity declarations only mkFixMap :: HsGroup Name -> FixMap mkFixMap group_ = M.fromList [ (n,f)- | L _ (FixitySig (L _ n) f) <- hs_fixds group_ ]+ | L _ (FixitySig ns f) <- hs_fixds group_,+ L _ n <- ns ] -- | Take all declarations except pragmas, infix decls, rules from an 'HsGroup'.@@ -396,11 +392,7 @@ mkDecls hs_docs DocD group_ ++ mkDecls hs_instds InstD group_ ++ mkDecls (typesigs . hs_valds) SigD group_ ++-#if MIN_VERSION_ghc(7,8,3) mkDecls (valbinds . hs_valds) ValD group_-#else- mkDecls (map snd . valbinds . hs_valds) ValD group_-#endif where typesigs (ValBindsOut _ sigs) = filter isVanillaLSig sigs typesigs _ = error "expected ValBindsOut"@@ -503,11 +495,11 @@ Nothing -> fullModuleContents dflags warnings gre maps fixMap splices decls Just exports -> liftM concat $ mapM lookupExport exports where- lookupExport (IEVar x) = declWith x- lookupExport (IEThingAbs t) = declWith t- lookupExport (IEThingAll t) = declWith t- lookupExport (IEThingWith t _) = declWith t- lookupExport (IEModuleContents m) =+ lookupExport (IEVar (L _ x)) = declWith x+ lookupExport (IEThingAbs (L _ t)) = declWith t+ lookupExport (IEThingAll (L _ t)) = declWith t+ lookupExport (IEThingWith (L _ t) _) = declWith t+ lookupExport (IEModuleContents (L _ m)) = moduleExports thisMod m dflags warnings gre exportedNames decls modMap instIfaceMap maps fixMap splices lookupExport (IEGroup lev docStr) = return $ return . ExportGroup lev "" $ processDocString dflags gre docStr@@ -561,7 +553,7 @@ L loc (TyClD cl@ClassDecl{}) -> do mdef <- liftGhcToErrMsgGhc $ minimalDef t- let sig = maybeToList $ fmap (noLoc . MinimalSig . fmap noLoc) mdef+ let sig = maybeToList $ fmap (noLoc . MinimalSig mempty . fmap noLoc) mdef return [ mkExportDecl t (L loc $ TyClD cl { tcdSigs = sig ++ tcdSigs cl }) docs_ ] @@ -618,8 +610,15 @@ Nothing -> do liftErrMsg $ tell ["Warning: Not found in environment: " ++ pretty dflags t] return Nothing- Just x -> return (Just (tyThingToLHsDecl x))-+ Just x -> case tyThingToLHsDecl x of+ Left m -> liftErrMsg (tell [bugWarn m]) >> return Nothing+ Right (m, t') -> liftErrMsg (tell $ map bugWarn m)+ >> return (Just $ noLoc t')+ where+ warnLine x = O.text "haddock-bug:" O.<+> O.text x O.<>+ O.comma O.<+> O.quotes (O.ppr t) O.<+>+ O.text "-- Please report this on Haddock issue tracker!"+ bugWarn = O.showSDoc dflags . warnLine hiValExportItem :: DynFlags -> Name -> DocForDecl Name -> Bool -> Maybe Fixity -> ErrMsgGhc (ExportItem Name) hiValExportItem dflags name doc splice fixity = do@@ -634,7 +633,8 @@ -- | Lookup docs for a declaration from maps.-lookupDocs :: Name -> WarningMap -> DocMap Name -> ArgMap Name -> SubMap -> (DocForDecl Name, [(Name, DocForDecl Name)])+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@@ -689,8 +689,8 @@ "documentation for exported module: " ++ pretty dflags expMod] return [] where- m = mkModule packageId expMod- packageId = modulePackageId thisMod+ m = mkModule packageKey expMod+ packageKey = modulePackageKey thisMod -- Note [1]:@@ -724,7 +724,7 @@ 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 (TypeSig names t nwcs))) xs = foldr (\n acc -> L l (SigD (TypeSig [n] t nwcs)) : 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 @@ -745,7 +745,7 @@ return $ Just (ExportDecl decl doc subs [] (fixities name subs) (l `elem` splices)) mkExportItem (L l (TyClD cl@ClassDecl{ tcdLName = L _ name, tcdSigs = sigs })) = do mdef <- liftGhcToErrMsgGhc $ minimalDef name- let sig = maybeToList $ fmap (noLoc . MinimalSig . fmap noLoc) mdef+ let sig = maybeToList $ fmap (noLoc . MinimalSig mempty . fmap noLoc) mdef expDecl (L l (TyClD cl { tcdSigs = sig ++ sigs })) l name mkExportItem decl@(L l d) | name:_ <- getMainDeclBinder d = expDecl decl l name@@ -785,7 +785,8 @@ InstD (ClsInstD ClsInstDecl { cid_datafam_insts = insts }) -> let matches = [ d | L _ d <- insts , L _ ConDecl { con_details = RecCon rec } <- dd_cons (dfid_defn d)- , ConDeclField { cd_fld_name = L _ n } <- rec+ , ConDeclField { cd_fld_names = ns } <- map unLoc (unLoc rec)+ , L _ n <- ns , n == name ] in case matches of@@ -801,10 +802,10 @@ 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 (HsForAllTy Implicit emptyHsQTvs (lctxt []) ltype)))+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 Nothing tvs (lctxt preds) ty)) [])+ _ -> L pos (TypeSig lname (noLoc (HsForAllTy Implicit Nothing emptyHsQTvs (lctxt []) ltype)) []) where lctxt = noLoc . ctxt ctxt preds = nlHsTyConApp c (map toTypeNoLoc tvs0) : preds@@ -817,13 +818,13 @@ extractRecSel nm mdl t tvs (L _ con : rest) = case con_details con of- RecCon fields | (ConDeclField n ty _ : _) <- matching_fields fields ->- L (getLoc n) (TypeSig [noLoc nm] (noLoc (HsFunTy data_ty (getBangType ty))))+ RecCon (L _ fields) | ((n,L _ (ConDeclField _nn ty _)) : _) <- matching_fields fields ->+ L (getLoc n) (TypeSig [noLoc nm] (noLoc (HsFunTy data_ty (getBangType ty))) []) _ -> extractRecSel nm mdl t tvs rest where- matching_fields flds = [ f | f@(ConDeclField n _ _) <- flds, unLoc n == nm ]+ matching_fields flds = [ (n,f) | f@(L _ (ConDeclField ns _ _)) <- flds, n <- ns, unLoc n == nm ] data_ty- | ResTyGADT ty <- con_res con = ty+ | ResTyGADT _ ty <- con_res con = ty | otherwise = foldl' (\x y -> noLoc (HsAppTy x y)) (noLoc (HsTyVar t)) tvs
src/Haddock/Interface/LexParseRn.hs view
@@ -21,7 +21,7 @@ import Control.Applicative import Data.IntSet (toList) import Data.List-import Documentation.Haddock.Doc (docConcat)+import Documentation.Haddock.Doc (metaDocConcat) import DynFlags (ExtensionFlag(..), languageExtensions) import FastString import GHC@@ -32,31 +32,26 @@ import Outputable (showPpr) import RdrName -processDocStrings :: DynFlags -> GlobalRdrEnv -> [HsDocString] -> Maybe (Doc Name)+processDocStrings :: DynFlags -> GlobalRdrEnv -> [HsDocString]+ -> Maybe (MDoc Name) processDocStrings dflags gre strs =- case docConcat $ map (processDocStringParas dflags gre) strs of- DocEmpty -> Nothing+ case metaDocConcat $ map (processDocStringParas dflags gre) strs of+ -- We check that we don't have any version info to render instead+ -- of just checking if there is no comment: there may not be a+ -- comment but we still want to pass through any meta data.+ MetaDoc { _meta = Meta { _version = Nothing }, _doc = DocEmpty } -> Nothing x -> Just x --processDocStringParas :: DynFlags -> GlobalRdrEnv -> HsDocString -> Doc Name-processDocStringParas = process parseParas-+processDocStringParas :: DynFlags -> GlobalRdrEnv -> HsDocString -> MDoc Name+processDocStringParas dflags gre (HsDocString fs) =+ overDoc (rename dflags gre) $ parseParas dflags (unpackFS fs) processDocString :: DynFlags -> GlobalRdrEnv -> HsDocString -> Doc Name-processDocString = process parseString--process :: (DynFlags -> String -> Doc RdrName)- -> DynFlags- -> GlobalRdrEnv- -> HsDocString- -> Doc Name-process parse dflags gre (HsDocString fs) =- rename dflags gre $ parse dflags (unpackFS fs)-+processDocString dflags gre (HsDocString fs) =+ rename dflags gre $ parseString dflags (unpackFS fs) processModuleHeader :: DynFlags -> GlobalRdrEnv -> SafeHaskellMode -> Maybe LHsDocString- -> ErrMsgM (HaddockModInfo Name, Maybe (Doc Name))+ -> ErrMsgM (HaddockModInfo Name, Maybe (MDoc Name)) processModuleHeader dflags gre safety mayStr = do (hmi, doc) <- case mayStr of@@ -66,7 +61,7 @@ (hmi, doc) = parseModuleHeader dflags str !descr = rename dflags gre <$> hmi_description hmi hmi' = hmi { hmi_description = descr }- doc' = rename dflags gre doc+ doc' = overDoc (rename dflags gre) doc return (hmi', Just doc') let flags :: [ExtensionFlag]
src/Haddock/Interface/ParseModuleHeader.hs view
@@ -25,7 +25,7 @@ -- NB. The headers must be given in the order Module, Description, -- Copyright, License, Maintainer, Stability, Portability, except that -- any or all may be omitted.-parseModuleHeader :: DynFlags -> String -> (HaddockModInfo RdrName, Doc RdrName)+parseModuleHeader :: DynFlags -> String -> (HaddockModInfo RdrName, MDoc RdrName) parseModuleHeader dflags str0 = let getKey :: String -> String -> (Maybe String,String)
src/Haddock/Interface/Rename.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE TypeFamilies #-} ---------------------------------------------------------------------------- -- | -- Module : Haddock.Interface.Rename@@ -12,7 +13,7 @@ module Haddock.Interface.Rename (renameInterface) where -import Data.Traversable (traverse)+import Data.Traversable (mapM) import Haddock.GhcUtils import Haddock.Types@@ -20,12 +21,13 @@ import Bag (emptyBag) import GHC hiding (NoLink) import Name+import NameSet+import Coercion import Control.Applicative import Control.Monad hiding (mapM) import Data.List import qualified Data.Map as Map hiding ( Map )-import Data.Traversable (mapM) import Prelude hiding (mapM) @@ -160,10 +162,9 @@ renameLDocHsSyn = return -renameDoc :: Doc Name -> RnM (Doc DocName)+renameDoc :: Traversable t => t Name -> RnM (t DocName) renameDoc = traverse rename - renameFnArgsDoc :: FnArgsDoc Name -> RnM (FnArgsDoc DocName) renameFnArgsDoc = mapM renameDoc @@ -177,13 +178,14 @@ renameMaybeLKind :: Maybe (LHsKind Name) -> RnM (Maybe (LHsKind DocName)) renameMaybeLKind = traverse renameLKind + renameType :: HsType Name -> RnM (HsType DocName) renameType t = case t of- HsForAllTy expl tyvars lcontext ltype -> do+ HsForAllTy expl extra tyvars lcontext ltype -> do tyvars' <- renameLTyVarBndrs tyvars lcontext' <- renameLContext lcontext ltype' <- renameLType ltype- return (HsForAllTy expl tyvars' lcontext' ltype')+ return (HsForAllTy expl extra tyvars' lcontext' ltype') HsTyVar n -> return . HsTyVar =<< rename n HsBangTy b ltype -> return . HsBangTy b =<< renameLType ltype@@ -232,6 +234,8 @@ HsExplicitTupleTy a b -> HsExplicitTupleTy a <$> mapM renameLType b HsQuasiQuoteTy a -> HsQuasiQuoteTy <$> renameHsQuasiQuote a HsSpliceTy _ _ -> error "renameType: HsSpliceTy"+ HsWildcardTy -> pure HsWildcardTy+ HsNamedWildcardTy a -> HsNamedWildcardTy <$> rename a renameHsQuasiQuote :: HsQuasiQuote Name -> RnM (HsQuasiQuote DocName) renameHsQuasiQuote (HsQuasiQuote a b c) = HsQuasiQuote <$> rename a <*> pure b <*> pure c@@ -246,17 +250,16 @@ renameLTyVarBndr (L loc (UserTyVar n)) = do { n' <- rename n ; return (L loc (UserTyVar n')) }-renameLTyVarBndr (L loc (KindedTyVar n kind))+renameLTyVarBndr (L loc (KindedTyVar (L lv n) kind)) = do { n' <- rename n ; kind' <- renameLKind kind- ; return (L loc (KindedTyVar n' kind')) }+ ; return (L loc (KindedTyVar (L lv n') kind')) } renameLContext :: Located [LHsType Name] -> RnM (Located [LHsType DocName]) renameLContext (L loc context) = do context' <- mapM renameLType context return (L loc context') - renameInstHead :: InstHead Name -> RnM (InstHead DocName) renameInstHead (className, k, types, rest) = do className' <- rename className@@ -294,26 +297,22 @@ renameTyClD :: TyClDecl Name -> RnM (TyClDecl DocName) renameTyClD d = case d of- ForeignType lname b -> do- lname' <- renameL lname- return (ForeignType lname' b)- -- TyFamily flav lname ltyvars kind tckind -> do FamDecl { tcdFam = decl } -> do decl' <- renameFamilyDecl decl return (FamDecl { tcdFam = decl' }) - SynDecl { tcdLName = lname, tcdTyVars = tyvars, tcdRhs = rhs, tcdFVs = fvs } -> do+ SynDecl { tcdLName = lname, tcdTyVars = tyvars, tcdRhs = rhs, tcdFVs = _fvs } -> do lname' <- renameL lname tyvars' <- renameLTyVarBndrs tyvars rhs' <- renameLType rhs- return (SynDecl { tcdLName = lname', tcdTyVars = tyvars', tcdRhs = rhs', tcdFVs = fvs })+ return (SynDecl { tcdLName = lname', tcdTyVars = tyvars', tcdRhs = rhs', tcdFVs = placeHolderNames }) - DataDecl { tcdLName = lname, tcdTyVars = tyvars, tcdDataDefn = defn, tcdFVs = fvs } -> do+ DataDecl { tcdLName = lname, tcdTyVars = tyvars, tcdDataDefn = defn, tcdFVs = _fvs } -> do lname' <- renameL lname tyvars' <- renameLTyVarBndrs tyvars defn' <- renameDataDefn defn- return (DataDecl { tcdLName = lname', tcdTyVars = tyvars', tcdDataDefn = defn', tcdFVs = fvs })+ return (DataDecl { tcdLName = lname', tcdTyVars = tyvars', tcdDataDefn = defn', tcdFVs = placeHolderNames }) ClassDecl { tcdCtxt = lcontext, tcdLName = lname, tcdTyVars = ltyvars , tcdFDs = lfundeps, tcdSigs = lsigs, tcdATs = ats, tcdATDefs = at_defs } -> do@@ -323,7 +322,7 @@ lfundeps' <- mapM renameLFunDep lfundeps lsigs' <- mapM renameLSig lsigs ats' <- mapM (renameLThing renameFamilyDecl) ats- at_defs' <- mapM (mapM renameTyFamInstD) at_defs+ at_defs' <- mapM renameLTyFamDefltEqn at_defs -- we don't need the default methods or the already collected doc entities return (ClassDecl { tcdCtxt = lcontext', tcdLName = lname', tcdTyVars = ltyvars' , tcdFDs = lfundeps', tcdSigs = lsigs', tcdMeths= emptyBag@@ -331,9 +330,9 @@ where renameLFunDep (L loc (xs, ys)) = do- xs' <- mapM rename xs- ys' <- mapM rename ys- return (L loc (xs', ys'))+ xs' <- mapM rename (map unLoc xs)+ ys' <- mapM rename (map unLoc ys)+ return (L loc (map noLoc xs', map noLoc ys')) renameLSig (L loc sig) = return . L loc =<< renameSig sig @@ -351,7 +350,7 @@ renameFamilyInfo DataFamily = return DataFamily renameFamilyInfo OpenTypeFamily = return OpenTypeFamily renameFamilyInfo (ClosedTypeFamily eqns)- = do { eqns' <- mapM (renameLThing renameTyFamInstEqn) eqns+ = do { eqns' <- mapM renameLTyFamInstEqn eqns ; return $ ClosedTypeFamily eqns' } renameDataDefn :: HsDataDefn Name -> RnM (HsDataDefn DocName)@@ -365,19 +364,22 @@ , dd_kindSig = k', dd_cons = cons', dd_derivs = Nothing }) renameCon :: ConDecl Name -> RnM (ConDecl DocName)-renameCon decl@(ConDecl { con_name = lname, con_qvars = ltyvars+renameCon decl@(ConDecl { con_names = lnames, con_qvars = ltyvars , con_cxt = lcontext, con_details = details , con_res = restype, con_doc = mbldoc }) = do- lname' <- renameL lname+ lnames' <- mapM renameL lnames 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'+ return (decl { con_names = lnames', con_qvars = ltyvars', con_cxt = lcontext' , con_details = details', con_res = restype', con_doc = mbldoc' })+ where- renameDetails (RecCon fields) = return . RecCon =<< mapM renameConDeclFieldField fields+ renameDetails (RecCon (L l fields)) = do+ fields' <- mapM renameConDeclFieldField fields+ return (RecCon (L l fields')) renameDetails (PrefixCon ps) = return . PrefixCon =<< mapM renameLType ps renameDetails (InfixCon a b) = do a' <- renameLType a@@ -385,36 +387,34 @@ return (InfixCon a' b') renameResType (ResTyH98) = return ResTyH98- renameResType (ResTyGADT t) = return . ResTyGADT =<< renameLType t+ renameResType (ResTyGADT l t) = return . ResTyGADT l =<< renameLType t -renameConDeclFieldField :: ConDeclField Name -> RnM (ConDeclField DocName)-renameConDeclFieldField (ConDeclField name t doc) = do- name' <- renameL name+renameConDeclFieldField :: LConDeclField Name -> RnM (LConDeclField DocName)+renameConDeclFieldField (L l (ConDeclField names t doc)) = do+ names' <- mapM renameL names t' <- renameLType t doc' <- mapM renameLDocHsSyn doc- return (ConDeclField name' t' doc')+ return $ L l (ConDeclField names' t' doc') renameSig :: Sig Name -> RnM (Sig DocName) renameSig sig = case sig of- TypeSig lnames ltype -> do+ TypeSig lnames ltype _ -> do lnames' <- mapM renameL lnames ltype' <- renameLType ltype- return (TypeSig lnames' ltype')- PatSynSig lname args ltype lreq lprov -> do+ return (TypeSig lnames' ltype' PlaceHolder)+ PatSynSig lname (flag, qtvs) lreq lprov lty -> do lname' <- renameL lname- args' <- case args of- PrefixPatSyn largs -> PrefixPatSyn <$> mapM renameLType largs- InfixPatSyn lleft lright -> InfixPatSyn <$> renameLType lleft <*> renameLType lright- ltype' <- renameLType ltype+ qtvs' <- renameLTyVarBndrs qtvs lreq' <- renameLContext lreq lprov' <- renameLContext lprov- return $ PatSynSig lname' args' ltype' lreq' lprov'- FixSig (FixitySig lname fixity) -> do- lname' <- renameL lname- return $ FixSig (FixitySig lname' fixity)- MinimalSig s -> MinimalSig <$> traverse renameL s+ lty' <- renameLType lty+ return $ PatSynSig lname' (flag, qtvs') lreq' lprov' lty'+ FixSig (FixitySig lnames fixity) -> do+ lnames' <- mapM renameL lnames+ return $ FixSig (FixitySig lnames' fixity)+ MinimalSig src s -> MinimalSig src <$> traverse renameL s -- we have filtered out all other kinds of signatures in Interface.Create _ -> error "expected TypeSig" @@ -442,34 +442,50 @@ return (DataFamInstD { dfid_inst = d' }) renameClsInstD :: ClsInstDecl Name -> RnM (ClsInstDecl DocName)-renameClsInstD (ClsInstDecl { cid_poly_ty =ltype, cid_tyfam_insts = lATs, cid_datafam_insts = lADTs }) = do+renameClsInstD (ClsInstDecl { cid_overlap_mode = omode+ , cid_poly_ty =ltype, cid_tyfam_insts = lATs+ , cid_datafam_insts = lADTs }) = do ltype' <- renameLType ltype lATs' <- mapM (mapM renameTyFamInstD) lATs lADTs' <- mapM (mapM renameDataFamInstD) lADTs- return (ClsInstDecl { cid_poly_ty = ltype', cid_binds = emptyBag, cid_sigs = []+ return (ClsInstDecl { cid_overlap_mode = omode+ , cid_poly_ty = ltype', cid_binds = emptyBag+ , cid_sigs = [] , cid_tyfam_insts = lATs', cid_datafam_insts = lADTs' }) renameTyFamInstD :: TyFamInstDecl Name -> RnM (TyFamInstDecl DocName) renameTyFamInstD (TyFamInstDecl { tfid_eqn = eqn })- = do { eqn' <- renameLThing renameTyFamInstEqn eqn+ = do { eqn' <- renameLTyFamInstEqn eqn ; return (TyFamInstDecl { tfid_eqn = eqn' , tfid_fvs = placeHolderNames }) } -renameTyFamInstEqn :: TyFamInstEqn Name -> RnM (TyFamInstEqn DocName)-renameTyFamInstEqn (TyFamInstEqn { tfie_tycon = tc, tfie_pats = pats_w_bndrs, tfie_rhs = rhs })+renameLTyFamInstEqn :: LTyFamInstEqn Name -> RnM (LTyFamInstEqn DocName)+renameLTyFamInstEqn (L loc (TyFamEqn { tfe_tycon = tc, tfe_pats = pats_w_bndrs, tfe_rhs = rhs })) = do { tc' <- renameL tc ; pats' <- mapM renameLType (hswb_cts pats_w_bndrs) ; rhs' <- renameLType rhs- ; return (TyFamInstEqn { tfie_tycon = tc', tfie_pats = pats_w_bndrs { hswb_cts = pats' }- , tfie_rhs = rhs' }) }+ ; return (L loc (TyFamEqn { tfe_tycon = tc'+ , tfe_pats = HsWB pats' PlaceHolder PlaceHolder PlaceHolder+ , tfe_rhs = rhs' })) } +renameLTyFamDefltEqn :: LTyFamDefltEqn Name -> RnM (LTyFamDefltEqn DocName)+renameLTyFamDefltEqn (L loc (TyFamEqn { tfe_tycon = tc, tfe_pats = tvs, tfe_rhs = rhs }))+ = do { tc' <- renameL tc+ ; tvs' <- renameLTyVarBndrs tvs+ ; rhs' <- renameLType rhs+ ; return (L loc (TyFamEqn { tfe_tycon = tc'+ , tfe_pats = tvs'+ , tfe_rhs = rhs' })) }+ renameDataFamInstD :: DataFamInstDecl Name -> RnM (DataFamInstDecl DocName) renameDataFamInstD (DataFamInstDecl { dfid_tycon = tc, dfid_pats = pats_w_bndrs, dfid_defn = defn }) = do { tc' <- renameL tc ; pats' <- mapM renameLType (hswb_cts pats_w_bndrs) ; defn' <- renameDataDefn defn- ; return (DataFamInstDecl { dfid_tycon = tc', dfid_pats = pats_w_bndrs { hswb_cts = pats' }+ ; return (DataFamInstDecl { dfid_tycon = tc'+ , dfid_pats+ = HsWB pats' PlaceHolder PlaceHolder PlaceHolder , dfid_defn = defn', dfid_fvs = placeHolderNames }) } renameExportItem :: ExportItem Name -> RnM (ExportItem DocName)@@ -482,10 +498,10 @@ decl' <- renameLDecl decl doc' <- renameDocForDecl doc subs' <- mapM renameSub subs- instances' <- forM instances $ \(inst, idoc) -> do+ instances' <- forM instances $ \(L l inst, idoc) -> do inst' <- renameInstHead inst idoc' <- mapM renameDoc idoc- return (inst', idoc')+ return (L l inst', idoc') fixities' <- forM fixities $ \(name, fixity) -> do name' <- lookupRn name return (name', fixity)@@ -504,3 +520,12 @@ n' <- rename n doc' <- renameDocForDecl doc return (n', doc')++type instance PostRn DocName NameSet = PlaceHolder+type instance PostRn DocName Fixity = PlaceHolder+type instance PostRn DocName Bool = PlaceHolder+type instance PostRn DocName [Name] = PlaceHolder++type instance PostTc DocName Kind = PlaceHolder+type instance PostTc DocName Type = PlaceHolder+type instance PostTc DocName Coercion = PlaceHolder
src/Haddock/InterfaceFile.hs view
@@ -14,7 +14,7 @@ -- Reading and writing the .haddock interface file ----------------------------------------------------------------------------- module Haddock.InterfaceFile (- InterfaceFile(..), ifPackageId,+ InterfaceFile(..), ifPackageKey, readInterfaceFile, nameCacheFromGhc, freshNameCache, NameCacheAccessor, writeInterfaceFile, binaryInterfaceVersion, binaryInterfaceVersionCompatibility ) where@@ -52,11 +52,11 @@ } -ifPackageId :: InterfaceFile -> PackageId-ifPackageId if_ =+ifPackageKey :: InterfaceFile -> PackageKey+ifPackageKey if_ = case ifInstalledIfaces if_ of [] -> error "empty InterfaceFile"- iface:_ -> modulePackageId $ instMod iface+ iface:_ -> modulePackageKey $ instMod iface binaryInterfaceMagic :: Word32@@ -76,8 +76,8 @@ -- (2) set `binaryInterfaceVersionCompatibility` to [binaryInterfaceVersion] -- binaryInterfaceVersion :: Word16-#if __GLASGOW_HASKELL__ == 708-binaryInterfaceVersion = 25+#if (__GLASGOW_HASKELL__ >= 709) && (__GLASGOW_HASKELL__ < 711)+binaryInterfaceVersion = 27 binaryInterfaceVersionCompatibility :: [Word16] binaryInterfaceVersionCompatibility = [binaryInterfaceVersion]@@ -310,7 +310,7 @@ return (namecache', arr) -type OnDiskName = (PackageId, ModuleName, OccName)+type OnDiskName = (PackageKey, ModuleName, OccName) fromOnDiskName@@ -340,7 +340,7 @@ serialiseName :: BinHandle -> Name -> UniqFM (Int,Name) -> IO () serialiseName bh name _ = do let modu = nameModule name- put_ bh (modulePackageId modu, moduleName modu, nameOccName name)+ put_ bh (modulePackageKey modu, moduleName modu, nameOccName name) -------------------------------------------------------------------------------@@ -454,6 +454,19 @@ l <- get bh t <- get bh return (Header l t)++instance Binary Meta where+ put_ bh Meta { _version = v } = put_ bh v+ get bh = (\v -> Meta { _version = v }) <$> get bh++instance (Binary mod, Binary id) => Binary (MetaDoc mod id) where+ put_ bh MetaDoc { _meta = m, _doc = d } = do+ put_ bh m+ put_ bh d+ get bh = do+ m <- get bh+ d <- get bh+ return $ MetaDoc { _meta = m, _doc = d } {-* Generated by DrIFT : Look, but Don't Touch. *-} instance (Binary mod, Binary id) => Binary (DocH mod id) where
src/Haddock/ModuleTree.hs view
@@ -12,26 +12,29 @@ module Haddock.ModuleTree ( ModuleTree(..), mkModuleTree ) where -import Haddock.Types ( Doc )+import Haddock.Types ( MDoc ) import GHC ( Name )-import Module ( Module, moduleNameString, moduleName, modulePackageId,- packageIdString )+import Module ( Module, moduleNameString, moduleName, modulePackageKey )+import DynFlags ( DynFlags )+import Packages ( lookupPackage )+import PackageConfig ( sourcePackageIdString ) -data ModuleTree = Node String Bool (Maybe String) (Maybe (Doc Name)) [ModuleTree]+data ModuleTree = Node String Bool (Maybe String) (Maybe (MDoc Name)) [ModuleTree] -mkModuleTree :: Bool -> [(Module, Maybe (Doc Name))] -> [ModuleTree]-mkModuleTree showPkgs mods =+mkModuleTree :: DynFlags -> Bool -> [(Module, Maybe (MDoc Name))] -> [ModuleTree]+mkModuleTree dflags showPkgs mods = foldr fn [] [ (splitModule mdl, modPkg mdl, short) | (mdl, short) <- mods ] where- modPkg mod_ | showPkgs = Just (packageIdString (modulePackageId mod_))+ modPkg mod_ | showPkgs = fmap sourcePackageIdString+ (lookupPackage dflags (modulePackageKey mod_)) | otherwise = Nothing fn (mod_,pkg,short) = addToTrees mod_ pkg short -addToTrees :: [String] -> Maybe String -> Maybe (Doc Name) -> [ModuleTree] -> [ModuleTree]+addToTrees :: [String] -> Maybe String -> Maybe (MDoc Name) -> [ModuleTree] -> [ModuleTree] addToTrees [] _ _ ts = ts addToTrees ss pkg short [] = mkSubTree ss pkg short addToTrees (s1:ss) pkg short (t@(Node s2 leaf node_pkg node_short subs) : ts)@@ -43,7 +46,7 @@ this_short = if null ss then short else node_short -mkSubTree :: [String] -> Maybe String -> Maybe (Doc Name) -> [ModuleTree]+mkSubTree :: [String] -> Maybe String -> Maybe (MDoc Name) -> [ModuleTree] mkSubTree [] _ _ = [] mkSubTree [s] pkg short = [Node s True pkg short []] mkSubTree (s:ss) pkg short = [Node s (null ss) Nothing Nothing (mkSubTree ss pkg short)]
src/Haddock/Options.hs view
@@ -28,15 +28,21 @@ qualification, verbosity, ghcFlags,- readIfaceArgs+ readIfaceArgs,+ optPackageName,+ optPackageVersion ) where -import Distribution.Verbosity-import Haddock.Utils-import Haddock.Types-import System.Console.GetOpt import qualified Data.Char as Char+import Data.Version+import Distribution.Verbosity+import FastString+import Haddock.Types+import Haddock.Utils+import Packages+import System.Console.GetOpt+import qualified Text.ParserCombinators.ReadP as RP data Flag@@ -82,8 +88,10 @@ | Flag_NoTmpCompDir | Flag_Qualification String | Flag_PrettyHtml- | Flag_PrintMissingDocs- deriving (Eq)+ | Flag_NoPrintMissingDocs+ | Flag_PackageName String+ | Flag_PackageVersion String+ deriving (Eq, Show) options :: Bool -> [OptDescr Flag]@@ -107,7 +115,7 @@ Option [] ["latex-style"] (ReqArg Flag_LaTeXStyle "FILE") "provide your own LaTeX style in FILE", Option ['U'] ["use-unicode"] (NoArg Flag_UseUnicode) "use Unicode in HTML output", Option [] ["hoogle"] (NoArg Flag_Hoogle)- "output for Hoogle",+ "output for Hoogle; you may want --package-name and --package-version too", Option [] ["source-base"] (ReqArg Flag_SourceBaseURL "URL") "URL for a source code link on the contents\nand index pages", Option ['s'] (if backwardsCompat then ["source", "source-module"] else ["source-module"])@@ -170,8 +178,12 @@ "do not re-direct compilation output to a temporary directory", Option [] ["pretty-html"] (NoArg Flag_PrettyHtml) "generate html with newlines and indenting (for use with --html)",- Option [] ["print-missing-docs"] (NoArg Flag_PrintMissingDocs)- "print information about any undocumented entities"+ Option [] ["no-print-missing-docs"] (NoArg Flag_NoPrintMissingDocs)+ "don't print information about any undocumented entities",+ Option [] ["package-name"] (ReqArg Flag_PackageName "NAME")+ "name of the package being documented",+ Option [] ["package-version"] (ReqArg Flag_PackageVersion "VERSION")+ "version of the package being documented in usual x.y.z.w format" ] @@ -191,6 +203,15 @@ (_, _, errors) -> do usage <- getUsage throwE (concat errors ++ usage)++optPackageVersion :: [Flag] -> Maybe Data.Version.Version+optPackageVersion flags =+ let ver = optLast [ v | Flag_PackageVersion v <- flags ]+ in ver >>= fmap fst . optLast . RP.readP_to_S parseVersion++optPackageName :: [Flag] -> Maybe PackageName+optPackageName flags =+ optLast [ PackageName $ mkFastString n | Flag_PackageName n <- flags ] optTitle :: [Flag] -> Maybe String
src/Haddock/Parser.hs view
@@ -28,8 +28,8 @@ import SrcLoc (mkRealSrcLoc, unLoc) import StringBuffer (stringToStringBuffer) -parseParas :: DynFlags -> String -> DocH mod RdrName-parseParas d = P.overIdentifier (parseIdent d) . P.parseParas+parseParas :: DynFlags -> String -> MetaDoc mod RdrName+parseParas d = overDoc (P.overIdentifier (parseIdent d)) . P.parseParas parseString :: DynFlags -> String -> DocH mod RdrName parseString d = P.overIdentifier (parseIdent d) . P.parseString
src/Haddock/Types.hs view
@@ -34,7 +34,6 @@ import DynFlags (ExtensionFlag, Language) import OccName import Outputable-import Control.Applicative (Applicative(..)) import Control.Monad (ap) -----------------------------------------------------------------------------@@ -44,13 +43,13 @@ type IfaceMap = Map Module Interface type InstIfaceMap = Map Module InstalledInterface -- TODO: rename-type DocMap a = Map Name (Doc a)-type ArgMap a = Map Name (Map Int (Doc a))+type DocMap a = Map Name (MDoc a)+type ArgMap a = Map Name (Map Int (MDoc a)) type SubMap = Map Name [Name] type DeclMap = Map Name [LHsDecl Name] type InstMap = Map SrcSpan Name type FixMap = Map Name Fixity-type SrcMap = Map PackageId FilePath+type SrcMap = Map PackageKey FilePath type DocPaths = (FilePath, Maybe FilePath) -- paths to HTML and sources @@ -128,7 +127,7 @@ , ifaceWarningMap :: !WarningMap } -type WarningMap = DocMap Name+type WarningMap = Map Name (Doc Name) -- | A subset of the fields of 'Interface' that we store in the interface@@ -233,20 +232,20 @@ } -- | Some documentation.- | ExportDoc !(Doc name)+ | ExportDoc !(MDoc name) -- | A cross-reference to another module. | ExportModule !Module data Documentation name = Documentation- { documentationDoc :: Maybe (Doc name)+ { documentationDoc :: Maybe (MDoc name) , documentationWarning :: !(Maybe (Doc name)) } deriving Functor -- | 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 FnArgsDoc name = Map Int (MDoc name) type DocForDecl name = (Documentation name, FnArgsDoc name) @@ -300,8 +299,8 @@ ppr (TypeInst a) = text "TypeInst" <+> ppr a ppr (DataInst a) = text "DataInst" <+> ppr a --- | An instance head that may have documentation.-type DocInstance name = (InstHead name, Maybe (Doc name))+-- | An instance head that may have documentation and a source location.+type DocInstance name = (Located (InstHead name), Maybe (MDoc name)) -- | The head of an instance. Consists of a class name, a list of kind -- parameters, a list of type parameters and an instance type@@ -315,6 +314,7 @@ type LDoc id = Located (Doc id) type Doc id = DocH (ModuleName, OccName) id+type MDoc id = MetaDoc (ModuleName, OccName) id instance (NFData a, NFData mod) => NFData (DocH mod a) where@@ -342,9 +342,9 @@ DocHeader a -> a `deepseq` () -instance NFData Name-instance NFData OccName-instance NFData ModuleName+instance NFData Name where rnf x = seq x ()+instance NFData OccName where rnf x = seq x ()+instance NFData ModuleName where rnf x = seq x () instance NFData id => NFData (Header id) where rnf (Header a b) = a `deepseq` b `deepseq` ()
src/Haddock/Utils.hs view
@@ -39,6 +39,7 @@ -- * Doc markup markup, idMarkup,+ mkMeta, -- * List utilities replace,@@ -56,6 +57,7 @@ ) where +import Documentation.Haddock.Doc (emptyMetaDoc) import Haddock.Types import Haddock.GhcUtils @@ -110,14 +112,16 @@ -- | Extract a module's short description.-toDescription :: Interface -> Maybe (Doc Name)-toDescription = hmi_description . ifaceInfo+toDescription :: Interface -> Maybe (MDoc Name)+toDescription = fmap mkMeta . hmi_description . ifaceInfo -- | Extract a module's short description.-toInstalledDescription :: InstalledInterface -> Maybe (Doc Name)-toInstalledDescription = hmi_description . instInfo+toInstalledDescription :: InstalledInterface -> Maybe (MDoc Name)+toInstalledDescription = fmap mkMeta . hmi_description . instInfo +mkMeta :: Doc a -> MDoc a+mkMeta x = emptyMetaDoc { _doc = x } -------------------------------------------------------------------------------- -- * Making abstract declarations@@ -146,24 +150,23 @@ restrictCons :: [Name] -> [LConDecl Name] -> [LConDecl Name] restrictCons names decls = [ L p d | L p (Just d) <- map (fmap keep) decls ] where- keep d | unLoc (con_name d) `elem` names =+ keep d | any (\n -> n `elem` names) (map unLoc $ con_names d) = case con_details d of PrefixCon _ -> Just d RecCon fields- | all field_avail fields -> Just d- | otherwise -> Just (d { con_details = PrefixCon (field_types fields) })+ | all field_avail (unL fields) -> Just d+ | otherwise -> Just (d { con_details = PrefixCon (field_types (map unL (unL fields))) }) -- if we have *all* the field names available, then -- keep the record declaration. Otherwise degrade to -- a constructor declaration. This isn't quite right, but -- it's the best we can do. InfixCon _ _ -> Just d where- field_avail (ConDeclField n _ _) = unLoc n `elem` names+ field_avail (L _ (ConDeclField ns _ _)) = all (\n -> unLoc n `elem` names) ns field_types flds = [ t | ConDeclField _ t _ <- flds ] keep _ = Nothing - restrictDecls :: [Name] -> [LSig Name] -> [LSig Name] restrictDecls names = mapMaybe (filterLSigNames (`elem` names)) @@ -300,11 +303,7 @@ bye s = putStr s >> exitSuccess -die :: String -> IO a-die s = hPutStr stderr s >> exitWith (ExitFailure 1)---dieMsg :: String -> IO a+dieMsg :: String -> IO () dieMsg s = getProgramName >>= \prog -> die (prog ++ ": " ++ s)