Skip to content

Commit 8c70ee9

Browse files
AiOOAiOO
committed
Improve document design
1 parent fc16709 commit 8c70ee9

File tree

1 file changed

+136
-66
lines changed

1 file changed

+136
-66
lines changed

‎src/Nirum/Targets/Docs.hs

Lines changed: 136 additions & 66 deletions
Original file line numberDiff line numberDiff line change
@@ -1,4 +1,4 @@
1-
{-# LANGUAGE OverloadedLists, QuasiQuotes, TypeFamilies #-}
1+
{-# LANGUAGE QuasiQuotes, TypeFamilies #-}
22
module Nirum.Targets.Docs ( Docs
33
, blockToHtml
44
, makeFilePath
@@ -9,14 +9,17 @@ module Nirum.Targets.Docs ( Docs
99
import Data.Maybe (mapMaybe)
1010
import GHC.Exts (IsList (fromList, toList))
1111

12+
import qualified Data.ByteString as BS
1213
import Data.ByteString.Lazy (toStrict)
1314
import qualified Text.Email.Parser as E
1415
import Data.Map.Strict (Map, union)
1516
import qualified Data.Text as T
16-
import Data.Text.Encoding (decodeUtf8)
17+
import qualified Data.Text.Lazy as TL
18+
import Data.Text.Encoding (decodeUtf8, encodeUtf8)
1719
import System.FilePath ((</>))
1820
import Text.Blaze (ToMarkup (preEscapedToMarkup))
1921
import Text.Blaze.Html.Renderer.Utf8 (renderHtml)
22+
import Text.Cassius (cassius, renderCss)
2023
import Text.Hamlet (Html, shamlet)
2124

2225
import Nirum.Constructs (Construct (toCode))
@@ -72,8 +75,8 @@ makeUri modulePath' =
7275
T.intercalate "/" $
7376
map toNormalizedText (toList modulePath') ++ ["index.html"]
7477

75-
layout :: ToMarkup m => Package Docs -> m -> Html -> Html
76-
layout Package { metadata = md } title body = [shamlet|
78+
layout :: ToMarkup m => Package Docs -> Int -> m -> Html -> Html
79+
layout Package { metadata = md } dirDepth title body = [shamlet|
7780
$doctype 5
7881
<html>
7982
<head>
@@ -82,11 +85,12 @@ $doctype 5
8285
<meta name="generator" content="Nirum #{versionText}">
8386
$forall Author { name = name' } <- authors md
8487
<meta name="author" content="#{name'}">
88+
<link rel="stylesheet" href="#{T.replicate dirDepth "../"}style.css">
8589
<body>#{body}
8690
|]
8791

8892
typeExpression :: BoundModule Docs -> TE.TypeExpression -> Html
89-
typeExpression _ expr = [shamlet|<code>#{typeExpr expr}|]
93+
typeExpression _ expr = [shamlet|#{typeExpr expr}|]
9094
where
9195
typeExpr :: TE.TypeExpression -> Html
9296
typeExpr expr' = [shamlet|
@@ -104,20 +108,23 @@ $case expr'
104108
|]
105109

106110
module' :: BoundModule Docs -> Html
107-
module' docsModule = layout pkg path $ [shamlet|
111+
module' docsModule = layout pkg depth path $ [shamlet|
108112
$maybe tit <- title
109-
<h1><code>#{path}</code> &mdash; #{tit}
113+
<h1><code>#{path}</code>
114+
<p>#{tit}
110115
$nothing
111116
<h1><code>#{path}</code>
112117
$forall (ident, decl) <- types'
113118
<div class="#{showKind decl}" id="#{toNormalizedText ident}">
114119
#{typeDecl docsModule ident decl}
115120
|]
116121
where
122+
docsModulePath :: ModulePath
123+
docsModulePath = modulePath docsModule
117124
pkg :: Package Docs
118125
pkg = boundPackage docsModule
119126
path :: T.Text
120-
path = toCode $ modulePath docsModule
127+
path = toCode docsModulePath
121128
types' :: [(Identifier, TD.TypeDeclaration)]
122129
types' = [ (facialName $ DE.name decl, decl)
123130
| decl <- DES.toList $ types docsModule
@@ -126,36 +133,44 @@ module' docsModule = layout pkg path $ [shamlet|
126133
_ -> True
127134
]
128135
mod' :: Maybe Module
129-
mod' = resolveModule (modulePath docsModule) pkg
136+
mod' = resolveModule docsModulePath pkg
130137
title :: Maybe Html
131138
title = do
132139
m <- mod'
133140
moduleTitle m
141+
depth :: Int
142+
depth = length $ toList docsModulePath
134143

135144
blockToHtml :: Block -> Html
136145
blockToHtml b = preEscapedToMarkup $ render b
137146

138147
typeDecl :: BoundModule Docs -> Identifier -> TD.TypeDeclaration -> Html
139148
typeDecl mod' ident
140149
tc@TD.TypeDeclaration { TD.type' = TD.Alias cname } = [shamlet|
141-
<h2>type <code>#{toNormalizedText ident}</code>
150+
<h2>
151+
<span.type>type
152+
<code>#{toNormalizedText ident}</code>
153+
=
154+
<code>#{typeExpression mod' cname}</code>
142155
$maybe d <- docsBlock tc
143-
<p>#{blockToHtml d}
144-
<p>= <span class="canonical-type">#{typeExpression mod' cname}</span>
156+
#{blockToHtml d}
145157
|]
146158
typeDecl mod' ident
147159
tc@TD.TypeDeclaration { TD.type' = TD.UnboxedType innerType } =
148160
[shamlet|
149-
<h2>unboxed <code>#{toNormalizedText ident}</code>
161+
<h2>
162+
<span.type>unboxed
163+
<code>#{toNormalizedText ident} (#{typeExpression mod' innerType})
150164
$maybe d <- docsBlock tc
151-
<p>#{blockToHtml d}
152-
<p>(<span class="inner-type">#{typeExpression mod' innerType}</span>)
165+
#{blockToHtml d}
153166
|]
154167
typeDecl _ ident
155168
tc@TD.TypeDeclaration { TD.type' = TD.EnumType members } = [shamlet|
156-
<h2>enum <code>#{toNormalizedText ident}</code>
169+
<h2>
170+
<span.type>enum
171+
<code>#{toNormalizedText ident}
157172
$maybe d <- docsBlock tc
158-
<p>#{blockToHtml d}
173+
#{blockToHtml d}
159174
<dl class="members">
160175
$forall decl <- DES.toList members
161176
<dt class="member-name"><code>#{nameText $ DE.name decl}</code>
@@ -165,33 +180,33 @@ typeDecl _ ident
165180
|]
166181
typeDecl mod' ident
167182
tc@TD.TypeDeclaration { TD.type' = TD.RecordType fields } = [shamlet|
168-
<h2>record <code>#{toNormalizedText ident}</code>
183+
<h2>
184+
<span.type>record
185+
<code>#{toNormalizedText ident}
169186
$maybe d <- docsBlock tc
170-
<p>#{blockToHtml d}
171-
<dl class="fields">
172-
$forall fieldDecl@(TD.Field _ fieldType _) <- DES.toList fields
173-
<dt class="field-name"><code>#{nameText $ DE.name fieldDecl}</code>
174-
<dd class="field-type">#{typeExpression mod' fieldType}
175-
$maybe d <- docsBlock fieldDecl
176-
<dd>#{blockToHtml d}
187+
#{blockToHtml d}
188+
$forall fieldDecl@(TD.Field _ fieldType _) <- DES.toList fields
189+
<h3>
190+
<span.type>#{typeExpression mod' fieldType}
191+
<code>#{nameText $ DE.name fieldDecl}
192+
$maybe d <- docsBlock fieldDecl
193+
#{blockToHtml d}
177194
|]
178195
typeDecl mod' ident
179196
tc@TD.TypeDeclaration { TD.type' = TD.UnionType tags } = [shamlet|
180197
<h2>union <code>#{toNormalizedText ident}</code>
181198
$maybe d <- docsBlock tc
182-
<p>#{blockToHtml d}
199+
#{blockToHtml d}
183200
$forall tagDecl@(TD.Tag _ fields _) <- DES.toList tags
184-
<h3 class="tag">
185-
<code>#{nameText $ DE.name tagDecl}
201+
<h3 class="tag"><code>#{nameText $ DE.name tagDecl}</code>
186202
$maybe d <- docsBlock tagDecl
187-
<p>#{blockToHtml d}
188-
<dl class="fields">
189-
$forall fieldDecl@(TD.Field _ fieldType _) <- DES.toList fields
190-
<dt class="field-name">
191-
<code>#{nameText $ DE.name fieldDecl}
192-
<dd class="field-type">#{typeExpression mod' fieldType}
193-
$maybe d <- docsBlock fieldDecl
194-
<dd>#{blockToHtml d}
203+
#{blockToHtml d}
204+
$forall fieldDecl@(TD.Field _ fieldType _) <- DES.toList fields
205+
<h4>
206+
<span.type>#{typeExpression mod' fieldType}
207+
<code>#{nameText $ DE.name fieldDecl}
208+
$maybe d <- docsBlock fieldDecl
209+
#{blockToHtml d}
195210
|]
196211
typeDecl _ ident
197212
TD.TypeDeclaration { TD.type' = TD.PrimitiveType {} } = [shamlet|
@@ -202,23 +217,28 @@ typeDecl mod' ident
202217
[shamlet|
203218
<h2>service <code>#{toNormalizedText ident}</code>
204219
$maybe d <- docsBlock tc
205-
<p>#{blockToHtml d}
206-
$forall methodDecl@(S.Method _ ps ret err _) <- DES.toList methods
220+
#{blockToHtml d}
221+
$forall md@(S.Method _ ps ret err _) <- DES.toList methods
207222
<h3 class="method">
208-
<code class="method-name">#{nameText $ DE.name methodDecl}()
209-
&rarr;
210-
<code class="return-type">#{typeExpression mod' ret}
211-
$maybe d <- docsBlock methodDecl
212-
<p>#{blockToHtml d}
213-
$maybe errType <- err
214-
<p class="error-type">#{typeExpression mod' errType}
215-
<dl class="parameters">
216-
$forall paramDecl@(S.Parameter _ paramType _) <- DES.toList ps
217-
<dt class="parameter-name">
218-
<code>#{nameText $ DE.name paramDecl}
219-
<dd class="parameter-type">#{typeExpression mod' paramType}
220-
$maybe d <- docsBlock paramDecl
221-
<dd>#{blockToHtml d}
223+
<code class="method-name">#{nameText $ DE.name md}</code>(
224+
<i>
225+
$forall pd@(S.Parameter _ pt _) <- DES.toList ps
226+
#{typeExpression mod' pt} #{nameText $ DE.name pd}
227+
)
228+
$maybe d <- docsBlock md
229+
#{blockToHtml d}
230+
<dl class="result">
231+
<dt class="return-label">returns:
232+
<dd class="return-type">#{typeExpression mod' ret}
233+
$maybe errType <- err
234+
<dt class="raise-label">raises:
235+
<dd class="raise-type">#{typeExpression mod' errType}
236+
$forall paramDecl@(S.Parameter _ paramType _) <- DES.toList ps
237+
$maybe d <- docsBlock paramDecl
238+
<h4>
239+
<span.type>#{typeExpression mod' paramType}
240+
<code>#{nameText $ DE.name paramDecl}</code>:
241+
#{blockToHtml d}
222242
|]
223243
typeDecl _ _ TD.Import {} =
224244
error ("It shouldn't happen; please report it to Nirum's bug tracker:\n" ++
@@ -241,15 +261,16 @@ showKind TD.Import {} = "import"
241261
contents :: Package Docs -> Html
242262
contents pkg@Package { metadata = md
243263
, modules = ms
244-
} = layout pkg ("Package docs" :: T.Text) [shamlet|
264+
} = layout pkg 0 ("Package docs" :: T.Text) [shamlet|
245265
<h1>Modules
246-
<ul>
247-
$forall (modulePath', mod) <- MS.toAscList ms
248-
<li>
249-
<a href="#{makeUri modulePath'}">
250-
<code>#{toCode modulePath'} </code>
251-
$maybe tit <- moduleTitle mod
252-
&mdash; #{tit}
266+
$forall (modulePath', mod) <- MS.toAscList ms
267+
$maybe tit <- moduleTitle mod
268+
<h2>
269+
<a href="#{makeUri modulePath'}"><code>#{toCode modulePath'}</code>
270+
<p>#{tit}
271+
$nothing
272+
<h2>
273+
<a href="#{makeUri modulePath'}"><code>#{toCode modulePath'}</code>
253274
<hr>
254275
<dl>
255276
<dt.author>
@@ -280,23 +301,72 @@ moduleTitle Module { docs = docs' } = do
280301
_ -> Nothing
281302
return $ preEscapedToMarkup $ renderInlines nodes
282303

283-
compilePackage' :: Package Docs -> Map FilePath (Either Error Html)
304+
stylesheet :: TL.Text
305+
stylesheet = renderCss ([cassius|
306+
@import url(
307+
https://fonts.googleapis.com/css?family=Source+Code+Pro:300,400|Source+Sans+Pro
308+
)
309+
body
310+
font-family: Source Sans Pro
311+
color: #{gray8}
312+
code
313+
font-family: Source Code Pro
314+
font-weight: 300
315+
background-color: #{gray1}
316+
pre
317+
padding: 16px 10px
318+
background-color: #{gray1}
319+
code
320+
background: none
321+
div
322+
border-top: 1px solid #{gray3}
323+
h1, h2, h3, h4, h5, h6
324+
code
325+
font-weight: 400
326+
background-color: #{gray3}
327+
a
328+
text-decoration: none
329+
a:link
330+
color: #{indigo8}
331+
a:visited
332+
color: #{graph8}
333+
a:hover
334+
text-decoration: underline
335+
|] undefined)
336+
where
337+
-- from Open Color https://yeun.github.io/open-color/
338+
gray1 :: T.Text
339+
gray1 = "#f1f3f5"
340+
gray3 :: T.Text
341+
gray3 = "#dee2e6"
342+
gray8 :: T.Text
343+
gray8 = "#343a40"
344+
graph8 :: T.Text
345+
graph8 = "#9c36b5"
346+
indigo8 :: T.Text
347+
indigo8 = "#3b5bdb"
348+
349+
compilePackage' :: Package Docs -> Map FilePath (Either Error BS.ByteString)
284350
compilePackage' pkg =
285-
[("index.html", Right $ contents pkg)] `union`
286-
(fromList [ (makeFilePath $ modulePath m, Right $ module' m)
351+
fromList [ ("style.css", Right $ encodeUtf8 $ TL.toStrict $ stylesheet)
352+
, ("index.html", Right $ toStrict $ renderHtml $ contents pkg)
353+
] `union`
354+
(fromList [ ( makeFilePath $ modulePath m
355+
, Right $ toStrict $ renderHtml $ module' m
356+
)
287357
| m <- modules'
288-
] :: Map FilePath (Either Error Html))
358+
] :: Map FilePath (Either Error BS.ByteString))
289359
where
290360
paths' :: [ModulePath]
291361
paths' = MS.keys $ modules pkg
292362
modules' :: [BoundModule Docs]
293363
modules' = mapMaybe (`resolveBoundModule` pkg) paths'
294364

295365
instance Target Docs where
296-
type CompileResult Docs = Html
366+
type CompileResult Docs = BS.ByteString
297367
type CompileError Docs = Error
298368
targetName _ = "docs"
299369
parseTarget _ = return Docs
300370
compilePackage = compilePackage'
301371
showCompileError _ = id
302-
toByteString _ = toStrict . renderHtml
372+
toByteString _ = id

0 commit comments

Comments
 (0)