summaryrefslogtreecommitdiff
path: root/src/Language/PureScript/Docs/AsHtml.hs
blob: c3eec5bd3604529b4cc845af6fa375c283d63ad2 (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302

-- | Functions for rendering generated documentation from PureScript code as
-- HTML.

module Language.PureScript.Docs.AsHtml (
  HtmlOutput(..),
  HtmlOutputModule(..),
  HtmlRenderContext(..),
  nullRenderContext,
  declNamespace,
  packageAsHtml,
  moduleAsHtml,
  makeFragment,
  renderMarkdown
) where

import Prelude
import Control.Arrow (second)
import Control.Category ((>>>))
import Control.Monad (unless)
import Data.Char (isUpper)
import Data.Monoid ((<>))
import Data.Foldable (for_)
import Data.String (fromString)

import Data.Text (Text)
import qualified Data.Text as T

import Text.Blaze.Html5 as H hiding (map)
import qualified Text.Blaze.Html5.Attributes as A
import qualified Cheapskate

import qualified Language.PureScript as P

import Language.PureScript.Docs.Types
import Language.PureScript.Docs.RenderedCode hiding (sp)
import qualified Language.PureScript.Docs.Render as Render

declNamespace :: Declaration -> Namespace
declNamespace = declInfoNamespace . declInfo

data HtmlOutput a = HtmlOutput
  { htmlIndex     :: [(Maybe Char, a)]
  , htmlModules   :: [(P.ModuleName, HtmlOutputModule a)]
  }
  deriving (Show, Functor)

data HtmlOutputModule a = HtmlOutputModule
  { htmlOutputModuleLocals    :: a
  , htmlOutputModuleReExports :: [(InPackage P.ModuleName, a)]
  }
  deriving (Show, Functor)

data HtmlRenderContext = HtmlRenderContext
  { currentModuleName :: P.ModuleName
  , buildDocLink :: Namespace -> Text -> ContainingModule -> Maybe DocLink
  , renderDocLink :: DocLink -> Text
  , renderSourceLink :: P.SourceSpan -> Maybe Text
  }

-- |
-- An HtmlRenderContext for when you don't want to render any links.
nullRenderContext :: P.ModuleName -> HtmlRenderContext
nullRenderContext mn = HtmlRenderContext
  { currentModuleName = mn
  , buildDocLink = const (const (const Nothing))
  , renderDocLink = const ""
  , renderSourceLink = const Nothing
  }

packageAsHtml :: (P.ModuleName -> HtmlRenderContext) -> Package a -> HtmlOutput Html
packageAsHtml getHtmlCtx Package{..} =
  HtmlOutput indexFile modules
  where
  indexFile = []
  modules = map (\m -> moduleAsHtml (getHtmlCtx (modName m)) m) pkgModules

moduleAsHtml :: HtmlRenderContext -> Module -> (P.ModuleName, HtmlOutputModule Html)
moduleAsHtml r Module{..} = (modName, HtmlOutputModule modHtml reexports)
  where
  renderDecl = declAsHtml r
  modHtml = do
    for_ modComments renderMarkdown
    for_ modDeclarations renderDecl
  reexports =
    map (second (foldMap renderDecl)) modReExports

-- renderIndex :: LinksContext -> [(Maybe Char, Html)]
-- renderIndex LinksContext{..} = go ctxBookmarks
--   where
--   go = takeLocals
--      >>> groupIndex getIndex renderEntry
--      >>> map (second (ul . mconcat))
-- 
--   getIndex (_, title_) = do
--     c <- textHeadMay title_
--     guard (toUpper c `elem` ['A'..'Z'])
--     pure c
-- 
--   textHeadMay t =
--     case T.length t of
--       0 -> Nothing
--       _ -> Just (T.index t 0)
-- 
--   renderEntry (mn, title_) =
--     li $ do
--       let url = T.pack (filePathFor mn `relativeTo` "index") <> "#" <> title_
--       code $
--         a ! A.href (v url) $ text title_
--       sp
--       text ("(" <> P.runModuleName mn <> ")")
-- 
--   groupIndex :: Ord i => (a -> Maybe i) -> (a -> b) -> [a] -> [(Maybe i, [b])]
--   groupIndex f g =
--     map (second DList.toList) . M.toList . foldr go' M.empty . sortBy (comparing f)
--     where
--     go' x = insertOrAppend (f x) (g x)
--     insertOrAppend idx val m =
--       let cur = M.findWithDefault DList.empty idx m
--           new = DList.snoc cur val
--       in  M.insert idx new m

declAsHtml :: HtmlRenderContext -> Declaration -> Html
declAsHtml r d@Declaration{..} = do
  let declFragment = makeFragment (declInfoNamespace declInfo) declTitle
  H.div ! A.class_ "decl" ! A.id (v (T.drop 1 declFragment)) $ do
    h3 ! A.class_ "decl__title clearfix" $ do
      a ! A.class_ "decl__anchor" ! A.href (v declFragment) $ "#"
      H.span $ text declTitle
      for_ declSourceSpan (linkToSource r)

    H.div ! A.class_ "decl__body" $ do
      case declInfo of
        AliasDeclaration fixity alias_ ->
          renderAlias fixity alias_
        _ ->
          pre ! A.class_ "decl__signature" $ code $
            codeAsHtml r (Render.renderDeclaration d)

      for_ declComments renderMarkdown

      let (instances, dctors, members) = partitionChildren declChildren

      unless (null dctors) $ do
        h4 "Constructors"
        renderChildren r dctors

      unless (null members) $ do
        h4 "Members"
        renderChildren r members

      unless (null instances) $ do
        h4 "Instances"
        renderChildren r instances
  where
    linkToSource :: HtmlRenderContext -> P.SourceSpan -> Html
    linkToSource ctx srcspan =
      maybe (return ()) go (renderSourceLink ctx srcspan)
      where
      go href =
        H.span ! A.class_ "decl__source" $
          a ! A.href (v href) $ text "Source"

renderChildren :: HtmlRenderContext -> [ChildDeclaration] -> Html
renderChildren _ [] = return ()
renderChildren r xs = ul $ mapM_ go xs
  where
  go decl = item decl . code . codeAsHtml r . Render.renderChildDeclaration $ decl
  item decl = let fragment = makeFragment (childDeclInfoNamespace (cdeclInfo decl)) (cdeclTitle decl)
              in  li ! A.id (v (T.drop 1 fragment))

codeAsHtml :: HtmlRenderContext -> RenderedCode -> Html
codeAsHtml r = outputWith elemAsHtml
  where
  elemAsHtml e = case e of
    Syntax x ->
      withClass "syntax" (text x)
    Keyword x ->
      withClass "keyword" (text x)
    Space ->
      text " "
    Symbol ns name link_ ->
      case link_ of
        Link mn ->
          let
            class_ = if startsWithUpper name then "ctor" else "ident"
          in
            linkToDecl ns name mn (withClass class_ (text name))
        NoLink ->
          text name

  linkToDecl = linkToDeclaration r

  startsWithUpper :: Text -> Bool
  startsWithUpper str =
    if T.null str
      then False
      else isUpper (T.index str 0)

renderLink :: HtmlRenderContext -> DocLink -> Html -> Html
renderLink r link_@DocLink{..} =
  a ! A.href (v (renderDocLink r link_ <> fragmentFor link_))
    ! A.title (v fullyQualifiedName)
  where
  fullyQualifiedName = case linkLocation of
    SameModule                -> fq (currentModuleName r) linkTitle
    LocalModule _ modName     -> fq modName linkTitle
    DepsModule _ _ _ modName  -> fq modName linkTitle
    BuiltinModule modName     -> fq modName linkTitle

  fq mn str = P.runModuleName mn <> "." <> str

makeFragment :: Namespace -> Text -> Text
makeFragment ns = (prefix <>) . escape
  where
  prefix = case ns of
    TypeLevel -> "#t:"
    ValueLevel -> "#v:"
    KindLevel -> "#k:"

  -- TODO
  escape = id

fragmentFor :: DocLink -> Text
fragmentFor l = makeFragment (linkNamespace l) (linkTitle l)

linkToDeclaration ::
  HtmlRenderContext ->
  Namespace ->
  Text ->
  ContainingModule ->
  Html ->
  Html
linkToDeclaration r ns target containMn =
  maybe id (renderLink r) (buildDocLink r ns target containMn)

renderAlias :: P.Fixity -> FixityAlias -> Html
renderAlias (P.Fixity associativity precedence) alias_ =
  p $ do
    -- TODO: Render a link
    toHtml $ "Operator alias for " <> P.showQualified showAliasName alias_ <> " "
    em $
      text ("(" <> associativityStr <> " / precedence " <> T.pack (show precedence) <> ")")
  where
  showAliasName (Left valueAlias) = P.runProperName valueAlias
  showAliasName (Right typeAlias) = case typeAlias of
    (Left identifier)  -> P.runIdent identifier
    (Right properName) -> P.runProperName properName
  associativityStr = case associativity of
    P.Infixl -> "left-associative"
    P.Infixr -> "right-associative"
    P.Infix  -> "non-associative"

-- | Render Markdown to HTML. Safe for untrusted input. Relative links are
-- | removed.
renderMarkdown :: Text -> H.Html
renderMarkdown =
  H.toMarkup . removeRelativeLinks . Cheapskate.markdown opts
  where
  opts = Cheapskate.def { Cheapskate.allowRawHtml = False }

removeRelativeLinks :: Cheapskate.Doc -> Cheapskate.Doc
removeRelativeLinks = Cheapskate.walk go
  where
  go :: Cheapskate.Inlines -> Cheapskate.Inlines
  go = (>>= stripRelatives)

  stripRelatives :: Cheapskate.Inline -> Cheapskate.Inlines
  stripRelatives (Cheapskate.Link contents_ href _)
    | isRelativeURI href = contents_
  stripRelatives other = pure other

  -- Tests for a ':' character in the first segment of a URI.
  --
  -- See Section 4.2 of RFC 3986:
  -- https://tools.ietf.org/html/rfc3986#section-4.2
  --
  -- >>> isRelativeURI "http://example.com/" == False
  -- >>> isRelativeURI "mailto:me@example.com" == False
  -- >>> isRelativeURI "foo/bar" == True
  -- >>> isRelativeURI "/bar" == True
  -- >>> isRelativeURI "./bar" == True
  isRelativeURI :: Text -> Bool
  isRelativeURI =
    T.takeWhile (/= '/') >>> T.all (/= ':')

v :: Text -> AttributeValue
v = toValue

withClass :: String -> Html -> Html
withClass className content = H.span ! A.class_ (fromString className) $ content

partitionChildren ::
  [ChildDeclaration] ->
  ([ChildDeclaration], [ChildDeclaration], [ChildDeclaration])
partitionChildren = foldl go ([], [], [])
  where
  go (instances, dctors, members) rcd =
    case cdeclInfo rcd of
      ChildInstance _ _      -> (rcd : instances, dctors, members)
      ChildDataConstructor _ -> (instances, rcd : dctors, members)
      ChildTypeClassMember _ -> (instances, dctors, rcd : members)