haddock 2.4.2 → 2.5.0
raw patch · 29 files changed
+1504/−1366 lines, 29 filesdep ~basedep ~ghcPVP ok
version bump matches the API change (PVP)
Dependency ranges changed: base, ghc
API changes (from Hackage documentation)
- Distribution.Haddock: docNameOrig :: DocName -> Name
Files
- CHANGES +20/−0
- doc/haddock.xml +5/−5
- haddock.cabal +30/−32
- haddock.spec +1/−1
- src/Distribution/Haddock.hs +3/−2
- src/Haddock/Backends/DevHelp.hs +19/−13
- src/Haddock/Backends/HH.hs +9/−4
- src/Haddock/Backends/HH2.hs +14/−8
- src/Haddock/Backends/HaddockDB.hs +10/−4
- src/Haddock/Backends/Hoogle.hs +31/−19
- src/Haddock/Backends/Html.hs +498/−382
- src/Haddock/DocName.hs +0/−59
- src/Haddock/Exception.hs +0/−34
- src/Haddock/GHC.hs +0/−119
- src/Haddock/GHC/Typecheck.hs +0/−53
- src/Haddock/GHC/Utils.hs +0/−180
- src/Haddock/GhcUtils.hs +198/−0
- src/Haddock/Interface.hs +85/−43
- src/Haddock/Interface/AttachInstances.hs +29/−26
- src/Haddock/Interface/Create.hs +76/−98
- src/Haddock/Interface/Rename.hs +116/−89
- src/Haddock/InterfaceFile.hs +39/−30
- src/Haddock/ModuleTree.hs +10/−4
- src/Haddock/Options.hs +17/−7
- src/Haddock/Types.hs +87/−13
- src/Haddock/Utils.hs +46/−62
- src/Haddock/Utils/FastMutInt2.hs +1/−2
- src/Haddock/Version.hs +9/−4
- src/Main.hs +151/−73
CHANGES view
@@ -1,3 +1,23 @@+Changed in version 2.5.0:++ * Drop support for GHC 6.8.*++ * Add support for GHC 6.10.3 and 6.10.4++ * Revert to the old multi-page index for large packages (#106)++ * Show GADT records in the generated documentation++ * Create output directory if it doesn't exist (#104)++ * Use the native codegen instead of compiling via C for TH modules++ * Add --use-unicode flag for displaying prettier versions of common symbols++ * Mutiple verbosity levels: remove --verbose and add --verbosity=n++-----------------------------------------------------------------------------+ Changed in version 2.4.2: * Support GHC 6.10.2
doc/haddock.xml view
@@ -16,7 +16,7 @@ <holder>Simon Marlow</holder> </copyright> <abstract>- <para>This document describes Haddock version 2.4.2, a Haskell+ <para>This document describes Haddock version 2.5.0, a Haskell documentation tool.</para> </abstract> </bookinfo>@@ -804,9 +804,8 @@ atribute. (<xref linkend="module-attributes" />).</para> </listitem> </varlistentry>- </variablelist> -<varlistentry>+ <varlistentry> <term> <indexterm><primary><option>-w</option></primary></indexterm> <option>-w</option>@@ -819,6 +818,7 @@ <para>Turn off all warnings.</para> </listitem> </varlistentry>+ </variablelist> <section id="cpp"> <title>Using literate or pre-processed source</title>@@ -1367,8 +1367,8 @@ <varlistentry> <term>- <indexterm><primary><literal>not-home</literal></primary>- </indexterm>+ <indexterm><primary><literal>not-home</literal></primary></indexterm>+ <literal>not-home</literal> </term> <listitem> <para>Indicates that the current module should not be considered to
haddock.cabal view
@@ -1,6 +1,6 @@ name: haddock-version: 2.4.2-cabal-version: >= 1.2.3+version: 2.5.0+cabal-version: >= 1.6 license: BSD3 build-type: Simple license-file: LICENSE@@ -50,13 +50,13 @@ src/haddock.sh data-files:- html/haddock-DEBUG.css- html/haddock.css- html/haddock-util.js- html/haskell_icon.gif- html/minus.gif- html/plus.gif- html/frames.html+ html/haddock-DEBUG.css+ html/haddock.css+ html/haddock-util.js+ html/haskell_icon.gif+ html/minus.gif+ html/plus.gif+ html/frames.html flag in-ghc-tree description: Are we in a GHC tree?@@ -65,13 +65,15 @@ executable haddock build-depends:+ base >= 4.0.0.0 && < 4.2.0.0, haskell98,- ghc >= 6.8.2 && < 6.13, filepath, directory, pretty, containers,- array+ array,+ Cabal >= 1.5,+ ghc == 6.10.* || == 6.11.* if flag(in-ghc-tree) cpp-options: -DIN_GHC_TREE@@ -79,17 +81,11 @@ else build-depends: ghc-paths - if impl(ghc >= 6.9)- build-depends: Cabal >= 1.5- build-depends: base >= 4.0.0.0 && < 4.2.0.0- else- build-depends: base < 4.0.0.0- main-is: Main.hs hs-source-dirs: src extensions: CPP, PatternGuards, DeriveDataTypeable, ScopedTypeVariables, MagicHash- ghc-options: -funbox-strict-fields -O2+ ghc-options: -funbox-strict-fields -O2 -Wall other-modules: Haddock.Interface@@ -108,22 +104,20 @@ Haddock.Backends.Hoogle Haddock.ModuleTree Haddock.Types- Haddock.DocName Haddock.Version Haddock.InterfaceFile - Haddock.Exception Haddock.Options- Haddock.GHC.Typecheck- Haddock.GHC.Utils- Haddock.GHC+ Haddock.GhcUtils -- Cabal doesn't define __GHC_PATCHLEVEL__ if impl(ghc == 6.10.1) cpp-options: -D__GHC_PATCHLEVEL__=1- if impl(ghc == 6.8.3)- cpp-options: -D__GHC_PATCHLEVEL__=3- if impl(ghc == 6.8.2) || impl(ghc >= 6.10.1.20090223)+ if impl(ghc == 6.10.2) cpp-options: -D__GHC_PATCHLEVEL__=2+ if impl(ghc == 6.10.3)+ cpp-options: -D__GHC_PATCHLEVEL__=3+ if impl(ghc == 6.10.4)+ cpp-options: -D__GHC_PATCHLEVEL__=4 library hs-source-dirs: src@@ -131,17 +125,21 @@ ScopedTypeVariables, MagicHash exposed-modules: Distribution.Haddock other-modules:- Haddock.DocName Haddock.Types Haddock.InterfaceFile- Haddock.Exception Haddock.Utils- Haddock.GHC.Utils+ Haddock.GhcUtils -- Cabal doesn't define __GHC_PATCHLEVEL__ if impl(ghc == 6.10.1) cpp-options: -D__GHC_PATCHLEVEL__=1- if impl(ghc == 6.8.3)- cpp-options: -D__GHC_PATCHLEVEL__=3- if impl(ghc == 6.8.2) || impl(ghc >= 6.10.1.20090223)+ if impl(ghc == 6.10.2) cpp-options: -D__GHC_PATCHLEVEL__=2+ if impl(ghc == 6.10.3)+ cpp-options: -D__GHC_PATCHLEVEL__=3+ if impl(ghc == 6.10.4)+ cpp-options: -D__GHC_PATCHLEVEL__=4++ if flag(in-ghc-tree)+ buildable: False+
haddock.spec view
@@ -17,7 +17,7 @@ # version label of your release tarball. %define name haddock-%define version 2.4.2+%define version 2.5.0 %define release 1 Name: %{name}
src/Distribution/Haddock.hs view
@@ -13,10 +13,11 @@ InterfaceFile(..), LinkEnv, InstalledInterface(..),- module Haddock.DocName+ DocName(..),+ docNameOcc ) where import Haddock.InterfaceFile import Haddock.Types-import Haddock.DocName+
src/Haddock/Backends/DevHelp.hs view
@@ -1,8 +1,14 @@------ Haddock - A Haskell Documentation Tool------ (c) Simon Marlow 2003+-----------------------------------------------------------------------------+-- |+-- Module : Haddock.Backends.DevHelp+-- Copyright : (c) Simon Marlow 2003-2006,+-- David Waern 2006+-- License : BSD-like --+-- Maintainer : haddock@projects.haskell.org+-- Stability : experimental+-- Portability : portable+----------------------------------------------------------------------------- module Haddock.Backends.DevHelp (ppDevHelpFile) where @@ -21,9 +27,9 @@ import Text.PrettyPrint ppDevHelpFile :: FilePath -> String -> Maybe String -> [Interface] -> IO ()-ppDevHelpFile odir doctitle maybe_package modules = do+ppDevHelpFile odir doctitle maybe_package ifaces = do let devHelpFile = package++".devhelp"- tree = mkModuleTree True [ (ifaceMod mod, toDescription mod) | mod <- modules ]+ tree = mkModuleTree True [ (ifaceMod iface, toDescription iface) | iface <- ifaces ] doc = text "<?xml version=\"1.0\" encoding=\"utf-8\" standalone=\"no\"?>" $$ (text "<book xmlns=\"http://www.devhelp.net/book\" title=\""<>text doctitle<>@@ -48,7 +54,7 @@ ppNode ss (Node s leaf _ _short ts) = case ts of [] -> text "<sub"<+>ppAttribs<>text "/>"- ts -> + _ -> text "<sub"<+>ppAttribs<>text ">" $$ nest 4 (ppModuleTree (s:ss) ts) $+$ text "</sub>"@@ -64,11 +70,11 @@ -- reconstruct the module name index :: [(Name, [Module])]- index = Map.toAscList (foldr getModuleIndex Map.empty modules)+ index = Map.toAscList (foldr getModuleIndex Map.empty ifaces) getModuleIndex iface fm =- Map.unionWith (++) (Map.fromListWith (flip (++)) [(name, [mod]) | name <- ifaceExports iface, nameModule name == mod]) fm- where mod = ifaceMod iface+ Map.unionWith (++) (Map.fromListWith (flip (++)) [(name, [mdl]) | name <- ifaceExports iface, nameModule name == mdl]) fm+ where mdl = ifaceMod iface ppList :: [(Name, [Module])] -> Doc ppList [] = empty@@ -77,7 +83,7 @@ ppList mdls ppReference :: Name -> [Module] -> Doc- ppReference name [] = empty- ppReference name (mod:refs) = - text "<function name=\""<>text (escapeStr (getOccString name))<>text"\" link=\""<>text (nameHtmlRef mod (nameOccName name))<>text"\"/>" $$+ ppReference _ [] = empty+ ppReference name (mdl:refs) = + text "<function name=\""<>text (escapeStr (getOccString name))<>text"\" link=\""<>text (nameHtmlRef mdl (nameOccName name))<>text"\"/>" $$ ppReference name refs
src/Haddock/Backends/HH.hs view
@@ -1,8 +1,13 @@------ Haddock - A Haskell Documentation Tool------ (c) Simon Marlow 2003+-----------------------------------------------------------------------------+-- |+-- Module : Haddock.Backends.HH+-- Copyright : (c) Simon Marlow 2003+-- License : BSD-like --+-- Maintainer : haddock@projects.haskell.org+-- Stability : experimental+-- Portability : portable+----------------------------------------------------------------------------- module Haddock.Backends.HH (ppHHContents, ppHHIndex, ppHHProject) where
src/Haddock/Backends/HH2.hs view
@@ -1,22 +1,28 @@------ Haddock - A Haskell Documentation Tool------ (c) Simon Marlow 2003+-----------------------------------------------------------------------------+-- |+-- Module : Haddock.Backends.HH2+-- Copyright : (c) Simon Marlow 2003+-- License : BSD-like ---+-- Maintainer : haddock@projects.haskell.org+-- Stability : experimental+-- Portability : portable+----------------------------------------------------------------------------- module Haddock.Backends.HH2 (ppHH2Contents, ppHH2Index, ppHH2Files, ppHH2Collection) where +import Haddock.Types -ppHH2Contents, ppHH2Index, ppHH2Files, ppHH2Collection :: a+ppHH2Files :: FilePath -> Maybe String -> [Interface] -> [FilePath] -> IO ()+ppHH2Files = error "not yet"++ppHH2Contents, ppHH2Index, ppHH2Collection :: a ppHH2Contents = error "not yet" ppHH2Index = error "not yet"-ppHH2Files = error "not yet" ppHH2Collection = error "not yet" {- import HaddockModuleTree-import HaddockTypes import HaddockUtil import HsSyn2 hiding(Doc) import qualified Map
src/Haddock/Backends/HaddockDB.hs view
@@ -1,8 +1,13 @@------ Haddock - A Haskell Documentation Tool------ (c) Simon Marlow 2003+-----------------------------------------------------------------------------+-- |+-- 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 @@ -17,6 +22,7 @@ ----------------------------------------------------------------------------- -- Printing the results in DocBook format +ppDocBook :: a ppDocBook = error "not working" {- ppDocBook :: FilePath -> [(Module, Interface)] -> String
src/Haddock/Backends/Hoogle.hs view
@@ -1,33 +1,36 @@------ Haddock - A Haskell Documentation Tool+-----------------------------------------------------------------------------+-- |+-- Module : Haddock.Backends.Hoogle+-- Copyright : (c) Neil Mitchell 2006-2008+-- License : BSD-like ----- (c) Simon Marlow 2003+-- Maintainer : haddock@projects.haskell.org+-- Stability : experimental+-- Portability : portable ----- This file, (c) Neil Mitchell 2006-2008 -- Write out Hoogle compatible documentation -- http://www.haskell.org/hoogle/+----------------------------------------------------------------------------- module Haddock.Backends.Hoogle ( ppHoogle ) where -import Haddock.GHC-import Haddock.GHC.Utils+import Haddock.GhcUtils import Haddock.Types-import Haddock.Utils+import Haddock.Utils hiding (out) import GHC-import SrcLoc import Outputable import Control.Monad import Data.Char import Data.List import Data.Maybe-import qualified Data.Set as Set import System.FilePath +prefix :: [String] prefix = ["-- Hoogle documentation, generated by Haddock" ,"-- See Hoogle, http://www.haskell.org/hoogle/" ,""]@@ -68,19 +71,22 @@ 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 b) = f $ unL a+ f (HsDocTy a _) = f $ unL a f x = x outHsType :: OutputableBndr a => HsType a -> String outHsType = out . 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 [] = []@@ -134,14 +140,16 @@ concatMap (ppSig . addContext . unL) (tcdSigs x) where addContext (TypeSig name (L l sig)) = TypeSig name (L l $ f sig)+ addContext _ = error "expected TypeSig"+ f (HsForAllTy a b con d) = HsForAllTy a b (reL $ context : unL con) d- f x = HsForAllTy Implicit [] (reL [context]) (reL x)+ f t = HsForAllTy Implicit [] (reL [context]) (reL t) context = reL $ HsClassP (unL $ tcdLName x) (map (reL . HsTyVar . tyVar . unL) (tcdTyVars x)) - tyVar (UserTyVar x) = x- tyVar (KindedTyVar x _) = x+ tyVar (UserTyVar v) = v+ tyVar (KindedTyVar v _) = v ppInstance :: Instance -> [String]@@ -154,11 +162,11 @@ where -- GHC gives out "data Bar =", we want to delete the equals -- also writes data : a b, when we want data (:) a b- showData x = unwords $ map f $ if last xs == "=" then init xs else xs+ showData d = unwords $ map f $ if last xs == "=" then init xs else xs where- xs = words $ out x- nam = out $ tcdLName x- f x = if x == nam then operator nam else x+ xs = words $ out d+ nam = out $ tcdLName d+ f w = if w == nam then operator nam else w ppCtor :: TyClDecl Name -> ConDecl Name -> [String]@@ -174,7 +182,7 @@ funs = foldr1 (\x y -> reL $ HsFunTy (makeExplicitL x) (makeExplicitL y)) apps = foldl1 (\x y -> reL $ HsAppTy x y) - typeSig name flds = operator name ++ " :: " ++ outHsType (makeExplicit $ unL $ funs flds)+ typeSig nm flds = operator nm ++ " :: " ++ outHsType (makeExplicit $ unL $ funs flds) name = out $ unL $ con_name con resType = case con_res con of@@ -204,7 +212,10 @@ 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@@ -247,6 +258,7 @@ 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]@@ -282,7 +294,7 @@ unwordsWrap :: Int -> [String] -> [String] unwordsWrap n = f n [] where- f i s [] = [g s | s /= []]+ 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
src/Haddock/Backends/Html.hs view
@@ -1,9 +1,14 @@---- Haddock - A Haskell Documentation Tool------ (c) Simon Marlow 2003+-----------------------------------------------------------------------------+-- |+-- Module : Haddock.Backends.Html+-- Copyright : (c) Simon Marlow 2003-2006,+-- David Waern 2006-2009+-- License : BSD-like ---+-- Maintainer : haddock@projects.haskell.org+-- Stability : experimental+-- Portability : portable+----------------------------------------------------------------------------- module Haddock.Backends.Html ( ppHtml, copyHtmlBits, @@ -14,25 +19,25 @@ import Prelude hiding (div) -import Haddock.DocName import Haddock.Backends.DevHelp import Haddock.Backends.HH import Haddock.Backends.HH2 import Haddock.ModuleTree-import Haddock.Types+import Haddock.Types hiding ( Doc ) import Haddock.Version import Haddock.Utils-import Haddock.Utils.Html-import Haddock.GHC.Utils+import Haddock.Utils.Html hiding ( name, title, p ) import qualified Haddock.Utils.Html as Html+import Haddock.GhcUtils import Control.Exception ( bracket ) import Control.Monad ( when, unless, join )-import Data.Char ( isUpper, toUpper )+import Data.Char ( toUpper ) import Data.List ( sortBy, groupBy ) import Data.Maybe import Foreign.Marshal.Alloc ( allocaBytes ) import System.IO ( IOMode(..), hClose, hGetBuf, hPutBuf, openFile )+import System.Directory hiding ( copyFile ) import Data.Map ( Map ) import qualified Data.Map as Map hiding ( Map ) import Data.Function@@ -45,18 +50,20 @@ #endif import Name import Module-import PackageConfig-import RdrName hiding ( Qual )-import SrcLoc +import RdrName hiding ( Qual, is_explicit ) import FastString ( unpackFS ) import BasicTypes ( IPName(..), Boxity(..) )-import Type ( Kind )-import Outputable ( ppr, defaultUserStyle, showSDoc )+import Outputable ( ppr, showSDoc, Outputable ) -- the base, module and entity URLs for the source code and wiki links. type SourceURLs = (Maybe String, Maybe String, Maybe String) type WikiURLs = (Maybe String, Maybe String, Maybe String) ++-- convenient short-hands+type Doc = HsDoc DocName++ -- ----------------------------------------------------------------------------- -- Generating HTML documentation @@ -70,11 +77,12 @@ -> 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) -> IO () ppHtml doctitle maybe_package ifaces odir prologue maybe_html_help_format maybe_source_url maybe_wiki_url- maybe_contents_url maybe_index_url = do+ maybe_contents_url maybe_index_url unicode = do let visible_ifaces = filter visible ifaces visible i = OptHide `notElem` ifaceOptions i@@ -95,7 +103,7 @@ mapM_ (ppHtmlModule odir doctitle maybe_source_url maybe_wiki_url- maybe_contents_url maybe_index_url) visible_ifaces+ maybe_contents_url maybe_index_url unicode) visible_ifaces ppHtmlHelpFiles :: String -- doctitle@@ -174,9 +182,9 @@ spliceURL maybe_file maybe_mod maybe_name maybe_loc url = run url where file = fromMaybe "" maybe_file- mod = case maybe_mod of+ mdl = case maybe_mod of Nothing -> ""- Just mod -> moduleString mod + Just m -> moduleString m (name, kind) = case maybe_name of@@ -186,23 +194,23 @@ line = case maybe_loc of Nothing -> ""- Just span -> show $ srcSpanStartLine span+ Just span_ -> show $ srcSpanStartLine span_ run "" = ""- run ('%':'M':rest) = mod ++ run rest+ 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) = mod ++ 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) mod ++ run 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@@ -215,8 +223,8 @@ wikiButton (Just wiki_base_url, _, _) Nothing = topButBox (anchor ! [href wiki_base_url] << toHtml "User Comments") -wikiButton (_, Just wiki_module_url, _) (Just mod) =- let url = spliceURL Nothing (Just mod) Nothing Nothing wiki_module_url+wikiButton (_, Just wiki_module_url, _) (Just mdl) =+ let url = spliceURL Nothing (Just mdl) Nothing Nothing wiki_module_url in topButBox (anchor ! [href url] << toHtml "User Comments") wikiButton _ _ =@@ -225,16 +233,12 @@ contentsButton :: Maybe String -> HtmlTable contentsButton maybe_contents_url = topButBox (anchor ! [href url] << toHtml "Contents")- where url = case maybe_contents_url of- Nothing -> contentsHtmlFile- Just url -> url+ where url = maybe contentsHtmlFile id maybe_contents_url indexButton :: Maybe String -> HtmlTable indexButton maybe_index_url = topButBox (anchor ! [href url] << toHtml "Index")- where url = case maybe_index_url of- Nothing -> indexHtmlFile- Just url -> url+ where url = maybe indexHtmlFile id maybe_index_url simpleHeader :: String -> Maybe String -> Maybe String -> SourceURLs -> WikiURLs -> HtmlTable@@ -316,7 +320,7 @@ maybe_package maybe_html_help_format maybe_index_url maybe_source_url maybe_wiki_url ifaces showPkgs prologue = do let tree = mkModuleTree showPkgs- [(instMod mod, toInstalledDescription mod) | mod <- ifaces]+ [(instMod iface, toInstalledDescription iface) | iface <- ifaces] html = header (documentCharacterEncoding +++@@ -331,6 +335,7 @@ s15 </> footer )+ createDirectoryIfMissing True odir writeFile (pathJoin [odir, contentsHtmlFile]) (renderHtml html) -- XXX: think of a better place for this?@@ -345,7 +350,7 @@ Just format -> fail ("The "++format++" format is not implemented") ppPrologue :: String -> Maybe (GHC.HsDoc GHC.RdrName) -> HtmlTable-ppPrologue title Nothing = Html.emptyTable+ppPrologue _ Nothing = Html.emptyTable ppPrologue title (Just doc) = (tda [theclass "section1"] << toHtml title) </> docBox (rdrDocToHtml doc)@@ -355,29 +360,30 @@ tda [theclass "section1"] << toHtml "Modules" </> td << vanillaTable2 << htmlTable where- genTable htmlTable id [] = (htmlTable,id)- genTable htmlTable id (x:xs) = genTable (htmlTable </> u) id' xs + genTable tbl id_ [] = (tbl, id_)+ genTable tbl id_ (x:xs) = genTable (tbl </> u) id' xs where- (u,id') = mkNode [] x 0 id+ (u,id') = mkNode [] x 0 id_ (htmlTable,_) = genTable emptyTable 0 ts mkNode :: [String] -> ModuleTree -> Int -> Int -> (HtmlTable,Int)-mkNode ss (Node s leaf pkg short ts) depth id = htmlNode+mkNode ss (Node s leaf pkg short ts) depth id_ = htmlNode where htmlNode = case ts of- [] -> (td_pad_w 1.25 depth << htmlModule <-> shortDescr <-> htmlPkg,id)+ [] -> (td_pad_w 1.25 depth << htmlModule <-> shortDescr <-> htmlPkg,id_) _ -> (td_w depth << (collapsebutton id_s +++ htmlModule) <-> shortDescr <-> htmlPkg </> (td_subtree << sub_tree), id') mod_width = 50::Int {-em-} - td_pad_w pad depth = + td_pad_w :: Double -> Int -> Html -> HtmlTable+ td_pad_w pad depth_ = tda [thestyle ("padding-left: " ++ show pad ++ "em;" ++- "width: " ++ show (mod_width - depth*2) ++ "em")]+ "width: " ++ show (mod_width - depth_*2) ++ "em")] - td_w depth = - tda [thestyle ("width: " ++ show (mod_width - depth*2) ++ "em")]+ td_w depth_ = + tda [thestyle ("width: " ++ show (mod_width - depth_*2) ++ "em")] td_subtree = tda [thestyle ("padding: 0; padding-left: 2em")]@@ -401,17 +407,17 @@ (s':ss') = reverse (s:ss) -- reconstruct the module name - id_s = "n:" ++ show id+ id_s = "n:" ++ show id_ - (sub_tree,id') = genSubTree emptyTable (id+1) ts+ (sub_tree,id') = genSubTree emptyTable (id_+1) ts genSubTree :: HtmlTable -> Int -> [ModuleTree] -> (Html,Int)- genSubTree htmlTable id [] = (sub_tree,id)+ genSubTree htmlTable id__ [] = (sub_tree_, id__) where- sub_tree = collapsed vanillaTable2 id_s htmlTable- genSubTree htmlTable id (x:xs) = genSubTree (htmlTable </> u) id' xs + sub_tree_ = collapsed vanillaTable2 id_s htmlTable+ genSubTree htmlTable id__ (x:xs) = genSubTree (htmlTable </> u) id__' xs where- (u,id') = mkNode (s:ss) x (depth+1) id+ (u,id__') = mkNode (s:ss) x (depth+1) id__ -- The URL for source and wiki links, and the current module type LinksInfo = (SourceURLs, WikiURLs)@@ -431,11 +437,12 @@ . sortBy (comparing fst) $ mods where- mods = [ (moduleString mod, mod) | mod <- map instMod ifaces ]- ppModule' txt mod =- anchor ! [href ((moduleHtmlFile mod)), target mainFrameName]+ mods = [ (moduleString mdl, mdl) | mdl <- map instMod ifaces ]+ ppModule' txt mdl =+ anchor ! [href ((moduleHtmlFile mdl)), target mainFrameName] << toHtml txt +ppHtmlContentsFrame :: FilePath -> String -> [InstalledInterface] -> IO () ppHtmlContentsFrame odir doctitle ifaces = do let mods = flatModuleTree ifaces html =@@ -444,8 +451,9 @@ thetitle (toHtml doctitle) +++ styleSheet +++ (script ! [src jsFile, thetype "text/javascript"] $ noHtml)) +++- body << vanillaTable << p << (+ body << vanillaTable << Html.p << ( foldr (+++) noHtml (map (+++br) mods))+ createDirectoryIfMissing True odir writeFile (pathJoin [odir, frameIndexHtmlFile]) (renderHtml html) -- ---------------------------------------------------------------------------@@ -470,9 +478,14 @@ body << vanillaTable << ( simpleHeader doctitle maybe_contents_url Nothing maybe_source_url maybe_wiki_url </>- search_box </> index_html+ index_html ) + createDirectoryIfMissing True odir++ when split_indices $+ mapM_ (do_sub_index index) initialChars+ writeFile (pathJoin [odir, indexHtmlFile]) (renderHtml html) -- Generate index and contents page for Html Help if requested@@ -483,20 +496,23 @@ Just "devhelp" -> return () Just format -> fail ("The "++format++" format is not implemented") where- -- colspan 2, marginheight 5- search_box :: HtmlTable- search_box = tda [colspan 2, thestyle "padding-top:5px;"] << search- where- search :: Html- search = form ! [strAttr "onsubmit" "full_search(); return false;", action ""] << (- "Search: "- +++ input ! [identifier "searchbox", strAttr "onkeyup" "quick_search()"]- +++ " " +++ input ! [value "Search", thetype "submit"]- +++ " " +++ thespan ! [identifier "searchmsg"] << " ") - index_html = td << setTrClass (table ! [identifier "indexlist", cellpadding 0, cellspacing 5] <<- aboves (map indexElt index))+ index_html+ | split_indices = + tda [theclass "section1"] << + toHtml ("Index") </>+ indexInitialLetterLinks+ | otherwise =+ td << setTrClass (table ! [identifier "indexlist", cellpadding 0, cellspacing 5] <<+ aboves (map indexElt index)) + -- 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+ setTrClass :: Html -> Html setTrClass (Html xs) = Html $ map f xs where@@ -504,7 +520,41 @@ | map toUpper name == "TR" = HtmlTag name (theclass "indexrow":attrs) inner | otherwise = HtmlTag name attrs (setTrClass inner) f x = x+ + indexInitialLetterLinks = + td << setTrClass (table ! [cellpadding 0, cellspacing 5] <<+ besides [ td << anchor ! [href (subIndexHtmlFile c)] <<+ toHtml [c]+ | c <- initialChars+ , any ((==c) . toUpper . head . fst) index ]) + -- 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 (pathJoin [odir, subIndexHtmlFile c]) (renderHtml html)+ where + html = header (documentCharacterEncoding ++++ thetitle (toHtml (doctitle ++ " (Index)")) ++++ styleSheet) ++++ body << vanillaTable << (+ simpleHeader doctitle maybe_contents_url Nothing+ maybe_source_url maybe_wiki_url </>+ indexInitialLetterLinks </>+ tda [theclass "section1"] << + toHtml ("Index (" ++ c:")") </>+ td << setTrClass (table ! [identifier "indexlist", cellpadding 0, cellspacing 5] <<+ aboves (map indexElt 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,_) = map toUpper n1 `compare` map toUpper n2@@ -533,6 +583,7 @@ tda [ theclass "indexentry" ] << toHtml str </> aboves (map doAnnotatedEntity (zip [1..] many_entities)) + doAnnotatedEntity :: (Integer, (Name, [(Module, Bool)])) -> HtmlTable doAnnotatedEntity (j,(nm,entries)) = tda [ theclass "indexannot" ] << toHtml (show j) <+> parens (ppAnnot (nameOccName nm)) <->@@ -546,10 +597,10 @@ tda [ theclass "indexlinks" ] << hsep (punctuate comma [ if visible then- linkId mod (Just nm) << toHtml (moduleString mod)+ linkId mdl (Just nm) << toHtml (moduleString mdl) else- toHtml (moduleString mod)- | (mod, visible) <- entries ])+ toHtml (moduleString mdl)+ | (mdl, visible) <- entries ]) -- --------------------------------------------------------------------------- -- Generate the HTML page for a module@@ -557,51 +608,53 @@ ppHtmlModule :: FilePath -> String -> SourceURLs -> WikiURLs- -> Maybe String -> Maybe String+ -> Maybe String -> Maybe String -> Bool -> Interface -> IO () ppHtmlModule odir doctitle maybe_source_url maybe_wiki_url- maybe_contents_url maybe_index_url iface = do+ maybe_contents_url maybe_index_url unicode iface = do let - mod = ifaceMod iface- mdl = moduleString mod+ mdl = ifaceMod iface+ mdl_str = moduleString mdl html = header (documentCharacterEncoding +++- thetitle (toHtml mdl) ++++ thetitle (toHtml mdl_str) +++ styleSheet +++ (script ! [src jsFile, thetype "text/javascript"] $ noHtml) +++ (script ! [thetype "text/javascript"] -- XXX: quoting errors possible? << Html [HtmlString ("window.onload = function () {setSynopsis(\"mini_" - ++ moduleHtmlFile mod ++ "\")};")])+ ++ moduleHtmlFile mdl ++ "\")};")]) ) +++ body << vanillaTable << (- pageHeader mdl iface doctitle+ pageHeader mdl_str iface doctitle maybe_source_url maybe_wiki_url maybe_contents_url maybe_index_url </> s15 </>- ifaceToHtml maybe_source_url maybe_wiki_url iface </> s15 </>+ ifaceToHtml maybe_source_url maybe_wiki_url iface unicode </> s15 </> footer )- writeFile (pathJoin [odir, moduleHtmlFile mod]) (renderHtml html)- ppHtmlModuleMiniSynopsis odir doctitle iface+ createDirectoryIfMissing True odir+ writeFile (pathJoin [odir, moduleHtmlFile mdl]) (renderHtml html)+ ppHtmlModuleMiniSynopsis odir doctitle iface unicode -ppHtmlModuleMiniSynopsis :: FilePath -> String -> Interface -> IO ()-ppHtmlModuleMiniSynopsis odir _doctitle iface = do- let mod = ifaceMod iface+ppHtmlModuleMiniSynopsis :: FilePath -> String -> Interface -> Bool -> IO ()+ppHtmlModuleMiniSynopsis odir _doctitle iface unicode = do+ let mdl = ifaceMod iface html = header (documentCharacterEncoding +++- thetitle (toHtml $ moduleString mod) ++++ thetitle (toHtml $ moduleString mdl) +++ styleSheet +++ (script ! [src jsFile, thetype "text/javascript"] $ noHtml)) +++ body << thediv ! [ theclass "outer" ] << ( (thediv ! [theclass "mini-topbar"]- << toHtml (moduleString mod)) +++- miniSynopsis mod iface)- writeFile (pathJoin [odir, "mini_" ++ moduleHtmlFile mod]) (renderHtml html)+ << toHtml (moduleString mdl)) ++++ miniSynopsis mdl iface unicode)+ createDirectoryIfMissing True odir+ writeFile (pathJoin [odir, "mini_" ++ moduleHtmlFile mdl]) (renderHtml html) -ifaceToHtml :: SourceURLs -> WikiURLs -> Interface -> HtmlTable-ifaceToHtml maybe_source_url maybe_wiki_url iface+ifaceToHtml :: SourceURLs -> WikiURLs -> Interface -> Bool -> HtmlTable+ifaceToHtml maybe_source_url maybe_wiki_url iface unicode = abovesSep s15 (contents ++ description: synopsis: maybe_doc_hdr: bdy) where docMap = ifaceRnDocMap iface@@ -632,7 +685,7 @@ = (tda [theclass "section1"] << toHtml "Synopsis") </> s15 </> (tda [theclass "body"] << vanillaTable <<- abovesSep s8 (map (processExport True linksInfo docMap)+ abovesSep s8 (map (processExport True linksInfo docMap unicode) (filter forSummary exports)) ) @@ -644,55 +697,56 @@ ExportGroup _ _ _ : _ -> Html.emptyTable _ -> tda [ theclass "section1" ] << toHtml "Documentation" - bdy = map (processExport False linksInfo docMap) exports+ bdy = map (processExport False linksInfo docMap unicode) exports linksInfo = (maybe_source_url, maybe_wiki_url) -miniSynopsis :: Module -> Interface -> Html-miniSynopsis mod iface =+miniSynopsis :: Module -> Interface -> Bool -> Html+miniSynopsis mdl iface unicode = thediv ! [ theclass "mini-synopsis" ]- << hsep (map (processForMiniSynopsis mod) $ exports)-+ << hsep (map (processForMiniSynopsis mdl unicode) $ exports) where exports = numberSectionHeadings (ifaceRnExportItems iface) -processForMiniSynopsis :: Module -> ExportItem DocName -> Html-processForMiniSynopsis mod (ExportDecl (L _loc decl0) _doc _ _insts) =+processForMiniSynopsis :: Module -> Bool -> ExportItem DocName -> Html+processForMiniSynopsis mdl unicode (ExportDecl (L _loc decl0) _doc _ _insts) = thediv ! [theclass "decl" ] << case decl0 of- TyClD d@(TyFamily{}) -> ppTyFamHeader True False d+ TyClD d@(TyFamily{}) -> ppTyFamHeader True False d unicode TyClD d@(TyData{tcdTyPats = ps})- | Nothing <- ps -> keyword "data" <++> ppTyClBinderWithVarsMini mod d+ | Nothing <- ps -> keyword "data" <++> ppTyClBinderWithVarsMini mdl d | Just _ <- ps -> keyword "data" <++> keyword "instance"- <++> ppTyClBinderWithVarsMini mod d+ <++> ppTyClBinderWithVarsMini mdl d TyClD d@(TySynonym{tcdTyPats = ps})- | Nothing <- ps -> keyword "type" <++> ppTyClBinderWithVarsMini mod d+ | Nothing <- ps -> keyword "type" <++> ppTyClBinderWithVarsMini mdl d | Just _ <- ps -> keyword "type" <++> keyword "instance"- <++> ppTyClBinderWithVarsMini mod d+ <++> ppTyClBinderWithVarsMini mdl d TyClD d@(ClassDecl {}) ->- keyword "class" <++> ppTyClBinderWithVarsMini mod d- SigD (TypeSig (L _ n) (L _ t)) ->+ keyword "class" <++> ppTyClBinderWithVarsMini mdl d+ SigD (TypeSig (L _ n) (L _ _)) -> let nm = docNameOcc n- in ppNameMini mod nm+ in ppNameMini mdl nm _ -> noHtml-processForMiniSynopsis mod (ExportGroup lvl _id txt) =- let heading | lvl == 1 = h1- | lvl == 2 = h2- | lvl >= 3 = h3+processForMiniSynopsis _ _ (ExportGroup lvl _id txt) =+ let heading+ | lvl == 1 = h1+ | lvl == 2 = h2+ | lvl >= 3 = h3+ | otherwise = error "bad group level" in heading << docToHtml txt-processForMiniSynopsis _ _ = noHtml+processForMiniSynopsis _ _ _ = noHtml ppNameMini :: Module -> OccName -> Html-ppNameMini mod nm =- anchor ! [ href ( moduleHtmlFile mod ++ "#"+ppNameMini mdl nm =+ anchor ! [ href ( moduleHtmlFile mdl ++ "#" ++ (escapeStr (anchorNameStr nm))) , target mainFrameName ] << ppBinder' nm ppTyClBinderWithVarsMini :: Module -> TyClDecl DocName -> Html-ppTyClBinderWithVarsMini mod decl =+ppTyClBinderWithVarsMini mdl decl = let n = unLoc $ tcdLName decl ns = tyvarNames $ tcdTyVars decl- in ppTypeApp n ns (ppNameMini mod . docNameOcc) ppTyName+ in ppTypeApp n ns (ppNameMini mdl . docNameOcc) ppTyName ppModuleContents :: [ExportItem DocName] -> Maybe HtmlTable ppModuleContents exports@@ -728,19 +782,19 @@ go n (other:es) = other : go n es -processExport :: Bool -> LinksInfo -> DocMap -> (ExportItem DocName) -> HtmlTable-processExport _ _ _ (ExportGroup lev id0 doc)+processExport :: Bool -> LinksInfo -> DocMap -> Bool -> (ExportItem DocName) -> HtmlTable+processExport _ _ _ _ (ExportGroup lev id0 doc) = ppDocGroup lev (namedAnchor id0 << docToHtml doc)-processExport summary links docMap (ExportDecl decl doc subdocs insts)- = ppDecl summary links decl doc insts docMap subdocs-processExport summmary _ _ (ExportNoDecl y [])+processExport summary links docMap unicode (ExportDecl decl doc subdocs insts)+ = ppDecl summary links decl doc insts docMap subdocs unicode+processExport _ _ _ _ (ExportNoDecl y []) = declBox (ppDocName y)-processExport summmary _ _ (ExportNoDecl y subs)+processExport _ _ _ _ (ExportNoDecl y subs) = declBox (ppDocName y <+> parenList (map ppDocName subs))-processExport _ _ _ (ExportDoc doc)+processExport _ _ _ _ (ExportDoc doc) = docBox (docToHtml doc)-processExport _ _ _ (ExportModule mod)- = declBox (toHtml "module" <+> ppModule mod "")+processExport _ _ _ _ (ExportModule mdl)+ = declBox (toHtml "module" <+> ppModule mdl "") forSummary :: (ExportItem DocName) -> Bool forSummary (ExportGroup _ _ _) = False@@ -763,37 +817,38 @@ -- TODO: use DeclInfo DocName or something ppDecl :: Bool -> LinksInfo -> LHsDecl DocName -> - Maybe (HsDoc DocName) -> [InstHead DocName] -> DocMap -> [(DocName, Maybe (HsDoc DocName))] -> HtmlTable-ppDecl summ links (L loc decl) mbDoc instances docMap subdocs = case decl of- TyClD d@(TyFamily {}) -> ppTyFam summ False links loc mbDoc d+ Maybe (HsDoc DocName) -> [InstHead DocName] -> DocMap -> [(DocName, Maybe (HsDoc DocName))] -> Bool -> HtmlTable+ppDecl summ links (L loc decl) mbDoc instances docMap subdocs unicode = case decl of+ TyClD d@(TyFamily {}) -> ppTyFam summ False links loc mbDoc d unicode TyClD d@(TyData {})- | Nothing <- tcdTyPats d -> ppDataDecl summ links instances loc mbDoc d+ | Nothing <- tcdTyPats d -> ppDataDecl summ links instances loc mbDoc d unicode | Just _ <- tcdTyPats d -> ppDataInst summ links loc mbDoc d TyClD d@(TySynonym {})- | Nothing <- tcdTyPats d -> ppTySyn summ links loc mbDoc d- | Just _ <- tcdTyPats d -> ppTyInst summ False links loc mbDoc d- TyClD d@(ClassDecl {}) -> ppClassDecl summ links instances loc mbDoc docMap subdocs d- SigD (TypeSig (L _ n) (L _ t)) -> ppFunSig summ links loc mbDoc n t- ForD d -> ppFor summ links loc mbDoc d- InstD d -> Html.emptyTable+ | Nothing <- tcdTyPats d -> ppTySyn summ links loc mbDoc d unicode+ | Just _ <- tcdTyPats d -> ppTyInst summ False links loc mbDoc d unicode+ TyClD d@(ClassDecl {}) -> ppClassDecl summ links instances loc mbDoc docMap subdocs d unicode+ SigD (TypeSig (L _ n) (L _ t)) -> ppFunSig summ links loc mbDoc n t unicode+ ForD d -> ppFor summ links loc mbDoc d unicode+ InstD _ -> Html.emptyTable+ _ -> error "declaration not supported by ppDecl" ppFunSig :: Bool -> LinksInfo -> SrcSpan -> Maybe (HsDoc DocName) ->- DocName -> HsType DocName -> HtmlTable-ppFunSig summary links loc mbDoc docname typ =- ppTypeOrFunSig summary links loc docname typ mbDoc - (ppTypeSig summary occname typ, ppBinder False occname, dcolon)+ DocName -> HsType DocName -> Bool -> HtmlTable+ppFunSig summary links loc mbDoc docname typ unicode =+ ppTypeOrFunSig summary links loc docname typ mbDoc+ (ppTypeSig summary occname typ unicode, ppBinder False occname, dcolon unicode) unicode where- occname = nameOccName . docNameOrig $ docname+ occname = docNameOcc docname ppTypeOrFunSig :: Bool -> LinksInfo -> SrcSpan -> DocName -> HsType DocName ->- Maybe (HsDoc DocName) -> (Html, Html, Html) -> HtmlTable-ppTypeOrFunSig summary links loc docname typ doc (pref1, pref2, sep)+ Maybe (HsDoc DocName) -> (Html, Html, Html) -> Bool -> HtmlTable+ppTypeOrFunSig summary links loc docname typ doc (pref1, pref2, sep) unicode | summary || noArgDocs typ = declWithDoc summary links loc docname doc pref1 | otherwise = topDeclBox links loc docname pref2 </> (tda [theclass "body"] << vanillaTable << ( do_args sep typ </> (case doc of- Just doc -> ndocBox (docToHtml doc)+ Just d -> ndocBox (docToHtml d) Nothing -> Html.emptyTable) )) where @@ -809,63 +864,68 @@ do_args leader (HsForAllTy Explicit tvs lctxt ltype) = (argBox ( leader <+> - hsep (keyword "forall" : ppTyVars tvs ++ [dot]) <+>- ppLContextNoArrow lctxt)+ hsep (forallSymbol unicode : ppTyVars tvs ++ [dot]) <+>+ ppLContextNoArrow lctxt unicode) <-> rdocBox noHtml) </> - do_largs darrow ltype+ do_largs (darrow unicode) ltype do_args leader (HsForAllTy Implicit _ lctxt ltype)- = (argBox (leader <+> ppLContextNoArrow lctxt)+ = (argBox (leader <+> ppLContextNoArrow lctxt unicode) <-> rdocBox noHtml) </> - do_largs darrow ltype+ do_largs (darrow unicode) ltype do_args leader (HsFunTy (L _ (HsDocTy lt ldoc)) r)- = (argBox (leader <+> ppLType lt) <-> rdocBox (docToHtml (unLoc ldoc)))- </> do_largs arrow r+ = (argBox (leader <+> ppLType unicode lt) <-> rdocBox (docToHtml (unLoc ldoc)))+ </> do_largs (arrow unicode) r do_args leader (HsFunTy lt r)- = (argBox (leader <+> ppLType lt) <-> rdocBox noHtml) </> do_largs arrow r+ = (argBox (leader <+> ppLType unicode lt) <-> rdocBox noHtml) </> do_largs (arrow unicode) r do_args leader (HsDocTy lt ldoc)- = (argBox (leader <+> ppLType lt) <-> rdocBox (docToHtml (unLoc ldoc)))+ = (argBox (leader <+> ppLType unicode lt) <-> rdocBox (docToHtml (unLoc ldoc))) do_args leader t- = argBox (leader <+> ppType t) <-> rdocBox (noHtml)+ = argBox (leader <+> ppType unicode t) <-> rdocBox (noHtml) -ppTyVars tvs = ppTyNames (tyvarNames tvs)+ppTyVars :: [LHsTyVarBndr DocName] -> [Html]+ppTyVars tvs = map ppTyName (tyvarNames tvs) -tyvarNames = map f - where f x = docNameOrig . hsTyVarName . unLoc $ x++tyvarNames :: [LHsTyVarBndr DocName] -> [Name]+tyvarNames = map (getName . hsTyVarName . unLoc) -ppFor summary links loc mbDoc (ForeignImport (L _ name) (L _ typ) _)- = ppFunSig summary links loc mbDoc name typ-ppFor _ _ _ _ _ = error "ppFor" +ppFor :: Bool -> LinksInfo -> SrcSpan -> Maybe Doc -> ForeignDecl DocName -> Bool -> HtmlTable+ppFor summary links loc mbDoc (ForeignImport (L _ name) (L _ typ) _) unicode+ = ppFunSig summary links loc mbDoc name typ unicode+ppFor _ _ _ _ _ _ = error "ppFor"++ -- we skip type patterns for now-ppTySyn summary links loc mbDoc (TySynonym (L _ name) ltyvars _ ltype) +ppTySyn :: Bool -> LinksInfo -> SrcSpan -> Maybe Doc -> TyClDecl DocName -> Bool -> HtmlTable+ppTySyn summary links loc mbDoc (TySynonym (L _ name) ltyvars _ ltype) unicode = ppTypeOrFunSig summary links loc name (unLoc ltype) mbDoc - (full, hdr, spaceHtml +++ equals)+ (full, hdr, spaceHtml +++ equals) unicode where hdr = hsep ([keyword "type", ppBinder summary occ] ++ ppTyVars ltyvars)- full = hdr <+> equals <+> ppLType ltype+ full = hdr <+> equals <+> ppLType unicode ltype occ = docNameOcc name+ppTySyn _ _ _ _ _ _ = error "declaration not supported by ppTySyn" -ppTypeSig :: Bool -> OccName -> HsType DocName -> Html-ppTypeSig summary nm ty = ppBinder summary nm <+> dcolon <+> ppType ty+ppTypeSig :: Bool -> OccName -> HsType DocName -> Bool -> Html+ppTypeSig summary nm ty unicode = ppBinder summary nm <+> dcolon unicode <+> ppType unicode ty +ppTyName :: Name -> Html ppTyName name | isNameSym name = parens (ppName name) | otherwise = ppName name -ppTyNames = map ppTyName-- -------------------------------------------------------------------------------- -- Type families -------------------------------------------------------------------------------- -ppTyFamHeader :: Bool -> Bool -> TyClDecl DocName -> Html-ppTyFamHeader summary associated decl =+ppTyFamHeader :: Bool -> Bool -> TyClDecl DocName -> Bool -> Html+ppTyFamHeader summary associated decl unicode = (case tcdFlavour decl of TypeFamily@@ -879,38 +939,38 @@ ppTyClBinderWithVars summary decl <+> case tcdKind decl of- Just kind -> dcolon <+> ppKind kind + Just kind -> dcolon unicode <+> ppKind kind Nothing -> empty ppTyFam :: Bool -> Bool -> LinksInfo -> SrcSpan -> Maybe (HsDoc DocName) ->- TyClDecl DocName -> HtmlTable-ppTyFam summary associated links loc mbDoc decl+ TyClDecl DocName -> Bool -> HtmlTable+ppTyFam summary associated links loc mbDoc decl unicode | summary = declWithDoc summary links loc docname mbDoc - (ppTyFamHeader True associated decl)+ (ppTyFamHeader True associated decl unicode) - | associated, isJust mbDoc = header </> bodyBox << doc - | associated = header - | null instances, isJust mbDoc = header </> bodyBox << doc- | null instances = header- | isJust mbDoc = header </> bodyBox << (doc </> instancesBit)- | otherwise = header </> bodyBox << instancesBit+ | associated, isJust mbDoc = header_ </> bodyBox << doc + | associated = header_ + | null instances, isJust mbDoc = header_ </> bodyBox << doc+ | null instances = header_+ | isJust mbDoc = header_ </> bodyBox << (doc </> instancesBit)+ | otherwise = header_ </> bodyBox << instancesBit where docname = tcdName decl - header = topDeclBox links loc docname (ppTyFamHeader summary associated decl)+ header_ = topDeclBox links loc docname (ppTyFamHeader summary associated decl unicode) doc = ndocBox . docToHtml . fromJust $ mbDoc - instId = collapseId (docNameOrig docname)+ instId = collapseId (getName docname) instancesBit = instHdr instId </> tda [theclass "body"] << collapsed thediv instId ( spacedTable1 << (- aboves (map (declBox . ppInstHead) instances)+ aboves (map (declBox . ppInstHead unicode) instances) ) ) @@ -923,6 +983,7 @@ -------------------------------------------------------------------------------- +ppDataInst :: a ppDataInst = undefined @@ -930,8 +991,8 @@ -- Indexed newtypes -------------------------------------------------------------------------------- --ppNewTyInst = undefined+-- TODO+-- ppNewTyInst = undefined --------------------------------------------------------------------------------@@ -940,31 +1001,29 @@ ppTyInst :: Bool -> Bool -> LinksInfo -> SrcSpan -> Maybe (HsDoc DocName) ->- TyClDecl DocName -> HtmlTable-ppTyInst summary associated links loc mbDoc decl+ TyClDecl DocName -> Bool -> HtmlTable+ppTyInst summary associated links loc mbDoc decl unicode | summary = declWithDoc summary links loc docname mbDoc- (ppTyInstHeader True associated decl)+ (ppTyInstHeader True associated decl unicode) - | isJust mbDoc = header </> bodyBox << doc - | otherwise = header+ | isJust mbDoc = header_ </> bodyBox << doc + | otherwise = header_ where docname = tcdName decl - header = topDeclBox links loc docname (ppTyInstHeader summary associated decl)+ header_ = topDeclBox links loc docname (ppTyInstHeader summary associated decl unicode) doc = case mbDoc of Just d -> ndocBox (docToHtml d) Nothing -> Html.emptyTable -ppTyInstHeader :: Bool -> Bool -> TyClDecl DocName -> Html-ppTyInstHeader summary associated decl =-+ppTyInstHeader :: Bool -> Bool -> TyClDecl DocName -> Bool -> Html+ppTyInstHeader _ _ decl unicode = keyword "type instance" <+>-- ppAppNameTypes (tcdName decl) typeArgs+ ppAppNameTypes (tcdName decl) typeArgs unicode where typeArgs = map unLoc . fromJust . tcdTyPats $ decl @@ -974,11 +1033,12 @@ -------------------------------------------------------------------------------- -ppAssocType :: Bool -> LinksInfo -> Maybe (HsDoc DocName) -> LTyClDecl DocName -> HtmlTable-ppAssocType summ links doc (L loc decl) = +ppAssocType :: Bool -> LinksInfo -> Maybe (HsDoc DocName) -> LTyClDecl DocName -> Bool -> HtmlTable+ppAssocType summ links doc (L loc decl) unicode = case decl of- TyFamily {} -> ppTyFam summ True links loc doc decl- TySynonym {} -> ppTySyn summ links loc doc decl+ TyFamily {} -> ppTyFam summ True links loc doc decl unicode+ TySynonym {} -> ppTySyn summ links loc doc decl unicode+ _ -> error "declaration type not supported by ppAssocType" --------------------------------------------------------------------------------@@ -998,8 +1058,8 @@ -- | Print an application of a DocName and a list of HsTypes-ppAppNameTypes :: DocName -> [HsType DocName] -> Html-ppAppNameTypes n ts = ppTypeApp n ts ppDocName ppParendType+ppAppNameTypes :: DocName -> [HsType DocName] -> Bool -> Html+ppAppNameTypes n ts unicode = ppTypeApp n ts ppDocName (ppParendType unicode) -- | Print an application of a DocName and a list of Names @@ -1010,11 +1070,11 @@ -- | General printing of type applications ppTypeApp :: DocName -> [a] -> (DocName -> Html) -> (a -> Html) -> Html-ppTypeApp n ts@(t1:t2:rest) ppDN ppT+ppTypeApp n (t1:t2:rest) ppDN ppT | operator, not . null $ rest = parens opApp <+> hsep (map ppT rest) | operator = opApp where- operator = isNameSym . docNameOrig $ n+ operator = isNameSym . getName $ n opApp = ppT t1 <+> ppDN n <+> ppT t2 ppTypeApp n ts ppDN ppT = ppDN n <+> hsep (map ppT ts)@@ -1024,54 +1084,64 @@ -- Contexts ------------------------------------------------------------------------------- ++ppLContext, ppLContextNoArrow :: Located (HsContext DocName) -> Bool -> Html ppLContext = ppContext . unLoc ppLContextNoArrow = ppContextNoArrow . unLoc -ppContextNoArrow :: HsContext DocName -> Html-ppContextNoArrow [] = empty-ppContextNoArrow cxt = pp_hs_context (map unLoc cxt) -ppContextNoLocs :: [HsPred DocName] -> Html-ppContextNoLocs [] = empty-ppContextNoLocs cxt = pp_hs_context cxt <+> darrow +ppContextNoArrow :: HsContext DocName -> Bool -> Html+ppContextNoArrow [] _ = empty+ppContextNoArrow cxt unicode = pp_hs_context (map unLoc cxt) unicode -ppContext :: HsContext DocName -> Html-ppContext cxt = ppContextNoLocs (map unLoc cxt) -pp_hs_context [] = empty-pp_hs_context [p] = ppPred p-pp_hs_context cxt = parenList (map ppPred cxt) +ppContextNoLocs :: [HsPred DocName] -> Bool -> Html+ppContextNoLocs [] _ = empty+ppContextNoLocs cxt unicode = pp_hs_context cxt unicode <+> darrow unicode -ppLPred = ppPred . unLoc +ppContext :: HsContext DocName -> Bool -> Html+ppContext cxt unicode = ppContextNoLocs (map unLoc cxt) unicode -ppPred (HsClassP n ts) = ppAppNameTypes n (map unLoc ts)--- TODO: find out what happened to the Dupable/Linear distinction-ppPred (HsEqualP t1 t2) = ppLType t1 <+> toHtml "~" <+> ppLType t2-ppPred (HsIParam (IPName n) t) - = toHtml "?" +++ ppDocName n <+> dcolon <+> ppLType t +pp_hs_context :: [HsPred DocName] -> Bool -> Html+pp_hs_context [] _ = empty+pp_hs_context [p] unicode = ppPred unicode p+pp_hs_context cxt unicode = parenList (map (ppPred unicode) cxt) ++ppPred :: Bool -> HsPred DocName -> Html+ppPred unicode (HsClassP n ts) = ppAppNameTypes n (map unLoc ts) unicode+ppPred unicode (HsEqualP t1 t2) = ppLType unicode t1 <+> toHtml "~" <+> ppLType unicode t2+ppPred unicode (HsIParam (IPName n) t)+ = toHtml "?" +++ ppDocName n <+> dcolon unicode <+> ppLType unicode t++ ------------------------------------------------------------------------------- -- Class declarations ------------------------------------------------------------------------------- -ppClassHdr summ lctxt n tvs fds = +ppClassHdr :: Bool -> Located [LHsPred DocName] -> DocName+ -> [Located (HsTyVarBndr DocName)] -> [Located ([DocName], [DocName])]+ -> Bool -> Html+ppClassHdr summ lctxt n tvs fds unicode = keyword "class" - <+> (if not . null . unLoc $ lctxt then ppLContext lctxt else empty)+ <+> (if not . null . unLoc $ lctxt then ppLContext lctxt unicode else empty) <+> ppAppDocNameNames summ n (tyvarNames $ tvs)- <+> ppFds fds+ <+> ppFds fds unicode -ppFds fds =++ppFds :: [Located ([DocName], [DocName])] -> Bool -> Html+ppFds fds unicode = if null fds then noHtml else char '|' <+> hsep (punctuate comma (map (fundep . unLoc) fds)) where- fundep (vars1,vars2) = hsep (map ppDocName vars1) <+> toHtml "->" <+>+ fundep (vars1,vars2) = hsep (map ppDocName vars1) <+> arrow unicode <+> hsep (map ppDocName vars2) -ppShortClassDecl :: Bool -> LinksInfo -> TyClDecl DocName -> SrcSpan -> [(DocName, Maybe (HsDoc DocName))] -> HtmlTable-ppShortClassDecl summary links (ClassDecl lctxt lname tvs fds sigs _ ats _) loc subdocs = +ppShortClassDecl :: Bool -> LinksInfo -> TyClDecl DocName -> SrcSpan -> [(DocName, Maybe (HsDoc DocName))] -> Bool -> HtmlTable+ppShortClassDecl summary links (ClassDecl lctxt lname tvs fds sigs _ ats _) loc subdocs unicode = if null sigs && null ats then (if summary then declBox else topDeclBox links loc nm) hdr else (if summary then declBox else topDeclBox links loc nm) (hdr <+> keyword "where")@@ -1080,34 +1150,34 @@ bodyBox << aboves (- [ ppAssocType summary links doc at | at <- ats+ [ ppAssocType summary links doc at unicode | at <- ats , let doc = join $ lookup (tcdName $ unL at) subdocs ] ++ - [ ppFunSig summary links loc doc n typ+ [ ppFunSig summary links loc doc n typ unicode | L _ (TypeSig (L _ n) (L _ typ)) <- sigs , let doc = join $ lookup n subdocs ] ) ) where- hdr = ppClassHdr summary lctxt (unLoc lname) tvs fds+ hdr = ppClassHdr summary lctxt (unLoc lname) tvs fds unicode nm = unLoc lname+ppShortClassDecl _ _ _ _ _ _ = error "declaration type not supported by ppShortClassDecl" -ppClassDecl :: Bool -> LinksInfo -> [InstHead DocName] -> SrcSpan ->- Maybe (HsDoc DocName) -> DocMap -> [(DocName, Maybe (HsDoc DocName))] -> TyClDecl DocName -> - HtmlTable-ppClassDecl summary links instances loc mbDoc docMap subdocs- decl@(ClassDecl lctxt lname ltyvars lfds lsigs _ ats _)- | summary = ppShortClassDecl summary links decl loc subdocs- | otherwise = classheader </> bodyBox << (classdoc </> body </> instancesBit)+ppClassDecl :: Bool -> LinksInfo -> [InstHead DocName] -> SrcSpan+ -> Maybe (HsDoc DocName) -> DocMap -> [(DocName, Maybe (HsDoc DocName))]+ -> TyClDecl DocName -> Bool -> HtmlTable+ppClassDecl summary links instances loc mbDoc _ subdocs+ decl@(ClassDecl lctxt lname ltyvars lfds lsigs _ ats _) unicode+ | summary = ppShortClassDecl summary links decl loc subdocs unicode+ | otherwise = classheader </> bodyBox << (classdoc </> body_ </> instancesBit) where classheader- | null lsigs = topDeclBox links loc nm hdr- | otherwise = topDeclBox links loc nm (hdr <+> keyword "where")+ | null lsigs = topDeclBox links loc nm (hdr unicode)+ | otherwise = topDeclBox links loc nm (hdr unicode <+> keyword "where") nm = unLoc $ tcdLName decl- ctxt = unLoc lctxt hdr = ppClassHdr summary lctxt (unLoc lname) ltyvars lfds @@ -1115,21 +1185,21 @@ Nothing -> Html.emptyTable Just d -> ndocBox (docToHtml d) - body+ body_ | null lsigs, null ats = Html.emptyTable | null ats = s8 </> methHdr </> bodyBox << methodTable | otherwise = s8 </> atHdr </> bodyBox << atTable </> s8 </> methHdr </> bodyBox << methodTable methodTable =- abovesSep s8 [ ppFunSig summary links loc doc n typ+ abovesSep s8 [ ppFunSig summary links loc doc n typ unicode | L _ (TypeSig (L _ n) (L _ typ)) <- lsigs , let doc = join $ lookup n subdocs ] - atTable = abovesSep s8 $ [ ppAssocType summary links doc at | at <- ats+ atTable = abovesSep s8 $ [ ppAssocType summary links doc at unicode | at <- ats , let doc = join $ lookup (tcdName $ unL at) subdocs ] - instId = collapseId (docNameOrig nm)+ instId = collapseId (getName nm) instancesBit | null instances = Html.emptyTable | otherwise @@ -1137,28 +1207,29 @@ tda [theclass "body"] << collapsed thediv instId ( spacedTable1 << (- aboves (map (declBox . ppInstHead) instances)+ aboves (map (declBox . ppInstHead unicode) instances) ))+ppClassDecl _ _ _ _ _ _ _ _ _ = error "declaration type not supported by ppShortClassDecl" -ppInstHead :: InstHead DocName -> Html-ppInstHead ([], n, ts) = ppAppNameTypes n ts -ppInstHead (ctxt, n, ts) = ppContextNoLocs ctxt <+> ppAppNameTypes n ts +ppInstHead :: Bool -> InstHead DocName -> Html+ppInstHead unicode ([], n, ts) = ppAppNameTypes n ts unicode+ppInstHead unicode (ctxt, n, ts) = ppContextNoLocs ctxt unicode <+> ppAppNameTypes n ts unicode + -- ----------------------------------------------------------------------------- -- Data & newtype declarations -- TODO: print contexts-ppShortDataDecl :: Bool -> LinksInfo -> SrcSpan -> - Maybe (HsDoc DocName) -> TyClDecl DocName -> Html-ppShortDataDecl summary links loc mbDoc dataDecl +ppShortDataDecl :: Bool -> LinksInfo -> SrcSpan -> TyClDecl DocName -> Bool -> Html+ppShortDataDecl summary links loc dataDecl unicode | [lcon] <- cons, ResTyH98 <- resTy = - ppDataHeader summary dataDecl - <+> equals <+> ppShortConstr summary (unLoc lcon)+ ppDataHeader summary dataDecl unicode+ <+> equals <+> ppShortConstr summary (unLoc lcon) unicode - | [] <- cons = ppDataHeader summary dataDecl+ | [] <- cons = ppDataHeader summary dataDecl unicode | otherwise = vanillaTable << ( case resTy of @@ -1175,29 +1246,25 @@ where dataHeader = (if summary then declBox else topDeclBox links loc docname)- ((ppDataHeader summary dataDecl) <+> + ((ppDataHeader summary dataDecl unicode) <+> case resTy of ResTyGADT _ -> keyword "where"; _ -> empty) - doConstr c con = declBox (toHtml [c] <+> ppShortConstr summary (unLoc con))- doGADTConstr con = declBox (ppShortConstr summary (unLoc con))+ doConstr c con = declBox (toHtml [c] <+> ppShortConstr summary (unLoc con) unicode)+ doGADTConstr con = declBox (ppShortConstr summary (unLoc con) unicode) docname = unLoc . tcdLName $ dataDecl- context = unLoc (tcdCtxt dataDecl)- newOrData = tcdND dataDecl- tyVars = tyvarNames (tcdTyVars dataDecl)- mbKSig = tcdKindSig dataDecl cons = tcdCons dataDecl resTy = (con_res . unLoc . head) cons ppDataDecl :: Bool -> LinksInfo -> [InstHead DocName] -> - SrcSpan -> Maybe (HsDoc DocName) -> TyClDecl DocName -> HtmlTable-ppDataDecl summary links instances loc mbDoc dataDecl+ SrcSpan -> Maybe (HsDoc DocName) -> TyClDecl DocName -> Bool -> HtmlTable+ppDataDecl summary links instances loc mbDoc dataDecl unicode | summary = declWithDoc summary links loc docname mbDoc - (ppShortDataDecl summary links loc mbDoc dataDecl)+ (ppShortDataDecl summary links loc dataDecl unicode) | otherwise- = (if validTable then (</>) else const) header $+ = (if validTable then (</>) else const) header_ $ tda [theclass "body"] << vanillaTable << ( datadoc </> constrBit </>@@ -1207,14 +1274,10 @@ where docname = unLoc . tcdLName $ dataDecl- context = unLoc (tcdCtxt dataDecl)- newOrData = tcdND dataDecl- tyVars = tyvarNames (tcdTyVars dataDecl)- mbKSig = tcdKindSig dataDecl cons = tcdCons dataDecl resTy = (con_res . unLoc . head) cons - header = topDeclBox links loc docname (ppDataHeader summary dataDecl+ header_ = topDeclBox links loc docname (ppDataHeader summary dataDecl unicode <+> whereBit) whereBit @@ -1235,10 +1298,10 @@ | null cons = Html.emptyTable | otherwise = constrHdr </> ( tda [theclass "body"] << constrTable << - aboves (map ppSideBySideConstr cons)+ aboves (map (ppSideBySideConstr unicode) cons) ) - instId = collapseId (docNameOrig docname)+ instId = collapseId (getName docname) instancesBit | null instances = Html.emptyTable@@ -1247,38 +1310,50 @@ tda [theclass "body"] << collapsed thediv instId ( spacedTable1 << (- aboves (map (declBox . ppInstHead) instances)+ aboves (map (declBox . ppInstHead unicode) instances) ) ) validTable = isJust mbDoc || not (null cons) || not (null instances) +isRecCon :: Located (ConDecl a) -> Bool isRecCon lcon = case con_details (unLoc lcon) of RecCon _ -> True _ -> False -ppShortConstr :: Bool -> ConDecl DocName -> Html-ppShortConstr summary con = case con_res con of +ppShortConstr :: Bool -> ConDecl DocName -> Bool -> Html+ppShortConstr summary con unicode = case con_res con of ResTyH98 -> case con_details con of - PrefixCon args -> header +++ hsep (ppBinder summary occ : map ppLParendType args)- RecCon fields -> header +++ ppBinder summary occ <+>- braces (vanillaTable << aboves (map (ppShortField summary) fields))- InfixCon arg1 arg2 -> header +++ - hsep [ppLParendType arg1, ppBinder summary occ, ppLParendType arg2] + PrefixCon args -> header_ unicode +++ hsep (ppBinder summary occ : map (ppLParendType unicode) args)+ RecCon fields -> header_ unicode +++ ppBinder summary occ <+>+ doRecordFields fields+ InfixCon arg1 arg2 -> header_ unicode +++ + hsep [ppLParendType unicode arg1, ppBinder summary occ, ppLParendType unicode arg2] ResTyGADT resTy -> case con_details con of + -- prefix & infix could use hsConDeclArgTys if it seemed to+ -- simplify the code. PrefixCon args -> doGADTCon args resTy- RecCon _ -> error "GADT records not suported"+ -- 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 <+> hsep [+ ppForAll forall ltvs lcontext unicode,+ doRecordFields fields,+ arrow unicode <+> ppLType unicode resTy ] InfixCon arg1 arg2 -> doGADTCon [arg1, arg2] resTy where- doGADTCon args resTy = ppBinder summary occ <+> dcolon <+> hsep [- ppForAll forall ltvs lcontext,- ppLType (foldr mkFunTy resTy args) ]+ doRecordFields fields = braces (vanillaTable <<+ aboves (map (ppShortField summary unicode) fields))+ doGADTCon args resTy = ppBinder summary occ <+> dcolon unicode <+> hsep [+ ppForAll forall ltvs lcontext unicode,+ ppLType unicode (foldr mkFunTy resTy args) ] - header = ppConstrHdr forall tyVars context+ header_ = ppConstrHdr forall tyVars context occ = docNameOcc . unLoc . con_name $ con ltvs = con_qvars con tyVars = tyvarNames ltvs @@ -1287,48 +1362,55 @@ forall = con_explicit con mkFunTy a b = noLoc (HsFunTy a b) -ppConstrHdr :: HsExplicitForAll -> [Name] -> HsContext DocName -> Html-ppConstrHdr forall tvs ctxt+-- ppConstrHdr is for (non-GADT) existentials constructors' syntax+ppConstrHdr :: HsExplicitForAll -> [Name] -> HsContext DocName -> Bool -> Html+ppConstrHdr forall tvs ctxt unicode = (if null tvs then noHtml else ppForall) +++- (if null ctxt then noHtml else ppContextNoArrow ctxt <+> toHtml "=> ")+ (if null ctxt then noHtml else ppContextNoArrow ctxt unicode <+> darrow unicode +++ toHtml " ") where ppForall = case forall of - Explicit -> keyword "forall" <+> hsep (map ppName tvs) <+> toHtml ". "+ Explicit -> forallSymbol unicode <+> hsep (map ppName tvs) <+> toHtml ". " Implicit -> empty -ppSideBySideConstr :: LConDecl DocName -> HtmlTable-ppSideBySideConstr (L _ con) = case con_res con of +ppSideBySideConstr :: Bool -> LConDecl DocName -> HtmlTable+ppSideBySideConstr unicode (L _ con) = case con_res con of ResTyH98 -> case con_details con of PrefixCon args -> - argBox (hsep ((header +++ ppBinder False occ) : map ppLParendType args)) + argBox (hsep ((header_ unicode +++ ppBinder False occ) : map (ppLParendType unicode) args)) <-> maybeRDocBox mbLDoc RecCon fields -> - argBox (header +++ ppBinder False occ) <->- maybeRDocBox mbLDoc </>- (tda [theclass "body"] << spacedTable1 <<- aboves (map ppSideBySideField fields))+ argBox (header_ unicode +++ ppBinder False occ) <->+ maybeRDocBox mbLDoc+ </>+ doRecordFields fields InfixCon arg1 arg2 -> - argBox (hsep [header+++ppLParendType arg1, ppBinder False occ, ppLParendType arg2])+ argBox (hsep [header_ unicode+++ppLParendType unicode arg1, ppBinder False occ, ppLParendType unicode arg2]) <-> maybeRDocBox mbLDoc 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- RecCon _ -> error "GADT records not supported"+ cd@(RecCon fields) -> doGADTCon (hsConDeclArgTys cd) resTy+ </> doRecordFields fields InfixCon arg1 arg2 -> doGADTCon [arg1, arg2] resTy where - doGADTCon args resTy = argBox (ppBinder False occ <+> dcolon <+> hsep [- ppForAll forall ltvs (con_cxt con),- ppLType (foldr mkFunTy resTy args) ]+ doRecordFields fields =+ (tda [theclass "body"] << spacedTable1 <<+ aboves (map (ppSideBySideField unicode) fields))+ doGADTCon args resTy = argBox (ppBinder False occ <+> dcolon unicode <+> hsep [+ ppForAll forall ltvs (con_cxt con) unicode,+ ppLType unicode (foldr mkFunTy resTy args) ] ) <-> maybeRDocBox mbLDoc - header = ppConstrHdr forall tyVars context+ header_ = ppConstrHdr forall tyVars context occ = docNameOcc . unLoc . con_name $ con ltvs = con_qvars con tyVars = tyvarNames (con_qvars con)@@ -1337,10 +1419,10 @@ mbLDoc = con_doc con mkFunTy a b = noLoc (HsFunTy a b) -ppSideBySideField :: ConDeclField DocName -> HtmlTable-ppSideBySideField (ConDeclField (L _ name) ltype mbLDoc) =+ppSideBySideField :: Bool -> ConDeclField DocName -> HtmlTable+ppSideBySideField unicode (ConDeclField (L _ name) ltype mbLDoc) = argBox (ppBinder False (docNameOcc name)- <+> dcolon <+> ppLType ltype) <->+ <+> dcolon unicode <+> ppLType unicode ltype) <-> maybeRDocBox mbLDoc {-@@ -1370,11 +1452,11 @@ ) -} -ppShortField :: Bool -> ConDeclField DocName -> HtmlTable-ppShortField summary (ConDeclField (L _ name) ltype _) +ppShortField :: Bool -> Bool -> ConDeclField DocName -> HtmlTable+ppShortField summary unicode (ConDeclField (L _ name) ltype _) = tda [theclass "recfield"] << ( ppBinder summary (docNameOcc name)- <+> dcolon <+> ppLType ltype+ <+> dcolon unicode <+> ppLType unicode ltype ) {-@@ -1391,14 +1473,14 @@ -- | Print the LHS of a data\/newtype declaration. -- Currently doesn't handle 'data instance' decls or kind signatures-ppDataHeader :: Bool -> TyClDecl DocName -> Html-ppDataHeader summary decl +ppDataHeader :: Bool -> TyClDecl DocName -> Bool -> Html+ppDataHeader summary decl unicode | not (isDataDecl decl) = error "ppDataHeader: illegal argument" | otherwise = -- newtype or data (if tcdND decl == NewType then keyword "newtype" else keyword "data") <+> -- context- ppLContext (tcdCtxt decl) <+>+ ppLContext (tcdCtxt decl) unicode <+> -- T a b c ..., or a :+: b ppTyClBinderWithVars summary decl @@ -1406,18 +1488,26 @@ -- ---------------------------------------------------------------------------- -- Types and contexts ++ppKind :: Outputable a => a -> Html ppKind k = toHtml $ showSDoc (ppr k) + {- ppForAll Implicit _ lctxt = ppCtxtPart lctxt ppForAll Explicit ltvs lctxt = hsep (keyword "forall" : ppTyVars ltvs ++ [dot]) <+> ppCtxtPart lctxt -} ++ppBang :: HsBang -> Html+ppBang HsNoBang = empty ppBang HsStrict = toHtml "!" ppBang HsUnbox = toHtml "!" -- unboxed args is an implementation detail, -- so we just show the strictness annotation ++tupleParens :: Boxity -> [Html] -> Html tupleParens Boxed = parenList tupleParens Unboxed = ubxParenList {-@@ -1448,6 +1538,8 @@ -------------------------------------------------------------------------------- +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 (->)@@ -1463,75 +1555,82 @@ | otherwise = p -ppLTypes = hsep . map ppLType-ppLParendTypes = hsep . map ppLParendType---ppParendTypes = hsep . map ppParendType---ppLType = ppType . unLoc-ppLParendType = ppParendType . unLoc+ppLType, ppLParendType :: Bool -> Located (HsType DocName) -> Html+ppLType unicode y = ppType unicode (unLoc y)+ppLParendType unicode y = ppParendType unicode (unLoc y) -ppType ty = ppr_mono_ty pREC_TOP ty-ppParendType ty = ppr_mono_ty pREC_CON ty+ppType, ppParendType :: Bool -> HsType DocName -> Html+ppType unicode ty = ppr_mono_ty pREC_TOP ty unicode +ppParendType unicode ty = ppr_mono_ty pREC_CON ty unicode -- Drop top-level for-all type variables in user style -- since they are implicit in Haskell -ppForAll exp tvs cxt - | show_forall = forall_part <+> ppLContext cxt- | otherwise = ppLContext cxt+ppForAll :: HsExplicitForAll -> [Located (HsTyVarBndr DocName)]+ -> Located (HsContext DocName) -> Bool -> Html+ppForAll expl tvs cxt unicode+ | show_forall = forall_part <+> ppLContext cxt unicode+ | otherwise = ppLContext cxt unicode where show_forall = not (null tvs) && is_explicit- is_explicit = case exp of {Explicit -> True; Implicit -> False}- forall_part = hsep (keyword "forall" : ppTyVars tvs) +++ dot + is_explicit = case expl of {Explicit -> True; Implicit -> False}+ forall_part = hsep (forallSymbol unicode : ppTyVars tvs) +++ dot -ppr_mono_lty ctxt_prec ty = ppr_mono_ty ctxt_prec (unLoc ty) -ppr_mono_ty ctxt_prec (HsForAllTy exp tvs ctxt ty)+ppr_mono_lty :: Int -> LHsType DocName -> Bool -> Html+ppr_mono_lty ctxt_prec ty unicode = ppr_mono_ty ctxt_prec (unLoc ty) unicode +++ppr_mono_ty :: Int -> HsType DocName -> Bool -> Html+ppr_mono_ty ctxt_prec (HsForAllTy expl tvs ctxt ty) unicode = maybeParen ctxt_prec pREC_FUN $- hsep [ppForAll exp tvs ctxt, ppr_mono_lty pREC_TOP ty]+ hsep [ppForAll expl tvs ctxt unicode, ppr_mono_lty pREC_TOP ty unicode] -- gaw 2004-ppr_mono_ty ctxt_prec (HsBangTy b ty) = ppBang b +++ ppLParendType ty-ppr_mono_ty ctxt_prec (HsTyVar name) = ppDocName name-ppr_mono_ty ctxt_prec (HsFunTy ty1 ty2) = ppr_fun_ty ctxt_prec ty1 ty2-ppr_mono_ty ctxt_prec (HsTupleTy con tys) = tupleParens con (map ppLType tys)-ppr_mono_ty ctxt_prec (HsKindSig ty kind) = parens (ppr_mono_lty pREC_TOP ty <+> dcolon <+> ppKind kind)-ppr_mono_ty ctxt_prec (HsListTy ty) = brackets (ppr_mono_lty pREC_TOP ty)-ppr_mono_ty ctxt_prec (HsPArrTy ty) = pabrackets (ppr_mono_lty pREC_TOP ty)-ppr_mono_ty ctxt_prec (HsPredTy pred) = parens (ppPred pred)-ppr_mono_ty ctxt_prec (HsNumTy n) = toHtml (show n) -- generics only-ppr_mono_ty ctxt_prec (HsSpliceTy s) = error "ppr_mono_ty-haddock"+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 <+> ppKind 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 _ (HsPredTy p) u = parens (ppPred u p)+ppr_mono_ty _ (HsNumTy n) _ = toHtml (show n) -- generics only+ppr_mono_ty _ (HsSpliceTy _) _ = error "ppr_mono_ty-haddock"+#if __GLASGOW_HASKELL__ >= 611+ppr_mono_ty _ (HsRecTy _) _ = error "ppr_mono_ty HsRecTy"+#endif -ppr_mono_ty ctxt_prec (HsAppTy fun_ty arg_ty)+ppr_mono_ty ctxt_prec (HsAppTy fun_ty arg_ty) unicode = maybeParen ctxt_prec pREC_CON $- hsep [ppr_mono_lty pREC_FUN fun_ty, ppr_mono_lty pREC_CON arg_ty]+ 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)+ppr_mono_ty ctxt_prec (HsOpTy ty1 op ty2) unicode = maybeParen ctxt_prec pREC_FUN $- ppr_mono_lty pREC_OP ty1 <+> ppr_op <+> ppr_mono_lty pREC_OP ty2+ ppr_mono_lty pREC_OP ty1 unicode <+> ppr_op <+> ppr_mono_lty pREC_OP ty2 unicode where ppr_op = if not (isSymOcc occName) then quote (ppLDocName op) else ppLDocName op occName = docNameOcc . unLoc $ op -ppr_mono_ty ctxt_prec (HsParTy ty)+ppr_mono_ty ctxt_prec (HsParTy ty) unicode -- = parens (ppr_mono_lty pREC_TOP ty)- = ppr_mono_lty ctxt_prec ty+ = ppr_mono_lty ctxt_prec ty unicode -ppr_mono_ty ctxt_prec (HsDocTy ty doc)- = ppr_mono_lty ctxt_prec ty+ppr_mono_ty ctxt_prec (HsDocTy ty _) unicode + = ppr_mono_lty ctxt_prec ty unicode -ppr_fun_ty ctxt_prec ty1 ty2- = let p1 = ppr_mono_lty pREC_FUN ty1- p2 = ppr_mono_lty pREC_TOP ty2++ppr_fun_ty :: Int -> LHsType DocName -> LHsType DocName -> Bool -> Html +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 $- hsep [p1, arrow <+> p2]+ hsep [p1, arrow unicode <+> p2] + -- ---------------------------------------------------------------------------- -- Names @@ -1541,11 +1640,12 @@ ppRdrName :: RdrName -> Html ppRdrName = ppOccName . rdrNameOcc +ppLDocName :: Located DocName -> Html ppLDocName (L _ d) = ppDocName d ppDocName :: DocName -> Html-ppDocName (Documented name mod) = - linkIdOcc mod (Just occName) << ppOccName occName+ppDocName (Documented name mdl) = + linkIdOcc mdl (Just occName) << ppOccName occName where occName = nameOccName name ppDocName (Undocumented name) = toHtml (getOccString name) @@ -1569,19 +1669,20 @@ | otherwise = ppOccName n -linkId mod mbName = linkIdOcc mod (fmap nameOccName mbName)+linkId :: Module -> Maybe Name -> Html -> Html+linkId mdl mbName = linkIdOcc mdl (fmap nameOccName mbName) linkIdOcc :: Module -> Maybe OccName -> Html -> Html-linkIdOcc mod mbName = anchor ! [href hr]+linkIdOcc mdl mbName = anchor ! [href uri] where - hr = case mbName of- Nothing -> moduleHtmlFile mod- Just name -> nameHtmlRef mod name+ uri = case mbName of+ Nothing -> moduleHtmlFile mdl+ Just name -> nameHtmlRef mdl name ppModule :: Module -> String -> Html-ppModule mod ref = anchor ! [href ((moduleHtmlFile mod) ++ ref)] - << toHtml (moduleString mod)+ppModule mdl ref = anchor ! [href ((moduleHtmlFile mdl) ++ ref)] + << toHtml (moduleString mdl) -- ----------------------------------------------------------------------------- -- * Doc Markup@@ -1593,7 +1694,7 @@ markupString = toHtml, markupAppend = (+++), markupIdentifier = tt . ppId . choose,- markupModule = \m -> let (mod,ref) = break (=='#') m in ppModule (mkModuleNoPackage mod) ref,+ markupModule = \m -> let (mdl,ref) = break (=='#') m in ppModule (mkModuleNoPackage mdl) ref, markupEmphasis = emphasize . toHtml, markupMonospaced = tt . toHtml, markupUnorderedList = ulist . concatHtml . map (li <<),@@ -1610,26 +1711,35 @@ -- to Name, but since we will move this process from GHC into Haddock in -- the future, we fix it here in the meantime. -- TODO: mention this rule in the documentation.+ choose [] = error "empty identifier list in HsDoc" choose [x] = x choose (x:y:_) | isTyCon x = x | otherwise = y +markupDef :: (HTML a, HTML b) => (a, b) -> Html markupDef (a,b) = dterm << a +++ ddef << b ++htmlMarkup :: DocMarkup DocName Html htmlMarkup = parHtmlMarkup ppDocName (isTyConName . getName)++htmlOrigMarkup :: DocMarkup Name Html htmlOrigMarkup = parHtmlMarkup ppName isTyConName++htmlRdrMarkup :: DocMarkup RdrName Html htmlRdrMarkup = parHtmlMarkup ppRdrName isRdrTc -- If the doc is a single paragraph, don't surround it with <P> (this causes -- ugly extra whitespace with some browsers).-docToHtml :: GHC.HsDoc DocName -> Html+docToHtml :: HsDoc DocName -> Html docToHtml doc = markup htmlMarkup (unParagraph (markup htmlCleanup doc)) -origDocToHtml :: GHC.HsDoc GHC.Name -> Html+origDocToHtml :: HsDoc Name -> Html origDocToHtml doc = markup htmlOrigMarkup (unParagraph (markup htmlCleanup doc)) +rdrDocToHtml :: HsDoc RdrName -> Html rdrDocToHtml doc = markup htmlRdrMarkup (unParagraph (markup htmlCleanup doc)) -- If there is a single paragraph, then surrounding it with <P>..</P>@@ -1637,6 +1747,7 @@ -- we have multiple paragraphs, then we want the extra whitespace to -- separate them. So we catch the single paragraph case and transform it -- here.+unParagraph :: HsDoc a -> HsDoc a unParagraph (GHC.DocParagraph d) = d --NO: This eliminates line breaks in the code block: (SDM, 6/5/2003) --unParagraph (DocCodeBlock d) = (DocMonospaced d)@@ -1680,7 +1791,7 @@ quote h = char '`' +++ h +++ '`' -parens, brackets, braces :: Html -> Html+parens, brackets, pabrackets, braces :: Html -> Html parens h = char '(' +++ h +++ char ')' brackets h = char '[' +++ h +++ char ']' pabrackets h = toHtml "[:" +++ h +++ toHtml ":]"@@ -1742,7 +1853,7 @@ case maybe_wiki_url of Nothing -> Html.emptyTable Just url -> tda [theclass "declbut"] <<- let url' = spliceURL (Just fname) (Just mod)+ let url' = spliceURL (Just fname) (Just mdl) (Just n) (Just loc) url in anchor ! [href url'] << toHtml "Comments" @@ -1753,7 +1864,7 @@ origMod = nameModule n -- Name must be documented, otherwise we wouldn't get here- Documented n mod = name+ Documented n mdl = name fname = unpackFS (srcSpanFile loc) @@ -1790,30 +1901,35 @@ -- a vanilla table has width 100%, no border, no padding, no spacing -- a narrow table is the same but without width 100%.-vanillaTable, narrowTable :: Html -> Html-vanillaTable = table ! [theclass "vanilla", cellspacing 0, cellpadding 0]+vanillaTable, vanillaTable2, narrowTable :: Html -> Html+vanillaTable = table ! [theclass "vanilla", cellspacing 0, cellpadding 0] vanillaTable2 = table ! [theclass "vanilla2", cellspacing 0, cellpadding 0]-narrowTable = table ! [theclass "narrow", cellspacing 0, cellpadding 0]+narrowTable = table ! [theclass "narrow", cellspacing 0, cellpadding 0] spacedTable1, spacedTable5 :: Html -> Html spacedTable1 = table ! [theclass "vanilla", cellspacing 1, cellpadding 0] spacedTable5 = table ! [theclass "vanilla", cellspacing 5, cellpadding 0] -constrHdr, methHdr :: HtmlTable+constrHdr, methHdr, atHdr :: HtmlTable constrHdr = tda [ theclass "section4" ] << toHtml "Constructors" methHdr = tda [ theclass "section4" ] << toHtml "Methods" atHdr = tda [ theclass "section4" ] << toHtml "Associated Types" instHdr :: String -> HtmlTable-instHdr id = - tda [ theclass "section4" ] << (collapsebutton id +++ toHtml " Instances")+instHdr id_ = + tda [ theclass "section4" ] << (collapsebutton id_ +++ toHtml " Instances") -dcolon, arrow, darrow :: Html-dcolon = toHtml "::"-arrow = toHtml "->"-darrow = toHtml "=>"-dot = 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 "."++ s8, s15 :: HtmlTable s8 = tda [ theclass "s8" ] << noHtml s15 = tda [ theclass "s15" ] << noHtml@@ -1826,7 +1942,7 @@ -- versions) needs the name to be unescaped, while IE 7 needs it to be escaped. -- namedAnchor :: String -> Html -> Html-namedAnchor n = (anchor ! [name n]) . (anchor ! [name (escapeStr n)])+namedAnchor n = (anchor ! [Html.name n]) . (anchor ! [Html.name (escapeStr n)]) --@@ -1838,12 +1954,12 @@ -- use cookies from JavaScript to have a more persistent state. collapsebutton :: String -> Html-collapsebutton id = - image ! [ src minusFile, theclass "coll", onclick ("toggle(this,'" ++ id ++ "')"), alt "show/hide" ]+collapsebutton id_ = + image ! [ src minusFile, theclass "coll", onclick ("toggle(this,'" ++ id_ ++ "')"), alt "show/hide" ] collapsed :: (HTML a) => (Html -> Html) -> String -> a -> Html-collapsed fn id html =- fn ! [identifier id, thestyle "display:block;"] << html+collapsed fn id_ html =+ fn ! [identifier id_, thestyle "display:block;"] << html -- A quote is a valid part of a Haskell identifier, but it would interfere with -- the ECMA script string delimiter used in collapsebutton above.@@ -1851,9 +1967,9 @@ collapseId nm = "i:" ++ escapeStr (getOccString nm) linkedAnchor :: String -> Html -> Html-linkedAnchor frag = anchor ! [href hr]- where hr | null frag = ""- | otherwise = '#': escapeStr frag+linkedAnchor frag = anchor ! [href hr_]+ where hr_ | null frag = ""+ | otherwise = '#': escapeStr frag documentCharacterEncoding :: Html documentCharacterEncoding =
− src/Haddock/DocName.hs
@@ -1,59 +0,0 @@-{-# OPTIONS_HADDOCK hide #-}------- Haddock - A Haskell Documentation Tool------ (c) Simon Marlow 2003------module Haddock.DocName where---import GHC-import Name-import Binary---data DocName = Documented Name Module | Undocumented Name- deriving Eq----- TODO: remove docNameOrig in favour of the NamedThing instance--instance NamedThing DocName where- getName (Documented name _) = name- getName (Undocumented name) = name----- | The 'OccName' belonging to this name-docNameOcc :: DocName -> OccName-docNameOcc = nameOccName . docNameOrig----- | The original definition site of this name-docNameOrig :: DocName -> Name-docNameOrig (Documented name _) = name-docNameOrig (Undocumented name) = name---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"
− src/Haddock/Exception.hs
@@ -1,34 +0,0 @@------ Haddock - A Haskell Documentation Tool------ (c) Simon Marlow 2003------{-# LANGUAGE DeriveDataTypeable #-}---module Haddock.Exception (- HaddockException,- throwE-) where---import Data.Typeable-import Control.Exception---data HaddockException = HaddockException String deriving Typeable---instance Show HaddockException where- show (HaddockException str) = str---throwE :: String -> a-#if __GLASGOW_HASKELL__ >= 609-instance Exception HaddockException-throwE str = throw (HaddockException str)-#else-throwE str = throwDyn (HaddockException str)-#endif
− src/Haddock/GHC.hs
@@ -1,119 +0,0 @@------ Haddock - A Haskell Documentation Tool------ (c) Simon Marlow 2003------module Haddock.GHC (- startGhc,- module Haddock.GHC.Typecheck,- module Haddock.GHC.Utils-) where---import Haddock.GHC.Typecheck-import Haddock.GHC.Utils-import Haddock.Exception-import Haddock.Options--import Data.Foldable (foldlM)-import Data.Maybe-import Control.Monad--import GHC-import DynFlags hiding (Option)-import Packages hiding (package)-import StaticFlags-import SrcLoc----- | Start a GHC session with the -haddock flag set. Also turn off --- compilation and linking. -#if __GLASGOW_HASKELL__ >= 609 -startGhc :: String -> [String] -> (DynFlags -> Ghc a) -> IO a-startGhc libDir flags ghcActs = do- -- TODO: handle warnings?- (restFlags, _) <- parseStaticFlags (map noLoc flags)- runGhc (Just libDir) $ do- dynflags <- getSessionDynFlags-#else-startGhc :: String -> [String] -> IO (Session, DynFlags)-startGhc libDir flags = do- restFlags <- parseStaticFlags flags- session <- newSession (Just libDir)- dynflags <- getSessionDynFlags session- do-#endif- let dynflags' = dopt_set dynflags Opt_Haddock- let dynflags'' = dynflags' {- hscTarget = HscNothing,- ghcMode = CompManager,- ghcLink = NoLink- }- dynflags''' <- parseGhcFlags dynflags'' restFlags flags- defaultCleanupHandler dynflags''' $ do-#if __GLASGOW_HASKELL__ >= 609- setSessionDynFlags dynflags'''- ghcActs dynflags'''-#else- setSessionDynFlags session dynflags'''- return (session, dynflags''')-#endif----- | Expose the list of packages to GHC. Then initialize GHC's package state--- and get the name of the actually loaded packages matching the supplied --- list of packages. The matching packages might be newer versions of the --- supplied ones. For each matching package, return its InstalledPackageInfo. ---- Commented out, since it is unused and doesn't build with GHC >= 6.9-{--loadPackages :: Session -> [String] -> IO [InstalledPackageInfo]---- It would be better to try to get the "in scope" packages from GHC instead.--- This would make the -use-package flag unnecessary. But currently it --- seems all you can get from the GHC api is all packages that are linked in --- (i.e the closure of the "in scope" packages).--loadPackages session pkgStrs = do-- -- expose the packages -- dfs <- getSessionDynFlags session- let dfs' = dfs { packageFlags = packageFlags dfs ++ map ExposePackage pkgStrs }- setSessionDynFlags session dfs'-- -- try to parse the packages and get their names, without versions- pkgNames <- mapM (handleParse . unpackPackageId . stringToPackageId) pkgStrs-- -- init GHC's package state- (dfs'', depPackages) <- initPackages dfs'-- -- compute the pkgIds of the loaded packages matching the - -- supplied ones- - let depPkgs = map (fromJust . unpackPackageId) depPackages - matchingPackages = [ mkPackageId pkg | pkg <- depPkgs, - pkgName pkg `elem` pkgNames ]-- -- get InstalledPackageInfos for each package- let pkgInfos = map (getPackageDetails (pkgState dfs'')) matchingPackages-- return pkgInfos- where- handleParse (Just pkg) = return (pkgName pkg)- handleParse Nothing = throwE "Could not parse package identifier"--}---- | Try to parse dynamic GHC flags-parseGhcFlags dynflags flags origFlags = do- -- TODO: handle warnings?-#if __GLASGOW_HASKELL__ >= 609- (dynflags', rest, _) <- parseDynamicFlags dynflags flags-#else- (dynflags', rest) <- parseDynamicFlags dynflags flags-#endif- if not (null rest)- then throwE ("Couldn't parse GHC options: " ++ (unwords origFlags))- else return dynflags'
− src/Haddock/GHC/Typecheck.hs
@@ -1,53 +0,0 @@------ Haddock - A Haskell Documentation Tool------ (c) Simon Marlow 2003------module Haddock.GHC.Typecheck (- mkGhcModule-) where---import Haddock.Types--import Data.Maybe-import GHC-import SrcLoc--import Data.List---type CheckedMod = (Module, FilePath, FullyCheckedMod)---type FullyCheckedMod = (ParsedSource, - RenamedSource, - TypecheckedSource, - ModuleInfo)----- | Dig out what we want from the typechecker output-mkGhcModule :: CheckedMod -> DynFlags -> GhcModule -mkGhcModule (mdl, file, checkedMod) dynflags = GhcModule {- ghcModule = mdl,- ghcFilename = file,- ghcMbDocOpts = mbOpts,- ghcHaddockModInfo = info,- ghcMbDoc = mbDoc,- ghcGroup = group_,- ghcMbExports = mbExports,- ghcExportedNames = modInfoExports modInfo,- ghcDefinedNames = map getName $ modInfoTyThings modInfo,- ghcNamesInScope = fromJust $ modInfoTopLevelScope modInfo, - ghcInstances = modInfoInstances modInfo-}- where-#if __GLASGOW_HASKELL__ == 608 && __GHC_PATCHLEVEL__ == 2- HsModule _ _ _ _ _ mbOpts _ _ = unLoc parsed-#else- mbOpts = haddockOptions dynflags-#endif- (group_, _, mbExports, mbDoc, info) = renamed- (parsed, renamed, _, modInfo) = checkedMod
− src/Haddock/GHC/Utils.hs
@@ -1,180 +0,0 @@------ Haddock - A Haskell Documentation Tool------ (c) Simon Marlow 2003------{-# LANGUAGE FlexibleInstances #-}-{-# OPTIONS_GHC -fno-warn-orphans #-}-{-# OPTIONS_HADDOCK hide #-}---module Haddock.GHC.Utils where---import Data.Char-import Data.Version-import qualified Data.Map as Map-import Control.Arrow--import HsSyn-import SrcLoc-import Outputable-import Name-import Packages-import Module---unL :: Located a -> a-unL (L _ x) = x---reL :: a -> Located a-reL = L undefined---moduleString :: Module -> String-moduleString = moduleNameString . moduleName ----- return the name of the package, with version info-modulePackageString :: Module -> String-modulePackageString = packageIdString . modulePackageId----- return the (name,version) of the package-modulePackageInfo :: Module -> (String, [Char])-modulePackageInfo modu = case unpackPackageId pkg of- Nothing -> (packageIdString pkg, "")-#if __GLASGOW_HASKELL__ >= 609- Just x -> (display $ pkgName x, showVersion (pkgVersion x))-#else- Just x -> (pkgName x, showVersion (pkgVersion x))-#endif- where pkg = modulePackageId modu---mkModuleNoPackage :: String -> Module-mkModuleNoPackage str = mkModule (stringToPackageId "") (mkModuleName str)---instance (Outputable a, Outputable b) => Outputable (Map.Map a b) where- ppr m = ppr (Map.toList m)---isNameSym :: Name -> Bool-isNameSym = isSymOcc . nameOccName---isVarSym :: OccName -> Bool-isVarSym = isLexVarSym . occNameFS---getMainDeclBinder :: HsDecl name -> Maybe name-getMainDeclBinder (TyClD d) = Just (tcdName d)-getMainDeclBinder (ValD d)- = case collectAcc d [] of- [] -> Nothing - (name:_) -> Just (unLoc name)-getMainDeclBinder (SigD d) = sigNameNoLoc d-getMainDeclBinder (ForD (ForeignImport name _ _)) = Just (unLoc name)-getMainDeclBinder (ForD (ForeignExport _ _ _)) = Nothing-getMainDeclBinder _ = Nothing---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 (TyClD d) = isFamInstDecl d-isInstD _ = False---declATs :: HsDecl a -> [a]-declATs (TyClD d) | isClassDecl d = map (tcdName . unL) $ tcdATs d-declATs _ = []---pretty :: Outputable a => a -> String-pretty x = showSDoc (ppr x)---trace_ppr :: Outputable a => a -> b -> b-trace_ppr x y = trace (pretty x) y------------------------------------------------------------------------------------- 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) . tcdCons $ d- | isClassDecl d =- map (tcdName . unL) (tcdATs d) ++- [ unL n | L _ (TypeSig n _) <- tcdSigs d ]- | 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) (tcdCons d)- | isClassDecl d = family d : concatMap (families . unL) (tcdATs 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 _ _ = []
+ src/Haddock/GhcUtils.hs view
@@ -0,0 +1,198 @@+{-# LANGUAGE FlexibleInstances #-}+{-# 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 qualified Data.Map as Map+import Control.Arrow+import Data.Foldable hiding (concatMap)+import Data.Traversable++import HsSyn+import SrcLoc+import Outputable+import Name+import Packages+import Module+++moduleString :: Module -> String+moduleString = moduleNameString . moduleName +++-- return the name of the package, with version info+modulePackageString :: Module -> String+modulePackageString = packageIdString . modulePackageId+++-- return the (name,version) of the package+modulePackageInfo :: Module -> (String, [Char])+modulePackageInfo modu = case unpackPackageId pkg of+ Nothing -> (packageIdString pkg, "")+#if __GLASGOW_HASKELL__ >= 609+ Just x -> (display $ pkgName x, showVersion (pkgVersion x))+#else+ Just x -> (pkgName x, showVersion (pkgVersion x))+#endif+ where pkg = modulePackageId modu+++mkModuleNoPackage :: String -> Module+mkModuleNoPackage str = mkModule (stringToPackageId "") (mkModuleName str)+++instance (Outputable a, Outputable b) => Outputable (Map.Map a b) where+ ppr m = ppr (Map.toList m)+++isNameSym :: Name -> Bool+isNameSym = isSymOcc . nameOccName+++isVarSym :: OccName -> Bool+isVarSym = isLexVarSym . occNameFS+++getMainDeclBinder :: HsDecl name -> Maybe name+getMainDeclBinder (TyClD d) = Just (tcdName d)+getMainDeclBinder (ValD d)+ = case collectAcc d [] of+ [] -> Nothing + (name:_) -> Just (unLoc name)+getMainDeclBinder (SigD d) = sigNameNoLoc d+getMainDeclBinder (ForD (ForeignImport name _ _)) = Just (unLoc name)+getMainDeclBinder (ForD (ForeignExport _ _ _)) = Nothing+getMainDeclBinder _ = Nothing+++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 (TyClD d) = isFamInstDecl d+isInstD _ = False+++declATs :: HsDecl a -> [a]+declATs (TyClD d) | isClassDecl d = map (tcdName . unL) $ tcdATs d+declATs _ = []+++pretty :: Outputable a => a -> String+pretty x = showSDoc (ppr x)+++trace_ppr :: Outputable a => a -> b -> b+trace_ppr x y = trace (pretty x) y+++-------------------------------------------------------------------------------+-- Located+-------------------------------------------------------------------------------+++unL :: Located a -> a+unL (L _ x) = x+++reL :: a -> Located a+reL = L undefined+++instance Foldable Located where+ foldMap f (L _ x) = f x+++instance Traversable Located where+ mapM f (L l x) = (return . 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) . tcdCons $ d+ | isClassDecl d =+ map (tcdName . unL) (tcdATs d) +++ [ unL n | L _ (TypeSig n _) <- tcdSigs d ]+ | 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) (tcdCons d)+ | isClassDecl d = family d : concatMap (families . unL) (tcdATs 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 _ _ = []
src/Haddock/Interface.hs view
@@ -1,66 +1,68 @@------ Haddock - A Haskell Documentation Tool+-----------------------------------------------------------------------------+-- |+-- Module : Haddock.Interface+-- Copyright : (c) Simon Marlow 2003-2006,+-- David Waern 2006-2009+-- License : BSD-like ----- (c) Simon Marlow 2003+-- Maintainer : haddock@projects.haskell.org+-- Stability : experimental+-- Portability : portable ------ Here we build the actual module interfaces. By interface we mean the --- information that is used to render a Haddock page for a module. Parts of --- this information is also stored in the interface files.-+-- Here we build the actual module interfaces. By interface we mean the+-- information that is used to render a Haddock page for a module. Parts of+-- this information are also stored in the .haddock files.+----------------------------------------------------------------------------- module Haddock.Interface ( createInterfaces ) where -import Haddock.DocName import Haddock.Interface.Create import Haddock.Interface.AttachInstances import Haddock.Interface.Rename import Haddock.Types import Haddock.Options-import Haddock.GHC.Utils-import Haddock.GHC.Typecheck-import Haddock.Exception+import Haddock.GhcUtils import Haddock.Utils import Haddock.InterfaceFile import qualified Data.Map as Map-import Data.Map (Map) import Data.List+import Data.Maybe import Control.Monad import Control.Exception ( evaluate )+import Distribution.Verbosity -import GHC-import Name-import HscTypes ( msHsFilePath )+import GHC hiding (verbosity, flags) import Digraph-import BasicTypes-import SrcLoc import HscTypes -- | Turn a topologically sorted list of module names/filenames into interfaces. Also -- return the home link environment created in the process. #if __GLASGOW_HASKELL__ >= 609-createInterfaces :: [String] -> [Flag] -> [InterfaceFile]+createInterfaces :: Verbosity -> [String] -> [Flag] -> [InterfaceFile] -> Ghc ([Interface], LinkEnv)-createInterfaces modules flags extIfaces = do+createInterfaces verbosity modules flags extIfaces = do -- part 1, create interfaces let instIfaceMap = Map.fromList [ (instMod iface, iface) | ext <- extIfaces , iface <- ifInstalledIfaces ext ]- interfaces <- createInterfaces' modules flags instIfaceMap+ out verbosity verbose "Creating interfaces..."+ interfaces <- createInterfaces' verbosity modules flags instIfaceMap #else-createInterfaces :: Session -> [String] -> [Flag]+createInterfaces :: Verbosity -> Session -> [String] -> [Flag] -> [InterfaceFile] -> IO ([Interface], LinkEnv)-createInterfaces session modules flags extIfaces = do+createInterfaces verbosity session modules flags extIfaces = do -- part 1, create interfaces let instIfaceMap = Map.fromList [ (instMod iface, iface) | ext <- extIfaces , iface <- ifInstalledIfaces ext ]- interfaces <- createInterfaces' session modules flags instIfaceMap+ out verbosity verbose "Creating interfaces..."+ interfaces <- createInterfaces' verbosity session modules flags instIfaceMap #endif -- part 2, build link environment+ out verbosity verbose "Building link 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@@ -69,9 +71,11 @@ allNames = Map.keys links -- part 3, attach instances+ out verbosity verbose "Attaching instances..." let interfaces' = attachInstances interfaces allNames -- part 4, rename interfaces+ out verbosity verbose "Renaming interfaces..." let warnings = Flag_NoWarnings `notElem` flags let (interfaces'', msgs) = runWriter $ mapM (renameInterface links warnings) interfaces'@@ -81,8 +85,8 @@ #if __GLASGOW_HASKELL__ >= 609-createInterfaces' :: [String] -> [Flag] -> InstIfaceMap -> Ghc [Interface]-createInterfaces' modules flags instIfaceMap = do+createInterfaces' :: Verbosity -> [String] -> [Flag] -> InstIfaceMap -> Ghc [Interface]+createInterfaces' verbosity modules flags instIfaceMap = do targets <- mapM (\f -> guessTarget f Nothing) modules setTargets targets modgraph <- depanal [] False@@ -97,10 +101,10 @@ modgraph' <- if needsTemplateHaskell modgraph then do dflags <- getSessionDynFlags- setSessionDynFlags dflags { hscTarget = HscC } - -- we need to set HscC on all the ModSummaries as well- let addHscC m = m { ms_hspp_opts = (ms_hspp_opts m) { hscTarget = HscC } } - return (map addHscC modgraph)+ _ <- setSessionDynFlags dflags { hscTarget = HscAsm } + -- we need to set HscAsm on all the ModSummaries as well+ let addHscAsm m = m { ms_hspp_opts = (ms_hspp_opts m) { hscTarget = HscAsm } } + return (map addHscAsm modgraph) else return modgraph #else let modgraph' = modgraph@@ -108,10 +112,10 @@ let orderedMods = flattenSCCs $ topSortModuleGraph False modgraph' Nothing (ifaces, _) <- foldM (\(ifaces, modMap) modsum -> do- x <- processModule modsum flags modMap instIfaceMap+ x <- processModule verbosity modsum flags modMap instIfaceMap #else-createInterfaces' :: Session -> [String] -> [Flag] -> InstIfaceMap -> IO [Interface]-createInterfaces' session modules flags instIfaceMap = do+createInterfaces' :: Verbosity -> Session -> [String] -> [Flag] -> InstIfaceMap -> IO [Interface]+createInterfaces' verbosity session modules flags instIfaceMap = do targets <- mapM (\f -> guessTarget f Nothing) modules setTargets session targets mbGraph <- depanal session [] False@@ -120,7 +124,7 @@ Nothing -> throwE "Failed to create dependency graph" let orderedMods = flattenSCCs $ topSortModuleGraph False modgraph Nothing (ifaces, _) <- foldM (\(ifaces, modMap) modsum -> do- x <- processModule session modsum flags modMap instIfaceMap+ x <- processModule verbosity session modsum flags modMap instIfaceMap #endif case x of Just interface ->@@ -162,8 +166,9 @@ -} #if __GLASGOW_HASKELL__ >= 609-processModule :: ModSummary -> [Flag] -> ModuleMap -> InstIfaceMap -> Ghc (Maybe Interface)-processModule modsum flags modMap instIfaceMap = do+processModule :: Verbosity -> ModSummary -> [Flag] -> ModuleMap -> InstIfaceMap -> Ghc (Maybe Interface)+processModule verbosity modsum flags modMap instIfaceMap = do+ out verbosity verbose $ "Checking module " ++ moduleString (ms_mod modsum) ++ "..." tc_mod <- loadModule =<< typecheckModule =<< parseModule modsum if not $ isBootSummary modsum then do@@ -177,15 +182,17 @@ typecheckedSource tc_mod, moduleInfo tc_mod)) dynflags+ out verbosity verbose "Creating interface..." let (interface, msg) = runWriter $ createInterface ghcMod flags modMap instIfaceMap liftIO $ mapM_ putStrLn msg- liftIO $ evaluate interface- return (Just interface)+ interface' <- liftIO $ evaluate interface+ return (Just interface') else return Nothing #else-processModule :: Session -> ModSummary -> [Flag] -> ModuleMap -> InstIfaceMap -> IO (Maybe Interface)-processModule session modsum flags modMap instIfaceMap = do+processModule :: Verbosity -> Session -> ModSummary -> [Flag] -> ModuleMap -> InstIfaceMap -> IO (Maybe Interface)+processModule verbosity session modsum flags modMap instIfaceMap = do+ out verbosity verbose $ "Checking module " ++ moduleString (ms_mod modsum) ++ "..." let filename = msHsFilePath modsum mbMod <- checkAndLoadModule session modsum False if not $ isBootSummary modsum@@ -201,6 +208,41 @@ return Nothing #endif ++type CheckedMod = (Module, FilePath, FullyCheckedMod)+++type FullyCheckedMod = (ParsedSource, + RenamedSource, + TypecheckedSource, + ModuleInfo)+++-- | Dig out what we want from the typechecker output+mkGhcModule :: CheckedMod -> DynFlags -> GhcModule +mkGhcModule (mdl, file, checkedMod) dynflags = GhcModule {+ ghcModule = mdl,+ ghcFilename = file,+ ghcMbDocOpts = mbOpts,+ ghcHaddockModInfo = info,+ ghcMbDoc = mbDoc,+ ghcGroup = group_,+ ghcMbExports = mbExports,+ ghcExportedNames = modInfoExports modInfo,+ ghcDefinedNames = map getName $ modInfoTyThings modInfo,+ ghcNamesInScope = fromJust $ modInfoTopLevelScope modInfo, + ghcInstances = modInfoInstances modInfo+}+ where+#if __GLASGOW_HASKELL__ == 608 && __GHC_PATCHLEVEL__ == 2+ HsModule _ _ _ _ _ mbOpts _ _ = unLoc parsed+#else+ mbOpts = haddockOptions dynflags+#endif+ (group_, _, mbExports, mbDoc, info) = renamed+ (_, renamed, _, modInfo) = checkedMod++ -- | 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@@ -219,6 +261,6 @@ | otherwise = foldl' keep_new old_env exported_names where exported_names = ifaceVisibleExports iface- mod = ifaceMod iface- keep_old env n = Map.insertWith (\new old -> old) n mod env- keep_new env n = Map.insert n mod env+ mdl = ifaceMod iface+ keep_old env n = Map.insertWith (\_ old -> old) n mdl env+ keep_new env n = Map.insert n mdl env
src/Haddock/Interface/AttachInstances.hs view
@@ -1,18 +1,19 @@------ Haddock - A Haskell Documentation Tool------ (c) Simon Marlow 2003----- {-# LANGUAGE MagicHash #-}-+-----------------------------------------------------------------------------+-- |+-- Module : Haddock.Interface.AttachInstances+-- Copyright : (c) David Waern 2006-2009+-- License : BSD-like+--+-- Maintainer : haddock@projects.haskell.org+-- Stability : experimental+-- Portability : portable+----------------------------------------------------------------------------- module Haddock.Interface.AttachInstances (attachInstances) where import Haddock.Types-import Haddock.GHC.Utils import qualified Data.Map as Map import Data.Map (Map)@@ -20,7 +21,6 @@ import GHC import Name-import SrcLoc import InstEnv import Class @@ -33,21 +33,20 @@ import Var hiding (varName) import TyCon import PrelNames-import HscTypes import FastString #define FSLIT(x) (mkFastString# (x#)) attachInstances :: [Interface] -> [Name] -> [Interface]-attachInstances modules filterNames = map attach modules+attachInstances ifaces filterNames = map attach ifaces where instMap = fmap (map toHsInstHead . sortImage instHead) $- collectInstances modules filterNames+ collectInstances ifaces filterNames - attach mod = mod { ifaceExportItems = newItems }+ attach iface = iface { ifaceExportItems = newItems } where- newItems = map attachExport (ifaceExportItems mod)+ newItems = map attachExport (ifaceExportItems iface) attachExport (ExportDecl decl@(L _ (TyClD d)) doc subs _) | isClassDecl d || isDataDecl d || isFamilyDecl d =@@ -72,13 +71,15 @@ -> [Name] -> Map Name [([TyVar], [PredType], Class, [Type])] -- maps class/type names to instances -collectInstances modules filterNames+collectInstances ifaces _ -- filterNames = Map.fromListWith (flip (++)) tyInstPairs `Map.union` Map.fromListWith (flip (++)) classInstPairs where- allInstances = concat (map ifaceInstances modules)+ allInstances = concatMap ifaceInstances ifaces classInstPairs = [ (is_cls inst, [instanceHead inst]) | - inst <- allInstances, Just n <- nub (is_tcs inst) ]+ inst <- allInstances ]+ -- unfinished filtering of internal instances+ -- Just n <- nub (is_tcs inst) ] -- n `elem` filterNames ] tyInstPairs = [ (tycon, [instanceHead inst]) | inst <- allInstances, Just tycon <- nub (is_tcs inst) ] @@ -98,8 +99,8 @@ simplify (ForAllTy _ t) = simplify t simplify (FunTy t1 t2) = SimpleType funTyConName [simplify t1, simplify t2]- simplify (AppTy t1 t2) = SimpleType s (args ++ [simplify t2])- where (SimpleType s args) = simplify t1+ 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 _ = error "simplify"@@ -111,6 +112,7 @@ where cmp_fst (x,_) (y,_) = compare x y +funTyConName :: Name funTyConName = mkWiredInName gHC_PRIM (mkOccNameFS tcName FSLIT("(->)")) funTyConKey@@ -133,6 +135,7 @@ toHsPred (EqPred t1 t2) = HsEqualP (toLHsType t1) (toLHsType t2) +toLHsType :: Type -> Located (HsType Name) toLHsType = noLoc . toHsType @@ -148,11 +151,11 @@ _ -> app (tycon tc) ts FunTy a b -> HsFunTy (toLHsType a) (toLHsType b)- ForAllTy v t -> cvForAll [v] t + ForAllTy v ty -> cvForAll [v] ty PredTy p -> HsPredTy (toHsPred p) where- tycon tc = HsTyVar (tyConName tc)- app tc ts = foldl (\a b -> HsAppTy (noLoc a) (noLoc b)) tc (map toHsType ts)- cvForAll vs (ForAllTy v t) = cvForAll (v:vs) t- cvForAll vs t = mkExplicitHsForAllTy (tyvarbinders vs) (noLoc []) (toLHsType t)- tyvarbinders vs = map (noLoc . UserTyVar . tyVarName) vs+ tycon = HsTyVar . tyConName+ app tc = foldl (\a b -> HsAppTy (noLoc a) (noLoc b)) tc . map toHsType+ cvForAll vs (ForAllTy v ty) = cvForAll (v:vs) ty+ cvForAll vs ty = mkExplicitHsForAllTy (tyvarbinders vs) (noLoc []) (toLHsType ty)+ tyvarbinders = map (noLoc . UserTyVar . tyVarName)
src/Haddock/Interface/Create.hs view
@@ -1,40 +1,33 @@------ Haddock - A Haskell Documentation Tool------ (c) Simon Marlow 2003+-----------------------------------------------------------------------------+-- |+-- Module : Haddock.Interface.Create+-- 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.Create (createInterface) where import Haddock.Types import Haddock.Options-import Haddock.GHC.Utils+import Haddock.GhcUtils import Haddock.Utils import qualified Data.Map as Map import Data.Map (Map) import Data.List import Data.Maybe-import Data.Char import Data.Ord import Control.Monad-import Control.Arrow -import GHC-import Outputable-import SrcLoc+import GHC hiding (flags) import Name-import Module-import InstEnv-import Class-import TypeRep-import Var hiding (varName)-import TyCon-import PrelNames import Bag-import HscTypes -- | Process the data in the GhcModule to produce an interface.@@ -44,26 +37,26 @@ -> ErrMsgM Interface createInterface ghcMod flags modMap instIfaceMap = do - let mod = ghcModule ghcMod+ let mdl = ghcModule ghcMod - opts0 <- mkDocOpts (ghcMbDocOpts ghcMod) flags mod+ opts0 <- mkDocOpts (ghcMbDocOpts ghcMod) flags mdl let opts | Flag_IgnoreAllExports `elem` flags = OptIgnoreExports : opts0 | otherwise = opts0 - let group = ghcGroup ghcMod+ let group_ = ghcGroup ghcMod exports = fmap (reverse . map unLoc) (ghcMbExports ghcMod) localNames = ghcDefinedNames ghcMod- decls0 = declInfos . topDecls $ group+ decls0 = declInfos . topDecls $ group_ decls = filterOutInstances decls0 declMap = mkDeclMap decls ignoreExps = Flag_IgnoreAllExports `elem` flags exportedNames = ghcExportedNames ghcMod instances = ghcInstances ghcMod - warnAboutFilteredDecls mod decls0+ warnAboutFilteredDecls mdl decls0 - exportItems <- mkExportItems modMap mod (ghcExportedNames ghcMod) decls declMap+ exportItems <- mkExportItems modMap mdl (ghcExportedNames ghcMod) decls declMap opts exports ignoreExps instances instIfaceMap let visibleNames = mkVisibleNames exportItems opts@@ -76,7 +69,7 @@ | otherwise = exportItems return Interface {- ifaceMod = mod,+ ifaceMod = mdl, ifaceOrigFilename = ghcFilename ghcMod, ifaceInfo = ghcHaddockModInfo ghcMod, ifaceDoc = ghcMbDoc ghcMod,@@ -102,13 +95,13 @@ mkDocOpts :: Maybe String -> [Flag] -> Module -> ErrMsgM [DocOption]-mkDocOpts mbOpts flags mod = do+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 []- if Flag_HideModule (moduleString mod) `elem` flags + if Flag_HideModule (moduleString mdl) `elem` flags then return $ OptHide : opts else return opts @@ -150,6 +143,7 @@ | (parent@(L _ d), doc) <- decls] +subordinates :: HsDecl Name -> [(Name, Maybe Doc)] subordinates (TyClD d) = classDataSubs d subordinates _ = [] @@ -172,21 +166,25 @@ -- All the sub declarations of a class (that we handle), ordered by -- source location, with documentation attached if it exists. +classDecls :: TyClDecl Name -> [(Decl, Maybe Doc)] classDecls = filterDecls . collectDocs . sortByLoc . declsFromClass +declsFromClass :: TyClDecl a -> [Located (HsDecl a)] declsFromClass class_ = docs ++ defs ++ sigs ++ ats where - docs = decls tcdDocs DocD class_- defs = decls (bagToList . tcdMeths) ValD class_- sigs = decls tcdSigs SigD class_- ats = decls tcdATs TyClD class_+ docs = mkDecls tcdDocs DocD class_+ defs = mkDecls (bagToList . tcdMeths) ValD class_+ sigs = mkDecls tcdSigs SigD class_+ ats = mkDecls tcdATs TyClD class_ +declName :: HsDecl a -> a declName (TyClD d) = tcdName d declName (ForD (ForeignImport n _ _)) = unLoc n -- we have normal sigs only (since they are taken from ValBindsOut) declName (SigD sig) = fromJust $ sigNameNoLoc sig+declName _ = error "unexpected argument to declName" -- | The top-level declarations of a module that we care about, @@ -195,39 +193,44 @@ topDecls = filterClasses . filterDecls . collectDocs . sortByLoc . declsFromGroup +filterOutInstances :: [(Located (HsDecl a), b, c)] -> [(Located (HsDecl a), b, c)] filterOutInstances = filter (\(L _ d, _, _) -> not (isInstD d)) -- | Take all declarations except pragmas, infix decls, rules and value -- bindings from an 'HsGroup'. declsFromGroup :: HsGroup Name -> [Decl]-declsFromGroup group = - decls hs_tyclds TyClD group ++- decls hs_derivds DerivD group ++- decls hs_defds DefD group ++- decls hs_fords ForD group ++- decls hs_docs DocD group ++- decls hs_instds InstD group ++- decls (typesigs . hs_valds) SigD group+declsFromGroup group_ = + mkDecls 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_ where typesigs (ValBindsOut _ sigs) = filter isVanillaLSig sigs+ typesigs _ = error "expected ValBindsOut" -- | Take a field of declarations from a data structure and create HsDecls -- using the given constructor-decls field con struct = [ L loc (con decl) | L loc decl <- field struct ]+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) -warnAboutFilteredDecls mod decls = do- let modStr = moduleString mod+warnAboutFilteredDecls :: Module -> [(LHsDecl Name, b, c)] -> ErrMsgM ()+warnAboutFilteredDecls mdl decls = do+ let modStr = moduleString mdl let typeInstances = nub [ tcdName d | (L _ (TyClD d), _, _) <- decls, isFamInstDecl d ] - when (not $null typeInstances) $+ unless (null typeInstances) $ tell $ nub [ "Warning: " ++ modStr ++ ": Instances of type and data " ++ "families are not yet supported. Instances of the following families "@@ -237,9 +240,8 @@ let instances = nub [ pretty i | (L _ (InstD (InstDecl i _ _ ats)), _, _) <- decls , not (null ats) ] - when (not $ null instances) $-- tell $ nub $ [+ unless (null instances) $+ tell $ nub [ "Warning: " ++ modStr ++ ": We do not support associated types in instances yet. " ++ "These instances are affected:\n" ++ (concat $ intersperse ", " instances) ] @@ -271,6 +273,7 @@ where filterClass (TyClD c) = TyClD $ c { tcdSigs = filter isVanillaLSig $ tcdSigs c } + filterClass _ = error "expected TyClD" --------------------------------------------------------------------------------@@ -284,7 +287,7 @@ -- | Collect the docs and attach them to the right declaration. collectDocs :: [Decl] -> [(Decl, (Maybe Doc))]-collectDocs decls = collect Nothing DocEmpty decls+collectDocs = collect Nothing DocEmpty collect :: Maybe Decl -> Doc -> [Decl] -> [(Decl, (Maybe Doc))] collect d doc_so_far [] =@@ -343,15 +346,17 @@ -> ErrMsgM [ExportItem Name] mkExportItems modMap this_mod exported_names decls declMap- opts maybe_exps ignore_all_exports instances instIfaceMap+ opts maybe_exps ignore_all_exports _ instIfaceMap | isNothing maybe_exps || ignore_all_exports || OptIgnoreExports `elem` opts = everything_local_exported- | Just specs <- maybe_exps = liftM concat $ mapM lookupExport specs+ | otherwise = liftM concat $ mapM lookupExport (fromJust maybe_exps) where- instances = [ d | d@(L _ decl, _, _) <- decls, isInstD decl ] +-- creating export items for intsances (unfinished experiment)+-- instances = [ d | d@(L _ decl, _, _) <- decls, isInstD decl ]+ everything_local_exported = -- everything exported- return (fullContentsOfThisModule this_mod decls)+ return (fullContentsOfThisModule decls) lookupExport (IEVar x) = declWith x@@ -363,7 +368,7 @@ -- absFam (Nothing, instances) = lookupExport (IEThingAll t) = declWith t- lookupExport (IEThingWith t cs) = declWith t+ lookupExport (IEThingWith t _) = declWith t lookupExport (IEModuleContents m) = fullContentsOf m lookupExport (IEGroup lev doc) = return [ ExportGroup lev "" doc ] lookupExport (IEDoc doc) = return [ ExportDoc doc ] @@ -377,9 +382,9 @@ declWith t = case findDecl t of Just x@(decl,_,_) ->- let declName =+ let declName_ = case getMainDeclBinder (unL decl) of- Just declName -> declName+ Just n -> n Nothing -> error "declWith: should not happen" in case () of _@@ -390,7 +395,7 @@ -- We should not show a subordinate by itself if any of its -- parents is also exported. See note [1].- | t /= declName,+ | t /= declName_, Just p <- find isExported (parents t $ unL decl) -> do tell [ "Warning: " ++ moduleString this_mod ++ ": " ++@@ -425,7 +430,7 @@ isExported n = n `elem` exported_names fullContentsOf modname- | m == this_mod = return (fullContentsOfThisModule this_mod decls)+ | m == this_mod = return (fullContentsOfThisModule decls) | otherwise = case Map.lookup m modMap of Just iface@@ -473,8 +478,8 @@ -- (For more information, see Trac #69) -fullContentsOfThisModule :: Module -> [DeclInfo] -> [ExportItem Name]-fullContentsOfThisModule module_ decls = catMaybes (map mkExportItem decls)+fullContentsOfThisModule :: [DeclInfo] -> [ExportItem Name]+fullContentsOfThisModule decls = catMaybes (map mkExportItem decls) where mkExportItem (L _ (DocD (DocGroup lev doc)), _, _) = Just $ ExportGroup lev "" doc mkExportItem (L _ (DocD (DocCommentNamed _ doc)), _, _) = Just $ ExportDoc doc@@ -498,7 +503,7 @@ -- let assocMathes = [ tyDecl | at <- tcdATs d, ] in case matches of [s0] -> let (n, tyvar_names) = name_and_tyvars d- L pos sig = extractClassDecl n mdl tyvar_names s0+ L pos sig = extractClassDecl n tyvar_names s0 in L pos (SigD sig) _ -> error "internal: extractDecl" TyClD d | isDataDecl d -> @@ -511,23 +516,18 @@ toTypeNoLoc :: Located Name -> LHsType Name-toTypeNoLoc lname = noLoc (HsTyVar (unLoc lname))---rmLoc :: Located a -> Located a-rmLoc a = noLoc (unLoc a)+toTypeNoLoc = noLoc . HsTyVar . unLoc -extractClassDecl :: Name -> Module -> [Located Name] -> LSig Name -> LSig Name-extractClassDecl c mdl tvs0 (L pos (TypeSig lname ltype)) = case ltype of- L _ (HsForAllTy exp tvs (L _ preds) ty) -> - L pos (TypeSig lname (noLoc (HsForAllTy exp tvs (lctxt preds) ty)))+extractClassDecl :: Name -> [Located Name] -> LSig Name -> LSig Name+extractClassDecl c tvs0 (L pos (TypeSig lname ltype)) = case ltype of+ L _ (HsForAllTy expl tvs (L _ preds) ty) -> + L pos (TypeSig lname (noLoc (HsForAllTy expl tvs (lctxt preds) ty))) _ -> L pos (TypeSig lname (noLoc (mkImplicitHsForAllTy (lctxt []) ltype))) where- lctxt preds = noLoc (ctxt preds)- ctxt preds = [noLoc (HsClassP c (map toTypeNoLoc tvs0))] ++ preds --extractClassDecl _ _ _ d = error $ "extractClassDecl: unexpected decl"+ lctxt = noLoc . ctxt+ ctxt preds = noLoc (HsClassP c (map toTypeNoLoc tvs0)) : preds +extractClassDecl _ _ _ = error "extractClassDecl: unexpected decl" extractRecSel :: Name -> Module -> Name -> [Located Name] -> [LConDecl Name]@@ -540,7 +540,7 @@ L (getLoc n) (TypeSig (noLoc nm) (noLoc (HsFunTy data_ty (getBangType ty)))) _ -> extractRecSel nm mdl t tvs rest where - matching_fields flds = [ f | f@(ConDeclField n _ _) <- flds, (unLoc n) == nm ] + matching_fields flds = [ f | f@(ConDeclField n _ _) <- flds, unLoc n == nm ] data_ty = foldl (\x y -> noLoc (HsAppTy x y)) (noLoc (HsTyVar t)) (map toTypeNoLoc tvs) @@ -561,31 +561,9 @@ Just n -> n : subs Nothing -> subs where subs = map fst (expItemSubDocs e) - exportName e@ExportNoDecl {} = [] -- we don't count these as visible, since- -- we don't want links to go to them.+ exportName ExportNoDecl {} = [] -- we don't count these as visible, since+ -- we don't want links to go to them. exportName _ = []-- -exportModuleMissingErr this mdl - = ["Warning: in export list of " ++ show (moduleString this)- ++ ": module not found: " ++ show (moduleString mdl)]----- | For a given entity, find all the names it "owns" (ie. all the--- constructors and field names of a tycon, or all the methods of a--- class).-allSubsOfName :: Map Module Interface -> Name -> [Name]-allSubsOfName ifaces name =- case Map.lookup (nameModule name) ifaces of- Just iface -> subsOfName name (ifaceDeclMap iface)- Nothing -> []---subsOfName :: Name -> Map Name DeclInfo -> [Name]-subsOfName n declMap =- case Map.lookup n declMap of- Just (_, _, subs) -> map fst subs- Nothing -> [] -- | Find a stand-alone documentation comment by its name
src/Haddock/Interface/Rename.hs view
@@ -1,93 +1,92 @@------ Haddock - A Haskell Documentation Tool------ (c) Simon Marlow 2003+----------------------------------------------------------------------------+-- |+-- 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 Haddock.DocName import Haddock.Types-import Haddock.GHC.Utils+import Haddock.GhcUtils import GHC hiding (NoLink) import Name import BasicTypes-import SrcLoc import Bag (emptyBag)-import Outputable-import Util (thenCmp) import Data.List-import Data.Map (Map) import qualified Data.Map as Map hiding ( Map ) import Prelude hiding (mapM) import Data.Traversable (mapM)-import Control.Arrow import Control.Monad hiding (mapM) renameInterface :: LinkEnv -> Bool -> Interface -> ErrMsgM Interface-renameInterface renamingEnv warnings mod =+renameInterface 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 mod)- where fn env name = Map.insert name (ifaceMod mod) env- - docMap = Map.map (\(_,x,_) -> x) (ifaceDeclMap mod)+ let localEnv = foldl fn renamingEnv (ifaceVisibleExports iface)+ where fn env name = Map.insert name (ifaceMod iface) env++ docMap = Map.map (\(_,x,_) -> x) (ifaceDeclMap iface) docs = [ (n, doc) | (n, Just doc) <- Map.toList docMap ]- renameMapElem (k,d) = do d' <- renameDoc d; return (k, d') + renameMapElem (k,d) = do d' <- renameDoc d; return (k, d') -- 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 mod))+ = runRnFM localEnv (renameExportItems (ifaceExportItems iface)) - (rnDocMap, missingNames2) + (rnDocMap, missingNames2) = runRnFM localEnv (liftM Map.fromList (mapM renameMapElem docs)) (finalModuleDoc, missingNames3)- = runRnFM localEnv (renameMaybeDoc (ifaceDoc mod))+ = runRnFM localEnv (renameMaybeDoc (ifaceDoc iface)) -- combine the missing names and filter out the built-ins, which would- -- otherwise allways be missing. + -- otherwise allways be missing. missingNames = nub $ filter isExternalName (missingNames1 ++ missingNames2 ++ missingNames3) - -- filter out certain built in type constructors using their string + -- filter out certain built in type constructors using their string -- representation. TODO: use the Name constants from the GHC API.--- strings = filter (`notElem` ["()", "[]", "(->)"]) +-- strings = filter (`notElem` ["()", "[]", "(->)"]) -- (map pretty missingNames) strings = map pretty . 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 mod || null strings || not warnings) $- tell ["Warning: " ++ moduleString (ifaceMod mod) +++ unless (OptHide `elem` ifaceOptions iface || null strings || not warnings) $+ tell ["Warning: " ++ moduleString (ifaceMod iface) ++ ": could not find link destinations for:\n"++- " " ++ concat (map (' ':) strings) ]+ unwords (" " : strings) ] - return $ mod { ifaceRnDoc = finalModuleDoc,- ifaceRnDocMap = rnDocMap,- ifaceRnExportItems = renamedExportItems }+ return $ iface { ifaceRnDoc = finalModuleDoc,+ ifaceRnDocMap = rnDocMap,+ 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 +-- renaming, and it returns a list of names which couldn't be found in -- the environment. -------------------------------------------------------------------------------- -newtype GenRnM n a = - RnM { unRn :: (n -> (Bool, DocName)) -- name lookup function+newtype GenRnM n a =+ RnM { unRn :: (n -> (Bool, DocName)) -- name lookup function -> (a,[n]) } @@ -95,34 +94,34 @@ instance Monad (GenRnM n) where (>>=) = thenRn- return = returnRn + return = returnRn returnRn :: a -> GenRnM n a-returnRn a = RnM (\_ -> (a,[]))+returnRn a = RnM (const (a,[])) thenRn :: GenRnM n a -> (a -> GenRnM n b) -> GenRnM n b-m `thenRn` k = RnM (\lkp -> case unRn m lkp of - (a,out1) -> case unRn (k a) lkp of- (b,out2) -> (b,out1++out2))+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 (\_ -> ((),[name]))+outRn name = RnM (const ((),[name])) lookupRn :: (DocName -> a) -> Name -> RnM a lookupRn and_then name = do lkp <- getLookupRn case lkp name of- (False,maps_to) -> do outRn name; return (and_then maps_to)- (True, maps_to) -> return (and_then maps_to)+ (False,maps_to) -> do outRn name; return (and_then maps_to)+ (True, maps_to) -> return (and_then maps_to) runRnFM :: LinkEnv -> RnM a -> (a,[Name])-runRnFM env rn = unRn rn lkp - where +runRnFM env rn = unRn rn lkp+ where lkp n = case Map.lookup n env of- Nothing -> (False, Undocumented n) - Just mod -> (True, Documented n mod)+ Nothing -> (False, Undocumented n)+ Just mdl -> (True, Documented n mdl) --------------------------------------------------------------------------------@@ -130,23 +129,28 @@ -------------------------------------------------------------------------------- -rename = lookupRn id -renameL (L loc name) = return . L loc =<< rename name+rename :: Name -> RnM DocName+rename = lookupRn id +renameL :: Located Name -> RnM (Located DocName)+renameL = mapM rename++ renameExportItems :: [ExportItem Name] -> RnM [ExportItem DocName]-renameExportItems items = mapM renameExportItem items+renameExportItems = mapM renameExportItem renameMaybeDoc :: Maybe (HsDoc Name) -> RnM (Maybe (HsDoc DocName))-renameMaybeDoc mbDoc = mapM renameDoc mbDoc+renameMaybeDoc = mapM renameDoc -renameLDoc (L loc doc) = return . L loc =<< renameDoc doc+renameLDoc :: LHsDoc Name -> RnM (LHsDoc DocName)+renameLDoc = mapM renameDoc renameDoc :: HsDoc Name -> RnM (HsDoc DocName)-renameDoc doc = case doc of+renameDoc d = case d of DocEmpty -> return DocEmpty DocAppend a b -> do a' <- renameDoc a@@ -179,21 +183,22 @@ a' <- renameDoc a b' <- renameDoc b return (a',b')) docs- return (DocDefList docs') + return (DocDefList docs') DocCodeBlock doc -> do doc' <- renameDoc doc return (DocCodeBlock doc')- DocURL str -> return (DocURL str) + DocURL str -> return (DocURL str) DocPic str -> return (DocPic str) DocAName str -> return (DocAName str) -renameLPred (L loc p) = return . L loc =<< renamePred p+renameLPred :: LHsPred Name -> RnM (LHsPred DocName)+renameLPred = mapM renamePred renamePred :: HsPred Name -> RnM (HsPred DocName) renamePred (HsClassP name types) = do- name' <- rename name + name' <- rename name types' <- mapM renameLType types return (HsClassP name' types') renamePred (HsEqualP type1 type2) = do@@ -206,31 +211,33 @@ return (HsIParam (IPName name') t') -renameLType (L loc t) = return . L loc =<< renameType t+renameLType :: LHsType Name -> RnM (LHsType DocName)+renameLType = mapM renameType -renameType t = case t of +renameType :: HsType Name -> RnM (HsType DocName)+renameType t = case t of HsForAllTy expl tyvars lcontext ltype -> do tyvars' <- mapM renameLTyVarBndr tyvars- lcontext' <- renameLContext lcontext + 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 + HsFunTy a b -> do a' <- renameLType a b' <- renameLType b return (HsFunTy a' b') - HsListTy t -> return . HsListTy =<< renameLType t- HsPArrTy t -> return . HsPArrTy =<< renameLType t+ HsListTy ty -> return . HsListTy =<< renameLType ty+ HsPArrTy ty -> return . HsPArrTy =<< renameLType ty HsTupleTy b ts -> return . HsTupleTy b =<< mapM renameLType ts @@ -240,29 +247,31 @@ b' <- renameLType b return (HsOpTy a' (L loc op') b') - HsParTy t -> return . HsParTy =<< renameLType t+ HsParTy ty -> return . HsParTy =<< renameLType ty HsNumTy n -> return (HsNumTy n) HsPredTy p -> return . HsPredTy =<< renamePred p - HsKindSig t k -> do- t' <- renameLType t- return (HsKindSig t' k)+ HsKindSig ty k -> do+ ty' <- renameLType ty+ return (HsKindSig ty' k) - HsDocTy t doc -> do- t' <- renameLType t+ HsDocTy ty doc -> do+ ty' <- renameLType ty doc' <- renameLDoc doc- return (HsDocTy t' doc')+ return (HsDocTy ty' doc') _ -> error "renameType" +renameLTyVarBndr :: LHsTyVarBndr Name -> RnM (LHsTyVarBndr DocName) renameLTyVarBndr (L loc tv) = do name' <- rename (hsTyVarName tv) return $ L loc (replaceTyVarName tv name') - ++renameLContext :: Located [LHsPred Name] -> RnM (Located [LHsPred DocName]) renameLContext (L loc context) = do context' <- mapM renameLPred context return (L loc context')@@ -276,10 +285,12 @@ return (preds', className', types') +renameLDecl :: LHsDecl Name -> RnM (LHsDecl DocName) renameLDecl (L loc d) = return . L loc =<< renameDecl d -renameDecl d = case d of+renameDecl :: HsDecl Name -> RnM (HsDecl DocName)+renameDecl decl = case decl of TyClD d -> do d' <- renameTyClD d return (TyClD d')@@ -295,13 +306,21 @@ _ -> error "renameDecl" -renameLTyClD (L loc d) = return . L loc =<< renameTyClD d +renameLTyClD :: LTyClDecl Name -> RnM (LTyClDecl DocName)+renameLTyClD (L loc d) = return . L loc =<< renameTyClD d +renameTyClD :: TyClDecl Name -> RnM (TyClDecl DocName) renameTyClD d = case d of+#if __GLASGOW_HASKELL__ >= 611+ ForeignType lname b -> do+ lname' <- renameL lname+ return (ForeignType lname' b)+#else ForeignType lname a b -> do lname' <- renameL lname return (ForeignType lname' a b)+#endif TyFamily flav lname ltyvars kind -> do lname' <- renameL lname@@ -315,8 +334,8 @@ typats' <- mapM (mapM renameLType) typats cons' <- mapM renameLCon cons -- I don't think we need the derivings, so we return Nothing- return (TyData x lcontext' lname' ltyvars' typats' k cons' Nothing) - + return (TyData x lcontext' lname' ltyvars' typats' k cons' Nothing)+ TySynonym lname ltyvars typats ltype -> do lname' <- renameL lname ltyvars' <- mapM renameLTyVarBndr ltyvars@@ -328,22 +347,25 @@ lcontext' <- renameLContext lcontext lname' <- renameL lname ltyvars' <- mapM renameLTyVarBndr ltyvars- lfundeps' <- mapM renameLFunDep lfundeps + lfundeps' <- mapM renameLFunDep lfundeps lsigs' <- mapM renameLSig lsigs ats' <- mapM renameLTyClD ats -- we don't need the default methods or the already collected doc entities return (ClassDecl lcontext' lname' ltyvars' lfundeps' lsigs' emptyBag ats' [])- + where renameLCon (L loc con) = return . L loc =<< renameCon con- renameCon (ConDecl lname expl ltyvars lcontext details restype mbldoc) = do+ renameCon decl@(ConDecl { con_name = lname, con_qvars = ltyvars+ , con_cxt = lcontext, con_details = details+ , con_res = restype, con_doc = mbldoc }) = do lname' <- renameL lname ltyvars' <- mapM renameLTyVarBndr ltyvars lcontext' <- renameLContext lcontext details' <- renameDetails details restype' <- renameResType restype mbldoc' <- mapM renameLDoc mbldoc- return (ConDecl lname' expl ltyvars' lcontext' details' restype' mbldoc') + return (decl { con_name = lname', con_qvars = ltyvars', con_cxt = lcontext'+ , con_details = details', con_res = restype', con_doc = mbldoc' }) renameDetails (RecCon fields) = return . RecCon =<< mapM renameField fields renameDetails (PrefixCon ps) = return . PrefixCon =<< mapM renameLType ps@@ -365,18 +387,21 @@ xs' <- mapM rename xs ys' <- mapM rename ys return (L loc (xs', ys'))- + renameLSig (L loc sig) = return . L loc =<< renameSig sig - -renameSig sig = case sig of - TypeSig lname ltype -> do ++renameSig :: Sig Name -> RnM (Sig DocName)+renameSig sig = case sig of+ TypeSig lname ltype -> do lname' <- renameL lname ltype' <- renameLType ltype return (TypeSig lname' ltype') -- 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 x) = do lname' <- renameL lname ltype' <- renameLType ltype@@ -387,18 +412,19 @@ return (ForeignExport lname' ltype' x) +renameInstD :: InstDecl Name -> RnM (InstDecl DocName) renameInstD (InstDecl ltype _ _ lATs) = do- ltype <- renameLType ltype+ ltype' <- renameLType ltype lATs' <- mapM renameLTyClD lATs- return (InstDecl ltype emptyBag [] lATs') + return (InstDecl ltype' emptyBag [] lATs') renameExportItem :: ExportItem Name -> RnM (ExportItem DocName)-renameExportItem item = case item of - ExportModule mod -> return (ExportModule mod)- ExportGroup lev id doc -> do+renameExportItem item = case item of+ ExportModule mdl -> return (ExportModule mdl)+ ExportGroup lev id_ doc -> do doc' <- renameDoc doc- return (ExportGroup lev id doc')+ return (ExportGroup lev id_ doc') ExportDecl decl doc subs instances -> do decl' <- renameLDecl decl doc' <- mapM renameDoc doc@@ -414,6 +440,7 @@ return (ExportDoc doc') +renameSub :: (Name, Maybe (HsDoc Name)) -> RnM (DocName, Maybe (HsDoc DocName)) renameSub (n,doc) = do n' <- rename n doc' <- mapM renameDoc doc
src/Haddock/InterfaceFile.hs view
@@ -1,11 +1,16 @@ {-# OPTIONS_GHC -fno-warn-orphans #-}------- Haddock - A Haskell Documentation Tool+-----------------------------------------------------------------------------+-- |+-- Module : Haddock.InterfaceFile+-- Copyright : (c) David Waern 2006-2009+-- License : BSD-like ----- (c) Simon Marlow 2003+-- Maintainer : haddock@projects.haskell.org+-- Stability : experimental+-- Portability : portable ---+-- Reading and writing the .haddock interface file+----------------------------------------------------------------------------- module Haddock.InterfaceFile ( InterfaceFile(..),@@ -14,29 +19,23 @@ ) where -import Haddock.DocName () import Haddock.Types-import Haddock.Utils+import Haddock.Utils hiding (out) import Data.List import Data.Word import Data.Array import Data.IORef import qualified Data.Map as Map-import System.IO-import Control.Monad import GHC hiding (NoLink)-import SrcLoc (noSrcSpan) -- tmp, GHC now exports this import Binary import Name import UniqSupply import UniqFM import IfaceEnv-import Module import HscTypes import FastMutInt-import HsDoc #if __GLASGOW_HASKELL__ >= 609 import FastString import Unique@@ -52,26 +51,13 @@ binaryInterfaceMagic = 0xD0Cface --- Since datatypes in GHC might change between patchlevel versions,--- and because we store GHC datatypes in our interface files,--- we need to make sure we version our interface files accordingly.------ Instead of adding one, we add five to all version numbers--- when one of our own (stored) datatypes is changed. +-- 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. binaryInterfaceVersion :: Word16-#if __GLASGOW_HASKELL__ == 608 && __GHC_PATCHLEVEL__ == 2-binaryInterfaceVersion = 9-#endif -#if __GLASGOW_HASKELL__ == 608 && __GHC_PATCHLEVEL__ == 3-binaryInterfaceVersion = 10-#endif -#if __GLASGOW_HASKELL__ == 610 && __GHC_PATCHLEVEL__ == 1-binaryInterfaceVersion = 11-#endif-#if __GLASGOW_HASKELL__ == 610 && __GHC_PATCHLEVEL__ == 2+#if __GLASGOW_HASKELL__ == 610 binaryInterfaceVersion = 12-#endif-#if __GLASGOW_HASKELL__ == 611+#elif __GLASGOW_HASKELL__ == 611 binaryInterfaceVersion = 13 #endif @@ -515,3 +501,26 @@ stabi <- get bh maint <- get bh return (HaddockModInfo descr porta stabi maint)+++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"+
src/Haddock/ModuleTree.hs view
@@ -1,8 +1,14 @@------ Haddock - A Haskell Documentation Tool------ (c) Simon Marlow 2003+-----------------------------------------------------------------------------+-- |+-- 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
src/Haddock/Options.hs view
@@ -1,8 +1,16 @@------ Haddock - A Haskell Documentation Tool+-----------------------------------------------------------------------------+-- |+-- Module : Haddock.Options+-- Copyright : (c) Simon Marlow 2003-2006,+-- David Waern 2006-2009+-- License : BSD-like ----- (c) Simon Marlow 2003+-- Maintainer : haddock@projects.haskell.org+-- Stability : experimental+-- Portability : portable --+-- Definition of the command line interface of Haddock+----------------------------------------------------------------------------- module Haddock.Options (@@ -15,7 +23,7 @@ import Haddock.Utils-import Haddock.Exception+import Haddock.Types import System.Console.GetOpt @@ -72,7 +80,7 @@ | Flag_WikiModuleURL String | Flag_WikiEntityURL String | Flag_Help- | Flag_Verbose+ | Flag_Verbosity String | Flag_Version | Flag_UseContents String | Flag_GenContents@@ -84,6 +92,7 @@ | Flag_GhcLibDir String | Flag_GhcVersion | Flag_NoWarnings+ | Flag_UseUnicode deriving (Eq) @@ -104,6 +113,7 @@ -- "output in DocBook XML", Option ['h'] ["html"] (NoArg Flag_Html) "output in HTML",+ Option ['U'] ["use-unicode"] (NoArg Flag_UseUnicode) "use Unicode in HTML output", Option [] ["hoogle"] (NoArg Flag_Hoogle) "output for Hoogle", Option [] ["html-help"] (ReqArg Flag_HtmlHelp "format")@@ -133,8 +143,8 @@ "display this help and exit", Option ['V'] ["version"] (NoArg Flag_Version) "output version information and exit",- Option ['v'] ["verbose"] (NoArg Flag_Verbose)- "increase verbosity",+ 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)
src/Haddock/Types.hs view
@@ -1,18 +1,26 @@ {-# OPTIONS_HADDOCK hide #-}------- Haddock - A Haskell Documentation Tool+{-# LANGUAGE DeriveDataTypeable #-}+-----------------------------------------------------------------------------+-- |+-- Module : Haddock.Types+-- Copyright : (c) Simon Marlow 2003-2006,+-- David Waern 2006-2009+-- License : BSD-like ----- (c) Simon Marlow 2003+-- 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 where -import Haddock.DocName+import Control.Exception+import Data.Typeable import Data.Map (Map)-import qualified Data.Map as Map import GHC hiding (NoLink) import Name @@ -27,6 +35,22 @@ type DeclInfo = (Decl, Maybe Doc, [(Name, Maybe Doc)]) +-- | A 'DocName' is an identifier that may be documented. The 'Module'+-- component specifies the place which we want to link to in the documentation.+data DocName = Documented Name Module | Undocumented Name+ deriving Eq+++-- | The 'OccName' belonging to this name+docNameOcc :: DocName -> OccName+docNameOcc = nameOccName . getName+++instance NamedThing DocName where+ getName (Documented name _) = name+ getName (Undocumented name) = name++ {-! for DocOption derive: Binary !-} data DocOption = OptHide -- ^ This module should not appear in the docs@@ -113,7 +137,7 @@ -- data needed during its creation. data Interface = Interface { - -- | The documented module+ -- | The module represented by this interface ifaceMod :: Module, -- | The original filename for this module@@ -131,24 +155,33 @@ -- | The Haddock options for this module (prune, ignore-exports, etc) ifaceOptions :: ![DocOption], + -- | The declarations of the module. Excludes declarations that don't+ -- have names (instances and stand-alone documentation comments). Includes+ -- subordinate names, but they are mapped to their parent declarations. ifaceDeclMap :: Map Name DeclInfo,++ -- | Everything declared in the module (including subordinates) that has docs ifaceRnDocMap :: Map Name (HsDoc DocName),+ ifaceSubMap :: Map Name [Name], ifaceExportItems :: ![ExportItem Name], ifaceRnExportItems :: [ExportItem DocName], - -- | All the names that are defined in this module+ -- | All names defined in this module ifaceLocals :: ![Name], - -- | All the names that are exported by this module+ -- | All names exported by this module ifaceExports :: ![Name], -- | All the visible names exported by this module -- For a name to be visible, it has to:- -- - be exported normally, and not via a full module re-exportation.- -- - have a declaration in this module or any of it's imports, with the - -- exception that it can't be from another package.+ --+ -- * be exported normally, and not via a full module re-exportation.+ --+ -- * have a declaration in this module or any of it's imports, with the+ -- exception that it can't be from another package.+ -- -- Basically, a visible name is a name that will show up in the documentation -- for this module. ifaceVisibleExports :: ![Name],@@ -161,12 +194,34 @@ -- | A smaller version of 'Interface' that we can get from the Haddock -- interface files. data InstalledInterface = InstalledInterface {++ -- | The module represented by this interface instMod :: Module,++ -- | Textual information about the module instInfo :: HaddockModInfo Name,++ -- | Everything declared in the module (including subordinates) that has docs instDocMap :: Map Name (HsDoc DocName),++ -- | All names exported by this module instExports :: [Name],++ -- | All the visible names exported by this module+ -- For a name to be visible, it has to:+ --+ -- * be exported normally, and not via a full module re-exportation.+ --+ -- * have a declaration in this module or any of it's imports, with the+ -- exception that it can't be from another package.+ --+ -- Basically, a visible name is a name that will show up in the documentation+ -- for this module. instVisibleExports :: [Name],++ -- | The Haddock options for this module (prune, ignore-exports, etc) instOptions :: [DocOption],+ instSubMap :: Map Name [Name] } @@ -218,3 +273,22 @@ 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+#if __GLASGOW_HASKELL__ >= 609+instance Exception HaddockException+throwE str = throw (HaddockException str)+#else+throwE str = throwDyn (HaddockException str)+#endif
src/Haddock/Utils.hs view
@@ -1,11 +1,15 @@-{-# LANGUAGE PatternSignatures #-}------- Haddock - A Haskell Documentation Tool------ (c) The University of Glasgow 2001-2002--- (c) Simon Marlow 2003+-----------------------------------------------------------------------------+-- |+-- 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 (@@ -15,7 +19,6 @@ toDescription, toInstalledDescription, -- * Filename utilities- basename, dirname, splitFilename3, moduleHtmlFile, nameHtmlRef, contentsHtmlFile, indexHtmlFile, frameIndexHtmlFile,@@ -41,18 +44,19 @@ -- FormatVersion, mkFormatVersion -- * MTL stuff- MonadIO(..)+ MonadIO(..),+ + -- * Logging+ parseVerbosity,+ out ) where import Haddock.Types-import Haddock.GHC.Utils+import Haddock.GhcUtils import GHC-import SrcLoc import Name-import OccName import Binary-import Module import Control.Monad ( liftM ) import Data.Char ( isAlpha, ord, chr )@@ -68,6 +72,9 @@ import System.Exit ( exitWith, ExitCode(..) ) import System.IO ( hPutStr, stderr ) import System.IO.Unsafe ( unsafePerformIO )+import System.FilePath+import Distribution.Verbosity+import Distribution.ReadE #if __GLASGOW_HASKELL__ >= 609 import MonadUtils ( MonadIO(..) )@@ -77,7 +84,26 @@ instance MonadIO IO where liftIO = id #endif + -- -----------------------------------------------------------------------------+-- 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 @@ -122,7 +148,7 @@ -- it's the best we can do. InfixCon _ _ -> Just d where- field_avail (ConDeclField n _ _) = (unLoc n) `elem` names+ field_avail (ConDeclField n _ _) = unLoc n `elem` names field_types flds = [ t | ConDeclField _ t _ <- flds ] keep _ | otherwise = Nothing@@ -140,48 +166,6 @@ -- ----------------------------------------------------------------------------- -- Filename mangling functions stolen from s main/DriverUtil.lhs. -type Suffix = String--splitFilename :: String -> (String,Suffix)-splitFilename f = split_longest_prefix f (=='.')--basename :: String -> String-basename f = base where (_dir, base, _suff) = splitFilename3 f--dirname :: String -> String-dirname f = dir where (dir, _base, _suff) = splitFilename3 f---- "foo/bar/xyzzy.ext" -> ("foo/bar", "xyzzy", ".ext")-splitFilename3 :: String -> (String,String,Suffix)-splitFilename3 str- = let (dir, rest) = split_longest_prefix str isPathSeparator- (name, ext) = splitFilename rest- real_dir | null dir = "."- | otherwise = dir- in (real_dir, name, ext)--split_longest_prefix :: String -> (Char -> Bool) -> (String,String)-split_longest_prefix s pred0- = case pre0 of- [] -> ([], reverse suf)- (_:pre) -> (reverse pre, reverse suf)- where (suf,pre0) = break pred0 (reverse s)--pathSeparator :: Char-#ifdef __WIN32__-pathSeparator = '\\'-#else-pathSeparator = '/'-#endif--isPathSeparator :: Char -> Bool-isPathSeparator ch =-#ifdef mingw32_TARGET_OS- ch == '/' || ch == '\\'-#else- ch == '/'-#endif- moduleHtmlFile :: Module -> FilePath moduleHtmlFile mdl = case Map.lookup mdl html_xrefs of@@ -265,7 +249,7 @@ mapMaybeM :: Monad m => (a -> m b) -> Maybe a -> m (Maybe b) mapMaybeM _ Nothing = return Nothing-mapMaybeM f (Just a) = f a >>= return . Just+mapMaybeM f (Just a) = liftM Just (f a) escapeStr :: String -> String escapeStr = escapeURIString isUnreserved@@ -281,7 +265,7 @@ | otherwise = '%' : myShowHex (ord c) "" where myShowHex :: Int -> ShowS- myShowHex n r = case showIntAtBase 16 (toChrHex) n r of+ myShowHex n r = case showIntAtBase 16 toChrHex n r of [] -> "00" [a] -> ['0',a] cs -> cs@@ -290,7 +274,7 @@ | otherwise = chr (ord 'A' + fromIntegral (d - 10)) escapeURIString :: (Char -> Bool) -> String -> String-escapeURIString p s = concatMap (escapeURIChar p) s+escapeURIString = concatMap . escapeURIChar isUnreserved :: Char -> Bool isUnreserved c = isAlphaNumChar c || (c `elem` "-_.~")@@ -298,7 +282,7 @@ isAlphaChar, isDigitChar, isAlphaNumChar :: Char -> Bool isAlphaChar c = (c >= 'A' && c <= 'Z') || (c >= 'a' && c <= 'z')-isDigitChar c = (c >= '0' && c <= '9')+isDigitChar c = c >= '0' && c <= '9' isAlphaNumChar c = isAlphaChar c || isDigitChar c @@ -327,7 +311,7 @@ replace :: Eq a => a -> a -> [a] -> [a]-replace a b xs = map (\x -> if x == a then b else x) xs +replace a b = map (\x -> if x == a then b else x) -----------------------------------------------------------------------------@@ -383,7 +367,7 @@ nullFormatVersion = mkFormatVersion 0 mkFormatVersion :: Int -> FormatVersion-mkFormatVersion i = FormatVersion i+mkFormatVersion = FormatVersion instance Binary FormatVersion where put_ bh (FormatVersion i) =
src/Haddock/Utils/FastMutInt2.hs view
@@ -22,7 +22,6 @@ import PrelIOBase #else import GHC.Base-import GHC.IOBase #endif #if __GLASGOW_HASKELL__ < 411@@ -36,7 +35,7 @@ newFastMutInt = IO $ \s0 -> case newByteArray# size s0 of { (# s, arr #) -> (# s, FastMutInt arr #) }- where I# size = SIZEOF_HSINT+ where !(I# size) = SIZEOF_HSINT readFastMutInt :: FastMutInt -> IO Int readFastMutInt (FastMutInt arr) = IO $ \s0 ->
src/Haddock/Version.hs view
@@ -1,8 +1,13 @@------ Haddock - A Haskell Documentation Tool------ (c) Simon Marlow 2003+-----------------------------------------------------------------------------+-- |+-- 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
src/Main.hs view
@@ -1,13 +1,20 @@-{-# LANGUAGE ForeignFunctionInterface, PatternSignatures #-}-+{-# OPTIONS_GHC -Wwarn #-}+{-# LANGUAGE ForeignFunctionInterface, ScopedTypeVariables #-}+-----------------------------------------------------------------------------+-- |+-- Module : Main+-- Copyright : (c) Simon Marlow 2003-2006,+-- David Waern 2006-2009+-- License : BSD-like ----- Haddock - A Haskell Documentation Tool+-- Maintainer : haddock@projects.haskell.org+-- Stability : experimental+-- Portability : portable ----- (c) Simon Marlow 2003--- --- Ported to use the GHC API by David Waern during "Summer of Code" 2006+-- Haddock - A Haskell Documentation Tool ---+-- Program entry point and top-level code.+----------------------------------------------------------------------------- module Main (main) where @@ -18,10 +25,9 @@ import Haddock.Types import Haddock.Version import Haddock.InterfaceFile-import Haddock.Exception import Haddock.Options-import Haddock.GHC import Haddock.Utils+import Haddock.GhcUtils import Paths_haddock import Control.Monad@@ -31,15 +37,14 @@ #else import Control.Exception #endif-import Data.Dynamic import Data.Maybe import Data.IORef import qualified Data.Map as Map-import Data.Version import System.IO import System.Exit import System.Environment import System.FilePath+import Distribution.Verbosity #if defined(mingw32_HOST_OS) import Foreign@@ -51,13 +56,11 @@ import GHC.Paths #endif -import GHC-import DynFlags-import Bag-import ErrUtils+import GHC hiding (flags, verbosity)+import Config+import DynFlags hiding (flags, verbosity) #if __GLASGOW_HASKELL__ >= 609 import Panic (handleGhcException)-import Util import MonadUtils ( MonadIO(..) ) #else import Util hiding (handle)@@ -69,13 +72,15 @@ -------------------------------------------------------------------------------- -handleTopExceptions = +handleTopExceptions :: IO a -> IO a+handleTopExceptions = handleNormalExceptions . handleHaddockExceptions . handleGhcExceptions +handleNormalExceptions :: IO a -> IO a handleNormalExceptions inner = handle (\exception -> do- hFlush stdout + hFlush stdout case exception of AsyncException StackOverflow -> do putStrLn "stack overflow: use -g +RTS -K<size> to increase it"@@ -87,7 +92,8 @@ ) inner -handleHaddockExceptions inner = +handleHaddockExceptions :: IO a -> IO a+handleHaddockExceptions inner = #if __GLASGOW_HASKELL__ >= 609 NewException.catches inner [NewException.Handler handler] #else@@ -99,7 +105,8 @@ exitFailure -handleGhcExceptions inner = +handleGhcExceptions :: IO a -> IO a+handleGhcExceptions inner = -- compilation errors: messages with locations attached #if __GLASGOW_HASKELL__ < 609 handleDyn (\e -> do@@ -119,7 +126,7 @@ case e of PhaseFailed _ code -> exitWith code Interrupted -> exitFailure- _ -> do + _ -> do print (e :: GhcException) exitFailure ) inner@@ -136,9 +143,10 @@ -- parse command-line flags and handle some of them initially args <- getArgs (flags, fileArgs) <- parseHaddockOpts args- handleEasyFlags flags fileArgs+ handleEasyFlags flags+ verbosity <- getVerbosity flags - let renderStep packages interfaces = do + let renderStep packages interfaces = do updateHTMLXRefs packages let ifaceFiles = map fst packages installedIfaces = concatMap ifInstalledIfaces ifaceFiles@@ -154,33 +162,37 @@ do m <- getExecDir case m of Nothing -> error "No GhcLibDir found"+#ifdef NEW_GHC_LAYOUT+ Just d -> return (d </> ".." </> "lib")+#else Just d -> return (d </> "..")+#endif #else return libdir -- from GHC.Paths #endif #if __GLASGOW_HASKELL__ >= 609 -- We have one global error handler for all GHC source errors. Other kinds- -- of exceptions will be propagated to the top-level error handler. + -- of exceptions will be propagated to the top-level error handler. let handleSrcErrors action = flip handleSourceError action $ \err -> do printExceptionAndWarnings err liftIO exitFailure -- initialize GHC- startGhc libDir (ghcFlags flags) $ \dynflags -> handleSrcErrors $ do+ startGhc libDir (ghcFlags flags) $ \_ -> handleSrcErrors $ do -- get packages supplied with --read-interface packages <- readInterfaceFiles nameCacheFromGhc (ifacePairs flags) -- create the interfaces -- this is the core part of Haddock- (interfaces, homeLinks) <- createInterfaces fileArgs flags+ (interfaces, homeLinks) <- createInterfaces verbosity fileArgs flags (map fst packages) liftIO $ do -- render the interfaces renderStep packages interfaces- + -- last but not least, dump the interface file dumpInterfaceFile (map toInstalledIface interfaces) homeLinks flags #else@@ -191,12 +203,12 @@ packages <- readInterfaceFiles (nameCacheFromGhc session) (ifacePairs flags) -- create the interfaces -- this is the core part of Haddock- (interfaces, homeLinks) <- createInterfaces session fileArgs flags+ (interfaces, homeLinks) <- createInterfaces verbosity session fileArgs flags (map fst packages) -- render the interfaces renderStep packages interfaces- + -- last but not least, dump the interface file dumpInterfaceFile (map toInstalledIface interfaces) homeLinks flags #endif@@ -213,13 +225,13 @@ ------------------------------------------------------------------------------- --- | Render the interfaces with whatever backend is specified in the flags +-- | Render the interfaces with whatever backend is specified in the flags render :: [Flag] -> [Interface] -> [InstalledInterface] -> IO () render flags ifaces installedIfaces = do let title = case [str | Flag_Heading str <- flags] of- [] -> ""- (t:_) -> t+ [] -> ""+ (t:_) -> t maybe_source_urls = (listToMaybe [str | Flag_SourceBaseURL str <- flags] ,listToMaybe [str | Flag_SourceModuleURL str <- flags]@@ -229,35 +241,37 @@ ,listToMaybe [str | Flag_WikiModuleURL str <- flags] ,listToMaybe [str | Flag_WikiEntityURL str <- flags]) - verbose = Flag_Verbose `elem` flags-- libdir <- case [str | Flag_Lib str <- flags] of- [] ->+ libDir <- case [str | Flag_Lib str <- flags] of+ [] -> #ifdef IN_GHC_TREE do m <- getExecDir case m of Nothing -> error "No libdir found"+#ifdef NEW_GHC_LAYOUT+ Just d -> return (d </> ".." </> "lib")+#else Just d -> return (d </> "..")+#endif #else getDataDir -- provided by Cabal #endif- fs -> return (last fs)-+ fs -> return (last fs)+ let unicode = Flag_UseUnicode `elem` flags let css_file = case [str | Flag_CSS str <- flags] of- [] -> Nothing- fs -> Just (last fs)+ [] -> Nothing+ fs -> Just (last fs) odir <- case [str | Flag_OutputDir str <- flags] of- [] -> return "."- fs -> return (last fs)+ [] -> return "."+ fs -> return (last fs) - let - maybe_contents_url = + let+ maybe_contents_url = case [url | Flag_UseContents url <- flags] of [] -> Nothing us -> Just (last us) - maybe_index_url = + maybe_index_url = case [url | Flag_UseIndex url <- flags] of [] -> Nothing us -> Just (last us)@@ -269,7 +283,7 @@ prologue <- getPrologue flags - let + let visibleIfaces = [ i | i <- ifaces, OptHide `notElem` ifaceOptions i ] -- *all* visible interfaces including external package modules@@ -280,28 +294,28 @@ packageStr = Just (modulePackageString packageMod) (pkgName,pkgVer) = modulePackageInfo packageMod - + when (Flag_GenIndex `elem` flags) $ do ppHtmlIndex odir title packageStr maybe_html_help_format maybe_contents_url maybe_source_urls maybe_wiki_urls allVisibleIfaces- copyHtmlBits odir libdir css_file- + copyHtmlBits odir libDir css_file+ when (Flag_GenContents `elem` flags && Flag_GenIndex `elem` flags) $ do ppHtmlHelpFiles title packageStr visibleIfaces odir maybe_html_help_format [] when (Flag_GenContents `elem` flags) $ do ppHtmlContents odir title packageStr maybe_html_help_format- maybe_index_url maybe_source_urls maybe_wiki_urls- allVisibleIfaces True prologue- copyHtmlBits odir libdir css_file+ maybe_index_url maybe_source_urls maybe_wiki_urls+ allVisibleIfaces True prologue+ copyHtmlBits odir libDir css_file when (Flag_Html `elem` flags) $ do ppHtml title packageStr visibleIfaces odir prologue maybe_html_help_format maybe_source_urls maybe_wiki_urls- maybe_contents_url maybe_index_url- copyHtmlBits odir libdir css_file+ maybe_contents_url maybe_index_url unicode+ copyHtmlBits odir libDir css_file when (Flag_Hoogle `elem` flags) $ do let pkgName2 = if pkgName == "main" && title /= [] then title else pkgName@@ -330,15 +344,15 @@ putStrLn (" " ++ show err) putStrLn "Skipping this interface." return Nothing- Right iface -> return $ Just (iface, html)+ Right f -> return $ Just (f, html) dumpInterfaceFile :: [InstalledInterface] -> LinkEnv -> [Flag] -> IO ()-dumpInterfaceFile ifaces homeLinks flags = +dumpInterfaceFile ifaces homeLinks flags = case [str | Flag_DumpInterface str <- flags] of [] -> return () fs -> let filename = last fs in writeInterfaceFile filename ifaceFile- where + where ifaceFile = InterfaceFile { ifInstalledIfaces = ifaces, ifLinkEnv = homeLinks@@ -346,23 +360,88 @@ -------------------------------------------------------------------------------+-- Creating a GHC session+-------------------------------------------------------------------------------++-- | Start a GHC session with the -haddock flag set. Also turn off+-- compilation and linking.+#if __GLASGOW_HASKELL__ >= 609+startGhc :: String -> [String] -> (DynFlags -> Ghc a) -> IO a+startGhc libDir flags ghcActs = do+ -- TODO: handle warnings?+ (restFlags, _) <- parseStaticFlags (map noLoc flags)+ runGhc (Just libDir) $ do+ dynflags <- getSessionDynFlags+#else+startGhc :: String -> [String] -> IO (Session, DynFlags)+startGhc libDir flags = do+ restFlags <- parseStaticFlags flags+ session <- newSession (Just libDir)+ dynflags <- getSessionDynFlags session+ do+#endif+ let dynflags' = dopt_set dynflags Opt_Haddock+ let dynflags'' = dynflags' {+ hscTarget = HscNothing,+ ghcMode = CompManager,+ ghcLink = NoLink+ }+ dynflags''' <- parseGhcFlags dynflags'' restFlags flags+ defaultCleanupHandler dynflags''' $ do+#if __GLASGOW_HASKELL__ >= 609+ setSessionDynFlags dynflags'''+ ghcActs dynflags'''+#else+ setSessionDynFlags session dynflags'''+ return (session, dynflags''')+#endif+ where+ parseGhcFlags :: Monad m => DynFlags -> [Located String]+ -> [String] -> m DynFlags+ parseGhcFlags dynflags flags_ origFlags = do+ -- TODO: handle warnings?+#if __GLASGOW_HASKELL__ >= 609+ (dynflags', rest, _) <- parseDynamicFlags dynflags flags_+#else+ (dynflags', rest) <- parseDynamicFlags dynflags flags_+#endif+ if not (null rest)+ then throwE ("Couldn't parse GHC options: " ++ (unwords origFlags))+ else return dynflags'+++------------------------------------------------------------------------------- -- Misc ------------------------------------------------------------------------------- +getGhcLibDir :: [Flag] -> Maybe String getGhcLibDir flags = case [ dir | Flag_GhcLibDir dir <- flags ] of [] -> Nothing xs -> Just $ last xs -handleEasyFlags flags fileArgs = do+getVerbosity :: Monad m => [Flag] -> m Verbosity+getVerbosity flags =+ case [ str | Flag_Verbosity str <- flags ] of+ [] -> return normal+ x:_ -> case parseVerbosity x of+ Left e -> throwE e+ Right v -> return v+++handleEasyFlags :: [Flag] -> IO ()+handleEasyFlags flags = do usage <- getUsage when (Flag_Help `elem` flags) (bye usage) when (Flag_Version `elem` flags) byeVersion when (Flag_GhcVersion `elem` flags) byeGhcVersion + when (Flag_UseUnicode `elem` flags && not (Flag_Html `elem` flags)) $+ throwE ("Unicode can only be enabled for HTML output.")+ when ((Flag_GenIndex `elem` flags || Flag_GenContents `elem` flags) && Flag_Html `elem` flags) $ throwE ("-h cannot be used with --gen-index or --gen-contents")@@ -371,29 +450,29 @@ "Haddock version " ++ projectVersion ++ ", (c) Simon Marlow 2006\n" ++ "Ported to use the GHC API by David Waern 2006-2008\n" - byeGhcVersion = bye $ - (fromJust $ lookup "Project version" $ compilerInfo) ++ "\n"+ byeGhcVersion = bye (cProjectVersion ++ "\n") updateHTMLXRefs :: [(InterfaceFile, FilePath)] -> IO () updateHTMLXRefs packages = do writeIORef html_xrefs_ref (Map.fromList mapping) where- mapping = [ (instMod iface, html) | (ifaces, html) <- packages,- iface <- ifInstalledIfaces ifaces ]+ mapping = [ (instMod iface, html) | (ifaces, html) <- packages+ , iface <- ifInstalledIfaces ifaces ] getPrologue :: [Flag] -> IO (Maybe (HsDoc RdrName))-getPrologue flags- = case [filename | Flag_Prologue filename <- flags ] of- [] -> return Nothing - [filename] -> do- str <- readFile filename- case parseHaddockComment str of- Left err -> throwE err- Right doc -> return (Just doc)- _otherwise -> throwE "multiple -p/--prologue options"+getPrologue flags =+ case [filename | Flag_Prologue filename <- flags ] of+ [] -> return Nothing+ [filename] -> do+ str <- readFile filename+ case parseHaddockComment str of+ Left err -> throwE err+ Right doc -> return (Just doc)+ _otherwise -> throwE "multiple -p/--prologue options" + getExecDir :: IO (Maybe String) #if defined(mingw32_HOST_OS) getExecDir = allocaArray len $ \buf -> do@@ -404,10 +483,9 @@ return (Just (dropFileName s)) where len = 2048 -- Plenty, PATH_MAX is 512 under Win32. -foreign import stdcall unsafe "GetModuleFileNameA"+foreign import stdcall unsafe "GetModuleFileNameA" getModuleFileName :: Ptr () -> CString -> Int -> IO Int32 #else getExecDir = return Nothing #endif-