@@ -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)