Skip to content
New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

Sign up for GitHub

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Improve document design #170

Merged
merged 1 commit into from
Aug 17, 2017
Merged

Improve document design #170

Changes from all commits
Commits
Show all changes
1 commit
Select commit
File filter

Filter by extension

Filter by extension
Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
202 changes: 136 additions & 66 deletions src/Nirum/Targets/Docs.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
@@ -1,4 +1,4 @@
{-# LANGUAGE OverloadedLists, QuasiQuotes, TypeFamilies #-}
{-# LANGUAGE QuasiQuotes, TypeFamilies #-}
module Nirum.Targets.Docs ( Docs
, blockToHtml
, makeFilePath
Expand All @@ -9,14 +9,17 @@ module Nirum.Targets.Docs ( Docs
import Data.Maybe (mapMaybe)
import GHC.Exts (IsList (fromList, toList))

import qualified Data.ByteString as BS
import Data.ByteString.Lazy (toStrict)
import qualified Text.Email.Parser as E
import Data.Map.Strict (Map, union)
import qualified Data.Text as T
import Data.Text.Encoding (decodeUtf8)
import qualified Data.Text.Lazy as TL
import Data.Text.Encoding (decodeUtf8, encodeUtf8)
import System.FilePath ((</>))
import Text.Blaze (ToMarkup (preEscapedToMarkup))
import Text.Blaze.Html.Renderer.Utf8 (renderHtml)
import Text.Cassius (cassius, renderCss)
import Text.Hamlet (Html, shamlet)

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

layout :: ToMarkup m => Package Docs -> m -> Html -> Html
layout Package { metadata = md } title body = [shamlet|
layout :: ToMarkup m => Package Docs -> Int -> m -> Html -> Html
layout Package { metadata = md } dirDepth title body = [shamlet|
$doctype 5
<html>
<head>
Expand All @@ -82,11 +85,12 @@ $doctype 5
<meta name="generator" content="Nirum #{versionText}">
$forall Author { name = name' } <- authors md
<meta name="author" content="#{name'}">
<link rel="stylesheet" href="#{T.replicate dirDepth "../"}style.css">
<body>#{body}
|]

typeExpression :: BoundModule Docs -> TE.TypeExpression -> Html
typeExpression _ expr = [shamlet|<code>#{typeExpr expr}|]
typeExpression _ expr = [shamlet|#{typeExpr expr}|]
where
typeExpr :: TE.TypeExpression -> Html
typeExpr expr' = [shamlet|
Expand All @@ -104,20 +108,23 @@ $case expr'
|]

module' :: BoundModule Docs -> Html
module' docsModule = layout pkg path $ [shamlet|
module' docsModule = layout pkg depth path $ [shamlet|
$maybe tit <- title
<h1><code>#{path}</code> &mdash; #{tit}
<h1><code>#{path}</code>
<p>#{tit}
$nothing
<h1><code>#{path}</code>
$forall (ident, decl) <- types'
<div class="#{showKind decl}" id="#{toNormalizedText ident}">
#{typeDecl docsModule ident decl}
|]
where
docsModulePath :: ModulePath
docsModulePath = modulePath docsModule
pkg :: Package Docs
pkg = boundPackage docsModule
path :: T.Text
path = toCode $ modulePath docsModule
path = toCode docsModulePath
types' :: [(Identifier, TD.TypeDeclaration)]
types' = [ (facialName $ DE.name decl, decl)
| decl <- DES.toList $ types docsModule
Expand All @@ -126,36 +133,44 @@ module' docsModule = layout pkg path $ [shamlet|
_ -> True
]
mod' :: Maybe Module
mod' = resolveModule (modulePath docsModule) pkg
mod' = resolveModule docsModulePath pkg
title :: Maybe Html
title = do
m <- mod'
moduleTitle m
depth :: Int
depth = length $ toList docsModulePath

blockToHtml :: Block -> Html
blockToHtml b = preEscapedToMarkup $ render b

typeDecl :: BoundModule Docs -> Identifier -> TD.TypeDeclaration -> Html
typeDecl mod' ident
tc@TD.TypeDeclaration { TD.type' = TD.Alias cname } = [shamlet|
<h2>type <code>#{toNormalizedText ident}</code>
<h2>
<span.type>type
<code>#{toNormalizedText ident}</code>
=
<code>#{typeExpression mod' cname}</code>
$maybe d <- docsBlock tc
<p>#{blockToHtml d}
<p>= <span class="canonical-type">#{typeExpression mod' cname}</span>
#{blockToHtml d}
|]
typeDecl mod' ident
tc@TD.TypeDeclaration { TD.type' = TD.UnboxedType innerType } =
[shamlet|
<h2>unboxed <code>#{toNormalizedText ident}</code>
<h2>
<span.type>unboxed
<code>#{toNormalizedText ident} (#{typeExpression mod' innerType})
$maybe d <- docsBlock tc
<p>#{blockToHtml d}
<p>(<span class="inner-type">#{typeExpression mod' innerType}</span>)
#{blockToHtml d}
|]
typeDecl _ ident
tc@TD.TypeDeclaration { TD.type' = TD.EnumType members } = [shamlet|
<h2>enum <code>#{toNormalizedText ident}</code>
<h2>
<span.type>enum
<code>#{toNormalizedText ident}
$maybe d <- docsBlock tc
<p>#{blockToHtml d}
#{blockToHtml d}
<dl class="members">
$forall decl <- DES.toList members
<dt class="member-name"><code>#{nameText $ DE.name decl}</code>
Expand All @@ -165,33 +180,33 @@ typeDecl _ ident
|]
typeDecl mod' ident
tc@TD.TypeDeclaration { TD.type' = TD.RecordType fields } = [shamlet|
<h2>record <code>#{toNormalizedText ident}</code>
<h2>
<span.type>record
<code>#{toNormalizedText ident}
$maybe d <- docsBlock tc
<p>#{blockToHtml d}
<dl class="fields">
$forall fieldDecl@(TD.Field _ fieldType _) <- DES.toList fields
<dt class="field-name"><code>#{nameText $ DE.name fieldDecl}</code>
<dd class="field-type">#{typeExpression mod' fieldType}
$maybe d <- docsBlock fieldDecl
<dd>#{blockToHtml d}
#{blockToHtml d}
$forall fieldDecl@(TD.Field _ fieldType _) <- DES.toList fields
<h3>
<span.type>#{typeExpression mod' fieldType}
<code>#{nameText $ DE.name fieldDecl}
$maybe d <- docsBlock fieldDecl
#{blockToHtml d}
|]
typeDecl mod' ident
tc@TD.TypeDeclaration { TD.type' = TD.UnionType tags } = [shamlet|
<h2>union <code>#{toNormalizedText ident}</code>
$maybe d <- docsBlock tc
<p>#{blockToHtml d}
#{blockToHtml d}
$forall tagDecl@(TD.Tag _ fields _) <- DES.toList tags
<h3 class="tag">
<code>#{nameText $ DE.name tagDecl}
<h3 class="tag"><code>#{nameText $ DE.name tagDecl}</code>
$maybe d <- docsBlock tagDecl
<p>#{blockToHtml d}
<dl class="fields">
$forall fieldDecl@(TD.Field _ fieldType _) <- DES.toList fields
<dt class="field-name">
<code>#{nameText $ DE.name fieldDecl}
<dd class="field-type">#{typeExpression mod' fieldType}
$maybe d <- docsBlock fieldDecl
<dd>#{blockToHtml d}
#{blockToHtml d}
$forall fieldDecl@(TD.Field _ fieldType _) <- DES.toList fields
<h4>
<span.type>#{typeExpression mod' fieldType}
<code>#{nameText $ DE.name fieldDecl}
$maybe d <- docsBlock fieldDecl
#{blockToHtml d}
|]
typeDecl _ ident
TD.TypeDeclaration { TD.type' = TD.PrimitiveType {} } = [shamlet|
Expand All @@ -202,23 +217,28 @@ typeDecl mod' ident
[shamlet|
<h2>service <code>#{toNormalizedText ident}</code>
$maybe d <- docsBlock tc
<p>#{blockToHtml d}
$forall methodDecl@(S.Method _ ps ret err _) <- DES.toList methods
#{blockToHtml d}
$forall md@(S.Method _ ps ret err _) <- DES.toList methods
<h3 class="method">
<code class="method-name">#{nameText $ DE.name methodDecl}()
&rarr;
<code class="return-type">#{typeExpression mod' ret}
$maybe d <- docsBlock methodDecl
<p>#{blockToHtml d}
$maybe errType <- err
<p class="error-type">#{typeExpression mod' errType}
<dl class="parameters">
$forall paramDecl@(S.Parameter _ paramType _) <- DES.toList ps
<dt class="parameter-name">
<code>#{nameText $ DE.name paramDecl}
<dd class="parameter-type">#{typeExpression mod' paramType}
$maybe d <- docsBlock paramDecl
<dd>#{blockToHtml d}
<code class="method-name">#{nameText $ DE.name md}</code>(
<i>
$forall pd@(S.Parameter _ pt _) <- DES.toList ps
#{typeExpression mod' pt} #{nameText $ DE.name pd}
)
$maybe d <- docsBlock md
#{blockToHtml d}
<dl class="result">
<dt class="return-label">returns:
<dd class="return-type">#{typeExpression mod' ret}
$maybe errType <- err
<dt class="raise-label">raises:
<dd class="raise-type">#{typeExpression mod' errType}
$forall paramDecl@(S.Parameter _ paramType _) <- DES.toList ps
$maybe d <- docsBlock paramDecl
<h4>
<span.type>#{typeExpression mod' paramType}
<code>#{nameText $ DE.name paramDecl}</code>:
#{blockToHtml d}
|]
typeDecl _ _ TD.Import {} =
error ("It shouldn't happen; please report it to Nirum's bug tracker:\n" ++
Expand All @@ -241,15 +261,16 @@ showKind TD.Import {} = "import"
contents :: Package Docs -> Html
contents pkg@Package { metadata = md
, modules = ms
} = layout pkg ("Package docs" :: T.Text) [shamlet|
} = layout pkg 0 ("Package docs" :: T.Text) [shamlet|
<h1>Modules
<ul>
$forall (modulePath', mod) <- MS.toAscList ms
<li>
<a href="#{makeUri modulePath'}">
<code>#{toCode modulePath'} </code>
$maybe tit <- moduleTitle mod
&mdash; #{tit}
$forall (modulePath', mod) <- MS.toAscList ms
$maybe tit <- moduleTitle mod
<h2>
<a href="#{makeUri modulePath'}"><code>#{toCode modulePath'}</code>
<p>#{tit}
$nothing
<h2>
<a href="#{makeUri modulePath'}"><code>#{toCode modulePath'}</code>
<hr>
<dl>
<dt.author>
Expand Down Expand Up @@ -280,23 +301,72 @@ moduleTitle Module { docs = docs' } = do
_ -> Nothing
return $ preEscapedToMarkup $ renderInlines nodes

compilePackage' :: Package Docs -> Map FilePath (Either Error Html)
stylesheet :: TL.Text
stylesheet = renderCss ([cassius|
@import url(
https://fonts.googleapis.com/css?family=Source+Code+Pro:300,400|Source+Sans+Pro
)
body
font-family: Source Sans Pro
color: #{gray8}
code
font-family: Source Code Pro
font-weight: 300
background-color: #{gray1}
pre
padding: 16px 10px
background-color: #{gray1}
code
background: none
div
border-top: 1px solid #{gray3}
h1, h2, h3, h4, h5, h6
code
font-weight: 400
background-color: #{gray3}
a
text-decoration: none
a:link
color: #{indigo8}
a:visited
color: #{graph8}
a:hover
text-decoration: underline
|] undefined)
where
-- from Open Color https://yeun.github.io/open-color/
gray1 :: T.Text
gray1 = "#f1f3f5"
gray3 :: T.Text
gray3 = "#dee2e6"
gray8 :: T.Text
gray8 = "#343a40"
graph8 :: T.Text
graph8 = "#9c36b5"
indigo8 :: T.Text
indigo8 = "#3b5bdb"

compilePackage' :: Package Docs -> Map FilePath (Either Error BS.ByteString)
compilePackage' pkg =
[("index.html", Right $ contents pkg)] `union`
(fromList [ (makeFilePath $ modulePath m, Right $ module' m)
fromList [ ("style.css", Right $ encodeUtf8 $ TL.toStrict stylesheet)
, ("index.html", Right $ toStrict $ renderHtml $ contents pkg)
] `union`
(fromList [ ( makeFilePath $ modulePath m
, Right $ toStrict $ renderHtml $ module' m
)
| m <- modules'
] :: Map FilePath (Either Error Html))
] :: Map FilePath (Either Error BS.ByteString))
where
paths' :: [ModulePath]
paths' = MS.keys $ modules pkg
modules' :: [BoundModule Docs]
modules' = mapMaybe (`resolveBoundModule` pkg) paths'

instance Target Docs where
type CompileResult Docs = Html
type CompileResult Docs = BS.ByteString
type CompileError Docs = Error
targetName _ = "docs"
parseTarget _ = return Docs
compilePackage = compilePackage'
showCompileError _ = id
toByteString _ = toStrict . renderHtml
toByteString _ = id