mirror of
https://github.com/unisonweb/unison.git
synced 2024-09-20 14:57:41 +03:00
Doc.AsHtml: Use lucid to render docs and syntax
This commit is contained in:
Simon Højberg
parent
481a25b3da
commit
ece8e77c2f
@ -90,6 +90,7 @@ library:
|
||||
- safe-exceptions
|
||||
- mwc-random
|
||||
- NanoID
|
||||
- lucid
|
||||
- servant
|
||||
- servant-docs
|
||||
- servant-openapi3
|
||||
|
||||
@ -10,51 +10,11 @@ import Data.Text (Text)
|
||||
import qualified Data.Text as Text
|
||||
import Unison.Codebase.Editor.DisplayObject (DisplayObject (..))
|
||||
import Unison.Server.Doc
|
||||
import Unison.Server.Html
|
||||
( Html,
|
||||
a,
|
||||
article,
|
||||
aside,
|
||||
blank,
|
||||
blockquote,
|
||||
br,
|
||||
code,
|
||||
details,
|
||||
div_,
|
||||
hr,
|
||||
img,
|
||||
li,
|
||||
ol,
|
||||
p,
|
||||
pre,
|
||||
section,
|
||||
span_,
|
||||
strong,
|
||||
summary,
|
||||
table,
|
||||
tbody,
|
||||
td,
|
||||
text,
|
||||
tr,
|
||||
ul,
|
||||
)
|
||||
import qualified Unison.Server.Html as Html
|
||||
import Unison.Server.Html.Attribute
|
||||
( Attribute,
|
||||
alt,
|
||||
class_,
|
||||
data_,
|
||||
href,
|
||||
id_,
|
||||
open,
|
||||
rel,
|
||||
src,
|
||||
start,
|
||||
style,
|
||||
target,
|
||||
)
|
||||
import Unison.Server.Syntax (SyntaxText)
|
||||
import qualified Unison.Server.Syntax as Syntax
|
||||
import Lucid
|
||||
import qualified Lucid as L
|
||||
import Data.Foldable
|
||||
|
||||
data NamedLinkHref
|
||||
= Href Text
|
||||
@ -76,13 +36,13 @@ embeddedSource ref =
|
||||
Term s -> embeddedSource' s
|
||||
Type s -> embeddedSource' s
|
||||
|
||||
inlineCode :: [Attribute] -> Html -> Html
|
||||
inlineCode attrs content =
|
||||
pre (class_ "inline-code" : attrs) [code [] [content]]
|
||||
inlineCode :: [Attribute] -> Html () -> Html ()
|
||||
inlineCode attrs =
|
||||
pre_ (class_ "inline-code" : attrs) . code_ []
|
||||
|
||||
codeBlock :: [Attribute] -> Html -> Html
|
||||
codeBlock attrs content =
|
||||
pre attrs [code [] [content]]
|
||||
codeBlock :: [Attribute] -> Html () -> Html ()
|
||||
codeBlock attrs =
|
||||
pre_ attrs . code_ []
|
||||
|
||||
normalizeHref :: NamedLinkHref -> Doc -> NamedLinkHref
|
||||
normalizeHref href doc =
|
||||
@ -99,6 +59,7 @@ normalizeHref href doc =
|
||||
normalizeHref href d_
|
||||
Join ds ->
|
||||
foldl' normalizeHref href ds
|
||||
|
||||
Special (Link syntax) ->
|
||||
let folder acc seg =
|
||||
case acc of
|
||||
@ -111,22 +72,22 @@ normalizeHref href doc =
|
||||
href
|
||||
|
||||
data IsFolded
|
||||
= IsFolded Bool [Html] [Html]
|
||||
| Disabled Html
|
||||
= IsFolded Bool [Html ()] [Html ()]
|
||||
| Disabled (Html ())
|
||||
|
||||
foldedToHtml :: [Attribute] -> IsFolded -> Html
|
||||
foldedToHtml :: [Attribute] -> IsFolded -> Html ()
|
||||
foldedToHtml attrs isFolded =
|
||||
case isFolded of
|
||||
Disabled summary_ ->
|
||||
details attrs [summary [] [summary_]]
|
||||
IsFolded isFolded summary_ details_ ->
|
||||
Disabled summary ->
|
||||
details_ attrs $ summary_ summary
|
||||
IsFolded isFolded summary details ->
|
||||
let attrsWithOpen =
|
||||
if isFolded
|
||||
then open : attrs
|
||||
then open_ "open" : attrs
|
||||
else attrs
|
||||
in details attrsWithOpen (summary [] summary_ : details_)
|
||||
in details_ attrsWithOpen $ summary_ [] $ sequence_ $ summary ++ details
|
||||
|
||||
foldedToHtmlSource :: Bool -> EmbeddedSource -> Html
|
||||
foldedToHtmlSource :: Bool -> EmbeddedSource -> Html ()
|
||||
foldedToHtmlSource isFolded source =
|
||||
case source of
|
||||
Builtin summary ->
|
||||
@ -134,20 +95,20 @@ foldedToHtmlSource isFolded source =
|
||||
[class_ "rich source"]
|
||||
( Disabled
|
||||
( div_
|
||||
[class_ "builtin-summary"]
|
||||
[ codeBlock [] (Syntax.toHtml summary),
|
||||
badge (span_ [] [strong [] [text "Built-in "], span_ [] [text "provided by the Unison runtime"]])
|
||||
]
|
||||
[class_ "builtin-summary"] $ do
|
||||
codeBlock [] $ Syntax.toHtml summary
|
||||
badge $ do
|
||||
span_ [] $ strong_ [] "Built-in"
|
||||
span_ [] "provided by the Unison runtime"
|
||||
|
||||
)
|
||||
)
|
||||
EmbeddedSource summary details ->
|
||||
foldedToHtml
|
||||
[class_ "rich source"]
|
||||
( IsFolded
|
||||
foldedToHtml [class_ "rich source"] $ IsFolded
|
||||
isFolded
|
||||
[codeBlock [] (Syntax.toHtml summary)]
|
||||
[codeBlock [] (Syntax.toHtml details)]
|
||||
)
|
||||
[codeBlock [] $ Syntax.toHtml summary]
|
||||
[codeBlock [] $ Syntax.toHtml details]
|
||||
|
||||
|
||||
-- Merge adjacent Word elements in a list to 1 element with a string of words
|
||||
-- separated by space— useful for rendering to the dom without creating dom
|
||||
@ -163,7 +124,7 @@ mergeWords = foldr merge_ [] where
|
||||
_ ->
|
||||
d : acc
|
||||
|
||||
toHtml :: Doc -> Html
|
||||
toHtml :: Doc -> Html ()
|
||||
toHtml document =
|
||||
let toHtml_ sectionLevel doc =
|
||||
let -- Make it simple to retain the sectionLevel when recurring.
|
||||
@ -174,66 +135,64 @@ toHtml document =
|
||||
sectionContentToHtml renderer doc_ =
|
||||
case doc_ of
|
||||
Paragraph _ ->
|
||||
p [] [renderer doc_]
|
||||
p_ [] $ renderer doc_
|
||||
_ ->
|
||||
renderer doc_
|
||||
in case doc of
|
||||
Word word ->
|
||||
span_ [class_ "word"] [text word]
|
||||
span_ [class_ "word"] (L.toHtml word)
|
||||
Code code ->
|
||||
span_ [class_ "rich source inline-code"] [inlineCode [] (currentSectionLevelToHtml code)]
|
||||
span_ [class_ "rich source inline-code"] $ inlineCode [] (currentSectionLevelToHtml code)
|
||||
CodeBlock lang code ->
|
||||
div_ [class_ "rich source code", class_ $ textToClass lang] [codeBlock [] (currentSectionLevelToHtml code)]
|
||||
div_ [class_ "rich source code", class_ $ textToClass lang] $ codeBlock [] (currentSectionLevelToHtml code)
|
||||
Bold d ->
|
||||
strong [] [currentSectionLevelToHtml d]
|
||||
strong_ [] $ currentSectionLevelToHtml d
|
||||
Italic d ->
|
||||
span_ [class_ "italic"] [currentSectionLevelToHtml d]
|
||||
span_ [class_ "italic"] $ currentSectionLevelToHtml d
|
||||
Strikethrough d ->
|
||||
span_ [class_ "strikethrough"] [currentSectionLevelToHtml d]
|
||||
span_ [class_ "strikethrough"] $ currentSectionLevelToHtml d
|
||||
Style cssclass_ d ->
|
||||
span_ [class_ $ textToClass cssclass_] [currentSectionLevelToHtml d]
|
||||
span_ [class_ $ textToClass cssclass_] $ currentSectionLevelToHtml d
|
||||
Anchor id' d ->
|
||||
a [id_ id', target id'] [currentSectionLevelToHtml d]
|
||||
a_ [id_ id', target_ id'] $ currentSectionLevelToHtml d
|
||||
Blockquote d ->
|
||||
blockquote [] [currentSectionLevelToHtml d]
|
||||
blockquote_ [] $ currentSectionLevelToHtml d
|
||||
Blankline ->
|
||||
div_ [] [br [], br []]
|
||||
div_ [] $ do
|
||||
br_ []
|
||||
br_ []
|
||||
Linebreak ->
|
||||
br []
|
||||
br_ []
|
||||
SectionBreak ->
|
||||
hr []
|
||||
hr_ []
|
||||
Tooltip triggerContent tooltipContent ->
|
||||
span_
|
||||
[class_ "tooltip below arrow-start"]
|
||||
[ span_ [class_ "tooltip-trigger"] [currentSectionLevelToHtml triggerContent],
|
||||
div_ [class_ "tooltip-bubble", style "display: none"] [currentSectionLevelToHtml tooltipContent]
|
||||
]
|
||||
[class_ "tooltip below arrow-start"] $ do
|
||||
span_ [class_ "tooltip-trigger"] $ currentSectionLevelToHtml triggerContent
|
||||
div_ [class_ "tooltip-bubble", style_ "display: none"] $ currentSectionLevelToHtml tooltipContent
|
||||
|
||||
Aside d ->
|
||||
span_
|
||||
[class_ "aside-anchor"]
|
||||
[ aside [] [currentSectionLevelToHtml d]
|
||||
]
|
||||
[class_ "aside-anchor"] $
|
||||
aside_ [] $ currentSectionLevelToHtml d
|
||||
|
||||
Callout icon content ->
|
||||
let (cls, ico) =
|
||||
case icon of
|
||||
Just (Word emoji) ->
|
||||
(class_ "callout callout-with-icon", div_ [class_ "callout-icon"] [text emoji])
|
||||
(class_ "callout callout-with-icon", div_ [class_ "callout-icon"] $ L.toHtml emoji)
|
||||
_ ->
|
||||
(class_ "callout", blank)
|
||||
in div_
|
||||
[cls]
|
||||
[ ico,
|
||||
div_
|
||||
[class_ "callout-content"]
|
||||
[currentSectionLevelToHtml content]
|
||||
]
|
||||
(class_ "callout", "")
|
||||
in div_ [cls] $ do
|
||||
ico
|
||||
div_ [class_ "callout-content"] $ currentSectionLevelToHtml content
|
||||
Table rows ->
|
||||
let cellToHtml d =
|
||||
td [] [currentSectionLevelToHtml d]
|
||||
let cellToHtml =
|
||||
td_ [] . currentSectionLevelToHtml
|
||||
|
||||
rowToHtml cells =
|
||||
tr [] (map cellToHtml (mergeWords cells))
|
||||
in table [] [tbody [] (map rowToHtml rows)]
|
||||
tr_ [] $ mapM_ cellToHtml $ mergeWords cells
|
||||
in table_ [] $ tbody_ [] $ mapM_ rowToHtml rows
|
||||
Folded isFolded summary details ->
|
||||
let content =
|
||||
if isFolded
|
||||
@ -248,112 +207,135 @@ toHtml document =
|
||||
[d] ->
|
||||
currentSectionLevelToHtml d
|
||||
ds ->
|
||||
span_ [class_ "span"] (map currentSectionLevelToHtml (mergeWords ds))
|
||||
span_ [class_ "span"] $ mapM_ currentSectionLevelToHtml $ mergeWords ds
|
||||
BulletedList items ->
|
||||
let itemToHtml d =
|
||||
li [] [currentSectionLevelToHtml d]
|
||||
in ul [] (map itemToHtml (mergeWords items))
|
||||
let itemToHtml =
|
||||
li_ [] . currentSectionLevelToHtml
|
||||
in ul_ [] $ mapM_ itemToHtml $ mergeWords items
|
||||
NumberedList startNum items ->
|
||||
let itemToHtml d =
|
||||
li [] [currentSectionLevelToHtml d]
|
||||
in ol [start startNum] (map itemToHtml (mergeWords items))
|
||||
let itemToHtml =
|
||||
li_ [] . currentSectionLevelToHtml
|
||||
in ol_ [start_ $ Text.pack $ show startNum] $ mapM_ itemToHtml $ mergeWords items
|
||||
Section title docs ->
|
||||
let -- Unison Doc allows endlessly deep section nesting with
|
||||
-- titles, but HTML only supports to h1-h6, so we clamp
|
||||
-- the sectionLevel when converting
|
||||
level =
|
||||
min 6 sectionLevel
|
||||
|
||||
titleEl =
|
||||
Html.element (Text.pack $ "h" ++ show level) [] [currentSectionLevelToHtml title]
|
||||
in section [] (titleEl : map (sectionContentToHtml (toHtml_ (sectionLevel + 1))) docs)
|
||||
NamedLink label href_ ->
|
||||
case normalizeHref InvalidHref href_ of
|
||||
let titleEl =
|
||||
h sectionLevel $ currentSectionLevelToHtml title
|
||||
in section_ [] $ sequence_ (titleEl : map (sectionContentToHtml (toHtml_ (sectionLevel + 1))) docs)
|
||||
NamedLink label href ->
|
||||
case normalizeHref InvalidHref href of
|
||||
Href h ->
|
||||
a [class_ "named-link", href h, rel "noopener", target "_blank"] [currentSectionLevelToHtml label]
|
||||
a_ [class_ "named-link", href_ h, rel_ "noopener", target_ "_blank"] $ currentSectionLevelToHtml label
|
||||
ReferenceHref ref ->
|
||||
a [class_ "named-link", data_ "ref" ref] [currentSectionLevelToHtml label]
|
||||
a_ [class_ "named-link", data_ "ref" ref] $ currentSectionLevelToHtml label
|
||||
InvalidHref ->
|
||||
span_ [class_ "named-link invalid-href"] [currentSectionLevelToHtml label]
|
||||
Image altText src_ caption ->
|
||||
span_ [class_ "named-link invalid-href"] $ currentSectionLevelToHtml label
|
||||
Image altText src caption ->
|
||||
let altAttr =
|
||||
case altText of
|
||||
Word t ->
|
||||
[alt t]
|
||||
[alt_ t]
|
||||
_ ->
|
||||
[]
|
||||
|
||||
image =
|
||||
case src_ of
|
||||
case src of
|
||||
Word s ->
|
||||
img (altAttr ++ [src s])
|
||||
img_ (altAttr ++ [src_ s ])
|
||||
_ ->
|
||||
blank
|
||||
""
|
||||
|
||||
imageWithCaption c =
|
||||
div_
|
||||
[class_ "image-with-caption"]
|
||||
[ image,
|
||||
div_ [class_ "caption"] [currentSectionLevelToHtml c]
|
||||
]
|
||||
[class_ "image-with-caption"] $ do
|
||||
image
|
||||
div_ [class_ "caption"] $ currentSectionLevelToHtml c
|
||||
in maybe image imageWithCaption caption
|
||||
Special specialForm ->
|
||||
case specialForm of
|
||||
Source sources ->
|
||||
div_
|
||||
[class_ "folded-sources"]
|
||||
(mapMaybe (fmap (foldedToHtmlSource False) . embeddedSource) sources)
|
||||
let
|
||||
sources' =
|
||||
mapMaybe
|
||||
(fmap (foldedToHtmlSource False) . embeddedSource)
|
||||
sources
|
||||
in
|
||||
div_ [class_ "folded-sources"] $ sequence_ sources'
|
||||
FoldedSource sources ->
|
||||
div_
|
||||
[class_ "folded-sources"]
|
||||
(mapMaybe (fmap (foldedToHtmlSource True) . embeddedSource) sources)
|
||||
let
|
||||
sources' =
|
||||
mapMaybe
|
||||
(fmap (foldedToHtmlSource True) . embeddedSource)
|
||||
sources
|
||||
in
|
||||
div_ [class_ "folded-sources"] $ sequence_ sources'
|
||||
Example syntax ->
|
||||
span_ [class_ "source rich example-inline"] [inlineCode [] (Syntax.toHtml syntax)]
|
||||
span_ [class_ "source rich example-inline"] $ inlineCode [] (Syntax.toHtml syntax)
|
||||
ExampleBlock syntax ->
|
||||
div_ [class_ "source rich example"] [codeBlock [] (Syntax.toHtml syntax)]
|
||||
div_ [class_ "source rich example"] $ codeBlock [] (Syntax.toHtml syntax)
|
||||
Link syntax ->
|
||||
inlineCode [class_ "rich source"] (Syntax.toHtml syntax)
|
||||
Signature signatures ->
|
||||
div_
|
||||
[class_ "rich source signatures"]
|
||||
( map
|
||||
(\sig -> div_ [class_ "signature"] [Syntax.toHtml sig])
|
||||
( mapM_
|
||||
(div_ [class_ "signature"] . Syntax.toHtml)
|
||||
signatures
|
||||
)
|
||||
SignatureInline sig ->
|
||||
span_ [class_ "rich source signature-inline"] [Syntax.toHtml sig]
|
||||
span_ [class_ "rich source signature-inline"] $ Syntax.toHtml sig
|
||||
Eval source result ->
|
||||
div_
|
||||
[class_ "source rich eval"]
|
||||
[codeBlock [] (div_ [] [Syntax.toHtml source, div_ [class_ "result"] [text "⧨", div_ [] [Syntax.toHtml result]]])]
|
||||
div_ [class_ "source rich eval"] $
|
||||
codeBlock [] $
|
||||
div_ [] $ do
|
||||
Syntax.toHtml source
|
||||
div_ [class_ "result"] $ do
|
||||
"⧨"
|
||||
div_ [] $ Syntax.toHtml result
|
||||
EvalInline source result ->
|
||||
span_
|
||||
[class_ "source rich eval-inline"]
|
||||
[inlineCode [] (span_ [] [Syntax.toHtml source, span_ [class_ "result"] [text "⧨", Syntax.toHtml result]])]
|
||||
span_ [class_ "source rich eval-inline"] $
|
||||
inlineCode [] $
|
||||
span_ [] $ do
|
||||
Syntax.toHtml source
|
||||
span_ [class_ "result"] $ do
|
||||
"⧨"
|
||||
Syntax.toHtml result
|
||||
Embed syntax ->
|
||||
div_ [class_ "source rich embed"] [codeBlock [] (Syntax.toHtml syntax)]
|
||||
div_ [class_ "source rich embed"] $ codeBlock [] (Syntax.toHtml syntax)
|
||||
EmbedInline syntax ->
|
||||
span_ [class_ "source rich embed-inline"] [inlineCode [] (Syntax.toHtml syntax)]
|
||||
span_ [class_ "source rich embed-inline"] $ inlineCode [] (Syntax.toHtml syntax)
|
||||
Join docs ->
|
||||
span_ [class_ "join"] (map currentSectionLevelToHtml (mergeWords docs))
|
||||
span_ [class_ "join"] (mapM_ currentSectionLevelToHtml (mergeWords docs))
|
||||
UntitledSection docs ->
|
||||
section [] (map (sectionContentToHtml currentSectionLevelToHtml) docs)
|
||||
section_ [] (mapM_ (sectionContentToHtml currentSectionLevelToHtml) docs)
|
||||
Column docs ->
|
||||
ul
|
||||
ul_
|
||||
[class_ "column"]
|
||||
( map
|
||||
(\c -> li [] [currentSectionLevelToHtml c])
|
||||
( mapM_
|
||||
(li_ [] . currentSectionLevelToHtml)
|
||||
(mergeWords docs)
|
||||
)
|
||||
Group content ->
|
||||
span_ [class_ "group"] [currentSectionLevelToHtml content]
|
||||
in article [class_ "unison-doc"] [toHtml_ 1 document]
|
||||
span_ [class_ "group"] $ currentSectionLevelToHtml content
|
||||
in article_ [class_ "unison-doc"] $ toHtml_ 1 document
|
||||
|
||||
-- HELPERS
|
||||
|
||||
badge :: Html -> Html
|
||||
badge content =
|
||||
span_ [class_ "badge"] [content]
|
||||
-- Unison Doc allows endlessly deep section nesting with
|
||||
-- titles, but HTML only supports to h1-h6, so we clamp
|
||||
-- the sectionLevel when converting
|
||||
h :: Nat -> (Html () -> Html ())
|
||||
h n =
|
||||
case n of
|
||||
1 -> h1_
|
||||
2 -> h2_
|
||||
3 -> h3_
|
||||
4 -> h4_
|
||||
5 -> h5_
|
||||
6 -> h6_
|
||||
_ -> h6_
|
||||
|
||||
badge :: Html () -> Html ()
|
||||
badge =
|
||||
span_ [class_ "badge"]
|
||||
|
||||
textToClass :: Text -> Text
|
||||
textToClass =
|
||||
|
||||
@ -1,199 +0,0 @@
|
||||
--
|
||||
-- This is a small Html combinator library for building up an Html document.
|
||||
-- There exists a few Haskell libraries like this, but we had a preference of
|
||||
-- an Elm-like API that did not exist.
|
||||
--
|
||||
-- Example:
|
||||
--
|
||||
-- toText $ (
|
||||
-- article
|
||||
-- []
|
||||
-- [ h1 [] [ text "Hello World" ]
|
||||
-- , p [] [ text "Really cool example!" ]
|
||||
-- ]
|
||||
-- )
|
||||
--
|
||||
-- Results in:
|
||||
--
|
||||
-- "<article><h1>Hello World</h1><p>Really cool example!</p></article>"
|
||||
--
|
||||
--
|
||||
-- It does not try to do anything fancy with which element is allowed as a
|
||||
-- child of which.
|
||||
--
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
|
||||
module Unison.Server.Html where
|
||||
|
||||
import qualified Data.List as List
|
||||
import Data.Text (Text)
|
||||
import Unison.Server.Html.Attribute (Attribute)
|
||||
import qualified Unison.Server.Html.Attribute as Attribute
|
||||
|
||||
data Html = Html Text [Attribute] Element
|
||||
|
||||
data Element
|
||||
= -- The "hidden" textNode that exists within an Element
|
||||
-- https://developer.mozilla.org/en-US/docs/Web/API/Text
|
||||
TextElement Text
|
||||
| -- Elements that can have children
|
||||
-- https://developer.mozilla.org/en-US/docs/Glossary/Element
|
||||
-- Examples: <div>hello world</div>
|
||||
Element [Html]
|
||||
| -- Elements without children. Sometimes called Empty Elements
|
||||
-- https://developer.mozilla.org/en-US/docs/Glossary/Empty_element
|
||||
-- Examples: <hr />, <br />, <img />
|
||||
VoidElement
|
||||
|
||||
-- Elements -------------------------------------------------------------------
|
||||
|
||||
element :: Text -> [Attribute] -> [Html] -> Html
|
||||
element tagName attrs inner = Html tagName attrs (Element inner)
|
||||
|
||||
voidElement :: Text -> [Attribute] -> Html
|
||||
voidElement tagName attrs = Html tagName attrs VoidElement
|
||||
|
||||
text :: Text -> Html
|
||||
text t = Html "text" [] (TextElement t)
|
||||
|
||||
blank :: Html
|
||||
blank =
|
||||
text ""
|
||||
|
||||
div_ :: [Attribute] -> [Html] -> Html
|
||||
div_ = element "div"
|
||||
|
||||
span_ :: [Attribute] -> [Html] -> Html
|
||||
span_ = element "span"
|
||||
|
||||
p :: [Attribute] -> [Html] -> Html
|
||||
p = element "p"
|
||||
|
||||
a :: [Attribute] -> [Html] -> Html
|
||||
a = element "a"
|
||||
|
||||
small :: [Attribute] -> [Html] -> Html
|
||||
small = element "small"
|
||||
|
||||
strong :: [Attribute] -> [Html] -> Html
|
||||
strong = element "strong"
|
||||
|
||||
em :: [Attribute] -> [Html] -> Html
|
||||
em = element "em"
|
||||
|
||||
label :: [Attribute] -> [Html] -> Html
|
||||
label = element "label"
|
||||
|
||||
img :: [Attribute] -> Html
|
||||
img = voidElement "img"
|
||||
|
||||
article :: [Attribute] -> [Html] -> Html
|
||||
article = element "article"
|
||||
|
||||
header :: [Attribute] -> [Html] -> Html
|
||||
header = element "header"
|
||||
|
||||
section :: [Attribute] -> [Html] -> Html
|
||||
section = element "section"
|
||||
|
||||
footer :: [Attribute] -> [Html] -> Html
|
||||
footer = element "footer"
|
||||
|
||||
h1 :: [Attribute] -> [Html] -> Html
|
||||
h1 = element "h1"
|
||||
|
||||
h2 :: [Attribute] -> [Html] -> Html
|
||||
h2 = element "h2"
|
||||
|
||||
h3 :: [Attribute] -> [Html] -> Html
|
||||
h3 = element "h3"
|
||||
|
||||
h4 :: [Attribute] -> [Html] -> Html
|
||||
h4 = element "h4"
|
||||
|
||||
h5 :: [Attribute] -> [Html] -> Html
|
||||
h5 = element "h5"
|
||||
|
||||
h6 :: [Attribute] -> [Html] -> Html
|
||||
h6 = element "h6"
|
||||
|
||||
ol :: [Attribute] -> [Html] -> Html
|
||||
ol = element "ol"
|
||||
|
||||
ul :: [Attribute] -> [Html] -> Html
|
||||
ul = element "ul"
|
||||
|
||||
li :: [Attribute] -> [Html] -> Html
|
||||
li = element "li"
|
||||
|
||||
details :: [Attribute] -> [Html] -> Html
|
||||
details = element "details"
|
||||
|
||||
summary :: [Attribute] -> [Html] -> Html
|
||||
summary = element "summary"
|
||||
|
||||
pre :: [Attribute] -> [Html] -> Html
|
||||
pre = element "pre"
|
||||
|
||||
code :: [Attribute] -> [Html] -> Html
|
||||
code = element "code"
|
||||
|
||||
table :: [Attribute] -> [Html] -> Html
|
||||
table = element "table"
|
||||
|
||||
thead :: [Attribute] -> [Html] -> Html
|
||||
thead = element "thead"
|
||||
|
||||
tbody :: [Attribute] -> [Html] -> Html
|
||||
tbody = element "tbody"
|
||||
|
||||
tfoot :: [Attribute] -> [Html] -> Html
|
||||
tfoot = element "tfoot"
|
||||
|
||||
tr :: [Attribute] -> [Html] -> Html
|
||||
tr = element "tr"
|
||||
|
||||
th :: [Attribute] -> [Html] -> Html
|
||||
th = element "th"
|
||||
|
||||
td :: [Attribute] -> [Html] -> Html
|
||||
td = element "td"
|
||||
|
||||
aside :: [Attribute] -> [Html] -> Html
|
||||
aside = element "aside"
|
||||
|
||||
blockquote :: [Attribute] -> [Html] -> Html
|
||||
blockquote = element "blockquote"
|
||||
|
||||
hr :: [Attribute] -> Html
|
||||
hr = voidElement "hr"
|
||||
|
||||
br :: [Attribute] -> Html
|
||||
br = voidElement "br"
|
||||
|
||||
-- Rendering ------------------------------------------------------------------
|
||||
|
||||
toText :: Html -> Text
|
||||
toText html =
|
||||
let openTag name attrs =
|
||||
let renderedAttrs =
|
||||
List.foldl (\acc attr -> acc <> " " <> Attribute.toText attr) "" attrs
|
||||
in "<" <> name <> renderedAttrs <> ">"
|
||||
|
||||
selfClosingTag name attrs =
|
||||
let renderedAttrs =
|
||||
List.foldl (\acc attr -> acc <> " " <> Attribute.toText attr) "" attrs
|
||||
in "<" <> name <> renderedAttrs <> " />"
|
||||
|
||||
closeTag name =
|
||||
"</" <> name <> ">"
|
||||
|
||||
renderChildren children =
|
||||
List.foldl (\acc c -> acc <> toText c) "" children
|
||||
in case html of
|
||||
Html _ _ (TextElement t) ->
|
||||
t
|
||||
Html tagName attrs VoidElement ->
|
||||
selfClosingTag tagName attrs
|
||||
Html tagName attrs (Element children) ->
|
||||
openTag tagName attrs <> renderChildren children <> closeTag tagName
|
||||
@ -1,55 +0,0 @@
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
|
||||
module Unison.Server.Html.Attribute where
|
||||
|
||||
import Data.Text (Text)
|
||||
import qualified Data.Text as Text
|
||||
import Data.Word
|
||||
|
||||
type Nat = Word64
|
||||
|
||||
data Attribute = Attribute Text Text
|
||||
|
||||
-- Attributes -----------------------------------------------------------------
|
||||
|
||||
data_ :: Text -> Text -> Attribute
|
||||
data_ name = Attribute ("data-" <> name)
|
||||
|
||||
class_ :: Text -> Attribute
|
||||
class_ = Attribute "class"
|
||||
|
||||
style :: Text -> Attribute
|
||||
style = Attribute "style"
|
||||
|
||||
id_ :: Text -> Attribute
|
||||
id_ = Attribute "id"
|
||||
|
||||
title :: Text -> Attribute
|
||||
title = Attribute "title"
|
||||
|
||||
src :: Text -> Attribute
|
||||
src = Attribute "src"
|
||||
|
||||
href :: Text -> Attribute
|
||||
href = Attribute "href"
|
||||
|
||||
rel :: Text -> Attribute
|
||||
rel = Attribute "rel"
|
||||
|
||||
start :: Nat -> Attribute
|
||||
start n = Attribute "start" (Text.pack $ show n)
|
||||
|
||||
target :: Text -> Attribute
|
||||
target = Attribute "target"
|
||||
|
||||
alt :: Text -> Attribute
|
||||
alt = Attribute "alt"
|
||||
|
||||
open :: Attribute
|
||||
open = Attribute "open" "open"
|
||||
|
||||
-- Rendering ------------------------------------------------------------------
|
||||
|
||||
toText :: Attribute -> Text
|
||||
toText (Attribute attrName attrValue) =
|
||||
attrName <> "='" <> attrValue <> "'"
|
||||
@ -25,8 +25,8 @@ import Unison.Prelude
|
||||
import Unison.Reference (Reference)
|
||||
import qualified Unison.Reference as Reference
|
||||
import qualified Unison.Referent as Referent
|
||||
import Unison.Server.Html (Html, span_, text)
|
||||
import Unison.Server.Html.Attribute (class_, data_)
|
||||
import Lucid
|
||||
import qualified Lucid as L
|
||||
import Unison.Util.AnnotatedText
|
||||
( AnnotatedText (..),
|
||||
Segment (..),
|
||||
@ -164,19 +164,29 @@ toPlain (AnnotatedText at) = join (toList $ segment <$> at)
|
||||
|
||||
-- HTML -----------------------------------------------------------------------
|
||||
|
||||
toHtml :: SyntaxText -> Html
|
||||
toHtml :: SyntaxText -> Html ()
|
||||
toHtml (AnnotatedText segments) =
|
||||
let renderedSegments =
|
||||
fmap segmentToHtml segments
|
||||
in span_ [class_ "syntax"] (toList renderedSegments)
|
||||
in span_ [class_ "syntax"] $ sequence_ (toList renderedSegments)
|
||||
|
||||
nameToHtml :: Name -> Html
|
||||
nameToHtml =
|
||||
span_ [class_ "fqn"] . List.intersperse (span_ [class_ "sep"] [text "."])
|
||||
. map ((\s -> span_ [class_ "segment"] [text s]) . NameSegment.toText)
|
||||
. Name.segments
|
||||
nameToHtml :: Name -> Html ()
|
||||
nameToHtml name =
|
||||
span_ [class_ "fqn"] $ sequence_ parts
|
||||
where
|
||||
segments =
|
||||
map (segment . L.toHtml . NameSegment.toText) $ Name.segments name
|
||||
|
||||
segmentToHtml :: SyntaxSegment -> Html
|
||||
segment =
|
||||
span_ [class_ "segment"]
|
||||
|
||||
sep =
|
||||
span_ [ class_ "sep "] "."
|
||||
|
||||
parts =
|
||||
List.intersperse sep segments
|
||||
|
||||
segmentToHtml :: SyntaxSegment -> Html ()
|
||||
segmentToHtml (Segment segmentText element) =
|
||||
let sText = Text.pack segmentText
|
||||
|
||||
@ -216,14 +226,14 @@ segmentToHtml (Segment segmentText element) =
|
||||
elementToClassName el
|
||||
|
||||
content
|
||||
| Text.isInfixOf "->" sText = span_ [class_ "arrow"] [text sText]
|
||||
| Text.isInfixOf "->" sText = span_ [class_ "arrow"] $ L.toHtml sText
|
||||
| isFQN = nameToHtml (Name.unsafeFromText sText)
|
||||
| otherwise = text sText
|
||||
| otherwise = L.toHtml sText
|
||||
in case ref of
|
||||
Just r ->
|
||||
span_ [class_ className, data_ "ref" r] [content]
|
||||
span_ [class_ className, data_ "ref" r] content
|
||||
_ ->
|
||||
span_ [class_ className] [content]
|
||||
span_ [class_ className] content
|
||||
|
||||
elementToClassName :: Element -> Text
|
||||
elementToClassName el =
|
||||
|
||||
@ -152,8 +152,6 @@ library
|
||||
Unison.Server.Endpoints.NamespaceDetails
|
||||
Unison.Server.Endpoints.NamespaceListing
|
||||
Unison.Server.Errors
|
||||
Unison.Server.Html
|
||||
Unison.Server.Html.Attribute
|
||||
Unison.Server.QueryResult
|
||||
Unison.Server.SearchResult
|
||||
Unison.Server.SearchResult'
|
||||
@ -252,6 +250,7 @@ library
|
||||
, http-media
|
||||
, http-types
|
||||
, lens
|
||||
, lucid
|
||||
, megaparsec >=5.0.0 && <7.0.0
|
||||
, memory
|
||||
, mmorph
|
||||
|
||||
Loading…
Reference in New Issue
Block a user