Skip to content

Commit b03f4cf

Browse files
hdgarroodhdgarrood
committed
Add modules for rendering HTML documentation
Refs purescript#2520. This code is more or less copied from Pursuit, although I managed to drop the `hxt` dependency by instead using Cheapskate's provided functions for walking a rendered Markdown document. This is just a starting point towards generating HTML documentation from a given package set. Next, I plan to make psc-docs capable of producing HTML documentation as well as Markdown.
1 parent 5539c93 commit b03f4cf

File tree

3 files changed

+386
-1
lines changed

3 files changed

+386
-1
lines changed

‎purescript.cabal‎

Lines changed: 3 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -117,9 +117,11 @@ library
117117
aeson-better-errors >= 0.8,
118118
ansi-terminal >= 0.6.2 && < 0.7,
119119
base-compat >=0.6.0,
120+
blaze-html >= 0.8.1 && < 0.9,
120121
bower-json >= 1.0.0.1 && < 1.1,
121122
boxes >= 0.1.4 && < 0.2.0,
122123
bytestring -any,
124+
cheapskate >= 0.1 && < 0.2,
123125
containers -any,
124126
clock -any,
125127
data-ordlist >= 0.4.7.0,
@@ -270,6 +272,7 @@ library
270272
Language.PureScript.Docs.RenderedCode.RenderType
271273
Language.PureScript.Docs.RenderedCode.RenderKind
272274
Language.PureScript.Docs.AsMarkdown
275+
Language.PureScript.Docs.AsHtml
273276
Language.PureScript.Docs.ParseInPackage
274277
Language.PureScript.Docs.Utils.MonoidExtras
275278

‎src/Language/PureScript/Docs/AsHtml.hs‎

Lines changed: 299 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,299 @@
1+
2+
-- | Functions for rendering generated documentation from PureScript code as
3+
-- HTML.
4+
5+
module Language.PureScript.Docs.AsHtml (
6+
HtmlOutput(..),
7+
HtmlOutputModule(..),
8+
HtmlRenderContext(..),
9+
nullRenderContext,
10+
declNamespace,
11+
packageAsHtml,
12+
moduleAsHtml,
13+
makeFragment,
14+
renderMarkdown
15+
) where
16+
17+
import Prelude
18+
import Control.Arrow (second)
19+
import Control.Category ((>>>))
20+
import Control.Monad (unless)
21+
import Data.Char (isUpper)
22+
import Data.Monoid ((<>))
23+
import Data.Foldable (for_)
24+
import Data.String (fromString)
25+
26+
import Data.Text (Text)
27+
import qualified Data.Text as T
28+
29+
import Text.Blaze.Html5 as H hiding (map)
30+
import qualified Text.Blaze.Html5.Attributes as A
31+
import qualified Cheapskate
32+
33+
import qualified Language.PureScript as P
34+
35+
import Language.PureScript.Docs.Types
36+
import Language.PureScript.Docs.RenderedCode hiding (sp)
37+
import qualified Language.PureScript.Docs.Render as Render
38+
39+
declNamespace :: Declaration -> Namespace
40+
declNamespace = declInfoNamespace . declInfo
41+
42+
data HtmlOutput a = HtmlOutput
43+
{ htmlIndex :: [(Maybe Char, a)]
44+
, htmlModules :: [(P.ModuleName, HtmlOutputModule a)]
45+
}
46+
deriving (Show, Functor)
47+
48+
data HtmlOutputModule a = HtmlOutputModule
49+
{ htmlOutputModuleLocals :: a
50+
, htmlOutputModuleReExports :: [(InPackage P.ModuleName, a)]
51+
}
52+
deriving (Show, Functor)
53+
54+
data HtmlRenderContext = HtmlRenderContext
55+
{ currentModuleName :: P.ModuleName
56+
, buildDocLink :: Namespace -> Text -> ContainingModule -> Maybe DocLink
57+
, renderDocLink :: DocLink -> Text
58+
, renderSourceLink :: P.SourceSpan -> Text
59+
}
60+
61+
-- |
62+
-- An HtmlRenderContext for when you don't want to render any links.
63+
nullRenderContext :: P.ModuleName -> HtmlRenderContext
64+
nullRenderContext mn = HtmlRenderContext
65+
{ currentModuleName = mn
66+
, buildDocLink = const (const (const Nothing))
67+
, renderDocLink = const ""
68+
, renderSourceLink = const ""
69+
}
70+
71+
packageAsHtml :: (P.ModuleName -> HtmlRenderContext) -> Package a -> HtmlOutput Html
72+
packageAsHtml getHtmlCtx Package{..} =
73+
HtmlOutput indexFile modules
74+
where
75+
indexFile = []
76+
modules = map (\m -> moduleAsHtml (getHtmlCtx (modName m)) m) pkgModules
77+
78+
moduleAsHtml :: HtmlRenderContext -> Module -> (P.ModuleName, HtmlOutputModule Html)
79+
moduleAsHtml r Module{..} = (modName, HtmlOutputModule modHtml reexports)
80+
where
81+
renderDecl = declAsHtml r
82+
modHtml = do
83+
for_ modComments renderMarkdown
84+
for_ modDeclarations renderDecl
85+
reexports =
86+
map (second (foldMap renderDecl)) modReExports
87+
88+
-- renderIndex :: LinksContext -> [(Maybe Char, Html)]
89+
-- renderIndex LinksContext{..} = go ctxBookmarks
90+
-- where
91+
-- go = takeLocals
92+
-- >>> groupIndex getIndex renderEntry
93+
-- >>> map (second (ul . mconcat))
94+
--
95+
-- getIndex (_, title_) = do
96+
-- c <- textHeadMay title_
97+
-- guard (toUpper c `elem` ['A'..'Z'])
98+
-- pure c
99+
--
100+
-- textHeadMay t =
101+
-- case T.length t of
102+
-- 0 -> Nothing
103+
-- _ -> Just (T.index t 0)
104+
--
105+
-- renderEntry (mn, title_) =
106+
-- li $ do
107+
-- let url = T.pack (filePathFor mn `relativeTo` "index") <> "#" <> title_
108+
-- code $
109+
-- a ! A.href (v url) $ text title_
110+
-- sp
111+
-- text ("(" <> P.runModuleName mn <> ")")
112+
--
113+
-- groupIndex :: Ord i => (a -> Maybe i) -> (a -> b) -> [a] -> [(Maybe i, [b])]
114+
-- groupIndex f g =
115+
-- map (second DList.toList) . M.toList . foldr go' M.empty . sortBy (comparing f)
116+
-- where
117+
-- go' x = insertOrAppend (f x) (g x)
118+
-- insertOrAppend idx val m =
119+
-- let cur = M.findWithDefault DList.empty idx m
120+
-- new = DList.snoc cur val
121+
-- in M.insert idx new m
122+
123+
declAsHtml :: HtmlRenderContext -> Declaration -> Html
124+
declAsHtml r d@Declaration{..} = do
125+
let declFragment = makeFragment (declInfoNamespace declInfo) declTitle
126+
H.div ! A.class_ "decl" ! A.id (v (T.drop 1 declFragment)) $ do
127+
h3 ! A.class_ "decl__title clearfix" $ do
128+
a ! A.class_ "decl__anchor" ! A.href (v declFragment) $ "#"
129+
text declTitle
130+
for_ declSourceSpan (linkToSource r)
131+
132+
H.div ! A.class_ "decl__body" $ do
133+
case declInfo of
134+
AliasDeclaration fixity alias_ ->
135+
renderAlias fixity alias_
136+
_ ->
137+
pre ! A.class_ "decl__signature" $ code $
138+
codeAsHtml r (Render.renderDeclaration d)
139+
140+
for_ declComments renderMarkdown
141+
142+
let (instances, dctors, members) = partitionChildren declChildren
143+
144+
unless (null dctors) $ do
145+
h4 "Constructors"
146+
renderChildren r dctors
147+
148+
unless (null members) $ do
149+
h4 "Members"
150+
renderChildren r members
151+
152+
unless (null instances) $ do
153+
h4 "Instances"
154+
renderChildren r instances
155+
where
156+
linkToSource :: HtmlRenderContext -> P.SourceSpan -> Html
157+
linkToSource ctx srcspan =
158+
H.span ! A.class_ "decl__source" $
159+
a ! A.href (v (renderSourceLink ctx srcspan)) $ text "Source"
160+
161+
renderChildren :: HtmlRenderContext -> [ChildDeclaration] -> Html
162+
renderChildren _ [] = return ()
163+
renderChildren r xs = ul $ mapM_ go xs
164+
where
165+
go decl = item decl . code . codeAsHtml r . Render.renderChildDeclaration $ decl
166+
item decl = let fragment = makeFragment (childDeclInfoNamespace (cdeclInfo decl)) (cdeclTitle decl)
167+
in li ! A.id (v (T.drop 1 fragment))
168+
169+
codeAsHtml :: HtmlRenderContext -> RenderedCode -> Html
170+
codeAsHtml r = outputWith elemAsHtml
171+
where
172+
elemAsHtml e = case e of
173+
Syntax x ->
174+
withClass "syntax" (text x)
175+
Keyword x ->
176+
withClass "keyword" (text x)
177+
Space ->
178+
text " "
179+
Symbol ns name link_ ->
180+
case link_ of
181+
Link mn ->
182+
let
183+
class_ = if startsWithUpper name then "ctor" else "ident"
184+
in
185+
linkToDecl ns name mn (withClass class_ (text name))
186+
NoLink ->
187+
text name
188+
189+
linkToDecl = linkToDeclaration r
190+
191+
startsWithUpper :: Text -> Bool
192+
startsWithUpper str =
193+
if T.null str
194+
then False
195+
else isUpper (T.index str 0)
196+
197+
renderLink :: HtmlRenderContext -> DocLink -> Html -> Html
198+
renderLink r link_@DocLink{..} =
199+
a ! A.href (v (renderDocLink r link_ <> fragmentFor link_))
200+
! A.title (v fullyQualifiedName)
201+
where
202+
fullyQualifiedName = case linkLocation of
203+
SameModule -> fq (currentModuleName r) linkTitle
204+
LocalModule _ modName -> fq modName linkTitle
205+
DepsModule _ _ _ modName -> fq modName linkTitle
206+
BuiltinModule modName -> fq modName linkTitle
207+
208+
fq mn str = P.runModuleName mn <> "." <> str
209+
210+
makeFragment :: Namespace -> Text -> Text
211+
makeFragment ns = (prefix <>) . escape
212+
where
213+
prefix = case ns of
214+
TypeLevel -> "#t:"
215+
ValueLevel -> "#v:"
216+
KindLevel -> "#k:"
217+
218+
-- TODO
219+
escape = id
220+
221+
fragmentFor :: DocLink -> Text
222+
fragmentFor l = makeFragment (linkNamespace l) (linkTitle l)
223+
224+
linkToDeclaration ::
225+
HtmlRenderContext ->
226+
Namespace ->
227+
Text ->
228+
ContainingModule ->
229+
Html ->
230+
Html
231+
linkToDeclaration r ns target containMn =
232+
maybe id (renderLink r) (buildDocLink r ns target containMn)
233+
234+
renderAlias :: P.Fixity -> FixityAlias -> Html
235+
renderAlias (P.Fixity associativity precedence) alias_ =
236+
p $ do
237+
-- TODO: Render a link
238+
toHtml $ "Operator alias for " <> P.showQualified showAliasName alias_ <> " "
239+
em $
240+
text ("(" <> associativityStr <> " / precedence " <> T.pack (show precedence) <> ")")
241+
where
242+
showAliasName (Left valueAlias) = P.runProperName valueAlias
243+
showAliasName (Right typeAlias) = case typeAlias of
244+
(Left identifier) -> P.runIdent identifier
245+
(Right properName) -> P.runProperName properName
246+
associativityStr = case associativity of
247+
P.Infixl -> "left-associative"
248+
P.Infixr -> "right-associative"
249+
P.Infix -> "non-associative"
250+
251+
-- | Render Markdown to HTML. Safe for untrusted input. Relative links are
252+
-- | removed.
253+
renderMarkdown :: Text -> H.Html
254+
renderMarkdown =
255+
H.toMarkup . removeRelativeLinks . Cheapskate.markdown opts
256+
where
257+
opts = Cheapskate.def { Cheapskate.allowRawHtml = False }
258+
259+
removeRelativeLinks :: Cheapskate.Doc -> Cheapskate.Doc
260+
removeRelativeLinks = Cheapskate.walk go
261+
where
262+
go :: Cheapskate.Inlines -> Cheapskate.Inlines
263+
go = (>>= stripRelatives)
264+
265+
stripRelatives :: Cheapskate.Inline -> Cheapskate.Inlines
266+
stripRelatives (Cheapskate.Link contents_ href _)
267+
| isRelativeURI href = contents_
268+
stripRelatives other = pure other
269+
270+
-- Tests for a ':' character in the first segment of a URI.
271+
--
272+
-- See Section 4.2 of RFC 3986:
273+
-- https://tools.ietf.org/html/rfc3986#section-4.2
274+
--
275+
-- >>> isRelativeURI "http://example.com/" == False
276+
-- >>> isRelativeURI "mailto:me@example.com" == False
277+
-- >>> isRelativeURI "foo/bar" == True
278+
-- >>> isRelativeURI "/bar" == True
279+
-- >>> isRelativeURI "./bar" == True
280+
isRelativeURI :: Text -> Bool
281+
isRelativeURI =
282+
T.takeWhile (/= '/') >>> T.all (/= ':')
283+
284+
v :: Text -> AttributeValue
285+
v = toValue
286+
287+
withClass :: String -> Html -> Html
288+
withClass className content = H.span ! A.class_ (fromString className) $ content
289+
290+
partitionChildren ::
291+
[ChildDeclaration] ->
292+
([ChildDeclaration], [ChildDeclaration], [ChildDeclaration])
293+
partitionChildren = foldl go ([], [], [])
294+
where
295+
go (instances, dctors, members) rcd =
296+
case cdeclInfo rcd of
297+
ChildInstance _ _ -> (rcd : instances, dctors, members)
298+
ChildDataConstructor _ -> (instances, rcd : dctors, members)
299+
ChildTypeClassMember _ -> (instances, dctors, rcd : members)

0 commit comments

Comments
 (0)