1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
|
-- | HTML output for documentation package index.
module Ppr049 (
htmlPage
) where
import Control.Monad
import Data.Char (isAlpha, toUpper)
import Data.List
import Data.Ord
import Data.Time
import Data.Version
import qualified Data.Map as M
import System.FilePath
import System.Locale
import Text.Html
import Distribution.DocIdx.Common
import Distribution.DocIdx.Config
import Distribution.GhcPkgList
-- | Project homepage, for footer.
homePage :: String
homePage = "http://hackage.haskell.org/package/docidx"
-- | Create and render entire page.
htmlPage :: DocIdxCfg -> PackageMap HaddockInfo -> UTCTime -> String
htmlPage config pkgs now = renderHtml [htmlHeader, htmlBody]
where htmlHeader = header << ((thetitle << pageTitle config) : fav : css)
fav = thelink ! [rel "shortcut icon", href $ favIcon config] << noHtml
css = map oneCss (pageCss config)
oneCss cp = thelink ! [rel "stylesheet",
thetype "text/css", href cp] << noHtml
htmlBody = body << (title' ++ toc ++ secs ++ nowFoot)
where title' = [h2 << "Local packages with docs"]
toc = [htmlToc config am]
secs = concatMap (uncurry htmlPkgsAlpha) $ M.assocs am
am = alphabetize pkgs
now' = formatTime defaultTimeLocale rfc822DateFormat now
nowFoot = [p ! [theclass "toc"] $
stringToHtml ("Page rendered " ++ now' ++ " by ")
+++ (anchor ! [href homePage] <<
stringToHtml appName)]
-- | An AlphaMap groups packages together by their name's first character.
type AlphaMap = M.Map Char (PackageMap HaddockInfo)
-- | Group packages together by their name's first character.
alphabetize :: PackageMap HaddockInfo -> AlphaMap
alphabetize = foldr addAlpha M.empty
where addAlpha (n, vs) = M.insertWith (++) c [(n, vs)]
where c = if isAlpha c' then c' else '\0'
c' = toUpper $ head n
-- | Generate the table of contents.
htmlToc :: DocIdxCfg -> AlphaMap -> Html
htmlToc config am =
p ! [theclass "toc"] << tocHtml (alphaItems ++ tocExtras config)
where tocHtml = intersperse bull . concatMap tocItemHtml
alphaItems = map (\k -> TocItem [k] ('#':[k])) $ sort $ M.keys am
-- | Render toc elements to HTML.
tocItemHtml :: TocItem -> [Html]
tocItemHtml (TocItem nm path) = [anchor ! [href path] << nm]
tocItemHtml TocSeparator = [mdash]
tocItemHtml TocNewline = [br] -- Hmmm... you still get the bullets?
-- | Render a collection of packages with the same first character.
htmlPkgsAlpha :: Char -> PackageMap HaddockInfo -> [Html]
htmlPkgsAlpha c pm = [heading, packages]
where heading = h3 ! [theclass "category"] << anchor ! [name [c]] << [c]
packages = ulist ! [theclass "packages"] <<
map (uncurry htmlPkg) pm'
pm' = sortBy (comparing (map toUpper . fst)) pm
-- | Render a particularly-named package (all versions of it).
htmlPkg :: String -> VersionMap HaddockInfo -> Html
htmlPkg nm vs = li << pvsHtml (flattenPkgVersions nm vs)
-- | Everything we want to know about a particular version of a
-- package, nicely flattened and ready to use. (Actually, we'd also
-- like to use the synopsis, but this isn't exposed through the Cabal
-- library, sadly. We could conceivably grab it from the haddock docs
-- (and hackage for packages with no local docs) but this
-- seems excessive so for now we forget about it.
data PkgVersion = PkgVersion {
pvName ::String
, pvSynopsis :: Maybe String
, pvVersion :: Version
, pvExposed :: Bool
, pvHaddocks :: Maybe FilePath
} deriving (Eq, Ord, Show)
-- | Flatten a given package's various versions into a list of
-- PkgVersion values, which is much nicer to iterate over when
-- building the HTML for this package.
flattenPkgVersions :: String -> VersionMap HaddockInfo -> [PkgVersion]
flattenPkgVersions nm vs = concatMap (uncurry flatten') $ reverse vs
where flatten' :: Version -> [VersionInfo HaddockInfo] -> [PkgVersion]
-- We reverse here to put user versions of pkgs before
-- identically versioned global versions.
flatten' v = concatMap (uncurry flatten3) . reverse
where flatten3 :: Bool -> [HaddockInfo] -> [PkgVersion]
flatten3 ex [] = [PkgVersion nm Nothing v ex Nothing]
flatten3 ex ps = map (mkPv nm v ex) ps
-- | Construct a PkgVersion from information about a single version of
-- a package.
mkPv :: String -> Version -> Bool -> HaddockInfo -> PkgVersion
mkPv nm v ex Nothing = PkgVersion nm Nothing v ex Nothing
mkPv nm v ex (Just (hp, syn)) = PkgVersion nm (Just syn) v ex (Just hp)
-- | Render the HTML for a list of versions of (we presume) the same
-- package.
pvsHtml :: [PkgVersion] -> Html
pvsHtml pvs = pvHeader (head pvs) +++ spaceHtml +++ pvVersions pvs +++
pvSyn pvs
-- | Render the "header" part of some package's HTML: name (with link
-- to default version of local docs if available) and hackage link.
pvHeader :: PkgVersion -> [Html]
pvHeader pv = [maybeURL nme (pvHaddocks pv)
,spaceHtml
,anchor ! [href $ hackagePath pv] << extLinkArrow
]
where nme = if not (pvExposed pv) then "(" ++ nm ++ ")" else nm
nm = pvName pv
-- | Render HTML linking to the various versions of a package
-- installed, listed by version number only (name is implicit).
pvVersions :: [PkgVersion] -> Html
pvVersions [_] = noHtml -- Don't bother if there's only one version.
pvVersions pvs = stringToHtml "[" +++
intersperse comma (map pvOneVer pvs) +++
stringToHtml "]"
where pvOneVer pv = maybeURL (showVersion $ pvVersion pv) (pvHaddocks pv)
-- | Render the synopsis of a package, if present in any of its versions.
pvSyn :: [PkgVersion] -> Html
pvSyn = maybe noHtml (\x -> mdash +++ stringToHtml x) . msum . map pvSynopsis
-- | Render a URL if there's a path; otherwise, just render some text.
-- (Useful in cases where a package is installed but no documentation
-- was found: you'll still get the hackage link.)
maybeURL :: String -> Maybe String -> Html
maybeURL nm Nothing = stringToHtml nm
maybeURL nm (Just path) = anchor ! [href $ joinPath [path, "index.html"]] << nm
-- | Compute the URL to a package's page on hackage.
hackagePath :: PkgVersion -> String
hackagePath pv = "http://hackage.haskell.org/package/" ++ pvTag
where pvTag = pvName pv ++ "-" ++ showVersion (pvVersion pv)
-- Some primitives.
bull, comma, extLinkArrow, mdash :: Html
bull = primHtml " • "
comma = stringToHtml ", "
extLinkArrow = primHtml "⬈"
mdash = primHtml " — "
|
