Added some slight modifications so it is inside the DocGen4 instead of
the Lean4.Widget namespace.
main
Henrik Böving 2021-12-10 14:30:39 +01:00
parent 77cb52e9cb
commit 11de4f7f55
2 changed files with 91 additions and 0 deletions

View File

@ -6,3 +6,4 @@ Authors: Henrik Böving
import DocGen4.Process import DocGen4.Process
import DocGen4.Load import DocGen4.Load
import DocGen4.ToHtmlFormat

90
DocGen4/ToHtmlFormat.lean Normal file
View File

@ -0,0 +1,90 @@
/-
Copyright (c) 2021 Wojciech Nawrocki. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Wojciech Nawrocki, Sebastian Ullrich, Henrik Böving
-/
import Lean.Data.Json
import Lean.Parser
/-! This module defines:
- a representation of HTML trees
- together with a JSX-like DSL for writing them
- and widget support for visualizing any type as HTML. -/
namespace DocGen4
open Lean
inductive Html where
-- TODO(WN): it's nameless for shorter JSON; re-add names when we have deriving strategies for From/ToJson
-- element (tag : String) (attrs : Array HtmlAttribute) (children : Array Html)
| element : String → Array (String × String) → Array Html → Html
| text : String → Html
deriving Repr, BEq, Inhabited, FromJson, ToJson
instance : Coe String Html :=
⟨Html.text⟩
namespace Jsx
open Parser PrettyPrinter
declare_syntax_cat jsxElement
declare_syntax_cat jsxChild
def jsxAttrVal : Parser := strLit <|> group ("{" >> termParser >> "}")
def jsxAttr : Parser := ident >> "=" >> jsxAttrVal
-- JSXTextCharacter : SourceCharacter but not one of {, <, > or }
def jsxText : Parser :=
withAntiquot (mkAntiquot "jsxText" `jsxText) {
fn := fun c s =>
let startPos := s.pos
let s := takeWhile1Fn (not ∘ "{<>}$".contains) "expected JSX text" c s
mkNodeToken `jsxText startPos c s }
@[combinatorFormatter DocGen4.Jsx.jsxText] def jsxText.formatter : Formatter := pure ()
@[combinatorParenthesizer DocGen4.Jsx.jsxText] def jsxText.parenthesizer : Parenthesizer := pure ()
scoped syntax "<" ident jsxAttr* "/>" : jsxElement
scoped syntax "<" ident jsxAttr* ">" jsxChild* "</" ident ">" : jsxElement
scoped syntax jsxText : jsxChild
scoped syntax "{" term "}" : jsxChild
scoped syntax jsxElement : jsxChild
scoped syntax:max jsxElement : term
macro_rules
| `(<$n $[$ns = $vs]* />) =>
let ns := ns.map (quote <| toString ·.getId)
let vs := vs.map fun
| `(jsxAttrVal| $s:strLit) => s
| `(jsxAttrVal| { $t:term }) => t
| _ => unreachable!
`(Html.element $(quote <| toString n.getId) #[ $[($ns, $vs)],* ] #[])
| `(<$n $[$ns = $vs]* >$cs*</$m>) =>
if n.getId == m.getId then do
let ns := ns.map (quote <| toString ·.getId)
let vs := vs.map fun
| `(jsxAttrVal| $s:strLit) => s
| `(jsxAttrVal| { $t:term }) => t
| _ => unreachable!
let cs ← cs.mapM fun
| `(jsxChild|$t:jsxText) => `(Html.text $(quote t[0].getAtomVal!))
-- TODO(WN): elab as list of children if type is `t Html` where `Foldable t`
| `(jsxChild|{$t}) => t
| `(jsxChild|$e:jsxElement) => `($e:jsxElement)
| _ => unreachable!
let tag := toString n.getId
`(Html.element $(quote tag) #[ $[($ns, $vs)],* ] #[ $[$cs],* ])
else Macro.throwError ("expected </" ++ toString n.getId ++ ">")
end Jsx
/-- A type which implements `ToHtmlFormat` will be visualized
as the resulting HTML in editors which support it. -/
class ToHtmlFormat (α : Type u) where
formatHtml : α → Html
end DocGen4