diff options
Diffstat (limited to 'haddock-api/src/Haddock')
27 files changed, 9267 insertions, 0 deletions
diff --git a/haddock-api/src/Haddock/Backends/HaddockDB.hs b/haddock-api/src/Haddock/Backends/HaddockDB.hs new file mode 100644 index 00000000..1c248bfb --- /dev/null +++ b/haddock-api/src/Haddock/Backends/HaddockDB.hs @@ -0,0 +1,170 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Haddock.Backends.HaddockDB +-- Copyright : (c) Simon Marlow 2003 +-- License : BSD-like +-- +-- Maintainer : haddock@projects.haskell.org +-- Stability : experimental +-- Portability : portable +----------------------------------------------------------------------------- +module Haddock.Backends.HaddockDB (ppDocBook) where + +{- +import HaddockTypes +import HaddockUtil +import HsSyn2 + +import Text.PrettyPrint +-} + +----------------------------------------------------------------------------- +-- Printing the results in DocBook format + +ppDocBook :: a +ppDocBook = error "not working" +{- +ppDocBook :: FilePath -> [(Module, Interface)] -> String +ppDocBook odir mods = render (ppIfaces mods) + +ppIfaces mods + = text "<!DOCTYPE BOOK PUBLIC \"-//OASIS//DTD DocBook V3.1//EN\" [" + $$ text "]>" + $$ text "<book>" + $$ text "<bookinfo>" + $$ text "<author><othername>HaskellDoc version 0.0</othername></author>" + $$ text "</bookinfo>" + $$ text "<article>" + $$ vcat (map do_mod mods) + $$ text "</article></book>" + where + do_mod (Module mod, iface) + = text "<sect1 id=\"sec-" <> text mod <> text "\">" + $$ text "<title><literal>" + <> text mod + <> text "</literal></title>" + $$ text "<indexterm><primary><literal>" + <> text mod + <> text "</literal></primary></indexterm>" + $$ text "<variablelist>" + $$ vcat (map (do_export mod) (eltsFM (iface_decls iface))) + $$ text "</variablelist>" + $$ text "</sect1>" + + do_export mod decl | (nm:_) <- declBinders decl + = text "<varlistentry id=" <> ppLinkId mod nm <> char '>' + $$ text "<term><literal>" + <> do_decl decl + <> text "</literal></term>" + $$ text "<listitem>" + $$ text "<para>" + $$ text "</para>" + $$ text "</listitem>" + $$ text "</varlistentry>" + do_export _ _ = empty + + do_decl (HsTypeSig _ [nm] ty _) + = ppHsName nm <> text " :: " <> ppHsType ty + do_decl (HsTypeDecl _ nm args ty _) + = hsep ([text "type", ppHsName nm ] + ++ map ppHsName args + ++ [equals, ppHsType ty]) + do_decl (HsNewTypeDecl loc ctx nm args con drv _) + = hsep ([text "data", ppHsName nm] -- data, not newtype + ++ map ppHsName args + ) <+> equals <+> ppHsConstr con -- ToDo: derivings + do_decl (HsDataDecl loc ctx nm args cons drv _) + = hsep ([text "data", {-ToDo: context-}ppHsName nm] + ++ map ppHsName args) + <+> vcat (zipWith (<+>) (equals : repeat (char '|')) + (map ppHsConstr cons)) + do_decl (HsClassDecl loc ty fds decl _) + = hsep [text "class", ppHsType ty] + do_decl decl + = empty + +ppHsConstr :: HsConDecl -> Doc +ppHsConstr (HsRecDecl pos name tvs ctxt fieldList maybe_doc) = + ppHsName name + <> (braces . hsep . punctuate comma . map ppField $ fieldList) +ppHsConstr (HsConDecl pos name tvs ctxt typeList maybe_doc) = + hsep (ppHsName name : map ppHsBangType typeList) + +ppField (HsFieldDecl ns ty doc) + = hsep (punctuate comma (map ppHsName ns) ++ + [text "::", ppHsBangType ty]) + +ppHsBangType :: HsBangType -> Doc +ppHsBangType (HsBangedTy ty) = char '!' <> ppHsType ty +ppHsBangType (HsUnBangedTy ty) = ppHsType ty + +ppHsContext :: HsContext -> Doc +ppHsContext [] = empty +ppHsContext context = parenList (map (\ (a,b) -> ppHsQName a <+> + hsep (map ppHsAType b)) context) + +ppHsType :: HsType -> Doc +ppHsType (HsForAllType Nothing context htype) = + hsep [ ppHsContext context, text "=>", ppHsType htype] +ppHsType (HsForAllType (Just tvs) [] htype) = + hsep (text "forall" : map ppHsName tvs ++ text "." : [ppHsType htype]) +ppHsType (HsForAllType (Just tvs) context htype) = + hsep (text "forall" : map ppHsName tvs ++ text "." : + ppHsContext context : text "=>" : [ppHsType htype]) +ppHsType (HsTyFun a b) = fsep [ppHsBType a, text "->", ppHsType b] +ppHsType (HsTyIP n t) = fsep [(char '?' <> ppHsName n), text "::", ppHsType t] +ppHsType t = ppHsBType t + +ppHsBType (HsTyApp (HsTyCon (Qual (Module "Prelude") (HsTyClsName (HsSpecial "[]")))) b ) + = brackets $ ppHsType b +ppHsBType (HsTyApp a b) = fsep [ppHsBType a, ppHsAType b] +ppHsBType t = ppHsAType t + +ppHsAType :: HsType -> Doc +ppHsAType (HsTyTuple True l) = parenList . map ppHsType $ l +ppHsAType (HsTyTuple False l) = ubxParenList . map ppHsType $ l +-- special case +ppHsAType (HsTyApp (HsTyCon (Qual (Module "Prelude") (HsTyClsName (HsSpecial "[]")))) b ) + = brackets $ ppHsType b +ppHsAType (HsTyVar name) = ppHsName name +ppHsAType (HsTyCon name) = ppHsQName name +ppHsAType t = parens $ ppHsType t + +ppHsQName :: HsQName -> Doc +ppHsQName (UnQual str) = ppHsName str +ppHsQName n@(Qual (Module mod) str) + | n == unit_con_name = ppHsName str + | isSpecial str = ppHsName str + | otherwise + = text "<link linkend=" <> ppLinkId mod str <> char '>' + <> ppHsName str + <> text "</link>" + +isSpecial (HsTyClsName id) | HsSpecial _ <- id = True +isSpecial (HsVarName id) | HsSpecial _ <- id = True +isSpecial _ = False + +ppHsName :: HsName -> Doc +ppHsName (HsTyClsName id) = ppHsIdentifier id +ppHsName (HsVarName id) = ppHsIdentifier id + +ppHsIdentifier :: HsIdentifier -> Doc +ppHsIdentifier (HsIdent str) = text str +ppHsIdentifier (HsSymbol str) = text str +ppHsIdentifier (HsSpecial str) = text str + +ppLinkId :: String -> HsName -> Doc +ppLinkId mod str + = hcat [char '\"', text mod, char '.', ppHsName str, char '\"'] + +-- ----------------------------------------------------------------------------- +-- * Misc + +parenList :: [Doc] -> Doc +parenList = parens . fsep . punctuate comma + +ubxParenList :: [Doc] -> Doc +ubxParenList = ubxparens . fsep . punctuate comma + +ubxparens p = text "(#" <> p <> text "#)" +-} diff --git a/haddock-api/src/Haddock/Backends/Hoogle.hs b/haddock-api/src/Haddock/Backends/Hoogle.hs new file mode 100644 index 00000000..628e1cd0 --- /dev/null +++ b/haddock-api/src/Haddock/Backends/Hoogle.hs @@ -0,0 +1,331 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Haddock.Backends.Hoogle +-- Copyright : (c) Neil Mitchell 2006-2008 +-- License : BSD-like +-- +-- Maintainer : haddock@projects.haskell.org +-- Stability : experimental +-- Portability : portable +-- +-- Write out Hoogle compatible documentation +-- http://www.haskell.org/hoogle/ +----------------------------------------------------------------------------- +module Haddock.Backends.Hoogle ( + ppHoogle + ) where + + +import Haddock.GhcUtils +import Haddock.Types +import Haddock.Utils hiding (out) +import GHC +import Outputable + +import Data.Char +import Data.List +import Data.Maybe +import System.FilePath +import System.IO + +prefix :: [String] +prefix = ["-- Hoogle documentation, generated by Haddock" + ,"-- See Hoogle, http://www.haskell.org/hoogle/" + ,""] + + +ppHoogle :: DynFlags -> String -> String -> String -> Maybe (Doc RdrName) -> [Interface] -> FilePath -> IO () +ppHoogle dflags package version synopsis prologue ifaces odir = do + let filename = package ++ ".txt" + contents = prefix ++ + docWith dflags (drop 2 $ dropWhile (/= ':') synopsis) prologue ++ + ["@package " ++ package] ++ + ["@version " ++ version | version /= ""] ++ + concat [ppModule dflags i | i <- ifaces, OptHide `notElem` ifaceOptions i] + h <- openFile (odir </> filename) WriteMode + hSetEncoding h utf8 + hPutStr h (unlines contents) + hClose h + +ppModule :: DynFlags -> Interface -> [String] +ppModule dflags iface = + "" : ppDocumentation dflags (ifaceDoc iface) ++ + ["module " ++ moduleString (ifaceMod iface)] ++ + concatMap (ppExport dflags) (ifaceExportItems iface) ++ + concatMap (ppInstance dflags) (ifaceInstances iface) + + +--------------------------------------------------------------------- +-- Utility functions + +dropHsDocTy :: HsType a -> HsType a +dropHsDocTy = f + where + g (L src x) = L src (f x) + f (HsForAllTy a b c d) = HsForAllTy a b c (g d) + 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) + f (HsListTy a) = HsListTy (g a) + f (HsPArrTy a) = HsPArrTy (g a) + f (HsTupleTy a b) = HsTupleTy a (map g b) + f (HsOpTy a b c) = HsOpTy (g a) b (g c) + f (HsParTy a) = HsParTy (g a) + f (HsKindSig a b) = HsKindSig (g a) b + f (HsDocTy a _) = f $ unL a + f x = x + +outHsType :: OutputableBndr a => DynFlags -> HsType a -> String +outHsType dflags = out dflags . dropHsDocTy + + +makeExplicit :: HsType a -> HsType a +makeExplicit (HsForAllTy _ a b c) = HsForAllTy Explicit a b c +makeExplicit x = x + +makeExplicitL :: LHsType a -> LHsType a +makeExplicitL (L src x) = L src (makeExplicit x) + + +dropComment :: String -> String +dropComment (' ':'-':'-':' ':_) = [] +dropComment (x:xs) = x : dropComment xs +dropComment [] = [] + + +out :: Outputable a => DynFlags -> a -> String +out dflags = f . unwords . map (dropWhile isSpace) . lines . showSDocUnqual dflags . ppr + where + f xs | " <document comment>" `isPrefixOf` xs = f $ drop 19 xs + f (x:xs) = x : f xs + f [] = [] + + +operator :: String -> String +operator (x:xs) | not (isAlphaNum x) && x `notElem` "_' ([{" = '(' : x:xs ++ ")" +operator x = x + + +--------------------------------------------------------------------- +-- How to print each export + +ppExport :: DynFlags -> ExportItem Name -> [String] +ppExport dflags ExportDecl { expItemDecl = L _ decl + , expItemMbDoc = (dc, _) + , expItemSubDocs = subdocs + } = ppDocumentation dflags dc ++ f decl + where + 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 (SigD sig) = ppSig dflags sig + f _ = [] +ppExport _ _ = [] + + +ppSig :: DynFlags -> Sig Name -> [String] +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 + x -> x +ppSig _ _ = [] + + +-- note: does not yet output documentation for class methods +ppClass :: DynFlags -> TyClDecl Name -> [String] +ppClass dflags x = out dflags x{tcdSigs=[]} : + concatMap (ppSig dflags . addContext . unL) (tcdSigs x) + where + addContext (TypeSig name (L l sig)) = TypeSig name (L l $ f sig) + addContext (MinimalSig sig) = MinimalSig 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) + + context = nlHsTyConApp (tcdName x) + (map (reL . HsTyVar . hsTyVarName . unL) (hsQTvBndrs (tyClDeclTyVars x))) + + +ppInstance :: DynFlags -> ClsInst -> [String] +ppInstance dflags x = [dropComment $ out dflags x] + + +ppSynonym :: DynFlags -> TyClDecl Name -> [String] +ppSynonym dflags x = [out dflags x] + +ppData :: DynFlags -> TyClDecl Name -> [(Name, DocForDecl Name)] -> [String] +ppData dflags decl@(DataDecl { tcdDataDefn = defn }) subdocs + = showData decl{ tcdDataDefn = defn { dd_cons=[],dd_derivs=Nothing }} : + concatMap (ppCtor dflags decl subdocs . unL) (dd_cons defn) + where + + -- GHC gives out "data Bar =", we want to delete the equals + -- also writes data : a b, when we want data (:) a b + showData d = unwords $ map f $ if last xs == "=" then init xs else xs + where + xs = words $ out dflags d + nam = out dflags $ tyClDeclLName d + f w = if w == nam then operator nam else w +ppData _ _ _ = panic "ppData" + +-- | for constructors, and named-fields... +lookupCon :: DynFlags -> [(Name, DocForDecl Name)] -> Located Name -> [String] +lookupCon dflags subdocs (L _ name) = case lookup name subdocs of + Just (d, _) -> ppDocumentation dflags d + _ -> [] + +ppCtor :: DynFlags -> TyClDecl Name -> [(Name, DocForDecl Name)] -> ConDecl Name -> [String] +ppCtor dflags dat subdocs con = lookupCon dflags subdocs (con_name con) + ++ f (con_details con) + where + f (PrefixCon args) = [typeSig name $ args ++ [resType]] + f (InfixCon a1 a2) = f $ PrefixCon [a1,a2] + f (RecCon recs) = f (PrefixCon $ map cd_fld_type recs) ++ concat + [lookupCon dflags subdocs (cd_fld_name r) ++ + [out dflags (unL $ cd_fld_name r) `typeSig` [resType, cd_fld_type r]] + | r <- recs] + + funs = foldr1 (\x y -> reL $ HsFunTy (makeExplicitL x) (makeExplicitL y)) + apps = foldl1 (\x y -> reL $ HsAppTy x y) + + typeSig nm flds = operator nm ++ " :: " ++ outHsType dflags (makeExplicit $ unL $ funs flds) + name = out dflags $ unL $ con_name 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 + + +--------------------------------------------------------------------- +-- DOCUMENTATION + +ppDocumentation :: Outputable o => DynFlags -> Documentation o -> [String] +ppDocumentation dflags (Documentation d w) = doc dflags d ++ doc dflags w + + +doc :: Outputable o => DynFlags -> Maybe (Doc o) -> [String] +doc dflags = docWith dflags "" + + +docWith :: Outputable o => DynFlags -> String -> Maybe (Doc o) -> [String] +docWith _ [] Nothing = [] +docWith dflags header d + = ("":) $ zipWith (++) ("-- | " : repeat "-- ") $ + [header | header /= ""] ++ ["" | header /= "" && isJust d] ++ + maybe [] (showTags . markup (markupTag dflags)) d + + +data Tag = TagL Char [Tags] | TagP Tags | TagPre Tags | TagInline String Tags | Str String + deriving Show + +type Tags = [Tag] + +box :: (a -> b) -> a -> [b] +box f x = [f x] + +str :: String -> [Tag] +str a = [Str a] + +-- want things like paragraph, pre etc to be handled by blank lines in the source document +-- and things like \n and \t converted away +-- much like blogger in HTML mode +-- everything else wants to be included as tags, neatly nested for some (ul,li,ol) +-- or inlne for others (a,i,tt) +-- entities (&,>,<) should always be appropriately escaped + +markupTag :: Outputable o => DynFlags -> DocMarkup o [Tag] +markupTag dflags = Markup { + markupParagraph = box TagP, + markupEmpty = str "", + markupString = str, + markupAppend = (++), + markupIdentifier = box (TagInline "a") . str . out dflags, + markupIdentifierUnchecked = box (TagInline "a") . str . out dflags . snd, + markupModule = box (TagInline "a") . str, + markupWarning = box (TagInline "i"), + markupEmphasis = box (TagInline "i"), + markupBold = box (TagInline "b"), + markupMonospaced = box (TagInline "tt"), + markupPic = const $ str " ", + markupUnorderedList = box (TagL 'u'), + markupOrderedList = box (TagL 'o'), + markupDefList = box (TagL 'u') . map (\(a,b) -> TagInline "i" a : Str " " : b), + markupCodeBlock = box TagPre, + markupHyperlink = \(Hyperlink url mLabel) -> (box (TagInline "a") . str) (fromMaybe url mLabel), + markupAName = const $ str "", + markupProperty = box TagPre . str, + markupExample = box TagPre . str . unlines . map exampleToString, + markupHeader = \(Header l h) -> box (TagInline $ "h" ++ show l) h + } + + +showTags :: [Tag] -> [String] +showTags = intercalate [""] . map showBlock + + +showBlock :: Tag -> [String] +showBlock (TagP xs) = showInline xs +showBlock (TagL t xs) = ['<':t:"l>"] ++ mid ++ ['<':'/':t:"l>"] + where mid = concatMap (showInline . box (TagInline "li")) xs +showBlock (TagPre xs) = ["<pre>"] ++ showPre xs ++ ["</pre>"] +showBlock x = showInline [x] + + +asInline :: Tag -> Tags +asInline (TagP xs) = xs +asInline (TagPre xs) = [TagInline "pre" xs] +asInline (TagL t xs) = [TagInline (t:"l") $ map (TagInline "li") xs] +asInline x = [x] + + +showInline :: [Tag] -> [String] +showInline = unwordsWrap 70 . words . concatMap f + where + fs = concatMap f + f (Str x) = escape x + f (TagInline s xs) = "<"++s++">" ++ (if s == "li" then trim else id) (fs xs) ++ "</"++s++">" + f x = fs $ asInline x + + trim = dropWhile isSpace . reverse . dropWhile isSpace . reverse + + +showPre :: [Tag] -> [String] +showPre = trimFront . trimLines . lines . concatMap f + where + trimLines = dropWhile null . reverse . dropWhile null . reverse + trimFront xs = map (drop i) xs + where + ns = [length a | x <- xs, let (a,b) = span isSpace x, b /= ""] + i = if null ns then 0 else minimum ns + + fs = concatMap f + f (Str x) = escape x + f (TagInline s xs) = "<"++s++">" ++ fs xs ++ "</"++s++">" + f x = fs $ asInline x + + +unwordsWrap :: Int -> [String] -> [String] +unwordsWrap n = f n [] + where + f _ s [] = [g s | s /= []] + f i s (x:xs) | nx > i = g s : f (n - nx - 1) [x] xs + | otherwise = f (i - nx - 1) (x:s) xs + where nx = length x + + g = unwords . reverse + + +escape :: String -> String +escape = concatMap f + where + f '<' = "<" + f '>' = ">" + f '&' = "&" + f x = [x] diff --git a/haddock-api/src/Haddock/Backends/LaTeX.hs b/haddock-api/src/Haddock/Backends/LaTeX.hs new file mode 100644 index 00000000..7b72c030 --- /dev/null +++ b/haddock-api/src/Haddock/Backends/LaTeX.hs @@ -0,0 +1,1221 @@ +{-# OPTIONS_GHC -fno-warn-name-shadowing #-} +----------------------------------------------------------------------------- +-- | +-- Module : Haddock.Backends.LaTeX +-- Copyright : (c) Simon Marlow 2010, +-- Mateusz Kowalczyk 2013 +-- License : BSD-like +-- +-- Maintainer : haddock@projects.haskell.org +-- Stability : experimental +-- Portability : portable +----------------------------------------------------------------------------- +module Haddock.Backends.LaTeX ( + ppLaTeX +) where + + +import Haddock.Types +import Haddock.Utils +import Haddock.GhcUtils +import Pretty hiding (Doc, quote) +import qualified Pretty + +import GHC +import OccName +import Name ( nameOccName ) +import RdrName ( rdrNameOcc ) +import FastString ( unpackFS, unpackLitString, zString ) + +import qualified Data.Map as Map +import System.Directory +import System.FilePath +import Data.Char +import Control.Monad +import Data.Maybe +import Data.List + +import Haddock.Doc (combineDocumentation) + +-- import Debug.Trace + +{- SAMPLE OUTPUT + +\haddockmoduleheading{\texttt{Data.List}} +\hrulefill +{\haddockverb\begin{verbatim} +module Data.List ( + (++), head, last, tail, init, null, length, map, reverse, + ) where\end{verbatim}} +\hrulefill + +\section{Basic functions} +\begin{haddockdesc} +\item[\begin{tabular}{@{}l} +head\ ::\ {\char 91}a{\char 93}\ ->\ a +\end{tabular}]\haddockbegindoc +Extract the first element of a list, which must be non-empty. +\par + +\end{haddockdesc} +\begin{haddockdesc} +\item[\begin{tabular}{@{}l} +last\ ::\ {\char 91}a{\char 93}\ ->\ a +\end{tabular}]\haddockbegindoc +Extract the last element of a list, which must be finite and non-empty. +\par + +\end{haddockdesc} +-} + + +{- TODO + * don't forget fixity!! +-} + +ppLaTeX :: String -- Title + -> Maybe String -- Package name + -> [Interface] + -> FilePath -- destination directory + -> Maybe (Doc GHC.RdrName) -- prologue text, maybe + -> Maybe String -- style file + -> FilePath + -> IO () + +ppLaTeX title packageStr visible_ifaces odir prologue maybe_style libdir + = do + createDirectoryIfMissing True odir + when (isNothing maybe_style) $ + copyFile (libdir </> "latex" </> haddockSty) (odir </> haddockSty) + ppLaTeXTop title packageStr odir prologue maybe_style visible_ifaces + mapM_ (ppLaTeXModule title odir) visible_ifaces + + +haddockSty :: FilePath +haddockSty = "haddock.sty" + + +type LaTeX = Pretty.Doc + + +ppLaTeXTop + :: String + -> Maybe String + -> FilePath + -> Maybe (Doc GHC.RdrName) + -> Maybe String + -> [Interface] + -> IO () + +ppLaTeXTop doctitle packageStr odir prologue maybe_style ifaces = do + + let tex = vcat [ + text "\\documentclass{book}", + text "\\usepackage" <> braces (maybe (text "haddock") text maybe_style), + text "\\begin{document}", + text "\\begin{titlepage}", + text "\\begin{haddocktitle}", + text doctitle, + text "\\end{haddocktitle}", + case prologue of + Nothing -> empty + Just d -> vcat [text "\\begin{haddockprologue}", + rdrDocToLaTeX d, + text "\\end{haddockprologue}"], + text "\\end{titlepage}", + text "\\tableofcontents", + vcat [ text "\\input" <> braces (text mdl) | mdl <- mods ], + text "\\end{document}" + ] + + mods = sort (map (moduleBasename.ifaceMod) ifaces) + + filename = odir </> (fromMaybe "haddock" packageStr <.> "tex") + + writeFile filename (show tex) + + +ppLaTeXModule :: String -> FilePath -> Interface -> IO () +ppLaTeXModule _title odir iface = do + createDirectoryIfMissing True odir + let + mdl = ifaceMod iface + mdl_str = moduleString mdl + + exports = ifaceRnExportItems iface + + tex = vcat [ + text "\\haddockmoduleheading" <> braces (text mdl_str), + text "\\label{module:" <> text mdl_str <> char '}', + text "\\haddockbeginheader", + verb $ vcat [ + text "module" <+> text mdl_str <+> lparen, + text " " <> fsep (punctuate (text ", ") $ + map exportListItem $ + filter forSummary exports), + text " ) where" + ], + text "\\haddockendheader" $$ text "", + description, + body + ] + + description + = (fromMaybe empty . documentationToLaTeX . ifaceRnDoc) iface + + body = processExports exports + -- + writeFile (odir </> moduleLaTeXFile mdl) (fullRender PageMode 80 1 string_txt "" tex) + + +string_txt :: TextDetails -> String -> String +string_txt (Chr c) s = c:s +string_txt (Str s1) s2 = s1 ++ s2 +string_txt (PStr s1) s2 = unpackFS s1 ++ s2 +string_txt (ZStr s1) s2 = zString s1 ++ s2 +string_txt (LStr s1 _) s2 = unpackLitString s1 ++ s2 + + +exportListItem :: ExportItem DocName -> LaTeX +exportListItem ExportDecl { expItemDecl = decl, expItemSubDocs = subdocs } + = sep (punctuate comma . map ppDocBinder $ declNames decl) <> + case subdocs of + [] -> empty + _ -> parens (sep (punctuate comma (map (ppDocBinder . fst) subdocs))) +exportListItem (ExportNoDecl y []) + = ppDocBinder y +exportListItem (ExportNoDecl y subs) + = ppDocBinder y <> parens (sep (punctuate comma (map ppDocBinder subs))) +exportListItem (ExportModule mdl) + = text "module" <+> text (moduleString mdl) +exportListItem _ + = error "exportListItem" + + +-- Deal with a group of undocumented exports together, to avoid lots +-- of blank vertical space between them. +processExports :: [ExportItem DocName] -> LaTeX +processExports [] = empty +processExports (decl : es) + | Just sig <- isSimpleSig decl + = multiDecl [ ppTypeSig (map getName names) typ False + | (names,typ) <- sig:sigs ] $$ + processExports es' + where (sigs, es') = spanWith isSimpleSig es +processExports (ExportModule mdl : es) + = declWithDoc (vcat [ text "module" <+> text (moduleString m) | m <- mdl:mdls ]) Nothing $$ + processExports es' + where (mdls, es') = spanWith isExportModule es +processExports (e : es) = + processExport e $$ processExports es + + +isSimpleSig :: ExportItem DocName -> Maybe ([DocName], HsType DocName) +isSimpleSig ExportDecl { expItemDecl = L _ (SigD (TypeSig lnames (L _ t))) + , expItemMbDoc = (Documentation Nothing Nothing, argDocs) } + | Map.null argDocs = Just (map unLoc lnames, t) +isSimpleSig _ = Nothing + + +isExportModule :: ExportItem DocName -> Maybe Module +isExportModule (ExportModule m) = Just m +isExportModule _ = Nothing + + +processExport :: ExportItem DocName -> LaTeX +processExport (ExportGroup lev _id0 doc) + = ppDocGroup lev (docToLaTeX doc) +processExport (ExportDecl decl doc subdocs insts fixities _splice) + = ppDecl decl doc insts subdocs fixities +processExport (ExportNoDecl y []) + = ppDocName y +processExport (ExportNoDecl y subs) + = ppDocName y <> parens (sep (punctuate comma (map ppDocName subs))) +processExport (ExportModule mdl) + = declWithDoc (text "module" <+> text (moduleString mdl)) Nothing +processExport (ExportDoc doc) + = docToLaTeX doc + + +ppDocGroup :: Int -> LaTeX -> LaTeX +ppDocGroup lev doc = sec lev <> braces doc + where sec 1 = text "\\section" + sec 2 = text "\\subsection" + sec 3 = text "\\subsubsection" + sec _ = text "\\paragraph" + + +declNames :: LHsDecl DocName -> [DocName] +declNames (L _ decl) = case decl of + TyClD d -> [tcdName d] + SigD (TypeSig lnames _) -> map unLoc lnames + SigD (PatSynSig lname _ _ _ _) -> [unLoc lname] + ForD (ForeignImport (L _ n) _ _ _) -> [n] + ForD (ForeignExport (L _ n) _ _ _) -> [n] + _ -> error "declaration not supported by declNames" + + +forSummary :: (ExportItem DocName) -> Bool +forSummary (ExportGroup _ _ _) = False +forSummary (ExportDoc _) = False +forSummary _ = True + + +moduleLaTeXFile :: Module -> FilePath +moduleLaTeXFile mdl = moduleBasename mdl ++ ".tex" + + +moduleBasename :: Module -> FilePath +moduleBasename mdl = map (\c -> if c == '.' then '-' else c) + (moduleNameString (moduleName mdl)) + + +------------------------------------------------------------------------------- +-- * Decls +------------------------------------------------------------------------------- + + +ppDecl :: LHsDecl DocName + -> DocForDecl DocName + -> [DocInstance DocName] + -> [(DocName, DocForDecl DocName)] + -> [(DocName, Fixity)] + -> LaTeX + +ppDecl (L loc decl) (doc, fnArgsDoc) instances subdocs _fixities = case decl of + TyClD d@(FamDecl {}) -> ppTyFam False loc doc d unicode + TyClD d@(DataDecl {}) + -> ppDataDecl instances subdocs loc (Just doc) d unicode + TyClD d@(SynDecl {}) -> ppTySyn loc (doc, fnArgsDoc) d unicode +-- Family instances happen via FamInst now +-- TyClD d@(TySynonym {}) +-- | Just _ <- tcdTyPats d -> ppTyInst False loc doc d unicode +-- Family instances happen via FamInst now + TyClD d@(ClassDecl {}) -> ppClassDecl instances loc doc subdocs d unicode + SigD (TypeSig lnames (L _ t)) -> ppFunSig loc (doc, fnArgsDoc) (map unLoc lnames) t unicode + SigD (PatSynSig lname args ty prov req) -> + ppLPatSig loc (doc, fnArgsDoc) lname args ty prov req unicode + ForD d -> ppFor loc (doc, fnArgsDoc) d unicode + InstD _ -> empty + _ -> error "declaration not supported by ppDecl" + where + unicode = False + + +ppTyFam :: Bool -> SrcSpan -> Documentation DocName -> + TyClDecl DocName -> Bool -> LaTeX +ppTyFam _ _ _ _ _ = + error "type family declarations are currently not supported by --latex" + + +ppFor :: SrcSpan -> DocForDecl DocName -> ForeignDecl DocName -> Bool -> LaTeX +ppFor loc doc (ForeignImport (L _ name) (L _ typ) _ _) unicode = + ppFunSig loc doc [name] typ unicode +ppFor _ _ _ _ = error "ppFor error in Haddock.Backends.LaTeX" +-- error "foreign declarations are currently not supported by --latex" + + +------------------------------------------------------------------------------- +-- * Type Synonyms +------------------------------------------------------------------------------- + + +-- we skip type patterns for now +ppTySyn :: SrcSpan -> DocForDecl DocName -> TyClDecl DocName -> Bool -> LaTeX + +ppTySyn loc doc (SynDecl { tcdLName = L _ name, tcdTyVars = ltyvars + , tcdRhs = ltype }) unicode + = ppTypeOrFunSig loc [name] (unLoc ltype) doc (full, hdr, char '=') unicode + where + hdr = hsep (keyword "type" : ppDocBinder name : ppTyVars ltyvars) + full = hdr <+> char '=' <+> ppLType unicode ltype + +ppTySyn _ _ _ _ = error "declaration not supported by ppTySyn" + + +------------------------------------------------------------------------------- +-- * Function signatures +------------------------------------------------------------------------------- + + +ppFunSig :: SrcSpan -> DocForDecl DocName -> [DocName] -> HsType DocName + -> Bool -> LaTeX +ppFunSig loc doc docnames typ unicode = + ppTypeOrFunSig loc docnames typ doc + ( ppTypeSig names typ False + , hsep . punctuate comma $ map ppSymName names + , dcolon unicode) + unicode + where + names = map getName docnames + +ppLPatSig :: SrcSpan -> DocForDecl DocName -> Located DocName + -> HsPatSynDetails (LHsType DocName) -> LHsType 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 + -> Bool -> LaTeX +ppPatSig _loc (doc, _argDocs) docname args typ prov req unicode = declWithDoc pref1 (documentationToLaTeX doc) + where + pref1 = hsep [ keyword "pattern" + , pp_ctx prov + , pp_head + , dcolon unicode + , pp_ctx req + , ppType unicode typ + ] + + 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] + + pp_type = ppParendType unicode + pp_ctx ctx = ppContext ctx unicode + +ppTypeOrFunSig :: SrcSpan -> [DocName] -> HsType DocName + -> DocForDecl DocName -> (LaTeX, LaTeX, LaTeX) + -> Bool -> LaTeX +ppTypeOrFunSig _ _ typ (doc, argDocs) (pref1, pref2, sep0) + unicode + | Map.null argDocs = + declWithDoc pref1 (documentationToLaTeX doc) + | otherwise = + declWithDoc pref2 $ Just $ + text "\\haddockbeginargs" $$ + do_args 0 sep0 typ $$ + text "\\end{tabulary}\\par" $$ + fromMaybe empty (documentationToLaTeX doc) + where + do_largs n leader (L _ t) = do_args n leader t + + arg_doc n = rDoc (Map.lookup n argDocs) + + do_args :: Int -> LaTeX -> (HsType DocName) -> LaTeX + 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) + | not (null (unLoc lctxt)) + = decltt leader <-> decltt (ppLContextNoArrow lctxt unicode) <+> nl $$ + do_largs n (darrow unicode) ltype + -- if we're not showing any 'forall' or class constraints or + -- anything, skip having an empty line for the context. + | otherwise + = do_largs n leader ltype + do_args n leader (HsFunTy lt r) + = decltt leader <-> decltt (ppLFunLhType unicode lt) <-> arg_doc n <+> nl $$ + do_largs (n+1) (arrow unicode) r + do_args n leader t + = decltt leader <-> decltt (ppType unicode t) <-> arg_doc n <+> nl + + +ppTypeSig :: [Name] -> HsType DocName -> Bool -> LaTeX +ppTypeSig nms ty unicode = + hsep (punctuate comma $ map ppSymName nms) + <+> dcolon unicode + <+> ppType unicode ty + + +ppTyVars :: LHsTyVarBndrs DocName -> [LaTeX] +ppTyVars tvs = map ppSymName (tyvarNames tvs) + + +tyvarNames :: LHsTyVarBndrs DocName -> [Name] +tyvarNames = map getName . hsLTyVarNames + + +declWithDoc :: LaTeX -> Maybe LaTeX -> LaTeX +declWithDoc decl doc = + text "\\begin{haddockdesc}" $$ + text "\\item[\\begin{tabular}{@{}l}" $$ + text (latexMonoFilter (show decl)) $$ + text "\\end{tabular}]" <> + (if isNothing doc then empty else text "\\haddockbegindoc") $$ + maybe empty id doc $$ + text "\\end{haddockdesc}" + + +-- in a group of decls, we don't put them all in the same tabular, +-- because that would prevent the group being broken over a page +-- boundary (breaks Foreign.C.Error for example). +multiDecl :: [LaTeX] -> LaTeX +multiDecl decls = + text "\\begin{haddockdesc}" $$ + vcat [ + text "\\item[" $$ + text (latexMonoFilter (show decl)) $$ + text "]" + | decl <- decls ] $$ + text "\\end{haddockdesc}" + + +------------------------------------------------------------------------------- +-- * Rendering Doc +------------------------------------------------------------------------------- + + +maybeDoc :: Maybe (Doc DocName) -> LaTeX +maybeDoc = maybe empty docToLaTeX + + +-- for table cells, we strip paragraphs out to avoid extra vertical space +-- and don't add a quote environment. +rDoc :: Maybe (Doc DocName) -> LaTeX +rDoc = maybeDoc . fmap latexStripTrailingWhitespace + + +------------------------------------------------------------------------------- +-- * Class declarations +------------------------------------------------------------------------------- + + +ppClassHdr :: Bool -> Located [LHsType DocName] -> DocName + -> LHsTyVarBndrs DocName -> [Located ([DocName], [DocName])] + -> Bool -> LaTeX +ppClassHdr summ lctxt n tvs fds unicode = + keyword "class" + <+> (if not . null . unLoc $ lctxt then ppLContext lctxt unicode else empty) + <+> ppAppDocNameNames summ n (tyvarNames $ tvs) + <+> ppFds fds unicode + + +ppFds :: [Located ([DocName], [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) + + +ppClassDecl :: [DocInstance DocName] -> SrcSpan + -> Documentation DocName -> [(DocName, DocForDecl DocName)] + -> TyClDecl DocName -> Bool -> LaTeX +ppClassDecl instances loc doc subdocs + (ClassDecl { tcdCtxt = lctxt, tcdLName = lname, tcdTyVars = ltyvars, tcdFDs = lfds + , tcdSigs = lsigs, tcdATs = ats, tcdATDefs = at_defs }) unicode + = declWithDoc classheader (if null body then Nothing else Just (vcat body)) $$ + instancesBit + where + classheader + | null lsigs = hdr unicode + | otherwise = hdr unicode <+> keyword "where" + + hdr = ppClassHdr False lctxt (unLoc lname) ltyvars lfds + + body = catMaybes [documentationToLaTeX doc, body_] + + body_ + | null lsigs, null ats, null at_defs = Nothing + | null ats, null at_defs = Just methodTable +--- | otherwise = atTable $$ methodTable + | otherwise = error "LaTeX.ppClassDecl" + + methodTable = + text "\\haddockpremethods{}\\textbf{Methods}" $$ + vcat [ ppFunSig loc doc names typ unicode + | L _ (TypeSig lnames (L _ typ)) <- lsigs + , let doc = lookupAnySubdoc (head names) subdocs + names = map unLoc lnames ] + -- FIXME: is taking just the first name ok? Is it possible that + -- there are different subdocs for different names in a single + -- type signature? + + instancesBit = ppDocInstances unicode instances + +ppClassDecl _ _ _ _ _ _ = error "declaration type not supported by ppShortClassDecl" + +ppDocInstances :: Bool -> [DocInstance DocName] -> LaTeX +ppDocInstances _unicode [] = empty +ppDocInstances unicode (i : rest) + | Just ihead <- isUndocdInstance i + = declWithDoc (vcat (map (ppInstDecl unicode) (ihead:is))) Nothing $$ + ppDocInstances unicode rest' + | otherwise + = ppDocInstance unicode i $$ ppDocInstances unicode rest + where + (is, rest') = spanWith isUndocdInstance rest + +isUndocdInstance :: DocInstance a -> Maybe (InstHead a) +isUndocdInstance (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) + + +ppInstDecl :: Bool -> InstHead DocName -> LaTeX +ppInstDecl unicode instHead = keyword "instance" <+> ppInstHead unicode instHead + + +ppInstHead :: Bool -> InstHead DocName -> LaTeX +ppInstHead unicode (n, ks, ts, ClassInst ctx) = ppContextNoLocs ctx unicode <+> ppAppNameTypes n ks ts unicode +ppInstHead unicode (n, ks, ts, TypeInst rhs) = keyword "type" + <+> ppAppNameTypes n ks ts unicode + <+> maybe empty (\t -> equals <+> ppType unicode t) rhs +ppInstHead _unicode (_n, _ks, _ts, DataInst _dd) = + error "data instances not supported by --latex yet" + +lookupAnySubdoc :: (Eq name1) => + name1 -> [(name1, DocForDecl name2)] -> DocForDecl name2 +lookupAnySubdoc n subdocs = case lookup n subdocs of + Nothing -> noDocForDecl + Just docs -> docs + + +------------------------------------------------------------------------------- +-- * Data & newtype declarations +------------------------------------------------------------------------------- + + +ppDataDecl :: [DocInstance DocName] -> + [(DocName, DocForDecl DocName)] -> SrcSpan -> + Maybe (Documentation DocName) -> TyClDecl DocName -> Bool -> + LaTeX +ppDataDecl instances subdocs _loc doc dataDecl unicode + + = declWithDoc (ppDataHeader dataDecl unicode <+> whereBit) + (if null body then Nothing else Just (vcat body)) + $$ instancesBit + + where + cons = dd_cons (tcdDataDefn dataDecl) + resTy = (con_res . unLoc . head) cons + + body = catMaybes [constrBit, doc >>= documentationToLaTeX] + + (whereBit, leaders) + | null cons = (empty,[]) + | otherwise = case resTy of + ResTyGADT _ -> (decltt (keyword "where"), repeat empty) + _ -> (empty, (decltt (text "=") : repeat (decltt (text "|")))) + + constrBit + | null cons = Nothing + | otherwise = Just $ + text "\\haddockbeginconstrs" $$ + vcat (zipWith (ppSideBySideConstr subdocs unicode) leaders cons) $$ + text "\\end{tabulary}\\par" + + instancesBit = ppDocInstances unicode instances + + +-- ppConstrHdr is for (non-GADT) existentials constructors' syntax +ppConstrHdr :: HsExplicitFlag -> [Name] -> HsContext DocName -> Bool -> LaTeX +ppConstrHdr forall tvs ctxt unicode + = (if null tvs then empty else ppForall) + <+> + (if null ctxt then empty else ppContextNoArrow ctxt unicode <+> darrow unicode <+> text " ") + where + ppForall = case forall of + Explicit -> forallSymbol unicode <+> hsep (map ppName tvs) <+> text ". " + Implicit -> empty + + +ppSideBySideConstr :: [(DocName, DocForDecl DocName)] -> Bool -> LaTeX + -> LConDecl DocName -> LaTeX +ppSideBySideConstr subdocs unicode leader (L _ con) = + leader <-> + case con_res con of + ResTyH98 -> case con_details con of + + PrefixCon args -> + decltt (hsep ((header_ unicode <+> ppBinder occ) : + map (ppLParendType unicode) args)) + <-> rDoc mbDoc <+> nl + + RecCon fields -> + (decltt (header_ unicode <+> ppBinder occ) + <-> rDoc mbDoc <+> nl) + $$ + doRecordFields fields + + InfixCon arg1 arg2 -> + decltt (hsep [ header_ unicode <+> ppLParendType unicode arg1, + ppBinder occ, + ppLParendType unicode arg2 ]) + <-> rDoc mbDoc <+> nl + + 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 $$ + doRecordFields fields + InfixCon arg1 arg2 -> doGADTCon [arg1, arg2] resTy + + where + doRecordFields fields = + vcat (map (ppSideBySideField subdocs unicode) fields) + + doGADTCon args resTy = decltt (ppBinder occ <+> 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 + 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 + 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) + <+> 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 + +-- {- +-- ppHsFullConstr :: HsConDecl -> LaTeX +-- ppHsFullConstr (HsConDecl _ nm tvs ctxt typeList doc) = +-- declWithDoc False doc ( +-- hsep ((ppHsConstrHdr tvs ctxt +++ +-- ppHsBinder False nm) : map ppHsBangType typeList) +-- ) +-- ppHsFullConstr (HsRecDecl _ nm tvs ctxt fields doc) = +-- td << vanillaTable << ( +-- case doc of +-- Nothing -> aboves [hdr, fields_html] +-- Just _ -> aboves [hdr, constr_doc, fields_html] +-- ) +-- +-- where hdr = declBox (ppHsConstrHdr tvs ctxt +++ ppHsBinder False nm) +-- +-- constr_doc +-- | isJust doc = docBox (docToLaTeX (fromJust doc)) +-- | otherwise = LaTeX.emptyTable +-- +-- fields_html = +-- td << +-- table ! [width "100%", cellpadding 0, cellspacing 8] << ( +-- aboves (map ppFullField (concat (map expandField fields))) +-- ) +-- -} +-- +-- ppShortField :: Bool -> Bool -> ConDeclField DocName -> LaTeX +-- ppShortField summary unicode (ConDeclField (L _ name) ltype _) +-- = tda [theclass "recfield"] << ( +-- ppBinder summary (docNameOcc name) +-- <+> dcolon unicode <+> ppLType unicode ltype +-- ) +-- +-- {- +-- ppFullField :: HsFieldDecl -> LaTeX +-- ppFullField (HsFieldDecl [n] ty doc) +-- = declWithDoc False doc ( +-- ppHsBinder False n <+> dcolon <+> ppHsBangType ty +-- ) +-- ppFullField _ = error "ppFullField" +-- +-- expandField :: HsFieldDecl -> [HsFieldDecl] +-- expandField (HsFieldDecl ns ty doc) = [ HsFieldDecl [n] ty doc | n <- ns ] +-- -} + + +-- | Print the LHS of a data\/newtype declaration. +-- Currently doesn't handle 'data instance' decls or kind signatures +ppDataHeader :: TyClDecl DocName -> Bool -> LaTeX +ppDataHeader (DataDecl { tcdLName = L _ name, tcdTyVars = tyvars + , tcdDataDefn = HsDataDefn { dd_ND = nd, dd_ctxt = ctxt } }) unicode + = -- newtype or data + (case nd of { NewType -> keyword "newtype"; DataType -> keyword "data" }) <+> + -- context + ppLContext ctxt unicode <+> + -- T a b c ..., or a :+: b + ppAppDocNameNames False name (tyvarNames tyvars) +ppDataHeader _ _ = error "ppDataHeader: illegal argument" + +-------------------------------------------------------------------------------- +-- * Type applications +-------------------------------------------------------------------------------- + + +-- | Print an application of a DocName and two lists of HsTypes (kinds, types) +ppAppNameTypes :: DocName -> [HsType DocName] -> [HsType DocName] -> Bool -> LaTeX +ppAppNameTypes n ks ts unicode = ppTypeApp n ks ts ppDocName (ppParendType unicode) + + +-- | Print an application of a DocName and a list of Names +ppAppDocNameNames :: Bool -> DocName -> [Name] -> LaTeX +ppAppDocNameNames _summ n ns = + ppTypeApp n [] ns (ppBinder . nameOccName . getName) ppSymName + + +-- | General printing of type applications +ppTypeApp :: DocName -> [a] -> [a] -> (DocName -> LaTeX) -> (a -> LaTeX) -> LaTeX +ppTypeApp n [] (t1:t2:rest) ppDN ppT + | operator, not . null $ rest = parens opApp <+> hsep (map ppT rest) + | operator = opApp + where + operator = isNameSym . getName $ n + opApp = ppT t1 <+> ppDN n <+> ppT t2 + +ppTypeApp n ks ts ppDN ppT = ppDN n <+> hsep (map ppT $ ks ++ ts) + + +------------------------------------------------------------------------------- +-- * Contexts +------------------------------------------------------------------------------- + + +ppLContext, ppLContextNoArrow :: Located (HsContext DocName) -> Bool -> LaTeX +ppLContext = ppContext . unLoc +ppLContextNoArrow = ppContextNoArrow . unLoc + + +ppContextNoArrow :: HsContext DocName -> Bool -> LaTeX +ppContextNoArrow [] _ = empty +ppContextNoArrow cxt unicode = pp_hs_context (map unLoc cxt) unicode + + +ppContextNoLocs :: [HsType DocName] -> Bool -> LaTeX +ppContextNoLocs [] _ = empty +ppContextNoLocs cxt unicode = pp_hs_context cxt unicode <+> darrow unicode + + +ppContext :: HsContext DocName -> Bool -> LaTeX +ppContext cxt unicode = ppContextNoLocs (map unLoc cxt) unicode + + +pp_hs_context :: [HsType DocName] -> Bool -> LaTeX +pp_hs_context [] _ = empty +pp_hs_context [p] unicode = ppType unicode p +pp_hs_context cxt unicode = parenList (map (ppType unicode) cxt) + + +------------------------------------------------------------------------------- +-- * Types and contexts +------------------------------------------------------------------------------- + + +ppBang :: HsBang -> LaTeX +ppBang HsNoBang = empty +ppBang _ = char '!' -- Unpacked args is an implementation detail, + + +tupleParens :: HsTupleSort -> [LaTeX] -> LaTeX +tupleParens HsUnboxedTuple = ubxParenList +tupleParens _ = parenList + + +------------------------------------------------------------------------------- +-- * Rendering of HsType +-- +-- Stolen from Html and tweaked for LaTeX generation +------------------------------------------------------------------------------- + + +pREC_TOP, pREC_FUN, pREC_OP, pREC_CON :: Int + +pREC_TOP = (0 :: Int) -- type in ParseIface.y in GHC +pREC_FUN = (1 :: Int) -- btype in ParseIface.y in GHC + -- Used for LH arg of (->) +pREC_OP = (2 :: Int) -- Used for arg of any infix operator + -- (we don't keep their fixities around) +pREC_CON = (3 :: Int) -- Used for arg of type applicn: + -- always parenthesise unless atomic + +maybeParen :: Int -- Precedence of context + -> Int -- Precedence of top-level operator + -> LaTeX -> LaTeX -- Wrap in parens if (ctxt >= op) +maybeParen ctxt_prec op_prec p | ctxt_prec >= op_prec = parens p + | otherwise = p + + +ppLType, ppLParendType, ppLFunLhType :: Bool -> Located (HsType DocName) -> LaTeX +ppLType unicode y = ppType unicode (unLoc y) +ppLParendType unicode y = ppParendType unicode (unLoc y) +ppLFunLhType unicode y = ppFunLhType unicode (unLoc y) + + +ppType, ppParendType, ppFunLhType :: Bool -> HsType DocName -> LaTeX +ppType unicode ty = ppr_mono_ty pREC_TOP ty unicode +ppParendType unicode ty = ppr_mono_ty pREC_CON ty unicode +ppFunLhType unicode ty = ppr_mono_ty pREC_FUN ty unicode + +ppLKind :: Bool -> LHsKind DocName -> LaTeX +ppLKind unicode y = ppKind unicode (unLoc y) + +ppKind :: Bool -> HsKind DocName -> LaTeX +ppKind unicode ki = ppr_mono_ty pREC_TOP ki unicode + + +-- Drop top-level for-all type variables in user style +-- since they are implicit in Haskell + +ppForAll :: HsExplicitFlag -> LHsTyVarBndrs DocName + -> Located (HsContext DocName) -> Bool -> LaTeX +ppForAll expl tvs cxt unicode + | show_forall = forall_part <+> ppLContext cxt unicode + | otherwise = ppLContext cxt unicode + where + show_forall = not (null (hsQTvBndrs tvs)) && is_explicit + is_explicit = case expl of {Explicit -> True; Implicit -> False} + forall_part = hsep (forallSymbol unicode : ppTyVars tvs) <> dot + + +ppr_mono_lty :: Int -> LHsType DocName -> Bool -> 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 + = maybeParen ctxt_prec pREC_FUN $ + hsep [ppForAll expl tvs ctxt unicode, ppr_mono_lty pREC_TOP ty unicode] + +ppr_mono_ty _ (HsBangTy b ty) u = ppBang b <> ppLParendType u ty +ppr_mono_ty _ (HsTyVar name) _ = ppDocName name +ppr_mono_ty ctxt_prec (HsFunTy ty1 ty2) u = ppr_fun_ty ctxt_prec ty1 ty2 u +ppr_mono_ty _ (HsTupleTy con tys) u = tupleParens con (map (ppLType u) tys) +ppr_mono_ty _ (HsKindSig ty kind) u = parens (ppr_mono_lty pREC_TOP ty u <+> dcolon u <+> ppLKind u kind) +ppr_mono_ty _ (HsListTy ty) u = brackets (ppr_mono_lty pREC_TOP ty u) +ppr_mono_ty _ (HsPArrTy ty) u = pabrackets (ppr_mono_lty pREC_TOP ty u) +ppr_mono_ty _ (HsIParamTy n ty) u = brackets (ppIPName n <+> dcolon u <+> ppr_mono_lty pREC_TOP ty u) +ppr_mono_ty _ (HsSpliceTy {}) _ = error "ppr_mono_ty HsSpliceTy" +ppr_mono_ty _ (HsQuasiQuoteTy {}) _ = error "ppr_mono_ty HsQuasiQuoteTy" +ppr_mono_ty _ (HsRecTy {}) _ = error "ppr_mono_ty HsRecTy" +ppr_mono_ty _ (HsCoreTy {}) _ = error "ppr_mono_ty HsCoreTy" +ppr_mono_ty _ (HsExplicitListTy _ tys) u = Pretty.quote $ brackets $ hsep $ punctuate comma $ map (ppLType u) tys +ppr_mono_ty _ (HsExplicitTupleTy _ tys) u = Pretty.quote $ parenList $ map (ppLType u) tys +ppr_mono_ty _ (HsWrapTy {}) _ = error "ppr_mono_ty HsWrapTy" + +ppr_mono_ty ctxt_prec (HsEqTy ty1 ty2) unicode + = maybeParen ctxt_prec pREC_OP $ + ppr_mono_lty pREC_OP ty1 unicode <+> char '~' <+> ppr_mono_lty pREC_OP ty2 unicode + +ppr_mono_ty ctxt_prec (HsAppTy fun_ty arg_ty) unicode + = maybeParen ctxt_prec pREC_CON $ + hsep [ppr_mono_lty pREC_FUN fun_ty unicode, ppr_mono_lty pREC_CON arg_ty unicode] + +ppr_mono_ty ctxt_prec (HsOpTy ty1 (_, op) ty2) unicode + = maybeParen ctxt_prec pREC_FUN $ + ppr_mono_lty pREC_OP ty1 unicode <+> ppr_op <+> ppr_mono_lty pREC_OP ty2 unicode + where + ppr_op = if not (isSymOcc occName) then char '`' <> ppLDocName op <> char '`' else ppLDocName op + occName = nameOccName . getName . unLoc $ op + +ppr_mono_ty ctxt_prec (HsParTy ty) unicode +-- = parens (ppr_mono_lty pREC_TOP ty) + = ppr_mono_lty ctxt_prec ty unicode + +ppr_mono_ty ctxt_prec (HsDocTy ty _) unicode + = ppr_mono_lty ctxt_prec ty unicode + +ppr_mono_ty _ (HsTyLit t) u = ppr_tylit t u + + +ppr_tylit :: HsTyLit -> Bool -> LaTeX +ppr_tylit (HsNumTy n) _ = integer n +ppr_tylit (HsStrTy s) _ = text (show s) + -- XXX: Ok in verbatim, but not otherwise + -- XXX: Do something with Unicode parameter? + + +ppr_fun_ty :: Int -> LHsType DocName -> LHsType DocName -> Bool -> LaTeX +ppr_fun_ty ctxt_prec ty1 ty2 unicode + = let p1 = ppr_mono_lty pREC_FUN ty1 unicode + p2 = ppr_mono_lty pREC_TOP ty2 unicode + in + maybeParen ctxt_prec pREC_FUN $ + sep [p1, arrow unicode <+> p2] + + +------------------------------------------------------------------------------- +-- * Names +------------------------------------------------------------------------------- + + +ppBinder :: OccName -> LaTeX +ppBinder n + | 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 + +ppSymName :: Name -> LaTeX +ppSymName name + | isNameSym name = parens $ ppName name + | otherwise = ppName name + + +ppVerbOccName :: OccName -> LaTeX +ppVerbOccName = text . latexFilter . occNameString + +ppIPName :: HsIPName -> LaTeX +ppIPName ip = text $ unpackFS $ hsIPNameFS ip + +ppOccName :: OccName -> LaTeX +ppOccName = text . occNameString + + +ppVerbDocName :: DocName -> LaTeX +ppVerbDocName = ppVerbOccName . nameOccName . getName + + +ppVerbRdrName :: RdrName -> LaTeX +ppVerbRdrName = ppVerbOccName . rdrNameOcc + + +ppDocName :: DocName -> LaTeX +ppDocName = ppOccName . nameOccName . getName + + +ppLDocName :: Located DocName -> LaTeX +ppLDocName (L _ d) = ppDocName d + + +ppDocBinder :: DocName -> LaTeX +ppDocBinder = ppBinder . nameOccName . getName + +ppDocBinderInfix :: DocName -> LaTeX +ppDocBinderInfix = ppBinderInfix . nameOccName . getName + + +ppName :: Name -> LaTeX +ppName = ppOccName . nameOccName + + +latexFilter :: String -> String +latexFilter = foldr latexMunge "" + + +latexMonoFilter :: String -> String +latexMonoFilter = foldr latexMonoMunge "" + + +latexMunge :: Char -> String -> String +latexMunge '#' s = "{\\char '43}" ++ s +latexMunge '$' s = "{\\char '44}" ++ s +latexMunge '%' s = "{\\char '45}" ++ s +latexMunge '&' s = "{\\char '46}" ++ s +latexMunge '~' s = "{\\char '176}" ++ s +latexMunge '_' s = "{\\char '137}" ++ s +latexMunge '^' s = "{\\char '136}" ++ s +latexMunge '\\' s = "{\\char '134}" ++ s +latexMunge '{' s = "{\\char '173}" ++ s +latexMunge '}' s = "{\\char '175}" ++ s +latexMunge '[' s = "{\\char 91}" ++ s +latexMunge ']' s = "{\\char 93}" ++ s +latexMunge c s = c : s + + +latexMonoMunge :: Char -> String -> String +latexMonoMunge ' ' s = '\\' : ' ' : s +latexMonoMunge '\n' s = '\\' : '\\' : s +latexMonoMunge c s = latexMunge c s + + +------------------------------------------------------------------------------- +-- * Doc Markup +------------------------------------------------------------------------------- + + +parLatexMarkup :: (a -> LaTeX) -> DocMarkup a (StringContext -> LaTeX) +parLatexMarkup ppId = Markup { + markupParagraph = \p v -> p v <> text "\\par" $$ text "", + markupEmpty = \_ -> empty, + markupString = \s v -> text (fixString v s), + markupAppend = \l r v -> l v <> r v, + markupIdentifier = markupId ppId, + markupIdentifierUnchecked = markupId (ppVerbOccName . snd), + markupModule = \m _ -> let (mdl,_ref) = break (=='#') m in tt (text mdl), + markupWarning = \p v -> emph (p v), + markupEmphasis = \p v -> emph (p v), + markupBold = \p v -> bold (p v), + markupMonospaced = \p _ -> tt (p Mono), + markupUnorderedList = \p v -> itemizedList (map ($v) p) $$ text "", + markupPic = \p _ -> markupPic p, + markupOrderedList = \p v -> enumeratedList (map ($v) p) $$ text "", + markupDefList = \l v -> descriptionList (map (\(a,b) -> (a v, b v)) l), + markupCodeBlock = \p _ -> quote (verb (p Verb)) $$ text "", + markupHyperlink = \l _ -> markupLink l, + markupAName = \_ _ -> empty, + markupProperty = \p _ -> quote $ verb $ text p, + markupExample = \e _ -> quote $ verb $ text $ unlines $ map exampleToString e, + markupHeader = \(Header l h) p -> header l (h p) + } + where + header 1 d = text "\\section*" <> braces d + header 2 d = text "\\subsection*" <> braces d + header l d + | l > 0 && l <= 6 = text "\\subsubsection*" <> braces d + header l _ = error $ "impossible header level in LaTeX generation: " ++ show l + + fixString Plain s = latexFilter s + fixString Verb s = s + fixString Mono s = latexMonoFilter s + + markupLink (Hyperlink url mLabel) = case mLabel of + Just label -> text "\\href" <> braces (text url) <> braces (text label) + Nothing -> text "\\url" <> braces (text url) + + -- Is there a better way of doing this? Just a space is an aribtrary choice. + markupPic (Picture uri title) = parens (imageText title) + where + imageText Nothing = beg + imageText (Just t) = beg <> text " " <> text t + + beg = text "image: " <> text uri + + markupId ppId_ id v = + case v of + Verb -> theid + Mono -> theid + Plain -> text "\\haddockid" <> braces theid + where theid = ppId_ id + + +latexMarkup :: DocMarkup DocName (StringContext -> LaTeX) +latexMarkup = parLatexMarkup ppVerbDocName + + +rdrLatexMarkup :: DocMarkup RdrName (StringContext -> LaTeX) +rdrLatexMarkup = parLatexMarkup ppVerbRdrName + + +docToLaTeX :: Doc DocName -> LaTeX +docToLaTeX doc = markup latexMarkup doc Plain + + +documentationToLaTeX :: Documentation DocName -> Maybe LaTeX +documentationToLaTeX = fmap docToLaTeX . combineDocumentation + + +rdrDocToLaTeX :: Doc RdrName -> LaTeX +rdrDocToLaTeX doc = markup rdrLatexMarkup doc Plain + + +data StringContext = Plain | Verb | Mono + + +latexStripTrailingWhitespace :: Doc a -> Doc a +latexStripTrailingWhitespace (DocString s) + | null s' = DocEmpty + | otherwise = DocString s + where s' = reverse (dropWhile isSpace (reverse s)) +latexStripTrailingWhitespace (DocAppend l r) + | DocEmpty <- r' = latexStripTrailingWhitespace l + | otherwise = DocAppend l r' + where + r' = latexStripTrailingWhitespace r +latexStripTrailingWhitespace (DocParagraph p) = + latexStripTrailingWhitespace p +latexStripTrailingWhitespace other = other + + +------------------------------------------------------------------------------- +-- * LaTeX utils +------------------------------------------------------------------------------- + + +itemizedList :: [LaTeX] -> LaTeX +itemizedList items = + text "\\begin{itemize}" $$ + vcat (map (text "\\item" $$) items) $$ + text "\\end{itemize}" + + +enumeratedList :: [LaTeX] -> LaTeX +enumeratedList items = + text "\\begin{enumerate}" $$ + vcat (map (text "\\item " $$) items) $$ + text "\\end{enumerate}" + + +descriptionList :: [(LaTeX,LaTeX)] -> LaTeX +descriptionList items = + text "\\begin{description}" $$ + vcat (map (\(a,b) -> text "\\item" <> brackets a <+> b) items) $$ + text "\\end{description}" + + +tt :: LaTeX -> LaTeX +tt ltx = text "\\haddocktt" <> braces ltx + + +decltt :: LaTeX -> LaTeX +decltt ltx = text "\\haddockdecltt" <> braces ltx + + +emph :: LaTeX -> LaTeX +emph ltx = text "\\emph" <> braces ltx + +bold :: LaTeX -> LaTeX +bold ltx = text "\\textbf" <> braces ltx + +verb :: LaTeX -> LaTeX +verb doc = text "{\\haddockverb\\begin{verbatim}" $$ doc <> text "\\end{verbatim}}" + -- NB. swallow a trailing \n in the verbatim text by appending the + -- \end{verbatim} directly, otherwise we get spurious blank lines at the + -- end of code blocks. + + +quote :: LaTeX -> LaTeX +quote doc = text "\\begin{quote}" $$ doc $$ text "\\end{quote}" + + +dcolon, arrow, darrow, forallSymbol :: Bool -> LaTeX +dcolon unicode = text (if unicode then "∷" else "::") +arrow unicode = text (if unicode then "→" else "->") +darrow unicode = text (if unicode then "⇒" else "=>") +forallSymbol unicode = text (if unicode then "∀" else "forall") + + +dot :: LaTeX +dot = char '.' + + +parenList :: [LaTeX] -> LaTeX +parenList = parens . hsep . punctuate comma + + +ubxParenList :: [LaTeX] -> LaTeX +ubxParenList = ubxparens . hsep . punctuate comma + + +ubxparens :: LaTeX -> LaTeX +ubxparens h = text "(#" <> h <> text "#)" + + +pabrackets :: LaTeX -> LaTeX +pabrackets h = text "[:" <> h <> text ":]" + + +nl :: LaTeX +nl = text "\\\\" + + +keyword :: String -> LaTeX +keyword = text + + +infixr 4 <-> -- combining table cells +(<->) :: LaTeX -> LaTeX -> LaTeX +a <-> b = a <+> char '&' <+> b diff --git a/haddock-api/src/Haddock/Backends/Xhtml.hs b/haddock-api/src/Haddock/Backends/Xhtml.hs new file mode 100644 index 00000000..9628a33d --- /dev/null +++ b/haddock-api/src/Haddock/Backends/Xhtml.hs @@ -0,0 +1,690 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Haddock.Backends.Html +-- Copyright : (c) Simon Marlow 2003-2006, +-- David Waern 2006-2009, +-- Mark Lentczner 2010, +-- Mateusz Kowalczyk 2013 +-- License : BSD-like +-- +-- Maintainer : haddock@projects.haskell.org +-- Stability : experimental +-- Portability : portable +----------------------------------------------------------------------------- +{-# LANGUAGE CPP #-} +module Haddock.Backends.Xhtml ( + ppHtml, copyHtmlBits, + ppHtmlIndex, ppHtmlContents, +) where + + +import Prelude hiding (div) + +import Haddock.Backends.Xhtml.Decl +import Haddock.Backends.Xhtml.DocMarkup +import Haddock.Backends.Xhtml.Layout +import Haddock.Backends.Xhtml.Names +import Haddock.Backends.Xhtml.Themes +import Haddock.Backends.Xhtml.Types +import Haddock.Backends.Xhtml.Utils +import Haddock.ModuleTree +import Haddock.Types +import Haddock.Version +import Haddock.Utils +import Text.XHtml hiding ( name, title, p, quote ) +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 ) +import Data.Maybe +import System.FilePath hiding ( (</>) ) +import System.Directory +import Data.Map ( Map ) +import qualified Data.Map as Map hiding ( Map ) +import qualified Data.Set as Set hiding ( Set ) +import Data.Function +import Data.Ord ( comparing ) + +import DynFlags (Language(..)) +import GHC hiding ( NoLink, moduleInfo ) +import Name +import Module + +-------------------------------------------------------------------------------- +-- * Generating HTML documentation +-------------------------------------------------------------------------------- + + +ppHtml :: String + -> Maybe String -- ^ Package + -> [Interface] + -> FilePath -- ^ Destination directory + -> Maybe (Doc GHC.RdrName) -- ^ Prologue text, maybe + -> Themes -- ^ Themes + -> SourceURLs -- ^ The source URL (--source) + -> WikiURLs -- ^ The wiki URL (--wiki) + -> Maybe String -- ^ The contents URL (--use-contents) + -> Maybe String -- ^ The index URL (--use-index) + -> Bool -- ^ Whether to use unicode in output (--use-unicode) + -> QualOption -- ^ How to qualify names + -> Bool -- ^ Output pretty html (newlines and indenting) + -> IO () + +ppHtml doctitle maybe_package ifaces odir prologue + themes maybe_source_url maybe_wiki_url + maybe_contents_url maybe_index_url unicode + qual debug = do + let + visible_ifaces = filter visible ifaces + visible i = OptHide `notElem` ifaceOptions i + + when (isNothing maybe_contents_url) $ + ppHtmlContents 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 + prologue debug (makeContentsQual qual) + + when (isNothing maybe_index_url) $ + ppHtmlIndex odir doctitle maybe_package + themes maybe_contents_url maybe_source_url maybe_wiki_url + (map toInstalledIface visible_ifaces) debug + + mapM_ (ppHtmlModule odir doctitle themes + maybe_source_url maybe_wiki_url + maybe_contents_url maybe_index_url unicode qual debug) visible_ifaces + + +copyHtmlBits :: FilePath -> FilePath -> Themes -> IO () +copyHtmlBits odir libdir themes = do + let + libhtmldir = joinPath [libdir, "html"] + copyCssFile f = copyFile f (combine odir (takeFileName f)) + copyLibFile f = copyFile (joinPath [libhtmldir, f]) (joinPath [odir, f]) + mapM_ copyCssFile (cssFiles themes) + mapM_ copyLibFile [ jsFile, framesFile ] + + +headHtml :: String -> Maybe String -> Themes -> Html +headHtml docTitle miniPage themes = + header << [ + meta ! [httpequiv "Content-Type", content "text/html; charset=UTF-8"], + thetitle << docTitle, + styleSheet themes, + script ! [src jsFile, thetype "text/javascript"] << noHtml, + script ! [thetype "text/javascript"] + -- NB: Within XHTML, the content of script tags needs to be + -- a <![CDATA[ section. Will break if the miniPage name could + -- have "]]>" in it! + << primHtml ( + "//<![CDATA[\nwindow.onload = function () {pageLoad();" + ++ setSynopsis ++ "};\n//]]>\n") + ] + where + setSynopsis = maybe "" (\p -> "setSynopsis(\"" ++ p ++ "\");") miniPage + + +srcButton :: SourceURLs -> Maybe Interface -> Maybe Html +srcButton (Just src_base_url, _, _, _) Nothing = + Just (anchor ! [href src_base_url] << "Source") +srcButton (_, Just src_module_url, _, _) (Just iface) = + let url = spliceURL (Just $ ifaceOrigFilename iface) + (Just $ ifaceMod iface) Nothing Nothing src_module_url + in Just (anchor ! [href url] << "Source") +srcButton _ _ = + Nothing + + +wikiButton :: WikiURLs -> Maybe Module -> Maybe Html +wikiButton (Just wiki_base_url, _, _) Nothing = + Just (anchor ! [href wiki_base_url] << "User Comments") + +wikiButton (_, Just wiki_module_url, _) (Just mdl) = + let url = spliceURL Nothing (Just mdl) Nothing Nothing wiki_module_url + in Just (anchor ! [href url] << "User Comments") + +wikiButton _ _ = + Nothing + + +contentsButton :: Maybe String -> Maybe Html +contentsButton maybe_contents_url + = Just (anchor ! [href url] << "Contents") + where url = fromMaybe contentsHtmlFile maybe_contents_url + + +indexButton :: Maybe String -> Maybe Html +indexButton maybe_index_url + = Just (anchor ! [href url] << "Index") + where url = fromMaybe indexHtmlFile maybe_index_url + + +bodyHtml :: String -> Maybe Interface + -> SourceURLs -> WikiURLs + -> Maybe String -> Maybe String + -> Html -> Html +bodyHtml doctitle iface + maybe_source_url maybe_wiki_url + maybe_contents_url maybe_index_url + pageContent = + body << [ + divPackageHeader << [ + unordList (catMaybes [ + srcButton maybe_source_url iface, + wikiButton maybe_wiki_url (ifaceMod <$> iface), + contentsButton maybe_contents_url, + indexButton maybe_index_url]) + ! [theclass "links", identifier "page-menu"], + nonEmptySectionName << doctitle + ], + divContent << pageContent, + divFooter << paragraph << ( + "Produced by " +++ + (anchor ! [href projectUrl] << toHtml projectName) +++ + (" version " ++ projectVersion) + ) + ] + + +moduleInfo :: Interface -> Html +moduleInfo iface = + let + info = ifaceInfo iface + + doOneEntry :: (String, HaddockModInfo GHC.Name -> Maybe String) -> Maybe HtmlTable + doOneEntry (fieldName, field) = + field info >>= \a -> return (th << fieldName <-> td << a) + + entries :: [HtmlTable] + entries = mapMaybe doOneEntry [ + ("Copyright",hmi_copyright), + ("License",hmi_license), + ("Maintainer",hmi_maintainer), + ("Stability",hmi_stability), + ("Portability",hmi_portability), + ("Safe Haskell",hmi_safety), + ("Language", lg) + ] ++ extsForm + where + lg inf = case hmi_language inf of + Nothing -> Nothing + Just Haskell98 -> Just "Haskell98" + Just Haskell2010 -> Just "Haskell2010" + + extsForm + | OptShowExtensions `elem` ifaceOptions iface = + let fs = map (dropOpt . show) (hmi_extensions info) + in case map stringToHtml fs of + [] -> [] + [x] -> extField x -- don't use a list for a single extension + xs -> extField $ unordList xs ! [theclass "extension-list"] + | otherwise = [] + where + extField x = return $ th << "Extensions" <-> td << x + dropOpt x = if "Opt_" `isPrefixOf` x then drop 4 x else x + in + case entries of + [] -> noHtml + _ -> table ! [theclass "info"] << aboves entries + + +-------------------------------------------------------------------------------- +-- * Generate the module contents +-------------------------------------------------------------------------------- + + +ppHtmlContents + :: FilePath + -> String + -> Maybe String + -> Themes + -> Maybe String + -> SourceURLs + -> WikiURLs + -> [InstalledInterface] -> Bool -> Maybe (Doc GHC.RdrName) + -> Bool + -> Qualification -- ^ How to qualify names + -> IO () +ppHtmlContents odir doctitle _maybe_package + themes maybe_index_url + maybe_source_url maybe_wiki_url ifaces showPkgs prologue debug qual = do + let tree = mkModuleTree showPkgs + [(instMod iface, toInstalledDescription iface) | iface <- ifaces] + html = + headHtml doctitle Nothing themes +++ + bodyHtml doctitle Nothing + maybe_source_url maybe_wiki_url + Nothing maybe_index_url << [ + ppPrologue qual doctitle prologue, + ppModuleTree qual tree + ] + createDirectoryIfMissing True odir + writeFile (joinPath [odir, contentsHtmlFile]) (renderToString debug html) + + -- XXX: think of a better place for this? + ppHtmlContentsFrame odir doctitle themes ifaces debug + + +ppPrologue :: Qualification -> String -> Maybe (Doc GHC.RdrName) -> Html +ppPrologue _ _ Nothing = noHtml +ppPrologue qual title (Just doc) = + divDescription << (h1 << title +++ docElement thediv (rdrDocToHtml qual doc)) + + +ppModuleTree :: Qualification -> [ModuleTree] -> Html +ppModuleTree qual ts = + divModuleList << (sectionName << "Modules" +++ mkNodeList qual [] "n" ts) + + +mkNodeList :: Qualification -> [String] -> String -> [ModuleTree] -> Html +mkNodeList qual ss p ts = case ts of + [] -> noHtml + _ -> unordList (zipWith (mkNode qual ss) ps ts) + where + ps = [ p ++ '.' : show i | i <- [(1::Int)..]] + + +mkNode :: Qualification -> [String] -> String -> ModuleTree -> Html +mkNode qual ss p (Node s leaf pkg short ts) = + htmlModule <+> shortDescr +++ htmlPkg +++ subtree + where + modAttrs = case (ts, leaf) of + (_:_, False) -> collapseControl p True "module" + (_, _ ) -> [theclass "module"] + + cBtn = case (ts, leaf) of + (_:_, True) -> thespan ! collapseControl p True "" << spaceHtml + (_, _ ) -> noHtml + -- We only need an explicit collapser button when the module name + -- is also a leaf, and so is a link to a module page. Indeed, the + -- spaceHtml is a minor hack and does upset the layout a fraction. + + htmlModule = thespan ! modAttrs << (cBtn +++ + if leaf + then ppModule (mkModule (stringToPackageId (fromMaybe "" pkg)) + (mkModuleName mdl)) + else toHtml s + ) + + mdl = intercalate "." (reverse (s:ss)) + + shortDescr = maybe noHtml (origDocToHtml qual) short + htmlPkg = maybe noHtml (thespan ! [theclass "package"] <<) pkg + + subtree = mkNodeList qual (s:ss) p ts ! collapseSection p True "" + + +-- | Turn a module tree into a flat list of full module names. E.g., +-- @ +-- A +-- +-B +-- +-C +-- @ +-- becomes +-- @["A", "A.B", "A.B.C"]@ +flatModuleTree :: [InstalledInterface] -> [Html] +flatModuleTree ifaces = + map (uncurry ppModule' . head) + . groupBy ((==) `on` fst) + . sortBy (comparing fst) + $ mods + where + mods = [ (moduleString mdl, mdl) | mdl <- map instMod ifaces ] + ppModule' txt mdl = + anchor ! [href (moduleHtmlFile mdl), target mainFrameName] + << toHtml txt + + +ppHtmlContentsFrame :: FilePath -> String -> Themes + -> [InstalledInterface] -> Bool -> IO () +ppHtmlContentsFrame odir doctitle themes ifaces debug = do + let mods = flatModuleTree ifaces + html = + headHtml doctitle Nothing themes +++ + miniBody << divModuleList << + (sectionName << "Modules" +++ + ulist << [ li ! [theclass "module"] << m | m <- mods ]) + createDirectoryIfMissing True odir + writeFile (joinPath [odir, frameIndexHtmlFile]) (renderToString debug html) + + +-------------------------------------------------------------------------------- +-- * Generate the index +-------------------------------------------------------------------------------- + + +ppHtmlIndex :: FilePath + -> String + -> Maybe String + -> Themes + -> Maybe String + -> SourceURLs + -> WikiURLs + -> [InstalledInterface] + -> Bool + -> IO () +ppHtmlIndex odir doctitle _maybe_package themes + maybe_contents_url maybe_source_url maybe_wiki_url ifaces debug = do + let html = indexPage split_indices Nothing + (if split_indices then [] else index) + + createDirectoryIfMissing True odir + + when split_indices $ do + mapM_ (do_sub_index index) initialChars + -- Let's add a single large index as well for those who don't know exactly what they're looking for: + let mergedhtml = indexPage False Nothing index + writeFile (joinPath [odir, subIndexHtmlFile merged_name]) (renderToString debug mergedhtml) + + writeFile (joinPath [odir, indexHtmlFile]) (renderToString debug html) + + where + indexPage showLetters ch items = + headHtml (doctitle ++ " (" ++ indexName ch ++ ")") Nothing themes +++ + bodyHtml doctitle Nothing + maybe_source_url maybe_wiki_url + maybe_contents_url Nothing << [ + if showLetters then indexInitialLetterLinks else noHtml, + if null items then noHtml else + divIndex << [sectionName << indexName ch, buildIndex items] + ] + + indexName ch = "Index" ++ maybe "" (\c -> " - " ++ [c]) ch + merged_name = "All" + + buildIndex items = table << aboves (map indexElt items) + + -- an arbitrary heuristic: + -- too large, and a single-page will be slow to load + -- too small, and we'll have lots of letter-indexes with only one + -- or two members in them, which seems inefficient or + -- unnecessarily hard to use. + split_indices = length index > 150 + + indexInitialLetterLinks = + divAlphabet << + unordList (map (\str -> anchor ! [href (subIndexHtmlFile str)] << str) $ + [ [c] | c <- initialChars + , any ((==c) . toUpper . head . fst) index ] ++ + [merged_name]) + + -- todo: what about names/operators that start with Unicode + -- characters? + -- Exports beginning with '_' can be listed near the end, + -- presumably they're not as important... but would be listed + -- with non-split index! + initialChars = [ 'A'..'Z' ] ++ ":!#$%&*+./<=>?@\\^|-~" ++ "_" + + do_sub_index this_ix c + = unless (null index_part) $ + writeFile (joinPath [odir, subIndexHtmlFile [c]]) (renderToString debug html) + where + html = indexPage True (Just c) index_part + index_part = [(n,stuff) | (n,stuff) <- this_ix, toUpper (head n) == c] + + + index :: [(String, Map GHC.Name [(Module,Bool)])] + index = sortBy cmp (Map.toAscList full_index) + where cmp (n1,_) (n2,_) = comparing (map toUpper) n1 n2 + + -- for each name (a plain string), we have a number of original HsNames that + -- it can refer to, and for each of those we have a list of modules + -- that export that entity. Each of the modules exports the entity + -- in a visible or invisible way (hence the Bool). + full_index :: Map String (Map GHC.Name [(Module,Bool)]) + full_index = Map.fromListWith (flip (Map.unionWith (++))) + (concatMap getIfaceIndex ifaces) + + getIfaceIndex iface = + [ (getOccString name + , Map.fromList [(name, [(mdl, name `Set.member` visible)])]) + | name <- instExports iface ] + where + mdl = instMod iface + visible = Set.fromList (instVisibleExports iface) + + indexElt :: (String, Map GHC.Name [(Module,Bool)]) -> HtmlTable + indexElt (str, entities) = + case Map.toAscList entities of + [(nm,entries)] -> + td ! [ theclass "src" ] << toHtml str <-> + indexLinks nm entries + many_entities -> + td ! [ theclass "src" ] << toHtml str <-> td << spaceHtml </> + aboves (zipWith (curry doAnnotatedEntity) [1..] many_entities) + + doAnnotatedEntity :: (Integer, (Name, [(Module, Bool)])) -> HtmlTable + doAnnotatedEntity (j,(nm,entries)) + = td ! [ theclass "alt" ] << + toHtml (show j) <+> parens (ppAnnot (nameOccName nm)) <-> + indexLinks nm entries + + ppAnnot n | not (isValOcc n) = toHtml "Type/Class" + | isDataOcc n = toHtml "Data Constructor" + | otherwise = toHtml "Function" + + indexLinks nm entries = + td ! [ theclass "module" ] << + hsep (punctuate comma + [ if visible then + linkId mdl (Just nm) << toHtml (moduleString mdl) + else + toHtml (moduleString mdl) + | (mdl, visible) <- entries ]) + + +-------------------------------------------------------------------------------- +-- * Generate the HTML page for a module +-------------------------------------------------------------------------------- + + +ppHtmlModule + :: FilePath -> String -> Themes + -> SourceURLs -> WikiURLs + -> Maybe String -> Maybe String -> Bool -> QualOption + -> Bool -> Interface -> IO () +ppHtmlModule odir doctitle themes + maybe_source_url maybe_wiki_url + maybe_contents_url maybe_index_url unicode qual debug iface = do + let + mdl = ifaceMod iface + aliases = ifaceModuleAliases iface + mdl_str = moduleString mdl + real_qual = makeModuleQual qual aliases mdl + html = + headHtml mdl_str (Just $ "mini_" ++ moduleHtmlFile mdl) themes +++ + bodyHtml doctitle (Just iface) + maybe_source_url maybe_wiki_url + maybe_contents_url maybe_index_url << [ + divModuleHeader << (moduleInfo iface +++ (sectionName << mdl_str)), + ifaceToHtml maybe_source_url maybe_wiki_url iface unicode real_qual + ] + + createDirectoryIfMissing True odir + writeFile (joinPath [odir, moduleHtmlFile mdl]) (renderToString debug html) + ppHtmlModuleMiniSynopsis odir doctitle themes iface unicode real_qual debug + +ppHtmlModuleMiniSynopsis :: FilePath -> String -> Themes + -> Interface -> Bool -> Qualification -> Bool -> IO () +ppHtmlModuleMiniSynopsis odir _doctitle themes iface unicode qual debug = do + let mdl = ifaceMod iface + html = + headHtml (moduleString mdl) Nothing themes +++ + miniBody << + (divModuleHeader << sectionName << moduleString mdl +++ + miniSynopsis mdl iface unicode qual) + createDirectoryIfMissing True odir + writeFile (joinPath [odir, "mini_" ++ moduleHtmlFile mdl]) (renderToString debug html) + + +ifaceToHtml :: SourceURLs -> WikiURLs -> Interface -> Bool -> Qualification -> Html +ifaceToHtml maybe_source_url maybe_wiki_url iface unicode qual + = ppModuleContents qual exports +++ + description +++ + synopsis +++ + divInterface (maybe_doc_hdr +++ bdy) + where + exports = numberSectionHeadings (ifaceRnExportItems iface) + + -- todo: if something has only sub-docs, or fn-args-docs, should + -- it be measured here and thus prevent omitting the synopsis? + has_doc ExportDecl { expItemMbDoc = (Documentation mDoc mWarning, _) } = isJust mDoc || isJust mWarning + has_doc (ExportNoDecl _ _) = False + has_doc (ExportModule _) = False + has_doc _ = True + + no_doc_at_all = not (any has_doc exports) + + description | isNoHtml doc = doc + | otherwise = divDescription $ sectionName << "Description" +++ doc + where doc = docSection qual (ifaceRnDoc iface) + + -- omit the synopsis if there are no documentation annotations at all + synopsis + | no_doc_at_all = noHtml + | otherwise + = divSynposis $ + paragraph ! collapseControl "syn" False "caption" << "Synopsis" +++ + shortDeclList ( + mapMaybe (processExport True linksInfo unicode qual) exports + ) ! (collapseSection "syn" False "" ++ collapseToggle "syn") + + -- if the documentation doesn't begin with a section header, then + -- add one ("Documentation"). + maybe_doc_hdr + = case exports of + [] -> noHtml + ExportGroup {} : _ -> noHtml + _ -> h1 << "Documentation" + + bdy = + foldr (+++) noHtml $ + mapMaybe (processExport False linksInfo unicode qual) exports + + linksInfo = (maybe_source_url, maybe_wiki_url) + + +miniSynopsis :: Module -> Interface -> Bool -> Qualification -> Html +miniSynopsis mdl iface unicode qual = + divInterface << concatMap (processForMiniSynopsis mdl unicode qual) exports + where + exports = numberSectionHeadings (ifaceRnExportItems iface) + + +processForMiniSynopsis :: Module -> Bool -> Qualification -> ExportItem DocName + -> [Html] +processForMiniSynopsis mdl unicode qual ExportDecl { expItemDecl = L _loc decl0 } = + ((divTopDecl <<).(declElem <<)) <$> case decl0 of + TyClD d -> let b = ppTyClBinderWithVarsMini mdl d in case d of + (FamDecl decl) -> [ppTyFamHeader True False decl unicode qual] + (DataDecl{}) -> [keyword "data" <+> b] + (SynDecl{}) -> [keyword "type" <+> b] + (ClassDecl {}) -> [keyword "class" <+> b] + _ -> [] + SigD (TypeSig lnames (L _ _)) -> + map (ppNameMini Prefix mdl . nameOccName . getName . unLoc) lnames + _ -> [] +processForMiniSynopsis _ _ qual (ExportGroup lvl _id txt) = + [groupTag lvl << docToHtml qual txt] +processForMiniSynopsis _ _ _ _ = [] + + +ppNameMini :: Notation -> Module -> OccName -> Html +ppNameMini notation mdl nm = + anchor ! [ href (moduleNameUrl mdl nm) + , target mainFrameName ] + << ppBinder' notation nm + + +ppTyClBinderWithVarsMini :: Module -> TyClDecl DocName -> Html +ppTyClBinderWithVarsMini mdl decl = + let n = tcdName decl + 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 + | otherwise = contentsDiv + where + contentsDiv = divTableOfContents << ( + sectionName << "Contents" +++ + unordList sections) + + (sections, _leftovers{-should be []-}) = process 0 exports + + process :: Int -> [ExportItem DocName] -> ([Html],[ExportItem DocName]) + process _ [] = ([], []) + process n items@(ExportGroup lev id0 doc : rest) + | 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 + process n (_ : rest) = process n rest + + mk_subsections [] = noHtml + mk_subsections ss = unordList ss + +-- we need to assign a unique id to each section heading so we can hyperlink +-- them from the contents: +numberSectionHeadings :: [ExportItem DocName] -> [ExportItem DocName] +numberSectionHeadings = go 1 + where go :: Int -> [ExportItem DocName] -> [ExportItem DocName] + go _ [] = [] + go n (ExportGroup lev _ doc : es) + = ExportGroup lev (show n) doc : go (n+1) es + go n (other:es) + = other : go n es + + +processExport :: Bool -> LinksInfo -> Bool -> Qualification + -> 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 +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 []) + = processDeclOneLiner summary $ ppDocName qual Prefix True y +processExport summary _ _ qual (ExportNoDecl y subs) + = processDeclOneLiner summary $ + ppDocName qual Prefix True y + +++ parenList (map (ppDocName qual Prefix True) subs) +processExport summary _ _ qual (ExportDoc doc) + = nothingIf summary $ docSection_ qual doc +processExport summary _ _ _ (ExportModule mdl) + = processDeclOneLiner summary $ toHtml "module" <+> ppModule mdl + + +nothingIf :: Bool -> a -> Maybe a +nothingIf True _ = Nothing +nothingIf False a = Just a + + +processDecl :: Bool -> Html -> Maybe Html +processDecl True = Just +processDecl False = Just . divTopDecl + + +processDeclOneLiner :: Bool -> Html -> Maybe Html +processDeclOneLiner True = Just +processDeclOneLiner False = Just . divTopDecl . declElem + +groupHeading :: Int -> String -> Html -> Html +groupHeading lev id0 = groupTag lev ! [identifier (groupId id0)] + +groupTag :: Int -> Html -> Html +groupTag lev + | lev == 1 = h1 + | lev == 2 = h2 + | lev == 3 = h3 + | otherwise = h4 diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs new file mode 100644 index 00000000..8884f69f --- /dev/null +++ b/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs @@ -0,0 +1,885 @@ +{-# LANGUAGE TransformListComp #-} +----------------------------------------------------------------------------- +-- | +-- Module : Haddock.Backends.Html.Decl +-- Copyright : (c) Simon Marlow 2003-2006, +-- David Waern 2006-2009, +-- Mark Lentczner 2010 +-- License : BSD-like +-- +-- Maintainer : haddock@projects.haskell.org +-- Stability : experimental +-- Portability : portable +----------------------------------------------------------------------------- +module Haddock.Backends.Xhtml.Decl ( + ppDecl, + + ppTyName, ppTyFamHeader, ppTypeApp, + tyvarNames +) where + + +import Haddock.Backends.Xhtml.DocMarkup +import Haddock.Backends.Xhtml.Layout +import Haddock.Backends.Xhtml.Names +import Haddock.Backends.Xhtml.Types +import Haddock.Backends.Xhtml.Utils +import Haddock.GhcUtils +import Haddock.Types +import Haddock.Doc (combineDocumentation) + +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 +import GHC.Exts +import Name +import BooleanFormula + +ppDecl :: Bool -> LinksInfo -> LHsDecl DocName + -> 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 + ForD d -> ppFor summ links loc (mbDoc, fnArgsDoc) d fixities splice unicode qual + InstD _ -> noHtml + _ -> error "declaration not supported by ppDecl" + + +ppLFunSig :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName -> + [Located DocName] -> LHsType DocName -> [(DocName, Fixity)] -> + Splice -> Unicode -> Qualification -> Html +ppLFunSig summary links loc doc lnames lty fixities splice unicode qual = + ppFunSig summary links loc doc (map unLoc lnames) (unLoc lty) fixities + splice unicode qual + +ppFunSig :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName -> + [DocName] -> HsType DocName -> [(DocName, Fixity)] -> + Splice -> Unicode -> Qualification -> Html +ppFunSig summary links loc doc docnames typ fixities splice unicode qual = + ppSigLike summary links loc mempty doc docnames fixities (typ, pp_typ) + splice unicode qual + where + pp_typ = ppType unicode qual typ + +ppLPatSig :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName -> + Located DocName -> + HsPatSynDetails (LHsType DocName) -> LHsType DocName -> + LHsContext DocName -> LHsContext 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 + | summary = pref1 + | otherwise = topDeclElem links loc splice [docname] (pref1 <+> ppFixities fixities qual) + +++ docSection qual doc + where + pref1 = hsep [ toHtml "pattern" + , pp_cxt prov + , pp_head + , dcolon unicode + , pp_cxt req + , ppType 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 + + occname = nameOccName . getName $ docname + +ppSigLike :: Bool -> LinksInfo -> SrcSpan -> Html -> DocForDecl DocName -> + [DocName] -> [(DocName, Fixity)] -> (HsType DocName, Html) -> + Splice -> Unicode -> Qualification -> Html +ppSigLike summary links loc leader doc docnames fixities (typ, pp_typ) + splice unicode qual = + ppTypeOrFunSig summary links loc docnames typ doc + ( addFixities $ leader <+> ppTypeSig summary occnames pp_typ unicode + , addFixities . concatHtml . punctuate comma $ map (ppBinder False) occnames + , dcolon unicode + ) + splice unicode qual + where + occnames = map (nameOccName . getName) docnames + addFixities html + | summary = html + | otherwise = html <+> ppFixities fixities qual + + +ppTypeOrFunSig :: Bool -> LinksInfo -> SrcSpan -> [DocName] -> HsType DocName + -> DocForDecl DocName -> (Html, Html, Html) + -> 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 + | otherwise = topDeclElem links loc splice docnames pref2 +++ + subArguments qual (do_args 0 sep typ) +++ docSection qual doc + where + argDoc n = Map.lookup n argDocs + + do_largs n leader (L _ t) = do_args n leader t + do_args :: Int -> Html -> HsType DocName -> [SubDecl] + do_args n leader (HsForAllTy Explicit tvs lctxt ltype) + = (leader <+> + hsep (forallSymbol unicode : ppTyVars tvs ++ [dot]) <+> + ppLContextNoArrow lctxt unicode qual, + Nothing, []) + : do_largs n (darrow unicode) ltype + do_args n leader (HsForAllTy Implicit _ lctxt ltype) + | not (null (unLoc lctxt)) + = (leader <+> ppLContextNoArrow lctxt unicode qual, + Nothing, []) + : do_largs n (darrow unicode) ltype + -- if we're not showing any 'forall' or class constraints or + -- anything, skip having an empty line for the context. + | otherwise + = do_largs n leader ltype + do_args n leader (HsFunTy lt r) + = (leader <+> ppLFunLhType unicode qual lt, argDoc n, []) + : do_largs (n+1) (arrow unicode) r + do_args n leader t + = [(leader <+> ppType unicode qual t, argDoc n, [])] + +ppFixities :: [(DocName, Fixity)] -> Qualification -> Html +ppFixities [] _ = noHtml +ppFixities fs qual = foldr1 (+++) (map ppFix uniq_fs) +++ rightEdge + where + ppFix (ns, p, d) = thespan ! [theclass "fixity"] << + (toHtml d <+> toHtml (show p) <+> ppNames ns) + + ppDir InfixR = "infixr" + ppDir InfixL = "infixl" + ppDir InfixN = "infix" + + ppNames = case fs of + _:[] -> const noHtml -- Don't display names for fixities on single names + _ -> concatHtml . intersperse (stringToHtml ", ") . map (ppDocName qual Infix False) + + uniq_fs = [ (n, the p, the d') | (n, Fixity p d) <- fs + , let d' = ppDir d + , then group by Down (p,d') using groupWith ] + + rightEdge = thespan ! [theclass "rightedge"] << noHtml + + +ppTyVars :: LHsTyVarBndrs DocName -> [Html] +ppTyVars tvs = map ppTyName (tyvarNames tvs) + + +tyvarNames :: LHsTyVarBndrs DocName -> [Name] +tyvarNames = map getName . hsLTyVarNames + + +ppFor :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName + -> ForeignDecl DocName -> [(DocName, Fixity)] + -> Splice -> Unicode -> Qualification -> Html +ppFor summary links loc doc (ForeignImport (L _ name) (L _ typ) _ _) fixities + splice unicode qual + = ppFunSig summary links loc doc [name] typ fixities splice unicode qual +ppFor _ _ _ _ _ _ _ _ _ = error "ppFor" + + +-- we skip type patterns for now +ppTySyn :: Bool -> LinksInfo -> [(DocName, Fixity)] -> SrcSpan + -> DocForDecl DocName -> TyClDecl DocName + -> Splice -> Unicode -> Qualification -> Html +ppTySyn summary links fixities loc doc (SynDecl { tcdLName = L _ name, tcdTyVars = ltyvars + , tcdRhs = ltype }) + splice unicode qual + = ppTypeOrFunSig summary links loc [name] (unLoc ltype) doc + (full <+> fixs, hdr <+> fixs, spaceHtml +++ equals) + splice unicode qual + where + hdr = hsep ([keyword "type", ppBinder summary occ] ++ ppTyVars ltyvars) + full = hdr <+> equals <+> ppLType unicode qual ltype + occ = nameOccName . getName $ name + fixs + | summary = noHtml + | otherwise = ppFixities fixities qual +ppTySyn _ _ _ _ _ _ _ _ _ = error "declaration not supported by ppTySyn" + + +ppTypeSig :: Bool -> [OccName] -> Html -> Bool -> Html +ppTypeSig summary nms pp_ty unicode = + concatHtml htmlNames <+> dcolon unicode <+> pp_ty + where + htmlNames = intersperse (stringToHtml ", ") $ map (ppBinder summary) nms + + +ppTyName :: Name -> Html +ppTyName = ppName Prefix + + +-------------------------------------------------------------------------------- +-- * Type families +-------------------------------------------------------------------------------- + + +ppTyFamHeader :: Bool -> Bool -> FamilyDecl DocName + -> Unicode -> Qualification -> Html +ppTyFamHeader summary associated d@(FamilyDecl { fdInfo = info + , fdKindSig = mkind }) + unicode qual = + (case info of + OpenTypeFamily + | associated -> keyword "type" + | otherwise -> keyword "type family" + DataFamily + | associated -> keyword "data" + | otherwise -> keyword "data family" + ClosedTypeFamily _ + -> keyword "type family" + ) <+> + + ppFamDeclBinderWithVars summary d <+> + + (case mkind of + Just kind -> dcolon unicode <+> ppLKind unicode qual kind + Nothing -> noHtml + ) + +ppTyFam :: Bool -> Bool -> LinksInfo -> [DocInstance DocName] -> + [(DocName, Fixity)] -> SrcSpan -> Documentation DocName -> + FamilyDecl DocName -> Splice -> Unicode -> Qualification -> Html +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 + + where + docname = unLoc $ fdLName decl + + header_ = topDeclElem links loc splice [docname] $ + ppTyFamHeader summary associated decl unicode qual <+> ppFixities fixities qual + + instancesBit + | FamilyDecl { fdInfo = ClosedTypeFamily eqns } <- decl + , not summary + = subEquations qual $ map (ppTyFamEqn . unLoc) eqns + + | otherwise + = ppInstances 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 }} + = ( ppAppNameTypes (unLoc n) [] (map unLoc ts) unicode qual + <+> equals <+> ppType unicode qual (unLoc rhs) + , Nothing, [] ) + +-------------------------------------------------------------------------------- +-- * Associated Types +-------------------------------------------------------------------------------- + + +ppAssocType :: Bool -> LinksInfo -> DocForDecl DocName -> LFamilyDecl DocName + -> [(DocName, Fixity)] -> Splice -> Unicode -> Qualification -> Html +ppAssocType summ links doc (L loc decl) fixities splice unicode qual = + ppTyFam summ True links [] fixities loc (fst doc) decl splice unicode qual + + +-------------------------------------------------------------------------------- +-- * TyClDecl helpers +-------------------------------------------------------------------------------- + +-- | Print a type family and its variables +ppFamDeclBinderWithVars :: Bool -> FamilyDecl DocName -> Html +ppFamDeclBinderWithVars summ (FamilyDecl { fdLName = lname, fdTyVars = tvs }) = + ppAppDocNameNames summ (unLoc lname) (tyvarNames tvs) + +-- | Print a newtype / data binder and its variables +ppDataBinderWithVars :: Bool -> TyClDecl DocName -> Html +ppDataBinderWithVars summ decl = + ppAppDocNameNames summ (tcdName decl) (tyvarNames $ tcdTyVars decl) + +-------------------------------------------------------------------------------- +-- * Type applications +-------------------------------------------------------------------------------- + + +-- | Print an application of a DocName and two lists of HsTypes (kinds, types) +ppAppNameTypes :: DocName -> [HsType DocName] -> [HsType DocName] + -> Unicode -> Qualification -> Html +ppAppNameTypes n ks ts unicode qual = + ppTypeApp n ks ts (\p -> ppDocName qual p True) (ppParendType unicode qual) + + +-- | Print an application of a DocName and a list of Names +ppAppDocNameNames :: Bool -> DocName -> [Name] -> Html +ppAppDocNameNames summ n ns = + ppTypeApp n [] ns ppDN ppTyName + where + ppDN notation = ppBinderFixity notation summ . nameOccName . getName + ppBinderFixity Infix = ppBinderInfix + ppBinderFixity _ = ppBinder + +-- | General printing of type applications +ppTypeApp :: DocName -> [a] -> [a] -> (Notation -> DocName -> Html) -> (a -> Html) -> Html +ppTypeApp n [] (t1:t2:rest) ppDN ppT + | operator, not . null $ rest = parens opApp <+> hsep (map ppT rest) + | operator = opApp + where + operator = isNameSym . getName $ n + opApp = ppT t1 <+> ppDN Infix n <+> ppT t2 + +ppTypeApp n ks ts ppDN ppT = ppDN Prefix n <+> hsep (map ppT $ ks ++ ts) + + +------------------------------------------------------------------------------- +-- * Contexts +------------------------------------------------------------------------------- + + +ppLContext, ppLContextNoArrow :: Located (HsContext DocName) -> Unicode + -> Qualification -> Html +ppLContext = ppContext . unLoc +ppLContextNoArrow = ppContextNoArrow . unLoc + + +ppContextNoArrow :: HsContext DocName -> Unicode -> Qualification -> Html +ppContextNoArrow [] _ _ = noHtml +ppContextNoArrow cxt unicode qual = ppHsContext (map unLoc cxt) unicode qual + + +ppContextNoLocs :: [HsType DocName] -> Unicode -> Qualification -> Html +ppContextNoLocs [] _ _ = noHtml +ppContextNoLocs cxt unicode qual = ppHsContext cxt unicode qual + <+> darrow unicode + + +ppContext :: HsContext DocName -> Unicode -> Qualification -> Html +ppContext cxt unicode qual = ppContextNoLocs (map unLoc cxt) unicode qual + + +ppHsContext :: [HsType DocName] -> Unicode -> Qualification-> Html +ppHsContext [] _ _ = noHtml +ppHsContext [p] unicode qual = ppCtxType unicode qual p +ppHsContext cxt unicode qual = parenList (map (ppType unicode qual) cxt) + + +------------------------------------------------------------------------------- +-- * Class declarations +------------------------------------------------------------------------------- + + +ppClassHdr :: Bool -> Located [LHsType DocName] -> DocName + -> LHsTyVarBndrs DocName -> [Located ([DocName], [DocName])] + -> Unicode -> Qualification -> Html +ppClassHdr summ lctxt n tvs fds unicode qual = + keyword "class" + <+> (if not . null . unLoc $ lctxt then ppLContext lctxt unicode qual else noHtml) + <+> ppAppDocNameNames summ n (tyvarNames tvs) + <+> ppFds fds unicode qual + + +ppFds :: [Located ([DocName], [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) + +ppShortClassDecl :: Bool -> LinksInfo -> TyClDecl DocName -> SrcSpan + -> [(DocName, DocForDecl DocName)] + -> Splice -> Unicode -> Qualification -> Html +ppShortClassDecl summary links (ClassDecl { tcdCtxt = lctxt, tcdLName = lname, tcdTyVars = tvs + , tcdFDs = fds, tcdSigs = sigs, tcdATs = ats }) loc + subdocs splice unicode qual = + if not (any isVanillaLSig sigs) && null ats + then (if summary then id else topDeclElem links loc splice [nm]) hdr + else (if summary then id else topDeclElem links loc splice [nm]) (hdr <+> keyword "where") + +++ shortSubDecls False + ( + [ ppAssocType summary links doc at [] splice unicode qual | at <- ats + , let doc = lookupAnySubdoc (unL $ fdLName $ unL at) subdocs ] ++ + + -- ToDo: add associated type defaults + + [ ppFunSig summary links loc doc names typ [] splice unicode qual + | L _ (TypeSig lnames (L _ typ)) <- sigs + , let doc = lookupAnySubdoc (head names) subdocs + names = map unLoc lnames ] + -- FIXME: is taking just the first name ok? Is it possible that + -- there are different subdocs for different names in a single + -- type signature? + ) + where + hdr = ppClassHdr summary lctxt (unLoc lname) tvs fds unicode qual + nm = unLoc lname +ppShortClassDecl _ _ _ _ _ _ _ _ = error "declaration type not supported by ppShortClassDecl" + + + +ppClassDecl :: Bool -> LinksInfo -> [DocInstance DocName] -> [(DocName, Fixity)] + -> SrcSpan -> Documentation DocName + -> [(DocName, DocForDecl DocName)] -> TyClDecl DocName + -> Splice -> Unicode -> Qualification -> Html +ppClassDecl summary links instances fixities loc d subdocs + decl@(ClassDecl { tcdCtxt = lctxt, tcdLName = lname, tcdTyVars = ltyvars + , tcdFDs = lfds, tcdSigs = lsigs, tcdATs = ats }) + splice unicode qual + | summary = ppShortClassDecl summary links decl loc subdocs splice unicode qual + | otherwise = classheader +++ docSection qual d + +++ minimalBit +++ atBit +++ methodBit +++ instancesBit + where + classheader + | any isVanillaLSig lsigs = topDeclElem links loc splice [nm] (hdr unicode qual <+> keyword "where" <+> fixs) + | otherwise = topDeclElem links loc splice [nm] (hdr unicode qual <+> fixs) + + -- Only the fixity relevant to the class header + fixs = ppFixities [ f | f@(n,_) <- fixities, n == unLoc lname ] qual + + nm = tcdName decl + + hdr = ppClassHdr summary lctxt (unLoc lname) ltyvars lfds + + -- ToDo: add assocatied typ defaults + atBit = subAssociatedTypes [ ppAssocType summary links doc at subfixs splice unicode qual + | at <- ats + , let n = unL . fdLName $ unL at + doc = lookupAnySubdoc (unL $ fdLName $ unL at) subdocs + 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 + , let doc = lookupAnySubdoc (head names) subdocs + subfixs = [ f | n <- names + , f@(n',_) <- fixities + , n == n' ] + names = map unLoc lnames ] + -- FIXME: is taking just the first name ok? Is it possible that + -- there are different subdocs for different names in a single + -- type signature? + + 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] + -> noHtml + + -- Minimal complete definition = the only shown method + Var (L _ n) : _ | [getName n] == + [getName n' | L _ (TypeSig ns _) <- lsigs, L _ n' <- ns] + -> noHtml + + -- Minimal complete definition = nothing + And [] : _ -> subMinimal $ toHtml "Nothing" + + m : _ -> subMinimal $ ppMinimal False m + _ -> noHtml + + ppMinimal _ (Var (L _ n)) = ppDocName qual Prefix True n + ppMinimal _ (And fs) = foldr1 (\a b -> a+++", "+++b) $ map (ppMinimal True) fs + 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 + +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) + where + instName = getOccString $ getName baseName + instDecl :: DocInstance DocName -> SubDecl + instDecl (inst, maybeDoc) = (instHead inst, maybeDoc, []) + instHead (n, ks, ts, ClassInst cs) = ppContextNoLocs cs unicode qual + <+> ppAppNameTypes n ks ts unicode qual + instHead (n, ks, ts, TypeInst rhs) = keyword "type" + <+> ppAppNameTypes n ks ts unicode qual + <+> maybe noHtml (\t -> equals <+> ppType unicode qual t) rhs + instHead (n, ks, ts, DataInst dd) = keyword "data" + <+> ppAppNameTypes n ks ts unicode qual + <+> ppShortDataDecl False True dd unicode qual + +lookupAnySubdoc :: Eq id1 => id1 -> [(id1, DocForDecl id2)] -> DocForDecl id2 +lookupAnySubdoc n = fromMaybe noDocForDecl . lookup n + + +------------------------------------------------------------------------------- +-- * Data & newtype declarations +------------------------------------------------------------------------------- + + +-- TODO: print contexts +ppShortDataDecl :: Bool -> Bool -> TyClDecl DocName -> Unicode -> Qualification -> Html +ppShortDataDecl summary dataInst dataDecl unicode qual + + | [] <- cons = dataHeader + + | [lcon] <- cons, ResTyH98 <- resTy, + (cHead,cBody,cFoot) <- ppShortConstrParts summary dataInst (unLoc lcon) unicode qual + = (dataHeader <+> equals <+> cHead) +++ cBody +++ cFoot + + | ResTyH98 <- resTy = dataHeader + +++ shortSubDecls dataInst (zipWith doConstr ('=':repeat '|') cons) + + | otherwise = (dataHeader <+> keyword "where") + +++ shortSubDecls dataInst (map doGADTConstr cons) + + where + dataHeader + | dataInst = noHtml + | otherwise = ppDataHeader summary dataDecl unicode qual + doConstr c con = toHtml [c] <+> ppShortConstr summary (unLoc con) unicode qual + doGADTConstr con = ppShortConstr summary (unLoc con) unicode qual + + cons = dd_cons (tcdDataDefn dataDecl) + resTy = (con_res . unLoc . head) cons + + +ppDataDecl :: Bool -> LinksInfo -> [DocInstance DocName] -> [(DocName, Fixity)] -> + [(DocName, DocForDecl DocName)] -> + SrcSpan -> Documentation DocName -> TyClDecl DocName -> + Splice -> Unicode -> Qualification -> Html +ppDataDecl summary links instances fixities subdocs loc doc dataDecl + splice unicode qual + + | summary = ppShortDataDecl summary False dataDecl unicode qual + | otherwise = header_ +++ docSection qual doc +++ constrBit +++ instancesBit + + where + docname = tcdName dataDecl + cons = dd_cons (tcdDataDefn dataDecl) + resTy = (con_res . unLoc . head) cons + + header_ = topDeclElem links loc splice [docname] $ + ppDataHeader summary dataDecl unicode qual <+> whereBit <+> fix + + fix = ppFixities (filter (\(n,_) -> n == docname) fixities) qual + + whereBit + | null cons = noHtml + | otherwise = case resTy of + 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 + ] + + instancesBit = ppInstances instances docname unicode qual + + + +ppShortConstr :: Bool -> ConDecl DocName -> Unicode -> Qualification -> Html +ppShortConstr summary con unicode qual = cHead <+> cBody <+> cFoot + where + (cHead,cBody,cFoot) = ppShortConstrParts summary False con unicode qual + + +-- returns three pieces: header, body, footer so that header & footer can be +-- incorporated into the declaration +ppShortConstrParts :: Bool -> Bool -> ConDecl DocName -> Unicode -> Qualification -> (Html, Html, Html) +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 + : map (ppLParendType unicode qual) args), noHtml, noHtml) + RecCon fields -> + (header_ unicode qual +++ ppBinder summary occ <+> char '{', + doRecordFields fields, + char '}') + InfixCon arg1 arg2 -> + (header_ unicode qual +++ hsep [ppLParendType unicode qual arg1, + ppBinderInfix summary occ, ppLParendType unicode qual arg2], + noHtml, noHtml) + + 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) + -- display GADT records with the new syntax, + -- 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 <+> + ppForAll forall_ ltvs lcontext unicode qual <+> char '{', + doRecordFields fields, + char '}' <+> arrow unicode <+> ppLType unicode qual resTy) + InfixCon arg1 arg2 -> (doGADTCon [arg1, arg2] resTy, noHtml, noHtml) + + where + doRecordFields fields = shortSubDecls dataInst (map (ppShortField summary unicode qual) fields) + doGADTCon args resTy = ppBinder summary occ <+> dcolon unicode <+> hsep [ + ppForAll forall_ ltvs lcontext unicode qual, + ppLType unicode qual (foldr mkFunTy resTy args) ] + + header_ = ppConstrHdr forall_ tyVars context + occ = nameOccName . getName . unLoc . con_name $ con + ltvs = con_qvars con + tyVars = tyvarNames ltvs + lcontext = con_cxt con + context = unLoc (con_cxt con) + forall_ = con_explicit con + mkFunTy a b = noLoc (HsFunTy a b) + + +-- ppConstrHdr is for (non-GADT) existentials constructors' syntax +ppConstrHdr :: HsExplicitFlag -> [Name] -> HsContext DocName -> Unicode + -> Qualification -> Html +ppConstrHdr forall_ tvs ctxt unicode qual + = (if null tvs then noHtml else ppForall) + +++ + (if null ctxt then noHtml else ppContextNoArrow ctxt unicode qual + <+> darrow unicode +++ toHtml " ") + where + ppForall = case forall_ of + Explicit -> forallSymbol unicode <+> hsep (map (ppName Prefix) tvs) <+> toHtml ". " + Implicit -> noHtml + + +ppSideBySideConstr :: [(DocName, DocForDecl DocName)] -> [(DocName, Fixity)] + -> Unicode -> Qualification -> LConDecl DocName -> SubDecl +ppSideBySideConstr subdocs fixities unicode qual (L _ con) = (decl, mbDoc, fieldPart) + where + decl = case con_res con of + ResTyH98 -> case con_details con of + PrefixCon args -> + hsep ((header_ +++ ppBinder False occ) + : map (ppLParendType unicode qual) args) + <+> fixity + + RecCon _ -> header_ +++ ppBinder False occ <+> fixity + + InfixCon arg1 arg2 -> + hsep [header_ +++ ppLParendType unicode qual arg1, + ppBinderInfix False occ, + ppLParendType unicode qual arg2] + <+> fixity + + 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 _) -> doGADTCon (hsConDeclArgTys cd) resTy + InfixCon arg1 arg2 -> doGADTCon [arg1, arg2] resTy + + fieldPart = case con_details con of + RecCon fields -> [doRecordFields fields] + _ -> [] + + doRecordFields fields = subFields qual + (map (ppSideBySideField subdocs unicode qual) fields) + doGADTCon :: [LHsType DocName] -> Located (HsType DocName) -> Html + doGADTCon args resTy = ppBinder False occ <+> dcolon unicode + <+> hsep [ppForAll 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 + 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 + 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, + mbDoc, + []) + where + -- don't use cd_fld_doc for same reason we don't use con_doc above + mbDoc = lookup name subdocs >>= combineDocumentation . fst + + +ppShortField :: Bool -> Unicode -> Qualification -> ConDeclField DocName -> Html +ppShortField summary unicode qual (ConDeclField (L _ name) ltype _) + = ppBinder summary (nameOccName . getName $ name) + <+> dcolon unicode <+> ppLType unicode qual ltype + + +-- | Print the LHS of a data\/newtype declaration. +-- Currently doesn't handle 'data instance' decls or kind signatures +ppDataHeader :: Bool -> TyClDecl DocName -> Unicode -> Qualification -> Html +ppDataHeader summary decl@(DataDecl { tcdDataDefn = + HsDataDefn { dd_ND = nd + , dd_ctxt = ctxt + , dd_kindSig = ks } }) + unicode qual + = -- newtype or data + (case nd of { NewType -> keyword "newtype"; DataType -> keyword "data" }) + <+> + -- context + ppLContext ctxt unicode qual <+> + -- T a b c ..., or a :+: b + ppDataBinderWithVars summary decl + <+> case ks of + Nothing -> mempty + Just (L _ x) -> dcolon unicode <+> ppKind unicode qual x + +ppDataHeader _ _ _ _ = error "ppDataHeader: illegal argument" + +-------------------------------------------------------------------------------- +-- * Types and contexts +-------------------------------------------------------------------------------- + + +ppBang :: HsBang -> Html +ppBang HsNoBang = noHtml +ppBang _ = toHtml "!" -- Unpacked args is an implementation detail, + -- so we just show the strictness annotation + + +tupleParens :: HsTupleSort -> [Html] -> Html +tupleParens HsUnboxedTuple = ubxParenList +tupleParens _ = parenList + + +-------------------------------------------------------------------------------- +-- * Rendering of HsType +-------------------------------------------------------------------------------- + + +pREC_TOP, pREC_CTX, pREC_FUN, pREC_OP, pREC_CON :: Int + +pREC_TOP = 0 :: Int -- type in ParseIface.y in GHC +pREC_CTX = 1 :: Int -- Used for single contexts, eg. ctx => type + -- (as opposed to (ctx1, ctx2) => type) +pREC_FUN = 2 :: Int -- btype in ParseIface.y in GHC + -- Used for LH arg of (->) +pREC_OP = 3 :: Int -- Used for arg of any infix operator + -- (we don't keep their fixities around) +pREC_CON = 4 :: Int -- Used for arg of type applicn: + -- always parenthesise unless atomic + +maybeParen :: Int -- Precedence of context + -> Int -- Precedence of top-level operator + -> Html -> Html -- Wrap in parens if (ctxt >= op) +maybeParen ctxt_prec op_prec p | ctxt_prec >= op_prec = parens p + | otherwise = p + + +ppLType, ppLParendType, ppLFunLhType :: Unicode -> Qualification + -> Located (HsType DocName) -> Html +ppLType unicode qual y = ppType unicode qual (unLoc y) +ppLParendType unicode qual y = ppParendType unicode qual (unLoc y) +ppLFunLhType unicode qual y = ppFunLhType unicode qual (unLoc y) + + +ppType, ppCtxType, ppParendType, ppFunLhType :: Unicode -> Qualification + -> HsType DocName -> Html +ppType unicode qual ty = ppr_mono_ty pREC_TOP ty unicode qual +ppCtxType unicode qual ty = ppr_mono_ty pREC_CTX ty unicode qual +ppParendType unicode qual ty = ppr_mono_ty pREC_CON ty unicode qual +ppFunLhType unicode qual ty = ppr_mono_ty pREC_FUN ty unicode qual + +ppLKind :: Unicode -> Qualification -> LHsKind DocName -> Html +ppLKind unicode qual y = ppKind unicode qual (unLoc y) + +ppKind :: Unicode -> Qualification -> HsKind DocName -> Html +ppKind unicode qual ki = ppr_mono_ty pREC_TOP ki unicode qual + +-- Drop top-level for-all type variables in user style +-- since they are implicit in Haskell + +ppForAll :: HsExplicitFlag -> LHsTyVarBndrs DocName + -> Located (HsContext DocName) -> Unicode -> Qualification -> Html +ppForAll expl tvs cxt unicode qual + | show_forall = forall_part <+> ppLContext cxt unicode qual + | otherwise = ppLContext cxt unicode qual + where + show_forall = not (null (hsQTvBndrs tvs)) && is_explicit + is_explicit = case expl of {Explicit -> True; Implicit -> False} + forall_part = hsep (forallSymbol unicode : ppTyVars tvs) +++ dot + + +ppr_mono_lty :: Int -> LHsType DocName -> Unicode -> Qualification -> Html +ppr_mono_lty ctxt_prec ty = ppr_mono_ty ctxt_prec (unLoc ty) + + +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 $ + hsep [ppForAll expl tvs ctxt unicode qual, ppr_mono_lty pREC_TOP ty unicode qual] + +-- UnicodeSyntax alternatives +ppr_mono_ty _ (HsTyVar name) True _ + | getOccString (getName name) == "*" = toHtml "★" + | getOccString (getName name) == "(->)" = toHtml "(→)" + +ppr_mono_ty _ (HsBangTy b ty) u q = ppBang b +++ ppLParendType u q ty +ppr_mono_ty _ (HsTyVar name) _ q = ppDocName q Prefix True name +ppr_mono_ty ctxt_prec (HsFunTy ty1 ty2) u q = ppr_fun_ty ctxt_prec ty1 ty2 u q +ppr_mono_ty _ (HsTupleTy con tys) u q = tupleParens con (map (ppLType u q) tys) +ppr_mono_ty _ (HsKindSig ty kind) u q = + parens (ppr_mono_lty pREC_TOP ty u q <+> dcolon u <+> ppLKind u q kind) +ppr_mono_ty _ (HsListTy ty) u q = brackets (ppr_mono_lty pREC_TOP ty u q) +ppr_mono_ty _ (HsPArrTy ty) u q = pabrackets (ppr_mono_lty pREC_TOP ty u q) +ppr_mono_ty ctxt_prec (HsIParamTy n ty) u q = + maybeParen ctxt_prec pREC_CTX $ ppIPName n <+> dcolon u <+> ppr_mono_lty pREC_TOP ty u q +ppr_mono_ty _ (HsSpliceTy {}) _ _ = error "ppr_mono_ty HsSpliceTy" +ppr_mono_ty _ (HsQuasiQuoteTy {}) _ _ = error "ppr_mono_ty HsQuasiQuoteTy" +ppr_mono_ty _ (HsRecTy {}) _ _ = error "ppr_mono_ty HsRecTy" +ppr_mono_ty _ (HsCoreTy {}) _ _ = error "ppr_mono_ty HsCoreTy" +ppr_mono_ty _ (HsExplicitListTy _ tys) u q = quote $ brackets $ hsep $ punctuate comma $ map (ppLType u q) tys +ppr_mono_ty _ (HsExplicitTupleTy _ tys) u q = quote $ parenList $ map (ppLType u q) tys +ppr_mono_ty _ (HsWrapTy {}) _ _ = error "ppr_mono_ty HsWrapTy" + +ppr_mono_ty ctxt_prec (HsEqTy ty1 ty2) unicode qual + = maybeParen ctxt_prec pREC_CTX $ + ppr_mono_lty pREC_OP ty1 unicode qual <+> char '~' <+> ppr_mono_lty pREC_OP ty2 unicode qual + +ppr_mono_ty ctxt_prec (HsAppTy fun_ty arg_ty) unicode qual + = maybeParen ctxt_prec pREC_CON $ + hsep [ppr_mono_lty pREC_FUN fun_ty unicode qual, ppr_mono_lty pREC_CON arg_ty unicode qual] + +ppr_mono_ty ctxt_prec (HsOpTy ty1 (_, op) ty2) unicode qual + = maybeParen ctxt_prec pREC_FUN $ + ppr_mono_lty pREC_OP ty1 unicode qual <+> ppr_op <+> ppr_mono_lty pREC_OP ty2 unicode qual + where + ppr_op = ppLDocName qual Infix op + +ppr_mono_ty ctxt_prec (HsParTy ty) unicode qual +-- = parens (ppr_mono_lty pREC_TOP ty) + = ppr_mono_lty ctxt_prec ty unicode qual + +ppr_mono_ty ctxt_prec (HsDocTy ty _) unicode qual + = ppr_mono_lty ctxt_prec ty unicode qual + +ppr_mono_ty _ (HsTyLit n) _ _ = ppr_tylit n + +ppr_tylit :: HsTyLit -> Html +ppr_tylit (HsNumTy n) = toHtml (show n) +ppr_tylit (HsStrTy s) = toHtml (show s) + + +ppr_fun_ty :: Int -> LHsType DocName -> LHsType DocName -> Unicode -> Qualification -> Html +ppr_fun_ty ctxt_prec ty1 ty2 unicode qual + = let p1 = ppr_mono_lty pREC_FUN ty1 unicode qual + p2 = ppr_mono_lty pREC_TOP ty2 unicode qual + in + maybeParen ctxt_prec pREC_FUN $ + hsep [p1, arrow unicode <+> p2] diff --git a/haddock-api/src/Haddock/Backends/Xhtml/DocMarkup.hs b/haddock-api/src/Haddock/Backends/Xhtml/DocMarkup.hs new file mode 100644 index 00000000..5e27d9b0 --- /dev/null +++ b/haddock-api/src/Haddock/Backends/Xhtml/DocMarkup.hs @@ -0,0 +1,143 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Haddock.Backends.Html.DocMarkup +-- Copyright : (c) Simon Marlow 2003-2006, +-- David Waern 2006-2009, +-- Mark Lentczner 2010 +-- License : BSD-like +-- +-- Maintainer : haddock@projects.haskell.org +-- Stability : experimental +-- Portability : portable +----------------------------------------------------------------------------- +module Haddock.Backends.Xhtml.DocMarkup ( + docToHtml, + rdrDocToHtml, + origDocToHtml, + docToHtmlNoAnchors, + + docElement, docSection, docSection_, +) where + +import Control.Applicative ((<$>)) + +import Haddock.Backends.Xhtml.Names +import Haddock.Backends.Xhtml.Utils +import Haddock.Types +import Haddock.Utils +import Haddock.Doc (combineDocumentation) + +import Text.XHtml hiding ( name, p, quote ) +import Data.Maybe (fromMaybe) + +import GHC + +parHtmlMarkup :: Qualification -> Bool + -> (Bool -> a -> Html) -> DocMarkup a Html +parHtmlMarkup qual insertAnchors ppId = Markup { + markupEmpty = noHtml, + markupString = toHtml, + markupParagraph = paragraph, + markupAppend = (+++), + markupIdentifier = thecode . ppId insertAnchors, + markupIdentifierUnchecked = thecode . ppUncheckedLink qual, + markupModule = \m -> let (mdl,ref) = break (=='#') m + -- Accomodate for old style + -- foo\#bar anchors + mdl' = case reverse mdl of + '\\':_ -> init mdl + _ -> mdl + in ppModuleRef (mkModuleName mdl') ref, + markupWarning = thediv ! [theclass "warning"], + markupEmphasis = emphasize, + markupBold = strong, + markupMonospaced = thecode, + markupUnorderedList = unordList, + markupOrderedList = ordList, + markupDefList = defList, + markupCodeBlock = pre, + markupHyperlink = \(Hyperlink url mLabel) + -> if insertAnchors + then anchor ! [href url] + << fromMaybe url mLabel + else toHtml $ fromMaybe url mLabel, + markupAName = \aname -> namedAnchor aname << "", + markupPic = \(Picture uri t) -> image ! ([src uri] ++ fromMaybe [] (return . title <$> t)), + markupProperty = pre . toHtml, + markupExample = examplesToHtml, + markupHeader = \(Header l t) -> makeHeader l t + } + where + makeHeader :: Int -> Html -> Html + makeHeader 1 mkup = h1 mkup + makeHeader 2 mkup = h2 mkup + makeHeader 3 mkup = h3 mkup + makeHeader 4 mkup = h4 mkup + makeHeader 5 mkup = h5 mkup + makeHeader 6 mkup = h6 mkup + makeHeader l _ = error $ "Somehow got a header level `" ++ show l ++ "' in DocMarkup!" + + + examplesToHtml l = pre (concatHtml $ map exampleToHtml l) ! [theclass "screen"] + + exampleToHtml (Example expression result) = htmlExample + where + htmlExample = htmlPrompt +++ htmlExpression +++ toHtml (unlines result) + htmlPrompt = (thecode . toHtml $ ">>> ") ! [theclass "prompt"] + htmlExpression = (strong . thecode . toHtml $ expression ++ "\n") ! [theclass "userinput"] + + +-- 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 + 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 + where fmt = parHtmlMarkup qual False (ppDocName qual Raw) + +origDocToHtml :: Qualification -> Doc Name -> Html +origDocToHtml qual = markup fmt . cleanup + where fmt = parHtmlMarkup qual True (const $ ppName Raw) + + +rdrDocToHtml :: Qualification -> Doc RdrName -> Html +rdrDocToHtml qual = markup fmt . cleanup + where fmt = parHtmlMarkup qual True (const ppRdrName) + + +docElement :: (Html -> Html) -> Html -> Html +docElement el content_ = + if isNoHtml content_ + then el ! [theclass "doc empty"] << spaceHtml + else el ! [theclass "doc"] << content_ + + +docSection :: Qualification -> Documentation DocName -> Html +docSection qual = maybe noHtml (docSection_ qual) . combineDocumentation + + +docSection_ :: Qualification -> Doc DocName -> Html +docSection_ qual = (docElement thediv <<) . docToHtml qual + + +cleanup :: Doc a -> Doc a +cleanup = 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 + -- we have multiple paragraphs, then we want the extra whitespace to + -- separate them. So we catch the single paragraph case and transform it + -- here. We don't do this in code blocks as it eliminates line breaks. + unParagraph :: Doc a -> Doc a + unParagraph (DocParagraph d) = d + unParagraph doc = doc + + fmtUnParagraphLists :: DocMarkup a (Doc a) + fmtUnParagraphLists = idMarkup { + markupUnorderedList = DocUnorderedList . map unParagraph, + markupOrderedList = DocOrderedList . map unParagraph + } diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs b/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs new file mode 100644 index 00000000..e84a57b3 --- /dev/null +++ b/haddock-api/src/Haddock/Backends/Xhtml/Layout.hs @@ -0,0 +1,235 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Haddock.Backends.Html.Layout +-- Copyright : (c) Simon Marlow 2003-2006, +-- David Waern 2006-2009, +-- Mark Lentczner 2010 +-- License : BSD-like +-- +-- Maintainer : haddock@projects.haskell.org +-- Stability : experimental +-- Portability : portable +----------------------------------------------------------------------------- +module Haddock.Backends.Xhtml.Layout ( + miniBody, + + divPackageHeader, divContent, divModuleHeader, divFooter, + divTableOfContents, divDescription, divSynposis, divInterface, + divIndex, divAlphabet, divModuleList, + + sectionName, + nonEmptySectionName, + + shortDeclList, + shortSubDecls, + + divTopDecl, + + SubDecl, + subArguments, + subAssociatedTypes, + subConstructors, + subEquations, + subFields, + subInstances, + subMethods, + subMinimal, + + topDeclElem, declElem, +) where + + +import Haddock.Backends.Xhtml.DocMarkup +import Haddock.Backends.Xhtml.Types +import Haddock.Backends.Xhtml.Utils +import Haddock.Types +import Haddock.Utils (makeAnchorId) + +import qualified Data.Map as Map +import Text.XHtml hiding ( name, title, p, quote ) + +import FastString ( unpackFS ) +import GHC + + +-------------------------------------------------------------------------------- +-- * Sections of the document +-------------------------------------------------------------------------------- + + +miniBody :: Html -> Html +miniBody = body ! [identifier "mini"] + + +sectionDiv :: String -> Html -> Html +sectionDiv i = thediv ! [identifier i] + + +sectionName :: Html -> Html +sectionName = paragraph ! [theclass "caption"] + + +-- | Make an element that always has at least something (a non-breaking space). +-- If it would have otherwise been empty, then give it the class ".empty". +nonEmptySectionName :: Html -> Html +nonEmptySectionName c + | isNoHtml c = paragraph ! [theclass "caption empty"] $ spaceHtml + | otherwise = paragraph ! [theclass "caption"] $ c + + +divPackageHeader, divContent, divModuleHeader, divFooter, + divTableOfContents, divDescription, divSynposis, divInterface, + divIndex, divAlphabet, divModuleList + :: Html -> Html + +divPackageHeader = sectionDiv "package-header" +divContent = sectionDiv "content" +divModuleHeader = sectionDiv "module-header" +divFooter = sectionDiv "footer" +divTableOfContents = sectionDiv "table-of-contents" +divDescription = sectionDiv "description" +divSynposis = sectionDiv "synopsis" +divInterface = sectionDiv "interface" +divIndex = sectionDiv "index" +divAlphabet = sectionDiv "alphabet" +divModuleList = sectionDiv "module-list" + + +-------------------------------------------------------------------------------- +-- * Declaration containers +-------------------------------------------------------------------------------- + + +shortDeclList :: [Html] -> Html +shortDeclList items = ulist << map (li ! [theclass "src short"] <<) items + + +shortSubDecls :: Bool -> [Html] -> Html +shortSubDecls inst items = ulist ! [theclass c] << map (i <<) items + where i | inst = li ! [theclass "inst"] + | otherwise = li + c | inst = "inst" + | otherwise = "subs" + + +divTopDecl :: Html -> Html +divTopDecl = thediv ! [theclass "top"] + + +type SubDecl = (Html, Maybe (Doc DocName), [Html]) + + +divSubDecls :: (HTML a) => String -> a -> Maybe Html -> Html +divSubDecls cssClass captionName = maybe noHtml wrap + where + wrap = (subSection <<) . (subCaption +++) + subSection = thediv ! [theclass $ unwords ["subs", cssClass]] + subCaption = paragraph ! [theclass "caption"] << captionName + + +subDlist :: Qualification -> [SubDecl] -> Maybe Html +subDlist _ [] = Nothing +subDlist qual decls = Just $ dlist << map subEntry decls +++ clearDiv + where + subEntry (decl, mdoc, subs) = + dterm ! [theclass "src"] << decl + +++ + docElement ddef << (fmap (docToHtml qual) mdoc +++ subs) + + clearDiv = thediv ! [ theclass "clear" ] << noHtml + + +subTable :: Qualification -> [SubDecl] -> Maybe Html +subTable _ [] = Nothing +subTable qual decls = Just $ table << aboves (concatMap subRow decls) + where + subRow (decl, mdoc, subs) = + (td ! [theclass "src"] << decl + <-> + docElement td << fmap (docToHtml qual) mdoc) + : map (cell . (td <<)) subs + + +subBlock :: [Html] -> Maybe Html +subBlock [] = Nothing +subBlock hs = Just $ toHtml hs + + +subArguments :: Qualification -> [SubDecl] -> Html +subArguments qual = divSubDecls "arguments" "Arguments" . subTable qual + + +subAssociatedTypes :: [Html] -> Html +subAssociatedTypes = divSubDecls "associated-types" "Associated Types" . subBlock + + +subConstructors :: Qualification -> [SubDecl] -> Html +subConstructors qual = divSubDecls "constructors" "Constructors" . subTable qual + + +subFields :: Qualification -> [SubDecl] -> Html +subFields qual = divSubDecls "fields" "Fields" . subDlist qual + + +subEquations :: Qualification -> [SubDecl] -> Html +subEquations qual = divSubDecls "equations" "Equations" . subTable qual + + +subInstances :: Qualification -> String -> [SubDecl] -> Html +subInstances qual nm = maybe noHtml wrap . instTable + where + wrap = (subSection <<) . (subCaption +++) + instTable = fmap (thediv ! collapseSection id_ True [] <<) . subTable qual + subSection = thediv ! [theclass "subs instances"] + subCaption = paragraph ! collapseControl id_ True "caption" << "Instances" + id_ = makeAnchorId $ "i:" ++ nm + +subMethods :: [Html] -> Html +subMethods = divSubDecls "methods" "Methods" . subBlock + +subMinimal :: Html -> Html +subMinimal = divSubDecls "minimal" "Minimal complete definition" . Just . declElem + + +-- a box for displaying code +declElem :: Html -> Html +declElem = paragraph ! [theclass "src"] + + +-- 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) + where srcLink = let nameUrl = Map.lookup origPkg sourceMap + lineUrl = Map.lookup origPkg lineMap + mUrl | splice = lineUrl + -- Use the lineUrl as a backup + | otherwise = maybe lineUrl Just nameUrl in + case mUrl of + Nothing -> noHtml + Just url -> let url' = spliceURL (Just fname) (Just origMod) + (Just n) (Just loc) url + in anchor ! [href url', theclass "link"] << "Source" + + wikiLink = + case maybe_wiki_url of + Nothing -> noHtml + Just url -> let url' = spliceURL (Just fname) (Just mdl) + (Just n) (Just loc) url + in anchor ! [href url', theclass "link"] << "Comments" + + -- For source links, we want to point to the original module, + -- because only that will have the source. + -- 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? + + fname = case loc of + RealSrcSpan l -> unpackFS (srcSpanFile l) + UnhelpfulSpan _ -> error "topDeclElem UnhelpfulSpan" diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Names.hs b/haddock-api/src/Haddock/Backends/Xhtml/Names.hs new file mode 100644 index 00000000..cf12da40 --- /dev/null +++ b/haddock-api/src/Haddock/Backends/Xhtml/Names.hs @@ -0,0 +1,171 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Haddock.Backends.Html.Names +-- Copyright : (c) Simon Marlow 2003-2006, +-- David Waern 2006-2009, +-- Mark Lentczner 2010 +-- License : BSD-like +-- +-- Maintainer : haddock@projects.haskell.org +-- Stability : experimental +-- Portability : portable +----------------------------------------------------------------------------- +module Haddock.Backends.Xhtml.Names ( + ppName, ppDocName, ppLDocName, ppRdrName, ppUncheckedLink, + ppBinder, ppBinderInfix, ppBinder', + ppModule, ppModuleRef, ppIPName, linkId, Notation(..) +) where + + +import Haddock.Backends.Xhtml.Utils +import Haddock.GhcUtils +import Haddock.Types +import Haddock.Utils + +import Text.XHtml hiding ( name, title, p, quote ) +import qualified Data.Map as M +import qualified Data.List as List + +import GHC +import Name +import RdrName +import FastString (unpackFS) + + +-- | Indicator of how to render a 'DocName' into 'Html' +data Notation = Raw -- ^ Render as-is. + | Infix -- ^ Render using infix notation. + | Prefix -- ^ Render using prefix notation. + deriving (Eq, Show) + +ppOccName :: OccName -> Html +ppOccName = toHtml . occNameString + + +ppRdrName :: RdrName -> Html +ppRdrName = ppOccName . rdrNameOcc + +ppIPName :: HsIPName -> Html +ppIPName = toHtml . ('?':) . unpackFS . hsIPNameFS + + +ppUncheckedLink :: Qualification -> (ModuleName, OccName) -> Html +ppUncheckedLink _ (mdl, occ) = linkIdOcc' mdl (Just occ) << ppOccName occ -- TODO: apply ppQualifyName + + +-- The Bool indicates if it is to be rendered in infix notation +ppLDocName :: Qualification -> Notation -> Located DocName -> Html +ppLDocName qual notation (L _ d) = ppDocName qual notation True d + +ppDocName :: Qualification -> Notation -> Bool -> DocName -> Html +ppDocName qual notation insertAnchors docName = + case docName of + Documented name mdl -> + linkIdOcc mdl (Just (nameOccName name)) insertAnchors + << ppQualifyName qual notation name mdl + Undocumented name + | isExternalName name || isWiredInName name -> + ppQualifyName qual notation name (nameModule name) + | otherwise -> ppName notation name + +-- | Render a name depending on the selected qualification mode +ppQualifyName :: Qualification -> Notation -> Name -> Module -> Html +ppQualifyName qual notation name mdl = + case qual of + NoQual -> ppName notation name + FullQual -> ppFullQualName notation mdl name + LocalQual localmdl -> + if moduleString mdl == moduleString localmdl + then ppName notation name + else ppFullQualName notation mdl name + RelativeQual localmdl -> + case List.stripPrefix (moduleString localmdl) (moduleString mdl) of + -- local, A.x -> x + Just [] -> ppName notation name + -- sub-module, A.B.x -> B.x + Just ('.':m) -> toHtml $ m ++ '.' : getOccString name + -- some module with same prefix, ABC.x -> ABC.x + Just _ -> ppFullQualName notation mdl name + -- some other module, D.x -> D.x + Nothing -> ppFullQualName notation mdl name + AliasedQual aliases localmdl -> + case (moduleString mdl == moduleString localmdl, + M.lookup mdl aliases) of + (False, Just alias) -> ppQualName notation alias name + _ -> ppName notation name + + +ppFullQualName :: Notation -> Module -> Name -> Html +ppFullQualName notation mdl name = wrapInfix notation (getOccName name) qname + where + qname = toHtml $ moduleString mdl ++ '.' : getOccString name + +ppQualName :: Notation -> ModuleName -> Name -> Html +ppQualName notation mdlName name = wrapInfix notation (getOccName name) qname + where + qname = toHtml $ moduleNameString mdlName ++ '.' : getOccString name + +ppName :: Notation -> Name -> Html +ppName notation name = wrapInfix notation (getOccName name) $ toHtml (getOccString name) + + +ppBinder :: Bool -> OccName -> Html +-- The Bool indicates whether we are generating the summary, in which case +-- the binder will be a link to the full definition. +ppBinder True n = linkedAnchor (nameAnchorId n) << ppBinder' Prefix n +ppBinder False n = namedAnchor (nameAnchorId n) ! [theclass "def"] + << ppBinder' Prefix n + +ppBinderInfix :: Bool -> OccName -> Html +ppBinderInfix True n = linkedAnchor (nameAnchorId n) << ppBinder' Infix n +ppBinderInfix False n = namedAnchor (nameAnchorId n) ! [theclass "def"] + << ppBinder' Infix n + +ppBinder' :: Notation -> OccName -> Html +ppBinder' notation n = wrapInfix notation n $ ppOccName n + +wrapInfix :: Notation -> OccName -> Html -> Html +wrapInfix notation n = case notation of + Infix | is_star_kind -> id + | not is_sym -> quote + Prefix | is_star_kind -> id + | is_sym -> parens + _ -> id + where + is_sym = isSymOcc n + is_star_kind = isTcOcc n && occNameString n == "*" + +linkId :: Module -> Maybe Name -> Html -> Html +linkId mdl mbName = linkIdOcc mdl (fmap nameOccName mbName) True + + +linkIdOcc :: Module -> Maybe OccName -> Bool -> Html -> Html +linkIdOcc mdl mbName insertAnchors = + if insertAnchors + then anchor ! [href url] + else id + where + url = case mbName of + Nothing -> moduleUrl mdl + Just name -> moduleNameUrl mdl name + + +linkIdOcc' :: ModuleName -> Maybe OccName -> Html -> Html +linkIdOcc' mdl mbName = anchor ! [href url] + where + url = case mbName of + Nothing -> moduleHtmlFile' mdl + Just name -> moduleNameUrl' mdl name + + +ppModule :: Module -> Html +ppModule mdl = anchor ! [href (moduleUrl mdl)] + << toHtml (moduleString mdl) + + +ppModuleRef :: ModuleName -> String -> Html +ppModuleRef mdl ref = anchor ! [href (moduleHtmlFile' mdl ++ ref)] + << toHtml (moduleNameString mdl) + -- NB: The ref parameter already includes the '#'. + -- This function is only called from markupModule expanding a + -- DocModule, which doesn't seem to be ever be used. diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Themes.hs b/haddock-api/src/Haddock/Backends/Xhtml/Themes.hs new file mode 100644 index 00000000..79b093ec --- /dev/null +++ b/haddock-api/src/Haddock/Backends/Xhtml/Themes.hs @@ -0,0 +1,209 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Haddock.Backends.Html.Themes +-- Copyright : (c) Mark Lentczner 2010 +-- License : BSD-like +-- +-- Maintainer : haddock@projects.haskell.org +-- Stability : experimental +-- Portability : portable +----------------------------------------------------------------------------- +module Haddock.Backends.Xhtml.Themes ( + Themes, + getThemes, + + cssFiles, styleSheet + ) + where + +import Haddock.Options + +import Control.Applicative +import Control.Monad (liftM) +import Data.Char (toLower) +import Data.Either (lefts, rights) +import Data.List (nub) +import Data.Maybe (isJust, listToMaybe) + +import System.Directory +import System.FilePath +import Text.XHtml hiding ( name, title, p, quote, (</>) ) +import qualified Text.XHtml as XHtml + + +-------------------------------------------------------------------------------- +-- * CSS Themes +-------------------------------------------------------------------------------- + +data Theme = Theme { + themeName :: String, + themeHref :: String, + themeFiles :: [FilePath] + } + +type Themes = [Theme] + +type PossibleTheme = Either String Theme +type PossibleThemes = Either String Themes + + +-- | Find a theme by name (case insensitive match) +findTheme :: String -> Themes -> Maybe Theme +findTheme s = listToMaybe . filter ((== ls).lower.themeName) + where lower = map toLower + ls = lower s + + +-- | Standard theme used by default +standardTheme :: FilePath -> IO PossibleThemes +standardTheme libDir = liftM (liftEither (take 1)) (defaultThemes libDir) + + +-- | Default themes that are part of Haddock; added with --default-themes +-- The first theme in this list is considered the standard theme. +-- Themes are "discovered" by scanning the html sub-dir of the libDir, +-- and looking for directories with the extension .theme or .std-theme. +-- The later is, obviously, the standard theme. +defaultThemes :: FilePath -> IO PossibleThemes +defaultThemes libDir = do + themeDirs <- getDirectoryItems (libDir </> "html") + themes <- mapM directoryTheme $ discoverThemes themeDirs + return $ sequenceEither themes + where + discoverThemes paths = + filterExt ".std-theme" paths ++ filterExt ".theme" paths + filterExt ext = filter ((== ext).takeExtension) + + +-- | Build a theme from a single .css file +singleFileTheme :: FilePath -> IO PossibleTheme +singleFileTheme path = + if isCssFilePath path + then retRight $ Theme name file [path] + else errMessage "File extension isn't .css" path + where + name = takeBaseName path + file = takeFileName path + + +-- | Build a theme from a directory +directoryTheme :: FilePath -> IO PossibleTheme +directoryTheme path = do + items <- getDirectoryItems path + case filter isCssFilePath items of + [cf] -> retRight $ Theme (takeBaseName path) (takeFileName cf) items + [] -> errMessage "No .css file in theme directory" path + _ -> errMessage "More than one .css file in theme directory" path + + +-- | Check if we have a built in theme +doesBuiltInExist :: IO PossibleThemes -> String -> IO Bool +doesBuiltInExist pts s = fmap (either (const False) test) pts + where test = isJust . findTheme s + + +-- | Find a built in theme +builtInTheme :: IO PossibleThemes -> String -> IO PossibleTheme +builtInTheme pts s = either Left fetch <$> pts + where fetch = maybe (Left ("Unknown theme: " ++ s)) Right . findTheme s + + +-------------------------------------------------------------------------------- +-- * CSS Theme Arguments +-------------------------------------------------------------------------------- + +-- | Process input flags for CSS Theme arguments +getThemes :: FilePath -> [Flag] -> IO PossibleThemes +getThemes libDir flags = + liftM concatEither (mapM themeFlag flags) >>= someTheme + where + themeFlag :: Flag -> IO (Either String Themes) + themeFlag (Flag_CSS path) = (liftM . liftEither) (:[]) (theme path) + themeFlag (Flag_BuiltInThemes) = builtIns + themeFlag _ = retRight [] + + theme :: FilePath -> IO PossibleTheme + theme path = pick path + [(doesFileExist, singleFileTheme), + (doesDirectoryExist, directoryTheme), + (doesBuiltInExist builtIns, builtInTheme builtIns)] + "Theme not found" + + pick :: FilePath + -> [(FilePath -> IO Bool, FilePath -> IO PossibleTheme)] -> String + -> IO PossibleTheme + pick path [] msg = errMessage msg path + pick path ((test,build):opts) msg = do + pass <- test path + if pass then build path else pick path opts msg + + + someTheme :: Either String Themes -> IO (Either String Themes) + someTheme (Right []) = standardTheme libDir + someTheme est = return est + + builtIns = defaultThemes libDir + + +errMessage :: String -> FilePath -> IO (Either String a) +errMessage msg path = return (Left msg') + where msg' = "Error: " ++ msg ++ ": \"" ++ path ++ "\"\n" + + +retRight :: a -> IO (Either String a) +retRight = return . Right + + +-------------------------------------------------------------------------------- +-- * File Utilities +-------------------------------------------------------------------------------- + + +getDirectoryItems :: FilePath -> IO [FilePath] +getDirectoryItems path = + map (combine path) . filter notDot <$> getDirectoryContents path + where notDot s = s /= "." && s /= ".." + + +isCssFilePath :: FilePath -> Bool +isCssFilePath path = takeExtension path == ".css" + + +-------------------------------------------------------------------------------- +-- * Style Sheet Utilities +-------------------------------------------------------------------------------- + +cssFiles :: Themes -> [String] +cssFiles ts = nub $ concatMap themeFiles ts + + +styleSheet :: Themes -> Html +styleSheet ts = toHtml $ zipWith mkLink rels ts + where + rels = "stylesheet" : repeat "alternate stylesheet" + mkLink aRel t = + thelink + ! [ href (themeHref t), rel aRel, thetype "text/css", + XHtml.title (themeName t) + ] + << noHtml + +-------------------------------------------------------------------------------- +-- * Either Utilities +-------------------------------------------------------------------------------- + +-- These three routines are here because Haddock does not have access to the +-- Control.Monad.Error module which supplies the Functor and Monad instances +-- for Either String. + +sequenceEither :: [Either a b] -> Either a [b] +sequenceEither es = maybe (Right $ rights es) Left (listToMaybe (lefts es)) + + +liftEither :: (b -> c) -> Either a b -> Either a c +liftEither f = either Left (Right . f) + + +concatEither :: [Either a [b]] -> Either a [b] +concatEither = liftEither concat . sequenceEither + diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Types.hs b/haddock-api/src/Haddock/Backends/Xhtml/Types.hs new file mode 100644 index 00000000..122861c3 --- /dev/null +++ b/haddock-api/src/Haddock/Backends/Xhtml/Types.hs @@ -0,0 +1,37 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Haddock.Backends.Html.Types +-- Copyright : (c) Simon Marlow 2003-2006, +-- David Waern 2006-2009, +-- Mark Lentczner 2010 +-- License : BSD-like +-- +-- Maintainer : haddock@projects.haskell.org +-- Stability : experimental +-- Portability : portable +----------------------------------------------------------------------------- +module Haddock.Backends.Xhtml.Types ( + SourceURLs, WikiURLs, + LinksInfo, + Splice, + Unicode, +) where + + +import Data.Map +import GHC + + +-- 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 WikiURLs = (Maybe FilePath, Maybe FilePath, Maybe FilePath) + + +-- The URL for source and wiki links +type LinksInfo = (SourceURLs, WikiURLs) + +-- Whether something is a splice or not +type Splice = Bool + +-- Whether unicode syntax is to be used +type Unicode = Bool diff --git a/haddock-api/src/Haddock/Backends/Xhtml/Utils.hs b/haddock-api/src/Haddock/Backends/Xhtml/Utils.hs new file mode 100644 index 00000000..cbcbbd6d --- /dev/null +++ b/haddock-api/src/Haddock/Backends/Xhtml/Utils.hs @@ -0,0 +1,218 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Haddock.Backends.Html.Util +-- Copyright : (c) Simon Marlow 2003-2006, +-- David Waern 2006-2009, +-- Mark Lentczner 2010 +-- License : BSD-like +-- +-- Maintainer : haddock@projects.haskell.org +-- Stability : experimental +-- Portability : portable +----------------------------------------------------------------------------- +module Haddock.Backends.Xhtml.Utils ( + renderToString, + + namedAnchor, linkedAnchor, + spliceURL, + groupId, + + (<+>), (<=>), char, + keyword, punctuate, + + braces, brackets, pabrackets, parens, parenList, ubxParenList, + arrow, comma, dcolon, dot, darrow, equals, forallSymbol, quote, + + hsep, vcat, + + collapseSection, collapseToggle, collapseControl, +) where + + +import Haddock.GhcUtils +import Haddock.Utils + +import Data.Maybe + +import Text.XHtml hiding ( name, title, p, quote ) +import qualified Text.XHtml as XHtml + +import GHC ( SrcSpan(..), srcSpanStartLine, Name ) +import Module ( Module ) +import Name ( getOccString, nameOccName, isValOcc ) + + +spliceURL :: Maybe FilePath -> Maybe Module -> Maybe GHC.Name -> + Maybe SrcSpan -> String -> String +spliceURL maybe_file maybe_mod maybe_name maybe_loc = run + where + file = fromMaybe "" maybe_file + mdl = case maybe_mod of + Nothing -> "" + Just m -> moduleString m + + (name, kind) = + case maybe_name of + Nothing -> ("","") + Just n | isValOcc (nameOccName n) -> (escapeStr (getOccString n), "v") + | otherwise -> (escapeStr (getOccString n), "t") + + line = case maybe_loc of + Nothing -> "" + Just span_ -> + case span_ of + RealSrcSpan span__ -> + show $ srcSpanStartLine span__ + UnhelpfulSpan _ -> + error "spliceURL UnhelpfulSpan" + + run "" = "" + run ('%':'M':rest) = mdl ++ run rest + run ('%':'F':rest) = file ++ run rest + run ('%':'N':rest) = name ++ run rest + run ('%':'K':rest) = kind ++ run rest + run ('%':'L':rest) = line ++ run rest + run ('%':'%':rest) = '%' : run rest + + run ('%':'{':'M':'O':'D':'U':'L':'E':'}':rest) = mdl ++ run rest + run ('%':'{':'F':'I':'L':'E':'}':rest) = file ++ run rest + run ('%':'{':'N':'A':'M':'E':'}':rest) = name ++ run rest + run ('%':'{':'K':'I':'N':'D':'}':rest) = kind ++ run rest + + run ('%':'{':'M':'O':'D':'U':'L':'E':'/':'.':'/':c:'}':rest) = + map (\x -> if x == '.' then c else x) mdl ++ run rest + + run ('%':'{':'F':'I':'L':'E':'/':'/':'/':c:'}':rest) = + map (\x -> if x == '/' then c else x) file ++ run rest + + run ('%':'{':'L':'I':'N':'E':'}':rest) = line ++ run rest + + run (c:rest) = c : run rest + + +renderToString :: Bool -> Html -> String +renderToString debug html + | debug = renderHtml html + | otherwise = showHtml html + + +hsep :: [Html] -> Html +hsep [] = noHtml +hsep htmls = foldr1 (\a b -> a+++" "+++b) htmls + +-- | Concatenate a series of 'Html' values vertically, with linebreaks in between. +vcat :: [Html] -> Html +vcat [] = noHtml +vcat htmls = foldr1 (\a b -> a+++br+++b) htmls + + +infixr 8 <+> +(<+>) :: Html -> Html -> Html +a <+> b = a +++ sep +++ b + where + sep = if isNoHtml a || isNoHtml b then noHtml else toHtml " " + +-- | Join two 'Html' values together with a linebreak in between. +-- Has 'noHtml' as left identity. +infixr 8 <=> +(<=>) :: Html -> Html -> Html +a <=> b = a +++ sep +++ b + where + sep = if isNoHtml a then noHtml else br + + +keyword :: String -> Html +keyword s = thespan ! [theclass "keyword"] << toHtml s + + +equals, comma :: Html +equals = char '=' +comma = char ',' + + +char :: Char -> Html +char c = toHtml [c] + + +quote :: Html -> Html +quote h = char '`' +++ h +++ '`' + + +parens, brackets, pabrackets, braces :: Html -> Html +parens h = char '(' +++ h +++ char ')' +brackets h = char '[' +++ h +++ char ']' +pabrackets h = toHtml "[:" +++ h +++ toHtml ":]" +braces h = char '{' +++ h +++ char '}' + + +punctuate :: Html -> [Html] -> [Html] +punctuate _ [] = [] +punctuate h (d0:ds) = go d0 ds + where + go d [] = [d] + go d (e:es) = (d +++ h) : go e es + + +parenList :: [Html] -> Html +parenList = parens . hsep . punctuate comma + + +ubxParenList :: [Html] -> Html +ubxParenList = ubxparens . hsep . punctuate comma + + +ubxparens :: Html -> Html +ubxparens h = toHtml "(#" +++ h +++ toHtml "#)" + + +dcolon, arrow, darrow, forallSymbol :: Bool -> Html +dcolon unicode = toHtml (if unicode then "∷" else "::") +arrow unicode = toHtml (if unicode then "→" else "->") +darrow unicode = toHtml (if unicode then "⇒" else "=>") +forallSymbol unicode = if unicode then toHtml "∀" else keyword "forall" + + +dot :: Html +dot = toHtml "." + + +-- | Generate a named anchor +namedAnchor :: String -> Html -> Html +namedAnchor n = anchor ! [XHtml.name n] + + +linkedAnchor :: String -> Html -> Html +linkedAnchor n = anchor ! [href ('#':n)] + + +-- | generate an anchor identifier for a group +groupId :: String -> String +groupId g = makeAnchorId ("g:" ++ g) + +-- +-- A section of HTML which is collapsible. +-- + +-- | Attributes for an area that can be collapsed +collapseSection :: String -> Bool -> String -> [HtmlAttr] +collapseSection id_ state classes = [ identifier sid, theclass cs ] + where cs = unwords (words classes ++ [pick state "show" "hide"]) + sid = "section." ++ id_ + +-- | Attributes for an area that toggles a collapsed area +collapseToggle :: String -> [HtmlAttr] +collapseToggle id_ = [ strAttr "onclick" js ] + where js = "toggleSection('" ++ id_ ++ "')"; + +-- | Attributes for an area that toggles a collapsed area, +-- and displays a control. +collapseControl :: String -> Bool -> String -> [HtmlAttr] +collapseControl id_ state classes = + [ identifier cid, theclass cs ] ++ collapseToggle id_ + where cs = unwords (words classes ++ [pick state "collapser" "expander"]) + cid = "control." ++ id_ + + +pick :: Bool -> a -> a -> a +pick True t _ = t +pick False _ f = f diff --git a/haddock-api/src/Haddock/Convert.hs b/haddock-api/src/Haddock/Convert.hs new file mode 100644 index 00000000..73ff3f1a --- /dev/null +++ b/haddock-api/src/Haddock/Convert.hs @@ -0,0 +1,403 @@ +{-# LANGUAGE CPP, PatternGuards #-} +----------------------------------------------------------------------------- +-- | +-- Module : Haddock.Convert +-- Copyright : (c) Isaac Dupree 2009, +-- License : BSD-like +-- +-- Maintainer : haddock@projects.haskell.org +-- Stability : experimental +-- Portability : portable +-- +-- Conversion between TyThing and HsDecl. This functionality may be moved into +-- GHC at some point. +----------------------------------------------------------------------------- +module Haddock.Convert where +-- 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 Class +import TyCon +import CoAxiom +import ConLike +import DataCon +import PatSyn +import FamInstEnv +import BasicTypes ( TupleSort(..) ) +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 + + +-- the main function here! yay! +tyThingToLHsDecl :: TyThing -> LHsDecl Name +tyThingToLHsDecl t = noLoc $ 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 + -- instead of SigD if we wanted... + -- + -- 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) + + -- 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 + extractFamilyDecl _ = + error "tyThingToLHsDecl: impossible associated tycon" + + atTyClDecls = [synifyTyCon Nothing at_tc | (at_tc, _) <- classATItems cl] + atFamDecls = map extractFamilyDecl atTyClDecls in + TyClD $ ClassDecl + { tcdCtxt = synifyCtx (classSCTheta cl) + , tcdLName = synifyName cl + , tcdTyVars = synifyTyVars (classTyVars cl) + , tcdFDs = map (\ (l,r) -> noLoc + (map getName l, map getName r) ) $ + snd $ classTvsFds cl + , tcdSigs = noLoc (MinimalSig . 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 + , tcdATDefs = [] --ignore associated type defaults + , tcdDocs = [] --we don't have any docs at this point + , tcdFVs = placeHolderNames } + | otherwise + -> TyClD (synifyTyCon Nothing tc) + + -- type-constructors (e.g. Maybe) are complicated, put the definition + -- later in the file (also it's used for class associated-types too.) + ACoAxiom ax -> synifyAxiom ax + + -- a data-constructor alone just gets rendered as a function: + AConLike (RealDataCon dc) -> 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 + (synifyCtx req_theta) + (synifyCtx prov_theta) + +synifyAxBranch :: TyCon -> CoAxBranch -> TyFamInstEqn Name +synifyAxBranch tc (CoAxBranch { cab_tvs = tkvs, cab_lhs = args, cab_rhs = rhs }) + = let name = synifyName tc + 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 } + +synifyAxiom :: CoAxiom br -> HsDecl Name +synifyAxiom ax@(CoAxiom { co_ax_tc = tc }) + | isOpenSynFamilyTyCon tc + , Just branch <- coAxiomSingleBranch_maybe ax + = InstD (TyFamInstD (TyFamInstDecl { tfid_eqn = noLoc $ synifyAxBranch tc branch + , tfid_fvs = placeHolderNames })) + + | Just ax' <- isClosedSynFamilyTyCon_maybe tc + , getUnique ax' == getUnique ax -- without the getUniques, type error + = TyClD (synifyTyCon (Just ax) tc) + + | otherwise + = error "synifyAxiom: closed/open family confusion" + +synifyTyCon :: Maybe (CoAxiom br) -> TyCon -> TyClDecl Name +synifyTyCon coax tc + | isFunTyCon tc || isPrimTyCon tc + = 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) + (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 + -- algebraic data nor newtype: + , dd_ctxt = noLoc [] + , dd_cType = Nothing + , dd_kindSig = Just (synifyKindSig (tyConKind tc)) + -- we have their kind accurately: + , dd_cons = [] -- No constructors + , dd_derivs = Nothing } + , tcdFVs = placeHolderNames } + + | isSynFamilyTyCon tc + = case synTyConRhs_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 + , fdLName = synifyName tc + , fdTyVars = synifyTyVars (tyConTyVars tc) + , fdKindSig = Just (synifyKindSig (synTyConResKind tc)) }) + Nothing -> error "synifyTyCon: impossible open type synonym?" + + | isDataFamilyTyCon tc + = --(why no "isOpenAlgTyCon"?) + case algTyConRhs tc of + DataFamilyTyCon -> + 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" + | otherwise = + -- (closed) newtype and data + let + alg_nd = if isNewTyCon tc then NewType else DataType + alg_ctx = synifyCtx (tyConStupidTheta tc) + name = case coax of + Just a -> synifyName a -- Data families are named according to their + -- CoAxioms, not their TyCons + _ -> synifyName tc + tyvars = synifyTyVars (tyConTyVars tc) + kindSig = Just (tyConKind tc) + -- The data constructors. + -- + -- Any data-constructors not exported from the module that *defines* the + -- type will not (cannot) be included. + -- + -- Very simple constructors, Haskell98 with no existentials or anything, + -- probably look nicer in non-GADT syntax. In source code, all constructors + -- must be declared with the same (GADT vs. not) syntax, and it probably + -- is less confusing to follow that principle for the documentation as well. + -- + -- There is no sensible infix-representation for GADT-syntax constructor + -- declarations. They cannot be made in source code, but we could end up + -- with some here in the case where some constructors use existentials. + -- That seems like an acceptable compromise (they'll just be documented + -- 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) + -- "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_derivs = alg_deriv } + in DataDecl { tcdLName = name, tcdTyVars = tyvars, tcdDataDefn = defn + , tcdFVs = placeHolderNames } + +-- User beware: it is your responsibility to pass True (use_gadt_syntax) +-- for any constructor that would be misrepresented by omitting its +-- 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 $ + let + -- dataConIsInfix allegedly tells us whether it was declared with + -- infix *syntax*. + use_infix_syntax = dataConIsInfix dc + use_named_field_syntax = not (null field_tys) + name = synifyName dc + -- con_qvars means a different thing depending on gadt-syntax + (univ_tvs, ex_tvs, _eq_spec, theta, arg_tys, res_ty) = dataConFullSig dc + + qvars = if use_gadt_syntax + then synifyTyVars (univ_tvs ++ ex_tvs) + else synifyTyVars ex_tvs + + -- skip any EqTheta, use 'orig'inal syntax + ctx = synifyCtx theta + + 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 + _ -> 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) + (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 + (False,True) -> case linear_tys of + [a,b] -> InfixCon a b + _ -> error "synifyDataCon: infix with non-2 args?" + hs_res_ty = if use_gadt_syntax + then ResTyGADT (synifyType WithinType res_ty) + else ResTyH98 + -- finally we get synifyDataCon's result! + in ConDecl name Implicit{-we don't know nor care-} + qvars ctx hs_arg_tys hs_res_ty Nothing + False --we don't want any "deprecated GADT syntax" warnings! + + +synifyName :: NamedThing n => n -> Located Name +synifyName = noLoc . getName + + +synifyIdSig :: SynifyTypeState -> Id -> Sig Name +synifyIdSig s i = TypeSig [synifyName i] (synifyType s (varType i)) + + +synifyCtx :: [PredType] -> LHsContext Name +synifyCtx = noLoc . map (synifyType WithinType) + + +synifyTyVars :: [TyVar] -> LHsTyVarBndrs Name +synifyTyVars ktvs = HsQTvs { hsq_kvs = map tyVarName kvs + , hsq_tvs = map synifyTyVar tvs } + where + (kvs, tvs) = partition isKindVar ktvs + synifyTyVar tv + | isLiftedTypeKind kind = noLoc (UserTyVar name) + | otherwise = noLoc (KindedTyVar name (synifyKindSig kind)) + where + kind = tyVarKind tv + name = getName tv + +--states of what to do with foralls: +data SynifyTypeState + = WithinType + -- ^ normal situation. This is the safe one to use if you don't + -- quite understand what's going on. + | ImplicitizeForAll + -- ^ beginning of a function definition, in which, to make it look + -- less ugly, those rank-1 foralls are made implicit. + | DeleteTopLevelQuantification + -- ^ because in class methods the context is added to the type + -- (e.g. adding @forall a. Num a =>@ to @(+) :: a -> a -> a@) + -- which is rather sensible, + -- but we want to restore things to the source-syntax situation where + -- the defining class gets to quantify all its functions for free! + + +synifyType :: SynifyTypeState -> Type -> LHsType Name +synifyType _ (TyVarTy tv) = noLoc $ HsTyVar (getName tv) +synifyType _ (TyConApp tc tys) + -- Use non-prefix tuple syntax where possible, because it looks nicer. + | isTupleTyCon tc, tyConArity tc == length tys = + noLoc $ HsTupleTy (case tupleTyConSort tc of + BoxedTuple -> HsBoxedTuple + ConstraintTuple -> HsConstraintTuple + UnboxedTuple -> HsUnboxedTuple) + (map (synifyType WithinType) tys) + -- ditto for lists + | getName tc == listTyConName, [ty] <- tys = + noLoc $ HsListTy (synifyType WithinType ty) + -- ditto for implicit parameter tycons + | tyConName tc == ipClassName + , [name, ty] <- tys + , Just x <- isStrLitTy name + = noLoc $ HsIParamTy (HsIPName x) (synifyType WithinType ty) + -- and equalities + | tc == eqTyCon + , [ty1, ty2] <- tys + = noLoc $ HsEqTy (synifyType WithinType ty1) (synifyType WithinType ty2) + -- Most TyCons: + | otherwise = + foldl (\t1 t2 -> noLoc (HsAppTy t1 t2)) + (noLoc $ HsTyVar (getName tc)) + (map (synifyType WithinType) tys) +synifyType _ (AppTy t1 t2) = let + s1 = synifyType WithinType t1 + s2 = synifyType WithinType t2 + in noLoc $ HsAppTy s1 s2 +synifyType _ (FunTy t1 t2) = let + s1 = synifyType WithinType t1 + s2 = synifyType WithinType t2 + 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 +synifyType _ (LitTy t) = noLoc $ HsTyLit $ synifyTyLit t + +synifyTyLit :: TyLit -> HsTyLit +synifyTyLit (NumTyLit n) = HsNumTy n +synifyTyLit (StrTyLit s) = HsStrTy s + +synifyKindSig :: Kind -> LHsKind Name +synifyKindSig k = synifyType WithinType k + +synifyInstHead :: ([TyVar], [PredType], Class, [Type]) -> InstHead Name +synifyInstHead (_, preds, cls, types) = + ( getName cls + , map (unLoc . synifyType WithinType) ks + , map (unLoc . synifyType WithinType) ts + , ClassInst $ map (unLoc . synifyType WithinType) preds + ) + 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 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 + ) + where (ks,ts) = break (not . isKind) $ fi_tys fi diff --git a/haddock-api/src/Haddock/Doc.hs b/haddock-api/src/Haddock/Doc.hs new file mode 100644 index 00000000..91ad709f --- /dev/null +++ b/haddock-api/src/Haddock/Doc.hs @@ -0,0 +1,31 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} +module Haddock.Doc ( module Documentation.Haddock.Doc + , docCodeBlock + , combineDocumentation + ) where + +import Data.Maybe +import Documentation.Haddock.Doc +import Haddock.Types + +combineDocumentation :: Documentation name -> Maybe (Doc name) +combineDocumentation (Documentation Nothing Nothing) = Nothing +combineDocumentation (Documentation mDoc mWarning) = + Just (fromMaybe DocEmpty mWarning `docAppend` fromMaybe DocEmpty mDoc) + +-- Drop trailing whitespace from @..@ code blocks. Otherwise this: +-- +-- -- @ +-- -- foo +-- -- @ +-- +-- turns into (DocCodeBlock "\nfoo\n ") which when rendered in HTML +-- gives an extra vertical space after the code block. The single space +-- on the final line seems to trigger the extra vertical space. +-- +docCodeBlock :: DocH mod id -> DocH mod id +docCodeBlock (DocString s) + = DocString (reverse $ dropWhile (`elem` " \t") $ reverse s) +docCodeBlock (DocAppend l r) + = DocAppend l (docCodeBlock r) +docCodeBlock d = d diff --git a/haddock-api/src/Haddock/GhcUtils.hs b/haddock-api/src/Haddock/GhcUtils.hs new file mode 100644 index 00000000..c06b34a6 --- /dev/null +++ b/haddock-api/src/Haddock/GhcUtils.hs @@ -0,0 +1,304 @@ +{-# LANGUAGE FlexibleInstances, ViewPatterns #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +{-# OPTIONS_HADDOCK hide #-} +----------------------------------------------------------------------------- +-- | +-- Module : Haddock.GhcUtils +-- Copyright : (c) David Waern 2006-2009 +-- License : BSD-like +-- +-- Maintainer : haddock@projects.haskell.org +-- Stability : experimental +-- Portability : portable +-- +-- Utils for dealing with types from the GHC API +----------------------------------------------------------------------------- +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 Module +import RdrName (GlobalRdrEnv) +import GhcMonad (withSession) +import HscTypes +import UniqFM +import GHC +import Class + + +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 + Just mod_info -> return (mi_globals (hm_iface mod_info)) + _not_a_home_module -> return Nothing + + +isNameSym :: Name -> Bool +isNameSym = isSymOcc . nameOccName + + +isVarSym :: OccName -> Bool +isVarSym = isLexVarSym . occNameFS + +isConSym :: OccName -> Bool +isConSym = isLexConSym . occNameFS + + +getMainDeclBinder :: HsDecl name -> [name] +getMainDeclBinder (TyClD d) = [tcdName d] +getMainDeclBinder (ValD d) = + case collectHsBindBinders d of + [] -> [] + (name:_) -> [name] +getMainDeclBinder (SigD d) = sigNameNoLoc d +getMainDeclBinder (ForD (ForeignImport name _ _ _)) = [unLoc name] +getMainDeclBinder (ForD (ForeignExport _ _ _ _)) = [] +getMainDeclBinder _ = [] + +-- Extract the source location where an instance is defined. This is used +-- to correlate InstDecls with their Instance/CoAxiom Names, via the +-- instanceMap. +getInstLoc :: InstDecl name -> SrcSpan +getInstLoc (ClsInstD (ClsInstDecl { cid_poly_ty = L l _ })) = l +getInstLoc (DataFamInstD (DataFamInstDecl { dfid_tycon = L l _ })) = l +getInstLoc (TyFamInstD (TyFamInstDecl + -- 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 + +-- Useful when there is a signature with multiple names, e.g. +-- foo, bar :: Types.. +-- but only one of the names is exported and we have to change the +-- type signature to only include the exported names. +filterLSigNames :: (name -> Bool) -> LSig name -> Maybe (LSig name) +filterLSigNames p (L loc sig) = L loc <$> (filterSigNames p sig) + +filterSigNames :: (name -> Bool) -> Sig name -> Maybe (Sig name) +filterSigNames p orig@(SpecSig n _ _) = ifTrueJust (p $ unLoc n) orig +filterSigNames p orig@(InlineSig n _) = ifTrueJust (p $ unLoc n) orig +filterSigNames p orig@(FixSig (FixitySig n _)) = ifTrueJust (p $ unLoc n) orig +filterSigNames _ orig@(MinimalSig _) = Just orig +filterSigNames p (TypeSig ns ty) = + case filter (p . unLoc) ns of + [] -> Nothing + filtered -> Just (TypeSig filtered ty) +filterSigNames _ _ = Nothing + +ifTrueJust :: Bool -> name -> Maybe name +ifTrueJust True = Just +ifTrueJust False = const Nothing + +sigName :: LSig name -> [name] +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 _ = [] + + +isTyClD :: HsDecl a -> Bool +isTyClD (TyClD _) = True +isTyClD _ = False + + +isClassD :: HsDecl a -> Bool +isClassD (TyClD d) = isClassDecl d +isClassD _ = False + + +isDocD :: HsDecl a -> Bool +isDocD (DocD _) = True +isDocD _ = False + + +isInstD :: HsDecl a -> Bool +isInstD (InstD _) = True +isInstD _ = False + + +isValD :: HsDecl a -> Bool +isValD (ValD _) = True +isValD _ = False + + +declATs :: HsDecl a -> [a] +declATs (TyClD d) | isClassDecl d = map (unL . fdLName . unL) $ tcdATs d +declATs _ = [] + + +pretty :: Outputable a => DynFlags -> a -> String +pretty = showPpr + + +trace_ppr :: Outputable a => DynFlags -> a -> b -> b +trace_ppr dflags x y = trace (pretty dflags x) y + + +------------------------------------------------------------------------------- +-- * Located +------------------------------------------------------------------------------- + + +unL :: Located a -> a +unL (L _ x) = x + + +reL :: a -> Located a +reL = L undefined + + +before :: Located a -> Located a -> Bool +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 +------------------------------------------------------------------------------- + + +instance NamedThing (TyClDecl Name) where + getName = tcdName + + +instance NamedThing (ConDecl Name) where + getName = unL . con_name + + +------------------------------------------------------------------------------- +-- * Subordinates +------------------------------------------------------------------------------- + + +class Parent a where + children :: a -> [Name] + + +instance Parent (ConDecl Name) where + children con = + case con_details con of + RecCon fields -> map (unL . cd_fld_name) fields + _ -> [] + + +instance Parent (TyClDecl Name) where + children d + | isDataDecl d = map (unL . con_name . unL) . dd_cons . tcdDataDefn $ d + | isClassDecl d = + map (unL . fdLName . unL) (tcdATs d) ++ + [ unL n | L _ (TypeSig ns _) <- tcdSigs d, n <- ns ] + | otherwise = [] + + +-- | A parent and its children +family :: (NamedThing a, Parent a) => a -> (Name, [Name]) +family = getName &&& children + + +-- | 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)) + | isClassDecl d = [family d] + | otherwise = [] + + +-- | A mapping from child to parent +parentMap :: TyClDecl Name -> [(Name, Name)] +parentMap d = [ (c, p) | (p, cs) <- families d, c <- cs ] + + +-- | The parents of a subordinate in a declaration +parents :: Name -> HsDecl Name -> [Name] +parents n (TyClD d) = [ p | (c, p) <- parentMap d, c == n ] +parents _ _ = [] + + +------------------------------------------------------------------------------- +-- * Utils that work in monads defined by GHC +------------------------------------------------------------------------------- + + +modifySessionDynFlags :: (DynFlags -> DynFlags) -> Ghc () +modifySessionDynFlags f = do + dflags <- getSessionDynFlags + _ <- setSessionDynFlags (f dflags) + return () + + +-- | A variant of 'gbracket' where the return value from the first computation +-- is not required. +gbracket_ :: ExceptionMonad m => m a -> m b -> m c -> m c +gbracket_ before_ after thing = gbracket before_ (const after) (const thing) + +-- Extract the minimal complete definition of a Name, if one exists +minimalDef :: GhcMonad m => Name -> m (Maybe ClassMinimalDef) +minimalDef n = do + mty <- lookupGlobalName n + case mty of + Just (ATyCon (tyConClass_maybe -> Just c)) -> return . Just $ classMinimalDef c + _ -> return Nothing + +------------------------------------------------------------------------------- +-- * DynFlags +------------------------------------------------------------------------------- + + +setObjectDir, setHiDir, setStubDir, setOutputDir :: String -> DynFlags -> DynFlags +setObjectDir f d = d{ objectDir = Just f} +setHiDir f d = d{ hiDir = Just f} +setStubDir f d = d{ stubDir = Just f, includePaths = f : includePaths d } + -- -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 + diff --git a/haddock-api/src/Haddock/Interface.hs b/haddock-api/src/Haddock/Interface.hs new file mode 100644 index 00000000..60a20fe5 --- /dev/null +++ b/haddock-api/src/Haddock/Interface.hs @@ -0,0 +1,244 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Haddock.Interface +-- Copyright : (c) Simon Marlow 2003-2006, +-- David Waern 2006-2010, +-- Mateusz Kowalczyk 2013 +-- License : BSD-like +-- +-- Maintainer : haddock@projects.haskell.org +-- Stability : experimental +-- Portability : portable +-- +-- This module typechecks Haskell modules using the GHC API and processes +-- the result to create 'Interface's. The typechecking and the 'Interface' +-- creation is interleaved, so that when a module is processed, the +-- 'Interface's of all previously processed modules are available. The +-- creation of an 'Interface' from a typechecked module is delegated to +-- "Haddock.Interface.Create". +-- +-- When all modules have been typechecked and processed, information about +-- instances are attached to each 'Interface'. This task is delegated to +-- "Haddock.Interface.AttachInstances". Note that this is done as a separate +-- step because GHC can't know about all instances until all modules have been +-- typechecked. +-- +-- As a last step a link environment is built which maps names to the \"best\" +-- places to link to in the documentation, and all 'Interface's are \"renamed\" +-- using this environment. +----------------------------------------------------------------------------- +module Haddock.Interface ( + processModules +) where + + +import Haddock.GhcUtils +import Haddock.InterfaceFile +import Haddock.Interface.Create +import Haddock.Interface.AttachInstances +import Haddock.Interface.Rename +import Haddock.Options hiding (verbosity) +import Haddock.Types +import Haddock.Utils + +import Control.Monad +import Data.List +import qualified Data.Map as Map +import qualified Data.Set as Set +import Distribution.Verbosity +import System.Directory +import System.FilePath +import Text.Printf + +import Digraph +import DynFlags hiding (verbosity) +import Exception +import GHC hiding (verbosity) +import HscTypes +import FastString (unpackFS) + +-- | Create 'Interface's and a link environment by typechecking the list of +-- modules using the GHC API and processing the resulting syntax trees. +processModules + :: Verbosity -- ^ Verbosity of logging to 'stdout' + -> [String] -- ^ A list of file or module names sorted by + -- module topology + -> [Flag] -- ^ Command-line flags + -> [InterfaceFile] -- ^ Interface files of package dependencies + -> Ghc ([Interface], LinkEnv) -- ^ Resulting list of interfaces and renaming + -- environment +processModules verbosity modules flags extIfaces = do + + out verbosity verbose "Creating interfaces..." + let instIfaceMap = Map.fromList [ (instMod iface, iface) | ext <- extIfaces + , iface <- ifInstalledIfaces ext ] + interfaces <- createIfaces0 verbosity modules flags instIfaceMap + + let exportedNames = + Set.unions $ map (Set.fromList . ifaceExports) $ + filter (\i -> not $ OptHide `elem` ifaceOptions i) interfaces + mods = Set.fromList $ map ifaceMod interfaces + out verbosity verbose "Attaching instances..." + interfaces' <- attachInstances (exportedNames, mods) interfaces instIfaceMap + + out verbosity verbose "Building cross-linking environment..." + -- Combine the link envs of the external packages into one + let extLinks = Map.unions (map ifLinkEnv extIfaces) + homeLinks = buildHomeLinks interfaces -- Build the environment for the home + -- package + links = homeLinks `Map.union` extLinks + + out verbosity verbose "Renaming interfaces..." + let warnings = Flag_NoWarnings `notElem` flags + dflags <- getDynFlags + let (interfaces'', msgs) = + runWriter $ mapM (renameInterface dflags links warnings) interfaces' + liftIO $ mapM_ putStrLn msgs + + return (interfaces'', homeLinks) + + +-------------------------------------------------------------------------------- +-- * Module typechecking and Interface creation +-------------------------------------------------------------------------------- + + +createIfaces0 :: Verbosity -> [String] -> [Flag] -> InstIfaceMap -> Ghc [Interface] +createIfaces0 verbosity modules flags instIfaceMap = + -- Output dir needs to be set before calling depanal since depanal uses it to + -- compute output file names that are stored in the DynFlags of the + -- resulting ModSummaries. + (if useTempDir then withTempOutputDir else id) $ do + modGraph <- depAnalysis + if needsTemplateHaskell modGraph then do + modGraph' <- enableCompilation modGraph + createIfaces verbosity flags instIfaceMap modGraph' + else + createIfaces verbosity flags instIfaceMap modGraph + + where + useTempDir :: Bool + useTempDir = Flag_NoTmpCompDir `notElem` flags + + + withTempOutputDir :: Ghc a -> Ghc a + withTempOutputDir action = do + tmp <- liftIO getTemporaryDirectory + x <- liftIO getProcessID + let dir = tmp </> ".haddock-" ++ show x + modifySessionDynFlags (setOutputDir dir) + withTempDir dir action + + + depAnalysis :: Ghc ModuleGraph + depAnalysis = do + targets <- mapM (\f -> guessTarget f Nothing) modules + setTargets targets + depanal [] False + + + enableCompilation :: ModuleGraph -> Ghc ModuleGraph + enableCompilation modGraph = do + let enableComp d = let platform = targetPlatform d + in d { hscTarget = defaultObjectTarget platform } + modifySessionDynFlags enableComp + -- We need to update the DynFlags of the ModSummaries as well. + let upd m = m { ms_hspp_opts = enableComp (ms_hspp_opts m) } + let modGraph' = map upd modGraph + return modGraph' + + +createIfaces :: Verbosity -> [Flag] -> InstIfaceMap -> ModuleGraph -> Ghc [Interface] +createIfaces verbosity flags instIfaceMap mods = do + let sortedMods = flattenSCCs $ topSortModuleGraph False mods Nothing + out verbosity normal "Haddock coverage:" + (ifaces, _) <- foldM f ([], Map.empty) sortedMods + return (reverse ifaces) + where + f (ifaces, ifaceMap) modSummary = do + x <- processModule verbosity modSummary flags ifaceMap instIfaceMap + return $ case x of + Just iface -> (iface:ifaces, Map.insert (ifaceMod iface) iface ifaceMap) + Nothing -> (ifaces, ifaceMap) -- Boot modules don't generate ifaces. + + +processModule :: Verbosity -> ModSummary -> [Flag] -> IfaceMap -> InstIfaceMap -> Ghc (Maybe Interface) +processModule verbosity modsum flags modMap instIfaceMap = do + out verbosity verbose $ "Checking module " ++ moduleString (ms_mod modsum) ++ "..." + tm <- loadModule =<< typecheckModule =<< parseModule modsum + if not $ isBootSummary modsum then do + out verbosity verbose "Creating interface..." + (interface, msg) <- runWriterGhc $ createInterface tm flags modMap instIfaceMap + liftIO $ mapM_ putStrLn msg + dflags <- getDynFlags + let (haddockable, haddocked) = ifaceHaddockCoverage interface + percentage = round (fromIntegral haddocked * 100 / fromIntegral haddockable :: Double) :: Int + modString = moduleString (ifaceMod interface) + coverageMsg = printf " %3d%% (%3d /%3d) in '%s'" percentage haddocked haddockable modString + header = case ifaceDoc interface of + Documentation Nothing _ -> False + _ -> True + undocumentedExports = [ formatName s n | ExportDecl { expItemDecl = L s n + , expItemMbDoc = (Documentation Nothing _, _) + } <- ifaceExportItems interface ] + where + formatName :: SrcSpan -> HsDecl Name -> String + formatName loc n = p (getMainDeclBinder n) ++ case loc of + RealSrcSpan rss -> " (" ++ unpackFS (srcSpanFile rss) ++ ":" ++ show (srcSpanStartLine rss) ++ ")" + _ -> "" + + p [] = "" + p (x:_) = let n = pretty dflags x + ms = modString ++ "." + in if ms `isPrefixOf` n + then drop (length ms) n + else n + + out verbosity normal coverageMsg + when (Flag_PrintMissingDocs `elem` flags + && not (null undocumentedExports && header)) $ do + out verbosity normal " Missing documentation for:" + unless header $ out verbosity normal " Module header" + mapM_ (out verbosity normal . (" " ++)) undocumentedExports + interface' <- liftIO $ evaluate interface + return (Just interface') + else + return Nothing + + +-------------------------------------------------------------------------------- +-- * Building of cross-linking environment +-------------------------------------------------------------------------------- + + +-- | Build a mapping which for each original name, points to the "best" +-- place to link to in the documentation. For the definition of +-- "best", we use "the module nearest the bottom of the dependency +-- graph which exports this name", not including hidden modules. When +-- there are multiple choices, we pick a random one. +-- +-- The interfaces are passed in in topologically sorted order, but we start +-- by reversing the list so we can do a foldl. +buildHomeLinks :: [Interface] -> LinkEnv +buildHomeLinks ifaces = foldl upd Map.empty (reverse ifaces) + where + upd old_env iface + | OptHide `elem` ifaceOptions iface = old_env + | OptNotHome `elem` ifaceOptions iface = + foldl' keep_old old_env exported_names + | otherwise = foldl' keep_new old_env exported_names + where + exported_names = ifaceVisibleExports iface + mdl = ifaceMod iface + keep_old env n = Map.insertWith (\_ old -> old) n mdl env + keep_new env n = Map.insert n mdl env + + +-------------------------------------------------------------------------------- +-- * Utils +-------------------------------------------------------------------------------- + + +withTempDir :: (ExceptionMonad m, MonadIO m) => FilePath -> m a -> m a +withTempDir dir = gbracket_ (liftIO $ createDirectory dir) + (liftIO $ removeDirectoryRecursive dir) diff --git a/haddock-api/src/Haddock/Interface/AttachInstances.hs b/haddock-api/src/Haddock/Interface/AttachInstances.hs new file mode 100644 index 00000000..a0bac8fc --- /dev/null +++ b/haddock-api/src/Haddock/Interface/AttachInstances.hs @@ -0,0 +1,221 @@ +{-# LANGUAGE CPP, MagicHash #-} +----------------------------------------------------------------------------- +-- | +-- Module : Haddock.Interface.AttachInstances +-- Copyright : (c) Simon Marlow 2006, +-- David Waern 2006-2009, +-- Isaac Dupree 2009 +-- License : BSD-like +-- +-- Maintainer : haddock@projects.haskell.org +-- Stability : experimental +-- Portability : portable +----------------------------------------------------------------------------- +module Haddock.Interface.AttachInstances (attachInstances) where + + +import Haddock.Types +import Haddock.Convert +import Haddock.GhcUtils + +import Control.Arrow +import Data.List +import Data.Ord (comparing) +import Data.Function (on) +import qualified Data.Map as Map +import qualified Data.Set as Set + +import Class +import FamInstEnv +import FastString +import GHC +import GhcMonad (withSession) +import Id +import InstEnv +import MonadUtils (liftIO) +import Name +import PrelNames +import TcRnDriver (tcRnGetInfo) +import TcType (tcSplitSigmaTy) +import TyCon +import TypeRep +import TysPrim( funTyCon ) +import Var hiding (varName) +#define FSLIT(x) (mkFastString# (x#)) + +type ExportedNames = Set.Set Name +type Modules = Set.Set Module +type ExportInfo = (ExportedNames, Modules) + +-- Also attaches fixities +attachInstances :: ExportInfo -> [Interface] -> InstIfaceMap -> Ghc [Interface] +attachInstances expInfo ifaces instIfaceMap = mapM attach ifaces + where + -- TODO: take an IfaceMap as input + ifaceMap = Map.fromList [ (ifaceMod i, i) | i <- ifaces ] + + attach iface = do + newItems <- mapM (attachToExportItem expInfo iface ifaceMap instIfaceMap) + (ifaceExportItems iface) + return $ iface { ifaceExportItems = newItems } + + +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' + e -> return e + where + attachFixities e@ExportDecl{ expItemDecl = L _ d } = e { expItemFixities = + nubBy ((==) `on` fst) $ expItemFixities e ++ + [ (n',f) | n <- getMainDeclBinder d + , Just subs <- [instLookup instSubMap n iface ifaceMap instIfaceMap] + , n' <- n : subs + , Just f <- [instLookup instFixMap n' iface ifaceMap instIfaceMap] + ] } + + attachFixities e = e + + +instLookup :: (InstalledInterface -> Map.Map Name a) -> Name + -> Interface -> IfaceMap -> InstIfaceMap -> Maybe a +instLookup f name iface ifaceMap instIfaceMap = + case Map.lookup name (f $ toInstalledIface iface) of + res@(Just _) -> res + Nothing -> do + let ifaceMaps = Map.union (fmap toInstalledIface ifaceMap) instIfaceMap + iface' <- Map.lookup (nameModule name) ifaceMaps + Map.lookup name (f iface') + +-- | Like GHC's 'instanceHead' but drops "silent" arguments. +instanceHead' :: ClsInst -> ([TyVar], ThetaType, Class, [Type]) +instanceHead' ispec = (tvs, dropSilentArgs dfun theta, cls, tys) + where + dfun = is_dfun ispec + (tvs, cls, tys) = instanceHead ispec + (_, theta, _) = tcSplitSigmaTy (idType dfun) + +-- | Drop "silent" arguments. See GHC Note [Silent superclass +-- arguments]. +dropSilentArgs :: DFunId -> ThetaType -> ThetaType +dropSilentArgs dfun theta = drop (dfunNSilent dfun) theta + + +-- | 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 + (_msgs, r) <- liftIO $ tcRnGetInfo hsc_env name + return r + + +-------------------------------------------------------------------------------- +-- Collecting and sorting instances +-------------------------------------------------------------------------------- + + +-- | Simplified type for sorting types, ignoring qualification (not visible +-- in Haddock output) and unifying special tycons with normal ones. +-- For the benefit of the user (looks nice and predictable) and the +-- tests (which prefer output to be deterministic). +data SimpleType = SimpleType Name [SimpleType] + | SimpleTyLit TyLit + deriving (Eq,Ord) + + +instHead :: ([TyVar], [PredType], Class, [Type]) -> ([Int], Name, [SimpleType]) +instHead (_, _, cls, args) + = (map argCount args, className cls, map simplify args) + +argCount :: Type -> Int +argCount (AppTy t _) = argCount t + 1 +argCount (TyConApp _ ts) = length ts +argCount (FunTy _ _ ) = 2 +argCount (ForAllTy _ t) = argCount t +argCount _ = 0 + +simplify :: Type -> SimpleType +simplify (ForAllTy _ t) = simplify t +simplify (FunTy t1 t2) = SimpleType funTyConName [simplify t1, simplify t2] +simplify (AppTy t1 t2) = SimpleType s (ts ++ [simplify t2]) + where (SimpleType s ts) = simplify t1 +simplify (TyVarTy v) = SimpleType (tyVarName v) [] +simplify (TyConApp tc ts) = SimpleType (tyConName tc) (map simplify ts) +simplify (LitTy l) = SimpleTyLit l + +-- Used for sorting +instFam :: FamInst -> ([Int], Name, [SimpleType], Int, SimpleType) +instFam FamInst { fi_fam = n, fi_tys = ts, fi_rhs = t } + = (map argCount ts, n, map simplify ts, argCount t, simplify t) + + +funTyConName :: Name +funTyConName = mkWiredInName gHC_PRIM + (mkOccNameFS tcName FSLIT("(->)")) + funTyConKey + (ATyCon funTyCon) -- Relevant TyCon + BuiltInSyntax + +-------------------------------------------------------------------------------- +-- Filtering hidden instances +-------------------------------------------------------------------------------- + +-- | A class or data type is hidden iff +-- +-- * it is defined in one of the modules that are being processed +-- +-- * and it is not exported by any non-hidden module +isNameHidden :: ExportInfo -> Name -> Bool +isNameHidden (names, modules) name = + nameModule name `Set.member` modules && + not (name `Set.member` names) + +-- | We say that an instance is «hidden» iff its class or any (part) +-- of its type(s) is hidden. +isInstanceHidden :: ExportInfo -> Class -> [Type] -> Bool +isInstanceHidden expInfo cls tys = + instClassHidden || instTypeHidden + where + instClassHidden :: Bool + instClassHidden = isNameHidden expInfo $ getName cls + + instTypeHidden :: Bool + instTypeHidden = any (isTypeHidden expInfo) tys + +isTypeHidden :: ExportInfo -> Type -> Bool +isTypeHidden expInfo = typeHidden + where + typeHidden :: Type -> Bool + typeHidden t = + case t of + TyVarTy {} -> False + AppTy t1 t2 -> typeHidden t1 || typeHidden t2 + TyConApp tcon args -> nameHidden (getName tcon) || any typeHidden args + FunTy t1 t2 -> typeHidden t1 || typeHidden t2 + ForAllTy _ ty -> typeHidden ty + LitTy _ -> False + + nameHidden :: Name -> Bool + nameHidden = isNameHidden expInfo diff --git a/haddock-api/src/Haddock/Interface/Create.hs b/haddock-api/src/Haddock/Interface/Create.hs new file mode 100644 index 00000000..b66773ae --- /dev/null +++ b/haddock-api/src/Haddock/Interface/Create.hs @@ -0,0 +1,867 @@ +{-# LANGUAGE CPP, TupleSections, BangPatterns, LambdaCase #-} +{-# OPTIONS_GHC -Wwarn #-} +----------------------------------------------------------------------------- +-- | +-- Module : Haddock.Interface.Create +-- Copyright : (c) Simon Marlow 2003-2006, +-- David Waern 2006-2009, +-- Mateusz Kowalczyk 2013 +-- License : BSD-like +-- +-- Maintainer : haddock@projects.haskell.org +-- Stability : experimental +-- Portability : portable +----------------------------------------------------------------------------- +module Haddock.Interface.Create (createInterface) where + +import Documentation.Haddock.Doc (docAppend) +import Haddock.Types +import Haddock.Options +import Haddock.GhcUtils +import Haddock.Utils +import Haddock.Convert +import Haddock.Interface.LexParseRn + +import qualified Data.Map as M +import Data.Map (Map) +import Data.List +import Data.Maybe +import Data.Monoid +import Data.Ord +import Control.Applicative +import Control.Arrow (second) +import Control.DeepSeq +import Control.Monad +import Data.Function (on) +import qualified Data.Foldable as F + +import qualified Packages +import qualified Module +import qualified SrcLoc +import GHC +import HscTypes +import Name +import Bag +import RdrName +import TcRnTypes +import FastString (concatFS) + + +-- | Use a 'TypecheckedModule' to produce an 'Interface'. +-- To do this, we need access to already processed modules in the topological +-- sort. That's what's in the 'IfaceMap'. +createInterface :: TypecheckedModule -> [Flag] -> IfaceMap -> InstIfaceMap -> ErrMsgGhc Interface +createInterface tm flags modMap instIfaceMap = do + + let ms = pm_mod_summary . tm_parsed_module $ tm + mi = moduleInfo tm + L _ hsm = parsedSource tm + !safety = modInfoSafe mi + mdl = ms_mod ms + dflags = ms_hspp_opts ms + !instances = modInfoInstances mi + !fam_instances = md_fam_insts md + !exportedNames = modInfoExports mi + + (TcGblEnv {tcg_rdr_env = gre, tcg_warns = warnings}, md) = tm_internals_ tm + + -- The renamed source should always be available to us, but it's best + -- to be on the safe side. + (group_, mayExports, mayDocHeader) <- + case renamedSource tm of + Nothing -> do + liftErrMsg $ tell [ "Warning: Renamed source is not available." ] + return (emptyRnGroup, Nothing, Nothing) + Just (x, _, y, z) -> return (x, y, z) + + opts0 <- liftErrMsg $ mkDocOpts (haddockOptions dflags) flags mdl + let opts + | Flag_IgnoreAllExports `elem` flags = OptIgnoreExports : opts0 + | otherwise = opts0 + + (!info, mbDoc) <- liftErrMsg $ processModuleHeader dflags gre safety mayDocHeader + + let declsWithDocs = topDecls group_ + fixMap = mkFixMap group_ + (decls, _) = unzip declsWithDocs + localInsts = filter (nameIsLocalOrFrom mdl) $ map getName instances + ++ map getName fam_instances + -- Locations of all TH splices + splices = [ l | L l (SpliceD _) <- hsmodDecls hsm ] + + maps@(!docMap, !argMap, !subMap, !declMap, _) = + mkMaps dflags gre localInsts declsWithDocs + + let exports0 = fmap (reverse . map unLoc) mayExports + exports + | OptIgnoreExports `elem` opts = Nothing + | otherwise = exports0 + warningMap = mkWarningMap dflags warnings gre exportedNames + + let allWarnings = M.unions (warningMap : map ifaceWarningMap (M.elems modMap)) + + exportItems <- mkExportItems modMap mdl allWarnings gre exportedNames decls + maps fixMap splices exports instIfaceMap dflags + + let !visibleNames = mkVisibleNames maps exportItems opts + + -- Measure haddock documentation coverage. + let prunedExportItems0 = pruneExportItems exportItems + !haddockable = 1 + length exportItems -- module + exports + !haddocked = (if isJust mbDoc then 1 else 0) + length prunedExportItems0 + !coverage = (haddockable, haddocked) + + -- Prune the export list to just those declarations that have + -- documentation, if the 'prune' option is on. + let prunedExportItems' + | OptPrune `elem` opts = prunedExportItems0 + | otherwise = exportItems + !prunedExportItems = seqList prunedExportItems' `seq` prunedExportItems' + + let !aliases = + mkAliasMap dflags $ tm_renamed_source tm + modWarn = moduleWarning dflags gre warnings + + return $! Interface { + ifaceMod = mdl + , ifaceOrigFilename = msHsFilePath ms + , ifaceInfo = info + , ifaceDoc = Documentation mbDoc modWarn + , ifaceRnDoc = Documentation Nothing Nothing + , ifaceOptions = opts + , ifaceDocMap = docMap + , ifaceArgMap = argMap + , ifaceRnDocMap = M.empty + , ifaceRnArgMap = M.empty + , ifaceExportItems = prunedExportItems + , ifaceRnExportItems = [] + , ifaceExports = exportedNames + , ifaceVisibleExports = visibleNames + , ifaceDeclMap = declMap + , ifaceSubMap = subMap + , ifaceFixMap = fixMap + , ifaceModuleAliases = aliases + , ifaceInstances = instances + , ifaceFamInstances = fam_instances + , ifaceHaddockCoverage = coverage + , ifaceWarningMap = warningMap + } + +mkAliasMap :: DynFlags -> Maybe RenamedSource -> M.Map Module ModuleName +mkAliasMap dflags mRenamedSource = + case mRenamedSource of + Nothing -> M.empty + Just (_,impDecls,_,_) -> + M.fromList $ + mapMaybe (\(SrcLoc.L _ impDecl) -> do + alias <- ideclAs impDecl + return $ + (lookupModuleDyn dflags + (fmap Module.fsToPackageId $ + ideclPkgQual impDecl) + (case ideclName impDecl of SrcLoc.L _ name -> name), + alias)) + impDecls + +-- similar to GHC.lookupModule +lookupModuleDyn :: + DynFlags -> Maybe PackageId -> ModuleName -> Module +lookupModuleDyn _ (Just pkgId) mdlName = + Module.mkModule pkgId mdlName +lookupModuleDyn dflags Nothing mdlName = + flip Module.mkModule mdlName $ + case filter snd $ + Packages.lookupModuleInAllPackages dflags mdlName of + (pkgId,_):_ -> Packages.packageConfigId pkgId + [] -> Module.mainPackageId + + +------------------------------------------------------------------------------- +-- Warnings +------------------------------------------------------------------------------- + +mkWarningMap :: DynFlags -> Warnings -> GlobalRdrEnv -> [Name] -> WarningMap +mkWarningMap dflags warnings gre exps = case warnings of + NoWarnings -> M.empty + WarnAll _ -> M.empty + WarnSome ws -> + let ws' = [ (n, w) | (occ, w) <- ws, elt <- lookupGlobalRdrEnv gre occ + , let n = gre_name elt, n `elem` exps ] + in M.fromList $ map (second $ parseWarning dflags gre) ws' + +moduleWarning :: DynFlags -> GlobalRdrEnv -> Warnings -> Maybe (Doc Name) +moduleWarning _ _ NoWarnings = Nothing +moduleWarning _ _ (WarnSome _) = Nothing +moduleWarning dflags gre (WarnAll w) = Just $ parseWarning dflags gre w + +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) + where + format x xs = DocWarning . DocParagraph . DocAppend (DocString x) + . processDocString dflags gre $ HsDocString xs + + +------------------------------------------------------------------------------- +-- Doc options +-- +-- Haddock options that are embedded in the source file +------------------------------------------------------------------------------- + + +mkDocOpts :: Maybe String -> [Flag] -> Module -> ErrMsgM [DocOption] +mkDocOpts mbOpts flags mdl = do + opts <- case mbOpts of + Just opts -> case words $ replace ',' ' ' opts of + [] -> tell ["No option supplied to DOC_OPTION/doc_option"] >> return [] + xs -> liftM catMaybes (mapM parseOption xs) + Nothing -> return [] + hm <- if Flag_HideModule (moduleString mdl) `elem` flags + then return $ OptHide : opts + else return opts + if Flag_ShowExtensions (moduleString mdl) `elem` flags + then return $ OptShowExtensions : hm + else return hm + + +parseOption :: String -> ErrMsgM (Maybe DocOption) +parseOption "hide" = return (Just OptHide) +parseOption "prune" = return (Just OptPrune) +parseOption "ignore-exports" = return (Just OptIgnoreExports) +parseOption "not-home" = return (Just OptNotHome) +parseOption "show-extensions" = return (Just OptShowExtensions) +parseOption other = tell ["Unrecognised option: " ++ other] >> return Nothing + + +-------------------------------------------------------------------------------- +-- Maps +-------------------------------------------------------------------------------- + + +type Maps = (DocMap Name, ArgMap Name, SubMap, DeclMap, InstMap) + +-- | Create 'Maps' by looping through the declarations. For each declaration, +-- find its names, its subordinates, and its doc strings. Process doc strings +-- into 'Doc's. +mkMaps :: DynFlags + -> GlobalRdrEnv + -> [Name] + -> [(LHsDecl Name, [HsDocString])] + -> Maps +mkMaps dflags gre instances decls = + let (a, b, c, d) = unzip4 $ map mappings decls + in (f' $ map (nubBy ((==) `on` fst)) a , f b, f c, f d, instanceMap) + where + 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 + + mappings :: (LHsDecl Name, [HsDocString]) + -> ( [(Name, Doc Name)] + , [(Name, Map Int (Doc 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)) + declDoc strs m = + let doc' = processDocStrings dflags gre strs + m' = M.map (processDocStringParas dflags gre) m + in (doc', m') + (doc, args) = declDoc docStrs (typeDocs decl) + subs :: [(Name, [HsDocString], Map Int HsDocString)] + subs = subordinates instanceMap decl + (subDocs, subArgs) = unzip $ map (\(_, strs, m) -> declDoc strs m) subs + ns = names l decl + subNs = [ n | (n, _, _) <- subs ] + dm = [ (n, d) | (n, Just d) <- zip ns (repeat doc) ++ zip subNs subDocs ] + am = [ (n, args) | n <- ns ] ++ zip subNs subArgs + sm = [ (n, subNs) | n <- ns ] + cm = [ (n, [ldecl]) | n <- ns ++ subNs ] + in seqList ns `seq` + seqList subNs `seq` + doc `seq` + seqList subDocs `seq` + seqList subArgs `seq` + (dm, am, sm, cm) + + instanceMap :: Map SrcSpan Name + instanceMap = M.fromList [ (getSrcSpan n, n) | n <- instances ] + + names :: SrcSpan -> HsDecl Name -> [Name] + names l (InstD d) = maybeToList (M.lookup loc instanceMap) -- See note [2]. + where loc = case d of + TyFamInstD _ -> l -- The CoAx's loc is the whole line, but only for TFs + _ -> getInstLoc d + names _ decl = getMainDeclBinder decl + +-- Note [2]: +------------ +-- We relate ClsInsts to InstDecls using the SrcSpans buried inside them. +-- That should work for normal user-written instances (from looking at GHC +-- sources). We can assume that commented instances are user-written. +-- This lets us relate Names (from ClsInsts) to comments (associated +-- with InstDecls). + + +-------------------------------------------------------------------------------- +-- Declarations +-------------------------------------------------------------------------------- + + +-- | Get all subordinate declarations inside a declaration, and their docs. +subordinates :: InstMap -> HsDecl Name -> [(Name, [HsDocString], Map Int HsDocString)] +subordinates instMap decl = case decl of + InstD (ClsInstD d) -> do + DataFamInstDecl { dfid_tycon = L l _ + , dfid_defn = def } <- unLoc <$> cid_datafam_insts d + [ (n, [], M.empty) | Just n <- [M.lookup l instMap] ] ++ dataSubs def + + InstD (DataFamInstD d) -> dataSubs (dfid_defn d) + TyClD d | isClassDecl d -> classSubs d + | isDataDecl d -> dataSubs (tcdDataDefn d) + _ -> [] + where + classSubs dd = [ (name, doc, typeDocs d) | (L _ d, doc) <- classDecls dd + , name <- getMainDeclBinder d, not (isValD d) + ] + 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 ] + fields = [ (unL n, maybeToList $ fmap unL doc, M.empty) + | RecCon flds <- map con_details cons + , ConDeclField n _ doc <- flds ] + +-- | 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 ] + 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 (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 + go _ _ = M.empty + + +-- | All the sub declarations of a class (that we handle), ordered by +-- source location, with documentation attached if it exists. +classDecls :: TyClDecl Name -> [(LHsDecl Name, [HsDocString])] +classDecls class_ = filterDecls . collectDocs . sortByLoc $ decls + 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_ + + +-- | The top-level declarations of a module that we care about, +-- ordered by source location, with documentation attached if it exists. +topDecls :: HsGroup Name -> [(LHsDecl Name, [HsDocString])] +topDecls = filterClasses . filterDecls . collectDocs . sortByLoc . ungroup + +-- | 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_ ] + + +-- | Take all declarations except pragmas, infix decls, rules from an 'HsGroup'. +ungroup :: HsGroup Name -> [LHsDecl Name] +ungroup group_ = + mkDecls (tyClGroupConcat . hs_tyclds) TyClD group_ ++ + mkDecls hs_derivds DerivD group_ ++ + mkDecls hs_defds DefD group_ ++ + mkDecls hs_fords ForD group_ ++ + 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" + + valbinds (ValBindsOut binds _) = concatMap bagToList . snd . unzip $ binds + valbinds _ = error "expected ValBindsOut" + + +-- | Take a field of declarations from a data structure and create HsDecls +-- using the given constructor +mkDecls :: (a -> [Located b]) -> (b -> c) -> a -> [Located c] +mkDecls field con struct = [ L loc (con decl) | L loc decl <- field struct ] + + +-- | Sort by source location +sortByLoc :: [Located a] -> [Located a] +sortByLoc = sortBy (comparing getLoc) + + +-------------------------------------------------------------------------------- +-- Filtering of declarations +-- +-- We filter out declarations that we don't intend to handle later. +-------------------------------------------------------------------------------- + + +-- | Filter out declarations that we don't handle in Haddock +filterDecls :: [(LHsDecl a, doc)] -> [(LHsDecl a, doc)] +filterDecls = filter (isHandled . unL . fst) + where + isHandled (ForD (ForeignImport {})) = True + isHandled (TyClD {}) = True + isHandled (InstD {}) = True + isHandled (SigD d) = isVanillaLSig (reL d) + isHandled (ValD _) = True + -- we keep doc declarations to be able to get at named docs + isHandled (DocD _) = True + isHandled _ = False + + +-- | Go through all class declarations and filter their sub-declarations +filterClasses :: [(LHsDecl a, doc)] -> [(LHsDecl a, doc)] +filterClasses decls = [ if isClassD d then (L loc (filterClass d), doc) else x + | x@(L loc d, doc) <- decls ] + where + filterClass (TyClD c) = + TyClD $ c { tcdSigs = filter (liftA2 (||) isVanillaLSig isMinimalLSig) $ tcdSigs c } + filterClass _ = error "expected TyClD" + + +-------------------------------------------------------------------------------- +-- Collect docs +-- +-- To be able to attach the right Haddock comment to the right declaration, +-- we sort the declarations by their SrcLoc and "collect" the docs for each +-- declaration. +-------------------------------------------------------------------------------- + + +-- | Collect docs and attach them to the right declarations. +collectDocs :: [LHsDecl a] -> [(LHsDecl a, [HsDocString])] +collectDocs = go Nothing [] + where + go Nothing _ [] = [] + go (Just prev) docs [] = finished prev docs [] + go prev docs (L _ (DocD (DocCommentNext str)) : ds) + | Nothing <- prev = go Nothing (str:docs) ds + | Just decl <- prev = finished decl docs (go Nothing [str] ds) + go prev docs (L _ (DocD (DocCommentPrev str)) : ds) = go prev (str:docs) ds + go Nothing docs (d:ds) = go (Just d) docs ds + go (Just prev) docs (d:ds) = finished prev docs (go (Just d) [] ds) + + finished decl docs rest = (decl, reverse docs) : rest + + +-- | Build the list of items that will become the documentation, from the +-- export list. At this point, the list of ExportItems is in terms of +-- original names. +-- +-- We create the export items even if the module is hidden, since they +-- might be useful when creating the export items for other modules. +mkExportItems + :: IfaceMap + -> Module -- this module + -> WarningMap + -> GlobalRdrEnv + -> [Name] -- exported names (orig) + -> [LHsDecl Name] + -> Maps + -> FixMap + -> [SrcSpan] -- splice locations + -> Maybe [IE Name] + -> InstIfaceMap + -> DynFlags + -> ErrMsgGhc [ExportItem Name] +mkExportItems + modMap thisMod warnings gre exportedNames decls + maps@(docMap, argMap, subMap, declMap, instMap) fixMap splices optExports instIfaceMap dflags = + case optExports of + 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) = + 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 + + lookupExport (IEDoc docStr) = return $ + return . ExportDoc $ processDocStringParas dflags gre docStr + + lookupExport (IEDocNamed str) = liftErrMsg $ + findNamedDoc str [ unL d | d <- decls ] >>= return . \case + Nothing -> [] + Just doc -> return . ExportDoc $ processDocStringParas dflags gre doc + + declWith :: Name -> ErrMsgGhc [ ExportItem Name ] + declWith t = + case findDecl t of + ([L l (ValD _)], (doc, _)) -> do + -- Top-level binding without type signature + export <- hiValExportItem dflags t doc (l `elem` splices) $ M.lookup t fixMap + return [export] + (ds, docs_) | decl : _ <- filter (not . isValD . unLoc) ds -> + let declNames = getMainDeclBinder (unL decl) + in case () of + _ + -- temp hack: we filter out separately exported ATs, since we haven't decided how + -- to handle them yet. We should really give an warning message also, and filter the + -- name out in mkVisibleNames... + | t `elem` declATs (unL decl) -> return [] + + -- We should not show a subordinate by itself if any of its + -- parents is also exported. See note [1]. + | t `notElem` declNames, + Just p <- find isExported (parents t $ unL decl) -> + do liftErrMsg $ tell [ + "Warning: " ++ moduleString thisMod ++ ": " ++ + pretty dflags (nameOccName t) ++ " is exported separately but " ++ + "will be documented under " ++ pretty dflags (nameOccName p) ++ + ". Consider exporting it together with its parent(s)" ++ + " for code clarity." ] + return [] + + -- normal case + | otherwise -> case decl of + -- A single signature might refer to many names, but we + -- create an export item for a single name only. So we + -- modify the signature to contain only that single name. + L loc (SigD sig) -> + -- fromJust is safe since we already checked in guards + -- that 't' is a name declared in this declaration. + let newDecl = L loc . SigD . fromJust $ filterSigNames (== t) sig + in return [ mkExportDecl t newDecl docs_ ] + + L loc (TyClD cl@ClassDecl{}) -> do + mdef <- liftGhcToErrMsgGhc $ minimalDef t + let sig = maybeToList $ fmap (noLoc . MinimalSig . fmap noLoc) mdef + return [ mkExportDecl t + (L loc $ TyClD cl { tcdSigs = sig ++ tcdSigs cl }) docs_ ] + + _ -> return [ mkExportDecl t decl docs_ ] + + -- Declaration from another package + ([], _) -> do + mayDecl <- hiDecl dflags t + case mayDecl of + Nothing -> return [ ExportNoDecl t [] ] + Just decl -> + -- We try to get the subs and docs + -- from the installed .haddock file for that package. + case M.lookup (nameModule t) instIfaceMap of + Nothing -> do + liftErrMsg $ tell + ["Warning: Couldn't find .haddock for export " ++ pretty dflags t] + let subs_ = [ (n, noDocForDecl) | (n, _, _) <- subordinates instMap (unLoc decl) ] + return [ mkExportDecl t decl (noDocForDecl, subs_) ] + Just iface -> + return [ mkExportDecl t decl (lookupDocs t warnings (instDocMap iface) (instArgMap iface) (instSubMap iface)) ] + + _ -> return [] + + + mkExportDecl :: Name -> LHsDecl Name -> (DocForDecl Name, [(Name, DocForDecl Name)]) -> ExportItem Name + mkExportDecl name decl (doc, subs) = decl' + where + decl' = ExportDecl (restrictTo sub_names (extractDecl name mdl decl)) doc subs' [] fixities False + mdl = nameModule name + subs' = filter (isExported . fst) subs + sub_names = map fst subs' + fixities = [ (n, f) | n <- name:sub_names, Just f <- [M.lookup n fixMap] ] + + + isExported = (`elem` exportedNames) + + + findDecl :: Name -> ([LHsDecl Name], (DocForDecl Name, [(Name, DocForDecl Name)])) + findDecl n + | m == thisMod, Just ds <- M.lookup n declMap = + (ds, lookupDocs n warnings docMap argMap subMap) + | Just iface <- M.lookup m modMap, Just ds <- M.lookup n (ifaceDeclMap iface) = + (ds, lookupDocs n warnings (ifaceDocMap iface) (ifaceArgMap iface) (ifaceSubMap iface)) + | otherwise = ([], (noDocForDecl, [])) + where + m = nameModule n + + +hiDecl :: DynFlags -> Name -> ErrMsgGhc (Maybe (LHsDecl Name)) +hiDecl dflags t = do + mayTyThing <- liftGhcToErrMsgGhc $ lookupName t + case mayTyThing of + Nothing -> do + liftErrMsg $ tell ["Warning: Not found in environment: " ++ pretty dflags t] + return Nothing + Just x -> return (Just (tyThingToLHsDecl x)) + + +hiValExportItem :: DynFlags -> Name -> DocForDecl Name -> Bool -> Maybe Fixity -> ErrMsgGhc (ExportItem Name) +hiValExportItem dflags name doc splice fixity = do + mayDecl <- hiDecl dflags name + case mayDecl of + Nothing -> return (ExportNoDecl name []) + Just decl -> return (ExportDecl decl doc [] [] fixities splice) + where + fixities = case fixity of + Just f -> [(name, f)] + Nothing -> [] + + +-- | Lookup docs for a declaration from maps. +lookupDocs :: Name -> WarningMap -> DocMap Name -> ArgMap Name -> SubMap -> (DocForDecl Name, [(Name, DocForDecl Name)]) +lookupDocs n warnings docMap argMap subMap = + let lookupArgDoc x = M.findWithDefault M.empty x argMap in + let doc = (lookupDoc n, lookupArgDoc n) in + let subs = M.findWithDefault [] n subMap in + let subDocs = [ (s, (lookupDoc s, lookupArgDoc s)) | s <- subs ] in + (doc, subDocs) + where + lookupDoc name = Documentation (M.lookup name docMap) (M.lookup name warnings) + + +-- | Return all export items produced by an exported module. That is, we're +-- interested in the exports produced by \"module B\" in such a scenario: +-- +-- > module A (module B) where +-- > import B (...) hiding (...) +-- +-- There are three different cases to consider: +-- +-- 1) B is hidden, in which case we return all its exports that are in scope in A. +-- 2) B is visible, but not all its exports are in scope in A, in which case we +-- only return those that are. +-- 3) B is visible and all its exports are in scope, in which case we return +-- a single 'ExportModule' item. +moduleExports :: Module -- ^ Module A + -> ModuleName -- ^ The real name of B, the exported module + -> DynFlags -- ^ The flags used when typechecking A + -> WarningMap + -> GlobalRdrEnv -- ^ The renaming environment used for A + -> [Name] -- ^ All the exports of A + -> [LHsDecl Name] -- ^ All the declarations in A + -> IfaceMap -- ^ Already created interfaces + -> InstIfaceMap -- ^ Interfaces in other packages + -> Maps + -> FixMap + -> [SrcSpan] -- ^ Locations of all TH splices + -> ErrMsgGhc [ExportItem Name] -- ^ Resulting export items +moduleExports thisMod expMod dflags warnings gre _exports decls ifaceMap instIfaceMap maps fixMap splices + | m == thisMod = fullModuleContents dflags warnings gre maps fixMap splices decls + | otherwise = + case M.lookup m ifaceMap of + Just iface + | OptHide `elem` ifaceOptions iface -> return (ifaceExportItems iface) + | otherwise -> return [ ExportModule m ] + + Nothing -> -- We have to try to find it in the installed interfaces + -- (external packages). + case M.lookup expMod (M.mapKeys moduleName instIfaceMap) of + Just iface -> return [ ExportModule (instMod iface) ] + Nothing -> do + liftErrMsg $ + tell ["Warning: " ++ pretty dflags thisMod ++ ": Could not find " ++ + "documentation for exported module: " ++ pretty dflags expMod] + return [] + where + m = mkModule packageId expMod + packageId = modulePackageId thisMod + + +-- Note [1]: +------------ +-- It is unnecessary to document a subordinate by itself at the top level if +-- any of its parents is also documented. Furthermore, if the subordinate is a +-- record field or a class method, documenting it under its parent +-- indicates its special status. +-- +-- A user might expect that it should show up separately, so we issue a +-- warning. It's a fine opportunity to also tell the user she might want to +-- export the subordinate through the parent export item for clarity. +-- +-- The code removes top-level subordinates also when the parent is exported +-- through a 'module' export. I think that is fine. +-- +-- (For more information, see Trac #69) + + +fullModuleContents :: DynFlags -> WarningMap -> GlobalRdrEnv -> Maps -> FixMap -> [SrcSpan] + -> [LHsDecl Name] -> ErrMsgGhc [ExportItem Name] +fullModuleContents dflags warnings gre (docMap, argMap, subMap, declMap, instMap) fixMap splices decls = + liftM catMaybes $ mapM mkExportItem (expandSig decls) + where + -- A type signature can have multiple names, like: + -- foo, bar :: Types.. + -- + -- We go through the list of declarations and expand type signatures, so + -- that every type signature has exactly one name! + expandSig :: [LHsDecl name] -> [LHsDecl name] + expandSig = foldr f [] + where + f :: LHsDecl name -> [LHsDecl name] -> [LHsDecl name] + f (L l (SigD (TypeSig names t))) xs = foldr (\n acc -> L l (SigD (TypeSig [n] t)) : acc) xs names + f (L l (SigD (GenericSig names t))) xs = foldr (\n acc -> L l (SigD (GenericSig [n] t)) : acc) xs names + f x xs = x : xs + + mkExportItem :: LHsDecl Name -> ErrMsgGhc (Maybe (ExportItem Name)) + mkExportItem (L _ (DocD (DocGroup lev docStr))) = do + return . Just . ExportGroup lev "" $ processDocString dflags gre docStr + mkExportItem (L _ (DocD (DocCommentNamed _ docStr))) = do + return . Just . ExportDoc $ processDocStringParas dflags gre docStr + mkExportItem (L l (ValD d)) + | name:_ <- collectHsBindBinders d, Just [L _ (ValD _)] <- M.lookup name declMap = + -- Top-level binding without type signature. + let (doc, _) = lookupDocs name warnings docMap argMap subMap in + fmap Just (hiValExportItem dflags name doc (l `elem` splices) $ M.lookup name fixMap) + | otherwise = return Nothing + mkExportItem decl@(L l (InstD d)) + | Just name <- M.lookup (getInstLoc d) instMap = + let (doc, subs) = lookupDocs name warnings docMap argMap subMap in + 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 + expDecl (L l (TyClD cl { tcdSigs = sig ++ sigs })) l name + mkExportItem decl@(L l d) + | name:_ <- getMainDeclBinder d = expDecl decl l name + | otherwise = return Nothing + + fixities name subs = [ (n,f) | n <- name : map fst subs + , Just f <- [M.lookup n fixMap] ] + + expDecl decl l name = return $ Just (ExportDecl decl doc subs [] (fixities name subs) (l `elem` splices)) + where (doc, subs) = lookupDocs name warnings docMap argMap subMap + + +-- | Sometimes the declaration we want to export is not the "main" declaration: +-- it might be an individual record selector or a class method. In these +-- cases we have to extract the required declaration (and somehow cobble +-- together a type signature for it...). +extractDecl :: Name -> Module -> LHsDecl Name -> LHsDecl Name +extractDecl name mdl decl + | name `elem` getMainDeclBinder (unLoc decl) = decl + | otherwise = + case unLoc decl of + TyClD d@ClassDecl {} -> + let matches = [ sig | sig <- tcdSigs d, name `elem` sigName sig, + isVanillaLSig sig ] -- TODO: document fixity + in case matches of + [s0] -> let (n, tyvar_names) = (tcdName d, getTyVars d) + L pos sig = extractClassDecl n tyvar_names s0 + in L pos (SigD sig) + _ -> error "internal: extractDecl (ClassDecl)" + TyClD d@DataDecl {} -> + let (n, tyvar_names) = (tcdName d, map toTypeNoLoc $ getTyVars d) + in SigD <$> extractRecSel name mdl n tyvar_names (dd_cons (tcdDataDefn d)) + InstD (DataFamInstD DataFamInstDecl { dfid_tycon = L _ n + , dfid_pats = HsWB { hswb_cts = tys } + , dfid_defn = defn }) -> + SigD <$> extractRecSel name mdl n tys (dd_cons defn) + 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 + , n == name + ] + in case matches of + [d0] -> extractDecl name mdl (noLoc . InstD $ DataFamInstD d0) + _ -> error "internal: extractDecl (ClsInstD)" + _ -> error "internal: extractDecl" + where + getTyVars = hsLTyVarLocNames . tyClDeclTyVars + + +toTypeNoLoc :: Located Name -> LHsType Name +toTypeNoLoc = noLoc . HsTyVar . unLoc + + +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))) + where + lctxt = noLoc . ctxt + ctxt preds = nlHsTyConApp c (map toTypeNoLoc tvs0) : preds +extractClassDecl _ _ _ = error "extractClassDecl: unexpected decl" + + +extractRecSel :: Name -> Module -> Name -> [LHsType Name] -> [LConDecl Name] + -> LSig Name +extractRecSel _ _ _ _ [] = error "extractRecSel: selector not found" + +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)))) + _ -> extractRecSel nm mdl t tvs rest + where + matching_fields flds = [ f | f@(ConDeclField n _ _) <- flds, unLoc n == nm ] + data_ty + | ResTyGADT ty <- con_res con = ty + | otherwise = foldl' (\x y -> noLoc (HsAppTy x y)) (noLoc (HsTyVar t)) tvs + + +-- | Keep export items with docs. +pruneExportItems :: [ExportItem Name] -> [ExportItem Name] +pruneExportItems = filter hasDoc + where + hasDoc (ExportDecl{expItemMbDoc = (Documentation d _, _)}) = isJust d + hasDoc _ = True + + +mkVisibleNames :: Maps -> [ExportItem Name] -> [DocOption] -> [Name] +mkVisibleNames (_, _, _, _, instMap) exports opts + | OptHide `elem` opts = [] + | otherwise = let ns = concatMap exportName exports + in seqList ns `seq` ns + where + exportName e@ExportDecl {} = name ++ subs + where subs = map fst (expItemSubDocs e) + name = case unLoc $ expItemDecl e of + InstD d -> maybeToList $ M.lookup (getInstLoc d) instMap + decl -> getMainDeclBinder decl + exportName ExportNoDecl {} = [] -- we don't count these as visible, since + -- we don't want links to go to them. + exportName _ = [] + +seqList :: [a] -> () +seqList [] = () +seqList (x : xs) = x `seq` seqList xs + +-- | Find a stand-alone documentation comment by its name. +findNamedDoc :: String -> [HsDecl Name] -> ErrMsgM (Maybe HsDocString) +findNamedDoc name = search + where + search [] = do + tell ["Cannot find documentation for: $" ++ name] + return Nothing + search (DocD (DocCommentNamed name' doc) : rest) + | name == name' = return (Just doc) + | otherwise = search rest + search (_other_decl : rest) = search rest diff --git a/haddock-api/src/Haddock/Interface/LexParseRn.hs b/haddock-api/src/Haddock/Interface/LexParseRn.hs new file mode 100644 index 00000000..f1021436 --- /dev/null +++ b/haddock-api/src/Haddock/Interface/LexParseRn.hs @@ -0,0 +1,146 @@ +{-# OPTIONS_GHC -Wwarn #-} +{-# LANGUAGE BangPatterns #-} + ----------------------------------------------------------------------------- +-- | +-- Module : Haddock.Interface.LexParseRn +-- Copyright : (c) Isaac Dupree 2009, +-- Mateusz Kowalczyk 2013 +-- License : BSD-like +-- +-- Maintainer : haddock@projects.haskell.org +-- Stability : experimental +-- Portability : portable +----------------------------------------------------------------------------- +module Haddock.Interface.LexParseRn + ( processDocString + , processDocStringParas + , processDocStrings + , processModuleHeader + ) where + +import Control.Applicative +import Data.IntSet (toList) +import Data.List +import Documentation.Haddock.Doc (docConcat) +import DynFlags (ExtensionFlag(..), languageExtensions) +import FastString +import GHC +import Haddock.Interface.ParseModuleHeader +import Haddock.Parser +import Haddock.Types +import Name +import Outputable (showPpr) +import RdrName + +processDocStrings :: DynFlags -> GlobalRdrEnv -> [HsDocString] -> Maybe (Doc Name) +processDocStrings dflags gre strs = + case docConcat $ map (processDocStringParas dflags gre) strs of + DocEmpty -> Nothing + x -> Just x + + +processDocStringParas :: DynFlags -> GlobalRdrEnv -> HsDocString -> Doc Name +processDocStringParas = process parseParas + + +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) + + +processModuleHeader :: DynFlags -> GlobalRdrEnv -> SafeHaskellMode -> Maybe LHsDocString + -> ErrMsgM (HaddockModInfo Name, Maybe (Doc Name)) +processModuleHeader dflags gre safety mayStr = do + (hmi, doc) <- + case mayStr of + Nothing -> return failure + Just (L _ (HsDocString fs)) -> do + let str = unpackFS fs + (hmi, doc) = parseModuleHeader dflags str + !descr = rename dflags gre <$> hmi_description hmi + hmi' = hmi { hmi_description = descr } + doc' = rename dflags gre doc + return (hmi', Just doc') + + let flags :: [ExtensionFlag] + -- We remove the flags implied by the language setting and we display the language instead + flags = map toEnum (toList $ extensionFlags dflags) \\ languageExtensions (language dflags) + return (hmi { hmi_safety = Just $ showPpr dflags safety + , hmi_language = language dflags + , hmi_extensions = flags + } , doc) + where + failure = (emptyHaddockModInfo, Nothing) + + +rename :: DynFlags -> GlobalRdrEnv -> Doc RdrName -> Doc Name +rename dflags gre = rn + where + rn d = case d of + DocAppend a b -> DocAppend (rn a) (rn b) + DocParagraph doc -> DocParagraph (rn doc) + DocIdentifier x -> do + let choices = dataTcOccs' x + let names = concatMap (\c -> map gre_name (lookupGRE_RdrName c gre)) choices + case names of + [] -> + case choices of + [] -> DocMonospaced (DocString (showPpr dflags x)) + [a] -> outOfScope dflags a + a:b:_ | isRdrTc a -> outOfScope dflags a + | otherwise -> outOfScope dflags b + [a] -> DocIdentifier a + a:b:_ | isTyConName a -> DocIdentifier a | otherwise -> DocIdentifier b + -- If an id can refer to multiple things, we give precedence to type + -- constructors. + + DocWarning doc -> DocWarning (rn doc) + DocEmphasis doc -> DocEmphasis (rn doc) + DocBold doc -> DocBold (rn doc) + DocMonospaced doc -> DocMonospaced (rn doc) + DocUnorderedList docs -> DocUnorderedList (map rn docs) + DocOrderedList docs -> DocOrderedList (map rn docs) + DocDefList list -> DocDefList [ (rn a, rn b) | (a, b) <- list ] + DocCodeBlock doc -> DocCodeBlock (rn doc) + DocIdentifierUnchecked x -> DocIdentifierUnchecked x + DocModule str -> DocModule str + DocHyperlink l -> DocHyperlink l + DocPic str -> DocPic str + DocAName str -> DocAName str + DocProperty p -> DocProperty p + DocExamples e -> DocExamples e + DocEmpty -> DocEmpty + DocString str -> DocString str + DocHeader (Header l t) -> DocHeader $ Header l (rn t) + +dataTcOccs' :: RdrName -> [RdrName] +-- If the input is a data constructor, return both it and a type +-- constructor. This is useful when we aren't sure which we are +-- looking at. +-- +-- We use this definition instead of the GHC's to provide proper linking to +-- functions accross modules. See ticket #253 on Haddock Trac. +dataTcOccs' rdr_name + | isDataOcc occ = [rdr_name, rdr_name_tc] + | otherwise = [rdr_name] + where + occ = rdrNameOcc rdr_name + rdr_name_tc = setRdrNameSpace rdr_name tcName + + +outOfScope :: DynFlags -> RdrName -> Doc a +outOfScope dflags x = + case x of + Unqual occ -> monospaced occ + Qual mdl occ -> DocIdentifierUnchecked (mdl, occ) + Orig _ occ -> monospaced occ + Exact name -> monospaced name -- Shouldn't happen since x is out of scope + where + monospaced a = DocMonospaced (DocString (showPpr dflags a)) diff --git a/haddock-api/src/Haddock/Interface/ParseModuleHeader.hs b/haddock-api/src/Haddock/Interface/ParseModuleHeader.hs new file mode 100644 index 00000000..6848dc63 --- /dev/null +++ b/haddock-api/src/Haddock/Interface/ParseModuleHeader.hs @@ -0,0 +1,150 @@ +{-# OPTIONS_GHC -Wwarn #-} +----------------------------------------------------------------------------- +-- | +-- Module : Haddock.Interface.ParseModuleHeader +-- Copyright : (c) Simon Marlow 2006, Isaac Dupree 2009 +-- License : BSD-like +-- +-- Maintainer : haddock@projects.haskell.org +-- Stability : experimental +-- Portability : portable +----------------------------------------------------------------------------- +module Haddock.Interface.ParseModuleHeader (parseModuleHeader) where + +import Control.Applicative ((<$>)) +import Control.Monad (mplus) +import Data.Char +import DynFlags +import Haddock.Parser +import Haddock.Types +import RdrName + +-- ----------------------------------------------------------------------------- +-- Parsing module headers + +-- 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 dflags str0 = + let + getKey :: String -> String -> (Maybe String,String) + getKey key str = case parseKey key str of + Nothing -> (Nothing,str) + Just (value,rest) -> (Just value,rest) + + (_moduleOpt,str1) = getKey "Module" str0 + (descriptionOpt,str2) = getKey "Description" str1 + (copyrightOpt,str3) = getKey "Copyright" str2 + (licenseOpt,str4) = getKey "License" str3 + (licenceOpt,str5) = getKey "Licence" str4 + (maintainerOpt,str6) = getKey "Maintainer" str5 + (stabilityOpt,str7) = getKey "Stability" str6 + (portabilityOpt,str8) = getKey "Portability" str7 + + in (HaddockModInfo { + hmi_description = parseString dflags <$> descriptionOpt, + hmi_copyright = copyrightOpt, + hmi_license = licenseOpt `mplus` licenceOpt, + hmi_maintainer = maintainerOpt, + hmi_stability = stabilityOpt, + hmi_portability = portabilityOpt, + hmi_safety = Nothing, + hmi_language = Nothing, -- set in LexParseRn + hmi_extensions = [] -- also set in LexParseRn + }, parseParas dflags str8) + +-- | This function is how we read keys. +-- +-- all fields in the header are optional and have the form +-- +-- [spaces1][field name][spaces] ":" +-- [text]"\n" ([spaces2][space][text]"\n" | [spaces]"\n")* +-- where each [spaces2] should have [spaces1] as a prefix. +-- +-- Thus for the key "Description", +-- +-- > Description : this is a +-- > rather long +-- > +-- > description +-- > +-- > The module comment starts here +-- +-- the value will be "this is a .. description" and the rest will begin +-- at "The module comment". +parseKey :: String -> String -> Maybe (String,String) +parseKey key toParse0 = + do + let + (spaces0,toParse1) = extractLeadingSpaces toParse0 + + indentation = spaces0 + afterKey0 <- extractPrefix key toParse1 + let + afterKey1 = extractLeadingSpaces afterKey0 + afterColon0 <- case snd afterKey1 of + ':':afterColon -> return afterColon + _ -> Nothing + let + (_,afterColon1) = extractLeadingSpaces afterColon0 + + return (scanKey True indentation afterColon1) + where + scanKey :: Bool -> String -> String -> (String,String) + scanKey _ _ [] = ([],[]) + scanKey isFirst indentation str = + let + (nextLine,rest1) = extractNextLine str + + accept = isFirst || sufficientIndentation || allSpaces + + sufficientIndentation = case extractPrefix indentation nextLine of + Just (c:_) | isSpace c -> True + _ -> False + + allSpaces = case extractLeadingSpaces nextLine of + (_,[]) -> True + _ -> False + in + if accept + then + let + (scanned1,rest2) = scanKey False indentation rest1 + + scanned2 = case scanned1 of + "" -> if allSpaces then "" else nextLine + _ -> nextLine ++ "\n" ++ scanned1 + in + (scanned2,rest2) + else + ([],str) + + extractLeadingSpaces :: String -> (String,String) + extractLeadingSpaces [] = ([],[]) + extractLeadingSpaces (s@(c:cs)) + | isSpace c = + let + (spaces1,cs1) = extractLeadingSpaces cs + in + (c:spaces1,cs1) + | otherwise = ([],s) + + extractNextLine :: String -> (String,String) + extractNextLine [] = ([],[]) + extractNextLine (c:cs) + | c == '\n' = + ([],cs) + | otherwise = + let + (line,rest) = extractNextLine cs + in + (c:line,rest) + + -- comparison is case-insensitive. + extractPrefix :: String -> String -> Maybe String + extractPrefix [] s = Just s + extractPrefix _ [] = Nothing + extractPrefix (c1:cs1) (c2:cs2) + | toUpper c1 == toUpper c2 = extractPrefix cs1 cs2 + | otherwise = Nothing diff --git a/haddock-api/src/Haddock/Interface/Rename.hs b/haddock-api/src/Haddock/Interface/Rename.hs new file mode 100644 index 00000000..748e0210 --- /dev/null +++ b/haddock-api/src/Haddock/Interface/Rename.hs @@ -0,0 +1,506 @@ +---------------------------------------------------------------------------- +-- | +-- Module : Haddock.Interface.Rename +-- Copyright : (c) Simon Marlow 2003-2006, +-- David Waern 2006-2009 +-- License : BSD-like +-- +-- Maintainer : haddock@projects.haskell.org +-- Stability : experimental +-- Portability : portable +----------------------------------------------------------------------------- +module Haddock.Interface.Rename (renameInterface) where + + +import Data.Traversable (traverse) + +import Haddock.GhcUtils +import Haddock.Types + +import Bag (emptyBag) +import GHC hiding (NoLink) +import Name + +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) + + +renameInterface :: DynFlags -> LinkEnv -> Bool -> Interface -> ErrMsgM Interface +renameInterface dflags renamingEnv warnings iface = + + -- first create the local env, where every name exported by this module + -- is mapped to itself, and everything else comes from the global renaming + -- env + let localEnv = foldl fn renamingEnv (ifaceVisibleExports iface) + where fn env name = Map.insert name (ifaceMod iface) env + + -- rename names in the exported declarations to point to things that + -- are closer to, or maybe even exported by, the current module. + (renamedExportItems, missingNames1) + = runRnFM localEnv (renameExportItems (ifaceExportItems iface)) + + (rnDocMap, missingNames2) = runRnFM localEnv (mapM renameDoc (ifaceDocMap iface)) + + (rnArgMap, missingNames3) = runRnFM localEnv (mapM (mapM renameDoc) (ifaceArgMap iface)) + + (finalModuleDoc, missingNames4) + = runRnFM localEnv (renameDocumentation (ifaceDoc iface)) + + -- combine the missing names and filter out the built-ins, which would + -- otherwise allways be missing. + missingNames = nub $ filter isExternalName -- XXX: isExternalName filters out too much + (missingNames1 ++ missingNames2 ++ missingNames3 ++ missingNames4) + + -- filter out certain built in type constructors using their string + -- representation. TODO: use the Name constants from the GHC API. +-- strings = filter (`notElem` ["()", "[]", "(->)"]) +-- (map pretty missingNames) + strings = map (pretty dflags) . filter (\n -> not (isSystemName n || isBuiltInSyntax n)) $ missingNames + + in do + -- report things that we couldn't link to. Only do this for non-hidden + -- modules. + unless (OptHide `elem` ifaceOptions iface || null strings || not warnings) $ + tell ["Warning: " ++ moduleString (ifaceMod iface) ++ + ": could not find link destinations for:\n"++ + unwords (" " : strings) ] + + return $ iface { ifaceRnDoc = finalModuleDoc, + ifaceRnDocMap = rnDocMap, + ifaceRnArgMap = rnArgMap, + ifaceRnExportItems = renamedExportItems } + + +-------------------------------------------------------------------------------- +-- Monad for renaming +-- +-- The monad does two things for us: it passes around the environment for +-- renaming, and it returns a list of names which couldn't be found in +-- the environment. +-------------------------------------------------------------------------------- + + +newtype RnM a = + RnM { unRn :: (Name -> (Bool, DocName)) -- name lookup function + -> (a,[Name]) + } + +instance Monad RnM where + (>>=) = thenRn + return = returnRn + +instance Functor RnM where + fmap f x = do a <- x; return (f a) + +instance Applicative RnM where + pure = return + (<*>) = ap + +returnRn :: a -> RnM a +returnRn a = RnM (const (a,[])) +thenRn :: RnM a -> (a -> RnM b) -> RnM b +m `thenRn` k = RnM (\lkp -> case unRn m lkp of + (a,out1) -> case unRn (k a) lkp of + (b,out2) -> (b,out1++out2)) + +getLookupRn :: RnM (Name -> (Bool, DocName)) +getLookupRn = RnM (\lkp -> (lkp,[])) + +outRn :: Name -> RnM () +outRn name = RnM (const ((),[name])) + +lookupRn :: Name -> RnM DocName +lookupRn name = do + lkp <- getLookupRn + case lkp name of + (False,maps_to) -> do outRn name; return maps_to + (True, maps_to) -> return maps_to + + +runRnFM :: LinkEnv -> RnM a -> (a,[Name]) +runRnFM env rn = unRn rn lkp + where + lkp n = case Map.lookup n env of + Nothing -> (False, Undocumented n) + Just mdl -> (True, Documented n mdl) + + +-------------------------------------------------------------------------------- +-- Renaming +-------------------------------------------------------------------------------- + + +rename :: Name -> RnM DocName +rename = lookupRn + + +renameL :: Located Name -> RnM (Located DocName) +renameL = mapM rename + + +renameExportItems :: [ExportItem Name] -> RnM [ExportItem DocName] +renameExportItems = mapM renameExportItem + + +renameDocForDecl :: DocForDecl Name -> RnM (DocForDecl DocName) +renameDocForDecl (doc, fnArgsDoc) = + (,) <$> renameDocumentation doc <*> renameFnArgsDoc fnArgsDoc + + +renameDocumentation :: Documentation Name -> RnM (Documentation DocName) +renameDocumentation (Documentation mDoc mWarning) = + Documentation <$> mapM renameDoc mDoc <*> mapM renameDoc mWarning + + +renameLDocHsSyn :: LHsDocString -> RnM LHsDocString +renameLDocHsSyn = return + + +renameDoc :: Doc Name -> RnM (Doc DocName) +renameDoc = traverse rename + + +renameFnArgsDoc :: FnArgsDoc Name -> RnM (FnArgsDoc DocName) +renameFnArgsDoc = mapM renameDoc + + +renameLType :: LHsType Name -> RnM (LHsType DocName) +renameLType = mapM renameType + +renameLKind :: LHsKind Name -> RnM (LHsKind DocName) +renameLKind = renameLType + +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 + tyvars' <- renameLTyVarBndrs tyvars + lcontext' <- renameLContext lcontext + ltype' <- renameLType ltype + return (HsForAllTy expl tyvars' lcontext' ltype') + + HsTyVar n -> return . HsTyVar =<< rename n + HsBangTy b ltype -> return . HsBangTy b =<< renameLType ltype + + HsAppTy a b -> do + a' <- renameLType a + b' <- renameLType b + return (HsAppTy a' b') + + HsFunTy a b -> do + a' <- renameLType a + b' <- renameLType b + return (HsFunTy a' b') + + HsListTy ty -> return . HsListTy =<< renameLType ty + HsPArrTy ty -> return . HsPArrTy =<< renameLType ty + HsIParamTy n ty -> liftM (HsIParamTy n) (renameLType ty) + HsEqTy ty1 ty2 -> liftM2 HsEqTy (renameLType ty1) (renameLType ty2) + + HsTupleTy b ts -> return . HsTupleTy b =<< mapM renameLType ts + + HsOpTy a (w, L loc op) b -> do + op' <- rename op + a' <- renameLType a + b' <- renameLType b + return (HsOpTy a' (w, L loc op') b') + + HsParTy ty -> return . HsParTy =<< renameLType ty + + HsKindSig ty k -> do + ty' <- renameLType ty + k' <- renameLKind k + return (HsKindSig ty' k') + + HsDocTy ty doc -> do + ty' <- renameLType ty + doc' <- renameLDocHsSyn doc + return (HsDocTy ty' doc') + + HsTyLit x -> return (HsTyLit x) + + HsWrapTy a b -> HsWrapTy a <$> renameType b + HsRecTy a -> HsRecTy <$> mapM renameConDeclFieldField a + HsCoreTy a -> pure (HsCoreTy a) + HsExplicitListTy a b -> HsExplicitListTy a <$> mapM renameLType b + HsExplicitTupleTy a b -> HsExplicitTupleTy a <$> mapM renameLType b + HsQuasiQuoteTy a -> HsQuasiQuoteTy <$> renameHsQuasiQuote a + HsSpliceTy _ _ -> error "renameType: HsSpliceTy" + +renameHsQuasiQuote :: HsQuasiQuote Name -> RnM (HsQuasiQuote DocName) +renameHsQuasiQuote (HsQuasiQuote a b c) = HsQuasiQuote <$> rename a <*> pure b <*> pure c + +renameLTyVarBndrs :: LHsTyVarBndrs Name -> RnM (LHsTyVarBndrs DocName) +renameLTyVarBndrs (HsQTvs { hsq_kvs = _, hsq_tvs = tvs }) + = do { tvs' <- mapM renameLTyVarBndr tvs + ; return (HsQTvs { hsq_kvs = error "haddock:renameLTyVarBndrs", hsq_tvs = tvs' }) } + -- This is rather bogus, but I'm not sure what else to do + +renameLTyVarBndr :: LHsTyVarBndr Name -> RnM (LHsTyVarBndr DocName) +renameLTyVarBndr (L loc (UserTyVar n)) + = do { n' <- rename n + ; return (L loc (UserTyVar n')) } +renameLTyVarBndr (L loc (KindedTyVar n kind)) + = do { n' <- rename n + ; kind' <- renameLKind kind + ; return (L loc (KindedTyVar 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 + k' <- mapM renameType k + types' <- mapM renameType types + rest' <- case rest of + ClassInst cs -> ClassInst <$> mapM renameType cs + TypeInst ts -> TypeInst <$> traverse renameType ts + DataInst dd -> DataInst <$> renameTyClD dd + return (className', k', types', rest') + + +renameLDecl :: LHsDecl Name -> RnM (LHsDecl DocName) +renameLDecl (L loc d) = return . L loc =<< renameDecl d + + +renameDecl :: HsDecl Name -> RnM (HsDecl DocName) +renameDecl decl = case decl of + TyClD d -> do + d' <- renameTyClD d + return (TyClD d') + SigD s -> do + s' <- renameSig s + return (SigD s') + ForD d -> do + d' <- renameForD d + return (ForD d') + InstD d -> do + d' <- renameInstD d + return (InstD d') + _ -> error "renameDecl" + +renameLThing :: (a Name -> RnM (a DocName)) -> Located (a Name) -> RnM (Located (a DocName)) +renameLThing fn (L loc x) = return . L loc =<< fn x + +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 + lname' <- renameL lname + tyvars' <- renameLTyVarBndrs tyvars + rhs' <- renameLType rhs + return (SynDecl { tcdLName = lname', tcdTyVars = tyvars', tcdRhs = rhs', tcdFVs = fvs }) + + 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 }) + + ClassDecl { tcdCtxt = lcontext, tcdLName = lname, tcdTyVars = ltyvars + , tcdFDs = lfundeps, tcdSigs = lsigs, tcdATs = ats, tcdATDefs = at_defs } -> do + lcontext' <- renameLContext lcontext + lname' <- renameL lname + ltyvars' <- renameLTyVarBndrs ltyvars + lfundeps' <- mapM renameLFunDep lfundeps + lsigs' <- mapM renameLSig lsigs + ats' <- mapM (renameLThing renameFamilyDecl) ats + at_defs' <- mapM (mapM renameTyFamInstD) 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 + , tcdATs = ats', tcdATDefs = at_defs', tcdDocs = [], tcdFVs = placeHolderNames }) + + where + renameLFunDep (L loc (xs, ys)) = do + xs' <- mapM rename xs + ys' <- mapM rename ys + return (L loc (xs', ys')) + + renameLSig (L loc sig) = return . L loc =<< renameSig sig + +renameFamilyDecl :: FamilyDecl Name -> RnM (FamilyDecl DocName) +renameFamilyDecl (FamilyDecl { fdInfo = info, fdLName = lname + , fdTyVars = ltyvars, fdKindSig = tckind }) = do + info' <- renameFamilyInfo info + lname' <- renameL lname + ltyvars' <- renameLTyVarBndrs ltyvars + tckind' <- renameMaybeLKind tckind + return (FamilyDecl { fdInfo = info', fdLName = lname' + , fdTyVars = ltyvars', fdKindSig = tckind' }) + +renameFamilyInfo :: FamilyInfo Name -> RnM (FamilyInfo DocName) +renameFamilyInfo DataFamily = return DataFamily +renameFamilyInfo OpenTypeFamily = return OpenTypeFamily +renameFamilyInfo (ClosedTypeFamily eqns) + = do { eqns' <- mapM (renameLThing renameTyFamInstEqn) eqns + ; return $ ClosedTypeFamily eqns' } + +renameDataDefn :: HsDataDefn Name -> RnM (HsDataDefn DocName) +renameDataDefn (HsDataDefn { dd_ND = nd, dd_ctxt = lcontext, dd_cType = cType + , dd_kindSig = k, dd_cons = cons }) = do + lcontext' <- renameLContext lcontext + k' <- renameMaybeLKind k + cons' <- mapM (mapM renameCon) cons + -- I don't think we need the derivings, so we return Nothing + return (HsDataDefn { dd_ND = nd, dd_ctxt = lcontext', dd_cType = cType + , dd_kindSig = k', dd_cons = cons', dd_derivs = Nothing }) + +renameCon :: ConDecl Name -> RnM (ConDecl DocName) +renameCon decl@(ConDecl { con_name = lname, con_qvars = ltyvars + , con_cxt = lcontext, con_details = details + , con_res = restype, con_doc = mbldoc }) = do + lname' <- renameL lname + ltyvars' <- renameLTyVarBndrs ltyvars + lcontext' <- renameLContext lcontext + details' <- renameDetails details + restype' <- renameResType restype + mbldoc' <- mapM renameLDocHsSyn mbldoc + return (decl { con_name = lname', con_qvars = ltyvars', con_cxt = lcontext' + , con_details = details', con_res = restype', con_doc = mbldoc' }) + where + renameDetails (RecCon fields) = return . RecCon =<< mapM renameConDeclFieldField fields + renameDetails (PrefixCon ps) = return . PrefixCon =<< mapM renameLType ps + renameDetails (InfixCon a b) = do + a' <- renameLType a + b' <- renameLType b + return (InfixCon a' b') + + renameResType (ResTyH98) = return ResTyH98 + renameResType (ResTyGADT t) = return . ResTyGADT =<< renameLType t + + +renameConDeclFieldField :: ConDeclField Name -> RnM (ConDeclField DocName) +renameConDeclFieldField (ConDeclField name t doc) = do + name' <- renameL name + t' <- renameLType t + doc' <- mapM renameLDocHsSyn doc + return (ConDeclField name' t' doc') + + +renameSig :: Sig Name -> RnM (Sig DocName) +renameSig sig = case sig of + TypeSig lnames ltype -> do + lnames' <- mapM renameL lnames + ltype' <- renameLType ltype + return (TypeSig lnames' ltype') + PatSynSig lname args ltype lreq lprov -> 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 + 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 + -- we have filtered out all other kinds of signatures in Interface.Create + _ -> error "expected TypeSig" + + +renameForD :: ForeignDecl Name -> RnM (ForeignDecl DocName) +renameForD (ForeignImport lname ltype co x) = do + lname' <- renameL lname + ltype' <- renameLType ltype + return (ForeignImport lname' ltype' co x) +renameForD (ForeignExport lname ltype co x) = do + lname' <- renameL lname + ltype' <- renameLType ltype + return (ForeignExport lname' ltype' co x) + + +renameInstD :: InstDecl Name -> RnM (InstDecl DocName) +renameInstD (ClsInstD { cid_inst = d }) = do + d' <- renameClsInstD d + return (ClsInstD { cid_inst = d' }) +renameInstD (TyFamInstD { tfid_inst = d }) = do + d' <- renameTyFamInstD d + return (TyFamInstD { tfid_inst = d' }) +renameInstD (DataFamInstD { dfid_inst = d }) = do + d' <- renameDataFamInstD d + 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 + ltype' <- renameLType ltype + lATs' <- mapM (mapM renameTyFamInstD) lATs + lADTs' <- mapM (mapM renameDataFamInstD) lADTs + return (ClsInstDecl { 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 + ; 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 }) + = 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' }) } + +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' } + , dfid_defn = defn', dfid_fvs = placeHolderNames }) } + +renameExportItem :: ExportItem Name -> RnM (ExportItem DocName) +renameExportItem item = case item of + ExportModule mdl -> return (ExportModule mdl) + ExportGroup lev id_ doc -> do + doc' <- renameDoc doc + return (ExportGroup lev id_ doc') + ExportDecl decl doc subs instances fixities splice -> do + decl' <- renameLDecl decl + doc' <- renameDocForDecl doc + subs' <- mapM renameSub subs + instances' <- forM instances $ \(inst, idoc) -> do + inst' <- renameInstHead inst + idoc' <- mapM renameDoc idoc + return (inst', idoc') + fixities' <- forM fixities $ \(name, fixity) -> do + name' <- lookupRn name + return (name', fixity) + return (ExportDecl decl' doc' subs' instances' fixities' splice) + ExportNoDecl x subs -> do + x' <- lookupRn x + subs' <- mapM lookupRn subs + return (ExportNoDecl x' subs') + ExportDoc doc -> do + doc' <- renameDoc doc + return (ExportDoc doc') + + +renameSub :: (Name, DocForDecl Name) -> RnM (DocName, DocForDecl DocName) +renameSub (n,doc) = do + n' <- rename n + doc' <- renameDocForDecl doc + return (n', doc') diff --git a/haddock-api/src/Haddock/InterfaceFile.hs b/haddock-api/src/Haddock/InterfaceFile.hs new file mode 100644 index 00000000..bb997b9a --- /dev/null +++ b/haddock-api/src/Haddock/InterfaceFile.hs @@ -0,0 +1,636 @@ +{-# LANGUAGE CPP, RankNTypes, ScopedTypeVariables #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +----------------------------------------------------------------------------- +-- | +-- Module : Haddock.InterfaceFile +-- Copyright : (c) David Waern 2006-2009, +-- Mateusz Kowalczyk 2013 +-- License : BSD-like +-- +-- Maintainer : haddock@projects.haskell.org +-- Stability : experimental +-- Portability : portable +-- +-- Reading and writing the .haddock interface file +----------------------------------------------------------------------------- +module Haddock.InterfaceFile ( + InterfaceFile(..), ifPackageId, + readInterfaceFile, nameCacheFromGhc, freshNameCache, NameCacheAccessor, + writeInterfaceFile, binaryInterfaceVersion, binaryInterfaceVersionCompatibility +) where + + +import Haddock.Types +import Haddock.Utils hiding (out) + +import Control.Monad +import Data.Array +import Data.Functor ((<$>)) +import Data.IORef +import Data.List +import qualified Data.Map as Map +import Data.Map (Map) +import Data.Word + +import BinIface (getSymtabName, getDictFastString) +import Binary +import FastMutInt +import FastString +import GHC hiding (NoLink) +import GhcMonad (withSession) +import HscTypes +import IfaceEnv +import Name +import UniqFM +import UniqSupply +import Unique + + +data InterfaceFile = InterfaceFile { + ifLinkEnv :: LinkEnv, + ifInstalledIfaces :: [InstalledInterface] +} + + +ifPackageId :: InterfaceFile -> PackageId +ifPackageId if_ = + case ifInstalledIfaces if_ of + [] -> error "empty InterfaceFile" + iface:_ -> modulePackageId $ instMod iface + + +binaryInterfaceMagic :: Word32 +binaryInterfaceMagic = 0xD0Cface + + +-- IMPORTANT: Since datatypes in the GHC API might change between major +-- versions, and because we store GHC datatypes in our interface files, we need +-- to make sure we version our interface files accordingly. +-- +-- If you change the interface file format or adapt Haddock to work with a new +-- major version of GHC (so that the format changes indirectly) *you* need to +-- follow these steps: +-- +-- (1) increase `binaryInterfaceVersion` +-- +-- (2) set `binaryInterfaceVersionCompatibility` to [binaryInterfaceVersion] +-- +binaryInterfaceVersion :: Word16 +#if __GLASGOW_HASKELL__ == 708 +binaryInterfaceVersion = 25 + +binaryInterfaceVersionCompatibility :: [Word16] +binaryInterfaceVersionCompatibility = [binaryInterfaceVersion] +#else +#error Unsupported GHC version +#endif + + +initBinMemSize :: Int +initBinMemSize = 1024*1024 + + +writeInterfaceFile :: FilePath -> InterfaceFile -> IO () +writeInterfaceFile filename iface = do + bh0 <- openBinMem initBinMemSize + put_ bh0 binaryInterfaceMagic + put_ bh0 binaryInterfaceVersion + + -- remember where the dictionary pointer will go + dict_p_p <- tellBin bh0 + put_ bh0 dict_p_p + + -- remember where the symbol table pointer will go + symtab_p_p <- tellBin bh0 + put_ bh0 symtab_p_p + + -- Make some intial state + symtab_next <- newFastMutInt + writeFastMutInt symtab_next 0 + symtab_map <- newIORef emptyUFM + let bin_symtab = BinSymbolTable { + bin_symtab_next = symtab_next, + bin_symtab_map = symtab_map } + dict_next_ref <- newFastMutInt + writeFastMutInt dict_next_ref 0 + dict_map_ref <- newIORef emptyUFM + let bin_dict = BinDictionary { + bin_dict_next = dict_next_ref, + bin_dict_map = dict_map_ref } + + -- put the main thing + let bh = setUserData bh0 $ newWriteState (putName bin_symtab) + (putFastString bin_dict) + put_ bh iface + + -- write the symtab pointer at the front of the file + symtab_p <- tellBin bh + putAt bh symtab_p_p symtab_p + seekBin bh symtab_p + + -- write the symbol table itself + symtab_next' <- readFastMutInt symtab_next + symtab_map' <- readIORef symtab_map + putSymbolTable bh symtab_next' symtab_map' + + -- write the dictionary pointer at the fornt of the file + dict_p <- tellBin bh + putAt bh dict_p_p dict_p + seekBin bh dict_p + + -- write the dictionary itself + dict_next <- readFastMutInt dict_next_ref + dict_map <- readIORef dict_map_ref + putDictionary bh dict_next dict_map + + -- and send the result to the file + writeBinMem bh filename + return () + + +type NameCacheAccessor m = (m NameCache, NameCache -> m ()) + + +nameCacheFromGhc :: NameCacheAccessor Ghc +nameCacheFromGhc = ( read_from_session , write_to_session ) + where + read_from_session = do + ref <- withSession (return . hsc_NC) + liftIO $ readIORef ref + write_to_session nc' = do + ref <- withSession (return . hsc_NC) + liftIO $ writeIORef ref nc' + + +freshNameCache :: NameCacheAccessor IO +freshNameCache = ( create_fresh_nc , \_ -> return () ) + where + create_fresh_nc = do + u <- mkSplitUniqSupply 'a' -- ?? + return (initNameCache u []) + + +-- | Read a Haddock (@.haddock@) interface file. Return either an +-- 'InterfaceFile' or an error message. +-- +-- This function can be called in two ways. Within a GHC session it will +-- update the use and update the session's name cache. Outside a GHC session +-- a new empty name cache is used. The function is therefore generic in the +-- monad being used. The exact monad is whichever monad the first +-- argument, the getter and setter of the name cache, requires. +-- +readInterfaceFile :: forall m. + MonadIO m + => NameCacheAccessor m + -> FilePath + -> m (Either String InterfaceFile) +readInterfaceFile (get_name_cache, set_name_cache) filename = do + bh0 <- liftIO $ readBinMem filename + + magic <- liftIO $ get bh0 + version <- liftIO $ get bh0 + + case () of + _ | magic /= binaryInterfaceMagic -> return . Left $ + "Magic number mismatch: couldn't load interface file: " ++ filename + | version `notElem` binaryInterfaceVersionCompatibility -> return . Left $ + "Interface file is of wrong version: " ++ filename + | otherwise -> with_name_cache $ \update_nc -> do + + dict <- get_dictionary bh0 + + -- read the symbol table so we are capable of reading the actual data + bh1 <- do + let bh1 = setUserData bh0 $ newReadState (error "getSymtabName") + (getDictFastString dict) + symtab <- update_nc (get_symbol_table bh1) + return $ setUserData bh1 $ newReadState (getSymtabName (NCU (\f -> update_nc (return . f))) dict symtab) + (getDictFastString dict) + + -- load the actual data + iface <- liftIO $ get bh1 + return (Right iface) + where + with_name_cache :: forall a. + ((forall n b. MonadIO n + => (NameCache -> n (NameCache, b)) + -> n b) + -> m a) + -> m a + with_name_cache act = do + nc_var <- get_name_cache >>= (liftIO . newIORef) + x <- act $ \f -> do + nc <- liftIO $ readIORef nc_var + (nc', x) <- f nc + liftIO $ writeIORef nc_var nc' + return x + liftIO (readIORef nc_var) >>= set_name_cache + return x + + get_dictionary bin_handle = liftIO $ do + dict_p <- get bin_handle + data_p <- tellBin bin_handle + seekBin bin_handle dict_p + dict <- getDictionary bin_handle + seekBin bin_handle data_p + return dict + + get_symbol_table bh1 theNC = liftIO $ do + symtab_p <- get bh1 + data_p' <- tellBin bh1 + seekBin bh1 symtab_p + (nc', symtab) <- getSymbolTable bh1 theNC + seekBin bh1 data_p' + return (nc', symtab) + + +------------------------------------------------------------------------------- +-- * Symbol table +------------------------------------------------------------------------------- + + +putName :: BinSymbolTable -> BinHandle -> Name -> IO () +putName BinSymbolTable{ + bin_symtab_map = symtab_map_ref, + bin_symtab_next = symtab_next } bh name + = do + symtab_map <- readIORef symtab_map_ref + case lookupUFM symtab_map name of + Just (off,_) -> put_ bh (fromIntegral off :: Word32) + Nothing -> do + off <- readFastMutInt symtab_next + writeFastMutInt symtab_next (off+1) + writeIORef symtab_map_ref + $! addToUFM symtab_map name (off,name) + put_ bh (fromIntegral off :: Word32) + + +data BinSymbolTable = BinSymbolTable { + bin_symtab_next :: !FastMutInt, -- The next index to use + bin_symtab_map :: !(IORef (UniqFM (Int,Name))) + -- indexed by Name + } + + +putFastString :: BinDictionary -> BinHandle -> FastString -> IO () +putFastString BinDictionary { bin_dict_next = j_r, + bin_dict_map = out_r} bh f + = do + out <- readIORef out_r + let unique = getUnique f + case lookupUFM out unique of + Just (j, _) -> put_ bh (fromIntegral j :: Word32) + Nothing -> do + j <- readFastMutInt j_r + put_ bh (fromIntegral j :: Word32) + writeFastMutInt j_r (j + 1) + writeIORef out_r $! addToUFM out unique (j, f) + + +data BinDictionary = BinDictionary { + bin_dict_next :: !FastMutInt, -- The next index to use + bin_dict_map :: !(IORef (UniqFM (Int,FastString))) + -- indexed by FastString + } + + +putSymbolTable :: BinHandle -> Int -> UniqFM (Int,Name) -> IO () +putSymbolTable bh next_off symtab = do + put_ bh next_off + let names = elems (array (0,next_off-1) (eltsUFM symtab)) + mapM_ (\n -> serialiseName bh n symtab) names + + +getSymbolTable :: BinHandle -> NameCache -> IO (NameCache, Array Int Name) +getSymbolTable bh namecache = do + sz <- get bh + od_names <- replicateM sz (get bh) + let arr = listArray (0,sz-1) names + (namecache', names) = mapAccumR (fromOnDiskName arr) namecache od_names + return (namecache', arr) + + +type OnDiskName = (PackageId, ModuleName, OccName) + + +fromOnDiskName + :: Array Int Name + -> NameCache + -> OnDiskName + -> (NameCache, Name) +fromOnDiskName _ nc (pid, mod_name, occ) = + let + modu = mkModule pid mod_name + cache = nsNames nc + in + case lookupOrigNameCache cache modu occ of + Just name -> (nc, name) + Nothing -> + let + us = nsUniqs nc + u = uniqFromSupply us + name = mkExternalName u modu occ noSrcSpan + new_cache = extendNameCache cache modu occ name + in + case splitUniqSupply us of { (us',_) -> + ( nc{ nsUniqs = us', nsNames = new_cache }, name ) + } + + +serialiseName :: BinHandle -> Name -> UniqFM (Int,Name) -> IO () +serialiseName bh name _ = do + let modu = nameModule name + put_ bh (modulePackageId modu, moduleName modu, nameOccName name) + + +------------------------------------------------------------------------------- +-- * GhcBinary instances +------------------------------------------------------------------------------- + + +instance (Ord k, Binary k, Binary v) => Binary (Map k v) where + put_ bh m = put_ bh (Map.toList m) + get bh = fmap (Map.fromList) (get bh) + + +instance Binary InterfaceFile where + put_ bh (InterfaceFile env ifaces) = do + put_ bh env + put_ bh ifaces + + get bh = do + env <- get bh + ifaces <- get bh + return (InterfaceFile env ifaces) + + +instance Binary InstalledInterface where + put_ bh (InstalledInterface modu info docMap argMap + exps visExps opts subMap fixMap) = do + put_ bh modu + put_ bh info + put_ bh docMap + put_ bh argMap + put_ bh exps + put_ bh visExps + put_ bh opts + put_ bh subMap + put_ bh fixMap + + get bh = do + modu <- get bh + info <- get bh + docMap <- get bh + argMap <- get bh + exps <- get bh + visExps <- get bh + opts <- get bh + subMap <- get bh + fixMap <- get bh + + return (InstalledInterface modu info docMap argMap + exps visExps opts subMap fixMap) + + +instance Binary DocOption where + put_ bh OptHide = do + putByte bh 0 + put_ bh OptPrune = do + putByte bh 1 + put_ bh OptIgnoreExports = do + putByte bh 2 + put_ bh OptNotHome = do + putByte bh 3 + put_ bh OptShowExtensions = do + putByte bh 4 + get bh = do + h <- getByte bh + case h of + 0 -> do + return OptHide + 1 -> do + return OptPrune + 2 -> do + return OptIgnoreExports + 3 -> do + return OptNotHome + 4 -> do + return OptShowExtensions + _ -> fail "invalid binary data found" + + +instance Binary Example where + put_ bh (Example expression result) = do + put_ bh expression + put_ bh result + get bh = do + expression <- get bh + result <- get bh + return (Example expression result) + +instance Binary Hyperlink where + put_ bh (Hyperlink url label) = do + put_ bh url + put_ bh label + get bh = do + url <- get bh + label <- get bh + return (Hyperlink url label) + +instance Binary Picture where + put_ bh (Picture uri title) = do + put_ bh uri + put_ bh title + get bh = do + uri <- get bh + title <- get bh + return (Picture uri title) + +instance Binary a => Binary (Header a) where + put_ bh (Header l t) = do + put_ bh l + put_ bh t + get bh = do + l <- get bh + t <- get bh + return (Header l t) + +{-* Generated by DrIFT : Look, but Don't Touch. *-} +instance (Binary mod, Binary id) => Binary (DocH mod id) where + put_ bh DocEmpty = do + putByte bh 0 + put_ bh (DocAppend aa ab) = do + putByte bh 1 + put_ bh aa + put_ bh ab + put_ bh (DocString ac) = do + putByte bh 2 + put_ bh ac + put_ bh (DocParagraph ad) = do + putByte bh 3 + put_ bh ad + put_ bh (DocIdentifier ae) = do + putByte bh 4 + put_ bh ae + put_ bh (DocModule af) = do + putByte bh 5 + put_ bh af + put_ bh (DocEmphasis ag) = do + putByte bh 6 + put_ bh ag + put_ bh (DocMonospaced ah) = do + putByte bh 7 + put_ bh ah + put_ bh (DocUnorderedList ai) = do + putByte bh 8 + put_ bh ai + put_ bh (DocOrderedList aj) = do + putByte bh 9 + put_ bh aj + put_ bh (DocDefList ak) = do + putByte bh 10 + put_ bh ak + put_ bh (DocCodeBlock al) = do + putByte bh 11 + put_ bh al + put_ bh (DocHyperlink am) = do + putByte bh 12 + put_ bh am + put_ bh (DocPic x) = do + putByte bh 13 + put_ bh x + put_ bh (DocAName an) = do + putByte bh 14 + put_ bh an + put_ bh (DocExamples ao) = do + putByte bh 15 + put_ bh ao + put_ bh (DocIdentifierUnchecked x) = do + putByte bh 16 + put_ bh x + put_ bh (DocWarning ag) = do + putByte bh 17 + put_ bh ag + put_ bh (DocProperty x) = do + putByte bh 18 + put_ bh x + put_ bh (DocBold x) = do + putByte bh 19 + put_ bh x + put_ bh (DocHeader aa) = do + putByte bh 20 + put_ bh aa + + get bh = do + h <- getByte bh + case h of + 0 -> do + return DocEmpty + 1 -> do + aa <- get bh + ab <- get bh + return (DocAppend aa ab) + 2 -> do + ac <- get bh + return (DocString ac) + 3 -> do + ad <- get bh + return (DocParagraph ad) + 4 -> do + ae <- get bh + return (DocIdentifier ae) + 5 -> do + af <- get bh + return (DocModule af) + 6 -> do + ag <- get bh + return (DocEmphasis ag) + 7 -> do + ah <- get bh + return (DocMonospaced ah) + 8 -> do + ai <- get bh + return (DocUnorderedList ai) + 9 -> do + aj <- get bh + return (DocOrderedList aj) + 10 -> do + ak <- get bh + return (DocDefList ak) + 11 -> do + al <- get bh + return (DocCodeBlock al) + 12 -> do + am <- get bh + return (DocHyperlink am) + 13 -> do + x <- get bh + return (DocPic x) + 14 -> do + an <- get bh + return (DocAName an) + 15 -> do + ao <- get bh + return (DocExamples ao) + 16 -> do + x <- get bh + return (DocIdentifierUnchecked x) + 17 -> do + ag <- get bh + return (DocWarning ag) + 18 -> do + x <- get bh + return (DocProperty x) + 19 -> do + x <- get bh + return (DocBold x) + 20 -> do + aa <- get bh + return (DocHeader aa) + _ -> error "invalid binary data found in the interface file" + + +instance Binary name => Binary (HaddockModInfo name) where + put_ bh hmi = do + put_ bh (hmi_description hmi) + put_ bh (hmi_copyright hmi) + put_ bh (hmi_license hmi) + put_ bh (hmi_maintainer hmi) + put_ bh (hmi_stability hmi) + put_ bh (hmi_portability hmi) + put_ bh (hmi_safety hmi) + put_ bh (fromEnum <$> hmi_language hmi) + put_ bh (map fromEnum $ hmi_extensions hmi) + + get bh = do + descr <- get bh + copyr <- get bh + licen <- get bh + maint <- get bh + stabi <- get bh + porta <- get bh + safet <- get bh + langu <- fmap toEnum <$> get bh + exten <- map toEnum <$> get bh + return (HaddockModInfo descr copyr licen maint stabi porta safet langu exten) + +instance Binary DocName where + put_ bh (Documented name modu) = do + putByte bh 0 + put_ bh name + put_ bh modu + put_ bh (Undocumented name) = do + putByte bh 1 + put_ bh name + + get bh = do + h <- getByte bh + case h of + 0 -> do + name <- get bh + modu <- get bh + return (Documented name modu) + 1 -> do + name <- get bh + return (Undocumented name) + _ -> error "get DocName: Bad h" diff --git a/haddock-api/src/Haddock/ModuleTree.hs b/haddock-api/src/Haddock/ModuleTree.hs new file mode 100644 index 00000000..2a7fbfcc --- /dev/null +++ b/haddock-api/src/Haddock/ModuleTree.hs @@ -0,0 +1,56 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Haddock.ModuleTree +-- Copyright : (c) Simon Marlow 2003-2006, +-- David Waern 2006 +-- License : BSD-like +-- +-- Maintainer : haddock@projects.haskell.org +-- Stability : experimental +-- Portability : portable +----------------------------------------------------------------------------- +module Haddock.ModuleTree ( ModuleTree(..), mkModuleTree ) where + + +import Haddock.Types ( Doc ) + +import GHC ( Name ) +import Module ( Module, moduleNameString, moduleName, modulePackageId, + packageIdString ) + + +data ModuleTree = Node String Bool (Maybe String) (Maybe (Doc Name)) [ModuleTree] + + +mkModuleTree :: Bool -> [(Module, Maybe (Doc Name))] -> [ModuleTree] +mkModuleTree showPkgs mods = + foldr fn [] [ (splitModule mdl, modPkg mdl, short) | (mdl, short) <- mods ] + where + modPkg mod_ | showPkgs = Just (packageIdString (modulePackageId mod_)) + | otherwise = Nothing + fn (mod_,pkg,short) = addToTrees mod_ pkg short + + +addToTrees :: [String] -> Maybe String -> Maybe (Doc 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) + | s1 > s2 = t : addToTrees (s1:ss) pkg short ts + | s1 == s2 = Node s2 (leaf || null ss) this_pkg this_short (addToTrees ss pkg short subs) : ts + | otherwise = mkSubTree (s1:ss) pkg short ++ t : ts + where + this_pkg = if null ss then pkg else node_pkg + this_short = if null ss then short else node_short + + +mkSubTree :: [String] -> Maybe String -> Maybe (Doc 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)] + + +splitModule :: Module -> [String] +splitModule mdl = split (moduleNameString (moduleName mdl)) + where split mod0 = case break (== '.') mod0 of + (s1, '.':s2) -> s1 : split s2 + (s1, _) -> [s1] diff --git a/haddock-api/src/Haddock/Options.hs b/haddock-api/src/Haddock/Options.hs new file mode 100644 index 00000000..b166de46 --- /dev/null +++ b/haddock-api/src/Haddock/Options.hs @@ -0,0 +1,287 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Haddock.Options +-- Copyright : (c) Simon Marlow 2003-2006, +-- David Waern 2006-2009, +-- Mateusz Kowalczyk 2013 +-- License : BSD-like +-- +-- Maintainer : haddock@projects.haskell.org +-- Stability : experimental +-- Portability : portable +-- +-- Definition of the command line interface of Haddock. +----------------------------------------------------------------------------- +module Haddock.Options ( + parseHaddockOpts, + Flag(..), + getUsage, + optTitle, + outputDir, + optContentsUrl, + optIndexUrl, + optCssFile, + sourceUrls, + wikiUrls, + optDumpInterfaceFile, + optLaTeXStyle, + qualification, + verbosity, + ghcFlags, + readIfaceArgs +) where + + +import Distribution.Verbosity +import Haddock.Utils +import Haddock.Types +import System.Console.GetOpt +import qualified Data.Char as Char + + +data Flag + = Flag_BuiltInThemes + | Flag_CSS String +-- | Flag_DocBook + | Flag_ReadInterface String + | Flag_DumpInterface String + | Flag_Heading String + | Flag_Html + | Flag_Hoogle + | Flag_Lib String + | Flag_OutputDir FilePath + | Flag_Prologue FilePath + | Flag_SourceBaseURL String + | Flag_SourceModuleURL String + | Flag_SourceEntityURL String + | Flag_SourceLEntityURL String + | Flag_WikiBaseURL String + | Flag_WikiModuleURL String + | Flag_WikiEntityURL String + | Flag_LaTeX + | Flag_LaTeXStyle String + | Flag_Help + | Flag_Verbosity String + | Flag_Version + | Flag_CompatibleInterfaceVersions + | Flag_InterfaceVersion + | Flag_UseContents String + | Flag_GenContents + | Flag_UseIndex String + | Flag_GenIndex + | Flag_IgnoreAllExports + | Flag_HideModule String + | Flag_ShowExtensions String + | Flag_OptGhc String + | Flag_GhcLibDir String + | Flag_GhcVersion + | Flag_PrintGhcPath + | Flag_PrintGhcLibDir + | Flag_NoWarnings + | Flag_UseUnicode + | Flag_NoTmpCompDir + | Flag_Qualification String + | Flag_PrettyHtml + | Flag_PrintMissingDocs + deriving (Eq) + + +options :: Bool -> [OptDescr Flag] +options backwardsCompat = + [ + Option ['B'] [] (ReqArg Flag_GhcLibDir "DIR") + "path to a GHC lib dir, to override the default path", + Option ['o'] ["odir"] (ReqArg Flag_OutputDir "DIR") + "directory in which to put the output files", + Option ['l'] ["lib"] (ReqArg Flag_Lib "DIR") + "location of Haddock's auxiliary files", + Option ['i'] ["read-interface"] (ReqArg Flag_ReadInterface "FILE") + "read an interface from FILE", + Option ['D'] ["dump-interface"] (ReqArg Flag_DumpInterface "FILE") + "write the resulting interface to FILE", +-- Option ['S'] ["docbook"] (NoArg Flag_DocBook) +-- "output in DocBook XML", + Option ['h'] ["html"] (NoArg Flag_Html) + "output in HTML (XHTML 1.0)", + Option [] ["latex"] (NoArg Flag_LaTeX) "use experimental LaTeX rendering", + 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", + 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"]) + (ReqArg Flag_SourceModuleURL "URL") + "URL for a source code link for each module\n(using the %{FILE} or %{MODULE} vars)", + Option [] ["source-entity"] (ReqArg Flag_SourceEntityURL "URL") + "URL for a source code link for each entity\n(using the %{FILE}, %{MODULE}, %{NAME},\n%{KIND} or %{LINE} vars)", + Option [] ["source-entity-line"] (ReqArg Flag_SourceLEntityURL "URL") + "URL for a source code link for each entity.\nUsed if name links are unavailable, eg. for TH splices.", + Option [] ["comments-base"] (ReqArg Flag_WikiBaseURL "URL") + "URL for a comments link on the contents\nand index pages", + Option [] ["comments-module"] (ReqArg Flag_WikiModuleURL "URL") + "URL for a comments link for each module\n(using the %{MODULE} var)", + Option [] ["comments-entity"] (ReqArg Flag_WikiEntityURL "URL") + "URL for a comments link for each entity\n(using the %{FILE}, %{MODULE}, %{NAME},\n%{KIND} or %{LINE} vars)", + Option ['c'] ["css", "theme"] (ReqArg Flag_CSS "PATH") + "the CSS file or theme directory to use for HTML output", + Option [] ["built-in-themes"] (NoArg Flag_BuiltInThemes) + "include all the built-in haddock themes", + Option ['p'] ["prologue"] (ReqArg Flag_Prologue "FILE") + "file containing prologue text", + Option ['t'] ["title"] (ReqArg Flag_Heading "TITLE") + "page heading", + Option ['q'] ["qual"] (ReqArg Flag_Qualification "QUAL") + "qualification of names, one of \n'none' (default), 'full', 'local'\n'relative' or 'aliased'", + Option ['?'] ["help"] (NoArg Flag_Help) + "display this help and exit", + Option ['V'] ["version"] (NoArg Flag_Version) + "output version information and exit", + Option [] ["compatible-interface-versions"] (NoArg Flag_CompatibleInterfaceVersions) + "output compatible interface file versions and exit", + Option [] ["interface-version"] (NoArg Flag_InterfaceVersion) + "output interface file version and exit", + Option ['v'] ["verbosity"] (ReqArg Flag_Verbosity "VERBOSITY") + "set verbosity level", + Option [] ["use-contents"] (ReqArg Flag_UseContents "URL") + "use a separately-generated HTML contents page", + Option [] ["gen-contents"] (NoArg Flag_GenContents) + "generate an HTML contents from specified\ninterfaces", + Option [] ["use-index"] (ReqArg Flag_UseIndex "URL") + "use a separately-generated HTML index", + Option [] ["gen-index"] (NoArg Flag_GenIndex) + "generate an HTML index from specified\ninterfaces", + Option [] ["ignore-all-exports"] (NoArg Flag_IgnoreAllExports) + "behave as if all modules have the\nignore-exports atribute", + Option [] ["hide"] (ReqArg Flag_HideModule "MODULE") + "behave as if MODULE has the hide attribute", + Option [] ["show-extensions"] (ReqArg Flag_ShowExtensions "MODULE") + "behave as if MODULE has the show-extensions attribute", + Option [] ["optghc"] (ReqArg Flag_OptGhc "OPTION") + "option to be forwarded to GHC", + Option [] ["ghc-version"] (NoArg Flag_GhcVersion) + "output GHC version in numeric format", + Option [] ["print-ghc-path"] (NoArg Flag_PrintGhcPath) + "output path to GHC binary", + Option [] ["print-ghc-libdir"] (NoArg Flag_PrintGhcLibDir) + "output GHC lib dir", + Option ['w'] ["no-warnings"] (NoArg Flag_NoWarnings) "turn off all warnings", + Option [] ["no-tmp-comp-dir"] (NoArg Flag_NoTmpCompDir) + "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" + ] + + +getUsage :: IO String +getUsage = do + prog <- getProgramName + return $ usageInfo (usageHeader prog) (options False) + where + usageHeader :: String -> String + usageHeader prog = "Usage: " ++ prog ++ " [OPTION...] file...\n" + + +parseHaddockOpts :: [String] -> IO ([Flag], [String]) +parseHaddockOpts params = + case getOpt Permute (options True) params of + (flags, args, []) -> return (flags, args) + (_, _, errors) -> do + usage <- getUsage + throwE (concat errors ++ usage) + + +optTitle :: [Flag] -> Maybe String +optTitle flags = + case [str | Flag_Heading str <- flags] of + [] -> Nothing + (t:_) -> Just t + + +outputDir :: [Flag] -> FilePath +outputDir flags = + case [ path | Flag_OutputDir path <- flags ] of + [] -> "." + paths -> last paths + + +optContentsUrl :: [Flag] -> Maybe String +optContentsUrl flags = optLast [ url | Flag_UseContents url <- flags ] + + +optIndexUrl :: [Flag] -> Maybe String +optIndexUrl flags = optLast [ url | Flag_UseIndex url <- flags ] + + +optCssFile :: [Flag] -> Maybe FilePath +optCssFile flags = optLast [ str | Flag_CSS str <- flags ] + + +sourceUrls :: [Flag] -> (Maybe String, Maybe String, Maybe String, Maybe String) +sourceUrls flags = + (optLast [str | Flag_SourceBaseURL str <- flags] + ,optLast [str | Flag_SourceModuleURL str <- flags] + ,optLast [str | Flag_SourceEntityURL str <- flags] + ,optLast [str | Flag_SourceLEntityURL str <- flags]) + + +wikiUrls :: [Flag] -> (Maybe String, Maybe String, Maybe String) +wikiUrls flags = + (optLast [str | Flag_WikiBaseURL str <- flags] + ,optLast [str | Flag_WikiModuleURL str <- flags] + ,optLast [str | Flag_WikiEntityURL str <- flags]) + + +optDumpInterfaceFile :: [Flag] -> Maybe FilePath +optDumpInterfaceFile flags = optLast [ str | Flag_DumpInterface str <- flags ] + + +optLaTeXStyle :: [Flag] -> Maybe String +optLaTeXStyle flags = optLast [ str | Flag_LaTeXStyle str <- flags ] + + +qualification :: [Flag] -> Either String QualOption +qualification flags = + case map (map Char.toLower) [ str | Flag_Qualification str <- flags ] of + [] -> Right OptNoQual + ["none"] -> Right OptNoQual + ["full"] -> Right OptFullQual + ["local"] -> Right OptLocalQual + ["relative"] -> Right OptRelativeQual + ["aliased"] -> Right OptAliasedQual + [arg] -> Left $ "unknown qualification type " ++ show arg + _:_ -> Left "qualification option given multiple times" + + +verbosity :: [Flag] -> Verbosity +verbosity flags = + case [ str | Flag_Verbosity str <- flags ] of + [] -> normal + x:_ -> case parseVerbosity x of + Left e -> throwE e + Right v -> v + + +ghcFlags :: [Flag] -> [String] +ghcFlags flags = [ option | Flag_OptGhc option <- flags ] + + +readIfaceArgs :: [Flag] -> [(DocPaths, FilePath)] +readIfaceArgs flags = [ parseIfaceOption s | Flag_ReadInterface s <- flags ] + where + parseIfaceOption :: String -> (DocPaths, FilePath) + parseIfaceOption str = + case break (==',') str of + (fpath, ',':rest) -> + case break (==',') rest of + (src, ',':file) -> ((fpath, Just src), file) + (file, _) -> ((fpath, Nothing), file) + (file, _) -> (("", Nothing), file) + + +-- | Like 'listToMaybe' but returns the last element instead of the first. +optLast :: [a] -> Maybe a +optLast [] = Nothing +optLast xs = Just (last xs) diff --git a/haddock-api/src/Haddock/Parser.hs b/haddock-api/src/Haddock/Parser.hs new file mode 100644 index 00000000..ea4b7a3f --- /dev/null +++ b/haddock-api/src/Haddock/Parser.hs @@ -0,0 +1,44 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE StandaloneDeriving + , FlexibleInstances, UndecidableInstances + , IncoherentInstances #-} +{-# LANGUAGE LambdaCase #-} +-- | +-- Module : Haddock.Parser +-- Copyright : (c) Mateusz Kowalczyk 2013, +-- Simon Hengel 2013 +-- License : BSD-like +-- +-- Maintainer : haddock@projects.haskell.org +-- Stability : experimental +-- Portability : portable + +module Haddock.Parser ( parseParas + , parseString + , parseIdent + ) where + +import qualified Documentation.Haddock.Parser as P +import DynFlags (DynFlags) +import FastString (mkFastString) +import Documentation.Haddock.Types +import Lexer (mkPState, unP, ParseResult(POk)) +import Parser (parseIdentifier) +import RdrName (RdrName) +import SrcLoc (mkRealSrcLoc, unLoc) +import StringBuffer (stringToStringBuffer) + +parseParas :: DynFlags -> String -> DocH mod RdrName +parseParas d = P.overIdentifier (parseIdent d) . P.parseParas + +parseString :: DynFlags -> String -> DocH mod RdrName +parseString d = P.overIdentifier (parseIdent d) . P.parseString + +parseIdent :: DynFlags -> String -> Maybe RdrName +parseIdent dflags str0 = + let buffer = stringToStringBuffer str0 + realSrcLc = mkRealSrcLoc (mkFastString "<unknown file>") 0 0 + pstate = mkPState dflags buffer realSrcLc + in case unP parseIdentifier pstate of + POk _ name -> Just (unLoc name) + _ -> Nothing diff --git a/haddock-api/src/Haddock/Types.hs b/haddock-api/src/Haddock/Types.hs new file mode 100644 index 00000000..85b3a592 --- /dev/null +++ b/haddock-api/src/Haddock/Types.hs @@ -0,0 +1,552 @@ +{-# LANGUAGE DeriveDataTypeable, DeriveFunctor, DeriveFoldable, DeriveTraversable, StandaloneDeriving #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +----------------------------------------------------------------------------- +-- | +-- Module : Haddock.Types +-- Copyright : (c) Simon Marlow 2003-2006, +-- David Waern 2006-2009, +-- Mateusz Kowalczyk 2013 +-- License : BSD-like +-- +-- Maintainer : haddock@projects.haskellorg +-- Stability : experimental +-- Portability : portable +-- +-- Types that are commonly used through-out Haddock. Some of the most +-- important types are defined here, like 'Interface' and 'DocName'. +----------------------------------------------------------------------------- +module Haddock.Types ( + module Haddock.Types + , HsDocString, LHsDocString + , Fixity(..) + , module Documentation.Haddock.Types + ) where + +import Control.Exception +import Control.Arrow hiding ((<+>)) +import Control.DeepSeq +import Data.Typeable +import Data.Map (Map) +import qualified Data.Map as Map +import Documentation.Haddock.Types +import BasicTypes (Fixity(..)) +import GHC hiding (NoLink) +import DynFlags (ExtensionFlag, Language) +import OccName +import Outputable +import Control.Applicative (Applicative(..)) +import Control.Monad (ap) + +----------------------------------------------------------------------------- +-- * Convenient synonyms +----------------------------------------------------------------------------- + + +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 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 DocPaths = (FilePath, Maybe FilePath) -- paths to HTML and sources + + +----------------------------------------------------------------------------- +-- * Interface +----------------------------------------------------------------------------- + + +-- | 'Interface' holds all information used to render a single Haddock page. +-- It represents the /interface/ of a module. The core business of Haddock +-- lies in creating this structure. Note that the record contains some fields +-- that are only used to create the final record, and that are not used by the +-- backends. +data Interface = Interface + { + -- | The module behind this interface. + ifaceMod :: !Module + + -- | Original file name of the module. + , ifaceOrigFilename :: !FilePath + + -- | Textual information about the module. + , ifaceInfo :: !(HaddockModInfo Name) + + -- | Documentation header. + , ifaceDoc :: !(Documentation Name) + + -- | Documentation header with cross-reference information. + , ifaceRnDoc :: !(Documentation DocName) + + -- | Haddock options for this module (prune, ignore-exports, etc). + , ifaceOptions :: ![DocOption] + + -- | Declarations originating from the module. Excludes declarations without + -- names (instances and stand-alone documentation comments). Includes + -- names of subordinate declarations mapped to their parent declarations. + , ifaceDeclMap :: !(Map Name [LHsDecl Name]) + + -- | Documentation of declarations originating from the module (including + -- subordinates). + , ifaceDocMap :: !(DocMap Name) + , ifaceArgMap :: !(ArgMap Name) + + -- | Documentation of declarations originating from the module (including + -- subordinates). + , ifaceRnDocMap :: !(DocMap DocName) + , ifaceRnArgMap :: !(ArgMap DocName) + + , ifaceSubMap :: !(Map Name [Name]) + , ifaceFixMap :: !(Map Name Fixity) + + , ifaceExportItems :: ![ExportItem Name] + , ifaceRnExportItems :: ![ExportItem DocName] + + -- | All names exported by the module. + , ifaceExports :: ![Name] + + -- | All \"visible\" names exported by the module. + -- A visible name is a name that will show up in the documentation of the + -- module. + , ifaceVisibleExports :: ![Name] + + -- | Aliases of module imports as in @import A.B.C as C@. + , ifaceModuleAliases :: !AliasMap + + -- | Instances exported by the module. + , ifaceInstances :: ![ClsInst] + , ifaceFamInstances :: ![FamInst] + + -- | The number of haddockable and haddocked items in the module, as a + -- tuple. Haddockable items are the exports and the module itself. + , ifaceHaddockCoverage :: !(Int, Int) + + -- | Warnings for things defined in this module. + , ifaceWarningMap :: !WarningMap + } + +type WarningMap = DocMap Name + + +-- | A subset of the fields of 'Interface' that we store in the interface +-- files. +data InstalledInterface = InstalledInterface + { + -- | The module represented by this interface. + instMod :: Module + + -- | Textual information about the module. + , instInfo :: HaddockModInfo Name + + -- | Documentation of declarations originating from the module (including + -- subordinates). + , instDocMap :: DocMap Name + + , instArgMap :: ArgMap Name + + -- | All names exported by this module. + , instExports :: [Name] + + -- | All \"visible\" names exported by the module. + -- A visible name is a name that will show up in the documentation of the + -- module. + , instVisibleExports :: [Name] + + -- | Haddock options for this module (prune, ignore-exports, etc). + , instOptions :: [DocOption] + + , instSubMap :: Map Name [Name] + , instFixMap :: Map Name Fixity + } + + +-- | Convert an 'Interface' to an 'InstalledInterface' +toInstalledIface :: Interface -> InstalledInterface +toInstalledIface interface = InstalledInterface + { instMod = ifaceMod interface + , instInfo = ifaceInfo interface + , instDocMap = ifaceDocMap interface + , instArgMap = ifaceArgMap interface + , instExports = ifaceExports interface + , instVisibleExports = ifaceVisibleExports interface + , instOptions = ifaceOptions interface + , instSubMap = ifaceSubMap interface + , instFixMap = ifaceFixMap interface + } + + +----------------------------------------------------------------------------- +-- * Export items & declarations +----------------------------------------------------------------------------- + + +data ExportItem name + + -- | An exported declaration. + = ExportDecl + { + -- | A declaration. + expItemDecl :: !(LHsDecl name) + + -- | Maybe a doc comment, and possibly docs for arguments (if this + -- decl is a function or type-synonym). + , expItemMbDoc :: !(DocForDecl name) + + -- | Subordinate names, possibly with documentation. + , expItemSubDocs :: ![(name, DocForDecl name)] + + -- | Instances relevant to this declaration, possibly with + -- documentation. + , expItemInstances :: ![DocInstance name] + + -- | Fixity decls relevant to this declaration (including subordinates). + , expItemFixities :: ![(name, Fixity)] + + -- | Whether the ExportItem is from a TH splice or not, for generating + -- the appropriate type of Source link. + , expItemSpliced :: !Bool + } + + -- | An exported entity for which we have no documentation (perhaps because it + -- resides in another package). + | ExportNoDecl + { expItemName :: !name + + -- | Subordinate names. + , expItemSubs :: ![name] + } + + -- | A section heading. + | ExportGroup + { + -- | Section level (1, 2, 3, ...). + expItemSectionLevel :: !Int + + -- | Section id (for hyperlinks). + , expItemSectionId :: !String + + -- | Section heading text. + , expItemSectionText :: !(Doc name) + } + + -- | Some documentation. + | ExportDoc !(Doc name) + + -- | A cross-reference to another module. + | ExportModule !Module + +data Documentation name = Documentation + { documentationDoc :: Maybe (Doc 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 DocForDecl name = (Documentation name, FnArgsDoc name) + + +noDocForDecl :: DocForDecl name +noDocForDecl = (Documentation Nothing Nothing, Map.empty) + + +unrenameDocForDecl :: DocForDecl DocName -> DocForDecl Name +unrenameDocForDecl (doc, fnArgsDoc) = + (fmap getName doc, (fmap . fmap) getName fnArgsDoc) + + +----------------------------------------------------------------------------- +-- * Cross-referencing +----------------------------------------------------------------------------- + + +-- | Type of environment used to cross-reference identifiers in the syntax. +type LinkEnv = Map Name Module + + +-- | Extends 'Name' with cross-reference information. +data DocName + = Documented Name Module + -- ^ This thing is part of the (existing or resulting) + -- documentation. The 'Module' is the preferred place + -- in the documentation to refer to. + | Undocumented Name + -- ^ This thing is not part of the (existing or resulting) + -- documentation, as far as Haddock knows. + deriving Eq + + +instance NamedThing DocName where + getName (Documented name _) = name + getName (Undocumented name) = name + + +----------------------------------------------------------------------------- +-- * Instances +----------------------------------------------------------------------------- + +-- | The three types of instances +data InstType name + = ClassInst [HsType name] -- ^ Context + | TypeInst (Maybe (HsType name)) -- ^ Body (right-hand side) + | DataInst (TyClDecl name) -- ^ Data constructors + +instance OutputableBndr a => Outputable (InstType a) where + ppr (ClassInst a) = text "ClassInst" <+> ppr a + 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)) + +-- | The head of an instance. Consists of a class name, a list of kind +-- parameters, a list of type parameters and an instance type +type InstHead name = (name, [HsType name], [HsType name], InstType name) + +----------------------------------------------------------------------------- +-- * Documentation comments +----------------------------------------------------------------------------- + + +type LDoc id = Located (Doc id) + +type Doc id = DocH (ModuleName, OccName) id + +instance (NFData a, NFData mod) + => NFData (DocH mod a) where + rnf doc = case doc of + DocEmpty -> () + DocAppend a b -> a `deepseq` b `deepseq` () + DocString a -> a `deepseq` () + DocParagraph a -> a `deepseq` () + DocIdentifier a -> a `deepseq` () + DocIdentifierUnchecked a -> a `deepseq` () + DocModule a -> a `deepseq` () + DocWarning a -> a `deepseq` () + DocEmphasis a -> a `deepseq` () + DocBold a -> a `deepseq` () + DocMonospaced a -> a `deepseq` () + DocUnorderedList a -> a `deepseq` () + DocOrderedList a -> a `deepseq` () + DocDefList a -> a `deepseq` () + DocCodeBlock a -> a `deepseq` () + DocHyperlink a -> a `deepseq` () + DocPic a -> a `deepseq` () + DocAName a -> a `deepseq` () + DocProperty a -> a `deepseq` () + DocExamples a -> a `deepseq` () + DocHeader a -> a `deepseq` () + + +instance NFData Name +instance NFData OccName +instance NFData ModuleName + +instance NFData id => NFData (Header id) where + rnf (Header a b) = a `deepseq` b `deepseq` () + +instance NFData Hyperlink where + rnf (Hyperlink a b) = a `deepseq` b `deepseq` () + +instance NFData Picture where + rnf (Picture a b) = a `deepseq` b `deepseq` () + +instance NFData Example where + rnf (Example a b) = a `deepseq` b `deepseq` () + + +exampleToString :: Example -> String +exampleToString (Example expression result) = + ">>> " ++ expression ++ "\n" ++ unlines result + + +data DocMarkup id a = Markup + { markupEmpty :: a + , markupString :: String -> a + , markupParagraph :: a -> a + , markupAppend :: a -> a -> a + , markupIdentifier :: id -> a + , markupIdentifierUnchecked :: (ModuleName, OccName) -> a + , markupModule :: String -> a + , markupWarning :: a -> a + , markupEmphasis :: a -> a + , markupBold :: a -> a + , markupMonospaced :: a -> a + , markupUnorderedList :: [a] -> a + , markupOrderedList :: [a] -> a + , markupDefList :: [(a,a)] -> a + , markupCodeBlock :: a -> a + , markupHyperlink :: Hyperlink -> a + , markupAName :: String -> a + , markupPic :: Picture -> a + , markupProperty :: String -> a + , markupExample :: [Example] -> a + , markupHeader :: Header a -> a + } + + +data HaddockModInfo name = HaddockModInfo + { hmi_description :: Maybe (Doc name) + , hmi_copyright :: Maybe String + , hmi_license :: Maybe String + , hmi_maintainer :: Maybe String + , hmi_stability :: Maybe String + , hmi_portability :: Maybe String + , hmi_safety :: Maybe String + , hmi_language :: Maybe Language + , hmi_extensions :: [ExtensionFlag] + } + + +emptyHaddockModInfo :: HaddockModInfo a +emptyHaddockModInfo = HaddockModInfo + { hmi_description = Nothing + , hmi_copyright = Nothing + , hmi_license = Nothing + , hmi_maintainer = Nothing + , hmi_stability = Nothing + , hmi_portability = Nothing + , hmi_safety = Nothing + , hmi_language = Nothing + , hmi_extensions = [] + } + + +----------------------------------------------------------------------------- +-- * Options +----------------------------------------------------------------------------- + + +{-! for DocOption derive: Binary !-} +-- | Source-level options for controlling the documentation. +data DocOption + = OptHide -- ^ This module should not appear in the docs. + | OptPrune + | OptIgnoreExports -- ^ Pretend everything is exported. + | OptNotHome -- ^ Not the best place to get docs for things + -- exported by this module. + | OptShowExtensions -- ^ Render enabled extensions for this module. + deriving (Eq, Show) + + +-- | Option controlling how to qualify names +data QualOption + = OptNoQual -- ^ Never qualify any names. + | OptFullQual -- ^ Qualify all names fully. + | OptLocalQual -- ^ Qualify all imported names fully. + | OptRelativeQual -- ^ Like local, but strip module prefix + -- from modules in the same hierarchy. + | OptAliasedQual -- ^ Uses aliases of module names + -- as suggested by module import renamings. + -- However, we are unfortunately not able + -- to maintain the original qualifications. + -- Image a re-export of a whole module, + -- how could the re-exported identifiers be qualified? + +type AliasMap = Map Module ModuleName + +data Qualification + = NoQual + | FullQual + | LocalQual Module + | RelativeQual Module + | AliasedQual AliasMap Module + -- ^ @Module@ contains the current module. + -- This way we can distinguish imported and local identifiers. + +makeContentsQual :: QualOption -> Qualification +makeContentsQual qual = + case qual of + OptNoQual -> NoQual + _ -> FullQual + +makeModuleQual :: QualOption -> AliasMap -> Module -> Qualification +makeModuleQual qual aliases mdl = + case qual of + OptLocalQual -> LocalQual mdl + OptRelativeQual -> RelativeQual mdl + OptAliasedQual -> AliasedQual aliases mdl + OptFullQual -> FullQual + OptNoQual -> NoQual + + +----------------------------------------------------------------------------- +-- * Error handling +----------------------------------------------------------------------------- + + +-- A monad which collects error messages, locally defined to avoid a dep on mtl + + +type ErrMsg = String +newtype ErrMsgM a = Writer { runWriter :: (a, [ErrMsg]) } + + +instance Functor ErrMsgM where + fmap f (Writer (a, msgs)) = Writer (f a, msgs) + +instance Applicative ErrMsgM where + pure = return + (<*>) = ap + +instance Monad ErrMsgM where + return a = Writer (a, []) + m >>= k = Writer $ let + (a, w) = runWriter m + (b, w') = runWriter (k a) + in (b, w ++ w') + + +tell :: [ErrMsg] -> ErrMsgM () +tell w = Writer ((), w) + + +-- Exceptions + + +-- | Haddock's own exception type. +data HaddockException = HaddockException String deriving Typeable + + +instance Show HaddockException where + show (HaddockException str) = str + + +throwE :: String -> a +instance Exception HaddockException +throwE str = throw (HaddockException str) + + +-- In "Haddock.Interface.Create", we need to gather +-- @Haddock.Types.ErrMsg@s a lot, like @ErrMsgM@ does, +-- but we can't just use @GhcT ErrMsgM@ because GhcT requires the +-- transformed monad to be MonadIO. +newtype ErrMsgGhc a = WriterGhc { runWriterGhc :: Ghc (a, [ErrMsg]) } +--instance MonadIO ErrMsgGhc where +-- liftIO = WriterGhc . fmap (\a->(a,[])) liftIO +--er, implementing GhcMonad involves annoying ExceptionMonad and +--WarnLogMonad classes, so don't bother. +liftGhcToErrMsgGhc :: Ghc a -> ErrMsgGhc a +liftGhcToErrMsgGhc = WriterGhc . fmap (\a->(a,[])) +liftErrMsg :: ErrMsgM a -> ErrMsgGhc a +liftErrMsg = WriterGhc . return . runWriter +-- for now, use (liftErrMsg . tell) for this +--tell :: [ErrMsg] -> ErrMsgGhc () +--tell msgs = WriterGhc $ return ( (), msgs ) + + +instance Functor ErrMsgGhc where + fmap f (WriterGhc x) = WriterGhc (fmap (first f) x) + +instance Applicative ErrMsgGhc where + pure = return + (<*>) = ap + +instance Monad ErrMsgGhc where + return a = WriterGhc (return (a, [])) + m >>= k = WriterGhc $ runWriterGhc m >>= \ (a, msgs1) -> + fmap (second (msgs1 ++)) (runWriterGhc (k a)) diff --git a/haddock-api/src/Haddock/Utils.hs b/haddock-api/src/Haddock/Utils.hs new file mode 100644 index 00000000..ee7bfd0a --- /dev/null +++ b/haddock-api/src/Haddock/Utils.hs @@ -0,0 +1,480 @@ +{-# LANGUAGE CPP #-} +----------------------------------------------------------------------------- +-- | +-- Module : Haddock.Utils +-- Copyright : (c) The University of Glasgow 2001-2002, +-- Simon Marlow 2003-2006, +-- David Waern 2006-2009 +-- License : BSD-like +-- +-- Maintainer : haddock@projects.haskell.org +-- Stability : experimental +-- Portability : portable +----------------------------------------------------------------------------- +module Haddock.Utils ( + + -- * Misc utilities + restrictTo, emptyHsQTvs, + toDescription, toInstalledDescription, + + -- * Filename utilities + moduleHtmlFile, moduleHtmlFile', + contentsHtmlFile, indexHtmlFile, + frameIndexHtmlFile, + moduleIndexFrameName, mainFrameName, synopsisFrameName, + subIndexHtmlFile, + jsFile, framesFile, + + -- * Anchor and URL utilities + moduleNameUrl, moduleNameUrl', moduleUrl, + nameAnchorId, + makeAnchorId, + + -- * Miscellaneous utilities + getProgramName, bye, die, dieMsg, noDieMsg, mapSnd, mapMaybeM, escapeStr, + + -- * HTML cross reference mapping + html_xrefs_ref, html_xrefs_ref', + + -- * Doc markup + markup, + idMarkup, + + -- * List utilities + replace, + spanWith, + + -- * MTL stuff + MonadIO(..), + + -- * Logging + parseVerbosity, + out, + + -- * System tools + getProcessID + ) where + + +import Haddock.Types +import Haddock.GhcUtils + +import GHC +import Name + +import Control.Monad ( liftM ) +import Data.Char ( isAlpha, isAlphaNum, isAscii, ord, chr ) +import Numeric ( showIntAtBase ) +import Data.Map ( Map ) +import qualified Data.Map as Map hiding ( Map ) +import Data.IORef ( IORef, newIORef, readIORef ) +import Data.List ( isSuffixOf ) +import Data.Maybe ( mapMaybe ) +import System.Environment ( getProgName ) +import System.Exit +import System.IO ( hPutStr, stderr ) +import System.IO.Unsafe ( unsafePerformIO ) +import qualified System.FilePath.Posix as HtmlPath +import Distribution.Verbosity +import Distribution.ReadE + +#ifndef mingw32_HOST_OS +import qualified System.Posix.Internals +#endif + +import MonadUtils ( MonadIO(..) ) + + +-------------------------------------------------------------------------------- +-- * Logging +-------------------------------------------------------------------------------- + + +parseVerbosity :: String -> Either String Verbosity +parseVerbosity = runReadE flagToVerbosity + + +-- | Print a message to stdout, if it is not too verbose +out :: MonadIO m + => Verbosity -- ^ program verbosity + -> Verbosity -- ^ message verbosity + -> String -> m () +out progVerbosity msgVerbosity msg + | msgVerbosity <= progVerbosity = liftIO $ putStrLn msg + | otherwise = return () + + +-------------------------------------------------------------------------------- +-- * Some Utilities +-------------------------------------------------------------------------------- + + +-- | Extract a module's short description. +toDescription :: Interface -> Maybe (Doc Name) +toDescription = hmi_description . ifaceInfo + + +-- | Extract a module's short description. +toInstalledDescription :: InstalledInterface -> Maybe (Doc Name) +toInstalledDescription = hmi_description . instInfo + + +-------------------------------------------------------------------------------- +-- * Making abstract declarations +-------------------------------------------------------------------------------- + + +restrictTo :: [Name] -> LHsDecl Name -> LHsDecl Name +restrictTo names (L loc decl) = L loc $ case decl of + TyClD d | isDataDecl d -> + TyClD (d { tcdDataDefn = restrictDataDefn names (tcdDataDefn d) }) + TyClD d | isClassDecl d -> + TyClD (d { tcdSigs = restrictDecls names (tcdSigs d), + tcdATs = restrictATs names (tcdATs d) }) + _ -> decl + +restrictDataDefn :: [Name] -> HsDataDefn Name -> HsDataDefn Name +restrictDataDefn names defn@(HsDataDefn { dd_ND = new_or_data, dd_cons = cons }) + | DataType <- new_or_data + = defn { dd_cons = restrictCons names cons } + | otherwise -- Newtype + = case restrictCons names cons of + [] -> defn { dd_ND = DataType, dd_cons = [] } + [con] -> defn { dd_cons = [con] } + _ -> error "Should not happen" + +restrictCons :: [Name] -> [LConDecl Name] -> [LConDecl Name] +restrictCons names decls = [ L p d | L p (Just d) <- map (fmap keep) decls ] + where + keep d | unLoc (con_name d) `elem` names = + 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) }) + -- 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_types flds = [ t | ConDeclField _ t _ <- flds ] + + keep _ = Nothing + + +restrictDecls :: [Name] -> [LSig Name] -> [LSig Name] +restrictDecls names = mapMaybe (filterLSigNames (`elem` names)) + + +restrictATs :: [Name] -> [LFamilyDecl Name] -> [LFamilyDecl Name] +restrictATs names ats = [ at | at <- ats , unL (fdLName (unL at)) `elem` names ] + +emptyHsQTvs :: LHsTyVarBndrs Name +-- This function is here, rather than in HsTypes, because it *renamed*, but +-- does not necessarily have all the rigt kind variables. It is used +-- in Haddock just for printing, so it doesn't matter +emptyHsQTvs = HsQTvs { hsq_kvs = error "haddock:emptyHsQTvs", hsq_tvs = [] } + + +-------------------------------------------------------------------------------- +-- * Filename mangling functions stolen from s main/DriverUtil.lhs. +-------------------------------------------------------------------------------- + + +baseName :: ModuleName -> FilePath +baseName = map (\c -> if c == '.' then '-' else c) . moduleNameString + + +moduleHtmlFile :: Module -> FilePath +moduleHtmlFile mdl = + case Map.lookup mdl html_xrefs of + Nothing -> baseName mdl' ++ ".html" + Just fp0 -> HtmlPath.joinPath [fp0, baseName mdl' ++ ".html"] + where + mdl' = moduleName mdl + + +moduleHtmlFile' :: ModuleName -> FilePath +moduleHtmlFile' mdl = + case Map.lookup mdl html_xrefs' of + Nothing -> baseName mdl ++ ".html" + Just fp0 -> HtmlPath.joinPath [fp0, baseName mdl ++ ".html"] + + +contentsHtmlFile, indexHtmlFile :: String +contentsHtmlFile = "index.html" +indexHtmlFile = "doc-index.html" + + +-- | The name of the module index file to be displayed inside a frame. +-- Modules are display in full, but without indentation. Clicking opens in +-- the main window. +frameIndexHtmlFile :: String +frameIndexHtmlFile = "index-frames.html" + + +moduleIndexFrameName, mainFrameName, synopsisFrameName :: String +moduleIndexFrameName = "modules" +mainFrameName = "main" +synopsisFrameName = "synopsis" + + +subIndexHtmlFile :: String -> String +subIndexHtmlFile ls = "doc-index-" ++ b ++ ".html" + where b | all isAlpha ls = ls + | otherwise = concatMap (show . ord) ls + + +------------------------------------------------------------------------------- +-- * Anchor and URL utilities +-- +-- NB: Anchor IDs, used as the destination of a link within a document must +-- conform to XML's NAME production. That, taken with XHTML and HTML 4.01's +-- various needs and compatibility constraints, means these IDs have to match: +-- [A-Za-z][A-Za-z0-9:_.-]* +-- Such IDs do not need to be escaped in any way when used as the fragment part +-- of a URL. Indeed, %-escaping them can lead to compatibility issues as it +-- isn't clear if such fragment identifiers should, or should not be unescaped +-- before being matched with IDs in the target document. +------------------------------------------------------------------------------- + + +moduleUrl :: Module -> String +moduleUrl = moduleHtmlFile + + +moduleNameUrl :: Module -> OccName -> String +moduleNameUrl mdl n = moduleUrl mdl ++ '#' : nameAnchorId n + + +moduleNameUrl' :: ModuleName -> OccName -> String +moduleNameUrl' mdl n = moduleHtmlFile' mdl ++ '#' : nameAnchorId n + + +nameAnchorId :: OccName -> String +nameAnchorId name = makeAnchorId (prefix : ':' : occNameString name) + where prefix | isValOcc name = 'v' + | otherwise = 't' + + +-- | Takes an arbitrary string and makes it a valid anchor ID. The mapping is +-- identity preserving. +makeAnchorId :: String -> String +makeAnchorId [] = [] +makeAnchorId (f:r) = escape isAlpha f ++ concatMap (escape isLegal) r + where + escape p c | p c = [c] + | otherwise = '-' : show (ord c) ++ "-" + isLegal ':' = True + isLegal '_' = True + isLegal '.' = True + isLegal c = isAscii c && isAlphaNum c + -- NB: '-' is legal in IDs, but we use it as the escape char + + +------------------------------------------------------------------------------- +-- * Files we need to copy from our $libdir +------------------------------------------------------------------------------- + + +jsFile, framesFile :: String +jsFile = "haddock-util.js" +framesFile = "frames.html" + + +------------------------------------------------------------------------------- +-- * Misc. +------------------------------------------------------------------------------- + + +getProgramName :: IO String +getProgramName = liftM (`withoutSuffix` ".bin") getProgName + where str `withoutSuffix` suff + | suff `isSuffixOf` str = take (length str - length suff) str + | otherwise = str + + +bye :: String -> IO a +bye s = putStr s >> exitSuccess + + +die :: String -> IO a +die s = hPutStr stderr s >> exitWith (ExitFailure 1) + + +dieMsg :: String -> IO a +dieMsg s = getProgramName >>= \prog -> die (prog ++ ": " ++ s) + + +noDieMsg :: String -> IO () +noDieMsg s = getProgramName >>= \prog -> hPutStr stderr (prog ++ ": " ++ s) + + +mapSnd :: (b -> c) -> [(a,b)] -> [(a,c)] +mapSnd _ [] = [] +mapSnd f ((x,y):xs) = (x,f y) : mapSnd f xs + + +mapMaybeM :: Monad m => (a -> m b) -> Maybe a -> m (Maybe b) +mapMaybeM _ Nothing = return Nothing +mapMaybeM f (Just a) = liftM Just (f a) + + +escapeStr :: String -> String +escapeStr = escapeURIString isUnreserved + + +-- Following few functions are copy'n'pasted from Network.URI module +-- to avoid depending on the network lib, since doing so gives a +-- circular build dependency between haddock and network +-- (at least if you want to build network with haddock docs) +escapeURIChar :: (Char -> Bool) -> Char -> String +escapeURIChar p c + | p c = [c] + | otherwise = '%' : myShowHex (ord c) "" + where + myShowHex :: Int -> ShowS + myShowHex n r = case showIntAtBase 16 toChrHex n r of + [] -> "00" + [a] -> ['0',a] + cs -> cs + toChrHex d + | d < 10 = chr (ord '0' + fromIntegral d) + | otherwise = chr (ord 'A' + fromIntegral (d - 10)) + + +escapeURIString :: (Char -> Bool) -> String -> String +escapeURIString = concatMap . escapeURIChar + + +isUnreserved :: Char -> Bool +isUnreserved c = isAlphaNumChar c || (c `elem` "-_.~") + + +isAlphaChar, isDigitChar, isAlphaNumChar :: Char -> Bool +isAlphaChar c = (c >= 'A' && c <= 'Z') || (c >= 'a' && c <= 'z') +isDigitChar c = c >= '0' && c <= '9' +isAlphaNumChar c = isAlphaChar c || isDigitChar c + + +----------------------------------------------------------------------------- +-- * HTML cross references +-- +-- For each module, we need to know where its HTML documentation lives +-- so that we can point hyperlinks to it. It is extremely +-- inconvenient to plumb this information to all the places that need +-- it (basically every function in HaddockHtml), and furthermore the +-- mapping is constant for any single run of Haddock. So for the time +-- being I'm going to use a write-once global variable. +----------------------------------------------------------------------------- + + +{-# NOINLINE html_xrefs_ref #-} +html_xrefs_ref :: IORef (Map Module FilePath) +html_xrefs_ref = unsafePerformIO (newIORef (error "module_map")) + + +{-# NOINLINE html_xrefs_ref' #-} +html_xrefs_ref' :: IORef (Map ModuleName FilePath) +html_xrefs_ref' = unsafePerformIO (newIORef (error "module_map")) + + +{-# NOINLINE html_xrefs #-} +html_xrefs :: Map Module FilePath +html_xrefs = unsafePerformIO (readIORef html_xrefs_ref) + + +{-# NOINLINE html_xrefs' #-} +html_xrefs' :: Map ModuleName FilePath +html_xrefs' = unsafePerformIO (readIORef html_xrefs_ref') + + +----------------------------------------------------------------------------- +-- * List utils +----------------------------------------------------------------------------- + + +replace :: Eq a => a -> a -> [a] -> [a] +replace a b = map (\x -> if x == a then b else x) + + +spanWith :: (a -> Maybe b) -> [a] -> ([b],[a]) +spanWith _ [] = ([],[]) +spanWith p xs@(a:as) + | Just b <- p a = let (bs,cs) = spanWith p as in (b:bs,cs) + | otherwise = ([],xs) + + +----------------------------------------------------------------------------- +-- * Put here temporarily +----------------------------------------------------------------------------- + + +markup :: DocMarkup id a -> Doc id -> a +markup m DocEmpty = markupEmpty m +markup m (DocAppend d1 d2) = markupAppend m (markup m d1) (markup m d2) +markup m (DocString s) = markupString m s +markup m (DocParagraph d) = markupParagraph m (markup m d) +markup m (DocIdentifier x) = markupIdentifier m x +markup m (DocIdentifierUnchecked x) = markupIdentifierUnchecked m x +markup m (DocModule mod0) = markupModule m mod0 +markup m (DocWarning d) = markupWarning m (markup m d) +markup m (DocEmphasis d) = markupEmphasis m (markup m d) +markup m (DocBold d) = markupBold m (markup m d) +markup m (DocMonospaced d) = markupMonospaced m (markup m d) +markup m (DocUnorderedList ds) = markupUnorderedList m (map (markup m) ds) +markup m (DocOrderedList ds) = markupOrderedList m (map (markup m) ds) +markup m (DocDefList ds) = markupDefList m (map (markupPair m) ds) +markup m (DocCodeBlock d) = markupCodeBlock m (markup m d) +markup m (DocHyperlink l) = markupHyperlink m l +markup m (DocAName ref) = markupAName m ref +markup m (DocPic img) = markupPic m img +markup m (DocProperty p) = markupProperty m p +markup m (DocExamples e) = markupExample m e +markup m (DocHeader (Header l t)) = markupHeader m (Header l (markup m t)) + + +markupPair :: DocMarkup id a -> (Doc id, Doc id) -> (a, a) +markupPair m (a,b) = (markup m a, markup m b) + + +-- | The identity markup +idMarkup :: DocMarkup a (Doc a) +idMarkup = Markup { + markupEmpty = DocEmpty, + markupString = DocString, + markupParagraph = DocParagraph, + markupAppend = DocAppend, + markupIdentifier = DocIdentifier, + markupIdentifierUnchecked = DocIdentifierUnchecked, + markupModule = DocModule, + markupWarning = DocWarning, + markupEmphasis = DocEmphasis, + markupBold = DocBold, + markupMonospaced = DocMonospaced, + markupUnorderedList = DocUnorderedList, + markupOrderedList = DocOrderedList, + markupDefList = DocDefList, + markupCodeBlock = DocCodeBlock, + markupHyperlink = DocHyperlink, + markupAName = DocAName, + markupPic = DocPic, + markupProperty = DocProperty, + markupExample = DocExamples, + markupHeader = DocHeader + } + + +----------------------------------------------------------------------------- +-- * System tools +----------------------------------------------------------------------------- + + +#ifdef mingw32_HOST_OS +foreign import ccall unsafe "_getpid" getProcessID :: IO Int -- relies on Int == Int32 on Windows +#else +getProcessID :: IO Int +getProcessID = fmap fromIntegral System.Posix.Internals.c_getpid +#endif diff --git a/haddock-api/src/Haddock/Version.hs b/haddock-api/src/Haddock/Version.hs new file mode 100644 index 00000000..2ef3a257 --- /dev/null +++ b/haddock-api/src/Haddock/Version.hs @@ -0,0 +1,30 @@ +{-# LANGUAGE CPP #-} +----------------------------------------------------------------------------- +-- | +-- Module : Haddock.Version +-- Copyright : (c) Simon Marlow 2003 +-- License : BSD-like +-- +-- Maintainer : haddock@projects.haskell.org +-- Stability : experimental +-- Portability : portable +----------------------------------------------------------------------------- +module Haddock.Version ( + projectName, projectVersion, projectUrl +) where + +#ifdef IN_GHC_TREE +import Paths_haddock ( version ) +#else +import Paths_haddock_api ( version ) +#endif +import Data.Version ( showVersion ) + +projectName :: String +projectName = "Haddock" + +projectUrl :: String +projectUrl = "http://www.haskell.org/haddock/" + +projectVersion :: String +projectVersion = showVersion version |