""")
# Write raw, *escaped* text so it appears exactly as typed
diff --git a/docs/_static/style.css b/docs/_static/style.css
index 0c9048e5..b4409ba8 100644
--- a/docs/_static/style.css
+++ b/docs/_static/style.css
@@ -1,16 +1,3 @@
-.right-panel1.active_panel, .right-panel2.active_panel {
- z-index: 1;
-}
-.right-panel1, .right-panel2 {
- z-index: 0;
- width:100%;
- position:absolute;
- top:0;
- bottom:0;
- left:0;
- right:0;
- border:0;
-}
.preview {
position: relative;
@@ -64,7 +51,9 @@
.entry.show-presentation .preview,
.entry.show-editor .editor,
.entry.show-both .preview,
-.entry.show-both .editor {
+.entry.show-both .editor,
+.entry.show-warnings .editor,
+.entry.show-warnings .errors-el {
opacity: 1;
position: relative;
pointer-events: all;
@@ -72,7 +61,8 @@
.show-editor > .tabs > .editor-button,
.show-presentation > .tabs > .pres-button,
-.show-both > .tabs > .both-button {
+.show-both > .tabs > .both-button,
+.show-warnings > .tabs > .warnings-button {
background: aliceblue;
}
.running-example.fullscreen {
diff --git a/docs/doc-repl/main.ml b/docs/doc-repl/main.ml
index 3a4c46f1..db2b3ff9 100644
--- a/docs/doc-repl/main.ml
+++ b/docs/doc-repl/main.ml
@@ -1,6 +1,6 @@
open Code_mirror
-let view ~dimension ~preview_el ~editor_el starting =
+let view ~dimension ~preview_el ~errors_el ~editor_el starting =
let open Editor in
let basic_setup = Jv.get Jv.global "__CM__basic_setup" |> Extension.of_jv in
let dark_mode =
@@ -14,6 +14,7 @@ let view ~dimension ~preview_el ~editor_el starting =
let frontmatter =
(Resolved
{
+ external_ids = [];
toplevel_attributes = None;
math_link = None;
theme = None;
@@ -32,7 +33,8 @@ let view ~dimension ~preview_el ~editor_el starting =
basic_setup;
markdown_extension;
dark_mode;
- Slipshow_communication.slipshow_plugin ~frontmatter preview_el;
+ Slipshow_communication.slipshow_plugin ~frontmatter ~errors_el
+ preview_el;
|]
()
in
@@ -42,74 +44,83 @@ let view ~dimension ~preview_el ~editor_el starting =
let ( !! ) = Jstr.v
-let do_ ~dimension ~editor_el ~preview_el starting =
- let _view = view ~dimension ~preview_el ~editor_el starting in
+let do_ ~dimension ~editor_el ~preview_el ~errors_el starting =
+ let _view : Editor.View.t =
+ view ~dimension ~preview_el ~errors_el ~editor_el starting
+ in
()
type mode = Show_editor | Show_presentation | Show_both
let all_modes = [ Show_both; Show_editor; Show_presentation ]
+let handle_elem =
+ fun el () ->
+ let open Brr in
+ let dimension =
+ El.at !!"dimension" el |> Option.map Jstr.to_string |> fun x ->
+ Option.bind x (fun s ->
+ match Slipshow.Frontmatter.Dimension.of_string s with
+ | Ok x -> Some x
+ | Error _ -> None)
+ in
+ let ffbs_unsafe c = El.find_first_by_selector ~root:el !!c |> Option.get in
+ let content =
+ let source = ffbs_unsafe ".source" in
+ Jv.get (Brr.El.to_jv source) "textContent" |> Jv.to_string
+ in
+ let editor_el = ffbs_unsafe ".editor" in
+ let errors_el = ffbs_unsafe ".errors-el" in
+ let preview_el = ffbs_unsafe ".preview" in
+ let editor_button = ffbs_unsafe ".editor-button" in
+ let pres_button = ffbs_unsafe ".pres-button" in
+ let both_button = ffbs_unsafe ".both-button" in
+ let fullscreen_button = ffbs_unsafe ".fullscreen-button" in
+ let () =
+ let fullscreen = ref false in
+ Ev.(listen click)
+ (fun _ ->
+ fullscreen := not !fullscreen;
+ El.set_class !!"fullscreen" !fullscreen el)
+ (El.as_target fullscreen_button)
+ |> ignore
+ in
+ let new_el = ffbs_unsafe ".entry" in
+ (* See also the python file _ext/slipshowexample.py *)
+ let mode_to_string = function
+ | Show_editor -> Jstr.v "show-editor"
+ | Show_presentation -> Jstr.v "show-presentation"
+ | Show_both -> Jstr.v "show-both"
+ in
+ let () =
+ let set_class v =
+ let set v b = El.set_class (mode_to_string v) b new_el in
+ List.iter (fun m -> set m false) all_modes;
+ set v true
+ in
+ let listen v el =
+ Ev.(listen click) (fun _ -> set_class v) (El.as_target el) |> ignore
+ in
+ listen Show_editor editor_button;
+ listen Show_presentation pres_button;
+ listen Show_both both_button
+ in
+ do_ ~dimension ~preview_el ~editor_el ~errors_el content
+
let () =
let _ =
Brr.Ev.listen Brr.Ev.load
(fun _ ->
+ let () =
+ match Brr.El.find_first_by_selector !!".running-example" with
+ | None -> ()
+ | Some _ ->
+ Brr.El.append_children
+ (Brr.Document.body Brr.G.document)
+ [ Brr.El.style [ Brr.El.txt' Ansi.css ] ]
+ in
let _ =
- Brr.El.fold_find_by_selector
- (fun el () ->
- let open Brr in
- let dimension =
- El.at !!"dimension" el |> Option.map Jstr.to_string |> fun x ->
- Option.bind x (fun s ->
- match Slipshow.Frontmatter.String_to.dimension s with
- | Ok x -> Some x
- | Error _ -> None)
- in
- let ffbs_unsafe c =
- El.find_first_by_selector ~root:el !!c |> Option.get
- in
- let content =
- let source = ffbs_unsafe ".source" in
- Jv.get (Brr.El.to_jv source) "textContent" |> Jv.to_string
- in
- let editor_el = ffbs_unsafe ".editor" in
- let preview_el = ffbs_unsafe ".preview" in
- let editor_button = ffbs_unsafe ".editor-button" in
- let pres_button = ffbs_unsafe ".pres-button" in
- let both_button = ffbs_unsafe ".both-button" in
- let fullscreen_button = ffbs_unsafe ".fullscreen-button" in
- let () =
- let fullscreen = ref false in
- Ev.(listen click)
- (fun _ ->
- fullscreen := not !fullscreen;
- El.set_class !!"fullscreen" !fullscreen el)
- (El.as_target fullscreen_button)
- |> ignore
- in
- let new_el = ffbs_unsafe ".entry" in
- (* See also the python file _ext/slipshowexample.py *)
- let mode_to_string = function
- | Show_editor -> Jstr.v "show-editor"
- | Show_presentation -> Jstr.v "show-presentation"
- | Show_both -> Jstr.v "show-both"
- in
- let () =
- let set_class v =
- let set v b = El.set_class (mode_to_string v) b new_el in
- List.iter (fun m -> set m false) all_modes;
- set v true
- in
- let listen v el =
- Ev.(listen click) (fun _ -> set_class v) (El.as_target el)
- |> ignore
- in
- listen Show_editor editor_button;
- listen Show_presentation pres_button;
- listen Show_both both_button
- in
- do_ ~dimension ~preview_el ~editor_el content)
- !!".running-example" ()
+ Brr.El.fold_find_by_selector handle_elem !!".running-example" ()
in
())
(Brr.Window.as_target Brr.G.window)
diff --git a/docs/frontmatter.rst b/docs/frontmatter.rst
index f22c3992..0e111214 100644
--- a/docs/frontmatter.rst
+++ b/docs/frontmatter.rst
@@ -40,3 +40,8 @@ The current options for the frontmatter are:
a theme, corresponding to the name of a file in `this list
`_,
stripped from its extension.
+
+- ``external-ids``, for telling the slipshow compiler which ``ids`` will be
+ present even if they do not seem to be present in the document. This is just
+ in order to silence some warnings. This is useful when including svgs or math
+ where some IDs are given.
diff --git a/docs/manim.rst b/docs/manim.rst
index d711f96b..cc4c04dc 100644
--- a/docs/manim.rst
+++ b/docs/manim.rst
@@ -121,18 +121,12 @@ single video. We'll simply put them in a carousel.
.. slipshow-example::
:visible: presentation
-
-
+ {carousel .carousel-fixed-size #c}
+ > {#v1 video width=100%}
+ >
+ > {#v2 width=100% video}
+ >
+ > {#v3 width=100% video}
{focus=c}
diff --git a/docs/math.rst b/docs/math.rst
index 6e0ddf63..332629dd 100644
--- a/docs/math.rst
+++ b/docs/math.rst
@@ -73,10 +73,17 @@ respectively assign an identifier, and a class.
This allows to easily make them target of actions. For instance, one can use the ``pause`` action with a target to reveal content bit by bit. The ``reveal`` action and ``unrevealed`` class are also useful.
+Remember to use the ``external-ids`` field of the frontmatter to tell the
+compiler not to warn you that it cannot find the given ids.
+
.. slipshow-example::
:visible: both
:dimension: 4:3
+ ---
+ external-ids: pause1 pause2
+ ---
+
# Some title to make it more realistic
```math
diff --git a/docs/tikz.rst b/docs/tikz.rst
index a0922ccf..b251dbc4 100644
--- a/docs/tikz.rst
+++ b/docs/tikz.rst
@@ -105,6 +105,7 @@ dynamics with actions:
---
toplevel-attributes: slip enter=~duration:0 unreveal="c c-edges"
+ external-ids: c c-edges
---
{style="width:75%"}
@@ -113,7 +114,8 @@ dynamics with actions:
{reveal=c-edges}
-Here is the final result!
+The ``external-ids`` field of the frontmatter tells the compiler not to warn you
+that it cannot find the given ids. Here is the final result!
.. slipshow-example::
:visible: presentation
@@ -121,6 +123,7 @@ Here is the final result!
---
toplevel-attributes: slip enter=~duration:0 unreveal="c c-edges"
+ external-ids: c c-edges
---
diff --git a/dune-project b/dune-project
index 9167ca94..5a565079 100644
--- a/dune-project
+++ b/dune-project
@@ -24,6 +24,7 @@
(depends
(ocaml (>= 4.14))
dune
+ (grace (>= 0.3.0))
(crunch :with-dev-setup)
(lambdasoup :with-test)
(cmdliner (>= 1.3.0))
@@ -45,6 +46,7 @@
sexplib
ppx_sexp_conv
ppx_deriving_yojson
+ (ansi (>= 0.7.0))
(odoc :with-doc)
(ocamlformat
(and :with-dev-setup (= 0.27.0))))
diff --git a/example/funocaml-2025/main.md b/example/funocaml-2025/main.md
index 55890715..6dccec3c 100644
--- a/example/funocaml-2025/main.md
+++ b/example/funocaml-2025/main.md
@@ -15,7 +15,7 @@ dimension: 16:9
> {slip #part1 style="width:49%; height:" speaker-note=initial-sn}
> {include src="slipshow.md"}
>
-> {pause clear=draw-links reveal=surrprise}
+> {pause reveal=surrprise}
>
> {slip #my-part2 style="width:49%"}
> {include src="three-simple-steps.md"}
diff --git a/example/funocaml-2025/slipshow.md b/example/funocaml-2025/slipshow.md
index c3eae331..dbddea55 100644
--- a/example/funocaml-2025/slipshow.md
+++ b/example/funocaml-2025/slipshow.md
@@ -599,7 +599,7 @@ Say: "Slipshow has support for videos"
}
-{#video-demo .addons .block external}
+{#video-demo .addons .block}
> {style=width:100% #videoelem}
{play-media=videoelem}
diff --git a/slipshow.opam b/slipshow.opam
index b1c98dee..7a178f24 100644
--- a/slipshow.opam
+++ b/slipshow.opam
@@ -13,6 +13,7 @@ bug-reports: "https://github.com/panglesd/slipshow/issues"
depends: [
"ocaml" {>= "4.14"}
"dune" {>= "3.6"}
+ "grace" {>= "0.3.0"}
"crunch" {with-dev-setup}
"lambdasoup" {with-test}
"cmdliner" {>= "1.3.0"}
@@ -34,6 +35,7 @@ depends: [
"sexplib"
"ppx_sexp_conv"
"ppx_deriving_yojson"
+ "ansi" {>= "0.7.0"}
"odoc" {with-doc}
"ocamlformat" {with-dev-setup & = "0.27.0"}
]
diff --git a/src/actions-arguments/actions_arguments.ml b/src/actions-arguments/actions_arguments.ml
new file mode 100644
index 00000000..546b7ec9
--- /dev/null
+++ b/src/actions-arguments/actions_arguments.ml
@@ -0,0 +1,384 @@
+module W = Warnings
+
+type id_or_self = [ `Self | `Id of string W.node ]
+type ids_or_self = [ `Self | `Ids of string W.node list ]
+
+module type S = sig
+ type args
+
+ val on : string
+ val action_name : string
+ val parse_args : string -> (args W.t, [> `Msg of string ]) result
+end
+
+module Pause = struct
+ let on = "pause"
+ let action_name = "pause"
+
+ type args = [ `Self | `Ids of string W.node list ]
+
+ let parse_args = Parse.parse_only_els ~action_name
+end
+
+module _ : S = Pause
+
+module type Move = sig
+ type args = {
+ margin : float option;
+ duration : float option;
+ target : id_or_self;
+ }
+
+ include S with type args := args
+end
+
+module Move (X : sig
+ val on : string
+ val action_name : string
+end) : Move = struct
+ let on = X.on
+ let action_name = X.action_name
+
+ type args = {
+ margin : float option;
+ duration : float option;
+ target : id_or_self;
+ }
+
+ let parse_args s =
+ let ( let+ ) x f = Result.map f x in
+ let open W.M in
+ let+ x =
+ Parse.parse ~action_name
+ ~named:[ Parse.duration; Parse.margin ]
+ ~positional:Parse.id s
+ in
+ let$ x = x in
+ let$ res = Parse.require_single_action ~action_name:X.action_name x in
+ match res with
+ | { p_named = [ duration; margin ]; p_pos = positional }, _ -> (
+ let$+ res =
+ Parse.require_single_positional ~action_name:X.action_name positional
+ in
+ match res with
+ | None -> { target = `Self; duration; margin }
+ | Some positional -> { target = `Id positional; duration; margin })
+end
+
+module Up = Move (struct
+ let on = "up-at-unpause"
+ let action_name = "up"
+end)
+
+module _ : S = Up
+
+module Down = Move (struct
+ let on = "down-at-unpause"
+ let action_name = "down"
+end)
+
+module _ : S = Down
+
+module Center = Move (struct
+ let on = "center-at-unpause"
+ let action_name = "center"
+end)
+
+module _ : S = Center
+
+module Scroll = Move (struct
+ let on = "scroll-at-unpause"
+ let action_name = "scroll"
+end)
+
+module _ : S = Scroll
+
+module Enter = Move (struct
+ let on = "enter-at-unpause"
+ let action_name = "enter"
+end)
+
+module _ : S = Enter
+
+module type SetClass = S with type args = ids_or_self
+
+module SetClass (X : sig
+ val on : string
+ val action_name : string
+end) : SetClass = struct
+ let on = X.on
+ let action_name = X.action_name
+
+ type args = ids_or_self
+
+ let parse_args = Parse.parse_only_els ~action_name
+end
+
+module Unstatic = SetClass (struct
+ let on = "unstatic-at-unpause"
+ let action_name = "unstatic"
+end)
+
+module _ : S = Unstatic
+
+module Static = SetClass (struct
+ let on = "static-at-unpause"
+ let action_name = "static"
+end)
+
+module _ : S = Static
+
+module Reveal = SetClass (struct
+ let on = "reveal-at-unpause"
+ let action_name = "reveal"
+end)
+
+module _ : S = Reveal
+
+module Unreveal = SetClass (struct
+ let on = "unreveal-at-unpause"
+ let action_name = "unreveal"
+end)
+
+module _ : S = Unreveal
+
+module Emph = SetClass (struct
+ let on = "emph-at-unpause"
+ let action_name = "emph"
+end)
+
+module _ : S = Emph
+
+module Unemph = SetClass (struct
+ let on = "unemph-at-unpause"
+ let action_name = "unemph"
+end)
+
+module _ : S = Unemph
+
+module Step = struct
+ type args = unit
+
+ let on = "step"
+ let action_name = on
+ let parse_args s = Parse.no_args ~action_name s
+end
+
+module _ : S = Step
+
+module Focus = struct
+ type args = {
+ margin : float option;
+ duration : float option;
+ target : ids_or_self;
+ }
+
+ let on = "focus-at-unpause"
+ let action_name = "focus"
+
+ let parse_args s =
+ let ( let+ ) = Fun.flip Result.map in
+ let+ x =
+ Parse.parse ~action_name
+ ~named:[ Parse.duration; Parse.margin ]
+ ~positional:Parse.id s
+ in
+ let open W.M in
+ let$ x = x in
+ let$+ res = Parse.require_single_action ~action_name x in
+ match res with
+ | { p_named = [ duration; margin ]; p_pos = [] }, _loc ->
+ { target = `Self; duration; margin }
+ | { p_named = [ duration; margin ]; p_pos = positional }, _loc ->
+ let target = `Ids positional in
+ { target; duration; margin }
+end
+
+module _ : S = Focus
+
+module Unfocus = struct
+ type args = unit
+
+ let on = "unfocus-at-unpause"
+ let action_name = "unfocus"
+ let parse_args s = Parse.no_args ~action_name s
+end
+
+module _ : S = Unfocus
+
+module Speaker_note = struct
+ let on = "speaker-note"
+ let action_name = on
+
+ type args = id_or_self
+
+ let parse_args = Parse.parse_only_el ~action_name
+end
+
+module _ : S = Speaker_note
+
+module Play_media = struct
+ let on = "play-media"
+ let action_name = "play-media"
+
+ type args = ids_or_self
+
+ let parse_args = Parse.parse_only_els ~action_name
+end
+
+module _ : S = Play_media
+
+module Change_page = struct
+ type change = Absolute of int | Relative of int | All | Range of int * int
+ type arg = { target : id_or_self; n : change list }
+ type args = arg list
+
+ let on = "change-page"
+ let action_name = "change-page"
+ let ( let+ ) x f = Result.map f x
+ let ( let* ) x f = Result.bind x f
+
+ let parse_change (s, loc) =
+ if String.equal "all" s then Some All
+ else
+ match int_of_string_opt s with
+ | None -> (
+ match String.split_on_char '-' s with
+ | [ a; b ] -> (
+ match (int_of_string_opt a, int_of_string_opt b) with
+ | Some a, Some b -> Some (Range (a, b))
+ | _ ->
+ let msg = "Could not parse parameter" in
+ W.add (W.Parsing_failure { msg; loc });
+ None)
+ | _ ->
+ let msg = "Could not parse parameter" in
+ W.add (W.Parsing_failure { msg; loc });
+ None)
+ | Some x -> (
+ match s.[0] with
+ | '+' | '-' -> Some (Relative x)
+ | _ -> Some (Absolute x))
+
+ let parse_single_action
+ { Parse.p_named = ([ n_opt ] : _ Parse.output_tuple); p_pos = elem_ids } =
+ let n = Option.value ~default:[ Relative 1 ] n_opt in
+ let open W.M in
+ let$+ id_or_self =
+ match elem_ids with
+ | [] -> (`Self, [])
+ | [ id ] -> (`Id id, [])
+ | ((_, loc) as id) :: rest ->
+ let loc = W.range loc rest in
+ let msg = "Expected single id. Considering only the first one." in
+ let w = W.Parsing_failure { msg; loc } in
+ (`Id id, [ w ])
+ in
+ { n; target = id_or_self }
+
+ let parse_n (s, (loc_min, _)) =
+ let l =
+ String.split_on_char ' ' s
+ |> List.fold_left
+ (fun (acc, idx) x ->
+ let l = String.length x in
+ if l = 0 then (acc, idx + 1)
+ else ((x, (idx, idx + l)) :: acc, idx + l + 1))
+ ([], loc_min)
+ |> fun (x, _) -> List.rev x
+ in
+ l |> List.filter_map parse_change |> Result.ok
+
+ let parse_args s =
+ let open W.M in
+ let+ res =
+ Parse.parse ~action_name ~named:[ ("n", parse_n) ] ~positional:Fun.id s
+ in
+ let$ ac, actions = res in
+ let actions = ac :: actions in
+ let warnings, res =
+ List.fold_left_map
+ (fun acc (action, _loc) ->
+ let res, w = parse_single_action action in
+ (w :: acc, res))
+ [] actions
+ in
+ (res, List.concat warnings)
+
+ let args_as_string args =
+ let arg_to_string { n; target } =
+ let to_string = function
+ | All -> "all"
+ | Relative x when x < 0 -> string_of_int x
+ | Relative x -> "+" ^ string_of_int x
+ | Absolute x -> string_of_int x
+ | Range (x, y) -> string_of_int x ^ "-" ^ string_of_int y
+ in
+ let s = n |> List.map to_string |> String.concat " " in
+ let n = "~n:\"" ^ s ^ "\"" in
+ let original_id =
+ match target with `Self -> "" | `Id (s, _) -> " " ^ s
+ in
+ n ^ original_id
+ in
+ args |> List.map arg_to_string |> String.concat " ; "
+end
+
+module _ : S = Change_page
+
+module Draw = struct
+ let on = "draw"
+ let action_name = on
+
+ type args = ids_or_self
+
+ let parse_args = Parse.parse_only_els ~action_name
+end
+
+module _ : S = Draw
+
+module Clear_draw = struct
+ let on = "clear"
+ let action_name = on
+
+ type args = ids_or_self
+
+ let parse_args = Parse.parse_only_els ~action_name
+end
+
+module _ : S = Clear_draw
+
+module Execute = struct
+ type args = ids_or_self
+
+ let on = "exec-at-unpause"
+ let action_name = "exec"
+ let parse_args = Parse.parse_only_els ~action_name
+end
+
+module _ : S = Execute
+
+let all_actions =
+ [
+ (module Enter : S);
+ (module Clear_draw : S);
+ (module Draw : S);
+ (module Pause : S);
+ (module Step : S);
+ (module Up : S);
+ (module Down : S);
+ (module Center : S);
+ (module Scroll : S);
+ (module Change_page : S);
+ (module Focus : S);
+ (module Unfocus : S);
+ (module Execute : S);
+ (module Unstatic : S);
+ (module Static : S);
+ (module Reveal : S);
+ (module Unreveal : S);
+ (module Emph : S);
+ (module Unemph : S);
+ (module Speaker_note : S);
+ (module Play_media : S);
+ ]
diff --git a/src/actions-arguments/dune b/src/actions-arguments/dune
new file mode 100644
index 00000000..cce0eaec
--- /dev/null
+++ b/src/actions-arguments/dune
@@ -0,0 +1,6 @@
+(library
+ (name actions_arguments)
+ (public_name slipshow.actions_arguments)
+ (libraries logs))
+
+; TODO: remove logs and output warnings
diff --git a/src/actions-arguments/parse.ml b/src/actions-arguments/parse.ml
new file mode 100644
index 00000000..a50c3646
--- /dev/null
+++ b/src/actions-arguments/parse.ml
@@ -0,0 +1,350 @@
+module W = Warnings
+
+type 'a node = 'a W.node
+
+let parse_string s =
+ let is_ws idx = match s.[idx] with '\n' | ' ' -> true | _ -> false in
+ let is_alpha idx =
+ let c = s.[idx] in
+ ('a' <= c && c <= 'z')
+ || ('A' <= c && c <= 'Z')
+ || ('0' <= c && c <= '9')
+ || c = '_'
+ in
+ let rec consume_ws idx =
+ if idx >= String.length s then idx
+ else if is_ws idx then consume_ws (idx + 1)
+ else idx
+ in
+ let rec consume_non_ws idx =
+ if idx >= String.length s then idx
+ else if not (is_ws idx) then consume_non_ws (idx + 1)
+ else idx
+ in
+ let rec consume_alpha idx =
+ if idx >= String.length s then idx
+ else if is_alpha idx then consume_alpha (idx + 1)
+ else idx
+ in
+ let quoted_string idx0 =
+ let rec take_inside_quoted_string acc idx =
+ match s.[idx] with
+ | '"' ->
+ ( (acc |> List.rev |> List.to_seq |> String.of_seq, (idx0, idx - 1)),
+ idx + 1 )
+ | '\\' -> take_inside_quoted_string (s.[idx + 1] :: acc) (idx + 2)
+ | _ -> take_inside_quoted_string (s.[idx] :: acc) (idx + 1)
+ in
+ take_inside_quoted_string [] idx0
+ in
+ let parse_unquoted_string idx =
+ let idx0 = idx in
+ let idx = consume_non_ws idx in
+ let arg = String.sub s idx0 (idx - idx0) in
+ ((arg, (idx0, idx)), idx)
+ in
+ let parse_arg idx =
+ match s.[idx] with
+ | '"' -> quoted_string (idx + 1)
+ | _ -> parse_unquoted_string idx
+ | exception _ -> failwith ": needs something after"
+ in
+ let repeat parser idx =
+ let rec do_ acc idx =
+ match parser idx with
+ | None -> (List.rev acc, idx)
+ | Some (x, idx') ->
+ if idx' = idx then
+ failwith "Parser did not consume input; infinite loop detected"
+ else do_ (x :: acc) idx'
+ in
+ do_ [] idx
+ in
+ let parse_name idx =
+ let idx0 = idx in
+ let idx = consume_alpha idx in
+ let name = String.sub s idx0 (idx - idx0) in
+ (name, idx)
+ in
+ let parse_column idx =
+ match s.[idx] with
+ | ':' -> idx + 1
+ | _ -> failwith "no : after named argument"
+ | exception _ -> failwith "no : after named argument"
+ in
+ let parse_named idx =
+ let idx0 = consume_ws idx in
+ match s.[idx0] with
+ | '~' ->
+ let idx = idx0 + 1 in
+ let name, idx = parse_name idx in
+ let () =
+ if String.equal name "" then
+ failwith "'~' needs to be followed by a name"
+ in
+ let name_loc = (idx0, idx) in
+ let idx = parse_column idx in
+ let arg, idx = parse_arg idx in
+ Some (((name, name_loc), arg), idx)
+ | (exception Invalid_argument _) | _ -> None
+ in
+ let parse_semicolon idx =
+ let idx = consume_ws idx in
+ match s.[idx] with
+ | ';' -> Some ((), idx + 1)
+ | (exception Invalid_argument _) | _ -> None
+ in
+ let parse_positional idx =
+ let idx = consume_ws idx in
+ match s.[idx] with
+ | _ -> Some (parse_arg idx, idx)
+ | exception Invalid_argument _ -> None
+ in
+ let parse_one idx =
+ let ( let$ ) x f = match x with Some _ as x -> x | None -> f () in
+ let ( let> ) x f = Option.map f x in
+ let$ () =
+ let> named, idx = parse_named idx in
+ (`Named named, idx)
+ in
+ let$ () =
+ let> (), idx' = parse_semicolon idx in
+ (`Semicolon idx', idx')
+ in
+ let> (p, idx'), _idx = parse_positional idx in
+ (`Positional p, idx')
+ in
+ let parse_all = repeat parse_one in
+ let parsed, _ = parse_all 0 in
+ let (unfinished_acc, loc), parsed =
+ List.fold_left
+ (fun ((current_acc, idx0), global_acc) -> function
+ | `Semicolon idx ->
+ (([], idx), (List.rev current_acc, (idx0, idx)) :: global_acc)
+ | (`Positional _ | `Named _) as x ->
+ ((x :: current_acc, idx0), global_acc))
+ (([], 0), [])
+ parsed
+ in
+ let parsed =
+ (List.rev unfinished_acc, (loc, String.length s)) :: parsed |> List.rev
+ in
+ parsed
+ |> List.map @@ fun (l, loc) ->
+ ( List.partition_map
+ (function `Named x -> Left x | `Positional p -> Right p)
+ l,
+ loc )
+
+let ( let+ ) x y = Result.map y x
+
+module Smap = Map.Make (String)
+
+type action = {
+ name : string;
+ named : (string node * W.loc) Smap.t;
+ positional : string node list;
+}
+
+let parse_string ~action_name s : (_ W.t, _) result =
+ let+ s =
+ try Ok (parse_string s) with
+ | Failure s -> Error (`Msg s)
+ | _ (* TODO: finer grain catch and better error messages *) ->
+ Error (`Msg "Failed when trying to parse argument")
+ in
+ let res, warnings =
+ s
+ |> List.map (fun ((named, positional), loc) ->
+ let named, warnings =
+ named
+ |> List.fold_left
+ (fun (map, warnings) ((k, k_loc), (v, loc')) ->
+ match Smap.find_opt k map with
+ | None -> (Smap.add k ((v, loc'), k_loc) map, warnings)
+ | Some _ ->
+ (* let loc = _ in *)
+ let msg =
+ "Named argument '" ^ k
+ ^ "' is duplicated. This instance is ignored."
+ in
+ let w = W.Parsing_failure { msg; loc = k_loc } in
+ (map, w :: warnings))
+ (Smap.empty, [])
+ in
+ (({ name = action_name; named; positional }, loc), warnings))
+ |> List.split
+ in
+ let warnings = List.concat warnings in
+ (res, warnings)
+
+let id x = x
+
+type 'a description_named_atom =
+ string * (string node -> ('a, [ `Msg of string ]) result)
+
+type _ descr_tuple =
+ | [] : unit descr_tuple
+ | ( :: ) : 'a description_named_atom * 'b descr_tuple -> ('a * 'b) descr_tuple
+
+type _ output_tuple =
+ | [] : unit output_tuple
+ | ( :: ) : 'a option * 'b output_tuple -> ('a * 'b) output_tuple
+
+type 'a non_empty_list = 'a * 'a list
+
+type ('named, 'positional) parsed = {
+ p_named : 'named output_tuple;
+ p_pos : 'positional node list;
+}
+
+let parsed_name (description_name, description_convert) action =
+ Smap.find_opt description_name action.named
+ |> Option.map (fun (((_, loc) as x), _) -> (description_convert x, loc))
+
+let rec all_keys : type a. a descr_tuple -> string list =
+ fun names ->
+ match names with
+ | [] -> []
+ | (action_key, _) :: rest -> action_key :: all_keys rest
+
+let check_is_unused : type a. action -> a descr_tuple -> unit =
+ fun action descriptions ->
+ let all_keys = all_keys descriptions in
+ Smap.iter
+ (fun key (_, loc) ->
+ if List.mem key all_keys then ()
+ else
+ let possible_arguments = all_keys in
+ W.add
+ (UnusedArgument
+ {
+ action_name = action.name;
+ argument_name = key;
+ loc;
+ possible_arguments;
+ }))
+ action.named
+
+let rec parsed_names : type a. action -> a descr_tuple -> a output_tuple =
+ fun action descriptions ->
+ match descriptions with
+ | [] -> []
+ | description :: rest ->
+ let parsed =
+ match parsed_name description action with
+ | None -> None
+ | Some (Error (`Msg msg), loc) ->
+ W.add @@ Parsing_failure { msg; loc };
+ None
+ | Some (Ok a, _) -> Some a
+ in
+ parsed :: parsed_names action rest
+
+let parse_atom ~named ~positional (action, loc) =
+ let p_named = parsed_names action named in
+ check_is_unused action named;
+ let p_pos =
+ List.map (fun (x, loc) -> (positional x, loc)) action.positional
+ in
+ ({ p_named; p_pos }, loc)
+
+open W.M
+
+let parse ~action_name ~named ~positional s :
+ (('named, 'pos) parsed node non_empty_list * W.warnor list, _) result =
+ let+ parsed_string = parse_string ~action_name s in
+ let$ parsed_string = parsed_string in
+ W.with_ @@ fun () ->
+ List.map (parse_atom ~named ~positional) parsed_string |> function
+ | [] ->
+ assert false
+ (* An empty string would be parsed as [ [[None; None; ...], []] ] *)
+ | a :: rest -> ((a, rest) : _ non_empty_list)
+
+let merge_positional (h, t) =
+ List.concat_map
+ (fun ({ p_named = ([] : _ output_tuple); p_pos = p }, _loc) -> p)
+ (h :: t)
+
+let require_single_action ~action_name x =
+ match x with
+ | ((_, loc) as a), rest ->
+ let warnings =
+ match (rest : _ list) with
+ | [] -> ([] : _ list)
+ | rest ->
+ let msg =
+ "Action " ^ action_name
+ ^ " does not support ';'-separated arguments"
+ in
+ let loc = W.range loc rest in
+ [ W.Parsing_failure { msg; loc } ]
+ in
+ (a, warnings)
+
+let require_single_positional ~action_name (x : _ list) =
+ W.with_ @@ fun () ->
+ match x with
+ | [] -> None
+ | a :: rest ->
+ let () =
+ match rest with
+ | [] -> ()
+ | (_, loc) :: rest ->
+ let msg =
+ "Action " ^ action_name ^ " does not support multiple arguments"
+ and loc = W.range loc rest in
+ W.add (Parsing_failure { msg; loc })
+ in
+ Some a
+
+let no_args ~action_name s =
+ let ( let+ ) = Fun.flip Result.map in
+ let open W.M in
+ let+ x = parse ~action_name ~named:[] ~positional:id s in
+ let$ x = x in
+ match x with
+ | ({ p_named = []; p_pos = [] }, _loc), [] -> ((), [])
+ | (_, loc), _ ->
+ let msg = "The " ^ action_name ^ " action does not accept any argument" in
+ ((), [ W.Parsing_failure { msg; loc } ])
+
+let parse_only_els ~action_name s =
+ let ( let$ ) = Fun.flip Result.map in
+ let$ x, warnings = parse ~action_name ~named:[] ~positional:id s in
+ let res = match merge_positional x with [] -> `Self | x -> `Ids x in
+ (res, warnings)
+
+let parse_only_el ~action_name s =
+ let ( let$ ) x f = Result.map f x in
+ let$ x, warnings = parse ~action_name ~named:[] ~positional:id s in
+ (* TODO why is this one an error (and not a warning)? *)
+ match merge_positional x with
+ | [] -> (`Self, warnings)
+ | x :: rest ->
+ let warnings =
+ match rest with
+ | [] -> warnings
+ | (_, loc) :: _ ->
+ let msg = "Expected a single ID" in
+ let w = W.Parsing_failure { msg; loc } in
+ w :: warnings
+ in
+ (`Id x, warnings)
+
+let option_to_error error = function
+ | Some x -> Ok x
+ | None -> Error (`Msg error)
+
+let duration =
+ ( "duration",
+ fun (x, _) ->
+ x |> Float.of_string_opt |> option_to_error "Error during float parsing"
+ )
+
+let margin =
+ ( "margin",
+ fun (x, _) ->
+ x |> Float.of_string_opt |> option_to_error "Error during float parsing"
+ )
diff --git a/src/actions-arguments/parse.mli b/src/actions-arguments/parse.mli
new file mode 100644
index 00000000..8d0861b0
--- /dev/null
+++ b/src/actions-arguments/parse.mli
@@ -0,0 +1,51 @@
+module W := Warnings
+
+val id : string (* node *) -> string (* node *)
+
+type 'a description_named_atom =
+ string * (string W.node -> ('a, [ `Msg of string ]) result)
+
+type _ descr_tuple =
+ | [] : unit descr_tuple
+ | ( :: ) : 'a description_named_atom * 'b descr_tuple -> ('a * 'b) descr_tuple
+
+type _ output_tuple =
+ | [] : unit output_tuple
+ | ( :: ) : 'a option * 'b output_tuple -> ('a * 'b) output_tuple
+
+type 'a non_empty_list = 'a * 'a list
+
+type ('named, 'positional) parsed = {
+ p_named : 'named output_tuple;
+ p_pos : 'positional W.node list;
+}
+
+val parse :
+ action_name:string ->
+ named:'named descr_tuple ->
+ positional:(string -> 'pos) ->
+ string ->
+ (('named, 'pos) parsed W.node non_empty_list W.t, [> `Msg of string ]) result
+
+val require_single_action :
+ action_name:string -> 'a W.node non_empty_list -> 'a W.node W.t
+
+val require_single_positional :
+ action_name:string -> 'a W.node list -> 'a W.node option W.t
+
+val no_args :
+ action_name:string -> string -> (unit W.t, [> `Msg of string ]) result
+
+val parse_only_els :
+ action_name:string ->
+ string ->
+ ([ `Self | `Ids of string W.node list ] W.t, [> `Msg of string ]) result
+
+val parse_only_el :
+ action_name:string ->
+ string ->
+ ([ `Self | `Id of string W.node ] W.t, [> `Msg of string ]) result
+
+val option_to_error : 'a -> 'b option -> ('b, [> `Msg of 'a ]) result
+val duration : string * (string W.node -> (float, [> `Msg of string ]) result)
+val margin : string * (string W.node -> (float, [> `Msg of string ]) result)
diff --git a/src/actions-arguments/warnings.ml b/src/actions-arguments/warnings.ml
new file mode 100644
index 00000000..00cfac53
--- /dev/null
+++ b/src/actions-arguments/warnings.ml
@@ -0,0 +1,55 @@
+type loc = int * int
+type 'a node = 'a * loc
+
+let range (x, y) (l : 'a node list) : loc =
+ let max = List.fold_left (fun max (_, (_, max')) -> Int.max max max') y l in
+ (x, max)
+
+type warnor =
+ | UnusedArgument of {
+ action_name : string;
+ argument_name : string;
+ possible_arguments : string list;
+ loc : loc;
+ }
+ | Parsing_failure of { msg : string; loc : loc }
+
+type 'a t = 'a * warnor list
+
+let errors_acc : warnor list ref = ref []
+let add x = errors_acc := x :: !errors_acc
+
+let with_ f =
+ let old_errors = !errors_acc in
+ errors_acc := [];
+ let clean_up () =
+ let errors = !errors_acc in
+ errors_acc := old_errors;
+ errors
+ in
+ try
+ let res = f () in
+ (res, clean_up ())
+ with exn ->
+ let _ = clean_up in
+ raise exn
+
+module M = struct
+ let ( let$ ) (x, warnings) f =
+ let x, warnings' = f x in
+ (x, warnings @ warnings')
+
+ let ( let$+ ) (x, warnings) f =
+ let x = f x in
+ (x, warnings)
+end
+
+module RM = struct
+ let ( let$$ ) x f =
+ match x with
+ | Error _ as e -> e
+ | Ok (x, warnings) -> (
+ match f x with
+ | Error _ as e -> e
+ | Ok (x, warnings') -> Ok (x, warnings @ warnings'))
+end
diff --git a/src/cli/dune b/src/cli/dune
index 9e9d962e..8dff0d21 100644
--- a/src/cli/dune
+++ b/src/cli/dune
@@ -12,4 +12,5 @@
fmt.cli
fmt.tty
logs.fmt
- themes))
+ themes
+ diagnosis))
diff --git a/src/cli/main.ml b/src/cli/main.ml
index a84a9fc2..8db18fab 100644
--- a/src/cli/main.ml
+++ b/src/cli/main.ml
@@ -18,12 +18,12 @@ let handle_error = function Ok _ as x -> x | Error (`Msg msg) -> Error msg
module Custom_conv = struct
let toplevel_attributes =
let parser s =
- Slipshow.Frontmatter.String_to.toplevel_attributes s
+ Slipshow.Frontmatter.Toplevel_attributes.of_string s
|> Result.map @@ fun s -> Some s
in
let printer fmt attrs =
let attrs =
- Option.value ~default:Slipshow.Frontmatter.Default.toplevel_attributes
+ Option.value ~default:Slipshow.Frontmatter.Toplevel_attributes.default
attrs
in
let doc =
@@ -55,48 +55,38 @@ module Custom_conv = struct
let output = io `Stdout
let theme =
- let parser_ s = Ok (Some (Slipshow.Frontmatter.String_to.theme s)) in
+ let parser_ s =
+ Result.map Option.some (Slipshow.Frontmatter.Theme.of_string s)
+ in
let rec printer fmt = function
| Some (`Builtin s) -> Format.fprintf fmt "%s" (Themes.to_string s)
| Some (`External s) -> Format.fprintf fmt "%s" s
- | None -> printer fmt (Some Slipshow.Frontmatter.Default.theme)
+ | None -> printer fmt (Some Slipshow.Frontmatter.Theme.default)
in
Arg.conv (parser_, printer)
let math_mode =
let parser_ s =
- Result.map (fun x -> Some x) @@ Slipshow.Frontmatter.String_to.math_mode s
+ Result.map (fun x -> Some x) @@ Slipshow.Frontmatter.Math_mode.of_string s
in
let rec printer fmt = function
| Some `Mathjax -> Format.fprintf fmt "mathjax"
| Some `Katex -> Format.fprintf fmt "katex"
- | None -> printer fmt (Some Slipshow.Frontmatter.Default.math_mode)
+ | None -> printer fmt (Some Slipshow.Frontmatter.Math_mode.default)
in
Arg.conv (parser_, printer)
let dimension =
- let int_parser = Cmdliner.Arg.(conv_parser int) in
let int_printer = Cmdliner.Arg.(conv_printer int) in
- let ( let* ) = Result.bind in
let parser_ s =
- match String.split_on_char 'x' s with
- | [ "4:3" ] -> Ok (Some (1440, 1080))
- | [ "16:9" ] -> Ok (Some (1920, 1080))
- | [ width; height ] ->
- let* width = int_parser width in
- let* height = int_parser height in
- Ok (Some (width, height))
- | _ ->
- Error
- (`Msg
- "Expected \"4:3\", \"16:9\", or two integers separated by a 'x'")
+ Result.map (fun x -> Some x) @@ Slipshow.Frontmatter.Dimension.of_string s
in
let rec printer fmt x =
match x with
| Some (1440, 1080) -> Format.fprintf fmt "4:3"
| Some (1920, 1080) -> Format.fprintf fmt "16:9"
| Some (w, h) -> Format.fprintf fmt "%ax%a" int_printer w int_printer h
- | None -> printer fmt (Some Slipshow.Frontmatter.Default.dimension)
+ | None -> printer fmt (Some Slipshow.Frontmatter.Dimension.default)
in
Cmdliner.Arg.conv ~docv:"WIDTHxHEIGHT" (parser_, printer)
end
@@ -220,6 +210,7 @@ module Compile_args = struct
js_links;
highlightjs_theme;
math_mode;
+ external_ids = [];
};
input;
output;
diff --git a/src/cli/run.ml b/src/cli/run.ml
index b99aaebd..16548b83 100644
--- a/src/cli/run.ml
+++ b/src/cli/run.ml
@@ -39,19 +39,31 @@ let compile ~input ~output ~cli_frontmatter =
let used_files, read_file = read_file (Fpath.v "./") () in
(used_files, Slipshow.Asset.of_string ~read_file)
in
- let cli_frontmatter =
+ let cli_frontmatter, warnings =
+ Diagnosis.with_ @@ fun () ->
Slipshow.Frontmatter.resolve cli_frontmatter ~to_asset
in
+ List.iter (Format.printf "%a" Diagnosis.report_no_src) warnings;
let* content = Io.read input in
let used_files, read_file =
read_file
(match input with `Stdin -> Fpath.v "./" | `File f -> Fpath.parent f)
()
in
- let html =
- Slipshow.convert ~has_speaker_view:true ~frontmatter:cli_frontmatter
+ let html, warnings =
+ let file =
+ match input with `File f -> Some (Fpath.to_string f) | _ -> None
+ in
+ Slipshow.convert ~has_speaker_view:true ~frontmatter:cli_frontmatter ?file
~read_file content
in
+ let () =
+ List.iter
+ (Format.printf "%a@.@."
+ (Grace_ansi_renderer.pp_diagnostic ?config:None
+ ~code_to_string:Diagnosis.to_code))
+ warnings
+ in
let all_used_files = Fpath.Set.union !asset_files !used_files in
match output with
| `Stdout ->
@@ -80,19 +92,36 @@ let serve ~input ~output ~cli_frontmatter ~port =
let used_files, read_file = read_file (Fpath.v "./") () in
(used_files, Slipshow.Asset.of_string ~read_file)
in
- let cli_frontmatter =
+ let cli_frontmatter, warnings_cli_frontmatter =
+ Diagnosis.with_ @@ fun () ->
Slipshow.Frontmatter.resolve cli_frontmatter ~to_asset
in
let* content = Io.read (`File input) in
let used_files, read_file = read_file (Fpath.parent input) () in
- let result =
+ let result, warnings =
+ let file = Fpath.to_string input in
Slipshow.delayed ~has_speaker_view:true ~frontmatter:cli_frontmatter
- ~read_file content
+ ~read_file ~file content
+ in
+ let warnings =
+ List.map
+ (Format.asprintf "%a@.@."
+ (Grace_ansi_renderer.pp_diagnostic ?config:None
+ ~code_to_string:Diagnosis.to_code))
+ warnings
+ in
+ let warnings = List.map (Ansi.process (Ansi.create ())) warnings in
+ let cli_warnings =
+ List.map
+ (Format.asprintf "%a" Diagnosis.report_no_src)
+ warnings_cli_frontmatter
in
+ let warnings = cli_warnings @ warnings |> String.concat "" in
let all_used_files = Fpath.Set.union !asset_files !used_files in
let html = Slipshow.add_starting_state result None in
let+ () = Io.write output html in
- ( result,
+ let warnings = warnings in
+ ( (result, warnings),
Fpath.Set.add
(Fpath.normalize (Fpath.( // ) (Fpath.v (Sys.getcwd ())) input))
all_used_files )
diff --git a/src/cm_plugin/slipshow_communication.ml b/src/cm_plugin/slipshow_communication.ml
index 4163eca7..96a029e9 100644
--- a/src/cm_plugin/slipshow_communication.ml
+++ b/src/cm_plugin/slipshow_communication.ml
@@ -24,14 +24,16 @@ let update_slipshow ?slipshow_js ?frontmatter ?read_file () =
in
preview state content
-let slipshow_plugin ?slipshow_js ?frontmatter ?read_file preview_element =
+let slipshow_plugin ?slipshow_js ?frontmatter ?read_file ~errors_el
+ preview_element =
let open Editor in
let update_slipshow =
update_slipshow ?slipshow_js ?frontmatter ?read_file ()
in
View.ViewPlugin.define (fun view ->
let state =
- Previewer.create_previewer ~include_speaker_view:false preview_element
+ Previewer.create_previewer ~include_speaker_view:false ~errors_el
+ preview_element
in
let _ : unit Fut.t = update_slipshow ~ms:0 state view in
let update upd =
diff --git a/src/cm_plugin/slipshow_communication.mli b/src/cm_plugin/slipshow_communication.mli
index 95aa6385..fd49b1ba 100644
--- a/src/cm_plugin/slipshow_communication.mli
+++ b/src/cm_plugin/slipshow_communication.mli
@@ -5,5 +5,6 @@ val slipshow_plugin :
?slipshow_js:Slipshow.Asset.t ->
?frontmatter:Slipshow.Frontmatter.resolved Slipshow.Frontmatter.t ->
?read_file:Slipshow.file_reader ->
+ errors_el:Brr.El.t ->
Brr.El.t ->
Code_mirror.Extension.t
diff --git a/src/compiler/asset.ml b/src/compiler/asset.ml
index 97c19fa8..b34cfa9e 100644
--- a/src/compiler/asset.ml
+++ b/src/compiler/asset.ml
@@ -5,6 +5,7 @@ module Uri = struct
if
Astring.String.is_infix ~affix:"://" s
|| String.starts_with ~prefix:"//" s
+ || String.starts_with ~prefix:"data:" s
then Link s
else Path (Fpath.v s)
@@ -27,10 +28,10 @@ let of_uri ~read_file s =
let mime_type = Some (mime_of_ext (Fpath.filename fp)) in
Local { mime_type; content; path = fp }
| Ok None -> Remote (Fpath.to_string p)
- | Error (`Msg e) ->
- Logs.warn (fun f ->
- f "Could not read file: %a. Considering it as an URL. (%s)"
- Fpath.pp p e);
+ | Error (`Msg error_msg) ->
+ let locs = [] in
+ Diagnosis.add
+ (MissingFile { file = Fpath.to_string p; error_msg; locs });
Remote (Fpath.to_string p))
let of_string ~read_file s = s |> Uri.of_string |> of_uri ~read_file
diff --git a/src/compiler/ast.ml b/src/compiler/ast.ml
index 90292c8f..ec0bbb4d 100644
--- a/src/compiler/ast.ml
+++ b/src/compiler/ast.ml
@@ -24,7 +24,7 @@ let mermaid_js d = S_block (MermaidJS d)
let carousel d = S_block (Carousel d)
type media = {
- uri : Asset.Uri.t;
+ uri : Asset.Uri.t node;
id : string;
origin : Cmarkit.Inline.Link.t attributed node;
}
@@ -94,6 +94,81 @@ module Folder = struct
let make ~block ~inline () =
Folder.make ~block_ext_default ~inline_ext_default ~block ~inline ()
+
+ let continue_block f c acc =
+ let open Block in
+ match c with
+ | Blank_line _ | Code_block _ | Html_block _ | Ext_standalone_attributes _
+ | Link_reference_definition _ | Thematic_break _ | Ext_math_block _
+ | Ext_attribute_definition _ ->
+ acc
+ | Heading ((h, _attrs), _) ->
+ Folder.fold_inline f acc (Block.Heading.inline h)
+ | Block_quote ((bq, _attrs), _) ->
+ Folder.fold_block f acc (Cmarkit.Block.Block_quote.block bq)
+ | Blocks (bs, _) -> List.fold_left (Folder.fold_block f) acc bs
+ | List ((l, _attrs), _) ->
+ let fold_list_item m acc (i, _) =
+ Folder.fold_block m acc (Block.List_item.block i)
+ in
+ List.fold_left (fold_list_item f) acc (List'.items l)
+ | Paragraph ((p, _attrs), _) ->
+ Folder.fold_inline f acc (Block.Paragraph.inline p)
+ | Ext_table ((t, _attrs), _) ->
+ let fold_row acc ((r, _), _) =
+ match r with
+ | `Header is | `Data is ->
+ List.fold_left
+ (fun acc (i, _) -> Folder.fold_inline f acc i)
+ acc is
+ | `Sep _ -> acc
+ in
+ List.fold_left fold_row acc (Table.rows t)
+ | Ext_footnote_definition ((_fn, _attrs), _) -> acc (* TODO: do *)
+ | S_block b -> (
+ match b with
+ | Slide (({ content = b; title = Some (title, _) }, _), _) ->
+ let acc = Folder.fold_inline f acc title in
+ Folder.fold_block f acc b
+ | Slide (({ content = b; title = None }, _), _)
+ | Div ((b, _), _)
+ | Included ((b, _), _)
+ | Slip ((b, _), _) ->
+ Folder.fold_block f acc b
+ | MermaidJS _ | SlipScript _ -> acc
+ | Carousel ((l, _), _) ->
+ List.fold_left (fun acc x -> Folder.fold_block f acc x) acc l)
+ | _ -> assert false
+
+ let continue_inline f i acc =
+ let open Inline in
+ match i with
+ | Autolink _ | Break _ | Code_span _ | Raw_html _ | Text _ | Ext_math_span _
+ ->
+ acc
+ | Image ((l, _), _) | Link ((l, _), _) ->
+ let text = Link.text l in
+ Folder.fold_inline f acc text
+ | Ext_attrs (attrs, _) ->
+ let inline = Attributes_span.content attrs in
+ Folder.fold_inline f acc inline
+ | Emphasis ((e, _), _) ->
+ let inline = Emphasis.inline e in
+ Folder.fold_inline f acc inline
+ | Strong_emphasis ((e, _), _) ->
+ let inline = Emphasis.inline e in
+ Folder.fold_inline f acc inline
+ | Inlines (is, _) -> List.fold_left (Folder.fold_inline f) acc is
+ | Ext_strikethrough ((inline, _), _) ->
+ let inline = Strikethrough.inline inline in
+ Folder.fold_inline f acc inline
+ | S_inline ext -> (
+ match ext with
+ | Hand_drawn m | Image m | Svg m | Video m | Audio m | Pdf m ->
+ let (link, _), _ = m.origin in
+ let inline = Link.text link in
+ Folder.fold_inline f acc inline)
+ | _ -> assert false
end
module Mapper = struct
@@ -178,3 +253,200 @@ module Mapper = struct
let make = Mapper.make ~block_ext_default ~inline_ext_default
end
+
+module Utils = struct
+ module Block = struct
+ (** Get the attributes of a cmarkit node, returns them and the element
+ stripped of its attributes *)
+ let update_attribute :
+ (Attributes.t node -> Attributes.t node) ->
+ Block.t ->
+ (Block.t * Attributes.t node) option =
+ fun attr_upd ->
+ let open Block in
+ function
+ (* Standard Cmarkit nodes *)
+ | Blank_line _ | Blocks _ -> None
+ | Block_quote ((bq, attrs), meta) ->
+ Some (Block_quote ((bq, attr_upd attrs), meta), attrs)
+ | Code_block ((cb, attrs), meta) ->
+ Some (Code_block ((cb, attr_upd attrs), meta), attrs)
+ | Heading ((h, attrs), meta) ->
+ Some (Heading ((h, attr_upd attrs), meta), attrs)
+ | Html_block ((hb, attrs), meta) ->
+ Some (Html_block ((hb, attr_upd attrs), meta), attrs)
+ | Link_reference_definition _ -> None
+ | List ((l, attrs), meta) -> Some (List ((l, attr_upd attrs), meta), attrs)
+ | Paragraph ((p, attrs), meta) ->
+ Some (Paragraph ((p, attr_upd attrs), meta), attrs)
+ | Thematic_break ((tb, attrs), meta) ->
+ Some (Thematic_break ((tb, attr_upd attrs), meta), attrs)
+ (* Extension Cmarkit nodes *)
+ | Ext_standalone_attributes attrs ->
+ Some (Ext_standalone_attributes (attr_upd attrs), attrs)
+ | Ext_math_block ((mb, attrs), meta) ->
+ Some (Ext_math_block ((mb, attr_upd attrs), meta), attrs)
+ | Ext_table ((table, attrs), meta) ->
+ Some (Ext_table ((table, attr_upd attrs), meta), attrs)
+ | Ext_footnote_definition _ | Ext_attribute_definition _ -> None
+ (* Slipshow nodes *)
+ | S_block b -> (
+ match b with
+ | Included ((inc, attrs), meta) ->
+ Some (included ((inc, attr_upd attrs), meta), attrs)
+ | Div ((d, attrs), meta) ->
+ Some (div ((d, attr_upd attrs), meta), attrs)
+ | Slide ((s, attrs), meta) ->
+ Some (slide ((s, attr_upd attrs), meta), attrs)
+ | Slip ((s, attrs), meta) ->
+ Some (slip ((s, attr_upd attrs), meta), attrs)
+ | SlipScript ((slscr, attrs), meta) ->
+ Some (slipscript ((slscr, attr_upd attrs), meta), attrs)
+ | MermaidJS ((slscr, attrs), meta) ->
+ Some (mermaid_js ((slscr, attr_upd attrs), meta), attrs)
+ | Carousel ((c, attrs), meta) ->
+ Some (carousel ((c, attr_upd attrs), meta), attrs))
+ | _ -> None
+
+ (** Get the attributes of a cmarkit node, returns them and the element
+ stripped of its attributes *)
+ let get_attribute b =
+ let no_attrs = (Attributes.empty, Meta.none) in
+ let attr_upd _ = no_attrs in
+ update_attribute attr_upd b
+
+ (** Get the attributes of a cmarkit node, returns them and the element
+ stripped of its attributes *)
+ let merge_attribute new_attrs b =
+ let merge (base, meta) =
+ (Attributes.merge ~base ~new_attrs, meta)
+ (* Old attributes take precendence over "new" one *)
+ in
+ match update_attribute merge b with None -> b | Some (b, _) -> b
+
+ let meta b =
+ let ext b =
+ match b with
+ | S_block b -> (
+ match b with
+ | Included (_, meta) -> meta
+ | Div (_, meta) -> meta
+ | Slide (_, meta) -> meta
+ | Slip (_, meta) -> meta
+ | SlipScript (_, meta) -> meta
+ | Carousel (_, meta) -> meta
+ | MermaidJS (_, meta) -> meta)
+ | _ -> assert false
+ in
+ Block.meta ~ext b
+ end
+
+ module Inline = struct
+ (** Get the attributes of a cmarkit node, returns them and the element
+ stripped of its attributes *)
+ let update_attribute :
+ (Attributes.t node -> Attributes.t node) ->
+ Inline.t ->
+ (Inline.t * Attributes.t node) option =
+ fun attr_upd ->
+ let open Inline in
+ function
+ (* Standard Cmarkit nodes *)
+ | Autolink ((al, attrs), meta) ->
+ Some (Autolink ((al, attr_upd attrs), meta), attrs)
+ | Break _ -> None
+ | Code_span ((cs, attrs), meta) ->
+ Some (Code_span ((cs, attr_upd attrs), meta), attrs)
+ | Emphasis ((em, attrs), meta) ->
+ Some (Emphasis ((em, attr_upd attrs), meta), attrs)
+ | Image ((im, attrs), meta) ->
+ Some (Image ((im, attr_upd attrs), meta), attrs)
+ | Inlines _ -> None
+ | Link ((link, attrs), meta) ->
+ Some (Link ((link, attr_upd attrs), meta), attrs)
+ | Raw_html _ -> None
+ | Strong_emphasis ((sem, attrs), meta) ->
+ Some (Strong_emphasis ((sem, attr_upd attrs), meta), attrs)
+ | Text ((txt, attrs), meta) ->
+ Some (Text ((txt, attr_upd attrs), meta), attrs)
+ (* Extension Cmarkit nodes *)
+ | Ext_strikethrough ((strk, attrs), meta) ->
+ Some (Ext_strikethrough ((strk, attr_upd attrs), meta), attrs)
+ | Ext_math_span ((ms, attrs), meta) ->
+ Some (Ext_math_span ((ms, attr_upd attrs), meta), attrs)
+ | Ext_attrs (attr_span, meta) ->
+ let inline = Attributes_span.content attr_span in
+ let attrs = Attributes_span.attrs attr_span in
+ Some
+ ( Ext_attrs (Attributes_span.make inline (attr_upd attrs), meta),
+ attrs )
+ (* Slipshow nodes *)
+ | S_inline i -> (
+ match i with
+ | Hand_drawn m ->
+ let (link, attrs), meta = m.origin in
+ let origin = ((link, attr_upd attrs), meta) in
+ Some (S_inline (Hand_drawn { m with origin }), attrs)
+ | Image m ->
+ let (link, attrs), meta = m.origin in
+ let origin = ((link, attr_upd attrs), meta) in
+ Some (S_inline (Image { m with origin }), attrs)
+ | Svg m ->
+ let (link, attrs), meta = m.origin in
+ let origin = ((link, attr_upd attrs), meta) in
+ Some (S_inline (Svg { m with origin }), attrs)
+ | Video m ->
+ let (link, attrs), meta = m.origin in
+ let origin = ((link, attr_upd attrs), meta) in
+ Some (S_inline (Video { m with origin }), attrs)
+ | Audio m ->
+ let (link, attrs), meta = m.origin in
+ let origin = ((link, attr_upd attrs), meta) in
+ Some (S_inline (Audio { m with origin }), attrs)
+ | Pdf m ->
+ let (link, attrs), meta = m.origin in
+ let origin = ((link, attr_upd attrs), meta) in
+ Some (S_inline (Pdf { m with origin }), attrs))
+ | _ -> None
+
+ (** Get the attributes of a cmarkit node, returns them and the element
+ stripped of its attributes *)
+ let get_attribute b =
+ let no_attrs = (Attributes.empty, Meta.none) in
+ let attr_upd _ = no_attrs in
+ update_attribute attr_upd b
+
+ (** Get the attributes of a cmarkit node, returns them and the element
+ stripped of its attributes *)
+ let merge_attribute new_attrs b =
+ let merge (base, meta) =
+ (Attributes.merge ~base ~new_attrs, meta)
+ (* Old attributes take precendence over "new" one *)
+ in
+ match update_attribute merge b with None -> b | Some (b, _) -> b
+
+ let meta i =
+ let ext i =
+ match i with
+ | S_inline i -> (
+ match i with
+ | Image { origin = _, meta; _ } -> meta
+ | Svg { origin = _, meta; _ } -> meta
+ | Video { origin = _, meta; _ } -> meta
+ | Audio { origin = _, meta; _ } -> meta
+ | Pdf { origin = _, meta; _ } -> meta
+ | Hand_drawn { origin = _, meta; _ } -> meta)
+ | _ -> assert false
+ in
+ Inline.meta ~ext i
+ end
+end
+
+module Bol = struct
+ type t = [ `Block of Block.t | `Inline of Inline.t ]
+
+ let text_loc (bol : t) =
+ match bol with
+ | `Block b -> b |> Utils.Block.meta |> Meta.textloc
+ | `Inline i -> i |> Utils.Inline.meta |> Meta.textloc
+end
diff --git a/src/compiler/check.ml b/src/compiler/check.ml
new file mode 100644
index 00000000..21c493b9
--- /dev/null
+++ b/src/compiler/check.ml
@@ -0,0 +1,224 @@
+open Cmarkit
+module M = Map.Make (String)
+
+module Is = struct
+ let carousel_or_pdf (bol : Ast.Bol.t) =
+ match bol with
+ | `Block (Ast.S_block (Carousel _)) -> true
+ | `Inline (Ast.S_inline (Pdf _)) -> true
+ | _ -> false
+
+ let carousel_or_pdf = (carousel_or_pdf, "carousel or pdf")
+
+ let playable_media (bol : Ast.Bol.t) =
+ match bol with
+ | `Inline (Ast.S_inline (Video _ | Audio _)) -> true
+ | _ -> false
+
+ let playable_media = (playable_media, "video or audio")
+
+ let slip_script (bol : Ast.Bol.t) =
+ match bol with `Block (Ast.S_block (SlipScript _)) -> true | _ -> false
+
+ let slip_script = (slip_script, "slip-script")
+
+ let draw (bol : Ast.Bol.t) =
+ match bol with `Inline (Ast.S_inline (Hand_drawn _)) -> true | _ -> false
+
+ let draw = (draw, "drawing")
+end
+
+let act_only_on_attributes_with_actions (module A : Actions_arguments.S) attrs f
+ =
+ let ex = Attributes.find A.on attrs in
+ match ex with None -> () | Some (_, value) -> f value
+
+let parse_args (type args)
+ (module A : Actions_arguments.S with type args = args) attrs f =
+ act_only_on_attributes_with_actions (module A) attrs @@ fun value ->
+ let value, val_loc =
+ match value with
+ | None -> ("", Textloc.none)
+ | Some ({ Attributes.v; _ }, meta) -> (v, Meta.textloc meta)
+ in
+ let args = A.parse_args value in
+ match args with
+ | Error (`Msg msg) ->
+ Diagnosis.add
+ @@ ParsingError { action = A.action_name; msg; loc = val_loc }
+ | Ok (args, warnings) ->
+ List.iter
+ (fun warnor -> Diagnosis.add @@ ParsingWarnor { warnor; loc = val_loc })
+ warnings;
+ f args val_loc
+
+let handle_id_get id_map val_loc (id, loc) =
+ let loc = Diagnosis.loc_of_ploc val_loc loc in
+ match M.find_opt id id_map with
+ | None ->
+ Diagnosis.add @@ MissingID { id; loc };
+ None
+ | Some (_, bol, _) -> Some (bol, Some loc)
+
+let handle_id id_map val_loc (id, loc) =
+ handle_id_get id_map val_loc (id, loc) |> ignore
+
+let handle_ids id_map val_loc ids = List.iter (handle_id id_map val_loc) ids
+
+let check_targets (is, expected_type) id_map bol val_loc targets =
+ let targets =
+ match targets with
+ | `Self -> [ ((bol : Ast.Bol.t :> [ Ast.Bol.t | `External ]), None) ]
+ | `Ids ids -> List.filter_map (handle_id_get id_map val_loc) ids
+ in
+ List.iter
+ (fun (bol, id_loc) ->
+ match bol with
+ | #Ast.Bol.t as bol ->
+ if not (is bol) then
+ let loc_block = Ast.Bol.text_loc bol in
+ let loc_reason =
+ Option.value id_loc ~default:(Ast.Bol.text_loc bol)
+ in
+ Diagnosis.add @@ WrongType { loc_reason; loc_block; expected_type }
+ | `External -> ())
+ targets;
+ ()
+
+let check_target is id_map bol val_loc target =
+ let targets = match target with `Self -> `Self | `Id id -> `Ids [ id ] in
+ check_targets is id_map bol val_loc targets
+
+let exec id_map attrs block_or_inline =
+ parse_args (module Actions_arguments.Execute) attrs @@ fun args val_loc ->
+ check_targets Is.slip_script id_map block_or_inline val_loc args
+
+type id_map = ((string * Meta.t) * [ Ast.Bol.t | `External ] * Meta.t) M.t
+
+let move (module A : Actions_arguments.Move) (id_map : id_map) attrs
+ (_block_or_inline : Ast.Bol.t) =
+ parse_args (module A) attrs @@ fun args val_loc ->
+ match args.target with `Self -> () | `Id id -> handle_id id_map val_loc id
+
+let up = move (module Actions_arguments.Up)
+let down = move (module Actions_arguments.Down)
+let center = move (module Actions_arguments.Center)
+let scroll = move (module Actions_arguments.Scroll)
+let enter = move (module Actions_arguments.Enter)
+
+let focus (id_map : id_map) attrs _block_or_inline =
+ parse_args (module Actions_arguments.Focus) attrs @@ fun args val_loc ->
+ match args.target with
+ | `Self -> ()
+ | `Ids ids -> handle_ids id_map val_loc ids
+
+let unfocus (_id_map : id_map) attrs _block_or_inline =
+ parse_args (module Actions_arguments.Unfocus) attrs @@ fun _ _ -> ()
+
+let set_class (module A : Actions_arguments.SetClass) (id_map : id_map) attrs
+ (_block_or_inline : Ast.Bol.t) =
+ parse_args (module A) attrs @@ fun args val_loc ->
+ match args with `Self -> () | `Ids ids -> handle_ids id_map val_loc ids
+
+let unstatic = set_class (module Actions_arguments.Unstatic)
+let static = set_class (module Actions_arguments.Static)
+let reveal = set_class (module Actions_arguments.Reveal)
+let unreveal = set_class (module Actions_arguments.Unreveal)
+let emph = set_class (module Actions_arguments.Emph)
+let unemph = set_class (module Actions_arguments.Unemph)
+
+let speaker_note id_map attrs _block_or_inline =
+ parse_args (module Actions_arguments.Speaker_note) attrs
+ @@ fun args val_loc ->
+ match args with `Self -> () | `Id id -> handle_id id_map val_loc id
+
+let play_media id_map attrs block_or_inline =
+ parse_args (module Actions_arguments.Play_media) attrs @@ fun args val_loc ->
+ check_targets Is.playable_media id_map block_or_inline val_loc args
+
+let change_page id_map attrs block_or_inline =
+ parse_args (module Actions_arguments.Change_page) attrs @@ fun args val_loc ->
+ List.iter
+ (fun (arg : Actions_arguments.Change_page.arg) ->
+ check_target Is.carousel_or_pdf id_map block_or_inline val_loc arg.target)
+ args
+
+let draw id_map attrs block_or_inline =
+ parse_args (module Actions_arguments.Draw) attrs @@ fun args val_loc ->
+ check_targets Is.draw id_map block_or_inline val_loc args
+
+let clear_draw id_map attrs block_or_inline =
+ parse_args (module Actions_arguments.Clear_draw) attrs @@ fun args val_loc ->
+ check_targets Is.draw id_map block_or_inline val_loc args
+
+let pause id_map attrs _block_or_inline =
+ parse_args (module Actions_arguments.Pause) attrs @@ fun args val_loc ->
+ match args with `Self -> () | `Ids ids -> handle_ids id_map val_loc ids
+
+module SSet = Set.Make (String)
+
+(* To get this list of all valid html attributes, go to
+ [https://developer.mozilla.org/en-US/docs/Web/HTML/Reference/Attributes], get
+ the [tbody] DOM element of the list table, and run:
+
+ {[
+ Array.from(temp0.querySelectorAll("tr>td:first-child")).map((e) => {return e.innerText})
+ ]}
+
+ Right click, copy object, paste it, and then:
+ - Remove the "Deprecated" and "Experimental" flags
+ - Remove the data-* entry
+*)
+let all_attributes =
+ [
+ "accept";"accept-charset";"accesskey";"action";"align";"allow";"alpha";"alt";"as";"async";"autocapitalize";"autocomplete";"autoplay";"background";"bgcolor";"border";"capture";"charset";"checked";"cite";"class";"color";"colorspace";"cols";"colspan";"content";"contenteditable";"controls";"coords";"crossorigin";"csp";"data";"datetime";"decoding";"default";"defer";"dir";"dirname";"disabled";"download";"draggable";"enctype";"enterkeyhint";"elementtiming";"fetchpriority";"for";"form";"formaction";"formenctype";"formmethod";"formnovalidate";"formtarget";"headers";"height";"hidden";"high";"href";"hreflang";"http-equiv";"id";"integrity";"inputmode";"ismap";"itemprop";"kind";"label";"lang";"language";"loading";"list";"loop";"low";"max";"maxlength";"minlength";"media";"method";"min";"multiple";"muted";"name";"novalidate";"open";"optimum";"pattern";"ping";"placeholder";"playsinline";"poster";"preload";"readonly";"referrerpolicy";"rel";"required";"reversed";"role";"rows";"rowspan";"sandbox";"scope";"selected";"shape";"size";"sizes";"slot";"span";"spellcheck";"src";"srcdoc";"srclang";"srcset";"start";"step";"style";"summary";"tabindex";"target";"title";"translate";"type";"usemap";"value";"width";"wrap";
+ ] |> SSet.of_list
+ [@@ocamlformat "disable"]
+
+let all_actions =
+ List.map
+ (fun (module A : Actions_arguments.S) -> A.on)
+ Actions_arguments.all_actions
+ |> SSet.of_list
+
+let all_special = Special_attrs.all_attrs |> SSet.of_list
+
+let check_attribute key loc =
+ if SSet.mem key all_actions then ()
+ else if SSet.mem key all_special then ()
+ else if SSet.mem key all_attributes then ()
+ else if String.starts_with ~prefix:"data-" key then ()
+ else if String.starts_with ~prefix:"children:" key then ()
+ else Diagnosis.add (UnknownAttribute { attr = key; loc })
+
+let no_unknown_attributes _id_map attrs _block_or_inline =
+ let kv = Attributes.kv_attributes attrs in
+ List.iter
+ (fun ((key, meta), _value) ->
+ check_attribute key (Cmarkit.Meta.textloc meta))
+ kv
+
+let all_checks =
+ [
+ clear_draw;
+ draw;
+ change_page;
+ play_media;
+ pause;
+ speaker_note;
+ unstatic;
+ static;
+ reveal;
+ unreveal;
+ emph;
+ unemph;
+ focus;
+ unfocus;
+ up;
+ down;
+ center;
+ scroll;
+ enter;
+ exec;
+ no_unknown_attributes;
+ ]
diff --git a/src/compiler/check.mli b/src/compiler/check.mli
new file mode 100644
index 00000000..1b596f20
--- /dev/null
+++ b/src/compiler/check.mli
@@ -0,0 +1,8 @@
+module M : module type of Map.Make (String)
+
+type id_map :=
+ (string Cmarkit.node * [ Ast.Bol.t | `External ] * Cmarkit.Meta.t) M.t
+
+type check := id_map -> Cmarkit.Attributes.t -> Ast.Bol.t -> unit
+
+val all_checks : check list
diff --git a/src/compiler/cmarkit_proxy.ml b/src/compiler/cmarkit_proxy.ml
new file mode 100644
index 00000000..d5aba96d
--- /dev/null
+++ b/src/compiler/cmarkit_proxy.ml
@@ -0,0 +1,4 @@
+let of_string ?loc_offset ~file =
+ let locs = Option.is_some file in
+ Cmarkit.Doc.of_string ~heading_auto_ids:false ~strict:false ~locs ?loc_offset
+ ?file
diff --git a/src/compiler/compile.ml b/src/compiler/compile.ml
index 997c1c26..7a217c7e 100644
--- a/src/compiler/compile.ml
+++ b/src/compiler/compile.ml
@@ -30,7 +30,10 @@ type file_reader = Fpath.t -> (string option, [ `Msg of string ]) result
- [slide] attributed elements are turned into slides
- [carousel] attributed elements are turned into carousels
- The fourth stage is populating the media files map *)
+ The fourth stage is populating the media files map, and the ID map.
+
+ The fifth stage is iterating on the attributes to generate warnings for
+ wrongly designed action attributes. *)
module Path_entering : sig
(** Path are relative to the file we are reading. When we include a file we
@@ -90,7 +93,7 @@ let classify_image p =
let resolve_file ps s =
match Asset.Uri.of_string s with
- | Link s -> Asset.Uri.Link s
+ | Link _ as l -> l
| Path p -> Path (Path_entering.relativize ps p)
module Stage1 = struct
@@ -115,22 +118,32 @@ module Stage1 = struct
(Ast.mermaid_js ((cb, (Mapper.map_attrs m attrs, meta)), meta2))
| _ -> Mapper.default)
- let handle_includes read_file current_path m (attrs, meta) =
- match (Attributes.find "include" attrs, Attributes.find "src" attrs) with
- | Some (_, None), Some (_, Some ({ v = src; _ }, _)) -> (
+ let handle_includes ~htbl_include read_file current_path m (attrs, meta) =
+ match
+ ( Attributes.find Special_attrs.include_ attrs,
+ Attributes.find Special_attrs.src attrs )
+ with
+ | Some (_, None), Some (_, Some ({ v = src; _ }, filepath_meta)) -> (
let relativized_path =
Path_entering.relativize current_path (Fpath.v src)
in
match read_file relativized_path with
| Error (`Msg err) ->
- Logs.warn (fun m ->
- m "Could not read %a: %s" Fpath.pp relativized_path err);
+ let locs = [ Meta.textloc filepath_meta ] in
+ Diagnosis.add
+ (MissingFile
+ {
+ file = Fpath.to_string relativized_path;
+ error_msg = err;
+ locs;
+ });
Mapper.default
| Ok None -> Mapper.default
| Ok (Some contents) -> (
+ Hashtbl.add htbl_include (Fpath.to_string relativized_path) contents;
let md =
- Cmarkit.Doc.of_string ~heading_auto_ids:false ~strict:false
- contents
+ let file = Some (Fpath.to_string relativized_path) in
+ Cmarkit_proxy.of_string ~file contents
in
Path_entering.in_path current_path (Fpath.parent (Fpath.v src))
@@ fun () ->
@@ -149,10 +162,10 @@ module Stage1 = struct
let classify_link_definition (ld : Cmarkit.Link_definition.t) attrs =
let has_attrs x = Cmarkit.Attributes.find x attrs |> Option.is_some in
- if has_attrs "video" then `Video
- else if has_attrs "audio" then `Audio
- else if has_attrs "image" then `Image
- else if has_attrs "svg" then `Svg
+ if has_attrs Special_attrs.video then `Video
+ else if has_attrs Special_attrs.audio then `Audio
+ else if has_attrs Special_attrs.image then `Image
+ else if has_attrs Special_attrs.svg then `Svg
(* else if has_attrs "pdf" then `Pdf *)
(* else if has_attrs "draw" then `Draw
We don't want to pollute too much the namespace. *)
@@ -162,13 +175,14 @@ module Stage1 = struct
| Error _ -> `Image
| Ok p -> classify_image p
- let update_link_definition current_path ld =
+ let update_link_definition current_path (ld, meta) =
let label, layout, defined_label, (dest, meta_dest), title =
Link_definition.(label ld, layout ld, defined_label ld, dest ld, title ld)
in
let uri = resolve_file current_path dest in
let dest = (Asset.Uri.to_string uri, meta_dest) in
- (uri, Link_definition.make ~layout ~defined_label ?label ~dest ?title ())
+ ( (uri, meta),
+ Link_definition.make ~layout ~defined_label ?label ~dest ?title () )
let handle_image_inlining m defs current_path ((l, (attrs, meta2)), meta) =
let text = Inline.Link.text l in
@@ -182,7 +196,7 @@ module Stage1 = struct
in
let kind = classify_link_definition ld attrs in
let attrs_ld = Mapper.map_attrs m attrs_ld in
- let dest, ld = update_link_definition current_path ld in
+ let dest, ld = update_link_definition current_path (ld, meta) in
Some (kind, ((ld, (attrs_ld, meta2)), meta), dest)
in
let reference = `Inline ld in
@@ -250,14 +264,14 @@ module Stage1 = struct
let res = List.filter_map div res in
Mapper.ret @@ Block.Blocks (res, meta)
- let execute defs read_file =
+ let execute ~htbl_include defs read_file =
let current_path = Path_entering.make () in
let block m = function
| Block.Blocks bs -> handle_dash_separated_blocks m bs
| Block.Block_quote bq -> turn_block_quotes_into_divs m bq
| Block.Code_block cb -> handle_slip_scripts_creation m cb
| Block.Ext_standalone_attributes sa ->
- handle_includes read_file current_path m sa
+ handle_includes ~htbl_include read_file current_path m sa
| _ -> Mapper.default
in
let inline i = function
@@ -313,128 +327,14 @@ module Stage1 = struct
Ast.Mapper.make ~block ~inline ~attrs ()
let execute defs read_file md =
- Cmarkit.Mapper.map_doc (execute defs read_file) md
+ let htbl_include = Hashtbl.create 3 in
+ let res =
+ Cmarkit.Mapper.map_doc (execute ~htbl_include defs read_file) md
+ in
+ (res, htbl_include)
end
module Stage2 = struct
- (** Get the attributes of a cmarkit node, returns them and the element
- stripped of its attributes *)
- let get_attribute =
- let no_attrs = (Attributes.empty, Meta.none) in
- function
- (* Standard Cmarkit nodes *)
- | Block.Blank_line _ -> None
- | Block.Block_quote ((bq, attrs), meta) ->
- Some (Block.Block_quote ((bq, no_attrs), meta), attrs)
- | Block.Blocks _ -> None
- | Block.Code_block ((cb, attrs), meta) ->
- Some (Block.Code_block ((cb, no_attrs), meta), attrs)
- | Block.Heading ((h, attrs), meta) ->
- Some (Block.Heading ((h, no_attrs), meta), attrs)
- | Block.Html_block ((hb, attrs), meta) ->
- Some (Block.Html_block ((hb, no_attrs), meta), attrs)
- | Block.Link_reference_definition _ -> None
- | Block.List ((l, attrs), meta) ->
- Some (Block.List ((l, no_attrs), meta), attrs)
- | Block.Paragraph ((p, attrs), meta) ->
- Some (Block.Paragraph ((p, no_attrs), meta), attrs)
- | Block.Thematic_break ((tb, attrs), meta) ->
- Some (Block.Thematic_break ((tb, no_attrs), meta), attrs)
- (* Extension Cmarkit nodes *)
- | Block.Ext_math_block ((mb, attrs), meta) ->
- Some (Block.Ext_math_block ((mb, no_attrs), meta), attrs)
- | Block.Ext_table ((table, attrs), meta) ->
- Some (Block.Ext_table ((table, no_attrs), meta), attrs)
- | Block.Ext_footnote_definition _ -> None
- | Block.Ext_standalone_attributes _ -> None
- | Block.Ext_attribute_definition _ -> None
- (* Slipshow nodes *)
- | Ast.S_block b -> (
- match b with
- | Included ((inc, attrs), meta) ->
- Some (Ast.included ((inc, no_attrs), meta), attrs)
- | Div ((div, attrs), meta) ->
- Some (Ast.div ((div, no_attrs), meta), attrs)
- | Slide ((slide, attrs), meta) ->
- Logs.err (fun m ->
- m
- "Slides should not appear here, this is an error on \
- slipshow's side. Please report!");
- Some (Ast.slide ((slide, no_attrs), meta), attrs)
- | Slip ((slip, attrs), meta) ->
- Logs.err (fun m ->
- m
- "Slips should not appear here, this is an error on \
- slipshow's side. Please report!");
- Some (Ast.slip ((slip, no_attrs), meta), attrs)
- | SlipScript ((slscr, attrs), meta) ->
- Some (Ast.slipscript ((slscr, no_attrs), meta), attrs)
- | MermaidJS ((slscr, attrs), meta) ->
- Some (Ast.mermaid_js ((slscr, no_attrs), meta), attrs)
- | Carousel ((c, attrs), meta) ->
- Some (Ast.carousel ((c, no_attrs), meta), attrs))
- | _ -> None
-
- (** Get the attributes of a cmarkit node, returns them and the element
- stripped of its attributes *)
- let merge_attribute new_attrs b =
- let merge base =
- Attributes.merge ~base ~new_attrs
- (* Old attributes take precendence over "new" one *)
- in
- match b with
- (* Standard Cmarkit nodes *)
- | Block.Blank_line _ | Block.Blocks _ -> b
- | Block.Block_quote ((bq, (attrs, meta_a)), meta) ->
- Block.Block_quote ((bq, (merge attrs, meta_a)), meta)
- | Block.Code_block ((cb, (attrs, meta_a)), meta) ->
- Block.Code_block ((cb, (merge attrs, meta_a)), meta)
- | Block.Heading ((h, (attrs, meta_a)), meta) ->
- Block.Heading ((h, (merge attrs, meta_a)), meta)
- | Block.Html_block ((hb, (attrs, meta_a)), meta) ->
- Block.Html_block ((hb, (merge attrs, meta_a)), meta)
- | Block.Link_reference_definition _ -> b
- | Block.List ((l, (attrs, meta_a)), meta) ->
- Block.List ((l, (merge attrs, meta_a)), meta)
- | Block.Paragraph ((p, (attrs, meta_a)), meta) ->
- Block.Paragraph ((p, (merge attrs, meta_a)), meta)
- | Block.Thematic_break ((tb, (attrs, meta_a)), meta) ->
- Block.Thematic_break ((tb, (merge attrs, meta_a)), meta)
- (* Extension Cmarkit nodes *)
- | Block.Ext_math_block ((mb, (attrs, meta_a)), meta) ->
- Block.Ext_math_block ((mb, (merge attrs, meta_a)), meta)
- | Block.Ext_table ((table, (attrs, meta_a)), meta) ->
- Block.Ext_table ((table, (merge attrs, meta_a)), meta)
- | Block.Ext_footnote_definition _ -> b
- | Block.Ext_standalone_attributes _ -> b
- | Block.Ext_attribute_definition _ -> b
- (* Slipshow nodes *)
- | Ast.S_block b -> (
- match b with
- | Included ((inc, (attrs, meta_a)), meta) ->
- Ast.included ((inc, (merge attrs, meta_a)), meta)
- | Div ((div, (attrs, meta_a)), meta) ->
- Ast.div ((div, (merge attrs, meta_a)), meta)
- | Slide ((slide, (attrs, meta_a)), meta) ->
- Logs.err (fun m ->
- m
- "Slides should not appear here, this is an error on \
- slipshow's side. Please report!");
- Ast.slide ((slide, (merge attrs, meta_a)), meta)
- | Slip ((slip, (attrs, meta_a)), meta) ->
- Logs.err (fun m ->
- m
- "Slips should not appear here, this is an error on \
- slipshow's side. Please report!");
- Ast.slip ((slip, (merge attrs, meta_a)), meta)
- | SlipScript ((slscr, (attrs, meta_a)), meta) ->
- Ast.slipscript ((slscr, (merge attrs, meta_a)), meta)
- | MermaidJS ((slscr, (attrs, meta_a)), meta) ->
- Ast.mermaid_js ((slscr, (merge attrs, meta_a)), meta)
- | Carousel ((c, (attrs, meta_a)), meta) ->
- Ast.carousel ((c, (merge attrs, meta_a)), meta))
- | _ -> b
-
let execute =
let block m c =
match c with
@@ -462,13 +362,19 @@ module Stage2 = struct
match (categorize key, value) with
| `Class c, None -> Attributes.add_class acc (c, meta)
| `Kv c, _ -> Attributes.add (c, meta) value acc
- | `Class c, Some _ ->
- Logs.warn (fun m ->
- m "Children classes cannot have a value");
+ | `Class c, Some (_, v_meta) ->
+ Diagnosis.add
+ (General
+ {
+ msg = "Children classes cannot have a value";
+ labels = [ ("", Meta.textloc v_meta) ];
+ notes = [];
+ code = "ChildrenAttrs";
+ });
Attributes.add (c, meta) value acc))
Attributes.empty kvs
in
- let bs = List.map (merge_attribute new_attrs) bs in
+ let bs = List.map (Ast.Utils.Block.merge_attribute new_attrs) bs in
let bs =
match Mapper.map_block m (Block.Blocks (bs, m_bs)) with
| None -> Block.Blocks ([], m_bs)
@@ -513,30 +419,34 @@ module Stage3 = struct
in
let attrs =
if
- (Attributes.mem "no-enter" attrs
- || Attributes.mem "enter-at-unpause" attrs)
+ (Attributes.mem Special_attrs.no_enter attrs
+ || Attributes.mem Actions_arguments.Enter.on attrs)
|| not may_enter
then attrs
- else Attributes.add ("enter-at-unpause", Meta.none) None attrs
+ else Attributes.add (Actions_arguments.Enter.on, Meta.none) None attrs
in
let attrs = Mapper.map_attrs m attrs in
(b, (attrs, meta2))
in
- match Stage2.get_attribute c with
+ match Ast.Utils.Block.get_attribute c with
| None -> Mapper.default
- | Some (block, (attrs, meta2)) when Attributes.mem "blockquote" attrs ->
+ | Some (block, (attrs, meta2))
+ when Attributes.mem Special_attrs.blockquote attrs ->
let block, attrs = map ~may_enter:false block (attrs, meta2) in
let block = Block.Block_quote.make block in
Mapper.ret @@ Block.Block_quote ((block, attrs), Meta.none)
- | Some (block, (attrs, meta2)) when Attributes.mem "slide" attrs ->
+ | Some (block, (attrs, meta2))
+ when Attributes.mem Special_attrs.slide attrs ->
let block, attrs = map ~may_enter:true block (attrs, meta2) in
let block, title = extract_title block in
Mapper.ret
@@ Ast.slide (({ content = block; title }, attrs), Meta.none)
- | Some (block, (attrs, meta2)) when Attributes.mem "slip" attrs ->
+ | Some (block, (attrs, meta2))
+ when Attributes.mem Special_attrs.slip attrs ->
let block, (attrs, meta) = map ~may_enter:true block (attrs, meta2) in
Mapper.ret @@ Ast.slip ((block, (attrs, meta)), Meta.none)
- | Some (block, (attrs, meta2)) when Attributes.mem "carousel" attrs ->
+ | Some (block, (attrs, meta2))
+ when Attributes.mem Special_attrs.carousel attrs ->
let block, attrs = map ~may_enter:false block (attrs, meta2) in
let children =
match block with
@@ -562,60 +472,154 @@ module Stage4 = struct
Fpath.Map.update x add m
let execute =
- let block _f _acc _c = Folder.default in
- let inline _f acc = function
- | Ast.S_inline i -> (
- match i with
- | Video media
- | Pdf media
- | Audio media
- | Hand_drawn media
- | Svg media
- | Image media -> (
- match media with
- | { uri = Path p; id; _ } ->
- Folder.ret @@ fpath_map_add_to_list p id acc
- | _ -> Folder.default))
- | _ -> Folder.default
+ let block f (x, id_list) c =
+ let acc =
+ match Ast.Utils.Block.get_attribute c with
+ | None -> (x, id_list)
+ | Some (_, (attrs, meta)) -> (
+ match Attributes.id attrs with
+ | None -> (x, id_list)
+ | Some id -> (x, (id, `Block c, meta) :: id_list))
+ in
+ let res = Ast.Folder.continue_block f c acc in
+ Folder.ret res
+ in
+ let inline f (acc, id_list) i =
+ let id_list =
+ match Ast.Utils.Inline.get_attribute i with
+ | None -> id_list
+ | Some (_, (attrs, meta)) -> (
+ match Attributes.id attrs with
+ | None -> id_list
+ | Some id -> (id, `Inline i, meta) :: id_list)
+ in
+ let acc =
+ match i with
+ | Ast.S_inline i -> (
+ match i with
+ | Video media
+ | Pdf media
+ | Audio media
+ | Hand_drawn media
+ | Svg media
+ | Image media -> (
+ match media with
+ | { uri = Path p, meta; id; origin } ->
+ fpath_map_add_to_list p (id, (origin, meta)) acc
+ | _ -> acc))
+ | _ -> acc
+ in
+ let acc = Ast.Folder.continue_inline f i (acc, id_list) in
+ Folder.ret acc
in
Ast.Folder.make ~block ~inline ()
- let execute ~read_file md =
- let asset_map = Cmarkit.Folder.fold_doc execute Fpath.Map.empty md in
+ let execute ~(fm : Frontmatter.resolved Frontmatter.t) ~read_file md =
+ let (Frontmatter.Resolved fm) = fm in
+ let external_ids =
+ fm.external_ids
+ |> List.map (fun x -> ((x, Meta.none), `External, Meta.none))
+ in
+ let asset_map, id_list =
+ Cmarkit.Folder.fold_doc execute (Fpath.Map.empty, external_ids) md
+ in
+ let id_list = List.rev id_list in
+ let module Map = Map.Make (String) in
+ let id_map =
+ List.fold_left
+ (fun acc (((id, _meta1), _b1, _meta_attrs) as value) ->
+ Map.update id
+ (function
+ | None -> Some [ value ] | Some same -> Some (value :: same))
+ acc)
+ Map.empty id_list
+ in
+ let id_map =
+ Map.filter_map
+ (fun id list ->
+ match list with
+ | [] -> assert false
+ | [ x ] -> Some x
+ | x :: _ :: _ ->
+ let occurrences =
+ List.map
+ (fun ((_id, meta1), _b1, _meta_attrs) -> Meta.textloc meta1)
+ list
+ in
+ Diagnosis.add @@ DuplicateID { id; occurrences };
+ Some x)
+ id_map
+ in
let files =
Fpath.Map.filter_map
(fun path used_by ->
let read_file : file_reader = read_file in
let mode = `Base64 in
match read_file path with
- | Ok (Some content) -> Some { Ast.Files.content; mode; used_by; path }
+ | Ok (Some content) ->
+ let used_by = List.map fst used_by in
+ Some { Ast.Files.content; mode; used_by; path }
| Ok None -> None
- | Error (`Msg s) ->
- Logs.warn (fun m ->
- m "Could not read file: %a. Considering it as an URL. (%s)"
- Fpath.pp path s);
+ | Error (`Msg error_msg) ->
+ let locs =
+ List.map (fun (_id, (_node, meta)) -> Meta.textloc meta) used_by
+ in
+ Diagnosis.add
+ (MissingFile { file = Fpath.to_string path; error_msg; locs });
None)
asset_map
in
- { Ast.doc = md; files }
+ ({ Ast.doc = md; files }, id_map)
+end
+
+module Stage5 = struct
+ module M = Map.Make (String)
+
+ let check_attribute ~id_map block_or_inline (attrs, _meta) =
+ List.iter (fun check -> check id_map attrs block_or_inline) Check.all_checks
+
+ let folder ~id_map =
+ let block _f () c =
+ let () =
+ match Ast.Utils.Block.get_attribute c with
+ | None -> ()
+ | Some (_, attrs) -> check_attribute ~id_map (`Block c) attrs
+ in
+ Folder.default
+ in
+ let inline _f () i =
+ let () =
+ match Ast.Utils.Inline.get_attribute i with
+ | None -> ()
+ | Some (_, attrs) -> check_attribute ~id_map (`Inline i) attrs
+ in
+ Folder.default
+ in
+ Ast.Folder.make ~block ~inline ()
+
+ let execute ~id_map ast =
+ let () = Cmarkit.Folder.fold_doc (folder ~id_map) () ast.Ast.doc in
+ ast
end
-let of_cmarkit ~read_file md =
+let of_cmarkit ~read_file ~(fm : Frontmatter.resolved Frontmatter.t) md =
let defs = Cmarkit.Doc.defs md in
- let md1 = Stage1.execute defs read_file md in
+ let md1, htbl_include = Stage1.execute defs read_file md in
let md2 = Stage2.execute md1 in
let md3 = Stage3.execute md2 in
- Stage4.execute ~read_file md3
+ let md4, id_map = Stage4.execute ~read_file ~fm md3 in
+ (Stage5.execute ~id_map md4, htbl_include)
-let compile ~attrs ?(read_file = fun _ -> Ok None) s =
+let compile ?file ?loc_offset ~attrs ~fm ?(read_file = fun _ -> Ok None) s =
+ Diagnosis.with_ @@ fun () ->
let open Cmarkit in
let md =
- let doc = Doc.of_string ~heading_auto_ids:false ~strict:false s in
+ let doc = Cmarkit_proxy.of_string ?loc_offset ~file s in
let bq = Block.Block_quote.make (Doc.block doc) in
let block = Block.Block_quote ((bq, (attrs, Meta.none)), Meta.none) in
Doc.make block
in
- of_cmarkit ~read_file md
+ of_cmarkit ~read_file ~fm md
let to_cmarkit =
let ( let* ) x f = Option.bind x f in
diff --git a/src/compiler/compile.mli b/src/compiler/compile.mli
index d938c0bc..6ecb58a7 100644
--- a/src/compiler/compile.mli
+++ b/src/compiler/compile.mli
@@ -1,7 +1,18 @@
type file_reader = Fpath.t -> (string option, [ `Msg of string ]) result
-val of_cmarkit : read_file:file_reader -> Cmarkit.Doc.t -> Ast.t
+val of_cmarkit :
+ read_file:file_reader ->
+ fm:Frontmatter.resolved Frontmatter.t ->
+ Cmarkit.Doc.t ->
+ Ast.t * (string, string) Hashtbl.t
+
val to_cmarkit : Ast.t -> Cmarkit.Doc.t
val compile :
- attrs:Cmarkit.Attributes.t -> ?read_file:file_reader -> string -> Ast.t
+ ?file:string ->
+ ?loc_offset:int * int ->
+ attrs:Cmarkit.Attributes.t ->
+ fm:Frontmatter.resolved Frontmatter.t ->
+ ?read_file:file_reader ->
+ string ->
+ (Ast.t * (string, string) Hashtbl.t) * Diagnosis.t list
diff --git a/src/compiler/dune b/src/compiler/dune
index e8f5b781..c8497fe5 100644
--- a/src/compiler/dune
+++ b/src/compiler/dune
@@ -11,4 +11,6 @@
bos
highlightjs
katex
- mermaid))
+ mermaid
+ actions_arguments
+ diagnosis))
diff --git a/src/compiler/frontmatter.ml b/src/compiler/frontmatter.ml
index 84e10261..32bdce4a 100644
--- a/src/compiler/frontmatter.ml
+++ b/src/compiler/frontmatter.ml
@@ -10,27 +10,17 @@ type 'a fm = {
dimension : (int * int) option;
highlightjs_theme : string option;
math_mode : [ `Mathjax | `Katex ] option;
+ external_ids : string list;
}
(** We keep an option even though there are default value to be able to merge
two frontmatter. None and default value represent different things. *)
-type 'a t =
- | Unresolved : string fm -> unresolved t
- | Resolved : Asset.t fm -> resolved t
-
-let resolve (Unresolved fm) ~to_asset =
- Resolved
- {
- fm with
- math_link = Option.map to_asset fm.math_link;
- css_links = List.map to_asset fm.css_links;
- js_links = List.map to_asset fm.js_links;
- }
+module Toplevel_attributes = struct
+ type t = Cmarkit.Attributes.t
-module Default = struct
- let dimension = (1440, 1080)
+ let key = "toplevel-attributes"
- let toplevel_attributes =
+ let default =
Cmarkit.Attributes.make
~kv_attributes:
[
@@ -40,31 +30,11 @@ module Default = struct
]
()
- let theme = `Builtin Themes.Default
- let highlightjs_theme = "default"
- let math_mode = `Mathjax
-end
-
-let empty =
- Resolved
- {
- dimension = None;
- toplevel_attributes = None;
- math_link = None;
- theme = None;
- css_links = [];
- js_links = [];
- highlightjs_theme = None;
- math_mode = None;
- }
-
-module String_to = struct
- let toplevel_attributes s =
+ let of_string s =
let s = String.trim s in
let s =
if String.length s > 0 && s.[0] = '{' then
- (* Just so emacs does not find an unmatched curly brace! *)
- let _ = '}' in
+ (* Just so emacs does not find an unmatched curly brace: '}'! *)
s
else "{" ^ s ^ "}"
in
@@ -72,23 +42,68 @@ module String_to = struct
let cmarkit = Cmarkit.Doc.block cmarkit in
match cmarkit with
| Cmarkit.Block.Ext_standalone_attributes (attrs, _) -> Ok attrs
- | _ -> Error (`Msg "Can only be a set of attributes")
+ | _ -> Error (`Msg "Failed to parse the attributes")
- let math_link s = s
+ let update_frontmatter (fm : _ fm) v =
+ { fm with toplevel_attributes = Some v }
+end
- let math_mode = function
- | "mathjax" -> Ok `Mathjax
- | "katex" -> Ok `Katex
- | _ -> Error (`Msg "Expected \"mathjax\" or \"katex\"")
+module Math_link = struct
+ type t = string
+
+ let key = "math-link"
+ let of_string s = Ok s
+ let update_frontmatter (fm : _ fm) v = { fm with math_link = Some v }
+end
+
+module Theme = struct
+ type t = [ `Builtin of Themes.t | `External of string ]
+
+ let key = "theme"
+ let default = `Builtin Themes.Default
- let theme s =
+ let of_string s =
match Themes.of_string s with
- | Some theme -> `Builtin theme
- | None -> `External s
+ | Some theme -> Ok (`Builtin theme)
+ | None -> Ok (`External s)
+
+ let update_frontmatter (fm : _ fm) v = { fm with theme = Some v }
+end
+
+module Css_links = struct
+ type t = string list
+
+ let key = "css"
+
+ let of_string s =
+ s |> String.split_on_char ' '
+ |> List.filter (fun x -> not (String.equal "" x))
+ |> Result.ok
+
+ let update_frontmatter (fm : _ fm) v =
+ { fm with css_links = v @ fm.css_links }
+end
+
+module Js_links = struct
+ type t = string list
+
+ let key = "js"
- let css_link s = s
+ let of_string s =
+ s |> String.split_on_char ' '
+ |> List.filter (fun x -> not (String.equal "" x))
+ |> Result.ok
- let dimension s =
+ let update_frontmatter (fm : _ fm) v = { fm with js_links = v @ fm.js_links }
+end
+
+module Dimension = struct
+ type t = int * int
+
+ let key = "dimension"
+ let default = (1440, 1080)
+
+ let of_string s =
let ( let* ) = Result.bind in
let error =
Error
@@ -105,63 +120,185 @@ module String_to = struct
let* height = int_parser height in
Ok (width, height)
| _ -> error
+
+ let update_frontmatter (fm : _ fm) v = { fm with dimension = Some v }
end
-let get (field_name, convert) kv =
- List.assoc_opt field_name kv |> Option.map convert
+module Hljs_theme = struct
+ type t = string
-let cut s c =
- String.index_opt s c
- |> Option.map @@ fun idx ->
- ( String.sub s 0 idx,
- String.trim @@ String.sub s (idx + 1) (String.length s - (idx + 1)) )
+ let key = "highlightjs-theme"
+ let of_string = fun x -> Ok x
+ let default = "default"
+ let update_frontmatter (fm : _ fm) v = { fm with highlightjs_theme = Some v }
+end
-let of_string s =
- let assoc =
- s |> String.split_on_char '\n'
- |> List.filter_map @@ fun line ->
- let line = String.trim line in
- cut line ':'
- in
- let get x y =
- match get x y with
- | Some (Ok x) -> Some x
- | Some (Error (`Msg x)) ->
- Logs.warn (fun m -> m "Error in frontmatter: %s" x);
- None
- | None -> None
+module Math_mode = struct
+ type t = [ `Mathjax | `Katex ]
+
+ let key = "math-mode"
+
+ let of_string = function
+ | "mathjax" -> Ok `Mathjax
+ | "katex" -> Ok `Katex
+ | _ -> Error (`Msg "Expected \"mathjax\" or \"katex\"")
+
+ let default = `Mathjax
+ let update_frontmatter (fm : _ fm) v = { fm with math_mode = Some v }
+end
+
+module type Field = sig
+ type t
+
+ val key : string
+ val of_string : string -> (t, [ `Msg of string ]) result
+ val update_frontmatter : string fm -> t -> string fm
+end
+
+module External_ids = struct
+ type t = string list
+
+ let key = "external-ids"
+
+ let of_string s =
+ String.split_on_char ' ' s
+ |> List.filter (fun x -> not @@ String.equal String.empty x)
+ |> Result.ok
+
+ let update_frontmatter (fm : _ fm) v =
+ { fm with external_ids = v @ fm.external_ids }
+end
+
+let all_fields =
+ [
+ (module Dimension : Field);
+ (module Toplevel_attributes : Field);
+ (module Math_link : Field);
+ (module Theme : Field);
+ (module Css_links : Field);
+ (module Js_links : Field);
+ (module Hljs_theme : Field);
+ (module Math_mode : Field);
+ (module External_ids : Field);
+ ]
+
+module SMap = struct
+ include Map.Make (String)
+
+ (* Not included before OCaml 5.1 *)
+ let of_list bs = List.fold_left (fun m (k, v) -> add k v m) empty bs
+end
+
+let fields_map =
+ all_fields
+ |> List.map (fun ((module X : Field) as m) -> (X.key, m))
+ |> SMap.of_list
+
+let fields_names = all_fields |> List.map (fun (module X : Field) -> X.key)
+
+type 'a t =
+ | Unresolved : string fm -> unresolved t
+ | Resolved : Asset.t fm -> resolved t
+
+let resolve (Unresolved fm) ~to_asset =
+ Resolved
+ {
+ fm with
+ math_link = Option.map to_asset fm.math_link;
+ css_links = List.map to_asset fm.css_links;
+ js_links = List.map to_asset fm.js_links;
+ }
+
+let empty_fm =
+ {
+ dimension = None;
+ toplevel_attributes = None;
+ math_link = None;
+ theme = None;
+ css_links = [];
+ js_links = [];
+ highlightjs_theme = None;
+ math_mode = None;
+ external_ids = [];
+ }
+
+let empty = Resolved empty_fm
+
+(* let get (field_name, convert) kv = *)
+(* List.assoc_opt field_name kv |> Option.map convert *)
+
+let string_sub s idx idx' = (String.sub s idx idx', (idx, idx + idx' - 1))
+
+let split_in_lines s =
+ let accumulate n (start_loc : int) i acc =
+ if start_loc = i then acc else (n, (start_loc, i)) :: acc
in
- let toplevel_attributes =
- get ("toplevel-attributes", String_to.toplevel_attributes) assoc
+ let rec loop acc start_loc n i =
+ match s.[i] with
+ | exception _ -> accumulate n start_loc i acc
+ | '\r' when i + 1 < String.length s && s.[i + 1] = '\n' ->
+ loop (accumulate n start_loc i acc) (i + 2) (n + 1) (i + 2)
+ | '\n' -> loop (accumulate n start_loc i acc) (i + 1) (n + 1) (i + 1)
+ | _ -> loop acc start_loc n (i + 1)
in
- let math_link =
- get ("math-link", fun x -> Ok (String_to.math_link x)) assoc
+ loop [] 0 1 0
+ |> List.rev_map (fun (n, (x, y)) -> (n, String.sub s x (y - x), (x, y)))
+
+let cut file offset (i, line, (byte_start, _)) c =
+ let i = i + 1 in
+ let byte_start = byte_start + offset in
+ let update_loc (beg, end_) =
+ Cmarkit.Textloc.v ~file ~first_line:(i, byte_start)
+ ~last_line:(i, byte_start) ~first_byte:(beg + byte_start)
+ ~last_byte:(end_ + byte_start)
in
- let math_mode = get ("math-mode", String_to.math_mode) assoc in
- let theme = get ("theme", fun x -> Ok (String_to.theme x)) assoc in
- let highlightjs_theme = get ("highlightjs-theme", fun x -> Ok x) assoc in
- let files field =
- get (field, fun x -> Ok x) assoc
- |> Option.map (fun x -> String.split_on_char ' ' x)
- |> Option.map @@ List.filter (fun x -> not (String.equal " " x))
- |> Option.value ~default:[]
+ String.index_opt line c
+ |> Option.map @@ fun idx ->
+ let key, kloc = string_sub line 0 idx in
+ let key = (String.trim key, update_loc kloc) in
+ let v, loc = string_sub line (idx + 1) (String.length line - (idx + 1)) in
+ let v = (String.trim v, update_loc loc) in
+ (key, v)
+
+let send_unrecognized_field ~key ~kloc =
+ let msg = "Frontmatter field '" ^ key ^ "' is not interpreted by slipshow" in
+ let n =
+ "Recognized fields are: '" ^ String.concat "', '" fields_names ^ "'"
in
- let css_links = files "css" in
- let js_links = files "js" in
- let dimension = get ("dimension", String_to.dimension) assoc in
- Ok
- (Unresolved
+ Diagnosis.add
+ (General
+ { msg; notes = [ n ]; labels = [ ("", kloc) ]; code = "Frontmatter" })
+
+let send_general_error ~key ~msg ~vloc =
+ Diagnosis.add
+ (General
{
- toplevel_attributes;
- math_link;
- theme;
- css_links;
- dimension;
- js_links;
- highlightjs_theme;
- math_mode;
+ msg = "Error while parsing frontmatter field '" ^ key ^ "'";
+ notes = [];
+ labels = [ (msg, vloc) ];
+ code = "Frontmatter";
})
+let of_string file offset s =
+ let assoc =
+ s |> split_in_lines
+ |> List.filter_map @@ fun line -> cut file offset line ':'
+ in
+ let handle_line fm ((key, kloc), (value, vloc)) =
+ match SMap.find_opt key fields_map with
+ | None ->
+ send_unrecognized_field ~key ~kloc;
+ fm
+ | Some (module F) -> (
+ match F.of_string value with
+ | Ok x -> F.update_frontmatter fm x
+ | Error (`Msg msg) ->
+ send_general_error ~key ~msg ~vloc;
+ fm)
+ in
+ let fm = List.fold_left handle_line empty_fm assoc in
+ Unresolved fm
+
let ( let* ) x f = Option.bind x f
let ( let+ ) x f = Option.map f x
@@ -196,7 +333,16 @@ let extract s =
let+ end_, after = find_closing s start in
let frontmatter = String.sub s start (end_ - start) in
let rest = String.sub s after (String.length s - after) in
- (frontmatter, rest)
+ let offset =
+ let rec n_lines acc index =
+ if index < 0 then acc
+ else
+ let acc = if s.[index] = '\n' then acc + 1 else acc in
+ n_lines acc (index - 1)
+ in
+ (after, n_lines 0 (after - 1))
+ in
+ (frontmatter, rest, offset, start)
let combine (Resolved cli_frontmatter) (Resolved frontmatter) =
let combine_opt cli f = match cli with Some _ as x -> x | None -> f in
@@ -214,6 +360,7 @@ let combine (Resolved cli_frontmatter) (Resolved frontmatter) =
let highlightjs_theme =
combine_opt cli_frontmatter.highlightjs_theme frontmatter.highlightjs_theme
in
+ let external_ids = cli_frontmatter.external_ids @ frontmatter.external_ids in
Resolved
{
toplevel_attributes;
@@ -224,4 +371,5 @@ let combine (Resolved cli_frontmatter) (Resolved frontmatter) =
js_links;
highlightjs_theme;
math_mode;
+ external_ids;
}
diff --git a/src/compiler/frontmatter.mli b/src/compiler/frontmatter.mli
index afccc8b4..057035af 100644
--- a/src/compiler/frontmatter.mli
+++ b/src/compiler/frontmatter.mli
@@ -10,6 +10,7 @@ type 'a fm = {
dimension : (int * int) option;
highlightjs_theme : string option;
math_mode : [ `Mathjax | `Katex ] option;
+ external_ids : string list;
}
(** We use this trick to only allow [string fm] and [Asset.t fm], but it is
@@ -19,34 +20,38 @@ type 'a t =
| Unresolved : string fm -> unresolved t
| Resolved : Asset.t fm -> resolved t
-module Default : sig
- val dimension : int * int
- val toplevel_attributes : Cmarkit.Attributes.t
- val theme : [> `Builtin of Themes.t ]
- val highlightjs_theme : string
- val math_mode : [ `Mathjax | `Katex ]
+module type Field = sig
+ type t
+
+ val key : string
+ val of_string : string -> (t, [ `Msg of string ]) result
+ val update_frontmatter : string fm -> t -> string fm
end
-val empty : resolved t
+module type Field_with_default := sig
+ include Field
-module String_to : sig
- (** This is used to convert each field from a string to its unresolved ocaml
- value. Used internally by {!extract}, but also externally by the CLI
- converters. *)
+ val default : t
+end
- val toplevel_attributes :
- string -> (Cmarkit.Attributes.t, [> `Msg of string ]) result
+module Toplevel_attributes :
+ Field_with_default with type t = Cmarkit.Attributes.t
- val math_link : string -> string
- val theme : string -> [> `Builtin of Themes.t | `External of string ]
- val css_link : string -> string
- val dimension : string -> (int * int, [> `Msg of string ]) result
- val math_mode : string -> ([ `Katex | `Mathjax ], [ `Msg of string ]) result
-end
+module Math_link : Field with type t = string
-val of_string : string -> (unresolved t, [> `Msg of string ]) result
+module Theme :
+ Field_with_default with type t = [ `Builtin of Themes.t | `External of string ]
+
+module Css_links : Field with type t = string list
+module Js_links : Field with type t = string list
+module Dimension : Field_with_default with type t = int * int
+module Hljs_theme : Field_with_default with type t = string
+module Math_mode : Field_with_default with type t = [ `Mathjax | `Katex ]
+
+val empty : resolved t
+val of_string : string -> int -> string -> unresolved t
-val extract : string -> (string * string) option
+val extract : string -> (string * string * (int * int) * int) option
(** The first string is the frontmatter, the second one the original string with
the frontmatter and separator stripped *)
diff --git a/src/compiler/renderers.ml b/src/compiler/renderers.ml
index c0ed1cce..eb2d9edb 100644
--- a/src/compiler/renderers.ml
+++ b/src/compiler/renderers.ml
@@ -212,22 +212,22 @@ let custom_html_renderer (files : Ast.Files.map) =
let default = renderer ~safe:false () in
let custom_html =
let inline c = function
- | Ast.Pdf { uri; id = _; origin = (l, (attrs, _)), _ } ->
+ | Ast.Pdf { uri = uri, _; id = _; origin = (l, (attrs, _)), _ } ->
pdf c ~uri ~files l attrs;
true
- | Ast.Video { uri; id = _; origin = (l, (attrs, _)), _ } ->
+ | Ast.Video { uri = uri, _; id = _; origin = (l, (attrs, _)), _ } ->
media ~media_name:"video" c ~uri ~files l attrs;
true
- | Ast.Image { uri; id = _; origin = (l, (attrs, _)), _ } ->
+ | Ast.Image { uri = uri, _; id = _; origin = (l, (attrs, _)), _ } ->
media ~media_name:"img" c ~uri ~files l attrs;
true
- | Ast.Svg { uri; id = _; origin = (l, (attrs, _)), _ } ->
+ | Ast.Svg { uri = uri, _; id = _; origin = (l, (attrs, _)), _ } ->
svg c ~uri ~files l attrs;
true
- | Ast.Audio { uri; id = _; origin = (l, (attrs, _)), _ } ->
+ | Ast.Audio { uri = uri, _; id = _; origin = (l, (attrs, _)), _ } ->
media ~media_name:"audio" c ~uri ~files l attrs;
true
- | Ast.Hand_drawn { uri; id = _; origin = (_, (attrs, _)), _ } ->
+ | Ast.Hand_drawn { uri = uri, _; id = _; origin = (_, (attrs, _)), _ } ->
let attrs =
Attributes.add_class attrs ("slipshow-hand-drawn", Meta.none)
in
diff --git a/src/compiler/slipshow.ml b/src/compiler/slipshow.ml
index c3c91da8..833e4dcb 100644
--- a/src/compiler/slipshow.ml
+++ b/src/compiler/slipshow.ml
@@ -244,62 +244,96 @@ let string_to_delayed s =
Marshal.from_string s 0
let convert_to_md ~read_file content =
+ let (fm, content, loc_offset), _warnings =
+ Diagnosis.with_ @@ fun () ->
+ match Frontmatter.extract content with
+ | None -> (Frontmatter.empty, content, (0, 0))
+ | Some (yaml, s, offset, start) ->
+ let file = "-" in
+ let frontmatter = Frontmatter.of_string file start yaml in
+ let to_asset = Asset.of_string ~read_file in
+ let frontmatter = Frontmatter.resolve frontmatter ~to_asset in
+ (frontmatter, s, offset)
+ in
let md =
- Cmarkit.Doc.of_string ~heading_auto_ids:false ~strict:false content
+ Cmarkit.Doc.of_string ~loc_offset ~heading_auto_ids:false ~strict:false
+ content
in
- let sd = Compile.of_cmarkit ~read_file md in
+ let sd, _htbl_include = Compile.of_cmarkit ~read_file ~fm md in
let sd = Compile.to_cmarkit sd in
Cmarkit_commonmark.of_doc ~include_attributes:false sd
-let delayed ?slipshow_js ?(frontmatter = Frontmatter.empty)
+let to_grace file whole_content htbl_include er =
+ Diagnosis.to_grace
+ (fun f ->
+ if file = Some f then
+ Grace.Source.(`String { name = file; content = whole_content })
+ else
+ match Hashtbl.find_opt htbl_include f with
+ | Some content -> Grace.Source.(`String { name = file; content })
+ | None ->
+ Grace.Source.(`String { name = file; content = whole_content }))
+ er
+
+let delayed ?slipshow_js ?(frontmatter = Frontmatter.empty) ?file
?(read_file = fun _ -> Ok None) ~has_speaker_view s =
- let Frontmatter.Resolved frontmatter, s =
- let ( let* ) x f =
- match x with
- | Ok x -> f x
- | Error (`Msg err) ->
- Logs.err (fun m -> m "Failed to parse the frontmatter: %s" err);
- (frontmatter, s)
- in
+ let whole_content = s in
+ let (Frontmatter.Resolved frontmatter, s, loc_offset), warnings =
+ Diagnosis.with_ @@ fun () ->
match Frontmatter.extract s with
- | None -> (frontmatter, s)
- | Some (yaml, s) ->
- let* txt_frontmatter = Frontmatter.of_string yaml in
+ | None -> (frontmatter, s, (0, 0))
+ | Some (yaml, s, offset, start) ->
+ let file = Option.value ~default:"-" file in
+ let txt_frontmatter = Frontmatter.of_string file start yaml in
let to_asset = Asset.of_string ~read_file in
let txt_frontmatter = Frontmatter.resolve txt_frontmatter ~to_asset in
let frontmatter = Frontmatter.combine txt_frontmatter frontmatter in
- (frontmatter, s)
+ (frontmatter, s, offset)
in
let toplevel_attributes =
frontmatter.toplevel_attributes
- |> Option.value ~default:Frontmatter.Default.toplevel_attributes
+ |> Option.value ~default:Frontmatter.Toplevel_attributes.default
in
let dimension =
- frontmatter.dimension |> Option.value ~default:Frontmatter.Default.dimension
+ frontmatter.dimension |> Option.value ~default:Frontmatter.Dimension.default
in
let css_links = frontmatter.css_links in
let js_links = frontmatter.js_links in
let math_mode =
- Option.value ~default:Frontmatter.Default.math_mode frontmatter.math_mode
+ Option.value ~default:Frontmatter.Math_mode.default frontmatter.math_mode
in
- let theme =
- match frontmatter.theme with
- | None -> Frontmatter.Default.theme
- | Some (`Builtin _ as x) -> x
- | Some (`External x) ->
+ let resolve_theme = function
+ | `Builtin _ as x -> x
+ | `External x ->
let asset = Asset.of_string ~read_file x in
`External asset
in
+ let theme =
+ match frontmatter.theme with
+ | None -> resolve_theme Frontmatter.Theme.default
+ | Some t -> resolve_theme t
+ in
let highlightjs_theme =
- Option.value ~default:Frontmatter.Default.highlightjs_theme
+ Option.value ~default:Frontmatter.Hljs_theme.default
frontmatter.highlightjs_theme
in
let math_link = frontmatter.math_link in
- let md = Compile.compile ~attrs:toplevel_attributes ~read_file s in
+ let (md, htbl_include), errors =
+ Compile.compile ~loc_offset ?file ~attrs:toplevel_attributes
+ ~fm:(Frontmatter.Resolved frontmatter) ~read_file s
+ in
+ let warnings =
+ List.filter_map
+ (to_grace file whole_content htbl_include)
+ (warnings @ errors)
+ in
let content = Renderers.to_html_string md in
let has = Has.find_out md in
- embed_in_page ~has_speaker_view ~slipshow_js ~dimension ~has ~math_link ~theme
- ~css_links ~js_links content ~highlightjs_theme ~math_mode
+ let res =
+ embed_in_page ~has_speaker_view ~slipshow_js ~dimension ~has ~math_link
+ ~theme ~css_links ~js_links content ~highlightjs_theme ~math_mode
+ in
+ (res, warnings)
let add_starting_state ?(autofocus = true) (start, end_, has_speaker_view)
(starting_state : starting_state option) =
@@ -361,9 +395,10 @@ let add_starting_state ?(autofocus = true) (start, end_, has_speaker_view)
in
if has_speaker_view then html else orig_html
-let convert ~has_speaker_view ?autofocus ?slipshow_js ?frontmatter
+let convert ~has_speaker_view ?autofocus ?slipshow_js ?frontmatter ?file
?starting_state ?read_file s =
- let delayed =
- delayed ~has_speaker_view ?slipshow_js ?frontmatter ?read_file s
+ let delayed, w =
+ delayed ~has_speaker_view ?slipshow_js ?frontmatter ?file ?read_file s
in
- add_starting_state ?autofocus delayed starting_state
+ let res = add_starting_state ?autofocus delayed starting_state in
+ (res, w)
diff --git a/src/compiler/slipshow.mli b/src/compiler/slipshow.mli
index 3ea08840..c9b1982e 100644
--- a/src/compiler/slipshow.mli
+++ b/src/compiler/slipshow.mli
@@ -4,8 +4,8 @@ module Frontmatter = Frontmatter
type starting_state = int
type delayed
-val delayed_to_string : delayed -> string
-val string_to_delayed : string -> delayed
+val delayed_to_string : delayed * string -> string
+val string_to_delayed : string -> delayed * string
type file_reader = Fpath.t -> (string option, [ `Msg of string ]) result
(** A value of type [file_reader], given a path [p], outputs:
@@ -20,10 +20,11 @@ type file_reader = Fpath.t -> (string option, [ `Msg of string ]) result
val delayed :
?slipshow_js:Asset.t ->
?frontmatter:Frontmatter.resolved Frontmatter.t ->
+ ?file:string ->
?read_file:file_reader ->
has_speaker_view:bool ->
string ->
- delayed
+ delayed * Diagnosis.t Grace.Diagnostic.t list
(** This function is used to delay the decision on the starting state. It allows
to run [convert] server-side (which is useful to get images and so on) but
let the previewer decide on the starting state. *)
@@ -36,9 +37,10 @@ val convert :
?autofocus:bool ->
?slipshow_js:Asset.t ->
?frontmatter:Frontmatter.resolved Frontmatter.t ->
+ ?file:string ->
?starting_state:starting_state ->
?read_file:file_reader ->
string ->
- string
+ string * Diagnosis.t Grace.Diagnostic.t list
val convert_to_md : read_file:file_reader -> string -> string
diff --git a/src/compiler/special_attrs.ml b/src/compiler/special_attrs.ml
new file mode 100644
index 00000000..61ae08cb
--- /dev/null
+++ b/src/compiler/special_attrs.ml
@@ -0,0 +1,28 @@
+let no_enter = "no-enter"
+let include_ = "include"
+let src = "src"
+let blockquote = "blockquote"
+let slide = "slide"
+let slip = "slip"
+let carousel = "carousel"
+let video = "video"
+let audio = "audio"
+let image = "image"
+let svg = "svg"
+let pdf_resolution = "pdf-resolution"
+
+let all_attrs =
+ [
+ no_enter;
+ include_;
+ src;
+ blockquote;
+ slide;
+ slip;
+ carousel;
+ video;
+ audio;
+ image;
+ svg;
+ pdf_resolution;
+ ]
diff --git a/src/diagnosis/diagnosis.ml b/src/diagnosis/diagnosis.ml
new file mode 100644
index 00000000..b5acbfe1
--- /dev/null
+++ b/src/diagnosis/diagnosis.ml
@@ -0,0 +1,218 @@
+type loc = Cmarkit.Textloc.t
+
+let loc_of_ploc loc (idx, idx') =
+ let open Cmarkit.Textloc in
+ let file = file loc in
+ let first_line = first_line loc in
+ let last_line = first_line in
+ let first_byte = first_byte loc + idx in
+ let last_byte = first_byte + idx' - idx - 1 in
+ v ~file ~first_line ~last_line ~first_byte ~last_byte
+
+type t =
+ | DuplicateID of { id : string; occurrences : loc list }
+ | MissingFile of { file : string; error_msg : string; locs : loc list }
+ | WrongType of { loc_reason : loc; loc_block : loc; expected_type : string }
+ | ParsingError of { action : string; msg : string; loc : loc }
+ | ParsingWarnor of { warnor : Actions_arguments.W.warnor; loc : loc }
+ | MissingID of { id : string; loc : loc }
+ | UnknownAttribute of { attr : string; loc : loc }
+ | General of {
+ code : string;
+ msg : string;
+ labels : (string * loc) list;
+ notes : string list;
+ }
+
+(* This is currently used to render issues on things that don't have location:
+ mostly CLI input. CLI input have much less errors they can raise, so it's OK
+ if (most) of them are not great messages. But I still keep all of those here
+ since this function will have some things to be taken for LSP integration. *)
+let pp ppf = function
+ | DuplicateID id ->
+ Format.fprintf ppf "ID '%s' has already been given at %a." id.id
+ (Fmt.list Cmarkit.Textloc.pp_ocaml)
+ id.occurrences
+ | MissingFile s ->
+ Format.fprintf ppf "Missing file: %s, considering it as an URL. (%s)"
+ s.file s.error_msg
+ | WrongType { loc_reason = _; loc_block = _; expected_type } ->
+ Format.fprintf ppf "Wrong type: expected type '%s'" expected_type
+ | ParsingError { action; msg; loc = _ } ->
+ Format.fprintf ppf
+ "Parsing of the arguments of actions '%s' failed with '%s'" action msg
+ | ParsingWarnor
+ { warnor = UnusedArgument { action_name; argument_name; _ }; loc = _ } ->
+ Format.fprintf ppf "Action '%s' does not accept argument '%s'" action_name
+ argument_name
+ | ParsingWarnor { warnor = Parsing_failure { msg; loc = _ }; loc = _ } ->
+ Format.fprintf ppf "Action argument parsing failure: %s" msg
+ | MissingID { id; loc = _ } ->
+ Format.fprintf ppf "Id '%s' could not be found" id
+ | General { msg; labels = _; notes = _; code = _ } ->
+ Format.fprintf ppf "%s" msg (* TODO: improve *)
+ | UnknownAttribute { attr; loc = _ } ->
+ Format.fprintf ppf
+ "Attribute '%s' is neither a standard HTML attribute nor a slipshow \
+ specific one"
+ attr
+
+let with_range source_map loc f =
+ let open Grace in
+ let range (loc : loc) =
+ let source = source_map (Cmarkit.Textloc.file loc) in
+ let start = Cmarkit.Textloc.first_byte loc in
+ let stop = Cmarkit.Textloc.last_byte loc + 1 in
+ Range.create ~source (Byte_index.of_int start) (Byte_index.of_int stop)
+ in
+ try
+ let range = range loc in
+ Some (f ~range)
+ with _ -> None
+
+let to_grace source_map error =
+ let open Grace in
+ let with_range = with_range source_map in
+ match error with
+ | DuplicateID { id; occurrences } ->
+ let labels =
+ List.filter_map
+ (fun occ -> with_range occ @@ Diagnostic.Label.primaryf "")
+ occurrences
+ in
+ Some
+ (Diagnostic.createf ~labels ~code:error Warning
+ "ID %s is assigned multiple times" id)
+ | MissingFile { file; error_msg; locs } ->
+ let labels =
+ List.filter_map
+ (fun loc -> with_range loc @@ Diagnostic.Label.primaryf "")
+ locs
+ in
+ Some
+ (Diagnostic.createf ~labels ~code:error Warning
+ "file '%s' could not be read: %s" file error_msg)
+ | WrongType { loc_reason; loc_block; expected_type } ->
+ let labels =
+ List.filter_map Fun.id
+ [
+ with_range loc_reason
+ @@ Diagnostic.Label.primaryf "This expects the id of a %s"
+ expected_type;
+ with_range loc_block
+ @@ Diagnostic.Label.primaryf "This is not a %s" expected_type;
+ ]
+ in
+ Some (Diagnostic.createf ~labels ~code:error Warning "Wrong type")
+ | ParsingError { action; msg; loc } ->
+ let labels =
+ List.filter_map Fun.id
+ [ with_range loc @@ Diagnostic.Label.primaryf "%s" msg ]
+ in
+ Some
+ (Diagnostic.createf ~labels ~code:error Warning
+ "Action %s arguments could not be parsed" action)
+ | ParsingWarnor
+ {
+ warnor =
+ UnusedArgument
+ { action_name; argument_name; loc = parse_loc; possible_arguments };
+ loc;
+ } ->
+ let loc = loc_of_ploc loc parse_loc in
+ let labels =
+ List.filter_map Fun.id
+ [
+ with_range loc
+ @@ Diagnostic.Label.primaryf
+ "Action '%s' does not take argument '%s'" action_name
+ argument_name;
+ ]
+ in
+ let notes =
+ match possible_arguments with
+ | [] ->
+ [
+ Diagnostic.Message.createf "'%s' accepts no arguments" action_name;
+ ]
+ | _ ->
+ [
+ Diagnostic.Message.createf "'%s' accepts arguments '%s'"
+ action_name
+ (String.concat "', '" possible_arguments);
+ ]
+ in
+ Some (Diagnostic.createf ~labels ~notes ~code:error Warning "")
+ | ParsingWarnor { warnor = Parsing_failure { msg; loc = parse_loc }; loc } ->
+ let loc = loc_of_ploc loc parse_loc in
+ let labels =
+ List.filter_map Fun.id
+ [ with_range loc @@ Diagnostic.Label.primaryf "%s" msg ]
+ in
+ Some (Diagnostic.createf ~labels ~code:error Warning "Failed to parse")
+ | MissingID { id; loc } ->
+ let labels =
+ List.filter_map Fun.id
+ [
+ with_range loc
+ @@ Diagnostic.Label.primaryf
+ "This should be an ID present in the document";
+ ]
+ in
+ Some
+ (Diagnostic.createf ~labels ~code:error Warning
+ "No element with id '%s' were found" id)
+ | General { msg; labels; notes; code = _ } ->
+ let labels =
+ List.filter_map
+ (fun (msg, loc) ->
+ with_range loc @@ Diagnostic.Label.primaryf "%s" msg)
+ labels
+ in
+ let notes =
+ List.map (fun msg -> Diagnostic.Message.createf "%s" msg) notes
+ in
+ Some (Diagnostic.createf ~labels ~notes ~code:error Warning "%s" msg)
+ | UnknownAttribute { attr; loc } ->
+ let labels =
+ List.filter_map Fun.id
+ [ with_range loc @@ Diagnostic.Label.primaryf "" ]
+ in
+ Some
+ (Diagnostic.createf ~labels ~code:error Warning
+ "Non standard attribute: '%s'" attr)
+
+let errors_acc = ref []
+let add x = errors_acc := x :: !errors_acc
+
+let with_ f =
+ let old_errors = !errors_acc in
+ errors_acc := [];
+ let clean_up () =
+ let errors = !errors_acc in
+ errors_acc := old_errors;
+ errors
+ in
+ try
+ let res = f () in
+ (res, clean_up ())
+ with exn ->
+ let _ = clean_up in
+ raise exn
+
+let to_code = function
+ | DuplicateID _ -> "DupID"
+ | MissingFile _ -> "FSError"
+ | WrongType _ -> "WrongType"
+ | ParsingError _ -> "ActionParsing"
+ | ParsingWarnor _ -> "ActionParsing"
+ | MissingID _ -> "IDNotFound"
+ | UnknownAttribute _ -> "UnkownAttribute"
+ | General { code; _ } -> code
+
+let report_no_src fmt x =
+ let msg = Format.asprintf "%a" pp x in
+ let msg = Grace.Diagnostic.createf ~labels:[] ~code:x Warning "%s" msg in
+ Format.fprintf fmt "%a@.@."
+ (Grace_ansi_renderer.pp_diagnostic ?config:None ~code_to_string:to_code)
+ msg
diff --git a/src/diagnosis/diagnosis.mli b/src/diagnosis/diagnosis.mli
new file mode 100644
index 00000000..3800e7e3
--- /dev/null
+++ b/src/diagnosis/diagnosis.mli
@@ -0,0 +1,27 @@
+type loc = Cmarkit.Textloc.t
+
+val loc_of_ploc : loc -> Actions_arguments.W.loc -> loc
+
+type t =
+ | DuplicateID of { id : string; occurrences : loc list }
+ | MissingFile of { file : string; error_msg : string; locs : loc list }
+ | WrongType of { loc_reason : loc; loc_block : loc; expected_type : string }
+ | ParsingError of { action : string; msg : string; loc : loc }
+ | ParsingWarnor of { warnor : Actions_arguments.W.warnor; loc : loc }
+ | MissingID of { id : string; loc : loc }
+ | UnknownAttribute of { attr : string; loc : loc }
+ | General of {
+ code : string;
+ msg : string;
+ labels : (string * loc) list;
+ notes : string list;
+ }
+
+val pp : Format.formatter -> t -> unit
+val to_grace : (string -> Grace.Source.t) -> t -> t Grace.Diagnostic.t option
+val add : t -> unit
+val with_ : (unit -> 'a) -> 'a * t list
+val to_code : t -> string
+
+val report_no_src : Format.formatter -> t -> unit
+(** This one reports badly, without source code. Used for reporting cli. *)
diff --git a/src/diagnosis/dune b/src/diagnosis/dune
new file mode 100644
index 00000000..bcaf947f
--- /dev/null
+++ b/src/diagnosis/dune
@@ -0,0 +1,4 @@
+(library
+ (name diagnosis)
+ (public_name slipshow.diagnosis)
+ (libraries grace grace.ansi_renderer cmarkit actions_arguments))
diff --git a/src/engine/previewer/dune b/src/engine/previewer/dune
index 2076f0a6..c04a45a1 100644
--- a/src/engine/previewer/dune
+++ b/src/engine/previewer/dune
@@ -1,4 +1,4 @@
(library
(name previewer)
(public_name slipshow.previewer)
- (libraries communication brr slipshow js_of_ocaml-lwt lwt))
+ (libraries communication brr slipshow js_of_ocaml-lwt lwt ansi))
diff --git a/src/engine/previewer/previewer.ml b/src/engine/previewer/previewer.ml
index 1ce9af08..498fc586 100644
--- a/src/engine/previewer/previewer.ml
+++ b/src/engine/previewer/previewer.ml
@@ -8,6 +8,7 @@ type previewer = {
stage : int ref;
index : int ref;
panels : Brr.El.t array;
+ errors_el : Brr.El.t;
ids : string * string;
include_speaker_view : bool;
}
@@ -30,8 +31,26 @@ let send_speaker_view oc panel =
let () = Random.self_init ()
+let css =
+ {|
+.right-panel1.active_panel, .right-panel2.active_panel {
+ z-index: 1;
+}
+.right-panel1, .right-panel2 {
+ z-index: 0;
+ width:100%;
+ position:absolute;
+ top:0;
+ bottom:0;
+ left:0;
+ right:0;
+ border:0;
+ height:100%
+}
+|}
+
let create_previewer ?(initial_stage = 0) ?(callback = fun _ -> ())
- ~include_speaker_view root =
+ ~include_speaker_view ~errors_el root =
let ( !! ) = Jstr.v in
let name1 = Random.int 1000000 |> string_of_int |> fun s -> "id" ^ s in
let name2 = Random.int 1000000 |> string_of_int |> fun s -> "id" ^ s in
@@ -42,7 +61,8 @@ let create_previewer ?(initial_stage = 0) ?(callback = fun _ -> ())
let panel2 =
Brr.El.iframe ~at:[ Brr.At.name !!name2; Brr.At.class' !!"right-panel2" ] []
in
- let () = Brr.El.append_children root [ panel1; panel2 ] in
+ let css = Brr.El.style [ Brr.El.txt' css ] in
+ let () = Brr.El.append_children root [ panel1; panel2; css ] in
let panels = [| panel1; panel2 |] in
let index = ref 0 in
let stage = ref initial_stage in
@@ -92,24 +112,49 @@ let create_previewer ?(initial_stage = 0) ?(callback = fun _ -> ())
| _ -> ())
(Brr.Window.as_target Brr.G.window)
in
- { stage; index; panels; ids = (name1, name2); include_speaker_view }
+ {
+ stage;
+ index;
+ panels;
+ ids = (name1, name2);
+ include_speaker_view;
+ errors_el;
+ }
-let set_srcdoc { index; panels; _ } slipshow =
+let set_errors errors_el warnings =
+ Brr.El.set_class (Jstr.v "has_warnings") (String.equal "" warnings) errors_el;
+ let innerhtml el v =
+ let _ = Jv.set (Brr.El.to_jv el) "innerHTML" (Jv.of_string v) in
+ ()
+ in
+ innerhtml errors_el warnings
+
+let set_srcdoc { index; panels; errors_el; _ } (slipshow, warnings) =
+ set_errors errors_el warnings;
try Jv.set (Brr.El.to_jv panels.(1 - !index)) "srcdoc" (Jv.of_string slipshow)
with _ -> Brr.Console.(log [ "XXX exception" ])
let preview ?slipshow_js ?frontmatter ?read_file previewer source =
let starting_state = !(previewer.stage) in
let has_speaker_view = previewer.include_speaker_view in
- let slipshow =
- Slipshow.convert ~has_speaker_view ?slipshow_js ?frontmatter ?read_file
- ~autofocus:false ~starting_state source
+ let slipshow, warnings =
+ Slipshow.convert ~file:"-" ~has_speaker_view ?slipshow_js ?frontmatter
+ ?read_file ~autofocus:false ~starting_state source
+ in
+ let warnings =
+ List.map
+ (Format.asprintf "%a@.@."
+ (Grace_ansi_renderer.pp_diagnostic ?config:None
+ ~code_to_string:Diagnosis.to_code))
+ warnings
+ |> List.map (Ansi.process (Ansi.create ()))
+ |> String.concat ""
in
- set_srcdoc previewer slipshow
+ set_srcdoc previewer (slipshow, warnings)
-let preview_compiled previewer delayed =
+let preview_compiled previewer (delayed, warnings) =
let starting_state = Some !(previewer.stage) in
let slipshow = Slipshow.add_starting_state delayed starting_state in
- set_srcdoc previewer slipshow
+ set_srcdoc previewer (slipshow, warnings)
let ids { ids; _ } = ids
diff --git a/src/engine/previewer/previewer.mli b/src/engine/previewer/previewer.mli
index 0d636b59..0c2ab342 100644
--- a/src/engine/previewer/previewer.mli
+++ b/src/engine/previewer/previewer.mli
@@ -13,6 +13,7 @@ val create_previewer :
?initial_stage:int ->
?callback:(int -> unit) ->
include_speaker_view:bool ->
+ errors_el:Brr.El.t ->
Brr.El.t ->
previewer
@@ -24,5 +25,5 @@ val preview :
string ->
unit
-val preview_compiled : previewer -> Slipshow.delayed -> unit
+val preview_compiled : previewer -> Slipshow.delayed * string -> unit
val ids : previewer -> string * string
diff --git a/src/engine/runtime/step/action_scheduler.ml b/src/engine/runtime/step/action_scheduler.ml
index baae2ec1..c07c139d 100644
--- a/src/engine/runtime/step/action_scheduler.ml
+++ b/src/engine/runtime/step/action_scheduler.ml
@@ -33,8 +33,8 @@ module AttributeActions = struct
else Undoable.return ()
in
let v = Jstr.to_string v in
- let$$ args = Action.parse_args elem v in
- Action.do_ ~mode window args
+ let$$ args, _warnings = Action.parse_args v in
+ Action.do_ ~mode window elem args
let do_ ~mode window elem =
let do_ = fun m -> activate ~mode m window elem in
@@ -63,8 +63,8 @@ let setup_actions window () =
(module struct
include X
- let do_ ~mode:_ _window x =
- setup2 x |> ignore;
+ let do_ ~mode:_ _window el x =
+ setup2 el x |> ignore;
Undoable.return ()
end)
window elem)
diff --git a/src/engine/runtime/step/actions.ml b/src/engine/runtime/step/actions.ml
index ef17c224..1be859bf 100644
--- a/src/engine/runtime/step/actions.ml
+++ b/src/engine/runtime/step/actions.ml
@@ -5,12 +5,7 @@ include Actions_
[Actions] would depend on [Javascrip_api] which would depend on [Actions]. *)
module Execute = struct
- type args = Brr.El.t list
-
- let on = "exec-at-unpause"
- let action_name = "exec"
- let parse_args = Parse.parse_only_els
-
+ include Actions_arguments.Execute
open Fut.Syntax
let only_if_fast mode f =
@@ -46,7 +41,14 @@ module Execute = struct
[ "An exception occurred when trying to execute a custom script:"; e ]);
Undoable.return ~undo:undo_fallback ()
- let do_ ~mode window elems = Undoable.List.iter (do_ ~mode window) elems
+ type js_args = |
+
+ let do_js ~mode:_ _window _not_inhabited = Undoable.return ()
+
+ let do_ ~mode window elem args =
+ let elems = Actions_.elems_of_ids_or_self args elem in
+ Undoable.List.iter (do_ ~mode window) elems
+
let setup = None
let setup_all = None
end
diff --git a/src/engine/runtime/step/actions.mli b/src/engine/runtime/step/actions.mli
index 4331af28..6667aeed 100644
--- a/src/engine/runtime/step/actions.mli
+++ b/src/engine/runtime/step/actions.mli
@@ -1,31 +1,42 @@
module type S = sig
- type args
+ include Actions_arguments.S
- val setup : (args -> unit Fut.t) option
+ val setup : (Brr.El.t -> args -> unit Fut.t) option
val setup_all : (unit -> unit Fut.t) option
- val on : string
- val action_name : string
- val parse_args : Brr.El.t -> string -> (args, [> `Msg of string ]) result
- val do_ : mode:Fast.mode -> Universe.Window.t -> args -> unit Undoable.t
-end
-module Pause : sig
- type args = Brr.El.t list
+ type js_args
+
+ val do_js : mode:Fast.mode -> Universe.Window.t -> js_args -> unit Undoable.t
- include S with type args := args
+ val do_ :
+ mode:Fast.mode -> Universe.Window.t -> Brr.El.t -> args -> unit Undoable.t
end
+module Pause :
+ S
+ with type args := Actions_arguments.ids_or_self
+ and type js_args = Brr.El.t list
+
module type Move = sig
type args = {
margin : float option;
duration : float option;
+ target : [ `Self | `Id of string Actions_arguments.W.node ];
+ }
+
+ type js_args = {
elem : Brr.El.t;
+ duration : float option;
+ margin : float option;
}
- include S with type args := args
+ include S with type args := args and type js_args := js_args
end
-module type SetClass = S with type args = Brr.El.t list
+module type SetClass =
+ S
+ with type args = [ `Self | `Ids of string Actions_arguments.W.node list ]
+ and type js_args = Brr.El.t list
module Up : Move
module Down : Move
@@ -43,36 +54,31 @@ module Step : S with type args = unit
val exit : mode:Fast.mode -> Universe.Window.t -> Brr.El.t -> unit Undoable.t
module Focus : sig
- type args = {
+ include module type of Actions_arguments.Focus
+
+ type js_args = {
margin : float option;
duration : float option;
elems : Brr.El.t list;
}
- include S with type args := args
+ include S with type args := args and type js_args := js_args
end
module Unfocus : S with type args = unit
-module Execute : S with type args = Brr.El.t list
-module Play_media : S with type args = Brr.El.t list
+module Execute : S with type args = Actions_arguments.Execute.args
-module Change_page : sig
- type change = Absolute of int | Relative of int | All | Range of int * int
+module Play_media :
+ S
+ with type args = Actions_arguments.Play_media.args
+ and type js_args = Brr.El.t list
- type arg = {
- target_elem : Brr.El.t;
- n : change list;
- original_id : string option;
- }
-
- type args = { original_elem : Brr.El.t; args : arg list }
-
- val parse_change : string -> change option
+module Change_page : sig
+ include module type of Actions_arguments.Change_page
- val do_javascript_api :
- mode:Fast.mode -> target_elem:Brr.El.t -> change:change -> unit Undoable.t
+ type js_args = { elem : Brr.El.t; change : change }
- include S with type args := args
+ include S with type args := args and type js_args := js_args
end
val all : (module S) list
diff --git a/src/engine/runtime/step/actions_.ml b/src/engine/runtime/step/actions_.ml
index 2e0a443f..2f2810d4 100644
--- a/src/engine/runtime/step/actions_.ml
+++ b/src/engine/runtime/step/actions_.ml
@@ -1,387 +1,91 @@
open Undoable.Syntax
+open Brr
+
+let ( !! ) = Jstr.v
(** On an invalid selector, this function will raise. Since in this module ids
are user input, we valide them *)
let find_first_by_selector ?root x =
- try Brr.El.find_first_by_selector ?root x
+ try El.find_first_by_selector ?root x
with e ->
- Brr.Console.(error [ e ]);
+ Console.(error [ e ]);
None
(* We define the [Actions_] module to avoid a circular dependency: If we had
only one [Action] module (and not an [Actions] and an [Actions_]) then
[Actions] would depend on [Javascrip_api] which would depend on [Actions]. *)
-module Parse : sig
- val id : string -> Jstr.t
-
- type 'a description_named_atom =
- string * (string -> ('a, [ `Msg of string ]) result)
-
- type _ descr_tuple =
- | [] : unit descr_tuple
- | ( :: ) :
- 'a description_named_atom * 'b descr_tuple
- -> ('a * 'b) descr_tuple
-
- type _ output_tuple =
- | [] : unit output_tuple
- | ( :: ) : 'a option * 'b output_tuple -> ('a * 'b) output_tuple
-
- type 'a non_empty_list = 'a * 'a list
-
- type ('named, 'positional) parsed = {
- p_named : 'named output_tuple;
- p_pos : 'positional list;
- }
-
- val parse :
- named:'named descr_tuple ->
- positional:(string -> 'pos) ->
- string ->
- (('named, 'pos) parsed non_empty_list, [> `Msg of string ]) result
-
- val merge_positional : (unit, 'a) parsed * (unit, 'a) parsed list -> 'a list
- val require_single_action : action_name:string -> 'a * 'b list -> 'a
- val require_single_positional : action_name:string -> 'a list -> 'a option
-
- val no_args :
- action_name:string -> 'a -> string -> (unit, [> `Msg of string ]) result
-
- val parse_only_els :
- Brr.El.t -> string -> (Brr.El.t list, [> `Msg of string ]) result
-
- val parse_only_el :
- Brr.El.t -> string -> (Brr.El.t, [> `Msg of string ]) result
-
- val option_to_error : 'a -> 'b option -> ('b, [> `Msg of 'a ]) result
- val duration : string * (string -> (float, [> `Msg of string ]) result)
- val margin : string * (string -> (float, [> `Msg of string ]) result)
-end = struct
- let parse_string s =
- let is_ws idx = match s.[idx] with '\n' | ' ' -> true | _ -> false in
- let is_alpha idx =
- let c = s.[idx] in
- ('a' <= c && c <= 'z')
- || ('A' <= c && c <= 'Z')
- || ('0' <= c && c <= '9')
- || c = '_'
- in
- let rec consume_ws idx =
- if idx >= String.length s then idx
- else if is_ws idx then consume_ws (idx + 1)
- else idx
- in
- let rec consume_non_ws idx =
- if idx >= String.length s then idx
- else if not (is_ws idx) then consume_non_ws (idx + 1)
- else idx
- in
- let rec consume_alpha idx =
- if idx >= String.length s then idx
- else if is_alpha idx then consume_alpha (idx + 1)
- else idx
- in
- let quoted_string idx =
- let rec take_inside_quoted_string acc idx =
- match s.[idx] with
- | '"' -> (acc |> List.rev |> List.to_seq |> String.of_seq, idx + 1)
- | '\\' -> take_inside_quoted_string (s.[idx + 1] :: acc) (idx + 2)
- | _ -> take_inside_quoted_string (s.[idx] :: acc) (idx + 1)
- in
- take_inside_quoted_string [] idx
- in
- let parse_unquoted_string idx =
- let idx0 = idx in
- let idx = consume_non_ws idx in
- let arg = String.sub s idx0 (idx - idx0) in
- (arg, idx)
- in
- let parse_arg idx =
- match s.[idx] with
- | '"' -> quoted_string (idx + 1)
- | _ -> parse_unquoted_string idx
- in
- let repeat parser idx =
- let rec do_ acc idx =
- match parser idx with
- | None -> (List.rev acc, idx)
- | Some (x, idx') ->
- if idx' = idx then
- failwith "Parser did not consume input; infinite loop detected"
- else do_ (x :: acc) idx'
- in
- do_ [] idx
- in
- let parse_name idx =
- let idx0 = idx in
- let idx = consume_alpha idx in
- let name = String.sub s idx0 (idx - idx0) in
- (name, idx)
- in
- let parse_column idx =
- match s.[idx] with
- | ':' -> idx + 1
- | _ -> failwith "no : after named argument"
- in
- let parse_named idx =
- let idx = consume_ws idx in
- match s.[idx] with
- | '~' ->
- let idx = idx + 1 in
- let name, idx = parse_name idx in
- let idx = parse_column idx in
- let arg, idx = parse_arg idx in
- Some ((name, arg), idx)
- | (exception Invalid_argument _) | _ -> None
- in
- let parse_semicolon idx =
- let idx = consume_ws idx in
- match s.[idx] with
- | ';' -> Some ((), idx + 1)
- | (exception Invalid_argument _) | _ -> None
- in
- let parse_positional idx =
- let idx = consume_ws idx in
- match s.[idx] with
- | _ -> Some (parse_arg idx)
- | exception Invalid_argument _ -> None
- in
- let parse_one idx =
- let ( let$ ) x f = match x with Some _ as x -> x | None -> f () in
- let ( let> ) x f =
- match x with Some (x, idx) -> Some (f x, idx) | None -> None
- in
- let$ () =
- let> named = parse_named idx in
- `Named named
- in
- let$ () =
- let> () = parse_semicolon idx in
- `Semicolon
- in
- let> p = parse_positional idx in
- `Positional p
- in
- let parse_all = repeat parse_one in
- let parsed, _ = parse_all 0 in
- let unfinished_acc, parsed =
- List.fold_left
- (fun (current_acc, global_acc) -> function
- | `Semicolon -> ([], List.rev current_acc :: global_acc)
- | (`Positional _ | `Named _) as x -> (x :: current_acc, global_acc))
- ([], []) parsed
- in
- let parsed = List.rev unfinished_acc :: parsed |> List.rev in
- parsed
- |> List.map
- @@ List.partition_map (function
- | `Named x -> Left x
- | `Positional p -> Right p)
-
- let ( let+ ) x y = Result.map y x
-
- module Smap_ = Map.Make (String)
-
- module Smap = struct
- include Smap_
-
- (* of_list has only been added in 5.1. Implementation taken from the OCaml
- stdlib. *)
- let of_list bs = List.fold_left (fun m (k, v) -> add k v m) empty bs
- end
-
- type action = { named : string Smap.t; positional : string list }
+module type S = sig
+ include Actions_arguments.S
- let parse_string s =
- let+ s =
- try Ok (parse_string s)
- with _ (* TODO: finer grain catch and better error messages *) ->
- Error (`Msg "Failed when trying to parse argument")
- in
- s
- |> List.map (fun (named, positional) ->
- let named =
- Smap.of_list named
- (* TODO: warn on duplicate name *)
- in
- { named; positional })
-
- let id x = Jstr.of_string ("#" ^ x)
-
- type 'a description_named_atom =
- string * (string -> ('a, [ `Msg of string ]) result)
-
- type _ descr_tuple =
- | [] : unit descr_tuple
- | ( :: ) :
- 'a description_named_atom * 'b descr_tuple
- -> ('a * 'b) descr_tuple
-
- type _ output_tuple =
- | [] : unit output_tuple
- | ( :: ) : 'a option * 'b output_tuple -> ('a * 'b) output_tuple
-
- type 'a non_empty_list = 'a * 'a list
-
- type ('named, 'positional) parsed = {
- p_named : 'named output_tuple;
- p_pos : 'positional list;
- }
+ val setup : (El.t -> args -> unit Fut.t) option
+ val setup_all : (unit -> unit Fut.t) option
- let parsed_name (description_name, description_convert) action =
- Smap.find_opt description_name action.named
- |> Option.map description_convert
-
- let rec parsed_names : type a. action -> a descr_tuple -> a output_tuple =
- fun action descriptions ->
- match descriptions with
- | [] -> []
- | description :: rest ->
- let parsed =
- match parsed_name description action with
- | None -> None
- | Some (Error (`Msg s)) ->
- Logs.warn (fun m -> m "Could not parse argument: %s" s);
- None
- | Some (Ok a) -> Some a
- in
- parsed :: parsed_names action rest
-
- let parse_atom ~named ~positional action =
- let p_named = parsed_names action named in
- let p_pos = List.map positional action.positional in
- { p_named; p_pos }
-
- let parse ~named ~positional s :
- (('named, 'pos) parsed non_empty_list, _) result =
- let+ parsed_string = parse_string s in
- List.map (parse_atom ~named ~positional) parsed_string |> function
- | [] ->
- assert false
- (* An empty string would be parsed as [ [[None; None; ...], []] ] *)
- | a :: rest -> ((a, rest) : _ non_empty_list)
-
- let merge_positional (h, t) =
- List.concat_map
- (fun { p_named = ([] : _ output_tuple); p_pos = p } -> p)
- (h :: t)
-
- let require_single_action ~action_name x =
- match x with
- | a, rest ->
- let () =
- match (rest : _ list) with
- | [] -> ()
- | _ :: _ ->
- Logs.warn (fun m ->
- m "Action %s does not support ';'-separated arguments"
- action_name)
- in
- a
-
- let require_single_positional ~action_name (x : _ list) =
- match x with
- | [] -> None
- | a :: rest ->
- let () =
- match rest with
- | [] -> ()
- | _ :: _ ->
- Logs.warn (fun m ->
- m "Action %s does not support multiple arguments" action_name)
- in
- Some a
-
- let no_args ~action_name _elem s =
- let ( let$ ) = Fun.flip Result.map in
- let$ x = parse ~named:[] ~positional:id s in
- match x with
- | { p_named = []; p_pos = [] }, [] -> ()
- | _ ->
- Logs.warn (fun m ->
- m "The %s action does not accept any argument" action_name)
-
- let parse_only_els elem s =
- let ( let$ ) = Fun.flip Result.map in
- let$ x = parse ~named:[] ~positional:id s in
- match merge_positional x with
- | [] -> List.[ elem ]
- | x -> List.filter_map find_first_by_selector x
-
- let parse_only_el elem s =
- let ( let$ ) = Result.bind in
- let$ x = parse ~named:[] ~positional:id s in
- match merge_positional x with
- | [] -> Ok elem
- | _ :: _ :: _ -> Error (`Msg "Expected a single ID")
- | [ x ] -> (
- match find_first_by_selector x with
- | Some x -> Ok x
- | None ->
- Error (`Msg ("Could not find element with ID " ^ Jstr.to_string x)))
-
- let option_to_error error = function
- | Some x -> Ok x
- | None -> Error (`Msg error)
-
- let duration =
- ( "duration",
- fun x ->
- x |> Float.of_string_opt |> option_to_error "Error during float parsing"
- )
-
- let margin =
- ( "margin",
- fun x ->
- x |> Float.of_string_opt |> option_to_error "Error during float parsing"
- )
-end
+ type js_args
-module type S = sig
- type args
+ val do_js : mode:Fast.mode -> Universe.Window.t -> js_args -> unit Undoable.t
- val setup : (args -> unit Fut.t) option
- val setup_all : (unit -> unit Fut.t) option
- val on : string
- val action_name : string
- val parse_args : Brr.El.t -> string -> (args, [> `Msg of string ]) result
- val do_ : mode:Fast.mode -> Universe.Window.t -> args -> unit Undoable.t
+ val do_ :
+ mode:Fast.mode -> Universe.Window.t -> El.t -> args -> unit Undoable.t
end
module type Move = sig
type args = {
margin : float option;
duration : float option;
+ target : [ `Self | `Id of string Actions_arguments.W.node ];
+ }
+
+ type js_args = {
elem : Brr.El.t;
+ duration : float option;
+ margin : float option;
}
- include S with type args := args
+ include S with type args := args and type js_args := js_args
end
-module type SetClass = S with type args = Brr.El.t list
+module type SetClass =
+ S
+ with type args = [ `Self | `Ids of string Actions_arguments.W.node list ]
+ and type js_args = Brr.El.t list
let only_if_not_counting mode f =
match mode with
| Fast.Counting_for_toc -> Undoable.return ()
| Normal _ | Fast | Slow -> f ()
+let elems_of_ids_or_self ids_or_self elem =
+ match ids_or_self with
+ | `Self -> [ elem ]
+ | `Ids ids ->
+ (* TODO: warn on non-existent element *)
+ List.filter_map
+ (fun (id, _) -> El.find_first_by_selector !!("#" ^ id))
+ ids
+
+let elem_of_id_or_self id_or_self elem =
+ match id_or_self with
+ | `Self -> elem
+ | `Id (id, _) ->
+ (* TODO: no Option.get *)
+ El.find_first_by_selector !!("#" ^ id) |> Option.get
+
module Pause = struct
- let on = "pause"
- let action_name = "pause"
+ include Actions_arguments.Pause
let do_to_root elem f =
let is_root elem =
- Brr.El.class' (Jstr.v "slip") elem
- || Brr.El.class' (Jstr.v "slide") elem
- || Brr.El.class' (Jstr.v "slipshow-universe") elem
- || (Option.is_some @@ Brr.El.at (Jstr.v "pause-block") elem)
+ El.class' (Jstr.v "slip") elem
+ || El.class' (Jstr.v "slide") elem
+ || El.class' (Jstr.v "slipshow-universe") elem
+ || (Option.is_some @@ El.at (Jstr.v "pause-block") elem)
in
let rec do_rec elem =
if is_root elem then Undoable.return ()
else
let> () = f elem in
- match Brr.El.parent elem with
+ match El.parent elem with
| None -> Undoable.return ()
| Some elem -> do_rec elem
in
@@ -402,12 +106,12 @@ module Pause = struct
let update elem f =
do_to_root elem @@ fun elem ->
let n =
- match Brr.El.at (Jstr.v "pauseAncestorMultiplicity") elem with
+ match El.at (Jstr.v "pauseAncestorMultiplicity") elem with
| None -> 0
| Some n -> (
match Jstr.to_int n with
| None ->
- Brr.Console.(
+ Console.(
log [ "Error: wrong value to pauseAncestorMultiplicity:"; n ]);
0
| Some n -> n)
@@ -420,14 +124,16 @@ module Pause = struct
update elem (( + ) 1) |> Undoable.discard
let setup_all () =
+ (* TODO: check if this is really needed *)
let open Fut.Syntax in
- Brr.El.fold_find_by_selector
+ El.fold_find_by_selector
(fun elem acc ->
let* () = acc in
setup elem)
(Jstr.v "pause-target") (Fut.return ())
- let setup elems =
+ let setup elem args =
+ let elems = elems_of_ids_or_self args elem in
let open Fut.Syntax in
List.fold_left
(fun acc elem ->
@@ -438,18 +144,23 @@ module Pause = struct
let setup = Some setup
let setup_all = Some setup_all
- type args = Brr.El.t list
+ type js_args = El.t list
- let parse_args = Parse.parse_only_els
-
- let do_ ~mode _window elems =
+ let do_js ~mode _window elems =
only_if_not_counting mode @@ fun _mode ->
elems
|> Undoable.List.iter @@ fun elem ->
let> () = set_class "pauseTarget" false elem in
update elem (fun n -> n - 1)
+
+ let do_ ~mode _window elem args =
+ only_if_not_counting mode @@ fun _mode ->
+ let elems = elems_of_ids_or_self args elem in
+ do_js ~mode _window elems
end
+module _ : S = Pause
+
module Move (X : sig
val on : string
val action_name : string
@@ -459,48 +170,34 @@ module Move (X : sig
?margin:float ->
Fast.mode ->
Universe.Window.t ->
- Brr.El.t ->
+ El.t ->
unit Undoable.t
end) =
struct
- let on = X.on
- let action_name = X.action_name
+ include Actions_arguments.Move (X)
+
+ type js_args = { elem : El.t; duration : float option; margin : float option }
+
let setup = None
let setup_all = None
- type args = {
- margin : float option;
- duration : float option;
- elem : Brr.El.t;
- }
-
- let parse_args elem s =
- let ( let* ) = Result.bind in
- let* x =
- Parse.parse ~named:[ Parse.duration; Parse.margin ] ~positional:Parse.id s
- in
- match Parse.require_single_action ~action_name:X.action_name x with
- | { p_named = [ duration; margin ]; p_pos = positional } -> (
- match
- Parse.require_single_positional ~action_name:X.action_name positional
- with
- | None -> Ok { elem; duration; margin }
- | Some positional -> (
- match find_first_by_selector positional with
- | None ->
- Error
- (`Msg
- ("Could not find element with id"
- ^ Jstr.to_string positional))
- | Some elem -> Ok { elem; duration; margin }))
-
- let do_ ~mode window { margin; duration; elem } =
+ let do_js ~mode window { elem; margin; duration } =
only_if_not_counting mode @@ fun _mode ->
let open Fut.Syntax in
let* () = Excursion.end_ window () in
let margin = Option.value ~default:0. margin in
let duration = Option.value ~default:1. duration in
X.move ~margin ~duration mode window elem
+
+ let do_ ~mode window elem { margin; duration; target } =
+ only_if_not_counting mode @@ fun _mode ->
+ let elem =
+ match target with
+ | `Self -> elem
+ | `Id (id, _) -> find_first_by_selector !!("#" ^ id) |> Option.get
+ (* TODO: not option.get *)
+ in
+ do_js ~mode window { elem; margin; duration }
end
module SetClass (X : sig
@@ -510,18 +207,21 @@ module SetClass (X : sig
val state : bool
end) =
struct
- let on = X.on
- let action_name = X.action_name
- let setup = None
- let setup_all = None
+ include Actions_arguments.SetClass (X)
- type args = Brr.El.t list
+ type js_args = El.t list
- let parse_args = Parse.parse_only_els
+ let setup = None
+ let setup_all = None
- let do_ ~mode _window elems =
+ let do_js ~mode _window elems =
only_if_not_counting mode @@ fun _mode ->
Undoable.List.iter (Undoable.Browser.set_class X.class_ X.state) elems
+
+ let do_ ~mode _window elem args =
+ only_if_not_counting mode @@ fun _mode ->
+ let elems = elems_of_ids_or_self args elem in
+ do_js ~mode _window elems
end
module Up = Move (struct
@@ -530,6 +230,8 @@ module Up = Move (struct
let move = Universe.Move.up
end)
+module _ : S = Up
+
module Down = Move (struct
let on = "down-at-unpause"
let action_name = "down"
@@ -550,7 +252,7 @@ end)
module Enter = struct
type t = {
- element_entered : Brr.El.t; (** The element we entered *)
+ element_entered : El.t; (** The element we entered *)
coord_left : Universe.Coordinates.window;
(** The coordinate we left when entering *)
duration : float option; (** The duration it took to enter entering *)
@@ -577,7 +279,7 @@ let exit ~mode window to_elem =
match coord with
| None -> Undoable.return ()
| Some { element_entered; _ }
- when Brr.El.contains element_entered ~child:to_elem ->
+ when El.contains element_entered ~child:to_elem ->
Undoable.return ()
| Some { coord_left; duration; _ } -> (
let open Fut.Syntax in
@@ -587,14 +289,15 @@ let exit ~mode window to_elem =
match Undoable.Stack.peek Enter.stack with
| None -> Universe.Move.move mode window coord_left ~duration
| Some { Enter.element_entered; _ }
- when Brr.El.contains element_entered ~child:to_elem ->
+ when El.contains element_entered ~child:to_elem ->
let duration =
- match Brr.El.at (Jstr.v "enter-at-unpause") to_elem with
+ match El.at (Jstr.v "enter-at-unpause") to_elem with
| None -> duration
| Some s -> (
- match Enter.parse_args to_elem (Jstr.to_string s) with
+ match Enter.parse_args (Jstr.to_string s) with
| Error _ -> duration
- | Ok v -> Option.value ~default:duration v.duration)
+ | Ok (v, _warnings) ->
+ Option.value ~default:duration v.duration)
in
Universe.Move.move mode window coord_left ~duration
| Some _ -> exit ())
@@ -608,6 +311,8 @@ module Unstatic = SetClass (struct
let state = true
end)
+module _ : S = Unstatic
+
module Static = SetClass (struct
let on = "static-at-unpause"
let action_name = "static"
@@ -616,6 +321,8 @@ module Static = SetClass (struct
end)
module Focus = struct
+ include Actions_arguments.Focus
+
module State = struct
let stack = ref None
@@ -635,28 +342,13 @@ module Focus = struct
Undoable.return ~undo ret
end
- type args = {
+ type js_args = {
margin : float option;
duration : float option;
- elems : Brr.El.t list;
+ elems : El.t list;
}
- let on = "focus-at-unpause"
- let action_name = "focus"
-
- let parse_args elem s =
- let ( let$ ) = Fun.flip Result.map in
- let$ x =
- Parse.parse ~named:[ Parse.duration; Parse.margin ] ~positional:Parse.id s
- in
- match Parse.require_single_action ~action_name x with
- | { p_named = [ duration; margin ]; p_pos = [] } ->
- { elems = [ elem ]; duration; margin }
- | { p_named = [ duration; margin ]; p_pos = positional } ->
- let elems = List.filter_map find_first_by_selector positional in
- { elems; duration; margin }
-
- let do_ ~mode window { margin; duration; elems } =
+ let do_js ~mode window { elems; margin; duration } =
only_if_not_counting mode @@ fun _mode ->
let open Fut.Syntax in
let* () = Excursion.end_ window () in
@@ -665,20 +357,26 @@ module Focus = struct
let duration = Option.value ~default:1. duration in
Universe.Move.focus ~margin ~duration mode window elems
+ let do_ ~mode window el { target; margin; duration } =
+ only_if_not_counting mode @@ fun _mode ->
+ let elems = elems_of_ids_or_self target el in
+ do_js ~mode window { elems; margin; duration }
+
let setup = None
let setup_all = None
end
+module _ : S = Focus
+
module Unfocus = struct
- type args = unit
+ include Actions_arguments.Unfocus
let setup = None
let setup_all = None
- let on = "unfocus-at-unpause"
- let action_name = "unfocus"
- let parse_args elem s = Parse.no_args ~action_name elem s
- let do_ ~mode window () =
+ type js_args = unit
+
+ let do_js ~mode window () =
only_if_not_counting mode @@ fun _mode ->
let> coord = Focus.State.pop () in
match coord with
@@ -687,8 +385,13 @@ module Unfocus = struct
let open Fut.Syntax in
let* () = Excursion.end_ window () in
Universe.Move.move mode window coord ~duration:1.0
+
+ let do_ ~mode window _elem () =
+ only_if_not_counting mode @@ fun _mode -> do_js ~mode window ()
end
+module _ : S = Unfocus
+
module Reveal = SetClass (struct
let on = "reveal-at-unpause"
let action_name = "reveal"
@@ -718,35 +421,35 @@ module Unemph = SetClass (struct
end)
module Step = struct
- type args = unit
+ include Actions_arguments.Step
let setup = None
let setup_all = None
- let on = "step"
- let action_name = "step"
- let parse_args elem s = Parse.no_args ~action_name elem s
- let do_ ~mode:_ _ _ = Undoable.return ()
+
+ type js_args = unit
+
+ let do_js ~mode:_ _ _ = Undoable.return ()
+ let do_ ~mode:_ _ _ _ = Undoable.return ()
end
-module Speaker_note : S = struct
- let on = "speaker-note"
- let action_name = on
+module _ : S = Step
- type args = Brr.El.t
+module Speaker_note = struct
+ include Actions_arguments.Speaker_note
- let parse_args = Parse.parse_only_el
let sn = ref ""
- let setup elem =
- Fut.return @@ Brr.El.set_class (Jstr.v "__slipshow__speaker_note") true elem
+ let setup elem arg =
+ let elem = elem_of_id_or_self arg elem in
+ Fut.return @@ El.set_class (Jstr.v "__slipshow__speaker_note") true elem
let setup = Some setup
let setup_all = None
- let do_ ~mode:_ (_ : Universe.Window.t) (el : args) =
- let innerHTML =
- Jv.Jstr.get (Brr.El.to_jv el) "innerHTML" |> Jstr.to_string
- in
+ type js_args = El.t
+
+ let do_js ~mode:_ (_ : Universe.Window.t) elem =
+ let innerHTML = Jv.Jstr.get (El.to_jv elem) "innerHTML" |> Jstr.to_string in
let old_value = !sn in
let undo () =
Messaging.send_speaker_notes old_value;
@@ -756,31 +459,35 @@ module Speaker_note : S = struct
sn := innerHTML;
Messaging.send_speaker_notes !sn;
Undoable.return ~undo ()
+
+ let do_ ~mode _window elem (arg : args) =
+ let elem = elem_of_id_or_self arg elem in
+ do_js ~mode _window elem
end
+module _ : S = Speaker_note
+
module Play_media = struct
- let on = "play-media"
- let action_name = "play-media"
+ include Actions_arguments.Play_media
- type args = Brr.El.t list
+ type js_args = Brr.El.t list
- let parse_args = Parse.parse_only_els
- let log_error = function Ok x -> x | Error x -> Brr.Console.(error [ x ])
+ let log_error = function Ok x -> x | Error x -> Console.(error [ x ])
- let do_ ~mode _window elems =
+ let do_js ~mode _window elems =
only_if_not_counting mode @@ fun _mode ->
let is_speaker_note =
- match Brr.Window.name Brr.G.window |> Jstr.to_string with
+ match Window.name G.window |> Jstr.to_string with
| "slipshow_speaker_view" -> true
| _ -> false
in
Undoable.List.iter
(fun e ->
let open Fut.Syntax in
- let is_video = Jstr.equal (Jstr.v "video") @@ Brr.El.tag_name e in
- let is_audio = Jstr.equal (Jstr.v "audio") @@ Brr.El.tag_name e in
+ let is_video = Jstr.equal (Jstr.v "video") @@ El.tag_name e in
+ let is_audio = Jstr.equal (Jstr.v "audio") @@ El.tag_name e in
if (not is_video) && not is_audio then (
- Brr.Console.(
+ Console.(
log
[
"Action play-media only has effect on video and audio elements:";
@@ -809,7 +516,7 @@ module Play_media = struct
let* () =
let open Brr_io.Media.El in
let when_slow hurry_bomb =
- Brr.Console.(log [ "Playing" ]);
+ Console.(log [ "Playing" ]);
let fut, activate = Fut.create () in
let activate =
let did = ref false in
@@ -826,21 +533,21 @@ module Play_media = struct
activate ()
in
let _unlisten =
- let opts = Brr.Ev.listen_opts ~once:true () in
- Brr.Ev.listen ~opts Brr.Ev.ended
+ let opts = Ev.listen_opts ~once:true () in
+ Ev.listen ~opts Ev.ended
(fun _ev -> activate ())
- (e |> Brr_io.Media.El.to_el |> Brr.El.as_target)
+ (e |> Brr_io.Media.El.to_el |> El.as_target)
in
let* err = Brr_io.Media.El.play e in
match err with
| Ok () -> fut
| Error e ->
- Brr.Console.(error [ e ]);
+ Console.(error [ e ]);
activate ();
fut
in
let when_fast () =
- Brr.Console.(log [ "Just setting current time" ]);
+ Console.(log [ "Just setting current time" ]);
let duration = duration_s e in
if Float.is_nan duration then Fut.return ()
else Fut.return @@ set_current_time_s e duration
@@ -858,107 +565,29 @@ module Play_media = struct
Undoable.return ~undo ())
elems
+ let do_ ~mode _window elem args =
+ only_if_not_counting mode @@ fun _mode ->
+ let elems = elems_of_ids_or_self args elem in
+ do_js ~mode _window elems
+
let setup = None
let setup_all = None
end
-module Change_page = struct
- type change = Absolute of int | Relative of int | All | Range of int * int
-
- type arg = {
- target_elem : Brr.El.t;
- n : change list;
- original_id : string option;
- }
+module _ : S = Play_media
- type args = { original_elem : Brr.El.t; args : arg list }
+module Change_page = struct
+ include Actions_arguments.Change_page
- let on = "change-page"
- let action_name = "change-page"
let ( let+ ) x f = Result.map f x
let ( let* ) x f = Result.bind x f
let handle_error = function
| Ok x -> Some x
| Error (`Msg x) ->
- Brr.Console.(log [ x ]);
+ Console.(log [ x ]);
None
- let parse_change s =
- if String.equal "all" s then Some All
- else
- match int_of_string_opt s with
- | None -> (
- match String.split_on_char '-' s with
- | [ a; b ] -> (
- match (int_of_string_opt a, int_of_string_opt b) with
- | Some a, Some b -> Some (Range (a, b))
- | _ ->
- Brr.Console.(log [ "Could not parse parameter" ]);
- None)
- | _ ->
- Brr.Console.(log [ "Could not parse parameter" ]);
- None)
- | Some x -> (
- match s.[0] with
- | '+' | '-' -> Some (Relative x)
- | _ -> Some (Absolute x))
-
- let parse_single_action original_elem
- { Parse.p_named = ([ n_opt ] : _ Parse.output_tuple); p_pos = elem_ids } =
- let n = Option.value ~default:[ Relative 1 ] n_opt in
- let+ elem, elem_id =
- match elem_ids with
- | [] -> Ok (original_elem, None)
- | [ id ] -> (
- find_first_by_selector ("#" ^ id |> Jstr.v) |> function
- | Some x -> Ok (x, Some id)
- | None -> Error (`Msg "No elem of id found"))
- | id :: _ -> (
- Brr.Console.(log [ "Expected single id" ]);
- find_first_by_selector ("#" ^ id |> Jstr.v) |> function
- | Some x -> Ok (x, Some id)
- | None -> Error (`Msg "No elem of id found"))
- in
- { n; target_elem = elem; original_id = elem_id }
-
- let parse_n s =
- let l =
- String.split_on_char ' ' s
- |> List.filter (fun x -> not @@ String.equal "" x)
- in
- l |> List.filter_map parse_change |> Result.ok
-
- let parse_args original_elem s =
- let+ ac, actions =
- Parse.parse ~named:[ ("n", parse_n) ] ~positional:Fun.id s
- in
- let actions = ac :: actions in
- let args =
- List.filter_map
- (fun action -> parse_single_action original_elem action |> handle_error)
- actions
- in
- { args; original_elem }
-
- let args_as_string args =
- let arg_to_string { n; original_id; _ } =
- let to_string = function
- | All -> "all"
- | Relative x when x < 0 -> string_of_int x
- | Relative x -> "+" ^ string_of_int x
- | Absolute x -> string_of_int x
- | Range (x, y) -> string_of_int x ^ "-" ^ string_of_int y
- in
- let s = n |> List.map to_string |> String.concat " " in
- let n = "~n:\"" ^ s ^ "\"" in
- let original_id =
- match original_id with None -> "" | Some s -> " " ^ s
- in
- n ^ original_id
- in
- args |> List.map arg_to_string |> String.concat " ; "
-
(* Taken from OCaml 5.2 *)
let find_mapi f =
let rec aux i = function
@@ -968,29 +597,31 @@ module Change_page = struct
in
aux 0
- let do_1 ({ target_elem; n; _ } as arg) =
- let check_carousel f =
- if Brr.El.class' (Jstr.v "slipshow__carousel") target_elem then f ()
- else Undoable.return None
- in
- check_carousel @@ fun () ->
- let children = Brr.El.children ~only_els:true target_elem in
+ type js_args = { elem : El.t; change : change }
+
+ let check_carousel elem f =
+ if El.class' (Jstr.v "slipshow__carousel") elem then f ()
+ else Undoable.return None
+
+ (* TODO: better name... *)
+ let do_js' ~mode:_ _window { elem; change } =
+ check_carousel elem @@ fun () ->
+ let children = El.children ~only_els:true elem in
let current_index =
find_mapi
(fun i x ->
- if Brr.El.class' (Jstr.v "slipshow__carousel_active") x then
- Some (i, x)
+ if El.class' (Jstr.v "slipshow__carousel_active") x then Some (i, x)
else None)
children
in
let new_index =
- match (n, current_index) with
- | Range (a, _) :: _, _ -> a
- | Absolute i :: _, _ -> i - 1
- | Relative r :: _, Some (i, _) -> i + r
- | All :: _, Some (i, _) -> i + 1
+ match (change, current_index) with
+ | Range (a, _), _ -> a
+ | Absolute i, _ -> i - 1
+ | Relative r, Some (i, _) -> i + r
+ | All, Some (i, _) -> i + 1
| _ ->
- Brr.Console.(log [ "Error during carousel" ]);
+ Console.(log [ "Error during carousel" ]);
0
in
let new_index = Int.max 0 new_index in
@@ -1008,44 +639,60 @@ module Change_page = struct
active_elem
else Undoable.return ())
in
- let new_n =
+ Undoable.return (Some overflow)
+
+ let do_js ~mode _window js_args =
+ let> _ = do_js' ~mode _window js_args in
+ Undoable.return ()
+
+ (* TODO: Make it more elegant, coding-wise! *)
+ let do_1 ~mode window elem ({ target; n; _ } as arg) =
+ let target_elem = elem_of_id_or_self target elem in
+ check_carousel target_elem @@ fun () ->
+ let> new_n =
match n with
- | [] -> []
- | All :: _ as n when not overflow -> n
- | Range (a, b) :: rest when a < b -> Range (a + 1, b) :: rest
- | Range (a, b) :: rest when a = b -> rest
- | Range (a, b) :: rest (* when a > b *) -> Range (a - 1, b) :: rest
- | _ :: n -> n
+ | [] -> Undoable.return []
+ | change :: rest -> (
+ let> overflow = do_js' ~mode window { elem = target_elem; change } in
+ match overflow with
+ | None -> Undoable.return []
+ | Some overflow -> (
+ match change with
+ | All when not overflow -> Undoable.return n
+ | Range (a, b) when a < b ->
+ Undoable.return (Range (a + 1, b) :: rest)
+ | Range (a, b) when a = b -> Undoable.return rest
+ | Range (a, b) (* when a > b *) ->
+ Undoable.return (Range (a - 1, b) :: rest)
+ | _ -> Undoable.return rest))
in
Undoable.return
@@ match new_n with [] -> None | new_n -> Some { arg with n = new_n }
- let do_ ~mode:_ _window { args; original_elem } =
- let> args = Undoable.List.filter_map do_1 args in
+ let do_ ~mode _window elem args =
+ let> args = Undoable.List.filter_map (do_1 ~mode _window elem) args in
match args with
| [] -> Undoable.return ()
| args ->
let new_v = args_as_string args in
- Undoable.Browser.set_at on (Some (Jstr.v new_v)) original_elem
-
- let do_javascript_api ~mode:_ ~target_elem ~change =
- let> _ = do_1 { target_elem; n = [ change ]; original_id = None } in
- Undoable.return ()
+ Undoable.Browser.set_at on (Some (Jstr.v new_v)) elem
let setup = None
let setup_all = None
end
+module _ : S = Change_page
+
module Draw = struct
+ include Actions_arguments.Draw
+
let state = Hashtbl.create 10
- let on = "draw"
- let action_name = on
let setup elem =
match Hashtbl.find_opt state elem with
| Some _ -> Fut.return ()
| None ->
- let data = Brr.El.at (Jstr.v "x-data") elem in
+ let data = El.at (Jstr.v "x-data") elem in
(match data with
| None -> ()
| Some data -> (
@@ -1053,7 +700,7 @@ module Draw = struct
match
Drawing_state.Json.string_to_recording (Jstr.to_string data)
with
- | Error e -> Brr.Console.(log [ e ])
+ | Error e -> Console.(log [ e ])
| Ok recording ->
let replaying_state =
{ recording; time = Lwd.var 0.; is_playing = Lwd.var false }
@@ -1063,24 +710,21 @@ module Draw = struct
Fut.return ()
let setup_all () =
- Brr.El.fold_find_by_selector
+ El.fold_find_by_selector
(fun elem acc -> Fut.bind acc (fun () -> setup elem))
(Jstr.v ".slipshow-hand-drawn")
(Fut.return ())
let setup_all = Some setup_all
- let setup elems =
+ let setup el args =
+ let elems = elems_of_ids_or_self args el in
List.fold_left
(fun acc elem -> Fut.bind acc (fun () -> setup elem))
(Fut.return ()) elems
let setup = Some setup
- type args = Brr.El.t list
-
- let parse_args = Parse.parse_only_els
-
let replay ?(speedup = 1.) mode (record : Drawing_state.replaying_state) =
let fut, resolve_fut = Fut.create () in
let start_replay = Drawing_controller.Tools.now () in
@@ -1112,7 +756,7 @@ module Draw = struct
Lwd.set record.time max_time;
resolve_fut ())
else
- let _animation_frame_id = Brr.G.request_animation_frame draw_loop in
+ let _animation_frame_id = G.request_animation_frame draw_loop in
()
in
match mode with
@@ -1140,10 +784,12 @@ module Draw = struct
resolve_fut ()
(* | Counting_for_toc -> assert false (\* See "only_if_not_fast" *\) *)
in
- let _animation_frame_id = Brr.G.request_animation_frame draw_loop in
+ let _animation_frame_id = G.request_animation_frame draw_loop in
fut
- let do_ ~mode _window elems =
+ type js_args = El.t list
+
+ let do_js ~mode _window elems =
only_if_not_counting mode @@ fun _mode ->
(* let speedup = update_speedup 1. in *)
Undoable.List.iter
@@ -1160,19 +806,24 @@ module Draw = struct
in
Undoable.return ~undo ())
elems
+
+ let do_ ~mode _window el args =
+ only_if_not_counting mode @@ fun _mode ->
+ let elems = elems_of_ids_or_self args el in
+ do_js ~mode _window elems
end
+module _ : S = Draw
+
module Clear_draw = struct
- let on = "clear"
- let action_name = on
+ include Actions_arguments.Clear_draw
+
let setup = None
let setup_all = None
- type args = Brr.El.t list
+ type js_args = El.t list
- let parse_args = Parse.parse_only_els
-
- let do_ ~mode _window elems =
+ let do_js ~mode _window elems =
only_if_not_counting mode @@ fun _mode ->
Undoable.List.iter
(fun elem ->
@@ -1187,4 +838,11 @@ module Clear_draw = struct
in
Undoable.return ~undo ())
elems
+
+ let do_ ~mode _window el args =
+ only_if_not_counting mode @@ fun _mode ->
+ let elems = elems_of_ids_or_self args el in
+ do_js ~mode _window elems
end
+
+module _ : S = Clear_draw
diff --git a/src/engine/runtime/step/dune b/src/engine/runtime/step/dune
index a07d34e7..f4628541 100644
--- a/src/engine/runtime/step/dune
+++ b/src/engine/runtime/step/dune
@@ -8,4 +8,5 @@
logs
fast
drawing_state
- drawing_controller))
+ drawing_controller
+ actions_arguments))
diff --git a/src/engine/runtime/step/javascript_api.ml b/src/engine/runtime/step/javascript_api.ml
index c6184a1f..14f616b6 100644
--- a/src/engine/runtime/step/javascript_api.ml
+++ b/src/engine/runtime/step/javascript_api.ml
@@ -22,12 +22,12 @@ let one_arg conv action undos_ref =
(* let one_elem_list action = one_arg (Jv.to_list Brr.El.of_jv) action *)
let move (module X : Actions.Move) ~mode window undos_ref =
- Jv.callback ~arity:3 @@ fun elems duration margin ->
- let elem = Brr.El.of_jv elems
+ Jv.callback ~arity:3 @@ fun elem duration margin ->
+ let elem = Brr.El.of_jv elem
and duration = Jv.to_option Jv.to_float duration
and margin = Jv.to_option Jv.to_float margin in
register_undo undos_ref @@ fun () ->
- X.do_ ~mode window X.{ duration; margin; elem }
+ X.do_ ~mode window elem X.{ duration; margin; target = `Self }
let up = move (module Actions.Up)
let down = move (module Actions.Down)
@@ -40,15 +40,15 @@ let focus ~mode window undos_ref =
and duration = Jv.to_option Jv.to_float duration
and margin = Jv.to_option Jv.to_float margin in
register_undo undos_ref @@ fun () ->
- Actions.Focus.do_ ~mode window { duration; margin; elems }
+ Actions.Focus.do_js ~mode window { duration; margin; elems }
let unfocus ~mode window =
- one_arg (fun _ -> ()) (Actions.Unfocus.do_ ~mode window)
+ one_arg (fun _ -> ()) (Actions.Unfocus.do_js ~mode window)
let class_setter (module X : Actions.SetClass) ~mode window undos_ref =
Jv.callback ~arity:1 @@ fun elems ->
let elems = (Jv.to_list Brr.El.of_jv) elems in
- register_undo undos_ref @@ fun () -> X.do_ ~mode window elems
+ register_undo undos_ref @@ fun () -> X.do_js ~mode window elems
let unstatic = class_setter (module Actions.Unstatic)
let static = class_setter (module Actions.Static)
@@ -60,21 +60,23 @@ let unemph = class_setter (module Actions.Unemph)
let play_media ~mode window undos_ref =
Jv.callback ~arity:1 @@ fun elems ->
let elems = Jv.to_list Brr.El.of_jv elems in
- register_undo undos_ref @@ fun () -> Actions.Play_media.do_ ~mode window elems
+ register_undo undos_ref @@ fun () ->
+ Actions.Play_media.do_js ~mode window elems
let draw ~mode window undos_ref =
Jv.callback ~arity:1 @@ fun elems ->
let elems = Jv.to_list Brr.El.of_jv elems in
- register_undo undos_ref @@ fun () -> Actions.Draw.do_ ~mode window elems
+ register_undo undos_ref @@ fun () -> Actions.Draw.do_js ~mode window elems
let change_page ~mode _window undos_ref =
Jv.callback ~arity:2 @@ fun elem change ->
- let target_elem = Brr.El.of_jv elem in
+ let elem = Brr.El.of_jv elem in
let change = Jv.to_string change in
register_undo undos_ref @@ fun () ->
- Actions.Change_page.parse_change change
+ Actions.Change_page.parse_change (change, (0, 0))
|> Undoable.Option.iter @@ fun change ->
- Actions.Change_page.do_javascript_api ~mode ~target_elem ~change
+ let js_arg = { Actions.Change_page.change; elem } in
+ Actions.Change_page.do_js ~mode _window js_arg
let on_undo =
one_arg Fun.id @@ fun callback ->
diff --git a/src/server/client/client.ml b/src/server/client/client.ml
index f42ff447..010d8f54 100644
--- a/src/server/client/client.ml
+++ b/src/server/client/client.ml
@@ -12,6 +12,21 @@ let uri typ =
let elem = Brr.El.find_first_by_selector (Jstr.v "#iframes") |> Option.get
+let warnings =
+ Brr.El.find_first_by_selector (Jstr.v "#warnings-slipshow") |> Option.get
+
+let warnings_show =
+ Brr.El.find_first_by_selector (Jstr.v "#warnings-slipshow-show") |> Option.get
+
+let _unlistener =
+ Brr.Ev.listen Brr.Ev.click
+ (fun _ ->
+ let show_class = Jstr.v "hide-warnings" in
+ Brr.El.set_class show_class
+ (not @@ Brr.El.class' show_class warnings)
+ warnings)
+ (Brr.El.as_target warnings_show)
+
let previewer =
let initial_stage =
Brr.G.window |> Brr.Window.location |> Brr.Uri.fragment |> Jstr.to_string
@@ -30,7 +45,7 @@ let previewer =
Brr.Window.History.replace_state ~uri history
in
Previewer.create_previewer ?initial_stage ~callback ~include_speaker_view:true
- elem
+ ~errors_el:warnings elem
let recv () =
let open Lwt.Syntax in
diff --git a/src/server/dune b/src/server/dune
index ce6fa3e6..b088b4c3 100644
--- a/src/server/dune
+++ b/src/server/dune
@@ -4,4 +4,4 @@
(pps ppx_blob))
(preprocessor_deps
(file client/client.bc.js))
- (libraries lwt slipshow bos fpath irmin-watcher dream))
+ (libraries lwt slipshow bos fpath irmin-watcher dream ansi))
diff --git a/src/server/slipshow_server.ml b/src/server/slipshow_server.ml
index 00498522..98679843 100644
--- a/src/server/slipshow_server.ml
+++ b/src/server/slipshow_server.ml
@@ -105,28 +105,51 @@ let html_source =
Slipshow preview
-
-