@@ -1,219 +0,0 @@
1−{-# LANGUAGE RecordWildCards #-}
2−{-# LANGUAGE OverloadedStrings #-}
3−{-# LANGUAGE TemplateHaskell #-}
4−{-# LANGUAGE ViewPatterns #-}
5−
6−-- | Functions for rendering generated documentation from PureScript code as
7−-- HTML.
8−
9−module Language.PureScript.Docs.AsHtml (
10− HtmlOutput(..),
11− packageAsHtml
12−) where
13−
14−import Control.Arrow (second)
15−import Control.Category ((>>>))
16−import Data.Char (toUpper)
17−import Data.Ord (comparing)
18−import Data.Monoid (mconcat)
19−import Data.Foldable (for_)
20−import Data.List (intercalate, find, sortBy)
21−import qualified Data.DList as DList
22−import Data.List.Split (splitOn)
23−import Data.Default (def)
24−import Data.Version
25−import qualified Data.Map as M
26−
27−import qualified Data.Text as T
28−
29−import Lucid hiding (for_)
30−import qualified Text.Blaze.Html as H
31−import qualified Text.Blaze.Html.Renderer.Text as H
32−import qualified Cheapskate
33−
34−import System.FilePath ((</>))
35−
36−import Web.Bower.PackageMeta hiding (Version)
37−
38−import qualified Language.PureScript as P
39−
40−import Language.PureScript.Docs.Types
41−import Language.PureScript.Docs.RenderedCode hiding (sp)
42−import Language.PureScript.Docs.Utils.HtmlHelpers
43−
44−data LinksContext = LinksContext
45− { ctxGithub :: (GithubUser, GithubRepo)
46− , ctxBookmarks :: [Bookmark]
47− , ctxResolvedDependencies :: [(PackageName, Version)]
48− }
49− deriving (Show, Eq, Ord)
50−
51−-- | A LinksContext with the current module name.
52−type LinksContext' = (LinksContext, P.ModuleName)
53−
54−data DocLink
55− -- | A link to a declaration in the same module; in this case, only the title
56− -- is needed to generate the link.
57− = SameModule String
58−
59− -- | A link to a declaration in a different module, but still in the current
60− -- package; we need to store the current module, the other declaration's
61− -- module, and the declaration title.
62− | LocalModule P.ModuleName P.ModuleName String
63−
64− -- | A link to a declaration in a different package. We store: current module
65− -- name, name of the other package, version of the other package, name of
66− -- the module in the other package that the declaration is in, and
67− -- declaration title.
68− | DepsModule P.ModuleName PackageName Version P.ModuleName String
69− deriving (Show, Eq, Ord)
70−
71−data HtmlOutput = HtmlOutput
72− { htmlIndex :: [(Maybe Char, Html ())]
73− , htmlModules :: [(P.ModuleName, Html ())]
74− }
75− deriving (Show)
76−
77−packageAsHtml :: UploadedPackage -> HtmlOutput
78−packageAsHtml UploadedPackage{..} = HtmlOutput indexFile modules
79− where
80− indexFile = renderIndex ctx
81− modules = map (moduleAsHtml ctx) pkgModules
82− ctx = LinksContext pkgGithub pkgBookmarks pkgResolvedDependencies
83−
84−moduleAsHtml :: LinksContext -> RenderedModule -> (P.ModuleName, Html ())
85−moduleAsHtml ctx RenderedModule{..} = (mn, html)
86− where
87− mn = P.moduleNameFromString rmName
88− ctx' = (ctx, mn)
89− html = do
90− h1_ $ do
91− text "module "
92− strong_ (text rmName)
93− for_ rmComments renderComments
94− for_ rmDeclarations (declAsHtml ctx')
95−
96−renderIndex :: LinksContext -> [(Maybe Char, Html ())]
97−renderIndex LinksContext{..} = go ctxBookmarks
98− where
99− go = takeLocals
100− >>> groupIndex getIndex renderEntry
101− >>> map (second (ul_ . mconcat))
102−
103− getIndex (_, ((toUpper -> c) :_))
104− | c `elem` ['A'..'Z'] = Just c
105− | otherwise = Nothing
106− getIndex _ = Nothing
107−
108− renderEntry (mn, title) =
109− li_ $ do
110− let url = T.pack ((filePathFor mn `relativeTo` "index") ++ "#" ++ title)
111− code_ (a_ [href_ url] (text title))
112− sp
113− text ("(" ++ show mn ++ ")")
114−
115− groupIndex :: Ord i => (a -> Maybe i) -> (a -> b) -> [a] -> [(Maybe i, [b])]
116− groupIndex f g =
117− map (second DList.toList) . M.toList . foldr go' M.empty . sortBy (comparing f)
118− where
119− go' x = insertOrAppend (f x) (g x)
120− insertOrAppend idx val m =
121− let cur = M.findWithDefault DList.empty idx m
122− new = DList.snoc cur val
123− in M.insert idx new m
124−
125−declAsHtml :: LinksContext' -> RenderedDeclaration -> Html ()
126−declAsHtml ctx RenderedDeclaration{..} = do
127− a_ [name_ (T.pack rdTitle), href_ (T.pack ('#' : rdTitle))] $
128− h2_ (code_ (text rdTitle))
129− para "decl" (code_ (codeAsHtml ctx rdCode))
130− renderChildren ctx rdChildren
131− case rdComments of
132− Just cs -> renderComments cs
133− Nothing -> return ()
134− for_ rdSourceSpan (linkToSource ctx)
135−
136−renderChildren :: LinksContext' -> [RenderedChildDeclaration] -> Html ()
137−renderChildren _ [] = return ()
138−renderChildren ctx xs = go xs
139− where
140− go = ul_ . mapM_ (li_ . code_ . codeAsHtml ctx . rcdCode)
141−
142−codeAsHtml :: LinksContext' -> RenderedCode -> Html ()
143−codeAsHtml ctx = outputWith elemAsHtml
144− where
145− elemAsHtml (Syntax x) = withClass "syntax" (text x)
146− elemAsHtml (Ident x) = withClass "ident" (text x)
147− elemAsHtml (Ctor x mn) = linkToConstructor ctx x mn (withClass "ctor" (text x))
148− elemAsHtml (Kind x) = text x
149− elemAsHtml (Keyword x) = withClass "keyword" (text x)
150− elemAsHtml Space = text " "
151−
152−getLink :: LinksContext' -> String -> ContainingModule -> Maybe DocLink
153−getLink (LinksContext{..}, curMn) ctor' containingMod = do
154− let bookmark' = (fromContainingModule curMn containingMod, ctor')
155− bookmark <- find ((bookmark' ==) . ignorePackage) ctxBookmarks
156−
157− case containingMod of
158− ThisModule -> return (SameModule ctor')
159− OtherModule destMn ->
160− case bookmark of
161− Local _ -> return (LocalModule curMn destMn ctor')
162− FromDep pkgName _ -> do
163− pkgVersion <- lookup pkgName ctxResolvedDependencies
164− return (DepsModule curMn pkgName pkgVersion destMn ctor')
165−
166−renderLink :: DocLink -> Html () -> Html ()
167−renderLink (SameModule x) = linkTo ('#' : x)
168−renderLink (LocalModule srcMn destMn x) =
169− let uri = filePathFor destMn `relativeTo` filePathFor srcMn
170− in linkTo (uri ++ "#" ++ x)
171−renderLink (DepsModule srcMn pkgName pkgVersion destMn x) =
172− let relativeTo' = relativeToOtherPackage pkgName pkgVersion
173− uri = filePathFor destMn `relativeTo'` filePathFor srcMn
174− in linkTo (uri ++ "#" ++ x)
175−
176−linkToConstructor :: LinksContext' -> String -> ContainingModule -> Html () -> Html ()
177−linkToConstructor ctx ctor' containMn =
178− maybe id renderLink (getLink ctx ctor' containMn)
179−
180−linkToSource :: LinksContext' -> P.SourceSpan -> Html ()
181−linkToSource (LinksContext{..}, _) (P.SourceSpan name start end) =
182− linkTo (concat
183− [githubBaseUrl, "/tree/master/", relativeToBase name, "#", fragment])
184− (text "Source")
185− where
186− (P.SourcePos startLine _) = start
187− (P.SourcePos endLine _) = end
188− (GithubUser user, GithubRepo repo) = ctxGithub
189−
190− relativeToBase = intercalate "/" . dropWhile (/= "src") . splitOn "/"
191− githubBaseUrl = concat ["https://github.com/", user, "/", repo]
192− fragment = "L" ++ show startLine ++ "-L" ++ show endLine
193−
194−-- TODO: use GitHub API instead?
195−renderComments :: String -> Html ()
196−renderComments = toHtml . H.renderHtml . H.toHtml . Cheapskate.markdown def . T.pack
197−
198−-- | if `to` and `from` are both files in the current package, generate a
199−-- FilePath for `to` relative to `from`.
200−relativeTo :: FilePath -> FilePath -> FilePath
201−relativeTo to from = go (splitOn "/" to) (splitOn "/" from)
202− where
203− go (x : xs) (y : ys) | x == y = go xs ys
204− go xs ys = intercalate "/" $ replicate (length ys - 1) ".." ++ xs
205−
206−-- | Generate a FilePath for module documentation for a module in the current
207−-- package.
208−filePathFor :: P.ModuleName -> FilePath
209−filePathFor (P.ModuleName parts) = go parts
210− where
211− go [] = "index.html"
212− go (x : xs) = show x </> go xs
213−
214−-- | Like `relativeTo`, but in the case where `to` is in another package.
215−relativeToOtherPackage :: PackageName -> Version -> FilePath -> FilePath -> FilePath
216−relativeToOtherPackage name (showVersion -> vers) to from =
217− intercalate "/" (dots ++ [runPackageName name, vers] ++ splitOn "/" to)
218− where
219− dots = replicate (length from - 1) ".."